Imported Upstream version 8.5~beta1+dfsg

2317 files changed, 169740 insertions, 103731 deletions

diff --git a/.merlin b/.merlin
new file mode 100644
index 00000000..02420c4d
--- /dev/null
+++ b/.merlin
@@ -0,0 +1,35 @@
+FLG -rectypes
+
+S config
+B config
+S lib
+B lib
+S intf
+B intf
+S kernel
+B kernel
+S kernel/byterun
+B kernel/byterun
+S library
+B library
+S pretyping
+B pretyping
+S interp
+B interp
+S proofs
+B proofs
+S tactics
+B tactics
+S printing
+B printing
+S parsing
+B parsing
+S toplevel
+B toplevel
+
+S tools
+B tools
+S tools/coqdoc
+B tools/coqdoc
+S dev
+B dev
diff --git a/CHANGES b/CHANGES
index d13a15e6..3471bc61 100644
--- a/CHANGES
+++ b/CHANGES
@@ -1,132 +1,355 @@
-Changes from V8.4pl3 to V8.4pl4
-===============================
-
-WARNING:
-The current logic of Coq is now known to be inconsistent with
-  Axiom prop_extensionality : forall A B:Prop, (A <-> B) -> A = B.
-For more details, see:
-  https://gforge.inria.fr/plugins/scmgit/cgi-bin/gitweb.cgi?p=coq/coq.git;a=blob_plain;f=test-suite/failure/subterm2.v;hb=HEAD
-or
-  https://gforge.inria.fr/plugins/scmgit/cgi-bin/gitweb.cgi?p=coq/coq.git;a=blob_plain;f=test-suite/failure/subterm3.v;hb=HEAD
-
-Kernel
-
-- Bug #3211: unsound check of elimination sort.
-- Fix guard condition for nested cofixpoints.
-- Bug #3243: Univ constraints of module subtyping were not propagated.
-
-Tactics
-
-- A new option "Set Stable Omega" ensures that repeated identical calls
-  to omega will produce identical proof terms. This option is off by default
-  for maximal compatibility, but should be pretty safe to activate.
-- The interpretation of the open_constr tactic argument was erroneously
-  firing type classes resolution in some corner cases.  This has been
-  fixed.  The tactic argument type open_constr_wTC is provided for retro
-  compatibility purposes.
-- Fixing bug #3228 (fixing precedence of ltac variables over variables in
-  env) introduces rare and justified tactic failure.
-
-Bug fixes
-
-- Solved bugs:
-  #3260, #2697, #3037, #3262, #2900, #3131, #3238, #3204, #1758, #1039,
-  #3144
-- micromega: solved an ambiguous symbol resolution.
-- Coq always uses / as separator between directories on all platforms.
-- remove trailing '\r' from file names returned by coqtop.
-- bug correction in proving inversion principles for Function.
-- ocamlbuild: minor fixes related to camlp4 and cross-compilation.
-
-Changes from V8.4pl2 to V8.4pl3
-===============================
-
-Ide_slave XML interface
-
-- 20120712, 20130419 : Invalidated protocol versions
-- From 20130419 extra datastructure : union
-   (Inl "" = <union val="in_l"><string></string></union>,
-    Inr _ = <union val="in_r">...)
-- 20130419~1 : new toplevel entry : message, not send by coptop v8.4 and not
-  handle by coqide v8.4. A message has a level and a content (of string).
-  Message levels are Debug of string, Info, Notice, Warning and Error.
-- 20130425 :
-  * new toplevel entry : feedback, once again not send by coqtop v8.4 and not
-  handle by coqide v8.4. A feedback gives the id of the sentence it provides info
-  about and a content. Feedback contents are Processed, AddedAxiom and
-  GlobRef of Util.loc * string * string * string * string
-  * <call val="interp"> must provide an attribute id of type int. It is OK in
-  coqtop v8.4 to alwais send <call val="interp" id="0">
-
-Bug fixes
-
-- Solved bugs:
-  #2230 #2837 #2846 #2987 #3003 #3001 #3013 #3023 #3025 #3036 #3118 #3169
-  #(3150, 3151, 3152, 3153)
-- Fixing a significant efficiency leak in the code of the field tactic.
-- Fix caching of local hint database in typeclasses eauto which could
-  miss some hypotheses.
-- Fix automatic solving of obligation in program, which was not trying
-  to solve obligations that had no undefined dependencies left.
-
-Changes from V8.4pl1 to V8.4pl2
-===============================
-
-Bug fixes
-
-- Solved bugs :
-  #2466 #2629 #2668 #2750 #2839 #2869 #2954 #2955 #2959 #2962 #2966 #2967
-  #2969 #2970 #2975 #2976 #2977 #2978 #2981 #2983 #2995 #3000 #3004 #3008 
-- Partially fixed bugs : #2830 #2949
-- Coqtop should now react more reliably when receiving interrupt signals:
-  all the "try...with" constructs have been protected against undue
-  handling of the Sys.Break exception.
+Changes from V8.4 to V8.5beta1
+==============================
 
-Coqide
+Logic
 
-- The Windows-specific code handling the interrupt button of Coqide
-  had to be reworked (cf. bug #2869). Now, in Win32 this button does
-  not target a specific coqtop client, but instead sends a Ctrl-C to
-  any process sharing its console with Coqide. To avoid awkward
-  effects, it is recommended to launch Coqide via its icon, its menu,
-  or in a dedicated console window.
+- Primitive projections for records allow for a compact representation
+  of projections, without parameters and avoid the behavior of defined
+  projections that can unfold to a case expression. To turn the use of
+  native projections on, use [Set Primitive Projections]. Record,
+  Class and Structure types defined while this option is set will be
+  defined with primitive projections instead of the usual encoding as
+  a case expression. For compatibility, when p is a primitive
+  projection, @p can be used to refer to the projection with explicit
+  parameters, i.e. [@p] is definitionally equal to [λ params r. r.(p)].
+  Records with primitive projections have eta-conversion, the
+  canonical form being [mkR pars (p1 t) ... (pn t)].
+
+- New universe polymorphism (see reference manual)
+- New option -type-in-type to collapse the universe hierarchy (this makes the
+  logic inconsistent).
+- The guard condition for fixpoints is now a bit stricter. Propagation of
+subterm value through pattern matching is restricted according to the return
+predicate. Restores compatibility of Coq's logic with the propositional
+extensionality axiom. May create incompatibilities in recursive programs heavily
+using dependent types.
 
-Extraction
+Vernacular commands
 
-- The option Extraction AccessOpaque is now set by default,
-  restoring compatibility of older versions of Coq (cf bug #2952).
+- A command "Variant" allows to define non-recursive variant types.
+- The command "Record foo ..." does not generate induction principles
+  (foo_rect, foo_rec, foo_ind) anymore by default (feature wish
+  #2693). The command "Variant foo ..." does not either. A flag
+  "Set/Unset Nonrecursive Elimination Schemes" allows changing this.
+  The tactic "induction" on a "Record" or a "Variant" is now actually
+  doing "destruct".
+- The "Open Scope" command can now be given also a delimiter (e.g. Z).
+- The "Definition" command now allows the "Local" modifier, allowing
+  for non-importable definitions. The same goes for "Axiom" and "Parameter".
+- Section-specific commands such as "Let" (resp. "Variable", "Hypothesis") used
+  out of a section now behave like the corresponding "Local" command, i.e.
+  "Local Definition" (resp. "Local Parameter", "Local Axiom"). (potential source
+  of rare incompatibilities).
+- The "Let" command can now define local (co)fixpoints.
+- Command "Search" has been renamed into "SearchHead". The command
+  name "Search" now behaves like former "SearchAbout". The latter name
+  is deprecated.
+- "Search" "About" "SearchHead" "SearchRewrite" and "SearchPattern"
+  now search for hypothesis (of the current goal by default) first.
+  They now also support the goal selector prefix to specify another
+  goal to search: e.g. "n:Search id". This is also true for
+  SearchAbout although it is deprecated.
+- The coq/user-contrib directory and the XDG directories are no longer
+  recursively added to the load path, so files from installed libraries
+  now need to be fully qualified for the "Require" command to find them.
+  The tools/update-require script can be used to convert a development.
+- A new Print Strategies command allows visualizing the opacity status
+  of the whole engine.
+- The "Locate" command now searches through all sorts of qualified namespaces of
+  Coq: terms, modules, tactics, etc. The old behavior of the command can be
+  retrieved using the "Locate Term" command.
+- New "Derive" command to help writing program by derivation.
+- "Undo" undoes any command, not just tactics.
+- New "Refine Instance Mode" option that allows to deactivate the generation of
+  obligations in incomplete typeclass instances, raising an error instead.
+- "Collection" command to name sets of section hypotheses.  Named collections
+  can be used in the syntax of "Proof using" to assert with section variables
+  are used in a proof.
+- The "Optimize Proof" command can be placed in the middle of a proof to
+  force the compaction the data structure used to represent the ongoing
+  proof (evar map).  This may result in a lower memory footprint and speed up
+  the execution of the following tactics.
+- "Optimize Heap" command to tell the OCaml runtime to performa a major
+  garbage collection step and heap compaction.
+
+Specification Language
+
+- Slight changes in unification error messages.
+- Added a syntax $(...)$ that allows putting tactics in terms (may
+  break user notations using "$(", fixable by inserting a space or
+  rewriting the notation).
+- Constants in pattern-matching branches now respect the same rules regarding
+  implicit arguments than in applicative position. The old behavior can be
+  recovered by the command "Set Asymmetric Patterns". (possible source of
+  incompatibilities)
+- Type inference algorithm now granting opacity of constants. This might also
+  affect behavior of tactics (source of incompatibilities, solvable by
+  re-declaring transparent constants which were set opaque).
+- Existential variables are now referred to by an identifier and the
+  relevant part of their instance is displayed by default. They can be
+  reparsed. The naming policy is yet unstable and subject to changes
+  in future releases.
 
-Changes from V8.4 to V8.4pl1
-============================
+Tactics
 
-Bug fixes
+- New tactic engine allowing dependent subgoals, fully backtracking
+  (also known as multiple success) tactics, as well as tactics which
+  can consider multiple goals together. In the new tactic engine,
+  instantiation information of existential variables is always
+  propagated to tactics, removing the need to manually use the
+  "instantiate" tactics to mark propagation points.
+  * New tactical (a+b) insert a backtracking point. When (a+b);c fails
+    during the execution of c, it can backtrack and try b instead of a.
+  * New tactical (once a) removes all the backtracking point from a
+    (i.e. it selects the first success of a).
+  * Tactic "constructor" is now fully backtracking, thus deprecating
+    the need of the undocumented "constructor <tac>" syntax which is
+    now equivalent to "once (constructor; tac)". (potential source of
+    rare incompatibilities).
+  * New "multimatch" variant of "match" tactic which backtracks to
+    new branches in case of a later failure. The "match" tactic is
+    equivalent to "once multimatch".
+  * New selector all: to qualify a tactic allows applying a tactic to
+    all the focused goal, instead of just the first one as is the
+    default.
+  * A corresponding new option Set Default Goal Selector "all" makes
+    the tactics in scripts be applied to all the focused goal by default
+  * New selector par: to qualify a tactic allows applying a (terminating)
+    tactic to all the focused goal in parallel.  The number of worker can
+    be selected with -async-proofs-tac-j and also limited using the
+    coqworkmgr utility.
+  * New tactics "revgoals", "cycle" and "swap" to reorder goals.
+  * The semantics of recursive tactics (introduced with Ltac t :=
+    ... or let rec t := ... in ...) changes slightly as t is now
+    applied to every goal not each goal independently, in particular
+    it may be applied when no goal are left. This may cause tactics
+    such as let rec t := constructor;t to loop indefinitely. The
+    simple fix is to rewrite the recursive calls as follows: let rec t
+    := constructor;[t..] which recovers the earlier behavior (source
+    of rare incompatibilities).
+  * New tactic language feature "numgoals" to count number of goals.
+    Accompanied by "guard" tactic which fails if a Boolean test does
+    not pass.
+  * New tactical "[> ... ]" to apply tactics to individual goals.
+  * New tactic "gfail" which works like "fail" except it will also
+    fail if every goal has been solved.
+  * The refine tactic is changed not to use an ad hoc typing algorithm
+    to generate subgoals. It also uses the dependent subgoal feature
+    to generate goals to materialize every existential variable which
+    is introduced by the refinement (source of incompatibilities).
+  * A tactic shelve is introduced to manage the subgoals which may be
+    solved by unification: shelve removes every goal it is applied to
+    from focus. These goals can later be called back into focus by the
+    Unshelve command.
+  * A variant shelve_unifiable only removes those goals which appear
+    as existential variables in other goals. To emulate the old
+    refine, use (refine c;shelve_unifiable). This can still cause
+    incompatibilities in rare occasions.
+  * New "give_up" tactic to skip over a goal without admitting it.
+- Matching using "lazymatch" was fundamentally modified. It now behaves
+  like "match" (immediate execution of the matching branch) but without
+  the backtracking mechanism in case of failure.
+- New "tryif t then u else v" tactical which executes "u" in case of success
+  of "t" and "v" in case of failure.
+- New conversion tactic "native_compute": evaluates the goal (or an hypothesis)
+  with a call-by-value strategy, using the OCaml native compiler. Useful on
+  very intensive computations.
+- New "cbn" tactic, a well-behaved simpl.
+- Repeated identical calls to omega should now produce identical proof terms.
+- Tactics btauto, a reflexive Boolean tautology solver.
+- Tactic "tauto" was exceptionally able to destruct other connectives
+  than the binary connectives "and", "or", "prod", "sum", "iff". This
+  non-uniform behavior has been fixed (bug #2680) and tauto is
+  slightly weaker (possible source of incompatibilities). On the
+  opposite side, new tactic "dtauto" is able to destruct any
+  record-like inductive types, superseding the old version of "tauto".
+- Similarly, "intuition" has been made more uniform and, where it now
+  fails, "dintuition" can be used. (possible source of incompatibilities)
+- Tactic notations can now be defined locally to a module (use "Local" prefix).
+- Tactic "red" now reduces head beta-iota redexes (potential source of
+  rare incompatibilities).
+- Tactic "hnf" now reduces inner beta-iota redexes
+  (potential source of rare incompatibilities).
+- Tactic "intro H" now reduces beta-iota redexes if these hide a product
+  (potential source of rare incompatibilities).
+- In Ltac matching on patterns of the form "_ pat1 ... patn" now
+  behaves like if matching on "?X pat1 ... patn", i.e. accepting "_"
+  to be instantiated by an applicative term (experimental at this
+  stage, potential source of incompatibilities).
+- In Ltac matching on goal, types of hypotheses are now interpreted in
+  the %type scope (possible source of incompatibilities).
+- "change ... in ..." and "simpl ... in ..." now properly consider nested
+  occurrences (possible source of incompatibilities since this alters
+  the numbering of occurrences), but do not support nested occurrences.
+- Tactics simpl, vm_compute and native_compute can be given a notation string
+  to a constant as argument.
+- When given a reference as argument, simpl, vm_compute and
+  native_compute now strictly interpret it as the head of a pattern
+  starting with this reference.
+- The "change p with c" tactic semantics changed, now type-checking 
+  "c" at each matching occurrence "t" of the pattern "p", and 
+  converting "t" with "c".
+- Now "appcontext" and "context" behave the same. The old buggy behavior of
+  "context" can be retrieved at parse time by setting the
+  "Tactic Compat Context" flag (possible source of incompatibilities).
+- New introduction pattern p/c which applies lemma c on the fly on the
+  hypothesis under consideration before continuing with introduction pattern p.
+- New introduction pattern [= x1 .. xn] applies "injection as [x1 .. xn]"
+  on the fly if injection is applicable to the hypothesis under consideration
+  (idea borrowed from Georges Gonthier). Introduction pattern [=] applies
+  "discriminate" if a discriminable equality.
+- Tactic "injection c as ipats" now clears c if c refers to an
+  hypothesis and moves the resulting equations in the hypotheses
+  independently of the number of ipats, which has itself to be less
+  than the number of new hypotheses (possible source of incompatibilities;
+  former behavior obtainable by "Unset Injection L2R Pattern Order").
+- Tactic "injection" now automatically simplifies subgoals
+  "existT n p = existT n p'" into "p = p'" when "n" is in an inductive type for
+  which a decidable equality scheme has been generated with "Scheme Equality"
+  (possible source of incompatibilities).
+- New tactic "rewrite_strat" for generalized rewriting with user-defined
+  strategies, subsuming autorewrite.
+- Injection can now also deduce equality of arguments of sort Prop, by using
+  the option "Set Injection On Proofs" (disabled by default). Also improved the
+  error messages.
+- Tactic "subst id" now supports id occurring in dependent local definitions.
+- Bugs fixed about intro-pattern "*" might lead to some rare incompatibilities.
+- New tactical "time" to display time spent executing its argument.
+- Tactics referring or using a constant dependent in a section variable which
+  has been cleared or renamed in the current goal context now fail
+  (possible source of incompatibilities solvable by avoiding clearing
+  the relevant hypotheses).
+- New construct "uconstr:c" and "type_term c" to build untyped terms.
+- Binders in terms defined in Ltac (either "constr" or "uconstr") can
+  now take their names from identifier defined in Ltac. As a
+  consequence, a name cannot be used in a binder (constr:(fun x =>
+  ...)) if an Ltac variable of that name already exists and does not
+  contain an identifier. Source of occasional incompatibilities.
+- The "refine" tactic now accepts untyped terms built with "uconstr"
+  so that terms with holes can be constructed piecewise in Ltac.
+- New bullets --, ++, **, ---, +++, ***, ... made available.
+- More informative messages when wrong bullet is used.
+- bullet suggestion when a subgoal is solved.
+- New tactic "enough", symmetric to "assert", but with subgoals
+  swapped, as a more friendly replacement of "cut".
+- In destruct/induction, experimental modifier "!" prefixing the
+  hypothesis name to tell not erasing the hypothesis.
+- Bug fixes in "inversion as" may occasionally lead to incompatibilities.
+- Behavior of introduction patterns -> and <- made more uniform
+  (hypothesis is cleared, rewrite in hypotheses and conclusion and
+  erasing the variable when rewriting a variable).
+- Tactics from plugins are now active only when the corresponding
+  module is imported (source of incompatibilities, solvable by adding
+  an "Import", like e.g. "Import Omega").
+- Semantics of destruct/induction has been made more regular in some
+  edge cases, possibly leading to incompatibilities:
+  - new goals are now opened when the term does not match a subterm of
+    the goal and has unresolved holes, while in 8.4 these holes were
+    turned into existential variables
+  - when no "at" option is given, the historical semantics which
+    selects all subterms syntactically identical to the first subterm
+    matching the given pattern is used
+  - non-dependent destruct/induction on an hypothesis with premises in
+    an inductive type with indices is fixed
+  - residual local definitions are now correctly removed.
+- The rename tactic may now replace variables in parallel.
 
-- Solved bugs :
-  #2851 #2863 #2865 #2893 #2895 #2892 #2905 #2906 #2907 #2917 #2921
-  #2930 #2941 #2878
-- Partially fixed bug : #2904
-- Various fixes concerning coq_makefile
+Program
 
-Optimizations
+- "Solve Obligations using" changed to "Solve Obligations with",
+  consistent with "Proof with".
+- Program Lemma, Definition now respect automatic introduction.
+- Add/document "Set Hide Obligations" (to hide obligations in the final
+  term inside an implicit argument) and "Set Shrink Obligations" (to
+  minimize dependencies of obligations defined by tactics).
 
-- "Union by rank" optimization for universes contributed by J.H. Jourdan
-  and G. Sherrer (see union-find-and-coq-universes on gagallium blog).
+Notations
 
-Libraries
+- The syntax "x -> y" is now declared at level 99. In particular, it has
+  now a lower priority than "<->": "A -> B <-> C" is now "A -> (B <-> C)"
+  (possible source of incompatibilities)
+- Notations accept term-providing tactics using the $(...)$ syntax.
+- "Bind Scope" can no longer bind "Funclass" and "Sortclass".
+- A notation can be given a (compat "8.x") annotation, making
+  it behave like a (only parsing), but flags may active warning
+  or error when this notation is used.
+- More systematic insertion of spaces as a default for printing
+  notations ("format" still available to override the default).
+- In notations, a level modifier referring to a non-existent variable is
+  now considered an error rather than silently ignored.
 
-- Internal organisation of some modular libraries have slightly changed
-  due to bug #2904 (GenericMinMax, OrdersTac)
-- No more constant "int" in ZArith/Int.v to avoid name clash with OCaml
-  (cf bug #2878).
+Tools
 
-Coqide
+- Option -I now only adds directories to the ml path. To add to both
+  the load path and the ml path, use -I -as.
+- Option -Q behaves as -I -as and -R, except that the logical path of
+  any loaded file has to be fully qualified.
+- Option -R no longer adds recursively to the ml path; only the root
+  directory is added. (Behavior with respect to the load path is
+  unchanged.)
+- Option -nois prevents coq/theories and coq/plugins to be recursively
+  added to the load path. (Same behavior as with coq/user-contrib.)
+- coqdep accepts a -dumpgraph option generating a dot file.
+- Makefiles generated through coq_makefile have three new targets "quick"
+  "checkproof" and "vio2vo", allowing respectively to asynchronously compile
+  the files without playing the proof scripts, asynchronously checking
+  that the quickly generated proofs are correct and generating the object
+  files from the quickly generated proofs.
+- The XML plugin was discontinued and removed from the source.
+- A new utility called coqworkmgr can be used to limit the number of
+  concurrent workers started by independent processes, like make and CoqIDE.
+  This is of interest for users of the par: goal selector.
+
+Interfaces
+
+- CoqIDE supports asynchronous edition of the document, ongoing tasks and
+  errors are reported in the bottom right window.  The number of workers
+  taking care of processing proofs can be selected with -async-proofs-j.
+- CoqIDE highlight in yellow "unsafe" commands such as axiom
+  declarations, and tactics like "admit".
+- CoqIDE supports Proof General like key bindings;
+  to activate the PG mode go to Edit -> Preferences -> Editor.
+  For the documentation see Help -> Help for PG mode.
+- CoqIDE automatically retracts the locked area when one edits the
+  locked text.
+- CoqIDE search and replace got regular expressions power.  See the
+  documentation of OCaml's Str module for the supported syntax.
+- Many CoqIDE windows, including the query one, are now detachable to
+  improve usability on multi screen work stations.
+
+- Coqtop outputs highlighted syntax. Colors can be configured thanks
+  to the COQ_COLORS environment variable, and their current state can
+  be displayed with the -list-tags command line option.
+
+- Third party user interfaces can install their main loop in $COQLIB/toploop
+  and call coqtop with the -toploop flag to select it.
+
+Internal Infrastructure
+
+- Many reorganizations in the ocaml source files. For instance,
+  many internal a.s.t. of Coq are now placed in mli files in
+  a new directory intf/, for instance constrexpr.mli or glob_term.mli.
+  More details in dev/doc/changes.
+- The file states/initial.coq does not exist anymore. Instead, coqtop
+  initially does a "Require" of Prelude.vo (or nothing when given
+  the options -noinit or -nois).
+- The format of vo files has slightly changed: cf final comments in
+  checker/cic.mli
+- The build system does not produce anymore programs named coqtop.opt
+  and a symbolic link to coqtop. Instead, coqtop is now directly
+  an executable compiled with the best OCaml compiler available.
+  The bytecode program coqtop.byte is still produced. Same for other
+  utilities.
+- Some options of the ./configure script slightly changed:
+  * The -coqrunbyteflags and its blank-separated argument is replaced
+    by option -vmbyteflags which expects a comma-separated argument.
+  * The -coqtoolsbyteflags option is discontinued, see -no-custom instead.
 
-- Improved shutdown of coqtop processes spawned by coqide
-  (in particular added a missing close_on_exec primitive before forking).
-- On windows, launching coqide with the -debug option now produces
-  a log file in the user's temporary directory. The location of this
-  log file is displayed in the "About" message.
+Miscellaneous
 
+- ML plugins now require a "DECLARE PLUGIN \"foo\"" statement. The "foo" name
+  must be exactly the name of the ML module that will be loaded through a
+  "Declare ML \"foo\"" command.
 
 Changes from V8.4beta2 to V8.4
 ==============================
@@ -164,6 +387,9 @@ Libraries
 - Reals: changed definition of PI, no more axiom about sin(PI/2).
 - SetoidPermutation: a notion of permutation for lists modulo a setoid equality.
 - BigN: fixed the ocaml code doing the parsing/printing of big numbers.
+- List: a couple of lemmas added especially about no-duplication, partitions.
+- Init: Removal of the coercions between variants of sigma-types and
+  subset types (possible source of incompatibility).
 
 Changes from V8.4beta to V8.4beta2
 ==================================
@@ -248,7 +474,7 @@ Tactics
   Proof General no older than mid-July 2011 is currently required.
 - Support for tactical "info" is suspended.
 - Support for command "Show Script" is suspended.
-- New tactics constr_eq, is_evar and has_evar for use in Ltac.
+- New tactics constr_eq, is_evar and has_evar for use in Ltac (DOC TODO).
 - Removed the two-argument variant of "decide equality".
 - New experimental tactical "timeout <n> <tac>". Since <n> is a time
   in second for the moment, this feature should rather be avoided
@@ -312,7 +538,7 @@ Vernacular commands
 - New command "Show Goal ident" to display the statement of a goal, even
   a closed one (available from Proof General).
 - Command "Proof" accept a new modifier "using" to force generalization
-  over a given list of section variables at section ending.
+  over a given list of section variables at section ending (DOC TODO).
 - New command "Arguments" generalizing "Implicit Arguments" and
   "Arguments Scope" and that also allows to rename the parameters of a
   definition and to tune the behavior of the tactic "simpl".
@@ -329,7 +555,7 @@ Module System
   are lower or equal than XX will be inlined.
   The level of a parameter can be fixed by "Parameter Inline(30) foo".
   When levels aren't given, the default value is 100. One can also use
-  the flag "Set Inline Level ..." to set a level.
+  the flag "Set Inline Level ..." to set a level (DOC TODO).
 - Print Assumptions should now handle correctly opaque modules (#2168).
 - Print Module (Type) now tries to print more details, such as types and
   bodies of the module elements. Note that Print Module Type could be
@@ -416,9 +642,10 @@ Extraction
 - The pretty-printer for Haskell now produces layout-independant code
 - A new command "Separate Extraction cst1 cst2 ..." that mixes a
   minimal extracted environment a la "Recursive Extraction" and the
-  production of several files (one per coq source) a la "Extraction Library".
+  production of several files (one per coq source) a la "Extraction Library"
+  (DOC TODO).
 - New option "Set/Unset Extraction KeepSingleton" for preventing the
-  extraction to optimize singleton container types.
+  extraction to optimize singleton container types (DOC TODO).
 - The extraction now identifies and properly rejects a particular case of
   universe polymorphism it cannot handle yet (the pair (I,I) being Prop).
 - Support of anonymous fields in record (#2555).
@@ -430,7 +657,8 @@ CoqIDE
   (cf button "Restart Coq", ex-"Go to Start"). For allowing such
   interrupts, the Windows version of coqide now requires Windows >= XP
   SP1.
-- The communication between CoqIDE and Coqtop is now done via a dialect of XML.
+- The communication between CoqIDE and Coqtop is now done via a dialect
+  of XML (DOC TODO).
 - The backtrack engine of CoqIDE has been reworked, it now uses the
   "Backtrack" command similarly to Proof General.
 - The Coqide parsing of sentences has be reworked and now supports
@@ -538,6 +766,9 @@ Other tactics
   clears (resp. reverts) H and all the hypotheses that depend on H.
 - Ltac's pattern-matching now supports matching metavariables that
   depend on variables bound upwards in the pattern.
+- New experimental option "Set Standard Proposition Elimination Names"
+  so that case analysis or induction on schemes in Type containing
+  propositions now produces "H"-based names.
 
 Tactic definitions
 
@@ -2536,5 +2767,3 @@ New user contributions
 
 - Correctness proof of Stalmarck tautology checker algorithm
   [Stalmarck] (Laurent Théry, Pierre Letouzey, Sophia-Antipolis)
-
- LocalWords:  recommended
diff --git a/COMPATIBILITY b/COMPATIBILITY
index 41474202..2ce29346 100644
--- a/COMPATIBILITY
+++ b/COMPATIBILITY
@@ -1,3 +1,31 @@
+Potential sources of incompatibilities between Coq V8.4 and V8.5
+----------------------------------------------------------------
+
+(see also file CHANGES)
+
+Universe Polymorphism.
+
+- Refinement, unification and tactics are now aware of universes,
+  resulting in more localized errors. Universe inconsistencies 
+  should no more get raised at Qed time but during the proof.
+  Unification *always* produces well-typed substitutions, hence
+  some rare cases of unifications that succeeded while producing
+  ill-typed terms before will now fail.
+  
+- The [change p with c] tactic semantics changed, now typechecking 
+  [c] at each matching occurrence [t] of the pattern [p], and 
+  converting [t] with [c].
+  
+- Template polymorphic inductive types: the partial application 
+  of a template polymorphic type (e.g. list) is not polymorphic.
+  An explicit parameter application (e.g [fun A => list A]) or
+  [apply (list _)] will result in a polymorphic instance.
+
+- The type inference algorithm now takes opacity of constants into
+  account. This may have effects on tactics using type inference
+  (e.g. induction). Extra "Transparent" might have to be added to
+  revert opacity of constants.
+
 Potential sources of incompatibilities between Coq V8.3 and V8.4
 ----------------------------------------------------------------
 
@@ -49,3 +77,16 @@ of the following changes:
 
   - The command "Load" is now atomic for backtracking (use "Unset
     Atomic Load" for compatibility).
+
+
+Incompatibilities beyond 8.4...
+
+- Syntax: "x -> y" has now lower priority than "<->" "A -> B <-> C" is
+  now "A -> (B <-> C)"
+
+- Tactics: tauto and intuition no longer accidentally destruct binary
+  connectives or records other than and, or, prod, sum, iff. In most
+  of cases, dtauto or dintuition, though stronger than 8.3 tauto and
+  8.3 intuition will provide compatibility.
+
+- "Solve Obligations using" is now "Solve Obligations with".
diff --git a/COPYRIGHT b/COPYRIGHT
index 3aa6aae9..006ce18f 100644
--- a/COPYRIGHT
+++ b/COPYRIGHT
@@ -1,13 +1,13 @@
                      The Coq proof assistant
 
-Copyright 1999-2012 The Coq development team, INRIA, CNRS, University
+Copyright 1999-2015 The Coq development team, INRIA, CNRS, University
 Paris Sud, University Paris 7, Ecole Polytechnique.
 
 This product includes also software developed by
   Pierre Crégut, France Telecom R & D (plugins/omega and plugins/romega)
   Pierre Courtieu and Julien Forest, CNAM (plugins/funind)
   Claudio Sacerdoti Coen, HELM, University of Bologna, (plugins/xml)
-  Pierre Corbineau, Radbout University, Nijmegen (declarative mode)
+  Pierre Corbineau, Radboud University, Nijmegen (declarative mode)
   John Harrison, University of Cambridge (csdp wrapper)
 
 The file CREDITS contains a list of contributors.
diff --git a/CREDITS b/CREDITS
index 543cb3f3..ace4648d 100644
--- a/CREDITS
+++ b/CREDITS
@@ -1,8 +1,7 @@
-The "Coq proof assistant" was jointly developed by 
-	
+The "Coq proof assistant" was jointly developed by
 - INRIA Formel, Coq, LogiCal, ProVal, TypiCal, Marelle, pi.r2 projects
   (starting 1985),
-- Laboratoire de l'Informatique du Parallelisme (LIP) 
+- Laboratoire de l'Informatique du Parallelisme (LIP)
   associated to CNRS and ENS Lyon (Sep. 1989 to Aug. 1997),
 - Laboratoire de Recherche en Informatique (LRI)
   associated to CNRS and university Paris Sud (since Sep. 1997),
@@ -12,139 +11,129 @@ The "Coq proof assistant" was jointly developed by
 
 All files of the "Coq proof assistant" in directories or sub-directories of
 
-  config dev ide interp kernel lib library parsing pretyping proofs
+  config dev ide interp intf kernel lib library parsing pretyping proofs
   scripts states tactics test-suite theories tools toplevel
 
-are distributed under the terms of the GNU Lesser General Public License 
+are distributed under the terms of the GNU Lesser General Public License
 Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2010,
-The Coq development team, CNRS, INRIA and Université Paris Sud.
+The Coq development team, CNRS, INRIA and Université Paris Sud.
 
 Files from the directory doc are distributed as indicated in file doc/LICENCE.
 
-The following directories contain independent contributions supported 
+The following directories contain independent contributions supported
 by the Coq development team. All of them are released under the terms of
 the GNU Lesser General Public License Version 2.1.
 
 plugins/cc
   developed by Pierre Corbineau (ENS Cachan, 2001, LRI, 2001-2005, Radboud
-  University at Nijmegen, 2005-2008)
-plugins/correctness
-  developed by Jean-Christophe Filliâtre (LRI, 1999-2001)
-plugins/dp
-  developed by Nicolas Ayache (LRI, 2005-2006) and Jean-Christophe Filliâtre
-  (LRI, 2005-2008)
+  University at Nijmegen, 2005-2008, Grenoble 1, 2010-2014)
+plugins/decl_mode
+  developed by Pierre Corbineau (Radboud University at Nijmegen, 2005-2008,
+  Grenoble 1, 2009-2011)
 plugins/extraction
   developed by Pierre Letouzey (LRI, 2000-2004, PPS, 2005-now)
-plugins/field
-  developed by David Delahaye and Micaela Mayero (INRIA-LogiCal, 2001)
-plugins/firstorder 
+plugins/firstorder
   developed by Pierre Corbineau (LRI, 2003-2008)
 plugins/fourier
-  developed by Loïc Pottier (INRIA-Lemme, 2001)
+  developed by Loïc Pottier (INRIA-Lemme, 2001)
 plugins/funind
   developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2004-2008),
-  Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008) 
+  Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008)
   and Yves Bertot (INRIA-Marelle, 2005-2006)
 plugins/omega
-  developed by Pierre Crégut (France Telecom R&D, 1996)
+  developed by Pierre Crégut (France Telecom R&D, 1996)
 plugins/nsatz
-  developed by Loïc Pottier (INRIA-Marelle, 2009)
-plugins/ring
-  developed by Samuel Boutin (INRIA-Coq, 1996) and Patrick 
-  Loiseleur (LRI, 1997-1999)
+  developed by Loïc Pottier (INRIA-Marelle, 2009-2011)
+plugins/quote
+  developed by Patrick Loiseleur (LRI, 1997-1999)
 plugins/romega
-  developed by Pierre Crégut (France Telecom R&D, 2001-2004)
+  developed by Pierre Crégut (France Telecom R&D, 2001-2004)
 plugins/rtauto
   developed by Pierre Corbineau (LRI, 2005)
 plugins/setoid_ring
-  developed by Benjamin Grégoire (INRIA-Everest, 2005-2006), 
-  Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) 
+  developed by Benjamin Grégoire (INRIA-Everest, 2005-2006),
+  Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006)
   and Bruno Barras (INRIA LogiCal, 2005-2006),
 plugins/subtac
   developed by Matthieu Sozeau (LRI, 2005-2008)
-plugins/xml
-  developed by Claudio Sacerdoti (Univ. Bologna, 2000-2005) 
-  as part of the HELM and MoWGLI projects; extension by Cezary Kaliszyk as
-  part of the ProofWeb project (Radbout University at Nijmegen, 2008)
 plugins/micromega
-  developed by Frédéric Besson (IRISA/INRIA, 2006-2008), with some 
-  extensions by Evgeny Makarov (INRIA, 2007); sum-of-squares solver and 
+  developed by Frédéric Besson (IRISA/INRIA, 2006-2008), with some
+  extensions by Evgeny Makarov (INRIA, 2007); sum-of-squares solver and
   interface to the csdp solver uses code from John Harrison (University
   of Cambridge, 1998)
-parsing/search.ml
-  mainly developed by Yves Bertot (INRIA-Lemme, 2000-2004)
 theories/ZArith
-  started by Pierre Crégut (France Telecom R&D, 1996)
+  started by Pierre Crégut (France Telecom R&D, 1996)
 theories/Strings
-  developed by Laurent Théry (INRIA-Lemme, 2003)
+  developed by Laurent Théry (INRIA-Lemme, 2003)
 theories/Numbers/Cyclic
-  developed by Benjamin Grégoire (INRIA-Everest, 2007), Laurent Théry (INRIA-Marelle, 2007-2008), Arnaud Spiwack (INRIA-LogiCal, 2007) and Pierre Letouzey (PPS, 2008)
+  developed by Benjamin Grégoire (INRIA-Everest, 2007),
+  Laurent Théry (INRIA-Marelle, 2007-2008),
+  Arnaud Spiwack (INRIA-LogiCal, 2007) and Pierre Letouzey (PPS, 2008)
 ide/utils
-  some files come from Maxence Guesdon's Cameleon tool 
+  some files come from Maxence Guesdon's Cameleon tool
 
-Many discussions within the INRIA teams and labs taking part to the
-development influenced the design of Coq especially with
+The development of Coq significantly benefited from feedback,
+suggestions or short contributions from the following non exhaustive
+list of persons and groups:
 
-  C. Auger, Y. Bertot, F. Blanqui, J. Courant, P. Courtieu, J. Duprat,
-  S. Glondu, J. Goubault, J.-P. Jouannaud, S. Lescuyer, A. Mahboubi,
-  C. Marché, A. Miquel, B. Monate, L. Pottier, Y. Régis-Gianas,
-  P.-Y. Strub, L. Théry, B. Werner
-
-The development of Coq also significantly benefited from feedback,
-suggestions or short contributions from:
-
-  C. Alvarado, P. Crégut, J.-F. Monin (France Telecom R&D),
-  P. Castéran (University Bordeaux 1),
+  C. Alvarado, C. Auger, F. Blanqui, P. Castéran, C. Cohen,
+  J. Courant, J. Duprat, F. Garillot, G. Gonthier, J. Goubault,
+  J.-P. Jouannaud, S. Lescuyer, A. Miquel, J.-F. Monin, P.-Y. Strub
   the Foundations Group (Radboud University, Nijmegen, The Netherlands),
-  Laboratoire J.-A. Dieudonné (University of Nice-Sophia Antipolis),
-  F. Garillot, G. Gonthier (INRIA-MSR joint lab),
-  INRIA-Gallium project, 
-  the CS dept at Yale, the CIS dept at U. Penn, 
-  the CSE dept at Harvard, the CS dept at Princeton
+  Laboratoire J.-A. Dieudonné (University of Nice-Sophia Antipolis),
+  INRIA-Gallium project,
+  the CS dept at Yale, the CIS dept at U. Penn,
+  the CSE dept at Harvard, the CS dept at Princeton, the CS dept at MIT
+  as well as a lot of users on coq-club, coqdev, coq-bugs
 
-The following people have contributed to the development of different versions 
+The following people have contributed to the development of different versions
 of the Coq Proof assistant during the indicated time:
 
   Bruno Barras (INRIA, 1995-now)
+  Yves Bertot (INRIA, 2000-now)
   Pierre Boutillier (INRIA-PPS, 2010-now)
+  Xavier Clerc (INRIA, 2012-2014)
   Jacek Chrzaszcz (LRI, 1998-2003)
   Thierry Coquand (INRIA, 1985-1989)
-  Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now)
+  Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-2011)
   Cristina Cornes (INRIA, 1993-1996)
   Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996)
   David Delahaye (INRIA, 1997-2002)
+  Maxime Dénès (INRIA, 2013-now)
   Daniel de Rauglaudre (INRIA, 1996-1998)
   Olivier Desmettre (INRIA, 2001-2003)
   Gilles Dowek (INRIA, 1991-1994)
   Amy Felty (INRIA, 1993)
-  Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now)
-  Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
-  Stéphane Glondu (INRIA-PPS, 2007-now)
-  Benjamin Grégoire (INRIA, 2003-now)
+  Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-2008)
+  Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
+  Stéphane Glondu (INRIA-PPS, 2007-2013)
+  Benjamin Grégoire (INRIA, 2003-2011)
   Hugo Herbelin (INRIA, 1996-now)
-  Gérard Huet (INRIA, 1985-1997)
+  Sébastien Hinderer (INRIA, 2014)
+  Gérard Huet (INRIA, 1985-1997)
   Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now)
   Patrick Loiseleur (Paris Sud, 1997-1999)
   Evgeny Makarov (INRIA, 2007)
   Pascal Manoury (INRIA, 1993)
   Micaela Mayero (INRIA, 1997-2002)
-  Claude Marché (INRIA 2003-2004 & LRI, 2004)
+  Claude Marché (INRIA, 2003-2004 & LRI, 2004)
+  Guillaume Melquiond (INRIA, 2009-now)
   Benjamin Monate (LRI, 2003)
-  César Muñoz (INRIA, 1994-1995)
+  César Muñoz (INRIA, 1994-1995)
   Chetan Murthy (INRIA, 1992-1994)
-  Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now)
+  Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-2011)
   Jean-Marc Notin (CNRS, 2006-now)
   Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
-  Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, 
-                            LRI, 1997-now)
-  Pierre-Marie Pédrot (INRIA-PPS, 2011-now)
-  Matthias Puech (INRIA-Bologna, 2008-now)
-  Yann Régis-Gianas (INRIA-PPS, 2009-now)
-  Clément Renard (INRIA, 2001-2004)
+  Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997,
+                            LRI, 1997-2006)
+  Pierre-Marie Pédrot (INRIA-PPS, 2011-now)
+  Matthias Puech (INRIA-Bologna, 2008-2011)
+  Yann Régis-Gianas (INRIA-PPS, 2009-now)
+  Clément Renard (INRIA, 2001-2004)
   Claudio Sacerdoti Coen (INRIA, 2004-2005)
-  Amokrane Saïbi (INRIA, 1993-1998)
+  Amokrane Saïbi (INRIA, 1993-1998)
   Vincent Siles (INRIA, 2007)
-  Élie Soubiran (INRIA, 2007-now)
+  Élie Soubiran (INRIA, 2007-2010)
   Matthieu Sozeau (INRIA, 2005-now)
   Arnaud Spiwack (INRIA, 2006-now)
   Enrico Tassi (INRIA, 2011-now)
@@ -156,9 +145,9 @@ INRIA refers to:
 CNRS refers to:
   Centre National de la Recherche Scientifique
 LRI refers to: Laboratoire de Recherche en Informatique, UMR 8623
-  CNRS and Université Paris-Sud
+  CNRS and Université Paris-Sud
 ENS Lyon refers to:
-  Ecole Normale Supérieure de Lyon
-PPS refers to: Laboratoire Preuve, Programmation, Système, UMR 7126,
-  CNRS and Université Paris 7
+  Ecole Normale Supérieure de Lyon
+PPS refers to: Laboratoire Preuve, Programmation, Système, UMR 7126,
+  CNRS and Université Paris 7
 ****************************************************************************
diff --git a/INSTALL b/INSTALL
index 15f1b90a..2b387b01 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,24 +1,21 @@
 
-            INSTALLATION PROCEDURES FOR THE COQ V8.4 SYSTEM
+            INSTALLATION PROCEDURES FOR THE COQ V8.5 SYSTEM
             -----------------------------------------------
 
 
 WHAT DO YOU NEED ?
 ==================
 
-   Coq is designed to work on computers equipped with a POSIX (Unix or
-   a clone) operating system. It also works under Microsoft Windows
-   (see INSTALL.win); for a precompiled MacOS X package, see
-   INSTALL.macosx.
+   Coq is designed to work on computers equipped with a POSIX (Unix or a
+   clone) operating system. It also works under Microsoft Windows (see
+   INSTALL.win); for a MacOS X bundle application, see INSTALL.macosx.
 
-   Coq is known to be actively used under GNU/Linux (i386, amd64 and
-   ppc) and FreeBSD. Automated tests are run under many, many
-   different architectures under GNU/Linux.
+   Coq is known to be actively used under GNU/Linux (i386 and amd64) and
+   FreeBSD. Automated tests are run under many, many different architectures
+   under GNU/Linux.
 
-   Naturally, Coq will run faster on an architecture where OCaml can
-   compile to native code, rather than only bytecode. At time of
-   writing, that is IA32, PowerPC, AMD64, Alpha, Sparc, Mips, IA64,
-   HPPA and StrongArm. See
+   Naturally, Coq will run faster on an architecture where OCaml can compile
+   to native code, rather than only bytecode.  See
    http://caml.inria.fr/ocaml/portability.en.html for details.
 
 
@@ -27,49 +24,36 @@ WHAT DO YOU NEED ?
    version suits you, follow the usual procedure for your OS to
    install it. E.g.:
 
-   - Debian GNU/Linux (or Debian GNU/k*BSD or ...):
+   - Debian GNU/Linux derivatives (or Debian GNU/k*BSD or ...):
 
      aptitude install coq
 
-   - Gentoo GNU/Linux: 
+   - Gentoo GNU/Linux:
 
      emerge sci-mathematics/coq
 
-   - Mandriva GNU/Linux:
+   - Fedora GNU/Linux:
 
      urpmi coq
 
-   Should you need or prefer to compile Coq V8.4 yourself, you need:
+   - MacOS:
 
-     - Objective Caml version 3.11.2 or later
+     port install coq
+
+   Should you need or prefer to compile Coq V8.5 yourself, you need:
+
+     - Objective Caml version 3.12.1 or later
        (available at http://caml.inria.fr/)
 
-     - Camlp5 (version <= 4.08, or 5.* transitional)
+     - Camlp5 (version >= 6.06) (Coq compiles with Camlp4 but might be less
+       well supported)
 
      - GNU Make version 3.81 or later
-       (
-	available at http://www.gnu.org/software/make/, but also a
-        standard or optional add-on part to most Unices and Unix
-        clones, sometimes under the name "gmake".
-
-	If a new enough version is not included in your system, nor
-        easily available as an add-on, this should get you a working
-        make:
-
-	#Download it (wget is an example, use your favourite FTP or HTTP client)
-	wget http://ftp.gnu.org/pub/gnu/make/make-3.81.tar.bz2
-	bzip2 -cd make-3.81.tar.bz2 | tar x
-	#If you don't have bzip2, you can download the gzipped version instead.
-        cd make-3.81
-        ./configure --prefix=${HOME}
-	make install
-
-	Then, make sure that ${HOME}/bin is first in your $PATH.
-       )
 
      - a C compiler
 
-     - for Coqide, the Lablgtk development files, and the GTK libraries, see INSTALL.ide for more details
+     - for Coqide, the Lablgtk development files, and the GTK libraries
+       incuding gtksourceview, see INSTALL.ide for more details
 
    By FTP, Coq comes as a single compressed tar-file. You have
    probably already decompressed it if you are reading this document.
@@ -87,31 +71,28 @@ QUICK INSTALLATION PROCEDURE.
 INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 =================================================
 
-1- Check that you have the Objective Caml compiler version 3.11.2 (or later)
-   installed on your computer and that "ocamlmktop" and "ocamlc" (or
-   its native code version "ocamlc.opt") lie in a directory which is present
-   in your $PATH environment variable. 
+1- Check that you have the Objective Caml compiler version 3.12.1 (or later)
+   installed on your computer and that "ocamlc" (or its native code version
+   "ocamlc.opt") lie in a directory which is present in your $PATH environment
+   variable.
 
    To get Coq in native-code, (it runs 4 to 10 times faster than
    bytecode, but it takes more time to get compiled and the binary is
    bigger), you will also need the "ocamlopt" (or its native code version
    "ocamlopt.opt") command.
 
-2- Check that you have Camlp4 installed on your 
-   computer and that the command "camlp4" lies in a directory which
+2- Check that you have Camlp5 (or a supported Camlp4) installed on your
+   computer and that the command "camlp5" lies in a directory which
    is present in your $PATH environment variable path.
-   (You need Camlp4 in both bytecode and native versions if
+   (You need Camlp5/4 in both bytecode and native versions if
    your platform supports it).
 
-   Note: in the latest ocaml distributions, camlp4 comes with ocaml so
-   you do not have to check this point anymore.
-
-3- The uncompression and un-tarring of the distribution file gave birth 
-   to a directory named "coq-8.xx". You can rename this directory and put 
+3- The uncompression and un-tarring of the distribution file gave birth
+   to a directory named "coq-8.xx". You can rename this directory and put
    it wherever you want. Just keep in mind that you will need some spare
-   space during the compilation (reckon on about 50 Mb of disk space
+   space during the compilation (reckon on about 300 Mb of disk space
    for the whole system in native-code compilation). Once installed, the
-   binaries take about 14 Mb, and the library about 9 Mb.
+   binaries take about 30 Mb, and the library about 200 Mb.
 
 4- First you need to configure the system. It is done automatically with
    the command:
@@ -136,7 +117,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 -libdir <dir>                   (default: /usr/local/lib/coq)
         Directory where the Coq standard library will be installed
 
--mandir <dir>                   (default: /usr/local/man)
+-mandir <dir>                   (default: /usr/local/share/man)
         Directory where the Coq manual pages will be installed
 
 -emacslib <dir>			(default: /usr/local/lib/emacs/site-lisp)
@@ -152,7 +133,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
         is not necessary in that case.
 
 -opt
-        Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt 
+        Use the ocamlc.opt compiler instead of ocamlc (and ocamlopt.opt
         compiler instead of ocamlopt). Makes compilation faster (recommended).
 
 -browser <command>
@@ -166,7 +147,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
    to compile Coq in Objective Caml bytecode (and native-code if supported).
 
    This will compile the entire system. This phase can take more or less time,
-   depending on your architecture and is fairly verbose. 
+   depending on your architecture and is fairly verbose.
 
 6- You can now install the Coq system. Executables, libraries, manual pages
    and emacs mode are copied in some standard places of your system, defined at
@@ -180,7 +161,7 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
    in you .emacs file:
 
         (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
-        (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+        (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t)
 
 7- You can now clean all the sources. (You can even erase them.)
 
@@ -190,12 +171,10 @@ INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
 INSTALLATION PROCEDURE FOR ADVANCED USERS.
 ==========================================
 
-   If you wish to write tactics (and that really means that you belong
-   to advanced users!) you *must* keep the Coq sources, without cleaning
-   them. Therefore, to avoid a duplication of binaries and library, it is
-   not necessary to do the installation step (6- above).
-   You just have to tell it at configuration step (4- above) with the
-   option -local :
+   If you wish to write plugins you *must* keep the Coq sources, without
+   cleaning them. Therefore, to avoid a duplication of binaries and library,
+   it is not necessary to do the installation step (6- above).  You just have
+   to tell it at configuration step (4- above) with the option -local :
 
 	./configure -local <other options>
 
@@ -218,61 +197,42 @@ THE AVAILABLE COMMANDS.
 =======================
 
    There are two Coq commands:
-	
+
 	coqtop		The Coq toplevel
 	coqc		The Coq compiler
 
-   There are actually two binaries for the interactive system, coqtop.byte
-   and coqtop.opt (respectively bytecode and native code versions of Coq). 
-   coqtop is a link to the fastest version, i.e. coqtop.opt if any, and
-   coqtop.byte otherwise. coqc also invokes the fastest version of Coq.
-   Options -opt and -byte to coqtop and coqc selects a particular binary.
+   Under architecture where ocamlopt is available, there are actually two
+   binaries for the interactive system, coqtop.byte and coqtop (respectively
+   bytecode and native code versions of Coq).  coqtop is a link to coqtop.byte
+   otherwise. coqc also invokes the fastest version of Coq.  Options -opt and
+   -byte to coqtop and coqc selects a particular binary.
 
-    * `coqtop' launches Coq in the interactive mode. The default state
-      (see the "-inputstate" option) is `initial.coq', which contains some 
-      basic logical definitions, the associated parsing and printing rules,
-      and the following tactic modules: Equality, Tauto, Inv, EAuto and Refine.
+    * `coqtop' launches Coq in the interactive mode. By default it loads
+      basic logical definitions and tactics from the Init directory.
 
     * `coqc' allows compilation of Coq files directly from the command line.
       To compile a file foo.v, do:
 
 		coqc foo.v
 
-      It will produce a file foo.vo, that you can now load through the Coq 
-      command "Require". 
+      It will produce a file foo.vo, that you can now load through the Coq
+      command "Require".
 
    A detailed description of these commands and of their options is given
    in the Reference Manual (which you can get by FTP, in the doc/
    directory, or read online on http://coq.inria.fr/doc/)
    and in the corresponding manual pages.
 
-   There is also a tutorial and a FAQ; see http://coq.inria.fr/doc1-eng.html
-
-
-COMMON PROBLEMS.
-================
-
-    * On some sites, when running `./configure', `pwd' returned a 
-    path which is not valid from another machine (it may look like 
-    "/tmp_mnt/foo/...") and, as a consequence, you won't be able to run
-    coqtop or coqc. The solution is to give the correct value, with
-
-	./configure -src <correct path> <other options>
-
-    * The `make install' procedure uses mkdirhier, a program that may
-   not be present on certain systems. To fix that, try to replace
-   mkdirhier with mkdir -p
-
-    * See also section on dynamically loaded libraries.
+   There is also a tutorial and a FAQ; see http://coq.inria.fr/getting-started
 
 
 COMPILING FOR DIFFERENT ARCHITECTURES.
 ======================================
 
-   This section explains how to compile Coq for several architecture,
-   sharing the same sources. The important fact is that some files are 
-   architecture dependent (.cmx, .o and executable  files for instance)
-   but others are not (.cmo and .vo). Consequently, you can :
+   This section explains how to compile Coq for several architecture, sharing
+   the same sources. The important fact is that some files are architecture
+   dependent (.cmx, .o and executable files for instance) but others are not
+   (.cmo and .vo). Consequently, you can :
 
    o  save some time during compilation by not cleaning the architecture
       independent files;
@@ -300,17 +260,16 @@ COMPILING FOR DIFFERENT ARCHITECTURES.
 MOVING BINARIES OR LIBRARY.
 ===========================
 
-   If you move the binaries or the library, Coq will be "lost".
-   Running "coqtop" would then return an error message of the kind:
+   If you move both the binaries and the library in a consistent way,
+   Coq should be able to still run. Otherwise, Coq may be "lost",
+   running "coqtop" would then return an error message of the kind:
 
 	Error during initialization :
-	Error: Can't find file initial.coq on loadpath
+	Error: cannot guess a path for Coq libraries; please use -coqlib option
 
-   If you really have (or want) to move the binaries or the library, then
-   you have to indicate their new places to Coq, using the options -bindir (for
-   the binaries directory) and -libdir (for the standard library directory) :
+   You can then indicate the new places to Coq, using the options -coqlib :
 
-	coqtop -bindir <new directory> -libdir <new directory>
+	coqtop -coqlib <new directory>
 
    See also next section.
 
@@ -334,7 +293,7 @@ DYNAMICALLY LOADED LIBRARIES FOR BYTECODE EXECUTABLES.
        the directory of the standard library of OCaml;
      - recompile your bytecode executables after reconfiguring the location of
        of the shared library:
-         ./configure -coqrunbyteflags "-dllib -lcoqrun -dllpath <path>" ...
+         ./configure -vmbyteflags "-dllib,-lcoqrun,-dllpath,<path>" ...
        where <path> is the directory where the dllcoqrun.so is installed;
      - (not recommended) compile bytecode executables with a custom OCaml
        runtime by using:
diff --git a/INSTALL.ide b/INSTALL.ide
index 300d17b1..2bbb4a5f 100644
--- a/INSTALL.ide
+++ b/INSTALL.ide
@@ -1,7 +1,7 @@
 			CoqIde Installation procedure.
 
 CoqIde is a graphical interface to perform interactive proofs.
-You should be able to do everything you do in coqtop inside CoqIde 
+You should be able to do everything you do in coqtop inside CoqIde
 excepted dropping to the ML toplevel.
 
 DISCLAIMER: CoqIde is ongoing work. Although it should never let you
@@ -23,10 +23,10 @@ On Gentoo GNU/Linux, do:
 Else, read the rest of this document to compile your own CoqIde.
 
 REQUIREMENT:
-	- OCaml >= 3.11 with native threads support.
+	- OCaml >= 3.12.1 with native threads support.
 	- make world must succeed.
 	- The graphical toolkit GTK+ 2.x. See http://www.gtk.org.
-	  The official supported version is at least 2.10.x.
+	  The official supported version is at least 2.24.x.
 	  You may still compile CoqIde with older versions and 
           use all features.
 	  Run 
@@ -40,36 +40,36 @@ REQUIREMENT:
           install GTK+ 2.x should you need to force it for one reason
           or another.)
 
-        - The OCaml bindings for GTK+ 2.x, lablgtk2.
+        - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2.
 
-	  You need at least version 2.12.0.
+	  You need at least version 2.14.2.
 
 	  Your distribution may contain precompiled packages. For
           example, for Debian, run
-                aptitude install liblablgtk2-ocaml-dev
+                aptitude install liblablgtksourceview2-ocaml-dev
 		   for Mandriva, run
-		urpmi ocaml-lablgtk2-devel
+		urpmi ocaml-lablgtk-devel
 
           If it does not, see
-          http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/lablgtk.html .
+	  http://lablgtk.forge.ocamlcore.org/
 
           One official releases of lablgtk2 is here:
-          http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/dist/lablgtk-2.10.1.tar.gz
+          https://forge.ocamlcore.org/frs/download.php/561/lablgtk-2.14.2.tar.gz
 
           If you are in a hurry just run :
 
               cd /tmp && \
               wget \
-               http://wwwfun.kurims.kyoto-u.ac.jp/soft/olabl/dist/lablgtk-2.10.1.tar.gz && \
-              tar zxvf lablgtk-2.10.1.tar.gz && \
-              cd lablgtk-2.10.1 && \
+               https://forge.ocamlcore.org/frs/download.php/561/lablgtk-2.14.2.tar.gz && \
+              tar zxvf lablgtk-2.14.2.tar.gz && \
+              cd lablgtk-2.14.2 && \
               ./configure && \
               make world && \
               make install
 
    	  You must have write access to the OCaml standard library path.
 
-          If this fails, read lablgtk-2.10.1/README.
+          If this fails, read lablgtk-2.14.2/README.
 
 
 INSTALLATION
diff --git a/INSTALL.macosx b/INSTALL.macosx
new file mode 100644
index 00000000..cc1317b1
--- /dev/null
+++ b/INSTALL.macosx
@@ -0,0 +1,20 @@
+INSTALLATION PROCEDURE FOR THE PRECOMPILED COQ V8.1 SYSTEM UNDER MACOS X
+------------------------------------------------------------------------
+
+You can also use fink, or the MacOS X package prepared by the Coq
+team. To use the MacOS X package,:
+
+1) Download archive coq-8.1-macosx-ppc.dmg (for PowerPC-base computer)
+   or coq-8.1-macosx-i386.dmg (for Pentium-based computer).
+
+2) Double-click on its icon; it mounts a disk volume named "Coq V8.1".
+
+3) Open volume "Coq 8.1" and double-click on coq-8.1.pkg to launch the
+   installer (you'll need administrator permissions).
+
+4) Coq installs in /usr/local/bin, which should be in your PATH, and
+   can be used from a Terminal window: the interactive toplevel is
+   named coqtop and the compiler is coqc.
+
+If you have any trouble with this installation, please contact:
+coq-bugs@pauillac.inria.fr.
diff --git a/Makefile b/Makefile
index bb5ec3bc..c7fb1ff7 100644
--- a/Makefile
+++ b/Makefile
@@ -26,7 +26,6 @@
 #
 # make VERBOSE=1           # restore the raw echoing of commands
 # make NO_RECALC_DEPS=1    # avoid recomputing dependencies
-# make NO_RECOMPILE_LIB=1  # a coqtop rebuild does not trigger a stdlib rebuild
 #
 # Nota: the 1 above can be replaced by any non-empty value
 #
@@ -60,11 +59,20 @@ define find
  $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||')
 endef
 
+define findx
+ $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -exec $(2) {} \; | sed 's|^\./||')
+endef
+
+# We now discriminate .ml4 files according to their need of grammar.cma
+# or q_constr.cmo
+USEGRAMMAR := '(\*.*camlp4deps.*grammar'
+
 ## Files in the source tree
 
 YACCFILES:=$(call find, '*.mly')
 LEXFILES := $(call find, '*.mll')
 export MLLIBFILES := $(call find, '*.mllib')
+export ML4BASEFILES := $(call findx, '*.ml4', grep -L -e $(USEGRAMMAR))
 export ML4FILES := $(call find, '*.ml4')
 export CFILES := $(call find, '*.c')
 
@@ -78,13 +86,13 @@ EXISTINGMLI := $(call find, '*.mli')
 ## Files that will be generated
 
 GENML4FILES:= $(ML4FILES:.ml4=.ml)
-GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \
-  scripts/tolink.ml kernel/copcodes.ml
 GENMLIFILES:=$(YACCFILES:.mly=.mli)
 GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml))
+export GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) \
+  tools/tolink.ml kernel/copcodes.ml $(GENPLUGINSMOD)
 export GENHFILES:=kernel/byterun/coq_jumptbl.h
 export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v
-export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES) $(GENPLUGINSMOD)
+export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES)
 
 # NB: all files in $(GENFILES) can be created initially, while
 # .ml files in $(GENML4FILES) might need some intermediate building.
@@ -96,8 +104,7 @@ define diff
  $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f)))
 endef
 
-export MLEXTRAFILES := $(GENMLFILES) $(GENML4FILES) $(GENPLUGINSMOD)
-export MLSTATICFILES := $(call diff, $(EXISTINGML), $(MLEXTRAFILES))
+export MLSTATICFILES := $(call diff, $(EXISTINGML), $(GENMLFILES) $(GENML4FILES))
 export MLIFILES := $(sort $(GENMLIFILES) $(EXISTINGMLI))
 
 include Makefile.common
@@ -108,7 +115,7 @@ include Makefile.common
 
 NOARG: world
 
-.PHONY: NOARG help always
+.PHONY: NOARG help noconfig submake
 
 help:
 	@echo "Please use either"
@@ -132,17 +139,27 @@ endif
 
 # Apart from clean and tags, everything will be done in a sub-call to make
 # on Makefile.build. This way, we avoid doing here the -include of .d :
-# since they trigger some compilations, we do not want them for a mere clean
+# since they trigger some compilations, we do not want them for a mere clean.
+# Moreover, we regroup this sub-call in a common target named 'submake'.
+# This way, multiple user-given goals (cf the MAKECMDGOALS variable) won't
+# trigger multiple (possibly parallel) make sub-calls
 
 ifdef COQ_CONFIGURED
-%:: always
-	$(MAKE) --warn-undefined-variable --no-builtin-rules -f Makefile.build "$@"
+%:: submake ;
 else
-%:: always
-	@echo "Please run ./configure first" >&2; exit 1
+%:: noconfig ;
 endif
 
-always : ;
+MAKE_OPTS := --warn-undefined-variable --no-builtin-rules
+
+GRAM_TARGETS := grammar/grammar.cma grammar/q_constr.cmo
+
+submake:
+	$(MAKE) $(MAKE_OPTS) -f Makefile.build BUILDGRAMMAR=1 $(GRAM_TARGETS)
+	$(MAKE) $(MAKE_OPTS) -f Makefile.build $(MAKECMDGOALS)
+
+noconfig:
+	@echo "Please run ./configure first" >&2; exit 1
 
 # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles
 
@@ -166,8 +183,8 @@ cruftclean: ml4clean
 
 indepclean:
 	rm -f $(GENFILES)
-	rm -f $(COQTOPBYTE) $(COQMKTOPBYTE) $(COQCBYTE) $(CHICKENBYTE) bin/fake_ide
-	find . -name '*~' -o -name '*.cm[ioa]' | xargs rm -f
+	rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(FAKEIDE)
+	find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -delete
 	rm -f */*.pp[iox] plugins/*/*.pp[iox]
 	rm -rf $(SOURCEDOCDIR)
 	rm -f toplevel/mltop.byteml toplevel/mltop.optml
@@ -192,23 +209,22 @@ docclean:
 	rm -f doc/common/version.tex
 	rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html
 	rm -f doc/coq.tex
-	rm -f doc/refman/styles.hva doc/refman/cover.html 
 
 archclean: clean-ide optclean voclean
-	rm -rf _build myocamlbuild_config.ml
+	rm -rf _build
 	rm -f $(ALLSTDLIB).*
 
 optclean:
 	rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT)
-	rm -f $(COQTOPOPT) $(COQMKTOPOPT) $(COQCOPT) $(CHICKENOPT)
 	rm -f $(TOOLS) $(CSDPCERT)
 	find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f
 
 clean-ide:
-	rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
+	rm -f $(COQIDECMO) $(COQIDECMX) $(COQIDECMO:.cmo=.cmi) $(COQIDEBYTE) $(COQIDE)
 	rm -f ide/input_method_lexer.ml
 	rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml
 	rm -f ide/utf8_convert.ml
+	rm -rf $(COQIDEAPP)
 
 ml4clean:
 	rm -f $(GENML4FILES)
@@ -219,14 +235,16 @@ ml4depclean:
 depclean:
 	find . $(FIND_VCS_CLAUSE) '(' -name '*.d' ')' -print | xargs rm -f
 
+cacheclean:
+	find theories plugins test-suite -name '.*.aux' -delete
+
 cleanconfig:
-	rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli
+	rm -f config/Makefile config/coq_config.ml myocamlbuild_config.ml dev/ocamldebug-v7 config/Info-*.plist
 
-distclean: clean cleanconfig
+distclean: clean cleanconfig cacheclean
 
 voclean:
-	rm -f states/*.coq
-	find theories plugins test-suite -name '*.vo' -o -name '*.glob' | xargs rm -f
+	find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -delete
 
 devdocclean:
 	find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f
@@ -238,10 +256,10 @@ devdocclean:
 # Emacs tags
 ###########################################################################
 
-.PHONY: tags otags
+.PHONY: tags printenv
 
 tags:
-	echo $(MLIFILES) $(MLSTATICFILES) $(ML4FILES) | sort -r | xargs \
+	echo $(filter-out checker/%, $(MLIFILES)) $(filter-out checker/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \
 	etags --language=none\
 	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
@@ -254,11 +272,9 @@ tags:
 	etags --append --language=none\
 	      "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/"
 
-
-otags: 
-	echo $(MLIFILES) $(MLSTATICFILES) | sort -r | xargs otags
-	echo $(ML4FILES) | sort -r | xargs \
-	etags --append --language=none\
+checker-tags:
+	echo $(filter-out kernel/%, $(MLIFILES)) $(filter-out kernel/%, $(MLSTATICFILES)) $(ML4FILES) | sort -r | xargs \
+	etags --language=none\
 	      "--regex=/let[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/and[ \t]+\([^ \t]+\)/\1/" \
@@ -266,17 +282,9 @@ otags:
               "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/val[ \t]+\([^ \t]+\)/\1/" \
 	      "--regex=/module[ \t]+\([^ \t]+\)/\1/"
-
-
-%.elc: %.el
-ifdef COQ_CONFIGURED
-	echo "(setq load-path (cons \".\" load-path))" > $*.compile
-	echo "(byte-compile-file \"$<\")" >> $*.compile
-	- $(EMACS) -batch -l $*.compile
-	rm -f $*.compile
-else
-	@echo "Please run ./configure first" >&2; exit 1
-endif
+	echo $(ML4FILES) | sort -r | xargs \
+	etags --append --language=none\
+	      "--regex=/[ \t]*\([^: \t]+\)[ \t]*:/\1/"
 
 # Useful to check that the exported variables are within the win32 limits
 
diff --git a/Makefile.build b/Makefile.build
index 8d3045cc..0d87d98e 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -13,11 +13,10 @@
 # Starting rule
 ###########################################################################
 
-# build and install the three subsystems: coq, coqide
-world: revision coq coqide
-install: install-coq install-coqide
+# build the different subsystems: coq, coqide
+world: revision coq coqide documentation
 
-.PHONY: world install
+.PHONY: world
 
 ###########################################################################
 # Includes
@@ -26,29 +25,29 @@ install: install-coq install-coqide
 include Makefile.common
 include Makefile.doc
 
-ifeq ($(WITHDOC),all)
-world: doc
-install: install-doc
+# In a first phase, we restrict to the basic .ml4 (the ones without grammar.cma)
+
+ifdef BUILDGRAMMAR
+ MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4BASEFILES:.ml4=.ml)
+ CURFILES := $(MLFILES) $(MLIFILES) $(ML4BASEFILES) grammar/grammar.mllib
+else
+ MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml)
+ CURFILES := $(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(CFILES) $(VFILES)
 endif
 
+CURDEPS:=$(addsuffix .d, $(CURFILES))
+
 # All dependency includes must be declared secondary, otherwise make will
 # delete them if it decided to build them by dependency instead of because
 # of include, and they will then be automatically deleted, leading to an
 # infinite loop.
 
-MLFILES:=$(MLSTATICFILES) $(MLEXTRAFILES)
-
-ALLDEPS:=$(addsuffix .d, \
-  $(ML4FILES) $(MLFILES) $(MLIFILES) $(CFILES) $(MLLIBFILES) $(VFILES))
+.SECONDARY: $(CURDEPS) $(GENFILES) $(ML4FILES:.ml4=.ml)
 
-.SECONDARY: $(ALLDEPS) $(GENFILES) $(ML4FILES:.ml4=.ml)
+# This include below will lauch the build of all concerned .d.
+# The - at front is for disabling warnings about currently missing ones.
 
-# NOTA: the -include below will lauch the build of all .d. Some of them
-# will _fail_ at first, this is to be expected (no grammar.cma initially).
-# These errors (see below "not ready yet") do not discourage make to
-# try again and finally succeed.
-
--include $(ALLDEPS)
+-include $(CURDEPS)
 
 
 ###########################################################################
@@ -59,21 +58,31 @@ ALLDEPS:=$(addsuffix .d, \
 
 VERBOSE=
 NO_RECOMPILE_ML4=
-NO_RECOMPILE_LIB=
 NO_RECALC_DEPS=
-READABLE_ML4=	# non-empty means .ml of .ml4 will be ascii instead of binary
+READABLE_ML4=true	# non-empty means .ml of .ml4 will be ascii instead of binary
 VALIDATE=
 COQ_XML=	# is "-xml" when building XML library
 VM=		# is "-no-vm" to not use the vm"
-TIMECMD=	# is "'time -p'" to get compilation time of .v
 
-# NB: variable TIME, if set, is the formatting string for unix command 'time'.
-# For instance:
-# TIME="%C (%U user, %S sys, %e total, %M maxres)"
+TIMED=          # non-empty will activate a default time command
+                # when compiling .v (see $(STDTIME) below)
+
+TIMECMD=	# if you prefer a specific time command instead of $(STDTIME)
+                # e.g. "'time -p'"
+
+# NB: if you want to collect compilation timings of .v and import them
+# in a spreadsheet, I suggest something like:
+#   make TIMED=1 2> timings.csv
+
+# NB: do not use a variable named TIME, since this variable controls
+# the output format of the unix command time. For instance:
+#   TIME="%C (%U user, %S sys, %e total, %M maxres)"
+
+STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)"
+TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))
 
 COQOPTS=$(COQ_XML) $(VM)
-BOOTCOQTOP:=$(TIMECMD) $(BESTCOQTOP) -boot $(COQOPTS)
-BOOTCOQC:=$(BOOTCOQTOP) -compile
+BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile
 
 # The SHOW and HIDE variables control whether make will echo complete commands 
 # or only abbreviated versions. 
@@ -85,39 +94,50 @@ HIDE := $(if $(VERBOSE),,@)
 LOCALINCLUDES=$(addprefix -I , $(SRCDIRS) )
 MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB)
 
-OCAMLC += $(CAMLFLAGS)
-OCAMLOPT += $(CAMLFLAGS)
+OCAMLC := $(OCAMLC) $(CAMLFLAGS)
+OCAMLOPT := $(OCAMLOPT) $(CAMLFLAGS)
+
+BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS)
+OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
+DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils
 
-BAREBYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS)
-BAREOPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
-BYTEFLAGS=$(MLINCLUDES) $(BAREBYTEFLAGS)
-OPTFLAGS=$(MLINCLUDES) $(BAREOPTFLAGS)
-DEPFLAGS= -slash $(LOCALINCLUDES)
+ifeq ($(ARCH),Darwin)
+LINKMETADATA=-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist"
+CODESIGN=codesign -s -
+else
+LINKMETADATA=
+CODESIGN=true
+endif
 
 define bestocaml
 $(if $(OPT),\
-$(OCAMLOPT) $(OPTFLAGS) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@,\
-$(OCAMLC) $(BYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(1) $(addsuffix .cma,$(2)) $^)
+$(if $(findstring $@,$(PRIVATEBINARIES)),\
+  $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@,\
+  $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@),\
+$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^)
 endef
 
-CAMLP4DEPS=`LC_ALL=C sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*@\1@p' $<`
+CAMLP4DEPS=$(shell LC_ALL=C sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*@\1@p' $(1) \#))
 ifeq ($(CAMLP4),camlp5)
 CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION)
 else
 CAMLP4USE=-D$(CAMLVERSION)
 endif
 
+CAMLP4FLAGS=-I $(CAMLLIB) -I $(CAMLLIB)/threads -I $(MYCAMLP4LIB) unix.cma threads.cma
+
 PR_O := $(if $(READABLE_ML4),pr_o.cmo,pr_dump.cmo) # works also with new camlp4
 
+SYSMOD:=str unix dynlink threads
+SYSCMA:=$(addsuffix .cma,$(SYSMOD))
+SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD))
+
 ifeq ($(CAMLP4),camlp5)
-SYSMOD:=str unix gramlib
+P4CMA:=gramlib.cma
 else
-SYSMOD:=str unix dynlink camlp4lib
+P4CMA:=dynlink.cma camlp4lib.cma
 endif
 
-SYSCMA:=$(addsuffix .cma,$(SYSMOD))
-SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD))
-
 
 ###########################################################################
 # Infrastructure for the rest of the Makefile
@@ -135,19 +155,12 @@ ifndef ORDER_ONLY_SEP
 $(error This Makefile needs GNU Make 3.81 or later (that is a version that supports the order-only dependency feature without major bugs.))
 endif
 
-VO_TOOLS_DEP := $(BESTCOQTOP)
+VO_TOOLS_DEP := $(COQTOPEXE)
 ifdef COQ_XML
  VO_TOOLS_DEP += $(COQDOC)
 endif
 ifdef VALIDATE
- VO_TOOLS_DEP += $(BESTCHICKEN)
-endif
-ifdef NO_RECOMPILE_LIB
- VO_TOOLS_ORDER_ONLY:=$(VO_TOOLS_DEP)
- VO_TOOLS_STRICT:=
-else
- VO_TOOLS_ORDER_ONLY:=
- VO_TOOLS_STRICT:=$(VO_TOOLS_DEP)
+ VO_TOOLS_DEP += $(CHICKEN)
 endif
 
 ifdef NO_RECALC_DEPS
@@ -193,110 +206,89 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h
 # Main targets (coqmktop, coqtop.opt, coqtop.byte)
 ###########################################################################
 
-## In Win32, cygwin provides an emulation of ln -s, but this emulation
-## won't work outside of cygwin shell (i.e. typically in a Sys.command).
-## So we just forget about it, and do a simple copy.
-
-ifeq ($(ARCH),win32)
-LN:=cp -f
-else
-LN:=ln -sf
-endif
-
 .PHONY: coqbinaries coq coqlib coqlight states
 
-coqbinaries:: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE}
+coqbinaries: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE}
 
 coq: coqlib tools coqbinaries
 
-coqlib:: theories plugins
+coqlib: theories plugins
 
 coqlight: theories-light tools coqbinaries
 
-states:: states/initial.coq
+states: theories/Init/Prelude.vo
+
+miniopt: $(COQTOPEXE) pluginsopt
+minibyte: $(COQTOPBYTE) pluginsbyte
 
-$(COQTOPOPT): $(BESTCOQMKTOP) $(LINKCMX) $(LIBCOQRUN)
+ifeq ($(BEST),opt)
+$(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs)
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(BESTCOQMKTOP) -boot -opt $(BAREOPTFLAGS) -o $@
+	$(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -thread -o $@
 	$(STRIP) $@
+	$(CODESIGN) $@
+else
+$(COQTOPEXE): $(COQTOPBYTE)
+	cp $< $@
+endif
 
-$(COQTOPBYTE): $(BESTCOQMKTOP) $(LINKCMO) $(LIBCOQRUN)
+$(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA)
 	$(SHOW)'COQMKTOP -o $@'	
-	$(HIDE)$(BESTCOQMKTOP) -boot -top $(BAREBYTEFLAGS) -o $@
-
-$(COQTOPEXE): $(ORDER_ONLY_SEP) $(BESTCOQTOP)
-	cd bin && $(LN) coqtop.$(BEST)$(EXE) coqtop$(EXE)
+	$(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -thread -o $@
 
 LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) )
 CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB)
-CHKBYTEFLAGS:=$(CHKLIBS) $(CAMLDEBUG) $(USERFLAGS)
-CHKOPTFLAGS:=$(CHKLIBS) $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS)
 
-$(CHICKENOPT): checker/check.cmxa checker/main.ml
+ifeq ($(BEST),opt)
+$(CHICKEN): checker/check.cmxa checker/main.ml
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -o $@ $(SYSCMXA) $^
+	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -thread -o $@ $(SYSCMXA) $^
 	$(STRIP) $@
+	$(CODESIGN) $@
+else
+$(CHICKEN): $(CHICKENBYTE)
+	cp $< $@
+endif
 
 $(CHICKENBYTE): checker/check.cma checker/main.ml
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) $(COQTOOLSBYTEFLAGS) -o $@ $(SYSCMA) $^
-
-$(CHICKEN): $(ORDER_ONLY_SEP) $(BESTCHICKEN)
-	cd bin && $(LN) coqchk.$(BEST)$(EXE) coqchk$(EXE)
-
-# coqmktop 
-
-$(COQMKTOPBYTE): $(COQMKTOPCMO)
-	$(SHOW)'OCAMLC -o $@'	
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS)
+	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -thread -o $@ $(SYSCMA) $^
 
-$(COQMKTOPOPT): $(COQMKTOPCMO:.cmo=.cmx)
-	$(SHOW)'OCAMLOPT -o $@'	
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS)
-	$(STRIP) $@
-
-$(COQMKTOP): $(ORDER_ONLY_SEP) $(BESTCOQMKTOP)
-	cd bin && $(LN) coqmktop.$(BEST)$(EXE) coqmktop$(EXE)
+# coqmktop
+$(COQMKTOP): $(patsubst %.cma,%$(BESTLIB),$(COQMKTOPCMO:.cmo=$(BESTOBJ)))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
-scripts/tolink.ml: Makefile.build Makefile.common
+tools/tolink.ml: Makefile.build Makefile.common
 	$(SHOW)"ECHO... >" $@
 	$(HIDE)echo "let copts = \"-cclib -lcoqrun\"" > $@
 	$(HIDE)echo "let core_libs = \""$(LINKCMO)"\"" >> $@
 	$(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@
 
 # coqc
-
-$(COQCBYTE): $(COQCCMO) | $(COQTOPBYTE)
-	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(SYSCMA) $^ $(OSDEPLIBS)
-
-$(COQCOPT): $(COQCCMO:.cmo=.cmx) | $(COQTOPOPT)
-	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -o $@ $(SYSCMXA) $^ $(OSDEPLIBS)
-	$(STRIP) $@
-
-$(COQC): $(ORDER_ONLY_SEP) $(BESTCOQC) 
-	cd bin && $(LN) coqc.$(BEST)$(EXE) coqc$(EXE)
+$(COQC):  $(patsubst %.cma,%$(BESTLIB),$(COQCCMO:.cmo=$(BESTOBJ)))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
 # target for libraries
 
 %.cma: | %.mllib.d
 	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -a -o $@ $^
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^
 
 %.cmxa: | %.mllib.d
 	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -a -o $@ $^
+	$(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^
 
 # For the checker, different flags may be used
 
 checker/check.cma: | checker/check.mllib.d
 	$(SHOW)'OCAMLC -a -o $@'
-	$(HIDE)$(OCAMLC) $(CHKBYTEFLAGS) -a -o $@ $^
+	$(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $^
 
 checker/check.cmxa: | checker/check.mllib.d
 	$(SHOW)'OCAMLOPT -a -o $@'
-	$(HIDE)$(OCAMLOPT) $(CHKOPTFLAGS) -a -o $@ $^
+	$(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $^
 
 ###########################################################################
 # Csdp to micromega special targets
@@ -313,87 +305,191 @@ plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ))
 .PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files
 
 # target to build CoqIde
-coqide:: coqide-files coqide-binaries states
+coqide: coqide-files coqide-binaries theories/Init/Prelude.vo
 
-COQIDEFLAGS=-thread $(COQIDEINCLUDES)
+COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES)
 
 .SUFFIXES:.vo
 
-IDEFILES=ide/coq.png ide/coqide-gtk2rc ide/mac_default_accel_map
+IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map
 
-coqide-binaries: coqide-$(HASCOQIDE)
+coqide-binaries: coqide-$(HASCOQIDE) ide-toploop
 coqide-no:
 coqide-byte: $(COQIDEBYTE) $(COQIDE)
-coqide-opt:  $(COQIDEBYTE) $(COQIDEOPT) $(COQIDE)
+coqide-opt:  $(COQIDEBYTE) $(COQIDE)
 coqide-files: $(IDEFILES)
+ifeq ($(BEST),opt)
+ide-toploop: $(IDETOPLOOPCMA) $(IDETOPLOOPCMA:.cma=.cmxs)
+else
+ide-toploop: $(IDETOPLOOPCMA)
+endif
 
-$(COQIDEOPT): $(LINKIDEOPT) | $(COQTOPOPT)
+ifeq ($(HASCOQIDE),opt)
+$(COQIDE): $(LINKIDEOPT)
 	$(SHOW)'OCAMLOPT -o $@'
-	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa \
-		lablgtk.cmxa $(IDEOPTFLAGS) gtkThread.cmx str.cmxa $(LINKIDEOPT)
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa \
+		lablgtksourceview2.cmxa str.cmxa $(IDEFLAGS:.cma=.cmxa) $^
 	$(STRIP) $@
+else
+$(COQIDE): $(COQIDEBYTE)
+	cp $< $@
+endif
 
-$(COQIDEBYTE): $(LINKIDE) | $(COQTOPBYTE)
+$(COQIDEBYTE): $(LINKIDE)
 	$(SHOW)'OCAMLC -o $@'
-	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\
-		str.cma $(COQRUNBYTEFLAGS) $(LINKIDE)
-
-$(COQIDE):
-	cd bin && $(LN) coqide.$(HASCOQIDE)$(EXE) coqide$(EXE)
+	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \
+	        lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^
 
 # install targets
 
-.PHONY: install-coqide install-ide-no install-ide-byte install-ide-opt
-.PHONY: install-ide-files install-ide-info install-im
+.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles
 
-install-coqide:: install-ide-$(HASCOQIDE) install-ide-files install-ide-info
-
-install-ide-no:
+ifeq ($(HASCOQIDE),no)
+install-coqide: install-ide-toploop
+else
+install-coqide: install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles
+endif
 
-install-ide-byte:
+install-ide-bin:
 	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQIDEBYTE) $(FULLBINDIR)
-	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \
-	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
-	cd $(FULLBINDIR) && $(LN) coqide.byte$(EXE) coqide$(EXE)
+	$(INSTALLBIN) $(COQIDE) $(FULLBINDIR)
 
-install-ide-opt:
-	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQIDEOPT) $(FULLBINDIR)
-	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) \
+install-ide-toploop:
+	$(MKDIR) $(FULLCOQLIB)/toploop
+	$(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/
+ifeq ($(BEST),opt)
+	$(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/
+endif
+
+install-ide-devfiles:
+	$(MKDIR) $(FULLCOQLIB)
+	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \
 	  $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib))))
-	cd $(FULLBINDIR) && $(LN) coqide.opt$(EXE) coqide$(EXE)
+ifeq ($(BEST),opt)
+	$(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a)
+endif
 
-install-ide-files:
+install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time
 	$(MKDIR) $(FULLDATADIR)
-	$(INSTALLLIB) ide/coq.png $(FULLDATADIR)
+	$(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR)
 	$(MKDIR) $(FULLCONFIGDIR)
-	$(INSTALLLIB) ide/coqide-gtk2rc $(FULLCONFIGDIR)
-	if [ $(IDEOPTINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi
+	if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi
 
 install-ide-info:
 	$(MKDIR) $(FULLDOCDIR)
 	$(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde
 
 ###########################################################################
+# CoqIde MacOS special targets
+###########################################################################
+
+.PHONY: $(COQIDEAPP)/Contents
+
+$(COQIDEAPP)/Contents:
+	rm -rdf $@
+	$(MKDIR) $@
+	sed -e "s/VERSION/$(VERSION)/g" ide/MacOS/Info.plist.template > $@/Info.plist
+	$(MKDIR) "$@/MacOS"
+
+$(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents
+	$(SHOW)'OCAMLOPT -o $@'
+	$(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \
+		unix.cmxa lablgtk.cmxa lablgtksourceview2.cmxa str.cmxa \
+		threads.cmxa $(IDEFLAGS:.cma=.cmxa) $^
+	$(STRIP) $@
+
+$(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents
+	$(MKDIR) $@/coq/
+	$(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $@/coq/
+	$(MKDIR) $@/gtksourceview-2.0/{language-specs,styles}
+	$(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/
+	$(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/
+	cp -R "$(GTKSHARE)/"locale $@
+	cp -R "$(GTKSHARE)/"icons $@
+	cp -R "$(GTKSHARE)/"themes $@
+
+$(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents
+	$(MKDIR) $@
+	$(INSTALLLIB) $$("$(GTKBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@
+
+$(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents
+	$(MKDIR) $@
+	$(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@
+
+
+$(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib
+	$(MKDIR) $@/xdg/coq
+	$(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys
+	$(MKDIR) $@/gtk-2.0
+	{ "$(GTKBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\
+	 sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \
+	> $@/gtk-2.0/gdk-pixbuf.loaders
+	{ "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\
+	 sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\
+	 sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \
+	> $@/gtk-2.0/gtk-immodules.loaders
+	$(MKDIR) $@/pango
+	echo "[Pango]" > $@/pango/pangorc
+
+$(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP)
+	$(MKDIR) $@
+	$(INSTALLLIB) $(GTKLIBS)/charset.alias $@/
+	$(MKDIR) $@/pango/1.8.0/modules
+	$(INSTALLLIB) "$(GTKLIBS)/pango/1.8.0/modules/"*.so $@/pango/1.8.0/modules/
+	{ "$(GTKBIN)/pango-querymodules" $@/pango/1.8.0/modules/*.so |\
+	 sed -e "s!/.*\(/pango/1.8.0/modules/.*.so\)!@executable_path/../Resources/lib\1!"; } \
+	> $@/pango/1.8.0/modules.cache
+
+	for i in $$(otool -L $(COQIDEINAPP) |sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \
+	    do cp $$i $@/; \
+	    ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$i) $(GTKLIBS) $@; \
+	done
+	for i in $@/../loaders/*.so $@/../immodules/*.so $@/pango/1.8.0/modules/*.so; \
+	    do \
+		for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \
+		do cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \
+		ide/MacOS/relatify_with-respect-to_.sh $$i $(GTKLIBS) $@; \
+	    done
+	EXTRAWORK=1; \
+	while [ $${EXTRAWORK} -eq 1 ]; \
+	do EXTRAWORK=0; \
+	    for i in $@/*.dylib; \
+	    do for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \
+		do EXTRAWORK=1; cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \
+	    done; \
+	done
+	ide/MacOS/relatify_with-respect-to_.sh $(COQIDEINAPP) $(GTKLIBS) $@
+
+$(COQIDEAPP)/Contents/Resources:$(COQIDEAPP)/Contents/Resources/etc $(COQIDEAPP)/Contents/Resources/share
+	$(INSTALLLIB) ide/MacOS/*.icns $@
+
+$(COQIDEAPP):$(COQIDEAPP)/Contents/Resources
+	$(CODESIGN) $@
+
+###########################################################################
 # tests
 ###########################################################################
 
-.PHONY: validate check test-suite $(ALLSTDLIB).v
+.PHONY: validate check test-suite $(ALLSTDLIB).v md5chk
 
-VALIDOPTS=-silent -o -m
+md5chk:
+	$(SHOW)'MD5SUM cic.mli'
+	$(HIDE)if grep -q `$(MD5SUM) checker/cic.mli` checker/values.ml; \
+	       then true; else echo "Error: outdated checker/values.ml"; false; fi
 
-validate:: $(BESTCHICKEN) $(ALLVO)
+VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m
+
+validate: $(CHICKEN) md5chk | $(ALLVO)
 	$(SHOW)'COQCHK <theories & plugins>'
-	$(HIDE)$(BESTCHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
+	$(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS)
 
 $(ALLSTDLIB).v:
 	$(SHOW)'MAKE $(notdir $@)'
 	$(HIDE)echo "Require $(ALLMODS)." > $@
 
-MAKE_TSOPTS=-C test-suite -s BEST=$(BEST) VERBOSE=$(VERBOSE)
+MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE)
 
-check:: validate test-suite
+check: validate test-suite
 
 test-suite: world $(ALLSTDLIB).v
 	$(MAKE) $(MAKE_TSOPTS) clean
@@ -405,9 +501,9 @@ test-suite: world $(ALLSTDLIB).v
 ##################################################################
 
 .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping
-.PHONY: highparsing toplevel hightactics
+.PHONY: highparsing stm toplevel hightactics
 
-lib: lib/lib.cma
+lib: lib/clib.cma lib/lib.cma
 kernel: kernel/kernel.cma
 byterun: $(BYTERUN)
 library: library/library.cma
@@ -417,6 +513,7 @@ interp: interp/interp.cma
 parsing: parsing/parsing.cma
 pretyping: pretyping/pretyping.cma
 highparsing: parsing/highparsing.cma
+stm: stm/stm.cma
 toplevel: toplevel/toplevel.cma
 hightactics: tactics/hightactics.cma
 
@@ -455,45 +552,39 @@ program: $(PROGRAMVO)
 structures: $(STRUCTURESVO)
 vectors: $(VECTORSVO)
 
-noreal: logic arith bool zarith qarith lists sets fsets relations \
-	wellfounded setoids sorting
+noreal: unicode logic arith bool zarith qarith lists sets fsets \
+	relations wellfounded setoids sorting
 
 ###########################################################################
 # 3) plugins
 ###########################################################################
 
-.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction
-.PHONY: field fourier funind cc subtac rtauto pluginsopt
+.PHONY: plugins omega micromega setoid_ring nsatz extraction
+.PHONY: fourier funind cc rtauto btauto pluginsopt pluginsbyte
 
 plugins: $(PLUGINSVO)
 omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA)
 micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT)
-ring: $(RINGVO) $(RINGCMA)
-setoid_ring: $(NEWRINGVO) $(NEWRINGCMA)
+setoid_ring: $(RINGVO) $(RINGCMA)
 nsatz: $(NSATZVO) $(NSATZCMA)
-xml: $(XMLVO) $(XMLCMA)
 extraction: $(EXTRACTIONCMA)
-field: $(FIELDVO) $(FIELDCMA)
 fourier: $(FOURIERVO) $(FOURIERCMA)
 funind: $(FUNINDCMA) $(FUNINDVO)
 cc: $(CCVO) $(CCCMA)
-subtac: $(SUBTACCMA)
 rtauto: $(RTAUTOVO) $(RTAUTOCMA)
+btauto: $(BTAUTOVO) $(BTAUTOCMA)
 
 pluginsopt: $(PLUGINSOPT)
+pluginsbyte: $(PLUGINS)
 
 ###########################################################################
-# rules to make theories, plugins and states
+# rules to make theories and plugins
 ###########################################################################
 
-states/initial.coq: states/MakeInitial.v $(INITVO) $(VO_TOOLS_STRICT) | states/MakeInitial.v.d $(VO_TOOLS_ORDER_ONLY)
-	$(SHOW)'BUILD     $@'
-	$(HIDE)$(BOOTCOQTOP) -batch -notop -silent -nois -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq
-
-theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_STRICT) | theories/Init/%.v.d $(VO_TOOLS_ORDER_ONLY)
-	$(SHOW)'COQC -nois $<'
+theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d
+	$(SHOW)'COQC -noinit $<'
 	$(HIDE)rm -f theories/Init/$*.glob
-	$(HIDE)$(BOOTCOQC) theories/Init/$* -nois
+	$(HIDE)$(BOOTCOQC) theories/Init/$* -noinit -R theories Coq
 
 theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml
 	$(OCAML) $< $(TOTARGET)
@@ -506,7 +597,7 @@ theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_g
 
 printers: $(DEBUGPRINTERS)
 
-tools:: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
+tools: $(TOOLS) $(DEBUGPRINTERS) $(COQDEPBOOT)
 
 # coqdep_boot : a basic version of coqdep, with almost no dependencies.
 
@@ -525,7 +616,7 @@ $(COQDEPBOOT): $(COQDEPBOOTSRC)
 
 # the full coqdep
 
-$(COQDEP): $(COQDEPCMO:.cmo=$(BESTOBJ))
+$(COQDEP): $(patsubst %.cma,%$(BESTLIB),$(COQDEPCMO:.cmo=$(BESTOBJ)))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD))
 
@@ -533,9 +624,9 @@ $(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,)
 
-$(COQMAKEFILE): $(addsuffix $(BESTOBJ),config/coq_config ide/minilib ide/project_file tools/coq_makefile)
+$(COQMAKEFILE):  $(patsubst %.cma,%$(BESTLIB),$(COQMAKEFILECMO:.cmo=$(BESTOBJ)))
 	$(SHOW)'OCAMLBEST -o $@'
-	$(HIDE)$(call bestocaml,,str unix)
+	$(HIDE)$(call bestocaml,,str unix threads)
 
 $(COQTEX): tools/coq_tex$(BESTOBJ)
 	$(SHOW)'OCAMLBEST -o $@'
@@ -545,24 +636,35 @@ $(COQWC): tools/coqwc$(BESTOBJ)
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,)
 
-$(COQDOC): $(COQDOCCMO:.cmo=$(BESTOBJ))
+$(COQDOC): $(patsubst %.cma,%$(BESTLIB),$(COQDOCCMO:.cmo=$(BESTOBJ)))
 	$(SHOW)'OCAMLBEST -o $@'
 	$(HIDE)$(call bestocaml,,str unix)
 
+$(COQWORKMGR): $(addsuffix $(BESTOBJ), stm/coqworkmgrApi tools/coqworkmgr) \
+		$(addsuffix $(BESTLIB), lib/clib)
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,, $(SYSMOD) clib)
+
 # fake_ide : for debugging or test-suite purpose, a fake ide simulating
 # a connection to coqtop -ideslave
 
-$(FAKEIDE): lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) lib/xml_utils$(BESTOBJ) toplevel/ide_intf$(BESTOBJ) tools/fake_ide$(BESTOBJ)
+$(FAKEIDE): lib/clib$(BESTLIB) lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) lib/xml_printer$(BESTOBJ) lib/errors$(BESTOBJ) lib/spawn$(BESTOBJ) ide/document$(BESTOBJ) ide/xmlprotocol$(BESTOBJ) tools/fake_ide$(BESTOBJ) | $(IDETOPLOOPCMA:.cma=$(BESTDYN))
+	$(SHOW)'OCAMLBEST -o $@'
+	$(HIDE)$(call bestocaml,-I ide,str unix threads)
+
+# votour: a small vo explorer (based on the checker)
+
+bin/votour: lib/cObj$(BESTOBJ) checker/values$(BESTOBJ) checker/votour.ml
 	$(SHOW)'OCAMLBEST -o $@'
-	$(HIDE)$(call bestocaml,,unix)
+	$(HIDE)$(call bestocaml, -I checker,)
 
 # Special rule for the compatibility-with-camlp5 extension for camlp4
 
 ifeq ($(CAMLP4),camlp4)
 tools/compat5.cmo: tools/compat5.mlp
-	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -impl' -impl $<
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $<
 tools/compat5b.cmo: tools/compat5b.mlp
-	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) -impl' -impl $<
+	$(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $<
 else
 tools/compat5.cmo: tools/compat5.ml
 	$(OCAMLC) -c $<
@@ -571,9 +673,31 @@ tools/compat5b.cmo: tools/compat5b.ml
 endif
 
 ###########################################################################
+# Documentation : cf Makefile.doc
+###########################################################################
+
+documentation: doc-$(WITHDOC)
+doc-all: doc
+doc-no:
+
+.PHONY: documentation doc-all doc-no
+
+###########################################################################
 # Installation
 ###########################################################################
 
+ifeq ($(LOCAL),true)
+install:
+	@echo "Nothing to install in a local build!"
+else
+install: install-coq install-coqide install-doc-$(WITHDOC)
+endif
+
+install-doc-all: install-doc
+install-doc-no:
+
+.PHONY: install install-doc-all install-doc-no
+
 #These variables are intended to be set by the caller to make
 #COQINSTALLPREFIX=
 #OLDROOT=
@@ -602,25 +726,23 @@ FULLDOCDIR=$(DOCDIR)
 endif
 
 .PHONY: install-coq install-coqlight install-binaries install-byte install-opt
-.PHONY: install-tools install-library install-library-light
+.PHONY: install-tools install-library install-library-light install-devfiles
 .PHONY: install-coq-info install-coq-manpages install-emacs install-latex
 
-install-coq: install-binaries install-library install-coq-info
+install-coq: install-binaries install-library install-coq-info install-devfiles
 install-coqlight: install-binaries install-library-light
 
-install-binaries:: install-$(BEST)  install-tools
-
-install-byte::
+install-binaries: install-tools
 	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(CHICKEN) $(FULLBINDIR)
-	cd $(FULLBINDIR); $(LN) coqtop.byte$(EXE) coqtop$(EXE); $(LN) coqchk.byte$(EXE) coqchk$(EXE)
+	$(INSTALLBIN) $(COQC) $(COQTOPBYTE) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR)
+	$(MKDIR) $(FULLCOQLIB)/toploop
+	$(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/
+ifeq ($(BEST),opt)
+	$(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/
+endif
 
-install-opt::
-	$(MKDIR) $(FULLBINDIR)
-	$(INSTALLBIN) $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(COQTOPOPT) $(CHICKEN) $(CHICKENOPT) $(FULLBINDIR)
-	cd $(FULLBINDIR); $(LN) coqtop.opt$(EXE) coqtop$(EXE); $(LN) coqchk.opt$(EXE) coqchk$(EXE)
 
-install-tools::
+install-tools:
 	$(MKDIR) $(FULLBINDIR)
 	# recopie des fichiers de style pour coqide
 	$(MKDIR) $(FULLCOQLIB)/tools/coqdoc
@@ -632,24 +754,29 @@ install-tools::
 # from .mli without .ml, and the ones obtained from .ml without .mli
 
 INSTALLCMI = $(sort \
-	$(CONFIG:.cmo=.cmi) \
 	$(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \
 	$(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES)))))
 
+install-devfiles:
+	$(MKDIR) $(FULLBINDIR)
+	$(INSTALLBIN) $(COQMKTOP) $(FULLBINDIR)
+	$(MKDIR) $(FULLCOQLIB)
+	$(INSTALLSH)  $(FULLCOQLIB) $(LINKCMO) $(GRAMMARCMA)
+	$(INSTALLSH)  $(FULLCOQLIB) $(INSTALLCMI)
+ifeq ($(BEST),opt)
+	$(INSTALLSH)  $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a)
+endif
+
 install-library:
 	$(MKDIR) $(FULLCOQLIB)
 	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS)
-	$(MKDIR) $(FULLCOQLIB)/states
-	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
 	$(MKDIR) $(FULLCOQLIB)/user-contrib
-ifneq ($(COQRUNBYTEFLAGS),"-custom")
+ifndef CUSTOM
 	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
 endif
-	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG) $(LINKCMO) $(GRAMMARCMA)
-	$(INSTALLSH)  $(FULLCOQLIB) $(INSTALLCMI)
 ifeq ($(BEST),opt)
 	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
-	$(INSTALLSH)  $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT)
+	$(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT)
 endif
 # csdpcert is not meant to be directly called by the user; we install
 # it with libraries
@@ -661,11 +788,13 @@ endif
 install-library-light:
 	$(MKDIR) $(FULLCOQLIB)
 	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS)
-	$(MKDIR) $(FULLCOQLIB)/states
-	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
 	rm -f $(FULLCOQLIB)/revision
 	-$(INSTALLLIB) revision $(FULLCOQLIB)
+ifndef CUSTOM
+	$(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB)
+endif
 ifeq ($(BEST),opt)
+	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
 	$(INSTALLSH)  $(FULLCOQLIB) $(INITPLUGINSOPT)
 endif
 
@@ -677,7 +806,7 @@ install-coq-manpages:
 
 install-emacs:
 	$(MKDIR) $(FULLEMACSLIB)
-	$(INSTALLLIB) tools/coq-db.el tools/coq-font-lock.el tools/coq-syntax.el tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB)
+	$(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/coq-inferior.el $(FULLEMACSLIB)
 
 # command to update TeX' kpathsea database
 #UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null
@@ -695,17 +824,21 @@ install-latex:
 
 source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf
 
-$(OCAMLDOCDIR)/coq.tex:: $(DOCMLIS:.mli=.cmi)
+$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi)
 	$(OCAMLDOC) -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
 	$(DOCMLIS) -t "Coq mlis documentation" \
 	-intro $(OCAMLDOCDIR)/docintro -o $@
 
-mli-doc:: $(DOCMLIS:.mli=.cmi)
-	$(OCAMLDOC) -html -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\
+mli-doc: $(DOCMLIS:.mli=.cmi)
+	$(OCAMLDOC) -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \
 	$(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \
 	-t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \
 	-css-style style.css
 
+ml-dot: $(MLFILES)
+	$(OCAMLDOC) -dot -dot-reduce -rectypes -I +threads -I $(CAMLLIB) -I $(MYCAMLP4LIB) $(MLINCLUDES) \
+	$(filter $(addsuffix /%.ml,$(CORESRCDIRS)),$(MLFILES)) -o $(OCAMLDOCDIR)/coq.dot
+
 %_dep.png: %.dot
 	$(DOT) -Tpng $< -o $@
 
@@ -719,11 +852,14 @@ OCAMLDOC_MLLIBD = $(OCAMLDOC) -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \
 	$(OCAMLDOC_MLLIBD)
 
 ml-doc:
-	$(OCAMLDOC) -html -rectypes $(LOCALINCLUDES) -d $(SOURCEDOCDIR) $(MLSTATICFILES)
+	$(OCAMLDOC) -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES)
 
 parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d
 	$(OCAMLDOC_MLLIBD)
 
+grammar/grammar.dot : | grammar/grammar.mllib.d
+	$(OCAMLDOC_MLLIBD)
+
 tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d
 	$(OCAMLDOC_MLLIBD)
 
@@ -739,46 +875,23 @@ $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex
 
 dev/printers.cma: | dev/printers.mllib.d
 	$(SHOW)'Testing $@'
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $(SYSCMA) $^ -o test-printer
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer
 	@rm -f test-printer
 	$(SHOW)'OCAMLC -a $@'   
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $^ -linkall -a -o $@
 
-parsing/grammar.cma: | parsing/grammar.mllib.d
+grammar/grammar.cma: | grammar/grammar.mllib.d
 	$(SHOW)'Testing $@'
 	@touch test.ml4
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp '$(CAMLP4O) -I $(CAMLLIB) $^ -impl' -impl test.ml4 -o test-grammar
+	$(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $^ -impl test.ml4 -o test.ml
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) test.ml -o test-grammar
 	@rm -f test-grammar test.*
 	$(SHOW)'OCAMLC -a $@'   
-	$(HIDE)$(OCAMLC) $(BYTEFLAGS) $^ -linkall -a -o $@
-
-# toplevel/mltop.ml4 (ifdef Byte)
+	$(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $^ -linkall -a -o $@
 
-## NB: mltop.ml correspond to the byte version (and hence need no special rules)
-## while the opt version is in mltop.optml. Since mltop.optml uses mltop.ml.d
-## as dependency file, be sure to import the same modules in the different sections
-## of the ml4
-
-toplevel/mltop.cmx: toplevel/mltop.optml | toplevel/mltop.ml.d toplevel/mltop.ml4.d
-	$(SHOW)'OCAMLOPT  $<'
-	$(HIDE)$(OCAMLOPT) $(OPTFLAGS) -c -impl $< -o $@
-
-toplevel/mltop.ml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
-	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) -DByte -DHasDynlink -impl $< -o $@
-
-toplevel/mltop.optml: toplevel/mltop.ml4 config/Makefile # no camlp4deps here
-	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(PR_O) $(CAMLP4USE) $(NATDYNLINKDEF) -impl $< -o $@
-
-ide/coqide_main.ml: ide/coqide_main.ml4
+ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here
 	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4USE) -impl $< -o $@
-
-ide/coqide_main_opt.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here
-	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)$(CAMLP4O) $(CAMLP4USE) -D$(IDEOPTINT) -impl $< -o $@
-
+	$(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@
 
 # pretty printing of the revision number when compiling a checked out
 # source tree
@@ -834,17 +947,23 @@ endif
 ## Three flavor of flags: checker/* ide/* and normal files
 
 COND_BYTEFLAGS= \
- $(if $(filter checker/%,$<), $(CHKBYTEFLAGS), \
-   $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(BYTEFLAGS))
+ $(if $(filter checker/%,$<), $(CHKLIBS) -thread, \
+   $(if $(filter ide/%,$<), $(COQIDEFLAGS), \
+     $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) -thread)) $(BYTEFLAGS)
 
 COND_OPTFLAGS= \
- $(if $(filter checker/%,$<), $(CHKOPTFLAGS), \
-   $(if $(filter ide/%,$<),$(COQIDEFLAGS),) $(OPTFLAGS))
+ $(if $(filter checker/%,$<), $(CHKLIBS) -thread, \
+   $(if $(filter ide/%,$<), $(COQIDEFLAGS), \
+     $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) -thread)) $(OPTFLAGS)
 
 %.o: %.c
 	$(SHOW)'OCAMLC    $<'
 	$(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<)
 
+%.o: %.rc
+	$(SHOW)'WINDRES    $<'
+	$(HIDE)i686-w64-mingw32-windres -i $< -o $@
+
 %.cmi: %.mli | %.mli.d
 	$(SHOW)'OCAMLC    $<'
 	$(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $<
@@ -910,19 +1029,16 @@ plugins/%_mod.ml: plugins/%.mllib
 
 %.ml: %.ml4 | %.ml4.d tools/compat5.cmo tools/compat5b.cmo
 	$(SHOW)'CAMLP4O   $<'
-	$(HIDE)\
-	DEPS=$(CAMLP4DEPS); \
-	if ls $${DEPS} > /dev/null 2>&1; then \
-	$(CAMLP4O) $(PR_O) -I $(CAMLLIB) tools/compat5.cmo $${DEPS} $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@; \
-	else echo $< : Dependency $${DEPS} not ready yet; false; fi
+	$(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) tools/compat5.cmo \
+	  $(call CAMLP4DEPS,$<) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@
 
-%.vo %.glob: %.v states/initial.coq $(INITPLUGINSBEST) $(VO_TOOLS_STRICT) | %.v.d  $(VO_TOOLS_ORDER_ONLY)
+%.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) | %.v.d
 	$(SHOW)'COQC      $<'
 	$(HIDE)rm -f $*.glob 
 	$(HIDE)$(BOOTCOQC) $*
 ifdef VALIDATE
 	$(SHOW)'COQCHK    $(call vo_to_mod,$@)'
-	$(HIDE)$(BESTCHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
+	$(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \
 	  || ( RV=$$?; rm -f "$@"; exit $${RV} )
 endif
 
@@ -935,20 +1051,20 @@ endif
 
 %.ml4.d: $(D_DEPEND_BEFORE_SRC) %.ml4
 	$(SHOW)'CAMLP4DEPS $<'
-	$(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(CAMLP4DEPS)" $(TOTARGET)
+	$(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(call CAMLP4DEPS,$<)" $(TOTARGET)
 
-# We now use coqdep_boot to wrap around ocamldep -modules, since it is aware
-# of .ml4 files
+# Since OCaml 3.12.1, we could use again ocamldep directly, thanks to
+# the option -ml-synonym
 
-OCAMLDEP_NG = $(COQDEPBOOT) -mldep $(OCAMLDEP)
+OCAMLDEP_NG = $(OCAMLDEP) -slash -ml-synonym .ml4
 
 checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET)
+	$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
 
 checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
-	$(HIDE)$(OCAMLDEP_NG) -slash $(LOCALCHKLIBS) "$<" $(TOTARGET)
+	$(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET)
 
 %.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'OCAMLDEP  $<'
@@ -960,15 +1076,15 @@ checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(CO
 
 checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'COQDEP  $<'
-	$(HIDE)$(COQDEPBOOT) -slash -I checker -c "$<" $(TOTARGET)
+	$(HIDE)$(COQDEPBOOT) -I checker -c "$<" $(TOTARGET)
 
 %.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENFILES)
 	$(SHOW)'COQDEP  $<'
-	$(HIDE)$(COQDEPBOOT) -slash -I kernel -I tools/coqdoc -c "$<" $(TOTARGET)
+	$(HIDE)$(COQDEPBOOT) -I kernel -I tools/coqdoc -c "$<" $(TOTARGET)
 
 %.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES)
 	$(SHOW)'COQDEP    $<'
-	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) -slash "$<" $(TOTARGET)
+	$(HIDE)$(COQDEPBOOT) $(DEPNATDYN) "$<" $(TOTARGET)
 
 %_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC)
 	$(SHOW)'CCDEP	$<'
@@ -982,11 +1098,20 @@ checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC)
 # this sets up developper supporting stuff
 ###########################################################################
 
-.PHONY: devel
+.PHONY: devel otags
 devel: $(DEBUGPRINTERS)
 
+otags:
+	otags $(MLIFILES) $(MLSTATICFILES) \
+	$(foreach i,$(ML4FILES),-pc -pa tools/compat5.cmo -pa op -pa g -pa m -pa rq $(patsubst %,-pa %,$(call CAMLP4DEPS,$i)) -impl $i)
+
+
 ###########################################################################
 
+# To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles
+
+Makefile Makefile.build Makefile.common config/Makefile : ;
+
 
 # For emacs: 
 # Local Variables: 
diff --git a/Makefile.common b/Makefile.common
index 444a7ee5..d752a5be 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -12,28 +12,16 @@
 # Executables
 ###########################################################################
 
-COQMKTOPBYTE:=bin/coqmktop.byte$(EXE)
-COQMKTOPOPT:=bin/coqmktop.opt$(EXE)
-BESTCOQMKTOP:=bin/coqmktop.$(BEST)$(EXE)
 COQMKTOP:=bin/coqmktop$(EXE) 
 
-COQCBYTE:=bin/coqc.byte$(EXE)
-COQCOPT:=bin/coqc.opt$(EXE)
-BESTCOQC:=bin/coqc.$(BEST)$(EXE)
 COQC:=bin/coqc$(EXE)
 
 COQTOPBYTE:=bin/coqtop.byte$(EXE)
-COQTOPOPT:=bin/coqtop.opt$(EXE)
-BESTCOQTOP:=bin/coqtop.$(BEST)$(EXE)
 COQTOPEXE:=bin/coqtop$(EXE)
 
 CHICKENBYTE:=bin/coqchk.byte$(EXE)
-CHICKENOPT:=bin/coqchk.opt$(EXE)
-BESTCHICKEN:=bin/coqchk.$(BEST)$(EXE)
 CHICKEN:=bin/coqchk$(EXE)
 
-FAKEIDE:=bin/fake_ide$(EXE)
-
 ifeq ($(CAMLP4),camlp4)
 CAMLP4MOD:=camlp4lib
 else
@@ -41,12 +29,8 @@ CAMLP4MOD:=gramlib
 endif
 
 ifeq ($(HASNATDYNLINK)-$(BEST),true-opt)
-  DYNLINKCMXA:=dynlink.cmxa
-  NATDYNLINKDEF:=-DHasDynlink
   DEPNATDYN:=
 else
-  DYNLINKCMXA:=
-  NATDYNLINKDEF:=
   DEPNATDYN:=-natdynlink no
 endif
 
@@ -56,8 +40,9 @@ INSTALLSH:=./install.sh
 MKDIR:=install -d
 
 COQIDEBYTE:=bin/coqide.byte$(EXE)
-COQIDEOPT:=bin/coqide.opt$(EXE)
 COQIDE:=bin/coqide$(EXE)
+COQIDEAPP:=bin/CoqIDE_$(VERSION).app
+COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide
 
 ifeq ($(BEST),opt)
 OPT:=opt
@@ -66,35 +51,39 @@ OPT:=
 endif
 
 BESTOBJ:=$(if $(OPT),.cmx,.cmo)
+BESTLIB:=$(if $(OPT),.cmxa,.cma)
+BESTDYN:=$(if $(OPT),.cmxs,.cma)
 
-COQBINARIES:= $(COQMKTOP) $(COQC) \
-  $(COQTOPBYTE) $(if $(OPT),$(COQTOPOPT)) $(COQTOPEXE) \
-  $(CHICKENBYTE) $(if $(OPT),$(CHICKENOPT)) $(CHICKEN)
+COQBINARIES:= $(COQMKTOP) \
+  $(COQTOPBYTE) $(COQTOPEXE) \
+  $(CHICKENBYTE) $(CHICKEN)
 
 CSDPCERT:=plugins/micromega/csdpcert$(EXE)
 
 CORESRCDIRS:=\
   config 	lib		kernel		kernel/byterun	library \
-  proofs 	tactics 	pretyping	interp		toplevel \
-  parsing
+  proofs 	tactics 	pretyping	interp		stm \
+  toplevel	parsing	printing	grammar	        intf
 
 PLUGINS:=\
-  omega		romega 		micromega 	quote		ring \
-  setoid_ring 	xml 		extraction 	fourier \
-  cc 		funind 		firstorder 	field 		subtac \
-  rtauto 	nsatz           syntax          decl_mode
+  omega		romega 		micromega 	quote \
+  setoid_ring 	extraction 	fourier \
+  cc 		funind 		firstorder 	derive \
+  rtauto 	nsatz           syntax          decl_mode	btauto
 
 SRCDIRS:=\
   $(CORESRCDIRS)  \
-  tools 	tools/coqdoc 	scripts		ide/utils	ide \
+  tools 	tools/coqdoc	\
   $(addprefix plugins/, $(PLUGINS))
 
-# Order is relevent here because kernel and checker contain files
+IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils
+
+# Order is relevant here because kernel and checker contain files
 # with the same name
-CHKSRCDIRS:= checker lib config kernel
+CHKSRCDIRS:= checker lib config kernel parsing
 
 ###########################################################################
-# tools
+# Tools
 ###########################################################################
 
 COQDEP:=bin/coqdep$(EXE)
@@ -104,8 +93,13 @@ GALLINA:=bin/gallina$(EXE)
 COQTEX:=bin/coq-tex$(EXE)
 COQWC:=bin/coqwc$(EXE)
 COQDOC:=bin/coqdoc$(EXE)
+FAKEIDE:=bin/fake_ide$(EXE)
+COQWORKMGR:=bin/coqworkmgr$(EXE)
+
+TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\
+	$(COQWORKMGR)
 
-TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC)
+PRIVATEBINARIES:=$(FAKEIDE) $(COQDEPBOOT)
 
 ###########################################################################
 # Documentation
@@ -130,11 +124,11 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \
   RefMan-cic.v.tex RefMan-lib.v.tex \
   RefMan-tacex.v.tex RefMan-syn.v.tex \
   RefMan-oth.v.tex RefMan-ltac.v.tex \
-  RefMan-decl.v.tex RefMan-sch.v.tex \
-  RefMan-pro.v.tex \
-  Cases.v.tex Coercion.v.tex Extraction.v.tex \
+  RefMan-decl.v.tex RefMan-pro.v.tex RefMan-sch.v.tex \
+  Cases.v.tex Coercion.v.tex CanonicalStructures.v.tex Extraction.v.tex \
   Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \
-  Setoid.v.tex Helm.tex Classes.v.tex )
+  Setoid.v.tex Classes.v.tex AsyncProofs.v.tex Universes.v.tex \
+  Misc.v.tex)
 
 REFMANTEXFILES:=$(addprefix doc/refman/, \
   headers.sty Reference-Manual.tex \
@@ -158,8 +152,6 @@ COQRUN := coqrun
 LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a
 DLLCOQRUN:=$(dir $(LIBCOQRUN))dll$(COQRUN)$(DLLEXT)
 
-CONFIG:=config/coq_config.cmo
-
 BYTERUN:=$(addprefix kernel/byterun/, \
   coq_fix_code.o coq_memory.o coq_values.o coq_interp.o )
 
@@ -168,28 +160,27 @@ BYTERUN:=$(addprefix kernel/byterun/, \
 # respecting this order is useful for developers that want to load or link
 # the libraries directly
 
-CORECMA:=lib/lib.cma kernel/kernel.cma library/library.cma \
+CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \
         pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \
-        parsing/parsing.cma tactics/tactics.cma toplevel/toplevel.cma \
-        parsing/highparsing.cma tactics/hightactics.cma 
+        parsing/parsing.cma printing/printing.cma tactics/tactics.cma \
+	stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma tactics/hightactics.cma
+
+TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma
 
-GRAMMARCMA:=parsing/grammar.cma
+GRAMMARCMA:=tools/compat5.cmo grammar/grammar.cma
 
 OMEGACMA:=plugins/omega/omega_plugin.cma
 ROMEGACMA:=plugins/romega/romega_plugin.cma
 MICROMEGACMA:=plugins/micromega/micromega_plugin.cma
 QUOTECMA:=plugins/quote/quote_plugin.cma
-RINGCMA:=plugins/ring/ring_plugin.cma
-NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma
+RINGCMA:=plugins/setoid_ring/newring_plugin.cma
 NSATZCMA:=plugins/nsatz/nsatz_plugin.cma
-FIELDCMA:=plugins/field/field_plugin.cma
-XMLCMA:=plugins/xml/xml_plugin.cma
 FOURIERCMA:=plugins/fourier/fourier_plugin.cma
 EXTRACTIONCMA:=plugins/extraction/extraction_plugin.cma
 FUNINDCMA:=plugins/funind/recdef_plugin.cma
 FOCMA:=plugins/firstorder/ground_plugin.cma
 CCCMA:=plugins/cc/cc_plugin.cma
-SUBTACCMA:=plugins/subtac/subtac_plugin.cma
+BTAUTOCMA:=plugins/btauto/btauto_plugin.cma
 RTAUTOCMA:=plugins/rtauto/rtauto_plugin.cma
 NATSYNTAXCMA:=plugins/syntax/nat_syntax_plugin.cma
 OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \
@@ -199,17 +190,19 @@ OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \
 	ascii_syntax_plugin.cma \
         string_syntax_plugin.cma )
 DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma
+DERIVECMA:=plugins/derive/derive_plugin.cma
 
 PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \
-        $(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \
-        $(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \
-        $(CCCMA)  $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \
-        $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA)
+        $(QUOTECMA) $(RINGCMA) \
+        $(FOURIERCMA) $(EXTRACTIONCMA) \
+        $(CCCMA)  $(FOCMA) $(RTAUTOCMA) $(BTAUTOCMA) \
+        $(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA) \
+	$(DERIVECMA)
 
 ifneq ($(HASNATDYNLINK),false)
  STATICPLUGINS:=
  INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \
-	$(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA)
+	$(FUNINDCMA) $(NATSYNTAXCMA)
  INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
  PLUGINS:=$(PLUGINSCMA)
  PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs)
@@ -221,34 +214,29 @@ else
  PLUGINSOPT:=
 endif
 
-INITPLUGINSBEST:=$(if $(OPT),$(INITPLUGINSOPT),$(INITPLUGINS))
+LINKCMO:=$(CORECMA) $(STATICPLUGINS)
+LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa)
 
-LINKCMO:=$(CONFIG) $(CORECMA) $(STATICPLUGINS)
-LINKCMX:=$(CONFIG:.cmo=.cmx) $(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa)
-
-IDEDEPS:=$(CONFIG) lib/flags.cmo lib/xml_lexer.cmo lib/xml_parser.cmo \
-  lib/xml_utils.cmo toplevel/ide_intf.cmo
+IDEDEPS:=lib/clib.cma lib/xml_lexer.cmo lib/xml_parser.cmo lib/xml_printer.cmo lib/errors.cmo lib/spawn.cmo
 IDECMA:=ide/ide.cma
+IDETOPLOOPCMA=ide/coqidetop.cma
 
-LINKIDE:=$(IDEDEPS) $(IDECMA) ide/coqide_main.ml
-LINKIDEOPT:=$(IDEOPTDEPS) $(IDEDEPS:.cmo=.cmx) $(IDECMA:.cma=.cmxa) ide/coqide_main_opt.ml
+LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml
+LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml
 
 # modules known by the toplevel of Coq
 
-OBJSMOD:=Coq_config $(shell cat $(CORECMA:.cma=.mllib))
+OBJSMOD:=$(shell cat $(CORECMA:.cma=.mllib))
 
 IDEMOD:=$(shell cat ide/ide.mllib)
 
 # coqmktop, coqc
 
-COQENVCMO:=$(CONFIG) \
-  lib/pp_control.cmo lib/pp.cmo  lib/compat.cmo lib/flags.cmo \
-  lib/segmenttree.cmo lib/unicodetable.cmo lib/util.cmo lib/errors.cmo lib/system.cmo \
-  lib/envars.cmo
+COQENVCMO:=lib/clib.cma lib/errors.cmo
 
-COQMKTOPCMO:=$(COQENVCMO) scripts/tolink.cmo scripts/coqmktop.cmo 
+COQMKTOPCMO:=$(COQENVCMO) tools/tolink.cmo tools/coqmktop.cmo
 
-COQCCMO:=$(COQENVCMO) toplevel/usage.cmo scripts/coqc.cmo
+COQCCMO:=$(COQENVCMO) toplevel/usage.cmo tools/coqc.cmo
 
 ## Misc
 
@@ -260,9 +248,11 @@ DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma
 
 COQDEPCMO:=$(COQENVCMO) tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo
 
-COQDOCCMO:=$(CONFIG) $(addprefix tools/coqdoc/, \
+COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \
   cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo )
 
+COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo
+
 ###########################################################################
 # vo files
 ###########################################################################
@@ -299,13 +289,16 @@ CLASSESVO:=$(call cat_vo_itarget, theories/Classes)
 PROGRAMVO:=$(call cat_vo_itarget, theories/Program)
 
 THEORIESVO:=\
-  $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(PARITHVO) $(NARITHVO) $(ZARITHVO) \
-  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(MSETSVO) \
-  $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
-  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO) \
-  $(VECTORSVO)
+  $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) \
+  $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) \
+  $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \
+  $(LISTSVO) $(STRINGSVO) \
+  $(PARITHVO) $(NARITHVO) $(ZARITHVO) \
+  $(SETSVO) $(FSETSVO) $(MSETSVO) \
+  $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
+  $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO)
 
-THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(ARITHVO)
+THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(UNICODEVO) $(ARITHVO)
 
 ## Plugins
 
@@ -313,21 +306,20 @@ OMEGAVO:=$(call cat_vo_itarget, plugins/omega)
 ROMEGAVO:=$(call cat_vo_itarget, plugins/romega)
 MICROMEGAVO:=$(call cat_vo_itarget, plugins/micromega)
 QUOTEVO:=$(call cat_vo_itarget, plugins/quote)
-RINGVO:=$(call cat_vo_itarget, plugins/ring)
-FIELDVO:=$(call cat_vo_itarget, plugins/field)
-NEWRINGVO:=$(call cat_vo_itarget, plugins/setoid_ring)
+RINGVO:=$(call cat_vo_itarget, plugins/setoid_ring)
 NSATZVO:=$(call cat_vo_itarget, plugins/nsatz)
 FOURIERVO:=$(call cat_vo_itarget, plugins/fourier)
 FUNINDVO:=$(call cat_vo_itarget, plugins/funind)
+BTAUTOVO:=$(call cat_vo_itarget, plugins/btauto)
 RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto)
 EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction)
-XMLVO:=
 CCVO:=
+DERIVEVO:=$(call cat_vo_itarget, plugins/derive)
 
-PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
-	    $(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \
-	    $(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \
-            $(NSATZVO) $(EXTRACTIONVO)
+PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) \
+	    $(FOURIERVO) $(CCVO) $(FUNINDVO) \
+	    $(RTAUTOVO) $(BTAUTOVO) $(RINGVO) $(QUOTEVO) \
+            $(NSATZVO) $(EXTRACTIONVO) $(DERIVEVO)
 
 ALLVO:= $(THEORIESVO) $(PLUGINSVO)
 VFILES:= $(ALLVO:.vo=.v)
@@ -337,9 +329,20 @@ ALLSTDLIB := test-suite/misc/universes/all_stdlib
 # remove .vo, replace theories and plugins by Coq, and replace slashes by dots
 vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=))))
 
+# Converting a stdlib filename into native compiler filenames
+# Used for install targets
+vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.cm*)))))
+
+vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o)))))
+
 ALLMODS:=$(call vo_to_mod,$(ALLVO))
 
-LIBFILES:=$(THEORIESVO) $(PLUGINSVO)
+LIBFILES:=$(THEORIESVO) $(PLUGINSVO) $(call vo_to_cm,$(THEORIESVO)) \
+	    $(call vo_to_cm,$(PLUGINSVO)) $(call vo_to_obj,$(THEORIESVO)) \
+	    $(call vo_to_obj,$(PLUGINSVO)) \
+	    $(PLUGINSVO:.vo=.v) $(THEORIESVO:.vo=.v) \
+	    $(PLUGINSVO:.vo=.glob) $(THEORIESVO:.vo=.glob)
+
 LIBFILESLIGHT:=$(THEORIESLIGHTVO)
 
 ###########################################################################
@@ -357,15 +360,24 @@ MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \
 
 OCAMLDOCDIR=dev/ocamldoc
 
-DOCMLIS=$(wildcard ./lib/*.mli ./kernel/*.mli ./library/*.mli \
-	./pretyping/*.mli ./interp/*.mli \
+DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \
+	./pretyping/*.mli ./interp/*.mli printing/*.mli \
 	./parsing/*.mli ./proofs/*.mli \
-	./tactics/*.mli ./toplevel/*.mli)
+	./tactics/*.mli ./stm/*.mli ./toplevel/*.mli)
 
 # Defining options to generate dependencies graphs
 DOT=dot
 ODOCDOTOPTS=-dot -dot-reduce
 
+###########################################################################
+# GTK for Coqide MacOS bundle
+###########################################################################
+
+GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share
+GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin
+GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0)
+
+
 # For emacs: 
 # Local Variables: 
 # mode: makefile 
diff --git a/Makefile.doc b/Makefile.doc
index 31a0675c..bc6ae020 100644
--- a/Makefile.doc
+++ b/Makefile.doc
@@ -1,7 +1,5 @@
 # Makefile for the Coq documentation
 
-# COQSRC needs to be set to a coq source repository
-
 # To compile documentation, you need the following tools:
 # Dvi: latex (latex2e), bibtex, makeindex
 # Pdf: pdflatex
@@ -118,7 +116,7 @@ doc/refman/Reference-Manual.html: doc/refman/styles.hva doc/refman/headers.hva d
 	(cd doc/refman; BIBINPUTS=.: $(HEVEA) $(HEVEAOPTS) ./styles.hva ./Reference-Manual.tex)
 
 doc/refman/cover.html: doc/common/styles/html/$(HTMLSTYLE)/cover.html
-	$(INSTALLLIB) $< doc/refman
+	sed -e "s/COQVERSION/$(VERSION)/g" $< > $@
 
 doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva
 	$(INSTALLLIB) $< doc/refman
@@ -148,7 +146,7 @@ refman-quick:
 ######################################################################
 
 $(INDEXURLS): $(INDEXES)
-	cat $< | grep li-indexenv | grep HREF | sed -e 's@.*<TT>\(.*\)</TT>.*, <A HREF="\(.*\)">.*@\1,\2@' > $@
+	cat $< | grep li-indexenv | grep href= | sed -e 's@.*>\([^<]*\)</span>.*, <a href="\([^"]*\)">.*@\1,\2@' > $@
 
 
 ######################################################################
@@ -322,9 +320,8 @@ install-doc-printable:
 	$(INSTALLLIB) doc/faq/FAQ.v.ps $(FULLDOCDIR)/ps/FAQ.ps
 
 install-doc-index-urls:
-	$(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf
-	$(INSTALLLIB) $(INDEXURLS) \
-		$(FULLDOCDIR)/html/refman 
+	$(MKDIR) $(FULLDATADIR)
+	$(INSTALLLIB) $(INDEXURLS) $(FULLDATADIR)
 
 # For emacs:
 # Local Variables:
diff --git a/README b/README
index 1755be5f..293ee4c8 100644
--- a/README
+++ b/README
@@ -27,18 +27,15 @@ CHANGES.
 AVAILABILITY.
 =============
 
-   Coq is available at http://coq.inria.fr, or, for older versions at
-   ftp://ftp.inria.fr/INRIA/Projects/LogiCal/coq.
+   Coq is available from http://coq.inria.fr.
 
 
 THE COQ CLUB.
 =============
 
-   The Coq Club moderated mailing list is meant to be a standard way to
-   discuss questions about the Coq system and related topics. The submission
-   address is:
-
-	coq-club@inria.fr
+   The Coq Club moderated mailing list is meant to be a standard way
+   to discuss questions about the Coq system and related topics. The
+   subscription link can be found at http://coq.inria.fr/community.
 
    The topics to be discussed in the club should include:
 
@@ -53,13 +50,8 @@ THE COQ CLUB.
      * theoretical questions about typed lambda-calculi which are
        closely related to Coq.
 
-   To be added to, or removed from, the mailing list, please write to:
-
-	coq-club-request@inria.fr
-
-   Please use also this address for any questions/suggestions about the
-   Coq Club. It might sometimes take a few days before your messages get
-   forwarded.
+   For any questions/suggestions about the Coq Club, please write to
+   coq-club-request@inria.fr.
 
 
 BUGS REPORT.
diff --git a/_tags b/_tags
index a8b4ff1a..8cb8b1f9 100644
--- a/_tags
+++ b/_tags
@@ -1,40 +1,30 @@
 
 ## tags for binaries
 
-<scripts/coqmktop.{native,byte}> : use_str, use_unix, use_dynlink, use_camlpX
-<scripts/coqc.{native,byte}> : use_unix, use_dynlink, use_camlpX
+<tools/coqmktop.{native,byte}> : use_str, use_unix
+<tools/coqc.{native,byte}> : use_str, use_unix
 <tools/coqdep_boot.{native,byte}> : use_unix
-<tools/coqdep.{native,byte}> : use_unix, use_dynlink, use_camlpX
+<tools/coqdep.{native,byte}> : use_str, use_unix
 <tools/coq_tex.{native,byte}> : use_str
 <tools/coq_makefile.{native,byte}> : use_str, use_unix
 <tools/coqdoc/main.{native,byte}> : use_str
-<ide/coqide_main.{native,byte}> : use_str, use_unix, thread, ide, use_camlpX
-<checker/main.{native,byte}> : use_str, use_unix, use_dynlink, use_camlpX
+<ide/coqide_main.{native,byte}> : use_str, use_unix, ide
+<checker/main.{native,byte}> : use_str, use_unix, thread
 <plugins/micromega/csdpcert.{native,byte}> : use_nums, use_unix
 <tools/mkwinapp.{native,byte}> : use_unix
-<tools/fake_ide.{native,byte}> : use_unix, use_camlpX
+<tools/fake_ide.{native,byte}> : use_unix, use_str
 
 ## tags for ide
 
-<ide/**/*.{ml,mli}>: thread, ide
+<ide/**/*.{ml,mli}>: ide
 
 ## tags for grammar.cm*
 
-<parsing/grammar.{cma,cmxa}> : use_unix
+<grammar/grammar.{cma,cmxa}> : use_unix
 
 ## tags for camlp4 files 
 
-"toplevel/mltop.ml4": is_mltop
-
 "toplevel/whelp.ml4": use_grammar
-"tactics/extraargs.ml4": use_grammar
-"tactics/extratactics.ml4": use_grammar
-"tactics/class_tactics.ml4": use_grammar
-"tactics/eauto.ml4": use_grammar
-"tactics/tauto.ml4": use_grammar
-"tactics/eqdecide.ml4": use_grammar
-"tactics/hipattern.ml4": use_grammar, use_constr
-"tactics/rewrite.ml4": use_grammar
 
 "parsing/g_constr.ml4": use_compat5
 "parsing/g_ltac.ml4": use_compat5
@@ -44,16 +34,19 @@
 "parsing/g_vernac.ml4": use_compat5
 "parsing/g_xml.ml4": use_compat5
 "parsing/pcoq.ml4": use_compat5
-"plugins/decl_mode/g_decl_mode.ml4": use_compat5
-"plugins/funind/g_indfun.ml4": use_compat5
-"plugins/subtac/g_subtac.ml4": use_compat5
+"parsing/g_obligations.ml4": use_grammar
 
-"parsing/argextend.ml4": use_compat5b
-"parsing/q_constr.ml4": use_compat5b
-"parsing/tacextend.ml4": use_compat5b
-"parsing/vernacextend.ml4": use_compat5b
+"grammar/argextend.ml4": use_compat5b
+"grammar/q_constr.ml4": use_compat5b
+"grammar/tacextend.ml4": use_compat5b
+"grammar/vernacextend.ml4": use_compat5b
+
+<tactics/*.ml4>: use_grammar
+"tactics/hipattern.ml4": use_constr
 
 <plugins/**/*.ml4>: use_grammar
+"plugins/decl_mode/g_decl_mode.ml4": use_compat5
+"plugins/funind/g_indfun.ml4": use_compat5
 
 ## sub-directory inclusion
 
@@ -64,6 +57,8 @@
 "ide": include
 "ide/utils": include
 "interp": include
+"intf": include
+"grammar": include
 "kernel": include
 "kernel/byterun": include
 "lib": include
@@ -71,9 +66,8 @@
 "parsing": include
 "plugins": include
 "pretyping": include
+"printing": include
 "proofs": include
-"scripts": include
-"states": include
 "tactics": include
 "theories": include
 "tools": include
diff --git a/build b/build
index 4fca642e..debf29cf 100755
--- a/build
+++ b/build
@@ -1,25 +1,21 @@
 #!/bin/sh
 
-FLAGS=
+FLAGS="-j 2"
 OCAMLBUILD=ocamlbuild
-CFG=config/coq_config.ml
 MYCFG=myocamlbuild_config.ml
 
 export CAML_LD_LIBRARY_PATH=`pwd`/_build/kernel/byterun
 
 check_config() {
- [ -f $CFG ] || (echo "please run ./configure first"; exit 1)
- [ -L $MYCFG ] || ln -sf $CFG $MYCFG
+ if [ ! -f $MYCFG ]; then echo "please run ./configure first"; exit 1; fi
 }
 
-# NB: we exec ocamlbuild and run ocb last for a correct exit code
-
-ocb() { exec $OCAMLBUILD $FLAGS $*; }
+ocb() { $OCAMLBUILD $FLAGS $*; }
 
 rule() {
   check_config
   case $1 in
-    clean)  rm -rf bin/* $MYCFG && ocb -clean;;
+    clean)  ocb -clean && rm -rf bin/*;;
     all)    ocb coq.otarget;;
     win32)  ocb coq-win32.otarget;;
     *)      ocb $1;;
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]")
diff --git a/config/coq_config.mli b/config/coq_config.mli
index bdfab7dc..c63ba65d 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.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        *)
@@ -36,8 +36,9 @@ val cflags : string     (* arguments passed to gcc *)
 
 val best : string       (* byte/opt *)
 val arch : string       (* architecture *)
+val arch_is_win32 : bool
 val osdeplibs : string  (* OS dependant link options for ocamlc *)
-val coqrunbyteflags : string (* -custom/-dllib -lcoqrun *)
+val vmbyteflags : string list (* -custom/-dllib -lcoqrun *)
 
 
 (* val defined : string list  (* options for lib/ocamlpp *) *)
@@ -49,7 +50,6 @@ val compile_date : string (* compile date *)
 val vo_magic_number : int
 val state_magic_number : int
 
-val theories_dirs : string list
 val plugins_dirs : string list
 
 val exec_extension : string (* "" under Unix, ".exe" under MS-windows *)
@@ -70,3 +70,4 @@ val wwwrefman : string
 val wwwstdlib : string
 val localwwwrefman : string
 
+val no_native_compiler : bool
diff --git a/configure b/configure
index cb43a73d..09585e59 100755
--- a/configure
+++ b/configure
@@ -1,1294 +1,37 @@
 #!/bin/sh
 
-##################################
-#
-#  Configuration script for Coq
-# 
-##################################
+## This micro-configure shell script is here only to
+## launch the real configuration via ocaml
 
-VERSION=8.4pl4
-VOMAGIC=08400
-STATEMAGIC=58400
-DATE=`LC_ALL=C LANG=C date +"%B %Y"`
+cmd=ocaml
+script=./configure.ml
 
-# Create the bin/ directory if non-existent
-test -d bin || mkdir bin
-
-# a local which command for sh
-which () {
-IFS=":" # set words separator in PATH to be ':' (it allows spaces in dirnames)
-for i in $PATH; do
-  if test -z "$i"; then i=.; fi 
-  if [ -f "$i/$1" ] ; then
-	IFS=" "
-        echo "$i/$1"
-	break
-  fi
-done
-}
-
-usage () {
-    printf "Available options for configure are:\n"
-    echo "-help"
-    printf "\tDisplays this help page\n"
-    echo "-prefix <dir>"
-    printf "\tSet installation directory to <dir>\n"
-    echo "-local"
-    printf "\tSet installation directory to the current source tree\n"
-    echo "-coqrunbyteflags <flags>"
-    printf "\tSet link flags for VM-dependent bytecode (coqtop)\n"
-    echo "-coqtoolsbyteflags <flags>"
-    printf "\tSet link flags for VM-independant bytecode (coqdep, coqdoc, ...)\n"
-    echo "-custom"
-    printf "\tGenerate all bytecode executables with -custom (not recommended)\n"
-    echo "-src <dir>"
-    printf "\tSpecifies the source directory\n"
-    echo "-bindir <dir>"
-    echo "-libdir <dir>"
-    echo "-configdir <dir>"
-    echo "-datadir <dir>"
-    echo "-mandir <dir>"
-    echo "-docdir <dir>"
-    printf "\tSpecifies where to install bin/lib/config/data/man/doc files resp.\n"
-    echo "-emacslib <dir>"
-    printf "\tSpecifies where emacs files are to be installed\n"
-    echo "-coqdocdir <dir>"
-    printf "\tSpecifies where Coqdoc style files are to be installed\n"
-    echo "-camldir <dir>"
-    printf "\tSpecifies the path to the OCaml library\n"
-    echo "-lablgtkdir <dir>"
-    printf "\tSpecifies the path to the Lablgtk library\n"
-    echo "-usecamlp5"
-    printf "\tSpecifies to use camlp5 instead of camlp4\n"
-    echo "-usecamlp4"
-    printf "\tSpecifies to use camlp4 instead of camlp5\n"
-    echo "-camlp5dir <dir>"
-    printf "\tSpecifies where to look for the Camlp5 library and tells to use it\n"
-    echo "-arch <arch>"
-    printf "\tSpecifies the architecture\n"
-    echo "-opt"
-    printf "\tSpecifies whether or not to use OCaml *.opt optimized compilers\n"
-    echo "-natdynlink (yes|no)"
-    printf "\tSpecifies whether or not to use dynamic loading of native code\n"
-    echo "-coqide (opt|byte|no)"
-    printf "\tSpecifies whether or not to compile Coqide\n"
-    echo "-nomacintegration"
-    printf "\tSpecifies to not try to build coqide mac integration\n"
-    echo "-browser <command>"
-    printf "\tUse <command> to open URL %%s\n"
-    echo "-with-doc (yes|no)"
-    printf "\tSpecifies whether or not to compile the documentation\n"
-    echo "-with-geoproof (yes|no)"
-    printf "\tSpecifies whether or not to use Geoproof binding\n"
-    echo "-byte-only"
-    printf "\tCompiles only bytecode version of Coq\n"
-    echo "-debug"
-    printf "\tAdd debugging information in the Coq executables\n"
-    echo "-profile"
-    printf "\tAdd profiling information in the Coq executables\n"
-    echo "-annotate"
-    printf "\tCompiles Coq with -dtypes option\n"
-    echo "-makecmd <command>"
-    printf "\tName of GNU Make command.\n"
-}
-
-
-# Default OCaml binaries
-bytecamlc=ocamlc
-nativecamlc=ocamlopt
-ocamlmklibexec=ocamlmklib
-ocamlexec=ocaml
-ocamldepexec=ocamldep
-ocamldocexec=ocamldoc
-ocamllexexec=ocamllex
-ocamlyaccexec=ocamlyacc
-ocamlmktopexec=ocamlmktop
-camlp4oexec=camlp4o
-
-
-coq_debug_flag=
-coq_debug_flag_opt=
-coq_profile_flag=
-coq_annotate_flag=
-best_compiler=opt
-cflags="-Wall -Wno-unused"
-natdynlink=yes
-
-local=false
-coqrunbyteflags_spec=no
-coqtoolsbyteflags_spec=no
-custom_spec=no
-src_spec=no
-prefix_spec=no
-bindir_spec=no
-libdir_spec=no
-configdir_spec=no
-datadir_spec=no
-mandir_spec=no
-docdir_spec=no
-emacslib_spec=no
-emacs_spec=no
-camldir_spec=no
-lablgtkdir_spec=no
-coqdocdir_spec=no
-arch_spec=no
-coqide_spec=no
-nomacintegration_spec=no
-browser_spec=no
-wwwcoq_spec=no
-with_geoproof=false
-with_doc=all
-with_doc_spec=no
-force_caml_version=no
-force_caml_version_spec=no
-usecamlp5=yes
-
-COQSRC=`pwd`
-
-# Parse command-line arguments
-
-while : ; do
-  case "$1" in
-    "") break;;
-    -help|--help) usage
-	          exit;;
-    -prefix|--prefix) prefix_spec=yes
-                      prefix="$2"
-		      shift;;
-    -local|--local) local=true;;
-    -coqrunbyteflags|--coqrunbyteflags) coqrunbyteflags_spec=yes
-                                        coqrunbyteflags="$2"
-                                        shift;;
-    -coqtoolsbyteflags|--coqtoolsbyteflags) coqtoolsbyteflags_spec=yes
-                                            coqtoolsbyteflags="$2"
-                                            shift;;
-    -custom|--custom) custom_spec=yes;;
-    -src|--src) src_spec=yes
-                COQSRC="$2"
-	        shift;;
-    -bindir|--bindir) bindir_spec=yes
-                      bindir="$2"
-		      shift;;
-    -libdir|--libdir) libdir_spec=yes
-                      libdir="$2"
-		      shift;;
-    -configdir|--configdir) configdir_spec=yes
-                      configdir="$2"
-		      shift;;
-    -datadir|--datadir) datadir_spec=yes
-                      datadir="$2"
-		      shift;;
-    -mandir|--mandir) mandir_spec=yes
-                      mandir="$2"
-		      shift;;
-    -docdir|--docdir) docdir_spec=yes
-                      docdir="$2"
-		      shift;;
-    -emacslib|--emacslib) emacslib_spec=yes
-                          emacslib="$2"
-			  shift;;
-    -emacs |--emacs) emacs_spec=yes
-		     emacs="$2"
-                     printf "Warning: obsolete -emacs option\n"
-		     shift;;
-    -coqdocdir|--coqdocdir) coqdocdir_spec=yes
-	              coqdocdir="$2"
-		      shift;;
-    -camldir|--camldir) camldir_spec=yes
-	                camldir="$2"
-			shift;;
-    -lablgtkdir|--lablgtkdir) lablgtkdir_spec=yes
-	                lablgtkdir="$2"
-			shift;;
-    -usecamlp5|--usecamlp5)
-	                usecamlp5=yes;;
-    -usecamlp4|--usecamlp4)
-	                usecamlp5=no;;
-    -camlp5dir|--camlp5dir)
-                        usecamlp5=yes
-	                camlp5dir="$2"
-			shift;;
-    -arch|--arch) arch_spec=yes
-                  arch=$2
-		  shift;;
-    -opt|--opt) bytecamlc=ocamlc.opt
-                camlp4oexec=camlp4o  # can't add .opt since dyn load'll be required
-                nativecamlc=ocamlopt.opt;;
-    -natdynlink|--natdynlink) case "$2" in
-	                  yes) natdynlink=yes;;
-                          *) natdynlink=no
-                        esac
-                        shift;;
-    -coqide|--coqide) coqide_spec=yes
-		      case "$2" in
-			  byte|opt) COQIDE=$2;;
-			  *) COQIDE=no
-		      esac
-		      shift;;
-    -nomacintegration) nomacintegration_spec=yes
-		      shift;;
-    -browser|--browser) browser_spec=yes
-		      BROWSER=$2
-		      shift;;
-    -coqwebsite|--coqwebsite) wwwcoq_spec=yes
-                      WWWCOQ=$2
-                      shift;;
-    -with-doc|--with-doc) with_doc_spec=yes
-		      case "$2" in
-			  yes|all) with_doc=all;;
-			  *) with_doc=no
-		      esac
-		      shift;;
-    -with-geoproof|--with-geoproof) 
-	  case "$2" in
-	      yes) with_geoproof=true;;
-	      no) with_geoproof=false;;
-	  esac
-	  shift;;
-    -makecmd|--makecmd) makecmd="$2"
-		      shift;;
-    -byte-only|-byteonly|--byteonly|--byte-only) best_compiler=byte;;
-    -debug|--debug) coq_debug_flag=-g;;
-    -profile|--profile) coq_profile_flag=-p;;
-    -annotate|--annotate) coq_annotate_flag=-dtypes;;
-    -force-caml-version|--force-caml-version|-force-ocaml-version|--force-ocaml-version) 
-          force_caml_version_spec=yes
-	  force_caml_version=yes;;
-    *) echo "Unknown option \"$1\"." 1>&2; usage; exit 2;;
-  esac
-  shift
-done
-
-if [ $prefix_spec = yes -a $local = true ] ; then
-  echo "Options -prefix and -local are incompatible."
-  echo "Configure script failed!"
-  exit 1
-fi
-
-# compile date
-DATEPGM=`which date`
-case $DATEPGM in
-    "") echo "I can't find the program \"date\" in your path."
-        echo "Please give me the current date"
-	read COMPILEDATE;;
-    *)  COMPILEDATE=`LC_ALL=C LANG=C date +"%b %d %Y %H:%M:%S"`;;
-esac
-
-# Architecture
-
-case $arch_spec in
-    no) 
-    # First we test if we are running a Cygwin or Mingw/Msys system
-    if [ `uname -s | cut -c -6` = "CYGWIN" ] ; then
-	ARCH="win32"
-	CYGWIN=yes
-    elif [ `uname -s | cut -c -7` = "MINGW32" ]; then
-	ARCH="win32"
-    else
-	# If not, we determine the architecture
-	if test -x /bin/uname ; then
- 	    ARCH=`/bin/uname -s`
- 	elif test -x /usr/bin/uname ; then
- 	    ARCH=`/usr/bin/uname -s`
- 	elif test -x /bin/arch ; then
- 	    ARCH=`/bin/arch`
- 	elif test -x /usr/bin/arch ; then
- 	    ARCH=`/usr/bin/arch`
- 	elif test -x /usr/ucb/arch ; then
- 	    ARCH=`/usr/ucb/arch`
-	else
-	    echo "I can not automatically find the name of your architecture."
-	    printf "%s"\
-		"Give me a name, please [win32 for Win95, Win98 or WinNT]: "
-	    read ARCH
-	fi
-    fi;;
-    yes) ARCH=$arch
-esac
-
-# executable extension
-
-case $ARCH in
-    win32) 
-      EXE=".exe"
-      DLLEXT=".dll";;
-    *) EXE=""
-       DLLEXT=".so"
-esac
-
-# Is the source tree checked out from a recognised
-# version control system ?
-if test -e .svn/entries ; then 
-    checkedout=svn
-elif [ -d '{arch}' ]; then
-    checkedout=gnuarch
-elif [ -z "${GIT_DIR}" ] && [ -d .git ] || [ -d "${GIT_DIR}" ]; then
-    checkedout=git
-else
-    checkedout=0
-fi
-
-# make command
-
-MAKE=`which ${makecmd:-make}`
-if [ "$MAKE" != "" ]; then
-  # Beware of the final \r in Win32
-  MAKEVERSION=`"$MAKE" -v | head -1 | tr -d "\r" | cut -d" " -f3`
-  MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1`
-  MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2`
-  if [ "$MAKEVERSIONMAJOR" -gt 3 -o "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then
-      echo "You have GNU Make $MAKEVERSION. Good!"
-  else
-      OK="no"
-      #Extra support for local installation of make 3.81
-      #will be useless when make >= 3.81 will be standard
-      if [ -x ./make ]; then
-	  MAKEVERSION=`./make -v | head -1`
-	  if [ "$MAKEVERSION" = "GNU Make 3.81" ]; then OK="yes"; fi
-      fi
-      if [ $OK = "no" ]; then
-	  echo "GNU Make >= 3.81 is needed."
-	  echo "Make 3.81 can be downloaded from ftp://ftp.gnu.org/gnu/make/make-3.81.tar.gz"
-	  echo "then locally installed on a Unix-style system by issuing:"
-	  echo "  tar xzvf make-3.81.tar.gz"
-	  echo "  cd make-3.81"
-          echo "  ./configure"
-          echo "  make"
-          echo "  mv make .."
-	  echo "  cd .."
-	  echo "Restart then the configure script and later use ./make instead of make."
-	  exit 1
-      else
-	  echo "You have locally installed GNU Make 3.81. Good!"
-      fi
-  fi
-else
-  echo "Cannot find GNU Make >= 3.81."
-fi
-
-# Browser command
-
-if [ "$browser_spec" = "no" ]; then
-    case $ARCH in
-        win32) BROWSER='start %s' ;;
-	Darwin) BROWSER='open %s' ;;
-        *) BROWSER='firefox -remote "OpenURL(%s,new-tab)" || firefox %s &' ;;
-    esac
-fi
-
-if [ "$wwwcoq_spec" = "no" ]; then
-    WWWCOQ="http://coq.inria.fr/"
-fi
-
-#########################################
-# Objective Caml programs
-
-case $camldir_spec in
-    no) CAMLC=`which $bytecamlc`
-	case "$CAMLC" in
-	    "") echo "$bytecamlc is not present in your path!"
-		echo "Give me manually the path to the $bytecamlc executable [/usr/local/bin by default]: "
-		read CAMLC
-		
-		case "$CAMLC" in
-		    "") CAMLC=/usr/local/bin/$bytecamlc;;
-		    */ocamlc|*/ocamlc.opt) true;;
-		    */) CAMLC="${CAMLC}"$bytecamlc;;
-		    *) CAMLC="${CAMLC}"/$bytecamlc;;
-		esac
-	esac
-	CAMLBIN=`dirname "$CAMLC"`;;
-    yes) CAMLC=$camldir/$bytecamlc
-        
-         CAMLBIN=`dirname "$CAMLC"`
-	 bytecamlc="$CAMLC"
-	 nativecamlc=$CAMLBIN/$nativecamlc
-	 ocamlexec=$CAMLBIN/ocaml
-	 ocamldepexec=$CAMLBIN/ocamldep
-	 ocamldocexec=$CAMLBIN/ocamldoc
-	 ocamllexexec=$CAMLBIN/ocamllex
-	 ocamlyaccexec=$CAMLBIN/ocamlyacc
-	 ocamlmktopexec=$CAMLBIN/ocamlmktop
-	 ocamlmklibexec=$CAMLBIN/ocamlmklib
-	 camlp4oexec=$CAMLBIN/camlp4o
-esac
-
-if test ! -f "$CAMLC" ; then
-    echo "I can not find the executable '$CAMLC'. Have you installed it?"
+if [ ! -f $script ]; then
+    echo "Error: file $script not found in the current directory."
+    echo "Please run the configure script from the root of the coq sources."
     echo "Configuration script failed!"
     exit 1
 fi
 
-# Under Windows, we need to convert from cygwin/mingw paths (/c/Program Files/Ocaml)
-# to more windows-looking paths (c:/Program Files/Ocaml). Note that / are kept
-
-mk_win_path () {
-    case $ARCH,$CYGWIN in
-	win32,yes) cygpath -m "$1" ;;
-	win32*) "$ocamlexec" "tools/mingwpath.ml" "$1" ;;
-	*) echo "$1" ;;
-    esac
-}
-
-case $ARCH,$src_spec in
-    win32,yes) echo "Error: the -src option is currently not supported on Windows"
-	       exit 1;;
-    win32) CAMLBIN=`mk_win_path "$CAMLBIN"`;;
-esac
-
-# Beware of the final \r in Win32
-CAMLVERSION=`"$CAMLC" -version | tr -d "\r"`
-CAMLLIB=`"$CAMLC" -where | tr -d "\r"`
-
-case $CAMLVERSION in
-    1.*|2.*|3.0*|3.10*|3.11.[01])
-	echo "Your version of Objective-Caml is $CAMLVERSION."
-	if [ "$force_caml_version" = "yes" ]; then
-	    echo "*Warning* You are compiling Coq with an outdated version of Objective-Caml."
-	else
-	    echo "          You need Objective-Caml 3.11.2 or later."
-	    echo "          Configuration script failed!"
-	    exit 1
-	fi;;
-    3.11.2|3.12*|4.*)
-	CAMLP4COMPAT="-loc loc" 
-	echo "You have Objective-Caml $CAMLVERSION. Good!";;
-    *)
-	echo "I found the Objective-Caml compiler but cannot find its version number!"
-	echo "Is it installed properly?"
-	echo "Configuration script failed!"
-	exit 1;;
-esac
-
-CAMLTAG=OCAML`echo $CAMLVERSION | sed -e "s/\([1-9]\)\.\([0-9]*\).*/\1\2/g"`
-
-# For coqmktop & bytecode compiler
-
-if [ "$coq_debug_flag" = "-g" ]; then
-    case $CAMLTAG in
-        OCAML31*|OCAML4*)
-            # Compilation debug flag
-            coq_debug_flag_opt="-g"
-            ;;
-    esac
-fi
-
-# Native dynlink
-if [ "$natdynlink" = "yes" -a -f "$CAMLLIB"/dynlink.cmxa ]; then
-    HASNATDYNLINK=true
-else
-    HASNATDYNLINK=false
-fi
-
-case $HASNATDYNLINK,$ARCH,`uname -r`,$CAMLVERSION in
-    true,Darwin,9.*,3.11.*)  # ocaml 3.11.0 dynlink on MacOS 10.5 is buggy
-        NATDYNLINKFLAG=os5fixme;;
-    #Possibly a problem on 10.6.0/10.6.1/10.6.2
-    #May just be a 32 vs 64 problem for all 10.6.*
-    true,Darwin,10.0.*,3.11.*) # Possibly a problem on 10.6.0
-        NATDYNLINKFLAG=os5fixme;;
-    true,Darwin,10.1.*,3.11.*) # Possibly a problem on 10.6.1
-        NATDYNLINKFLAG=os5fixme;;
-    true,Darwin,10.2.*,3.11.*) # Possibly a problem on 10.6.2
-        NATDYNLINKFLAG=os5fixme;;
-    true,Darwin,10.*,3.11.*)
-        if [ `getconf LONG_BIT` = "32" ]; then
-	    # Still a problem for x86_32
-            NATDYNLINKFLAG=os5fixme
-        else
-	    # Not a problem for x86_64
-            NATDYNLINKFLAG=$HASNATDYNLINK
-        fi;;
-    *)
-        NATDYNLINKFLAG=$HASNATDYNLINK;;
-esac
-
-# Camlp4 / Camlp5 configuration
-
-# Assume that camlp(4|5) binaries are at the same place as ocaml ones
-# (this should become configurable some day)
-CAMLP4BIN=${CAMLBIN}
-
-case $usecamlp5 in
-  yes)
-    CAMLP4=camlp5
-    CAMLP4MOD=gramlib
-    if [ "$camlp5dir" != "" ]; then
-	if [ -f "$camlp5dir/${CAMLP4MOD}.cma" ]; then
-	    CAMLP4LIB=$camlp5dir
-	    FULLCAMLP4LIB=$camlp5dir
-	else
-	    echo "Cannot find camlp5 libraries in $camlp5dir (camlp5.cma not found)."
-	    echo "Configuration script failed!"
-	    exit 1
-	fi
-    else
-	# Beware of the final \r in Win32
-	camlp5dir="$(camlp5 -where | tr -d '\r')"
-	if [ "$camlp5dir" != "" ]; then
-	    CAMLP4LIB=$camlp5dir
-	    FULLCAMLP4LIB=$camlp5dir
-	elif [ -f "${CAMLLIB}/camlp5/${CAMLP4MOD}.cma" ]; then
-            CAMLP4LIB=+camlp5
-	    FULLCAMLP4LIB=${CAMLLIB}/camlp5
-	elif [ -f "${CAMLLIB}/site-lib/${CAMLP4MOD}.cma" ]; then
-        CAMLP4LIB=+site-lib/camlp5
-	FULLCAMLP4LIB=${CAMLLIB}/site-lib/camlp5
-	else
-	    echo "No Camlp5 installation found. Looking for Camlp4 instead..."
-	    usecamlp5=no
-	fi
-   fi
-esac
-
-# If we're (still...) going to use Camlp5, let's check its version
-
-case $usecamlp5 in
-  yes)
-    camlp4oexec=`echo "$camlp4oexec" | tr 4 5`
-    case `"$camlp4oexec" -v 2>&1` in
-	*"version 4.0"*|*5.00*)
-	    echo "Camlp5 version < 5.01 not supported."
-	    echo "Configuration script failed!"
-	    exit 1;;
-    esac
-esac
-
-# We might now try to use Camlp4, either by explicit choice or
-# by lack of proper Camlp5 installation
-
-case $usecamlp5 in
-  no)
-    CAMLP4=camlp4
-    CAMLP4MOD=camlp4lib
-    CAMLP4LIB=+camlp4
-    FULLCAMLP4LIB=${CAMLLIB}/camlp4
-
-    if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cma" ]; then
-	echo "No Camlp4 installation found."
-	echo "Configuration script failed!"
-	exit 1
-    fi
-
-    camlp4oexec=${camlp4oexec}rf
-    if [ "`"$camlp4oexec" 2>&1`" != "" ]; then
-	echo "Error: $camlp4oexec not found or not executable."
-	echo "Configuration script failed!"
-	exit 1
-    fi
-esac
-
-# do we have a native compiler: test of ocamlopt and its version
-
-if [ "$best_compiler" = "opt" ] ; then
-  if test -e "$nativecamlc" || test -e "`which $nativecamlc`"; then
-      CAMLOPTVERSION=`"$nativecamlc" -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
-      if [ ! -f "${FULLCAMLP4LIB}/${CAMLP4MOD}.cmxa" ]; then
-	  best_compiler=byte
-	  echo "Cannot find native-code $CAMLP4,"
-	  echo "only the bytecode version of Coq will be available."
-      else
-          if [ "$CAMLOPTVERSION" != "$CAMLVERSION" ] ; then
-	      echo "Native and bytecode compilers do not have the same version!"
-          fi
-          echo "You have native-code compilation. Good!"
-      fi
-  else
-      best_compiler=byte
-      echo "You have only bytecode compilation."
-  fi
-fi
-
-# OS dependent libraries
-
-OSDEPLIBS="-cclib -lunix"
-case $ARCH in
-  sun4*) OS=`uname -r`
-	case $OS in
-	   5*) OS="Sun Solaris $OS"
-	       OSDEPLIBS="$OSDEPLIBS -cclib -lnsl -cclib -lsocket";;
-	   *) OS="Sun OS $OS"
-        esac;;
-esac
-
-# lablgtk2 and CoqIDE
-
-IDEARCHFLAGS=
-IDEARCHFILE=
-IDEARCHDEF=X11
-
-# -byte-only should imply -coqide byte, unless the user decides otherwise
-
-if [ "$best_compiler" = "byte" -a "$coqide_spec" = "no" ]; then 
-    coqide_spec=yes
-    COQIDE=byte
-fi
-
-# Which coqide is asked ? which one is possible ?
-
-if [ "$coqide_spec" = "yes" -a "$COQIDE" = "no" ]; then 
-    echo "CoqIde disabled as requested."
-else
-    case $lablgtkdir_spec in
-	no)
-            # Beware of the final \r in Win32
-            lablgtkdirtmp="$(ocamlfind query lablgtk2 2> /dev/null | tr -d '\r')"
-            if [ "$lablgtkdirtmp" != "" ]; then
-                if [ -f "$lablgtkdirtmp/glib.cmi" -a -f "$lablgtkdirtmp/glib.mli" ]; then
-                    lablgtkdirfoundmsg="LabelGtk2 found by ocamlfind"
-                    lablgtkdir=$lablgtkdirtmp
-                    LABLGTKLIB=$lablgtkdir # Pour le message utilisateur
-                else
-	            echo "Headers missings in Lablgtk2 found by ocamlfind (glib.cmi/glib.mli not found)."
-                fi
-            fi
-            if [ "$lablgtkdir" = "" -a -f "${CAMLLIB}/lablgtk2/glib.cmi" -a -f "${CAMLLIB}/lablgtk2/glib.mli" ]; then
-	        lablgtkdirfoundmsg="LablGtk2 found in ocaml lib directory"
-		lablgtkdir=${CAMLLIB}/lablgtk2
-                LABLGTKLIB=+lablgtk2 # Pour le message utilisateur
-	    fi;;
-	yes)
-	    if [ ! -d "$lablgtkdir" ]; then
-                echo "$lablgtkdir is not a valid directory."
-		echo "Configuration script failed!"
-		exit 1
-	    elif [ -f "$lablgtkdir/glib.cmi" -a -f "$lablgtkdir/glib.mli" ]; then
-                lablgtkdirfoundmsg="LablGtk2 directory found"
-                LABLGTKLIB=$lablgtkdir # Pour le message utilisateur
-            else
-		echo "Headers missing in LablGtk2 library (glib.cmi/glib.mli not found)."
-		echo "Configuration script failed!"
-		exit 1
-	    fi;;
-    esac
-    if [ "$lablgtkdir" = "" ]; then
-	echo "LablGtk2 not found: CoqIde will not be available."
-	COQIDE=no
-    elif [ -z "`grep -w convert_with_fallback "$lablgtkdir/glib.mli"`" ]; then
-	echo "$lablgtkdirfoundmsg but too old: CoqIde will not be available."
-	COQIDE=no;
-    elif [ "$coqide_spec" = "yes" -a "$COQIDE" = "byte" ]; then 
-	echo "$lablgtkdirfoundmsg, bytecode CoqIde will be used as requested."
-	COQIDE=byte
-    elif [ ! -f "${CAMLLIB}/threads/threads.cmxa" ]; then 
-	echo "$lablgtkdirfoundmsg, no native threads: bytecode CoqIde will be available."
-	COQIDE=byte
-    else
-        echo "$lablgtkdirfoundmsg, native threads: native CoqIde will be available."
-	COQIDE=opt
-        if [ "$nomacintegration_spec" = "no" ] && lablgtkosxdir=$(ocamlfind query lablgtkosx 2> /dev/null);
-        then
-            IDEARCHFLAGS=lablgtkosx.cmxa
-	    IDEARCHDEF=QUARTZ
-	elif [ "$ARCH" = "win32" ];
-        then
-	    IDEARCHFLAGS=
-	    IDEARCHFILE=ide/ide_win32_stubs.o
-	    IDEARCHDEF=WIN32
-	fi
-    fi
-fi
-
-case $COQIDE in
-    byte|opt)
-        LABLGTKINCLUDES="-I $LABLGTKLIB";;
-    no)
-        LABLGTKINCLUDES="";;
-esac
-
-[ x$lablgtkosxdir = x ] || LABLGTKINCLUDES="$LABLGTKINCLUDES -I $lablgtkosxdir"
-
-# strip command
-
-case $ARCH in
-    Darwin) if [ "$HASNATDYNLINK" = "true" ]
-	then
-	  STRIPCOMMAND="true"
-	else
-	  STRIPCOMMAND="strip"
-	fi;;
-    *)
-    if [ "$coq_profile_flag" = "-p" ] || [ "$coq_debug_flag" = "-g" ]
-    then
-	STRIPCOMMAND="true"
-    else
-	STRIPCOMMAND="strip"
-    fi
-esac
-
-### Test if documentation can be compiled (latex, hevea)
-
-if test "$with_doc" = "all" 
-then
-    for cmd in "latex" "hevea" ; do
-	if test ! -x "`which $cmd`"
-	then 
-	    echo "$cmd was not found; documentation will not be available"
-	    with_doc=no
-	    break
-	fi
-    done
-fi
-
-###########################################
-# bindir, libdir, mandir, docdir, etc.
-
-# OCaml only understand Windows filenames (C:\...)
-case $ARCH in
-    win32) COQSRC=`mk_win_path "$COQSRC"`
-	   CAMLBIN=`mk_win_path "$CAMLBIN"`
-	   CAMLP4BIN=`mk_win_path "$CAMLP4BIN"`
-esac
-
-case $src_spec in
-  no) COQTOP=${COQSRC}
-esac
-
-case $ARCH$CYGWIN in
-  win32)
-	 W32PREF='C:\coq\'
-	 bindir_def="${W32PREF}bin"
-	 libdir_def="${W32PREF}lib"
-	 configdir_def="${W32PREF}config"
-	 datadir_def="${W32PREF}share"
-	 mandir_def="${W32PREF}man"
-	 docdir_def="${W32PREF}doc"
-	 emacslib_def="${W32PREF}emacs"
-	 coqdocdir_def="${W32PREF}latex";;
-  *)
-	 bindir_def=/usr/local/bin
-	 libdir_def=/usr/local/lib/coq
-	 configdir_def=/etc/xdg/coq
-	 datadir_def=/usr/local/share/coq
-	 mandir_def=/usr/local/share/man
-	 docdir_def=/usr/local/share/doc/coq
-	 emacslib_def=/usr/local/share/emacs/site-lisp
-	 coqdocdir_def=/usr/local/share/texmf/tex/latex/misc;;
-esac
-
-emacs_def=emacs
-
-case $bindir_spec/$prefix_spec/$local in
-    yes/*/*) BINDIR=$bindir ;;
-    */yes/*) BINDIR=$prefix/bin ;;
-    */*/true) BINDIR=$COQTOP/bin ;;
-    *)  printf "Where should I install the Coq binaries [%s]? " "$bindir_def"
-        read BINDIR
-	case $BINDIR in
-	    "") BINDIR=$bindir_def;;
-	    *) true;;
-	esac;;
-esac
-
-case $libdir_spec/$prefix_spec/$local in
-    yes/*/*) LIBDIR=$libdir;;
-    */yes/*)
-        libdir_spec=yes
-        case $ARCH in
-          win32) LIBDIR=$prefix ;;
-          *)  LIBDIR=$prefix/lib/coq ;;
-        esac ;;
-    */*/true) LIBDIR=$COQTOP ;;
-    *)  printf "Where should I install the Coq library [%s]? " "$libdir_def"
-        read LIBDIR
-        libdir_spec=yes
-	case $LIBDIR in
-	    "") LIBDIR=$libdir_def;;
-	    *) true;;
-	esac;;
-esac
-
-case $configdir_spec/$prefix_spec/$local in
-    yes/*/*) CONFIGDIR=$configdir;;
-    */yes/*) configdir_spec=yes
-	case $ARCH in
-	    win32) CONFIGDIR=$prefix/config;;
-            *) CONFIGDIR=$prefix/etc/xdg/coq;;
-	esac;;
-    */*/true) CONFIGDIR=$COQTOP/ide
-    configdir_spec=yes;;
-    *)  printf "Where should I install the Coqide configuration files [%s]? " "$configdir_def"
-        read CONFIGDIR
-	case $CONFIGDIR in
-	    "") CONFIGDIR=$configdir_def;;
-	    *) configdir_spec=yes;;
-	esac;;
-esac
-
-case $datadir_spec/$prefix_spec/$local in
-    yes/*/*) DATADIR=$datadir;;
-    */yes/*) DATADIR=$prefix/share/coq;;
-    */*/true) DATADIR=$COQTOP/ide
-        datadir_spec=yes;;
-    *)  printf "Where should I install the Coqide data files [%s]? " "$datadir_def"
-        read DATADIR
-	case $DATADIR in
-	    "") DATADIR=$datadir_def;;
-	    *) datadir_spec=yes;;
-	esac;;
-esac
-
-case $mandir_spec/$prefix_spec/$local in
-    yes/*/*) MANDIR=$mandir;;
-    */yes/*) MANDIR=$prefix/share/man ;;
-    */*/true) MANDIR=$COQTOP/man ;;
-    *)  printf "Where should I install the Coq man pages [%s]? "  "$mandir_def"
-        read MANDIR
-	case $MANDIR in
-	    "") MANDIR=$mandir_def;;
-	    *) true;;
-	esac;;
-esac
-
-case $docdir_spec/$prefix_spec/$local in
-    yes/*/*) DOCDIR=$docdir;;
-    */yes/*) DOCDIR=$prefix/share/doc/coq;;
-    */*/true) DOCDIR=$COQTOP/doc;;
-    *)  printf "Where should I install the Coq documentation [%s]? " "$docdir_def"
-        read DOCDIR
-	case $DOCDIR in
-	    "") DOCDIR=$docdir_def;;
-	    *) true;;
-	esac;;
-esac
-
-case $emacslib_spec/$prefix_spec/$local in
-    yes/*/*) EMACSLIB=$emacslib;;
-    */yes/*)
-        case $ARCH in
-          win32) EMACSLIB=$prefix/emacs ;;
-          *)  EMACSLIB=$prefix/share/emacs/site-lisp ;;
-        esac ;;
-    */*/true) EMACSLIB=$COQTOP/tools/emacs ;;
-    *)  printf "Where should I install the Coq Emacs mode [%s]? " "$emacslib_def"
-        read EMACSLIB
-	case $EMACSLIB in
-	    "") EMACSLIB=$emacslib_def;;
-	    *) true;;
-	esac;;
-esac
-
-case $coqdocdir_spec/$prefix_spec/$local in
-    yes/*/*) COQDOCDIR=$coqdocdir;;
-    */yes/*)
-        case $ARCH in
-          win32) COQDOCDIR=$prefix/latex ;;
-          *)  COQDOCDIR=$prefix/share/emacs/site-lisp ;;
-        esac ;;
-    */*/true) COQDOCDIR=$COQTOP/tools/coqdoc ;;
-    *)  printf "Where should I install Coqdoc TeX/LaTeX files [%s]? " "$coqdocdir_def"
-        read COQDOCDIR
-	case $COQDOCDIR in
-	    "") COQDOCDIR=$coqdocdir_def;;
-	    *) true;;
-	esac;;
-esac
-
-# Determine if we enable -custom by default (Windows and MacOS)
-CUSTOM_OS=no
-if [ "$ARCH" = "win32" ] || [ "$ARCH" = "Darwin" ]; then
-    CUSTOM_OS=yes
-fi
-
-BUILDLDPATH="# you might want to set CAML_LD_LIBRARY_PATH by hand!"
-case $coqrunbyteflags_spec/$local/$custom_spec/$CUSTOM_OS in
-    yes/*/*/*) COQRUNBYTEFLAGS="$coqrunbyteflags";;
-    */*/yes/*|*/*/*/yes) COQRUNBYTEFLAGS="-custom";;
-    */true/*/*) COQRUNBYTEFLAGS="-dllib -lcoqrun -dllpath '$COQTOP'/kernel/byterun";;
-    *)
-        COQRUNBYTEFLAGS="-dllib -lcoqrun -dllpath '$LIBDIR'"
-        BUILDLDPATH="export CAML_LD_LIBRARY_PATH='$COQTOP'/kernel/byterun:$CAML_LD_LIBRARY_PATH";;
-esac
-case $coqtoolsbyteflags_spec/$custom_spec/$CUSTOM_OS in
-    yes/*/*) COQTOOLSBYTEFLAGS="$coqtoolsbyteflags";;
-    */yes/*|*/*/yes) COQTOOLSBYTEFLAGS="-custom";;
-    *) COQTOOLSBYTEFLAGS="";;
-esac
-
-# case $emacs_spec in
-#     no) printf "Which Emacs command should I use to compile coq.el [%s]? " "$emacs_def"
-#         read EMACS
-	
-# 	case $EMACS in
-# 	    "") EMACS="$emacs_def";;
-# 	    *) true;;
-# 	esac;;
-#     yes) EMACS="$emacs";;
-# esac
-
-
-
-###########################################
-# Summary of the configuration
-
-echo ""
-echo "  Coq top directory                 : $COQTOP"
-echo "  Architecture                      : $ARCH"
-if test ! -z "$OS" ; then
-  echo "  Operating system                  : $OS"
-fi
-echo "  Coq VM bytecode link flags        : $COQRUNBYTEFLAGS"
-echo "  Coq tools bytecode link flags     : $COQTOOLSBYTEFLAGS"
-echo "  OS dependent libraries            : $OSDEPLIBS"
-echo "  Objective-Caml/Camlp4 version     : $CAMLVERSION"
-echo "  Objective-Caml/Camlp4 binaries in : $CAMLBIN"
-echo "  Objective-Caml library in         : $CAMLLIB"
-echo "  Camlp4 library in                 : $CAMLP4LIB"
-if test "$best_compiler" = opt ; then
-echo "  Native dynamic link support       : $HASNATDYNLINK"
-fi
-if test "$COQIDE" != "no"; then
-echo "  Lablgtk2 library in               : $LABLGTKLIB"
-fi
-if test "$IDEARCHDEF" = "QUARTZ"; then
-echo "  Mac OS integration is on"
-fi
-if test "$with_doc" = "all"; then
-echo "  Documentation                     : All"
-else
-echo "  Documentation                     : None"
-fi
-echo "  CoqIde                            : $COQIDE"
-echo "  Web browser                       : $BROWSER"
-echo "  Coq web site                      : $WWWCOQ"
-echo ""
-
-echo "  Paths for true installation:"
-echo "    binaries      will be copied in $BINDIR"
-echo "    library       will be copied in $LIBDIR"
-echo "    config files  will be copied in $CONFIGDIR"
-echo "    data files    will be copied in $DATADIR"
-echo "    man pages     will be copied in $MANDIR"
-echo "    documentation will be copied in $DOCDIR"
-echo "    emacs mode    will be copied in $EMACSLIB"
-echo ""
-
-##################################################
-# Building the $COQTOP/dev/ocamldebug-coq file
-##################################################
-
-OCAMLDEBUGCOQ=$COQSRC/dev/ocamldebug-coq
-
-if test "$coq_debug_flag" = "-g" ; then
-  rm -f $OCAMLDEBUGCOQ
-  sed -e "s|COQTOPDIRECTORY|$COQTOP|" \
-      -e "s|COQLIBDIRECTORY|$LIBDIR|" \
-      -e "s|CAMLBINDIRECTORY|$CAMLBIN|" \
-      -e "s|CAMLP4LIBDIRECTORY|$FULLCAMLP4LIB|"\
-      $OCAMLDEBUGCOQ.template > $OCAMLDEBUGCOQ
-  chmod a-w,a+x $OCAMLDEBUGCOQ
-fi
-
-####################################################
-# Fixing lablgtk types (before/after 2.6.0) 
-####################################################
-
-if [ ! "$COQIDE" = "no" ]; then 
-    if grep "class view " "$lablgtkdir/gText.mli" | grep -q "\[>" ; then
-       if grep -q "?accepts_tab:bool" "$lablgtkdir/gText.mli" ; then
-        cp -f ide/undo_lablgtk_ge212.mli ide/undo.mli
-       else
-	cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli
-       fi
-    else
-	cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli
-    fi
-fi  
-
-##############################################
-# Creation of configuration files
-##############################################
-
-mlconfig_file="$COQSRC/config/coq_config.ml"
-config_file="$COQSRC/config/Makefile"
-config_template="$COQSRC/config/Makefile.template"
-
-
-### Warning !!
-### After this line, be careful when using variables,
-### since some of them (e.g. $COQSRC) will be escaped
-
-escape_string () {
-    "$ocamlexec" "tools/escape_string.ml" "$1"
-}
-
-# Escaped version of browser command
-BROWSER=`escape_string "$BROWSER"`
-
-# Under Windows, we now escape the backslashes that will ends in
-# ocaml strings (coq_config.ml) or in Makefile variables.
-
-case $ARCH in
-    win32)
-	COQTOP=`escape_string "$COQTOP"`
-	BINDIR=`escape_string "$BINDIR"`
-	COQSRC=`escape_string "$COQSRC"`
-	LIBDIR=`escape_string "$LIBDIR"`
-	CONFIGDIR=`escape_string "$CONFIGDIR"`
-	DATADIR=`escape_string "$DATADIR"`
-	CAMLBIN=`escape_string "$CAMLBIN"`
-	CAMLLIB=`escape_string "$CAMLLIB"`
-	MANDIR=`escape_string "$MANDIR"`
-	DOCDIR=`escape_string "$DOCDIR"`
-	EMACSLIB=`escape_string "$EMACSLIB"`
-	COQDOCDIR=`escape_string "$COQDOCDIR"`
-	CAMLP4BIN=`escape_string "$CAMLP4BIN"`
-	CAMLP4LIB=`escape_string "$CAMLP4LIB"`
-	LABLGTKINCLUDES=`escape_string "$LABLGTKINCLUDES"`
-	COQRUNBYTEFLAGS=`escape_string "$COQRUNBYTEFLAGS"`
-	COQTOOLSBYTEFLAGS=`escape_string "$COQTOOLSBYTEFLAGS"`
-	BUILDLDPATH=`escape_string "$BUILDLDPATH"`
-	ocamlexec=`escape_string "$ocamlexec"`
-	bytecamlc=`escape_string "$bytecamlc"`
-	nativecamlc=`escape_string "$nativecamlc"`
-	ocamlmklibexec=`escape_string "$ocamlmklibexec"`
-	ocamldepexec=`escape_string "$ocamldepexec"`
-	ocamldocexec=`escape_string "$ocamldocexec"`
-	ocamllexexec=`escape_string "$ocamllexexec"`
-	ocamlyaccexec=`escape_string "$ocamlyaccexec"`
-	camlp4oexec=`escape_string "$camlp4oexec"`
-    ;;
-esac
-
-case $libdir_spec in
-    yes) LIBDIR_OPTION="Some \"$LIBDIR\"";;
-    *) LIBDIR_OPTION="None";;
-esac
-
-case $configdir_spec in
-    yes) CONFIGDIR_OPTION="Some \"$CONFIGDIR\"";;
-    *) CONFIGDIR_OPTION="None";;
-esac
-
-case $datadir_spec in
-    yes) DATADIR_OPTION="Some \"$DATADIR\"";;
-    *) DATADIR_OPTION="None";;
-esac
-
-#####################################################
-# Building the $COQTOP/config/coq_config.ml file
-#####################################################
+## Parse the args, only looking for -camldir
+## We avoid using shift to keep "$@" intact
 
-rm -f "$mlconfig_file"
-cat << END_OF_COQ_CONFIG > $mlconfig_file
-(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)
-
-let local = $local
-let coqrunbyteflags = "$COQRUNBYTEFLAGS"
-let coqlib = $LIBDIR_OPTION
-let configdir = $CONFIGDIR_OPTION
-let datadir = $DATADIR_OPTION
-let docdir = "$DOCDIR"
-let ocaml = "$ocamlexec"
-let ocamlc = "$bytecamlc"
-let ocamlopt = "$nativecamlc"
-let ocamlmklib = "$ocamlmklibexec"
-let ocamldep = "$ocamldepexec"
-let ocamldoc = "$ocamldocexec"
-let ocamlyacc = "$ocamlyaccexec"
-let ocamllex = "$ocamllexexec"
-let camlbin = "$CAMLBIN"
-let camllib = "$CAMLLIB"
-let camlp4 = "$CAMLP4"
-let camlp4o = "$camlp4oexec"
-let camlp4bin = "$CAMLP4BIN"
-let camlp4lib = "$CAMLP4LIB"
-let camlp4compat = "$CAMLP4COMPAT"
-let coqideincl = "$LABLGTKINCLUDES"
-let cflags = "$cflags"
-let best = "$best_compiler"
-let arch = "$ARCH"
-let has_coqide = "$COQIDE"
-let gtk_platform = \`$IDEARCHDEF
-let has_natdynlink = $HASNATDYNLINK
-let natdynlinkflag = "$NATDYNLINKFLAG"
-let osdeplibs = "$OSDEPLIBS"
-let version = "$VERSION"
-let caml_version = "$CAMLVERSION"
-let date = "$DATE"
-let compile_date = "$COMPILEDATE"
-let vo_magic_number = $VOMAGIC
-let state_magic_number = $STATEMAGIC
-let exec_extension = "$EXE"
-let with_geoproof = ref $with_geoproof
-let browser = "$BROWSER"
-let wwwcoq = "$WWWCOQ"
-let wwwrefman = wwwcoq ^ "distrib/" ^ version ^ "/refman/"
-let wwwstdlib = wwwcoq ^ "distrib/" ^ version ^ "/stdlib/"
-let localwwwrefman = "file:/" ^ docdir ^ "html/refman"
-
-END_OF_COQ_CONFIG
-
-# to be sure printf is found on windows when spaces occur in PATH variable
-PRINTF=`which printf`
-
-# Subdirectories of theories/ added in coq_config.ml
-subdirs () {
-    (cd $1; find * \( -name .svn -prune \) -o \( -type d -exec $PRINTF "\"%s\";\n" {} \; \) >> "$mlconfig_file")
-}
-
-echo "let theories_dirs = [" >> "$mlconfig_file"
-subdirs theories
-echo "]" >> "$mlconfig_file"
-
-echo "let plugins_dirs = [" >> "$mlconfig_file"
-subdirs plugins
-echo "]" >> "$mlconfig_file"
-
-chmod a-w "$mlconfig_file"
-
-
-###############################################
-# Building the $COQTOP/config/Makefile file
-###############################################
-
-rm -f "$config_file"
-cat << END_OF_MAKEFILE > $config_file
-###### config/Makefile : Configuration file for Coq ##############
-#                                                                #
-# This file is generated by the script "configure"               #
-# DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !!          #
-# If something is wrong below, then rerun the script "configure" #
-# with the good options (see the file INSTALL).                  #
-#                                                                #
-##################################################################
-
-#Variable used to detect whether ./configure has run successfully.
-COQ_CONFIGURED=yes
-
-# Local use (no installation)
-LOCAL=$local
-
-# Bytecode link flags for VM ("-custom" or "-dllib -lcoqrun")
-COQRUNBYTEFLAGS=$COQRUNBYTEFLAGS
-COQTOOLSBYTEFLAGS=$COQTOOLSBYTEFLAGS
-$BUILDLDPATH
-
-# Paths for true installation
-# BINDIR=path where coqtop, coqc, coqmktop, coq-tex, coqdep, gallina and
-#        do_Makefile will reside
-# LIBDIR=path where the Coq library will reside
-# MANDIR=path where to install manual pages
-# EMACSDIR=path where to put Coq's Emacs mode (coq.el)
-BINDIR="$BINDIR"
-COQLIBINSTALL="$LIBDIR"
-CONFIGDIR="$CONFIGDIR"
-DATADIR="$DATADIR"
-MANDIR="$MANDIR"
-DOCDIR="$DOCDIR"
-EMACSLIB="$EMACSLIB"
-EMACS=$EMACS
-
-# Path to Coq distribution
-COQSRC="$COQSRC"
-VERSION=$VERSION
-
-# Ocaml version number
-CAMLVERSION=$CAMLTAG
-
-# Ocaml libraries
-CAMLLIB="$CAMLLIB"
-
-# Ocaml .h directory
-CAMLHLIB="$CAMLLIB"
-
-# Camlp4 : flavor, binaries, libraries ...
-# NB : CAMLP4BIN can be empty if camlp4 is in the PATH
-# NB : avoid using CAMLP4LIB (conflict under Windows)
-CAMLP4BIN="$CAMLP4BIN"
-CAMLP4=$CAMLP4
-CAMLP4O=$camlp4oexec
-CAMLP4COMPAT=$CAMLP4COMPAT
-MYCAMLP4LIB="$CAMLP4LIB"
-
-# LablGTK
-COQIDEINCLUDES=$LABLGTKINCLUDES
-
-# Objective-Caml compile command
-OCAML="$ocamlexec"
-OCAMLC="$bytecamlc"
-OCAMLMKLIB="$ocamlmklibexec"
-OCAMLOPT="$nativecamlc"
-OCAMLDEP="$ocamldepexec"
-OCAMLDOC="$ocamldocexec"
-OCAMLLEX="$ocamllexexec"
-OCAMLYACC="$ocamlyaccexec"
-
-# Caml link command and Caml make top command
-CAMLLINK="$bytecamlc"
-CAMLOPTLINK="$nativecamlc"
-CAMLMKTOP="$ocamlmktopexec"
-
-# Caml flags
-CAMLFLAGS=-rectypes $coq_annotate_flag
-
-# Compilation debug flags
-CAMLDEBUG=$coq_debug_flag
-CAMLDEBUGOPT=$coq_debug_flag_opt
-
-# User compilation flag
-USERFLAGS=
-
-# Flags for GCC
-CFLAGS=$cflags
-
-# Compilation profile flag
-CAMLTIMEPROF=$coq_profile_flag
-
-# The best compiler: native (=opt) or bytecode (=byte) if no native compiler
-BEST=$best_compiler
-
-# Your architecture
-# Can be obtain by UNIX command arch
-ARCH=$ARCH
-HASNATDYNLINK=$NATDYNLINKFLAG
-
-# Supplementary libs for some systems, currently:
-#  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket
-#  . others     : -cclib -lunix
-OSDEPLIBS=$OSDEPLIBS
-
-# executable files extension, currently:
-#  Unix systems:
-#  Win32 systems : .exe
-EXE=$EXE
-DLLEXT=$DLLEXT
-
-# the command MKDIR (try to replace it with mkdirhier if you have problems)
-MKDIR=mkdir -p
-
-# where to put the coqdoc.sty style file
-COQDOCDIR="$COQDOCDIR"
-
-#the command STRIP
-# Unix systems and profiling: true
-# Unix systems and no profiling: strip
-STRIP=$STRIPCOMMAND
-
-# CoqIde (no/byte/opt)
-HASCOQIDE=$COQIDE
-IDEOPTFLAGS=$IDEARCHFLAGS
-IDEOPTDEPS=$IDEARCHFILE
-IDEOPTINT=$IDEARCHDEF
-
-# Defining REVISION
-CHECKEDOUT=$checkedout
-
-# Option to control compilation and installation of the documentation
-WITHDOC=$with_doc
-
-# make or sed are bogus and believe lines not terminating by a return
-# are inexistent
-END_OF_MAKEFILE
+last=
+for i; do
+   case $last in
+       -camldir|--camldir) cmd="$i/ocaml"; break;;
+   esac
+   last=$i
+done
 
-chmod a-w "$config_file"
+## We check that $cmd is ok before the real exec $cmd
 
-##################################################
-# The end
-####################################################
+`$cmd -version > /dev/null 2>&1` && exec $cmd $script "$@"
 
-echo "If anything in the above is wrong, please restart './configure'."
-echo
-echo "*Warning* To compile the system for a new architecture"
-echo "          don't forget to do a 'make archclean' before './configure'."
+## If we're still here, something is wrong with $cmd
 
+echo "Error: failed to run $cmd"
+echo "Please use the option -camldir <dir> if 'ocaml' is installed"
+echo "in directory <dir>, or add <dir> to your path."
+echo "Configuration script failed!"
+exit 1
diff --git a/configure.ml b/configure.ml
new file mode 100644
index 00000000..d68fc505
--- /dev/null
+++ b/configure.ml
@@ -0,0 +1,1193 @@
+(**********************************)
+
+(**  Configuration script for Coq *)
+
+(**********************************)
+
+(** This file should be run via: ocaml configure.ml <opts>
+    You could also use our wrapper ./configure <opts> *)
+
+#load "unix.cma"
+#load "str.cma"
+open Printf
+
+let coq_version = "8.5beta1"
+let coq_macos_version = "8.5.91" (** "[...] should be a string comprised of
+three non-negative, period-separed integers [...]" *)
+let vo_magic = 8591
+let state_magic = 58501
+let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr";
+"coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert"]
+
+let verbose = ref false (* for debugging this script *)
+
+(** * Utility functions *)
+
+let die msg = eprintf "%s\nConfiguration script failed!\n" msg; exit 1
+
+let s2i = int_of_string
+let i2s = string_of_int
+let (/) = Filename.concat
+
+(** Remove the final '\r' that may exists on Win32 *)
+
+let remove_final_cr s =
+  let n = String.length s in
+  if n<>0 && s.[n-1] = '\r' then String.sub s 0 (n-1)
+  else s
+
+let check_exit_code (_,code) = match code with
+  | Unix.WEXITED 0 -> ()
+  | Unix.WEXITED 127 -> failwith "no such command"
+  | Unix.WEXITED n -> failwith ("exit code " ^ i2s n)
+  | Unix.WSIGNALED n -> failwith ("killed by signal " ^ i2s n)
+  | Unix.WSTOPPED n -> failwith ("stopped by signal " ^ i2s n)
+
+(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *)
+
+let rec waitpid_non_intr pid =
+  try Unix.waitpid [] pid
+  with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
+(** Below, we'd better read all lines on a channel before closing it,
+    otherwise a SIGPIPE could be encountered by the sub-process *)
+
+let read_lines_and_close fd =
+  let cin = Unix.in_channel_of_descr fd in
+  let lines = ref [] in
+  begin
+    try
+      while true do
+        lines := remove_final_cr (input_line cin) :: !lines
+      done
+    with End_of_file -> ()
+  end;
+  close_in cin;
+  let lines = List.rev !lines in
+  try List.hd lines, lines with Failure _ -> "", []
+
+(** Run some unix command and read the first line of its output.
+    We avoid Unix.open_process and its non-fully-portable /bin/sh,
+    especially when it comes to quoting the filenames.
+    See open_process_pid in ide/coq.ml for more details.
+    Error messages:
+     - if err=StdErr, any error message goes in the stderr of our script.
+     - if err=StdOut, we merge stderr and stdout (just as 2>&1).
+     - if err=DevNull, we drop the error messages (same as 2>/dev/null). *)
+
+type err = StdErr | StdOut | DevNull
+
+let run ?(fatal=true) ?(err=StdErr) prog args =
+  let argv = Array.of_list (prog::args) in
+  try
+    let out_r,out_w = Unix.pipe () in
+    let nul_r,nul_w = Unix.pipe () in
+    let () = Unix.set_close_on_exec out_r in
+    let () = Unix.set_close_on_exec nul_r in
+    let fd_err = match err with
+      | StdErr -> Unix.stderr
+      | StdOut -> out_w
+      | DevNull -> nul_w
+    in
+    let pid = Unix.create_process prog argv Unix.stdin out_w fd_err in
+    let () = Unix.close out_w in
+    let () = Unix.close nul_w in
+    let line, all = read_lines_and_close out_r in
+    let _ = read_lines_and_close nul_r in
+    let () = check_exit_code (waitpid_non_intr pid) in
+    line, all
+  with
+  | _ when not fatal && not !verbose -> "", []
+  | e ->
+      let cmd = String.concat " " (prog::args) in
+      let exn = match e with Failure s -> s | _ -> Printexc.to_string e in
+      let msg = sprintf "Error while running '%s' (%s)" cmd exn in
+      if fatal then die msg else (printf "W: %s\n" msg; "", [])
+
+let tryrun prog args = run ~fatal:false ~err:DevNull prog args
+
+(** Splitting a string at some character *)
+
+let string_split c s =
+  let len = String.length s in
+  let rec split n =
+    try
+      let pos = String.index_from s n c in
+      let dir = String.sub s n (pos-n) in
+      dir :: split (succ pos)
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if len = 0 then [] else split 0
+
+(** String prefix test : does [s1] starts with [s2] ? *)
+
+let starts_with s1 s2 =
+  let l1 = String.length s1 and l2 = String.length s2 in
+  l2 <= l1 && s2 = String.sub s1 0 l2
+
+(** Turn a version string such as "4.01.0+rc2" into the list
+    ["4";"01";"1"], stopping at the first non-digit or "." *)
+
+let numeric_prefix_list s =
+  let isnum c = (c = '.' || (c >= '0' && c <= '9')) in
+  let max = String.length s in
+  let i = ref 0 in
+  while !i < max && isnum s.[!i] do incr i done;
+  string_split '.' (String.sub s 0 !i)
+
+(** Combined existence and directory tests *)
+
+let dir_exists f = Sys.file_exists f && Sys.is_directory f
+
+(** Does a file exist and is executable ? *)
+
+let is_executable f =
+  try let () = Unix.access f [Unix.X_OK] in true
+  with Unix.Unix_error _ -> false
+
+(** Equivalent of rm -f *)
+
+let safe_remove f =
+  try Unix.chmod f 0o644; Sys.remove f with _ -> ()
+
+(** The PATH list for searching programs *)
+
+let os_type_win32 = (Sys.os_type = "Win32")
+let os_type_cygwin = (Sys.os_type = "Cygwin")
+
+let global_path =
+  try string_split (if os_type_win32 then ';' else ':') (Sys.getenv "PATH")
+  with Not_found -> []
+
+(** A "which" command. May raise [Not_found] *)
+
+let which prog =
+  let rec search = function
+    | [] -> raise Not_found
+    | dir :: path ->
+      let file = if os_type_win32 then dir/prog^".exe" else dir/prog in
+      if is_executable file then file else search path
+  in search global_path
+
+let program_in_path prog =
+  try let _ = which prog in true with Not_found -> false
+
+
+(** * Date *)
+
+(** The short one is displayed when starting coqtop,
+    The long one is used as compile date *)
+
+let months =
+ [| "January";"February";"March";"April";"May";"June";
+    "July";"August";"September";"October";"November";"December" |]
+
+let get_date () =
+  let now = Unix.localtime (Unix.time ()) in
+  let year = 1900+now.Unix.tm_year in
+  let month = months.(now.Unix.tm_mon) in
+  sprintf "%s %d" month year,
+  sprintf "%s %d %d %d:%d:%d" (String.sub month 0 3) now.Unix.tm_mday year
+    now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec
+
+let short_date, full_date = get_date ()
+
+
+(** Create the bin/ directory if non-existent *)
+
+let _ = if not (dir_exists "bin") then Unix.mkdir "bin" 0o755
+
+
+(** * Command-line parsing *)
+
+type ide = Opt | Byte | No
+
+let get_bool = function
+  | "true" | "yes" | "y" | "all" -> true
+  | "false" | "no" | "n" -> false
+  | s -> raise (Arg.Bad ("boolean argument expected instead of "^s))
+
+let get_ide = function
+  | "opt" -> Opt
+  | "byte" -> Byte
+  | "no" -> No
+  | s -> raise (Arg.Bad ("(opt|byte|no) argument expected instead of "^s))
+
+let arg_bool r = Arg.String (fun s -> r := get_bool s)
+
+let arg_string_option r = Arg.String (fun s -> r := Some s)
+
+module Prefs = struct
+  let prefix = ref (None : string option)
+  let local = ref false
+  let vmbyteflags = ref (None : string option)
+  let custom = ref (None : bool option)
+  let bindir = ref (None : string option)
+  let libdir = ref (None : string option)
+  let configdir = ref (None : string option)
+  let datadir = ref (None : string option)
+  let mandir = ref (None : string option)
+  let docdir = ref (None : string option)
+  let emacslib = ref (None : string option)
+  let coqdocdir = ref (None : string option)
+  let camldir = ref (None : string option)
+  let lablgtkdir = ref (None : string option)
+  let usecamlp5 = ref true
+  let camlp5dir = ref (None : string option)
+  let arch = ref (None : string option)
+  let opt = ref false
+  let natdynlink = ref true
+  let coqide = ref (None : ide option)
+  let macintegration = ref true
+  let browser = ref (None : string option)
+  let withdoc = ref true
+  let geoproof = ref false
+  let byteonly = ref false
+  let debug = ref false
+  let profile = ref false
+  let annotate = ref false
+  let makecmd = ref "make"
+  let nativecompiler = ref true
+  let coqwebsite = ref "http://coq.inria.fr/"
+  let force_caml_version = ref false
+end
+
+(* TODO : earlier any option -foo was also available as --foo *)
+
+let args_options = Arg.align [
+  "-prefix", arg_string_option Prefs.prefix,
+    "<dir> Set installation directory to <dir>";
+  "-local", Arg.Set Prefs.local,
+    " Set installation directory to the current source tree";
+  "-vmbyteflags", arg_string_option Prefs.vmbyteflags,
+    "<flags> Comma-separated link flags for the VM of coqtop.byte";
+  "-custom", Arg.Unit (fun () -> Prefs.custom := Some true),
+    " Build bytecode executables with -custom (not recommended)";
+  "-no-custom", Arg.Unit (fun () -> Prefs.custom := Some false),
+    " Do not build with -custom on Windows and MacOS";
+  "-bindir", arg_string_option Prefs.bindir,
+    "<dir> Where to install bin files";
+  "-libdir", arg_string_option Prefs.libdir,
+    "<dir> Where to install lib files";
+  "-configdir", arg_string_option Prefs.configdir,
+    "<dir> Where to install config files";
+  "-datadir", arg_string_option Prefs.datadir,
+    "<dir> Where to install data files";
+  "-mandir", arg_string_option Prefs.mandir,
+    "<dir> Where to install man files";
+  "-docdir", arg_string_option Prefs.docdir,
+    "<dir> Where to install doc files";
+  "-emacslib", arg_string_option Prefs.emacslib,
+    "<dir> Where to install emacs files";
+  "-emacs", Arg.String (fun s ->
+      printf "Warning: obsolete -emacs option\n";
+      Prefs.emacslib := Some s),
+    "<dir> (Obsolete) same as -emacslib";
+  "-coqdocdir", arg_string_option Prefs.coqdocdir,
+    "<dir> Where to install Coqdoc style files";
+  "-camldir", arg_string_option Prefs.camldir,
+    "<dir> Specifies the path to the OCaml library";
+  "-lablgtkdir", arg_string_option Prefs.lablgtkdir,
+    "<dir> Specifies the path to the Lablgtk library";
+  "-usecamlp5", Arg.Set Prefs.usecamlp5,
+    " Specifies to use camlp5 instead of camlp4";
+  "-usecamlp4", Arg.Clear Prefs.usecamlp5,
+    " Specifies to use camlp4 instead of camlp5";
+  "-camlp5dir",
+    Arg.String (fun s -> Prefs.usecamlp5:=true; Prefs.camlp5dir:=Some s),
+    "<dir> Specifies where is the Camlp5 library and tells to use it";
+  "-arch", arg_string_option Prefs.arch,
+    "<arch> Specifies the architecture";
+  "-opt", Arg.Set Prefs.opt,
+    " Use OCaml *.opt optimized compilers";
+  "-natdynlink", arg_bool Prefs.natdynlink,
+    "(yes|no) Use dynamic loading of native code or not";
+  "-coqide", Arg.String (fun s -> Prefs.coqide := Some (get_ide s)),
+    "(opt|byte|no) Specifies whether or not to compile Coqide";
+  "-nomacintegration", Arg.Clear Prefs.macintegration,
+    " Do not try to build coqide mac integration";
+  "-browser", arg_string_option Prefs.browser,
+    "<command> Use <command> to open URL %s";
+  "-nodoc", Arg.Clear Prefs.withdoc,
+    " Do not compile the documentation";
+  "-with-doc", arg_bool Prefs.withdoc,
+    "(yes|no) Compile the documentation or not";
+  "-with-geoproof", arg_bool Prefs.geoproof,
+    "(yes|no) Use Geoproof binding or not";
+  "-byte-only", Arg.Set Prefs.byteonly,
+    " Compiles only bytecode version of Coq";
+  "-byteonly", Arg.Set Prefs.byteonly,
+    " Compiles only bytecode version of Coq";
+  "-debug", Arg.Set Prefs.debug,
+    " Add debugging information in the Coq executables";
+  "-profile", Arg.Set Prefs.profile,
+    " Add profiling information in the Coq executables";
+  "-annotate", Arg.Set Prefs.annotate,
+    " Dumps ml annotation files while compiling Coq";
+  "-makecmd", Arg.Set_string Prefs.makecmd,
+    "<command> Name of GNU Make command";
+  "-no-native-compiler", Arg.Clear Prefs.nativecompiler,
+    " No compilation to native code for conversion and normalization";
+  "-coqwebsite", Arg.Set_string Prefs.coqwebsite,
+    " URL of the coq website";
+  "-force-caml-version", arg_bool Prefs.force_caml_version,
+    " Force OCaml version";
+]
+
+let parse_args () =
+  Arg.parse
+    args_options
+    (fun s -> raise (Arg.Bad ("Unknown option: "^s)))
+    "Available options for configure are:";
+  if !Prefs.local && !Prefs.prefix <> None then
+    die "Options -prefix and -local are incompatible."
+
+let _ = parse_args ()
+
+(** Default OCaml binaries *)
+
+type camlexec =
+ { mutable byte : string;
+   mutable opt : string;
+   mutable top : string;
+   mutable mklib : string;
+   mutable dep : string;
+   mutable doc : string;
+   mutable lex : string;
+   mutable yacc : string;
+   mutable p4 : string }
+
+(* TODO: autodetect .opt binaries ? *)
+
+let camlexec =
+  { byte = if !Prefs.opt then "ocamlc.opt" else "ocamlc";
+    opt = if !Prefs.opt then "ocamlopt.opt" else "ocamlopt";
+    top = "ocaml";
+    mklib = "ocamlmklib";
+    dep = "ocamldep";
+    doc = "ocamldoc";
+    lex = "ocamllex";
+    yacc = "ocamlyacc";
+    p4 = "camlp4o" }
+
+let rebase_camlexec dir c =
+  c.byte <- Filename.concat dir c.byte;
+  c.opt <- Filename.concat dir c.opt;
+  c.top <- Filename.concat dir c.top;
+  c.mklib <- Filename.concat dir c.mklib;
+  c.dep <- Filename.concat dir c.dep;
+  c.doc <- Filename.concat dir c.doc;
+  c.lex <- Filename.concat dir c.lex;
+  c.yacc <- Filename.concat dir c.yacc;
+  c.p4 <- Filename.concat dir c.p4
+
+let coq_debug_flag = if !Prefs.debug then "-g" else ""
+let coq_profile_flag = if !Prefs.profile then "-p" else ""
+let coq_annotate_flag =
+  if !Prefs.annotate
+  then if program_in_path "ocamlmerlin" then "-bin-annot" else "-dtypes"
+  else ""
+
+let cflags = "-Wall -Wno-unused"
+
+
+(** * Architecture *)
+
+let arch_progs =
+  [("/bin/uname",["-s"]);
+   ("/usr/bin/uname",["-s"]);
+   ("/bin/arch", []);
+   ("/usr/bin/arch", []);
+   ("/usr/ucb/arch", []) ]
+
+let query_arch () =
+  printf "I can not automatically find the name of your architecture.\n";
+  printf "Give me a name, please [win32 for Win95, Win98 or WinNT]: %!";
+  read_line ()
+
+let rec try_archs = function
+  | (prog,args)::rest when is_executable prog ->
+    let arch, _ = tryrun prog args in
+    if arch <> "" then arch else try_archs rest
+  | _ :: rest -> try_archs rest
+  | [] -> query_arch ()
+
+let arch = match !Prefs.arch with
+  | Some a -> a
+  | None ->
+    let arch,_ = tryrun "uname" ["-s"] in
+    if starts_with arch "CYGWIN" then "win32"
+    else if starts_with arch "MINGW32" then "win32"
+    else if arch <> "" then arch
+    else try_archs arch_progs
+
+(** NB: [arch_win32] is broader than [os_type_win32], cf. cygwin *)
+
+let arch_win32 = (arch = "win32")
+
+let exe = if arch_win32 then ".exe" else ""
+let dll = if os_type_win32 then ".dll" else ".so"
+
+(** * VCS
+
+    Is the source tree checked out from a recognised
+    Version Control System ? *)
+
+let vcs =
+  let git_dir = try Sys.getenv "GIT_DIR" with Not_found -> ".git" in
+  if dir_exists git_dir then "git"
+  else if Sys.file_exists ".svn/entries" then "svn"
+  else if dir_exists "{arch}" then "gnuarch"
+  else "none"
+
+(** * The make command *)
+
+let make =
+  try
+    let version_line, _ = run !Prefs.makecmd ["-v"] in
+    let version = List.nth (string_split ' ' version_line) 2 in
+    match string_split '.' version with
+    | major::minor::_ when (s2i major, s2i minor) >= (3,81) ->
+      printf "You have GNU Make %s. Good!\n" version
+    | _ -> failwith "bad version"
+  with _ -> die "Error: Cannot find GNU Make >= 3.81."
+
+(** * Browser command *)
+
+let browser =
+  match !Prefs.browser with
+  | Some b -> b
+  | None when arch_win32 -> "start %s"
+  | None when arch = "Darwin" -> "open %s"
+  | _ -> "firefox -remote \"OpenURL(%s,new-tab)\" || firefox %s &"
+
+(** * OCaml programs *)
+
+let camlbin, camlc = match !Prefs.camldir with
+  | Some dir ->
+    rebase_camlexec dir camlexec;
+    Filename.dirname camlexec.byte, camlexec.byte
+  | None ->
+    try let camlc = which camlexec.byte in Filename.dirname camlc, camlc
+    with Not_found ->
+      die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^
+           "Please adjust your path or use the -camldir option of ./configure")
+
+let _ =
+  if not (is_executable camlc) then
+    die ("Error: cannot find the executable '"^camlc^"'.")
+
+let caml_version, _ = run camlc ["-version"]
+let camllib, _ = run camlc ["-where"]
+let camlp4compat = "-loc loc"
+
+(** Caml version as a list of string, e.g. ["4";"00";"1"] *)
+
+let caml_version_list = numeric_prefix_list caml_version
+
+(** Same, with integers in the version list *)
+
+let caml_version_nums =
+  try
+    if List.length caml_version_list < 2 then failwith "bad version";
+    List.map s2i caml_version_list
+  with _ ->
+    die ("I found the OCaml compiler but cannot read its version number!\n" ^
+         "Is it installed properly?")
+
+let check_caml_version () =
+  if caml_version_nums >= [3;12;1] then
+    printf "You have OCaml %s. Good!\n" caml_version
+  else
+    let () = printf "Your version of OCaml is %s.\n" caml_version in
+    if !Prefs.force_caml_version then
+      printf "*Warning* Your version of OCaml is outdated.\n"
+    else
+      die "You need OCaml 3.12.1 or later."
+
+let _ = check_caml_version ()
+
+let coq_debug_flag_opt =
+  if caml_version_nums >= [3;10] then coq_debug_flag else ""
+
+let camltag = match caml_version_list with
+  | x::y::_ -> "OCAML"^x^y
+  | _ -> assert false
+
+
+(** * CamlpX configuration *)
+
+(** We assume that camlp(4|5) binaries are at the same place as ocaml ones
+    (this should become configurable some day). *)
+
+let camlp4bin = camlbin
+
+(* TODO: camlp5dir should rather be the *binary* location, just as camldir *)
+(* TODO: remove the late attempts at finding gramlib.cma *)
+
+exception NoCamlp5
+
+let check_camlp5 testcma = match !Prefs.camlp5dir with
+  | Some dir ->
+    if Sys.file_exists (dir/testcma) then dir
+    else
+      let msg =
+        sprintf "Cannot find camlp5 libraries in '%s' (%s not found)."
+          dir testcma
+      in die msg
+  | None ->
+    let dir,_ = tryrun "camlp5" ["-where"] in
+    let dir2 =
+      if Sys.file_exists (camllib/"camlp5"/testcma) then
+        camllib/"camlp5"
+      else if Sys.file_exists (camllib/"site-lib"/"camlp5"/testcma) then
+        camllib/"site-lib"/"camlp5"
+      else ""
+    in
+    (* if the two values are different than camlp5 has been relocated
+     * and will not be able to find its own files, so we prefer the
+     * path where the files actually do exist *)
+    if dir2 = "" then
+      if dir = "" then
+        let () = printf "No Camlp5 installation found." in
+        let () = printf "Looking for Camlp4 instead...\n" in
+        raise NoCamlp5
+      else dir
+    else dir2
+
+let check_camlp5_version () =
+  let s = camlexec.p4 in
+  (* translate 4 into 5 in the binary name *)
+  for i = 0 to String.length s - 1 do
+    if s.[i] = '4' then s.[i] <- '5'
+  done;
+  try
+    let version_line, _ = run ~err:StdOut camlexec.p4 ["-v"] in
+    let version = List.nth (string_split ' ' version_line) 2 in
+    match string_split '.' version with
+    | major::minor::_ when s2i major > 5 || (s2i major, s2i minor) >= (5,1) ->
+      printf "You have Camlp5 %s. Good!\n" version
+    | _ -> failwith "bad version"
+  with _ -> die "Error: unsupported Camlp5 (version < 5.01 or unrecognized).\n"
+
+let config_camlpX () =
+  try
+    if not !Prefs.usecamlp5 then raise NoCamlp5;
+    let lib = "gramlib" in
+    let dir = check_camlp5 (lib^".cma") in
+    let () = check_camlp5_version () in
+    "camlp5", dir, lib
+  with NoCamlp5 ->
+    (* We now try to use Camlp4, either by explicit choice or
+       by lack of proper Camlp5 installation *)
+    let lib = "camlp4lib" in
+    let dir = camllib/"camlp4" in
+    if not (Sys.file_exists (dir/lib^".cma")) then
+      die "No Camlp4 installation found.\n";
+    let () = camlexec.p4 <- camlexec.p4 ^ "rf" in
+    ignore (run camlexec.p4 []);
+    "camlp4", dir, lib
+
+let camlp4, fullcamlp4lib, camlp4mod = config_camlpX ()
+
+let shorten_camllib s =
+  if starts_with s (camllib^"/") then
+    let l = String.length camllib + 1 in
+    "+" ^ String.sub s l (String.length s - l)
+  else s
+
+let camlp4lib = shorten_camllib fullcamlp4lib
+
+
+(** * Native compiler *)
+
+let msg_byteonly () =
+  printf "Only the bytecode version of Coq will be available.\n"
+
+let msg_no_ocamlopt () =
+  printf "Cannot find the OCaml native-code compiler.\n"; msg_byteonly ()
+
+let msg_no_camlp4_cmxa () =
+  printf "Cannot find the native-code library of %s.\n" camlp4; msg_byteonly ()
+
+let msg_no_dynlink_cmxa () =
+  printf "Cannot find native-code dynlink library.\n"; msg_byteonly ();
+  printf "For building a native-code Coq, you may try to first\n";
+  printf "compile and install a dummy dynlink.cmxa (see dev/dynlink.ml)\n";
+  printf "and then run ./configure -natdynlink no\n"
+
+let check_native () =
+  if !Prefs.byteonly then raise Not_found;
+  if not (is_executable camlexec.opt || program_in_path camlexec.opt) then
+    (msg_no_ocamlopt (); raise Not_found);
+  if not (Sys.file_exists (fullcamlp4lib/camlp4mod^".cmxa")) then
+    (msg_no_camlp4_cmxa (); raise Not_found);
+  if not (Sys.file_exists (camllib/"dynlink.cmxa")) then
+    (msg_no_dynlink_cmxa (); raise Not_found);
+  let version, _ = run camlexec.opt ["-version"] in
+  if version <> caml_version then
+    printf
+      "Warning: Native and bytecode compilers do not have the same version!\n";
+  printf "You have native-code compilation. Good!\n"
+
+let best_compiler =
+  try check_native (); "opt" with Not_found -> "byte"
+
+
+(** * Native dynlink *)
+
+let hasnatdynlink = !Prefs.natdynlink && best_compiler = "opt"
+
+(** OCaml 3.11.0 dynlink is buggy on MacOS 10.5, and possibly
+    also on 10.6.(0|1|2) for x86_64 and 10.6.x on x86_32 *)
+
+let needs_MacOS_fix () =
+  match hasnatdynlink, arch, caml_version_nums with
+  | true, "Darwin", 3::11::_ ->
+    (match string_split '.' (fst(run "uname" ["-r"])) with
+    | "9"::_ -> true
+    | "10"::("0"|"1"|"2")::_ -> true
+    | "10"::_ when Sys.word_size = 32 -> true
+    | _ -> false)
+  | _ -> false
+
+let natdynlinkflag =
+  if needs_MacOS_fix () then "os5fixme" else
+    if hasnatdynlink then "true" else "false"
+
+
+(** * OS dependent libraries *)
+
+let osdeplibs = "-cclib -lunix"
+
+let operating_system, osdeplibs =
+  if starts_with arch "sun4" then
+    let os, _ = run "uname" ["-r"] in
+    if starts_with os "5" then
+      "Sun Solaris "^os, osdeplibs^" -cclib -lnsl -cclib -lsocket"
+    else
+      "Sun OS "^os, osdeplibs
+  else
+    (try Sys.getenv "OS" with Not_found -> ""), osdeplibs
+
+
+(** * lablgtk2 and CoqIDE *)
+
+(** Is some location a suitable LablGtk2 installation ? *)
+
+let check_lablgtkdir ?(fatal=false) msg dir =
+  let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in
+  if not (dir_exists dir) then
+    yell (sprintf "No such directory '%s' (%s)." dir msg)
+  else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then
+    yell (sprintf "Incomplete LablGtk2 (%s): no %s/gSourceView2.cmi." msg dir)
+  else if not (Sys.file_exists (dir/"glib.mli")) then
+    yell (sprintf "Incomplete LablGtk2 (%s): no %s/glib.mli." msg dir)
+  else true
+
+(** Detect and/or verify the Lablgtk2 location *)
+
+let get_lablgtkdir () =
+  match !Prefs.lablgtkdir with
+  | Some dir ->
+    let msg = "manually provided" in
+    if check_lablgtkdir ~fatal:true msg dir then dir, msg
+    else "", ""
+  | None ->
+    let msg = "via ocamlfind" in
+    let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in
+    if d1 <> "" && check_lablgtkdir msg d1 then d1, msg
+    else
+      (* In debian wheezy, ocamlfind knows only of lablgtk2 *)
+      let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in
+      if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg
+      else
+        let msg = "in OCaml library" in
+        let d3 = camllib^"/lablgtk2" in
+        if check_lablgtkdir msg d3 then d3, msg
+        else "", ""
+
+let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native"
+
+exception Ide of ide
+
+(** If the user asks an impossible coqide, we abort the configuration *)
+
+let set_ide ide msg = match ide, !Prefs.coqide with
+  | No, Some (Byte|Opt)
+  | Byte, Some Opt -> die (msg^":\n=> cannot build requested CoqIde")
+  | _ ->
+    printf "%s:\n=> %s CoqIde will be built.\n" msg (pr_ide ide);
+    raise (Ide ide)
+
+let lablgtkdir = ref ""
+
+(** Which CoqIde is possible ? Which one is requested ?
+    This function also sets the lablgtkdir reference in case of success. *)
+
+let check_coqide () =
+  if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled";
+  let dir, via = get_lablgtkdir () in
+  if dir = "" then set_ide No "LablGtk2 not found";
+  let found = sprintf "LablGtk2 found (%s)" via in
+  let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in
+  if Sys.command test <> 0 then set_ide No (found^" but too old");
+  (* We're now sure to produce at least one kind of coqide *)
+  lablgtkdir := shorten_camllib dir;
+  if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested");
+  if best_compiler<>"opt" then set_ide Byte (found^", but no native compiler");
+  if not (Sys.file_exists (dir/"gtkThread.cmx")) then
+    set_ide Byte (found^", but no native LablGtk2");
+  if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then
+    set_ide Byte (found^", but no native threads");
+  set_ide Opt (found^", with native threads")
+
+let coqide =
+  try check_coqide ()
+  with Ide Opt -> "opt" | Ide Byte -> "byte" | Ide No -> "no"
+
+(** System-specific CoqIde flags *)
+
+let lablgtkincludes = ref ""
+let idearchflags = ref ""
+let idearchfile = ref ""
+let idecdepsflags = ref ""
+let idearchdef = ref "X11"
+
+let coqide_flags () =
+  if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir;
+  match coqide, arch with
+    | "opt", "Darwin" when !Prefs.macintegration ->
+      let osxdir,_ = tryrun "ocamlfind" ["query";"lablgtkosx"] in
+      if osxdir <> "" then begin
+        lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir;
+        idearchflags := "lablgtkosx.cma";
+        idearchdef := "QUARTZ"
+      end
+    | "opt", "win32" ->
+      idearchfile := "ide/ide_win32_stubs.o ide/coq_icon.o";
+      idecdepsflags := "-custom";
+      idearchflags := "-ccopt '-subsystem windows'";
+      idearchdef := "WIN32"
+    | _, "win32" ->
+      idearchflags := "-ccopt '-subsystem windows'";
+      idearchdef := "WIN32"
+    | _ -> ()
+
+let _ = coqide_flags ()
+
+
+(** * strip command *)
+
+let strip =
+  if arch = "Darwin" then
+    if hasnatdynlink then "true" else "strip"
+  else
+    if !Prefs.profile || !Prefs.debug then "true" else begin
+    let _, all = run camlexec.byte ["-config"] in
+    let strip = String.concat "" (List.map (fun l ->
+        match string_split ' ' l with
+        | "ranlib:" :: cc :: _ -> (* on windows, we greb the right strip *)
+             Str.replace_first (Str.regexp "ranlib") "strip" cc
+        | _ -> ""
+      ) all) in
+    if strip = "" then "stip" else strip
+    end
+
+(** * md5sum command *)
+
+let md5sum =
+  if arch = "Darwin" then "md5 -q" else "md5sum"
+
+
+(** * md5sum command *)
+
+let md5sum =
+  if arch = "Darwin" then "md5 -q" else "md5sum"
+
+
+(** * Documentation : do we have latex, hevea, ... *)
+
+let check_doc () =
+  let err s =
+    printf "%s was not found; documentation will not be available\n" s;
+    raise Not_found
+  in
+  try
+    if not !Prefs.withdoc then raise Not_found;
+    if not (program_in_path "latex") then err "latex";
+    if not (program_in_path "hevea") then err "hevea";
+    true
+  with Not_found -> false
+
+let withdoc = check_doc ()
+
+
+(** * Installation directories : bindir, libdir, mandir, docdir, etc *)
+
+let coqtop = Sys.getcwd ()
+
+let unix = os_type_cygwin || not arch_win32
+
+(** Variable name, description, ref in Prefs, default dir, prefix-relative *)
+
+let install = [
+  "BINDIR", "the Coq binaries", Prefs.bindir,
+    (if unix then "/usr/local/bin" else "C:/coq/bin"),
+    "/bin";
+  "COQLIBINSTALL", "the Coq library", Prefs.libdir,
+    (if unix then "/usr/local/lib/coq" else "C:/coq/lib"),
+    (if arch_win32 then "" else "/lib/coq");
+  "CONFIGDIR", "the Coqide configuration files", Prefs.configdir,
+    (if unix then "/etc/xdg/coq" else "C:/coq/config"),
+    (if arch_win32 then "/config" else "/etc/xdg/coq");
+  "DATADIR", "the Coqide data files", Prefs.datadir,
+    (if unix then "/usr/local/share/coq" else "C:/coq/share"),
+    "/share/coq";
+  "MANDIR", "the Coq man pages", Prefs.mandir,
+    (if unix then "/usr/local/share/man" else "C:/coq/man"),
+    "/share/man";
+  "DOCDIR", "the Coq documentation", Prefs.docdir,
+    (if unix then "/usr/local/share/doc/coq" else "C:/coq/doc"),
+    "/share/doc/coq";
+  "EMACSLIB", "the Coq Emacs mode", Prefs.emacslib,
+    (if unix then "/usr/local/share/emacs/site-lisp" else "C:/coq/emacs"),
+    (if arch_win32 then "/emacs" else "/share/emacs/site-lisp");
+  "COQDOCDIR", "the Coqdoc LaTeX files", Prefs.coqdocdir,
+    (if unix then "/usr/local/share/texmf/tex/latex/misc" else "C:/coq/latex"),
+    (if arch_win32 then "/latex" else "/share/emacs/site-lisp");
+ ]
+
+let do_one_instdir (var,msg,r,dflt,suff) =
+  let dir = match !r, !Prefs.prefix with
+    | Some d, _ -> d
+    | _, Some p -> p^suff
+    | _ ->
+      let () = printf "Where should I install %s [%s]? " msg dflt in
+      let line = read_line () in
+      if line = "" then dflt else line
+  in (var,msg,dir,dir<>dflt)
+
+let do_one_noinst (var,msg,_,_,_) =
+  if var="CONFIGDIR" || var="DATADIR" then (var,msg,coqtop^"/ide",true)
+  else (var,msg,"",false)
+
+let install_dirs =
+  let f = if !Prefs.local then do_one_noinst else do_one_instdir in
+  List.map f install
+
+let select var = List.find (fun (v,_,_,_) -> v=var) install_dirs
+
+let libdir = let (_,_,d,_) = select "COQLIBINSTALL" in d
+
+let docdir = let (_,_,d,_) = select "DOCDIR" in d
+
+let configdir =
+  let (_,_,d,b) = select "CONFIGDIR" in if b then Some d else None
+
+let datadir =
+  let (_,_,d,b) = select "DATADIR" in if b then Some d else None
+
+
+(** * OCaml runtime flags *)
+
+(** Do we use -custom (yes by default on Windows and MacOS) *)
+
+let custom_os = arch_win32 || arch = "Darwin"
+
+let use_custom = match !Prefs.custom with
+  | Some b -> b
+  | None -> custom_os
+
+let custom_flag = if use_custom then "-custom" else ""
+
+let build_loadpath =
+  ref "# you might want to set CAML_LD_LIBRARY_PATH by hand!"
+
+let config_runtime () =
+  match !Prefs.vmbyteflags with
+  | Some flags -> string_split ',' flags
+  | _ when use_custom -> [custom_flag]
+  | _ when !Prefs.local ->
+    ["-dllib";"-lcoqrun";"-dllpath";coqtop/"kernel/byterun"]
+  | _ ->
+    let ld="CAML_LD_LIBRARY_PATH" in
+    build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld;
+    ["-dllib";"-lcoqrun";"-dllpath";libdir]
+
+let vmbyteflags = config_runtime ()
+
+
+(** * Summary of the configuration *)
+
+let print_summary () =
+  let pr s = printf s in
+  pr "\n";
+  pr "  Architecture                : %s\n" arch;
+  if operating_system <> "" then
+    pr "  Operating system          : %s\n" operating_system;
+  pr "  Coq VM bytecode link flags  : %s\n" (String.concat " " vmbyteflags);
+  pr "  Other bytecode link flags   : %s\n" custom_flag;
+  pr "  OS dependent libraries      : %s\n" osdeplibs;
+  pr "  OCaml/Camlp4 version        : %s\n" caml_version;
+  pr "  OCaml/Camlp4 binaries in    : %s\n" camlbin;
+  pr "  OCaml library in            : %s\n" camllib;
+  pr "  Camlp4 library in           : %s\n" camlp4lib;
+  if best_compiler = "opt" then
+    pr "  Native dynamic link support : %B\n" hasnatdynlink;
+  if coqide <> "no" then
+    pr "  Lablgtk2 library in         : %s\n" !lablgtkdir;
+  if !idearchdef = "QUARTZ" then
+    pr "  Mac OS integration is on\n";
+  pr "  CoqIde                      : %s\n" coqide;
+  pr "  Documentation               : %s\n"
+    (if withdoc then "All" else "None");
+  pr "  Web browser                 : %s\n" browser;
+  pr "  Coq web site                : %s\n\n" !Prefs.coqwebsite;
+  if not !Prefs.nativecompiler then
+    pr "  Native compiler for conversion and normalization disabled\n\n";
+  if !Prefs.local then
+    pr "  Local build, no installation...\n"
+  else
+    (pr "  Paths for true installation:\n";
+     List.iter
+       (fun (_,msg,dir,_) -> pr "  - %s will be copied in %s\n" msg dir)
+       install_dirs);
+  pr "\n";
+  pr "If anything is wrong above, please restart './configure'.\n\n";
+  pr "*Warning* To compile the system for a new architecture\n";
+  pr "          don't forget to do a 'make clean' before './configure'.\n"
+
+let _ = print_summary ()
+
+
+(** * Build the dev/ocamldebug-coq file *)
+
+let write_dbg_wrapper f =
+  safe_remove f;
+  let o = open_out f in
+  let pr s = fprintf o s in
+  pr "#!/bin/sh\n\n";
+  pr "###### ocamldebug-coq : a wrapper around ocamldebug for Coq ######\n\n";
+  pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure #\n\n";
+  pr "export COQTOP=%S\n" coqtop;
+  pr "OCAMLDEBUG=%S\n" (camlbin^"/ocamldebug");
+  pr "CAMLP4LIB=%S\n\n" camlp4lib;
+  pr ". $COQTOP/dev/ocamldebug-coq.run\n";
+  close_out o;
+  Unix.chmod f 0o555
+
+let _ = write_dbg_wrapper "dev/ocamldebug-coq"
+
+
+(** * Build the config/coq_config.ml file (+ link to myocamlbuild_config.ml) *)
+
+let write_configml f =
+  safe_remove f;
+  let o = open_out f in
+  let pr s = fprintf o s in
+  let pr_s = pr "let %s = %S\n" in
+  let pr_b = pr "let %s = %B\n" in
+  let pr_i = pr "let %s = %d\n" in
+  let pr_o s o = pr "let %s = %s\n" s
+    (match o with None -> "None" | Some d -> sprintf "Some %S" d)
+  in
+  pr "(* DO NOT EDIT THIS FILE: automatically generated by ../configure *)\n";
+  pr "(* Exact command that generated this file: *)\n";
+  pr "(* %s *)\n\n" (String.concat " " (Array.to_list Sys.argv));
+  pr_b "local" !Prefs.local;
+  pr "let vmbyteflags = ["; List.iter (pr "%S;") vmbyteflags; pr "]\n";
+  pr_o "coqlib" (if !Prefs.local then None else Some libdir);
+  pr_o "configdir" configdir;
+  pr_o "datadir" datadir;
+  pr_s "docdir" docdir;
+  pr_s "ocaml" camlexec.top;
+  pr_s "ocamlc" camlexec.byte;
+  pr_s "ocamlopt" camlexec.opt;
+  pr_s "ocamlmklib" camlexec.mklib;
+  pr_s "ocamldep" camlexec.dep;
+  pr_s "ocamldoc" camlexec.doc;
+  pr_s "ocamlyacc" camlexec.yacc;
+  pr_s "ocamllex" camlexec.lex;
+  pr_s "camlbin" camlbin;
+  pr_s "camllib" camllib;
+  pr_s "camlp4" camlp4;
+  pr_s "camlp4o" camlexec.p4;
+  pr_s "camlp4bin" camlp4bin;
+  pr_s "camlp4lib" camlp4lib;
+  pr_s "camlp4compat" camlp4compat;
+  pr_s "cflags" cflags;
+  pr_s "best" best_compiler;
+  pr_s "osdeplibs" osdeplibs;
+  pr_s "version" coq_version;
+  pr_s "caml_version" caml_version;
+  pr_s "date" short_date;
+  pr_s "compile_date" full_date;
+  pr_s "arch" arch;
+  pr_b "arch_is_win32" arch_win32;
+  pr_s "exec_extension" exe;
+  pr_s "coqideincl" !lablgtkincludes;
+  pr_s "has_coqide" coqide;
+  pr "let gtk_platform = `%s\n" !idearchdef;
+  pr_b "has_natdynlink" hasnatdynlink;
+  pr_s "natdynlinkflag" natdynlinkflag;
+  pr_i "vo_magic_number" vo_magic;
+  pr_i "state_magic_number" state_magic;
+  pr "let with_geoproof = ref %B\n" !Prefs.geoproof;
+  pr_s "browser" browser;
+  pr_s "wwwcoq" !Prefs.coqwebsite;
+  pr_s "wwwrefman" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/refman/");
+  pr_s "wwwstdlib" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/stdlib/");
+  pr_s "localwwwrefman"  ("file:/" ^ docdir ^ "/html/refman");
+  pr_b "no_native_compiler" (not !Prefs.nativecompiler);
+  pr "\nlet plugins_dirs = [\n";
+  let plugins = Sys.readdir "plugins" in
+  Array.sort compare plugins;
+  Array.iter
+    (fun f ->
+      let f' = "plugins/"^f in
+      if Sys.is_directory f' && f.[0] <> '.' then pr "  %S;\n" f')
+    plugins;
+  pr "]\n";
+  close_out o;
+  Unix.chmod f 0o444
+
+let write_configml_my f f' =
+  write_configml f;
+  if os_type_win32 then
+    write_configml f'
+  else
+    (safe_remove f'; Unix.symlink f f')
+
+let _ = write_configml_my "config/coq_config.ml" "myocamlbuild_config.ml"
+
+
+(** * Build the config/Makefile file *)
+
+let write_makefile f =
+  safe_remove f;
+  let o = open_out f in
+  let pr s = fprintf o s in
+  pr "###### config/Makefile : Configuration file for Coq ##############\n";
+  pr "#                                                                #\n";
+  pr "# This file is generated by the script \"configure\"               #\n";
+  pr "# DO NOT EDIT IT !! DO NOT EDIT IT !! DO NOT EDIT IT !!          #\n";
+  pr "# If something is wrong below, then rerun the script \"configure\" #\n";
+  pr "# with the good options (see the file INSTALL).                  #\n";
+  pr "#                                                                #\n";
+  pr "##################################################################\n\n";
+  pr "#Variable used to detect whether ./configure has run successfully.\n";
+  pr "COQ_CONFIGURED=yes\n\n";
+  pr "# Local use (no installation)\n";
+  pr "LOCAL=%B\n\n" !Prefs.local;
+  pr "# Bytecode link flags : should we use -custom or not ?\n";
+  pr "CUSTOM=%s\n" custom_flag;
+  pr "%s\n\n" !build_loadpath;
+  pr "# Paths for true installation\n";
+  List.iter (fun (v,msg,_,_) -> pr "# %s: path for %s\n" v msg) install_dirs;
+  List.iter (fun (v,_,dir,_) -> pr "%s=%S\n" v dir) install_dirs;
+  pr "\n# Coq version\n";
+  pr "VERSION=%s\n\n" coq_version;
+  pr "# Objective-Caml compile command\n";
+  pr "OCAML=%S\n" camlexec.top;
+  pr "OCAMLC=%S\n" camlexec.byte;
+  pr "OCAMLMKLIB=%S\n" camlexec.mklib;
+  pr "OCAMLOPT=%S\n" camlexec.opt;
+  pr "OCAMLDEP=%S\n" camlexec.dep;
+  pr "OCAMLDOC=%S\n" camlexec.doc;
+  pr "OCAMLLEX=%S\n" camlexec.lex;
+  pr "OCAMLYACC=%S\n\n" camlexec.yacc;
+  pr "# The best compiler: native (=opt) or bytecode (=byte)\n";
+  pr "BEST=%s\n\n" best_compiler;
+  pr "# Ocaml version number\n";
+  pr "CAMLVERSION=%s\n\n" camltag;
+  pr "# Ocaml libraries\n";
+  pr "CAMLLIB=%S\n\n" camllib;
+  pr "# Ocaml .h directory\n";
+  pr "CAMLHLIB=%S\n\n" camllib;
+  pr "# Caml link command and Caml make top command\n";
+  pr "CAMLLINK=%S\n" camlexec.byte;
+  pr "CAMLOPTLINK=%S\n\n" camlexec.opt;
+  pr "# Caml flags\n";
+  pr "CAMLFLAGS=-rectypes %s\n" coq_annotate_flag;
+  pr "# User compilation flag\n";
+  pr "USERFLAGS=\n\n";
+  pr "# Flags for GCC\n";
+  pr "CFLAGS=%s\n\n" cflags;
+  pr "# Compilation debug flags\n";
+  pr "CAMLDEBUG=%s\n" coq_debug_flag;
+  pr "CAMLDEBUGOPT=%s\n\n" coq_debug_flag_opt;
+  pr "# Compilation profile flag\n";
+  pr "CAMLTIMEPROF=%s\n\n" coq_profile_flag;
+  pr "# Camlp4 : flavor, binaries, libraries ...\n";
+  pr "# NB : avoid using CAMLP4LIB (conflict under Windows)\n";
+  pr "CAMLP4=%s\n" camlp4;
+  pr "CAMLP4O=%S\n" camlexec.p4;
+  pr "CAMLP4COMPAT=%s\n" camlp4compat;
+  pr "MYCAMLP4LIB=%S\n\n" camlp4lib;
+  pr "# Your architecture\n";
+  pr "# Can be obtain by UNIX command arch\n";
+  pr "ARCH=%s\n" arch;
+  pr "HASNATDYNLINK=%s\n\n" natdynlinkflag;
+  pr "# Supplementary libs for some systems, currently:\n";
+  pr "#  . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket\n";
+  pr "#  . others     : -cclib -lunix\n";
+  pr "OSDEPLIBS=%s\n\n" osdeplibs;
+  pr "# executable files extension, currently:\n";
+  pr "#  Unix systems:\n";
+  pr "#  Win32 systems : .exe\n";
+  pr "EXE=%s\n" exe;
+  pr "DLLEXT=%s\n\n" dll;
+  pr "# the command MKDIR (try to use mkdirhier if you have problems)\n";
+  pr "MKDIR=mkdir -p\n\n";
+  pr "#the command STRIP\n";
+  pr "# Unix systems and profiling: true\n";
+  pr "# Unix systems and no profiling: strip\n";
+  pr "STRIP=%s\n\n" strip;
+  pr "#the command md5sum\n";
+  pr "MD5SUM=%s\n\n" md5sum;
+  pr "# LablGTK\n";
+  pr "COQIDEINCLUDES=%s\n\n" !lablgtkincludes;
+  pr "# CoqIde (no/byte/opt)\n";
+  pr "HASCOQIDE=%s\n" coqide;
+  pr "IDEFLAGS=%s\n" !idearchflags;
+  pr "IDEOPTCDEPS=%s\n" !idearchfile;
+  pr "IDECDEPS=%s\n" !idearchfile;
+  pr "IDECDEPSFLAGS=%s\n" !idecdepsflags;
+  pr "IDEINT=%s\n\n" !idearchdef;
+  pr "# Defining REVISION\n";
+  pr "CHECKEDOUT=%s\n\n" vcs;
+  pr "# Option to control compilation and installation of the documentation\n";
+  pr "WITHDOC=%s\n" (if withdoc then "all" else "no");
+  close_out o;
+  Unix.chmod f 0o444
+
+let _ = write_makefile "config/Makefile"
+
+let write_macos_metadata exec =
+  let f = "config/Info-"^exec^".plist" in
+  let () = safe_remove f in
+  let o = open_out f in
+  let pr s = fprintf o s in
+  pr "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
+  pr "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">\n";
+  pr "<plist version=\"1.0\">\n";
+  pr "<dict>\n";
+  pr "    <key>CFBundleIdentifier</key>\n";
+  pr "    <string>fr.inria.coq.%s</string>\n" exec;
+  pr "    <key>CFBundleName</key>\n";
+  pr "    <string>%s</string>\n" exec;
+  pr "    <key>CFBundleVersion</key>\n";
+  pr "    <string>%s</string>\n" coq_macos_version;
+  pr "    <key>CFBundleShortVersionString</key>\n";
+  pr "    <string>%s</string>\n" coq_macos_version;
+  pr "    <key>CFBundleInfoDictionaryVersion</key>\n";
+  pr "    <string>6.0</string>\n";
+  pr "</dict>\n";
+  pr "</plist>\n";
+  let () = close_out o in
+  Unix.chmod f 0o444
+
+let () = if arch = "Darwin" then
+List.iter write_macos_metadata distributed_exec
diff --git a/dev/TODO b/dev/TODO
index 926861c9..e62ee6e5 100644
--- a/dev/TODO
+++ b/dev/TODO
@@ -3,16 +3,16 @@
      - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml
 
  o arguments implicites
-     - les calculer une fois pour toutes à la déclaration (dans Declare)
+     - les calculer une fois pour toutes à la déclaration (dans Declare)
        et stocker cette information dans le in_variable, in_constant, etc.
 
- o Environnements compilés (type Environ.compiled_env)
-     - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?)
+ o Environnements compilés (type Environ.compiled_env)
+     - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?)
 
- o Efficacité
-     - utiliser DOPL plutôt que DOPN (sauf pour Case)
+ o Efficacité
+     - utiliser DOPL plutôt que DOPN (sauf pour Case)
      - batch mode => pas de undo, ni de reset
-     - conversion : déplier la constante la plus récente
+     - conversion : déplier la constante la plus récente
      - un cache pour type_of_const, type_of_inductive, type_of_constructor,
        lookup_mind_specif
 
diff --git a/dev/base_include b/dev/base_include
index 9a788b7b..de63c557 100644
--- a/dev/base_include
+++ b/dev/base_include
@@ -12,7 +12,10 @@
 #directory "lib";;
 #directory "proofs";;
 #directory "tactics";;
-#directory "translate";;
+#directory "printing";;
+#directory "grammar";;
+#directory "intf";;
+#directory "stm";;
 
 #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *)
 #directory "+camlp5";; (* Gramext is found in top_printers.ml *)
@@ -31,14 +34,17 @@
 #install_printer  (* qualid *)  ppqualid;;
 #install_printer  (* kernel_name *) ppkn;;
 #install_printer  (* constant *) ppcon;;
+#install_printer  (* projection *) ppproj;;
 #install_printer  (* cl_index *) ppclindex;;
-#install_printer  (* constr *)  print_pure_constr;; 
+#install_printer  (* recarg Rtree.t *)  ppwf_paths;;
+#install_printer  (* constr *)  print_pure_constr;;
 #install_printer  (* patch *) ppripos;;
 #install_printer  (* values *) ppvalues;;
 #install_printer  (* Idpred.t *) pp_idpred;;
 #install_printer  (* Cpred.t *) pp_cpred;;
 #install_printer ppzipper;;
 #install_printer ppstack;;
+#install_printer (* Reductionops.Stack.t *) pp_stack_t;;
 #install_printer ppatom;;
 #install_printer ppwhd;;
 #install_printer ppvblock;;
@@ -50,6 +56,8 @@
 
 open Names
 open Term
+open Vars
+open Context
 open Typeops
 open Term_typing
 open Univ
@@ -63,38 +71,48 @@ open Declare
 open Declaremods
 open Impargs
 open Libnames
+open Globnames
 open Nametab
 open Library
 
 open Cases
 open Pattern
+open Patternops
 open Cbv
 open Classops
+open Arguments_renaming
 open Pretyping
-open Pretyping.Default
-open Pretyping.Default.Cases
 open Cbv
 open Classops
 open Clenv
 open Clenvtac
 open Glob_term
+open Glob_ops
 open Coercion
-open Coercion.Default
 open Recordops
 open Detyping
 open Reductionops
 open Evarconv
 open Retyping
 open Evarutil
+open Evarsolve
 open Tacred
 open Evd
+open Universes
 open Termops
 open Namegen
 open Indrec
 open Typing
 open Inductiveops
+open Locusops
+open Find_subterm
 open Unification
-open Matching
+open Miscops
+open Miscops
+open Nativenorm
+open Typeclasses
+open Typeclasses_errors
+open Vnorm
 
 open Constrextern
 open Constrintern
@@ -105,19 +123,28 @@ open Notation
 open Ppextend
 open Reserve
 open Syntax_def
+open Constrexpr
+open Constrexpr_ops
 open Topconstr
+open Notation_term
+open Notation_ops
 open Prettyp
 open Search
 
 open Evar_refiner
+open Goal
 open Logic
 open Pfedit
+open Proof
+open Proof_using
+open Proof_global
 open Proof_type
 open Redexpr
 open Refiner
 open Tacmach
-open Decl_proof_instr
 open Tactic_debug
+
+open Decl_proof_instr
 open Decl_mode
 
 open Auto
@@ -129,11 +156,11 @@ open Equality
 open Evar_tactics
 open Extraargs
 open Extratactics
-open Hiddentac
 open Hipattern
 open Inv
 open Leminv
-open Refine
+open Tacsubst
+open Tacintern
 open Tacinterp
 open Tacticals
 open Tactics
@@ -145,7 +172,6 @@ open Command
 open Indschemes
 open Ind_tables
 open Auto_ind_decl
-open Lemmas
 open Coqinit
 open Coqtop
 open Discharge
@@ -153,7 +179,7 @@ open Himsg
 open Metasyntax
 open Mltop
 open Record
-open Toplevel
+open Coqloop
 open Vernacentries
 open Vernacinterp
 open Vernac
@@ -171,22 +197,22 @@ let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac;;
 (* build a term of type glob_constr without type-checking or resolution of 
    implicit syntax *)
 
-let e s =
-  Constrintern.intern_constr Evd.empty (Global.env()) (parse_constr s);;
+let e s = Constrintern.intern_constr (Global.env()) (parse_constr s);;
 
 (* build a term of type constr with type-checking and resolution of 
    implicit syntax *)
 
 let constr_of_string s = 
-  Constrintern.interp_constr Evd.empty (Global.env()) (parse_constr s);;
+  Constrintern.interp_constr (Global.env()) Evd.empty (parse_constr s);;
 
 (* get the body of a constant *)
 
 open Declarations;;
+open Declareops;;
 
 let constbody_of_string s =
   let b = Global.lookup_constant (Nametab.locate_constant (qualid_of_string s)) in
-  Option.get (body_of_constant b);;
+  Option.get (Declareops.body_of_constant Opaqueproof.empty_opaquetab b);;
 
 (* Get the current goal *)
 (*
@@ -196,14 +222,15 @@ let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());;
 let current_goal () = get_nth_goal 1;;
 *)
 let pf_e gl s = 
-  Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);;
+  Constrintern.interp_constr (pf_env gl) (project gl) (parse_constr s);;
 
 (* Set usual printing since the global env is available from the tracer *)
-let _ = Constrextern.in_debugger := false
+let _ = Flags.in_debugger := false
+let _ = Flags.in_toplevel := true
 let _ = Constrextern.set_extern_reference
   (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));;
 
-open Toplevel
+open Coqloop
 let go = loop
 
 let _ =
diff --git a/dev/db b/dev/db
index 63c98bb6..f259b50e 100644
--- a/dev/db
+++ b/dev/db
@@ -1,20 +1,28 @@
 load_printer "gramlib.cma"
+load_printer "str.cma"
 load_printer "printers.cma"
 
+install_printer Top_printers.ppfuture
+
 install_printer Top_printers.ppid
 install_printer Top_printers.ppidset
+install_printer Top_printers.ppevar
 install_printer Top_printers.ppevarsubst
+install_printer Top_printers.ppexistentialfilter
+install_printer Top_printers.ppexistentialset
 install_printer Top_printers.ppintset
 install_printer Top_printers.pplab
 install_printer Top_printers.ppdir
 install_printer Top_printers.ppmp
 install_printer Top_printers.ppkn
 install_printer Top_printers.ppcon
+install_printer Top_printers.ppwf_paths
 install_printer Top_printers.ppmind
 install_printer Top_printers.ppsp
 install_printer Top_printers.ppqualid
 install_printer Top_printers.ppclindex
 install_printer Top_printers.ppbigint
+install_printer Top_printers.pp_transparent_state
 
 install_printer Top_printers.pppattern
 install_printer Top_printers.ppglob_constr
@@ -26,10 +34,16 @@ install_printer Top_printers.ppconstraints
 install_printer Top_printers.pptype
 install_printer Top_printers.ppj
 install_printer Top_printers.ppenv
+install_printer Top_printers.ppnamedcontextval
+install_printer Top_printers.pp_stack_t
+install_printer Top_printers.pp_cst_stack_t
 
 install_printer Top_printers.ppmetas
 install_printer Top_printers.ppevm
+install_printer Top_printers.ppgoalgoal
 install_printer Top_printers.ppgoal
+install_printer Top_printers.ppproofview
+install_printer Top_printers.pphintdb
 
 install_printer Top_printers.pptac
 install_printer Top_printers.ppobj
@@ -37,3 +51,10 @@ install_printer Top_printers.pploc
 install_printer Top_printers.prsubst
 install_printer Top_printers.prdelta
 install_printer Top_printers.ppfconstr
+install_printer Top_printers.ppgenarginfo
+install_printer Top_printers.ppist
+install_printer Top_printers.ppconstrunderbindersidmap
+install_printer Top_printers.ppunbound_ltac_var_map
+install_printer Top_printers.ppididmap
+install_printer Top_printers.ppclosure
+install_printer Top_printers.ppclosedglobconstr
diff --git a/dev/db_printers.ml b/dev/db_printers.ml
index f535de4a..e843bbc5 100644
--- a/dev/db_printers.ml
+++ b/dev/db_printers.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        *)
@@ -10,7 +10,7 @@ open Names
 
 let pp s = pp (hov 0 s)
 
-let prid id = Format.print_string (string_of_id id)
-let prsp sp = Format.print_string (string_of_path sp)
+let prid id = Format.print_string (Id.to_string id)
+let prsp sp = Format.print_string (DirPath.to_string sp)
 
 
diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt
index 3d9cba14..af1120e9 100644
--- a/dev/doc/build-system.dev.txt
+++ b/dev/doc/build-system.dev.txt
@@ -1,21 +1,38 @@
 
-Since July 2007, Coq features a build system overhauled by Pierre
-Corbineau and Lionel Elie Mamane.
-
----------------------------------------------------------------------
-WARNING:
-In March 2010 this build system has been heavily adapted by Pierre
-Letouzey. In particular there no more explicit stage1,2. Stage3
-was removed some time ago when coqdep was splitted into coqdep_boot
-and full coqdep. Ideas are still similar to what is describe below,
-but:
-1) .ml4 are explicitely turned into .ml files, which stay after build
-2) we let "make" handle the inclusion of .d without trying to guess
-   what could be done at what time. Some initial inclusions hence
-  _fail_, but "make" tries again later and succeed.
-
-TODO: remove obsolete sections below and better describe the new approach
------------------------------------------------------------------------
+
+HISTORY:
+-------
+
+* July 2007 (Pierre Corbineau & Lionel Elie Mamane).
+  Inclusion of a build system with 3 explicit phases:
+  - Makefile.stage1: ocamldep, sed, camlp4 without Coq grammar extension
+  - Makefile.stage2: camlp4 with grammar.cma or q_constr.cmo
+  - Makefile.stage3: coqdep (.vo)
+
+* March 2010 (Pierre Letouzey).
+  Revised build system. In particular, no more stage1,2,3 :
+  - Stage3 was removed some time ago when coqdep was splitted into
+    coqdep_boot and full coqdep.
+  - Stage1,2 were replaced by brutal inclusion of all .d at the start
+    of Makefile.build, without trying to guess what could be done at
+    what time. Some initial inclusions hence _fail_, but "make" tries
+    again later and succeed.
+  - Btw, .ml4 are explicitely turned into .ml files, which stay after build.
+    By default, they are in binary ast format, see READABLE_ML4 option.
+
+* February 2014 (Pierre Letouzey).
+  Another revision of the build system. We avoid relying on the awkward
+  include-which-fails-but-works-finally-after-a-retry feature of gnu make.
+  This was working, but was quite hard to understand. Instead, we reuse
+  the idea of two explicit phases, but in a lighter way than in 2007.
+  The main Makefile calls Makefile.build twice :
+  - first for building grammar.cma (and q_constr.cmo), with a
+    restricted set of .ml4 (see variable BUILDGRAMMAR).
+  - then on the true target asked by the user.
+
+    
+---------------------------------------------------------------------------
+
 
 This file documents internals of the implementation of the build
 system. For what a Coq developer needs to know about the build system,
@@ -24,68 +41,47 @@ see build-system.txt .
 .ml4 files
 ----------
 
-.ml files corresponding to .ml4 files are created to keep ocamldep
-happy only. To ensure they are not used for compilation, they contain
-invalid OCaml.
-
+.ml4 are converted to .ml by camlp4. By default, they are produced
+in the binary ast format understood by ocamlc/ocamlopt/ocamldep.
+Pros:
+ - faster than parsing clear-text source file.
+ - no risk of editing them by mistake instead of the .ml4
+ - the location in the binary .ml are those of the initial .ml4,
+   hence errors are properly reported in the .ml4.
+Cons:
+ - This format may depend on your ocaml version, they should be
+   cleaned if you change your build environment.
+ - Unreadable in case you want to inspect this generated code.
+   For that, use make with the READABLE_ML4=1 option to switch to
+   clear-text generated .ml.
 
-multi-stage build
------------------
 
-Le processus de construction est séparé en trois étapes qui correspondent
-aux outils nécessaires pour calculer les dépendances de cette étape:
-
-stage1: ocamldep, sed , camlp4 sans fichiers de Coq
-stage2: camlp4 avec grammar.cma et/ou q_constr.cmo
-stage3: coqdep (.vo)
+Makefiles hierachy
+------------------
 
 Le Makefile a été séparé en plusieurs fichiers :
 
-- Makefile: coquille vide qui délègue les cibles à la bonne étape sauf
-  clean et les fichiers pour emacs (car ils sont en quelque sorte en
-  "stage0": aucun calcul de dépendance nécessaire).
+- Makefile: coquille vide qui lançant Makefile.build sauf pour
+  clean et quelques petites choses ne nécessitant par de calculs
+  de dépendances.
 - Makefile.common : définitions des variables (essentiellement des
   listes de fichiers)
-- Makefile.build : les règles de compilation sans inclure de
-  dépendances
-- Makefile.stage* : fichiers qui incluent les dépendances calculables
-  à cette étape ainsi que Makefile.build.
-
-The build needs to be cut in stages because make will not take into
-account one include when making another include.
+- Makefile.build : contient les regles de compilation, ainsi que
+  le "include" des dépendances (restreintes ou non selon la variable
+  BUILDGRAMMAR).
+- Makefile.doc : regles specifiques à la compilation de la documentation.
 
 
 Parallélisation
 ---------------
 
-Le découpage en étapes veut dire que le makefile est un petit peu
-moins parallélisable que strictement possible en théorie: par exemple,
-certaines choses faites en stage2 pourraient être faites en parallèle
-avec des choses de stage1. Nous essayons de minimiser cet effet, mais
-nous ne l'avons pas complètement éliminé parce que cela mènerait à un
-makefile très complexe. La minimisation est principalement que si on
-demande un objet spécifique (par exemple "make parsing/g_constr.cmx"),
-il est fait dans l'étape la plus basse possible (simplement), mais si
-un objet est fait comme dépendance de la cible demandée (par exemple
-dans un "make world"), il est fait le plus tard possible (par exemple,
-tout code OCaml non nécessaire pour coqdep ni grammar.cma ni
-q_constr.cmo est compilé en stage3 lors d'un "make world"; cela permet
-le parallélisme de compilation de code OCaml et de fichiers Coq (.v)).
-
-Le "(simplement)" ci-dessus veut dire que savoir si un fichier non
-nécessaire pour grammar.cma/q_constr.cmo peut en fait être fait en
-stage1 est compliqué avec make, alors nous retombons en général sur le
-stage2. La séparation entre le stage2 et stage3 est plus facile, donc
-l'optimisation ci-dessus s'y applique pleinement.
-
-En d'autres mots, nous avons au niveau conceptuel deux assignations
-d'étape pour chaque fichier:
-
- - l'étape la plus petite où nous savons qu'il peut être fait.
- - l'étape la plus grande où il peut être fait.
-
-Mais seule la première est gérée explicitement, la seconde est
-implicite.
+Il y a actuellement un double appel interne à "make -f Makefile.build",
+d'abord pour construire grammar.cma/q_constr.cmo, puis le reste.
+Cela signifie que ce makefile est un petit peu moins parallélisable
+que strictement possible en théorie: par exemple, certaines choses
+faites lors du second make pourraient être faites en parallèle avec
+le premier. En pratique, ce premier make va suffisemment vite pour
+que cette limitation soit peu gênante.
 
 
 FIND_VCS_CLAUSE
diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt
index b243ebe2..31d9875a 100644
--- a/dev/doc/build-system.txt
+++ b/dev/doc/build-system.txt
@@ -1,26 +1,8 @@
-Since July 2007, Coq features a build system overhauled by Pierre
-Corbineau and Lionel Elie Mamane.
-
----------------------------------------------------------------------
-WARNING:
-In March 2010 this build system has been heavily adapted by Pierre
-Letouzey. In particular there no more explicit stage1,2. Stage3
-was removed some time ago when coqdep was splitted into coqdep_boot
-and full coqdep. Ideas are still similar to what is describe below,
-but:
-1) .ml4 are explicitely turned into .ml files, which stay after build
-2) we let "make" handle the inclusion of .d without trying to guess
-   what could be done at what time. Some initial inclusions hence
-  _fail_, but "make" tries again later and succeed.
-
-TODO: remove obsolete sections below and better describe the new approach
------------------------------------------------------------------------
 
 This file documents what a Coq developer needs to know about the build
 system. If you want to enhance the build system itself (or are curious
-about its implementation details), see build-system.dev.txt .
-
-The build system is not at its optimal state, see TODO section.
+about its implementation details), see build-system.dev.txt, and in
+particular its initial HISTORY section.
 
 
 FAQ: special features used in this Makefile
@@ -51,22 +33,10 @@ $(subst ...), $(patsubst ...), $(shell ...), $(foreach ...), $(if ...)
 * Behavior of -include
 
 If the file given to -include doesn't exist, make tries to build it,
-but doesn't care if this build fails. This can be quite surprising,
-see in particular the -include in Makefile.stage*
-
-
-Stages in build system
-----------------------
-
-The build system is separated into three stages, corresponding to the
-tool(s) necessary to compute the dependencies necessary at this stage:
-
-stage1: ocamldep, sed, camlp4 without Coq extensions
-stage2: camlp4 with grammar.cma and/or q_constr.cmo
-stage3: coqdep (.vo)
-
-The file "Makefile" itself serves as minimum stage for targets that
-should not need any dependency (such as *clean*).
+and even retries again if necessary, but doesn't care if this build
+finally fails. We used to rely on this "feature", but this should not
+be the case anymore. We kept "-include" instead of "include" for
+avoiding warnings about initially non-existant files.
 
 Changes (for old-timers)
 ------------------------
@@ -97,40 +67,11 @@ save precious time:
 
  - Always ask for what you want directly (e.g. bin/coqtop,
    foo/bar.cmo, ...), don't do "make world" and interrupt
-   it when it has done what you want. This will try to minimise the
-   stage at which what you ask for is done (instead of maximising it
-   in order to maximise parallelism of the build process).
-
+   it when it has done what you want.
    For example, if you only want to test whether bin/coqtop still
    builds (and eventually start it to test your bugfix or new
-   feature), don't do "make world" and interrupt it when bin/coqtop is
-   built. Use "make bin/coqtop" or "make coqbinaries" or something
-   like that. This will avoid entering the stage 3, and cut build
-   system overhead by 50% (1.2s instead of 2.4 on writer's machine).
-
- - You can turn off rebuilding of the standard library each time
-   bin/coqtop is rebuilt with NO_RECOMPILE_LIB=1.
-
- - If you want to avoid all .ml4 files being recompiled only because
-   grammar.cma was rebuilt, do "make ml4depclean" once and then use
-   NO_RECOMPILE_ML4=1.
-
- - The CM_STAGE1=1 option to make will build all .cm* files mentioned
-   as targets on the command line in stage1. Whether this will work is
-   your responsibility. It should work for .ml files that don't depend
-   (nor directly nor indirectly through transitive closure of the
-   dependencies) on any .ml4 file, or where those dependencies can be
-   safely ignored in the current situation (e.g. all these .ml4 files
-   don't need to be recompiled).
-
-   This will avoid entering the stage2 (a reduction of 33% in
-   overhead, 0.4s on the writer's machine).
-
- - To jump directly into a stage (e.g. because you know nothing is to
-   be done in stage 1 or (1 and 2) or because you know that the target
-   you give can be, in this situation, done in a lower stage than the
-   build system dares to), use GOTO_STAGE=n. This will jump into stage
-   n and try to do the targets you gave in that stage.
+   feature), use "make bin/coqtop" or "make coqbinaries" or something
+   like that.
 
  - To disable all dependency recalculation, use the NO_RECALC_DEPS=1
    option. It disables REcalculation of dependencies, not calculation
@@ -138,12 +79,6 @@ save precious time:
    still created, but it is not updated every time the source file
    (e.g. .ml) is changed.
 
-General speed improvements:
-
- - When building both the native and bytecode versions, the
-   KEEP_ML4_PREPROCESSED=1 option may reduce global compilation time
-   by running camlp4o only once on every .ml4 file, at the expense of
-   readability of compilation error messages for .ml4 files.
 
 Dependencies
 ------------
@@ -181,166 +116,30 @@ Targets for cleaning various parts:
 .ml4 files
 ----------
 
-The camlp4-preprocessed version of FOO.ml4 is FOO.ml4-preprocessed and
-can be obtained with:
- make FOO.ml4-preprocessed
-
 If a .ml4 file uses a grammar extension from Coq (such as grammar.cma
 or q_constr.cmo), it must contain a line like:
  (*i camlp4deps: "grammar.cma q_constr.cmo" i*)
 
-If it uses a standard grammar extension, it must contain a line like:
- (*i camlp4use: "pa_ifdef.cmo" i*)
-
-It can naturally contain both a camlp4deps and a camlp4use line. Both
-are used for preprocessing. It is thus _not_ necessary to add a
-specific rule for a .ml4 file in the Makefile.build just because it
-uses grammar extensions.
-
-By default, the build system is geared towards development that may
-use the Coq grammar extensions, but not development of Coq's grammar
-extensions themselves. This means that .ml4 files are compiled
-directly (using ocamlc/opt's -pp option), without use of an
-intermediary .ml (or .ml4-preprocessed) file. This is so that if a
-compilation error occurs, the location in the error message is a
-location in the .ml4 file. If you are modifying the grammar
-extensions, you may be more interested in the location of the error in
-the .ml4-preprocessed file, so that you can see what your new grammar
-extension made wrong. In that case, use the KEEP_ML4_PREPROCESSED=1
-option. This will make compilation of a .ml4 file a two-stage process:
-
-1) create the .ml4-preprocessed file with camlp4o
-2) compile it with straight ocamlc/opt without preprocessor
-
-and will instruct make not to delete .ml4-preprocessed files
-automatically just because they are intermediary files, so that you
-can inspect them.
-
-If you add a _new_ grammar extension to Coq:
-
- - if it can be built at stage1, that is the .ml4 file does not use a
-   Coq grammar extension itself, then add it, and all .cmo files it
-   needs to STAGE1_TARGETS and STAGE_ML4 in Makefile.common. See the
-   handling of grammar.cma and q_constr.cmo for an example.
-
- - if it cannot be built at stage1, that is the .ml4 file itself needs
-   to be preprocessed with a Coq camlp4 grammar extension, then,
-   congratulations, you need to add a new stage between stage1 and
-   stage2.
+The use of (*i camlp4use: ... i*) to mention uses of standard
+extension such as IFDEF has been discontinued, the Makefile now
+always calls camlp4 with pa_macros.cmo and a few others by default.
+
+For debugging a Coq grammar extension, it could be interesting
+to use the READABLE_ML4=1 option, otherwise the generated .ml are
+in an internal binary format (see build-system.dev.txt).
+
 
 New files
 ---------
 
 For a new file, in most cases, you just have to add it to the proper
-file list(s) in Makefile.common, such as ARITHVO or TACTICS.
+file list(s):
+ - For .ml, in the corresponding .mllib (e.g. kernel/kernel.mllib)
+   These files are also used by the experimental ocamlbuild plugin,
+   which is quite touchy about them : be careful with order,
+   duplicated entries, whitespace errors, and do not mention .mli there.
+ - For .v, in the corresponding vo.itarget (e.g theories/Init/vo.itarget)
+ - The definitions in Makefile.common might have to be adapted too.
+ - If your file needs a specific rule, add it to Makefile.build
 
 The list of all ml4 files is not handled manually anymore.
-
-Exceptions are:
-
- - The file is necessary at stage1, that it is necessary to build the
-   Coq camlp4 grammar extensions. In this case, make sure it ends up
-   in STAGE1_CMO and (for .ml4 files) STAGE1_ML4. See the handling of
-   grammar.cma and/or q_constr.cmo for an example.
-
- - if the file needs to be compiled with -rectypes, add it to
-   RECTYPESML in Makefile.common. If it is a .ml4 file, implement
-   RECTYPESML4 or '(*i ocamlflags i*)'; see TODO.
-
- - the file needs a specific Makefile entry; add it to Makefile.build
-
- - the files produced from the added file do not match an existing
-   pattern or entry in "Makefile". (All the common cases of
-   .ml{,i,l,y,4}, .v, .c, ... files that produces (respectively)
-   .cm[iox], .vo, .glob, .o, ... files with the same basename are
-   already covered.) In this case, see section "New targets".
-
-New targets
------------
-
-If you want to add:
-
- - a new PHONY target to the build system, that is a target that is
-   not the name of the file it creates,
-
- - a normal target is not already mapped to a stage by "Makefile"
-
- then:
-
- - add the necessary rule to Makefile.build, if any
- - add the target to STAGEn_TARGETS, with n being the smallest stage
-   it can be built at, that is:
-   * 1 for OCaml code that doesn't use any Coq camlp4 grammar extension
-   * 2 for OCaml code that uses (directly or indirectly) a Coq
-       camlp4 grammar extension. Indirectly means a dependency of it
-       does.
-   * 3 for Coq (.v) code.
-
-   *or*
-
-   add a pattern matching the target to the pattern lists for the
-   smallest stage it can be built at in "Makefile".
-
-TODO
-----
-
-delegate pa_extend.cmo to camlp4use statements and remove it from
-standard camlp4 options.
-
-maybe manage compilation flags (such as -rectypes or the CoqIDE ones)
-from a
- (*i ocamlflags: "-rectypes" i*)
-statement in the .ml(4) files themselves, like camlp4use. The CoqIDE
-files could have
- (*i ocamlflags: "${COQIDEFLAGS}" i*)
-and COQIDEFLAGS is still defined (and exported by) the Makefile.build.
-
-Clean up doc/Makefile
-
-config/Makefile looks like it contains a lot of unused variables,
-clean that up (are any maybe used by nightly scripts on
-pauillac?). Also, the COQTOP variable from config/Makefile (and used
-in contribs) has a very poorly chosen name, because "coqtop" is the
-name of a Coq executable! In the coq Makefiles, $(COQTOPEXE) is used
-to refer to that executable.
-
-Promote the granular .glob handling to official way of doing things
-for Coq developments, that is implement it in coq_makefile and the
-contribs. Here are a few hints:
-
->> Les fichiers de constantes produits par -dump-glob sont maintenant
->> produits par fichier et sont ensuite concaténés dans
->> glob.dump. Ilsont produits par défaut (avec les bonnes
->> dépendances).
-
-> C'est une chose que l'on voulait faire aussi.
-
-(J'ai testé et débogué ce concept sur CoRN dans les derniers mois.)
-
-> Est-ce que vous sauriez modifier coq_makefile pour qu'il procède de
-> la même façon
-
-Dans cette optique, il serait alors plus propre de changer coqdep pour
-qu'il produise directement l'output que nous mettons maintenant dans
-les .v.d (qui est celui de coqdoc post-processé avec sed).
-
-Si cette manière de gérer les glob devient le standard béni
-officiellement par "the Coq development team", ne voudrions nous pas
-changer coqc pour qu'il produise FOO.glob lors de la compilation de
-FOO.v par défaut (sans argument "-dump-glob")?
-
-> et que la production de a.html par coqdoc n'ait une dépendance qu'en
-> les a.v et a.glob correspondant ?
-
-Je crois que coqdoc exige un glob-dump unique, il convient donc de
-concaténer les .glob correspondants. Soit un glob-dump global par
-projet (par Makefile), soit un glob-dump global par .v(o), qui
-contient son .glob et ceux de tous les .v(o) atteignables par le
-graphe des dépendances. CoRN contient déjà un outil de calcul de
-partie atteignable du graphe des dépendances (il y est pour un autre
-usage, pour calculer les .v à mettre dans les différents tarballs sur
-http://corn.cs.ru.nl/download.html; les parties partielles sont
-définies par liste de fichiers .v + toutes leurs dépendances
-(in)directes), il serait alors adéquat de le mettre dans les tools de
-Coq.
-
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index 322530e6..2f62be9a 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -1,4 +1,103 @@
 =========================================
+= CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 =
+=========================================
+
+** Refactoring : more mli interfaces and simpler grammar.cma **
+
+- A new directory intf/ now contains mli-only interfaces :
+
+ Constrexpr : definition of constr_expr, was in Topconstr
+ Decl_kinds : now contains binding_kind = Explicit | Implicit
+ Evar_kinds : type Evar_kinds.t was previously Evd.hole_kind
+ Extend : was parsing/extend.mli
+ Genredexpr : regroup Glob_term.red_expr_gen and Tacexpr.glob_red_flag
+ Glob_term  : definition of glob_constr
+ Locus : definition of occurrences and stuff about clauses
+ Misctypes : intro_pattern_expr, glob_sort, cast_type, or_var, ...
+ Notation_term : contains notation_constr, was Topconstr.aconstr
+ Pattern : contains constr_pattern
+ Tacexpr : was tactics/tacexpr.ml
+ Vernacexpr : was toplevel/vernacexpr.ml
+
+- Many files have been divided :
+
+ vernacexpr: vernacexpr.mli + Locality
+ decl_kinds: decl_kinds.mli + Kindops
+ evd: evar_kinds.mli + evd
+ tacexpr: tacexpr.mli + tacops
+ glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops
+ topconstr: constrexpr.mli + constrexpr_ops
+            + notation_expr.mli + notation_ops + topconstr
+ pattern: pattern.mli + patternops
+ libnames: libnames (qualid, reference) + globnames (global_reference)
+ egrammar: egramml + egramcoq
+
+- New utility files : miscops (cf. misctypes.mli) and
+  redops (cf genredexpr.mli).
+
+- Some other directory changes :
+  * grammar.cma and the source files specific to it are now in grammar/
+  * pretty-printing files are now in printing/
+
+- Inner-file changes :
+
+  * aconstr is now notation_constr, all constructors for this type
+    now start with a N instead of a A (e.g. NApp instead of AApp),
+    and functions about aconstr may have been renamed (e.g. match_aconstr
+    is now match_notation_constr).
+
+  * occurrences (now in Locus.mli) is now an algebraic type, with
+    - AllOccurrences instead of all_occurrences_expr = (false,[])
+    - (AllOccurrencesBut l) instead of (all_occurrences_expr_but l) = (false,l)
+    - NoOccurrences instead of no_occurrences_expr = (true,[])
+    - (OnlyOccurrences l) instead of (no_occurrences_expr_but l) = (true,l)
+
+  * move_location (now in Misctypes) has two new constructors
+    MoveFirst and MoveLast replacing (MoveToEnd false) and (MoveToEnd true)
+
+- API of pretyping.ml and constrintern.ml has been made more uniform
+  * Parametrization of understand_* functions is now made using
+    "inference flags"
+  * Functions removed:
+    - interp_constr_judgment (inline its former body if really needed)
+    - interp_casted_constr, interp_type: use instead interp_constr with
+      expected_type set to OfType or to IsType
+    - interp_gen: use any of interp_constr, interp_casted_constr, interp_type
+    - interp_open_constr_patvar
+    - interp_context: use interp_context_evars (with a "evar_map ref") and
+      call solve_remaining_evars afterwards with a failing flag
+      (e.g. all_and_fail_flags)
+    - understand_type, understand_gen: use understand with appropriate
+      parameters
+  * Change of semantics:
+    - Functions interp_*_evars_impls have a different interface and do
+      not any longer check resolution of evars by default; use
+      check_evars_are_solved explicitly to check that evars are solved.
+  See also the corresponding commit log.
+
+- Tactics API: new_induct -> induction; new_destruct -> destruct;
+  letin_pat_tac do not accept a type anymore
+
+- New file find_subterm.ml for gathering former functions
+  subst_closed_term_occ_modulo, subst_closed_term_occ_decl (which now
+  take and outputs also an evar_map), and
+  subst_closed_term_occ_modulo, subst_closed_term_occ_decl_modulo (now
+  renamed into replace_term_occ_modulo and
+  replace_term_occ_decl_modulo).
+
+- API of Inductiveops made more uniform (see commit log or file itself).
+
+- API of intros_pattern style tactic changed; "s" is dropped in
+  "intros_pattern" and "intros_patterns" is not anymore behaving like
+  tactic "intros" on the empty list.
+
+- API of cut tactics changed: for instance, cut_intro should be replaced by
+  "assert_after Anonymous"
+
+- All functions taking an env and a sigma (or an evdref) now takes the
+  env first.
+
+=========================================
 = CHANGES BETWEEN COQ V8.3 AND COQ V8.4 =
 =========================================
 
@@ -516,14 +615,14 @@ Changements d'organisation / modules :
   Std, More_util		-> lib/util.ml
 
   Names				-> kernel/names.ml et kernel/sign.ml
-    (les parties noms et signatures ont été séparées)
+    (les parties noms et signatures ont été séparées)
 
-  Avm,Mavm,Fmavm,Mhm  ->  utiliser plutôt Map (et freeze alors gratuit)
+  Avm,Mavm,Fmavm,Mhm  ->  utiliser plutôt Map (et freeze alors gratuit)
   Mhb                 ->  Bij
 
-  Generic est intégré à Term (et un petit peu à Closure)
+  Generic est intégré à Term (et un petit peu à Closure)
 
-Changements dans les types de données :
+Changements dans les types de données :
 ---------------------------------------
   dans Generic: free_rels : constr -> int Listset.t
                   devient : constr -> Intset.t
@@ -543,7 +642,7 @@ ATTENTION:
   
 		try . .. with UserError _ -> ...
 
-  mais écrire à la place
+  mais écrire à la place
  
                 try ... with e when Logic.catchable_exception e -> ...
 
@@ -675,7 +774,7 @@ Changements dans les inductifs
 Nouveaux types "constructor" et "inductive" dans Term
 La plupart des fonctions de typage des inductives prennent maintenant
 un inductive au lieu d'un oonstr comme argument. Les seules fonctions
-à traduire un constr en inductive sont les find_rectype and co.
+à traduire un constr en inductive sont les find_rectype and co.
 
 Changements dans les grammaires
 -------------------------------
@@ -683,9 +782,9 @@ Changements dans les grammaires
  . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex
 
  . attention : LIDENT -> IDENT  (les identificateurs n'ont pas de
-                                 casse particulière dans Coq)
+                                 casse particulière dans Coq)
 
- . Le mot "command" est remplacé par "constr" dans les noms de
+ . Le mot "command" est remplacé par "constr" dans les noms de
  fichiers, noms de modules et non-terminaux relatifs au parsing des
  termes; aussi les changements suivants "COMMAND"/"CONSTR" dans
  g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml*
@@ -693,22 +792,22 @@ Changements dans les grammaires
  . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n
    passent en minuscule Identifier, Constr, ...
  
- . Plusieurs parsers ont changé de format (ex: sortarg)
+ . Plusieurs parsers ont changé de format (ex: sortarg)
 
 Changements dans le pretty-printing
 -----------------------------------
 
- . Découplage de la traduction de constr -> rawconstr (dans detyping)
+ . Découplage de la traduction de constr -> rawconstr (dans detyping)
     et de rawconstr -> ast (dans termast)
- . Déplacement des options d'affichage de printer vers termast
- . Déplacement des réaiguillage d'univers du pp de printer vers esyntax
+ . Déplacement des options d'affichage de printer vers termast
+ . Déplacement des réaiguillage d'univers du pp de printer vers esyntax
 
 	
 Changements divers
 ------------------
 
  . il n'y a plus de script coqtop => coqtop et coqtop.byte sont
-   directement le résultat du link du code
+   directement le résultat du link du code
    => debuggage et profiling directs
 
  . il n'y a plus d'installation locale dans bin/$ARCH
diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt
new file mode 100644
index 00000000..fe896d31
--- /dev/null
+++ b/dev/doc/coq-src-description.txt
@@ -0,0 +1,122 @@
+
+Coq main source components (in link order)
+------------------------------------------
+
+clib : Basic files in lib/, such as util.ml
+lib : Other files in lib/
+kernel
+library
+pretyping
+interp
+proofs
+printing
+parsing
+tactics
+toplevel
+
+highparsing :
+
+ Files in parsing/ that cannot be linked too early.
+ Contains the grammar rules g_*.ml4
+
+hightactics :
+
+ Files in tactics/ that cannot be linked too early.
+ These are the .ml4 files that uses the EXTEND possibilities
+ provided by grammar.cma, for instance eauto.ml4.
+
+
+Special components
+------------------
+
+intf :
+
+ Contains mli-only interfaces, many of them providing a.s.t.
+ used for dialog bewteen coq components. Ex: Constrexpr.constr_expr
+ produced by parsing and transformed by interp.
+
+grammar :
+
+ Camlp4 syntax extensions. The file grammar/grammar.cma is used
+ to pre-process .ml4 files containing EXTEND constructions,
+ either TACTIC EXTEND, ARGUMENTS EXTEND or VERNAC ... EXTEND.
+ This grammar.cma incorporates many files from other directories
+ (mainly parsing/), plus some specific files in grammar/.
+ The other syntax extension grammar/q_constr.cmo is a addition to
+ grammar.cma with a constr PATTERN quotation.
+
+
+Hierarchy of A.S.T.
+-------------------
+
+*** Terms ***
+
+             ...          ...
+              |            /\
+    parsing   |            | printing
+              |            |
+              V            |
+           Constrexpr.constr_expr
+              |            /\
+ constrintern |            | constrextern
+  (in interp) |            | (in interp)
+globalization |            |
+              V            |
+           Glob_term.glob_constr
+              |            /\
+    pretyping |            | detyping
+              |            | (in pretyping)
+              V            |
+               Term.constr
+                 |     /\
+   safe_typing   |      |
+   (validation   |      |
+    by kernel)   |______|
+
+
+*** Patterns ***
+
+  |
+  | parsing
+  V
+constr_pattern_expr = constr_expr
+  |
+  | Constrintern.interp_constr_pattern (in interp)
+  | reverse way in Constrextern
+  V
+Pattern.constr_pattern
+  |
+  ---> used for instance by Matching.matches (in pretyping)
+
+
+*** Notations ***
+
+
+Notation_term.notation_constr
+
+Conversion from/to glob_constr in Notation_ops
+
+TODO...
+
+
+*** Tactics ***
+
+ |
+ | parsing
+ V
+Tacexpr.raw_tactic_expr
+ |
+ | Tacinterp.intern_pure_tactic (?)
+ V
+Tacexpr.glob_tactic_expr
+ |
+ | Tacinterp.eval_tactic (?)
+ V
+Proof_type.tactic
+
+TODO: check with Hugo
+
+
+*** Vernac expressions ***
+
+Vernacexpr.vernac_expr, produced by parsing, used in Vernacentries and Vernac
diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.txt
index 2480b8ed..f0df2fc3 100644
--- a/dev/doc/debugging.txt
+++ b/dev/doc/debugging.txt
@@ -21,14 +21,6 @@ Debugging from Coq toplevel using Caml trace mechanism
   notations, ...), use "Set Printing All". It will affect the #trace
   printers too.
 
-Note for Ocaml 3.10.x: Ocaml 3.10.x requires that modules compiled
-with -rectypes are loaded in an environment with -rectypes set but
-there is no way to tell the toplevel to support -rectypes. To make it
-works, use "patch -p0 < dev/doc/patch.ocaml-3.10.drop.rectypes" to
-hack script/coqmktop.ml, then recompile coqtop.byte. The procedure
-above then works as soon as coqtop.byte is called with at least one
-argument (add neutral option -byte to ensure at least one argument).
-
 
 Debugging from Caml debugger
 ============================
diff --git a/dev/doc/extensions.txt b/dev/doc/extensions.txt
index eb4d2659..075496db 100644
--- a/dev/doc/extensions.txt
+++ b/dev/doc/extensions.txt
@@ -1,19 +1,19 @@
-Comment ajouter une nouvelle entrée primitive pour les TACTIC EXTEND ?
+Comment ajouter une nouvelle entrée primitive pour les TACTIC EXTEND ?
 ======================================================================
 
-Exemple de l'ajout de l'entrée "clause":
+Exemple de l'ajout de l'entrée "clause":
 
 - ajouter un type ClauseArgType dans interp/genarg.ml{,i}, avec les
   wit_, rawwit_, et globwit_ correspondants
 
-- ajouter partout où Genarg.argument_type est filtré le cas traitant de
+- ajouter partout où Genarg.argument_type est filtré le cas traitant de
   ce nouveau ClauseArgType
 
-- utiliser le rawwit_clause pour définir une entrée clause du bon
+- utiliser le rawwit_clause pour définir une entrée clause du bon
   type et du bon nom dans le module Tactic de pcoq.ml4
 
-- il faut aussi exporter la règle hors de g_tactic.ml4. Pour cela, il
+- il faut aussi exporter la règle hors de g_tactic.ml4. Pour cela, il
   faut rejouter clause dans le GLOBAL du GEXTEND
 
-- seulement après, le nom clause sera accessible dans les TACTIC EXTEND !
+- seulement après, le nom clause sera accessible dans les TACTIC EXTEND !
 
diff --git a/dev/doc/naming-conventions.tex b/dev/doc/naming-conventions.tex
index e7c8975b..34916494 100644
--- a/dev/doc/naming-conventions.tex
+++ b/dev/doc/naming-conventions.tex
@@ -1,6 +1,6 @@
 \documentclass[a4paper]{article}
 \usepackage{fullpage}
-\usepackage[latin1]{inputenc}
+\usepackage[utf8]{inputenc}
 \usepackage[T1]{fontenc}
 \usepackage{amsfonts}
 
@@ -299,7 +299,7 @@ element {\zero} and multiplicative binary operator
     (for \texttt{Z}, \texttt{Q} and \texttt{R}), \texttt{eq\_mul\_0} (for
     \texttt{NZ}).
 
-  Remark: The French school says ``integrité''.
+  Remark: The French school says ``integrité''.
 
 \itemrule{Nilpotency of binary operator {\op} wrt to its absorbing element
 zero in D}{Dop\_nilpotent} {forall x, op x x = zero}
diff --git a/dev/doc/newsyntax.tex b/dev/doc/newsyntax.tex
index 96e61292..d1986fa0 100644
--- a/dev/doc/newsyntax.tex
+++ b/dev/doc/newsyntax.tex
@@ -5,7 +5,7 @@
 
 \usepackage{verbatim}
 \usepackage[T1]{fontenc}
-\usepackage[latin1]{inputenc}
+\usepackage[utf8]{inputenc}
 \usepackage[french]{babel}
 \usepackage{amsmath}
 \usepackage{amssymb}
@@ -15,7 +15,7 @@
 \author{B.~Barras}
 \title{Proposition de syntaxe pour Coq}
 
-%% Le _ est un caractère normal
+%% Le _ est un caractère normal
 \catcode`\_=13
 \let\subscr=_
 \def_{\ifmmode\sb\else\subscr\fi}
@@ -47,21 +47,21 @@
 \section{Grammaire des tactiques}
 \label{tacticsyntax}
 
-La réflexion de la rénovation de la syntaxe des tactiques n'est pas
-encore aussi poussée que pour les termes (section~\ref{constrsyntax}),
-mais cette section vise à énoncer les quelques principes que l'on
+La réflexion de la rénovation de la syntaxe des tactiques n'est pas
+encore aussi poussée que pour les termes (section~\ref{constrsyntax}),
+mais cette section vise à énoncer les quelques principes que l'on
 souhaite suivre. 
 
 \begin{itemize}
-\item Réutiliser les mots-clés de la syntaxe des termes (i.e. en
+\item Réutiliser les mots-clés de la syntaxe des termes (i.e. en
   minuscules) pour les constructions similaires de tactiques (let_in,
-  match, and, etc.). Le connecteur logique \texttt{and} n'étant que
-  rarement utilisé autrement que sous la forme \texttt{$\wedge$} (sauf
-  dans le code ML), on pourrait dégager ce mot-clé.
-\item Les arguments passés aux tactiques sont principalement des
-  termes, on préconise l'utilisation d'un symbole spécial (par exemple
+  match, and, etc.). Le connecteur logique \texttt{and} n'étant que
+  rarement utilisé autrement que sous la forme \texttt{$\wedge$} (sauf
+  dans le code ML), on pourrait dégager ce mot-clé.
+\item Les arguments passés aux tactiques sont principalement des
+  termes, on préconise l'utilisation d'un symbole spécial (par exemple
   l'apostrophe) pour passer une tactique ou une expression
-  (AST). L'idée étant que l'on écrit plus souvent des tactiques
+  (AST). L'idée étant que l'on écrit plus souvent des tactiques
   prenant des termes en argument que des tacticals.
 \end{itemize}
 
@@ -97,15 +97,15 @@ souhaite suivre.
 \subsection{Arguments de tactiques}
 
 La syntaxe actuelle des arguments de tactiques est que l'on parse par
-défaut une expression de tactique, ou bien l'on parse un terme si
-celui-ci est préfixé par \TERM{'} (sauf dans le cas des
-variables). Cela est gênant pour les utilisateurs qui doivent écrire
+défaut une expression de tactique, ou bien l'on parse un terme si
+celui-ci est préfixé par \TERM{'} (sauf dans le cas des
+variables). Cela est gênant pour les utilisateurs qui doivent écrire
 des \TERM{'} pour leurs tactiques.
 
-À mon avis, il n'est pas souhaitable pour l'utilisateur de l'obliger à
-marquer une différence entre les tactiques ``primitives'' (en fait
-``système'') et les tactiques définies par Ltac. En effet, on se
-dirige inévitablement vers une situation où il existera des librairies
+À mon avis, il n'est pas souhaitable pour l'utilisateur de l'obliger à
+marquer une différence entre les tactiques ``primitives'' (en fait
+``système'') et les tactiques définies par Ltac. En effet, on se
+dirige inévitablement vers une situation où il existera des librairies
 de tactiques et il va devenir difficile de savoir facilement s'il faut
 ou non mettre des \TERM{'}.
 
@@ -113,33 +113,33 @@ ou non mettre des \TERM{'}.
 
 \subsection{Bindings}
 
-Dans un premier temps, les ``bindings'' sont toujours considérés comme
-une construction du langage des tactiques, mais il est intéressant de
-prévoir l'extension de ce procédé aux termes, puisqu'il s'agit
+Dans un premier temps, les ``bindings'' sont toujours considérés comme
+une construction du langage des tactiques, mais il est intéressant de
+prévoir l'extension de ce procédé aux termes, puisqu'il s'agit
 simplement de construire un n{\oe}ud d'application dans lequel on
-donne les arguments par nom ou par position, les autres restant à
-inférer. Le principal point est de trouver comment combiner de manière
-uniforme ce procédé avec les arguments implicites.
+donne les arguments par nom ou par position, les autres restant à
+inférer. Le principal point est de trouver comment combiner de manière
+uniforme ce procédé avec les arguments implicites.
 
-Il est toutefois important de réfléchir dès maintenant à une syntaxe
-pour éviter de rechanger encore la syntaxe.
+Il est toutefois important de réfléchir dès maintenant à une syntaxe
+pour éviter de rechanger encore la syntaxe.
 
-Intégrer la notation \TERM{with} aux termes peut poser des problèmes
-puisque ce mot-clé est utilisé pour le filtrage: comment parser (en
+Intégrer la notation \TERM{with} aux termes peut poser des problèmes
+puisque ce mot-clé est utilisé pour le filtrage: comment parser (en
 LL(1)) l'expression:
 \begin{verbatim}
 Cases x with y ...
 \end{verbatim}
 
-Soit on trouve un autre mot-clé, soit on joue avec les niveaus de
-priorité en obligeant a parenthéser le \TERM{with} des ``bindings'':
+Soit on trouve un autre mot-clé, soit on joue avec les niveaus de
+priorité en obligeant a parenthéser le \TERM{with} des ``bindings'':
 \begin{verbatim}
 Cases (x with y) with (C z) => ...
 \end{verbatim}
-ce qui introduit un constructeur moralement équivalent à une
-application situé à une priorité totalement différente (les
+ce qui introduit un constructeur moralement équivalent à une
+application situé à une priorité totalement différente (les
 ``bindings'' seraient au plus haut niveau alors que l'application est
-à un niveau bas).
+à un niveau bas).
 
 
 \begin{figure}
@@ -156,9 +156,9 @@ application situé à une priorité totalement différente (les
 
 \subsection{Enregistrements}
 
-Il faudrait aménager la syntaxe des enregistrements dans l'optique
-d'avoir des enregistrements anonymes (termes de première classe), même
-si pour l'instant, on ne dispose que d'enregistrements définis a
+Il faudrait aménager la syntaxe des enregistrements dans l'optique
+d'avoir des enregistrements anonymes (termes de première classe), même
+si pour l'instant, on ne dispose que d'enregistrements définis a
 toplevel.
 
 Exemple de syntaxe pour les types d'enregistrements:
@@ -179,22 +179,22 @@ Exemple de syntaxe pour le constructeur:
   ...
 }
 \end{verbatim}
-Quant aux dépendences, une convention pourrait être de considérer les
-champs non annotés par le type comme non dépendants.
+Quant aux dépendences, une convention pourrait être de considérer les
+champs non annotés par le type comme non dépendants.
 
 Plusieurs interrogations:
 \begin{itemize}
-\item l'ordre des champs doit-il être respecté ?
+\item l'ordre des champs doit-il être respecté ?
   sinon, que faire pour les champs sans projection ?
 \item autorise-t-on \texttt{v1} a mentionner \texttt{x1} (comme dans
-  la définition d'un module), ce qui se comporterait comme si on avait
-  écrit \texttt{v1} à la place. Cela pourrait être une autre manière
-  de déclarer les dépendences
+  la définition d'un module), ce qui se comporterait comme si on avait
+  écrit \texttt{v1} à la place. Cela pourrait être une autre manière
+  de déclarer les dépendences
 \end{itemize}
 
-La notation pointée pour les projections pose un problème de parsing,
+La notation pointée pour les projections pose un problème de parsing,
 sauf si l'on a une convention lexicale qui discrimine les noms de
-modules des projections et identificateurs: \texttt{x.y.z} peut être
+modules des projections et identificateurs: \texttt{x.y.z} peut être
 compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}.
 
 
@@ -204,17 +204,17 @@ compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}.
 \subsection{Quelques principes}
 
 \begin{enumerate}
-\item Diminuer le nombre de niveaux de priorité en regroupant les
-  règles qui se ressemblent: infixes, préfixes, lieurs (constructions
-  ouvertes à droite), etc.
-\item Éviter de surcharger la signification d'un symbole (ex:
-  \verb+( )+ comme parenthésage et produit dans la V7).
+\item Diminuer le nombre de niveaux de priorité en regroupant les
+  règles qui se ressemblent: infixes, préfixes, lieurs (constructions
+  ouvertes à droite), etc.
+\item Éviter de surcharger la signification d'un symbole (ex:
+  \verb+( )+ comme parenthésage et produit dans la V7).
 \item Faire en sorte que les membres gauches (motifs de Cases, lieurs
   d'abstraction ou de produits) utilisent une syntaxe compatible avec
   celle des membres droits (branches de Cases et corps de fonction).
 \end{enumerate}
 
-\subsection{Présentation de la grammaire}
+\subsection{Présentation de la grammaire}
 
 \begin{figure}
 \begin{rulebox}
@@ -286,15 +286,15 @@ compris comme \texttt{(x.y).z} ou texttt{x.(y.z)}.
 \label{gram-annexes}
 \end{figure}
 
-La grammaire des termes (correspondant à l'état \texttt{barestate})
-est décrite figures~\ref{constr} et~\ref{gram-annexes}. On constate
-par rapport aux précédentes versions de Coq d'importants changements
-de priorité, le plus marquant étant celui de l'application qui se
-trouve désormais juste au dessus\footnote{La convention est de
-considérer les opérateurs moins lieurs comme ``au dessus'',
-c'est-à-dire ayant un niveau de priorité plus élévé (comme c'est le
+La grammaire des termes (correspondant à l'état \texttt{barestate})
+est décrite figures~\ref{constr} et~\ref{gram-annexes}. On constate
+par rapport aux précédentes versions de Coq d'importants changements
+de priorité, le plus marquant étant celui de l'application qui se
+trouve désormais juste au dessus\footnote{La convention est de
+considérer les opérateurs moins lieurs comme ``au dessus'',
+c'est-à-dire ayant un niveau de priorité plus élévé (comme c'est le
 cas avec le niveau de la grammaire actuelle des termes).} des
-constructions fermées à gauche et à droite.
+constructions fermées à gauche et à droite.
 
 La grammaire des noms globaux est la suivante:
 \begin{eqnarray*}
@@ -304,43 +304,43 @@ La grammaire des noms globaux est la suivante:
 \nlsep \NT{ident}\TERM{.}\NT{global}
 \end{eqnarray*}
 
-Le $\TERM{_}$ dénote les termes à synthétiser. Les métavariables sont
+Le $\TERM{_}$ dénote les termes à synthétiser. Les métavariables sont
 reconnues au niveau du lexer pour ne pas entrer en conflit avec le
 $\TERM{?}$ de l'existentielle.
 
-Les opérateurs infixes ou préfixes sont tous au même niveau de
-priorité du point de vue de Camlp4. La solution envisagée est de les
-gérer à la manière de Yacc, avec une pile (voir discussions plus
+Les opérateurs infixes ou préfixes sont tous au même niveau de
+priorité du point de vue de Camlp4. La solution envisagée est de les
+gérer à la manière de Yacc, avec une pile (voir discussions plus
 bas). Ainsi, l'implication est un infixe normal; la quantification
-universelle et le let sont vus comme des opérateurs préfixes avec un
-niveau de priorité plus haut (i.e. moins lieur). Il subsiste des
-problèmes si l'on ne veut pas écrire de parenthèses dans:
+universelle et le let sont vus comme des opérateurs préfixes avec un
+niveau de priorité plus haut (i.e. moins lieur). Il subsiste des
+problèmes si l'on ne veut pas écrire de parenthèses dans:
 \begin{verbatim}
  A -> (!x. B -> (let y = C in D))
 \end{verbatim}
 
-La solution proposée est d'analyser le membre droit d'un infixe de
-manière à autoriser les préfixes et les infixes de niveau inférieur,
-et d'exiger le parenthésage que pour les infixes de niveau supérieurs.
+La solution proposée est d'analyser le membre droit d'un infixe de
+manière à autoriser les préfixes et les infixes de niveau inférieur,
+et d'exiger le parenthésage que pour les infixes de niveau supérieurs.
 
-En revanche, à l'affichage, certains membres droits seront plus
+En revanche, à l'affichage, certains membres droits seront plus
 lisibles s'ils n'utilisent pas cette astuce:
 \begin{verbatim}
 (fun x => x) = fun x => x
 \end{verbatim}
 
-La proposition est d'autoriser ce type d'écritures au parsing, mais
-l'afficheur écrit de manière standardisée en mettant quelques
-parenthèses superflues: $\TERM{=}$ serait symétrique alors que
-$\rightarrow$ appellerait l'afficheur de priorité élevée pour son
+La proposition est d'autoriser ce type d'écritures au parsing, mais
+l'afficheur écrit de manière standardisée en mettant quelques
+parenthèses superflues: $\TERM{=}$ serait symétrique alors que
+$\rightarrow$ appellerait l'afficheur de priorité élevée pour son
 sous-terme droit.
 
-Les priorités des opérateurs primitifs sont les suivantes (le signe
-$*$ signifie que pour le membre droit les opérateurs préfixes seront
-affichés sans parenthèses quel que soit leur priorité):
+Les priorités des opérateurs primitifs sont les suivantes (le signe
+$*$ signifie que pour le membre droit les opérateurs préfixes seront
+affichés sans parenthèses quel que soit leur priorité):
 $$
 \begin{array}{c|l}
-$symbole$ & $priorité$ \\
+$symbole$ & $priorité$ \\
 \hline
 \TERM{!}      & 200\,R* \\
 \TERM{fun}    & 200\,R* \\
@@ -351,39 +351,39 @@ $symbole$ & $priorité$ \\
 \end{array}
 $$
 
-Il y a deux points d'entrée pour les termes: $\NT{constr}$ et
-$\NT{simple-constr}$. Le premier peut être utilisé lorsqu'il est suivi
-d'un séparateur particulier. Dans le cas où l'on veut une liste de
-termes séparés par un espace, il faut lire des $\NT{simple-constr}$.
+Il y a deux points d'entrée pour les termes: $\NT{constr}$ et
+$\NT{simple-constr}$. Le premier peut être utilisé lorsqu'il est suivi
+d'un séparateur particulier. Dans le cas où l'on veut une liste de
+termes séparés par un espace, il faut lire des $\NT{simple-constr}$.
 
 
 
 Les constructions $\TERM{fix}$ et $\TERM{cofix}$ (voir aussi
-figure~\ref{gram-fix}) sont fermées par end pour simplifier
-l'analyse. Sinon, une expression de point fixe peut être suivie par un
-\TERM{in} ou un \TERM{and}, ce qui pose les mêmes problèmes que le
+figure~\ref{gram-fix}) sont fermées par end pour simplifier
+l'analyse. Sinon, une expression de point fixe peut être suivie par un
+\TERM{in} ou un \TERM{and}, ce qui pose les mêmes problèmes que le
 ``dangling else'': dans
 \begin{verbatim}
 fix f1 x {x} = fix f2 y {y} = ... and ... in ...
 \end{verbatim}
-il faut définir une stratégie pour associer le \TERM{and} et le
+il faut définir une stratégie pour associer le \TERM{and} et le
 \TERM{in} au bon point fixe.
 
 Un autre avantage est de faire apparaitre que le \TERM{fix} est un
-constructeur de terme de première classe et pas un lieur:
+constructeur de terme de première classe et pas un lieur:
 \begin{verbatim}
 fix f1 ... and f2 ...
 in f1 end x
 \end{verbatim}
-Les propositions précédentes laissaient \texttt{f1} et \texttt{x}
-accolés, ce qui est source de confusion lorsque l'on fait par exemple
+Les propositions précédentes laissaient \texttt{f1} et \texttt{x}
+accolés, ce qui est source de confusion lorsque l'on fait par exemple
 \texttt{Pattern (f1 x)}.
 
 Les corps de points fixes et co-points fixes sont identiques, bien que
-ces derniers n'aient pas d'information de décroissance. Cela
-fonctionne puisque l'annotation est optionnelle. Cela préfigure des
-cas où l'on arrive à inférer quel est l'argument qui décroit
-structurellement (en particulier dans le cas où il n'y a qu'un seul
+ces derniers n'aient pas d'information de décroissance. Cela
+fonctionne puisque l'annotation est optionnelle. Cela préfigure des
+cas où l'on arrive à inférer quel est l'argument qui décroit
+structurellement (en particulier dans le cas où il n'y a qu'un seul
 argument).
 
 \begin{figure}
@@ -412,8 +412,8 @@ argument).
 \label{gram-fix}
 \end{figure}
 
-La construction $\TERM{Case}$ peut-être considérée comme
-obsolète. Quant au $\TERM{Match}$ de la V6, il disparaît purement et
+La construction $\TERM{Case}$ peut-être considérée comme
+obsolète. Quant au $\TERM{Match}$ de la V6, il disparaît purement et
 simplement.
 
 \begin{figure}
@@ -456,15 +456,15 @@ simplement.
 \label{gram-match}
 \end{figure}
 
-De manière globale, l'introduction de définitions dans les termes se
-fait avec le symbole $=$, et le $\!:=$ est réservé aux définitions au
-niveau vernac. Il y avait un manque de cohérence dans la
+De manière globale, l'introduction de définitions dans les termes se
+fait avec le symbole $=$, et le $\!:=$ est réservé aux définitions au
+niveau vernac. Il y avait un manque de cohérence dans la
 V6, puisque l'on utilisait $=$ pour le $\TERM{let}$ et $\!:=$ pour les
 points fixes et les commandes vernac.
 
 % OBSOLETE: lieurs multiples supprimes
 %On peut remarquer que $\NT{binder}$ est un sous-ensemble de
-%$\NT{simple-constr}$, à l'exception de $\texttt{(a,b\!\!:T)}$: en tant
+%$\NT{simple-constr}$, à l'exception de $\texttt{(a,b\!\!:T)}$: en tant
 %que lieur, {\tt a} et {\tt b} sont tous deux contraints, alors qu'en
 %tant que terme, seul {\tt b} l'est. Cela qui signifie que l'objectif
 %de rendre compatibles les membres gauches et droits est {\it presque}
@@ -474,14 +474,14 @@ points fixes et les commandes vernac.
 
 \subsubsection{Infixes extensibles}
 
-Le problème de savoir si la liste des symboles pouvant apparaître en
-infixe est fixée ou extensible par l'utilisateur reste à voir.
+Le problème de savoir si la liste des symboles pouvant apparaître en
+infixe est fixée ou extensible par l'utilisateur reste à voir.
 
-Notons que la solution où les symboles infixes sont des
-identificateurs que l'on peut définir paraît difficilement praticable:
-par exemple $\texttt{Logic.eq}$ n'est pas un opérateur binaire, mais
-ternaire. Il semble plus simple de garder des déclarations infixes qui
-relient un symbole infixe à un terme avec deux ``trous''. Par exemple:
+Notons que la solution où les symboles infixes sont des
+identificateurs que l'on peut définir paraît difficilement praticable:
+par exemple $\texttt{Logic.eq}$ n'est pas un opérateur binaire, mais
+ternaire. Il semble plus simple de garder des déclarations infixes qui
+relient un symbole infixe à un terme avec deux ``trous''. Par exemple:
 
 $$\begin{array}{c|l}
 $infixe$ &  $identificateur$ \\
@@ -490,33 +490,33 @@ $infixe$ &  $identificateur$ \\
 == & \texttt{JohnMajor.eq _ ?1 _ ?2}
 \end{array}$$
 
-La syntaxe d'une déclaration d'infixe serait par exemple:
+La syntaxe d'une déclaration d'infixe serait par exemple:
 \begin{verbatim}
 Infix "=" 50 := Logic.eq _ ?1 ?2;
 \end{verbatim}
 
 
-\subsubsection{Gestion des précédences}
+\subsubsection{Gestion des précédences}
 
-Les infixes peuvent être soit laissé à Camlp4, ou bien (comme ici)
-considérer que tous les opérateurs ont la même précédence et gérer
-soit même la recomposition des termes à l'aide d'une pile (comme
+Les infixes peuvent être soit laissé à Camlp4, ou bien (comme ici)
+considérer que tous les opérateurs ont la même précédence et gérer
+soit même la recomposition des termes à l'aide d'une pile (comme
 Yacc).
 
 
 \subsection{Extensions de syntaxe}
 
-\subsubsection{Litéraux numériques}
+\subsubsection{Litéraux numériques}
 
-La proposition est de considerer les litéraux numériques comme de
-simples identificateurs. Comme il en existe une infinité, il faut un
-nouveau mécanisme pour leur associer une définition. Par exemple, en
-ce qui concerne \texttt{Arith}, la définition de $5$ serait
+La proposition est de considerer les litéraux numériques comme de
+simples identificateurs. Comme il en existe une infinité, il faut un
+nouveau mécanisme pour leur associer une définition. Par exemple, en
+ce qui concerne \texttt{Arith}, la définition de $5$ serait
 $\texttt{S}~4$. Pour \texttt{ZArith}, $5$ serait $\texttt{xI}~2$.
 
-Comme les infixes, les constantes numériques peuvent être qualifiées
+Comme les infixes, les constantes numériques peuvent être qualifiées
 pour indiquer dans quels module est le type que l'on veut
-référencer. Par exemple (si on renomme \texttt{Arith} en \texttt{N} et
+référencer. Par exemple (si on renomme \texttt{Arith} en \texttt{N} et
 \texttt{ZArith} en \texttt{Z}): \verb+N.5+, \verb+Z.5+.
 
 \begin{eqnarray*}
@@ -539,18 +539,18 @@ $$
 $$
 
 Pour l'instant l'existentielle n'admet qu'une seule variable, ce qui
-oblige à écrire des cascades de $\TERM{ex}$.
+oblige à écrire des cascades de $\TERM{ex}$.
 
-Pour parser les existentielles avec deux prédicats, on peut considérer
-\TERM{\&} comme un infixe intermédiaire et l'opérateur existentiel en
-présence de cet infixe se transforme en \texttt{ex2}.
+Pour parser les existentielles avec deux prédicats, on peut considérer
+\TERM{\&} comme un infixe intermédiaire et l'opérateur existentiel en
+présence de cet infixe se transforme en \texttt{ex2}.
 
 \subsubsection{Nouveaux infixes}
 
-Précédences des opérateurs infixes (les plus grands associent moins fort):
+Précédences des opérateurs infixes (les plus grands associent moins fort):
 $$
 \begin{array}{l|l|c|l}
-$identificateur$      & $module$     & $infixe/préfixe$ & $précédence$ \\
+$identificateur$      & $module$     & $infixe/préfixe$ & $précédence$ \\
 \hline
 \texttt{iff}          & $Logic$      & \longleftrightarrow & 100 \\
 \texttt{or}           & $Logic$      & \vee     & 80\, R \\
@@ -590,8 +590,8 @@ $identificateur$      & $module$     & $infixe/préfixe$ & $précédence$ \\
 \end{array}
 $$
 
-Notons qu'il faudrait découper {\tt Logic_Type} en deux car celui-ci
-définit deux égalités, ou alors les mettre dans des modules différents.
+Notons qu'il faudrait découper {\tt Logic_Type} en deux car celui-ci
+définit deux égalités, ou alors les mettre dans des modules différents.
 
 \subsection{Exemples}
 
@@ -611,20 +611,20 @@ Fixpoint plus n m : nat {struct n} :=
 
 \subsection{Questions ouvertes}
 
-Voici les points sur lesquels la discussion est particulièrement
+Voici les points sur lesquels la discussion est particulièrement
 ouverte: 
 \begin{itemize}
 \item choix d'autres symboles pour les quantificateurs \TERM{!} et
-  \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!}
+  \TERM{?}. En l'état actuel des discussions, on garderait le \TERM{!}
   pour la qunatification universelle, mais on choisirait quelquechose
-  comme \TERM{ex} pour l'existentielle, afin de ne pas suggérer trop
-  de symétrie entre ces quantificateurs (l'un est primitif, l'autre
+  comme \TERM{ex} pour l'existentielle, afin de ne pas suggérer trop
+  de symétrie entre ces quantificateurs (l'un est primitif, l'autre
   pas).
-\item syntaxe particulière pour les \texttt{sig}, \texttt{sumor}, etc.
-\item la possibilité d'introduire plusieurs variables du même type est
-  pour l'instant supprimée au vu des problèmes de compatibilité de
-  syntaxe entre les membres gauches et membres droits. L'idée étant
-  que l'inference de type permet d'éviter le besoin de déclarer tous
+\item syntaxe particulière pour les \texttt{sig}, \texttt{sumor}, etc.
+\item la possibilité d'introduire plusieurs variables du même type est
+  pour l'instant supprimée au vu des problèmes de compatibilité de
+  syntaxe entre les membres gauches et membres droits. L'idée étant
+  que l'inference de type permet d'éviter le besoin de déclarer tous
   les types.
 \end{itemize}
 
@@ -632,19 +632,19 @@ ouverte:
 
 \subsubsection{Lieur multiple}
 
-L'écriture de types en présence de polymorphisme est souvent assez
-pénible:
+L'écriture de types en présence de polymorphisme est souvent assez
+pénible:
 \begin{verbatim}
 Check !(A:Set) (x:A) (B:Set) (y:B). P A x B y;
 \end{verbatim}
 
-On pourrait avoir des déclarations introduisant à la fois un type
+On pourrait avoir des déclarations introduisant à la fois un type
 d'une certaine sorte et une variable de ce type:
 \begin{verbatim}
 Check !(x:A:Set) (y:B:Set). P A x B y;
 \end{verbatim}
 
-Noter que l'on aurait pu écrire:
+Noter que l'on aurait pu écrire:
 \begin{verbatim}
 Check !A x B y. P A (x:A:Set) B (y:B:Set);
 \end{verbatim}
@@ -654,19 +654,19 @@ Check !A x B y. P A (x:A:Set) B (y:B:Set);
 \subsection{Questions diverses}
 
 Changer ``Pattern nl c ... nl c'' en ``Pattern [ nl ] c ... [ nl ] c''
-pour permettre des chiffres seuls dans la catégorie syntaxique des
+pour permettre des chiffres seuls dans la catégorie syntaxique des
 termes.
 
-Par uniformité remplacer ``Unfold nl c'' par ``Unfold [ nl ] c'' ?
+Par uniformité remplacer ``Unfold nl c'' par ``Unfold [ nl ] c'' ?
 
-Même problème pour l'entier de Specialize (ou virer Specialize ?) ?
+Même problème pour l'entier de Specialize (ou virer Specialize ?) ?
 
 \subsection{Questions en suspens}
 
-\verb=EAuto= : deux syntaxes différentes pour la recherche en largeur
-et en profondeur ? Quelle recherche par défaut ?
+\verb=EAuto= : deux syntaxes différentes pour la recherche en largeur
+et en profondeur ? Quelle recherche par défaut ?
 
-\section*{Remarques pêle-mêle (HH)}
+\section*{Remarques pêle-mêle (HH)}
 
 Autoriser la syntaxe
 
@@ -685,16 +685,16 @@ Mettre des \verb=?x= plutot que des \verb=?1= dans les motifs de ltac ??
 
 \begin{itemize}
 
-\item Mettre \verb=/= et * au même niveau dans R.
+\item Mettre \verb=/= et * au même niveau dans R.
 
-\item Changer la précédence du - unaire dans R.
+\item Changer la précédence du - unaire dans R.
 
 \item Ajouter Require Arith par necessite si Require ArithRing ou Require ZArithRing.
 
 \item Ajouter Require ZArith par necessite si Require ZArithRing ou Require Omega.
 
-\item Enlever le Export de Bool, Arith et ZARith de Ring quand inapproprié et
-l'ajouter à côté des Require Ring.
+\item Enlever le Export de Bool, Arith et ZARith de Ring quand inapproprié et
+l'ajouter à côté des Require Ring.
 
 \item Remplacer "Check n" par "n:Check ..."
 
diff --git a/dev/doc/old_svn_branches.txt b/dev/doc/old_svn_branches.txt
new file mode 100644
index 00000000..ee56ee24
--- /dev/null
+++ b/dev/doc/old_svn_branches.txt
@@ -0,0 +1,33 @@
+## During the migration to git, some old branches and tags have not been
+## converted to directly visible git branches or tags. They are still there
+## in the archive, their names on the gforge repository are in the 3rd
+## column below (e.g. remotes/V8-0-bugfix). After a git clone, they
+## could always be accessed by their git hashref (2nd column below).
+
+# SVN   # GIT   # Symbolic name on gforge repository
+
+r5      d2f789d remotes/tags/start
+r1714   0605b7c remotes/V7
+r2583   372f3f0 remotes/tags/modules-2-branching
+r2603   6e15d9a remotes/modules
+r2866   76a93fa remotes/tags/modules-2-before-grammar
+r2951   356f749 remotes/tags/before-modules
+r2952   8ee67df remotes/tags/modules-2-update
+r2956   fb11bd9 remotes/modules-2
+r3193   4d23172 remotes/mowgli
+r3194   c91e99b remotes/tags/mowgli-before-merge
+r3500   5078d29 remotes/mowgli2
+r3672   63b0886 remotes/V7-3-bugfix
+r5086   bdceb72 remotes/V7-4-bugfix
+r5731   a274456 remotes/recriture
+r9046   e19553c remotes/tags/trunk
+r9146   b38ce05 remotes/coq-diff-tool
+r9786   a05abf8 remotes/ProofIrrelevance
+r10294  fdf8871 remotes/InternalExtraction
+r10408  df97909 remotes/TypeClasses
+r10673  4e19bca remotes/bertot
+r11130  bfd1cb3 remotes/proofs
+r12282  a726b30 remotes/revised-theories
+r13855  bae3a8e remotes/native
+r14062  b77191b remotes/recdef
+r16421  9f4bfa8 remotes/V8-0-bugfix
diff --git a/dev/doc/patch.ocaml-3.10.drop.rectypes b/dev/doc/patch.ocaml-3.10.drop.rectypes
deleted file mode 100644
index ba7a3e95..00000000
--- a/dev/doc/patch.ocaml-3.10.drop.rectypes
+++ /dev/null
@@ -1,31 +0,0 @@
-Index: scripts/coqmktop.ml
-===================================================================
---- scripts/coqmktop.ml	(révision 12084)
-+++ scripts/coqmktop.ml	(copie de travail)
-@@ -231,12 +231,25 @@
-      end;;
- 
-      let ppf = Format.std_formatter;;
-+     let set_rectypes_hack () =
-+       if String.length (Sys.ocaml_version) >= 4 &
-+          String.sub (Sys.ocaml_version) 0 4 = \"3.10\"
-+       then
-+         (* ocaml 3.10 does not have #rectypes but needs it *)
-+         (* simulate a call with option -rectypes before *)
-+         (* jumping to the ocaml toplevel *)
-+         for i = 1 to Array.length Sys.argv - 1 do
-+           Sys.argv.(i) <- \"-rectypes\"
-+         done
-+       else
-+         () in
-+
-      Mltop.set_top
-        {Mltop.load_obj=
-          (fun f -> if not (Topdirs.load_file ppf f) then failwith \"error\");
-         Mltop.use_file=Topdirs.dir_use ppf;
-         Mltop.add_dir=Topdirs.dir_directory;
--        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\n"
-+        Mltop.ml_loop=(fun () -> set_rectypes_hack(); Topmain.main()) };;\n"
- 
- (* create a temporary main file to link *)
- let create_tmp_main_file modules =
diff --git a/dev/doc/style.txt b/dev/doc/style.txt
index a8924ba6..27695a09 100644
--- a/dev/doc/style.txt
+++ b/dev/doc/style.txt
@@ -1,16 +1,16 @@
 
-<< L'uniformité du style est plus importante que le style lui-même. >>
+<< L'uniformité du style est plus importante que le style lui-même. >>
 (Kernigan & Pike, The Practice of Programming)
 
 Mode Emacs
 ==========
    Tuareg, que l'on trouve ici :  http://www.prism.uvsq.fr/~acohen/tuareg/
 
-   avec le réglage suivant :     (setq tuareg-in-indent 2)
+   avec le réglage suivant :     (setq tuareg-in-indent 2)
 
-Types récursifs et filtrages
+Types récursifs et filtrages
 ============================
-   Une barre de séparation y compris sur le premier constructeur
+   Une barre de séparation y compris sur le premier constructeur
 
 type t =
   | A 
@@ -20,9 +20,9 @@ match expr with
   | A -> ...
   | B x -> ...
 
-Remarque : à partir de la 8.2 environ, la tendance est à utiliser le
+Remarque : à partir de la 8.2 environ, la tendance est à utiliser le
 format suivant qui permet de limiter l'escalade d'indentation tout en
-produisant un aspect visuel intéressant de bloc :
+produisant un aspect visuel intéressant de bloc :
 
 type t =
 | A 
@@ -40,11 +40,11 @@ let f expr = function
 | A -> ...
 | B x -> ...
 
-Le deuxième cas est obtenu sous tuareg avec les réglages
+Le deuxième cas est obtenu sous tuareg avec les réglages
 
   (setq tuareg-with-indent 0)
   (setq tuareg-function-indent 0)
-  (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien 
+  (setq tuareg-let-always-indent nil) /// notons que cette dernière est bien 
                                       /// pour les let mais pas pour les let-in
 
 Conditionnelles
@@ -55,7 +55,7 @@ Conditionnelles
     deuxieme-cas
 
   Si effets de bord dans les branches, utilisez begin ... end et non des
-  parenthèses i.e.
+  parenthèses i.e.
 
   if condition then begin
     instr1;
@@ -65,7 +65,7 @@ Conditionnelles
     instr4
   end
     
-  Si la première branche lève une exception, évitez le else i.e.
+  Si la première branche lève une exception, évitez le else i.e.
 
     if condition then                     if condition then error "machin";
       error "machin"          ----->      suite
diff --git a/dev/doc/transition-V5.10-V6 b/dev/doc/transition-V5.10-V6
new file mode 100644
index 00000000..df7b65dd
--- /dev/null
+++ b/dev/doc/transition-V5.10-V6
@@ -0,0 +1,5 @@
+The V5.10 archive has been created with cvs in February 1995 by
+Jean-Christophe Filliâtre. It was moved to archive V6 in March 1996.
+At this occasion, the contrib directory (user-contributions) were
+moved to a separate directory and some theories (like ALGEBRA) moved
+to the user-contributions directory too.
diff --git a/dev/doc/transition-V6-V7 b/dev/doc/transition-V6-V7
new file mode 100644
index 00000000..e477c9ff
--- /dev/null
+++ b/dev/doc/transition-V6-V7
@@ -0,0 +1,8 @@
+The V6 archive has been created in March 1996 with files from the
+former V5.10 archive and has been abandoned in 2000.
+
+A new archive named V7 has been created in August 1999 by
+Jean-Christophe Filliâtre with a new architecture placing the
+type-checking at the kernel of Coq. This new architecture came with a
+"cleaner" organization of files, a uniform indentation style, uniform
+headers, etc.
diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt
new file mode 100644
index 00000000..4c89af01
--- /dev/null
+++ b/dev/doc/univpoly.txt
@@ -0,0 +1,255 @@
+Notes on universe polymorphism and primitive projections, M. Sozeau - WIP 
+=========================================================================
+
+The new implementation of universe polymorphism and primitive
+projections introduces a few changes to the API of Coq. First and
+foremost, the term language changes, as global references now carry a
+universe level substitution:
+
+type 'a puniverses = 'a * Univ.Instance.t
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+type constr = ...
+  | Const of puniversess
+  | Ind of pinductive
+  | Constr of pconstructor
+  | Proj of constant * constr
+
+
+Universes
+=========
+
+  Universe instances (an array of levels) gets substituted when
+unfolding definitions, are used to typecheck and are unified according
+to the rules in the ITP'14 paper on universe polymorphism in Coq.  
+
+type Level.t = Set | Prop | Level of int * dirpath (* hashconsed *)
+type Instance.t = Level.t array
+type Universe.t = Level.t list (* hashconsed *)
+
+The universe module defines modules and abstract types for levels,
+universes etc.. Structures are hashconsed (with a hack to take care
+of the fact that deserialization breaks sharing). 
+
+  Definitions (constants, inductives) now carry around not only 
+constraints but also the universes they introduced (a Univ.UContext.t).
+There is another kind of contexts [Univ.ContextSet.t], the latter has 
+a set of universes, while the former has serialized the levels in an
+array, and is used for polymorphic objects. Both have "reified" 
+constraints depending on global and local universes. 
+
+  A polymorphic definition is abstract w.r.t. the variables in this
+context, while a monomorphic one (or template polymorphic) just adds the
+universes and constraints to the global universe context when it is put
+in the environment. No other universes than the global ones and the
+declared local ones are needed to check a declaration, hence the kernel
+does not produce any constraints anymore, apart from module
+subtyping.... There are hance two conversion functions now: check_conv
+and infer_conv: the former just checks the definition in the current env
+(in which we usually push_universe_context of the associated context),
+and infer_conv which produces constraints that were not implied by the
+ambient constraints. Ideally, that one could be put out of the kernel,
+but again, module subtyping needs it. 
+
+ Inference of universes is now done during refinement, and the evar_map
+carries the incrementally built universe context. [Evd.conversion] is a
+wrapper around [infer_conv] that will do the bookkeeping for you, it
+uses [evar_conv_x]. There is a universe substitution being built
+incrementally according to the constraints, so one should normalize at
+the end of a proof (or during a proof) with that substitution just like
+we normalize evars. There are some nf_* functions in
+library/universes.ml to do that. Additionally, there is a minimization
+algorithm in there that can be applied at the end of a proof to simplify
+the universe constraints used in the term. It is heuristic but
+validity-preserving. No user-introduced universe (i.e. coming from a
+user-written anonymous Type) gets touched by this, only the fresh
+universes generated for each global application. Using
+
+val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic
+
+Is the way to make a constr out of a global reference in the new API.
+If they constr is polymorphic, it will add the necessary constraints to
+the evar_map. Even if a constr is not polymorphic, we have to take care
+of keeping track of it's universes. Typically, using:
+
+  mkApp (coq_id_function, [| A; a |]) 
+
+and putting it in a proof term is not enough now. One has to somehow
+show that A's type is in cumululativity relation with id's type
+argument, incurring a universe constraint. To do this, one can simply
+call Typing.resolve_evars env evdref c which will do some infer_conv to
+produce the right constraints and put them in the evar_map. Of course in
+some cases you might now from an invariant that no new constraint would
+be produced and get rid of it. Anyway the kernel will tell you if you
+forgot some. As a temporary way out, [Universes.constr_of_global] allows
+you to make a constr from any non-polymorphic constant, but it might
+forget constraints.
+
+Other than that, unification (w_unify and evarconv) now take account of universes and
+produce only well-typed evar_maps.
+
+Some syntactic comparisons like the one used in [change] have to be
+adapted to allow identification up-to-universes (when dealing with 
+polymorphic references), [make_eq_univs_test] is there to help. 
+In constr, there are actually many new comparison functions to deal with
+that:
+ 
+(** [equal a b] is true if [a] equals [b] modulo alpha, casts,
+   and application grouping *)
+val equal : constr -> constr -> bool
+
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [u]. *)
+val eq_constr_univs : constr Univ.check_function
+
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe inequalities in [u]. *)
+val leq_constr_univs : constr Univ.check_function
+
+(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [c]. *)
+val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained
+
+(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo
+    alpha, casts, application grouping and the universe inequalities in [c]. *)
+val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained
+
+(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and ignoring universe instances. *)
+val eq_constr_nounivs : constr -> constr -> bool
+
+The [_univs] versions are doing checking of universe constraints
+according to a graph, while the [_universes] are producing (non-atomic) 
+universe constraints. The non-atomic universe constraints include the
+[ULub] constructor: when comparing [f (* u1 u2 *) c] and [f (* u1' u2'
+*) c] we add ULub constraints on [u1, u1'] and [u2, u2']. These are
+treated specially: as unfolding [f] might not result in these
+unifications, we need to keep track of the fact that failure to satisfy
+them does not mean that the term are actually equal. This is used in
+unification but probably not necessary to the average programmer. 
+
+Another issue for ML programmers is that tables of constrs now usually
+need to take a [constr Univ.in_universe_context_set] instead, and
+properly refresh the universes context when using the constr, e.g. using 
+Clenv.refresh_undefined_univs clenv or: 
+
+(** Get fresh variables for the universe context.
+    Useful to make tactics that manipulate constrs in universe contexts polymorphic. *)
+val fresh_universe_context_set_instance : universe_context_set -> 
+  universe_level_subst * universe_context_set
+
+The substitution should be applied to the constr(s) under consideration, 
+and the context_set merged with the current evar_map with:
+
+val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map
+
+The [rigid] flag here should be [Evd.univ_flexible] most of the
+time. This means the universe levels of polymorphic objects in the
+constr might get instantiated instead of generating equality constraints 
+(Evd.univ_rigid does that).
+
+On this issue, I recommend forcing commands to take [global_reference]s
+only, the user can declare his specialized terms used as hints as
+constants and this is cleaner. Alas, backward-compatibility-wise,
+this is the only solution I found. In the case of global_references
+only, it's just a matter of using [Evd.fresh_global] /
+[pf_constr_of_global] to let the system take care of universes.
+
+Projections
+===========
+
+  | Proj of constant * constr
+
+Projections are always applied to a term, which must be of a record type
+(i.e. reducible to an inductive type [I params]). Type-checking,
+reduction and conversion are fast (not as fast as they could be yet)
+because we don't keep parameters around. As you can see, it's currently
+a [constant] that is used here to refer to the projection, that will
+change to an abstract [projection] type in the future. Basically a
+projection constant records which inductive it is a projection for, the
+number of params and the actual position in the constructor that must be
+projected. For compatibility reason, we also define an eta-expanded form
+(accessible from user syntax @f). The constant_entry of a projection has
+both informations. Declaring a record (under [Set Primitive
+Projections]) will generate such definitions. The API to declare them is
+not stable at the moment, but the inductive type declaration also knows
+about the projections, i.e. a record inductive type decl contains an
+array of terms representing the projections. This is used to implement
+eta-conversion for record types (with at least one field and having all
+projections definable). The canonical value being [Build_R (pn x)
+... (pn x)]. Unification and conversion work up to this eta rule. The
+records can also be universe polymorphic of course, and we don't need to
+keep track of the universe instance for the projections either.
+Projections are reduced _eagerly_ everywhere, and introduce a new Zproj
+constructor in the abstract machines that obeys both the delta (for the
+constant opacity) and iota laws (for the actual reduction). Refolding
+works as well (afaict), but there is a slight hack there related to
+universes (not projections). 
+
+For the ML programmer, the biggest change is that pattern-matchings on
+kind_of_term require an additional case, that is handled usually exactly
+like an [App (Const p) arg].
+
+There are slight hacks related to hints is well, to use the primitive
+projection form of f when one does [Hint Resolve f]. Usually hint
+resolve will typecheck the term, resulting in a partially applied
+projection (disallowed), so we allow it to take
+[constr_or_global_reference] arguments instead and special-case on
+projections. Other tactic extensions might need similar treatment. 
+
+WIP
+===
+
+- [vm_compute] does not deal with universes and projections correctly,
+except when it goes to a normal form with no projections or polymorphic
+constants left (the most common case). E.g. Ring with Set Universe
+Polymorphism and Set Primitive Projections work (at least it did at some
+point, I didn't recheck yet).  
+
+- [native_compute] is untested: it should deal with primitive
+projections right but not universes.
+
+
+Incompatibilities
+=================
+
+Old-style universe polymorphic definitions were implemented by taking
+advantage of the fact that elaboration (i.e., pretyping and unification)
+were _not_ universe aware, so some of the constraints generated during
+pretypechecking would be forgotten. In the current setting, this is not
+possible, as unification ensures that the substitution is built is
+entirely well-typed, even w.r.t universes. This means that some terms
+that type-checked before no longer do, especially projections of the
+pair:
+
+@fst ?x ?y : prod ?x ?y : Type (max(Datatypes.i, Datatypes.j)).
+
+The "template universe polymorphic" variables i and j appear during
+typing without being refreshed, meaning that they can be lowered (have
+upper constraints) with user-introduced universes. In most cases this
+won't work, so ?x and ?y have to be instantiated earlier, either from
+the type of the actual projected pair term (some t : prod A B) or the
+typing constraint. Adding the correct type annotations will always fix 
+this.
+
+
+Unification semantics
+=====================
+
+In Ltac, matching with:
+
+- a universe polymorphic constant [c] matches any instance of the
+  constant.
+- a variable ?x already bound to a term [t] (non-linear pattern) uses 
+  strict equality of universes (e.g., Type@{i} and Type@{j} are not
+  equal).
+
+In tactics:
+
+- [change foo with bar], [pattern foo] will unify all instances of [foo]
+  (and convert them with [bar]). This might incur unifications of
+  universes. [change] uses conversion while [pattern] only does
+  syntactic matching up-to unification of universes.
+- [apply], [refine] use unification up to universes.
diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex
index 175297f9..9892a441 100644
--- a/dev/doc/versions-history.tex
+++ b/dev/doc/versions-history.tex
@@ -1,6 +1,6 @@
 \documentclass[a4paper]{book}
 \usepackage{fullpage}
-\usepackage[latin1]{inputenc}
+\usepackage[utf8]{inputenc}
 \usepackage[T1]{fontenc}
 \usepackage{amsfonts}
 
@@ -245,7 +245,7 @@ Coq V6.3.1& released 7 December 1999\\
 \begin{tabular}{l|l|l}
 version & date & comments \\
 \hline
-Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \\
+Coq ``V7'' archive & August 1999 & new cvs archive based on J.-C. Filliâtre's \\
    & & \feature{kernel-centric} architecture \\
    & & more care for outside readers\\
    & & (indentation, ocaml warning protection)\\
diff --git a/dev/dynlink.ml b/dev/dynlink.ml
new file mode 100644
index 00000000..810e0ffc
--- /dev/null
+++ b/dev/dynlink.ml
@@ -0,0 +1,51 @@
+
+(** Some architectures may have a native ocaml compiler but no native
+    dynlink.cmxa (e.g. ARM). If you still want to build a native coqtop
+    there, you'll need this dummy implementation of Dynlink.
+    Compile it and install with:
+
+      ocamlopt -a -o dynlink.cmxa dynlink.ml
+      sudo cp -i dynlink.cmxa `ocamlopt -where`
+
+    Then build coq this way: ./configure -natdynlink no && make world
+*)
+
+let is_native = true (* This file will only be given to the native compiler *)
+
+type linking_error =
+| Undefined_global of string
+| Unavailable_primitive of string
+| Uninitialized_global of string
+
+type error =
+| Not_a_bytecode_file of string
+| Inconsistent_import of string
+| Unavailable_unit of string
+| Unsafe_file
+| Linking_error of string * linking_error
+| Corrupted_interface of string
+| File_not_found of string
+| Cannot_open_dll of string
+| Inconsistent_implementation of string
+
+exception Error of error
+
+let error_message = function
+  | Not_a_bytecode_file s -> "Native dynamic link not supported (module "^s^")"
+  | _ -> "Native dynamic link not supported"
+
+let loadfile : string -> unit = fun s -> raise (Error (Not_a_bytecode_file s))
+let loadfile_private = loadfile
+
+let adapt_filename s = s
+
+let init () = ()
+let allow_only : string list -> unit = fun _ -> ()
+let prohibit : string list -> unit = fun _ -> ()
+let default_available_units : unit -> unit = fun _ -> ()
+let allow_unsafe_modules : bool -> unit = fun _ -> ()
+let add_interfaces : string list -> string list -> unit = fun _ _ -> ()
+let add_available_units : (string * Digest.t) list -> unit = fun _ -> ()
+let clear_available_units : unit -> unit = fun _ -> ()
+let digest_interface : string -> string list -> Digest.t =
+ fun _ _ -> failwith "digest_interface"
diff --git a/dev/header b/dev/header
index 4dd8f5a9..e5184df3 100644
--- a/dev/header
+++ b/dev/header
@@ -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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
diff --git a/dev/include b/dev/include
index 69ac3c41..b2eb280d 100644
--- a/dev/include
+++ b/dev/include
@@ -10,8 +10,9 @@
    Alternatively, you can avoid typing #use "include" after each Drop
    by adding the following lines in your $HOME/.ocamlinit :
 
+   #directory "+compiler-libs";;
    if Filename.basename Sys.argv.(0) = "coqtop.byte"
-   then ignore (Toploop.use_silently Format.std_formatter "include")
+   then ignore (Toploop.use_silently Format.std_formatter "dev/include")
 *)
 
 (* For OCaml 3.10.x:
@@ -28,25 +29,50 @@
 
 #install_printer  (* pattern *) pppattern;;
 #install_printer  (* glob_constr *) ppglob_constr;;
-
+#install_printer  (* open constr *) ppopenconstr;;
 #install_printer  (* constr *) ppconstr;;
 #install_printer  (* constr_substituted *) ppsconstr;; 
+#install_printer  (* constraints *)  ppconstraints;;
+#install_printer  (* univ constraints *)  ppuniverseconstraints;;
 #install_printer  (* universe *)  ppuni;;
+#install_printer  (* universes *)  ppuniverse;;
 #install_printer  (* universes *)  ppuniverses;;
+#install_printer  (* univ level *) ppuni_level;;
+#install_printer  (* univ context *) ppuniverse_context;;
+#install_printer  (* univ context future *) ppuniverse_context_future;;
+#install_printer  (* univ context set *) ppuniverse_context_set;;
+#install_printer  (* univ set *) ppuniverse_set;;
+#install_printer  (* univ instance *) ppuniverse_instance;;
+#install_printer  (* univ subst *) ppuniverse_subst;;
+#install_printer  (* univ full subst *) ppuniverse_level_subst;;
+#install_printer  (* univ opt subst *) ppuniverse_opt_subst;;
+#install_printer  (* evar univ ctx *) ppevar_universe_context;;
+#install_printer  (* constraints_map *) ppconstraints_map;;
+#install_printer  (* inductive *) ppind;;
+#install_printer  (* 'a scheme_kind *) ppscheme;;
 #install_printer  (* type_judgement *) pptype;;
 #install_printer  (* judgement *) ppj;;
+#install_printer  (* id set *) ppidset;;
+#install_printer  (* int set *) ppintset;;
+
+#install_printer  (* Reductionops stcak of unfolded constants *) pp_cst_stack_t;;
+#install_printer  (* Reductionops machine stack *) pp_stack_t;;
 
-#install_printer  (* hint_db *)  print_hint_db;;
+(*#install_printer  (* hint_db *)  print_hint_db;;*)
 (*#install_printer  (* hints_path *)  pphintspath;;*)
 #install_printer  (* goal *)  ppgoal;;
 (*#install_printer  (* sigma goal *)  ppsigmagoal;;*)
 (*#install_printer  (* proof *)  pproof;;*)
 #install_printer  (* Goal.goal *)  ppgoalgoal;;
+#install_printer  (* proofview *)  ppproofview;;
 #install_printer  (* metaset.t *) ppmetas;;
+#install_printer  (* evar *)  ppevar;;
 #install_printer  (* evar_map *)  ppevm;;
-#install_printer  (* ExistentialSet.t *) ppexistentialset;;
+#install_printer  (* Evar.Set.t *) ppexistentialset;;
 #install_printer  (* clenv *) ppclenv;;
 #install_printer  (* env *) ppenv;;
+#install_printer  (* Hint_db.t *) pphintdb;;
+#install_printer  (* named_context_val *) ppnamedcontextval;;
 
 #install_printer  (* tactic *) pptac;;
 #install_printer  (* object *) ppobj;;
@@ -54,3 +80,5 @@
 #install_printer  (* generic_argument *) pp_generic_argument;;
 
 #install_printer  (* fconstr *) ppfconstr;;
+
+#install_printer (* Future.computation *) ppfuture;;
diff --git a/dev/make-installer-win32.sh b/dev/make-installer-win32.sh
new file mode 100755
index 00000000..ec7cd577
--- /dev/null
+++ b/dev/make-installer-win32.sh
@@ -0,0 +1,20 @@
+#!/bin/sh
+
+NSIS="$BASE/NSIS/makensis"
+ZIP=_make.zip
+URL1=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-bin.zip/download
+URL2=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-dep.zip/download
+
+[ -e config/Makefile ] || ./configure -prefix ./ -with-doc no
+make -j2 
+if [ ! -e bin/make.exe ]; then
+  wget -O $ZIP $URL1 && 7z x $ZIP "bin/*"
+  wget -O $ZIP $URL2 && 7z x $ZIP "bin/*"
+  rm -rf $ZIP
+fi
+VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2`
+cd dev/nsis
+"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" coq.nsi
+echo Installer:
+ls -h $PWD/*exe
+cd ../..
diff --git a/dev/make-sdk-win32.sh b/dev/make-sdk-win32.sh
new file mode 100755
index 00000000..0112324d
--- /dev/null
+++ b/dev/make-sdk-win32.sh
@@ -0,0 +1,370 @@
+#!/bin/bash
+
+# To run this script install cygwin by running setup-x86.exe from cygwin.com
+# Install the standard packages plus wget.  Then run this script.
+
+# Sworn by Enrico Tassi <enrico.tassi@inra.fr>
+# Modified to support other directories and almost support spaces in paths
+# by Jason Gross <jgross@mit.edu>
+# License: Expat/MIT http://opensource.org/licenses/MIT
+
+# This script reads the following environment variables:
+# VERBOSE     - set to non-empty to have wget/this script be more verbose, for debugging purposes
+# BASE        - set to non-empty to give a different location for the zip file, e.g., if /cygdrive/c is full or doesn't exist
+
+set -e
+if [ ! -z "$VERBOSE" ]
+then
+  set -x
+fi
+
+# Resources
+ocaml=ocaml-4.01.0-i686-mingw64-installer3.exe
+glib=base-windows-0.18.1.1.13.356@BUILD_ec06e9.txz
+gtk=base-gtk-2.24.18.1.58@BUILD_594ca8.txz
+lablgtk=lablgtk-2.18.0.tar.gz
+camlp5=camlp5-6.11.tgz
+nsis=nsis-2.46-setup.exe
+
+ocaml_URL='http://yquem.inria.fr/~protzenk/caml-installer/'$ocaml
+lablgtk_URL='https://forge.ocamlcore.org/frs/download.php/1261/'$lablgtk
+glib_URL='http://dl.arirux.de/5/binaries32/'$glib
+gtk_URL='http://dl.arirux.de/5/binaries32/'$gtk
+camlp5_URL='http://pauillac.inria.fr/~ddr/camlp5/distrib/src/'$camlp5
+nsis_URL='http://netcologne.dl.sourceforge.net/project/nsis/NSIS%202/2.46/'$nsis
+
+cygwin=setup-${HOSTTYPE/i6/x}.exe
+cygwin_URL='http://cygwin.com/'$cygwin
+cygwin_PKGS=p7zip,zip,sed,make,mingw64-i686-gcc-g++,mingw64-i686-gcc-core,mingw64-i686-gcc,patch,rlwrap,libreadline6,diffutils
+
+has_spaces() {
+    test -z "$2"
+}
+# utilities
+# http://www.dependencywalker.com/depends22_x86.zip
+
+# The SDK itself
+REVISION=85-1
+# support for working on computers that don't have a C: drive
+if [ -z "$BASE" ]
+then
+  TRUE_BASE=/cygdrive/c
+else
+  # get absolute path
+  TRUE_BASE="$(readlink -f "$BASE")"
+fi
+BASE="$TRUE_BASE/CoqSDK-$REVISION"
+
+if [ -z "$VERBOSE" ]
+then
+  WGET_ARGS="-N -q"
+else
+  WGET_ARGS="-N"
+fi
+
+# Windows has a version of FIND in C:/Windows/system32/find, and we don't want to use that
+if [ -x /usr/bin/find ]
+then
+  FIND=/usr/bin/find
+else
+  echo "WARNING: /usr/bin/find does not exist.  Falling back on:"
+  which find
+  FIND=find
+fi
+
+WGET_ARGS="-N -q"
+
+if [ "$(has_spaces $BASE; echo $?)" -ne 0 ]; then
+  echo "ERROR: The current base directory ($BASE) has spaces."
+  echo "ERROR: building lablgtk would fail."
+  exit 1
+fi
+
+cyg_install() {
+  if [ ! -e "$cygwin" ]; then wget $WGET_ARGS "$cygwin_URL"; fi
+  chmod a+x "$cygwin"
+  cygstart -w "$cygwin" -q -P $@
+}
+
+sanity_check() {
+  echo "Check: wget."
+  (which wget) || \
+	  (echo "Please install wget using the cygwin installer and retry.";\
+	   exit 1)
+  echo "Check: 7z, gcc.  If it fails wait for cygwin to complete and retry"
+  (which 7z && which i686-w64-mingw32-gcc) || \
+	  (echo "Some cygwin package is not installed.";\
+	   echo "Please wait for cygwin to finish and retry.";\
+	   cyg_install $cygwin_PKGS;\
+	   exit 1)
+}
+
+install_base() {
+  echo "Setting up $BASE"
+  rm -rf "$BASE"
+  mkdir -p "$BASE"
+}
+
+make_environ() {
+  echo "Setting up $BASE/environ"
+  pushd "$BASE" >/dev/null
+  cat > environ <<- EOF
+	cyg_install() {
+	  if [ ! -e "$cygwin" ]; then wget $WGET_ARGS "$cygwin_URL"; fi
+	  chmod a+x "$cygwin"
+	  cygstart -w "$cygwin" -q -P \$@
+	}
+	# Sanity checks: is the mingw64-i686-gcc package installed?
+	(which i686-w64-mingw32-gcc && which make && which sed) || \\
+		(echo "Some cygwin package is not installed.";\\
+	         echo "Please wait for cygwin to finish and retry.";\\
+	 	 cyg_install $cygwin_PKGS;\\
+		 exit 1) || exit 1
+
+	export BASE="\$( cd "\$( dirname "\${BASH_SOURCE[0]}" )" && pwd )"
+	export PATH="\$BASE/bin:\$PATH"
+	export OCAMLLIB="\$(cygpath -m "\$BASE")/lib"
+	export OCAMLFIND_CONF="\$(cygpath -m "\$BASE")/etc/findlib.conf"
+	sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/lib/ld.conf.in" \\
+	        > "\$BASE/lib/ld.conf"
+	sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/lib/topfind.in" \\
+	        > "\$BASE/lib/topfind"
+	sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/etc/findlib.conf.in" \\
+	        > "\$BASE/etc/findlib.conf"
+	echo "Good.  You can now build Coq and Coqide from cygwin."
+	EOF
+  popd >/dev/null
+}
+
+download() {
+  echo "Downloading some software:"
+  if [ ! -e "$ocaml" ]; then
+    echo "- downloading OCaml..."
+    wget $WGET_ARGS "$ocaml_URL"
+  fi
+  chmod a+x "$ocaml"
+  if [ ! -e "$lablgtk" ]; then
+    echo "- downloading lablgtk..."
+    wget $WGET_ARGS --no-check-certificate "$lablgtk_URL"
+  fi
+  if [ ! -e "$gtk" ]; then
+    echo "- downloading gtk..."
+    wget $WGET_ARGS "$gtk_URL"
+  fi
+  if [ ! -e "$glib" ]; then
+    echo "- downloading glib..."
+    wget $WGET_ARGS "$glib_URL"
+  fi
+  if [ ! -e "$camlp5" ]; then
+    echo "- downloading camlp5..."
+    wget $WGET_ARGS "$camlp5_URL"
+  fi
+  if [ ! -e "$nsis" ]; then
+    echo "- downloading nsis..."
+    wget $WGET_ARGS "$nsis_URL"
+  fi
+}
+
+cleanup() {
+  rm -rf tmp build
+}
+
+install_gtk() {
+  echo "Installing $glib"
+  tar -xJf "$glib" -C "$BASE"
+  echo "Installing $gtk"
+  tar -xJf "$gtk" -C "$BASE"
+}
+
+install_ocaml() {
+  echo "Installing $ocaml"
+  mkdir -p tmp
+  7z -otmp x "$ocaml" >/dev/null
+  cp -r tmp/\$_OUTDIR/bin "$BASE/"
+  cp -r tmp/bin "$BASE/"
+  cp -r tmp/\$_OUTDIR/lib "$BASE/"
+  cp -r tmp/lib "$BASE/"
+  cp -r tmp/\$_OUTDIR/etc "$BASE/"
+  "$FIND" "$BASE" -name '*.dll' -o -name '*.exe' | tr '\n' '\0' \
+	  | xargs -0 chmod a+x
+  mv "$BASE/lib/topfind" "$BASE/lib/topfind.in"
+  sed -i 's|@SITELIB@|@BASE@/lib/site-lib|g' "$BASE/lib/topfind.in"
+  cat > "$BASE/lib/ld.conf.in" <<- EOF
+	@BASE@/lib
+	@BASE@/lib/stublibs
+	EOF
+  cat > "$BASE/etc/findlib.conf.in" <<- EOF
+	destdir="@BASE@/lib/site-lib"
+	path="@BASE@/lib/site-lib"
+	stdlib="@BASE@/lib"
+	ldconf="@BASE@/lib/ld.conf"
+	ocamlc="ocamlc.opt"
+	ocamlopt="ocamlopt.opt"
+	ocamldep="ocamldep.opt"
+	ocamldoc="ocamldoc.opt"
+	EOF
+  cp "$BASE/lib/topdirs.cmi" "$BASE/lib/compiler-libs/"
+}
+
+build_install_lablgtk() {
+  echo "Building $lablgtk"
+  mkdir -p build
+  tar -xzf "$lablgtk" -C build
+  cd build/lablgtk-*
+  patch -p1 <<EOT
+--- lablgtk-2.18.0/src/glib.mli	2013-10-01 01:31:50.000000000 -0700
++++ lablgtk-2.18.0.new/src/glib.mli	2013-12-06 11:57:34.203675200 -0800
+@@ -75,6 +75,7 @@
+   type condition = [ \`ERR | \`HUP | \`IN | \`NVAL | \`OUT | \`PRI]
+   type id
+   val channel_of_descr : Unix.file_descr -> channel
++  val channel_of_descr_socket : Unix.file_descr -> channel
+   val add_watch :
+     cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id
+   val remove : id -> unit
+--- lablgtk-2.18.0/src/glib.ml	2013-10-01 01:31:50.000000000 -0700
++++ lablgtk-2.18.0.new/src/glib.ml	2013-12-06 11:57:53.070804800 -0800
+@@ -72,6 +72,8 @@
+   type id
+   external channel_of_descr : Unix.file_descr -> channel
+     = "ml_g_io_channel_unix_new"
++  external channel_of_descr_socket : Unix.file_descr -> channel
++    = "ml_g_io_channel_unix_new_socket"
+   external remove : id -> unit = "ml_g_source_remove"
+   external add_watch :
+     cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id
+--- lablgtk-2.18.0/src/ml_glib.c	2013-10-01 01:31:50.000000000 -0700
++++ lablgtk-2.18.0.new/src/ml_glib.c	2013-12-10 02:03:33.940371800 -0800
+@@ -25,6 +25,8 @@
+ #include <string.h>
+ #include <locale.h>
+ #ifdef _WIN32
++/* to kill a #warning: include winsock2.h before windows.h */
++#include <winsock2.h>
+ #include "win32.h"
+ #include <wtypes.h>
+ #include <io.h>
+@@ -38,6 +40,11 @@
+ #include <caml/callback.h>
+ #include <caml/threads.h>
+
++#ifdef _WIN32
++/* for Socket_val */
++#include <caml/unixsupport.h>
++#endif
++
+ #include "wrappers.h"
+ #include "ml_glib.h"
+ #include "glib_tags.h"
+@@ -325,14 +332,23 @@
+
+ #ifndef _WIN32
+ ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref)
++CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) {
++  return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1)));
++}
+
+ #else
+ CAMLprim value ml_g_io_channel_unix_new(value wh)
+ {
+   return Val_GIOChannel_noref
+-    (g_io_channel_unix_new
++    (g_io_channel_win32_new_fd
+      (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY)));
+ }
++
++CAMLprim value ml_g_io_channel_unix_new_socket(value wh)
++{
++  return Val_GIOChannel_noref
++    (g_io_channel_win32_new_socket(Socket_val(wh)));
++}
+ #endif
+
+ static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c,
+EOT
+  #sed -i s'/$PKG_CONFIG/"$PKG_CONFIG"/g' configure
+  #sed -i s'/""$PKG_CONFIG""/"$PKG_CONFIG"/g' configure
+  ./configure --disable-gtktest --prefix="$(cygpath -m "$BASE")" \
+	  >log-configure 2>&1
+  sed -i 's?\\?/?g' config.make
+  make >log-make 2>&1
+  make opt >>log-make 2>&1
+  #echo "Testing $lablgtk"
+  #cd src
+  #./lablgtk2 ../examples/calc.ml
+  #./lablgtk2 -all ../examples/calc.ml
+  #cd ..
+  echo "Installing $lablgtk"
+  make install >>log-make 2>&1
+  cd ../..
+}
+
+build_install_camlp5() {
+  echo "Building $camlp5"
+  mkdir -p build
+  tar -xzf "$camlp5" -C build
+  cd build/camlp5-*
+  ./configure >log-configure 2>&1
+  sed -i 's/EXT_OBJ=.obj/EXT_OBJ=.o/' config/Makefile
+  sed -i 's/EXT_LIB=.lib/EXT_LIB=.a/' config/Makefile
+  make world.opt >log-make 2>&1
+  echo "Installing $camlp5"
+  make install >>log-make 2>&1
+  cd ../..
+}
+
+install_nsis() {
+  echo "Installing $nsis"
+  rm -rf tmp
+  mkdir -p tmp
+  7z -otmp x $nsis >/dev/null
+  mkdir "$BASE/NSIS"
+  cp -r tmp/\$_OUTDIR/* "$BASE/NSIS"
+  rm -rf tmp/\$_OUTDIR
+  rm -rf tmp/\$PLUGINSDIR
+  cp -r tmp/* "$BASE/NSIS"
+}
+
+zip_sdk() {
+  echo "Generating CoqSDK-${REVISION}.zip"
+  here="`pwd`"
+  cd "$BASE/.."
+  rm -f "$here/CoqSDK-${REVISION}.zip"
+  zip -q -r "$here/CoqSDK-${REVISION}.zip" "$(basename "$BASE")"
+  cd "$here"
+}
+
+diet_sdk() {
+  rm -rf "$BASE"/+*
+  rm -rf "$BASE"/bin/camlp4*
+  rm -rf "$BASE"/lib/camlp4/
+  rm -rf "$BASE"/lib/site-lib/camlp4/
+}
+
+victory(){
+  echo "Output file: CoqSDK-${REVISION}.zip "\
+	  "(`du -sh CoqSDK-${REVISION}.zip | cut -f 1`)"
+  echo "Usage: unpack and source the environ file at its root"
+}
+
+if [ -z "$1" ]; then
+  sanity_check
+  download
+  cleanup
+  install_base
+  install_nsis
+  install_ocaml
+  install_gtk
+  make_environ
+  . "$BASE/environ"
+  build_install_lablgtk
+  build_install_camlp5
+  diet_sdk
+  make_environ
+  zip_sdk
+  cleanup
+  victory
+else
+  # just one step
+  $1
+fi
diff --git a/dev/nsis/FileAssociation.nsh b/dev/nsis/FileAssociation.nsh
new file mode 100644
index 00000000..b8c1e5ee
--- /dev/null
+++ b/dev/nsis/FileAssociation.nsh
@@ -0,0 +1,190 @@
+/*
+_____________________________________________________________________________
+ 
+                       File Association
+_____________________________________________________________________________
+ 
+ Based on code taken from http://nsis.sourceforge.net/File_Association 
+ 
+ Usage in script:
+ 1. !include "FileAssociation.nsh"
+ 2. [Section|Function]
+      ${FileAssociationFunction} "Param1" "Param2" "..." $var
+    [SectionEnd|FunctionEnd]
+ 
+ FileAssociationFunction=[RegisterExtension|UnRegisterExtension]
+ 
+_____________________________________________________________________________
+ 
+ ${RegisterExtension} "[executable]" "[extension]" "[description]"
+ 
+"[executable]"     ; executable which opens the file format
+                   ;
+"[extension]"      ; extension, which represents the file format to open
+                   ;
+"[description]"    ; description for the extension. This will be display in Windows Explorer.
+                   ;
+ 
+ 
+ ${UnRegisterExtension} "[extension]" "[description]"
+ 
+"[extension]"      ; extension, which represents the file format to open
+                   ;
+"[description]"    ; description for the extension. This will be display in Windows Explorer.
+                   ;
+ 
+_____________________________________________________________________________
+ 
+                         Macros
+_____________________________________________________________________________
+ 
+ Change log window verbosity (default: 3=no script)
+ 
+ Example:
+ !include "FileAssociation.nsh"
+ !insertmacro RegisterExtension
+ ${FileAssociation_VERBOSE} 4   # all verbosity
+ !insertmacro UnRegisterExtension
+ ${FileAssociation_VERBOSE} 3   # no script
+*/
+ 
+ 
+!ifndef FileAssociation_INCLUDED
+!define FileAssociation_INCLUDED
+ 
+!include Util.nsh
+ 
+!verbose push
+!verbose 3
+!ifndef _FileAssociation_VERBOSE
+  !define _FileAssociation_VERBOSE 3
+!endif
+!verbose ${_FileAssociation_VERBOSE}
+!define FileAssociation_VERBOSE `!insertmacro FileAssociation_VERBOSE`
+!verbose pop
+ 
+!macro FileAssociation_VERBOSE _VERBOSE
+  !verbose push
+  !verbose 3
+  !undef _FileAssociation_VERBOSE
+  !define _FileAssociation_VERBOSE ${_VERBOSE}
+  !verbose pop
+!macroend
+ 
+ 
+ 
+!macro RegisterExtensionCall _EXECUTABLE _EXTENSION _DESCRIPTION
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+  Push `${_DESCRIPTION}`
+  Push `${_EXTENSION}`
+  Push `${_EXECUTABLE}`
+  ${CallArtificialFunction} RegisterExtension_
+  !verbose pop
+!macroend
+ 
+!macro UnRegisterExtensionCall _EXTENSION _DESCRIPTION
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+  Push `${_EXTENSION}`
+  Push `${_DESCRIPTION}`
+  ${CallArtificialFunction} UnRegisterExtension_
+  !verbose pop
+!macroend
+ 
+ 
+ 
+!define RegisterExtension `!insertmacro RegisterExtensionCall`
+!define un.RegisterExtension `!insertmacro RegisterExtensionCall`
+ 
+!macro RegisterExtension
+!macroend
+ 
+!macro un.RegisterExtension
+!macroend
+ 
+!macro RegisterExtension_
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+ 
+  Exch $R2 ;exe
+  Exch
+  Exch $R1 ;ext
+  Exch
+  Exch 2
+  Exch $R0 ;desc
+  Exch 2
+  Push $0
+  Push $1
+ 
+  ReadRegStr $1 HKCR $R1 ""  ; read current file association
+  StrCmp "$1" "" NoBackup  ; is it empty
+  StrCmp "$1" "$R0" NoBackup  ; is it our own
+    WriteRegStr HKCR $R1 "backup_val" "$1"  ; backup current value
+NoBackup:
+  WriteRegStr HKCR $R1 "" "$R0"  ; set our file association
+ 
+  ReadRegStr $0 HKCR $R0 ""
+  StrCmp $0 "" 0 Skip
+    WriteRegStr HKCR "$R0" "" "$R0"
+    WriteRegStr HKCR "$R0\shell" "" "open"
+    WriteRegStr HKCR "$R0\DefaultIcon" "" "$R2,0"
+Skip:
+  WriteRegStr HKCR "$R0\shell\open\command" "" '"$R2" "%1"'
+  WriteRegStr HKCR "$R0\shell\edit" "" "Edit $R0"
+  WriteRegStr HKCR "$R0\shell\edit\command" "" '"$R2" "%1"'
+ 
+  Pop $1
+  Pop $0
+  Pop $R2
+  Pop $R1
+  Pop $R0
+ 
+  !verbose pop
+!macroend
+ 
+ 
+ 
+!define UnRegisterExtension `!insertmacro UnRegisterExtensionCall`
+!define un.UnRegisterExtension `!insertmacro UnRegisterExtensionCall`
+ 
+!macro UnRegisterExtension
+!macroend
+ 
+!macro un.UnRegisterExtension
+!macroend
+ 
+!macro UnRegisterExtension_
+  !verbose push
+  !verbose ${_FileAssociation_VERBOSE}
+ 
+  Exch $R1 ;desc
+  Exch
+  Exch $R0 ;ext
+  Exch
+  Push $0
+  Push $1
+ 
+  ReadRegStr $1 HKCR $R0 ""
+  StrCmp $1 $R1 0 NoOwn ; only do this if we own it
+  ReadRegStr $1 HKCR $R0 "backup_val"
+  StrCmp $1 "" 0 Restore ; if backup="" then delete the whole key
+  DeleteRegKey HKCR $R0
+  Goto NoOwn
+ 
+Restore:
+  WriteRegStr HKCR $R0 "" $1
+  DeleteRegValue HKCR $R0 "backup_val"
+  DeleteRegKey HKCR $R1 ;Delete key with association name settings
+ 
+NoOwn:
+ 
+  Pop $1
+  Pop $0
+  Pop $R1
+  Pop $R0
+ 
+  !verbose pop
+!macroend
+ 
+!endif # !FileAssociation_INCLUDED
\ No newline at end of file
diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi
new file mode 100755
index 00000000..90e3fdaa
--- /dev/null
+++ b/dev/nsis/coq.nsi
@@ -0,0 +1,231 @@
+; This script is used to build the Windows install program for Coq.
+
+;NSIS Modern User Interface
+;Written by Joost Verburg
+;Modified by Julien Narboux and Pierre Letouzey and Enrico Tassi
+
+;SetCompress off
+SetCompressor lzma
+; Comment out after debuging.
+
+; The VERSION should be passed as an argument at compile time using :
+;
+
+!define MY_PRODUCT "Coq" ;Define your own software name here
+!define COQ_SRC_PATH "..\.."
+!define OUTFILE "coq-installer-${VERSION}.exe"
+
+!include "MUI2.nsh"
+!include "FileAssociation.nsh"
+
+;--------------------------------
+;Configuration
+
+  Name "Coq"
+
+  ;General
+  OutFile "${OUTFILE}"
+
+  ;Folder selection page
+  InstallDir "C:\${MY_PRODUCT}"
+  
+  ;Remember install folder
+  InstallDirRegKey HKCU "Software\${MY_PRODUCT}" ""
+
+;--------------------------------
+;Modern UI Configuration
+
+  !insertmacro MUI_PAGE_WELCOME
+  !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/LICENSE"
+  !insertmacro MUI_PAGE_COMPONENTS
+  !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq.  The path MUST NOT include spaces."
+  !insertmacro MUI_PAGE_DIRECTORY
+  !insertmacro MUI_PAGE_INSTFILES
+  !insertmacro MUI_PAGE_FINISH
+  
+  !insertmacro MUI_UNPAGE_WELCOME
+  !insertmacro MUI_UNPAGE_CONFIRM
+  !insertmacro MUI_UNPAGE_INSTFILES
+  !insertmacro MUI_UNPAGE_FINISH  
+
+;--------------------------------
+;Languages
+ 
+  !insertmacro MUI_LANGUAGE "English"
+  
+;--------------------------------
+;Language Strings
+
+  ;Description
+  LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE."
+  LangString DESC_2 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq."
+
+;--------------------------------
+; Check for white spaces
+Function .onVerifyInstDir
+  StrLen $0 "$INSTDIR"
+  StrCpy $1 0
+  ${While} $1 < $0
+    StrCpy $3 $INSTDIR 1 $1
+    StrCmp $3 " " SpacesInPath
+    IntOp $1 $1 + 1
+  ${EndWhile}
+  Goto done
+  SpacesInPath:
+  Abort
+  done:
+FunctionEnd
+
+;--------------------------------
+;Installer Sections
+
+
+Section "Coq" Sec1
+
+  SetOutPath "$INSTDIR\"
+
+  SetOutPath "$INSTDIR\bin"
+  File ${COQ_SRC_PATH}\bin\*.exe
+  ; make.exe and its dll
+  File ${COQ_SRC_PATH}\bin\make.exe
+  File ${COQ_SRC_PATH}\bin\libiconv2.dll
+  File ${COQ_SRC_PATH}\bin\libintl3.dll
+
+  SetOutPath "$INSTDIR\lib\theories"
+  File /r ${COQ_SRC_PATH}\theories\*.vo
+  File /r ${COQ_SRC_PATH}\theories\*.v
+  File /r ${COQ_SRC_PATH}\theories\*.glob
+  File /r ${COQ_SRC_PATH}\theories\*.cmi
+  File /r ${COQ_SRC_PATH}\theories\*.cmxs
+  SetOutPath "$INSTDIR\lib\plugins"
+  File /r ${COQ_SRC_PATH}\plugins\*.vo
+  File /r ${COQ_SRC_PATH}\plugins\*.v
+  File /r ${COQ_SRC_PATH}\plugins\*.glob
+  File /r ${COQ_SRC_PATH}\plugins\*.cmi
+  File /r ${COQ_SRC_PATH}\plugins\*.cmxs
+  SetOutPath "$INSTDIR\lib\tools\coqdoc"
+  File ${COQ_SRC_PATH}\tools\coqdoc\coqdoc.sty
+  File ${COQ_SRC_PATH}\tools\coqdoc\coqdoc.css
+  SetOutPath "$INSTDIR\emacs"
+  File ${COQ_SRC_PATH}\tools\*.el
+  SetOutPath "$INSTDIR\man"
+  File ${COQ_SRC_PATH}\man\*.1
+  SetOutPath "$INSTDIR\lib\toploop"
+  File ${COQ_SRC_PATH}\stm\*top.cmxs
+  File ${COQ_SRC_PATH}\ide\*top.cmxs
+
+  ; CoqIDE
+  SetOutPath "$INSTDIR\ide\"
+  File ${COQ_SRC_PATH}\ide\*.png
+  SetOutPath "$INSTDIR\share\gtksourceview-2.0\language-specs\"
+  File ${COQ_SRC_PATH}\ide\*.lang
+  File ${COQ_SRC_PATH}\ide\*.xml
+
+  ; Start Menu Entries
+  SetOutPath "$INSTDIR"
+  CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe"
+
+  ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File"
+
+  SetOutPath "$INSTDIR"
+  File /r ${GTK_RUNTIME}\etc\gtk-2.0
+  SetOutPath "$INSTDIR\bin"
+  File ${GTK_RUNTIME}\bin\*.dll
+  SetOutPath "$INSTDIR\lib"
+  File /r ${GTK_RUNTIME}\lib\gtk-2.0 ${GTK_RUNTIME}\lib\glib-2.0
+  SetOutPath "$INSTDIR\share"
+  File /r ${GTK_RUNTIME}\share\themes
+  File /r ${GTK_RUNTIME}\share\gtksourceview-2.0
+
+  ;Store install folder
+  WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR
+  
+  ;Create uninstaller
+  WriteUninstaller "$INSTDIR\Uninstall.exe"
+  WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+	  "DisplayName" "Coq Version ${VERSION}"
+  WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+	  "UninstallString" '"$INSTDIR\Uninstall.exe"'
+
+  WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+          "DisplayVersion" "${VERSION}"
+
+  WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+          "NoModify" "1"
+  WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+          "NoRepair" "1"
+
+  WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \
+          "URLInfoAbout" "http://coq.inria.fr"
+
+; Start Menu Entries
+
+; for the path in the .lnk
+  SetOutPath "$INSTDIR" 
+
+  CreateDirectory "$SMPROGRAMS\Coq"
+  CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe"
+  WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr"
+  WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library"
+  CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0
+
+SectionEnd
+
+Section "Coq files for plugin developers" Sec2
+
+  SetOutPath "$INSTDIR\lib\"
+  File /r ${COQ_SRC_PATH}\*.cmxa
+  File /r ${COQ_SRC_PATH}\*.cmi
+  File /r ${COQ_SRC_PATH}\*.cma
+  File /r ${COQ_SRC_PATH}\*.cmo
+  File /r ${COQ_SRC_PATH}\*.a
+  File /r ${COQ_SRC_PATH}\*.o
+
+SectionEnd
+
+;--------------------------------
+;Descriptions
+
+!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN
+  !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1)
+  !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2)
+!insertmacro MUI_FUNCTION_DESCRIPTION_END
+ 
+;--------------------------------
+;Uninstaller Section
+
+Section "Uninstall"
+
+;; We keep the settings 
+;; Delete "$INSTDIR\config\coqide-gtk2rc"
+ 
+  RMDir /r "$INSTDIR\bin"
+  RMDir /r "$INSTDIR\dev"
+  RMDir /r "$INSTDIR\etc"
+  RMDir /r "$INSTDIR\lib"
+  RMDir /r "$INSTDIR\share"
+
+  Delete "$INSTDIR\man\*.1"
+  RMDir "$INSTDIR\man"
+
+  Delete "$INSTDIR\emacs\*.el"
+  RMDir "$INSTDIR\emacs"
+
+;; Start Menu
+  Delete "$SMPROGRAMS\Coq\Coq.lnk"
+  Delete "$SMPROGRAMS\Coq\CoqIde.lnk"
+  Delete "$SMPROGRAMS\Coq\Uninstall.lnk"
+  Delete "$SMPROGRAMS\Coq\The Coq HomePage.url"
+  Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url"
+  Delete "$INSTDIR\Uninstall.exe"
+  
+  DeleteRegKey /ifempty HKCU "Software\${MY_PRODUCT}"
+
+  DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\Coq"
+  DeleteRegKey HKEY_LOCAL_MACHINE "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq"
+  RMDir "$INSTDIR"
+  RMDir "$SMPROGRAMS\Coq"
+
+  ${unregisterExtension} ".v" "Coq Script File"
+
+SectionEnd
diff --git a/dev/ocamldebug-coq.template b/dev/ocamldebug-coq.run
index 74320588..d4ab22ce 100644
--- a/dev/ocamldebug-coq.template
+++ b/dev/ocamldebug-coq.run
@@ -1,21 +1,24 @@
 #!/bin/sh
 
-# wrap around ocamldebug for Coq
+# Wrapper around ocamldebug for Coq
 
-export COQTOP=COQTOPDIRECTORY
-export COQLIB=COQLIBDIRECTORY
-export COQTH=$COQLIB/theories
-CAMLBIN=CAMLBINDIRECTORY
-CAMLP4LIB=CAMLP4LIBDIRECTORY
-OCAMLDEBUG=$CAMLBIN/ocamldebug
+# This file is to be launched via the generated script ocamldebug-coq,
+# which will set the env variables $OCAMLDEBUG, $CAMLP4LIB, $COQTOP
+# Anyway, just in case someone tries to use this script directly,
+# here are some reasonable default values
+
+[ -z "$OCAMLDEBUG" ] && OCAMLDEBUG=ocamldebug
+[ -z "$CAMLP4LIB" ] && CAMLP4LIB=+camlp5
+[ -z "$COQTOP" -a -d "$PWD/kernel" ] && COQTOP=$PWD
+[ -z "$COQTOP" -a -d "$PWD/../kernel" ] && COQTOP=`dirname $PWD`
 
 exec $OCAMLDEBUG \
 	-I $CAMLP4LIB \
 	-I $COQTOP \
-	-I $COQTOP/config \
-	-I $COQTOP/lib -I $COQTOP/kernel \
+	-I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar \
+	-I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel \
 	-I $COQTOP/library -I $COQTOP/pretyping -I $COQTOP/parsing \
-        -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics \
+        -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \
 	-I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \
         -I $COQTOP/plugins/cc         -I $COQTOP/plugins/dp \
         -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \
@@ -28,4 +31,4 @@ exec $OCAMLDEBUG \
         -I $COQTOP/plugins/subtac     -I $COQTOP/plugins/syntax \
         -I $COQTOP/plugins/xml \
         -I $COQTOP/ide \
-	$*
+	"$@"
diff --git a/dev/printers.mllib b/dev/printers.mllib
index 40a5a822..2f78c2e9 100644
--- a/dev/printers.mllib
+++ b/dev/printers.mllib
@@ -1,105 +1,166 @@
 Coq_config
 
+Terminal
+Hook
+Canary
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+IStream
 Pp_control
-Pp
+Loc
 Compat
 Flags
+Control
+Loc
+Serialize
+Stateid
+Feedback
+Pp
 Segmenttree
 Unicodetable
-Util
+Unicode
 Errors
+CObj
+CList
+CString
+CArray
+CStack
+Util
 Bigint
-Hashcons
 Dyn
+CUnix
 System
 Envars
-Store
-Gmap
-Fset
-Fmap
-Gmapl
+Aux_file
 Profile
 Explore
 Predicate
 Rtree
 Heap
-Option
-Dnet
-Hashtbl_alt
+Genarg
+Stateid
+Ephemeron
+Future
+RemoteCounter
+Monad
 
 Names
 Univ
 Esubst
+Uint31
+Sorts
+Evar
+Constr
+Context
+Vars
 Term
 Mod_subst
-Sign
 Cbytecodes
 Copcodes
 Cemitcodes
-Declarations
+Nativevalues
+Primitives
+Nativeinstr
+Future
+Opaqueproof
+Declareops
 Retroknowledge
+Conv_oracle
 Pre_env
+Nativelambda
+Nativecode
+Nativelib
 Cbytegen
 Environ
-Conv_oracle
 Closure
 Reduction
+Nativeconv
 Type_errors
-Entries
 Modops
 Inductive
 Typeops
+Fast_typeops
 Indtypes
 Cooking
 Term_typing
 Subtyping
 Mod_typing
+Nativelibrary
 Safe_typing
+Unionfind
 
 Summary
 Nameops
 Libnames
+Globnames
 Global
 Nametab
 Libobject
 Lib
+Loadpath
 Goptions
 Decls
 Heads
 Assumptions
+Keys
+Locusops
+Miscops
+Universes
 Termops
 Namegen
 Evd
-Glob_term
+Glob_ops
+Redops
 Reductionops
 Inductiveops
+Arguments_renaming
+Nativenorm
 Retyping
 Cbv
 Pretype_errors
 Evarutil
-Term_dnet
+Evarsolve
 Recordops
 Evarconv
-Arguments_renaming
 Typing
-Pattern
-Matching
+Patternops
+Constr_matching
+Find_subterm
 Tacred
 Classops
 Typeclasses_errors
 Typeclasses
 Detyping
 Indrec
+Program
 Coercion
-Unification
 Cases
 Pretyping
+Unification
 Declaremods
+Library
+States
 
+Genprint
 Tok
 Lexer
 Ppextend
-Genarg
+Pputils
+Ppstyle
+Ppannotation
+Stdarg
+Constrarg
+Constrexpr_ops
+Genintern
+Notation_ops
 Topconstr
 Notation
 Dumpglob
@@ -111,13 +172,16 @@ Smartlocate
 Constrintern
 Modintern
 Constrextern
-Tacexpr
 Proof_type
 Goal
+Miscprint
 Logic
 Refiner
 Clenv
 Evar_refiner
+Proof_errors
+Logic_monad
+Proofview_monad
 Proofview
 Proof
 Proof_global
@@ -125,16 +189,24 @@ Pfedit
 Tactic_debug
 Decl_mode
 Ppconstr
-Extend
-Extrawit
 Pcoq
 Printer
 Pptactic
 Ppdecl_proof
-Tactic_printer
-Egrammar
+Egramml
+Egramcoq
+Tacsubst
+Tacenv
+Trie
+Dn
+Btermdn
+Hints
 Himsg
 Cerrors
-Vernacexpr
+Locality
 Vernacinterp
+Dischargedhypsmap
+Discharge
+Declare
+Ind_tables
 Top_printers
diff --git a/dev/top_printers.ml b/dev/top_printers.ml
index 0c244603..dea70360 100644
--- a/dev/top_printers.ml
+++ b/dev/top_printers.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,70 +8,93 @@
 
 (* Printers for the ocaml toplevel. *)
 
-open System
 open Util
 open Pp
 open Names
 open Libnames
+open Globnames
 open Nameops
-open Sign
 open Univ
 open Environ
 open Printer
-open Tactic_printer
 open Term
-open Termops
-open Cerrors
 open Evd
 open Goptions
 open Genarg
-open Mod_subst
 open Clenv
+open Universes
 
-let _ = Constrextern.print_evar_arguments := true
-let _ = Constrextern.print_universes := true
+let _ = Detyping.print_evar_arguments := true
+let _ = Detyping.print_universes := true
 let _ = set_bool_option_value ["Printing";"Matching"] false
 let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found)
 
 (* std_ppcmds *)
 let pppp x = pp x
 
+(** Future printer *)
+
+let ppfuture kx = pp (Future.print (fun _ -> str "_") kx)
+
 (* name printers *)
 let ppid id = pp (pr_id id)
 let pplab l = pp (pr_lab l)
-let ppmbid mbid = pp (str (debug_string_of_mbid mbid))
+let ppmbid mbid = pp (str (MBId.debug_to_string mbid))
 let ppdir dir = pp (pr_dirpath dir)
 let ppmp mp = pp(str (string_of_mp mp))
 let ppcon con = pp(debug_pr_con con)
+let ppproj con = pp(debug_pr_con (Projection.constant con))
 let ppkn kn = pp(pr_kn kn)
 let ppmind kn = pp(debug_pr_mind kn)
+let ppind (kn,i) = pp(debug_pr_mind kn ++ str"," ++int i)
 let ppsp sp = pp(pr_path sp)
 let ppqualid qid = pp(pr_qualid qid)
 let ppclindex cl = pp(Classops.pr_cl_index cl)
+let ppscheme k = pp (Ind_tables.pr_scheme_kind k)
+
+let pprecarg = function
+  | Declarations.Norec -> str "Norec"
+  | Declarations.Mrec (mind,i) ->
+     str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
+  | Declarations.Imbr (mind,i) ->
+     str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
+let ppwf_paths x = pp (Rtree.pp_tree pprecarg x)
+
+let pprecarg = function
+  | Declarations.Norec -> str "Norec"
+  | Declarations.Mrec (mind,i) ->
+     str "Mrec[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
+  | Declarations.Imbr (mind,i) ->
+     str "Imbr[" ++ MutInd.print mind ++ pr_comma () ++ int i ++ str "]"
+let ppwf_paths x = pp (Rtree.pp_tree pprecarg x)
 
 (* term printers *)
 let rawdebug = ref false
+let ppevar evk = pp (str (Evd.string_of_existential evk))
 let ppconstr x = pp (Termops.print_constr x)
+let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x)
 let ppconstrdb x = pp(Flags.with_option rawdebug Termops.print_constr x)
 let ppterm = ppconstr
-let ppsconstr x = ppconstr (Declarations.force x)
+let ppsconstr x = ppconstr (Mod_subst.force_constr x)
 let ppconstr_univ x = Constrextern.with_universes ppconstr x
 let ppglob_constr = (fun x -> pp(pr_lglob_constr x))
 let pppattern = (fun x -> pp(pr_constr_pattern x))
 let pptype = (fun x -> try pp(pr_ltype x) with e -> pp (str (Printexc.to_string e)))
-
 let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
 
 let ppbigint n = pp (str (Bigint.to_string n));;
 
 let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]"
-let ppintset l = pp (prset int (Intset.elements l))
-let ppidset l = pp (prset pr_id (Idset.elements l))
+let ppintset l = pp (prset int (Int.Set.elements l))
+let ppidset l = pp (prset pr_id (Id.Set.elements l))
 
 let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]"
-let ppidmap pr l =
+
+let pridmap pr l =
   let pr (id,b) = pr_id id ++ str "=>" ++ pr id b in
-  pp (prset' pr (Idmap.fold (fun a b l -> (a,b)::l) l []))
+  prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l [])
+
+let ppidmap pr l = pp (pridmap pr l)
 
 let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) ->
   hov 0
@@ -81,6 +104,33 @@ let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) ->
    (if id = id0 then mt ()
     else spc () ++ str "<canonical: " ++ pr_id id ++ str ">"))))
 
+let prididmap = pridmap (fun _ -> pr_id)
+let ppididmap = ppidmap (fun _ -> pr_id)
+
+let prconstrunderbindersidmap = pridmap (fun _ (l,c) ->
+  hov 1 (str"[" ++  prlist_with_sep spc Id.print l ++ str"]")
+  ++ str "," ++ spc () ++ Termops.print_constr c)
+
+let ppconstrunderbindersidmap l = pp (prconstrunderbindersidmap l)
+
+let ppunbound_ltac_var_map l = ppidmap (fun _ arg ->
+  str"<genarg:" ++ pr_argument_type(genarg_tag arg) ++ str">")
+
+open Glob_term
+
+let rec pr_closure {idents=idents;typed=typed;untyped=untyped} =
+  hov 1 (str"{idents=" ++ prididmap idents ++ str";" ++ spc() ++
+         str"typed=" ++ prconstrunderbindersidmap typed ++ str";" ++ spc() ++
+         str"untyped=" ++ pr_closed_glob_constr_idmap untyped ++ str"}")
+and pr_closed_glob_constr_idmap x =
+  pridmap (fun _ -> pr_closed_glob_constr) x
+and pr_closed_glob_constr {closure=closure;term=term} =
+  pr_closure closure ++ pr_lglob_constr term
+
+let ppclosure x = pp (pr_closure x)
+let ppclosedglobconstr x = pp (pr_closed_glob_constr x)
+let ppclosedglobconstridmap x = pp (pr_closed_glob_constr_idmap x)
+
 let pP s = pp (hov 0 s)
 
 let safe_pr_global = function
@@ -109,18 +159,33 @@ let prdelta s = pp (Mod_subst.debug_pr_delta s)
 let pp_idpred s = pp (pr_idpred s)
 let pp_cpred s = pp (pr_cpred s)
 let pp_transparent_state s = pp (pr_transparent_state s)
+let pp_stack_t n = pp (Reductionops.Stack.pr Termops.print_constr n)
+let pp_cst_stack_t n = pp (Reductionops.Cst_stack.pr n)
+let pp_state_t n = pp (Reductionops.pr_state n)
 
 (* proof printers *)
+let pr_evar ev = Pp.int (Evar.repr ev)
 let ppmetas metas = pp(pr_metaset metas)
-let ppevm evd = pp(pr_evar_map (Some 2) evd)
-let ppevmall evd = pp(pr_evar_map None evd)
+let ppevm evd = pp(pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd)
+let ppevmall evd = pp(pr_evar_map ~with_univs:!Flags.univ_print None evd)
 let pr_existentialset evars =
-  prlist_with_sep spc pr_meta (ExistentialSet.elements evars)
+  prlist_with_sep spc pr_evar (Evar.Set.elements evars)
 let ppexistentialset evars =
   pp (pr_existentialset evars)
+let ppexistentialfilter filter = match Evd.Filter.repr filter with
+| None -> pp (Pp.str "ø")
+| Some f -> pp (prlist_with_sep spc bool f)
 let ppclenv clenv = pp(pr_clenv clenv)
 let ppgoalgoal gl = pp(Goal.pr_goal gl)
 let ppgoal g = pp(Printer.pr_goal g)
+let ppgoalsigma g = pp(Printer.pr_goal g ++ pr_evar_map None (Refiner.project g))
+let pphintdb db = pp(Hints.pr_hint_db db)
+let ppproofview p =
+  let gls,sigma = Proofview.proofview p in
+  pp(pr_enum Goal.pr_goal gls ++ fnl () ++ pr_evar_map (Some 1) sigma)
+
+let ppopenconstr (x : Evd.open_constr) =
+  let (evd,c) = x in pp (pr_evar_map (Some 2) evd ++ pr_constr c)
 (* spiwack: deactivated until a replacement is found
 let pppftreestate p = pp(print_pftreestate p)
 *)
@@ -131,7 +196,7 @@ let pppftreestate p = pp(print_pftreestate p)
 
 (* let pr_glls glls = *)
 (*   hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ *)
-(*          prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) *)
+(*          prlist_with_sep fnl db_pr_goal (sig_it glls)) *)
 
 (* let ppsigmagoal g = pp(pr_goal (sig_it g)) *)
 (* let prgls gls = pp(pr_gls gls) *)
@@ -139,19 +204,34 @@ let pppftreestate p = pp(print_pftreestate p)
 (* let pproof p = pp(print_proof Evd.empty empty_named_context p) *)
 
 let ppuni u = pp(pr_uni u)
-
-let ppuniverses u = pp (str"[" ++ pr_universes u ++ str"]")
-
-let ppconstraints c = pp (pr_constraints c)
+let ppuni_level u = pp (Level.pr u)
+let ppuniverse u = pp (str"[" ++ Universe.pr u ++ str"]")
+
+let prlev = Universes.pr_with_global_universes
+let ppuniverse_set l = pp (LSet.pr prlev l)
+let ppuniverse_instance l = pp (Instance.pr prlev l)
+let ppuniverse_context l = pp (pr_universe_context prlev l)
+let ppuniverse_context_set l = pp (pr_universe_context_set prlev l)
+let ppuniverse_subst l = pp (Univ.pr_universe_subst l)
+let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l)
+let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l)
+let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l)
+let ppconstraints_map c = pp (Universes.pr_constraints_map c)
+let ppconstraints c = pp (pr_constraints Level.pr c)
+let ppuniverseconstraints c = pp (Universes.Constraints.pr c)
+let ppuniverse_context_future c = 
+  let ctx = Future.force c in
+    ppuniverse_context ctx
+let ppuniverses u = pp (Univ.pr_universes Level.pr u)
+let ppnamedcontextval e =
+  pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e))
 
 let ppenv e = pp
-  (str "[" ++ pr_named_context_of e ++ str "]" ++ spc() ++
-   str "[" ++ pr_rel_context e (rel_context e) ++ str "]")
+  (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++
+   str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]")
 
 let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x))
 
-let ppinsts c = pp (pr_instance_gmap c)
-
 let ppobj obj = Format.print_string (Libobject.object_tag obj)
 
 let cnt = ref 0
@@ -161,12 +241,13 @@ let cast_kind_display k =
   | VMcast -> "VMcast"
   | DEFAULTcast -> "DEFAULTcast"
   | REVERTcast -> "REVERTcast"
+  | NATIVEcast -> "NATIVEcast"
 
 let constr_display csr =
   let rec term_display c = match kind_of_term c with
   | Rel n -> "Rel("^(string_of_int n)^")"
   | Meta n -> "Meta("^(string_of_int n)^")"
-  | Var id -> "Var("^(string_of_id id)^")"
+  | Var id -> "Var("^(Id.to_string id)^")"
   | Sort s -> "Sort("^(sort_display s)^")"
   | Cast (c,k, t) ->
       "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")"
@@ -178,13 +259,14 @@ let constr_display csr =
       "LetIn("^(name_display na)^","^(term_display b)^","
       ^(term_display t)^","^(term_display c)^")"
   | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n"
-  | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")"
-  | Const c -> "Const("^(string_of_con c)^")"
-  | Ind (sp,i) ->
-      "MutInd("^(string_of_mind sp)^","^(string_of_int i)^")"
-  | Construct ((sp,i),j) ->
+  | Evar (e,l) -> "Evar("^(string_of_existential e)^","^(array_display l)^")"
+  | Const (c,u) -> "Const("^(string_of_con c)^","^(universes_display u)^")"
+  | Ind ((sp,i),u) ->
+      "MutInd("^(string_of_mind sp)^","^(string_of_int i)^","^(universes_display u)^")"
+  | Construct (((sp,i),j),u) ->
       "MutConstruct(("^(string_of_mind sp)^","^(string_of_int i)^"),"
-      ^(string_of_int j)^")"
+      ^","^(universes_display u)^(string_of_int j)^")"
+  | Proj (p, c) -> "Proj("^(string_of_con (Projection.constant p))^","^term_display c ^")"
   | Case (ci,p,c,bl) ->
       "MutCase(<abs>,"^(term_display p)^","^(term_display c)^","
       ^(array_display bl)^")"
@@ -208,19 +290,28 @@ let constr_display csr =
        (fun x i -> (term_display x)^(if not(i="") then (";"^i) else ""))
        v "")^"|]"
 
+  and univ_display u =
+    incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ pr_uni u ++ fnl ())
+
+  and level_display u =
+    incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ())
+
   and sort_display = function
     | Prop(Pos) -> "Prop(Pos)"
     | Prop(Null) -> "Prop(Null)"
-    | Type u ->
-	incr cnt; pp (str "with " ++ int !cnt ++ pr_uni u ++ fnl ());
+    | Type u -> univ_display u;
 	"Type("^(string_of_int !cnt)^")"
 
+  and universes_display l = 
+    Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="")
+        then (" "^i) else "")) (Instance.to_array l) ""
+
   and name_display = function
-    | Name id -> "Name("^(string_of_id id)^")"
+    | Name id -> "Name("^(Id.to_string id)^")"
     | Anonymous -> "Anonymous"
 
   in
-    msg (str (term_display csr) ++fnl ())
+  Pp.pp (str (term_display csr) ++fnl ()); Pp.pp_flush ()
 
 open Format;;
 
@@ -228,14 +319,14 @@ let print_pure_constr csr =
   let rec term_display c = match kind_of_term c with
   | Rel n -> print_string "#"; print_int n
   | Meta n -> print_string "Meta("; print_int n; print_string ")"
-  | Var id -> print_string (string_of_id id)
+  | 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 (string_of_id id);
+      print_string"("; print_string (Id.to_string id);
       print_string ":"; box_display t;
       print_string ")"; print_cut();
       box_display c; close_box()
@@ -256,22 +347,31 @@ let print_pure_constr csr =
       box_display c;
       Array.iter (fun x -> print_space (); box_display x) l;
       print_string ")"
-  | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{";
+  | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{";
       Array.iter (fun x -> print_space (); box_display x) l;
       print_string"}"
-  | Const c -> print_string "Cons(";
+  | Const (c,u) -> print_string "Cons(";
       sp_con_display c;
+      print_string ","; universes_display u;
       print_string ")"
-  | Ind (sp,i) ->
+  | Proj (p,c') -> print_string "Proj(";
+      sp_con_display (Projection.constant p);
+      print_string ",";
+      box_display c';
+      print_string ")"
+  | Ind ((sp,i),u) ->
       print_string "Ind(";
       sp_display sp;
       print_string ","; print_int i;
+      print_string ","; universes_display u;
       print_string ")"
-  | Construct ((sp,i),j) ->
+  | Construct (((sp,i),j),u) ->
       print_string "Constr(";
       sp_display sp;
       print_string ",";
-      print_int i; print_string ","; print_int j; print_string ")"
+      print_int i; print_string ","; print_int j; 
+      print_string ","; universes_display u;
+      print_string ")"
   | Case (ci,p,c,bl) ->
       open_vbox 0;
       print_string "<"; box_display p; print_string ">";
@@ -287,7 +387,7 @@ let print_pure_constr csr =
       print_string "Fix("; print_int i; print_string ")";
       print_cut();
       open_vbox 0;
-      let rec print_fix () =
+      let print_fix () =
         for k = 0 to (Array.length tl) - 1 do
 	  open_vbox 0;
 	  name_display lna.(k); print_string "/";
@@ -301,7 +401,7 @@ let print_pure_constr csr =
       print_string "CoFix("; print_int i; print_string ")";
       print_cut();
       open_vbox 0;
-      let rec print_fix () =
+      let print_fix () =
         for k = 0 to (Array.length tl) - 1 do
           open_vbox 1;
 	  name_display lna.(k);  print_cut(); print_string ":";
@@ -313,6 +413,9 @@ let print_pure_constr csr =
 
   and box_display c = open_hovbox 1; term_display c; close_box()
 
+  and universes_display u =
+    Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u)
+
   and sort_display = function
     | Prop(Pos) -> print_string "Set"
     | Prop(Null) -> print_string "Prop"
@@ -320,13 +423,13 @@ let print_pure_constr csr =
 	print_string "Type("; pp (pr_uni u); print_string ")"; close_box()
 
   and name_display = function
-    | Name id -> print_string (string_of_id id)
+    | 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 (List.map string_of_id (repr_dirpath dir)) with
+      match List.rev_map Id.to_string (DirPath.repr dir) with
           ("Top"::l)-> l
 	| ("Coq"::_::l) -> l
 	| l             -> l
@@ -335,7 +438,7 @@ let print_pure_constr csr =
   and sp_con_display sp =
 (*    let dir,l = decode_kn sp in
     let ls =
-      match List.rev (List.map string_of_id (repr_dirpath dir)) with
+      match List.rev_map Id.to_string (DirPath.repr dir) with
           ("Top"::l)-> l
 	| ("Coq"::_::l) -> l
 	| l             -> l
@@ -351,43 +454,29 @@ let print_pure_constr csr =
 
 let ppfconstr c = ppconstr (Closure.term_of_fconstr c)
 
-let pploc x = let (l,r) = unloc x in
+let pploc x = let (l,r) = Loc.unloc x in
   print_string"(";print_int l;print_string",";print_int r;print_string")"
 
-(* extendable tactic arguments *)
-let rec pr_argument_type = function
-  (* Basic types *)
-  | BoolArgType -> str"bool"
-  | IntArgType -> str"int"
-  | IntOrVarArgType -> str"int-or-var"
-  | StringArgType -> str"string"
-  | PreIdentArgType -> str"pre-ident"
-  | IntroPatternArgType -> str"intro-pattern"
-  | IdentArgType true -> str"ident"
-  | IdentArgType false -> str"pattern_ident"
-  | VarArgType -> str"var"
-  | RefArgType -> str"ref"
-  (* Specific types *)
-  | SortArgType -> str"sort"
-  | ConstrArgType -> str"constr"
-  | ConstrMayEvalArgType -> str"constr-may-eval"
-  | QuantHypArgType -> str"qhyp"
-  | OpenConstrArgType _ -> str"open-constr"
-  | ConstrWithBindingsArgType -> str"constr-with-bindings"
-  | BindingsArgType -> str"bindings"
-  | RedExprArgType -> str"redexp"
-  | List0ArgType t -> pr_argument_type t ++ str" list0"
-  | List1ArgType t -> pr_argument_type t ++ str" list1"
-  | OptArgType t -> pr_argument_type t ++ str" opt"
-  | PairArgType (t1,t2) ->
-      str"("++ pr_argument_type t1 ++ str"*" ++ pr_argument_type t2 ++str")"
-  | ExtraArgType s -> str"\"" ++ str s ++ str "\""
-
 let pp_argument_type t = pp (pr_argument_type t)
 
 let pp_generic_argument arg =
   pp(str"<genarg:"++pr_argument_type(genarg_tag arg)++str">")
 
+let prgenarginfo arg =
+  let tpe = pr_argument_type (genarg_tag arg) in
+  let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in
+  try
+    let data = Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg in
+    str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >"
+  with _any ->
+    str "<genarg:" ++ tpe ++ str ">"
+
+let ppgenarginfo arg = pp (prgenarginfo arg)
+
+let ppist ist =
+  let pr id arg = prgenarginfo arg in
+  pp (pridmap pr ist.Geninterp.lfun)
+
 (**********************************************************************)
 (* Vernac-level debugging commands                                    *)
 
@@ -395,7 +484,7 @@ let in_current_context f c =
   let (evmap,sign) =
     try Pfedit.get_current_goal_context ()
     with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in
-  f (Constrintern.interp_constr evmap sign c)
+  f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*)
 
 (* We expand the result of preprocessing to be independent of camlp4
 
@@ -409,87 +498,87 @@ END
 
 open Pcoq
 open Genarg
-open Egrammar
+open Constrarg
+open Egramml
 
 let _ =
   try
-    Vernacinterp.vinterp_add "PrintConstr"
+    Vernacinterp.vinterp_add ("PrintConstr", 0)
       (function
          [c] when genarg_tag c = ConstrArgType && true ->
-           let c = out_gen rawwit_constr c in
+           let c = out_gen (rawwit wit_constr) c in
            (fun () -> in_current_context constr_display c)
        | _ -> failwith "Vernac extension: cannot occur")
   with
     e -> Pp.pp (Errors.print e)
 let _ =
-  extend_vernac_command_grammar "PrintConstr" None
-    [[GramTerminal "PrintConstr";
+  extend_vernac_command_grammar ("PrintConstr", 0) None
+    [GramTerminal "PrintConstr";
       GramNonTerminal
-        (dummy_loc,ConstrArgType,Aentry ("constr","constr"),
-	 Some (Names.id_of_string "c"))]]
+        (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
+	 Some (Names.Id.of_string "c"))]
 
 let _ =
   try
-    Vernacinterp.vinterp_add "PrintPureConstr"
+    Vernacinterp.vinterp_add ("PrintPureConstr", 0)
       (function
          [c] when genarg_tag c = ConstrArgType && true ->
-           let c = out_gen rawwit_constr c in
+           let c = out_gen (rawwit wit_constr) c in
            (fun () -> in_current_context print_pure_constr c)
        | _ -> failwith "Vernac extension: cannot occur")
   with
     e -> Pp.pp (Errors.print e)
 let _ =
-  extend_vernac_command_grammar "PrintPureConstr" None
-    [[GramTerminal "PrintPureConstr";
+  extend_vernac_command_grammar ("PrintPureConstr", 0) None
+    [GramTerminal "PrintPureConstr";
       GramNonTerminal
-        (dummy_loc,ConstrArgType,Aentry ("constr","constr"),
-	 Some (Names.id_of_string "c"))]]
+        (Loc.ghost,ConstrArgType,Aentry ("constr","constr"),
+	 Some (Names.Id.of_string "c"))]
 
 (* Setting printer of unbound global reference *)
 open Names
-open Nameops
 open Libnames
 
 let encode_path loc prefix mpdir suffix id =
   let dir = match mpdir with
     | None -> []
     | Some (mp,dir) ->
-	(repr_dirpath (dirpath_of_string (string_of_mp mp))@
-	repr_dirpath dir) in
+	(DirPath.repr (dirpath_of_string (string_of_mp mp))@
+	DirPath.repr dir) in
   Qualid (loc, make_qualid
-    (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id)
+    (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id)
 
 let raw_string_of_ref loc _ = function
   | ConstRef cst ->
       let (mp,dir,id) = repr_con cst in
-      encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id)
+      encode_path loc "CST" (Some (mp,dir)) [] (Label.to_id id)
   | IndRef (kn,i) ->
       let (mp,dir,id) = repr_mind kn in
-      encode_path loc "IND" (Some (mp,dir)) [id_of_label id]
-	(id_of_string ("_"^string_of_int i))
+      encode_path loc "IND" (Some (mp,dir)) [Label.to_id id]
+	(Id.of_string ("_"^string_of_int i))
   | ConstructRef ((kn,i),j) ->
       let (mp,dir,id) = repr_mind kn in
       encode_path loc "CSTR" (Some (mp,dir))
-	[id_of_label id;id_of_string ("_"^string_of_int i)]
-	(id_of_string ("_"^string_of_int j))
+	[Label.to_id id;Id.of_string ("_"^string_of_int i)]
+	(Id.of_string ("_"^string_of_int j))
   | VarRef id ->
       encode_path loc "SECVAR" None [] id
 
 let short_string_of_ref loc _ = function
   | VarRef id -> Ident (loc,id)
-  | ConstRef cst -> Ident (loc,id_of_label (pi3 (repr_con cst)))
-  | IndRef (kn,0) -> Ident (loc,id_of_label (pi3 (repr_mind kn)))
+  | ConstRef cst -> Ident (loc,Label.to_id (pi3 (repr_con cst)))
+  | IndRef (kn,0) -> Ident (loc,Label.to_id (pi3 (repr_mind kn)))
   | IndRef (kn,i) ->
-      encode_path loc "IND" None [id_of_label (pi3 (repr_mind kn))]
-        (id_of_string ("_"^string_of_int i))
+      encode_path loc "IND" None [Label.to_id (pi3 (repr_mind kn))]
+        (Id.of_string ("_"^string_of_int i))
   | ConstructRef ((kn,i),j) ->
       encode_path loc "CSTR" None
-        [id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)]
-        (id_of_string ("_"^string_of_int j))
+        [Label.to_id (pi3 (repr_mind kn));Id.of_string ("_"^string_of_int i)]
+        (Id.of_string ("_"^string_of_int j))
 
 (* Anticipate that printers can be used from ocamldebug and that 
    pretty-printer should not make calls to the global env since ocamldebug
    runs in a different process and does not have the proper env at hand *)
-let _ = Constrextern.in_debugger := true
+let _ = Flags.in_debugger := true
 let _ = Constrextern.set_extern_reference
   (if !rawdebug then raw_string_of_ref else short_string_of_ref)
diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml
index 59545d8a..4578a3b3 100644
--- a/dev/vm_printers.ml
+++ b/dev/vm_printers.ml
@@ -13,7 +13,7 @@ let ppripos (ri,pos) =
 	("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n")
   | Reloc_const _ ->
       print_string "structured constant\n"
-  | Reloc_getglobal kn ->
+  | Reloc_getglobal (kn,_) ->
       print_string ("getglob "^(string_of_con kn)^"\n"));
    print_flush ()
 
@@ -30,11 +30,11 @@ let ppsort = function
 
 let print_idkey idk =
   match idk with
-  | ConstKey sp ->
+  | ConstKey (sp,_) ->
       print_string "Cons(";
       print_string (string_of_con sp);
       print_string ")"
-  | VarKey id -> print_string (string_of_id id)
+  | VarKey id -> print_string (Id.to_string id)
   | RelKey i -> print_string "~";print_int i
 
 let rec ppzipper z =
@@ -61,7 +61,7 @@ and ppatom a =
   match a with
   | Aid idk -> print_idkey idk
   | Aiddef(idk,_) -> print_string "&";print_idkey idk
-  | Aind(sp,i) ->  print_string "Ind(";
+  | Aind((sp,i),_) ->  print_string "Ind(";
       print_string (string_of_mind sp);
       print_string ","; print_int i;
       print_string ")"
diff --git a/doc/LICENSE b/doc/LICENSE
index 99087480..ada22e66 100644
--- a/doc/LICENSE
+++ b/doc/LICENSE
@@ -8,7 +8,7 @@ forth in the Open Publication License, v1.0 or later (the latest
 version is presently available at http://www.opencontent.org/openpub/).
 Options A and B are *not* elected.
 
-The Coq Tutorial is a work by Gérard Huet, Gilles Kahn and Christine
+The Coq Tutorial is a work by Gérard Huet, Gilles Kahn and Christine
 Paulin-Mohring. All documents (the LaTeX source and the PostScript,
 PDF and html outputs) are copyright (c) INRIA 1999-2006. The material
 connected to the Coq Tutorial may be distributed only subject to the
@@ -25,7 +25,7 @@ the PostScript, PDF and html outputs) are copyright (c) INRIA
 distributed under the terms of the Lesser General Public License
 version 2.1 or later. 
 
-The FAQ (Coq for the Clueless) is a work by Pierre Castéran, Hugo
+The FAQ (Coq for the Clueless) is a work by Pierre Castéran, Hugo
 Herbelin, Florent Kirchner, Benjamin Monate, and Julien Narboux. All
 documents (the LaTeX source and the PostScript, PDF and html outputs)
 are copyright (c) INRIA 2004-2006. The material connected to the FAQ
@@ -36,7 +36,7 @@ http://www.opencontent.org/openpub/). Options A and B are *not*
 elected.
 
 The Tutorial on [Co-]Inductive Types in Coq is a work by Pierre
-Castéran and Eduardo Gimenez. All related documents (the LaTeX and
+Castéran and Eduardo Gimenez. All related documents (the LaTeX and
 BibTeX sources and the PostScript, PDF and html outputs) are copyright
 (c) INRIA 1997-2006. The material connected to the Tutorial on
 [Co-]Inductive Types in Coq may be distributed only subject to the
diff --git a/doc/common/styles/html/coqremote/footer.html b/doc/common/styles/html/coqremote/footer.html
index ff38ba8a..23dfccb6 100644
--- a/doc/common/styles/html/coqremote/footer.html
+++ b/doc/common/styles/html/coqremote/footer.html
@@ -21,9 +21,9 @@
   <div id="footer">
     <div id="nav-footer">
       <ul class="links-menu-footer">
-        <li><a href="mailto:www-coq_@_lix.polytechnique.fr">webmaster</a></li>
-        <li><a href="http://validator.w3.org/check?uri=referer">xhtml valid</a></li>
-        <li><a href="http://jigsaw.w3.org/css-validator/check/referer">CSS valid</a></li>
+        <li><a href="mailto:coq-www_@_inria.fr">webmaster</a></li>
+        <li><a href="http://validator.w3.org/">xhtml valid</a></li>
+        <li><a href="http://jigsaw.w3.org/css-validator/">CSS valid</a></li>
       </ul>
     </div>
   </div>
diff --git a/doc/common/styles/html/coqremote/header.html b/doc/common/styles/html/coqremote/header.html
index 891fb328..c6c45091 100644
--- a/doc/common/styles/html/coqremote/header.html
+++ b/doc/common/styles/html/coqremote/header.html
@@ -2,18 +2,16 @@
 <html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
 
 <head>
-<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
-<title>Standard Library | The Coq Proof Assistant</title>
-
-<link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/node/node.css";</style>
+<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+<link rel="shortcut icon" href="/favicon.ico" type="image/x-icon" />
+<link type="text/css" rel="stylesheet" media="all" href="/modules/node/node.css" />
+<link type="text/css" rel="stylesheet" media="all" href="/modules/system/defaults.css" />
+<link type="text/css" rel="stylesheet" media="all" href="/modules/system/system.css" />
+<link type="text/css" rel="stylesheet" media="all" href="/modules/user/user.css" />
+<link type="text/css" rel="stylesheet" media="all" href="/sites/all/themes/coq/style.css" />
+<link type="text/css" rel="stylesheet" media="all" href="/sites/all/themes/coq/coqdoc.css" />
 
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/defaults.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/system/system.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/modules/user/user.css";</style>
-
-<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/style.css";</style>
-<style type="text/css" media="all">@import "http://coq.inria.fr/sites/all/themes/coq/coqdoc.css";</style>
+<title>Standard Library | The Coq Proof Assistant</title>
 
 </head>
 
@@ -23,20 +21,20 @@
   <div id="headertop">
     <div id="nav">
       <ul class="links-menu">
-        <li><a href="http://coq.inria.fr/" class="active">Home</a></li>
-        <li><a href="http://coq.inria.fr/about-coq" title="More about coq">About Coq</a></li>    
-        <li><a href="http://coq.inria.fr/download">Get Coq</a></li>
-        <li><a href="http://coq.inria.fr/documentation">Documentation</a></li>
-        <li><a href="http://coq.inria.fr/community">Community</a></li>
+        <li><a href="/" class="active">Home</a></li>
+        <li><a href="/about-coq" title="More about coq">About Coq</a></li>
+        <li><a href="/download">Get Coq</a></li>
+        <li><a href="/documentation">Documentation</a></li>
+        <li><a href="/community">Community</a></li>
       </ul>
     </div>
   </div>
 
   <div id="header">
     <div id="logoWrapper">
-      <div id="logo"><a href="http://coq.inria.fr/" title="Home"><img src="http://coq.inria.fr/files/barron_logo.png" alt="Home" /></a>
+      <div id="logo"><a href="/" title="Home"><img src="/files/barron_logo.png" alt="Home" /></a>
       </div>
-      <div id="siteName"><a href="http://coq.inria.fr/" title="Home">The Coq Proof Assistant</a>
+      <div id="siteName"><a href="/" title="Home">The Coq Proof Assistant</a>
       </div>
     </div>
   </div>
diff --git a/doc/common/styles/html/simple/header.html b/doc/common/styles/html/simple/header.html
index 14d2f988..c350a8b9 100644
--- a/doc/common/styles/html/simple/header.html
+++ b/doc/common/styles/html/simple/header.html
@@ -1,11 +1,11 @@
-<!DOCTYPE html 
+<!DOCTYPE html
      PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
 
 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
 <head>
-<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/>
-<link rel="stylesheet" href="coqdoc.css" type="text/css"/>
+<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+<link rel="stylesheet" href="coqdoc.css" type="text/css" />
 <title>The Coq Standard Library</title>
 </head>
 
diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex
index cb32adfc..44a0b1d3 100755
--- a/doc/stdlib/Library.tex
+++ b/doc/stdlib/Library.tex
@@ -1,9 +1,11 @@
 \documentclass[11pt]{report}
 
+\usepackage[mathletters]{ucs}
 \usepackage[utf8x]{inputenc}
 \usepackage[T1]{fontenc}
 \usepackage{fullpage}
 \usepackage{amsfonts}
+\usepackage{url}
 \usepackage[color]{../../coqdoc}
 
 \input{../common/version}
diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files
index e69de29b..8b137891 100644
--- a/doc/stdlib/hidden-files
+++ b/doc/stdlib/hidden-files
@@ -0,0 +1 @@
+
diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template
index 833b5c4c..854c786c 100644
--- a/doc/stdlib/index-list.html.template
+++ b/doc/stdlib/index-list.html.template
@@ -3,7 +3,7 @@
 
 <p>Here is a short description of the Coq standard library, which is
 distributed with the system.
-It provides a set of modules directly available 
+It provides a set of modules directly available
 through the <tt>Require Import</tt> command.</p>
 
 <p>The standard library is composed of the following subdirectories:</p>
@@ -12,27 +12,26 @@ through the <tt>Require Import</tt> command.</p>
   <dt> <b>Init</b>:
     The core library (automatically loaded when starting Coq)
   </dt>
-  <dd> 
+  <dd>
     theories/Init/Notations.v
     theories/Init/Datatypes.v
     theories/Init/Logic.v
     theories/Init/Logic_Type.v
+    theories/Init/Nat.v
     theories/Init/Peano.v
     theories/Init/Specif.v
     theories/Init/Tactics.v
     theories/Init/Wf.v
     (theories/Init/Prelude.v)
   </dd>
-  
+
   <dt> <b>Logic</b>:
-      Classical logic and dependent equality
+      Classical logic, dependent equality, extensionality, choice axioms
   </dt>
   <dd>
     theories/Logic/SetIsType.v
-    theories/Logic/Classical_Pred_Set.v
     theories/Logic/Classical_Pred_Type.v
     theories/Logic/Classical_Prop.v
-    theories/Logic/Classical_Type.v
     (theories/Logic/Classical.v)
     theories/Logic/ClassicalFacts.v
     theories/Logic/Decidable.v
@@ -57,8 +56,11 @@ through the <tt>Require Import</tt> command.</p>
     theories/Logic/IndefiniteDescription.v
     theories/Logic/FunctionalExtensionality.v
     theories/Logic/ExtensionalityFacts.v
+    theories/Logic/WeakFan.v
+    theories/Logic/WKL.v
+    theories/Logic/FinFun.v
   </dd>
-    
+
   <dt> <b>Structures</b>:
        Algebraic structures (types with equality, with order, ...).
        DecidableType* and OrderedType* are there only for compatibility.
@@ -83,7 +85,7 @@ through the <tt>Require Import</tt> command.</p>
   <dt> <b>Bool</b>:
        Booleans (basic functions and results)
   </dt>
-  <dd> 
+  <dd>
     theories/Bool/Bool.v
     theories/Bool/BoolEq.v
     theories/Bool/DecBool.v
@@ -92,12 +94,12 @@ through the <tt>Require Import</tt> command.</p>
     theories/Bool/Zerob.v
     theories/Bool/Bvector.v
   </dd>
-    
+
   <dt> <b>Arith</b>:
     Basic Peano arithmetic
   </dt>
-  <dd> 
-    theories/Arith/Arith_base.v
+  <dd>
+    theories/Arith/PeanoNat.v
     theories/Arith/Le.v
     theories/Arith/Lt.v
     theories/Arith/Plus.v
@@ -107,6 +109,7 @@ through the <tt>Require Import</tt> command.</p>
     theories/Arith/Between.v
     theories/Arith/Peano_dec.v
     theories/Arith/Compare_dec.v
+    (theories/Arith/Arith_base.v)
     (theories/Arith/Arith.v)
     theories/Arith/Min.v
     theories/Arith/Max.v
@@ -173,8 +176,6 @@ through the <tt>Require Import</tt> command.</p>
     theories/ZArith/Zpow_def.v
     theories/ZArith/Zpow_alt.v
     theories/ZArith/Zpower.v
-    theories/ZArith/ZOdiv_def.v
-    theories/ZArith/ZOdiv.v
     theories/ZArith/Zdiv.v
     theories/ZArith/Zquot.v
     theories/ZArith/Zeuclid.v
@@ -206,10 +207,13 @@ through the <tt>Require Import</tt> command.</p>
     theories/QArith/Qminmax.v
   </dd>
 
-  <dt> <b>Numbers</b>: 
+  <dt> <b>Numbers</b>:
     An experimental modular architecture for arithmetic
   </dt>
-    <dt> <b>&nbsp;&nbsp;Prelude</b>: 
+  <dd>
+    <dl>
+    <dt> <b>&nbsp;&nbsp;Prelude</b>:
+    </dt>
     <dd>
     theories/Numbers/BinNums.v
     theories/Numbers/NumPrelude.v
@@ -219,6 +223,7 @@ through the <tt>Require Import</tt> command.</p>
 
     <dt> <b>&nbsp;&nbsp;NatInt</b>:
        Abstract mixed natural/integer/cyclic arithmetic
+    </dt>
     <dd>
     theories/Numbers/NatInt/NZAdd.v
     theories/Numbers/NatInt/NZAddOrder.v
@@ -237,10 +242,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/NatInt/NZGcd.v
     theories/Numbers/NatInt/NZBits.v
     </dd>
-    </dt>
 
-    <dt> <b>&nbsp;&nbsp;Cyclic</b>: 
+    <dt> <b>&nbsp;&nbsp;Cyclic</b>:
        Abstract and 31-bits-based cyclic arithmetic
+    </dt>
     <dd>
     theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
     theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -259,10 +264,10 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Cyclic/Int31/Int31.v
     theories/Numbers/Cyclic/ZModulo/ZModulo.v
     </dd>
-    </dt>
 
-    <dt> <b>&nbsp;&nbsp;Natural</b>: 
+    <dt> <b>&nbsp;&nbsp;Natural</b>:
        Abstract and 31-bits-words-based natural arithmetic
+    </dt>
     <dd>
     theories/Numbers/Natural/Abstract/NAdd.v
     theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -293,10 +298,11 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Natural/BigN/NMake.v
     theories/Numbers/Natural/BigN/NMake_gen.v
     </dd>
-    </dt>
 
-    <dt> <b>&nbsp;&nbsp;Integer</b>: 
-       Abstract and concrete (especially 31-bits-words-based) integer arithmetic
+    <dt> <b>&nbsp;&nbsp;Integer</b>:
+       Abstract and concrete (especially 31-bits-words-based) integer
+       arithmetic
+    </dt>
     <dd>
     theories/Numbers/Integer/Abstract/ZAdd.v
     theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -323,32 +329,32 @@ through the <tt>Require Import</tt> command.</p>
     theories/Numbers/Integer/BigZ/BigZ.v
     theories/Numbers/Integer/BigZ/ZMake.v
     </dd>
-    </dt>
 
     <dt><b>&nbsp;&nbsp;Rational</b>:
        Abstract and 31-bits-words-based rational arithmetic
+    </dt>
     <dd>
     theories/Numbers/Rational/SpecViaQ/QSig.v
     theories/Numbers/Rational/BigQ/BigQ.v
     theories/Numbers/Rational/BigQ/QMake.v
     </dd>
-    </dt>
-  </dt>
-  
+    </dl>
+  </dd>
+
   <dt> <b>Relations</b>:
        Relations (definitions and basic results)
   </dt>
-  <dd> 
+  <dd>
     theories/Relations/Relation_Definitions.v
     theories/Relations/Relation_Operators.v
     theories/Relations/Relations.v
     theories/Relations/Operators_Properties.v
   </dd>
-    
+
   <dt> <b>Sets</b>:
        Sets (classical, constructive, finite, infinite, powerset, etc.)
   </dt>
-  <dd> 
+  <dd>
     theories/Sets/Classical_sets.v
     theories/Sets/Constructive_sets.v
     theories/Sets/Cpo.v
@@ -372,32 +378,39 @@ through the <tt>Require Import</tt> command.</p>
     theories/Sets/Relations_3.v
     theories/Sets/Uniset.v
   </dd>
-    
+
   <dt> <b>Classes</b>:
-  <dd> 
+  </dt>
+  <dd>
     theories/Classes/Init.v
     theories/Classes/RelationClasses.v
     theories/Classes/Morphisms.v
     theories/Classes/Morphisms_Prop.v
     theories/Classes/Morphisms_Relations.v
     theories/Classes/Equivalence.v
+    theories/Classes/CRelationClasses.v
+    theories/Classes/CMorphisms.v
+    theories/Classes/CEquivalence.v
     theories/Classes/EquivDec.v
     theories/Classes/SetoidTactics.v
     theories/Classes/SetoidClass.v
     theories/Classes/SetoidDec.v
     theories/Classes/RelationPairs.v
+    theories/Classes/DecidableClass.v
   </dd>
 
   <dt> <b>Setoids</b>:
-  <dd> 
+  </dt>
+  <dd>
     theories/Setoids/Setoid.v
   </dd>
-    
+
   <dt> <b>Lists</b>:
     Polymorphic lists, Streams (infinite sequences)
   </dt>
-  <dd> 
+  <dd>
     theories/Lists/List.v
+    theories/Lists/ListDec.v
     theories/Lists/ListSet.v
     theories/Lists/SetoidList.v
     theories/Lists/SetoidPermutation.v
@@ -413,13 +426,14 @@ through the <tt>Require Import</tt> command.</p>
     theories/Vectors/Fin.v
     theories/Vectors/VectorDef.v
     theories/Vectors/VectorSpec.v
+    theories/Vectors/VectorEq.v
     (theories/Vectors/Vector.v)
   </dd>
 
   <dt> <b>Sorting</b>:
     Axiomatizations of sorts
   </dt>
-  <dd> 
+  <dd>
     theories/Sorting/Heap.v
     theories/Sorting/Permutation.v
     theories/Sorting/Sorting.v
@@ -432,7 +446,7 @@ through the <tt>Require Import</tt> command.</p>
   <dt> <b>Wellfounded</b>:
        Well-founded Relations
   </dt>
-  <dd> 
+  <dd>
     theories/Wellfounded/Disjoint_Union.v
     theories/Wellfounded/Inclusion.v
     theories/Wellfounded/Inverse_Image.v
@@ -500,11 +514,11 @@ through the <tt>Require Import</tt> command.</p>
     theories/Strings/Ascii.v
     theories/Strings/String.v
   </dd>
-    
+
   <dt> <b>Reals</b>:
     Formalization of real numbers
   </dt>
-  <dd> 
+  <dd>
     theories/Reals/Rdefinitions.v
     theories/Reals/Raxioms.v
     theories/Reals/RIneq.v
@@ -566,14 +580,13 @@ through the <tt>Require Import</tt> command.</p>
     theories/Reals/SeqSeries.v
     theories/Reals/Sqrt_reg.v
     theories/Reals/Rlogic.v
-    theories/Reals/LegacyRfield.v
     (theories/Reals/Reals.v)
   </dd>
-    
+
   <dt> <b>Program</b>:
     Support for dependently-typed programming.
   </dt>
-  <dd> 
+  <dd>
     theories/Program/Basics.v
     theories/Program/Wf.v
     theories/Program/Subset.v
diff --git a/doc/stdlib/make-library-files b/doc/stdlib/make-library-files
deleted file mode 100755
index c071c4a2..00000000
--- a/doc/stdlib/make-library-files
+++ /dev/null
@@ -1,36 +0,0 @@
-#!/bin/sh
-
-# Needs COQSRC and GALLINA set
-
-# On garde la liste de tous les *.v avec dates dans library.files.ls
-# Si elle a change depuis la derniere fois ou library.files n'existe pas
-# on fabrique des .g (si besoin) et la liste library.files dans 
-# l'ordre de ls -tr des *.vo
-# Ce dernier trie les fichiers dans l'ordre inverse de leur date de création
-# En supposant que make fait son boulot, ca fait un tri topologique du
-# graphe des dépendances
-
-LIBDIRS="Arith PArith NArith ZArith Reals Logic Bool Lists Relations Sets Sorting Wellfounded Setoids Program Classes Numbers"
-
-rm -f library.files.ls.tmp
-(cd $COQSRC/theories; find $LIBDIR -name "*.v" -ls) > library.files.ls.tmp
-if ! test -e library.files || ! cmp library.files.ls library.files.ls.tmp; then
-  mv -f library.files.ls.tmp library.files.ls
-  rm -f library.files; touch library.files
-  ABSOLUTE=`pwd`/library.files
-  cd $COQSRC/theories
-  echo $LIBDIRS
-  for rep in $LIBDIRS ; do
-    (cd $rep
-     echo $rep/intro.tex >> $ABSOLUTE
-     VOFILES=`ls -tr *.vo`
-     for file in $VOFILES ; do
-       VF=`basename $file \.vo`
-       if [ \( ! -e $VF.g \) -o \( $VF.v -nt $VF.g \) ] ; then
-          $GALLINA $VF.v
-       fi
-       echo $rep/$VF.g >> $ABSOLUTE
-     done
-    )
-  done
-fi
diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index
index 1a70567f..43802efa 100755
--- a/doc/stdlib/make-library-index
+++ b/doc/stdlib/make-library-index
@@ -6,17 +6,14 @@ FILE=$1
 HIDDEN=$2
 
 cp -f $FILE.template tmp
-echo -n Building file index-list.prehtml ...
+echo -n "Building file index-list.prehtml... "
 
 #LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings"
-LIBDIRS=`find theories/* -type d | sed -e "s:^theories/::"`
+LIBDIRS=`find theories/* -type d ! -name .coq-native | sed -e "s:^theories/::"`
 
 for k in $LIBDIRS; do
     i=theories/$k
-    echo $i
-    
     d=`basename $i`
-    if [ "$d" != "CVS" ]; then
       ls $i | grep -q \.v'$'
       if [ $? = 0 ]; then
 	for j in $i/*.v; do
@@ -46,7 +43,6 @@ for k in $LIBDIRS; do
             fi
 	done
       fi
-    fi
     rm -f tmp2
     sed -e "s/#$d#//" tmp > tmp2
     mv -f tmp2 tmp
diff --git a/doc/whodidwhat/whodidwhat-8.2update.tex b/doc/whodidwhat/whodidwhat-8.2update.tex
new file mode 100644
index 00000000..4f4f0e95
--- /dev/null
+++ b/doc/whodidwhat/whodidwhat-8.2update.tex
@@ -0,0 +1,303 @@
+\documentclass{article}
+
+\usepackage{fullpage}
+\usepackage[utf8]{inputenc}
+\usepackage{t1enc}
+
+\begin{document}
+
+\title{Who did what in the Coq archive?}
+
+\author{The Coq development team}
+
+\maketitle
+
+\centerline{(updated for Coq 8.2)}
+
+\section{The Calculus of Inductive Constructions}
+
+\begin{itemize}
+\item The Calculus of Constructions
+  \begin{itemize}
+  \item Core type-checker: Gérard Huet and Thierry Coquand with
+    optimizations by Chet Murthy, Bruno Barras
+  \item Head reduction functions: Gérard Huet, Christine Paulin, Bruno Barras
+  \end{itemize}
+\item Conversion and reduction
+  \begin{itemize}
+  \item Lazy conversion machine: Bruno Barras
+  \item Transparency/opacity: Bruno Barras
+  \item Bytecode-based conversion: Benjamin Grégoire
+  \item Binary-words retroknowledge: Arnaud Spiwack 
+  \end{itemize}
+\item The universe hierarchy
+  \begin{itemize}
+  \item Floating universes: Gérard Huet, with contributions from Bruno Barras
+  \item Algebraic universes: Hugo Herbelin
+  \end{itemize}
+\item Mutual inductive types and recursive definitions
+  \begin{itemize}
+  \item Type-checking: Christine Paulin
+  \item Positivity condition: Christine Paulin
+  \item Guardness condition for fixpoints: Christine Paulin;
+    extensions by Eduardo Gimenez and Bruno Barras
+  \item Recursively non-uniform parameters: Christine Paulin
+  \item Sort-polymorphism of inductive types: Hugo Herbelin
+  \end{itemize}
+\item Local definitions: Hugo Herbelin
+\item Mutual coinductive types and corecursive definitions: Eduardo Gimenez
+\item Module system
+  \begin{itemize}
+  \item Core system: Jacek Chrz\k{a}szcz
+  \item Inlining: Claudio Sacerdoti Coen and Élie Soubiran
+  \item Module inclusion: Élie Soubiran
+  \item Functorial signature application: Élie Soubiran
+  \item Transparent name space: Élie Soubiran
+  \item Resolution of qualified names: Hugo Herbelin
+  \end{itemize}
+\item Minimalist stand-alone type-checker (\texttt{coqchk}): Bruno Barras
+\end{itemize}
+
+\section{Specification language}
+
+\begin{itemize}
+\item Sections: Gilles Dowek with extra contributions by Gérard
+  Huet, Chet Murthy, Hugo Herbelin
+\item The \texttt{Russell} specifications language, proof obligations (\texttt{Program}): Matthieu Sozeau
+\item Type inference: Chet Murthy, with extra contributions by Bruno
+  Barras, Hugo Herbelin and Matthieu Sozeau
+\item Pattern-matching: Hugo Herbelin on top of a first version by
+  Cristina Cornes
+\item Implicit arguments: Amokrane Saïbi, with extensions by Hugo
+  Herbelin and Matthieu Sozeau
+\item Coercions: Amokrane Saïbi
+\item Records: Amokrane Saïbi with extensions by Arnaud Spiwack and
+  Matthieu Sozeau
+\item Canonical structures: Amokrane Saïbi
+\item Type classes: Matthieu Sozeau
+\item Functional schemes (\texttt{Function}, \texttt{Functional Scheme}, ...): Julien Forest and Pierre Courtieu (preliminary version by Yves Bertot)
+\item Generation of induction schemes: Christine Paulin, Vincent
+  Siles, Matthieu Sozeau
+ \end{itemize}
+
+\section{Tactics}
+
+\subsection{General tactic support}
+
+\begin{itemize}
+\item Proof engine: Chet Murthy (first version by Thierry Coquand)
+\item Ltac: David Delahaye, with extensions by Hugo Herbelin, Bruno Barras, ...
+\item Tactic notations: Hugo Herbelin (first version by Chet Murthy)
+\item Main tactic unification procedure: Chet Murthy with
+  contributions from Hugo Herbelin and Matthieu Sozeau
+\item Mathematical-style language (C-Zar): Pierre Corbineau
+\item Communication with external tools (\texttt{external}): Hugo Herbelin
+
+\end{itemize}
+
+\subsection{Predefined tactics}
+
+\begin{itemize}
+\item Basic tactics (\texttt{intro}, \texttt{apply},
+  \texttt{assumption}, \texttt{exact}): Thierry Coquand, with further
+  collective extensions
+\item Reduction tactics: Christine Paulin (\texttt{simpl}), Bruno
+  Barras (\texttt{cbv}, \texttt{lazy}), ...
+\item Tacticals: Thierry Coquand, Chet Murthy, Eduardo Gimenez, ...
+\item Induction: Christine Paulin (\texttt{elim}, \texttt{case}), Hugo Herbelin (\texttt{induction}, \texttt{destruct}
+\item Refinement (\texttt{refine}): Jean-Christophe Filliâtre
+\item Introduction patterns: Eduardo Gimenez with collective extensions
+\item Forward reasoning: Hugo Herbelin (\texttt{assert}, \texttt{apply in}), Pierre Letouzey (\texttt{specialize}, initial version by Amy Felty)
+\item Rewriting tactics (\texttt{rewrite}): basic version by Christine Paulin,
+  extensions by Jean-Christophe Filliâtre and Pierre Letouzey
+\item Tactics about equivalence properties (\texttt{reflexivity},
+  \texttt{symmetry}, \texttt{transitivity}): Christine Paulin (?),
+\item Equality tactics (\texttt{injection}/\texttt{discriminate}):
+  Cristina Cornes
+\item Inversion tactics (\texttt{inversion}): Cristina Cornes, Chet Murthy
+\item Setoid rewriting: Matthieu Sozeau (first version by Clément
+  Renard, second version by Claudio Sacerdoti Coen), contributions
+  from Nicolas Tabareau
+\item Decision of equality: Eduardo Gimenez
+\item Basic Ltac-level tactics: Pierre Letouzey, Matthieu Sozeau,
+  Evgeny Makarov
+\end{itemize}
+
+\subsection{General automation tactics}
+
+\begin{itemize}
+\item Resolution (\texttt{auto}, \texttt{trivial}): Christine Paulin
+  with extensions from Chet Murthy, Eduardo Gimenez, Patrick
+  Loiseleur (hint bases), Matthieu Sozeau
+\item Resolution with existential variables (\texttt{eauto}): Chet Murthy, Jean-Christophe Filliâtre, with extensions from Matthieu Sozeau
+\item Automatic rewriting (\texttt{autorewrite}): David Delahaye
+\end{itemize}
+
+\subsection{Domain-specific decision tactics}
+
+\begin{itemize}
+\item Congruence closure (\texttt{cc}): Pierre Corbineau
+\item Decision of first-order logic (\texttt{firstorder}): Pierre Corbineau
+\item Simplification of polynomial fractions (\texttt{field}): Laurent
+  Théry and Benjamin Grégoire (first version by David Delahaye and
+  Micaela Mayero)
+\item Simplification of polynomial expressions (\texttt{ring}): Assia
+  Mahboubi, Bruno Barras and Benjamin Grégoire (first version by
+  Samuel Boutin, second version by Patrick Loiseleur)
+\item Decision of systems of linear inequations: Frédéric Besson
+  (\texttt{psatzl}); Loïc Pottier (\texttt{fourier})
+\item Decision of systems of linear inequations over integers:
+  Frédéric Besson (\texttt{lia}); Pierre Crégut (\texttt{omega} and
+  \texttt{romega})
+\item (Partial) decision of systems of polynomical inequations
+  (\texttt{sos}, \texttt{psatz}): Frédéric Besson, with generalization
+  over arbitrary rings by Evgeny Makarov; uses HOL-Light interface to
+  \texttt{csdp} by John Harrisson
+\item Decision/simplification of intuitionistic propositional logic:
+  David Delahaye (\texttt{tauto}, \texttt{intuition}, first version by
+  Cesar Mu\~noz, second version by Chet Murthy), with contributions
+  from Judicaël Courant; Pierre Corbineau (\texttt{rtauto})
+\item Decision/simplification of intuition first-order logic: Pierre
+  Corbineau (\texttt{firstorder})
+\end{itemize}
+
+\section{Extra tools}
+
+\begin{itemize}
+\item Program extraction: Pierre Letouzey (first implementation by
+  Benjamin Werner, second by Jean-Christophe Filliâtre)
+\item Export of context to external communication tools (\texttt{dp}):
+  Nicolas Ayache and Jean-Christophe Filliâtre, with contributions by
+  Claude Marché
+\item Export of terms and environments to XML format: Claudio
+  Sacerdoti Coen, with extensions from Cezary Kaliszyk
+\end{itemize}
+
+\section{Environment management}
+
+\begin{itemize}
+\item Separate compilation: initiated by Chet Murthy
+\item Import/Export: initiated by Chet Murthy
+\item Options management: Hugo Herbelin with contributions by Arnaud Spiwack
+\item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu
+\item Searching: Hugo Herbelin, Yves Bertot
+\item Whelp suppport: Hugo Herbelin
+\end{itemize}
+
+\section{Parsing and printing}
+
+\begin{itemize}
+\item General parsing support: Chet Murthy, Bruno Barras, Daniel de Rauglaudre
+\item General printing support: Chet Murthy, Jean-Christophe Filliâtre
+\item Lexing: Daniel de Rauglaudre
+\item Support for UTF-8: Hugo Herbelin, with contributions from Alexandre Miquel
+\item Numerical notations: Hugo Herbelin, Patrick Loiseleur, Micaela Mayero
+\item String notations: Hugo Herbelin
+\item New ``V8'' syntax: Bruno Barras, Hugo Herbelin with contributions by Olivier Desmettre
+\item Abbreviations: Chet Murthy
+\item Notations: Chet Murthy, Hugo Herbelin
+\end{itemize}
+
+\section{Libraries}
+
+\begin{itemize}
+\item Init: collective (initiated by Christine Paulin and Gérard Huet)
+\item Arith: collective (initiated by Christine Paulin)
+\item ZArith: collective (initiated by Pierre Crégut)
+\item Bool: collective (initiated by Christine Paulin)
+\item NArith: Hugo Herbelin, Pierre Letouzey, Evgeny Makarov (out of
+  initial contibution by Pierre Crégut)
+\item Lists: Pierre Letouzey, Jean-Marc Notin (initiated by Christine Paulin)
+\item Reals: Micaela Mayero (axiomatization and main properties), Olivier Desmettre (convergence, derivability, integrals, trigonometric functions), contributions from Russell O'Connor and Cezary Kaliszyk
+\item Relations: Bruno Barras, Cristina Cornes with contributions from
+  Pierre Castéran
+\item Wellfounded: Bruno Barras, Cristina Cornes
+\item FSets: Pierre Letouzey, from initial work with Jean-Christophe Filliâtre, decision tactic for FSets by Aaron Bohannon
+\item Logic: Christine Paulin, Hugo Herbelin, Bruno Barras
+\item Numbers: Evgeny Makarov (abstractions), Laurent Théry and Benjamin Grégoire (big numbers), Arnaud Spiwack and Pierre Letouzey (word-based arithmetic)
+\item Classes: Matthieu Sozeau
+\item QArith: Pierre Letouzey, with contributions from Russell O'Connor
+\item Setoid: Matthieu Sozeau (first version by Clément Renard, second version by Claudio Sacerdoti Coen)
+\item Sets: Gilles Kahn and Gérard Huet
+\item Sorting: Gérard Huet
+\item Strings: Laurent Théry
+\item Program: Matthieu Sozeau
+\item Unicode: Claude Marché
+\end{itemize}
+
+\section{Commands}
+
+\begin{itemize}
+\item Batch compiler (\texttt{coqc}):  Chet Murthy (?)
+\item Compilation dependency calculator (\texttt{coqdep}):
+  Jean-Christophe Filliâtre
+\item Statistic tool (\texttt{coqwc}): Jean-Christophe Filliâtre
+\item Simple html presentation tool (\texttt{gallina}) (deprecated): Jean-Christophe Filliâtre
+\item Auto-maker (\texttt{coq\_makefile}): Jean-Christophe Filliâtre,
+  with contributions from Judicaël Courant
+\item LaTeX presentation tool (\texttt{coq-tex}): Jean-Christophe Filliâtre
+\item Multi-purpose presentation tool (\texttt{coqdoc}): Jean-Christophe Filliâtre with extensions from
+  Matthieu Sozeau, Jean-Marc Notin, Hugo Herbelin
+\item Interactive toplevel (\texttt{coqtop}): Jean-Christophe Filliâtre (?)
+\item Custom toplevel builder (\texttt{coqmktop}): Jean-Christophe Filliâtre (?)
+\end{itemize}
+
+\section{Graphical interfaces}
+
+\begin{itemize}
+\item Support for {\em PCoq}: Yves Bertot with contributions by
+  Laurence Rideau and Loïc Pottier; additional support for {\em TmEgg}
+  by Lionel Mamane
+\item Support for {\em Proof General}: Pierre Courtieu
+\item {\em CoqIDE}: Benjamin Monate with contributions from
+  Jean-Christophe Filliâtre, Claude Marché, Pierre Letouzey, Julien
+  Narboux, Hugo Herbelin, Pierre Corbineau; uses the Cameleon library
+  by Maxence Guesdon
+\end{itemize}
+
+\section{Architecture}
+
+\begin{itemize}
+\item Functional-kernel-based architecture: Jean-Christophe Filliâtre
+\item Extensible objects and summaries: Chet Murthy
+\item Hash-consing: Bruno Barras
+\item Error locations: Jean-Christophe Filliâtre, Bruno Barras, Hugo Herbelin
+\item Existential variables engine: Chet Murthy with a revision by
+  Bruno Barras and extensions by Clément Renard and Hugo Herbelin
+\end{itemize}
+
+\section{Development tools}
+
+\begin{itemize}
+\item Makefile's: Chet Murthy, Jean-Christophe Filliâtre, Judicaël
+  Courant, Lionel Mamane, Pierre Corbineau, Pierre Letouzey
+\item Debugging: Jean-Christophe Filliâtre with contributions from Jacek Chrz\k{a}szcz, Hugo Herbelin, Bruno Barras, ...
+\item ML quotations: David Delahaye and Daniel de Rauglaudre
+\item ML tactic and vernacular extensions: Hugo Herbelin (first version by Chet Murthy)
+\item Test suite: collective content, initiated by Jean-Christophe Filliâtre with further extensions by Hugo Herbelin, Jean-Marc Notin
+\end{itemize}
+
+\section{Documentation}
+
+\begin{itemize}
+
+\item Reference Manual: collective, layout by Patrick Loiseleur,
+  Claude Marché (former User's Guide in 1991 by Gilles Dowek, Amy
+  Felty, Hugo Herbelin, Gérard Huet, Christine Paulin, Benjamin
+  Werner; initial documentation in 1989 by Thierry Coquand, Gilles
+  Dowek, Gérard Huet, Christine Paulin),
+\item Basic tutorial: Gérard Huet, Gilles Kahn, Christine Paulin
+\item Tutorial on recursive types: Eduardo Gimenez with updates by Pierre Castéran
+\item FAQ: Hugo Herbelin, Julien Narboux, Florent Kirchner
+\end{itemize}
+
+\section{Features discontinued by lack of support}
+
+\begin{itemize}
+\item Searching modulo isomorphism: David Delahaye
+\item Explanation of proofs in pseudo-natural language: Yann Coscoy
+\end{itemize}
+
+Errors may have been inopportunely introduced, please report them to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr
+
+\end{document}
diff --git a/doc/whodidwhat/whodidwhat-8.3update.tex b/doc/whodidwhat/whodidwhat-8.3update.tex
new file mode 100644
index 00000000..0a073781
--- /dev/null
+++ b/doc/whodidwhat/whodidwhat-8.3update.tex
@@ -0,0 +1,312 @@
+\documentclass{article}
+
+\usepackage{fullpage}
+\usepackage[utf8]{inputenc}
+\usepackage{t1enc}
+
+\begin{document}
+
+\title{Who did what in the Coq archive?}
+
+\author{The Coq development team}
+
+\maketitle
+
+\centerline{(updated for Coq 8.3)}
+
+\section{The Calculus of Inductive Constructions}
+
+\begin{itemize}
+\item The Calculus of Constructions
+  \begin{itemize}
+  \item Core type-checker: Gérard Huet and Thierry Coquand with
+    optimizations by Chet Murthy, Bruno Barras
+  \item Head reduction functions: Gérard Huet, Christine Paulin, Bruno Barras
+  \end{itemize}
+\item Conversion and reduction
+  \begin{itemize}
+  \item Lazy conversion machine: Bruno Barras
+  \item Transparency/opacity: Bruno Barras
+  \item Bytecode-based conversion: Benjamin Grégoire
+  \item Binary-words retroknowledge: Arnaud Spiwack 
+  \end{itemize}
+\item The universe hierarchy
+  \begin{itemize}
+  \item Floating universes: Gérard Huet, with contributions from Bruno Barras
+  \item Algebraic universes: Hugo Herbelin
+  \end{itemize}
+\item Mutual inductive types and recursive definitions
+  \begin{itemize}
+  \item Type-checking: Christine Paulin
+  \item Positivity condition: Christine Paulin
+  \item Guardness condition for fixpoints: Christine Paulin;
+    extensions by Eduardo Gimenez and Bruno Barras
+  \item Recursively non-uniform parameters: Christine Paulin
+  \item Sort-polymorphism of inductive types: Hugo Herbelin
+  \end{itemize}
+\item Local definitions: Hugo Herbelin
+\item Mutual coinductive types and corecursive definitions: Eduardo Gimenez
+\item Module system
+  \begin{itemize}
+  \item Core system: Jacek Chrz\k{a}szcz
+  \item Inlining: Claudio Sacerdoti Coen and Élie Soubiran
+  \item Module inclusion: Élie Soubiran
+  \item Functorial signature application: Élie Soubiran
+  \item Transparent name space: Élie Soubiran
+  \item Resolution of qualified names: Hugo Herbelin
+  \item Operator for nested functor application: Élie Soubiran and
+    Pierre Letouzey
+  \end{itemize}
+\item Minimalist stand-alone type-checker (\texttt{coqchk}): Bruno Barras, with extra support for modules by Élie Soubiran
+\end{itemize}
+
+\section{Specification language}
+
+\begin{itemize}
+\item Sections: Gilles Dowek with extra contributions by Gérard
+  Huet, Chet Murthy, Hugo Herbelin
+\item The \texttt{Russell} specifications language, proof obligations (\texttt{Program}): Matthieu Sozeau
+\item Type inference: Chet Murthy, with extra contributions by Bruno
+  Barras, Hugo Herbelin and Matthieu Sozeau
+\item Pattern-matching: Hugo Herbelin on top of a first version by
+  Cristina Cornes
+\item Implicit arguments: Amokrane Saïbi, with extensions by Hugo
+  Herbelin and Matthieu Sozeau
+\item Coercions: Amokrane Saïbi
+\item Records: Amokrane Saïbi with extensions by Arnaud Spiwack and
+  Matthieu Sozeau
+\item Canonical structures: Amokrane Saïbi
+\item Type classes: Matthieu Sozeau
+\item Functional schemes (\texttt{Function}, \texttt{Functional Scheme}, ...): Julien Forest and Pierre Courtieu (preliminary version by Yves Bertot)
+\item Generation of induction schemes: Christine Paulin, Vincent
+  Siles, Matthieu Sozeau
+ \end{itemize}
+
+\section{Tactics}
+
+\subsection{General tactic support}
+
+\begin{itemize}
+\item Proof engine: Chet Murthy (first version by Thierry Coquand)
+\item Ltac: David Delahaye, with extensions by Hugo Herbelin, Bruno Barras, ...
+\item Tactic notations: Hugo Herbelin (first version by Chet Murthy)
+\item Main tactic unification procedure: Chet Murthy with
+  contributions from Hugo Herbelin and Matthieu Sozeau
+\item Mathematical-style language (C-Zar): Pierre Corbineau
+\item Communication with external tools (\texttt{external}): Hugo Herbelin
+
+\end{itemize}
+
+\subsection{Predefined tactics}
+
+\begin{itemize}
+\item Basic tactics (\texttt{intro}, \texttt{apply},
+  \texttt{assumption}, \texttt{exact}): Thierry Coquand, with further
+  collective extensions
+\item Reduction tactics: Christine Paulin (\texttt{simpl}), Bruno
+  Barras (\texttt{cbv}, \texttt{lazy}), ...
+\item Tacticals: Thierry Coquand, Chet Murthy, Eduardo Gimenez, ...
+\item Induction: Christine Paulin (\texttt{elim}, \texttt{case}), Hugo Herbelin (\texttt{induction}, \texttt{destruct}, {\tt e}-variants of them), Matthieu Sozeau ({\tt dependent destruction}, {\tt dependent induction})
+\item Refinement (\texttt{refine}): Jean-Christophe Filliâtre
+\item Introduction patterns: Eduardo Gimenez with collective extensions
+\item Forward reasoning: Hugo Herbelin (\texttt{assert}, \texttt{apply in}), Pierre Letouzey (\texttt{specialize}, initial version by Amy Felty)
+\item Rewriting tactics (\texttt{rewrite}): basic version by Christine Paulin,
+  extensions by Jean-Christophe Filliâtre ({\tt subst}), Pierre Letouzey (\verb=!=, \verb=?= modifiers) and Matthieu Sozeau (\verb=*=)
+\item Tactics about equivalence properties (\texttt{reflexivity},
+  \texttt{symmetry}, \texttt{transitivity}): Christine Paulin (?),
+  {\tt e}-variants by Hugo Herbelin, type-classes-based generalization to
+  arbitrary appropriate relations by Matthieu Sozeau
+\item Equality tactics (\texttt{injection}/\texttt{discriminate}):
+  Cristina Cornes
+\item Inversion tactics (\texttt{inversion}): Cristina Cornes, Chet Murthy
+\item Setoid rewriting: Matthieu Sozeau (first version by Clément
+  Renard, second version by Claudio Sacerdoti Coen), contributions
+  from Nicolas Tabareau
+\item Decision of equality: Eduardo Gimenez
+\item Basic Ltac-level tactics: Pierre Letouzey, Matthieu Sozeau,
+  Evgeny Makarov, Hugo Herbelin
+\end{itemize}
+
+\subsection{General automation tactics}
+
+\begin{itemize}
+\item Resolution (\texttt{auto}, \texttt{trivial}): Christine Paulin
+  with extensions from Chet Murthy, Eduardo Gimenez, Patrick
+  Loiseleur (hint bases), Matthieu Sozeau
+\item Resolution with existential variables (\texttt{eauto}): Chet Murthy, Jean-Christophe Filliâtre, with extensions from Matthieu Sozeau
+\item Automatic rewriting (\texttt{autorewrite}): David Delahaye
+\end{itemize}
+
+\subsection{Domain-specific decision tactics}
+
+\begin{itemize}
+\item Congruence closure (\texttt{cc}): Pierre Corbineau
+\item Decision of first-order logic (\texttt{firstorder}): Pierre Corbineau
+\item Simplification of polynomial fractions (\texttt{field}): Laurent
+  Théry and Benjamin Grégoire (first version by David Delahaye and
+  Micaela Mayero)
+\item Simplification of polynomial expressions (\texttt{ring}): Assia
+  Mahboubi, Bruno Barras and Benjamin Grégoire (first version by
+  Samuel Boutin, second version by Patrick Loiseleur)
+\item Decision of systems of polynomial equations: Loïc Pottier (\texttt{nsatz})
+\item Decision of systems of linear inequations: Frédéric Besson
+  (\texttt{psatzl}); Loïc Pottier (\texttt{fourier})
+\item Decision of systems of linear inequations over integers:
+  Frédéric Besson (\texttt{lia}); Pierre Crégut (\texttt{omega} and
+  \texttt{romega})
+\item (Partial) decision of systems of polynomical inequations
+  (\texttt{sos}, \texttt{psatz}): Frédéric Besson, with generalization
+  over arbitrary rings by Evgeny Makarov; uses HOL-Light interface to
+  \texttt{csdp} by John Harrisson
+\item Decision/simplification of intuitionistic propositional logic:
+  David Delahaye (\texttt{tauto}, \texttt{intuition}, first version by
+  Cesar Mu\~noz, second version by Chet Murthy), with contributions
+  from Judicaël Courant; Pierre Corbineau (\texttt{rtauto})
+\item Decision/simplification of intuition first-order logic: Pierre
+  Corbineau (\texttt{firstorder})
+\item Reification ({\tt quote}): Patrick Loiseleur, with
+  generalization by Stéphane Glondu
+\end{itemize}
+
+\section{Extra tools}
+
+\begin{itemize}
+\item Program extraction: Pierre Letouzey (first implementation by
+  Benjamin Werner, second by Jean-Christophe Filliâtre)
+\item Export of context to external communication tools (\texttt{dp}):
+  Nicolas Ayache and Jean-Christophe Filliâtre, with contributions by
+  Claude Marché
+\item Export of terms and environments to XML format: Claudio
+  Sacerdoti Coen, with extensions from Cezary Kaliszyk
+\end{itemize}
+
+\section{Environment management}
+
+\begin{itemize}
+\item Separate compilation: initiated by Chet Murthy
+\item Import/Export: initiated by Chet Murthy
+\item Options management: Hugo Herbelin with contributions by Arnaud Spiwack
+\item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu
+\item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech
+\item Whelp suppport: Hugo Herbelin
+\end{itemize}
+
+\section{Parsing and printing}
+
+\begin{itemize}
+\item General parsing support: Chet Murthy, Bruno Barras, Daniel de Rauglaudre
+\item General printing support: Chet Murthy, Jean-Christophe Filliâtre
+\item Lexing: Daniel de Rauglaudre
+\item Support for UTF-8: Hugo Herbelin, with contributions from Alexandre Miquel and Yann Régis-Gianas
+\item Numerical notations: Hugo Herbelin, Patrick Loiseleur, Micaela Mayero
+\item String notations: Hugo Herbelin
+\item New ``V8'' syntax: Bruno Barras, Hugo Herbelin with contributions by Olivier Desmettre
+\item Abbreviations: Chet Murthy
+\item Notations: Chet Murthy, Hugo Herbelin
+\end{itemize}
+
+\section{Libraries}
+
+\begin{itemize}
+\item Init: collective (initiated by Christine Paulin and Gérard Huet)
+\item Arith: collective (initiated by Christine Paulin)
+\item ZArith: collective (initiated by Pierre Crégut)
+\item Bool: collective (initiated by Christine Paulin)
+\item NArith: Hugo Herbelin, Pierre Letouzey, Evgeny Makarov (out of
+  initial contibution by Pierre Crégut)
+\item Lists: Pierre Letouzey, Jean-Marc Notin (initiated by Christine Paulin)
+\item Reals: Micaela Mayero (axiomatization and main properties), Olivier Desmettre (convergence, derivability, integrals, trigonometric functions), contributions from Russell O'Connor, Cezary Kaliszyk, Guillaume Melquiond
+\item Relations: Bruno Barras, Cristina Cornes with contributions from
+  Pierre Castéran
+\item Wellfounded: Bruno Barras, Cristina Cornes
+\item FSets: Pierre Letouzey, from initial work with Jean-Christophe Filliâtre, decision tactic for FSets by Aaron Bohannon
+\item MSets: Pierre Letouzey
+\item Logic: Christine Paulin, Hugo Herbelin, Bruno Barras
+\item Numbers: Evgeny Makarov (abstractions), Laurent Théry and Benjamin Grégoire (big numbers), Arnaud Spiwack and Pierre Letouzey (word-based arithmetic), further extensions by Pierre Letouzey
+\item Classes: Matthieu Sozeau
+\item QArith: Pierre Letouzey, with contributions from Russell O'Connor
+\item Setoid: Matthieu Sozeau (first version by Clément Renard, second version by Claudio Sacerdoti Coen)
+\item Sets: Gilles Kahn and Gérard Huet
+\item Sorting: Gérard Huet with revisions by Hugo Herbelin
+\item Strings: Laurent Théry
+\item Program: Matthieu Sozeau
+\item Unicode: Claude Marché
+\end{itemize}
+
+\section{Commands}
+
+\begin{itemize}
+\item Batch compiler (\texttt{coqc}):  Chet Murthy (?)
+\item Compilation dependency calculator (\texttt{coqdep}):
+  Jean-Christophe Filliâtre
+\item Statistic tool (\texttt{coqwc}): Jean-Christophe Filliâtre
+\item Simple html presentation tool (\texttt{gallina}) (deprecated): Jean-Christophe Filliâtre
+\item Auto-maker (\texttt{coq\_makefile}): Jean-Christophe Filliâtre,
+  with contributions from Judicaël Courant
+\item LaTeX presentation tool (\texttt{coq-tex}): Jean-Christophe Filliâtre
+\item Multi-purpose presentation tool (\texttt{coqdoc}): Jean-Christophe Filliâtre with extensions from
+  Matthieu Sozeau, Jean-Marc Notin, Hugo Herbelin
+\item Interactive toplevel (\texttt{coqtop}): Jean-Christophe Filliâtre (?)
+\item Custom toplevel builder (\texttt{coqmktop}): Jean-Christophe Filliâtre (?)
+\end{itemize}
+
+\section{Graphical interfaces}
+
+\begin{itemize}
+\item Support for {\em PCoq}: Yves Bertot with contributions by
+  Laurence Rideau and Loïc Pottier; additional support for {\em TmEgg}
+  by Lionel Mamane
+\item Support for {\em Proof General}: Pierre Courtieu
+\item {\em CoqIDE}: Benjamin Monate with contributions from
+  Jean-Christophe Filliâtre, Claude Marché, Pierre Letouzey, Julien
+  Narboux, Hugo Herbelin, Pierre Corbineau, Vincent Gross; uses the Cameleon library
+  by Maxence Guesdon
+\end{itemize}
+
+\section{Architecture}
+
+\begin{itemize}
+\item Functional-kernel-based architecture: Jean-Christophe Filliâtre
+\item Extensible objects and summaries: Chet Murthy
+\item Hash-consing: Bruno Barras
+\item Error locations: Jean-Christophe Filliâtre, Bruno Barras, Hugo Herbelin
+\item Existential variables engine: Chet Murthy with revisions by
+  Bruno Barras and Arnaud Spiwack and extensions by Clément Renard and
+  Hugo Herbelin
+\end{itemize}
+
+\section{Development tools}
+
+\begin{itemize}
+\item Makefile's: Chet Murthy, Jean-Christophe Filliâtre, Judicaël
+  Courant, Lionel Mamane, Pierre Corbineau, Pierre Letouzey
+\item Debugging: Jean-Christophe Filliâtre with contributions from Jacek Chrz\k{a}szcz, Hugo Herbelin, Bruno Barras, ...
+\item ML quotations: David Delahaye and Daniel de Rauglaudre
+\item ML tactic and vernacular extensions: Hugo Herbelin (first version by Chet Murthy)
+\item Test suite: collective content, initiated by Jean-Christophe Filliâtre with further extensions by Hugo Herbelin, Jean-Marc Notin
+\end{itemize}
+
+\section{Documentation}
+
+\begin{itemize}
+
+\item Reference Manual: collective, layout by Patrick Loiseleur,
+  Claude Marché (former User's Guide in 1991 by Gilles Dowek, Amy
+  Felty, Hugo Herbelin, Gérard Huet, Christine Paulin, Benjamin
+  Werner; initial documentation in 1989 by Thierry Coquand, Gilles
+  Dowek, Gérard Huet, Christine Paulin),
+\item Basic tutorial: Gérard Huet, Gilles Kahn, Christine Paulin
+\item Tutorial on recursive types: Eduardo Gimenez with updates by Pierre Castéran
+\item FAQ: Hugo Herbelin, Julien Narboux, Florent Kirchner
+\end{itemize}
+
+\section{Features discontinued by lack of support}
+
+\begin{itemize}
+\item Searching modulo isomorphism: David Delahaye
+\item Explanation of proofs in pseudo-natural language: Yann Coscoy
+\end{itemize}
+
+Errors may have been inopportunely introduced, please report them to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr
+
+\end{document}
diff --git a/doc/whodidwhat/whodidwhat-8.4update.tex b/doc/whodidwhat/whodidwhat-8.4update.tex
new file mode 100644
index 00000000..696fff4f
--- /dev/null
+++ b/doc/whodidwhat/whodidwhat-8.4update.tex
@@ -0,0 +1,334 @@
+\documentclass{article}
+
+\usepackage{fullpage}
+\usepackage[utf8]{inputenc}
+\usepackage{t1enc}
+
+\begin{document}
+
+\title{Who did what in the Coq archive?}
+
+\author{The Coq development team}
+
+\maketitle
+
+\centerline{(updated for Coq 8.4)}
+
+\section{The Calculus of Inductive Constructions}
+
+\begin{itemize}
+\item The Calculus of Constructions
+  \begin{itemize}
+  \item Core type-checker: Gérard Huet and Thierry Coquand with
+    optimizations by Chet Murthy, Bruno Barras
+  \item Head reduction functions: Gérard Huet, Christine Paulin, Bruno Barras
+  \end{itemize}
+\item Conversion and reduction
+  \begin{itemize}
+  \item Lazy conversion machine: Bruno Barras
+  \item Transparency/opacity: Bruno Barras
+  \item Bytecode-based conversion: Benjamin Grégoire
+  \item Binary-words retroknowledge: Arnaud Spiwack 
+  \end{itemize}
+\item The universe hierarchy
+  \begin{itemize}
+  \item Floating universes: Gérard Huet, with contributions from Bruno Barras
+  \item Algebraic universes: Hugo Herbelin
+  \end{itemize}
+\item Mutual inductive types and recursive definitions
+  \begin{itemize}
+  \item Type-checking: Christine Paulin
+  \item Positivity condition: Christine Paulin
+  \item Guardness condition for fixpoints: Christine Paulin;
+    extensions by Eduardo Gimenez, Bruno Barras, Pierre Boutillier
+  \item Recursively non-uniform parameters: Christine Paulin
+  \item Sort-polymorphism of inductive types: Hugo Herbelin
+  \end{itemize}
+\item Local definitions: Hugo Herbelin
+\item Mutual coinductive types and corecursive definitions: Eduardo Gimenez
+\item Module system
+  \begin{itemize}
+  \item Core system: Jacek Chrz\k{a}szcz
+  \item Inlining: Claudio Sacerdoti Coen and Élie Soubiran
+  \item Module inclusion: Élie Soubiran
+  \item Functorial signature application: Élie Soubiran
+  \item Transparent name space: Élie Soubiran
+  \item Resolution of qualified names: Hugo Herbelin
+  \item Operator for nested functor application: Élie Soubiran and
+    Pierre Letouzey
+  \end{itemize}
+\item Minimalist stand-alone type-checker (\texttt{coqchk}): Bruno Barras, with extra support for modules by Élie Soubiran and Pierre Letouzey
+\item Eta-conversion: Hugo Herbelin, with contributions from Stéphane
+  Glondu, Benjamin Grégoire
+\end{itemize}
+
+\section{Specification language}
+
+\begin{itemize}
+\item Sections: Gilles Dowek with extra contributions by Gérard
+  Huet, Chet Murthy, Hugo Herbelin
+\item The \texttt{Russell} specifications language, proof obligations (\texttt{Program}): Matthieu Sozeau
+\item Type inference: Chet Murthy, with extra contributions by Bruno
+  Barras, Hugo Herbelin, Matthieu Sozeau, Enrico Tassi
+\item Pattern-matching: Hugo Herbelin on top of a first version by
+  Cristina Cornes
+\item Implicit arguments: Amokrane Saïbi, with extensions by Hugo
+  Herbelin, Matthieu Sozeau, Pierre Boutillier
+\item Synthetic {\tt Arguments} command: Enrico Tassi
+\item Coercions: Amokrane Saïbi
+\item Records: Amokrane Saïbi with extensions by Arnaud Spiwack and
+  Matthieu Sozeau
+\item Canonical structures: Amokrane Saïbi
+\item Type classes: Matthieu Sozeau
+\item Functional schemes (\texttt{Function}, \texttt{Functional Scheme}, ...): Julien Forest and Pierre Courtieu (preliminary version by Yves Bertot)
+\item Generation of induction schemes: Christine Paulin, Vincent
+  Siles, Matthieu Sozeau
+ \end{itemize}
+
+\section{Tactics}
+
+\subsection{General tactic support}
+
+\begin{itemize}
+\item Proof engine: Arnaud Spiwack (first version by Thierry Coquand, second version by Chet Murthy)
+\item Ltac: David Delahaye, with extensions by Hugo Herbelin, Bruno Barras, ...
+\item Tactic notations: Hugo Herbelin (first version by Chet Murthy)
+\item Main tactic unification procedure: Chet Murthy with
+  contributions from Hugo Herbelin and Matthieu Sozeau
+\item Mathematical-style language (C-Zar): Pierre Corbineau
+\item Communication with external tools (\texttt{external}): Hugo Herbelin
+\item Proof structuring (bullets and brackets): Arnaud Spiwack
+\end{itemize}
+
+\subsection{Predefined tactics}
+
+\begin{itemize}
+\item Basic tactics (\texttt{intro}, \texttt{apply},
+  \texttt{assumption}, \texttt{exact}): Thierry Coquand, with further
+  collective extensions
+\item Reduction tactics: Christine Paulin (\texttt{simpl}), Bruno
+  Barras (\texttt{cbv}, \texttt{lazy}), with contributions from Hugo Herbelin, Enrico Tassi, ...
+\item Tacticals: Thierry Coquand, Chet Murthy, Eduardo Gimenez, ...;
+  new versions of {\tt info} and {\tt Show Script} by Pierre Letouzey;
+  {\tt timeout} by Pierre Letouzey
+\item Induction: Christine Paulin (\texttt{elim}, \texttt{case}), Hugo Herbelin (\texttt{induction}, \texttt{destruct}
+\item Refinement (\texttt{refine}): Jean-Christophe Filliâtre
+\item Introduction patterns: Eduardo Gimenez with collective extensions
+\item Forward reasoning: Hugo Herbelin (\texttt{assert}, \texttt{apply in}), Pierre Letouzey (\texttt{specialize}, initial version by Amy Felty)
+\item Rewriting tactics (\texttt{rewrite}): basic version by Christine Paulin,
+  extensions by Jean-Christophe Filliâtre and Pierre Letouzey
+\item Tactics about equivalence properties (\texttt{reflexivity},
+  \texttt{symmetry}, \texttt{transitivity}): Christine Paulin (?),
+\item Equality tactics (\texttt{injection}/\texttt{discriminate}):
+  Cristina Cornes
+\item Inversion tactics (\texttt{inversion}): Cristina Cornes, Chet Murthy
+\item Setoid rewriting: Matthieu Sozeau (first version by Clément
+  Renard, second version by Claudio Sacerdoti Coen), contributions
+  from Nicolas Tabareau
+\item Decision of equality: Eduardo Gimenez
+\item Basic Ltac-level tactics: Pierre Letouzey, Matthieu Sozeau,
+  Evgeny Makarov
+\item Tactics about existential variables: Clément Renard, Pierre Corbineau, Stéphane Glondu, Arnaud Spiwack, ...
+\end{itemize}
+
+\subsection{General automation tactics}
+
+\begin{itemize}
+\item Resolution (\texttt{auto}, \texttt{trivial}): Christine Paulin
+  with extensions from Chet Murthy, Eduardo Gimenez, Patrick
+  Loiseleur (hint bases), Matthieu Sozeau
+\item Resolution with existential variables (\texttt{eauto}): Chet Murthy, Jean-Christophe Filliâtre, with extensions from Matthieu Sozeau
+\item Automatic rewriting (\texttt{autorewrite}): David Delahaye
+\end{itemize}
+
+\subsection{Domain-specific decision tactics}
+
+\begin{itemize}
+\item Congruence closure (\texttt{cc}): Pierre Corbineau
+\item Decision of first-order logic (\texttt{firstorder}): Pierre Corbineau
+\item Simplification of polynomial fractions (\texttt{field}): Laurent
+  Théry and Benjamin Grégoire (first version by David Delahaye and
+  Micaela Mayero)
+\item Simplification of polynomial expressions (\texttt{ring}): Assia
+  Mahboubi, Bruno Barras and Benjamin Grégoire (first version by
+  Samuel Boutin, second version by Patrick Loiseleur)
+\item Decision of systems of polynomial equations: Loïc Pottier (\texttt{nsatz})
+\item Decision of systems of linear inequations: Frédéric Besson
+  (\texttt{psatzl}); Loïc Pottier (\texttt{fourier})
+\item Decision of systems of linear inequations over integers:
+  Frédéric Besson (\texttt{lia}); Pierre Crégut (\texttt{omega} and
+  \texttt{romega})
+\item (Partial) decision of systems of polynomical inequations
+  (\texttt{sos}, \texttt{psatz}): Frédéric Besson, with generalization
+  over arbitrary rings by Evgeny Makarov; uses HOL-Light interface to
+  \texttt{csdp} by John Harrisson
+\item Decision/simplification of intuitionistic propositional logic:
+  David Delahaye (\texttt{tauto}, \texttt{intuition}, first version by
+  Cesar Mu\~noz, second version by Chet Murthy), with contributions
+  from Judicaël Courant; Pierre Corbineau (\texttt{rtauto})
+\item Decision/simplification of intuition first-order logic: Pierre
+  Corbineau (\texttt{firstorder})
+\end{itemize}
+
+\section{Extra tools}
+
+\begin{itemize}
+\item Program extraction: Pierre Letouzey (first implementation by
+  Benjamin Werner, second by Jean-Christophe Filliâtre)
+\item Export of context to external communication tools (\texttt{dp}):
+  Nicolas Ayache and Jean-Christophe Filliâtre, with contributions by
+  Claude Marché
+\item Export of terms and environments to XML format: Claudio
+  Sacerdoti Coen, with extensions from Cezary Kaliszyk
+\end{itemize}
+
+\section{Environment management}
+
+\begin{itemize}
+\item Separate compilation: initiated by Chet Murthy
+\item Import/Export: initiated by Chet Murthy
+\item Options management: Hugo Herbelin with contributions by Arnaud Spiwack
+\item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu
+\item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech
+\item Whelp suppport: Hugo Herbelin
+\end{itemize}
+
+\section{Parsing and printing}
+
+\begin{itemize}
+\item General parsing support: Chet Murthy, Bruno Barras, Daniel de Rauglaudre
+\item General printing support: Chet Murthy, Jean-Christophe Filliâtre
+\item Lexing: Daniel de Rauglaudre
+\item Support for UTF-8: Hugo Herbelin, with contributions from Alexandre Miquel and Yann Régis-Gianas
+\item Numerical notations: Hugo Herbelin, Patrick Loiseleur, Micaela Mayero
+\item String notations: Hugo Herbelin
+\item New ``V8'' syntax: Bruno Barras, Hugo Herbelin with contributions by Olivier Desmettre
+\item Abbreviations: Chet Murthy
+\item Notations: Chet Murthy, Hugo Herbelin
+\end{itemize}
+
+\section{Libraries}
+
+\begin{itemize}
+\item Init: collective (initiated by Christine Paulin and Gérard Huet)
+\item Arith: collective (initiated by Christine Paulin)
+\item ZArith: collective (initiated by Pierre Crégut)
+\item Bool: collective (initiated by Christine Paulin)
+\item NArith: Hugo Herbelin, Pierre Letouzey, Evgeny Makarov (out of
+  initial contibution by Pierre Crégut)
+\item Lists: Pierre Letouzey, Jean-Marc Notin (initiated by Christine Paulin)
+\item Vectors: Pierre Boutillier
+\item Reals: Micaela Mayero (axiomatization and main properties), Olivier Desmettre (convergence, derivability, integrals, trigonometric functions), contributions from Russell O'Connor, Cezary Kaliszyk, Guillaume Melquiond, Yves Bertot, Guillaume Allais
+\item Relations: Bruno Barras, Cristina Cornes with contributions from
+  Pierre Castéran
+\item Wellfounded: Bruno Barras, Cristina Cornes
+\item FSets: Pierre Letouzey, from initial work with Jean-Christophe Filliâtre, decision tactic for FSets by Aaron Bohannon, red-black trees by Andrew Appel and Pierre Letouzey
+\item MSets: Pierre Letouzey
+\item Logic: Christine Paulin, Hugo Herbelin, Bruno Barras
+\item Numbers: Evgeny Makarov (abstractions), Laurent Théry and Benjamin Grégoire (big numbers), Arnaud Spiwack and Pierre Letouzey (word-based arithmetic), further extensions by Pierre Letouzey; integration of Arith and ZArith to Numbers by Pierre Letouzey
+\item Classes: Matthieu Sozeau
+\item QArith: Pierre Letouzey, with contributions from Russell O'Connor
+\item Setoid: Matthieu Sozeau (first version by Clément Renard, second version by Claudio Sacerdoti Coen)
+\item Sets: Gilles Kahn and Gérard Huet
+\item Sorting: Gérard Huet with revisions by Hugo Herbelin
+\item Strings: Laurent Théry
+\item Program: Matthieu Sozeau
+\item Unicode: Claude Marché
+\end{itemize}
+
+\section{Commands}
+
+\begin{itemize}
+\item Batch compiler (\texttt{coqc}):  Chet Murthy (?)
+\item Compilation dependency calculator (\texttt{coqdep}):
+  Jean-Christophe Filliâtre
+\item Statistic tool (\texttt{coqwc}): Jean-Christophe Filliâtre
+\item Simple html presentation tool (\texttt{gallina}) (deprecated): Jean-Christophe Filliâtre
+\item Auto-maker (\texttt{coq\_makefile}): Jean-Christophe Filliâtre,
+  with contributions from Judicaël Courant, updated by Pierre Boutillier
+\item LaTeX presentation tool (\texttt{coq-tex}): Jean-Christophe Filliâtre
+\item Multi-purpose presentation tool (\texttt{coqdoc}): Jean-Christophe Filliâtre with extensions from
+  Matthieu Sozeau, Jean-Marc Notin, Hugo Herbelin and contributions from Adam Chlipala
+\item Interactive toplevel (\texttt{coqtop}): Jean-Christophe Filliâtre (?)
+\item Custom toplevel builder (\texttt{coqmktop}): Jean-Christophe Filliâtre (?)
+\end{itemize}
+
+\section{Graphical interfaces}
+
+\begin{itemize}
+\item Support for {\em PCoq}: Yves Bertot with contributions by
+  Laurence Rideau and Loïc Pottier; additional support for {\em TmEgg}
+  by Lionel Mamane
+\item Support for {\em Proof General}: Pierre Courtieu with contributions from Arnaud Spiwack
+\item {\em CoqIDE}: Benjamin Monate with contributions from
+  Jean-Christophe Filliâtre, Claude Marché, Pierre Letouzey, Julien
+  Narboux, Hugo Herbelin, Pierre Corbineau, Pierre Boutillier,
+  Pierre-Marie Pédrot; processus-based communication protocol by
+  Vincent Gross with contributions from Pierre Letouzey, Pierre
+  Boutillier, Pierre-Marie Pédrot; backtracking revised by Pierre
+  Letouzey; uses the Cameleon library by Maxence Guesdon;
+\end{itemize}
+
+\section{Architecture}
+
+\begin{itemize}
+\item Functional-kernel-based architecture: Jean-Christophe Filliâtre
+\item Extensible objects and summaries: Chet Murthy
+\item Hash-consing: Bruno Barras
+\item Error locations: Jean-Christophe Filliâtre, Bruno Barras, Hugo Herbelin, with contributions from Arnaud Spiwack
+\item Existential variables engine: Chet Murthy with revisions by
+  Bruno Barras and Arnaud Spiwack and extensions by Clément Renard and
+  Hugo Herbelin
+\end{itemize}
+
+\section{Development tools}
+
+\begin{itemize}
+\item Makefile's: Chet Murthy, Jean-Christophe Filliâtre, Judicaël
+  Courant, Lionel Mamane, Pierre Corbineau, Pierre Letouzey with
+  contributions from Stéphane Glondu, Hugo Herbelin, ...
+\item Debugging: Jean-Christophe Filliâtre with contributions from Jacek Chrz\k{a}szcz, Hugo Herbelin, Bruno Barras, ...
+\item ML quotations: David Delahaye and Daniel de Rauglaudre
+\item ML tactic and vernacular extensions: Hugo Herbelin (first version by Chet Murthy)
+\item Test suite: collective content, initiated by Jean-Christophe Filliâtre with further extensions by Hugo Herbelin, Jean-Marc Notin
+\end{itemize}
+
+\section{Maintenance and system engineering}
+
+\begin{itemize}
+\item General bug support: Gérard Huet, Christine Paulin, Chet Murthy,
+  Jean-Christophe Filliâtre, Hugo Herbelin, Bruno Barras, Pierre
+  Letouzey with contributions at some time from Benjamin Werner,
+  Jean-Marc Notin, Pierre Boutillier, ...
+\item Team coordination: Gérard Huet, Christine Paulin, Hugo Herbelin,
+  with various other contributions
+\item Packaging tools: Henri Laulhere, David Delahaye, Julien Narboux,
+  Pierre Letouzey, Enrico Tassi (Windows); Damien Doligez, Hugo
+  Herbelin, Pierre Boutillier (MacOS); Jean-Christophe Filliâtre,
+  Judicaël Courant, Hugo Herbelin, Stéphane Glondu (Linux)
+\end{itemize}
+
+\section{Documentation}
+
+\begin{itemize}
+
+\item Reference Manual: collective, layout by Patrick Loiseleur,
+  Claude Marché (former User's Guide in 1991 by Gilles Dowek, Amy
+  Felty, Hugo Herbelin, Gérard Huet, Christine Paulin, Benjamin
+  Werner; initial documentation in 1989 by Thierry Coquand, Gilles
+  Dowek, Gérard Huet, Christine Paulin),
+\item Basic tutorial: Gérard Huet, Gilles Kahn, Christine Paulin
+\item Tutorial on recursive types: Eduardo Gimenez with updates by Pierre Castéran
+\item FAQ: Hugo Herbelin, Julien Narboux, Florent Kirchner
+\end{itemize}
+
+\section{Features discontinued by lack of support}
+
+\begin{itemize}
+\item Searching modulo isomorphism: David Delahaye
+\item Explanation of proofs in pseudo-natural language: Yann Coscoy
+\end{itemize}
+
+For probable oversights or accidental errors, please report to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr
+
+\end{document}
diff --git a/doc/whodidwhat/whodidwhat-8.5update.tex b/doc/whodidwhat/whodidwhat-8.5update.tex
new file mode 100644
index 00000000..ce099dc3
--- /dev/null
+++ b/doc/whodidwhat/whodidwhat-8.5update.tex
@@ -0,0 +1,346 @@
+\documentclass{article}
+
+\usepackage{fullpage}
+\usepackage[utf8]{inputenc}
+\usepackage{t1enc}
+
+\begin{document}
+
+\title{Who did what in the Coq archive?}
+
+\author{The Coq development team}
+
+\maketitle
+
+\centerline{(updated for Coq 8.5)}
+
+\section{The Calculus of Inductive Constructions}
+
+\begin{itemize}
+\item The Calculus of Constructions
+  \begin{itemize}
+  \item Core type-checker: Gérard Huet and Thierry Coquand with
+    optimizations by Chet Murthy, Bruno Barras
+  \item Head reduction functions: Gérard Huet, Christine Paulin, Bruno Barras
+  \end{itemize}
+\item Conversion and reduction
+  \begin{itemize}
+  \item Lazy conversion machine: Bruno Barras
+  \item Transparency/opacity: Bruno Barras
+  \item Bytecode-based conversion: Benjamin Grégoire
+  \item Binary-words retroknowledge: Arnaud Spiwack 
+  \item Native code based conversion: Maxime Dénès, Benjamin Grégoire
+  \end{itemize}
+\item The universe hierarchy
+  \begin{itemize}
+  \item Floating universes: Gérard Huet, with contributions from Bruno Barras
+  \item Algebraic universes: Hugo Herbelin
+  \end{itemize}
+\item Mutual inductive types and recursive definitions
+  \begin{itemize}
+  \item Type-checking: Christine Paulin
+  \item Positivity condition: Christine Paulin
+  \item Guardness condition for fixpoints: Christine Paulin;
+    extensions by Eduardo Gimenez, Bruno Barras, Pierre Boutillier; fixes by
+    Bruno Barras, Maxime Dénès
+  \item Recursively non-uniform parameters: Christine Paulin
+  \item Sort-polymorphism of inductive types: Hugo Herbelin
+  \end{itemize}
+\item Local definitions: Hugo Herbelin
+\item Mutual coinductive types and corecursive definitions: Eduardo Gimenez
+\item Module system
+  \begin{itemize}
+  \item Core system: Jacek Chrz\k{a}szcz
+  \item Inlining: Claudio Sacerdoti Coen and Élie Soubiran
+  \item Module inclusion: Élie Soubiran
+  \item Functorial signature application: Élie Soubiran
+  \item Transparent name space: Élie Soubiran
+  \item Resolution of qualified names: Hugo Herbelin
+  \item Operator for nested functor application: Élie Soubiran and
+    Pierre Letouzey
+  \end{itemize}
+\item Minimalist stand-alone type-checker (\texttt{coqchk}): Bruno Barras, with extra support for modules by Élie Soubiran and Pierre Letouzey
+\item Eta-conversion: Hugo Herbelin, with contributions from Stéphane
+  Glondu, Benjamin Grégoire
+\end{itemize}
+
+\section{Specification language}
+
+\begin{itemize}
+\item Sections: Gilles Dowek with extra contributions by Gérard
+  Huet, Chet Murthy, Hugo Herbelin
+\item The \texttt{Russell} specifications language, proof obligations (\texttt{Program}): Matthieu Sozeau
+\item Type inference: Chet Murthy, with extra contributions by Bruno
+  Barras, Hugo Herbelin, Matthieu Sozeau, Enrico Tassi
+\item Pattern-matching: Hugo Herbelin on top of a first version by
+  Cristina Cornes, contributions by Arnaud Spiwack
+\item Implicit arguments: Amokrane Saïbi, with extensions by Hugo
+  Herbelin, Matthieu Sozeau, Pierre Boutillier
+\item Synthetic {\tt Arguments} command: Enrico Tassi
+\item Coercions: Amokrane Saïbi
+\item Records
+  \begin{itemize}
+  \item Core implementation: Amokrane Saïbi with extensions by Matthieu Sozeau
+  \item Extension to inductive and co-inductive records: Arnaud Spiwack
+  \item Non-recursive variants: Arnaud Spiwack
+  \end{itemize}
+\item Canonical structures: Amokrane Saïbi
+\item Type classes: Matthieu Sozeau
+\item Function (\texttt{Function}, \texttt{functional induction}...):
+  Julien Forest (preliminary versions by Pierre Courtieu
+  (\texttt{Functional Schemes}) and Yves Bertot (\texttt{Recursive
+    Definition}))
+\item Generation of induction schemes: Christine Paulin, Vincent
+  Siles, Matthieu Sozeau
+ \end{itemize}
+
+\section{Tactics}
+
+\subsection{General tactic support}
+
+\begin{itemize}
+\item Proof engine: Arnaud Spiwack (first version by Thierry Coquand, second version by Chet Murthy)
+\item Ltac: David Delahaye, with extensions by Hugo Herbelin, Bruno Barras, ...
+  Evolution to the new proof engine Arnaud Spiwack, Pierre-Marie P\'edrot
+\item Tactic notations: Hugo Herbelin (first version by Chet Murthy)
+\item Main tactic unification procedure: Chet Murthy with
+  contributions from Hugo Herbelin and Matthieu Sozeau
+\item Mathematical-style language (C-Zar): Pierre Corbineau
+\item Communication with external tools (\texttt{external}): Hugo Herbelin
+\item Proof structuring (bullets and brackets): Arnaud Spiwack
+\end{itemize}
+
+\subsection{Predefined tactics}
+
+\begin{itemize}
+\item Basic refinement tactic (\texttt{refine}): Arnaud Spiwack (previous non-basic version by Jean-Christophe Filliâtre)
+\item Core tactics (\texttt{intro}, \texttt{apply},
+  \texttt{assumption}, \texttt{exact}): Thierry Coquand, with further
+  collective extensions
+\item Reduction tactics: Christine Paulin (\texttt{simpl}), Bruno
+  Barras (\texttt{cbv}, \texttt{lazy}), Pierre Boutillier (\texttt{cbn})
+  with contributions from Hugo Herbelin, Enrico Tassi, ...
+\item Tacticals: Thierry Coquand, Chet Murthy, Eduardo Gimenez, ...;
+  new versions of {\tt info} and {\tt Show Script} by Pierre Letouzey;
+  {\tt timeout} by Pierre Letouzey; backtracking-related tacticals by Arnaud Spiwack
+\item Generic tactic traces ({\tt Info}) by Arnaud Spiwack (based on the former {\tt info} tactical)
+\item Induction: Christine Paulin (\texttt{elim}, \texttt{case}), Hugo Herbelin (\texttt{induction}, \texttt{destruct}
+\item Introduction patterns: Eduardo Gimenez with collective extensions
+\item Forward reasoning: Hugo Herbelin (\texttt{assert}, \texttt{enough}, \texttt{apply in}),
+  Pierre Letouzey (\texttt{specialize}, initial version by Amy Felty)
+\item Rewriting tactics (\texttt{rewrite}): basic version by Christine Paulin,
+  extensions by Jean-Christophe Filliâtre and Pierre Letouzey
+\item Setoid rewriting: Matthieu Sozeau (first version by Clément
+  Renard, second version by Claudio Sacerdoti Coen), contributions
+  from Nicolas Tabareau
+\item Tactics about equivalence properties (\texttt{reflexivity},
+  \texttt{symmetry}, \texttt{transitivity}): Christine Paulin (?),
+\item Equality tactics (\texttt{injection}/\texttt{discriminate}): Cristina Cornes, extensions by Hugo Herbelin
+\item Inversion tactics (\texttt{inversion}): Cristina Cornes, Chet Murthy
+\item Decision of equality: Eduardo Gimenez
+\item Basic Ltac-level tactics: Pierre Letouzey, Matthieu Sozeau,
+  Evgeny Makarov
+\item Tactics about existential variables: Clément Renard, Pierre Corbineau, Stéphane Glondu, Arnaud Spiwack, ...
+\end{itemize}
+
+\subsection{General automation tactics}
+
+\begin{itemize}
+\item Resolution (\texttt{auto}, \texttt{trivial}): Christine Paulin
+  with extensions from Chet Murthy, Eduardo Gimenez, Patrick
+  Loiseleur (hint bases), Matthieu Sozeau
+\item Resolution with existential variables (\texttt{eauto}): Chet Murthy, Jean-Christophe Filliâtre, with extensions from Matthieu Sozeau
+\item Automatic rewriting (\texttt{autorewrite}): David Delahaye
+\end{itemize}
+
+\subsection{Domain-specific decision tactics}
+
+\begin{itemize}
+\item Congruence closure (\texttt{cc}): Pierre Corbineau
+\item Decision of first-order logic (\texttt{firstorder}): Pierre Corbineau
+\item Simplification of polynomial fractions (\texttt{field}): Laurent
+  Théry and Benjamin Grégoire (first version by David Delahaye and
+  Micaela Mayero)
+\item Simplification of polynomial expressions (\texttt{ring}): Assia
+  Mahboubi, Bruno Barras and Benjamin Grégoire (first version by
+  Samuel Boutin, second version by Patrick Loiseleur)
+\item Decision of systems of polynomial equations: Loïc Pottier (\texttt{nsatz})
+\item Decision of systems of linear inequations: Frédéric Besson
+  (\texttt{psatzl}); Loïc Pottier (\texttt{fourier})
+\item Decision of systems of linear inequations over integers:
+  Frédéric Besson (\texttt{lia}); Pierre Crégut (\texttt{omega} and
+  \texttt{romega})
+\item (Partial) decision of systems of polynomical inequations
+  (\texttt{sos}, \texttt{psatz}): Frédéric Besson, with generalization
+  over arbitrary rings by Evgeny Makarov; uses HOL-Light interface to
+  \texttt{csdp} by John Harrisson
+\item Decision/simplification of intuitionistic propositional logic:
+  David Delahaye (\texttt{tauto}, \texttt{intuition}, first version by
+  Cesar Mu\~noz, second version by Chet Murthy), with contributions
+  from Judicaël Courant; Pierre Corbineau (\texttt{rtauto})
+\item Decision/simplification of intuition first-order logic: Pierre
+  Corbineau (\texttt{firstorder})
+\end{itemize}
+
+\section{Extra tools}
+
+\begin{itemize}
+\item Program extraction: Pierre Letouzey (first implementation by
+  Benjamin Werner, second by Jean-Christophe Filliâtre)
+\end{itemize}
+
+\section{Environment management}
+
+\begin{itemize}
+\item Separate compilation: initiated by Chet Murthy
+\item Import/Export: initiated by Chet Murthy
+\item Options management: Hugo Herbelin with contributions by Arnaud Spiwack
+\item Resetting and backtracking: Chet Murthy with contributions from Pierre Courtieu
+\item Searching: Hugo Herbelin and Yves Bertot with extensions by Matthias Puech
+\item Whelp suppport: Hugo Herbelin
+\end{itemize}
+
+\section{Parsing and printing}
+
+\begin{itemize}
+\item General parsing support: Chet Murthy, Bruno Barras, Daniel de Rauglaudre
+\item General printing support: Chet Murthy, Jean-Christophe Filliâtre
+\item Lexing: Daniel de Rauglaudre
+\item Support for UTF-8: Hugo Herbelin, with contributions from Alexandre Miquel and Yann Régis-Gianas
+\item Numerical notations: Hugo Herbelin, Patrick Loiseleur, Micaela Mayero
+\item String notations: Hugo Herbelin
+\item New ``V8'' syntax: Bruno Barras, Hugo Herbelin with contributions by Olivier Desmettre
+\item Abbreviations: Chet Murthy
+\item Notations: Chet Murthy, Hugo Herbelin
+\end{itemize}
+
+\section{Libraries}
+
+\begin{itemize}
+\item Init: collective (initiated by Christine Paulin and Gérard Huet)
+\item Arith: collective (initiated by Christine Paulin)
+\item ZArith: collective (initiated by Pierre Crégut)
+\item Bool: collective (initiated by Christine Paulin)
+\item NArith: Hugo Herbelin, Pierre Letouzey, Evgeny Makarov (out of
+  initial contibution by Pierre Crégut)
+\item Lists: Pierre Letouzey, Jean-Marc Notin (initiated by Christine Paulin)
+\item Vectors: Pierre Boutillier
+\item Reals: Micaela Mayero (axiomatization and main properties), Olivier Desmettre (convergence, derivability, integrals, trigonometric functions), contributions from Russell O'Connor, Cezary Kaliszyk, Guillaume Melquiond, Yves Bertot, Guillaume Allais
+\item Relations: Bruno Barras, Cristina Cornes with contributions from
+  Pierre Castéran
+\item Wellfounded: Bruno Barras, Cristina Cornes
+\item FSets: Pierre Letouzey, from initial work with Jean-Christophe Filliâtre, decision tactic for FSets by Aaron Bohannon, red-black trees by Andrew Appel and Pierre Letouzey
+\item MSets: Pierre Letouzey
+\item Logic: Christine Paulin, Hugo Herbelin, Bruno Barras, contributions by Arnaud Spiwack
+\item Numbers: Evgeny Makarov (abstractions), Laurent Théry and Benjamin Grégoire (big numbers), Arnaud Spiwack and Pierre Letouzey (word-based arithmetic), further extensions by Pierre Letouzey; integration of Arith and ZArith to Numbers by Pierre Letouzey
+\item Classes: Matthieu Sozeau
+\item QArith: Pierre Letouzey, with contributions from Russell O'Connor
+\item Setoid: Matthieu Sozeau (first version by Clément Renard, second version by Claudio Sacerdoti Coen)
+\item Sets: Gilles Kahn and Gérard Huet
+\item Sorting: Gérard Huet with revisions by Hugo Herbelin
+\item Strings: Laurent Théry
+\item Program: Matthieu Sozeau
+\item Unicode: Claude Marché
+\end{itemize}
+
+\section{Commands}
+
+\begin{itemize}
+\item Batch compiler (\texttt{coqc}):  Chet Murthy (?)
+\item Compilation dependency calculator (\texttt{coqdep}):
+  Jean-Christophe Filliâtre
+\item Statistic tool (\texttt{coqwc}): Jean-Christophe Filliâtre
+\item Simple html presentation tool (\texttt{gallina}) (deprecated): Jean-Christophe Filliâtre
+\item Auto-maker (\texttt{coq\_makefile}): Jean-Christophe Filliâtre,
+  with contributions from Judicaël Courant, updated by Pierre Boutillier
+\item LaTeX presentation tool (\texttt{coq-tex}): Jean-Christophe Filliâtre
+\item Multi-purpose presentation tool (\texttt{coqdoc}): Jean-Christophe Filliâtre with extensions from
+  Matthieu Sozeau, Jean-Marc Notin, Hugo Herbelin and contributions from Adam Chlipala
+\item Interactive toplevel (\texttt{coqtop}): Jean-Christophe Filliâtre (?)
+\item Custom toplevel builder (\texttt{coqmktop}): Jean-Christophe Filliâtre (?)
+\end{itemize}
+
+\section{Graphical interfaces}
+
+\begin{itemize}
+\item Support for {\em Proof General}: Pierre Courtieu with contributions from Arnaud Spiwack
+\item {\em CoqIDE}: Benjamin Monate with contributions from
+  Jean-Christophe Filliâtre, Claude Marché, Pierre Letouzey, Julien
+  Narboux, Hugo Herbelin, Pierre Corbineau, Pierre Boutillier,
+  Pierre-Marie Pédrot; processus-based communication protocol by
+  Vincent Gross with contributions from Pierre Letouzey, Pierre
+  Boutillier, Pierre-Marie Pédrot; backtracking revised by Pierre
+  Letouzey; uses the Cameleon library by Maxence Guesdon;
+\end{itemize}
+
+\section{Architecture}
+
+\begin{itemize}
+\item Functional-kernel-based architecture: Jean-Christophe Filliâtre
+\item Extensible objects and summaries: Chet Murthy
+\item Hash-consing: Bruno Barras
+\item Error locations: Jean-Christophe Filliâtre, Bruno Barras, Hugo Herbelin, with contributions from Arnaud Spiwack
+\item Existential variables engine: Chet Murthy with revisions by
+  Bruno Barras and Arnaud Spiwack and extensions by Clément Renard and
+  Hugo Herbelin
+\end{itemize}
+
+\section{Development tools}
+
+\begin{itemize}
+\item Makefile's: Chet Murthy, Jean-Christophe Filliâtre, Judicaël
+  Courant, Lionel Mamane, Pierre Corbineau, Pierre Letouzey with
+  contributions from Stéphane Glondu, Hugo Herbelin, ...
+\item Debugging: Jean-Christophe Filliâtre with contributions from Jacek Chrz\k{a}szcz, Hugo Herbelin, Bruno Barras, ...
+\item ML quotations: David Delahaye and Daniel de Rauglaudre
+\item ML tactic and vernacular extensions: Hugo Herbelin (first version by Chet Murthy)
+\item Test suite: collective content, initiated by Jean-Christophe Filliâtre with further extensions by Hugo Herbelin, Jean-Marc Notin
+\end{itemize}
+
+\section{Maintenance and system engineering}
+
+\begin{itemize}
+\item General bug support: Gérard Huet, Christine Paulin, Chet Murthy,
+  Jean-Christophe Filliâtre, Hugo Herbelin, Bruno Barras, Pierre
+  Letouzey with contributions at some time from Benjamin Werner,
+  Jean-Marc Notin, Pierre Boutillier, ...
+\item Team coordination: Gérard Huet, Christine Paulin, Hugo Herbelin,
+  with various other contributions
+\item Packaging tools: Henri Laulhere, David Delahaye, Julien Narboux,
+  Pierre Letouzey, Enrico Tassi (Windows); Damien Doligez, Hugo
+  Herbelin, Pierre Boutillier (MacOS); Jean-Christophe Filliâtre,
+  Judicaël Courant, Hugo Herbelin, Stéphane Glondu (Linux)
+\end{itemize}
+
+\section{Documentation}
+
+\begin{itemize}
+
+\item Reference Manual: collective, layout by Patrick Loiseleur,
+  Claude Marché (former User's Guide in 1991 by Gilles Dowek, Amy
+  Felty, Hugo Herbelin, Gérard Huet, Christine Paulin, Benjamin
+  Werner; initial documentation in 1989 by Thierry Coquand, Gilles
+  Dowek, Gérard Huet, Christine Paulin),
+\item Basic tutorial: Gérard Huet, Gilles Kahn, Christine Paulin
+\item Tutorial on recursive types: Eduardo Gimenez with updates by Pierre Castéran
+\item FAQ: Hugo Herbelin, Julien Narboux, Florent Kirchner
+\end{itemize}
+
+\section{Features discontinued by lack of support}
+
+\begin{itemize}
+\item Searching modulo isomorphism: David Delahaye
+\item Explanation of proofs in pseudo-natural language: Yann Coscoy
+\item Export of context to external communication tools (\texttt{dp}):
+  Nicolas Ayache and Jean-Christophe Filliâtre, with contributions by
+  Claude Marché
+\item Support for {\em PCoq}: Yves Bertot with contributions by
+  Laurence Rideau and Loïc Pottier; additional support for {\em TmEgg}
+  by Lionel Mamane
+\item Export of terms and environments to XML format: Claudio
+  Sacerdoti Coen, with extensions from Cezary Kaliszyk
+\end{itemize}
+
+For probable oversights or accidental errors, please report to Hugo~\verb=.=~Herbelin~\verb=@=~inria~\verb=.=~fr
+
+\end{document}
diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4
new file mode 100644
index 00000000..fe0959dd
--- /dev/null
+++ b/grammar/argextend.ml4
@@ -0,0 +1,299 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "tools/compat5b.cmo" i*)
+
+open Genarg
+open Q_util
+open Egramml
+open Compat
+open Pcoq
+
+let loc = CompatLoc.ghost
+let default_loc = <:expr< Loc.ghost >>
+
+let qualified_name loc s =
+  let path = CString.split '.' s in
+  let (name, path) = CList.sep_last path in
+  qualified_name loc path name
+
+let mk_extraarg loc s =
+  try
+    let name = Genarg.get_name0 s in
+    qualified_name loc name
+  with Not_found ->
+    <:expr< $lid:"wit_"^s$ >>
+
+let rec make_wit loc = function
+  | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >>
+  | IdentArgType -> <:expr< Constrarg.wit_ident >>
+  | VarArgType -> <:expr< Constrarg.wit_var >>
+  | QuantHypArgType -> <:expr< Constrarg.wit_quant_hyp >>
+  | GenArgType -> <:expr< Constrarg.wit_genarg >>
+  | ConstrArgType -> <:expr< Constrarg.wit_constr >>
+  | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >>
+  | RedExprArgType -> <:expr< Constrarg.wit_red_expr >>
+  | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >>
+  | ConstrWithBindingsArgType -> <:expr< Constrarg.wit_constr_with_bindings >>
+  | BindingsArgType -> <:expr< Constrarg.wit_bindings >>
+  | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >>
+  | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
+  | PairArgType (t1,t2) ->
+      <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
+  | ExtraArgType s -> mk_extraarg loc s
+
+let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >>
+let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >>
+let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >>
+
+let has_extraarg =
+  List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false)
+
+let rec is_possibly_empty = function
+| Aopt _ | Alist0 _ | Alist0sep _ | Amodifiers _ -> true
+| Alist1 t | Alist1sep (t, _) -> is_possibly_empty t
+| _ -> false
+
+let rec get_empty_entry = function
+| Aopt _ -> <:expr< None >>
+| Alist0 _ | Alist0sep _ | Amodifiers _ -> <:expr< [] >>
+| Alist1 t | Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >>
+| _ -> assert false
+
+let statically_known_possibly_empty s (prods,_) =
+  List.for_all (function
+    | GramNonTerminal(_,ExtraArgType s',_,_) ->
+        (* For ExtraArg we don't know (we'll have to test dynamically) *)
+        (* unless it is a recursive call *)
+        s <> s'
+    | GramNonTerminal(_,_,e,_) ->
+        is_possibly_empty e
+    | GramTerminal _ ->
+        (* This consumes a token for sure *) false)
+      prods
+
+let possibly_empty_subentries loc (prods,act) =
+  let bind_name p v e = match p with
+    | None -> e
+    | Some id ->
+        let s = Names.Id.to_string id in <:expr< let $lid:s$ = $v$ in $e$ >> in
+  let rec aux = function
+    | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >>
+    | GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e ->
+        bind_name p (get_empty_entry e) (aux tl)
+    | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl ->
+        (* We check at runtime if extraarg s parses "epsilon" *)
+        let s = match p with None -> "_" | Some id -> Names.Id.to_string id in
+        <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with
+          [ None -> raise Exit
+          | Some v -> v ] in $aux tl$ >>
+    | _ -> assert false (* already filtered out *) in
+  if has_extraarg prods then
+    (* Needs a dynamic check; catch all exceptions if ever some rhs raises *)
+    (* an exception rather than returning a value; *)
+    (* declares loc because some code can refer to it; *)
+    (* ensures loc is used to avoid "unused variable" warning *)
+    (true, <:expr< try Some $aux prods$
+                   with [ Exit -> None ] >>)
+  else
+    (* Static optimisation *)
+    (false, aux prods)
+
+let make_possibly_empty_subentries loc s cl =
+  let cl = List.filter (statically_known_possibly_empty s) cl in
+  if cl = [] then
+    <:expr< None >>
+  else
+    let rec aux = function
+    | (true, e) :: l ->
+        <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >>
+    | (false, e) :: _ ->
+        <:expr< Some $e$ >>
+    | [] ->
+        <:expr< None >> in
+    aux (List.map (possibly_empty_subentries loc) cl)
+
+let make_act loc act pil =
+  let rec make = function
+    | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >>
+    | GramNonTerminal (_,t,_,Some p) :: tl ->
+	let p = Names.Id.to_string p in
+	<:expr<
+          Pcoq.Gram.action
+            (fun $lid:p$ ->
+               let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
+        >>
+    | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl ->
+	<:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in
+  make (List.rev pil)
+
+let make_prod_item = function
+  | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >>
+  | GramNonTerminal (_,_,g,_) ->
+      <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >>
+
+let make_rule loc (prods,act) =
+  <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >>
+
+let declare_tactic_argument loc s (typ, pr, f, g, h) cl =
+  let rawtyp, rawpr, globtyp, globpr = match typ with
+    | `Uniform typ ->
+      typ, pr, typ, pr
+    | `Specialized (a, b, c, d) -> a, b, c, d
+  in
+  let glob = match g with
+    | None ->
+      begin match rawtyp with
+      | Genarg.ExtraArgType s' when CString.equal s s' ->
+        <:expr< fun ist v -> (ist, v) >>
+      | _ ->
+        <:expr< fun ist v ->
+          let ans = out_gen $make_globwit loc rawtyp$
+          (Tacintern.intern_genarg ist
+          (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in
+          (ist, ans) >>
+      end
+    | Some f ->
+      <:expr< fun ist v -> (ist, $lid:f$ ist v) >>
+  in
+  let interp = match f with
+    | None ->
+      begin match globtyp with
+      | Genarg.ExtraArgType s' when CString.equal s s' ->
+        <:expr< fun ist gl v -> (gl.Evd.sigma, v) >>
+      | _ ->
+	<:expr< fun ist gl x ->
+	  let (sigma,a_interp) =
+	    Tacinterp.interp_genarg ist
+              (Tacmach.pf_env gl) (Tacmach.project gl) (Tacmach.pf_concl gl) gl.Evd.it
+               (Genarg.in_gen $make_globwit loc globtyp$ x)
+	  in
+          (sigma , out_gen $make_topwit loc globtyp$ a_interp)>>
+      end
+    | Some f -> <:expr< $lid:f$>> in
+  let subst = match h with
+    | None ->
+      begin match globtyp with
+      | Genarg.ExtraArgType s' when CString.equal s s' ->
+        <:expr< fun s v -> v >>
+      | _ ->
+        <:expr< fun s x ->
+          out_gen $make_globwit loc globtyp$
+          (Tacsubst.subst_genarg s
+            (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
+      end
+    | Some f -> <:expr< $lid:f$>> in
+  let se = mlexpr_of_string s in
+  let wit = <:expr< $lid:"wit_"^s$ >> in
+  let rawwit = <:expr< Genarg.rawwit $wit$ >> in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in
+  declare_str_items loc
+   [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $default_value$ $se$ >>;
+     <:str_item< Genintern.register_intern0 $wit$ $glob$ >>;
+     <:str_item< Genintern.register_subst0 $wit$ $subst$ >>;
+     <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+     <:str_item< do {
+      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
+	(None, [(None, None, $rules$)]);
+      Pptactic.declare_extra_genarg_pprule
+        $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$ }
+     >> ]
+
+let declare_vernac_argument loc s pr cl =
+  let se = mlexpr_of_string s in
+  let wit = <:expr< $lid:"wit_"^s$ >> in
+  let rawwit = <:expr< Genarg.rawwit $wit$ >> in
+  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
+  let pr_rules = match pr with
+    | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >>
+    | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in
+  declare_str_items loc
+   [ <:str_item<
+      value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) =
+        Genarg.create_arg None $se$ >>;
+     <:str_item<
+      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
+    <:str_item< do {
+      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
+	(None, [(None, None, $rules$)]);
+      Pptactic.declare_extra_genarg_pprule $wit$
+        $pr_rules$
+        (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not globwit printer"))
+        (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not wit printer")) }
+      >> ]
+
+open Pcoq
+open Pcaml
+open PcamlSig (* necessary for camlp4 *)
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "ARGUMENT"; "EXTEND"; s = entry_name;
+        header = argextend_header;
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+         declare_tactic_argument loc s header l
+      | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name;
+        pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr];
+        OPT "|"; l = LIST1 argrule SEP "|";
+        "END" ->
+         declare_vernac_argument loc s pr l ] ]
+  ;
+  argextend_header:
+    [ [ "TYPED"; "AS"; typ = argtype;
+        "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] ->
+        (`Uniform typ, pr, f, g, h)
+      | "PRINTED"; "BY"; pr = LIDENT;
+        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
+        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
+        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
+        "RAW_TYPED"; "AS"; rawtyp = argtype;
+        "RAW_PRINTED"; "BY"; rawpr = LIDENT;
+        "GLOB_TYPED"; "AS"; globtyp = argtype;
+        "GLOB_PRINTED"; "BY"; globpr = LIDENT ->
+        (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ]
+  ;
+  argtype:
+    [ "2"
+      [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
+    | "1"
+      [ e = argtype; LIDENT "list" -> ListArgType e
+      | e = argtype; LIDENT "option" -> OptArgType e ]
+    | "0"
+      [ e = LIDENT -> fst (interp_entry_name false None e "")
+      | "("; e = argtype; ")" -> e ] ]
+  ;
+  argrule:
+    [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ]
+  ;
+  genarg:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name false None e "" in
+	GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let t, g = interp_entry_name false None e sep in
+	GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | s = STRING ->
+	  if String.length s > 0 && Util.is_letter s.[0] then
+	    Lexer.add_keyword s;
+          GramTerminal s
+    ] ]
+  ;
+  entry_name:
+    [ [ s = LIDENT -> s
+      | UIDENT -> failwith "Argument entry names must be lowercase"
+      ] ]
+  ;
+  END
diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib
new file mode 100644
index 00000000..0b168377
--- /dev/null
+++ b/grammar/grammar.mllib
@@ -0,0 +1,62 @@
+Coq_config
+
+Hook
+Canary
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+Pp_control
+Flags
+Loc
+Serialize
+Stateid
+Feedback
+Pp
+Errors
+CList
+CString
+CArray
+CStack
+Util
+Bigint
+Predicate
+Segmenttree
+Unicodetable
+Unicode
+Genarg
+
+Evar
+Names
+
+Libnames
+
+Redops
+Miscops
+Locusops
+
+Stdarg
+Constrarg
+Constrexpr_ops
+
+Compat
+Tok
+Lexer
+Pcoq
+G_prim
+G_tactic
+G_ltac
+G_constr
+
+Q_util
+Q_coqast
+Egramml
+Argextend
+Tacextend
+Vernacextend
diff --git a/parsing/q_constr.ml4 b/grammar/q_constr.ml4
index 7e69163e..6ae8bea3 100644
--- a/parsing/q_constr.ml4
+++ b/grammar/q_constr.ml4
@@ -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,37 +8,32 @@
 
 (*i camlp4deps: "tools/compat5b.cmo" i*)
 
-open Glob_term
-open Term
-open Names
-open Pattern
 open Q_util
-open Util
 open Compat
 open Pcaml
-open PcamlSig
+open PcamlSig (* necessary for camlp4 *)
 
-let loc = dummy_loc
-let dloc = <:expr< Util.dummy_loc >>
+let loc = CompatLoc.ghost
+let dloc = <:expr< Loc.ghost >>
 
 let apply_ref f l =
   <:expr<
-    Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$)
+    Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$, None), $mlexpr_of_list (fun x -> x) l$)
   >>
 
 EXTEND
   GLOBAL: expr;
   expr:
     [ [ "PATTERN"; "["; c = constr; "]" ->
-      <:expr< snd (Pattern.pattern_of_glob_constr $c$) >> ] ]
+      <:expr< snd (Patternops.pattern_of_glob_constr $c$) >> ] ]
   ;
   sort:
-    [ [ "Set"  -> GProp Pos
-      | "Prop" -> GProp Null
-      | "Type" -> GType None ] ]
+    [ [ "Set"  -> Misctypes.GSet
+      | "Prop" -> Misctypes.GProp
+      | "Type" -> Misctypes.GType [] ] ]
   ;
   ident:
-    [ [ s = string -> <:expr< Names.id_of_string $str:s$ >> ] ]
+    [ [ s = string -> <:expr< Names.Id.of_string $str:s$ >> ] ]
   ;
   name:
     [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ]
@@ -49,9 +44,9 @@ EXTEND
   constr:
     [ "200" RIGHTA
       [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr ->
-        <:expr< Glob_term.GProd ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >>
+        <:expr< Glob_term.GProd ($dloc$,Name $id$,Decl_kinds.Explicit,$c1$,$c2$) >>
       | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr ->
-        <:expr< Glob_term.GLambda ($dloc$,Name $id$,Glob_term.Explicit,$c1$,$c2$) >>
+        <:expr< Glob_term.GLambda ($dloc$,Name $id$,Decl_kinds.Explicit,$c1$,$c2$) >>
       | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr ->
         <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >>
       (* fix todo *)
@@ -61,7 +56,7 @@ EXTEND
         <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ]
     | "90" RIGHTA
       [ c1 = constr; "->"; c2 = SELF ->
-        <:expr< Glob_term.GProd ($dloc$,Anonymous,Glob_term.Explicit,$c1$,$c2$) >> ]
+        <:expr< Glob_term.GProd ($dloc$,Anonymous,Decl_kinds.Explicit,$c1$,$c2$) >> ]
     | "75" RIGHTA
       [ "~"; c = constr ->
         apply_ref <:expr< coq_not_ref >> [c] ]
@@ -75,11 +70,11 @@ EXTEND
     | "0"
       [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >>
       | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >>
-      | "_" -> <:expr< Glob_term.GHole ($dloc$, QuestionMark (Define False)) >>
+      | "_" -> <:expr< Glob_term.GHole ($dloc$,Evar_kinds.QuestionMark (Evar_kinds.Define False),Misctypes.IntroAnonymous,None) >>
       | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >>
       | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" ->
           apply_ref <:expr< coq_sumbool_ref >> [c1;c2]
-      | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$) >>
+      | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$, None) >>
       | c = match_constr -> c
       | "("; c = constr LEVEL "200"; ")" -> c ] ]
   ;
@@ -123,4 +118,3 @@ EXTEND
 open Coqlib
 let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ]
 *)
-
diff --git a/parsing/q_coqast.ml4 b/grammar/q_coqast.ml4
index f5508352..dd97107f 100644
--- a/parsing/q_coqast.ml4
+++ b/grammar/q_coqast.ml4
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Libnames
 open Q_util
 open Compat
 
@@ -22,182 +20,221 @@ let anti loc x =
   expl_anti loc <:expr< $lid:purge_str x$ >>
 
 (* We don't give location for tactic quotation! *)
-let loc = dummy_loc
+let loc = CompatLoc.ghost
 
-let dloc = <:expr< Util.dummy_loc >>
+let dloc = <:expr< Loc.ghost >>
 
 let mlexpr_of_ident id =
-  <:expr< Names.id_of_string $str:Names.string_of_id id$ >>
+  <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >>
 
 let mlexpr_of_name = function
   | Names.Anonymous -> <:expr< Names.Anonymous >>
   | Names.Name id ->
-      <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >>
+      <:expr< Names.Name (Names.Id.of_string $str:Names.Id.to_string id$) >>
 
 let mlexpr_of_dirpath dir =
-  let l = Names.repr_dirpath dir in
-  <:expr< Names.make_dirpath $mlexpr_of_list mlexpr_of_ident l$ >>
+  let l = Names.DirPath.repr dir in
+  <:expr< Names.DirPath.make $mlexpr_of_list mlexpr_of_ident l$ >>
 
 let mlexpr_of_qualid qid =
-  let (dir, id) = repr_qualid qid in
-  <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >>
+  let (dir, id) = Libnames.repr_qualid qid in
+  <:expr< Libnames.make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >>
 
 let mlexpr_of_reference = function
-  | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >>
-  | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >>
+  | Libnames.Qualid (loc,qid) ->
+    let loc = of_coqloc loc in <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >>
+  | Libnames.Ident (loc,id) ->
+    let loc = of_coqloc loc in <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >>
 
-let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >>
+let mlexpr_of_union f g = function
+  | Util.Inl a -> <:expr< Util.Inl $f a$ >>
+  | Util.Inr b -> <:expr< Util.Inr $g b$ >>
+
+let mlexpr_of_located f (loc,x) =
+  let loc = of_coqloc loc in
+  <:expr< ($dloc$, $f x$) >>
 
 let mlexpr_of_loc loc = <:expr< $dloc$ >>
 
 let mlexpr_of_by_notation f = function
-  | Genarg.AN x -> <:expr< Genarg.AN $f x$ >>
-  | Genarg.ByNotation (loc,s,sco) ->
-      <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >>
+  | Misctypes.AN x -> <:expr< Misctypes.AN $f x$ >>
+  | Misctypes.ByNotation (loc,s,sco) ->
+      let loc = of_coqloc loc in
+      <:expr< Misctypes.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >>
+
+let mlexpr_of_global_flag = function
+  | Tacexpr.TacGlobal -> <:expr<Tacexpr.TacGlobal>>
+  | Tacexpr.TacLocal  -> <:expr<Tacexpr.TacLocal>>
+
+let mlexpr_of_intro_pattern_disjunctive = function
+  _ -> failwith "mlexpr_of_intro_pattern_disjunctive: TODO"
+
+let mlexpr_of_intro_pattern_naming = function
+  | Misctypes.IntroAnonymous -> <:expr< Misctypes.IntroAnonymous >>
+  | Misctypes.IntroFresh id -> <:expr< Misctypes.IntroFresh (mlexpr_of_ident $dloc$ id) >>
+  | Misctypes.IntroIdentifier id ->
+      <:expr< Misctypes.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
 
 let mlexpr_of_intro_pattern = function
-  | Genarg.IntroWildcard -> <:expr< Genarg.IntroWildcard >>
-  | Genarg.IntroAnonymous -> <:expr< Genarg.IntroAnonymous >>
-  | Genarg.IntroFresh id -> <:expr< Genarg.IntroFresh (mlexpr_of_ident $dloc$ id) >>
-  | Genarg.IntroForthcoming b -> <:expr< Genarg.IntroForthcoming (mlexpr_of_bool $dloc$ b) >>
-  | Genarg.IntroIdentifier id ->
-      <:expr< Genarg.IntroIdentifier (mlexpr_of_ident $dloc$ id) >>
-  | Genarg.IntroOrAndPattern _ | Genarg.IntroRewrite _ ->
+  | Misctypes.IntroForthcoming b -> <:expr< Misctypes.IntroForthcoming (mlexpr_of_bool $dloc$ b) >>
+  | Misctypes.IntroNaming pat ->
+      <:expr< Misctypes.IntroNaming $mlexpr_of_intro_pattern_naming pat$ >>
+  | Misctypes.IntroAction _ ->
       failwith "mlexpr_of_intro_pattern: TODO"
 
 let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident)
 
-let mlexpr_of_or_metaid f = function
-  | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >>
-  | Tacexpr.MetaId (_,id) -> <:expr< Tacexpr.AI $anti loc id$ >>
-
 let mlexpr_of_quantified_hypothesis = function
-  | Glob_term.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >>
-  | Glob_term.NamedHyp id ->  <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >>
+  | Misctypes.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >>
+  | Misctypes.NamedHyp id ->  <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >>
 
 let mlexpr_of_or_var f = function
-  | Glob_term.ArgArg x -> <:expr< Glob_term.ArgArg $f x$ >>
-  | Glob_term.ArgVar id -> <:expr< Glob_term.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
+  | Misctypes.ArgArg x -> <:expr< Misctypes.ArgArg $f x$ >>
+  | Misctypes.ArgVar id -> <:expr< Misctypes.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >>
 
-let mlexpr_of_hyp = mlexpr_of_or_metaid (mlexpr_of_located mlexpr_of_ident)
+let mlexpr_of_hyp = (mlexpr_of_located mlexpr_of_ident)
 
-let mlexpr_of_occs =
-  mlexpr_of_pair
-    mlexpr_of_bool (mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int))
+let mlexpr_of_occs = function
+  | Locus.AllOccurrences -> <:expr< Locus.AllOccurrences >>
+  | Locus.AllOccurrencesBut l ->
+    <:expr< Locus.AllOccurrencesBut
+      $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >>
+  | Locus.NoOccurrences -> <:expr< Locus.NoOccurrences >>
+  | Locus.OnlyOccurrences l ->
+    <:expr< Locus.OnlyOccurrences
+      $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >>
 
 let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f
 
 let mlexpr_of_hyp_location = function
-  | occs, Termops.InHyp ->
-      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHyp) >>
-  | occs, Termops.InHypTypeOnly ->
-      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypTypeOnly) >>
-  | occs, Termops.InHypValueOnly ->
-      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Termops.InHypValueOnly) >>
+  | occs, Locus.InHyp ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHyp) >>
+  | occs, Locus.InHypTypeOnly ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypTypeOnly) >>
+  | occs, Locus.InHypValueOnly ->
+      <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypValueOnly) >>
 
 let mlexpr_of_clause cl =
-  <:expr< {Tacexpr.onhyps=
+  <:expr< {Locus.onhyps=
              $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location)
-               cl.Tacexpr.onhyps$;
-           Tacexpr.concl_occs= $mlexpr_of_occs cl.Tacexpr.concl_occs$} >>
+               cl.Locus.onhyps$;
+           Locus.concl_occs= $mlexpr_of_occs cl.Locus.concl_occs$} >>
 
 let mlexpr_of_red_flags {
-  Glob_term.rBeta = bb;
-  Glob_term.rIota = bi;
-  Glob_term.rZeta = bz;
-  Glob_term.rDelta = bd;
-  Glob_term.rConst = l
+  Genredexpr.rBeta = bb;
+  Genredexpr.rIota = bi;
+  Genredexpr.rZeta = bz;
+  Genredexpr.rDelta = bd;
+  Genredexpr.rConst = l
 } = <:expr< {
-  Glob_term.rBeta = $mlexpr_of_bool bb$;
-  Glob_term.rIota = $mlexpr_of_bool bi$;
-  Glob_term.rZeta = $mlexpr_of_bool bz$;
-  Glob_term.rDelta = $mlexpr_of_bool bd$;
-  Glob_term.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$
+  Genredexpr.rBeta = $mlexpr_of_bool bb$;
+  Genredexpr.rIota = $mlexpr_of_bool bi$;
+  Genredexpr.rZeta = $mlexpr_of_bool bz$;
+  Genredexpr.rDelta = $mlexpr_of_bool bd$;
+  Genredexpr.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$
 } >>
 
+let mlexpr_of_instance c = <:expr< None >>
+
 let mlexpr_of_explicitation = function
-  | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >>
-  | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >>
+  | Constrexpr.ExplByName id -> <:expr< Constrexpr.ExplByName $mlexpr_of_ident id$ >>
+  | Constrexpr.ExplByPos (n,_id) -> <:expr< Constrexpr.ExplByPos $mlexpr_of_int n$ >>
 
 let mlexpr_of_binding_kind = function
-  | Glob_term.Implicit -> <:expr< Glob_term.Implicit >>
-  | Glob_term.Explicit -> <:expr< Glob_term.Explicit >>
+  | Decl_kinds.Implicit -> <:expr< Decl_kinds.Implicit >>
+  | Decl_kinds.Explicit -> <:expr< Decl_kinds.Explicit >>
 
 let mlexpr_of_binder_kind = function
-  | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >>
-  | Topconstr.Generalized (b,b',b'') ->
-      <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$
+  | Constrexpr.Default b -> <:expr< Constrexpr.Default $mlexpr_of_binding_kind b$ >>
+  | Constrexpr.Generalized (b,b',b'') ->
+      <:expr< Constrexpr.TypeClass $mlexpr_of_binding_kind b$
 	$mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >>
 
 let rec mlexpr_of_constr = function
-  | Topconstr.CRef (Libnames.Ident (loc,id)) when is_meta (string_of_id id) ->
-      anti loc (string_of_id id)
-  | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >>
-  | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
-  | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
-  | Topconstr.CArrow (loc,a,b) ->
-  <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >>
-  | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list
+  | Constrexpr.CRef (Libnames.Ident (loc,id),_) when is_meta (Id.to_string id) ->
+      let loc = of_coqloc loc in
+      anti loc (Id.to_string id)
+  | Constrexpr.CRef (r,n) -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ None >>
+  | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Constrexpr.CProdN (loc,l,a) ->
+      let loc = of_coqloc loc in
+      <:expr< Constrexpr.CProdN $dloc$ $mlexpr_of_list
       (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
-  | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
-  | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
-  | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >>
-  | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >>
-  | Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO"
-  | Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >>
-  | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)"
-  | Topconstr.CNotation(_,ntn,(subst,substl,[])) ->
-      <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$
+  | Constrexpr.CLambdaN (loc,l,a) ->
+    let loc = of_coqloc loc in
+    <:expr< Constrexpr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >>
+  | Constrexpr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Constrexpr.CAppExpl (loc,(p,r,us),l) ->
+    let loc = of_coqloc loc in
+    let a = (p,r,us) in
+    <:expr< Constrexpr.CAppExpl $dloc$ $mlexpr_of_triple (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference mlexpr_of_instance a$ $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Constrexpr.CApp (loc,a,l) ->
+    let loc = of_coqloc loc in
+    <:expr< Constrexpr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >>
+  | Constrexpr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO"
+  | Constrexpr.CHole (loc, None, ipat, None) ->
+    let loc = of_coqloc loc in
+    <:expr< Constrexpr.CHole $dloc$ None $mlexpr_of_intro_pattern_naming ipat$ None >>
+  | Constrexpr.CHole (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO CHole (Some _)"
+  | Constrexpr.CNotation(_,ntn,(subst,substl,[])) ->
+      <:expr< Constrexpr.CNotation $dloc$ $mlexpr_of_string ntn$
               ($mlexpr_of_list mlexpr_of_constr subst$,
                $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >>
-  | Topconstr.CPatVar (loc,n) ->
-      <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >>
+  | Constrexpr.CPatVar (loc,n) ->
+      let loc = of_coqloc loc in
+      <:expr< Constrexpr.CPatVar $dloc$ $mlexpr_of_ident n$ >>
+  | Constrexpr.CEvar (loc,n,[]) ->
+      let loc = of_coqloc loc in
+      <:expr< Constrexpr.CEvar $dloc$ $mlexpr_of_ident n$ [] >>
   | _ -> failwith "mlexpr_of_constr: TODO"
 
 let mlexpr_of_occ_constr =
   mlexpr_of_occurrences mlexpr_of_constr
 
+let mlexpr_of_occ_ref_or_constr =
+  mlexpr_of_occurrences
+    (mlexpr_of_union
+       (mlexpr_of_by_notation mlexpr_of_reference) mlexpr_of_constr)
+
 let mlexpr_of_red_expr = function
-  | Glob_term.Red b -> <:expr< Glob_term.Red $mlexpr_of_bool b$ >>
-  | Glob_term.Hnf -> <:expr< Glob_term.Hnf >>
-  | Glob_term.Simpl o -> <:expr< Glob_term.Simpl $mlexpr_of_option mlexpr_of_occ_constr o$ >>
-  | Glob_term.Cbv f ->
-      <:expr< Glob_term.Cbv $mlexpr_of_red_flags f$ >>
-  | Glob_term.Lazy f ->
-      <:expr< Glob_term.Lazy $mlexpr_of_red_flags f$ >>
-  | Glob_term.Unfold l ->
+  | Genredexpr.Red b -> <:expr< Genredexpr.Red $mlexpr_of_bool b$ >>
+  | Genredexpr.Hnf -> <:expr< Genredexpr.Hnf >>
+  | Genredexpr.Simpl (f,o) ->
+      <:expr< Genredexpr.Simpl $mlexpr_of_red_flags f$ $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >>
+  | Genredexpr.Cbv f ->
+      <:expr< Genredexpr.Cbv $mlexpr_of_red_flags f$ >>
+  | Genredexpr.Cbn f ->
+      <:expr< Genredexpr.Cbn $mlexpr_of_red_flags f$ >>
+  | Genredexpr.Lazy f ->
+      <:expr< Genredexpr.Lazy $mlexpr_of_red_flags f$ >>
+  | Genredexpr.Unfold l ->
       let f1 = mlexpr_of_by_notation mlexpr_of_reference in
       let f = mlexpr_of_list (mlexpr_of_occurrences f1) in
-      <:expr< Glob_term.Unfold $f l$ >>
-  | Glob_term.Fold l ->
-      <:expr< Glob_term.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
-  | Glob_term.Pattern l ->
+      <:expr< Genredexpr.Unfold $f l$ >>
+  | Genredexpr.Fold l ->
+      <:expr< Genredexpr.Fold $mlexpr_of_list mlexpr_of_constr l$ >>
+  | Genredexpr.Pattern l ->
       let f = mlexpr_of_list mlexpr_of_occ_constr in
-      <:expr< Glob_term.Pattern $f l$ >>
-  | Glob_term.CbvVm -> <:expr< Glob_term.CbvVm >>
-  | Glob_term.ExtraRedExpr s ->
-      <:expr< Glob_term.ExtraRedExpr $mlexpr_of_string s$ >>
+      <:expr< Genredexpr.Pattern $f l$ >>
+  | Genredexpr.CbvVm o -> <:expr< Genredexpr.CbvVm $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >>
+  | Genredexpr.CbvNative o -> <:expr< Genredexpr.CbvNative $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >>
+  | Genredexpr.ExtraRedExpr s ->
+      <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >>
 
 let rec mlexpr_of_argtype loc = function
-  | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >>
-  | Genarg.IntArgType -> <:expr< Genarg.IntArgType >>
   | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >>
-  | Genarg.RefArgType -> <:expr< Genarg.RefArgType >>
-  | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >>
-  | Genarg.IntroPatternArgType -> <:expr< Genarg.IntroPatternArgType >>
-  | Genarg.IdentArgType b -> <:expr< Genarg.IdentArgType $mlexpr_of_bool b$ >>
+  | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >>
   | Genarg.VarArgType -> <:expr< Genarg.VarArgType >>
-  | Genarg.StringArgType -> <:expr< Genarg.StringArgType >>
   | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >>
-  | Genarg.OpenConstrArgType (b1,b2) -> <:expr< Genarg.OpenConstrArgType ($mlexpr_of_bool b1$, $mlexpr_of_bool b2$) >>
+  | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >>
   | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >>
   | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >>
   | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >>
-  | Genarg.SortArgType -> <:expr< Genarg.SortArgType >>
+  | Genarg.GenArgType -> <:expr< Genarg.GenArgType >>
   | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >>
   | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >>
-  | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >>
-  | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >>
+  | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >>
   | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >>
   | Genarg.PairArgType (t1,t2) ->
       let t1 = mlexpr_of_argtype loc t1 in
@@ -205,36 +242,41 @@ let rec mlexpr_of_argtype loc = function
       <:expr< Genarg.PairArgType $t1$ $t2$ >>
   | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >>
 
-let rec mlexpr_of_may_eval f = function
-  | Glob_term.ConstrEval (r,c) ->
-      <:expr< Glob_term.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
-  | Glob_term.ConstrContext ((loc,id),c) ->
+let mlexpr_of_may_eval f = function
+  | Genredexpr.ConstrEval (r,c) ->
+      <:expr< Genredexpr.ConstrEval $mlexpr_of_red_expr r$ $f c$ >>
+  | Genredexpr.ConstrContext ((loc,id),c) ->
+      let loc = of_coqloc loc in
       let id = mlexpr_of_ident id in
-      <:expr< Glob_term.ConstrContext (loc,$id$) $f c$ >>
-  | Glob_term.ConstrTypeOf c ->
-      <:expr< Glob_term.ConstrTypeOf $mlexpr_of_constr c$ >>
-  | Glob_term.ConstrTerm c ->
-      <:expr< Glob_term.ConstrTerm $mlexpr_of_constr c$ >>
+      <:expr< Genredexpr.ConstrContext (loc,$id$) $f c$ >>
+  | Genredexpr.ConstrTypeOf c ->
+      <:expr< Genredexpr.ConstrTypeOf $mlexpr_of_constr c$ >>
+  | Genredexpr.ConstrTerm c ->
+      <:expr< Genredexpr.ConstrTerm $mlexpr_of_constr c$ >>
 
 let mlexpr_of_binding_kind = function
-  | Glob_term.ExplicitBindings l ->
+  | Misctypes.ExplicitBindings l ->
       let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in
-      <:expr< Glob_term.ExplicitBindings $l$ >>
-  | Glob_term.ImplicitBindings l ->
+      <:expr< Misctypes.ExplicitBindings $l$ >>
+  | Misctypes.ImplicitBindings l ->
       let l = mlexpr_of_list mlexpr_of_constr l in
-      <:expr< Glob_term.ImplicitBindings $l$ >>
-  | Glob_term.NoBindings ->
-       <:expr< Glob_term.NoBindings >>
+      <:expr< Misctypes.ImplicitBindings $l$ >>
+  | Misctypes.NoBindings ->
+       <:expr< Misctypes.NoBindings >>
 
 let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr
 
 let mlexpr_of_constr_with_binding =
   mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind
 
+let mlexpr_of_constr_with_binding_arg =
+  mlexpr_of_pair (mlexpr_of_option mlexpr_of_bool) mlexpr_of_constr_with_binding
+
 let mlexpr_of_move_location f = function
-  | Tacexpr.MoveAfter id -> <:expr< Tacexpr.MoveAfter $f id$ >>
-  | Tacexpr.MoveBefore id -> <:expr< Tacexpr.MoveBefore $f id$ >>
-  | Tacexpr.MoveToEnd b -> <:expr< Tacexpr.MoveToEnd $mlexpr_of_bool b$ >>
+  | Misctypes.MoveAfter id -> <:expr< Misctypes.MoveAfter $f id$ >>
+  | Misctypes.MoveBefore id -> <:expr< Misctypes.MoveBefore $f id$ >>
+  | Misctypes.MoveFirst -> <:expr< Misctypes.MoveFirst >>
+  | Misctypes.MoveLast -> <:expr< Misctypes.MoveLast >>
 
 let mlexpr_of_induction_arg = function
   | Tacexpr.ElimOnConstr c ->
@@ -251,6 +293,11 @@ let mlexpr_of_pattern_ast = mlexpr_of_constr
 let mlexpr_of_entry_type = function
     _ -> failwith "mlexpr_of_entry_type: TODO"
 
+let mlexpr_of_match_lazy_flag = function
+  | Tacexpr.General -> <:expr<Tacexpr.General>>
+  | Tacexpr.Select    -> <:expr<Tacexpr.Select>>
+  | Tacexpr.Once    -> <:expr<Tacexpr.Once>>
+
 let mlexpr_of_match_pattern = function
   | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >>
   | Tacexpr.Subterm (b,ido,t) ->
@@ -283,59 +330,44 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacIntroPattern pl ->
       let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in
       <:expr< Tacexpr.TacIntroPattern $pl$ >>
-  | Tacexpr.TacIntrosUntil h ->
-      <:expr< Tacexpr.TacIntrosUntil $mlexpr_of_quantified_hypothesis h$ >>
   | Tacexpr.TacIntroMove (idopt,idopt') ->
       let idopt = mlexpr_of_ident_option idopt in
       let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in
       <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >>
-  | Tacexpr.TacAssumption ->
-      <:expr< Tacexpr.TacAssumption >>
   | Tacexpr.TacExact c ->
       <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >>
-  | Tacexpr.TacExactNoCheck c ->
-      <:expr< Tacexpr.TacExactNoCheck $mlexpr_of_constr c$ >>
-  | Tacexpr.TacVmCastNoCheck c ->
-      <:expr< Tacexpr.TacVmCastNoCheck $mlexpr_of_constr c$ >>
   | Tacexpr.TacApply (b,false,cb,None) ->
-      <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding cb$ None >>
+      <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding_arg cb$ None >>
   | Tacexpr.TacElim (false,cb,cbo) ->
-      let cb = mlexpr_of_constr_with_binding cb in
+      let cb = mlexpr_of_constr_with_binding_arg cb in
       let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in
       <:expr< Tacexpr.TacElim False $cb$ $cbo$ >>
-  | Tacexpr.TacElimType c ->
-      <:expr< Tacexpr.TacElimType $mlexpr_of_constr c$ >>
   | Tacexpr.TacCase (false,cb) ->
-      let cb = mlexpr_of_constr_with_binding cb in
+      let cb = mlexpr_of_constr_with_binding_arg cb in
       <:expr< Tacexpr.TacCase False $cb$ >>
-  | Tacexpr.TacCaseType c ->
-      <:expr< Tacexpr.TacCaseType $mlexpr_of_constr c$ >>
   | Tacexpr.TacFix (ido,n) ->
       let ido = mlexpr_of_ident_option ido in
       let n = mlexpr_of_int n in
       <:expr< Tacexpr.TacFix $ido$ $n$ >>
-  | Tacexpr.TacMutualFix (b,id,n,l) ->
-      let b = mlexpr_of_bool b in
+  | Tacexpr.TacMutualFix (id,n,l) ->
       let id = mlexpr_of_ident id in
       let n = mlexpr_of_int n in
       let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in
       let l = mlexpr_of_list f l in
-      <:expr< Tacexpr.TacMutualFix $b$ $id$ $n$ $l$ >>
+      <:expr< Tacexpr.TacMutualFix $id$ $n$ $l$ >>
   | Tacexpr.TacCofix ido ->
       let ido = mlexpr_of_ident_option ido in
       <:expr< Tacexpr.TacCofix $ido$ >>
-  | Tacexpr.TacMutualCofix (b,id,l) ->
-      let b = mlexpr_of_bool b in
+  | Tacexpr.TacMutualCofix (id,l) ->
       let id = mlexpr_of_ident id in
       let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in
       let l = mlexpr_of_list f l in
-      <:expr< Tacexpr.TacMutualCofix $b$ $id$ $l$ >>
+      <:expr< Tacexpr.TacMutualCofix $id$ $l$ >>
 
-  | Tacexpr.TacCut c ->
-      <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >>
-  | Tacexpr.TacAssert (t,ipat,c) ->
+  | Tacexpr.TacAssert (b,t,ipat,c) ->
       let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in
-      <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$
+      <:expr< Tacexpr.TacAssert $mlexpr_of_bool b$
+              $mlexpr_of_option mlexpr_of_tactic t$ $ipat$
 	      $mlexpr_of_constr c$ >>
   | Tacexpr.TacGeneralize cl ->
       <:expr< Tacexpr.TacGeneralize
@@ -352,20 +384,20 @@ let rec mlexpr_of_atomic_tactic = function
       >>
 
   (* Derived basic tactics *)
-  | Tacexpr.TacSimpleInductionDestruct (isrec,h) ->
-      <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$
-                  $mlexpr_of_quantified_hypothesis h$ >>
   | Tacexpr.TacInductionDestruct (isrec,ev,l) ->
       <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$
-	$mlexpr_of_triple
+	$mlexpr_of_pair
 	(mlexpr_of_list
-	   (mlexpr_of_pair
-	      mlexpr_of_induction_arg
+	   (mlexpr_of_triple
 	      (mlexpr_of_pair
-		 (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern))
-		 (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern)))))
+                 (mlexpr_of_option mlexpr_of_bool)
+                 mlexpr_of_induction_arg)
+	      (mlexpr_of_pair
+		 (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern_naming))
+		 (mlexpr_of_option (mlexpr_of_intro_pattern_disjunctive)))
+	      (mlexpr_of_option mlexpr_of_clause)))
 	(mlexpr_of_option mlexpr_of_constr_with_binding)
-	(mlexpr_of_option mlexpr_of_clause) l$ >>
+ l$ >>
 
   (* Context management *)
   | Tacexpr.TacClear (b,l) ->
@@ -374,25 +406,15 @@ let rec mlexpr_of_atomic_tactic = function
   | Tacexpr.TacClearBody l ->
       let l = mlexpr_of_list (mlexpr_of_hyp) l in
       <:expr< Tacexpr.TacClearBody $l$ >>
-  | Tacexpr.TacMove (dep,id1,id2) ->
-      <:expr< Tacexpr.TacMove $mlexpr_of_bool dep$
+  | Tacexpr.TacMove (id1,id2) ->
+      <:expr< Tacexpr.TacMove
               $mlexpr_of_hyp id1$
               $mlexpr_of_move_location mlexpr_of_hyp id2$ >>
 
   (* Constructors *)
-  | Tacexpr.TacLeft (ev,l) ->
-      <:expr< Tacexpr.TacLeft $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>>
-  | Tacexpr.TacRight (ev,l) ->
-      <:expr< Tacexpr.TacRight $mlexpr_of_bool ev$ $mlexpr_of_binding_kind l$>>
-  | Tacexpr.TacSplit (ev,b,l) ->
+  | Tacexpr.TacSplit (ev,l) ->
       <:expr< Tacexpr.TacSplit
-        ($mlexpr_of_bool ev$,$mlexpr_of_bool b$,$mlexpr_of_list mlexpr_of_binding_kind l$)>>
-  | Tacexpr.TacAnyConstructor (ev,t) ->
-      <:expr< Tacexpr.TacAnyConstructor $mlexpr_of_bool ev$ $mlexpr_of_option mlexpr_of_tactic t$>>
-  | Tacexpr.TacConstructor (ev,n,l) ->
-      let n = mlexpr_of_or_var mlexpr_of_int n in
-      <:expr< Tacexpr.TacConstructor $mlexpr_of_bool ev$ $n$ $mlexpr_of_binding_kind l$>>
-
+        ($mlexpr_of_bool ev$, $mlexpr_of_list mlexpr_of_binding_kind l$)>>
   (* Conversion *)
   | Tacexpr.TacReduce (r,cl) ->
       let l = mlexpr_of_clause cl in
@@ -403,9 +425,7 @@ let rec mlexpr_of_atomic_tactic = function
       <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >>
 
   (* Equivalence relations *)
-  | Tacexpr.TacReflexivity -> <:expr< Tacexpr.TacReflexivity >>
   | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >>
-  | Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >>
 
   (* Automation tactics *)
   | Tacexpr.TacAuto (debug,n,lems,l) ->
@@ -424,9 +444,10 @@ let rec mlexpr_of_atomic_tactic = function
 
 and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
   | Tacexpr.TacAtom (loc,t) ->
+      let loc = of_coqloc loc in
       <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >>
-  | Tacexpr.TacThen (t1,[||],t2,[||]) ->
-      <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ [||] $mlexpr_of_tactic t2$ [||]>>
+  | Tacexpr.TacThen (t1,t2) ->
+      <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$>>
   | Tacexpr.TacThens (t,tl) ->
       <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>>
   | Tacexpr.TacFirst tl ->
@@ -435,6 +456,8 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >>
   | Tacexpr.TacTry t ->
       <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacOr (t1,t2) ->
+      <:expr< Tacexpr.TacOr $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
   | Tacexpr.TacOrelse (t1,t2) ->
       <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >>
   | Tacexpr.TacDo (n,t) ->
@@ -445,10 +468,12 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >>
   | Tacexpr.TacProgress t ->
       <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >>
+  | Tacexpr.TacShowHyps t ->
+      <:expr< Tacexpr.TacShowHyps $mlexpr_of_tactic t$ >>
   | Tacexpr.TacId l ->
       <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >>
-  | Tacexpr.TacFail (n,l) ->
-      <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >>
+  | Tacexpr.TacFail (g,n,l) ->
+      <:expr< Tacexpr.TacFail $mlexpr_of_global_flag g$ $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >>
 (*
   | Tacexpr.TacInfo t -> TacInfo (loc,f t)
 
@@ -463,12 +488,12 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
       <:expr< Tacexpr.TacLetIn $mlexpr_of_bool isrec$ $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >>
   | Tacexpr.TacMatch (lz,t,l) ->
       <:expr< Tacexpr.TacMatch
-        $mlexpr_of_bool lz$
+        $mlexpr_of_match_lazy_flag lz$
         $mlexpr_of_tactic t$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
   | Tacexpr.TacMatchGoal (lz,lr,l) ->
       <:expr< Tacexpr.TacMatchGoal
-        $mlexpr_of_bool lz$
+        $mlexpr_of_match_lazy_flag lz$
         $mlexpr_of_bool lr$
         $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>>
 
@@ -484,11 +509,15 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function
   | _ -> failwith "Quotation of tactic expressions: TODO"
 
 and mlexpr_of_tactic_arg = function
-  | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id
+  | Tacexpr.MetaIdArg (loc,true,id) ->
+    let loc = of_coqloc loc in
+    anti loc id
   | Tacexpr.MetaIdArg (loc,false,id) ->
-      <:expr< Tacexpr.ConstrMayEval (Glob_term.ConstrTerm $anti loc id$) >>
+    let loc = of_coqloc loc in
+    <:expr< Tacexpr.ConstrMayEval (Genredexpr.ConstrTerm $anti loc id$) >>
   | Tacexpr.TacCall (loc,t,tl) ->
-      <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>>
+    let loc = of_coqloc loc in
+    <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>>
   | Tacexpr.Tacexp t ->
       <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >>
   | Tacexpr.ConstrMayEval c ->
diff --git a/parsing/q_util.ml4 b/grammar/q_util.ml4
index 947e7e54..18b1ccd3 100644
--- a/parsing/q_util.ml4
+++ b/grammar/q_util.ml4
@@ -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,35 +8,33 @@
 
 (* This file defines standard combinators to build ml expressions *)
 
-open Extrawit
 open Compat
-open Util
 
 let mlexpr_of_list f l =
   List.fold_right
     (fun e1 e2 ->
       let e1 = f e1 in
-       let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
+       let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
        <:expr< [$e1$ :: $e2$] >>)
-    l (let loc = dummy_loc in <:expr< [] >>)
+    l (let loc = CompatLoc.ghost in <:expr< [] >>)
 
 let mlexpr_of_pair m1 m2 (a1,a2) =
   let e1 = m1 a1 and e2 = m2 a2 in
-  let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
+  let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in
   <:expr< ($e1$, $e2$) >>
 
 let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)=
   let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in
-  let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in
+  let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in
   <:expr< ($e1$, $e2$, $e3$) >>
 
 let mlexpr_of_quadruple m1 m2 m3 m4 (a1,a2,a3,a4)=
   let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 and e4 = m4 a4 in
-  let loc = join_loc (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in
+  let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in
   <:expr< ($e1$, $e2$, $e3$, $e4$) >>
 
 (* We don't give location for tactic quotation! *)
-let loc = dummy_loc
+let loc = CompatLoc.ghost
 
 
 let mlexpr_of_bool = function
@@ -51,9 +49,6 @@ let mlexpr_of_option f = function
   | None -> <:expr< None >>
   | Some e -> <:expr< Some $f e$ >>
 
-open Vernacexpr
-open Genarg
-
 let rec mlexpr_of_prod_entry_key = function
   | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >>
   | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >>
@@ -64,6 +59,6 @@ let rec mlexpr_of_prod_entry_key = function
   | Pcoq.Aself -> <:expr< Pcoq.Aself >>
   | Pcoq.Anext -> <:expr< Pcoq.Anext >>
   | Pcoq.Atactic n -> <:expr< Pcoq.Atactic $mlexpr_of_int n$ >>
-  | Pcoq.Agram s -> Util.anomaly "Agram not supported"
-  | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.obj $lid:s$) >>
+  | Pcoq.Agram s -> Errors.anomaly (Pp.str "Agram not supported")
+  | Pcoq.Aentry ("",s) -> <:expr< Pcoq.Agram (Pcoq.Gram.Entry.name $lid:s$) >>
   | Pcoq.Aentry (u,s) -> <:expr< Pcoq.Aentry $str:u$ $str:s$ >>
diff --git a/parsing/q_util.mli b/grammar/q_util.mli
index babbfb8a..7393a0d5 100644
--- a/parsing/q_util.mli
+++ b/grammar/q_util.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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 Compat (* necessary for camlp4 *)
 
 val mlexpr_of_list :  ('a -> MLast.expr) -> 'a list -> MLast.expr
 
diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4
new file mode 100644
index 00000000..0421ad7c
--- /dev/null
+++ b/grammar/tacextend.ml4
@@ -0,0 +1,281 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "tools/compat5b.cmo" i*)
+
+open Util
+open Pp
+open Names
+open Genarg
+open Q_util
+open Q_coqast
+open Argextend
+open Pcoq
+open Egramml
+open Compat
+
+let dloc = <:expr< Loc.ghost >>
+
+let plugin_name = <:expr< __coq_plugin_name >>
+
+let rec make_patt = function
+  | [] -> <:patt< [] >>
+  | GramNonTerminal(loc',_,_,Some p)::l ->
+      let p = Names.Id.to_string p in
+      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
+  | _::l -> make_patt l
+
+let rec make_when loc = function
+  | [] -> <:expr< True >>
+  | GramNonTerminal(loc',t,_,Some p)::l ->
+      let loc' = of_coqloc loc' in
+      let p = Names.Id.to_string p in
+      let l = make_when loc l in
+      let loc = CompatLoc.merge loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >>
+  | _::l -> make_when loc l
+
+let rec make_let raw e = function
+  | [] -> <:expr< fun $lid:"ist"$ -> $e$ >>
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let loc = of_coqloc loc in
+      let p = Names.Id.to_string p in
+      let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in
+      let e = make_let raw e l in
+      let v =
+        if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >>
+               else <:expr< Genarg.out_gen $make_topwit    loc t$ $lid:p$ >> in
+      <:expr< let $lid:p$ = $v$ in $e$ >>
+  | _::l -> make_let raw e l
+
+let rec extract_signature = function
+  | [] -> []
+  | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
+  | _::l -> extract_signature l
+
+
+
+let check_unicity s l =
+  let l' = List.map (fun (l,_,_) -> extract_signature l) l in
+  if not (Util.List.distinct l') then
+    Pp.msg_warning
+      (strbrk ("Two distinct rules of tactic entry "^s^" have the same "^
+      "non-terminals in the same order: put them in distinct tactic entries"))
+
+let make_clause (pt,_,e) =
+  (make_patt pt,
+   vala (Some (make_when (MLast.loc_of_expr e) pt)),
+   make_let false e pt)
+
+let make_fun_clauses loc s l =
+  check_unicity s l;
+  Compat.make_fun loc (List.map make_clause l)
+
+let rec make_args = function
+  | [] -> <:expr< [] >>
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let loc = of_coqloc loc in
+      let p = Names.Id.to_string p in
+      <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >>
+  | _::l -> make_args l
+
+let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function
+  | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >>
+  | GramNonTerminal (loc,nt,_,sopt) ->
+    let loc = of_coqloc loc in <:expr< None >>
+
+let make_prod_item = function
+  | GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >>
+  | GramNonTerminal (loc,nt,g,sopt) ->
+      let loc = of_coqloc loc in
+      <:expr< Egramml.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$
+      $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >>
+
+let mlexpr_of_clause =
+  mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a)
+
+let rec make_tags loc = function
+  | [] -> <:expr< [] >>
+  | GramNonTerminal(loc',t,_,Some p)::l ->
+      let loc' = of_coqloc loc' in
+      let l = make_tags loc l in
+      let loc = CompatLoc.merge loc' loc in
+      let t = mlexpr_of_argtype loc' t in
+      <:expr< [ $t$ :: $l$ ] >>
+  | _::l -> make_tags loc l
+
+let make_one_printing_rule se (pt,_,e) =
+  let level = mlexpr_of_int 0 in (* only level 0 supported here *)
+  let loc = MLast.loc_of_expr e in
+  let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in
+  <:expr< ($se$, { Pptactic.pptac_args = $make_tags loc pt$;
+            pptac_prods = ($level$, $prods$) }) >>
+
+let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
+
+let make_empty_check = function
+| GramNonTerminal(_, t, e, _)->
+  let is_extra = match t with ExtraArgType _ -> true | _ -> false in
+  if is_possibly_empty e || is_extra then
+    (* This possibly parses epsilon *)
+    let wit = make_wit loc t in
+    let rawwit = make_rawwit loc t in
+    <:expr<
+      match Genarg.default_empty_value $wit$ with
+      [ None -> raise Exit
+      | Some v ->
+        Tacintern.intern_genarg Tacintern.fully_empty_glob_sign
+          (Genarg.in_gen $rawwit$ v) ] >>
+  else
+  (* This does not parse epsilon (this Exit is static time) *)
+    raise Exit
+| GramTerminal _ ->
+  (* Idem *)
+  raise Exit
+
+let rec possibly_empty_subentries loc = function
+  | [] -> []
+  | (s,prodsl) :: l ->
+    let rec aux = function
+    | [] -> (false,<:expr< None >>)
+    | prods :: rest ->
+      try
+        let l = List.map make_empty_check prods in
+        if has_extraarg prods then
+          (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$
+                        with [ Exit -> $snd (aux rest)$ ] >>)
+        else
+          (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>)
+      with Exit -> aux rest in
+    let (nonempty,v) = aux prodsl in
+    if nonempty then (s,v) :: possibly_empty_subentries loc l
+    else possibly_empty_subentries loc l
+
+let possibly_atomic loc prods =
+  let l = List.map_filter (function
+    | GramTerminal s :: l, _, _ -> Some (s,l)
+    | _ -> None) prods
+  in
+  possibly_empty_subentries loc (List.factorize_left String.equal l)
+
+(** Special treatment of constr entries *)
+let is_constr_gram = function
+| GramTerminal _ -> false
+| GramNonTerminal (_, _, e, _) ->
+  match e with
+  | Aentry ("constr", "constr") -> true
+  | _ -> false
+
+let make_vars len =
+  (** We choose names unlikely to be written by a human, even though that
+      does not matter at all. *)
+  List.init len (fun i -> Some (Id.of_string (Printf.sprintf "_%i" i)))
+
+let declare_tactic loc s c cl = match cl with
+| [(GramTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem ->
+  (** The extension is only made of a name followed by constr entries: we do not
+      add any grammar nor printing rule and add it as a true Ltac definition. *)
+  let patt = make_patt rem in
+  let vars = make_vars (List.length rem) in
+  let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in
+  let entry = mlexpr_of_string s in
+  let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
+  let name = mlexpr_of_string name in
+  let tac =
+    (** Special handling of tactics without arguments: such tactics do not do
+        a Proofview.Goal.nf_enter to compute their arguments. It matters for some
+        whole-prof tactics like [shelve_unifiable]. *)
+    if List.is_empty rem then
+      <:expr< fun _ $lid:"ist"$ -> $tac$ >>
+    else
+      let f = Compat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in
+      <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >>
+  in
+  (** Arguments are not passed directly to the ML tactic in the TacML node,
+      the ML tactic retrieves its arguments in the [ist] environment instead.
+      This is the rôle of the [lift_constr_tac_to_ml_tac] function. *)
+  let body = <:expr< Tacexpr.TacFun ($vars$, Tacexpr.TacML ($dloc$, $se$, [])) >> in
+  let name = <:expr< Names.Id.of_string $name$ >> in
+  declare_str_items loc
+    [ <:str_item< do {
+      let obj () = Tacenv.register_ltac True False $name$ $body$ in
+      try do {
+        Tacenv.register_ml_tactic $se$ $tac$;
+        Mltop.declare_cache_obj obj $plugin_name$; }
+      with [ e when Errors.noncritical e ->
+        Pp.msg_warning
+          (Pp.app
+            (Pp.str ("Exception in tactic extend " ^ $entry$ ^": "))
+            (Errors.print e)) ]; } >>
+    ]
+| _ ->
+  (** Otherwise we add parsing and printing rules to generate a call to a
+      TacML tactic. *)
+  let entry = mlexpr_of_string s in
+  let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in
+  let pp = make_printing_rule se cl in
+  let gl = mlexpr_of_clause cl in
+  let atom =
+    mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x))
+      (possibly_atomic loc cl) in
+  let obj = <:expr< fun () -> Metasyntax.add_ml_tactic_notation $se$ $gl$ $atom$ >> in
+  declare_str_items loc
+    [ <:str_item< do {
+      try do {
+        Tacenv.register_ml_tactic $se$ $make_fun_clauses loc s cl$;
+        Mltop.declare_cache_obj $obj$ $plugin_name$;
+        List.iter (fun (s, r) -> Pptactic.declare_ml_tactic_pprule s r) $pp$; }
+      with [ e when Errors.noncritical e ->
+        Pp.msg_warning
+          (Pp.app
+            (Pp.str ("Exception in tactic extend " ^ $entry$ ^": "))
+            (Errors.print e)) ]; } >>
+    ]
+
+open Pcaml
+open PcamlSig (* necessary for camlp4 *)
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "TACTIC"; "EXTEND"; s = tac_name;
+        c = OPT [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >> ];
+        OPT "|"; l = LIST1 tacrule SEP "|";
+        "END" ->
+         declare_tactic loc s c l ] ]
+  ;
+  tacrule:
+    [ [ "["; l = LIST1 tacargs; "]";
+        c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ];
+        "->"; "["; e = Pcaml.expr; "]" ->
+	(match l with
+	  | GramNonTerminal _ :: _ ->
+	    (* En attendant la syntaxe de tacticielles *)
+	    failwith "Tactic syntax must start with an identifier"
+	  | _ -> (l,c,e))
+    ] ]
+  ;
+  tacargs:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name false None e "" in
+        GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let t, g = interp_entry_name false None e sep in
+        GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | s = STRING ->
+	if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal.");
+        GramTerminal s
+    ] ]
+  ;
+  tac_name:
+    [ [ s = LIDENT -> s
+      | s = UIDENT -> s
+    ] ]
+  ;
+  END
diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4
new file mode 100644
index 00000000..7a4d52ab
--- /dev/null
+++ b/grammar/vernacextend.ml4
@@ -0,0 +1,166 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "tools/compat5b.cmo" i*)
+
+open Pp
+open Util
+open Q_util
+open Argextend
+open Tacextend
+open Pcoq
+open Egramml
+open Compat
+
+let rec make_let e = function
+  | [] -> e
+  | GramNonTerminal(loc,t,_,Some p)::l ->
+      let loc = of_coqloc loc in
+      let p = Names.Id.to_string p in
+      let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in
+      let e = make_let e l in
+      <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
+  | _::l -> make_let e l
+
+let make_clause (_,pt,_,e) =
+  (make_patt pt,
+   vala (Some (make_when (MLast.loc_of_expr e) pt)),
+   make_let e pt)
+
+(* To avoid warnings *)
+let mk_ignore c pt =
+  let names = CList.map_filter (function
+  | GramNonTerminal(_,_,_,Some p) -> Some (Names.Id.to_string p)
+  | _ -> None) pt in
+  let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in
+  let names = List.fold_left fold <:expr< () >> names in
+  <:expr< do { let _ = $names$ in $c$ } >>
+
+let make_clause_classifier cg s (_,pt,c,_) =
+  match c ,cg with
+  | Some c, _ ->
+     (make_patt pt,
+      vala (Some (make_when (MLast.loc_of_expr c) pt)),
+      make_let (mk_ignore c pt) pt)
+  | None, Some cg ->
+     (make_patt pt,
+      vala (Some (make_when (MLast.loc_of_expr cg) pt)),
+      <:expr< fun () -> $cg$ $str:s$ >>)
+  | None, None -> msg_warning
+      (strbrk("Vernac entry \""^s^"\" misses a classifier. "^
+         "A classifier is a function that returns an expression "^
+         "of type vernac_classification (see Vernacexpr). You can: ")++
+       str"- "++hov 0 (
+        strbrk("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^
+          "new vernacular command does not alter the system state;"))++fnl()++
+       str"- "++hov 0 (
+        strbrk("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^
+          "new vernacular command alters the system state but not the "^
+          "parser nor it starts a proof or ends one;"))++fnl()++
+       str"- "++hov 0 (
+        strbrk("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^
+          "a global function f.  The function f will be called passing "^
+          "\""^s^"\" as the only argument;")) ++fnl()++
+       str"- "++hov 0 (
+        strbrk"Add a specific classifier in each clause using the syntax:"
+        ++fnl()++strbrk("'[...] => [ f ] -> [...]'. "))++fnl()++
+       strbrk("Specific classifiers have precedence over global "^
+         "classifiers. Only one classifier is called.")++fnl());
+    (make_patt pt,
+      vala (Some (make_when loc pt)),
+      <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>)
+
+let make_fun_clauses loc s l =
+  let cl = List.map (fun c -> Compat.make_fun loc [make_clause c]) l in
+  mlexpr_of_list (fun x -> x) cl
+
+let make_fun_classifiers loc s c l =
+  let cl = List.map (fun x -> Compat.make_fun loc [make_clause_classifier c s x]) l in
+  mlexpr_of_list (fun x -> x) cl
+
+let mlexpr_of_clause =
+  mlexpr_of_list
+    (fun (a,b,_,_) -> mlexpr_of_list make_prod_item
+       (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b))
+
+let declare_command loc s c nt cl =
+  let se = mlexpr_of_string s in
+  let gl = mlexpr_of_clause cl in
+  let funcl = make_fun_clauses loc s cl in
+  let classl = make_fun_classifiers loc s c cl in
+  declare_str_items loc
+    [ <:str_item< do {
+	try do {
+          CList.iteri (fun i f -> Vernacinterp.vinterp_add ($se$, i) f) $funcl$;
+          CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$ }
+	with [ e when Errors.noncritical e ->
+	  Pp.msg_warning
+	    (Pp.app
+	       (Pp.str ("Exception in vernac extend " ^ $se$ ^": "))
+	       (Errors.print e)) ];
+	CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$;
+      } >> ]
+
+open Pcaml
+open PcamlSig (* necessary for camlp4 *)
+
+EXTEND
+  GLOBAL: str_item;
+  str_item:
+    [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT; c = OPT classification;
+        OPT "|"; l = LIST1 rule SEP "|";
+        "END" ->
+         declare_command loc s c <:expr<None>> l
+      | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT; c = OPT classification;
+        OPT "|"; l = LIST1 rule SEP "|";
+        "END" ->
+          declare_command loc s c <:expr<Some $lid:nt$>> l
+      | "DECLARE"; "PLUGIN"; name = STRING ->
+        declare_str_items loc [
+          <:str_item< value __coq_plugin_name = $str:name$ >>;
+          <:str_item< value _ = Mltop.add_known_module $str:name$ >>;
+        ]
+      ] ]
+  ;
+  classification:
+    [ [ "CLASSIFIED"; "BY"; c = LIDENT -> <:expr< $lid:c$ >>
+      | "CLASSIFIED"; "AS"; "SIDEFF" ->
+          <:expr< fun _ -> Vernac_classifier.classify_as_sideeff >>
+      | "CLASSIFIED"; "AS"; "QUERY" ->
+          <:expr< fun _ -> Vernac_classifier.classify_as_query >>
+    ] ]
+  ;
+  (* spiwack: comment-by-guessing: it seems that the isolated string (which
+      otherwise could have been another argument) is not passed to the
+      VernacExtend interpreter function to discriminate between the clauses. *)
+  rule:
+    [ [ "["; s = STRING; l = LIST0 args; "]";
+        c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ];
+                  "->"; "["; e = Pcaml.expr; "]" ->
+      if String.is_empty s then
+        Errors.user_err_loc (!@loc,"",Pp.str"Command name is empty.");
+      (Some s,l,c,<:expr< fun () -> $e$ >>)
+      | "[" ; "-" ; l = LIST1 args ; "]" ;
+        c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun () -> $c$>> ];
+                  "->"; "["; e = Pcaml.expr; "]" ->
+      (None,l,c,<:expr< fun () -> $e$ >>)
+    ] ]
+  ;
+  args:
+    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
+        let t, g = interp_entry_name false None e "" in
+        GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
+        let t, g = interp_entry_name false None e sep in
+        GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s))
+      | s = STRING ->
+        GramTerminal s
+    ] ]
+  ;
+  END
+;;
diff --git a/ide/.merlin b/ide/.merlin
new file mode 100644
index 00000000..3f3d9d27
--- /dev/null
+++ b/ide/.merlin
@@ -0,0 +1,6 @@
+PKG lablgtk2.sourceview2
+
+S utils
+B utils
+
+REC
diff --git a/ide/FAQ b/ide/FAQ
index f07f229f..07b81824 100644
--- a/ide/FAQ
+++ b/ide/FAQ
@@ -6,8 +6,8 @@ R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more i
 Q1) How to enable Emacs keybindings?
 R1: Insert 
 	gtk-key-theme-name = "Emacs"
-    in your "coqide-gtk2rc" file. It should be in $XDG_CONFIG_DIRS/coq dir.
-    This is done by default.
+in your gtkrc file. The location of this file is system-dependent. If you're running
+Gnome, you may use the graphical configuration tools.
 
 Q2) How to enable antialiased fonts?
 R2) Set the GDK_USE_XFT variable to 1. This is by default with Gtk >= 2.2.
@@ -34,27 +34,14 @@ R5)-First solution : type "<CONTROL><SHIFT>2200" to enter a forall in the script
 	2200 is the hexadecimal code for forall in unicode charts and is encoded as "∀"	
 	in UTF-8.
 	2203 is for exists. See http://www.unicode.org for more codes.
--Second solution : rebind "<AltGr>a" to forall and "<AltGr>e" to exists. 
-	Under X11, you need to use something like
-		xmodmap -e "keycode  24 = a A F13 F13" 
-		xmodmap -e "keycode  26 = e E F14 F14" 
-	and then to add   
-		bind "F13" {"insert-at-cursor" ("∀")}
-		bind "F14" {"insert-at-cursor" ("∃")}
-	to your "binding "text"" section in coqiderc-gtk2rc.
-	The strange ("∀") argument is the UTF-8 encoding for
-	0x2200. 
-	You can compute these encodings using the lablgtk2 toplevel with 
-		Glib.Utf8.from_unichar 0x2200;;
-	Further symbols can be bound on higher Fxx keys or on even on other keys you
-	do not need .
+-Second solution : Use an input method editor, such as SCIM or iBus. The latter offers 
+a module for LaTeX-like inputting.
 
 Q6) How to customize the shortcuts for menus?
 R6) Two solutions are offered:
   - Edit $XDG_CONFIG_HOME/coq/coqide.keys by hand or
-  - Add "gtk-can-change-accels = 1" in your coqide-gtk2rc file. Then
-    from CoqIde, you may select a menu entry and press the desired 
-    shortcut. 
+  - If your system allows it, from CoqIde, you may select a menu entry and press the 
+    desired shortcut. 
 
 Q7) What encoding should I use? What is this \x{iiii} in my file?
 R7) The encoding option is related to the way files are saved.
diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template
new file mode 100644
index 00000000..fd80c839
--- /dev/null
+++ b/ide/MacOS/Info.plist.template
@@ -0,0 +1,89 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+	<key>CFBundleDocumentTypes</key>
+	<array>
+		<dict>
+			<key>CFBundleTypeExtensions</key>
+			<array>
+				<string>*</string>
+			</array>
+			<key>CFBundleTypeName</key>
+			<string>NSStringPboardType</string>
+			<key>CFBundleTypeOSTypes</key>
+			<array>
+				<string>****</string>
+			</array>
+			<key>CFBundleTypeRole</key>
+			<string>Editor</string>
+		</dict>
+		<dict>
+			<key>CFBundleTypeIconFile</key>
+			<string>coqfile.icns</string>
+			<key>CFBundleTypeName</key>
+			<string>Coq file</string>
+			<key>CFBundleTypeRole</key>
+			<string>Editor</string>
+			<key>CFBundleTypeMIMETypes</key>
+			<array>
+				<string>text/plain</string>
+			</array>
+			<key>CFBundleTypeExtensions</key>
+			<array>
+				<string>v</string>
+			</array>
+			<key>LSHandlerRank</key>
+			<string>Owner</string>
+		</dict>
+		<dict>
+			<key>CFBundleTypeName</key>
+			<string>All</string>
+			<key>CFBundleTypeRole</key>
+			<string>Editor</string>
+			<key>CFBundleTypeMIMETypes</key>
+			<array>
+				<string>text/plain</string>
+			</array>
+			<key>LSHandlerRank</key>
+			<string>Default</string>
+			<key>CFBundleTypeExtensions</key>
+			<array>
+				<string>*</string>
+			</array>
+		</dict>
+	</array>
+	<key>CFBundleIconFile</key>
+	<string>coqide.icns</string>
+	<key>CFBundleVersion</key>
+	<string>390</string>
+	<key>CFBundleName</key>
+	<string>CoqIDE</string>
+	<key>CFBundleShortVersionString</key>
+	<string>VERSION</string>
+	<key>CFBundleDisplayName</key>
+	<string>Coq Proof Assistant vVERSION</string>
+	<key>CFBundleGetInfoString</key>
+	<string>Coq_vVERSION</string>
+	<key>NSHumanReadableCopyright</key>
+	<string>Copyright 1999-2014, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string>
+	<key>CFBundleHelpBookFolder</key>
+	<string>share/doc/coq/html/</string>
+	<key>CFAppleHelpAnchor</key>
+	<string>index</string>
+	<key>CFBundleExecutable</key>
+	<string>coqide</string>
+	<key>CFBundlePackageType</key>
+	<string>APPL</string>
+	<key>CFBundleInfoDictionaryVersion</key>
+	<string>6.0</string>
+	<key>CFBundleIdentifier</key>
+	<string>fr.inria.coq.coqide</string>
+	<key>LSApplicationCategoryType</key>
+	<string>public.app-category.developer-tools</string>
+	<key>CFBundleDevelopmentRegion</key>
+	<string>English</string>
+	<key>NSPrincipalClass</key>
+	<string>NSApplication</string>
+</dict>
+</plist>
diff --git a/ide/MacOS/coqfile.icns b/ide/MacOS/coqfile.icns
new file mode 100644
index 00000000..107e7043
--- /dev/null
+++ b/ide/MacOS/coqfile.icns
diff --git a/ide/MacOS/coqide.icns b/ide/MacOS/coqide.icns
new file mode 100644
index 00000000..92bdfe77
--- /dev/null
+++ b/ide/MacOS/coqide.icns
diff --git a/ide/mac_default_accel_map b/ide/MacOS/default_accel_map
index 636447e3..6f474eb1 100644
--- a/ide/mac_default_accel_map
+++ b/ide/MacOS/default_accel_map
@@ -22,10 +22,9 @@
 (gtk_accel_path "<Actions>/Tactics/auto with *" "<Primary><Control>asterisk")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Implicit Arguments" "")
-(gtk_accel_path "<Actions>/Edit/Find backwards" "<Primary>b")
 ; (gtk_accel_path "<Actions>/Edit/Copy" "<Primary>c")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using" "")
-(gtk_accel_path "<Actions>/View/Previous tab" "<Control>Left")
+; (gtk_accel_path "<Actions>/View/Previous tab" "<Shift>Left")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic change -- in" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic jp" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic red" "")
@@ -61,69 +60,73 @@
 ; (gtk_accel_path "<Actions>/Tactics/Tactic destruct" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic intro after" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic abstract" "")
+; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
 ; (gtk_accel_path "<Actions>/Queries/About" "F5")
 ; (gtk_accel_path "<Actions>/Templates/Template CoInductive" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Unset Hyps--limit" "")
+; (gtk_accel_path "<Actions>/Templates/Template Transparent" "")
 ; (gtk_accel_path "<Actions>/Export/Ps" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic elim" "")
-; (gtk_accel_path "<Actions>/Templates/Template Transparent" "")
+; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:--)" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Add Rec LoadPath" "")
-; (gtk_accel_path "<Actions>/Templates/Template Extract Constant" "")
+; (gtk_accel_path "<Actions>/Edit/Redo" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic compute" "")
 ; (gtk_accel_path "<Actions>/Compile/Next error" "F7")
 ; (gtk_accel_path "<Actions>/Templates/Template Add ML Path" "")
-; (gtk_accel_path "<Actions>/Templates/Template Test Printing Wildcard" "")
+; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "")
+; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "")
+; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Set Implicit Arguments" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Test Printing Let" "")
 ; (gtk_accel_path "<Actions>/Windows/Windows" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Defined." "")
 (gtk_accel_path "<Actions>/Templates/match" "<Shift><Primary>c")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic set (--:=--)" "")
-; (gtk_accel_path "<Actions>/Templates/Template Test Printing If" "")
+; (gtk_accel_path "<Actions>/Templates/Template Proof." "")
 ; (gtk_accel_path "<Actions>/Compile/Make" "F6")
 ; (gtk_accel_path "<Actions>/Templates/Template Module Type" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic apply -- with" "")
 ; (gtk_accel_path "<Actions>/File/Save as" "")
-; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Set Hyps--limit" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Global Variable" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "")
+; (gtk_accel_path "<Actions>/Templates/Template Remove Printing Constructor" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Add Setoid" "")
-; (gtk_accel_path "<Actions>/Templates/Template Proof." "")
-; (gtk_accel_path "<Actions>/Templates/Template Load Verbose" "")
-; (gtk_accel_path "<Actions>/Compile/Compile buffer" "")
+; (gtk_accel_path "<Actions>/Edit/Find Next" "F3")
+; (gtk_accel_path "<Actions>/Edit/Find" "<Primary>f")
+; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "")
 ; (gtk_accel_path "<Actions>/Queries/Print" "F4")
 ; (gtk_accel_path "<Actions>/Templates/Template Obligations Tactic" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic trivial" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic first" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic case" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Hint Constructors" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Add Abstract Ring A Aplus Amult Aone Azero Ainv Aeq T." "")
 ; (gtk_accel_path "<Actions>/Templates/Template Coercion Local" "")
-; (gtk_accel_path "<Actions>/View/Show Query Pane" "Escape")
-; (gtk_accel_path "<Actions>/Templates/Template Add Relation" "")
+(gtk_accel_path "<Actions>/View/Show Query Pane" "<Control>Escape")
+; (gtk_accel_path "<Actions>/Tactics/Tactic cbv" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion--clear -- in" "")
-; (gtk_accel_path "<Actions>/Templates/Template Definition" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Add Rec ML Path" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic apply" "")
 ; (gtk_accel_path "<Actions>/Export/Latex" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic inversion -- using -- in" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic generalize" "")
-; (gtk_accel_path "<Actions>/Templates/Template Reset Extraction Inline" "")
+(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up")
+; (gtk_accel_path "<Actions>/Tactics/Tactic p" "")
 (gtk_accel_path "<Actions>/Navigation/Hide" "<Primary><Control>h")
 ; (gtk_accel_path "<Actions>/File/Close buffer" "<Primary>w")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic induction" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic eauto with" "")
 (gtk_accel_path "<Actions>/View/Display raw matching expressions" "<Shift><Control>m")
-(gtk_accel_path "<Actions>/Navigation/Backward" "<Primary><Control>Up")
+; (gtk_accel_path "<Actions>/Tactics/Tactic d" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic u" "")
 ; (gtk_accel_path "<Actions>/Templates/Templates" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic p" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic s" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic lapply" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic t" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic s" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic r" "")
+; (gtk_accel_path "<Actions>/Edit/Replace" "<Primary>r")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic case -- with" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic eexact" "")
 ; (gtk_accel_path "<Actions>/Queries/Check" "F3")
@@ -133,10 +136,10 @@
 ; (gtk_accel_path "<Actions>/Tactics/Tactic intro" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic j" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic i" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic e" "")
+; (gtk_accel_path "<Actions>/Templates/Template Definition" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic g" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic f" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic d" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic e" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic c" "")
 (gtk_accel_path "<Actions>/File/Rehighlight" "<Primary>l")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic simple inversion" "")
@@ -179,10 +182,9 @@
 ; (gtk_accel_path "<Actions>/Tactics/Tactic symmetry in" "")
 ; (gtk_accel_path "<Actions>/Help/Help" "")
 (gtk_accel_path "<Actions>/Templates/Inductive" "<Shift><Primary>i")
-; (gtk_accel_path "<Actions>/Edit/Clear Undo Stack" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "")
-; (gtk_accel_path "<Actions>/Templates/Template Syntax" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic idtac" "")
+; (gtk_accel_path "<Actions>/Templates/Template Syntax" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic intro -- after" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic fold -- in" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Program Definition" "")
 (gtk_accel_path "<Actions>/Tactics/Wizard" "<Primary><Control>dollar")
@@ -242,20 +244,20 @@
 ; (gtk_accel_path "<Actions>/Templates/Template Notation" "")
 ; (gtk_accel_path "<Actions>/Edit/Cut" "<Primary>x")
 ; (gtk_accel_path "<Actions>/Templates/Template Theorem" "")
-; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic constructor" "")
+; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Identity Coercion" "")
 ; (gtk_accel_path "<Actions>/Queries/Whelp Locate" "")
 (gtk_accel_path "<Actions>/View/Display all low-level contents" "<Shift><Control>l")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic right" "")
-; (gtk_accel_path "<Actions>/Tactics/Tactic elim -- with" "")
+; (gtk_accel_path "<Actions>/Edit/Find Previous" "<Shift>F3")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic cofix" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Restore State" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Lemma" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic refine" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Section" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic assert (--:=--)" "")
-; (gtk_accel_path "<Actions>/Edit/Find in buffer" "<Primary>f")
+; (gtk_accel_path "<Actions>/Templates/Template Unset Printing Wildcard" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic progress" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Add Printing If" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Chapter" "")
@@ -285,8 +287,8 @@
 ; (gtk_accel_path "<Actions>/Templates/Template Set Extraction AutoInline" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Unset Undo" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic dependent inversion" "")
-; (gtk_accel_path "<Actions>/Templates/Template Add Field" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--rewrite" "")
+; (gtk_accel_path "<Actions>/Templates/Template Add Field" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Require Export" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic rewrite <-" "")
 (gtk_accel_path "<Actions>/Tactics/omega" "<Primary><Control>o")
@@ -348,15 +350,15 @@
 ; (gtk_accel_path "<Actions>/Tactics/Tactic set" "")
 ; (gtk_accel_path "<Actions>/Edit/External editor" "")
 ; (gtk_accel_path "<Actions>/View/Show Toolbar" "")
-(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic try" "")
-(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic discriminate" "")
+(gtk_accel_path "<Actions>/Templates/Fixpoint" "<Shift><Primary>f")
+(gtk_accel_path "<Actions>/Edit/Complete Word" "<Primary>slash")
 (gtk_accel_path "<Actions>/Navigation/Next" "<Primary><Control>greater")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic elimtype" "")
 ; (gtk_accel_path "<Actions>/Templates/Template End" "")
 ; (gtk_accel_path "<Actions>/Templates/Template Fixpoint" "")
-(gtk_accel_path "<Actions>/View/Next tab" "<Control>Right")
+; (gtk_accel_path "<Actions>/View/Next tab" "<Shift>Right")
 ; (gtk_accel_path "<Actions>/File/File" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic setoid--replace" "")
 ; (gtk_accel_path "<Actions>/Tactics/Tactic generalize dependent" "")
diff --git a/ide/MacOS/relatify_with-respect-to_.sh b/ide/MacOS/relatify_with-respect-to_.sh
new file mode 100755
index 00000000..a24af939
--- /dev/null
+++ b/ide/MacOS/relatify_with-respect-to_.sh
@@ -0,0 +1,15 @@
+#!/bin/sh
+
+set -e
+
+for i in "$3/"*.dylib
+do install_name_tool -change "$2"/$(basename $i) @executable_path/../Resources/lib/$(basename $i) "$1"
+done
+case "$1" in
+	*.dylib)
+	    install_name_tool -id @executable_path/../Resources/lib/$(basename $1) $1
+	    for i in "$3"/*.dylib
+	    do install_name_tool -change "$2/"$(basename $1) @executable_path/../Resources/lib/$(basename $1) $i
+	    done;;
+	*)
+esac
diff --git a/ide/Make b/ide/Make
new file mode 100644
index 00000000..c0881ca3
--- /dev/null
+++ b/ide/Make
@@ -0,0 +1,6 @@
+interface.mli
+xmlprotocol.mli
+xmlprotocol.ml
+ide_slave.ml
+
+coqidetop.mllib
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
deleted file mode 100644
index 67b09656..00000000
--- a/ide/command_windows.ml
+++ /dev/null
@@ -1,158 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-class command_window coqtop current =
-(*  let window = GWindow.window
-		 ~allow_grow:true ~allow_shrink:true
-		 ~width:500 ~height:250
-		 ~position:`CENTER
-		 ~title:"CoqIde queries" ~show:false ()
-  in *)
-  let views = ref [] in
-  let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in
-  let _ = frame#misc#hide () in
-  let _ = GtkData.AccelGroup.create () in
-  let hbox = GPack.hbox ~homogeneous:false ~packing:frame#add () in
-  let toolbar = GButton.toolbar
-		  ~orientation:`VERTICAL
-		  ~style:`ICONS
-		  ~tooltips:true
-		  ~packing:(hbox#pack
-			       ~expand:false
-			       ~fill:false)
-		  ()
-  in
-  let notebook = GPack.notebook ~scrollable:true
-		   ~packing:(hbox#pack
-			       ~expand:true
-			       ~fill:true
-			    )
-		   ()
-  in
-  let _ =
-    toolbar#insert_button
-      ~tooltip:"Hide Commands Pane"
-      ~text:"Hide Pane"
-      ~icon:(Ideutils.stock_to_widget `CLOSE)
-      ~callback:frame#misc#hide
-      ()
-  in
-  let new_page_menu =
-    toolbar#insert_button
-      ~tooltip:"New Page"
-      ~text:"New Page"
-      ~icon:(Ideutils.stock_to_widget `NEW)
-      ()
-  in
-
-  let remove_cb () =
-    let index = notebook#current_page in
-    let () = notebook#remove_page index in
-    views := Minilib.list_filter_i (fun i x -> i <> index) !views
-  in
-  let _ =
-    toolbar#insert_button
-      ~tooltip:"Delete Page"
-      ~text:"Delete Page"
-      ~icon:(Ideutils.stock_to_widget `DELETE)
-      ~callback:remove_cb
-      ()
-  in
-object(self)
-  val frame = frame
-
-
-  val new_page_menu = new_page_menu
-  val notebook = notebook
-
-  method frame = frame
-  method new_command ?command ?term () =
-    let frame = GBin.frame
-		  ~shadow_type:`ETCHED_OUT
-		  ()
-    in
-    let _ = notebook#append_page frame#coerce in
-    notebook#goto_page (notebook#page_num frame#coerce);
-    let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
-    let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-    let (combo,_) = GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving
-		  ~packing:hbox#pack
-		  ()
-    in
-    let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in
-    entry#misc#set_can_default true;
-    let r_bin =
-      GBin.scrolled_window
-	~vpolicy:`AUTOMATIC
-	~hpolicy:`AUTOMATIC
-	~packing:(vbox#pack ~fill:true ~expand:true) () in
-    let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
-    let result = GText.view ~packing:r_bin#add () in
-    let () = views := !views @ [result] in
-    result#misc#modify_font !current.Preferences.text_font;
-    let clr = Tags.color_of_string !current.Preferences.background_color in
-    result#misc#modify_base [`NORMAL, `COLOR clr];
-    result#misc#set_can_focus true; (* false causes problems for selection *)
-    result#set_editable false;
-    let on_activate c () =
-      if List.mem combo#entry#text Coq_commands.state_preserving then c ()
-      else result#buffer#set_text "Error: Not a state preserving command"
-    in
-    let callback () =
-      let com = combo#entry#text in
-      let phrase =
-	if String.get com (String.length com - 1) = '.'
-	then com ^ " " else com ^ " " ^ entry#text ^" . "
-      in
-      try
-        result#buffer#set_text
-          (match Coq.interp !coqtop ~raw:true 0 phrase with
-             | Interface.Fail (l,str) ->
-                 ("Error while interpreting "^phrase^":\n"^str)
-             | Interface.Good results ->
-                 ("Result for command " ^ phrase ^ ":\n" ^ results))
-      with e ->
-	let s = Printexc.to_string e in
-	assert (Glib.Utf8.validate s);
-	result#buffer#set_text s
-    in
-    ignore (combo#entry#connect#activate ~callback:(on_activate callback));
-    ignore (ok_b#connect#clicked ~callback:(on_activate callback));
-
-    begin match command,term with
-      | None,None -> ()
-      | Some c, None ->
-	  combo#entry#set_text c;
-
-      | Some c, Some t ->
-	  combo#entry#set_text c;
-	  entry#set_text t
-
-      | None , Some t ->
-	  entry#set_text t
-    end;
-    on_activate callback ();
-    entry#misc#grab_focus ();
-    entry#misc#grab_default ();
-    ignore (entry#connect#activate ~callback);
-    ignore (combo#entry#connect#activate ~callback);
-    self#frame#misc#show ()
-
-  method refresh_font () =
-    let iter view = view#misc#modify_font !current.Preferences.text_font in
-    List.iter iter !views
-
-  method refresh_color () =
-    let clr = Tags.color_of_string !current.Preferences.background_color in
-    let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in
-    List.iter iter !views
-
-  initializer
-    ignore (new_page_menu#connect#clicked ~callback:self#new_command);
-   (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*)
-end
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index aafc90f4..87cc6d06 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -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        *)
@@ -10,7 +10,6 @@
 
   open Lexing
   open Format
-  open Minilib
 
   let string_buffer = Buffer.create 1024
 
@@ -23,7 +22,7 @@ let ignore = space | ('#' [^ '\n']*)
 
 rule prefs m = parse
   |ignore* (ident as id) ignore* '=' { let conf = str_list [] lexbuf in
-				 prefs (Stringmap.add id conf m) lexbuf }
+				 prefs (Util.String.Map.add id conf m) lexbuf }
   | _     { let c = lexeme_start lexbuf in
 	      eprintf "coqiderc: invalid character (%d)\n@." c;
 	      prefs m lexbuf }
@@ -48,7 +47,7 @@ and string = parse
   let load_file f =
     let c = open_in f in
     let lb = from_channel c in
-    let m = prefs Stringmap.empty lb in
+    let m = prefs Util.String.Map.empty lb in
     close_in c;
     m
 
@@ -59,7 +58,7 @@ and string = parse
       | [] -> ()
       | s :: sl -> fprintf fmt "%S@ %a" s print_list sl
     in
-    Stringmap.iter
+    Util.String.Map.iter
       (fun k s -> fprintf fmt "@[<hov 2>%s = %a@]@\n" k print_list s) m;
     fprintf fmt "@.";
     close_out c
diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang
new file mode 100644
index 00000000..4c488ae8
--- /dev/null
+++ b/ide/coq-ssreflect.lang
@@ -0,0 +1,246 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<language id="coq-ssreflect" _name="Coq + Ssreflect" version="2.0" _section="Scientific">
+  <metadata>
+    <property name="globs">*.v</property>
+    <property name="block-comment-start">\(\*</property>
+    <property name="block-comment-stop">\*\)</property>
+  </metadata>
+  
+  <styles>
+    <style id="comment" _name="Comment" map-to="def:comment"/>
+    <style id="coqdoc" _name="Coqdoc text" map-to="def:note"/>
+    <style id="vernac-keyword" _name="Vernacular keyword" map-to="def:keyword"/>
+    <style id="gallina-keyword" _name="Gallina keyword" map-to="def:keyword"/>
+    <style id="identifier" _name="Identifier" map-to="def:identifier"/>
+    <style id="constr-keyword" _name="Cic keyword" map-to="def:keyword"/>
+    <style id="constr-sort" _name="Cic sort" map-to="def:builtin"/>
+    <style id="string" _name="String" map-to="def:string"/>
+    <style id="escape" _name="Escaped Character" map-to="def:special-char"/>
+    <style id="error" _name="Error" map-to="def:error"/>
+    <style id="safe" _name="Checked Part"/>
+    <style id="sentence" _name="Sentence terminator"/>
+    <style id="tactic" _name="Tactic"/>
+    <style id="endtactic" _name="Tactic terminator"/>
+    <style id="iterator" _name="Tactic iterator"/>
+  </styles>
+  
+  <definitions>
+    <define-regex id="space">\s</define-regex>
+    <define-regex id="first_ident_char">[_\p{L}]</define-regex>
+    <define-regex id="ident_char">[_\p{L}'\pN]</define-regex>
+    <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex>
+    <define-regex id="qualit">(\%{ident}*\.)*\%{ident}</define-regex>
+    <define-regex id="undotted_sep">[-+*{}]</define-regex>
+    <define-regex id="dot_sep">\.(\s|\z)</define-regex>
+    <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)|(Canonical)|(Coercion)</define-regex>
+    <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex>
+    <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex>
+    <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex>
+    <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex>
+    <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))</define-regex>
+
+    <context id="escape-seq" style-ref="escape">
+      <match>""</match>
+    </context>
+    <context id="string" style-ref="string">
+      <start>"</start>
+      <end>"</end>
+      <include>
+	<context ref="escape-seq"/>
+      </include>
+    </context>
+    <context id="ssr-iter" style-ref="iterator">
+      <keyword>do</keyword>
+      <keyword>last</keyword>
+      <keyword>first</keyword>
+    </context>
+    <context id="ssr-tac" style-ref="tactic">
+      <keyword>apply</keyword>
+      <keyword>auto</keyword>
+      <keyword>case</keyword>
+      <keyword>case</keyword>
+      <keyword>congr</keyword>
+      <keyword>elim</keyword>
+      <keyword>exists</keyword>
+      <keyword>have</keyword>
+      <keyword>gen have</keyword>
+      <keyword>generally have</keyword>
+      <keyword>move</keyword>
+      <keyword>pose</keyword>
+      <keyword>rewrite</keyword>
+      <keyword>set</keyword>
+      <keyword>split</keyword>
+      <keyword>suffices</keyword>
+      <keyword>suff</keyword>
+      <keyword>transitivity</keyword>
+      <keyword>without loss</keyword>
+      <keyword>wlog</keyword>
+    </context>
+    <context id="ssr-endtac" style-ref="endtactic">
+      <keyword>by</keyword>
+      <keyword>exact</keyword>
+      <keyword>reflexivity</keyword>
+    </context>
+    <context id="coq-ssreflect" class="no-spell-check">
+      <include>
+        <context ref="string"/>
+	<context id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check">
+	  <start>\(\*\*(\s|\z)</start>
+	  <end>\*\)</end>
+	  <include>
+	    <context ref="comment-in-comment"/>
+	    <context ref="string"/>
+	    <context ref="escape-seq"/>
+	  </include>
+	</context>
+	<context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+	  <start>\(\*</start>
+	  <end>\*\)</end>
+	  <include>
+	    <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+	      <start>\(\*</start>
+	      <end>\*\)</end>
+	      <include>
+		<context ref="comment-in-comment"/>
+		<context ref="string"/>
+		<context ref="escape-seq"/>
+	      </include>
+	    </context>
+	    <context ref="string"/>
+	    <context ref="escape-seq"/>
+	  </include>
+	</context>
+	<context id="declaration">
+	  <start>\%{decl_head}</start>
+	  <end>\%{dot_sep}</end>
+	  <include>
+	    <context sub-pattern="id" where="start" style-ref="identifier"/>
+	    <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/>
+	    <context sub-pattern="id_list" where="start" style-ref="identifier"/>
+	    <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/>
+	    <context id="constr-keyword" style-ref="constr-keyword">
+	      <keyword>forall</keyword>
+	      <keyword>fun</keyword>
+	      <keyword>match</keyword>
+	      <keyword>fix</keyword>
+	      <keyword>cofix</keyword>
+	      <keyword>with</keyword>
+	      <keyword>for</keyword>
+	      <keyword>end</keyword>
+	      <keyword>as</keyword>
+	      <keyword>let</keyword>
+	      <keyword>in</keyword>
+	      <keyword>if</keyword>
+	      <keyword>then</keyword>
+	      <keyword>else</keyword>
+	      <keyword>return</keyword>
+	      <keyword>using</keyword>
+	    </context>
+	    <context id="constr-sort" style-ref="constr-sort">
+	      <keyword>Prop</keyword>
+	      <keyword>Set</keyword>
+	      <keyword>Type</keyword>
+	    </context>
+	    <context id="dot-nosep">
+	      <match>\.\.</match>
+	    </context>
+	    <context ref="comment"/>
+	    <context ref="string"/>
+	    <context ref="coqdoc"/>
+	  </include>
+	</context>
+	<context id="proof">
+	  <start>Proof</start>
+	  <end>\%{end_proof}\%{dot_sep}</end>
+	  <include>
+	    <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+	    <context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
+	    <context ref="command"/>
+	    <context ref="scope-command"/>
+	    <context ref="hint-command"/>
+	    <context ref="command-for-qualit"/>
+	    <context ref="declaration"/>
+	    <context ref="comment"/>
+	    <context ref="string"/>
+	    <context ref="coqdoc"/>
+	    <context ref="proof"/>
+	    <context ref="undotted-sep"/>
+	    <context id="tactic" extend-parent="false">
+              <start></start>
+              <end>\%{dot_sep}</end>
+	      <include>
+	        <context ref="ssr-tac"/>
+	        <context ref="ssr-endtac"/>
+	        <context ref="ssr-iter"/>
+		<context ref="dot-nosep"/>
+		<context ref="constr-keyword"/>
+		<context ref="constr-sort"/>
+	        <context ref="comment"/>
+	        <context ref="string"/>
+	      </include>
+	    </context>
+	  </include>
+	</context>
+	<context id="undotted-sep" style-ref="vernac-keyword">
+	  <match>\%{undotted_sep}</match>
+	</context>
+	<context id="command" style-ref="vernac-keyword">
+	  <keyword>Add</keyword>
+	  <keyword>Check</keyword>
+	  <keyword>Eval</keyword>
+	  <keyword>Load</keyword>
+	  <keyword>Undo</keyword>
+	  <keyword>Goal</keyword>
+	  <keyword>Print</keyword>
+	  <keyword>Save</keyword>
+	  <keyword>Comments</keyword>
+	  <keyword>Solve\%{space}+Obligation</keyword>
+	  <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword>
+	  <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword>
+	  <keyword>\%{locality}Infix</keyword>
+	  <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword>
+	</context>
+	<context id="hint-command" style-ref="vernac-keyword">
+	  <prefix>\%{locality}Hint\%{space}+</prefix>
+	  <keyword>Resolve</keyword>
+	  <keyword>Immediate</keyword>
+	  <keyword>Constructors</keyword>
+	  <keyword>unfold</keyword>
+	  <keyword>Opaque</keyword>
+	  <keyword>Transparent</keyword>
+	  <keyword>Extern</keyword>
+	</context>
+	<context id="scope-command" style-ref="vernac-keyword">
+	  <suffix>\%{space}+Scope</suffix>
+	  <keyword>\%{locality}Open</keyword>
+	  <keyword>\%{locality}Close</keyword>
+	  <keyword>Bind</keyword>
+	  <keyword>Delimit</keyword>
+	</context>
+	<context id="command-for-qualit">
+	  <suffix>\%{space}+(?'qua'\%{qualit})</suffix>
+	  <keyword>Chapter</keyword>
+	  <keyword>Combined\%{space}+Scheme</keyword>
+	  <keyword>End</keyword>
+	  <keyword>Section</keyword>
+	  <keyword>Arguments</keyword>
+	  <keyword>Implicit\%{space}+Arguments</keyword>
+	  <keyword>(Import)|(Include)</keyword>
+	  <keyword>Require(\%{space}+((Import)|(Export)))?</keyword>
+	  <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword>
+	  <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword>
+	  <include>
+	    <context sub-pattern="1" style-ref="vernac-keyword"/>
+	  </include>
+	</context>
+	<context id="command-for-qualit-list" style-ref="vernac-keyword">
+	  <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix>
+	  <keyword>Typeclasses (Transparent)|(Opaque)</keyword>
+	  <include>
+	    <context sub-pattern="qua_list" style-ref="identifier"/>
+	  </include>
+	</context>
+      </include>
+    </context>
+  </definitions>
+</language>
diff --git a/ide/coq.lang b/ide/coq.lang
new file mode 100644
index 00000000..608a4aea
--- /dev/null
+++ b/ide/coq.lang
@@ -0,0 +1,216 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<language id="coq" _name="Coq" version="2.0" _section="Scientific">
+  <metadata>
+    <property name="globs">*.v</property>
+    <property name="block-comment-start">\(\*</property>
+    <property name="block-comment-stop">\*\)</property>
+  </metadata>
+  
+  <styles>
+    <style id="comment" _name="Comment" map-to="def:comment"/>
+    <style id="coqdoc" _name="Coqdoc text" map-to="def:note"/>
+    <style id="vernac-keyword" _name="Vernacular keyword" map-to="def:keyword"/>
+    <style id="gallina-keyword" _name="Gallina keyword" map-to="def:keyword"/>
+    <style id="identifier" _name="Identifier" map-to="def:identifier"/>
+    <style id="constr-keyword" _name="Cic keyword" map-to="def:keyword"/>
+    <style id="constr-sort" _name="Cic sort" map-to="def:builtin"/>
+    <style id="string" _name="String" map-to="def:string"/>
+    <style id="escape" _name="Escaped Character" map-to="def:special-char"/>
+    <style id="error" _name="Error" map-to="def:error"/>
+    <style id="safe" _name="Checked Part"/>
+    <style id="sentence" _name="Sentence terminator"/>
+  </styles>
+  
+  <definitions>
+    <define-regex id="space">\s</define-regex>
+    <define-regex id="first_ident_char">[_\p{L}]</define-regex>
+    <define-regex id="ident_char">[_\p{L}'\pN]</define-regex>
+    <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex>
+    <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex>
+    <define-regex id="undotted_sep">[-+*{}]</define-regex>
+    <define-regex id="dot_sep">\.(\s|\z)</define-regex>
+    <define-regex id="single_decl">(Definition)|(Let)|(Example)|(SubClass)|(Fixpoint)|(CoFixpoint)|(Scheme)|(Function)|(Hypothesis)|(Axiom)|(Variable)|(Parameter)|(Conjecture)|(Inductive)|(CoInductive)|(Record)|(Structure)|(Ltac)|(Instance)|(Context)|(Class)|(Module(\%{space}+Type)?)|(Existing\%{space}+Instance)|(Canonical\%{space}+Structure)</define-regex>
+    <define-regex id="mult_decl">(Hypotheses)|(Axioms)|(Variables)|(Parameters)|(Implicit\%{space}+Type(s)?)</define-regex>
+    <define-regex id="locality">(((Local)|(Global))\%{space}+)?</define-regex>
+    <define-regex id="begin_proof">(Theorem)|(Lemma)|(Fact)|(Remark)|(Corollary)|(Proposition)|(Property)</define-regex>
+    <define-regex id="end_proof">(Qed)|(Defined)|(Admitted)|(Abort)</define-regex>
+    <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space}+)?(\%{single_decl}|\%{begin_proof}))\%{space}+(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}+\%{ident})*))|(?'gal2'Goal)</define-regex>
+
+    <context id="escape-seq" style-ref="escape">
+      <match>""</match>
+    </context>
+    <context id="string" style-ref="string">
+      <start>"</start>
+      <end>"</end>
+      <include>
+	<context ref="escape-seq"/>
+      </include>
+    </context>
+    <context id="coq" class="no-spell-check">
+      <include>
+        <context ref="string"/>
+	<context id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check">
+	  <start>\(\*\*(\s|\z)</start>
+	  <end>\*\)</end>
+	  <include>
+	    <context ref="comment-in-comment"/>
+	    <context ref="string"/>
+	  </include>
+	</context>
+	<context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+	  <start>\(\*</start>
+	  <end>\*\)</end>
+	  <include>
+	    <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">
+	      <start>\(\*</start>
+	      <end>\*\)</end>
+	      <include>
+		<context ref="comment-in-comment"/>
+		<context ref="string"/>
+	      </include>
+	    </context>
+	    <context ref="string"/>
+	  </include>
+	</context>
+	<context id="declaration">
+	  <start>\%{decl_head}</start>
+	  <end>\%{dot_sep}</end>
+	  <include>
+	    <context sub-pattern="id" where="start" style-ref="identifier"/>
+	    <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/>
+	    <context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/>
+	    <context sub-pattern="id_list" where="start" style-ref="identifier"/>
+	    <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/>
+	    <context id="constr-keyword" style-ref="constr-keyword">
+	      <keyword>forall</keyword>
+	      <keyword>fun</keyword>
+	      <keyword>match</keyword>
+	      <keyword>fix</keyword>
+	      <keyword>cofix</keyword>
+	      <keyword>with</keyword>
+	      <keyword>for</keyword>
+	      <keyword>end</keyword>
+	      <keyword>as</keyword>
+	      <keyword>let</keyword>
+	      <keyword>in</keyword>
+	      <keyword>if</keyword>
+	      <keyword>then</keyword>
+	      <keyword>else</keyword>
+	      <keyword>return</keyword>
+	      <keyword>using</keyword>
+	    </context>
+	    <context id="constr-sort" style-ref="constr-sort">
+	      <keyword>Prop</keyword>
+	      <keyword>Set</keyword>
+	      <keyword>Type</keyword>
+	    </context>
+	    <context id="dot-nosep">
+	      <match>\.\.</match>
+	    </context>
+	    <context ref="comment"/>
+	    <context ref="string"/>
+	    <context ref="coqdoc"/>
+	  </include>
+	</context>
+	<context id="proof">
+	  <start>Proof(\%{dot_sep}|\%{space}+(using)|\%{space}+(with))</start>
+	  <end>\%{end_proof}\%{dot_sep}</end>
+	  <include>
+	    <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+	    <context sub-pattern="0" where="end" style-ref="vernac-keyword"/>
+	    <context ref="command"/>
+	    <context ref="scope-command"/>
+	    <context ref="hint-command"/>
+	    <context ref="command-for-qualit"/>
+	    <context ref="declaration"/>
+	    <context ref="comment"/>
+	    <context ref="string"/>
+	    <context ref="coqdoc"/>
+	    <context ref="proof"/>
+	    <context ref="undotted-sep"/>
+	    <context id="tactic" extend-parent="false">
+	      <start>\b[^-+*{}]</start>
+	      <end>\%{dot_sep}</end>
+	      <include>
+		<context ref="dot-nosep"/>
+		<context ref="constr-keyword"/>
+		<context ref="constr-sort"/>
+	      </include>
+	    </context>
+	  </include>
+	</context>
+	<context id="exact-proof">
+	  <start>Proof</start>
+	  <end>\%{dot_sep}</end>
+	  <include>
+	    <context sub-pattern="0" where="start" style-ref="vernac-keyword"/>
+	    <context ref="constr-keyword"/>
+	    <context ref="constr-sort"/>
+	  </include>
+	</context>
+	<context id="undotted-sep" style-ref="vernac-keyword">
+	  <match>\%{undotted_sep}</match>
+	</context>
+	<context id="command" style-ref="vernac-keyword">
+	  <keyword>Add</keyword>
+	  <keyword>Check</keyword>
+	  <keyword>Eval</keyword>
+	  <keyword>Load</keyword>
+	  <keyword>Undo</keyword>
+	  <keyword>Print</keyword>
+	  <keyword>Save</keyword>
+	  <keyword>Comments</keyword>
+	  <keyword>Solve\%{space}+Obligation</keyword>
+	  <keyword>((Uns)|(S))et(\%{space}+\%{ident})+</keyword>
+	  <keyword>(\%{locality}|((Reserved)|(Tactic))\%{space}+)?Notation</keyword>
+	  <keyword>\%{locality}Infix</keyword>
+	  <keyword>(Print)|(Reset)\%{space}+Extraction\%{space}+(Inline)|(Blacklist)</keyword>
+	</context>
+	<context id="hint-command" style-ref="vernac-keyword">
+	  <prefix>\%{locality}Hint\%{space}+</prefix>
+	  <keyword>Resolve</keyword>
+	  <keyword>Immediate</keyword>
+	  <keyword>Constructors</keyword>
+	  <keyword>Unfold</keyword>
+	  <keyword>Opaque</keyword>
+	  <keyword>Transparent</keyword>
+	  <keyword>Extern</keyword>
+	  <keyword>Rewrite</keyword>
+	</context>
+	<context id="scope-command" style-ref="vernac-keyword">
+	  <suffix>\%{space}+Scope</suffix>
+	  <keyword>\%{locality}Open</keyword>
+	  <keyword>\%{locality}Close</keyword>
+	  <keyword>Bind</keyword>
+	  <keyword>Delimit</keyword>
+	</context>
+	<context id="command-for-qualit">
+	  <suffix>\%{space}+(?'qua'\%{qualit})</suffix>
+	  <keyword>Chapter</keyword>
+	  <keyword>Combined\%{space}+Scheme</keyword>
+	  <keyword>End</keyword>
+	  <keyword>Section</keyword>
+	  <keyword>Arguments</keyword>
+	  <keyword>Implicit\%{space}+Arguments</keyword>
+	  <keyword>Import</keyword>
+	  <keyword>Include</keyword>
+	  <keyword>Export</keyword>
+	  <keyword>Require(\%{space}+((Import)|(Export)))?</keyword>
+	  <keyword>(Recursive\%{space}+)?Extraction(\%{space}+(Language\%{space}+(Ocaml)|(Haskell)|(Scheme)|(Toplevel))|(Library)|((No)?Inline)|(Blacklist))?</keyword>
+	  <keyword>Extract\%{space}+(Inlined\%{space}+)?(Constant)|(Inductive)</keyword>
+	  <include>
+	    <context sub-pattern="1" style-ref="vernac-keyword"/>
+	    <context sub-pattern="qua" style-ref="identifier"/>
+	  </include>
+	</context>
+	<context id="command-for-qualit-list" style-ref="vernac-keyword">
+	  <suffix>(?'qua_list'(\%{space}+\%{qualit})+)</suffix>
+	  <keyword>Typeclasses (Transparent)|(Opaque)</keyword>
+	  <include>
+	    <context sub-pattern="qua_list" style-ref="identifier"/>
+	  </include>
+	</context>
+      </include>
+    </context>
+  </definitions>
+</language>
diff --git a/ide/coq.ml b/ide/coq.ml
index 1d1a7dd0..b7753e6e 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -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        *)
 (************************************************************************)
 
 open Ideutils
+open Preferences
 
 (** * Version and date *)
 
@@ -53,7 +54,7 @@ let rec read_all_lines in_chan =
     let arg = input_line in_chan in
     let len = String.length arg  in
     let arg =
-      if arg.[len - 1] = '\r' then
+      if len > 0 && arg.[len - 1] = '\r' then
 	String.sub arg 0 (len - 1)
       else arg
     in
@@ -112,8 +113,7 @@ let rec filter_coq_opts args =
     filtered_args := read_all_lines oc;
     errlines := read_all_lines ec;
     match Unix.close_process_full (oc,ic,ec) with
-      | Unix.WEXITED 0 ->
-	List.iter check_remaining_opt !filtered_args; !filtered_args
+      | Unix.WEXITED 0 -> !filtered_args
       | Unix.WEXITED 127 -> asks_for_coqtop args
       | _ -> display_coqtop_answer cmd (!filtered_args @ !errlines)
   with Sys_error _ -> asks_for_coqtop args
@@ -125,7 +125,7 @@ and asks_for_coqtop args =
     ~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
   match pb_mes#run () with
     | `YES ->
-      let () = !Preferences.current.Preferences.cmd_coqtop  <- None in
+      let () = current.cmd_coqtop  <- None in
       let () = custom_coqtop := None in
       let () = pb_mes#destroy () in
       filter_coq_opts args
@@ -151,37 +151,106 @@ let print_status = function
 let check_connection args =
   let lines = ref [] in
   let argstr = String.concat " " (List.map Filename.quote args) in
-  let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in
+  let cmd = Filename.quote (coqtop_path ()) ^ " -batch -ideslave " ^ argstr in
   let cmd = requote cmd in
   try
-    let ic = Unix.open_process_in cmd in
-    lines := read_all_lines ic;
-    match Unix.close_process_in ic with
+    let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
+    lines := read_all_lines oc @ read_all_lines ec;
+    match Unix.close_process_full (oc,ic,ec) with
     | Unix.WEXITED 0 -> () (* coqtop seems ok *)
     | st -> raise (WrongExitStatus (print_status st))
   with e -> connection_error cmd !lines e
 
+(** Useful stuff *)
+
+let ignore_error f arg =
+  try ignore (f arg) with _ -> ()
+
+(** An abstract copy of unit.
+    This will help ensuring that we do not forget to finally call
+    continuations when building tasks in other modules. *)
+
+type void = Void
+
+(** ccb : existential type for a (call + callback) type.
+
+    Reference: http://alan.petitepomme.net/cwn/2004.01.13.html
+    To rewrite someday with GADT. *)
+
+type 'a poly_ccb = 'a Xmlprotocol.call * ('a Interface.value -> void)
+type 't scoped_ccb = { bind_ccb : 'a. 'a poly_ccb -> 't }
+type ccb = { open_ccb : 't. 't scoped_ccb -> 't }
+
+let mk_ccb poly = { open_ccb = fun scope -> scope.bind_ccb poly }
+let with_ccb ccb e = ccb.open_ccb e
+
+let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint)
+
 (** * The structure describing a coqtop sub-process *)
 
-type coqtop = {
-  pid : int; (* Unix process id *)
-  cout : in_channel ;
-  cin : out_channel ;
-  sup_args : string list;
+let gio_channel_of_descr_socket = ref Glib.Io.channel_of_descr
+
+module GlibMainLoop = struct
+  type async_chan = Glib.Io.channel
+  type watch_id = Glib.Io.id
+  type condition = Glib.Io.condition
+  let add_watch ~callback chan =
+    Glib.Io.add_watch ~cond:[`ERR; `HUP; `IN; `NVAL; `PRI] ~callback chan
+  let remove_watch x = try Glib.Io.remove x with Glib.GError _ -> ()
+  let read_all = Ideutils.io_read_all
+  let async_chan_of_file fd = Glib.Io.channel_of_descr fd
+  let async_chan_of_socket s = !gio_channel_of_descr_socket s
+  let add_timeout ~sec callback =
+    ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback)
+end
+
+module CoqTop = Spawn.Async(GlibMainLoop)
+
+type handle = {
+  proc : CoqTop.process;
+  xml_oc : Xml_printer.t;
+  mutable alive : bool;
+  mutable waiting_for : (ccb * logger) option; (* last call + callback + log *)
 }
 
-(** * Count of all active coqtops *)
+(** Coqtop process status :
+  - New    : a process has been spawned, but not initialized via [init_coqtop].
+             It will reject tasks given via [try_grab].
+  - Ready  : no current task, accepts new tasks via [try_grab].
+  - Busy   : has accepted a task via [init_coqtop] or [try_grab],
+             It will reject other tasks for the moment
+  - Closed : the coqide buffer has been closed, we discard any further task.
+*)
 
-let toplvl_ctr = ref 0
+type status = New | Ready | Busy | Closed
 
-let toplvl_ctr_mtx = Mutex.create ()
+type 'a task = handle -> ('a -> void) -> void
 
-let coqtop_zombies () =
-  Mutex.lock toplvl_ctr_mtx;
-  let res = !toplvl_ctr in
-  Mutex.unlock toplvl_ctr_mtx;
-  res
+type reset_kind = Planned | Unexpected
+
+type coqtop = {
+  (* non quoted command-line arguments of coqtop *)
+  mutable sup_args : string list;
+  (* called whenever coqtop dies *)
+  mutable reset_handler : reset_kind -> unit task;
+  (* called whenever coqtop sends a feedback message *)
+  mutable feedback_handler : Feedback.feedback -> unit;
+  (* actual coqtop process and its status *)
+  mutable handle : handle;
+  mutable status : status;
+}
 
+let return (x : 'a) : 'a task =
+  (); fun _ k -> k x
+
+let bind (m : 'a task) (f : 'a -> 'b task) : 'b task =
+  (); fun h k -> m h (fun x -> f x h k)
+
+let seq (m : unit task) (n : 'a task) : 'a task =
+  (); fun h k -> m h (fun () -> n h k)
+
+let lift (f : unit -> 'a) : 'a task =
+  (); fun _ k -> k (f ())
 
 (** * Starting / signaling / ending a real coqtop sub-process *)
 
@@ -215,107 +284,304 @@ let coqtop_zombies () =
     closed in coqide.
 *)
 
-let open_process_pid prog args =
-  let (ide2top_r,ide2top_w) = Unix.pipe () in
-  let (top2ide_r,top2ide_w) = Unix.pipe () in
-  Unix.set_close_on_exec ide2top_w;
-  Unix.set_close_on_exec top2ide_r;
-  let pid = Unix.create_process prog args ide2top_r top2ide_w Unix.stderr in
-  assert (pid <> 0);
-  Unix.close ide2top_r;
-  Unix.close top2ide_w;
-  let oc = Unix.out_channel_of_descr ide2top_w in
-  let ic = Unix.in_channel_of_descr top2ide_r in
-  set_binary_mode_out oc true;
-  set_binary_mode_in ic true;
-  (pid,ic,oc)
+exception TubeError of string
+exception AnswerWithoutRequest of string
+
+let rec check_errors = function
+| [] -> ()
+| (`IN | `PRI) :: conds -> check_errors conds
+| `ERR :: _ -> raise (TubeError "ERR")
+| `HUP :: _ -> raise (TubeError "HUP")
+| `NVAL :: _ -> raise (TubeError "NVAL")
+| `OUT :: _ -> raise (TubeError "OUT")
+
+let handle_intermediate_message handle xml =
+  let message = Pp.to_message xml in
+  let level = message.Pp.message_level in
+  let content = message.Pp.message_content in
+  let logger = match handle.waiting_for with
+    | Some (_, l) -> l 
+    | None -> function
+        | Pp.Error -> Minilib.log ~level:`ERROR
+        | Pp.Info -> Minilib.log ~level:`INFO
+        | Pp.Notice -> Minilib.log ~level:`NOTICE
+        | Pp.Warning -> Minilib.log ~level:`WARNING
+        | Pp.Debug _ -> Minilib.log ~level:`DEBUG
+  in
+  logger level content
+
+let handle_feedback feedback_processor xml =
+  let feedback = Feedback.to_feedback xml in
+  feedback_processor feedback
+
+let handle_final_answer handle xml =
+  let () = Minilib.log "Handling coqtop answer" in
+  let ccb = match handle.waiting_for with
+    | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml))
+    | Some (c, _) -> c in
+  let () = handle.waiting_for <- None in
+  with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) }
+
+type input_state = {
+  mutable fragment : string;
+  mutable lexerror : int option;
+}
+
+let unsafe_handle_input handle feedback_processor state conds ~read_all =
+  check_errors conds;
+  let s = read_all () in
+  if String.length s = 0 then raise (TubeError "EMPTY");
+  let s = state.fragment ^ s in
+  state.fragment <- s;
+  let lex = Lexing.from_string s in
+  let p = Xml_parser.make (Xml_parser.SLexbuf lex) in
+  let rec loop () =
+    let xml = Xml_parser.parse p in
+    let l_end = Lexing.lexeme_end lex in
+    state.fragment <- String.sub s l_end (String.length s - l_end);
+    state.lexerror <- None;
+    if Pp.is_message xml then begin
+      handle_intermediate_message handle xml;
+      loop ()
+    end else if Feedback.is_feedback xml then begin
+      handle_feedback feedback_processor xml;
+      loop ()
+    end else begin
+      ignore (handle_final_answer handle xml)
+    end
+  in
+  try loop ()
+  with Xml_parser.Error _ as e ->
+    (* Parsing error at the end of s : we have only received a part of
+        an xml answer. We store the current fragment for later *)
+    let l_end = Lexing.lexeme_end lex in
+    (** Heuristic hack not to reimplement the lexer:  if ever the lexer dies
+        twice at the same place, then this is a non-recoverable error *)
+    if state.lexerror = Some l_end then raise e;
+    state.lexerror <- Some l_end
+
+let print_exception = function
+  | Xml_parser.Error e -> Xml_parser.error e
+  | Serialize.Marshal_error -> "Protocol violation"
+  | e -> Printexc.to_string e
+
+let input_watch handle respawner feedback_processor =
+  let state = { fragment = ""; lexerror = None; } in
+  (fun conds ~read_all ->
+    let h = handle () in
+    if not h.alive then false
+    else
+      try unsafe_handle_input h feedback_processor state conds ~read_all; true
+      with e ->
+        Minilib.log ("Coqtop reader failed, resetting: "^print_exception e);
+        respawner ();
+        false)
+
+let bind_self_as f =
+  let me = ref None in
+  let get_me () = Option.get !me in
+  me := Some(f get_me);
+  Option.get !me
+
+(** This launches a fresh handle from its command line arguments. *)
+let spawn_handle args respawner feedback_processor =
+  let prog = coqtop_path () in
+  let args = Array.of_list ("-async-proofs" :: "on" :: "-ideslave" :: args) in
+  let env =
+    match !Flags.ideslave_coqtop_flags with
+    | None -> None
+    | Some s ->
+      let open Str in
+      let open Array in
+      let opts = split_delim (regexp ",") s in
+      begin try
+        let erex = regexp "^extra-env=" in
+        let echunk = List.find (fun s -> string_match erex s 0) opts in
+        Some (append
+          (of_list (split_delim (regexp ";") (replace_first erex "" echunk)))
+          (Unix.environment ()))
+      with Not_found -> None end in
+  bind_self_as (fun handle ->
+  let proc, oc =
+    CoqTop.spawn ?env prog args (input_watch handle respawner feedback_processor) in
+  {
+    proc;
+    xml_oc = Xml_printer.make (Xml_printer.TChannel oc);
+    alive = true;
+    waiting_for = None;
+  })
+
+(** This clears any potentially remaining open garbage. *)
+let clear_handle h =
+  if h.alive then begin
+    (* invalidate the old handle *)
+    CoqTop.kill h.proc;
+    ignore(CoqTop.wait h.proc);
+    h.alive <- false;
+  end
+
+let mkready coqtop =
+  fun () -> coqtop.status <- Ready; Void
+
+let rec respawn_coqtop ?(why=Unexpected) coqtop =
+  clear_handle coqtop.handle;
+  ignore_error (fun () ->
+     coqtop.handle <-
+       spawn_handle
+         coqtop.sup_args
+         (fun () -> respawn_coqtop coqtop)
+         coqtop.feedback_handler) ();
+  (* Normally, the handle is now a fresh one.
+     If not, there isn't much we can do ... *)
+  assert (coqtop.handle.alive = true);
+  coqtop.status <- New;
+  ignore (coqtop.reset_handler why coqtop.handle (mkready coqtop))
 
 let spawn_coqtop sup_args =
-  Mutex.lock toplvl_ctr_mtx;
-  try
-    let prog = coqtop_path () in
-    let args = Array.of_list (prog :: "-ideslave" :: sup_args) in
-    let (pid,ic,oc) = open_process_pid prog args in
-    incr toplvl_ctr;
-    Mutex.unlock toplvl_ctr_mtx;
-    { pid = pid; cin = oc; cout = ic ; sup_args = sup_args }
-  with e ->
-    Mutex.unlock toplvl_ctr_mtx;
-    raise e
+  bind_self_as (fun this -> {
+    handle = spawn_handle sup_args
+               (fun () -> respawn_coqtop (this ()))
+               (fun msg -> (this ()).feedback_handler msg);
+    sup_args = sup_args;
+    reset_handler = (fun _ _ k -> k ());
+    feedback_handler = (fun _ -> ());
+    status = New;
+  })
 
-let respawn_coqtop coqtop = spawn_coqtop coqtop.sup_args
+let set_reset_handler coqtop hook = coqtop.reset_handler <- hook
 
-let interrupter = ref (fun pid -> Unix.kill pid Sys.sigint)
-let killer = ref (fun pid -> Unix.kill pid Sys.sigkill)
+let set_feedback_handler coqtop hook = coqtop.feedback_handler <- hook
+
+let is_computing coqtop = (coqtop.status = Busy)
+
+(* For closing a coqtop, we don't try to send it a Quit call anymore,
+   but rather close its channels:
+    - a listening coqtop will handle this just as a Quit call
+    - a busy coqtop will anyway have to be killed *)
+
+let close_coqtop coqtop =
+  coqtop.status <- Closed;
+  clear_handle coqtop.handle
+
+let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop
 
 let break_coqtop coqtop =
-  try !interrupter coqtop.pid
-  with _ -> prerr_endline "Error while sending Ctrl-C"
-
-let kill_coqtop coqtop =
-  let pid = coqtop.pid in
-  begin
-    try !killer pid
-    with _ -> prerr_endline "Kill -9 failed. Process already terminated ?"
-  end;
-  try
-    ignore (Unix.waitpid [] pid);
-    Mutex.lock toplvl_ctr_mtx; decr toplvl_ctr; Mutex.unlock toplvl_ctr_mtx
-  with _ -> prerr_endline "Error while waiting for child"
+  try !interrupter (CoqTop.unixpid coqtop.handle.proc)
+  with _ -> Minilib.log "Error while sending Ctrl-C"
 
-(** * Calls to coqtop *)
+let get_arguments coqtop = coqtop.sup_args
 
-(** Cf [Ide_intf] for more details *)
+let set_arguments coqtop args =
+  coqtop.sup_args <- args;
+  reset_coqtop coqtop
+
+let process_task coqtop task =
+  assert (coqtop.status = Ready || coqtop.status = New);
+  coqtop.status <- Busy;
+  try ignore (task coqtop.handle (mkready coqtop))
+  with e ->
+    Minilib.log ("Coqtop writer failed, resetting: " ^ Printexc.to_string e);
+    if coqtop.status <> Closed then respawn_coqtop coqtop
 
-let p = Xml_parser.make ()
-let () = Xml_parser.check_eof p false
+let try_grab coqtop task abort =
+  match coqtop.status with
+    |Closed -> ()
+    |Busy|New -> abort ()
+    |Ready -> process_task coqtop task
 
-let eval_call coqtop (c:'a Ide_intf.call) =
-  Xml_utils.print_xml coqtop.cin (Ide_intf.of_call c);
-  flush coqtop.cin;
-  let xml = Xml_parser.parse p (Xml_parser.SChannel coqtop.cout) in
-  (Ide_intf.to_answer xml c : 'a Interface.value)
+let init_coqtop coqtop task =
+  assert (coqtop.status = New);
+  process_task coqtop task
 
-let interp coqtop ?(raw=false) ?(verbose=true) i s =
-  eval_call coqtop (Ide_intf.interp (i,raw,verbose,s))
-let rewind coqtop i = eval_call coqtop (Ide_intf.rewind i)
-let inloadpath coqtop s = eval_call coqtop (Ide_intf.inloadpath s)
-let mkcases coqtop s = eval_call coqtop (Ide_intf.mkcases s)
-let status coqtop = eval_call coqtop (Ide_intf.status ())
-let hints coqtop = eval_call coqtop (Ide_intf.hints ())
+(** * Calls to coqtop *)
+
+(** Cf [Ide_intf] for more details *)
+
+type 'a query = 'a Interface.value task
+
+let eval_call ?(logger=default_logger) call handle k =
+  (** Send messages to coqtop and prepare the decoding of the answer *)
+  Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call);
+  assert (handle.alive && handle.waiting_for = None);
+  handle.waiting_for <- Some (mk_ccb (call,k), logger);
+  Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call);
+  Minilib.log "End eval_call";
+  Void
+
+let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x)
+let edit_at i = eval_call (Xmlprotocol.edit_at i)
+let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x)
+let mkcases s = eval_call (Xmlprotocol.mkcases s)
+let status ?logger force = eval_call ?logger (Xmlprotocol.status force)
+let hints x = eval_call (Xmlprotocol.hints x)
+let search flags = eval_call (Xmlprotocol.search flags)
+let init x = eval_call (Xmlprotocol.init x)
+let stop_worker x = eval_call (Xmlprotocol.stop_worker x)
 
 module PrintOpt =
 struct
   type t = string list
+
+  (* Boolean options *)
+
   let implicit = ["Printing"; "Implicit"]
   let coercions = ["Printing"; "Coercions"]
-  let raw_matching = ["Printing"; "Matching"; "Synth"]
+  let raw_matching = ["Printing"; "Matching"]
   let notations = ["Printing"; "Notations"]
   let all_basic = ["Printing"; "All"]
   let existential = ["Printing"; "Existential"; "Instances"]
   let universes = ["Printing"; "Universes"]
 
-  let state_hack = Hashtbl.create 11
-  let _ = List.iter (fun opt -> Hashtbl.add state_hack opt false)
-            [ implicit; coercions; raw_matching; notations; all_basic; existential; universes ]
+  type bool_descr = { opts : t list; init : bool; label : string }
+
+  let bool_items = [
+    { opts = [implicit]; init = false; label = "Display _implicit arguments" };
+    { opts = [coercions]; init = false; label = "Display _coercions" };
+    { opts = [raw_matching]; init = true;
+      label = "Display raw _matching expressions" };
+    { opts = [notations]; init = true; label = "Display _notations" };
+    { opts = [all_basic]; init = false;
+      label = "Display _all basic low-level contents" };
+    { opts = [existential]; init = false;
+      label = "Display _existential variable instances" };
+    { opts = [universes]; init = false; label = "Display _universe levels" };
+    { opts = [all_basic;existential;universes]; init = false;
+      label = "Display all _low-level contents" }
+  ]
+
+  (** The current status of the boolean options *)
+
+  let current_state = Hashtbl.create 11
+
+  let set opt v = Hashtbl.replace current_state opt v
+
+  let reset () =
+    let init_descr d = List.iter (fun o -> set o d.init) d.opts in
+    List.iter init_descr bool_items
+
+  let _ = reset ()
+
+  (** Integer option *)
+
+  let width = ["Printing"; "Width"]
+  let width_state = ref None
+  let set_printing_width w = width_state := Some w
 
-  let set coqtop options =
-    let () = List.iter (fun (name, v) -> Hashtbl.replace state_hack name v) options in
-    let options = List.map (fun (name, v) -> (name, Interface.BoolValue v)) options in
-    match eval_call coqtop (Ide_intf.set_options options) with
-    | Interface.Good () -> ()
-    | _ -> raise (Failure "Cannot set options.")
+  (** Transmitting options to coqtop *)
 
-  let enforce_hack coqtop =
-    let elements = Hashtbl.fold (fun opt v acc -> (opt, v) :: acc) state_hack [] in
-    set coqtop elements
+  let enforce h k =
+    let mkopt o v acc = (o, Interface.BoolValue v) :: acc in
+    let opts = Hashtbl.fold mkopt current_state [] in
+    let opts = (width, Interface.IntValue !width_state) :: opts in
+    eval_call (Xmlprotocol.set_options opts) h
+      (function
+	| Interface.Good () -> k ()
+	| _ -> failwith "Cannot set options. Resetting coqtop")
 
 end
 
-let goals coqtop =
-  let () = PrintOpt.enforce_hack coqtop in
-  eval_call coqtop (Ide_intf.goals ())
+let goals ?logger x h k =
+  PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k)
 
-let evars coqtop =
-  let () = PrintOpt.enforce_hack coqtop in
-  eval_call coqtop (Ide_intf.evars ())
+let evars x h k =
+  PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k)
diff --git a/ide/coq.mli b/ide/coq.mli
index c255d08f..a72c67b4 100644
--- a/ide/coq.mli
+++ b/ide/coq.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,67 +8,168 @@
 
 (** Coq : Interaction with the Coq toplevel *)
 
-(** * Version and date *)
+(** {5 General structures} *)
 
-val short_version : unit -> string
-val version : unit -> string
+type coqtop
+(** The structure describing a coqtop sub-process .
 
-(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
-    @return the list of arguments that coqtop did not understand
-    (the files probably ..). This command may terminate coqide in
-    case of trouble.  *)
-val filter_coq_opts : string list -> string list
+    Liveness management of coqtop is automatic. Whenever a coqtop dies abruptly,
+    this module is responsible for relaunching the whole process. The reset
+    handler set through [set_reset_handler] will be called after such an
+    abrupt failure. It is also called when explicitely requesting coqtop to
+    reset. *)
 
-(** Launch a coqtop with the user args in order to be sure that it works,
-    checking in particular that initial.coq is found. This command
-    may terminate coqide in case of trouble *)
-val check_connection : string list -> unit
+type 'a task
+(** Coqtop tasks.
 
-(** * The structure describing a coqtop sub-process *)
+    A task is a group of sequential calls to be performed on a coqtop process,
+    that ultimately return some content.
 
-type coqtop
+    If a task is already sent to coqtop, it is considered busy
+    ([is_computing] will answer [true]), and any other task submission
+    will be rejected by [try_grab].
 
-(** * Count of all active coqtops *)
+    Any exception occuring within the task will trigger a coqtop reset.
 
-val coqtop_zombies : unit -> int
+    Beware, because of the GTK scheduler, you never know when a task will
+    actually be executed. If you need to sequentialize imperative actions, you
+    should do so using the monadic primitives.
+*)
 
-(** * Starting / signaling / ending a real coqtop sub-process *)
+val return : 'a -> 'a task
+(** Monadic return of values as tasks. *)
 
-val spawn_coqtop : string list -> coqtop
-val respawn_coqtop : coqtop -> coqtop
-val kill_coqtop : coqtop -> unit
-val break_coqtop : coqtop -> unit
+val bind : 'a task -> ('a -> 'b task) -> 'b task
+(** Monadic binding of tasks *)
 
-(** In win32, we'll use a different kill function than Unix.kill *)
+val lift : (unit -> 'a) -> 'a task
+(** Return the impertative computation waiting to be processed. *)
 
-val killer : (int -> unit) ref
-val interrupter : (int -> unit) ref
+val seq : unit task -> 'a task -> 'a task
+(** Sequential composition *)
+
+(** {5 Coqtop process management} *)
 
-(** * Calls to Coqtop, cf [Ide_intf] for more details *)
+type reset_kind = Planned | Unexpected
+(** A reset may occur accidentally or voluntarily, so we discriminate between
+    these. *)
 
-val interp :
-  coqtop -> ?raw:bool -> ?verbose:bool -> int -> string -> string Interface.value
-val rewind : coqtop -> int -> int Interface.value
-val status : coqtop -> Interface.status Interface.value
-val goals : coqtop -> Interface.goals option Interface.value
-val evars : coqtop -> Interface.evar list option Interface.value
-val hints : coqtop -> (Interface.hint list * Interface.hint) option Interface.value
-val inloadpath : coqtop -> string -> bool Interface.value
-val mkcases : coqtop -> string -> string list list Interface.value
+val is_computing : coqtop -> bool
+(** Check if coqtop is computing, i.e. already has a current task *)
 
-(** A specialized version of [raw_interp] dedicated to
-    set/unset options. *)
+val spawn_coqtop : string list -> coqtop
+(** Create a coqtop process with some command-line arguments. *)
+
+val set_reset_handler : coqtop -> (reset_kind -> unit task) -> unit
+(** Register a handler called when a coqtop dies (badly or on purpose) *)
+
+val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit
+(** Register a handler called when coqtop sends a feedback message *)
+
+val init_coqtop : coqtop -> unit task -> unit
+(** Finish initializing a freshly spawned coqtop, by running a first task on it.
+    The task should run its inner continuation at the end. *)
+
+val break_coqtop : coqtop -> unit
+(** Interrupt the current computation of coqtop. *)
+
+val close_coqtop : coqtop -> unit
+(** Close coqtop. Subsequent requests will be discarded. Hook ignored. *)
+
+val reset_coqtop : coqtop -> unit
+(** Reset coqtop. Pending requests will be discarded. The reset handler
+    of coqtop will be called with [Planned] as first argument *)
+
+val get_arguments : coqtop -> string list
+(** Get the current arguments used by coqtop. *)
+
+val set_arguments : coqtop -> string list -> unit
+(** Set process arguments. This also forces a planned reset. *)
+
+(** In win32, sockets are not like regular files *)
+val gio_channel_of_descr_socket : (Unix.file_descr -> Glib.Io.channel) ref
+
+(** {5 Task processing} *)
+
+val try_grab : coqtop -> unit task -> (unit -> unit) -> unit
+(** Try to schedule a task on a coqtop. If coqtop is available, the task
+    callback is run (asynchronously), otherwise the [(unit->unit)] callback
+    is triggered.
+    - If coqtop ever dies during the computation, this function restarts coqtop
+      and calls the restart hook with the fresh coqtop.
+    - If the argument function raises an exception, a coqtop reset occurs.
+    - The task may be discarded if a [close_coqtop] or [reset_coqtop] occurs
+      before its completion.
+    - The task callback should run its inner continuation at the end. *)
+
+(** {5 Atomic calls to coqtop} *)
+
+(**
+  These atomic calls can be combined to form arbitrary multi-call tasks.
+  They correspond to the protocol calls (cf [Serialize] for more details).
+  Note that each call is asynchronous: it will return immediately,
+  but the inner callback will be executed later to handle the call answer
+  when this answer is available.
+  Except for interp, we use the default logger for any call. *)
+
+type 'a query = 'a Interface.value task
+(** A type abbreviation for coqtop specific answers *)
+
+val add        : ?logger:Ideutils.logger ->
+                 Interface.add_sty        -> Interface.add_rty query
+val edit_at    : Interface.edit_at_sty    -> Interface.edit_at_rty query
+val query      : ?logger:Ideutils.logger ->
+                 Interface.query_sty      -> Interface.query_rty query
+val status     : ?logger:Ideutils.logger ->
+                 Interface.status_sty     -> Interface.status_rty query
+val goals      : ?logger:Ideutils.logger ->
+                 Interface.goals_sty      -> Interface.goals_rty query
+val evars      : Interface.evars_sty      -> Interface.evars_rty query
+val hints      : Interface.hints_sty      -> Interface.hints_rty query
+val mkcases    : Interface.mkcases_sty    -> Interface.mkcases_rty query
+val search     : Interface.search_sty     -> Interface.search_rty query
+val init       : Interface.init_sty       -> Interface.init_rty query
+
+val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query
+
+(** A specialized version of [raw_interp] dedicated to set/unset options. *)
 
 module PrintOpt :
 sig
-  type t
-  val implicit : t
-  val coercions : t
-  val raw_matching : t
-  val notations : t
-  val all_basic : t
-  val existential : t
-  val universes : t
-
-  val set : coqtop -> (t * bool) list -> unit
+  type t (** Representation of an option *)
+
+  type bool_descr = { opts : t list; init : bool; label : string }
+
+  val bool_items : bool_descr list
+
+  val set : t -> bool -> unit
+  val set_printing_width : int -> unit
+
+  (** [enforce] transmits to coq the current option values.
+      It is also called by [goals] and [evars] above. *)
+
+  val enforce : unit task
 end
+
+(** {5 Miscellaneous} *)
+
+val short_version : unit -> string
+(** Return a short phrase identifying coqtop version and date of compilation, as
+    given by the [configure] script. *)
+
+val version : unit -> string
+(** More verbose description, including details about libraries and
+    architecture. *)
+
+val filter_coq_opts : string list -> string list
+(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
+    @return the list of arguments that coqtop did not understand
+    (the files probably ..). This command may terminate coqide in
+    case of trouble.  *)
+
+val check_connection : string list -> unit
+(** Launch a coqtop with the user args in order to be sure that it works,
+    checking in particular that Prelude.vo is found. This command
+    may terminate coqide in case of trouble *)
+
+val interrupter : (int -> unit) ref
diff --git a/ide/coq.png b/ide/coq.png
index 06aac459..cccd5a9a 100644
--- a/ide/coq.png
+++ b/ide/coq.png
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
new file mode 100644
index 00000000..52e18456
--- /dev/null
+++ b/ide/coqOps.ml
@@ -0,0 +1,824 @@
+(************************************************************************)
+(*  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 Util
+open Coq
+open Ideutils
+open Interface
+open Feedback
+
+type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ]
+type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
+let mem_flag_of_flag : flag -> mem_flag = function
+  | `ERROR _ -> `ERROR
+  | (`INCOMPLETE | `UNSAFE | `PROCESSING) as mem_flag -> mem_flag
+let str_of_flag = function
+  | `UNSAFE -> "U"
+  | `PROCESSING -> "P"
+  | `ERROR _ -> "E"
+  | `INCOMPLETE -> "I"
+
+class type signals =
+object
+  inherit GUtil.ml_signals
+  method changed : callback:(int * mem_flag list -> unit) -> GtkSignal.id
+end
+
+module SentenceId : sig
+
+  type sentence = private {
+    start : GText.mark;
+    stop : GText.mark;
+    mutable flags : flag list;
+    mutable tooltips : (int * int * string) list;
+    edit_id : int;
+    mutable index : int;
+    changed_sig : (int * mem_flag list) GUtil.signal;
+  }
+
+  val mk_sentence :
+    start:GText.mark -> stop:GText.mark -> flag list -> sentence
+
+  val set_flags : sentence -> flag list -> unit
+  val add_flag : sentence -> flag -> unit
+  val has_flag : sentence -> mem_flag -> bool
+  val remove_flag : sentence -> mem_flag -> unit
+  val same_sentence : sentence -> sentence -> bool
+  val hidden_edit_id : unit -> int
+  val find_all_tooltips : sentence -> int -> string list
+  val add_tooltip : sentence -> int -> int -> string -> unit
+  val set_index : sentence -> int -> unit
+
+  val connect : sentence -> signals
+
+  val dbg_to_string :
+    GText.buffer -> bool -> Stateid.t option -> sentence -> Pp.std_ppcmds
+
+end = struct
+
+  type sentence = {
+    start : GText.mark;
+    stop : GText.mark;
+    mutable flags : flag list;
+    mutable tooltips : (int * int * string) list;
+    edit_id : int;
+    mutable index : int;
+    changed_sig : (int * mem_flag list) GUtil.signal;
+  }
+
+  let connect s : signals =
+    object
+      inherit GUtil.ml_signals [s.changed_sig#disconnect]
+      method changed = s.changed_sig#connect ~after
+    end
+
+  let id = ref 0
+  let mk_sentence ~start ~stop flags = decr id; {
+    start = start;
+    stop = stop;
+    flags = flags;
+    edit_id = !id;
+    tooltips = [];
+    index = -1;
+    changed_sig = new GUtil.signal ();
+  }
+  let hidden_edit_id () = decr id; !id
+
+  let changed s =
+    s.changed_sig#call (s.index, List.map mem_flag_of_flag s.flags)
+
+  let set_flags s f = s.flags <- f; changed s
+  let add_flag s f = s.flags <- CList.add_set (=) f s.flags; changed s
+  let has_flag s mf =
+    List.exists (fun f -> mem_flag_of_flag f = mf) s.flags
+  let remove_flag s mf =
+    s.flags <- List.filter (fun f -> mem_flag_of_flag f <> mf) s.flags; changed s
+  let same_sentence s1 s2 = s1.edit_id = s2.edit_id
+  let find_all_tooltips s off =
+    CList.map_filter (fun (start,stop,t) ->
+      if start <= off && off <= stop then Some t else None)
+    s.tooltips
+  let add_tooltip s a b t = s.tooltips <- (a,b,t) :: s.tooltips
+
+  let set_index s i = s.index <- i
+
+  let dbg_to_string (b : GText.buffer) focused id s =
+    let ellipsize s =
+            Str.global_replace (Str.regexp "^[\n ]*") ""
+        (if String.length s > 20 then String.sub s 0 17 ^ "..."
+         else s) in
+    Pp.str (Printf.sprintf "%s[%3d,%3s](%5d,%5d) %s [%s] %s"
+      (if focused then "*" else " ")
+      s.edit_id
+      (Stateid.to_string (Option.default Stateid.dummy id))
+      (b#get_iter_at_mark s.start)#offset
+      (b#get_iter_at_mark s.stop)#offset
+      (ellipsize
+        ((b#get_iter_at_mark s.start)#get_slice (b#get_iter_at_mark s.stop)))
+      (String.concat "," (List.map str_of_flag s.flags))
+      (ellipsize
+        (String.concat ","
+          (List.map (fun (a,b,t) ->
+             Printf.sprintf "<%d,%d> %s" a b t) s.tooltips))))
+
+
+end
+open SentenceId
+
+let prefs = Preferences.current
+
+let log msg : unit task =
+  Coq.lift (fun () -> Minilib.log msg)
+
+class type ops =
+object
+  method go_to_insert : unit task
+  method go_to_mark : GText.mark -> unit task
+  method tactic_wizard : string list -> unit task
+  method process_next_phrase : unit task
+  method process_until_end_or_error : unit task
+  method handle_reset_initial : Coq.reset_kind -> unit task
+  method raw_coq_query : string -> unit task
+  method show_goals : unit task
+  method backtrack_last_phrase : unit task
+  method initialize : unit task
+  method join_document : unit task
+  method stop_worker : string -> unit task
+
+  method get_n_errors : int
+  method get_errors : (int * string) list
+  method get_slaves_status : int * int * string CString.Map.t
+
+  method handle_failure : handle_exn_rty -> unit task
+
+  method destroy : unit -> unit
+end
+
+let flags_to_color f =
+  let of_col c = `NAME (Tags.string_of_color c) in
+  if List.mem `PROCESSING f then `NAME "blue"
+  else if List.mem `ERROR f then `NAME "red"
+  else if List.mem `UNSAFE f then `NAME "orange"
+  else if List.mem `INCOMPLETE f then `NAME "gray"
+  else of_col (Tags.get_processed_color ())
+
+module Doc = Document
+
+class coqops
+  (_script:Wg_ScriptView.script_view)
+  (_pv:Wg_ProofView.proof_view)
+  (_mv:Wg_MessageView.message_view)
+  (_sg:Wg_Segment.segment)
+  (_ct:Coq.coqtop)
+  get_filename =
+object(self)
+  val script = _script
+  val buffer = (_script#source_buffer :> GText.buffer)
+  val proof = _pv
+  val messages = _mv
+  val segment = _sg
+
+  val document : sentence Doc.document = Doc.create ()
+  val mutable document_length = 0
+
+  val mutable initial_state = Stateid.initial
+
+  (* proofs being processed by the slaves *)
+  val mutable to_process = 0
+  val mutable processed = 0
+  val mutable slaves_status = CString.Map.empty
+
+  val feedbacks : feedback Queue.t = Queue.create ()
+  val feedback_timer = Ideutils.mktimer ()
+
+  initializer
+    Coq.set_feedback_handler _ct self#enqueue_feedback;
+    script#misc#set_has_tooltip true;
+    ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback);
+    feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback;
+    let on_changed (i, f) = segment#add i (flags_to_color f) in
+    let on_push s =
+      set_index s document_length;
+      (SentenceId.connect s)#changed on_changed;
+      document_length <- succ document_length;
+      segment#set_length document_length;
+      let flags = List.map mem_flag_of_flag s.flags in
+      segment#add s.index (flags_to_color flags);
+    in
+    let on_pop s =
+      set_index s (-1);
+      document_length <- pred document_length;
+      segment#set_length document_length;
+    in
+    let _ = (Doc.connect document)#pushed on_push in
+    let _ = (Doc.connect document)#popped on_pop in
+    ()
+
+  method private tooltip_callback ~x ~y ~kbd tooltip =
+    let x, y = script#window_to_buffer_coords `WIDGET x y in
+    let iter = script#get_iter_at_location x y in
+    if iter#has_tag Tags.Script.tooltip then begin
+      let s =
+        let rec aux iter =
+          let marks = iter#marks in
+          if marks = [] then aux iter#backward_char
+          else
+            let mem_marks _ _ s =
+              List.exists (fun m ->
+                Gobject.get_oid m =
+                Gobject.get_oid (buffer#get_mark s.start)) marks in
+            try Doc.find document mem_marks 
+            with Not_found -> aux iter#backward_char in
+        aux iter in
+      let ss =
+        find_all_tooltips s
+          (iter#offset - (buffer#get_iter_at_mark s.start)#offset) in
+      let msg = String.concat "\n" (CList.uniquize ss) in
+      GtkBase.Tooltip.set_icon_from_stock tooltip `INFO `BUTTON;
+      script#misc#set_tooltip_markup ("<tt>" ^ msg ^ "</tt>")
+    end else begin
+      script#misc#set_tooltip_text ""; script#misc#set_has_tooltip true
+    end;
+    false
+    
+  method destroy () =
+    feedback_timer.Ideutils.kill ()
+
+  method private print_stack =
+    Minilib.log "document:";
+    Minilib.log (Pp.string_of_ppcmds (Doc.print document (dbg_to_string buffer)))
+
+  method private enter_focus start stop =
+    let at id id' _ = Stateid.equal id' id in
+    self#print_stack;
+    Minilib.log("Focusing "^Stateid.to_string start^" "^Stateid.to_string stop);
+    Doc.focus document ~cond_top:(at start) ~cond_bot:(at stop);
+    self#print_stack;
+    let qed_s = Doc.tip_data document in
+    buffer#apply_tag Tags.Script.read_only
+      ~start:((buffer#get_iter_at_mark qed_s.start)#forward_find_char
+        (fun c -> not(Glib.Unichar.isspace c)))
+      ~stop:(buffer#get_iter_at_mark qed_s.stop);
+    buffer#move_mark ~where:(buffer#get_iter_at_mark qed_s.stop)
+      (`NAME "stop_of_input")
+
+  method private exit_focus =
+    Minilib.log "Unfocusing";
+    begin try
+      let { start; stop } = Doc.tip_data document in
+      buffer#remove_tag Tags.Script.read_only
+        ~start:(buffer#get_iter_at_mark start)
+        ~stop:(buffer#get_iter_at_mark stop)
+    with Doc.Empty -> () end;
+    Doc.unfocus document;
+    self#print_stack;
+    begin try
+      let where = buffer#get_iter_at_mark (Doc.tip_data document).stop in
+      buffer#move_mark ~where (`NAME "start_of_input");
+    with Doc.Empty -> () end;
+    buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input")
+
+  method private get_start_of_input =
+    buffer#get_iter_at_mark (`NAME "start_of_input")
+  
+  method private get_end_of_input =
+    buffer#get_iter_at_mark (`NAME "stop_of_input")
+
+  method private get_insert =
+    buffer#get_iter_at_mark `INSERT
+
+  method private show_goals_aux ?(move_insert=false) () =
+    Coq.PrintOpt.set_printing_width proof#width;
+    if move_insert then begin
+      buffer#place_cursor ~where:self#get_start_of_input;
+      script#recenter_insert;
+    end;
+    Coq.bind (Coq.goals ~logger:messages#push ()) (function
+    | Fail x -> self#handle_failure_aux ~move_insert x
+    | Good goals ->
+      Coq.bind (Coq.evars ()) (function
+        | Fail x -> self#handle_failure_aux ~move_insert x
+        | Good evs ->
+          proof#set_goals goals;
+          proof#set_evars evs;
+          proof#refresh ();
+          Coq.return ()
+        )
+      )
+  method show_goals = self#show_goals_aux ()
+
+  (* This method is intended to perform stateless commands *)
+  method raw_coq_query phrase =
+    let action = log "raw_coq_query starting now" in
+    let display_error s =
+      if not (Glib.Utf8.validate s) then
+        flash_info "This error is so nasty that I can't even display it."
+      else messages#add s;
+    in
+    let query =
+      Coq.query ~logger:messages#push (phrase,Stateid.dummy) in
+    let next = function
+    | Fail (_, _, err) -> display_error err; Coq.return ()
+    | Good msg ->
+      messages#add msg; Coq.return ()
+    in
+    Coq.bind (Coq.seq action query) next
+
+  method private mark_as_needed sentence =
+    Minilib.log("Marking " ^
+      Pp.string_of_ppcmds (dbg_to_string buffer false None sentence));
+    let start = buffer#get_iter_at_mark sentence.start in
+    let stop = buffer#get_iter_at_mark sentence.stop in
+    let to_process = Tags.Script.to_process in
+    let processed = Tags.Script.processed in
+    let unjustified = Tags.Script.unjustified in
+    let error_bg = Tags.Script.error_bg in
+    let error = Tags.Script.error in
+    let incomplete = Tags.Script.incomplete in
+    let all_tags = [
+      error_bg; to_process; incomplete; processed; unjustified; error ] in
+    let tags =
+      (if has_flag sentence `PROCESSING then [to_process]
+       else if has_flag sentence `ERROR then [error_bg]
+       else if has_flag sentence `INCOMPLETE then [incomplete]
+       else [processed]) @
+      (if [ `UNSAFE ] = sentence.flags then [unjustified] else [])
+    in
+    List.iter (fun t -> buffer#remove_tag t ~start ~stop) all_tags;
+    List.iter (fun t -> buffer#apply_tag t ~start ~stop) tags
+
+  method private attach_tooltip sentence loc text =
+    let start_sentence, stop_sentence, phrase = self#get_sentence sentence in
+    let pre_chars, post_chars =
+      if Loc.is_ghost loc then 0, String.length phrase else Loc.unloc loc in
+    let pre = Ideutils.glib_utf8_pos_to_offset phrase ~off:pre_chars in
+    let post = Ideutils.glib_utf8_pos_to_offset phrase ~off:post_chars in
+    let start = start_sentence#forward_chars pre in
+    let stop = start_sentence#forward_chars post in
+    let markup = Glib.Markup.escape_text text in
+    buffer#apply_tag Tags.Script.tooltip ~start ~stop;
+    add_tooltip sentence pre post markup
+
+  method private is_dummy_id id =
+    match id with
+    | Edit 0 -> true
+    | State id when Stateid.equal id Stateid.dummy -> true
+    | _ -> false
+
+  method private enqueue_feedback msg =
+    let id = msg.id in
+    if self#is_dummy_id id then () else Queue.add msg feedbacks
+    
+  method private process_feedback () =
+    let rec eat_feedback n =
+      if n = 0 then true else
+      let msg = Queue.pop feedbacks in
+      let id = msg.id in
+      let sentence =
+        let finder _ state_id s =
+          match state_id, id with
+          | Some id', State id when Stateid.equal id id' -> Some (state_id, s)
+          | _, Edit id when id = s.edit_id -> Some (state_id, s)
+          | _ -> None in
+        try Some (Doc.find_map document finder)
+        with Not_found -> None in
+      let log s state_id =
+        Minilib.log ("Feedback " ^ s ^ " on " ^ Stateid.to_string
+          (Option.default Stateid.dummy state_id)) in
+      begin match msg.contents, sentence with
+      | AddedAxiom, Some (id,sentence) ->
+          log "AddedAxiom" id;
+          remove_flag sentence `PROCESSING;
+          remove_flag sentence `ERROR;
+          add_flag sentence `UNSAFE;
+          self#mark_as_needed sentence
+      | Processed, Some (id,sentence) ->
+          log "Processed" id;
+          remove_flag sentence `PROCESSING;
+          remove_flag sentence `ERROR;
+          self#mark_as_needed sentence
+      | ProcessingIn _,  Some (id,sentence) ->
+          log "ProcessingIn" id;
+          add_flag sentence `PROCESSING;
+          self#mark_as_needed sentence
+      | Incomplete, Some (id, sentence) ->
+          log "Incomplete" id;
+          add_flag sentence `INCOMPLETE;
+          self#mark_as_needed sentence
+      | Complete, Some (id, sentence) ->
+          log "Complete" id;
+          remove_flag sentence `INCOMPLETE;
+          self#mark_as_needed sentence
+      | GlobRef(loc, filepath, modpath, ident, ty), Some (id,sentence) ->
+          log "GlobRef" id;
+          self#attach_tooltip sentence loc
+            (Printf.sprintf "%s %s %s" filepath ident ty)
+      | ErrorMsg(loc, msg), Some (id,sentence) ->
+          log "ErrorMsg" id;
+          remove_flag sentence `PROCESSING;
+          add_flag sentence (`ERROR msg);
+          self#mark_as_needed sentence;
+          self#attach_tooltip sentence loc msg;
+          if not (Loc.is_ghost loc) then
+            self#position_error_tag_at_sentence sentence (Some (Loc.unloc loc))
+      | InProgress n, _ ->
+          if n < 0 then processed <- processed + abs n
+          else to_process <- to_process + n
+      | WorkerStatus(id,status), _ ->
+          log "WorkerStatus" None;
+          slaves_status <- CString.Map.add id status slaves_status
+
+      | _ ->
+          if sentence <> None then Minilib.log "Unsupported feedback message"
+          else if Doc.is_empty document then ()
+          else
+            try
+              match id, Doc.tip document with
+              | Edit _, _ -> ()
+              | State id1, id2 when Stateid.newer_than id2 id1 -> ()
+              | _ -> Queue.add msg feedbacks
+            with Doc.Empty | Invalid_argument _ -> Queue.add msg feedbacks 
+      end;
+        eat_feedback (n-1)
+    in
+      eat_feedback (Queue.length feedbacks)
+
+  method private commit_queue_transaction sentence =
+    (* A queued command has been successfully done, we push it to [cmd_stack].
+       We reget the iters here because Gtk is unable to warranty that they
+       were not modified meanwhile. Not really necessary but who knows... *)
+    self#mark_as_needed sentence;
+    let stop = buffer#get_iter_at_mark sentence.stop in
+    buffer#move_mark ~where:stop (`NAME "start_of_input");
+
+  method private position_error_tag_at_iter iter phrase = function
+    | None -> ()
+    | Some (start, stop) ->
+        buffer#apply_tag Tags.Script.error
+          ~start:(iter#forward_chars (byte_offset_to_char_offset phrase start))
+          ~stop:(iter#forward_chars (byte_offset_to_char_offset phrase stop))
+
+  method private position_error_tag_at_sentence sentence loc =
+    let start, _, phrase = self#get_sentence sentence in
+    self#position_error_tag_at_iter start phrase loc
+
+  method private process_interp_error queue sentence loc msg tip id =
+    Coq.bind (Coq.return ()) (function () ->
+    let start, stop, phrase = self#get_sentence sentence in
+    buffer#remove_tag Tags.Script.to_process ~start ~stop;
+    self#discard_command_queue queue;
+    pop_info ();
+    if Stateid.equal id tip || Stateid.equal id Stateid.dummy then begin
+      self#position_error_tag_at_iter start phrase loc;
+      buffer#place_cursor ~where:stop;
+      messages#clear;
+      messages#push Pp.Error msg;
+      self#show_goals
+    end else
+      self#show_goals_aux ~move_insert:true ()
+    )
+
+  method private get_sentence sentence =
+    let start = buffer#get_iter_at_mark sentence.start in
+    let stop = buffer#get_iter_at_mark sentence.stop in
+    let phrase = start#get_slice ~stop in
+    start, stop, phrase
+
+  (** [fill_command_queue until q] fills a command queue until the [until]
+      condition returns true; it is fed with the number of phrases read and the
+      iters enclosing the current sentence. *)
+  method private fill_command_queue until queue =
+    let rec loop n iter =
+      match Sentence.find buffer iter with
+      | None -> ()
+      | Some (start, stop) ->
+        if until n start stop then begin
+          ()
+        end else if start#has_tag Tags.Script.processed then begin
+          Queue.push (`Skip (start, stop)) queue;
+          loop n stop
+        end else begin
+          buffer#apply_tag Tags.Script.to_process ~start ~stop;
+          let sentence =
+            mk_sentence
+              ~start:(`MARK (buffer#create_mark start))
+              ~stop:(`MARK (buffer#create_mark stop))
+              [] in
+          Queue.push (`Sentence sentence) queue;
+          if not stop#is_end then loop (succ n) stop
+        end
+    in
+    loop 0 self#get_start_of_input
+
+  method private discard_command_queue queue =
+    while not (Queue.is_empty queue) do
+      match Queue.pop queue with
+      | `Skip _ -> ()
+      | `Sentence sentence ->
+          let start = buffer#get_iter_at_mark sentence.start in
+          let stop = buffer#get_iter_at_mark sentence.stop in
+          buffer#remove_tag Tags.Script.to_process ~start ~stop;
+          buffer#delete_mark sentence.start;
+          buffer#delete_mark sentence.stop;
+    done
+
+  (** Compute the phrases until [until] returns [true]. *)
+  method private process_until ?move_insert until verbose =
+    let logger lvl msg = if verbose then messages#push lvl msg in
+    let fill_queue = Coq.lift (fun () ->
+      let queue = Queue.create () in
+      (* Lock everything and fill the waiting queue *)
+      push_info "Coq is computing";
+      messages#clear;
+      script#set_editable false;
+      self#fill_command_queue until queue;
+      (* Now unlock and process asynchronously. Since [until]
+        may contain iterators, it shouldn't be used anymore *)
+      script#set_editable true;
+      Minilib.log "Begin command processing";
+      queue) in
+    let conclude topstack =
+      pop_info ();
+      script#recenter_insert;
+      match topstack with
+      | [] -> self#show_goals_aux ?move_insert ()
+      | (_,s) :: _ -> self#backtrack_to_iter (buffer#get_iter_at_mark s.start) in
+    let process_queue queue =
+      let rec loop tip topstack =
+        if Queue.is_empty queue then conclude topstack else
+        match Queue.pop queue, topstack with
+        | `Skip(start,stop), [] -> assert false
+        | `Skip(start,stop), (_,s) :: topstack ->
+            assert(start#equal (buffer#get_iter_at_mark s.start));
+            assert(stop#equal (buffer#get_iter_at_mark s.stop));
+            loop tip topstack
+        | `Sentence sentence, _ :: _ -> assert false
+        | `Sentence ({ edit_id } as sentence), [] ->
+            add_flag sentence `PROCESSING;
+            Doc.push document sentence;
+            let _, _, phrase = self#get_sentence sentence in
+            let coq_query = Coq.add ~logger ((phrase,edit_id),(tip,verbose)) in
+            let handle_answer = function
+              | Good (id, (Util.Inl (* NewTip *) (), msg)) ->
+                  Doc.assign_tip_id document id;
+                  logger Pp.Notice msg;
+                  self#commit_queue_transaction sentence;
+                  loop id []
+              | Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
+                  Doc.assign_tip_id document id;
+                  let topstack, _ = Doc.context document in
+                  self#exit_focus;
+                  self#cleanup (Doc.cut_at document tip);
+                  logger Pp.Notice msg;
+                  self#mark_as_needed sentence;
+                  if Queue.is_empty queue then loop tip []
+                  else loop tip (List.rev topstack)
+              | Fail (id, loc, msg) ->
+                  let sentence = Doc.pop document in
+                  self#process_interp_error queue sentence loc msg tip id in
+            Coq.bind coq_query handle_answer
+      in
+      let tip =
+        try Doc.tip document
+        with Doc.Empty -> initial_state | Invalid_argument _ -> assert false in
+      loop tip [] in
+    Coq.bind fill_queue process_queue
+  
+  method join_document =
+   let next = function
+     | Good _ ->
+         messages#clear;
+         messages#push Pp.Info "All proof terms checked by the kernel";
+         Coq.return ()
+     | Fail x -> self#handle_failure x in
+   Coq.bind (Coq.status ~logger:messages#push true) next
+
+  method stop_worker n =
+    Coq.bind (Coq.stop_worker n) (fun _ -> Coq.return ())
+
+  method get_slaves_status = processed, to_process, slaves_status
+
+  method get_n_errors =
+    Doc.fold_all document 0 (fun n _ _ s -> if has_flag s `ERROR then n+1 else n)
+
+  method get_errors =
+    let extract_error s =
+      match List.find (function `ERROR _ -> true | _ -> false) s.flags with
+      | `ERROR msg -> (buffer#get_iter_at_mark s.start)#line + 1, msg
+      | _ -> assert false in
+    List.rev
+      (Doc.fold_all document [] (fun acc _ _ s ->
+        if has_flag s `ERROR then extract_error s :: acc else acc))
+
+  method process_next_phrase =
+    let until n _ _ = n >= 1 in
+    self#process_until ~move_insert:true until true
+
+  method private process_until_iter iter =
+    let until _ start stop =
+      if prefs.Preferences.stop_before then stop#compare iter > 0
+      else start#compare iter >= 0
+    in
+    self#process_until until false
+
+  method process_until_end_or_error =
+    self#process_until_iter self#get_end_of_input
+
+  (* finds the state_id and if it an unfocus is needed to reach it *)
+  method private find_id until =
+    try
+      Doc.find_id document (fun id { start;stop } -> until (Some id) start stop)
+    with Not_found -> initial_state, Doc.focused document 
+
+  method private cleanup seg =
+    if seg <> [] then begin
+      let start = buffer#get_iter_at_mark (CList.last seg).start in
+      let stop = buffer#get_iter_at_mark (CList.hd seg).stop in
+      Minilib.log
+        (Printf.sprintf "Cleanup in range %d -> %d" start#offset stop#offset);
+      buffer#remove_tag Tags.Script.processed ~start ~stop;
+      buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+      buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+      buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+      buffer#remove_tag Tags.Script.to_process ~start ~stop;
+      buffer#move_mark ~where:start (`NAME "start_of_input")
+    end;
+    List.iter (fun { start } -> buffer#delete_mark start) seg;
+    List.iter (fun { stop } -> buffer#delete_mark stop) seg
+
+  (** Wrapper around the raw undo command *)
+  method private backtrack_to_id ?(move_insert=true) (to_id, unfocus_needed) =
+    Minilib.log("backtrack_to_id "^Stateid.to_string to_id^
+      " (unfocus_needed="^string_of_bool unfocus_needed^")");
+    let opening () =
+      push_info "Coq is undoing" in
+    let conclusion () =
+      pop_info ();
+      if move_insert then buffer#place_cursor ~where:self#get_start_of_input;
+      let start = self#get_start_of_input in
+      let stop = self#get_end_of_input in
+      Minilib.log(Printf.sprintf "cleanup tags %d %d" start#offset stop#offset);
+      buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+      buffer#remove_tag Tags.Script.processed ~start ~stop;
+      buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+      buffer#remove_tag Tags.Script.to_process ~start ~stop;
+      buffer#remove_tag Tags.Script.unjustified ~start ~stop;
+      self#show_goals in
+    Coq.bind (Coq.lift opening) (fun () ->
+    let rec undo to_id unfocus_needed =
+      Coq.bind (Coq.edit_at to_id) (function
+      | Good (CSig.Inl (* NewTip *) ()) ->
+          if unfocus_needed then self#exit_focus;
+          self#cleanup (Doc.cut_at document to_id);
+          conclusion ()
+      | Good (CSig.Inr (* Focus  *) (stop_id,(start_id,tip))) ->
+          if unfocus_needed then self#exit_focus;
+          self#cleanup (Doc.cut_at document tip);
+          self#enter_focus start_id stop_id;
+          self#cleanup (Doc.cut_at document to_id);
+          conclusion ()
+      | Fail (safe_id, loc, msg) ->
+          if loc <> None then messages#push Pp.Error "Fixme LOC";
+          messages#push Pp.Error msg;
+          if Stateid.equal safe_id Stateid.dummy then self#show_goals
+          else undo safe_id
+                 (Doc.focused document && Doc.is_in_focus document safe_id))
+    in
+      undo to_id unfocus_needed)
+  
+  method private backtrack_until ?move_insert until =
+    self#backtrack_to_id ?move_insert (self#find_id until)
+
+  method private backtrack_to_iter ?move_insert iter =
+    let until _ _ stop = iter#compare (buffer#get_iter_at_mark stop) >= 0 in
+    self#backtrack_until ?move_insert until
+
+  method private handle_failure_aux
+    ?(move_insert=false) (safe_id, (loc : (int * int) option), msg)
+  =
+    messages#clear;
+    messages#push Pp.Error msg;
+    ignore(self#process_feedback ());
+    if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ())
+    else
+      Coq.seq
+        (self#backtrack_until ~move_insert
+          (fun id _ _ -> id = Some safe_id))
+        (Coq.lift (fun () -> script#recenter_insert))
+
+  method handle_failure f = self#handle_failure_aux f
+
+  method backtrack_last_phrase =
+    messages#clear;
+    try 
+      let tgt = Doc.before_tip document in
+      self#backtrack_to_id tgt
+    with Not_found -> Coq.return (Coq.reset_coqtop _ct)
+
+  method go_to_insert =
+    Coq.bind (Coq.return ()) (fun () ->
+    messages#clear;
+    let point = self#get_insert in
+    if point#compare self#get_start_of_input >= 0
+    then self#process_until_iter point
+    else self#backtrack_to_iter ~move_insert:false point)
+
+  method go_to_mark m =
+    Coq.bind (Coq.return ()) (fun () ->
+    messages#clear;
+    let point = buffer#get_iter_at_mark m in
+    if point#compare self#get_start_of_input >= 0
+    then Coq.seq (self#process_until_iter point)
+          (Coq.lift (fun () -> Sentence.tag_on_insert buffer))
+    else Coq.seq (self#backtrack_to_iter ~move_insert:false point)
+          (Coq.lift (fun () -> Sentence.tag_on_insert buffer)))
+
+  method tactic_wizard l =
+    let insert_phrase phrase tag =
+      let stop = self#get_start_of_input in
+      let phrase' = if stop#starts_line then phrase else "\n"^phrase in
+      buffer#insert ~iter:stop phrase';
+      Sentence.tag_on_insert buffer;
+      let start = self#get_start_of_input in
+      buffer#move_mark ~where:stop (`NAME "start_of_input");
+      buffer#apply_tag tag ~start ~stop;
+      if self#get_insert#compare stop <= 0 then
+        buffer#place_cursor ~where:stop;
+      let sentence =
+        mk_sentence
+          ~start:(`MARK (buffer#create_mark start))
+          ~stop:(`MARK (buffer#create_mark stop))
+          [] in
+      Doc.push document sentence;
+      messages#clear;
+      self#show_goals
+    in
+    let display_error (loc, s) =
+      if not (Glib.Utf8.validate s) then
+        flash_info "This error is so nasty that I can't even display it."
+      else messages#add s
+    in
+    let try_phrase phrase stop more =
+      let action = log "Sending to coq now" in
+      let query = Coq.query (phrase,Stateid.dummy) in
+      let next = function
+      | Fail (_, l, str) -> (* FIXME: check *)
+        display_error (l, str);
+        messages#add ("Unsuccessfully tried: "^phrase);
+        more
+      | Good msg ->
+        messages#add msg;
+        stop Tags.Script.processed
+      in
+      Coq.bind (Coq.seq action query) next
+    in
+    let rec loop l = match l with
+      | [] -> Coq.return ()
+      | p :: l' ->
+        try_phrase ("progress "^p^".") (insert_phrase (p^".")) (loop l')
+    in
+    loop l
+
+  method handle_reset_initial why =
+    let action () =
+      if why = Coq.Unexpected then warning "Coqtop died badly. Resetting."
+      else
+      (* clear the stack *)
+      if Doc.focused document then Doc.unfocus document;
+      while not (Doc.is_empty document) do
+        let phrase = Doc.pop document in
+        buffer#delete_mark phrase.start;
+        buffer#delete_mark phrase.stop
+      done;
+      List.iter
+        (buffer#remove_tag ~start:buffer#start_iter ~stop:buffer#end_iter)
+        Tags.Script.all;
+      (* reset the buffer *)
+      buffer#move_mark ~where:buffer#start_iter (`NAME "start_of_input");
+      buffer#move_mark ~where:buffer#end_iter (`NAME "stop_of_input");
+      Sentence.tag_all buffer;
+      (* clear the views *)
+      messages#clear;
+      proof#clear ();
+      clear_info ();
+      processed <- 0;
+      to_process <- 0;
+      push_info "Restarted";
+      (* apply the initial commands to coq *)
+    in
+    Coq.seq (Coq.lift action) self#initialize
+
+  method initialize =
+    let get_initial_state =
+      let next = function
+      | Fail _ -> messages#set ("Couln't initialize Coq"); Coq.return ()
+      | Good id -> initial_state <- id; Coq.return () in
+      Coq.bind (Coq.init (get_filename ())) next in
+    Coq.seq get_initial_state Coq.PrintOpt.enforce
+
+end
diff --git a/ide/coqOps.mli b/ide/coqOps.mli
new file mode 100644
index 00000000..8e76d3b2
--- /dev/null
+++ b/ide/coqOps.mli
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  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 Coq
+
+class type ops =
+object
+  method go_to_insert : unit task
+  method go_to_mark : GText.mark -> unit task
+  method tactic_wizard : string list -> unit task
+  method process_next_phrase : unit task
+  method process_until_end_or_error : unit task
+  method handle_reset_initial : Coq.reset_kind -> unit task
+  method raw_coq_query : string -> unit task
+  method show_goals : unit task
+  method backtrack_last_phrase : unit task
+  method initialize : unit task
+  method join_document : unit task
+  method stop_worker : string -> unit task
+
+  method get_n_errors : int
+  method get_errors : (int * string) list
+  method get_slaves_status : int * int * string CString.Map.t
+
+
+  method handle_failure : Interface.handle_exn_rty -> unit task
+  
+  method destroy : unit -> unit
+end
+
+class coqops :
+  Wg_ScriptView.script_view ->
+  Wg_ProofView.proof_view ->
+  Wg_MessageView.message_view ->
+  Wg_Segment.segment ->
+  coqtop ->
+  (unit -> string option) ->
+  ops
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index cd189981..995c45c5 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.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        *)
@@ -92,6 +92,7 @@ let commands = [
    ];
   ["Read Module";
    "Record";
+   "Variant";
    "Remark";
    "Remove LoadPath";
    "Remove Printing Constructor";
@@ -207,7 +208,8 @@ let state_preserving = [
   "Recursive Extraction Library";
 
   "Search";
-  "SearchAbout";
+  "SearchAbout (* deprecated *)";
+  "SearchHead";
   "SearchPattern";
   "SearchRewrite";
 
diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll
index 1de102d5..e333c0b2 100644
--- a/ide/coq_lex.mll
+++ b/ide/coq_lex.mll
@@ -1,161 +1,57 @@
 (************************************************************************)
 (*  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 Lexing
-
-  type token =
-    | Comment
-    | Keyword
-    | Declaration
-    | ProofDeclaration
-    | Qed
-    | String
-
-  (* Without this table, the automaton would be too big and
-     ocamllex would fail *)
-
-  let tag_of_ident =
-    let one_word_commands =
-      [ "Add" ; "Check"; "Eval"; "Extraction" ;
-	"Load" ; "Undo"; "Goal";
-	"Proof" ; "Print";"Save" ; "Restart";
-	"End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]
-    in
-    let one_word_declarations =
-      [ (* Definitions *)
-	"Definition" ; "Let" ; "Example" ; "SubClass" ;
-        "Fixpoint" ; "CoFixpoint" ; "Scheme" ; "Function" ;
-        (* Assumptions *)
-	"Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ;
-	"Hypotheses" ; "Variables" ; "Axioms" ; "Parameters";
-        (* Inductive *)
-        "Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
-        (* Other *)
-	"Ltac" ; "Instance"; "Include"; "Context"; "Class" ;
-	 "Arguments" ]
-    in
-    let proof_declarations =
-      [ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ;
-        "Proposition" ; "Property" ]
-    in
-    let proof_ends =
-      [ "Qed" ; "Defined" ; "Admitted"; "Abort" ]
-    in
-    let constr_keywords =
-      [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for";
-	"end"; "as"; "let"; "in"; "if"; "then"; "else"; "return";
-	"Prop"; "Set"; "Type" ]
-    in
-    let h = Hashtbl.create 97 in (* for vernac *)
-    let h' = Hashtbl.create 97 in (* for constr *)
-    List.iter (fun s -> Hashtbl.add h s Keyword) one_word_commands;
-    List.iter (fun s -> Hashtbl.add h s Declaration) one_word_declarations;
-    List.iter (fun s -> Hashtbl.add h s ProofDeclaration) proof_declarations;
-    List.iter (fun s -> Hashtbl.add h s Qed) proof_ends;
-    List.iter (fun s -> Hashtbl.add h' s Keyword) constr_keywords;
-    (fun initial id -> Hashtbl.find (if initial then h else h') id)
-
   exception Unterminated
 
-  let here f lexbuf = f (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
+  let utf8_adjust = ref 0
 
+  let utf8_lexeme_start lexbuf =
+    Lexing.lexeme_start lexbuf - !utf8_adjust
 }
 
-let space =
-  [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *)
+let space = [' ' '\n' '\r' '\t' '\012'] (* '\012' is form-feed *)
 
-let firstchar =
-  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255']
-let identchar =
-  ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
-let ident = firstchar identchar*
-
-let undotted_sep = [ '{' '}' '-' '+' '*' ]
+let undotted_sep = '{' | '}' | '-'+ | '+'+ | '*'+
 
 let dot_sep = '.' (space | eof)
 
-let multiword_declaration =
-  "Module" (space+ "Type")?
-| "Program" space+ ident
-| "Existing" space+ "Instance" "s"?
-| "Canonical" space+ "Structure"
-
-let locality = (space+ "Local")?
-
-let multiword_command =
-  ("Uns" | "S")" et" (space+ ident)*
-| (("Open" | "Close") locality | "Bind" | " Delimit" )
-    space+ "Scope"
-| (("Reserved" space+)? "Notation" | "Infix") locality space+
-| "Next" space+ "Obligation"
-| "Solve" space+ "Obligations"
-| "Require" space+ ("Import"|"Export")?
-| "Hint" locality space+ ident
-| "Reset" (space+ "Initial")?
-| "Tactic" space+ "Notation"
-| "Implicit" space+ "Type" "s"?
-| "Combined" space+ "Scheme"
-| "Extraction" space+ (("Language" space+ ("Ocaml"|"Haskell"|"Scheme"|"Toplevel"))|
-    ("Library"|"Inline"|"NoInline"|"Blacklist"))
-| "Recursive" space+ "Extraction" (space+ "Library")?
-| ("Print"|"Reset") space+ "Extraction" space+ ("Inline"|"Blacklist")
-| "Extract" space+ (("Inlined" space+) "Constant"| "Inductive")
-| "Typeclasses" space+ ("eauto" | "Transparent" | "Opaque")
-| ("Generalizable" space+) ("All" | "No")? "Variable" "s"?
-
-(* At least still missing: "Inline" + decl, variants of "Identity
-  Coercion", variants of Print, Add, ... *)
+let utf8_extra_byte = [ '\x80' - '\xBF' ]
 
 rule coq_string = parse
   | "\"\"" { coq_string lexbuf }
-  | "\"" { Lexing.lexeme_end lexbuf }
-  | eof { Lexing.lexeme_end lexbuf }
+  | "\"" { () }
+  | eof { () }
+  | utf8_extra_byte { incr utf8_adjust; coq_string lexbuf }
   | _ { coq_string lexbuf }
 
 and comment = parse
-  | "(*" { ignore (comment lexbuf); comment lexbuf }
-  | "\"" { ignore (coq_string lexbuf); comment lexbuf }
-  | "*)" { (true, Lexing.lexeme_start lexbuf + 2) }
-  | eof { (false, Lexing.lexeme_end lexbuf) }
+  | "(*" { let _  = comment lexbuf in comment lexbuf }
+  | "\"" { let () = coq_string lexbuf in comment lexbuf }
+  | "*)" { Some (utf8_lexeme_start lexbuf) }
+  | eof { None }
+  | utf8_extra_byte { incr utf8_adjust; comment lexbuf }
   | _ { comment lexbuf }
 
+(** NB : [mkiter] should be called on increasing offsets *)
+
 and sentence initial stamp = parse
   | "(*" {
-      let comm_start = Lexing.lexeme_start lexbuf in
-      let trully_terminated,comm_end = comment lexbuf in
-      stamp comm_start comm_end Comment;
-      if not trully_terminated then raise Unterminated;
-      (* A comment alone is a sentence.
-	 A comment in a sentence doesn't terminate the sentence.
-         Note: comm_end is the first position _after_ the comment,
-	 as required when tagging a zone, hence the -1 to locate the
-	 ")" terminating the comment.
-      *)
-      if initial then comm_end - 1 else sentence false stamp lexbuf
+      match comment lexbuf with
+        | None -> raise Unterminated
+        | Some comm_last ->
+          stamp comm_last Tags.Script.comment;
+          sentence initial stamp lexbuf
     }
   | "\"" {
-      let str_start = Lexing.lexeme_start lexbuf in
-      let str_end = coq_string lexbuf in
-      stamp str_start str_end String;
-      sentence false stamp lexbuf
-    }
-  | multiword_declaration {
-      if initial then here stamp lexbuf Declaration;
+      let () = coq_string lexbuf in
       sentence false stamp lexbuf
     }
-  | multiword_command {
-      if initial then here stamp lexbuf Keyword;
-      sentence false stamp lexbuf
-    }
-  | ident as id {
-      (try here stamp lexbuf (tag_of_ident initial id) with Not_found -> ());
-      sentence false stamp lexbuf }
   | ".." {
       (* We must have a particular rule for parsing "..", where no dot
 	 is a terminator, even if we have a blank afterwards
@@ -164,32 +60,38 @@ and sentence initial stamp = parse
 	 special case, where the third dot is a terminator. *)
       sentence false stamp lexbuf
     }
-  | dot_sep { Lexing.lexeme_start lexbuf } (* The usual "." terminator *)
+  | dot_sep {
+      (* The usual "." terminator *)
+      stamp (utf8_lexeme_start lexbuf) Tags.Script.sentence;
+      sentence true stamp lexbuf
+    }
   | undotted_sep {
       (* Separators like { or } and bullets * - + are only active
 	 at the start of a sentence *)
-      if initial then Lexing.lexeme_start lexbuf
-      else sentence false stamp lexbuf
+      if initial then stamp (utf8_lexeme_start lexbuf + String.length (Lexing.lexeme lexbuf) - 1) Tags.Script.sentence;
+      sentence initial stamp lexbuf
     }
   | space+ {
        (* Parsing spaces is the only situation preserving initiality *)
        sentence initial stamp lexbuf
     }
+  | utf8_extra_byte { incr utf8_adjust; sentence false stamp lexbuf }
+  | eof { if initial then () else raise Unterminated }
   | _ {
       (* Any other characters *)
       sentence false stamp lexbuf
     }
-  | eof { raise Unterminated }
 
 {
 
-  (** Parse a sentence in string [slice], tagging relevant parts with
-      function [stamp], and returning the position of the first
-      sentence delimitor (either "." or "{" or "}" or the end of a comment).
-      It will raise [Unterminated] when no end of sentence is found.
+  (** Parse sentences in string [slice], tagging last characters
+      of sentences with the [stamp] function.
+      It will raise [Unterminated] if [slice] ends with an unfinished
+      sentence.
   *)
 
-  let delimit_sentence stamp slice =
+  let delimit_sentences stamp slice =
+    utf8_adjust := 0;
     sentence true stamp (Lexing.from_string slice)
 
 }
diff --git a/ide/coq_style.xml b/ide/coq_style.xml
new file mode 100644
index 00000000..67631d34
--- /dev/null
+++ b/ide/coq_style.xml
@@ -0,0 +1,26 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<style-scheme id="coq_style" _name="Coq highlighting based on Ssr manual"
+	      parent-scheme="classic" version="1.0">
+<author>The Coq Dev Team</author>
+<_description>Coq/Ssreflect color scheme for the vernacular language</_description>
+
+<style name="coq:comment" foreground="#brown"/>
+<style name="coq:coqdoc" foreground="#brown" italic="true"/>
+<style name="coq:vernac-keyword" bold="true" foreground="#dark violet"/>
+<style name="coq:gallina-keyword" bold="true" foreground="#orange red"/>
+<style name="coq:identifier" foreground="#navy"/>
+<style name="coq:constr-keyword" foreground="#dark green"/>
+<style name="coq:constr-sort" foreground="#008080"/>
+
+<style name="coq-ssreflect:comment" foreground="#b22222"/>
+<style name="coq-ssreflect:coqdoc" foreground="#b22222" italic="true"/>
+<style name="coq-ssreflect:vernac-keyword" bold="true" foreground="#a021f0"/>
+<style name="coq-ssreflect:gallina-keyword" bold="true" foreground="#a021f0"/>
+<style name="coq-ssreflect:identifier" bold="true" foreground="#0000ff"/>
+<style name="coq-ssreflect:constr-keyword" foreground="#228b22"/>
+<style name="coq-ssreflect:constr-sort" foreground="#228b22"/>
+<style name="coq-ssreflect:tactic" foreground="#101092"/>
+<style name="coq-ssreflect:endtactic" foreground="#ff3f3f"/>
+<style name="coq-ssreflect:iterator" foreground="#be6ad4"/>
+<style name="coq-ssreflect:string" foreground="#8b2252"/>
+</style-scheme>
diff --git a/ide/coqide-gtk2rc b/ide/coqide-gtk2rc
deleted file mode 100644
index 9da99551..00000000
--- a/ide/coqide-gtk2rc
+++ /dev/null
@@ -1,39 +0,0 @@
-# Some default functions for CoqIde. You may copy the file in $XDG_CONFIG_HOME
-# ($HOME/.config/coq/) and edit as you want. See 
-# http://developer.gnome.org/doc/API/2.0/gtk/gtk-Resource-Files.html
-# for a complete set of options
-# To set the font of the text windows, edit the .coqiderc file through the menus.
-
-gtk-key-theme-name = "Emacs"
-
-#pixmap_path "/home/"
-
-binding "text" {
-  bind "<ctrl>k" { "set-anchor" ()
-		   "move-cursor" (display-line-ends,1,0)
-		   "move-cursor" (visual-positions,1,0)
-		   "cut-clipboard" ()	
-		}
-  bind "<ctrl>w" { "cut-clipboard" () }
-
-# For UTF-8 inputs !
-#  bind "F11" {"insert-at-cursor" ("∀")}
-#  bind "F12" {"insert-at-cursor" ("∃")}
-}
-class "GtkTextView" binding "text"
-
-
-gtk-font-name = "Sans 12"
-
-style "location" {
-font_name = "Sans 10"
-}
-widget "*location*" style "location"
-
-
-gtk-can-change-accels = 1
-
-style "men" {
-# 
-}
-widget "GtkMenu" style "men"
diff --git a/ide/coqide.ml b/ide/coqide.ml
index c7e14007..fa64defa 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.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        *)
@@ -9,1418 +9,483 @@
 open Preferences
 open Gtk_parsing
 open Ideutils
+open Session
 
-type ide_info = {
-  start : GText.mark;
-  stop : GText.mark;
-}
-
-(** Have we used admit or declarative mode's daimon ?
-    If yes, we color differently *)
-
-type safety = Safe | Unsafe
-
-let safety_tag = function
-  | Safe -> Tags.Script.processed
-  | Unsafe -> Tags.Script.unjustified
-
-class type analyzed_views=
-object
-  val mutable act_id : GtkSignal.id option
-  val input_buffer : GText.buffer
-  val input_view : Undo.undoable_view
-  val last_array : string array
-  val mutable last_index : bool
-  val message_buffer : GText.buffer
-  val message_view : GText.view
-  val proof_buffer : GText.buffer
-  val proof_view : GText.view
-  val cmd_stack : ide_info Stack.t
-  val mycoqtop : Coq.coqtop ref
-  val mutable is_active : bool
-  val mutable read_only : bool
-  val mutable filename : string option
-  val mutable stats : Unix.stats option
-  method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b
-  method set_auto_complete : bool -> unit
-
-  method filename : string option
-  method stats :  Unix.stats option
-  method update_stats : unit
-  method revert : unit
-  method auto_save : unit
-  method save : string -> bool
-  method save_as : string -> bool
-  method read_only : bool
-  method set_read_only : bool -> unit
-  method is_active : bool
-  method activate : unit -> unit
-  method active_keypress_handler : GdkEvent.Key.t -> bool
-  method backtrack_to : GText.iter -> unit
-  method backtrack_to_no_lock : GText.iter -> unit
-  method clear_message : unit
-  method find_phrase_starting_at :
-    GText.iter -> (GText.iter * GText.iter) option
-  method get_insert : GText.iter
-  method get_start_of_input : GText.iter
-  method go_to_insert : unit
-  method indent_current_line : unit
-  method go_to_next_occ_of_cur_word : unit
-  method go_to_prev_occ_of_cur_word : unit
-  method insert_command : string -> string -> unit
-  method tactic_wizard : string list -> unit
-  method insert_message : string -> unit
-  method process_next_phrase : bool -> unit
-  method process_until_iter_or_error : GText.iter -> unit
-  method process_until_end_or_error : unit
-  method recenter_insert : unit
-  method reset_initial : unit
-  method force_reset_initial : unit
-  method set_message : string -> unit
-  method raw_coq_query : string -> unit
-  method show_goals : unit
-  method show_goals_full : unit
-  method undo_last_step : unit
-  method help_for_keyword : unit -> unit
-  method complete_at_offset : int -> bool
-end
+(** Note concerning GtkTextBuffer
 
+    Be careful with gtk calls on text buffers, since many are non-atomic :
+    they emit a gtk signal and the handlers for this signal are run
+    immediately, before returning to the current function.
+    Here's a partial list of these signals and the methods that
+    trigger them (cf. documentation of GtkTextBuffer, signal section)
 
-type viewable_script =
-    {script : Undo.undoable_view;
-     tab_label : GMisc.label;
-     mutable filename : string;
-     mutable encoding : string;
-     proof_view : GText.view;
-     message_view : GText.view;
-     analyzed_view : analyzed_views;
-     toplvl : Coq.coqtop ref;
-     command : Command_windows.command_window;
-    }
-
-let kill_session s =
-  (* To close the detached views of this script, we call manually
-     [destroy] on it, triggering some callbacks in [detach_view].
-     In a more modern lablgtk, rather use the page-removed signal ? *)
-  s.script#destroy ();
-  Coq.kill_coqtop !(s.toplvl)
-
-let build_session s =
-  let session_paned = GPack.paned `VERTICAL () in
-  let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
-    ~packing:(session_paned#pack1 ~shrink:false ~resize:true) () in
-  let script_frame = GBin.frame ~shadow_type:`IN
-    ~packing:eval_paned#add1 () in
-  let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
-    ~packing:script_frame#add () in
-  let state_paned = GPack.paned `VERTICAL
-    ~packing:eval_paned#add2 () in
-  let proof_frame = GBin.frame ~shadow_type:`IN
-    ~packing:state_paned#add1 () in
-  let proof_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
-    ~packing:proof_frame#add () in
-  let message_frame = GBin.frame ~shadow_type:`IN
-    ~packing:state_paned#add2 () in
-  let message_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC
-    ~packing:message_frame#add () in
-  let session_tab = GPack.hbox ~homogeneous:false () in
-  let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
-    ~packing:session_tab#pack () in
-  let _ =
-    s.script#buffer#connect#modified_changed
-      ~callback:(fun () -> if s.script#buffer#modified
-        then img#set_stock `SAVE
-        else img#set_stock `YES) in
-  let _ =
-    eval_paned#misc#connect#size_allocate
-      ~callback:
-      (let old_paned_width = ref 2 in
-       let old_paned_height = ref 2 in
-       (fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
-	 if !old_paned_width <> paned_width || !old_paned_height <> paned_height then (
-	   eval_paned#set_position (eval_paned#position * paned_width / !old_paned_width);
-	   state_paned#set_position (state_paned#position * paned_height / !old_paned_height);
-	   old_paned_width := paned_width;
-	   old_paned_height := paned_height;
-	 )))
-  in
-  session_paned#pack2 ~shrink:false ~resize:false (s.command#frame#coerce);
-  script_scroll#add s.script#coerce;
-  proof_scroll#add s.proof_view#coerce;
-  message_scroll#add s.message_view#coerce;
-  session_tab#pack s.tab_label#coerce;
-  img#set_stock `YES;
-  eval_paned#set_position 1;
-  state_paned#set_position 1;
-  (Some session_tab#coerce,None,session_paned#coerce)
-
-let session_notebook =
-  Typed_notebook.create build_session kill_session
-    ~border_width:2 ~show_border:false ~scrollable:true ()
+      begin_user_action : #begin_user_action, #insert_interactive,
+        #insert_range_interactive, #delete_interactive, #delete_selection
+      end_user_action : #end_user_action, #insert_interactive,
+        #insert_range_interactive, #delete_interactive, #delete_selection
 
-let cb = GData.clipboard Gdk.Atom.primary
+      insert_text : #insert (and variants)
+      delete_range : #delete (and variants)
 
-let last_cb_content = ref ""
+      apply_tag : #apply_tag, (and some #insert)
+      remove_tag : #remove_tag
 
-let update_notebook_pos () =
-  let pos =
-    match !current.vertical_tabs, !current.opposite_tabs with
-      | false, false -> `TOP
-      | false, true  -> `BOTTOM
-      | true , false -> `LEFT
-      | true , true  -> `RIGHT
-  in
-  session_notebook#set_tab_pos pos
+      mark_deleted : #delete_mark
+      mark_set : #create_mark, #move_mark
 
-let to_do_on_page_switch = ref []
+      changed : ... (whenever a buffer has changed)
+      modified_changed : #set_modified (and whenever the modified bit flips)
 
+   Caveat : when the buffer is modified, all iterators on it become
+   invalid and shouldn't be used (nasty errors otherwise). There are
+   some special cases : boundaries given to #insert and #delete are
+   revalidated by the default signal handler.
+*)
 
-(** * Coqide's handling of signals *)
+(** {2 Some static elements } *)
 
-(** We ignore Ctrl-C, and for most of the other catchable signals
-    we launch an emergency save of opened files and then exit *)
+let prefs = Preferences.current
 
-let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
-			Sys.sigill; Sys.sigpipe; Sys.sigquit;
-			(* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2]
+(** The arguments that will be passed to coqtop. No quoting here, since
+    no /bin/sh when using create_process instead of open_process. *)
+let custom_project_files = ref []
+let sup_args = ref []
 
-let crash_save i =
-  (*  ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*)
-  Minilib.safe_prerr_endline "Trying to save all buffers in .crashcoqide files";
-  let count = ref 0 in
-  List.iter
-    (function {script=view; analyzed_view = av } ->
-      (let filename = match av#filename with
-	| None ->
-	  incr count;
-	  "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide"
-	| Some f -> f^".crashcoqide"
-       in
-       try
-	 if try_export filename (view#buffer#get_text ()) then
-	   Minilib.safe_prerr_endline ("Saved "^filename)
-	 else Minilib.safe_prerr_endline ("Could not save "^filename)
-       with _ -> Minilib.safe_prerr_endline ("Could not save "^filename))
-    )
-    session_notebook#pages;
-  Minilib.safe_prerr_endline "Done. Please report.";
-  if i <> 127 then exit i
-
-let ignore_break () =
-  List.iter
-    (fun i ->
-      try Sys.set_signal i (Sys.Signal_handle crash_save)
-      with _ -> prerr_endline "Signal ignored (normal if Win32)")
-    signals_to_crash;
-  (* We ignore the Ctrl-C, this is required for the Stop button to work,
-     since we will actually send Ctrl-C to all processes sharing
-     our console (including us) *)
-  Sys.set_signal Sys.sigint Sys.Signal_ignore
-
-
-(** * Locks *)
-
-(* Locking machinery for Coq kernel *)
-let coq_computing = Mutex.create ()
-
-(* To prevent Coq from interrupting during undoing...*)
-let coq_may_stop = Mutex.create ()
-
-(* To prevent a force_reset_initial during a force_reset_initial *)
-let resetting = Mutex.create ()
-
-exception RestartCoqtop
-exception Unsuccessful
-
-let force_reset_initial () =
-  prerr_endline "Reset Initial";
-  session_notebook#current_term.analyzed_view#force_reset_initial
-
-let break () =
-  prerr_endline "User break received";
-  Coq.break_coqtop !(session_notebook#current_term.toplvl)
-
-let do_if_not_computing text f x =
-  let threaded_task () =
-    if Mutex.try_lock coq_computing then
-      begin
-	prerr_endline "Getting lock";
-	List.iter
-          (fun elt -> try f elt with
-            | RestartCoqtop -> elt.analyzed_view#reset_initial
-            | Sys_error str ->
-              elt.analyzed_view#reset_initial;
-              elt.analyzed_view#set_message
-                ("Unable to communicate with coqtop, restarting coqtop.\n"^
-		    "Error was: "^str)
-            | e ->
-              Mutex.unlock coq_computing;
-              elt.analyzed_view#set_message
-                ("Unknown error, please report:\n"^(Printexc.to_string e)))
-          x;
-	prerr_endline "Releasing lock";
-	Mutex.unlock coq_computing;
-      end
-    else
-      prerr_endline "Discarded order (computations are ongoing)"
-  in
-  prerr_endline ("Launching thread " ^ text);
-  ignore (Glib.Timeout.add ~ms:300 ~callback:
-            (fun () -> if Mutex.try_lock coq_computing
-              then (Mutex.unlock coq_computing; false)
-              else (pbar#pulse (); true)));
-  ignore (Thread.create threaded_task ())
-
-let warning msg =
-  GToolbox.message_box ~title:"Warning"
-    ~icon:(let img = GMisc.image () in
-	   img#set_stock `DIALOG_WARNING;
-	   img#set_icon_size `DIALOG;
-	   img#coerce)
-    msg
-
-let remove_current_view_page () =
-  let do_remove () =
-    let c = session_notebook#current_page in
-    session_notebook#remove_page c
-  in
-  let current = session_notebook#current_term in
-  if not current.script#buffer#modified then do_remove ()
-  else
-    match GToolbox.question_box ~title:"Close"
-      ~buttons:["Save Buffer and Close";
-                "Close without Saving";
-                "Don't Close"]
-      ~default:0
-      ~icon:(let img = GMisc.image () in
-             img#set_stock `DIALOG_WARNING;
-             img#set_icon_size `DIALOG;
-             img#coerce)
-      "This buffer has unsaved modifications"
-    with
-      | 1 ->
-        begin match current.analyzed_view#filename with
-          | None ->
-            begin match select_file_for_save ~title:"Save file" () with
-              | None -> ()
-              | Some f ->
-                if current.analyzed_view#save_as f then begin
-                  flash_info ("File " ^ f ^ " saved") ;
-                  do_remove ()
-                end else
-                  warning  ("Save Failed (check if " ^ f ^ " is writable)")
-            end
-          | Some f ->
-            if current.analyzed_view#save f then begin
-              flash_info ("File " ^ f ^ " saved") ;
-              do_remove ()
-            end else
-              warning  ("Save Failed (check if " ^ f ^ " is writable)")
-        end
-      | 2 -> do_remove ()
-      | _ -> ()
+let logfile = ref None
 
-module Opt = Coq.PrintOpt
+(** {2 Notebook of sessions } *)
 
-let print_items = [
-  ([Opt.implicit],"Display implicit arguments","Display _implicit arguments",
-   "i",false);
-  ([Opt.coercions],"Display coercions","Display _coercions","c",false);
-  ([Opt.raw_matching],"Display raw matching expressions",
-   "Display raw _matching expressions","m",true);
-  ([Opt.notations],"Display notations","Display _notations","n",true);
-  ([Opt.all_basic],"Display all basic low-level contents",
-   "Display _all basic low-level contents","a",false);
-  ([Opt.existential],"Display existential variable instances",
-   "Display _existential variable instances","e",false);
-  ([Opt.universes],"Display universe levels","Display _universe levels",
-   "u",false);
-  ([Opt.all_basic;Opt.existential;Opt.universes], "Display all low-level contents",
-   "Display all _low-level contents","l",false)
-]
+(** The main element of coqide is a notebook of session views *)
 
-let setopts ct opts v =
-  let opts = List.map (fun o -> (o, v)) opts in
-  Coq.PrintOpt.set ct opts
-
-(* Reset this to None on page change ! *)
-let (last_completion:(string*int*int*bool) option ref) = ref None
-
-let () = to_do_on_page_switch :=
-  (fun i -> last_completion := None)::!to_do_on_page_switch
-
-let rec complete input_buffer w (offset:int) =
-  match !last_completion with
-    | Some (lw,loffset,lpos,backward)
-	when lw=w && loffset=offset ->
-      begin
-	let iter = input_buffer#get_iter (`OFFSET lpos) in
-	if backward then
-	  match complete_backward w iter with
-	    | None ->
-	      last_completion :=
-		Some (lw,loffset,
-		      (find_word_end
-			 (input_buffer#get_iter (`OFFSET loffset)))#offset ,
-		      false);
-	      None
-	    | Some (ss,start,stop) as result ->
-	      last_completion :=
-		Some (w,offset,ss#offset,true);
-	      result
-	else
-	  match complete_forward w iter with
-	    | None ->
-	      last_completion := None;
-	      None
-	    | Some (ss,start,stop) as result ->
-	      last_completion :=
-		Some (w,offset,ss#offset,false);
-	      result
-      end
-    | _ -> begin
-      match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with
-	| None ->
-	  last_completion :=
-	    Some (w,offset,(find_word_end (input_buffer#get_iter
-					     (`OFFSET offset)))#offset,false);
-	  complete input_buffer w offset
-	| Some (ss,start,stop) as result ->
-	  last_completion := Some (w,offset,ss#offset,true);
-	  result
-    end
+let notebook =
+  Wg_Notebook.create Session.build_layout Session.kill
+    ~border_width:2 ~show_border:false ~scrollable:true ()
 
-let get_current_word () =
-  match session_notebook#current_term,cb#text with
-    | {script=script; analyzed_view=av;},None ->
-      prerr_endline "None selected";
-      let it = av#get_insert in
-      let start = find_word_start it in
-      let stop = find_word_end start in
-      script#buffer#move_mark `SEL_BOUND ~where:start;
-      script#buffer#move_mark `INSERT ~where:stop;
-      script#buffer#get_text ~slice:true ~start ~stop ()
-    | _,Some t ->
-      prerr_endline "Some selected";
-      prerr_endline t;
-      t
-
-
-let input_channel b ic =
-  let buf = String.create 1024 and len = ref 0 in
-  while len := input ic buf 0 1024; !len > 0 do
-    Buffer.add_substring b buf 0 !len
-  done
-
-let with_file handler name ~f =
-  try
-    let ic = open_in_gen [Open_rdonly;Open_creat] 0o644 name in
-    try f ic; close_in ic with e -> close_in ic; raise e
-  with Sys_error s -> handler s
-
-(* For find_phrase_starting_at *)
-exception Stop of int
-
-let tag_of_sort = function
-  | Coq_lex.Comment -> Tags.Script.comment
-  | Coq_lex.Keyword -> Tags.Script.kwd
-  | Coq_lex.Declaration -> Tags.Script.decl
-  | Coq_lex.ProofDeclaration -> Tags.Script.proof_decl
-  | Coq_lex.Qed -> Tags.Script.qed
-  | Coq_lex.String -> failwith "No tag"
-
-let apply_tag (buffer:GText.buffer) orig off_conv from upto sort =
-  try
-    let tag = tag_of_sort sort in
-    let start = orig#forward_chars (off_conv from) in
-    let stop = orig#forward_chars (off_conv upto) in
-    buffer#apply_tag ~start ~stop tag
-  with _ -> ()
-
-let remove_tags (buffer:GText.buffer) from upto =
-  List.iter (buffer#remove_tag ~start:from ~stop:upto)
-    [ Tags.Script.comment; Tags.Script.kwd; Tags.Script.decl;
-      Tags.Script.proof_decl; Tags.Script.qed ]
-
-(** Cut a part of the buffer in sentences and tag them.
-    Invariant: either this slice ends the buffer, or it ends with ".".
-    May raise [Coq_lex.Unterminated] when the zone ends with
-    an unterminated sentence. *)
-
-let split_slice_lax (buffer:GText.buffer) from upto =
-  remove_tags buffer from upto;
-  buffer#remove_tag ~start:from ~stop:upto Tags.Script.sentence;
-  let slice = buffer#get_text ~start:from ~stop:upto () in
-  let rec split_substring str =
-    let off_conv = byte_offset_to_char_offset str in
-    let slice_len = String.length str in
-    let end_off = Coq_lex.delimit_sentence (apply_tag buffer from off_conv) str
-    in
-    let start = from#forward_chars (off_conv end_off) in
-    let stop = start#forward_char in
-    buffer#apply_tag ~start ~stop Tags.Script.sentence;
-    let next = end_off + 1 in
-    if next < slice_len then begin
-      ignore (from#nocopy#forward_chars (off_conv next));
-      split_substring (String.sub str next (slice_len - next))
-    end
-  in
-  split_substring slice
 
-(** Searching forward and backward a position fulfilling some condition *)
+(** {2 Callback functions for the user interface } *)
 
-let rec forward_search cond (iter:GText.iter) =
-  if iter#is_end || cond iter then iter
-  else forward_search cond iter#forward_char
+let on_current_term f =
+  let term = try Some notebook#current_term with Invalid_argument _ -> None in
+  match term with
+  | None -> ()
+  | Some t -> ignore (f t)
 
-let rec backward_search cond (iter:GText.iter) =
-  if iter#is_start || cond iter then iter
-  else backward_search cond iter#backward_char
+let cb_on_current_term f _ = on_current_term f
 
-let is_sentence_end s = s#has_tag Tags.Script.sentence
-let is_char s c = s#char = Char.code c
+(** Nota: using && here has the advantage of working both under win32 and unix.
+    If someday we want the main command to be tried even if the "cd" has failed,
+    then we should use " ; " under unix but " & " under win32 (cf. #2363). *)
 
-(** Search backward the first character of a sentence, starting at [iter]
-    and going at most up to [soi] (meant to be the end of the locked zone).
-    Raise [StartError] when no proper sentence start has been found.
-    A character following a ending "." is considered as a sentence start
-    only if this character is a blank. In particular, when a final "."
-    at the end of the locked zone isn't followed by a blank, then this
-    non-blank character will be signaled as erroneous in [tag_on_insert] below.
-*)
+let local_cd file =
+  "cd " ^ Filename.quote (Filename.dirname file) ^ " && "
 
-exception StartError
+let pr_exit_status = function
+  | Unix.WEXITED 0 -> " succeeded"
+  | _ -> " failed"
 
-let grab_sentence_start (iter:GText.iter) soi =
-  let cond iter =
-    if iter#compare soi < 0 then raise StartError;
-    let prev = iter#backward_char in
-    is_sentence_end prev &&
-      (not (is_char prev '.') ||
-       List.exists (is_char iter) [' ';'\n';'\r';'\t'])
-  in
-  backward_search cond iter
+let make_coqtop_args = function
+  |None -> !sup_args
+  |Some the_file ->
+    let get_args f = Project_file.args_from_project f
+      !custom_project_files prefs.project_file_name
+    in
+    match prefs.read_project with
+      |Ignore_args -> !sup_args
+      |Append_args -> get_args the_file @ !sup_args
+      |Subst_args -> get_args the_file
+
+(** Setting drag & drop on widgets *)
+
+let load_file_cb : (string -> unit) ref = ref ignore
+
+let drop_received context ~x ~y data ~info ~time =
+  if data#format = 8 then begin
+    let files = Str.split (Str.regexp "\r?\n") data#data in
+    let path = Str.regexp "^file://\\(.*\\)$" in
+    List.iter (fun f ->
+      if Str.string_match path f 0 then
+        !load_file_cb (Str.matched_group 1 f)
+    ) files;
+    context#finish ~success:true ~del:false ~time
+  end else context#finish ~success:false ~del:false ~time
+
+let drop_targets = [
+  { Gtk.target = "text/uri-list"; Gtk.flags = []; Gtk.info = 0}
+]
 
-(** Search forward the first character immediately after a sentence end *)
+let set_drag (w : GObj.drag_ops) =
+  w#dest_set drop_targets ~actions:[`COPY;`MOVE];
+  w#connect#data_received ~callback:drop_received
 
-let rec grab_sentence_stop (start:GText.iter) =
-  (forward_search is_sentence_end start)#forward_char
+(** Session management *)
 
-(** Search forward the first character immediately after a "." sentence end
-    (and not just a "{" or "}" or comment end *)
+let create_session f =
+  let ans = Session.create f (make_coqtop_args f) in
+  let _ = set_drag ans.script#drag in
+  ans
 
-let rec grab_ending_dot (start:GText.iter) =
-  let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
-  (forward_search is_ending_dot start)#forward_char
+(** Auxiliary functions for the File operations *)
 
-(** Retag a zone that has been edited *)
+module FileAux = struct
 
-let tag_on_insert buffer =
-  (* the start of the non-locked zone *)
-  let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
-  (* the inserted zone is between [prev_insert] and [insert] *)
-  let insert = buffer#get_iter_at_mark `INSERT in
-  let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in
-  (* [prev] is normally always before [insert] even when deleting.
-     Let's check this nonetheless *)
-  let prev, insert =
-    if insert#compare prev < 0 then insert, prev else prev, insert
-  in
+let load_file ?(maycreate=false) f =
+  let f = CUnix.correct_path f (Sys.getcwd ()) in
   try
-    let start = grab_sentence_start prev soi in
-    (** The status of "{" "}" as sentence delimiters is too fragile.
-	We retag up to the next "." instead. *)
-    let stop = grab_ending_dot insert in
-    try split_slice_lax buffer start stop
-    with Coq_lex.Unterminated ->
-      (* This shouldn't happen frequently. Either:
-         - we are at eof, with indeed an unfinished sentence.
-         - we have just inserted an opening of comment or string.
-         - the inserted text ends with a "." that interacts with the "."
-         found by [grab_ending_dot] to form a non-ending "..".
-         In any case, we retag up to eof, since this isn't that costly. *)
-      if not stop#is_end then
-        try split_slice_lax buffer start buffer#end_iter
-        with Coq_lex.Unterminated -> ()
-  with StartError ->
-    buffer#apply_tag Tags.Script.error ~start:soi ~stop:soi#forward_char
-
-let force_retag buffer =
-  try split_slice_lax buffer buffer#start_iter buffer#end_iter
-  with Coq_lex.Unterminated -> ()
-
-let toggle_proof_visibility (buffer:GText.buffer) (cursor:GText.iter) =
-  (* move back twice if not into proof_decl,
-   * once if into proof_decl and back_char into_proof_decl,
-   * don't move if into proof_decl and back_char not into proof_decl *)
-  if not (cursor#has_tag Tags.Script.proof_decl) then
-    ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
-  if cursor#backward_char#has_tag Tags.Script.proof_decl then
-    ignore (cursor#nocopy#backward_to_tag_toggle (Some Tags.Script.proof_decl));
-  let decl_start = cursor in
-  let prf_end = decl_start#forward_to_tag_toggle (Some Tags.Script.qed) in
-  let decl_end = grab_ending_dot decl_start in
-  let prf_end = grab_ending_dot prf_end in
-  let prf_end = prf_end#forward_char in
-  if decl_start#has_tag Tags.Script.folded then (
-    buffer#remove_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
-    buffer#remove_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
-  else (
-    buffer#apply_tag ~start:decl_start ~stop:decl_end Tags.Script.folded;
-    buffer#apply_tag ~start:decl_end ~stop:prf_end Tags.Script.hidden)
+    Minilib.log "Loading file starts";
+    let is_f = CUnix.same_file f in
+    let rec search_f i = function
+      | [] -> false
+      | sn :: sessions ->
+        match sn.fileops#filename with
+	  | Some fn when is_f fn -> notebook#goto_page i; true
+          | _ -> search_f (i+1) sessions
+    in
+    if not (search_f 0 notebook#pages) then begin
+      Minilib.log "Loading: get raw content";
+      let b = Buffer.create 1024 in
+      if Sys.file_exists f then Ideutils.read_file f b
+      else if not maycreate then flash_info ("Load failed: no such file");
+      Minilib.log "Loading: convert content";
+      let s = do_convert (Buffer.contents b) in
+      Minilib.log "Loading: create view";
+      let session = create_session (Some f) in
+      let index = notebook#append_term session in
+      notebook#goto_page index;
+      Minilib.log "Loading: stats";
+      session.fileops#update_stats;
+      let input_buffer = session.buffer in
+      Minilib.log "Loading: fill buffer";
+      input_buffer#set_text s;
+      input_buffer#set_modified false;
+      input_buffer#place_cursor ~where:input_buffer#start_iter;
+      Sentence.tag_all input_buffer;
+      session.script#clear_undo ();
+      !refresh_editor_hook ();
+      Minilib.log "Loading: success";
+    end
+  with e -> flash_info ("Load failed: "^(Printexc.to_string e))
+
+let confirm_save ok =
+  if ok then flash_info "Saved" else warning "Save Failed"
+
+let select_and_save ~saveas ?filename sn =
+  let do_save = if saveas then sn.fileops#saveas else sn.fileops#save in
+  let title = if saveas then "Save file as" else "Save file" in
+  match select_file_for_save ~title ?filename () with
+    |None -> false
+    |Some f ->
+      let ok = do_save f in
+      confirm_save ok;
+      if ok then sn.tab_label#set_text (Filename.basename f);
+      ok
+
+let check_save ~saveas sn =
+  try match sn.fileops#filename with
+    |None -> select_and_save ~saveas sn
+    |Some f ->
+      let ok = sn.fileops#save f in
+      confirm_save ok;
+      ok
+  with _ -> warning "Save Failed"; false
+
+exception DontQuit
+
+let check_quit saveall =
+  (try save_pref () with _ -> flash_info "Cannot save preferences");
+  let is_modified sn = sn.buffer#modified in
+  if List.exists is_modified notebook#pages then begin
+    let answ = GToolbox.question_box ~title:"Quit"
+      ~buttons:["Save Named Buffers and Quit";
+                "Quit without Saving";
+                "Don't Quit"]
+      ~default:0
+      ~icon:(warn_image ())#coerce
+      "There are unsaved buffers"
+    in
+    match answ with
+      | 1 -> saveall ()
+      | 2 -> ()
+      | _ -> raise DontQuit
+  end;
+  List.iter (fun sn -> Coq.close_coqtop sn.coqtop) notebook#pages
+
+(* For MacOS, just to be sure, we close all coqtops (again?) *)
+let close_and_quit () =
+  List.iter (fun sn -> Coq.close_coqtop sn.coqtop) notebook#pages;
+  exit 0
+
+let crash_save exitcode =
+  Minilib.log "Starting emergency save of buffers in .crashcoqide files";
+  let idx =
+    let r = ref 0 in
+    fun () -> incr r; string_of_int !r
+  in
+  let save_session sn =
+    let filename = match sn.fileops#filename with
+      | None -> "Unnamed_coqscript_" ^ idx () ^ ".crashcoqide"
+      | Some f -> f^".crashcoqide"
+    in
+    try
+      if try_export filename (sn.buffer#get_text ()) then
+	Minilib.log ("Saved "^filename)
+      else Minilib.log ("Could not save "^filename)
+    with _ -> Minilib.log ("Could not save "^filename)
+  in
+  List.iter save_session notebook#pages;
+  Minilib.log "End emergency save";
+  exit exitcode
 
-(** The arguments that will be passed to coqtop. No quoting here, since
-    no /bin/sh when using create_process instead of open_process. *)
-let custom_project_files = ref []
-let sup_args = ref []
+end
 
-class analyzed_view (_script:Undo.undoable_view) (_pv:GText.view) (_mv:GText.view) _cs _ct _fn =
-object(self)
-  val input_view = _script
-  val input_buffer = _script#buffer
-  val proof_view = _pv
-  val proof_buffer = _pv#buffer
-  val message_view = _mv
-  val message_buffer = _mv#buffer
-  val cmd_stack = _cs
-  val mycoqtop = _ct
-  val mutable is_active = false
-  val mutable read_only = false
-  val mutable filename = _fn
-  val mutable stats = None
-  val mutable last_modification_time = 0.
-  val mutable last_auto_save_time = 0.
-  val mutable find_forward_instead_of_backward = false
-
-  val mutable auto_complete_on = !current.auto_complete
-  val hidden_proofs = Hashtbl.create 32
-
-  method private toggle_auto_complete =
-    auto_complete_on <- not auto_complete_on
-  method set_auto_complete t = auto_complete_on <- t
-  method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x ->
-    let old = auto_complete_on in
-    self#set_auto_complete false;
-    let y = f x in
-    self#set_auto_complete old;
-    y
-
-  method filename = filename
-  method stats = stats
-  method update_stats =
-    match filename with
-      | Some f -> stats <- my_stat f
-      | _ -> ()
+let () = load_file_cb := (fun s -> FileAux.load_file s)
 
-  method revert =
-    match filename with
-      | Some f -> begin
-        let do_revert () = begin
-          push_info "Reverting buffer";
-          try
-            if is_active then self#force_reset_initial;
-            let b = Buffer.create 1024 in
-            with_file flash_info f ~f:(input_channel b);
-            let s = try_convert (Buffer.contents b) in
-            input_buffer#set_text s;
-            self#update_stats;
-            input_buffer#place_cursor ~where:input_buffer#start_iter;
-            input_buffer#set_modified false;
-            pop_info ();
-            flash_info "Buffer reverted";
-            force_retag input_buffer;
-          with _  ->
-            pop_info ();
-            flash_info "Warning: could not revert buffer";
-        end
-        in
-        if input_buffer#modified then
-          match (GToolbox.question_box
-                   ~title:"Modified buffer changed on disk"
-                   ~buttons:["Revert from File";
-                             "Overwrite File";
-                             "Disable Auto Revert"]
-                   ~default:0
-                   ~icon:(stock_to_widget `DIALOG_WARNING)
-                   "Some unsaved buffers changed on disk"
-          )
-          with 1 -> do_revert ()
-            | 2 -> if self#save f then flash_info "Overwritten" else
-                flash_info "Could not overwrite file"
-            | _ ->
-              prerr_endline "Auto revert set to false";
-              !current.global_auto_revert <- false;
-              disconnect_revert_timer ()
-        else do_revert ()
-      end
-      | None -> ()
+(** Callbacks for the File menu *)
 
-  method save f =
-    if try_export f (input_buffer#get_text ()) then begin
-      filename <- Some f;
-      input_buffer#set_modified false;
-      stats <- my_stat f;
-      (match self#auto_save_name with
-        | None -> ()
-        | Some fn -> try Sys.remove fn with _ -> ());
-      true
-    end
-    else false
-
-  method private auto_save_name =
-    match filename with
-      | None -> None
-      | Some f ->
-        let dir = Filename.dirname f in
-        let base = (fst !current.auto_save_name) ^
-          (Filename.basename f) ^
-          (snd !current.auto_save_name)
-        in Some (Filename.concat dir base)
-
-  method private need_auto_save =
-    input_buffer#modified &&
-      last_modification_time > last_auto_save_time
-
-  method auto_save =
-    if self#need_auto_save then begin
-      match self#auto_save_name with
-        | None -> ()
-        | Some fn ->
-          try
-            last_auto_save_time <- Unix.time();
-            prerr_endline ("Autosave time : "^(string_of_float (Unix.time())));
-            if try_export fn (input_buffer#get_text ()) then begin
-              flash_info ~delay:1000 "Autosaved"
-            end
-            else warning
-              ("Autosave failed (check if " ^ fn ^ " is writable)")
-          with _ ->
-            warning ("Autosave: unexpected error while writing "^fn)
-    end
+module File = struct
 
-  method save_as f =
-    if Sys.file_exists f then
-      match (GToolbox.question_box ~title:"File exists on disk"
-               ~buttons:["Overwrite";
-                         "Cancel";]
-               ~default:1
-               ~icon:
-               (let img = GMisc.image () in
-                img#set_stock `DIALOG_WARNING;
-                img#set_icon_size `DIALOG;
-                img#coerce)
-               ("File "^f^" already exists")
-      )
-      with 1 -> self#save f
-        | _ -> false
-    else self#save f
-
-  method set_read_only b = read_only<-b
-  method read_only = read_only
-  method is_active = is_active
-  method insert_message s =
-    message_buffer#insert s;
-    message_view#misc#draw None
-
-  method set_message s =
-    message_buffer#set_text s;
-    message_view#misc#draw None
-
-  method clear_message = message_buffer#set_text ""
-  val mutable last_index = true
-  val last_array = [|"";""|]
-  method get_start_of_input =  input_buffer#get_iter_at_mark (`NAME "start_of_input")
-
-  method get_insert = get_insert input_buffer
-
-  method recenter_insert =
-    (* BUG : to investigate further:
-       FIXED : Never call  GMain.* in thread !
-       PLUS : GTK BUG ??? Cannot be called from a thread...
-       ADDITION: using sync instead of async causes deadlock...*)
-    ignore (GtkThread.async (
-      input_view#scroll_to_mark
-        ~use_align:false
-        ~yalign:0.75
-        ~within_margin:0.25)
-              `INSERT)
-
-
-  method indent_current_line =
-    let get_nb_space it =
-      let it = it#copy in
-      let nb_sep = ref 0 in
-      let continue = ref true in
-      while !continue do
-        if it#char = space then begin
-          incr nb_sep;
-          if not it#nocopy#forward_char then continue := false;
-        end else continue := false
-      done;
-      !nb_sep
-    in
-    let previous_line = self#get_insert in
-    if previous_line#nocopy#backward_line then begin
-      let previous_line_spaces = get_nb_space previous_line in
-      let current_line_start = self#get_insert#set_line_offset 0 in
-      let current_line_spaces = get_nb_space current_line_start in
-      if input_buffer#delete_interactive
-        ~start:current_line_start
-        ~stop:(current_line_start#forward_chars current_line_spaces)
-        ()
-      then
-        let current_line_start = self#get_insert#set_line_offset 0 in
-        input_buffer#insert
-          ~iter:current_line_start
-          (String.make previous_line_spaces ' ')
-    end
+let newfile _ =
+  let session = create_session None in
+  let index = notebook#append_term session in
+  !refresh_editor_hook ();
+  notebook#goto_page index
 
+let load _ =
+  match select_file_for_open ~title:"Load file" () with
+    | None -> ()
+    | Some f -> FileAux.load_file f
 
-  method go_to_next_occ_of_cur_word =
-    let cv = session_notebook#current_term in
-    let av = cv.analyzed_view in
-    let b = (cv.script)#buffer in
-    let start = find_word_start (av#get_insert) in
-    let stop = find_word_end start in
-    let text = b#get_text ~start ~stop () in
-    match stop#forward_search text with
-      | None -> ()
-      | Some(start, _) ->
-        (b#place_cursor start;
-         self#recenter_insert)
-
-  method go_to_prev_occ_of_cur_word =
-    let cv = session_notebook#current_term in
-    let av = cv.analyzed_view in
-    let b = (cv.script)#buffer in
-    let start = find_word_start (av#get_insert) in
-    let stop = find_word_end start in
-    let text = b#get_text ~start ~stop () in
-    match start#backward_search text with
+let save _ = on_current_term (FileAux.check_save ~saveas:false)
+
+let saveas sn =
+  try
+    let filename = sn.fileops#filename in
+    ignore (FileAux.select_and_save ~saveas:true ?filename sn)
+  with _ -> warning "Save Failed"
+
+let saveas = cb_on_current_term saveas
+
+let saveall _ =
+  List.iter
+    (fun sn -> match sn.fileops#filename with
       | None -> ()
-      | Some(start, _) ->
-        (b#place_cursor start;
-         self#recenter_insert)
-
-  val mutable full_goal_done = true
-
-  method show_goals_full =
-    if not full_goal_done then
-      proof_view#buffer#set_text "";
-    begin
-      let menu_callback = if !current.contextual_menus_on_goal then
-          (fun s () -> ignore (self#insert_this_phrase_on_success
-				 true true false ("progress "^s) s))
-        else
-          (fun _ _ -> ()) in
-      try
-        begin match Coq.goals !mycoqtop with
-          | Interface.Fail (l, str) ->
-            self#set_message ("Error in coqtop :\n"^str)
-          | Interface.Good goals ->
-            begin match Coq.evars !mycoqtop with
-            | Interface.Fail (l, str) ->
-              self#set_message ("Error in coqtop :\n"^str)
-            | Interface.Good evs ->
-              let hints = match Coq.hints !mycoqtop with
-              | Interface.Fail (_, _) -> None
-              | Interface.Good hints -> hints
-              in
-              Ideproof.display
-                (Ideproof.mode_tactic menu_callback)
-                proof_view goals hints evs
-            end
-        end
-      with
-        | e -> prerr_endline (Printexc.to_string e)
-    end
+      | Some f -> ignore (sn.fileops#save f))
+    notebook#pages
 
-  method show_goals = self#show_goals_full
+let revert_all _ =
+  List.iter
+    (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert)
+    notebook#pages
 
-  method private send_to_coq ct verbose phrase show_output show_error localize =
-    let display_output msg =
-      self#insert_message (if show_output then msg else "") in
-    let display_error (loc,s) =
-      if show_error then begin
-        if not (Glib.Utf8.validate s) then
-          flash_info "This error is so nasty that I can't even display it."
-        else begin
-          self#insert_message s;
-          message_view#misc#draw None;
-          if localize then
-            (match loc with
-              | None -> ()
-              | Some (start,stop) ->
-                let convert_pos = byte_offset_to_char_offset phrase in
-                let start = convert_pos start in
-                let stop = convert_pos stop in
-                let i = self#get_start_of_input in
-                let starti = i#forward_chars start in
-                let stopi = i#forward_chars stop in
-                input_buffer#apply_tag Tags.Script.error
-                  ~start:starti
-                  ~stop:stopi;
-                input_buffer#place_cursor ~where:starti)
-        end
-      end in
-    try
-      full_goal_done <- false;
-      prerr_endline "Send_to_coq starting now";
-      (* It's important here to work with [ct] and not [!mycoqtop], otherwise
-         we could miss a restart of coqtop and continue sending it orders. *)
-      match Coq.interp ct ~verbose 0 phrase with
-        | Interface.Fail (l,str) -> sync display_error (l,str); None
-        | Interface.Good msg -> sync display_output msg; Some Safe
-    with
-      | End_of_file -> (* Coqtop has died, let's trigger a reset_initial. *)
-        raise RestartCoqtop
-      | e -> sync display_error (None, Printexc.to_string e); None
-
-  (* This method is intended to perform stateless commands *)
-  method raw_coq_query phrase =
-    let () = prerr_endline "raw_coq_query starting now" in
-    let display_error s =
-      if not (Glib.Utf8.validate s) then
-        flash_info "This error is so nasty that I can't even display it."
-      else begin
-        self#insert_message s;
-        message_view#misc#draw None
-      end
+let quit _ =
+  try FileAux.check_quit saveall; exit 0
+  with FileAux.DontQuit -> ()
+
+let close_buffer sn =
+  let do_remove () = notebook#remove_page notebook#current_page in
+  if not sn.buffer#modified then do_remove ()
+  else
+    let answ = GToolbox.question_box ~title:"Close"
+      ~buttons:["Save Buffer and Close";
+                "Close without Saving";
+                "Don't Close"]
+      ~default:0
+      ~icon:(warn_image ())#coerce
+      "This buffer has unsaved modifications"
     in
-    try
-      match Coq.interp !mycoqtop ~raw:true ~verbose:false 0 phrase with
-      | Interface.Fail (_, err) -> sync display_error err
-      | Interface.Good msg ->
-	sync self#insert_message msg
-    with
-    | End_of_file -> raise RestartCoqtop
-    | e -> sync display_error (Printexc.to_string e)
-
-  method find_phrase_starting_at (start:GText.iter) =
-    try
-      let start = grab_sentence_start start self#get_start_of_input in
-      let stop = grab_sentence_stop start in
-      (* Is this phrase non-empty and complete ? *)
-      if stop#compare start > 0 && is_sentence_end stop#backward_char
-      then Some (start,stop)
-      else None
-    with StartError -> None
-
-  method complete_at_offset (offset:int) =
-    prerr_endline ("Completion at offset : " ^ string_of_int offset);
-    let it () = input_buffer#get_iter (`OFFSET offset) in
-    let iit = it () in
-    let start = find_word_start iit in
-    if ends_word iit then
-      let w = input_buffer#get_text
-        ~start
-        ~stop:iit
-        ()
+    match answ with
+      | 1 when FileAux.check_save ~saveas:true sn -> do_remove ()
+      | 2 -> do_remove ()
+      | _ -> ()
+
+let close_buffer = cb_on_current_term close_buffer
+
+let export kind sn =
+  match sn.fileops#filename with
+    |None -> flash_info "Cannot print: this buffer has no name"
+    |Some f ->
+      let basef = Filename.basename f in
+      let output =
+        let basef_we = try Filename.chop_extension basef with _ -> basef in
+        match kind with
+          | "latex" -> basef_we ^ ".tex"
+          | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
+          | _ -> assert false
       in
-      if String.length w <> 0 then begin
-        prerr_endline ("Completion of prefix : '" ^ w^"'");
-        match complete input_buffer w start#offset with
-          | None -> false
-          | Some (ss,start,stop) ->
-            let completion = input_buffer#get_text ~start ~stop () in
-            ignore (input_buffer#delete_selection ());
-            ignore (input_buffer#insert_interactive completion);
-            input_buffer#move_mark `SEL_BOUND ~where:(it())#backward_char;
-            true
-      end else false
-    else false
-
-  method private process_one_phrase ct verbosely display_goals do_highlight =
-    let get_next_phrase () =
-      self#clear_message;
-      prerr_endline "process_one_phrase starting now";
-      if do_highlight then begin
-        push_info "Coq is computing";
-        input_view#set_editable false;
-      end;
-      match self#find_phrase_starting_at self#get_start_of_input with
-        | None ->
-          if do_highlight then begin
-            input_view#set_editable true;
-            pop_info ();
-          end;
-          None
-        | Some(start,stop) ->
-          prerr_endline "process_one_phrase : to_process highlight";
-          if do_highlight then begin
-            input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
-            prerr_endline "process_one_phrase : to_process applied";
-          end;
-          prerr_endline "process_one_phrase : getting phrase";
-          Some((start,stop),start#get_slice ~stop) in
-    let remove_tag (start,stop) =
-      if do_highlight then begin
-        input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
-        input_view#set_editable true;
-        pop_info ();
-      end in
-    let mark_processed safe (start,stop) =
-      let b = input_buffer in
-      b#move_mark ~where:stop (`NAME "start_of_input");
-      b#apply_tag (safety_tag safe) ~start ~stop;
-      if (self#get_insert#compare) stop <= 0 then
-        begin
-          b#place_cursor ~where:stop;
-          self#recenter_insert
-        end;
-      let ide_payload = { start = `MARK (b#create_mark start);
-                          stop = `MARK (b#create_mark stop); } in
-      Stack.push ide_payload cmd_stack;
-      if display_goals then self#show_goals;
-      remove_tag (start,stop)
-    in
-    match sync get_next_phrase () with
-      | None -> raise Unsuccessful
-      | Some ((_,stop) as loc,phrase) ->
-	  if stop#backward_char#has_tag Tags.Script.comment
-	  then sync mark_processed Safe loc
-          else try match self#send_to_coq ct verbosely phrase true true true with
-            | Some safe -> sync mark_processed safe loc
-            | None -> sync remove_tag loc; raise Unsuccessful
-	  with
-	    | RestartCoqtop -> sync remove_tag loc; raise RestartCoqtop
-
-  method process_next_phrase verbosely =
-    try self#process_one_phrase !mycoqtop verbosely true true
-    with Unsuccessful -> ()
-
-  method private insert_this_phrase_on_success
-    show_output show_msg localize coqphrase insertphrase =
-    let mark_processed safe =
-      let stop = self#get_start_of_input in
-      if stop#starts_line then
-        input_buffer#insert ~iter:stop insertphrase
-      else input_buffer#insert ~iter:stop ("\n"^insertphrase);
-      tag_on_insert input_buffer;
-      let start = self#get_start_of_input in
-      input_buffer#move_mark ~where:stop (`NAME "start_of_input");
-      input_buffer#apply_tag (safety_tag safe) ~start ~stop;
-      if (self#get_insert#compare) stop <= 0 then
-        input_buffer#place_cursor ~where:stop;
-      let ide_payload = { start = `MARK (input_buffer#create_mark start);
-                          stop = `MARK (input_buffer#create_mark stop); } in
-      Stack.push ide_payload cmd_stack;
-      self#show_goals;
-       (*Auto insert save on success...
-	 try (match Coq.get_current_goals () with
-	 | [] ->
-	 (match self#send_to_coq "Save.\n" true true true with
-	 | Some ast ->
-	 begin
-	 let stop = self#get_start_of_input in
-	 if stop#starts_line then
-	 input_buffer#insert ~iter:stop "Save.\n"
-	 else input_buffer#insert ~iter:stop "\nSave.\n";
-	 let start = self#get_start_of_input in
-	 input_buffer#move_mark ~where:stop (`NAME"start_of_input");
-	 input_buffer#apply_tag_by_name "processed" ~start ~stop;
-	 if (self#get_insert#compare) stop <= 0 then
-	 input_buffer#place_cursor stop;
-	 let start_of_phrase_mark =
-	 `MARK (input_buffer#create_mark start) in
-	 let end_of_phrase_mark =
-	 `MARK (input_buffer#create_mark stop) in
-	 push_phrase
-	 reset_info start_of_phrase_mark end_of_phrase_mark ast
-	 end
-	 | None -> ())
-	 | _ -> ())
-	 with _ -> ()*) in
-    match self#send_to_coq !mycoqtop false coqphrase show_output show_msg localize with
-      | Some safe -> sync mark_processed safe; true
-      | None ->
-        sync
-          (fun _ -> self#insert_message ("Unsuccessfully tried: "^coqphrase))
-          ();
-        false
-
-  method process_until_iter_or_error stop =
-    let stop' = `OFFSET stop#offset in
-    let start = self#get_start_of_input#copy in
-    let start' = `OFFSET start#offset in
-    sync (fun _ ->
-      input_buffer#apply_tag Tags.Script.to_process ~start ~stop;
-      input_view#set_editable false) ();
-    push_info "Coq is computing";
-    let get_current () =
-      if !current.stop_before then
-        match self#find_phrase_starting_at self#get_start_of_input with
-          | None -> self#get_start_of_input
-          | Some (_, stop2) -> stop2
-      else begin
-        self#get_start_of_input
-      end
-    in
-    let unlock () =
-      sync (fun _ ->
-	self#show_goals;
-	(* Start and stop might be invalid if an eol was added at eof *)
-	let start = input_buffer#get_iter start' in
-	let stop =  input_buffer#get_iter stop' in
-	input_buffer#remove_tag Tags.Script.to_process ~start ~stop;
-	input_view#set_editable true) ()
-    in
-    (* All the [process_one_phrase] below should be done with the same [ct]
-       instead of accessing multiple time [mycoqtop]. Otherwise a restart of
-       coqtop could go unnoticed, and the new coqtop could receive strange
-       things. *)
-    let ct = !mycoqtop in
-    (try
-       while stop#compare (get_current()) >= 0
-       do self#process_one_phrase ct false false false done
-     with
-       | Unsuccessful -> ()
-       | RestartCoqtop -> unlock (); raise RestartCoqtop);
-    unlock ();
-    pop_info()
-
-  method process_until_end_or_error =
-    self#process_until_iter_or_error input_buffer#end_iter
-
-  method reset_initial =
-    mycoqtop := Coq.respawn_coqtop !mycoqtop;
-    sync (fun () ->
-      Stack.iter
-	(function inf ->
-          let start = input_buffer#get_iter_at_mark inf.start in
-          let stop = input_buffer#get_iter_at_mark inf.stop in
-          input_buffer#move_mark ~where:start (`NAME "start_of_input");
-          input_buffer#remove_tag Tags.Script.processed ~start ~stop;
-	  input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
-          input_buffer#delete_mark inf.start;
-          input_buffer#delete_mark inf.stop;
-	)
-	cmd_stack;
-      Stack.clear cmd_stack;
-      self#clear_message) ()
-
-  method force_reset_initial =
-    (* Do nothing if a force_reset_initial is already ongoing *)
-    if Mutex.try_lock resetting then begin
-      Coq.kill_coqtop !mycoqtop;
-      (* If a computation is ongoing, an exception will trigger
-	 the reset_initial in do_if_not_computing, not here. *)
-      if Mutex.try_lock coq_computing then begin
-	self#reset_initial;
-	Mutex.unlock coq_computing
-      end;
-      Mutex.unlock resetting
-    end
+      let cmd =
+        local_cd f ^ prefs.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^
+        (Filename.quote output) ^ " " ^ (Filename.quote basef) ^ " 2>&1"
+      in
+      sn.messages#set ("Running: "^cmd);
+      let finally st = flash_info (cmd ^ pr_exit_status st)
+      in
+      run_command sn.messages#add finally cmd
 
-  (* Internal method for dialoging with coqtop about a backtrack.
-     The ide's cmd_stack has already been cleared up to the desired point.
-     The [finish] function is used to handle minor differences between
-     [go_to_insert] and [undo_last_step] *)
-
-  method private do_backtrack finish n =
-    (* pop n more commands if coqtop has said so (e.g. for undoing a proof) *)
-    let rec n_pop n =
-      if n = 0 then ()
-      else
-	let phrase = Stack.pop cmd_stack in
-	let stop = input_buffer#get_iter_at_mark phrase.stop in
-        if stop#backward_char#has_tag Tags.Script.comment
-	  then n_pop n
-	  else n_pop (pred n)
-    in
-    match Coq.rewind !mycoqtop n with
-      | Interface.Good n ->
-	n_pop n;
-        sync (fun _ ->
-          let start =
-            if Stack.is_empty cmd_stack then input_buffer#start_iter
-            else input_buffer#get_iter_at_mark (Stack.top cmd_stack).stop in
-	  let stop = self#get_start_of_input in
-          input_buffer#remove_tag Tags.Script.processed ~start ~stop;
-          input_buffer#remove_tag Tags.Script.unjustified ~start ~stop;
-          input_buffer#move_mark ~where:start (`NAME "start_of_input");
-          self#show_goals;
-          self#clear_message;
-          finish start) ()
-      | Interface.Fail (l,str) ->
-        sync self#set_message
-          ("Error while backtracking :\n" ^ str ^ "\n" ^
-	   "CoqIDE and coqtop may be out of sync, you may want to use Restart.")
-
-  (* backtrack Coq to the phrase preceding iterator [i] *)
-  method backtrack_to_no_lock i =
-    prerr_endline "Backtracking_to iter starts now.";
-    full_goal_done <- false;
-    (* pop Coq commands until we reach iterator [i] *)
-    let rec n_step n =
-      if Stack.is_empty cmd_stack then n else
-        let phrase = Stack.top cmd_stack in
-	let stop = input_buffer#get_iter_at_mark phrase.stop in
-        if i#compare stop >= 0 then n
-	else begin
-	  ignore (Stack.pop cmd_stack);
-          if stop#backward_char#has_tag Tags.Script.comment
-	  then n_step n
-	  else n_step (succ n)
-	end
-    in
-    begin
-      try
-	self#do_backtrack (fun _ -> ()) (n_step 0);
-	(* We may have backtracked too much: let's replay *)
-	self#process_until_iter_or_error i
-      with _ ->
-        push_info
-	  ("WARNING: undo failed badly.\n" ^
-	   "Coq might be in an inconsistent state.\n" ^
-	   "Please restart and report.");
-    end
+let export kind = cb_on_current_term (export kind)
 
-  method backtrack_to i =
-    if Mutex.try_lock coq_may_stop then
-      (push_info "Undoing...";
-       self#backtrack_to_no_lock i; Mutex.unlock coq_may_stop;
-       pop_info ())
-    else prerr_endline "backtrack_to : discarded (lock is busy)"
-
-  method go_to_insert =
-    let point = self#get_insert in
-    if point#compare self#get_start_of_input>=0
-    then self#process_until_iter_or_error point
-    else self#backtrack_to point
-
-  method undo_last_step =
-    full_goal_done <- false;
-    if Mutex.try_lock coq_may_stop then
-      (push_info "Undoing last step...";
-       (try
-          let phrase = Stack.pop cmd_stack in
-	  let stop = input_buffer#get_iter_at_mark phrase.stop in
-	  let count =
-	    if stop#backward_char#has_tag Tags.Script.comment then 0 else 1
-	  in
-	  let finish where =
-	    input_buffer#place_cursor ~where;
-	    self#recenter_insert;
-	  in
-	  self#do_backtrack finish count
-        with Stack.Empty -> ()
-       );
-       pop_info ();
-       Mutex.unlock coq_may_stop)
-    else prerr_endline "undo_last_step discarded"
-
-
-  method insert_command cp ip =
-    async(fun _ -> self#clear_message)();
-    ignore (self#insert_this_phrase_on_success true false false cp ip)
-
-  method tactic_wizard l =
-    async(fun _ -> self#clear_message)();
-    ignore
-      (List.exists
-         (fun p ->
-           self#insert_this_phrase_on_success true false false
-             ("progress "^p^".") (p^".")) l)
-
-  method active_keypress_handler k =
-    let state = GdkEvent.Key.state k in
-    begin
-      match  state with
-        | l ->
-          if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
-            prerr_endline "active_kp_handler for Tab";
-            self#indent_current_line;
-            true
-          end else false
-    end
+let print sn =
+  match sn.fileops#filename with
+    |None -> flash_info "Cannot print: this buffer has no name"
+    |Some f_name ->
+      let cmd =
+        local_cd f_name ^ prefs.cmd_coqdoc ^ " -ps " ^
+        Filename.quote (Filename.basename f_name) ^ " | " ^ prefs.cmd_print
+      in
+      let w = GWindow.window ~title:"Print" ~modal:true
+        ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" ()
+      in
+      let v = GPack.vbox ~spacing:10 ~border_width:10 ~packing:w#add ()
+      in
+      let _ = GMisc.label ~text:"Print using the following command:"
+        ~justify:`LEFT ~packing:v#add ()
+      in
+      let e = GEdit.entry ~text:cmd ~editable:true ~width_chars:80
+        ~packing:v#add ()
+      in
+      let h = GPack.hbox ~spacing:10 ~packing:v#add ()
+      in
+      let ko = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:h#add ()
+      in
+      let ok = GButton.button ~stock:`PRINT ~label:"Print" ~packing:h#add ()
+      in
+      let callback_print () =
+        w#destroy ();
+        let cmd = e#text in
+        let finally st = flash_info (cmd ^ pr_exit_status st) in
+        run_command ignore finally cmd
+      in
+      let _ = ko#connect#clicked ~callback:w#destroy in
+      let _ = ok#connect#clicked ~callback:callback_print in
+      w#misc#show ()
 
-  val mutable act_id = None
+let print = cb_on_current_term print
+
+let highlight sn =
+  Sentence.tag_all sn.buffer;
+  sn.script#recenter_insert
+
+let highlight = cb_on_current_term highlight
 
-  method activate () = if not is_active then begin
-    is_active <- true;
-    act_id <- Some
-      (input_view#event#connect#key_press ~callback:self#active_keypress_handler);
-    prerr_endline "CONNECTED active : ";
-    print_id (match act_id with Some x -> x | None -> assert false);
-    match filename with
-      | None -> ()
-      | Some f ->
-	let dir = Filename.dirname f in
-	let ct = !mycoqtop in
-	match Coq.inloadpath ct dir with
-	  | Interface.Fail (_,str) ->
-	    self#set_message
-	      ("Could not determine lodpath, this might lead to problems:\n"^str)
-	  | Interface.Good true -> ()
-	  | Interface.Good false ->
-	    let cmd = Printf.sprintf "Add LoadPath \"%s\". "  dir in
-	    match Coq.interp ct 0 cmd with
-	      | Interface.Fail (l,str) ->
-		self#set_message ("Couln't add loadpath:\n"^str)
-	      | Interface.Good _ -> ()
-  end
-
-  method private electric_paren tag =
-    let oparen_code = Glib.Utf8.to_unichar "("  ~pos:(ref 0) in
-    let cparen_code = Glib.Utf8.to_unichar ")"  ~pos:(ref 0) in
-    ignore (input_buffer#connect#insert_text ~callback:
-              (fun it x ->
-                input_buffer#remove_tag
-                  ~start:input_buffer#start_iter
-                  ~stop:input_buffer#end_iter
-                  tag;
-                if x = "" then () else
-                  match x.[String.length x - 1] with
-                    | ')' ->
-                      let hit = self#get_insert in
-                      let count = ref 0 in
-                      if hit#nocopy#backward_find_char
-                        (fun c ->
-                          if c = oparen_code && !count = 0 then true
-                          else if c = cparen_code then
-                            (incr count;false)
-                          else if c = oparen_code then
-                            (decr count;false)
-                          else false
-                        )
-                      then
-                        begin
-                          prerr_endline "Found matching parenthesis";
-                          input_buffer#apply_tag tag ~start:hit ~stop:hit#forward_char
-                        end
-                      else ()
-                    | _ -> ())
-  )
-
-  method help_for_keyword () =
-    browse_keyword (self#insert_message) (get_current_word ())
-
-(** NB: Events during text edition:
-
-    - [begin_user_action]
-    - [insert_text] (or [delete_range] when deleting)
-    - [changed]
-    - [end_user_action]
-
-   When pasting a text containing tags (e.g. the sentence terminators),
-   there is actually many [insert_text] and [changed]. For instance,
-   for "a. b.":
-
-    - [begin_user_action]
-    - [insert_text] (for "a")
-    - [changed]
-    - [insert_text] (for ".")
-    - [changed]
-    - [apply_tag] (for the tag of ".")
-    - [insert_text] (for " b")
-    - [changed]
-    - [insert_text] (for ".")
-    - [changed]
-    - [apply_tag] (for the tag of ".")
-    - [end_user_action]
-
-  Since these copy-pasted tags may interact badly with the retag mechanism,
-  we now don't monitor the "changed" event, but rather the "begin_user_action"
-  and "end_user_action". We begin by setting a mark at the initial cursor
-  point. At the end, the zone between the mark and the cursor is to be
-  untagged and then retagged. *)
-
-  initializer
-    ignore (message_buffer#connect#insert_text
-              ~callback:(fun it s -> ignore
-                (message_view#scroll_to_mark
-                   ~use_align:false
-                   ~within_margin:0.49
-                   `INSERT)));
-    ignore (input_buffer#connect#insert_text
-              ~callback:(fun it s ->
-                if (it#compare self#get_start_of_input)<0
-                then GtkSignal.stop_emit ();
-                if String.length s > 1 then
-                  (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor ~where:it)));
-    ignore (input_buffer#connect#after#apply_tag
-              ~callback:(fun tag ~start ~stop ->
-                if (start#compare self#get_start_of_input)>=0
-                then
-                  begin
-                    input_buffer#remove_tag
-                      Tags.Script.processed
-                      ~start
-                      ~stop;
-                    input_buffer#remove_tag
-                      Tags.Script.unjustified
-                      ~start
-                      ~stop
-                  end
-              )
-    );
-    ignore (input_buffer#connect#after#insert_text
-              ~callback:(fun it s ->
-                if auto_complete_on &&
-                  String.length s = 1 && s <> " " && s <> "\n"
-                then
-                  let v = session_notebook#current_term.analyzed_view
-                  in
-                  let has_completed =
-                    v#complete_at_offset
-                      ((input_view#buffer#get_iter `SEL_BOUND)#offset)
-                  in
-                  if has_completed then
-                    input_buffer#move_mark `SEL_BOUND ~where:(input_buffer#get_iter `SEL_BOUND)#forward_char;
-              )
-    );
-    ignore (input_buffer#connect#begin_user_action
-	      ~callback:(fun () ->
-                let where = self#get_insert in
-                input_buffer#move_mark (`NAME "prev_insert") ~where;
-                let start = self#get_start_of_input in
-                let stop = input_buffer#end_iter in
-                input_buffer#remove_tag Tags.Script.error ~start ~stop)
-    );
-    ignore (input_buffer#connect#end_user_action
-              ~callback:(fun () ->
-                last_modification_time <- Unix.time ();
-                tag_on_insert input_buffer
-              )
-    );
-    ignore (input_buffer#add_selection_clipboard cb);
-    ignore (proof_buffer#add_selection_clipboard cb);
-    ignore (message_buffer#add_selection_clipboard cb);
-    self#electric_paren Tags.Script.paren;
-    ignore (input_buffer#connect#after#mark_set
-              ~callback:(fun it (m:Gtk.text_mark) ->
-                !set_location
-                  (Printf.sprintf
-                     "Line: %5d Char: %3d" (self#get_insert#line + 1)
-                     (self#get_insert#line_offset + 1));
-                match GtkText.Mark.get_name m  with
-                  | Some "insert" ->
-                    input_buffer#remove_tag
-                      ~start:input_buffer#start_iter
-                      ~stop:input_buffer#end_iter
-                      Tags.Script.paren;
-                  | Some s ->
-                    prerr_endline (s^" moved")
-                  | None -> () )
-    );
-    ignore (input_buffer#connect#insert_text
-              ~callback:(fun it s ->
-                prerr_endline "Should recenter ?";
-                if String.contains s '\n' then begin
-                  prerr_endline "Should recenter : yes";
-                  self#recenter_insert
-                end));
 end
 
-let last_make = ref "";;
-let last_make_index = ref 0;;
+(** Timers *)
+
+let reset_revert_timer () =
+  FileOps.revert_timer.kill ();
+  if prefs.global_auto_revert then
+    FileOps.revert_timer.run
+      ~ms:prefs.global_auto_revert_delay
+      ~callback:(fun () -> File.revert_all (); true)
+
+let reset_autosave_timer () =
+  let autosave sn = try sn.fileops#auto_save with _ -> () in
+  let autosave_all () = List.iter autosave notebook#pages; true in
+  FileOps.autosave_timer.kill ();
+  if prefs.auto_save then
+    FileOps.autosave_timer.run ~ms:prefs.auto_save_delay ~callback:autosave_all
+
+(** Export of functions used in [coqide_main] : *)
+
+let forbid_quit () =
+  try FileAux.check_quit File.saveall; false
+  with FileAux.DontQuit -> true
+
+let close_and_quit = FileAux.close_and_quit
+let crash_save = FileAux.crash_save
+let do_load f = FileAux.load_file f
+
+(** Callbacks for external commands *)
+
+module External = struct
+
+let coq_makefile sn =
+  match sn.fileops#filename with
+    |None -> flash_info "Cannot make makefile: this buffer has no name"
+    |Some f ->
+      let cmd = local_cd f ^ prefs.cmd_coqmakefile in
+      let finally st = flash_info (current.cmd_coqmakefile ^ pr_exit_status st)
+      in
+      run_command ignore finally cmd
+
+let coq_makefile = cb_on_current_term coq_makefile
+
+let editor sn =
+  match sn.fileops#filename with
+    |None -> warning "Call to external editor available only on named files"
+    |Some f ->
+      File.save ();
+      let f = Filename.quote f in
+      let cmd = Util.subst_command_placeholder prefs.cmd_editor f in
+      run_command ignore (fun _ -> sn.fileops#revert) cmd
+
+let editor = cb_on_current_term editor
+
+let compile sn =
+  File.save ();
+  match sn.fileops#filename with
+    |None -> flash_info "Active buffer has no name"
+    |Some f ->
+      let cmd = prefs.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f))
+	^ " " ^ (Filename.quote f) ^ " 2>&1"
+      in
+      let buf = Buffer.create 1024 in
+      sn.messages#set ("Running: "^cmd);
+      let display s =
+        sn.messages#add s;
+        Buffer.add_string buf s
+      in
+      let finally st =
+        if st = Unix.WEXITED 0 then
+          flash_info (f ^ " successfully compiled")
+        else begin
+          flash_info (f ^ " failed to compile");
+          sn.messages#set "Compilation output:\n";
+          sn.messages#add (Buffer.contents buf);
+        end
+      in
+      run_command display finally cmd
+
+let compile = cb_on_current_term compile
+
+(** [last_make_buf] contains the output of the last make compilation.
+    [last_make] is the same, but as a string, refreshed only when searching
+    the next error. *)
+
+let last_make_buf = Buffer.create 1024
+let last_make = ref ""
+let last_make_index = ref 0
+let last_make_dir = ref ""
+
+let make sn =
+  match sn.fileops#filename with
+    |None -> flash_info "Cannot make: this buffer has no name"
+    |Some f ->
+      File.saveall ();
+      let cmd = local_cd f ^ prefs.cmd_make ^ " 2>&1" in
+      sn.messages#set "Compilation output:\n";
+      Buffer.reset last_make_buf;
+      last_make := "";
+      last_make_index := 0;
+      last_make_dir := Filename.dirname f;
+      let display s =
+        sn.messages#add s;
+        Buffer.add_string last_make_buf s
+      in
+      let finally st = flash_info (current.cmd_make ^ pr_exit_status st)
+      in
+      run_command display finally cmd
+
+let make = cb_on_current_term make
+
 let search_compile_error_regexp =
   Str.regexp
-    "File \"\\([^\"]+\\)\", line \\([0-9]+\\), characters \\([0-9]+\\)-\\([0-9]+\\)";;
+    "File \"\\([^\"]+\\)\", line \\([0-9]+\\), characters \\([0-9]+\\)-\\([0-9]+\\)"
 
 let search_next_error () =
-  let _ = Str.search_forward search_compile_error_regexp !last_make !last_make_index in
+  if String.length !last_make <> Buffer.length last_make_buf
+  then last_make := Buffer.contents last_make_buf;
+  let _ =
+    Str.search_forward search_compile_error_regexp !last_make !last_make_index
+  in
   let f = Str.matched_group 1 !last_make
   and l = int_of_string (Str.matched_group 2 !last_make)
   and b = int_of_string (Str.matched_group 3 !last_make)
@@ -1428,1527 +493,938 @@ let search_next_error () =
   and msg_index = Str.match_beginning ()
   in
   last_make_index := Str.group_end 4;
-  (f,l,b,e,
+  (Filename.concat !last_make_dir f, l, b, e,
    String.sub !last_make msg_index (String.length !last_make - msg_index))
 
+let next_error sn =
+  try
+    let file,line,start,stop,error_msg = search_next_error () in
+    FileAux.load_file file;
+    let b = sn.buffer in
+    let starti = b#get_iter_at_byte ~line:(line-1) start in
+    let stopi = b#get_iter_at_byte ~line:(line-1) stop in
+    b#apply_tag Tags.Script.error ~start:starti ~stop:stopi;
+    b#place_cursor ~where:starti;
+    sn.messages#set error_msg;
+    sn.script#misc#grab_focus ()
+  with Not_found ->
+    last_make_index := 0;
+    sn.messages#set "No more errors.\n"
+
+let next_error = cb_on_current_term next_error
 
+end
 
-(**********************************************************************)
-(* session creation and primitive handling                            *)
-(**********************************************************************)
-
-let create_session file =
-  let script =
-    Undo.undoable_view
-      ~buffer:(GText.buffer ~tag_table:Tags.Script.table ())
-      ~wrap_mode:`NONE () in
-  let proof =
-    GText.view
-      ~buffer:(GText.buffer ~tag_table:Tags.Proof.table ())
-      ~editable:false ~wrap_mode:`CHAR () in
-  let message =
-    GText.view
-      ~buffer:(GText.buffer ~tag_table:Tags.Message.table ())
-      ~editable:false ~wrap_mode:`WORD () in
-  let basename = GMisc.label ~text:(match file with
-				      |None -> "*scratch*"
-				      |Some f -> (Glib.Convert.filename_to_utf8 (Filename.basename f))
-				   ) () in
-  let stack = Stack.create () in
-  let coqtop_args = match file with
-    |None -> !sup_args
-    |Some the_file -> match !current.read_project with
-	|Ignore_args -> !sup_args
-	|Append_args -> (Project_file.args_from_project the_file !custom_project_files !current.project_file_name)
-	   @(!sup_args)
-	|Subst_args -> Project_file.args_from_project the_file !custom_project_files !current.project_file_name
-  in
-  let ct = ref (Coq.spawn_coqtop coqtop_args) in
-  let command = new Command_windows.command_window ct current in
-  let legacy_av = new analyzed_view script proof message stack ct file in
-  let () = legacy_av#update_stats in
-  let _ =
-    script#buffer#create_mark ~name:"start_of_input" script#buffer#start_iter in
-  let _ =
-    script#buffer#create_mark ~name:"prev_insert" script#buffer#start_iter in
-  let _ =
-    proof#buffer#create_mark ~name:"end_of_conclusion" proof#buffer#start_iter in
-  let _ =
-    GtkBase.Widget.add_events proof#as_widget [`ENTER_NOTIFY;`POINTER_MOTION] in
-  let () =
-    List.iter (fun (opts,_,_,_,dflt) -> setopts !ct opts dflt) print_items in
-  let _ = legacy_av#activate () in
-  let _ =
-    proof#event#connect#motion_notify ~callback:
-      (fun e ->
-        let win = match proof#get_window `WIDGET with
-          | None -> assert false
-          | Some w -> w in
-        let x,y = Gdk.Window.get_pointer_location win in
-        let b_x,b_y = proof#window_to_buffer_coords ~tag:`WIDGET ~x ~y in
-        let it = proof#get_iter_at_location ~x:b_x ~y:b_y in
-        let tags = it#tags in
-        List.iter
-          (fun t ->
-            ignore (GtkText.Tag.event t#as_tag proof#as_widget e it#as_iter))
-          tags;
-        false) in
-  script#misc#set_name "ScriptWindow";
-  script#buffer#place_cursor ~where:(script#buffer#start_iter);
-  proof#misc#set_can_focus true;
-  message#misc#set_can_focus true;
-  (* setting fonts *)
-  script#misc#modify_font !current.text_font;
-  proof#misc#modify_font !current.text_font;
-  message#misc#modify_font !current.text_font;
-  (* setting colors *)
-  script#misc#modify_base [`NORMAL, `NAME !current.background_color];
-  proof#misc#modify_base [`NORMAL, `NAME !current.background_color];
-  message#misc#modify_base [`NORMAL, `NAME !current.background_color];
-
-  { tab_label=basename;
-    filename=begin match file with None -> "" |Some f -> f end;
-    script=script;
-    proof_view=proof;
-    message_view=message;
-    analyzed_view=legacy_av;
-    encoding="";
-    toplvl=ct;
-    command=command
-  }
-
-(* XXX - to be used later
-   let load_session session filename encs =
-   session.encoding <- List.find (IdeIO.load filename session.script#buffer) encs;
-   session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
-   session.filename <- filename;
-   session.script#buffer#set_modified false
-
-
-   let save_session session filename encs =
-   session.encoding <- List.find (IdeIO.save session.script#buffer filename) encs;
-   session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename filename));
-   session.filename <- filename;
-   session.script#buffer#set_modified false
-
-
-   let init_session session =
-   session.script#buffer#set_modified false;
-   session.script#clear_undo;
-   session.script#buffer#place_cursor session.script#buffer#start_iter
-*)
-
+(** Callbacks for the Navigation menu *)
 
+let update_status sn =
+  let display msg = pop_info (); push_info msg in
+  let next = function
+  | Interface.Fail x -> sn.coqops#handle_failure x
+  | Interface.Good status ->
+    let path = match status.Interface.status_path with
+      | [] | _ :: [] -> "" (* Drop the topmost level, usually "Top" *)
+      | _ :: l -> " in " ^ String.concat "." l
+    in
+    let name = match status.Interface.status_proofname with
+      | None -> ""
+      | Some n -> ", proving " ^ n
+    in
+    display ("Ready"^ if current.nanoPG then ", [μPG]" else "" ^ path ^ name);
+    Coq.return ()
+  in
+  Coq.bind (Coq.status ~logger:sn.messages#push false) next
+
+let find_next_occurrence ~backward sn =
+  (** go to the next occurrence of the current word, forward or backward *)
+  let b = sn.buffer in
+  let start = find_word_start (b#get_iter_at_mark `INSERT) in
+  let stop = find_word_end start in
+  let text = b#get_text ~start ~stop () in
+  let search = if backward then start#backward_search else stop#forward_search
+  in
+  match search text with
+    |None -> ()
+    |Some(where, _) -> b#place_cursor ~where; sn.script#recenter_insert
+
+let send_to_coq_aux f sn =
+  let info () = Minilib.log ("Coq busy, discarding query") in
+  let f = Coq.seq (f sn) (update_status sn) in
+  Coq.try_grab sn.coqtop f info
+
+let send_to_coq f = on_current_term (send_to_coq_aux f)
+
+module Nav = struct
+  let forward_one _ = send_to_coq (fun sn -> sn.coqops#process_next_phrase)
+  let backward_one _ = send_to_coq (fun sn -> sn.coqops#backtrack_last_phrase)
+  let goto _ = send_to_coq (fun sn -> sn.coqops#go_to_insert)
+  let goto_end _ = send_to_coq (fun sn -> sn.coqops#process_until_end_or_error)
+  let previous_occ = cb_on_current_term (find_next_occurrence ~backward:true)
+  let next_occ = cb_on_current_term (find_next_occurrence ~backward:false)
+  let restart sn =
+    Minilib.log "Reset Initial";
+    Coq.reset_coqtop sn.coqtop
+  let restart _ = on_current_term restart
+  let interrupt sn =
+    Minilib.log "User break received";
+    Coq.break_coqtop sn.coqtop
+  let interrupt = cb_on_current_term interrupt
+  let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document)
+end
 
+let tactic_wizard_callback l _ =
+  send_to_coq (fun sn -> sn.coqops#tactic_wizard l)
+
+let printopts_callback opts v =
+  let b = v#get_active in
+  let () = List.iter (fun o -> Coq.PrintOpt.set o b) opts in
+  send_to_coq (fun sn -> sn.coqops#show_goals)
+
+(** Templates menu *)
+
+let get_current_word term =
+  (** First look to find if autocompleting *)
+  match term.script#complete_popup#proposal with
+  | Some p -> p
+  | None ->
+  (** Then look at the current selected word *)
+  if term.script#buffer#has_selection then
+    let (start, stop) = term.script#buffer#selection_bounds in
+    term.script#buffer#get_text ~slice:true ~start ~stop ()
+  (** Otherwise try to recover the clipboard *)
+  else match Ideutils.cb#text with
+  | Some t -> t
+  | None -> ""
+
+let print_branch c l =
+  Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
+    (Minilib.print_list (fun c s -> Format.fprintf c "%s@ " s)) l
+
+let print_branches c cases =
+  Format.fprintf c "@[match var with@\n%aend@]@."
+    (Minilib.print_list print_branch) cases
+
+let display_match sn = function
+  |Interface.Fail _ ->
+    flash_info "Not an inductive type"; Coq.return ()
+  |Interface.Good cases ->
+    let text =
+      let buf = Buffer.create 1024 in
+      let () = print_branches (Format.formatter_of_buffer buf) cases in
+      Buffer.contents buf
+    in
+    Minilib.log ("match template :\n" ^ text);
+    let b = sn.buffer in
+    let _ =  b#delete_selection () in
+    let m = b#create_mark (b#get_iter_at_mark `INSERT) in
+    if b#insert_interactive text then begin
+      let i = b#get_iter (`MARK m) in
+      let _ = i#nocopy#forward_chars 9 in
+      let _ = b#place_cursor ~where:i in
+      b#move_mark ~where:(i#backward_chars 3) `SEL_BOUND
+    end;
+    b#delete_mark (`MARK m);
+    Coq.return ()
+
+let match_callback sn =
+  let w = get_current_word sn in
+  let coqtop = sn.coqtop in
+  let query = Coq.bind (Coq.mkcases w) (display_match sn) in
+  Coq.try_grab coqtop query ignore
+
+let match_callback = cb_on_current_term match_callback
+
+(** Queries *)
+
+module Query = struct
+
+let searchabout sn =
+  let word = get_current_word sn in
+  let buf = sn.messages#buffer in
+  let insert result =
+    let qualid = result.Interface.coq_object_qualid in
+    let name = String.concat "." qualid in
+    let tpe = result.Interface.coq_object_object in
+    buf#insert ~tags:[Tags.Message.item] name;
+    buf#insert "\n";
+    buf#insert tpe;
+    buf#insert "\n";
+  in
+  let display_results r =
+    sn.messages#clear;
+    List.iter insert (match r with Interface.Good l -> l | _ -> []);
+    Coq.return ()
+  in
+  let launch_query =
+    let search = Coq.search [Interface.SubType_Pattern word, true] in
+    Coq.bind search display_results
+  in
+  Coq.try_grab sn.coqtop launch_query ignore
 
-(*********************************************************************)
-(* functions called by the user interface                            *)
-(*********************************************************************)
-(* XXX - to be used later
-   let do_open session filename =
-   try
-   load_session session filename ["UTF-8";"ISO-8859-1";"ISO-8859-15"];
-   init_session session;
-   ignore (session_notebook#append_term session)
-   with _ -> ()
-
-
-   let do_save session =
-   try
-   if session.script#buffer#modified then
-   save_session session session.filename [session.encoding]
-   with _ -> ()
-
-
-   let choose_open =
-   let last_filename = ref "" in fun session ->
-   let open_dialog = GWindow.file_chooser_dialog ~action:`OPEN ~title:"Open file" ~modal:true () in
-   let enc_frame = GBin.frame ~label:"File encoding" ~packing:(open_dialog#vbox#pack ~fill:false) () in
-   let enc_entry = GEdit.entry ~text:(String.concat " " ["UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
-   let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
-   ~message:"Invalid encoding, please indicate the encoding to use." () in
-   let open_response = function
-   | `OPEN -> begin
-   match open_dialog#filename with
-   | Some fn -> begin
-   try
-   load_session session fn (Util.split_string_at ' ' enc_entry#text);
-   session.analyzed_view <- Some (new analyzed_view session);
-   init_session session;
-   session_notebook#goto_page (session_notebook#append_term session);
-   last_filename := fn
-   with
-   | Not_found -> open_dialog#misc#hide (); error_dialog#show ()
-   | _ ->
-   error_dialog#set_markup "Unknown error while loading file, aborting.";
-   open_dialog#destroy (); error_dialog#destroy ()
-   end
-   | None -> ()
-   end
-   | `DELETE_EVENT -> open_dialog#destroy (); error_dialog#destroy ()
-   in
-   let _ = open_dialog#connect#response open_response in
-   let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); open_dialog#show ()) in
-   let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
-   let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
-   open_dialog#add_select_button_stock `OPEN `OPEN;
-   open_dialog#add_button_stock `CANCEL `DELETE_EVENT;
-   open_dialog#add_filter filter_any;
-   open_dialog#add_filter filter_coq;
-   ignore(open_dialog#set_filename !last_filename);
-   open_dialog#show ()
-
-
-   let choose_save session =
-   let save_dialog = GWindow.file_chooser_dialog ~action:`SAVE ~title:"Save file" ~modal:true () in
-   let enc_frame = GBin.frame ~label:"File encoding" ~packing:(save_dialog#vbox#pack ~fill:false) () in
-   let enc_entry = GEdit.entry ~text:(String.concat " " [session.encoding;"UTF-8";"ISO-8859-1";"ISO-8859-15"]) ~packing:enc_frame#add () in
-   let error_dialog = GWindow.message_dialog ~message_type:`ERROR ~modal:true ~buttons:GWindow.Buttons.ok
-   ~message:"Invalid encoding, please indicate the encoding to use." () in
-   let save_response = function
-   | `SAVE -> begin
-   match save_dialog#filename with
-   | Some fn -> begin
-   try
-   save_session session fn (Util.split_string_at ' ' enc_entry#text)
-   with
-   | Not_found -> save_dialog#misc#hide (); error_dialog#show ()
-   | _ ->
-   error_dialog#set_markup "Unknown error while saving file, aborting.";
-   save_dialog#destroy (); error_dialog#destroy ()
-   end
-   | None -> ()
-   end
-   | `DELETE_EVENT -> save_dialog#destroy (); error_dialog#destroy ()
-   in
-   let _ = save_dialog#connect#response save_response in
-   let _ = error_dialog#connect#response (fun x -> error_dialog#misc#hide (); save_dialog#show ()) in
-   let filter_any = GFile.filter ~name:"Any" ~patterns:["*"] () in
-   let filter_coq = GFile.filter ~name:"Coq source" ~patterns:["*.v"] () in
-   save_dialog#add_select_button_stock `SAVE `SAVE;
-   save_dialog#add_button_stock `CANCEL `DELETE_EVENT;
-   save_dialog#add_filter filter_any;
-   save_dialog#add_filter filter_coq;
-   ignore(save_dialog#set_filename session.filename);
-   save_dialog#show ()
-*)
+let searchabout () = on_current_term searchabout
 
-(* Nota: using && here has the advantage of working both under win32 and unix.
-   If someday we want the main command to be tried even if the "cd" has failed,
-   then we should use " ; " under unix but " & " under win32 (cf. #2363).
-*)
+let otherquery command sn =
+  let word = get_current_word sn in
+  if word <> "" then
+    let query = command ^ " " ^ word ^ "." in
+    sn.messages#clear;
+    Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore
 
-let local_cd file =
-  "cd " ^ Filename.quote (Filename.dirname file) ^ " && "
+let otherquery command = cb_on_current_term (otherquery command)
 
-let do_print session =
-  let av = session.analyzed_view in
-  match av#filename with
-    |None ->  flash_info "Cannot print: this buffer has no name"
-    |Some f_name ->  begin
-      let cmd =
-        local_cd f_name ^
-          !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename f_name) ^
-          " | " ^ !current.cmd_print
-      in
-      let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE"  () in
-      let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in
-      let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in
-      let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in
-      let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in
-      let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in
-      let print_button  = GButton.button ~stock:`PRINT  ~label:"Print"  ~packing:hbox_print#add () in
-      let callback_print () =
-        let cmd = print_entry#text in
-        let s,_ = run_command av#insert_message cmd in
-        flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed");
-        print_window#destroy ()
-      in
-      ignore (print_cancel_button#connect#clicked ~callback:print_window#destroy) ;
-      ignore (print_button#connect#clicked ~callback:callback_print);
-      print_window#misc#show ()
-    end
+let query command _ =
+  if command = "Search" || command = "SearchAbout"
+  then searchabout ()
+  else otherquery command ()
 
-let load_file handler f =
-  let f = absolute_filename f in
-  try
-    prerr_endline "Loading file starts";
-    let is_f = Minilib.same_file f in
-      if not (Minilib.list_fold_left_i
-		(fun i found x -> if found then found else
-                   let {analyzed_view=av} = x in
-                     (match av#filename with
-			| None -> false
-			| Some fn ->
-			    if is_f fn
-			    then (session_notebook#goto_page i; true)
-			    else false))
-              0 false session_notebook#pages)
-      then begin
-	prerr_endline "Loading: must open";
-	let b = Buffer.create 1024 in
-	prerr_endline "Loading: get raw content";
-	with_file handler f ~f:(input_channel b);
-	prerr_endline "Loading: convert content";
-	let s = do_convert (Buffer.contents b) in
-	prerr_endline "Loading: create view";
-	let session = create_session (Some f) in
-	prerr_endline "Loading: adding view";
-	let index = session_notebook#append_term session in
-	let av = session.analyzed_view in
-	prerr_endline "Loading: stats";
-	av#update_stats;
-	let input_buffer = session.script#buffer in
-	prerr_endline "Loading: fill buffer";
-	input_buffer#set_text s;
-	input_buffer#place_cursor ~where:input_buffer#start_iter;
-	force_retag input_buffer;
-	prerr_endline ("Loading: switch to view "^ string_of_int index);
-	session_notebook#goto_page index;
-	prerr_endline "Loading: highlight";
-	input_buffer#set_modified false;
-	prerr_endline "Loading: clear undo";
-	session.script#clear_undo;
-	prerr_endline "Loading: success"
-      end
-  with
-    | e -> handler ("Load failed: "^(Printexc.to_string e))
-
-let do_load = load_file flash_info
-
-let saveall_f () =
-  List.iter
-    (function
-       | {script = view ; analyzed_view = av} ->
-           begin match av#filename with
-             | None -> ()
-             | Some f ->
-		 ignore (av#save f)
-           end
-    )  session_notebook#pages
-
-let forbid_quit_to_save () =
-    begin try save_pref() with e -> flash_info "Cannot save preferences" end;
-    (if List.exists
-      (function
-        | {script=view} -> view#buffer#modified
-      )
-      session_notebook#pages then
-      match (GToolbox.question_box ~title:"Quit"
-               ~buttons:["Save Named Buffers and Quit";
-                         "Quit without Saving";
-                         "Don't Quit"]
-               ~default:0
-               ~icon:
-               (let img = GMisc.image () in
-                img#set_stock `DIALOG_WARNING;
-                img#set_icon_size `DIALOG;
-                img#coerce)
-               "There are unsaved buffers"
-      )
-      with 1 -> saveall_f () ; false
-        | 2 -> false
-        | _ -> true
-    else false)||
-      (let wait_window =
-        GWindow.window ~modal:true ~wm_class:"CoqIde" ~wm_name:"CoqIde" ~kind:`POPUP
-          ~title:"Terminating coqtops" () in
-      let _ =
-        GMisc.label ~text:"Terminating coqtops processes, please wait ..."
-          ~packing:wait_window#add () in
-      let warning_window =
-        GWindow.message_dialog ~message_type:`WARNING ~buttons:GWindow.Buttons.yes_no
-          ~message:
-	  ("Some coqtops processes are still running.\n" ^
-	     "If you quit CoqIDE right now, you may have to kill them manually.\n" ^
-	     "Do you want to wait for those processes to terminate ?") () in
-      let () = List.iter (fun _ -> session_notebook#remove_page 0) session_notebook#pages in
-      let nb_try=ref (0) in
-      let () = wait_window#show () in
-      let () = while (Coq.coqtop_zombies () <> 0)&&(!nb_try <= 50) do
-	incr nb_try;
-	Thread.delay 0.1 ;
-      done in
-	if (!nb_try = 50) then begin
-	  wait_window#misc#hide ();
-	  match warning_window#run () with
-	    | `YES -> warning_window#misc#hide (); true
-	    | `NO | `DELETE_EVENT -> false
-	end
-	else false)
+end
 
-let logfile = ref None
+(** Misc *)
 
-let main files =
+module MiscMenu = struct
 
-  (* Main window *)
-  let w = GWindow.window
-    ~wm_class:"CoqIde" ~wm_name:"CoqIde"
-    ~allow_grow:true ~allow_shrink:true
-    ~width:!current.window_width ~height:!current.window_height
-    ~title:"CoqIde" ()
-  in
-  (try
-     let icon_image = Filename.concat (List.find
-       (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
-       Minilib.xdg_data_dirs) "coq.png" in
-     let icon = GdkPixbuf.from_file icon_image in
-     w#set_icon (Some icon)
-   with _ -> ());
+let detach_view sn = sn.control#detach ()
 
-  let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
+let detach_view = cb_on_current_term detach_view
 
-  let new_f _ =
-    let session = create_session None in
-    let index = session_notebook#append_term session in
-    session_notebook#goto_page index
-  in
-  let load_f _ =
-    match select_file_for_open ~title:"Load file" () with
-      | None -> ()
-      | Some f -> do_load f
-  in
-  let save_f _ =
-    let current = session_notebook#current_term in
-    try
-      (match current.analyzed_view#filename with
-        | None ->
-          begin match select_file_for_save ~title:"Save file" ()
-            with
-              | None -> ()
-              | Some f ->
-                if current.analyzed_view#save_as f then begin
-                  current.tab_label#set_text (Filename.basename f);
-                  flash_info ("File " ^ f ^ " saved")
-                end
-                else warning ("Save Failed (check if " ^ f ^ " is writable)")
-          end
-        | Some f ->
-          if current.analyzed_view#save f then
-            flash_info ("File " ^ f ^ " saved")
-          else warning  ("Save Failed (check if " ^ f ^ " is writable)")
-
-      )
-    with
-      | e -> warning "Save: unexpected error"
-  in
-  let saveas_f _ =
-    let current = session_notebook#current_term in
-    try (match current.analyzed_view#filename with
-      | None ->
-        begin match select_file_for_save ~title:"Save file as" ()
-          with
-            | None -> ()
-            | Some f ->
-              if current.analyzed_view#save_as f then begin
-                current.tab_label#set_text (Filename.basename f);
-                flash_info "Saved"
-              end
-              else flash_info "Save Failed"
-        end
-      | Some f ->
-        begin match select_file_for_save
-            ~dir:(ref (Filename.dirname f))
-            ~filename:(Filename.basename f)
-            ~title:"Save file as" ()
-          with
-            | None -> ()
-            | Some f ->
-              if current.analyzed_view#save_as f then begin
-                current.tab_label#set_text (Filename.basename f);
-                flash_info "Saved"
-              end else flash_info "Save Failed"
-        end);
-    with e -> flash_info "Save Failed"
-  in
-  let revert_f {analyzed_view = av} =
-    (try
-       match av#filename,av#stats with
-         | Some f,Some stats ->
-           let new_stats = Unix.stat f in
-           if new_stats.Unix.st_mtime > stats.Unix.st_mtime
-           then av#revert
-         | Some _, None -> av#revert
-         | _ -> ()
-     with _ -> av#revert)
-  in
-  let export_f kind _ =
-    let v = session_notebook#current_term in
-    let av = v.analyzed_view in
-    match av#filename with
-      | None ->
-        flash_info "Cannot print: this buffer has no name"
-      | Some f ->
-        let basef = Filename.basename f in
-        let output =
-          let basef_we = try Filename.chop_extension basef with _ -> basef in
-          match kind with
-            | "latex" -> basef_we ^ ".tex"
-            | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind
-            | _ -> assert false
-        in
-        let cmd =
-          local_cd f ^ !current.cmd_coqdoc ^ " --" ^ kind ^
-	    " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef)
-        in
-        let s,_ = run_command av#insert_message cmd in
-        flash_info (cmd ^
-                      if s = Unix.WEXITED 0
-                      then " succeeded"
-                      else " failed")
-  in
-  let quit_f _ = if not (forbid_quit_to_save ()) then exit 0 in
-  let get_active_view_for_cp () =
-    let has_sel (i0,i1) = i0#compare i1 <> 0 in
-    let current = session_notebook#current_term in
-    if has_sel current.script#buffer#selection_bounds
-    then current.script#as_view
-    else if has_sel current.proof_view#buffer#selection_bounds
-    then current.proof_view#as_view
-    else current.message_view#as_view
-  in
-  (*
-    let toggle_auto_complete_i =
-    edit_f#add_check_item "_Auto Completion"
-    ~active:!current.auto_complete
-    ~callback:
-    in
-  *)
-  (*
-    auto_complete :=
-    (fun b -> match session_notebook#current_term.analyzed_view with
-    | Some av -> av#set_auto_complete b
-    | None -> ());
-  *)
-
-(* begin of find/replace mechanism *)
-  let last_found = ref None in
-  let search_backward = ref false in
-  let find_w = GWindow.window
-    (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *)
-    (* ~allow_grow:true ~allow_shrink:true *)
-    (* ~width:!current.window_width ~height:!current.window_height *)
-    ~position:`CENTER
-    ~title:"CoqIde search/replace" ()
-  in
-  let find_box = GPack.table
-    ~columns:3 ~rows:5
-    ~col_spacings:10 ~row_spacings:10 ~border_width:10
-    ~homogeneous:false ~packing:find_w#add () in
+let log_file_message () =
+  if !Minilib.debug then
+    let file = match !logfile with None -> "stderr" | Some f -> f in
+    "\nDebug mode is on, log file is "^file
+  else ""
 
-  let _ =
-    GMisc.label ~text:"Find:"
-      ~xalign:1.0
-      ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) ()
+let initial_about () =
+  let initial_string =
+    "Welcome to CoqIDE, an Integrated Development Environment for Coq"
   in
-  let find_entry = GEdit.entry
-    ~editable: true
-    ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X)
-    ()
+  let coq_version = Coq.short_version () in
+  let version_info =
+    if Glib.Utf8.validate coq_version then
+      "\nYou are running " ^ coq_version
+    else ""
   in
+  let msg = initial_string ^ version_info ^ log_file_message () in
+  on_current_term (fun term -> term.messages#add msg)
+
+let coq_icon () =
+  (* May raise Nof_found *)
+  let name = "coq.png" in
+  let chk d = Sys.file_exists (Filename.concat d name) in
+  let dir = List.find chk (Minilib.coqide_data_dirs ()) in
+  Filename.concat dir name
+
+let about _ =
+  let dialog = GWindow.about_dialog () in
+  let _ = dialog#connect#response ~callback:(fun _ -> dialog#destroy ()) in
   let _ =
-    GMisc.label ~text:"Replace with:"
-      ~xalign:1.0
-      ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) ()
-  in
-  let replace_entry = GEdit.entry
-    ~editable: true
-    ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X)
-    ()
-  in
-  (* let _ =
-     GButton.check_button
-     ~label:"case sensitive"
-     ~active:true
-     ~packing: (find_box#attach ~left:1 ~top:2)
-     ()
-     in
-  *)
-  let find_backwards_check =
-    GButton.check_button
-      ~label:"search backwards"
-      ~active:!search_backward
-      ~packing: (find_box#attach ~left:1 ~top:3)
-      ()
-  in
-  let close_find_button =
-    GButton.button
-      ~label:"Close"
-      ~packing: (find_box#attach ~left:2 ~top:2)
-      ()
-  in
-  let replace_find_button =
-    GButton.button
-      ~label:"Replace and find"
-      ~packing: (find_box#attach ~left:2 ~top:1)
-      ()
-  in
-  let find_again_button =
-    GButton.button
-      ~label:"_Find again"
-      ~packing: (find_box#attach ~left:2 ~top:0)
-      ()
-  in
-  let last_find () =
-    let v = session_notebook#current_term.script in
-    let b = v#buffer in
-    let start,stop =
-      match !last_found with
-	| None -> let i = b#get_iter_at_mark `INSERT in (i,i)
-	| Some(start,stop) ->
-	  let start = b#get_iter_at_mark start
-	  and stop = b#get_iter_at_mark stop
-	  in
-	  b#remove_tag Tags.Script.found ~start ~stop;
-	  last_found:=None;
-	  start,stop
-    in
-    (v,b,start,stop)
+    try dialog#set_logo (GdkPixbuf.from_file (coq_icon ()))
+    with _ -> ()
   in
-  let do_replace () =
-    let v = session_notebook#current_term.script in
-    let b = v#buffer in
-    match !last_found with
-      | None -> ()
-      | Some(start,stop) ->
-	let start = b#get_iter_at_mark start
-	and stop = b#get_iter_at_mark stop
-	in
-	b#delete ~start ~stop;
-	b#insert ~iter:start replace_entry#text;
-	last_found:=None
+  let copyright =
+    "Coq is developed by the Coq Development Team\n\
+     (INRIA - CNRS - LIX - LRI - PPS)"
   in
-  let find_from (v : Undo.undoable_view)
-      (b : GText.buffer) (starti : GText.iter) text =
-    prerr_endline ("Searching for " ^ text);
-    match (if !search_backward then starti#backward_search text
-      else starti#forward_search text)
-    with
-      | None -> ()
-      | Some(start,stop) ->
-	b#apply_tag Tags.Script.found ~start ~stop;
-	let start = `MARK (b#create_mark start)
-	and stop = `MARK (b#create_mark stop)
-	in
-	v#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25
-	  stop;
-	last_found := Some(start,stop)
+  let authors = [
+    "Benjamin Monate";
+    "Jean-Christophe Filliâtre";
+    "Pierre Letouzey";
+    "Claude Marché";
+    "Bruno Barras";
+    "Pierre Corbineau";
+    "Julien Narboux";
+    "Hugo Herbelin";
+    "Enrico Tassi";
+    ]
   in
-  let do_find () =
-    let (v,b,starti,_) = last_find () in
-    find_from v b starti find_entry#text
+  dialog#set_name "CoqIDE";
+  dialog#set_comments "The Coq Integrated Development Environment";
+  dialog#set_website Coq_config.wwwcoq;
+  dialog#set_version Coq_config.version;
+  dialog#set_copyright copyright;
+  dialog#set_authors authors;
+  dialog#show ()
+
+let comment = cb_on_current_term (fun t -> t.script#comment ())
+let uncomment = cb_on_current_term (fun t -> t.script#uncomment ())
+
+let coqtop_arguments sn =
+  let dialog = GWindow.dialog ~title:"Coqtop arguments" () in
+  let coqtop = sn.coqtop in
+  (** Text entry *)
+  let args = Coq.get_arguments coqtop in
+  let text = String.concat " " args in
+  let entry = GEdit.entry ~text ~packing:dialog#vbox#add () in
+  (** Buttons *)
+  let box = dialog#action_area in
+  let ok = GButton.button ~stock:`OK ~packing:box#add () in
+  let ok_cb () =
+    let nargs = CString.split ' ' entry#text in
+    if nargs <> args then
+      let failed = Coq.filter_coq_opts nargs in
+      match failed with
+      | [] ->
+        let () = Coq.set_arguments coqtop nargs in
+        dialog#destroy ()
+      | args ->
+        let args = String.concat " " args in
+        let msg = Printf.sprintf "Invalid arguments: %s" args in
+        let () = sn.messages#clear in
+        sn.messages#push Pp.Error msg
+    else dialog#destroy ()
   in
-  let do_replace_find () =
-    do_replace();
-    do_find()
+  let _ = entry#connect#activate ok_cb in
+  let _ = ok#connect#clicked ok_cb in
+  let cancel = GButton.button ~stock:`CANCEL ~packing:box#add () in
+  let cancel_cb () = dialog#destroy () in
+  let _ = cancel#connect#clicked cancel_cb in
+  dialog#show ()
+
+let coqtop_arguments = cb_on_current_term coqtop_arguments
+
+let show_hide_query_pane sn =
+  let ccw = sn.command in
+  if ccw#visible then ccw#hide else ccw#show
+
+let zoom_fit sn =
+  let script = sn.script in
+  let space = script#misc#allocation.Gtk.width in
+  let cols = script#right_margin_position in
+  let pango_ctx = script#misc#pango_context in
+  let layout = pango_ctx#create_layout in
+  let fsize = Pango.Font.get_size current.text_font in
+  Pango.Layout.set_text layout (String.make cols 'X');
+  let tlen = fst (Pango.Layout.get_pixel_size layout) in
+  Pango.Font.set_size current.text_font
+    (fsize * space / tlen / Pango.scale * Pango.scale);
+  save_pref ();
+  !refresh_editor_hook ()
+
+end
+
+(** Refresh functions *)
+
+let refresh_editor_prefs () =
+  let wrap_mode = if prefs.dynamic_word_wrap then `WORD else `NONE in
+  let show_spaces =
+    if prefs.show_spaces then 0b1001011 (* SPACE, TAB, NBSP, TRAILING *)
+    else 0
   in
-  let close_find () =
-    let (v,b,_,stop) = last_find () in
-    b#place_cursor ~where:stop;
-    find_w#misc#hide();
-    v#coerce#misc#grab_focus()
+  let fd = prefs.text_font in
+  let clr = Tags.color_of_string prefs.background_color
   in
-  to_do_on_page_switch :=
-    (fun i -> if find_w#misc#visible then close_find())::
-    !to_do_on_page_switch;
-  let find_again () =
-    let (v,b,start,_) = last_find () in
-    let start =
-      if !search_backward
-      then start#backward_chars 1
-      else start#forward_chars 1
+  let iter_session sn =
+    (* Editor settings *)
+    sn.script#set_wrap_mode wrap_mode;
+    sn.script#set_show_line_numbers prefs.show_line_number;
+    sn.script#set_auto_indent prefs.auto_indent;
+    sn.script#set_highlight_current_line prefs.highlight_current_line;
+
+    (* Hack to handle missing binding in lablgtk *)
+    let conv = { Gobject.name = "draw-spaces"; Gobject.conv = Gobject.Data.int }
     in
-    find_from v b start find_entry#text
+    Gobject.set conv sn.script#as_widget show_spaces;
+
+    sn.script#set_show_right_margin prefs.show_right_margin;
+    if prefs.show_progress_bar then sn.segment#misc#show () else sn.segment#misc#hide ();
+    sn.script#set_insert_spaces_instead_of_tabs
+      prefs.spaces_instead_of_tabs;
+    sn.script#set_tab_width prefs.tab_length;
+    sn.script#set_auto_complete prefs.auto_complete;
+
+    (* Fonts *)
+    sn.script#misc#modify_font fd;
+    sn.proof#misc#modify_font fd;
+    sn.messages#modify_font fd;
+    sn.command#refresh_font ();
+
+    (* Colors *)
+    sn.script#misc#modify_base [`NORMAL, `COLOR clr];
+    sn.proof#misc#modify_base [`NORMAL, `COLOR clr];
+    sn.messages#misc#modify_base [`NORMAL, `COLOR clr];
+    sn.command#refresh_color ()
+
   in
-  let click_on_backward () =
-    search_backward := not !search_backward
+  List.iter iter_session notebook#pages
+
+let refresh_notebook_pos () =
+  let pos = match prefs.vertical_tabs, prefs.opposite_tabs with
+    | false, false -> `TOP
+    | false, true  -> `BOTTOM
+    | true , false -> `LEFT
+    | true , true  -> `RIGHT
   in
-  let key_find ev =
-    let s = GdkEvent.Key.state ev and k = GdkEvent.Key.keyval ev in
-    if k = GdkKeysyms._Escape then
-      begin
-	let (v,b,_,stop) = last_find () in
-	find_w#misc#hide();
-	v#coerce#misc#grab_focus();
-	true
-      end
-    else if k = GdkKeysyms._Escape then
-      begin
-	close_find();
-	true
-      end
-    else if k = GdkKeysyms._Return ||
-	   List.mem `CONTROL s && k = GdkKeysyms._f then
-      begin
-	find_again ();
-	true
-      end
-    else if List.mem `CONTROL s && k = GdkKeysyms._b then
-      begin
-	find_backwards_check#set_active (not !search_backward);
-	true
-      end
-    else false (* to let default callback execute *)
+  notebook#set_tab_pos pos
+
+(** Wrappers around GAction functions for creating menus *)
+
+let menu = GAction.add_actions
+let item = GAction.add_action
+
+(** Toggle items in menus for printing options *)
+
+let toggle_item = GAction.add_toggle_action
+
+(** Search the first '_' in a label string and return the following
+    character as shortcut, plus the string without the '_' *)
+
+let get_shortcut s =
+  try
+    let n = String.length s in
+    let i = String.index s '_' in
+    let k = String.make 1 s.[i+1] in
+    let s' = (String.sub s 0 i) ^ (String.sub s (i+1) (n-i-1)) in
+    Some k, s'
+  with _ -> None,s
+
+module Opt = Coq.PrintOpt
+
+let toggle_items menu_name l =
+  let f d =
+    let label = d.Opt.label in
+    let k, name = get_shortcut label in
+    let accel = Option.map ((^) prefs.modifier_for_display) k in
+    toggle_item name ~label ?accel ~active:d.Opt.init
+      ~callback:(printopts_callback d.Opt.opts)
+      menu_name
   in
-  let find_f ~backward () =
-    let save_dir = !search_backward in
-    search_backward := backward;
-    find_w#show ();
-    find_w#present ();
-    find_entry#misc#grab_focus ();
-    search_backward := save_dir
+  List.iter f l
+
+(** Create alphabetical menu items with elements in sub-items.
+    [l] is a list of lists, one per initial letter *)
+
+let alpha_items menu_name item_name l =
+  let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
   in
-  let _ = find_again_button#connect#clicked find_again in
-  let _ = close_find_button#connect#clicked close_find in
-  let _ = replace_find_button#connect#clicked do_replace_find in
-  let _ = find_backwards_check#connect#clicked click_on_backward in
-  let _ = find_entry#connect#changed do_find in
-  let _ = find_entry#event#connect#key_press ~callback:key_find in
-  let _ = find_w#event#connect#delete ~callback:(fun _ -> find_w#misc#hide(); true) in
-  (*
-    let search_if = edit_f#add_item "Search _forward"
-    ~key:GdkKeysyms._greater
-    in
-    let search_ib = edit_f#add_item "Search _backward"
-    ~key:GdkKeysyms._less
+  let mk_item text =
+    let text' =
+      let last = String.length text - 1 in
+      if text.[last] = '.'
+      then text ^"\n"
+      else text ^" "
     in
-  *)
-  (*
-    let complete_i = edit_f#add_item "_Complete"
-    ~key:GdkKeysyms._comma
-    ~callback:
-    (do_if_not_computing
-    (fun b ->
-    let v = session_notebook#current_term.analyzed_view
-
-    in v#complete_at_offset
-    ((v#view#buffer#get_iter `SEL_BOUND)#offset)
-    ))
+    let callback _ =
+      on_current_term (fun sn -> sn.buffer#insert_interactive text')
     in
-    complete_i#misc#set_state `INSENSITIVE;
-  *)
-(* end of find/replace mechanism *)
-(* begin Preferences *)
-  let reset_revert_timer () =
-    disconnect_revert_timer ();
-    if !current.global_auto_revert then
-      revert_timer := Some
-	(GMain.Timeout.add ~ms:!current.global_auto_revert_delay
-	   ~callback:
-	   (fun () ->
-	     do_if_not_computing "revert" (sync revert_f) session_notebook#pages;
-	     true))
-  in reset_revert_timer (); (* to enable statup preferences timer *)
-  (* XXX *)
-  let auto_save_f {analyzed_view = av} =
-    (try
-       av#auto_save
-     with _ -> ())
-  in
-
-  let reset_auto_save_timer () =
-    disconnect_auto_save_timer ();
-    if !current.auto_save then
-      auto_save_timer := Some
-	(GMain.Timeout.add ~ms:!current.auto_save_delay
-	   ~callback:
-	   (fun () ->
-	     do_if_not_computing "autosave" (sync auto_save_f) session_notebook#pages;
-	     true))
-  in reset_auto_save_timer (); (* to enable statup preferences timer *)
-(* end Preferences *)
-
-  let do_or_activate f () =
-    do_if_not_computing "do_or_activate"
-      (fun current ->
-        let av = current.analyzed_view in
-        ignore (f av);
-        pop_info ();
-        let msg = match Coq.status !(current.toplvl) with
-        | Interface.Fail (l, str) ->
-          "Oops, problem while fetching coq status."
-        | Interface.Good status ->
-          let path = match status.Interface.status_path with
-          | [] | _ :: [] -> "" (* Drop the topmost level, usually "Top" *)
-          | _ :: l -> " in " ^ String.concat "." l
-          in
-          let name = match status.Interface.status_proofname with
-          | None -> ""
-          | Some n -> ", proving " ^ n
-          in
-          "Ready" ^ path ^ name
-        in
-        push_info msg
-      )
-      [session_notebook#current_term]
-  in
-  let do_if_active f _ =
-    do_if_not_computing "do_if_active"
-      (fun sess -> ignore (f sess.analyzed_view))
-      [session_notebook#current_term] in
-  let match_callback _ =
-    let w = get_current_word () in
-    let cur_ct = !(session_notebook#current_term.toplvl) in
-    try
-      match Coq.mkcases cur_ct w with
-        | Interface.Fail _ -> raise Not_found
-        | Interface.Good cases ->
-          let print_branch c l =
-	    Format.fprintf c " | @[<hov 1>%a@]=> _@\n"
-	      (print_list (fun c s -> Format.fprintf c "%s@ " s)) l
-          in
-          let b = Buffer.create 1024 in
-          let fmt = Format.formatter_of_buffer b in
-          Format.fprintf fmt "@[match var with@\n%aend@]@."
-            (print_list print_branch) cases;
-          let s = Buffer.contents b in
-          prerr_endline s;
-          let {script = view } = session_notebook#current_term in
-          ignore (view#buffer#delete_selection ());
-          let m = view#buffer#create_mark
-            (view#buffer#get_iter `INSERT)
-          in
-          if view#buffer#insert_interactive s then
-            let i = view#buffer#get_iter (`MARK m) in
-            let _ = i#nocopy#forward_chars 9 in
-            view#buffer#place_cursor ~where:i;
-            view#buffer#move_mark ~where:(i#backward_chars 3)
-              `SEL_BOUND
-    with Not_found -> flash_info "Not an inductive type"
-  in
-(* External command callback *)
-  let compile_f _ =
-    let v = session_notebook#current_term in
-    let av = v.analyzed_view in
-    save_f ();
-    match av#filename with
-      | None ->
-	flash_info "Active buffer has no name"
-      | Some f ->
-	let cmd = !current.cmd_coqc ^ " -I "
-	  ^ (Filename.quote (Filename.dirname f))
-	  ^ " " ^ (Filename.quote f) in
-	let s,res = run_command av#insert_message cmd in
-	if s = Unix.WEXITED 0 then
-	  flash_info (f ^ " successfully compiled")
-	else begin
-	  flash_info (f ^ " failed to compile");
-	  av#process_until_end_or_error;
-	  av#insert_message "Compilation output:\n";
-	  av#insert_message res
-	end
-  in
-  let make_f _ =
-    let v = session_notebook#current_term in
-    let av = v.analyzed_view in
-    match av#filename with
-      | None ->
-	flash_info "Cannot make: this buffer has no name"
-      | Some f ->
-	let cmd = local_cd f ^ !current.cmd_make in
-
-	(*
-	  save_f ();
-	*)
-	av#insert_message "Command output:\n";
-	let s,res = run_command av#insert_message cmd in
-	last_make := res;
-	last_make_index := 0;
-	flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+    item (item_name^" "^(no_under text)) ~label:text ~callback menu_name
   in
-  let next_error _ =
-    try
-      let file,line,start,stop,error_msg = search_next_error () in
-      do_load file;
-      let v = session_notebook#current_term in
-      let av = v.analyzed_view in
-      let input_buffer = v.script#buffer in
-      (*
-	let init = input_buffer#start_iter in
-	let i = init#forward_lines (line-1) in
-      *)
-      (*
-	let convert_pos = byte_offset_to_char_offset phrase in
-	let start = convert_pos start in
-	let stop = convert_pos stop in
-      *)
-      (*
-	let starti = i#forward_chars start in
-	let stopi = i#forward_chars stop in
-      *)
-      let starti = input_buffer#get_iter_at_byte ~line:(line-1) start in
-      let stopi = input_buffer#get_iter_at_byte ~line:(line-1) stop in
-      input_buffer#apply_tag Tags.Script.error
-	~start:starti
-	~stop:stopi;
-      input_buffer#place_cursor ~where:starti;
-      av#set_message error_msg;
-      v.script#misc#grab_focus ()
-    with Not_found ->
-      last_make_index := 0;
-      let v = session_notebook#current_term in
-      let av = v.analyzed_view in
-      av#set_message "No more errors.\n"
+  let mk_items = function
+    | [] -> ()
+    | [s] -> mk_item s
+    | s::_ as ll ->
+      let name = item_name^" "^(String.make 1 s.[0]) in
+      let label = "_@..." in label.[1] <- s.[0];
+      item name ~label menu_name;
+      List.iter mk_item ll
   in
-  let coq_makefile_f _ =
-    let v = session_notebook#current_term in
-    let av = v.analyzed_view in
-    match av#filename with
-      | None ->
-	flash_info "Cannot make makefile: this buffer has no name"
-      | Some f ->
-	let cmd = local_cd f ^ !current.cmd_coqmakefile in
-	let s,res = run_command av#insert_message cmd in
-	flash_info
-	  (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed")
+  List.iter mk_items l
+
+(** Create a menu item that will insert a given text,
+    and select the zone given by (offset,len).
+    The first word in the text is used as item keyword.
+    Caveat: the offset is now from the start of the text. *)
+
+let template_item (text, offset, len, key) =
+  let modifier = prefs.modifier_for_templates in
+  let idx = String.index text ' ' in
+  let name = String.sub text 0 idx in
+  let label = "_"^name^" __" in
+  let negoffset = String.length text - offset - len in
+  let callback sn =
+    let b = sn.buffer in
+    if b#insert_interactive text then begin
+      let iter = b#get_iter_at_mark `INSERT in
+      ignore (iter#nocopy#backward_chars negoffset);
+      b#move_mark `INSERT ~where:iter;
+      ignore (iter#nocopy#backward_chars len);
+      b#move_mark `SEL_BOUND ~where:iter;
+    end
   in
+  item name ~label ~callback:(cb_on_current_term callback) ~accel:(modifier^key)
 
-  let file_actions = GAction.action_group ~name:"File" () in
-  let edit_actions = GAction.action_group ~name:"Edit" () in
-  let view_actions = GAction.action_group ~name:"View" () in
-  let export_actions = GAction.action_group ~name:"Export" () in
-  let navigation_actions = GAction.action_group ~name:"Navigation" () in
-  let tactics_actions = GAction.action_group ~name:"Tactics" () in
-  let templates_actions = GAction.action_group ~name:"Templates" () in
-  let queries_actions = GAction.action_group ~name:"Queries" () in
-  let compile_actions = GAction.action_group ~name:"Compile" () in
-  let windows_actions = GAction.action_group ~name:"Windows" () in
-  let help_actions = GAction.action_group ~name:"Help" () in
-  let add_gen_actions menu_name act_grp l =
-    let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x) in
-    let add_simple_template menu_name act_grp text =
-      let text' =
-	let l = String.length text - 1 in
-	if String.get text l = '.'
-	then text ^"\n"
-	else text ^" "
-      in
-      GAction.add_action (menu_name^" "^(no_under text)) ~label:text
-	~callback:(fun _ -> let {script = view } = session_notebook#current_term in
-			    ignore (view#buffer#insert_interactive text')) act_grp
-    in
-    List.iter (function
-      | [] -> ()
-      | [s] -> add_simple_template menu_name act_grp s
-      | s::_ as ll -> let label = "_@..." in label.[1] <- s.[0];
-		      GAction.add_action (menu_name^" "^(String.make 1 s.[0])) ~label act_grp;
-		      List.iter (add_simple_template menu_name act_grp) ll
-    ) l
-  in
-  let tactic_shortcut s sc = GAction.add_action s ~label:("_"^s)
-    ~accel:(!current.modifier_for_tactics^sc)
-    ~callback:(do_if_active (fun a -> a#insert_command
-			       ("progress "^s^".") (s^"."))) in
-  let query_callback command _ =
-    let word = get_current_word () in
-    if not (word = "") then
-      let term = session_notebook#current_term in
-      let query = command ^ " " ^ word ^ "." in
-      term.message_view#buffer#set_text "";
-      term.analyzed_view#raw_coq_query query
-  in
-  let query_shortcut s accel =
-    GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s)
-  in
-  let add_complex_template (name, label, text, offset, len, key) =
-    (* Templates/Lemma *)
-    let callback _ =
-      let {script = view } = session_notebook#current_term in
-      if view#buffer#insert_interactive text then begin
-	let iter = view#buffer#get_iter_at_mark `INSERT in
-	ignore (iter#nocopy#backward_chars offset);
-	view#buffer#move_mark `INSERT ~where:iter;
-	ignore (iter#nocopy#backward_chars len);
-	view#buffer#move_mark `SEL_BOUND ~where:iter;
-      end in
-      match key with
-	|Some ac -> GAction.add_action name ~label ~callback ~accel:(!current.modifier_for_templates^ac)
-	|None -> GAction.add_action name ~label ~callback ?accel:None
+let emit_to_focus window sgn =
+  let focussed_widget = GtkWindow.Window.get_focus window#as_window in
+  let obj = Gobject.unsafe_cast focussed_widget in
+  try GtkSignal.emit_unit obj ~sgn with _ -> ()
+
+(** {2 Creation of the main coqide window } *)
+
+let build_ui () =
+  let w = GWindow.window
+    ~wm_class:"CoqIde" ~wm_name:"CoqIde"
+    ~allow_grow:true ~allow_shrink:true
+    ~width:prefs.window_width ~height:prefs.window_height
+    ~title:"CoqIde" ()
   in
-  let detach_view _ =
-    (* Open a separate window containing the current buffer *)
-    let trm = session_notebook#current_term in
-    let w = GWindow.window ~show:true
-      ~width:(!current.window_width*2/3)
-      ~height:(!current.window_height*2/3)
-      ~position:`CENTER
-      ~title:(if trm.filename = "" then "*scratch*" else trm.filename)
-      ()
-    in
-    let sb = GBin.scrolled_window ~packing:w#add ()
-    in
-    let nv = GText.view ~buffer:trm.script#buffer ~packing:sb#add ()
-    in
-    nv#misc#modify_font !current.text_font;
-    (* If the buffer in the main window is closed, destroy this detached view *)
-    ignore (trm.script#connect#destroy ~callback:w#destroy)
+  let () =
+    try w#set_icon (Some (GdkPixbuf.from_file (MiscMenu.coq_icon ())))
+    with _ -> ()
   in
-    GAction.add_actions file_actions [
-      GAction.add_action "File" ~label:"_File";
-      GAction.add_action "New" ~callback:new_f ~stock:`NEW;
-      GAction.add_action "Open" ~callback:load_f ~stock:`OPEN;
-      GAction.add_action "Save" ~callback:save_f ~stock:`SAVE ~tooltip:"Save current buffer";
-      GAction.add_action "Save as" ~label:"S_ave as" ~callback:saveas_f ~stock:`SAVE_AS;
-      GAction.add_action "Save all" ~label:"Sa_ve all" ~callback:(fun _ -> saveall_f ());
-      GAction.add_action "Revert all buffers" ~label:"_Revert all buffers" ~callback:(fun _ -> List.iter revert_f session_notebook#pages) ~stock:`REVERT_TO_SAVED;
-      GAction.add_action "Close buffer" ~label:"_Close buffer" ~callback:(fun _ -> remove_current_view_page ()) ~stock:`CLOSE ~tooltip:"Close current buffer";
-      GAction.add_action "Print..." ~label:"_Print..." ~callback:(fun _ -> do_print session_notebook#current_term) ~stock:`PRINT ~accel:"<Ctrl>p";
-      GAction.add_action "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l"
-	~callback:(fun _ -> force_retag
-                     session_notebook#current_term.script#buffer;
-		     session_notebook#current_term.analyzed_view#recenter_insert)
-	~stock:`REFRESH;
-      GAction.add_action "Quit" ~callback:quit_f ~stock:`QUIT;
-    ];
-    GAction.add_actions export_actions [
-      GAction.add_action "Export to" ~label:"E_xport to";
-      GAction.add_action "Html" ~label:"_Html" ~callback:(export_f "html");
-      GAction.add_action "Latex" ~label:"_LaTeX" ~callback:(export_f "latex");
-      GAction.add_action "Dvi" ~label:"_Dvi" ~callback:(export_f "dvi");
-      GAction.add_action "Pdf" ~label:"_Pdf" ~callback:(export_f "pdf");
-      GAction.add_action "Ps" ~label:"_Ps" ~callback:(export_f "ps");
-    ];
-    GAction.add_actions edit_actions [
-      GAction.add_action "Edit" ~label:"_Edit";
-      GAction.add_action "Undo" ~accel:"<Ctrl>u"
-	~callback:(fun _ -> do_if_not_computing "undo"
-		     (fun sess ->
-			ignore (sess.analyzed_view#without_auto_complete
-				  (fun () -> session_notebook#current_term.script#undo) ()))
-		     [session_notebook#current_term]) ~stock:`UNDO;
-      GAction.add_action "Clear Undo Stack" ~label:"_Clear Undo Stack"
-	~callback:(fun _ -> ignore session_notebook#current_term.script#clear_undo);
-      GAction.add_action "Cut" ~callback:(fun _ -> GtkSignal.emit_unit
-					    (get_active_view_for_cp ())
-					    ~sgn:GtkText.View.S.cut_clipboard
-					 ) ~stock:`CUT;
-      GAction.add_action "Copy" ~callback:(fun _ -> GtkSignal.emit_unit
-             (get_active_view_for_cp ())
-             ~sgn:GtkText.View.S.copy_clipboard) ~stock:`COPY;
-      GAction.add_action "Paste" ~callback:(fun _ ->
-             try GtkSignal.emit_unit
-                   session_notebook#current_term.script#as_view
-                   ~sgn:GtkText.View.S.paste_clipboard
-             with _ -> prerr_endline "EMIT PASTE FAILED") ~stock:`PASTE;
-      GAction.add_action "Find in buffer" ~label:"_Find in buffer" ~callback:(fun _ -> find_f ~backward:false ()) ~stock:`FIND;
-      GAction.add_action "Find backwards" ~label:"Find _backwards" ~callback:(fun _ -> find_f ~backward:true ()) ~accel:"<Ctrl>b";
-      GAction.add_action "Complete Word" ~label:"Complete Word" ~callback:(fun _ ->
-	     ignore (
-	       let av = session_notebook#current_term.analyzed_view in
-	       av#complete_at_offset (av#get_insert)#offset
-	     )) ~accel:"<Ctrl>slash";
-      GAction.add_action "External editor" ~label:"External editor" ~callback:(fun _ ->
-	let av = session_notebook#current_term.analyzed_view in
-	match av#filename with
-	  | None -> warning "Call to external editor available only on named files"
-	  | Some f ->
-	    save_f ();
-	    let com = Minilib.subst_command_placeholder !current.cmd_editor (Filename.quote f) in
-	    let _ = run_command av#insert_message com in
-	    av#revert) ~stock:`EDIT;
-      GAction.add_action "Preferences" ~callback:(fun _ ->
-	begin
-	  try configure ~apply:update_notebook_pos ()
+  let _ = w#event#connect#delete ~callback:(fun _ -> File.quit (); true) in
+  let _ = set_drag w#drag in
+
+  let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
+
+  let file_menu = GAction.action_group ~name:"File" () in
+  let edit_menu = GAction.action_group ~name:"Edit" () in
+  let view_menu = GAction.action_group ~name:"View" () in
+  let export_menu = GAction.action_group ~name:"Export" () in
+  let navigation_menu = GAction.action_group ~name:"Navigation" () in
+  let tactics_menu = GAction.action_group ~name:"Tactics" () in
+  let templates_menu = GAction.action_group ~name:"Templates" () in
+  let tools_menu = GAction.action_group ~name:"Tools" () in
+  let queries_menu = GAction.action_group ~name:"Queries" () in
+  let compile_menu = GAction.action_group ~name:"Compile" () in
+  let windows_menu = GAction.action_group ~name:"Windows" () in
+  let help_menu = GAction.action_group ~name:"Help" () in
+  let all_menus = [
+    file_menu; edit_menu; view_menu; export_menu; navigation_menu; tactics_menu;
+    templates_menu; tools_menu; queries_menu; compile_menu; windows_menu;
+    help_menu; ] in
+
+  menu file_menu [
+    item "File" ~label:"_File";
+    item "New" ~callback:File.newfile ~stock:`NEW;
+    item "Open" ~callback:File.load ~stock:`OPEN;
+    item "Save" ~callback:File.save ~stock:`SAVE ~tooltip:"Save current buffer";
+    item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:File.saveas;
+    item "Save all" ~label:"Sa_ve all" ~callback:File.saveall;
+    item "Revert all buffers" ~label:"_Revert all buffers"
+      ~callback:File.revert_all ~stock:`REVERT_TO_SAVED;
+    item "Close buffer" ~label:"_Close buffer" ~stock:`CLOSE
+      ~callback:File.close_buffer ~tooltip:"Close current buffer";
+    item "Print..." ~label:"_Print..."
+      ~callback:File.print ~stock:`PRINT ~accel:"<Ctrl>p";
+    item "Rehighlight" ~label:"Reh_ighlight" ~accel:"<Ctrl>l"
+      ~callback:File.highlight ~stock:`REFRESH;
+    item "Quit" ~stock:`QUIT ~callback:File.quit;
+  ];
+
+  menu export_menu [
+    item "Export to" ~label:"E_xport to";
+    item "Html" ~label:"_Html" ~callback:(File.export "html");
+    item "Latex" ~label:"_LaTeX" ~callback:(File.export "latex");
+    item "Dvi" ~label:"_Dvi" ~callback:(File.export "dvi");
+    item "Pdf" ~label:"_Pdf" ~callback:(File.export "pdf");
+    item "Ps" ~label:"_Ps" ~callback:(File.export "ps");
+  ];
+
+  menu edit_menu [
+    item "Edit" ~label:"_Edit";
+    item "Undo" ~accel:"<Ctrl>u" ~stock:`UNDO
+      ~callback:(cb_on_current_term (fun t -> t.script#undo ()));
+    item "Redo" ~stock:`REDO
+      ~callback:(cb_on_current_term (fun t -> t.script#redo ()));
+    item "Cut" ~stock:`CUT
+      ~callback:(fun _ -> emit_to_focus w GtkText.View.S.cut_clipboard);
+    item "Copy" ~stock:`COPY
+      ~callback:(fun _ -> emit_to_focus w GtkText.View.S.copy_clipboard);
+    item "Paste" ~stock:`PASTE
+      ~callback:(fun _ -> emit_to_focus w GtkText.View.S.paste_clipboard);
+    item "Find" ~stock:`FIND ~label:"Find / Replace"
+      ~callback:(cb_on_current_term (fun t -> t.finder#show ()));
+    item "Find Next" ~label:"Find _Next" ~stock:`GO_DOWN ~accel:"F3"
+      ~callback:(cb_on_current_term (fun t -> t.finder#find_forward ()));
+    item "Find Previous" ~label:"Find _Previous" ~stock:`GO_UP
+      ~accel:"<Shift>F3"
+      ~callback:(cb_on_current_term (fun t -> t.finder#find_backward ()));
+    item "Complete Word" ~label:"Complete Word" ~accel:"<Ctrl>slash"
+      ~callback:(fun _ -> ());
+    item "External editor" ~label:"External editor" ~stock:`EDIT
+      ~callback:External.editor;
+    item "Preferences" ~accel:"<Ctrl>comma" ~stock:`PREFERENCES
+      ~callback:(fun _ ->
+        begin
+	  try Preferences.configure ~apply:refresh_notebook_pos ()
 	  with _ -> flash_info "Cannot save preferences"
-	end;
-	reset_revert_timer ()) ~accel:"<Ctrl>comma" ~stock:`PREFERENCES;
-      (* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ];
-    GAction.add_actions view_actions [
-      GAction.add_action "View" ~label:"_View";
-      GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("<ALT>Left") ~stock:`GO_BACK
-        ~callback:(fun _ -> session_notebook#previous_page ());
-      GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("<ALT>Right") ~stock:`GO_FORWARD
-        ~callback:(fun _ -> session_notebook#next_page ());
-      GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar"
-        ~active:(!current.show_toolbar) ~callback:
-        (fun _ -> !current.show_toolbar <- not !current.show_toolbar;
-           !refresh_toolbar_hook ());
-      GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane"
-        ~callback:(fun _ -> let ccw = session_notebook#current_term.command in
-                     if ccw#frame#misc#visible
-                     then ccw#frame#misc#hide ()
-                     else ccw#frame#misc#show ())
-        ~accel:"Escape";
-    ];
-    List.iter
-      (fun (opts,name,label,key,dflt) ->
-         GAction.add_toggle_action name ~active:dflt ~label
-           ~accel:(!current.modifier_for_display^key)
-          ~callback:(fun v -> do_or_activate (fun a ->
-            let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
-            a#show_goals) ()) view_actions)
-      print_items;
-    GAction.add_actions navigation_actions [
-      GAction.add_action "Navigation" ~label:"_Navigation";
-      GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN
-	~callback:(fun _ -> do_or_activate (fun a -> a#process_next_phrase true) ())
-	~tooltip:"Forward one command" ~accel:(!current.modifier_for_navigation^"Down");
-      GAction.add_action "Backward" ~label:"_Backward" ~stock:`GO_UP
-	~callback:(fun _ -> do_or_activate (fun a -> a#undo_last_step) ())
-	~tooltip:"Backward one command" ~accel:(!current.modifier_for_navigation^"Up");
-      GAction.add_action "Go to" ~label:"_Go to" ~stock:`JUMP_TO
-	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_insert) ())
-	~tooltip:"Go to cursor" ~accel:(!current.modifier_for_navigation^"Right");
-      GAction.add_action "Start" ~label:"_Start" ~stock:`GOTO_TOP
-	~callback:(fun _ -> force_reset_initial ())
-	~tooltip:"Restart coq" ~accel:(!current.modifier_for_navigation^"Home");
-      GAction.add_action "End" ~label:"_End" ~stock:`GOTO_BOTTOM
-	~callback:(fun _ -> do_or_activate (fun a -> a#process_until_end_or_error) ())
-	~tooltip:"Go to end" ~accel:(!current.modifier_for_navigation^"End");
-      GAction.add_action "Interrupt" ~label:"_Interrupt" ~stock:`STOP
-	~callback:(fun _ -> break ()) ~tooltip:"Interrupt computations"
-	~accel:(!current.modifier_for_navigation^"Break");
-      GAction.add_action "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
-	~callback:(fun _ -> let sess = session_notebook#current_term in
-		     toggle_proof_visibility sess.script#buffer
+        end;
+        reset_revert_timer ());
+  ];
+
+  menu view_menu [
+    item "View" ~label:"_View";
+    item "Previous tab" ~label:"_Previous tab" ~accel:"<Alt>Left"
+      ~stock:`GO_BACK
+      ~callback:(fun _ -> notebook#previous_page ());
+    item "Next tab" ~label:"_Next tab" ~accel:"<Alt>Right"
+      ~stock:`GO_FORWARD
+      ~callback:(fun _ -> notebook#next_page ());
+    item "Zoom in" ~label:"_Zoom in" ~accel:("<Control>plus")
+        ~stock:`ZOOM_IN ~callback:(fun _ ->
+          Pango.Font.set_size current.text_font
+            (Pango.Font.get_size current.text_font + Pango.scale);
+          save_pref ();
+          !refresh_editor_hook ());
+    item "Zoom out" ~label:"_Zoom out" ~accel:("<Control>minus")
+        ~stock:`ZOOM_OUT ~callback:(fun _ ->
+          Pango.Font.set_size current.text_font
+            (Pango.Font.get_size current.text_font - Pango.scale);
+          save_pref ();
+          !refresh_editor_hook ());
+    item "Zoom fit" ~label:"_Zoom fit" ~accel:("<Control>0")
+        ~stock:`ZOOM_FIT ~callback:(cb_on_current_term MiscMenu.zoom_fit);
+    toggle_item "Show Toolbar" ~label:"Show _Toolbar"
+      ~active:(prefs.show_toolbar)
+      ~callback:(fun _ ->
+        prefs.show_toolbar <- not prefs.show_toolbar;
+        !refresh_toolbar_hook ());
+    item "Query Pane" ~label:"_Query Pane"
+      ~accel:"F1"
+      ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane)
+  ];
+  toggle_items view_menu Coq.PrintOpt.bool_items;
+
+  menu navigation_menu [
+    item "Navigation" ~label:"_Navigation";
+    item "Forward" ~label:"_Forward" ~stock:`GO_DOWN ~callback:Nav.forward_one
+      ~tooltip:"Forward one command"
+      ~accel:(prefs.modifier_for_navigation^"Down");
+    item "Backward" ~label:"_Backward" ~stock:`GO_UP ~callback:Nav.backward_one
+      ~tooltip:"Backward one command"
+      ~accel:(prefs.modifier_for_navigation^"Up");
+    item "Go to" ~label:"_Go to" ~stock:`JUMP_TO ~callback:Nav.goto
+      ~tooltip:"Go to cursor"
+      ~accel:(prefs.modifier_for_navigation^"Right");
+    item "Start" ~label:"_Start" ~stock:`GOTO_TOP ~callback:Nav.restart
+      ~tooltip:"Restart coq"
+      ~accel:(prefs.modifier_for_navigation^"Home");
+    item "End" ~label:"_End" ~stock:`GOTO_BOTTOM  ~callback:Nav.goto_end
+      ~tooltip:"Go to end"
+      ~accel:(prefs.modifier_for_navigation^"End");
+    item "Interrupt" ~label:"_Interrupt" ~stock:`STOP ~callback:Nav.interrupt
+      ~tooltip:"Interrupt computations"
+      ~accel:(prefs.modifier_for_navigation^"Break");
+(* wait for this available in GtkSourceView !
+      item "Hide" ~label:"_Hide" ~stock:`MISSING_IMAGE
+	~callback:(fun _ -> let sess = notebook#current_term in
+		     toggle_proof_visibility sess.buffer
 		       sess.analyzed_view#get_insert) ~tooltip:"Hide proof"
-	~accel:(!current.modifier_for_navigation^"h");
-      GAction.add_action "Previous" ~label:"_Previous" ~stock:`GO_BACK
-	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_prev_occ_of_cur_word) ())
-	~tooltip:"Previous occurence" ~accel:(!current.modifier_for_navigation^"less");
-      GAction.add_action "Next" ~label:"_Next" ~stock:`GO_FORWARD
-	~callback:(fun _ -> do_or_activate (fun a -> a#go_to_next_occ_of_cur_word) ())
-	~tooltip:"Next occurence" ~accel:(!current.modifier_for_navigation^"greater");
-    ];
-    GAction.add_actions tactics_actions [
-      GAction.add_action "Try Tactics" ~label:"_Try Tactics";
-      GAction.add_action "Wizard" ~tooltip:"Proof Wizard" ~label:"<Proof Wizard>"
-	~stock:`DIALOG_INFO ~callback:(do_if_active (fun a -> a#tactic_wizard
-						       !current.automatic_tactics))
-	~accel:(!current.modifier_for_tactics^"dollar");
-      tactic_shortcut "auto" "a";
-      tactic_shortcut "auto with *" "asterisk";
-      tactic_shortcut "eauto" "e";
-      tactic_shortcut "eauto with *" "ampersand";
-      tactic_shortcut "intuition" "i";
-      tactic_shortcut "omega" "o";
-      tactic_shortcut "simpl" "s";
-      tactic_shortcut "tauto" "p";
-      tactic_shortcut "trivial" "v";
-    ];
-    add_gen_actions "Tactic" tactics_actions Coq_commands.tactics;
-    GAction.add_actions templates_actions [
-      GAction.add_action "Templates" ~label:"Te_mplates";
-      add_complex_template
-	("Lemma", "_Lemma __", "Lemma new_lemma : .\nIdeproof.\n\nSave.\n",
-	 19, 9, Some "L");
-      add_complex_template
-	("Theorem", "_Theorem __", "Theorem new_theorem : .\nIdeproof.\n\nSave.\n",
-	 19, 11, Some "T");
-      add_complex_template
-	("Definition", "_Definition __", "Definition ident := .\n",
-	 6, 5, Some "D");
-      add_complex_template
-	("Inductive", "_Inductive __", "Inductive ident : :=\n  | : .\n",
-	 14, 5, Some "I");
-      add_complex_template
-	("Fixpoint", "_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n",
-	 29, 5, Some "F");
-      add_complex_template ("Scheme", "_Scheme __",
-			    "Scheme new_scheme := Induction for _ Sort _\
-\nwith _ := Induction for _ Sort _.\n",61,10, Some "S");
-      GAction.add_action "match" ~label:"match ..." ~callback:match_callback
-	~accel:(!current.modifier_for_templates^"C");
-    ];
-    add_gen_actions "Template" templates_actions Coq_commands.commands;
-    GAction.add_actions queries_actions [
-      GAction.add_action "Queries" ~label:"_Queries";
-      query_shortcut "SearchAbout" (Some "F2");
-      query_shortcut "Check" (Some "F3");
-      query_shortcut "Print" (Some "F4");
-      query_shortcut "About" (Some "F5");
-      query_shortcut "Locate" None;
-      query_shortcut "Whelp Locate" None;
-    ];
-    GAction.add_actions compile_actions [
-      GAction.add_action "Compile" ~label:"_Compile";
-      GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f;
-      GAction.add_action "Make" ~label:"_Make" ~callback:make_f ~accel:"F6";
-      GAction.add_action "Next error" ~label:"_Next error" ~callback:next_error
-	~accel:"F7";
-      GAction.add_action "Make makefile" ~label:"Make makefile" ~callback:coq_makefile_f;
-    ];
-    GAction.add_actions windows_actions [
-      GAction.add_action "Windows" ~label:"_Windows";
-      GAction.add_action "Detach View" ~label:"Detach _View" ~callback:detach_view
-    ];
-    GAction.add_actions help_actions [
-      GAction.add_action "Help" ~label:"_Help";
-      GAction.add_action "Browse Coq Manual" ~label:"Browse Coq _Manual"
-	~callback:(fun _ ->
-		     let av = session_notebook#current_term.analyzed_view in
-		       browse av#insert_message (doc_url ()));
-      GAction.add_action "Browse Coq Library" ~label:"Browse Coq _Library"
-	~callback:(fun _ ->
-		     let av = session_notebook#current_term.analyzed_view in
-		       browse av#insert_message !current.library_url);
-      GAction.add_action "Help for keyword" ~label:"Help for _keyword"
-	~callback:(fun _ -> let av = session_notebook#current_term.analyzed_view in
-		     av#help_for_keyword ()) ~stock:`HELP;
-      GAction.add_action "About Coq" ~label:"_About" ~stock:`ABOUT;
-    ];
-    Coqide_ui.init ();
-    Coqide_ui.ui_m#insert_action_group file_actions 0;
-    Coqide_ui.ui_m#insert_action_group export_actions 0;
-    Coqide_ui.ui_m#insert_action_group edit_actions 0;
-    Coqide_ui.ui_m#insert_action_group view_actions 0;
-    Coqide_ui.ui_m#insert_action_group navigation_actions 0;
-    Coqide_ui.ui_m#insert_action_group tactics_actions 0;
-    Coqide_ui.ui_m#insert_action_group templates_actions 0;
-    Coqide_ui.ui_m#insert_action_group queries_actions 0;
-    Coqide_ui.ui_m#insert_action_group compile_actions 0;
-    Coqide_ui.ui_m#insert_action_group windows_actions 0;
-    Coqide_ui.ui_m#insert_action_group help_actions 0;
-    w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
-    GtkMain.Rc.parse_string "gtk-can-change-accels = 1";
-    if Coq_config.gtk_platform <> `QUARTZ
-    then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
-    let tbar = GtkButton.Toolbar.cast ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
-    in let () = GtkButton.Toolbar.set ~orientation:`HORIZONTAL ~style:`ICONS
-	~tooltips:true tbar in
-    let toolbar = new GObj.widget tbar in
-    vbox#pack toolbar;
-
-    ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true));
-
-  (* The vertical Separator between Scripts and Goals *)
-  vbox#pack ~expand:true session_notebook#coerce;
-  update_notebook_pos ();
-  let nb = session_notebook in
-  let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
-  lower_hbox#pack ~expand:true status#coerce;
-  let search_lbl = GMisc.label ~text:"Search:"
-    ~show:false
-    ~packing:(lower_hbox#pack ~expand:false) ()
+	~accel:(prefs.modifier_for_navigation^"h");*)
+    item "Previous" ~label:"_Previous" ~stock:`GO_BACK
+      ~callback:Nav.previous_occ
+      ~tooltip:"Previous occurence"
+      ~accel:(prefs.modifier_for_navigation^"less");
+    item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ
+      ~tooltip:"Next occurence"
+      ~accel:(prefs.modifier_for_navigation^"greater");
+    item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document
+      ~tooltip:"Fully check the document" 
+      ~accel:(current.modifier_for_navigation^"f"); 
+  ];
+
+  let tacitem s sc =
+    item s ~label:("_"^s)
+      ~accel:(prefs.modifier_for_tactics^sc)
+      ~callback:(tactic_wizard_callback [s])
+  in
+  menu tactics_menu [
+    item "Try Tactics" ~label:"_Try Tactics";
+    item "Wizard" ~label:"<Proof Wizard>" ~stock:`DIALOG_INFO
+      ~tooltip:"Proof Wizard" ~accel:(prefs.modifier_for_tactics^"dollar")
+      ~callback:(tactic_wizard_callback prefs.automatic_tactics);
+    tacitem "auto" "a";
+    tacitem "auto with *" "asterisk";
+    tacitem "eauto" "e";
+    tacitem "eauto with *" "ampersand";
+    tacitem "intuition" "i";
+    tacitem "omega" "o";
+    tacitem "simpl" "s";
+    tacitem "tauto" "p";
+    tacitem "trivial" "v";
+  ];
+  alpha_items tactics_menu "Tactic" Coq_commands.tactics;
+
+  menu templates_menu [
+    item "Templates" ~label:"Te_mplates";
+    template_item ("Lemma new_lemma : .\nProof.\n\nSave.\n", 6,9, "L");
+    template_item ("Theorem new_theorem : .\nProof.\n\nSave.\n", 8,11, "T");
+    template_item ("Definition ident := .\n", 11,5, "E");
+    template_item ("Inductive ident : :=\n  | : .\n", 10,5, "I");
+    template_item ("Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 9,5, "F");
+    template_item ("Scheme new_scheme := Induction for _ Sort _\n" ^
+                   "with _ := Induction for _ Sort _.\n", 7,10, "S");
+    item "match" ~label:"match ..." ~accel:(prefs.modifier_for_templates^"C")
+      ~callback:match_callback
+  ];
+  alpha_items templates_menu "Template" Coq_commands.commands;
+
+  let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in
+  menu queries_menu [
+    item "Queries" ~label:"_Queries";
+    qitem "Search" (Some "F2");
+    qitem "Check" (Some "F3");
+    qitem "Print" (Some "F4");
+    qitem "About" (Some "F5");
+    qitem "Locate" None;
+    qitem "Print Assumptions" None;
+    qitem "Whelp Locate" None;
+  ];
+
+  menu tools_menu [
+    item "Tools" ~label:"_Tools";
+    item "Comment" ~label:"_Comment" ~accel:"<CTRL>D"
+      ~callback:MiscMenu.comment;
+    item "Uncomment" ~label:"_Uncomment" ~accel:"<CTRL><SHIFT>D"
+      ~callback:MiscMenu.uncomment;
+    item "Coqtop arguments" ~label:"Coqtop _arguments"
+      ~callback:MiscMenu.coqtop_arguments;
+  ];
+
+  menu compile_menu [
+    item "Compile" ~label:"_Compile";
+    item "Compile buffer" ~label:"_Compile buffer" ~callback:External.compile;
+    item "Make" ~label:"_Make" ~accel:"F6"
+      ~callback:External.make;
+    item "Next error" ~label:"_Next error" ~accel:"F7"
+      ~callback:External.next_error;
+    item "Make makefile" ~label:"Make makefile" ~callback:External.coq_makefile;
+  ];
+
+  menu windows_menu [
+    item "Windows" ~label:"_Windows";
+    item "Detach View" ~label:"Detach _View" ~callback:MiscMenu.detach_view
+  ];
+
+  menu help_menu [
+    item "Help" ~label:"_Help";
+    item "Browse Coq Manual" ~label:"Browse Coq _Manual"
+      ~callback:(fun _ ->
+        browse notebook#current_term.messages#add (doc_url ()));
+    item "Browse Coq Library" ~label:"Browse Coq _Library"
+      ~callback:(fun _ ->
+        browse notebook#current_term.messages#add prefs.library_url);
+    item "Help for keyword" ~label:"Help for _keyword" ~stock:`HELP
+      ~callback:(fun _ -> on_current_term (fun sn ->
+        browse_keyword sn.messages#add (get_current_word sn)));
+    item "Help for μPG mode" ~label:"Help for μPG mode"
+      ~callback:(fun _ -> on_current_term (fun sn ->
+         sn.messages#clear;
+         sn.messages#add (NanoPG.get_documentation ())));
+    item "About Coq" ~label:"_About" ~stock:`ABOUT
+      ~callback:MiscMenu.about
+  ];
+
+  Coqide_ui.init ();
+  Coqide_ui.ui_m#insert_action_group file_menu 0;
+  Coqide_ui.ui_m#insert_action_group export_menu 0;
+  Coqide_ui.ui_m#insert_action_group edit_menu 0;
+  Coqide_ui.ui_m#insert_action_group view_menu 0;
+  Coqide_ui.ui_m#insert_action_group navigation_menu 0;
+  Coqide_ui.ui_m#insert_action_group tactics_menu 0;
+  Coqide_ui.ui_m#insert_action_group templates_menu 0;
+  Coqide_ui.ui_m#insert_action_group tools_menu 0;
+  Coqide_ui.ui_m#insert_action_group queries_menu 0;
+  Coqide_ui.ui_m#insert_action_group compile_menu 0;
+  Coqide_ui.ui_m#insert_action_group windows_menu 0;
+  Coqide_ui.ui_m#insert_action_group help_menu 0;
+  w#add_accel_group Coqide_ui.ui_m#get_accel_group ;
+  GtkMain.Rc.parse_string "gtk-can-change-accels = 1";
+  if Coq_config.gtk_platform <> `QUARTZ
+  then vbox#pack (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar");
+
+  (* Toolbar *)
+  let tbar = GtkButton.Toolbar.cast
+      ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget)
   in
-  let search_history = ref [] in
-  let (search_input,_) = GEdit.combo_box_entry_text ~strings:!search_history ~show:false
-    ~packing:(lower_hbox#pack ~expand:false) ()
+  let () = GtkButton.Toolbar.set
+    ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar
   in
-  let ready_to_wrap_search = ref false in
+  let toolbar = new GObj.widget tbar in
+  let () = vbox#pack toolbar in
 
-  let start_of_search = ref None in
-  let start_of_found = ref None in
-  let end_of_found = ref None in
-  let search_forward = ref true in
-  let matched_word = ref None in
+  (* Emacs/PG mode *)
+  NanoPG.init w notebook all_menus;
 
-  let memo_search () =
-    matched_word := Some search_input#entry#text
+  (* Reset on tab switch *)
+  let _ = notebook#connect#switch_page ~callback:(fun _ ->
+    if prefs.reset_on_tab_switch then Nav.restart ())
   in
-  let end_search () =
-    prerr_endline "End Search";
-    memo_search ();
-    let v = session_notebook#current_term.script in
-    v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
-    v#coerce#misc#grab_focus ();
-    search_input#entry#set_text "";
-    search_lbl#misc#hide ();
-    search_input#misc#hide ()
-  in
-  let end_search_focus_out () =
-    prerr_endline "End Search(focus out)";
-    memo_search ();
-    let v = session_notebook#current_term.script in
-    v#buffer#move_mark `SEL_BOUND ~where:(v#buffer#get_iter_at_mark `INSERT);
-    search_input#entry#set_text "";
-    search_lbl#misc#hide ();
-    search_input#misc#hide ()
-  in
-  ignore (search_input#entry#connect#activate ~callback:end_search);
-  ignore (search_input#entry#event#connect#key_press
-	    ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in
-				if
-				  kv = GdkKeysyms._Right
-				  || kv = GdkKeysyms._Up
-				    || kv = GdkKeysyms._Left
-				      || (kv = GdkKeysyms._g
-					 && (List.mem `CONTROL (GdkEvent.Key.state k)))
-				then end_search ();
-				false));
-  ignore (search_input#entry#event#connect#focus_out
-	    ~callback:(fun _ -> end_search_focus_out (); false));
-  to_do_on_page_switch :=
-    (fun i ->
-      start_of_search := None;
-      ready_to_wrap_search:=false)::!to_do_on_page_switch;
-
-  (* TODO : make it work !!! *)
-  let rec search_f () =
-    search_lbl#misc#show ();
-    search_input#misc#show ();
-
-    prerr_endline "search_f called";
-    if !start_of_search = None then begin
-      (* A full new search is starting *)
-      start_of_search :=
-	Some (session_notebook#current_term.script#buffer#create_mark
-		(session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT));
-      start_of_found := !start_of_search;
-      end_of_found := !start_of_search;
-      matched_word := Some "";
-    end;
-    let txt = search_input#entry#text in
-    let v = session_notebook#current_term.script in
-    let iit = v#buffer#get_iter_at_mark `SEL_BOUND
-    and insert_iter = v#buffer#get_iter_at_mark `INSERT
-    in
-    prerr_endline ("SELBOUND="^(string_of_int iit#offset));
-    prerr_endline ("INSERT="^(string_of_int insert_iter#offset));
-
-    (match
-	if !search_forward then iit#forward_search txt
-	else let npi = iit#forward_chars (Glib.Utf8.length txt) in
-	     match
-	       (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset),
-	       (let t = iit#get_text ~stop:npi in
-		flash_info (t^"\n"^txt);
-		t = txt)
-	     with
-	       | true,true ->
-		 (flash_info "T,T";iit#backward_search txt)
-	       | false,true -> flash_info "F,T";Some (iit,npi)
-	       | _,false ->
-		 (iit#backward_search txt)
-
-     with
-       | None ->
-	 if !ready_to_wrap_search then begin
-	   ready_to_wrap_search := false;
-	   flash_info "Search wrapped";
-	   v#buffer#place_cursor
-	     ~where:(if !search_forward then v#buffer#start_iter else
-		 v#buffer#end_iter);
-	   search_f ()
-	 end else begin
-	   if !search_forward then flash_info "Search at end"
-	   else flash_info "Search at start";
-	   ready_to_wrap_search := true
-	 end
-       | Some (start,stop) ->
-	 prerr_endline "search: before moving marks";
-	 prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-	 prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-
-	 v#buffer#move_mark `SEL_BOUND ~where:start;
-	 v#buffer#move_mark `INSERT ~where:stop;
-	 prerr_endline "search: after moving marks";
-	 prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset));
-	 prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset));
-	 v#scroll_to_mark `SEL_BOUND
-    )
-  in
-  ignore (search_input#entry#event#connect#key_release
-	    ~callback:
-	    (fun ev ->
-	      if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin
-		let v = session_notebook#current_term.script in
-		(match !start_of_search with
-		  | None ->
-		    prerr_endline "search_key_rel: Placing sel_bound";
-		    v#buffer#move_mark
-		      `SEL_BOUND
-		      ~where:(v#buffer#get_iter_at_mark `INSERT)
-		  | Some mk -> let it = v#buffer#get_iter_at_mark
-				 (`MARK mk) in
-			       prerr_endline "search_key_rel: Placing cursor";
-			       v#buffer#place_cursor ~where:it;
-			       start_of_search := None
-		);
-		search_input#entry#set_text "";
-		v#coerce#misc#grab_focus ();
-	      end;
-	      false
-	    ));
-  ignore (search_input#entry#connect#changed ~callback:search_f);
-  push_info "Ready";
+
+  (* Vertical Separator between Scripts and Goals *)
+  let () = vbox#pack ~expand:true notebook#coerce in
+  let () = refresh_notebook_pos () in
+  let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in
+  let () = lower_hbox#pack ~expand:true status#coerce in
+  let () = push_info ("Ready"^ if current.nanoPG then ", [μPG]" else "")  in
+
   (* Location display *)
   let l = GMisc.label
     ~text:"Line:     1 Char:   1"
-    ~packing:lower_hbox#pack () in
-  l#coerce#misc#set_name "location";
-  set_location := l#set_text;
+    ~packing:lower_hbox#pack ()
+  in
+  let () = l#coerce#misc#set_name "location" in
+  let () = set_location := l#set_text in
+
   (* Progress Bar *)
-  lower_hbox#pack pbar#coerce;
-  pbar#set_text "CoqIde started";
+  let pbar = GRange.progress_bar ~pulse_step:0.1 () in
+  let () = lower_hbox#pack pbar#coerce in
+  let ready () = pbar#set_fraction 0.0; pbar#set_text "Coq is ready" in
+  let pulse sn =
+    if Coq.is_computing sn.coqtop then
+      (pbar#set_text "Coq is computing"; pbar#pulse ())
+    else ready () in
+  let callback () = on_current_term pulse; true in
+  let _ = Glib.Timeout.add ~ms:300 ~callback in
+
+  (* Pending proofs.  It should be with a GtkSpinner... not bound *)
+  let slaveinfo = GMisc.label ~xalign:0.5 ~width:50 () in
+  let () = lower_hbox#pack slaveinfo#coerce in
+  let () = slaveinfo#misc#set_has_tooltip true in
+  let () = slaveinfo#misc#set_tooltip_markup
+    "Proofs to be checked / Errors" in
+  let update sn =
+    let processed, to_process, jobs = sn.coqops#get_slaves_status in
+    let missing = to_process - processed in
+    let n_err = sn.coqops#get_n_errors in
+    if n_err > 0 then
+      slaveinfo#set_text (Printf.sprintf
+        "%d / <span foreground=\"#FF0000\">%d</span>" missing n_err)
+    else
+      slaveinfo#set_text (Printf.sprintf "%d / %d" missing n_err);
+    slaveinfo#set_use_markup true;
+    sn.errpage#update sn.coqops#get_errors;
+    sn.jobpage#update (Util.pi3 sn.coqops#get_slaves_status) in
+  let callback () = on_current_term update; true in
+  let _ = Glib.Timeout.add ~ms:300 ~callback in
 
   (* Initializing hooks *)
-
-  refresh_toolbar_hook :=
-    (fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ());
-  refresh_font_hook :=
-    (fun () ->
-      let fd = !current.text_font in
-      let iter_page p =
-        p.script#misc#modify_font fd;
-        p.proof_view#misc#modify_font fd;
-        p.message_view#misc#modify_font fd;
-        p.command#refresh_font ()
-      in
-      List.iter iter_page session_notebook#pages;
-    );
-  refresh_background_color_hook :=
-    (fun () ->
-      let clr = Tags.color_of_string !current.background_color in
-      let iter_page p =
-        p.script#misc#modify_base [`NORMAL, `COLOR clr];
-        p.proof_view#misc#modify_base [`NORMAL, `COLOR clr];
-        p.message_view#misc#modify_base [`NORMAL, `COLOR clr];
-        p.command#refresh_color ()
-      in
-      List.iter iter_page session_notebook#pages;
-    );
-  resize_window_hook := (fun () ->
-    w#resize
-      ~width:!current.window_width
-      ~height:!current.window_height);
-  refresh_tabs_hook := update_notebook_pos;
-
-  let about_full_string =
-    "\nCoq is developed by the Coq Development Team\
-     \n(INRIA - CNRS - LIX - LRI - PPS)\
-     \nWeb site: " ^ Coq_config.wwwcoq ^
-    "\nFeature wish or bug report: http://coq.inria.fr/bugs/\
-     \n\
-     \nCredits for CoqIDE, the Integrated Development Environment for Coq:\
-     \n\
-     \nMain author  : Benjamin Monate\
-     \nContributors : Jean-Christophe Filliâtre\
-     \n               Pierre Letouzey, Claude Marché\
-     \n               Bruno Barras, Pierre Corbineau\
-     \n               Julien Narboux, Hugo Herbelin, ... \
-     \n\
-     \nVersion information\
-     \n-------------------\
-     \n"
+  let refresh_toolbar () =
+    if prefs.show_toolbar
+    then toolbar#misc#show ()
+    else toolbar#misc#hide ()
   in
-  let display_log_file (b:GText.buffer) =
-    if !debug then
-      let file = match !logfile with None -> "stderr" | Some f -> f in
-      b#insert ("Debug mode is on, log file is "^file)
+  let refresh_style () =
+    let style =  style_manager#style_scheme prefs.source_style in
+    let iter_session v = v.script#source_buffer#set_style_scheme style in
+    List.iter iter_session notebook#pages
   in
-  let initial_about (b:GText.buffer) =
-    let initial_string =
-      "Welcome to CoqIDE, an Integrated Development Environment for Coq\n"
-    in
-    let coq_version = Coq.short_version () in
-    display_log_file b;
-    if Glib.Utf8.validate ("You are running " ^ coq_version) then
-      b#insert ~iter:b#start_iter ("You are running " ^ coq_version);
-    if Glib.Utf8.validate initial_string then
-      b#insert ~iter:b#start_iter initial_string;
-    (try
-       let image = Filename.concat (List.find
-	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
-	 Minilib.xdg_data_dirs) "coq.png" in
-       let startup_image = GdkPixbuf.from_file image in
-       b#insert ~iter:b#start_iter "\n\n";
-       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
-       b#insert ~iter:b#start_iter "\n\n\t\t   "
-     with _ -> ())
+  let refresh_language () =
+    let lang =  lang_manager#language prefs.source_language in
+    let iter_session v = v.script#source_buffer#set_language lang in
+    List.iter iter_session notebook#pages
   in
-
-  let about (b:GText.buffer) =
-    (try
-       let image = Filename.concat (List.find
-	 (fun x -> Sys.file_exists (Filename.concat x "coq.png"))
-	 Minilib.xdg_data_dirs) "coq.png" in
-       let startup_image = GdkPixbuf.from_file image in
-       b#insert ~iter:b#start_iter "\n\n";
-       b#insert_pixbuf ~iter:b#start_iter ~pixbuf:startup_image;
-       b#insert ~iter:b#start_iter "\n\n\t\t   "
-     with _ -> ());
-    if Glib.Utf8.validate about_full_string
-    then b#insert about_full_string;
-    let coq_version = Coq.version () in
-    if Glib.Utf8.validate coq_version
-    then b#insert coq_version;
-    display_log_file b;
+  let resize_window () =
+    w#resize ~width:prefs.window_width ~height:prefs.window_height
   in
-  (* Remove default pango menu for textviews *)
-  w#show ();
-  ignore ((help_actions#get_action "About Coq")#connect#activate
-	    ~callback:(fun _ -> let prf_v = session_notebook#current_term.proof_view in
-                                 prf_v#buffer#set_text ""; about prf_v#buffer));
-  (*
-
-  *)
-(* Begin Color configuration *)
-
-  Tags.set_processing_color (Tags.color_of_string !current.processing_color);
-  Tags.set_processed_color (Tags.color_of_string !current.processed_color);
-
-(* End of color configuration *)
-  ignore(nb#connect#switch_page
-	   ~callback:
-	   (fun i ->
-	     prerr_endline ("switch_page: starts " ^ string_of_int i);
-	     List.iter (function f -> f i) !to_do_on_page_switch;
-	     prerr_endline "switch_page: success")
-  );
-  if List.length files >=1 then
-    begin
-      List.iter (fun f ->
-	if Sys.file_exists f then do_load f else
-          let f = if Filename.check_suffix f ".v" then f else f^".v" in
-	  load_file (fun s -> print_endline s; exit 1) f)
-        files;
-      session_notebook#goto_page 0;
-    end
-  else
-    begin
-      let session = create_session None in
-      let index = session_notebook#append_term session in
-      session_notebook#goto_page index;
-    end;
-  initial_about session_notebook#current_term.proof_view#buffer;
-  !refresh_toolbar_hook ();
-  session_notebook#current_term.script#misc#grab_focus ();;
+  refresh_toolbar ();
+  refresh_toolbar_hook := refresh_toolbar;
+  refresh_style_hook := refresh_style;
+  refresh_language_hook := refresh_language;
+  refresh_editor_hook := refresh_editor_prefs;
+  resize_window_hook := resize_window;
+  refresh_tabs_hook := refresh_notebook_pos;
+
+  (* Color configuration *)
+  Tags.set_processing_color (Tags.color_of_string prefs.processing_color);
+  Tags.set_processed_color (Tags.color_of_string prefs.processed_color);
+  Tags.Script.incomplete#set_property
+    (`BACKGROUND_STIPPLE
+      (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02"));
+  Tags.Script.incomplete#set_property
+    (`BACKGROUND_GDK (Tags.get_processed_color ())); 
+
+  (* Showtime ! *)
+  w#show ()
+
+
+(** {2 Coqide main function } *)
+
+let make_file_buffer f =
+  let f = if Filename.check_suffix f ".v" then f else f^".v" in
+  FileAux.load_file ~maycreate:true f
+
+let make_scratch_buffer () =
+  let session = create_session None in
+  let _ = notebook#append_term session in
+  !refresh_editor_hook ()
+
+let main files =
+  build_ui ();
+  reset_revert_timer ();
+  reset_autosave_timer ();
+  (match files with
+    | [] -> make_scratch_buffer ()
+    | _ -> List.iter make_file_buffer files);
+  notebook#goto_page 0;
+  MiscMenu.initial_about ();
+  on_current_term (fun t -> t.script#misc#grab_focus ());
+  Minilib.log "End of Coqide.main"
+
+
+(** {2 Geoproof } *)
 
-(* This function check every half of second if GeoProof has send
-   something on his private clipboard *)
+(** This function check every tenth of second if GeoProof has send
+    something on his private clipboard *)
 
-let rec check_for_geoproof_input () =
+let check_for_geoproof_input () =
   let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in
-  while true do
-    Thread.delay 0.1;
-    let s = cb_Dr#text in
-    (match s with
-	Some s ->
-	  if s <> "Ack" then
-	    session_notebook#current_term.script#buffer#insert (s^"\n");
-	  cb_Dr#set_text "Ack"
-      | None -> ()
-    );
-  (* cb_Dr#clear does not work so i use : *)
-  (* cb_Dr#set_text "Ack" *)
-  done
+  let handler () = match cb_Dr#text with
+    |None -> true
+    |Some "Ack" -> true
+    |Some s ->
+      on_current_term (fun sn -> sn.buffer#insert (s ^ "\n"));
+      (* cb_Dr#clear does not work so i use : *)
+      cb_Dr#set_text "Ack";
+      true
+  in
+  ignore (GMain.Timeout.add ~ms:100 ~callback:handler)
+
+
+(** {2 Argument parsing } *)
 
 (** By default, the coqtop we try to launch is exactly the current coqide
     full name, with the last occurrence of "coqide" replaced by "coqtop".
     This should correctly handle the ".opt", ".byte", ".exe" situations.
     If the replacement fails, we default to "coqtop", hoping it's somewhere
-    in the path. Note that the -coqtop option to coqide allows to override
+    in the path. Note that the -coqtop option to coqide overrides
     this default coqtop path *)
 
 let read_coqide_args argv =
   let rec filter_coqtop coqtop project_files out = function
-    | "-coqtop" :: prog :: args ->
+    |"-coqtop" :: prog :: args ->
       if coqtop = None then filter_coqtop (Some prog) project_files out args
-      else
-       (output_string stderr "Error: multiple -coqtop options"; exit 1)
-    | "-f" :: file :: args ->
-	filter_coqtop coqtop
-	  ((Minilib.canonical_path_name (Filename.dirname file),
-	    Project_file.read_project_file file) :: project_files) out args
-    | "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1
-    | "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1
-    | "-debug"::args -> Ideutils.debug := true;
+      else (output_string stderr "Error: multiple -coqtop options"; exit 1)
+    |"-f" :: file :: args ->
+      let d = CUnix.canonical_path_name (Filename.dirname file) in
+      let p = Project_file.read_project_file file in
+      filter_coqtop coqtop ((d,p) :: project_files) out args
+    |"-f" :: [] ->
+      output_string stderr "Error: missing project file name"; exit 1
+    |"-coqtop" :: [] ->
+      output_string stderr "Error: missing argument after -coqtop"; exit 1
+    |"-debug"::args ->
+      Minilib.debug := true;
+      Flags.debug := true;
+      Backtrace.record_backtrace true;
       filter_coqtop coqtop project_files ("-debug"::out) args
-    | arg::args -> filter_coqtop coqtop project_files (arg::out) args
-    | [] -> (coqtop,List.rev project_files,List.rev out)
+    |"-coqtop-flags" :: flags :: args->
+      Flags.ideslave_coqtop_flags := Some flags;
+      filter_coqtop coqtop project_files out args
+    |arg::args when out = [] && Minilib.is_prefix_of "-psn_" arg ->
+      (* argument added by MacOS during .app launch *)
+      filter_coqtop coqtop project_files out args
+    |arg::args -> filter_coqtop coqtop project_files (arg::out) args
+    |[] -> (coqtop,List.rev project_files,List.rev out)
   in
   let coqtop,project_files,argv = filter_coqtop None [] [] argv in
-    Ideutils.custom_coqtop := coqtop;
-    custom_project_files := project_files;
+  Ideutils.custom_coqtop := coqtop;
+  custom_project_files := project_files;
   argv
+
+
+(** {2 Signal handling } *)
+
+(** The Ctrl-C (sigint) is handled as a interactive quit.
+    For most of the other catchable signals we launch
+    an emergency save of opened files and then exit. *)
+
+let signals_to_crash =
+  [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup;
+   Sys.sigill; Sys.sigpipe; Sys.sigquit; Sys.sigusr1; Sys.sigusr2]
+
+let set_signal_handlers () =
+  try
+    Sys.set_signal Sys.sigint (Sys.Signal_handle File.quit);
+    List.iter
+      (fun i -> Sys.set_signal i (Sys.Signal_handle FileAux.crash_save))
+      signals_to_crash
+  with _ -> Minilib.log "Signal ignored (normal if Win32)"
diff --git a/ide/coqide.mli b/ide/coqide.mli
index 811535d5..66915128 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.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        *)
@@ -24,14 +24,18 @@ val main : string list -> unit
 
 (** Function to save anything and kill all coqtops
     @return [false] if you're allowed to quit. *)
-val forbid_quit_to_save : unit -> bool
+val forbid_quit : unit -> bool
+
+(** Terminate coqide after closing all coqtops and waiting
+    for their death *)
+val close_and_quit : unit -> unit
 
 (** Function to load of a file. *)
 val do_load : string -> unit
 
-(** Set coqide to ignore Ctrl-C, while launching [crash_save] and
-    exiting for others received signals *)
-val ignore_break : unit -> unit
+(** Set coqide to perform a clean quit at Ctrl-C, while launching
+    [crash_save] and exiting for others received signals *)
+val set_signal_handlers : unit -> unit
 
 (** Emergency saving of opened files as "foo.v.crashcoqide",
     and exit (if the integer isn't 127). *)
diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4
index 1466060c..db69ec66 100644
--- a/ide/coqide_main.ml4
+++ b/ide/coqide_main.ml4
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-let _ = Coqide.ignore_break ()
+let _ = Coqide.set_signal_handlers ()
 let _ = GtkMain.Main.init ()
 
 (* We handle Gtk warning messages ourselves :
@@ -18,18 +18,27 @@ let catch_gtk_messages () =
     [`FLAG_RECURSION;`FLAG_FATAL;`ERROR;`CRITICAL;`WARNING;
      `MESSAGE;`INFO;`DEBUG]
   in
+  let log_level lvl =
+    let level_is tag = (lvl land Glib.Message.log_level tag) <> 0 in
+    if level_is `ERROR then `FATAL
+    else if level_is `CRITICAL then `ERROR
+    else if level_is `DEBUG then `DEBUG
+    else if level_is `WARNING then `WARNING
+    else if level_is `MESSAGE then `NOTICE
+    else `INFO
+  in
   let handler ~level msg =
     let header = "Coqide internal error: " in
-    let level_is tag = (level land Glib.Message.log_level tag) <> 0 in
-    if level_is `ERROR then
-      let () = GToolbox.message_box ~title:"Error" (header ^ msg) in
-      Coqide.crash_save 1
-    else if level_is `CRITICAL then
-      GToolbox.message_box ~title:"Error" (header ^ msg)
-    else if level_is `DEBUG || Sys.os_type = "Win32" then
-      Ideutils.prerr_endline msg (* no-op unless in debug mode *)
-    else
-      Printf.eprintf "%s\n" msg
+    match log_level level with
+      |`FATAL ->
+        let () = GToolbox.message_box ~title:"Error" (header ^ msg) in
+        Coqide.crash_save 1
+      |`ERROR ->
+        if !Flags.debug then GToolbox.message_box ~title:"Error" (header ^ msg)
+        else Printf.eprintf "%s\n" (header ^ msg)
+      |`DEBUG -> Minilib.log msg
+      |level when Sys.os_type = "Win32" -> Minilib.log ~level msg
+      |_ -> Printf.eprintf "%s\n" msg
   in
   let catch domain =
     ignore (Glib.Message.set_log_handler ~domain ~levels:all_levels handler)
@@ -38,10 +47,13 @@ let catch_gtk_messages () =
 
 let () = catch_gtk_messages ()
 
-(* We anticipate a bit the argument parsing and look for -debug *)
 
-let early_set_debug () =
-  Ideutils.debug := List.mem "-debug" (Array.to_list Sys.argv)
+
+(** System-dependent settings *)
+
+let os_specific_init () = ()
+
+(** Win32 *)
 
 (* On win32, we add the directory of coqide to the PATH at launch-time
    (this used to be done in a .bat script). *)
@@ -51,12 +63,23 @@ let set_win32_path () =
     (Filename.dirname Sys.executable_name ^ ";" ^
       (try Sys.getenv "PATH" with _ -> ""))
 
-(* On win32, in debug mode we duplicate stdout/stderr in a log file. *)
-
-let log_stdout_stderr () =
-  let (name,chan) = Filename.open_temp_file "coqide_" ".log" in
-  Coqide.logfile := Some name;
-  let out_descr = Unix.descr_of_out_channel chan in
+(* On win32, since coqide is now console-free, we re-route stdout/stderr
+   to avoid Sys_error if someone writes to them. We write to a pipe which
+   is never read (by default) or to a temp log file (when in debug mode).
+*)
+
+let reroute_stdout_stderr () =
+  (* We anticipate a bit the argument parsing and look for -debug *)
+  let debug = List.mem "-debug" (Array.to_list Sys.argv) in
+  Minilib.debug := debug;
+  let out_descr =
+    if debug then
+      let (name,chan) = Filename.open_temp_file "coqide_" ".log" in
+      Coqide.logfile := Some name;
+      Unix.descr_of_out_channel chan
+    else
+      snd (Unix.pipe ())
+  in
   Unix.set_close_on_exec out_descr;
   Unix.dup2 out_descr Unix.stdout;
   Unix.dup2 out_descr Unix.stderr
@@ -65,71 +88,65 @@ let log_stdout_stderr () =
 
 IFDEF WIN32 THEN
 external win32_kill : int -> unit = "win32_kill"
-external win32_interrupt_all : unit -> unit = "win32_interrupt_all"
-external win32_hide_console : unit -> unit = "win32_hide_console"
-
+external win32_interrupt : int -> unit = "win32_interrupt"
 let () =
+  Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket;
   set_win32_path ();
-  Coq.killer := win32_kill;
-  Coq.interrupter := (fun pid -> win32_interrupt_all ());
-  early_set_debug ();
-  if !Ideutils.debug then
-    log_stdout_stderr ()
-  else
-    win32_hide_console ()
+  Coq.interrupter := win32_interrupt;
+  reroute_stdout_stderr ()
 END
 
+(** MacOSX *)
+
 IFDEF QUARTZ THEN
-  let osx = GosxApplication.osxapplication ()
+let osx = GosxApplication.osxapplication ()
 
-  let _ =
-    osx#connect#ns_application_open_file ~callback:(fun x -> Coqide.do_load x; true) in
-  let _ =
-    osx#connect#ns_application_block_termination ~callback:Coqide.forbid_quit_to_save in
-  ()
+let () =
+  let _ = osx#connect#ns_application_open_file
+    ~callback:(fun x -> Coqide.do_load x; true)
+  in
+  let _ = osx#connect#ns_application_block_termination
+    ~callback:Coqide.forbid_quit
+  in
+  let _ = osx#connect#ns_application_will_terminate
+    ~callback:Coqide.close_and_quit
+  in ()
+
+let os_specific_init () =
+  let () = GtkosxApplication.Application.set_menu_bar osx#as_osxapplication
+    (GtkMenu.MenuShell.cast
+       (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget)
+  in
+  let () = GtkosxApplication.Application.insert_app_menu_item
+    osx#as_osxapplication
+    (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1
+  in
+  let () = GtkosxApplication.Application.set_help_menu osx#as_osxapplication
+    (Some (GtkMenu.MenuItem.cast
+             (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget))
+  in
+  osx#ready ()
 END
 
+let load_prefs () =
+  try Preferences.load_pref ()
+  with e -> Ideutils.flash_info
+    ("Could not load preferences ("^Printexc.to_string e^").")
+
 let () =
-  (try
-     let gtkrcdir = List.find
-       (fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc"))
-       Minilib.xdg_config_dirs in
-     GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc");
-   with Not_found -> ());
-  (* Statup preferences *)
-  begin
-    try Preferences.load_pref ()
-    with e ->
-      Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^").");
-  end;
-(*    GtkData.AccelGroup.set_default_mod_mask
-      (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*)
-  let argl = Array.to_list Sys.argv in
+  load_prefs ();
+  let argl = List.tl (Array.to_list Sys.argv) in
   let argl = Coqide.read_coqide_args argl in
-  let files = Coq.filter_coq_opts (List.tl argl) in
-  let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
+  let files = Coq.filter_coq_opts argl in
+  let args = List.filter (fun x -> not (List.mem x files)) argl in
   Coq.check_connection args;
   Coqide.sup_args := args;
   Coqide.main files;
-    if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ())
-
-IFDEF QUARTZ THEN
-  let () =
-    GtkosxApplication.Application.set_menu_bar osx#as_osxapplication (GtkMenu.MenuShell.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar")#as_widget) in
-  let () =
-    GtkosxApplication.Application.insert_app_menu_item osx#as_osxapplication (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")#as_widget 1 in
-  let () =
-    GtkosxApplication.Application.set_help_menu osx#as_osxapplication (Some (GtkMenu.MenuItem.cast (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help")#as_widget)) in
-  osx#ready ()
-END
-
-    while true do
-      try
-	GtkThread.main ()
-      with
-	| Sys.Break -> Ideutils.prerr_endline "Interrupted."
-	| e ->
-	    Minilib.safe_prerr_endline
-	      ("CoqIde unexpected error:" ^ (Printexc.to_string e));
-	    Coqide.crash_save 127
-    done
+  if !Coq_config.with_geoproof then Coqide.check_for_geoproof_input ();
+  os_specific_init ();
+  try
+    GMain.main ();
+    failwith "Gtk loop ended"
+  with e ->
+    Minilib.log ("CoqIde unexpected error:" ^ Printexc.to_string e);
+    Coqide.crash_save 127
diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml
index eaf1e934..af71b1e7 100644
--- a/ide/coqide_ui.ml
+++ b/ide/coqide_ui.ml
@@ -1,6 +1,6 @@
 let ui_m = GAction.ui_manager ();;
 
-let no_under = Minilib.string_map (fun x -> if x = '_' then '-' else x)
+let no_under = Util.String.map (fun x -> if x = '_' then '-' else x)
 
 let list_items menu li =
   let res_buf = Buffer.create 500 in
@@ -42,14 +42,15 @@ let init () =
   </menu>
   <menu name='Edit' action='Edit'>
     <menuitem action='Undo' />
-    <menuitem action='Clear Undo Stack' />
+    <menuitem action='Redo' />
     <separator />
     <menuitem action='Cut' />
     <menuitem action='Copy' />
     <menuitem action='Paste' />
     <separator />
-    <menuitem action='Find in buffer' />
-    <menuitem action='Find backwards' />
+    <menuitem action='Find' />
+    <menuitem action='Find Next' />
+    <menuitem action='Find Previous' />
     <menuitem action='Complete Word' />
     <separator />
     <menuitem action='External editor' />
@@ -60,8 +61,12 @@ let init () =
     <menuitem action='Previous tab' />
     <menuitem action='Next tab' />
     <separator/>
+    <menuitem action='Zoom in' />
+    <menuitem action='Zoom out' />
+    <menuitem action='Zoom fit' />
+    <separator/>
     <menuitem action='Show Toolbar' />
-    <menuitem action='Show Query Pane' />
+    <menuitem action='Query Pane' />
     <separator/>
     <menuitem action='Display implicit arguments' />
     <menuitem action='Display coercions' />
@@ -79,7 +84,6 @@ let init () =
     <menuitem action='Start' />
     <menuitem action='End' />
     <menuitem action='Interrupt' />
-    <menuitem action='Hide' />
     <menuitem action='Previous' />
     <menuitem action='Next' />
   </menu>
@@ -109,13 +113,20 @@ let init () =
     %s
   </menu>
   <menu action='Queries'>
-    <menuitem action='SearchAbout' />
+    <menuitem action='Search' />
     <menuitem action='Check' />
     <menuitem action='Print' />
     <menuitem action='About' />
     <menuitem action='Locate' />
+    <menuitem action='Print Assumptions' />
     <menuitem action='Whelp Locate' />
   </menu>
+  <menu name='Tools' action='Tools'>
+    <menuitem action='Comment' />
+    <menuitem action='Uncomment' />
+    <separator />
+    <menuitem action='Coqtop arguments' />
+  </menu>
   <menu action='Compile'>
     <menuitem action='Compile buffer' />
     <menuitem action='Make' />
@@ -129,6 +140,7 @@ let init () =
     <menuitem action='Browse Coq Manual' />
     <menuitem action='Browse Coq Library' />
     <menuitem action='Help for keyword' />
+    <menuitem action='Help for μPG mode' />
     <separator />
     <menuitem name='Abt' action='About Coq' />
   </menu>
@@ -141,8 +153,8 @@ let init () =
   <toolitem action='Go to' />
   <toolitem action='Start' />
   <toolitem action='End' />
+  <toolitem action='Force' />
   <toolitem action='Interrupt' />
-  <toolitem action='Hide' />
   <toolitem action='Previous' />
   <toolitem action='Next' />
   <toolitem action='Wizard' />
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
new file mode 100644
index 00000000..92301dc3
--- /dev/null
+++ b/ide/coqidetop.mllib
@@ -0,0 +1,2 @@
+Xmlprotocol
+Ide_slave
diff --git a/ide/document.ml b/ide/document.ml
new file mode 100644
index 00000000..9823e757
--- /dev/null
+++ b/ide/document.ml
@@ -0,0 +1,186 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+exception Empty
+
+let invalid_arg s = raise (Invalid_argument ("Document."^s))
+
+type 'a sentence = { mutable state_id : Stateid.t option; data : 'a }
+
+type id = Stateid.t
+
+class type ['a] signals =
+  object
+    method popped : callback:('a -> unit) -> unit
+    method pushed : callback:('a -> unit) -> unit
+  end
+
+class ['a] signal () =
+object
+  val mutable attached : ('a -> unit) list = []
+  method call (x : 'a) =
+    let iter f = try f x with _ -> () in
+    List.iter iter attached
+  method connect f = attached <- f :: attached
+end
+
+type 'a document = {
+  mutable stack : 'a sentence list;
+  mutable context : ('a sentence list * 'a sentence list) option;
+  pushed_sig : 'a signal;
+  popped_sig : 'a signal;
+}
+
+let connect d =
+  object
+    method pushed ~callback = d.pushed_sig#connect callback
+    method popped ~callback = d.popped_sig#connect callback
+  end
+
+let create () = {
+  stack = [];
+  context = None;
+  pushed_sig = new signal ();
+  popped_sig = new signal ();
+}
+
+(* Invariant, only the tip is a allowed to have state_id = None *)
+let invariant l = l = [] || (List.hd l).state_id <> None
+
+let tip = function
+  | { stack = [] } -> raise Empty
+  | { stack = { state_id = Some id }::_ } -> id
+  | { stack = { state_id = None }::_ } -> invalid_arg "tip"
+  
+let tip_data = function
+  | { stack = [] } -> raise Empty
+  | { stack = { data }::_ } -> data
+
+let push d x =
+  assert(invariant d.stack);
+  d.stack <- { data = x; state_id = None } :: d.stack;
+  d.pushed_sig#call x
+
+let pop = function
+  | { stack = [] } -> raise Empty
+  | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data
+  
+let focus d ~cond_top:c_start ~cond_bot:c_stop =
+  assert(invariant d.stack);
+  if d.context <> None then invalid_arg "focus";
+  let rec aux (a,s,b) grab = function
+    | [] -> invalid_arg "focus"
+    | { state_id = Some id; data } as x :: xs when not grab ->
+        if c_start id data then aux (a,s,b) true (x::xs)
+        else aux (x::a,s,b) grab xs
+    | { state_id = Some id; data } as x :: xs ->
+        if c_stop id data then List.rev a, List.rev (x::s), xs
+        else aux (a,x::s,b) grab xs 
+    | _ -> assert false in
+  let a, s, b = aux ([],[],[]) false d.stack in
+  d.stack <- s;
+  d.context <- Some (a, b)
+  
+let unfocus = function
+  | { context = None } -> invalid_arg "unfocus"
+  | { context = Some (a,b); stack } as d ->
+       assert(invariant stack);
+       d.context <- None;
+       d.stack <- a @ stack @ b
+  
+let focused { context } = context <> None
+
+let to_lists = function
+  | { context = None; stack = s } -> [],s,[]
+  | { context = Some (a,b); stack = s } -> a,s,b
+
+let flat f b = fun x -> f b x.state_id x.data
+
+let find d f =
+  let a, s, b = to_lists d in
+  (
+  try List.find (flat f false) a with Not_found ->
+  try List.find (flat f true)  s with Not_found ->
+      List.find (flat f false) b
+  ).data
+  
+let find_map d f =
+  let a, s, b = to_lists d in
+  try CList.find_map (flat f false) a with Not_found -> 
+  try CList.find_map (flat f true)  s with Not_found -> 
+      CList.find_map (flat f false) b
+  
+let is_empty = function
+  | { stack = []; context = None } -> true
+  | _ -> false
+  
+let context d =
+  let top, _, bot = to_lists d in
+  let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in
+  List.map (flat pair true) top, List.map (flat pair true) bot
+
+let iter d f =
+  let a, s, b = to_lists d in
+  List.iter (flat f false) a;
+  List.iter (flat f true)  s;
+  List.iter (flat f false) b
+  
+let stateid_opt_equal = Option.equal Stateid.equal
+
+let is_in_focus d id =
+  let _, focused, _ = to_lists d in
+  List.exists (fun { state_id } -> stateid_opt_equal state_id (Some id)) focused
+
+let print d f =
+  let top, mid, bot = to_lists d in
+  let open Pp in
+  v 0
+    (List.fold_right (fun i acc -> acc ++ cut() ++ flat f false i) top
+    (List.fold_right (fun i acc -> acc ++ cut() ++ flat f true i)  mid
+    (List.fold_right (fun i acc -> acc ++ cut() ++ flat f false i) bot (mt()))))
+
+let assign_tip_id d id =
+  match d with
+  | { stack = { state_id = None } as top :: _ } -> top.state_id <- Some id
+  | _ -> invalid_arg "assign_tip_id"
+
+let cut_at d id =
+  let aux (n, zone) { state_id; data } =
+    if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone)
+    else CSig.Cont (n + 1, data :: zone) in
+  let n, zone = CList.fold_left_until aux (0, []) d.stack in
+  for i = 1 to n do ignore(pop d) done;
+  List.rev zone
+
+let find_id d f =
+  let top, focus, bot = to_lists d in
+  let pred = function
+    | { state_id = Some id; data } when f id data -> Some id
+    | _ -> None in
+  try CList.find_map pred top, true with Not_found ->
+  try CList.find_map pred focus, false with Not_found ->
+      CList.find_map pred bot, true
+
+let before_tip d =
+  let _, focused, rest = to_lists d in
+  match focused with
+  | _:: { state_id = Some id } :: _ -> id, false
+  | _:: { state_id = None } :: _ -> assert false
+  | [] -> raise Not_found
+  | [_] ->
+      match rest with
+      | { state_id = Some id } :: _ -> id, true
+      | { state_id = None } :: _ -> assert false
+      | [] -> raise Not_found
+
+let fold_all d a f =
+  let top, focused, bot = to_lists d in
+  let a = List.fold_left (fun a -> flat (f a) false) a top in
+  let a = List.fold_left (fun a -> flat (f a) true)  a focused in
+  let a = List.fold_left (fun a -> flat (f a) false) a bot in
+  a
diff --git a/ide/document.mli b/ide/document.mli
new file mode 100644
index 00000000..0d803ff0
--- /dev/null
+++ b/ide/document.mli
@@ -0,0 +1,115 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* An 'a document is a structure to hold and manipulate list of sentences.
+   Sentences are equipped with an id = Stateid.t and can carry arbitrary
+   data ('a).
+   
+   When added (push) to the document, a sentence has no id, it has
+   be manually assigned just afterward or the sentence has to be removed
+   (pop) before any other sentence can be pushed.
+   This exception is useful since the process of assigning an id to
+   a sentence may fail (parse error) and an error handler may want to annotate
+   a script buffer with the error message.  This handler needs to find the
+   sentence in question, and it is simpler if the sentence is in the document.
+   Only the functions pop, find, fold_all and find_map can be called on a
+   document with a tip that has no id (and assign_tip_id of course).
+   
+   The document can be focused (non recursively) to a zone.  After that
+   some functions operate on the focused zone only.  When unfocused the
+   context (the part of the document out of focus) is restored.
+*)
+
+exception Empty
+
+type 'a document
+type id = Stateid.t
+
+val create : unit -> 'a document
+
+(* Functions that work on the focused part of the document ******************* *)
+
+(** The last sentence.  @raise Invalid_argument if tip has no id.  @raise Empty *)
+val tip       : 'a document -> id
+
+(** The last sentence.  @raise Empty *)
+val tip_data  : 'a document -> 'a
+
+(** Add a sentence on the top (with no state_id) *)
+val push : 'a document -> 'a -> unit
+
+(** Remove the tip setence.  @raise Empty *)
+val pop : 'a document -> 'a
+
+(** Assign the state_id of the tip.  @raise Empty *)
+val assign_tip_id : 'a document -> id -> unit
+
+(** [cut_at d id] cuts the document at [id] that is the new tip.
+    Returns the list of sentences that were cut.
+    @raise Not_found *)
+val cut_at : 'a document -> id -> 'a list
+
+(* Functions that work on the whole document ********************************* *)
+
+(** returns the id of the topmost sentence validating the predicate and
+    a boolean that is true if one needs to unfocus the document to access
+    such sentence.  @raise Not_found *)
+val find_id : 'a document -> (id -> 'a -> bool) -> id * bool
+
+(** look for a sentence validating the predicate.  The boolean is true
+    if the sentence is in the zone currently focused.  @raise Not_found *)
+val find : 'a document -> (bool -> id option -> 'a -> bool) -> 'a
+val find_map : 'a document -> (bool -> id option -> 'a -> 'b option) -> 'b
+
+(** After [focus s c1 c2] the top of [s] is the topmost element [x] such that
+    [c1 x] is [true] and the bottom is the first element [y] following [x]
+    such that [c2 y] is [true].
+    @raise Invalid_argument if there is no such [x] and [y] or already focused *)
+val focus :
+  'a document ->
+    cond_top:(id -> 'a -> bool) -> cond_bot:(id -> 'a -> bool) -> unit
+
+(** Undoes a [focus].
+    @raise Invalid_argument "CStack.unfocus" if the stack is not focused *)
+val unfocus : 'a document -> unit
+
+(** Is the document focused *)
+val focused : 'a document -> bool
+
+(** No sentences at all *)
+val is_empty : 'a document -> bool
+
+(** returns the 1 to-last sentence, and true if we need to unfocus to reach it.
+    @raise Not_found *)
+val before_tip : 'a document -> id * bool
+
+(** Is the id in the focused zone? *)
+val is_in_focus : 'a document -> id -> bool
+
+(** Folds over the whole document starting from the topmost (maybe unfocused)
+    sentence. *)
+val fold_all :
+  'a document -> 'c -> ('c -> bool -> id option -> 'a -> 'c) -> 'c
+
+(** Returns (top,bot) such that the document is morally (top @ s @ bot) where
+    s is the focused part.  @raise Invalid_argument *)
+val context : 'a document -> (id * 'a) list * (id * 'a) list
+
+(** debug print *)
+val print :
+  'a document -> (bool -> id option -> 'a ->  Pp.std_ppcmds) -> Pp.std_ppcmds
+
+(** Callbacks on documents *)
+
+class type ['a] signals =
+  object
+    method popped : callback:('a -> unit) -> unit
+    method pushed : callback:('a -> unit) -> unit
+  end
+
+val connect : 'a document -> 'a signals
diff --git a/ide/fileOps.ml b/ide/fileOps.ml
new file mode 100644
index 00000000..03b3fcd4
--- /dev/null
+++ b/ide/fileOps.ml
@@ -0,0 +1,154 @@
+(************************************************************************)
+(*  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 Ideutils
+
+let prefs = Preferences.current
+
+let revert_timer = mktimer ()
+let autosave_timer = mktimer ()
+
+class type ops =
+object
+  method filename : string option
+  method update_stats : unit
+  method changed_on_disk : bool
+  method revert : unit
+  method auto_save : unit
+  method save : string -> bool
+  method saveas : string -> bool
+end
+
+class fileops (buffer:GText.buffer) _fn (reset_handler:unit->unit) =
+object(self)
+
+  val mutable filename = _fn
+  val mutable last_stats = NoSuchFile
+  val mutable last_modification_time = 0.
+  val mutable last_auto_save_time = 0.
+
+  method filename = filename
+
+  method update_stats = match filename with
+    |Some f -> last_stats <- Ideutils.stat f
+    |_ -> ()
+
+  method changed_on_disk = match filename with
+    |None -> false
+    |Some f -> match Ideutils.stat f, last_stats with
+        |MTime cur_mt, MTime last_mt -> cur_mt > last_mt
+        |MTime _, (NoSuchFile|OtherError) -> true
+        |NoSuchFile, MTime _ ->
+          flash_info ("Warning, file not on disk anymore : "^f);
+          false
+        |_ -> false
+
+  method revert =
+    let do_revert f =
+      push_info "Reverting buffer";
+      try
+        reset_handler ();
+        let b = Buffer.create 1024 in
+        Ideutils.read_file f b;
+        let s = try_convert (Buffer.contents b) in
+        buffer#set_text s;
+        self#update_stats;
+        buffer#place_cursor ~where:buffer#start_iter;
+        buffer#set_modified false;
+        pop_info ();
+        flash_info "Buffer reverted";
+        Sentence.tag_all buffer;
+      with _  ->
+        pop_info ();
+        flash_info "Warning: could not revert buffer";
+    in
+    match filename with
+      | None -> ()
+      | Some f ->
+        if not buffer#modified then do_revert f
+        else
+          let answ = GToolbox.question_box
+            ~title:"Modified buffer changed on disk"
+            ~buttons:["Revert from File";
+                      "Overwrite File";
+                      "Disable Auto Revert"]
+            ~default:0
+            ~icon:(stock_to_widget `DIALOG_WARNING)
+            "Some unsaved buffers changed on disk"
+          in
+          match answ with
+            | 1 -> do_revert f
+            | 2 -> if self#save f then flash_info "Overwritten" else
+                flash_info "Could not overwrite file"
+            | _ ->
+              Minilib.log "Auto revert set to false";
+              prefs.Preferences.global_auto_revert <- false;
+              revert_timer.kill ()
+
+  method save f =
+    if try_export f (buffer#get_text ()) then begin
+      filename <- Some f;
+      self#update_stats;
+      buffer#set_modified false;
+      (match self#auto_save_name with
+        | None -> ()
+        | Some fn -> try Sys.remove fn with _ -> ());
+      true
+    end
+    else false
+
+  method saveas f =
+  if not (Sys.file_exists f) then self#save f
+  else
+    let answ = GToolbox.question_box ~title:"File exists on disk"
+      ~buttons:["Overwrite"; "Cancel";]
+      ~default:1
+      ~icon:(warn_image ())#coerce
+      ("File "^f^" already exists")
+    in
+    match answ with
+      | 1 -> self#save f
+      | _ -> false
+
+  method private auto_save_name =
+    match filename with
+      | None -> None
+      | Some f ->
+        let dir = Filename.dirname f in
+        let base = (fst prefs.Preferences.auto_save_name) ^
+          (Filename.basename f) ^
+          (snd prefs.Preferences.auto_save_name)
+        in Some (Filename.concat dir base)
+
+  method private need_auto_save =
+    buffer#modified &&
+      last_modification_time > last_auto_save_time
+
+  method auto_save =
+    if self#need_auto_save then begin
+      match self#auto_save_name with
+        | None -> ()
+        | Some fn ->
+          try
+            last_auto_save_time <- Unix.time();
+            Minilib.log ("Autosave time: "^(string_of_float (Unix.time())));
+            if try_export fn (buffer#get_text ()) then begin
+              flash_info ~delay:1000 "Autosaved"
+            end
+            else warning
+              ("Autosave failed (check if " ^ fn ^ " is writable)")
+          with _ ->
+            warning ("Autosave: unexpected error while writing "^fn)
+    end
+
+  initializer
+  let _ = buffer#connect#end_user_action
+    ~callback:(fun () -> last_modification_time <- Unix.time ())
+  in ()
+
+end
diff --git a/ide/fileOps.mli b/ide/fileOps.mli
new file mode 100644
index 00000000..48b7c8f6
--- /dev/null
+++ b/ide/fileOps.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+val revert_timer : Ideutils.timer
+val autosave_timer : Ideutils.timer
+
+class type ops =
+object
+  method filename : string option
+  method update_stats : unit
+  method changed_on_disk : bool
+  method revert : unit
+  method auto_save : unit
+  method save : string -> bool
+  method saveas : string -> bool
+end
+
+class fileops : GText.buffer -> string option -> (unit -> unit) -> ops
diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml
index 172e4609..abbd7e6d 100644
--- a/ide/gtk_parsing.ml
+++ b/ide/gtk_parsing.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  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 Ideutils
-
 let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0)
 let arobase = Glib.Utf8.to_unichar "@" ~pos:(ref 0)
 let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0)
@@ -22,14 +20,12 @@ let is_word_char c =
 
 
 let starts_word (it:GText.iter) =
-  prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'");
-  (not it#copy#nocopy#backward_char ||
-     (let c = it#backward_char#char in
-	not (is_word_char c)))
-
+  (it#is_start ||
+    (let c = it#backward_char#char in
+      not (is_word_char c)))
 
 let ends_word (it:GText.iter) =
-  (not it#copy#nocopy#forward_char ||
+  (it#is_end ||
      let c = it#forward_char#char in
        not (is_word_char c)
   )
@@ -47,26 +43,25 @@ let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it
 
 let find_word_start (it:GText.iter) =
   let rec step_to_start it =
-    prerr_endline "Find word start";
+    Minilib.log "Find word start";
     if not it#nocopy#backward_char then
-      (prerr_endline "find_word_start: cannot backward"; it)
+      (Minilib.log "find_word_start: cannot backward"; it)
     else if is_word_char it#char
     then step_to_start it
     else (it#nocopy#forward_char;
-	prerr_endline ("Word start at: "^(string_of_int it#offset));it)
+	Minilib.log ("Word start at: "^(string_of_int it#offset));it)
   in
     step_to_start it#copy
 
-
 let find_word_end (it:GText.iter) =
   let rec step_to_end (it:GText.iter) =
-    prerr_endline "Find word end";
+    Minilib.log "Find word end";
     let c = it#char in
     if c<>0 && is_word_char c then (
       ignore (it#nocopy#forward_char);
       step_to_end it
     ) else (
-      prerr_endline ("Word end at: "^(string_of_int it#offset));
+      Minilib.log ("Word end at: "^(string_of_int it#offset));
       it)
   in
     step_to_end it#copy
@@ -79,11 +74,11 @@ let get_word_around (it:GText.iter) =
 
 
 let rec complete_backward w (it:GText.iter) =
-  prerr_endline "Complete backward...";
+  Minilib.log "Complete backward...";
   match it#backward_search w with
-    | None -> (prerr_endline "backward_search failed";None)
+    | None -> (Minilib.log "backward_search failed";None)
     | Some (start,stop) ->
-	prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
+	Minilib.log ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset));
 	if starts_word start then
 	  let ne = find_word_end stop in
 	    if ne#compare stop = 0
@@ -93,7 +88,7 @@ let rec complete_backward w (it:GText.iter) =
 
 
 let rec complete_forward w (it:GText.iter) =
-  prerr_endline "Complete forward...";
+  Minilib.log "Complete forward...";
   match it#forward_search w with
     | None -> None
     | Some (start,stop) ->
diff --git a/ide/ide.mllib b/ide/ide.mllib
index 9bbf9b0d..e082bd18 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -9,18 +9,30 @@ Configwin
 Editable_cells
 Config_parser
 Tags
-Typed_notebook
+Wg_Segment
+Wg_Notebook
 Config_lexer
 Utf8_convert
 Preferences
 Project_file
 Ideutils
-Ideproof
+Xmlprotocol
+Coq
 Coq_lex
+Sentence
 Gtk_parsing
-Undo
-Coq
+Wg_ProofView
+Wg_MessageView
+Wg_Detachable
+Wg_Find
+Wg_Completion
+Wg_ScriptView
 Coq_commands
-Command_windows
+Wg_Command
+FileOps
+Document
+CoqOps
+Session
 Coqide_ui
+NanoPG
 Coqide
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
new file mode 100644
index 00000000..ac38f1ea
--- /dev/null
+++ b/ide/ide_slave.ml
@@ -0,0 +1,505 @@
+(************************************************************************)
+(*  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 Vernacexpr
+open Errors
+open Util
+open Pp
+open Printer
+
+(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
+    function and a rewind function. This specialized loop is triggered
+    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+    the only one using this mode, but we try here to be as generic as
+    possible, so this may change in the future... *)
+
+(** Signal handling: we postpone ^C during input and output phases,
+    but make it directly raise a Sys.Break during evaluation of the request. *)
+
+let catch_break = ref false
+
+let init_signal_handler () =
+  let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in
+  Sys.set_signal Sys.sigint (Sys.Signal_handle f)
+
+
+(** Redirection of standard output to a printable buffer *)
+
+let init_stdout, read_stdout =
+  let out_buff = Buffer.create 100 in
+  let out_ft = Format.formatter_of_buffer out_buff in
+  let deep_out_ft = Format.formatter_of_buffer out_buff in
+  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
+  (fun () ->
+     flush_all ();
+     Pp_control.std_ft := out_ft;
+     Pp_control.err_ft := out_ft;
+     Pp_control.deep_ft := deep_out_ft;
+  ),
+  (fun () -> Format.pp_print_flush out_ft ();
+             let r = Buffer.contents out_buff in
+             Buffer.clear out_buff; r)
+
+let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+
+let pr_debug s =
+  if !Flags.debug then pr_with_pid s
+let pr_debug_call q =
+  if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q)
+let pr_debug_answer q r =
+  if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r)
+
+(** Categories of commands *)
+
+let coqide_known_option table = List.mem table [
+  ["Printing";"Implicit"];
+  ["Printing";"Coercions"];
+  ["Printing";"Matching"];
+  ["Printing";"Synth"];
+  ["Printing";"Notations"];
+  ["Printing";"All"];
+  ["Printing";"Records"];
+  ["Printing";"Existential";"Instances"];
+  ["Printing";"Universes"]]
+
+let is_known_option cmd = match cmd with
+  | VernacSetOption (o,BoolValue true)
+  | VernacUnsetOption o -> coqide_known_option o
+  | _ -> false
+
+let is_debug cmd = match cmd with
+  | VernacSetOption (["Ltac";"Debug"], _) -> true
+  | _ -> false
+
+let is_query cmd = match cmd with
+  | VernacChdir None
+  | VernacMemOption _
+  | VernacPrintOption _
+  | VernacCheckMayEval _
+  | VernacGlobalCheck _
+  | VernacPrint _
+  | VernacSearch _
+  | VernacLocate _ -> true
+  | _ -> false
+
+let is_undo cmd = match cmd with
+  | VernacUndo _ | VernacUndoTo _ -> true
+  | _ -> false
+
+(** Check whether a command is forbidden by CoqIDE *)
+
+let coqide_cmd_checks (loc,ast) =
+  let user_error s = Errors.user_err_loc (loc, "CoqIde", str s) in
+  if is_debug ast then
+    user_error "Debug mode not available within CoqIDE";
+  if is_known_option ast then
+    msg_warning (strbrk"This will not work. Use CoqIDE display menu instead");
+  if Vernac.is_navigation_vernac ast || is_undo ast then
+    msg_warning (strbrk "Rather use CoqIDE navigation instead");
+  if is_query ast then
+    msg_warning (strbrk "Query commands should not be inserted in scripts")
+
+(** Interpretation (cf. [Ide_intf.interp]) *)
+
+let add ((s,eid),(sid,verbose)) =
+  let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in
+  let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in
+  newid, (rc, read_stdout ())
+
+let edit_at id =
+  match Stm.edit_at id with
+  | `NewTip -> CSig.Inl ()
+  | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip))
+
+let query (s,id) = Stm.query ~at:id s; read_stdout ()
+
+let annotate phrase =
+  let (loc, ast) =
+    let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in
+    Vernac.parse_sentence (pa,None)
+  in
+  let (_, _, xml) =
+    Richprinter.richpp_vernac ast
+  in
+  xml
+
+(** Goal display *)
+
+let hyp_next_tac sigma env (id,_,ast) =
+  let id_s = Names.Id.to_string id in
+  let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in
+  [
+    ("clear "^id_s),("clear "^id_s^".");
+    ("apply "^id_s),("apply "^id_s^".");
+    ("exact "^id_s),("exact "^id_s^".");
+    ("generalize "^id_s),("generalize "^id_s^".");
+    ("absurd <"^id_s^">"),("absurd "^type_s^".")
+  ] @ [
+    ("discriminate "^id_s),("discriminate "^id_s^".");
+    ("injection "^id_s),("injection "^id_s^".")
+  ] @ [
+    ("rewrite "^id_s),("rewrite "^id_s^".");
+    ("rewrite <- "^id_s),("rewrite <- "^id_s^".")
+  ] @ [
+    ("elim "^id_s), ("elim "^id_s^".");
+    ("inversion "^id_s), ("inversion "^id_s^".");
+    ("inversion clear "^id_s), ("inversion_clear "^id_s^".")
+  ]
+
+let concl_next_tac sigma concl =
+  let expand s = (s,s^".") in
+  List.map expand ([
+    "intro";
+    "intros";
+    "intuition"
+  ] @ [
+    "reflexivity";
+    "discriminate";
+    "symmetry"
+  ] @ [
+    "assumption";
+    "omega";
+    "ring";
+    "auto";
+    "eauto";
+    "tauto";
+    "trivial";
+    "decide equality";
+    "simpl";
+    "subst";
+    "red";
+    "split";
+    "left";
+    "right"
+  ])
+
+let process_goal sigma g =
+  let env = Goal.V82.env sigma g in
+  let min_env = Environ.reset_context env in
+  let id = Goal.uid g in
+  let ccl =
+    let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
+    string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in
+  let process_hyp d =
+    let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in
+    (string_of_ppcmds (pr_var_list_decl min_env sigma d)) in
+  let hyps =
+    List.map process_hyp
+      (Termops.compact_named_context_reverse (Environ.named_context env)) in
+  { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
+
+let export_pre_goals pgs =
+  {
+    Interface.fg_goals       = pgs.Proof.fg_goals;
+    Interface.bg_goals       = pgs.Proof.bg_goals;
+    Interface.shelved_goals  = pgs.Proof.shelved_goals;
+    Interface.given_up_goals = pgs.Proof.given_up_goals
+  }
+
+let goals () =
+  Stm.finish ();
+  let s = read_stdout () in
+  if not (String.is_empty s) then msg_info (str s);
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    Some (export_pre_goals (Proof.map_structured_proof pfts process_goal))
+  with Proof_global.NoCurrentProof -> None
+
+let evars () =
+  try
+    Stm.finish ();
+    let s = read_stdout () in
+    if not (String.is_empty s) then msg_info (str s);
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in
+    let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar sigma ev); } in
+    let el = List.map map_evar exl in
+    Some el
+  with Proof_global.NoCurrentProof -> None
+
+let hints () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    match all_goals with
+    | [] -> None
+    | g :: _ ->
+      let env = Goal.V82.env sigma g in
+      let hint_goal = concl_next_tac sigma g in
+      let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
+      let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
+      Some (hint_hyps, hint_goal)
+  with Proof_global.NoCurrentProof -> None
+
+
+(** Other API calls *)
+
+let status force =
+  (** We remove the initial part of the current [DirPath.t]
+      (usually Top in an interactive session, cf "coqtop -top"),
+      and display the other parts (opened sections and modules) *)
+  Stm.finish ();
+  if force then Stm.join ();
+  let s = read_stdout () in
+  if not (String.is_empty s) then msg_info (str s);
+  let path =
+    let l = Names.DirPath.repr (Lib.cwd ()) in
+    List.rev_map Names.Id.to_string l
+  in
+  let proof =
+    try Some (Names.Id.to_string (Proof_global.get_current_proof_name ()))
+    with Proof_global.NoCurrentProof -> None
+  in
+  let allproofs =
+    let l = Proof_global.get_all_proof_names () in
+    List.map Names.Id.to_string l
+  in
+  {
+    Interface.status_path = path;
+    Interface.status_proofname = proof;
+    Interface.status_allproofs = allproofs;
+    Interface.status_proofnum = Stm.current_proof_depth ();
+  }
+
+let export_coq_object t = {
+  Interface.coq_object_prefix = t.Search.coq_object_prefix;
+  Interface.coq_object_qualid = t.Search.coq_object_qualid;
+  Interface.coq_object_object = t.Search.coq_object_object
+}
+
+let import_search_constraint = function
+  | Interface.Name_Pattern s    -> Search.Name_Pattern s
+  | Interface.Type_Pattern s    -> Search.Type_Pattern s
+  | Interface.SubType_Pattern s -> Search.SubType_Pattern s
+  | Interface.In_Module ms      -> Search.In_Module ms
+  | Interface.Include_Blacklist -> Search.Include_Blacklist
+
+let search flags =
+  List.map export_coq_object (Search.interface_search (
+    List.map (fun (c, b) -> (import_search_constraint c, b)) flags)
+  )
+
+let export_option_value = function
+  | Goptions.BoolValue b   -> Interface.BoolValue b
+  | Goptions.IntValue x    -> Interface.IntValue x
+  | Goptions.StringValue s -> Interface.StringValue s
+
+let import_option_value = function
+  | Interface.BoolValue b   -> Goptions.BoolValue b
+  | Interface.IntValue x    -> Goptions.IntValue x
+  | Interface.StringValue s -> Goptions.StringValue s
+
+let export_option_state s = {
+  Interface.opt_sync  = s.Goptions.opt_sync;
+  Interface.opt_depr  = s.Goptions.opt_depr;
+  Interface.opt_name  = s.Goptions.opt_name;
+  Interface.opt_value = export_option_value s.Goptions.opt_value;
+}
+
+let get_options () =
+  let table = Goptions.get_tables () in
+  let fold key state accu = (key, export_option_state state) :: accu in
+  Goptions.OptionMap.fold fold table []
+
+let set_options options =
+  let iter (name, value) = match import_option_value value with
+  | BoolValue b -> Goptions.set_bool_option_value name b
+  | IntValue i -> Goptions.set_int_option_value name i
+  | StringValue s -> Goptions.set_string_option_value name s
+  in
+  List.iter iter options
+
+let about () = {
+  Interface.coqtop_version = Coq_config.version;
+  Interface.protocol_version = Xmlprotocol.protocol_version;
+  Interface.release_date = Coq_config.date;
+  Interface.compile_date = Coq_config.compile_date;
+}
+
+let handle_exn (e, info) =
+  let dummy = Stateid.dummy in
+  let loc_of e = match Loc.get_loc e with
+    | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
+    | _ -> None in
+  let mk_msg e = read_stdout ()^"\n"^string_of_ppcmds (Errors.print e) in
+  match e with
+  | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
+  | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+  | e ->
+      match Stateid.get info with
+      | Some (valid, _) -> valid, loc_of info, mk_msg e
+      | None -> dummy, loc_of info, mk_msg e
+
+let init =
+  let initialized = ref false in
+  fun file ->
+   if !initialized then anomaly (str "Already initialized")
+   else begin
+     initialized := true;
+     match file with
+     | None -> Stm.get_current_state ()
+     | Some file ->
+         if not (Filename.check_suffix file ".v") then
+           error "A file with suffix .v is expected.";
+         let dir = Filename.dirname file in
+         let open Loadpath in let open CUnix in
+         let initial_id, _ =
+           if not (is_in_load_paths (physical_path_of_string dir)) then
+             Stm.add false ~ontop:(Stm.get_current_state ())
+               0 (Printf.sprintf "Add LoadPath \"%s\". " dir)
+           else Stm.get_current_state (), `NewTip in
+         Stm.set_compilation_hints file;
+         initial_id
+   end
+
+(* Retrocompatibility stuff *)
+let interp ((_raw, verbose), s) =
+  let vernac_parse s =
+    let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+    Flags.with_option Flags.we_are_parsing (fun () ->
+      match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
+      | None -> raise (Invalid_argument "vernac_parse")
+      | Some ast -> ast)
+    () in
+  Stm.interp verbose (vernac_parse s);
+  Stm.get_current_state (), CSig.Inl (read_stdout ())
+
+(** When receiving the Quit call, we don't directly do an [exit 0],
+    but rather set this reference, in order to send a final answer
+    before exiting. *)
+
+let quit = ref false
+
+(** Grouping all call handlers together + error handling *)
+
+let eval_call xml_oc log c =
+  let interruptible f x =
+    catch_break := true;
+    Control.check_for_interrupt ();
+    let r = f x in
+    catch_break := false;
+    let out = read_stdout () in
+    if not (String.is_empty out) then log (str out);
+    r
+  in
+  let handler = {
+    Interface.add = interruptible add;
+    Interface.edit_at = interruptible edit_at;
+    Interface.query = interruptible query;
+    Interface.goals = interruptible goals;
+    Interface.evars = interruptible evars;
+    Interface.hints = interruptible hints;
+    Interface.status = interruptible status;
+    Interface.search = interruptible search;
+    Interface.get_options = interruptible get_options;
+    Interface.set_options = interruptible set_options;
+    Interface.mkcases = interruptible Vernacentries.make_cases;
+    Interface.quit = (fun () -> quit := true);
+    Interface.init = interruptible init;
+    Interface.about = interruptible about;
+    Interface.interp = interruptible interp;
+    Interface.handle_exn = handle_exn;
+    Interface.stop_worker = Stm.stop_worker;
+    Interface.print_ast = Stm.print_ast;
+    Interface.annotate = interruptible annotate;
+  } in
+  Xmlprotocol.abstract_eval_call handler c
+
+(** Message dispatching.
+    Since coqtop -ideslave starts 1 thread per slave, and each
+    thread forwards feedback messages from the slave to the GUI on the same
+    xml channel, we need mutual exclusion.  The mutex should be per-channel, but
+    here we only use 1 channel. *)
+let print_xml =
+  let m = Mutex.create () in
+  fun oc xml ->
+    Mutex.lock m;
+    try Xml_printer.print oc xml; Mutex.unlock m
+    with e -> let e = Errors.push e in Mutex.unlock m; iraise e
+
+
+let slave_logger xml_oc level message =
+  (* convert the message into XML *)
+  let msg = string_of_ppcmds (hov 0 message) in
+  let message = {
+    Pp.message_level = level;
+    Pp.message_content = msg;
+  } in
+  let () = pr_debug (Printf.sprintf "-> %S" msg) in
+  let xml = Pp.of_message message in
+  print_xml xml_oc xml
+
+let slave_feeder xml_oc msg =
+  let xml = Feedback.of_feedback msg in
+  print_xml xml_oc xml
+
+(** The main loop *)
+
+(** Exceptions during eval_call should be converted into [Interface.Fail]
+    messages by [handle_exn] above. Otherwise, we die badly, without
+    trying to answer malformed requests. *)
+
+let loop () =
+  init_signal_handler ();
+  catch_break := false;
+  let in_ch, out_ch = Spawned.get_channels () in
+  let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in
+  let in_lb = Lexing.from_function (fun s len ->
+    CThread.thread_friendly_read in_ch s ~off:0 ~len) in
+  let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
+  let () = Xml_parser.check_eof xml_ic false in
+  set_logger (slave_logger xml_oc);
+  set_feeder (slave_feeder xml_oc);
+  (* We'll handle goal fetching and display in our own way *)
+  Vernacentries.enable_goal_printing := false;
+  Vernacentries.qed_display_script := false;
+  while not !quit do
+    try
+      let xml_query = Xml_parser.parse xml_ic in
+(*       pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
+      let q = Xmlprotocol.to_call xml_query in
+      let () = pr_debug_call q in
+      let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in
+      let () = pr_debug_answer q r in
+(*       pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *)
+      print_xml xml_oc (Xmlprotocol.of_answer q r);
+      flush out_ch
+    with
+      | Xml_parser.Error (Xml_parser.Empty, _) ->
+        pr_debug "End of input, exiting gracefully.";
+        exit 0
+      | Xml_parser.Error (err, loc) ->
+        pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err);
+        exit 1
+      | Serialize.Marshal_error ->
+        pr_debug "Incorrect query.";
+        exit 1
+      | any ->
+        pr_debug ("Fatal exception in coqtop:\n" ^ Printexc.to_string any);
+        exit 1
+  done;
+  pr_debug "Exiting gracefully.";
+  exit 0
+
+let rec parse = function
+  | "--help-XML-protocol" :: rest ->
+        Xmlprotocol.document Xml_printer.to_string_fmt; exit 0
+  | x :: rest -> x :: parse rest
+  | [] -> []
+
+let () = Coqtop.toploop_init := (fun args ->
+        let args = parse args in
+        Flags.make_silent true;
+        init_stdout ();
+        CoqworkmgrApi.(init Flags.High);
+        args)
+
+let () = Coqtop.toploop_run := loop
+
+let () = Usage.add_to_usage "coqidetop" "  --help-XML-protocol    print the documentation of the XML protocol used by CoqIDE\n"
diff --git a/ide/ide_win32_stubs.c b/ide/ide_win32_stubs.c
index c170b1a9..c09bf37d 100644
--- a/ide/ide_win32_stubs.c
+++ b/ide/ide_win32_stubs.c
@@ -19,33 +19,31 @@ CAMLprim value win32_kill(value pseudopid) {
   CAMLreturn(Val_unit);
 }
 
-/* Win32 emulation of a kill -2 (SIGINT) */
 
-/* For simplicity, we signal all processes sharing a console with coqide.
-   This shouldn't be an issue since currently at most one coqtop is busy
-   at a given time. Earlier, we tried to be more precise via
-   FreeConsole and AttachConsole before generating the Ctrl-C, but
-   that wasn't working so well (see #2869).
-   This code rely now on the fact that coqide is a console app,
-   and that coqide itself ignores Ctrl-C.
-*/
+/* Win32 emulation of a kill -2 (SIGINT) */
 
-CAMLprim value win32_interrupt_all(value unit) {
-  CAMLparam1(unit);
-  GenerateConsoleCtrlEvent(CTRL_C_EVENT,0);
-  CAMLreturn(Val_unit);
-}
+/* This code rely of the fact that coqide is now without initial console.
+   Otherwise, no console creation in win32unix/createprocess.c, hence
+   the same console for coqide and all coqtop, and everybody will be
+   signaled at the same time by the code below. */
 
-/* Get rid of the nasty console window (only if we created it) */
+/* Moreover, AttachConsole exists only since WinXP, and GetProcessId
+   since WinXP SP1. For avoiding the GetProcessId, we could adapt code
+   from win32unix/createprocess.c to make it return both the pid and the
+   handle. For avoiding the AttachConsole, I don't know, maybe having
+   an intermediate process between coqide and coqtop ? */
 
-CAMLprim value win32_hide_console (value unit) {
-  CAMLparam1(unit);
+CAMLprim value win32_interrupt(value pseudopid) {
+  CAMLparam1(pseudopid);
+  HANDLE h;
   DWORD pid;
-  HWND hw = GetConsoleWindow();
-  if (hw != NULL) {
-    GetWindowThreadProcessId(hw, &pid);
-    if (pid == GetCurrentProcessId())
-      ShowWindow(hw, SW_HIDE);
-  }
+  FreeConsole(); /* Normally unnecessary, just to be sure... */
+  h = (HANDLE)(Long_val(pseudopid));
+  pid = GetProcessId(h);
+  AttachConsole(pid);
+  /* We want to survive the Ctrl-C that will also concerns us */
+  SetConsoleCtrlHandler(NULL,TRUE); /* NULL + TRUE means ignore */
+  GenerateConsoleCtrlEvent(CTRL_C_EVENT,0); /* signal our co-console */
+  FreeConsole();
   CAMLreturn(Val_unit);
 }
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index 1b4941b6..d2305b58 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.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        *)
@@ -11,13 +11,27 @@ open Preferences
 
 exception Forbidden
 
+let warn_image () =
+  let img = GMisc.image () in
+  img#set_stock `DIALOG_WARNING;
+  img#set_icon_size `DIALOG;
+  img
+
+let warning msg = 
+   GToolbox.message_box ~title:"Warning" ~icon:(warn_image ())#coerce msg 
+
+let cb = GData.clipboard Gdk.Atom.primary
+
 (* status bar and locations *)
 
 let status = GMisc.statusbar ()
 
-let push_info,pop_info =
+let push_info,pop_info,clear_info =
   let status_context = status#new_context ~name:"Messages" in
-    (fun s -> ignore (status_context#push s)),status_context#pop
+  let size = ref 0 in
+  (fun s -> incr size; ignore (status_context#push s)),
+  (fun () -> decr size; status_context#pop ()),
+  (fun () -> for i = 1 to !size do status_context#pop () done; size := 0)
 
 let flash_info =
   let flash_context = status#new_context ~name:"Flash" in
@@ -27,61 +41,44 @@ let flash_info =
 
 let set_location = ref  (function s -> failwith "not ready")
 
-let pbar = GRange.progress_bar ~pulse_step:0.2 ()
-
-let debug = ref (false)
+(** A utf8 char is either a single byte (ascii char, 0xxxxxxx)
+    or multi-byte (with a leading byte 11xxxxxx and extra bytes 10xxxxxx) *)
 
-let prerr_endline s =
-  if !debug then try prerr_endline s;flush stderr with _ -> ()
+let is_extra_byte c = ((Char.code c) lsr 6 = 2)
 
-let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT
-
-let is_char_start c = let code = Char.code c in code < 0x80 || code >= 0xc0
+(** For a string buffer that may contain utf8 chars,
+    we convert a byte offset into a char offset
+    by only counting char-starting bytes.
+    Normally the string buffer starts with a char-starting byte
+    (buffer produced by a [#get_text]) *)
 
 let byte_offset_to_char_offset s byte_offset =
-  if (byte_offset < String.length s) then begin
-    let count_delta = ref 0 in
-    for i = 0 to byte_offset do
-      let code = Char.code s.[i] in
-      if code >= 0x80 && code < 0xc0 then incr count_delta
-    done;
-    byte_offset - !count_delta
-  end
-  else begin
-    let count_delta = ref 0 in
-    for i = 0 to String.length s - 1 do
-      let code = Char.code s.[i] in
-      if code >= 0x80 && code < 0xc0 then incr count_delta
-    done;
-    byte_offset - !count_delta
-  end
-
-let print_id id =
-  prerr_endline ("GOT sig id :"^(string_of_int (Obj.magic id)))
+  let extra_bytes = ref 0 in
+  for i = 0 to min byte_offset (String.length s - 1) do
+    if is_extra_byte s.[i] then incr extra_bytes
+  done;
+  byte_offset - !extra_bytes
 
+let glib_utf8_pos_to_offset s ~off = byte_offset_to_char_offset s off
 
 let do_convert s =
-  Utf8_convert.f
-    (if Glib.Utf8.validate s then begin
-      prerr_endline "Input is UTF-8";s
-    end else
-	let from_loc () =
-	  let _,char_set = Glib.Convert.get_charset () in
-	  flash_info
-	    ("Converting from locale ("^char_set^")");
-	  Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
-	in
-	let from_manual enc =
-	  flash_info
-	    ("Converting from "^ enc);
-	  Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
-	in
-	match !current.encoding with
-	  |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
-	  |Emanual enc ->
-	    try
-	      from_manual enc
-	    with _ -> from_loc ())
+  let from_loc () =
+    let _,char_set = Glib.Convert.get_charset () in
+    flash_info ("Converting from locale ("^char_set^")");
+    Glib.Convert.convert_with_fallback
+      ~to_codeset:"UTF-8" ~from_codeset:char_set s
+  in
+  let from_manual enc =
+    flash_info ("Converting from "^ enc);
+    Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
+  in
+  let s =
+    if Glib.Utf8.validate s then (Minilib.log "Input is UTF-8"; s)
+    else match current.encoding with
+      |Preferences.Eutf8 | Preferences.Elocale -> from_loc ()
+      |Emanual enc -> try from_manual enc with _ -> from_loc ()
+  in
+  Utf8_convert.f s
 
 let try_convert s =
   try
@@ -92,54 +89,48 @@ Please choose a correct encoding in the preference panel.*)";;
 
 
 let try_export file_name s =
-  try let s =
-    try match !current.encoding with
-      |Eutf8 -> begin
-	(prerr_endline "UTF-8 is enforced" ;s)
-      end
-      |Elocale -> begin
+  let s =
+    try match current.encoding with
+      |Eutf8 -> Minilib.log "UTF-8 is enforced" ; s
+      |Elocale ->
 	let is_unicode,char_set = Glib.Convert.get_charset () in
 	if is_unicode then
-	  (prerr_endline "Locale is UTF-8" ;s)
+	  (Minilib.log "Locale is UTF-8" ; s)
 	else
-	  (prerr_endline ("Locale is "^char_set);
-	   Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
-      end
+	  (Minilib.log ("Locale is "^char_set);
+	   Glib.Convert.convert_with_fallback
+             ~from_codeset:"UTF-8" ~to_codeset:char_set s)
       |Emanual enc ->
-	(prerr_endline ("Manual charset is "^ enc);
-       Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s)
-    with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
+	(Minilib.log ("Manual charset is "^ enc);
+         Glib.Convert.convert_with_fallback
+           ~from_codeset:"UTF-8" ~to_codeset:enc s)
+    with e ->
+      let str = Printexc.to_string e in
+      Minilib.log ("Error ("^str^") in transcoding: falling back to UTF-8");
+      s
   in
-  let oc = open_out file_name in
-  output_string oc s;
-  close_out oc;
-  true
-  with e -> prerr_endline (Printexc.to_string e);false
-
-let my_stat f = try Some (Unix.stat f) with _ -> None
-
-let revert_timer = ref None
-let disconnect_revert_timer () = match !revert_timer with
-  | None -> ()
-  | Some id -> GMain.Timeout.remove id; revert_timer := None
-
-let auto_save_timer = ref None
-let disconnect_auto_save_timer () = match !auto_save_timer with
-  | None -> ()
-  | Some id -> GMain.Timeout.remove id; auto_save_timer := None
-
-let highlight_timer = ref None
-let set_highlight_timer f =
-  match !highlight_timer with
-    | None ->
-	revert_timer :=
-      Some (GMain.Timeout.add ~ms:2000
-	      ~callback:(fun () -> f (); highlight_timer := None; true))
-    | Some id ->
-	GMain.Timeout.remove id;
-	revert_timer :=
-	Some (GMain.Timeout.add ~ms:2000
-		~callback:(fun () -> f (); highlight_timer := None; true))
+  try
+    let oc = open_out file_name in
+    output_string oc s;
+    close_out oc;
+    true
+  with e -> Minilib.log (Printexc.to_string e);false
+
+type timer = { run : ms:int -> callback:(unit->bool) -> unit;
+               kill : unit -> unit }
+
+let mktimer () =
+  let timer = ref None in
+  { run =
+      (fun ~ms ~callback ->
+          timer := Some (GMain.Timeout.add ~ms ~callback));
+    kill =
+      (fun () -> match !timer with
+        | None -> ()
+        | Some id ->
+            (try GMain.Timeout.remove id
+             with Glib.GError _ -> ());
+             timer := None) }
 
 let last_dir = ref ""
 
@@ -151,55 +142,62 @@ let filter_coq_files () =  GFile.filter
   ~name:"Coq source code"
   ~patterns:[ "*.v"] ()
 
-let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () =
+let select_file_for_open ~title () =
   let file = ref None in
-  let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in
-    file_chooser#add_button_stock `CANCEL `CANCEL ;
-    file_chooser#add_select_button_stock `OPEN `OPEN ;
-    file_chooser#add_filter (filter_coq_files ());
-    file_chooser#add_filter (filter_all_files ());
-    file_chooser#set_default_response `OPEN;
-    ignore (file_chooser#set_current_folder !dir);
-    begin match file_chooser#run () with
-      | `OPEN ->
-	  begin
-	    file := file_chooser#filename;
-	    match !file with
-		None -> ()
-	      | Some s -> dir := Filename.dirname s;
-	  end
-      | `DELETE_EVENT | `CANCEL -> ()
-    end ;
-    file_chooser#destroy ();
-    !file
-
-
-let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () =
+  let file_chooser =
+    GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ()
+  in
+  file_chooser#add_button_stock `CANCEL `CANCEL ;
+  file_chooser#add_select_button_stock `OPEN `OPEN ;
+  file_chooser#add_filter (filter_coq_files ());
+  file_chooser#add_filter (filter_all_files ());
+  file_chooser#set_default_response `OPEN;
+  ignore (file_chooser#set_current_folder !last_dir);
+  begin match file_chooser#run () with
+    | `OPEN ->
+      begin
+	file := file_chooser#filename;
+	match !file with
+	  | None -> ()
+	  | Some s -> last_dir := Filename.dirname s;
+      end
+    | `DELETE_EVENT | `CANCEL -> ()
+  end ;
+  file_chooser#destroy ();
+  !file
+
+let select_file_for_save ~title ?filename () =
   let file = ref None in
-  let file_chooser = GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () in
-    file_chooser#add_button_stock `CANCEL `CANCEL ;
-    file_chooser#add_select_button_stock `SAVE `SAVE ;
-    file_chooser#add_filter (filter_coq_files ());
-    file_chooser#add_filter (filter_all_files ());
-  (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions
-       file_chooser#set_do_overwrite_confirmation true;
-     *)
-    file_chooser#set_default_response `SAVE;
-    ignore (file_chooser#set_current_folder !dir);
-    ignore (file_chooser#set_current_name filename);
-
-    begin match file_chooser#run () with
-      | `SAVE ->
-	  begin
-	    file := file_chooser#filename;
-	    match !file with
-		None -> ()
-	      | Some s -> dir := Filename.dirname s;
-	  end
-      | `DELETE_EVENT | `CANCEL -> ()
-    end ;
-    file_chooser#destroy ();
-    !file
+  let file_chooser =
+    GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ()
+  in
+  file_chooser#add_button_stock `CANCEL `CANCEL ;
+  file_chooser#add_select_button_stock `SAVE `SAVE ;
+  file_chooser#add_filter (filter_coq_files ());
+  file_chooser#add_filter (filter_all_files ());
+  (* this line will be used when a lablgtk >= 2.10.0 is the default
+     on most distributions:
+     file_chooser#set_do_overwrite_confirmation true;
+  *)
+  file_chooser#set_default_response `SAVE;
+  let dir,filename = match filename with
+    |None -> !last_dir, ""
+    |Some f -> Filename.dirname f, Filename.basename f
+  in
+  ignore (file_chooser#set_current_folder dir);
+  ignore (file_chooser#set_current_name filename);
+  begin match file_chooser#run () with
+    | `SAVE ->
+      begin
+        file := file_chooser#filename;
+        match !file with
+            None -> ()
+          | Some s -> last_dir := Filename.dirname s;
+      end
+    | `DELETE_EVENT | `CANCEL -> ()
+  end ;
+  file_chooser#destroy ();
+  !file
 
 let find_tag_start (tag :GText.tag) (it:GText.iter) =
   let it = it#copy in
@@ -218,38 +216,19 @@ let find_tag_stop (tag :GText.tag) (it:GText.iter) =
 let find_tag_limits (tag :GText.tag) (it:GText.iter) =
  (find_tag_start tag it , find_tag_stop tag it)
 
-(* explanations: Win32 threads won't work if events are produced
-   in a thread different from the thread of the Gtk loop. In this
-   case we must use GtkThread.async to push a callback in the
-   main thread. Beware that the synchronus version may produce
-   deadlocks. *)
-let async =
-  if Sys.os_type = "Win32" then GtkThread.async else (fun x -> x)
-let sync =
-  if Sys.os_type = "Win32" then GtkThread.sync else (fun x -> x)
-
-let mutex text f =
-  let m = Mutex.create() in
-  fun x ->
-    if Mutex.try_lock m
-    then
-      (try
-        prerr_endline ("Got lock on "^text);
-        f x;
-        Mutex.unlock m;
-        prerr_endline ("Released lock on "^text)
-      with e ->
-        Mutex.unlock m;
-        prerr_endline ("Released lock on "^text^" (on error)");
-        raise e)
-    else
-      prerr_endline
-        ("Discarded call for "^text^": computations ongoing")
-
-
-let stock_to_widget ?(size=`DIALOG) s =
-  let img = GMisc.image ()
-  in img#set_stock s;
+let stock_to_widget ?(size=`BUTTON) s =
+  let img = GMisc.image () in
+  (match size with
+    | `CUSTOM(width,height) ->
+         let opb = img#misc#render_icon ~size:`BUTTON s in
+         let pb = GdkPixbuf.create ~width ~height
+           ~bits:(GdkPixbuf.get_bits_per_sample opb)
+           ~has_alpha:(GdkPixbuf.get_has_alpha opb) () in
+         GdkPixbuf.scale ~width ~height ~dest:pb opb;
+         img#set_pixbuf pb
+    | #Gtk.Tags.icon_size as icon_size ->
+         img#set_stock s;
+         img#set_icon_size icon_size);
   img#coerce
 
 let custom_coqtop = ref None
@@ -258,23 +237,19 @@ let coqtop_path () =
   let file = match !custom_coqtop with
     | Some s -> s
     | None ->
-      match !current.cmd_coqtop with
+      match current.cmd_coqtop with
 	| Some s -> s
 	| None ->
 	  let prog = String.copy Sys.executable_name in
 	  try
 	    let pos = String.length prog - 6 in
-	    let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
+	    let i = Str.search_backward (Str.regexp_string "coqide") prog pos
+            in
 	    String.blit "coqtop" 0 prog i 6;
-	    prog
+	    if Sys.file_exists prog then prog else "coqtop"
 	  with Not_found -> "coqtop"
   in file
 
-let rec print_list print fmt = function
-  | [] -> ()
-  | [x] -> print fmt x
-  | x :: r -> print fmt x; print_list print fmt r
-
 (* In win32, when a command-line is to be executed via cmd.exe
    (i.e. Sys.command, Unix.open_process, ...), it cannot contain several
    quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
@@ -282,76 +257,160 @@ let rec print_list print fmt = function
 
 let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd
 
-(* TODO: allow to report output as soon as it comes (user-fiendlier
-   for long commands like make...) *)
-let run_command f c =
-  let c = requote c in
-  let result = Buffer.create 127 in
-  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
-  let buff = String.make 127 ' ' in
-  let buffe = String.make 127 ' ' in
-  let n = ref 0 in
-  let ne = ref 0 in
-  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0
-  do
-    let r = try_convert (String.sub buff 0 !n) in
-    f r;
-    Buffer.add_string result r;
-    let r = try_convert (String.sub buffe 0 !ne) in
-    f r;
-    Buffer.add_string result r
-  done;
-  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
-
-let browse f url =
-  let com = Minilib.subst_command_placeholder !current.cmd_browse url in
-  let _ = Unix.open_process_out com in ()
-(* This beautiful message will wait for twt ...
-  if s = 127 then
-    f ("Could not execute\n\""^com^
-       "\"\ncheck your preferences for setting a valid browser command\n")
-*)
+let textview_width (view : #GText.view_skel) =
+  let rect = view#visible_rect in
+  let pixel_width = Gdk.Rectangle.width rect in
+  let metrics = view#misc#pango_context#get_metrics ()  in
+  let char_width = GPango.to_pixels metrics#approx_char_width in
+  pixel_width / char_width
+
+type logger = Pp.message_level -> string -> unit
+
+let default_logger level message =
+  let level = match level with
+  | Pp.Debug _ -> `DEBUG
+  | Pp.Info -> `INFO
+  | Pp.Notice -> `NOTICE
+  | Pp.Warning -> `WARNING
+  | Pp.Error -> `ERROR
+  in
+  Minilib.log ~level message
+
+
+(** {6 File operations} *)
+
+(** A customized [stat] function. Exceptions are catched. *)
+
+type stats = MTime of float | NoSuchFile | OtherError
+
+let stat f =
+  try MTime (Unix.stat f).Unix.st_mtime
+  with
+    | Unix.Unix_error (Unix.ENOENT,_,_) -> NoSuchFile
+    | _ -> OtherError
+
+(** I/O utilities
+
+    Note: In a mono-thread coqide, we use the same buffer for
+    different read operations *)
+
+let maxread = 4096
+
+let read_string = String.create maxread
+let read_buffer = Buffer.create maxread
+
+(** Read the content of file [f] and add it to buffer [b].
+    I/O Exceptions are propagated. *)
+
+let read_file name buf =
+  let ic = open_in name in
+  let len = ref 0 in
+  try
+    while len := input ic read_string 0 maxread; !len > 0 do
+      Buffer.add_substring buf read_string 0 !len
+    done;
+    close_in ic
+  with e -> close_in ic; raise e
+
+(** Read what is available on a gtk channel. This channel should have been
+    set as non-blocking. When there's nothing more to read, the inner loop
+    will be exited via a GError exception concerning a EAGAIN unix error.
+    Anyway, any other exception also stops the read. *)
+
+let io_read_all chan =
+  Buffer.clear read_buffer;
+  let read_once () =
+    let len = Glib.Io.read_chars ~buf:read_string ~pos:0 ~len:maxread chan in
+    Buffer.add_substring read_buffer read_string 0 len
+  in
+  begin
+    try while true do read_once () done
+    with Glib.GError _ -> ()
+  end;
+  Buffer.contents read_buffer
+
+(** Run an external command asynchronously *)
+
+let run_command display finally cmd =
+  let cin = Unix.open_process_in cmd in
+  let fd = Unix.descr_of_in_channel cin in
+  let () = Unix.set_nonblock fd in
+  let io_chan = Glib.Io.channel_of_descr fd in
+  let all_conds = [`ERR; `HUP; `IN; `NVAL; `PRI] in (* all except `OUT *)
+  let rec has_errors = function
+    | [] -> false
+    | (`IN | `PRI) :: conds -> has_errors conds
+    | e :: _ -> true
+  in
+  let handle_end () = finally (Unix.close_process_in cin); false
+  in
+  let handle_input conds =
+    if has_errors conds then handle_end ()
+    else
+      let s = io_read_all io_chan in
+      if s = "" then handle_end ()
+      else (display (try_convert s); true)
+  in
+  ignore (Glib.Io.add_watch ~cond:all_conds ~callback:handle_input io_chan)
+
+(** Web browsing *)
+
+let browse prerr url =
+  let com = Util.subst_command_placeholder current.cmd_browse url in
+  let finally = function
+    | Unix.WEXITED 127 ->
+      prerr
+        ("Could not execute:\n"^com^"\n"^
+         "check your preferences for setting a valid browser command\n")
+    | _ -> ()
+  in
+  run_command (fun _ -> ()) finally com
+
 let doc_url () =
-  if !current.doc_url = use_default_doc_url || !current.doc_url = "" then
-    let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in
+  if current.doc_url = use_default_doc_url || current.doc_url = ""
+  then
+    let addr = List.fold_left Filename.concat (Coq_config.docdir)
+      ["html";"refman";"index.html"]
+    in
     if Sys.file_exists addr then "file://"^addr else Coq_config.wwwrefman
-  else !current.doc_url
+  else current.doc_url
 
 let url_for_keyword =
   let ht = Hashtbl.create 97 in
     lazy (
       begin try
-	let cin =
-	  try let index_urls = Filename.concat (List.find
+        let cin =
+          try let index_urls = Filename.concat (List.find
             (fun x -> Sys.file_exists (Filename.concat x "index_urls.txt"))
-	    Minilib.xdg_config_dirs) "index_urls.txt" in
-	    open_in index_urls
-	  with Not_found ->
-	    let doc_url = doc_url () in
-	    let n = String.length doc_url in
-	      if n > 8 && String.sub doc_url 0 7 = "file://" then
-		open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
-	      else
-		raise Exit
-	in
-	  try while true do
-	    let s = input_line cin in
-	      try
-		let i = String.index s ',' in
-		let k = String.sub s 0 i in
-		let u = String.sub s (i + 1) (String.length s - i - 1) in
-		  Hashtbl.add ht k u
-	      with _ ->
-		Minilib.safe_prerr_endline "Warning: Cannot parse documentation index file."
-	  done with End_of_file ->
-	    close_in cin
+            (Minilib.coqide_data_dirs ())) "index_urls.txt" in
+            open_in index_urls
+          with Not_found ->
+            let doc_url = doc_url () in
+            let n = String.length doc_url in
+              if n > 8 && String.sub doc_url 0 7 = "file://" then
+                open_in (String.sub doc_url 7 (n-7) ^ "index_urls.txt")
+              else
+                raise Exit
+        in
+          try while true do
+            let s = input_line cin in
+              try
+                let i = String.index s ',' in
+                let k = String.sub s 0 i in
+                let u = String.sub s (i + 1) (String.length s - i - 1) in
+                  Hashtbl.add ht k u
+              with _ ->
+                Minilib.log "Warning: Cannot parse documentation index file."
+          done with End_of_file ->
+            close_in cin
       with _ ->
-	Minilib.safe_prerr_endline "Warning: Cannot find documentation index file."
+        Minilib.log "Warning: Cannot find documentation index file."
       end;
       Hashtbl.find ht : string -> string)
 
-let browse_keyword f text =
-  try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u)
-  with Not_found -> f ("No documentation found for \""^text^"\".\n")
+let browse_keyword prerr text =
+  try
+    let u = Lazy.force url_for_keyword text in
+    browse prerr (doc_url() ^ u)
+  with Not_found -> prerr ("No documentation found for \""^text^"\".\n")
 
-let absolute_filename f = Minilib.correct_path f (Sys.getcwd ())
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index c8493825..8269582d 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -1,56 +1,42 @@
 (************************************************************************)
 (*  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 async : ('a -> unit) -> 'a -> unit
-val sync  : ('a -> 'b) -> 'a -> 'b
+val warn_image : unit -> GMisc.image
+val warning : string -> unit
 
-(* avoid running two instances of a function concurrently *)
-val mutex : string -> ('a -> unit) -> 'a -> unit
+val cb : GData.clipboard
 
 val doc_url : unit -> string
 val browse : (string -> unit) -> string -> unit
 val browse_keyword : (string -> unit) -> string -> unit
+
+(* These two functions are equivalent, the latter is named following
+   glib schema, and exists in glib but is not in lablgtk2 *)
 val byte_offset_to_char_offset : string -> int -> int
-val debug : bool ref
-val disconnect_revert_timer : unit -> unit
-val disconnect_auto_save_timer : unit -> unit
+val glib_utf8_pos_to_offset : string -> off:int -> int
+
+type timer = { run : ms:int -> callback:(unit->bool) -> unit;
+               kill : unit -> unit }
+val mktimer : unit -> timer
+
 val do_convert : string -> string
 val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter
 val find_tag_start : GText.tag -> GText.iter -> GText.iter
 val find_tag_stop : GText.tag -> GText.iter -> GText.iter
-val get_insert : < get_iter_at_mark : [> `INSERT] -> 'a; .. > -> 'a
-
-val is_char_start : char -> bool
-
-val my_stat : string -> Unix.stats option
-
-(** debug printing *)
-val prerr_endline : string -> unit
 
-val print_id : 'a -> unit
-
-val revert_timer : GMain.Timeout.id option ref
-val auto_save_timer : GMain.Timeout.id option ref
-val select_file_for_open :
-  title:string ->
-  ?dir:string ref -> ?filename:string -> unit -> string option
+val select_file_for_open : title:string -> unit -> string option
 val select_file_for_save :
-  title:string ->
-  ?dir:string ref -> ?filename:string -> unit -> string option
-val set_highlight_timer : (unit -> 'a) -> unit
+  title:string -> ?filename:string -> unit -> string option
 val try_convert : string -> string
 val try_export : string -> string -> bool
-val stock_to_widget :  ?size:Gtk.Tags.icon_size -> GtkStock.id -> GObj.widget
-
-open Format
-val print_list : (formatter -> 'a -> unit) -> formatter -> 'a list -> unit
-
-val run_command : (string -> unit) -> string -> Unix.process_status*string
+val stock_to_widget :
+  ?size:[`CUSTOM of int * int | Gtk.Tags.icon_size] ->
+    GtkStock.id -> GObj.widget
 
 val custom_coqtop : string option ref
 (* @return command to call coqtop
@@ -63,20 +49,47 @@ val coqtop_path : unit -> string
 val status : GMisc.statusbar
 val push_info : string -> unit
 val pop_info : unit -> unit
+val clear_info : unit -> unit
 val flash_info : ?delay:int -> string -> unit
 
 val set_location : (string -> unit) ref
 
-val pbar : GRange.progress_bar
-
-(*
-  returns an absolute filename equivalent to given filename
-*)
-val absolute_filename : string -> string
-
 (* In win32, when a command-line is to be executed via cmd.exe
    (i.e. Sys.command, Unix.open_process, ...), it cannot contain several
    quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
    everything. Reference: http://ss64.com/nt/cmd.html *)
 
 val requote : string -> string
+
+val textview_width : #GText.view_skel -> int
+(** Returns an approximate value of the character width of a textview *)
+
+type logger = Pp.message_level -> string -> unit
+
+val default_logger : Pp.message_level -> string -> unit
+(** Default logger. It logs messages that the casual user should not see. *)
+
+(** {6 I/O operations} *)
+
+(** A customized [stat] function. Exceptions are catched. *)
+
+type stats = MTime of float | NoSuchFile | OtherError
+val stat : string -> stats
+
+(** Read the content of file [f] and add it to buffer [b].
+    I/O Exceptions are propagated. *)
+
+val read_file : string -> Buffer.t -> unit
+
+(** Read what is available on a gtk input channel.
+    This channel should have been set as non-blocking. *)
+
+val io_read_all : Glib.Io.channel -> string
+
+(** [run_command display finally cmd] allow to run a command
+    asynchronously, calling [display] on any output of this command
+    and [finally] when the command has returned. *)
+
+val run_command :
+  (string -> unit) -> (Unix.process_status -> unit) -> string -> unit
+
diff --git a/toplevel/interface.mli b/ide/interface.mli
index bb338a96..464e851f 100644
--- a/toplevel/interface.mli
+++ b/ide/interface.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        *)
@@ -35,31 +35,35 @@ type status = {
   (** Current proof name. [None] if no focussed proof is in progress *)
   status_allproofs : string list;
   (** List of all pending proofs. Order is not significant *)
-  status_statenum : int;
-  (** A unique id describing the state of coqtop *)
   status_proofnum : int;
   (** An id describing the state of the current proof. *)
 }
 
-type goals = {
-  fg_goals : goal list;
+type 'a pre_goals = {
+  fg_goals : 'a list;
   (** List of the focussed goals *)
-  bg_goals : (goal list * goal list) list;
-  (** Zipper representing the unfocussed background goals *)
+  bg_goals : ('a list * 'a list) list;
+  (** Zipper representing the unfocused background goals *)
+  shelved_goals : 'a list;
+  (** List of the goals on the shelf. *)
+  given_up_goals : 'a list;
+  (** List of the goals that have been given up *)
 }
 
+type goals = goal pre_goals
+
 type hint = (string * string) list
 (** A list of tactics applicable and their appearance *)
 
-type option_name = Goptionstyp.option_name
+type option_name = string list
 
-type option_value = Goptionstyp.option_value =
+type option_value =
   | BoolValue   of bool
   | IntValue    of int option
   | StringValue of string
 
 (** Summary of an option status *)
-type option_state = Goptionstyp.option_state = {
+type option_state = {
   opt_sync  : bool;
   (** Whether an option is synchronous *)
   opt_depr  : bool;
@@ -103,61 +107,44 @@ type coq_info = {
   compile_date : string;
 }
 
-(** Coq unstructured messages *)
-
-type message_level =
-  | Debug of string
-  | Info
-  | Notice
-  | Warning
-  | Error
-
-type message = {
-  message_level : message_level;
-  message_content : string;
-}
-
-(** Coq "semantic" infos obtained during parsing/execution *)
-type edit_id = int
-
-type feedback_content =
-  | AddedAxiom
-  | Processed
-  | GlobRef of (int*int) * string * string * string * string
-
-type feedback = {
-  edit_id : edit_id;
-  content : feedback_content;
-}
-
 (** Calls result *)
 
 type location = (int * int) option (* start and end of the error *)
+type state_id = Feedback.state_id
+type edit_id = Feedback.edit_id
 
+(* The fail case carries the current state_id of the prover, the GUI
+   should probably retract to that point *)
 type 'a value =
   | Good of 'a
-  | Fail of (location * string)
+  | Fail of (state_id * location * string)
+
+type ('a, 'b) union = ('a, 'b) Util.union
 
 (* Request/Reply message protocol between Coq and CoqIde *)
 
-(** Running a command (given as its id and its text).
-    "raw" mode (less sanity checks, no impact on the undo stack)
-    is suitable for queries, or for the Set/Unset
-    of display options that coqide performs all the time.
-    The returned string contains the messages produced
-    but not the updated goals (they are
-    to be fetch by a separated [current_goals]). *)
-type interp_sty = edit_id * raw * verbose * string
-type interp_rty = string
-
-(** Backtracking by at least a certain number of phrases.
-    No finished proofs will be re-opened. Instead,
-    we continue backtracking until before these proofs,
-    and answer the amount of extra backtracking performed.
-    Backtracking by more than the number of phrases already
-    interpreted successfully (and not yet undone) will fail. *)
-type rewind_sty = int
-type rewind_rty = int
+(**  [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid]
+     on top of the current edit position (that is asserted to be [sid])
+     verbosely if [v] is true.  The response [(id,(rc,s)] is the new state
+     [id] assigned to the phrase, some output [s].  [rc] is [Inl] if the new
+     state id is the tip of the edit point, or [Inr tip] if the new phrase
+     closes a focus and [tip] is the new edit tip *)
+type add_sty = (string * edit_id) * (state_id * verbose)
+type add_rty = state_id * ((unit, state_id) union * string)
+
+(** [edit_at id] declares the user wants to edit just after [id].
+    The response is [Inl] if the document has been rewound to that point,
+    [Inr (start,(stop,tip))] if [id] is in a zone that can be focused.
+    In that case the zone is delimited by [start] and [stop] while [tip]
+    is the new document [tip].  Edits made by subsequent [add] are always
+    performend on top of [id]. *)
+type edit_at_sty = state_id
+type edit_at_rty = (unit, state_id * (state_id * state_id)) union
+
+(** [query s id] executes [s] at state [id] and does not record any state
+    change but for the printings that are sent in response *)
+type query_sty = string * state_id
+type query_rty = string
 
 (** Fetching the list of current goals. Return [None] if no proof is in
     progress, [Some gl] otherwise. *)
@@ -174,8 +161,10 @@ type evars_rty = evar list option
 type hints_sty = unit
 type hints_rty = (hint list * hint) option
 
-(** The status, for instance "Ready in SomeSection, proving Foo" *)
-type status_sty = unit
+(** The status, for instance "Ready in SomeSection, proving Foo", the
+    input boolean (if true) forces the evaluation of all unevaluated
+    statements *)
+type status_sty = bool
 type status_rty = status
 
 (** Search for objects satisfying the given search flags. *)
@@ -192,10 +181,6 @@ type get_options_rty = (option_name * option_state) list
 type set_options_sty = (option_name * option_value) list
 type set_options_rty = unit
 
-(** Is a directory part of Coq's loadpath ? *)
-type inloadpath_sty = string
-type inloadpath_rty = bool
-
 (** Create a "match" template for a given inductive type.
     For each branch of the match, we list the constructor name
     followed by enough pattern variables. *)
@@ -206,15 +191,36 @@ type mkcases_rty = string list list
 type quit_sty = unit
 type quit_rty = unit
 
+(* Initialize, and return the initial state id.  The argument is the filename.
+ * If its directory is not in dirpath, it adds it.  It also loads
+ * compilation hints for the filename. *)
+type init_sty = string option
+type init_rty = state_id
+
 type about_sty = unit
 type about_rty = coq_info
 
-type handle_exn_rty = location * string
-type handle_exn_sty = exn
+type handle_exn_sty = Exninfo.iexn
+type handle_exn_rty = state_id * location * string
+
+(* Retrocompatibility stuff *)
+type interp_sty = (raw * verbose) * string
+(* spiwack: [Inl] for safe and [Inr] for unsafe. *)
+type interp_rty = state_id * (string,string) Util.union
+
+type stop_worker_sty = string
+type stop_worker_rty = unit
+
+type print_ast_sty = state_id
+type print_ast_rty = Xml_datatype.xml
+
+type annotate_sty = string
+type annotate_rty = Xml_datatype.xml
 
 type handler = {
-  interp      : interp_sty      -> interp_rty;
-  rewind      : rewind_sty      -> rewind_rty;
+  add         : add_sty         -> add_rty;
+  edit_at     : edit_at_sty     -> edit_at_rty;
+  query       : query_sty       -> query_rty;
   goals       : goals_sty       -> goals_rty;
   evars       : evars_sty       -> evars_rty;
   hints       : hints_sty       -> hints_rty;
@@ -222,10 +228,15 @@ type handler = {
   search      : search_sty      -> search_rty;
   get_options : get_options_sty -> get_options_rty;
   set_options : set_options_sty -> set_options_rty;
-  inloadpath  : inloadpath_sty  -> inloadpath_rty;
   mkcases     : mkcases_sty     -> mkcases_rty;
-  quit        : quit_sty        -> quit_rty;
   about       : about_sty       -> about_rty;
+  stop_worker : stop_worker_sty -> stop_worker_rty;
+  print_ast   : print_ast_sty   -> print_ast_rty;
+  annotate    : annotate_sty    -> annotate_rty;
   handle_exn  : handle_exn_sty  -> handle_exn_rty;
+  init        : init_sty        -> init_rty;
+  quit        : quit_sty        -> quit_rty;
+  (* Retrocompatibility stuff *)
+  interp      : interp_sty      -> interp_rty;
 }
 
diff --git a/ide/macos_prehook.ml b/ide/macos_prehook.ml
new file mode 100644
index 00000000..d6687889
--- /dev/null
+++ b/ide/macos_prehook.ml
@@ -0,0 +1,37 @@
+let append_to_var var value =
+  let new_val =
+    try value ^ ":" ^ Unix.getenv var
+    with Not_found -> value in
+  Unix.putenv var new_val
+
+let resources_dir =
+  let working_dir = Sys.getcwd () in
+  let () = Sys.chdir (Filename.dirname (Sys.executable_name)) in
+  let app_root_dir = Filename.dirname (Sys.getcwd ()) in
+  let () = Sys.chdir working_dir in
+  Filename.concat app_root_dir "Resources"
+
+let lib_dir = Filename.concat resources_dir "lib"
+let etc_dir = Filename.concat resources_dir "etc"
+let xdg_home = Filename.concat (Sys.getenv "HOME") "Library/Application Support"
+
+let () = Unix.putenv "DYLD_LIBRARY_PATH" lib_dir
+let () = Unix.putenv "XDG_DATA_HOME" xdg_home
+let () = Unix.putenv "XDG_CONFIG_HOME" xdg_home
+let () = append_to_var "XDG_DATA_DIRS" (Filename.concat resources_dir "share")
+let () = append_to_var "XDG_CONFIG_DIRS" (Filename.concat etc_dir "xdg")
+let () = Unix.putenv "GTK_DATA_PREFIX" resources_dir
+let () = Unix.putenv "GTK_EXE_PREFIX" resources_dir
+let () = Unix.putenv "GTK_PATH" resources_dir
+let () =
+  Unix.putenv "GTK2_RC_FILES" (Filename.concat etc_dir "gtk-2.0/gtkrc")
+let () =
+  Unix.putenv "GTK_IM_MODULE_FILE"
+   (Filename.concat etc_dir "gtk-2.0/gtk-immodules.loaders")
+let () =
+  Unix.putenv "GDK_PIXBUF_MODULE_FILE"
+   (Filename.concat etc_dir "gtk-2.0/gdk-pixbuf.loaders")
+let () = Unix.putenv "PANGO_LIBDIR" lib_dir
+let () = Unix.putenv "PANGO_SYSCONFIGDIR" etc_dir
+let () = Unix.putenv "CHARSETALIASDIR" lib_dir
+let () = append_to_var "PATH" (Filename.concat resources_dir "bin")
diff --git a/ide/minilib.ml b/ide/minilib.ml
index 74a42b23..d11e8c56 100644
--- a/ide/minilib.ml
+++ b/ide/minilib.ml
@@ -6,112 +6,23 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
+let rec print_list print fmt = function
+  | [] -> ()
+  | [x] -> print fmt x
+  | x :: r -> print fmt x; print_list print fmt r
+
+type level = [
+  | `DEBUG
+  | `INFO
+  | `NOTICE
+  | `WARNING
+  | `ERROR
+  | `FATAL ]
+
 (** Some excerpt of Util and similar files to avoid loading the whole
     module and its dependencies (and hence Compat and Camlp4) *)
 
-module Stringmap = Map.Make(String)
-
-let list_fold_left_i f =
-  let rec it_list_f i a = function
-    | [] -> a
-    | b::l -> it_list_f (i+1) (f i a b) l
-  in
-  it_list_f
-
-(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
-   [l1++l2=l] and [l1] has length [i].
-   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
-
-let list_chop n l =
-  let rec chop_aux i acc = function
-    | tl when i=0 -> (List.rev acc, tl)
-    | h::t -> chop_aux (pred i) (h::acc) t
-    | [] -> failwith "list_chop"
-  in
-  chop_aux n [] l
-
-
-let list_map_i f =
-  let rec map_i_rec i = function
-    | [] -> []
-    | x::l -> let v = f i x in v :: map_i_rec (i+1) l
-  in
-  map_i_rec
-
-
-let list_index x =
-  let rec index_x n = function
-    | y::l -> if x = y then n else index_x (succ n) l
-    | [] -> raise Not_found
-  in
-  index_x 1
-
-let list_index0 x l = list_index x l - 1
-
-let list_filter_i p =
-  let rec filter_i_rec i = function
-    | [] -> []
-    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
-  in
-  filter_i_rec 0
-
-let string_map f s =
-  let l = String.length s in
-  let r = String.create l in
-  for i= 0 to (l - 1) do r.[i] <- f (s.[i]) done;
-  r
-
-let subst_command_placeholder s t =
-  Str.global_replace (Str.regexp_string "%s") t s
-
-(* Split the content of a variable such as $PATH in a list of directories.
-   The separators are either ":" in unix or ";" in win32 *)
-
-let path_to_list = Str.split (Str.regexp "[:;]")
-
-(* On win32, the home directory is probably not in $HOME, but in
-   some other environment variable *)
-
-let home =
-  try Sys.getenv "HOME" with Not_found ->
-    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
-      try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name
-
-let opt2list = function None -> [] | Some x -> [x]
-
-let (/) = Filename.concat
-
-let coqify d = d / "coq"
-
-let xdg_config_home =
-  coqify (try Sys.getenv "XDG_CONFIG_HOME" with Not_found -> home / ".config")
-
-let relative_base =
-  Filename.dirname (Filename.dirname Sys.executable_name)
-
-let xdg_config_dirs =
-  let sys_dirs =
-    try List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
-    with
-      | Not_found when Sys.os_type = "Win32" -> [relative_base / "config"]
-      | Not_found -> ["/etc/xdg/coq"]
-  in
-  xdg_config_home :: sys_dirs @ opt2list Coq_config.configdir
-
-let xdg_data_home =
-  coqify
-    (try Sys.getenv "XDG_DATA_HOME" with Not_found -> home / ".local" / "share")
-
-let xdg_data_dirs =
-  let sys_dirs =
-    try List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
-    with
-      | Not_found when Sys.os_type = "Win32" -> [relative_base / "share"]
-      | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
-  in
-  xdg_data_home :: sys_dirs @ opt2list Coq_config.datadir
-
-let coqtop_path = ref ""
+let debug = ref false
 
 (* On a Win32 application with no console, writing to stderr raise
    a Sys_error "bad file descriptor", hence the "try" below.
@@ -119,68 +30,41 @@ let coqtop_path = ref ""
    print in the response buffer.
 *)
 
-let safe_prerr_endline s =
-  try prerr_endline s;flush stderr with _ -> ()
-
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p =
-  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
-  let n = String.length curdir in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = curdir then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    p
-
-let strip_path p =
-  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
-  let n = String.length cwd in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = cwd then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    remove_path_dot p
-
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  try
-    Sys.chdir p;
-    let p' = Sys.getcwd () in
-    Sys.chdir current;
-    p'
-  with Sys_error _ ->
-    (* We give up to find a canonical name and just simplify it... *)
-    strip_path p
-
-let correct_path f dir = if Filename.is_relative f then Filename.concat dir f else f
-
-(*
-  checks if two file names refer to the same (existing) file by
-  comparing their device and inode.
-  It seems that under Windows, inode is always 0, so we cannot
-  accurately check if
+let log ?(level = `DEBUG) msg =
+  let prefix = match level with
+  | `DEBUG -> "DEBUG"
+  | `INFO -> "INFO"
+  | `NOTICE -> "NOTICE"
+  | `WARNING -> "WARNING"
+  | `ERROR -> "ERROR"
+  | `FATAL -> "FATAL"
+  in
+  if !debug then begin
+    try Printf.eprintf "[%s] %s\n%!" prefix msg
+    with _ -> ()
+  end
+
+let coqify d = Filename.concat d "coq"
+
+let coqide_config_home () =
+  coqify (Glib.get_user_config_dir ())
+
+let coqide_data_dirs () =
+  coqify (Glib.get_user_data_dir ())
+  :: List.map coqify (Glib.get_system_data_dirs ())
+  @ Option.List.cons Coq_config.datadir []
+
+let coqide_config_dirs () =
+  coqide_config_home ()
+  :: List.map coqify (Glib.get_system_config_dirs ())
+  @ Option.List.cons Coq_config.configdir []
+
+let is_prefix_of pre s =
+  let i = ref 0 in
+  let () = while (!i < (String.length pre)
+        && !i < (String.length s)
+	     && pre.[!i] = s.[!i]) do
+	          incr i
+		     done
+  in !i = String.length pre
 
-*)
-(* Optimised for partial application (in case many candidates must be
-   compared to f1). *)
-let same_file f1 =
-  try
-    let s1 = Unix.stat f1 in
-    (fun f2 ->
-      try
-        let s2 = Unix.stat f2 in
-        s1.Unix.st_dev = s2.Unix.st_dev &&
-          if Sys.os_type = "Win32" then f1 = f2
-          else s1.Unix.st_ino = s2.Unix.st_ino
-      with
-          Unix.Unix_error _ -> false)
-  with
-      Unix.Unix_error _ -> (fun _ -> false)
diff --git a/ide/minilib.mli b/ide/minilib.mli
index 53d6c87c..b7672c90 100644
--- a/ide/minilib.mli
+++ b/ide/minilib.mli
@@ -9,36 +9,22 @@
 (** Some excerpts of Util and similar files to avoid depending on them
     and hence on Compat and Camlp4 *)
 
-module Stringmap : Map.S with type key = string
+val print_list : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit
 
-val list_fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
-val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_filter_i : (int -> 'a -> bool) -> 'a list -> 'a list
-val list_chop : int -> 'a list -> 'a list * 'a list
-val list_index0 : 'a -> 'a list -> int
+type level = [
+  | `DEBUG
+  | `INFO
+  | `NOTICE
+  | `WARNING
+  | `ERROR
+  | `FATAL ]
 
-val string_map : (char -> char) -> string -> string
+(** debug printing *)
+val debug : bool ref
 
-val subst_command_placeholder : string -> string -> string
-
-val home : string
-val xdg_config_home : string
-val xdg_config_dirs : string list
-val xdg_data_home : string
-val xdg_data_dirs : string list
-
-val coqtop_path : string ref
-
-(** safe version of Pervasives.prerr_endline
-    (avoid exception in win32 without console) *)
-val safe_prerr_endline : string -> unit
-
-val remove_path_dot : string -> string
-val strip_path : string -> string
-val canonical_path_name : string -> string
-(** correct_path f dir = dir/f if f is relative *)
-val correct_path : string -> string -> string
-
-(** checks if two file names refer to the same (existing) file *)
-val same_file : string -> string -> bool
+val log : ?level:level -> string -> unit
 
+val coqide_config_home : unit -> string
+val coqide_config_dirs : unit -> string list
+val coqide_data_dirs : unit -> string list
+val is_prefix_of : string -> string -> bool
diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml
new file mode 100644
index 00000000..805ace93
--- /dev/null
+++ b/ide/nanoPG.ml
@@ -0,0 +1,321 @@
+(************************************************************************)
+(*  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 Ideutils
+open Session
+open Preferences
+open GdkKeysyms
+open Printf
+
+let eprintf x =
+  if !Flags.debug then Printf.eprintf x else Printf.ifprintf stderr x
+
+type gui = {
+  notebook : session Wg_Notebook.typed_notebook;
+  action_groups : GAction.action_group list;
+}
+
+let actiong gui name = List.find (fun ag -> ag#name = name) gui.action_groups
+let ct gui = gui.notebook#current_term
+
+let get_sel b = b#selection_bounds
+let sel_nonempty b = let i, j = get_sel b in not (i#equal j)
+let get_sel_txt b = let i, j = get_sel b in i#get_text ~stop:j
+
+type status = { move : int option; kill : (string * bool) option; sel: bool }
+
+let pr_status { move; kill; sel } =
+  let move = Option.cata (fun i -> string_of_int i) "" move in
+  let kill = Option.cata (fun (s,b) -> sprintf "kill(%b) %S" b s) "" kill in
+  let sel = string_of_bool sel in
+  Printf.sprintf "{ move: %s; kill: %s; sel: %s }" move kill sel
+let pr_key t =
+  let kv = GdkEvent.Key.keyval t in
+  let str = GdkEvent.Key.string t in
+  let str_of_mod = function
+  | `SHIFT -> "SHIFT" | `LOCK -> "LOCK" | `CONTROL -> "CONTROL"
+  | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" | `MOD3 -> "MOD3" | `MOD4 -> "MOD4"
+  | `MOD5 -> "MOD5" | `BUTTON1 -> "BUTTON1" | `BUTTON2 -> "BUTTON2"
+  | `BUTTON3 -> "BUTTON3" | `BUTTON4 -> "BUTTON4" | `BUTTON5 -> "BUTTON5"
+  | `SUPER -> "SUPER" | `HYPER -> "HYPER" | `META -> "META"
+  | `RELEASE -> "RELEASE" in
+  let mods = String.concat " " (List.map str_of_mod (GdkEvent.Key.state t)) in
+  Printf.sprintf "'%s' (%d, %s)" str kv mods
+
+type action =
+  | Action of string * string
+  | Callback of (gui -> unit)
+  | Edit of (status -> GSourceView2.source_buffer -> GText.iter ->
+              (string -> string -> unit) -> status)
+  | Motion of (status -> GText.iter -> GText.iter * status)
+
+type 'c entry = {
+  mods : Gdk.Tags.modifier list;
+  key : Gdk.keysym;
+  keyname : string;
+  doc : string;
+  contents : 'c
+}
+
+let mC = [`CONTROL]
+let mM = [`MOD1]
+
+let mod_of t x = List.for_all (fun m -> List.mem m (GdkEvent.Key.state t)) x
+
+let pr_keymod l =
+  if l = mC then "C-"
+  else if l = mM then "M-"
+  else ""
+
+let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents =
+  List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents })
+    ((mods, key, keyname)::alias)
+
+type keypaths = Step of action entry list * keypaths entry list
+
+let print_keypaths kps =
+  let rec aux prefix (Step (l, konts)) =
+    String.concat "\n" (
+       (List.map (fun x ->
+         prefix ^ pr_keymod x.mods ^ x.keyname ^ "  " ^ x.doc ) l) @
+       (List.map (fun x ->
+         aux (prefix^pr_keymod x.mods^x.keyname^" ") x.contents) konts)) in
+  aux "  " kps
+
+let empty = Step([],[])
+
+let frontier (Step(l1,l2)) =
+  List.map (fun x -> pr_keymod x.mods ^ x.keyname) l1 @
+  List.map (fun x -> pr_keymod x.mods ^ x.keyname) l2
+
+let insert kps name enter_syms bindings =
+  let rec aux kps enter_syms =
+    match enter_syms, kps with
+    | [], Step (el, konts) -> Step (List.flatten bindings @ el, konts)
+    | (mods, key, keyname)::gs, Step (el, konts) ->
+         if List.exists (fun { key = k; mods = m } -> key = k && mods = m) konts
+         then
+           let konts =
+             List.map
+               (fun ({ key = k; contents } as x) ->
+                 if key <> k then x else { x with contents = aux contents gs })
+             konts in
+           Step(el,konts)
+         else
+           let kont =
+             { mods; key; keyname; doc = name; contents = aux empty gs } in
+           Step(el, kont::konts) in
+  aux kps enter_syms
+
+let run_action gui group name =
+  ((actiong gui group)#get_action name)#activate ()
+
+let run key gui action status =
+  match action with
+  | Callback f -> f gui; status
+  | Action(group, name) -> run_action gui group name; status
+  | Edit f ->
+      let b = (ct gui).script#source_buffer in
+      let i = b#get_iter_at_mark `INSERT in
+      let status = f status b i (run_action gui) in
+      if not status.sel then
+        b#place_cursor ~where:(b#get_iter_at_mark `SEL_BOUND);
+      status
+  | Motion f ->
+      let b, script = (ct gui).script#source_buffer, (ct gui).script in
+      let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in
+      let i =
+        if sel_mode then b#get_iter_at_mark `SEL_BOUND
+        else b#get_iter_at_mark `INSERT in
+      let where, status = f status i in
+      let sel_mode = status.sel || List.mem `SHIFT (GdkEvent.Key.state key) in
+      if sel_mode then (b#move_mark `SEL_BOUND ~where; script#scroll_mark_onscreen `SEL_BOUND)
+      else (b#place_cursor ~where; script#scroll_mark_onscreen `INSERT);
+      status
+
+let emacs = empty 
+
+let emacs = insert emacs "Emacs" [] [
+  (* motion *)
+  mkE _e "e" "Move to end of line" (Motion(fun s i ->
+    (if not i#ends_line then i#forward_to_line_end else i),
+    { s with move = None }));
+  mkE _a "a" "Move to beginning of line" (Motion(fun s i ->
+    (i#set_line_offset 0), { s with move = None }));
+  mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i ->
+    i#forward_sentence_end, { s with move = None }));
+  mkE ~mods:mM _a "a" "Move to beginning of sentence" (Motion(fun s i ->
+    i#backward_sentence_start, { s with move = None }));
+  mkE _n "n" "Move to next line" ~alias:[[],_Down,"DOWN"] (Motion(fun s i ->
+    let orig_off = Option.default i#line_offset s.move in
+    let i = i#forward_line in
+    let new_off = min (i#chars_in_line - 1) orig_off in
+    (if new_off > 0 then i#set_line_offset new_off else i),
+    { s with move = Some orig_off }));
+  mkE _p "p" "Move to previous line" ~alias:[[],_Up,"UP"] (Motion(fun s i ->
+    let orig_off = Option.default i#line_offset s.move in
+    let i = i#backward_line in
+    let new_off = min (i#chars_in_line - 1) orig_off in
+    (if new_off > 0 then i#set_line_offset new_off else i),
+    { s with move = Some orig_off }));
+  mkE _f "f" "Forward char" ~alias:[[],_Right,"RIGHT"]
+    (Motion(fun s i -> i#forward_char, { s with move = None }));
+  mkE _b "b" "Backward char" ~alias:[[],_Left,"LEFT"]
+    (Motion(fun s i -> i#backward_char, { s with move = None }));
+  mkE ~mods:mM _f "f" "Forward word" ~alias:[mC,_Right,"RIGHT"]
+    (Motion(fun s i -> i#forward_word_end, { s with move = None }));
+  mkE ~mods:mM _b "b" "Backward word" ~alias:[mC,_Left,"LEFT"]
+    (Motion(fun s i -> i#backward_word_start, { s with move = None }));
+  mkE _space "SPC" "Set mark" ~alias:[mC,_at,"@"] (Motion(fun s i ->
+    if s.sel = false then i, { s with sel = true }
+    else i, { s with sel = false } ));
+  (* edits *)
+  mkE ~mods:mM _w "w" "Copy selected region" (Edit(fun s b i run ->
+    if sel_nonempty b then
+      let txt = get_sel_txt b in
+      run "Edit" "Copy";
+      { s with kill = Some(txt,false); sel = false }
+    else s));
+  mkE _w "w" "Kill selected region" (Edit(fun s b i run ->
+    if sel_nonempty b then
+      let txt = get_sel_txt b in
+      run "Edit" "Cut";
+      { s with kill = Some(txt,false); sel = false }
+    else s));
+  mkE _k "k" "Kill untill the end of line" (Edit(fun s b i _ ->
+    let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+    let k =
+      if i#ends_line then begin
+        b#delete ~start:i ~stop:i#forward_char; "\n"
+      end else begin 
+        let k = b#get_text ~start:i ~stop:i#forward_to_line_end () in
+        b#delete ~start:i ~stop:i#forward_to_line_end; k
+      end in
+    { s with kill = Some (already_killed ^ k,true) }));
+  mkE ~mods:mM _d "d" "Kill next word" (Edit(fun s b i _ ->
+    let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+    let k =
+      let k = b#get_text ~start:i ~stop:i#forward_word_end () in
+      b#delete ~start:i ~stop:i#forward_word_end; k in
+    { s with kill = Some (already_killed ^ k,true) }));
+  mkE ~mods:mM _k "k" "Kill until sentence end" (Edit(fun s b i _ ->
+    let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+    let k =
+      let k = b#get_text ~start:i ~stop:i#forward_sentence_end () in
+      b#delete ~start:i ~stop:i#forward_sentence_end; k in
+    { s with kill = Some (already_killed ^ k,true) }));
+  mkE ~mods:mM _BackSpace "DELBACK" "Kill word before cursor"
+    (Edit(fun s b i _ ->
+    let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in
+    let k =
+      let k = b#get_text ~start:i ~stop:i#backward_word_start () in
+      b#delete ~start:i ~stop:i#backward_word_start; k in
+    { s with kill = Some (already_killed ^ k,true) }));
+  mkE _d "d" "Delete next character" (Edit(fun s b i _ ->
+    b#delete ~start:i ~stop:i#forward_char; s));
+  mkE _y "y" "Yank killed text back " (Edit(fun s b i _ ->
+    let k, s = match s.kill with
+    | Some (k,_) -> k, { s with kill = Some (k,false) }
+    | _ -> "", s in
+    b#insert ~iter:i k;
+    s));
+  (* misc *)
+  mkE _underscore "_" "Undo" (Action("Edit", "Undo"));
+  mkE _g "g" "Esc" (Callback(fun gui -> (ct gui).finder#hide ()));
+  mkE _s "s" "Search" (Callback(fun gui ->
+    if (ct gui).finder#coerce#misc#visible
+    then run_action gui "Edit" "Find Next"
+    else run_action gui "Edit" "Find"));
+  mkE _s "r" "Search backward" (Callback(fun gui ->
+    if (ct gui).finder#coerce#misc#visible
+    then run_action gui "Edit" "Find Previous"
+    else run_action gui "Edit" "Find"));
+  ]
+
+let emacs = insert emacs "Emacs" [mC,_x,"x"] [
+  mkE _s "s" "Save" (Action("File", "Save"));
+  mkE _c "c" "Quit" (Action("File", "Quit"));
+  mkE _f "f" "Open" (Action("File", "Open"));
+  mkE ~mods:[] _u "u" "Undo" (Action("Edit", "Undo"));
+  ]
+  
+let pg = insert emacs "Proof General" [mC,_c,"c"] [
+  mkE _Return "RET" "Go to" (Action("Navigation", "Go to"));
+  mkE _n "n" "Advance 1 sentence" (Action("Navigation", "Forward"));
+  mkE _u "u" "Retract 1 sentence" (Action("Navigation", "Backward"));
+  mkE _b "b" "Advance" (Action("Navigation", "End"));
+  mkE _r "r" "Restart" (Action("Navigation", "Start"));
+  mkE _c "c" "Stop"    (Action("Navigation", "Interrupt"));
+  ]
+
+let command gui c =
+  let command = (ct gui).command in
+  let script = (ct gui).script in
+  let term =
+    let i, j = script#source_buffer#selection_bounds in
+    if i#equal j then None
+    else Some (script#buffer#get_text ~start:i ~stop:j ()) in
+  command#show;
+  command#new_query ~command:c ?term ()
+
+let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [
+  mkE _p "p" "Print" (Callback (fun gui -> command gui "Print"));
+  mkE _c "c" "Check" (Callback (fun gui -> command gui "Check"));
+  mkE _b "b" "About" (Callback (fun gui -> command gui "About"));
+  mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout"));
+  mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern"));
+  mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate"));
+  mkE _Return "RET" "match template" (Action("Templates","match"));
+  ]
+
+let empty = { sel = false; kill = None; move = None }
+
+let find gui (Step(here,konts)) t =
+  (* hack: ^c does copy in clipboard *)
+  let sel_nonempty () = sel_nonempty (ct gui).script#source_buffer in
+  let k = GdkEvent.Key.keyval t in
+  if k = _x && mod_of t mC && sel_nonempty () then
+    ignore(run t gui (Action("Edit","Cut")) empty)
+  else
+    if k = _c && mod_of t mC && sel_nonempty () then
+      ignore(run t gui (Action("Edit","Copy")) empty);
+    let cmp { key; mods } = key = k && mod_of t mods in
+    try `Do (List.find cmp here) with Not_found ->
+    try `Cont (List.find cmp konts).contents with Not_found -> `NotFound
+
+let init w nb ags =
+  let gui = { notebook = nb; action_groups = ags } in
+  let cur = ref pg in
+  let status = ref empty in
+  let reset () = eprintf "reset\n%!"; cur := pg in
+  ignore(w#event#connect#key_press ~callback:(fun t ->
+    let on_current_term f =
+      let term = try Some nb#current_term with Invalid_argument _ -> None in
+      match term with None -> false | Some t -> f t
+    in
+    on_current_term (fun x ->
+    if x.script#misc#get_property "has-focus" <> `BOOL true
+    then false
+    else begin
+    eprintf "got key %s\n%!" (pr_key t);
+    if current.nanoPG then begin
+      match find gui !cur t with
+      | `Do e ->
+           eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status);
+           status := run t gui e.contents !status; reset (); true
+      | `Cont c ->
+           flash_info ("Waiting one of " ^ String.concat " " (frontier c));
+           cur := c; true
+      | `NotFound -> reset (); false
+    end else false
+  end)));
+  ignore(w#event#connect#button_press ~callback:(fun t -> reset (); false))
+
+
+
+let get_documentation () = print_keypaths pg
diff --git a/ide/preferences.ml b/ide/preferences.ml
index 9161d923..c8506132 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -1,32 +1,37 @@
 (************************************************************************)
 (*  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 Configwin
-open Printf
 
-let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc"
-let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys"
+let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc"
+let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys"
+let lang_manager = GSourceView2.source_language_manager ~default:true
+let () = lang_manager#set_search_path
+  ((Minilib.coqide_data_dirs ())@lang_manager#search_path)
+let style_manager = GSourceView2.source_style_scheme_manager ~default:true
+let () = style_manager#set_search_path
+  ((Minilib.coqide_data_dirs ())@style_manager#search_path)
 
 let get_config_file name =
   let find_config dir = Sys.file_exists (Filename.concat dir name) in
-  let config_dir = List.find find_config Minilib.xdg_config_dirs in
+  let config_dir = List.find find_config (Minilib.coqide_config_dirs ()) in
   Filename.concat config_dir name
 
 (* Small hack to handle v8.3 to v8.4 change in configuration file *)
 let loaded_pref_file =
   try get_config_file "coqiderc"
-  with Not_found -> Filename.concat Minilib.home ".coqiderc"
+  with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqiderc"
 
 let loaded_accel_file =
   try get_config_file "coqide.keys"
-  with Not_found -> Filename.concat Minilib.home ".coqide.keys"
+  with Not_found -> Filename.concat (Option.default "" (Glib.get_home_dir ())) ".coqide.keys"
 
-let mod_to_str (m:Gdk.Tags.modifier) =
+let mod_to_str m =
   match m with
     | `MOD1 -> "<Alt>"
     | `MOD2 -> "<Mod2>"
@@ -72,10 +77,10 @@ let inputenc_of_string s =
 
 (** Hooks *)
 
-let refresh_font_hook = ref (fun () -> ())
-let refresh_background_color_hook = ref (fun () -> ())
+let refresh_style_hook = ref (fun () -> ())
+let refresh_language_hook = ref (fun () -> ())
+let refresh_editor_hook = ref (fun () -> ())
 let refresh_toolbar_hook = ref (fun () -> ())
-let auto_complete_hook = ref (fun x -> ())
 let contextual_menus_on_goal_hook = ref (fun x -> ())
 let resize_window_hook = ref (fun () -> ())
 let refresh_tabs_hook = ref (fun () -> ())
@@ -88,6 +93,9 @@ type pref =
       mutable cmd_coqmakefile : string;
       mutable cmd_coqdoc : string;
 
+      mutable source_language : string;
+      mutable source_style : string;
+
       mutable global_auto_revert : bool;
       mutable global_auto_revert_delay : int;
 
@@ -128,19 +136,32 @@ type pref =
 *)
       mutable auto_complete : bool;
       mutable stop_before : bool;
+      mutable reset_on_tab_switch : bool;
       mutable vertical_tabs : bool;
       mutable opposite_tabs : bool;
 
       mutable background_color : string;
       mutable processing_color : string;
       mutable processed_color : string;
+      mutable error_color : string;
+
+      mutable dynamic_word_wrap : bool;
+      mutable show_line_number : bool;
+      mutable auto_indent : bool;
+      mutable show_spaces : bool;
+      mutable show_right_margin : bool;
+      mutable show_progress_bar : bool;
+      mutable spaces_instead_of_tabs : bool;
+      mutable tab_length : int;
+      mutable highlight_current_line : bool;
+
+      mutable nanoPG : bool;
 
 }
 
 let use_default_doc_url = "(automatic)"
 
-let (current:pref ref) =
-  ref {
+let current = {
     cmd_coqtop = None;
     cmd_coqc = "coqc";
     cmd_make = "make";
@@ -155,6 +176,9 @@ let (current:pref ref) =
     auto_save_delay = 10000;
     auto_save_name = "#","#";
 
+    source_language = "coq";
+    source_style = "coq_style";
+
     read_project = Ignore_args;
     project_file_name = "_CoqProject";
 
@@ -192,29 +216,44 @@ let (current:pref ref) =
 *)
     auto_complete = false;
     stop_before = true;
+    reset_on_tab_switch = false;
     vertical_tabs = false;
     opposite_tabs = false;
 
     background_color = "cornsilk";
     processed_color = "light green";
     processing_color = "light blue";
-
+    error_color = "#FFCCCC";
+
+    dynamic_word_wrap = false;
+    show_line_number = false;
+    auto_indent = false;
+    show_spaces = true;
+    show_right_margin = false;
+    show_progress_bar = true;
+    spaces_instead_of_tabs = true;
+    tab_length = 2;
+    highlight_current_line = false;
+
+    nanoPG = false;
   }
 
 let save_pref () =
-  if not (Sys.file_exists Minilib.xdg_config_home)
-  then Unix.mkdir Minilib.xdg_config_home 0o700;
+  if not (Sys.file_exists (Minilib.coqide_config_home ()))
+  then Unix.mkdir (Minilib.coqide_config_home ()) 0o700;
   let () = try GtkData.AccelMap.save accel_file with _ -> () in
-  let p = !current in
+  let p = current in
 
-    let add = Minilib.Stringmap.add in
+    let add = Util.String.Map.add in
     let (++) x f = f x in
-    Minilib.Stringmap.empty ++
+    Util.String.Map.empty ++
     add "cmd_coqtop" (match p.cmd_coqtop with | None -> [] | Some v-> [v]) ++
     add "cmd_coqc" [p.cmd_coqc] ++
     add "cmd_make" [p.cmd_make] ++
     add "cmd_coqmakefile" [p.cmd_coqmakefile] ++
     add "cmd_coqdoc" [p.cmd_coqdoc] ++
+    add "source_language" [p.source_language] ++
+    add "source_style" [p.source_style] ++
     add "global_auto_revert" [string_of_bool p.global_auto_revert] ++
     add "global_auto_revert_delay"
       [string_of_int p.global_auto_revert_delay] ++
@@ -250,20 +289,31 @@ let save_pref () =
     add "query_window_width" [string_of_int p.query_window_width] ++
     add "auto_complete" [string_of_bool p.auto_complete] ++
     add "stop_before" [string_of_bool p.stop_before] ++
+    add "reset_on_tab_switch" [string_of_bool p.reset_on_tab_switch] ++
     add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
     add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
     add "background_color" [p.background_color] ++
     add "processing_color" [p.processing_color] ++
     add "processed_color" [p.processed_color] ++
+    add "error_color" [p.error_color] ++
+    add "dynamic_word_wrap" [string_of_bool p.dynamic_word_wrap] ++
+    add "show_line_number" [string_of_bool p.show_line_number] ++
+    add "auto_indent" [string_of_bool p.auto_indent] ++
+    add "show_spaces" [string_of_bool p.show_spaces] ++
+    add "show_right_margin" [string_of_bool p.show_right_margin] ++
+    add "show_progress_bar" [string_of_bool p.show_progress_bar] ++
+    add "spaces_instead_of_tabs" [string_of_bool p.spaces_instead_of_tabs] ++
+    add "tab_length" [string_of_int p.tab_length] ++
+    add "highlight_current_line" [string_of_bool p.highlight_current_line] ++
+    add "nanoPG" [string_of_bool p.nanoPG] ++
     Config_lexer.print_file pref_file
 
 let load_pref () =
   let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
-  let p = !current in
 
     let m = Config_lexer.load_file loaded_pref_file in
-    let np = { p with cmd_coqc = p.cmd_coqc } in
-    let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in
+    let np = current in
+    let set k f = try let v = Util.String.Map.find k m in f v with _ -> () in
     let set_hd k f = set k (fun v -> f (List.hd v)) in
     let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in
     let set_int k f = set_hd k (fun v -> f (int_of_string v)) in
@@ -277,6 +327,8 @@ let load_pref () =
     set_hd "cmd_make" (fun v -> np.cmd_make <- v);
     set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);
     set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v);
+    set_hd "source_language" (fun v -> np.source_language <- v);
+    set_hd "source_style" (fun v -> np.source_style <- v);
     set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v);
     set_int "global_auto_revert_delay"
       (fun v -> np.global_auto_revert_delay <- v);
@@ -299,7 +351,8 @@ let load_pref () =
     set_hd "modifier_for_display"
       (fun v -> np.modifier_for_display <- v);
     set_hd "modifiers_valid"
-      (fun v -> np.modifiers_valid <- v);
+      (fun v ->
+	np.modifiers_valid <- v);
     set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v);
     set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v);
     set_hd "text_font" (fun v -> np.text_font <- Pango.Font.from_string v);
@@ -310,7 +363,7 @@ let load_pref () =
         v <> Coq_config.wwwcoq ^ "doc" &&
 	v <> Coq_config.wwwcoq ^ "doc/"
       then
-	(*prerr_endline ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*)
+	(* ("Warning: Non-standard URL for Coq documentation in preference file: "^v);*)
       np.doc_url <- v);
     set_hd "library_url" (fun v -> np.library_url <- v);
     set_bool "show_toolbar" (fun v -> np.show_toolbar <- v);
@@ -322,41 +375,50 @@ let load_pref () =
     set_int "query_window_height" (fun v -> np.query_window_height <- v);
     set_bool "auto_complete" (fun v -> np.auto_complete <- v);
     set_bool "stop_before" (fun v -> np.stop_before <- v);
+    set_bool "reset_on_tab_switch" (fun v -> np.reset_on_tab_switch <- v);
     set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
     set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
     set_hd "background_color" (fun v -> np.background_color <- v);
     set_hd "processing_color" (fun v -> np.processing_color <- v);
     set_hd "processed_color" (fun v -> np.processed_color <- v);
-    current := np
-(*
-    Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
-*)
+    set_hd "error_color" (fun v -> np.error_color <- v);
+    set_bool "dynamic_word_wrap" (fun v -> np.dynamic_word_wrap <- v);
+    set_bool "show_line_number" (fun v -> np.show_line_number <- v);
+    set_bool "auto_indent" (fun v -> np.auto_indent <- v);
+    set_bool "show_spaces" (fun v -> np.show_spaces <- v);
+    set_bool "show_right_margin" (fun v -> np.show_right_margin <- v);
+    set_bool "show_progress_bar" (fun v -> np.show_progress_bar <- v);
+    set_bool "spaces_instead_of_tabs" (fun v -> np.spaces_instead_of_tabs <- v);
+    set_int "tab_length" (fun v -> np.tab_length <- v);
+    set_bool "highlight_current_line" (fun v -> np.highlight_current_line <- v);
+    set_bool "nanoPG" (fun v -> np.nanoPG <- v);
+    ()
 
 let configure ?(apply=(fun () -> ())) () =
   let cmd_coqtop =
     string
-      ~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s)
-      "       coqtop" (match !current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
+      ~f:(fun s -> current.cmd_coqtop <- if s = "AUTO" then None else Some s)
+      "       coqtop" (match current.cmd_coqtop with |None -> "AUTO" | Some x -> x) in
   let cmd_coqc =
     string
-      ~f:(fun s -> !current.cmd_coqc <- s)
-      "       coqc"  !current.cmd_coqc in
+      ~f:(fun s -> current.cmd_coqc <- s)
+      "       coqc"  current.cmd_coqc in
   let cmd_make =
     string
-      ~f:(fun s -> !current.cmd_make <- s)
-      "       make" !current.cmd_make in
+      ~f:(fun s -> current.cmd_make <- s)
+      "       make" current.cmd_make in
   let cmd_coqmakefile =
     string
-      ~f:(fun s -> !current.cmd_coqmakefile <- s)
-      "coqmakefile" !current.cmd_coqmakefile in
+      ~f:(fun s -> current.cmd_coqmakefile <- s)
+      "coqmakefile" current.cmd_coqmakefile in
   let cmd_coqdoc =
     string
-      ~f:(fun s -> !current.cmd_coqdoc <- s)
-      "     coqdoc" !current.cmd_coqdoc in
+      ~f:(fun s -> current.cmd_coqdoc <- s)
+      "     coqdoc" current.cmd_coqdoc in
   let cmd_print =
     string
-      ~f:(fun s -> !current.cmd_print <- s)
-      "   Print ps" !current.cmd_print in
+      ~f:(fun s -> current.cmd_print <- s)
+      "   Print ps" current.cmd_print in
 
   let config_font =
     let box = GPack.hbox () in
@@ -366,17 +428,17 @@ let configure ?(apply=(fun () -> ())) () =
     box#pack ~expand:true w#coerce;
     ignore (w#misc#connect#realize
 	      ~callback:(fun () -> w#set_font_name
-			   (Pango.Font.to_string !current.text_font)));
+			   (Pango.Font.to_string current.text_font)));
     custom
       ~label:"Fonts for text"
       box
       (fun () ->
 	 let fd =  w#font_name in
-	 !current.text_font <- (Pango.Font.from_string fd) ;
+	 current.text_font <- (Pango.Font.from_string fd) ;
 (*
-	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+	 Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string current.text_font);
 *)
-	 !refresh_font_hook ())
+	 !refresh_editor_hook ())
       true
   in
 
@@ -400,11 +462,16 @@ let configure ?(apply=(fun () -> ())) () =
       ~text:"Background color of text being processed"
       ~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
     in
+    let error_label = GMisc.label
+      ~text:"Background color of errors"
+      ~packing:(table#attach ~expand:`X ~left:0 ~top:3) ()
+    in
     let () = background_label#set_xalign 0. in
     let () = processed_label#set_xalign 0. in
     let () = processing_label#set_xalign 0. in
+    let () = error_label#set_xalign 0. in
     let background_button = GButton.color_button
-      ~color:(Tags.color_of_string (!current.background_color))
+      ~color:(Tags.color_of_string (current.background_color))
       ~packing:(table#attach ~left:1 ~top:0) ()
     in
     let processed_button = GButton.color_button
@@ -415,6 +482,10 @@ let configure ?(apply=(fun () -> ())) () =
       ~color:(Tags.get_processing_color ())
       ~packing:(table#attach ~left:1 ~top:2) ()
     in
+    let error_button = GButton.color_button
+      ~color:(Tags.get_error_color ())
+      ~packing:(table#attach ~left:1 ~top:3) ()
+    in
     let reset_button = GButton.button
       ~label:"Reset"
       ~packing:box#pack ()
@@ -423,16 +494,65 @@ let configure ?(apply=(fun () -> ())) () =
       background_button#set_color (Tags.color_of_string "cornsilk");
       processing_button#set_color (Tags.color_of_string "light blue");
       processed_button#set_color (Tags.color_of_string "light green");
+      error_button#set_color (Tags.color_of_string "#FFCCCC");
     in
     let _ = reset_button#connect#clicked ~callback:reset_cb in
     let label = "Color configuration" in
     let callback () =
-      !current.background_color <- Tags.string_of_color background_button#color;
-      !current.processing_color <- Tags.string_of_color processing_button#color;
-      !current.processed_color <- Tags.string_of_color processed_button#color;
-      !refresh_background_color_hook ();
+      current.background_color <- Tags.string_of_color background_button#color;
+      current.processing_color <- Tags.string_of_color processing_button#color;
+      current.processed_color <- Tags.string_of_color processed_button#color;
+      current.error_color <- Tags.string_of_color error_button#color;
+      !refresh_editor_hook ();
       Tags.set_processing_color processing_button#color;
-      Tags.set_processed_color processed_button#color
+      Tags.set_processed_color processed_button#color;
+      Tags.set_error_color error_button#color
+    in
+    custom ~label box callback true
+  in
+
+  let config_editor =
+    let label = "Editor configuration" in
+    let box = GPack.vbox () in
+    let gen_button text active =
+      GButton.check_button ~label:text ~active ~packing:box#pack () in
+    let wrap = gen_button "Dynamic word wrap" current.dynamic_word_wrap in
+    let line = gen_button "Show line number" current.show_line_number in
+    let auto_indent = gen_button "Auto indentation" current.auto_indent in
+    let auto_complete = gen_button "Auto completion" current.auto_complete in
+    let show_spaces = gen_button "Show spaces" current.show_spaces in
+    let show_right_margin = gen_button "Show right margin" current.show_right_margin in
+    let show_progress_bar = gen_button "Show progress bar" current.show_progress_bar in
+    let spaces_instead_of_tabs =
+      gen_button "Insert spaces instead of tabs"
+      current.spaces_instead_of_tabs
+    in
+    let highlight_current_line =
+      gen_button "Highlight current line"
+      current.highlight_current_line
+    in
+    let nanoPG = gen_button "Emacs/PG keybindings (μPG mode)" current.nanoPG in
+(*     let lbox = GPack.hbox ~packing:box#pack () in *)
+(*     let _ = GMisc.label ~text:"Tab width" *)
+(*         ~xalign:0. *)
+(*         ~packing:(lbox#pack ~expand:true) () *)
+(*     in *)
+(*     let tab_width = GEdit.spin_button *)
+(*       ~digits:0 ~packing:lbox#pack () *)
+(*     in *)
+    let callback () =
+      current.dynamic_word_wrap <- wrap#active;
+      current.show_line_number <- line#active;
+      current.auto_indent <- auto_indent#active;
+      current.show_spaces <- show_spaces#active;
+      current.show_right_margin <- show_right_margin#active;
+      current.show_progress_bar <- show_progress_bar#active;
+      current.spaces_instead_of_tabs <- spaces_instead_of_tabs#active;
+      current.highlight_current_line <- highlight_current_line#active;
+      current.nanoPG <- nanoPG#active;
+      current.auto_complete <- auto_complete#active;
+(*       current.tab_length <- tab_width#value_as_int; *)
+      !refresh_editor_hook ()
     in
     custom ~label box callback true
   in
@@ -441,40 +561,32 @@ let configure ?(apply=(fun () -> ())) () =
   let show_toolbar =
     bool
       ~f:(fun s ->
-	    !current.show_toolbar <- s;
+	    current.show_toolbar <- s;
 	    !show_toolbar s)
-      "Show toolbar" !current.show_toolbar
+      "Show toolbar" current.show_toolbar
   in
   let window_height =
     string
-    ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600);
+    ~f:(fun s -> current.window_height <- (try int_of_string s with _ -> 600);
 	  !resize_window ();
        )
       "Window height"
-      (string_of_int !current.window_height)
+      (string_of_int current.window_height)
   in
   let window_width =
     string
-    ~f:(fun s -> !current.window_width <-
+    ~f:(fun s -> current.window_width <-
 	  (try int_of_string s with _ -> 800))
       "Window width"
-      (string_of_int !current.window_width)
+      (string_of_int current.window_width)
   in
 *)
-  let auto_complete =
-    bool
-      ~f:(fun s ->
-	    !current.auto_complete <- s;
-	    !auto_complete_hook s)
-      "Auto Complete" !current.auto_complete
-  in
-
 (*  let use_utf8_notation =
     bool
       ~f:(fun b ->
-	    !current.use_utf8_notation <- b;
+	    current.use_utf8_notation <- b;
 	 )
-      "Use Unicode Notation: " !current.use_utf8_notation
+      "Use Unicode Notation: " current.use_utf8_notation
   in
 *)
 (*
@@ -482,113 +594,144 @@ let configure ?(apply=(fun () -> ())) () =
 *)
   let global_auto_revert =
     bool
-      ~f:(fun s -> !current.global_auto_revert <- s)
-      "Enable global auto revert" !current.global_auto_revert
+      ~f:(fun s -> current.global_auto_revert <- s)
+      "Enable global auto revert" current.global_auto_revert
   in
   let global_auto_revert_delay =
     string
-    ~f:(fun s -> !current.global_auto_revert_delay <-
+    ~f:(fun s -> current.global_auto_revert_delay <-
 	  (try int_of_string s with _ -> 10000))
       "Global auto revert delay (ms)"
-      (string_of_int !current.global_auto_revert_delay)
+      (string_of_int current.global_auto_revert_delay)
   in
 
   let auto_save =
     bool
-      ~f:(fun s -> !current.auto_save <- s)
-      "Enable auto save" !current.auto_save
+      ~f:(fun s -> current.auto_save <- s)
+      "Enable auto save" current.auto_save
   in
   let auto_save_delay =
     string
-    ~f:(fun s -> !current.auto_save_delay <-
+    ~f:(fun s -> current.auto_save_delay <-
 	  (try int_of_string s with _ -> 10000))
       "Auto save delay (ms)"
-      (string_of_int !current.auto_save_delay)
+      (string_of_int current.auto_save_delay)
   in
 
   let stop_before =
     bool
-      ~f:(fun s -> !current.stop_before <- s)
-      "Stop interpreting before the current point" !current.stop_before
+      ~f:(fun s -> current.stop_before <- s)
+      "Stop interpreting before the current point" current.stop_before
+  in
+
+  let reset_on_tab_switch =
+    bool
+      ~f:(fun s -> current.reset_on_tab_switch <- s)
+      "Reset coqtop on tab switch" current.reset_on_tab_switch
   in
 
   let vertical_tabs =
     bool
-      ~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ())
-      "Vertical tabs" !current.vertical_tabs
+      ~f:(fun s -> current.vertical_tabs <- s; !refresh_tabs_hook ())
+      "Vertical tabs" current.vertical_tabs
   in
 
   let opposite_tabs =
     bool
-      ~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ())
-      "Tabs on opposite side" !current.opposite_tabs
+      ~f:(fun s -> current.opposite_tabs <- s; !refresh_tabs_hook ())
+      "Tabs on opposite side" current.opposite_tabs
   in
 
   let encodings =
     combo
       "File charset encoding "
-      ~f:(fun s -> !current.encoding <- (inputenc_of_string s))
+      ~f:(fun s -> current.encoding <- (inputenc_of_string s))
       ~new_allowed: true
-      ("UTF-8"::"LOCALE":: match !current.encoding with
+      ("UTF-8"::"LOCALE":: match current.encoding with
 	|Emanual s -> [s]
 	|_ -> []
       )
-      (string_of_inputenc !current.encoding)
+      (string_of_inputenc current.encoding)
   in
+
+  let source_style =
+    let f s =
+      current.source_style <- s;
+      !refresh_style_hook ()
+    in
+    combo "Highlighting style:"
+      ~f ~new_allowed:false
+      style_manager#style_scheme_ids current.source_style
+  in
+
+  let source_language =
+    let f s =
+      current.source_language <- s;
+      !refresh_language_hook ()
+    in
+    combo "Language:"
+      ~f ~new_allowed:false
+      (List.filter
+        (fun x -> Str.string_match (Str.regexp "^coq") x 0)
+        lang_manager#language_ids)
+      current.source_language
+  in
+
   let read_project =
     combo
       "Project file options are"
-      ~f:(fun s -> !current.read_project <- project_behavior_of_string s)
+      ~f:(fun s -> current.read_project <- project_behavior_of_string s)
       ~editable:false
       [string_of_project_behavior Subst_args;
        string_of_project_behavior Append_args;
        string_of_project_behavior Ignore_args]
-      (string_of_project_behavior !current.read_project)
+      (string_of_project_behavior current.read_project)
   in
   let project_file_name =
     string "Default name for project file"
-      ~f:(fun s -> !current.project_file_name <- s)
-      !current.project_file_name
+      ~f:(fun s -> current.project_file_name <- s)
+      current.project_file_name
   in
   let help_string =
     "restart to apply"
   in
-  let the_valid_mod = str_to_mod_list !current.modifiers_valid in
+  let the_valid_mod = str_to_mod_list current.modifiers_valid in
   let modifier_for_tactics =
     modifiers
       ~allow:the_valid_mod
-      ~f:(fun l -> !current.modifier_for_tactics <- mod_list_to_str l)
+      ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Tactics Menu"
-      (str_to_mod_list !current.modifier_for_tactics)
+      (str_to_mod_list current.modifier_for_tactics)
   in
   let modifier_for_templates =
     modifiers
       ~allow:the_valid_mod
-      ~f:(fun l -> !current.modifier_for_templates <- mod_list_to_str l)
+      ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Templates Menu"
-      (str_to_mod_list !current.modifier_for_templates)
+      (str_to_mod_list current.modifier_for_templates)
   in
   let modifier_for_navigation =
     modifiers
       ~allow:the_valid_mod
-      ~f:(fun l -> !current.modifier_for_navigation <- mod_list_to_str l)
+      ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l)
       ~help:help_string
       "Modifiers for Navigation Menu"
-      (str_to_mod_list !current.modifier_for_navigation)
+      (str_to_mod_list current.modifier_for_navigation)
   in
   let modifier_for_display =
     modifiers
       ~allow:the_valid_mod
-      ~f:(fun l -> !current.modifier_for_display <- mod_list_to_str l)
+      ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l)
       ~help:help_string
-      "Modifiers for Display Menu"
-      (str_to_mod_list !current.modifier_for_display)
+      "Modifiers for View Menu"
+      (str_to_mod_list current.modifier_for_display)
   in
   let modifiers_valid =
     modifiers
-      ~f:(fun l -> !current.modifiers_valid <- mod_list_to_str l)
+      ~f:(fun l ->
+	current.modifiers_valid <- mod_list_to_str l)
       "Allowed modifiers"
       the_valid_mod
   in
@@ -597,11 +740,11 @@ let configure ?(apply=(fun () -> ())) () =
     combo
       ~help:"(%s for file name)"
       "External editor"
-      ~f:(fun s -> !current.cmd_editor <- s)
+      ~f:(fun s -> current.cmd_editor <- s)
       ~new_allowed: true
-      (predefined@[if List.mem !current.cmd_editor predefined then ""
-                   else !current.cmd_editor])
-      !current.cmd_editor
+      (predefined@[if List.mem current.cmd_editor predefined then ""
+                   else current.cmd_editor])
+      current.cmd_editor
   in
   let cmd_browse =
     let predefined = [
@@ -614,11 +757,11 @@ let configure ?(apply=(fun () -> ())) () =
     combo
       ~help:"(%s for url)"
       "Browser"
-      ~f:(fun s -> !current.cmd_browse <- s)
+      ~f:(fun s -> current.cmd_browse <- s)
       ~new_allowed: true
-      (predefined@[if List.mem !current.cmd_browse predefined then ""
-                   else !current.cmd_browse])
-      !current.cmd_browse
+      (predefined@[if List.mem current.cmd_browse predefined then ""
+                   else current.cmd_browse])
+      current.cmd_browse
   in
   let doc_url =
     let predefined = [
@@ -628,11 +771,11 @@ let configure ?(apply=(fun () -> ())) () =
     ] in
     combo
       "Manual URL"
-      ~f:(fun s -> !current.doc_url <- s)
+      ~f:(fun s -> current.doc_url <- s)
       ~new_allowed: true
-      (predefined@[if List.mem !current.doc_url predefined then ""
-                   else !current.doc_url])
-      !current.doc_url in
+      (predefined@[if List.mem current.doc_url predefined then ""
+                   else current.doc_url])
+      current.doc_url in
   let library_url =
     let predefined = [
       "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]);
@@ -640,30 +783,30 @@ let configure ?(apply=(fun () -> ())) () =
     ] in
     combo
       "Library URL"
-      ~f:(fun s -> !current.library_url <- s)
+      ~f:(fun s -> current.library_url <- s)
       ~new_allowed: true
-      (predefined@[if List.mem !current.library_url predefined then ""
-                   else !current.library_url])
-      !current.library_url
+      (predefined@[if List.mem current.library_url predefined then ""
+                   else current.library_url])
+      current.library_url
   in
   let automatic_tactics =
     strings
-      ~f:(fun l -> !current.automatic_tactics <- l)
+      ~f:(fun l -> current.automatic_tactics <- l)
       ~add:(fun () -> ["<edit me>"])
       "Wizard tactics to try in order"
-      !current.automatic_tactics
+      current.automatic_tactics
 
   in
 
   let contextual_menus_on_goal =
     bool
       ~f:(fun s ->
-	    !current.contextual_menus_on_goal <- s;
+	    current.contextual_menus_on_goal <- s;
 	    !contextual_menus_on_goal_hook s)
-      "Contextual menus on goal" !current.contextual_menus_on_goal
+      "Contextual menus on goal" current.contextual_menus_on_goal
   in
 
-  let misc = [contextual_menus_on_goal;auto_complete;stop_before;
+  let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch;
               vertical_tabs;opposite_tabs] in
 
 (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!
@@ -671,7 +814,9 @@ let configure ?(apply=(fun () -> ())) () =
   let cmds =
     [Section("Fonts", Some `SELECT_FONT,
 	     [config_font]);
-     Section("Colors", Some `SELECT_COLOR, [config_color]);
+     Section("Colors", Some `SELECT_COLOR,
+             [config_color; source_language; source_style]);
+     Section("Editor", Some `EDIT, [config_editor]);
      Section("Files", Some `DIRECTORY,
 	     [global_auto_revert;global_auto_revert_delay;
 	      auto_save; auto_save_delay; (* auto_save_name*)
@@ -696,11 +841,11 @@ let configure ?(apply=(fun () -> ())) () =
 	     misc)]
   in
 (*
-  Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+  Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
 *)
   let x = edit ~apply "Customizations" cmds in
 (*
-  Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
+  Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string current.text_font);
 *)
   match x with
     | Return_apply | Return_ok -> save_pref ()
diff --git a/ide/preferences.mli b/ide/preferences.mli
index 3ba10a84..1b52d20a 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -1,11 +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        *)
 (************************************************************************)
 
+val lang_manager : GSourceView2.source_language_manager
+val style_manager : GSourceView2.source_style_scheme_manager
+
 type project_behavior = Ignore_args | Append_args | Subst_args
 type inputenc = Elocale | Eutf8 | Emanual of string
 
@@ -17,6 +20,9 @@ type pref =
       mutable cmd_coqmakefile : string;
       mutable cmd_coqdoc : string;
 
+      mutable source_language : string;
+      mutable source_style : string;
+
       mutable global_auto_revert : bool;
       mutable global_auto_revert_delay : int;
 
@@ -57,24 +63,40 @@ type pref =
 *)
       mutable auto_complete : bool;
       mutable stop_before : bool;
+      mutable reset_on_tab_switch : bool;
       mutable vertical_tabs : bool;
       mutable opposite_tabs : bool;
 
       mutable background_color : string;
       mutable processing_color : string;
       mutable processed_color : string;
+      mutable error_color : string;
+
+      mutable dynamic_word_wrap : bool;
+      mutable show_line_number : bool;
+      mutable auto_indent : bool;
+      mutable show_spaces : bool;
+      mutable show_right_margin : bool;
+      mutable show_progress_bar : bool;
+      mutable spaces_instead_of_tabs : bool;
+      mutable tab_length : int;
+      mutable highlight_current_line : bool;
+
+      mutable nanoPG : bool;
+
     }
 
 val save_pref : unit -> unit
 val load_pref : unit -> unit
 
-val current : pref ref
+val current : pref
 
 val configure : ?apply:(unit -> unit) -> unit -> unit
 
 (* Hooks *)
-val refresh_font_hook : (unit -> unit) ref
-val refresh_background_color_hook : (unit -> unit) ref
+val refresh_editor_hook : (unit -> unit) ref
+val refresh_style_hook : (unit -> unit) ref
+val refresh_language_hook : (unit -> unit) ref
 val refresh_toolbar_hook : (unit -> unit) ref
 val resize_window_hook : (unit -> unit) ref
 val refresh_tabs_hook : (unit -> unit) ref
diff --git a/ide/project_file.ml4 b/ide/project_file.ml4
index aa1189ce..41dc1bef 100644
--- a/ide/project_file.ml4
+++ b/ide/project_file.ml4
@@ -6,10 +6,12 @@ type target =
   | MLPACK of string (* MLLIB file : foo.mlpack -> (MLLIB "foo.mlpack") *)
   | V of string  (* V file : foo.v -> (V "foo") *)
   | Arg of string
-  | Special of string * string * string (* file, dependencies, command *)
+  | Special of string * string * bool * string
+    (* file, dependencies, is_phony, command *)
   | Subdir of string
   | Def of string * string (* X=foo -> Def ("X","foo") *)
-  | Include of string
+  | MLInclude of string (* -I physicalpath *)
+  | Include of string * string (* -Q physicalpath logicalpath *)
   | RInclude of string * string (* -R physicalpath logicalpath *)
 
 type install =
@@ -53,36 +55,47 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
   | ("-full"|"-opt") :: r ->
     process_cmd_line orig_dir (project_file,makefile,install,true) l r
   | "-impredicative-set" :: r ->
-    Minilib.safe_prerr_endline "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.";
+    Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform.");
     process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r
   | "-no-install" :: r ->
-    Minilib.safe_prerr_endline "Option -no-install is deprecated. Use \"-install none\" instead";
+    Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead")));
     process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r
   | "-install" :: d :: r ->
-    if install <> UnspecInstall then Minilib.safe_prerr_endline "Warning: -install sets more than once.";
+    if install <> UnspecInstall then Pp.msg_warning (Pp.str "-install sets more than once.");
     let install =
       match d with
 	| "user" -> UserInstall
 	| "none" -> NoInstall
 	| "global" -> TraditionalInstall
-	| _ -> Minilib.safe_prerr_endline (String.concat "" ["Warning: invalid option '"; d; "' passed to -install."]);
+	| _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install.")));
           install
     in
     process_cmd_line orig_dir (project_file,makefile,install,opt) l r
   | "-custom" :: com :: dependencies :: file :: r ->
-    process_cmd_line orig_dir opts (Special (file,dependencies,com) :: l) r
+    Pp.msg_warning (Pp.app
+    (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".")
+    (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.")
+    );
+    process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r
+  | "-extra" :: file :: dependencies :: com :: r ->
+    process_cmd_line orig_dir opts (Special (file,dependencies,false,com) :: l) r
+  | "-extra-phony" :: target :: dependencies :: com :: r ->
+    process_cmd_line orig_dir opts (Special (target,dependencies,true,com) :: l) r
+  | "-Q" :: d :: lp :: r ->
+    process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r
   | "-I" :: d :: r ->
-    process_cmd_line orig_dir opts ((Include (Minilib.correct_path d orig_dir)) :: l) r
+    process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r
+  | "-R" :: p :: "-as" :: lp :: r
   | "-R" :: p :: lp :: r ->
-    process_cmd_line orig_dir opts (RInclude (Minilib.correct_path p orig_dir,lp) :: l) r
-  | ("-I"|"-custom") :: _ ->
+    process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r
+  | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ ->
     raise Parsing_error
   | "-f" :: file :: r ->
-    let file = Minilib.remove_path_dot (Minilib.correct_path file orig_dir) in
+    let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in
     let () = match project_file with
       | None -> ()
-      | Some _ -> Minilib.safe_prerr_endline
-	"Warning: Several features will not work with multiple project files."
+      | Some _ -> Pp.msg_warning (Pp.str
+	"Several features will not work with multiple project files.")
     in
     let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in
       process_cmd_line orig_dir opts' l' r
@@ -96,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
 	let () = match makefile with
 	  |None -> ()
 	  |Some f ->
-	     Minilib.safe_prerr_endline ("Warning: Only one output file is genererated. "^f^" will not be.")
+	     Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be.")))
 	in process_cmd_line orig_dir (project_file,Some file,install,opt) l r
       end
   | v :: "=" :: def :: r ->
@@ -104,7 +117,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts)
   | "-arg" :: a :: r ->
     process_cmd_line orig_dir opts (Arg a :: l) r
   | f :: r ->
-      let f = Minilib.correct_path f orig_dir in
+      let f = CUnix.correct_path f orig_dir in
 	process_cmd_line orig_dir opts ((
           if Filename.check_suffix f ".v" then V f
 	  else if (Filename.check_suffix f ".ml") then ML f
@@ -120,41 +133,48 @@ let rec post_canonize f =
     if dir = Filename.current_dir_name then f else post_canonize dir
   else f
 
-(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(i_inc,r_inc),(args,defs)) *)
+(* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *)
 let split_arguments =
   let rec aux = function
   | V n :: r ->
-	let (v,m,o,s),i,d = aux r in ((Minilib.remove_path_dot n::v,m,o,s),i,d)
+	let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d)
   | ML n :: r ->
       let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
-      ((v,(mli,ml4,Minilib.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
+      ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d)
   | MLI n :: r ->
       let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
-      ((v,(Minilib.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
+      ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d)
   | ML4 n :: r ->
       let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
-      ((v,(mli,Minilib.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
+      ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d)
   | MLLIB n :: r ->
       let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
-      ((v,(mli,ml4,ml,Minilib.remove_path_dot n::mllib,mlpack),o,s),i,d)
+      ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d)
   | MLPACK n :: r ->
       let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in
-      ((v,(mli,ml4,ml,mllib,Minilib.remove_path_dot n::mlpack),o,s),i,d)
-  | Special (n,dep,c) :: r ->
-      let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,c)::o,s),i,d)
+      ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d)
+  | Special (n,dep,is_phony,c) :: r ->
+      let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d)
   | Subdir n :: r ->
       let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d)
-  | Include p :: r ->
-      let t,(i,r),d = aux r in (t,((Minilib.remove_path_dot (post_canonize p),
-				    Minilib.canonical_path_name p)::i,r),d)
+  | MLInclude p :: r ->
+      let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p),
+                                   CUnix.canonical_path_name p)::ml,q,r),d)
+  | Include (p,l) :: r ->
+      let t,(ml,i,r),d = aux r in
+      let i_new = (CUnix.remove_path_dot (post_canonize p),l,
+		   CUnix.canonical_path_name p) in
+      (t,(ml,i_new::i,r),d)
   | RInclude (p,l) :: r ->
-      let t,(i,r),d = aux r in (t,(i,(Minilib.remove_path_dot (post_canonize p),l,
-				      Minilib.canonical_path_name p)::r),d)
+      let t,(ml,i,r),d = aux r in
+      let r_new = (CUnix.remove_path_dot (post_canonize p),l,
+		   CUnix.canonical_path_name p) in
+      (t,(ml,i,r_new::r),d)
   | Def (v,def) :: r ->
       let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs))
   | Arg a :: r ->
       let t,i,(args,defs) = aux r in (t,i,(a::args,defs))
-  | [] -> ([],([],[],[],[],[]),[],[]),([],[]),([],[])
+  | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[])
   in aux
 
 let read_project_file f =
@@ -162,27 +182,27 @@ let read_project_file f =
     (snd (process_cmd_line (Filename.dirname f) (Some f, None, NoInstall, true) [] (parse f)))
 
 let args_from_project file project_files default_name =
-  let is_f = Minilib.same_file file in
+  let is_f = CUnix.same_file file in
   let contains_file dir =
-      List.exists (fun x -> is_f (Minilib.correct_path x dir))
+      List.exists (fun x -> is_f (CUnix.correct_path x dir))
   in
-  let build_cmd_line i_inc r_inc args =
-    List.fold_right (fun (_,i) o -> "-I" :: i :: o) i_inc
-      (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc
-	 (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args []))
+  let build_cmd_line ml_inc i_inc r_inc args =
+    List.fold_right (fun (_,i) o -> "-I" :: i :: o) ml_inc
+      (List.fold_right (fun (_,l,i) o -> "-Q" :: i :: l :: o) i_inc
+        (List.fold_right (fun (_,l,p) o -> "-R" :: p :: l :: o) r_inc
+	  (List.fold_right (fun a o -> parse_args (Stream.of_string a) @ o) args [])))
   in try
-      let (_,(_,(i_inc,r_inc),(args,_))) =
+      let (_,(_,(ml_inc,i_inc,r_inc),(args,_))) =
 	List.find (fun (dir,((v_files,_,_,_),_,_)) ->
 		     contains_file dir v_files) project_files in
-	build_cmd_line i_inc r_inc args
+	build_cmd_line ml_inc i_inc r_inc args
     with Not_found ->
       let rec find_project_file dir = try
-	let ((v_files,_,_,_),(i_inc,r_inc),(args,_)) =
+	let ((v_files,_,_,_),(ml_inc,i_inc,r_inc),(args,_)) =
 	  read_project_file (Filename.concat dir default_name) in
 	  if contains_file dir v_files
-	  then build_cmd_line i_inc r_inc args
+	  then build_cmd_line ml_inc i_inc r_inc args
 	  else let newdir = Filename.dirname dir in
-	    Minilib.safe_prerr_endline newdir;
 	    if dir = newdir then [] else find_project_file newdir
       with Sys_error s ->
 	let newdir = Filename.dirname dir in
diff --git a/ide/sentence.ml b/ide/sentence.ml
new file mode 100644
index 00000000..dd6b10a4
--- /dev/null
+++ b/ide/sentence.ml
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {1 Sentences in coqide buffers } *)
+
+(** Cut a part of the buffer in sentences and tag them.
+    Invariant: either this slice ends the buffer, or it ends with ".".
+    May raise [Coq_lex.Unterminated] when the zone ends with
+    an unterminated sentence. *)
+
+let split_slice_lax (buffer:GText.buffer) start stop =
+  buffer#remove_tag ~start ~stop Tags.Script.sentence;
+  buffer#remove_tag ~start ~stop Tags.Script.error;
+  buffer#remove_tag ~start ~stop Tags.Script.error_bg;
+  let slice = buffer#get_text ~start ~stop () in
+  let apply_tag off tag =
+    (* off is now a utf8-compliant char offset, cf Coq_lex.utf8_adjust *)
+    let iter = start#forward_chars off in
+    buffer#apply_tag ~start:iter ~stop:iter#forward_char tag
+  in
+  Coq_lex.delimit_sentences apply_tag slice
+
+(** Searching forward and backward a position fulfilling some condition *)
+
+let rec forward_search cond (iter:GText.iter) =
+  if iter#is_end || cond iter then iter
+  else forward_search cond iter#forward_char
+
+let rec backward_search cond (iter:GText.iter) =
+  if iter#is_start || cond iter then iter
+  else backward_search cond iter#backward_char
+
+let is_sentence_end s =
+  s#has_tag Tags.Script.sentence
+
+let is_char s c = s#char = Char.code c
+
+(** Search backward the first character of a sentence, starting at [iter]
+    and going at most up to [soi] (meant to be the end of the locked zone).
+    Raise [StartError] when no proper sentence start has been found.
+    A character following a ending "." is considered as a sentence start
+    only if this character is a blank. In particular, when a final "."
+    at the end of the locked zone isn't followed by a blank, then this
+    non-blank character will be signaled as erroneous in [tag_on_insert] below.
+*)
+
+exception StartError
+
+let grab_sentence_start (iter:GText.iter) soi =
+  let cond iter =
+    if iter#compare soi < 0 then raise StartError;
+    let prev = iter#backward_char in
+    is_sentence_end prev &&
+      (not (is_char prev '.') ||
+       List.exists (is_char iter) [' ';'\n';'\r';'\t'])
+  in
+  backward_search cond iter
+
+(** Search forward the first character immediately after a sentence end *)
+
+let rec grab_sentence_stop (start:GText.iter) =
+  (forward_search is_sentence_end start)#forward_char
+
+(** Search forward the first character immediately after a "." sentence end
+    (and not just a "\{" or "\}" or comment end *)
+
+let rec grab_ending_dot (start:GText.iter) =
+  let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in
+  (forward_search is_ending_dot start)#forward_char
+
+(** Retag a zone that has been edited *)
+
+let tag_on_insert buffer =
+  (* the start of the non-locked zone *)
+  let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+  (* the inserted zone is between [prev_insert] and [insert] *)
+  let insert = buffer#get_iter_at_mark `INSERT in
+  let prev = buffer#get_iter_at_mark (`NAME "prev_insert") in
+  (* [prev] is normally always before [insert] even when deleting.
+     Let's check this nonetheless *)
+  let prev, insert =
+    if insert#compare prev < 0 then insert, prev else prev, insert
+  in
+  try
+    let start = grab_sentence_start prev soi in
+    (** The status of "{" "}" as sentence delimiters is too fragile.
+        We retag up to the next "." instead. *)
+    let stop = grab_ending_dot insert in
+    try split_slice_lax buffer start#backward_char stop
+    with Coq_lex.Unterminated ->
+      (* This shouldn't happen frequently. Either:
+         - we are at eof, with indeed an unfinished sentence.
+         - we have just inserted an opening of comment or string.
+         - the inserted text ends with a "." that interacts with the "."
+           found by [grab_ending_dot] to form a non-ending "..".
+         In any case, we retag up to eof, since this isn't that costly. *)
+      if not stop#is_end then
+        let eoi = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+        try split_slice_lax buffer start eoi
+        with Coq_lex.Unterminated -> ()
+  with StartError ->
+    buffer#apply_tag ~start:soi ~stop:soi#forward_char Tags.Script.error
+
+let tag_all buffer =
+  let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+  let eoi = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+  try split_slice_lax buffer soi eoi
+  with Coq_lex.Unterminated -> ()
+
+(** Search a sentence around some position *)
+
+let find buffer (start:GText.iter) =
+  let soi = buffer#get_iter_at_mark (`NAME "start_of_input") in
+  try
+    let start = grab_sentence_start start soi in
+    let stop = grab_sentence_stop start in
+    (* Is this phrase non-empty and complete ? *)
+    if stop#compare start > 0 && is_sentence_end stop#backward_char
+    then Some (start,stop)
+    else None
+  with StartError -> None
diff --git a/ide/sentence.mli b/ide/sentence.mli
new file mode 100644
index 00000000..f0ba5d22
--- /dev/null
+++ b/ide/sentence.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Retag the ends of sentences around an inserted zone *)
+
+val tag_on_insert : GText.buffer -> unit
+
+(** Retag the ends of sentences in the non-locked part of the buffer *)
+
+val tag_all : GText.buffer -> unit
+
+(** Search a sentence around some position *)
+
+val find : GText.buffer -> GText.iter -> (GText.iter * GText.iter) option
diff --git a/ide/session.ml b/ide/session.ml
new file mode 100644
index 00000000..29363211
--- /dev/null
+++ b/ide/session.ml
@@ -0,0 +1,517 @@
+(************************************************************************)
+(*  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 Preferences
+
+let prefs = Preferences.current
+
+(** A session is a script buffer + proof + messages,
+    interacting with a coqtop, and a few other elements around *)
+
+class type ['a] page =
+  object
+    inherit GObj.widget
+    method update : 'a -> unit
+    method on_update : callback:('a -> unit) -> unit
+  end
+
+class type control =
+  object
+    method detach : unit -> unit
+  end
+
+type errpage = (int * string) list page
+type jobpage = string CString.Map.t page
+
+type session = {
+  buffer : GText.buffer;
+  script : Wg_ScriptView.script_view;
+  proof : Wg_ProofView.proof_view;
+  messages : Wg_MessageView.message_view;
+  segment : Wg_Segment.segment;
+  fileops : FileOps.ops;
+  coqops : CoqOps.ops;
+  coqtop : Coq.coqtop;
+  command : Wg_Command.command_window;
+  finder : Wg_Find.finder;
+  tab_label : GMisc.label;
+  errpage : errpage;
+  jobpage : jobpage;
+  mutable control : control;
+}
+
+let create_buffer () =
+  let buffer = GSourceView2.source_buffer
+    ~tag_table:Tags.Script.table
+    ~highlight_matching_brackets:true
+    ?language:(lang_manager#language prefs.source_language)
+    ?style_scheme:(style_manager#style_scheme prefs.source_style)
+    ()
+  in
+  let _ = buffer#create_mark ~name:"start_of_input" buffer#start_iter in
+  let _ = buffer#create_mark
+    ~left_gravity:false ~name:"stop_of_input" buffer#end_iter in
+  let _ = buffer#create_mark ~name:"prev_insert" buffer#start_iter in
+  let _ = buffer#place_cursor ~where:buffer#start_iter in
+  let _ = buffer#add_selection_clipboard Ideutils.cb in
+  buffer
+
+let create_script coqtop source_buffer =
+  let script = Wg_ScriptView.script_view coqtop ~source_buffer
+    ~show_line_numbers:true ~wrap_mode:`NONE ()
+  in
+  let _ = script#misc#set_name "ScriptWindow"
+  in
+  script
+
+(** NB: Events during text edition:
+
+    - [begin_user_action]
+    - [insert_text] (or [delete_range] when deleting)
+    - [changed]
+    - [end_user_action]
+
+   When pasting a text containing tags (e.g. the sentence terminators),
+   there is actually many [insert_text] and [changed]. For instance,
+   for "a. b.":
+
+    - [begin_user_action]
+    - [insert_text] (for "a")
+    - [changed]
+    - [insert_text] (for ".")
+    - [changed]
+    - [apply_tag] (for the tag of ".")
+    - [insert_text] (for " b")
+    - [changed]
+    - [insert_text] (for ".")
+    - [changed]
+    - [apply_tag] (for the tag of ".")
+    - [end_user_action]
+
+  Since these copy-pasted tags may interact badly with the retag mechanism,
+  we now don't monitor the "changed" event, but rather the "begin_user_action"
+  and "end_user_action". We begin by setting a mark at the initial cursor
+  point. At the end, the zone between the mark and the cursor is to be
+  untagged and then retagged. *)
+
+let set_buffer_handlers
+  (buffer : GText.buffer) script (coqops : CoqOps.ops) coqtop
+=
+  let action_was_cancelled = ref true in
+  let no_coq_action_required = ref true in
+  let cur_action = ref 0 in
+  let new_action_id =
+    let id = ref 0 in
+    fun () -> incr id; !id in
+  let running_action = ref None in
+  let cancel_signal reason =
+    Minilib.log ("user_action cancelled: "^reason);
+    action_was_cancelled := true;
+    GtkSignal.stop_emit () in
+  let del_mark () =
+    try buffer#delete_mark (`NAME "target")
+    with GText.No_such_mark _ -> () in
+  let add_mark it = del_mark (); buffer#create_mark ~name:"target" it in
+  let call_coq_or_cancel_action f =
+    no_coq_action_required := false;
+    let action = !cur_action in
+    let action, fallback =
+      Coq.seq (Coq.lift (fun () -> running_action := Some action)) f,
+      fun () -> (* If Coq is busy due to the current action, we don't cancel *)
+        match !running_action with
+        | Some aid when aid = action -> ()
+        | _ -> cancel_signal "Coq busy" in
+    Coq.try_grab coqtop action fallback in
+  let get_start () = buffer#get_iter_at_mark (`NAME "start_of_input") in
+  let get_stop () = buffer#get_iter_at_mark (`NAME "stop_of_input") in
+  let ensure_marks_exist () =
+    try ignore(buffer#get_mark (`NAME "stop_of_input"))
+    with GText.No_such_mark _ -> assert false in
+  let get_insert () = buffer#get_iter_at_mark `INSERT in
+  let debug_edit_zone () = if false (*!Minilib.debug*) then begin
+    buffer#remove_tag Tags.Script.edit_zone
+      ~start:buffer#start_iter ~stop:buffer#end_iter;
+    buffer#apply_tag Tags.Script.edit_zone
+      ~start:(get_start()) ~stop:(get_stop())
+    end in
+  let backto_before_error it =
+    let rec aux old it =
+      if it#is_start || not(it#has_tag Tags.Script.error_bg) then old
+      else aux it it#backward_char in
+    aux it it in
+  let insert_cb it s = if String.length s = 0 then () else begin
+    Minilib.log ("insert_cb " ^ string_of_int it#offset);
+    let text_mark = add_mark it in
+    if it#has_tag Tags.Script.to_process then
+      cancel_signal "Altering the script being processed in not implemented"
+    else if it#has_tag Tags.Script.read_only then
+      cancel_signal "Altering read_only text not allowed"
+    else if it#has_tag Tags.Script.processed then
+      call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+    else if it#has_tag Tags.Script.error_bg then begin
+      let prev_sentence_end = backto_before_error it in
+      let text_mark = add_mark prev_sentence_end in
+      call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+    end end in
+  let delete_cb ~start ~stop =
+    Minilib.log (Printf.sprintf "delete_cb %d %d" start#offset stop#offset);
+    cur_action := new_action_id ();
+    let min_iter, max_iter =
+      if start#compare stop < 0 then start, stop else stop, start in
+    let text_mark = add_mark min_iter in
+    let rec aux min_iter =
+      if min_iter#equal max_iter then ()
+      else if min_iter#has_tag Tags.Script.to_process then
+        cancel_signal "Altering the script being processed in not implemented"
+      else if min_iter#has_tag Tags.Script.read_only then
+        cancel_signal "Altering read_only text not allowed"
+      else if min_iter#has_tag Tags.Script.processed then
+        call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+      else if min_iter#has_tag Tags.Script.error_bg then
+        let prev_sentence_end = backto_before_error min_iter in
+        let text_mark = add_mark prev_sentence_end in
+        call_coq_or_cancel_action (coqops#go_to_mark (`MARK text_mark))
+      else aux min_iter#forward_char in
+    aux min_iter in
+  let begin_action_cb () =
+    Minilib.log "begin_action_cb";
+    action_was_cancelled := false;
+    no_coq_action_required := true;
+    cur_action := new_action_id ();
+    let where = get_insert () in
+    buffer#move_mark (`NAME "prev_insert") ~where in
+  let end_action_cb () =
+    Minilib.log "end_action_cb";
+    ensure_marks_exist ();
+    if not !action_was_cancelled then begin
+      (* If coq was asked to backtrack, the clenup must be done by the
+         backtrack_until function, since it may move the stop_of_input
+         to a point indicated by coq. *)
+      if !no_coq_action_required then begin
+        let start, stop = get_start (), get_stop () in
+        buffer#remove_tag Tags.Script.error ~start ~stop;
+        buffer#remove_tag Tags.Script.error_bg ~start ~stop;
+        buffer#remove_tag Tags.Script.tooltip ~start ~stop;
+        buffer#remove_tag Tags.Script.processed ~start ~stop;
+        buffer#remove_tag Tags.Script.to_process ~start ~stop;
+        buffer#remove_tag Tags.Script.incomplete ~start ~stop;
+        Sentence.tag_on_insert buffer
+      end;
+    end in
+  let mark_deleted_cb m =
+    match GtkText.Mark.get_name m with
+    | Some "insert" -> ()
+    | Some s -> Minilib.log (s^" deleted")
+    | None -> ()
+  in
+  let mark_set_cb it m =
+    debug_edit_zone ();
+    let ins = get_insert () in
+    let line = ins#line + 1 in
+    let off = ins#line_offset + 1 in
+    let msg = Printf.sprintf "Line: %5d Char: %3d" line off in
+    let () = !Ideutils.set_location msg in
+    match GtkText.Mark.get_name m with
+    | Some "insert" -> ()
+    | Some s -> Minilib.log (s^" moved")
+    | None -> ()
+  in
+  (** Pluging callbacks *)
+  let _ = buffer#connect#insert_text ~callback:insert_cb in
+  let _ = buffer#connect#delete_range ~callback:delete_cb in
+  let _ = buffer#connect#begin_user_action ~callback:begin_action_cb in
+  let _ = buffer#connect#end_user_action ~callback:end_action_cb in
+  let _ = buffer#connect#after#mark_set ~callback:mark_set_cb in
+  let _ = buffer#connect#after#mark_deleted ~callback:mark_deleted_cb in
+  ()
+
+let find_int_col s l =
+  match List.assoc s l with `IntC c -> c | _ -> assert false
+
+let find_string_col s l =
+  match List.assoc s l with `StringC c -> c | _ -> assert false
+
+let make_table_widget cd cb =
+  let frame = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in
+  let columns, store =
+    let cols = new GTree.column_list in
+    let columns = List.map (function
+      | (`Int,n,_)    -> n, `IntC (cols#add Gobject.Data.int)
+      | (`String,n,_) -> n, `StringC (cols#add Gobject.Data.string))
+    cd in
+    columns, GTree.list_store cols in
+  let data = GTree.view
+      ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment
+      ~rules_hint:true ~headers_visible:false
+      ~model:store ~packing:frame#add () in
+  let () = data#set_headers_visible true in
+  let mk_rend c = GTree.cell_renderer_text [], ["text",c] in
+  let cols =
+    List.map2 (fun (_,c) (_,n,v) ->
+      let c = match c with
+        | `IntC c -> GTree.view_column ~renderer:(mk_rend c) ()
+        | `StringC c -> GTree.view_column ~renderer:(mk_rend c) () in
+      c#set_title n;
+      c#set_visible v;
+      c#set_sizing `AUTOSIZE;
+      c)
+    columns cd in
+  List.iter (fun c -> ignore(data#append_column c)) cols;
+  ignore(
+    data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc)
+  );
+  frame, (fun f -> f columns store)
+
+let create_errpage (script : Wg_ScriptView.script_view) : errpage =
+  let table, access =
+    make_table_widget
+      [`Int,"Line",true; `String,"Error message",true]
+      (fun columns store tp vc ->
+        let row = store#get_iter tp in
+        let lno = store#get ~row ~column:(find_int_col "Line" columns) in
+        let where = script#buffer#get_iter (`LINE (lno-1)) in
+        script#buffer#place_cursor ~where;
+        ignore (script#scroll_to_iter
+		  ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in
+  let tip = GMisc.label ~text:"Double click to jump to error line" () in
+  let box = GPack.vbox ~homogeneous:false () in
+  let () = box#pack ~expand:true table#coerce in
+  let () = box#pack ~expand:false ~padding:2 tip#coerce in
+  let last_update = ref [] in
+  let callback = ref (fun _ -> ()) in
+  object (self)
+    inherit GObj.widget box#as_widget
+    method update errs =
+      if !last_update = errs then ()
+      else begin
+	last_update := errs;
+	access (fun _ store -> store#clear ());
+        !callback errs;
+	List.iter (fun (lno, msg) -> access (fun columns store ->
+          let line = store#append () in
+          store#set line (find_int_col "Line" columns) lno;
+          store#set line (find_string_col "Error message" columns) msg))
+          errs
+      end
+    method on_update ~callback:cb = callback := cb
+  end
+
+let create_jobpage coqtop coqops : jobpage =
+  let table, access =
+    make_table_widget
+      [`String,"Worker",true; `String,"Job name",true]
+      (fun columns store tp vc ->
+        let row = store#get_iter tp in
+        let w = store#get ~row ~column:(find_string_col "Worker" columns) in
+	let info () = Minilib.log ("Coq busy, discarding query") in
+	Coq.try_grab coqtop (coqops#stop_worker w) info
+      ) in
+  let tip = GMisc.label ~text:"Double click to interrupt worker" () in
+  let box = GPack.vbox ~homogeneous:false () in
+  let () = box#pack ~expand:true table#coerce in
+  let () = box#pack ~expand:false ~padding:2 tip#coerce in
+  let last_update = ref CString.Map.empty in
+  let callback = ref (fun _ -> ()) in
+  object (self)
+    inherit GObj.widget box#as_widget
+    method update jobs =
+      if !last_update = jobs then ()
+      else begin
+	last_update := jobs;
+	access (fun _ store -> store#clear ());
+        !callback jobs;
+	CString.Map.iter (fun id job -> access (fun columns store ->
+          let column = find_string_col "Worker" columns in
+          if job = "Dead" then
+            store#foreach (fun _ row ->
+              if store#get ~row ~column = id then store#remove row || true
+              else false)
+          else
+            let line = store#append () in
+            store#set line column id;
+            store#set line (find_string_col "Job name" columns) job))
+          jobs
+      end
+    method on_update ~callback:cb = callback := cb
+  end
+
+let create_proof () =
+  let proof = Wg_ProofView.proof_view () in
+  let _ = proof#misc#set_can_focus true in
+  let _ = GtkBase.Widget.add_events proof#as_widget
+    [`ENTER_NOTIFY;`POINTER_MOTION]
+  in
+  proof
+
+let create_messages () =
+  let messages = Wg_MessageView.message_view () in
+  let _ = messages#misc#set_can_focus true in
+  messages
+
+let dummy_control : control =
+  object
+    method detach () = ()
+  end
+
+let create file coqtop_args =
+  let basename = match file with
+    |None -> "*scratch*"
+    |Some f -> Glib.Convert.filename_to_utf8 (Filename.basename f)
+  in
+  let coqtop = Coq.spawn_coqtop coqtop_args in
+  let reset () = Coq.reset_coqtop coqtop in
+  let buffer = create_buffer () in
+  let script = create_script coqtop buffer in
+  let proof = create_proof () in
+  let messages = create_messages () in
+  let segment = new Wg_Segment.segment () in
+  let command = new Wg_Command.command_window basename coqtop in
+  let finder = new Wg_Find.finder basename (script :> GText.view) in
+  let fops = new FileOps.fileops (buffer :> GText.buffer) file reset in
+  let _ = fops#update_stats in
+  let cops =
+    new CoqOps.coqops script proof messages segment coqtop (fun () -> fops#filename) in
+  let errpage = create_errpage script in
+  let jobpage = create_jobpage coqtop cops in
+  let _ = set_buffer_handlers (buffer :> GText.buffer) script cops coqtop in
+  let _ = Coq.set_reset_handler coqtop cops#handle_reset_initial in
+  let _ = Coq.init_coqtop coqtop cops#initialize in
+  {
+    buffer = (buffer :> GText.buffer);
+    script=script;
+    proof=proof;
+    messages=messages;
+    segment=segment;
+    fileops=fops;
+    coqops=cops;
+    coqtop=coqtop;
+    command=command;
+    finder=finder;
+    tab_label= GMisc.label ~text:basename ();
+    errpage=errpage;
+    jobpage=jobpage;
+    control = dummy_control;
+  }
+
+let kill (sn:session) =
+  (* To close the detached views of this script, we call manually
+     [destroy] on it, triggering some callbacks in [detach_view].
+     In a more modern lablgtk, rather use the page-removed signal ? *)
+  sn.coqops#destroy ();
+  sn.script#destroy ();
+  Coq.close_coqtop sn.coqtop
+
+let build_layout (sn:session) =
+  let session_paned = GPack.paned `VERTICAL () in
+  let session_box =
+    GPack.vbox ~packing:(session_paned#pack1 ~shrink:false ~resize:true) ()
+  in
+
+  (** Right part of the window. *)
+
+  let eval_paned = GPack.paned `HORIZONTAL ~border_width:5
+    ~packing:(session_box#pack ~expand:true) () in
+  let script_frame = GBin.frame ~shadow_type:`IN
+    ~packing:eval_paned#add1 () in
+  let script_scroll = GBin.scrolled_window
+    ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in
+  let state_paned = GPack.paned `VERTICAL
+    ~packing:eval_paned#add2 () in
+
+  (** Proof buffer. *)
+
+  let title = Printf.sprintf "Proof (%s)" sn.tab_label#text in
+  let proof_detachable = Wg_Detachable.detachable ~title () in
+  let () = proof_detachable#button#misc#hide () in
+  let () = proof_detachable#frame#set_shadow_type `IN in
+  let () = state_paned#add1 proof_detachable#coerce in
+  let callback _ = proof_detachable#show in
+  let () = proof_detachable#connect#attached ~callback in
+  let callback _ =
+    sn.proof#coerce#misc#set_size_request ~width:500 ~height:400 ()
+  in
+  let () = proof_detachable#connect#detached ~callback in
+  let proof_scroll = GBin.scrolled_window
+    ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:proof_detachable#pack () in
+
+  (** Message buffer. *)
+
+  let message_frame = GPack.notebook ~packing:state_paned#add () in
+  let add_msg_page pos name text (w : GObj.widget) =
+    let detachable =
+      Wg_Detachable.detachable ~title:(text^" ("^name^")") () in
+    detachable#add w#coerce;
+    let label = GPack.hbox ~spacing:5 () in
+    let lbl = GMisc.label ~text ~packing:label#add () in
+    let but = GButton.button () in
+    but#add (GMisc.label ~markup:"<small>↗</small>" ())#coerce;
+    label#add but#coerce;
+    ignore(message_frame#insert_page ~pos
+      ~tab_label:label#coerce detachable#coerce);
+    ignore(but#connect#clicked ~callback:(fun _ ->
+      message_frame#remove_page (message_frame#page_num detachable#coerce);
+      detachable#button#clicked ()));
+    detachable#connect#detached ~callback:(fun _ ->
+      if message_frame#all_children = [] then message_frame#misc#hide ();
+      w#misc#set_size_request  ~width:500 ~height:400 ());
+    detachable#connect#attached ~callback:(fun _ ->
+      ignore(message_frame#insert_page ~pos
+        ~tab_label:label#coerce detachable#coerce);
+      message_frame#misc#show ();
+      detachable#show);
+    detachable#button#misc#hide ();
+    lbl in
+  let session_tab = GPack.hbox ~homogeneous:false () in
+  let img = GMisc.image ~icon_size:`SMALL_TOOLBAR
+    ~packing:session_tab#pack () in
+  let _ =
+    sn.buffer#connect#modified_changed
+      ~callback:(fun () -> if sn.buffer#modified
+        then img#set_stock `SAVE
+        else img#set_stock `YES) in
+  let _ =
+    eval_paned#misc#connect#size_allocate
+      ~callback:
+      (let old_paned_width = ref 2 in
+       let old_paned_height = ref 2 in
+       fun {Gtk.width=paned_width;Gtk.height=paned_height} ->
+         if !old_paned_width <> paned_width ||
+            !old_paned_height <> paned_height
+         then begin
+           eval_paned#set_position
+             (eval_paned#position * paned_width / !old_paned_width);
+           state_paned#set_position
+             (state_paned#position * paned_height / !old_paned_height);
+           old_paned_width := paned_width;
+           old_paned_height := paned_height;
+	 end)
+  in
+  session_box#pack sn.finder#coerce;
+  session_box#pack sn.segment#coerce;
+  sn.command#pack_in (session_paned#pack2 ~shrink:false ~resize:false);
+  script_scroll#add sn.script#coerce;
+  proof_scroll#add sn.proof#coerce;
+  ignore(add_msg_page 0 sn.tab_label#text "Messages" sn.messages#coerce);
+  let label = add_msg_page 1 sn.tab_label#text "Errors" sn.errpage#coerce in
+  ignore(add_msg_page 2 sn.tab_label#text "Jobs" sn.jobpage#coerce);
+  let txt = label#text in
+  let red s = "<span foreground=\"#FF0000\">" ^ s ^ "</span>" in
+  sn.errpage#on_update ~callback:(fun l ->
+    if l = [] then (label#set_use_markup false; label#set_text txt)
+    else (label#set_text (red txt);label#set_use_markup true));
+  session_tab#pack sn.tab_label#coerce;
+  img#set_stock `YES;
+  eval_paned#set_position 1;
+  state_paned#set_position 1;
+  let control =
+    object
+      method detach () = proof_detachable#detach ()
+    end
+  in
+  let () = sn.control <- control in
+  (Some session_tab#coerce,None,session_paned#coerce)
diff --git a/ide/session.mli b/ide/session.mli
new file mode 100644
index 00000000..3a6b4585
--- /dev/null
+++ b/ide/session.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** A session is a script buffer + proof + messages,
+    interacting with a coqtop, and a few other elements around *)
+
+class type ['a] page =
+  object
+    inherit GObj.widget
+    method update : 'a -> unit
+    method on_update : callback:('a -> unit) -> unit
+  end
+
+class type control =
+  object
+    method detach : unit -> unit
+  end
+
+type errpage = (int * string) list page
+type jobpage = string CString.Map.t page
+
+type session = {
+  buffer : GText.buffer;
+  script : Wg_ScriptView.script_view;
+  proof : Wg_ProofView.proof_view;
+  messages : Wg_MessageView.message_view;
+  segment : Wg_Segment.segment;
+  fileops : FileOps.ops;
+  coqops : CoqOps.ops;
+  coqtop : Coq.coqtop;
+  command : Wg_Command.command_window;
+  finder : Wg_Find.finder;
+  tab_label : GMisc.label;
+  errpage : errpage;
+  jobpage : jobpage;
+  mutable control : control;
+}
+
+(** [create filename coqtop_args] *)
+val create : string option -> string list -> session
+
+val kill : session -> unit
+
+val build_layout : session ->
+  GObj.widget option * GObj.widget option * GObj.widget
diff --git a/ide/tags.ml b/ide/tags.ml
index 955dfa96..04ad9a51 100644
--- a/ide/tags.ml
+++ b/ide/tags.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        *)
@@ -15,25 +15,37 @@ let make_tag (tt:GText.tag_table) ~name prop =
 
 let processed_color = ref "light green"
 let processing_color = ref "light blue"
+let error_color = ref "#FFCCCC"
 
 module Script =
 struct
   let table = GText.tag_table ()
-  let kwd = make_tag table ~name:"kwd" [`FOREGROUND "blue"]
-  let qed = make_tag table ~name:"qed" [`FOREGROUND "blue"]
-  let decl = make_tag table ~name:"decl" [`FOREGROUND "orange red"]
-  let proof_decl = make_tag table ~name:"proof_decl" [`FOREGROUND "orange red"]
-  let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"]
-  let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"]
-  let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]
-  let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false]
-  let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false]
-  let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false]
+  let comment = make_tag table ~name:"comment" []
+  let error = make_tag table ~name:"error" [`UNDERLINE `SINGLE ; `FOREGROUND "red"]
+  let error_bg = make_tag table ~name:"error_bg" [`BACKGROUND !error_color]
+  let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color]
+  let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color]
+  let incomplete = make_tag table ~name:"incomplete" [
+          `BACKGROUND !processing_color;
+          `BACKGROUND_STIPPLE_SET true;
+  ]
+  let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"]
   let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"]
-  let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false]
-  let folded = make_tag table ~name:"locked" [`EDITABLE false; `BACKGROUND "light grey"]
-  let paren = make_tag table ~name:"paren" [`BACKGROUND "purple"]
   let sentence = make_tag table ~name:"sentence" []
+  let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *)
+
+  let all =
+    [comment; error; error_bg; to_process; processed; incomplete; unjustified;
+     found; sentence; tooltip]
+
+  let edit_zone =
+    let t = make_tag table ~name:"edit_zone" [`UNDERLINE `SINGLE] in
+    t#set_priority (List.length all);
+    t
+  let all = edit_zone :: all
+  
+  let read_only = make_tag table ~name:"read_only" [`EDITABLE false ]
+
 end
 module Proof =
 struct
@@ -46,6 +58,8 @@ module Message =
 struct
   let table = GText.tag_table ()
   let error = make_tag table ~name:"error" [`FOREGROUND "red"]
+  let warning = make_tag table ~name:"warning" [`FOREGROUND "orange"]
+  let item = make_tag table ~name:"item" [`WEIGHT `BOLD]
 end
 
 let string_of_color clr =
@@ -71,4 +85,12 @@ let get_processing_color () = color_of_string !processing_color
 let set_processing_color clr =
   let s = string_of_color clr in
   processing_color := s;
+  Script.incomplete#set_property (`BACKGROUND s);
   Script.to_process#set_property (`BACKGROUND s)
+
+let get_error_color () = color_of_string !error_color
+
+let set_error_color clr =
+  let s = string_of_color clr in
+  error_color := s;
+  Script.error_bg#set_property (`BACKGROUND s)
diff --git a/ide/tags.mli b/ide/tags.mli
index 3cc4920a..9c3261d6 100644
--- a/ide/tags.mli
+++ b/ide/tags.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        *)
@@ -9,21 +9,21 @@
 module Script :
 sig
   val table : GText.tag_table
-  val kwd : GText.tag
-  val qed : GText.tag
-  val decl : GText.tag
-  val proof_decl : GText.tag
   val comment : GText.tag
-  val reserved : GText.tag
   val error : GText.tag
+  val error_bg : GText.tag
   val to_process : GText.tag
   val processed : GText.tag
+  val incomplete : GText.tag
   val unjustified : GText.tag
   val found : GText.tag
-  val hidden : GText.tag
-  val folded : GText.tag
-  val paren : GText.tag
   val sentence : GText.tag
+  val tooltip : GText.tag
+  val edit_zone : GText.tag (* for debugging *)
+  val all : GText.tag list
+
+  (* Not part of the all list. Special tags! *)
+  val read_only : GText.tag
 end
 
 module Proof :
@@ -38,6 +38,8 @@ module Message :
 sig
   val table : GText.tag_table
   val error : GText.tag
+  val warning : GText.tag
+  val item : GText.tag
 end
 
 val string_of_color : Gdk.color -> string
@@ -48,3 +50,6 @@ val set_processed_color : Gdk.color -> unit
 
 val get_processing_color : unit -> Gdk.color
 val set_processing_color : Gdk.color -> unit
+
+val get_error_color : unit -> Gdk.color
+val set_error_color : Gdk.color -> unit
diff --git a/ide/undo.ml b/ide/undo.ml
deleted file mode 100644
index 8456cf9f..00000000
--- a/ide/undo.ml
+++ /dev/null
@@ -1,175 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Ideutils
-open GText
-type action =
-  | Insert of string * int * int (* content*pos*length *)
-  | Delete of string * int * int (* content*pos*length *)
-
-let neg act = match act with
-  | Insert (s,i,l) -> Delete (s,i,l)
-  | Delete (s,i,l) -> Insert (s,i,l)
-
-class undoable_view (tv:[>Gtk.text_view] Gtk.obj) =
-  let undo_lock = ref true in
-object(self)
-  inherit GText.view tv as super
-  val history = (Stack.create () : action Stack.t)
-  val redo = (Queue.create () : action Queue.t)
-  val nredo = (Stack.create () : action Stack.t)
-
-  method private dump_debug =
-    if false (* !debug *) then begin
-      prerr_endline "==========Stack top=============";
-      Stack.iter
-	(fun e -> match e with
-	   | Insert(s,p,l) ->
- 	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
-	   | Delete(s,p,l) ->
-	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
-	history;
-      Printf.eprintf "Stack size %d\n" (Stack.length history);
-      prerr_endline "==========Stack Bottom==========";
-      prerr_endline "==========Queue start=============";
-      Queue.iter
-	(fun e -> match e with
-	   | Insert(s,p,l) ->
- 	       Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l
-	   | Delete(s,p,l) ->
-	       Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l)
-	redo;
-      Printf.eprintf "Stack size %d\n" (Queue.length redo);
-      prerr_endline "==========Queue End=========="
-
-    end
-
-  method clear_undo = Stack.clear history; Stack.clear nredo; Queue.clear redo
-
-  method undo = if !undo_lock then begin
-    undo_lock := false;
-    prerr_endline "UNDO";
-    try begin
-      let r =
-	match Stack.pop history with
-	  | Insert(s,p,l) as act ->
-	      let start = self#buffer#get_iter_at_char p in
-	      (self#buffer#delete_interactive
-		 ~start
-		 ~stop:(start#forward_chars l)
-		 ()) or
-	      (Stack.push act history; false)
-	  | Delete(s,p,l) as act ->
-	      let iter = self#buffer#get_iter_at_char p in
-	      (self#buffer#insert_interactive ~iter s) or
-	      (Stack.push act history; false)
-      in if r then begin
-	let act = Stack.pop history in
-	Queue.push act redo;
-	Stack.push act nredo
-      end;
-      undo_lock := true;
-      r
-    end
-    with Stack.Empty ->
-      undo_lock := true;
-      false
-  end else
-    (prerr_endline "UNDO DISCARDED"; true)
-
-  method redo = prerr_endline "REDO"; true
-  initializer
-(* INCORRECT: is called even while undoing...
-   ignore (self#buffer#connect#mark_set
-	      ~callback:
-	      (fun it tm -> if !undo_lock && not (Queue.is_empty redo) then begin
-		 Stack.iter (fun e -> Stack.push (neg e) history) nredo;
-		 Stack.clear nredo;
-		 Queue.iter (fun e -> Stack.push e history) redo;
-		 Queue.clear redo;
-	       end)
-	   );
-*)
-    ignore (self#buffer#connect#insert_text
-	      ~callback:
-	      (fun it s ->
-		 if !undo_lock && not (Queue.is_empty redo) then begin
-		   Stack.iter (fun e -> Stack.push (neg e) history) nredo;
-		   Stack.clear nredo;
-		   Queue.iter (fun e -> Stack.push e history) redo;
-		   Queue.clear redo;
-		 end;
-(*		 let pos = it#offset in
-		 if Stack.is_empty history or
-		   s=" " or s="\t" or s="\n" or
-					(match Stack.top history with
-					   | Insert(old,opos,olen) ->
-					       opos + olen <> pos
-					   | _ -> true)
-		 then *)
-		 Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history
-		 (*else begin
-		   match Stack.pop history with
-		     | Insert(olds,offset,len) ->
-			 Stack.push
-			 (Insert(olds^s,
-				 offset,
-				 len+(Glib.Utf8.length s)))
-			 history
-		     | _ -> assert false
-		   end*);
-		 self#dump_debug
-	      ));
-    ignore (self#buffer#connect#delete_range
-	      ~callback:
-	      (fun ~start ~stop ->
-		 if !undo_lock && not (Queue.is_empty redo) then begin
-		   Queue.iter (fun e -> Stack.push e history) redo;
-		   Queue.clear redo;
-		 end;
-		 let start_offset = start#offset in
-		 let stop_offset = stop#offset in
-		 let s = self#buffer#get_text ~start ~stop () in
-(*		 if Stack.is_empty history or (match Stack.top history with
-						 | Delete(old,opos,olen) ->
-						     olen=1 or opos <> start_offset
-						 | _ -> true
-					      )
-		 then
-*)		   Stack.push
-		     (Delete(s,
-			     start_offset,
-			     stop_offset - start_offset
-			    ))
-		     history
-	(*	 else begin
-		   match Stack.pop history with
-		     | Delete(olds,offset,len) ->
-			 Stack.push
-			 (Delete(olds^s,
-				 offset,
-				 len+(Glib.Utf8.length s)))
-			 history
-		     | _ -> assert false
-
-		 end*);
-		 self#dump_debug
-	      ))
-end
-
-let undoable_view ?(buffer:GText.buffer option) =
-  GtkText.View.make_params []
-    ~cont:(GContainer.pack_container
-	     ~create:
-	     (fun pl -> let w = match buffer with
-	      | None -> GtkText.View.create []
-	      | Some b -> GtkText.View.create_with_buffer b#as_buffer
-	      in
-	      Gobject.set_params w pl; ((new undoable_view w):undoable_view)))
-
-
diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli
deleted file mode 100644
index ea7f85ef..00000000
--- a/ide/undo_lablgtk_ge212.mli
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* An undoable view class *)
-
-class undoable_view : ([> Gtk.text_view] as 'a) Gtk.obj ->
-object
-  inherit GText.view
-  val obj : 'a Gtk.obj
-  method undo : bool
-  method redo : bool
-  method clear_undo : unit
-end
-
-val undoable_view :
-    ?buffer:GText.buffer ->
-    ?editable:bool ->
-    ?cursor_visible:bool ->
-    ?justification:GtkEnums.justification ->
-    ?wrap_mode:GtkEnums.wrap_mode ->
-    ?accepts_tab:bool ->
-    ?border_width:int ->
-    ?width:int ->
-    ?height:int ->
-    ?packing:(GObj.widget -> unit) ->
-    ?show:bool ->
-    unit ->
-  undoable_view
-
-
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli
deleted file mode 100644
index 12396fca..00000000
--- a/ide/undo_lablgtk_ge26.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* An undoable view class *)
-
-class undoable_view : [> Gtk.text_view] Gtk.obj ->
-object
-  inherit GText.view
-  method undo : bool
-  method redo : bool
-  method clear_undo : unit
-end
-
-val undoable_view :
-    ?buffer:GText.buffer ->
-    ?editable:bool ->
-    ?cursor_visible:bool ->
-    ?justification:GtkEnums.justification ->
-    ?wrap_mode:GtkEnums.wrap_mode ->
-    ?border_width:int ->
-    ?width:int ->
-    ?height:int ->
-    ?packing:(GObj.widget -> unit) ->
-    ?show:bool ->
-    unit ->
-  undoable_view
-
-
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index dac519eb..621833dd 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -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/ide/utils/config_file.ml b/ide/utils/config_file.ml
index 921d3d9c..4d0aabeb 100644
--- a/ide/utils/config_file.ml
+++ b/ide/utils/config_file.ml
@@ -128,8 +128,8 @@ Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allo
   open Format
   (* formating convention: the caller has to open the box, close it and flush the output *)
   (* remarks on Format:
-     set_margin impose un appel à set_max_indent
-     sprintf et bprintf sont flushées à chaque appel*)
+     set_margin forces a call to set_max_indent
+     sprintf et bprintf are flushed at each call*)
 
   (* pretty print a Raw.cp *)
   let rec save formatter = function
diff --git a/ide/utils/config_file.mli b/ide/utils/config_file.mli
index b9c77682..22328e7f 100644
--- a/ide/utils/config_file.mli
+++ b/ide/utils/config_file.mli
@@ -141,8 +141,8 @@ exception Missing_cp of groupable_cp
 or used to generate command line arguments.
 
 The basic usage is to have only one group and one configuration file,
-but this mechanism allows to have more,
-for instance to have another smaller group for the options to pass on the command line.
+but this mechanism allows having more,
+for instance having another smaller group for the options to pass on the command line.
 *)
 class group : object
   (** Adds a cp to the group.
diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml
index 7dbd0452..c1062a9d 100644
--- a/ide/utils/configwin_ihm.ml
+++ b/ide/utils/configwin_ihm.ml
@@ -38,7 +38,7 @@ class type widget =
 let file_html_config = Filename.concat Configwin_messages.home ".configwin_html"
 
 let debug = false
-let dbg = if debug then prerr_endline else (fun _ -> ())
+let dbg s = if debug then Minilib.log s else ()
 
 (** Return the config group for the html config file,
    and the option for bindings. *)
@@ -67,7 +67,7 @@ let html_config_file_and_option () =
 let last_dir = ref "";;
 
 (** This function allows the user to select a file and returns the
-   selected file name. An optional function allows to change the
+   selected file name. An optional function allows changing the
    behaviour of the ok button.
    A VOIR : mutli-selection ? *)
 let select_files ?dir
@@ -1015,7 +1015,7 @@ class configuration_box (tt : GData.tooltips) conf_struct =
 
   let set_icon iter = function
   | None -> ()
-  | Some icon -> tree#set iter icon_col icon
+  | Some icon -> tree#set ~row:iter ~column:icon_col icon
   in
 
   (* Populate the tree *)
@@ -1036,9 +1036,9 @@ class configuration_box (tt : GData.tooltips) conf_struct =
           method apply () = List.iter (fun param -> param#apply) params
         end
       in
-      let () = tree#set new_iter label_col label in
+      let () = tree#set ~row:new_iter ~column:label_col label in
       let () = set_icon new_iter icon in
-      let () = tree#set new_iter box_col widget in
+      let () = tree#set ~row:new_iter ~column:box_col widget in
       ()
     | Section_list (label, icon, struct_list) ->
       let widget =
@@ -1049,9 +1049,9 @@ class configuration_box (tt : GData.tooltips) conf_struct =
           method box = box#coerce
         end
       in
-      let () = tree#set new_iter label_col label in
+      let () = tree#set ~row:new_iter ~column:label_col label in
       let () = set_icon new_iter icon in
-      let () = tree#set new_iter box_col widget in
+      let () = tree#set ~row:new_iter ~column:box_col widget in
       List.iter (make_tree (Some new_iter)) struct_list
   in
 
diff --git a/ide/utils/configwin_messages.ml b/ide/utils/configwin_messages.ml
index de292431..de1b4721 100644
--- a/ide/utils/configwin_messages.ml
+++ b/ide/utils/configwin_messages.ml
@@ -30,7 +30,7 @@ let version = "1.2";;
 
 let html_config = "Configwin bindings configurator for html parameters"
 
-let home = Minilib.home
+let home = Option.default "" (Glib.get_home_dir ())
 
 let mCapture = "Capture";;
 let mType_key = "Type key" ;;
diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml
index 5e2b1e7c..ace751c6 100644
--- a/ide/utils/configwin_types.ml
+++ b/ide/utils/configwin_types.ml
@@ -52,7 +52,7 @@ let string_to_key s =
       | '4' -> `MOD4
       | '5' -> `MOD5
       | _ ->
-	  prerr_endline s;
+	  Minilib.log s;
 	  raise Not_found
       in
       mask := m :: !mask
@@ -65,7 +65,7 @@ let string_to_key s =
     !mask, List.assoc key name_to_keysym
   with
     e ->
-      prerr_endline s;
+      Minilib.log s;
       raise e
 
 let key_to_string (m, k) =
@@ -116,7 +116,7 @@ let value_to_key v =
   match v with
     Raw.String s -> string_to_key s
   | _ ->
-      prerr_endline "value_to_key";
+      Minilib.log "value_to_key";
       raise Not_found
 
 let key_to_value k =
diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml
index 1ab107c7..33968b8d 100644
--- a/ide/utils/editable_cells.ml
+++ b/ide/utils/editable_cells.ml
@@ -1,4 +1,3 @@
-open GTree
 open Gobject
 
 let create l =
diff --git a/ide/utils/okey.ml b/ide/utils/okey.ml
index 905c3485..580f1fbc 100644
--- a/ide/utils/okey.ml
+++ b/ide/utils/okey.ml
@@ -115,7 +115,7 @@ let key_press w ev =
 	  (fun h ->
 	    if h.cond () then
 	      try h.cback ()
-	      with e -> prerr_endline (Printexc.to_string e)
+	      with e -> Minilib.log (Printexc.to_string e)
 	    else ()
 	  )
 	  l;
diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml
new file mode 100644
index 00000000..7dad92ed
--- /dev/null
+++ b/ide/wg_Command.ml
@@ -0,0 +1,166 @@
+(************************************************************************)
+(*  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 Preferences
+
+class command_window name coqtop =
+  let frame = Wg_Detachable.detachable
+    ~title:(Printf.sprintf "Query pane (%s)" name) () in
+  let _ = frame#hide in
+  let _ = GtkData.AccelGroup.create () in
+  let notebook =
+    GPack.notebook ~height:200 ~scrollable:true ~packing:frame#add () in
+  let _ = frame#connect#attached ~callback:(fun _ ->
+    notebook#misc#set_size_request ~height:200 ()) in
+  let _ = frame#connect#detached ~callback:(fun _ ->
+    notebook#misc#set_size_request ~width:600 ~height:500 ();
+    notebook#misc#grab_focus ()) in
+
+object(self)
+  val frame = frame
+
+  val notebook = notebook
+
+  method pack_in (f : GObj.widget -> unit) = f frame#coerce
+
+  val mutable new_page : GObj.widget = (GMisc.label ())#coerce
+
+  val mutable views = []
+
+  method private new_page_maker =
+    let page = notebook#append_page
+      (GMisc.label ~text:"No query" ())#coerce in
+    let page = notebook#get_nth_page page in
+    let b = GButton.button () in
+    b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,12)) `NEW);
+    ignore(b#connect#clicked ~callback:self#new_query);
+    notebook#set_page ~tab_label:b#coerce page;
+    new_page <- page
+
+  method new_query ?command ?term () = self#new_query_aux ?command ?term ()
+
+  method private new_query_aux ?command ?term ?(grab_now=true) () =
+    let frame = GBin.frame ~shadow_type:`NONE () in
+    ignore(notebook#insert_page ~pos:(notebook#page_num new_page) frame#coerce);
+    let new_tab_lbl text =
+      let hbox = GPack.hbox ~homogeneous:false () in
+      ignore(GMisc.label ~width:100 ~ellipsize:`END ~text ~packing:hbox#pack());
+      let b = GButton.button ~packing:hbox#pack () in
+      ignore(b#connect#clicked ~callback:(fun () ->
+        views <-
+          List.filter (fun (f,_,_) -> f#get_oid <> frame#coerce#get_oid) views;
+        notebook#remove_page (notebook#page_num frame#coerce)));
+      b#add (Ideutils.stock_to_widget ~size:(`CUSTOM(12,10)) `CLOSE);
+      hbox#coerce in
+    notebook#set_page ~tab_label:(new_tab_lbl "New query") frame#coerce;
+    notebook#goto_page (notebook#page_num frame#coerce);
+    let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
+    let combo, entry, ok_b =
+      let bar =
+        GButton.toolbar ~style:`ICONS ~packing:(vbox#pack ~expand:false) () in
+      let bar_add ~expand w =
+        let item = GButton.tool_item ~expand () in
+        item#add w#coerce;
+        bar#insert item in
+      let combo, _ =
+        GEdit.combo_box_entry_text ~strings:Coq_commands.state_preserving () in
+      combo#entry#set_text "Search";
+      let entry = GEdit.entry () in
+      entry#misc#set_can_default true;
+      let ok_b = GButton.button () in
+      ok_b#add (Ideutils.stock_to_widget `OK);
+      bar_add ~expand:false combo;
+      bar_add ~expand:true entry;
+      bar_add ~expand:false ok_b;
+      combo, entry, ok_b in
+    let r_bin =
+      GBin.scrolled_window
+	~vpolicy:`AUTOMATIC
+	~hpolicy:`AUTOMATIC
+	~packing:(vbox#pack ~fill:true ~expand:true) () in
+    let result = GText.view ~packing:r_bin#add () in
+    views <- (frame#coerce, result, combo#entry) :: views;
+    result#misc#modify_font current.text_font;
+    let clr = Tags.color_of_string current.background_color in
+    result#misc#modify_base [`NORMAL, `COLOR clr];
+    result#misc#set_can_focus true; (* false causes problems for selection *)
+    result#set_editable false;
+    let callback () =
+      let com = combo#entry#text in
+      let arg = entry#text in
+      if Str.string_match (Str.regexp "^ *$") (com^arg) 0 then () else
+      let phrase =
+        if Str.string_match (Str.regexp "\\. *$") com 0 then com
+        else com ^ " " ^ arg ^" . "
+      in
+      let log level message = result#buffer#insert (message^"\n") in
+      let process =
+	Coq.bind (Coq.query ~logger:log (phrase,Stateid.dummy)) (function
+          | Interface.Fail (_,l,str) ->
+            result#buffer#insert str;
+            notebook#set_page ~tab_label:(new_tab_lbl "Error") frame#coerce;
+	    Coq.return ()
+          | Interface.Good res ->
+            result#buffer#insert res; 
+            notebook#set_page ~tab_label:(new_tab_lbl arg) frame#coerce;
+	    Coq.return ())
+      in
+      result#buffer#set_text ("Result for command " ^ phrase ^ ":\n");
+      Coq.try_grab coqtop process ignore
+    in
+    ignore (combo#entry#connect#activate ~callback);
+    ignore (ok_b#connect#clicked ~callback);
+    begin match command with
+      | None -> ()
+      | Some c -> combo#entry#set_text c
+    end;
+    begin match term with
+      | None -> ()
+      | Some t -> entry#set_text t
+    end;
+    combo#entry#misc#grab_focus ();
+    if grab_now then entry#misc#grab_default ();
+    ignore (entry#connect#activate ~callback);
+    ignore (combo#entry#connect#activate ~callback);
+    ignore (combo#entry#event#connect#key_press ~callback:(fun ev ->
+      if GdkEvent.Key.keyval ev = GdkKeysyms._Tab then
+        (entry#misc#grab_focus ();true)
+      else false))
+
+  method show =
+    frame#show;
+    let cur_page = notebook#get_nth_page notebook#current_page in
+    let _, _, e =
+      List.find (fun (p,_,_) -> p#get_oid == cur_page#get_oid) views in
+    e#misc#grab_focus ()
+
+  method hide =
+    frame#hide
+
+  method visible =
+    frame#visible
+  
+  method refresh_font () =
+    let iter (_,view,_) = view#misc#modify_font current.text_font in
+    List.iter iter views
+
+  method refresh_color () =
+    let clr = Tags.color_of_string current.background_color in
+    let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in
+    List.iter iter views
+
+  initializer
+    self#new_page_maker;
+    self#new_query_aux ~grab_now:false ();
+    frame#misc#hide ();
+    ignore(notebook#event#connect#key_press ~callback:(fun ev ->
+      if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then (self#hide; true)
+      else false
+    ));
+
+end
diff --git a/ide/command_windows.mli b/ide/wg_Command.mli
index 4ac480c9..91a8f26c 100644
--- a/ide/command_windows.mli
+++ b/ide/wg_Command.mli
@@ -1,16 +1,18 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-class command_window :
-  Coq.coqtop ref -> Preferences.pref ref ->
+class command_window : string -> Coq.coqtop ->
   object
-    method new_command : ?command:string -> ?term:string -> unit -> unit
-    method frame : GBin.frame
+    method new_query : ?command:string -> ?term:string -> unit -> unit
+    method pack_in : (GObj.widget -> unit) -> unit
     method refresh_font : unit -> unit
     method refresh_color : unit -> unit
+    method show : unit
+    method hide : unit
+    method visible : bool
   end
diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml
new file mode 100644
index 00000000..3f5ae4bd
--- /dev/null
+++ b/ide/wg_Completion.ml
@@ -0,0 +1,453 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module StringOrd =
+struct
+  type t = string
+  let compare s1 s2 =
+    (* we use first size, then usual comparison *)
+    let d = String.length s1 - String.length s2 in
+    if d <> 0 then d
+    else Pervasives.compare s1 s2
+end
+
+module Proposals = Set.Make(StringOrd)
+
+(** Retrieve completion proposals in the buffer *)
+let get_syntactic_completion (buffer : GText.buffer) pattern accu =
+  let rec get_aux accu (iter : GText.iter) =
+    match iter#forward_search pattern with
+    | None -> accu
+    | Some (start, stop) ->
+      if Gtk_parsing.starts_word start then
+        let ne = Gtk_parsing.find_word_end stop in
+        if ne#compare stop = 0 then get_aux accu stop
+        else
+          let proposal = buffer#get_text ~start ~stop:ne () in
+          let accu = Proposals.add proposal accu in
+          get_aux accu stop
+      else get_aux accu stop
+  in
+  get_aux accu buffer#start_iter
+
+(** Retrieve completion proposals in Coq libraries *)
+let get_semantic_completion pattern accu =
+  let flags = [Interface.Name_Pattern ("^" ^ pattern), true] in
+  (** Only get the last part of the qualified name *)
+  let rec last accu = function
+  | [] -> accu
+  | [basename] -> Proposals.add basename accu
+  | _ :: l -> last accu l
+  in
+  let next = function
+  | Interface.Good l ->
+    let fold accu elt = last accu elt.Interface.coq_object_qualid in
+    let ans = List.fold_left fold accu l in
+    Coq.return ans
+  | _ -> Coq.return accu
+  in
+  Coq.bind (Coq.search flags) next
+
+let is_substring s1 s2 =
+  let s1 = Glib.Utf8.to_unistring s1 in
+  let s2 = Glib.Utf8.to_unistring s2 in
+  let break = ref true in
+  let i = ref 0 in
+  let len1 = Array.length s1 in
+  let len2 = Array.length s2 in
+  while !break && !i < len1 && !i < len2 do
+    break := s1.(!i) = s2.(!i);
+    incr i;
+  done;
+  if !break then len2 - len1
+  else -1
+
+class type complete_model_signals =
+  object ('a)
+    method after : 'a
+    method disconnect : GtkSignal.id -> unit
+    method start_completion : callback:(int -> unit) -> GtkSignal.id
+    method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
+    method end_completion : callback:(unit -> unit) -> GtkSignal.id
+  end
+
+let complete_model_signals
+  (start_s : int GUtil.signal)
+  (update_s : (int * string * Proposals.t) GUtil.signal)
+  (end_s : unit GUtil.signal) : complete_model_signals =
+let signals = [
+  start_s#disconnect;
+  update_s#disconnect;
+  end_s#disconnect;
+] in
+object (self : 'a)
+  inherit GUtil.ml_signals signals as super
+  method start_completion = start_s#connect ~after
+  method update_completion = update_s#connect ~after
+  method end_completion = end_s#connect ~after
+end
+
+class complete_model coqtop (buffer : GText.buffer) =
+  let cols = new GTree.column_list in
+  let column = cols#add Gobject.Data.string in
+  let store = GTree.list_store cols in
+  let filtered_store = GTree.model_filter store in
+  let start_completion_signal = new GUtil.signal () in
+  let update_completion_signal = new GUtil.signal () in
+  let end_completion_signal = new GUtil.signal () in
+object (self)
+
+  val signals = complete_model_signals
+    start_completion_signal update_completion_signal end_completion_signal
+  val mutable active = false
+  val mutable auto_complete_length = 3
+  (* this variable prevents CoqIDE from autocompleting when we have deleted something *)
+  val mutable is_auto_completing = false
+  (* this mutex ensure that CoqIDE will not try to autocomplete twice *)
+  val mutable cache = (-1, "", Proposals.empty)
+  val mutable insert_offset = -1
+  val mutable current_completion = ("", Proposals.empty)
+  val mutable lock_auto_completing = true
+
+  method connect = signals
+
+  method active = active
+
+  method set_active b = active <- b
+
+  method private handle_insert iter s =
+    (* we're inserting, so we may autocomplete *)
+    is_auto_completing <- true
+
+  method private handle_delete ~start ~stop =
+    (* disable autocomplete *)
+    is_auto_completing <- false
+
+  method store = filtered_store
+
+  method column = column
+
+  method handle_proposal path =
+    let row = filtered_store#get_iter path in
+    let proposal = filtered_store#get ~row ~column in
+    let (start_offset, _, _) = cache in
+    (* [iter] might be invalid now, get a new one to please gtk *)
+    let iter = buffer#get_iter `INSERT in
+    (* We cancel completion when the buffer has changed recently *)
+    if iter#offset = insert_offset then begin
+      let suffix =
+        let len1 = String.length proposal in
+        let len2 = insert_offset - start_offset in
+        String.sub proposal len2 (len1 - len2)
+      in
+      buffer#begin_user_action ();
+      ignore (buffer#insert_interactive ~iter suffix);
+      buffer#end_user_action ();
+    end
+
+  method private init_proposals pref props =
+    let () = store#clear () in
+    let iter prop =
+      let iter = store#append () in
+      store#set iter column prop
+    in
+    let () = current_completion <- (pref, props) in
+    Proposals.iter iter props
+
+  method private update_proposals pref =
+    let (_, _, props) = cache in
+    let filter prop = 0 <= is_substring pref prop in
+    let props = Proposals.filter filter props in
+    let () = current_completion <- (pref, props) in
+    let () = filtered_store#refilter () in
+    props
+
+  method private do_auto_complete k =
+    let iter = buffer#get_iter `INSERT in
+    let () = insert_offset <- iter#offset in
+    let log = Printf.sprintf "Completion at offset: %i" insert_offset in
+    let () = Minilib.log log in
+    let prefix =
+      if Gtk_parsing.ends_word iter#backward_char then
+        let start = Gtk_parsing.find_word_start iter in
+        let w = buffer#get_text ~start ~stop:iter () in
+        if String.length w >= auto_complete_length then Some (w, start)
+        else None
+      else None
+    in
+    match prefix with
+    | Some (w, start) ->
+      let () = Minilib.log ("Completion of prefix: '" ^ w ^ "'") in
+      let (off, prefix, props) = cache in
+      let start_offset = start#offset in
+      (* check whether we have the last request in cache *)
+      if (start_offset = off) && (0 <= is_substring prefix w) then
+        let props = self#update_proposals w in
+        let () = update_completion_signal#call (start_offset, w, props) in
+        k ()
+      else
+        let () = start_completion_signal#call start_offset in
+        let update props =
+          let () = cache <- (start_offset, w, props) in
+          let () = self#init_proposals w props in
+          update_completion_signal#call (start_offset, w, props)
+        in
+        (** If not in the cache, we recompute it: first syntactic *)
+        let synt = get_syntactic_completion buffer w Proposals.empty in
+        (** Then semantic *)
+        let next prop =
+          let () = update prop in
+          Coq.lift k
+        in
+        let query = Coq.bind (get_semantic_completion w synt) next in
+        (** If coqtop is computing, do the syntactic completion altogether *)
+        let occupied () =
+          let () = update synt in
+          k ()
+        in
+        Coq.try_grab coqtop query occupied
+    | None -> end_completion_signal#call (); k ()
+
+  method private may_auto_complete () =
+    if active && is_auto_completing && lock_auto_completing then begin
+      let () = lock_auto_completing <- false in
+      let unlock () = lock_auto_completing <- true in
+      self#do_auto_complete unlock
+    end
+
+  initializer
+    let filter_prop model row =
+      let (_, props) = current_completion in
+      let prop = store#get ~row ~column in
+      Proposals.mem prop props
+    in
+    let () = filtered_store#set_visible_func filter_prop in
+    (* Install auto-completion *)
+    ignore (buffer#connect#insert_text ~callback:self#handle_insert);
+    ignore (buffer#connect#delete_range ~callback:self#handle_delete);
+    ignore (buffer#connect#after#end_user_action ~callback:self#may_auto_complete);
+
+end
+
+class complete_popup (model : complete_model) (view : GText.view) =
+  let obj = GWindow.window ~kind:`POPUP ~show:false () in
+  let frame = GBin.scrolled_window
+    ~hpolicy:`NEVER ~vpolicy:`NEVER
+    ~shadow_type:`OUT ~packing:obj#add ()
+  in
+(*   let frame = GBin.frame ~shadow_type:`OUT ~packing:obj#add () in *)
+  let data = GTree.view
+    ~vadjustment:frame#vadjustment ~hadjustment:frame#hadjustment
+    ~rules_hint:true ~headers_visible:false
+    ~model:model#store ~packing:frame#add ()
+  in
+  let renderer = GTree.cell_renderer_text [], ["text", model#column] in
+  let col = GTree.view_column ~renderer () in
+  let _ = data#append_column col in
+  let () = col#set_sizing `AUTOSIZE in
+  let page_size = 16 in
+
+object (self)
+
+  method coerce = view#coerce
+
+  method private refresh_style () =
+    let (renderer, _) = renderer in
+    let font = Preferences.current.Preferences.text_font in
+    renderer#set_properties [`FONT_DESC font; `XPAD 10]
+
+  method private coordinates pos =
+    (** Toplevel position w.r.t. screen *)
+    let (x, y) = Gdk.Window.get_position view#misc#toplevel#misc#window in
+    (** Position of view w.r.t. window *)
+    let (ux, uy) = Gdk.Window.get_position view#misc#window in
+    (** Relative buffer position to view *)
+    let (dx, dy) = view#window_to_buffer_coords `WIDGET 0 0 in
+    (** Iter position *)
+    let iter = view#buffer#get_iter pos in
+    let coords = view#get_iter_location iter in
+    let lx = Gdk.Rectangle.x coords in
+    let ly = Gdk.Rectangle.y coords in
+    let w = Gdk.Rectangle.width coords in
+    let h = Gdk.Rectangle.height coords in
+    (** Absolute position *)
+    (x + lx + ux - dx, y + ly + uy - dy, w, h)
+
+  method private select_any f =
+    let sel = data#selection#get_selected_rows in
+    let path = match sel with
+    | [] ->
+      begin match model#store#get_iter_first with
+      | None -> None
+      | Some iter -> Some (model#store#get_path iter)
+      end
+    | path :: _ -> Some path
+    in
+    match path with
+    | None -> ()
+    | Some path ->
+      let path = f path in
+      let _ = data#selection#select_path path in
+      data#scroll_to_cell ~align:(0.,0.) path col
+
+  method private select_previous () =
+    let prev path =
+      let copy = GTree.Path.copy path in
+      if GTree.Path.prev path then path
+      else copy
+    in
+    self#select_any prev
+
+  method private select_next () =
+    let next path =
+      let () = GTree.Path.next path in
+      path
+    in
+    self#select_any next
+
+  method private select_previous_page () =
+    let rec up i path =
+      if i = 0 then path
+      else
+        let copy = GTree.Path.copy path in
+        let has_prev = GTree.Path.prev path in
+        if has_prev then up (pred i) path
+        else copy
+    in
+    self#select_any (up page_size)
+
+  method private select_next_page () =
+    let rec down i path =
+      if i = 0 then path
+      else
+        let copy = GTree.Path.copy path in
+        let iter = model#store#get_iter path in
+        let has_next = model#store#iter_next iter in
+        if has_next then down (pred i) (model#store#get_path iter)
+        else copy
+    in
+    self#select_any (down page_size)
+
+  method private select_first () =
+    let rec up path =
+      let copy = GTree.Path.copy path in
+      let has_prev = GTree.Path.prev path in
+      if has_prev then up path
+      else copy
+    in
+    self#select_any up
+
+  method private select_last () =
+    let rec down path =
+      let copy = GTree.Path.copy path in
+      let iter = model#store#get_iter path in
+      let has_next = model#store#iter_next iter in
+      if has_next then down (model#store#get_path iter)
+      else copy
+    in
+    self#select_any down
+
+  method private select_enter () =
+    let sel = data#selection#get_selected_rows in
+    match sel with
+    | [] -> ()
+    | path :: _ ->
+      let () = model#handle_proposal path in
+      self#hide ()
+
+  method proposal =
+    let sel = data#selection#get_selected_rows in
+    if obj#misc#visible then match sel with
+    | [] -> None
+    | path :: _ ->
+      let row = model#store#get_iter path in
+      let column = model#column in
+      let proposal = model#store#get ~row ~column in
+      Some proposal
+    else None
+
+  method private manage_scrollbar () =
+    (** HACK: we don't have access to the treeview size because of the lack of
+        LablGTK binding for certain functions, so we bypass it by approximating
+        it through the size of the proposals *)
+    let height = match model#store#get_iter_first with
+    | None -> -1
+    | Some iter ->
+      let path = model#store#get_path iter in
+      let area = data#get_cell_area ~path ~col () in
+      let height = Gdk.Rectangle.height area in
+      let height = page_size * height in
+      height
+    in
+    let len = ref 0 in
+    let () = model#store#foreach (fun _ _ -> incr len; false) in
+    if !len > page_size then
+      let () = frame#set_vpolicy `ALWAYS in
+      data#misc#set_size_request ~height ()
+    else
+      data#misc#set_size_request ~height:(-1) ()
+
+  method private refresh () =
+    let () = frame#set_vpolicy `NEVER in
+    let () = self#select_first () in
+    let () = obj#misc#show () in
+    let () = self#manage_scrollbar () in
+    obj#resize 1 1
+
+  method private start_callback off =
+    let (x, y, w, h) = self#coordinates (`OFFSET off) in
+    let () = obj#move x (y + 3 * h / 2) in
+    ()
+
+  method private update_callback (off, word, props) =
+    if Proposals.is_empty props then self#hide ()
+    else if Proposals.mem word props then self#hide ()
+    else self#refresh ()
+
+  method private end_callback () =
+    obj#misc#hide ()
+
+  method private hide () = self#end_callback ()
+
+  initializer
+    let move_cb _ _ ~extend = self#hide () in
+    let key_cb ev =
+      let eval cb = cb (); true in
+      let ev_key = GdkEvent.Key.keyval ev in
+      if obj#misc#visible then
+        if ev_key = GdkKeysyms._Up then eval self#select_previous
+        else if ev_key = GdkKeysyms._Down then eval self#select_next
+        else if ev_key = GdkKeysyms._Tab then eval self#select_enter
+        else if ev_key = GdkKeysyms._Return then eval self#select_enter
+        else if ev_key = GdkKeysyms._Escape then eval self#hide
+        else if ev_key = GdkKeysyms._Page_Down then eval self#select_next_page
+        else if ev_key = GdkKeysyms._Page_Up then eval self#select_previous_page
+        else if ev_key = GdkKeysyms._Home then eval self#select_first
+        else if ev_key = GdkKeysyms._End then eval self#select_last
+        else false
+      else false
+    in
+    (** Style handling *)
+    let _ = view#misc#connect#style_set self#refresh_style in
+    let _ = self#refresh_style () in
+    let _ = data#set_resize_mode `PARENT in
+    let _ = frame#set_resize_mode `PARENT in
+    (** Callback to model *)
+    let _ = model#connect#start_completion self#start_callback in
+    let _ = model#connect#update_completion self#update_callback in
+    let _ = model#connect#end_completion self#end_callback in
+    (** Popup interaction *)
+    let _ = view#event#connect#key_press key_cb in
+    (** Hiding the popup when necessary*)
+    let _ = view#misc#connect#hide obj#misc#hide in
+    let _ = view#event#connect#button_press (fun _ -> self#hide (); false) in
+    let _ = view#connect#move_cursor move_cb in
+    let _ = view#event#connect#focus_out (fun _ -> self#hide (); false) in
+    ()
+
+end
diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli
new file mode 100644
index 00000000..c3cb230d
--- /dev/null
+++ b/ide/wg_Completion.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module Proposals : sig type t end
+
+class type complete_model_signals =
+  object ('a)
+    method after : 'a
+    method disconnect : GtkSignal.id -> unit
+    method start_completion : callback:(int -> unit) -> GtkSignal.id
+    method update_completion : callback:(int * string * Proposals.t -> unit) -> GtkSignal.id
+    method end_completion : callback:(unit -> unit) -> GtkSignal.id
+  end
+
+class complete_model : Coq.coqtop -> GText.buffer ->
+object
+  method active : bool
+  method connect : complete_model_signals
+  method set_active : bool -> unit
+  method store : GTree.model_filter
+  method column : string GTree.column
+  method handle_proposal : Gtk.tree_path -> unit
+end
+
+class complete_popup : complete_model -> GText.view ->
+object
+  method coerce : GObj.widget
+  method proposal : string option
+end
diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml
new file mode 100644
index 00000000..53c634d7
--- /dev/null
+++ b/ide/wg_Detachable.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class type detachable_signals =
+  object
+    inherit GContainer.container_signals
+    method attached : callback:(GObj.widget -> unit) -> unit
+    method detached : callback:(GObj.widget -> unit) -> unit
+  end
+
+class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) =
+
+  object(self)
+    inherit GPack.box_skel (obj :> Gtk.box Gobject.obj) as super
+
+    val but = GButton.button ()
+    val win = GWindow.window ()
+    val frame = GBin.frame ~shadow_type:`NONE ()
+    val mutable detached = false
+    val mutable detached_cb = (fun _ -> ())
+    val mutable attached_cb = (fun _ -> ())
+
+    method child = frame#child
+    method add = frame#add
+    method pack ?from ?expand ?fill ?padding w =
+      if frame#all_children = [] then self#add w
+      else raise (Invalid_argument "detachable#pack")
+
+    method title = win#title
+    method set_title = win#set_title
+
+    method connect : detachable_signals = object
+      inherit GContainer.container_signals_impl obj
+      method attached ~callback = attached_cb <- callback
+      method detached ~callback = detached_cb <- callback
+    end
+
+    method show =
+      if detached then win#present ()
+      else self#misc#show ();
+
+    method hide =
+      if detached then win#misc#hide ()
+      else self#misc#hide ()
+
+    method visible = win#misc#visible || self#misc#visible
+
+    method frame = frame
+
+    method button = but
+
+    method attach () =
+      win#misc#hide ();
+      frame#misc#reparent self#coerce;
+      detached <- false;
+      attached_cb self#child
+
+    method detach () =
+      frame#misc#reparent win#coerce;
+      self#misc#hide ();
+      win#present ();
+      detached <- true;
+      detached_cb self#child
+
+    initializer
+      self#set_homogeneous false;
+      super#pack ~expand:false but#coerce;
+      super#pack ~expand:true ~fill:true frame#coerce;
+      win#misc#hide ();
+      but#add (GMisc.label
+        ~markup:"<span size='x-small'>D\nE\nT\nA\nC\nH</span>" ())#coerce;
+      ignore(win#event#connect#delete ~callback:(fun _ -> self#attach (); true));
+      ignore(but#connect#clicked ~callback:(fun _ -> self#detach ()))
+
+  end
+
+let detachable ?title =
+  GtkPack.Box.make_params [] ~cont:(
+    GContainer.pack_container
+      ~create:(fun p ->
+         let d = new detachable (GtkPack.Box.create `HORIZONTAL p) in
+         Option.iter d#set_title title;
+         d))
+
diff --git a/ide/wg_Detachable.mli b/ide/wg_Detachable.mli
new file mode 100644
index 00000000..71f85ad8
--- /dev/null
+++ b/ide/wg_Detachable.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class type detachable_signals =
+  object
+    inherit GContainer.container_signals
+    method attached : callback:(GObj.widget -> unit) -> unit
+    method detached : callback:(GObj.widget -> unit) -> unit
+  end
+
+class detachable : ([> Gtk.box] as 'a) Gobject.obj ->
+  object
+    inherit GPack.box_skel
+    val obj : Gtk.box Gobject.obj
+    method connect : detachable_signals
+    method child : GObj.widget
+    method show : unit
+    method hide : unit
+    method visible : bool
+    method title : string
+    method set_title : string -> unit
+    method button : GButton.button
+    method frame : GBin.frame
+    method detach : unit -> unit
+    method attach : unit -> unit
+  end
+
+val detachable :
+  ?title:string ->
+  ?homogeneous:bool ->
+  ?spacing:int ->
+  ?border_width:int ->
+  ?width:int ->
+  ?height:int ->
+  ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> detachable
+
+
diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml
new file mode 100644
index 00000000..b6f63a3b
--- /dev/null
+++ b/ide/wg_Find.ml
@@ -0,0 +1,199 @@
+(************************************************************************)
+(*  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 mode = [ `FIND | `REPLACE ]
+
+class finder name (view : GText.view) =
+  
+  let widget = Wg_Detachable.detachable
+    ~title:(Printf.sprintf "Find & Replace (%s)" name) () in 
+  let replace_box = GPack.table ~columns:4 ~rows:2 ~homogeneous:false
+    ~packing:widget#add () in
+  let hb = GPack.hbox ~packing:(replace_box#attach
+      ~left:1 ~top:0 ~expand:`X ~fill:`X) () in
+  let use_regex =
+    GButton.check_button ~label:"Regular expression"
+      ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in
+  let use_nocase =
+    GButton.check_button ~label:"Case insensitive"
+      ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in
+  let _ = GMisc.label ~text:"Find:" ~xalign:1.0
+    ~packing:(replace_box#attach
+      ~xpadding:3 ~ypadding:3 ~left:0 ~top:1 ~fill:`X) () in
+  let _ = GMisc.label ~text:"Replace:" ~xalign:1.0
+    ~packing:(replace_box#attach
+      ~xpadding:3 ~ypadding:3 ~left:0 ~top:2 ~fill:`X) () in
+  let find_entry = GEdit.entry ~editable:true
+    ~packing:(replace_box#attach
+      ~xpadding:3 ~ypadding:3 ~left:1 ~top:1 ~expand:`X ~fill:`X) () in
+  let replace_entry = GEdit.entry ~editable:true
+    ~packing:(replace_box#attach
+      ~xpadding:3 ~ypadding:3 ~left:1 ~top:2 ~expand:`X ~fill:`X) () in
+  let next_button = GButton.button ~label:"_Next" ~use_mnemonic:true
+    ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:1) () in
+  let previous_button = GButton.button ~label:"_Previous" ~use_mnemonic:true
+    ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:1) () in
+  let replace_button = GButton.button ~label:"_Replace" ~use_mnemonic:true
+    ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:2) () in
+  let replace_all_button =
+    GButton.button ~label:"Replace _All" ~use_mnemonic:true
+      ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:2) () in
+
+  object (self)
+    val mutable last_found = None
+
+    method coerce = widget#coerce
+
+    method private get_selected_word () =
+      let start = view#buffer#get_iter `INSERT in
+      let stop = view#buffer#get_iter `SEL_BOUND in
+      view#buffer#get_text ~start ~stop ()
+
+    method private may_replace () =
+      (self#search_text <> "") &&
+      (Str.string_match self#regex (self#get_selected_word ()) 0)
+
+    method replace () =
+      if self#may_replace () then
+        let txt = self#get_selected_word () in
+        let _ = view#buffer#delete_selection () in
+        let _ = view#buffer#insert_interactive (self#replacement txt) in
+        self#find_forward ()
+      else self#find_forward ()
+
+    method private regex =
+      let rex = self#search_text in
+      if use_regex#active then
+        if use_nocase#active then Str.regexp_case_fold rex
+        else Str.regexp rex
+      else 
+        if use_nocase#active then Str.regexp_string_case_fold rex
+        else Str.regexp_string rex
+
+    method private replacement txt =
+      if use_regex#active then Str.replace_matched replace_entry#text txt
+      else replace_entry#text
+
+    method private backward_search starti =
+      let text = view#buffer#start_iter#get_text ~stop:starti in
+      let regexp = self#regex in
+      try
+        let i = Str.search_backward regexp text (String.length text - 1) in
+        let j = Str.match_end () in
+        Some(view#buffer#start_iter#forward_chars i,
+             view#buffer#start_iter#forward_chars j)
+      with Not_found -> None
+    
+    method private forward_search starti =
+      let text = starti#get_text ~stop:view#buffer#end_iter in
+      let regexp = self#regex in
+      try
+        let i = Str.search_forward regexp text 0 in
+        let j = Str.match_end () in
+        Some(starti#forward_chars i, starti#forward_chars j)
+      with Not_found -> None
+
+    method replace_all () =
+      let rec replace_at (iter : GText.iter) =
+        let found = self#forward_search iter in
+        match found with
+        | None -> ()
+        | Some (start, stop) ->
+          let text = iter#get_text ~stop:view#buffer#end_iter in
+          let start_mark = view#buffer#create_mark start in
+          let stop_mark = view#buffer#create_mark ~left_gravity:false stop in
+          let _ = view#buffer#delete_interactive ~start ~stop () in
+          let iter = view#buffer#get_iter_at_mark (`MARK start_mark) in
+          let _ = view#buffer#insert_interactive ~iter (self#replacement text)in
+          let next = view#buffer#get_iter_at_mark (`MARK stop_mark) in
+          let () = view#buffer#delete_mark (`MARK start_mark) in
+          let () = view#buffer#delete_mark (`MARK stop_mark) in
+          replace_at next
+      in
+      replace_at view#buffer#start_iter
+
+    method private set_not_found () =
+      find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"];
+
+    method private set_found () =
+      find_entry#misc#modify_base [`NORMAL, `NAME "#BAF9CE"]
+
+    method private set_normal () =
+      find_entry#misc#modify_base [`NORMAL, `NAME "white"]
+
+    method private find_from backward (starti : GText.iter) =
+      let found =
+        if backward then self#backward_search starti
+        else self#forward_search starti in
+      match found with
+      | None ->
+        if not backward && not (starti#equal view#buffer#start_iter) then
+          self#find_from backward view#buffer#start_iter
+        else if backward && not (starti#equal view#buffer#end_iter) then
+          self#find_from backward view#buffer#end_iter
+        else
+          self#set_not_found ()
+      | Some (start, stop) ->
+        let _ = view#buffer#select_range start stop in
+        let scroll = `MARK (view#buffer#create_mark stop) in
+        let _ = view#scroll_to_mark ~use_align:false scroll in
+        self#set_found ()
+
+    method find_forward () =
+      let starti = view#buffer#get_iter `SEL_BOUND in
+      self#find_from false starti
+
+    method find_backward () =
+      let starti = view#buffer#get_iter `INSERT in
+      self#find_from true starti
+
+    method private search_text = find_entry#text
+
+    method hide () =
+      widget#hide;
+      view#coerce#misc#grab_focus ()
+
+    method show () =
+      widget#show;
+      find_entry#misc#grab_focus ()
+
+    initializer
+      let _ = self#hide () in
+
+      (** Widget button interaction *)
+      let _ = next_button#connect#clicked ~callback:self#find_forward in
+      let _ = previous_button#connect#clicked ~callback:self#find_backward in
+      let _ = replace_button#connect#clicked ~callback:self#replace in
+      let _ = replace_all_button#connect#clicked ~callback:self#replace_all in
+
+      (** Keypress interaction *)
+      let generic_cb esc_cb ret_cb ev =
+        let ev_key = GdkEvent.Key.keyval ev in
+        let (return, _) = GtkData.AccelGroup.parse "Return" in
+        let (esc, _) = GtkData.AccelGroup.parse "Escape" in
+        if ev_key = return then (ret_cb (); true)
+        else if ev_key = esc then (esc_cb (); true)
+        else false
+      in
+      let find_cb = generic_cb self#hide self#find_forward in
+      let replace_cb = generic_cb self#hide self#replace in
+      let _ = find_entry#event#connect#key_press find_cb in
+      let _ = replace_entry#event#connect#key_press replace_cb in
+
+      (** TextView interaction *)
+      let view_cb ev =
+        if widget#visible then
+          let ev_key = GdkEvent.Key.keyval ev in
+          if ev_key = GdkKeysyms._Escape then (widget#hide; true)
+          else false
+        else false
+      in
+      let _ = view#event#connect#key_press view_cb in
+      ()
+
+  end
diff --git a/ide/wg_Find.mli b/ide/wg_Find.mli
new file mode 100644
index 00000000..7811fc43
--- /dev/null
+++ b/ide/wg_Find.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class finder : string -> GText.view ->
+  object
+    method coerce : GObj.widget
+    method hide : unit -> unit
+    method show : unit -> unit
+    method replace : unit -> unit
+    method replace_all : unit -> unit
+    method find_backward : unit -> unit
+    method find_forward : unit -> unit
+  end
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
new file mode 100644
index 00000000..9acda53f
--- /dev/null
+++ b/ide/wg_MessageView.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class type message_view =
+  object
+    inherit GObj.widget
+    method clear : unit
+    method add : string -> unit
+    method set : string -> unit
+    method push : Pp.message_level -> string -> unit
+      (** same as [add], but with an explicit level instead of [Notice] *)
+    method buffer : GText.buffer
+      (** for more advanced text edition *)
+    method modify_font : Pango.font_description -> unit
+  end
+
+let message_view () : message_view =
+  let buffer = GSourceView2.source_buffer
+    ~highlight_matching_brackets:true
+    ~tag_table:Tags.Message.table ()
+  in
+  let text_buffer = new GText.buffer buffer#as_buffer in
+  let box = GPack.vbox () in
+  let scroll = GBin.scrolled_window
+    ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in
+  let view = GSourceView2.source_view
+    ~source_buffer:buffer ~packing:scroll#add
+    ~editable:false ~cursor_visible:false ~wrap_mode:`WORD ()
+  in
+  let default_clipboard = GData.clipboard Gdk.Atom.primary in
+  let _ = buffer#add_selection_clipboard default_clipboard in
+  let () = view#set_left_margin 2 in
+  object (self)
+    inherit GObj.widget box#as_widget
+
+    method clear =
+      buffer#set_text ""
+
+    method push level msg =
+      let tags = match level with
+      | Pp.Error -> [Tags.Message.error]
+      | Pp.Warning -> [Tags.Message.warning]
+      | _ -> []
+      in
+      if msg <> "" then begin
+        buffer#insert ~tags msg;
+        buffer#insert ~tags "\n"
+      end
+
+    method add msg = self#push Pp.Notice msg
+
+    method set msg = self#clear; self#add msg
+
+    method buffer = text_buffer
+
+    method modify_font fd = view#misc#modify_font fd
+
+  end
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
new file mode 100644
index 00000000..cd3f00c9
--- /dev/null
+++ b/ide/wg_MessageView.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class type message_view =
+  object
+    inherit GObj.widget
+    method clear : unit
+    method add : string -> unit
+    method set : string -> unit
+    method push : Pp.message_level -> string -> unit
+      (** same as [add], but with an explicit level instead of [Notice] *)
+    method buffer : GText.buffer
+      (** for more advanced text edition *)
+    method modify_font : Pango.font_description -> unit
+  end
+
+val message_view : unit -> message_view
diff --git a/ide/typed_notebook.ml b/ide/wg_Notebook.ml
index dde86625..0611c3f3 100644
--- a/ide/typed_notebook.ml
+++ b/ide/wg_Notebook.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        *)
@@ -16,14 +16,14 @@ object(self)
       (* XXX - Temporary hack to compile with archaic lablgtk *)
     ignore (super#append_page ?tab_label ?menu_label page);
     let real_pos = super#page_num page in
-    let lower,higher = Minilib.list_chop real_pos term_list in
+    let lower,higher = Util.List.chop real_pos term_list in
       term_list <- lower@[term]@higher;
       real_pos
 (* XXX - Temporary hack to compile with archaic lablgtk
   method insert_term ?(build=default_build) ?pos (term:'a) =
     let tab_label,menu_label,page = build term in
     let real_pos = super#insert_page ?tab_label ?menu_label ?pos page in
-    let lower,higher = Minilib.list_chop real_pos term_list in
+    let lower,higher = Util.List.chop real_pos term_list in
       term_list <- lower@[term]@higher;
       real_pos
  *)
@@ -32,26 +32,26 @@ object(self)
       (* XXX - Temporary hack to compile with archaic lablgtk *)
     ignore (super#prepend_page ?tab_label ?menu_label page);
     let real_pos = super#page_num page in
-    let lower,higher = Minilib.list_chop real_pos term_list in
+    let lower,higher = Util.List.chop real_pos term_list in
       term_list <- lower@[term]@higher;
       real_pos
 
   method set_term (term:'a) =
     let tab_label,menu_label,page = make_page term in
     let real_pos = super#current_page in
-      term_list <- Minilib.list_map_i (fun i x -> if i = real_pos then term else x) 0 term_list;
+      term_list <- Util.List.map_i (fun i x -> if i = real_pos then term else x) 0 term_list;
       super#set_page ?tab_label ?menu_label page
 
   method get_nth_term i =
     List.nth term_list i
 
-  method term_num p =
-    Minilib.list_index0 p term_list
+  method term_num f p =
+    Util.List.index0 f p term_list
 
   method pages = term_list
 
   method remove_page index =
-    term_list <- Minilib.list_filter_i (fun i x -> if i = index then kill_page x; i <> index) term_list;
+    term_list <- Util.List.filteri (fun i x -> if i = index then kill_page x; i <> index) term_list;
     super#remove_page index
 
   method current_term =
diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli
new file mode 100644
index 00000000..15a2ba41
--- /dev/null
+++ b/ide/wg_Notebook.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class ['a] typed_notebook :
+  ('a -> GObj.widget option * GObj.widget option * GObj.widget) ->
+  ('a -> unit) ->
+  Gtk.notebook Gtk.obj ->
+object
+  inherit GPack.notebook
+  method append_term : 'a -> int
+  method prepend_term : 'a -> int
+  method set_term : 'a -> unit
+  method get_nth_term : int -> 'a
+  method term_num : ('a -> 'a -> bool) -> 'a -> int
+  method pages : 'a list
+  method remove_page : int -> unit
+  method current_term : 'a
+end
+
+val create :
+  ('a -> GObj.widget option * GObj.widget option * GObj.widget) ->
+  ('a -> unit) ->
+  ?enable_popup:bool ->
+  ?homogeneous_tabs:bool ->
+  ?scrollable:bool ->
+  ?show_border:bool ->
+  ?show_tabs:bool ->
+  ?tab_border:int ->
+  ?tab_pos:Gtk.Tags.position ->
+  ?border_width:int ->
+  ?width:int ->
+  ?height:int ->
+  ?packing:(GObj.widget -> unit) -> ?show:bool -> unit -> 'a typed_notebook
diff --git a/ide/ideproof.ml b/ide/wg_ProofView.ml
index 5244bf04..7e7a311e 100644
--- a/ide/ideproof.ml
+++ b/ide/wg_ProofView.ml
@@ -1,11 +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        *)
 (************************************************************************)
 
+class type proof_view =
+  object
+    inherit GObj.widget
+    method refresh : unit -> unit
+    method clear : unit -> unit
+    method set_goals : Interface.goals option -> unit
+    method set_evars : Interface.evar list option -> unit
+    method width : int
+  end
 
 (* tag is the tag to be hooked, item is the item covered by this tag, make_menu
  *  * is the template for building menu if needed, sel_cb is the callback if
@@ -34,7 +43,7 @@ let hook_tag_cb tag menu_content sel_cb hover_cb =
                      hover_cb start stop; false
                  | _ -> false))
 
-let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
+let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with
   | [] -> assert false
   | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: rem_goals ->
       let on_hover sel_start sel_stop =
@@ -50,7 +59,7 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
       in
       let goals_cnt = List.length rem_goals + 1 in
       let head_str = Printf.sprintf
-        "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s")
+        "%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "s" else "")
       in
       let goal_str index total = Printf.sprintf
         "______________________________________(%d/%d)\n" index total
@@ -84,21 +93,21 @@ let mode_tactic sel_cb (proof:GText.view) goals hints = match goals with
         in
         proof#buffer#insert (goal_str 1 goals_cnt);
         proof#buffer#insert ~tags cur_goal;
-	proof#buffer#insert "\n"
+        proof#buffer#insert "\n"
       in
       (* Insert remaining goals (no hypotheses) *)
       let fold_goal i _ { Interface.goal_ccl = g } =
         proof#buffer#insert (goal_str i goals_cnt);
         proof#buffer#insert (g ^ "\n")
       in
-      let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in
+      let () = Util.List.fold_left_i fold_goal 2 () rem_goals in
 
       ignore(proof#buffer#place_cursor
                ~where:(proof#buffer#end_iter#backward_to_tag_toggle
-			 (Some Tags.Proof.goal)));
+                         (Some Tags.Proof.goal)));
       ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT)
 
-let mode_cesar (proof:GText.view) = function
+let mode_cesar (proof : #GText.view_skel) = function
   | [] -> assert false
   | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ ->
       proof#buffer#insert "    *** Declarative Mode ***\n";
@@ -115,18 +124,18 @@ let rec flatten = function
   let inner = flatten l in
   List.rev_append lg inner @ rg
 
-let display mode (view:GText.view) goals hints evars =
+let display mode (view : #GText.view_skel) goals hints evars =
   let () = view#buffer#set_text "" in
   match goals with
   | None -> ()
     (* No proof in progress *)
-  | Some { Interface.fg_goals = []; Interface.bg_goals = bg } ->
+  | Some { Interface.fg_goals = []; bg_goals = bg; shelved_goals; given_up_goals; } ->
     let bg = flatten (List.rev bg) in
     let evars = match evars with None -> [] | Some evs -> evs in
-    begin match (bg, evars) with
-    | [], [] ->
+    begin match (bg, shelved_goals,given_up_goals, evars) with
+    | [], [], [], [] ->
       view#buffer#insert "No more subgoals."
-    | [], _ :: _ ->
+    | [], [], [], _ :: _ ->
       (* A proof has been finished, but not concluded *)
       view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n";
       let iter evar =
@@ -134,7 +143,23 @@ let display mode (view:GText.view) goals hints evars =
         view#buffer#insert msg
       in
       List.iter iter evars
-    | _, _ ->
+    | [], [], _, _ ->
+      (* The proof is finished, with the exception of given up goals. *)
+      view#buffer#insert "No more, however there are goals you gave up. You need to go back and solve them:\n\n";
+      let iter goal =
+        let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
+        view#buffer#insert msg
+      in
+      List.iter iter given_up_goals
+    | [], _, _, _ ->
+      (* All the goals have been resolved but those on the shelf. *)
+      view#buffer#insert "All the remaining goals are on the shelf:\n\n";
+      let iter goal =
+        let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in
+        view#buffer#insert msg
+      in
+      List.iter iter shelved_goals
+    | _, _, _, _ ->
       (* No foreground proofs, but still unfocused ones *)
       view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n";
       let iter goal =
@@ -145,3 +170,33 @@ let display mode (view:GText.view) goals hints evars =
     end
   | Some { Interface.fg_goals = fg } ->
     mode view fg hints
+
+let proof_view () =
+  let buffer = GSourceView2.source_buffer
+    ~highlight_matching_brackets:true
+    ~tag_table:Tags.Proof.table ()
+  in
+  let view = GSourceView2.source_view
+    ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD ()
+  in
+  let default_clipboard = GData.clipboard Gdk.Atom.primary in
+  let _ = buffer#add_selection_clipboard default_clipboard in
+  object
+    inherit GObj.widget view#as_widget
+    val mutable goals = None
+    val mutable evars = None
+
+    method clear () = buffer#set_text ""
+
+    method set_goals gls = goals <- gls
+
+    method set_evars evs = evars <- evs
+
+    method refresh () =
+      let dummy _ () = () in
+      display (mode_tactic dummy) (view :> GText.view_skel) goals None evars
+
+    method width = Ideutils.textview_width (view :> GText.view_skel)
+  end
+
+(*     ignore (proof_buffer#add_selection_clipboard cb); *)
diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli
new file mode 100644
index 00000000..1fbf9900
--- /dev/null
+++ b/ide/wg_ProofView.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+class type proof_view =
+  object
+    inherit GObj.widget
+    method refresh : unit -> unit
+    method clear : unit -> unit
+    method set_goals : Interface.goals option -> unit
+    method set_evars : Interface.evar list option -> unit
+    method width : int
+  end
+
+val proof_view : unit -> proof_view
diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml
new file mode 100644
index 00000000..1f399070
--- /dev/null
+++ b/ide/wg_ScriptView.ml
@@ -0,0 +1,467 @@
+(************************************************************************)
+(*  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 insert_action = {
+  ins_val : string;
+  ins_off : int;
+  ins_len : int;
+  ins_mrg : bool;
+}
+
+type delete_action = {
+  del_val : string; (** Contents *)
+  del_off : int; (** Absolute offset of the modification *)
+  del_len : int; (** Length *)
+  del_mrg : bool; (** Is the modification mergeable? *)
+}
+
+type action =
+  | Insert of insert_action
+  | Delete of delete_action
+  | Action of action list
+  | EndGrp (** pending begin_user_action *)
+
+let merge_insert ins = function
+| Insert ins' :: rem ->
+  if ins.ins_mrg && ins'.ins_mrg &&
+    (ins'.ins_off + ins'.ins_len = ins.ins_off) then
+    let nins = {
+      ins_val = ins'.ins_val ^ ins.ins_val;
+      ins_off = ins'.ins_off;
+      ins_len = ins'.ins_len + ins.ins_len;
+      ins_mrg = true;
+    } in
+    Insert nins :: rem
+  else
+    Insert ins :: Insert ins' :: rem
+| l ->
+  Insert ins :: l
+
+let merge_delete del = function
+| Delete del' :: rem ->
+  if del.del_mrg && del'.del_mrg &&
+    (del.del_off + del.del_len = del'.del_off) then
+    let ndel = {
+      del_val = del.del_val ^ del'.del_val;
+      del_off = del.del_off;
+      del_len = del.del_len + del'.del_len;
+      del_mrg = true;
+    } in
+    Delete ndel :: rem
+  else
+  Delete del :: Delete del' :: rem
+| l ->
+  Delete del :: l
+
+let rec negate_action act = match act with
+  | Insert act ->
+    let act = {
+      del_len = act.ins_len;
+      del_off = act.ins_off;
+      del_val = act.ins_val;
+      del_mrg = act.ins_mrg;
+    } in
+    Delete act
+  | Delete act ->
+    let act = {
+      ins_len = act.del_len;
+      ins_off = act.del_off;
+      ins_val = act.del_val;
+      ins_mrg = act.del_mrg;
+    } in
+    Insert act
+  | Action acts ->
+    Action (List.rev_map negate_action acts)
+  | EndGrp -> assert false
+
+type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj
+
+class undo_manager (buffer : GText.buffer) =
+object(self)
+  val mutable lock_undo = true
+  val mutable history = []
+  val mutable redo = []
+
+  method with_lock_undo : 'a. ('a -> unit) -> 'a -> unit =
+    fun f x ->
+    if lock_undo then
+      let () = lock_undo <- false in
+      try (f x; lock_undo <- true)
+      with e -> (lock_undo <- true; raise e)
+    else ()
+
+  method private dump_debug () =
+    let rec iter = function
+    | Insert act ->
+      Printf.eprintf "Insert of '%s' at %d (length %d, mergeable %b)\n%!"
+        act.ins_val act.ins_off act.ins_len act.ins_mrg
+    | Delete act ->
+      Printf.eprintf "Delete '%s' from %d (length %d, mergeable %b)\n%!"
+        act.del_val act.del_off act.del_len act.del_mrg
+    | Action l ->
+      Printf.eprintf "Action\n%!";
+      List.iter iter l;
+      Printf.eprintf "//Action\n%!";
+    | EndGrp ->
+      Printf.eprintf "End Group\n%!"
+    in
+    if false (* !debug *) then begin
+      Printf.eprintf "+++++++++++++++++++++++++++++++++++++\n%!";
+      Printf.eprintf "==========Undo Stack top=============\n%!";
+      List.iter iter history;
+      Printf.eprintf "Stack size %d\n" (List.length history);
+      Printf.eprintf "==========Undo Stack Bottom==========\n%!";
+      Printf.eprintf "==========Redo Stack start===========\n%!";
+      List.iter iter redo;
+      Printf.eprintf "Stack size %d\n" (List.length redo);
+      Printf.eprintf "==========Redo Stack End=============\n%!";
+      Printf.eprintf "+++++++++++++++++++++++++++++++++++++\n%!";
+    end
+
+  method clear_undo () =
+    history <- [];
+    redo <- []
+
+  (** Warning: processing actually undo the action *)
+  method private process_insert_action ins =
+    let start = buffer#get_iter (`OFFSET ins.ins_off) in
+    let stop = start#forward_chars ins.ins_len in
+    buffer#delete_interactive ~start ~stop ()
+
+  method private process_delete_action del =
+    let iter = buffer#get_iter (`OFFSET del.del_off) in
+    buffer#insert_interactive ~iter del.del_val
+
+  (** We don't care about atomicity. Return:
+    1. `OK when there was no error, `FAIL otherwise
+    2. `NOOP if no write occured, `WRITE otherwise
+  *)
+  method private process_action = function
+  | Insert ins ->
+    if self#process_insert_action ins then (`OK, `WRITE) else (`FAIL, `NOOP)
+  | Delete del ->
+    if self#process_delete_action del then (`OK, `WRITE) else (`FAIL, `NOOP)
+  | Action lst ->
+    let fold accu action = match accu with
+    | (`FAIL, _) -> accu (** we stop now! *)
+    | (`OK, status) ->
+      let (res, nstatus) = self#process_action action in
+      let merge op1 op2 = match op1, op2 with
+      | `NOOP, `NOOP -> `NOOP (** only a noop when both are *)
+      | _ -> `WRITE
+      in
+      (res, merge status nstatus)
+    in
+    List.fold_left fold (`OK, `NOOP) lst
+  | EndGrp -> assert false
+
+  method perform_undo () = match history with
+  | [] -> ()
+  | action :: rem ->
+    let ans = self#process_action action in
+    begin match ans with
+    | (`OK, _) ->
+      history <- rem;
+      redo <- (negate_action action) :: redo
+    | (`FAIL, `NOOP) -> () (** we do nothing *)
+    | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed, so start off *)
+    end
+
+  method perform_redo () = match redo with
+  | [] -> ()
+  | action :: rem ->
+    let ans = self#process_action action in
+    begin match ans with
+    | (`OK, _) ->
+      redo <- rem;
+      history <- (negate_action action) :: history;
+    | (`FAIL, `NOOP) -> () (** we do nothing *)
+    | (`FAIL, `WRITE) -> self#clear_undo () (** we don't know how we failed *)
+    end
+
+  method undo () =
+    Minilib.log "UNDO";
+    self#with_lock_undo self#perform_undo ();
+
+  method redo () =
+    Minilib.log "REDO";
+    self#with_lock_undo self#perform_redo ();
+
+  method process_begin_user_action () =
+    (* Push a new level of event on history stack *)
+    history <- EndGrp :: history
+
+  method begin_user_action () =
+    self#with_lock_undo self#process_begin_user_action ()
+
+  method process_end_user_action () =
+    (** Search for the pending action *)
+    let rec split accu = function
+    | [] -> raise Not_found (** no pending begin action! *)
+    | EndGrp :: rem ->
+      let grp = List.rev accu in
+      let rec flatten = function
+      | [] -> rem
+      | [Insert ins] -> merge_insert ins rem
+      | [Delete del] -> merge_delete del rem
+      | [Action l] -> flatten l
+      | _ -> Action grp :: rem
+      in
+      flatten grp
+    | action :: rem ->
+      split (action :: accu) rem
+    in
+    try (history <- split [] history; self#dump_debug ())
+    with Not_found ->
+      Minilib.log "Error: Badly parenthezised user action";
+      self#clear_undo ()
+
+  method end_user_action () =
+    self#with_lock_undo self#process_end_user_action ()
+
+  method private process_handle_insert iter s =
+    (* Save the insert action *)
+    let len = Glib.Utf8.length s in
+    let mergeable =
+      (** heuristic: split at newline and atomic pastes *)
+      len = 1 && (s <> "\n")
+    in
+    let ins = {
+      ins_val = s;
+      ins_off = iter#offset;
+      ins_len = len;
+      ins_mrg = mergeable;
+    } in
+    let () = history <- Insert ins :: history in
+    ()
+
+  method private handle_insert iter s =
+    self#with_lock_undo (self#process_handle_insert iter) s
+
+  method private process_handle_delete start stop =
+    (* Save the delete action *)
+    let text = buffer#get_text ~start ~stop () in
+    let len = Glib.Utf8.length text in
+    let mergeable = len = 1  && (text <> "\n") in
+    let del = {
+      del_val = text;
+      del_off = start#offset;
+      del_len = stop#offset - start#offset;
+      del_mrg = mergeable;
+    } in
+    let action = Delete del in
+    history <- action :: history;
+    redo <- [];
+
+  method private handle_delete ~start ~stop =
+    self#with_lock_undo (self#process_handle_delete start) stop
+
+  initializer
+    let _ = buffer#connect#after#begin_user_action ~callback:self#begin_user_action in
+    let _ = buffer#connect#after#end_user_action ~callback:self#end_user_action in
+    let _ = buffer#connect#insert_text ~callback:self#handle_insert in
+    let _ = buffer#connect#delete_range ~callback:self#handle_delete in
+    ()
+
+end
+
+class script_view (tv : source_view) (ct : Coq.coqtop) =
+
+let view = new GSourceView2.source_view (Gobject.unsafe_cast tv) in
+let completion = new Wg_Completion.complete_model ct view#buffer in
+let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in
+
+object (self)
+  inherit GSourceView2.source_view (Gobject.unsafe_cast tv) as super
+
+  val undo_manager = new undo_manager view#buffer
+
+  method auto_complete = completion#active
+
+  method set_auto_complete flag =
+    completion#set_active flag
+
+  method recenter_insert =
+    self#scroll_to_mark
+      ~use_align:false ~yalign:0.75 ~within_margin:0.25 `INSERT
+
+  (* HACK: missing gtksourceview features *)
+  method right_margin_position =
+    let prop = {
+      Gobject.name = "right-margin-position";
+      conv = Gobject.Data.int;
+    } in
+    Gobject.get prop obj
+
+  method set_right_margin_position pos =
+    let prop = {
+      Gobject.name = "right-margin-position";
+      conv = Gobject.Data.int;
+    } in
+    Gobject.set prop obj pos
+
+  method show_right_margin =
+    let prop = {
+      Gobject.name = "show-right-margin";
+      conv = Gobject.Data.boolean;
+    } in
+    Gobject.get prop obj
+
+  method set_show_right_margin show =
+    let prop = {
+      Gobject.name = "show-right-margin";
+      conv = Gobject.Data.boolean;
+    } in
+    Gobject.set prop obj show
+
+  method comment () =
+    let rec get_line_start iter =
+      if iter#starts_line then iter
+      else get_line_start iter#backward_char
+    in
+    let (start, stop) =
+      if self#buffer#has_selection then
+        self#buffer#selection_bounds
+      else
+        let insert = self#buffer#get_iter `INSERT in
+        (get_line_start insert, insert#forward_to_line_end)
+    in
+      let stop_mark = self#buffer#create_mark ~left_gravity:false stop in
+      let () = self#buffer#begin_user_action () in
+      let was_inserted = self#buffer#insert_interactive ~iter:start "(* " in
+      let stop = self#buffer#get_iter_at_mark (`MARK stop_mark) in
+      let () = if was_inserted then ignore (self#buffer#insert_interactive ~iter:stop " *)") in
+      let () = self#buffer#end_user_action () in
+      self#buffer#delete_mark (`MARK stop_mark)
+
+  method uncomment () =
+    let rec get_left_iter depth (iter : GText.iter) =
+      let prev_close = iter#backward_search "*)" in
+      let prev_open = iter#backward_search "(*" in
+      let prev_object = match prev_close, prev_open with
+      | None, None | Some _, None -> `NONE
+      | None, Some (po, _) -> `OPEN po
+      | Some (co, _), Some (po, _) -> if co#compare po < 0 then `OPEN po else `CLOSE co
+      in
+      match prev_object with
+      | `NONE -> None
+      | `OPEN po ->
+        if depth <= 0 then Some po
+        else get_left_iter (pred depth) po
+      | `CLOSE co ->
+        get_left_iter (succ depth) co
+    in
+    let rec get_right_iter depth (iter : GText.iter) =
+      let next_close = iter#forward_search "*)" in
+      let next_open = iter#forward_search "(*" in
+      let next_object = match next_close, next_open with
+      | None, None | None, Some _ -> `NONE
+      | Some (_, co), None -> `CLOSE co
+      | Some (_, co), Some (_, po) ->
+        if co#compare po > 0 then `OPEN po else `CLOSE co
+      in
+      match next_object with
+      | `NONE -> None
+      | `OPEN po ->
+        get_right_iter (succ depth) po
+      | `CLOSE co ->
+        if depth <= 0 then Some co
+        else get_right_iter (pred depth) co
+    in
+    let insert = self#buffer#get_iter `INSERT in
+    let left_elt = get_left_iter 0 insert in
+    let right_elt = get_right_iter 0 insert in
+    match left_elt, right_elt with
+    | Some liter, Some riter ->
+      let stop_mark = self#buffer#create_mark ~left_gravity:false riter in
+      (* We remove one trailing/leading space if it exists *)
+      let lcontent = self#buffer#get_text ~start:liter ~stop:(liter#forward_chars 3) () in
+      let rcontent = self#buffer#get_text ~start:(riter#backward_chars 3) ~stop:riter () in
+      let llen = if lcontent = "(* " then 3 else 2 in
+      let rlen = if rcontent = " *)" then 3 else 2 in
+      (* Atomic operation for the user *)
+      let () = self#buffer#begin_user_action () in
+      let was_deleted = self#buffer#delete_interactive ~start:liter ~stop:(liter#forward_chars llen) () in
+      let riter = self#buffer#get_iter_at_mark (`MARK stop_mark) in
+      if was_deleted then ignore (self#buffer#delete_interactive ~start:(riter#backward_chars rlen) ~stop:riter ());
+      let () = self#buffer#end_user_action () in
+      self#buffer#delete_mark (`MARK stop_mark)
+    | _ -> ()
+
+  method complete_popup = popup
+
+  method undo = undo_manager#undo
+  method redo = undo_manager#redo
+  method clear_undo = undo_manager#clear_undo
+
+  method private paste () =
+    let cb = GData.clipboard Gdk.Atom.clipboard in
+    match cb#text with
+    | None -> ()
+    | Some text ->
+      let () = self#buffer#begin_user_action () in
+      let _ = self#buffer#delete_selection () in
+      let _ = self#buffer#insert_interactive text in
+      self#buffer#end_user_action ()
+
+  initializer
+    let supersed cb _ =
+      let _ = cb () in
+      GtkSignal.stop_emit()
+    in
+    (* HACK: Redirect the undo/redo signals of the underlying GtkSourceView *)
+    let _ = self#connect#undo ~callback:(supersed self#undo) in
+    let _ = self#connect#redo ~callback:(supersed self#redo) in
+    (* HACK: Redirect the paste signal *)
+    let _ = self#connect#paste_clipboard ~callback:(supersed self#paste) in
+    (* HACK: Redirect the move_line signal of the underlying GtkSourceView *)
+    let move_line_marshal = GtkSignal.marshal2
+      Gobject.Data.boolean Gobject.Data.int "move_line_marshal"
+    in
+    let move_line_signal = {
+      GtkSignal.name = "move-lines";
+      classe = Obj.magic 0;
+      marshaller = move_line_marshal; }
+    in
+    let callback b i =
+      let rec start_line iter =
+        if iter#starts_line then iter
+        else start_line iter#backward_char
+      in
+      let iter = start_line (self#buffer#get_iter `INSERT) in
+      (* do we forward the signal? *)
+      let proceed =
+        if not b && i = 1 then
+          iter#editable ~default:true &&
+	  iter#forward_line#editable ~default:true
+        else if not b && i = -1 then
+          iter#editable ~default:true &&
+	  iter#backward_line#editable ~default:true
+        else false
+      in
+      if not proceed then GtkSignal.stop_emit ()
+    in
+    let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in
+    ()
+
+end
+
+let script_view ct ?(source_buffer:GSourceView2.source_buffer option)  ?draw_spaces =
+  GtkSourceView2.SourceView.make_params [] ~cont:(
+    GtkText.View.make_params ~cont:(
+      GContainer.pack_container ~create:
+	(fun pl ->
+	  let w = match source_buffer with
+	    | None -> GtkSourceView2.SourceView.new_ ()
+	    | Some buf -> GtkSourceView2.SourceView.new_with_buffer
+              (Gobject.try_cast buf#as_buffer "GtkSourceBuffer")
+	  in
+	  let w = Gobject.unsafe_cast w in
+	  Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl;
+	  Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces;
+	  ((new script_view w ct) : script_view))))
diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli
new file mode 100644
index 00000000..6e54c445
--- /dev/null
+++ b/ide/wg_ScriptView.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* An undoable view class *)
+
+type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj
+
+class script_view : source_view -> Coq.coqtop ->
+object
+  inherit GSourceView2.source_view
+  method undo : unit -> unit
+  method redo : unit -> unit
+  method clear_undo : unit -> unit
+  method auto_complete : bool
+  method set_auto_complete : bool -> unit
+  method right_margin_position : int
+  method set_right_margin_position : int -> unit
+  method show_right_margin : bool
+  method set_show_right_margin : bool -> unit
+  method comment : unit -> unit
+  method uncomment : unit -> unit
+  method recenter_insert : unit
+  method complete_popup : Wg_Completion.complete_popup
+end
+
+val script_view : Coq.coqtop ->
+  ?source_buffer:GSourceView2.source_buffer ->
+  ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list ->
+  ?auto_indent:bool ->
+  ?highlight_current_line:bool ->
+  ?indent_on_tab:bool ->
+  ?indent_width:int ->
+  ?insert_spaces_instead_of_tabs:bool ->
+  ?right_margin_position:int ->
+  ?show_line_marks:bool ->
+  ?show_line_numbers:bool ->
+  ?show_right_margin:bool ->
+  ?smart_home_end:SourceView2Enums.source_smart_home_end_type ->
+  ?tab_width:int ->
+  ?editable:bool ->
+  ?cursor_visible:bool ->
+  ?justification:GtkEnums.justification ->
+  ?wrap_mode:GtkEnums.wrap_mode ->
+  ?accepts_tab:bool ->
+  ?border_width:int ->
+  ?width:int ->
+  ?height:int ->
+  ?packing:(GObj.widget -> unit) ->
+  ?show:bool -> unit -> script_view
diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml
new file mode 100644
index 00000000..8520727a
--- /dev/null
+++ b/ide/wg_Segment.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  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 Util
+
+type color = GDraw.color
+
+module Segment :
+sig
+  type +'a t
+  val length : 'a t -> int
+  val resize : 'a t -> int -> 'a t
+  val empty : 'a t
+  val add : int -> 'a -> 'a t -> 'a t
+  val remove : int -> 'a t -> 'a t
+  val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end =
+struct
+  type 'a t = {
+    length : int;
+    content : 'a Int.Map.t;
+  }
+
+  let empty = { length = 0; content = Int.Map.empty }
+
+  let length s = s.length
+
+  let resize s len =
+    if s.length <= len then { s with length = len }
+    else
+      let filter i v = i < len in
+      { length = len; content = Int.Map.filter filter s.content }
+
+  let add i v s =
+    if i < s.length then
+      { s with content = Int.Map.add i v s.content }
+    else s
+
+  let remove i s = { s with content = Int.Map.remove i s.content }
+
+  let fold eq f s accu =
+    let make k v (cur, accu) = match cur with
+    | None -> Some (k, k, v), accu
+    | Some (i, j, w) ->
+      if k = j + 1 && eq v w then Some (i, k, w), accu
+      else Some (k, k, v), (i, j, w) :: accu
+    in
+    let p, segments = Int.Map.fold make s.content (None, []) in
+    let segments = match p with
+    | None -> segments
+    | Some p -> p :: segments
+    in
+    List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments
+
+end
+
+let i2f = float_of_int
+let f2i = int_of_float
+
+let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with
+| `BLACK, `BLACK -> true
+| `COLOR c1, `COLOR c2 -> c1 == c2
+| `NAME s1, `NAME s2 -> String.equal s1 s2
+| `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2
+| `WHITE, `WHITE -> true
+| _ -> false
+
+class segment () =
+let box = GBin.frame () in
+let draw = GMisc.image ~packing:box#add () in
+object (self)
+
+  inherit GObj.widget box#as_widget
+
+  val mutable width = 1
+  val mutable height = 20
+  val mutable data = Segment.empty
+  val mutable default : color = `WHITE
+  val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 ()
+
+  initializer
+    box#misc#set_size_request ~height ();
+    let cb rect =
+      let w = rect.Gtk.width in
+      let h = rect.Gtk.height in
+      (** Only refresh when size actually changed, otherwise loops *)
+      if self#misc#visible && (width <> w || height <> h) then begin
+        width <- w;
+        height <- h;
+        self#redraw ();
+      end
+    in
+    let _ = box#misc#connect#size_allocate cb in
+    (** Initial pixmap *)
+    draw#set_pixmap pixmap
+
+  method length = Segment.length data
+
+  method set_length len =
+    data <- Segment.resize data len;
+    if self#misc#visible then self#refresh ()
+
+  method private fill_range color i j =
+    let i = i2f i in
+    let j = i2f j in
+    let width = i2f width in
+    let len = i2f (Segment.length data) in
+    let x = f2i ((i *. width) /. len) in
+    let x' = f2i ((j *. width) /. len) in
+    let w = x' - x in
+    pixmap#set_foreground color;
+    pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true ();
+    draw#set_mask None;
+
+  method add i color =
+    data <- Segment.add i color data;
+    if self#misc#visible then self#fill_range color i (i + 1)
+
+  method remove i =
+    data <- Segment.remove i data;
+    if self#misc#visible then self#fill_range default i (i + 1)
+
+  method set_default_color color = default <- color
+  method default_color = default
+
+  method private redraw () =
+    pixmap <- GDraw.pixmap ~width ~height ();
+    draw#set_pixmap pixmap;
+    self#refresh ();
+
+  method private refresh () =
+    pixmap#set_foreground default;
+    pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
+    let fold i j v () = self#fill_range v i (j + 1) in
+    Segment.fold color_eq fold data ();
+    draw#set_mask None;
+
+end
diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli
new file mode 100644
index 00000000..ecb45147
--- /dev/null
+++ b/ide/wg_Segment.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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 color = GDraw.color
+
+class segment : unit ->
+  object
+    inherit GObj.widget
+    val obj : Gtk.widget Gtk.obj
+    method length : int
+    method set_length : int -> unit
+    method default_color : color
+    method set_default_color : color -> unit
+    method add : int -> color -> unit
+    method remove : int -> unit
+  end
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
new file mode 100644
index 00000000..d337a911
--- /dev/null
+++ b/ide/xmlprotocol.ml
@@ -0,0 +1,737 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Protocol version of this file. This is the date of the last modification. *)
+
+(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
+
+let protocol_version = "20140312"
+
+(** * Interface of calls to Coq by CoqIde *)
+
+open Util
+open Interface
+open Serialize
+open Xml_datatype
+
+(* Marshalling of basic types and type constructors *)
+module Xml_marshalling = struct
+
+let of_search_cst = function
+  | Name_Pattern s ->
+    constructor "search_cst" "name_pattern" [of_string s]
+  | Type_Pattern s ->
+    constructor "search_cst" "type_pattern" [of_string s]
+  | SubType_Pattern s ->
+    constructor "search_cst" "subtype_pattern" [of_string s]
+  | In_Module m ->
+    constructor "search_cst" "in_module" [of_list of_string m]
+  | Include_Blacklist ->
+    constructor "search_cst" "include_blacklist" []
+let to_search_cst = do_match "search_cst" (fun s args -> match s with
+  | "name_pattern" -> Name_Pattern (to_string (singleton args))
+  | "type_pattern" -> Type_Pattern (to_string (singleton args))
+  | "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
+  | "in_module" -> In_Module (to_list to_string (singleton args))
+  | "include_blacklist" -> Include_Blacklist
+  | _ -> raise Marshal_error)
+
+let of_coq_object f ans =
+  let prefix = of_list of_string ans.coq_object_prefix in
+  let qualid = of_list of_string ans.coq_object_qualid in
+  let obj = f ans.coq_object_object in
+  Element ("coq_object", [], [prefix; qualid; obj])
+
+let to_coq_object f = function
+| Element ("coq_object", [], [prefix; qualid; obj]) ->
+  let prefix = to_list to_string prefix in
+  let qualid = to_list to_string qualid in
+  let obj = f obj in {
+    coq_object_prefix = prefix;
+    coq_object_qualid = qualid;
+    coq_object_object = obj;
+  }
+| _ -> raise Marshal_error
+
+let of_option_value = function
+  | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
+  | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b]
+  | StringValue s -> constructor "option_value" "stringvalue" [of_string s]
+let to_option_value = do_match "option_value" (fun s args -> match s with
+  | "intvalue" -> IntValue (to_option to_int (singleton args))
+  | "boolvalue" -> BoolValue (to_bool (singleton args))
+  | "stringvalue" -> StringValue (to_string (singleton args))
+  | _ -> raise Marshal_error)
+
+let of_option_state s =
+  Element ("option_state", [], [
+    of_bool s.opt_sync;
+    of_bool s.opt_depr;
+    of_string s.opt_name;
+    of_option_value s.opt_value])
+let to_option_state = function
+  | Element ("option_state", [], [sync; depr; name; value]) -> {
+      opt_sync = to_bool sync;
+      opt_depr = to_bool depr;
+      opt_name = to_string name;
+      opt_value = to_option_value value }
+  | _ -> raise Marshal_error
+
+
+let of_value f = function
+| Good x -> Element ("value", ["val", "good"], [f x])
+| Fail (id,loc, msg) ->
+  let loc = match loc with
+  | None -> []
+  | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
+  let id = Stateid.to_xml id in
+  Element ("value", ["val", "fail"] @ loc, [id;PCData msg])
+let to_value f = function
+| Element ("value", attrs, l) ->
+  let ans = massoc "val" attrs in
+  if ans = "good" then Good (f (singleton l))
+  else if ans = "fail" then
+    let loc =
+      try
+        let loc_s = int_of_string (Serialize.massoc "loc_s" attrs) in
+        let loc_e = int_of_string (Serialize.massoc "loc_e" attrs) in
+        Some (loc_s, loc_e)
+      with Marshal_error | Failure _ -> None
+    in
+    let id = Stateid.of_xml (List.hd l) in
+    let msg = raw_string (List.tl l) in
+    Fail (id, loc, msg)
+  else raise Marshal_error
+| _ -> raise Marshal_error
+
+let of_status s =
+  let of_so = of_option of_string in
+  let of_sl = of_list of_string in
+  Element ("status", [], [
+      of_sl s.status_path;
+      of_so s.status_proofname;
+      of_sl s.status_allproofs;
+      of_int s.status_proofnum; ])
+let to_status = function
+  | Element ("status", [], [path; name; prfs; pnum]) -> {
+      status_path = to_list to_string path;
+      status_proofname = to_option to_string name;
+      status_allproofs = to_list to_string prfs;
+      status_proofnum = to_int pnum; }
+  | _ -> raise Marshal_error
+
+let of_evar s = Element ("evar", [], [PCData s.evar_info])
+let to_evar = function
+  | Element ("evar", [], data) -> { evar_info = raw_string data; }
+  | _ -> raise Marshal_error
+
+let of_goal g =
+  let hyp = of_list of_string g.goal_hyp in
+  let ccl = of_string g.goal_ccl in
+  let id = of_string g.goal_id in
+  Element ("goal", [], [id; hyp; ccl])
+let to_goal = function
+  | Element ("goal", [], [id; hyp; ccl]) ->
+    let hyp = to_list to_string hyp in
+    let ccl = to_string ccl in
+    let id = to_string id in
+    { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
+  | _ -> raise Marshal_error
+
+let of_goals g =
+  let of_glist = of_list of_goal in
+  let fg = of_list of_goal g.fg_goals in
+  let bg = of_list (of_pair of_glist of_glist) g.bg_goals in
+  let shelf = of_list of_goal g.shelved_goals in
+  let given_up = of_list of_goal g.given_up_goals in
+  Element ("goals", [], [fg; bg; shelf; given_up])
+let to_goals = function
+  | Element ("goals", [], [fg; bg; shelf; given_up]) ->
+    let to_glist = to_list to_goal in
+    let fg = to_list to_goal fg in
+    let bg = to_list (to_pair to_glist to_glist) bg in
+    let shelf = to_list to_goal shelf in
+    let given_up = to_list to_goal given_up in
+    { fg_goals = fg; bg_goals = bg; shelved_goals = shelf;
+      given_up_goals = given_up }
+  | _ -> raise Marshal_error
+
+let of_coq_info info =
+  let version = of_string info.coqtop_version in
+  let protocol = of_string info.protocol_version in
+  let release = of_string info.release_date in
+  let compile = of_string info.compile_date in
+  Element ("coq_info", [], [version; protocol; release; compile])
+let to_coq_info = function
+  | Element ("coq_info", [], [version; protocol; release; compile]) -> {
+      coqtop_version = to_string version;
+      protocol_version = to_string protocol;
+      release_date = to_string release;
+      compile_date = to_string compile; }
+  | _ -> raise Marshal_error
+
+end
+include Xml_marshalling
+
+(* Reification of basic types and type constructors, and functions
+   from to xml *)
+module ReifType : sig
+
+  type 'a val_t
+
+  val unit_t         : unit val_t
+  val string_t       : string val_t
+  val int_t          : int val_t
+  val bool_t         : bool val_t
+  val xml_t          : Xml_datatype.xml val_t
+
+  val option_t       : 'a val_t -> 'a option val_t
+  val list_t         : 'a val_t -> 'a list val_t
+  val pair_t         : 'a val_t -> 'b val_t -> ('a * 'b) val_t
+  val union_t        : 'a val_t -> 'b val_t -> ('a ,'b) union val_t
+
+  val goals_t        : goals val_t
+  val evar_t         : evar val_t
+  val state_t        : status val_t
+  val option_state_t : option_state val_t
+  val option_value_t : option_value val_t
+  val coq_info_t     : coq_info val_t
+  val coq_object_t   : 'a val_t -> 'a coq_object val_t
+  val state_id_t     : state_id val_t
+  val search_cst_t   : search_constraint val_t
+
+  val of_value_type : 'a val_t -> 'a -> xml
+  val to_value_type : 'a val_t -> xml -> 'a
+
+  val print         : 'a val_t -> 'a -> string
+
+  type value_type
+  val erase         : 'a val_t -> value_type
+  val print_type    : value_type -> string
+
+  val document_type_encoding : (xml -> string) -> unit
+
+end = struct
+
+  type value_type =
+    | Unit | String | Int | Bool | Xml
+
+    | Option of value_type
+    | List of value_type
+    | Pair of value_type * value_type
+    | Union of value_type * value_type
+
+    | Goals | Evar | State | Option_state | Option_value | Coq_info
+    | Coq_object of value_type
+    | State_id
+    | Search_cst
+
+  type 'a val_t = value_type
+
+  let erase (x : 'a val_t) : value_type = x
+
+  let unit_t         = Unit
+  let string_t       = String
+  let int_t          = Int
+  let bool_t         = Bool
+  let xml_t          = Xml
+
+  let option_t x     = Option x
+  let list_t x       = List x
+  let pair_t x y     = Pair (x, y)
+  let union_t x y    = Union (x, y)
+
+  let goals_t        = Goals
+  let evar_t         = Evar
+  let state_t        = State
+  let option_state_t = Option_state
+  let option_value_t = Option_value
+  let coq_info_t     = Coq_info
+  let coq_object_t x = Coq_object x
+  let state_id_t     = State_id
+  let search_cst_t   = Search_cst
+
+  let of_value_type (ty : 'a val_t) : 'a -> xml =
+    let rec convert ty : 'a -> xml = match ty with
+      | Unit          -> Obj.magic of_unit
+      | Bool          -> Obj.magic of_bool
+      | Xml           -> Obj.magic (fun x -> x)
+      | String        -> Obj.magic of_string
+      | Int           -> Obj.magic of_int
+      | State         -> Obj.magic of_status
+      | Option_state  -> Obj.magic of_option_state
+      | Option_value  -> Obj.magic of_option_value
+      | Coq_info      -> Obj.magic of_coq_info
+      | Goals         -> Obj.magic of_goals
+      | Evar          -> Obj.magic of_evar
+      | List t        -> Obj.magic (of_list (convert t))
+      | Option t      -> Obj.magic (of_option (convert t))
+      | Coq_object t  -> Obj.magic (of_coq_object (convert t))
+      | Pair (t1,t2)  -> Obj.magic (of_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
+      | State_id      -> Obj.magic Stateid.to_xml
+      | Search_cst    -> Obj.magic of_search_cst
+    in
+      convert ty
+
+  let to_value_type (ty : 'a val_t) : xml -> 'a =
+    let rec convert ty : xml -> 'a = match ty with
+      | Unit          -> Obj.magic to_unit
+      | Bool          -> Obj.magic to_bool
+      | Xml           -> Obj.magic (fun x -> x)
+      | String        -> Obj.magic to_string
+      | Int           -> Obj.magic to_int
+      | State         -> Obj.magic to_status
+      | Option_state  -> Obj.magic to_option_state
+      | Option_value  -> Obj.magic to_option_value
+      | Coq_info      -> Obj.magic to_coq_info
+      | Goals         -> Obj.magic to_goals
+      | Evar          -> Obj.magic to_evar
+      | List t        -> Obj.magic (to_list (convert t))
+      | Option t      -> Obj.magic (to_option (convert t))
+      | Coq_object t  -> Obj.magic (to_coq_object (convert t))
+      | Pair (t1,t2)  -> Obj.magic (to_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
+      | State_id      -> Obj.magic Stateid.of_xml
+      | Search_cst    -> Obj.magic to_search_cst
+    in
+      convert ty
+
+  let pr_unit () = ""
+  let pr_string s = Printf.sprintf "%S" s
+  let pr_int i = string_of_int i
+  let pr_bool b = Printf.sprintf "%B" b
+  let pr_goal (g : goals) =
+    if g.fg_goals = [] then
+      if g.bg_goals = [] then "Proof completed."
+      else
+        let rec pr_focus _ = function
+          | [] -> assert false
+          | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg)
+          | (lg, rg) :: l ->
+            Printf.sprintf "%i:%a"
+              (List.length lg + List.length rg) pr_focus l in
+        Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
+    else
+      let pr_menu s = s in
+      let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
+        "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
+            pr_menu goal ^ "]" in
+      String.concat " " (List.map pr_goal g.fg_goals)
+  let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
+  let pr_status (s : status) =
+    let path =
+      let l = String.concat "." s.status_path in
+      "path=" ^ l ^ ";" in
+    let name = match s.status_proofname with
+      | None -> "no proof;"
+      | Some n -> "proof = " ^ n ^ ";" in
+    "Status: " ^ path ^ name
+  let pr_coq_info (i : coq_info) = "FIXME"
+  let pr_option_value = function
+    | IntValue None -> "none"
+    | IntValue (Some i) -> string_of_int i
+    | StringValue s -> s
+    | BoolValue b -> if b then "true" else "false"
+  let pr_option_state (s : option_state) =
+    Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n"
+      s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value)
+  let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]"
+  let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")"
+  let pr_coq_object (o : 'a coq_object) = "FIXME"
+  let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
+  let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x
+
+  let pr_search_cst = function
+    | Name_Pattern s -> "Name_Pattern " ^ s
+    | Type_Pattern s -> "Type_Pattern " ^ s
+    | SubType_Pattern s -> "SubType_Pattern " ^ s
+    | In_Module s -> "In_Module " ^ String.concat "." s
+    | Include_Blacklist -> "Include_Blacklist"
+
+  let rec print = function
+  | Unit          -> Obj.magic pr_unit
+  | Bool          -> Obj.magic pr_bool
+  | String        -> Obj.magic pr_string
+  | Xml           -> Obj.magic Xml_printer.to_string_fmt
+  | Int           -> Obj.magic pr_int
+  | State         -> Obj.magic pr_status
+  | Option_state  -> Obj.magic pr_option_state
+  | Option_value  -> Obj.magic pr_option_value
+  | Search_cst    -> Obj.magic pr_search_cst
+  | Coq_info      -> Obj.magic pr_coq_info
+  | Goals         -> Obj.magic pr_goal
+  | Evar          -> Obj.magic pr_evar
+  | List t        -> Obj.magic (pr_list (print t))
+  | Option t      -> Obj.magic (pr_option (print t))
+  | Coq_object t  -> Obj.magic pr_coq_object
+  | Pair (t1,t2)  -> Obj.magic (pr_pair (print t1) (print t2))
+  | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2))
+  | State_id      -> Obj.magic pr_int
+
+  (* This is to break if a rename/refactoring makes the strings below outdated *)
+  type 'a exists = bool
+
+  let rec print_type = function
+  | Unit          -> "unit"
+  | Bool          -> "bool"
+  | String        -> "string"
+  | Xml           -> "xml"
+  | Int           -> "int"
+  | State         -> assert(true : status exists); "Interface.status"
+  | Option_state  -> assert(true : option_state exists); "Interface.option_state"
+  | Option_value  -> assert(true : option_value exists); "Interface.option_value"
+  | Search_cst    -> assert(true : search_constraint exists); "Interface.search_constraint"
+  | Coq_info      -> assert(true : coq_info exists); "Interface.coq_info"
+  | Goals         -> assert(true : goals exists); "Interface.goals"
+  | Evar          -> assert(true : evar exists); "Interface.evar"
+  | List t        -> Printf.sprintf "(%s list)" (print_type t)
+  | Option t      -> Printf.sprintf "(%s option)" (print_type t)
+  | Coq_object t  -> assert(true : 'a coq_object exists);
+                     Printf.sprintf "(%s Interface.coq_object)" (print_type t)
+  | Pair (t1,t2)  -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2)
+  | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
+                     Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+  | State_id      -> assert(true : Stateid.t exists); "Stateid.t"
+
+  let document_type_encoding pr_xml =
+    Printf.printf "\n=== Data encoding by examples ===\n\n";
+    Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ()));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool)
+      (pr_xml (of_bool true)) (pr_xml (of_bool false));
+    Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello"));
+    Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256));
+    Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5]));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int))
+      (pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int)))
+      (pr_xml (of_pair of_bool of_int (false,3)));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int)))
+      (pr_xml (of_union of_bool of_int (Inl false)));
+    print_endline ("All other types are records represented by a node named like the OCaml\n"^
+                   "type which contains a flattened n-tuple.  We provide one example.\n");
+    Printf.printf "%s:\n\n%s\n\n" (print_type Option_state)
+      (pr_xml (of_option_state { opt_sync = true; opt_depr = false;
+        opt_name = "name1"; opt_value = IntValue (Some 37) }));
+
+end
+open ReifType
+
+(** Types reification, checked with explicit casts *)
+let add_sty_t : add_sty val_t =
+  pair_t (pair_t string_t int_t) (pair_t state_id_t bool_t)
+let edit_at_sty_t : edit_at_sty val_t = state_id_t
+let query_sty_t : query_sty val_t = pair_t string_t state_id_t
+let goals_sty_t : goals_sty val_t = unit_t
+let evars_sty_t : evars_sty val_t = unit_t
+let hints_sty_t : hints_sty val_t = unit_t
+let status_sty_t : status_sty val_t = bool_t
+let search_sty_t : search_sty val_t = list_t (pair_t search_cst_t bool_t)
+let get_options_sty_t : get_options_sty val_t = unit_t
+let set_options_sty_t : set_options_sty val_t =
+  list_t (pair_t (list_t string_t) option_value_t)
+let mkcases_sty_t : mkcases_sty val_t = string_t
+let quit_sty_t : quit_sty val_t = unit_t
+let about_sty_t : about_sty val_t = unit_t
+let init_sty_t : init_sty val_t = option_t string_t
+let interp_sty_t : interp_sty val_t = pair_t (pair_t bool_t bool_t) string_t
+let stop_worker_sty_t : stop_worker_sty val_t = string_t
+let print_ast_sty_t : print_ast_sty val_t = state_id_t
+let annotate_sty_t : annotate_sty val_t = string_t
+
+let add_rty_t : add_rty val_t =
+  pair_t state_id_t (pair_t (union_t unit_t state_id_t) string_t)
+let edit_at_rty_t : edit_at_rty val_t =
+  union_t unit_t (pair_t state_id_t (pair_t state_id_t state_id_t))
+let query_rty_t : query_rty val_t = string_t
+let goals_rty_t : goals_rty val_t = option_t goals_t
+let evars_rty_t : evars_rty val_t = option_t (list_t evar_t)
+let hints_rty_t : hints_rty val_t =
+  let hint = list_t (pair_t string_t string_t) in
+  option_t (pair_t (list_t hint) hint)
+let status_rty_t : status_rty val_t = state_t
+let search_rty_t : search_rty val_t = list_t (coq_object_t string_t)
+let get_options_rty_t : get_options_rty val_t =
+  list_t (pair_t (list_t string_t) option_state_t)
+let set_options_rty_t : set_options_rty val_t = unit_t
+let mkcases_rty_t : mkcases_rty val_t = list_t (list_t string_t)
+let quit_rty_t : quit_rty val_t = unit_t
+let about_rty_t : about_rty val_t = coq_info_t
+let init_rty_t : init_rty val_t = state_id_t
+let interp_rty_t : interp_rty val_t = pair_t state_id_t (union_t string_t string_t)
+let stop_worker_rty_t : stop_worker_rty val_t = unit_t
+let print_ast_rty_t : print_ast_rty val_t = xml_t
+let annotate_rty_t : annotate_rty val_t = xml_t
+
+let ($) x = erase x
+let calls = [|
+  "Add",        ($)add_sty_t,         ($)add_rty_t;
+  "Edit_at",    ($)edit_at_sty_t,     ($)edit_at_rty_t;
+  "Query",      ($)query_sty_t,       ($)query_rty_t;
+  "Goal",       ($)goals_sty_t,       ($)goals_rty_t;
+  "Evars",      ($)evars_sty_t,       ($)evars_rty_t;
+  "Hints",      ($)hints_sty_t,       ($)hints_rty_t;
+  "Status",     ($)status_sty_t,      ($)status_rty_t;
+  "Search",     ($)search_sty_t,      ($)search_rty_t;
+  "GetOptions", ($)get_options_sty_t, ($)get_options_rty_t;
+  "SetOptions", ($)set_options_sty_t, ($)set_options_rty_t;
+  "MkCases",    ($)mkcases_sty_t,     ($)mkcases_rty_t;
+  "Quit",       ($)quit_sty_t,        ($)quit_rty_t;
+  "About",      ($)about_sty_t,       ($)about_rty_t;
+  "Init",       ($)init_sty_t,        ($)init_rty_t;
+  "Interp",     ($)interp_sty_t,      ($)interp_rty_t;
+  "StopWorker", ($)stop_worker_sty_t, ($)stop_worker_rty_t;
+  "PrintAst",   ($)print_ast_sty_t,   ($)print_ast_rty_t;
+  "Annotate",   ($)annotate_sty_t,    ($)annotate_rty_t;
+|]
+
+type 'a call =
+  | Add        of add_sty
+  | Edit_at    of edit_at_sty
+  | Query      of query_sty
+  | Goal       of goals_sty
+  | Evars      of evars_sty
+  | Hints      of hints_sty
+  | Status     of status_sty
+  | Search     of search_sty
+  | GetOptions of get_options_sty
+  | SetOptions of set_options_sty
+  | MkCases    of mkcases_sty
+  | Quit       of quit_sty
+  | About      of about_sty
+  | Init       of init_sty
+  | StopWorker of stop_worker_sty
+  (* retrocompatibility *)
+  | Interp     of interp_sty
+  | PrintAst   of print_ast_sty
+  | Annotate   of annotate_sty
+
+let id_of_call = function
+  | Add _        -> 0
+  | Edit_at _    -> 1
+  | Query _      -> 2
+  | Goal _       -> 3
+  | Evars _      -> 4
+  | Hints _      -> 5
+  | Status _     -> 6
+  | Search _     -> 7
+  | GetOptions _ -> 8
+  | SetOptions _ -> 9
+  | MkCases _    -> 10
+  | Quit _       -> 11
+  | About _      -> 12
+  | Init _       -> 13
+  | Interp _     -> 14
+  | StopWorker _ -> 15
+  | PrintAst _   -> 16
+  | Annotate _   -> 17
+
+let str_of_call c = pi1 calls.(id_of_call c)
+
+type unknown
+
+(** We use phantom types and GADT to protect ourselves against wild casts *)
+let add x         : add_rty call         = Add x
+let edit_at x     : edit_at_rty call     = Edit_at x
+let query x       : query_rty call       = Query x
+let goals x       : goals_rty call       = Goal x
+let evars x       : evars_rty call       = Evars x
+let hints x       : hints_rty call       = Hints x
+let status x      : status_rty call      = Status x
+let get_options x : get_options_rty call = GetOptions x
+let set_options x : set_options_rty call = SetOptions x
+let mkcases x     : mkcases_rty call     = MkCases x
+let search x      : search_rty call      = Search x
+let quit x        : quit_rty call        = Quit x
+let init x        : init_rty call        = Init x
+let interp x      : interp_rty call      = Interp x
+let stop_worker x : stop_worker_rty call = StopWorker x
+let print_ast   x : print_ast_rty call   = PrintAst x
+let annotate   x : annotate_rty call    = Annotate x
+
+let abstract_eval_call handler (c : 'a call) : 'a value =
+  let mkGood x : 'a value = Good (Obj.magic x) in
+  try
+    match c with
+    | Add x        -> mkGood (handler.add x)
+    | Edit_at x    -> mkGood (handler.edit_at x)
+    | Query x      -> mkGood (handler.query x)
+    | Goal x       -> mkGood (handler.goals x)
+    | Evars x      -> mkGood (handler.evars x)
+    | Hints x      -> mkGood (handler.hints x)
+    | Status x     -> mkGood (handler.status x)
+    | Search x     -> mkGood (handler.search x)
+    | GetOptions x -> mkGood (handler.get_options x)
+    | SetOptions x -> mkGood (handler.set_options x)
+    | MkCases x    -> mkGood (handler.mkcases x)
+    | Quit x       -> mkGood (handler.quit x)
+    | About x      -> mkGood (handler.about x)
+    | Init x       -> mkGood (handler.init x)
+    | Interp x     -> mkGood (handler.interp x)
+    | StopWorker x -> mkGood (handler.stop_worker x)
+    | PrintAst x   -> mkGood (handler.print_ast x)
+    | Annotate x   -> mkGood (handler.annotate x)
+  with any ->
+    let any = Errors.push any in
+    Fail (handler.handle_exn any)
+
+(** brain dead code, edit if protocol messages are added/removed *)
+let of_answer (q : 'a call) (v : 'a value) : xml = match q with
+  | Add _        -> of_value (of_value_type add_rty_t        ) (Obj.magic v)
+  | Edit_at _    -> of_value (of_value_type edit_at_rty_t    ) (Obj.magic v)
+  | Query _      -> of_value (of_value_type query_rty_t      ) (Obj.magic v)
+  | Goal _       -> of_value (of_value_type goals_rty_t      ) (Obj.magic v)
+  | Evars _      -> of_value (of_value_type evars_rty_t      ) (Obj.magic v)
+  | Hints _      -> of_value (of_value_type hints_rty_t      ) (Obj.magic v)
+  | Status _     -> of_value (of_value_type status_rty_t     ) (Obj.magic v)
+  | Search _     -> of_value (of_value_type search_rty_t     ) (Obj.magic v)
+  | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v)
+  | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v)
+  | MkCases _    -> of_value (of_value_type mkcases_rty_t    ) (Obj.magic v)
+  | Quit _       -> of_value (of_value_type quit_rty_t       ) (Obj.magic v)
+  | About _      -> of_value (of_value_type about_rty_t      ) (Obj.magic v)
+  | Init _       -> of_value (of_value_type init_rty_t       ) (Obj.magic v)
+  | Interp _     -> of_value (of_value_type interp_rty_t     ) (Obj.magic v)
+  | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v)
+  | PrintAst _   -> of_value (of_value_type print_ast_rty_t  ) (Obj.magic v)
+  | Annotate _   -> of_value (of_value_type annotate_rty_t   ) (Obj.magic v)
+
+let to_answer (q : 'a call) (x : xml) : 'a value = match q with
+  | Add _        -> Obj.magic (to_value (to_value_type add_rty_t        ) x)
+  | Edit_at _    -> Obj.magic (to_value (to_value_type edit_at_rty_t    ) x)
+  | Query _      -> Obj.magic (to_value (to_value_type query_rty_t      ) x)
+  | Goal _       -> Obj.magic (to_value (to_value_type goals_rty_t      ) x)
+  | Evars _      -> Obj.magic (to_value (to_value_type evars_rty_t      ) x)
+  | Hints _      -> Obj.magic (to_value (to_value_type hints_rty_t      ) x)
+  | Status _     -> Obj.magic (to_value (to_value_type status_rty_t     ) x)
+  | Search _     -> Obj.magic (to_value (to_value_type search_rty_t     ) x)
+  | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x)
+  | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x)
+  | MkCases _    -> Obj.magic (to_value (to_value_type mkcases_rty_t    ) x)
+  | Quit _       -> Obj.magic (to_value (to_value_type quit_rty_t       ) x)
+  | About _      -> Obj.magic (to_value (to_value_type about_rty_t      ) x)
+  | Init _       -> Obj.magic (to_value (to_value_type init_rty_t       ) x)
+  | Interp _     -> Obj.magic (to_value (to_value_type interp_rty_t     ) x)
+  | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x)
+  | PrintAst _   -> Obj.magic (to_value (to_value_type print_ast_rty_t  ) x)
+  | Annotate _   -> Obj.magic (to_value (to_value_type annotate_rty_t   ) x)
+
+let of_call (q : 'a call) : xml =
+  let mkCall x = constructor "call" (str_of_call q) [x] in
+  match q with
+  | Add x        -> mkCall (of_value_type add_sty_t         x)
+  | Edit_at x    -> mkCall (of_value_type edit_at_sty_t     x)
+  | Query x      -> mkCall (of_value_type query_sty_t       x)
+  | Goal x       -> mkCall (of_value_type goals_sty_t       x)
+  | Evars x      -> mkCall (of_value_type evars_sty_t       x)
+  | Hints x      -> mkCall (of_value_type hints_sty_t       x)
+  | Status x     -> mkCall (of_value_type status_sty_t      x)
+  | Search x     -> mkCall (of_value_type search_sty_t      x)
+  | GetOptions x -> mkCall (of_value_type get_options_sty_t x)
+  | SetOptions x -> mkCall (of_value_type set_options_sty_t x)
+  | MkCases x    -> mkCall (of_value_type mkcases_sty_t     x)
+  | Quit x       -> mkCall (of_value_type quit_sty_t        x)
+  | About x      -> mkCall (of_value_type about_sty_t       x)
+  | Init x       -> mkCall (of_value_type init_sty_t        x)
+  | Interp x     -> mkCall (of_value_type interp_sty_t      x)
+  | StopWorker x -> mkCall (of_value_type stop_worker_sty_t x)
+  | PrintAst x   -> mkCall (of_value_type print_ast_sty_t   x)
+  | Annotate x   -> mkCall (of_value_type annotate_sty_t    x)
+
+let to_call : xml -> unknown call =
+  do_match "call" (fun s a ->
+    let mkCallArg vt a = to_value_type vt (singleton a) in
+    match s with
+    | "Add"        -> Add        (mkCallArg add_sty_t         a)
+    | "Edit_at"    -> Edit_at    (mkCallArg edit_at_sty_t     a)
+    | "Query"      -> Query      (mkCallArg query_sty_t       a)
+    | "Goal"       -> Goal       (mkCallArg goals_sty_t       a)
+    | "Evars"      -> Evars      (mkCallArg evars_sty_t       a)
+    | "Hints"      -> Hints      (mkCallArg hints_sty_t       a)
+    | "Status"     -> Status     (mkCallArg status_sty_t      a)
+    | "Search"     -> Search     (mkCallArg search_sty_t      a)
+    | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a)
+    | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a)
+    | "MkCases"    -> MkCases    (mkCallArg mkcases_sty_t     a)
+    | "Quit"       -> Quit       (mkCallArg quit_sty_t        a)
+    | "About"      -> About      (mkCallArg about_sty_t       a)
+    | "Init"       -> Init       (mkCallArg init_sty_t        a)
+    | "Interp"     -> Interp     (mkCallArg interp_sty_t      a)
+    | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a)
+    | "PrintAst"   -> PrintAst   (mkCallArg print_ast_sty_t   a)
+    | "Annotate"   -> Annotate   (mkCallArg annotate_sty_t    a)
+    | _ -> raise Marshal_error)
+
+(** Debug printing *)
+
+let pr_value_gen pr = function
+  | Good v -> "GOOD " ^ pr v
+  | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]"
+  | Fail (id,Some(i,j),str) ->
+      "FAIL "^Stateid.to_string id^
+        " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+let pr_value v = pr_value_gen (fun _ -> "FIXME") v
+let pr_full_value call value = match call with
+  | Add _        -> pr_value_gen (print add_rty_t        ) (Obj.magic value)
+  | Edit_at _    -> pr_value_gen (print edit_at_rty_t    ) (Obj.magic value)
+  | Query _      -> pr_value_gen (print query_rty_t      ) (Obj.magic value)
+  | Goal _       -> pr_value_gen (print goals_rty_t      ) (Obj.magic value)
+  | Evars _      -> pr_value_gen (print evars_rty_t      ) (Obj.magic value)
+  | Hints _      -> pr_value_gen (print hints_rty_t      ) (Obj.magic value)
+  | Status _     -> pr_value_gen (print status_rty_t     ) (Obj.magic value)
+  | Search _     -> pr_value_gen (print search_rty_t     ) (Obj.magic value)
+  | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value)
+  | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value)
+  | MkCases _    -> pr_value_gen (print mkcases_rty_t    ) (Obj.magic value)
+  | Quit _       -> pr_value_gen (print quit_rty_t       ) (Obj.magic value)
+  | About _      -> pr_value_gen (print about_rty_t      ) (Obj.magic value)
+  | Init _       -> pr_value_gen (print init_rty_t       ) (Obj.magic value)
+  | Interp _     -> pr_value_gen (print interp_rty_t     ) (Obj.magic value)
+  | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value)
+  | PrintAst _   -> pr_value_gen (print print_ast_rty_t  ) (Obj.magic value)
+  | Annotate _   -> pr_value_gen (print annotate_rty_t   ) (Obj.magic value)
+let pr_call call =
+  let return what x = str_of_call call ^ " " ^ print what x in
+  match call with
+    | Add x        -> return add_sty_t x
+    | Edit_at x    -> return edit_at_sty_t x
+    | Query x      -> return query_sty_t x
+    | Goal x       -> return goals_sty_t x
+    | Evars x      -> return evars_sty_t x
+    | Hints x      -> return hints_sty_t x
+    | Status x     -> return status_sty_t x
+    | Search x     -> return search_sty_t x
+    | GetOptions x -> return get_options_sty_t x
+    | SetOptions x -> return set_options_sty_t x
+    | MkCases x    -> return mkcases_sty_t x
+    | Quit x       -> return quit_sty_t x
+    | About x      -> return about_sty_t x
+    | Init x       -> return init_sty_t x
+    | Interp x     -> return interp_sty_t x
+    | StopWorker x -> return stop_worker_sty_t x
+    | PrintAst x   -> return print_ast_sty_t x
+    | Annotate x   -> return annotate_sty_t x
+
+let document to_string_fmt =
+  Printf.printf "=== Available calls ===\n\n";
+  Array.iter (fun (cname, csty, crty) ->
+      Printf.printf "%12s :  %s\n %14s %s\n"
+        ("\""^cname^"\"") (print_type csty) "->" (print_type crty))
+    calls;
+  Printf.printf "\n=== Calls XML encoding ===\n\n";
+  Printf.printf "A call \"C\" carrying input a is encoded as:\n\n%s\n\n"
+    (to_string_fmt (constructor "call" "C" [PCData "a"]));
+  Printf.printf "A response carrying output b can either be:\n\n%s\n\n"
+    (to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
+  Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
+    (to_string_fmt (of_value (fun _ -> PCData "b")
+      (Fail (Stateid.initial,Some (15,34),"error message"))));
+  document_type_encoding to_string_fmt
+
+(* vim: set foldmethod=marker: *)
diff --git a/toplevel/ide_intf.mli b/ide/xmlprotocol.mli
index ab8ecc8e..2c8ebc65 100644
--- a/toplevel/ide_intf.mli
+++ b/ide/xmlprotocol.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        *)
@@ -9,25 +9,30 @@
 (** * Applicative part of the interface of CoqIde calls to Coq *)
 
 open Interface
-
-type xml = Xml_parser.xml
+open Xml_datatype
 
 type 'a call
 
 type unknown
 
-val interp      : interp_sty      -> interp_rty call
-val rewind      : rewind_sty      -> rewind_rty call
+val add         : add_sty         -> add_rty call
+val edit_at     : edit_at_sty     -> edit_at_rty call
+val query       : query_sty       -> query_rty call
 val goals       : goals_sty       -> goals_rty call
 val hints       : hints_sty       -> hints_rty call
 val status      : status_sty      -> status_rty call
-val inloadpath  : inloadpath_sty  -> inloadpath_rty call
 val mkcases     : mkcases_sty     -> mkcases_rty call
 val evars       : evars_sty       -> evars_rty call
 val search      : search_sty      -> search_rty call
 val get_options : get_options_sty -> get_options_rty call
 val set_options : set_options_sty -> set_options_rty call
 val quit        : quit_sty        -> quit_rty call
+val init        : init_sty        -> init_rty call
+val stop_worker : stop_worker_sty -> stop_worker_rty call
+(* retrocompatibility *)
+val interp      : interp_sty      -> interp_rty call
+val print_ast   : print_ast_sty   -> print_ast_rty call
+val annotate    : annotate_sty    -> annotate_rty call
 
 val abstract_eval_call : handler -> 'a call -> 'a value
 
@@ -37,23 +42,14 @@ val protocol_version : string
 
 (** * XML data marshalling *)
 
-exception Marshal_error
-
 val of_call : 'a call -> xml
 val to_call : xml -> unknown call
 
-val of_message : message -> xml
-val to_message : xml -> message
-val is_message : xml -> bool
-
-val of_value : ('a -> xml) -> 'a value -> xml
-
-val of_feedback : feedback -> xml
-val to_feedback : xml -> feedback
-val is_feedback : xml -> bool
-
 val of_answer : 'a call -> 'a value -> xml
-val to_answer : xml -> 'a call -> 'a value
+val to_answer : 'a call -> xml -> 'a value
+
+(* Prints the documentation of this module *)
+val document : (xml -> string) -> unit
 
 (** * Debug printing *)
 
diff --git a/install.sh b/install.sh
index 4b3abe5c..c5835b01 100755
--- a/install.sh
+++ b/install.sh
@@ -7,5 +7,10 @@ for f; do
   bn=`basename $f`
   dn=`dirname $f`
   install -d "$dest/$dn"
-  install -m 644 $f "$dest/$dn/$bn"
+  case $bn in
+      *.cmxs) install -m 755 $f "$dest/$dn/$bn"
+	      ;;
+      *) install -m 644 $f "$dest/$dn/$bn"
+	 ;;
+  esac
 done
diff --git a/interp/constrarg.ml b/interp/constrarg.ml
new file mode 100644
index 00000000..3f232c36
--- /dev/null
+++ b/interp/constrarg.ml
@@ -0,0 +1,71 @@
+(************************************************************************)
+(*  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 Loc
+open Tacexpr
+open Term
+open Misctypes
+open Genarg
+
+(** This is a hack for now, to break the dependency of Genarg on constr-related
+    types. We should use dedicated functions someday. *)
+
+let loc_of_or_by_notation f = function
+  | AN c -> f c
+  | ByNotation (loc,s,_) -> loc
+
+let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type =
+  Obj.magic t
+
+let wit_int_or_var = unsafe_of_type IntOrVarArgType
+
+let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type =
+  Genarg.make0 None "intropattern"
+
+let wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type =
+  Genarg.make0 None "tactic"
+
+let wit_ident = unsafe_of_type IdentArgType
+
+let wit_var = unsafe_of_type VarArgType
+
+let wit_ref = Genarg.make0 None "ref"
+
+let wit_quant_hyp = unsafe_of_type QuantHypArgType
+
+let wit_genarg = unsafe_of_type GenArgType
+
+let wit_sort : (glob_sort, glob_sort, sorts) genarg_type =
+  Genarg.make0 None "sort"
+
+let wit_constr = unsafe_of_type ConstrArgType
+
+let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType
+
+let wit_uconstr = Genarg.make0 None "uconstr"
+
+let wit_open_constr = unsafe_of_type OpenConstrArgType
+
+let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType
+
+let wit_bindings = unsafe_of_type BindingsArgType
+
+let wit_red_expr = unsafe_of_type RedExprArgType
+
+let wit_clause_dft_concl  =
+  Genarg.make0 None "clause_dft_concl"
+
+(** Register location *)
+
+let () =
+  register_name0 wit_ref "Constrarg.wit_ref";
+  register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern";
+  register_name0 wit_tactic "Constrarg.wit_tactic";
+  register_name0 wit_sort "Constrarg.wit_sort";
+  register_name0 wit_uconstr "Constrarg.wit_uconstr";
+  register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl";
diff --git a/interp/constrarg.mli b/interp/constrarg.mli
new file mode 100644
index 00000000..74c6bd31
--- /dev/null
+++ b/interp/constrarg.mli
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Generic arguments based on [constr]. We put them here to avoid a dependency
+    of Genarg in [constr]-related interfaces. *)
+
+open Loc
+open Names
+open Term
+open Libnames
+open Globnames
+open Genredexpr
+open Pattern
+open Constrexpr
+open Tacexpr
+open Misctypes
+open Genarg
+
+(** FIXME: nothing to do there. *)
+val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t
+
+(** {5 Additional generic arguments} *)
+
+val wit_int_or_var : int or_var uniform_genarg_type
+
+val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type
+
+val wit_ident : Id.t uniform_genarg_type
+
+val wit_var : (Id.t located, Id.t located, Id.t) genarg_type
+
+val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type
+
+val wit_quant_hyp : quantified_hypothesis uniform_genarg_type
+
+val wit_genarg : (raw_generic_argument, glob_generic_argument, typed_generic_argument) genarg_type
+
+val wit_sort : (glob_sort, glob_sort, sorts) genarg_type
+
+val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type
+
+val wit_constr_may_eval :
+  ((constr_expr,reference or_by_notation,constr_expr) may_eval,
+  (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval,
+  constr) genarg_type
+
+val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type
+
+val wit_open_constr :
+  (open_constr_expr, open_glob_constr, Evd.open_constr) genarg_type
+
+val wit_constr_with_bindings :
+  (constr_expr with_bindings,
+  glob_constr_and_expr with_bindings,
+  constr with_bindings Evd.sigma) genarg_type
+
+val wit_bindings :
+  (constr_expr bindings,
+  glob_constr_and_expr bindings,
+  constr bindings Evd.sigma) genarg_type
+
+val wit_red_expr :
+  ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,
+  (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen,
+  (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type
+
+val wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type
+
+val wit_clause_dft_concl :  (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type
diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml
new file mode 100644
index 00000000..2d48ea4d
--- /dev/null
+++ b/interp/constrexpr_ops.ml
@@ -0,0 +1,345 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Names
+open Libnames
+open Constrexpr
+open Misctypes
+open Decl_kinds
+
+(***********************)
+(* For binders parsing *)
+
+let binding_kind_eq bk1 bk2 = match bk1, bk2 with
+| Explicit, Explicit -> true
+| Implicit, Implicit -> true
+| _ -> false
+
+let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with
+| AbsLambda, AbsLambda -> true
+| AbsPi, AbsPi -> true
+| _ -> false
+
+let binder_kind_eq b1 b2 = match b1, b2 with
+| Default bk1, Default bk2 -> binding_kind_eq bk1 bk2
+| Generalized (bk1, ck1, b1), Generalized (bk2, ck2, b2) ->
+  binding_kind_eq bk1 bk2 && binding_kind_eq ck1 ck2 &&
+  (if b1 then b2 else not b2)
+| _ -> false
+
+let default_binder_kind = Default Explicit
+
+let names_of_local_assums bl =
+  List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl)
+
+let names_of_local_binders bl =
+  List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl)
+
+(**********************************************************************)
+(* Functions on constr_expr *)
+
+let prim_token_eq t1 t2 = match t1, t2 with
+| Numeral i1, Numeral i2 -> Bigint.equal i1 i2
+| String s1, String s2 -> String.equal s1 s2
+| _ -> false
+
+let explicitation_eq ex1 ex2 = match ex1, ex2 with
+| ExplByPos (i1, id1), ExplByPos (i2, id2) ->
+  Int.equal i1 i2 && Option.equal Id.equal id1 id2
+| ExplByName id1, ExplByName id2 ->
+  Id.equal id1 id2
+| _ -> false
+
+let eq_located f (_, x) (_, y) = f x y
+
+let rec cases_pattern_expr_eq p1 p2 =
+  if p1 == p2 then true
+  else match p1, p2 with
+  | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) ->
+      Id.equal i1 i2 && cases_pattern_expr_eq a1 a2
+  | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) ->
+      eq_reference c1 c2 &&
+      List.equal cases_pattern_expr_eq a1 a2 &&
+      List.equal cases_pattern_expr_eq b1 b2
+  | CPatAtom(_,r1), CPatAtom(_,r2) ->
+      Option.equal eq_reference r1 r2
+  | CPatOr (_, a1), CPatOr (_, a2) ->
+      List.equal cases_pattern_expr_eq a1 a2
+  | CPatNotation (_, n1, s1, l1), CPatNotation (_, n2, s2, l2) ->
+    String.equal n1 n2 &&
+    cases_pattern_notation_substitution_eq s1 s2 &&
+    List.equal cases_pattern_expr_eq l1 l2
+  | CPatPrim(_,i1), CPatPrim(_,i2) ->
+      prim_token_eq i1 i2
+  | CPatRecord (_, l1), CPatRecord (_, l2) ->
+      let equal (r1, e1) (r2, e2) =
+        eq_reference r1 r2 && cases_pattern_expr_eq e1 e2
+      in
+      List.equal equal l1 l2
+  | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) ->
+      String.equal s1 s2 && cases_pattern_expr_eq e1 e2
+  | _ -> false
+
+and cases_pattern_notation_substitution_eq (s1, n1) (s2, n2) =
+  List.equal cases_pattern_expr_eq s1 s2 &&
+  List.equal (List.equal cases_pattern_expr_eq) n1 n2
+
+let eq_universes u1 u2 =
+  match u1, u2 with
+  | None, None -> true
+  | Some l, Some l' -> l = l'
+  | _, _ -> false
+
+let rec constr_expr_eq e1 e2 =
+  if e1 == e2 then true
+  else match e1, e2 with
+  | CRef (r1,u1), CRef (r2,u2) -> eq_reference r1 r2 && eq_universes u1 u2
+  | CFix(_,id1,fl1), CFix(_,id2,fl2) ->
+      eq_located Id.equal id1 id2 &&
+      List.equal fix_expr_eq fl1 fl2
+  | CCoFix(_,id1,fl1), CCoFix(_,id2,fl2) ->
+      eq_located Id.equal id1 id2 &&
+      List.equal cofix_expr_eq fl1 fl2
+  | CProdN(_,bl1,a1), CProdN(_,bl2,a2) ->
+      List.equal binder_expr_eq bl1 bl2 &&
+      constr_expr_eq a1 a2
+  | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) ->
+      List.equal binder_expr_eq bl1 bl2 &&
+      constr_expr_eq a1 a2
+  | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) ->
+      Name.equal na1 na2 &&
+      constr_expr_eq a1 a2 &&
+      constr_expr_eq b1 b2
+  | CAppExpl(_,(proj1,r1,_),al1), CAppExpl(_,(proj2,r2,_),al2) ->
+      Option.equal Int.equal proj1 proj2 &&
+      eq_reference r1 r2 &&
+      List.equal constr_expr_eq al1 al2
+  | CApp(_,(proj1,e1),al1), CApp(_,(proj2,e2),al2) ->
+      Option.equal Int.equal proj1 proj2 &&
+      constr_expr_eq e1 e2 &&
+      List.equal args_eq al1 al2
+  | CRecord (_, e1, l1), CRecord (_, e2, l2) ->
+    let field_eq (r1, e1) (r2, e2) =
+      eq_reference r1 r2 && constr_expr_eq e1 e2
+    in
+    Option.equal constr_expr_eq e1 e2 &&
+    List.equal field_eq l1 l2
+  | CCases(_,_,r1,a1,brl1), CCases(_,_,r2,a2,brl2) ->
+      (** Don't care about the case_style *)
+      Option.equal constr_expr_eq r1 r2 &&
+      List.equal case_expr_eq a1 a2 &&
+      List.equal branch_expr_eq brl1 brl2
+  | CLetTuple (_, n1, (m1, e1), t1, b1), CLetTuple (_, n2, (m2, e2), t2, b2) ->
+    List.equal (eq_located Name.equal) n1 n2 &&
+    Option.equal (eq_located Name.equal) m1 m2 &&
+    Option.equal constr_expr_eq e1 e2 &&
+    constr_expr_eq t1 t2 &&
+    constr_expr_eq b1 b2
+  | CIf (_, e1, (n1, r1), t1, f1), CIf (_, e2, (n2, r2), t2, f2) ->
+    constr_expr_eq e1 e2 &&
+    Option.equal (eq_located Name.equal) n1 n2 &&
+    Option.equal constr_expr_eq r1 r2 &&
+    constr_expr_eq t1 t2 &&
+    constr_expr_eq f1 f2
+  | CHole _, CHole _ -> true
+  | CPatVar(_,i1), CPatVar(_,i2) ->
+    Id.equal i1 i2
+  | CEvar (_, id1, c1), CEvar (_, id2, c2) ->
+    Id.equal id1 id2 && List.equal instance_eq c1 c2
+  | CSort(_,s1), CSort(_,s2) ->
+    Miscops.glob_sort_eq s1 s2
+  | CCast(_,a1,(CastConv b1|CastVM b1)), CCast(_,a2,(CastConv b2|CastVM b2)) ->
+      constr_expr_eq a1 a2 &&
+      constr_expr_eq b1 b2
+  | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) ->
+      constr_expr_eq a1 a2
+  | CNotation(_, n1, s1), CNotation(_, n2, s2) ->
+      String.equal n1 n2 &&
+      constr_notation_substitution_eq s1 s2
+  | CPrim(_,i1), CPrim(_,i2) ->
+    prim_token_eq i1 i2
+  | CGeneralization (_, bk1, ak1, e1), CGeneralization (_, bk2, ak2, e2) ->
+    binding_kind_eq bk1 bk2 &&
+    Option.equal abstraction_kind_eq ak1 ak2 &&
+    constr_expr_eq e1 e2
+  | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) ->
+    String.equal s1 s2 &&
+    constr_expr_eq e1 e2
+  | _ -> false
+
+and args_eq (a1,e1) (a2,e2) =
+  Option.equal (eq_located explicitation_eq) e1 e2 &&
+  constr_expr_eq a1 a2
+
+and case_expr_eq (e1, (n1, p1)) (e2, (n2, p2)) =
+  constr_expr_eq e1 e2 &&
+  Option.equal (eq_located Name.equal) n1 n2 &&
+  Option.equal cases_pattern_expr_eq p1 p2
+
+and branch_expr_eq (_, p1, e1) (_, p2, e2) =
+  List.equal (eq_located (List.equal cases_pattern_expr_eq)) p1 p2 &&
+  constr_expr_eq e1 e2
+
+and binder_expr_eq ((n1, _, e1) : binder_expr) (n2, _, e2) =
+  (** Don't care about the [binder_kind] *)
+  List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2
+
+and fix_expr_eq (id1,(j1, r1),bl1,a1,b1) (id2,(j2, r2),bl2,a2,b2) =
+  (eq_located Id.equal id1 id2) &&
+  Option.equal (eq_located Id.equal) j1 j2 &&
+  recursion_order_expr_eq r1 r2 &&
+  List.equal local_binder_eq bl1 bl2 &&
+  constr_expr_eq a1 a2 &&
+  constr_expr_eq b1 b2
+
+and cofix_expr_eq (id1,bl1,a1,b1) (id2,bl2,a2,b2) =
+  (eq_located Id.equal id1 id2) &&
+  List.equal local_binder_eq bl1 bl2 &&
+  constr_expr_eq a1 a2 &&
+  constr_expr_eq b1 b2
+
+and recursion_order_expr_eq r1 r2 = match r1, r2 with
+| CStructRec, CStructRec -> true
+| CWfRec e1, CWfRec e2 -> constr_expr_eq e1 e2
+| CMeasureRec (e1, o1), CMeasureRec (e2, o2) ->
+  constr_expr_eq e1 e2 && Option.equal constr_expr_eq o1 o2
+| _ -> false
+
+and local_binder_eq l1 l2 = match l1, l2 with
+| LocalRawDef (n1, e1), LocalRawDef (n2, e2) ->
+  eq_located Name.equal n1 n2 && constr_expr_eq e1 e2
+| LocalRawAssum (n1, _, e1), LocalRawAssum (n2, _, e2) ->
+  (** Don't care about the [binder_kind] *)
+  List.equal (eq_located Name.equal) n1 n2 && constr_expr_eq e1 e2
+| _ -> false
+
+and constr_notation_substitution_eq (e1, el1, bl1) (e2, el2, bl2) =
+  List.equal constr_expr_eq e1 e2 &&
+  List.equal (List.equal constr_expr_eq) el1 el2 &&
+  List.equal (List.equal local_binder_eq) bl1 bl2
+
+and instance_eq (x1,c1) (x2,c2) =
+  Id.equal x1 x2 && constr_expr_eq c1 c2
+
+let constr_loc = function
+  | CRef (Ident (loc,_),_) -> loc
+  | CRef (Qualid (loc,_),_) -> loc
+  | CFix (loc,_,_) -> loc
+  | CCoFix (loc,_,_) -> loc
+  | CProdN (loc,_,_) -> loc
+  | CLambdaN (loc,_,_) -> loc
+  | CLetIn (loc,_,_,_) -> loc
+  | CAppExpl (loc,_,_) -> loc
+  | CApp (loc,_,_) -> loc
+  | CRecord (loc,_,_) -> loc
+  | CCases (loc,_,_,_,_) -> loc
+  | CLetTuple (loc,_,_,_,_) -> loc
+  | CIf (loc,_,_,_,_) -> loc
+  | CHole (loc,_,_,_) -> loc
+  | CPatVar (loc,_) -> loc
+  | CEvar (loc,_,_) -> loc
+  | CSort (loc,_) -> loc
+  | CCast (loc,_,_) -> loc
+  | CNotation (loc,_,_) -> loc
+  | CGeneralization (loc,_,_,_) -> loc
+  | CPrim (loc,_) -> loc
+  | CDelimiters (loc,_,_) -> loc
+
+let cases_pattern_expr_loc = function
+  | CPatAlias (loc,_,_) -> loc
+  | CPatCstr (loc,_,_,_) -> loc
+  | CPatAtom (loc,_) -> loc
+  | CPatOr (loc,_) -> loc
+  | CPatNotation (loc,_,_,_) -> loc
+  | CPatRecord (loc, _) -> loc
+  | CPatPrim (loc,_) -> loc
+  | CPatDelimiters (loc,_,_) -> loc
+
+let raw_cases_pattern_expr_loc = function
+  | RCPatAlias (loc,_,_) -> loc
+  | RCPatCstr (loc,_,_,_) -> loc
+  | RCPatAtom (loc,_) -> loc
+  | RCPatOr (loc,_) -> loc
+
+let local_binder_loc = function
+  | LocalRawAssum ((loc,_)::_,_,t)
+  | LocalRawDef ((loc,_),t) -> Loc.merge loc (constr_loc t)
+  | LocalRawAssum ([],_,_) -> assert false
+
+let local_binders_loc bll = match bll with
+  | [] -> Loc.ghost
+  | h :: l ->
+    Loc.merge (local_binder_loc h) (local_binder_loc (List.last bll))
+
+(** Pseudo-constructors *)
+
+let mkIdentC id  = CRef (Ident (Loc.ghost, id),None)
+let mkRefC r     = CRef (r,None)
+let mkCastC (a,k)  = CCast (Loc.ghost,a,k)
+let mkLambdaC (idl,bk,a,b) = CLambdaN (Loc.ghost,[idl,bk,a],b)
+let mkLetInC (id,a,b)   = CLetIn (Loc.ghost,id,a,b)
+let mkProdC (idl,bk,a,b)   = CProdN (Loc.ghost,[idl,bk,a],b)
+
+let mkAppC (f,l) =
+  let l = List.map (fun x -> (x,None)) l in
+  match f with
+  | CApp (_,g,l') -> CApp (Loc.ghost, g, l' @ l)
+  | _ -> CApp (Loc.ghost, (None, f), l)
+
+let rec mkCProdN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
+      CProdN (loc,[idl,bk,t],mkCProdN (Loc.merge loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll ->
+      CLetIn (loc,id,b,mkCProdN (Loc.merge loc1 loc) bll c)
+  | [] -> c
+  | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c
+
+let rec mkCLambdaN loc bll c =
+  match bll with
+  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
+      CLambdaN (loc,[idl,bk,t],mkCLambdaN (Loc.merge loc1 loc) bll c)
+  | LocalRawDef ((loc1,_) as id,b) :: bll ->
+      CLetIn (loc,id,b,mkCLambdaN (Loc.merge loc1 loc) bll c)
+  | [] -> c
+  | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c
+
+let rec abstract_constr_expr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
+  | LocalRawAssum (idl,bk,t)::bl ->
+      List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl
+      (abstract_constr_expr c bl)
+
+let rec prod_constr_expr c = function
+  | [] -> c
+  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl)
+  | LocalRawAssum (idl,bk,t)::bl ->
+      List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl
+      (prod_constr_expr c bl)
+
+let coerce_reference_to_id = function
+  | Ident (_,id) -> id
+  | Qualid (loc,_) ->
+      Errors.user_err_loc (loc, "coerce_reference_to_id",
+        str "This expression should be a simple identifier.")
+
+let coerce_to_id = function
+  | CRef (Ident (loc,id),_) -> (loc,id)
+  | a -> Errors.user_err_loc
+        (constr_loc a,"coerce_to_id",
+         str "This expression should be a simple identifier.")
+
+let coerce_to_name = function
+  | CRef (Ident (loc,id),_) -> (loc,Name id)
+  | CHole (loc,_,_,_) -> (loc,Anonymous)
+  | a -> Errors.user_err_loc
+        (constr_loc a,"coerce_to_name",
+         str "This expression should be a name.")
diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli
new file mode 100644
index 00000000..10c84b8d
--- /dev/null
+++ b/interp/constrexpr_ops.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  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 Loc
+open Names
+open Libnames
+open Misctypes
+open Constrexpr
+
+(** Constrexpr_ops: utilities on [constr_expr] *)
+
+(** {6 Equalities on [constr_expr] related types} *)
+
+val explicitation_eq : explicitation -> explicitation -> bool
+(** Equality on [explicitation]. *)
+
+val constr_expr_eq : constr_expr -> constr_expr -> bool
+(** Equality on [constr_expr]. This is a syntactical one, which is oblivious to
+    some parsing details, including locations. *)
+
+val local_binder_eq : local_binder -> local_binder -> bool
+(** Equality on [local_binder]. Same properties as [constr_expr_eq]. *)
+
+val binding_kind_eq : Decl_kinds.binding_kind -> Decl_kinds.binding_kind -> bool
+(** Equality on [binding_kind] *)
+
+val binder_kind_eq : binder_kind -> binder_kind -> bool
+(** Equality on [binder_kind] *)
+
+(** {6 Retrieving locations} *)
+
+val constr_loc : constr_expr -> Loc.t
+val cases_pattern_expr_loc : cases_pattern_expr -> Loc.t
+val raw_cases_pattern_expr_loc : raw_cases_pattern_expr -> Loc.t
+val local_binders_loc : local_binder list -> Loc.t
+
+(** {6 Constructors}*)
+
+val mkIdentC : Id.t -> constr_expr
+val mkRefC : reference -> constr_expr
+val mkAppC : constr_expr * constr_expr list -> constr_expr
+val mkCastC : constr_expr * constr_expr cast_type -> constr_expr
+val mkLambdaC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr
+val mkLetInC : Name.t located * constr_expr * constr_expr -> constr_expr
+val mkProdC : Name.t located list * binder_kind * constr_expr * constr_expr -> constr_expr
+
+val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
+val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
+
+val mkCLambdaN : Loc.t -> local_binder list -> constr_expr -> constr_expr
+(** Same as [abstract_constr_expr], with location *)
+
+val mkCProdN : Loc.t -> local_binder list -> constr_expr -> constr_expr
+(** Same as [prod_constr_expr], with location *)
+
+(** {6 Destructors}*)
+
+val coerce_reference_to_id : reference -> Id.t
+(** FIXME: nothing to do here *)
+
+val coerce_to_id : constr_expr -> Id.t located
+(** Destruct terms of the form [CRef (Ident _)]. *)
+
+val coerce_to_name : constr_expr -> Name.t located
+(** Destruct terms of the form [CRef (Ident _)] or [CHole _]. *)
+
+(** {6 Binder manipulation} *)
+
+val default_binder_kind : binder_kind
+
+val names_of_local_binders : local_binder list -> Name.t located list
+(** Retrieve a list of binding names from a list of binders. *)
+
+val names_of_local_assums : local_binder list -> Name.t located list
+(** Same as [names_of_local_binders], but does not take the [let] bindings into
+    account. *)
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 911d3741..58e1eb1d 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.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,25 +8,27 @@
 
 (*i*)
 open Pp
+open Errors
 open Util
-open Univ
 open Names
 open Nameops
 open Term
 open Termops
-open Namegen
-open Inductive
-open Sign
-open Environ
 open Libnames
+open Globnames
 open Impargs
+open Constrexpr
+open Constrexpr_ops
+open Notation_ops
 open Topconstr
 open Glob_term
+open Glob_ops
 open Pattern
 open Nametab
 open Notation
-open Reserve
 open Detyping
+open Misctypes
+open Decl_kinds
 (*i*)
 
 (* Translation from glob_constr to front constr *)
@@ -37,8 +39,8 @@ open Detyping
 (* This governs printing of local context of references *)
 let print_arguments = ref false
 
-(* If true, prints local context of evars, whatever print_arguments *)
-let print_evar_arguments = ref false
+(* If true, prints local context of evars *)
+let print_evar_arguments = Detyping.print_evar_arguments
 
 (* This governs printing of implicit arguments.  When
    [print_implicits] is on then [print_implicits_explicit_args] tells
@@ -56,11 +58,14 @@ let print_implicits_defensive = ref true
 let print_coercions = ref false
 
 (* This forces printing universe names of Type{.} *)
-let print_universes = ref false
+let print_universes = Detyping.print_universes
 
-(* This suppresses printing of primitive tokens (e.g. numeral) and symbols *)
+(* This suppresses printing of primitive tokens (e.g. numeral) and notations *)
 let print_no_symbol = ref false
 
+(* This tells which notations still not to used if print_no_symbol is true *)
+let print_non_active_notations = ref ([] : interp_rule list)
+
 (* This governs printing of projections using the dot notation symbols *)
 let print_projections = ref false
 
@@ -70,8 +75,10 @@ let with_arguments f = Flags.with_option print_arguments f
 let with_implicits f = Flags.with_option print_implicits f
 let with_coercions f = Flags.with_option print_coercions f
 let with_universes f = Flags.with_option print_universes f
-let without_symbols f = Flags.with_option print_no_symbol f
 let with_meta_as_hole f = Flags.with_option print_meta_as_hole f
+let without_symbols f = Flags.with_option print_no_symbol f
+let without_specific_symbols l f =
+  Flags.with_extra_values print_non_active_notations l f
 
 (**********************************************************************)
 (* Control printing of records *)
@@ -121,7 +128,7 @@ module PrintingConstructor = Goptions.MakeRefTable(PrintingRecordConstructor)
 
 let insert_delimiters e = function
   | None -> e
-  | Some sc -> CDelimiters (dummy_loc,sc,e)
+  | Some sc -> CDelimiters (Loc.ghost,sc,e)
 
 let insert_pat_delimiters loc p = function
   | None -> p
@@ -134,8 +141,7 @@ let insert_pat_alias loc p = function
 (**********************************************************************)
 (* conversion of references                                           *)
 
-let extern_evar loc n l =
-  if !print_evar_arguments then CEvar (loc,n,l) else CEvar (loc,n,None)
+let extern_evar loc n l = CEvar (loc,n,l)
 
 (** We allow customization of the global_reference printer.
     For instance, in the debugger the tables of global references
@@ -151,124 +157,44 @@ let get_extern_reference () = !my_extern_reference
 
 let extern_reference loc vars l = !my_extern_reference loc vars l
 
-let in_debugger = ref false
-
-
-(************************************************************************)
-(* Equality up to location (useful for translator v8) *)
-
-let rec check_same_pattern p1 p2 =
-  match p1, p2 with
-    | CPatAlias(_,a1,i1), CPatAlias(_,a2,i2) when i1=i2 ->
-        check_same_pattern a1 a2
-    | CPatCstr(_,c1,a1), CPatCstr(_,c2,a2) when c1=c2 ->
-        List.iter2 check_same_pattern a1 a2
-    | CPatCstrExpl(_,c1,a1), CPatCstrExpl(_,c2,a2) when c1=c2 ->
-        List.iter2 check_same_pattern a1 a2
-    | CPatAtom(_,r1), CPatAtom(_,r2) when r1=r2 -> ()
-    | CPatPrim(_,i1), CPatPrim(_,i2) when i1=i2 -> ()
-    | CPatDelimiters(_,s1,e1), CPatDelimiters(_,s2,e2) when s1=s2 ->
-        check_same_pattern e1 e2
-    | _ -> failwith "not same pattern"
-
-let check_same_ref r1 r2 =
-  match r1,r2 with
-  | Qualid(_,q1), Qualid(_,q2) when q1=q2 -> ()
-  | Ident(_,i1), Ident(_,i2) when i1=i2 -> ()
-  | _ -> failwith "not same ref"
-
-let rec check_same_type ty1 ty2 =
-  match ty1, ty2 with
-  | CRef r1, CRef r2 -> check_same_ref r1 r2
-  | CFix(_,(_,id1),fl1), CFix(_,(_,id2),fl2) when id1=id2 ->
-      List.iter2 (fun (id1,i1,bl1,a1,b1) (id2,i2,bl2,a2,b2) ->
-        if id1<>id2 || i1<>i2 then failwith "not same fix";
-        check_same_fix_binder bl1 bl2;
-        check_same_type a1 a2;
-        check_same_type b1 b2)
-        fl1 fl2
-  | CCoFix(_,(_,id1),fl1), CCoFix(_,(_,id2),fl2) when id1=id2 ->
-      List.iter2 (fun (id1,bl1,a1,b1) (id2,bl2,a2,b2) ->
-        if id1<>id2 then failwith "not same fix";
-        check_same_fix_binder bl1 bl2;
-        check_same_type a1 a2;
-        check_same_type b1 b2)
-        fl1 fl2
-  | CArrow(_,a1,b1), CArrow(_,a2,b2) ->
-      check_same_type a1 a2;
-      check_same_type b1 b2
-  | CProdN(_,bl1,a1), CProdN(_,bl2,a2) ->
-      List.iter2 check_same_binder bl1 bl2;
-      check_same_type a1 a2
-  | CLambdaN(_,bl1,a1), CLambdaN(_,bl2,a2) ->
-      List.iter2 check_same_binder bl1 bl2;
-      check_same_type a1 a2
-  | CLetIn(_,(_,na1),a1,b1), CLetIn(_,(_,na2),a2,b2) when na1=na2 ->
-      check_same_type a1 a2;
-      check_same_type b1 b2
-  | CAppExpl(_,(proj1,r1),al1), CAppExpl(_,(proj2,r2),al2) when proj1=proj2 ->
-      check_same_ref r1 r2;
-      List.iter2 check_same_type al1 al2
-  | CApp(_,(_,e1),al1), CApp(_,(_,e2),al2) ->
-      check_same_type e1 e2;
-      List.iter2 (fun (a1,e1) (a2,e2) ->
-                    if e1<>e2 then failwith "not same expl";
-                    check_same_type a1 a2) al1 al2
-  | CCases(_,_,_,a1,brl1), CCases(_,_,_,a2,brl2) ->
-      List.iter2 (fun (tm1,_) (tm2,_) -> check_same_type tm1 tm2) a1 a2;
-      List.iter2 (fun (_,pl1,r1) (_,pl2,r2) ->
-        List.iter2 (located_iter2 (List.iter2 check_same_pattern)) pl1 pl2;
-        check_same_type r1 r2) brl1 brl2
-  | CHole _, CHole _ -> ()
-  | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> ()
-  | CSort(_,s1), CSort(_,s2) when s1=s2 -> ()
-  | CCast(_,a1,CastConv (_,b1)), CCast(_,a2, CastConv(_,b2)) ->
-      check_same_type a1 a2;
-      check_same_type b1 b2
-  | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) ->
-      check_same_type a1 a2
-  | CNotation(_,n1,(e1,el1,bl1)), CNotation(_,n2,(e2,el2,bl2)) when n1=n2 ->
-      List.iter2 check_same_type e1 e2;
-      List.iter2 (List.iter2 check_same_type) el1 el2;
-      List.iter2 check_same_fix_binder bl1 bl2
-  | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> ()
-  | CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 ->
-      check_same_type e1 e2
-  | _ when ty1=ty2 -> ()
-  | _ -> failwith "not same type"
-
-and check_same_binder (nal1,_,e1) (nal2,_,e2) =
-  List.iter2 (fun (_,na1) (_,na2) ->
-    if na1<>na2 then failwith "not same name") nal1 nal2;
-  check_same_type e1 e2
-
-and check_same_fix_binder bl1 bl2 =
-  List.iter2 (fun b1 b2 ->
-    match b1,b2 with
-        LocalRawAssum(nal1,k,ty1), LocalRawAssum(nal2,k',ty2) ->
-          check_same_binder (nal1,k,ty1) (nal2,k',ty2)
-      | LocalRawDef(na1,def1), LocalRawDef(na2,def2) ->
-          check_same_binder ([na1],default_binder_kind,def1) ([na2],default_binder_kind,def2)
-      | _ -> failwith "not same binder") bl1 bl2
-
-let is_same_type c d =
-  try let () = check_same_type c d in true
-  with Failure _ | Invalid_argument _ -> false
-
 (**********************************************************************)
 (* mapping patterns to cases_pattern_expr                                *)
 
+let add_patt_for_params ind l =
+  if !Flags.in_debugger then l else
+    Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CPatAtom (Loc.ghost,None)) l
+
+let drop_implicits_in_patt cst nb_expl args =
+  let impl_st = (implicits_of_global cst) in
+  let impl_data = extract_impargs_data impl_st in
+  let rec impls_fit l = function
+    |[],t -> Some (List.rev_append l t)
+    |_,[] -> None
+    |h::t,CPatAtom(_,None)::tt when is_status_implicit h -> impls_fit l (t,tt)
+    |h::_,_ when is_status_implicit h -> None
+    |_::t,hh::tt -> impls_fit (hh::l) (t,tt)
+  in let rec aux = function
+    |[] -> None
+    |(_,imps)::t -> match impls_fit [] (imps,args) with
+	|None -> aux t
+	|x -> x
+     in
+     if Int.equal nb_expl 0 then aux impl_data
+     else
+       let imps = List.skipn_at_least nb_expl (select_stronger_impargs impl_st) in
+       impls_fit [] (imps,args)
+
 let has_curly_brackets ntn =
-  String.length ntn >= 6 & (String.sub ntn 0 6 = "{ _ } " or
-    String.sub ntn (String.length ntn - 6) 6 = " { _ }" or
-    string_string_contains ~where:ntn ~what:" { _ } ")
+  String.length ntn >= 6 && (String.is_sub "{ _ } " ntn 0 ||
+    String.is_sub " { _ }" ntn (String.length ntn - 6) ||
+    String.string_contains ~where:ntn ~what:" { _ } ")
 
 let rec wildcards ntn n =
-  if n = String.length ntn then []
-  else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l
+  if Int.equal n (String.length ntn) then []
+  else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l
 and spaces ntn n =
-  if n = String.length ntn then []
-  else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
+  if Int.equal n (String.length ntn) then []
+  else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
 
 let expand_curly_brackets loc mknot ntn l =
   let ntn' = ref ntn in
@@ -278,7 +204,7 @@ let expand_curly_brackets loc mknot ntn l =
     | a::l ->
         let a' =
           let p = List.nth (wildcards !ntn' 0) i - 2 in
-          if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }"
+          if p>=0 && p+5 <= String.length !ntn' && String.is_sub "{ _ }" !ntn' p
           then begin
             ntn' :=
               String.sub !ntn' 0 p ^ "_" ^
@@ -304,128 +230,199 @@ let make_notation_gen loc ntn mknot mkprim destprim l =
 	match decompose_notation_key ntn, l with
 	| [Terminal "-"; Terminal x], [] ->
 	    (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
-	     with e when Errors.noncritical e -> mknot (loc,ntn,[]))
+	     with Failure _ -> mknot (loc,ntn,[]))
 	| [Terminal x], [] ->
 	    (try mkprim (loc, Numeral (Bigint.of_string x))
-	     with e when Errors.noncritical e -> mknot (loc,ntn,[]))
+	     with Failure _ -> mknot (loc,ntn,[]))
 	| _ ->
 	    mknot (loc,ntn,l)
 
 let make_notation loc ntn (terms,termlists,binders as subst) =
-  if termlists <> [] or binders <> [] then CNotation (loc,ntn,subst) else
-  make_notation_gen loc ntn
-    (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[])))
-    (fun (loc,p) -> CPrim (loc,p))
-    destPrim terms
+  if not (List.is_empty termlists) || not (List.is_empty binders) then
+    CNotation (loc,ntn,subst)
+  else
+    make_notation_gen loc ntn
+      (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[])))
+      (fun (loc,p) -> CPrim (loc,p))
+      destPrim terms
 
-let make_pat_notation loc ntn (terms,termlists as subst) =
-  if termlists <> [] then CPatNotation (loc,ntn,subst) else
+let make_pat_notation loc ntn (terms,termlists as subst) args =
+  if not (List.is_empty termlists) then CPatNotation (loc,ntn,subst,args) else
   make_notation_gen loc ntn
-    (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[])))
+    (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[]),args))
     (fun (loc,p) -> CPatPrim (loc,p))
     destPatPrim terms
 
 let mkPat loc qid l =
   (* Normally irrelevant test with v8 syntax, but let's do it anyway *)
-  if l = [] then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,l)
+  if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,[],l)
+
+let pattern_printable_in_both_syntax (ind,_ as c) =
+  let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in
+  let nb_params = Inductiveops.inductive_nparams ind in
+  List.exists (fun (_,impls) ->
+    (List.length impls >= nb_params) &&
+      let params,args = Util.List.chop nb_params impls in
+      (List.for_all is_status_implicit params)&&(List.for_all (fun x -> not (is_status_implicit x)) args)
+  ) impl_st
 
  (* Better to use extern_glob_constr composed with injection/retraction ?? *)
 let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
+  (* pboutill: There are letins in pat which is incompatible with notations and
+     not explicit application. *)
+  match pat with
+    | PatCstr(loc,cstrsp,args,na)
+	when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp ->
+      let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in
+      let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
+      CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, [])
+    | _ ->
   try
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
+    if !Flags.raw_print || !print_no_symbol then raise No_match;
     let (na,sc,p) = uninterp_prim_token_cases_pattern pat in
     match availability_of_prim_token p sc scopes with
-    | None -> raise No_match
-    | Some key ->
-      let loc = cases_pattern_loc pat in
-      insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na
-  with No_match ->
-  try
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
-    extern_symbol_pattern scopes vars pat
-      (uninterp_cases_pattern_notations pat)
+      | None -> raise No_match
+      | Some key ->
+	let loc = cases_pattern_loc pat in
+	insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na
   with No_match ->
-  match pat with
-  | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id)))
-  | PatVar (loc,Anonymous) -> CPatAtom (loc, None)
-  | PatCstr(loc,cstrsp,args,na) ->
-      let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
-      let p =
-	try
-          if !in_debugger || !Flags.raw_print then raise Exit;
-	  let projs = Recordops.lookup_projections (fst cstrsp) in
-	  let rec ip projs args acc =
-	    match projs with
-	      | [] -> acc
-	      | None :: q -> ip q args acc
-	      | Some c :: q ->
-		  match args with
-		    | [] -> raise No_match
-		    | CPatAtom(_, None) :: tail -> ip q tail acc
-			(* we don't want to have 'x = _' in our patterns *)
-		    | head :: tail -> ip q tail
-		        ((extern_reference loc Idset.empty (ConstRef c), head) :: acc)
+    try
+      if !Flags.raw_print || !print_no_symbol then raise No_match;
+      extern_symbol_pattern scopes vars pat
+	(uninterp_cases_pattern_notations pat)
+    with No_match ->
+      match pat with
+	| PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id)))
+	| PatVar (loc,Anonymous) -> CPatAtom (loc, None)
+	| PatCstr(loc,cstrsp,args,na) ->
+	  let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
+	  let p =
+	    try
+              if !Flags.raw_print then raise Exit;
+	      let projs = Recordops.lookup_projections (fst cstrsp) in
+	      let rec ip projs args acc =
+		match projs with
+		  | [] -> acc
+		  | None :: q -> ip q args acc
+		  | Some c :: q ->
+		    match args with
+		      | [] -> raise No_match
+		      | CPatAtom(_, None) :: tail -> ip q tail acc
+		    (* we don't want to have 'x = _' in our patterns *)
+		      | head :: tail -> ip q tail
+		        ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc)
+	      in
+	      CPatRecord(loc, List.rev (ip projs args []))
+	    with
+		Not_found | No_match | Exit ->
+                  let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in
+		  if !Topconstr.oldfashion_patterns then
+		    if pattern_printable_in_both_syntax cstrsp
+		    then CPatCstr (loc, c, [], args)
+		    else CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, [])
+		  else
+		    let full_args = add_patt_for_params (fst cstrsp) args in
+		    match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with
+		      |Some true_args -> CPatCstr (loc, c, [], true_args)
+		      |None -> CPatCstr (loc, c, full_args, [])
+	  in insert_pat_alias loc p na
+and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args))
+    (tmp_scope, scopes as allscopes) vars =
+  function
+    | NotationRule (sc,ntn) ->
+      begin
+	match availability_of_notation (sc,ntn) allscopes with
+	  (* Uninterpretation is not allowed in current context *)
+	  | None -> raise No_match
+	  (* Uninterpretation is allowed in current context *)
+	  | Some (scopt,key) ->
+	    let scopes' = Option.List.cons scopt scopes in
+	    let l =
+	      List.map (fun (c,(scopt,scl)) ->
+		extern_cases_pattern_in_scope (scopt,scl@scopes') vars c)
+		subst in
+	    let ll =
+	      List.map (fun (c,(scopt,scl)) ->
+		let subscope = (scopt,scl@scopes') in
+		List.map (extern_cases_pattern_in_scope subscope vars) c)
+		substlist in
+	    let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in
+	    let l2' = if !Topconstr.oldfashion_patterns || not (List.is_empty ll) then l2
+	      else
+		match drop_implicits_in_patt gr nb_to_drop l2 with
+		  |Some true_args -> true_args
+		  |None -> raise No_match
 	    in
-	  CPatRecord(loc, List.rev (ip projs args []))
-	with
-	  Not_found | No_match | Exit ->
-	    CPatCstr (loc, extern_reference loc vars (ConstructRef cstrsp), args) in
-      insert_pat_alias loc p na
-
+	    insert_pat_delimiters loc
+	      (make_pat_notation loc ntn (l,ll) l2') key
+      end
+    | SynDefRule kn ->
+      let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in
+      let l1 =
+	List.rev_map (fun (c,(scopt,scl)) ->
+          extern_cases_pattern_in_scope (scopt,scl@scopes) vars c)
+          subst in
+      let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in
+      let l2' = if !Topconstr.oldfashion_patterns then l2
+	else
+	  match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with
+	    |Some true_args -> true_args
+	    |None -> raise No_match
+      in
+      assert (List.is_empty substlist);
+      mkPat loc qid (List.rev_append l1 l2')
 and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
     try
-      match t,n with
-      | PatCstr (loc,(ind,_),l,na), n when (n = Some 0 or n = None or
-	 n = Some(fst(Global.lookup_inductive ind)).Declarations.mind_nparams)
-          && (match keyrule with SynDefRule _ -> true | _ -> false) ->
-        (* Abbreviation for the constructor name only *)
-	(match keyrule with
-        | NotationRule _ -> assert false
-        | SynDefRule kn ->
-	    let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in
-	    let l = List.map (extern_cases_pattern_in_scope allscopes vars) l in
-	    insert_pat_alias loc (mkPat loc qid l) na)
-      | PatCstr (_,f,l,_), Some n when List.length l > n ->
-	  raise No_match
-      | PatCstr (loc,_,_,na),_ ->
-	(* Try matching ... *)
-	let subst,substlist = match_aconstr_cases_pattern t pat in
-	(* Try availability of interpretation ... *)
-	let p = match keyrule with
-          | NotationRule (sc,ntn) ->
-	      (match availability_of_notation (sc,ntn) allscopes with
-                  (* Uninterpretation is not allowed in current context *)
-              | None -> raise No_match
-                  (* Uninterpretation is allowed in current context *)
-	      | Some (scopt,key) ->
-	          let scopes' = Option.List.cons scopt scopes in
-	          let l =
-		    List.map (fun (c,(scopt,scl)) ->
-		      extern_cases_pattern_in_scope (scopt,scl@scopes') vars c)
-                      subst in
-		  let ll =
-		    List.map (fun (c,(scopt,scl)) ->
-		      let subscope = (scopt,scl@scopes') in
-		      List.map (extern_cases_pattern_in_scope subscope vars) c)
-                      substlist in
-		  insert_pat_delimiters loc
-		    (make_pat_notation loc ntn (l,ll)) key)
-          | SynDefRule kn ->
-	      let qid = Qualid (loc, shortest_qualid_of_syndef vars kn) in
-	      let l =
-		List.map (fun (c,(scopt,scl)) ->
-                  extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) 
-                  subst in
-              assert (substlist = []);
-	      mkPat loc qid l in
-	insert_pat_alias loc p na
-      | PatVar (loc,Anonymous),_ -> CPatAtom (loc, None)
-      | PatVar (loc,Name id),_ -> CPatAtom (loc, Some (Ident (loc,id)))
+      if List.mem keyrule !print_non_active_notations then raise No_match;
+      match t with
+	| PatCstr (loc,cstr,_,na) ->
+	  let p = apply_notation_to_pattern loc (ConstructRef cstr)
+	    (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in
+	  insert_pat_alias loc p na
+	| PatVar (loc,Anonymous) -> CPatAtom (loc, None)
+	| PatVar (loc,Name id) -> CPatAtom (loc, Some (Ident (loc,id)))
     with
 	No_match -> extern_symbol_pattern allscopes vars t rules
 
+let rec extern_symbol_ind_pattern allscopes vars ind args = function
+  | [] -> raise No_match
+  | (keyrule,pat,n as _rule)::rules ->
+    try
+      if List.mem keyrule !print_non_active_notations then raise No_match;
+      apply_notation_to_pattern Loc.ghost (IndRef ind)
+	(match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule
+    with
+	No_match -> extern_symbol_ind_pattern allscopes vars ind args rules
+
+let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args =
+  (* pboutill: There are letins in pat which is incompatible with notations and
+     not explicit application. *)
+  if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then
+    let c = extern_reference Loc.ghost vars (IndRef ind) in
+    let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
+    CPatCstr (Loc.ghost, c, add_patt_for_params ind args, [])
+  else
+    try
+      if !Flags.raw_print || !print_no_symbol then raise No_match;
+      let (sc,p) = uninterp_prim_token_ind_pattern ind args in
+      match availability_of_prim_token p sc scopes with
+	| None -> raise No_match
+	| Some key ->
+	  insert_pat_delimiters Loc.ghost (CPatPrim(Loc.ghost,p)) key
+    with No_match ->
+      try
+	if !Flags.raw_print || !print_no_symbol then raise No_match;
+	extern_symbol_ind_pattern scopes vars ind args
+	  (uninterp_ind_pattern_notations ind)
+    with No_match ->
+      let c = extern_reference Loc.ghost vars (IndRef ind) in
+      let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
+      match drop_implicits_in_patt (IndRef ind) 0 args with
+	   |Some true_args -> CPatCstr (Loc.ghost, c, [], true_args)
+	   |None -> CPatCstr (Loc.ghost, c, args, [])
+
 let extern_cases_pattern vars p =
   extern_cases_pattern_in_scope (None,[]) vars p
 
@@ -438,20 +435,32 @@ let occur_name na aty =
     | Anonymous -> false
 
 let is_projection nargs = function
-  | Some r when not !Flags.raw_print & !print_projections ->
-      (try
-	let n = Recordops.find_projection_nparams r + 1 in
-	if n <= nargs then Some n else None
-      with Not_found -> None)
+  | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections ->
+    (try
+       let n = Recordops.find_projection_nparams r + 1 in
+	 if n <= nargs then None
+	 else Some n
+     with Not_found -> None)
   | _ -> None
-
-let is_hole = function CHole _ -> true | _ -> false
+	
+let is_hole = function CHole _ | CEvar _ -> true | _ -> false
 
 let is_significant_implicit a =
   not (is_hole a)
 
 let is_needed_for_correct_partial_application tail imp =
-  tail = [] & not (maximal_insertion_of imp)
+  List.is_empty tail && not (maximal_insertion_of imp)
+
+exception Expl
+
+let params_implicit n impl = 
+  let rec aux n impl =
+    if n == 0 then true
+    else match impl with
+    | [] -> false
+    | imp :: impl when is_status_implicit imp -> aux (pred n) impl
+    | _ -> false
+  in aux n impl
 
 (* Implicit args indexes are in ascending order *)
 (* inctx is useful only if there is a last argument to be deduced from ctxt *)
@@ -462,55 +471,70 @@ let explicitize loc inctx impl (cf,f) args =
     | a::args, imp::impl when is_status_implicit imp ->
         let tail = exprec (q+1) (args,impl) in
         let visible =
-          !Flags.raw_print or
-          (!print_implicits & !print_implicits_explicit_args) or
-          (is_needed_for_correct_partial_application tail imp) or
-	  (!print_implicits_defensive &
-	   is_significant_implicit a &
+          !Flags.raw_print ||
+          (!print_implicits && !print_implicits_explicit_args) ||
+          (is_needed_for_correct_partial_application tail imp) ||
+	  (!print_implicits_defensive &&
+	   is_significant_implicit a &&
 	   not (is_inferable_implicit inctx n imp))
 	in
         if visible then
-	  (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail
+	  (a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail
 	else
 	  tail
     | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl)
     | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*)
-    | [], _ -> [] in
-  match is_projection (List.length args) cf with
-    | Some i as ip ->
-	if impl <> [] & is_status_implicit (List.nth impl (i-1)) then
-	  let f' = match f with CRef f -> f | _ -> assert false in
-	  CAppExpl (loc,(ip,f'),args)
-	else
-	  let (args1,args2) = list_chop i args in
-	  let (impl1,impl2) = if impl=[] then [],[] else list_chop i impl in
-	  let args1 = exprec 1 (args1,impl1) in
-	  let args2 = exprec (i+1) (args2,impl2) in
-	  CApp (loc,(Some (List.length args1),f),args1@args2)
+    | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> 
+      (* The non-explicit application cannot be parsed back with the same type *)
+      raise Expl
+    | [], _ -> []
+  in
+  let ip = is_projection (List.length args) cf in
+  let expl () = 
+    match ip with
+    | Some i ->
+      if not (List.is_empty impl) && is_status_implicit (List.nth impl (i-1)) then
+	raise Expl
+      else
+	let (args1,args2) = List.chop i args in
+	let (impl1,impl2) = if List.is_empty impl then [],[] else List.chop i impl in
+	let args1 = exprec 1 (args1,impl1) in
+	let args2 = exprec (i+1) (args2,impl2) in
+	let ip = Some (List.length args1) in
+	  CApp (loc,(ip,f),args1@args2)
     | None ->
-	let args = exprec 1 (args,impl) in
-	if args = [] then f else CApp (loc, (None, f), args)
-
-let extern_global loc impl f =
-  if not !Constrintern.parsing_explicit &&
-     impl <> [] && List.for_all is_status_implicit impl
+      let args = exprec 1 (args,impl) in
+	if List.is_empty args then f else CApp (loc, (None, f), args)
+  in
+    try expl ()
+    with Expl -> 
+      let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in
+      let ip = if !print_projections then ip else None in
+	CAppExpl (loc, (ip, f', us), args)
+
+let is_start_implicit = function
+  | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp
+  | [] -> false
+
+let extern_global loc impl f us =
+  if not !Constrintern.parsing_explicit && is_start_implicit impl
   then
-    CAppExpl (loc, (None, f), [])
-  else
-    CRef f
-
-let extern_app loc inctx impl (cf,f) args =
-  if args = [] (* maybe caused by a hidden coercion *) then
-    extern_global loc impl f
+    CAppExpl (loc, (None, f, us), [])
   else
-  if not !Constrintern.parsing_explicit &&
-    ((!Flags.raw_print or
-      (!print_implicits & not !print_implicits_explicit_args)) &
+    CRef (f,us)
+
+let extern_app loc inctx impl (cf,f) us args =
+  if List.is_empty args then
+    (* If coming from a notation "Notation a := @b" *)
+    CAppExpl (loc, (None, f, us), [])
+  else if not !Constrintern.parsing_explicit &&
+    ((!Flags.raw_print ||
+      (!print_implicits && not !print_implicits_explicit_args)) &&
      List.exists is_status_implicit impl)
   then
-    CAppExpl (loc, (is_projection (List.length args) cf, f), args)
+    CAppExpl (loc, (is_projection (List.length args) cf,f,us), args)
   else
-    explicitize loc inctx impl (cf,CRef f) args
+    explicitize loc inctx impl (cf,CRef (f,us)) args
 
 let rec extern_args extern scopes env args subscopes =
   match args with
@@ -521,15 +545,19 @@ let rec extern_args extern scopes env args subscopes =
 	  | scopt::subscopes -> (scopt,scopes), subscopes in
 	extern argscopes env a :: extern_args extern scopes env args subscopes
 
-let rec remove_coercions inctx = function
-  | GApp (loc,GRef (_,r),args) as c
-      when  not (!Flags.raw_print or !print_coercions)
-      ->
+
+let match_coercion_app = function
+  | GApp (loc,GRef (_,r,_),args) -> Some (loc, r, 0, args)
+  | _ -> None
+
+let rec remove_coercions inctx c =
+  match match_coercion_app c with
+  | Some (loc,r,pars,args) when not (!Flags.raw_print || !print_coercions) ->
       let nargs = List.length args in
       (try match Classops.hide_coercion r with
-	  | Some n when n < nargs && (inctx or n+1 < nargs) ->
+	  | Some n when (n - pars) < nargs && (inctx || (n - pars)+1 < nargs) ->
 	      (* We skip a coercion *)
-	      let l = list_skipn n args in
+	      let l = List.skipn (n - pars) args in
 	      let (a,l) = match l with a::l -> (a,l) | [] -> assert false in
               (* Recursively remove the head coercions *)
 	      let a' = remove_coercions true a in
@@ -541,10 +569,10 @@ let rec remove_coercions inctx = function
 		 been confused with ordinary application or would have need
                  a surrounding context and the coercion to funclass would
                  have been made explicit to match *)
-	      if l = [] then a' else GApp (loc,a',l)
+	      if List.is_empty l then a' else GApp (loc,a',l)
 	  | _ -> c
       with Not_found -> c)
-  | c -> c
+  | _ -> c
 
 let rec flatten_application = function
   | GApp (loc,GApp(_,a,l'),l) -> flatten_application (GApp (loc,a,l'@l))
@@ -574,38 +602,44 @@ let extern_optimal_prim_token scopes r r' =
 (* mapping glob_constr to constr_expr                                    *)
 
 let extern_glob_sort = function
-  | GProp _ as s -> s
-  | GType (Some _) as s when !print_universes -> s
-  | GType _ -> GType None
+  | GProp -> GProp
+  | GSet -> GSet
+  | GType _ as s when !print_universes -> s
+  | GType _ -> GType []
 
+let extern_universes = function
+  | Some _ as l when !print_universes -> l
+  | _ -> None
+  
 let rec extern inctx scopes vars r =
   let r' = remove_coercions inctx r in
   try
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
+    if !Flags.raw_print || !print_no_symbol then raise No_match;
     extern_optimal_prim_token scopes r r'
   with No_match ->
   try
     let r'' = flatten_application r' in
-    if !Flags.raw_print or !print_no_symbol then raise No_match;
+    if !Flags.raw_print || !print_no_symbol then raise No_match;
     extern_symbol scopes vars r'' (uninterp_notations r'')
   with No_match -> match r' with
-  | GRef (loc,ref) ->
+  | GRef (loc,ref,us) ->
       extern_global loc (select_stronger_impargs (implicits_of_global ref))
-        (extern_reference loc vars ref)
+        (extern_reference loc vars ref) (extern_universes us)
 
-  | GVar (loc,id) -> CRef (Ident (loc,id))
+  | GVar (loc,id) -> CRef (Ident (loc,id),None)
 
-  | GEvar (loc,n,None) when !print_meta_as_hole -> CHole (loc, None)
+  | GEvar (loc,n,[]) when !print_meta_as_hole -> CHole (loc, None, Misctypes.IntroAnonymous, None)
 
   | GEvar (loc,n,l) ->
-      extern_evar loc n (Option.map (List.map (extern false scopes vars)) l)
+      extern_evar loc n (List.map (on_snd (extern false scopes vars)) l)
 
-  | GPatVar (loc,n) ->
-      if !print_meta_as_hole then CHole (loc, None) else CPatVar (loc,n)
+  | GPatVar (loc,(b,n)) ->
+      if !print_meta_as_hole then CHole (loc, None, Misctypes.IntroAnonymous, None) else
+        if b then CPatVar (loc,n) else CEvar (loc,n,[])
 
   | GApp (loc,f,args) ->
       (match f with
-	 | GRef (rloc,ref) ->
+	 | GRef (rloc,ref,us) ->
 	     let subscopes = find_arguments_scope ref in
 	     let args =
 	       extern_args (extern true) (snd scopes) vars args subscopes in
@@ -623,7 +657,7 @@ let rec extern inctx scopes vars r =
 		 let projs = struc.Recordops.s_PROJ in
 		 let locals = struc.Recordops.s_PROJKIND in
 		 let rec cut args n =
-		   if n = 0 then args
+		   if Int.equal n 0 then args
 		   else
 		     match args with
 		     | [] -> raise No_match
@@ -635,7 +669,7 @@ let rec extern inctx scopes vars r =
 		     | None :: q -> raise No_match
 		     | Some c :: q ->
 		         match locs with
-			   | [] -> anomaly "projections corruption [Constrextern.extern]"
+			   | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern]")
 			   | (_, false) :: locs' ->
 			       (* we don't want to print locals *)
 			       ip q locs' args acc
@@ -644,92 +678,93 @@ let rec extern inctx scopes vars r =
 				 | [] -> raise No_match
 				     (* we give up since the constructor is not complete *)
 				 | head :: tail -> ip q locs' tail
-				     ((extern_reference loc Idset.empty (ConstRef c), head) :: acc)
+				     ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc)
 		   in
 		 CRecord (loc, None, List.rev (ip projs locals args []))
 	       with
 		 | Not_found | No_match | Exit ->
 		     extern_app loc inctx
 		       (select_stronger_impargs (implicits_of_global ref))
-		       (Some ref,extern_reference rloc vars ref) args
+		       (Some ref,extern_reference rloc vars ref) (extern_universes us) args
 	     end
+	       
 	 | _       ->
-	     explicitize loc inctx [] (None,sub_extern false scopes vars f)
-               (List.map (sub_extern true scopes vars) args))
-
-  | GProd (loc,Anonymous,_,t,c) ->
-      (* Anonymous product are never factorized *)
-      CArrow (loc,extern_typ scopes vars t, extern_typ scopes vars c)
+	   explicitize loc inctx [] (None,sub_extern false scopes vars f)
+             (List.map (sub_extern true scopes vars) args))
 
   | GLetIn (loc,na,t,c) ->
       CLetIn (loc,(loc,na),sub_extern false scopes vars t,
               extern inctx scopes (add_vname vars na) c)
 
   | GProd (loc,na,bk,t,c) ->
-      let t = extern_typ scopes vars (anonymize_if_reserved na t) in
+      let t = extern_typ scopes vars t in
       let (idl,c) = factorize_prod scopes (add_vname vars na) na bk t c in
-      CProdN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
+      CProdN (loc,[(Loc.ghost,na)::idl,Default bk,t],c)
 
   | GLambda (loc,na,bk,t,c) ->
-      let t = extern_typ scopes vars (anonymize_if_reserved na t) in
+      let t = extern_typ scopes vars t in
       let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) na bk t c in
-      CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c)
+      CLambdaN (loc,[(Loc.ghost,na)::idl,Default bk,t],c)
 
   | GCases (loc,sty,rtntypopt,tml,eqns) ->
-      let vars' =
-	List.fold_right (name_fold Idset.add)
-	  (cases_predicate_names tml) vars in
-      let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in
-      let tml = List.map (fun (tm,(na,x)) ->
-        let na' = match na,tm with
-            Anonymous, GVar (_,id) when
-              rtntypopt<>None & occur_glob_constr id (Option.get rtntypopt)
-              -> Some (dummy_loc,Anonymous)
-          | Anonymous, _ -> None
-          | Name id, GVar (_,id') when id=id' -> None
-          | Name _, _ -> Some (dummy_loc,na) in
-	(sub_extern false scopes vars tm,
-	(na',Option.map (fun (loc,ind,n,nal) ->
-	  let params = list_tabulate
-	    (fun _ -> GHole (dummy_loc,Evd.InternalHole)) n in
-	  let args = List.map (function
-	    | Anonymous -> GHole (dummy_loc,Evd.InternalHole)
-	    | Name id -> GVar (dummy_loc,id)) nal in
-	  let t = GApp (dummy_loc,GRef (dummy_loc,IndRef ind),params@args) in
-	  (extern_typ scopes vars t)) x))) tml in
-      let eqns = List.map (extern_eqn inctx scopes vars) eqns in
-      CCases (loc,sty,rtntypopt',tml,eqns)
+    let vars' =
+      List.fold_right (name_fold Id.Set.add)
+	(cases_predicate_names tml) vars in
+    let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in
+    let tml = List.map (fun (tm,(na,x)) ->
+      let na' = match na,tm with
+        | Anonymous, GVar (_, id) ->
+            begin match rtntypopt with
+            | None -> None
+            | Some ntn ->
+              if occur_glob_constr id ntn then
+                Some (Loc.ghost, Anonymous)
+              else None
+            end
+        | Anonymous, _ -> None
+        | Name id, GVar (_,id') when Id.equal id id' -> None
+        | Name _, _ -> Some (Loc.ghost,na) in
+      (sub_extern false scopes vars tm,
+       (na',Option.map (fun (loc,ind,nal) ->
+	 let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in
+	 let fullargs =
+	   if !Flags.in_debugger then args else
+	     Notation_ops.add_patterns_for_params ind args in
+	 extern_ind_pattern_in_scope scopes vars ind fullargs
+	) x))) tml in
+    let eqns = List.map (extern_eqn inctx scopes vars) eqns in
+    CCases (loc,sty,rtntypopt',tml,eqns)
 
   | GLetTuple (loc,nal,(na,typopt),tm,b) ->
-      CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal,
-        (Option.map (fun _ -> (dummy_loc,na)) typopt,
+      CLetTuple (loc,List.map (fun na -> (Loc.ghost,na)) nal,
+        (Option.map (fun _ -> (Loc.ghost,na)) typopt,
          Option.map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern false scopes vars tm,
         extern inctx scopes (List.fold_left add_vname vars nal) b)
 
   | GIf (loc,c,(na,typopt),b1,b2) ->
       CIf (loc,sub_extern false scopes vars c,
-        (Option.map (fun _ -> (dummy_loc,na)) typopt,
+        (Option.map (fun _ -> (Loc.ghost,na)) typopt,
          Option.map (extern_typ scopes (add_vname vars na)) typopt),
         sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2)
 
   | GRec (loc,fk,idv,blv,tyv,bv) ->
-      let vars' = Array.fold_right Idset.add idv vars in
+      let vars' = Array.fold_right Id.Set.add idv vars in
       (match fk with
 	 | GFix (nv,n) ->
 	     let listdecl =
 	       Array.mapi (fun i fi ->
                  let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in
                  let (assums,ids,bl) = extern_local_binder scopes vars bl in
-                 let vars0 = List.fold_right (name_fold Idset.add) ids vars in
-                 let vars1 = List.fold_right (name_fold Idset.add) ids vars' in
+                 let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in
+                 let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in
 		 let n =
 		   match fst nv.(i) with
 		     | None -> None
-		     | Some x -> Some (dummy_loc, out_name (List.nth assums x))
+		     | Some x -> Some (Loc.ghost, out_name (List.nth assums x))
 		 in
 		 let ro = extern_recursion_order scopes vars (snd nv.(i)) in
-		 ((dummy_loc, fi), (n, ro), bl, extern_typ scopes vars0 ty,
+		 ((Loc.ghost, fi), (n, ro), bl, extern_typ scopes vars0 ty,
                   extern false scopes vars1 def)) idv
 	     in
 	     CFix (loc,(loc,idv.(n)),Array.to_list listdecl)
@@ -737,21 +772,20 @@ let rec extern inctx scopes vars r =
 	     let listdecl =
                Array.mapi (fun i fi ->
                  let (_,ids,bl) = extern_local_binder scopes vars blv.(i) in
-                 let vars0 = List.fold_right (name_fold Idset.add) ids vars in
-                 let vars1 = List.fold_right (name_fold Idset.add) ids vars' in
-		 ((dummy_loc, fi),bl,extern_typ scopes vars0 tyv.(i),
+                 let vars0 = List.fold_right (name_fold Id.Set.add) ids vars in
+                 let vars1 = List.fold_right (name_fold Id.Set.add) ids vars' in
+		 ((Loc.ghost, fi),bl,extern_typ scopes vars0 tyv.(i),
                   sub_extern false scopes vars1 bv.(i))) idv
 	     in
 	     CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl))
 
   | GSort (loc,s) -> CSort (loc,extern_glob_sort s)
 
-  | GHole (loc,e) -> CHole (loc, Some e)
+  | GHole (loc,e,naming,_) -> CHole (loc, Some e, naming, None) (** TODO: extern tactics. *)
 
-  | GCast (loc,c, CastConv (k,t)) ->
-      CCast (loc,sub_extern true scopes vars c, CastConv (k,extern_typ scopes vars t))
-  | GCast (loc,c, CastCoerce) ->
-      CCast (loc,sub_extern true scopes vars c, CastCoerce)
+  | GCast (loc,c, c') ->
+      CCast (loc,sub_extern true scopes vars c,
+	     Miscops.map_cast_type (extern_typ scopes vars) c')
 
 and extern_typ (_,scopes) =
   extern true (Some Notation.type_scope,scopes)
@@ -762,8 +796,8 @@ and factorize_prod scopes vars na bk aty c =
   let c = extern_typ scopes vars c in
   match na, c with
   | Name id, CProdN (loc,[nal,Default bk',ty],c)
-      when bk = bk' && is_same_type aty ty
-      & not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) ->
+      when binding_kind_eq bk bk' && constr_expr_eq aty ty
+      && not (occur_var_constr_expr id ty) (* avoid na in ty escapes scope *) ->
       nal,c
   | _ ->
       [],c
@@ -772,8 +806,8 @@ and factorize_lambda inctx scopes vars na bk aty c =
   let c = sub_extern inctx scopes vars c in
   match c with
   | CLambdaN (loc,[nal,Default bk',ty],c)
-      when bk = bk' && is_same_type aty ty
-      & not (occur_name na ty) (* avoid na in ty escapes scope *) ->
+      when binding_kind_eq bk bk' && constr_expr_eq aty ty
+      && not (occur_name na ty) (* avoid na in ty escapes scope *) ->
       nal,c
   | _ ->
       [],c
@@ -782,22 +816,22 @@ and extern_local_binder scopes vars = function
     [] -> ([],[],[])
   | (na,bk,Some bd,ty)::l ->
       let (assums,ids,l) =
-        extern_local_binder scopes (name_fold Idset.add na vars) l in
+        extern_local_binder scopes (name_fold Id.Set.add na vars) l in
       (assums,na::ids,
-       LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l)
+       LocalRawDef((Loc.ghost,na), extern false scopes vars bd) :: l)
 
   | (na,bk,None,ty)::l ->
-      let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in
-      (match extern_local_binder scopes (name_fold Idset.add na vars) l with
+      let ty = extern_typ scopes vars ty in
+      (match extern_local_binder scopes (name_fold Id.Set.add na vars) l with
           (assums,ids,LocalRawAssum(nal,k,ty')::l)
-            when is_same_type ty ty' &
+            when constr_expr_eq ty ty' &&
               match na with Name id -> not (occur_var_constr_expr id ty')
                 | _ -> true ->
               (na::assums,na::ids,
-               LocalRawAssum((dummy_loc,na)::nal,k,ty')::l)
+               LocalRawAssum((Loc.ghost,na)::nal,k,ty')::l)
         | (assums,ids,l) ->
             (na::assums,na::ids,
-             LocalRawAssum([(dummy_loc,na)],Default bk,ty) :: l))
+             LocalRawAssum([(Loc.ghost,na)],Default bk,ty) :: l))
 
 and extern_eqn inctx scopes vars (loc,ids,pl,c) =
   (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl],
@@ -806,42 +840,42 @@ and extern_eqn inctx scopes vars (loc,ids,pl,c) =
 and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
   | [] -> raise No_match
   | (keyrule,pat,n as _rule)::rules ->
-      let loc = Glob_term.loc_of_glob_constr t in
+      let loc = Glob_ops.loc_of_glob_constr t in
       try
+        if List.mem keyrule !print_non_active_notations then raise No_match;
 	(* Adjusts to the number of arguments expected by the notation *)
 	let (t,args,argsscopes,argsimpls) = match t,n with
 	  | GApp (_,f,args), Some n
 	      when List.length args >= n ->
-	      let args1, args2 = list_chop n args in
+	      let args1, args2 = List.chop n args in
               let subscopes, impls =
                 match f with
-                | GRef (_,ref) ->
+                | GRef (_,ref,us) ->
 	          let subscopes =
-		    try list_skipn n (find_arguments_scope ref)
-                    with e when Errors.noncritical e -> [] in
+		    try List.skipn n (find_arguments_scope ref)
+                    with Failure _ -> [] in
 	          let impls =
 		    let impls =
 		      select_impargs_size
 		        (List.length args) (implicits_of_global ref) in
-		    try list_skipn n impls
-                    with e when Errors.noncritical e -> [] in
+		    try List.skipn n impls with Failure _ -> [] in
                   subscopes,impls
                 | _ ->
                   [], [] in
-	      (if n = 0 then f else GApp (dummy_loc,f,args1)),
+	      (if Int.equal n 0 then f else GApp (Loc.ghost,f,args1)),
 	      args2, subscopes, impls
-	  | GApp (_,(GRef (_,ref) as f),args), None ->
+	  | GApp (_,(GRef (_,ref,us) as f),args), None ->
 	      let subscopes = find_arguments_scope ref in
 	      let impls =
 		  select_impargs_size
 		    (List.length args) (implicits_of_global ref) in
 	      f, args, subscopes, impls
-	  | GRef _, Some 0 -> GApp (dummy_loc,t,[]), [], [], []
+	  | GRef (_,ref,us), Some 0 -> GApp (Loc.ghost,t,[]), [], [], []
           | _, None -> t, [], [], []
           | _ -> raise No_match in
 	(* Try matching ... *)
 	let terms,termlists,binders =
-          match_aconstr !print_universes t pat in
+          match_notation_constr !print_universes t pat in
 	(* Try availability of interpretation ... *)
         let e =
           match keyrule with
@@ -871,9 +905,9 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
 		List.map (fun (c,(scopt,scl)) ->
 		  extern true (scopt,scl@scopes) vars c, None)
 		  terms in
-              let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in
-	      if l = [] then a else CApp (loc,(None,a),l) in
- 	if args = [] then e
+              let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in
+	      if List.is_empty l then a else CApp (loc,(None,a),l) in
+ 	if List.is_empty args then e
 	else
 	  let args = extern_args (extern true) scopes vars args argsscopes in
 	  explicitize loc false argsimpls (None,e) args
@@ -896,9 +930,9 @@ let extern_glob_type vars c =
 (******************************************************************)
 (* Main translation function from constr -> constr_expr *)
 
-let loc = dummy_loc (* for constr and pattern, locations are lost *)
+let loc = Loc.ghost (* for constr and pattern, locations are lost *)
 
-let extern_constr_gen goal_concl_style scopt env t =
+let extern_constr_gen lax goal_concl_style scopt env sigma t =
   (* "goal_concl_style" means do alpha-conversion using the "goal" convention *)
   (* i.e.: avoid using the names of goal/section/rel variables and the short *)
   (* names of global definitions of current module when computing names for *)
@@ -907,87 +941,99 @@ let extern_constr_gen goal_concl_style scopt env t =
   (* those goal/section/rel variables that occurs in the subterm under *)
   (* consideration; see namegen.ml for further details *)
   let avoid = if goal_concl_style then ids_of_context env else [] in
-  let rel_env_names = names_of_rel_context env in
-  let r = Detyping.detype goal_concl_style avoid rel_env_names t in
+  let r = Detyping.detype ~lax:lax goal_concl_style avoid env sigma t in
   let vars = vars_of_env env in
   extern false (scopt,[]) vars r
 
-let extern_constr_in_scope goal_concl_style scope env t =
-  extern_constr_gen goal_concl_style (Some scope) env t
+let extern_constr_in_scope goal_concl_style scope env sigma t =
+  extern_constr_gen false goal_concl_style (Some scope) env sigma t
 
-let extern_constr goal_concl_style env t =
-  extern_constr_gen goal_concl_style None env t
+let extern_constr ?(lax=false) goal_concl_style env sigma t =
+  extern_constr_gen lax goal_concl_style None env sigma t
 
-let extern_type goal_concl_style env t =
+let extern_type goal_concl_style env sigma t =
   let avoid = if goal_concl_style then ids_of_context env else [] in
-  let rel_env_names = names_of_rel_context env in
-  let r = Detyping.detype goal_concl_style avoid rel_env_names t in
+  let r = Detyping.detype goal_concl_style avoid env sigma t in
   extern_glob_type (vars_of_env env) r
 
-let extern_sort s = extern_glob_sort (detype_sort s)
+let extern_sort sigma s = extern_glob_sort (detype_sort sigma s)
+
+let extern_closed_glob ?lax goal_concl_style env sigma t =
+  let avoid = if goal_concl_style then ids_of_context env else [] in
+  let r =
+    Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t
+  in
+  let vars = vars_of_env env in
+  extern false (None,[]) vars r
 
 (******************************************************************)
 (* Main translation function from pattern -> constr_expr *)
 
 let any_any_branch =
   (* | _ => _ *)
-  (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evd.InternalHole))
+  (loc,[],[PatVar (loc,Anonymous)],GHole (loc,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None))
 
-let rec glob_of_pat env = function
-  | PRef ref -> GRef (loc,ref)
+let rec glob_of_pat env sigma = function
+  | PRef ref -> GRef (loc,ref,None)
   | PVar id -> GVar (loc,id)
-  | PEvar (n,l) -> GEvar (loc,n,Some (array_map_to_list (glob_of_pat env) l))
+  | PEvar (evk,l) ->
+      let test id = function PVar id' -> Id.equal id id' | _ -> false in
+      let l = Evd.evar_instance_array test (Evd.find sigma evk) l in
+      let id = Evd.evar_ident evk sigma in
+      GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l)
   | PRel n ->
       let id = try match lookup_name_of_rel n env with
 	| Name id   -> id
 	| Anonymous ->
-	    anomaly "glob_constr_of_pattern: index to an anonymous variable"
-      with Not_found -> id_of_string ("_UNBOUND_REL_"^(string_of_int n)) in
+	    anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable")
+      with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in
       GVar (loc,id)
-  | PMeta None -> GHole (loc,Evd.InternalHole)
+  | PMeta None -> GHole (loc,Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None)
   | PMeta (Some n) -> GPatVar (loc,(false,n))
+  | PProj (p,c) -> GApp (loc,GRef (loc, ConstRef (Projection.constant p),None),
+			 [glob_of_pat env sigma c])
   | PApp (f,args) ->
-      GApp (loc,glob_of_pat env f,array_map_to_list (glob_of_pat env) args)
+      GApp (loc,glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args)
   | PSoApp (n,args) ->
       GApp (loc,GPatVar (loc,(true,n)),
-        List.map (glob_of_pat env) args)
+        List.map (glob_of_pat env sigma) args)
   | PProd (na,t,c) ->
-      GProd (loc,na,Explicit,glob_of_pat env t,glob_of_pat (na::env) c)
+      GProd (loc,na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c)
   | PLetIn (na,t,c) ->
-      GLetIn (loc,na,glob_of_pat env t, glob_of_pat (na::env) c)
+      GLetIn (loc,na,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c)
   | PLambda (na,t,c) ->
-      GLambda (loc,na,Explicit,glob_of_pat env t, glob_of_pat (na::env) c)
+      GLambda (loc,na,Explicit,glob_of_pat env sigma t, glob_of_pat (na::env) sigma c)
   | PIf (c,b1,b2) ->
-      GIf (loc, glob_of_pat env c, (Anonymous,None),
-           glob_of_pat env b1, glob_of_pat env b2)
-  | PCase ({cip_style=LetStyle; cip_ind_args=None},PMeta None,tm,[(0,n,b)]) ->
-      let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env b) in
-      GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env tm,b)
+      GIf (loc, glob_of_pat env sigma c, (Anonymous,None),
+           glob_of_pat env sigma b1, glob_of_pat env sigma b2)
+  | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) ->
+      let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat env sigma b) in
+      GLetTuple (loc,nal,(Anonymous,None),glob_of_pat env sigma tm,b)
   | PCase (info,p,tm,bl) ->
       let mat = match bl, info.cip_ind with
 	| [], _ -> []
 	| _, Some ind ->
-	  let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env c)) bl in
+	  let bl' = List.map (fun (i,n,c) -> (i,n,glob_of_pat env sigma c)) bl in
 	  simple_cases_matrix_of_branches ind bl'
-	| _, None -> anomaly "PCase with some branches but unknown inductive"
+	| _, None -> anomaly (Pp.str "PCase with some branches but unknown inductive")
       in
       let mat = if info.cip_extensible then mat @ [any_any_branch] else mat
       in
-      let indnames,rtn = match p, info.cip_ind, info.cip_ind_args with
+      let indnames,rtn = match p, info.cip_ind, info.cip_ind_tags with
 	| PMeta None, _, _ -> (Anonymous,None),None
-	| _, Some ind, Some (nparams,nargs) ->
-	  return_type_of_predicate ind nparams nargs (glob_of_pat env p)
-	| _ -> anomaly "PCase with non-trivial predicate but unknown inductive"
+	| _, Some ind, Some nargs ->
+	  return_type_of_predicate ind nargs (glob_of_pat env sigma p)
+	| _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive")
       in
-      GCases (loc,RegularStyle,rtn,[glob_of_pat env tm,indnames],mat)
-  | PFix f -> Detyping.detype false [] env (mkFix f)
-  | PCoFix c -> Detyping.detype false [] env (mkCoFix c)
+      GCases (loc,RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat)
+  | PFix f -> Detyping.detype_names false [] env (Global.env()) sigma (mkFix f) (** FIXME bad env *)
+  | PCoFix c -> Detyping.detype_names false [] env (Global.env()) sigma (mkCoFix c)
   | PSort s -> GSort (loc,s)
 
-let extern_constr_pattern env pat =
-  extern true (None,[]) Idset.empty (glob_of_pat env pat)
+let extern_constr_pattern env sigma pat =
+  extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat)
 
-let extern_rel_context where env sign =
-  let a = detype_rel_context where [] (names_of_rel_context env) sign in
+let extern_rel_context where env sigma sign =
+  let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in
   let vars = vars_of_env env in
   pi3 (extern_local_binder (None,[]) vars a)
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index 8933d3af..b797e455 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -1,43 +1,47 @@
 (************************************************************************)
 (*  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 Util
 open Names
 open Term
+open Context
 open Termops
-open Sign
 open Environ
 open Libnames
-open Nametab
+open Globnames
 open Glob_term
 open Pattern
-open Topconstr
+open Constrexpr
+open Notation_term
 open Notation
-
-val is_same_type : constr_expr -> constr_expr -> bool
+open Misctypes
 
 (** Translation of pattern, cases pattern, glob_constr and term into syntax
    trees for printing *)
 
-val extern_cases_pattern : Idset.t -> cases_pattern -> cases_pattern_expr
-val extern_glob_constr : Idset.t -> glob_constr -> constr_expr
-val extern_glob_type : Idset.t -> glob_constr -> constr_expr
-val extern_constr_pattern : names_context -> constr_pattern -> constr_expr
+val extern_cases_pattern : Id.Set.t -> cases_pattern -> cases_pattern_expr
+val extern_glob_constr : Id.Set.t -> glob_constr -> constr_expr
+val extern_glob_type : Id.Set.t -> glob_constr -> constr_expr
+val extern_constr_pattern : names_context -> Evd.evar_map ->
+  constr_pattern -> constr_expr
+val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob_constr -> constr_expr
 
 (** If [b=true] in [extern_constr b env c] then the variables in the first
-   level of quantification clashing with the variables in [env] are renamed *)
+   level of quantification clashing with the variables in [env] are renamed.
+    ~lax is for debug printing, when the constr might not be well typed in 
+    env, sigma
+*)
 
-val extern_constr : bool -> env -> constr -> constr_expr
-val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr
-val extern_reference : loc -> Idset.t -> global_reference -> reference
-val extern_type : bool -> env -> types -> constr_expr
-val extern_sort : sorts -> glob_sort
-val extern_rel_context : constr option -> env ->
+val extern_constr : ?lax:bool -> bool -> env -> Evd.evar_map -> constr -> constr_expr
+val extern_constr_in_scope : bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr
+val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference
+val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr
+val extern_sort : Evd.evar_map -> sorts -> glob_sort
+val extern_rel_context : constr option -> env -> Evd.evar_map ->
   rel_context -> local_binder list
 
 (** Printing options *)
@@ -52,11 +56,9 @@ val print_projections : bool ref
 
 (** Customization of the global_reference printer *)
 val set_extern_reference :
-  (loc -> Idset.t -> global_reference -> reference) -> unit
+  (Loc.t -> Id.Set.t -> global_reference -> reference) -> unit
 val get_extern_reference :
-  unit -> (loc -> Idset.t -> global_reference -> reference)
-
-val in_debugger : bool ref
+  unit -> (Loc.t -> Id.Set.t -> global_reference -> reference)
 
 (** This governs printing of implicit arguments. If [with_implicits] is
    on and not [with_arguments] then implicit args are printed prefixed
@@ -71,8 +73,11 @@ val with_coercions : ('a -> 'b) -> 'a -> 'b
 (** This forces printing universe names of Type\{.\} *)
 val with_universes : ('a -> 'b) -> 'a -> 'b
 
-(** This suppresses printing of numeral and symbols *)
+(** This suppresses printing of primitive tokens and notations *)
 val without_symbols : ('a -> 'b) -> 'a -> 'b
 
+(** This suppresses printing of specific notations only *)
+val without_specific_symbols : interp_rule list -> ('a -> 'b) -> 'a -> 'b
+
 (** This prints metas as anonymous holes *)
 val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index b6f18fe3..68f0050d 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -1,33 +1,50 @@
 (************************************************************************)
 (*  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 Flags
 open Names
 open Nameops
 open Namegen
 open Libnames
+open Globnames
 open Impargs
 open Glob_term
-open Pattern
+open Glob_ops
+open Patternops
 open Pretyping
 open Cases
+open Constrexpr
+open Constrexpr_ops
+open Notation_term
+open Notation_ops
 open Topconstr
 open Nametab
 open Notation
 open Inductiveops
+open Decl_kinds
+
+(** constr_expr -> glob_constr translation:
+    - it adds holes for implicit arguments
+    - it remplaces notations by their value (scopes stuff are here)
+    - it recognizes global vars from local ones
+    - it prepares pattern maching problems (a pattern becomes a tree where nodes
+    are constructor/variable pairs and leafs are variables)
+
+    All that at once, fasten your seatbelt!
+*)
 
 (* To interpret implicits and arg scopes of variables in inductive
    types and recursive definitions and of projection names in records *)
 
 type var_internalization_type =
-  | Inductive of identifier list (* list of params *)
+  | Inductive of Id.t list (* list of params *)
   | Recursive
   | Method
   | Variable
@@ -38,16 +55,21 @@ type var_internalization_data =
     var_internalization_type *
     (* impargs to automatically add to the variable, e.g. for "JMeq A a B b"
        in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *)
-    identifier list *
+    Id.t list *
     (* signature of impargs of the variable *)
     Impargs.implicit_status list *
     (* subscopes of the args of the variable *)
     scope_name option list
 
 type internalization_env =
-    (var_internalization_data) Idmap.t
+    (var_internalization_data) Id.Map.t
+
+type glob_binder = (Name.t * binding_kind * glob_constr option * glob_constr)
 
-type glob_binder = (name * binding_kind * glob_constr option * glob_constr)
+type ltac_sign = {
+  ltac_vars : Id.Set.t;
+  ltac_bound : Id.Set.t;
+}
 
 let interning_grammar = ref false
 
@@ -75,38 +97,33 @@ let global_reference_of_reference ref =
   locate_reference (snd (qualid_of_reference ref))
 
 let global_reference id =
-  constr_of_global (locate_reference (qualid_of_ident id))
+  Universes.constr_of_global (locate_reference (qualid_of_ident id))
 
 let construct_reference ctx id =
   try
-    Term.mkVar (let _ = Sign.lookup_named id ctx in id)
+    Term.mkVar (let _ = Context.lookup_named id ctx in id)
   with Not_found ->
     global_reference id
 
 let global_reference_in_absolute_module dir id =
-  constr_of_global (Nametab.global_of_path (Libnames.make_path dir id))
+  Universes.constr_of_global (Nametab.global_of_path (Libnames.make_path dir id))
 
 (**********************************************************************)
 (* Internalization errors                                             *)
 
 type internalization_error =
-  | VariableCapture of identifier
-  | WrongExplicitImplicit
+  | VariableCapture of Id.t * Id.t
   | IllegalMetavariable
   | NotAConstructor of reference
-  | UnboundFixName of bool * identifier
-  | NonLinearPattern of identifier
+  | UnboundFixName of bool * Id.t
+  | NonLinearPattern of Id.t
   | BadPatternsNumber of int * int
-  | BadExplicitationNumber of explicitation * int option
 
-exception InternalizationError of loc * internalization_error
+exception InternalizationError of Loc.t * internalization_error
 
-let explain_variable_capture id =
-  str "The variable " ++ pr_id id ++ str " occurs in its type"
-
-let explain_wrong_explicit_implicit =
-  str "Found an explicitly given implicit argument but was expecting" ++
-  fnl () ++ str "a regular one"
+let explain_variable_capture id id' =
+  pr_id id ++ str " is dependent in the type of " ++ pr_id id' ++
+  strbrk ": cannot interpret both of them with the same type"
 
 let explain_illegal_metavariable =
   str "Metavariables allowed only in patterns"
@@ -123,44 +140,31 @@ let explain_non_linear_pattern id =
   str "The variable " ++ pr_id id ++ str " is bound several times in pattern"
 
 let explain_bad_patterns_number n1 n2 =
-  str "Expecting " ++ int n1 ++ str (plural n1 " pattern") ++
+  str "Expecting " ++ int n1 ++ str (String.plural n1 " pattern") ++
   str " but found " ++ int n2
 
-let explain_bad_explicitation_number n po =
-  match n with
-  | ExplByPos (n,_id) ->
-      let s = match po with
-	| None -> str "a regular argument"
-	| Some p -> int p in
-      str "Bad explicitation number: found " ++ int n ++
-      str" but was expecting " ++ s
-  | ExplByName id ->
-      let s = match po with
-	| None -> str "a regular argument"
-	| Some p -> (*pr_id (name_of_position p) in*) failwith "" in
-      str "Bad explicitation name: found " ++ pr_id id ++
-      str" but was expecting " ++ s
-
 let explain_internalization_error e =
   let pp = match e with
-  | VariableCapture id -> explain_variable_capture id
-  | WrongExplicitImplicit -> explain_wrong_explicit_implicit
+  | VariableCapture (id,id') -> explain_variable_capture id id'
   | IllegalMetavariable -> explain_illegal_metavariable
   | NotAConstructor ref -> explain_not_a_constructor ref
   | UnboundFixName (iscofix,id) -> explain_unbound_fix_name iscofix id
   | NonLinearPattern id -> explain_non_linear_pattern id
   | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2
-  | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po in
-  pp ++ str "."
+  in pp ++ str "."
 
 let error_bad_inductive_type loc =
   user_err_loc (loc,"",str
-    "This should be an inductive type applied to names or \"_\".")
+    "This should be an inductive type applied to patterns.")
 
-let error_inductive_parameter_not_implicit loc =
+let error_parameter_not_implicit loc =
   user_err_loc (loc,"", str
-   ("The parameters of inductive types do not bind in\n"^
-    "the 'return' clauses; they must be replaced by '_' in the 'in' clauses."))
+   "The parameters do not bind in patterns;" ++ spc () ++ str
+    "they must be replaced by '_'.")
+
+let error_ldots_var loc =
+  user_err_loc (loc,"",str "Special token " ++ pr_id ldots_var ++
+    str " is for use in the Notation command.")
 
 (**********************************************************************)
 (* Pre-computing the implicit arguments and arguments scopes needed   *)
@@ -168,12 +172,12 @@ let error_inductive_parameter_not_implicit loc =
 
 let parsing_explicit = ref false
 
-let empty_internalization_env = Idmap.empty
+let empty_internalization_env = Id.Map.empty
 
 let compute_explicitable_implicit imps = function
   | Inductive params ->
       (* In inductive types, the parameters are fixed implicit arguments *)
-      let sub_impl,_ = list_chop (List.length params) imps in
+      let sub_impl,_ = List.chop (List.length params) imps in
       let sub_impl' = List.filter is_status_implicit sub_impl in
       List.map name_of_implicit sub_impl'
   | Recursive | Method | Variable ->
@@ -186,25 +190,25 @@ let compute_internalization_data env ty typ impl =
   (ty, expls_impl, impl, compute_arguments_scope typ)
 
 let compute_internalization_env env ty =
-  list_fold_left3
-    (fun map id typ impl -> Idmap.add id (compute_internalization_data env ty typ impl) map)
+  List.fold_left3
+    (fun map id typ impl -> Id.Map.add id (compute_internalization_data env ty typ impl) map)
     empty_internalization_env
 
 (**********************************************************************)
 (* Contracting "{ _ }" in notations *)
 
 let rec wildcards ntn n =
-  if n = String.length ntn then []
-  else let l = spaces ntn (n+1) in if ntn.[n] = '_' then n::l else l
+  if Int.equal n (String.length ntn) then []
+  else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l
 and spaces ntn n =
-  if n = String.length ntn then []
-  else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
+  if Int.equal n (String.length ntn) then []
+  else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
 
 let expand_notation_string ntn n =
   let pos = List.nth (wildcards ntn 0) n in
-  let hd = if pos = 0 then "" else String.sub ntn 0 pos in
+  let hd = if Int.equal pos 0 then "" else String.sub ntn 0 pos in
   let tl =
-    if pos = String.length ntn then ""
+    if Int.equal pos (String.length ntn) then ""
     else String.sub ntn (pos+1) (String.length ntn - pos -1) in
   hd ^ "{ _ }" ^ tl
 
@@ -227,7 +231,7 @@ let contract_pat_notation ntn (l,ll) =
   let ntn' = ref ntn in
   let rec contract_squash n = function
     | [] -> []
-    | CPatNotation (_,"{ _ }",([a],[])) :: l ->
+    | CPatNotation (_,"{ _ }",([a],[]),[]) :: l ->
         ntn' := expand_notation_string !ntn' n;
         contract_squash n (a::l)
     | a :: l ->
@@ -237,19 +241,19 @@ let contract_pat_notation ntn (l,ll) =
   !ntn',(l,ll)
 
 type intern_env = {
-  ids: Names.Idset.t;
+  ids: Names.Id.Set.t;
   unb: bool;
-  tmp_scope: Topconstr.tmp_scope_name option;
-  scopes: Topconstr.scope_name list;
+  tmp_scope: Notation_term.tmp_scope_name option;
+  scopes: Notation_term.scope_name list;
   impls: internalization_env }
 
 (**********************************************************************)
 (* Remembering the parsing scope of variables in notations            *)
 
-let make_current_scope = function
-  | (Some tmp_scope,(sc::_ as scopes)) when sc = tmp_scope -> scopes
-  | (Some tmp_scope,scopes) -> tmp_scope::scopes
-  | None,scopes -> scopes
+let make_current_scope tmp scopes = match tmp, scopes with
+| Some tmp_scope, (sc :: _) when String.equal sc tmp_scope -> scopes
+| Some tmp_scope, scopes -> tmp_scope :: scopes
+| None, scopes -> scopes
 
 let pr_scope_stack = function
   | [] -> str "the empty scope stack"
@@ -263,10 +267,6 @@ let error_inconsistent_scope loc id scopes1 scopes2 =
     pr_scope_stack scopes2 ++ strbrk " while it was elsewhere used in " ++
     pr_scope_stack scopes1)
 
-let error_expect_constr_notation_type loc id =
-  user_err_loc (loc,"",
-    pr_id id ++ str " is bound in the notation to a term variable.")
-
 let error_expect_binder_notation_type loc id =
   user_err_loc (loc,"",
     pr_id id ++
@@ -274,18 +274,17 @@ let error_expect_binder_notation_type loc id =
 
 let set_var_scope loc id istermvar env ntnvars =
   try
-    let idscopes,typ = List.assoc id ntnvars in
-    if istermvar then
+    let idscopes,typ = Id.Map.find id ntnvars in
+    let () = if istermvar then
       (* scopes have no effect on the interpretation of identifiers *)
-      if !idscopes = None then
-        idscopes := Some (env.tmp_scope,env.scopes)
-      else
-        if make_current_scope (Option.get !idscopes)
-          <> make_current_scope (env.tmp_scope,env.scopes)
-        then
-	  error_inconsistent_scope loc id
-	    (make_current_scope (Option.get !idscopes))
-	    (make_current_scope (env.tmp_scope,env.scopes));
+      begin match !idscopes with
+      | None -> idscopes := Some (env.tmp_scope, env.scopes)
+      | Some (tmp, scope) ->
+        let s1 = make_current_scope tmp scope in
+        let s2 = make_current_scope env.tmp_scope env.scopes in
+        if not (List.equal String.equal s1 s2) then error_inconsistent_scope loc id s1 s2
+      end
+    in
     match typ with
     | NtnInternTypeBinder ->
 	if istermvar then error_expect_binder_notation_type loc id
@@ -303,14 +302,14 @@ let set_type_scope env = {env with tmp_scope = Some Notation.type_scope}
 
 let reset_tmp_scope env = {env with tmp_scope = None}
 
-let rec it_mkGProd env body =
+let rec it_mkGProd loc2 env body =
   match env with
-      (na, bk, _, t) :: tl -> it_mkGProd tl (GProd (dummy_loc, na, bk, t, body))
+      (loc1, (na, bk, _, t)) :: tl -> it_mkGProd loc2 tl (GProd (Loc.merge loc1 loc2, na, bk, t, body))
     | [] -> body
 
-let rec it_mkGLambda env body =
+let rec it_mkGLambda loc2 env body =
   match env with
-      (na, bk, _, t) :: tl -> it_mkGLambda tl (GLambda (dummy_loc, na, bk, t, body))
+      (loc1, (na, bk, _, t)) :: tl -> it_mkGLambda loc2 tl (GLambda (Loc.merge loc1 loc2, na, bk, t, body))
     | [] -> body
 
 (**********************************************************************)
@@ -318,7 +317,7 @@ let rec it_mkGLambda env body =
 let build_impls = function
   |Implicit -> (function
 		  |Name id ->  Some (id, Impargs.Manual, (true,true))
-		  |Anonymous -> anomaly "Anonymous implicit argument")
+		  |Anonymous -> anomaly (Pp.str "Anonymous implicit argument"))
   |Explicit -> fun _ -> None
 
 let impls_type_list ?(args = []) =
@@ -337,30 +336,32 @@ let impls_term_list ?(args = []) =
     |_ -> (Variable,[],List.append args (List.rev acc),[])
   in aux []
 
-let check_capture loc ty = function
-  | Name id when occur_var_constr_expr id ty ->
-      raise (InternalizationError (loc,VariableCapture id))
-  | _ ->
+(* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *)
+let rec check_capture ty = function
+  | (loc,Name id)::(_,Name id')::_ when occur_glob_constr id ty ->
+      raise (InternalizationError (loc,VariableCapture (id,id')))
+  | _::nal ->
+      check_capture ty nal
+  | [] ->
       ()
 
-let locate_if_isevar loc na = function
-  | GHole _ ->
+let locate_if_hole loc na = function
+  | GHole (_,_,naming,arg) ->
       (try match na with
-	| Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id)
+	| Name id -> glob_constr_of_notation_constr loc
+	               (Reserve.find_reserved_type id)
 	| Anonymous -> raise Not_found
-      with Not_found -> GHole (loc, Evd.BinderType na))
+      with Not_found -> GHole (loc, Evar_kinds.BinderType na, naming, arg))
   | x -> x
 
 let reset_hidden_inductive_implicit_test env =
-  { env with impls = Idmap.fold (fun id x ->
-       let x = match x with
+  { env with impls = Id.Map.map (function
          | (Inductive _,b,c,d) -> (Inductive [],b,c,d)
-         | x -> x
-       in Idmap.add id x) env.impls Idmap.empty }
+         | x -> x) env.impls }
 
 let check_hidden_implicit_parameters id impls =
-  if Idmap.exists (fun _ -> function
-    | (Inductive indparams,_,_,_) -> List.mem id indparams
+  if Id.Map.exists (fun _ -> function
+    | (Inductive indparams,_,_,_) -> Id.List.mem id indparams
     | _ -> false) impls
   then
     errorlabstrm "" (strbrk "A parameter of an inductive type " ++
@@ -374,14 +375,17 @@ let push_name_env ?(global_level=false) lvar implargs env =
       env
   | loc,Name id ->
       check_hidden_implicit_parameters id env.impls ;
-      set_var_scope loc id false env (let (_,ntnvars) = lvar in ntnvars);
+      let (_,ntnvars) = lvar in
+      if Id.Map.is_empty ntnvars && Id.equal id ldots_var
+        then error_ldots_var loc;
+      set_var_scope loc id false env ntnvars;
       if global_level then Dumpglob.dump_definition (loc,id) true "var"
       else Dumpglob.dump_binding loc id;
-      {env with ids = Idset.add id env.ids; impls = Idmap.add id implargs env.impls}
+      {env with ids = Id.Set.add id env.ids; impls = Id.Map.add id implargs env.impls}
 
 let intern_generalized_binder ?(global_level=false) intern_type lvar
-    env bl (loc, na) b b' t ty =
-  let ids = (match na with Anonymous -> fun x -> x | Name na -> Idset.add na) env.ids in
+    env (loc, na) b b' t ty =
+  let ids = (match na with Anonymous -> fun x -> x | Name na -> Id.Set.add na) env.ids in
   let ty, ids' =
     if t then ty, ids else
       Implicit_quantifiers.implicit_application ids
@@ -392,7 +396,11 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar
   let env' = List.fold_left
     (fun env (x, l) -> push_name_env ~global_level lvar (Variable,[],[],[])(*?*) env (l, Name x))
     env fvs in
-  let bl = List.map (fun (id, loc) -> (Name id, b, None, GHole (loc, Evd.BinderType (Name id)))) fvs in
+  let bl = List.map
+    (fun (id, loc) ->
+      (loc, (Name id, b, None, GHole (loc, Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None))))
+    fvs
+  in
   let na = match na with
     | Anonymous ->
 	if global_level then na
@@ -400,183 +408,221 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar
 	  let name =
 	    let id =
 	      match ty with
-	      | CApp (_, (_, CRef (Ident (loc,id))), _) -> id
-	      | _ -> id_of_string "H"
+	      | CApp (_, (_, CRef (Ident (loc,id),_)), _) -> id
+	      | _ -> default_non_dependent_ident
 	    in Implicit_quantifiers.make_fresh ids' (Global.env ()) id
 	  in Name name
     | _ -> na
-  in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (na,b',None,ty') :: List.rev bl
-
-let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function
+  in (push_name_env ~global_level lvar (impls_type_list ty')(*?*) env' (loc,na)), (loc,(na,b',None,ty')) :: List.rev bl
+
+let intern_assumption intern lvar env nal bk ty =
+  let intern_type env = intern (set_type_scope env) in
+  match bk with
+  | Default k ->
+      let ty = intern_type env ty in
+      check_capture ty nal;
+      let impls = impls_type_list ty in
+      List.fold_left
+	(fun (env, bl) (loc, na as locna) ->
+          (push_name_env lvar impls env locna,
+           (loc,(na,k,None,locate_if_hole loc na ty))::bl))
+	(env, []) nal
+  | Generalized (b,b',t) ->
+     let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in
+     env, b
+
+let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function
   | LocalRawAssum(nal,bk,ty) ->
-      (match bk with
-      | Default k ->
-	  let ty = intern_type env ty in
-          let impls = impls_type_list ty in
-	    List.fold_left
-	     (fun (env,bl) (loc,na as locna) ->
-	       (push_name_env lvar impls env locna,
-                (na,k,None,locate_if_isevar loc na ty)::bl))
-	      (env,bl) nal
-      | Generalized (b,b',t) ->
-	  let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in
-	    env, b @ bl)
+      let env, bl' = intern_assumption intern lvar env nal bk ty in
+      env, bl' @ bl
   | LocalRawDef((loc,na as locna),def) ->
       let indef = intern env def in
       (push_name_env lvar (impls_term_list indef) env locna,
-      (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl)
+      (loc,(na,Explicit,Some(indef),GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None)))::bl)
 
 let intern_generalization intern env lvar loc bk ak c =
   let c = intern {env with unb = true} c in
   let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:env.ids c in
   let env', c' =
     let abs =
-      let pi =
-	match ak with
+      let pi = match ak with
 	| Some AbsPi -> true
-	| None when env.tmp_scope = Some Notation.type_scope
-	    || List.mem Notation.type_scope env.scopes -> true
-	| _ -> false
+        | Some _ -> false
+	| None ->
+          let is_type_scope = match env.tmp_scope with
+          | None -> false
+          | Some sc -> String.equal sc Notation.type_scope
+          in
+          is_type_scope ||
+          String.List.mem Notation.type_scope env.scopes
       in
 	if pi then
 	  (fun (id, loc') acc ->
-	    GProd (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc))
+	    GProd (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc))
 	else
 	  (fun (id, loc') acc ->
-	    GLambda (join_loc loc' loc, Name id, bk, GHole (loc', Evd.BinderType (Name id)), acc))
+	    GLambda (Loc.merge loc' loc, Name id, bk, GHole (loc', Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc))
     in
       List.fold_right (fun (id, loc as lid) (env, acc) ->
 	let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in
 	  (env', abs lid acc)) fvs (env,c)
   in c'
 
-let iterate_binder intern lvar (env,bl) = function
-  | LocalRawAssum(nal,bk,ty) ->
-      let intern_type env = intern (set_type_scope env) in
-      (match bk with
-      | Default k ->
-	  let ty = intern_type env ty in
-          let impls = impls_type_list ty in
-	  List.fold_left
-	    (fun (env,bl) (loc,na as locna) ->
-              (push_name_env lvar impls env locna,
-               (na,k,None,locate_if_isevar loc na ty)::bl))
-	    (env,bl) nal
-      | Generalized (b,b',t) ->
-	  let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in
-	    env, b @ bl)
-  | LocalRawDef((loc,na as locna),def) ->
-      let indef = intern env def in
-      (push_name_env lvar (impls_term_list indef) env locna,
-      (na,Explicit,Some(indef),GHole(loc,Evd.BinderType na))::bl)
-
 (**********************************************************************)
 (* Syntax extensions                                                  *)
 
 let option_mem_assoc id = function
-  | Some (id',c) -> id = id'
+  | Some (id',c) -> Id.equal id id'
   | None -> false
 
-let find_fresh_name renaming (terms,termlists,binders) id =
-  let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) terms in
-  let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in
-  let fvs3 = List.map snd renaming in
+let find_fresh_name renaming (terms,termlists,binders) avoid id =
+  let fold1 _ (c, _) accu = Id.Set.union (free_vars_of_constr_expr c) accu in
+  let fold2 _ (l, _) accu =
+    let fold accu c = Id.Set.union (free_vars_of_constr_expr c) accu in
+    List.fold_left fold accu l
+  in
+  let fold3 _ x accu = Id.Set.add x accu in
+  let fvs1 = Id.Map.fold fold1 terms avoid in
+  let fvs2 = Id.Map.fold fold2 termlists fvs1 in
+  let fvs3 = Id.Map.fold fold3 renaming fvs2 in
   (* TODO binders *)
-  let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in
-  next_ident_away id fvs
+  next_ident_away_from id (fun id -> Id.Set.mem id fvs3)
 
-let traverse_binder (terms,_,_ as subst)
-    (renaming,env)=
- function
+let traverse_binder (terms,_,_ as subst) avoid (renaming,env) = function
  | Anonymous -> (renaming,env),Anonymous
  | Name id ->
   try
     (* Binders bound in the notation are considered first-order objects *)
-    let _,na = coerce_to_name (fst (List.assoc id terms)) in
-    (renaming,{env with ids = name_fold Idset.add na env.ids}), na
+    let _,na = coerce_to_name (fst (Id.Map.find id terms)) in
+    (renaming,{env with ids = name_fold Id.Set.add na env.ids}), na
   with Not_found ->
     (* Binders not bound in the notation do not capture variables *)
     (* outside the notation (i.e. in the substitution) *)
-    let id' = find_fresh_name renaming subst id in
-    let renaming' = if id=id' then renaming else (id,id')::renaming in
+    let id' = find_fresh_name renaming subst avoid id in
+    let renaming' =
+      if Id.equal id id' then renaming else Id.Map.add id id' renaming
+    in
     (renaming',env), Name id'
 
-let make_letins loc = List.fold_right (fun (na,b,t) c -> GLetIn (loc,na,b,c))
+let make_letins = List.fold_right (fun (loc,(na,b,t)) c -> GLetIn (loc,na,b,c))
 
 let rec subordinate_letins letins = function
   (* binders come in reverse order; the non-let are returned in reverse order together *)
   (* with the subordinated let-in in writing order *)
-  | (na,_,Some b,t)::l ->
-      subordinate_letins ((na,b,t)::letins) l
-  | (na,bk,None,t)::l ->
+  | (loc,(na,_,Some b,t))::l ->
+      subordinate_letins ((loc,(na,b,t))::letins) l
+  | (loc,(na,bk,None,t))::l ->
       let letins',rest = subordinate_letins [] l in
-      letins',((na,bk,t),letins)::rest
+      letins',((loc,(na,bk,t)),letins)::rest
   | [] ->
       letins,[]
 
 let rec subst_iterator y t = function
-  | GVar (_,id) as x -> if id = y then t else x
+  | GVar (_,id) as x -> if Id.equal id y then t else x
   | x -> map_glob_constr (subst_iterator y t) x
 
-let subst_aconstr_in_glob_constr loc intern lvar subst infos c =
+let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c =
   let (terms,termlists,binders) = subst in
+  (* when called while defining a notation, avoid capturing the private binders
+     of the expression by variables bound by the notation (see #3892) *)
+  let avoid = Id.Map.domain ntnvars in
   let rec aux (terms,binderopt as subst') (renaming,env) c =
     let subinfos = renaming,{env with tmp_scope = None} in
     match c with
-    | AVar id ->
-      begin
-	(* subst remembers the delimiters stack in the interpretation *)
-	(* of the notations *)
-	try
-	  let (a,(scopt,subscopes)) = List.assoc id terms in
-	  intern {env with tmp_scope = scopt;
-		    scopes = subscopes @ env.scopes} a
-	with Not_found ->
-	try
-	  GVar (loc,List.assoc id renaming)
-	with Not_found ->
-	  (* Happens for local notation joint with inductive/fixpoint defs *)
-	  GVar (loc,id)
-      end
-    | AList (x,_,iter,terminator,lassoc) ->
+    | NVar id -> subst_var subst' (renaming, env) id
+    | NList (x,_,iter,terminator,lassoc) ->
       (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
-	let (l,(scopt,subscopes)) = List.assoc x termlists in
+	let (l,(scopt,subscopes)) = Id.Map.find x termlists in
         let termin = aux subst' subinfos terminator in
-	List.fold_right (fun a t ->
-          subst_iterator ldots_var t
-            (aux ((x,(a,(scopt,subscopes)))::terms,binderopt) subinfos iter))
-            (if lassoc then List.rev l else l) termin
+        let fold a t =
+          let nterms = Id.Map.add x (a, (scopt, subscopes)) terms in
+          subst_iterator ldots_var t (aux (nterms, binderopt) subinfos iter)
+        in
+	List.fold_right fold (if lassoc then List.rev l else l) termin
       with Not_found ->
-          anomaly "Inconsistent substitution of recursive notation")
-    | AHole (Evd.BinderType (Name id as na)) ->
-      let na =
-        try snd (coerce_to_name (fst (List.assoc id terms)))
-        with Not_found -> na in
-      GHole (loc,Evd.BinderType na)
-    | ABinderList (x,_,iter,terminator) ->
+          anomaly (Pp.str "Inconsistent substitution of recursive notation"))
+    | NHole (knd, naming, arg) ->
+      let knd = match knd with
+      | Evar_kinds.BinderType (Name id as na) ->
+        let na =
+          try snd (coerce_to_name (fst (Id.Map.find id terms)))
+          with Not_found ->
+          try Name (Id.Map.find id renaming)
+          with Not_found -> na
+        in
+        Evar_kinds.BinderType na
+      | _ -> knd
+      in
+      let arg = match arg with
+      | None -> None
+      | Some arg ->
+        let open Tacexpr in
+        let open Genarg in
+        let wit = glbwit Constrarg.wit_tactic in
+        let body =
+          if has_type arg wit then out_gen wit arg
+          else assert false (** FIXME *)
+        in
+        let mk_env id (c, (tmp_scope, subscopes)) accu =
+          let nenv = {env with tmp_scope; scopes = subscopes @ env.scopes} in
+          let gc = intern nenv c in
+          let c = ConstrMayEval (Genredexpr.ConstrTerm (gc, Some c)) in
+          ((loc, id), c) :: accu
+        in
+        let bindings = Id.Map.fold mk_env terms [] in
+        let tac = TacLetIn (false, bindings, body) in
+        let arg = in_gen wit tac in
+        Some arg
+      in
+      GHole (loc, knd, naming, arg)
+    | NBinderList (x,_,iter,terminator) ->
       (try
         (* All elements of the list are in scopes (scopt,subscopes) *)
-	let (bl,(scopt,subscopes)) = List.assoc x binders in
-	let env,bl = List.fold_left (iterate_binder intern lvar) (env,[]) bl in
+	let (bl,(scopt,subscopes)) = Id.Map.find x binders in
+	let env,bl = List.fold_left (intern_local_binder_aux intern lvar) (env,[]) bl in
 	let letins,bl = subordinate_letins [] bl in
         let termin = aux subst' (renaming,env) terminator in
 	let res = List.fold_left (fun t binder ->
           subst_iterator ldots_var t
 	    (aux (terms,Some(x,binder)) subinfos iter))
 	  termin bl in
-	make_letins loc letins res
+	make_letins letins res
       with Not_found ->
-          anomaly "Inconsistent substitution of recursive notation")
-    | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt ->
-        let (na,bk,t),letins = snd (Option.get binderopt) in
-	GProd (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
-    | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt ->
-        let (na,bk,t),letins = snd (Option.get binderopt) in
-	GLambda (loc,na,bk,t,make_letins loc letins (aux subst' infos c'))
+          anomaly (Pp.str "Inconsistent substitution of recursive notation"))
+    | NProd (Name id, NHole _, c') when option_mem_assoc id binderopt ->
+        let (loc,(na,bk,t)),letins = snd (Option.get binderopt) in
+	GProd (loc,na,bk,t,make_letins letins (aux subst' infos c'))
+    | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt ->
+        let (loc,(na,bk,t)),letins = snd (Option.get binderopt) in
+	GLambda (loc,na,bk,t,make_letins letins (aux subst' infos c'))
+    (* Two special cases to keep binder name synchronous with BinderType *)
+    | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c')
+        when Name.equal na na' ->
+        let subinfos,na = traverse_binder subst avoid subinfos na in
+        let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in
+	GProd (loc,na,Explicit,ty,aux subst' subinfos c')
+    | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c')
+        when Name.equal na na' ->
+        let subinfos,na = traverse_binder subst avoid subinfos na in
+        let ty = GHole (loc,Evar_kinds.BinderType na,naming,arg) in
+	GLambda (loc,na,Explicit,ty,aux subst' subinfos c')
     | t ->
-      glob_constr_of_aconstr_with_binders loc (traverse_binder subst)
-	(aux subst') subinfos t
+      glob_constr_of_notation_constr_with_binders loc
+        (traverse_binder subst avoid) (aux subst') subinfos t
+  and subst_var (terms, binderopt) (renaming, env) id =
+    (* subst remembers the delimiters stack in the interpretation *)
+    (* of the notations *)
+    try
+      let (a,(scopt,subscopes)) = Id.Map.find id terms in
+      intern {env with tmp_scope = scopt;
+                scopes = subscopes @ env.scopes} a
+    with Not_found ->
+    try
+      GVar (loc, Id.Map.find id renaming)
+    with Not_found ->
+      (* Happens for local notation joint with inductive/fixpoint defs *)
+      GVar (loc,id)
   in aux (terms,None) infos c
 
 let split_by_type ids =
@@ -586,7 +632,9 @@ let split_by_type ids =
     | NtnTypeConstrList -> (l1,(x,scl)::l2,l3)
     | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[])
 
-let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l
+let make_subst ids l =
+  let fold accu (id, scl) a = Id.Map.add id (a, scl) accu in
+  List.fold_left2 fold Id.Map.empty ids l
 
 let intern_notation intern env lvar loc ntn fullargs =
   let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in
@@ -597,7 +645,7 @@ let intern_notation intern env lvar loc ntn fullargs =
   let termlists = make_subst idsl argslist in
   let binders = make_subst idsbl bll in
   subst_aconstr_in_glob_constr loc intern lvar
-    (terms,termlists,binders) ([],env) c
+    (terms, termlists, binders) (Id.Map.empty, env) c
 
 (**********************************************************************)
 (* Discriminating between bound variables and global references       *)
@@ -609,39 +657,35 @@ let string_of_ty = function
   | Variable -> "var"
 
 let intern_var genv (ltacvars,ntnvars) namedctx loc id =
-  let (ltacvars,unbndltacvars) = ltacvars in
   (* Is [id] an inductive type potentially with implicit *)
   try
-    let ty,expl_impls,impls,argsc = Idmap.find id genv.impls in
+    let ty,expl_impls,impls,argsc = Id.Map.find id genv.impls in
     let expl_impls = List.map
-      (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in
+      (fun id -> CRef (Ident (loc,id),None), Some (loc,ExplByName id)) expl_impls in
     let tys = string_of_ty ty in
-    Dumpglob.dump_reference loc "<>" (string_of_id id) tys;
+    Dumpglob.dump_reference loc "<>" (Id.to_string id) tys;
     GVar (loc,id), make_implicits_list impls, argsc, expl_impls
   with Not_found ->
   (* Is [id] bound in current term or is an ltac var bound to constr *)
-  if Idset.mem id genv.ids or List.mem id ltacvars
+  if Id.Set.mem id genv.ids || Id.Set.mem id ltacvars.ltac_vars
   then
     GVar (loc,id), [], [], []
   (* Is [id] a notation variable *)
-
-  else if List.mem_assoc id ntnvars
+  else if Id.Map.mem id ntnvars
   then
     (set_var_scope loc id true genv ntnvars; GVar (loc,id), [], [], [])
   (* Is [id] the special variable for recursive notations *)
-  else if ntnvars <> [] && id = ldots_var
-  then
-    GVar (loc,id), [], [], []
+  else if Id.equal id ldots_var
+  then if Id.Map.is_empty ntnvars
+    then error_ldots_var loc
+    else GVar (loc,id), [], [], []
+  else if Id.Set.mem id ltacvars.ltac_bound then
+    (* Is [id] bound to a free name in ltac (this is an ltac error message) *)
+    user_err_loc (loc,"intern_var",
+      str "variable " ++ pr_id id ++ str " should be bound to a term.")
   else
-  (* Is [id] bound to a free name in ltac (this is an ltac error message) *)
-  try
-    match List.assoc id unbndltacvars with
-      | None -> user_err_loc (loc,"intern_var",
-	  str "variable " ++ pr_id id ++ str " should be bound to a term.")
-      | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-  with Not_found ->
     (* Is [id] a goal or section variable *)
-    let _ = Sign.lookup_named id namedctx in
+    let _ = Context.lookup_named id namedctx in
       try
 	(* [id] a section variable *)
 	(* Redundant: could be done in intern_qualid *)
@@ -649,128 +693,171 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id =
 	let impls = implicits_of_global ref in
 	let scopes = find_arguments_scope ref in
 	Dumpglob.dump_reference loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var";
-	GRef (loc, ref), impls, scopes, []
+	GRef (loc, ref, None), impls, scopes, []
       with e when Errors.noncritical e ->
 	(* [id] a goal variable *)
 	GVar (loc,id), [], [], []
 
-let find_appl_head_data = function
-  | GRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[]
-  | GApp (_,GRef (_,ref),l) as x
-      when l <> [] & Flags.version_strictly_greater Flags.V8_2 ->
+let proj_impls r impls =
+  let env = Global.env () in
+  let f (x, l) = x, projection_implicits env r l in
+    List.map f impls
+
+let proj_scopes n scopes = 
+  List.skipn_at_least n scopes
+
+let proj_impls_scopes p impls scopes =
+  match p with
+  | Some (r, n) -> proj_impls r impls, proj_scopes n scopes
+  | None -> impls, scopes
+
+let find_appl_head_data c =
+  match c with
+  | GRef (loc,ref,_) as x -> 
+    let impls = implicits_of_global ref in
+    let scopes = find_arguments_scope ref in
+      x, impls, scopes, []
+  | GApp (_,GRef (_,ref,_),l) as x
+      when l != [] && Flags.version_strictly_greater Flags.V8_2 ->
       let n = List.length l in
-      x,List.map (drop_first_implicits n) (implicits_of_global ref),
-      list_skipn_at_least n (find_arguments_scope ref),[]
+      let impls = implicits_of_global ref in 
+      let scopes = find_arguments_scope ref in
+	x, List.map (drop_first_implicits n) impls,
+	List.skipn_at_least n scopes,[]
   | x -> x,[],[],[]
 
 let error_not_enough_arguments loc =
   user_err_loc (loc,"",str "Abbreviation is not applied enough.")
 
 let check_no_explicitation l =
-  let l = List.filter (fun (a,b) -> b <> None) l in
-  if l <> [] then
-    let loc = fst (Option.get (snd (List.hd l))) in
-    user_err_loc
-     (loc,"",str"Unexpected explicitation of the argument of an abbreviation.")
+  let is_unset (a, b) = match b with None -> false | Some _ -> true in
+  let l = List.filter is_unset l in
+  match l with
+  | [] -> ()
+  | (_, None) :: _ -> assert false
+  | (_, Some (loc, _)) :: _ ->
+    user_err_loc (loc,"",str"Unexpected explicitation of the argument of an abbreviation.")
 
 let dump_extended_global loc = function
-  | TrueGlobal ref -> Dumpglob.add_glob loc ref
+  | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob loc ref
   | SynDef sp -> Dumpglob.add_glob_kn loc sp
 
 let intern_extended_global_of_qualid (loc,qid) =
-  try let r = Nametab.locate_extended qid in dump_extended_global loc r; r
-  with Not_found -> error_global_not_found_loc loc qid
+  let r = Nametab.locate_extended qid in dump_extended_global loc r; r
 
 let intern_reference ref =
-  Smartlocate.global_of_extended_global
-    (intern_extended_global_of_qualid (qualid_of_reference ref))
+  let qid = qualid_of_reference ref in
+  let r =
+    try intern_extended_global_of_qualid qid
+    with Not_found -> error_global_not_found_loc (fst qid) (snd qid)
+  in
+  Smartlocate.global_of_extended_global r
 
 (* Is it a global reference or a syntactic definition? *)
-let intern_qualid loc qid intern env lvar args =
+let intern_qualid loc qid intern env lvar us args =
   match intern_extended_global_of_qualid (loc,qid) with
-  | TrueGlobal ref ->
-      GRef (loc, ref), args
+  | TrueGlobal ref -> GRef (loc, ref, us), true, args
   | SynDef sp ->
       let (ids,c) = Syntax_def.search_syntactic_definition sp in
       let nids = List.length ids in
       if List.length args < nids then error_not_enough_arguments loc;
-      let args1,args2 = list_chop nids args in
+      let args1,args2 = List.chop nids args in
       check_no_explicitation args1;
-      let subst = make_subst ids (List.map fst args1) in
-      subst_aconstr_in_glob_constr loc intern lvar (subst,[],[]) ([],env) c, args2
+      let terms = make_subst ids (List.map fst args1) in
+      let subst = (terms, Id.Map.empty, Id.Map.empty) in
+      let infos = (Id.Map.empty, env) in
+      let projapp = match c with NRef _ -> true | _ -> false in
+	subst_aconstr_in_glob_constr loc intern lvar subst infos c, projapp, args2
 
 (* Rule out section vars since these should have been found by intern_var *)
-let intern_non_secvar_qualid loc qid intern env lvar args =
-  match intern_qualid loc qid intern env lvar args with
-    | GRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid
+let intern_non_secvar_qualid loc qid intern env lvar us args =
+  match intern_qualid loc qid intern env lvar us args with
+    | GRef (_, VarRef _, _),_,_ -> raise Not_found
     | r -> r
 
-let intern_applied_reference intern env namedctx lvar args = function
+let intern_applied_reference intern env namedctx lvar us args = function
   | Qualid (loc, qid) ->
-      let r,args2 = intern_qualid loc qid intern env lvar args in
-      find_appl_head_data r, args2
+      let r,projapp,args2 =
+	try intern_qualid loc qid intern env lvar us args
+	with Not_found -> error_global_not_found_loc loc qid
+      in
+      let x, imp, scopes, l = find_appl_head_data r in
+	(x,imp,scopes,l), args2
   | Ident (loc, id) ->
       try intern_var env lvar namedctx loc id, args
       with Not_found ->
       let qid = qualid_of_ident id in
       try
-	let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in
-	find_appl_head_data r, args2
-      with e when Errors.noncritical e ->
+	let r, projapp, args2 = intern_non_secvar_qualid loc qid intern env lvar us args in
+	let x, imp, scopes, l = find_appl_head_data r in
+	  (x,imp,scopes,l), args2
+      with Not_found ->
 	(* Extra allowance for non globalizing functions *)
 	if !interning_grammar || env.unb then
-	  (GVar (loc,id), [], [], []),args
-	else raise e
+	  (GVar (loc,id), [], [], []), args
+	else error_global_not_found_loc loc qid
 
 let interp_reference vars r =
   let (r,_,_,_),_ =
-    intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc)
-      {ids = Idset.empty; unb = false ;
+    intern_applied_reference (fun _ -> error_not_enough_arguments Loc.ghost)
+      {ids = Id.Set.empty; unb = false ;
        tmp_scope = None; scopes = []; impls = empty_internalization_env} []
-      (vars,[]) [] r
+      (vars, Id.Map.empty) None [] r
   in r
 
+(**********************************************************************)
+(** {5 Cases }                                                        *)
+
+(** {6 Elemtary bricks } *)
 let apply_scope_env env = function
   | [] -> {env with tmp_scope = None}, []
   | sc::scl -> {env with tmp_scope = sc}, scl
 
 let rec simple_adjust_scopes n scopes =
-  if n=0 then [] else match scopes with
+  (* Note: they can be less scopes than arguments but also more scopes *)
+  (* than arguments because extra scopes are used in the presence of *)
+  (* coercions to funclass *)
+  if Int.equal n 0 then [] else match scopes with
   | [] -> None :: simple_adjust_scopes (n-1) []
   | sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes
 
-let find_remaining_constructor_scopes pl1 pl2 (ind,j as cstr) =
-  let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
-  let npar = mib.Declarations.mind_nparams in
-  snd (list_chop (npar + List.length pl1)
-    (simple_adjust_scopes (npar + List.length pl1 + List.length pl2)
-      (find_arguments_scope (ConstructRef cstr))))
+let find_remaining_scopes pl1 pl2 ref =
+  let impls_st = implicits_of_global ref in
+  let len_pl1 = List.length pl1 in
+  let len_pl2 = List.length pl2 in
+  let impl_list = if Int.equal len_pl1 0
+    then select_impargs_size len_pl2 impls_st
+    else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in
+  let allscs = find_arguments_scope ref in
+  let scope_list = List.skipn_at_least len_pl1 allscs in
+  let rec aux = function
+    |[],l -> l
+    |_,[] -> []
+    |h::t,_::tt when is_status_implicit h -> aux (t,tt)
+    |_::t,h::tt -> h :: aux (t,tt)
+  in ((try List.firstn len_pl1 allscs with Failure _ -> simple_adjust_scopes len_pl1 allscs),
+      simple_adjust_scopes len_pl2 (aux (impl_list,scope_list)))
 
-(**********************************************************************)
-(* Cases                                                              *)
+let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2
 
 let product_of_cases_patterns ids idspl =
   List.fold_right (fun (ids,pl) (ids',ptaill) ->
-    (ids@ids',
-    (* Cartesian prod of the or-pats for the nth arg and the tail args *)
-    List.flatten (
-    List.map (fun (subst,p) ->
-      List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl)))
-    idspl (ids,[[],[]])
-
-let simple_product_of_cases_patterns pl =
-  List.fold_right (fun pl ptaill ->
-    List.flatten (List.map (fun (subst,p) ->
-      List.map (fun (subst',ptail) -> (subst@subst',p::ptail)) ptaill) pl))
-    pl [[],[]]
-
-(* Check linearity of pattern-matching *)
+    (ids @ ids',
+     (* Cartesian prod of the or-pats for the nth arg and the tail args *)
+     List.flatten (
+       List.map (fun (subst,p) ->
+	 List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl)))
+    idspl (ids,[Id.Map.empty,[]])
+
+(* @return the first variable that occurs twice in a pattern
+
+naive n^2 algo *)
 let rec has_duplicate = function
   | [] -> None
-  | x::l -> if List.mem x l then (Some x) else has_duplicate l
+  | x::l -> if Id.List.mem x l then (Some x) else has_duplicate l
 
 let loc_of_lhs lhs =
- join_loc (fst (List.hd lhs)) (fst (list_last lhs))
+ Loc.merge (fst (List.hd lhs)) (fst (List.last lhs))
 
 let check_linearity lhs ids =
   match has_duplicate ids with
@@ -782,167 +869,89 @@ let check_linearity lhs ids =
 (* Match the number of pattern against the number of matched args *)
 let check_number_of_pattern loc n l =
   let p = List.length l in
-  if n<>p then raise (InternalizationError (loc,BadPatternsNumber (n,p)))
+  if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p)))
 
 let check_or_pat_variables loc ids idsl =
-  if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then
+  if List.exists (fun ids' -> not (List.eq_set Id.equal ids ids')) idsl then
     user_err_loc (loc, "", str
     "The components of this disjunctive pattern must bind the same variables.")
 
-let check_constructor_length env loc cstr pl pl0 =
-  let n = List.length pl + List.length pl0 in
-  let nargs = Inductiveops.constructor_nrealargs env cstr in
-  let nhyps = Inductiveops.constructor_nrealhyps env cstr in
-  if n <> nargs && n <> nhyps (* i.e. with let's *) then
-    error_wrong_numarg_constructor_loc loc env cstr nargs
-
-(* Manage multiple aliases *)
-
-  (* [merge_aliases] returns the sets of all aliases encountered at this
-     point and a substitution mapping extra aliases to the first one *)
-let merge_aliases (ids,asubst as _aliases) id =
-  ids@[id], if ids=[] then asubst else (id, List.hd ids)::asubst
-
-let alias_of = function
-  | ([],_) -> Anonymous
-  | (id::_,_) -> Name id
-
-let message_redundant_alias (id1,id2) =
-  if_warn msg_warning
-    (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2)
-
-(* Expanding notations *)
-
-let chop_aconstr_constructor loc (ind,k) args =
-  if List.length args = 0 then (* Tolerance for a @id notation *) args else
-    begin
-      let mib,_ = Global.lookup_inductive ind in
-      let nparams = mib.Declarations.mind_nparams in
-      if nparams > List.length args then error_invalid_pattern_notation loc;
-      let params,args = list_chop nparams args in
-      List.iter (function AHole _ -> ()
-	| _ -> error_invalid_pattern_notation loc) params;
-      args
-    end
-
-let rec subst_pat_iterator y t (subst,p) = match p with
-  | PatVar (_,id) as x ->
-      if id = Name y then t else [subst,x]
-  | PatCstr (loc,id,l,alias) ->
-      let l' = List.map (fun a -> (subst_pat_iterator y t ([],a))) l in
-      let pl = simple_product_of_cases_patterns l' in
-      List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl
-
-let subst_cases_pattern loc alias intern fullsubst env a =
-  let rec aux alias (subst,substlist as fullsubst) = function
-  | AVar id ->
-      begin
-	(* subst remembers the delimiters stack in the interpretation *)
-	(* of the notations *)
-	try
-	  let (a,(scopt,subscopes)) = List.assoc id subst in
-	    intern {env with scopes=subscopes@env.scopes;
-		      tmp_scope = scopt} ([],[]) a
-	with Not_found ->
-	  if id = ldots_var then [], [[], PatVar (loc,Name id)] else
-	  anomaly ("Unbound pattern notation variable: "^(string_of_id id))
-	  (*
-	  (* Happens for local notation joint with inductive/fixpoint defs *)
-	  if aliases <> ([],[]) then
-	    anomaly "Pattern notation without constructors";
-	  [[id],[]], PatVar (loc,Name id)
-	  *)
-      end
-  | ARef (ConstructRef c) ->
-      ([],[[], PatCstr (loc,c, [], alias)])
-  | AApp (ARef (ConstructRef cstr),args) ->
-      let args = chop_aconstr_constructor loc cstr args in
-      let idslpll = List.map (aux Anonymous fullsubst) args in
-      let ids',pll = product_of_cases_patterns [] idslpll in
-      let pl' = List.map (fun (asubst,pl) ->
-        asubst,PatCstr (loc,cstr,pl,alias)) pll in
-	ids', pl'
-  | AList (x,_,iter,terminator,lassoc) ->
-      (try
-        (* All elements of the list are in scopes (scopt,subscopes) *)
-	let (l,(scopt,subscopes)) = List.assoc x substlist in
-        let termin = aux Anonymous fullsubst terminator in
-        let idsl,v =
-	  List.fold_right (fun a (tids,t) ->
-            let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in
-            let pll = List.map (subst_pat_iterator ldots_var t) u in
-            tids@uids, List.flatten pll)
-            (if lassoc then List.rev l else l) termin in
-        idsl, List.map (fun ((asubst, pl) as x) ->
-	  match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v
-      with Not_found ->
-          anomaly "Inconsistent substitution of recursive notation")
-  | AHole _ -> ([],[[], PatVar (loc,Anonymous)])
-  | t -> error_invalid_pattern_notation loc
-  in aux alias fullsubst a
-
-(* Differentiating between constructors and matching variables *)
-type pattern_qualid_kind =
-  | ConstrPat of constructor * (identifier list *
-      ((identifier * identifier) list * cases_pattern) list) list
-  | VarPat of identifier
-
-let find_constructor ref f aliases pats env =
-  let (loc,qid) = qualid_of_reference ref in
-  let gref =
-    try locate_extended qid
-    with Not_found -> raise (InternalizationError (loc,NotAConstructor ref)) in
-  match gref with
-  | SynDef sp ->
-      let (vars,a) = Syntax_def.search_syntactic_definition sp in
-      (match a with
-       | ARef (ConstructRef cstr) ->
-	   assert (vars=[]);
-	   cstr, [], pats
-       | AApp (ARef (ConstructRef cstr),args) ->
-	   let args = chop_aconstr_constructor loc cstr args in
-	   let nvars = List.length vars in
-	   if List.length pats < nvars then error_not_enough_arguments loc;
-	   let pats1,pats2 = list_chop nvars pats in
-	   let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) vars pats1 in
-	   let idspl1 = List.map (subst_cases_pattern loc Anonymous f (subst,[]) env) args in
-	   cstr, idspl1, pats2
-       | _ -> raise Not_found)
-
-  | TrueGlobal r ->
-      let rec unf = function
-        | ConstRef cst ->
-	    let v = Environ.constant_value (Global.env()) cst in
-	    unf (global_of_constr v)
-        | ConstructRef cstr ->
-	    Dumpglob.add_glob loc r;
-	    cstr, [], pats
-        | _ -> raise Not_found
-      in unf r
+(** Use only when params were NOT asked to the user.
+    @return if letin are included *)
+let check_constructor_length env loc cstr len_pl pl0 =
+  let n = len_pl + List.length pl0 in
+  if Int.equal n (Inductiveops.constructor_nallargs cstr) then false else
+    (Int.equal n (Inductiveops.constructor_nalldecls cstr) ||
+      (error_wrong_numarg_constructor_loc loc env cstr
+         (Inductiveops.constructor_nrealargs cstr)))
+
+let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 =
+  let impl_list = if Int.equal len_pl1 0
+    then select_impargs_size (List.length pl2) impls_st
+    else List.skipn_at_least len_pl1 (select_stronger_impargs impls_st) in
+  let remaining_args = List.fold_left (fun i x -> if is_status_implicit x then i else succ i) in
+  let rec aux i = function
+    |[],l -> let args_len = List.length l + List.length impl_list + len_pl1 in
+	     ((if Int.equal args_len nargs then false
+	      else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i))))
+	       ,l)
+    |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp
+      then let (b,out) = aux i (q,[]) in (b,RCPatAtom(Loc.ghost,None)::out)
+      else fail (remaining_args (len_pl1+i) il)
+    |imp::q,(hh::tt as l) -> if is_status_implicit imp
+      then let (b,out) = aux i (q,l) in (b,RCPatAtom(Loc.ghost,None)::out)
+      else let (b,out) = aux (succ i) (q,tt) in (b,hh::out)
+  in aux 0 (impl_list,pl2)
+
+let add_implicits_check_constructor_length env loc c len_pl1 pl2 =
+  let nargs = Inductiveops.constructor_nallargs c in
+  let nargs' = Inductiveops.constructor_nalldecls c in
+  let impls_st = implicits_of_global (ConstructRef c) in
+  add_implicits_check_length (error_wrong_numarg_constructor_loc loc env c)
+    nargs nargs' impls_st len_pl1 pl2
+
+let add_implicits_check_ind_length env loc c len_pl1 pl2 =
+  let nallargs = inductive_nallargs_env env c in
+  let nalldecls = inductive_nalldecls_env env c in
+  let impls_st = implicits_of_global (IndRef c) in
+  add_implicits_check_length (error_wrong_numarg_inductive_loc loc env c)
+    nallargs nalldecls impls_st len_pl1 pl2
+
+(** Do not raise NotEnoughArguments thanks to preconditions*)
+let chop_params_pattern loc ind args with_letin =
+  let nparams = if with_letin
+    then Inductiveops.inductive_nparamdecls ind
+    else Inductiveops.inductive_nparams ind in
+  assert (nparams <= List.length args);
+  let params,args = List.chop nparams args in
+  List.iter (function PatVar(_,Anonymous) -> ()
+    | PatVar (loc',_) | PatCstr(loc',_,_,_) -> error_parameter_not_implicit loc') params;
+  args
+
+let find_constructor loc add_params ref =
+  let cstr = match ref with
+  | ConstructRef cstr -> cstr
+  | IndRef _ ->
+    let error = str "There is an inductive name deep in a \"in\" clause." in
+    user_err_loc (loc, "find_constructor", error)
+  | ConstRef _ | VarRef _ ->
+    let error = str "This reference is not a constructor." in
+    user_err_loc (loc, "find_constructor", error)
+  in
+  cstr, (function (ind,_ as c) -> match add_params with
+    |Some nb_args ->
+      let nb =
+        if Int.equal nb_args (Inductiveops.constructor_nrealdecls c)
+          then Inductiveops.inductive_nparamdecls ind
+          else Inductiveops.inductive_nparams ind
+      in
+      List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))])
+    |None -> []) cstr
 
 let find_pattern_variable = function
   | Ident (loc,id) -> id
   | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x))
 
-let maybe_constructor ref f aliases env =
-  try
-    let c,idspl1,pl2 = find_constructor ref f aliases [] env in
-    assert (pl2 = []);
-    ConstrPat (c,idspl1)
-  with
-      (* patt var does not exists globally *)
-    | InternalizationError _ -> VarPat (find_pattern_variable ref)
-      (* patt var also exists globally but does not satisfy preconditions *)
-    | (Environ.NotEvaluableConst _ | Not_found) ->
-        if_warn msg_warning (str "pattern " ++ pr_reference ref ++
-              str " is understood as a pattern variable");
-        VarPat (find_pattern_variable ref)
-
-let mustbe_constructor loc ref f aliases patl env =
-  try find_constructor ref f aliases patl env
-  with (Environ.NotEvaluableConst _ | Not_found) ->
-    raise (InternalizationError (loc,NotAConstructor ref))
-
 let sort_fields mode loc l completer =
 (*mode=false if pattern and true if constructor*)
   match l with
@@ -966,18 +975,19 @@ let sort_fields mode loc l completer =
 	      | [] -> (i, acc)
 	      | (Some name) :: b->
 		 (match m with
-		    | [] -> anomaly "Number of projections mismatch"
+		    | [] -> anomaly (Pp.str "Number of projections mismatch")
 		    | (_, regular)::tm ->
 		       let boolean = not regular in
-                       (match global_reference_of_reference refer with
-                       | ConstRef name' when eq_constant name name' ->
+                       begin match global_reference_of_reference refer with
+		       | ConstRef name' when eq_constant name name' ->
 			 if boolean && mode then
 			   user_err_loc (loc, "", str"No local fields allowed in a record construction.")
 			 else build_patt b tm (i + 1) (i, snd acc) (* we found it *)
                        | _ ->
 			  build_patt b tm (if boolean&&mode then i else i + 1)
 			    (if boolean && mode then acc
-			     else fst acc, (i, ConstRef name) :: snd acc)))
+			     else fst acc, (i, ConstRef name) :: snd acc)
+                       end)
 	      | None :: b-> (* we don't want anonymous fields *)
 		 if mode then
 		   user_err_loc (loc, "", str "This record contains anonymous fields.")
@@ -987,9 +997,9 @@ let sort_fields mode loc l completer =
 	  let ind = record.Recordops.s_CONST in
 	  try (* insertion of Constextern.reference_global *)
 	    (record.Recordops.s_EXPECTEDPARAM,
-	     Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef ind)),
+	     Qualid (loc, shortest_qualid_of_global Id.Set.empty (ConstructRef ind)),
 	     build_patt record.Recordops.s_PROJ record.Recordops.s_PROJKIND 1 (0,[]))
-	  with Not_found -> anomaly "Environment corruption for records."
+	  with Not_found -> anomaly (Pp.str "Environment corruption for records.")
 	  in
 	(* now we want to have all fields of the pattern indexed by their place in
 	   the constructor *)
@@ -1032,111 +1042,287 @@ let sort_fields mode loc l completer =
 	Some (nparams, base_constructor,
 	  List.rev (clean_list sorted_indexed_pattern 0 []))
 
-let rec intern_cases_pattern genv env (ids,asubst as aliases) pat =
-  let intern_pat = intern_cases_pattern genv in
-  match pat with
-  | CPatAlias (loc, p, id) ->
-      let aliases' = merge_aliases aliases id in
-      intern_pat env aliases' p
+(** {6 Manage multiple aliases} *)
+
+type alias = {
+  alias_ids : Id.t list;
+  alias_map : Id.t Id.Map.t;
+}
+
+let empty_alias = {
+  alias_ids = [];
+  alias_map = Id.Map.empty;
+}
+
+  (* [merge_aliases] returns the sets of all aliases encountered at this
+     point and a substitution mapping extra aliases to the first one *)
+let merge_aliases aliases id =
+  let alias_ids = aliases.alias_ids @ [id] in
+  let alias_map = match aliases.alias_ids with
+  | [] -> aliases.alias_map
+  | id' :: _ -> Id.Map.add id id' aliases.alias_map
+  in
+  { alias_ids; alias_map; }
+
+let alias_of als = match als.alias_ids with
+| [] -> Anonymous
+| id :: _ -> Name id
+
+let message_redundant_alias id1 id2 =
+  msg_warning
+    (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2)
+
+(** {6 Expanding notations }
+
+    @returns a raw_case_pattern_expr :
+    - no notations and syntactic definition
+    - global reference and identifeir instead of reference
+
+*)
+
+let rec subst_pat_iterator y t p = match p with
+  | RCPatAtom (_,id) ->
+    begin match id with Some x when Id.equal x y -> t | _ -> p end
+  | RCPatCstr (loc,id,l1,l2) ->
+     RCPatCstr (loc,id,List.map (subst_pat_iterator y t) l1,
+	       List.map (subst_pat_iterator y t) l2)
+  | RCPatAlias (l,p,a) -> RCPatAlias (l,subst_pat_iterator y t p,a)
+  | RCPatOr (l,pl) -> RCPatOr (l,List.map (subst_pat_iterator y t) pl)
+
+let drop_notations_pattern looked_for =
+  (* At toplevel, Constructors and Inductives are accepted, in recursive calls
+     only constructor are allowed *)
+  let ensure_kind top loc g =
+    try
+      if top then looked_for g else
+      match g with ConstructRef _ -> () | _ -> raise Not_found
+    with Not_found ->
+      error_invalid_pattern_notation loc
+  in
+  let test_kind top =
+    if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found
+  in
+  let rec drop_syndef top env re pats =
+    let (loc,qid) = qualid_of_reference re in
+    try
+      match locate_extended qid with
+      |SynDef sp ->
+	let (vars,a) = Syntax_def.search_syntactic_definition sp in
+	(match a with
+	| NRef g ->
+	  test_kind top g;
+	  let () = assert (List.is_empty vars) in
+	  let (_,argscs) = find_remaining_scopes [] pats g in
+	  Some (g, [], List.map2 (in_pat_sc env) argscs pats)
+	| NApp (NRef g,[]) -> (* special case : Syndef for @Cstr *)
+	      test_kind top g;
+              let () = assert (List.is_empty vars) in
+	      let (argscs,_) = find_remaining_scopes pats [] g in
+	      Some (g, List.map2 (in_pat_sc env) argscs pats, [])
+	| NApp (NRef g,args) ->
+	      ensure_kind top loc g;
+	      let nvars = List.length vars in
+	      if List.length pats < nvars then error_not_enough_arguments loc;
+	      let pats1,pats2 = List.chop nvars pats in
+	      let subst = make_subst vars pats1 in
+	      let idspl1 = List.map (in_not false loc env (subst, Id.Map.empty) []) args in
+	      let (_,argscs) = find_remaining_scopes pats1 pats2 g in
+	      Some (g, idspl1, List.map2 (in_pat_sc env) argscs pats2)
+	| _ -> raise Not_found)
+      |TrueGlobal g ->
+	  test_kind top g;
+	  Dumpglob.add_glob loc g;
+	  let (_,argscs) = find_remaining_scopes [] pats g in
+	  Some (g,[],List.map2 (fun x -> in_pat false {env with tmp_scope = x}) argscs pats)
+    with Not_found -> None
+  and in_pat top env = function
+    | CPatAlias (loc, p, id) -> RCPatAlias (loc, in_pat top env p, id)
     | CPatRecord (loc, l) ->
-	let sorted_fields = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in
-	let self_patt =
-	  match sorted_fields with
-	    | None -> CPatAtom (loc, None)
-	    | Some (_, head, pl) -> CPatCstr(loc, head, pl)
-	  in
-	intern_pat env aliases self_patt
-  | CPatCstr (loc, head, pl) | CPatCstrExpl (loc, head, pl) ->
-      let c,idslpl1,pl2 = mustbe_constructor loc head intern_pat aliases pl env in
-      check_constructor_length genv loc c idslpl1 pl2;
-      let argscs2 = find_remaining_constructor_scopes idslpl1 pl2 c in
-      let idslpl2 = List.map2 (fun x -> intern_pat {env with tmp_scope = x} ([],[])) argscs2 pl2 in
-      let (ids',pll) = product_of_cases_patterns ids (idslpl1@idslpl2) in
-      let pl' = List.map (fun (asubst,pl) ->
-        (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in
-      ids',pl'
-  | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]))
-      when Bigint.is_strictly_pos p ->
-      intern_pat env aliases (CPatPrim(loc,Numeral(Bigint.neg p)))
-  | CPatNotation (_,"( _ )",([a],[])) ->
-      intern_pat env aliases a
-  | CPatNotation (loc, ntn, fullargs) ->
+      let sorted_fields =
+	sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in
+      begin match sorted_fields with
+	| None -> RCPatAtom (loc, None)
+	| Some (_, head, pl) ->
+	  match drop_syndef top env head pl with
+	    |Some (a,b,c) -> RCPatCstr(loc, a, b, c)
+	    |None -> raise (InternalizationError (loc,NotAConstructor head))
+      end
+    | CPatCstr (loc, head, [], pl) ->
+      begin
+	match drop_syndef top env head pl with
+	  | Some (a,b,c) -> RCPatCstr(loc, a, b, c)
+	  | None -> raise (InternalizationError (loc,NotAConstructor head))
+      end
+    | CPatCstr (loc, r, expl_pl, pl) ->
+      let g = try
+		      (locate (snd (qualid_of_reference r)))
+	    with Not_found ->
+ 	      raise (InternalizationError (loc,NotAConstructor r)) in
+      let (argscs1,argscs2) = find_remaining_scopes expl_pl pl g in
+      RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl, List.map2 (in_pat_sc env) argscs2 pl)
+    | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]),[])
+	when Bigint.is_strictly_pos p ->
+      fst (Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p))
+	     (env.tmp_scope,env.scopes))
+    | CPatNotation (_,"( _ )",([a],[]),[]) ->
+      in_pat top env a
+    | CPatNotation (loc, ntn, fullargs,extrargs) ->
       let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in
       let ((ids',c),df) = Notation.interp_notation loc ntn (env.tmp_scope,env.scopes) in
       let (ids',idsl',_) = split_by_type ids' in
       Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df;
-      let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in
-      let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in
-      let ids'',pl =
-	subst_cases_pattern loc (alias_of aliases) intern_pat (subst,substlist)
-	  env c
-      in ids@ids'', pl
-  | CPatPrim (loc, p) ->
-      let a = alias_of aliases in
-      let (c,_) = Notation.interp_prim_token_cases_pattern loc p a
-	(env.tmp_scope,env.scopes) in
-      (ids,[asubst,c])
-  | CPatDelimiters (loc, key, e) ->
-      intern_pat {env with scopes=find_delimiters_scope loc key::env.scopes;
-		    tmp_scope = None} aliases e
-  | CPatAtom (loc, Some head) ->
-      (match maybe_constructor head intern_pat aliases env with
-	 | ConstrPat (c,idspl) ->
-	     check_constructor_length genv loc c idspl [];
-	     let (ids',pll) = product_of_cases_patterns ids idspl in
-	     (ids,List.map (fun (asubst,pl) ->
-	       (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll)
-	 | VarPat id ->
-	     let ids,asubst = merge_aliases aliases id in
-	     (ids,[asubst, PatVar (loc,alias_of (ids,asubst))]))
-  | CPatAtom (loc, None) ->
-      (ids,[asubst, PatVar (loc,alias_of aliases)])
-  | CPatOr (loc, pl) ->
-      assert (pl <> []);
-      let pl' = List.map (intern_pat env aliases) pl in
+      let substlist = make_subst idsl' argsl in
+      let subst = make_subst ids' args in
+      in_not top loc env (subst,substlist) extrargs c
+    | CPatDelimiters (loc, key, e) ->
+      in_pat top {env with scopes=find_delimiters_scope loc key::env.scopes;
+	tmp_scope = None} e
+    | CPatPrim (loc,p) -> fst (Notation.interp_prim_token_cases_pattern_expr loc (test_kind false) p
+				 (env.tmp_scope,env.scopes))
+    | CPatAtom (loc, Some id) ->
+      begin
+	match drop_syndef top env id [] with
+	  |Some (a,b,c) -> RCPatCstr (loc, a, b, c)
+	  |None -> RCPatAtom (loc, Some (find_pattern_variable id))
+      end
+    | CPatAtom (loc,None) -> RCPatAtom (loc,None)
+    | CPatOr (loc, pl) ->
+      RCPatOr (loc,List.map (in_pat top env) pl)
+  and in_pat_sc env x = in_pat false {env with tmp_scope = x}
+  and in_not top loc env (subst,substlist as fullsubst) args = function
+    | NVar id ->
+      let () = assert (List.is_empty args) in
+      begin
+	(* subst remembers the delimiters stack in the interpretation *)
+	(* of the notations *)
+	try
+	  let (a,(scopt,subscopes)) = Id.Map.find id subst in
+	  in_pat top {env with scopes=subscopes@env.scopes;
+	    tmp_scope = scopt} a
+	with Not_found ->
+	  if Id.equal id ldots_var then RCPatAtom (loc,Some id) else
+	    anomaly (str "Unbound pattern notation variable: " ++ Id.print id)
+      end
+    | NRef g ->
+      ensure_kind top loc g;
+      let (_,argscs) = find_remaining_scopes [] args g in
+      RCPatCstr (loc, g, [], List.map2 (in_pat_sc env) argscs args)
+    | NApp (NRef g,pl) ->
+      ensure_kind top loc g;
+      let (argscs1,argscs2) = find_remaining_scopes pl args g in
+      RCPatCstr (loc, g,
+		 List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl,
+		 List.map2 (in_pat_sc env) argscs2 args)
+    | NList (x,_,iter,terminator,lassoc) ->
+      let () = assert (List.is_empty args) in
+      (try
+         (* All elements of the list are in scopes (scopt,subscopes) *)
+	 let (l,(scopt,subscopes)) = Id.Map.find x substlist in
+         let termin = in_not top loc env fullsubst [] terminator in
+	 List.fold_right (fun a t ->
+           let nsubst = Id.Map.add x (a, (scopt, subscopes)) subst in
+           let u = in_not false loc env (nsubst, substlist) [] iter in
+           subst_pat_iterator ldots_var t u)
+           (if lassoc then List.rev l else l) termin
+       with Not_found ->
+         anomaly (Pp.str "Inconsistent substitution of recursive notation"))
+    | NHole _ ->
+      let () = assert (List.is_empty args) in
+      RCPatAtom (loc, None)
+    | t -> error_invalid_pattern_notation loc
+  in in_pat true
+
+let rec intern_pat genv aliases pat =
+  let intern_cstr_with_all_args loc c with_letin idslpl1 pl2 =
+    let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in
+    let (ids',pll) = product_of_cases_patterns aliases.alias_ids (idslpl1@idslpl2) in
+    let pl' = List.map (fun (asubst,pl) ->
+      (asubst, PatCstr (loc,c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in
+    ids',pl' in
+  match pat with
+    | RCPatAlias (loc, p, id) ->
+      let aliases' = merge_aliases aliases id in
+      intern_pat genv aliases' p
+    | RCPatCstr (loc, head, expl_pl, pl) ->
+      if !oldfashion_patterns then
+        let len = if List.is_empty expl_pl then Some (List.length pl) else None in
+	let c,idslpl1 = find_constructor loc len head in
+	let with_letin =
+	  check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in
+	intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl)
+      else
+	let c,idslpl1 = find_constructor loc None head in
+	let with_letin, pl2 =
+	  add_implicits_check_constructor_length genv loc c (List.length idslpl1 + List.length expl_pl) pl in
+	intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2)
+    | RCPatAtom (loc, Some id) ->
+      let aliases = merge_aliases aliases id in
+      (aliases.alias_ids,[aliases.alias_map, PatVar (loc, alias_of aliases)])
+    | RCPatAtom (loc, None) ->
+      let { alias_ids = ids; alias_map = asubst; } = aliases in
+      (ids, [asubst, PatVar (loc, alias_of aliases)])
+    | RCPatOr (loc, pl) ->
+      assert (not (List.is_empty pl));
+      let pl' = List.map (intern_pat genv aliases) pl in
       let (idsl,pl') = List.split pl' in
       let ids = List.hd idsl in
       check_or_pat_variables loc ids (List.tl idsl);
       (ids,List.flatten pl')
 
+let intern_cases_pattern genv env aliases pat =
+  intern_pat genv aliases
+    (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) env pat)
+
+let intern_ind_pattern genv env pat =
+  let no_not =
+    try
+      drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) env pat
+    with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type loc
+ in
+  match no_not with
+    | RCPatCstr (loc, head,expl_pl, pl) ->
+      let c = (function IndRef ind -> ind
+	|_ -> error_bad_inductive_type loc) head in
+      let with_letin, pl2 = add_implicits_check_ind_length genv loc c
+	(List.length expl_pl) pl in
+      let idslpl1 = List.rev_map (intern_pat genv empty_alias) expl_pl in
+      let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in
+      (with_letin,
+       match product_of_cases_patterns [] (List.rev_append idslpl1 idslpl2) with
+	 |_,[_,pl] ->
+	   (c,chop_params_pattern loc c pl with_letin)
+	 |_ -> error_bad_inductive_type loc)
+    | x -> error_bad_inductive_type (raw_cases_pattern_expr_loc x)
+
 (**********************************************************************)
 (* Utilities for application                                          *)
 
 let merge_impargs l args =
+  let test x = function
+  | (_, Some (_, y)) -> explicitation_eq x y
+  | _ -> false
+  in
   List.fold_right (fun a l ->
     match a with
       | (_,Some (_,(ExplByName id as x))) when
-	  List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l
+	  List.exists (test x) args -> l
       | _ -> a::l)
     l args
 
-let check_projection isproj nargs r =
-  match (r,isproj) with
-  | GRef (loc, ref), Some _ ->
-      (try
-	let n = Recordops.find_projection_nparams ref + 1 in
-	if nargs <> n then
-	  user_err_loc (loc,"",str "Projection does not have the right number of explicit parameters.");
-      with Not_found ->
-	user_err_loc
-	(loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection."))
-  | _, Some _ -> user_err_loc (loc_of_glob_constr r, "", str "Not a projection.")
-  | _, None -> ()
-
 let get_implicit_name n imps =
   Some (Impargs.name_of_implicit (List.nth imps (n-1)))
 
 let set_hole_implicit i b = function
-  | GRef (loc,r) | GApp (_,GRef (loc,r),_) -> (loc,Evd.ImplicitArg (r,i,b))
-  | GVar (loc,id) -> (loc,Evd.ImplicitArg (VarRef id,i,b))
-  | _ -> anomaly "Only refs have implicits"
+  | GRef (loc,r,_) | GApp (_,GRef (loc,r,_),_) -> (loc,Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None)
+  | GVar (loc,id) -> (loc,Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None)
+  | _ -> anomaly (Pp.str "Only refs have implicits")
 
 let exists_implicit_name id =
-  List.exists (fun imp -> is_status_implicit imp & id = name_of_implicit imp)
+  List.exists (fun imp -> is_status_implicit imp && Id.equal id (name_of_implicit imp))
 
 let extract_explicit_arg imps args =
   let rec aux = function
-  | [] -> [],[]
+  | [] -> Id.Map.empty, []
   | (a,e)::l ->
       let (eargs,rargs) = aux l in
       match e with
@@ -1147,7 +1333,7 @@ let extract_explicit_arg imps args =
 	      if not (exists_implicit_name id imps) then
 		user_err_loc
 		  (loc,"",str "Wrong argument name: " ++ pr_id id ++ str ".");
-	      if List.mem_assoc id eargs then
+	      if Id.Map.mem id eargs then
 		user_err_loc (loc,"",str "Argument name " ++ pr_id id
 		++ str " occurs more than once.");
 	      id
@@ -1161,29 +1347,30 @@ let extract_explicit_arg imps args =
 		  user_err_loc
 		    (loc,"",str"Wrong argument position: " ++ int p ++ str ".")
 	      in
-	      if List.mem_assoc id eargs then
+	      if Id.Map.mem id eargs then
 		user_err_loc (loc,"",str"Argument at position " ++ int p ++
 		  str " is mentioned more than once.");
 	      id in
-	  ((id,(loc,a))::eargs,rargs)
+	  (Id.Map.add id (loc, a) eargs, rargs)
   in aux args
 
 (**********************************************************************)
 (* Main loop                                                          *)
 
-let internalize sigma globalenv env allow_patvar lvar c =
+let internalize globalenv env allow_patvar lvar c =
   let rec intern env = function
-    | CRef ref as x ->
+    | CRef (ref,us) as x ->
 	let (c,imp,subscopes,l),_ =
-	  intern_applied_reference intern env (Environ.named_context globalenv) lvar [] ref in
-	(match intern_impargs c env imp subscopes l with
-           | [] -> c
-           | l -> GApp (constr_loc x, c, l))
+	  intern_applied_reference intern env (Environ.named_context globalenv) 
+	    lvar us [] ref 
+	in
+	  apply_impargs c env imp subscopes l (constr_loc x)
+
     | CFix (loc, (locid,iddef), dl) ->
         let lf = List.map (fun ((_, id),_,_,_,_) -> id) dl in
         let dl = Array.of_list dl in
 	let n =
-	  try list_index0 iddef lf
+	  try List.index0 Id.equal iddef lf
           with Not_found ->
 	    raise (InternalizationError (locid,UnboundFixName (false,iddef)))
 	in
@@ -1194,7 +1381,7 @@ let internalize sigma globalenv env allow_patvar lvar c =
 	       let (env',rbefore) =
 		 List.fold_left intern_local_binder (env,[]) before in
 	       let ro = f (intern env') in
-	       let n' = Option.map (fun _ -> List.length rbefore) n in
+	       let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in
 		 n', ro, List.fold_left intern_local_binder (env',rbefore) after
 	     in
 	     let n, ro, (env',rbl) =
@@ -1207,47 +1394,45 @@ let internalize sigma globalenv env allow_patvar lvar c =
 		   intern_ro_arg (fun f -> GMeasureRec (f m, Option.map f r))
 	     in
 	       ((n, ro), List.rev rbl, intern_type env' ty, env')) dl in
-        let idl = array_map2 (fun (_,_,_,_,bd) (a,b,c,env') ->
-	     let env'' = list_fold_left_i (fun i en name -> 
+        let idl = Array.map2 (fun (_,_,_,_,bd) (a,b,c,env') ->
+	     let env'' = List.fold_left_i (fun i en name -> 
 					     let (_,bli,tyi,_) = idl_temp.(i) in
-					     let fix_args = (List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli) in
+					     let fix_args = (List.map (fun (_,(na, bk, _, _)) -> (build_impls bk na)) bli) in
 					       push_name_env lvar (impls_type_list ~args:fix_args tyi)
-					    en (dummy_loc, Name name)) 0 env' lf in
+					    en (Loc.ghost, Name name)) 0 env' lf in
              (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in
 	GRec (loc,GFix
 	      (Array.map (fun (ro,_,_,_) -> ro) idl,n),
               Array.of_list lf,
-              Array.map (fun (_,bl,_,_) -> bl) idl,
+              Array.map (fun (_,bl,_,_) -> List.map snd bl) idl,
               Array.map (fun (_,_,ty,_) -> ty) idl,
               Array.map (fun (_,_,_,bd) -> bd) idl)
     | CCoFix (loc, (locid,iddef), dl) ->
         let lf = List.map (fun ((_, id),_,_,_) -> id) dl in
         let dl = Array.of_list dl in
 	let n =
-          try list_index0 iddef lf
+          try List.index0 Id.equal iddef lf
           with Not_found ->
 	    raise (InternalizationError (locid,UnboundFixName (true,iddef)))
 	in
         let idl_tmp = Array.map
-          (fun (id,bl,ty,_) ->
+          (fun ((loc,id),bl,ty,_) ->
             let (env',rbl) =
               List.fold_left intern_local_binder (env,[]) bl in
             (List.rev rbl,
              intern_type env' ty,env')) dl in
-	let idl = array_map2 (fun (_,_,_,bd) (b,c,env') ->
-	     let env'' = list_fold_left_i (fun i en name ->
+	let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') ->
+	     let env'' = List.fold_left_i (fun i en name ->
 					     let (bli,tyi,_) = idl_tmp.(i) in
-					     let cofix_args =  List.map (fun (na, bk, _, _) -> (build_impls bk na)) bli in
+					     let cofix_args =  List.map (fun (_, (na, bk, _, _)) -> (build_impls bk na)) bli in
 	       push_name_env lvar (impls_type_list ~args:cofix_args tyi)
-					    en (dummy_loc, Name name)) 0 env' lf in
+					    en (Loc.ghost, Name name)) 0 env' lf in
              (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in
 	GRec (loc,GCoFix n,
               Array.of_list lf,
-              Array.map (fun (bl,_,_) -> bl) idl,
+              Array.map (fun (bl,_,_) -> List.map snd bl) idl,
               Array.map (fun (_,ty,_) -> ty) idl,
               Array.map (fun (_,_,bd) -> bd) idl)
-    | CArrow (loc,c1,c2) ->
-        GProd (loc, Anonymous, Explicit, intern_type env c1, intern_type env c2)
     | CProdN (loc,[],c2) ->
         intern_type env c2
     | CProdN (loc,(nal,bk,ty)::bll,c2) ->
@@ -1273,100 +1458,154 @@ let internalize sigma globalenv env allow_patvar lvar c =
     | CDelimiters (loc, key, e) ->
 	intern {env with tmp_scope = None;
 		  scopes = find_delimiters_scope loc key :: env.scopes} e
-    | CAppExpl (loc, (isproj,ref), args) ->
+    | CAppExpl (loc, (isproj,ref,us), args) ->
         let (f,_,args_scopes,_),args =
 	  let args = List.map (fun a -> (a,None)) args in
-	  intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref in
-	check_projection isproj (List.length args) f;
-	(* Rem: GApp(_,f,[]) stands for @f *)
-	GApp (loc, f, intern_args env args_scopes (List.map fst args))
+	  intern_applied_reference intern env (Environ.named_context globalenv) 
+	    lvar us args ref 
+	in
+	  (* Rem: GApp(_,f,[]) stands for @f *)
+	  GApp (loc, f, intern_args env args_scopes (List.map fst args))
+
     | CApp (loc, (isproj,f), args) ->
-        let isproj,f,args = match f with
+        let f,args = match f with
           (* Compact notations like "t.(f args') args" *)
-          | CApp (_,(Some _,f), args') when isproj=None -> isproj,f,args'@args
+          | CApp (_,(Some _,f), args') when not (Option.has_some isproj) -> 
+	    f,args'@args
           (* Don't compact "(f args') args" to resolve implicits separately *)
-          | _ -> isproj,f,args in
+          | _ -> f,args in
 	let (c,impargs,args_scopes,l),args =
           match f with
-            | CRef ref -> intern_applied_reference intern env (Environ.named_context globalenv) lvar args ref
+            | CRef (ref,us) -> 
+	       intern_applied_reference intern env
+		 (Environ.named_context globalenv) lvar us args ref
             | CNotation (loc,ntn,([],[],[])) ->
                 let c = intern_notation intern env lvar loc ntn ([],[],[]) in
-                find_appl_head_data c, args
+                let x, impl, scopes, l = find_appl_head_data c in
+		  (x,impl,scopes,l), args
             | x -> (intern env f,[],[],[]), args in
-	let args =
-          intern_impargs c env impargs args_scopes (merge_impargs l args) in
-	check_projection isproj (List.length args) c;
-	(match c with
-          (* Now compact "(f args') args" *)
-	  | GApp (loc', f', args') -> GApp (join_loc loc' loc, f',args'@args)
-	  | _ -> GApp (loc, c, args))
+          apply_impargs c env impargs args_scopes 
+	    (merge_impargs l args) loc
+
     | CRecord (loc, _, fs) ->
 	let cargs =
 	  sort_fields true loc fs
-	    (fun k l -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: l)
-	  in
+	    (fun k l -> CHole (loc, Some (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None) :: l)
+	in
 	begin
 	  match cargs with
 	    | None -> user_err_loc (loc, "intern", str"No constructor inference.")
 	    | Some (n, constrname, args) ->
-		let pars = list_make n (CHole (loc, None)) in
-		let app = CAppExpl (loc, (None, constrname), List.rev_append pars args) in
+		let pars = List.make n (CHole (loc, None, Misctypes.IntroAnonymous, None)) in
+                let app = CAppExpl (loc, (None, constrname,None), List.rev_append pars args) in
 	  intern env app
 	end
     | CCases (loc, sty, rtnpo, tms, eqns) ->
-        let tms,env' = List.fold_right
-          (fun citm (inds,env) ->
-	    let (tm,ind),nal = intern_case_item env citm in
-	    (tm,ind)::inds,List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal)
-	  tms ([],env) in
-        let rtnpo = Option.map (intern_type env') rtnpo in
+      let as_in_vars = List.fold_left (fun acc (_,(na,inb)) ->
+	Option.fold_left (fun x tt -> List.fold_right Id.Set.add (ids_of_cases_indtype tt) x)
+	  (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Id.Set.add y' x |_ -> x) acc na)
+	  inb) Id.Set.empty tms in
+      (* as, in & return vars *)
+      let forbidden_vars = Option.cata free_vars_of_constr_expr as_in_vars rtnpo in
+      let tms,ex_ids,match_from_in = List.fold_right
+	(fun citm (inds,ex_ids,matchs) ->
+	  let ((tm,ind),extra_id,match_td) = intern_case_item env forbidden_vars citm in
+	  (tm,ind)::inds, Option.fold_right Id.Set.add extra_id ex_ids, List.rev_append match_td matchs)
+	    tms ([],Id.Set.empty,[]) in
+      let env' = Id.Set.fold
+	(fun var bli -> push_name_env lvar (Variable,[],[],[]) bli (Loc.ghost,Name var))
+	(Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in
+      (* PatVars before a real pattern do not need to be matched *)
+      let stripped_match_from_in = let rec aux = function
+	|[] -> []
+	|(_,PatVar _) :: q -> aux q
+	|l -> l
+				   in aux match_from_in in
+        let rtnpo = match stripped_match_from_in with
+	  | [] -> Option.map (intern_type env') rtnpo (* Only PatVar in "in" clauses *)
+	  | l -> let thevars,thepats=List.split l in
+		 Some (
+		   GCases(Loc.ghost,Term.RegularStyle,(* Some (GSort (Loc.ghost,GType None)) *)None, (* "return Type" *)
+			  List.map (fun id -> GVar (Loc.ghost,id),(Name id,None)) thevars, (* "match v1,..,vn" *)
+			  [Loc.ghost,[],thepats, (* "|p1,..,pn" *)
+			   Option.cata (intern_type env') (GHole(Loc.ghost,Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) rtnpo; (* "=> P" is there were a P "=> _" else *)
+			   Loc.ghost,[],List.make (List.length thepats) (PatVar(Loc.ghost,Anonymous)), (* "|_,..,_" *)
+			   GHole(Loc.ghost,Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None) (* "=> _" *)]))
+	in
         let eqns' = List.map (intern_eqn (List.length tms) env) eqns in
 	GCases (loc, sty, rtnpo, tms, List.flatten eqns')
     | CLetTuple (loc, nal, (na,po), b, c) ->
 	let env' = reset_tmp_scope env in
-        let ((b',(na',_)),ids) = intern_case_item env' (b,(na,None)) in
-        let p' = Option.map (fun p ->
-          let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) env ids in
-	  intern_type env'' p) po in
+	(* "in" is None so no match to add *)
+        let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in
+        let p' = Option.map (fun u ->
+	  let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env')
+	    (Loc.ghost,na') in
+	  intern_type env'' u) po in
         GLetTuple (loc, List.map snd nal, (na', p'), b',
                    intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c)
     | CIf (loc, c, (na,po), b1, b2) ->
-	let env' = reset_tmp_scope env in
-        let ((c',(na',_)),ids) = intern_case_item env' (c,(na,None)) in
-        let p' = Option.map (fun p ->
-          let env'' = List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) ids in
+      let env' = reset_tmp_scope env in
+      let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *)
+      let p' = Option.map (fun p ->
+          let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env)
+	    (Loc.ghost,na') in
 	  intern_type env'' p) po in
         GIf (loc, c', (na', p'), intern env b1, intern env b2)
-    | CHole (loc, k) ->
-	GHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true))
+    | CHole (loc, k, naming, solve) ->
+        let k = match k with
+        | None -> Evar_kinds.QuestionMark (Evar_kinds.Define true)
+        | Some k -> k
+        in
+        let solve = match solve with
+        | None -> None
+        | Some gen ->
+          let (ltacvars, ntnvars) = lvar in
+          let ntnvars = Id.Map.domain ntnvars in
+          let lvars = Id.Set.union ltacvars.ltac_bound ltacvars.ltac_vars in
+          let lvars = Id.Set.union lvars ntnvars in
+          let lvars = Id.Set.union lvars env.ids in
+          let ist = {
+            Genintern.ltacvars = lvars;
+            ltacrecvars = Id.Map.empty;
+            genv = globalenv;
+          } in
+          let (_, glb) = Genintern.generic_intern ist gen in
+          Some glb
+        in
+	GHole (loc, k, naming, solve)
+    (* Parsing pattern variables *)
     | CPatVar (loc, n) when allow_patvar ->
-	GPatVar (loc, n)
-    | CPatVar (loc, _) ->
-	raise (InternalizationError (loc,IllegalMetavariable))
+	GPatVar (loc, (true,n))
+    | CEvar (loc, n, []) when allow_patvar ->
+	GPatVar (loc, (false,n))
+    (* end *)
+    (* Parsing existential variables *)
     | CEvar (loc, n, l) ->
-	GEvar (loc, n, Option.map (List.map (intern env)) l)
+	GEvar (loc, n, List.map (on_snd (intern env)) l)
+    | CPatVar (loc, _) ->
+        raise (InternalizationError (loc,IllegalMetavariable))
+    (* end *)
     | CSort (loc, s) ->
 	GSort(loc,s)
-    | CCast (loc, c1, CastConv (k, c2)) ->
-	GCast (loc,intern env c1, CastConv (k, intern_type env c2))
-    | CCast (loc, c1, CastCoerce) ->
-	GCast (loc,intern env c1, CastCoerce)
+    | CCast (loc, c1, c2) ->
+        GCast (loc,intern env c1, Miscops.map_cast_type (intern_type env) c2)
 
   and intern_type env = intern (set_type_scope env)
 
   and intern_local_binder env bind =
-    intern_local_binder_aux intern intern_type lvar env bind
+    intern_local_binder_aux intern lvar env bind
 
   (* Expands a multiple pattern into a disjunction of multiple patterns *)
   and intern_multiple_pattern env n (loc,pl) =
     let idsl_pll =
-      List.map (intern_cases_pattern globalenv {env with tmp_scope = None} ([],[])) pl in
+      List.map (intern_cases_pattern globalenv {env with tmp_scope = None} empty_alias) pl in
     check_number_of_pattern loc n pl;
     product_of_cases_patterns [] idsl_pll
 
   (* Expands a disjunction of multiple pattern *)
   and intern_disjunctive_multiple_pattern env loc n mpl =
-    assert (mpl <> []);
+    assert (not (List.is_empty mpl));
     let mpl' = List.map (intern_multiple_pattern env n) mpl in
     let (idsl,mpl') = List.split mpl' in
     let ids = List.hd idsl in
@@ -1378,91 +1617,77 @@ let internalize sigma globalenv env allow_patvar lvar c =
     let eqn_ids,pll = intern_disjunctive_multiple_pattern env loc n lhs in
     (* Linearity implies the order in ids is irrelevant *)
     check_linearity lhs eqn_ids;
-    let env_ids = List.fold_right Idset.add eqn_ids env.ids in
+    let env_ids = List.fold_right Id.Set.add eqn_ids env.ids in
     List.map (fun (asubst,pl) ->
       let rhs = replace_vars_constr_expr asubst rhs in
-      List.iter message_redundant_alias asubst;
+      Id.Map.iter message_redundant_alias asubst;
       let rhs' = intern {env with ids = env_ids} rhs in
       (loc,eqn_ids,pl,rhs')) pll
 
-  and intern_case_item env (tm,(na,t)) =
+  and intern_case_item env forbidden_names_for_gen (tm,(na,t)) =
+    (*the "match" part *)
     let tm' = intern env tm in
-    let ids,typ = match t with
+    (* the "as" part *)
+    let extra_id,na = match tm', na with
+      | GVar (loc,id), None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id)
+      | GRef (loc, VarRef id, _), None -> Some id,(loc,Name id)
+      | _, None -> None,(Loc.ghost,Anonymous)
+      | _, Some (loc,na) -> None,(loc,na) in
+    (* the "in" part *)
+    let match_td,typ = match t with
     | Some t ->
 	let tids = ids_of_cases_indtype t in
-	let tids = List.fold_right Idset.add tids Idset.empty in
-	let t = intern_type {env with ids = tids; tmp_scope = None} t in
-	let loc,ind,l = match t with
-	    | GRef (loc,IndRef ind) -> (loc,ind,[])
-	    | GApp (loc,GRef (_,IndRef ind),l) -> (loc,ind,l)
-	    | _ -> error_bad_inductive_type (loc_of_glob_constr t) in
-	let nparams, nrealargs = inductive_nargs globalenv ind in
-	let nindargs = nparams + nrealargs in
-	if List.length l <> nindargs then
-	  error_wrong_numarg_inductive_loc loc globalenv ind nindargs;
-	let nal = List.map (function
-	  | GHole (loc,_) -> loc,Anonymous
-	  | GVar (loc,id) -> loc,Name id
-	  | c -> user_err_loc (loc_of_glob_constr c,"",str "Not a name.")) l in
-	let parnal,realnal = list_chop nparams nal in
-	if List.exists (fun (_,na) -> na <> Anonymous) parnal then
-	  error_inductive_parameter_not_implicit loc;
-	realnal, Some (loc,ind,nparams,List.map snd realnal)
+	let tids = List.fold_right Id.Set.add tids Id.Set.empty in
+	let with_letin,(ind,l) = intern_ind_pattern globalenv {env with ids = tids; tmp_scope = None} t in
+	let (mib,mip) = Inductive.lookup_mind_specif globalenv ind in
+	let nparams = (List.length (mib.Declarations.mind_params_ctxt)) in
+	(* for "in Vect n", we answer (["n","n"],[(loc,"n")])
+
+	   for "in Vect (S n)", we answer ((match over "m", relevant branch is "S
+	   n"), abstract over "m") = ([("m","S n")],[(loc,"m")]) where "m" is
+	   generated from the canonical name of the inductive and outside of
+	   {forbidden_names_for_gen} *)
+	let (match_to_do,nal) =
+	  let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc =
+	    let add_name l = function
+	      |_,Anonymous -> l
+	      |loc,(Name y as x) -> (y,PatVar(loc,x)) :: l in
+	    match case_rel_ctxt,arg_pats with
+	      (* LetIn in the rel_context *)
+	      |(_,Some _,_)::t, l when not with_letin ->
+		canonize_args t l forbidden_names match_acc ((Loc.ghost,Anonymous)::var_acc)
+	      |[],[] ->
+		(add_name match_acc na, var_acc)
+	      |_::t,PatVar (loc,x)::tt ->
+		canonize_args t tt forbidden_names
+		  (add_name match_acc (loc,x)) ((loc,x)::var_acc)
+	      |(cano_name,_,ty)::t,c::tt ->
+		let fresh =
+		  Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names ty in
+		canonize_args t tt (fresh::forbidden_names)
+		  ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc)
+	      |_ -> assert false in
+	  let _,args_rel =
+	    List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in
+	  canonize_args args_rel l (Id.Set.elements forbidden_names_for_gen) [] [] in
+	match_to_do, Some (cases_pattern_expr_loc t,ind,List.rev_map snd nal)
     | None ->
-	[], None in
-    let na = match tm', na with
-      | GVar (loc,id), None when not (List.mem_assoc id (snd lvar)) ->
-          loc,Name id
-      | GRef (loc, VarRef id), None -> loc,Name id
-      | _, None -> dummy_loc,Anonymous
-      | _, Some (loc,na) -> loc,na in
-    (tm',(snd na,typ)), na::ids
+      [], None in
+    (tm',(snd na,typ)), extra_id, match_td
 
   and iterate_prod loc2 env bk ty body nal =
-    let default env bk = function
-    | (loc1,na)::nal' as nal ->
-	if nal' <> [] then check_capture loc1 ty na;
-        let ty = intern_type env ty in
-        let impls = impls_type_list ty in
-	let env = List.fold_left (push_name_env lvar impls) env nal in
-        List.fold_right (fun (loc,na) c ->
-          GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
-          nal (intern_type env body)
-    | [] -> assert false
-    in
-      match bk with
-	| Default b -> default env b nal
-	| Generalized (b,b',t) ->
-	    let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
-	    let body = intern_type env body in
-	      it_mkGProd ibind body
+    let env, bl = intern_assumption intern lvar env nal bk ty in
+    it_mkGProd loc2 bl (intern_type env body)
 
   and iterate_lam loc2 env bk ty body nal =
-    let default env bk = function
-    | (loc1,na)::nal' as nal ->
-        if nal' <> [] then check_capture loc1 ty na;
-        let ty = intern_type env ty in
-        let impls = impls_type_list ty in
-	let env = List.fold_left (push_name_env lvar impls) env nal in
-        List.fold_right (fun (loc,na) c ->
-          GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
-          nal (intern env body)
-    | [] -> assert false
-    in match bk with
-      | Default b -> default env b nal
-      | Generalized (b, b', t) ->
-	  let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
-	  let body = intern env body in
-	    it_mkGLambda ibind body
+    let env, bl = intern_assumption intern lvar env nal bk ty in
+    it_mkGLambda loc2 bl (intern env body)
 
   and intern_impargs c env l subscopes args =
-    let l = select_impargs_size (List.length args) l in
     let eargs, rargs = extract_explicit_arg l args in
     if !parsing_explicit then
-      if eargs <> [] then
-        error "Arguments given by name or position not supported in explicit mode."
-      else
-        intern_args env subscopes rargs
+      if Id.Map.is_empty eargs then intern_args env subscopes rargs
+      else error "Arguments given by name or position not supported in explicit mode."
     else
     let rec aux n impl subscopes eargs rargs =
       let (enva,subscopes') = apply_scope_env env subscopes in
@@ -1470,11 +1695,11 @@ let internalize sigma globalenv env allow_patvar lvar c =
       | (imp::impl', rargs) when is_status_implicit imp ->
 	  begin try
 	    let id = name_of_implicit imp in
-	    let (_,a) = List.assoc id eargs in
-	    let eargs' = List.remove_assoc id eargs in
+	    let (_,a) = Id.Map.find id eargs in
+	    let eargs' = Id.Map.remove id eargs in
 	    intern enva a :: aux (n+1) impl' subscopes' eargs' rargs
 	  with Not_found ->
-	  if rargs=[] & eargs=[] & not (maximal_insertion_of imp) then
+	  if List.is_empty rargs && Id.Map.is_empty eargs && not (maximal_insertion_of imp) then
             (* Less regular arguments than expected: complete *)
             (* with implicit arguments if maximal insertion is set *)
 	    []
@@ -1485,17 +1710,28 @@ let internalize sigma globalenv env allow_patvar lvar c =
       | (imp::impl', a::rargs') ->
 	  intern enva a :: aux (n+1) impl' subscopes' eargs rargs'
       | (imp::impl', []) ->
-	  if eargs <> [] then
-	    (let (id,(loc,_)) = List.hd eargs in
+	  if not (Id.Map.is_empty eargs) then
+	    (let (id,(loc,_)) = Id.Map.choose eargs in
 	       user_err_loc (loc,"",str "Not enough non implicit \
 	    arguments to accept the argument bound to " ++
 		 pr_id id ++ str"."));
 	  []
       | ([], rargs) ->
-	  assert (eargs = []);
+	  assert (Id.Map.is_empty eargs);
 	  intern_args env subscopes rargs
     in aux 1 l subscopes eargs rargs
 
+  and apply_impargs c env imp subscopes l loc = 
+    let imp = select_impargs_size (List.length l) imp in
+    let l = intern_impargs c env imp subscopes l in
+      smart_gapp c loc l
+
+  and smart_gapp f loc = function
+    | [] -> f
+    | l -> match f with 
+      | GApp (loc', g, args) -> GApp (Loc.merge loc' loc, g, args@l)
+      | _ -> GApp (Loc.merge (loc_of_glob_constr f) loc, f, l)
+      
   and intern_args env subscopes = function
     | [] -> []
     | a::args ->
@@ -1515,29 +1751,38 @@ let internalize sigma globalenv env allow_patvar lvar c =
 (**************************************************************************)
 
 let extract_ids env =
-  List.fold_right Idset.add
+  List.fold_right Id.Set.add
     (Termops.ids_of_rel_context (Environ.rel_context env))
-    Idset.empty
+    Id.Set.empty
+
+let scope_of_type_kind = function
+  | IsType -> Some Notation.type_scope
+  | OfType typ -> compute_type_scope typ
+  | WithoutTypeConstraint -> None
+
+let empty_ltac_sign = {
+  ltac_vars = Id.Set.empty;
+  ltac_bound = Id.Set.empty;
+}
 
-let intern_gen isarity sigma env
-               ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
+let intern_gen kind env
+               ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=empty_ltac_sign)
                c =
-  let tmp_scope =
-    if isarity then Some Notation.type_scope else None in
-    internalize sigma env {ids = extract_ids env; unb = false;
-			   tmp_scope = tmp_scope; scopes = [];
-			  impls = impls}
-      allow_patvar (ltacvars, []) c
+  let tmp_scope = scope_of_type_kind kind in
+  internalize env {ids = extract_ids env; unb = false;
+		         tmp_scope = tmp_scope; scopes = [];
+			 impls = impls}
+    allow_patvar (ltacvars, Id.Map.empty) c
 
-let intern_constr sigma env c = intern_gen false sigma env c
+let intern_constr env c = intern_gen WithoutTypeConstraint env c
 
-let intern_type sigma env c = intern_gen true sigma env c
+let intern_type env c = intern_gen IsType env c
 
 let intern_pattern globalenv patt =
   try
     intern_cases_pattern globalenv {ids = extract_ids globalenv; unb = false;
 				    tmp_scope = None; scopes = [];
-				    impls = empty_internalization_env} ([],[]) patt
+				    impls = empty_internalization_env} empty_alias patt
   with
       InternalizationError (loc,e) ->
 	user_err_loc (loc,"internalize",explain_internalization_error e)
@@ -1546,158 +1791,135 @@ let intern_pattern globalenv patt =
 (*********************************************************************)
 (* Functions to parse and interpret constructions *)
 
-let interp_gen kind sigma env
-               ?(impls=empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
-               c =
-  let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in
-    Default.understand_gen kind sigma env c
+(* All evars resolved *)
 
-let interp_constr sigma env c =
-  interp_gen (OfType None) sigma env c
+let interp_gen kind env sigma ?(impls=empty_internalization_env) c =
+  let c = intern_gen kind ~impls env c in
+  understand ~expected_type:kind env sigma c
 
-let interp_type sigma env ?(impls=empty_internalization_env) c =
-  interp_gen IsType sigma env ~impls c
+let interp_constr env sigma ?(impls=empty_internalization_env) c =
+  interp_gen WithoutTypeConstraint env sigma c
 
-let interp_casted_constr sigma env ?(impls=empty_internalization_env) c typ =
-  interp_gen (OfType (Some typ)) sigma env ~impls c
+let interp_type env sigma ?(impls=empty_internalization_env) c =
+  interp_gen IsType env sigma ~impls c
 
-let interp_open_constr sigma env c =
-  Default.understand_tcc sigma env (intern_constr sigma env c)
+let interp_casted_constr env sigma ?(impls=empty_internalization_env) c typ =
+  interp_gen (OfType typ) env sigma ~impls c
 
-let interp_open_constr_patvar sigma env c =
-  let raw = intern_gen false sigma env c ~allow_patvar:true in
-  let sigma = ref sigma in
-  let evars = ref (Gmap.empty : (identifier,glob_constr) Gmap.t) in
-  let rec patvar_to_evar r = match r with
-    | GPatVar (loc,(_,id)) ->
-	( try Gmap.find id !evars
-	  with Not_found ->
-	    let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in
-	    let ev = Evarutil.e_new_evar sigma env ev in
-	    let rev = GEvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in
-	    evars := Gmap.add id rev !evars;
-	    rev
-	)
-    | _ -> map_glob_constr patvar_to_evar r in
-  let raw = patvar_to_evar raw in
-  Default.understand_tcc !sigma env raw
-
-let interp_constr_judgment sigma env c =
-  Default.understand_judgment sigma env (intern_constr sigma env c)
-
-let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true)
-    env ?(impls=empty_internalization_env) kind c =
-  let evdref =
-    match evdref with
-    | None -> ref Evd.empty
-    | Some evdref -> evdref
-  in
-  let istype = kind = IsType in
-  let c = intern_gen istype ~impls !evdref env c in
-  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:istype c in
-    Default.understand_tcc_evars ~fail_evar evdref env kind c, imps
+(* Not all evars expected to be resolved *)
+
+let interp_open_constr env sigma c =
+  understand_tcc env sigma (intern_constr env c)
 
-let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true)
-    env ?(impls=empty_internalization_env) c typ =
-  interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c
+(* Not all evars expected to be resolved and computation of implicit args *)
 
-let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c =
-  interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c
+let interp_constr_evars_gen_impls env evdref
+    ?(impls=empty_internalization_env) expected_type c =
+  let c = intern_gen expected_type ~impls env c in
+  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in
+    understand_tcc_evars env evdref ~expected_type c, imps
 
-let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=empty_internalization_env) c =
-  interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c
+let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c =
+  interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c
 
-let interp_constr_evars_gen evdref env ?(impls=empty_internalization_env) kind c =
-  let c = intern_gen (kind=IsType) ~impls !evdref env c in
-    Default.understand_tcc_evars evdref env kind c
+let interp_casted_constr_evars_impls env evdref ?(impls=empty_internalization_env) c typ =
+  interp_constr_evars_gen_impls env evdref ~impls (OfType typ) c
 
-let interp_casted_constr_evars evdref env ?(impls=empty_internalization_env) c typ =
-  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
+let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c =
+  interp_constr_evars_gen_impls env evdref ~impls IsType c
 
-let interp_type_evars evdref env ?(impls=empty_internalization_env) c =
-  interp_constr_evars_gen evdref env IsType ~impls c
+(* Not all evars expected to be resolved, with side-effect on evars *)
 
-type ltac_sign = identifier list * unbound_ltac_var_map
+let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c =
+  let c = intern_gen expected_type ~impls env c in
+  understand_tcc_evars env evdref ~expected_type c
 
-let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c =
-  let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in
+let interp_constr_evars env evdref ?(impls=empty_internalization_env) c =
+  interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c
+
+let interp_casted_constr_evars env evdref ?(impls=empty_internalization_env) c typ =
+  interp_constr_evars_gen env evdref ~impls (OfType typ) c
+
+let interp_type_evars env evdref ?(impls=empty_internalization_env) c =
+  interp_constr_evars_gen env evdref IsType ~impls c
+
+(* Miscellaneous *)
+
+let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c =
+  let c = intern_gen (if as_type then IsType else WithoutTypeConstraint)
+            ~allow_patvar:true ~ltacvars env c in
   pattern_of_glob_constr c
 
-let interp_aconstr ?(impls=empty_internalization_env) vars recvars a =
+let interp_notation_constr ?(impls=empty_internalization_env) nenv a =
   let env = Global.env () in
   (* [vl] is intended to remember the scope of the free variables of [a] *)
-  let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in
-  let c = internalize Evd.empty (Global.env()) {ids = extract_ids env; unb = false;
+  let vl = Id.Map.map (fun typ -> (ref None, typ)) nenv.ninterp_var_type in
+  let c = internalize (Global.env()) {ids = extract_ids env; unb = false;
 						tmp_scope = None; scopes = []; impls = impls}
-    false (([],[]),vl) a in
+    false (empty_ltac_sign, vl) a in
   (* Translate and check that [c] has all its free variables bound in [vars] *)
-  let a = aconstr_of_glob_constr vars recvars c in
+  let a = notation_constr_of_glob_constr nenv c in
   (* Splits variables into those that are binding, bound, or both *)
   (* binding and bound *)
   let out_scope = function None -> None,[] | Some (a,l) -> a,l in
-  let vars = List.map (fun (id,(sc,typ)) -> (id,(out_scope !sc,typ))) vl in
+  let vars = Id.Map.map (fun (sc, typ) -> (out_scope !sc, typ)) vl in
   (* Returns [a] and the ordered list of variables with their scopes *)
   vars, a
 
 (* Interpret binders and contexts  *)
 
-let interp_binder sigma env na t =
-  let t = intern_gen true sigma env t in
-  let t' = locate_if_isevar (loc_of_glob_constr t) na t in
-  Default.understand_type sigma env t'
+let interp_binder env sigma na t =
+  let t = intern_gen IsType env t in
+  let t' = locate_if_hole (loc_of_glob_constr t) na t in
+  understand ~expected_type:IsType env sigma t'
 
-let interp_binder_evars evdref env na t =
-  let t = intern_gen true !evdref env t in
-  let t' = locate_if_isevar (loc_of_glob_constr t) na t in
-  Default.understand_tcc_evars evdref env IsType t'
+let interp_binder_evars env evdref na t =
+  let t = intern_gen IsType env t in
+  let t' = locate_if_hole (loc_of_glob_constr t) na t in
+  understand_tcc_evars env evdref ~expected_type:IsType t'
 
 open Environ
-open Term
 
-let my_intern_constr sigma env lvar acc c =
-  internalize sigma env acc false lvar c
+let my_intern_constr env lvar acc c =
+  internalize env acc false lvar c
 
-let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c
-
-let intern_context global_level sigma env impl_env params =
-  let lvar = (([],[]), []) in
+let intern_context global_level env impl_env binders =
+  try
+  let lvar = (empty_ltac_sign, Id.Map.empty) in
   let lenv, bl = List.fold_left
-	    (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar)
+	    (intern_local_binder_aux ~global_level (my_intern_constr env lvar) lvar)
 	    ({ids = extract_ids env; unb = false;
-	      tmp_scope = None; scopes = []; impls = impl_env}, []) params in (lenv.impls, bl)
+	      tmp_scope = None; scopes = []; impls = impl_env}, []) binders in
+  (lenv.impls, List.map snd bl)
+  with InternalizationError (loc,e) ->
+    user_err_loc (loc,"internalize", explain_internalization_error e)
 
-let interp_rawcontext_gen understand_type understand_judgment env bl =
+let interp_rawcontext_evars env evdref bl =
   let (env, par, _, impls) =
     List.fold_left
       (fun (env,params,n,impls) (na, k, b, t) ->
 	match b with
 	    None ->
-	      let t' = locate_if_isevar (loc_of_glob_constr t) na t in
-	      let t = understand_type env t' in
+	      let t' = locate_if_hole (loc_of_glob_constr t) na t in
+	      let t =
+                understand_tcc_evars env evdref ~expected_type:IsType t' in
 	      let d = (na,None,t) in
 	      let impls =
-		if k = Implicit then
+		if k == Implicit then
 		  let na = match na with Name n -> Some n | Anonymous -> None in
 		    (ExplByPos (n, na), (true, true, true)) :: impls
 		else impls
 	      in
 		(push_rel d env, d::params, succ n, impls)
 	  | Some b ->
-	      let c = understand_judgment env b in
-	      let d = (na, Some c.uj_val, Termops.refresh_universes c.uj_type) in
+	      let c = understand_judgment_tcc env evdref b in
+	      let d = (na, Some c.uj_val, c.uj_type) in
 		(push_rel d env, d::params, succ n, impls))
       (env,[],1,[]) (List.rev bl)
   in (env, par), impls
 
-let interp_context_gen understand_type understand_judgment ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params =
-  let int_env,bl = intern_context global_level sigma env impl_env params in
-    int_env, interp_rawcontext_gen understand_type understand_judgment env bl
-
-let interp_context ?(global_level=false) ?(impl_env=empty_internalization_env) sigma env params =
-  interp_context_gen (Default.understand_type sigma)
-    (Default.understand_judgment sigma) ~global_level ~impl_env sigma env params
-
-let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) evdref env params =
-  interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t)
-    (Default.understand_judgment_tcc evdref) ~global_level ~impl_env !evdref env params
+let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) env evdref params =
+  let int_env,bl = intern_context global_level env impl_env params in
+  let x = interp_rawcontext_evars env evdref bl in
+  int_env, x
 
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index b8b3d995..792e6f63 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.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,15 +8,18 @@
 
 open Names
 open Term
-open Sign
+open Context
 open Evd
 open Environ
 open Libnames
+open Globnames
 open Glob_term
 open Pattern
-open Topconstr
-open Termops
+open Constrexpr
+open Notation_term
 open Pretyping
+open Misctypes
+open Decl_kinds
 
 (** Translation from front abstract syntax of term to untyped terms (glob_constr) *)
 
@@ -37,7 +40,7 @@ open Pretyping
    of [env] *)
 
 type var_internalization_type =
-  | Inductive of identifier list (* list of params *)
+  | Inductive of Id.t list (* list of params *)
   | Recursive
   | Method
   | Variable
@@ -46,14 +49,14 @@ type var_internalization_data =
     var_internalization_type *
       (** type of the "free" variable, for coqdoc, e.g. while typing the
 	  constructor of JMeq, "JMeq" behaves as a variable of type Inductive *)
-    identifier list *
+    Id.t list *
       (** impargs to automatically add to the variable, e.g. for "JMeq A a B b"
           in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *)
     Impargs.implicit_status list * (** signature of impargs of the variable *)
-    scope_name option list (** subscopes of the args of the variable *)
+    Notation_term.scope_name option list (** subscopes of the args of the variable *)
 
 (** A map of free variables to their implicit arguments and scopes *)
-type internalization_env = var_internalization_data Idmap.t
+type internalization_env = var_internalization_data Id.Map.t
 
 val empty_internalization_env : internalization_env
 
@@ -61,79 +64,81 @@ val compute_internalization_data : env -> var_internalization_type ->
   types -> Impargs.manual_explicitation list -> var_internalization_data
 
 val compute_internalization_env : env -> var_internalization_type ->
-  identifier list -> types list -> Impargs.manual_explicitation list list ->
+  Id.t list -> types list -> Impargs.manual_explicitation list list ->
   internalization_env
 
-type ltac_sign = identifier list * unbound_ltac_var_map
+type ltac_sign = {
+  ltac_vars : Id.Set.t;
+  (** Variables of Ltac which may be bound to a term *)
+  ltac_bound : Id.Set.t;
+  (** Other variables of Ltac *)
+}
 
-type glob_binder = (name * binding_kind * glob_constr option * glob_constr)
+val empty_ltac_sign : ltac_sign
+
+type glob_binder = (Name.t * binding_kind * glob_constr option * glob_constr)
 
 (** {6 Internalization performs interpretation of global names and notations } *)
 
-val intern_constr : evar_map -> env -> constr_expr -> glob_constr
+val intern_constr : env -> constr_expr -> glob_constr
 
-val intern_type : evar_map -> env -> constr_expr -> glob_constr
+val intern_type : env -> constr_expr -> glob_constr
 
-val intern_gen : bool -> evar_map -> env ->
+val intern_gen : typing_constraint -> env ->
   ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
   constr_expr -> glob_constr
 
 val intern_pattern : env -> cases_pattern_expr ->
-  Names.identifier list *
-    ((Names.identifier * Names.identifier) list * Glob_term.cases_pattern) list
-
-val intern_context : bool -> evar_map -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list
+  Id.t list * (Id.t Id.Map.t * cases_pattern) list
 
-(** {6 Composing internalization with pretyping } *)
+val intern_context : bool -> env -> internalization_env -> local_binder list -> internalization_env * glob_binder list
 
-(** Main interpretation function *)
-
-val interp_gen : typing_constraint -> evar_map -> env ->
-  ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
-  constr_expr -> constr
+(** {6 Composing internalization with type inference (pretyping) } *)
 
-(** Particular instances *)
+(** Main interpretation functions expecting evars to be all resolved *)
 
-val interp_constr : evar_map -> env ->
-  constr_expr -> constr
+val interp_constr : env -> evar_map -> ?impls:internalization_env ->
+  constr_expr -> constr Evd.in_evar_universe_context
 
-val interp_type : evar_map -> env -> ?impls:internalization_env ->
-  constr_expr -> types
+val interp_casted_constr : env -> evar_map -> ?impls:internalization_env ->
+  constr_expr -> types -> constr Evd.in_evar_universe_context
 
-val interp_open_constr   : evar_map -> env -> constr_expr -> evar_map * constr
+val interp_type : env -> evar_map -> ?impls:internalization_env ->
+  constr_expr -> types Evd.in_evar_universe_context
 
-val interp_open_constr_patvar   : evar_map -> env -> constr_expr -> evar_map * constr
+(** Main interpretation function expecting evars to be all resolved *)
 
-val interp_casted_constr : evar_map -> env -> ?impls:internalization_env ->
-  constr_expr -> types -> constr
+val interp_open_constr   : env -> evar_map -> constr_expr -> evar_map * constr
 
-(** Accepting evars and giving back the manual implicits in addition. *)
+(** Accepting unresolved evars *)
 
-val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env ->
-  ?impls:internalization_env -> constr_expr -> types -> constr * Impargs.manual_implicits
+val interp_constr_evars : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr -> constr
 
-val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
-  env -> ?impls:internalization_env ->
-  constr_expr -> types * Impargs.manual_implicits
+val interp_casted_constr_evars : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr -> types -> constr
 
-val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
-  env -> ?impls:internalization_env ->
-  constr_expr -> constr * Impargs.manual_implicits
+val interp_type_evars : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr -> types
 
-val interp_casted_constr_evars : evar_map ref -> env ->
-  ?impls:internalization_env -> constr_expr -> types -> constr
+(** Accepting unresolved evars and giving back the manual implicit arguments *)
 
-val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env ->
-  constr_expr -> types
+val interp_constr_evars_impls : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr ->
+  constr * Impargs.manual_implicits
 
-(** {6 Build a judgment  } *)
+val interp_casted_constr_evars_impls : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr -> types ->
+  constr * Impargs.manual_implicits
 
-val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment
+val interp_type_evars_impls : env -> evar_map ref ->
+  ?impls:internalization_env -> constr_expr ->
+  types * Impargs.manual_implicits
 
 (** Interprets constr patterns *)
 
 val intern_constr_pattern :
-  evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign ->
+  env -> ?as_type:bool -> ?ltacvars:ltac_sign ->
     constr_pattern_expr -> patvar list * constr_pattern
 
 (** Raise Not_found if syndef not bound to a name and error if unexisting ref *)
@@ -144,39 +149,42 @@ val interp_reference : ltac_sign -> reference -> glob_constr
 
 (** Interpret binders *)
 
-val interp_binder  : evar_map -> env -> name -> constr_expr -> types
+val interp_binder  : env -> evar_map -> Name.t -> constr_expr -> 
+  types Evd.in_evar_universe_context
 
-val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types
+val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types
 
 (** Interpret contexts: returns extended env and context *)
 
-val interp_context_gen : (env -> glob_constr -> types) ->
-  (env -> glob_constr -> unsafe_judgment) ->
+val interp_context_evars :
   ?global_level:bool -> ?impl_env:internalization_env ->
-  evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
-  
-val interp_context : ?global_level:bool -> ?impl_env:internalization_env ->
-  evar_map -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
+  env -> evar_map ref -> local_binder list ->
+  internalization_env * ((env * rel_context) * Impargs.manual_implicits)
 
-val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env ->
-  evar_map ref -> env -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits)
+(* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *)
+(*   (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *)
+(*   ?global_level:bool -> ?impl_env:internalization_env -> *)
+(*   env -> evar_map -> local_binder list -> internalization_env * ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *)
+  
+(* val interp_context : ?global_level:bool -> ?impl_env:internalization_env -> *)
+(*   env -> evar_map -> local_binder list ->  *)
+(*   internalization_env *  *)
+(*   ((env * Evd.evar_universe_context * rel_context * sorts list) * Impargs.manual_implicits) *)
 
 (** Locating references of constructions, possibly via a syntactic definition 
    (these functions do not modify the glob file) *)
 
-val is_global : identifier -> bool
-val construct_reference : named_context -> identifier -> constr
-val global_reference : identifier -> constr
-val global_reference_in_absolute_module : dir_path -> identifier -> constr
-
-(** Interprets a term as the left-hand side of a notation; the boolean
-    list is a set and this set is [true] for a variable occurring in
-    term position, [false] for a variable occurring in binding
-    position; [true;false] if in both kinds of position *)
-val interp_aconstr : ?impls:internalization_env ->
-  (identifier * notation_var_internalization_type) list ->
-  (identifier * identifier) list -> constr_expr ->
-  (identifier * (subscopes * notation_var_internalization_type)) list * aconstr
+val is_global : Id.t -> bool
+val construct_reference : named_context -> Id.t -> constr
+val global_reference : Id.t -> constr
+val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr
+
+(** Interprets a term as the left-hand side of a notation. The returned map is
+    guaranteed to have the same domain as the input one. *)
+val interp_notation_constr : ?impls:internalization_env ->
+  notation_interp_env -> constr_expr ->
+  (subscopes * notation_var_internalization_type) Id.Map.t *
+  notation_constr
 
 (** Globalization options *)
 val parsing_explicit : bool ref
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index e446d177..e722615a 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -1,34 +1,38 @@
 (************************************************************************)
 (*  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 Pp
 open Names
 open Term
 open Libnames
-open Pattern
+open Globnames
 open Nametab
 open Smartlocate
 
+let coq = Nameops.coq_string (* "Coq" *)
+
 (************************************************************************)
 (* Generic functions to find Coq objects *)
 
 type message = string
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
 
 let find_reference locstr dir s =
-  let sp = Libnames.make_path (make_dir dir) (id_of_string s) in
+  let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in
   try global_of_extended_global (Nametab.extended_global_of_path sp)
-  with Not_found -> anomaly (locstr^": cannot find "^(string_of_path sp))
+  with Not_found ->
+    anomaly ~label:locstr (str "cannot find " ++ Libnames.pr_path sp)
 
-let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
-let coq_constant locstr dir s = constr_of_global (coq_reference locstr dir s)
+let coq_reference locstr dir s = find_reference locstr (coq::dir) s
+let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s)
 
 let gen_reference = coq_reference
 let gen_constant = coq_constant
@@ -40,103 +44,119 @@ let has_suffix_in_dirs dirs ref =
 let global_of_extended q =
   try Some (global_of_extended_global q) with Not_found -> None
 
-let gen_constant_in_modules locstr dirs s =
+let gen_reference_in_modules locstr dirs s =
   let dirs = List.map make_dir dirs in
   let qualid = qualid_of_string s in
   let all = Nametab.locate_extended_all qualid in
-  let all = list_uniquize (list_map_filter global_of_extended all) in
+  let all = List.map_filter global_of_extended all in
+  let all = List.sort_uniquize RefOrdered_env.compare all in
   let these = List.filter (has_suffix_in_dirs dirs) all in
   match these with
-    | [x] -> constr_of_global x
+    | [x] -> x
     | [] ->
-	anomalylabstrm "" (str (locstr^": cannot find "^s^
+	anomaly ~label:locstr (str ("cannot find "^s^
 	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
 	prlist_with_sep pr_comma pr_dirpath dirs)
     | l ->
-	anomalylabstrm ""
-	(str (locstr^": found more than once object of name "^s^
-	" in module"^(if List.length dirs > 1 then "s " else " ")) ++
-	prlist_with_sep pr_comma pr_dirpath dirs)
+      anomaly ~label:locstr
+	(str ("ambiguous name "^s^" can represent ") ++
+	   prlist_with_sep pr_comma
+	   (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++
+	   str (" in module"^(if List.length dirs > 1 then "s " else " ")) ++
+	   prlist_with_sep pr_comma pr_dirpath dirs)
+
+let gen_constant_in_modules locstr dirs s =
+  Universes.constr_of_global (gen_reference_in_modules locstr dirs s)
 
 
 (* For tactics/commands requiring vernacular libraries *)
 
 let check_required_library d =
-  let d' = List.map id_of_string d in
-  let dir = make_dirpath (List.rev d') in
-  let mp = (fst(Lib.current_prefix())) in
-  let current_dir = match mp with
-    | MPfile dp -> (dir=dp)
-    | _ -> false
-  in
-  if not (Library.library_is_loaded dir) then
-    if not current_dir then
+  let dir = make_dir d in
+  if Library.library_is_loaded dir then ()
+  else
+    let in_current_dir = match Lib.current_mp () with
+      | MPfile dp -> DirPath.equal dir dp
+      | _ -> false
+    in
+    if not in_current_dir then
 (* Loading silently ...
-    let m, prefix = list_sep_last d' in
+    let m, prefix = List.sep_last d' in
     read_library
-     (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m)
+     (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m)
 *)
 (* or failing ...*)
-      error ("Library "^(string_of_dirpath dir)^" has to be required first.")
+      error ("Library "^(DirPath.to_string dir)^" has to be required first.")
 
 (************************************************************************)
 (* Specific Coq objects *)
 
-let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s
+let init_reference dir s =
+  let d = "Init"::dir in
+  check_required_library (coq::d); gen_reference "Coqlib" d s
 
-let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s
+let init_constant dir s =
+  let d = "Init"::dir in
+  check_required_library (coq::d); gen_constant "Coqlib" d s
 
-let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s
+let logic_reference dir s =
+  let d = "Logic"::dir in
+  check_required_library ("Coq"::d); gen_reference "Coqlib" d s
 
-let arith_dir = ["Coq";"Arith"]
+let arith_dir = [coq;"Arith"]
 let arith_modules = [arith_dir]
 
-let numbers_dir = [ "Coq";"Numbers"]
-let parith_dir = ["Coq";"PArith"]
-let narith_dir = ["Coq";"NArith"]
-let zarith_dir = ["Coq";"ZArith"]
+let numbers_dir = [coq;"Numbers"]
+let parith_dir = [coq;"PArith"]
+let narith_dir = [coq;"NArith"]
+let zarith_dir = [coq;"ZArith"]
 
 let zarith_base_modules = [numbers_dir;parith_dir;narith_dir;zarith_dir]
 
-let init_dir = ["Coq";"Init"]
+let init_dir = [coq;"Init"]
 let init_modules = [
   init_dir@["Datatypes"];
   init_dir@["Logic"];
   init_dir@["Specif"];
   init_dir@["Logic_Type"];
+  init_dir@["Nat"];
   init_dir@["Peano"];
   init_dir@["Wf"]
 ]
 
-let logic_module_name = ["Coq";"Init";"Logic"]
+let prelude_module_name = init_dir@["Prelude"]
+let prelude_module = make_dir prelude_module_name
+
+let logic_module_name = init_dir@["Logic"]
 let logic_module = make_dir logic_module_name
 
-let logic_type_module_name = ["Coq";"Init";"Logic_Type"]
+let logic_type_module_name = init_dir@["Logic_Type"]
 let logic_type_module = make_dir logic_type_module_name
 
-let datatypes_module_name = ["Coq";"Init";"Datatypes"]
+let datatypes_module_name = init_dir@["Datatypes"]
 let datatypes_module = make_dir datatypes_module_name
 
-let arith_module_name = ["Coq";"Arith";"Arith"]
-let arith_module = make_dir arith_module_name
-
-let jmeq_module_name = ["Coq";"Logic";"JMeq"]
+let jmeq_module_name = [coq;"Logic";"JMeq"]
 let jmeq_module = make_dir jmeq_module_name
 
-(* TODO: temporary hack *)
-let make_kn dir id = Libnames.encode_mind dir id
-let make_con dir id = Libnames.encode_con dir id
+(* TODO: temporary hack. Works only if the module isn't an alias *)
+let make_ind dir id = Globnames.encode_mind dir (Id.of_string id)
+let make_con dir id = Globnames.encode_con dir (Id.of_string id)
 
 (** Identity *)
 
-let id = make_con datatypes_module (id_of_string "id")
-let type_of_id = make_con datatypes_module (id_of_string "ID")
+let id = make_con datatypes_module "idProp"
+let type_of_id = make_con datatypes_module "IDProp"
 
-let _ = Termops.set_impossible_default_clause (mkConst id,mkConst type_of_id)
+let _ = Termops.set_impossible_default_clause 
+  (fun () -> 
+    let c, ctx = Universes.fresh_global_instance (Global.env()) (ConstRef id) in
+    let (_, u) = destConst c in
+      (c,mkConstU (type_of_id,u)), ctx)
 
 (** Natural numbers *)
-let nat_kn = make_kn datatypes_module (id_of_string "nat")
-let nat_path = Libnames.make_path datatypes_module (id_of_string "nat")
+let nat_kn = make_ind datatypes_module "nat"
+let nat_path = Libnames.make_path datatypes_module (Id.of_string "nat")
 
 let glob_nat = IndRef (nat_kn,0)
 
@@ -146,7 +166,7 @@ let glob_O = ConstructRef path_of_O
 let glob_S = ConstructRef path_of_S
 
 (** Booleans *)
-let bool_kn = make_kn datatypes_module (id_of_string "bool")
+let bool_kn = make_ind datatypes_module "bool"
 
 let glob_bool = IndRef (bool_kn,0)
 
@@ -156,21 +176,21 @@ let glob_true  = ConstructRef path_of_true
 let glob_false  = ConstructRef path_of_false
 
 (** Equality *)
-let eq_kn = make_kn logic_module (id_of_string "eq")
+let eq_kn = make_ind logic_module "eq"
 let glob_eq = IndRef (eq_kn,0)
 
-let identity_kn = make_kn datatypes_module (id_of_string "identity")
+let identity_kn = make_ind datatypes_module "identity"
 let glob_identity = IndRef (identity_kn,0)
 
-let jmeq_kn = make_kn jmeq_module (id_of_string "JMeq")
+let jmeq_kn = make_ind jmeq_module "JMeq"
 let glob_jmeq = IndRef (jmeq_kn,0)
 
 type coq_sigma_data = {
-  proj1 : constr;
-  proj2 : constr;
-  elim  : constr;
-  intro : constr;
-  typ   : constr }
+  proj1 : global_reference;
+  proj2 : global_reference;
+  elim  : global_reference;
+  intro : global_reference;
+  typ   : global_reference }
 
 type coq_bool_data  = {
   andb : constr;
@@ -182,59 +202,61 @@ let build_bool_type () =
     andb_prop =  init_constant ["Datatypes"] "andb_prop";
     andb_true_intro =  init_constant ["Datatypes"] "andb_true_intro" }
 
-let build_sigma_set () = anomaly "Use build_sigma_type"
+let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type")
 
 let build_sigma_type () =
-  { proj1 = init_constant ["Specif"] "projT1";
-    proj2 = init_constant ["Specif"] "projT2";
-    elim = init_constant ["Specif"] "sigT_rect";
-    intro = init_constant ["Specif"] "existT";
-    typ = init_constant ["Specif"] "sigT" }
+  { proj1 = init_reference ["Specif"] "projT1";
+    proj2 = init_reference ["Specif"] "projT2";
+    elim = init_reference ["Specif"] "sigT_rect";
+    intro = init_reference ["Specif"] "existT";
+    typ = init_reference ["Specif"] "sigT" }
 
 let build_sigma () =
-  { proj1 = init_constant ["Specif"] "proj1_sig";
-    proj2 = init_constant ["Specif"] "proj2_sig";
-    elim = init_constant ["Specif"] "sig_rect";
-    intro = init_constant ["Specif"] "exist";
-    typ = init_constant ["Specif"] "sig" }
+  { proj1 = init_reference ["Specif"] "proj1_sig";
+    proj2 = init_reference ["Specif"] "proj2_sig";
+    elim = init_reference ["Specif"] "sig_rect";
+    intro = init_reference ["Specif"] "exist";
+    typ = init_reference ["Specif"] "sig" }
+
 
 let build_prod () =
-  { proj1 = init_constant ["Datatypes"] "fst";
-    proj2 = init_constant ["Datatypes"] "snd";
-    elim = init_constant ["Datatypes"] "prod_rec";
-    intro = init_constant ["Datatypes"] "pair";
-    typ = init_constant ["Datatypes"] "prod" }
+  { proj1 = init_reference ["Datatypes"] "fst";
+    proj2 = init_reference ["Datatypes"] "snd";
+    elim = init_reference ["Datatypes"] "prod_rec";
+    intro = init_reference ["Datatypes"] "pair";
+    typ = init_reference ["Datatypes"] "prod" }
 
 (* Equalities *)
 type coq_eq_data = {
-  eq   : constr;
-  ind  : constr;
-  refl : constr;
-  sym  : constr;
-  trans: constr;
-  congr: constr }
+  eq   : global_reference;
+  ind  : global_reference;
+  refl : global_reference;
+  sym  : global_reference;
+  trans: global_reference;
+  congr: global_reference }
 
 (* Data needed for discriminate and injection *)
 type coq_inversion_data = {
-  inv_eq   : constr; (* : forall params, t -> Prop *)
-  inv_ind  : constr; (* : forall params P y, eq params y -> P y *)
-  inv_congr: constr  (* : forall params B (f:t->B) y, eq params y -> f c=f y *)
+  inv_eq   : global_reference; (* : forall params, t -> Prop *)
+  inv_ind  : global_reference; (* : forall params P y, eq params y -> P y *)
+  inv_congr: global_reference  (* : forall params B (f:t->B) y, eq params y -> f c=f y *)
 }
 
+let lazy_init_reference dir id = lazy (init_reference dir id)
 let lazy_init_constant dir id = lazy (init_constant dir id)
-let lazy_logic_constant dir id = lazy (logic_constant dir id)
+let lazy_logic_reference dir id = lazy (logic_reference dir id)
 
 (* Leibniz equality on Type *)
 
-let coq_eq_eq = lazy_init_constant ["Logic"] "eq"
-let coq_eq_refl = lazy_init_constant ["Logic"] "eq_refl"
-let coq_eq_ind = lazy_init_constant ["Logic"] "eq_ind"
-let coq_eq_congr = lazy_init_constant ["Logic"] "f_equal"
-let coq_eq_sym  = lazy_init_constant ["Logic"] "eq_sym"
-let coq_eq_trans  = lazy_init_constant ["Logic"] "eq_trans"
-let coq_f_equal2 = lazy_init_constant ["Logic"] "f_equal2"
+let coq_eq_eq = lazy_init_reference ["Logic"] "eq"
+let coq_eq_refl = lazy_init_reference ["Logic"] "eq_refl"
+let coq_eq_ind = lazy_init_reference ["Logic"] "eq_ind"
+let coq_eq_congr = lazy_init_reference ["Logic"] "f_equal"
+let coq_eq_sym  = lazy_init_reference ["Logic"] "eq_sym"
+let coq_eq_trans  = lazy_init_reference ["Logic"] "eq_trans"
+let coq_f_equal2 = lazy_init_reference ["Logic"] "f_equal2"
 let coq_eq_congr_canonical =
-  lazy_init_constant ["Logic"] "f_equal_canonical_form"
+  lazy_init_reference ["Logic"] "f_equal_canonical_form"
 
 let build_coq_eq_data () =
   let _ = check_required_library logic_module_name in {
@@ -258,14 +280,15 @@ let build_coq_inversion_eq_data () =
 
 (* Heterogenous equality on Type *)
 
-let coq_jmeq_eq = lazy_logic_constant ["JMeq"] "JMeq"
-let coq_jmeq_refl = lazy_logic_constant ["JMeq"] "JMeq_refl"
-let coq_jmeq_ind = lazy_logic_constant ["JMeq"] "JMeq_ind"
-let coq_jmeq_sym  = lazy_logic_constant ["JMeq"] "JMeq_sym"
-let coq_jmeq_congr  = lazy_logic_constant ["JMeq"] "JMeq_congr"
-let coq_jmeq_trans  = lazy_logic_constant ["JMeq"] "JMeq_trans"
+let coq_jmeq_eq = lazy_logic_reference ["JMeq"] "JMeq"
+let coq_jmeq_hom = lazy_logic_reference ["JMeq"] "JMeq_hom"
+let coq_jmeq_refl = lazy_logic_reference ["JMeq"] "JMeq_refl"
+let coq_jmeq_ind = lazy_logic_reference ["JMeq"] "JMeq_ind"
+let coq_jmeq_sym  = lazy_logic_reference ["JMeq"] "JMeq_sym"
+let coq_jmeq_congr  = lazy_logic_reference ["JMeq"] "JMeq_congr"
+let coq_jmeq_trans  = lazy_logic_reference ["JMeq"] "JMeq_trans"
 let coq_jmeq_congr_canonical =
-  lazy_logic_constant ["JMeq"] "JMeq_congr_canonical_form"
+  lazy_logic_reference ["JMeq"] "JMeq_congr_canonical_form"
 
 let build_coq_jmeq_data () =
   let _ = check_required_library jmeq_module_name in {
@@ -276,14 +299,9 @@ let build_coq_jmeq_data () =
   trans = Lazy.force coq_jmeq_trans;
   congr = Lazy.force coq_jmeq_congr }
 
-let join_jmeq_types eq =
-  mkLambda(Name (id_of_string "A"),Termops.new_Type(),
-  mkLambda(Name (id_of_string "x"),mkRel 1,
-  mkApp (eq,[|mkRel 2;mkRel 1;mkRel 2|])))
-
 let build_coq_inversion_jmeq_data () =
   let _ = check_required_library logic_module_name in {
-  inv_eq = join_jmeq_types (Lazy.force coq_jmeq_eq);
+  inv_eq = Lazy.force coq_jmeq_hom;
   inv_ind = Lazy.force coq_jmeq_ind;
   inv_congr = Lazy.force coq_jmeq_congr_canonical }
 
@@ -293,13 +311,13 @@ let coq_sumbool  = lazy_init_constant ["Specif"] "sumbool"
 let build_coq_sumbool () = Lazy.force coq_sumbool
 
 (* Equality on Type as a Type *)
-let coq_identity_eq = lazy_init_constant ["Datatypes"] "identity"
-let coq_identity_refl = lazy_init_constant ["Datatypes"] "identity_refl"
-let coq_identity_ind = lazy_init_constant ["Datatypes"] "identity_ind"
-let coq_identity_congr = lazy_init_constant ["Logic_Type"] "identity_congr"
-let coq_identity_sym = lazy_init_constant ["Logic_Type"] "identity_sym"
-let coq_identity_trans = lazy_init_constant ["Logic_Type"] "identity_trans"
-let coq_identity_congr_canonical = lazy_init_constant ["Logic_Type"] "identity_congr_canonical_form"
+let coq_identity_eq = lazy_init_reference ["Datatypes"] "identity"
+let coq_identity_refl = lazy_init_reference ["Datatypes"] "identity_refl"
+let coq_identity_ind = lazy_init_reference ["Datatypes"] "identity_ind"
+let coq_identity_congr = lazy_init_reference ["Logic_Type"] "identity_congr"
+let coq_identity_sym = lazy_init_reference ["Logic_Type"] "identity_sym"
+let coq_identity_trans = lazy_init_reference ["Logic_Type"] "identity_trans"
+let coq_identity_congr_canonical = lazy_init_reference ["Logic_Type"] "identity_congr_canonical_form"
 
 let build_coq_identity_data () =
   let _ = check_required_library datatypes_module_name in {
@@ -318,9 +336,9 @@ let build_coq_inversion_identity_data () =
   inv_congr = Lazy.force coq_identity_congr_canonical }
 
 (* Equality to true *)
-let coq_eq_true_eq = lazy_init_constant ["Datatypes"] "eq_true"
-let coq_eq_true_ind = lazy_init_constant ["Datatypes"] "eq_true_ind"
-let coq_eq_true_congr = lazy_init_constant ["Logic"] "eq_true_congr"
+let coq_eq_true_eq = lazy_init_reference ["Datatypes"] "eq_true"
+let coq_eq_true_ind = lazy_init_reference ["Datatypes"] "eq_true_ind"
+let coq_eq_true_congr = lazy_init_reference ["Logic"] "eq_true_congr"
 
 let build_coq_inversion_eq_true_data () =
   let _ = check_required_library datatypes_module_name in
@@ -331,6 +349,7 @@ let build_coq_inversion_eq_true_data () =
 
 (* The False proposition *)
 let coq_False  = lazy_init_constant ["Logic"] "False"
+let coq_proof_admitted = lazy_init_constant ["Logic"] "proof_admitted"
 
 (* The True proposition and its unique proof *)
 let coq_True   = lazy_init_constant ["Logic"] "True"
@@ -352,6 +371,7 @@ let build_coq_True ()  = Lazy.force coq_True
 let build_coq_I ()     = Lazy.force coq_I
 
 let build_coq_False () = Lazy.force coq_False
+let build_coq_proof_admitted () = Lazy.force coq_proof_admitted
 let build_coq_not ()   = Lazy.force coq_not
 let build_coq_and ()   = Lazy.force coq_and
 let build_coq_conj ()  = Lazy.force coq_conj
@@ -368,7 +388,7 @@ let coq_eq_ref      = lazy (init_reference ["Logic"] "eq")
 let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity")
 let coq_jmeq_ref     = lazy (gen_reference "Coqlib" ["Logic";"JMeq"] "JMeq")
 let coq_eq_true_ref = lazy (gen_reference "Coqlib" ["Init";"Datatypes"] "eq_true")
-let coq_existS_ref  = lazy (anomaly "use coq_existT_ref")
+let coq_existS_ref  = lazy (anomaly (Pp.str "use coq_existT_ref"))
 let coq_existT_ref  = lazy (init_reference ["Specif"] "existT")
 let coq_exist_ref  = lazy (init_reference ["Specif"] "exist")
 let coq_not_ref     = lazy (init_reference ["Logic"] "not")
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index 0efebc29..986a4385 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.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,9 +8,8 @@
 
 open Names
 open Libnames
-open Nametab
+open Globnames
 open Term
-open Pattern
 open Util
 
 (** This module collects the global references, constructions and
@@ -43,6 +42,7 @@ val gen_reference :  message -> string list -> string -> global_reference
 
 (** Search in several modules (not prefixed by "Coq") *)
 val gen_constant_in_modules : string->string list list-> string -> constr
+val gen_reference_in_modules : string->string list list-> string -> global_reference
 val arith_modules : string list list
 val zarith_base_modules : string list list
 val init_modules : string list list
@@ -53,12 +53,18 @@ val check_required_library : string list -> unit
 (** {6 Global references } *)
 
 (** Modules *)
-val logic_module : dir_path
-val logic_type_module : dir_path
+val prelude_module : DirPath.t
 
-val datatypes_module_name : string list
+val logic_module : DirPath.t
 val logic_module_name : string list
 
+val logic_type_module : DirPath.t
+
+val jmeq_module : DirPath.t
+val jmeq_module_name : string list
+
+val datatypes_module_name : string list
+
 (** Natural numbers *)
 val nat_path : full_path
 val glob_nat : global_reference
@@ -96,43 +102,49 @@ val build_bool_type : coq_bool_data delayed
 
 (** {6 For Equality tactics } *)
 type coq_sigma_data = {
-  proj1 : constr;
-  proj2 : constr;
-  elim  : constr;
-  intro : constr;
-  typ   : constr }
+  proj1 : global_reference;
+  proj2 : global_reference;
+  elim  : global_reference;
+  intro : global_reference;
+  typ   : global_reference }
 
 val build_sigma_set : coq_sigma_data delayed
 val build_sigma_type : coq_sigma_data delayed
 val build_sigma : coq_sigma_data delayed
 
+(* val build_sigma_type_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *)
+(* val build_sigma_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *)
+(* val build_prod_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *)
+(* val build_coq_eq_data_in : Environ.env -> coq_eq_data Univ.in_universe_context_set *)
+
 (** Non-dependent pairs in Set from Datatypes *)
 val build_prod : coq_sigma_data delayed
 
 type coq_eq_data = {
-  eq   : constr;
-  ind  : constr;
-  refl : constr;
-  sym  : constr;
-  trans: constr;
-  congr: constr }
+  eq   : global_reference;
+  ind  : global_reference;
+  refl : global_reference;
+  sym  : global_reference;
+  trans: global_reference;
+  congr: global_reference }
 
 val build_coq_eq_data : coq_eq_data delayed
+
 val build_coq_identity_data : coq_eq_data delayed
 val build_coq_jmeq_data : coq_eq_data delayed
 
-val build_coq_eq       : constr delayed (** = [(build_coq_eq_data()).eq] *)
-val build_coq_eq_refl  : constr delayed (** = [(build_coq_eq_data()).refl] *)
-val build_coq_eq_sym   : constr delayed (** = [(build_coq_eq_data()).sym] *)
-val build_coq_f_equal2 : constr delayed
+val build_coq_eq       : global_reference delayed (** = [(build_coq_eq_data()).eq] *)
+val build_coq_eq_refl  : global_reference delayed (** = [(build_coq_eq_data()).refl] *)
+val build_coq_eq_sym   : global_reference delayed (** = [(build_coq_eq_data()).sym] *)
+val build_coq_f_equal2 : global_reference delayed
 
 (** Data needed for discriminate and injection *)
 
 type coq_inversion_data = {
-  inv_eq   : constr; (** : forall params, args -> Prop *)
-  inv_ind  : constr; (** : forall params P (H : P params) args, eq params args 
+  inv_eq   : global_reference; (** : forall params, args -> Prop *)
+  inv_ind  : global_reference; (** : forall params P (H : P params) args, eq params args 
 			 ->  P args *)
-  inv_congr: constr  (** : forall params B (f:t->B) args, eq params args -> 
+  inv_congr: global_reference  (** : forall params B (f:t->B) args, eq params args -> 
 			 f params = f args *)
 }
 
@@ -148,6 +160,7 @@ val build_coq_sumbool : constr delayed
 (** Connectives 
    The False proposition *)
 val build_coq_False : constr delayed
+val build_coq_proof_admitted : constr delayed
 
 (** The True proposition and its unique proof *)
 val build_coq_True : constr delayed
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index dbccf8ae..c18ceeca 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -1,11 +1,12 @@
 (************************************************************************)
 (*  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 Util
 
 (* Dump of globalization (to be used by coqdoc) *)
 
@@ -21,6 +22,7 @@ type glob_output_t =
     | NoGlob
     | StdOut
     | MultFiles
+    | Feedback
     | File of string
 
 let glob_output = ref NoGlob
@@ -29,14 +31,19 @@ let dump () = !glob_output != NoGlob
 
 let noglob () = glob_output := NoGlob
 
-let dump_to_stdout () = glob_output := StdOut; glob_file := Pervasives.stdout
+let dump_to_dotglob () = glob_output := MultFiles
 
-let dump_to_dotglob f = glob_output := MultFiles
+let dump_into_file f =
+  if String.equal f "stdout" then
+    (glob_output := StdOut; glob_file := Pervasives.stdout)
+  else
+    (glob_output := File f; open_glob_file f)
 
-let dump_into_file f = glob_output := File f; open_glob_file f
+let feedback_glob () = glob_output := Feedback
 
 let dump_string s =
-  if dump () then Pervasives.output_string !glob_file s
+  if dump () && !glob_output != Feedback then 
+    Pervasives.output_string !glob_file s
 
 let start_dump_glob vfile =
   match !glob_output with
@@ -48,23 +55,18 @@ let start_dump_glob vfile =
   | File f ->
       open_glob_file f;
       output_string !glob_file "DIGEST NO\n"
-  | NoGlob | StdOut ->
+  | NoGlob | Feedback | StdOut ->
       ()
 
 let end_dump_glob () =
   match !glob_output with
   | MultFiles | File _ -> close_glob_file ()
-  | NoGlob | StdOut -> ()
+  | NoGlob | Feedback | StdOut -> ()
 
 let previous_state = ref MultFiles
 let pause () = previous_state := !glob_output; glob_output := NoGlob
 let continue () = glob_output := !previous_state
 
-type coqdoc_state = Lexer.location_table
-
-let coqdoc_freeze = Lexer.location_table
-let coqdoc_unfreeze = Lexer.restore_location_table
-
 open Decl_kinds
 
 let type_of_logical_kind = function
@@ -102,18 +104,27 @@ let type_of_global_ref gr =
     "class"
   else
     match gr with
-    | Libnames.ConstRef cst ->
+    | Globnames.ConstRef cst ->
 	type_of_logical_kind (Decls.constant_kind cst)
-    | Libnames.VarRef v ->
+    | Globnames.VarRef v ->
 	"var" ^ type_of_logical_kind (Decls.variable_kind v)
-    | Libnames.IndRef ind ->
+    | Globnames.IndRef ind ->
 	let (mib,oib) = Inductive.lookup_mind_specif (Global.env ()) ind in
-	  if mib.Declarations.mind_record then
-	    if mib.Declarations.mind_finite then "rec"
-	    else "corec"
-	  else if mib.Declarations.mind_finite then "ind"
-	  else "coind"
-    | Libnames.ConstructRef _ -> "constr"
+	  if mib.Declarations.mind_record <> None then
+            let open Decl_kinds in
+            begin match mib.Declarations.mind_finite with
+            | Finite -> "indrec"
+            | BiFinite -> "rec"
+	    | CoFinite -> "corec"
+            end
+	  else
+            let open Decl_kinds in
+            begin match mib.Declarations.mind_finite with
+            | Finite -> "ind"
+            | BiFinite -> "variant"
+	    | CoFinite -> "coind"
+            end
+    | Globnames.ConstructRef _ -> "constr"
 
 let remove_sections dir =
   if Libnames.is_dirpath_prefix_of dir (Lib.cwd ()) then
@@ -124,79 +135,30 @@ let remove_sections dir =
     dir
 
 let interval loc =
-  let loc1,loc2 = Util.unloc loc in
+  let loc1,loc2 = Loc.unloc loc in
   loc1, loc2-1
 
 let dump_ref loc filepath modpath ident ty =
-  let bl,el = interval loc in
-  dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n"
+  if !glob_output = Feedback then
+    Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty))
+  else
+    let bl,el = interval loc in
+    dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n"
 		  bl el filepath modpath ident ty)
 
-let add_glob_gen loc sp lib_dp ty =
-  if dump () then
-    let mod_dp,id = Libnames.repr_path sp in
-    let mod_dp = remove_sections mod_dp in
-    let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in
-    let filepath = Names.string_of_dirpath lib_dp in
-    let modpath = Names.string_of_dirpath mod_dp_trunc in
-    let ident = Names.string_of_id id in
-      dump_ref loc filepath modpath ident ty
-
-let add_glob loc ref =
-  if dump () && loc <> Util.dummy_loc then
-    let sp = Nametab.path_of_global ref in
-    let lib_dp = Lib.library_part ref in
-    let ty = type_of_global_ref ref in
-      add_glob_gen loc sp lib_dp ty
-
-let mp_of_kn kn =
-  let mp,sec,l = Names.repr_kn kn in
-    Names.MPdot (mp,l)
-
-let add_glob_kn loc kn =
-  if dump () && loc <> Util.dummy_loc then
-    let sp = Nametab.path_of_syndef kn in
-    let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in
-      add_glob_gen loc sp lib_dp "syndef"
-
-let dump_binding loc id = ()
-
-let dump_definition (loc, id) sec s =
-  let bl,el = interval loc in
-  dump_string (Printf.sprintf "%s %d:%d %s %s\n" s bl el
-			(Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id))
-
 let dump_reference loc modpath ident ty =
-  let bl,el = interval loc in
-  dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n"
-		  bl el (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty)
-
-let dump_constraint ((loc, n), _, _) sec ty =
-  match n with
-    | Names.Name id -> dump_definition (loc, id) sec ty
-    | Names.Anonymous -> ()
+  let filepath = Names.DirPath.to_string (Lib.library_dp ()) in
+  dump_ref loc filepath modpath ident ty
 
 let dump_modref loc mp ty =
-  if dump () then
-    let (dp, l) = Lib.split_modpath mp in
-    let l = if l = [] then l else Util.list_drop_last l in
-    let fp = Names.string_of_dirpath dp in
-    let mp = Names.string_of_dirpath (Names.make_dirpath l) in
-    let bl,el = interval loc in
-      dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n"
-		      bl el fp mp "<>" ty)
-
-let dump_moddef loc mp ty =
-  if dump () then
-    let bl,el = interval loc in
-    let (dp, l) = Lib.split_modpath mp in
-    let mp = Names.string_of_dirpath (Names.make_dirpath l) in
-      dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el "<>" mp)
+  let (dp, l) = Lib.split_modpath mp in
+  let filepath = Names.DirPath.to_string dp in
+  let modpath = Names.DirPath.to_string (Names.DirPath.make l) in
+  let ident = "<>" in
+  dump_ref loc filepath modpath ident ty
 
 let dump_libref loc dp ty =
-  let bl,el = interval loc in
-  dump_string (Printf.sprintf "R%d:%d %s <> <> %s\n"
-		  bl el (Names.string_of_dirpath dp) ty)
+  dump_ref loc (Names.DirPath.to_string dp) "<>" "<>" ty
 
 let cook_notation df sc =
   (* We encode notations so that they are space-free and still human-readable *)
@@ -212,19 +174,19 @@ let cook_notation df sc =
   let l = String.length df - 1 in
   let i = ref 0 in
   while !i <= l do
-    assert (df.[!i] <> ' ');
-    if df.[!i] = '_' && (!i = l || df.[!i+1] = ' ') then
+    assert (df.[!i] != ' ');
+    if df.[!i] == '_' && (Int.equal !i l || df.[!i+1] == ' ') then
       (* Next token is a non-terminal *)
       (ntn.[!j] <- 'x'; incr j; incr i)
     else begin
       (* Next token is a terminal *)
       ntn.[!j] <- '\''; incr j;
-      while !i <= l && df.[!i] <> ' ' do
+      while !i <= l && df.[!i] != ' ' do
 	if df.[!i] < ' ' then
 	  let c = char_of_int (int_of_char 'A' + int_of_char df.[!i] - 1) in
 	  (String.blit ("'^" ^ String.make 1 c) 0 ntn !j 3; j := !j+3; incr i)
 	else begin
-	  if df.[!i] = '\'' then (ntn.[!j] <- '\''; incr j);
+	  if df.[!i] == '\'' then (ntn.[!j] <- '\''; incr j);
 	  ntn.[!j] <- df.[!i]; incr j; incr i
 	end
       done;
@@ -235,16 +197,67 @@ let cook_notation df sc =
   let df = String.sub ntn 0 !j in
   match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df
 
-let dump_notation (loc,(df,_)) sc sec =
-  (* We dump the location of the opening '"' *)
-  dump_string (Printf.sprintf "not %d %s %s\n" (fst (Util.unloc loc))
-    (Names.string_of_dirpath (Lib.current_dirpath sec)) (cook_notation df sc))
-
 let dump_notation_location posl df (((path,secpath),_),sc) =
   if dump () then
-    let path = Names.string_of_dirpath path in
-    let secpath = Names.string_of_dirpath secpath in
+    let path = Names.DirPath.to_string path in
+    let secpath = Names.DirPath.to_string secpath in
     let df = cook_notation df sc in
-    List.iter (fun (bl,el) ->
-      dump_string(Printf.sprintf "R%d:%d %s %s %s not\n" bl el path secpath df))
+    List.iter (fun l ->
+      dump_ref (Loc.make_loc l) path secpath df "not")
       posl
+
+let add_glob_gen loc sp lib_dp ty =
+  if dump () then
+    let mod_dp,id = Libnames.repr_path sp in
+    let mod_dp = remove_sections mod_dp in
+    let mod_dp_trunc = Libnames.drop_dirpath_prefix lib_dp mod_dp in
+    let filepath = Names.DirPath.to_string lib_dp in
+    let modpath = Names.DirPath.to_string mod_dp_trunc in
+    let ident = Names.Id.to_string id in
+      dump_ref loc filepath modpath ident ty
+
+let add_glob loc ref =
+  if dump () && not (Loc.is_ghost loc) then
+    let sp = Nametab.path_of_global ref in
+    let lib_dp = Lib.library_part ref in
+    let ty = type_of_global_ref ref in
+      add_glob_gen loc sp lib_dp ty
+
+let mp_of_kn kn =
+  let mp,sec,l = Names.repr_kn kn in
+    Names.MPdot (mp,l)
+
+let add_glob_kn loc kn =
+  if dump () && not (Loc.is_ghost loc) then
+    let sp = Nametab.path_of_syndef kn in
+    let lib_dp = Lib.dp_of_mp (mp_of_kn kn) in
+      add_glob_gen loc sp lib_dp "syndef"
+
+let dump_binding loc id = ()
+
+let dump_def ty loc secpath id =
+  if !glob_output = Feedback then
+    Pp.feedback (Feedback.GlobDef (loc, id, secpath, ty))
+  else
+    let bl,el = interval loc in
+    dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el secpath id)
+
+let dump_definition (loc, id) sec s =
+  dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id)
+
+let dump_constraint ((loc, n), _, _) sec ty =
+  match n with
+    | Names.Name id -> dump_definition (loc, id) sec ty
+    | Names.Anonymous -> ()
+
+let dump_moddef loc mp ty =
+  let (dp, l) = Lib.split_modpath mp in
+  let mp = Names.DirPath.to_string (Names.DirPath.make l) in
+  dump_def ty loc "<>" mp
+
+let dump_notation (loc,(df,_)) sc sec =
+  (* We dump the location of the opening '"' *)
+  let i = fst (Loc.unloc loc) in
+  let location = (Loc.make_loc (i, i+1)) in
+  dump_def "not" location (Names.DirPath.to_string (Lib.current_dirpath sec)) (cook_notation df sc)
+
diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli
index df192e9b..428189be 100644
--- a/interp/dumpglob.mli
+++ b/interp/dumpglob.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        *)
@@ -15,29 +15,30 @@ val end_dump_glob : unit -> unit
 val dump : unit -> bool
 
 val noglob : unit -> unit
-val dump_to_stdout : unit -> unit
-val dump_into_file : string -> unit
+val dump_into_file : string -> unit (** special handling of "stdout" *)
 val dump_to_dotglob : unit -> unit
+val feedback_glob : unit -> unit
 
 val pause : unit -> unit
 val continue : unit -> unit
 
-type coqdoc_state = Lexer.location_table
-val coqdoc_freeze : unit -> coqdoc_state
-val coqdoc_unfreeze : coqdoc_state -> unit
-
-val add_glob : Util.loc -> Libnames.global_reference -> unit
-val add_glob_kn : Util.loc -> Names.kernel_name -> unit
-
-val dump_definition : Util.loc * Names.identifier -> bool -> string -> unit
-val dump_moddef : Util.loc -> Names.module_path -> string -> unit
-val dump_modref  : Util.loc -> Names.module_path -> string -> unit
-val dump_reference  : Util.loc -> string -> string -> string -> unit
-val dump_libref : Util.loc -> Names.dir_path -> string -> unit
-val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation.notation_location * Topconstr.scope_name option) -> unit
-val dump_binding : Util.loc -> Names.Idset.elt -> unit
-val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit
-val dump_constraint :  Topconstr.typeclass_constraint -> bool -> string -> unit
+val add_glob : Loc.t -> Globnames.global_reference -> unit
+val add_glob_kn : Loc.t -> Names.kernel_name -> unit
+
+val dump_definition : Loc.t * Names.Id.t -> bool -> string -> unit
+val dump_moddef : Loc.t -> Names.module_path -> string -> unit
+val dump_modref  : Loc.t -> Names.module_path -> string -> unit
+val dump_reference  : Loc.t -> string -> string -> string -> unit
+val dump_libref : Loc.t -> Names.DirPath.t -> string -> unit
+val dump_notation_location : (int * int) list -> Constrexpr.notation ->
+  (Notation.notation_location * Notation_term.scope_name option) -> unit
+val dump_binding : Loc.t -> Names.Id.Set.elt -> unit
+val dump_notation :
+  Loc.t * (Constrexpr.notation * Notation.notation_location) ->
+  Notation_term.scope_name option -> bool -> unit
+val dump_constraint :
+  Constrexpr.typeclass_constraint -> bool -> string -> unit
 
 val dump_string : string -> unit
 
+val type_of_global_ref : Globnames.global_reference -> string 
diff --git a/interp/genarg.ml b/interp/genarg.ml
deleted file mode 100644
index 41cbcdaf..00000000
--- a/interp/genarg.ml
+++ /dev/null
@@ -1,281 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Nametab
-open Glob_term
-open Topconstr
-open Term
-open Evd
-
-type argument_type =
-  (* Basic types *)
-  | BoolArgType
-  | IntArgType
-  | IntOrVarArgType
-  | StringArgType
-  | PreIdentArgType
-  | IntroPatternArgType
-  | IdentArgType of bool
-  | VarArgType
-  | RefArgType
-  (* Specific types *)
-  | SortArgType
-  | ConstrArgType
-  | ConstrMayEvalArgType
-  | QuantHypArgType
-  | OpenConstrArgType of bool * bool (* casted, TC resolution *)
-  | ConstrWithBindingsArgType
-  | BindingsArgType
-  | RedExprArgType
-  | List0ArgType of argument_type
-  | List1ArgType of argument_type
-  | OptArgType of argument_type
-  | PairArgType of argument_type * argument_type
-  | ExtraArgType of string
-
-type 'a and_short_name = 'a * identifier located option
-type 'a or_by_notation =
-  | AN of 'a
-  | ByNotation of (loc * string * Notation.delimiters option)
-
-let loc_of_or_by_notation f = function
-  | AN c -> f c
-  | ByNotation (loc,s,_) -> loc
-
-type glob_constr_and_expr = glob_constr * constr_expr option
-type open_constr_expr = unit * constr_expr
-type open_glob_constr = unit * glob_constr_and_expr
-
-type glob_constr_pattern_and_expr = glob_constr_and_expr * Pattern.constr_pattern
-
-type 'a with_ebindings = 'a * open_constr bindings
-
-(* Dynamics but tagged by a type expression *)
-
-type 'a generic_argument = argument_type * Obj.t
-
-type rlevel
-type glevel
-type tlevel
-
-type intro_pattern_expr =
-  | IntroOrAndPattern of or_and_intro_pattern_expr
-  | IntroWildcard
-  | IntroRewrite of bool
-  | IntroIdentifier of identifier
-  | IntroFresh of identifier
-  | IntroForthcoming of bool
-  | IntroAnonymous
-and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list
-
-let rec pr_intro_pattern (_,pat) = match pat with
-  | IntroOrAndPattern pll -> pr_or_and_intro_pattern pll
-  | IntroWildcard -> str "_"
-  | IntroRewrite true -> str "->"
-  | IntroRewrite false -> str "<-"
-  | IntroIdentifier id -> pr_id id
-  | IntroFresh id -> str "?" ++ pr_id id
-  | IntroForthcoming true -> str "*"
-  | IntroForthcoming false -> str "**"
-  | IntroAnonymous -> str "?"
-
-and pr_or_and_intro_pattern = function
-  | [pl] ->
-      str "(" ++ hv 0 (prlist_with_sep pr_comma pr_intro_pattern pl) ++ str ")"
-  | pll ->
-      str "[" ++
-      hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc pr_intro_pattern) pll)
-      ++ str "]"
-
-let rawwit_bool = BoolArgType
-let globwit_bool = BoolArgType
-let wit_bool = BoolArgType
-
-let rawwit_int = IntArgType
-let globwit_int = IntArgType
-let wit_int = IntArgType
-
-let rawwit_int_or_var = IntOrVarArgType
-let globwit_int_or_var = IntOrVarArgType
-let wit_int_or_var = IntOrVarArgType
-
-let rawwit_string = StringArgType
-let globwit_string = StringArgType
-let wit_string = StringArgType
-
-let rawwit_pre_ident = PreIdentArgType
-let globwit_pre_ident = PreIdentArgType
-let wit_pre_ident = PreIdentArgType
-
-let rawwit_intro_pattern = IntroPatternArgType
-let globwit_intro_pattern = IntroPatternArgType
-let wit_intro_pattern = IntroPatternArgType
-
-let rawwit_ident_gen b = IdentArgType b
-let globwit_ident_gen b = IdentArgType b
-let wit_ident_gen b = IdentArgType b
-
-let rawwit_ident = rawwit_ident_gen true
-let globwit_ident = globwit_ident_gen true
-let wit_ident = wit_ident_gen true
-
-let rawwit_pattern_ident = rawwit_ident_gen false
-let globwit_pattern_ident = globwit_ident_gen false
-let wit_pattern_ident = wit_ident_gen false
-
-let rawwit_var = VarArgType
-let globwit_var = VarArgType
-let wit_var = VarArgType
-
-let rawwit_ref = RefArgType
-let globwit_ref = RefArgType
-let wit_ref = RefArgType
-
-let rawwit_quant_hyp = QuantHypArgType
-let globwit_quant_hyp = QuantHypArgType
-let wit_quant_hyp = QuantHypArgType
-
-let rawwit_sort = SortArgType
-let globwit_sort = SortArgType
-let wit_sort = SortArgType
-
-let rawwit_constr = ConstrArgType
-let globwit_constr = ConstrArgType
-let wit_constr = ConstrArgType
-
-let rawwit_constr_may_eval = ConstrMayEvalArgType
-let globwit_constr_may_eval = ConstrMayEvalArgType
-let wit_constr_may_eval = ConstrMayEvalArgType
-
-let rawwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2)
-let globwit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2)
-let wit_open_constr_gen (b1,b2) = OpenConstrArgType (b1,b2)
-
-let rawwit_open_constr = rawwit_open_constr_gen (false,false)
-let globwit_open_constr = globwit_open_constr_gen (false,false)
-let wit_open_constr = wit_open_constr_gen (false,false)
-
-let rawwit_casted_open_constr = rawwit_open_constr_gen (true,false)
-let globwit_casted_open_constr = globwit_open_constr_gen (true,false)
-let wit_casted_open_constr = wit_open_constr_gen (true,false)
-
-let rawwit_open_constr_wTC = rawwit_open_constr_gen (false,true)
-let globwit_open_constr_wTC = globwit_open_constr_gen (false,true)
-let wit_open_constr_wTC = wit_open_constr_gen (false,true)
-
-let rawwit_constr_with_bindings = ConstrWithBindingsArgType
-let globwit_constr_with_bindings = ConstrWithBindingsArgType
-let wit_constr_with_bindings = ConstrWithBindingsArgType
-
-let rawwit_bindings = BindingsArgType
-let globwit_bindings = BindingsArgType
-let wit_bindings = BindingsArgType
-
-let rawwit_red_expr = RedExprArgType
-let globwit_red_expr = RedExprArgType
-let wit_red_expr = RedExprArgType
-
-let wit_list0 t = List0ArgType t
-
-let wit_list1 t = List1ArgType t
-
-let wit_opt t = OptArgType t
-
-let wit_pair t1 t2 = PairArgType (t1,t2)
-
-let in_gen t o = (t,Obj.repr o)
-let out_gen t (t',o) = if t = t' then Obj.magic o else failwith "out_gen"
-let genarg_tag (s,_) = s
-
-let fold_list0 f = function
-  | (List0ArgType t, l) ->
-      List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l)
-  | _ -> failwith "Genarg: not a list0"
-
-let fold_list1 f = function
-  | (List1ArgType t, l) ->
-      List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l)
-  | _ -> failwith "Genarg: not a list1"
-
-let fold_opt f a = function
-  | (OptArgType t, l) ->
-      (match Obj.magic l with
-	| None -> a
-	| Some x -> f (in_gen t x))
-  | _ -> failwith "Genarg: not a opt"
-
-let fold_pair f = function
-  | (PairArgType (t1,t2), l) ->
-      let (x1,x2) = Obj.magic l in
-      f (in_gen t1 x1) (in_gen t2 x2)
-  | _ -> failwith "Genarg: not a pair"
-
-let app_list0 f = function
-  | (List0ArgType t as u, l) ->
-      let o = Obj.magic l in
-      (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o))
-  | _ -> failwith "Genarg: not a list0"
-
-let app_list1 f = function
-  | (List1ArgType t as u, l) ->
-      let o = Obj.magic l in
-      (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o))
-  | _ -> failwith "Genarg: not a list1"
-
-let app_opt f = function
-  | (OptArgType t as u, l) ->
-      let o = Obj.magic l in
-      (u, Obj.repr (Option.map (fun x -> out_gen t (f (in_gen t x))) o))
-  | _ -> failwith "Genarg: not an opt"
-
-let app_pair f1 f2 = function
-  | (PairArgType (t1,t2) as u, l) ->
-      let (o1,o2) = Obj.magic l in
-      let o1 = out_gen t1 (f1 (in_gen t1 o1)) in
-      let o2 = out_gen t2 (f2 (in_gen t2 o2)) in
-      (u, Obj.repr (o1,o2))
-  | _ -> failwith "Genarg: not a pair"
-
-let unquote x = x
-
-type an_arg_of_this_type = Obj.t
-
-let in_generic t x = (t, Obj.repr x)
-
-let dyntab = ref ([] : (string * glevel generic_argument option) list)
-
-type ('a,'b) abstract_argument_type = argument_type
-
-let create_arg v s =
-  if List.mem_assoc s !dyntab then
-    anomaly ("Genarg.create: already declared generic argument " ^ s);
-  let t = ExtraArgType s in
-  dyntab := (s,Option.map (in_gen t) v) :: !dyntab;
-  (t,t,t)
-
-let exists_argtype s = List.mem_assoc s !dyntab
-
-let default_empty_argtype_value s = List.assoc s !dyntab
-
-let default_empty_value t =
-  let rec aux = function
-  | List0ArgType _ -> Some (in_gen t [])
-  | OptArgType _ -> Some (in_gen t None)
-  | PairArgType(t1,t2) ->
-      (match aux t1, aux t2 with
-      | Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2))
-      | _ -> None)
-  | ExtraArgType s -> default_empty_argtype_value s
-  | _ -> None in
-  match aux t with
-  | Some v -> Some (out_gen t v)
-  | None -> None
diff --git a/interp/genarg.mli b/interp/genarg.mli
deleted file mode 100644
index f1425c55..00000000
--- a/interp/genarg.mli
+++ /dev/null
@@ -1,320 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Names
-open Term
-open Libnames
-open Glob_term
-open Pattern
-open Topconstr
-open Term
-open Evd
-
-type 'a and_short_name = 'a * identifier located option
-
-type 'a or_by_notation =
-  | AN of 'a
-  | ByNotation of (loc * string * Notation.delimiters option)
-
-val loc_of_or_by_notation : ('a -> loc) -> 'a or_by_notation -> loc
-
-(** In globalize tactics, we need to keep the initial [constr_expr] to recompute
-   in the environment by the effective calls to Intro, Inversion, etc 
-   The [constr_expr] field is [None] in TacDef though *)
-type glob_constr_and_expr = glob_constr * constr_expr option
-
-type open_constr_expr = unit * constr_expr
-type open_glob_constr = unit * glob_constr_and_expr
-
-type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern
-
-type 'a with_ebindings = 'a * open_constr bindings
-
-type intro_pattern_expr =
-  | IntroOrAndPattern of or_and_intro_pattern_expr
-  | IntroWildcard
-  | IntroRewrite of bool
-  | IntroIdentifier of identifier
-  | IntroFresh of identifier
-  | IntroForthcoming of bool
-  | IntroAnonymous
-and or_and_intro_pattern_expr = (loc * intro_pattern_expr) list list
-
-val pr_intro_pattern : intro_pattern_expr located -> Pp.std_ppcmds
-val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds
-
-(** The route of a generic argument, from parsing to evaluation.
-In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
-
-{% \begin{%}verbatim{% }%}
-             parsing          in_raw                            out_raw
-   char stream ---> raw_object ---> raw_object generic_argument -------+
-                          encapsulation                          decaps|
-                                                                       |
-                                                                       V
-                                                                   raw_object
-                                                                       |
-                                                         globalization |
-                                                                       V
-                                                                   glob_object
-                                                                       |
-                                                                encaps |
-                                                               in_glob |
-                                                                       V
-                                                           glob_object generic_argument
-                                                                       |
-          out                          in                     out_glob |
-  object <--- object generic_argument <--- object <--- glob_object <---+
-    |   decaps                       encaps      interp           decaps
-    |
-    V
-effective use
-{% \end{%}verbatim{% }%}
-
-To distinguish between the uninterpreted (raw), globalized and
-interpreted worlds, we annotate the type [generic_argument] by a
-phantom argument which is either [constr_expr], [glob_constr] or
-[constr].
-
-Transformation for each type :
-{% \begin{%}verbatim{% }%}
-tag                            raw open type            cooked closed type
-
-BoolArgType                    bool                      bool
-IntArgType                     int                       int
-IntOrVarArgType                int or_var                int
-StringArgType                  string (parsed w/ "")     string
-PreIdentArgType                string (parsed w/o "")    (vernac only)
-IdentArgType true              identifier                identifier
-IdentArgType false             identifier (pattern_ident) identifier
-IntroPatternArgType            intro_pattern_expr        intro_pattern_expr
-VarArgType                     identifier located        identifier
-RefArgType                     reference                 global_reference
-QuantHypArgType                quantified_hypothesis     quantified_hypothesis
-ConstrArgType                  constr_expr               constr
-ConstrMayEvalArgType           constr_expr may_eval      constr
-OpenConstrArgType              open_constr_expr          open_constr
-ConstrWithBindingsArgType      constr_expr with_bindings constr with_bindings
-BindingsArgType                constr_expr bindings      constr bindings
-List0ArgType of argument_type
-List1ArgType of argument_type
-OptArgType of argument_type
-ExtraArgType of string         '_a                      '_b
-{% \end{%}verbatim{% }%}
-*)
-
-(** All of [rlevel], [glevel] and [tlevel] must be non convertible
-   to ensure the injectivity of the type inference from type
-   ['co generic_argument] to [('a,'co) abstract_argument_type];
-   this guarantees that, for 'co fixed, the type of
-   out_gen is monomorphic over 'a, hence type-safe
-*)
-
-type rlevel
-type glevel
-type tlevel
-
-type ('a,'co) abstract_argument_type
-
-val rawwit_bool : (bool,rlevel) abstract_argument_type
-val globwit_bool : (bool,glevel) abstract_argument_type
-val wit_bool : (bool,tlevel) abstract_argument_type
-
-val rawwit_int : (int,rlevel) abstract_argument_type
-val globwit_int : (int,glevel) abstract_argument_type
-val wit_int : (int,tlevel) abstract_argument_type
-
-val rawwit_int_or_var : (int or_var,rlevel) abstract_argument_type
-val globwit_int_or_var : (int or_var,glevel) abstract_argument_type
-val wit_int_or_var : (int or_var,tlevel) abstract_argument_type
-
-val rawwit_string : (string,rlevel) abstract_argument_type
-val globwit_string : (string,glevel) abstract_argument_type
-
-val wit_string : (string,tlevel) abstract_argument_type
-
-val rawwit_pre_ident : (string,rlevel) abstract_argument_type
-val globwit_pre_ident : (string,glevel) abstract_argument_type
-val wit_pre_ident : (string,tlevel) abstract_argument_type
-
-val rawwit_intro_pattern : (intro_pattern_expr located,rlevel) abstract_argument_type
-val globwit_intro_pattern : (intro_pattern_expr located,glevel) abstract_argument_type
-val wit_intro_pattern : (intro_pattern_expr located,tlevel) abstract_argument_type
-
-val rawwit_ident : (identifier,rlevel) abstract_argument_type
-val globwit_ident : (identifier,glevel) abstract_argument_type
-val wit_ident : (identifier,tlevel) abstract_argument_type
-
-val rawwit_pattern_ident : (identifier,rlevel) abstract_argument_type
-val globwit_pattern_ident : (identifier,glevel) abstract_argument_type
-val wit_pattern_ident : (identifier,tlevel) abstract_argument_type
-
-val rawwit_ident_gen : bool -> (identifier,rlevel) abstract_argument_type
-val globwit_ident_gen : bool -> (identifier,glevel) abstract_argument_type
-val wit_ident_gen : bool -> (identifier,tlevel) abstract_argument_type
-
-val rawwit_var : (identifier located,rlevel) abstract_argument_type
-val globwit_var : (identifier located,glevel) abstract_argument_type
-val wit_var : (identifier,tlevel) abstract_argument_type
-
-val rawwit_ref : (reference,rlevel) abstract_argument_type
-val globwit_ref : (global_reference located or_var,glevel) abstract_argument_type
-val wit_ref : (global_reference,tlevel) abstract_argument_type
-
-val rawwit_quant_hyp : (quantified_hypothesis,rlevel) abstract_argument_type
-val globwit_quant_hyp : (quantified_hypothesis,glevel) abstract_argument_type
-val wit_quant_hyp : (quantified_hypothesis,tlevel) abstract_argument_type
-
-val rawwit_sort : (glob_sort,rlevel) abstract_argument_type
-val globwit_sort : (glob_sort,glevel) abstract_argument_type
-val wit_sort : (sorts,tlevel) abstract_argument_type
-
-val rawwit_constr : (constr_expr,rlevel) abstract_argument_type
-val globwit_constr : (glob_constr_and_expr,glevel) abstract_argument_type
-val wit_constr : (constr,tlevel) abstract_argument_type
-
-val rawwit_constr_may_eval : ((constr_expr,reference or_by_notation,constr_expr) may_eval,rlevel) abstract_argument_type
-val globwit_constr_may_eval : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) may_eval,glevel) abstract_argument_type
-val wit_constr_may_eval : (constr,tlevel) abstract_argument_type
-
-val rawwit_open_constr_gen : bool * bool -> (open_constr_expr,rlevel) abstract_argument_type
-val globwit_open_constr_gen : bool * bool -> (open_glob_constr,glevel) abstract_argument_type
-val wit_open_constr_gen : bool * bool -> (open_constr,tlevel) abstract_argument_type
-
-val rawwit_open_constr : (open_constr_expr,rlevel) abstract_argument_type
-val globwit_open_constr : (open_glob_constr,glevel) abstract_argument_type
-val wit_open_constr : (open_constr,tlevel) abstract_argument_type
-
-val rawwit_casted_open_constr : (open_constr_expr,rlevel) abstract_argument_type
-val globwit_casted_open_constr : (open_glob_constr,glevel) abstract_argument_type
-val wit_casted_open_constr : (open_constr,tlevel) abstract_argument_type
-
-val rawwit_open_constr_wTC : (open_constr_expr,rlevel) abstract_argument_type
-val globwit_open_constr_wTC : (open_glob_constr,glevel) abstract_argument_type
-val wit_open_constr_wTC : (open_constr,tlevel) abstract_argument_type
-
-val rawwit_constr_with_bindings : (constr_expr with_bindings,rlevel) abstract_argument_type
-val globwit_constr_with_bindings : (glob_constr_and_expr with_bindings,glevel) abstract_argument_type
-val wit_constr_with_bindings : (constr with_bindings sigma,tlevel) abstract_argument_type
-
-val rawwit_bindings : (constr_expr bindings,rlevel) abstract_argument_type
-val globwit_bindings : (glob_constr_and_expr bindings,glevel) abstract_argument_type
-val wit_bindings : (constr bindings sigma,tlevel) abstract_argument_type
-
-val rawwit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen,rlevel) abstract_argument_type
-val globwit_red_expr : ((glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen,glevel) abstract_argument_type
-val wit_red_expr : ((constr,evaluable_global_reference,constr_pattern) red_expr_gen,tlevel) abstract_argument_type
-
-val wit_list0 :
-  ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type
-
-val wit_list1 :
-  ('a,'co) abstract_argument_type -> ('a list,'co) abstract_argument_type
-
-val wit_opt :
-  ('a,'co) abstract_argument_type -> ('a option,'co) abstract_argument_type
-
-val wit_pair :
-  ('a,'co) abstract_argument_type ->
-  ('b,'co) abstract_argument_type ->
-      ('a * 'b,'co) abstract_argument_type
-
-(** ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *)
-type 'a generic_argument
-
-val fold_list0 :
- ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c
-
-val fold_list1 :
- ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c
-
-val fold_opt :
- ('a generic_argument -> 'c) -> 'c -> 'a generic_argument -> 'c
-
-val fold_pair :
- ('a generic_argument -> 'a generic_argument -> 'c) ->
-      'a generic_argument -> 'c
-
-(** [app_list0] fails if applied to an argument not of tag [List0 t]
-    for some [t]; it's the responsability of the caller to ensure it *)
-
-val app_list0 : ('a generic_argument -> 'b generic_argument) ->
-'a generic_argument -> 'b generic_argument
-
-val app_list1 : ('a generic_argument -> 'b generic_argument) ->
-'a generic_argument -> 'b generic_argument
-
-val app_opt : ('a generic_argument -> 'b generic_argument) ->
-'a generic_argument -> 'b generic_argument
-
-val app_pair :
-  ('a generic_argument -> 'b generic_argument) ->
-      ('a generic_argument -> 'b generic_argument)
-   -> 'a generic_argument -> 'b generic_argument
-
-(** create a new generic type of argument: force to associate
-   unique ML types at each of the three levels *)
-val create_arg : 'rawa option ->
-    string ->
-      ('a,tlevel) abstract_argument_type
-      * ('globa,glevel) abstract_argument_type
-      * ('rawa,rlevel) abstract_argument_type
-
-val exists_argtype : string -> bool
-
-type argument_type =
-  (** Basic types *)
-  | BoolArgType
-  | IntArgType
-  | IntOrVarArgType
-  | StringArgType
-  | PreIdentArgType
-  | IntroPatternArgType
-  | IdentArgType of bool
-  | VarArgType
-  | RefArgType
-  (** Specific types *)
-  | SortArgType
-  | ConstrArgType
-  | ConstrMayEvalArgType
-  | QuantHypArgType
-  | OpenConstrArgType of bool * bool
-  | ConstrWithBindingsArgType
-  | BindingsArgType
-  | RedExprArgType
-  | List0ArgType of argument_type
-  | List1ArgType of argument_type
-  | OptArgType of argument_type
-  | PairArgType of argument_type * argument_type
-  | ExtraArgType of string
-
-val genarg_tag : 'a generic_argument -> argument_type
-
-val unquote : ('a,'co) abstract_argument_type -> argument_type
-
-val in_gen :
-  ('a,'co) abstract_argument_type -> 'a -> 'co generic_argument
-val out_gen :
-  ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a
-
-(** [in_generic] is used in combination with camlp4 [Gramext.action] magic
-
-   [in_generic: !l:type, !a:argument_type -> |a|_l -> 'l generic_argument]
-
-   where |a|_l is the interpretation of a at level l
-
-   [in_generic] is not typable; we replace the second argument by an absurd
-   type (with no introduction rule)
-*)
-type an_arg_of_this_type
-
-val in_generic :
-  argument_type -> an_arg_of_this_type -> 'co generic_argument
-
-val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option
diff --git a/interp/genintern.ml b/interp/genintern.ml
new file mode 100644
index 00000000..c78b13a8
--- /dev/null
+++ b/interp/genintern.ml
@@ -0,0 +1,57 @@
+(************************************************************************)
+(*  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 Names
+open Mod_subst
+open Genarg
+
+type glob_sign = {
+  ltacvars : Id.Set.t;
+  ltacrecvars : Nametab.ltac_constant Id.Map.t;
+  genv : Environ.env }
+
+type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb
+type 'glb subst_fun = substitution -> 'glb -> 'glb
+
+module InternObj =
+struct
+  type ('raw, 'glb, 'top) obj = ('raw, 'glb) intern_fun
+  let name = "intern"
+  let default _ = None
+end
+
+module SubstObj =
+struct
+  type ('raw, 'glb, 'top) obj = 'glb subst_fun
+  let name = "subst"
+  let default _ = None
+end
+
+module Intern = Register (InternObj)
+module Subst = Register (SubstObj)
+
+let intern = Intern.obj
+let register_intern0 = Intern.register0
+
+let generic_intern ist v =
+  let unpacker wit v =
+    let (ist, v) = intern wit ist (raw v) in
+    (ist, in_gen (glbwit wit) v)
+  in
+  unpack { unpacker; } v
+
+(** Substitution functions *)
+
+let substitute = Subst.obj
+let register_subst0 = Subst.register0
+
+let generic_substitute subs v =
+  let unpacker wit v = in_gen (glbwit wit) (substitute wit subs (glb v)) in
+  unpack { unpacker; } v
+
+let () = Hook.set Detyping.subst_genarg_hook generic_substitute
diff --git a/interp/genintern.mli b/interp/genintern.mli
new file mode 100644
index 00000000..6e63f71c
--- /dev/null
+++ b/interp/genintern.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  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 Names
+open Mod_subst
+open Genarg
+
+type glob_sign = {
+  ltacvars : Id.Set.t;
+  ltacrecvars : Nametab.ltac_constant Id.Map.t;
+  genv : Environ.env }
+
+(** {5 Internalization functions} *)
+
+type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb
+(** The type of functions used for internalizing generic arguments. *)
+
+val intern : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb) intern_fun
+
+val generic_intern : (raw_generic_argument, glob_generic_argument) intern_fun
+
+(** {5 Substitution functions} *)
+
+type 'glb subst_fun = substitution -> 'glb -> 'glb
+(** The type of functions used for substituting generic arguments. *)
+
+val substitute : ('raw, 'glb, 'top) genarg_type -> 'glb subst_fun
+
+val generic_substitute : glob_generic_argument subst_fun
+
+(** Registering functions *)
+
+val register_intern0 : ('raw, 'glb, 'top) genarg_type ->
+  ('raw, 'glb) intern_fun -> unit
+
+val register_subst0 : ('raw, 'glb, 'top) genarg_type ->
+  'glb subst_fun -> unit
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 1b0f1341..e304725d 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.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        *)
@@ -9,45 +9,35 @@
 (*i*)
 open Names
 open Decl_kinds
-open Term
-open Sign
-open Evd
-open Environ
-open Nametab
-open Mod_subst
+open Errors
 open Util
 open Glob_term
-open Topconstr
+open Constrexpr
 open Libnames
 open Typeclasses
 open Typeclasses_errors
 open Pp
 open Libobject
 open Nameops
+open Misctypes
 (*i*)
 
-let generalizable_table = ref Idpred.empty
-
-let _ =
-  Summary.declare_summary "generalizable-ident"
-    { Summary.freeze_function = (fun () -> !generalizable_table);
-      Summary.unfreeze_function = (fun r -> generalizable_table := r);
-      Summary.init_function = (fun () -> generalizable_table := Idpred.empty) }
+let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident"
 
 let declare_generalizable_ident table (loc,id) =
-  if id <> root_of_id id then
+  if not (Id.equal id (root_of_id id)) then
     user_err_loc(loc,"declare_generalizable_ident",
     (pr_id id ++ str
       " is not declarable as generalizable identifier: it must have no trailing digits, quote, or _"));
-  if Idpred.mem id table then
+  if Id.Pred.mem id table then
     user_err_loc(loc,"declare_generalizable_ident",
 		(pr_id id++str" is already declared as a generalizable identifier"))
-  else Idpred.add id table
+  else Id.Pred.add id table
 
 let add_generalizable gen table =
   match gen with
-  | None -> Idpred.empty
-  | Some [] -> Idpred.full
+  | None -> Id.Pred.empty
+  | Some [] -> Id.Pred.full
   | Some l -> List.fold_left (fun table lid -> declare_generalizable_ident table lid)
       table l
 
@@ -57,7 +47,7 @@ let cache_generalizable_type (_,(local,cmd)) =
 let load_generalizable_type _ (_,(local,cmd)) =
   generalizable_table := add_generalizable cmd !generalizable_table
 
-let in_generalizable : bool * identifier located list option -> obj =
+let in_generalizable : bool * Id.t Loc.located list option -> obj =
   declare_object {(default_object "GENERALIZED-IDENT") with
     load_function = load_generalizable_type;
     cache_function = cache_generalizable_type;
@@ -67,29 +57,22 @@ let in_generalizable : bool * identifier located list option -> obj =
 let declare_generalizable local gen =
  Lib.add_anonymous_leaf (in_generalizable (local, gen))
 
-let find_generalizable_ident id = Idpred.mem (root_of_id id) !generalizable_table
+let find_generalizable_ident id = Id.Pred.mem (root_of_id id) !generalizable_table
 
 let ids_of_list l =
-  List.fold_right Idset.add l Idset.empty
-
-let locate_reference qid =
-  match Nametab.locate_extended qid with
-    | TrueGlobal ref -> true
-    | SynDef kn -> true
+  List.fold_right Id.Set.add l Id.Set.empty
 
 let is_global id =
-  try
-    locate_reference (qualid_of_ident id)
-  with Not_found ->
-    false
+  try ignore (Nametab.locate_extended (qualid_of_ident id)); true
+  with Not_found -> false
+
+let is_named id env =
+  try ignore (Environ.lookup_named id env); true
+  with Not_found -> false
 
 let is_freevar ids env x =
-  try
-    if Idset.mem x ids then false
-    else
-      try ignore(Environ.lookup_named x env) ; false
-      with e when Errors.noncritical e -> not (is_global x)
-  with e when Errors.noncritical e -> true
+  not (Id.Set.mem x ids || is_named x env || is_global x)
+
 
 (* Auxiliary functions for the inference of implicitly quantified variables. *)
 
@@ -97,9 +80,9 @@ let ungeneralizable loc id =
   user_err_loc (loc, "Generalization", 
 	       str "Unbound and ungeneralizable variable " ++ pr_id id)
 
-let free_vars_of_constr_expr c ?(bound=Idset.empty) l =
+let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l =
   let found loc id bdvars l =
-    if List.mem id l then l
+    if Id.List.mem id l then l
     else if is_freevar bdvars (Global.env ()) id
     then
       if find_generalizable_ident id then id :: l
@@ -107,26 +90,26 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l =
     else l
   in
   let rec aux bdvars l c = match c with
-    | CRef (Ident (loc,id)) -> found loc id bdvars l
-    | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) ->
-	fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c
-    | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c
+    | CRef (Ident (loc,id),_) -> found loc id bdvars l
+    | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id),_) :: _, [], [])) when not (Id.Set.mem id bdvars) ->
+	Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c
+    | c -> Topconstr.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c
   in aux bound l c
 
 let ids_of_names l =
   List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l
 
-let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) =
+let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder list) =
   let rec aux bdvars l c = match c with
       ((LocalRawAssum (n, _, c)) :: tl) ->
 	let bound = ids_of_names n in
 	let l' = free_vars_of_constr_expr c ~bound:bdvars l in
-	  aux (Idset.union (ids_of_list bound) bdvars) l' tl
+	  aux (Id.Set.union (ids_of_list bound) bdvars) l' tl
 
     | ((LocalRawDef (n, c)) :: tl) ->
 	let bound = match snd n with Anonymous -> [] | Name n -> [n] in
 	let l' = free_vars_of_constr_expr c ~bound:bdvars l in
-	  aux (Idset.union (ids_of_list bound) bdvars) l' tl
+	  aux (Id.Set.union (ids_of_list bound) bdvars) l' tl
 
     | [] -> bdvars, l
   in aux bound l binders
@@ -134,13 +117,13 @@ let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) =
 let add_name_to_ids set na =
   match na with
   | Anonymous -> set
-  | Name id -> Idset.add id set
+  | Name id -> Id.Set.add id set
 
-let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty) =
+let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) =
   let rec vars bound vs = function
     | GVar (loc,id) ->
 	if is_freevar bound (Global.env ()) id then
-	  if List.mem_assoc id vs then vs
+	  if Id.List.mem_assoc id vs then vs
 	  else (id, loc) :: vs
 	else vs
     | GApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args)
@@ -163,7 +146,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty
 	let vs3 = vars bound vs2 b1 in
 	vars bound vs3 b2
     | GRec (loc,fk,idl,bl,tyl,bv) ->
-	let bound' = Array.fold_right Idset.add idl bound in
+	let bound' = Array.fold_right Id.Set.add idl bound in
 	let vars_fix i vs fid =
 	  let vs1,bound1 =
 	    List.fold_left
@@ -179,13 +162,13 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty
 	  let vs2 = vars bound1 vs1 tyl.(i) in
 	  vars bound1 vs2 bv.(i)
 	in
-	array_fold_left_i vars_fix vs idl
+	Array.fold_left_i vars_fix vs idl
     | GCast (loc,c,k) -> let v = vars bound vs c in
-	(match k with CastConv (_,t) -> vars bound v t | _ -> v)
+	(match k with CastConv t | CastVM t -> vars bound v t | _ -> v)
     | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs
 
   and vars_pattern bound vs (loc,idl,p,c) =
-    let bound' = List.fold_right Idset.add idl bound  in
+    let bound' = List.fold_right Id.Set.add idl bound  in
     vars bound' vs c
 
   and vars_option bound vs = function None -> vs | Some p -> vars bound vs p
@@ -196,7 +179,7 @@ let generalizable_vars_of_glob_constr ?(bound=Idset.empty) ?(allowed=Idset.empty
   in fun rt -> 
     let vars = List.rev (vars bound [] rt) in
       List.iter (fun (id, loc) ->
-	if not (Idset.mem id allowed || find_generalizable_ident id) then 
+	if not (Id.Set.mem id allowed || find_generalizable_ident id) then 
 	  ungeneralizable loc id) vars;
       vars
 
@@ -205,7 +188,7 @@ let rec make_fresh ids env x =
 
 let next_name_away_from na avoid =
   match na with
-  | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon")
+  | Anonymous -> make_fresh avoid (Global.env ()) (Id.of_string "anon")
   | Name id -> make_fresh avoid (Global.env ()) id
 
 let combine_params avoid fn applied needed =
@@ -213,7 +196,11 @@ let combine_params avoid fn applied needed =
     List.partition
       (function
 	  (t, Some (loc, ExplByName id)) ->
-	    if not (List.exists (fun (_, (id', _, _)) -> Name id = id') needed) then
+            let is_id (_, (na, _, _)) = match na with
+            | Name id' -> Id.equal id id'
+            | Anonymous -> false
+            in
+	    if not (List.exists is_id needed) then
 	      user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id);
 	    true
 	| _ -> false) applied
@@ -222,13 +209,17 @@ let combine_params avoid fn applied needed =
     (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false)
     named
   in
-  let needed = List.filter (fun (_, (_, b, _)) -> b = None) needed in
+  let is_unset (_, (_, b, _)) = match b with
+  | None -> true
+  | Some _ -> false
+  in
+  let needed = List.filter is_unset needed in
   let rec aux ids avoid app need =
     match app, need with
 	[], [] -> List.rev ids, avoid
 
-      | app, (_, (Name id, _, _)) :: need when List.mem_assoc id named ->
-	  aux (List.assoc id named :: ids) avoid app need
+      | app, (_, (Name id, _, _)) :: need when Id.List.mem_assoc id named ->
+	  aux (Id.List.assoc id named :: ids) avoid app need
 
       | (x, None) :: app, (None, (Name id, _, _)) :: need ->
 	  aux (x :: ids) avoid app need
@@ -244,25 +235,25 @@ let combine_params avoid fn applied needed =
 	    aux (t' :: ids) avoid' app need
 
       | (x,_) :: _, [] ->
-	  user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments")
+	  user_err_loc (Constrexpr_ops.constr_loc x,"",str "Typeclass does not expect more arguments")
   in aux [] avoid applied needed
 
 let combine_params_freevar =
   fun avoid (_, (na, _, _)) ->
     let id' = next_name_away_from na avoid in
-      (CRef (Ident (dummy_loc, id')), Idset.add id' avoid)
+      (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid)
 
 let destClassApp cl =
   match cl with
-    | CApp (loc, (None, CRef ref), l) -> loc, ref, List.map fst l
-    | CAppExpl (loc, (None, ref), l) -> loc, ref, l
-    | CRef ref -> loc_of_reference ref, ref, []
+    | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, List.map fst l
+    | CAppExpl (loc, (None, ref,_), l) -> loc, ref, l
+    | CRef (ref,_) -> loc_of_reference ref, ref, []
     | _ -> raise Not_found
 
 let destClassAppExpl cl =
   match cl with
-    | CApp (loc, (None, CRef ref), l) -> loc, ref, l
-    | CRef ref -> loc_of_reference ref, ref, []
+    | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, l
+    | CRef (ref,_) -> loc_of_reference ref, ref, []
     | _ -> raise Not_found
 
 let implicit_application env ?(allow_partial=true) f ty =
@@ -277,32 +268,37 @@ let implicit_application env ?(allow_partial=true) f ty =
     match is_class with
     | None -> ty, env
     | Some ((loc, id, par), gr) ->
-	let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in
+	let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in
 	let c, avoid =
 	  let c = class_info gr in
 	  let (ci, rd) = c.cl_context in
 	  if not allow_partial then
 	    begin
-	      let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in
-	      let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in
-		if needlen <> applen then
+              let opt_succ x n = match x with
+              | None -> succ n
+              | Some _ -> n
+              in
+	      let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in
+	      let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in
+		if not (Int.equal needlen applen) then
 		  Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd
 	    end;
 	  let pars = List.rev (List.combine ci rd) in
 	  let args, avoid = combine_params avoid f par pars in
-	    CAppExpl (loc, (None, id), args), avoid
+	    CAppExpl (loc, (None, id, None), args), avoid
 	in c, avoid
 
 let implicits_of_glob_constr ?(with_products=true) l =
-  let add_impl i na bk l =
- 	if bk = Implicit then
-	  let name =
-	    match na with
-	    | Name id -> Some id
-	    | Anonymous -> None
-	  in
-	    (ExplByPos (i, name), (true, true, true)) :: l
-	else l in
+  let add_impl i na bk l = match bk with
+  | Implicit ->
+    let name =
+      match na with
+      | Name id -> Some id
+      | Anonymous -> None
+    in
+    (ExplByPos (i, name), (true, true, true)) :: l
+  | _ -> l
+  in
   let rec aux i c =
     let abs na bk b =
       add_impl i na bk (aux (succ i) b)
@@ -310,15 +306,17 @@ let implicits_of_glob_constr ?(with_products=true) l =
       match c with
       | GProd (loc, na, bk, t, b) ->
 	  if with_products then abs na bk b
-	  else 
-	    (if bk = Implicit then
-	       msg_warning (str "Ignoring implicit status of product binder " ++ 
-			      pr_name na ++ str " and following binders");
-	     [])
+	  else
+            let () = match bk with
+            | Implicit ->
+	       msg_warning (strbrk "Ignoring implicit status of product binder " ++ 
+			      pr_name na ++ strbrk " and following binders")
+            | _ -> ()
+            in []
       | GLambda (loc, na, bk, t, b) -> abs na bk b
       | GLetIn (loc, na, t, b) -> aux i b
       | GRec (_, fix_kind, nas, args, tys, bds) ->
        let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in
-       list_fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb)
+       List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb)
       | _ -> []
   in aux 1 l
diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli
index ab2ad566..818f7e9a 100644
--- a/interp/implicit_quantifiers.mli
+++ b/interp/implicit_quantifiers.mli
@@ -1,54 +1,47 @@
 (************************************************************************)
 (*  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 Loc
 open Names
-open Decl_kinds
-open Term
-open Sign
-open Evd
-open Environ
-open Nametab
-open Mod_subst
 open Glob_term
-open Topconstr
-open Util
+open Constrexpr
 open Libnames
-open Typeclasses
+open Globnames
 
-val declare_generalizable : Vernacexpr.locality_flag -> (identifier located) list option -> unit
+val declare_generalizable : Vernacexpr.locality_flag -> (Id.t located) list option -> unit
 
-val ids_of_list : identifier list -> Idset.t
-val destClassApp : constr_expr -> loc * reference * constr_expr list
-val destClassAppExpl : constr_expr -> loc * reference * (constr_expr * explicitation located option) list
+val ids_of_list : Id.t list -> Id.Set.t
+val destClassApp : constr_expr -> Loc.t * reference * constr_expr list
+val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list
 
 (** Fragile, should be used only for construction a set of identifiers to avoid *)
 
-val free_vars_of_constr_expr : constr_expr -> ?bound:Idset.t ->
-  identifier list -> identifier list
+val free_vars_of_constr_expr : constr_expr -> ?bound:Id.Set.t ->
+  Id.t list -> Id.t list
 
 val free_vars_of_binders :
-  ?bound:Idset.t -> Names.identifier list -> local_binder list -> Idset.t * Names.identifier list
+  ?bound:Id.Set.t -> Id.t list -> local_binder list -> Id.Set.t * Id.t list
 
 (** Returns the generalizable free ids in left-to-right
    order with the location of their first occurence *)
 
-val generalizable_vars_of_glob_constr : ?bound:Idset.t -> ?allowed:Idset.t ->
-  glob_constr -> (Names.identifier * loc) list
+val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t ->
+  glob_constr -> (Id.t * Loc.t) list
 
-val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier
+val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t
 
 val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits
 
 val combine_params_freevar :
-  Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
-  Topconstr.constr_expr * Names.Idset.t
+  Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) ->
+  Constrexpr.constr_expr * Id.Set.t
 
-val implicit_application : Idset.t -> ?allow_partial:bool ->
-  (Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
-    Topconstr.constr_expr * Names.Idset.t) ->
-  constr_expr -> constr_expr * Idset.t
+val implicit_application : Id.Set.t -> ?allow_partial:bool ->
+  (Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) ->
+    Constrexpr.constr_expr * Id.Set.t) ->
+  constr_expr -> constr_expr * Id.Set.t
diff --git a/interp/interp.mllib b/interp/interp.mllib
index 546f277e..c9a03152 100644
--- a/interp/interp.mllib
+++ b/interp/interp.mllib
@@ -1,10 +1,12 @@
-Tok
-Lexer
+Stdarg
+Constrarg
+Genintern
+Constrexpr_ops
+Notation_ops
 Topconstr
 Ppextend
 Notation
 Dumpglob
-Genarg
 Syntax_def
 Smartlocate
 Reserve
diff --git a/interp/modintern.ml b/interp/modintern.ml
index 2feac863..fdc6e609 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -1,18 +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 Util
-open Names
-open Entries
+open Declarations
 open Libnames
-open Topconstr
+open Constrexpr
 open Constrintern
+open Misctypes
 
 type module_internalization_error =
   | NotAModuleNorModtype of string
@@ -21,172 +19,72 @@ type module_internalization_error =
 
 exception ModuleInternalizationError of module_internalization_error
 
-(*
-val error_declaration_not_path : module_struct_entry -> 'a
-
-val error_not_a_functor :  module_struct_entry -> 'a
-
-val error_not_equal : module_path -> module_path -> 'a
-
-val error_result_must_be_signature : unit -> 'a
-
-oval error_not_a_modtype_loc : loc -> string -> 'a
-
-val error_not_a_module_loc : loc -> string -> 'a
-
-val error_not_a_module_or_modtype_loc : loc -> string -> 'a
-
-val error_with_in_module : unit -> 'a
-
-val error_application_to_module_type : unit -> 'a
-*)
-
-let error_result_must_be_signature () =
-  error "The result module type must be a signature."
-
-let error_not_a_modtype_loc loc s =
-  Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModuleType s))
-
-let error_not_a_module_loc loc s =
-  Compat.Loc.raise loc (Modops.ModuleTypingError (Modops.NotAModule s))
+let error_not_a_module_loc kind loc qid =
+  let s = string_of_qualid qid in
+  let e = match kind with
+    | Module -> Modops.ModuleTypingError (Modops.NotAModule s)
+    | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s)
+    | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s)
+  in
+  Loc.raise loc e
 
-let error_not_a_module_nor_modtype_loc loc s =
-  Compat.Loc.raise loc (ModuleInternalizationError (NotAModuleNorModtype s))
+let error_application_to_not_path loc me =
+  Loc.raise loc (Modops.ModuleTypingError (Modops.ApplicationToNotPath me))
 
 let error_incorrect_with_in_module loc =
-  Compat.Loc.raise loc (ModuleInternalizationError IncorrectWithInModule)
+  Loc.raise loc (ModuleInternalizationError IncorrectWithInModule)
 
 let error_application_to_module_type loc =
-  Compat.Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication)
-
-
+  Loc.raise loc (ModuleInternalizationError IncorrectModuleApplication)
 
+(** Searching for a module name in the Nametab.
 
-let rec make_mp mp = function
-    [] -> mp
-  | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
+    According to the input module kind, modules or module types
+    or both are searched. The returned kind is never ModAny, and
+    it is equal to the input kind when this one isn't ModAny. *)
 
-(*
-(* Since module components are not put in the nametab we try to locate
-the module prefix *)
-exception BadRef
-
-let lookup_qualid (modtype:bool) qid =
-  let rec make_mp mp = function
-      [] -> mp
-    | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl
-  in
-  let rec find_module_prefix dir n =
-    if n<0 then raise Not_found;
-    let dir',dir'' = list_chop n dir in
-    let id',dir''' =
-      match dir'' with
-	| hd::tl -> hd,tl
-	| _ -> anomaly "This list should not be empty!"
-    in
-    let qid' = make_qualid dir' id' in
-      try
-	match Nametab.locate qid' with
-	  | ModRef mp -> mp,dir'''
-	  | _ -> raise BadRef
-      with
-	  Not_found -> find_module_prefix dir (pred n)
-  in
-    try Nametab.locate qid
-    with Not_found ->
-      let (dir,id) = repr_qualid qid in
-      let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in
-      let mp =
-	List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir'
-      in
-	if modtype then
-	  ModTypeRef (make_ln mp (label_of_id id))
-	else
-	  ModRef (MPdot (mp,label_of_id id))
-
-*)
-
-
-(* Search for the head of [qid] in [binders].
-   If found, returns the module_path/kernel_name created from the dirpath
-   and the basename. Searches Nametab otherwise.
-*)
-let lookup_module (loc,qid) =
+let lookup_module_or_modtype kind (loc,qid) =
   try
+    if kind == ModType then raise Not_found;
     let mp = Nametab.locate_module qid in
-      Dumpglob.dump_modref loc mp "modtype"; mp
-  with
-    | Not_found -> error_not_a_module_loc loc (string_of_qualid qid)
-
-let lookup_modtype (loc,qid) =
-  try
-    let mp = Nametab.locate_modtype qid in
-      Dumpglob.dump_modref loc mp "mod"; mp
-  with
-    | Not_found ->
-	error_not_a_modtype_loc loc (string_of_qualid qid)
-
-let lookup_module_or_modtype (loc,qid) =
-  try
-    let mp = Nametab.locate_module qid in
-    Dumpglob.dump_modref loc mp "modtype"; (mp,true)
-  with Not_found -> try
-    let mp = Nametab.locate_modtype qid in
-    Dumpglob.dump_modref loc mp "mod"; (mp,false)
+    Dumpglob.dump_modref loc mp "modtype"; (mp,Module)
   with Not_found ->
-    error_not_a_module_nor_modtype_loc loc (string_of_qualid qid)
+    try
+      if kind == Module then raise Not_found;
+      let mp = Nametab.locate_modtype qid in
+      Dumpglob.dump_modref loc mp "mod"; (mp,ModType)
+    with Not_found -> error_not_a_module_loc kind loc qid
+
+let lookup_module lqid = fst (lookup_module_or_modtype Module lqid)
 
 let transl_with_decl env = function
   | CWith_Module ((_,fqid),qid) ->
-      With_Module (fqid,lookup_module qid)
+      WithMod (fqid,lookup_module qid)
   | CWith_Definition ((_,fqid),c) ->
-      With_Definition (fqid,interp_constr Evd.empty env c)
+      WithDef (fqid,fst (interp_constr env Evd.empty c)) (*FIXME*)
 
 let loc_of_module = function
   | CMident (loc,_) | CMapply (loc,_,_) | CMwith (loc,_,_) -> loc
 
-let check_module_argument_is_path me' = function
-  | CMident _ -> ()
-  | (CMapply (loc,_,_) | CMwith (loc,_,_)) ->
-      Compat.Loc.raise loc
-        (Modops.ModuleTypingError (Modops.ApplicationToNotPath me'))
+(* Invariant : the returned kind is never ModAny, and it is
+   equal to the input kind when this one isn't ModAny. *)
 
-let rec interp_modexpr env = function
+let rec interp_module_ast env kind = function
   | CMident qid ->
-      MSEident (lookup_module qid)
+      let (mp,kind) = lookup_module_or_modtype kind qid in
+      (MEident mp, kind)
   | CMapply (_,me1,me2) ->
-      let me1' = interp_modexpr env me1 in
-      let me2' = interp_modexpr env me2 in
-      check_module_argument_is_path me2' me2;
-      MSEapply(me1',me2')
-  | CMwith (loc,_,_) -> error_incorrect_with_in_module loc
-
-
-let rec interp_modtype env = function
-  | CMident qid ->
-      MSEident (lookup_modtype qid)
-  | CMapply (_,mty1,me) ->
-      let mty' = interp_modtype env mty1 in
-      let me' = interp_modexpr env me in
-      check_module_argument_is_path me' me;
-      MSEapply(mty',me')
-  | CMwith (_,mty,decl) ->
-      let mty = interp_modtype env mty in
-      let decl = transl_with_decl env decl in
-	MSEwith(mty,decl)
-
-let rec interp_modexpr_or_modtype env = function
-  | CMident qid ->
-      let (mp,ismod) = lookup_module_or_modtype qid in
-      (MSEident mp, ismod)
-  | CMapply (_,me1,me2) ->
-      let me1',ismod1 = interp_modexpr_or_modtype env me1 in
-      let me2',ismod2 = interp_modexpr_or_modtype env me2 in
-      check_module_argument_is_path me2' me2;
-      if not ismod2 then error_application_to_module_type (loc_of_module me2);
-      (MSEapply (me1',me2'), ismod1)
+      let me1',kind1 = interp_module_ast env kind me1 in
+      let me2',kind2 = interp_module_ast env ModAny me2 in
+      let mp2 = match me2' with
+        | MEident mp -> mp
+        | _ -> error_application_to_not_path (loc_of_module me2) me2'
+      in
+      if kind2 == ModType then
+        error_application_to_module_type (loc_of_module me2);
+      (MEapply (me1',mp2), kind1)
   | CMwith (loc,me,decl) ->
-      let me,ismod = interp_modexpr_or_modtype env me in
+      let me,kind = interp_module_ast env kind me in
+      if kind == Module then error_incorrect_with_in_module loc;
       let decl = transl_with_decl env decl in
-      if ismod then error_incorrect_with_in_module loc;
-      (MSEwith(me,decl), ismod)
+      (MEwith(me,decl), kind)
diff --git a/interp/modintern.mli b/interp/modintern.mli
index d832ffc6..8b6d002e 100644
--- a/interp/modintern.mli
+++ b/interp/modintern.mli
@@ -1,18 +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 Declarations
 open Environ
 open Entries
-open Util
-open Libnames
-open Names
-open Topconstr
+open Constrexpr
+open Misctypes
 
 (** Module internalization errors *)
 
@@ -24,17 +21,11 @@ type module_internalization_error =
 exception ModuleInternalizationError of module_internalization_error
 
 (** Module expressions and module types are interpreted relatively to
-   possible functor or functor signature arguments. *)
-
-val interp_modtype : env -> module_ast -> module_struct_entry
-
-val interp_modexpr : env -> module_ast -> module_struct_entry
-
-(** The following function tries to interprete an ast as a module,
-   and in case of failure, interpretes this ast as a module type.
-   The boolean is true for a module, false for a module type *)
-
-val interp_modexpr_or_modtype : env -> module_ast ->
- module_struct_entry * bool
-
-val lookup_module : qualid located -> module_path
+   possible functor or functor signature arguments. When the input kind
+   is ModAny (i.e. module or module type), we tries to interprete this ast
+   as a module, and in case of failure, as a module type. The returned
+   kind is never ModAny, and it is equal to the input kind when this one
+   isn't ModAny. *)
+
+val interp_module_ast :
+  env -> module_kind -> module_ast -> module_struct_entry * module_kind
diff --git a/interp/notation.ml b/interp/notation.ml
index dddc8aad..aeec4b61 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -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 Errors
 open Util
 open Pp
 open Bigint
@@ -14,9 +15,11 @@ open Names
 open Term
 open Nametab
 open Libnames
-open Summary
+open Globnames
+open Constrexpr
+open Notation_term
 open Glob_term
-open Topconstr
+open Glob_ops
 open Ppextend
 (*i*)
 
@@ -40,24 +43,24 @@ open Ppextend
 
 type level = precedence * tolerability list
 type delimiters = string
-type notation_location = (dir_path * dir_path) * string
+type notation_location = (DirPath.t * DirPath.t) * string
 
 type scope = {
-  notations: (string, interpretation * notation_location) Gmap.t;
+  notations: (interpretation * notation_location) String.Map.t;
   delimiters: delimiters option
 }
 
-(* Uninterpreted notation map: notation -> level * dir_path *)
-let notation_level_map = ref Gmap.empty
+(* Uninterpreted notation map: notation -> level * DirPath.t *)
+let notation_level_map = ref String.Map.empty
 
 (* Scopes table: scope_name -> symbol_interpretation *)
-let scope_map = ref Gmap.empty
+let scope_map = ref String.Map.empty
 
 (* Delimiter table : delimiter -> scope_name *)
-let delimiters_map = ref Gmap.empty
+let delimiters_map = ref String.Map.empty
 
 let empty_scope = {
-  notations = Gmap.empty;
+  notations = String.Map.empty;
   delimiters = None
 }
 
@@ -65,22 +68,33 @@ let default_scope = "" (* empty name, not available from outside *)
 let type_scope = "type_scope" (* special scope used for interpreting types *)
 
 let init_scope_map () =
-  scope_map := Gmap.add default_scope empty_scope !scope_map;
-  scope_map := Gmap.add type_scope empty_scope !scope_map
+  scope_map := String.Map.add default_scope empty_scope !scope_map;
+  scope_map := String.Map.add type_scope empty_scope !scope_map
 
 (**********************************************************************)
 (* Operations on scopes *)
 
+let parenRelation_eq t1 t2 = match t1, t2 with
+| L, L | E, E | Any, Any -> true
+| Prec l1, Prec l2 -> Int.equal l1 l2
+| _ -> false
+
+let level_eq (l1, t1) (l2, t2) =
+  let tolerability_eq (i1, r1) (i2, r2) =
+    Int.equal i1 i2 && parenRelation_eq r1 r2
+  in
+  Int.equal l1 l2 && List.equal tolerability_eq t1 t2
+
 let declare_scope scope =
-  try let _ = Gmap.find scope !scope_map in ()
+  try let _ = String.Map.find scope !scope_map in ()
   with Not_found ->
 (*    Flags.if_warn message ("Creating scope "^scope);*)
-    scope_map := Gmap.add scope empty_scope !scope_map
+    scope_map := String.Map.add scope empty_scope !scope_map
 
 let error_unknown_scope sc = error ("Scope "^sc^" is not declared.")
 
 let find_scope scope =
-  try Gmap.find scope !scope_map
+  try String.Map.find scope !scope_map
   with Not_found -> error_unknown_scope scope
 
 let check_scope sc = let _ = find_scope sc in ()
@@ -89,11 +103,11 @@ let check_scope sc = let _ = find_scope sc in ()
    (now allowed after Open Scope) *)
 
 let normalize_scope sc =
-  try let _ = Gmap.find sc !scope_map in sc
+  try let _ = String.Map.find sc !scope_map in sc
   with Not_found ->
     try
-      let sc = Gmap.find sc !delimiters_map in
-      let _ = Gmap.find sc !scope_map in sc
+      let sc = String.Map.find sc !delimiters_map in
+      let _ = String.Map.find sc !scope_map in sc
     with Not_found -> error_unknown_scope sc
 
 (**********************************************************************)
@@ -102,12 +116,18 @@ let normalize_scope sc =
 type scope_elem = Scope of scope_name | SingleNotation of string
 type scopes = scope_elem list
 
+let scope_eq s1 s2 = match s1, s2 with
+| Scope s1, Scope s2
+| SingleNotation s1, SingleNotation s2 -> String.equal s1 s2
+| Scope _, SingleNotation _
+| SingleNotation _, Scope _ -> false
+
 let scope_stack = ref []
 
 let current_scopes () = !scope_stack
 
 let scope_is_open_in_scopes sc l =
-  List.mem (Scope sc) l
+  List.exists (function Scope sc' -> String.equal sc sc' | _ -> false) l
 
 let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack)
 
@@ -115,13 +135,14 @@ let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack)
 
 (* Exportation of scopes *)
 let open_scope i (_,(local,op,sc)) =
-  if i=1 then
+  if Int.equal i 1 then
     let sc = match sc with
       | Scope sc -> Scope (normalize_scope sc)
       | _ -> sc
     in
     scope_stack :=
-      if op then sc :: !scope_stack else list_except sc !scope_stack
+      if op then sc :: !scope_stack
+      else List.except scope_eq sc !scope_stack
 
 let cache_scope o =
   open_scope 1 o
@@ -165,24 +186,24 @@ let declare_delimiters scope key =
   let sc = find_scope scope in
   let newsc = { sc with delimiters = Some key } in
   begin match sc.delimiters with
-    | None -> scope_map := Gmap.add scope newsc !scope_map
-    | Some oldkey when oldkey = key -> ()
+    | None -> scope_map := String.Map.add scope newsc !scope_map
+    | Some oldkey when String.equal oldkey key -> ()
     | Some oldkey ->
-	Flags.if_warn msg_warning
-	  (str ("Overwriting previous delimiting key "^oldkey^" in scope "^scope));
-	scope_map := Gmap.add scope newsc !scope_map
+	msg_warning
+	  (strbrk ("Overwriting previous delimiting key "^oldkey^" in scope "^scope));
+	scope_map := String.Map.add scope newsc !scope_map
   end;
   try
-    let oldscope = Gmap.find key !delimiters_map in
-    if oldscope = scope then ()
+    let oldscope = String.Map.find key !delimiters_map in
+    if String.equal oldscope scope then ()
     else begin
-      Flags.if_warn msg_warning (str ("Hiding binding of key "^key^" to "^oldscope));
-      delimiters_map := Gmap.add key scope !delimiters_map
+      msg_warning (strbrk ("Hiding binding of key "^key^" to "^oldscope));
+      delimiters_map := String.Map.add key scope !delimiters_map
     end
-  with Not_found -> delimiters_map := Gmap.add key scope !delimiters_map
+  with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map
 
 let find_delimiters_scope loc key =
-  try Gmap.find key !delimiters_map
+  try String.Map.find key !delimiters_map
   with Not_found ->
     user_err_loc
     (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^"."))
@@ -200,29 +221,50 @@ type key =
   | RefKey of global_reference
   | Oth
 
+let key_compare k1 k2 = match k1, k2 with
+| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2
+| RefKey _, Oth -> -1
+| Oth, RefKey _ -> 1
+| Oth, Oth -> 0
+
+module KeyOrd = struct type t = key let compare = key_compare end
+module KeyMap = Map.Make(KeyOrd)
+
+type notation_rule = interp_rule * interpretation * int option
+
+let keymap_add key interp map =
+  let old = try KeyMap.find key map with Not_found -> [] in
+  KeyMap.add key (interp :: old) map
+
+let keymap_find key map =
+  try KeyMap.find key map
+  with Not_found -> []
+
 (* Scopes table : interpretation -> scope_name *)
-let notations_key_table = ref Gmapl.empty
-let prim_token_key_table = Hashtbl.create 7
+let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t)
+
+let prim_token_key_table = ref KeyMap.empty
 
 let glob_prim_constr_key = function
-  | GApp (_,GRef (_,ref),_) | GRef (_,ref) -> RefKey (canonical_gr ref)
+  | GApp (_,GRef (_,ref,_),_) | GRef (_,ref,_) -> RefKey (canonical_gr ref)
   | _ -> Oth
 
 let glob_constr_keys = function
-  | GApp (_,GRef (_,ref),_) -> [RefKey (canonical_gr ref); Oth]
-  | GRef (_,ref) -> [RefKey (canonical_gr ref)]
+  | GApp (_,GRef (_,ref,_),_) -> [RefKey (canonical_gr ref); Oth]
+  | GRef (_,ref,_) -> [RefKey (canonical_gr ref)]
   | _ -> [Oth]
 
 let cases_pattern_key = function
   | PatCstr (_,ref,_,_) -> RefKey (canonical_gr (ConstructRef ref))
   | _ -> Oth
 
-let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
-  | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
-  | AList (_,_,AApp (ARef ref,args),_,_)
-  | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args)
-  | ARef ref -> RefKey(canonical_gr ref), None
-  | AApp (_,args) -> Oth, Some (List.length args)
+let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *)
+  | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
+  | NList (_,_,NApp (NRef ref,args),_,_)
+  | NBinderList (_,_,NApp (NRef ref,args),_) ->
+      RefKey (canonical_gr ref), Some (List.length args)
+  | NRef ref -> RefKey(canonical_gr ref), None
+  | NApp (_,args) -> Oth, Some (List.length args)
   | _ -> Oth, None
 
 (**********************************************************************)
@@ -231,7 +273,7 @@ let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
 type required_module = full_path * string list
 
 type 'a prim_token_interpreter =
-    loc -> 'a -> glob_constr
+    Loc.t -> 'a -> glob_constr
 
 type cases_pattern_status = bool (* true = use prim token in patterns *)
 
@@ -239,7 +281,7 @@ type 'a prim_token_uninterpreter =
     glob_constr list * (glob_constr -> 'a option) * cases_pattern_status
 
 type internal_prim_token_interpreter =
-    loc -> prim_token -> required_module * (unit -> glob_constr)
+    Loc.t -> prim_token -> required_module * (unit -> glob_constr)
 
 let prim_token_interpreter_tab =
   (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t)
@@ -256,8 +298,8 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) =
   declare_scope sc;
   add_prim_token_interpreter sc interp;
   List.iter (fun pat ->
-      Hashtbl.add prim_token_key_table
-        (glob_prim_constr_key pat) (sc,uninterp,b))
+      prim_token_key_table := KeyMap.add
+        (glob_prim_constr_key pat) (sc,uninterp,b) !prim_token_key_table)
     patl
 
 let mkNumeral n = Numeral n
@@ -280,7 +322,7 @@ let check_required_module loc sc (sp,d) =
   with Not_found ->
     user_err_loc (loc,"prim_token_interpreter",
     str ("Cannot interpret in "^sc^" without requiring first module "
-    ^(list_last d)^"."))
+    ^(List.last d)^"."))
 
 (* Look if some notation or numeral printer in [scope] can be used in
    the scope stack [scopes], and if yes, using delimiters or not *)
@@ -288,27 +330,31 @@ let check_required_module loc sc (sp,d) =
 let find_with_delimiters = function
   | None -> None
   | Some scope ->
-      match (Gmap.find scope !scope_map).delimiters with
+      match (String.Map.find scope !scope_map).delimiters with
 	| Some key -> Some (Some scope, Some key)
 	| None -> None
 
 let rec find_without_delimiters find (ntn_scope,ntn) = function
   | Scope scope :: scopes ->
       (* Is the expected ntn/numpr attached to the most recently open scope? *)
-      if Some scope = ntn_scope then
+      begin match ntn_scope with
+      | Some scope' when String.equal scope scope' ->
 	Some (None,None)
-      else
+      | _ ->
 	(* If the most recently open scope has a notation/numeral printer
     	   but not the expected one then we need delimiters *)
 	if find scope then
 	  find_with_delimiters ntn_scope
 	else
 	  find_without_delimiters find (ntn_scope,ntn) scopes
+      end
   | SingleNotation ntn' :: scopes ->
-      if ntn_scope = None & ntn = Some ntn' then
-	Some (None,None)
-      else
+      begin match ntn_scope, ntn with
+      | None, Some ntn when String.equal ntn ntn' ->
+	Some (None, None)
+      | _ ->
 	find_without_delimiters find (ntn_scope,ntn) scopes
+      end
   | [] ->
       (* Can we switch to [scope]? Yes if it has defined delimiters *)
       find_with_delimiters ntn_scope
@@ -316,35 +362,43 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function
 (* Uninterpreted notation levels *)
 
 let declare_notation_level ntn level =
-  if Gmap.mem ntn !notation_level_map then
-    anomaly ("Notation "^ntn^" is already assigned a level");
-  notation_level_map := Gmap.add ntn level !notation_level_map
+  if String.Map.mem ntn !notation_level_map then
+    anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level");
+  notation_level_map := String.Map.add ntn level !notation_level_map
 
 let level_of_notation ntn =
-  Gmap.find ntn !notation_level_map
+  String.Map.find ntn !notation_level_map
 
 (* The mapping between notations and their interpretation *)
 
 let declare_notation_interpretation ntn scopt pat df =
   let scope = match scopt with Some s -> s | None -> default_scope in
   let sc = find_scope scope in
-  if Gmap.mem ntn sc.notations then
-    Flags.if_warn msg_warning (str ("Notation "^ntn^" was already used"^
-    (if scopt = None then "" else " in scope "^scope)));
-  let sc = { sc with notations = Gmap.add ntn (pat,df) sc.notations } in
-  scope_map := Gmap.add scope sc !scope_map;
-  if scopt = None then scope_stack := SingleNotation ntn :: !scope_stack
+  let () =
+    if String.Map.mem ntn sc.notations then
+    let which_scope = match scopt with
+    | None -> ""
+    | Some _ -> " in scope " ^ scope in
+    let message = "Notation " ^ ntn ^ " was already used" ^ which_scope in
+    msg_warning (strbrk message)
+  in
+  let sc = { sc with notations = String.Map.add ntn (pat,df) sc.notations } in
+  let () = scope_map := String.Map.add scope sc !scope_map in
+  begin match scopt with
+  | None -> scope_stack := SingleNotation ntn :: !scope_stack
+  | Some _ -> ()
+  end
 
 let declare_uninterpretation rule (metas,c as pat) =
-  let (key,n) = aconstr_key c in
-  notations_key_table := Gmapl.add key (rule,pat,n) !notations_key_table
+  let (key,n) = notation_constr_key c in
+  notations_key_table := keymap_add key (rule,pat,n) !notations_key_table
 
 let rec find_interpretation ntn find = function
   | [] -> raise Not_found
   | Scope scope :: scopes ->
       (try let (pat,df) = find scope in pat,(df,Some scope)
        with Not_found -> find_interpretation ntn find scopes)
-  | SingleNotation ntn'::scopes when ntn' = ntn ->
+  | SingleNotation ntn'::scopes when String.equal ntn' ntn ->
       (try let (pat,df) = find default_scope in pat,(df,None)
        with Not_found ->
          (* e.g. because single notation only for constr, not cases_pattern *)
@@ -353,7 +407,7 @@ let rec find_interpretation ntn find = function
       find_interpretation ntn find scopes
 
 let find_notation ntn sc =
-  Gmap.find ntn (find_scope sc).notations
+  String.Map.find ntn (find_scope sc).notations
 
 let notation_of_prim_token = function
   | Numeral n when is_pos_or_zero n -> to_string n
@@ -364,12 +418,12 @@ let find_prim_token g loc p sc =
   (* Try for a user-defined numerical notation *)
   try
     let (_,c),df = find_notation (notation_of_prim_token p) sc in
-    g (glob_constr_of_aconstr loc c),df
+    g (Notation_ops.glob_constr_of_notation_constr loc c),df
   with Not_found ->
   (* Try for a primitive numerical notation *)
   let (spdir,interp) = Hashtbl.find prim_token_interpreter_tab sc loc p in
   check_required_module loc sc spdir;
-  g (interp ()), ((dirpath (fst spdir),empty_dirpath),"")
+  g (interp ()), ((dirpath (fst spdir),DirPath.empty),"")
 
 let interp_prim_token_gen g loc p local_scopes =
   let scopes = make_current_scopes local_scopes in
@@ -384,90 +438,129 @@ let interp_prim_token_gen g loc p local_scopes =
 let interp_prim_token =
   interp_prim_token_gen (fun x -> x)
 
-let interp_prim_token_cases_pattern loc p name =
-  interp_prim_token_gen (cases_pattern_of_glob_constr name) loc p
+(** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *)
 
-let rec interp_notation loc ntn local_scopes =
+let rec rcp_of_glob looked_for = function
+  | GVar (loc,id) -> RCPatAtom (loc,Some id)
+  | GHole (loc,_,_,_) -> RCPatAtom (loc,None)
+  | GRef (loc,g,_) -> looked_for g; RCPatCstr (loc, g,[],[])
+  | GApp (loc,GRef (_,g,_),l) ->
+    looked_for g; RCPatCstr (loc, g, List.map (rcp_of_glob looked_for) l,[])
+  | _ -> raise Not_found
+
+let interp_prim_token_cases_pattern_expr loc looked_for p =
+  interp_prim_token_gen (rcp_of_glob looked_for) loc p
+
+let interp_notation loc ntn local_scopes =
   let scopes = make_current_scopes local_scopes in
   try find_interpretation ntn (find_notation ntn) scopes
   with Not_found ->
     user_err_loc
     (loc,"",str ("Unknown interpretation for notation \""^ntn^"\"."))
 
-let isGApp = function GApp _ -> true | _ -> false
-
 let uninterp_notations c =
-  list_map_append (fun key -> Gmapl.find key !notations_key_table)
+  List.map_append (fun key -> keymap_find key !notations_key_table)
     (glob_constr_keys c)
 
 let uninterp_cases_pattern_notations c =
-  Gmapl.find (cases_pattern_key c) !notations_key_table
+  keymap_find (cases_pattern_key c) !notations_key_table
+
+let uninterp_ind_pattern_notations ind =
+  keymap_find (RefKey (canonical_gr (IndRef ind))) !notations_key_table
 
 let availability_of_notation (ntn_scope,ntn) scopes =
   let f scope =
-    Gmap.mem ntn (Gmap.find scope !scope_map).notations in
+    String.Map.mem ntn (String.Map.find scope !scope_map).notations in
   find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes)
 
 let uninterp_prim_token c =
   try
     let (sc,numpr,_) =
-      Hashtbl.find prim_token_key_table (glob_prim_constr_key c) in
+      KeyMap.find (glob_prim_constr_key c) !prim_token_key_table in
     match numpr c with
-      | None -> raise No_match
+      | None -> raise Notation_ops.No_match
+      | Some n -> (sc,n)
+  with Not_found -> raise Notation_ops.No_match
+
+let uninterp_prim_token_ind_pattern ind args =
+  let ref = IndRef ind in
+  try
+    let k = RefKey (canonical_gr ref) in
+    let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in
+    if not b then raise Notation_ops.No_match;
+    let args' = List.map
+      (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in
+    let ref = GRef (Loc.ghost,ref,None) in
+    match numpr (GApp (Loc.ghost,ref,args')) with
+      | None -> raise Notation_ops.No_match
       | Some n -> (sc,n)
-  with Not_found -> raise No_match
+  with Not_found -> raise Notation_ops.No_match
 
 let uninterp_prim_token_cases_pattern c =
   try
     let k = cases_pattern_key c in
-    let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in
-    if not b then raise No_match;
+    let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in
+    if not b then raise Notation_ops.No_match;
     let na,c = glob_constr_of_closed_cases_pattern c in
     match numpr c with
-      | None -> raise No_match
+      | None -> raise Notation_ops.No_match
       | Some n -> (na,sc,n)
-  with Not_found -> raise No_match
+  with Not_found -> raise Notation_ops.No_match
 
 let availability_of_prim_token n printer_scope local_scopes =
   let f scope =
-    try ignore (Hashtbl.find prim_token_interpreter_tab scope dummy_loc n); true
+    try ignore (Hashtbl.find prim_token_interpreter_tab scope Loc.ghost n); true
     with Not_found -> false in
   let scopes = make_current_scopes local_scopes in
   Option.map snd (find_without_delimiters f (Some printer_scope,None) scopes)
 
 (* Miscellaneous *)
 
-let exists_notation_in_scope scopt ntn r =
-  let scope = match scopt with Some s -> s | None -> default_scope in
-  try
-    let sc = Gmap.find scope !scope_map in
-    let (r',_) = Gmap.find ntn sc.notations in
-    r' = r
-  with Not_found -> false
-
-let isAVar_or_AHole = function AVar _ | AHole _ -> true | _ -> false
+let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false
 
 (**********************************************************************)
 (* Mapping classes to scopes *)
 
-open Classops
+type scope_class = ScopeRef of global_reference | ScopeSort
 
-let class_scope_map = ref (Gmap.empty : (cl_typ,scope_name) Gmap.t)
+let scope_class_compare sc1 sc2 = match sc1, sc2 with
+| ScopeRef gr1, ScopeRef gr2 -> RefOrdered.compare gr1 gr2
+| ScopeRef _, ScopeSort -> -1
+| ScopeSort, ScopeRef _ -> 1
+| ScopeSort, ScopeSort -> 0
 
-let _ =
-  class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
+let scope_class_of_reference x = ScopeRef x
 
-let declare_class_scope sc cl =
-  class_scope_map := Gmap.add cl sc !class_scope_map
+let compute_scope_class t =
+  let t', _ = decompose_appvect (Reductionops.whd_betaiotazeta Evd.empty t) in
+  match kind_of_term t' with
+  | Var _ | Const _ | Ind _ -> ScopeRef (global_of_constr t')
+  | Proj (p, c) -> ScopeRef (ConstRef (Projection.constant p))
+  | Sort _ -> ScopeSort
+  |  _ -> raise Not_found
 
-let find_class_scope cl =
-  Gmap.find cl !class_scope_map
+module ScopeClassOrd =
+struct
+  type t = scope_class
+  let compare = scope_class_compare
+end
 
-let find_class_scope_opt = function
-  | None -> None
-  | Some cl -> try Some (find_class_scope cl) with Not_found -> None
+module ScopeClassMap = Map.Make(ScopeClassOrd)
 
-let find_class t = fst (find_class_type Evd.empty t)
+let initial_scope_class_map : scope_name ScopeClassMap.t =
+  ScopeClassMap.add ScopeSort "type_scope" ScopeClassMap.empty
+
+let scope_class_map = ref initial_scope_class_map
+
+let declare_scope_class sc cl =
+  scope_class_map := ScopeClassMap.add cl sc !scope_class_map
+
+let find_scope_class cl =
+  ScopeClassMap.find cl !scope_class_map
+
+let find_scope_class_opt = function
+  | None -> None
+  | Some cl -> try Some (find_scope_class cl) with Not_found -> None
 
 (**********************************************************************)
 (* Special scopes associated to arguments of a global reference *)
@@ -475,26 +568,37 @@ let find_class t = fst (find_class_type Evd.empty t)
 let rec compute_arguments_classes t =
   match kind_of_term (Reductionops.whd_betaiotazeta Evd.empty t) with
     | Prod (_,t,u) ->
-	let cl = try Some (find_class t) with Not_found -> None in
+	let cl = try Some (compute_scope_class t) with Not_found -> None in
 	cl :: compute_arguments_classes u
     | _ -> []
 
 let compute_arguments_scope_full t =
   let cls = compute_arguments_classes t in
-  let scs = List.map find_class_scope_opt cls in
+  let scs = List.map find_scope_class_opt cls in
   scs, cls
 
 let compute_arguments_scope t = fst (compute_arguments_scope_full t)
 
-(** When merging scope list, we give priority to the first one (computed
-    by substitution), using the second one (user given or earlier automatic)
-    as fallback *)
+let compute_type_scope t =
+  find_scope_class_opt (try Some (compute_scope_class t) with Not_found -> None)
+
+let compute_scope_of_global ref =
+  find_scope_class_opt (Some (ScopeRef ref))
+
+(** Updating a scope list, thanks to a list of argument classes
+    and the current Bind Scope base. When some current scope
+    have been manually given, the corresponding argument class
+    is emptied below, so this manual scope will be preserved. *)
 
-let rec merge_scope sc1 sc2 = match sc1, sc2 with
-  | [], _ -> sc2
-  | _, [] -> sc1
-  | Some sc :: sc1, _ :: sc2 -> Some sc :: merge_scope sc1 sc2
-  | None :: sc1, sco :: sc2 -> sco :: merge_scope sc1 sc2
+let update_scope cl sco =
+  match find_scope_class_opt cl with
+  | None -> sco
+  | sco' -> sco'
+
+let rec update_scopes cls scl = match cls, scl with
+  | [], _ -> scl
+  | _, [] -> List.map find_scope_class_opt cls
+  | cl :: cls, sco :: scl -> update_scope cl sco :: update_scopes cls scl
 
 let arguments_scope = ref Refmap.empty
 
@@ -505,43 +609,56 @@ type arguments_scope_discharge_request =
 
 let load_arguments_scope _ (_,(_,r,scl,cls)) =
   List.iter (Option.iter check_scope) scl;
-  arguments_scope := Refmap.add r (scl,cls) !arguments_scope
+  let initial_stamp = ScopeClassMap.empty in
+  arguments_scope := Refmap.add r (scl,cls,initial_stamp) !arguments_scope
 
 let cache_arguments_scope o =
   load_arguments_scope 1 o
 
+let subst_scope_class subst cs = match cs with
+  | ScopeSort -> Some cs
+  | ScopeRef t ->
+      let (t',c) = subst_global subst t in
+      if t == t' then Some cs
+      else try Some (compute_scope_class c) with Not_found -> None
+
 let subst_arguments_scope (subst,(req,r,scl,cls)) =
   let r' = fst (subst_global subst r) in
-  let subst_cl cl =
-    try Option.smartmap (subst_cl_typ subst) cl with Not_found -> None in
-  let cls' = list_smartmap subst_cl cls in
-  let scl' = merge_scope (List.map find_class_scope_opt cls') scl in
-  let scl'' = List.map (Option.map Declaremods.subst_scope) scl' in
-  (ArgsScopeNoDischarge,r',scl'',cls')
+  let subst_cl ocl = match ocl with
+    | None -> ocl
+    | Some cl ->
+        match subst_scope_class subst cl with
+        | Some cl'  as ocl' when cl' != cl -> ocl'
+        | _ -> ocl in
+  let cls' = List.smartmap subst_cl cls in
+  (ArgsScopeNoDischarge,r',scl,cls')
 
 let discharge_arguments_scope (_,(req,r,l,_)) =
-  if req = ArgsScopeNoDischarge or (isVarRef r & Lib.is_in_section r) then None
+  if req == ArgsScopeNoDischarge || (isVarRef r && Lib.is_in_section r) then None
   else Some (req,Lib.discharge_global r,l,[])
 
 let classify_arguments_scope (req,_,_,_ as obj) =
-  if req = ArgsScopeNoDischarge then Dispose else Substitute obj
+  if req == ArgsScopeNoDischarge then Dispose else Substitute obj
 
 let rebuild_arguments_scope (req,r,l,_) =
   match req with
     | ArgsScopeNoDischarge -> assert false
     | ArgsScopeAuto ->
-        let scs,cls = compute_arguments_scope_full (Global.type_of_global r) in
+        let scs,cls = compute_arguments_scope_full (fst(Universes.type_of_global r)(*FIXME?*)) in
 	(req,r,scs,cls)
     | ArgsScopeManual ->
 	(* Add to the manually given scopes the one found automatically
-           for the extra parameters of the section *)
-	let l',cls = compute_arguments_scope_full (Global.type_of_global r) in
-	let l1,_ = list_chop (List.length l' - List.length l) l' in
-	(req,r,l1@l,cls)
+           for the extra parameters of the section. Discard the classes
+           of the manually given scopes to avoid further re-computations. *)
+	let l',cls = compute_arguments_scope_full (Global.type_of_global_unsafe r) in
+        let nparams = List.length l' - List.length l in
+	let l1 = List.firstn nparams l' in
+        let cls1 = List.firstn nparams cls in
+	(req,r,l1@l,cls1)
 
 type arguments_scope_obj =
     arguments_scope_discharge_request * global_reference *
-      scope_name option list * Classops.cl_typ option list
+      scope_name option list * scope_class option list
 
 let inArgumentsScope : arguments_scope_obj -> obj =
   declare_object {(default_object "ARGUMENTS-SCOPE") with
@@ -557,17 +674,27 @@ let is_local local ref = local || isVarRef ref && Lib.is_in_section ref
 let declare_arguments_scope_gen req r (scl,cls) =
   Lib.add_anonymous_leaf (inArgumentsScope (req,r,scl,cls))
 
-let declare_arguments_scope local ref scl =
-  let req =
-    if is_local local ref then ArgsScopeNoDischarge else ArgsScopeManual in
-  declare_arguments_scope_gen req ref (scl,[])
+let declare_arguments_scope local r scl =
+  let req = if is_local local r then ArgsScopeNoDischarge else ArgsScopeManual
+  in
+  (* We empty the list of argument classes to disable futher scope
+     re-computations and keep these manually given scopes. *)
+  declare_arguments_scope_gen req r (scl,[])
 
 let find_arguments_scope r =
-  try fst (Refmap.find r !arguments_scope)
+  try
+    let (scl,cls,stamp) = Refmap.find r !arguments_scope in
+    let cur_stamp = !scope_class_map in
+    if stamp == cur_stamp then scl
+    else
+      (* Recent changes in the Bind Scope base, we re-compute the scopes *)
+      let scl' = update_scopes cls scl in
+      arguments_scope := Refmap.add r (scl',cls,cur_stamp) !arguments_scope;
+      scl'
   with Not_found -> []
 
 let declare_ref_arguments_scope ref =
-  let t = Global.type_of_global ref in
+  let t = Global.type_of_global_unsafe ref in
   declare_arguments_scope_gen ArgsScopeAuto ref (compute_arguments_scope_full t)
 
 
@@ -576,10 +703,18 @@ let declare_ref_arguments_scope ref =
 
 type symbol =
   | Terminal of string
-  | NonTerminal of identifier
-  | SProdList of identifier * symbol list
+  | NonTerminal of Id.t
+  | SProdList of Id.t * symbol list
   | Break of int
 
+let rec symbol_eq s1 s2 = match s1, s2 with
+| Terminal s1, Terminal s2 -> String.equal s1 s2
+| NonTerminal id1, NonTerminal id2 -> Id.equal id1 id2
+| SProdList (id1, l1), SProdList (id2, l2) ->
+  Id.equal id1 id2 && List.equal symbol_eq l1 l2
+| Break i1, Break i2 -> Int.equal i1 i2
+| _ -> false
+
 let rec string_of_symbol = function
   | NonTerminal _ -> ["_"]
   | Terminal "_" -> ["'_'"]
@@ -602,8 +737,8 @@ let decompose_notation_key s =
     in
     let tok =
       match String.sub s n (pos-n) with
-      | "_" -> NonTerminal (id_of_string "_")
-      | s -> Terminal (drop_simple_quotes s) in
+      | "_" -> NonTerminal (Id.of_string "_")
+      | s -> Terminal (String.drop_simple_quotes s) in
     decomp_ntn (tok::dirs) (pos+1)
   in
     decomp_ntn [] 0
@@ -616,29 +751,35 @@ let pr_delimiters_info = function
   | Some key -> str "Delimiting key is " ++ str key
 
 let classes_of_scope sc =
-  Gmap.fold (fun cl sc' l -> if sc = sc' then cl::l else l) !class_scope_map []
+  ScopeClassMap.fold (fun cl sc' l -> if String.equal sc sc' then cl::l else l) !scope_class_map []
+
+let pr_scope_class = function
+  | ScopeSort -> str "Sort"
+  | ScopeRef t -> pr_global_env Id.Set.empty t
 
 let pr_scope_classes sc =
   let l = classes_of_scope sc in
-  if l = [] then mt()
-  else
-    hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++
-      spc() ++ prlist_with_sep spc pr_class l) ++ fnl()
+  match l with
+  | [] -> mt ()
+  | _ :: l ->
+    let opt_s = match l with [] -> "" | _ -> "es" in
+    hov 0 (str ("Bound to class" ^ opt_s) ++
+      spc() ++ prlist_with_sep spc pr_scope_class l) ++ fnl()
 
 let pr_notation_info prglob ntn c =
   str "\"" ++ str ntn ++ str "\" := " ++
-  prglob (glob_constr_of_aconstr dummy_loc c)
+  prglob (Notation_ops.glob_constr_of_notation_constr Loc.ghost c)
 
 let pr_named_scope prglob scope sc =
- (if scope = default_scope then
-   match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with
+ (if String.equal scope default_scope then
+   match String.Map.cardinal sc.notations with
      | 0 -> str "No lonely notation"
-     | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s")
+     | n -> str "Lonely notation" ++ (if Int.equal n 1 then mt() else str"s")
   else
     str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters)
   ++ fnl ()
   ++ pr_scope_classes scope
-  ++ Gmap.fold
+  ++ String.Map.fold
        (fun ntn ((_,r),(_,df)) strm ->
 	 pr_notation_info prglob df r ++ fnl () ++ strm)
        sc.notations (mt ())
@@ -646,16 +787,19 @@ let pr_named_scope prglob scope sc =
 let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope)
 
 let pr_scopes prglob =
- Gmap.fold
+ String.Map.fold
    (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm)
    !scope_map (mt ())
 
 let rec find_default ntn = function
-  | Scope scope::_ when Gmap.mem ntn (find_scope scope).notations ->
-      Some scope
-  | SingleNotation ntn'::_ when ntn = ntn' -> Some default_scope
-  | _::scopes -> find_default ntn scopes
   | [] -> None
+  | Scope scope :: scopes ->
+    if String.Map.mem ntn (find_scope scope).notations then
+      Some scope
+    else find_default ntn scopes
+  | SingleNotation ntn' :: scopes ->
+    if String.equal ntn ntn' then Some default_scope
+    else find_default ntn scopes
 
 let factorize_entries = function
   | [] -> []
@@ -663,29 +807,32 @@ let factorize_entries = function
       let (ntn,l_of_ntn,rest) =
 	List.fold_left
           (fun (a',l,rest) (a,c) ->
-	    if a = a' then (a',c::l,rest) else (a,[c],(a',l)::rest))
+	    if String.equal a a' then (a',c::l,rest) else (a,[c],(a',l)::rest))
 	  (ntn,[c],[]) l in
       (ntn,l_of_ntn)::rest
 
 let browse_notation strict ntn map =
-  let find =
-    if String.contains ntn ' ' then (=) ntn
-    else fun ntn' ->
+  let find ntn' =
+    if String.contains ntn ' ' then String.equal ntn ntn'
+    else
       let toks = decompose_notation_key ntn' in
-      let trms = List.filter (function Terminal _ -> true | _ -> false) toks in
-      if strict then [Terminal ntn] = trms else List.mem (Terminal ntn) trms in
+      let get_terminals = function Terminal ntn -> Some ntn | _ -> None in
+      let trms = List.map_filter get_terminals toks in
+      if strict then String.List.equal [ntn] trms
+      else String.List.mem ntn trms
+  in
   let l =
-    Gmap.fold
+    String.Map.fold
       (fun scope_name sc ->
-	Gmap.fold (fun ntn ((_,r),df) l ->
+	String.Map.fold (fun ntn ((_,r),df) l ->
 	  if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations)
       map [] in
-  List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) l
+  List.sort (fun x y -> String.compare (fst x) (fst y)) l
 
 let global_reference_of_notation test (ntn,(sc,c,_)) =
   match c with
-  | ARef ref when test ref -> Some (ntn,sc,ref)
-  | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref ->
+  | NRef ref when test ref -> Some (ntn,sc,ref)
+  | NApp (NRef ref, l) when List.for_all isNVar_or_NHole l && test ref ->
       Some (ntn,sc,ref)
   | _ -> None
 
@@ -700,7 +847,8 @@ let error_notation_not_reference loc ntn =
 let interp_notation_as_global_reference loc test ntn sc =
   let scopes = match sc with
   | Some sc ->
-      Gmap.add sc (find_scope (find_delimiters_scope dummy_loc sc)) Gmap.empty
+      let scope = find_scope (find_delimiters_scope Loc.ghost sc) in
+      String.Map.add sc scope String.Map.empty
   | None -> !scope_map in
   let ntns = browse_notation true ntn scopes in
   let refs = List.map (global_reference_of_notation test) ntns in
@@ -708,7 +856,12 @@ let interp_notation_as_global_reference loc test ntn sc =
   | [_,_,ref] -> ref
   | [] -> error_notation_not_reference loc ntn
   | refs ->
-      let f (ntn,sc,ref) = find_default ntn !scope_stack = Some sc in
+      let f (ntn,sc,ref) =
+        let def = find_default ntn !scope_stack in
+        match def with
+        | None -> false
+        | Some sc' -> String.equal sc sc'
+      in
       match List.filter f refs with
       | [_,_,ref] -> ref
       | [] -> error_notation_not_reference loc ntn
@@ -717,9 +870,9 @@ let interp_notation_as_global_reference loc test ntn sc =
 let locate_notation prglob ntn scope =
   let ntns = factorize_entries (browse_notation false ntn !scope_map) in
   let scopes = Option.fold_right push_scope scope !scope_stack in
-  if ntns = [] then
-    str "Unknown notation"
-  else
+  match ntns with
+  | [] -> str "Unknown notation"
+  | _ ->
     t (str "Notation            " ++
     tab () ++ str "Scope     " ++ tab () ++ fnl () ++
     prlist (fun (ntn,l) ->
@@ -728,35 +881,35 @@ let locate_notation prglob ntn scope =
 	(fun (sc,r,(_,df)) ->
 	  hov 0 (
 	    pr_notation_info prglob df r ++ tbrk (1,2) ++
-	    (if sc = default_scope then mt () else (str ": " ++ str sc)) ++
+	    (if String.equal sc default_scope then mt () else (str ": " ++ str sc)) ++
 	    tbrk (1,2) ++
-	    (if Some sc = scope then str "(default interpretation)" else mt ())
+	    (if Option.equal String.equal (Some sc) scope then str "(default interpretation)" else mt ())
 	    ++ fnl ()))
 	l) ntns)
 
 let collect_notation_in_scope scope sc known =
-  assert (scope <> default_scope);
-  Gmap.fold
+  assert (not (String.equal scope default_scope));
+  String.Map.fold
     (fun ntn ((_,r),(_,df)) (l,known as acc) ->
-      if List.mem ntn known then acc else ((df,r)::l,ntn::known))
+      if String.List.mem ntn known then acc else ((df,r)::l,ntn::known))
     sc.notations ([],known)
 
 let collect_notations stack =
   fst (List.fold_left
     (fun (all,knownntn as acc) -> function
       | Scope scope ->
-	  if List.mem_assoc scope all then acc
+	  if String.List.mem_assoc scope all then acc
 	  else
 	    let (l,knownntn) =
 	      collect_notation_in_scope scope (find_scope scope) knownntn in
 	    ((scope,l)::all,knownntn)
       | SingleNotation ntn ->
-	  if List.mem ntn knownntn then (all,knownntn)
+	  if String.List.mem ntn knownntn then (all,knownntn)
 	  else
 	    let ((_,r),(_,df)) =
-	      Gmap.find ntn (find_scope default_scope).notations in
+	      String.Map.find ntn (find_scope default_scope).notations in
 	    let all' = match all with
-	      | (s,lonelyntn)::rest when s = default_scope ->
+	      | (s,lonelyntn)::rest when String.equal s default_scope ->
 		  (s,(df,r)::lonelyntn)::rest
 	      | _ ->
 		  (default_scope,[df,r])::all in
@@ -768,8 +921,8 @@ let pr_visible_in_scope prglob (scope,ntns) =
     List.fold_right
       (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm)
       ntns (mt ()) in
-  (if scope = default_scope then
-     str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt())
+  (if String.equal scope default_scope then
+     str "Lonely notation" ++ (match ntns with [_] -> mt () | _ -> str "s")
    else
      str "Visible in scope " ++ str scope)
   ++ fnl () ++ strm
@@ -787,25 +940,36 @@ let pr_visibility prglob = function
 (* Mapping notations to concrete syntax *)
 
 type unparsing_rule = unparsing list * precedence
-
+type extra_unparsing_rules = (string * string) list
 (* Concrete syntax for symbolic-extension table *)
 let printing_rules =
-  ref (Gmap.empty : (string,unparsing_rule) Gmap.t)
+  ref (String.Map.empty : (unparsing_rule * extra_unparsing_rules) String.Map.t)
 
-let declare_notation_printing_rule ntn unpl =
-  printing_rules := Gmap.add ntn unpl !printing_rules
+let declare_notation_printing_rule ntn ~extra unpl =
+  printing_rules := String.Map.add ntn (unpl,extra) !printing_rules
 
 let find_notation_printing_rule ntn =
-  try Gmap.find ntn !printing_rules
-  with Not_found -> anomaly ("No printing rule found for "^ntn)
+  try fst (String.Map.find ntn !printing_rules)
+  with Not_found -> anomaly (str "No printing rule found for " ++ str ntn)
+let find_notation_extra_printing_rules ntn =
+  try snd (String.Map.find ntn !printing_rules)
+  with Not_found -> []
+let add_notation_extra_printing_rule ntn k v =
+  try
+    printing_rules := 
+      let p, pp = String.Map.find ntn !printing_rules in
+      String.Map.add ntn (p, (k,v) :: pp) !printing_rules
+  with Not_found ->
+    user_err_loc (Loc.ghost,"add_notation_extra_printing_rule",
+      str "No such Notation.")
 
 (**********************************************************************)
 (* Synchronisation with reset *)
 
-let freeze () =
+let freeze _ =
  (!scope_map, !notation_level_map, !scope_stack, !arguments_scope,
   !delimiters_map, !notations_key_table, !printing_rules,
-  !class_scope_map)
+  !scope_class_map)
 
 let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
   scope_map := scm;
@@ -815,27 +979,26 @@ let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) =
   arguments_scope := asc;
   notations_key_table := fkm;
   printing_rules := pprules;
-  class_scope_map := clsc
+  scope_class_map := clsc
 
 let init () =
   init_scope_map ();
-(*
-  scope_stack := Gmap.empty
-  arguments_scope := Refmap.empty
-*)
-  notation_level_map := Gmap.empty;
-  delimiters_map := Gmap.empty;
-  notations_key_table := Gmapl.empty;
-  printing_rules := Gmap.empty;
-  class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty
+  notation_level_map := String.Map.empty;
+  delimiters_map := String.Map.empty;
+  notations_key_table := KeyMap.empty;
+  printing_rules := String.Map.empty;
+  scope_class_map := initial_scope_class_map
 
 let _ =
-  declare_summary "symbols"
-    { freeze_function = freeze;
-      unfreeze_function = unfreeze;
-      init_function = init }
+  Summary.declare_summary "symbols"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init }
 
 let with_notation_protection f x =
-  let fs = freeze () in
+  let fs = freeze false in
   try let a = f x in unfreeze fs; a
-  with reraise -> unfreeze fs; raise reraise
+  with reraise ->
+    let reraise = Errors.push reraise in
+    let () = unfreeze fs in
+    iraise reraise
diff --git a/interp/notation.mli b/interp/notation.mli
index bb2d5090..c66115cb 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -1,19 +1,19 @@
 (************************************************************************)
 (*  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 Util
 open Pp
 open Bigint
 open Names
-open Nametab
 open Libnames
+open Globnames
+open Constrexpr
 open Glob_term
-open Topconstr
+open Notation_term
 open Ppextend
 
 (** Notations *)
@@ -34,6 +34,8 @@ val declare_scope : scope_name -> unit
 
 val current_scopes : unit -> scopes
 
+val level_eq : level -> level -> bool
+
 (** Check where a scope is opened or not in a scope list, or in
  * the current opened scopes *)
 val scope_is_open_in_scopes : scope_name -> scopes -> bool
@@ -53,7 +55,7 @@ val find_scope : scope_name -> scope
 (** Declare delimiters for printing *)
 
 val declare_delimiters : scope_name -> delimiters -> unit
-val find_delimiters_scope : loc -> delimiters -> scope_name
+val find_delimiters_scope : Loc.t -> delimiters -> scope_name
 
 (** {6 Declare and uses back and forth an interpretation of primitive token } *)
 
@@ -62,12 +64,12 @@ val find_delimiters_scope : loc -> delimiters -> scope_name
    negative numbers are not supported, the interpreter must fail with
    an appropriate error message *)
 
-type notation_location = (dir_path * dir_path) * string
+type notation_location = (DirPath.t * DirPath.t) * string
 type required_module = full_path * string list
 type cases_pattern_status = bool (** true = use prim token in patterns *)
 
 type 'a prim_token_interpreter =
-    loc -> 'a -> glob_constr
+    Loc.t -> 'a -> glob_constr
 
 type 'a prim_token_uninterpreter =
     glob_constr list * (glob_constr -> 'a option) * cases_pattern_status
@@ -81,10 +83,10 @@ val declare_string_interpreter : scope_name -> required_module ->
 (** Return the [term]/[cases_pattern] bound to a primitive token in a
    given scope context*)
 
-val interp_prim_token : loc -> prim_token -> local_scopes ->
+val interp_prim_token : Loc.t -> prim_token -> local_scopes ->
   glob_constr * (notation_location * scope_name option)
-val interp_prim_token_cases_pattern : loc -> prim_token -> name ->
-  local_scopes -> cases_pattern * (notation_location * scope_name option)
+val interp_prim_token_cases_pattern_expr : Loc.t -> (global_reference -> unit) -> prim_token ->
+  local_scopes -> raw_cases_pattern_expr * (notation_location * scope_name option)
 
 (** Return the primitive token associated to a [term]/[cases_pattern];
    raise [No_match] if no such token *)
@@ -92,7 +94,9 @@ val interp_prim_token_cases_pattern : loc -> prim_token -> name ->
 val uninterp_prim_token :
   glob_constr -> scope_name * prim_token
 val uninterp_prim_token_cases_pattern :
-  cases_pattern -> name * scope_name * prim_token
+  cases_pattern -> Name.t * scope_name * prim_token
+val uninterp_prim_token_ind_pattern :
+ inductive -> cases_pattern list -> scope_name * prim_token
 
 val availability_of_prim_token :
   prim_token -> scope_name -> local_scopes -> delimiters option option
@@ -110,14 +114,15 @@ val declare_notation_interpretation : notation -> scope_name option ->
 val declare_uninterpretation : interp_rule -> interpretation -> unit
 
 (** Return the interpretation bound to a notation *)
-val interp_notation : loc -> notation -> local_scopes ->
+val interp_notation : Loc.t -> notation -> local_scopes ->
       interpretation * (notation_location * scope_name option)
 
+type notation_rule = interp_rule * interpretation * int option
+
 (** Return the possible notations for a given term *)
-val uninterp_notations : glob_constr ->
-      (interp_rule * interpretation * int option) list
-val uninterp_cases_pattern_notations : cases_pattern ->
-      (interp_rule * interpretation * int option) list
+val uninterp_notations : glob_constr -> notation_rule list
+val uninterp_cases_pattern_notations : cases_pattern -> notation_rule list
+val uninterp_ind_pattern_notations : inductive -> notation_rule list
 
 (** Test if a notation is available in the scopes 
    context [scopes]; if available, the result is not None; the first 
@@ -132,36 +137,43 @@ val level_of_notation : notation -> level (** raise [Not_found] if no level *)
 
 (** {6 Miscellaneous} *)
 
-val interp_notation_as_global_reference : loc -> (global_reference -> bool) ->
+val interp_notation_as_global_reference : Loc.t -> (global_reference -> bool) ->
       notation -> delimiters option -> global_reference
 
-(** Checks for already existing notations *)
-val exists_notation_in_scope : scope_name option -> notation ->
-      interpretation -> bool
-
 (** Declares and looks for scopes associated to arguments of a global ref *)
 val declare_arguments_scope :
   bool (** true=local *) -> global_reference -> scope_name option list -> unit
 
 val find_arguments_scope : global_reference -> scope_name option list
 
-val declare_class_scope : scope_name -> Classops.cl_typ -> unit
+type scope_class
+
+val scope_class_of_reference : global_reference -> scope_class
+val subst_scope_class :
+  Mod_subst.substitution -> scope_class -> scope_class option
+
+val declare_scope_class : scope_name -> scope_class -> unit
 val declare_ref_arguments_scope : global_reference -> unit
 
 val compute_arguments_scope : Term.types -> scope_name option list
+val compute_type_scope : Term.types -> scope_name option
+val compute_scope_of_global : global_reference -> scope_name option
 
 (** Building notation key *)
 
 type symbol =
   | Terminal of string
-  | NonTerminal of identifier
-  | SProdList of identifier * symbol list
+  | NonTerminal of Id.t
+  | SProdList of Id.t * symbol list
   | Break of int
 
+val symbol_eq : symbol -> symbol -> bool
+
 val make_notation_key : symbol list -> notation
 val decompose_notation_key : notation -> symbol list
 
 (** Prints scopes (expects a pure aconstr printer) *)
+val pr_scope_class : scope_class -> std_ppcmds
 val pr_scope : (glob_constr -> std_ppcmds) -> scope_name -> std_ppcmds
 val pr_scopes : (glob_constr -> std_ppcmds) -> std_ppcmds
 val locate_notation : (glob_constr -> std_ppcmds) -> notation ->
@@ -173,8 +185,12 @@ val pr_visibility: (glob_constr -> std_ppcmds) -> scope_name option -> std_ppcmd
 
 (** Declare and look for the printing rule for symbolic notations *)
 type unparsing_rule = unparsing list * precedence
-val declare_notation_printing_rule : notation -> unparsing_rule -> unit
+type extra_unparsing_rules = (string * string) list
+val declare_notation_printing_rule :
+  notation -> extra:extra_unparsing_rules -> unparsing_rule -> unit
 val find_notation_printing_rule : notation -> unparsing_rule
+val find_notation_extra_printing_rules : notation -> extra_unparsing_rules
+val add_notation_extra_printing_rule : notation -> string -> string -> unit
 
 (** Rem: printing rules for primitive token are canonical *)
 
diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml
new file mode 100644
index 00000000..c91c7815
--- /dev/null
+++ b/interp/notation_ops.ml
@@ -0,0 +1,856 @@
+(************************************************************************)
+(*  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 Pp
+open Errors
+open Util
+open Names
+open Nameops
+open Globnames
+open Misctypes
+open Glob_term
+open Glob_ops
+open Mod_subst
+open Notation_term
+open Decl_kinds
+
+(**********************************************************************)
+(* Re-interpret a notation as a glob_constr, taking care of binders     *)
+
+let name_to_ident = function
+  | Anonymous -> Errors.error "This expression should be a simple identifier."
+  | Name id -> id
+
+let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na
+
+let rec cases_pattern_fold_map loc g e = function
+  | PatVar (_,na) ->
+      let e',na' = g e na in e', PatVar (loc,na')
+  | PatCstr (_,cstr,patl,na) ->
+      let e',na' = g e na in
+      let e',patl' = List.fold_map (cases_pattern_fold_map loc g) e patl in
+      e', PatCstr (loc,cstr,patl',na')
+
+let rec subst_glob_vars l = function
+  | GVar (_,id) as r -> (try Id.List.assoc id l with Not_found -> r)
+  | GProd (loc,Name id,bk,t,c) ->
+      let id =
+	try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id
+	with Not_found -> id in
+      GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
+  | GLambda (loc,Name id,bk,t,c) ->
+      let id =
+	try match Id.List.assoc id l with GVar(_,id') -> id' | _ -> id
+	with Not_found -> id in
+      GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
+  | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *)
+
+let ldots_var = Id.of_string ".."
+
+let glob_constr_of_notation_constr_with_binders loc g f e = function
+  | NVar id -> GVar (loc,id)
+  | NApp (a,args) -> GApp (loc,f e a, List.map (f e) args)
+  | NList (x,y,iter,tail,swap) ->
+      let t = f e tail in let it = f e iter in
+      let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in
+      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
+      let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in
+      subst_glob_vars outerl it
+  | NBinderList (x,y,iter,tail) ->
+      let t = f e tail in let it = f e iter in
+      let innerl = [(ldots_var,t);(x,GVar(loc,y))] in
+      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
+      let outerl = [(ldots_var,inner)] in
+      subst_glob_vars outerl it
+  | NLambda (na,ty,c) ->
+      let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c)
+  | NProd (na,ty,c) ->
+      let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c)
+  | NLetIn (na,b,c) ->
+      let e',na = g e na in GLetIn (loc,na,f e b,f e' c)
+  | NCases (sty,rtntypopt,tml,eqnl) ->
+      let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') ->
+	let e',t' = match t with
+	| None -> e',None
+	| Some (ind,nal) ->
+	  let e',nal' = List.fold_right (fun na (e',nal) ->
+	      let e',na' = g e' na in e',na'::nal) nal (e',[]) in
+	  e',Some (loc,ind,nal') in
+	let e',na' = g e' na in
+	(e',(f e tm,(na',t'))::tml')) tml (e,[]) in
+      let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in
+      let eqnl' = List.map (fun (patl,rhs) ->
+	let ((idl,e),patl) =
+	  List.fold_map (cases_pattern_fold_map loc fold) ([],e) patl in
+	(loc,idl,patl,f e rhs)) eqnl in
+      GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl')
+  | NLetTuple (nal,(na,po),b,c) ->
+      let e',nal = List.fold_map g e nal in
+      let e'',na = g e na in
+      GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c)
+  | NIf (c,(na,po),b1,b2) ->
+      let e',na = g e na in
+      GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2)
+  | NRec (fk,idl,dll,tl,bl) ->
+      let e,dll = Array.fold_map (List.fold_map (fun e (na,oc,b) ->
+	  let e,na = g e na in
+	  (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in
+      let e',idl = Array.fold_map (to_id g) e idl in
+      GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl)
+  | NCast (c,k) -> GCast (loc,f e c,Miscops.map_cast_type (f e) k)
+  | NSort x -> GSort (loc,x)
+  | NHole (x, naming, arg)  -> GHole (loc, x, naming, arg)
+  | NPatVar n -> GPatVar (loc,(false,n))
+  | NRef x -> GRef (loc,x,None)
+
+let glob_constr_of_notation_constr loc x =
+  let rec aux () x =
+    glob_constr_of_notation_constr_with_binders loc (fun () id -> ((),id)) aux () x
+  in aux () x
+
+(****************************************************************************)
+(* Translating a glob_constr into a notation, interpreting recursive patterns *)
+
+let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r)
+let add_name r = function Anonymous -> () | Name id -> add_id r id
+
+let split_at_recursive_part c =
+  let sub = ref None in
+  let rec aux = function
+  | GApp (loc0,GVar(loc,v),c::l) when Id.equal v ldots_var ->
+      begin match !sub with
+      | None ->
+        let () = sub := Some c in
+        begin match l with
+        | [] -> GVar (loc, ldots_var)
+        | _ :: _ -> GApp (loc0, GVar (loc, ldots_var), l)
+        end
+      | Some _ ->
+        (* Not narrowed enough to find only one recursive part *)
+        raise Not_found
+      end
+  | c -> map_glob_constr aux c in
+  let outer_iterator = aux c in
+  match !sub with
+  | None -> (* No recursive pattern found *) raise Not_found
+  | Some c ->
+  match outer_iterator with
+  | GVar (_,v) when Id.equal v ldots_var -> (* Not enough context *) raise Not_found
+  | _ -> outer_iterator, c
+
+let on_true_do b f c = if b then (f c; b) else b
+
+let compare_glob_constr f add t1 t2 = match t1,t2 with
+  | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2
+  | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1)
+  | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2
+  | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2)
+    when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 ->
+    on_true_do (f ty1 ty2 && f c1 c2) add na1
+  | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2)
+    when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 ->
+      on_true_do (f ty1 ty2 && f c1 c2) add na1
+  | GHole _, GHole _ -> true
+  | GSort (_,s1), GSort (_,s2) -> Miscops.glob_sort_eq s1 s2
+  | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when Name.equal na1 na2 ->
+      on_true_do (f b1 b2 && f c1 c2) add na1
+  | (GCases _ | GRec _
+    | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_
+  | _,(GCases _ | GRec _
+      | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _)
+      -> error "Unsupported construction in recursive notations."
+  | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _
+    | GHole _ | GSort _ | GLetIn _), _
+      -> false
+
+let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2
+
+let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1)
+
+let check_is_hole id = function GHole _ -> () | t ->
+  user_err_loc (loc_of_glob_constr t,"",
+    strbrk "In recursive notation with binders, " ++ pr_id id ++
+    strbrk " is expected to come without type.")
+
+let compare_recursive_parts found f (iterator,subc) =
+  let diff = ref None in
+  let terminator = ref None in
+  let rec aux c1 c2 = match c1,c2 with
+  | GVar(_,v), term when Id.equal v ldots_var ->
+      (* We found the pattern *)
+      assert (match !terminator with None -> true | Some _ -> false);
+      terminator := Some term;
+      true
+  | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when Id.equal v ldots_var ->
+      (* We found the pattern, but there are extra arguments *)
+      (* (this allows e.g. alternative (recursive) notation of application) *)
+      assert (match !terminator with None -> true | Some _ -> false);
+      terminator := Some term;
+      List.for_all2eq aux l1 l2
+  | GVar (_,x), GVar (_,y) when not (Id.equal x y) ->
+      (* We found the position where it differs *)
+      let lassoc = match !terminator with None -> false | Some _ -> true in
+      let x,y = if lassoc then y,x else x,y in
+      begin match !diff with
+      | None ->
+        let () = diff := Some (x, y, Some lassoc) in
+        true
+      | Some _ -> false
+      end
+  | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term)
+  | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) ->
+      (* We found a binding position where it differs *)
+      check_is_hole x t_x;
+      check_is_hole y t_y;
+      begin match !diff with
+      | None ->
+        let () = diff := Some (x, y, None) in
+        aux c term
+      | Some _ -> false
+      end
+  | _ ->
+      compare_glob_constr aux (add_name found) c1 c2 in
+  if aux iterator subc then
+    match !diff with
+    | None ->
+	let loc1 = loc_of_glob_constr iterator in
+	let loc2 = loc_of_glob_constr (Option.get !terminator) in
+	(* Here, we would need a loc made of several parts ... *)
+	user_err_loc (subtract_loc loc1 loc2,"",
+          str "Both ends of the recursive pattern are the same.")
+    | Some (x,y,Some lassoc) ->
+	let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in
+	let iterator =
+	  f (if lassoc then subst_glob_vars [y,GVar(Loc.ghost,x)] iterator
+	  else iterator) in
+	(* found have been collected by compare_constr *)
+	found := newfound;
+	NList (x,y,iterator,f (Option.get !terminator),lassoc)
+    | Some (x,y,None) ->
+	let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in
+	let iterator = f iterator in
+	(* found have been collected by compare_constr *)
+	found := newfound;
+	NBinderList (x,y,iterator,f (Option.get !terminator))
+  else
+    raise Not_found
+
+let notation_constr_and_vars_of_glob_constr a =
+  let found = ref ([],[],[]) in
+  let rec aux c =
+    let keepfound = !found in
+    (* n^2 complexity but small and done only once per notation *)
+    try compare_recursive_parts found aux' (split_at_recursive_part c)
+    with Not_found ->
+    found := keepfound;
+    match c with
+    | GApp (_,GVar (loc,f),[c]) when Id.equal f ldots_var ->
+	(* Fall on the second part of the recursive pattern w/o having
+	   found the first part *)
+	user_err_loc (loc,"",
+	str "Cannot find where the recursive pattern starts.")
+    | c ->
+	aux' c
+  and aux' = function
+  | GVar (_,id) -> add_id found id; NVar id
+  | GApp (_,g,args) -> NApp (aux g, List.map aux args)
+  | GLambda (_,na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c)
+  | GProd (_,na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c)
+  | GLetIn (_,na,b,c) -> add_name found na; NLetIn (na,aux b,aux c)
+  | GCases (_,sty,rtntypopt,tml,eqnl) ->
+      let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in
+      NCases (sty,Option.map aux rtntypopt,
+        List.map (fun (tm,(na,x)) ->
+	  add_name found na;
+	  Option.iter
+	    (fun (_,_,nl) -> List.iter (add_name found) nl) x;
+          (aux tm,(na,Option.map (fun (_,ind,nal) -> (ind,nal)) x))) tml,
+        List.map f eqnl)
+  | GLetTuple (loc,nal,(na,po),b,c) ->
+      add_name found na;
+      List.iter (add_name found) nal;
+      NLetTuple (nal,(na,Option.map aux po),aux b,aux c)
+  | GIf (loc,c,(na,po),b1,b2) ->
+      add_name found na;
+      NIf (aux c,(na,Option.map aux po),aux b1,aux b2)
+  | GRec (_,fk,idl,dll,tl,bl) ->
+      Array.iter (add_id found) idl;
+      let dll = Array.map (List.map (fun (na,bk,oc,b) ->
+	 if bk != Explicit then
+	   error "Binders marked as implicit not allowed in notations.";
+	 add_name found na; (na,Option.map aux oc,aux b))) dll in
+      NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl)
+  | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k)
+  | GSort (_,s) -> NSort s
+  | GHole (_,w,naming,arg) -> NHole (w, naming, arg)
+  | GRef (_,r,_) -> NRef r
+  | GPatVar (_,(_,n)) -> NPatVar n
+  | GEvar _ ->
+      error "Existential variables not allowed in notations."
+
+  in
+  let t = aux a in
+  (* Side effect *)
+  t, !found
+
+let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b'
+
+let check_variables nenv (found,foundrec,foundrecbinding) =
+  let recvars = nenv.ninterp_rec_vars in
+  let fold _ y accu = Id.Set.add y accu in
+  let useless_vars = Id.Map.fold fold recvars Id.Set.empty in
+  let filter y _ = not (Id.Set.mem y useless_vars) in
+  let vars = Id.Map.filter filter nenv.ninterp_var_type in
+  let check_recvar x =
+    if Id.List.mem x found then
+      errorlabstrm "" (pr_id x ++
+	strbrk " should only be used in the recursive part of a pattern.") in
+  let check (x, y) = check_recvar x; check_recvar y in
+  let () = List.iter check foundrec in
+  let () = List.iter check foundrecbinding in
+  let check_bound x =
+    if not (Id.List.mem x found) then
+      if Id.List.mem_assoc x foundrec ||
+         Id.List.mem_assoc x foundrecbinding ||
+         Id.List.mem_assoc_sym x foundrec ||
+         Id.List.mem_assoc_sym x foundrecbinding
+      then
+	error
+          (Id.to_string x ^
+          " should not be bound in a recursive pattern of the right-hand side.")
+      else nenv.ninterp_only_parse <- true
+  in
+  let check_pair s x y where =
+    if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then
+      errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++
+	str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++
+	str " position as part of a recursive pattern.") in
+  let check_type x typ =
+    match typ with
+    | NtnInternTypeConstr ->
+	begin
+	  try check_pair "term" x (Id.Map.find x recvars) foundrec
+	  with Not_found -> check_bound x
+	end
+    | NtnInternTypeBinder ->
+	begin
+	  try check_pair "binding" x (Id.Map.find x recvars) foundrecbinding
+	  with Not_found -> check_bound x
+	end
+    | NtnInternTypeIdent -> check_bound x in
+  Id.Map.iter check_type vars
+
+let notation_constr_of_glob_constr nenv a =
+  let a, found = notation_constr_and_vars_of_glob_constr a in
+  let () = check_variables nenv found in
+  a
+
+(* Substitution of kernel names, avoiding a list of bound identifiers *)
+
+let notation_constr_of_constr avoiding t =
+  let t = Detyping.detype false avoiding (Global.env()) Evd.empty t in
+  let nenv = {
+    ninterp_var_type = Id.Map.empty;
+    ninterp_rec_vars = Id.Map.empty;
+    ninterp_only_parse = false;
+  } in
+  notation_constr_of_glob_constr nenv t
+
+let rec subst_pat subst pat =
+  match pat with
+  | PatVar _ -> pat
+  | PatCstr (loc,((kn,i),j),cpl,n) ->
+      let kn' = subst_mind subst kn
+      and cpl' = List.smartmap (subst_pat subst) cpl in
+        if kn' == kn && cpl' == cpl then pat else
+          PatCstr (loc,((kn',i),j),cpl',n)
+
+let rec subst_notation_constr subst bound raw =
+  match raw with
+  | NRef ref ->
+      let ref',t = subst_global subst ref in
+	if ref' == ref then raw else
+	  notation_constr_of_constr bound t
+
+  | NVar _ -> raw
+
+  | NApp (r,rl) ->
+      let r' = subst_notation_constr subst bound r
+      and rl' = List.smartmap (subst_notation_constr subst bound) rl in
+	if r' == r && rl' == rl then raw else
+	  NApp(r',rl')
+
+  | NList (id1,id2,r1,r2,b) ->
+      let r1' = subst_notation_constr subst bound r1
+      and r2' = subst_notation_constr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  NList (id1,id2,r1',r2',b)
+
+  | NLambda (n,r1,r2) ->
+      let r1' = subst_notation_constr subst bound r1
+      and r2' = subst_notation_constr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  NLambda (n,r1',r2')
+
+  | NProd (n,r1,r2) ->
+      let r1' = subst_notation_constr subst bound r1
+      and r2' = subst_notation_constr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  NProd (n,r1',r2')
+
+  | NBinderList (id1,id2,r1,r2) ->
+      let r1' = subst_notation_constr subst bound r1
+      and r2' = subst_notation_constr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  NBinderList (id1,id2,r1',r2')
+
+  | NLetIn (n,r1,r2) ->
+      let r1' = subst_notation_constr subst bound r1
+      and r2' = subst_notation_constr subst bound r2 in
+	if r1' == r1 && r2' == r2 then raw else
+	  NLetIn (n,r1',r2')
+
+  | NCases (sty,rtntypopt,rl,branches) ->
+      let rtntypopt' = Option.smartmap (subst_notation_constr subst bound) rtntypopt
+      and rl' = List.smartmap
+        (fun (a,(n,signopt) as x) ->
+	  let a' = subst_notation_constr subst bound a in
+	  let signopt' = Option.map (fun ((indkn,i),nal as z) ->
+	    let indkn' = subst_mind subst indkn in
+	    if indkn == indkn' then z else ((indkn',i),nal)) signopt in
+	  if a' == a && signopt' == signopt then x else (a',(n,signopt')))
+        rl
+      and branches' = List.smartmap
+                        (fun (cpl,r as branch) ->
+                           let cpl' = List.smartmap (subst_pat subst) cpl
+                           and r' = subst_notation_constr subst bound r in
+                             if cpl' == cpl && r' == r then branch else
+                               (cpl',r'))
+                        branches
+      in
+        if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' &&
+          rl' == rl && branches' == branches then raw else
+          NCases (sty,rtntypopt',rl',branches')
+
+  | NLetTuple (nal,(na,po),b,c) ->
+      let po' = Option.smartmap (subst_notation_constr subst bound) po
+      and b' = subst_notation_constr subst bound b
+      and c' = subst_notation_constr subst bound c in
+	if po' == po && b' == b && c' == c then raw else
+	  NLetTuple (nal,(na,po'),b',c')
+
+  | NIf (c,(na,po),b1,b2) ->
+      let po' = Option.smartmap (subst_notation_constr subst bound) po
+      and b1' = subst_notation_constr subst bound b1
+      and b2' = subst_notation_constr subst bound b2
+      and c' = subst_notation_constr subst bound c in
+	if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else
+	  NIf (c',(na,po'),b1',b2')
+
+  | NRec (fk,idl,dll,tl,bl) ->
+      let dll' =
+	Array.smartmap (List.smartmap (fun (na,oc,b as x) ->
+	  let oc' =  Option.smartmap (subst_notation_constr subst bound) oc in
+	  let b' =  subst_notation_constr subst bound b in
+	  if oc' == oc && b' == b then x else (na,oc',b'))) dll in
+      let tl' = Array.smartmap (subst_notation_constr subst bound) tl in
+      let bl' = Array.smartmap (subst_notation_constr subst bound) bl in
+      if dll' == dll && tl' == tl && bl' == bl then raw else
+	  NRec (fk,idl,dll',tl',bl')
+
+  | NPatVar _ | NSort _ -> raw
+
+  | NHole (knd, naming, solve) ->
+    let nknd = match knd with
+    | Evar_kinds.ImplicitArg (ref, i, b) ->
+      let nref, _ = subst_global subst ref in
+      if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b)
+    | _ -> knd
+    in
+    let nsolve = Option.smartmap (Genintern.generic_substitute subst) solve in
+    if nsolve == solve && nknd == knd then raw
+    else NHole (nknd, naming, nsolve)
+
+  | NCast (r1,k) ->
+      let r1' = subst_notation_constr subst bound r1 in
+      let k' = Miscops.smartmap_cast_type (subst_notation_constr subst bound) k in
+      if r1' == r1 && k' == k then raw else NCast(r1',k')
+
+let subst_interpretation subst (metas,pat) =
+  let bound = List.map fst metas in
+  (metas,subst_notation_constr subst bound pat)
+
+(* Pattern-matching glob_constr and notation_constr *)
+
+let abstract_return_type_context pi mklam tml rtno =
+  Option.map (fun rtn ->
+    let nal =
+      List.flatten (List.map (fun (_,(na,t)) ->
+	match t with Some x -> (pi x)@[na] | None -> [na]) tml) in
+    List.fold_right mklam nal rtn)
+    rtno
+
+let abstract_return_type_context_glob_constr =
+  abstract_return_type_context (fun (_,_,nal) -> nal)
+    (fun na c ->
+      GLambda(Loc.ghost,na,Explicit,GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c))
+
+let abstract_return_type_context_notation_constr =
+  abstract_return_type_context snd
+    (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c))
+
+exception No_match
+
+let rec alpha_var id1 id2 = function
+  | (i1,i2)::_ when Id.equal i1 id1 -> Id.equal i2 id2
+  | (i1,i2)::_ when Id.equal i2 id2 -> Id.equal i1 id1
+  | _::idl -> alpha_var id1 id2 idl
+  | [] -> Id.equal id1 id2
+
+let add_env alp (sigma,sigmalist,sigmabinders) var v =
+  (* Check that no capture of binding variables occur *)
+  if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match;
+  (* TODO: handle the case of multiple occs in different scopes *)
+  ((var,v)::sigma,sigmalist,sigmabinders)
+
+let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v =
+  try
+    let v' = Id.List.assoc var sigma in
+    match v, v' with
+    | GHole _, _ -> fullsigma
+    | _, GHole _ ->
+      add_env alp (Id.List.remove_assoc var sigma,sigmalist,sigmabinders) var v
+    | _, _ ->
+        if glob_constr_eq v v' then fullsigma
+        else raise No_match
+  with Not_found -> add_env alp fullsigma var v
+
+let bind_binder (sigma,sigmalist,sigmabinders) x bl =
+  (sigma,sigmalist,(x,List.rev bl)::sigmabinders)
+
+let match_fix_kind fk1 fk2 =
+  match (fk1,fk2) with
+  | GCoFix n1, GCoFix n2 -> Int.equal n1 n2
+  | GFix (nl1,n1), GFix (nl2,n2) ->
+      let test (n1, _) (n2, _) = match n1, n2 with
+      | _, None -> true
+      | Some id1, Some id2 -> Int.equal id1 id2
+      | _ -> false
+      in
+      Int.equal n1 n2 &&
+      Array.for_all2 test nl1 nl2
+  | _ -> false
+
+let match_opt f sigma t1 t2 = match (t1,t2) with
+  | None, None -> sigma
+  | Some t1, Some t2 -> f sigma t1 t2
+  | _ -> raise No_match
+
+let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
+  | (_,Name id2) when Id.List.mem id2 (fst metas) ->
+      let rhs = match na1 with
+      | Name id1 -> GVar (Loc.ghost,id1)
+      | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in
+      alp, bind_env alp sigma id2 rhs
+  | (Name id1,Name id2) -> (id1,id2)::alp,sigma
+  | (Anonymous,Anonymous) -> alp,sigma
+  | _ -> raise No_match
+
+let rec match_cases_pattern_binders metas acc pat1 pat2 =
+  match (pat1,pat2) with
+  | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2
+  | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2)
+      when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) ->
+      List.fold_left2 (match_cases_pattern_binders metas)
+	(match_names metas acc na1 na2) patl1 patl2
+  | _ -> raise No_match
+
+let glue_letin_with_decls = true
+
+let rec match_iterated_binders islambda decls = function
+  | GLambda (_,na,bk,t,b) when islambda ->
+      match_iterated_binders islambda ((na,bk,None,t)::decls) b
+  | GProd (_,(Name _ as na),bk,t,b) when not islambda ->
+      match_iterated_binders islambda ((na,bk,None,t)::decls) b
+  | GLetIn (loc,na,c,b) when glue_letin_with_decls ->
+      match_iterated_binders islambda
+	((na,Explicit (*?*), Some c,GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None))::decls) b
+  | b -> (decls,b)
+
+let remove_sigma x (sigmavar,sigmalist,sigmabinders) =
+  (Id.List.remove_assoc x sigmavar,sigmalist,sigmabinders)
+
+let match_abinderlist_with_app match_fun metas sigma rest x iter termin =
+  let rec aux sigma acc rest =
+    try
+      let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
+      let rest = Id.List.assoc ldots_var (pi1 sigma) in
+      let b =
+        match Id.List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false
+      in
+      let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
+      aux sigma (b::acc) rest
+    with No_match when not (List.is_empty acc) ->
+      acc, match_fun metas sigma rest termin in
+  let bl,sigma = aux sigma [] rest in
+  bind_binder sigma x bl
+
+let match_alist match_fun metas sigma rest x iter termin lassoc =
+  let rec aux sigma acc rest =
+    try
+      let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
+      let rest = Id.List.assoc ldots_var (pi1 sigma) in
+      let t = Id.List.assoc x (pi1 sigma) in
+      let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
+      aux sigma (t::acc) rest
+    with No_match when not (List.is_empty acc) ->
+      acc, match_fun metas sigma rest termin in
+  let l,sigma = aux sigma [] rest in
+  (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma)
+
+let does_not_come_from_already_eta_expanded_var =
+  (* This is hack to avoid looping on a rule with rhs of the form *)
+  (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *)
+  (* "F (fun x => H x)" and "H x" is recursively matched against the same *)
+  (* rule, giving "H (fun x' => x x')" and so on. *)
+  (* Ideally, we would need the type of the expression to know which of *)
+  (* the arguments applied to it can be eta-expanded without looping. *)
+  (* The following test is then an approximation of what can be done *)
+  (* optimally (whether other looping situations can occur remains to be *)
+  (* checked). *)
+  function GVar _ -> false | _ -> true
+
+let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 =
+  match (a1,a2) with
+
+  (* Matching notation variable *)
+  | r1, NVar id2 when Id.List.mem id2 tmetas -> bind_env alp sigma id2 r1
+
+  (* Matching recursive notations for terms *)
+  | r1, NList (x,_,iter,termin,lassoc) ->
+      match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc
+
+  (* Matching recursive notations for binders: ad hoc cases supporting let-in *)
+  | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name id2,_,b2),termin)->
+      let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in
+      (* TODO: address the possibility that termin is a Lambda itself *)
+      match_in u alp metas (bind_binder sigma x decls) b termin
+  | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name id2,_,b2),termin)
+      when na1 != Anonymous ->
+      let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in
+      (* TODO: address the possibility that termin is a Prod itself *)
+      match_in u alp metas (bind_binder sigma x decls) b termin
+  (* Matching recursive notations for binders: general case *)
+  | r, NBinderList (x,_,iter,termin) ->
+      match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin
+
+  (* Matching individual binders as part of a recursive pattern *)
+  | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) when Id.List.mem id blmetas ->
+      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+  | GProd (_,na,bk,t,b1), NProd (Name id,_,b2)
+      when Id.List.mem id blmetas && na != Anonymous ->
+      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+
+  (* Matching compositionally *)
+  | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma
+  | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma
+  | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma
+  | GApp (loc,f1,l1), NApp (f2,l2) ->
+      let n1 = List.length l1 and n2 = List.length l2 in
+      let f1,l1,f2,l2 =
+	if n1 < n2 then
+	  let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22
+	else if n1 > n2 then
+	  let l11,l12 = List.chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2
+	else f1,l1, f2, l2 in
+      let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in
+      List.fold_left2 (match_ may_use_eta u alp metas)
+        (match_in u alp metas sigma f1 f2) l1 l2
+  | GLambda (_,na1,_,t1,b1), NLambda (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GProd (_,na1,_,t1,b1), NProd (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GLetIn (_,na1,t1,b1), NLetIn (na2,t2,b2) ->
+     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
+  | GCases (_,sty1,rtno1,tml1,eqnl1), NCases (sty2,rtno2,tml2,eqnl2)
+      when sty1 == sty2
+	 && Int.equal (List.length tml1) (List.length tml2)
+	 && Int.equal (List.length eqnl1) (List.length eqnl2) ->
+      let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in
+      let rtno2' = abstract_return_type_context_notation_constr tml2 rtno2 in
+      let sigma =
+	try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2'
+	with Option.Heterogeneous -> raise No_match
+      in
+      let sigma = List.fold_left2
+      (fun s (tm1,_) (tm2,_) ->
+        match_in u alp metas s tm1 tm2) sigma tml1 tml2 in
+      List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2
+  | GLetTuple (_,nal1,(na1,to1),b1,c1), NLetTuple (nal2,(na2,to2),b2,c2)
+      when Int.equal (List.length nal1) (List.length nal2) ->
+      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
+      let sigma = match_in u alp metas sigma b1 b2 in
+      let (alp,sigma) =
+	List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in
+      match_in u alp metas sigma c1 c2
+  | GIf (_,a1,(na1,to1),b1,c1), NIf (a2,(na2,to2),b2,c2) ->
+      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
+      List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2]
+  | GRec (_,fk1,idl1,dll1,tl1,bl1), NRec (fk2,idl2,dll2,tl2,bl2)
+      when match_fix_kind fk1 fk2 && Int.equal (Array.length idl1) (Array.length idl2) &&
+	Array.for_all2 (fun l1 l2 -> Int.equal (List.length l1) (List.length l2)) dll1 dll2
+	->
+      let alp,sigma = Array.fold_left2
+	(List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) ->
+	  let sigma =
+	    match_in u alp metas
+              (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2
+	  in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in
+      let sigma = Array.fold_left2 (match_in u alp metas) sigma tl1 tl2 in
+      let alp,sigma = Array.fold_right2 (fun id1 id2 alsig ->
+	match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in
+      Array.fold_left2 (match_in u alp metas) sigma bl1 bl2
+  | GCast(_,c1,CastConv t1), NCast (c2,CastConv t2)
+  | GCast(_,c1,CastVM t1), NCast (c2,CastVM t2) ->
+      match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2
+  | GCast(_,c1, CastCoerce), NCast(c2, CastCoerce) ->
+      match_in u alp metas sigma c1 c2
+  | GSort (_,GType _), NSort (GType _) when not u -> sigma
+  | GSort (_,s1), NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma
+  | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
+  | a, NHole _ -> sigma
+
+  (* On the fly eta-expansion so as to use notations of the form
+     "exists x, P x" for "ex P"; ensure at least one constructor is
+     consumed to avoid looping; expects type not given because don't know
+     otherwise how to ensure it corresponds to a well-typed eta-expansion;
+     we make an exception for types which are metavariables: this is useful e.g.
+     to print "{x:_ & P x}" knowing that notation "{x & P x}" is not defined. *)
+  | b1, NLambda (Name id,(NHole _ | NVar _ as t2),b2) when inner ->
+      let id' = Namegen.next_ident_away id (free_glob_vars b1) in
+      let t1 = GHole(Loc.ghost,Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in
+      let sigma = match t2 with
+      | NHole _ -> sigma
+      | NVar id2 -> bind_env alp sigma id2 t1
+      | _ -> assert false in
+      match_in u alp metas (bind_binder sigma id [(Name id',Explicit,None,t1)])
+       (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2
+
+  | (GRec _ | GEvar _), _
+  | _,_ -> raise No_match
+
+and match_in u = match_ true u
+
+and match_hd u = match_ false u
+
+and match_binders u alp metas na1 na2 sigma b1 b2 =
+  let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in
+  match_in u alp metas sigma b1 b2
+
+and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
+  (* patl1 and patl2 have the same length because they respectively
+     correspond to some tml1 and tml2 that have the same length *)
+  let (alp,sigma) =
+    List.fold_left2 (match_cases_pattern_binders metas)
+      (alp,sigma) patl1 patl2 in
+  match_in u alp metas sigma rhs1 rhs2
+
+let match_notation_constr u c (metas,pat) =
+  let test (_, (_, x)) = match x with NtnTypeBinderList -> false | _ -> true in
+  let vars = List.partition test metas in
+  let vars = (List.map fst (fst vars), List.map fst (snd vars)) in
+  let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in
+  (* Reorder canonically the substitution *)
+  let find x =
+    try Id.List.assoc x terms
+    with Not_found ->
+      (* Happens for binders bound to Anonymous *)
+      (* Find a better way to propagate Anonymous... *)
+      GVar (Loc.ghost,x) in
+  List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') ->
+    match typ with
+    | NtnTypeConstr ->
+       ((find x, scl)::terms',termlists',binders')
+    | NtnTypeConstrList ->
+       (terms',(Id.List.assoc x termlists,scl)::termlists',binders')
+    | NtnTypeBinderList ->
+       (terms',termlists',(Id.List.assoc x binders,scl)::binders'))
+    metas ([],[],[])
+
+(* Matching cases pattern *)
+let add_patterns_for_params ind l =
+  let mib,_ = Global.lookup_inductive ind in
+  let nparams = mib.Declarations.mind_nparams in
+    Util.List.addn nparams (PatVar (Loc.ghost,Anonymous)) l
+
+let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v =
+  try
+    let vvar = Id.List.assoc var sigma in
+    if cases_pattern_eq v vvar then fullsigma else raise No_match
+  with Not_found ->
+    (* TODO: handle the case of multiple occs in different scopes *)
+    (var,v)::sigma,sigmalist,x
+
+let rec match_cases_pattern metas sigma a1 a2 =
+ match (a1,a2) with
+  | r1, NVar id2 when Id.List.mem id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[])
+  | PatVar (_,Anonymous), NHole _ -> sigma,(0,[])
+  | PatCstr (loc,(ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 ->
+      sigma,(0,add_patterns_for_params (fst r1) largs)
+  | PatCstr (loc,(ind,_ as r1),args1,_), NApp (NRef (ConstructRef r2),l2)
+      when eq_constructor r1 r2 ->
+      let l1 = add_patterns_for_params (fst r1) args1 in
+      let le2 = List.length l2 in
+      if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length l1
+      then
+	raise No_match
+      else
+	let l1',more_args = Util.List.chop le2 l1 in
+	(List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args)
+  | r1, NList (x,_,iter,termin,lassoc) ->
+      (match_alist (fun (metas,_) -> match_cases_pattern_no_more_args metas)
+	(metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc),(0,[])
+  | _ -> raise No_match
+
+and match_cases_pattern_no_more_args metas sigma a1 a2 =
+    match match_cases_pattern metas sigma a1 a2 with
+      |out,(_,[]) -> out
+      |_ -> raise No_match
+
+let match_ind_pattern metas sigma ind pats a2 =
+  match a2 with
+  | NRef (IndRef r2) when eq_ind ind r2 ->
+      sigma,(0,pats)
+  | NApp (NRef (IndRef r2),l2)
+      when eq_ind ind r2 ->
+      let le2 = List.length l2 in
+      if Int.equal le2 0 (* Special case of a notation for a @Cstr *) || le2 > List.length pats
+      then
+	raise No_match
+      else
+	let l1',more_args = Util.List.chop le2 pats in
+	(List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args)
+  |_ -> raise No_match
+
+let reorder_canonically_substitution terms termlists metas =
+  List.fold_right (fun (x,(scl,typ)) (terms',termlists') ->
+    match typ with
+      | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists')
+      | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists')
+      | NtnTypeBinderList -> assert false)
+    metas ([],[])
+
+let match_notation_constr_cases_pattern c (metas,pat) =
+  let vars = List.map fst metas in
+  let (terms,termlists,()),more_args = match_cases_pattern vars ([],[],()) c pat in
+  reorder_canonically_substitution terms termlists metas, more_args
+
+let match_notation_constr_ind_pattern ind args (metas,pat) =
+  let vars = List.map fst metas in
+  let (terms,termlists,()),more_args = match_ind_pattern vars ([],[],()) ind args pat in
+  reorder_canonically_substitution terms termlists metas, more_args
diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli
new file mode 100644
index 00000000..7283ed6f
--- /dev/null
+++ b/interp/notation_ops.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  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 Names
+open Notation_term
+open Glob_term
+
+(** Utilities about [notation_constr] *)
+
+(** Translate a [glob_constr] into a notation given the list of variables
+    bound by the notation; also interpret recursive patterns           *)
+
+val notation_constr_of_glob_constr : notation_interp_env ->
+  glob_constr -> notation_constr
+
+(** Name of the special identifier used to encode recursive notations  *)
+val ldots_var : Id.t
+
+(** Equality of [glob_constr] (warning: only partially implemented) *)
+(** FIXME: nothing to do here *)
+val eq_glob_constr : glob_constr -> glob_constr -> bool
+
+(** Re-interpret a notation as a [glob_constr], taking care of binders     *)
+
+val glob_constr_of_notation_constr_with_binders : Loc.t ->
+  ('a -> Name.t -> 'a * Name.t) ->
+  ('a -> notation_constr -> glob_constr) ->
+  'a -> notation_constr -> glob_constr
+
+val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr
+
+(** [match_notation_constr] matches a [glob_constr] against a notation
+    interpretation; raise [No_match] if the matching fails   *)
+
+exception No_match
+
+val match_notation_constr : bool -> glob_constr -> interpretation ->
+      (glob_constr * subscopes) list * (glob_constr list * subscopes) list *
+      (glob_decl list * subscopes) list
+
+val match_notation_constr_cases_pattern :
+  cases_pattern -> interpretation ->
+  ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) *
+    (int * cases_pattern list)
+
+val match_notation_constr_ind_pattern :
+  inductive -> cases_pattern  list -> interpretation ->
+  ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) *
+    (int * cases_pattern list)
+
+(** Substitution of kernel names in interpretation data                *)
+
+val subst_interpretation :
+  Mod_subst.substitution -> interpretation -> interpretation
+
+val add_patterns_for_params : inductive -> cases_pattern list -> cases_pattern list
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index f244c4da..cb12b98a 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -1,16 +1,12 @@
 (************************************************************************)
 (*  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 Util
-open Names
-(*i*)
 
 (*s Pretty-print. *)
 
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index f3dcda8c..0385eea2 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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 Names
 
 (** {6 Pretty-print. } *)
 
diff --git a/interp/reserve.ml b/interp/reserve.ml
index 88d3546f..3100298e 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.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,57 +8,89 @@
 
 (* Reserved names *)
 
+open Errors
 open Util
 open Pp
 open Names
 open Nameops
-open Summary
 open Libobject
 open Lib
-open Topconstr
-open Libnames
+open Notation_term
+open Notation_ops
+open Globnames
 
 type key =
   | RefKey of global_reference
   | Oth
 
-let reserve_table = ref Idmap.empty
-let reserve_revtable = ref Gmapl.empty
+(** TODO: share code from Notation *)
 
-let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
-  | AApp (ARef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
-  | AList (_,_,AApp (ARef ref,args),_,_)
-  | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args)
-  | ARef ref -> RefKey(canonical_gr ref), None
+let key_compare k1 k2 = match k1, k2 with
+| RefKey gr1, RefKey gr2 -> RefOrdered.compare gr1 gr2
+| RefKey _, Oth -> -1
+| Oth, RefKey _ -> 1
+| Oth, Oth -> 0
+
+module KeyOrd = struct type t = key let compare = key_compare end
+module KeyMap = Map.Make(KeyOrd)
+
+module ReservedSet :
+sig
+  type t
+  val empty : t
+  val add : (Id.t * notation_constr) -> t -> t
+  val find : (Id.t -> notation_constr -> bool) -> t -> Id.t * notation_constr
+end =
+struct
+  type t = (Id.t * notation_constr) list
+
+  let empty = []
+
+  let rec mem id c = function
+  | [] -> false
+  | (id', c') :: l ->
+    if c == c' && Id.equal id id' then true else mem id c l
+
+  let add p l =
+    let (id, c) = p in
+    if mem id c l then l else p :: l
+
+  let rec find f = function
+  | [] -> raise Not_found
+  | (id, c) as p :: l -> if f id c then p else find f l
+end
+
+
+let keymap_add key data map =
+  let old = try KeyMap.find key map with Not_found -> ReservedSet.empty in
+  KeyMap.add key (ReservedSet.add data old) map
+
+let reserve_table = Summary.ref Id.Map.empty ~name:"reserved-type"
+let reserve_revtable = Summary.ref KeyMap.empty ~name:"reserved-type-rev"
+
+let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *)
+  | NApp (NRef ref,args) -> RefKey(canonical_gr ref), Some (List.length args)
+  | NList (_,_,NApp (NRef ref,args),_,_)
+  | NBinderList (_,_,NApp (NRef ref,args),_) -> RefKey (canonical_gr ref), Some (List.length args)
+  | NRef ref -> RefKey(canonical_gr ref), None
   | _ -> Oth, None
 
 let cache_reserved_type (_,(id,t)) =
-  let key = fst (aconstr_key t) in
-  reserve_table := Idmap.add id t !reserve_table;
-  reserve_revtable := Gmapl.add key (t,id) !reserve_revtable
+  let key = fst (notation_constr_key t) in
+  reserve_table := Id.Map.add id t !reserve_table;
+  reserve_revtable := keymap_add key (id, t) !reserve_revtable
 
-let in_reserved : identifier * aconstr -> obj =
+let in_reserved : Id.t * notation_constr -> obj =
   declare_object {(default_object "RESERVED-TYPE") with
     cache_function = cache_reserved_type }
 
-let freeze_reserved () = (!reserve_table,!reserve_revtable)
-let unfreeze_reserved (r,rr) = reserve_table := r; reserve_revtable := rr
-let init_reserved () =
-  reserve_table := Idmap.empty; reserve_revtable := Gmapl.empty
-
-let _ =
-  Summary.declare_summary "reserved-type"
-    { Summary.freeze_function = freeze_reserved;
-      Summary.unfreeze_function = unfreeze_reserved;
-      Summary.init_function = init_reserved }
-
 let declare_reserved_type_binding (loc,id) t =
-  if id <> root_of_id id then
+  if not (Id.equal id (root_of_id id)) then
     user_err_loc(loc,"declare_reserved_type",
     (pr_id id ++ str
       " is not reservable: it must have no trailing digits, quote, or _"));
   begin try
-    let _ = Idmap.find id !reserve_table in
+    let _ = Id.Map.find id !reserve_table in
     user_err_loc(loc,"declare_reserved_type",
     (pr_id id++str" is already bound to a type"))
   with Not_found -> () end;
@@ -67,7 +99,7 @@ let declare_reserved_type_binding (loc,id) t =
 let declare_reserved_type idl t =
   List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl)
 
-let find_reserved_type id = Idmap.find (root_of_id id) !reserve_table
+let find_reserved_type id = Id.Map.find (root_of_id id) !reserve_table
 
 let constr_key c =
   try RefKey (canonical_gr (global_of_constr (fst (Term.decompose_app c))))
@@ -75,25 +107,18 @@ let constr_key c =
 
 let revert_reserved_type t =
   try
-    let l = Gmapl.find (constr_key t) !reserve_revtable in
-    let t = Detyping.detype false [] [] t in
-    list_try_find
-      (fun (pat,id) ->
-	try let _ = match_aconstr false t ([],pat) in Name id
-	with No_match -> failwith "") l
+    let reserved = KeyMap.find (constr_key t) !reserve_revtable in
+    let t = Detyping.detype false [] (Global.env()) Evd.empty t in
+    (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _]
+        then I've introduced a bug... *)
+    let filter _ pat =
+      try
+        let _ = match_notation_constr false t ([], pat) in
+        true
+      with No_match -> false
+    in
+    let (id, _) = ReservedSet.find filter reserved in
+    Name id
   with Not_found | Failure _ -> Anonymous
 
 let _ = Namegen.set_reserved_typed_name revert_reserved_type
-
-open Glob_term
-
-let anonymize_if_reserved na t = match na with
-  | Name id as na ->
-      (try
-	if not !Flags.raw_print &
-	   (try aconstr_of_glob_constr [] [] t = find_reserved_type id
-            with UserError _ -> false)
-	then GHole (dummy_loc,Evd.BinderType na)
-	else t
-      with Not_found -> t)
-  | Anonymous -> t
diff --git a/interp/reserve.mli b/interp/reserve.mli
index 4d7685e3..6cae2b02 100644
--- a/interp/reserve.mli
+++ b/interp/reserve.mli
@@ -1,16 +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 Util
+open Loc
 open Names
-open Glob_term
-open Topconstr
+open Notation_term
 
-val declare_reserved_type : identifier located list -> aconstr -> unit
-val find_reserved_type : identifier -> aconstr
-val anonymize_if_reserved : name -> glob_constr -> glob_constr
+val declare_reserved_type : Id.t located list -> notation_constr -> unit
+val find_reserved_type : Id.t -> notation_constr
diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml
index 5779231d..ce3c9b8f 100644
--- a/interp/smartlocate.ml
+++ b/interp/smartlocate.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        *)
@@ -13,23 +13,38 @@
 
 (* *)
 open Pp
-open Util
-open Names
+open Errors
 open Libnames
-open Genarg
+open Globnames
+open Misctypes
 open Syntax_def
-open Topconstr
+open Notation_term
+
+let global_of_extended_global_head = function
+  | TrueGlobal ref -> ref
+  | SynDef kn ->
+      let _, syn_def = search_syntactic_definition kn in
+      let rec head_of = function
+        | NRef ref -> ref
+        | NApp (rc, _) -> head_of rc
+        | NCast (rc, _) -> head_of rc
+        | NLetIn (_, _, rc) -> head_of rc
+        | _ -> raise Not_found in
+      head_of syn_def
 
 let global_of_extended_global = function
   | TrueGlobal ref -> ref
   | SynDef kn ->
   match search_syntactic_definition kn with
-  | [],ARef ref -> ref
+  | [],NRef ref -> ref
+  | [],NApp (NRef ref,[]) -> ref
   | _ -> raise Not_found
 
-let locate_global_with_alias (loc,qid) =
+let locate_global_with_alias ?(head=false) (loc,qid) =
   let ref = Nametab.locate_extended qid in
-  try global_of_extended_global ref
+  try
+    if head then global_of_extended_global_head ref
+    else global_of_extended_global ref
   with Not_found ->
     user_err_loc (loc,"",pr_qualid qid ++
       str " is bound to a notation that does not denote a reference.")
@@ -43,14 +58,14 @@ let global_inductive_with_alias r =
         pr_reference r ++ spc () ++ str "is not an inductive type.")
   with Not_found -> Nametab.error_global_not_found_loc loc qid
 
-let global_with_alias r =
+let global_with_alias ?head r =
   let (loc,qid as lqid) = qualid_of_reference r in
-  try locate_global_with_alias lqid
+  try locate_global_with_alias ?head lqid
   with Not_found -> Nametab.error_global_not_found_loc loc qid
 
-let smart_global = function
+let smart_global ?head = function
   | AN r ->
-      global_with_alias r
+      global_with_alias ?head r
   | ByNotation (loc,ntn,sc) ->
       Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc
 
@@ -60,3 +75,7 @@ let smart_global_inductive = function
   | ByNotation (loc,ntn,sc) ->
       destIndRef
         (Notation.interp_notation_as_global_reference loc isIndRef ntn sc)
+
+let loc_of_smart_reference = function
+  | AN r -> loc_of_reference r
+  | ByNotation (loc,_,_) -> loc
diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli
index 589505c3..68ef6594 100644
--- a/interp/smartlocate.mli
+++ b/interp/smartlocate.mli
@@ -1,35 +1,41 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
 open Libnames
-open Genarg
+open Globnames
+open Misctypes
 
 (** [locate_global_with_alias] locates global reference possibly following
-   a notation if this notation has a role of aliasing; raise Not_found
-   if not bound in the global env; raise an error if bound to a
+   a notation if this notation has a role of aliasing; raise [Not_found]
+   if not bound in the global env; raise a [UserError] if bound to a
    syntactic def that does not denote a reference *)
 
-val locate_global_with_alias : qualid located -> global_reference
+val locate_global_with_alias : ?head:bool -> qualid located -> global_reference
 
 (** Extract a global_reference from a reference that can be an "alias" *)
 val global_of_extended_global : extended_global_reference -> global_reference
 
-(** Locate a reference taking into account possible "alias" notations *)
-val global_with_alias : reference -> global_reference
+(** Locate a reference taking into account possible "alias" notations.
+    May raise [Nametab.GlobalizationError _] for an unknown reference,
+    or a [UserError] if bound to a syntactic def that does not denote
+    a reference. *)
+val global_with_alias : ?head:bool -> reference -> global_reference
 
 (** The same for inductive types *)
 val global_inductive_with_alias : reference -> inductive
 
 (** Locate a reference taking into account notations and "aliases" *)
-val smart_global : reference or_by_notation -> global_reference
+val smart_global : ?head:bool -> reference or_by_notation -> global_reference
 
 (** The same for inductive types *)
 val smart_global_inductive : reference or_by_notation -> inductive
 
+(** Return the loc of a smart reference *)
+val loc_of_smart_reference : reference or_by_notation -> Loc.t
diff --git a/interp/stdarg.ml b/interp/stdarg.ml
new file mode 100644
index 00000000..e155a521
--- /dev/null
+++ b/interp/stdarg.ml
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  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 Genarg
+
+let wit_unit : unit uniform_genarg_type =
+  make0 None "unit"
+
+let wit_bool : bool uniform_genarg_type =
+  make0 None "bool"
+
+let wit_int : int uniform_genarg_type =
+  make0 None "int"
+
+let wit_string : string uniform_genarg_type =
+  make0 None "string"
+
+let wit_pre_ident : string uniform_genarg_type =
+  make0 None "preident"
+
+let () = register_name0 wit_unit "Stdarg.wit_unit"
+let () = register_name0 wit_bool "Stdarg.wit_bool"
+let () = register_name0 wit_int "Stdarg.wit_int"
+let () = register_name0 wit_string "Stdarg.wit_string"
+let () = register_name0 wit_pre_ident "Stdarg.wit_pre_ident"
diff --git a/interp/stdarg.mli b/interp/stdarg.mli
new file mode 100644
index 00000000..5a44b1ca
--- /dev/null
+++ b/interp/stdarg.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Basic generic arguments. *)
+
+open Genarg
+
+val wit_unit : unit uniform_genarg_type
+
+val wit_bool : bool uniform_genarg_type
+
+val wit_int : int uniform_genarg_type
+
+val wit_string : string uniform_genarg_type
+
+val wit_pre_ident : string uniform_genarg_type
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index da29c5e0..9be7abcf 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -1,16 +1,17 @@
 (************************************************************************)
 (*  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 Pp
 open Names
 open Libnames
-open Topconstr
+open Notation_term
 open Libobject
 open Lib
 open Nameops
@@ -20,13 +21,9 @@ open Nametab
 
 type version = Flags.compat_version option
 
-let syntax_table = ref (KNmap.empty : (interpretation*version) KNmap.t)
-
-let _ = Summary.declare_summary
-	  "SYNTAXCONSTANT"
-	  { Summary.freeze_function = (fun () -> !syntax_table);
-	    Summary.unfreeze_function = (fun ft -> syntax_table := ft);
-	    Summary.init_function = (fun () -> syntax_table := KNmap.empty) }
+let syntax_table =
+  Summary.ref (KNmap.empty : (interpretation*version) KNmap.t)
+    ~name:"SYNTAXCONSTANT"
 
 let add_syntax_constant kn c onlyparse =
   syntax_table := KNmap.add kn (c,onlyparse) !syntax_table
@@ -39,19 +36,21 @@ let load_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
   Nametab.push_syndef (Nametab.Until i) sp kn
 
 let is_alias_of_already_visible_name sp = function
-  | _,ARef ref ->
-      let (dir,id) = repr_qualid (shortest_qualid_of_global Idset.empty ref) in
-      dir = empty_dirpath && id = basename sp
+  | _,NRef ref ->
+      let (dir,id) = repr_qualid (shortest_qualid_of_global Id.Set.empty ref) in
+      DirPath.is_empty dir && Id.equal id (basename sp)
   | _ ->
       false
 
 let open_syntax_constant i ((sp,kn),(_,pat,onlyparse)) =
   if not (is_alias_of_already_visible_name sp pat) then begin
     Nametab.push_syndef (Nametab.Exactly i) sp kn;
-    if onlyparse = None then
+    match onlyparse with
+    | None ->
       (* Redeclare it to be used as (short) name in case an other (distfix)
 	 notation was declared inbetween *)
       Notation.declare_uninterpretation (Notation.SynDefRule kn) pat
+    | _ -> ()
   end
 
 let cache_syntax_constant d =
@@ -59,7 +58,7 @@ let cache_syntax_constant d =
   open_syntax_constant 1 d
 
 let subst_syntax_constant (subst,(local,pat,onlyparse)) =
-  (local,subst_interpretation subst pat,onlyparse)
+  (local,Notation_ops.subst_interpretation subst pat,onlyparse)
 
 let classify_syntax_constant (local,_,_ as o) =
   if local then Dispose else Substitute o
@@ -73,7 +72,7 @@ let in_syntax_constant
     subst_function = subst_syntax_constant;
     classify_function = classify_syntax_constant }
 
-type syndef_interpretation = (identifier * subscopes) list * aconstr
+type syndef_interpretation = (Id.t * subscopes) list * notation_constr
 
 (* Coercions to the general format of notation that also supports
    variables bound to list of expressions *)
@@ -83,8 +82,7 @@ let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac)
 let declare_syntactic_definition local id onlyparse pat =
   let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in ()
 
-let pr_global r = pr_global_env Idset.empty r
-let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Idset.empty kn)
+let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Id.Set.empty kn)
 
 let allow_compat_notations = ref true
 let verbose_compat_notations = ref false
@@ -98,7 +96,7 @@ let verbose_compat kn def = function
       if !verbose_compat_notations then msg_warning else errorlabstrm ""
     in
     let pp_def = match def with
-      | [], ARef r -> str " is " ++ pr_global_env Idset.empty r
+      | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r
       | _ -> str " is a compatibility notation"
     in
     let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index 338538a9..e5a3f4ce 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -1,23 +1,19 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Topconstr
-open Glob_term
-open Nametab
-open Libnames
+open Notation_term
 
 (** Syntactic definitions. *)
 
-type syndef_interpretation = (identifier * subscopes) list * aconstr
+type syndef_interpretation = (Id.t * subscopes) list * notation_constr
 
-val declare_syntactic_definition : bool -> identifier ->
+val declare_syntactic_definition : bool -> Id.t ->
   Flags.compat_version option -> syndef_interpretation -> unit
 
 val search_syntactic_definition : kernel_name -> syndef_interpretation
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index ff49fb73..1231f115 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.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,921 +8,26 @@
 
 (*i*)
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Libnames
-open Glob_term
-open Term
-open Mod_subst
+open Misctypes
+open Constrexpr
+open Constrexpr_ops
 (*i*)
 
-(**********************************************************************)
-(* This is the subtype of glob_constr allowed in syntactic extensions *)
-
-(* For AList: first constr is iterator, second is terminator;
-   first id is where each argument of the list has to be substituted
-   in iterator and snd id is alternative name just for printing;
-   boolean is associativity *)
-
-type aconstr =
-  (* Part common to glob_constr and cases_pattern *)
-  | ARef of global_reference
-  | AVar of identifier
-  | AApp of aconstr * aconstr list
-  | AList of identifier * identifier * aconstr * aconstr * bool
-  (* Part only in glob_constr *)
-  | ALambda of name * aconstr * aconstr
-  | AProd of name * aconstr * aconstr
-  | ABinderList of identifier * identifier * aconstr * aconstr
-  | ALetIn of name * aconstr * aconstr
-  | ACases of case_style * aconstr option *
-      (aconstr * (name * (inductive * int * name list) option)) list *
-      (cases_pattern list * aconstr) list
-  | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
-  | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
-  | ARec of fix_kind * identifier array *
-      (name * aconstr option * aconstr) list array * aconstr array *
-      aconstr array
-  | ASort of glob_sort
-  | AHole of Evd.hole_kind
-  | APatVar of patvar
-  | ACast of aconstr * aconstr cast_type
-
-type scope_name = string
-
-type tmp_scope_name = scope_name
-
-type subscopes = tmp_scope_name option * scope_name list
-
-type notation_var_instance_type =
-  | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList
-
-type notation_var_internalization_type =
-  | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent
-
-type interpretation =
-    (identifier * (subscopes * notation_var_instance_type)) list * aconstr
-
-(**********************************************************************)
-(* Re-interpret a notation as a glob_constr, taking care of binders     *)
-
-let name_to_ident = function
-  | Anonymous -> error "This expression should be a simple identifier."
-  | Name id -> id
-
-let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na
-
-let rec cases_pattern_fold_map loc g e = function
-  | PatVar (_,na) ->
-      let e',na' = g e na in e', PatVar (loc,na')
-  | PatCstr (_,cstr,patl,na) ->
-      let e',na' = g e na in
-      let e',patl' = list_fold_map (cases_pattern_fold_map loc g) e patl in
-      e', PatCstr (loc,cstr,patl',na')
-
-let rec subst_glob_vars l = function
-  | GVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
-  | GProd (loc,Name id,bk,t,c) ->
-      let id =
-	try match List.assoc id l with GVar(_,id') -> id' | _ -> id
-	with Not_found -> id in
-      GProd (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
-  | GLambda (loc,Name id,bk,t,c) ->
-      let id =
-	try match List.assoc id l with GVar(_,id') -> id' | _ -> id
-	with Not_found -> id in
-      GLambda (loc,Name id,bk,subst_glob_vars l t,subst_glob_vars l c)
-  | r -> map_glob_constr (subst_glob_vars l) r (* assume: id is not binding *)
-
-let ldots_var = id_of_string ".."
-
-let glob_constr_of_aconstr_with_binders loc g f e = function
-  | AVar id -> GVar (loc,id)
-  | AApp (a,args) -> GApp (loc,f e a, List.map (f e) args)
-  | AList (x,y,iter,tail,swap) ->
-      let t = f e tail in let it = f e iter in
-      let innerl = (ldots_var,t)::(if swap then [] else [x,GVar(loc,y)]) in
-      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
-      let outerl = (ldots_var,inner)::(if swap then [x,GVar(loc,y)] else []) in
-      subst_glob_vars outerl it
-  | ABinderList (x,y,iter,tail) ->
-      let t = f e tail in let it = f e iter in
-      let innerl = [(ldots_var,t);(x,GVar(loc,y))] in
-      let inner = GApp (loc,GVar (loc,ldots_var),[subst_glob_vars innerl it]) in
-      let outerl = [(ldots_var,inner)] in
-      subst_glob_vars outerl it
-  | ALambda (na,ty,c) ->
-      let e',na = g e na in GLambda (loc,na,Explicit,f e ty,f e' c)
-  | AProd (na,ty,c) ->
-      let e',na = g e na in GProd (loc,na,Explicit,f e ty,f e' c)
-  | ALetIn (na,b,c) ->
-      let e',na = g e na in GLetIn (loc,na,f e b,f e' c)
-  | ACases (sty,rtntypopt,tml,eqnl) ->
-      let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') ->
-	let e',t' = match t with
-	| None -> e',None
-	| Some (ind,npar,nal) ->
-	  let e',nal' = List.fold_right (fun na (e',nal) ->
-	      let e',na' = g e' na in e',na'::nal) nal (e',[]) in
-	  e',Some (loc,ind,npar,nal') in
-	let e',na' = g e' na in
-	(e',(f e tm,(na',t'))::tml')) tml (e,[]) in
-      let fold (idl,e) na = let (e,na) = g e na in ((name_cons na idl,e),na) in
-      let eqnl' = List.map (fun (patl,rhs) ->
-	let ((idl,e),patl) =
-	  list_fold_map (cases_pattern_fold_map loc fold) ([],e) patl in
-	(loc,idl,patl,f e rhs)) eqnl in
-      GCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl')
-  | ALetTuple (nal,(na,po),b,c) ->
-      let e',nal = list_fold_map g e nal in
-      let e'',na = g e na in
-      GLetTuple (loc,nal,(na,Option.map (f e'') po),f e b,f e' c)
-  | AIf (c,(na,po),b1,b2) ->
-      let e',na = g e na in
-      GIf (loc,f e c,(na,Option.map (f e') po),f e b1,f e b2)
-  | ARec (fk,idl,dll,tl,bl) ->
-      let e,dll = array_fold_map (list_fold_map (fun e (na,oc,b) ->
-	  let e,na = g e na in
-	  (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in
-      let e',idl = array_fold_map (to_id g) e idl in
-      GRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl)
-  | ACast (c,k) -> GCast (loc,f e c,
-			  match k with
-			    | CastConv (k,t) -> CastConv (k,f e t)
-			    | CastCoerce -> CastCoerce)
-  | ASort x -> GSort (loc,x)
-  | AHole x  -> GHole (loc,x)
-  | APatVar n -> GPatVar (loc,(false,n))
-  | ARef x -> GRef (loc,x)
-
-let rec glob_constr_of_aconstr loc x =
-  let rec aux () x =
-    glob_constr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x
-  in aux () x
-
-(****************************************************************************)
-(* Translating a glob_constr into a notation, interpreting recursive patterns *)
-
-let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r)
-let add_name r = function Anonymous -> () | Name id -> add_id r id
-
-let split_at_recursive_part c =
-  let sub = ref None in
-  let rec aux = function
-  | GApp (loc0,GVar(loc,v),c::l) when v = ldots_var ->
-      if !sub <> None then
-	(* Not narrowed enough to find only one recursive part *)
-	raise Not_found
-      else
-	(sub := Some c;
-	 if l = [] then GVar (loc,ldots_var)
-	 else GApp (loc0,GVar (loc,ldots_var),l))
-  | c -> map_glob_constr aux c in
-  let outer_iterator = aux c in
-  match !sub with
-  | None -> (* No recursive pattern found *) raise Not_found
-  | Some c ->
-  match outer_iterator with
-  | GVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found
-  | _ -> outer_iterator, c
-
-let on_true_do b f c = if b then (f c; b) else b
-
-let compare_glob_constr f add t1 t2 = match t1,t2 with
-  | GRef (_,r1), GRef (_,r2) -> eq_gr r1 r2
-  | GVar (_,v1), GVar (_,v2) -> on_true_do (v1 = v2) add (Name v1)
-  | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2
-  | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1
-  | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
-      on_true_do (f ty1 ty2 & f c1 c2) add na1
-  | GHole _, GHole _ -> true
-  | GSort (_,s1), GSort (_,s2) -> s1 = s2
-  | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when na1 = na2 ->
-      on_true_do (f b1 b2 & f c1 c2) add na1
-  | (GCases _ | GRec _
-    | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_
-  | _,(GCases _ | GRec _
-      | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _)
-      -> error "Unsupported construction in recursive notations."
-  | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _
-    | GHole _ | GSort _ | GLetIn _), _
-      -> false
-
-let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2
-
-let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1)
-
-let check_is_hole id = function GHole _ -> () | t ->
-  user_err_loc (loc_of_glob_constr t,"",
-    strbrk "In recursive notation with binders, " ++ pr_id id ++
-    strbrk " is expected to come without type.")
-
-let compare_recursive_parts found f (iterator,subc) =
-  let diff = ref None in
-  let terminator = ref None in
-  let rec aux c1 c2 = match c1,c2 with
-  | GVar(_,v), term when v = ldots_var ->
-      (* We found the pattern *)
-      assert (!terminator = None); terminator := Some term;
-      true
-  | GApp (_,GVar(_,v),l1), GApp (_,term,l2) when v = ldots_var ->
-      (* We found the pattern, but there are extra arguments *)
-      (* (this allows e.g. alternative (recursive) notation of application) *)
-      assert (!terminator = None); terminator := Some term;
-      list_for_all2eq aux l1 l2
-  | GVar (_,x), GVar (_,y) when x<>y ->
-      (* We found the position where it differs *)
-      let lassoc = (!terminator <> None) in
-      let x,y = if lassoc then y,x else x,y in
-      !diff = None && (diff := Some (x,y,Some lassoc); true)
-  | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term)
-  | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) ->
-      (* We found a binding position where it differs *)
-      check_is_hole x t_x;
-      check_is_hole y t_y;
-      !diff = None && (diff := Some (x,y,None); aux c term)
-  | _ ->
-      compare_glob_constr aux (add_name found) c1 c2 in
-  if aux iterator subc then
-    match !diff with
-    | None ->
-	let loc1 = loc_of_glob_constr iterator in
-	let loc2 = loc_of_glob_constr (Option.get !terminator) in
-	(* Here, we would need a loc made of several parts ... *)
-	user_err_loc (subtract_loc loc1 loc2,"",
-          str "Both ends of the recursive pattern are the same.")
-    | Some (x,y,Some lassoc) ->
-	let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in
-	let iterator =
-	  f (if lassoc then subst_glob_vars [y,GVar(dummy_loc,x)] iterator
-	  else iterator) in
-	(* found have been collected by compare_constr *)
-	found := newfound;
-	AList (x,y,iterator,f (Option.get !terminator),lassoc)
-    | Some (x,y,None) ->
-	let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in
-	let iterator = f iterator in
-	(* found have been collected by compare_constr *)
-	found := newfound;
-	ABinderList (x,y,iterator,f (Option.get !terminator))
-  else
-    raise Not_found
-
-let aconstr_and_vars_of_glob_constr a =
-  let found = ref ([],[],[]) in
-  let rec aux c =
-    let keepfound = !found in
-    (* n^2 complexity but small and done only once per notation *)
-    try compare_recursive_parts found aux' (split_at_recursive_part c)
-    with Not_found ->
-    found := keepfound;
-    match c with
-    | GApp (_,GVar (loc,f),[c]) when f = ldots_var ->
-	(* Fall on the second part of the recursive pattern w/o having
-	   found the first part *)
-	user_err_loc (loc,"",
-	str "Cannot find where the recursive pattern starts.")
-    | c ->
-	aux' c
-  and aux' = function
-  | GVar (_,id) -> add_id found id; AVar id
-  | GApp (_,g,args) -> AApp (aux g, List.map aux args)
-  | GLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c)
-  | GProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c)
-  | GLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c)
-  | GCases (_,sty,rtntypopt,tml,eqnl) ->
-      let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in
-      ACases (sty,Option.map aux rtntypopt,
-        List.map (fun (tm,(na,x)) ->
-	  add_name found na;
-	  Option.iter
-	    (fun (_,_,_,nl) -> List.iter (add_name found) nl) x;
-          (aux tm,(na,Option.map (fun (_,ind,n,nal) -> (ind,n,nal)) x))) tml,
-        List.map f eqnl)
-  | GLetTuple (loc,nal,(na,po),b,c) ->
-      add_name found na;
-      List.iter (add_name found) nal;
-      ALetTuple (nal,(na,Option.map aux po),aux b,aux c)
-  | GIf (loc,c,(na,po),b1,b2) ->
-      add_name found na;
-      AIf (aux c,(na,Option.map aux po),aux b1,aux b2)
-  | GRec (_,fk,idl,dll,tl,bl) ->
-      Array.iter (add_id found) idl;
-      let dll = Array.map (List.map (fun (na,bk,oc,b) ->
-	 if bk <> Explicit then
-	   error "Binders marked as implicit not allowed in notations.";
-	 add_name found na; (na,Option.map aux oc,aux b))) dll in
-      ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl)
-  | GCast (_,c,k) -> ACast (aux c,
-			    match k with CastConv (k,t) -> CastConv (k,aux t)
-			      | CastCoerce -> CastCoerce)
-  | GSort (_,s) -> ASort s
-  | GHole (_,w) -> AHole w
-  | GRef (_,r) -> ARef r
-  | GPatVar (_,(_,n)) -> APatVar n
-  | GEvar _ ->
-      error "Existential variables not allowed in notations."
-
-  in
-  let t = aux a in
-  (* Side effect *)
-  t, !found
-
-let rec list_rev_mem_assoc x = function
-  | [] -> false
-  | (_,x')::l -> x = x' || list_rev_mem_assoc x l
-
-let check_variables vars recvars (found,foundrec,foundrecbinding) =
-  let useless_vars = List.map snd recvars in
-  let vars = List.filter (fun (y,_) -> not (List.mem y useless_vars)) vars in
-  let check_recvar x =
-    if List.mem x found then
-      errorlabstrm "" (pr_id x ++
-	strbrk " should only be used in the recursive part of a pattern.") in
-  List.iter (fun (x,y) -> check_recvar x; check_recvar y)
-    (foundrec@foundrecbinding);
-  let check_bound x =
-    if not (List.mem x found) then
-      if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding
-	or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding
-      then
-	error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.")
-      else
-	error ((string_of_id x)^" is unbound in the right-hand side.") in
-  let check_pair s x y where =
-    if not (List.mem (x,y) where) then
-      errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++
-	str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++
-	str " position as part of a recursive pattern.") in
-  let check_type (x,typ) =
-    match typ with
-    | NtnInternTypeConstr ->
-	begin
-	  try check_pair "term" x (List.assoc x recvars) foundrec
-	  with Not_found -> check_bound x
-	end
-    | NtnInternTypeBinder ->
-	begin
-	  try check_pair "binding" x (List.assoc x recvars) foundrecbinding
-	  with Not_found -> check_bound x
-	end
-    | NtnInternTypeIdent -> check_bound x in
-  List.iter check_type vars
-
-let aconstr_of_glob_constr vars recvars a =
-  let a,found = aconstr_and_vars_of_glob_constr a in
-  check_variables vars recvars found;
-  a
-
-(* Substitution of kernel names, avoiding a list of bound identifiers *)
-
-let aconstr_of_constr avoiding t =
- aconstr_of_glob_constr [] [] (Detyping.detype false avoiding [] t)
-
-let rec subst_pat subst pat =
-  match pat with
-  | PatVar _ -> pat
-  | PatCstr (loc,((kn,i),j),cpl,n) ->
-      let kn' = subst_ind subst kn
-      and cpl' = list_smartmap (subst_pat subst) cpl in
-        if kn' == kn && cpl' == cpl then pat else
-          PatCstr (loc,((kn',i),j),cpl',n)
-
-let rec subst_aconstr subst bound raw =
-  match raw with
-  | ARef ref ->
-      let ref',t = subst_global subst ref in
-	if ref' == ref then raw else
-	  aconstr_of_constr bound t
-
-  | AVar _ -> raw
-
-  | AApp (r,rl) ->
-      let r' = subst_aconstr subst bound r
-      and rl' = list_smartmap (subst_aconstr subst bound) rl in
-	if r' == r && rl' == rl then raw else
-	  AApp(r',rl')
-
-  | AList (id1,id2,r1,r2,b) ->
-      let r1' = subst_aconstr subst bound r1
-      and r2' = subst_aconstr subst bound r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  AList (id1,id2,r1',r2',b)
-
-  | ALambda (n,r1,r2) ->
-      let r1' = subst_aconstr subst bound r1
-      and r2' = subst_aconstr subst bound r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ALambda (n,r1',r2')
-
-  | AProd (n,r1,r2) ->
-      let r1' = subst_aconstr subst bound r1
-      and r2' = subst_aconstr subst bound r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  AProd (n,r1',r2')
-
-  | ABinderList (id1,id2,r1,r2) ->
-      let r1' = subst_aconstr subst bound r1
-      and r2' = subst_aconstr subst bound r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ABinderList (id1,id2,r1',r2')
-
-  | ALetIn (n,r1,r2) ->
-      let r1' = subst_aconstr subst bound r1
-      and r2' = subst_aconstr subst bound r2 in
-	if r1' == r1 && r2' == r2 then raw else
-	  ALetIn (n,r1',r2')
-
-  | ACases (sty,rtntypopt,rl,branches) ->
-      let rtntypopt' = Option.smartmap (subst_aconstr subst bound) rtntypopt
-      and rl' = list_smartmap
-        (fun (a,(n,signopt) as x) ->
-	  let a' = subst_aconstr subst bound a in
-	  let signopt' = Option.map (fun ((indkn,i),n,nal as z) ->
-	    let indkn' = subst_ind subst indkn in
-	    if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in
-	  if a' == a && signopt' == signopt then x else (a',(n,signopt')))
-        rl
-      and branches' = list_smartmap
-                        (fun (cpl,r as branch) ->
-                           let cpl' = list_smartmap (subst_pat subst) cpl
-                           and r' = subst_aconstr subst bound r in
-                             if cpl' == cpl && r' == r then branch else
-                               (cpl',r'))
-                        branches
-      in
-        if rtntypopt' == rtntypopt && rtntypopt == rtntypopt' &
-          rl' == rl && branches' == branches then raw else
-          ACases (sty,rtntypopt',rl',branches')
-
-  | ALetTuple (nal,(na,po),b,c) ->
-      let po' = Option.smartmap (subst_aconstr subst bound) po
-      and b' = subst_aconstr subst bound b
-      and c' = subst_aconstr subst bound c in
-	if po' == po && b' == b && c' == c then raw else
-	  ALetTuple (nal,(na,po'),b',c')
-
-  | AIf (c,(na,po),b1,b2) ->
-      let po' = Option.smartmap (subst_aconstr subst bound) po
-      and b1' = subst_aconstr subst bound b1
-      and b2' = subst_aconstr subst bound b2
-      and c' = subst_aconstr subst bound c in
-	if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else
-	  AIf (c',(na,po'),b1',b2')
-
-  | ARec (fk,idl,dll,tl,bl) ->
-      let dll' =
-	array_smartmap (list_smartmap (fun (na,oc,b as x) ->
-	  let oc' =  Option.smartmap (subst_aconstr subst bound) oc in
-	  let b' =  subst_aconstr subst bound b in
-	  if oc' == oc && b' == b then x else (na,oc',b'))) dll in
-      let tl' = array_smartmap (subst_aconstr subst bound) tl in
-      let bl' = array_smartmap (subst_aconstr subst bound) bl in
-      if dll' == dll && tl' == tl && bl' == bl then raw else
-	  ARec (fk,idl,dll',tl',bl')
-
-  | APatVar _ | ASort _ -> raw
-
-  | AHole (Evd.ImplicitArg (ref,i,b)) ->
-      let ref',t = subst_global subst ref in
-	if ref' == ref then raw else
-	  AHole (Evd.InternalHole)
-  | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType
-    | Evd.InternalHole | Evd.TomatchTypeParameter _ | Evd.GoalEvar
-    | Evd.ImpossibleCase | Evd.MatchingVar _) -> raw
-
-  | ACast (r1,k) ->
-      match k with
-	  CastConv (k, r2) ->
-	    let r1' = subst_aconstr subst bound r1
-	    and r2' = subst_aconstr subst bound r2 in
-	      if r1' == r1 && r2' == r2 then raw else
-		ACast (r1',CastConv (k,r2'))
-	| CastCoerce ->
-	    let r1' = subst_aconstr subst bound r1 in
-	      if r1' == r1 then raw else
-		ACast (r1',CastCoerce)
-
-let subst_interpretation subst (metas,pat) =
-  let bound = List.map fst metas in
-  (metas,subst_aconstr subst bound pat)
-
-(* Pattern-matching glob_constr and aconstr *)
-
-let abstract_return_type_context pi mklam tml rtno =
-  Option.map (fun rtn ->
-    let nal =
-      List.flatten (List.map (fun (_,(na,t)) ->
-	match t with Some x -> (pi x)@[na] | None -> [na]) tml) in
-    List.fold_right mklam nal rtn)
-    rtno
-
-let abstract_return_type_context_glob_constr =
-  abstract_return_type_context (fun (_,_,_,nal) -> nal)
-    (fun na c -> GLambda(dummy_loc,na,Explicit,GHole(dummy_loc,Evd.InternalHole),c))
-
-let abstract_return_type_context_aconstr =
-  abstract_return_type_context pi3
-    (fun na c -> ALambda(na,AHole Evd.InternalHole,c))
-
-exception No_match
-
-let rec alpha_var id1 id2 = function
-  | (i1,i2)::_ when i1=id1 -> i2 = id2
-  | (i1,i2)::_ when i2=id2 -> i1 = id1
-  | _::idl -> alpha_var id1 id2 idl
-  | [] -> id1 = id2
-
-let alpha_eq_val (x,y) = x = y
-
-let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v =
-  try
-    let vvar = List.assoc var sigma in
-    if alpha_eq_val (v,vvar) then fullsigma
-    else raise No_match
-  with Not_found ->
-    (* Check that no capture of binding variables occur *)
-    if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match;
-    (* TODO: handle the case of multiple occs in different scopes *)
-    ((var,v)::sigma,sigmalist,sigmabinders)
-
-let bind_binder (sigma,sigmalist,sigmabinders) x bl =
-  (sigma,sigmalist,(x,List.rev bl)::sigmabinders)
-
-let match_fix_kind fk1 fk2 =
-  match (fk1,fk2) with
-  | GCoFix n1, GCoFix n2 -> n1 = n2
-  | GFix (nl1,n1), GFix (nl2,n2) ->
-      n1 = n2 &&
-      array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2
-  | _ -> false
-
-let match_opt f sigma t1 t2 = match (t1,t2) with
-  | None, None -> sigma
-  | Some t1, Some t2 -> f sigma t1 t2
-  | _ -> raise No_match
-
-let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
-  | (_,Name id2) when List.mem id2 (fst metas) ->
-      let rhs = match na1 with
-      | Name id1 -> GVar (dummy_loc,id1)
-      | Anonymous -> GHole (dummy_loc,Evd.InternalHole) in
-      alp, bind_env alp sigma id2 rhs
-  | (Name id1,Name id2) -> (id1,id2)::alp,sigma
-  | (Anonymous,Anonymous) -> alp,sigma
-  | _ -> raise No_match
 
-let rec match_cases_pattern_binders metas acc pat1 pat2 =
-  match (pat1,pat2) with
-  | PatVar (_,na1), PatVar (_,na2) -> match_names metas acc na1 na2
-  | PatCstr (_,c1,patl1,na1), PatCstr (_,c2,patl2,na2)
-      when c1 = c2 & List.length patl1 = List.length patl2 ->
-      List.fold_left2 (match_cases_pattern_binders metas)
-	(match_names metas acc na1 na2) patl1 patl2
-  | _ -> raise No_match
-
-let glue_letin_with_decls = true
-
-let rec match_iterated_binders islambda decls = function
-  | GLambda (_,na,bk,t,b) when islambda ->
-      match_iterated_binders islambda ((na,bk,None,t)::decls) b
-  | GProd (_,(Name _ as na),bk,t,b) when not islambda ->
-      match_iterated_binders islambda ((na,bk,None,t)::decls) b
-  | GLetIn (loc,na,c,b) when glue_letin_with_decls ->
-      match_iterated_binders islambda
-	((na,Explicit (*?*), Some c,GHole(loc,Evd.BinderType na))::decls) b
-  | b -> (decls,b)
-
-let remove_sigma x (sigmavar,sigmalist,sigmabinders) =
-  (List.remove_assoc x sigmavar,sigmalist,sigmabinders)
-
-let rec match_abinderlist_with_app match_fun metas sigma rest x iter termin =
-  let rec aux sigma acc rest =
-    try
-      let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
-      let rest = List.assoc ldots_var (pi1 sigma) in
-      let b = match List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false in
-      let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
-      aux sigma (b::acc) rest
-    with No_match when acc <> [] ->
-      acc, match_fun metas sigma rest termin in
-  let bl,sigma = aux sigma [] rest in
-  bind_binder sigma x bl
-
-let match_alist match_fun metas sigma rest x iter termin lassoc =
-  let rec aux sigma acc rest =
-    try
-      let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
-      let rest = List.assoc ldots_var (pi1 sigma) in
-      let t = List.assoc x (pi1 sigma) in
-      let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
-      aux sigma (t::acc) rest
-    with No_match when acc <> [] ->
-      acc, match_fun metas sigma rest termin in
-  let l,sigma = aux sigma [] rest in
-  (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma)
-
-let does_not_come_from_already_eta_expanded_var =
-  (* This is hack to avoid looping on a rule with rhs of the form *)
-  (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *)
-  (* "F (fun x => H x)" and "H x" is recursively matched against the same *)
-  (* rule, giving "H (fun x' => x x')" and so on. *)
-  (* Ideally, we would need the type of the expression to know which of *)
-  (* the arguments applied to it can be eta-expanded without looping. *)
-  (* The following test is then an approximation of what can be done *)
-  (* optimally (whether other looping situations can occur remains to be *)
-  (* checked). *)
-  function GVar _ -> false | _ -> true
-
-let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 =
-  match (a1,a2) with
-
-  (* Matching notation variable *)
-  | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1
-
-  (* Matching recursive notations for terms *)
-  | r1, AList (x,_,iter,termin,lassoc) ->
-      match_alist (match_hd u alp) metas sigma r1 x iter termin lassoc
-
-  (* Matching recursive notations for binders: ad hoc cases supporting let-in *)
-  | GLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)->
-      let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in
-      (* TODO: address the possibility that termin is a Lambda itself *)
-      match_in u alp metas (bind_binder sigma x decls) b termin
-  | GProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin)
-      when na1 <> Anonymous ->
-      let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in
-      (* TODO: address the possibility that termin is a Prod itself *)
-      match_in u alp metas (bind_binder sigma x decls) b termin
-  (* Matching recursive notations for binders: general case *)
-  | r, ABinderList (x,_,iter,termin) ->
-      match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin
-
-  (* Matching individual binders as part of a recursive pattern *)
-  | GLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas ->
-      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
-  | GProd (_,na,bk,t,b1), AProd (Name id,_,b2)
-      when List.mem id blmetas & na <> Anonymous ->
-      match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
-
-  (* Matching compositionally *)
-  | GVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
-  | GRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma
-  | GPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma
-  | GApp (loc,f1,l1), AApp (f2,l2) ->
-      let n1 = List.length l1 and n2 = List.length l2 in
-      let f1,l1,f2,l2 =
-	if n1 < n2 then
-	  let l21,l22 = list_chop (n2-n1) l2 in f1,l1, AApp (f2,l21), l22
-	else if n1 > n2 then
-	  let l11,l12 = list_chop (n1-n2) l1 in GApp (loc,f1,l11),l12, f2,l2
-	else f1,l1, f2, l2 in
-      let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in
-      List.fold_left2 (match_ may_use_eta u alp metas)
-        (match_in u alp metas sigma f1 f2) l1 l2
-  | GLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) ->
-     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
-  | GProd (_,na1,_,t1,b1), AProd (na2,t2,b2) ->
-     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
-  | GLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) ->
-     match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2
-  | GCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2)
-      when sty1 = sty2
-	 & List.length tml1 = List.length tml2
-	 & List.length eqnl1 = List.length eqnl2 ->
-      let rtno1' = abstract_return_type_context_glob_constr tml1 rtno1 in
-      let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in
-      let sigma =
-	try Option.fold_left2 (match_in u alp metas) sigma rtno1' rtno2'
-	with Option.Heterogeneous -> raise No_match
-      in
-      let sigma = List.fold_left2
-      (fun s (tm1,_) (tm2,_) ->
-        match_in u alp metas s tm1 tm2) sigma tml1 tml2 in
-      List.fold_left2 (match_equations u alp metas) sigma eqnl1 eqnl2
-  | GLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2)
-      when List.length nal1 = List.length nal2 ->
-      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
-      let sigma = match_in u alp metas sigma b1 b2 in
-      let (alp,sigma) =
-	List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in
-      match_in u alp metas sigma c1 c2
-  | GIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) ->
-      let sigma = match_opt (match_binders u alp metas na1 na2) sigma to1 to2 in
-      List.fold_left2 (match_in u alp metas) sigma [a1;b1;c1] [a2;b2;c2]
-  | GRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2)
-      when match_fix_kind fk1 fk2 & Array.length idl1 =  Array.length idl2 &
-	array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2
-	->
-      let alp,sigma = array_fold_left2
-	(List.fold_left2 (fun (alp,sigma) (na1,_,oc1,b1) (na2,oc2,b2) ->
-	  let sigma =
-	    match_in u alp metas
-              (match_opt (match_in u alp metas) sigma oc1 oc2) b1 b2
-	  in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in
-      let sigma = array_fold_left2 (match_in u alp metas) sigma tl1 tl2 in
-      let alp,sigma = array_fold_right2 (fun id1 id2 alsig ->
-	match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in
-      array_fold_left2 (match_in u alp metas) sigma bl1 bl2
-  | GCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) ->
-      match_in u alp metas (match_in u alp metas sigma c1 c2) t1 t2
-  | GCast(_,c1, CastCoerce), ACast(c2, CastCoerce) ->
-      match_in u alp metas sigma c1 c2
-  | GSort (_,GType _), ASort (GType None) when not u -> sigma
-  | GSort (_,s1), ASort s2 when s1 = s2 -> sigma
-  | GPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match
-  | a, AHole _ -> sigma
-
-  (* On the fly eta-expansion so as to use notations of the form
-     "exists x, P x" for "ex P"; expects type not given because don't know
-     otherwise how to ensure it corresponds to a well-typed eta-expansion;
-     ensure at least one constructor is consumed to avoid looping *)
-  | b1, ALambda (Name id,AHole _,b2) when inner ->
-      let id' = Namegen.next_ident_away id (free_glob_vars b1) in
-      match_in u alp metas (bind_binder sigma id
-       [(Name id',Explicit,None,GHole(dummy_loc,Evd.BinderType (Name id')))])
-       (mkGApp dummy_loc b1 (GVar (dummy_loc,id'))) b2
-
-  | (GRec _ | GEvar _), _
-  | _,_ -> raise No_match
-
-and match_in u = match_ true u
-
-and match_hd u = match_ false u
-
-and match_binders u alp metas na1 na2 sigma b1 b2 =
-  let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in
-  match_in u alp metas sigma b1 b2
-
-and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
-  (* patl1 and patl2 have the same length because they respectively
-     correspond to some tml1 and tml2 that have the same length *)
-  let (alp,sigma) =
-    List.fold_left2 (match_cases_pattern_binders metas)
-      (alp,sigma) patl1 patl2 in
-  match_in u alp metas sigma rhs1 rhs2
-
-let match_aconstr u c (metas,pat) =
-  let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in
-  let vars = (List.map fst (fst vars), List.map fst (snd vars)) in
-  let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in
-  (* Reorder canonically the substitution *)
-  let find x =
-    try List.assoc x terms
-    with Not_found ->
-      (* Happens for binders bound to Anonymous *)
-      (* Find a better way to propagate Anonymous... *)
-      GVar (dummy_loc,x) in
-  List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') ->
-    match typ with
-    | NtnTypeConstr ->
-       ((find x, scl)::terms',termlists',binders')
-    | NtnTypeConstrList ->
-       (terms',(List.assoc x termlists,scl)::termlists',binders')
-    | NtnTypeBinderList ->
-       (terms',termlists',(List.assoc x binders,scl)::binders'))
-    metas ([],[],[])
-
-(* Matching cases pattern *)
-
-let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v =
-  try
-    let vvar = List.assoc var sigma in
-    if v=vvar then fullsigma else raise No_match
-  with Not_found ->
-    (* TODO: handle the case of multiple occs in different scopes *)
-    (var,v)::sigma,sigmalist,x
-
-let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
-  | r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1
-  | PatVar (_,Anonymous), AHole _ -> sigma
-  | PatCstr (loc,(ind,_ as r1),[],_), ARef (ConstructRef r2) when r1 = r2 ->
-      sigma
-  | PatCstr (loc,(ind,_ as r1),args1,_), AApp (ARef (ConstructRef r2),l2)
-      when r1 = r2 ->
-      let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in
-      if List.length l2 <> nparams + List.length args1
-      then
-	(* TODO: revert partially applied notations of the form
-           "Notation P := (@pair)." *)
-	raise No_match
-      else
-        let (p2,args2) = list_chop nparams l2 in
-        (* All parameters must be _ *)
-        List.iter (function AHole _ -> () | _ -> raise No_match) p2;
-	List.fold_left2 (match_cases_pattern metas) sigma args1 args2
-  | r1, AList (x,_,iter,termin,lassoc) ->
-      match_alist (fun (metas,_) -> match_cases_pattern metas)
-	(metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc
-  | _ -> raise No_match
-
-let match_aconstr_cases_pattern c (metas,pat) =
-  let vars = List.map fst metas in
-  let terms,termlists,() = match_cases_pattern vars ([],[],()) c pat in
-  (* Reorder canonically the substitution *)
-  List.fold_right (fun (x,(scl,typ)) (terms',termlists') ->
-    match typ with
-    | NtnTypeConstr -> ((List.assoc x terms, scl)::terms',termlists')
-    | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists')
-    | NtnTypeBinderList -> assert false)
-    metas ([],[])
-
-(**********************************************************************)
-(*s Concrete syntax for terms *)
-
-type notation = string
-
-type explicitation = ExplByPos of int * identifier option | ExplByName of identifier
-
-type binder_kind = Default of binding_kind | Generalized of binding_kind * binding_kind * bool
-
-type abstraction_kind = AbsLambda | AbsPi
-
-type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
-
-type prim_token = Numeral of Bigint.bigint | String of string
-
-type cases_pattern_expr =
-  | CPatAlias of loc * cases_pattern_expr * identifier
-  | CPatCstr of loc * reference * cases_pattern_expr list
-  | CPatCstrExpl of loc * reference * cases_pattern_expr list
-  | CPatAtom of loc * reference option
-  | CPatOr of loc * cases_pattern_expr list
-  | CPatNotation of loc * notation * cases_pattern_notation_substitution
-  | CPatPrim of loc * prim_token
-  | CPatRecord of Util.loc * (reference * cases_pattern_expr) list
-  | CPatDelimiters of loc * string * cases_pattern_expr
-
-and cases_pattern_notation_substitution =
-    cases_pattern_expr list *     (** for constr subterms *)
-    cases_pattern_expr list list  (** for recursive notations *)
-
-type constr_expr =
-  | CRef of reference
-  | CFix of loc * identifier located * fix_expr list
-  | CCoFix of loc * identifier located * cofix_expr list
-  | CArrow of loc * constr_expr * constr_expr
-  | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
-  | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
-  | CLetIn of loc * name located * constr_expr * constr_expr
-  | CAppExpl of loc * (proj_flag * reference) * constr_expr list
-  | CApp of loc * (proj_flag * constr_expr) *
-      (constr_expr * explicitation located option) list
-  | CRecord of loc * constr_expr option * (reference * constr_expr) list
-  | CCases of loc * case_style * constr_expr option *
-      (constr_expr * (name located option * constr_expr option)) list *
-      (loc * cases_pattern_expr list located list * constr_expr) list
-  | CLetTuple of loc * name located list * (name located option * constr_expr option) *
-      constr_expr * constr_expr
-  | CIf of loc * constr_expr * (name located option * constr_expr option)
-      * constr_expr * constr_expr
-  | CHole of loc * Evd.hole_kind option
-  | CPatVar of loc * (bool * patvar)
-  | CEvar of loc * existential_key * constr_expr list option
-  | CSort of loc * glob_sort
-  | CCast of loc * constr_expr * constr_expr cast_type
-  | CNotation of loc * notation * constr_notation_substitution
-  | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
-  | CPrim of loc * prim_token
-  | CDelimiters of loc * string * constr_expr
-
-and fix_expr =
-    identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
-
-and cofix_expr =
-    identifier located * local_binder list * constr_expr * constr_expr
-
-and recursion_order_expr =
-  | CStructRec
-  | CWfRec of constr_expr
-  | CMeasureRec of constr_expr * constr_expr option (* measure, relation *)
-
-and local_binder =
-  | LocalRawDef of name located * constr_expr
-  | LocalRawAssum of name located list * binder_kind * constr_expr
-
-and constr_notation_substitution =
-    constr_expr list *      (* for constr subterms *)
-    constr_expr list list * (* for recursive notations *)
-    local_binder list list      (* for binders subexpressions *)
-
-type typeclass_constraint = name located * binding_kind * constr_expr
-
-and typeclass_context = typeclass_constraint list
-
-type constr_pattern_expr = constr_expr
-
-(***********************)
-(* For binders parsing *)
-
-let default_binder_kind = Default Explicit
-
-let names_of_local_assums bl =
-  List.flatten (List.map (function LocalRawAssum(l,_,_)->l|_->[]) bl)
-
-let names_of_local_binders bl =
-  List.flatten (List.map (function LocalRawAssum(l,_,_)->l|LocalRawDef(l,_)->[l]) bl)
+let oldfashion_patterns = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments";
+  Goptions.optkey = ["Asymmetric";"Patterns"];
+  Goptions.optread = (fun () -> !oldfashion_patterns);
+  Goptions.optwrite = (fun a -> oldfashion_patterns:=a);
+}
 
 (**********************************************************************)
 (* Miscellaneous *)
@@ -933,68 +38,22 @@ let error_invalid_pattern_notation loc =
 (**********************************************************************)
 (* Functions on constr_expr *)
 
-let constr_loc = function
-  | CRef (Ident (loc,_)) -> loc
-  | CRef (Qualid (loc,_)) -> loc
-  | CFix (loc,_,_) -> loc
-  | CCoFix (loc,_,_) -> loc
-  | CArrow (loc,_,_) -> loc
-  | CProdN (loc,_,_) -> loc
-  | CLambdaN (loc,_,_) -> loc
-  | CLetIn (loc,_,_,_) -> loc
-  | CAppExpl (loc,_,_) -> loc
-  | CApp (loc,_,_) -> loc
-  | CRecord (loc,_,_) -> loc
-  | CCases (loc,_,_,_,_) -> loc
-  | CLetTuple (loc,_,_,_,_) -> loc
-  | CIf (loc,_,_,_,_) -> loc
-  | CHole (loc, _) -> loc
-  | CPatVar (loc,_) -> loc
-  | CEvar (loc,_,_) -> loc
-  | CSort (loc,_) -> loc
-  | CCast (loc,_,_) -> loc
-  | CNotation (loc,_,_) -> loc
-  | CGeneralization (loc,_,_,_) -> loc
-  | CPrim (loc,_) -> loc
-  | CDelimiters (loc,_,_) -> loc
-
-let cases_pattern_expr_loc = function
-  | CPatAlias (loc,_,_) -> loc
-  | CPatCstr (loc,_,_) -> loc
-  | CPatCstrExpl (loc,_,_) -> loc
-  | CPatAtom (loc,_) -> loc
-  | CPatOr (loc,_) -> loc
-  | CPatNotation (loc,_,_) -> loc
-  | CPatRecord (loc, _) -> loc
-  | CPatPrim (loc,_) -> loc
-  | CPatDelimiters (loc,_,_) -> loc
-
-let local_binder_loc = function
-  | LocalRawAssum ((loc,_)::_,_,t)
-  | LocalRawDef ((loc,_),t) -> join_loc loc (constr_loc t)
-  | LocalRawAssum ([],_,_) -> assert false
-
-let local_binders_loc bll =
-  if bll = [] then dummy_loc else
-  join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll))
-
 let ids_of_cases_indtype =
-  let add_var ids = function CRef (Ident (_,id)) -> id::ids | _ -> ids in
-  let rec vars_of = function
+  let rec vars_of ids = function
     (* We deal only with the regular cases *)
-    | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l)
-    | CNotation (_,_,(l,[],[]))
+    | (CPatCstr (_,_,l1,l2)|CPatNotation (_,_,(l1,[]),l2)) ->
+      List.fold_left vars_of (List.fold_left vars_of [] l2) l1
     (* assume the ntn is applicative and does not instantiate the head !! *)
-    | CAppExpl (_,_,l) -> List.fold_left add_var [] l
-    | CDelimiters(_,_,c) -> vars_of c
-    | _ -> [] in
-  vars_of
+    | CPatDelimiters(_,_,c) -> vars_of ids c
+    | CPatAtom (_, Some (Libnames.Ident (_, x))) -> x::ids
+    | _ -> ids in
+  vars_of []
 
 let ids_of_cases_tomatch tms =
   List.fold_right
     (fun (_,(ona,indnal)) l ->
       Option.fold_right (fun t -> (@) (ids_of_cases_indtype t))
-      indnal (Option.fold_right (down_located name_cons) ona l))
+      indnal (Option.fold_right (Loc.down_located name_cons) ona l))
     tms []
 
 let is_constructor id =
@@ -1005,19 +64,23 @@ let rec cases_pattern_fold_names f a = function
   | CPatRecord (_, l) ->
       List.fold_left (fun acc (r, cp) -> cases_pattern_fold_names f acc cp) a l
   | CPatAlias (_,pat,id) -> f id a
-  | CPatCstr (_,_,patl) | CPatCstrExpl (_,_,patl) | CPatOr (_,patl) ->
+  | CPatOr (_,patl) ->
       List.fold_left (cases_pattern_fold_names f) a patl
-  | CPatNotation (_,_,(patl,patll)) ->
-      List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)
+  | CPatCstr (_,_,patl1,patl2) ->
+    List.fold_left (cases_pattern_fold_names f)
+      (List.fold_left (cases_pattern_fold_names f) a patl1) patl2
+  | CPatNotation (_,_,(patl,patll),patl') ->
+      List.fold_left (cases_pattern_fold_names f)
+	(List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl'
   | CPatDelimiters (_,_,pat) -> cases_pattern_fold_names f a pat
   | CPatAtom (_,Some (Ident (_,id))) when not (is_constructor id) -> f id a
   | CPatPrim _ | CPatAtom _ -> a
 
 let ids_of_pattern_list =
   List.fold_left
-    (located_fold_left
-      (List.fold_left (cases_pattern_fold_names Idset.add)))
-    Idset.empty
+    (Loc.located_fold_left
+      (List.fold_left (cases_pattern_fold_names Id.Set.add)))
+    Id.Set.empty
 
 let rec fold_constr_expr_binders g f n acc b = function
   | (nal,bk,t)::l ->
@@ -1038,18 +101,17 @@ let rec fold_local_binders g f n acc b = function
       f n acc b
 
 let fold_constr_expr_with_binders g f n acc = function
-  | CArrow (loc,a,b) -> f n (f n acc a) b
-  | CAppExpl (loc,(_,_),l) -> List.fold_left (f n) acc l
+  | CAppExpl (loc,(_,_,_),l) -> List.fold_left (f n) acc l
   | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l)
   | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l
   | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a]
-  | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b
+  | CCast (loc,a,(CastConv b|CastVM b|CastNative b)) -> f n (f n acc a) b
   | CCast (loc,a,CastCoerce) -> f n acc a
   | CNotation (_,_,(l,ll,bll)) ->
       (* The following is an approximation: we don't know exactly if
          an ident is binding nor to which subterms bindings apply *)
       let acc = List.fold_left (f n) acc (l@List.flatten ll) in
-      List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll
+      List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (Loc.ghost,None,IntroAnonymous,None)) bl) acc bll
   | CGeneralization (_,_,_,c) -> f n acc c
   | CDelimiters (loc,_,a) -> f n acc a
   | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ ->
@@ -1061,93 +123,29 @@ let fold_constr_expr_with_binders g f n acc = function
       let acc = List.fold_left (f n) acc (List.map fst al) in
       List.fold_right (fun (loc,patl,rhs) acc ->
 	let ids = ids_of_pattern_list patl in
-	f (Idset.fold g ids n) acc rhs) bl acc
+	f (Id.Set.fold g ids n) acc rhs) bl acc
   | CLetTuple (loc,nal,(ona,po),b,c) ->
-      let n' = List.fold_right (down_located (name_fold g)) nal n in
-      f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c
+      let n' = List.fold_right (Loc.down_located (name_fold g)) nal n in
+      f (Option.fold_right (Loc.down_located (name_fold g)) ona n') (f n acc b) c
   | CIf (_,c,(ona,po),b1,b2) ->
       let acc = f n (f n (f n acc b1) b2) c in
       Option.fold_left
-	(f (Option.fold_right (down_located (name_fold g)) ona n)) acc po
+	(f (Option.fold_right (Loc.down_located (name_fold g)) ona n)) acc po
   | CFix (loc,_,l) ->
       let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in
       List.fold_right (fun (_,(_,o),lb,t,c) acc ->
 	fold_local_binders g f n'
 	  (fold_local_binders g f n acc t lb) c lb) l acc
   | CCoFix (loc,_,_) ->
-      Pp.msg_warn "Capture check in multiple binders not done"; acc
+      msg_warning (strbrk "Capture check in multiple binders not done"); acc
 
 let free_vars_of_constr_expr c =
   let rec aux bdvars l = function
-  | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l
+  | CRef (Ident (_,id),_) -> if Id.List.mem id bdvars then l else Id.Set.add id l
   | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c
-  in aux [] Idset.empty c
-
-let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c)
-
-let mkIdentC id  = CRef (Ident (dummy_loc, id))
-let mkRefC r     = CRef r
-let mkCastC (a,k)  = CCast (dummy_loc,a,k)
-let mkLambdaC (idl,bk,a,b) = CLambdaN (dummy_loc,[idl,bk,a],b)
-let mkLetInC (id,a,b)   = CLetIn (dummy_loc,id,a,b)
-let mkProdC (idl,bk,a,b)   = CProdN (dummy_loc,[idl,bk,a],b)
-
-let mkAppC (f,l) =
-  let l = List.map (fun x -> (x,None)) l in
-  match f with
-  | CApp (_,g,l') -> CApp (dummy_loc, g, l' @ l)
-  | _ -> CApp (dummy_loc, (None, f), l)
-
-let rec mkCProdN loc bll c =
-  match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
-      CProdN (loc,[idl,bk,t],mkCProdN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll ->
-      CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c)
-  | [] -> c
-  | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c
-
-let rec mkCLambdaN loc bll c =
-  match bll with
-  | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll ->
-      CLambdaN (loc,[idl,bk,t],mkCLambdaN (join_loc loc1 loc) bll c)
-  | LocalRawDef ((loc1,_) as id,b) :: bll ->
-      CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c)
-  | [] -> c
-  | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c
-
-let rec abstract_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_constr_expr c bl)
-  | LocalRawAssum (idl,bk,t)::bl ->
-      List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl
-      (abstract_constr_expr c bl)
+  in aux [] Id.Set.empty c
 
-let rec prod_constr_expr c = function
-  | [] -> c
-  | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl)
-  | LocalRawAssum (idl,bk,t)::bl ->
-      List.fold_right (fun x b -> mkProdC([x],bk,t,b)) idl
-      (prod_constr_expr c bl)
-
-let coerce_reference_to_id = function
-  | Ident (_,id) -> id
-  | Qualid (loc,_) ->
-      user_err_loc (loc, "coerce_reference_to_id",
-        str "This expression should be a simple identifier.")
-
-let coerce_to_id = function
-  | CRef (Ident (loc,id)) -> (loc,id)
-  | a -> user_err_loc
-        (constr_loc a,"coerce_to_id",
-         str "This expression should be a simple identifier.")
-
-let coerce_to_name = function
-  | CRef (Ident (loc,id)) -> (loc,Name id)
-  | CHole (loc,_) -> (loc,Anonymous)
-  | a -> user_err_loc
-        (constr_loc a,"coerce_to_name",
-         str "This expression should be a name.")
+let occur_var_constr_expr id c = Id.Set.mem id (free_vars_of_constr_expr c)
 
 (* Interpret the index of a recursion order annotation *)
 
@@ -1155,16 +153,27 @@ let split_at_annot bl na =
   let names = List.map snd (names_of_local_assums bl) in
   match na with
   | None ->
-      if names = [] then error "A fixpoint needs at least one parameter."
-      else [], bl
+      begin match names with
+      | [] -> error "A fixpoint needs at least one parameter."
+      | _ -> ([], bl)
+      end
   | Some (loc, id) ->
       let rec aux acc = function
 	| LocalRawAssum (bls, k, t) as x :: rest ->
-	    let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in
-	      if r = [] then aux (x :: acc) rest
-	      else
-		(List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc),
-		 LocalRawAssum (r, k, t) :: rest)
+            let test (_, na) = match na with
+            | Name id' -> Id.equal id id'
+            | Anonymous -> false
+            in
+	    let l, r = List.split_when test bls in
+            begin match r with
+            | [] -> aux (x :: acc) rest
+            | _ ->
+              let ans = match l with
+              | [] -> acc
+              | _ -> LocalRawAssum (l, k, t) :: acc
+              in
+              (List.rev ans, LocalRawAssum (r, k, t) :: rest)
+            end
 	| LocalRawDef _ as x :: rest -> aux (x :: acc) rest
 	| [] ->
             user_err_loc(loc,"",
@@ -1173,7 +182,7 @@ let split_at_annot bl na =
 
 (* Used in correctness and interface *)
 
-let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e
+let map_binder g e nal = List.fold_right (Loc.down_located (name_fold g)) nal e
 
 let map_binders f g e bl =
   (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *)
@@ -1192,7 +201,6 @@ let map_local_binders f g e bl =
   (e, List.rev rbl)
 
 let map_constr_expr_with_binders g f e = function
-  | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b)
   | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l)
   | CApp (loc,(p,a),l) ->
       CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l)
@@ -1201,8 +209,7 @@ let map_constr_expr_with_binders g f e = function
   | CLambdaN (loc,bl,b) ->
       let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b)
   | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b)
-  | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b))
-  | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce)
+  | CCast (loc,a,c) -> CCast (loc,f e a, Miscops.map_cast_type (f e) c)
   | CNotation (loc,n,(l,ll,bll)) ->
       (* This is an approximation because we don't know what binds what *)
       CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll,
@@ -1219,11 +226,11 @@ let map_constr_expr_with_binders g f e = function
       let po = Option.map (f (List.fold_right g ids e)) rtnpo in
       CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl)
   | CLetTuple (loc,nal,(ona,po),b,c) ->
-      let e' = List.fold_right (down_located (name_fold g)) nal e in
-      let e'' = Option.fold_right (down_located (name_fold g)) ona e in
+      let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in
+      let e'' = Option.fold_right (Loc.down_located (name_fold g)) ona e in
       CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c)
   | CIf (loc,c,(ona,po),b1,b2) ->
-      let e' = Option.fold_right (down_located (name_fold g)) ona e in
+      let e' = Option.fold_right (Loc.down_located (name_fold g)) ona e in
       CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2)
   | CFix (loc,id,dl) ->
       CFix (loc,id,List.map (fun (id,n,bl,t,d) ->
@@ -1243,33 +250,21 @@ let map_constr_expr_with_binders g f e = function
 
 (* Used in constrintern *)
 let rec replace_vars_constr_expr l = function
-  | CRef (Ident (loc,id)) as x ->
-      (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x)
-  | c -> map_constr_expr_with_binders List.remove_assoc
+  | CRef (Ident (loc,id),us) as x ->
+      (try CRef (Ident (loc,Id.Map.find id l),us) with Not_found -> x)
+  | c -> map_constr_expr_with_binders Id.Map.remove
            replace_vars_constr_expr l c
 
-(**********************************************************************)
-(* Concrete syntax for modules and modules types *)
-
-type with_declaration_ast =
-  | CWith_Module of identifier list located * qualid located
-  | CWith_Definition of identifier list located * constr_expr
-
-type module_ast =
-  | CMident of qualid located
-  | CMapply of loc * module_ast * module_ast
-  | CMwith of loc * module_ast * with_declaration_ast
-
 (* Returns the ranges of locs of the notation that are not occupied by args  *)
 (* and which are then occupied by proper symbols of the notation (or spaces) *)
 
 let locs_of_notation loc locs ntn =
-  let (bl,el) = Util.unloc loc in
-  let locs =  List.map Util.unloc locs in
+  let (bl, el) = Loc.unloc loc in
+  let locs =  List.map Loc.unloc locs in
   let rec aux pos = function
-    | [] -> if pos = el then [] else [(pos,el-1)]
-    | (ba,ea)::l ->if pos = ba then aux ea l else (pos,ba-1)::aux ea l
-  in aux bl (Sort.list (fun l1 l2 -> fst l1 < fst l2) locs)
+    | [] -> if Int.equal pos el then [] else [(pos,el)]
+    | (ba,ea)::l -> if Int.equal pos ba then aux ea l else (pos,ba)::aux ea l
+  in aux bl (List.sort (fun l1 l2 -> fst l1 - fst l2) locs)
 
 let ntn_loc loc (args,argslist,binderslist) =
   locs_of_notation loc
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index 39ec8e74..b25d7082 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -1,274 +1,49 @@
 (************************************************************************)
 (*  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 Loc
 open Names
-open Libnames
-open Glob_term
-open Term
-open Mod_subst
+open Constrexpr
 
-(** Topconstr: definitions of [aconstr] et [constr_expr] *)
+(** Topconstr *)
 
-(** {6 aconstr } *)
-(** This is the subtype of glob_constr allowed in syntactic extensions 
-   No location since intended to be substituted at any place of a text 
-   Complex expressions such as fixpoints and cofixpoints are excluded, 
-   non global expressions such as existential variables also *)
+val oldfashion_patterns : bool ref
 
-type aconstr =
-  (** Part common to [glob_constr] and [cases_pattern] *)
-  | ARef of global_reference
-  | AVar of identifier
-  | AApp of aconstr * aconstr list
-  | AList of identifier * identifier * aconstr * aconstr * bool
-  (** Part only in [glob_constr] *)
-  | ALambda of name * aconstr * aconstr
-  | AProd of name * aconstr * aconstr
-  | ABinderList of identifier * identifier * aconstr * aconstr
-  | ALetIn of name * aconstr * aconstr
-  | ACases of case_style * aconstr option *
-      (aconstr * (name * (inductive * int * name list) option)) list *
-      (cases_pattern list * aconstr) list
-  | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr
-  | AIf of aconstr * (name * aconstr option) * aconstr * aconstr
-  | ARec of fix_kind * identifier array *
-      (name * aconstr option * aconstr) list array * aconstr array *
-      aconstr array
-  | ASort of glob_sort
-  | AHole of Evd.hole_kind
-  | APatVar of patvar
-  | ACast of aconstr * aconstr cast_type
-
-type scope_name = string
-
-type tmp_scope_name = scope_name
-
-type subscopes = tmp_scope_name option * scope_name list
-
-(** Type of the meta-variables of an aconstr: in a recursive pattern x..y,
-    x carries the sequence of objects bound to the list x..y  *)
-type notation_var_instance_type =
-  | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList
-
-(** Type of variables when interpreting a constr_expr as an aconstr:
-    in a recursive pattern x..y, both x and y carry the individual type
-    of each element of the list x..y *)
-type notation_var_internalization_type =
-  | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent
-
-(** This characterizes to what a notation is interpreted to *)
-type interpretation =
-    (identifier * (subscopes * notation_var_instance_type)) list * aconstr
-
-(** Translate a glob_constr into a notation given the list of variables
-    bound by the notation; also interpret recursive patterns           *)
-
-val aconstr_of_glob_constr :
-  (identifier * notation_var_internalization_type) list ->
-  (identifier * identifier) list -> glob_constr -> aconstr
-
-(** Name of the special identifier used to encode recursive notations  *)
-val ldots_var : identifier
-
-(** Equality of glob_constr (warning: only partially implemented) *)
-val eq_glob_constr : glob_constr -> glob_constr -> bool
-
-(** Re-interpret a notation as a glob_constr, taking care of binders     *)
-
-val glob_constr_of_aconstr_with_binders : loc ->
-  ('a -> name -> 'a * name) ->
-  ('a -> aconstr -> glob_constr) -> 'a -> aconstr -> glob_constr
-
-val glob_constr_of_aconstr : loc -> aconstr -> glob_constr
-
-(** [match_aconstr] matches a glob_constr against a notation interpretation;
-    raise [No_match] if the matching fails   *)
-
-exception No_match
-
-val match_aconstr : bool -> glob_constr -> interpretation ->
-      (glob_constr * subscopes) list * (glob_constr list * subscopes) list *
-      (glob_decl list * subscopes) list
-
-val match_aconstr_cases_pattern :  cases_pattern -> interpretation ->
-      (cases_pattern * subscopes) list * (cases_pattern list * subscopes) list
-
-(** Substitution of kernel names in interpretation data                *)
-
-val subst_interpretation : substitution -> interpretation -> interpretation
-
-(** {6 Concrete syntax for terms }                                        *)
-
-type notation = string
-
-type explicitation = ExplByPos of int * identifier option | ExplByName of identifier
-
-type binder_kind =
-  | Default of binding_kind
-  | Generalized of binding_kind * binding_kind * bool
-      (** Inner binding, outer bindings, typeclass-specific flag
-	 for implicit generalization of superclasses *)
-
-type abstraction_kind = AbsLambda | AbsPi
-
-type proj_flag = int option (** [Some n] = proj of the n-th visible argument *)
-
-type prim_token = Numeral of Bigint.bigint | String of string
-
-type cases_pattern_expr =
-  | CPatAlias of loc * cases_pattern_expr * identifier
-  | CPatCstr of loc * reference * cases_pattern_expr list
-  | CPatCstrExpl of loc * reference * cases_pattern_expr list
-  | CPatAtom of loc * reference option
-  | CPatOr of loc * cases_pattern_expr list
-  | CPatNotation of loc * notation * cases_pattern_notation_substitution
-  | CPatPrim of loc * prim_token
-  | CPatRecord of Util.loc * (reference * cases_pattern_expr) list
-  | CPatDelimiters of loc * string * cases_pattern_expr
-
-and cases_pattern_notation_substitution =
-    cases_pattern_expr list *     (** for constr subterms *)
-    cases_pattern_expr list list  (** for recursive notations *)
-
-type constr_expr =
-  | CRef of reference
-  | CFix of loc * identifier located * fix_expr list
-  | CCoFix of loc * identifier located * cofix_expr list
-  | CArrow of loc * constr_expr * constr_expr
-  | CProdN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
-  | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr
-  | CLetIn of loc * name located * constr_expr * constr_expr
-  | CAppExpl of loc * (proj_flag * reference) * constr_expr list
-  | CApp of loc * (proj_flag * constr_expr) *
-      (constr_expr * explicitation located option) list
-  | CRecord of loc * constr_expr option * (reference * constr_expr) list
-  | CCases of loc * case_style * constr_expr option *
-      (constr_expr * (name located option * constr_expr option)) list *
-      (loc * cases_pattern_expr list located list * constr_expr) list
-  | CLetTuple of loc * name located list * (name located option * constr_expr option) *
-      constr_expr * constr_expr
-  | CIf of loc * constr_expr * (name located option * constr_expr option)
-      * constr_expr * constr_expr
-  | CHole of loc * Evd.hole_kind option
-  | CPatVar of loc * (bool * patvar)
-  | CEvar of loc * existential_key * constr_expr list option
-  | CSort of loc * glob_sort
-  | CCast of loc * constr_expr * constr_expr cast_type
-  | CNotation of loc * notation * constr_notation_substitution
-  | CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
-  | CPrim of loc * prim_token
-  | CDelimiters of loc * string * constr_expr
-
-and fix_expr =
-    identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
-
-and cofix_expr =
-    identifier located * local_binder list * constr_expr * constr_expr
-
-and recursion_order_expr =
-  | CStructRec
-  | CWfRec of constr_expr
-  | CMeasureRec of constr_expr * constr_expr option (** measure, relation *)
-
-(** Anonymous defs allowed ?? *)
-and local_binder =
-  | LocalRawDef of name located * constr_expr
-  | LocalRawAssum of name located list * binder_kind * constr_expr
-
-and constr_notation_substitution =
-    constr_expr list *      (** for constr subterms *)
-    constr_expr list list * (** for recursive notations *)
-    local_binder list list (** for binders subexpressions *)
-
-type typeclass_constraint = name located * binding_kind * constr_expr
-
-and typeclass_context = typeclass_constraint list
-
-type constr_pattern_expr = constr_expr
-
-(** Utilities on constr_expr                                           *)
-
-val constr_loc : constr_expr -> loc
-
-val cases_pattern_expr_loc : cases_pattern_expr -> loc
-
-val local_binders_loc : local_binder list -> loc
+(** Utilities on constr_expr *)
 
 val replace_vars_constr_expr :
-  (identifier * identifier) list -> constr_expr -> constr_expr
+  Id.t Id.Map.t -> constr_expr -> constr_expr
 
-val free_vars_of_constr_expr : constr_expr -> Idset.t
-val occur_var_constr_expr : identifier -> constr_expr -> bool
-
-val default_binder_kind : binder_kind
+val free_vars_of_constr_expr : constr_expr -> Id.Set.t
+val occur_var_constr_expr : Id.t -> constr_expr -> bool
 
 (** Specific function for interning "in indtype" syntax of "match" *)
-val ids_of_cases_indtype : constr_expr -> identifier list
-
-val mkIdentC : identifier -> constr_expr
-val mkRefC : reference -> constr_expr
-val mkAppC : constr_expr * constr_expr list -> constr_expr
-val mkCastC : constr_expr * constr_expr cast_type -> constr_expr
-val mkLambdaC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr
-val mkLetInC : name located * constr_expr * constr_expr -> constr_expr
-val mkProdC : name located list * binder_kind * constr_expr * constr_expr -> constr_expr
-
-val coerce_reference_to_id : reference -> identifier
-val coerce_to_id : constr_expr -> identifier located
-val coerce_to_name : constr_expr -> name located
-
-val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list
-
-val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
-val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
+val ids_of_cases_indtype : cases_pattern_expr -> Id.t list
 
-(** Same as [abstract_constr_expr] and [prod_constr_expr], with location *)
-val mkCLambdaN : loc -> local_binder list -> constr_expr -> constr_expr
-val mkCProdN : loc -> local_binder list -> constr_expr -> constr_expr
-
-(** For binders parsing *)
-
-(** With let binders *)
-val names_of_local_binders : local_binder list -> name located list
-
-(** Does not take let binders into account *)
-val names_of_local_assums : local_binder list -> name located list
+val split_at_annot : local_binder list -> Id.t located option -> local_binder list * local_binder list
 
 (** Used in typeclasses *)
 
-val fold_constr_expr_with_binders : (identifier -> 'a -> 'a) ->
+val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) ->
    ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b
 
 (** Used in correctness and interface; absence of var capture not guaranteed 
    in pattern-matching clauses and in binders of the form [x,y:T(x)] *)
 
 val map_constr_expr_with_binders :
-  (identifier -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) ->
+  (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) ->
       'a -> constr_expr -> constr_expr
 
-(** Concrete syntax for modules and module types                       *)
-
-type with_declaration_ast =
-  | CWith_Module of identifier list located * qualid located
-  | CWith_Definition of identifier list located * constr_expr
-
-type module_ast =
-  | CMident of qualid located
-  | CMapply of loc * module_ast * module_ast
-  | CMwith of loc * module_ast * with_declaration_ast
-
 val ntn_loc :
-  Util.loc -> constr_notation_substitution -> string -> (int * int) list
+  Loc.t -> constr_notation_substitution -> string -> (int * int) list
 val patntn_loc :
-  Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list
+  Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list
 
 (** For cases pattern parsing errors *)
 
-val error_invalid_pattern_notation : Util.loc -> 'a
+val error_invalid_pattern_notation : Loc.t -> 'a
diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli
new file mode 100644
index 00000000..79f4e99e
--- /dev/null
+++ b/intf/constrexpr.mli
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  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 Loc
+open Names
+open Libnames
+open Misctypes
+open Decl_kinds
+
+(** {6 Concrete syntax for terms } *)
+
+(** [constr_expr] is the abstract syntax tree produced by the parser *)
+
+type notation = string
+
+type explicitation =
+  | ExplByPos of int * Id.t option
+  | ExplByName of Id.t
+
+type binder_kind =
+  | Default of binding_kind
+  | Generalized of binding_kind * binding_kind * bool
+      (** Inner binding, outer bindings, typeclass-specific flag
+	 for implicit generalization of superclasses *)
+
+type abstraction_kind = AbsLambda | AbsPi
+
+type proj_flag = int option (** [Some n] = proj of the n-th visible argument *)
+
+type prim_token = Numeral of Bigint.bigint | String of string
+
+type raw_cases_pattern_expr =
+  | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t
+  | RCPatCstr of Loc.t * Globnames.global_reference
+    * raw_cases_pattern_expr list * raw_cases_pattern_expr list
+  (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *)
+  | RCPatAtom of Loc.t * Id.t option
+  | RCPatOr of Loc.t * raw_cases_pattern_expr list
+
+type cases_pattern_expr =
+  | CPatAlias of Loc.t * cases_pattern_expr * Id.t
+  | CPatCstr of Loc.t * reference
+    * cases_pattern_expr list * cases_pattern_expr list
+  (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *)
+  | CPatAtom of Loc.t * reference option
+  | CPatOr of Loc.t * cases_pattern_expr list
+  | CPatNotation of Loc.t * notation * cases_pattern_notation_substitution
+    * cases_pattern_expr list (** CPatNotation (_, n, l1 ,l2) represents
+				  (notation n applied with substitution l1)
+				  applied to arguments l2 *)
+  | CPatPrim of Loc.t * prim_token
+  | CPatRecord of Loc.t * (reference * cases_pattern_expr) list
+  | CPatDelimiters of Loc.t * string * cases_pattern_expr
+
+and cases_pattern_notation_substitution =
+    cases_pattern_expr list *     (** for constr subterms *)
+    cases_pattern_expr list list  (** for recursive notations *)
+
+type instance_expr = Misctypes.glob_level list
+
+type constr_expr =
+  | CRef of reference * instance_expr option
+  | CFix of Loc.t * Id.t located * fix_expr list
+  | CCoFix of Loc.t * Id.t located * cofix_expr list
+  | CProdN of Loc.t * binder_expr list * constr_expr
+  | CLambdaN of Loc.t * binder_expr list * constr_expr
+  | CLetIn of Loc.t * Name.t located * constr_expr * constr_expr
+  | CAppExpl of Loc.t * (proj_flag * reference * instance_expr option) * constr_expr list
+  | CApp of Loc.t * (proj_flag * constr_expr) *
+      (constr_expr * explicitation located option) list
+  | CRecord of Loc.t * constr_expr option * (reference * constr_expr) list
+  | CCases of Loc.t * case_style * constr_expr option *
+      case_expr list * branch_expr list
+  | CLetTuple of Loc.t * Name.t located list * (Name.t located option * constr_expr option) *
+      constr_expr * constr_expr
+  | CIf of Loc.t * constr_expr * (Name.t located option * constr_expr option)
+      * constr_expr * constr_expr
+  | CHole of Loc.t * Evar_kinds.t option * intro_pattern_naming_expr * Genarg.raw_generic_argument option
+  | CPatVar of Loc.t * patvar
+  | CEvar of Loc.t * Glob_term.existential_name * (Id.t * constr_expr) list
+  | CSort of Loc.t * glob_sort
+  | CCast of Loc.t * constr_expr * constr_expr cast_type
+  | CNotation of Loc.t * notation * constr_notation_substitution
+  | CGeneralization of Loc.t * binding_kind * abstraction_kind option * constr_expr
+  | CPrim of Loc.t * prim_token
+  | CDelimiters of Loc.t * string * constr_expr
+
+and case_expr =
+  constr_expr * (Name.t located option * cases_pattern_expr option)
+
+and branch_expr =
+  Loc.t * cases_pattern_expr list located list * constr_expr
+
+and binder_expr =
+  Name.t located list * binder_kind * constr_expr
+
+and fix_expr =
+    Id.t located * (Id.t located option * recursion_order_expr) *
+      local_binder list * constr_expr * constr_expr
+
+and cofix_expr =
+    Id.t located * local_binder list * constr_expr * constr_expr
+
+and recursion_order_expr =
+  | CStructRec
+  | CWfRec of constr_expr
+  | CMeasureRec of constr_expr * constr_expr option (** measure, relation *)
+
+(** Anonymous defs allowed ?? *)
+and local_binder =
+  | LocalRawDef of Name.t located * constr_expr
+  | LocalRawAssum of Name.t located list * binder_kind * constr_expr
+
+and constr_notation_substitution =
+    constr_expr list *      (** for constr subterms *)
+    constr_expr list list * (** for recursive notations *)
+    local_binder list list (** for binders subexpressions *)
+
+type typeclass_constraint = Name.t located * binding_kind * constr_expr
+
+and typeclass_context = typeclass_constraint list
+
+type constr_pattern_expr = constr_expr
+
+(** Concrete syntax for modules and module types *)
+
+type with_declaration_ast =
+  | CWith_Module of Id.t list located * qualid located
+  | CWith_Definition of Id.t list located * constr_expr
+
+type module_ast =
+  | CMident of qualid located
+  | CMapply of Loc.t * module_ast * module_ast
+  | CMwith of Loc.t * module_ast * with_declaration_ast
diff --git a/library/decl_kinds.mli b/intf/decl_kinds.mli
index 44f5cbab..6886083c 100644
--- a/library/decl_kinds.mli
+++ b/intf/decl_kinds.mli
@@ -1,19 +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        *)
 (************************************************************************)
 
-open Util
-open Libnames
-
 (** Informal mathematical status of declarations *)
 
-type locality =
-  | Local
-  | Global
+type locality = Discharge | Local | Global
+
+type binding_kind = Explicit | Implicit
+
+type polymorphic = bool
+
+type private_flag = bool 
 
 type theorem_kind =
   | Theorem
@@ -48,9 +49,9 @@ type assumption_object_kind = Definitional | Logical | Conjectural
    Logical      |  Hypothesis | Axiom
 
 *)
-type assumption_kind = locality * assumption_object_kind
+type assumption_kind = locality * polymorphic * assumption_object_kind
 
-type definition_kind = locality * definition_object_kind
+type definition_kind = locality * polymorphic * definition_object_kind
 
 (** Kinds used in proofs *)
 
@@ -58,7 +59,7 @@ type goal_object_kind =
   | DefinitionBody of definition_object_kind
   | Proof of theorem_kind
 
-type goal_kind = locality * goal_object_kind
+type goal_kind = locality * polymorphic * goal_object_kind
 
 (** Kinds used in library *)
 
@@ -67,24 +68,9 @@ type logical_kind =
   | IsDefinition of definition_object_kind
   | IsProof of theorem_kind
 
-(** Utils *)
-
-val logical_kind_of_goal_kind : goal_object_kind -> logical_kind
-val string_of_theorem_kind : theorem_kind -> string
-val string_of_definition_kind :
-  locality * definition_object_kind -> string
-
-(** About locality *)
-
-val strength_of_global : global_reference -> locality
-val string_of_strength : locality -> string
-
-(** About recursive power of type declarations *)
+(** Recursive power of type declarations *)
 
 type recursivity_kind =
   | Finite (** = inductive *)
   | CoFinite (** = coinductive *)
   | BiFinite (** = non-recursive, like in "Record" definitions *)
-
-(** helper, converts to "finiteness flag" booleans *)
-val recursivity_flag_of_kind : recursivity_kind -> bool
diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli
new file mode 100644
index 00000000..38a3e81f
--- /dev/null
+++ b/intf/evar_kinds.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  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 Names
+open Globnames
+
+(** The kinds of existential variable *)
+
+(** Should the obligation be defined (opaque or transparent (default)) or
+    defined transparent and expanded in the term? *)
+
+type obligation_definition_status = Define of bool | Expand
+
+type t =
+  | ImplicitArg of global_reference * (int * Id.t option)
+     * bool (** Force inference *)
+  | BinderType of Name.t
+  | QuestionMark of obligation_definition_status
+  | CasesType of bool (* true = a subterm of the type *)
+  | InternalHole
+  | TomatchTypeParameter of inductive * int
+  | GoalEvar
+  | ImpossibleCase
+  | MatchingVar of bool * Id.t
+  | VarInstance of Id.t
+  | SubEvar of Constr.existential_key
diff --git a/parsing/extend.mli b/intf/extend.mli
index dd8ed0cd..ad9706f3 100644
--- a/parsing/extend.mli
+++ b/intf/extend.mli
@@ -1,17 +1,24 @@
 (************************************************************************)
 (*  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
-
 (** Entry keys for constr notations *)
 
 type side = Left | Right
 
+type gram_assoc = NonA | RightA | LeftA
+
+type gram_position =
+  | First
+  | Last
+  | Before of string
+  | After of string
+  | Level of string
+
 type production_position =
   | BorderProd of side * gram_assoc option
   | InternalProd
diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli
new file mode 100644
index 00000000..61340914
--- /dev/null
+++ b/intf/genredexpr.mli
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Reduction expressions *)
+
+(** The parsing produces initially a list of [red_atom] *)
+
+type 'a red_atom =
+  | FBeta
+  | FIota
+  | FZeta
+  | FConst of 'a list
+  | FDeltaBut of 'a list
+
+(** This list of atoms is immediately converted to a [glob_red_flag] *)
+
+type 'a glob_red_flag = {
+  rBeta : bool;
+  rIota : bool;
+  rZeta : bool;
+  rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*)
+  rConst : 'a list
+}
+
+(** Generic kinds of reductions *)
+
+type ('a,'b,'c) red_expr_gen =
+  | Red of bool
+  | Hnf
+  | Simpl of 'b glob_red_flag*('b,'c) Util.union Locus.with_occurrences option
+  | Cbv of 'b glob_red_flag
+  | Cbn of 'b glob_red_flag
+  | Lazy of 'b glob_red_flag
+  | Unfold of 'b Locus.with_occurrences list
+  | Fold of 'a list
+  | Pattern of 'a Locus.with_occurrences list
+  | ExtraRedExpr of string
+  | CbvVm of ('b,'c) Util.union Locus.with_occurrences option
+  | CbvNative of ('b,'c) Util.union Locus.with_occurrences option
+
+type ('a,'b,'c) may_eval =
+  | ConstrTerm of 'a
+  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
+  | ConstrContext of (Loc.t * Names.Id.t) * 'a
+  | ConstrTypeOf of 'a
diff --git a/intf/glob_term.mli b/intf/glob_term.mli
new file mode 100644
index 00000000..32cf9eaf
--- /dev/null
+++ b/intf/glob_term.mli
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Untyped intermediate terms *)
+
+(** [glob_constr] comes after [constr_expr] and before [constr].
+
+   Resolution of names, insertion of implicit arguments placeholder,
+   and notations are done, but coercions, inference of implicit
+   arguments and pattern-matching compilation are not. *)
+
+open Names
+open Globnames
+open Decl_kinds
+open Misctypes
+
+type existential_name = Id.t
+
+(**  The kind of patterns that occurs in "match ... with ... end"
+
+     locs here refers to the ident's location, not whole pat *)
+type cases_pattern =
+  | PatVar of Loc.t * Name.t
+  | PatCstr of Loc.t * constructor * cases_pattern list * Name.t
+      (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *)
+
+type glob_constr =
+  | GRef of (Loc.t * global_reference * glob_level list option)
+  | GVar of (Loc.t * Id.t)
+  | GEvar of Loc.t * existential_name * (Id.t * glob_constr) list
+  | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *)
+  | GApp of Loc.t * glob_constr * glob_constr list
+  | GLambda of Loc.t * Name.t * binding_kind *  glob_constr * glob_constr
+  | GProd of Loc.t * Name.t * binding_kind * glob_constr * glob_constr
+  | GLetIn of Loc.t * Name.t * glob_constr * glob_constr
+  | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses
+      (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in
+	  [MatchStyle]) *)
+  | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) *
+      glob_constr * glob_constr
+  | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr
+  | GRec of Loc.t * fix_kind * Id.t array * glob_decl list array *
+      glob_constr array * glob_constr array
+  | GSort of Loc.t * glob_sort
+  | GHole of (Loc.t * Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option)
+  | GCast of Loc.t * glob_constr * glob_constr cast_type
+
+and glob_decl = Name.t * binding_kind * glob_constr option * glob_constr
+
+and fix_recursion_order =
+  | GStructRec
+  | GWfRec of glob_constr
+  | GMeasureRec of glob_constr * glob_constr option
+
+and fix_kind =
+  | GFix of ((int option * fix_recursion_order) array * int)
+  | GCoFix of int
+
+and predicate_pattern =
+    Name.t * (Loc.t * inductive * Name.t list) option
+      (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *)
+
+and tomatch_tuple = (glob_constr * predicate_pattern)
+
+and tomatch_tuples = tomatch_tuple list
+
+and cases_clause = (Loc.t * Id.t list * cases_pattern list * glob_constr)
+(** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables
+    of [t] are members of [il]. *)
+and cases_clauses = cases_clause list
+
+(** A globalised term together with a closure representing the value
+    of its free variables. Intended for use when these variables are taken
+    from the Ltac environment. *)
+type closure = {
+  idents:Id.t Id.Map.t;
+  typed: Pattern.constr_under_binders Id.Map.t ;
+  untyped:closed_glob_constr Id.Map.t }
+and closed_glob_constr = {
+  closure: closure;
+  term: glob_constr }
diff --git a/intf/locus.mli b/intf/locus.mli
new file mode 100644
index 00000000..80857794
--- /dev/null
+++ b/intf/locus.mli
@@ -0,0 +1,94 @@
+(************************************************************************)
+(*  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 Names
+open Misctypes
+
+(** Locus : positions in hypotheses and goals *)
+
+(** {6 Occurrences} *)
+
+type 'a occurrences_gen =
+  | AllOccurrences
+  | AllOccurrencesBut of 'a list (** non-empty *)
+  | NoOccurrences
+  | OnlyOccurrences of 'a list (** non-empty *)
+
+type occurrences_expr = (int or_var) occurrences_gen
+type 'a with_occurrences = occurrences_expr * 'a
+
+type occurrences = int occurrences_gen
+
+
+(** {6 Locations}
+
+  Selecting the occurrences in body (if any), in type, or in both *)
+
+type hyp_location_flag = InHyp | InHypTypeOnly | InHypValueOnly
+
+
+(** {6 Abstract clauses expressions}
+
+  A [clause_expr] (and its instance [clause]) denotes occurrences and
+  hypotheses in a goal in an abstract way; in particular, it can refer
+  to the set of all hypotheses independently of the effective contents
+  of the current goal
+
+  Concerning the field [onhyps]:
+   - [None] means *on every hypothesis*
+   - [Some l] means on hypothesis belonging to l *)
+
+type 'a hyp_location_expr = 'a with_occurrences * hyp_location_flag
+
+type 'id clause_expr =
+  { onhyps : 'id hyp_location_expr list option;
+    concl_occs : occurrences_expr }
+
+type clause = Id.t clause_expr
+
+
+(** {6 Concrete view of occurrence clauses} *)
+
+(** [clause_atom] refers either to an hypothesis location (i.e. an
+   hypothesis with occurrences and a position, in body if any, in type
+   or in both) or to some occurrences of the conclusion *)
+
+type clause_atom =
+  | OnHyp of Id.t * occurrences_expr * hyp_location_flag
+  | OnConcl of occurrences_expr
+
+(** A [concrete_clause] is an effective collection of occurrences
+    in the hypotheses and the conclusion *)
+
+type concrete_clause = clause_atom list
+
+
+(** {6 A weaker form of clause with no mention of occurrences} *)
+
+(** A [hyp_location] is an hypothesis together with a location *)
+
+type hyp_location = Id.t * hyp_location_flag
+
+(** A [goal_location] is either an hypothesis (together with a location)
+    or the conclusion (represented by None) *)
+
+type goal_location = hyp_location option
+
+
+(** {6 Simple clauses, without occurrences nor location} *)
+
+(** A [simple_clause] is a set of hypotheses, possibly extended with
+   the conclusion (conclusion is represented by None) *)
+
+type simple_clause = Id.t option list
+
+(** {6 A notion of occurrences allowing to express "all occurrences
+       convertible to the first which matches"} *)
+
+type 'a or_like_first = AtOccs of 'a | LikeFirst
+
diff --git a/intf/misctypes.mli b/intf/misctypes.mli
new file mode 100644
index 00000000..74e13690
--- /dev/null
+++ b/intf/misctypes.mli
@@ -0,0 +1,106 @@
+(************************************************************************)
+(*  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 Names
+
+(** Basic types used both in [constr_expr] and in [glob_constr] *)
+
+(** Cases pattern variables *)
+
+type patvar = Id.t
+
+(** Introduction patterns *)
+
+type 'constr intro_pattern_expr =
+  | IntroForthcoming of bool
+  | IntroNaming of intro_pattern_naming_expr
+  | IntroAction of 'constr intro_pattern_action_expr
+and intro_pattern_naming_expr =
+  | IntroIdentifier of Id.t
+  | IntroFresh of Id.t
+  | IntroAnonymous
+and 'constr intro_pattern_action_expr =
+  | IntroWildcard
+  | IntroOrAndPattern of 'constr or_and_intro_pattern_expr
+  | IntroInjection of (Loc.t * 'constr intro_pattern_expr) list
+  | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr)
+  | IntroRewrite of bool
+and 'constr or_and_intro_pattern_expr =
+  (Loc.t * 'constr intro_pattern_expr) list list
+
+(** Move destination for hypothesis *)
+
+type 'id move_location =
+  | MoveAfter of 'id
+  | MoveBefore of 'id
+  | MoveFirst
+  | MoveLast (** can be seen as "no move" when doing intro *)
+
+(** Sorts *)
+
+type 'a glob_sort_gen = GProp | GSet | GType of 'a
+type sort_info = string list
+type level_info = string option
+
+type glob_sort = sort_info glob_sort_gen
+type glob_level = level_info glob_sort_gen
+
+(** A synonym of [Evar.t], also defined in Term *)
+
+type existential_key = Evar.t
+
+(** Case style, shared with Term *)
+
+type case_style = Term.case_style =
+  | LetStyle
+  | IfStyle
+  | LetPatternStyle
+  | MatchStyle
+  | RegularStyle (** infer printing form from number of constructor *)
+
+(** Casts *)
+
+type 'a cast_type =
+  | CastConv of 'a
+  | CastVM of 'a
+  | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *)
+  | CastNative of 'a
+
+(** Bindings *)
+
+type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t
+
+type 'a explicit_bindings = (Loc.t * quantified_hypothesis * 'a) list
+
+type 'a bindings =
+  | ImplicitBindings of 'a list
+  | ExplicitBindings of 'a explicit_bindings
+  | NoBindings
+
+type 'a with_bindings = 'a * 'a bindings
+
+
+(** Some utility types for parsing *)
+
+type 'a or_var =
+  | ArgArg of 'a
+  | ArgVar of Names.Id.t Loc.located
+
+type 'a and_short_name = 'a * Id.t Loc.located option
+
+type 'a or_by_notation =
+  | AN of 'a
+  | ByNotation of (Loc.t * string * string option)
+
+(* NB: the last string in [ByNotation] is actually a [Notation.delimiters],
+   but this formulation avoids a useless dependency. *)
+
+
+(** Kinds of modules *)
+
+type module_kind = Module | ModType | ModAny
diff --git a/intf/notation_term.mli b/intf/notation_term.mli
new file mode 100644
index 00000000..5a563bf9
--- /dev/null
+++ b/intf/notation_term.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  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 Names
+open Globnames
+open Misctypes
+open Glob_term
+
+(** [notation_constr] *)
+
+(** [notation_constr] is the subtype of [glob_constr] allowed in syntactic
+    extensions (i.e. notations).
+    No location since intended to be substituted at any place of a text.
+    Complex expressions such as fixpoints and cofixpoints are excluded,
+    as well as non global expressions such as existential variables. *)
+
+type notation_constr =
+  (** Part common to [glob_constr] and [cases_pattern] *)
+  | NRef of global_reference
+  | NVar of Id.t
+  | NApp of notation_constr * notation_constr list
+  | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option
+  | NList of Id.t * Id.t * notation_constr * notation_constr * bool
+  (** Part only in [glob_constr] *)
+  | NLambda of Name.t * notation_constr * notation_constr
+  | NProd of Name.t * notation_constr * notation_constr
+  | NBinderList of Id.t * Id.t * notation_constr * notation_constr
+  | NLetIn of Name.t * notation_constr * notation_constr
+  | NCases of case_style * notation_constr option *
+      (notation_constr * (Name.t * (inductive * Name.t list) option)) list *
+      (cases_pattern list * notation_constr) list
+  | NLetTuple of Name.t list * (Name.t * notation_constr option) *
+      notation_constr * notation_constr
+  | NIf of notation_constr * (Name.t * notation_constr option) *
+      notation_constr * notation_constr
+  | NRec of fix_kind * Id.t array *
+      (Name.t * notation_constr option * notation_constr) list array *
+      notation_constr array * notation_constr array
+  | NSort of glob_sort
+  | NPatVar of patvar
+  | NCast of notation_constr * notation_constr cast_type
+
+(** Note concerning NList: first constr is iterator, second is terminator;
+    first id is where each argument of the list has to be substituted
+    in iterator and snd id is alternative name just for printing;
+    boolean is associativity *)
+
+(** Types concerning notations *)
+
+type scope_name = string
+
+type tmp_scope_name = scope_name
+
+type subscopes = tmp_scope_name option * scope_name list
+
+(** Type of the meta-variables of an notation_constr: in a recursive pattern x..y,
+    x carries the sequence of objects bound to the list x..y  *)
+type notation_var_instance_type =
+  | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList
+
+(** Type of variables when interpreting a constr_expr as an notation_constr:
+    in a recursive pattern x..y, both x and y carry the individual type
+    of each element of the list x..y *)
+type notation_var_internalization_type =
+  | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent
+
+(** This characterizes to what a notation is interpreted to *)
+type interpretation =
+    (Id.t * (subscopes * notation_var_instance_type)) list *
+    notation_constr
+
+type notation_interp_env = {
+  ninterp_var_type : notation_var_internalization_type Id.Map.t;
+  ninterp_rec_vars : Id.t Id.Map.t;
+  mutable ninterp_only_parse : bool;
+}
diff --git a/pretyping/pattern.mli b/intf/pattern.mli
index 7fb53133..18cd2df0 100644
--- a/pretyping/pattern.mli
+++ b/intf/pattern.mli
@@ -1,23 +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        *)
 (************************************************************************)
 
-(** This module defines the type of pattern used for pattern-matching
-    terms in tatics *)
-
-open Pp
 open Names
-open Sign
+open Globnames
 open Term
-open Environ
-open Libnames
-open Nametab
-open Glob_term
-open Mod_subst
+open Misctypes
 
 (** {5 Maps of pattern variables} *)
 
@@ -51,76 +43,39 @@ open Mod_subst
     could be inferred. We also loose the ability of typing ltac
     variables before calling the right-hand-side of ltac matching clauses. *)
 
-type constr_under_binders = identifier list * constr
+type constr_under_binders = Id.t list * constr
 
 (** Types of substitutions with or w/o bound variables *)
 
-type patvar_map = (patvar * constr) list
-type extended_patvar_map = (patvar * constr_under_binders) list
+type patvar_map = constr Id.Map.t
+type extended_patvar_map = constr_under_binders Id.Map.t
 
 (** {5 Patterns} *)
 
 type case_info_pattern =
     { cip_style : case_style;
       cip_ind : inductive option;
-      cip_ind_args : (int * int) option; (** number of params and args *)
+      cip_ind_tags : bool list option; (** indicates LetIn/Lambda in arity *)
       cip_extensible : bool (** does this match end with _ => _ ? *) }
 
 type constr_pattern =
   | PRef of global_reference
-  | PVar of identifier
+  | PVar of Id.t
   | PEvar of existential_key * constr_pattern array
   | PRel of int
   | PApp of constr_pattern * constr_pattern array
   | PSoApp of patvar * constr_pattern list
-  | PLambda of name * constr_pattern * constr_pattern
-  | PProd of name * constr_pattern * constr_pattern
-  | PLetIn of name * constr_pattern * constr_pattern
+  | PProj of projection * constr_pattern
+  | PLambda of Name.t * constr_pattern * constr_pattern
+  | PProd of Name.t * constr_pattern * constr_pattern
+  | PLetIn of Name.t * constr_pattern * constr_pattern
   | PSort of glob_sort
   | PMeta of patvar option
   | PIf of constr_pattern * constr_pattern * constr_pattern
   | PCase of case_info_pattern * constr_pattern * constr_pattern *
-      (int * int * constr_pattern) list (** index of constructor, nb of args *)
+      (int * bool list * constr_pattern) list (** index of constructor, nb of args *)
   | PFix of fixpoint
   | PCoFix of cofixpoint
 
 (** Nota : in a [PCase], the array of branches might be shorter than
     expected, denoting the use of a final "_ => _" branch *)
-
-(** {5 Functions on patterns} *)
-
-val occur_meta_pattern : constr_pattern -> bool
-
-val subst_pattern : substitution -> constr_pattern -> constr_pattern
-
-exception BoundPattern
-
-(** [head_pattern_bound t] extracts the head variable/constant of the
-   type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
-   if [t] is an abstraction *)
-
-val head_pattern_bound : constr_pattern -> global_reference
-
-(** [head_of_constr_reference c] assumes [r] denotes a reference and
-   returns its label; raises an anomaly otherwise *)
-
-val head_of_constr_reference : Term.constr -> global_reference
-
-(** [pattern_of_constr c] translates a term [c] with metavariables into
-   a pattern; currently, no destructor (Cases, Fix, Cofix) and no
-   existential variable are allowed in [c] *)
-
-val pattern_of_constr : Evd.evar_map -> constr -> named_context * constr_pattern
-
-(** [pattern_of_glob_constr l c] translates a term [c] with metavariables into
-   a pattern; variables bound in [l] are replaced by the pattern to which they
-    are bound *)
-
-val pattern_of_glob_constr : glob_constr ->
-      patvar list * constr_pattern
-
-val instantiate_pattern :
-  Evd.evar_map -> (identifier * (identifier list * constr)) list ->
-  constr_pattern -> constr_pattern
-
-val lift_pattern : int -> constr_pattern -> constr_pattern
diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli
new file mode 100644
index 00000000..7b9ad313
--- /dev/null
+++ b/intf/tacexpr.mli
@@ -0,0 +1,415 @@
+(************************************************************************)
+(*  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 Loc
+open Names
+open Constrexpr
+open Libnames
+open Globnames
+open Nametab
+open Genredexpr
+open Genarg
+open Pattern
+open Decl_kinds
+open Misctypes
+open Locus
+
+type direction_flag = bool (* true = Left-to-right    false = right-to-right *)
+type lazy_flag =
+  | General (* returns all possible successes *)
+  | Select  (* returns all successes of the first matching branch *)
+  | Once    (* returns the first success in a maching branch
+               (not necessarily the first) *)
+type global_flag = (* [gfail] or [fail] *)
+  | TacGlobal
+  | TacLocal
+type evars_flag = bool     (* true = pose evars       false = fail on evars *)
+type rec_flag = bool       (* true = recursive        false = not recursive *)
+type advanced_flag = bool  (* true = advanced         false = basic *)
+type letin_flag = bool     (* true = use local def    false = use Leibniz *)
+type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *)
+
+type debug = Debug | Info | Off (* for trivial / auto / eauto ... *)
+
+type 'a core_induction_arg =
+  | ElimOnConstr of 'a
+  | ElimOnIdent of Id.t located
+  | ElimOnAnonHyp of int
+
+type 'a induction_arg =
+  clear_flag * 'a core_induction_arg
+
+type inversion_kind =
+  | SimpleInversion
+  | FullInversion
+  | FullInversionClear
+
+type ('c,'d,'id) inversion_strength =
+  | NonDepInversion of
+      inversion_kind * 'id list * 'd or_and_intro_pattern_expr located or_var option
+  | DepInversion of
+      inversion_kind * 'c option * 'd or_and_intro_pattern_expr located or_var option
+  | InversionUsing of 'c * 'id list
+
+type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
+
+type 'id message_token =
+  | MsgString of string
+  | MsgInt of int
+  | MsgIdent of 'id
+
+type ('dconstr,'id) induction_clause =
+    'dconstr with_bindings induction_arg *
+    (intro_pattern_naming_expr located option (* eqn:... *)
+    * 'dconstr or_and_intro_pattern_expr located or_var option) (* as ... *)
+    * 'id clause_expr option (* in ... *)
+
+type ('constr,'dconstr,'id) induction_clause_list =
+    ('dconstr,'id) induction_clause list
+    * 'constr with_bindings option (* using ... *)
+
+type 'a with_bindings_arg = clear_flag * 'a with_bindings
+
+type multi =
+  | Precisely of int
+  | UpTo of int
+  | RepeatStar
+  | RepeatPlus
+
+(* Type of patterns *)
+type 'a match_pattern =
+  | Term of 'a
+  | Subterm of bool * Id.t option * 'a
+
+(* Type of hypotheses for a Match Context rule *)
+type 'a match_context_hyps =
+  | Hyp of Name.t located * 'a match_pattern
+  | Def of Name.t located * 'a match_pattern * 'a match_pattern
+
+(* Type of a Match rule for Match Context and Match *)
+type ('a,'t) match_rule =
+  | Pat of 'a match_context_hyps list * 'a match_pattern * 't
+  | All of 't
+
+type ml_tactic_name = {
+  mltac_plugin : string;
+  mltac_tactic : string;
+}
+
+(** Composite types *)
+
+(** In globalize tactics, we need to keep the initial [constr_expr] to recompute
+   in the environment by the effective calls to Intro, Inversion, etc 
+   The [constr_expr] field is [None] in TacDef though *)
+type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option
+
+type open_constr_expr = unit * constr_expr
+type open_glob_constr = unit * glob_constr_and_expr
+
+type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern
+
+type delayed_open_constr_with_bindings =
+    Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr with_bindings
+
+type delayed_open_constr =
+    Environ.env -> Evd.evar_map -> Evd.evar_map * Term.constr
+
+type intro_pattern = delayed_open_constr intro_pattern_expr located
+type intro_patterns = delayed_open_constr intro_pattern_expr located list
+type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located
+type intro_pattern_naming = intro_pattern_naming_expr located
+
+(** Generic expressions for atomic tactics *)
+
+type 'a gen_atomic_tactic_expr =
+  (* Basic tactics *)
+  | TacIntroPattern of 'dtrm intro_pattern_expr located list
+  | TacIntroMove of Id.t option * 'nam move_location
+  | TacExact of 'trm
+  | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list *
+      (clear_flag * 'nam * 'dtrm intro_pattern_expr located option) option
+  | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option
+  | TacCase of evars_flag * 'trm with_bindings_arg
+  | TacFix of Id.t option * int
+  | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list
+  | TacCofix of Id.t option
+  | TacMutualCofix of Id.t * (Id.t * 'trm) list
+  | TacAssert of
+      bool * 'tacexpr option *
+      'dtrm intro_pattern_expr located option * 'trm
+  | TacGeneralize of ('trm with_occurrences * Name.t) list
+  | TacGeneralizeDep of 'trm
+  | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag *
+      intro_pattern_naming_expr located option
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct of
+      rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list
+  | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis
+
+  (* Automation tactics *)
+  | TacTrivial of debug * 'trm list * string list option
+  | TacAuto of debug * int or_var option * 'trm list * string list option
+
+  (* Context management *)
+  | TacClear of bool * 'nam list
+  | TacClearBody of 'nam list
+  | TacMove of 'nam * 'nam move_location
+  | TacRename of ('nam *'nam) list
+
+  (* Trmuctors *)
+  | TacSplit of evars_flag * 'trm bindings list
+
+  (* Conversion *)
+  | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr
+  | TacChange of 'pat option * 'dtrm * 'nam clause_expr
+
+  (* Equivalence relations *)
+  | TacSymmetry of 'nam clause_expr
+
+  (* Equality and inversion *)
+  | TacRewrite of evars_flag *
+      (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr *
+      (* spiwack: using ['dtrm] here is a small hack, may not be
+         stable by a change in the representation of delayed
+         terms. Because, in fact, it is the whole "with_bindings"
+         which is delayed. But because the "t" level for ['dtrm] is
+         uninterpreted, it works fine here too, and avoid more
+         disruption of this file. *)
+      'tacexpr option
+  | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis
+
+constraint 'a = <
+    term:'trm;
+    utrm: 'utrm;
+    dterm: 'dtrm;
+    pattern:'pat;
+    constant:'cst;
+    reference:'ref;
+    name:'nam;
+    tacexpr:'tacexpr;
+    level:'lev
+>
+
+(** Possible arguments of a tactic definition *)
+
+and 'a gen_tactic_arg =
+  | TacDynamic     of Loc.t * Dyn.t
+  | TacGeneric     of 'lev generic_argument
+  | MetaIdArg      of Loc.t * bool * string
+  | ConstrMayEval  of ('trm,'cst,'pat) may_eval
+  | UConstr        of 'utrm
+  | Reference      of 'ref
+  | TacCall of Loc.t * 'ref *
+      'a gen_tactic_arg list
+  | TacFreshId of string or_var list
+  | Tacexp of 'tacexpr
+  | TacPretype of 'trm
+  | TacNumgoals
+
+constraint 'a = <
+    term:'trm;
+    utrm: 'utrm;
+    dterm: 'dtrm;
+    pattern:'pat;
+    constant:'cst;
+    reference:'ref;
+    name:'nam;
+    tacexpr:'tacexpr;
+    level:'lev
+>
+
+(** Generic ltac expressions.
+    't : terms, 'p : patterns, 'c : constants, 'i : inductive,
+    'r : ltac refs, 'n : idents, 'l : levels *)
+
+and 'a gen_tactic_expr =
+  | TacAtom of Loc.t * 'a gen_atomic_tactic_expr
+  | TacThen of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacDispatch of
+      'a gen_tactic_expr list
+  | TacExtendTac of
+      'a gen_tactic_expr array *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array
+  | TacThens of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr list
+  | TacThens3parts of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr array
+  | TacFirst of 'a gen_tactic_expr list
+  | TacComplete of 'a gen_tactic_expr
+  | TacSolve of 'a gen_tactic_expr list
+  | TacTry of 'a gen_tactic_expr
+  | TacOr of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacOnce of
+      'a gen_tactic_expr
+  | TacExactlyOnce of
+      'a gen_tactic_expr
+  | TacIfThenCatch of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacOrelse of
+      'a gen_tactic_expr *
+      'a gen_tactic_expr
+  | TacDo of int or_var * 'a gen_tactic_expr
+  | TacTimeout of int or_var * 'a gen_tactic_expr
+  | TacTime of string option * 'a gen_tactic_expr
+  | TacRepeat of 'a gen_tactic_expr
+  | TacProgress of 'a gen_tactic_expr
+  | TacShowHyps of 'a gen_tactic_expr
+  | TacAbstract of
+      'a gen_tactic_expr * Id.t option
+  | TacId of 'n message_token list
+  | TacFail of global_flag * int or_var * 'n message_token list
+  | TacInfo of 'a gen_tactic_expr
+  | TacLetIn of rec_flag *
+      (Id.t located * 'a gen_tactic_arg) list *
+      'a gen_tactic_expr
+  | TacMatch of lazy_flag *
+      'a gen_tactic_expr *
+      ('p,'a gen_tactic_expr) match_rule list
+  | TacMatchGoal of lazy_flag * direction_flag *
+      ('p,'a gen_tactic_expr) match_rule list
+  | TacFun of 'a gen_tactic_fun_ast
+  | TacArg of 'a gen_tactic_arg located
+  (* For ML extensions *)
+  | TacML of Loc.t * ml_tactic_name * 'l generic_argument list
+  (* For syntax extensions *)
+  | TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list
+
+constraint 'a = <
+    term:'t;
+    utrm: 'utrm;
+    dterm: 'dtrm;
+    pattern:'p;
+    constant:'c;
+    reference:'r;
+    name:'n;
+    tacexpr:'tacexpr;
+    level:'l
+>
+
+and 'a gen_tactic_fun_ast =
+    Id.t option list * 'a gen_tactic_expr
+
+constraint 'a = <
+    term:'t;
+    utrm: 'utrm;
+    dterm: 'dtrm;
+    pattern:'p;
+    constant:'c;
+    reference:'r;
+    name:'n;
+    tacexpr:'te;
+    level:'l
+>
+
+(** Globalized tactics *)
+
+type g_trm = glob_constr_and_expr
+type g_utrm = g_trm
+type g_pat = glob_constr_and_expr * constr_pattern
+type g_cst = evaluable_global_reference and_short_name or_var
+type g_ref = ltac_constant located or_var
+type g_nam  = Id.t located
+
+type g_dispatch =  <
+    term:g_trm;
+    utrm:g_utrm;
+    dterm:g_trm;
+    pattern:g_pat;
+    constant:g_cst;
+    reference:g_ref;
+    name:g_nam;
+    tacexpr:glob_tactic_expr;
+    level:glevel
+>
+
+and glob_tactic_expr =
+    g_dispatch gen_tactic_expr
+
+type glob_atomic_tactic_expr =
+    g_dispatch gen_atomic_tactic_expr
+
+type glob_tactic_arg =
+    g_dispatch gen_tactic_arg
+
+(** Raw tactics *)
+
+type r_trm = constr_expr
+type r_utrm = r_trm
+type r_pat = constr_pattern_expr
+type r_cst = reference or_by_notation
+type r_ref = reference
+type r_nam  = Id.t located
+type r_lev = rlevel
+
+type r_dispatch =  <
+    term:r_trm;
+    utrm:r_utrm;
+    dterm:r_trm;
+    pattern:r_pat;
+    constant:r_cst;
+    reference:r_ref;
+    name:r_nam;
+    tacexpr:raw_tactic_expr;
+    level:rlevel
+>
+
+and raw_tactic_expr =
+    r_dispatch gen_tactic_expr
+
+type raw_atomic_tactic_expr =
+    r_dispatch gen_atomic_tactic_expr
+
+type raw_tactic_arg =
+    r_dispatch gen_tactic_arg
+
+(** Interpreted tactics *)
+
+type t_trm = Term.constr
+type t_utrm = Glob_term.closed_glob_constr
+type t_pat = glob_constr_and_expr * constr_pattern
+type t_cst = evaluable_global_reference and_short_name
+type t_ref = ltac_constant located
+type t_nam  = Id.t
+
+type t_dispatch =  <
+    term:t_trm;
+    utrm:t_utrm;
+    dterm:g_trm;
+    pattern:t_pat;
+    constant:t_cst;
+    reference:t_ref;
+    name:t_nam;
+    tacexpr:glob_tactic_expr;
+    level:tlevel
+>
+
+type tactic_expr =
+    t_dispatch gen_tactic_expr
+
+type atomic_tactic_expr =
+    t_dispatch gen_atomic_tactic_expr
+
+type tactic_arg =
+    t_dispatch gen_tactic_arg
+
+(** Misc *)
+
+type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen
+type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen
diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli
new file mode 100644
index 00000000..3f2d002c
--- /dev/null
+++ b/intf/vernacexpr.mli
@@ -0,0 +1,482 @@
+(************************************************************************)
+(*  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 Loc
+open Names
+open Tacexpr
+open Misctypes
+open Constrexpr
+open Decl_kinds
+open Libnames
+
+(** Vernac expressions, produced by the parser *)
+
+type lident = Id.t located
+type lname = Name.t located
+type lstring = string located
+type lreference = reference
+
+type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation
+
+(* spiwack: I'm choosing, for now, to have [goal_selector] be a
+   different type than [goal_reference] mostly because if it makes sense
+   to print a goal that is out of focus (or already solved) it doesn't
+   make sense to apply a tactic to it. Hence it the types may look very
+   similar, they do not seem to mean the same thing. *)
+type goal_selector =
+  | SelectNth of int
+  | SelectId of Id.t
+  | SelectAll
+  | SelectAllParallel
+
+type goal_identifier = string
+type scope_name = string
+
+type goal_reference =
+  | OpenSubgoals
+  | NthGoal of int
+  | GoalId of goal_identifier
+
+type printable =
+  | PrintTables
+  | PrintFullContext
+  | PrintSectionContext of reference
+  | PrintInspect of int
+  | PrintGrammar of string
+  | PrintLoadPath of DirPath.t option
+  | PrintModules
+  | PrintModule of reference
+  | PrintModuleType of reference
+  | PrintNamespace of DirPath.t
+  | PrintMLLoadPath
+  | PrintMLModules
+  | PrintDebugGC
+  | PrintName of reference or_by_notation
+  | PrintGraph
+  | PrintClasses
+  | PrintTypeClasses
+  | PrintInstances of reference or_by_notation
+  | PrintLtac of reference
+  | PrintCoercions
+  | PrintCoercionPaths of class_rawexpr * class_rawexpr
+  | PrintCanonicalConversions
+  | PrintUniverses of bool * string option
+  | PrintHint of reference or_by_notation
+  | PrintHintGoal
+  | PrintHintDbName of string
+  | PrintRewriteHintDbName of string
+  | PrintHintDb
+  | PrintScopes
+  | PrintScope of string
+  | PrintVisibility of string option
+  | PrintAbout of reference or_by_notation*int option
+  | PrintImplicit of reference or_by_notation
+  | PrintAssumptions of bool * bool * reference or_by_notation
+  | PrintStrategy of reference or_by_notation option
+
+type search_about_item =
+  | SearchSubPattern of constr_pattern_expr
+  | SearchString of string * scope_name option
+
+type searchable =
+  | SearchPattern of constr_pattern_expr
+  | SearchRewrite of constr_pattern_expr
+  | SearchHead of constr_pattern_expr
+  | SearchAbout of (bool * search_about_item) list
+
+type locatable =
+  | LocateAny of reference or_by_notation
+  | LocateTerm of reference or_by_notation
+  | LocateLibrary of reference
+  | LocateModule of reference
+  | LocateTactic of reference
+  | LocateFile of string
+
+type showable =
+  | ShowGoal of goal_reference
+  | ShowGoalImplicitly of int option
+  | ShowProof
+  | ShowNode
+  | ShowScript
+  | ShowExistentials
+  | ShowUniverses
+  | ShowTree
+  | ShowProofNames
+  | ShowIntros of bool
+  | ShowMatch of lident
+  | ShowThesis
+
+type comment =
+  | CommentConstr of constr_expr
+  | CommentString of string
+  | CommentInt of int
+
+type reference_or_constr = 
+  | HintsReference of reference
+  | HintsConstr of constr_expr
+
+type hints_expr =
+  | HintsResolve of (int option * bool * reference_or_constr) list
+  | HintsImmediate of reference_or_constr list
+  | HintsUnfold of reference list
+  | HintsTransparency of reference list * bool
+  | HintsMode of reference * bool list
+  | HintsConstructors of reference list
+  | HintsExtern of int * constr_expr option * raw_tactic_expr
+
+type search_restriction =
+  | SearchInside of reference list
+  | SearchOutside of reference list
+
+type rec_flag       = bool (* true = Rec;           false = NoRec          *)
+type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
+type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
+type coercion_flag  = bool (* true = AddCoercion    false = NoCoercion     *)
+type instance_flag  = bool option
+  (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *)
+type export_flag    = bool (* true = Export;        false = Import         *)
+type inductive_flag = Decl_kinds.recursivity_kind
+type onlyparsing_flag = Flags.compat_version option
+ (* Some v = Parse only;  None = Print also.
+    If v<>Current, it contains the name of the coq version
+    which this notation is trying to be compatible with *)
+type locality_flag  = bool (* true = Local *)
+type obsolete_locality = bool
+(* Some grammar entries use obsolete_locality.  This bool is to be backward
+ * compatible.  If the grammar is fixed removing deprecated syntax, this
+ * bool should go away too *)
+
+type option_value = Goptions.option_value =
+  | BoolValue of bool
+  | IntValue of int option
+  | StringValue of string
+
+type option_ref_value =
+  | StringRefValue of string
+  | QualidRefValue of reference
+
+type sort_expr = glob_sort
+
+type definition_expr =
+  | ProveBody of local_binder list * constr_expr
+  | DefineBody of local_binder list * raw_red_expr option * constr_expr
+      * constr_expr option
+
+type fixpoint_expr =
+    Id.t located * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option
+
+type cofixpoint_expr =
+    Id.t located * local_binder list * constr_expr * constr_expr option
+
+type local_decl_expr =
+  | AssumExpr of lname * constr_expr
+  | DefExpr of lname * constr_expr * constr_expr option
+
+type inductive_kind = Inductive_kw | CoInductive | Variant | Record | Structure | Class of bool (* true = definitional, false = inductive *)
+type decl_notation = lstring * constr_expr * scope_name option
+type simple_binder = lident list  * constr_expr
+type class_binder = lident * constr_expr list
+type 'a with_coercion = coercion_flag * 'a
+type 'a with_instance = instance_flag * 'a
+type 'a with_notation = 'a * decl_notation list
+type 'a with_priority = 'a * int option
+type constructor_expr = (lident * constr_expr) with_coercion
+type constructor_list_or_record_decl_expr =
+  | Constructors of constructor_expr list
+  | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list
+type inductive_expr =
+  lident with_coercion * local_binder list * constr_expr option * inductive_kind *
+    constructor_list_or_record_decl_expr
+
+type one_inductive_expr =
+  lident * local_binder list * constr_expr option * constructor_expr list
+
+type grammar_tactic_prod_item_expr =
+  | TacTerm of string
+  | TacNonTerm of Loc.t * string * (Names.Id.t * string) option
+
+type syntax_modifier =
+  | SetItemLevel of string list * Extend.production_level
+  | SetLevel of int
+  | SetAssoc of Extend.gram_assoc
+  | SetEntryType of string * Extend.simple_constr_prod_entry_key
+  | SetOnlyParsing of Flags.compat_version
+  | SetFormat of string * string located
+
+type proof_end =
+  | Admitted
+  | Proved of opacity_flag * (lident * theorem_kind option) option
+
+type scheme =
+  | InductionScheme of bool * reference or_by_notation * sort_expr
+  | CaseScheme of bool * reference or_by_notation * sort_expr
+  | EqualityScheme of reference or_by_notation
+
+type section_subset_expr =
+  | SsSet of lident list
+  | SsCompl of section_subset_expr
+  | SsUnion of section_subset_expr * section_subset_expr
+  | SsSubstr of section_subset_expr * section_subset_expr
+
+type section_subset_descr = SsAll | SsType | SsExpr of section_subset_expr
+
+type extend_name = string * int
+
+(* This type allows registering the inlining of constants in native compiler.
+   It will be extended with primitive inductive types and operators *)
+type register_kind = 
+  | RegisterInline
+
+type bullet =
+    | Dash of int
+    | Star of int
+    | Plus of int
+
+(** {6 Types concerning Stm} *)
+type 'a stm_vernac =
+  | JoinDocument
+  | Finish
+  | Wait
+  | PrintDag
+  | Observe of Stateid.t
+  | Command of 'a (* An out of flow command not to be recorded by Stm *)
+  | PGLast of 'a (* To ease the life of PG *)
+
+(** {6 Types concerning the module layer} *)
+
+(** Rigid / flexible module signature *)
+
+type 'a module_signature =
+  | Enforce of 'a (** ... : T *)
+  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
+
+(** Which module inline annotations should we honor,
+    either None or the ones whose level is less or equal
+    to the given integer *)
+
+type inline =
+  | NoInline
+  | DefaultInline
+  | InlineAt of int
+
+type module_ast_inl = module_ast * inline
+type module_binder = bool option * lident list * module_ast_inl
+
+(** {6 The type of vernacular expressions} *)
+
+type vernac_expr =
+  (* Control *)
+  | VernacLoad of verbose_flag * string
+  | VernacTime of vernac_list
+  | VernacTimeout of int * vernac_expr
+  | VernacFail of vernac_expr
+  | VernacError of exn (* always fails *)
+
+  (* Syntax *)
+  | VernacTacticNotation of
+      int * grammar_tactic_prod_item_expr list * raw_tactic_expr
+  | VernacSyntaxExtension of
+      obsolete_locality * (lstring * syntax_modifier list)
+  | VernacOpenCloseScope of obsolete_locality * (bool * scope_name)
+  | VernacDelimiters of scope_name * string
+  | VernacBindScope of scope_name * reference or_by_notation list
+  | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) *
+      constr_expr * scope_name option
+  | VernacNotation of
+      obsolete_locality * constr_expr * (lstring * syntax_modifier list) *
+      scope_name option
+  | VernacNotationAddFormat of string * string * string
+
+  (* Gallina *)
+  | VernacDefinition of
+      (locality option * definition_object_kind) * lident * definition_expr
+  | VernacStartTheoremProof of theorem_kind * 
+      (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list *
+        bool
+  | VernacEndProof of proof_end
+  | VernacExactProof of constr_expr
+  | VernacAssumption of (locality option * assumption_object_kind) *
+      inline * simple_binder with_coercion list
+  | VernacInductive of private_flag * inductive_flag * (inductive_expr * decl_notation list) list
+  | VernacFixpoint of
+      locality option * (fixpoint_expr * decl_notation list) list
+  | VernacCoFixpoint of
+      locality option * (cofixpoint_expr * decl_notation list) list
+  | VernacScheme of (lident option * scheme) list
+  | VernacCombinedScheme of lident * lident list
+  | VernacUniverse of lident list
+  | VernacConstraint of (lident * Univ.constraint_type * lident) list
+
+  (* Gallina extensions *)
+  | VernacBeginSection of lident
+  | VernacEndSegment of lident
+  | VernacRequire of
+      export_flag option * lreference list
+  | VernacImport of export_flag * lreference list
+  | VernacCanonical of reference or_by_notation
+  | VernacCoercion of obsolete_locality * reference or_by_notation *
+      class_rawexpr * class_rawexpr
+  | VernacIdentityCoercion of obsolete_locality * lident *
+      class_rawexpr * class_rawexpr
+  | VernacNameSectionHypSet of lident * section_subset_descr 
+
+  (* Type classes *)
+  | VernacInstance of
+      bool * (* abstract instance *)
+      local_binder list * (* super *)
+	typeclass_constraint * (* instance name, class name, params *)
+	(bool * constr_expr) option * (* props *)
+	int option (* Priority *)
+
+  | VernacContext of local_binder list
+
+  | VernacDeclareInstances of
+    reference list * int option (* instance names, priority *)
+
+  | VernacDeclareClass of reference (* inductive or definition name *)
+
+  (* Modules and Module Types *)
+  | VernacDeclareModule of bool option * lident *
+      module_binder list * module_ast_inl
+  | VernacDefineModule of bool option * lident * module_binder list *
+      module_ast_inl module_signature * module_ast_inl list
+  | VernacDeclareModuleType of lident *
+      module_binder list * module_ast_inl list * module_ast_inl list
+  | VernacInclude of module_ast_inl list
+
+  (* Solving *)
+
+  | VernacSolve of goal_selector * int option * raw_tactic_expr * bool
+  | VernacSolveExistential of int * constr_expr
+
+  (* Auxiliary file and library management *)
+  | VernacAddLoadPath of rec_flag * string * DirPath.t option
+  | VernacRemoveLoadPath of string
+  | VernacAddMLPath of rec_flag * string
+  | VernacDeclareMLModule of string list
+  | VernacChdir of string option
+
+  (* State management *)
+  | VernacWriteState of string
+  | VernacRestoreState of string
+
+  (* Resetting *)
+  | VernacResetName of lident
+  | VernacResetInitial
+  | VernacBack of int
+  | VernacBackTo of int
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition of
+      (rec_flag * (reference * bool * raw_tactic_expr) list)
+  | VernacCreateHintDb of string * bool
+  | VernacRemoveHints of string list * reference list
+  | VernacHints of obsolete_locality * string list * hints_expr
+  | VernacSyntacticDefinition of Id.t located * (Id.t list * constr_expr) *
+      obsolete_locality * onlyparsing_flag
+  | VernacDeclareImplicits of reference or_by_notation *
+      (explicitation * bool * bool) list list
+  | VernacArguments of reference or_by_notation *
+      ((Name.t * bool * (Loc.t * string) option * bool * bool) list) list *
+      int * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename |
+              `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes |
+              `DefaultImplicits ] list
+  | VernacArgumentsScope of reference or_by_notation *
+      scope_name option list
+  | VernacReserve of simple_binder list
+  | VernacGeneralizable of (lident list) option
+  | VernacSetOpacity of (Conv_oracle.level * reference or_by_notation list)
+  | VernacSetStrategy of
+      (Conv_oracle.level * reference or_by_notation list) list
+  | VernacUnsetOption of Goptions.option_name
+  | VernacSetOption of Goptions.option_name * option_value
+  | VernacAddOption of Goptions.option_name * option_ref_value list
+  | VernacRemoveOption of Goptions.option_name * option_ref_value list
+  | VernacMemOption of Goptions.option_name * option_ref_value list
+  | VernacPrintOption of Goptions.option_name
+  | VernacCheckMayEval of raw_red_expr option * int option * constr_expr
+  | VernacGlobalCheck of constr_expr
+  | VernacDeclareReduction of string * raw_red_expr
+  | VernacPrint of printable
+  | VernacSearch of searchable * int option * search_restriction
+  | VernacLocate of locatable
+  | VernacRegister of lident * register_kind
+  | VernacComments of comment list
+  | VernacNop
+
+  (* Stm backdoor *)
+  | VernacStm of vernac_expr stm_vernac
+
+  (* Proof management *)
+  | VernacGoal of constr_expr
+  | VernacAbort of lident option
+  | VernacAbortAll
+  | VernacRestart
+  | VernacUndo of int
+  | VernacUndoTo of int
+  | VernacBacktrack of int*int*int
+  | VernacFocus of int option
+  | VernacUnfocus
+  | VernacUnfocused
+  | VernacBullet of bullet
+  | VernacSubproof of int option
+  | VernacEndSubproof
+  | VernacShow of showable
+  | VernacCheckGuard
+  | VernacProof of raw_tactic_expr option * section_subset_descr option
+  | VernacProofMode of string
+  (* Toplevel control *)
+  | VernacToplevelControl of exn
+
+  (* For extension *)
+  | VernacExtend of extend_name * Genarg.raw_generic_argument list
+
+  (* Flags *)
+  | VernacProgram of vernac_expr
+  | VernacPolymorphic of bool * vernac_expr
+  | VernacLocal of bool * vernac_expr
+
+and vernac_list = located_vernac_expr list
+
+and located_vernac_expr = Loc.t * vernac_expr
+
+(* A vernac classifier has to tell if a command:
+   vernac_when: has to be executed now (alters the parser) or later
+   vernac_type: if it is starts, ends, continues a proof or
+     alters the global state or is a control command like BackTo or is
+     a query like Check *)
+type vernac_type =
+  | VtStartProof of vernac_start
+  | VtSideff of vernac_sideff_type
+  | VtQed of vernac_qed_type
+  | VtProofStep of bool (* parallelize *)
+  | VtProofMode of string
+  | VtQuery of vernac_part_of_script * report_with
+  | VtStm of vernac_control * vernac_part_of_script
+  | VtUnknown
+and report_with = Stateid.t * Feedback.route_id (* feedback on id/route *)
+and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *)
+and vernac_start = string * opacity_guarantee * Id.t list
+and vernac_sideff_type = Id.t list
+and vernac_is_alias = bool
+and vernac_part_of_script = bool
+and vernac_control =
+  | VtFinish
+  | VtWait
+  | VtJoinDocument
+  | VtPrintDag
+  | VtObserve of Stateid.t
+  | VtBack of Stateid.t
+  | VtPG
+and opacity_guarantee =
+  | GuaranteesOpacity (** Only generates opaque terms at [Qed] *)
+  | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*)
+type vernac_when =
+  | VtNow
+  | VtLater
+type vernac_classification = vernac_type * vernac_when
diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c
index 5d302660..3fded663 100644
--- a/kernel/byterun/coq_fix_code.c
+++ b/kernel/byterun/coq_fix_code.c
@@ -46,7 +46,8 @@ void init_arity () {
     arity[MULCINT31]=arity[MULINT31]=arity[COMPAREINT31]=
     arity[DIV21INT31]=arity[DIVINT31]=arity[ADDMULDIVINT31]=
     arity[HEAD0INT31]=arity[TAIL0INT31]=
-    arity[COMPINT31]=arity[DECOMPINT31]=0;
+    arity[COMPINT31]=arity[DECOMPINT31]=
+    arity[ORINT31]=arity[ANDINT31]=arity[XORINT31]=0;
   /* instruction with one operand */
   arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]=
     arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]=
@@ -54,7 +55,7 @@ void init_arity () {
     arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]=
     arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]=
     arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]=
-    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=arity[ACCUMULATECOND]=
+    arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]=
     arity[BRANCH]=arity[ISCONST]= 1;
   /* instruction with two operands */
   arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]=
@@ -84,15 +85,6 @@ value coq_makeaccu (value i) {
   return (value)res;
 }
 
-value coq_accucond (value i) {
-  code_t q;
-  code_t res = coq_stat_alloc(8);
-  q = res;
-  *q++ = VALINSTR(ACCUMULATECOND);
-  *q = (opcode_t)Int_val(i);
-  return (value)res;
-}
-
 value coq_pushpop (value i) {
   code_t res;
   int n;
@@ -117,7 +109,7 @@ value coq_is_accumulate_code(value code){
   code_t q;
   int res;
   q = (code_t)code;
-  res = Is_instruction(q,ACCUMULATECOND) || Is_instruction(q,ACCUMULATE);
+  res = Is_instruction(q,ACCUMULATE);
   return Val_bool(res);
 }
 
diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h
index c1a4e0ae..5c85389d 100644
--- a/kernel/byterun/coq_fix_code.h
+++ b/kernel/byterun/coq_fix_code.h
@@ -29,7 +29,6 @@ void init_arity();
 value coq_tcode_of_code(value code, value len);
 value coq_makeaccu (value i);
 value coq_pushpop (value i);
-value coq_accucond (value i);
 value coq_is_accumulate_code(value code);
 
 #endif /* _COQ_FIX_CODE_ */
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h
index e224a108..9cbf4077 100644
--- a/kernel/byterun/coq_instruct.h
+++ b/kernel/byterun/coq_instruct.h
@@ -38,7 +38,7 @@ enum instructions {
   SETFIELD0, SETFIELD1, SETFIELD,
   CONST0, CONST1, CONST2, CONST3, CONSTINT,
   PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
-  ACCUMULATE, ACCUMULATECOND, 
+  ACCUMULATE,
   MAKESWITCHBLOCK, MAKEACCU, MAKEPROD, 
 /* spiwack: */
   BRANCH,
@@ -49,6 +49,7 @@ enum instructions {
   HEAD0INT31, TAIL0INT31,
   ISCONST, ARECONST,
   COMPINT31, DECOMPINT31,
+  ORINT31, ANDINT31, XORINT31,
 /* /spiwack  */
   STOP
 };
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index aab08d89..f9e0dc7f 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -543,21 +543,21 @@ value coq_interprete
 	    coq_extra_args = Long_val(sp[2]);
 	    sp += 3;
 	  } else {
-	    /* L'argument recursif est un accumulateur */
+	    /* The recursif argument is an accumulator */
 	    mlsize_t num_args, i;
-	    /* Construction du PF partiellement appliqué */ 
+	    /* Construction of partially applied PF */
 	    Alloc_small(accu, rec_pos + 2, Closure_tag); 
 	    Field(accu, 1) = coq_env;
 	    for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i];
 	    Code_val(accu) = pc;
 	    sp += rec_pos;
 	    *--sp = accu;
-	      /* Construction de l'atom */
+	      /* Construction of the atom */
 	    Alloc_small(accu, 2, ATOM_FIX_TAG);
 	    Field(accu,1) = sp[0];
 	    Field(accu,0)  = sp[1];
 	    sp++; sp[0] = accu;
-	      /* Construction de l'accumulateur */
+	      /* Construction of the accumulator */
 	    num_args = coq_extra_args - rec_pos;
 	    Alloc_small(accu, 2+num_args, Accu_tag);
 	    Code_val(accu) = accumulate;
@@ -922,26 +922,6 @@ value coq_interprete
       }
 
       /* Special operations for reduction of open term */
-      Instruct(ACCUMULATECOND) {
-	int i, num;
-	print_instr("ACCUMULATECOND");
-	num = *pc;
-	pc++;
-	if (Field(coq_global_boxed, num) == Val_false || coq_all_transp) {
-	  /*	  printf ("false\n");
-		  printf ("tag = %d", Tag_val(Field(accu,1))); */
-	  num = Wosize_val(coq_env);
-	  for(i = 2; i < num; i++) *--sp = Field(accu,i);
-	  coq_extra_args = coq_extra_args + (num - 2);
-	  coq_env = Field(Field(accu,1),1);
-	  pc = Code_val(coq_env);
-	  accu = coq_env;
-	  /*	  printf ("end\n"); */
-	  Next;
-	};
-	/*	printf ("true\n"); */
-      }
-      
       Instruct(ACCUMULATE) {
 	mlsize_t i, size;
 	print_instr("ACCUMULATE");
@@ -1373,7 +1353,29 @@ value coq_interprete
         Next;
       }
 
+      Instruct (ORINT31) {
+	/* returns the bitwise or */
+	print_instr("ORINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) | (uint32_of_value(*sp++)));
+	Next;
+      }
 
+      Instruct (ANDINT31) {
+	/* returns the bitwise and */
+	print_instr("ANDINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) & (uint32_of_value(*sp++)));
+	Next;
+      }
+
+      Instruct (XORINT31) {
+	/* returns the bitwise xor */
+	print_instr("XORINT31");
+        accu =
+	  value_of_uint32((uint32_of_value(accu)) ^ (uint32_of_value(*sp++)));
+	Next;
+      }
 
       /*  /spiwack   */
 
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 00f5eb3b..8d03829a 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -26,7 +26,6 @@ asize_t coq_max_stack_size = Coq_max_stack_size;
 
 
 value coq_global_data;
-value coq_global_boxed;
 int coq_all_transp;
 value coq_atom_tbl;
 
@@ -62,7 +61,6 @@ static void coq_scan_roots(scanning_action action)
   register value * i;
   /* Scan the global variables */
   (*action)(coq_global_data, &coq_global_data);
-  (*action)(coq_global_boxed, &coq_global_boxed);
   (*action)(coq_atom_tbl, &coq_atom_tbl);
   /* Scan the stack */
   for (i = coq_sp; i < coq_stack_high; i++) {
@@ -90,14 +88,6 @@ void init_coq_global_data(long requested_size)
     Field (coq_global_data, i) = Val_unit;
 }
 
-void init_coq_global_boxed(long requested_size)
-{
-  int i;
-  coq_global_boxed = alloc_shr(requested_size, 0);
-  for (i = 0; i < requested_size; i++) 
-    Field (coq_global_boxed, i) = Val_true;
-}
-
 void init_coq_atom_tbl(long requested_size){
   int i;
   coq_atom_tbl = alloc_shr(requested_size, 0);
@@ -125,7 +115,6 @@ value init_coq_vm(value unit) /* ML */
     /* Allocate the table of global and the stack */
     init_coq_stack();
     init_coq_global_data(Coq_global_data_Size);
-    init_coq_global_boxed(40);
     init_coq_atom_tbl(40);
     /* Initialing the interpreter */
     coq_all_transp = 0;
@@ -181,11 +170,6 @@ value get_coq_atom_tbl(value unit)                  /* ML */
   return coq_atom_tbl;
 }
 
-value get_coq_global_boxed(value unit)        /* ML */
-{
-  return coq_global_boxed;
-}
-
 value realloc_coq_global_data(value size)           /* ML */
 {
   mlsize_t requested_size, actual_size, i;
@@ -205,24 +189,6 @@ value realloc_coq_global_data(value size)           /* ML */
   return Val_unit;
 }
 
-value realloc_coq_global_boxed(value size)           /* ML */
-{
-  mlsize_t requested_size, actual_size, i;
-  value new_global_boxed;
-  requested_size = Long_val(size);
-  actual_size = Wosize_val(coq_global_boxed);
-  if (requested_size >= actual_size) {
-    requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    new_global_boxed = alloc_shr(requested_size, 0);
-    for (i = 0; i < actual_size; i++)
-      initialize(&Field(new_global_boxed, i), Field(coq_global_boxed, i));
-    for (i = actual_size; i < requested_size; i++)
-      Field (new_global_boxed, i) = Val_long (0);
-    coq_global_boxed = new_global_boxed;
-  }
-  return Val_unit;
-}
-
 value realloc_coq_atom_tbl(value size)            /* ML */
 {
   mlsize_t requested_size, actual_size, i;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index 79e4d0fe..cec34f56 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -35,7 +35,6 @@ extern value * coq_stack_threshold;
 /* global_data */
 
 extern value coq_global_data;
-extern value coq_global_boxed;
 extern int coq_all_transp;
 extern value coq_atom_tbl;
 
@@ -56,8 +55,6 @@ value re_init_coq_vm(value unit); /* ML */
 void  realloc_coq_stack(asize_t required_space); 
 value get_coq_global_data(value unit); /* ML */
 value realloc_coq_global_data(value size); /* ML */
-value get_coq_global_boxed(value unit);
-value realloc_coq_global_boxed(value size); /* ML */
 value get_coq_atom_tbl(value unit); /* ML */
 value realloc_coq_atom_tbl(value size); /* ML */
 value coq_set_transp_value(value transp); /* ML */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 5d6d92ff..ae679027 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.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        *)
@@ -27,7 +27,7 @@ let cofix_evaluated_tag = 6
 
 type structured_constant =
   | Const_sorts of sorts
-  | Const_ind of inductive
+  | Const_ind of pinductive
   | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
@@ -67,7 +67,7 @@ type instruction =
                    (* nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
                    (* nb fv, init, lbl types, lbl bodies *)
-  | Kgetglobal of constant
+  | Kgetglobal of pconstant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (* size, tag *)
   | Kmakeprod
@@ -114,11 +114,14 @@ type instruction =
   | Kareconst of int*Label.t            (* conditional jump *)
   | Kcompint31                          (* dynamic compilation of int31 *)
   | Kdecompint31                        (* dynamic decompilation of int31 *)
+  | Klorint31                            (* bitwise operations: or and xor *)
+  | Klandint31
+  | Klxorint31
 (* /spiwack *)
 
 and bytecodes = instruction list
 
-type fv_elem = FVnamed of identifier | FVrel of int
+type fv_elem = FVnamed of Id.t | FVrel of int
 
 type fv = fv_elem array
 
@@ -182,7 +185,7 @@ let rec instruction ppf = function
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt;
       print_string " bodies = ";
       Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb;
-  | Kgetglobal id -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
+  | Kgetglobal (id,u) -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id)
   | Kconst cst ->
       fprintf ppf "\tconst"
   | Kmakeblock(n, m) ->
@@ -220,6 +223,9 @@ let rec instruction ppf = function
   | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl
   | Kcompint31 -> fprintf ppf "\tcompint31"
   | Kdecompint31 -> fprintf ppf "\tdecompint"
+  | Klorint31 -> fprintf ppf "\tlorint31"
+  | Klandint31 -> fprintf ppf "\tlandint31"
+  | Klxorint31 -> fprintf ppf "\tlxorint31"
 
 (* /spiwack *)
 
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index c8cc9503..b65268f7 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.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        *)
@@ -23,7 +23,7 @@ val cofix_evaluated_tag : tag
 
 type structured_constant =
   | Const_sorts of sorts
-  | Const_ind of inductive
+  | Const_ind of pinductive
   | Const_b0 of tag
   | Const_bn of tag * structured_constant array
 
@@ -60,7 +60,7 @@ type instruction =
                    (** nb fv, init, lbl types, lbl bodies *)
   | Kclosurecofix of int * int * Label.t array * Label.t array
                    (** nb fv, init, lbl types, lbl bodies *)
-  | Kgetglobal of constant
+  | Kgetglobal of pconstant
   | Kconst of structured_constant
   | Kmakeblock of int * tag             (** size, tag *)
   | Kmakeprod
@@ -107,13 +107,14 @@ type instruction =
   | Kisconst of Label.t                 (** conditional jump *)
   | Kareconst of int*Label.t            (** conditional jump *)
   | Kcompint31                          (** dynamic compilation of int31 *)
-  | Kdecompint31                        (** dynamix decompilation of int31 
-   /spiwack *)
-
+  | Kdecompint31                        (** dynamix decompilation of int31 *)
+  | Klorint31                           (** bitwise operations: or and xor *)
+  | Klandint31
+  | Klxorint31
 
 and bytecodes = instruction list
 
-type fv_elem = FVnamed of identifier | FVrel of int
+type fv_elem = FVnamed of Id.t | FVrel of int
 
 type fv = fv_elem array
 
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 56008749..d6c160c3 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.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        *)
@@ -50,7 +50,7 @@ open Pre_env
 (* Access to these variables is performed by the [Koffsetclosure n]       *)
 (* instruction that shifts the environment pointer of [n] fields.         *)
 
-(* This allows to represent mutual fixpoints in just one block.           *)
+(* This allows representing mutual fixpoints in just one block.           *)
 (* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint    *)
 (* types. They are used in conversion tests (which requires that          *)
 (* fixpoint types must be convertible). Their environment is the one of   *)
@@ -108,7 +108,7 @@ let empty_comp_env ()=
 (*i Creation functions for comp_env *)
 
 let rec add_param n sz l =
-  if n = 0 then l else add_param (n - 1) sz (n+sz::l)
+  if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l)
 
 let comp_env_fun arity =
   { nb_stack = arity;
@@ -179,16 +179,17 @@ let push_local sz r =
 
 
 (*i Compilation of variables *)
-let find_at el l =
+let find_at f l =
   let rec aux n = function
     | [] -> raise Not_found
-    | hd :: tl -> if hd = el then n else aux (n+1) tl
+    | hd :: tl -> if f hd then n else aux (n + 1) tl
   in aux 1 l
 
 let pos_named id r =
   let env = !(r.in_env) in
   let cid = FVnamed id in
-  try Kenvacc(r.offset + env.size - (find_at cid env.fv_rev))
+  let f = function FVnamed id' -> Id.equal id id' | _ -> false in
+  try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
   with Not_found ->
     let pos = env.size in
     r.in_env := { size = pos+1; fv_rev =  cid:: env.fv_rev};
@@ -206,7 +207,8 @@ let pos_rel i r sz =
       let i = i - r.nb_rec in
       let db = FVrel(i) in
       let env = !(r.in_env) in
-      try Kenvacc(r.offset + env.size - (find_at db env.fv_rev))
+      let f = function FVrel j -> Int.equal i j | _ -> false in
+      try Kenvacc(r.offset + env.size - (find_at f env.fv_rev))
       with Not_found ->
 	let pos = env.size in
 	r.in_env := { size = pos+1; fv_rev =  db:: env.fv_rev};
@@ -219,7 +221,7 @@ let pos_rel i r sz =
 (* non-terminating instruction (branch, raise, return, appterm)          *)
 (* in front of it.                                                       *)
 
-let rec discard_dead_code cont = cont
+let discard_dead_code cont = cont
 (*function
     [] -> []
   | (Klabel _ | Krestart ) :: _ as cont -> cont
@@ -280,14 +282,14 @@ let rec is_tailcall = function
 let rec add_pop n = function
   | Kpop m :: cont -> add_pop (n+m) cont
   | Kreturn m:: cont -> Kreturn (n+m) ::cont
-  | cont -> if n = 0 then cont else Kpop n :: cont
+  | cont -> if Int.equal n 0 then cont else Kpop n :: cont
 
 let add_grab arity lbl cont =
-  if arity = 1 then Klabel lbl :: cont
+  if Int.equal arity 1 then Klabel lbl :: cont
   else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont
 
 let add_grabrec rec_arg arity lbl cont =
-  if arity = 1 then
+  if Int.equal arity 1 && rec_arg < arity then
     Klabel lbl :: Kgrabrec 0 :: Krestart :: cont
   else
     Krestart :: Klabel lbl :: Kgrabrec rec_arg ::
@@ -331,7 +333,7 @@ let init_fun_code () = fun_code := []
 let code_construct tag nparams arity cont =
   let f_cont =
       add_pop nparams
-      (if arity = 0 then
+      (if Int.equal arity 0 then
 	[Kconst (Const_b0 tag); Kreturn 0]
        else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0])
     in
@@ -351,13 +353,13 @@ let rec str_const c =
   | App(f,args) ->
       begin
 	match kind_of_term f with
-	| Construct((kn,j),i) -> 
+	| Construct(((kn,j),i),u) -> 
             begin
 	    let oib = lookup_mind kn !global_env in
 	    let oip = oib.mind_packets.(j) in
 	    let num,arity = oip.mind_reloc_tbl.(i-1) in
 	    let nparams = oib.mind_nparams in
-	    if nparams + arity = Array.length args then
+	    if Int.equal (nparams + arity) (Array.length args) then
               (* spiwack: *)
               (* 1/ tries to compile the constructor in an optimal way,
                     it is supposed to work only if the arguments are
@@ -371,7 +373,7 @@ let rec str_const c =
 		try
 		  Bstrconst (Retroknowledge.get_vm_constant_static_info
                                               (!global_env).retroknowledge
-                                              (kind_of_term f) args)
+                                              f args)
                 with NotClosed ->
 		  (* 2/ if the arguments are not all closed (this is
                         expectingly (and it is currently the case) the only
@@ -392,12 +394,12 @@ let rec str_const c =
 		  let b_args = Array.map str_const rargs in
 		  Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term f)),
+                                           f),
                            b_args)
               with Not_found ->
 		(* 3/ if no special behavior is available, then the compiler
 		      falls back to the normal behavior *)
-		if arity = 0 then Bstrconst(Const_b0 num)
+		if Int.equal arity 0 then Bstrconst(Const_b0 num)
 		else
 		  let rargs = Array.sub args nparams arity in
 		  let b_args = Array.map str_const rargs in
@@ -413,7 +415,7 @@ let rec str_const c =
 	      try
 		Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term f)),
+                                           f),
                          b_args)
 	      with Not_found ->
 	        Bconstruct_app(num, nparams, arity, b_args)
@@ -421,21 +423,21 @@ let rec str_const c =
 	| _ -> Bconstr c
       end
   | Ind ind -> Bstrconst (Const_ind ind)
-  | Construct ((kn,j),i) ->  
+  | Construct (((kn,j),i),u) ->  
       begin
       (* spiwack: tries first to apply the run-time compilation
            behavior of the constructor, as in 2/ above *)
       try
 	Bspecial ((Retroknowledge.get_vm_constant_dynamic_info
                                            (!global_env).retroknowledge
-                                           (kind_of_term c)),
+                                           c),
                          [| |])
       with Not_found ->
 	let oib = lookup_mind kn !global_env in
 	let oip = oib.mind_packets.(j) in
 	let num,arity = oip.mind_reloc_tbl.(i-1) in
 	let nparams = oib.mind_nparams in
-	if nparams + arity = 0 then Bstrconst(Const_b0 num)
+	if Int.equal (nparams + arity) 0 then Bstrconst(Const_b0 num)
 	else Bconstruct_app(num,nparams,arity,[||])
       end
   | _ -> Bconstr c
@@ -484,25 +486,33 @@ let rec compile_fv reloc l sz cont =
 
 (* Compiling constants *)
 
-let rec get_allias env kn =
-  let tps = (lookup_constant kn env).const_body_code in
-  match Cemitcodes.force tps with
-  | BCallias kn' -> get_allias env kn'
-  | _ -> kn
-
+let rec get_allias env (kn,u as p) =
+  let cb = lookup_constant kn env in
+  let tps = cb.const_body_code in
+    (match Cemitcodes.force tps with
+    | BCallias (kn',u') -> get_allias env (kn', Univ.subst_instance_instance u u')
+    | _ -> p)
 
 (* Compiling expressions *)
 
 let rec compile_constr reloc c sz cont =
   match kind_of_term c with
-  | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta")
-  | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar")
+  | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta"
+  | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar"
+  | Proj (p,c) -> 
+    (* compile_const reloc p [|c|] sz cont *)
+    let kn = Projection.constant p in
+    let cb = lookup_constant kn !global_env in
+      (* TODO: better representation of projections *)
+    let pb = Option.get cb.const_proj in
+    let args = Array.make pb.proj_npars mkProp in
+      compile_const reloc kn Univ.Instance.empty (Array.append args [|c|]) sz cont
 
   | Cast(c,_,_) -> compile_constr reloc c sz cont
 
   | Rel i -> pos_rel i reloc sz :: cont
   | Var id -> pos_named id reloc :: cont
-  | Const kn -> compile_const reloc kn [||] sz cont
+  | Const (kn,u) -> compile_const reloc kn u [||] sz cont
   | Sort _  | Ind _ | Construct _ ->
       compile_str_cst reloc (str_const c) sz cont
 
@@ -529,14 +539,14 @@ let rec compile_constr reloc c sz cont =
       begin
 	match kind_of_term f with
 	| Construct _ -> compile_str_cst reloc (str_const c) sz cont
-        | Const kn -> compile_const reloc kn args sz cont
+        | Const (kn,u) -> compile_const reloc kn u args sz cont
 	| _ -> comp_app compile_constr compile_constr reloc f args sz cont
       end
   | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
       let rfv = ref empty_fv in
-      let lbl_types = Array.create ndef Label.no in
-      let lbl_bodies = Array.create ndef Label.no in
+      let lbl_types = Array.make ndef Label.no in
+      let lbl_bodies = Array.make ndef Label.no in
       (* Compilation des types *)
       let env_type = comp_env_fix_type rfv in
       for i = 0 to ndef - 1 do
@@ -564,8 +574,8 @@ let rec compile_constr reloc c sz cont =
 
   | CoFix(init,(_,type_bodies,rec_bodies)) ->
       let ndef = Array.length type_bodies in
-      let lbl_types = Array.create ndef Label.no in
-      let lbl_bodies = Array.create ndef Label.no in
+      let lbl_types = Array.make ndef Label.no in
+      let lbl_bodies = Array.make ndef Label.no in
       (* Compiling types *)
       let rfv = ref empty_fv in
       let env_type = comp_env_cofix_type ndef rfv in
@@ -598,8 +608,8 @@ let rec compile_constr reloc c sz cont =
       let mib = lookup_mind (fst ind) !global_env in
       let oib = mib.mind_packets.(snd ind) in
       let tbl = oib.mind_reloc_tbl in
-      let lbl_consts = Array.create oib.mind_nb_constant Label.no in
-      let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
+      let lbl_consts = Array.make oib.mind_nb_constant Label.no in
+      let lbl_blocks = Array.make (oib.mind_nb_args+1) Label.no in
       let branch1,cont = make_branch cont in
       (* Compiling return type *)
       let lbl_typ,fcode =
@@ -609,7 +619,7 @@ let rec compile_constr reloc c sz cont =
       let lbl_sw = Label.create () in
       let sz_b,branch,is_tailcall =
 	match branch1 with
-	| Kreturn k -> assert (k = sz); sz, branch1, true
+	| Kreturn k -> assert (Int.equal k sz); sz, branch1, true
 	| _ -> sz+3, Kjump, false
       in
       let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
@@ -622,7 +632,7 @@ let rec compile_constr reloc c sz cont =
       (* Compiling regular constructor branches *)
       for i = 0 to Array.length tbl - 1 do
 	let tag, arity = tbl.(i) in
-	if arity = 0 then
+	if Int.equal arity 0 then
 	  let lbl_b,code_b =
 	    label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in
 	  lbl_consts.(tag) <- lbl_b;
@@ -632,7 +642,7 @@ let rec compile_constr reloc c sz cont =
 	  let nargs = List.length args in
 	  let lbl_b,code_b =
 	    label_code(
-	    if nargs = arity then
+	    if Int.equal nargs arity then
 	      Kpushfields arity ::
 	      compile_constr (push_param arity sz_b reloc)
 		body (sz_b+arity) (add_pop arity (branch :: !c))
@@ -655,7 +665,7 @@ let rec compile_constr reloc c sz cont =
       in
       compile_constr reloc a sz
       (try
-	let entry = Term.Ind ind in
+	let entry = mkInd ind in
 	Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge
 	                                       entry code_sw
       with Not_found ->
@@ -669,7 +679,7 @@ and compile_str_cst reloc sc sz cont =
       let nargs = Array.length args in
       comp_args compile_str_cst reloc args sz (Kmakeblock(nargs,tag) :: cont)
   | Bconstruct_app(tag,nparams,arity,args) ->
-      if Array.length args = 0 then code_construct tag nparams arity cont
+      if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont
       else
 	comp_app
 	  (fun _ _ _ cont -> code_construct tag nparams arity cont)
@@ -680,20 +690,20 @@ and compile_str_cst reloc sc sz cont =
 (* spiwack : compilation of constants with their arguments.
    Makes a special treatment with 31-bit integer addition *)
 and compile_const =
-  fun reloc-> fun  kn -> fun args -> fun sz -> fun cont ->
+  fun reloc-> fun  kn u -> fun args -> fun sz -> fun cont ->
   let nargs = Array.length args in
   (* spiwack: checks if there is a specific way to compile the constant
               if there is not, Not_found is raised, and the function
               falls back on its normal behavior *)
   try
     Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge
-                  (kind_of_term (mkConst kn)) reloc args sz cont
+                  (mkConstU (kn,u)) reloc args sz cont
   with Not_found ->
-    if nargs = 0 then
-      Kgetglobal (get_allias !global_env kn) :: cont
+    if Int.equal nargs 0 then
+      Kgetglobal (get_allias !global_env (kn, u)) :: cont
     else
       comp_app (fun _ _ _ cont ->
-                   Kgetglobal (get_allias !global_env kn) :: cont)
+                   Kgetglobal (get_allias !global_env (kn,u)) :: cont)
         compile_constr reloc () args sz cont
 
 let compile env c =
@@ -708,7 +718,7 @@ let compile env c =
   Format.print_string "fv = ";
   List.iter (fun v ->
     match v with
-    | FVnamed id -> Format.print_string ((string_of_id id)^"; ")
+    | FVnamed id -> Format.print_string ((Id.to_string id)^"; ")
     | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv;  Format
     .print_string "\n";
   Format.print_flush();  *)
@@ -717,12 +727,12 @@ let compile env c =
 let compile_constant_body env = function
   | Undef _ | OpaqueDef _ -> BCconstant
   | Def sb ->
-      let body = Declarations.force sb in
+      let body = Mod_subst.force_constr sb in
       match kind_of_term body with
-	| Const kn' ->
+	| Const (kn',u) ->
 	    (* we use the canonical name of the constant*)
 	    let con= constant_of_kn (canonical_con kn') in
-	      BCallias (get_allias env con)
+	      BCallias (get_allias env (con,u))
 	| _ ->
 	    let res = compile env body in
 	    let to_patch = to_memory res in
@@ -730,7 +740,7 @@ let compile_constant_body env = function
 
 (* Shortcut of the previous function used during module strengthening *)
 
-let compile_alias kn = BCallias (constant_of_kn (canonical_con kn))
+let compile_alias (kn,u) = BCallias (constant_of_kn (canonical_con kn), u)
 
 (* spiwack: additional function which allow different part of compilation of the
       31-bit integers *)
@@ -749,7 +759,7 @@ let compile_structured_int31 fc args =
   Const_b0
     (Array.fold_left
        (fun temp_i -> fun t -> match kind_of_term t with
-          | Construct (_,d) -> 2*temp_i+d-1
+          | Construct ((_,d),_) -> 2*temp_i+d-1
           | _ -> raise NotClosed)
        0 args
     )
@@ -760,7 +770,7 @@ let compile_structured_int31 fc args =
 let dynamic_int31_compilation fc reloc args sz cont =
   if not fc then raise Not_found else
     let nargs = Array.length args in
-      if nargs = 31 then
+      if Int.equal nargs 31 then
 	let (escape,labeled_cont) = make_branch cont in
 	let else_lbl = Label.create() in
 	  comp_args compile_str_cst reloc args sz
@@ -778,7 +788,7 @@ let dynamic_int31_compilation fc reloc args sz cont =
 	    fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)];
 	    Kclosure(lbl,0) :: cont
 	in
-	  if nargs = 0 then
+	  if Int.equal nargs 0 then
 	    code_construct cont
 	  else
 	    comp_app (fun _ _ _ cont -> code_construct cont)
@@ -844,7 +854,7 @@ let op_compilation n op =
   fun kn fc reloc args sz cont ->
   if not fc then raise Not_found else
   let nargs = Array.length args in
-  if nargs=n then (*if it is a fully applied addition*)
+  if Int.equal nargs n then (*if it is a fully applied addition*)
     let (escape, labeled_cont) = make_branch cont in
     let else_lbl = Label.create () in
       comp_args compile_constr reloc args sz
@@ -854,7 +864,7 @@ let op_compilation n op =
            (* works as comp_app with nargs = n and non-tailcall cont*)
            Kgetglobal (get_allias !global_env kn)::
            Kapply n::labeled_cont)))
-  else if nargs=0 then
+  else if Int.equal nargs 0 then
     code_construct kn cont
   else
     comp_app (fun _ _ _ cont -> code_construct kn cont)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index d0bfd46c..eab36d8b 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -13,7 +13,7 @@ val compile_constant_body : env -> constant_def -> body_code
 
 (** Shortcut of the previous function used during module strengthening *)
 
-val compile_alias : constant -> body_code
+val compile_alias : pconstant -> body_code
 
 (** spiwack: this function contains the information needed to perform
             the static compilation of int31 (trying and obtaining
@@ -33,7 +33,7 @@ val dynamic_int31_compilation : bool -> comp_env ->
            works as follow: checks if all the arguments are non-pointers
            if they are applies the operation (second argument) if not
            all of them are, returns to a coq definition (third argument) *)
-val op_compilation : int -> instruction -> constant -> bool -> comp_env ->
+val op_compilation : int -> instruction -> pconstant -> bool -> comp_env ->
                              constr array -> int -> bytecodes-> bytecodes
 
 (*spiwack: compiling function to insert dynamic decompilation before
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 897464e6..3c9692a5 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.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        *)
@@ -20,7 +20,7 @@ open Mod_subst
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
-  | Reloc_getglobal of constant
+  | Reloc_getglobal of pconstant
 
 type patch = reloc_info * int
 
@@ -61,8 +61,7 @@ let out_word b1 b2 b3 b4 =
       then 2 * len
       else
 	if len = Sys.max_string_length
-	then raise (Invalid_argument "String.create")  (* Pas la bonne execption
-.... *)
+	then invalid_arg "String.create"  (* Pas la bonne exception .... *)
 	else Sys.max_string_length in
     let new_buffer = String.create new_len in
     String.blit !out_buffer 0 new_buffer 0 len;
@@ -97,7 +96,7 @@ let label_table  = ref ([| |] : label_definition array)
 let extend_label_table needed =
   let new_size = ref(Array.length !label_table) in
   while needed >= !new_size do new_size := 2 * !new_size done;
-  let new_table = Array.create !new_size (Label_undefined []) in
+  let new_table = Array.make !new_size (Label_undefined []) in
   Array.blit !label_table 0 new_table 0 (Array.length !label_table);
   label_table := new_table
 
@@ -148,8 +147,8 @@ and slot_for_annot a =
   enter (Reloc_annot a);
   out_int 0
 
-and slot_for_getglobal id =
-  enter (Reloc_getglobal id);
+and slot_for_getglobal p =
+  enter (Reloc_getglobal p);
   out_int 0
 
 
@@ -165,7 +164,7 @@ let emit_instr = function
       then out(opENVACC1 + n - 1)
       else (out opENVACC; out_int n)
   | Koffsetclosure ofs ->
-      if ofs = -2 || ofs = 0 || ofs = 2
+      if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
       then out (opOFFSETCLOSURE0 + ofs / 2)
       else (out opOFFSETCLOSURE; out_int ofs)
   | Kpush ->
@@ -214,7 +213,7 @@ let emit_instr = function
   | Kconst c ->
       out opGETGLOBAL; slot_for_const c
   | Kmakeblock(n, t) ->
-      if n = 0 then raise (Invalid_argument "emit_instr : block size = 0")
+      if Int.equal n 0 then invalid_arg "emit_instr : block size = 0"
       else if n < 4 then (out(opMAKEBLOCK1 + n - 1); out_int t)
       else (out opMAKEBLOCK; out_int n; out_int t)
   | Kmakeprod ->
@@ -237,7 +236,7 @@ let emit_instr = function
   | Ksetfield n ->
       if n <= 1 then out (opSETFIELD0+n)
       else (out opSETFIELD;out_int n)
-  | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr")
+  | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr"
   (* spiwack *)
   | Kbranch lbl -> out opBRANCH; out_label lbl
   | Kaddint31 -> out opADDINT31
@@ -258,6 +257,9 @@ let emit_instr = function
   | Kareconst(n,lbl) -> out opARECONST; out_int n; out_label lbl
   | Kcompint31 -> out opCOMPINT31
   | Kdecompint31 -> out opDECOMPINT31
+  | Klorint31 -> out opORINT31
+  | Klandint31 -> out opANDINT31
+  | Klxorint31 -> out opXORINT31
   (*/spiwack *)
   | Kstop ->
       out opSTOP
@@ -276,7 +278,7 @@ let rec emit = function
       else (out opPUSHENVACC; out_int n);
       emit c
   | Kpush :: Koffsetclosure ofs :: c ->
-      if ofs = -2 || ofs = 0 || ofs = 2
+      if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2
       then out(opPUSHOFFSETCLOSURE0 + ofs / 2)
       else (out opPUSHOFFSETCLOSURE; out_int ofs);
       emit c
@@ -302,7 +304,7 @@ let rec emit = function
 
 let init () =
   out_position := 0;
-  label_table := Array.create 16 (Label_undefined []);
+  label_table := Array.make 16 (Label_undefined []);
   reloc_info := []
 
 type emitcodes = string
@@ -318,28 +320,28 @@ let rec subst_strcst s sc =
   match sc with
   | Const_sorts _ | Const_b0 _ -> sc
   | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args)
-  | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i))
+  | Const_ind(ind,u) -> let kn,i = ind in Const_ind((subst_mind s kn, i), u)
 
 let subst_patch s (ri,pos) =
   match ri with
   | Reloc_annot a ->
       let (kn,i) = a.ci.ci_ind in
-      let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in
+      let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in
       (Reloc_annot {a with ci = ci},pos)
   | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos)
-  | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos)
+  | Reloc_getglobal kn -> (Reloc_getglobal (subst_pcon s kn), pos)
 
 let subst_to_patch s (code,pl,fv) =
   code,List.rev_map (subst_patch s) pl,fv
 
 type body_code =
   | BCdefined of to_patch
-  | BCallias of constant
+  | BCallias of pconstant
   | BCconstant
 
 let subst_body_code s = function
   | BCdefined tp -> BCdefined (subst_to_patch s tp)
-  | BCallias kn -> BCallias (fst (subst_con s kn))
+  | BCallias (kn,u) -> BCallias (fst (subst_con_kn s kn), u)
   | BCconstant -> BCconstant
 
 type to_patch_substituted = body_code substituted
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 287c3930..cec90130 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -4,7 +4,7 @@ open Cbytecodes
 type reloc_info =
   | Reloc_annot of annot_switch
   | Reloc_const of structured_constant
-  | Reloc_getglobal of constant
+  | Reloc_getglobal of constant Univ.puniverses
 
 type patch = reloc_info * int
 
@@ -25,7 +25,7 @@ val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
 
 type body_code =
   | BCdefined of to_patch
-  | BCallias of constant
+  | BCallias of constant Univ.puniverses
   | BCconstant
 
 
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 9e2af94b..f06b13d8 100644
--- a/kernel/closure.ml
+++ b/kernel/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        *)
@@ -19,11 +19,12 @@
 (* This file implements a lazy reduction for the Calculus of Inductive
    Constructions *)
 
+open Errors
 open Util
 open Pp
-open Term
 open Names
-open Declarations
+open Term
+open Vars
 open Environ
 open Esubst
 
@@ -33,6 +34,7 @@ let share = ref true
 (* Profiling *)
 let beta = ref 0
 let delta = ref 0
+let eta = ref 0
 let zeta = ref 0
 let evar = ref 0
 let iota = ref 0
@@ -43,9 +45,10 @@ let reset () =
   prune := 0
 
 let stop() =
-  msgnl (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
-	 str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++
-         str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]")
+  msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++
+	 str " eta=" ++ int !eta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++
+	 int !evar ++ str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++
+	 str"]")
 
 let incr_cnt red cnt =
   if red then begin
@@ -63,10 +66,10 @@ let with_stats c =
   end else
     Lazy.force c
 
-let all_opaque = (Idpred.empty, Cpred.empty)
-let all_transparent = (Idpred.full, Cpred.full)
+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
@@ -74,16 +77,18 @@ module type RedFlagsSig = sig
   type red_kind
   val fBETA : red_kind
   val fDELTA : red_kind
+  val fETA : red_kind
   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 red_sub : reds -> red_kind -> reds
   val red_add_transparent : reds -> transparent_state -> reds
   val mkflags : red_kind list -> reds
   val red_set : reds -> red_kind -> bool
+  val red_projection : reds -> projection -> bool
 end
 
 module RedFlags = (struct
@@ -95,14 +100,16 @@ module RedFlags = (struct
   type reds = {
     r_beta : bool;
     r_delta : bool;
+    r_eta : bool;
     r_const : transparent_state;
     r_zeta : bool;
     r_iota : bool }
 
-  type red_kind = BETA | DELTA | IOTA | ZETA
-	      | CONST of constant | VAR of identifier
+  type red_kind = BETA | DELTA | ETA | IOTA | ZETA
+	      | CONST of constant | VAR of Id.t
   let fBETA = BETA
   let fDELTA = DELTA
+  let fETA = ETA
   let fIOTA = IOTA
   let fZETA = ZETA
   let fCONST kn  = CONST kn
@@ -110,12 +117,14 @@ module RedFlags = (struct
   let no_red = {
     r_beta = false;
     r_delta = false;
+    r_eta = false;
     r_const = all_opaque;
     r_zeta = false;
     r_iota = false }
 
   let red_add red = function
     | BETA -> { red with r_beta = true }
+    | ETA -> { red with r_eta = true }
     | DELTA -> { red with r_delta = true; r_const = all_transparent }
     | CONST kn ->
 	let (l1,l2) = red.r_const in
@@ -124,10 +133,11 @@ 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 red_sub red = function
     | BETA -> { red with r_beta = false }
+    | ETA -> { red with r_eta = false }
     | DELTA -> { red with r_delta = false }
     | CONST kn ->
  	let (l1,l2) = red.r_const in
@@ -136,7 +146,7 @@ module RedFlags = (struct
     | ZETA -> { red with r_zeta = false }
     | VAR id ->
 	let (l1,l2) = red.r_const in
-	{ red with r_const = Idpred.remove id l1, l2 }
+	{ red with r_const = Id.Pred.remove id l1, l2 }
 
   let red_add_transparent red tr =
     { red with r_const = tr }
@@ -145,19 +155,24 @@ module RedFlags = (struct
 
   let red_set red = function
     | BETA -> incr_cnt red.r_beta beta
+    | ETA -> incr_cnt red.r_eta eta
     | CONST kn ->
 	let (_,l) = red.r_const in
 	let c = Cpred.mem kn l in
 	incr_cnt c delta
     | VAR id -> (* En attendant d'avoir des kn pour les Var *)
 	let (l,_) = red.r_const in
-	let c = Idpred.mem id l in
+	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
     | DELTA -> (* Used for Rel/Var defined in context *)
 	incr_cnt red.r_delta delta
 
+  let red_projection red p = 
+    if Projection.unfolded p then true
+    else red_set red (fCONST (Projection.constant p))
+
 end : RedFlagsSig)
 
 open RedFlags
@@ -185,9 +200,8 @@ let unfold_red kn =
  *  * i_repr is the function to get the representation from the current
  *         state of the cache and the body of the constant. The result
  *         is stored in the table.
- *  * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables
- *    and only those with index 1 and 3 have bodies which are c and d resp.
- *  * i_vars is the list of _defined_ named variables.
+ *  * i_rels is the array of free rel variables together with their optional
+ *    body
  *
  * 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
@@ -197,72 +211,96 @@ let unfold_red kn =
  * instantiations (cbv or lazy) are.
  *)
 
-type table_key = id_key
+type table_key = constant puniverses tableKey
+
+let eq_pconstant_key (c,u) (c',u') =
+  eq_constant_key c c' && Univ.Instance.equal u u'
+  
+module IdKeyHash =
+struct
+  open Hashset.Combine
+  type t = table_key
+  let equal = Names.eq_table_key eq_pconstant_key
+  let hash = function
+  | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c)
+  | VarKey id -> combinesmall 2 (Id.hash id)
+  | RelKey i -> combinesmall 3 (Int.hash i)
+end
 
-let eq_table_key = Names.eq_id_key
+module KeyTable = Hashtbl.Make(IdKeyHash)
 
-type 'a infos = {
-  i_flags : reds;
+let eq_table_key = IdKeyHash.equal
+
+type 'a infos_cache = {
   i_repr : 'a infos -> constr -> 'a;
   i_env : env;
   i_sigma : existential -> constr option;
-  i_rels : int * (int * constr) list;
-  i_vars : (identifier * constr) list;
-  i_tab : (table_key, 'a) Hashtbl.t }
+  i_rels : constr option array;
+  i_tab : 'a KeyTable.t }
+
+and 'a infos = { 
+  i_flags : reds;
+  i_cache : 'a infos_cache }
 
 let info_flags info = info.i_flags
+let info_env info = info.i_cache.i_env
 
-let ref_value_cache info ref =
+let rec assoc_defined id = function
+| [] -> raise Not_found
+| (_, None, _) :: ctxt -> assoc_defined id ctxt
+| (id', Some c, _) :: ctxt ->
+  if Id.equal id id' then c else assoc_defined id ctxt
+
+let ref_value_cache ({i_cache = cache} as infos)  ref =
   try
-    Some (Hashtbl.find info.i_tab ref)
+    Some (KeyTable.find cache.i_tab ref)
   with Not_found ->
   try
     let body =
       match ref with
 	| RelKey n ->
-	    let (s,l) = info.i_rels in lift n (List.assoc (s-n) l)
-	| VarKey id -> List.assoc id info.i_vars
-	| ConstKey cst -> constant_value info.i_env cst
+            let len = Array.length cache.i_rels in
+            let i = n - 1 in
+            let () = if i < 0 || len <= i then raise Not_found in
+            begin match Array.unsafe_get cache.i_rels i with
+            | None -> raise Not_found
+            | Some t -> lift n t
+            end
+	| VarKey id -> assoc_defined id (named_context cache.i_env)
+	| ConstKey cst -> constant_value_in cache.i_env cst
     in
-    let v = info.i_repr info body in
-    Hashtbl.add info.i_tab ref v;
+    let v = cache.i_repr infos body in
+    KeyTable.add cache.i_tab ref v;
     Some v
   with
     | Not_found (* List.assoc *)
     | NotEvaluableConst _ (* Const *)
       -> None
 
-let evar_value info ev =
-  info.i_sigma ev
-
-let defined_vars flags env =
-(*  if red_local_const (snd flags) then*)
-    Sign.fold_named_context
-      (fun (id,b,_) e ->
-	 match b with
-	   | None -> e
-	   | Some body -> (id, body)::e)
-       (named_context env) ~init:[]
-(*  else []*)
+let evar_value cache ev =
+  cache.i_sigma ev
 
 let defined_rels flags env =
 (*  if red_local_const (snd flags) then*)
-  Sign.fold_rel_context
-      (fun (id,b,t) (i,subs) ->
-	 match b with
-	   | None -> (i+1, subs)
-	   | Some body -> (i+1, (i,body) :: subs))
-      (rel_context env) ~init:(0,[])
+  let ctx = rel_context env in
+  let len = List.length ctx in
+  let ans = Array.make len None in
+  let iter i (_, b, _) = match b with
+  | None -> ()
+  | Some _ -> Array.unsafe_set ans i b
+  in
+  let () = List.iteri iter ctx in
+  ans
 (*  else (0,[])*)
 
 let create mk_cl flgs env evars =
-  { i_flags = flgs;
-    i_repr = mk_cl;
-    i_env = env;
-    i_sigma = evars;
-    i_rels = defined_rels flgs env;
-    i_vars = defined_vars flgs env;
-    i_tab = Hashtbl.create 17 }
+  let cache = 
+    { i_repr = mk_cl;
+      i_env = env;
+      i_sigma = evars;
+      i_rels = defined_rels flgs env;
+      i_tab = KeyTable.create 17 }
+  in { i_flags = flgs; i_cache = cache }
 
 
 (**********************************************************************)
@@ -302,15 +340,17 @@ 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 projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
-  | FLambda of int * (name * constr) list * constr * fconstr subs
-  | FProd of name * fconstr * fconstr
-  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | 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.t * constr) list * constr * fconstr subs
+  | FProd of Name.t * fconstr * fconstr
+  | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs
   | FEvar of existential * fconstr subs
   | FLIFT of int * fconstr
   | FCLOS of constr * fconstr subs
@@ -318,13 +358,13 @@ and fterm =
 
 let fterm_of v = v.term
 let set_norm v = v.norm <- Norm
-let is_val v = v.norm = Norm
+let is_val v = match v.norm with Norm -> true | _ -> false
 
 let mk_atom c = {norm=Norm;term=FAtom c}
 
 (* Could issue a warning if no is still Red, pointing out that we loose
    sharing. *)
-let update v1 (no,t) =
+let update v1 no t =
   if !share then
     (v1.norm <- no;
      v1.term <- t;
@@ -337,6 +377,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
@@ -345,7 +387,7 @@ and stack = stack_member list
 
 let empty_stack = []
 let append_stack v s =
-  if Array.length v = 0 then s else
+  if Int.equal (Array.length v) 0 then s else
   match s with
   | Zapp l :: s -> Zapp (Array.append v l) :: s
   | _ -> Zapp v :: s
@@ -389,7 +431,7 @@ let rec stack_assign s p c = match s with
          Zapp nargs :: s)
   | _ -> s
 let rec stack_tail p s =
-  if p = 0 then s else
+  if Int.equal p 0 then s else
     match s with
       | Zapp args :: s ->
 	  let q = Array.length args in
@@ -417,9 +459,9 @@ let rec lft_fconstr n ft =
     | FLOCKED -> assert false
     | _ -> {norm=ft.norm; term=FLIFT(n,ft)}
 let lift_fconstr k f =
-  if k=0 then f else lft_fconstr k f
+  if Int.equal k 0 then f else lft_fconstr k f
 let lift_fconstr_vect k v =
-  if k=0 then v else Array.map (fun f -> lft_fconstr k f) v
+  if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v
 
 let clos_rel e i =
   match expand_rel i e with
@@ -436,88 +478,21 @@ let compact_stack head stk =
         (* Be sure to create a new cell otherwise sharing would be
            lost by the update operation *)
         let h' = lft_fconstr depth head in
-        let _ = update m (h'.norm,h'.term) in
+        let _ = update m h'.norm h'.term in
         strip_rec depth s
     | stk -> zshift depth stk in
   strip_rec 0 stk
 
 (* Put an update mark in the stack, only if needed *)
 let zupdate m s =
-  if !share & m.norm = Red
+  if !share && begin match m.norm with Red -> true | _ -> false end
   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 kind_of_term c with
-      Rel i ->
-        if i < k then c,s else
-          (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs)
-          with Not_found -> mkRel (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 mkEvar(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 mkCast(a', ck, b'), s
-    | App(f,v) ->
-        let (f',s) = compact_constr s f k in
-        let (v',s) = compact_vect s v k in
-        if f==f' && v==v' then c,s else mkApp(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 mkLambda(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 mkProd(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 mkLetIn(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 mkFix(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 mkCoFix(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 mkCase(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)
 
@@ -539,10 +514,10 @@ 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
+let mk_clos_vect env v = CArray.Fun1.map mk_clos env v
 
 (* Translate the head constructor of t from constr to fconstr. This
    function is parameterized by the function to apply on the direct
@@ -557,11 +532,13 @@ let mk_clos_deep clos_fun env t =
           term = FCast (clos_fun env a, k, clos_fun env b)}
     | App (f,v) ->
         { norm = Red;
-	  term = FApp (clos_fun env f, Array.map (clos_fun env) v) }
+	  term = FApp (clos_fun env f, CArray.Fun1.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) }
+	  term = FCaseT (ci, p, clos_fun env c, v, env) }
     | Fix fx ->
         { norm = Cstr; term = FFix (fx, env) }
     | CoFix cfx ->
@@ -589,30 +566,37 @@ let rec to_constr constr_fun lfts v =
     | FAtom c -> exliftn lfts c
     | FCast (a,k,b) ->
         mkCast (constr_fun lfts a, k, constr_fun lfts b)
-    | FFlex (ConstKey op) -> mkConst op
-    | FInd op -> mkInd op
-    | FConstruct op -> mkConstruct op
-    | FCases (ci,p,c,ve) ->
+    | FFlex (ConstKey op) -> mkConstU op
+    | FInd op -> mkIndU op
+    | FConstruct op -> mkConstructU op
+    | FCase (ci,p,c,ve) ->
 	mkCase (ci, constr_fun lfts p,
                 constr_fun lfts c,
-		Array.map (constr_fun lfts) ve)
+		CArray.Fun1.map constr_fun lfts ve)
+    | FCaseT (ci,p,c,ve,env) ->
+	mkCase (ci, constr_fun lfts (mk_clos env p),
+                constr_fun lfts c,
+		Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve)
     | FFix ((op,(lna,tys,bds)),e) ->
         let n = Array.length bds in
-        let ftys = Array.map (mk_clos e) tys in
-        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+        let ftys = CArray.Fun1.map mk_clos e tys in
+        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
 	let lfts' = el_liftn n lfts in
-	mkFix (op, (lna, Array.map (constr_fun lfts) ftys,
-		         Array.map (constr_fun lfts') fbds))
+	mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
+		         CArray.Fun1.map constr_fun lfts' fbds))
     | FCoFix ((op,(lna,tys,bds)),e) ->
         let n = Array.length bds in
-        let ftys = Array.map (mk_clos e) tys in
-        let fbds = Array.map (mk_clos (subs_liftn n e)) bds in
+        let ftys = CArray.Fun1.map mk_clos e tys in
+        let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in
 	let lfts' = el_liftn (Array.length bds) lfts in
-	mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys,
-		           Array.map (constr_fun lfts') fbds))
+	mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys,
+		           CArray.Fun1.map constr_fun lfts' fbds))
     | FApp (f,ve) ->
 	mkApp (constr_fun lfts f,
-	       Array.map (constr_fun lfts) ve)
+	       CArray.Fun1.map constr_fun lfts ve)
+    | FProj (p,c) ->
+        mkProj (p,constr_fun lfts c)
+
     | FLambda _ ->
         let (na,ty,bd) = destFLambda mk_clos2 v in
 	mkLambda (na, constr_fun lfts ty,
@@ -630,9 +614,9 @@ let rec to_constr constr_fun lfts v =
     | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a
     | FCLOS (t,env) ->
         let fr = mk_clos2 env t in
-        let unfv = update v (fr.norm,fr.term) in
+        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,
@@ -641,11 +625,11 @@ 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 -> mkFix fx
-      | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
+      | FFix(fx,e) when is_subs_id e && is_lift_id lfts -> mkFix fx
+      | FCoFix(cfx,e) when is_subs_id e && is_lift_id lfts -> mkCoFix cfx
       | _ -> to_constr term_of_fconstr_lift lfts v in
   term_of_fconstr_lift el_id
 
@@ -663,14 +647,19 @@ 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(Projection.make cst true,m)} s
     | Zfix(fx,par)::s ->
         zip fx (par @ append_stack [|m|] s)
     | Zshift(n)::s ->
         zip (lift_fconstr n m) s
     | Zupdate(rf)::s ->
-        zip (update rf (m.norm,m.term)) s
+        zip (update rf m.norm m.term) s
 
 let fapp_stack (m,stk) = zip m stk
 
@@ -682,8 +671,7 @@ let fapp_stack (m,stk) = zip m stk
    (strip_update_shift, through get_arg). *)
 
 (* optimised for the case where there are no shifts... *)
-let strip_update_shift_app head stk =
-  assert (head.norm <> Red);
+let strip_update_shift_app_red head stk =
   let rec strip_rec rstk h depth = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s
@@ -691,13 +679,16 @@ let strip_update_shift_app head stk =
         strip_rec (Zapp args :: rstk)
           {norm=h.norm;term=FApp(h,args)} depth s
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) depth s
+        strip_rec rstk (update m h.norm h.term) depth s
     | stk -> (depth,List.rev rstk, stk) in
   strip_rec [] head 0 stk
 
+let strip_update_shift_app head stack =
+  assert (match head.norm with Red -> false | _ -> true);
+  strip_update_shift_app_red head stack
 
 let get_nth_arg head n stk =
-  assert (head.norm <> Red);
+  assert (match head.norm with Red -> false | _ -> true);
   let rec strip_rec rstk h n = function
     | Zshift(k) as e :: s ->
         strip_rec (e::rstk) (lift_fconstr k h) n s
@@ -710,10 +701,10 @@ let get_nth_arg head n stk =
           let bef = Array.sub args 0 n in
           let aft = Array.sub args (n+1) (q-n-1) in
           let stk' =
-            List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
+            List.rev (if Int.equal n 0 then rstk else (Zapp bef :: rstk)) in
           (Some (stk', args.(n)), append_stack aft s')
     | Zupdate(m)::s ->
-        strip_rec rstk (update m (h.norm,h.term)) n s
+        strip_rec rstk (update m h.norm h.term) n s
     | s -> (None, List.rev rstk @ s) in
   strip_rec [] head n stk
 
@@ -722,7 +713,7 @@ let get_nth_arg head n stk =
 let rec get_args n tys f e stk =
   match stk with
       Zupdate r :: s ->
-        let _hd = update r (Cstr,FLambda(n,tys,f,e)) in
+        let _hd = update r Cstr (FLambda(n,tys,f,e)) in
         get_args n tys f e s
     | Zshift k :: s ->
         get_args n tys f (subs_shft (k,e)) s
@@ -734,13 +725,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}|]]
@@ -751,29 +743,88 @@ let rec reloc_rargs_rec depth stk =
   match stk with
       Zapp args :: s ->
         Zapp (lift_fconstr_vect depth args) :: reloc_rargs_rec depth s
-    | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s
+    | Zshift(k)::s -> if Int.equal k depth then s else reloc_rargs_rec (depth-k) s
     | _ -> stk
 
 let reloc_rargs depth stk =
-  if depth = 0 then stk else reloc_rargs_rec depth stk
+  if Int.equal depth 0 then stk else reloc_rargs_rec depth stk
 
-let rec drop_parameters depth n argstk =
+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
+    | 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 ->
+  (* we know that n < stack_args_size(argstk) (if well-typed term) *) 
+  anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor")
+
+
+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 n=0 then []
-	else anomaly
-	  "ill-typed term: found a match on a partially applied constructor"
+	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 *)
 
+
+(** [eta_expand_ind_stack env ind c s t] computes stacks correspoding 
+    to the conversion of the eta expansion of t, considered as an inhabitant 
+    of ind, and the Constructor c of this inductive type applied to arguments
+    s.
+    @assumes [t] is an irreducible term, and not a constructor. [ind] is the inductive
+    of the constructor term [c] 
+    @raises Not_found if the inductive is not a primitive record, or if the 
+    constructor is partially applied.
+ *)
+let eta_expand_ind_stack env ind m s (f, s') =
+  let mib = lookup_mind (fst ind) env in
+    match mib.Declarations.mind_record with
+    | Some (Some (_,projs,pbs)) when
+	mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> 
+	(* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') ->
+	   arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *)
+      let pars = mib.Declarations.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 (Projection.make p true, 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.
  * Given a fixpoint and a substitution, returns the corresponding
  * fixpoint body, and the substitution in which it should be
@@ -798,39 +849,51 @@ let contract_fix_vect fix =
   in
   (subs_cons(Array.init nfix make_body, env), thisbody)
 
-
 (*********************************************************************)
 (* A machine that inspects the head of a term until it finds an
    atom or a subterm that may produce a redex (abstraction,
    constructor, cofix, letin, constant), or a neutral term (product,
    inductive) *)
-let rec knh m stk =
+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,e) -> knh info t (ZcaseT(ci,p,br,e)::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) ->
+      let unf = Projection.unfolded p in
+        if unf || red_set info.i_flags (fCONST (Projection.constant p)) then
+          (match try Some (lookup_projection p (info_env info)) with Not_found -> None with
+	  | None -> (m, stk)
+	  | Some pb ->
+	     knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+				Projection.constant 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 kind_of_term t with
     | App(a,b) ->
-        knht e a (append_stack (mk_clos_vect e b) stk)
+        knht info 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 t (ZcaseT(ci, p, br, e)::stk)
+    | Fix _ -> knh info (mk_clos2 e t) stk
+    | 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
     | (Lambda _|Prod _|Construct _|CoFix _|Ind _|
        LetIn _|Const _|Var _|Evar _|Meta _|Sort _) ->
         (mk_clos2 e t, stk)
@@ -845,8 +908,8 @@ 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) ->
-      (match ref_value_cache info (ConstKey kn) with
+  | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) ->
+      (match ref_value_cache info (ConstKey c) with
           Some v -> kni info v stk
         | None -> (set_norm m; (m,stk)))
   | FFlex(VarKey id) when red_set info.i_flags (fVAR id) ->
@@ -857,38 +920,46 @@ 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)
+        | (depth, args, ZcaseT(ci,_,br,e)::s) ->
+            assert (ci.ci_npar>=0);
+            let rargs = drop_parameters depth ci.ci_npar args in
+            knit info e 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'
+	| (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))
   | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA ->
       knit info (subs_cons([|v|],e)) bd stk
   | FEvar(ev,env) ->
-      (match evar_value info ev with
+      (match evar_value info.i_cache ev with
           Some c -> knit info env c stk
         | None -> (m,stk))
   | _ -> (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)
@@ -903,6 +974,13 @@ let rec zip_term zfun m stk =
     | Zcase(ci,p,br)::s ->
         let t = mkCase(ci, zfun p, m, Array.map zfun br) in
         zip_term zfun t s
+    | ZcaseT(ci,p,br,e)::s ->
+        let t = mkCase(ci, zfun (mk_clos e p), m,
+		       Array.map (fun b -> zfun (mk_clos e b)) br) in
+        zip_term zfun t s
+    | Zproj(_,_,p)::s -> 
+        let t = mkProj (Projection.make p true, m) in 
+	zip_term zfun t s
     | Zfix(fx,par)::s ->
         let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in
         zip_term zfun h s
@@ -940,17 +1018,19 @@ and norm_head info m =
       | FProd(na,dom,rng) ->
           mkProd(na, kl info dom, kl info rng)
       | FCoFix((n,(na,tys,bds)),e) ->
-          let ftys = Array.map (mk_clos e) tys in
+          let ftys = CArray.Fun1.map mk_clos e tys in
           let fbds =
-            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
-          mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+          mkCoFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds))
       | FFix((n,(na,tys,bds)),e) ->
-          let ftys = Array.map (mk_clos e) tys in
+          let ftys = CArray.Fun1.map mk_clos e tys in
           let fbds =
-            Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in
-          mkFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds))
+            CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in
+          mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds))
       | FEvar((i,args),env) ->
           mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args)
+      | FProj (p,c) ->
+          mkProj (p, kl info c)
       | t -> term_of_fconstr m
 
 (* Initialization and then normalization *)
@@ -963,7 +1043,7 @@ let whd_val info v =
 let norm_val info v =
   with_stats (lazy (kl info v))
 
-let inject = mk_clos (subs_id 0)
+let inject c = mk_clos (subs_id 0) c
 
 let whd_stack infos m stk =
   let k = kni infos m stk in
@@ -975,5 +1055,22 @@ type clos_infos = fconstr infos
 
 let create_clos_infos ?(evars=fun _ -> None) flgs env =
   create (fun _ -> inject) flgs env evars
-
-let unfold_reference = ref_value_cache
+let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env
+
+let env_of_infos infos = infos.i_cache.i_env
+
+let infos_with_reds infos reds = 
+  { infos with i_flags = reds }
+
+let unfold_reference info key = 
+  match key with
+  | ConstKey (kn,_) ->
+    if red_set info.i_flags (fCONST kn) then
+      ref_value_cache info key  
+    else None
+  | VarKey i -> 
+    if red_set info.i_flags (fVAR i) then
+      ref_value_cache info key
+    else None
+  | _ -> ref_value_cache info key
+  
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 0818d42f..a3b0e0f3 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  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 Names
 open Term
 open Environ
@@ -37,13 +36,16 @@ module type RedFlagsSig = sig
   type reds
   type red_kind
 
-  (** The different kinds of reduction *)
+  (** {7 The different kinds of reduction } *)
+
   val fBETA : red_kind
   val fDELTA : red_kind
+  val fETA : red_kind
+  (** This flag is never used by the kernel reduction but pretyping does *)
   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
@@ -62,7 +64,10 @@ module type RedFlagsSig = sig
 
   (** Tests if a reduction kind is set *)
   val red_set : reds -> red_kind -> bool
-
+    
+  (** This tests if the projection is in unfolded state already or
+      is unfodable due to delta. *)
+  val red_projection : reds -> projection -> bool
 end
 
 module RedFlags : RedFlagsSig
@@ -78,14 +83,20 @@ val unfold_side_red : reds
 val unfold_red : evaluable_global_reference -> reds
 
 (***********************************************************************)
-type table_key = id_key
+type table_key = constant puniverses tableKey
+
+type 'a infos_cache
+type 'a infos = { 
+  i_flags : reds;
+  i_cache : 'a infos_cache }
 
-type 'a infos
 val ref_value_cache: 'a infos -> table_key -> 'a option
-val info_flags: 'a infos -> reds
 val create: ('a infos -> constr -> 'a) -> reds -> env ->
   (existential -> constr option) -> 'a infos
-val evar_value : 'a infos -> existential -> constr option
+val evar_value : 'a infos_cache -> existential -> constr option
+
+val info_env : 'a infos -> env
+val info_flags: 'a infos -> reds
 
 (***********************************************************************
   s Lazy reduction. *)
@@ -102,15 +113,17 @@ 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 inductive puniverses
+  | FConstruct of constructor puniverses
   | FApp of fconstr * fconstr array
+  | FProj of projection * fconstr
   | FFix of fixpoint * fconstr subs
   | FCoFix of cofixpoint * fconstr subs
-  | FCases of case_info * fconstr * fconstr * fconstr array
-  | FLambda of int * (name * constr) list * constr * fconstr subs
-  | FProd of name * fconstr * fconstr
-  | FLetIn of name * fconstr * fconstr * constr * fconstr subs
+  | 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.t * constr) list * constr * fconstr subs
+  | FProd of Name.t * fconstr * fconstr
+  | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs
   | FEvar of existential * fconstr subs
   | FLIFT of int * fconstr
   | FCLOS of constr * fconstr subs
@@ -124,6 +137,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
@@ -154,12 +169,17 @@ val mk_atom : constr -> fconstr
 val fterm_of : fconstr -> fterm
 val term_of_fconstr : fconstr -> constr
 val destFLambda :
-  (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
+  (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr
 
 (** Global and local constant cache *)
-type clos_infos
+type clos_infos = fconstr infos
 val create_clos_infos :
   ?evars:(existential->constr option) -> reds -> env -> clos_infos
+val oracle_of_infos : clos_infos -> Conv_oracle.oracle
+
+val env_of_infos : clos_infos -> env
+
+val infos_with_reds : clos_infos -> reds -> clos_infos
 
 (** Reduction function *)
 
@@ -174,6 +194,18 @@ val whd_val : clos_infos -> fconstr -> constr
 val whd_stack :
   clos_infos -> fconstr -> stack -> fconstr * stack
 
+(** [eta_expand_ind_stack env ind c s t] computes stacks correspoding 
+    to the conversion of the eta expansion of t, considered as an inhabitant 
+    of ind, and the Constructor c of this inductive type applied to arguments
+    s.
+    @assumes [t] is a rigid term, and not a constructor. [ind] is the inductive
+    of the constructor term [c] 
+    @raises Not_found if the inductive is not a primitive record, or if the 
+    constructor is partially applied.
+ *)
+val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> 
+   (fconstr * stack) -> stack * stack
+
 (** Conversion auxiliary functions to do step by step normalisation *)
 
 (** [unfold_reference] unfolds references in a [fconstr] *)
@@ -198,6 +230,5 @@ val knr: clos_infos -> fconstr -> stack -> fconstr * stack
 val kl : clos_infos -> fconstr -> constr
 
 val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
-val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
 
 (** End of cbn debug section i*)
diff --git a/kernel/constr.ml b/kernel/constr.ml
new file mode 100644
index 00000000..49f74841
--- /dev/null
+++ b/kernel/constr.ml
@@ -0,0 +1,1011 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
+(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
+(* Extension to mutual inductive constructions by Christine Paulin for
+   Coq V5.10.2 *)
+(* Extension to co-inductive constructions by Eduardo Gimenez *)
+(* Optimization of substitution functions by Chet Murthy *)
+(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
+   Filliâtre, 1999 *)
+(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+
+(* This file defines the internal syntax of the Calculus of
+   Inductive Constructions (CIC) terms together with constructors,
+   destructors, iterators and basic functions *)
+
+open Util
+open Names
+open Univ
+
+type existential_key = Evar.t
+type metavariable = int
+
+(* This defines the strategy to use for verifiying a Cast *)
+(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
+(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
+type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast
+
+(* This defines Cases annotations *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
+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 }
+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 *)
+  }
+
+(********************************************************************)
+(*       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, 'types) prec_declaration =
+    Name.t array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+type 'a puniverses = 'a Univ.puniverses
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+(* [Var] is used for named variables and [Rel] for variables as
+   de Bruijn indices. *)
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of Id.t
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of Sorts.t
+  | Cast      of 'constr * cast_kind * 'types
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * '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, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
+(* constr is the fixpoint of the previous type. Requires option
+   -rectypes of the Caml compiler to be set *)
+type t = (t,t) kind_of_term
+type constr = t
+
+type existential = existential_key * constr array
+type rec_declaration = Name.t array * constr array * constr array
+type fixpoint = (int array * int) * rec_declaration
+type cofixpoint = int * rec_declaration
+
+type types = constr
+
+(*********************)
+(* Term constructors *)
+(*********************)
+
+(* Constructs a DeBrujin index with number n *)
+let rels =
+  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
+    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
+
+let mkRel n = if 0<n && n<=16 then rels.(n-1) else Rel n
+
+(* Construct a type *)
+let mkProp   = Sort Sorts.prop
+let mkSet    = Sort Sorts.set
+let mkType u = Sort (Sorts.Type u)
+let mkSort   = function
+  | Sorts.Prop Sorts.Null -> mkProp (* Easy sharing *)
+  | Sorts.Prop Sorts.Pos -> mkSet
+  | s -> Sort s
+
+(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
+(* (that means t2 is declared as the type of t1) *)
+let mkCast (t1,k2,t2) =
+  match t1 with
+  | Cast (c,k1, _) when (k1 == VMcast || k1 == NATIVEcast) && k1 == k2 -> Cast (c,k1,t2)
+  | _ -> Cast (t1,k2,t2)
+
+(* Constructs the product (x:t1)t2 *)
+let mkProd (x,t1,t2) = Prod (x,t1,t2)
+
+(* Constructs the abstraction [x:t1]t2 *)
+let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
+
+(* Constructs [x=c_1:t]c_2 *)
+let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
+
+(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
+(* We ensure applicative terms have at least one argument and the
+   function is not itself an applicative term *)
+let mkApp (f, a) =
+  if Int.equal (Array.length a) 0 then f else
+    match f with
+      | App (g, cl) -> App (g, Array.append cl a)
+      | _ -> App (f, a)
+
+let map_puniverses f (x,u) = (f x, u)
+let in_punivs a = (a, Univ.Instance.empty)
+
+(* Constructs a constant *)
+let mkConst c = Const (in_punivs c)
+let mkConstU c = Const c
+
+(* Constructs an applied projection *)
+let mkProj (p,c) = Proj (p,c)
+
+(* Constructs an existential variable *)
+let mkEvar e = Evar e
+
+(* Constructs the ith (co)inductive type of the block named kn *)
+let mkInd m = Ind (in_punivs m)
+let mkIndU m = Ind m
+
+(* Constructs the jth constructor of the ith (co)inductive type of the
+   block named kn. *)
+let mkConstruct c = Construct (in_punivs c)
+let mkConstructU c = Construct c
+let mkConstructUi ((ind,u),i) = Construct ((ind,i),u)
+
+(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
+
+(* If recindxs = [|i1,...in|]
+      funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkFix ((recindxs,i),(funnames,typarray,bodies))
+
+   constructs the ith function of the block
+
+    Fixpoint f1 [ctx1] : t1 := b1
+    with     f2 [ctx2] : t2 := b2
+    ...
+    with     fn [ctxn] : tn := bn.
+
+   where the length of the jth context is ij.
+*)
+
+let mkFix fix = Fix fix
+
+(* If funnames = [|f1,...fn|]
+      typarray = [|t1,...tn|]
+      bodies   = [|b1,...bn|]
+   then
+
+      mkCoFix (i,(funnames,typsarray,bodies))
+
+   constructs the ith function of the block
+
+    CoFixpoint f1 : t1 := b1
+    with       f2 : t2 := b2
+    ...
+    with       fn : tn := bn.
+*)
+let mkCoFix cofix= CoFix cofix
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta  n =  Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
+
+
+(************************************************************************)
+(*    kind_of_term = constructions as seen by the user                 *)
+(************************************************************************)
+
+(* User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+let kind c = c
+
+(****************************************************************************)
+(*              Functions to recur through subterms                         *)
+(****************************************************************************)
+
+(* [fold f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+let fold f acc c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> acc
+  | Cast (c,_,t) -> f (f acc c) t
+  | Prod (_,t,c) -> f (f acc t) c
+  | Lambda (_,t,c) -> f (f acc t) c
+  | LetIn (_,b,t,c) -> f (f (f acc b) t) c
+  | App (c,l) -> Array.fold_left f (f acc c) l
+  | Proj (p,c) -> f acc c
+  | Evar (_,l) -> Array.fold_left f acc l
+  | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
+  | Fix (_,(lna,tl,bl)) ->
+    Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
+  | CoFix (_,(lna,tl,bl)) ->
+    Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl
+
+(* [iter f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+let iter f c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,_,t) -> f c; f t
+  | Prod (_,t,c) -> f t; f c
+  | Lambda (_,t,c) -> f t; f c
+  | LetIn (_,b,t,c) -> f b; f t; f c
+  | App (c,l) -> f c; Array.iter f l
+  | Proj (p,c) -> f c
+  | Evar (_,l) -> Array.iter f l
+  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
+  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
+
+(* [iter_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let iter_with_binders g f n c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> ()
+  | Cast (c,_,t) -> f n c; f n t
+  | Prod (_,t,c) -> f n t; f (g n) c
+  | Lambda (_,t,c) -> f n t; f (g n) c
+  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
+  | App (c,l) -> f n c; CArray.Fun1.iter f n l
+  | Evar (_,l) -> CArray.Fun1.iter f n l
+  | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl
+  | Proj (p,c) -> f n c
+  | Fix (_,(_,tl,bl)) ->
+      CArray.Fun1.iter f n tl;
+      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+  | CoFix (_,(_,tl,bl)) ->
+      CArray.Fun1.iter f n tl;
+      CArray.Fun1.iter f (iterate g (Array.length tl) n) bl
+
+(* [map f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+let map f c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c
+  | Cast (b,k,t) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkCast (b', k, t')
+  | Prod (na,t,b) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkProd (na, t', b')
+  | Lambda (na,t,b) ->
+      let b' = f b in
+      let t' = f t in
+      if b'==b && t' == t then c
+      else mkLambda (na, t', b')
+  | LetIn (na,b,t,k) ->
+      let b' = f b in
+      let t' = f t in
+      let k' = f k in
+      if b'==b && t' == t && k'==k then c
+      else mkLetIn (na, b', t', k')
+  | App (b,l) ->
+      let b' = f b in
+      let l' = Array.smartmap f l in
+      if b'==b && l'==l then c
+      else mkApp (b', l')
+  | Proj (p,t) ->
+      let t' = f t in
+      if t' == t then c
+      else mkProj (p, t')
+  | Evar (e,l) ->
+      let l' = Array.smartmap f l in
+      if l'==l then c
+      else mkEvar (e, l')
+  | Case (ci,p,b,bl) ->
+      let b' = f b in
+      let p' = f p in
+      let bl' = Array.smartmap f bl in
+      if b'==b && p'==p && bl'==bl then c
+      else mkCase (ci, p', b', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let tl' = Array.smartmap f tl in
+      let bl' = Array.smartmap f bl in
+      if tl'==tl && bl'==bl then c
+      else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let tl' = Array.smartmap f tl in
+      let bl' = Array.smartmap f bl in
+      if tl'==tl && bl'==bl then c
+      else mkCoFix (ln,(lna,tl',bl'))
+
+(* Like {!map} but with an accumulator. *)
+
+let fold_map f accu c = match kind c with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> accu, c
+  | Cast (b,k,t) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkCast (b', k, t')
+  | Prod (na,t,b) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkProd (na, t', b')
+  | Lambda (na,t,b) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      if b'==b && t' == t then accu, c
+      else accu, mkLambda (na, t', b')
+  | LetIn (na,b,t,k) ->
+      let accu, b' = f accu b in
+      let accu, t' = f accu t in
+      let accu, k' = f accu k in
+      if b'==b && t' == t && k'==k then accu, c
+      else accu, mkLetIn (na, b', t', k')
+  | App (b,l) ->
+      let accu, b' = f accu b in
+      let accu, l' = Array.smartfoldmap f accu l in
+      if b'==b && l'==l then accu, c
+      else accu, mkApp (b', l')
+  | Proj (p,t) ->
+      let accu, t' = f accu t in
+      if t' == t then accu, c
+      else accu, mkProj (p, t')
+  | Evar (e,l) ->
+      let accu, l' = Array.smartfoldmap f accu l in
+      if l'==l then accu, c
+      else accu, mkEvar (e, l')
+  | Case (ci,p,b,bl) ->
+      let accu, b' = f accu b in
+      let accu, p' = f accu p in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if b'==b && p'==p && bl'==bl then accu, c
+      else accu, mkCase (ci, p', b', bl')
+  | Fix (ln,(lna,tl,bl)) ->
+      let accu, tl' = Array.smartfoldmap f accu tl in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if tl'==tl && bl'==bl then accu, c
+      else accu, mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+      let accu, tl' = Array.smartfoldmap f accu tl in
+      let accu, bl' = Array.smartfoldmap f accu bl in
+      if tl'==tl && bl'==bl then accu, c
+      else accu, mkCoFix (ln,(lna,tl',bl'))
+
+(* [map_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+let map_with_binders g f l c0 = match kind c0 with
+  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
+    | Construct _) -> c0
+  | Cast (c, k, t) ->
+    let c' = f l c in
+    let t' = f l t in
+    if c' == c && t' == t then c0
+    else mkCast (c', k, t')
+  | Prod (na, t, c) ->
+    let t' = f l t in
+    let c' = f (g l) c in
+    if t' == t && c' == c then c0
+    else mkProd (na, t', c')
+  | Lambda (na, t, c) ->
+    let t' = f l t in
+    let c' = f (g l) c in
+    if t' == t && c' == c then c0
+    else mkLambda (na, t', c')
+  | LetIn (na, b, t, c) ->
+    let b' = f l b in
+    let t' = f l t in
+    let c' = f (g l) c in
+    if b' == b && t' == t && c' == c then c0
+    else mkLetIn (na, b', t', c')
+  | App (c, al) ->
+    let c' = f l c in
+    let al' = CArray.Fun1.smartmap f l al in
+    if c' == c && al' == al then c0
+    else mkApp (c', al')
+  | Proj (p, t) ->
+    let t' = f l t in
+    if t' == t then c0
+    else mkProj (p, t')
+  | Evar (e, al) ->
+    let al' = CArray.Fun1.smartmap f l al in
+    if al' == al then c0
+    else mkEvar (e, al')
+  | Case (ci, p, c, bl) ->
+    let p' = f l p in
+    let c' = f l c in
+    let bl' = CArray.Fun1.smartmap f l bl in
+    if p' == p && c' == c && bl' == bl then c0
+    else mkCase (ci, p', c', bl')
+  | Fix (ln, (lna, tl, bl)) ->
+    let tl' = CArray.Fun1.smartmap f l tl in
+    let l' = iterate g (Array.length tl) l in
+    let bl' = CArray.Fun1.smartmap f l' bl in
+    if tl' == tl && bl' == bl then c0
+    else mkFix (ln,(lna,tl',bl'))
+  | CoFix(ln,(lna,tl,bl)) ->
+    let tl' = CArray.Fun1.smartmap f l tl in
+    let l' = iterate g (Array.length tl) l in
+    let bl' = CArray.Fun1.smartmap f l' bl in
+    mkCoFix (ln,(lna,tl',bl'))
+
+(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed, [u] to compare universe
+   instances and [s] to compare sorts; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_head_gen eq_universes eq_sorts f t1 t2 =
+  match kind t1, kind t2 with
+  | 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 -> eq_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
+  | App (Cast(c1, _, _),l1), _ -> f (mkApp (c1,l1)) t2
+  | _, App (Cast (c2, _, _),l2) -> f t1 (mkApp (c2,l2))
+  | App (c1,l1), App (c2,l2) ->
+    Int.equal (Array.length l1) (Array.length l2) &&
+      f c1 c2 && Array.equal f l1 l2
+  | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2
+  | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && f c1 c2
+  | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2
+  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2
+  | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,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)) ->
+      Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2
+  | _ -> false
+
+let compare_head = compare_head_gen (fun _ -> Univ.Instance.equal) Sorts.equal
+
+(* [compare_head_gen_leq u s sl eq leq c1 c2] compare [c1] and [c2] using [eq] to compare
+   the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity,
+   [u] to compare universe instances and [s] to compare sorts; Cast's,
+   application associativity, binders name and Cases annotations are
+   not taken into account *)
+
+let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 =
+  match kind t1, kind t2 with
+  | Rel n1, Rel n2 -> Int.equal n1 n2
+  | Meta m1, Meta m2 -> Int.equal m1 m2
+  | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0
+  | Sort s1, Sort s2 -> leq_sorts s1 s2
+  | Cast (c1,_,_), _ -> leq c1 t2
+  | _, Cast (c2,_,_) -> leq t1 c2
+  | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2
+  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2
+  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2
+  | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2
+  | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2))
+  | App (c1,l1), App (c2,l2) ->
+    Int.equal (Array.length l1) (Array.length l2) &&
+      eq c1 c2 && Array.equal eq l1 l2
+  | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq c1 c2
+  | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2
+  | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2
+  | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2
+  | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2
+  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+      eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2
+  | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+      Int.equal i1 i2 && Array.equal Int.equal ln1 ln2
+      && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2
+  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+      Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2
+  | _ -> false
+
+(*******************************)
+(*  alpha conversion functions *)
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let rec eq_constr m n =
+  (m == n) || compare_head_gen (fun _ -> Instance.equal) Sorts.equal eq_constr m n
+
+let equal m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+let eq_constr_univs univs m n =
+  if m == n then true
+  else 
+    let eq_universes _ = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = s1 == s2 || Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in compare_head_gen eq_universes eq_sorts eq_constr' m n
+
+let leq_constr_univs univs m n =
+  if m == n then true
+  else 
+    let eq_universes _ = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = s1 == s2 || 
+      Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let leq_sorts s1 s2 = s1 == s2 || 
+      Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+      compare_leq m n
+
+let eq_constr_univs_infer univs m n =
+  if m == n then true, Constraint.empty
+  else 
+    let cstrs = ref Constraint.empty in
+    let eq_universes strict = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else
+	    (cstrs := Univ.enforce_eq u1 u2 !cstrs;
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in
+      res, !cstrs
+
+let leq_constr_univs_infer univs m n =
+  if m == n then true, Constraint.empty
+  else 
+    let cstrs = ref Constraint.empty in
+    let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else (cstrs := Univ.enforce_eq u1 u2 !cstrs;
+		true)
+    in
+    let leq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else 
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_leq univs u1 u2 then true
+	  else
+	    (cstrs := Univ.enforce_leq u1 u2 !cstrs; 
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+    let res = compare_leq m n in
+      res, !cstrs
+
+let always_true _ _ = true
+
+let rec eq_constr_nounivs m n =
+  (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n
+
+(** We only use this function over blocks! *)
+let tag t = Obj.tag (Obj.repr t)
+
+let constr_ord_int f t1 t2 =
+  let (=?) f g i1 i2 j1 j2=
+    let c = f i1 i2 in
+    if Int.equal c 0 then g j1 j2 else c in
+  let (==?) fg h i1 i2 j1 j2 k1 k2=
+    let c=fg i1 i2 j1 j2 in
+    if Int.equal c 0 then h k1 k2 else c in
+  let fix_cmp (a1, i1) (a2, i2) =
+    ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2
+  in
+  match kind t1, kind t2 with
+    | Rel n1, Rel n2 -> Int.compare n1 n2
+    | Meta m1, Meta m2 -> Int.compare m1 m2
+    | Var id1, Var id2 -> Id.compare id1 id2
+    | Sort s1, Sort s2 -> Sorts.compare s1 s2
+    | Cast (c1,_,_), _ -> f c1 t2
+    | _, Cast (c2,_,_) -> f t1 c2
+    | Prod (_,t1,c1), Prod (_,t2,c2)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+        (f =? f) t1 t2 c1 c2
+    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+        ((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+    | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2
+    | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2))
+    | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2
+    | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2
+    | Evar (e1,l1), Evar (e2,l2) ->
+        (Evar.compare =? (Array.compare f)) e1 e2 l1 l2
+    | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2
+    | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2
+    | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2
+    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+        ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2
+    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+        ((fix_cmp =? (Array.compare f)) ==? (Array.compare f))
+        ln1 ln2 tl1 tl2 bl1 bl2
+    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+        ((Int.compare =? (Array.compare f)) ==? (Array.compare f))
+        ln1 ln2 tl1 tl2 bl1 bl2
+    | t1, t2 -> Int.compare (tag t1) (tag t2)
+
+let rec compare m n=
+  constr_ord_int compare m n
+
+(*******************)
+(*  hash-consing   *)
+(*******************)
+
+(* Hash-consing of [constr] does not use the module [Hashcons] because
+   [Hashcons] is not efficient on deep tree-like data
+   structures. Indeed, [Hashcons] is based the (very efficient)
+   generic hash function [Hashtbl.hash], which computes the hash key
+   through a depth bounded traversal of the data structure to be
+   hashed. As a consequence, for a deep [constr] like the natural
+   number 1000 (S (S (... (S O)))), the same hash is assigned to all
+   the sub [constr]s greater than the maximal depth handled by
+   [Hashtbl.hash]. This entails a huge number of collisions in the
+   hash table and leads to cubic hash-consing in this worst-case.
+
+   In order to compute a hash key that is independent of the data
+   structure depth while being constant-time, an incremental hashing
+   function must be devised. A standard implementation creates a cache
+   of the hashing function by decorating each node of the hash-consed
+   data structure with its hash key. In that case, the hash function
+   can deduce the hash key of a toplevel data structure by a local
+   computation based on the cache held on its substructures.
+   Unfortunately, this simple implementation introduces a space
+   overhead that is damageable for the hash-consing of small [constr]s
+   (the most common case). One can think of an heterogeneous
+   distribution of caches on smartly chosen nodes, but this is forbidden
+   by the use of generic equality in Coq source code. (Indeed, this forces
+   each [constr] to have a unique canonical representation.)
+
+   Given that hash-consing proceeds inductively, we can nonetheless
+   computes the hash key incrementally during hash-consing by changing
+   a little the signature of the hash-consing function: it now returns
+   both the hash-consed term and its hash key. This simple solution is
+   implemented in the following code: it does not introduce a space
+   overhead in [constr], that's why the efficiency is unchanged for
+   small [constr]s. Besides, it does handle deep [constr]s without
+   introducing an unreasonable number of collisions in the hash table.
+   Some benchmarks make us think that this implementation of
+   hash-consing is linear in the size of the hash-consed data
+   structure for our daily use of Coq.
+*)
+
+let array_eqeq 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 hasheq t1 t2 =
+  match t1, t2 with
+    | Rel n1, Rel n2 -> n1 == n2
+    | Meta m1, Meta m2 -> m1 == m2
+    | Var id1, Var id2 -> id1 == id2
+    | Sort s1, Sort s2 -> s1 == s2
+    | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 && k1 == k2 && t1 == t2
+    | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2
+    | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2
+    | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
+      n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2
+    | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2
+    | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2
+    | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2
+    | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2
+    | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> 
+      sp1 == sp2 && Int.equal i1 i2 && u1 == u2
+    | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) ->
+      sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && u1 == u2
+    | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+      ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2
+    | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) ->
+      Int.equal i1 i2
+      && Array.equal Int.equal ln1 ln2
+      && array_eqeq lna1 lna2
+      && array_eqeq tl1 tl2
+      && array_eqeq bl1 bl2
+    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+      Int.equal ln1 ln2
+      && array_eqeq lna1 lna2
+      && array_eqeq tl1 tl2
+      && array_eqeq bl1 bl2
+    | _ -> false
+
+(** Note that the following Make has the side effect of creating
+    once and for all the table we'll use for hash-consing all constr *)
+
+module HashsetTerm =
+  Hashset.Make(struct type t = constr let equal = hasheq end)
+
+module HashsetTermArray =
+  Hashset.Make(struct type t = constr array let equal = array_eqeq end)
+
+let term_table = HashsetTerm.create 19991
+(* The associative table to hashcons terms. *)
+
+let term_array_table = HashsetTermArray.create 4999
+(* The associative table to hashcons term arrays. *)
+
+open Hashset.Combine
+
+let hash_cast_kind = function
+| VMcast -> 0
+| NATIVEcast -> 1
+| DEFAULTcast -> 2
+| REVERTcast -> 3
+
+let sh_instance = Univ.Instance.share
+
+(* [hashcons hash_consing_functions constr] computes an hash-consed
+   representation for [constr] using [hash_consing_functions] on
+   leaves. *)
+let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
+  let rec hash_term t =
+    match t with
+      | Var i ->
+	(Var (sh_id i), combinesmall 1 (Id.hash i))
+      | Sort s ->
+	(Sort (sh_sort s), combinesmall 2 (Sorts.hash s))
+      | Cast (c, k, t) ->
+	let c, hc = sh_rec c in
+	let t, ht = sh_rec t in
+	(Cast (c, k, t), combinesmall 3 (combine3 hc (hash_cast_kind k) ht))
+      | Prod (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (Name.hash na) ht hc))
+      | Lambda (na,t,c) ->
+	let t, ht = sh_rec t
+	and c, hc = sh_rec c in
+	(Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Name.hash na) ht hc))
+      | LetIn (na,b,t,c) ->
+	let b, hb = sh_rec b in
+	let t, ht = sh_rec t in
+	let c, hc = sh_rec c in
+	(LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Name.hash na) hb ht hc))
+      | App (c,l) ->
+	let c, hc = sh_rec c in
+	let l, hl = hash_term_array l in
+	(App (c,l), combinesmall 7 (combine hl hc))
+      | Evar (e,l) ->
+	let l, hl = hash_term_array l in
+	(Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl))
+      | Proj (p,c) ->
+        let c, hc = sh_rec c in
+	let p' = Projection.hcons p in
+	  (Proj (p', c), combinesmall 17 (combine (Projection.hash p') hc))
+      | Const (c,u) ->
+	let c' = sh_con c in
+	let u', hu = sh_instance u in
+	(Const (c', u'), combinesmall 9 (combine (Constant.hash c) hu))
+      | Ind ((kn,i) as ind,u) ->
+	let u', hu = sh_instance u in
+	(Ind (sh_ind ind, u'), 
+	 combinesmall 10 (combine (ind_hash ind) hu))
+      | Construct ((((kn,i),j) as c,u))->
+	let u', hu = sh_instance u in
+	(Construct (sh_construct c, u'),
+	 combinesmall 11 (combine (constructor_hash c) hu))
+      | Case (ci,p,c,bl) ->
+	let p, hp = sh_rec p
+	and c, hc = sh_rec c in
+	let bl,hbl = hash_term_array bl in
+	let hbl = combine (combine hc hp) hbl in
+	(Case (sh_ci ci, p, c, bl), combinesmall 12 hbl)
+      | Fix (ln,(lna,tl,bl)) ->
+	let bl,hbl = hash_term_array bl in
+	let tl,htl = hash_term_array tl in
+        let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in
+        let fold accu na = combine (Name.hash na) accu in
+        let hna = Array.fold_left fold 0 lna in
+        let h = combine3 hna hbl htl in
+	(Fix (ln,(lna,tl,bl)), combinesmall 13 h)
+      | CoFix(ln,(lna,tl,bl)) ->
+	let bl,hbl = hash_term_array bl in
+	let tl,htl = hash_term_array tl in
+        let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in
+        let fold accu na = combine (Name.hash na) accu in
+        let hna = Array.fold_left fold 0 lna in
+        let h = combine3 hna hbl htl in
+	(CoFix (ln,(lna,tl,bl)), combinesmall 14 h)
+      | Meta n ->
+	(t, combinesmall 15 n)
+      | Rel n ->
+	(t, combinesmall 16 n)
+
+  and sh_rec t =
+    let (y, h) = hash_term t in
+    (* [h] must be positive. *)
+    let h = h land 0x3FFFFFFF in
+    (HashsetTerm.repr h y term_table, h)
+
+  (* Note : During hash-cons of arrays, we modify them *in place* *)
+
+  and hash_term_array t =
+    let accu = ref 0 in
+    for i = 0 to Array.length t - 1 do
+      let x, h = sh_rec (Array.unsafe_get t i) in
+      accu := combine !accu h;
+      Array.unsafe_set t i x
+    done;
+    (* [h] must be positive. *)
+    let h = !accu land 0x3FFFFFFF in
+    (HashsetTermArray.repr h t term_array_table, h)
+
+  in
+  (* Make sure our statically allocated Rels (1 to 16) are considered
+     as canonical, and hence hash-consed to themselves *)
+  ignore (hash_term_array rels);
+
+  fun t -> fst (sh_rec t)
+
+(* Exported hashing fonction on constr, used mainly in plugins.
+   Appears to have slight differences from [snd (hash_term t)] above ? *)
+
+let rec hash t =
+  match kind t with
+    | Var i -> combinesmall 1 (Id.hash i)
+    | Sort s -> combinesmall 2 (Sorts.hash s)
+    | Cast (c, k, t) ->
+      let hc = hash c in
+      let ht = hash t in
+      combinesmall 3 (combine3 hc (hash_cast_kind k) ht)
+    | Prod (_, t, c) -> combinesmall 4 (combine (hash t) (hash c))
+    | Lambda (_, t, c) -> combinesmall 5 (combine (hash t) (hash c))
+    | LetIn (_, b, t, c) ->
+      combinesmall 6 (combine3 (hash b) (hash t) (hash c))
+    | App (Cast(c, _, _),l) -> hash (mkApp (c,l))
+    | App (c,l) ->
+      combinesmall 7 (combine (hash_term_array l) (hash c))
+    | Proj (p,c) ->
+      combinesmall 17 (combine (Projection.hash p) (hash c))
+    | Evar (e,l) ->
+      combinesmall 8 (combine (Evar.hash e) (hash_term_array l))
+    | Const (c,u) ->
+      combinesmall 9 (combine (Constant.hash c) (Instance.hash u))
+    | Ind (ind,u) ->
+      combinesmall 10 (combine (ind_hash ind) (Instance.hash u))
+    | Construct (c,u) ->
+      combinesmall 11 (combine (constructor_hash c) (Instance.hash u))
+    | Case (_ , p, c, bl) ->
+      combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl))
+    | Fix (ln ,(_, tl, bl)) ->
+      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
+    | CoFix(ln, (_, tl, bl)) ->
+       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
+    | Meta n -> combinesmall 15 n
+    | Rel n -> combinesmall 16 n
+
+and hash_term_array t =
+  Array.fold_left (fun acc t -> combine (hash t) acc) 0 t
+
+module CaseinfoHash =
+struct
+  type t = case_info
+  type u = inductive -> inductive
+  let hashcons hind ci = { ci with ci_ind = hind ci.ci_ind }
+  let pp_info_equal info1 info2 =
+    List.equal (==) info1.ind_tags info2.ind_tags &&
+    Array.equal (List.equal (==)) info1.cstr_tags info2.cstr_tags &&
+    info1.style == info2.style
+  let equal ci ci' =
+    ci.ci_ind == ci'.ci_ind &&
+    Int.equal ci.ci_npar ci'.ci_npar &&
+    Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *)
+    Array.equal Int.equal ci.ci_cstr_nargs ci'.ci_cstr_nargs && (* we use [Array.equal] on purpose *)
+    pp_info_equal ci.ci_pp_info ci'.ci_pp_info  (* we use (=) on purpose *)
+  open Hashset.Combine
+  let hash_bool b = if b then 0 else 1
+  let hash_bool_list = List.fold_left (fun n b -> combine n (hash_bool b))
+  let hash_pp_info info =
+    let h1 = match info.style with
+    | LetStyle -> 0
+    | IfStyle -> 1
+    | LetPatternStyle -> 2
+    | MatchStyle -> 3
+    | RegularStyle -> 4 in
+    let h2 = hash_bool_list 0 info.ind_tags in
+    let h3 = Array.fold_left hash_bool_list 0 info.cstr_tags in
+    combine3 h1 h2 h3
+  let hash ci =
+    let h1 = ind_hash ci.ci_ind in
+    let h2 = Int.hash ci.ci_npar in
+    let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in
+    let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in
+    let h5 = hash_pp_info ci.ci_pp_info in
+    combine5 h1 h2 h3 h4 h5
+end
+
+module Hcaseinfo = Hashcons.Make(CaseinfoHash)
+
+let case_info_hash = CaseinfoHash.hash
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      open Sorts
+
+      type t = Sorts.t
+      type u = universe -> universe
+      let hashcons huniv = function
+          Prop c -> Prop c
+        | Type u -> Type (huniv u)
+      let equal s1 s2 =
+        s1 == s2 ||
+	  match (s1,s2) with
+            (Prop c1, Prop c2) -> c1 == c2
+          | (Type u1, Type u2) -> u1 == u2
+          |_ -> false
+      let hash = function
+	| Prop Null -> 0 | Prop Pos -> 1
+	| Type u -> 2 + Universe.hash u
+    end)
+
+(* let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ *)
+let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind
+
+let hcons =
+  hashcons
+    (Sorts.hcons,
+     hcons_caseinfo,
+     hcons_construct,
+     hcons_ind,
+     hcons_con,
+     Name.hcons,
+     Id.hcons)
+
+(* let hcons_types = hcons_constr *)
+
+(*******)
+(* Type of abstract machine values *)
+(** FIXME: nothing to do there *)
+type values
diff --git a/kernel/constr.mli b/kernel/constr.mli
new file mode 100644
index 00000000..5d11511b
--- /dev/null
+++ b/kernel/constr.mli
@@ -0,0 +1,313 @@
+(************************************************************************)
+(*  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 Names
+
+(** {6 Value under universe substitution } *)
+type 'a puniverses = 'a Univ.puniverses
+
+(** {6 Simply type aliases } *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+(** {6 Existential variables } *)
+type existential_key = Evar.t
+
+(** {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; (** tell whether letin or lambda in the signature of each constructor *)
+    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 *)
+  }
+
+(** {6 The type of constructions } *)
+
+type t
+type constr = t
+(** [types] is the same as [constr] but is intended to be used for
+   documentation to indicate that such or such function specifically works
+   with {e types} (i.e. terms of type a sort).
+   (Rem:plurial form since [type] is a reserved ML keyword) *)
+
+type types = constr
+
+(** {5 Functions for dealing with constr terms. }
+  The following functions are intended to simplify and to uniform the
+  manipulation of terms. Some of these functions may be overlapped with
+  previous ones. *)
+
+(** {6 Term constructors. } *)
+
+(** Constructs a DeBrujin index (DB indices begin at 1) *)
+val mkRel : int -> constr
+
+(** Constructs a Variable *)
+val mkVar : Id.t -> constr
+
+(** Constructs an patvar named "?n" *)
+val mkMeta : metavariable -> constr
+
+(** Constructs an existential variable *)
+type existential = existential_key * constr array
+val mkEvar : existential -> constr
+
+(** Construct a sort *)
+val mkSort : Sorts.t -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+
+
+(** This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast
+
+(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
+   type t{_ 2} (that means t2 is declared as the type of t1). *)
+val mkCast : constr * cast_kind * constr -> constr
+
+(** Constructs the product [(x:t1)t2] *)
+val mkProd : Name.t * types * types -> types
+
+(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
+val mkLambda : Name.t * types * constr -> constr
+
+(** Constructs the product [let x = t1 : t2 in t3] *)
+val mkLetIn : Name.t * constr * types * constr -> constr
+
+(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+   {% $(f~t_1~\dots~t_n)$ %}. *)
+val mkApp : constr * constr array -> constr
+
+val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses
+
+(** Constructs a constant *)
+val mkConst : constant -> constr
+val mkConstU : pconstant -> constr
+
+(** Constructs a projection application *)
+val mkProj : (projection * constr) -> constr
+
+(** Inductive types *)
+
+(** Constructs the ith (co)inductive type of the block named kn *)
+val mkInd : inductive -> constr
+val mkIndU : pinductive -> constr
+
+(** Constructs the jth constructor of the ith (co)inductive type of the
+   block named kn. *)
+val mkConstruct : constructor -> constr
+val mkConstructU : pconstructor -> constr
+val mkConstructUi : pinductive * int -> constr
+
+(** Constructs a destructor of inductive type.
+    
+    [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] 
+    presented as describe in [ci].
+
+    [p] stucture is [fun args x -> "return clause"]
+
+    [ac]{^ ith} element is ith constructor case presented as 
+    {e lambda construct_args (without params). case_term } *)
+val mkCase : case_info * constr * constr * constr array -> constr
+
+(** If [recindxs = [|i1,...in|]]
+      [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [|b1,.....bn|]]
+   then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
+   constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
+
+    [Fixpoint f1 [ctx1] = b1
+     with     f2 [ctx2] = b2
+     ...
+     with     fn [ctxn] = bn.]
+
+   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
+*)
+type rec_declaration = Name.t array * types array * constr array
+type fixpoint = (int array * int) * rec_declaration
+val mkFix : fixpoint -> constr
+
+(** If [funnames = [|f1,.....fn|]]
+      [typarray = [|t1,...tn|]]
+      [bodies   = [b1,.....bn]] 
+   then [mkCoFix (i, (funnames, typarray, bodies))]
+   constructs the ith function of the block
+   
+    [CoFixpoint f1 = b1
+     with       f2 = b2
+     ...
+     with       fn = bn.]
+ *)
+type cofixpoint = int * rec_declaration
+val mkCoFix : cofixpoint -> constr
+
+
+(** {6 Concrete type for making pattern-matching. } *)
+
+(** [constr array] is an instance matching definitional [named_context] in
+   the same order (i.e. last argument first) *)
+type 'constr pexistential = existential_key * 'constr array
+type ('constr, 'types) prec_declaration =
+    Name.t array * 'types array * 'constr array
+type ('constr, 'types) pfixpoint =
+    (int array * int) * ('constr, 'types) prec_declaration
+type ('constr, 'types) pcofixpoint =
+    int * ('constr, 'types) prec_declaration
+
+type ('constr, 'types) kind_of_term =
+  | Rel       of int
+  | Var       of Id.t
+  | Meta      of metavariable
+  | Evar      of 'constr pexistential
+  | Sort      of Sorts.t
+  | Cast      of 'constr * cast_kind * 'types
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
+  | App       of 'constr * 'constr array
+  | Const     of constant puniverses
+  | Ind       of inductive puniverses
+  | Construct of constructor puniverses
+  | Case      of case_info * 'constr * 'constr * 'constr array
+  | Fix       of ('constr, 'types) pfixpoint
+  | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
+
+(** User view of [constr]. For [App], it is ensured there is at
+   least one argument and the function is not itself an applicative
+   term *)
+
+val kind : constr -> (constr, types) kind_of_term
+
+(** [equal a b] is true if [a] equals [b] modulo alpha, casts,
+   and application grouping *)
+val equal : constr -> constr -> bool
+
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [u]. *)
+val eq_constr_univs : constr Univ.check_function
+
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe inequalities in [u]. *)
+val leq_constr_univs : constr Univ.check_function
+
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe equalities in [u]. *)
+val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe inequalities in [u]. *)
+val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool Univ.constrained
+
+(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and ignoring universe instances. *)
+val eq_constr_nounivs : constr -> constr -> bool
+
+(** Total ordering compatible with [equal] *)
+val compare : constr -> constr -> int
+
+(** {6 Functionals working on the immediate subterm of a construction } *)
+
+(** [fold f acc c] folds [f] on the immediate subterms of [c]
+   starting from [acc] and proceeding from left to right according to
+   the usual representation of the constructions; it is not recursive *)
+
+val fold : ('a -> constr -> 'a) -> 'a -> constr -> 'a
+
+(** [map f c] maps [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val map : (constr -> constr) -> constr -> constr
+
+(** Like {!map}, but also has an additional accumulator. *)
+
+val fold_map : ('a -> constr -> 'a * constr) -> 'a -> constr -> 'a * constr
+
+(** [map_with_binders g f n c] maps [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val map_with_binders :
+  ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+
+(** [iter f c] iters [f] on the immediate subterms of [c]; it is
+   not recursive and the order with which subterms are processed is
+   not specified *)
+
+val iter : (constr -> unit) -> constr -> unit
+
+(** [iter_with_binders g f n c] iters [f n] on the immediate
+   subterms of [c]; it carries an extra data [n] (typically a lift
+   index) which is processed by [g] (which typically add 1 to [n]) at
+   each binder traversal; it is not recursive and the order with which
+   subterms are processed is not specified *)
+
+val iter_with_binders :
+  ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
+
+(** [compare_head f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
+   name and Cases annotations are not taken into account *)
+
+val compare_head : (constr -> constr -> bool) -> constr -> constr -> bool
+
+(** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare
+   the immediate subterms of [c1] of [c2] if needed, [u] to compare universe
+   instances (the first boolean tells if they belong to a constant), [s] to 
+   compare sorts; Cast's, binders name and Cases annotations are not taken 
+    into account *)
+
+val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (constr -> constr -> bool) ->
+  constr -> constr -> bool
+
+(** [compare_head_gen_leq u s sle f fle c1 c2] compare [c1] and [c2]
+    using [f] to compare the immediate subterms of [c1] of [c2] for
+    conversion, [fle] for cumulativity, [u] to compare universe
+    instances (the first boolean tells if they belong to a constant),
+    [s] to compare sorts for equality and [sle] for subtyping; Cast's,
+    binders name and Cases annotations are not taken into account *)
+
+val compare_head_gen_leq : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (Sorts.t -> Sorts.t -> bool) ->
+  (constr -> constr -> bool) ->
+  (constr -> constr -> bool) ->
+  constr -> constr -> bool
+  
+(** {6 Hashconsing} *)
+
+val hash : constr -> int
+val case_info_hash : case_info -> int
+
+(*********************************************************************)
+
+val hcons : constr -> constr
+
+(**************************************)
+
+type values
diff --git a/kernel/context.ml b/kernel/context.ml
new file mode 100644
index 00000000..796f06d3
--- /dev/null
+++ b/kernel/context.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(*  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 by Jean-Christophe Filliâtre out of names.ml as part of the
+   rebuilding of Coq around a purely functional abstract type-checker,
+   Aug 1999 *)
+(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
+   Herbelin and Bruno Barras *)
+
+(* This file defines types and combinators regarding indexes-based and
+   names-based contexts *)
+
+open Util
+open Names
+
+(***************************************************************************)
+(*     Type of assumptions                                                 *)
+(***************************************************************************)
+
+type named_declaration = Id.t * Constr.t option * Constr.t
+type named_list_declaration = Id.t list * Constr.t option * Constr.t
+type rel_declaration = Name.t * Constr.t option * Constr.t
+
+let map_named_declaration_skel f (id, (v : Constr.t option), ty) =
+  (id, Option.map f v, f ty)
+let map_named_list_declaration = map_named_declaration_skel
+let map_named_declaration = map_named_declaration_skel
+
+let map_rel_declaration = map_named_declaration
+
+let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
+let fold_rel_declaration = fold_named_declaration
+
+let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
+let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
+
+let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
+let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
+
+let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+  Id.equal i1 i2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
+
+let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
+  Name.equal n1 n2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
+
+(***************************************************************************)
+(*     Type of local contexts (telescopes)                                 *)
+(***************************************************************************)
+
+(*s Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices (to represent bound variables) *)
+
+type rel_context = rel_declaration list
+
+let empty_rel_context = []
+
+let add_rel_decl d ctxt = d::ctxt
+
+let rec lookup_rel n sign =
+  match n, sign with
+  | 1, decl :: _ -> decl
+  | n, _ :: sign -> lookup_rel (n-1) sign
+  | _, []        -> raise Not_found
+
+let rel_context_length = List.length
+
+let rel_context_nhyps hyps =
+  let rec nhyps acc = function
+    | [] -> acc
+    | (_,None,_)::hyps -> nhyps (1+acc) hyps
+    | (_,Some _,_)::hyps -> nhyps acc hyps in
+  nhyps 0 hyps
+
+let rel_context_tags ctx =
+  let rec aux l = function
+  | [] -> l
+  | (_,Some _,_)::ctx -> aux (true::l) ctx
+  | (_,None,_)::ctx -> aux (false::l) ctx
+  in aux [] ctx
+
+(*s Signatures of named hypotheses. Used for section variables and
+    goal assumptions. *)
+
+type named_context = named_declaration list
+type named_list_context = named_list_declaration list
+
+let empty_named_context = []
+
+let add_named_decl d sign = d::sign
+
+let rec lookup_named id = function
+  | (id',_,_ as decl) :: _ when Id.equal id id' -> decl
+  | _ :: sign -> lookup_named id sign
+  | [] -> raise Not_found
+
+let named_context_length = List.length
+let named_context_equal = List.equal eq_named_declaration
+
+let vars_of_named_context ctx =
+  List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty ctx
+
+let instance_from_named_context sign =
+  let filter = function
+  | (id, None, _) -> Some (Constr.mkVar id)
+  | (_, Some _, _) -> None
+  in
+  List.map_filter filter sign
+
+let fold_named_context f l ~init = List.fold_right f l init
+let fold_named_list_context f l ~init = List.fold_right f l init
+let fold_named_context_reverse f ~init l = List.fold_left f init l
+
+(*s Signatures of ordered section variables *)
+type section_context = named_context
+
+let fold_rel_context f l ~init:x = List.fold_right f l x
+let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
+
+let map_context f l =
+  let map_decl (n, body_o, typ as decl) =
+    let body_o' = Option.smartmap f body_o in
+    let typ' = f typ in
+      if body_o' == body_o && typ' == typ then decl else
+        (n, body_o', typ')
+  in
+    List.smartmap map_decl l
+
+let map_rel_context = map_context
+let map_named_context = map_context
+
+let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
+let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
diff --git a/kernel/context.mli b/kernel/context.mli
new file mode 100644
index 00000000..5279aefb
--- /dev/null
+++ b/kernel/context.mli
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  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 Names
+
+(** TODO: cleanup *)
+
+(** {6 Declarations} *)
+(** A {e declaration} has the form [(name,body,type)]. It is either an
+    {e assumption} if [body=None] or a {e definition} if
+    [body=Some actualbody]. It is referred by {e name} if [na] is an
+    identifier or by {e relative index} if [na] is not an identifier
+    (in the latter case, [na] is of type [name] but just for printing
+    purpose) *)
+
+type named_declaration = Id.t * Constr.t option * Constr.t
+type named_list_declaration = Id.t list * Constr.t option * Constr.t
+type rel_declaration = Name.t * Constr.t option * Constr.t
+
+val map_named_declaration :
+  (Constr.t -> Constr.t) -> named_declaration -> named_declaration
+val map_named_list_declaration :
+  (Constr.t -> Constr.t) -> named_list_declaration -> named_list_declaration
+val map_rel_declaration :
+  (Constr.t -> Constr.t) -> rel_declaration -> rel_declaration
+
+val fold_named_declaration :
+  (Constr.t -> 'a -> 'a) -> named_declaration -> 'a -> 'a
+val fold_rel_declaration :
+  (Constr.t -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
+
+val exists_named_declaration :
+  (Constr.t -> bool) -> named_declaration -> bool
+val exists_rel_declaration :
+  (Constr.t -> bool) -> rel_declaration -> bool
+
+val for_all_named_declaration :
+  (Constr.t -> bool) -> named_declaration -> bool
+val for_all_rel_declaration :
+  (Constr.t -> bool) -> rel_declaration -> bool
+
+val eq_named_declaration :
+  named_declaration -> named_declaration -> bool
+
+val eq_rel_declaration :
+    rel_declaration -> rel_declaration -> bool
+
+(** {6 Signatures of ordered named declarations } *)
+
+type named_context = named_declaration list
+type section_context = named_context
+type named_list_context = named_list_declaration list
+type rel_context = rel_declaration list
+(** In [rel_context], more recent declaration is on top *)
+
+val empty_named_context : named_context
+val add_named_decl : named_declaration -> named_context -> named_context
+val vars_of_named_context : named_context -> Id.Set.t
+
+val lookup_named : Id.t -> named_context -> named_declaration
+
+(** number of declarations *)
+val named_context_length : named_context -> int
+
+(** named context equality *)
+val named_context_equal : named_context -> named_context -> bool
+
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
+val fold_named_context :
+  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
+
+val fold_named_list_context :
+  (named_list_declaration -> 'a -> 'a) -> named_list_context -> init:'a -> 'a
+
+(** newer declarations first *)
+val fold_named_context_reverse :
+  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
+
+(** {6 Section-related auxiliary functions } *)
+val instance_from_named_context : named_context -> Constr.t list
+
+(** {6 ... } *)
+(** Signatures of ordered optionally named variables, intended to be
+   accessed by de Bruijn indices *)
+
+(** {6 Recurrence on [rel_context]: older declarations processed first } *)
+val fold_rel_context :
+  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
+
+(** newer declarations first *)
+val fold_rel_context_reverse :
+  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
+
+(** {6 Map function of [rel_context] } *)
+val map_rel_context : (Constr.t -> Constr.t) -> rel_context -> rel_context
+
+(** {6 Map function of [named_context] } *)
+val map_named_context : (Constr.t -> Constr.t) -> named_context -> named_context
+
+(** {6 Map function of [rel_context] } *)
+val iter_rel_context : (Constr.t -> unit) -> rel_context -> unit
+
+(** {6 Map function of [named_context] } *)
+val iter_named_context : (Constr.t -> unit) -> named_context -> unit
+
+(** {6 Contexts of declarations referred to by de Bruijn indices } *)
+
+val empty_rel_context : rel_context
+val add_rel_decl : rel_declaration -> rel_context -> rel_context
+
+val lookup_rel : int -> rel_context -> rel_declaration
+(** Size of the [rel_context] including LetIns *)
+val rel_context_length : rel_context -> int
+(** Size of the [rel_context] without LetIns *)
+val rel_context_nhyps : rel_context -> int
+(** Indicates whether a LetIn or a Lambda, starting from oldest declaration *)
+val rel_context_tags : rel_context -> bool list
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 26b7a397..3b01538b 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.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        *)
@@ -18,52 +18,76 @@ open Names
  *)
 type level = Expand | Level of int | Opaque
 let default = Level 0
+let is_default = function
+| Level 0 -> true
+| _ -> false
 let transparent = default
+let is_transparent = function
+| Level 0 -> true
+| _ -> false
 
-type oracle = level Idmap.t * level Cmap.t
+type oracle = {
+  var_opacity : level Id.Map.t;
+  cst_opacity : level Cmap.t;
+  var_trstate : Id.Pred.t;
+  cst_trstate : Cpred.t;
+}
 
-let var_opacity = ref Idmap.empty
-let cst_opacity = ref Cmap.empty
+let empty = {
+  var_opacity = Id.Map.empty;
+  cst_opacity = Cmap.empty;
+  var_trstate = Id.Pred.full;
+  cst_trstate = Cpred.full;
+}
 
-let get_strategy = function
+let get_strategy { var_opacity; cst_opacity } f = function
   | VarKey id ->
-      (try Idmap.find id !var_opacity
+      (try Id.Map.find id var_opacity
       with Not_found -> default)
   | ConstKey c ->
-      (try Cmap.find c !cst_opacity
+      (try Cmap.find (f c) cst_opacity
       with Not_found -> default)
   | RelKey _ -> Expand
 
-let set_strategy k l =
+let set_strategy ({ var_opacity; cst_opacity } as oracle) k l =
   match k with
   | VarKey id ->
-      var_opacity :=
-      if l=default then Idmap.remove id !var_opacity
-      else Idmap.add id l !var_opacity
+    let var_opacity =
+      if is_default l then Id.Map.remove id var_opacity
+      else Id.Map.add id l var_opacity
+    in
+    let var_trstate = match l with
+    | Opaque -> Id.Pred.remove id oracle.var_trstate
+    | _ -> Id.Pred.add id oracle.var_trstate
+    in
+    { oracle with var_opacity; var_trstate; }
   | ConstKey c ->
-      cst_opacity :=
-      if l=default then Cmap.remove c !cst_opacity
-      else Cmap.add c l !cst_opacity
-  | RelKey _ -> Util.error "set_strategy: RelKey"
+    let cst_opacity =
+      if is_default l then Cmap.remove c cst_opacity
+      else Cmap.add c l cst_opacity
+    in
+    let cst_trstate = match l with
+    | Opaque -> Cpred.remove c oracle.cst_trstate
+    | _ -> Cpred.add c oracle.cst_trstate
+    in
+    { oracle with cst_opacity; cst_trstate; }
+  | RelKey _ -> Errors.error "set_strategy: RelKey"
 
-let get_transp_state () =
-  (Idmap.fold
-    (fun id l ts -> if  l=Opaque then Idpred.remove id ts else ts)
-    !var_opacity Idpred.full,
-   Cmap.fold
-    (fun c l ts -> if  l=Opaque then Cpred.remove c ts else ts)
-    !cst_opacity Cpred.full)
+let fold_strategy f { var_opacity; cst_opacity; } accu =
+  let fvar id lvl accu = f (VarKey id) lvl accu in
+  let fcst cst lvl accu = f (ConstKey cst) lvl accu in
+  let accu = Id.Map.fold fvar var_opacity accu in
+  Cmap.fold fcst cst_opacity accu
+
+let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate)
 
 (* Unfold the first constant only if it is "more transparent" than the
    second one. In case of tie, expand the second one. *)
-let oracle_order l2r k1 k2 =
-  match get_strategy k1, get_strategy k2 with
+let oracle_order f o l2r k1 k2 =
+  match get_strategy o f k1, get_strategy o f k2 with
     | Expand, _ -> true
     | Level n1, Opaque -> true
     | Level n1, Level n2 -> n1 < n2
     | _ -> l2r (* use recommended default *)
 
-(* summary operations *)
-let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
-let freeze () = (!var_opacity, !cst_opacity)
-let unfreeze (vo,co) = (cst_opacity := co; var_opacity := vo)
+let get_strategy o = get_strategy o (fun x -> x)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index c8cfdf62..62991222 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.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,11 +8,16 @@
 
 open Names
 
+type oracle
+
+val empty : oracle
+
 (** Order on section paths for unfolding.
    If [oracle_order kn1 kn2] is true, then unfold kn1 first.
    Note: the oracle does not introduce incompleteness, it only
    tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
+val oracle_order : ('a -> constant) -> oracle -> bool -> 
+  'a tableKey -> 'a tableKey -> bool
 
 (** Priority for the expansion of constant in the conversion test.
  * Higher levels means that the expansion is less prioritary.
@@ -22,17 +27,17 @@ val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
 type level = Expand | Level of int | Opaque
 val transparent : level
 
-val get_strategy : 'a tableKey -> level
+(** Check whether a level is transparent *)
+val is_transparent : level -> bool
+
+val get_strategy : oracle -> constant tableKey -> level
 
 (** Sets the level of a constant.
  * Level of RelKey constant cannot be set. *)
-val set_strategy : 'a tableKey -> level -> unit
+val set_strategy : oracle -> constant tableKey -> level -> oracle
 
-val get_transp_state : unit -> transparent_state
+(** Fold over the non-transparent levels of the oracle. Order unspecified. *)
+val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a
+
+val get_transp_state : oracle -> transparent_state
 
-(****************************
-   Summary operations *)
-type oracle
-val init     : unit -> unit
-val freeze   : unit -> oracle
-val unfreeze : oracle -> unit
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index 9ec99f99..be71bd7b 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.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        *)
@@ -13,22 +13,19 @@
 (* This module implements kernel-level discharching of local
    declarations over global constants and inductive types *)
 
-open Pp
+open Errors
 open Util
 open Names
 open Term
-open Sign
 open Declarations
 open Environ
-open Reduction
+open Univ
 
 (*s Cooking the constants. *)
 
-type work_list = identifier array Cmap.t * identifier array Mindmap.t
-
-let pop_dirpath p = match repr_dirpath p with
-  | [] -> anomaly "dirpath_prefix: empty dirpath"
-  | _::l -> make_dirpath l
+let pop_dirpath p = match DirPath.repr p with
+  | [] -> anomaly ~label:"dirpath_prefix" (Pp.str "empty dirpath")
+  | _::l -> DirPath.make l
 
 let pop_mind kn =
   let (mp,dir,l) = Names.repr_mind kn in
@@ -43,67 +40,104 @@ type my_global_reference =
   | IndRef of inductive
   | ConstructRef of constructor
 
-let cache = (Hashtbl.create 13 : (my_global_reference, constr) Hashtbl.t)
-
-let clear_cooking_sharing () = Hashtbl.clear cache
-
-let share r (cstl,knl) =
-  try Hashtbl.find cache r
+module RefHash =
+struct
+  type t = my_global_reference
+  let equal gr1 gr2 = match gr1, gr2 with
+  | ConstRef c1, ConstRef c2 -> Constant.CanOrd.equal c1 c2
+  | IndRef i1, IndRef i2 -> eq_ind i1 i2
+  | ConstructRef c1, ConstructRef c2 -> eq_constructor c1 c2
+  | _ -> false
+  open Hashset.Combine
+  let hash = function
+  | ConstRef c -> combinesmall 1 (Constant.hash c)
+  | IndRef i -> combinesmall 2 (ind_hash i)
+  | ConstructRef c -> combinesmall 3 (constructor_hash c)
+end
+
+module RefTable = Hashtbl.Make(RefHash)
+
+let instantiate_my_gr gr u =
+  match gr with
+  | ConstRef c -> mkConstU (c, u)
+  | IndRef i -> mkIndU (i, u)
+  | ConstructRef c -> mkConstructU (c, u)
+
+let share cache r (cstl,knl) =
+  try RefTable.find cache r
   with Not_found ->
-  let f,l =
+  let f,(u,l) =
     match r with
     | IndRef (kn,i) ->
-	mkInd (pop_mind kn,i), Mindmap.find kn knl
+	IndRef (pop_mind kn,i), Mindmap.find kn knl
     | ConstructRef ((kn,i),j) ->
-	mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl
+	ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl
     | ConstRef cst ->
-	mkConst (pop_con cst), Cmap.find cst cstl in
-  let c = mkApp (f, Array.map mkVar l) in
-  Hashtbl.add cache r c;
-  (* has raised Not_found if not in work_list *)
+	ConstRef (pop_con cst), Cmap.find cst cstl in
+  let c = (f, (u, Array.map mkVar l)) in
+  RefTable.add cache r c;
   c
 
-let update_case_info ci modlist =
+let share_univs cache r u l =
+  let r', (u', args) = share cache r l in
+    mkApp (instantiate_my_gr r' (Instance.append u' u), args)
+
+let update_case_info cache ci modlist =
   try
     let ind, n =
-      match kind_of_term (share (IndRef ci.ci_ind) modlist) with
-      | App (f,l) -> (destInd f, Array.length l)
-      | Ind ind -> ind, 0
+      match share cache (IndRef ci.ci_ind) modlist with
+      | (IndRef f,(u,l)) -> (f, Array.length l)
       | _ -> assert false in
     { ci with ci_ind = ind; ci_npar = ci.ci_npar + n }
   with Not_found ->
     ci
 
-let empty_modlist = (Cmap.empty, Mindmap.empty)
+let is_empty_modlist (cm, mm) =
+  Cmap.is_empty cm && Mindmap.is_empty mm
 
-let expmod_constr modlist c =
+let expmod_constr cache modlist c =
+  let share_univs = share_univs cache in
+  let update_case_info = update_case_info cache in
   let rec substrec c =
     match kind_of_term c with
       | Case (ci,p,t,br) ->
 	  map_constr substrec (mkCase (update_case_info ci modlist,p,t,br))
 
-      | Ind ind ->
+      | Ind (ind,u) ->
 	  (try
-	    share (IndRef ind) modlist
+	    share_univs (IndRef ind) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
-      | Construct cstr ->
+      | Construct (cstr,u) ->
 	  (try
-	    share (ConstructRef cstr) modlist
+	     share_univs (ConstructRef cstr) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
-      | Const cst ->
+      | Const (cst,u) ->
 	  (try
-	    share (ConstRef cst) modlist
+	    share_univs (ConstRef cst) u modlist
 	   with
 	    | Not_found -> map_constr substrec c)
 
+      | Proj (p, c') ->
+          (try 
+	     let p' = share_univs (ConstRef (Projection.constant p)) Univ.Instance.empty modlist in
+	     let make c = Projection.make c (Projection.unfolded p) in
+	     match kind_of_term p' with
+	     | Const (p',_) -> mkProj (make p', substrec c')
+	     | App (f, args) -> 
+	       (match kind_of_term f with 
+	       | Const (p', _) -> mkProj (make p', substrec c')
+	       | _ -> assert false)
+	     | _ -> assert false
+	   with Not_found -> map_constr substrec c)
+
   | _ -> map_constr substrec c
 
   in
-  if modlist = empty_modlist then c
+  if is_empty_modlist modlist then c
   else substrec c
 
 let abstract_constant_type =
@@ -112,41 +146,108 @@ let abstract_constant_type =
 let abstract_constant_body =
   List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c)
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : named_context;
-  d_modlist : work_list }
+type recipe = { from : constant_body; info : Opaqueproof.cooking_info }
+type inline = bool
 
-let on_body f = function
-  | Undef inl -> Undef inl
-  | Def cs -> Def (Declarations.from_val (f (Declarations.force cs)))
-  | OpaqueDef lc ->
-    OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc)))
+type result =
+  constant_def * constant_type * projection_body option * 
+    bool * constant_universes * inline
+    * Context.section_context option
 
-let constr_of_def = function
+let on_body ml hy f = function
+  | Undef _ as x -> x
+  | Def cs -> Def (Mod_subst.from_val (f (Mod_subst.force_constr cs)))
+  | OpaqueDef o ->
+    OpaqueDef (Opaqueproof.discharge_direct_opaque ~cook_constr:f
+                 { Opaqueproof.modlist = ml; abstract = hy } o)
+
+let constr_of_def otab = function
   | Undef _ -> assert false
-  | Def cs -> Declarations.force cs
-  | OpaqueDef lc -> Declarations.force_opaque lc
-
-let cook_constant env r =
-  let cb = r.d_from in
-  let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
-  let body = on_body
-    (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps)
+  | Def cs -> Mod_subst.force_constr cs
+  | OpaqueDef lc -> Opaqueproof.force_proof otab lc
+
+let expmod_constr_subst cache modlist subst c =
+  let c = expmod_constr cache modlist c in
+    Vars.subst_univs_level_constr subst c
+
+let cook_constr { Opaqueproof.modlist ; abstract } c =
+  let cache = RefTable.create 13 in
+  let expmod = expmod_constr_subst cache modlist (pi2 abstract) in
+  let hyps = Context.map_named_context expmod (pi1 abstract) in
+  abstract_constant_body (expmod c) hyps
+
+let lift_univs cb subst =
+  if cb.const_polymorphic && not (Univ.LMap.is_empty subst) then
+    let inst = Univ.UContext.instance cb.const_universes in
+    let cstrs = Univ.UContext.constraints cb.const_universes in
+    let len = Univ.LMap.cardinal subst in
+    let subst = 
+      Array.fold_left_i (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc)
+	subst (Univ.Instance.to_array inst)
+    in
+    let cstrs' = Univ.subst_univs_level_constraints subst cstrs in
+      subst, Univ.UContext.make (inst,cstrs')
+  else subst, cb.const_universes
+
+let cook_constant env { from = cb; info } =
+  let { Opaqueproof.modlist; abstract } = info in
+  let cache = RefTable.create 13 in
+  let abstract, usubst, abs_ctx = abstract in
+  let usubst, univs = lift_univs cb usubst in
+  let expmod = expmod_constr_subst cache modlist usubst in
+  let hyps = Context.map_named_context expmod abstract in
+  let body = on_body modlist (hyps, usubst, abs_ctx)
+    (fun c -> abstract_constant_body (expmod c) hyps)
     cb.const_body
   in
   let const_hyps =
-    Sign.fold_named_context (fun (h,_,_) hyps ->
-      List.filter (fun (id,_,_) -> id <> h) hyps)
+    Context.fold_named_context (fun (h,_,_) hyps ->
+      List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps)
       hyps ~init:cb.const_hyps in
   let typ = match cb.const_type with
-    | NonPolymorphicType t ->
-	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	NonPolymorphicType typ
-    | PolymorphicArity (ctx,s) ->
-	let t = mkArity (ctx,Type s.poly_level) in
-	let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
-	let j = make_judge (constr_of_def body) typ in
-	Typeops.make_polymorphic_if_constant_for_ind env j
+    | RegularArity t ->
+  	let typ =
+          abstract_constant_type (expmod t) hyps in
+  	RegularArity typ
+    | TemplateArity (ctx,s) ->
+  	let t = mkArity (ctx,Type s.template_level) in
+  	let typ = abstract_constant_type (expmod t) hyps in
+  	let j = make_judge (constr_of_def (opaque_tables env) body) typ in
+  	Typeops.make_polymorphic_if_constant_for_ind env j
+  in
+  let projection pb =
+    let c' = abstract_constant_body (expmod pb.proj_body) hyps in
+    let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in
+    let etat = abstract_constant_body (expmod (snd pb.proj_eta)) hyps in
+    let ((mind, _), _), n' =
+      try 
+	let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in
+	  match kind_of_term c' with
+	  | App (f,l) -> (destInd f, Array.length l)
+	  | Ind ind -> ind, 0
+	  | _ -> assert false 
+      with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0)
+    in 
+    let typ = (* By invariant, a regular arity *)
+      match typ with RegularArity t -> t | TemplateArity _ -> assert false 
+    in
+    let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in
+      { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg;
+	proj_eta = etab, etat;
+	proj_type = ty'; proj_body = c' }
+  in
+  let univs = 
+    let abs' = 
+      if cb.const_polymorphic then abs_ctx
+      else instantiate_univ_context abs_ctx
+    in
+      UContext.union abs' univs
   in
-  (body, typ, cb.const_constraints, const_hyps)
+    (body, typ, Option.map projection cb.const_proj, 
+     cb.const_polymorphic, univs, cb.const_inline_code, 
+     Some const_hyps)
+
+(* let cook_constant_key = Profile.declare_profile "cook_constant" *)
+(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *)
+
+let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index a5141568..441c9dd2 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -1,36 +1,30 @@
 (************************************************************************)
 (*  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 Declarations
 open Environ
-open Univ
 
 (** {6 Cooking the constants. } *)
 
-type work_list = identifier array Cmap.t * identifier array Mindmap.t
+type recipe = { from : constant_body; info : Opaqueproof.cooking_info }
 
-type recipe = {
-  d_from : constant_body;
-  d_abstract : Sign.named_context;
-  d_modlist : work_list }
+type inline = bool
 
-val cook_constant :
-  env -> recipe ->
-    constant_def * constant_type * constraints * Sign.section_context
+type result =
+  constant_def * constant_type * projection_body option * 
+    bool * constant_universes * inline
+    * Context.section_context option
 
+val cook_constant : env -> recipe -> result
+val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr
 
 (** {6 Utility functions used in module [Discharge]. } *)
 
-val expmod_constr : work_list -> constr -> constr
-
-val clear_cooking_sharing : unit -> unit
-
-
+val expmod_constr : Opaqueproof.work_list -> constr -> constr
 
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2f931818..ed8b0a6d 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.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        *)
@@ -12,8 +12,10 @@
 
 (* This file manages the table of global symbols for the bytecode machine *)
 
+open Util
 open Names
 open Term
+open Context
 open Vm
 open Cemitcodes
 open Cbytecodes
@@ -51,41 +53,60 @@ let set_global v =
   incr num_global;
   n
 
-(* [global_transp],[global_boxed] contiennent les valeurs des
-   definitions gelees. Les deux versions sont maintenues en //.
-   [global_transp] contient la version transparente.
-   [global_boxed] contient la version gelees. *)
-
-external global_boxed : unit -> bool array = "get_coq_global_boxed"
-
-(* [realloc_global_data n] augmente de n la taille de [global_data] *)
-external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed"
-
-let check_global_boxed n =
-  if n >= Array.length (global_boxed()) then realloc_global_boxed n
-
-let num_boxed = ref 0
-
-let boxed_tbl = Hashtbl.create 53
-
-let cst_opaque = ref Cpred.full
-
-let is_opaque kn = Cpred.mem kn !cst_opaque
-
-let set_global_boxed kn v =
-  let n = !num_boxed in
-  check_global_boxed n;
-  (global_boxed()).(n) <- (is_opaque kn);
-  Hashtbl.add boxed_tbl kn n ;
-  incr num_boxed;
-  set_global (val_of_constant_def n kn v)
-
 (* table pour les structured_constant et les annotations des switchs *)
 
-let str_cst_tbl = Hashtbl.create 31
-    (* (structured_constant * int) Hashtbl.t*)
-
-let annot_tbl = Hashtbl.create 31
+let rec eq_structured_constant c1 c2 = match c1, c2 with
+| Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2
+| Const_ind i1, Const_ind i2 -> Univ.eq_puniverses eq_ind i1 i2
+| Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2
+| Const_bn (t1, a1), Const_bn (t2, a2) ->
+  Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2
+| _ -> false
+
+let rec hash_structured_constant c =
+  let open Hashset.Combine in
+  match c with
+  | Const_sorts s -> combinesmall 1 (Sorts.hash s)
+  | Const_ind (i,u) -> combinesmall 2 (combine (ind_hash i) (Univ.Instance.hash u))
+  | Const_b0 t -> combinesmall 3 (Int.hash t)
+  | Const_bn (t, a) ->
+    let fold h c = combine h (hash_structured_constant c) in
+    let h = Array.fold_left fold 0 a in
+    combinesmall 4 (combine (Int.hash t) h)
+
+module SConstTable = Hashtbl.Make (struct
+  type t = structured_constant
+  let equal = eq_structured_constant
+  let hash = hash_structured_constant
+end)
+
+let eq_annot_switch asw1 asw2 =
+  let eq_ci ci1 ci2 =
+    eq_ind ci1.ci_ind ci2.ci_ind &&
+    Int.equal ci1.ci_npar ci2.ci_npar &&
+    Array.equal Int.equal ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls
+  in
+  let eq_rlc (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2 in
+  eq_ci asw1.ci asw2.ci &&
+  Array.equal eq_rlc asw1.rtbl asw2.rtbl &&
+  (asw1.tailcall : bool) == asw2.tailcall
+
+let hash_annot_switch asw =
+  let open Hashset.Combine in
+  let h1 = Constr.case_info_hash asw.ci in
+  let h2 = Array.fold_left (fun h (t, i) -> combine3 h t i) 0 asw.rtbl in
+  let h3 = if asw.tailcall then 1 else 0 in
+  combine3 h1 h2 h3
+
+module AnnotTable = Hashtbl.Make (struct
+  type t = annot_switch
+  let equal = eq_annot_switch
+  let hash = hash_annot_switch
+end)
+
+let str_cst_tbl : int SConstTable.t = SConstTable.create 31
+
+let annot_tbl : int AnnotTable.t = AnnotTable.create 31
     (* (annot_switch * int) Hashtbl.t  *)
 
 (*************************************************************)
@@ -94,11 +115,12 @@ let annot_tbl = Hashtbl.create 31
 
 exception NotEvaluated
 
-open Pp
 let key rk =
   match !rk with
-  | Some k -> (*Pp.msgnl (str"found at: "++int k);*)  k
-  | _ -> raise NotEvaluated
+  | None -> raise NotEvaluated
+  | Some k -> (*Pp.msgnl (str"found at: "++int k);*)
+      try Ephemeron.get k
+      with Ephemeron.InvalidKey -> raise NotEvaluated
 
 (************************)
 (* traduction des patch *)
@@ -107,65 +129,64 @@ let key rk =
    dans la table global, rend sa position dans la table *)
 
 let slot_for_str_cst key =
-  try Hashtbl.find str_cst_tbl key
+  try SConstTable.find str_cst_tbl key
   with Not_found ->
     let n = set_global (val_of_str_const key) in
-    Hashtbl.add str_cst_tbl key n;
+    SConstTable.add str_cst_tbl key n;
     n
 
 let slot_for_annot key =
-  try Hashtbl.find annot_tbl key
+  try AnnotTable.find annot_tbl key
   with Not_found ->
     let n =  set_global (val_of_annot_switch key) in
-    Hashtbl.add annot_tbl key n;
+    AnnotTable.add annot_tbl key n;
     n
 
-let rec slot_for_getglobal env kn =
-  let (cb,rk) = lookup_constant_key kn env in
+let rec slot_for_getglobal env (kn,u) =
+  let (cb,(_,rk)) = lookup_constant_key kn env in
   try key rk
   with NotEvaluated ->
 (*    Pp.msgnl(str"not yet evaluated");*)
     let pos =
       match Cemitcodes.force cb.const_body_code with
       | BCdefined(code,pl,fv) ->
-	let v = eval_to_patch env (code,pl,fv) in
-	set_global v
+	if Univ.Instance.is_empty u then
+	  let v = eval_to_patch env (code,pl,fv) in
+	    set_global v
+	else set_global (val_of_constant (kn,u))
     | BCallias kn' -> slot_for_getglobal env kn'
-    | BCconstant -> set_global (val_of_constant kn) in
+    | BCconstant -> set_global (val_of_constant (kn,u)) in
 (*Pp.msgnl(str"value stored at: "++int pos);*)
-    rk := Some pos;
+    rk := Some (Ephemeron.create pos);
     pos
 
 and slot_for_fv env fv =
+  let fill_fv_cache cache id v_of_id env_of_id b =
+    let v,d =
+      match b with
+      | None -> v_of_id id, Id.Set.empty
+      | Some c ->
+          val_of_constr (env_of_id id env) c,
+          Environ.global_vars_set (Environ.env_of_pre_env env) c in
+    build_lazy_val cache (v, d); v in
+  let val_of_rel i = val_of_rel (nb_rel env - i) in
+  let idfun _ x = x in
   match fv with
   | FVnamed id ->
       let nv = Pre_env.lookup_named_val id env in
-      begin
-	match !nv with
-	| VKvalue (v,_) -> v
-	| VKnone ->
-	    let (_, b, _) = Sign.lookup_named id env.env_named_context in
-	    let v,d =
-	      match b with
-		| None -> (val_of_named id, Idset.empty)
-		| Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c)
-	    in
-	      nv := VKvalue (v,d); v
+      begin match force_lazy_val nv with
+      | None ->
+          let _, b, _ = Context.lookup_named id env.env_named_context in
+          fill_fv_cache nv id val_of_named idfun b
+      | Some (v, _) -> v
       end
   | FVrel i ->
       let rv = Pre_env.lookup_rel_val i env in
-      begin
-	match !rv with
-	| VKvalue (v, _) -> v
-	| VKnone ->
-	    let (_, b, _) = lookup_rel i env.env_rel_context in
-	    let (v, d) =
-	      match b with
-		| None -> (val_of_rel (nb_rel env - i), Idset.empty)
-		| Some c -> let renv =  env_of_rel i env in
-			      (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
-	    in
-	      rv := VKvalue (v,d); v
+      begin match force_lazy_val rv with
+      | None ->
+          let _, b, _ = lookup_rel i env.env_rel_context in
+          fill_fv_cache rv i val_of_rel env_of_rel b
+      | Some (v, _) -> v
       end
 
 and eval_to_patch env (buff,pl,fv) =
@@ -191,18 +212,14 @@ and val_of_constr env c =
   let (_,fun_code,_ as ccfv) =
     try compile env c
     with reraise ->
-      print_string "can not compile \n";Format.print_flush();raise reraise
+      let reraise = Errors.push reraise in
+      let () = print_string "can not compile \n" in
+      let () = Format.print_flush () in
+      iraise reraise
   in
   eval_to_patch env (to_memory ccfv)
 
-let set_transparent_const kn =
-  cst_opaque := Cpred.remove kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- false)
-    (Hashtbl.find_all boxed_tbl kn)
-
-let set_opaque_const kn =
-  cst_opaque := Cpred.add kn !cst_opaque;
-  List.iter (fun n -> (global_boxed()).(n) <- true)
-    (Hashtbl.find_all boxed_tbl kn)
+let set_transparent_const kn = () (* !?! *)
+let set_opaque_const kn = () (* !?! *)
 
 
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 5fb2f975..ca5f8ac2 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.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/kernel/declarations.ml b/kernel/declarations.ml
deleted file mode 100644
index 88d28323..00000000
--- a/kernel/declarations.ml
+++ /dev/null
@@ -1,409 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* This file is a late renaming in May 2000 of constant.ml which
-   itself was made for V7.0 in Aug 1999 out of a dispatch by
-   Jean-Christophe Filliâtre of Chet Murthy's constants.ml in V5.10.5
-   into cooking.ml, declare.ml and constant.ml, ...; renaming done
-   because the new contents exceeded in extent what the name
-   suggested *)
-(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
-(* Declarations for the module systems added by Jacek Chrzaszcz, Aug 2002 *)
-(* Miscellaneous extensions, cleaning or restructurations by Bruno
-   Barras, Hugo Herbelin, Jean-Christophe Filliâtre, Pierre Letouzey *)
-
-(* This module defines the types of global declarations. This includes
-   global constants/axioms, mutual inductive definitions and the
-   module system *)
-
-open Util
-open Names
-open Univ
-open Term
-open Sign
-open Mod_subst
-
-type engagement = ImpredicativeSet
-
-(*s Constants (internal representation) (Definition/Axiom) *)
-
-type polymorphic_arity = {
-  poly_param_levels : universe option list;
-  poly_level : universe;
-}
-
-type constant_type =
-  | NonPolymorphicType of types
-  | PolymorphicArity of rel_context * polymorphic_arity
-
-type constr_substituted = constr substituted
-
-let from_val = from_val
-
-let force = force subst_mps
-
-let subst_constr_subst = subst_substituted
-
-(** Opaque proof terms are not loaded immediately, but are there
-    in a lazy form. Forcing this lazy may trigger some unmarshal of
-    the necessary structure. The ['a substituted] type isn't really great
-    here, so we store "manually" a substitution list, the younger one at top.
-*)
-
-type lazy_constr = constr_substituted Lazy.t * substitution list
-
-let force_lazy_constr (c,l) =
-  List.fold_right subst_constr_subst l (Lazy.force c)
-
-let lazy_constr_is_val (c,_) = Lazy.lazy_is_val c
-
-let make_lazy_constr c = (c, [])
-
-let force_opaque lc = force (force_lazy_constr lc)
-
-let opaque_from_val c = (Lazy.lazy_from_val (from_val c), [])
-
-let subst_lazy_constr sub (c,l) = (c,sub::l)
-
-(** Inlining level of parameters at functor applications.
-    None means no inlining *)
-
-type inline = int option
-
-(** A constant can have no body (axiom/parameter), or a
-    transparent body, or an opaque one *)
-
-type constant_def =
-  | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
-
-type constant_body = {
-    const_hyps : section_context; (* New: younger hyp at top *)
-    const_body : constant_def;
-    const_type : constant_type;
-    const_body_code : Cemitcodes.to_patch_substituted;
-    const_constraints : constraints }
-
-let body_of_constant cb = match cb.const_body with
-  | Undef _ -> None
-  | Def c -> Some c
-  | OpaqueDef lc -> Some (force_lazy_constr lc)
-
-let constant_has_body cb = match cb.const_body with
-  | Undef _ -> false
-  | Def _ | OpaqueDef _ -> true
-
-let is_opaque cb = match cb.const_body with
-  | OpaqueDef _ -> true
-  | Undef _ | Def _ -> false
-
-(* Substitutions of [constant_body] *)
-
-let subst_rel_declaration sub (id,copt,t as x) =
-  let copt' = Option.smartmap (subst_mps sub) copt in
-  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)
-
-(* TODO: these substitution functions could avoid duplicating things
-   when the substitution have preserved all the fields *)
-
-let subst_const_type sub arity =
-  if is_empty_subst sub then arity
-  else match arity with
-    | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
-    | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
-
-let subst_const_def sub = function
-  | Undef inl -> Undef inl
-  | Def c -> Def (subst_constr_subst sub c)
-  | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
-
-let subst_const_body sub cb = {
-  const_hyps = (assert (cb.const_hyps=[]); []);
-  const_body = subst_const_def sub cb.const_body;
-  const_type = subst_const_type sub cb.const_type;
-  const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
-  const_constraints = cb.const_constraints}
-
-(* Hash-consing of [constant_body] *)
-
-let hcons_rel_decl ((n,oc,t) as d) =
-  let n' = hcons_name n
-  and oc' = Option.smartmap hcons_constr oc
-  and t' = hcons_types t
-  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
-
-let hcons_rel_context l = list_smartmap hcons_rel_decl l
-
-let hcons_polyarity ar =
-  { poly_param_levels =
-      list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels;
-    poly_level = hcons_univ ar.poly_level }
-
-let hcons_const_type = function
-  | NonPolymorphicType t ->
-    NonPolymorphicType (hcons_constr t)
-  | PolymorphicArity (ctx,s) ->
-    PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s)
-
-let hcons_const_def = function
-  | Undef inl -> Undef inl
-  | Def l_constr ->
-    let constr = force l_constr in
-    Def (from_val (hcons_constr constr))
-  | OpaqueDef lc ->
-    if lazy_constr_is_val lc then
-      let constr = force_opaque lc in
-      OpaqueDef (opaque_from_val (hcons_constr constr))
-    else OpaqueDef lc
-
-let hcons_const_body cb =
-  { cb with
-    const_body = hcons_const_def cb.const_body;
-    const_type = hcons_const_type cb.const_type;
-    const_constraints = hcons_constraints cb.const_constraints }
-
-
-(*s Inductive types (internal representation with redundant
-    information). *)
-
-type recarg =
-  | Norec
-  | Mrec of inductive
-  | Imbr of inductive
-
-let subst_recarg sub r = match r with
-  | Norec -> r
-  | Mrec (kn,i) -> let kn' = subst_ind sub kn in
-      if kn==kn' then r else Mrec (kn',i)
-  | Imbr (kn,i) -> let kn' = subst_ind sub kn in
-      if kn==kn' then r else Imbr (kn',i)
-
-type wf_paths = recarg Rtree.t
-
-let mk_norec = Rtree.mk_node Norec [||]
-
-let mk_paths r recargs =
-  Rtree.mk_node r
-    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
-
-let dest_recarg p = fst (Rtree.dest_node p)
-
-(* dest_subterms returns the sizes of each argument of each constructor of
-   an inductive object of size [p]. This should never be done for Norec,
-   because the number of sons does not correspond to the number of
-   constructors.
- *)
-let dest_subterms p =
-  let (ra,cstrs) = Rtree.dest_node p in
-  assert (ra<>Norec);
-  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
-
-let recarg_length p j =
-  let (_,cstrs) = Rtree.dest_node p in
-  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
-
-let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
-
-(**********************************************************************)
-(* Representation of mutual inductive types in the kernel             *)
-(*
-   Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
-   ...
-   with      In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
-*)
-
-type monomorphic_inductive_arity = {
-  mind_user_arity : constr;
-  mind_sort : sorts;
-}
-
-type inductive_arity =
-| Monomorphic of monomorphic_inductive_arity
-| Polymorphic of polymorphic_arity
-
-type one_inductive_body = {
-
-(* Primitive datas *)
-
- (* Name of the type: [Ii] *)
-    mind_typename : identifier;
-
- (* Arity context of [Ii] with parameters: [forall params, Ui] *)
-    mind_arity_ctxt : rel_context;
-
- (* Arity sort, original user arity, and allowed elim sorts, if monomorphic *)
-    mind_arity : inductive_arity;
-
- (* Names of the constructors: [cij] *)
-    mind_consnames : identifier array;
-
- (* Types of the constructors with parameters: [forall params, Tij],
-    where the Ik are replaced by de Bruijn index in the context
-    I1:forall params, U1 ..  In:forall params, Un *)
-    mind_user_lc : types 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 : types array;
-
- (* Length of the signature of the constructors (with let, w/o params) *)
-    mind_consnrealdecls : int array;
-
- (* Signature of recursive arguments in the constructors *)
-    mind_recargs : wf_paths;
-
-(* Datas for bytecode compilation *)
-
- (* number of constant constructor *)
-    mind_nb_constant : int;
-
- (* number of no constant constructor *)
-    mind_nb_args : int;
-
-    mind_reloc_tbl :  Cbytecodes.reloc_table;
-  }
-
-type mutual_inductive_body = {
-
-  (* The component of the mutual inductive block *)
-    mind_packets : one_inductive_body array;
-
-  (* Whether the inductive type has been declared as a record *)
-    mind_record : bool;
-
-  (* Whether the type is inductive or coinductive *)
-    mind_finite : bool;
-
-  (* Number of types in the block *)
-    mind_ntypes : int;
-
-  (* Section hypotheses on which the block depends *)
-    mind_hyps : section_context;
-
-  (* Number of expected parameters *)
-    mind_nparams : int;
-
-  (* Number of recursively uniform (i.e. ordinary) parameters *)
-    mind_nparams_rec : int;
-
-  (* The context of parameters (includes let-in declaration) *)
-    mind_params_ctxt : rel_context;
-
-  (* Universes constraints enforced by the inductive declaration *)
-    mind_constraints : constraints;
-
-  }
-
-let subst_indarity sub = function
-| Monomorphic s ->
-    Monomorphic {
-      mind_user_arity = subst_mps sub s.mind_user_arity;
-      mind_sort = s.mind_sort;
-    }
-| Polymorphic s as x -> x
-
-let subst_mind_packet sub mbp =
-  { mind_consnames = mbp.mind_consnames;
-    mind_consnrealdecls = mbp.mind_consnrealdecls;
-    mind_typename = mbp.mind_typename;
-    mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
-    mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
-    mind_arity = subst_indarity sub mbp.mind_arity;
-    mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
-    mind_nrealargs = mbp.mind_nrealargs;
-    mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
-    mind_kelim = mbp.mind_kelim;
-    mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*);
-    mind_nb_constant = mbp.mind_nb_constant;
-    mind_nb_args = mbp.mind_nb_args;
-    mind_reloc_tbl = mbp.mind_reloc_tbl }
-
-let subst_mind sub mib =
-  { mind_record = mib.mind_record ;
-    mind_finite = mib.mind_finite ;
-    mind_ntypes = mib.mind_ntypes ;
-    mind_hyps = (assert (mib.mind_hyps=[]); []) ;
-    mind_nparams = mib.mind_nparams;
-    mind_nparams_rec = mib.mind_nparams_rec;
-    mind_params_ctxt =
-      map_rel_context (subst_mps sub) mib.mind_params_ctxt;
-    mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
-    mind_constraints = mib.mind_constraints  }
-
-let hcons_indarity = function
-  | Monomorphic a ->
-    Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity;
-		  mind_sort = hcons_sorts a.mind_sort }
-  | Polymorphic a -> Polymorphic (hcons_polyarity a)
-
-let hcons_mind_packet oib =
- { oib with
-   mind_typename = hcons_ident oib.mind_typename;
-   mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
-   mind_arity = hcons_indarity oib.mind_arity;
-   mind_consnames = array_smartmap hcons_ident oib.mind_consnames;
-   mind_user_lc = array_smartmap hcons_types oib.mind_user_lc;
-   mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc }
-
-let hcons_mind mib =
-  { mib with
-    mind_packets = array_smartmap hcons_mind_packet mib.mind_packets;
-    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
-    mind_constraints = hcons_constraints mib.mind_constraints }
-
-(*s Modules: signature component specifications, module types, and
-  module declarations *)
-
-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 * 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 : constraints;
-      mod_delta : delta_resolver;
-      mod_retroknowledge : 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 : constraints;
-      typ_delta :delta_resolver}
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 4ee2fe57..bec52122 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -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 Names
-open Univ
 open Term
-open Cemitcodes
-open Sign
-open Mod_subst
+open Context
 
 (** This module defines the internal representation of global
    declarations. This includes global constants/axioms, mutual
@@ -21,33 +18,24 @@ type engagement = ImpredicativeSet
 
 (** {6 Representation of constants (Definition/Axiom) } *)
 
-type polymorphic_arity = {
-  poly_param_levels : universe option list;
-  poly_level : universe;
-}
-
-type constant_type =
-  | NonPolymorphicType of types
-  | PolymorphicArity of rel_context * polymorphic_arity
-
-type constr_substituted
-
-val from_val : constr -> constr_substituted
-val force : constr_substituted -> constr
-
-(** Opaque proof terms are not loaded immediately, but are there
-    in a lazy form. Forcing this lazy may trigger some unmarshal of
-    the necessary structure. *)
+(** Non-universe polymorphic mode polymorphism (Coq 8.2+): inductives
+    and constants hiding inductives are implicitely polymorphic when
+    applied to parameters, on the universes appearing in the whnf of
+    their parameters and their conclusion, in a template style.
+    
+    In truely universe polymorphic mode, we always use RegularArity.
+*)
 
-type lazy_constr
+type template_arity = {
+  template_param_levels : Univ.universe_level option list;
+  template_level : Univ.universe;
+}
 
-val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr
-val force_lazy_constr : lazy_constr -> constr_substituted
-val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr
-val lazy_constr_is_val : lazy_constr -> bool
+type ('a, 'b) declaration_arity = 
+  | RegularArity of 'a
+  | TemplateArity of 'b
 
-val force_opaque : lazy_constr -> constr
-val opaque_from_val : constr -> lazy_constr
+type constant_type = (types, rel_context * template_arity) declaration_arity
 
 (** Inlining level of parameters at functor applications.
     None means no inlining *)
@@ -57,31 +45,43 @@ 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 : types; (* Type under params *)
+  proj_eta : constr * types; (* Eta-expanded term and type *)
+  proj_body : constr; (* For compatibility with VMs only, the match version *)
+}
+
 type constant_def =
   | Undef of inline
-  | Def of constr_substituted
-  | OpaqueDef of lazy_constr
+  | Def of constr Mod_subst.substituted
+  | OpaqueDef of Opaqueproof.opaque
 
+type constant_universes = Univ.universe_context
+
+(* some contraints are in constant_constraints, some other may be in
+ * the OpaueDef *)
 type constant_body = {
-    const_hyps : section_context; (** New: younger hyp at top *)
+    const_hyps : Context.section_context; (** New: younger hyp at top *)
     const_body : constant_def;
     const_type : constant_type;
-    const_body_code : to_patch_substituted;
-    const_constraints : constraints }
-
-val subst_const_def : substitution -> constant_def -> constant_def
-val subst_const_body : substitution -> constant_body -> constant_body
-
-(** Is there a actual body in const_body or const_body_opaque ? *)
-
-val constant_has_body : constant_body -> bool
-
-(** Accessing const_body_opaque or const_body *)
-
-val body_of_constant : constant_body -> constr_substituted option
-
-val is_opaque : constant_body -> bool
-
+    const_body_code : Cemitcodes.to_patch_substituted;
+    const_polymorphic : bool; (** Is it polymorphic or not *)
+    const_universes : constant_universes;
+    const_proj : projection_body option;
+    const_inline_code : bool }
+
+type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ]
+
+type side_effect =
+  | SEsubproof of constant * constant_body * seff_env
+  | SEscheme of (inductive * constant * constant_body * seff_env) list * string
+    
 (** {6 Representation of mutual inductive types in the kernel } *)
 
 type recarg =
@@ -89,18 +89,8 @@ type recarg =
   | Mrec of inductive
   | Imbr of inductive
 
-val subst_recarg : substitution -> recarg -> recarg
-
 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
-val recarg_length : wf_paths -> int -> int
-
-val subst_wf_paths : substitution -> wf_paths -> wf_paths
-
 (**
 {v
    Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
@@ -109,25 +99,32 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths
 v}
 *)
 
-type monomorphic_inductive_arity = {
-  mind_user_arity : constr;
+(** Record information:
+    If the record is not primitive, then None
+    Otherwise, we get:
+    - The identifier for the binder name of the record in primitive projections.
+    - The constants associated to each projection.
+    - The checked projection bodies. *)
+
+type record_body = (Id.t * constant array * projection_body array) option
+
+type regular_inductive_arity = {
+  mind_user_arity : types;
   mind_sort : sorts;
 }
 
-type inductive_arity =
-| Monomorphic of monomorphic_inductive_arity
-| Polymorphic of polymorphic_arity
+type inductive_arity = (regular_inductive_arity, template_arity) declaration_arity
 
 type one_inductive_body = {
 (** {8 Primitive datas } *)
 
-    mind_typename : identifier; (** Name of the type: [Ii] *)
+    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_arity : inductive_arity; (** Arity sort and original user arity *)
 
-    mind_consnames : identifier array; (** Names of the constructors: [cij] *)
+    mind_consnames : Id.t array; (** Names of the constructors: [cij] *)
 
     mind_user_lc : types array;
  (** Types of the constructors with parameters:  [forall params, Tij],
@@ -138,12 +135,16 @@ type one_inductive_body = {
 
     mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
 
-    mind_nrealargs_ctxt : int; (** Length of realargs context (with 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 : types array; (** Head normalized constructor types so that their conclusion is atomic *)
 
+    mind_consnrealargs : int array;
+ (** Number of expected proper arguments of the constructors (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) *)
@@ -163,13 +164,13 @@ type mutual_inductive_body = {
 
     mind_packets : one_inductive_body array;  (** The component of the mutual inductive block *)
 
-    mind_record : bool;  (** Whether the inductive type has been declared as a record *)
+    mind_record : record_body option; (** The record information *)
 
-    mind_finite : bool;  (** Whether the type is inductive or coinductive *)
+    mind_finite : Decl_kinds.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_hyps : Context.section_context;  (** Section hypotheses on which the block depends *)
 
     mind_nparams : int;  (** Number of expected parameters *)
 
@@ -177,14 +178,38 @@ type mutual_inductive_body = {
 
     mind_params_ctxt : rel_context;  (** The context of parameters (includes let-in declaration) *)
 
-    mind_constraints : constraints;  (** Universes constraints enforced by the inductive 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 *)
+  
+}
+
+(** {6 Module declarations } *)
 
-val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
+(** Functor expressions are forced to be on top of other expressions *)
 
-(** {6 Modules: signature component specifications, module types, and
-  module declarations } *)
+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
@@ -192,57 +217,52 @@ type structure_field_body =
   | SFBmodule of module_body
   | SFBmodtype of module_type_body
 
-(** NB: we may encounter now (at most) twice the same label in
+(** 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 * structure_field_body) list
+and structure_body = (Label.t * 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 * constraints
-  | SEBstruct of structure_body
-  | SEBwith of struct_expr_body * with_declaration_body
+(** A module signature is a structure, with possibly functors on top of it *)
 
-and with_declaration_body =
-    With_module_body of identifier list * module_path
-  | With_definition_body of  identifier list * constant_body
+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 *)
+  | 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 =
-    {  (** absolute path of the module *)
-      mod_mp : module_path;
-      (** Implementation *)
-      mod_expr : struct_expr_body option; 
-      (** Signature *)
-      mod_type : struct_expr_body;
-      (** algebraic structure expression is kept 
-	 if it's relevant for extraction  *)
-      mod_type_alg : struct_expr_body option; 
-      (** set of all constraint in the module  *)
-      mod_constraints : constraints;
-      (** quotiented set of equivalent constant and inductive name  *)
-      mod_delta : delta_resolver;
-      mod_retroknowledge : Retroknowledge.action list}
-      
-and module_type_body =
-    { 
-      (** Path of the module type *)
-      typ_mp : module_path;
-      typ_expr : struct_expr_body;
-      (** algebraic structure expression is kept 
-	 if it's relevant for extraction  *)
-      typ_expr_alg : struct_expr_body option ;
-      typ_constraints : constraints;
-      (** quotiented set of equivalent constant and inductive name  *)
-      typ_delta :delta_resolver}
-
-
-(** Hash-consing *)
-
-(** Here, strictly speaking, we don't perform true hash-consing
-    of the structure, but simply hash-cons all inner constr
-    and other known elements *)
-
-val hcons_const_body : constant_body -> constant_body
-val hcons_mind : mutual_inductive_body -> mutual_inductive_body
+  { 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 : Mod_subst.delta_resolver;
+    mod_retroknowledge : 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
+
+(** Extra invariants :
+
+    - No [MEwith] inside a [mod_expr] implementation : the 'with' syntax
+      is only supported for module types
+
+    - A module application is atomic, for instance ((M N) P) :
+      * the head of [MEapply] can only be another [MEapply] or a [MEident]
+      * the argument of [MEapply] is now directly forced to be a [module_path].
+*)
diff --git a/kernel/declareops.ml b/kernel/declareops.ml
new file mode 100644
index 00000000..48a6098e
--- /dev/null
+++ b/kernel/declareops.ml
@@ -0,0 +1,320 @@
+(************************************************************************)
+(*  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 Declarations
+open Mod_subst
+open Util
+
+(** Operations concernings types in [Declarations] :
+    [constant_body], [mutual_inductive_body], [module_body] ... *)
+
+(** {6 Arities } *)
+
+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'
+
+let map_decl_arity f g = function
+  | RegularArity a -> RegularArity (f a)
+  | TemplateArity a -> TemplateArity (g a)
+
+let hcons_template_arity ar =
+  { template_param_levels = ar.template_param_levels;
+      (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *)
+    template_level = Univ.hcons_univ ar.template_level }
+
+(** {6 Constants } *)
+
+let instantiate cb c =
+  if cb.const_polymorphic then 
+    Vars.subst_instance_constr (Univ.UContext.instance cb.const_universes) c
+  else c
+
+let body_of_constant otab cb = match cb.const_body with
+  | Undef _ -> None
+  | Def c -> Some (instantiate cb (force_constr c))
+  | OpaqueDef o -> Some (instantiate cb (Opaqueproof.force_proof otab o))
+
+let type_of_constant cb =
+  match cb.const_type with
+  | RegularArity t as x -> 
+    let t' = instantiate cb t in
+      if t' == t then x else RegularArity t'
+  | TemplateArity _ as x -> x
+
+let constraints_of_constant otab cb = Univ.Constraint.union 
+  (Univ.UContext.constraints cb.const_universes)
+  (match cb.const_body with
+  | Undef _ -> Univ.empty_constraint
+  | Def c -> Univ.empty_constraint
+  | OpaqueDef o ->
+      Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o))
+
+let universes_of_constant otab cb = 
+  match cb.const_body with
+  | Undef _ | Def _ -> cb.const_universes
+  | OpaqueDef o -> 
+      let body_uctxs = Opaqueproof.force_constraints otab o in
+      assert(not cb.const_polymorphic || Univ.ContextSet.is_empty body_uctxs);
+      let uctxs = Univ.ContextSet.of_context cb.const_universes in
+      Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) 
+
+let universes_of_polymorphic_constant otab cb = 
+  if cb.const_polymorphic then 
+    let univs = universes_of_constant otab cb in
+      Univ.instantiate_univ_context univs
+  else Univ.UContext.empty
+
+let constant_has_body cb = match cb.const_body with
+  | Undef _ -> false
+  | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+  | OpaqueDef _ -> true
+  | Undef _ | Def _ -> false
+
+(** {7 Constant substitutions } *)
+
+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)
+
+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)
+      
+let subst_const_type sub arity =
+  if is_empty_subst sub then arity
+  else subst_mps sub arity
+
+(** No need here to check for physical equality after substitution,
+    at least for Def due to the delayed substitution [subst_constr_subst]. *)
+let subst_const_def sub def = match def with
+  | Undef _ -> def
+  | Def c -> Def (subst_constr sub c)
+  | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o)
+
+let subst_const_proj sub pb =
+  { pb with proj_ind = subst_mind sub pb.proj_ind;
+    proj_type = subst_mps sub pb.proj_type;
+    proj_body = subst_const_type sub pb.proj_body }
+
+let subst_const_body sub cb =
+  assert (List.is_empty cb.const_hyps); (* we're outside sections *)
+  if is_empty_subst sub then cb
+  else
+    let body' = subst_const_def sub cb.const_body in
+    let type' = subst_decl_arity subst_const_type subst_template_cst_arity sub cb.const_type in
+    let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in
+    if body' == cb.const_body && type' == cb.const_type
+      && proj' == cb.const_proj then cb
+    else
+      { const_hyps = [];
+        const_body = body';
+        const_type = type';
+        const_proj = proj';
+        const_body_code =
+          Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+        const_polymorphic = cb.const_polymorphic;
+        const_universes = cb.const_universes;
+        const_inline_code = cb.const_inline_code }
+
+(** {7 Hash-consing of constants } *)
+
+(** This hash-consing is currently quite partial : we only
+    share internal fields (e.g. constr), and not the records
+    themselves. But would it really bring substantial gains ? *)
+
+let hcons_rel_decl ((n,oc,t) as d) =
+  let n' = Names.Name.hcons n
+  and oc' = Option.smartmap Term.hcons_constr oc
+  and t' = Term.hcons_types t
+  in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
+
+let hcons_rel_context l = List.smartmap hcons_rel_decl l
+
+let hcons_regular_const_arity t = Term.hcons_constr t
+
+let hcons_template_const_arity (ctx, ar) = 
+  (hcons_rel_context ctx, hcons_template_arity ar)
+
+let hcons_const_type = 
+  map_decl_arity hcons_regular_const_arity hcons_template_const_arity
+
+let hcons_const_def = function
+  | Undef inl -> Undef inl
+  | Def l_constr ->
+    let constr = force_constr l_constr in
+    Def (from_val (Term.hcons_constr constr))
+  | OpaqueDef _ as x -> x (* hashconsed when turned indirect *)
+
+let hcons_const_body cb =
+  { cb with
+    const_body = hcons_const_def cb.const_body;
+    const_type = hcons_const_type cb.const_type;
+    const_universes = Univ.hcons_universe_context cb.const_universes }
+
+(** {6 Inductive types } *)
+
+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 subst_recarg sub r = match r with
+  | Norec -> r
+  | Mrec (kn,i) ->
+    let kn' = subst_mind sub kn in
+    if kn==kn' then r else Mrec (kn',i)
+  | Imbr (kn,i) ->
+    let kn' = subst_mind sub kn in
+    if kn==kn' then r else Imbr (kn',i)
+
+let mk_norec = Rtree.mk_node Norec [||]
+
+let mk_paths r recargs =
+  Rtree.mk_node r
+    (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs)
+
+let dest_recarg p = fst (Rtree.dest_node p)
+
+(* dest_subterms returns the sizes of each argument of each constructor of
+   an inductive object of size [p]. This should never be done for Norec,
+   because the number of sons does not correspond to the number of
+   constructors.
+ *)
+let dest_subterms p =
+  let (ra,cstrs) = Rtree.dest_node p in
+  assert (match ra with Norec -> false | _ -> true);
+  Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
+
+let recarg_length p j =
+  let (_,cstrs) = Rtree.dest_node p in
+  Array.length (snd (Rtree.dest_node cstrs.(j-1)))
+
+let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p
+
+(** {7 Substitution of inductive declarations } *)
+
+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_template_ind_arity sub s = s
+
+(* 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_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
+    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_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;
+    mind_nb_args = mbp.mind_nb_args;
+    mind_reloc_tbl = mbp.mind_reloc_tbl }
+
+let subst_mind_record sub (id, ps, pb as r) =
+  let ps' = Array.smartmap (subst_constant sub) ps in
+  let pb' = Array.smartmap (subst_const_proj sub) pb in
+    if ps' == ps && pb' == pb then r
+    else (id, ps', pb')
+
+let subst_mind_body sub mib =
+  { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ;
+    mind_finite = mib.mind_finite ;
+    mind_ntypes = mib.mind_ntypes ;
+    mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false);
+    mind_nparams = mib.mind_nparams;
+    mind_nparams_rec = mib.mind_nparams_rec;
+    mind_params_ctxt =
+      Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt;
+    mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ;
+    mind_polymorphic = mib.mind_polymorphic;
+    mind_universes = mib.mind_universes;
+    mind_private = mib.mind_private }
+
+let inductive_instance mib =
+  if mib.mind_polymorphic then
+    Univ.UContext.instance mib.mind_universes
+  else Univ.Instance.empty
+
+let inductive_context mib =
+  if mib.mind_polymorphic then 
+    Univ.instantiate_univ_context mib.mind_universes 
+  else Univ.UContext.empty
+
+(** {6 Hash-consing of inductive declarations } *)
+
+let hcons_regular_ind_arity a =
+  { mind_user_arity = Term.hcons_constr a.mind_user_arity;
+    mind_sort = Term.hcons_sorts a.mind_sort }
+
+(** Just as for constants, this hash-consing is quite partial *)
+
+let hcons_ind_arity =
+  map_decl_arity hcons_regular_ind_arity hcons_template_arity
+
+(** Substitution of inductive declarations *)
+
+let hcons_mind_packet oib =
+  let user = Array.smartmap Term.hcons_types oib.mind_user_lc in
+  let nf = Array.smartmap Term.hcons_types oib.mind_nf_lc in
+  (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *)
+  let nf = if Array.equal (==) user nf then user else nf in
+  { oib with
+    mind_typename = Names.Id.hcons oib.mind_typename;
+    mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
+    mind_arity = hcons_ind_arity oib.mind_arity;
+    mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames;
+    mind_user_lc = user;
+    mind_nf_lc = nf }
+
+let hcons_mind mib =
+  { mib with
+    mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets;
+    mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
+    mind_universes = Univ.hcons_universe_context mib.mind_universes }
+
+(** {6 Stm machinery } *)
+
+let string_of_side_effect = function
+  | SEsubproof (c,_,_) -> Names.string_of_con c
+  | SEscheme (cl,_) ->
+      String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl)
+type side_effects = side_effect list
+let no_seff = ([] : side_effects)
+let iter_side_effects f l = List.iter f (List.rev l)
+let fold_side_effects f a l = List.fold_left f a l
+let uniquize_side_effects l = List.rev (CList.uniquize (List.rev l))
+let union_side_effects l1 l2 = l1 @ l2
+let flatten_side_effects l = List.flatten l
+let side_effects_of_list l = l
+let cons_side_effects x l = x :: l
+let side_effects_is_empty = List.is_empty
diff --git a/kernel/declareops.mli b/kernel/declareops.mli
new file mode 100644
index 00000000..47a82cc6
--- /dev/null
+++ b/kernel/declareops.mli
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  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 Declarations
+open Mod_subst
+open Univ
+open Context
+
+(** Operations concerning types in [Declarations] :
+    [constant_body], [mutual_inductive_body], [module_body] ... *)
+
+(** {6 Arities} *)
+
+val map_decl_arity : ('a -> 'c) -> ('b -> 'd) ->
+  ('a, 'b) declaration_arity -> ('c, 'd) declaration_arity
+
+(** {6 Constants} *)
+
+val subst_const_body : substitution -> constant_body -> constant_body
+
+(** Is there a actual body in const_body ? *)
+
+val constant_has_body : constant_body -> bool
+
+(** Accessing const_body, forcing access to opaque proof term if needed.
+    Only use this function if you know what you're doing. *)
+
+val body_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Term.constr option
+val type_of_constant : constant_body -> constant_type
+val constraints_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.constraints
+val universes_of_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.universe_context
+
+(** Return the universe context, in case the definition is polymorphic, otherwise
+    the context is empty. *)
+
+val universes_of_polymorphic_constant :
+  Opaqueproof.opaquetab -> constant_body -> Univ.universe_context
+
+val is_opaque : constant_body -> bool
+
+(** Side effects *)
+
+val string_of_side_effect : side_effect -> string
+
+type side_effects
+val no_seff : side_effects
+val iter_side_effects : (side_effect -> unit) -> side_effects -> unit
+val fold_side_effects : ('a -> side_effect -> 'a) -> 'a -> side_effects -> 'a
+val uniquize_side_effects : side_effects -> side_effects
+val union_side_effects : side_effects -> side_effects -> side_effects
+val flatten_side_effects : side_effects list -> side_effects
+val side_effects_of_list : side_effect list -> side_effects
+val cons_side_effects : side_effect -> side_effects -> side_effects
+val side_effects_is_empty : side_effects -> bool
+
+(** {6 Inductive types} *)
+
+val eq_recarg : recarg -> recarg -> bool
+
+val subst_recarg : substitution -> recarg -> recarg
+
+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
+val recarg_length : wf_paths -> int -> int
+
+val subst_wf_paths : substitution -> wf_paths -> wf_paths
+
+val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body
+
+val inductive_instance : mutual_inductive_body -> universe_instance
+val inductive_context : mutual_inductive_body -> universe_context
+
+(** {6 Hash-consing} *)
+
+(** Here, strictly speaking, we don't perform true hash-consing
+    of the structure, but simply hash-cons all inner constr
+    and other known elements *)
+
+val hcons_const_body : constant_body -> constant_body
+val hcons_mind : mutual_inductive_body -> mutual_inductive_body
diff --git a/kernel/entries.ml b/kernel/entries.ml
deleted file mode 100644
index 1b98c7b8..00000000
--- a/kernel/entries.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Univ
-open Term
-open Sign
-(*i*)
-
-(* This module defines the entry types for global declarations. This
-   information is entered in the environments. This includes global
-   constants/axioms, mutual inductive definitions, modules and module
-   types *)
-
-
-(*s Local entries *)
-
-type local_entry =
-  | LocalDef of constr
-  | LocalAssum of constr
-
-
-(*s Declaration of inductive types. *)
-
-(* Assume the following definition in concrete syntax:
-\begin{verbatim}
-Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
-...
-with      Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
-\end{verbatim}
-then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
-[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
-[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
-*)
-
-type one_inductive_entry = {
-  mind_entry_typename : identifier;
-  mind_entry_arity : constr;
-  mind_entry_consnames : identifier list;
-  mind_entry_lc : constr list }
-
-type mutual_inductive_entry = {
-  mind_entry_record : bool;
-  mind_entry_finite : bool;
-  mind_entry_params : (identifier * local_entry) list;
-  mind_entry_inds : one_inductive_entry list }
-
-
-(*s Constants (Definition/Axiom) *)
-
-type definition_entry = {
-  const_entry_body   : constr;
-  const_entry_secctx : section_context option;
-  const_entry_type   : types option;
-  const_entry_opaque : bool }
-
-type inline = int option (* inlining level, None for no inlining *)
-
-type parameter_entry = section_context option * types * inline 
-
-type constant_entry =
-  | DefinitionEntry of definition_entry
-  | ParameterEntry of parameter_entry
-
-(*s Modules *)
-
-type module_struct_entry =
-    MSEident of module_path
-  | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
-  | MSEwith of module_struct_entry * with_declaration
-  | MSEapply of module_struct_entry * module_struct_entry
-
-and with_declaration =
-    With_Module of identifier list * module_path
-  | With_Definition of identifier list * constr
-
-and module_entry =
-    { mod_entry_type : module_struct_entry option;
-      mod_entry_expr : module_struct_entry option}
-
-
diff --git a/kernel/entries.mli b/kernel/entries.mli
index 5782d092..303d27d3 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.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        *)
 (************************************************************************)
 
 open Names
-open Univ
 open Term
-open Sign
 
 (** This module defines the entry types for global declarations. This
    information is entered in the environments. This includes global
@@ -37,47 +35,64 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1];
 *)
 
 type one_inductive_entry = {
-  mind_entry_typename : identifier;
+  mind_entry_typename : Id.t;
   mind_entry_arity : constr;
-  mind_entry_consnames : identifier list;
+  mind_entry_template : bool; (* Use template polymorphism *)
+  mind_entry_consnames : Id.t list;
   mind_entry_lc : constr list }
 
 type mutual_inductive_entry = {
-  mind_entry_record : bool;
-  mind_entry_finite : bool;
-  mind_entry_params : (identifier * local_entry) list;
-  mind_entry_inds : one_inductive_entry list }
+  mind_entry_record : (Id.t option) option; 
+  (** Some (Some id): primitive record with id the binder name of the record
+      in projections.
+      Some None: non-primitive record *)
+  mind_entry_finite : Decl_kinds.recursivity_kind;
+  mind_entry_params : (Id.t * local_entry) list;
+  mind_entry_inds : one_inductive_entry list;
+  mind_entry_polymorphic : bool; 
+  mind_entry_universes : Univ.universe_context;
+  mind_entry_private : bool option }
 
 (** {6 Constants (Definition/Axiom) } *)
+type proof_output = constr Univ.in_universe_context_set * Declareops.side_effects
+type const_entry_body = proof_output Future.computation
 
 type definition_entry = {
-  const_entry_body   : constr;
-  const_entry_secctx : section_context option;
-  const_entry_type   : types option;
-  const_entry_opaque : bool }
+  const_entry_body   : const_entry_body;
+  (* List of section variables *)
+  const_entry_secctx : Context.section_context option;
+  (* State id on which the completion of type checking is reported *)
+  const_entry_feedback : Stateid.t option;
+  const_entry_type        : types option;
+  const_entry_polymorphic : bool;
+  const_entry_universes   : Univ.universe_context;
+  const_entry_opaque      : bool;
+  const_entry_inline_code : bool }
 
 type inline = int option (* inlining level, None for no inlining *)
 
-type parameter_entry = section_context option * types * inline 
+type parameter_entry = 
+    Context.section_context option * bool * types Univ.in_universe_context * inline 
+
+type projection_entry = {
+  proj_entry_ind : mutual_inductive;
+  proj_entry_arg : int }
 
 type constant_entry =
   | DefinitionEntry of definition_entry
   | ParameterEntry of parameter_entry
+  | ProjectionEntry of projection_entry
 
 (** {6 Modules } *)
 
-type module_struct_entry =
-    MSEident of module_path
-  | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
-  | MSEwith of module_struct_entry * with_declaration
-  | MSEapply of module_struct_entry * module_struct_entry
-
-and with_declaration =
-    With_Module of identifier list * module_path
-  | With_Definition of identifier list * constr
+type module_struct_entry = Declarations.module_alg_expr
 
-and module_entry =
-    { mod_entry_type : module_struct_entry option;
-      mod_entry_expr : module_struct_entry option}
+type module_params_entry =
+  (MBId.t * module_struct_entry) list (** older first *)
 
+type module_type_entry = module_params_entry * module_struct_entry
 
+type module_entry =
+  | MType of module_params_entry * module_struct_entry
+  | MExpr of
+      module_params_entry * module_struct_entry * module_struct_entry option
diff --git a/kernel/environ.ml b/kernel/environ.ml
index b8818950..0ebff440 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.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        *)
@@ -20,11 +20,12 @@
 (* This file defines the type of environments on which the
    type-checker works, together with simple related functions *)
 
+open Errors
 open Util
 open Names
-open Sign
-open Univ
 open Term
+open Context
+open Vars
 open Declarations
 open Pre_env
 
@@ -36,20 +37,33 @@ type env = Pre_env.env
 
 let pre_env env = env
 let env_of_pre_env env = env
+let oracle env = env.env_conv_oracle
+let set_oracle env o = { env with env_conv_oracle = o }
 
 let empty_named_context_val = empty_named_context_val
 
 let empty_env = empty_env
 
 let engagement env = env.env_stratification.env_engagement
+
+let type_in_type env = env.env_stratification.env_type_in_type
+
+let is_impredicative_set env = 
+  match engagement env with
+  | Some ImpredicativeSet -> true
+  | _ -> false
+
 let universes env = env.env_stratification.env_universes
 let named_context env = env.env_named_context
 let named_context_val env = env.env_named_context,env.env_named_vals
 let rel_context env = env.env_rel_context
+let opaque_tables env = env.indirect_pterms
+let set_opaque_tables env indirect_pterms = { env with indirect_pterms }
 
 let empty_context env =
-  env.env_rel_context = empty_rel_context
-  && env.env_named_context = empty_named_context
+  match env.env_rel_context, env.env_named_context with
+  | [], [] -> true
+  | _ -> false
 
 (* Rel context *)
 let lookup_rel n env =
@@ -64,10 +78,10 @@ let nb_rel env = env.env_nb_rel
 
 let push_rel = push_rel
 
-let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x
+let push_rel_context ctxt x = Context.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
 
 let fold_rel_context f env ~init =
@@ -92,21 +106,29 @@ let named_vals_of_val = snd
    each declarations.
    *** /!\ ***   [f t] should be convertible with t *)
 let map_named_val f (ctxt,ctxtv) =
-  let ctxt =
-    List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in
-  (ctxt,ctxtv)
+  let rec map ctx = match ctx with
+  | [] -> []
+  | (id, body, typ) :: rem ->
+    let body' = Option.smartmap f body in
+    let typ' = f typ in
+    let rem' = map rem in
+    if body' == body && typ' == typ && rem' == rem then ctx
+    else (id, body', typ') :: rem'
+  in
+  (map ctxt, ctxtv)
 
 let empty_named_context = empty_named_context
 
 let push_named = push_named
+let push_named_context = List.fold_right push_named
 let push_named_context_val = push_named_context_val
 
 let val_of_named_context ctxt =
   List.fold_right push_named_context_val ctxt empty_named_context_val
 
 
-let lookup_named id env = Sign.lookup_named id env.env_named_context
-let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
+let lookup_named id env = Context.lookup_named id env.env_named_context
+let lookup_named_val id (ctxt,_) = Context.lookup_named id ctxt
 
 let eq_named_context_val c1 c2 =
    c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
@@ -134,6 +156,12 @@ let reset_with_named_context (ctxt,ctxtv) env =
 
 let reset_context = reset_with_named_context empty_named_context_val
 
+let pop_rel_context n env =
+  let ctxt = env.env_rel_context in
+  { env with
+    env_rel_context = List.firstn (List.length ctxt - n) ctxt;
+    env_nb_rel = env.env_nb_rel - n }
+
 let fold_named_context f env ~init =
   let rec fold_right env =
     match env.env_named_context with
@@ -145,77 +173,210 @@ let fold_named_context f env ~init =
   in fold_right env
 
 let fold_named_context_reverse f ~init env =
-  Sign.fold_named_context_reverse f ~init:init (named_context env)
+  Context.fold_named_context_reverse f ~init:init (named_context env)
+
+
+(* Universe constraints *)
+
+let add_constraints c env =
+  if Univ.Constraint.is_empty c then
+    env
+  else
+    let s = env.env_stratification in
+    { env with env_stratification =
+      { s with env_universes = Univ.merge_constraints c s.env_universes } }
+
+let check_constraints c env =
+  Univ.check_constraints c env.env_stratification.env_universes
+
+let set_engagement c env = (* Unsafe *)
+  { env with env_stratification =
+    { env.env_stratification with env_engagement = Some c } }
+
+let set_type_in_type env =
+  { env with env_stratification =
+    { env.env_stratification with env_type_in_type = true } }
+
+let push_constraints_to_env (_,univs) env =
+  add_constraints univs env
+
+let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env
+let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env
 
 (* Global constants *)
 
 let lookup_constant = lookup_constant
 
-let add_constant kn cs env =
+let no_link_info = NotLinked
+
+let add_constant_key kn cb linkinfo env =
   let new_constants =
-    Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in
+    Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.env_constants in
   let new_globals =
     { env.env_globals with
 	env_constants = new_constants } in
   { env with env_globals = new_globals }
 
+let add_constant kn cb env =
+  add_constant_key kn cb no_link_info env
+
+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 =
+let constant_type env (kn,u) =
   let cb = lookup_constant kn env in
-    cb.const_type
+    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
 
-type const_evaluation_result = NoBody | Opaque
+let constant_context env kn =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then cb.const_universes
+    else Univ.UContext.empty
+
+type const_evaluation_result = NoBody | Opaque | IsProj
 
 exception NotEvaluableConst of const_evaluation_result
 
-let constant_value env kn =
+let constant_value env (kn,u) =
+  let cb = lookup_constant kn env in
+    if cb.const_proj = None then
+      match cb.const_body with
+      | Def l_body -> 
+	if cb.const_polymorphic then
+	  let csts = constraints_of cb u in
+	    (subst_instance_constr u (Mod_subst.force_constr l_body), csts)
+	else Mod_subst.force_constr l_body, Univ.Constraint.empty
+      | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+      | Undef _ -> raise (NotEvaluableConst NoBody)
+    else raise (NotEvaluableConst IsProj)
+
+let constant_opt_value env cst =
+  try Some (constant_value env cst)
+  with NotEvaluableConst _ -> None
+
+let constant_value_and_type env (kn, u) =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then
+      let cst = constraints_of cb u in
+      let b' = match cb.const_body with
+	| Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body))
+	| OpaqueDef _ -> None
+	| Undef _ -> None
+      in
+	b', map_regular_arity (subst_instance_constr u) cb.const_type, cst
+    else 
+      let b' = match cb.const_body with
+	| Def l_body -> Some (Mod_subst.force_constr l_body)
+	| OpaqueDef _ -> None
+	| Undef _ -> None
+      in b', cb.const_type, Univ.Constraint.empty
+
+(* These functions should be called under the invariant that [env] 
+   already contains the constraints corresponding to the constant 
+   application. *)
+
+(* constant_type gives the type of a constant *)
+let constant_type_in env (kn,u) =
+  let cb = lookup_constant kn env in
+    if cb.const_polymorphic then
+      map_regular_arity (subst_instance_constr u) cb.const_type
+    else cb.const_type
+
+let constant_value_in env (kn,u) =
   let cb = lookup_constant kn env in
   match cb.const_body with
-    | Def l_body -> Declarations.force l_body
+    | Def l_body -> 
+      let b = Mod_subst.force_constr l_body in
+	subst_instance_constr u b
     | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
     | Undef _ -> raise (NotEvaluableConst NoBody)
 
-let constant_opt_value env cst =
-  try Some (constant_value env cst)
+let constant_opt_value_in env cst =
+  try Some (constant_value_in env cst)
   with NotEvaluableConst _ -> None
 
 (* A global const is evaluable if it is defined and not opaque *)
-let evaluable_constant cst env =
-  try let _  = constant_value env cst in true
-  with NotEvaluableConst _ -> false
+let evaluable_constant kn env =
+  let cb = lookup_constant kn env in
+    match cb.const_body with
+    | Def _ -> true
+    | OpaqueDef _ -> false
+    | Undef _ -> false
+
+let polymorphic_constant cst env =
+  (lookup_constant cst env).const_polymorphic
+
+let polymorphic_pconstant (cst,u) env =
+  if Univ.Instance.is_empty u then false
+  else polymorphic_constant cst env
+
+let template_polymorphic_constant cst env =
+  match (lookup_constant cst env).const_type with 
+  | TemplateArity _ -> true
+  | RegularArity _ -> false
+
+let template_polymorphic_pconstant (cst,u) env =
+  if not (Univ.Instance.is_empty u) then false
+  else template_polymorphic_constant cst env
+
+let lookup_projection cst env =
+  match (lookup_constant (Projection.constant cst) env).const_proj with 
+  | Some pb -> pb
+  | None -> anomaly (Pp.str "lookup_projection: constant is not a projection")
+
+let is_projection cst env =
+  match (lookup_constant cst env).const_proj with 
+  | Some _ -> true
+  | None -> false
 
 (* Mutual Inductives *)
 let lookup_mind = lookup_mind
+
+let polymorphic_ind (mind,i) env =
+  (lookup_mind mind env).mind_polymorphic
+
+let polymorphic_pind (ind,u) env =
+  if Univ.Instance.is_empty u then false
+  else polymorphic_ind ind env
+
+let template_polymorphic_ind (mind,i) env =
+  match (lookup_mind mind env).mind_packets.(i).mind_arity with 
+  | TemplateArity _ -> true
+  | RegularArity _ -> false
+
+let template_polymorphic_pind (ind,u) env =
+  if not (Univ.Instance.is_empty u) then false
+  else template_polymorphic_ind ind env
   
-let add_mind kn mib env =
-  let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in
+let add_mind_key kn mind_key env =
+  let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in
   let new_globals =
     { env.env_globals with
 	env_inductives = new_inds } in
   { env with env_globals = new_globals }
 
-(* Universe constraints *)
-
-let add_constraints c env =
-  if is_empty_constraint c then
-    env
-  else
-    let s = env.env_stratification in
-    { env with env_stratification =
-      { s with env_universes = merge_constraints c s.env_universes } }
-
-let set_engagement c env = (* Unsafe *)
-  { env with env_stratification =
-    { env.env_stratification with env_engagement = Some c } }
+let add_mind kn mib env =
+  let li = ref no_link_info in add_mind_key kn (mib, li) env
 
 (* Lookup of section variables *)
+
 let lookup_constant_variables c env =
   let cmap = lookup_constant c env in
-  Sign.vars_of_named_context cmap.const_hyps
+  Context.vars_of_named_context cmap.const_hyps
 
 let lookup_inductive_variables (kn,i) env =
   let mis = lookup_mind kn env in
-  Sign.vars_of_named_context mis.mind_hyps
+  Context.vars_of_named_context mis.mind_hyps
 
 let lookup_constructor_variables (ind,_) env =
   lookup_inductive_variables ind env
@@ -224,10 +385,11 @@ let lookup_constructor_variables (ind,_) env =
 
 let vars_of_global env constr =
   match kind_of_term constr with
-      Var id -> [id]
-    | Const kn -> lookup_constant_variables kn env
-    | Ind ind -> lookup_inductive_variables ind env
-    | Construct cstr -> lookup_constructor_variables cstr env
+      Var id -> Id.Set.singleton id
+    | Const (kn, _) -> lookup_constant_variables kn env
+    | Ind (ind, _) -> lookup_inductive_variables ind env
+    | Construct (cstr, _) -> lookup_constructor_variables cstr env
+    (** FIXME: is Proj missing? *)
     | _ -> raise Not_found
 
 let global_vars_set env constr =
@@ -235,54 +397,54 @@ let global_vars_set env constr =
     let acc =
       match kind_of_term c with
       | Var _ | Const _ | Ind _ | Construct _ ->
-	  List.fold_right Idset.add (vars_of_global env c) acc
+	  Id.Set.union (vars_of_global env c) acc
       | _ ->
 	  acc in
     fold_constr filtrec acc c
   in
-    filtrec Idset.empty constr
+    filtrec Id.Set.empty constr
 
 
 (* [keep_hyps env ids] keeps the part of the section context of [env] which
    contains the variables of the set [ids], and recursively the variables
    contained in the types of the needed variables. *)
 
+let really_needed env needed =
+  Context.fold_named_context_reverse
+    (fun need (id,copt,t) ->
+      if Id.Set.mem id need then
+        let globc =
+          match copt with
+            | None -> Id.Set.empty
+            | Some c -> global_vars_set env c in
+        Id.Set.union
+          (global_vars_set env t)
+          (Id.Set.union globc need)
+      else need)
+    ~init:needed
+    (named_context env)
+
 let keep_hyps env needed =
-  let really_needed =
-    Sign.fold_named_context_reverse
-      (fun need (id,copt,t) ->
-        if Idset.mem id need then
-          let globc =
-	    match copt with
-	      | None -> Idset.empty
-	      | Some c -> global_vars_set env c in
-	  Idset.union
-            (global_vars_set env t)
-	    (Idset.union globc need)
-        else need)
-      ~init:needed
-      (named_context env) in
-  Sign.fold_named_context
+  let really_needed = really_needed env needed in
+  Context.fold_named_context
     (fun (id,_,_ as d) nsign ->
-      if Idset.mem id really_needed then add_named_decl d nsign
+      if Id.Set.mem id really_needed then add_named_decl d nsign
       else nsign)
     (named_context env)
     ~init:empty_named_context
 
 (* Modules *)
 
-let add_modtype ln mtb env =
-  let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in
-  let new_globals =
-    { env.env_globals with
-	env_modtypes = new_modtypes } in
+let add_modtype mtb env =
+  let mp = mtb.mod_mp in
+  let new_modtypes = MPmap.add mp mtb env.env_globals.env_modtypes in
+  let new_globals = { env.env_globals with env_modtypes = new_modtypes } in
   { env with env_globals = new_globals }
 
-let shallow_add_module mp mb env =
+let shallow_add_module mb env =
+  let mp = mb.mod_mp in
   let new_mods = MPmap.add mp mb env.env_globals.env_modules in
-  let new_globals =
-    { env.env_globals with
-	env_modules = new_mods } in
+  let new_globals = { env.env_globals with env_modules = new_mods } in
   { env with env_globals = new_globals }
 
 let lookup_module mp env =
@@ -315,11 +477,11 @@ let compile_constant_body = Cbytegen.compile_constant_body
 
 exception Hyp_not_found
 
-let rec apply_to_hyp (ctxt,vals) id f =
+let apply_to_hyp (ctxt,vals) id f =
   let rec aux rtail ctxt vals =
     match ctxt, vals with
     | (idc,c,ct as d)::ctxt, v::vals ->
-	if idc = id then
+	if Id.equal idc id then
 	  (f ctxt d rtail)::ctxt, v::vals
 	else
 	  let ctxt',vals' = aux (d::rtail) ctxt vals in
@@ -328,11 +490,11 @@ let rec apply_to_hyp (ctxt,vals) id f =
     | _, _ -> assert false
   in aux [] ctxt vals
 
-let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
+let apply_to_hyp_and_dependent_on (ctxt,vals) id f g =
   let rec aux ctxt vals =
     match ctxt,vals with
     | (idc,c,ct as d)::ctxt, v::vals ->
-	if idc = id then
+	if Id.equal idc id then
 	  let sign = ctxt,vals in
 	  push_named_context_val (f d sign) sign
 	else
@@ -346,7 +508,7 @@ let insert_after_hyp (ctxt,vals) id d check =
   let rec aux ctxt vals =
     match  ctxt, vals with
     | (idc,c,ct)::ctxt', v::vals' ->
-	if idc = id then begin
+	if Id.equal idc id then begin
 	  check ctxt;
 	  push_named_context_val d (ctxt,vals)
 	end else
@@ -359,18 +521,22 @@ let insert_after_hyp (ctxt,vals) id d check =
 
 (* To be used in Logic.clear_hyps *)
 let remove_hyps ids check_context check_value (ctxt, vals) =
-  List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) ->
-      if List.mem id ids then
-	(ctxt,vals)
-      else
-	let nd = check_context d in
-	let nv = check_value v in
-	  (nd::ctxt,(id',nv)::vals))
-		     ctxt vals ([],[])
-
-
-
-
+  let rec remove_hyps ctxt vals = match ctxt, vals with
+  | [], [] -> [], []
+  | d :: rctxt, (nid, v) :: rvals ->
+    let (id, _, _) = d in
+    let ans = remove_hyps rctxt rvals in
+    if Id.Set.mem id ids then ans
+    else
+      let (rctxt', rvals') = ans in
+      let d' = check_context d in
+      let v' = check_value v in
+      if d == d' && v == v' && rctxt == rctxt' && rvals == rvals' then
+        ctxt, vals
+      else (d' :: rctxt', (nid, v') :: rvals')
+  | _ -> assert false
+  in
+  remove_hyps ctxt vals
 
 (*spiwack: the following functions assemble the pieces of the retroknowledge
    note that the "consistent" register function is available in the module
@@ -385,35 +551,23 @@ let retroknowledge f env =
 let registered env field =
     retroknowledge mem env field
 
-(* spiwack: this unregistration function is not in operation yet. It should
-            not be used *)
-(* this unregistration function assumes that no "constr" can hold two different
-   places in the retroknowledge. There is no reason why it shouldn't be true,
-   but in case someone needs it, remember to add special branches to the
-   unregister function *)
-let unregister env field =
-  match field with
-    | KInt31 (_,Int31Type) ->
-	(*there is only one matching kind due to the fact that Environ.env
-          is abstract, and that the only function which add elements to the
-          retroknowledge is Environ.register which enforces this shape *)
-	(match retroknowledge find env field with
-	   | Ind i31t -> let i31c = Construct (i31t, 1) in
-	     {env with retroknowledge =
-		 remove (retroknowledge clear_info env i31c) field}
-	   | _ -> assert false)
-    |_ -> {env with retroknowledge =
-	   try
-	     remove (retroknowledge clear_info env
-                       (retroknowledge find env field)) field
-	   with Not_found ->
-	     retroknowledge remove env field}
-
+let register_one env field entry =
+  { env with retroknowledge = Retroknowledge.add_field env.retroknowledge field entry }
 
+(* [register env field entry] may register several fields when needed *)
+let register env field entry =
+  match field with
+    | KInt31 (grp, Int31Type) ->
+        let i31c = match kind_of_term entry with
+                     | Ind i31t -> mkConstructUi (i31t, 1)
+		     | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type")
+	in
+        register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry
+    | field -> register_one env field entry
 
 (* the Environ.register function syncrhonizes the proactive and reactive
    retroknowledge. *)
-let register =
+let dispatch =
 
   (* subfunction used for static decompilation of int31 (after a vm_compute,
      see pretyping/vnorm.ml for more information) *)
@@ -421,7 +575,7 @@ let register =
     let nth_digit_plus_one i n = (* calculates the nth (starting with 0)
                                     digit of i and adds 1 to it
                                     (nth_digit_plus_one 1 3 = 2) *)
-      if (land) i ((lsl) 1 n) = 0 then
+      if Int.equal (i land (1 lsl n)) 0 then
         1
       else
         2
@@ -434,92 +588,94 @@ let register =
 	  mkApp(mkConstruct(ind, 1), array_of_int tag)
   in
 
-  (* subfunction which adds the information bound to the constructor of
-     the int31 type to the reactive retroknowledge *)
-  let add_int31c retroknowledge c =
-    let rk = add_vm_constant_static_info retroknowledge c
-                                         Cbytegen.compile_structured_int31
-    in
-    add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation
-  in
-
-  (* subfunction which adds the compiling information of an
+  (* subfunction which dispatches the compiling information of an
      int31 operation which has a specific vm instruction (associates
      it to the name of the coq definition in the reactive retroknowledge) *)
-  let add_int31_op retroknowledge v n op kn =
-    add_vm_compiling_info retroknowledge v (Cbytegen.op_compilation n op kn)
+  let int31_op n op prim kn =
+    { empty_reactive_info with
+      vm_compiling = Some (Cbytegen.op_compilation n op kn);
+      native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn));
+    }
   in
 
-fun env field value ->
-  (* subfunction which shortens the (very often use) registration of binary
-     operators to the reactive retroknowledge. *)
-  let add_int31_binop_from_const op =
-    match value with
-      | Const kn ->  retroknowledge add_int31_op env value 2
-	                               op kn
-      | _ -> anomaly "Environ.register: should be a constant"
-  in
-  let add_int31_unop_from_const op =
-    match value with
-      | Const kn ->  retroknowledge add_int31_op env value 1
-	                               op kn
-      | _ -> anomaly "Environ.register: should be a constant"
-  in
-  (* subfunction which completes the function constr_of_int31 above
-     by performing the actual retroknowledge operations *)
-  let add_int31_decompilation_from_type rk =
-    (* invariant : the type of bits is registered, otherwise the function
-       would raise Not_found. The invariant is enforced in safe_typing.ml *)
-    match field with
-      | KInt31 (grp, Int31Type) ->
-	  (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with
-	    | Ind i31bit_type ->
-		(match value with
-		  | Ind i31t ->
-		      Retroknowledge.add_vm_decompile_constant_info rk
-		               value (constr_of_int31 i31t i31bit_type)
-		  | _ -> anomaly "Environ.register: should be an inductive type")
-	    | _ -> anomaly "Environ.register: Int31Bits should be an inductive type")
-      | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field"
+fun rk value field ->
+  (* subfunction which shortens the (very common) dispatch of operations *)
+  let int31_op_from_const n op prim =
+    match kind_of_term value with
+      | Const kn ->  int31_op n op prim kn
+      | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")
   in
-  {env with retroknowledge =
-  let retroknowledge_with_reactive_info =
+  let int31_binop_from_const op prim = int31_op_from_const 2 op prim in
+  let int31_unop_from_const op prim = int31_op_from_const 1 op prim in
   match field with
-    | KInt31 (_, Int31Type) ->
-        let i31c = match value with
-                     | Ind i31t -> (Construct (i31t, 1))
-		     | _ -> anomaly "Environ.register: should be an inductive type"
-	in
-	add_int31_decompilation_from_type
-	  (add_vm_before_match_info
-	     (retroknowledge add_int31c env i31c)
-	     value Cbytegen.int31_escape_before_match)
-    | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31
-    | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31
-    | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31
-    | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31
-    | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31
-    | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const
-	                                           Cbytecodes.Ksubcarrycint31
-    | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31
-    | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31
-    | KInt31 (_, Int31Div21) -> (* this is a ternary operation *)
-                                (match value with
-				 | Const kn ->
-				     retroknowledge add_int31_op env value 3
-	                               Cbytecodes.Kdiv21int31 kn
-				 | _ -> anomaly "Environ.register: should be a constant")
-    | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31
-    | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *)
-                                (match value with
-				 | Const kn ->
-				     retroknowledge add_int31_op env value 3
-	                               Cbytecodes.Kaddmuldivint31 kn
-				 | _ -> anomaly "Environ.register: should be a constant")
-    | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31
-    | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31
-    | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31
-    | _ -> env.retroknowledge
-  in
-  Retroknowledge.add_field retroknowledge_with_reactive_info field value
-  }
+    | KInt31 (grp, Int31Type) ->
+        let int31bit =
+          (* invariant : the type of bits is registered, otherwise the function
+             would raise Not_found. The invariant is enforced in safe_typing.ml *)
+          match field with
+          | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits))
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "add_int31_decompilation_from_type called with an abnormal field")
+        in
+        let i31bit_type =
+          match kind_of_term int31bit with
+          | Ind (i31bit_type,_) -> i31bit_type
+          |  _ -> anomaly ~label:"Environ.register"
+              (Pp.str "Int31Bits should be an inductive type")
+        in
+        let int31_decompilation =
+          match kind_of_term value with
+          | Ind (i31t,_) ->
+              constr_of_int31 i31t i31bit_type
+          | _ -> anomaly ~label:"Environ.register"
+              (Pp.str "should be an inductive type")
+        in
+        { empty_reactive_info with
+          vm_decompile_const = Some int31_decompilation;
+          vm_before_match = Some Cbytegen.int31_escape_before_match;
+          native_before_match = Some (Nativelambda.before_match_int31 i31bit_type);
+        }
+    | KInt31 (_, Int31Constructor) ->
+        { empty_reactive_info with
+          vm_constant_static = Some Cbytegen.compile_structured_int31;
+          vm_constant_dynamic = Some Cbytegen.dynamic_int31_compilation;
+          native_constant_static = Some Nativelambda.compile_static_int31;
+          native_constant_dynamic = Some Nativelambda.compile_dynamic_int31;
+        }
+    | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31
+							  Primitives.Int31add
+    | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31
+							   Primitives.Int31addc
+    | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31
+								Primitives.Int31addcarryc
+    | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31
+							   Primitives.Int31sub
+    | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31
+							    Primitives.Int31subc
+    | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const
+	                                Cbytecodes.Ksubcarrycint31 Primitives.Int31subcarryc
+    | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31
+							   Primitives.Int31mul
+    | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31
+							   Primitives.Int31mulc
+    | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31
+                                                           Primitives.Int31div21
+    | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31
+							 Primitives.Int31diveucl
+    | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31
+                                                         Primitives.Int31addmuldiv
+    | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31
+							     Primitives.Int31compare
+    | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31
+							  Primitives.Int31head0
+    | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31
+							  Primitives.Int31tail0
+    | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31
+							 Primitives.Int31lor
+    | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31
+							  Primitives.Int31land
+    | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31
+							  Primitives.Int31lxor
+    | _ -> empty_reactive_info
+
+let _ = Hook.set Retroknowledge.dispatch_hook dispatch
diff --git a/kernel/environ.mli b/kernel/environ.mli
index 76e3ecf0..de960ecc 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.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,8 +8,9 @@
 
 open Names
 open Term
+open Context
 open Declarations
-open Sign
+open Univ
 
 (** Unsafe environments. We define here a datatype for environments.
    Since typing is not yet defined, it is not possible to check the
@@ -32,6 +33,8 @@ open Sign
 type env
 val pre_env : env -> Pre_env.env
 val env_of_pre_env : Pre_env.env -> env
+val oracle : env -> Conv_oracle.oracle
+val set_oracle : env -> Conv_oracle.oracle -> env
 
 type named_context_val
 val eq_named_context_val : named_context_val -> named_context_val -> bool
@@ -43,8 +46,14 @@ val rel_context   : env -> rel_context
 val named_context : env -> named_context
 val named_context_val : env -> named_context_val
 
+val opaque_tables : env -> Opaqueproof.opaquetab
+val set_opaque_tables : env -> Opaqueproof.opaquetab -> env
+
 
 val engagement    : env -> engagement option
+val is_impredicative_set : env -> bool
+
+val type_in_type  : env -> bool
 
 (** is the local context empty *)
 val empty_context : env -> bool
@@ -81,13 +90,14 @@ val map_named_val :
    (constr -> constr) -> named_context_val -> named_context_val
 
 val push_named : named_declaration -> env -> env
+val push_named_context : named_context -> env -> env
 val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 
 
 
 (** Looks up in the context of local vars referred by names ([named_context]) 
-   raises [Not_found] if the identifier is not found *)
+   raises [Not_found] if the Id.t is not found *)
 
 val lookup_named     : variable -> env -> named_declaration
 val lookup_named_val : variable -> named_context_val -> named_declaration
@@ -110,63 +120,118 @@ val reset_context : env -> env
 (** This forgets rel context and sets a new named context *)
 val reset_with_named_context : named_context_val -> env -> env
 
+(** This removes the [n] last declarations from the rel context *)
+val pop_rel_context : int -> env -> env
+
 (** {5 Global constants }
   {6 Add entries to global environment } *)
 
 val add_constant : constant -> constant_body -> env -> env
+val add_constant_key : constant -> constant_body -> Pre_env.link_info ->
+  env -> env
 
 (** Looks up in the context of global constant names 
    raises [Not_found] if the required path is not found *)
 val lookup_constant    : constant -> env -> constant_body
 val evaluable_constant : constant -> env -> bool
 
+(** New-style polymorphism *)
+val polymorphic_constant  : constant -> env -> bool
+val polymorphic_pconstant : pconstant -> env -> bool
+
+(** Old-style polymorphism *)
+val template_polymorphic_constant  : constant -> env -> bool
+val template_polymorphic_pconstant : pconstant -> env -> bool
+
 (** {6 ... } *)
 (** [constant_value env c] raises [NotEvaluableConst Opaque] if
    [c] is opaque and [NotEvaluableConst NoBody] if it has no
-   body and [Not_found] if it does not exist in [env] *)
+   body and [NotEvaluableConst IsProj] if [c] is a projection 
+   and [Not_found] if it does not exist in [env] *)
 
-type const_evaluation_result = NoBody | Opaque
+type const_evaluation_result = NoBody | Opaque | IsProj
 exception NotEvaluableConst of const_evaluation_result
 
-val constant_value     : env -> constant -> constr
-val constant_type      : env -> constant -> constant_type
-val constant_opt_value : env -> constant -> constr option
+val constant_value : env -> constant puniverses -> constr constrained
+val constant_type : env -> constant puniverses -> constant_type constrained
 
-(** {5 Inductive types } *)
+val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option
+val constant_value_and_type : env -> constant puniverses -> 
+  constr option * constant_type * Univ.constraints
+(** The universe context associated to the constant, empty if not 
+    polymorphic *)
+val constant_context : env -> constant -> Univ.universe_context
+
+(* These functions should be called under the invariant that [env] 
+   already contains the constraints corresponding to the constant 
+   application. *)
+val constant_value_in : env -> constant puniverses -> constr
+val constant_type_in : env -> constant puniverses -> constant_type
+val constant_opt_value_in : env -> constant puniverses -> constr option
+
+(** {6 Primitive projections} *)
+
+val lookup_projection    : Names.projection -> env -> projection_body
+val is_projection : constant -> env -> bool
 
+(** {5 Inductive types } *)
+val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env
 val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
 
 (** Looks up in the context of global inductive names 
    raises [Not_found] if the required path is not found *)
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
 
+(** New-style polymorphism *)
+val polymorphic_ind  : inductive -> env -> bool
+val polymorphic_pind : pinductive -> env -> bool
+
+(** Old-style polymorphism *)
+val template_polymorphic_ind : inductive -> env -> bool
+val template_polymorphic_pind : pinductive -> env -> bool
+
 (** {5 Modules } *)
 
-val add_modtype : module_path -> module_type_body -> env -> env
+val add_modtype : module_type_body -> env -> env
 
 (** [shallow_add_module] does not add module components *)
-val shallow_add_module : module_path -> module_body -> env -> env
+val shallow_add_module : module_body -> env -> env
 
 val lookup_module : module_path -> env -> module_body
 val lookup_modtype : module_path -> env -> module_type_body
 
 (** {5 Universe constraints } *)
 
+(** Add universe constraints to the environment.
+    @raises UniverseInconsistency
+*)
 val add_constraints : Univ.constraints -> env -> env
 
+(** Check constraints are satifiable in the environment. *)
+val check_constraints : Univ.constraints -> env -> bool
+val push_context : Univ.universe_context -> env -> env
+val push_context_set : Univ.universe_context_set -> env -> env
+val push_constraints_to_env : 'a Univ.constrained -> env -> env
+
 val set_engagement : engagement -> env -> env
 
+val set_type_in_type : env -> env
+
 (** {6 Sets of referred section variables }
    [global_vars_set env c] returns the list of [id]'s occurring either
    directly as [Var id] in [c] or indirectly as a section variable
    dependent in a global reference occurring in [c] *)
 
-val global_vars_set : env -> constr -> Idset.t
+val global_vars_set : env -> constr -> Id.Set.t
 
 (** the constr must be a global reference *)
-val vars_of_global : env -> constr -> identifier list
+val vars_of_global : env -> constr -> Id.Set.t
+
+(** closure of the input id set w.r.t. dependency *)
+val really_needed : env -> Id.Set.t -> Id.Set.t
 
-val keep_hyps : env -> Idset.t -> section_context
+(** like [really_needed] but computes a well ordered named context *)
+val keep_hyps : env -> Id.Set.t -> section_context
 
 (** {5 Unsafe judgments. }
     We introduce here the pre-type of judgments, which is
@@ -211,7 +276,7 @@ val insert_after_hyp : named_context_val -> variable ->
   named_declaration ->
     (named_context -> unit) -> named_context_val
 
-val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
+val remove_hyps : Id.Set.t -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
 
 
 
@@ -222,8 +287,7 @@ val retroknowledge : (retroknowledge->'a) -> env -> 'a
 
 val registered : env -> field -> bool
 
-val unregister : env -> field -> env
-
 val register : env -> field -> Retroknowledge.entry -> env
 
-
+(** Native compiler *)
+val no_link_info : Pre_env.link_info
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 5bb34253..42ca48ef 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.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        *)
@@ -29,14 +29,14 @@ let el_id = ELID
 let rec el_shft_rec n = function
   | ELSHFT(el,k) -> el_shft_rec (k+n) el
   | el           -> ELSHFT(el,n)
-let el_shft n el = if n = 0 then el else el_shft_rec n el
+let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el
 
 (* cross n binders *)
 let rec el_liftn_rec n = function
   | ELID        -> ELID
   | ELLFT(k,el) -> el_liftn_rec (n+k) el
   | el          -> ELLFT(n, el)
-let el_liftn n el = if n = 0 then el else el_liftn_rec n el
+let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el
 
 let el_lift el = el_liftn_rec 1 el
 
@@ -49,7 +49,7 @@ let rec reloc_rel n = function
 
 let rec is_lift_id = function
   | ELID -> true
-  | ELSHFT(e,n) -> n=0 & is_lift_id e
+  | ELSHFT(e,n) -> Int.equal n 0 && is_lift_id e
   | ELLFT (_,e) -> is_lift_id e
 
 (*********************)
@@ -73,7 +73,7 @@ type 'a subs =
 
 let subs_id i = ESID i
 
-let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
+let subs_cons(x,s) = if Int.equal (Array.length x) 0 then s else CONS(x,s)
 
 let subs_liftn n = function
   | ESID p        -> ESID (p+n) (* bounded identity lifted extends by p *)
@@ -81,13 +81,13 @@ let subs_liftn n = function
   | lenv          -> LIFT (n,lenv)
 
 let subs_lift a = subs_liftn 1 a
-let subs_liftn n a = if n = 0 then a else subs_liftn n a
+let subs_liftn n a = if Int.equal n 0 then a else subs_liftn n a
 
 let subs_shft = function
   | (0, s)            -> s
   | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1)
   | (n, s)            -> SHIFT (n,s)
-let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a)
+let subs_shft s = if Int.equal (fst s) 0 then snd s else subs_shft s
 
 let subs_shift_cons = function
   (0, s, t)           -> CONS(t,s)
@@ -99,7 +99,7 @@ let rec is_subs_id = function
     ESID _     -> true
   | LIFT(_,s)  -> is_subs_id s
   | SHIFT(0,s) -> is_subs_id s
-  | CONS(x,s)  -> Array.length x = 0 && is_subs_id s
+  | CONS(x,s)  -> Int.equal (Array.length x) 0 && is_subs_id s
   | _          -> false
 
 (* Expands de Bruijn k in the explicit substitution subs
@@ -136,7 +136,7 @@ let rec comp mk_cl s1 s2 =
     | ESID _, _ -> s2
     | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2)
     | _, CONS(x,s') ->
-        CONS(Array.map (fun t -> mk_cl(s1,t)) x, comp mk_cl s1 s')
+        CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s')
     | CONS(x,s), SHIFT(k,s') ->
         let lg = Array.length x in
         if k == lg then comp mk_cl s s'
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index c3980c30..2b34da4d 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.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/kernel/evar.ml b/kernel/evar.ml
new file mode 100644
index 00000000..54f15df4
--- /dev/null
+++ b/kernel/evar.ml
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  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 t = int
+
+let repr x = x
+let unsafe_of_int x = x
+let compare = Int.compare
+let equal = Int.equal
+let hash = Int.hash
+
+module Set = Int.Set
+module Map = Int.Map
diff --git a/kernel/evar.mli b/kernel/evar.mli
new file mode 100644
index 00000000..2c94db3f
--- /dev/null
+++ b/kernel/evar.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module defines existential variables, which are isomorphic to [int].
+    Nonetheless, casting from an [int] to a variable is deemed unsafe, so that
+    to keep track of such casts, one has to use the provided {!unsafe_of_int}
+    function. *)
+
+type t
+(** Type of existential variables. *)
+
+val repr : t -> int
+(** Recover the underlying integer. *)
+
+val unsafe_of_int : int -> t
+(** This is not for dummies. Do not use this function if you don't know what you
+    are doing. *)
+
+val equal : t -> t -> bool
+(** Equality over existential variables. *)
+
+val compare : t -> t -> int
+(** Comparison over existential variables. *)
+
+val hash : t -> int
+(** Hash over existential variables. *)
+
+module Set : Set.S with type elt = t
+module Map : CMap.ExtS with type key = t and module Set := Set
diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml
new file mode 100644
index 00000000..86fb1b64
--- /dev/null
+++ b/kernel/fast_typeops.ml
@@ -0,0 +1,461 @@
+(************************************************************************)
+(*  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 Errors
+open Util
+open Names
+open Univ
+open Term
+open Vars
+open Declarations
+open Environ
+open Reduction
+open Inductive
+open Type_errors
+
+let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
+
+let conv_leq_vecti env v1 v2 =
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq false env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
+    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 t =
+  match kind_of_term(whd_betadeltaiota env t) with
+    | Sort s -> {utj_val = c; utj_type = s }
+    | _ -> error_not_type env (make_judge c t)
+
+let check_type env c t =
+  match kind_of_term(whd_betadeltaiota env t) with
+  | Sort s -> s
+  | _ -> error_not_type env (make_judge c t)
+
+(* This should be a type intended to be assumed. The error message is *)
+(* not as useful as for [type_judgment]. *)
+let assumption_of_judgment env t ty =
+  try let _ = check_type env t ty in t
+  with TypeError _ ->
+    error_assumption env (make_judge t ty)
+
+(************************************************)
+(* Incremental typing rules: builds a typing judgement given the *)
+(* judgements for the subterms. *)
+
+(*s Type of sorts *)
+
+(* Prop and Set *)
+
+let judge_of_prop = mkSort type1_sort
+
+let judge_of_prop_contents _ = judge_of_prop
+
+(* Type of Type(i). *)
+
+let judge_of_type u =
+  let uu = Universe.super u in
+    mkType uu
+
+(*s Type of a de Bruijn index. *)
+
+let judge_of_relative env n =
+  try
+    let (_,_,typ) = lookup_rel n env in
+      lift n typ
+  with Not_found ->
+    error_unbound_rel env n
+
+(* Type of variables *)
+let judge_of_variable env id =
+  try named_type id env
+  with Not_found ->
+    error_unbound_var env id
+
+(* Management of context of variables. *)
+
+(* Checks if a context of variables can be instantiated by the
+   variables of the current env *)
+(* TODO: check order? *)
+let check_hyps_inclusion env f c sign =
+  Context.fold_named_context
+    (fun (id,_,ty1) () ->
+      try
+        let ty2 = named_type id env in
+        if not (eq_constr ty2 ty1) then raise Exit
+      with Not_found | Exit ->
+        error_reference_variables env id (f c))
+    sign
+    ~init:()
+
+(* Instantiation of terms on real arguments. *)
+
+(* Make a type polymorphic if an arity *)
+
+(* Type of constants *)
+
+
+let type_of_constant_knowing_parameters_arity env t paramtyps =
+  match t with
+  | 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_knowing_parameters_arity env ty paramtyps, cu
+
+let judge_of_constant_knowing_parameters env (kn,u as cst) args =
+  let cb = lookup_constant kn env in
+  let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in
+  let ty, cu = type_of_constant_knowing_parameters env cst args in
+  let () = check_constraints cu env in
+    ty
+
+let judge_of_constant env cst =
+  judge_of_constant_knowing_parameters env cst [||]
+
+(* Type of a lambda-abstraction. *)
+
+(* [judge_of_abstraction env name var j] implements the rule
+
+ env, name:typ |- j.uj_val:j.uj_type     env, |- (name:typ)j.uj_type : s
+ -----------------------------------------------------------------------
+          env |- [name:typ]j.uj_val : (name:typ)j.uj_type
+
+  Since all products are defined in the Calculus of Inductive Constructions
+  and no upper constraint exists on the sort $s$, we don't need to compute $s$
+*)
+
+let judge_of_abstraction env name var ty =
+  mkProd (name, var, ty)
+
+(* Type of an application. *)
+
+let make_judgev c t = 
+  Array.map2 make_judge c t
+
+let judge_of_apply env func funt argsv argstv =
+  let len = Array.length argsv in
+  let rec apply_rec i typ = 
+    if Int.equal i len then typ
+    else 
+      (match kind_of_term (whd_betadeltaiota env typ) with
+      | Prod (_,c1,c2) ->
+	let arg = argsv.(i) and argt = argstv.(i) in
+	  (try
+	     let () = conv_leq false env argt c1 in
+	       apply_rec (i+1) (subst1 arg c2)
+	   with NotConvertible ->
+	     error_cant_apply_bad_type env
+	       (i+1,c1,argt)
+	       (make_judge func funt)
+	       (make_judgev argsv argstv))
+	    
+      | _ ->
+	error_cant_apply_not_functional env 
+	  (make_judge func funt)
+	  (make_judgev argsv argstv))
+  in apply_rec 0 funt
+
+(* Type of product *)
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *)
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        begin match engagement env with
+        | Some ImpredicativeSet ->
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        | _ ->
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          Type (Universe.sup Universe.type0 u1)
+        end
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Pos,  Type u2)  -> Type (Universe.sup Universe.type0 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 (Universe.sup u1 u2)
+
+(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
+
+    env |- typ1:s1       env, name:typ1 |- typ2 : s2
+    -------------------------------------------------------------------------
+         s' >= (s1,s2), env |- (name:typ)j.uj_val : s'
+
+  where j.uj_type is convertible to a sort s2
+*)
+let judge_of_product env name s1 s2 =
+  let s = sort_of_product env s1 s2 in
+    mkSort s
+
+(* Type of a type cast *)
+
+(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule
+
+    env |- c:typ1    env |- typ2:s    env |- typ1 <= typ2
+    ---------------------------------------------------------------------
+         env |- c:typ2
+*)
+
+let judge_of_cast env c ct k expected_type =
+  try
+    match k with
+    | VMcast ->
+      vm_conv CUMUL env ct expected_type
+    | DEFAULTcast ->
+      default_conv ~l2r:false CUMUL env ct expected_type
+    | REVERTcast ->
+      default_conv ~l2r:true CUMUL env ct expected_type
+    | NATIVEcast ->
+      let sigma = Nativelambda.empty_evars in
+      native_conv CUMUL sigma env ct expected_type
+  with NotConvertible ->
+    error_actual_type env (make_judge c ct) expected_type
+
+(* Inductive types. *)
+
+(* The type is parametric over the uniform parameters whose conclusion
+   is in Type; to enforce the internal constraints between the
+   parameters and the instances of Type occurring in the type of the
+   constructors, we use the level variables _statically_ assigned to
+   the conclusions of the parameters as mediators: e.g. if a parameter
+   has conclusion Type(alpha), static constraints of the form alpha<=v
+   exist between alpha and the Type's occurring in the constructor
+   types; when the parameters is finally instantiated by a term of
+   conclusion Type(u), then the constraints u<=alpha is computed in
+   the App case of execute; from this constraints, the expected
+   dynamic constraints of the form u<=v are enforced *)
+
+let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env mkIndU indu mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters 
+    env (spec,u) args
+  in
+    check_constraints cst env;
+    t
+
+let judge_of_inductive env (ind,u as indu) =
+  let (mib,mip) = lookup_mind_specif env ind in
+  check_hyps_inclusion env mkIndU indu mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in
+    check_constraints cst env;
+    t
+
+(* Constructors. *)
+
+let judge_of_constructor env (c,u as cu) =
+  let _ =
+    let ((kn,_),_) = c in
+    let mib = lookup_mind kn env in
+    check_hyps_inclusion env mkConstructU cu mib.mind_hyps in
+  let specif = lookup_mind_specif env (inductive_of_constructor c) in
+  let t,cst = constrained_type_of_constructor cu specif in
+  let () = check_constraints cst env in
+    t
+
+(* Case. *)
+
+let check_branch_types env (ind,u) c ct lft explft =
+  try conv_leq_vecti env lft explft
+  with
+      NotConvertibleVect i ->
+        error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i)
+    | Invalid_argument _ ->
+        error_number_branches env (make_judge c ct) (Array.length explft)
+
+let judge_of_case env ci p pt c ct lf lft =
+  let (pind, _ as indspec) =
+    try find_rectype env ct
+    with Not_found -> error_case_not_inductive env (make_judge c ct) in
+  let _ = check_case_info env pind ci in
+  let (bty,rslty) =
+    type_case_branches env indspec (make_judge p pt) c in
+  let () = check_branch_types env pind c ct lft bty in
+    rslty
+
+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 (make_judge c ct)
+  in
+    assert(eq_mind pb.proj_ind (fst ind));
+    let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+      substl (c :: List.rev args) ty
+      
+
+(* Fixpoints. *)
+
+(* Checks the type of a general (co)fixpoint, i.e. without checking *)
+(* the specific guard condition. *)
+
+let type_fixpoint env lna lar vdef vdeft =
+  let lt = Array.length vdeft in
+  assert (Int.equal (Array.length lar) lt);
+  try
+    conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar)
+  with NotConvertibleVect i ->
+    error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar
+
+(************************************************************************)
+(************************************************************************)
+
+(* The typing machine. *)
+    (* ATTENTION : faudra faire le typage du contexte des Const,
+    Ind et Constructsi un jour cela devient des constructions
+    arbitraires et non plus des variables *)
+let rec execute env cstr =
+  match kind_of_term cstr with
+    (* Atomic terms *)
+    | Sort (Prop c) ->
+      judge_of_prop_contents c
+	
+    | Sort (Type u) ->
+      judge_of_type u
+
+    | Rel n ->
+      judge_of_relative env n
+
+    | Var id ->
+      judge_of_variable env id
+
+    | Const c ->
+      judge_of_constant env c
+	
+    | Proj (p, c) ->
+        let ct = execute env c in
+          judge_of_projection env p c ct
+
+    (* Lambda calculus operators *)
+    | App (f,args) ->
+        let argst = execute_array env args in
+	let ft =
+	  match kind_of_term f with
+	  | Ind ind when Environ.template_polymorphic_pind ind env ->
+	      (* Template sort-polymorphism of inductive types *)
+	    let args = Array.map (fun t -> lazy t) argst in
+	      judge_of_inductive_knowing_parameters env ind args
+	  | Const cst when Environ.template_polymorphic_pconstant cst env ->
+	      (* Template sort-polymorphism of constants *)
+	    let args = Array.map (fun t -> lazy t) argst in
+	      judge_of_constant_knowing_parameters env cst args
+	  | _ ->
+	    (* Full or no sort-polymorphism *)
+	    execute env f
+	in
+
+	  judge_of_apply env f ft args argst
+
+    | Lambda (name,c1,c2) ->
+      let _ = execute_is_type env c1 in
+      let env1 = push_rel (name,None,c1) env in
+      let c2t = execute env1 c2 in
+        judge_of_abstraction env name c1 c2t
+
+    | Prod (name,c1,c2) ->
+      let vars = execute_is_type env c1 in
+      let env1 = push_rel (name,None,c1) env in
+      let vars' = execute_is_type env1 c2 in
+	judge_of_product env name vars vars'
+
+    | LetIn (name,c1,c2,c3) ->
+      let c1t = execute env c1 in
+      let _c2s = execute_is_type env c2 in
+      let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in
+      let env1 = push_rel (name,Some c1,c2) env in
+      let c3t = execute env1 c3 in
+	subst1 c1 c3t
+
+    | Cast (c,k,t) ->
+      let ct = execute env c in
+      let _ts = execute_type env t in
+      let _ = judge_of_cast env c ct k t in
+	t
+
+    (* Inductive types *)
+    | Ind ind ->
+      judge_of_inductive env ind
+
+    | Construct c ->
+      judge_of_constructor env c
+
+    | Case (ci,p,c,lf) ->
+        let ct = execute env c in
+        let pt = execute env p in
+        let lft = execute_array env lf in
+          judge_of_case env ci p pt c ct lf lft
+
+    | Fix ((vn,i as vni),recdef) ->
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let fix = (vni,recdef') in
+        check_fix env fix; fix_ty
+	  
+    | CoFix (i,recdef) ->
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let cofix = (i,recdef') in
+        check_cofix env cofix; fix_ty
+	  
+    (* Partial proofs: unsupported by the kernel *)
+    | Meta _ ->
+	anomaly (Pp.str "the kernel does not support metavariables")
+
+    | Evar _ ->
+	anomaly (Pp.str "the kernel does not support existential variables")
+
+and execute_is_type env constr =
+  let t = execute env constr in
+    check_type env constr t
+
+and execute_type env constr =
+  let t = execute env constr in
+    type_judgment env constr t
+
+and execute_recdef env (names,lar,vdef) i =
+  let lart = execute_array env lar in
+  let lara = Array.map2 (assumption_of_judgment env) lar lart in
+  let env1 = push_rec_types (names,lara,vdef) env in
+  let vdeft = execute_array env1 vdef in
+  let () = type_fixpoint env1 names lara vdef vdeft in
+    (lara.(i),(names,lara,vdef))
+
+and execute_array env = Array.map (execute env)
+
+(* Derived functions *)
+let infer env constr =
+  let t = execute env constr in
+    make_judge constr t
+
+let infer = 
+  if Flags.profile then
+    let infer_key = Profile.declare_profile "Fast_infer" in
+      Profile.profile2 infer_key infer
+  else infer
+
+let infer_type env constr =
+  execute_type env constr
+
+let infer_v env cv =
+  let jv = execute_array env cv in
+    make_judgev cv jv
diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli
new file mode 100644
index 00000000..4c2c92cc
--- /dev/null
+++ b/kernel/fast_typeops.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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 Names
+open Univ
+open Term
+open Context
+open Environ
+open Entries
+open Declarations
+
+(** {6 Typing functions (not yet tagged as safe) }
+    
+    They return unsafe judgments that are "in context" of a set of 
+    (local) universe variables (the ones that appear in the term)
+    and associated constraints. In case of polymorphic definitions,
+    these variables and constraints will be generalized.
+ *)
+
+
+val infer      : env -> constr       -> unsafe_judgment
+val infer_v    : env -> constr array -> unsafe_judgment array
+val infer_type : env -> types        -> unsafe_type_judgment
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 20aaf52a..99d9f52c 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,22 +1,34 @@
 (************************************************************************)
 (*  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 Term
+open Vars
+open Context
 open Declarations
+open Declareops
 open Inductive
-open Sign
 open Environ
 open Reduction
 open Typeops
 open Entries
+open Pp
+
+(* Tell if indices (aka real arguments) contribute to size of inductive type *)
+(* If yes, this is compatible with the univalent model *)
+
+let indices_matter = ref false
+
+let enforce_indices_matter () = indices_matter := true
+let is_indices_matter () = !indices_matter
 
 (* Same as noccur_between but may perform reductions.
    Could be refined more...  *)
@@ -37,11 +49,11 @@ let is_constructor_head t =
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * identifier * constr * constr * int * int
+  | NotConstructor of env * Id.t * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
-  | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier
-  | SameNamesOverlap of identifier list
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
   | NotAnArity of env * constr
   | BadEntry
   | LargeNonPropInductiveNotInType
@@ -57,10 +69,10 @@ let check_constructors_names =
   let rec check idset = function
     | [] -> idset
     | c::cl ->
-	if Idset.mem c idset then
+	if Id.Set.mem c idset then
 	  raise (InductiveError (SameNamesConstructors c))
 	else
-	  check (Idset.add c idset) cl
+	  check (Id.Set.add c idset) cl
   in
   check
 
@@ -74,13 +86,13 @@ let mind_check_names mie =
     | ind::inds ->
 	let id = ind.mind_entry_typename in
 	let cl = ind.mind_entry_consnames in
-	if Idset.mem id indset then
+	if Id.Set.mem id indset then
 	  raise (InductiveError (SameNamesTypes id))
 	else
 	  let cstset' = check_constructors_names cstset cl in
-	  check (Idset.add id indset) cstset' inds
+	  check (Id.Set.add id indset) cstset' inds
   in
-  check Idset.empty Idset.empty mie.mind_entry_inds
+  check Id.Set.empty Id.Set.empty mie.mind_entry_inds
 (* The above verification is not necessary from the kernel point of
   vue since inductive and constructors are not referred to by their
   name, but only by the name of the inductive packet and an index. *)
@@ -90,40 +102,28 @@ let mind_check_names mie =
 
 (* Typing the arities and constructor types *)
 
-let is_logic_type t = (t.utj_type = prop_sort)
-
-(* [infos] is a sequence of pair [islogic,issmall] for each type in
-   the product of a constructor or arity *)
-
-let is_small infos = List.for_all (fun (logic,small) -> small) infos
-let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos
-
 (* An inductive definition is a "unit" if it has only one constructor
    and that all arguments expected by this constructor are
    logical, this is the case for equality, conjunction of logical properties
 *)
 let is_unit constrsinfos =
   match constrsinfos with  (* One info = One constructor *)
-   | [constrinfos] -> is_logic_constr constrinfos
+   | [level] -> is_type0m_univ level
    | [] -> (* type without constructors *) true
    | _ -> false
 
-let rec infos_and_sort env t =
-  let t = whd_betadeltaiota env t in
-  match kind_of_term t with
-    | Prod (name,c1,c2) ->
-        let (varj,_) = infer_type env c1 in
+let infos_and_sort env ctx t =
+  let rec aux env ctx t max =
+    let t = whd_betadeltaiota env t in
+      match kind_of_term t with
+      | Prod (name,c1,c2) ->
+        let varj = infer_type env c1 in
 	let env1 = Environ.push_rel (name,None,varj.utj_val) env in
-	let logic = is_logic_type varj in
-	let small = Term.is_small varj.utj_type in
-	(logic,small) :: (infos_and_sort env1 c2)
-    | _ when is_constructor_head t -> []
-    | _ -> (* don't fail if not positive, it is tested later *) []
-
-let small_unit constrsinfos =
-  let issmall = List.for_all is_small constrsinfos
-  and isunit = is_unit constrsinfos in
-  issmall, isunit
+	let max = Universe.sup max (univ_of_sort varj.utj_type) in
+	  aux env1 ctx c2 max
+    | _ when is_constructor_head t -> max
+    | _ -> (* don't fail if not positive, it is tested later *) max
+  in aux env ctx t Universe.type0m
 
 (* Computing the levels of polymorphic inductive types
 
@@ -145,140 +145,206 @@ let small_unit constrsinfos =
    w1,w2,w3 <= u3
 *)
 
-let extract_level (_,_,_,lc,lev) =
-  (* Enforce that the level is not in Prop if more than two constructors *)
-  if Array.length lc >= 2 then sup type0_univ lev else lev
-
-let inductive_levels arities inds =
-  let levels = Array.map pi3 arities in
-  let cstrs_levels = Array.map extract_level inds in
-  (* Take the transitive closure of the system of constructors *)
-  (* level constraints and remove the recursive dependencies *)
-  solve_constraints_system levels cstrs_levels
-
 (* This (re)computes informations relevant to extraction and the sort of an
    arity or type constructor; we do not to recompute universes constraints *)
 
-let constraint_list_union =
-  List.fold_left union_constraints empty_constraint
-
-let infer_constructor_packet env_ar_par params lc =
+let infer_constructor_packet env_ar_par ctx params lc =
   (* type-check the constructors *)
-  let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in
-  let cst = constraint_list_union cstl in
+  let jlc = List.map (infer_type env_ar_par) lc in
   let jlc = Array.of_list jlc in
   (* generalize the constructor over the parameters *)
   let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in
-  (* compute the max of the sorts of the products of the constructor type *)
-  let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in
-  (* compute *)
-  let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in
-
-  (info,lc'',level,cst)
+  (* compute the max of the sorts of the products of the constructors types *)
+  let levels = List.map (infos_and_sort env_ar_par ctx) lc in
+  let isunit = is_unit levels in
+  let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in
+  let level = List.fold_left (fun max l -> Universe.sup max l) min levels in
+  (lc'', (isunit, level))
+
+(* If indices matter *)
+let cumulate_arity_large_levels env sign =
+  fst (List.fold_right
+    (fun (_,_,t as d) (lev,env) ->
+      let tj = infer_type env t in
+      let u = univ_of_sort tj.utj_type in
+	(Universe.sup u lev, push_rel d env))
+    sign (Universe.type0m,env))
+
+let is_impredicative env u =
+  is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet)
+
+let param_ccls params =
+  let has_some_univ u = function
+    | Some v when Univ.Level.equal u v -> true
+    | _ -> false
+  in
+  let remove_some_univ u = function
+    | Some v when Univ.Level.equal u v -> None
+    | x -> x
+  in
+  let fold l (_, b, p) = match b with
+  | None ->
+    (* Parameter contributes to polymorphism only if explicit Type *)
+    let c = strip_prod_assum p in
+    (* Add Type levels to the ordered list of parameters contributing to *)
+    (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
+    begin match kind_of_term c with
+    | Sort (Type u) ->
+      (match Univ.Universe.level u with
+      | Some u ->
+	if List.exists (has_some_univ u) l then
+          None :: List.map (remove_some_univ u) l
+	else
+          Some u :: l
+      | None -> None :: l)
+    | _ ->
+      None :: l
+    end
+  | _ -> l
+  in
+    List.fold_left fold [] params
 
 (* Type-check an inductive definition. Does not check positivity
    conditions. *)
+(* TODO check that we don't overgeneralize construcors/inductive arities with
+   universes that are absent from them. Is it possible? 
+*)
 let typecheck_inductive env mie =
-  if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration";
+  let () = match mie.mind_entry_inds with
+  | [] -> anomaly (Pp.str "empty inductive types declaration")
+  | _ -> ()
+  in
   (* Check unicity of names *)
   mind_check_names mie;
   (* Params are typed-checked here *)
-  let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in
+  let env' = push_context mie.mind_entry_universes env in
+  let (env_params, params) = infer_local_decls env' mie.mind_entry_params in
   (* We first type arity of each inductive definition *)
-  (* This allows to build the environment of arities and to share *)
+  (* This allows building the environment of arities and to share *)
   (* the set of constraints *)
-  let cst, env_arities, rev_arity_list =
+  let env_arities, rev_arity_list =
     List.fold_left
-      (fun (cst,env_ar,l) ind ->
+      (fun (env_ar,l) ind ->
          (* Arities (without params) are typed-checked here *)
-	 let arity, cst2 = infer_type env_params ind.mind_entry_arity in
+	 let expltype = ind.mind_entry_template in
+         let arity =
+	   if isArity ind.mind_entry_arity then
+	     let (ctx,s) = dest_arity env_params ind.mind_entry_arity in
+	       match s with
+	       | Type u when Univ.universe_level u = None ->
+	         (** We have an algebraic universe as the conclusion of the arity,
+		     typecheck the dummy Π ctx, Prop and do a special case for the conclusion.
+		 *)
+	         let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in
+		 let (cctx, _) = destArity proparity.utj_val in
+		   (* Any universe is well-formed, we don't need to check [s] here *)
+		   mkArity (cctx, s)
+	       | _ -> 
+		 let arity = infer_type env_params ind.mind_entry_arity in
+		   arity.utj_val
+	   else let arity = infer_type env_params ind.mind_entry_arity in
+		  arity.utj_val
+	 in
+	 let (sign, deflev) = dest_arity env_params arity in
+	 let inflev = 
+	   (* The level of the inductive includes levels of indices if 
+	      in indices_matter mode *)
+	     if !indices_matter 
+	     then Some (cumulate_arity_large_levels env_params sign)
+	     else None
+	 in
 	 (* We do not need to generate the universe of full_arity; if
 	    later, after the validation of the inductive definition,
 	    full_arity is used as argument or subject to cast, an
 	    upper universe will be generated *)
-	 let full_arity = it_mkProd_or_LetIn arity.utj_val params in
-	 let cst = union_constraints cst cst2 in
+	 let full_arity = it_mkProd_or_LetIn arity params in
 	 let id = ind.mind_entry_typename in
 	 let env_ar' =
-           push_rel (Name id, None, full_arity)
-             (add_constraints cst2 env_ar) in
-	 let lev =
-	   (* Decide that if the conclusion is not explicitly Type *)
-	   (* then the inductive type is not polymorphic *)
-	   match kind_of_term ((strip_prod_assum arity.utj_val)) with
-	   | Sort (Type u) -> Some u
-	   | _ -> None in
-         (cst,env_ar',(id,full_arity,lev)::l))
-      (cst1,env,[])
+           push_rel (Name id, None, full_arity) env_ar in
+             (* (add_constraints cst2 env_ar) in *)
+	   (env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l))
+      (env',[])
       mie.mind_entry_inds in
 
   let arity_list = List.rev rev_arity_list in
 
   (* builds the typing context "Gamma, I1:A1, ... In:An, params" *)
-  let env_ar_par =
-    push_rel_context params (add_constraints cst1 env_arities) in
+  let env_ar_par = push_rel_context params env_arities in
 
   (* Now, we type the constructors (without params) *)
-  let inds,cst =
+  let inds =
     List.fold_right2
-      (fun ind arity_data (inds,cst) ->
-	 let (info,lc',cstrs_univ,cst') =
-	   infer_constructor_packet env_ar_par params ind.mind_entry_lc in
+      (fun ind arity_data inds ->
+	 let (lc',cstrs_univ) =
+	   infer_constructor_packet env_ar_par ContextSet.empty
+	     params ind.mind_entry_lc in
 	 let consnames = ind.mind_entry_consnames in
-	 let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
-	 (ind'::inds, union_constraints cst cst'))
+	 let ind' = (arity_data,consnames,lc',cstrs_univ) in
+	   ind'::inds)
       mie.mind_entry_inds
       arity_list
-      ([],cst) in
+    ([]) in
 
   let inds = Array.of_list inds in
-  let arities = Array.of_list arity_list in
-  let param_ccls = List.fold_left (fun l (_,b,p) ->
-    if b = None then
-      (* Parameter contributes to polymorphism only if explicit Type *)
-      let c = strip_prod_assum p in
-      (* Add Type levels to the ordered list of parameters contributing to *)
-      (* polymorphism unless there is aliasing (i.e. non distinct levels) *)
-      match kind_of_term c with
-      | Sort (Type u) ->
-          if List.mem (Some u) l then
-            None :: List.map (function Some v when u = v -> None | x -> x) l
-          else
-            Some u :: l
-      | _ ->
-          None :: l
-    else
-      l) [] params in
 
   (* Compute/check the sorts of the inductive types *)
-  let ind_min_levels = inductive_levels arities inds in
-  let inds, cst =
-    array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst ->
-      let sign, s =
-        try dest_arity env full_arity
-        with NotArity -> raise (InductiveError (NotAnArity (env, full_arity)))
+
+  let inds =
+    Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev))  ->
+      let infu = 
+	(** Inferred level, with parameters and constructors. *)
+	match inf_level with
+	| Some alev -> Universe.sup clev alev
+	| None -> clev
+      in
+      let full_polymorphic () = 
+	let defu = Term.univ_of_sort def_level in
+	let is_natural =
+	  type_in_type env || (check_leq (universes env') infu defu &&
+	    not (is_type0m_univ defu && not is_unit))
+	in
+	let _ =
+	  (** Impredicative sort, always allow *)
+	  if is_impredicative env defu then ()
+	  else (** Predicative case: the inferred level must be lower or equal to the
+		   declared level. *)
+	    if not is_natural then
+	      anomaly ~label:"check_inductive" 
+		(Pp.str"Incorrect universe " ++
+		   Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is "
+		 ++ Universe.pr infu)
+	in
+	  RegularArity (not is_natural,full_arity,defu)
+      in
+      let template_polymorphic () =
+	let sign, s =
+          try dest_arity env full_arity
+          with NotArity -> raise (InductiveError (NotAnArity (env, full_arity)))
+	in
+	  match s with
+	  | Type u when expltype (* Explicitly polymorphic *) ->
+	    (* The polymorphic level is a function of the level of the *)
+	    (* conclusions of the parameters *)
+            (* We enforce [u >= lev] in case [lev] has a strict upper *)
+            (* constraints over [u] *)
+	    let b = type_in_type env || check_leq (universes env') infu u in
+	      if not b then
+		anomaly ~label:"check_inductive" 
+		  (Pp.str"Incorrect universe " ++
+		     Universe.pr u ++ Pp.str " declared for inductive type, inferred level is "
+		   ++ Universe.pr clev)
+	      else
+		TemplateArity (param_ccls params, infu)
+	  | _ (* Not an explicit occurrence of Type *) ->
+	    full_polymorphic ()
+      in
+      let arity = 
+	if mie.mind_entry_polymorphic then full_polymorphic ()
+	else template_polymorphic ()
       in
-      let status,cst = match s with
-      | Type u when ar_level <> None (* Explicitly polymorphic *)
-            && no_upper_constraints u cst ->
-	  (* The polymorphic level is a function of the level of the *)
-	  (* conclusions of the parameters *)
-          (* We enforce [u >= lev] in case [lev] has a strict upper *)
-          (* constraints over [u] *)
-	  Inr (param_ccls, lev), enforce_geq u lev cst
-      | Type u (* Not an explicit occurrence of Type *) ->
-	  Inl (info,full_arity,s), enforce_geq u lev cst
-      | Prop Pos when engagement env <> Some ImpredicativeSet ->
-	  (* Predicative set: check that the content is indeed predicative *)
-	  if not (is_type0m_univ lev) & not (is_type0_univ lev) then
-	    raise (InductiveError LargeNonPropInductiveNotInType);
-	  Inl (info,full_arity,s), cst
-      | Prop _ ->
-	  Inl (info,full_arity,s), cst in
-      (id,cn,lc,(sign,status)),cst)
-      inds ind_min_levels cst in
-
-  (env_arities, params, inds, cst)
+	(id,cn,lc,(sign,arity)))
+    inds
+  in (env_arities, params, inds)
 
 (************************************************************************)
 (************************************************************************)
@@ -321,11 +387,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")
 
 (* Check the inductive type is called with the expected parameters *)
 let check_correct_par (env,n,ntypes,_) hyps l largs =
@@ -333,17 +399,17 @@ 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
     | [] -> ()
     | (_,Some _,_)::hyps -> check k (index+1) hyps
     | _::hyps ->
         match kind_of_term (whd_betadeltaiota env lpar.(k)) with
-	  | Rel w when w = index -> check (k-1) (index+1) hyps
+	  | Rel w when Int.equal 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'
 
 (* Computes the maximum number of recursive parameters :
@@ -352,9 +418,9 @@ let check_correct_par (env,n,ntypes,_) hyps l largs =
     recursive parameters *)
 
 let compute_rec_par (env,n,_,_) hyps nmr largs =
-if nmr = 0 then 0 else
+if Int.equal nmr 0 then 0 else
 (* start from 0, hyps will be in reverse order *)
-  let (lpar,_) = list_chop nmr largs in
+  let (lpar,_) = List.chop nmr largs in
   let rec find k index =
       function
 	  ([],_) -> nmr
@@ -362,27 +428,10 @@ if nmr = 0 then 0 else
 	| (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps)
 	| (p::lp,_::hyps) ->
        ( match kind_of_term (whd_betadeltaiota env p) with
-	  | Rel w when w = index -> find (k+1) (index-1) (lp,hyps)
+	  | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps)
           | _ -> k)
   in find 0 (n-1) (lpar,List.rev hyps)
 
-let lambda_implicit_lift n a =
-  let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in
-  let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
-  iterate lambda_implicit n (lift n a)
-
-(* This removes global parameters of the inductive types in lc (for
-   nested inductive types only ) *)
-let abstract_mind_lc env ntyps npars lc =
-  if npars = 0 then
-    lc
-  else
-    let make_abs =
-      list_tabulate
-	(function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps
-    in
-    Array.map (substl make_abs) lc
-
 (* [env] is the typing environment
    [n] is the dB of the last inductive type
    [ntypes] is the number of inductive types in the definition
@@ -392,12 +441,13 @@ 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 specif = (lookup_mind_specif env mi, u) in
+  let ty = type_of_inductive env specif in
   let env' =
     push_rel (Anonymous,None,
-              hnf_prod_applist env (type_of_inductive env specif) lpar) env in
+              hnf_prod_applist env ty 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
@@ -406,7 +456,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) =
   (env', newidx, ntypes, ra_env')
 
 let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
-  if n=0 then (ienv,c) else
+  if Int.equal n 0 then (ienv,c) else
     let c' = whd_betadeltaiota env c in
     match kind_of_term c' with
 	Prod(na,a,b) ->
@@ -414,7 +464,7 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c =
 	  ienv_decompose_prod ienv' (n-1) b
       | _ -> assert false
 
-let array_min nmr a = if nmr = 0 then 0 else
+let array_min nmr a = if Int.equal nmr 0 then 0 else
   Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a
 
 (* The recursive function that checks positivity and builds the list
@@ -427,7 +477,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
     let x,largs = decompose_app (whd_betadeltaiota env c) in
       match kind_of_term x with
 	| Prod (na,b,d) ->
-	    assert (largs = []);
+	    let () = assert (List.is_empty largs) in
             (match weaker_noccur_between env n ntypes b with
 		None -> failwith_non_pos_list n ntypes [b]
               | Some b ->
@@ -455,12 +505,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	    else failwith_non_pos_list n ntypes (x::largs)
 
   (* accesses to the environment are not factorised, but is it worth? *)
-  and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) =
+  and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((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. *)
@@ -469,12 +519,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	failwith_non_pos_list n ntypes auxlargs;
       (* We do not deal with imbricated mutual inductive types *)
       let auxntyp = mib.mind_ntypes in
-	if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
+	if not (Int.equal auxntyp 1) then raise (IllFormedInd (LocalNonPos n));
 	(* The nested inductive type with parameters removed *)
-	let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in
+	let auxlcvect = abstract_mind_lc 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_nmr =
@@ -503,25 +553,27 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 	match kind_of_term x with
 
           | Prod (na,b,d) ->
-	      assert (largs = []);
+	      let () = assert (List.is_empty largs) in
               let nmr',recarg = check_pos ienv nmr b in
               let ienv' = ienv_push_var ienv (na,b,mk_norec) in
-		check_constr_rec ienv' nmr' (recarg::lrec) d
-
-	  | hd ->
-	      if check_head then
-		if hd = Rel (n+ntypes-i-1) then
-		  check_correct_par ienv hyps (ntypes-i) largs
-		else
-		  raise (IllFormedInd LocalNotConstructor)
-	      else
-		if not (List.for_all (noccur_between n ntypes) largs)
-		then failwith_non_pos_list n ntypes largs;
-	      (nmr,List.rev lrec)
+                check_constr_rec ienv' nmr' (recarg::lrec) d
+          | hd ->
+            let () =
+              if check_head then
+                begin match hd with
+                | Rel j when Int.equal j (n + ntypes - i - 1) ->
+                  check_correct_par ienv hyps (ntypes - i) largs
+                | _ -> raise (IllFormedInd LocalNotConstructor)
+                end
+              else
+                if not (List.for_all (noccur_between n ntypes) largs)
+                then failwith_non_pos_list n ntypes largs
+            in
+            (nmr, List.rev lrec)
     in check_constr_rec ienv nmr [] c
   in
   let irecargs_nmr =
-    array_map2
+    Array.map2
       (fun id c ->
         let _,rawc = mind_extract_params lparams c in
           try
@@ -537,12 +589,12 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname
 let check_positivity kn env_ar params inds =
   let ntypes = Array.length inds in
   let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
-  let lra_ind = List.rev (Array.to_list rc) in
+  let lra_ind = Array.rev_to_list rc in
   let lparams = rel_context_length params in
   let nmr = rel_context_nhyps params in
   let check_one i (_,lcnames,lc,(sign,_)) =
     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
     let nargs = rel_context_nhyps sign - nmr in
     check_positivity_one ienv params (kn,i) nargs lcnames lc
@@ -563,67 +615,143 @@ let all_sorts = [InProp;InSet;InType]
 let small_sorts = [InProp;InSet]
 let logical_sorts = [InProp]
 
-let allowed_sorts issmall isunit s =
-  match family_of_sort s with
-  (* Type: all elimination allowed *)
-  | InType -> all_sorts
-
-  (* Small Set is predicative: all elimination allowed *)
-  | InSet when issmall -> all_sorts
-
-  (* Large Set is necessarily impredicative: forbids large elimination *)
-  | InSet -> small_sorts
-
-  (* Unitary/empty Prop: elimination to all sorts are realizable *)
-  (* unless the type is large. If it is large, forbids large elimination *)
-  (* which otherwise allows to simulate the inconsistent system Type:Type *)
-  | InProp when isunit -> if issmall then all_sorts else small_sorts
-
-  (* Other propositions: elimination only to Prop *)
-  | InProp -> logical_sorts
+let allowed_sorts is_smashed s =
+  if not is_smashed 
+  then (** Naturally in the defined sort.
+	   If [s] is Prop, it must be small and unitary.
+	   Unsmashed, predicative Type and Set: all elimination allowed
+	   as well. *)
+      all_sorts
+  else 
+    match family_of_sort s with
+    (* Type: all elimination allowed: above and below *)
+    | InType -> all_sorts
+    (* Smashed Set is necessarily impredicative: forbids large elimination *)
+    | InSet -> small_sorts
+    (* Smashed to Prop, no informative eliminations allowed *)
+    | InProp -> logical_sorts
+    
+(* Previous comment: *)
+(* Unitary/empty Prop: elimination to all sorts are realizable *)
+(* unless the type is large. If it is large, forbids large elimination *)
+(* which otherwise allows simulating the inconsistent system Type:Type. *)
+(* -> this is now handled by is_smashed: *)
+(* - all_sorts in case of small, unitary Prop (not smashed) *)
+(* - logical_sorts in case of large, unitary Prop (smashed) *)
+
+let arity_conclusion = function
+  | RegularArity (_, c, _) -> c
+  | TemplateArity (_, s) -> mkType s
 
 let fold_inductive_blocks f =
-  Array.fold_left (fun acc (_,_,lc,(arsign,_)) ->
-    f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (* dummy *) mkSet arsign))
+  Array.fold_left (fun acc (_,_,lc,(arsign,ar)) ->
+    f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (arity_conclusion ar) arsign))
 
 let used_section_variables env inds =
   let ids = fold_inductive_blocks
-    (fun l c -> Idset.union (Environ.global_vars_set env c) l)
-      Idset.empty inds in
+    (fun l c -> Id.Set.union (Environ.global_vars_set env c) l)
+      Id.Set.empty inds in
   keep_hyps env ids
 
-let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
+let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
+let rel_appvect n m = rel_vect n (List.length m)
+
+exception UndefinableExpansion
+
+(** From a rel context describing the constructor arguments,
+    build an expansion function.
+    The term built is expecting to be substituted first by 
+    a substitution of the form [params, x : ind params] *)
+let compute_projections ((kn, _ as ind), u as indsp) n x nparamargs params
+    mind_consnrealdecls mind_consnrealargs ctx =
+  let mp, dp, l = repr_mind kn in
+  let rp = mkApp (mkIndU indsp, rel_vect 0 nparamargs) in
+  let ci = 
+    let print_info =
+      { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in
+      { ci_ind     = ind;
+	ci_npar    = nparamargs;
+	ci_cstr_ndecls = mind_consnrealdecls;
+	ci_cstr_nargs = mind_consnrealargs;
+	ci_pp_info = print_info }
+  in
+  let len = List.length ctx in
+  let x = Name x in
+  let compat_body ccl i = 
+    (* [ccl] is defined in context [params;x:rp] *)
+    (* [ccl'] is defined in context [params;x:rp;x:rp] *)
+    let ccl' = liftn 1 2 ccl in
+    let p = mkLambda (x, lift 1 rp, ccl') in
+    let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in
+    let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in
+      it_mkLambda_or_LetIn (mkLambda (x,rp,body)) params
+  in
+  let projections (na, b, t) (i, j, kns, pbs, subst) =
+    match b with
+    | Some c -> (i, j+1, kns, pbs, substl subst c :: subst)
+    | None ->
+      match na with
+      | Name id ->
+	let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in
+	let ty = substl subst (liftn 1 j t) in
+	let term = mkProj (Projection.make kn true, mkRel 1) in
+	let fterm = mkProj (Projection.make kn false, mkRel 1) in
+	let compat = compat_body ty (j - 1) in
+	let etab = it_mkLambda_or_LetIn (mkLambda (x, rp, term)) params in
+	let etat = it_mkProd_or_LetIn (mkProd (x, rp, ty)) params in
+	let body = { proj_ind = fst ind; proj_npars = nparamargs;
+		     proj_arg = i; proj_type = ty; proj_eta = etab, etat; 
+		     proj_body = compat } in
+	  (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: subst)
+      | Anonymous -> raise UndefinableExpansion
+  in
+  let (_, _, kns, pbs, subst) = List.fold_right projections ctx (0, 1, [], [], []) in
+    Array.of_list (List.rev kns),
+    Array.of_list (List.rev pbs)
+
+let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr recargs =
   let ntypes = Array.length inds in
   (* Compute the set of used section variables *)
-  let hyps =  used_section_variables env inds in
+  let hyps = used_section_variables env inds in
   let nparamargs = rel_context_nhyps params in
   let nparamdecls = rel_context_length params in
+  let subst, ctx = Univ.abstract_universes p ctx in
+  let params = Vars.subst_univs_level_context subst params in
+  let env_ar = 
+    let ctx = Environ.rel_context env_ar in 
+    let ctx' = Vars.subst_univs_level_context subst ctx in
+      Environ.push_rel_context ctx' env
+  in
   (* Check one inductive *)
   let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg =
     (* Type of constructors in normal form *)
+    let lc = Array.map (Vars.subst_univs_level_constr subst) lc in
     let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
     let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
-    let consnrealargs =
+    let consnrealdecls =
       Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
 	splayed_lc in
+    let consnrealargs =
+      Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params)
+	splayed_lc in
     (* Elimination sorts *)
-    let arkind,kelim = match ar_kind with
-      | Inr (param_levels,lev) ->
-	  Polymorphic {
-	      poly_param_levels = param_levels;
-	      poly_level = lev;
-	    }, all_sorts
-      | Inl ((issmall,isunit),ar,s) ->
-	  let kelim = allowed_sorts issmall isunit s in
-	    Monomorphic {
-		mind_user_arity = ar;
-		mind_sort = s;
-	      }, kelim in
+    let arkind,kelim = 
+      match ar_kind with
+      | TemplateArity (paramlevs, lev) -> 
+	let ar = {template_param_levels = paramlevs; template_level = lev} in
+	  TemplateArity ar, all_sorts
+      | RegularArity (info,ar,defs) ->
+	let s = sort_of_univ defs in
+	let kelim = allowed_sorts info s in
+	let ar = RegularArity 
+	  { mind_user_arity = Vars.subst_univs_level_constr subst ar; 
+	    mind_sort = sort_of_univ (Univ.subst_univs_level_universe subst defs); } in
+	  ar, kelim in
     (* Assigning VM tags to constructors *)
     let nconst, nblock = ref 0, ref 0 in
     let transf num =
       let arity = List.length (dest_subterms recarg).(num) in
-	if arity = 0 then
+	if Int.equal arity 0 then
 	  let p  = (!nconst, 0) in
 	    incr nconst; p
 	else
@@ -636,12 +764,13 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
       (* Build the inductive packet *)
       { mind_typename = id;
 	mind_arity = arkind;
-	mind_arity_ctxt = ar_sign;
+	mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign;
 	mind_nrealargs = rel_context_nhyps ar_sign - nparamargs;
-	mind_nrealargs_ctxt = rel_context_length ar_sign - nparamdecls;
+	mind_nrealdecls = rel_context_length ar_sign - nparamdecls;
 	mind_kelim = kelim;
 	mind_consnames = Array.of_list cnames;
-	mind_consnrealdecls = consnrealargs;
+	mind_consnrealdecls = consnrealdecls;
+	mind_consnrealargs = consnrealargs;
 	mind_user_lc = lc;
 	mind_nf_lc = nf_lc;
 	mind_recargs = recarg;
@@ -649,7 +778,30 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 	mind_nb_args = !nblock;
 	mind_reloc_tbl = rtbl;
       } in
-  let packets = array_map2 build_one_packet inds recargs in
+  let packets = Array.map2 build_one_packet inds recargs in
+  let pkt = packets.(0) in	  
+  let isrecord = 
+    match isrecord with
+    | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1
+			   && pkt.mind_consnrealargs.(0) > 0 ->
+      (** The elimination criterion ensures that all projections can be defined. *)
+      let u = 
+	if p then 
+	  subst_univs_level_instance subst (Univ.UContext.instance ctx)
+	else Univ.Instance.empty 
+      in
+      let indsp = ((kn, 0), u) in
+      let rctx, _ = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in
+	(try 
+	   let fields = List.firstn pkt.mind_consnrealdecls.(0) rctx in
+	   let kns, projs = 
+	     compute_projections indsp pkt.mind_typename rid nparamargs params
+	       pkt.mind_consnrealdecls pkt.mind_consnrealargs fields
+	   in Some (Some (rid, kns, projs))
+	 with UndefinableExpansion -> Some None)
+    | Some _ -> Some None
+    | None -> None
+  in
     (* Build the mutual inductive *)
     { mind_record = isrecord;
       mind_ntypes = ntypes;
@@ -659,7 +811,9 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
       mind_nparams_rec = nmr;
       mind_params_ctxt = params;
       mind_packets = packets;
-      mind_constraints = cst
+      mind_polymorphic = p;
+      mind_universes = ctx;
+      mind_private = prv;
     }
 
 (************************************************************************)
@@ -667,9 +821,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
 
 let check_inductive env kn mie =
   (* First type-check the inductive definition *)
-  let (env_ar, params, inds, cst) = typecheck_inductive env mie in
+  let (env_ar, params, inds) = typecheck_inductive env mie in
   (* Then check positivity conditions *)
   let (nmr,recargs) = check_positivity kn env_ar params inds in
   (* Build the inductive packets *)
-    build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
-      inds nmr recargs cst
+    build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private
+      mie.mind_entry_universes
+      env_ar params kn mie.mind_entry_record mie.mind_entry_finite
+      inds nmr recargs
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 1cd0a0b0..7774e52e 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -1,18 +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 Names
-open Univ
 open Term
 open Declarations
 open Environ
 open Entries
-open Typeops
 
 (** Inductive type checking and errors *)
 
@@ -23,11 +21,11 @@ open Typeops
 type inductive_error =
   | NonPos of env * constr * constr
   | NotEnoughArgs of env * constr * constr
-  | NotConstructor of env * identifier * constr * constr * int * int
+  | NotConstructor of env * Id.t * constr * constr * int * int
   | NonPar of env * constr * int * constr * constr
-  | SameNamesTypes of identifier
-  | SameNamesConstructors of identifier
-  | SameNamesOverlap of identifier list
+  | SameNamesTypes of Id.t
+  | SameNamesConstructors of Id.t
+  | SameNamesOverlap of Id.t list
   | NotAnArity of env * constr
   | BadEntry
   | LargeNonPropInductiveNotInType
@@ -36,5 +34,14 @@ exception InductiveError of inductive_error
 
 (** The following function does checks on inductive declarations. *)
 
-val check_inductive :
-  env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
+val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
+
+(** The following enforces a system compatible with the univalent model *)
+
+val enforce_indices_matter : unit -> unit
+val is_indices_matter : unit -> bool
+
+val compute_projections : pinductive -> Id.t -> Id.t ->
+  int -> Context.rel_context -> int array -> int array -> 
+  Context.rel_context -> 
+  (constant array * projection_body array)
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index b78fb5ae..bb57ad25 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1,17 +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        *)
 (************************************************************************)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
-open Sign
+open Vars
+open Context
 open Declarations
+open Declareops
 open Environ
 open Reduction
 open Type_errors
@@ -35,37 +38,46 @@ let find_inductive env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
   match kind_of_term t with
     | Ind ind
-        when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+        when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite <> Decl_kinds.CoFinite -> (ind, l)
     | _ -> raise Not_found
 
 let find_coinductive env c =
   let (t, l) = decompose_app (whd_betadeltaiota env c) in
   match kind_of_term t with
     | Ind ind
-        when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l)
+        when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite == Decl_kinds.CoFinite -> (ind, l)
     | _ -> raise Not_found
 
 let inductive_params (mib,_) = mib.mind_nparams
 
+let inductive_paramdecls (mib,u) = 
+  Vars.subst_instance_context u mib.mind_params_ctxt
+
+let instantiate_inductive_constraints mib u =
+  if mib.mind_polymorphic then
+    Univ.subst_instance_constraints u (Univ.UContext.constraints mib.mind_universes)
+  else Univ.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 = mkInd (mind,ntypes-k-1) in
-  list_tabulate make_Ik ntypes
+  let make_Ik k = mkIndU ((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 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) =
-    Sign.fold_rel_context
+    Context.fold_rel_context
       (fun (_,copt,_) (largs,subs,ty) ->
         match (copt, largs, kind_of_term ty) with
           | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t)
@@ -75,16 +87,17 @@ let instantiate_params full t args sign =
       sign
       ~init:(args,[],t)
   in
-  if rem_args <> [] then fail();
+  let () = if not (List.is_empty rem_args) then fail () in
   substl subs ty
 
-let full_inductive_instantiate mib params sign =
+let full_inductive_instantiate mib u params sign =
   let dummy = prop_sort in
   let t = mkArity (sign,dummy) in
-  fst (destArity (instantiate_params true t params mib.mind_params_ctxt))
+  let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in
+    Vars.subst_instance_context u ar
 
-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)
 
@@ -116,18 +129,13 @@ Remark: Set (predicative) is encoded as Type(0)
 
 let sort_as_univ = function
 | Type u -> u
-| Prop Null -> type0m_univ
-| Prop Pos -> type0_univ
-
-let cons_subst u su subst =
-  try (u, sup su (List.assoc u subst)) :: List.remove_assoc u subst
-  with Not_found -> (u, su) :: subst
+| Prop Null -> Universe.type0m
+| Prop Pos -> Universe.type0
 
-let actualize_decl_level env lev t =
-  let sign,s = dest_arity env t in
-  mkArity (sign,lev)
+(* Template polymorphism *)
 
-let polymorphism_on_non_applied_parameters = false
+let cons_subst u su subst =
+  Univ.LMap.add u su subst
 
 (* Bind expected levels of parameters to actual levels *)
 (* Propagate the new levels in the signature *)
@@ -145,7 +153,7 @@ let rec make_subst env = function
       (* arity is a global level which, at typing time, will be enforce *)
       (* to be greater than the level of the argument; this is probably *)
       (* a useless extra constraint *)
-      let s = sort_as_univ (snd (dest_arity env a)) in
+      let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in
       let ctx,subst = make_subst env (sign, exp, args) in
       d::ctx, cons_subst u s subst
   | (na,None,t as d)::sign, Some u::exp, [] ->
@@ -154,82 +162,96 @@ 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,
-  (* Singleton type not containing types are interpretable in Prop *)
-  if is_type0m_univ level then prop_sort
-  (* Non singleton type not containing types are interpretable in Set *)
-  else if is_type0_univ level then set_sort
-  (* This is a Type with constraints *)
- else Type level
-
-exception SingletonInductiveBecomesProp of identifier
-
-let type_of_inductive_knowing_parameters ?(polyprop=true) 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 is_type0m_univ level then prop_sort
+    (* Non singleton type not containing types are interpretable in Set *)
+    else if is_type0_univ level then set_sort
+    (* This is a Type with constraints *)
+    else Type level
+  in
+    (ctx, ty)
+
+(* Type of an inductive type *)
+
+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 -> 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 (is_type0m_univ ar.poly_level) && s = prop_sort
+      if not polyprop && not (is_type0m_univ ar.template_level) && is_prop_sort s
       then raise (SingletonInductiveBecomesProp mip.mind_typename);
       mkArity (List.rev ctx,s)
 
-(* Type of a (non applied) inductive type *)
+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 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 env (_,mip) =
-  type_of_inductive_knowing_parameters env mip [||]
+let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = 
+  type_of_inductive_gen env mip args
 
 (* 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 -> Universe.sup Universe.type0 u
+  | Type u' -> Universe.sup u u'
 
 let max_inductive_sort =
-  Array.fold_left cumulate_constructor_univ type0m_univ
+  Array.fold_left cumulate_constructor_univ Universe.type0m
 
 (************************************************************************)
 (* Type of a constructor *)
 
-let type_of_constructor cstr (mib,mip) =
+let type_of_constructor (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)
+  constructor_instantiate (fst ind) u mib specif.(i-1)
 
-let arities_of_specif kn (mib,mip) =
+let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) =
+  let ty = type_of_constructor 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
 
 let arities_of_constructors ind specif =
-  arities_of_specif (fst ind) specif
+  arities_of_specif (fst (fst ind), snd ind) specif
 
-let type_of_constructors ind (mib,mip) =
+let type_of_constructors (ind,u) (mib,mip) =
   let specif = mip.mind_user_lc in
-  Array.map (constructor_instantiate (fst ind) mib) specif
+    Array.map (constructor_instantiate (fst ind) u mib) specif
 
 (************************************************************************)
 
@@ -237,7 +259,7 @@ let type_of_constructors ind (mib,mip) =
 
 let local_rels ctxt =
   let (rels,_) =
-    Sign.fold_rel_context_reverse
+    Context.fold_rel_context_reverse
       (fun (rels,n) (_,copt,_) ->
         match copt with
             None   -> (mkRel n :: rels, n+1)
@@ -251,18 +273,24 @@ let local_rels ctxt =
 
 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
 
+let is_private (mib,_) = mib.mind_private = Some true
+let is_primitive_record (mib,_) = 
+  match mib.mind_record with
+  | Some (Some _) -> true
+  | _ -> false
+
 let extended_rel_list n hyps =
   let rec reln l p = function
     | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps
@@ -272,30 +300,33 @@ 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
-    (mkInd ind,
-       List.map (lift mip.mind_nrealargs_ctxt) params
+    (mkIndU ind,
+       List.map (lift mip.mind_nrealdecls) params
        @ extended_rel_list 0 realargs)
 
 (* This exception is local *)
 exception LocalArity of (sorts_family * sorts_family * arity_error) option
 
 let check_allowed_sort ksort specif =
-  if not (List.exists ((=) ksort) (elim_sorts specif)) then
+  let eq_ksort s = match ksort, s with
+  | InProp, InProp | InSet, InSet | InType, InType -> true
+  | _ -> false in
+  if not (List.exists eq_ksort (elim_sorts specif)) then
     let s = inductive_sort_family (snd specif) in
     raise (LocalArity (Some(ksort,s,error_elim_explain ksort s)))
 
 let is_correct_arity env c pj ind specif params =
-  let arsign,_ = get_instantiated_arity specif params in
-  let rec srec env pt ar u =
+  let arsign,_ = get_instantiated_arity ind specif params in
+  let rec srec env pt ar =
     let pt' = whd_betadeltaiota env pt in
     match kind_of_term pt', ar with
       | Prod (na1,a1,t), (_,None,a1')::ar' ->
-          let univ =
+          let () =
             try conv env a1 a1'
             with NotConvertible -> raise (LocalArity None) in
-          srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ)
+          srec (push_rel (na1,None,a1) env) t ar' 
       (* The last Prod domain is the type of the scrutinee *)
       | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *)
 	 let env' = push_rel (na1,None,a1) env in
@@ -303,17 +334,16 @@ let is_correct_arity env c pj ind specif params =
        | Sort s -> family_of_sort s
        | _ -> raise (LocalArity None) in
 	 let dep_ind = build_dependent_inductive ind specif params in
-	 let univ =
+	 let _ =
            try conv env a1 dep_ind
            with NotConvertible -> raise (LocalArity None) in
-	 check_allowed_sort ksort specif;
-	 union_constraints u univ
+	 check_allowed_sort ksort specif
       | _, (_,Some _,_ as d)::ar' ->
-	 srec (push_rel d env) (lift 1 pt') ar' u
+	  srec (push_rel d env) (lift 1 pt') ar'
       | _ ->
 	  raise (LocalArity None)
   in
-  try srec env pj.uj_type (List.rev arsign) empty_constraint
+  try srec env pj.uj_type (List.rev arsign) 
   with LocalArity kinds ->
     error_elim_arity env ind (elim_sorts specif) c pj kinds
 
@@ -323,16 +353,16 @@ let is_correct_arity env c 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 p =
+let build_branches_type (ind,u) (_,mip as specif) params 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 =
       let cstr = ith_constructor_of_inductive ind (i+1) in
-      let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in
+      let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in
       vargs @ [dep_cstr] in
     let base = beta_appvect (lift nargs p) (Array.of_list cargs) in
     it_mkProd_or_LetIn base args in
@@ -340,30 +370,32 @@ let build_branches_type ind (_,mip as specif) params p =
 
 (* [p] is the predicate, [c] is the match object, [realargs] is the
    list of real args of the inductive type *)
-let build_case_type n p c realargs =
-  whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
+let build_case_type env n p c realargs =
+  whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c])))
 
-let type_case_branches env (ind,largs) pj c =
-  let specif = lookup_mind_specif env ind in
+let type_case_branches env (pind,largs) 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 (params,realargs) = List.chop nparams largs in
   let p = pj.uj_val in
-  let univ = is_correct_arity env c pj ind specif params in
-  let lc = build_branches_type ind specif params p in
-  let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in
-  (lc, ty, univ)
+  let () = is_correct_arity env c pj pind specif params in
+  let lc = build_branches_type pind specif params p in
+  let ty = build_case_type env (snd specif).mind_nrealdecls p c realargs in
+  (lc, ty)
 
 
 (************************************************************************)
-(* Checking the case annotation is relevent *)
+(* Checking the case annotation is relevant *)
 
-let check_case_info env indsp ci =
-  let (mib,mip) = lookup_mind_specif env indsp in
+let check_case_info env (indsp,u) ci =
+  let (mib,mip as spec) = 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)
-  then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
+    not (eq_ind indsp ci.ci_ind) ||
+    not (Int.equal mib.mind_nparams ci.ci_npar) ||
+    not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) ||
+    not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) ||
+    is_primitive_record spec
+  then raise (TypeError(env,WrongCaseInfo((indsp,u),ci)))
 
 (************************************************************************)
 (************************************************************************)
@@ -413,23 +445,43 @@ 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_wf_paths = Rtree.equal Declareops.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 Declareops.eq_recarg inter_recarg Norec
+
+let incl_wf_paths = Rtree.incl Declareops.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
-        s1, Dead_code -> s1
-      | Dead_code, s2 -> 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;
@@ -439,13 +491,10 @@ type guard_env =
     genv    : subterm_spec Lazy.t list;
   }
 
-let make_renv env recarg (kn,tyi) =
-  let mib = Environ.lookup_mind kn env in
-  let mind_recvec =
-    Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+let make_renv env recarg tree =
   { env = env;
-    rel_min = recarg+2;
-    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) =
   { env = push_rel (x,None,ty) renv.env;
@@ -453,7 +502,7 @@ let push_var renv (x,ty,spec) =
     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 Not_subterm)
@@ -492,7 +541,6 @@ let lookup_subterms env ind =
   let (_,mip) = lookup_mind_specif env ind in
   mip.mind_recargs
 
-
 let match_inductive ind ra =
   match ra with
     | (Mrec i | Imbr i) -> eq_ind ind i
@@ -517,15 +565,174 @@ let branches_specif renv c_spec ci =
 	   (match Lazy.force c_spec with
 		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)
+		  assert (Int.equal nca (Array.length vra));
+		  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
+  isInd i
+
+(* 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 kind_of_term 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 = mkType (Universe.make level) in
+  let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
+  iterate lambda_implicit n (lift n a)
+
+(* This removes global parameters of the inductive types in lc (for
+   nested inductive types only ) *)
+let abstract_mind_lc ntyps npars lc =
+  if Int.equal npars 0 then
+    lc
+  else
+    let make_abs =
+      List.init ntyps
+	(function i -> lambda_implicit_lift npars (mkRel (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 positivity 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 kind_of_term 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 inferred 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 kind_of_term 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 kind_of_term 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
@@ -536,67 +743,77 @@ let rec subterm_specif renv stack t =
   (* maybe reduction is not always necessary! *)
   let f,l = decompose_app (whd_betadeltaiota renv.env t) in
     match kind_of_term f with
-      | Rel k -> subterm_var k renv
-
-      | Case (ci,_,c,lbr) ->
-	  let 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' =
+    | Rel k -> subterm_var k 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'
-		       (nbfix-i, lazy (Subterm(Strict,recargs))) in
-		   let decrArg = recindxs.(i) in
-		   let theBody = bodies.(i)   in
-		   let nbOfAbst = decrArg+1 in
-		   let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
-		     (* pushing the fix parameters *)
-		   let stack' = push_stack_closures renv l stack in
-		   let renv'' = push_ctxt_renv renv' sign in
-		   let renv'' =
-                     if List.length stack' < nbOfAbst then renv''
-                     else
-		       let decrArg = List.nth stack' decrArg in
-                       let arg_spec = stack_element_specif decrArg in
-			 assign_var_spec renv'' (1, arg_spec) in
-		     subterm_specif renv'' [] strippedBody)
-
-      | Lambda (x,a,b) ->
-          assert (l=[]);
-	  let spec,stack' = extract_stack renv a stack in
-	    subterm_specif (push_var renv (x,a,spec)) stack' b
+          assign_var_spec renv'
+	  (nbfix-i, lazy (Subterm(Strict,recargs))) in
+	let decrArg = recindxs.(i) in
+	let theBody = bodies.(i)   in
+	let nbOfAbst = decrArg+1 in
+	let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+		   (* pushing the fix parameters *)
+	let stack' = push_stack_closures renv l stack in
+	let renv'' = push_ctxt_renv renv' sign in
+	let renv'' =
+          if List.length stack' < nbOfAbst then renv''
+          else
+	    let decrArg = List.nth stack' decrArg in
+            let arg_spec = stack_element_specif decrArg in
+	      assign_var_spec renv'' (1, arg_spec) in
+	  subterm_specif renv'' [] strippedBody)
+
+    | Lambda (x,a,b) ->
+      let () = assert (List.is_empty l) in
+      let spec,stack' = extract_stack renv a stack in
+	subterm_specif (push_var renv (x,a,spec)) stack' b
 
       (* Metas and evars are considered OK *)
-      | (Meta _|Evar _) -> Dead_code
+    | (Meta _|Evar _) -> Dead_code
+
+    | Proj (p, c) -> 
+      let subt = subterm_specif renv stack c in
+	(match subt with
+	| Subterm (s, wf) -> Subterm (Strict, wf)
+	| Dead_code -> Dead_code
+	| Not_subterm -> Not_subterm)
 
       (* Other terms are not subterms *)
-      | _ -> Not_subterm
+    | _ -> Not_subterm
 
 and lazy_subterm_specif renv stack t =
   lazy (subterm_specif renv stack t)
@@ -606,13 +823,14 @@ and stack_element_specif = function
   |SArg x -> x
 
 and extract_stack renv a = function
-  | [] -> Lazy.lazy_from_val Not_subterm , []
-  | h::t -> stack_element_specif h, t
+   | [] -> Lazy.lazy_from_val Not_subterm , []
+   | h::t -> stack_element_specif h, t
 
 (* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm 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
 
 (************************************************************************)
@@ -635,25 +853,53 @@ 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, kind_of_term 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 kind_of_term 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 
      [stack] is the list of constructor's argument specification and 
-     arguments than will be applied after reduction.
+     arguments that will be applied after reduction.
      example u in t where we have (match .. with |.. => t end) u *)
   let rec check_rec_call renv stack t =
     (* if [t] does not make recursive calls, it is guarded: *)
     if noccur_with_meta renv.rel_min nfi t then ()
     else
-      let (f,l) = decompose_app (whd_betaiotazeta t) in
+      let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in
       match kind_of_term 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: *)
@@ -663,9 +909,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
@@ -689,6 +936,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
@@ -713,29 +961,29 @@ let check_one_fix renv recpos def =
 	    let stack' = push_stack_closures renv l stack in
               Array.iteri
                 (fun j body ->
-                   if i=j && (List.length stack' > decrArg) then
+                   if Int.equal i j && (List.length stack' > decrArg) then
 		     let recArg = List.nth stack' decrArg in
 	             let arg_sp = stack_element_specif recArg in
 	             check_nested_fix_body renv' (decrArg+1) arg_sp body
                    else check_rec_call renv' [] body)
                 bodies
 
-        | Const kn ->
+        | Const (kn,u as cu) ->
             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_in renv.env cu, l)) in
 	        check_rec_call renv stack value
 	    else List.iter (check_rec_call renv []) l
 
         | Lambda (x,a,b) ->
-	    assert (l = []);
+            let () = assert (List.is_empty l) in
 	    check_rec_call renv [] a ;
 	    let spec, stack' = extract_stack renv a stack in
 	    check_rec_call (push_var renv (x,a,spec)) stack' b
 
         | Prod (x,a,b) ->
-	    assert (l = [] && stack = []);
+            let () = assert (List.is_empty l && List.is_empty stack) in
             check_rec_call renv [] a;
             check_rec_call (push_var_renv renv (x,a)) [] b
 
@@ -759,15 +1007,18 @@ let check_one_fix renv recpos def =
 		    check_rec_call renv stack (applist(c,l))
             end
 
-	| Sort _ -> assert (l = [])
+	| Sort _ ->
+          assert (List.is_empty l)
 
         (* l is not checked because it is considered as the meta's context *)
         | (Evar _ | Meta _) -> ()
 
         | (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
+    if Int.equal decr 0 then
       check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
     else
       match kind_of_term body with
@@ -775,23 +1026,23 @@ 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
 
 let judgment_of_fixpoint (_, types, bodies) =
-  array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
+  Array.map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
 
 let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
   let nbfix = Array.length bodies in
-  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";
+  if Int.equal nbfix 0
+    || not (Int.equal (Array.length nvect) nbfix)
+    || not (Int.equal (Array.length types) nbfix)
+    || not (Int.equal (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 vdefj = judgment_of_fixpoint recdef in
   let raise_err env i err =
@@ -805,7 +1056,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) =
         | Lambda (x,a,b) ->
 	    if noccur_with_meta n nbfix a then
 	      let env' = push_rel (x, None, a) env in
-              if n = k+1 then
+              if Int.equal n (k + 1) then
                 (* get the inductive type of the fixpoint *)
                 let (mind, _) =
                   try find_inductive env a
@@ -813,20 +1064,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 (fun (mind,_) -> get_tree mind) minds in
   for i = 0 to Array.length bodies - 1 do
     let (fenv,body) = rdef.(i) in
-    let renv = make_renv fenv 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
 	(push_rec_types recdef env) (judgment_of_fixpoint recdef)
@@ -843,7 +1099,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
@@ -856,7 +1112,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 kind_of_term c with
@@ -867,69 +1123,76 @@ 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
+                  if eq_wf_paths rar mk_norec then
                     if noccur_with_meta n nbfix t
                     then process_args_of_constr (lr, lrar)
                     else raise (CoFixGuardError
 		                 (env,RecCallInNonRecArgOfConstructor t))
-                  else
-                    let spec = dest_subterms rar in
-                    check_rec_call env true n spec t;
-                    process_args_of_constr (lr, lrar)
+                  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)
 
 	| Lambda (x,a,b) ->
-	     assert (args = []);
+	    let () = assert (List.is_empty args) in
             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 ((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/kernel/inductive.mli b/kernel/inductive.mli
index c507fe92..5847d25f 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -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 Names
-open Univ
 open Term
+open Context
+open Univ
 open Declarations
 open Environ
 
@@ -20,9 +21,9 @@ open Environ
    only a coinductive type.
    They raise [Not_found] if not convertible to a recursive type. *)
 
-val find_rectype     : env -> types -> inductive * constr list
-val find_inductive   : env -> types -> inductive * constr list
-val find_coinductive : env -> types -> inductive * constr list
+val find_rectype     : env -> types -> pinductive * constr list
+val find_inductive   : env -> types -> pinductive * constr list
+val find_coinductive : env -> types -> pinductive * constr list
 
 type mind_specif = mutual_inductive_body * one_inductive_body
 
@@ -32,23 +33,40 @@ type mind_specif = mutual_inductive_body * one_inductive_body
 val lookup_mind_specif : env -> inductive -> mind_specif
 
 (** {6 Functions to build standard types related to inductive } *)
-val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
+val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list
+
+val inductive_paramdecls : mutual_inductive_body puniverses -> rel_context
+
+val instantiate_inductive_constraints : 
+  mutual_inductive_body -> universe_instance -> constraints
+
+val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained
+val constrained_type_of_inductive_knowing_parameters : 
+  env -> mind_specif puniverses -> types Lazy.t array -> types constrained
 
-val type_of_inductive : env -> mind_specif -> types
+val type_of_inductive : env -> mind_specif puniverses -> types
+
+val type_of_inductive_knowing_parameters : 
+  env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types
 
 val elim_sorts : mind_specif -> sorts_family list
 
+val is_private : mind_specif -> bool
+val is_primitive_record : mind_specif -> bool
+
 (** Return type as quoted by the user *)
-val type_of_constructor : constructor -> mind_specif -> types
+
+val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained
+val type_of_constructor : pconstructor -> mind_specif -> types
 
 (** Return constructor types in normal form *)
-val arities_of_constructors : inductive -> mind_specif -> types array
+val arities_of_constructors : pinductive -> mind_specif -> types array
 
 (** Return constructor types in user form *)
-val type_of_constructors : inductive -> mind_specif -> types array
+val type_of_constructors : pinductive -> mind_specif -> types array
 
 (** Transforms inductive specification into types (in nf) *)
-val arities_of_specif : mutual_inductive -> mind_specif -> types array
+val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array
 
 val inductive_params : mind_specif -> int
 
@@ -60,11 +78,11 @@ val inductive_params : mind_specif -> int
    the universe constraints generated.
  *)
 val type_case_branches :
-  env -> inductive * constr list -> unsafe_judgment -> constr
-    -> types array * types * constraints
+  env -> pinductive * constr list -> unsafe_judgment -> constr
+    -> types array * types
 
 val build_branches_type :
-  inductive -> mutual_inductive_body * one_inductive_body ->
+  pinductive -> mutual_inductive_body * one_inductive_body ->
     constr list -> constr -> types array
 
 (** Return the arity of an inductive type *)
@@ -74,7 +92,7 @@ val inductive_sort_family : one_inductive_body -> sorts_family
 
 (** Check a [case_info] actually correspond to a Case expression on the
    given inductive type. *)
-val check_case_info : env -> inductive -> case_info -> unit
+val check_case_info : env -> pinductive -> case_info -> unit
 
 (** {6 Guard conditions for fix and cofix-points. } *)
 val check_fix : env -> fixpoint -> unit
@@ -82,22 +100,19 @@ val check_cofix : env -> cofixpoint -> unit
 
 (** {6 Support for sort-polymorphic inductive types } *)
 
-(** The "polyprop" optional argument below allows to control
+(** The "polyprop" optional argument below controls
     the "Prop-polymorphism". By default, it is allowed.
     But when "polyprop=false", the following exception is raised
     when a polymorphic singleton inductive type becomes Prop due to
     parameter instantiation. This is used by the Ocaml extraction,
     which cannot handle (yet?) Prop-polymorphism. *)
 
-exception SingletonInductiveBecomesProp of identifier
-
-val type_of_inductive_knowing_parameters : ?polyprop:bool ->
-  env -> one_inductive_body -> types array -> types
+exception SingletonInductiveBecomesProp of Id.t
 
 val max_inductive_sort : sorts array -> universe
 
 val instantiate_universes : env -> rel_context ->
-    polymorphic_arity -> types array -> rel_context * sorts
+  template_arity -> constr Lazy.t array -> rel_context * sorts
 
 (** {6 Debug} *)
 
@@ -118,3 +133,6 @@ type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
 
 val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
 
+val lambda_implicit_lift : int -> Constr.constr -> Term.constr
+
+val abstract_mind_lc : int -> Int.t -> Constr.constr array -> Constr.constr array
diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib
index 8c1dd53a..29fe887d 100644
--- a/kernel/kernel.mllib
+++ b/kernel/kernel.mllib
@@ -1,32 +1,45 @@
 Names
+Uint31
 Univ
 Esubst
+Sorts
+Evar
+Constr
+Context
+Vars
 Term
 Mod_subst
-Sign
 Cbytecodes
 Copcodes
 Cemitcodes
-Declarations
+Nativevalues
+Primitives
+Nativeinstr
+Opaqueproof
+Declareops
 Retroknowledge
+Conv_oracle
 Pre_env
 Cbytegen
+Nativelambda
+Nativecode
+Nativelib
 Environ
-Conv_oracle
 Closure
 Reduction
+Nativeconv
 Type_errors
-Entries
 Modops
 Inductive
 Typeops
+Fast_typeops
 Indtypes
 Cooking
 Term_typing
 Subtyping
 Mod_typing
+Nativelibrary
 Safe_typing
-
 Vm
 Csymtable
 Vconv
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index d46833db..f7ae30e7 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.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        *)
@@ -19,7 +19,7 @@ open Names
 open Term
 
 (* For Inline, the int is an inlining level, and the constr (if present)
-   is the term into which we should inline *)
+   is the term into which we should inline. *)
 
 type delta_hint =
   | Inline of int * constr option
@@ -31,28 +31,26 @@ type delta_hint =
 module Deltamap = struct
   type t = module_path MPmap.t * delta_hint KNmap.t
   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 find_mp mp map = MPmap.find mp (fst map)
   let find_kn kn map = KNmap.find kn (snd map)
   let mem_mp mp map = MPmap.mem mp (fst map)
-  let mem_kn kn map = KNmap.mem kn (snd map)
   let fold_kn f map i = KNmap.fold f (snd map) i
   let fold fmp fkn (mm,km) i =
     MPmap.fold fmp mm (KNmap.fold fkn km i)
   let join map1 map2 = fold add_mp add_kn map1 map2
 end
 
+(* Invariant: in the [delta_hint] map, an [Equiv] should only
+   relate [kernel_name] with the same label (and section dirpath). *)
+
 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
   let empty = MPmap.empty, MBImap.empty
@@ -61,8 +59,6 @@ module Umap = struct
   let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
   let find_mp mp map = MPmap.find mp (fst map)
   let find_mbi mbi map = MBImap.find mbi (snd map)
-  let mem_mp mp map = MPmap.mem mp (fst map)
-  let mem_mbi mbi map = MBImap.mem mbi (snd map)
   let iter_mbi f map = MBImap.iter f (snd map)
   let fold fmp fmbi (m1,m2) i =
     MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
@@ -95,7 +91,7 @@ let debug_string_of_delta resolve =
 let list_contents sub =
   let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in
   let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in
-  let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in
+  let mbi_one_pair mbi p l = (MBId.debug_to_string mbi, one_pair p)::l in
   Umap.fold mp_one_pair mbi_one_pair sub []
 
 let debug_string_of_subst sub =
@@ -120,11 +116,13 @@ let debug_pr_subst sub =
 
 let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc))
 
-let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn')
+let add_kn_delta_resolver kn kn' =
+  assert (Label.equal (label kn) (label kn'));
+  Deltamap.add_kn kn (Equiv kn')
 
 let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2
 
-(** Extending a [substitution *)
+(** Extending a [substitution] *)
 
 let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s
 let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s
@@ -141,13 +139,13 @@ let kn_in_delta kn resolver =
       | Inline _ -> false
   with Not_found -> false
 
-let con_in_delta con resolver = kn_in_delta (user_con con) resolver
-let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver
+let con_in_delta con resolver = kn_in_delta (Constant.user con) resolver
+let mind_in_delta mind resolver = kn_in_delta (MutInd.user mind) resolver
 
 let mp_of_delta resolve mp =
  try Deltamap.find_mp mp resolve with Not_found -> 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
@@ -156,6 +154,8 @@ let rec find_prefix resolve mp =
   in
   try sub_mp mp with Not_found -> mp
 
+(** Applying a resolver to a kernel name *)
+
 exception Change_equiv_to_inline of (int * constr)
 
 let solve_delta_kn resolve kn =
@@ -174,35 +174,25 @@ let solve_delta_kn resolve kn =
 
 let kn_of_delta resolve kn =
   try solve_delta_kn resolve kn
-  with e when Errors.noncritical e -> kn
+  with Change_equiv_to_inline _ -> kn
 
-let constant_of_delta_kn resolve kn =
-  constant_of_kn_equiv kn (kn_of_delta resolve kn)
+(** Try a 1st resolver, and then a 2nd in case it had no effect *)
 
-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 e when Errors.noncritical e -> x
+let kn_of_deltas resolve1 resolve2 kn =
+  let kn' = kn_of_delta resolve1 kn in
+  if kn' == kn then kn_of_delta resolve2 kn else kn'
 
-let constant_of_delta resolve con =
-  let kn = user_con con in
-  gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+let constant_of_delta_kn resolve kn =
+  Constant.make kn (kn_of_delta resolve kn)
 
-let constant_of_delta2 resolve con =
-  let kn, kn' = canonical_con con, user_con con in
-  gen_of_delta resolve con kn (constant_of_kn_equiv kn')
+let constant_of_deltas_kn resolve1 resolve2 kn =
+  Constant.make kn (kn_of_deltas resolve1 resolve2 kn)
 
 let mind_of_delta_kn resolve kn =
-  mind_of_kn_equiv kn (kn_of_delta resolve kn)
+  MutInd.make kn (kn_of_delta resolve kn)
 
-let mind_of_delta resolve mind =
-  let kn = user_mind mind in
-  gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
-
-let mind_of_delta2 resolve mind =
-  let kn, kn' = canonical_mind mind, user_mind mind in
-  gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
+let mind_of_deltas_kn resolve1 resolve2 kn =
+  MutInd.make kn (kn_of_deltas resolve1 resolve2 kn)
 
 let inline_of_delta inline resolver =
   match inline with
@@ -215,18 +205,16 @@ let inline_of_delta inline resolver =
       in
       Deltamap.fold_kn extract resolver []
 
-let find_inline_of_delta kn resolve =
-  match Deltamap.find_kn kn resolve with
+let search_delta_inline resolve kn1 kn2 =
+  let find kn = match Deltamap.find_kn kn resolve with
     | Inline (_,o) -> o
-    | _ -> raise Not_found
-
-let constant_of_delta_with_inline resolve con =
-  let kn1,kn2 = canonical_con con,user_con con in
-  try find_inline_of_delta kn2 resolve
+    | Equiv _ -> raise Not_found
+  in
+  try find kn1
   with Not_found ->
     if kn1 == kn2 then None
     else
-      try find_inline_of_delta kn1 resolve
+      try find kn2
       with Not_found -> None
 
 let subst_mp0 sub mp = (* 's like subst *)
@@ -270,52 +258,76 @@ let subst_kn sub kn =
 
 exception No_subst
 
-type sideconstantsubst =
-  | User
-  | Canonical
-
-let gen_subst_mp f sub mp1 mp2 =
+let subst_dual_mp sub mp1 mp2 =
   let o1 = subst_mp0 sub mp1 in
   let o2 = if mp1 == mp2 then o1 else subst_mp0 sub mp2 in
   match o1, o2 with
     | None, None -> raise No_subst
-    | Some (mp',resolve), None -> User, (f mp' mp2), resolve
-    | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
-    | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
-
-let subst_ind sub mind =
-  let kn1,kn2 = user_mind mind, canonical_mind mind in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-  let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+    | Some (mp1',resolve), None -> mp1', mp2, resolve, true
+    | None, Some (mp2',resolve) -> mp1, mp2', resolve, false
+    | Some (mp1',_), Some (mp2',resolve) -> mp1', mp2', resolve, false
+
+let progress f x ~orelse =
+  let y = f x in
+  if y != x then y else orelse
+
+let subst_mind sub mind =
+  let mpu,dir,l = MutInd.repr3 mind in
+  let mpc = KerName.modpath (MutInd.canonical mind) in
   try
-    let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
-    match side with
-      | User -> mind_of_delta resolve mind'
-      | Canonical -> mind_of_delta2 resolve mind'
+    let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in
+    let knu = KerName.make mpu dir l in
+    let knc = if mpu == mpc then knu else KerName.make mpc dir l in
+    let knc' =
+      progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc
+    in
+    MutInd.make knu knc'
   with No_subst -> mind
 
-let subst_con0 sub con =
-  let kn1,kn2 = user_con con,canonical_con con in
-  let mp1,dir,l = repr_kn kn1 in
-  let mp2,_,_ = repr_kn kn2 in
-  let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
-  let dup con = con, mkConst con in
-  let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
-  match constant_of_delta_with_inline resolve con' with
+let subst_ind sub (ind,i as indi) =
+  let ind' = subst_mind sub ind in
+    if ind' == ind then indi else ind',i
+
+let subst_pind sub (ind,u) =
+  (subst_ind sub ind, u)
+
+let subst_con0 sub (cst,u) =
+  let mpu,dir,l = Constant.repr3 cst in
+  let mpc = KerName.modpath (Constant.canonical cst) in
+  let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in
+  let knu = KerName.make mpu dir l in
+  let knc = if mpu == mpc then knu else KerName.make mpc dir l in
+  match search_delta_inline resolve knu knc with
     | Some t ->
       (* In case of inlining, discard the canonical part (cf #2608) *)
-      constant_of_kn (user_con con'), t
+      Constant.make1 knu, t
     | None ->
-      let con'' = match side with
-	| User -> constant_of_delta resolve con'
-	| Canonical -> constant_of_delta2 resolve con'
+      let knc' =
+        progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc
       in
-      if con'' == con then raise No_subst else dup con''
+      let cst' = Constant.make knu knc' in
+      cst', mkConstU (cst',u)
+
+let subst_con sub cst =
+  try subst_con0 sub cst
+  with No_subst -> fst cst, mkConstU cst
+
+let subst_con_kn sub con =
+  subst_con sub (con,Univ.Instance.empty)
+
+let subst_pcon sub (con,u as pcon) = 
+  try let con', can = subst_con0 sub pcon in 
+	con',u
+  with No_subst -> pcon
 
-let subst_con sub con =
-  try subst_con0 sub con
-  with No_subst -> con, mkConst con
+let subst_pcon_term sub (con,u as pcon) = 
+  try let con', can = subst_con0 sub pcon in 
+	(con',u), can
+  with No_subst -> pcon, mkConstU pcon
+
+let subst_constant sub con =
+  try fst (subst_con0 sub (con,Univ.Instance.empty))
+  with No_subst -> con
 
 (* Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
@@ -324,18 +336,27 @@ let subst_con sub con =
    interpretation (i.e. an evaluable reference is never expanded). *)
 let subst_evaluable_reference subst = function
   | EvalVarRef id -> EvalVarRef id
-  | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
+  | EvalConstRef kn -> EvalConstRef (subst_constant subst kn)
 
 let rec map_kn f f' c =
   let func = map_kn f f' in
     match kind_of_term c with
       | Const kn -> (try snd (f' kn) with No_subst -> c)
-      | Ind (kn,i) ->
+      | Proj (p,t) -> 
+          let p' = 
+	    try
+	      Projection.map (fun kn -> fst (f' (kn,Univ.Instance.empty))) p
+	    with No_subst -> p
+	  in
+	  let t' = func t in
+	    if p' == p && t' == t then c
+	    else mkProj (p', t')
+      | Ind ((kn,i),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else mkInd (kn',i)
-      | Construct ((kn,i),j) ->
+	  if kn'==kn then c else mkIndU ((kn',i),u)
+      | Construct (((kn,i),j),u) ->
 	  let kn' = f kn in
-	  if kn'==kn then c else mkConstruct ((kn',i),j)
+	  if kn'==kn then c else mkConstructU (((kn',i),j),u)
       | Case (ci,p,ct,l) ->
 	  let ci_ind =
             let (kn,i) = ci.ci_ind in
@@ -344,7 +365,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
@@ -373,35 +394,35 @@ let rec map_kn f f' c =
 	    else mkLetIn (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 mkApp (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 mkEvar (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 mkFix (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 mkCoFix (ln,(lna,tl',bl'))
       | _ -> c
 
 let subst_mps sub c =
   if is_empty_subst sub then c
-  else map_kn (subst_ind sub) (subst_con0 sub) c
+  else map_kn (subst_mind sub) (subst_con0 sub) c
 
 let rec replace_mp_in_mp mpfrom mpto mp =
   match mp with
-    | _ when mp = mpfrom -> mpto
+    | _ when mp_eq mp mpfrom -> mpto
     | MPdot (mp1,l) ->
 	let mp1' = replace_mp_in_mp mpfrom mpto mp1 in
-	  if mp1==mp1' then mp
+	  if mp1 == mp1' then mp
 	  else MPdot (mp1',l)
     | _ -> mp
 
@@ -413,7 +434,7 @@ let replace_mp_in_kn mpfrom mpto kn =
 
 let rec mp_in_mp mp mp1 =
   match mp1 with
-    | _ when mp1 = mp -> true
+    | _ when mp_eq mp1 mp -> true
     | MPdot (mp2,l) -> mp_in_mp mp mp2
     | _ -> false
 
@@ -471,33 +492,30 @@ let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
 
 let update_delta_resolver resolver1 resolver2 =
   let mp_apply_rslv mkey mequ rslv =
-    if Deltamap.mem_mp mkey resolver2 then rslv
-    else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+    Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
   in
-  let kn_apply_rslv kkey hint rslv =
-    if Deltamap.mem_kn kkey resolver2 then rslv
-    else
-      let hint' = match hint with
-	| Equiv kequ ->
-	  (try Equiv (solve_delta_kn resolver2 kequ)
-	   with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
-	| _ -> hint
-      in
-      Deltamap.add_kn kkey hint' rslv
+  let kn_apply_rslv kkey hint1 rslv =
+    let hint = match hint1 with
+      | Equiv kequ ->
+	(try Equiv (solve_delta_kn resolver2 kequ)
+	 with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
+      | Inline (_,Some _) -> hint1
+      | Inline (_,None) ->
+        (try Deltamap.find_kn kkey resolver2 with Not_found -> hint1)
+    in
+    Deltamap.add_kn kkey hint rslv
   in
-  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver
+  Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 resolver2
 
 let add_delta_resolver resolver1 resolver2 =
-  if resolver1 == resolver2 then
-    resolver2
-  else if resolver2 = empty_delta_resolver then
+  if Deltamap.is_empty resolver2 then
     resolver1
   else
-    Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2
+    update_delta_resolver resolver1 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 (mp_eq 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
@@ -529,44 +547,41 @@ let join subst1 subst2 =
   Umap.join subst2 subst
 
 let rec occur_in_path mbi = function
-  | MPbound bid' -> mbi = bid'
+  | MPbound bid' -> MBId.equal mbi bid'
   | MPdot (mp1,_) -> occur_in_path mbi mp1
   | _ -> false
 
 let occur_mbid mbi sub =
   let check_one mbi' (mp,_) =
-    if mbi = mbi' || occur_in_path mbi mp then raise Exit
+    if MBId.equal mbi mbi' || occur_in_path mbi mp then raise Exit
   in
   try
     Umap.iter_mbi check_one sub;
     false
   with Exit -> true
 
-type 'a lazy_subst =
-  | LSval of 'a
-  | LSlazy of substitution list * 'a
+type 'a substituted = {
+  mutable subst_value : 'a;
+  mutable subst_subst : substitution list;
+}
 
-type 'a substituted = 'a lazy_subst ref
+let from_val x = { subst_value = x; subst_subst = []; }
 
-let from_val a = ref (LSval a)
+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
 
-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 = { r with subst_subst = s :: r.subst_subst; }
 
-let subst_substituted s r =
-  match !r with
-    | LSval a -> ref (LSlazy([s],a))
-    | LSlazy(s',a) ->
-	  ref (LSlazy(s::s',a))
+let force_constr = force subst_mps
+let subst_constr = subst_substituted
 
 (* debug *)
-let repr_substituted r =
-  match !r with
-    | LSval a -> None, a
-    | LSlazy(s,a) -> Some s, a
+let repr_substituted r = match r.subst_subst with
+| [] -> None, r.subst_value
+| s -> Some s, r.subst_value
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index d29b4c9a..fc2b0441 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.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        *)
@@ -30,16 +30,25 @@ val add_inline_delta_resolver :
 
 val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
 
-(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *)
+(** Effect of a [delta_resolver] on a module path, on a kernel name *)
 
+val mp_of_delta : delta_resolver -> module_path -> module_path
 val kn_of_delta : delta_resolver -> kernel_name -> kernel_name
+
+(** Build a constant whose canonical part is obtained via a resolver *)
+
 val constant_of_delta_kn : delta_resolver -> kernel_name -> constant
-val constant_of_delta : delta_resolver -> constant -> constant
 
-val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
-val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
+(** Same, but a 2nd resolver is tried if the 1st one had no effect *)
 
-val mp_of_delta : delta_resolver -> module_path -> module_path
+val constant_of_deltas_kn :
+  delta_resolver -> delta_resolver -> kernel_name -> constant
+
+(** Same for inductive names *)
+
+val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
+val mind_of_deltas_kn :
+  delta_resolver -> delta_resolver -> kernel_name -> mutual_inductive
 
 (** Extract the set of inlined constant in the resolver *)
 val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list
@@ -62,13 +71,13 @@ val is_empty_subst : substitution -> bool
 (** add_* add [arg2/arg1]\{arg3\} to the substitution with no
    sequential composition  *)
 val add_mbid :
-  mod_bound_id -> module_path -> delta_resolver  -> substitution -> substitution
+  MBId.t -> module_path -> delta_resolver  -> substitution -> substitution
 val add_mp :
   module_path -> module_path -> delta_resolver -> substitution -> substitution
 
 (** map_* create a new substitution [arg2/arg1]\{arg3\} *)
 val map_mbid :
-  mod_bound_id -> module_path -> delta_resolver -> substitution
+  MBId.t -> module_path -> delta_resolver -> substitution
 val map_mp :
   module_path -> module_path -> delta_resolver -> substitution
 
@@ -109,15 +118,32 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds
 val subst_mp :
   substitution -> module_path -> module_path
 
-val subst_ind :
+val subst_mind :
   substitution -> mutual_inductive -> mutual_inductive
 
+val subst_ind :
+  substitution -> inductive -> inductive
+
+val subst_pind : substitution -> pinductive -> pinductive
+
 val subst_kn :
   substitution -> kernel_name -> kernel_name
 
 val subst_con :
+  substitution -> pconstant -> constant * constr
+
+val subst_pcon :
+  substitution -> pconstant -> pconstant
+
+val subst_pcon_term :
+  substitution -> pconstant -> pconstant * constr
+
+val subst_con_kn :
   substitution -> constant -> constant * constr
 
+val subst_constant : 
+  substitution -> constant -> constant
+
 (** Here the semantics is completely unclear.
    What does "Hint Unfold t" means when "t" is a parameter?
    Does the user mean "Unfold X.t" or does she mean "Unfold y"
@@ -136,10 +162,14 @@ val subst_mps : substitution -> constr -> constr
 (** [occur_*id id sub] returns true iff [id] occurs in [sub]
    on either side *)
 
-val occur_mbid : mod_bound_id -> substitution -> bool
+val occur_mbid : MBId.t -> substitution -> bool
 
 (** [repr_substituted r] dumps the representation of a substituted:
     - [None, a] when r is a value
     - [Some s, a] when r is a delayed substitution [s] applied to [a] *)
 
 val repr_substituted : 'a substituted -> substitution list option * 'a
+
+val force_constr : Term.constr substituted -> Term.constr
+val subst_constr :
+  substitution -> Term.constr substituted -> Term.constr substituted
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index 55fdf1ab..97c1d1fd 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.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        *)
@@ -14,432 +14,313 @@
 
 open Util
 open Names
-open Univ
 open Declarations
 open Entries
 open Environ
-open Term_typing
 open Modops
-open Subtyping
 open Mod_subst
 
-exception Not_path
-
-let path_of_mexpr = function
-  | MSEident mp -> mp
-  | _ -> raise Not_path
+type 'alg translation =
+  module_signature * 'alg option * delta_resolver * Univ.constraints
 
 let rec mp_from_mexpr = function
-  | MSEident mp -> mp
-  | MSEapply (expr,_) -> mp_from_mexpr expr
-  | MSEfunctor (_,_,expr) -> mp_from_mexpr expr
-  | MSEwith (expr,_) -> mp_from_mexpr expr
+  | MEident mp -> mp
+  | MEapply (expr,_) -> mp_from_mexpr expr
+  | MEwith (expr,_) -> mp_from_mexpr expr
 
 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
+(** Split a [structure_body] at some label corresponding to
+    a modular definition or not. *)
 
-let discr_resolver env mtb =
-     match mtb.typ_expr with
-	SEBstruct _ -> 
-	  mtb.typ_delta
-      | _ -> (*case mp is a functor *)
-	  empty_delta_resolver
-	
-let rec rebuild_mp mp l =
-  match l with
-      []-> mp
-    | i::r -> rebuild_mp (MPdot(mp,i)) r 
-	
-let rec check_with env sign with_decl alg_sign mp equiv = 
-  let sign,wd,equiv,cst= match with_decl with
-    | With_Definition (idl,c) ->
-	let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in
-	sign,With_definition_body(idl,cb),equiv,cst
-    | With_Module (idl,mp1) ->
-	let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in
-	sign,With_module_body(idl,mp1),equiv,cst
-  in
-    if alg_sign = None then
-      sign,None,equiv,cst
-    else
-      sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst
-	    
-and check_with_def env sign (idl,c) mp equiv =
-  let sig_b = match sign with 
-    | SEBstruct(sig_b) -> sig_b
-    | _ -> error_signature_expected sign
-  in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
-  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 equiv env in
-      if idl = [] then
-	      (* Toplevel definition *)
-	      let cb = match spec with
-		| SFBconst cb -> cb
-		| _ -> error_not_a_constant l
-	      in
-	      (* In the spirit of subtyping.check_constant, we accept
-                 any implementations of parameters and opaques terms,
-	         as long as they have the right type *)
-	      let def,cst = match cb.const_body with
-		| Undef _ | OpaqueDef _ ->
-		    let (j,cst1) = Typeops.infer env' c in
-		    let typ = Typeops.type_of_constant_type env' cb.const_type in
-		    let cst2 = Reduction.conv_leq env' j.uj_type typ in
-		    let cst =
-		      union_constraints
-			(union_constraints cb.const_constraints cst1)
-			cst2
-		    in
-		    let def = Def (Declarations.from_val j.uj_val) in
-		    def,cst
-		| Def cs ->
-		    let cst1 = Reduction.conv env' c (Declarations.force cs) in
-		    let cst = union_constraints cb.const_constraints cst1 in
-		    let def = Def (Declarations.from_val c) in
-		    def,cst
-	      in
-	      let cb' =
-		{ cb with
-		  const_body = def;
-		  const_body_code =
-		    Cemitcodes.from_val (compile_constant_body env' def);
-		  const_constraints = cst }
-	      in
-	      SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst
-      else
-	      (* Definition inside a sub-module *)
-	      let old = match spec with
-		| SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-		begin
-		  match old.mod_expr with
-                    | None ->
-			let sign,cb,cst = 
-			  check_with_def env' old.mod_type (idl,c)
-			    (MPdot(mp,l)) old.mod_delta in
-			let new_spec = SFBmodule({old with
-						    mod_type = sign;
-						    mod_type_alg = None}) in
-			  SEBstruct(before@(l,new_spec)::after),cb,cst
-                    | Some msb ->
-			error_generative_module_expected l
-		end
-    with
-      | Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_incorrect_with_constraint l
+let split_struc k m struc =
+  let rec split rev_before = function
+    | [] -> raise Not_found
+    | (k',b)::after when Label.equal k k' && (is_modular b) == (m : bool) ->
+      List.rev rev_before,b,after
+    | h::tail -> split (h::rev_before) tail
+  in split [] struc
 
-and check_with_mod env sign (idl,mp1) mp equiv = 
-  let sig_b = match sign with 
-    | SEBstruct(sig_b) ->sig_b
-    | _ -> error_signature_expected sign
-  in
-  let id,idl = match idl with
-    | [] -> assert false
-    | id::idl -> id,idl
-  in
-  let l = label_of_id id in
-    try
-      let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in
-      let before = List.rev rev_before in
-      let env' = Modops.add_signature mp before equiv env in
-      if idl = [] then
-	      (* Toplevel module definition *)
-	      let old = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-	      let mb_mp1 = (lookup_module mp1 env) in
-	      let mtb_mp1 = 
-		module_type_of_module None mb_mp1  in
-	      let cst =
-		match old.mod_expr with
-		    None ->
-		      begin
-			try union_constraints
-			  (check_subtypes env' mtb_mp1 
-			     (module_type_of_module None old))
-			  old.mod_constraints
-			with Failure _ -> error_incorrect_with_constraint (label_of_id id)
-		      end
-		  | Some (SEBident(mp')) ->
-		      check_modpath_equiv env' mp1 mp';
-		      old.mod_constraints
-		  | _ ->  error_generative_module_expected l
-	      in
-	      let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false
-	      in
-	      let new_spec = SFBmodule {new_mb with 
-					  mod_mp = MPdot(mp,l);
-					  mod_expr = Some (SEBident mp1);
-					  mod_constraints = cst} in
-		(* we propagate the new equality in the rest of the signature
-		   with the identity substitution accompagned by the new resolver*)
-	      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in
-		SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
-	      add_delta_resolver equiv new_mb.mod_delta,cst
-      else
-	      (* Module definition of a sub-module *)
-	      let old = match spec with
-		  SFBmodule msb -> msb
-		| _ -> error_not_a_module (string_of_label l)
-	      in
-	      begin
-		match old.mod_expr with
-		    None ->
-		      let sign,equiv',cst =
-			check_with_mod env'
-			  old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in
-		      let new_equiv = add_delta_resolver equiv equiv' in
-		      let new_spec = SFBmodule {old with 
-						  mod_type = sign;
-						  mod_type_alg = None;
-						  mod_delta = equiv'}
-		      in
-		      let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in
-			SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
-		      new_equiv,cst
-		  | Some (SEBident(mp')) ->
-		      let mpnew = rebuild_mp mp' (List.map label_of_id idl) in
-			check_modpath_equiv env' mpnew mp;
-			  SEBstruct(before@(l,spec)::after)
-			    ,equiv,empty_constraint
-		  | _ ->
-		      error_generative_module_expected l
-              end
-    with
-	Not_found -> error_no_such_label l
-      | Reduction.NotConvertible -> error_incorrect_with_constraint l
+let discr_resolver mtb = match mtb.mod_type with
+  | NoFunctor _ -> mtb.mod_delta
+  | MoreFunctor _ -> empty_delta_resolver
 
-and translate_module env mp inl me =
-  match me.mod_entry_expr, me.mod_entry_type with
-    | None, None ->
-	anomaly "Mod_typing.translate_module: empty type and expr in module entry"
-    | None, Some mte ->
-	let mtb = translate_module_type env mp inl mte in
-	  { mod_mp = mp;
-	    mod_expr = None;
-	    mod_type = mtb.typ_expr;
-	    mod_type_alg = mtb.typ_expr_alg;
-	    mod_delta = mtb.typ_delta;
-	    mod_constraints = mtb.typ_constraints; 
-	    mod_retroknowledge = []}
-   | Some mexpr, _ ->
-	let sign,alg_implem,resolver,cst1 =
-	  translate_struct_module_entry env mp inl mexpr in
-	let sign,alg1,resolver,cst2 =
-	  match me.mod_entry_type with
-	    | None ->
-		sign,None,resolver,empty_constraint
-	    | Some mte ->
-		let mtb = translate_module_type env mp inl mte in
-                let cst = check_subtypes env
-		  {typ_mp = mp;
-		   typ_expr = sign;
-		   typ_expr_alg = None;
-		   typ_constraints = empty_constraint;
-		   typ_delta = resolver;}
-		  mtb
-		in
-		  mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst
-	in
-	  { mod_mp = mp;
-	    mod_type = sign;
-	    mod_expr = alg_implem;
-	    mod_type_alg = alg1;
-	    mod_constraints = Univ.union_constraints cst1 cst2;
-	    mod_delta = resolver;
-	    mod_retroknowledge = []} 
-	    (* spiwack: not so sure about that. It may
-	       cause a bug when closing nested modules.
-	       If it does, I don't really know how to
-	       fix the bug.*)
+let rec rebuild_mp mp l =
+  match l with
+  | []-> mp
+  | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r
 
-and translate_apply env inl ftrans mexpr mkalg =
-  let sign,alg,resolver,cst1 = ftrans in
-  let farg_id, farg_b, fbody_b = destr_functor env sign in
-  let mp1 =
-    try path_of_mexpr mexpr
-    with Not_path -> error_application_to_not_path mexpr
-  in
-  let mtb = module_type_of_module None (lookup_module mp1 env) in
-  let cst2 = check_subtypes env mtb farg_b in
-  let mp_delta = discr_resolver env mtb in
-  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
-  let subst = map_mbid farg_id mp1 mp_delta
-  in
-  subst_struct_expr subst fbody_b,
-  mkalg alg mp1 cst2,
-  subst_codom_delta_resolver subst resolver,
-  Univ.union_constraints cst1 cst2
+let (+++) = Univ.Constraint.union
 
-and translate_functor env inl arg_id arg_e trans mkalg =
-  let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
-  let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
-  let sign,alg,resolver,cst = trans env'
+let rec check_with_def env struc (idl,c) mp equiv =
+  let lab,idl = match idl with
+    | [] -> assert false
+    | id::idl -> Label.of_id id, idl
   in
-  SEBfunctor (arg_id, mtb, sign),
-  mkalg alg arg_id mtb,
-  resolver,
-  Univ.union_constraints cst mtb.typ_constraints
-
-and translate_struct_module_entry env mp inl = function
-  | MSEident mp1 ->
-      let mb = lookup_module mp1 env in
-      let mb' = strengthen_and_subst_mb mb mp false in
-      mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint
-  | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let trans env' = translate_struct_module_entry env' mp inl body_expr in
-      let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in
-      translate_functor env inl arg_id arg_e trans mkalg
-  | MSEapply (fexpr,mexpr) ->
-      let trans = translate_struct_module_entry env mp inl fexpr in
-      let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in
-      translate_apply env inl trans mexpr mkalg
-  | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 =
-	translate_struct_module_entry env mp inl mte in
-      let sign,alg,resolve,cst2 =
-	check_with env sign with_decl alg mp resolve in
-      sign,alg,resolve,Univ.union_constraints cst1 cst2
-
-and translate_struct_type_entry env inl = function
-  | MSEident mp1 ->
-      let mtb = lookup_modtype mp1 env in
-      mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint
-  | MSEfunctor (arg_id, arg_e, body_expr) ->
-      let trans env' = translate_struct_type_entry env' inl body_expr in
-      translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None)
-  | MSEapply (fexpr,mexpr) ->
-      let trans = translate_struct_type_entry env inl fexpr in
-      translate_apply env inl trans mexpr (fun _ _ _ -> None)
-  | MSEwith(mte, with_decl) ->
-      let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in
-      let sign,alg,resolve,cst2 =
-	check_with env sign with_decl alg (mp_from_mexpr mte) resolve
+  try
+    let modular = not (List.is_empty idl) in
+    let before,spec,after = split_struc lab modular struc in
+    let env' = Modops.add_structure mp before equiv env in
+    if List.is_empty idl then
+      (* Toplevel definition *)
+      let cb = match spec with
+	| SFBconst cb -> cb
+	| _ -> error_not_a_constant lab
       in
-      sign,alg,resolve,Univ.union_constraints cst1 cst2
-
-and translate_module_type env mp inl mte =
-  let mp_from = mp_from_mexpr mte in
-  let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
-  let mtb = subst_modtype_and_resolver
-    {typ_mp = mp_from;
-     typ_expr = sign;
-     typ_expr_alg = None;
-     typ_constraints = cst;
-     typ_delta = resolve} mp
-  in {mtb with typ_expr_alg = alg}
-
-let rec translate_struct_include_module_entry env mp inl = function
-  | MSEident mp1 ->
-      let mb = lookup_module mp1 env in
-      let mb' = strengthen_and_subst_mb mb mp true in
-      let mb_typ = clean_bounded_mod_expr mb'.mod_type in
-      mb_typ,None,mb'.mod_delta,Univ.empty_constraint
-  | MSEapply (fexpr,mexpr) ->
-      let ftrans = translate_struct_include_module_entry env mp inl fexpr in
-      translate_apply env inl ftrans mexpr (fun _ _ _ -> None)
-  | _ -> error ("You cannot Include a high-order structure.")
-
-let rec add_struct_expr_constraints env = function
-  | SEBident _ -> env
-
-  | SEBfunctor (_,mtb,meb) ->
-      add_struct_expr_constraints
-	(add_modtype_constraints env mtb) meb
-
-  | SEBstruct (structure_body) ->
-      List.fold_left
-        (fun env (_,item) -> add_struct_elem_constraints env item)
-        env
-        structure_body
-
-  | SEBapply (meb1,meb2,cst) ->
-      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(_,_))->
-      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
-  | 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 =
-    add_struct_expr_constraints env mb.mod_type
+      (* In the spirit of subtyping.check_constant, we accept
+         any implementations of parameters and opaques terms,
+	 as long as they have the right type *)
+      let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in
+      let env' = Environ.add_constraints ccst env' in
+      let c',cst = match cb.const_body with
+	| Undef _ | OpaqueDef _ ->
+	  let j = Typeops.infer env' c in
+	  let typ = Typeops.type_of_constant_type env' cb.const_type in
+	  let cst = Reduction.infer_conv_leq env' (Environ.universes env')
+	    j.uj_type typ in
+	  j.uj_val,cst
+	| Def cs ->
+	  let cst = Reduction.infer_conv env' (Environ.universes env') c
+	    (Mod_subst.force_constr cs) in
+	  let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *)
+	    if cb.const_polymorphic then cst
+	    else ccst +++ cst 
+	  in
+            c, cst
+      in
+      let def = Def (Mod_subst.from_val c') in
+      let cb' =
+	{ cb with
+	  const_body = def;
+	  const_body_code = Cemitcodes.from_val (compile_constant_body env' def) }
+	  (* const_universes = Future.from_val cst } *)
+      in
+      before@(lab,SFBconst(cb'))::after, c', cst
+    else
+      (* Definition inside a sub-module *)
+      let mb = match spec with
+	| SFBmodule mb -> mb
+	| _ -> error_not_a_module (Label.to_string lab)
+      in
+      begin match mb.mod_expr with
+      | Abstract ->
+        let struc = Modops.destr_nofunctor mb.mod_type in
+        let struc',c',cst =
+          check_with_def env' struc (idl,c) (MPdot(mp,lab)) mb.mod_delta
+        in
+        let mb' = { mb with
+          mod_type = NoFunctor struc';
+	  mod_type_alg = None }
+        in
+	before@(lab,SFBmodule mb')::after, c', cst
+      | _ -> error_generative_module_expected lab
+      end
+  with
+  | Not_found -> error_no_such_label lab
+  | Reduction.NotConvertible -> error_incorrect_with_constraint lab
+
+let rec check_with_mod env struc (idl,mp1) mp equiv =
+  let lab,idl = match idl with
+    | [] -> assert false
+    | id::idl -> Label.of_id id, idl
   in
-    Environ.add_constraints mb.mod_constraints env
-
-and add_modtype_constraints env mtb =
-  Environ.add_constraints mtb.typ_constraints
-    (add_struct_expr_constraints env mtb.typ_expr)
-
-
-let rec struct_expr_constraints cst = function
-  | SEBident _ -> cst
-
-  | SEBfunctor (_,mtb,meb) ->
-      struct_expr_constraints
-	(modtype_constraints cst mtb) meb
-
-  | SEBstruct (structure_body) ->
-      List.fold_left
-        (fun cst (_,item) -> struct_elem_constraints cst item)
-        cst
-        structure_body
-
-  | SEBapply (meb1,meb2,cst1) ->
-      struct_expr_constraints
-	(struct_expr_constraints (Univ.union_constraints cst1 cst) meb1)
-	meb2
-  | SEBwith(meb,With_definition_body(_,cb))->
-      struct_expr_constraints
-        (Univ.union_constraints cb.const_constraints cst) meb
-  | SEBwith(meb,With_module_body(_,_))->
-      struct_expr_constraints  cst meb	
-		
-and struct_elem_constraints cst = function 
-  | SFBconst cb -> cst
-  | SFBmind mib -> cst
-  | SFBmodule mb -> module_constraints cst mb
-  | SFBmodtype mtb -> modtype_constraints cst mtb
-
-and module_constraints cst mb =
-  let cst = match mb.mod_expr with
-    | None -> cst
-    | Some meb -> struct_expr_constraints cst meb in
-  let cst = 
-      struct_expr_constraints cst mb.mod_type in
-  Univ.union_constraints mb.mod_constraints cst
-
-and modtype_constraints cst mtb =
-  struct_expr_constraints  (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr
-
-
-let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint
-let module_constraints = module_constraints Univ.empty_constraint
+  try
+    let before,spec,after = split_struc lab true struc in
+    let env' = Modops.add_structure mp before equiv env in
+    let old = match spec with
+      | SFBmodule mb -> mb
+      | _ -> error_not_a_module (Label.to_string lab)
+    in
+    if List.is_empty idl then
+      (* Toplevel module definition *)
+      let mb_mp1 = lookup_module mp1 env in
+      let mtb_mp1 = module_type_of_module mb_mp1 in
+      let cst = match old.mod_expr with
+	| Abstract ->
+	  begin
+            try
+              let mtb_old = module_type_of_module old in
+              Subtyping.check_subtypes env' mtb_mp1 mtb_old
+                +++ old.mod_constraints
+	    with Failure _ -> error_incorrect_with_constraint lab
+	  end
+	| Algebraic (NoFunctor (MEident(mp'))) ->
+	  check_modpath_equiv env' mp1 mp';
+	  old.mod_constraints
+	| _ -> error_generative_module_expected lab
+      in
+      let mp' = MPdot (mp,lab) in
+      let new_mb = strengthen_and_subst_mb mb_mp1 mp' false in
+      let new_mb' =
+        { new_mb with
+          mod_mp = mp';
+          mod_expr = Algebraic (NoFunctor (MEident mp1));
+          mod_constraints = cst }
+      in
+      let new_equiv = add_delta_resolver equiv new_mb.mod_delta in
+      (* we propagate the new equality in the rest of the signature
+	 with the identity substitution accompagned by the new resolver*)
+      let id_subst = map_mp mp' mp' new_mb.mod_delta in
+      let new_after = subst_structure id_subst after in
+      before@(lab,SFBmodule new_mb')::new_after, new_equiv, cst
+    else
+      (* Module definition of a sub-module *)
+      let mp' = MPdot (mp,lab) in
+      let old = match spec with
+        | SFBmodule msb -> msb
+	| _ -> error_not_a_module (Label.to_string lab)
+      in
+      begin match old.mod_expr with
+      | Abstract ->
+        let struc = destr_nofunctor old.mod_type in
+	let struc',equiv',cst =
+          check_with_mod env' struc (idl,mp1) mp' old.mod_delta
+        in
+	let new_mb =
+          { old with
+            mod_type = NoFunctor struc';
+            mod_type_alg = None;
+            mod_delta = equiv' }
+        in
+	let new_equiv = add_delta_resolver equiv equiv' in
+	let id_subst = map_mp mp' mp' equiv' in
+        let new_after = subst_structure id_subst after in
+	before@(lab,SFBmodule new_mb)::new_after, new_equiv, cst
+      | Algebraic (NoFunctor (MEident mp0)) ->
+	let mpnew = rebuild_mp mp0 idl in
+	check_modpath_equiv env' mpnew mp;
+	before@(lab,spec)::after, equiv, Univ.Constraint.empty
+      | _ -> error_generative_module_expected lab
+      end
+  with
+  | Not_found -> error_no_such_label lab
+  | Reduction.NotConvertible -> error_incorrect_with_constraint lab
+
+let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg
+
+let check_with env mp (sign,alg,reso,cst) = function
+  |WithDef(idl,c) ->
+    let struc = destr_nofunctor sign in
+    let struc',c',cst' = check_with_def env struc (idl,c) mp reso in
+    let alg' = mk_alg_with alg (WithDef (idl,c')) in
+    (NoFunctor struc'),alg',reso, cst+++cst'
+  |WithMod(idl,mp1) as wd ->
+    let struc = destr_nofunctor sign in
+    let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in
+    let alg' = mk_alg_with alg wd in
+    (NoFunctor struc'),alg',reso', cst+++cst'
+
+let mk_alg_app mpo alg arg = match mpo, alg with
+  | Some _, Some alg -> Some (MEapply (alg,arg))
+  | _ -> None
+
+(** Translation of a module struct entry :
+    - We translate to a module when a [module_path] is given,
+      otherwise to a module type.
+    - The first output is the expanded signature
+    - The second output is the algebraic expression, kept for the extraction.
+      It is never None when translating to a module, but for module type
+      it could not be contain [SEBapply] or [SEBfunctor].
+*)
+
+let rec translate_mse env mpo inl = function
+  |MEident mp1 ->
+    let sign,reso = match mpo with
+      |Some mp ->
+        let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in
+        mb.mod_type, mb.mod_delta
+      |None ->
+        let mtb = lookup_modtype mp1 env in
+        mtb.mod_type, mtb.mod_delta
+    in
+    sign,Some (MEident mp1),reso,Univ.Constraint.empty
+  |MEapply (fe,mp1) ->
+    translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo)
+  |MEwith(me, with_decl) ->
+    assert (mpo == None); (* No 'with' syntax for modules *)
+    let mp = mp_from_mexpr me in
+    check_with env mp (translate_mse env None inl me) with_decl
+
+and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg =
+  let farg_id, farg_b, fbody_b = destr_functor sign in
+  let mtb = module_type_of_module (lookup_module mp1 env) in
+  let cst2 = Subtyping.check_subtypes env mtb farg_b in
+  let mp_delta = discr_resolver mtb in
+  let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
+  let subst = map_mbid farg_id mp1 mp_delta in
+  let body = subst_signature subst fbody_b in
+  let alg' = mkalg alg mp1 in
+  let reso' = subst_codom_delta_resolver subst reso in
+  body,alg',reso', cst1 +++ cst2
+
+let mk_alg_funct mpo mbid mtb alg = match mpo, alg with
+  | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg))
+  | _ -> None
+
+let mk_mod mp e ty ty' cst reso =
+  { mod_mp = mp;
+    mod_expr = e;
+    mod_type = ty;
+    mod_type_alg = ty';
+    mod_constraints = cst;
+    mod_delta = reso;
+    mod_retroknowledge = [] }
+
+let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso
+
+let rec translate_mse_funct env mpo inl mse = function
+  |[] ->
+    let sign,alg,reso,cst = translate_mse env mpo inl mse in
+    sign, Option.map (fun a -> NoFunctor a) alg, reso, cst
+  |(mbid, ty) :: params ->
+    let mp_id = MPbound mbid in
+    let mtb = translate_modtype env mp_id inl ([],ty) in
+    let env' = add_module_type mp_id mtb env in
+    let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in
+    let alg' = mk_alg_funct mpo mbid mtb alg in
+    MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints
+
+and translate_modtype env mp inl (params,mte) =
+  let sign,alg,reso,cst = translate_mse_funct env None inl mte params in
+  let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in
+  let mtb' = subst_modtype_and_resolver mtb mp in
+  { mtb' with mod_type_alg = alg }
+
+(** [finalize_module] :
+    from an already-translated (or interactive) implementation
+    and a signature entry, produce a final [module_expr] *)
+
+let finalize_module env mp (sign,alg,reso,cst) restype = match restype with
+  |None ->
+    let impl = match alg with Some e -> Algebraic e | None -> FullStruct in
+    mk_mod mp impl sign None cst reso
+  |Some (params_mte,inl) ->
+    let res_mtb = translate_modtype env mp inl params_mte in
+    let auto_mtb = mk_modtype mp sign Univ.Constraint.empty reso in
+    let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in
+    let impl = match alg with Some e -> Algebraic e | None -> Struct sign in
+    { res_mtb with
+      mod_mp = mp;
+      mod_expr = impl;
+      mod_constraints = cst +++ cst' }
+
+let translate_module env mp inl = function
+  |MType (params,ty) ->
+    let mtb = translate_modtype env mp inl (params,ty) in
+    module_body_of_type mp mtb
+  |MExpr (params,mse,oty) ->
+    let t = translate_mse_funct env (Some mp) inl mse params in
+    let restype = Option.map (fun ty -> ((params,ty),inl)) oty in
+    finalize_module env mp t restype
+
+let rec translate_mse_incl env mp inl = function
+  |MEident mp1 ->
+    let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in
+    let sign = clean_bounded_mod_expr mb.mod_type in
+    sign,None,mb.mod_delta,Univ.Constraint.empty
+  |MEapply (fe,arg) ->
+    let ftrans = translate_mse_incl env mp inl fe in
+    translate_apply env inl ftrans arg (fun _ _ -> None)
+  |_ -> Modops.error_higher_order_include ()
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index e868aec2..b39e8212 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.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        *)
@@ -12,40 +12,35 @@ open Entries
 open Mod_subst
 open Names
 
+(** Main functions for translating module entries *)
 
 val translate_module :
   env -> module_path -> inline -> module_entry -> module_body
 
-val translate_module_type :
-  env -> module_path -> inline -> module_struct_entry -> module_type_body
+val translate_modtype :
+  env -> module_path -> inline -> module_type_entry -> module_type_body
 
-val translate_struct_module_entry :
-  env -> module_path -> inline -> module_struct_entry ->
-  struct_expr_body (* Signature *)
-  * struct_expr_body option  (* Algebraic expr, in fact never None *)
-  * delta_resolver
-  * Univ.constraints
-
-val translate_struct_type_entry :
-  env -> inline -> module_struct_entry ->
-  struct_expr_body
-  * struct_expr_body option
-  * delta_resolver
-  * Univ.constraints
-
-val translate_struct_include_module_entry :
-  env -> module_path -> inline -> module_struct_entry ->
-  struct_expr_body
-  * struct_expr_body option (* Algebraic expr, always None *)
-  * delta_resolver
-  * Univ.constraints
+(** Low-level function for translating a module struct entry :
+    - We translate to a module when a [module_path] is given,
+      otherwise to a module type.
+    - The first output is the expanded signature
+    - The second output is the algebraic expression, kept for the extraction.
+      It is never None when translating to a module, but for module type
+      it could not be contain applications or functors.
+*)
 
-val add_modtype_constraints : env -> module_type_body -> env
+type 'alg translation =
+  module_signature * 'alg option * delta_resolver * Univ.constraints
 
-val add_module_constraints : env -> module_body -> env
+val translate_mse :
+  env -> module_path option -> inline -> module_struct_entry ->
+    module_alg_expr translation
 
-val add_struct_expr_constraints : env -> struct_expr_body -> env
-
-val struct_expr_constraints : struct_expr_body -> Univ.constraints
+val translate_mse_incl :
+  env -> module_path -> inline -> module_struct_entry ->
+    module_alg_expr translation
 
-val module_constraints : module_body -> Univ.constraints
+val finalize_module :
+  env -> module_path -> module_expression translation ->
+  (module_type_entry * inline) option ->
+  module_body
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 3a914477..392e667b 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.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        *)
@@ -16,53 +16,58 @@
 (* This file provides with various operations on modules and module types *)
 
 open Util
-open Pp
 open Names
-open Univ
 open Term
 open Declarations
+open Declareops
 open Environ
 open Entries
 open Mod_subst
 
+(** {6 Errors } *)
+
 type signature_mismatch_error =
   | InductiveFieldExpected of mutual_inductive_body
   | DefinitionFieldExpected
   | ModuleFieldExpected
   | ModuleTypeFieldExpected
-  | NotConvertibleInductiveField of identifier
-  | NotConvertibleConstructorField of identifier
+  | NotConvertibleInductiveField of Id.t
+  | NotConvertibleConstructorField of Id.t
   | NotConvertibleBodyField
   | NotConvertibleTypeField of env * types * types
+  | PolymorphicStatusExpected of bool
   | NotSameConstructorNamesField
   | NotSameInductiveNameInBlockField
   | FiniteInductiveFieldExpected of bool
   | InductiveNumbersFieldExpected of int
   | InductiveParamsNumberField of int
   | RecordFieldExpected of bool
-  | RecordProjectionsExpected of name list
+  | RecordProjectionsExpected of Name.t list
   | NotEqualInductiveAliases
   | NoTypeConstraintExpected
+  | IncompatibleInstances
+  | IncompatibleUniverses of Univ.univ_inconsistency
+  | IncompatiblePolymorphism of env * types * types
+  | IncompatibleConstraints of Univ.constraints
 
 type module_typing_error =
-  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
-  | LabelAlreadyDeclared of label
+  | SignatureMismatch of
+      Label.t * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of Label.t
   | ApplicationToNotPath of module_struct_entry
-  | NotAFunctor of struct_expr_body
+  | NotAFunctor
+  | IsAFunctor
   | IncompatibleModuleTypes of module_type_body * module_type_body
   | NotEqualModulePaths of module_path * module_path
-  | NoSuchLabel of label
-  | IncompatibleLabels of label * label
-  | SignatureExpected of struct_expr_body
-  | NoModuleToEnd
-  | NoModuleTypeToEnd
+  | NoSuchLabel of Label.t
+  | IncompatibleLabels of Label.t * Label.t
   | NotAModule of string
   | NotAModuleType of string
-  | NotAConstant of label
-  | IncorrectWithConstraint of label
-  | GenerativeModuleExpected of label
-  | NonEmptyLocalContect of label option
-  | LabelMissing of label * string
+  | NotAConstant of Label.t
+  | IncorrectWithConstraint of Label.t
+  | GenerativeModuleExpected of Label.t
+  | LabelMissing of Label.t * string
+  | HigherOrderInclude
 
 exception ModuleTypingError of module_typing_error
 
@@ -72,8 +77,11 @@ let error_existing_label l =
 let error_application_to_not_path mexpr =
   raise (ModuleTypingError (ApplicationToNotPath mexpr))
 
-let error_not_a_functor mtb =
-  raise (ModuleTypingError (NotAFunctor mtb))
+let error_not_a_functor () =
+  raise (ModuleTypingError NotAFunctor)
+
+let error_is_a_functor () =
+  raise (ModuleTypingError IsAFunctor)
 
 let error_incompatible_modtypes mexpr1 mexpr2 =
   raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2)))
@@ -90,18 +98,6 @@ let error_no_such_label l =
 let error_incompatible_labels l l' =
   raise (ModuleTypingError (IncompatibleLabels (l,l')))
 
-let error_signature_expected mtb =
-  raise (ModuleTypingError (SignatureExpected mtb))
-
-let error_no_module_to_end _ =
-  raise (ModuleTypingError NoModuleToEnd)
-
-let error_no_modtype_to_end _ =
-  raise (ModuleTypingError NoModuleTypeToEnd)
-
-let error_not_a_modtype s =
-  raise (ModuleTypingError (NotAModuleType s))
-
 let error_not_a_module s =
   raise (ModuleTypingError (NotAModule s))
 
@@ -114,141 +110,165 @@ let error_incorrect_with_constraint l =
 let error_generative_module_expected l =
   raise (ModuleTypingError (GenerativeModuleExpected l))
 
-let error_non_empty_local_context lo =
-  raise (ModuleTypingError (NonEmptyLocalContect lo))
-
 let error_no_such_label_sub l l1 =
   raise (ModuleTypingError (LabelMissing (l,l1)))
 
-(************************)
+let error_higher_order_include () =
+  raise (ModuleTypingError HigherOrderInclude)
 
-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
+(** {6 Operations on functors } *)
 
 let is_functor = function
- | SEBfunctor (arg_id,arg_t,body_t) -> true
- | _ -> false
-
-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 check_modpath_equiv env mp1 mp2 = 
-  if mp1=mp2 then () else
-    let mb1=lookup_module  mp1 env in
-    let mb2=lookup_module mp2 env in
-      if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2)
-      then ()
-      else error_not_equal_modpaths mp1 mp2
-	
-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 do_delta mtb=
-  let mp = subst_mp sub mtb.typ_mp in
-  let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in
-  let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in
-  let typ_alg' = 
-    Option.smartmap 
-      (subst_struct_expr sub (fun x y-> x)) mtb.typ_expr_alg in
-  let mtb_delta = do_delta mtb.typ_delta sub 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';
-	 typ_delta = mtb_delta}
-	
-and subst_structure sub do_delta 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 do_delta mb)
-    | SFBmodtype mtb -> 
-	SFBmodtype (subst_modtype sub do_delta mtb)
+  |NoFunctor _ -> false
+  |MoreFunctor _ -> true
+
+let destr_functor = function
+  |NoFunctor _ -> error_not_a_functor ()
+  |MoreFunctor (mbid,ty,x) -> (mbid,ty,x)
+
+let destr_nofunctor = function
+  |NoFunctor a -> a
+  |MoreFunctor _ -> error_is_a_functor ()
+
+let rec functor_smartmap fty f0 funct = match funct with
+  |MoreFunctor (mbid,ty,e) ->
+    let ty' = fty ty in
+    let e' = functor_smartmap fty f0 e in
+    if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e')
+  |NoFunctor a ->
+    let a' = f0 a in if a==a' then funct else NoFunctor a'
+
+let rec functor_iter fty f0 = function
+  |MoreFunctor (mbid,ty,e) -> fty ty; functor_iter fty f0 e
+  |NoFunctor a -> f0 a
+
+(** {6 Misc operations } *)
+
+let module_type_of_module mb =
+  { mb with mod_expr = Abstract; mod_type_alg = None }
+
+let module_body_of_type mp mtb =
+  assert (mtb.mod_expr == Abstract);
+  { mtb with mod_mp = mp }
+
+let check_modpath_equiv env mp1 mp2 =
+  if ModPath.equal mp1 mp2 then ()
+  else
+    let mp1' = mp_of_delta (lookup_module mp1 env).mod_delta mp1 in
+    let mp2' = mp_of_delta (lookup_module mp2 env).mod_delta mp2 in
+    if ModPath.equal mp1' mp2' then ()
+    else error_not_equal_modpaths mp1 mp2
+
+let implem_smartmap fs fa impl = match impl with
+  |Struct e -> let e' = fs e in if e==e' then impl else Struct e'
+  |Algebraic a -> let a' = fa a in if a==a' then impl else Algebraic a'
+  |Abstract|FullStruct -> impl
+
+let implem_iter fs fa impl = match impl with
+  |Struct e -> fs e
+  |Algebraic a -> fa a
+  |Abstract|FullStruct -> ()
+
+(** {6 Substitutions of modular structures } *)
+
+let id_delta x y = x
+
+let subst_with_body sub = function
+  |WithMod(id,mp) as orig ->
+    let mp' = subst_mp sub mp in
+    if mp==mp' then orig else WithMod(id,mp')
+  |WithDef(id,c) as orig ->
+    let c' = subst_mps sub c in
+    if c==c' then orig else WithDef(id,c')
+
+let rec subst_structure sub do_delta sign =
+  let subst_body ((l,body) as orig) = match body with
+    |SFBconst cb ->
+      let cb' = subst_const_body sub cb in
+      if cb==cb' then orig else (l,SFBconst cb')
+    |SFBmind mib ->
+      let mib' = subst_mind_body sub mib in
+      if mib==mib' then orig else (l,SFBmind mib')
+    |SFBmodule mb ->
+      let mb' = subst_module sub do_delta mb in
+      if mb==mb' then orig else (l,SFBmodule mb')
+    |SFBmodtype mtb ->
+      let mtb' = subst_modtype sub do_delta mtb in
+      if mtb==mtb' then orig else (l,SFBmodtype mtb')
   in
-    List.map (fun (l,b) -> (l,subst_body b)) sign
-
-and subst_module sub do_delta mb =
-  let mp = subst_mp sub mb.mod_mp in
-  let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then
-    add_mp mb.mod_mp mp
-      empty_delta_resolver sub else sub in 
-  let id_delta = (fun x y-> x) in
-  let mtb',me' = 
-    let mtb = subst_struct_expr sub do_delta mb.mod_type in 
-      match mb.mod_expr with
-	  None -> mtb,None
-	| Some me -> if me==mb.mod_type then
-	    mtb,Some mtb
-	  else mtb,Option.smartmap 
-	    (subst_struct_expr sub id_delta) mb.mod_expr
+  List.smartmap subst_body sign
+
+and subst_body is_mod sub do_delta mb =
+  let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in
+  let mp' = subst_mp sub mp in
+  let sub =
+    if ModPath.equal mp mp' then sub
+    else if is_mod && not (is_functor ty) then sub
+    else add_mp mp mp' empty_delta_resolver sub
   in
-  let typ_alg' = Option.smartmap 
-    (subst_struct_expr sub id_delta) mb.mod_type_alg in
-  let mb_delta = do_delta mb.mod_delta sub in
-    if mtb'==mb.mod_type && mb.mod_expr == me' 
-      && mb_delta == mb.mod_delta && mp == mb.mod_mp
-    then mb else
-      { mb with
-	  mod_mp = mp;
-	  mod_expr = me';
-	  mod_type_alg = typ_alg';
-	  mod_type=mtb'; 
-	  mod_delta = mb_delta}
-
-and subst_struct_expr sub do_delta = function
-    | SEBident mp -> SEBident (subst_mp sub mp)
-    | SEBfunctor (mbid, mtb, meb') -> 
-	SEBfunctor(mbid,subst_modtype sub do_delta mtb
-		     ,subst_struct_expr sub do_delta meb')
-    | SEBstruct (str)->
-	SEBstruct( subst_structure sub do_delta str)
-    | SEBapply (meb1,meb2,cst)->
-	SEBapply(subst_struct_expr sub do_delta meb1,
-		 subst_struct_expr sub do_delta meb2,
-		 cst)
-    | SEBwith (meb,wdb)-> 
-	SEBwith(subst_struct_expr sub do_delta meb,
-		subst_with_body sub wdb)
-
-let subst_signature subst =
-  subst_structure subst 
-    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
-
-let subst_struct_expr subst = 
-  subst_struct_expr subst
-    (fun resolver subst-> subst_codom_delta_resolver subst resolver)
-
-(* spiwack: here comes the function which takes care of importing 
+  let ty' = subst_signature sub do_delta ty in
+  let me' =
+    implem_smartmap
+      (subst_signature sub id_delta) (subst_expression sub id_delta) me
+  in
+  let aty' = Option.smartmap (subst_expression sub id_delta) aty in
+  let delta' = do_delta mb.mod_delta sub in
+  if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta
+  then mb
+  else
+    { mb with
+      mod_mp = mp';
+      mod_expr = me';
+      mod_type = ty';
+      mod_type_alg = aty';
+      mod_delta = delta' }
+
+and subst_module sub do_delta mb = subst_body true sub do_delta mb
+
+and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb
+
+and subst_expr sub do_delta seb = match seb with
+  |MEident mp ->
+    let mp' = subst_mp sub mp in
+    if mp==mp' then seb else MEident mp'
+  |MEapply (meb1,mp2) ->
+    let meb1' = subst_expr sub do_delta meb1 in
+    let mp2' = subst_mp sub mp2 in
+    if meb1==meb1' && mp2==mp2' then seb else MEapply(meb1',mp2')
+  |MEwith (meb,wdb) ->
+    let meb' = subst_expr sub do_delta meb in
+    let wdb' = subst_with_body sub wdb in
+    if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb')
+
+and subst_expression sub do_delta =
+  functor_smartmap
+    (subst_modtype sub do_delta)
+    (subst_expr sub do_delta)
+
+and subst_signature sub do_delta =
+  functor_smartmap
+    (subst_modtype sub do_delta)
+    (subst_structure sub do_delta)
+
+let do_delta_dom reso sub = subst_dom_delta_resolver sub reso
+let do_delta_codom reso sub = subst_codom_delta_resolver sub reso
+let do_delta_dom_codom reso sub = subst_dom_codom_delta_resolver sub reso
+
+let subst_signature subst = subst_signature subst do_delta_codom
+let subst_structure subst = subst_structure subst do_delta_codom
+
+(** {6 Retroknowledge } *)
+
+(* spiwack: here comes the function which takes care of importing
    the retroknowledge declared in the library *)
 (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *)
 let add_retroknowledge mp =
-  let perform rkaction env =
-    match rkaction with
-      | Retroknowledge.RKRegister (f, e) ->
-	  Environ.register env f 
-	  (match e with 
-	    | Const kn -> kind_of_term (mkConst kn)
-	    | Ind ind -> kind_of_term (mkInd ind)
-	    | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term")
+  let perform rkaction env = match rkaction with
+    |Retroknowledge.RKRegister (f, e) when (isConst e || isInd e) ->
+      Environ.register env f e
+    |_ ->
+      Errors.anomaly ~label:"Modops.add_retroknowledge"
+        (Pp.str "had to import an unsupported kind of term")
   in
   fun lclrk env ->
   (* The order of the declaration matters, for instance (and it's at the
@@ -256,120 +276,117 @@ let add_retroknowledge mp =
      int31 type registration absolutely needs int31 bits to be registered.
      Since the local_retroknowledge is stored in reverse order (each new
      registration is added at the top of the list) we need a fold_right
-     for things to go right (the pun is not intented). So we lose 
+     for things to go right (the pun is not intented). So we lose
      tail recursivity, but the world will have exploded before any module
      imports 10 000 retroknowledge registration.*)
   List.fold_right perform lclrk env
 
-let rec add_signature mp sign resolver env = 
-  let add_one env (l,elem) =
-    let kn = make_kn mp empty_dirpath l in
-    match elem with
-      | SFBconst cb ->
-	Environ.add_constant (constant_of_delta_kn resolver kn) cb env
-      | SFBmind mib ->
-	Environ.add_mind (mind_of_delta_kn resolver kn) mib env
-      | SFBmodule mb -> add_module mb env (* adds components as well *)
-      | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+(** {6 Adding a module in the environment } *)
+
+let rec add_structure mp sign resolver linkinfo env =
+  let add_one env (l,elem) = match elem with
+    |SFBconst cb ->
+      let c = constant_of_delta_kn resolver (KerName.make2 mp l) in
+      Environ.add_constant_key c cb linkinfo env
+    |SFBmind mib ->
+      let mind = mind_of_delta_kn resolver (KerName.make2 mp l) in
+      let mib = 
+	if mib.mind_private != None then 
+	  { mib with mind_private = Some true }
+	else mib
+      in
+      Environ.add_mind_key mind (mib,ref linkinfo) env
+    |SFBmodule mb -> add_module mb linkinfo env (* adds components as well *)
+    |SFBmodtype mtb -> Environ.add_modtype 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 linkinfo 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_retroknowledge mp mb.mod_retroknowledge 
-	    (add_signature mp sign mb.mod_delta env)
-      | SEBfunctor _ -> env
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
+  let env = Environ.shallow_add_module mb env in
+  match mb.mod_type with
+  |NoFunctor struc ->
+    add_retroknowledge mp mb.mod_retroknowledge
+      (add_structure mp struc mb.mod_delta linkinfo env)
+  |MoreFunctor _ -> env
+
+let add_linked_module mb linkinfo env =
+  add_module mb linkinfo env
+
+let add_structure mp sign resolver env =
+  add_structure mp sign resolver no_link_info env
+
+let add_module mb env =
+  add_module mb no_link_info env
+
+let add_module_type mp mtb env =
+  add_module (module_body_of_type mp mtb) env
+
+(** {6 Strengtening } *)
 
 let strengthen_const mp_from l cb resolver =
   match cb.const_body with
-    | Def _ -> cb
-    | _ ->
-      let kn = make_kn mp_from empty_dirpath l in
-      let con = constant_of_delta_kn resolver kn in
+  |Def _ -> cb
+  |_ ->
+    let kn = KerName.make2 mp_from l in
+    let con = constant_of_delta_kn resolver kn in
+    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 (mkConst con));
-	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con)
-      }
+	const_body = Def (Mod_subst.from_val (mkConstU (con,u)));
+	const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias (con,u)) }
 
 let rec strengthen_mod mp_from mp_to mb =
-  if 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 = add_mp_delta_resolver mp_from mp_to
-	       (add_delta_resolver mb.mod_delta resolve_out);
-	       mod_retroknowledge = mb.mod_retroknowledge}
-     | SEBfunctor _ -> mb
-     | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-and strengthen_sig mp_from sign mp_to resolver =
-  match sign with
-    | [] -> empty_delta_resolver,[]
-    | (l,SFBconst cb) :: rest ->
-	let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item'::rest'
-    | (_,SFBmind _ as item):: rest ->
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item::rest'
-    | (l,SFBmodule mb) :: rest ->
-	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in
-	let mb_out = strengthen_mod mp_from' mp_to' mb in
-	let item' = l,SFBmodule (mb_out) in
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	add_delta_resolver resolve_out mb.mod_delta, item':: rest'
-    | (l,SFBmodtype mty as item) :: rest ->
-	let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
-	resolve_out,item::rest'
+  if mp_in_delta mb.mod_mp mb.mod_delta then mb
+  else match mb.mod_type with
+  |NoFunctor struc ->
+    let reso,struc' = strengthen_sig mp_from struc mp_to mb.mod_delta in
+    { mb with
+      mod_expr = Algebraic (NoFunctor (MEident mp_to));
+      mod_type = NoFunctor struc';
+      mod_delta =
+        add_mp_delta_resolver mp_from mp_to
+	  (add_delta_resolver mb.mod_delta reso) }
+  |MoreFunctor _ -> mb
+
+and strengthen_sig mp_from struc mp_to reso = match struc with
+  |[] -> empty_delta_resolver,[]
+  |(l,SFBconst cb) :: rest ->
+    let item' = l,SFBconst (strengthen_const mp_from l cb reso) in
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item'::rest'
+  |(_,SFBmind _ as item):: rest ->
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item::rest'
+  |(l,SFBmodule mb) :: rest ->
+    let mp_from' = MPdot (mp_from,l) in
+    let mp_to' = MPdot(mp_to,l) in
+    let mb' = strengthen_mod mp_from' mp_to' mb in
+    let item' = l,SFBmodule mb' in
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    add_delta_resolver reso' mb.mod_delta, item':: rest'
+  |(l,SFBmodtype mty as item) :: rest ->
+    let reso',rest' = strengthen_sig mp_from rest mp_to reso in
+    reso',item::rest'
 
 let strengthen mtb mp =
-  if mp_in_delta mtb.typ_mp mtb.typ_delta then
-    (* in this case mtb has already been strengthened*)
-    mtb
-  else
-    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 = add_delta_resolver mtb.typ_delta
-		(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
-      | SEBfunctor _ -> mtb
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
-
-let module_type_of_module mp mb =
-  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}
+  (* Has mtb already been strengthened ? *)
+  if mp_in_delta mtb.mod_mp mtb.mod_delta then mtb
+  else match mtb.mod_type with
+  |NoFunctor struc ->
+    let reso',struc' = strengthen_sig mtb.mod_mp struc mp mtb.mod_delta in
+    { mtb with
+      mod_type = NoFunctor struc';
+      mod_delta =
+        add_delta_resolver mtb.mod_delta
+	  (add_mp_delta_resolver mtb.mod_mp mp reso') }
+  |MoreFunctor _ -> mtb
 
 let inline_delta_resolver env inl mp mbid mtb delta =
-  let constants = inline_of_delta inl mtb.typ_delta in
+  let constants = inline_of_delta inl mtb.mod_delta in
   let rec make_inline delta = function
     | [] -> delta
     | (lev,kn)::r ->
@@ -381,7 +398,7 @@ let inline_delta_resolver env inl mp mbid mtb delta =
 	  match constant.const_body with
 	    | Undef _ | OpaqueDef _ -> l
 	    | Def body ->
-	      let constr = Declarations.force body in
+	      let constr = Mod_subst.force_constr body in
 	      add_inline_delta_resolver kn (lev, Some constr) l
 	with Not_found ->
 	  error_no_such_label_sub (con_label con)
@@ -389,198 +406,209 @@ let inline_delta_resolver env inl mp mbid mtb delta =
   in
   make_inline delta constants
 
-let rec strengthen_and_subst_mod
-    mb subst mp_from mp_to resolver =
-     match mb.mod_type with
-	 SEBstruct(str) ->
-	   let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	   if mb_is_an_alias then 
-	     subst_module subst 
-	       (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb 
-	   else
-	     let resolver,new_sig = 
-	       strengthen_and_subst_struct str subst
-		 mp_from mp_from mp_to false false mb.mod_delta 
-	     in
-	       {mb with 
-		  mod_mp = mp_to;
-		  mod_expr = Some (SEBident mp_from);
-		  mod_type = SEBstruct(new_sig);
-		  mod_delta = add_mp_delta_resolver mp_to mp_from resolver}
-       | SEBfunctor(arg_id,arg_b,body) ->
-	   let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in
-	   subst_module subst 
-	     (fun resolver subst-> subst_dom_codom_delta_resolver subst resolver) mb  
-	
-       | _ -> anomaly "Modops:the evaluation of the structure failed "
-	   
-and strengthen_and_subst_struct 
-    str subst mp_alias mp_from mp_to alias incl resolver =
+let rec strengthen_and_subst_mod mb subst mp_from mp_to =
+  match mb.mod_type with
+  |NoFunctor struc ->
+    let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+    if mb_is_an_alias then subst_module subst do_delta_dom mb
+    else
+      let reso',struc' =
+	strengthen_and_subst_struct struc subst
+	  mp_from mp_to false false mb.mod_delta
+      in
+      { mb with
+	mod_mp = mp_to;
+	mod_expr = Algebraic (NoFunctor (MEident mp_from));
+	mod_type = NoFunctor struc';
+	mod_delta = add_mp_delta_resolver mp_to mp_from reso' }
+  |MoreFunctor _ ->
+    let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in
+    subst_module subst do_delta_dom mb
+
+and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso =
   match str with
     | [] -> empty_delta_resolver,[]
     | (l,SFBconst cb) :: rest ->
-	let item' = if alias then 
-	  (* case alias no strengthening needed*)
-	  l,SFBconst (subst_const_body subst cb) 
-	else 
-	  l,SFBconst (strengthen_const mp_from l
-			(subst_const_body subst cb) resolver)
-	in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
+        let cb' = subst_const_body subst cb in
+        let cb'' =
+          if alias then cb'
+          else strengthen_const mp_from l cb' reso
+        in
+        let item' = l, SFBconst cb'' in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
 	if incl then
-	    (* If we are performing an inclusion we need to add
-	       the fact that the constant mp_to.l is \Delta-equivalent
-	       to resolver(mp_from.l) *)
-	  let kn_from = make_kn mp_from empty_dirpath l in
-	  let kn_to = make_kn mp_to empty_dirpath l in
-	  let old_name = kn_of_delta resolver kn_from in
-	  (add_kn_delta_resolver kn_to old_name resolve_out),
-	  item'::rest'
+          (* If we are performing an inclusion we need to add
+             the fact that the constant mp_to.l is \Delta-equivalent
+             to reso(mp_from.l) *)
+          let kn_from = KerName.make2 mp_from l in
+          let kn_to = KerName.make2 mp_to l in
+          let old_name = kn_of_delta reso kn_from in
+	  add_kn_delta_resolver kn_to old_name reso', item'::rest'
 	else
-	    (*In this case the fact that the constant mp_to.l is 
-	      \Delta-equivalent to resolver(mp_from.l) is already known
-	       because resolve_out contains mp_to maps to resolver(mp_from)*)
-	  resolve_out,item'::rest'
+	  (* In this case the fact that the constant mp_to.l is
+	     \Delta-equivalent to resolver(mp_from.l) is already known
+	     because reso' contains mp_to maps to reso(mp_from) *)
+	  reso', item'::rest'
     | (l,SFBmind mib) :: rest ->
-	(*Same as constant*)
-	let item' = l,SFBmind (subst_mind subst mib) in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
+	let item' = l,SFBmind (subst_mind_body subst mib) in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+	(* Same as constant *)
 	if incl then
-	  let kn_from = make_kn mp_from empty_dirpath l in
-	  let kn_to = make_kn mp_to empty_dirpath l in
-	  let old_name = kn_of_delta resolver kn_from in
-	  (add_kn_delta_resolver kn_to old_name resolve_out),
-	  item'::rest'
+	  let kn_from = KerName.make2 mp_from l in
+	  let kn_to = KerName.make2 mp_to l in
+	  let old_name = kn_of_delta reso kn_from in
+	  add_kn_delta_resolver kn_to old_name reso', item'::rest'
 	else
-	  resolve_out,item'::rest'
+	  reso', item'::rest'
     | (l,SFBmodule mb) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
-	let mp_to' = MPdot(mp_to,l) in
-	let mb_out = if alias then 
-	  subst_module subst 
-	  (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb 
+	let mp_to' = MPdot (mp_to,l) in
+	let mb' = if alias then
+	  subst_module subst do_delta_dom mb
 	else
-	  strengthen_and_subst_mod
-	    mb subst mp_from' mp_to' resolver
+	  strengthen_and_subst_mod mb subst mp_from' mp_to'
 	in
-	let item' = l,SFBmodule (mb_out) in
-	let resolve_out,rest' =
-	  strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
-	  (* if mb is a functor we should not derive new equivalences
-	     on names, hence we add the fact that the functor can only
-	     be equivalent to itself. If we adopt an applicative
-	     semantic for functor this should be changed.*)
-	  if is_functor mb_out.mod_type then 
-	    (add_mp_delta_resolver 
-	       mp_to' mp_to' resolve_out),item':: rest' 
-	  else
-	    add_delta_resolver resolve_out mb_out.mod_delta,
-	item':: rest'
-    | (l,SFBmodtype mty) :: rest -> 
+	let item' = l,SFBmodule mb' in
+	let reso',rest' =
+	  strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+        (* if mb is a functor we should not derive new equivalences
+           on names, hence we add the fact that the functor can only
+           be equivalent to itself. If we adopt an applicative
+           semantic for functor this should be changed.*)
+	if is_functor mb'.mod_type then
+	  add_mp_delta_resolver mp_to' mp_to' reso', item':: rest'
+	else
+	  add_delta_resolver reso' mb'.mod_delta, item':: rest'
+    | (l,SFBmodtype mty) :: rest ->
 	let mp_from' = MPdot (mp_from,l) in
 	let mp_to' = MPdot(mp_to,l) in
 	let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in
-	let mty = subst_modtype subst' 
-	  (fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in
-	let resolve_out,rest' = strengthen_and_subst_struct rest subst
-	    mp_alias mp_from mp_to alias incl resolver in
-	  (add_mp_delta_resolver 
-	     mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
-    
-
-(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M."
-   we need to perform two operations to compute the body of M. The first one is applying
-   the substitution {P <- M} on the type of P and the second one is strenghtening. *)
-let strengthen_and_subst_mb mb mp include_b =
-    match mb.mod_type with
-	SEBstruct str ->
-	  let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
-	    (*if mb.mod_mp is an alias then the strengthening is useless 
-	      (i.e. it is already done)*)
-	  let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
-	  let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
-	  let new_resolver = 
-	    add_mp_delta_resolver mp mp_alias
-	      (subst_dom_delta_resolver subst_resolver mb.mod_delta) in
-	  let subst = map_mp mb.mod_mp mp new_resolver in 
-	  let resolver_out,new_sig = 
-	    strengthen_and_subst_struct str subst
-	     mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta 
-	  in
-	    {mb with 
-	       mod_mp = mp;
-	       mod_type = SEBstruct(new_sig);
-	       mod_expr = Some (SEBident mb.mod_mp);
-	       mod_delta = if include_b then resolver_out 
-	       else add_delta_resolver new_resolver resolver_out}
-      | SEBfunctor(arg_id,argb,body) ->
-	  let subst = map_mp mb.mod_mp mp empty_delta_resolver in
-	  subst_module subst 
-	    (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mb 
-      | _ -> anomaly "Modops:the evaluation of the structure failed "
-
+	let mty = subst_modtype subst'
+	  (fun resolver _ -> subst_dom_codom_delta_resolver subst' resolver)
+          mty
+        in
+        let item' = l,SFBmodtype mty in
+	let reso',rest' =
+          strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso
+        in
+	add_mp_delta_resolver mp_to' mp_to' reso', item'::rest'
+
+
+(** Let P be a module path when we write:
+     "Module M:=P." or "Module M. Include P. End M."
+    We need to perform two operations to compute the body of M.
+    - The first one is applying the substitution {P <- M} on the type of P
+    - The second one is strenghtening. *)
+
+let strengthen_and_subst_mb mb mp include_b = match mb.mod_type with
+  |NoFunctor struc ->
+    let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
+    (* if mb.mod_mp is an alias then the strengthening is useless
+       (i.e. it is already done)*)
+    let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
+    let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
+    let new_resolver =
+      add_mp_delta_resolver mp mp_alias
+	(subst_dom_delta_resolver subst_resolver mb.mod_delta)
+    in
+    let subst = map_mp mb.mod_mp mp new_resolver in
+    let reso',struc' =
+      strengthen_and_subst_struct struc subst
+	mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
+    in
+    { mb with
+      mod_mp = mp;
+      mod_type = NoFunctor struc';
+      mod_expr = Algebraic (NoFunctor (MEident mb.mod_mp));
+      mod_delta =
+        if include_b then reso'
+	else add_delta_resolver new_resolver reso' }
+  |MoreFunctor _ ->
+    let subst = map_mp mb.mod_mp mp empty_delta_resolver in
+    subst_module subst do_delta_dom_codom mb
 
 let subst_modtype_and_resolver mtb mp =
-  let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
-  let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in 
-  let full_subst = (map_mp mtb.typ_mp mp new_delta) in
-    subst_modtype full_subst
-      (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mtb
+  let subst = map_mp mtb.mod_mp mp empty_delta_resolver in
+  let new_delta = subst_dom_codom_delta_resolver subst mtb.mod_delta in
+  let full_subst = map_mp mtb.mod_mp mp new_delta in
+  subst_modtype full_subst do_delta_dom_codom mtb
+
+(** {6 Cleaning a module expression from bounded parts }
+
+     For instance:
+       functor(X:T)->struct module M:=X end)
+     becomes:
+       functor(X:T)->struct module M:=<content of T> end)
+*)
 
 let rec is_bounded_expr l = function
-  | SEBident mp -> List.mem mp l
-  | SEBapply (fexpr,mexpr,_) ->  
-      is_bounded_expr l mexpr || is_bounded_expr l fexpr
+  | MEident (MPbound mbid) -> MBIset.mem mbid l
+  | MEapply (fexpr,mp) ->
+      is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr
   | _ -> false
 
-let rec clean_struct l = function
-  | (lab,SFBmodule mb) as field -> 
-      let clean_typ = clean_expr l mb.mod_type in 
-      let clean_impl = 
-	begin try
-	  if (is_bounded_expr l (Option.get mb.mod_expr)) then
-	    Some clean_typ
-	  else  Some (clean_expr l (Option.get mb.mod_expr))
-	with
-	    Option.IsNone -> None 
-	end in
-	  if clean_typ==mb.mod_type && clean_impl==mb.mod_expr then
-	    field 
-	  else 
-	    (lab,SFBmodule {mb with 
-			      mod_type=clean_typ;
-			      mod_expr=clean_impl})
-  | field -> field
-      
-and clean_expr l = function
- | SEBfunctor (mbid,sigt,str) as s->
-     let str_clean = clean_expr l str in
-     let sig_clean = clean_expr l sigt.typ_expr in 
-       if  str_clean == str && sig_clean = sigt.typ_expr then
-	 s else SEBfunctor (mbid,{sigt with typ_expr=sig_clean},str_clean)
-  | SEBstruct str as s->
-      let str_clean = Util.list_smartmap (clean_struct l) str in 
-	if  str_clean == str then s else SEBstruct(str_clean)
-  |  str -> str 
-
-let rec collect_mbid l = function
-  | SEBfunctor (mbid,sigt,str) as s->
-      let str_clean = collect_mbid ((MPbound mbid)::l) str in 
-	if  str_clean == str then s else 
-      SEBfunctor (mbid,sigt,str_clean)
-  | SEBstruct str as s->
-      let str_clean = Util.list_smartmap (clean_struct l) str in 
-	if  str_clean == str then s else SEBstruct(str_clean)
-  |  _ -> anomaly "Modops:the evaluation of the structure failed "
-       
-       
-let clean_bounded_mod_expr = function
-  | SEBfunctor _ as str -> 
-      let str_clean = collect_mbid [] str in 
-	if  str_clean == str then str else str_clean
-  | str -> str
+let rec clean_module l mb =
+  let impl, typ = mb.mod_expr, mb.mod_type in
+  let typ' = clean_signature l typ in
+  let impl' = match impl with
+    | Algebraic (NoFunctor m) when is_bounded_expr l m -> FullStruct
+    | _ -> implem_smartmap (clean_signature l) (clean_expression l) impl
+  in
+  if typ==typ' && impl==impl' then mb
+  else { mb with mod_type=typ'; mod_expr=impl' }
+
+and clean_field l field = match field with
+  |(lab,SFBmodule mb) ->
+    let mb' = clean_module l mb in
+    if mb==mb' then field else (lab,SFBmodule mb')
+  |_ -> field
+
+and clean_structure l = List.smartmap (clean_field l)
+
+and clean_signature l =
+  functor_smartmap (clean_module l) (clean_structure l)
+
+and clean_expression l =
+  functor_smartmap (clean_module l) (fun me -> me)
+
+let rec collect_mbid l sign =  match sign with
+  |MoreFunctor (mbid,ty,m) ->
+    let m' = collect_mbid (MBIset.add mbid l) m in
+    if m==m' then sign else MoreFunctor (mbid,ty,m')
+  |NoFunctor struc ->
+    let struc' = clean_structure l struc in
+    if struc==struc' then sign else NoFunctor struc'
+
+let clean_bounded_mod_expr sign =
+  if is_functor sign then collect_mbid MBIset.empty sign else sign
+
+(** {6 Stm machinery } *)
+let join_constant_body except otab cb =
+  match cb.const_body with
+  | OpaqueDef o ->
+      (match Opaqueproof.uuid_opaque otab o with
+      | Some uuid when not(Future.UUIDSet.mem uuid except) ->
+          Opaqueproof.join_opaque otab o
+      | _ -> ())
+  | _ -> ()
+
+let join_structure except otab s =
+  let rec join_module mb =
+    implem_iter join_signature join_expression mb.mod_expr;
+    Option.iter join_expression mb.mod_type_alg;
+    join_signature mb.mod_type
+  and join_field (l,body) = match body with
+    |SFBconst sb -> join_constant_body except otab sb
+    |SFBmind _ -> ()
+    |SFBmodule m |SFBmodtype m -> join_module m
+  and join_structure struc = List.iter join_field struc
+  and join_signature sign =
+    functor_iter join_module join_structure sign
+  and join_expression me = functor_iter join_module (fun _ -> ()) me in
+  join_structure s
+
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 1519df4d..6fbcd81d 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -1,47 +1,66 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Univ
 open Term
 open Environ
 open Declarations
 open Entries
 open Mod_subst
 
-(** Various operations on modules and module types *)
+(** {6 Various operations on modules and module types } *)
 
+(** Functors *)
 
-val module_body_of_type : module_path -> module_type_body  -> module_body 
+val is_functor : ('ty,'a) functorize -> bool
 
-val module_type_of_module : module_path option -> module_body ->
-  module_type_body
+val destr_functor : ('ty,'a) functorize -> MBId.t * 'ty * ('ty,'a) functorize
+
+val destr_nofunctor : ('ty,'a) functorize -> 'a
+
+(** Conversions between [module_body] and [module_type_body] *)
 
-val destr_functor :
-  env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body
+val module_type_of_module : module_body -> module_type_body
+val module_body_of_type : module_path -> module_type_body -> module_body
+
+val check_modpath_equiv : env -> module_path -> module_path -> unit
 
-val subst_struct_expr :  substitution -> struct_expr_body -> struct_expr_body
+val implem_smartmap :
+  (module_signature -> module_signature) ->
+  (module_expression -> module_expression) ->
+  (module_implementation -> module_implementation)
 
-val subst_signature : substitution -> structure_body -> structure_body
+(** {6 Substitutions } *)
 
-val add_signature :
+val subst_signature : substitution -> module_signature -> module_signature
+val subst_structure : substitution -> structure_body -> structure_body
+
+(** {6 Adding to an environment } *)
+
+val add_structure :
   module_path -> structure_body -> delta_resolver -> env -> env
 
 (** adds a module and its components, but not the constraints *)
 val add_module : module_body -> env -> env
 
-val check_modpath_equiv : env -> module_path -> module_path -> unit
+(** same as add_module, but for a module whose native code has been linked by
+the native compiler. The linking information is updated. *)
+val add_linked_module : module_body -> Pre_env.link_info -> env -> env
+
+(** same, for a module type *)
+val add_module_type : module_path -> module_type_body -> env -> env
+
+(** {6 Strengthening } *)
 
 val strengthen : module_type_body -> module_path -> module_type_body
 
 val inline_delta_resolver :
-  env -> inline -> module_path -> mod_bound_id -> module_type_body ->
+  env -> inline -> module_path -> MBId.t -> module_type_body ->
   delta_resolver -> delta_resolver
 
 val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
@@ -49,52 +68,69 @@ val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
 val subst_modtype_and_resolver : module_type_body -> module_path ->
   module_type_body
 
-val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
+(** {6 Cleaning a module expression from bounded parts }
+
+     For instance:
+       functor(X:T)->struct module M:=X end)
+     becomes:
+       functor(X:T)->struct module M:=<content of T> end)
+*)
+
+val clean_bounded_mod_expr : module_signature -> module_signature
+
+(** {6 Stm machinery } *)
 
-(** Errors *)
+val join_structure :
+  Future.UUIDSet.t -> Opaqueproof.opaquetab -> structure_body -> unit
+
+(** {6 Errors } *)
 
 type signature_mismatch_error =
   | InductiveFieldExpected of mutual_inductive_body
   | DefinitionFieldExpected
   | ModuleFieldExpected
   | ModuleTypeFieldExpected
-  | NotConvertibleInductiveField of identifier
-  | NotConvertibleConstructorField of identifier
+  | NotConvertibleInductiveField of Id.t
+  | NotConvertibleConstructorField of Id.t
   | NotConvertibleBodyField
   | NotConvertibleTypeField of env * types * types
+  | PolymorphicStatusExpected of bool
   | NotSameConstructorNamesField
   | NotSameInductiveNameInBlockField
   | FiniteInductiveFieldExpected of bool
   | InductiveNumbersFieldExpected of int
   | InductiveParamsNumberField of int
   | RecordFieldExpected of bool
-  | RecordProjectionsExpected of name list
+  | RecordProjectionsExpected of Name.t list
   | NotEqualInductiveAliases
   | NoTypeConstraintExpected
+  | IncompatibleInstances
+  | IncompatibleUniverses of Univ.univ_inconsistency
+  | IncompatiblePolymorphism of env * types * types
+  | IncompatibleConstraints of Univ.constraints
 
 type module_typing_error =
-  | SignatureMismatch of label * structure_field_body * signature_mismatch_error
-  | LabelAlreadyDeclared of label
+  | SignatureMismatch of
+      Label.t * structure_field_body * signature_mismatch_error
+  | LabelAlreadyDeclared of Label.t
   | ApplicationToNotPath of module_struct_entry
-  | NotAFunctor of struct_expr_body
+  | NotAFunctor
+  | IsAFunctor
   | IncompatibleModuleTypes of module_type_body * module_type_body
   | NotEqualModulePaths of module_path * module_path
-  | NoSuchLabel of label
-  | IncompatibleLabels of label * label
-  | SignatureExpected of struct_expr_body
-  | NoModuleToEnd
-  | NoModuleTypeToEnd
+  | NoSuchLabel of Label.t
+  | IncompatibleLabels of Label.t * Label.t
   | NotAModule of string
   | NotAModuleType of string
-  | NotAConstant of label
-  | IncorrectWithConstraint of label
-  | GenerativeModuleExpected of label
-  | NonEmptyLocalContect of label option
-  | LabelMissing of label * string
+  | NotAConstant of Label.t
+  | IncorrectWithConstraint of Label.t
+  | GenerativeModuleExpected of Label.t
+  | LabelMissing of Label.t * string
+  | HigherOrderInclude
 
 exception ModuleTypingError of module_typing_error
 
-val error_existing_label : label -> 'a
+val error_existing_label : Label.t -> 'a
 
 val error_application_to_not_path : module_struct_entry -> 'a
 
@@ -102,26 +138,20 @@ val error_incompatible_modtypes :
   module_type_body -> module_type_body -> 'a
 
 val error_signature_mismatch :
-  label -> structure_field_body -> signature_mismatch_error -> 'a
-
-val error_incompatible_labels : label -> label -> 'a
-
-val error_no_such_label : label -> 'a
-
-val error_signature_expected : struct_expr_body -> 'a
+  Label.t -> structure_field_body -> signature_mismatch_error -> 'a
 
-val error_no_module_to_end : unit -> 'a
+val error_incompatible_labels : Label.t -> Label.t -> 'a
 
-val error_no_modtype_to_end : unit -> 'a
+val error_no_such_label : Label.t -> 'a
 
 val error_not_a_module : string -> 'a
 
-val error_not_a_constant : label -> 'a
+val error_not_a_constant : Label.t -> 'a
 
-val error_incorrect_with_constraint : label -> 'a
+val error_incorrect_with_constraint : Label.t -> 'a
 
-val error_generative_module_expected : label -> 'a
+val error_generative_module_expected : Label.t -> 'a
 
-val error_non_empty_local_context : label option -> 'a
+val error_no_such_label_sub : Label.t->string->'a
 
-val error_no_such_label_sub : label->string->'a
+val error_higher_order_include : unit -> 'a
diff --git a/kernel/names.ml b/kernel/names.ml
index c20f75a9..b349ccb0 100644
--- a/kernel/names.ml
+++ b/kernel/names.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        *)
@@ -23,35 +23,106 @@ open Util
 
 (** {6 Identifiers } *)
 
-type identifier = string
+module Id =
+struct
+  type t = string
+
+  let equal = String.equal
+
+  let compare = String.compare
+
+  let hash = String.hash
+
+  let check_soft x =
+    let iter (fatal, x) =
+      if fatal then Errors.error x else Pp.msg_warning (str x)
+    in
+    Option.iter iter (Unicode.ident_refutation x)
 
-let id_of_string s = check_ident_soft s; String.copy s
-let string_of_id id = String.copy id
+  let is_valid s = match Unicode.ident_refutation s with
+  | None -> true
+  | Some _ -> false
 
-let id_ord = Pervasives.compare
+  let of_string s =
+    let () = check_soft s in
+    let s = String.copy s in
+    String.hcons s
 
-module IdOrdered =
+  let to_string id = String.copy id
+
+  let print id = str id
+
+  module Self =
   struct
-    type t = identifier
-    let compare = id_ord
+    type t = string
+    let compare = compare
   end
 
-module Idset = Set.Make(IdOrdered)
-module Idmap =
+  module Set = Set.Make(Self)
+  module Map = CMap.Make(Self)
+
+  module Pred = Predicate.Make(Self)
+
+  module List = String.List
+
+  let hcons = String.hcons
+
+end
+
+
+module Name =
 struct
-  include Map.Make(IdOrdered)
-  exception Finded
-  let exists f m =
-    try iter (fun a b -> if f a b then raise Finded) m ; false
-    with |Finded -> true
-  let singleton k v = add k v empty
+  type t = Name of Id.t | Anonymous
+
+  let compare n1 n2 = match n1, n2 with
+    | Anonymous, Anonymous -> 0
+    | Name id1, Name id2 -> Id.compare id1 id2
+    | Anonymous, Name _ -> -1
+    | Name _, Anonymous -> 1
+
+  let equal n1 n2 = match n1, n2 with
+    | Anonymous, Anonymous -> true
+    | Name id1, Name id2 -> String.equal id1 id2
+    | _ -> false
+
+  let hash = function
+  | Anonymous -> 0
+  | Name id -> Id.hash id
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = Id.t -> Id.t
+      let hashcons hident = function
+        | Name id -> Name (hident id)
+        | n -> n
+      let equal n1 n2 =
+        n1 == n2 ||
+        match (n1,n2) with
+          | (Name id1, Name id2) -> id1 == id2
+          | (Anonymous,Anonymous) -> true
+          | _ -> false
+      let hash = hash
+    end
+
+  module Hname = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons Hname.generate Hname.hcons Id.hcons
+
 end
-module Idpred = Predicate.Make(IdOrdered)
+
+type name = Name.t = Name of Id.t | Anonymous
+(** Alias, to import constructors. *)
 
 (** {6 Various types based on identifiers } *)
 
-type name = Name of identifier | Anonymous
-type variable = identifier
+type variable = Id.t
+
+type module_ident = Id.t
+
+module ModIdset = Id.Set
+module ModIdmap = Id.Map
 
 (** {6 Directory paths = section names paths } *)
 
@@ -59,250 +130,491 @@ type variable = identifier
     The actual representation is reversed to optimise sharing:
     Coq.A.B is ["B";"A";"Coq"] *)
 
-type module_ident = identifier
-type dir_path = module_ident list
+let default_module_name = "If you see this, it's a bug"
+
+module DirPath =
+struct
+  type t = module_ident list
+
+  let rec compare (p1 : t) (p2 : t) =
+    if p1 == p2 then 0
+    else begin match p1, p2 with
+    | [], [] -> 0
+    | [], _ -> -1
+    | _, [] -> 1
+    | id1 :: p1, id2 :: p2 ->
+      let c = Id.compare id1 id2 in
+      if Int.equal c 0 then compare p1 p2 else c
+    end
+
+  let rec equal p1 p2 = p1 == p2 || match p1, p2 with
+  | [], [] -> true
+  | id1 :: p1, id2 :: p2 -> Id.equal id1 id2 && equal p1 p2
+  | _ -> false
+
+  let rec hash accu = function
+  | [] -> accu
+  | id :: dp ->
+    let accu = Hashset.Combine.combine (Id.hash id) accu in
+    hash accu dp
+
+  let hash dp = hash 0 dp
+
+  let make x = x
+  let repr x = x
+
+  let empty = []
 
-module ModIdmap = Idmap
+  let is_empty d = match d with [] -> true | _ -> false
 
-let make_dirpath x = x
-let repr_dirpath x = x
+  let to_string = function
+    | [] -> "<>"
+    | sl -> String.concat "." (List.rev_map Id.to_string sl)
 
-let empty_dirpath = []
+  let initial = [default_module_name]
 
-(** Printing of directory paths as ["coq_root.module.submodule"] *)
+  module Hdir = Hashcons.Hlist(Id)
 
-let string_of_dirpath = function
-  | [] -> "<>"
-  | sl -> String.concat "." (List.map string_of_id (List.rev sl))
+  let hcons = Hashcons.recursive_hcons Hdir.generate Hdir.hcons Id.hcons
+
+end
 
 (** {6 Unique names for bound modules } *)
 
-let u_number = ref 0
-type uniq_ident = int * identifier * dir_path
-let make_uid dir s = incr u_number;(!u_number,s,dir)
- let debug_string_of_uid (i,s,p) =
- "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
-let string_of_uid (i,s,p) =
-  string_of_dirpath p ^"."^s
-
-module Umap = Map.Make(struct
-			 type t = uniq_ident
-			 let compare = Pervasives.compare
-		       end)
-
-type mod_bound_id = uniq_ident
-let make_mbid = make_uid
-let repr_mbid (n, id, dp) = (n, id, dp)
-let debug_string_of_mbid = debug_string_of_uid
-let string_of_mbid = string_of_uid
-let id_of_mbid (_,s,_) = s
+module MBId =
+struct
+  type t = int * Id.t * DirPath.t
 
-(** {6 Names of structure elements } *)
+  let gen =
+    let seed = ref 0 in fun () ->
+      let ans = !seed in
+      let () = incr seed in
+      ans
 
-type label = identifier
+  let make dir s = (gen(), s, dir)
 
-let mk_label = id_of_string
-let string_of_label = string_of_id
-let pr_label l = str (string_of_label l)
-let id_of_label l = l
-let label_of_id id = id
+  let repr mbid = mbid
 
-module Labset = Idset
-module Labmap = Idmap
+  let to_string (i, s, p) =
+    DirPath.to_string p ^ "." ^ s
 
-(** {6 The module part of the kernel name } *)
+  let debug_to_string (i, s, p) =
+    "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
+
+  let compare (x : t) (y : t) =
+    if x == y then 0
+    else match (x, y) with
+    | (nl, idl, dpl), (nr, idr, dpr) ->
+      let ans = Int.compare nl nr in
+      if not (Int.equal ans 0) then ans
+      else
+        let ans = Id.compare idl idr in
+        if not (Int.equal ans 0) then ans
+        else
+          DirPath.compare dpl dpr
 
-type module_path =
-  | MPfile of dir_path
-  | MPbound of mod_bound_id
-  | MPdot of module_path * label
+  let equal x y = x == y ||
+    let (i1, id1, p1) = x in
+    let (i2, id2, p2) = y in
+    Int.equal i1 i2 && Id.equal id1 id2 && DirPath.equal p1 p2
 
-let rec check_bound_mp = function
-  | MPbound _ -> true
-  | MPdot(mp,_) ->check_bound_mp mp
-  | _ -> false
+  let to_id (_, s, _) = s
+
+  open Hashset.Combine
+
+  let hash (i, id, dp) =
+    combine3 (Int.hash i) (Id.hash id) (DirPath.hash dp)
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t)
+      let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
+      let equal ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) =
+        (x == y) ||
+        (Int.equal n1 n2 && s1 == s2 && dir1 == dir2)
+      let hash = hash
+    end
+
+  module HashMBId = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons HashMBId.generate HashMBId.hcons (Id.hcons, DirPath.hcons)
 
-let rec string_of_mp = function
-  | MPfile sl -> string_of_dirpath sl
-  | MPbound uid -> string_of_uid uid
-  | MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
-
-(** we compare labels first if both are MPdots *)
-let rec mp_ord mp1 mp2 = match (mp1,mp2) with
-    MPdot(mp1,l1), MPdot(mp2,l2) ->
-      let c = Pervasives.compare l1 l2 in
-	if c<>0 then
-	  c
-	else
-	  mp_ord mp1 mp2
-  |  _,_ -> Pervasives.compare mp1 mp2
-
-module MPord = struct
-  type t = module_path
-  let compare = mp_ord
 end
 
-module MPset = Set.Make(MPord)
-module MPmap = Map.Make(MPord)
+module MBImap = CMap.Make(MBId)
+module MBIset = Set.Make(MBId)
 
-let default_module_name = "If you see this, it's a bug"
+(** {6 Names of structure elements } *)
+
+module Label =
+struct
+  include Id
+  let make = Id.of_string
+  let of_id id = id
+  let to_id id = id
+end
+
+(** {6 The module part of the kernel name } *)
+
+module ModPath = struct
+
+  type t =
+    | MPfile of DirPath.t
+    | MPbound of MBId.t
+    | MPdot of t * Label.t
+
+  type module_path = t
+
+  let rec is_bound = function
+    | MPbound _ -> true
+    | MPdot(mp,_) -> is_bound mp
+    | _ -> false
+
+  let rec to_string = function
+    | MPfile sl -> DirPath.to_string sl
+    | MPbound uid -> MBId.to_string uid
+    | MPdot (mp,l) -> to_string mp ^ "." ^ Label.to_string l
+
+  (** we compare labels first if both are MPdots *)
+  let rec compare mp1 mp2 =
+    if mp1 == mp2 then 0
+    else match mp1, mp2 with
+      | MPfile p1, MPfile p2 -> DirPath.compare p1 p2
+      | MPbound id1, MPbound id2 -> MBId.compare id1 id2
+      | MPdot (mp1, l1), MPdot (mp2, l2) ->
+        let c = String.compare l1 l2 in
+        if not (Int.equal c 0) then c
+        else compare mp1 mp2
+      | MPfile _, _ -> -1
+      | MPbound _, MPfile _ -> 1
+      | MPbound _, MPdot _ -> -1
+      | MPdot _, _ -> 1
+
+  let rec equal mp1 mp2 = mp1 == mp2 ||
+    match mp1, mp2 with
+    | MPfile p1, MPfile p2 -> DirPath.equal p1 p2
+    | MPbound id1, MPbound id2 -> MBId.equal id1 id2
+    | MPdot (mp1, l1), MPdot (mp2, l2) -> String.equal l1 l2 && equal mp1 mp2
+    | (MPfile _ | MPbound _ | MPdot _), _ -> false
+
+  open Hashset.Combine
+
+  let rec hash = function
+  | MPfile dp -> combinesmall 1 (DirPath.hash dp)
+  | MPbound id -> combinesmall 2 (MBId.hash id)
+  | MPdot (mp, lbl) ->
+    combinesmall 3 (combine (hash mp) (Label.hash lbl))
+
+  let initial = MPfile DirPath.initial
+
+  let rec dp = function
+  | MPfile sl -> sl
+  | MPbound (_,_,dp) -> dp
+  | MPdot (mp,l) -> dp mp
+
+  module Self_Hashcons = struct
+    type t = module_path
+    type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) *
+	(string -> string)
+    let rec hashcons (hdir,huniqid,hstr as hfuns) = function
+      | MPfile dir -> MPfile (hdir dir)
+      | MPbound m -> MPbound (huniqid m)
+      | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l)
+    let rec equal d1 d2 =
+      d1 == d2 ||
+      match d1,d2 with
+      | MPfile dir1, MPfile dir2 -> dir1 == dir2
+      | MPbound m1, MPbound m2 -> m1 == m2
+      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
+      | _ -> false
+    let hash = hash
+  end
+
+  module HashMP = Hashcons.Make(Self_Hashcons)
+
+  let hcons =
+    Hashcons.simple_hcons HashMP.generate HashMP.hcons
+      (DirPath.hcons,MBId.hcons,String.hcons)
+
+end
 
-let initial_dir = make_dirpath [default_module_name]
-let initial_path = MPfile initial_dir
+module MPset = Set.Make(ModPath)
+module MPmap = CMap.Make(ModPath)
 
 (** {6 Kernel names } *)
 
-type kernel_name = module_path * dir_path * label
+module KerName = struct
 
-let make_kn mp dir l = (mp,dir,l)
-let repr_kn kn = kn
+  type t = {
+    canary : Canary.t;
+    modpath : ModPath.t;
+    dirpath : DirPath.t;
+    knlabel : Label.t;
+    mutable refhash : int;
+    (** Lazily computed hash. If unset, it is set to negative values. *)
+  }
 
-let modpath kn =
-  let mp,_,_ = repr_kn kn in mp
+  let canary = Canary.obj
 
-let label kn =
-  let _,_,l = repr_kn kn in l
+  type kernel_name = t
 
-let string_of_kn (mp,dir,l) =
-  let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#"
-  in
-  string_of_mp mp ^ str_dir ^ string_of_label l
+  let make modpath dirpath knlabel =
+    { modpath; dirpath; knlabel; refhash = -1; canary; }
+  let repr kn = (kn.modpath, kn.dirpath, kn.knlabel)
 
-let pr_kn kn = str (string_of_kn kn)
+  let make2 modpath knlabel =
+    { modpath; dirpath = DirPath.empty; knlabel; refhash = -1; canary; }
 
-let kn_ord kn1 kn2 =
-    let mp1,dir1,l1 = kn1 in
-    let mp2,dir2,l2 = kn2 in
-    let c = Pervasives.compare l1 l2 in
-      if c <> 0 then
-	c
+  let modpath kn = kn.modpath
+  let label kn = kn.knlabel
+
+  let to_string kn =
+    let dp =
+      if DirPath.is_empty kn.dirpath then "."
+      else "#" ^ DirPath.to_string kn.dirpath ^ "#"
+    in
+    ModPath.to_string kn.modpath ^ dp ^ Label.to_string kn.knlabel
+
+  let print kn = str (to_string kn)
+
+  let compare (kn1 : kernel_name) (kn2 : kernel_name) =
+    if kn1 == kn2 then 0
+    else
+      let c = String.compare kn1.knlabel kn2.knlabel in
+      if not (Int.equal c 0) then c
       else
-	let c = Pervasives.compare dir1 dir2 in
-	  if c<>0 then
-	    c
-	  else
-	    MPord.compare mp1 mp2
-
-module KNord = struct
-  type t = kernel_name
-  let compare = kn_ord
-end
+        let c = DirPath.compare kn1.dirpath kn2.dirpath in
+        if not (Int.equal c 0) then c
+        else ModPath.compare kn1.modpath kn2.modpath
+
+  let equal kn1 kn2 =
+    let h1 = kn1.refhash in
+    let h2 = kn2.refhash in
+    if 0 <= h1 && 0 <= h2 && not (Int.equal h1 h2) then false
+    else
+      Label.equal kn1.knlabel kn2.knlabel &&
+      DirPath.equal kn1.dirpath kn2.dirpath &&
+      ModPath.equal kn1.modpath kn2.modpath
+
+  open Hashset.Combine
+
+  let hash kn =
+    let h = kn.refhash in
+    if h < 0 then
+      let { modpath = mp; dirpath = dp; knlabel = lbl; } = kn in
+      let h = combine3 (ModPath.hash mp) (DirPath.hash dp) (Label.hash lbl) in
+      (* Ensure positivity on all platforms. *)
+      let h = h land 0x3FFFFFFF in
+      let () = kn.refhash <- h in
+      h
+    else h
+
+  module Self_Hashcons = struct
+    type t = kernel_name
+    type u = (ModPath.t -> ModPath.t) * (DirPath.t -> DirPath.t)
+        * (string -> string)
+    let hashcons (hmod,hdir,hstr) kn =
+      let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in
+      { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; }
+    let equal kn1 kn2 =
+      kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath &&
+        kn1.knlabel == kn2.knlabel
+    let hash = hash
+  end
 
-module KNmap = Map.Make(KNord)
-module KNpred = Predicate.Make(KNord)
-module KNset = Set.Make(KNord)
-
-(** {6 Constant names } *)
-
-(** a constant name is a kernel name couple (kn1,kn2)
-   where kn1 corresponds to the name used at toplevel
-   (i.e. what the user see)
-   and kn2 corresponds to the canonical kernel name
-   i.e. in the environment we have
-   kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *)
-type constant = kernel_name*kernel_name
-
-let constant_of_kn kn = (kn,kn)
-let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_con mp dir l = constant_of_kn (mp,dir,l)
-let make_con_equiv mp1 mp2 dir l =
-  if mp1 == mp2 then make_con mp1 dir l
-  else ((mp1,dir,l),(mp2,dir,l))
-let canonical_con con = snd con
-let user_con con = fst con
-let repr_con con = fst con
-
-let eq_constant (_,kn1) (_,kn2) = kn1=kn2
-
-let con_label con = label (fst con)
-let con_modpath con = modpath (fst con)
-
-let string_of_con con = string_of_kn (fst con)
-let pr_con con = str (string_of_con con)
-let debug_string_of_con con =
-  "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
-let debug_pr_con con = str (debug_string_of_con con)
-
-let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
-  if lbl = l1 && lbl = l2 then con
-  else ((mp1,dp1,lbl),(mp2,dp2,lbl))
-
-(** For the environment we distinguish constants by their user part*)
-module User_ord = struct
-  type t = kernel_name*kernel_name
-  let compare x y= kn_ord (fst x) (fst y)
+  module HashKN = Hashcons.Make(Self_Hashcons)
+
+  let hcons =
+    Hashcons.simple_hcons HashKN.generate HashKN.hcons
+      (ModPath.hcons,DirPath.hcons,String.hcons)
 end
 
-(** For other uses (ex: non-logical things) it is enough
-    to deal with the canonical part *)
-module Canonical_ord = struct
-  type t = kernel_name*kernel_name
-  let compare x y= kn_ord (snd x) (snd y)
+module KNmap = HMap.Make(KerName)
+module KNpred = Predicate.Make(KerName)
+module KNset = KNmap.Set
+
+(** {6 Kernel pairs } *)
+
+(** For constant and inductive names, we use a kernel name couple (kn1,kn2)
+   where kn1 corresponds to the name used at toplevel (i.e. what the user see)
+   and kn2 corresponds to the canonical kernel name i.e. in the environment
+   we have {% kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t %}
+
+   Invariants :
+    - the user and canonical kn may differ only on their [module_path],
+      the dirpaths and labels should be the same
+    - when user and canonical parts differ, we cannot be in a section
+      anymore, hence the dirpath must be empty
+    - two pairs with the same user part should have the same canonical part
+
+   Note: since most of the time the canonical and user parts are equal,
+   we handle this case with a particular constructor to spare some memory *)
+
+module KerPair = struct
+
+  type t =
+    | Same of KerName.t (** user = canonical *)
+    | Dual of KerName.t * KerName.t (** user then canonical *)
+
+  type kernel_pair = t
+
+  let canonical = function
+    | Same kn -> kn
+    | Dual (_,kn) -> kn
+
+  let user = function
+    | Same kn -> kn
+    | Dual (kn,_) -> kn
+
+  let same kn = Same kn
+  let make knu knc = if knu == knc then Same knc else Dual (knu,knc)
+
+  let make1 = same
+  let make2 mp l = same (KerName.make2 mp l)
+  let make3 mp dir l = same (KerName.make mp dir l)
+  let repr3 kp = KerName.repr (user kp)
+  let label kp = KerName.label (user kp)
+  let modpath kp = KerName.modpath (user kp)
+
+  let change_label kp lbl =
+    let (mp1,dp1,l1) = KerName.repr (user kp)
+    and (mp2,dp2,l2) = KerName.repr (canonical kp) in
+    assert (String.equal l1 l2 && DirPath.equal dp1 dp2);
+    if String.equal lbl l1 then kp
+    else
+      let kn = KerName.make mp1 dp1 lbl in
+      if mp1 == mp2 then same kn
+      else make kn (KerName.make mp2 dp2 lbl)
+
+  let to_string kp = KerName.to_string (user kp)
+  let print kp = str (to_string kp)
+
+  let debug_to_string = function
+    | Same kn -> "(" ^ KerName.to_string kn ^ ")"
+    | Dual (knu,knc) ->
+      "(" ^ KerName.to_string knu ^ "," ^ KerName.to_string knc ^ ")"
+
+  let debug_print kp = str (debug_to_string kp)
+
+  (** For ordering kernel pairs, both user or canonical parts may make
+      sense, according to your needs : user for the environments, canonical
+      for other uses (ex: non-logical things). *)
+
+  module UserOrd = struct
+    type t = kernel_pair
+    let compare x y = KerName.compare (user x) (user y)
+    let equal x y = x == y || KerName.equal (user x) (user y)
+    let hash x = KerName.hash (user x)
+  end
+
+  module CanOrd = struct
+    type t = kernel_pair
+    let compare x y = KerName.compare (canonical x) (canonical y)
+    let equal x y = x == y || KerName.equal (canonical x) (canonical y)
+    let hash x = KerName.hash (canonical x)
+  end
+
+  (** Default comparison is on the canonical part *)
+  let equal = CanOrd.equal
+
+  (** Hash-consing : we discriminate only on the user part, since having
+      the same user part implies having the same canonical part
+      (invariant of the system). *)
+
+  let hash = function
+  | Same kn -> KerName.hash kn
+  | Dual (kn, _) -> KerName.hash kn
+
+  module Self_Hashcons =
+    struct
+      type t = kernel_pair
+      type u = KerName.t -> KerName.t
+      let hashcons hkn = function
+        | Same kn -> Same (hkn kn)
+        | Dual (knu,knc) -> make (hkn knu) (hkn knc)
+      let equal x y = (user x) == (user y)
+      let hash = hash
+    end
+
+  module HashKP = Hashcons.Make(Self_Hashcons)
+
 end
 
-module Cmap = Map.Make(Canonical_ord)
-module Cmap_env = Map.Make(User_ord)
-module Cpred = Predicate.Make(Canonical_ord)
-module Cset = Set.Make(Canonical_ord)
-module Cset_env = Set.Make(User_ord)
+(** {6 Constant Names} *)
+
+module Constant = KerPair
 
+module Cmap = HMap.Make(Constant.CanOrd)
+module Cmap_env = HMap.Make(Constant.UserOrd)
+module Cpred = Predicate.Make(Constant.CanOrd)
+module Cset = Cmap.Set
+module Cset_env = Cmap_env.Set
 
 (** {6 Names of mutual inductive types } *)
 
-(** The same thing is done for mutual inductive names
-    it replaces also the old mind_equiv field of mutual
-    inductive types *)
+module MutInd = KerPair
+
+module Mindmap = HMap.Make(MutInd.CanOrd)
+module Mindset = Mindmap.Set
+module Mindmap_env = HMap.Make(MutInd.UserOrd)
+
 (** Beware: first inductive has index 0 *)
 (** Beware: first constructor has index 1 *)
 
-type mutual_inductive = kernel_name*kernel_name
-type inductive = mutual_inductive * int
+type inductive = MutInd.t * int
 type constructor = inductive * int
 
-let mind_modpath mind = modpath (fst mind)
-let ind_modpath ind = mind_modpath (fst ind)
-let constr_modpath c = ind_modpath (fst c)
-
-let mind_of_kn kn = (kn,kn)
-let mind_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_mind mp dir l = mind_of_kn (mp,dir,l)
-let make_mind_equiv mp1 mp2 dir l =
-  if mp1 == mp2 then make_mind mp1 dir l
-  else ((mp1,dir,l),(mp2,dir,l))
-let canonical_mind mind = snd mind
-let user_mind mind = fst mind
-let repr_mind mind = fst mind
-let mind_label mind= label (fst mind)
-
-let eq_mind (_,kn1) (_,kn2) = kn1=kn2
-
-let string_of_mind mind = string_of_kn (fst mind)
-let pr_mind mind = str (string_of_mind mind)
-let debug_string_of_mind mind =
-  "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")"
-let debug_pr_mind con = str (debug_string_of_mind con)
-
-let ith_mutual_inductive (kn,_) i = (kn,i)
-let ith_constructor_of_inductive ind i = (ind,i)
-let inductive_of_constructor (ind,i) = ind
-let index_of_constructor (ind,i) = i
-let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
-let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
-
-module Mindmap = Map.Make(Canonical_ord)
-module Mindset = Set.Make(Canonical_ord)
-module Mindmap_env = Map.Make(User_ord)
+let ind_modpath (mind,_) = MutInd.modpath mind
+let constr_modpath (ind,_) = ind_modpath ind
+
+let ith_mutual_inductive (mind, _) i = (mind, i)
+let ith_constructor_of_inductive ind i = (ind, i)
+let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u)
+let inductive_of_constructor (ind, i) = ind
+let index_of_constructor (ind, i) = i
+
+let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2
+let eq_user_ind (m1, i1) (m2, i2) =
+  Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2
+
+let ind_ord (m1, i1) (m2, i2) =
+  let c = Int.compare i1 i2 in
+  if Int.equal c 0 then MutInd.CanOrd.compare m1 m2 else c
+let ind_user_ord (m1, i1) (m2, i2) =
+  let c = Int.compare i1 i2 in
+  if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c
+
+let ind_hash (m, i) =
+  Hashset.Combine.combine (MutInd.hash m) (Int.hash i)
+let ind_user_hash (m, i) =
+  Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i)
+
+let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2
+let eq_user_constructor (ind1, j1) (ind2, j2) =
+  Int.equal j1 j2 && eq_user_ind ind1 ind2
+
+let constructor_ord (ind1, j1) (ind2, j2) =
+  let c = Int.compare j1 j2 in
+  if Int.equal c 0 then ind_ord ind1 ind2 else c
+let constructor_user_ord (ind1, j1) (ind2, j2) =
+  let c = Int.compare j1 j2 in
+  if Int.equal c 0 then ind_user_ord ind1 ind2 else c
+
+let constructor_hash (ind, i) =
+  Hashset.Combine.combine (ind_hash ind) (Int.hash i)
+let constructor_user_hash (ind, i) =
+  Hashset.Combine.combine (ind_user_hash ind) (Int.hash i)
 
 module InductiveOrdered = struct
   type t = inductive
-  let compare (spx,ix) (spy,iy) =
-    let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c
+  let compare = ind_ord
 end
 
 module InductiveOrdered_env = struct
   type t = inductive
-  let compare (spx,ix) (spy,iy) =
-    let c = ix - iy in if c = 0 then User_ord.compare spx spy else c
+  let compare = ind_user_ord
 end
 
 module Indmap = Map.Make(InductiveOrdered)
@@ -310,14 +622,12 @@ module Indmap_env = Map.Make(InductiveOrdered_env)
 
 module ConstructorOrdered = struct
   type t = constructor
-  let compare (indx,ix) (indy,iy) =
-    let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c
+  let compare = constructor_ord
 end
 
 module ConstructorOrdered_env = struct
   type t = constructor
-  let compare (indx,ix) (indy,iy) =
-    let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c
+  let compare = constructor_user_ord
 end
 
 module Constrmap = Map.Make(ConstructorOrdered)
@@ -325,152 +635,223 @@ module Constrmap_env = Map.Make(ConstructorOrdered_env)
 
 (* Better to have it here that in closure, since used in grammar.cma *)
 type evaluable_global_reference =
-  | EvalVarRef of identifier
-  | EvalConstRef of constant
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
 
-let eq_egr e1 e2 = match e1,e2 with
-    EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
-  | _,_ -> e1 = e2
+let eq_egr e1 e2 = match e1, e2 with
+    EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2
+  | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2
+  | _, _ -> false
 
 (** {6 Hash-consing of name objects } *)
 
-module Hname = Hashcons.Make(
-  struct
-    type t = name
-    type u = identifier -> identifier
-    let hash_sub hident = function
-      | Name id -> Name (hident id)
-      | n -> n
-    let equal n1 n2 =
-      match (n1,n2) with
-	| (Name id1, Name id2) -> id1 == id2
-        | (Anonymous,Anonymous) -> true
-        | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Hdir = Hashcons.Make(
-  struct
-    type t = dir_path
-    type u = identifier -> identifier
-    let hash_sub hident d = list_smartmap hident d
-    let rec equal d1 d2 = match (d1,d2) with
-      | [],[] -> true
-      | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
-      | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Huniqid = Hashcons.Make(
-  struct
-    type t = uniq_ident
-    type u = (identifier -> identifier) * (dir_path -> dir_path)
-    let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
-    let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2
-    let hash = Hashtbl.hash
-  end)
-
-module Hmod = Hashcons.Make(
-  struct
-    type t = module_path
-    type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) *
-	(string -> string)
-    let rec hash_sub (hdir,huniqid,hstr as hfuns) = function
-      | MPfile dir -> MPfile (hdir dir)
-      | MPbound m -> MPbound (huniqid m)
-      | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l)
-    let rec equal d1 d2 = match (d1,d2) with
-      | MPfile dir1, MPfile dir2 -> dir1 == dir2
-      | MPbound m1, MPbound m2 -> m1 == m2
-      | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
-      | _ -> false
-    let hash = Hashtbl.hash
-  end)
-
-module Hkn = Hashcons.Make(
-  struct
-    type t = kernel_name
-    type u = (module_path -> module_path)
-	* (dir_path -> dir_path) * (string -> string)
-    let hash_sub (hmod,hdir,hstr) (md,dir,l) =
-      (hmod md, hdir dir, hstr l)
-    let equal (mod1,dir1,l1) (mod2,dir2,l2) =
-      mod1 == mod2 && dir1 == dir2 && l1 == l2
-    let hash = Hashtbl.hash
-  end)
-
-(** For [constant] and [mutual_inductive], we discriminate only on
-    the user part : having the same user part implies having the
-    same canonical part (invariant of the system). *)
-
-module Hcn = Hashcons.Make(
-  struct
-    type t = kernel_name*kernel_name
-    type u = kernel_name -> kernel_name
-    let hash_sub hkn (user,can) = (hkn user, hkn can)
-    let equal (user1,_) (user2,_) = user1 == user2
-    let hash (user,_) = Hashtbl.hash user
-  end)
-
 module Hind = Hashcons.Make(
   struct
     type t = inductive
-    type u = mutual_inductive -> mutual_inductive
-    let hash_sub hmind (mind, i) = (hmind mind, i)
-    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2
-    let hash = Hashtbl.hash
+    type u = MutInd.t -> MutInd.t
+    let hashcons hmind (mind, i) = (hmind mind, i)
+    let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2
+    let hash = ind_hash
   end)
 
 module Hconstruct = Hashcons.Make(
   struct
     type t = constructor
     type u = inductive -> inductive
-    let hash_sub hind (ind, j) = (hind ind, j)
-    let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2
-    let hash = Hashtbl.hash
+    let hashcons hind (ind, j) = (hind ind, j)
+    let equal (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2
+    let hash = constructor_hash
   end)
 
-let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f ()
-let hcons_ident = hcons_string
-let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident
-let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident
-let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath)
-let hcons_mp =
-  Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string)
-let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string)
-let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn
-let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn
-let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind
-let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind
-
+let hcons_con = Hashcons.simple_hcons Constant.HashKP.generate Constant.HashKP.hcons KerName.hcons
+let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate MutInd.HashKP.hcons KerName.hcons
+let hcons_ind = Hashcons.simple_hcons Hind.generate Hind.hcons hcons_mind
+let hcons_construct = Hashcons.simple_hcons Hconstruct.generate Hconstruct.hcons hcons_ind
 
-(*******)
+(*****************)
 
-type transparent_state = Idpred.t * Cpred.t
+type transparent_state = Id.Pred.t * Cpred.t
 
-let empty_transparent_state = (Idpred.empty, Cpred.empty)
-let full_transparent_state = (Idpred.full, Cpred.full)
-let var_full_transparent_state = (Idpred.full, Cpred.empty)
-let cst_full_transparent_state = (Idpred.empty, Cpred.full)
+let empty_transparent_state = (Id.Pred.empty, Cpred.empty)
+let full_transparent_state = (Id.Pred.full, Cpred.full)
+let var_full_transparent_state = (Id.Pred.full, Cpred.empty)
+let cst_full_transparent_state = (Id.Pred.empty, Cpred.full)
 
 type 'a tableKey =
-  | ConstKey of constant
-  | VarKey of identifier
-  | RelKey of 'a
-
+  | ConstKey of 'a
+  | VarKey of Id.t
+  | RelKey of Int.t
 
 type inv_rel_key = int (* index in the [rel_context] part of environment
 			  starting by the end, {\em inverse}
 			  of de Bruijn indice *)
 
-type id_key = inv_rel_key tableKey
+let eq_table_key f ik1 ik2 =
+  if ik1 == ik2 then true
+  else match ik1,ik2 with
+  | ConstKey c1, ConstKey c2 -> f c1 c2
+  | VarKey id1, VarKey id2 -> Id.equal id1 id2
+  | RelKey k1, RelKey k2 -> Int.equal k1 k2
+  | _ -> false
+
+let eq_con_chk = Constant.UserOrd.equal
+let eq_mind_chk = MutInd.UserOrd.equal
+let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2
+
+
+(*******************************************************************)
+(** Compatibility layers *)
+
+(** Backward compatibility for [Id] *)
+
+type identifier = Id.t
+
+let id_eq = Id.equal
+let id_ord = Id.compare
+let string_of_id = Id.to_string
+let id_of_string = Id.of_string
+
+module Idset = Id.Set
+module Idmap = Id.Map
+module Idpred = Id.Pred
+
+(** Compatibility layer for [Name] *)
+
+let name_eq = Name.equal
 
-let eq_id_key ik1 ik2 =
-  match ik1,ik2 with
-    ConstKey (_,kn1),
-      ConstKey (_,kn2) -> kn1=kn2
-    | a,b -> a=b
+(** Compatibility layer for [DirPath] *)
+
+type dir_path = DirPath.t
+let dir_path_ord = DirPath.compare
+let dir_path_eq = DirPath.equal
+let make_dirpath = DirPath.make
+let repr_dirpath = DirPath.repr
+let empty_dirpath = DirPath.empty
+let is_empty_dirpath = DirPath.is_empty
+let string_of_dirpath = DirPath.to_string
+let initial_dir = DirPath.initial
+
+(** Compatibility layer for [MBId] *)
+
+type mod_bound_id = MBId.t
+let mod_bound_id_ord = MBId.compare
+let mod_bound_id_eq = MBId.equal
+let make_mbid = MBId.make
+let repr_mbid = MBId.repr
+let debug_string_of_mbid = MBId.debug_to_string
+let string_of_mbid = MBId.to_string
+let id_of_mbid = MBId.to_id
+
+(** Compatibility layer for [Label] *)
+
+type label = Id.t
+let mk_label = Label.make
+let string_of_label = Label.to_string
+let pr_label = Label.print
+let id_of_label = Label.to_id
+let label_of_id = Label.of_id
+let eq_label = Label.equal
+
+(** Compatibility layer for [ModPath] *)
+
+type module_path = ModPath.t =
+  | MPfile of DirPath.t
+  | MPbound of MBId.t
+  | MPdot of module_path * Label.t
+let check_bound_mp = ModPath.is_bound
+let string_of_mp = ModPath.to_string
+let mp_ord = ModPath.compare
+let mp_eq = ModPath.equal
+let initial_path = ModPath.initial
+
+(** Compatibility layer for [KerName] *)
+
+type kernel_name = KerName.t
+let make_kn = KerName.make
+let repr_kn = KerName.repr
+let modpath = KerName.modpath
+let label = KerName.label
+let string_of_kn = KerName.to_string
+let pr_kn = KerName.print
+let kn_ord = KerName.compare
+
+(** Compatibility layer for [Constant] *)
+
+type constant = Constant.t
+
+
+module Projection = 
+struct 
+  type t = constant * bool
+    
+  let make c b = (c, b)
+
+  let constant = fst
+  let unfolded = snd
+  let unfold (c, b as p) = if b then p else (c, true)
+  let equal (c, b) (c', b') = Constant.equal c c' && b == b'
+
+  let hash (c, b) = (if b then 0 else 1) + Constant.hash c
+
+  module Self_Hashcons =
+    struct
+      type _t = t
+      type t = _t
+      type u = Constant.t -> Constant.t
+      let hashcons hc (c,b) = (hc c,b)
+      let equal ((c,b) as x) ((c',b') as y) =
+        x == y || (c == c' && b == b')
+      let hash = hash
+    end
+
+  module HashProjection = Hashcons.Make(Self_Hashcons)
+
+  let hcons = Hashcons.simple_hcons HashProjection.generate HashProjection.hcons hcons_con
+
+  let compare (c, b) (c', b') =
+    if b == b' then Constant.CanOrd.compare c c'
+    else if b then 1 else -1
+
+  let map f (c, b as x) =
+    let c' = f c in
+      if c' == c then x else (c', b)
+end
 
-let eq_con_chk (kn1,_) (kn2,_) = kn1=kn2
-let eq_mind_chk (kn1,_) (kn2,_) = kn1=kn2
-let eq_ind_chk (kn1,i1) (kn2,i2) = i1=i2&&eq_mind_chk kn1 kn2
+type projection = Projection.t
+
+let constant_of_kn = Constant.make1
+let constant_of_kn_equiv = Constant.make
+let make_con = Constant.make3
+let repr_con = Constant.repr3
+let canonical_con = Constant.canonical
+let user_con = Constant.user
+let con_label = Constant.label
+let con_modpath = Constant.modpath
+let eq_constant = Constant.equal
+let eq_constant_key = Constant.UserOrd.equal
+let con_ord = Constant.CanOrd.compare
+let con_user_ord = Constant.UserOrd.compare
+let string_of_con = Constant.to_string
+let pr_con = Constant.print
+let debug_string_of_con = Constant.debug_to_string
+let debug_pr_con = Constant.debug_print
+let con_with_label = Constant.change_label
+
+(** Compatibility layer for [MutInd] *)
+
+type mutual_inductive = MutInd.t
+let mind_of_kn = MutInd.make1
+let mind_of_kn_equiv = MutInd.make
+let make_mind = MutInd.make3
+let canonical_mind = MutInd.canonical
+let user_mind = MutInd.user
+let repr_mind = MutInd.repr3
+let mind_label = MutInd.label
+let mind_modpath = MutInd.modpath
+let eq_mind = MutInd.equal
+let mind_ord = MutInd.CanOrd.compare
+let mind_user_ord = MutInd.UserOrd.compare
+let string_of_mind = MutInd.to_string
+let pr_mind = MutInd.print
+let debug_string_of_mind = MutInd.debug_to_string
+let debug_pr_mind = MutInd.debug_print
diff --git a/kernel/names.mli b/kernel/names.mli
index c23f526d..d82043da 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -1,222 +1,453 @@
 (************************************************************************)
 (*  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 Util
+
 (** {6 Identifiers } *)
 
-type identifier
+module Id :
+sig
+  type t
+  (** Type of identifiers *)
 
-(** Parsing and printing of identifiers *)
-val string_of_id : identifier -> string
-val id_of_string : string -> identifier
+  val equal : t -> t -> bool
+  (** Equality over identifiers *)
 
-val id_ord : identifier -> identifier -> int
+  val compare : t -> t -> int
+  (** Comparison over identifiers *)
+
+  val hash : t -> int
+  (** Hash over identifiers *)
+
+  val is_valid : string -> bool
+  (** Check that a string may be converted to an identifier. *)
+
+  val of_string : string -> t
+  (** Converts a string into an identifier. May raise [UserError _] if the
+      string is not valid. *)
+
+  val to_string : t -> string
+  (** Converts a identifier into an string. *)
+
+  val print : t -> Pp.std_ppcmds
+  (** Pretty-printer. *)
+
+  module Set : Set.S with type elt = t
+  (** Finite sets of identifiers. *)
+
+  module Map : Map.ExtS with type key = t and module Set := Set
+  (** Finite maps of identifiers. *)
+
+  module Pred : Predicate.S with type elt = t
+  (** Predicates over identifiers. *)
+
+  module List : List.MonoS with type elt = t
+  (** Operations over lists of identifiers. *)
+
+  val hcons : t -> t
+  (** Hashconsing of identifiers. *)
+
+end
+
+module Name :
+sig
+  type t = Name of Id.t | Anonymous
+  (** A name is either undefined, either an identifier. *)
+
+  val compare : t -> t -> int
+  (** Comparison over names. *)
+
+  val equal : t -> t -> bool
+  (** Equality over names. *)
+
+  val hash : t -> int
+  (** Hash over names. *)
+
+  val hcons : t -> t
+  (** Hashconsing over names. *)
 
-(** Identifiers sets and maps *)
-module Idset  : Set.S with type elt = identifier
-module Idpred : Predicate.S with type elt = identifier
-module Idmap  : sig
-  include Map.S with type key = identifier
-  val exists : (identifier -> 'a -> bool) -> 'a t -> bool
-  val singleton : key -> 'a -> 'a t
 end
 
-(** {6 Various types based on identifiers } *)
+(** {6 Type aliases} *)
+
+type name = Name.t = Name of Id.t | Anonymous
+type variable = Id.t
+type module_ident = Id.t
 
-type name = Name of identifier | Anonymous
-type variable = identifier
+module ModIdset : Set.S with type elt = module_ident
+module ModIdmap : Map.ExtS with type key = module_ident and module Set := ModIdset
 
 (** {6 Directory paths = section names paths } *)
 
-type module_ident = identifier
-module ModIdmap : Map.S with type key = module_ident
+module DirPath :
+sig
+  type t
+  (** Type of directory paths. Essentially a list of module identifiers. The
+      order is reversed to improve sharing. E.g. A.B.C is ["C";"B";"A"] *)
 
-type dir_path
+  val equal : t -> t -> bool
+  (** Equality over directory paths. *)
 
-(** Inner modules idents on top of list (to improve sharing).
-   For instance: A.B.C is ["C";"B";"A"] *)
-val make_dirpath : module_ident list -> dir_path
-val repr_dirpath : dir_path -> module_ident list
+  val compare : t -> t -> int
+  (** Comparison over directory paths. *)
 
-val empty_dirpath : dir_path
+  val hash : t -> int
+  (** Hash over directory paths. *)
 
-(** Printing of directory paths as ["coq_root.module.submodule"] *)
-val string_of_dirpath : dir_path -> string
+  val make : module_ident list -> t
+  (** Create a directory path. (The list must be reversed). *)
+
+  val repr : t -> module_ident list
+  (** Represent a directory path. (The result list is reversed). *)
+
+  val empty : t
+  (** The empty directory path. *)
+
+  val is_empty : t -> bool
+  (** Test whether a directory path is empty. *)
+
+  val to_string : t -> string
+  (** Print directory paths as ["coq_root.module.submodule"] *)
+
+  val initial : t
+  (** Initial "seed" of the unique identifier generator *)
+
+  val hcons : t -> t
+  (** Hashconsing of directory paths. *)
+
+end
 
 (** {6 Names of structure elements } *)
 
-type label
+module Label :
+sig
+  type t
+  (** Type of labels *)
 
-val mk_label : string -> label
-val string_of_label : label -> string
-val pr_label : label -> Pp.std_ppcmds
+  val equal : t -> t -> bool
+  (** Equality over labels *)
 
-val label_of_id : identifier -> label
-val id_of_label : label -> identifier
+  val compare : t -> t -> int
+  (** Comparison over labels. *)
 
-module Labset : Set.S with type elt = label
-module Labmap : Map.S with type key = label
+  val hash : t -> int
+  (** Hash over labels. *)
 
-(** {6 Unique names for bound modules } *)
+  val make : string -> t
+  (** Create a label out of a string. *)
 
-type mod_bound_id
+  val to_string : t -> string
+  (** Conversion to string. *)
 
-(** The first argument is a file name - to prevent conflict between
-   different files *)
+  val of_id : Id.t -> t
+  (** Conversion from an identifier. *)
 
-val make_mbid : dir_path -> identifier -> mod_bound_id
-val repr_mbid : mod_bound_id -> int * identifier * dir_path
-val id_of_mbid : mod_bound_id -> identifier
-val debug_string_of_mbid : mod_bound_id -> string
-val string_of_mbid : mod_bound_id -> string
+  val to_id : t -> Id.t
+  (** Conversion to an identifier. *)
+
+  val print : t -> Pp.std_ppcmds
+  (** Pretty-printer. *)
+
+  module Set : Set.S with type elt = t
+  module Map : Map.ExtS with type key = t and module Set := Set
+
+end
+
+(** {6 Unique names for bound modules} *)
+
+module MBId :
+sig
+  type t
+  (** Unique names for bound modules. Each call to [make] constructs a fresh
+      unique identifier. *)
+
+  val equal : t -> t -> bool
+  (** Equality over unique bound names. *)
+
+  val compare : t -> t -> int
+  (** Comparison over unique bound names. *)
+
+  val hash : t -> int
+  (** Hash over unique bound names. *)
+
+  val make : DirPath.t -> Id.t -> t
+  (** The first argument is a file name, to prevent conflict between different
+      files. *)
+
+  val repr : t -> int * Id.t * DirPath.t
+  (** Reverse of [make]. *)
+
+  val to_id : t -> Id.t
+  (** Return the identifier contained in the argument. *)
+
+  val to_string : t -> string
+  (** Conversion to a string. *)
+
+  val debug_to_string : t -> string
+  (** Same as [to_string], but outputs information related to debug. *)
+
+end
+
+module MBIset : Set.S with type elt = MBId.t
+module MBImap : Map.ExtS with type key = MBId.t and module Set := MBIset
 
 (** {6 The module part of the kernel name } *)
 
-type module_path =
-  | MPfile of dir_path
-  | MPbound of mod_bound_id
-  | MPdot of module_path * label
+module ModPath :
+sig
+  type t =
+    | MPfile of DirPath.t
+    | MPbound of MBId.t
+    | MPdot of t * Label.t
 
-val check_bound_mp : module_path -> bool
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
 
-val string_of_mp : module_path -> string
+  val is_bound : t -> bool
 
-module MPset : Set.S with type elt = module_path
-module MPmap : Map.S with type key = module_path
+  val to_string : t -> string
 
-(** Initial "seed" of the unique identifier generator *)
-val initial_dir : dir_path
+  val initial : t
+  (** Name of the toplevel structure ([= MPfile initial_dir]) *)
 
-(** Name of the toplevel structure *)
-val initial_path : module_path (** [= MPfile initial_dir] *)
+  val dp : t -> DirPath.t
+
+end
+
+module MPset : Set.S with type elt = ModPath.t
+module MPmap : Map.ExtS with type key = ModPath.t and module Set := MPset
 
 (** {6 The absolute names of objects seen by kernel } *)
 
-type kernel_name
+module KerName :
+sig
+  type t
 
-(** Constructor and destructor *)
-val make_kn : module_path -> dir_path -> label -> kernel_name
-val repr_kn : kernel_name -> module_path * dir_path * label
+  (** Constructor and destructor *)
+  val make : ModPath.t -> DirPath.t -> Label.t -> t
+  val make2 : ModPath.t -> Label.t -> t
+  val repr : t -> ModPath.t * DirPath.t * Label.t
 
-val modpath : kernel_name -> module_path
-val label : kernel_name -> label
+  (** Projections *)
+  val modpath : t -> ModPath.t
+  val label : t -> Label.t
 
-val string_of_kn : kernel_name -> string
-val pr_kn : kernel_name -> Pp.std_ppcmds
+  (** Display *)
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
 
-val kn_ord : kernel_name -> kernel_name -> int
+  (** Comparisons *)
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
 
-module KNset  : Set.S with type elt = kernel_name
-module KNpred : Predicate.S with type elt = kernel_name
-module KNmap  : Map.S with type key = kernel_name
+module KNset  : CSig.SetS with type elt = KerName.t
+module KNpred : Predicate.S with type elt = KerName.t
+module KNmap  : Map.ExtS with type key = KerName.t and module Set := KNset
 
 
-(** {6 Specific paths for declarations } *)
+(** {6 Constant Names } *)
 
-type constant
-type mutual_inductive
+module Constant:
+sig
+  type t
 
-(** Beware: first inductive has index 0 *)
-type inductive = mutual_inductive * int
+  (** Constructors *)
 
-(** Beware: first constructor has index 1 *)
-type constructor = inductive * int
+  val make : KerName.t -> KerName.t -> t
+  (** Builds a constant name from a user and a canonical kernel name. *)
+
+  val make1 : KerName.t -> t
+  (** Special case of [make] where the user name is canonical.  *)
+
+  val make2 : ModPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make2 ...))] *)
+
+  val make3 : ModPath.t -> DirPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make ...))] *)
+
+  (** Projections *)
+
+  val user : t -> KerName.t
+  val canonical : t -> KerName.t
+
+  val repr3 : t -> ModPath.t * DirPath.t * Label.t
+  (** Shortcut for [KerName.repr (user ...)] *)
+
+  val modpath : t -> ModPath.t
+  (** Shortcut for [KerName.modpath (user ...)] *)
+
+  val label : t -> Label.t
+  (** Shortcut for [KerName.label (user ...)] *)
+
+  (** Comparisons *)
+
+  module CanOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
 
-(** *_env modules consider an order on user part of names
+  module UserOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+  val equal : t -> t -> bool
+  (** Default comparison, alias for [CanOrd.equal] *)
+
+  val hash : t -> int
+  (** Hashing function *)
+
+  val change_label : t -> Label.t -> t
+  (** Builds a new constant name with a different label *)
+
+  (** Displaying *)
+
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
+  val debug_to_string : t -> string
+  val debug_print : t -> Pp.std_ppcmds
+
+end
+
+(** The [*_env] modules consider an order on user part of names
    the others consider an order on canonical part of names*)
-module Cmap  : Map.S with type key = constant
-module Cmap_env  : Map.S with type key = constant
-module Cpred  : Predicate.S with type elt = constant
-module Cset  : Set.S with type elt = constant
-module Cset_env  : Set.S with type elt = constant
-module Mindmap : Map.S with type key = mutual_inductive
-module Mindmap_env : Map.S with type key = mutual_inductive
-module Mindset : Set.S with type elt = mutual_inductive
-module Indmap : Map.S with type key = inductive
-module Constrmap : Map.S with type key = constructor
-module Indmap_env : Map.S with type key = inductive
-module Constrmap_env : Map.S with type key = constructor
+module Cpred : Predicate.S with type elt = Constant.t
+module Cset : CSig.SetS with type elt = Constant.t
+module Cset_env  : CSig.SetS with type elt = Constant.t
+module Cmap : Map.ExtS with type key = Constant.t and module Set := Cset
+module Cmap_env : Map.ExtS with type key = Constant.t  and module Set := Cset_env
 
-val constant_of_kn : kernel_name -> constant
-val constant_of_kn_equiv : kernel_name -> kernel_name -> constant
-val make_con : module_path -> dir_path -> label -> constant
-val make_con_equiv : module_path -> module_path -> dir_path 
-  -> label -> constant
-val user_con : constant -> kernel_name
-val canonical_con : constant -> kernel_name
-val repr_con : constant -> module_path * dir_path * label
-val eq_constant : constant -> constant -> bool
-val con_with_label : constant -> label -> constant
+(** {6 Inductive names} *)
 
-val string_of_con : constant -> string
-val con_label : constant -> label
-val con_modpath : constant -> module_path
-val pr_con : constant -> Pp.std_ppcmds
-val debug_pr_con : constant -> Pp.std_ppcmds
-val debug_string_of_con : constant -> string
+module MutInd :
+sig
+  type t
 
+  (** Constructors *)
 
+  val make : KerName.t -> KerName.t -> t
+  (** Builds a mutual inductive name from a user and a canonical kernel name. *)
 
-val mind_of_kn : kernel_name -> mutual_inductive
-val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive
-val make_mind : module_path -> dir_path -> label -> mutual_inductive
-val make_mind_equiv : module_path -> module_path -> dir_path 
-  -> label -> mutual_inductive
-val user_mind : mutual_inductive -> kernel_name
-val canonical_mind : mutual_inductive -> kernel_name
-val repr_mind : mutual_inductive -> module_path * dir_path * label
-val eq_mind : mutual_inductive -> mutual_inductive -> bool
+  val make1 : KerName.t -> t
+  (** Special case of [make] where the user name is canonical.  *)
 
-val string_of_mind : mutual_inductive -> string
-val mind_label : mutual_inductive -> label
-val mind_modpath : mutual_inductive -> module_path
-val pr_mind : mutual_inductive -> Pp.std_ppcmds
-val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds
-val debug_string_of_mind : mutual_inductive -> string
+  val make2 : ModPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make2 ...))] *)
+
+  val make3 : ModPath.t -> DirPath.t -> Label.t -> t
+  (** Shortcut for [(make1 (KerName.make ...))] *)
+
+  (** Projections *)
+
+  val user : t -> KerName.t
+  val canonical : t -> KerName.t
+
+  val repr3 : t -> ModPath.t * DirPath.t * Label.t
+  (** Shortcut for [KerName.repr (user ...)] *)
+
+  val modpath : t -> ModPath.t
+  (** Shortcut for [KerName.modpath (user ...)] *)
+
+  val label : t -> Label.t
+  (** Shortcut for [KerName.label (user ...)] *)
+
+  (** Comparisons *)
+
+  module CanOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
+
+  module UserOrd : sig
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val hash : t -> int
+  end
 
+  val equal : t -> t -> bool
+  (** Default comparison, alias for [CanOrd.equal] *)
 
+  val hash : t -> int
+
+  (** Displaying *)
+
+  val to_string : t -> string
+  val print : t -> Pp.std_ppcmds
+  val debug_to_string : t -> string
+  val debug_print : t -> Pp.std_ppcmds
+
+end
+
+module Mindset : CSig.SetS with type elt = MutInd.t
+module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset
+module Mindmap_env : Map.S with type key = MutInd.t
+
+(** Beware: first inductive has index 0 *)
+type inductive = MutInd.t * int
+
+(** Beware: first constructor has index 1 *)
+type constructor = inductive * int
+
+module Indmap : Map.S with type key = inductive
+module Constrmap : Map.S with type key = constructor
+module Indmap_env : Map.S with type key = inductive
+module Constrmap_env : Map.S with type key = constructor
 
-val ind_modpath : inductive -> module_path
-val constr_modpath : constructor -> module_path
+val ind_modpath : inductive -> ModPath.t
+val constr_modpath : constructor -> ModPath.t
 
 val ith_mutual_inductive : inductive -> int -> inductive
 val ith_constructor_of_inductive : inductive -> int -> constructor
 val inductive_of_constructor : constructor -> inductive
 val index_of_constructor : constructor -> int
 val eq_ind : inductive -> inductive -> bool
+val eq_user_ind : inductive -> inductive -> bool
+val ind_ord : inductive -> inductive -> int
+val ind_hash : inductive -> int
+val ind_user_ord : inductive -> inductive -> int
+val ind_user_hash : inductive -> int
 val eq_constructor : constructor -> constructor -> bool
+val eq_user_constructor : constructor -> constructor -> bool
+val constructor_ord : constructor -> constructor -> int
+val constructor_user_ord : constructor -> constructor -> int
+val constructor_hash : constructor -> int
+val constructor_user_hash : constructor -> int
 
 (** Better to have it here that in Closure, since required in grammar.cma *)
 type evaluable_global_reference =
-  | EvalVarRef of identifier
-  | EvalConstRef of constant
+  | EvalVarRef of Id.t
+  | EvalConstRef of Constant.t
 
 val eq_egr : evaluable_global_reference ->  evaluable_global_reference
   -> bool
 
 (** {6 Hash-consing } *)
 
-val hcons_string : string -> string
-val hcons_ident : identifier -> identifier
-val hcons_name : name -> name
-val hcons_dirpath : dir_path -> dir_path
-val hcons_con : constant -> constant
-val hcons_mind : mutual_inductive -> mutual_inductive
+val hcons_con : Constant.t -> Constant.t
+val hcons_mind : MutInd.t -> MutInd.t
 val hcons_ind : inductive -> inductive
 val hcons_construct : constructor -> constructor
 
 (******)
 
 type 'a tableKey =
-  | ConstKey of constant
-  | VarKey of identifier
-  | RelKey of 'a
+  | ConstKey of 'a
+  | VarKey of Id.t
+  | RelKey of Int.t
 
-type transparent_state = Idpred.t * Cpred.t
+(** Sets of names *)
+type transparent_state = Id.Pred.t * Cpred.t
 
 val empty_transparent_state : transparent_state
 val full_transparent_state : transparent_state
@@ -227,13 +458,294 @@ type inv_rel_key = int (** index in the [rel_context] part of environment
 			  starting by the end, {e inverse}
 			  of de Bruijn indice *)
 
-type id_key = inv_rel_key tableKey
+val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool
+val eq_constant_key : Constant.t -> Constant.t -> bool
 
-val eq_id_key : id_key -> id_key -> bool
+(** equalities on constant and inductive names (for the checker) *)
 
-(*equalities on constant and inductive 
-  names for the checker*)
-
-val eq_con_chk : constant -> constant -> bool
+val eq_con_chk : Constant.t -> Constant.t -> bool
 val eq_ind_chk : inductive -> inductive -> bool
 
+(** {6 Deprecated functions. For backward compatibility.} *)
+
+(** {5 Identifiers} *)
+
+type identifier = Id.t
+(** @deprecated Alias for [Id.t] *)
+
+val string_of_id : identifier -> string
+(** @deprecated Same as [Id.to_string]. *)
+
+val id_of_string : string -> identifier
+(** @deprecated Same as [Id.of_string]. *)
+
+val id_ord : identifier -> identifier -> int
+(** @deprecated Same as [Id.compare]. *)
+
+val id_eq : identifier -> identifier -> bool
+(** @deprecated Same as [Id.equal]. *)
+
+module Idset  : Set.S with type elt = identifier and type t = Id.Set.t
+(** @deprecated Same as [Id.Set]. *)
+
+module Idpred : Predicate.S with type elt = identifier and type t = Id.Pred.t
+(** @deprecated Same as [Id.Pred]. *)
+
+module Idmap : module type of Id.Map
+(** @deprecated Same as [Id.Map]. *)
+
+(** {5 Directory paths} *)
+
+type dir_path = DirPath.t
+(** @deprecated Alias for [DirPath.t]. *)
+
+val dir_path_ord : dir_path -> dir_path -> int
+(** @deprecated Same as [DirPath.compare]. *)
+
+val dir_path_eq : dir_path -> dir_path -> bool
+(** @deprecated Same as [DirPath.equal]. *)
+
+val make_dirpath : module_ident list -> dir_path
+(** @deprecated Same as [DirPath.make]. *)
+
+val repr_dirpath : dir_path -> module_ident list
+(** @deprecated Same as [DirPath.repr]. *)
+
+val empty_dirpath : dir_path
+(** @deprecated Same as [DirPath.empty]. *)
+
+val is_empty_dirpath : dir_path -> bool
+(** @deprecated Same as [DirPath.is_empty]. *)
+
+val string_of_dirpath : dir_path -> string
+(** @deprecated Same as [DirPath.to_string]. *)
+
+val initial_dir : DirPath.t
+(** @deprecated Same as [DirPath.initial]. *)
+
+(** {5 Labels} *)
+
+type label = Label.t
+(** Alias type *)
+
+val mk_label : string -> label
+(** @deprecated Same as [Label.make]. *)
+
+val string_of_label : label -> string
+(** @deprecated Same as [Label.to_string]. *)
+
+val pr_label : label -> Pp.std_ppcmds
+(** @deprecated Same as [Label.print]. *)
+
+val label_of_id : Id.t -> label
+(** @deprecated Same as [Label.of_id]. *)
+
+val id_of_label : label -> Id.t
+(** @deprecated Same as [Label.to_id]. *)
+
+val eq_label : label -> label -> bool
+(** @deprecated Same as [Label.equal]. *)
+
+(** {5 Unique bound module names} *)
+
+type mod_bound_id = MBId.t
+(** Alias type. *)
+
+val mod_bound_id_ord : mod_bound_id -> mod_bound_id -> int
+(** @deprecated Same as [MBId.compare]. *)
+
+val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool
+(** @deprecated Same as [MBId.equal]. *)
+
+val make_mbid : DirPath.t -> Id.t -> mod_bound_id
+(** @deprecated Same as [MBId.make]. *)
+
+val repr_mbid : mod_bound_id -> int * Id.t * DirPath.t
+(** @deprecated Same as [MBId.repr]. *)
+
+val id_of_mbid : mod_bound_id -> Id.t
+(** @deprecated Same as [MBId.to_id]. *)
+
+val string_of_mbid : mod_bound_id -> string
+(** @deprecated Same as [MBId.to_string]. *)
+
+val debug_string_of_mbid : mod_bound_id -> string
+(** @deprecated Same as [MBId.debug_to_string]. *)
+
+(** {5 Names} *)
+
+val name_eq : name -> name -> bool
+(** @deprecated Same as [Name.equal]. *)
+
+(** {5 Module paths} *)
+
+type module_path = ModPath.t =
+  | MPfile of DirPath.t
+  | MPbound of MBId.t
+  | MPdot of module_path * Label.t
+(** @deprecated Alias type *)
+
+val mp_ord : module_path -> module_path -> int
+(** @deprecated Same as [ModPath.compare]. *)
+
+val mp_eq : module_path -> module_path -> bool
+(** @deprecated Same as [ModPath.equal]. *)
+
+val check_bound_mp : module_path -> bool
+(** @deprecated Same as [ModPath.is_bound]. *)
+
+val string_of_mp : module_path -> string
+(** @deprecated Same as [ModPath.to_string]. *)
+
+val initial_path : module_path
+(** @deprecated Same as [ModPath.initial]. *)
+
+(** {5 Kernel names} *)
+
+type kernel_name = KerName.t
+(** @deprecated Alias type *)
+
+val make_kn : ModPath.t -> DirPath.t -> Label.t -> kernel_name
+(** @deprecated Same as [KerName.make]. *)
+
+val repr_kn : kernel_name -> module_path * DirPath.t * Label.t
+(** @deprecated Same as [KerName.repr]. *)
+
+val modpath : kernel_name -> module_path
+(** @deprecated Same as [KerName.modpath]. *)
+
+val label : kernel_name -> Label.t
+(** @deprecated Same as [KerName.label]. *)
+
+val string_of_kn : kernel_name -> string
+(** @deprecated Same as [KerName.to_string]. *)
+
+val pr_kn : kernel_name -> Pp.std_ppcmds
+(** @deprecated Same as [KerName.print]. *)
+
+val kn_ord : kernel_name -> kernel_name -> int
+(** @deprecated Same as [KerName.compare]. *)
+
+(** {5 Constant names} *)
+
+type constant = Constant.t
+(** @deprecated Alias type *)
+
+module Projection : sig
+  type t
+    
+  val make : constant -> bool -> t
+
+  val constant : t -> constant
+  val unfolded : t -> bool
+  val unfold : t -> t
+
+  val equal : t -> t -> bool
+  val hash : t -> int
+  val hcons : t -> t
+  (** Hashconsing of projections. *)
+
+  val compare : t -> t -> int
+    
+  val map : (constant -> constant) -> t -> t
+end
+
+type projection = Projection.t
+
+val constant_of_kn_equiv : KerName.t -> KerName.t -> constant
+(** @deprecated Same as [Constant.make] *)
+
+val constant_of_kn : KerName.t -> constant
+(** @deprecated Same as [Constant.make1] *)
+
+val make_con : ModPath.t -> DirPath.t -> Label.t -> constant
+(** @deprecated Same as [Constant.make3] *)
+
+val repr_con : constant -> ModPath.t * DirPath.t * Label.t
+(** @deprecated Same as [Constant.repr3] *)
+
+val user_con : constant -> KerName.t
+(** @deprecated Same as [Constant.user] *)
+
+val canonical_con : constant -> KerName.t
+(** @deprecated Same as [Constant.canonical] *)
+
+val con_modpath : constant -> ModPath.t
+(** @deprecated Same as [Constant.modpath] *)
+
+val con_label : constant -> Label.t
+(** @deprecated Same as [Constant.label] *)
+
+val eq_constant : constant -> constant -> bool
+(** @deprecated Same as [Constant.equal] *)
+
+val con_ord : constant -> constant -> int
+(** @deprecated Same as [Constant.CanOrd.compare] *)
+
+val con_user_ord : constant -> constant -> int
+(** @deprecated Same as [Constant.UserOrd.compare] *)
+
+val con_with_label : constant -> Label.t -> constant
+(** @deprecated Same as [Constant.change_label] *)
+
+val string_of_con : constant -> string
+(** @deprecated Same as [Constant.to_string] *)
+
+val pr_con : constant -> Pp.std_ppcmds
+(** @deprecated Same as [Constant.print] *)
+
+val debug_pr_con : constant -> Pp.std_ppcmds
+(** @deprecated Same as [Constant.debug_print] *)
+
+val debug_string_of_con : constant -> string
+(** @deprecated Same as [Constant.debug_to_string] *)
+
+(** {5 Mutual Inductive names} *)
+
+type mutual_inductive = MutInd.t
+(** @deprecated Alias type *)
+
+val mind_of_kn : KerName.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make1] *)
+
+val mind_of_kn_equiv : KerName.t -> KerName.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make2] *)
+
+val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive
+(** @deprecated Same as [MutInd.make3] *)
+
+val user_mind : mutual_inductive -> KerName.t
+(** @deprecated Same as [MutInd.user] *)
+
+val canonical_mind : mutual_inductive -> KerName.t
+(** @deprecated Same as [MutInd.canonical] *)
+
+val repr_mind : mutual_inductive -> ModPath.t * DirPath.t * Label.t
+(** @deprecated Same as [MutInd.repr3] *)
+
+val eq_mind : mutual_inductive -> mutual_inductive -> bool
+(** @deprecated Same as [MutInd.equal] *)
+
+val mind_ord : mutual_inductive -> mutual_inductive -> int
+(** @deprecated Same as [MutInd.CanOrd.compare] *)
+
+val mind_user_ord : mutual_inductive -> mutual_inductive -> int
+(** @deprecated Same as [MutInd.UserOrd.compare] *)
+
+val mind_label : mutual_inductive -> Label.t
+(** @deprecated Same as [MutInd.label] *)
+
+val mind_modpath : mutual_inductive -> ModPath.t
+(** @deprecated Same as [MutInd.modpath] *)
+
+val string_of_mind : mutual_inductive -> string
+(** @deprecated Same as [MutInd.to_string] *)
+
+val pr_mind : mutual_inductive -> Pp.std_ppcmds
+(** @deprecated Same as [MutInd.print] *)
+
+val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds
+(** @deprecated Same as [MutInd.debug_print] *)
+
+val debug_string_of_mind : mutual_inductive -> string
+(** @deprecated Same as [MutInd.debug_to_string] *)
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
new file mode 100644
index 00000000..1a4a4b54
--- /dev/null
+++ b/kernel/nativecode.ml
@@ -0,0 +1,2117 @@
+(************************************************************************)
+(*  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 Errors
+open Names
+open Term
+open Context
+open Declarations
+open Util
+open Nativevalues
+open Primitives
+open Nativeinstr
+open Nativelambda
+open Pre_env
+
+(** This file defines the mllambda code generation phase of the native
+compiler. mllambda represents a fragment of ML, and can easily be printed
+to OCaml code. *)
+
+(** Local names **)
+
+type lname = { lname : name; luid : int }
+
+let dummy_lname = { lname = Anonymous; luid = -1 }
+
+module LNord = 
+  struct 
+    type t = lname 
+    let compare l1 l2 = l1.luid - l2.luid
+  end
+module LNmap = Map.Make(LNord)
+module LNset = Set.Make(LNord)
+
+let lname_ctr = ref (-1)
+
+let reset_lname = lname_ctr := -1
+
+let fresh_lname n = 
+  incr lname_ctr;
+  { lname = n; luid = !lname_ctr }
+
+(** Global names **)
+type gname = 
+  | Gind of string * pinductive (* prefix, inductive name *)
+  | Gconstruct of string * pconstructor (* prefix, constructor name *)
+  | Gconstant of string * pconstant (* prefix, constant name *)
+  | Gproj of string * constant (* prefix, constant name *)
+  | Gcase of label option * int
+  | Gpred of label option * int
+  | Gfixtype of label option * int
+  | Gnorm of label option * int
+  | Gnormtbl of label option * int
+  | Ginternal of string
+  | Grel of int
+  | Gnamed of identifier
+
+let eq_gname gn1 gn2 =
+  match gn1, gn2 with
+  | Gind (s1, ind1), Gind (s2, ind2) ->
+     String.equal s1 s2 && Univ.eq_puniverses eq_ind ind1 ind2
+  | Gconstruct (s1, c1), Gconstruct (s2, c2) ->
+      String.equal s1 s2 && Univ.eq_puniverses eq_constructor c1 c2
+  | Gconstant (s1, c1), Gconstant (s2, c2) ->
+      String.equal s1 s2 && Univ.eq_puniverses Constant.equal c1 c2
+  | Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2
+  | Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2
+  | Gpred (Some l1, i1), Gpred (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gfixtype (None, i1), Gfixtype (None, i2) -> Int.equal i1 i2
+  | Gfixtype (Some l1, i1), Gfixtype (Some l2, i2) ->
+      Int.equal i1 i2 && Label.equal l1 l2
+  | Gnorm (None, i1), Gnorm (None, i2) -> Int.equal i1 i2
+  | Gnorm (Some l1, i1), Gnorm (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
+  | Gnormtbl (None, i1), Gnormtbl (None, i2) -> Int.equal i1 i2
+  | Gnormtbl (Some l1, i1), Gnormtbl (Some l2, i2) ->
+      Int.equal i1 i2 && Label.equal l1 l2
+  | Ginternal s1, Ginternal s2 -> String.equal s1 s2
+  | Grel i1, Grel i2 -> Int.equal i1 i2
+  | Gnamed id1, Gnamed id2 -> Id.equal id1 id2
+  | _ -> false
+
+open Hashset.Combine
+
+let gname_hash gn = match gn with
+| Gind (s, (ind,u)) ->
+   combinesmall 1 (combine3 (String.hash s) (ind_hash ind) (Univ.Instance.hash u))
+| Gconstruct (s, (c,u)) ->
+   combinesmall 2 (combine3 (String.hash s) (constructor_hash c) (Univ.Instance.hash u))
+| Gconstant (s, (c,u)) ->
+   combinesmall 3 (combine3 (String.hash s) (Constant.hash c) (Univ.Instance.hash u))
+| Gcase (l, i) -> combinesmall 4 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gpred (l, i) -> combinesmall 5 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gfixtype (l, i) -> combinesmall 6 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gnorm (l, i) -> combinesmall 7 (combine (Option.hash Label.hash l) (Int.hash i))
+| Gnormtbl (l, i) -> combinesmall 8 (combine (Option.hash Label.hash l) (Int.hash i))
+| Ginternal s -> combinesmall 9 (String.hash s)
+| Grel i -> combinesmall 10 (Int.hash i)
+| Gnamed id -> combinesmall 11 (Id.hash id)
+| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p))
+
+let case_ctr = ref (-1)
+
+let reset_gcase () = case_ctr := -1
+
+let fresh_gcase l =
+  incr case_ctr;
+  Gcase (l,!case_ctr)
+
+let pred_ctr = ref (-1)
+
+let reset_gpred () = pred_ctr := -1
+
+let fresh_gpred l = 
+  incr pred_ctr;
+  Gpred (l,!pred_ctr)
+
+let fixtype_ctr = ref (-1)
+
+let reset_gfixtype () = fixtype_ctr := -1
+
+let fresh_gfixtype l =
+  incr fixtype_ctr;
+  Gfixtype (l,!fixtype_ctr)
+
+let norm_ctr = ref (-1)
+
+let reset_norm () = norm_ctr := -1
+
+let fresh_gnorm l =
+  incr norm_ctr;
+  Gnorm (l,!norm_ctr)
+
+let normtbl_ctr = ref (-1)
+
+let reset_normtbl () = normtbl_ctr := -1
+
+let fresh_gnormtbl l =
+  incr normtbl_ctr;
+  Gnormtbl (l,!normtbl_ctr)
+
+(** Symbols (pre-computed values) **)
+
+type symbol =
+  | SymbValue of Nativevalues.t
+  | SymbSort of sorts
+  | SymbName of name
+  | SymbConst of constant
+  | SymbMatch of annot_sw
+  | SymbInd of inductive
+  | SymbMeta of metavariable
+  | SymbEvar of existential
+  | SymbLevel of Univ.Level.t
+
+let dummy_symb = SymbValue (dummy_value ())
+
+let eq_symbol sy1 sy2 =
+  match sy1, sy2 with
+  | SymbValue v1, SymbValue v2 -> Pervasives.(=) v1 v2 (** FIXME: how is this even valid? *)
+  | SymbSort s1, SymbSort s2 -> Sorts.equal s1 s2
+  | SymbName n1, SymbName n2 -> Name.equal n1 n2
+  | SymbConst kn1, SymbConst kn2 -> Constant.equal kn1 kn2
+  | SymbMatch sw1, SymbMatch sw2 -> eq_annot_sw sw1 sw2
+  | SymbInd ind1, SymbInd ind2 -> eq_ind ind1 ind2
+  | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2
+  | SymbEvar (evk1,args1), SymbEvar (evk2,args2) ->
+     Evar.equal evk1 evk2 && Array.for_all2 eq_constr args1 args2
+  | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2
+  | _, _ -> false
+
+let hash_symbol symb =
+  match symb with
+  | SymbValue v -> combinesmall 1 (Hashtbl.hash v) (** FIXME *)
+  | SymbSort s -> combinesmall 2 (Sorts.hash s)
+  | SymbName name -> combinesmall 3 (Name.hash name)
+  | SymbConst c -> combinesmall 4 (Constant.hash c)
+  | SymbMatch sw -> combinesmall 5 (hash_annot_sw sw)
+  | SymbInd ind -> combinesmall 6 (ind_hash ind)
+  | SymbMeta m -> combinesmall 7 m
+  | SymbEvar (evk,args) ->
+     let evh = Evar.hash evk in
+     let hl = Array.fold_left (fun h t -> combine h (Constr.hash t)) evh args in
+     combinesmall 8 hl
+  | SymbLevel l -> combinesmall 9 (Univ.Level.hash l)
+
+module HashedTypeSymbol = struct
+  type t = symbol
+  let equal = eq_symbol
+  let hash = hash_symbol
+end
+
+module HashtblSymbol = Hashtbl.Make(HashedTypeSymbol)
+
+let symb_tbl = HashtblSymbol.create 211
+
+let clear_symb_tbl () = HashtblSymbol.clear symb_tbl
+
+let get_value tbl i =
+  match tbl.(i) with
+    | SymbValue v -> v
+    | _ -> anomaly (Pp.str "get_value failed")
+
+let get_sort tbl i =
+  match tbl.(i) with
+    | SymbSort s -> s
+    | _ -> anomaly (Pp.str "get_sort failed")
+
+let get_name tbl i =
+  match tbl.(i) with
+    | SymbName id -> id
+    | _ -> anomaly (Pp.str "get_name failed")
+
+let get_const tbl i =
+  match tbl.(i) with
+    | SymbConst kn -> kn
+    | _ -> anomaly (Pp.str "get_const failed")
+
+let get_match tbl i =
+  match tbl.(i) with
+    | SymbMatch case_info -> case_info
+    | _ -> anomaly (Pp.str "get_match failed")
+
+let get_ind tbl i =
+  match tbl.(i) with
+    | SymbInd ind -> ind
+    | _ -> anomaly (Pp.str "get_ind failed")
+
+let get_meta tbl i =
+  match tbl.(i) with
+    | SymbMeta m -> m
+    | _ -> anomaly (Pp.str "get_meta failed")
+
+let get_evar tbl i =
+  match tbl.(i) with
+    | SymbEvar ev -> ev
+    | _ -> anomaly (Pp.str "get_evar failed")
+
+let get_level tbl i =
+  match tbl.(i) with
+    | SymbLevel u -> u
+    | _ -> anomaly (Pp.str "get_level failed")
+
+let push_symbol x =
+  try HashtblSymbol.find symb_tbl x
+  with Not_found ->
+    let i = HashtblSymbol.length symb_tbl in
+    HashtblSymbol.add symb_tbl x i; i
+
+let symbols_tbl_name = Ginternal "symbols_tbl"
+
+let get_symbols_tbl () =
+  let tbl = Array.make (HashtblSymbol.length symb_tbl) dummy_symb in
+  HashtblSymbol.iter (fun x i -> tbl.(i) <- x) symb_tbl; tbl
+
+(** Lambda to Mllambda **)
+
+type primitive =
+  | Mk_prod
+  | Mk_sort
+  | Mk_ind
+  | Mk_const
+  | Mk_sw
+  | Mk_fix of rec_pos * int 
+  | Mk_cofix of int
+  | Mk_rel of int
+  | Mk_var of identifier
+  | Mk_proj
+  | Is_accu
+  | Is_int
+  | Cast_accu
+  | Upd_cofix
+  | Force_cofix
+  | Mk_uint
+  | Mk_int
+  | Mk_bool
+  | Val_to_int
+  | Mk_I31_accu
+  | Decomp_uint
+  | Mk_meta
+  | Mk_evar
+  | MLand
+  | MLle
+  | MLlt
+  | MLinteq
+  | MLlsl
+  | MLlsr
+  | MLland
+  | MLlor
+  | MLlxor
+  | MLadd
+  | MLsub
+  | MLmul
+  | MLmagic
+  | MLarrayget
+  | Mk_empty_instance
+  | Coq_primitive of Primitives.t * (prefix * constant) option
+
+let eq_primitive p1 p2 =
+  match p1, p2 with
+  | Mk_prod, Mk_prod -> true
+  | Mk_sort, Mk_sort -> true
+  | Mk_ind, Mk_ind -> true
+  | Mk_const, Mk_const -> true
+  | Mk_sw, Mk_sw -> true
+  | Mk_fix (rp1, i1), Mk_fix (rp2, i2) -> Int.equal i1 i2 && eq_rec_pos rp1 rp2
+  | Mk_cofix i1, Mk_cofix i2 -> Int.equal i1 i2
+  | Mk_rel i1, Mk_rel i2 -> Int.equal i1 i2
+  | Mk_var id1, Mk_var id2 -> Id.equal id1 id2
+  | Is_accu, Is_accu -> true
+  | Cast_accu, Cast_accu -> true
+  | Upd_cofix, Upd_cofix -> true
+  | Force_cofix, Force_cofix -> true
+  | Mk_meta, Mk_meta -> true
+  | Mk_evar, Mk_evar -> true
+  | Mk_proj, Mk_proj -> true
+  | MLarrayget, MLarrayget -> true
+
+  | _ -> false
+
+let primitive_hash = function
+  | Mk_prod -> 1
+  | Mk_sort -> 2
+  | Mk_ind -> 3
+  | Mk_const -> 4
+  | Mk_sw -> 5
+  | Mk_fix (r, i) ->
+     let h = Array.fold_left (fun h i -> combine h (Int.hash i)) 0 r in
+     combinesmall 6 (combine h (Int.hash i))
+  | Mk_cofix i ->
+     combinesmall 7 (Int.hash i)
+  | Mk_rel i ->
+     combinesmall 8 (Int.hash i)
+  | Mk_var id ->
+     combinesmall 9 (Id.hash id)
+  | Is_accu -> 10
+  | Is_int -> 11
+  | Cast_accu -> 12
+  | Upd_cofix -> 13
+  | Force_cofix -> 14
+  | Mk_uint -> 15
+  | Mk_int -> 16
+  | Mk_bool -> 17
+  | Val_to_int -> 18
+  | Mk_I31_accu -> 19
+  | Decomp_uint -> 20
+  | Mk_meta -> 21
+  | Mk_evar -> 22
+  | MLand -> 23
+  | MLle -> 24
+  | MLlt -> 25
+  | MLinteq -> 26
+  | MLlsl -> 27
+  | MLlsr -> 28
+  | MLland -> 29
+  | MLlor -> 30
+  | MLlxor -> 31
+  | MLadd -> 32
+  | MLsub -> 33
+  | MLmul -> 34
+  | MLmagic -> 35
+  | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim)
+  | Coq_primitive (prim, Some (prefix,kn)) ->
+     combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim))
+  | Mk_proj -> 38
+  | MLarrayget -> 39
+  | Mk_empty_instance -> 40
+
+type mllambda =
+  | MLlocal        of lname 
+  | MLglobal       of gname 
+  | MLprimitive    of primitive
+  | MLlam          of lname array * mllambda 
+  | MLletrec       of (lname * lname array * mllambda) array * mllambda
+  | MLlet          of lname * mllambda * mllambda
+  | MLapp          of mllambda * mllambda array
+  | MLif           of mllambda * mllambda * mllambda
+  | MLmatch        of annot_sw * mllambda * mllambda * mllam_branches
+                              (* argument, prefix, accu branch, branches *)
+  | MLconstruct    of string * constructor * mllambda array
+                   (* prefix, constructor name, arguments *)
+  | MLint          of int
+  | MLuint         of Uint31.t
+  | MLsetref       of string * mllambda
+  | MLsequence     of mllambda * mllambda
+  | MLarray        of mllambda array
+
+and mllam_branches = ((constructor * lname option array) list * mllambda) array
+
+let push_lnames n env lns =
+  snd (Array.fold_left (fun (i,r) x -> (i+1, LNmap.add x i r)) (n,env) lns)
+
+let opush_lnames n env lns =
+  let oadd x i r = match x with Some ln -> LNmap.add ln i r | None -> r in
+  snd (Array.fold_left (fun (i,r) x -> (i+1, oadd x i r)) (n,env) lns)
+
+(* Alpha-equivalence on mllambda *)
+(* eq_mllambda gn1 gn2 n env1 env2 t1 t2 tests if t1 = t2 modulo gn1 = gn2 *)
+let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 =
+  match t1, t2 with
+  | MLlocal ln1, MLlocal ln2 ->
+      Int.equal (LNmap.find ln1 env1) (LNmap.find ln2 env2)
+  | MLglobal gn1', MLglobal gn2' ->
+      eq_gname gn1' gn2' || (eq_gname gn1 gn1' && eq_gname gn2 gn2')
+  | MLprimitive prim1, MLprimitive prim2 -> eq_primitive prim1 prim2
+  | MLlam (lns1, ml1), MLlam (lns2, ml2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      let env1 = push_lnames n env1 lns1 in
+      let env2 = push_lnames n env2 lns2 in
+      eq_mllambda gn1 gn2 (n+Array.length lns1) env1 env2 ml1 ml2
+  | MLletrec (defs1, body1), MLletrec (defs2, body2) ->
+      Int.equal (Array.length defs1) (Array.length defs2) &&
+      let lns1 = Array.map (fun (x,_,_) -> x) defs1 in
+      let lns2 = Array.map (fun (x,_,_) -> x) defs2 in
+      let env1 = push_lnames n env1 lns1 in
+      let env2 = push_lnames n env2 lns2 in
+      let n = n + Array.length defs1 in
+      eq_letrec gn1 gn2 n env1 env2 defs1 defs2 &&
+      eq_mllambda gn1 gn2 n env1 env2 body1 body2
+  | MLlet (ln1, def1, body1), MLlet (ln2, def2, body2) ->
+      eq_mllambda gn1 gn2 n env1 env2 def1 def2 &&
+      let env1 = LNmap.add ln1 n env1 in
+      let env2 = LNmap.add ln2 n env2 in
+      eq_mllambda gn1 gn2 (n+1) env1 env2 body1 body2
+  | MLapp (ml1, args1), MLapp (ml2, args2) ->
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 &&
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2
+  | MLif (cond1,br1,br'1), MLif (cond2,br2,br'2) ->
+      eq_mllambda gn1 gn2 n env1 env2 cond1 cond2 &&
+      eq_mllambda gn1 gn2 n env1 env2 br1 br2 &&
+      eq_mllambda gn1 gn2 n env1 env2 br'1 br'2
+  | MLmatch (annot1, c1, accu1, br1), MLmatch (annot2, c2, accu2, br2) ->
+      eq_annot_sw annot1 annot2 &&
+      eq_mllambda gn1 gn2 n env1 env2 c1 c2 &&
+      eq_mllambda gn1 gn2 n env1 env2 accu1 accu2 &&
+      eq_mllam_branches gn1 gn2 n env1 env2 br1 br2
+  | MLconstruct (pf1, cs1, args1), MLconstruct (pf2, cs2, args2) ->
+      String.equal pf1 pf2 &&
+      eq_constructor cs1 cs2 &&
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) args1 args2
+  | MLint i1, MLint i2 ->
+      Int.equal i1 i2
+  | MLuint i1, MLuint i2 ->
+      Uint31.equal i1 i2
+  | MLsetref (id1, ml1), MLsetref (id2, ml2) ->
+      String.equal id1 id2 &&
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2
+  | MLsequence (ml1, ml'1), MLsequence (ml2, ml'2) ->
+      eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 &&
+      eq_mllambda gn1 gn2 n env1 env2 ml'1 ml'2
+  | MLarray arr1, MLarray arr2 ->
+      Array.equal (eq_mllambda gn1 gn2 n env1 env2) arr1 arr2
+
+  | _, _ -> false
+
+and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 =
+  let eq_def (_,args1,ml1) (_,args2,ml2) =
+    Int.equal (Array.length args1) (Array.length args2) &&
+    let env1 = push_lnames n env1 args1 in
+    let env2 = push_lnames n env2 args2 in
+    eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 ml1 ml2
+  in
+  Array.equal eq_def defs1 defs2
+
+(* we require here that patterns have the same order, which may be too strong *)
+and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 =
+  let eq_cargs (cs1, args1) (cs2, args2) body1 body2 =
+    Int.equal (Array.length args1) (Array.length args2) &&
+    eq_constructor cs1 cs2 &&
+    let env1 = opush_lnames n env1 args1 in
+    let env2 = opush_lnames n env2 args2 in
+    eq_mllambda gn1 gn2 (n + Array.length args1) env1 env2 body1 body2
+  in
+  let eq_branch (ptl1,body1) (ptl2,body2) =
+   List.equal (fun pt1 pt2 -> eq_cargs pt1 pt2 body1 body2) ptl1 ptl2
+  in
+  Array.equal eq_branch br1 br2
+
+(* hash_mllambda gn n env t computes the hash for t ignoring occurences of gn *)
+let rec hash_mllambda gn n env t =
+  match t with
+  | MLlocal ln -> combinesmall 1 (LNmap.find ln env)
+  | MLglobal gn' -> combinesmall 2 (if eq_gname gn gn' then 0 else gname_hash gn')
+  | MLprimitive prim -> combinesmall 3 (primitive_hash prim)
+  | MLlam (lns, ml) ->
+      let env = push_lnames n env lns in
+      combinesmall 4 (combine (Array.length lns) (hash_mllambda gn (n+1) env ml))
+  | MLletrec (defs, body) ->
+      let lns = Array.map (fun (x,_,_) -> x) defs in
+      let env = push_lnames n env lns in
+      let n = n + Array.length defs in
+      let h = combine (hash_mllambda gn n env body) (Array.length defs) in
+      combinesmall 5 (hash_mllambda_letrec gn n env h defs)
+  | MLlet (ln, def, body) ->
+      let hdef = hash_mllambda gn n env def in
+      let env = LNmap.add ln n env in
+      combinesmall 6 (combine hdef (hash_mllambda gn (n+1) env body))
+  | MLapp (ml, args) ->
+      let h = hash_mllambda gn n env ml in
+      combinesmall 7 (hash_mllambda_array gn n env h args)
+  | MLif (cond,br,br') ->
+      let hcond = hash_mllambda gn n env cond in
+      let hbr = hash_mllambda gn n env br in
+      let hbr' = hash_mllambda gn n env br' in
+      combinesmall 8 (combine3 hcond hbr hbr')
+  | MLmatch (annot, c, accu, br) ->
+      let hannot = hash_annot_sw annot in
+      let hc = hash_mllambda gn n env c in
+      let haccu = hash_mllambda gn n env accu in
+      combinesmall 9 (hash_mllam_branches gn n env (combine3 hannot hc haccu) br)
+  | MLconstruct (pf, cs, args) ->
+      let hpf = String.hash pf in
+      let hcs = constructor_hash cs in
+      combinesmall 10 (hash_mllambda_array gn n env (combine hpf hcs) args)
+  | MLint i ->
+      combinesmall 11 i
+  | MLuint i ->
+      combinesmall 12 (Uint31.to_int i)
+  | MLsetref (id, ml) ->
+      let hid = String.hash id in
+      let hml = hash_mllambda gn n env ml in
+      combinesmall 13 (combine hid hml)
+  | MLsequence (ml, ml') ->
+      let hml = hash_mllambda gn n env ml in
+      let hml' = hash_mllambda gn n env ml' in
+      combinesmall 14 (combine hml hml')
+  | MLarray arr ->
+      combinesmall 15 (hash_mllambda_array gn n env 1 arr)
+
+and hash_mllambda_letrec gn n env init defs =
+  let hash_def (_,args,ml) =
+    let env = push_lnames n env args in
+    let nargs = Array.length args in
+    combine nargs (hash_mllambda gn (n + nargs) env ml)
+  in
+  Array.fold_left (fun acc t -> combine (hash_def t) acc) init defs
+
+and hash_mllambda_array gn n env init arr =
+  Array.fold_left (fun acc t -> combine (hash_mllambda gn n env t) acc) init arr
+
+and hash_mllam_branches gn n env init br =
+  let hash_cargs (cs, args) body =
+    let nargs = Array.length args in
+    let hcs = constructor_hash cs in
+    let env = opush_lnames n env args in
+    let hbody = hash_mllambda gn (n + nargs) env body in
+    combine3 nargs hcs hbody
+  in
+  let hash_branch acc (ptl,body) =
+    List.fold_left (fun acc t -> combine (hash_cargs t body) acc) acc ptl
+  in
+  Array.fold_left hash_branch init br
+
+let fv_lam l =
+  let rec aux l bind fv =
+    match l with
+    | MLlocal l ->
+	if LNset.mem l bind then fv else LNset.add l fv
+    | MLglobal _ | MLprimitive _  | MLint _ | MLuint _ -> fv
+    | MLlam (ln,body) ->
+	let bind = Array.fold_right LNset.add ln bind in
+	aux body bind fv
+    | MLletrec(bodies,def) ->
+	let bind = 
+	  Array.fold_right (fun (id,_,_) b -> LNset.add id b) bodies bind in
+	let fv_body (_,ln,body) fv =
+	  let bind = Array.fold_right LNset.add ln bind in
+	  aux body bind fv in
+	Array.fold_right fv_body bodies (aux def bind fv)
+    | MLlet(l,def,body) ->
+	aux body (LNset.add l bind) (aux def bind fv)
+    | MLapp(f,args) ->
+	let fv_arg arg fv = aux arg bind fv in
+	Array.fold_right fv_arg args (aux f bind fv)
+    | MLif(t,b1,b2) ->
+	aux t bind (aux b1 bind (aux b2 bind fv))
+    | MLmatch(_,a,p,bs) ->
+      let fv = aux a bind (aux p bind fv) in
+      let fv_bs (cargs, body) fv =
+	let bind = 
+	  List.fold_right (fun (_,args) bind ->
+	    Array.fold_right 
+	      (fun o bind -> match o with 
+	      | Some l -> LNset.add l bind 
+	      | _ -> bind) args bind) 
+	    cargs bind in
+	aux body bind fv in
+      Array.fold_right fv_bs bs fv
+          (* argument, accu branch, branches *)
+    | MLconstruct (_,_,p) ->
+	Array.fold_right (fun a fv -> aux a bind fv) p fv
+    | MLsetref(_,l) -> aux l bind fv
+    | MLsequence(l1,l2) -> aux l1 bind (aux l2 bind fv)
+    | MLarray arr -> Array.fold_right (fun a fv -> aux a bind fv) arr fv
+  in
+  aux l LNset.empty LNset.empty
+
+
+let mkMLlam params body =
+  if Array.is_empty params then body 
+  else
+    match body with
+    | MLlam (params', body) -> MLlam(Array.append params params', body)
+    | _ -> MLlam(params,body)
+
+let mkMLapp f args =
+  if Array.is_empty args then f
+  else
+    match f with
+    | MLapp(f,args') -> MLapp(f,Array.append args' args)
+    | _ -> MLapp(f,args)
+
+let empty_params = [||]
+
+let decompose_MLlam c =
+  match c with
+  | MLlam(ids,c) -> ids,c
+  | _ -> empty_params,c
+
+(*s Global declaration *)
+type global =
+(*  | Gtblname of gname * identifier array *)
+  | Gtblnorm of gname * lname array * mllambda array 
+  | Gtblfixtype of gname * lname array * mllambda array
+  | Glet of gname * mllambda
+  | Gletcase of 
+      gname * lname array * annot_sw * mllambda * mllambda * mllam_branches
+  | Gopen of string
+  | Gtype of inductive * int array
+    (* ind name, arities of constructors *)
+  | Gcomment of string
+
+(* Alpha-equivalence on globals *)
+let eq_global g1 g2 =
+  match g1, g2 with
+  | Gtblnorm (gn1,lns1,mls1), Gtblnorm (gn2,lns2,mls2)
+  | Gtblfixtype (gn1,lns1,mls1), Gtblfixtype (gn2,lns2,mls2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      Int.equal (Array.length mls1) (Array.length mls2) &&
+      let env1 = push_lnames 0 LNmap.empty lns1 in
+      let env2 = push_lnames 0 LNmap.empty lns2 in
+      Array.for_all2 (eq_mllambda gn1 gn2 (Array.length lns1) env1 env2) mls1 mls2
+  | Glet (gn1, def1), Glet (gn2, def2) ->
+      eq_mllambda gn1 gn2 0 LNmap.empty LNmap.empty def1 def2
+  | Gletcase (gn1,lns1,annot1,c1,accu1,br1),
+      Gletcase (gn2,lns2,annot2,c2,accu2,br2) ->
+      Int.equal (Array.length lns1) (Array.length lns2) &&
+      let env1 = push_lnames 0 LNmap.empty lns1 in
+      let env2 = push_lnames 0 LNmap.empty lns2 in
+      let t1 = MLmatch (annot1,c1,accu1,br1) in
+      let t2 = MLmatch (annot2,c2,accu2,br2) in
+      eq_mllambda gn1 gn2 (Array.length lns1) env1 env2 t1 t2
+  | Gopen s1, Gopen s2 -> String.equal s1 s2
+  | Gtype (ind1, arr1), Gtype (ind2, arr2) ->
+      eq_ind ind1 ind2 && Array.equal Int.equal arr1 arr2
+  | Gcomment s1, Gcomment s2 -> String.equal s1 s2
+  | _, _ -> false
+
+let hash_global g =
+  match g with
+  | Gtblnorm (gn,lns,mls) ->
+      let nlns = Array.length lns in
+      let nmls = Array.length mls in
+      let env = push_lnames 0 LNmap.empty lns in
+      let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in
+      combinesmall 1 hmls
+  | Gtblfixtype (gn,lns,mls) ->
+      let nlns = Array.length lns in
+      let nmls = Array.length mls in
+      let env = push_lnames 0 LNmap.empty lns in
+      let hmls = hash_mllambda_array gn nlns env (combine nlns nmls) mls in
+      combinesmall 2 hmls
+  | Glet (gn, def) ->
+      combinesmall 3 (hash_mllambda gn 0 LNmap.empty def)
+  | Gletcase (gn,lns,annot,c,accu,br) ->
+      let nlns = Array.length lns in
+      let env = push_lnames 0 LNmap.empty lns in
+      let t = MLmatch (annot,c,accu,br) in
+      combinesmall 4 (combine nlns (hash_mllambda gn nlns env t))
+  | Gopen s -> combinesmall 5 (String.hash s)
+  | Gtype (ind, arr) ->
+      combinesmall 6 (combine (ind_hash ind) (Array.fold_left combine 0 arr))
+  | Gcomment s -> combinesmall 7 (String.hash s)
+  
+let global_stack = ref ([] : global list)
+
+module HashedTypeGlobal = struct
+  type t = global
+  let equal = eq_global
+  let hash = hash_global
+end
+
+module HashtblGlobal = Hashtbl.Make(HashedTypeGlobal)
+
+let global_tbl = HashtblGlobal.create 19991
+
+let clear_global_tbl () = HashtblGlobal.clear global_tbl
+
+let push_global gn t =
+  try HashtblGlobal.find global_tbl t
+  with Not_found ->
+    (global_stack := t :: !global_stack;
+    HashtblGlobal.add global_tbl t gn; gn)
+
+let push_global_let gn body =
+  push_global gn (Glet (gn,body))
+
+let push_global_fixtype gn params body =
+  push_global gn (Gtblfixtype (gn,params,body))
+
+let push_global_norm gn params body =
+  push_global gn (Gtblnorm (gn, params, body))
+
+let push_global_case gn params annot a accu bs =
+  push_global gn (Gletcase (gn, params, annot, a, accu, bs))
+
+(*s Compilation environment *)
+
+type env =
+    { env_rel : mllambda list; (* (MLlocal lname) list *)
+      env_bound : int; (* length of env_rel *)
+      (* free variables *)
+      env_urel : (int * mllambda) list ref; (* list of unbound rel *)
+      env_named : (identifier * mllambda) list ref;
+      env_univ : lname option}
+
+let empty_env univ () =
+  { env_rel = [];
+    env_bound = 0;
+    env_urel = ref [];
+    env_named = ref [];
+    env_univ = univ
+  }
+
+let push_rel env id = 
+  let local = fresh_lname id in
+  local, { env with 
+	   env_rel = MLlocal local :: env.env_rel;
+	   env_bound = env.env_bound + 1
+	 }
+
+let push_rels env ids =
+  let lnames, env_rel = 
+    Array.fold_left (fun (names,env_rel) id ->
+      let local = fresh_lname id in
+      (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in
+  Array.of_list (List.rev lnames), { env with 
+			  env_rel = env_rel;
+			  env_bound = env.env_bound + Array.length ids
+			}
+
+let get_rel env id i =
+  if i <= env.env_bound then
+    List.nth env.env_rel (i-1)
+  else 
+    let i = i - env.env_bound in
+    try Int.List.assoc i !(env.env_urel)
+    with Not_found ->
+      let local = MLlocal (fresh_lname id) in
+      env.env_urel := (i,local) :: !(env.env_urel);
+      local
+
+let get_var env id =
+  try Id.List.assoc id !(env.env_named)
+  with Not_found ->
+    let local = MLlocal (fresh_lname (Name id)) in
+    env.env_named := (id, local)::!(env.env_named);
+    local
+
+let fresh_univ () =
+  fresh_lname (Name (Id.of_string "univ"))
+
+(*s Traduction of lambda to mllambda *)
+
+let get_prod_name codom = 
+  match codom with
+  | MLlam(ids,_) -> ids.(0).lname
+  | _ -> assert false
+
+let get_lname (_,l) = 
+  match l with
+  | MLlocal id -> id
+  | _ -> invalid_arg "Nativecode.get_lname"
+
+(* Collects free variables from env in an array of local names *)
+let fv_params env = 
+  let fvn, fvr = !(env.env_named), !(env.env_urel) in 
+  let size = List.length fvn + List.length fvr in
+  let start,params = match env.env_univ with
+    | None -> 0, Array.make size dummy_lname
+    | Some u -> 1, let t = Array.make (size + 1) dummy_lname in t.(0) <- u; t
+  in
+  if Array.is_empty params then empty_params
+  else begin
+    let fvn = ref fvn in
+    let i = ref start in
+    while not (List.is_empty !fvn) do
+      params.(!i) <- get_lname (List.hd !fvn);
+      fvn := List.tl !fvn;
+      incr i
+    done;
+    let fvr = ref fvr in
+    while not (List.is_empty !fvr) do
+      params.(!i) <- get_lname (List.hd !fvr);
+      fvr := List.tl !fvr;
+      incr i
+    done;
+    params
+  end
+
+let generalize_fv env body = 
+  mkMLlam (fv_params env) body
+
+let empty_args = [||]
+
+let fv_args env fvn fvr =
+  let size = List.length fvn + List.length fvr in
+  let start,args = match env.env_univ with
+    | None -> 0, Array.make size (MLint 0)
+    | Some u -> 1, let t = Array.make (size + 1) (MLint 0) in t.(0) <- MLlocal u; t
+  in
+  if Array.is_empty args then empty_args
+  else 
+    begin
+      let fvn = ref fvn in
+      let i = ref start in
+      while not (List.is_empty !fvn) do
+	args.(!i) <- get_var env (fst (List.hd !fvn));
+	fvn := List.tl !fvn;
+	incr i
+      done;
+      let fvr = ref fvr in
+      while not (List.is_empty !fvr) do
+	let (k,_ as kml) = List.hd !fvr in
+	let n = get_lname kml in 
+	args.(!i) <- get_rel env n.lname k;
+	fvr := List.tl !fvr;
+	incr i
+      done;
+      args
+    end
+
+let get_value_code i =
+  MLapp (MLglobal (Ginternal "get_value"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_sort_code i =
+  MLapp (MLglobal (Ginternal "get_sort"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_name_code i =
+  MLapp (MLglobal (Ginternal "get_name"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_const_code i =
+  MLapp (MLglobal (Ginternal "get_const"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_match_code i =
+  MLapp (MLglobal (Ginternal "get_match"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_ind_code i =
+  MLapp (MLglobal (Ginternal "get_ind"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_meta_code i =
+  MLapp (MLglobal (Ginternal "get_meta"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_evar_code i =
+  MLapp (MLglobal (Ginternal "get_evar"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+let get_level_code i =
+  MLapp (MLglobal (Ginternal "get_level"),
+    [|MLglobal symbols_tbl_name; MLint i|])
+
+type rlist =
+  | Rnil 
+  | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' 
+and rlist' = rlist ref
+
+let rm_params fv params = 
+  Array.map (fun l -> if LNset.mem l fv then Some l else None) params 
+
+let rec insert cargs body rl =
+ match !rl with
+ | Rnil ->
+     let fv = fv_lam body in
+     let (c,params) = cargs in
+     let params = rm_params fv params in
+     rl:= Rcons(ref [(c,params)], fv, body, ref Rnil)
+ | Rcons(l,fv,body',rl) ->
+    (** ppedrot: It seems we only want to factorize common branches. It should
+        not matter to do so with a subapproximation by (==). *)
+     if body == body' then
+       let (c,params) = cargs in
+       let params = rm_params fv params in
+       l := (c,params)::!l
+     else insert cargs body rl
+
+let rec to_list rl =
+  match !rl with
+  | Rnil -> []
+  | Rcons(l,_,body,tl) -> (!l,body)::to_list tl
+
+let merge_branches t =
+  let newt = ref Rnil in
+  Array.iter (fun (c,args,body) -> insert (c,args) body newt) t;
+  Array.of_list (to_list newt)
+
+
+type prim_aux = 
+  | PAprim of string * constant * Primitives.t * prim_aux array
+  | PAml of mllambda
+
+let add_check cond args =
+  let aux cond a = 
+    match a with
+    | PAml(MLint _) -> cond
+    | PAml ml ->
+       (* FIXME: use explicit equality function *)
+       if List.mem ml cond then cond else ml::cond 
+    | _ -> cond
+  in
+  Array.fold_left aux cond args
+  
+let extract_prim ml_of l =
+  let decl = ref [] in
+  let cond = ref [] in
+  let rec aux l = 
+    match l with
+    | Lprim(prefix,kn,p,args) ->
+	let args = Array.map aux args in
+	cond := add_check !cond args;
+	PAprim(prefix,kn,p,args)
+    | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l)
+    | _ -> 
+	let x = fresh_lname Anonymous in
+	decl := (x,ml_of l)::!decl;
+	PAml (MLlocal x) in
+  let res = aux l in
+  (!decl, !cond, res)
+
+let app_prim p args = MLapp(MLprimitive p, args)
+
+let to_int v =
+  match v with
+  | MLapp(MLprimitive Mk_uint, t) ->
+     begin match t.(0) with
+     | MLuint i -> MLint (Uint31.to_int i)
+     | _ -> MLapp(MLprimitive Val_to_int, [|v|])
+     end
+  | MLapp(MLprimitive Mk_int, t) -> t.(0)
+  | _ -> MLapp(MLprimitive Val_to_int, [|v|]) 
+
+let of_int v = 
+  match v with
+  | MLapp(MLprimitive Val_to_int, t) -> t.(0)
+  | _ -> MLapp(MLprimitive Mk_int,[|v|]) 
+
+let compile_prim decl cond paux =
+(*
+  let args_to_int args = 
+    for i = 0 to Array.length args - 1 do
+      args.(i) <- to_int args.(i)
+    done;
+    args in
+ *)
+  let rec opt_prim_aux paux =
+    match paux with
+    | PAprim(prefix, kn, op, args) ->
+	let args = Array.map opt_prim_aux args in
+	app_prim (Coq_primitive(op,None)) args
+(*
+    TODO: check if this inling was useful
+	begin match op with
+        | Int31lt -> 
+           if Sys.word_size = 64 then
+             app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|]
+           else app_prim (Coq_primitive (Primitives.Int31lt,None)) args
+        | Int31le ->
+           if Sys.word_size = 64 then
+             app_prim Mk_bool [|(app_prim MLle (args_to_int args))|]
+           else app_prim (Coq_primitive (Primitives.Int31le, None)) args
+	| Int31lsl  -> of_int (mk_lsl (args_to_int args))
+	| Int31lsr  -> of_int (mk_lsr (args_to_int args))
+	| Int31land -> of_int (mk_land (args_to_int args))
+	| Int31lor  -> of_int (mk_lor (args_to_int args))
+	| Int31lxor -> of_int (mk_lxor (args_to_int args))
+	| Int31add  -> of_int (mk_add (args_to_int args))
+	| Int31sub  -> of_int (mk_sub (args_to_int args))
+	| Int31mul  -> of_int (mk_mul (args_to_int args))
+	| _ -> app_prim (Coq_primitive(op,None)) args
+	end *)
+    | PAml ml -> ml 
+  and naive_prim_aux paux = 
+    match paux with
+    | PAprim(prefix, kn, op, args) ->
+        app_prim (Coq_primitive(op, Some (prefix, kn))) (Array.map naive_prim_aux args)
+    | PAml ml -> ml in
+
+  let compile_cond cond paux = 
+    match cond with
+    | [] -> opt_prim_aux paux 
+    | [c1] ->
+        MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) 
+    | c1::cond ->
+	let cond = 
+	  List.fold_left 
+	    (fun ml c -> app_prim MLland [| ml; to_int c|])
+            (app_prim MLland [|to_int c1; MLint 0 |]) cond in
+        let cond = app_prim MLmagic [|cond|] in
+	MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in
+  let add_decl decl body =
+    List.fold_left (fun body (x,d) -> MLlet(x,d,body)) body decl in
+  add_decl decl (compile_cond cond paux)
+
+let ml_of_instance instance u =
+  let ml_of_level l =
+    match Univ.Level.var_index l with
+    | Some i ->
+       let univ = MLapp(MLprimitive MLmagic, [|MLlocal (Option.get instance)|]) in
+       mkMLapp (MLprimitive MLarrayget) [|univ; MLint i|]
+    | None -> let i = push_symbol (SymbLevel l) in get_level_code i
+  in
+  let u = Univ.Instance.to_array u in
+  if Array.is_empty u then [||]
+  else let u = Array.map ml_of_level u in
+       [|MLapp (MLprimitive MLmagic, [|MLarray u|])|]
+
+ let rec ml_of_lam env l t =
+  match t with
+  | Lrel(id ,i) -> get_rel env id i
+  | Lvar id -> get_var env id
+  | Lmeta(mv,ty) ->
+     let tyn = fresh_lname Anonymous in
+     let i = push_symbol (SymbMeta mv) in
+     MLapp(MLprimitive Mk_meta, [|get_meta_code i; MLlocal tyn|])
+  | Levar(ev,ty) ->
+     let tyn = fresh_lname Anonymous in
+     let i = push_symbol (SymbEvar ev) in
+     MLlet(tyn, ml_of_lam env l ty,
+       MLapp(MLprimitive Mk_evar, [|get_evar_code i;MLlocal tyn|]))
+  | Lprod(dom,codom) ->
+      let dom = ml_of_lam env l dom in
+      let codom = ml_of_lam env l codom in
+      let n = get_prod_name codom in
+      let i = push_symbol (SymbName n) in
+      MLapp(MLprimitive Mk_prod, [|get_name_code i;dom;codom|])
+  | Llam(ids,body) ->
+    let lnames,env = push_rels env ids in
+    MLlam(lnames, ml_of_lam env l body)
+  | Llet(id,def,body) ->
+      let def = ml_of_lam env l def in
+      let lname, env = push_rel env id in
+      let body = ml_of_lam env l body in
+      MLlet(lname,def,body)
+  | Lapp(f,args) ->
+      MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args)
+  | Lconst (prefix,c) ->
+     let args = ml_of_instance env.env_univ (snd c) in
+     mkMLapp (MLglobal(Gconstant (prefix,c))) args
+  | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c))
+  | Lprim _ ->
+      let decl,cond,paux = extract_prim (ml_of_lam env l) t in
+      compile_prim decl cond paux
+  | Lcase (annot,p,a,bs) ->
+      (* let predicate_uid fv_pred = compilation of p 
+         let rec case_uid fv a_uid = 
+           match a_uid with
+           | Accu _ => mk_sw (predicate_uid fv_pred) (case_uid fv) a_uid
+           | Ci argsi => compilation of branches 
+         compile case = case_uid fv (compilation of a) *)
+      (* Compilation of the predicate *)
+         (* Remark: if we do not want to compile the predicate we 
+            should a least compute the fv, then store the lambda representation
+            of the predicate (not the mllambda) *)
+      let env_p = empty_env env.env_univ () in
+      let pn = fresh_gpred l in
+      let mlp = ml_of_lam env_p l p in
+      let mlp = generalize_fv env_p mlp in
+      let (pfvn,pfvr) = !(env_p.env_named), !(env_p.env_urel) in
+      let pn = push_global_let pn mlp in
+      (* Compilation of the case *)
+      let env_c = empty_env env.env_univ () in
+      let a_uid = fresh_lname Anonymous in
+      let la_uid = MLlocal a_uid in
+      (* compilation of branches *)
+      let ml_br (c,params, body) = 
+	let lnames, env_c = push_rels env_c params in
+	(c, lnames, ml_of_lam env_c l body)
+      in
+      let bs = Array.map ml_br bs in
+      let cn = fresh_gcase l in
+      (* Compilation of accu branch *)
+      let pred = MLapp(MLglobal pn, fv_args env_c pfvn pfvr) in  
+      let (fvn, fvr) = !(env_c.env_named), !(env_c.env_urel) in
+      let cn_fv = mkMLapp (MLglobal cn) (fv_args env_c fvn fvr) in
+         (* remark : the call to fv_args does not add free variables in env_c *)
+      let i = push_symbol (SymbMatch annot) in
+      let accu =
+	MLapp(MLprimitive Mk_sw,
+	      [| get_match_code i; MLapp (MLprimitive Cast_accu, [|la_uid|]);
+		 pred;
+		 cn_fv |]) in
+(*      let body = MLlam([|a_uid|], MLmatch(annot, la_uid, accu, bs)) in
+      let case = generalize_fv env_c body in *)
+      let cn = push_global_case cn (Array.append (fv_params env_c) [|a_uid|])
+        annot la_uid accu (merge_branches bs)
+      in
+      (* Final result *)
+      let arg = ml_of_lam env l a in
+      let force =
+	if annot.asw_finite then arg
+	else MLapp(MLprimitive Force_cofix, [|arg|]) in
+      mkMLapp (MLapp (MLglobal cn, fv_args env fvn fvr)) [|force|]
+  | Lif(t,bt,bf) -> 
+      MLif(ml_of_lam env l t, ml_of_lam env l bt, ml_of_lam env l bf)
+  | Lfix ((rec_pos,start), (ids, tt, tb)) ->
+      (* let type_f fvt = [| type fix |] 
+         let norm_f1 fv f1 .. fn params1 = body1
+	 ..
+         let norm_fn fv f1 .. fn paramsn = bodyn
+         let norm fv f1 .. fn = 
+	    [|norm_f1 fv f1 .. fn; ..; norm_fn fv f1 .. fn|]
+         compile fix = 
+	   let rec f1 params1 = 
+             if is_accu rec_pos.(1) then mk_fix (type_f fvt) (norm fv) params1
+	     else norm_f1 fv f1 .. fn params1
+           and .. and fn paramsn = 
+	     if is_accu rec_pos.(n) then mk_fix (type_f fvt) (norm fv) paramsn
+             else norm_fn fv f1 .. fv paramsn in
+	   start
+      *)
+      (* Compilation of type *)
+      let env_t = empty_env env.env_univ () in
+      let ml_t = Array.map (ml_of_lam env_t l) tt in
+      let params_t = fv_params env_t in
+      let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in
+      let gft = fresh_gfixtype l in
+      let gft = push_global_fixtype gft params_t ml_t in
+      let mk_type = MLapp(MLglobal gft, args_t) in
+      (* Compilation of norm_i *)
+      let ndef = Array.length ids in
+      let lf,env_n = push_rels (empty_env env.env_univ ()) ids in
+      let t_params = Array.make ndef [||] in
+      let t_norm_f = Array.make ndef (Gnorm (l,-1)) in
+      let mk_let envi (id,def) t = MLlet (id,def,t) in
+      let mk_lam_or_let (params,lets,env) (id,def) =
+        let ln,env' = push_rel env id in
+        match def with
+        | None -> (ln::params,lets,env')
+        | Some lam -> (params, (ln,ml_of_lam env l lam)::lets,env')
+      in
+      let ml_of_fix i body =
+        let varsi, bodyi = decompose_Llam_Llet body in
+        let paramsi,letsi,envi = 
+          Array.fold_left mk_lam_or_let ([],[],env_n) varsi
+        in
+        let paramsi,letsi =
+          Array.of_list (List.rev paramsi), Array.of_list (List.rev letsi)
+        in
+        t_norm_f.(i) <- fresh_gnorm l;
+        let bodyi = ml_of_lam envi l bodyi in
+        t_params.(i) <- paramsi;
+        let bodyi = Array.fold_right (mk_let envi) letsi bodyi in
+        mkMLlam paramsi bodyi
+      in
+      let tnorm = Array.mapi ml_of_fix tb in
+      let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in
+      let fv_params = fv_params env_n in
+      let fv_args' = Array.map (fun id -> MLlocal id) fv_params in
+      let norm_params = Array.append fv_params lf in
+      let t_norm_f = Array.mapi (fun i body ->
+	push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in
+      let norm = fresh_gnormtbl l in
+      let norm = push_global_norm norm fv_params 
+         (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in
+      (* Compilation of fix *)
+      let fv_args = fv_args env fvn fvr in      
+      let lf, env = push_rels env ids in
+      let lf_args = Array.map (fun id -> MLlocal id) lf in
+      let mk_norm = MLapp(MLglobal norm, fv_args) in
+      let mkrec i lname = 
+	let paramsi = t_params.(i) in
+	let reci = MLlocal (paramsi.(rec_pos.(i))) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let body = 
+	  MLif(MLapp(MLprimitive Is_accu,[|reci|]),
+	       mkMLapp 
+		 (MLapp(MLprimitive (Mk_fix(rec_pos,i)), 
+			[|mk_type; mk_norm|]))
+		 pargsi,
+	       MLapp(MLglobal t_norm_f.(i), 
+		     Array.concat [fv_args;lf_args;pargsi])) 
+	in
+	(lname, paramsi, body) in
+      MLletrec(Array.mapi mkrec lf, lf_args.(start))
+  | Lcofix (start, (ids, tt, tb)) -> 
+      (* Compilation of type *)
+      let env_t = empty_env env.env_univ () in
+      let ml_t = Array.map (ml_of_lam env_t l) tt in
+      let params_t = fv_params env_t in
+      let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in
+      let gft = fresh_gfixtype l in
+      let gft = push_global_fixtype gft params_t ml_t in
+      let mk_type = MLapp(MLglobal gft, args_t) in
+      (* Compilation of norm_i *) 
+      let ndef = Array.length ids in
+      let lf,env_n = push_rels (empty_env env.env_univ ()) ids in
+      let t_params = Array.make ndef [||] in
+      let t_norm_f = Array.make ndef (Gnorm (l,-1)) in
+      let ml_of_fix i body =
+        let idsi,bodyi = decompose_Llam body in
+        let paramsi, envi = push_rels env_n idsi in
+        t_norm_f.(i) <- fresh_gnorm l;
+        let bodyi = ml_of_lam envi l bodyi in
+        t_params.(i) <- paramsi;
+        mkMLlam paramsi bodyi in
+      let tnorm = Array.mapi ml_of_fix tb in
+      let fvn,fvr = !(env_n.env_named), !(env_n.env_urel) in
+      let fv_params = fv_params env_n in
+      let fv_args' = Array.map (fun id -> MLlocal id) fv_params in
+      let norm_params = Array.append fv_params lf in
+      let t_norm_f = Array.mapi (fun i body ->
+	push_global_let (t_norm_f.(i)) (mkMLlam norm_params body)) tnorm in
+      let norm = fresh_gnormtbl l in
+      let norm = push_global_norm norm fv_params
+        (Array.map (fun g -> mkMLapp (MLglobal g) fv_args') t_norm_f) in
+      (* Compilation of fix *)
+      let fv_args = fv_args env fvn fvr in      
+      let mk_norm = MLapp(MLglobal norm, fv_args) in
+      let lnorm = fresh_lname Anonymous in
+      let ltype = fresh_lname Anonymous in
+      let lf, env = push_rels env ids in
+      let lf_args = Array.map (fun id -> MLlocal id) lf in
+      let upd i lname cont =
+	let paramsi = t_params.(i) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let uniti = fresh_lname Anonymous in
+	let body =
+	  MLlam(Array.append paramsi [|uniti|],
+		MLapp(MLglobal t_norm_f.(i),
+		      Array.concat [fv_args;lf_args;pargsi])) in
+	MLsequence(MLapp(MLprimitive Upd_cofix, [|lf_args.(i);body|]),
+		   cont) in
+      let upd = Array.fold_right_i upd lf lf_args.(start) in
+      let mk_let i lname cont =
+	MLlet(lname,
+	      MLapp(MLprimitive(Mk_cofix i),[| MLlocal ltype; MLlocal lnorm|]),
+	      cont) in
+      let init = Array.fold_right_i mk_let lf upd in 
+      MLlet(lnorm, mk_norm, MLlet(ltype, mk_type, init))
+  (*    	    
+      let mkrec i lname = 
+	let paramsi = t_params.(i) in
+	let pargsi = Array.map (fun id -> MLlocal id) paramsi in
+	let uniti = fresh_lname Anonymous in
+	let body = 
+	  MLapp( MLprimitive(Mk_cofix i),
+		 [|mk_type;mk_norm; 
+		   MLlam([|uniti|],
+			 MLapp(MLglobal t_norm_f.(i),
+			       Array.concat [fv_args;lf_args;pargsi]))|]) in
+	(lname, paramsi, body) in
+      MLletrec(Array.mapi mkrec lf, lf_args.(start)) *)
+
+  | Lmakeblock (prefix,(cn,u),_,args) ->
+     let args = Array.map (ml_of_lam env l) args in
+     MLconstruct(prefix,cn,args)
+  | Lconstruct (prefix, (cn,u)) ->
+     let uargs = ml_of_instance env.env_univ u in
+      mkMLapp (MLglobal (Gconstruct (prefix, (cn,u)))) uargs
+  | Luint v ->
+     (match v with
+     | UintVal i -> MLapp(MLprimitive Mk_uint, [|MLuint i|])
+     | UintDigits (prefix,cn,ds) ->
+	let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in
+	let ds = Array.map (ml_of_lam env l) ds in
+	let i31 = MLapp (MLprimitive Mk_I31_accu, [|c|]) in
+	MLapp(i31, ds)
+     | UintDecomp (prefix,cn,t) ->
+	let c = MLglobal (Gconstruct (prefix, (cn, Univ.Instance.empty))) in
+	let t = ml_of_lam env l t in
+	MLapp (MLprimitive Decomp_uint, [|c;t|]))
+  | Lval v ->
+      let i = push_symbol (SymbValue v) in get_value_code i
+  | Lsort s ->
+    let i = push_symbol (SymbSort s) in
+    let uarg = match env.env_univ with
+      | None -> MLarray [||]
+      | Some u -> MLlocal u
+    in
+    let uarg = MLapp(MLprimitive MLmagic, [|uarg|]) in
+    MLapp(MLprimitive Mk_sort, [|get_sort_code i; uarg|])
+  | Lind (prefix, pind) ->
+     let uargs = ml_of_instance env.env_univ (snd pind) in
+     mkMLapp (MLglobal (Gind (prefix, pind))) uargs
+  | Llazy -> MLglobal (Ginternal "lazy")
+  | Lforce -> MLglobal (Ginternal "Lazy.force")
+
+let mllambda_of_lambda univ auxdefs l t =
+  let env = empty_env univ () in
+  global_stack := auxdefs;
+  let ml = ml_of_lam env l t in
+  let fv_rel = !(env.env_urel) in
+  let fv_named = !(env.env_named) in
+  (* build the free variables *)
+  let get_lname (_,t) = 
+   match t with
+   | MLlocal x -> x
+   | _ -> assert false in
+  let params = 
+    List.append (List.map get_lname fv_rel) (List.map get_lname fv_named) in
+  if List.is_empty params then
+    (!global_stack, ([],[]), ml)
+  (* final result : global list, fv, ml *)
+  else
+    (!global_stack, (fv_named, fv_rel), mkMLlam (Array.of_list params) ml)
+
+(** Code optimization **)
+
+(** Optimization of match and fix *)
+
+let can_subst l = 
+  match l with
+  | MLlocal _ | MLint _ | MLuint _ | MLglobal _ -> true
+  | _ -> false
+
+let subst s l =
+  if LNmap.is_empty s then l 
+  else
+    let rec aux l =
+      match l with
+      | MLlocal id -> (try LNmap.find id s with Not_found -> l)
+      | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l
+      | MLlam(params,body) -> MLlam(params, aux body)
+      | MLletrec(defs,body) ->
+	let arec (f,params,body) = (f,params,aux body) in
+	MLletrec(Array.map arec defs, aux body)
+      | MLlet(id,def,body) -> MLlet(id,aux def, aux body)
+      | MLapp(f,args) -> MLapp(aux f, Array.map aux args)
+      | MLif(t,b1,b2) -> MLif(aux t, aux b1, aux b2)
+      | MLmatch(annot,a,accu,bs) ->
+	  let auxb (cargs,body) = (cargs,aux body) in
+	  MLmatch(annot,a,aux accu, Array.map auxb bs)
+      | MLconstruct(prefix,c,args) -> MLconstruct(prefix,c,Array.map aux args)
+      | MLsetref(s,l1) -> MLsetref(s,aux l1) 
+      | MLsequence(l1,l2) -> MLsequence(aux l1, aux l2)
+      | MLarray arr -> MLarray (Array.map aux arr)
+    in
+    aux l
+
+let add_subst id v s =
+  match v with
+  | MLlocal id' when Int.equal id.luid id'.luid -> s
+  | _ -> LNmap.add id v s
+
+let subst_norm params args s =
+  let len = Array.length params in
+  assert (Int.equal (Array.length args) len && Array.for_all can_subst args);
+  let s = ref s in
+  for i = 0 to len - 1 do
+    s := add_subst params.(i) args.(i) !s
+  done;
+  !s
+
+let subst_case params args s =
+  let len = Array.length params in
+  assert (len > 0 && 
+	  Int.equal (Array.length args) len && 
+	  let r = ref true and i = ref 0 in
+	  (* we test all arguments excepted the last *)
+	  while !i < len - 1  && !r do r := can_subst args.(!i); incr i done;
+	  !r);
+  let s = ref s in
+  for i = 0 to len - 2 do
+    s := add_subst params.(i) args.(i) !s
+  done;
+  !s, params.(len-1), args.(len-1)
+    
+let empty_gdef = Int.Map.empty, Int.Map.empty
+let get_norm (gnorm, _) i = Int.Map.find i gnorm
+let get_case (_, gcase) i = Int.Map.find i gcase
+
+let all_lam n bs = 
+  let f (_, l) = 
+    match l with
+    | MLlam(params, _) -> Int.equal (Array.length params) n
+    | _ -> false in
+  Array.for_all f bs
+
+let commutative_cut annot a accu bs args =
+  let mkb (c,b) =
+     match b with
+     | MLlam(params, body) -> 
+         (c, Array.fold_left2 (fun body x v -> MLlet(x,v,body)) body params args)
+     | _ -> assert false in
+  MLmatch(annot, a, mkMLapp accu args, Array.map mkb bs)
+
+let optimize gdef l =   
+  let rec optimize s l =
+    match l with
+    | MLlocal id -> (try LNmap.find id s with Not_found -> l)
+    | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l
+    | MLlam(params,body) -> 
+	MLlam(params, optimize s body)
+    | MLletrec(decls,body) ->
+	let opt_rec (f,params,body) = (f,params,optimize s body ) in 
+	MLletrec(Array.map opt_rec decls, optimize s body)
+    | MLlet(id,def,body) ->
+	let def = optimize s def in
+	if can_subst def then optimize (add_subst id def s) body 
+	else MLlet(id,def,optimize s body)
+    | MLapp(f, args) ->
+	let args = Array.map (optimize s) args in
+	begin match f with
+	| MLglobal (Gnorm (_,i)) ->
+	    (try
+	      let params,body = get_norm gdef i in
+	      let s = subst_norm params args s in
+	      optimize s body	    
+	    with Not_found -> MLapp(optimize s f, args))
+	| MLglobal (Gcase (_,i)) ->
+	    (try 
+	      let params,body = get_case gdef i in
+	      let s, id, arg = subst_case params args s in
+	      if can_subst arg then optimize (add_subst id arg s) body
+	      else MLlet(id, arg, optimize s body)
+	    with Not_found ->  MLapp(optimize s f, args))
+	| _ -> 
+            let f = optimize s f in
+            match f with
+            | MLmatch (annot,a,accu,bs) ->
+              if all_lam (Array.length args) bs then  
+                commutative_cut annot a accu bs args 
+              else MLapp(f, args)
+            | _ -> MLapp(f, args)
+
+	end
+    | MLif(t,b1,b2) ->
+	let t = optimize s t in
+	let b1 = optimize s b1 in
+	let b2 = optimize s b2 in
+	begin match t, b2 with
+	| MLapp(MLprimitive Is_accu,[| l1 |]), MLmatch(annot, l2, _, bs)
+	    when l1 == l2 -> MLmatch(annot, l1, b1, bs) (** approximation *)
+        | _, _ -> MLif(t, b1, b2)
+	end
+    | MLmatch(annot,a,accu,bs) ->
+	let opt_b (cargs,body) = (cargs,optimize s body) in
+	MLmatch(annot, optimize s a, subst s accu, Array.map opt_b bs)
+    | MLconstruct(prefix,c,args) ->
+        MLconstruct(prefix,c,Array.map (optimize s) args)
+    | MLsetref(r,l) -> MLsetref(r, optimize s l) 
+    | MLsequence(l1,l2) -> MLsequence(optimize s l1, optimize s l2)
+    | MLarray arr -> MLarray (Array.map (optimize s) arr)
+  in
+  optimize LNmap.empty l
+
+let optimize_stk stk =
+  let add_global gdef g =
+    match g with
+    | Glet (Gnorm (_,i), body) ->
+	let (gnorm, gcase) = gdef in
+	(Int.Map.add i (decompose_MLlam body) gnorm, gcase)
+    | Gletcase(Gcase (_,i), params, annot,a,accu,bs) ->
+	let (gnorm,gcase) = gdef in
+	(gnorm, Int.Map.add i (params,MLmatch(annot,a,accu,bs)) gcase)
+    | Gletcase _ -> assert false
+    | _ -> gdef in
+  let gdef = List.fold_left add_global empty_gdef stk in
+  let optimize_global g = 
+    match g with
+    | Glet(Gconstant (prefix, c), body) ->
+        Glet(Gconstant (prefix, c), optimize gdef body)
+    | _ -> g in
+  List.map optimize_global stk
+
+(** Printing to ocaml **)
+(* Redefine a bunch of functions in module Names to generate names
+   acceptable to OCaml. *)
+let string_of_id s = Unicode.ascii_of_ident (string_of_id s)
+let string_of_label l = Unicode.ascii_of_ident (string_of_label l)
+
+let string_of_dirpath = function
+  | [] -> "_"
+  | sl -> String.concat "_" (List.rev_map string_of_id sl)
+
+(* The first letter of the file name has to be a capital to be accepted by *)
+(* OCaml as a module identifier.                                           *)
+let string_of_dirpath s = "N"^string_of_dirpath s
+
+let mod_uid_of_dirpath dir = string_of_dirpath (repr_dirpath dir)
+
+let link_info_of_dirpath dir =
+  Linked (mod_uid_of_dirpath dir ^ ".")
+
+let string_of_name x =
+  match x with
+    | Anonymous -> "anonymous" (* assert false *)
+    | Name id -> string_of_id id
+
+let string_of_label_def l =
+  match l with
+    | None -> ""
+    | Some l -> string_of_label l
+
+(* Relativization of module paths *)
+let rec list_of_mp acc = function
+  | MPdot (mp,l) -> list_of_mp (string_of_label l::acc) mp
+  | MPfile dp ->
+      let dp = repr_dirpath dp in
+      string_of_dirpath dp :: acc
+  | MPbound mbid -> ("X"^string_of_id (id_of_mbid mbid))::acc
+
+let list_of_mp mp = list_of_mp [] mp
+
+let string_of_kn kn =
+  let (mp,dp,l) = repr_kn kn in
+  let mp = list_of_mp mp in
+  String.concat "_" mp ^ "_" ^ string_of_label l
+
+let string_of_con c = string_of_kn (user_con c)
+let string_of_mind mind = string_of_kn (user_mind mind)
+
+let string_of_gname g =
+  match g with
+  | Gind (prefix, ((mind,i), _)) ->
+      Format.sprintf "%sindaccu_%s_%i" prefix (string_of_mind mind) i
+  | Gconstruct (prefix, (((mind, i), j), _)) ->
+      Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1)
+  | Gconstant (prefix, (c,_)) ->
+      Format.sprintf "%sconst_%s" prefix (string_of_con c)
+  | Gproj (prefix, c) ->
+      Format.sprintf "%sproj_%s" prefix (string_of_con c)
+  | Gcase (l,i) ->
+      Format.sprintf "case_%s_%i" (string_of_label_def l) i
+  | Gpred (l,i) ->
+      Format.sprintf "pred_%s_%i" (string_of_label_def l) i
+  | Gfixtype (l,i) ->
+      Format.sprintf "fixtype_%s_%i" (string_of_label_def l) i
+  | Gnorm (l,i) ->
+      Format.sprintf "norm_%s_%i" (string_of_label_def l) i
+  | Ginternal s -> Format.sprintf "%s" s
+  | Gnormtbl (l,i) -> 
+      Format.sprintf "normtbl_%s_%i" (string_of_label_def l) i
+  | Grel i ->
+      Format.sprintf "rel_%i" i
+  | Gnamed id ->
+      Format.sprintf "named_%s" (string_of_id id)
+
+let pp_gname fmt g =
+  Format.fprintf fmt "%s" (string_of_gname g)
+
+let pp_lname fmt ln =
+  let s = Unicode.ascii_of_ident (string_of_name ln.lname) in
+  Format.fprintf fmt "x_%s_%i" s ln.luid
+
+let pp_ldecls fmt ids =
+  let len = Array.length ids in
+  for i = 0 to len - 1 do
+    Format.fprintf fmt " (%a : Nativevalues.t)" pp_lname ids.(i)
+  done
+
+let string_of_construct prefix ((mind,i),j) =
+  let id = Format.sprintf "Construct_%s_%i_%i" (string_of_mind mind) i (j-1) in
+  prefix ^ id
+   
+let pp_int fmt i =
+  if i < 0 then Format.fprintf fmt "(%i)" i else Format.fprintf fmt "%i" i
+
+let pp_mllam fmt l =
+
+  let rec pp_mllam fmt l =
+    match l with
+    | MLlocal ln -> Format.fprintf fmt "@[%a@]" pp_lname ln
+    | MLglobal g -> Format.fprintf fmt "@[%a@]" pp_gname g
+    | MLprimitive p -> Format.fprintf fmt "@[%a@]" pp_primitive p
+    | MLlam(ids,body) ->
+	Format.fprintf fmt "@[(fun%a@ ->@\n %a)@]"
+	  pp_ldecls ids pp_mllam body
+    | MLletrec(defs, body) ->
+	Format.fprintf fmt "@[%a@ in@\n%a@]" pp_letrec defs 
+	  pp_mllam body
+    | MLlet(id,def,body) ->
+	Format.fprintf fmt "@[(let@ %a@ =@\n %a@ in@\n%a)@]"
+          pp_lname id pp_mllam def pp_mllam body
+    | MLapp(f, args) ->
+	Format.fprintf fmt "@[%a@ %a@]" pp_mllam f (pp_args true) args
+    | MLif(t,l1,l2) ->
+	Format.fprintf fmt "@[(if %a then@\n  %a@\nelse@\n  %a)@]"
+	  pp_mllam t pp_mllam l1 pp_mllam l2 
+    | MLmatch (annot, c, accu_br, br) ->
+	  let mind,i = annot.asw_ind in
+      let prefix = annot.asw_prefix in
+	  let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in
+	  Format.fprintf fmt 
+	    "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n  %a@\n%aend@]"
+	  pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br
+	  
+    | MLconstruct(prefix,c,args) ->
+        Format.fprintf fmt "@[(Obj.magic (%s%a) : Nativevalues.t)@]" 
+          (string_of_construct prefix c) pp_cargs args
+    | MLint i -> pp_int fmt i
+    | MLuint i -> Format.fprintf fmt "(Uint31.of_int %a)" pp_int (Uint31.to_int i)
+    | MLsetref (s, body) ->
+	Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body
+    | MLsequence(l1,l2) ->
+	Format.fprintf fmt "@[%a;@\n%a@]" pp_mllam l1 pp_mllam l2
+    | MLarray arr ->
+       let len = Array.length arr in
+       Format.fprintf fmt "@[[|";
+       if 0 < len then begin
+	 for i = 0 to len - 2 do
+           Format.fprintf fmt "%a;" pp_mllam arr.(i)
+	 done;
+         pp_mllam fmt arr.(len-1)
+       end;
+       Format.fprintf fmt "|]@]"
+
+
+  and pp_letrec fmt defs =
+    let len = Array.length defs in
+    let pp_one_rec i (fn, argsn, body) =
+      Format.fprintf fmt "%a%a =@\n  %a"
+	pp_lname fn 
+	pp_ldecls argsn pp_mllam body in
+    Format.fprintf fmt "@[let rec ";
+    pp_one_rec 0 defs.(0);
+    for i = 1 to len - 1 do
+      Format.fprintf fmt "@\nand ";
+      pp_one_rec i defs.(i)
+    done;
+
+  and pp_blam fmt l =
+    match l with
+    | MLprimitive (Mk_prod | Mk_sort) (* FIXME: why this special case? *)
+    | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ ->
+	Format.fprintf fmt "(%a)" pp_mllam l
+    | MLconstruct(_,_,args) when Array.length args > 0 ->
+	Format.fprintf fmt "(%a)" pp_mllam l
+    | _ -> pp_mllam fmt l
+
+  and pp_args sep fmt args =
+    let sep = if sep then " " else "," in
+    let len = Array.length args in
+    if len > 0 then begin
+      Format.fprintf fmt "%a" pp_blam args.(0);
+      for i = 1 to len - 1 do
+	Format.fprintf fmt "%s%a" sep pp_blam args.(i)
+      done
+    end
+
+  and pp_cargs fmt args =
+    let len = Array.length args in
+    match len with
+    | 0 -> ()
+    | 1 -> Format.fprintf fmt " %a" pp_blam args.(0)
+    | _ -> Format.fprintf fmt "(%a)" (pp_args false) args
+
+  and pp_cparam fmt param = 
+    match param with
+    | Some l -> pp_mllam fmt (MLlocal l)
+    | None -> Format.fprintf fmt "_"
+
+  and pp_cparams fmt params =
+    let len = Array.length params in
+    match len with
+    | 0 -> ()
+    | 1 -> Format.fprintf fmt " %a" pp_cparam params.(0)
+    | _ -> 
+	let aux fmt params =
+	  Format.fprintf fmt "%a" pp_cparam params.(0);
+	  for i = 1 to len - 1 do
+	    Format.fprintf fmt ",%a" pp_cparam params.(i)
+	  done in 
+	Format.fprintf fmt "(%a)" aux params
+
+  and pp_branches prefix fmt bs =
+    let pp_branch (cargs,body) =
+      let pp_c fmt (cn,args) = 
+        Format.fprintf fmt "| %s%a " 
+      (string_of_construct prefix cn) pp_cparams args in
+      let rec pp_cargs fmt cargs =
+        match cargs with
+    | [] -> ()
+    | cargs::cargs' -> 
+        Format.fprintf fmt "%a%a" pp_c cargs pp_cargs cargs' in
+      Format.fprintf fmt "%a ->@\n  %a@\n" 
+    pp_cargs cargs pp_mllam body
+      in
+    Array.iter pp_branch bs
+
+  and pp_primitive fmt = function
+    | Mk_prod -> Format.fprintf fmt "mk_prod_accu" 
+    | Mk_sort -> Format.fprintf fmt "mk_sort_accu"
+    | Mk_ind -> Format.fprintf fmt "mk_ind_accu"
+    | Mk_const -> Format.fprintf fmt "mk_constant_accu"
+    | Mk_sw -> Format.fprintf fmt "mk_sw_accu"
+    | Mk_fix(rec_pos,start) -> 
+	let pp_rec_pos fmt rec_pos = 
+	  Format.fprintf fmt "@[[| %i" rec_pos.(0);
+	  for i = 1 to Array.length rec_pos - 1 do
+	    Format.fprintf fmt "; %i" rec_pos.(i) 
+	  done;
+	  Format.fprintf fmt " |]@]" in
+	Format.fprintf fmt "mk_fix_accu %a %i" pp_rec_pos rec_pos start
+    | Mk_cofix(start) -> Format.fprintf fmt "mk_cofix_accu %i" start
+    | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i
+    | Mk_var id ->
+        Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id)
+    | Mk_proj -> Format.fprintf fmt "mk_proj_accu"
+    | Is_accu -> Format.fprintf fmt "is_accu"
+    | Is_int -> Format.fprintf fmt "is_int"
+    | Cast_accu -> Format.fprintf fmt "cast_accu"
+    | Upd_cofix -> Format.fprintf fmt "upd_cofix"
+    | Force_cofix -> Format.fprintf fmt "force_cofix"
+    | Mk_uint -> Format.fprintf fmt "mk_uint"
+    | Mk_int -> Format.fprintf fmt "mk_int"
+    | Mk_bool -> Format.fprintf fmt "mk_bool"
+    | Val_to_int -> Format.fprintf fmt "val_to_int"
+    | Mk_I31_accu -> Format.fprintf fmt "mk_I31_accu"
+    | Decomp_uint -> Format.fprintf fmt "decomp_uint"
+    | Mk_meta -> Format.fprintf fmt "mk_meta_accu"
+    | Mk_evar -> Format.fprintf fmt "mk_evar_accu"
+    | MLand -> Format.fprintf fmt "(&&)"
+    | MLle -> Format.fprintf fmt "(<=)"
+    | MLlt -> Format.fprintf fmt "(<)"
+    | MLinteq -> Format.fprintf fmt "(==)"
+    | MLlsl -> Format.fprintf fmt "(lsl)"
+    | MLlsr -> Format.fprintf fmt "(lsr)"
+    | MLland -> Format.fprintf fmt "(land)"
+    | MLlor -> Format.fprintf fmt "(lor)"
+    | MLlxor -> Format.fprintf fmt "(lxor)"
+    | MLadd -> Format.fprintf fmt "(+)"
+    | MLsub -> Format.fprintf fmt "(-)"
+    | MLmul -> Format.fprintf fmt "( * )"
+    | MLmagic -> Format.fprintf fmt "Obj.magic"
+    | MLarrayget -> Format.fprintf fmt "Array.get"
+    | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty"
+    | Coq_primitive (op,None) ->
+       Format.fprintf fmt "no_check_%s" (Primitives.to_string op)
+    | Coq_primitive (op, Some (prefix,kn)) ->
+       let u = Univ.Instance.empty in
+        Format.fprintf fmt "%s %a" (Primitives.to_string op)
+		       pp_mllam (MLglobal (Gconstant (prefix,(kn,u))))
+  in
+  Format.fprintf fmt "@[%a@]" pp_mllam l
+  
+let pp_array fmt t =
+  let len = Array.length t in
+  Format.fprintf fmt "@[[|";
+  for i = 0 to len - 2 do
+    Format.fprintf fmt "%a; " pp_mllam t.(i)
+  done;
+  if len > 0 then
+    Format.fprintf fmt "%a" pp_mllam t.(len - 1);
+  Format.fprintf fmt "|]@]"
+  
+let pp_global fmt g =
+  match g with
+  | Glet (gn, c) ->
+      let ids, c = decompose_MLlam c in
+      Format.fprintf fmt "@[let %a%a =@\n  %a@]@\n@." pp_gname gn 
+	pp_ldecls ids
+	pp_mllam c
+  | Gopen s ->
+      Format.fprintf fmt "@[open %s@]@." s
+  | Gtype ((mind, i), lar) ->
+      let l = string_of_mind mind in
+      let rec aux s ar = 
+	if Int.equal ar 0 then s else aux (s^" * Nativevalues.t") (ar-1) in
+      let pp_const_sig i fmt j ar =
+        let sig_str = if ar > 0 then aux "of Nativevalues.t" (ar-1) else "" in
+        Format.fprintf fmt "  | Construct_%s_%i_%i %s@\n" l i j sig_str
+      in
+      let pp_const_sigs i fmt lar =
+        Format.fprintf fmt "  | Accu_%s_%i of Nativevalues.t@\n" l i;
+        Array.iteri (pp_const_sig i fmt) lar
+      in
+      Format.fprintf fmt "@[type ind_%s_%i =@\n%a@]@\n@." l i (pp_const_sigs i) lar
+  | Gtblfixtype (g, params, t) ->
+      Format.fprintf fmt "@[let %a %a =@\n  %a@]@\n@." pp_gname g
+	pp_ldecls params pp_array t
+  | Gtblnorm (g, params, t) ->
+      Format.fprintf fmt "@[let %a %a =@\n  %a@]@\n@." pp_gname g
+	pp_ldecls params pp_array t 
+  | Gletcase(gn,params,annot,a,accu,bs) ->
+      Format.fprintf fmt "@[(* Hash = %i *)@\nlet rec %a %a =@\n  %a@]@\n@."
+      (hash_global g)
+	pp_gname gn pp_ldecls params 
+	pp_mllam (MLmatch(annot,a,accu,bs))
+  | Gcomment s ->
+      Format.fprintf fmt "@[(* %s *)@]@." s
+
+(** Compilation of elements in environment **)
+let rec compile_with_fv env sigma univ auxdefs l t =
+  let (auxdefs,(fv_named,fv_rel),ml) = mllambda_of_lambda univ auxdefs l t in
+  if List.is_empty fv_named && List.is_empty fv_rel then (auxdefs,ml)
+  else apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml
+
+and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml =
+  let get_rel_val (n,_) auxdefs =
+    (*
+    match !(lookup_rel_native_val n env) with
+    | NVKnone ->
+    *)
+        compile_rel env sigma univ auxdefs n
+(*    | NVKvalue (v,d) -> assert false *)
+  in
+  let get_named_val (id,_) auxdefs =
+    (*
+    match !(lookup_named_native_val id env) with
+    | NVKnone ->
+        *)
+        compile_named env sigma univ auxdefs id
+(*    | NVKvalue (v,d) -> assert false *)
+  in
+  let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in
+  let auxdefs = List.fold_right get_named_val fv_named auxdefs in
+  let lvl = rel_context_length env.env_rel_context in
+  let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in
+  let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in
+  let aux_name = fresh_lname Anonymous in
+  auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named)))
+
+and compile_rel env sigma univ auxdefs n =
+  let (_,body,_) = lookup_rel n env.env_rel_context in
+  let n = rel_context_length env.env_rel_context - n in
+  match body with
+  | Some t ->
+      let code = lambda_of_constr env sigma t in
+      let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in
+      Glet(Grel n, code)::auxdefs
+  | None -> 
+      Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs
+
+and compile_named env sigma univ auxdefs id =
+  let (_,body,_) = lookup_named id env.env_named_context in
+  match body with
+  | Some t ->
+      let code = lambda_of_constr env sigma t in
+      let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in
+      Glet(Gnamed id, code)::auxdefs
+  | None -> 
+      Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs
+
+let compile_constant env sigma prefix ~interactive con cb =
+  match cb.const_proj with
+  | None ->
+     let u =
+       if cb.const_polymorphic then Univ.UContext.instance cb.const_universes
+       else Univ.Instance.empty
+     in
+    begin match cb.const_body with
+    | Def t ->
+      let t = Mod_subst.force_constr t in
+      let code = lambda_of_constr env sigma t in
+      if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code");
+      let is_lazy = is_lazy prefix t in
+      let code = if is_lazy then mk_lazy code else code in
+      let name =
+        if interactive then LinkedInteractive prefix
+        else Linked prefix
+      in
+      let l = con_label con in
+      let auxdefs,code =
+	if Univ.Instance.is_empty u then compile_with_fv env sigma None [] (Some l) code
+	else
+	  let univ = fresh_univ () in
+	  let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in
+          (auxdefs,mkMLlam [|univ|] code)
+      in
+      if !Flags.debug then Pp.msg_debug (Pp.str "Generated mllambda code");
+      let code =
+        optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs)
+      in
+      if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code");
+      code, name
+    | _ -> 
+        let i = push_symbol (SymbConst con) in
+	let args =
+	  if Univ.Instance.is_empty u then [|get_const_code i; MLarray [||]|]
+	  else [|get_const_code i|]
+	in
+	(*
+	let t = mkMLlam [|univ|] (mkMLapp (MLprimitive Mk_const)
+	 *)
+        [Glet(Gconstant ("",(con,u)), mkMLapp (MLprimitive Mk_const) args)],
+	  if interactive then LinkedInteractive prefix
+	  else Linked prefix
+    end
+  | Some pb ->
+      let u = Univ.Instance.empty in
+      let mind = pb.proj_ind in
+      let ind = (mind,0) in
+      let mib = lookup_mind mind env in
+      let oib = mib.mind_packets.(0) in
+      let tbl = oib.mind_reloc_tbl in 
+      (* Building info *)
+      let prefix = get_mind_prefix env mind in
+      let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; 
+		 ci_cstr_nargs = [|0|];
+		 ci_cstr_ndecls = [||] (*FIXME*);
+		 ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in
+      let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci;
+		  asw_reloc = tbl; asw_finite = true } in
+      let c_uid = fresh_lname Anonymous in
+      let _, arity = tbl.(0) in
+      let ci_uid = fresh_lname Anonymous in
+      let cargs = Array.init arity
+        (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None)
+      in
+      let i = push_symbol (SymbConst con) in
+      let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in
+      let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in
+      let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in
+      let gn = Gproj ("",con) in
+      let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in
+      let arg = fargs.(pb.proj_npars) in
+        Glet(Gconstant ("",(con,u)), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal
+          arg|])))::
+            [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix
+
+let loaded_native_files = ref ([] : string list)
+
+let is_loaded_native_file s = String.List.mem s !loaded_native_files
+
+let register_native_file s =
+  if not (is_loaded_native_file s) then
+    loaded_native_files := s :: !loaded_native_files
+
+let is_code_loaded ~interactive name =
+  match !name with
+  | NotLinked -> false
+  | LinkedInteractive s ->
+      if (interactive && is_loaded_native_file s) then true
+      else (name := NotLinked; false)
+  | Linked s ->
+      if is_loaded_native_file s then true
+      else (name := NotLinked; false)
+
+let param_name = Name (id_of_string "params")
+let arg_name = Name (id_of_string "arg")
+
+let compile_mind prefix ~interactive mb mind stack =
+  let u = Declareops.inductive_instance mb in
+  let f i stack ob =
+    let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in
+    let j = push_symbol (SymbInd (mind,i)) in
+    let name = Gind ("", ((mind, i), u)) in
+    let accu =
+      let args =
+	if Univ.Instance.is_empty u then
+	  [|get_ind_code j; MLarray [||]|]
+	else [|get_ind_code j|]
+      in
+      Glet(name, MLapp (MLprimitive Mk_ind, args))
+    in
+    let nparams = mb.mind_nparams in
+    let params = 
+      Array.init nparams (fun i -> {lname = param_name; luid = i}) in
+    let add_construct j acc (_,arity) = 
+      let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in 
+      let c = (mind,i), (j+1) in
+	  Glet(Gconstruct ("",(c,u)),
+	     mkMLlam (Array.append params args)
+	       (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc
+    in
+    Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl
+  in
+  Array.fold_left_i f stack mb.mind_packets
+
+type code_location_update =
+    link_info ref * link_info
+type code_location_updates =
+  code_location_update Mindmap_env.t * code_location_update Cmap_env.t
+
+type linkable_code = global list * code_location_updates
+
+let empty_updates = Mindmap_env.empty, Cmap_env.empty
+
+let compile_mind_deps env prefix ~interactive
+    (comp_stack, (mind_updates, const_updates) as init) mind =
+  let mib,nameref = lookup_mind_key mind env in
+  if is_code_loaded ~interactive nameref
+    || Mindmap_env.mem mind mind_updates
+  then init
+  else
+    let comp_stack =
+      compile_mind prefix ~interactive mib mind comp_stack
+    in
+    let name =
+      if interactive then LinkedInteractive prefix
+      else Linked prefix
+    in
+    let upd = (nameref, name) in
+    let mind_updates = Mindmap_env.add mind upd mind_updates in
+    (comp_stack, (mind_updates, const_updates))
+
+(* This function compiles all necessary dependencies of t, and generates code in
+   reverse order, as well as linking information updates *)
+let rec compile_deps env sigma prefix ~interactive init t =
+  match kind_of_term t with
+  | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind
+  | Const c ->
+      let c,u = get_allias env c in
+      let cb,(nameref,_) = lookup_constant_key c env in
+      let (_, (_, const_updates)) = init in
+      if is_code_loaded ~interactive nameref
+        || (Cmap_env.mem c const_updates)
+      then init
+      else
+      let comp_stack, (mind_updates, const_updates) = match cb.const_body with
+        | Def t ->
+	   compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t)
+        | _ -> init
+      in
+      let code, name =
+	compile_constant env sigma prefix ~interactive c cb
+      in
+      let comp_stack = code@comp_stack in
+      let const_updates = Cmap_env.add c (nameref, name) const_updates in
+      comp_stack, (mind_updates, const_updates)
+  | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind
+  | Proj (p,c) ->
+    let term = mkApp (mkConst (Projection.constant p), [|c|]) in
+      compile_deps env sigma prefix ~interactive init term
+  | Case (ci, p, c, ac) ->
+      let mind = fst ci.ci_ind in
+      let init = compile_mind_deps env prefix ~interactive init mind in
+      fold_constr (compile_deps env sigma prefix ~interactive) init t
+  | _ -> fold_constr (compile_deps env sigma prefix ~interactive) init t
+
+let compile_constant_field env prefix con acc cb =
+    let (gl, _) =
+      compile_constant ~interactive:false env empty_evars prefix
+        con cb
+    in
+    gl@acc
+
+let compile_mind_field prefix mp l acc mb =
+  let mind = MutInd.make2 mp l in
+  compile_mind prefix ~interactive:false mb mind acc
+
+let mk_open s = Gopen s
+
+let mk_internal_let s code =
+  Glet(Ginternal s, code)
+
+(* ML Code for conversion function *)
+let mk_conv_code env sigma prefix t1 t2 =
+  clear_symb_tbl ();
+  clear_global_tbl ();
+  let gl, (mind_updates, const_updates) =
+    let init = ([], empty_updates) in
+    compile_deps env sigma prefix ~interactive:true init t1
+  in
+  let gl, (mind_updates, const_updates) =
+    let init = (gl, (mind_updates, const_updates)) in
+    compile_deps env sigma prefix ~interactive:true init t2
+  in
+  let code1 = lambda_of_constr env sigma t1 in
+  let code2 = lambda_of_constr env sigma t2 in
+  let (gl,code1) = compile_with_fv env sigma None gl None code1 in
+  let (gl,code2) = compile_with_fv env sigma None gl None code2 in
+  let t1 = mk_internal_let "t1" code1 in
+  let t2 = mk_internal_let "t2" code2 in
+  let g1 = MLglobal (Ginternal "t1") in
+  let g2 = MLglobal (Ginternal "t2") in
+  let setref1 = Glet(Ginternal "_", MLsetref("rt1",g1)) in
+  let setref2 = Glet(Ginternal "_", MLsetref("rt2",g2)) in
+  let gl = List.rev (setref2 :: setref1 :: t2 :: t1 :: gl) in
+  let header = Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_symbols_tbl"),
+      [|MLglobal (Ginternal "()")|])) in
+  header::gl, (mind_updates, const_updates)
+
+let mk_norm_code env sigma prefix t =
+  clear_symb_tbl ();
+  clear_global_tbl ();
+  let gl, (mind_updates, const_updates) =
+    let init = ([], empty_updates) in
+    compile_deps env sigma prefix ~interactive:true init t
+  in
+  let code = lambda_of_constr env sigma t in
+  let (gl,code) = compile_with_fv env sigma None gl None code in
+  let t1 = mk_internal_let "t1" code in
+  let g1 = MLglobal (Ginternal "t1") in
+  let setref = Glet(Ginternal "_", MLsetref("rt1",g1)) in
+  let gl = List.rev (setref :: t1 :: gl) in
+  let header = Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_symbols_tbl"),
+      [|MLglobal (Ginternal "()")|])) in
+  header::gl, (mind_updates, const_updates)
+
+let mk_library_header dir =
+  let libname = Format.sprintf "(str_decode \"%s\")" (str_encode dir) in
+  [Glet(Ginternal "symbols_tbl",
+    MLapp (MLglobal (Ginternal "get_library_symbols_tbl"),
+    [|MLglobal (Ginternal libname)|]))]
+
+let update_location (r,v) = r := v
+
+let update_locations (ind_updates,const_updates) =
+  Mindmap_env.iter (fun _ -> update_location) ind_updates;
+  Cmap_env.iter (fun _ -> update_location) const_updates
+
+let add_header_comment mlcode s =
+  Gcomment s :: mlcode
+
+(* vim: set filetype=ocaml foldmethod=marker: *)
diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli
new file mode 100644
index 00000000..893db92d
--- /dev/null
+++ b/kernel/nativecode.mli
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  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 Term
+open Names
+open Declarations
+open Pre_env
+open Nativelambda
+
+(** This file defines the mllambda code generation phase of the native
+compiler. mllambda represents a fragment of ML, and can easily be printed
+to OCaml code. *)
+
+type mllambda
+type global
+
+val pp_global : Format.formatter -> global -> unit
+
+val mk_open : string -> global
+
+type symbol
+
+val clear_symb_tbl : unit -> unit
+
+val get_value : symbol array -> int -> Nativevalues.t
+
+val get_sort : symbol array -> int -> sorts
+
+val get_name : symbol array -> int -> name
+
+val get_const : symbol array -> int -> constant
+
+val get_match : symbol array -> int -> Nativevalues.annot_sw
+
+val get_ind : symbol array -> int -> inductive
+
+val get_meta : symbol array -> int -> metavariable
+
+val get_evar : symbol array -> int -> existential
+
+val get_level : symbol array -> int -> Univ.Level.t
+
+val get_symbols_tbl : unit -> symbol array
+
+type code_location_update
+type code_location_updates
+type linkable_code = global list * code_location_updates
+
+val clear_global_tbl : unit -> unit
+
+val empty_updates : code_location_updates
+
+val register_native_file : string -> unit
+
+val compile_constant_field : env -> string -> constant ->
+  global list -> constant_body -> global list
+
+val compile_mind_field : string -> module_path -> label ->
+  global list -> mutual_inductive_body -> global list
+
+val mk_conv_code : env -> evars -> string -> constr -> constr -> linkable_code
+val mk_norm_code : env -> evars -> string -> constr -> linkable_code
+
+val mk_library_header : dir_path -> global list
+
+val mod_uid_of_dirpath : dir_path -> string
+
+val link_info_of_dirpath : dir_path -> link_info
+
+val update_locations : code_location_updates -> unit
+
+val add_header_comment : global list -> string -> global list
diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml
new file mode 100644
index 00000000..75a3fc45
--- /dev/null
+++ b/kernel/nativeconv.ml
@@ -0,0 +1,148 @@
+(************************************************************************)
+(*  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 Errors
+open Names
+open Univ
+open Nativelib
+open Reduction
+open Util
+open Nativevalues
+open Nativecode 
+
+(** This module implements the conversion test by compiling to OCaml code *)
+
+let rec conv_val env pb lvl cu v1 v2 = 
+  if v1 == v2 then ()
+  else
+    match kind_of_value v1, kind_of_value v2 with
+    | Vaccu k1, Vaccu k2 ->
+	conv_accu env pb lvl cu k1 k2
+    | Vfun f1, Vfun f2 ->
+	let v = mk_rel_accu lvl in
+	conv_val env CONV (lvl+1) cu (f1 v) (f2 v)
+    | Vconst i1, Vconst i2 -> 
+	if not (Int.equal i1 i2) then raise NotConvertible
+    | Vblock b1, Vblock b2 ->
+	let n1 = block_size b1 in
+        let n2 = block_size b2 in
+	if not (Int.equal (block_tag b1) (block_tag b2)) || not (Int.equal n1 n2) then
+	  raise NotConvertible;
+	let rec aux lvl max b1 b2 i cu =
+	  if Int.equal i max then 
+	    conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i)
+	  else
+	      (conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i);
+	    aux lvl max b1 b2 (i+1) cu)
+	in
+	aux lvl (n1-1) b1 b2 0 cu
+    | Vfun f1, _ -> 
+	conv_val env CONV lvl cu v1 (fun x -> v2 x)
+    | _, Vfun f2 ->
+	conv_val env CONV lvl cu (fun x -> v1 x) v2
+    | _, _ -> raise NotConvertible
+
+and conv_accu env pb lvl cu k1 k2 = 
+  let n1 = accu_nargs k1 in
+  let n2 = accu_nargs k2 in
+  if not (Int.equal n1 n2) then raise NotConvertible;
+  if Int.equal n1 0 then 
+    conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu
+  else
+    (conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu;
+    List.iter2 (conv_val env CONV lvl cu) (args_of_accu k1) (args_of_accu k2))
+
+and conv_atom env pb lvl a1 a2 cu =
+  if a1 == a2 then ()
+  else
+    match a1, a2 with
+    | Arel i1, Arel i2 -> 
+	if not (Int.equal i1 i2) then raise NotConvertible
+    | Aind ind1, Aind ind2 ->
+	if not (eq_puniverses eq_ind ind1 ind2) then raise NotConvertible
+    | Aconstant c1, Aconstant c2 ->
+	if not (eq_puniverses eq_constant c1 c2) then raise NotConvertible
+    | Asort s1, Asort s2 -> 
+        check_sort_cmp_universes env pb s1 s2 cu
+    | Avar id1, Avar id2 ->
+	if not (Id.equal id1 id2) then raise NotConvertible
+    | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) ->
+	if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible;
+	conv_accu env CONV lvl cu ac1 ac2;
+	let tbl = a1.asw_reloc in
+	let len = Array.length tbl in
+	if Int.equal len 0 then conv_val env CONV lvl cu p1 p2
+	else begin
+	  conv_val env CONV lvl cu p1 p2;
+	  let max = len - 1 in
+	  let rec aux i =
+	    let tag,arity = tbl.(i) in
+	    let ci = 
+	      if Int.equal arity 0 then mk_const tag
+	      else mk_block tag (mk_rels_accu lvl arity) in
+	    let bi1 = bs1 ci and bi2 = bs2 ci in
+	    if Int.equal i max then conv_val env CONV (lvl + arity) cu bi1 bi2
+	    else (conv_val env CONV (lvl + arity) cu bi1 bi2; aux (i+1)) in
+	  aux 0
+	  end
+    | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) ->
+	if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible;
+	if f1 == f2 then ()
+	else conv_fix env lvl t1 f1 t2 f2 cu
+    | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)),
+      (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) ->
+	if not (Int.equal s1 s2) then raise NotConvertible;
+	if f1 == f2 then ()
+	else
+	  if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible
+	  else conv_fix env lvl t1 f1 t2 f2 cu 
+    | Aprod(_,d1,c1), Aprod(_,d2,c2) ->
+	conv_val env CONV lvl cu d1 d2;
+	let v = mk_rel_accu lvl in
+	conv_val env pb (lvl + 1) cu (d1 v) (d2 v)
+    | _, _ -> raise NotConvertible
+
+(* Precondition length t1 = length f1 = length f2 = length t2 *)
+and conv_fix env lvl t1 f1 t2 f2 cu =
+  let len = Array.length f1 in
+  let max = len - 1 in
+  let fargs = mk_rels_accu lvl len in
+  let flvl = lvl + len in
+  let rec aux i =
+    conv_val env CONV lvl cu t1.(i) t2.(i);
+    let fi1 = napply f1.(i) fargs in
+    let fi2 = napply f2.(i) fargs in
+    if Int.equal i max then conv_val env CONV flvl cu fi1 fi2
+    else (conv_val env CONV flvl cu fi1 fi2; aux (i+1)) in
+  aux 0
+
+let native_conv pb sigma env t1 t2 =
+  if !Flags.no_native_compiler then begin
+    let msg = "Native compiler is disabled, "^
+    "falling back to VM conversion test." in
+    Pp.msg_warning (Pp.str msg);
+    vm_conv pb env t1 t2
+  end
+  else
+  let penv = Environ.pre_env env in 
+  let ml_filename, prefix = get_ml_filename () in
+  let code, upds = mk_conv_code penv sigma prefix t1 t2 in
+  match compile ml_filename code with
+  | (true, fn) ->
+      begin
+        if !Flags.debug then Pp.msg_debug (Pp.str "Running test...");
+        let t0 = Sys.time () in
+        call_linker ~fatal:true prefix fn (Some upds);
+        let t1 = Sys.time () in
+        let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
+        if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+        (* TODO change 0 when we can have deBruijn *)
+        conv_val env pb 0 (Environ.universes env) !rt1 !rt2
+      end
+  | _ -> anomaly (Pp.str "Compilation failure") 
+
+let _ = set_nat_conv native_conv
diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli
new file mode 100644
index 00000000..318a7d83
--- /dev/null
+++ b/kernel/nativeconv.mli
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  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 Term
+open Reduction
+open Nativelambda
+
+(** This module implements the conversion test by compiling to OCaml code *)
+
+val native_conv : conv_pb -> evars -> types conversion_function
diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli
new file mode 100644
index 00000000..b7d3dadc
--- /dev/null
+++ b/kernel/nativeinstr.mli
@@ -0,0 +1,53 @@
+(************************************************************************)
+(*  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 Names
+open Term
+open Nativevalues
+
+(** This file defines the lambda code for the native compiler. It has been
+extracted from Nativelambda.ml because of the retroknowledge architecture. *)
+
+type prefix = string
+
+type uint =
+  | UintVal of Uint31.t
+  | UintDigits of prefix * constructor * lambda array
+  | UintDecomp of prefix * constructor * lambda
+
+and lambda =
+  | Lrel          of name * int 
+  | Lvar          of identifier
+  | Lmeta         of metavariable * lambda (* type *)
+  | Levar         of existential * lambda (* type *)
+  | Lprod         of lambda * lambda 
+  | Llam          of name array * lambda  
+  | Llet          of name * lambda * lambda
+  | Lapp          of lambda * lambda array
+  | Lconst        of prefix * pconstant
+  | Lproj         of prefix * constant (* prefix, projection name *)
+  | Lprim         of prefix * constant * Primitives.t * lambda array
+  | Lcase         of annot_sw * lambda * lambda * lam_branches 
+                  (* annotations, term being matched, accu, branches *)
+  | Lif           of lambda * lambda * lambda
+  | Lfix          of (int array * int) * fix_decl 
+  | Lcofix        of int * fix_decl 
+  | Lmakeblock    of prefix * pconstructor * int * lambda array
+                  (* prefix, constructor name, constructor tag, arguments *)
+	(* A fully applied constructor *)
+  | Lconstruct    of prefix * pconstructor
+	(* A partially applied constructor *)
+  | Luint         of uint
+  | Lval          of Nativevalues.t
+  | Lsort         of sorts
+  | Lind          of prefix * pinductive
+  | Llazy
+  | Lforce
+
+and lam_branches = (constructor * name array * lambda) array 
+
+and fix_decl =  name array * lambda array * lambda array
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
new file mode 100644
index 00000000..543397df
--- /dev/null
+++ b/kernel/nativelambda.ml
@@ -0,0 +1,779 @@
+(************************************************************************)
+(*  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 Util
+open Names
+open Esubst
+open Term
+open Declarations
+open Pre_env
+open Nativevalues
+open Nativeinstr
+
+(** This file defines the lambda code generation phase of the native compiler *)
+
+exception NotClosed
+
+type evars =
+    { evars_val : existential -> constr option;
+      evars_typ : existential -> types;
+      evars_metas : metavariable -> types }
+
+(*s Constructors *)
+
+let mkLapp f args =
+  if Array.is_empty args then f
+  else
+    match f with
+    | Lapp(f', args') -> Lapp (f', Array.append args' args)
+    | _ -> Lapp(f, args)
+
+let mkLlam ids body =
+  if Array.is_empty ids then body
+  else 
+    match body with
+    | Llam(ids', body) -> Llam(Array.append ids ids', body)
+    | _ -> Llam(ids, body)
+
+let decompose_Llam lam =
+  match lam with
+  | Llam(ids,body) -> ids, body
+  | _ -> [||], lam
+
+let rec decompose_Llam_Llet lam =
+  match lam with
+  | Llam(ids,body) ->
+      let vars, body = decompose_Llam_Llet body in
+      Array.fold_right (fun x l -> (x, None) :: l) ids vars, body
+  | Llet(id,def,body) ->
+      let vars, body = decompose_Llam_Llet body in
+      (id,Some def) :: vars, body
+  | _ -> [], lam
+
+let decompose_Llam_Llet lam =
+  let vars, body = decompose_Llam_Llet lam in
+  Array.of_list vars, body
+
+(*s Operators on substitution *)
+let subst_id = subs_id 0
+let lift = subs_lift 
+let liftn = subs_liftn
+let cons v subst = subs_cons([|v|], subst)
+let shift subst = subs_shft (1, subst)
+
+(* Linked code location utilities *)
+let get_mind_prefix env mind =
+   let _,name = lookup_mind_key mind env in
+   match !name with
+   | NotLinked -> ""
+   | Linked s -> s
+   | LinkedInteractive s -> s
+
+let get_const_prefix env c =
+   let _,(nameref,_) = lookup_constant_key c env in
+   match !nameref with
+   | NotLinked -> ""
+   | Linked s -> s
+   | LinkedInteractive s -> s
+
+(* A generic map function *)
+
+let map_lam_with_binders g f n lam =
+  match lam with
+  | Lrel _ | Lvar _  | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _
+  | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam
+  | Lprod(dom,codom) -> 
+      let dom' = f n dom in
+      let codom' = f n codom in
+      if dom == dom' && codom == codom' then lam else Lprod(dom',codom')
+  | Llam(ids,body) ->
+      let body' = f (g (Array.length ids) n) body in
+      if body == body' then lam else mkLlam ids body'
+  | Llet(id,def,body) ->
+      let def' = f n def in
+      let body' = f (g 1 n) body in
+      if body == body' && def == def' then lam else Llet(id,def',body')
+  | Lapp(fct,args) ->
+      let fct' = f n fct in
+      let args' = Array.smartmap (f n) args in
+      if fct == fct' && args == args' then lam else mkLapp fct' args'
+  | Lprim(prefix,kn,op,args) ->
+      let args' = Array.smartmap (f n) args in
+      if args == args' then lam else Lprim(prefix,kn,op,args')
+  | Lcase(annot,t,a,br) ->
+      let t' = f n t in
+      let a' = f n a in
+      let on_b b = 
+	let (cn,ids,body) = b in
+	let body' = 
+	  if Array.is_empty ids then f n body 
+	  else f (g (Array.length ids) n) body in
+	if body == body' then b else (cn,ids,body') in
+      let br' = Array.smartmap on_b br in
+      if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br')
+  | Lif(t,bt,bf) ->
+      let t' = f n t in
+      let bt' = f n bt in
+      let bf' = f n bf in
+      if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf')
+  | Lfix(init,(ids,ltypes,lbodies)) ->
+      let ltypes' = Array.smartmap (f n) ltypes in
+      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      if ltypes == ltypes' && lbodies == lbodies' then lam
+      else Lfix(init,(ids,ltypes',lbodies'))
+  | Lcofix(init,(ids,ltypes,lbodies)) ->
+      let ltypes' = Array.smartmap (f n) ltypes in
+      let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in
+      if ltypes == ltypes' && lbodies == lbodies' then lam
+      else Lcofix(init,(ids,ltypes',lbodies'))
+  | Lmakeblock(prefix,cn,tag,args) ->
+      let args' = Array.smartmap (f n) args in
+      if args == args' then lam else Lmakeblock(prefix,cn,tag,args')
+
+(*s Lift and substitution *)
+ 
+let rec lam_exlift el lam =
+  match lam with
+  | Lrel(id,i) -> 
+      let i' = reloc_rel i el in
+      if i == i' then lam else Lrel(id,i')
+  | _ -> map_lam_with_binders el_liftn lam_exlift el lam
+
+let lam_lift k lam =
+  if Int.equal k 0 then lam
+  else lam_exlift (el_shft k el_id) lam
+
+let lam_subst_rel lam id n subst =
+  match expand_rel n subst with
+  | Inl(k,v) -> lam_lift k v
+  | Inr(n',_) -> 
+      if n == n' then lam
+      else Lrel(id, n') 
+
+let rec lam_exsubst subst lam =
+  match lam with
+  | Lrel(id,i) -> lam_subst_rel lam id i subst
+  | _ -> map_lam_with_binders liftn lam_exsubst subst lam
+
+let lam_subst subst lam =
+  if is_subs_id subst then lam
+  else lam_exsubst subst lam
+
+let lam_subst_args subst args =
+  if is_subs_id subst then args 
+  else Array.smartmap (lam_exsubst subst) args
+  
+(** Simplification of lambda expression *)
+      
+(* [simplify subst lam] simplify the expression [lam_subst subst lam] *)
+(* that is :                                                          *)
+(* - Reduce [let] is the definition can be substituted i.e:           *)
+(*    - a variable (rel or identifier)                                *)
+ (*    - a constant                                                    *)
+(*    - a structured constant                                         *)
+(*    - a function                                                    *)
+(* - Transform beta redex into [let] expression                       *)
+(* - Move arguments under [let]                                       *) 
+(* Invariant : Terms in [subst] are already simplified and can be     *)
+(*             substituted                                            *)
+  
+let can_subst lam = 
+  match lam with
+  | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _
+  | Lconstruct _ | Lmeta _ | Levar _ -> true
+  | _ -> false
+
+let can_merge_if bt bf =
+  match bt, bf with
+  | Llam(idst,_), Llam(idsf,_) -> true
+  | _ -> false
+
+let merge_if t bt bf =
+  let (idst,bodyt) = decompose_Llam bt in
+  let (idsf,bodyf) = decompose_Llam bf in
+  let nt = Array.length idst in
+  let nf = Array.length idsf in
+  let common,idst,idsf = 
+    if Int.equal nt nf then idst, [||], [||] 
+    else
+      if nt < nf then idst,[||], Array.sub idsf nt (nf - nt)
+      else idsf, Array.sub idst nf (nt - nf), [||] in
+  Llam(common,
+       Lif(lam_lift (Array.length common) t, 
+	   mkLlam idst bodyt,
+	   mkLlam idsf bodyf))
+
+let rec simplify subst lam =
+  match lam with
+  | Lrel(id,i) -> lam_subst_rel lam id i subst 
+
+  | Llet(id,def,body) ->
+      let def' = simplify subst def in
+      if can_subst def' then simplify (cons def' subst) body
+      else 
+	let body' = simplify (lift subst) body in
+	if def == def' && body == body' then lam
+	else Llet(id,def',body')
+
+  | Lapp(f,args) ->
+      begin match simplify_app subst f subst args with
+      | Lapp(f',args') when f == f' && args == args' -> lam
+      | lam' -> lam'
+      end
+
+  | Lif(t,bt,bf) ->
+      let t' = simplify subst t in
+      let bt' = simplify subst bt in
+      let bf' = simplify subst bf in
+      if can_merge_if bt' bf' then merge_if t' bt' bf'
+      else 
+	if t == t' && bt == bt' && bf == bf' then lam
+	else Lif(t',bt',bf')
+  | _ -> map_lam_with_binders liftn simplify subst lam
+
+and simplify_app substf f substa args =
+  match f with
+  | Lrel(id, i) ->
+      begin match lam_subst_rel f id i substf with
+      | Llam(ids, body) ->
+	  reduce_lapp 
+	    subst_id (Array.to_list ids) body  
+	    substa (Array.to_list args)
+      | f' -> mkLapp f' (simplify_args substa args)
+      end
+  | Llam(ids, body) ->
+      reduce_lapp substf (Array.to_list ids) body substa (Array.to_list args)
+  | Llet(id, def, body) ->
+      let def' = simplify substf def in
+      if can_subst def' then
+	simplify_app (cons def' substf) body substa args
+      else 
+	Llet(id, def', simplify_app (lift substf) body (shift substa) args)
+  | Lapp(f, args') ->
+      let args = Array.append 
+	  (lam_subst_args substf args') (lam_subst_args substa args) in
+      simplify_app substf f subst_id args
+  (* TODO | Lproj -> simplify if the argument is known or a known global *)
+  | _ -> mkLapp (simplify substf f) (simplify_args substa args)
+  
+and simplify_args subst args = Array.smartmap (simplify subst) args
+
+and reduce_lapp substf lids body substa largs =
+  match lids, largs with
+  | id::lids, a::largs ->
+      let a = simplify substa a in
+      if can_subst a then
+	reduce_lapp (cons a substf) lids body substa largs
+      else
+	let body = reduce_lapp (lift substf) lids body (shift substa) largs in
+	Llet(id, a, body)
+  | [], [] -> simplify substf body
+  | _::_, _ -> 
+      Llam(Array.of_list lids,  simplify (liftn (List.length lids) substf) body)
+  | [], _::_ -> simplify_app substf body substa (Array.of_list largs)
+
+
+(* [occurence kind k lam]:
+   If [kind] is [true] return [true] if the variable [k] does not appear in 
+   [lam], return [false] if the variable appear one time and not
+   under a lambda, a fixpoint, a cofixpoint; else raise Not_found.
+   If [kind] is [false] return [false] if the variable does not appear in [lam]
+   else raise [Not_found]
+*)
+
+let rec occurence k kind lam =   
+  match lam with
+  | Lrel (_,n) -> 
+      if Int.equal n k then 
+	if kind then false else raise Not_found
+      else kind
+  | Lvar _  | Lconst _  | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _
+  | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind
+  | Lprod(dom, codom) ->
+      occurence k (occurence k kind dom) codom
+  | Llam(ids,body) ->
+      let _ = occurence (k+Array.length ids) false body in kind
+  | Llet(_,def,body) ->
+      occurence (k+1) (occurence k kind def) body
+  | Lapp(f, args) ->
+      occurence_args k (occurence k kind f) args
+  | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) ->
+      occurence_args k kind args
+  | Lcase(_,t,a,br) ->
+      let kind = occurence k (occurence k kind t) a in
+      let r = ref kind in
+      Array.iter (fun (_,ids,c) -> 
+	r := occurence (k+Array.length ids) kind c && !r) br;
+      !r 
+  | Lif (t, bt, bf) ->
+      let kind = occurence k kind t in
+      kind && occurence k kind bt && occurence k kind bf
+  | Lfix(_,(ids,ltypes,lbodies)) 
+  | Lcofix(_,(ids,ltypes,lbodies)) ->
+      let kind = occurence_args k kind ltypes in
+      let _ = occurence_args (k+Array.length ids) false lbodies in
+      kind 
+
+and occurence_args k kind args = 
+  Array.fold_left (occurence k) kind args
+    
+let occur_once lam = 
+  try let _ = occurence 1 true lam in true
+  with Not_found -> false
+      
+(* [remove_let lam] remove let expression in [lam] if the variable is *)
+(* used at most once time in the body, and does not appear under      *)
+(* a lambda or a fix or a cofix                                       *)
+      
+let rec remove_let subst lam =
+  match lam with
+  | Lrel(id,i) -> lam_subst_rel lam id i subst 
+  | Llet(id,def,body) ->
+      let def' = remove_let subst def in
+      if occur_once body then remove_let (cons def' subst) body
+      else 
+	let body' = remove_let (lift subst) body in
+	if def == def' && body == body' then lam else Llet(id,def',body')
+  | _ -> map_lam_with_binders liftn remove_let subst lam
+
+
+(*s Translation from [constr] to [lambda] *)
+
+(* Translation of constructor *)
+
+let is_value lc =
+  match lc with
+  | Lval _ -> true
+  | Lmakeblock(_,_,_,args) when Array.is_empty args -> true
+  | _ -> false
+	
+let get_value lc =
+  match lc with
+  | Lval v -> v
+  | Lmakeblock(_,_,tag,args) when Array.is_empty args -> 
+      Nativevalues.mk_int tag
+  | _ -> raise Not_found
+	
+let make_args start _end =
+  Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i))
+    
+(* Translation of constructors *)	
+
+let makeblock env cn u tag args =
+  if Array.for_all is_value args && Array.length args > 0 then
+    let args = Array.map get_value args in
+    Lval (Nativevalues.mk_block tag args)
+  else
+    let prefix = get_mind_prefix env (fst (fst cn)) in
+    Lmakeblock(prefix, (cn,u), tag, args)
+
+(* Translation of constants *)
+
+let rec get_allias env (kn, u as p) =
+  let tps = (lookup_constant kn env).const_body_code in
+  match Cemitcodes.force tps with
+  |  Cemitcodes.BCallias kn' -> get_allias env kn'
+  | _ -> p
+
+(*i Global environment *)
+
+let global_env = ref empty_env 
+
+let set_global_env env = global_env := env
+
+let get_names decl = 
+  let decl = Array.of_list decl in
+  Array.map fst decl
+
+(* Rel Environment *)
+module Vect = 
+  struct
+    type 'a t = {
+	mutable elems : 'a array;
+	mutable size : int;
+      }
+
+    let make n a = {
+      elems = Array.make n a;
+      size = 0;
+    }
+
+    let length v = v.size
+
+    let extend v =
+      if Int.equal v.size (Array.length v.elems) then 
+	let new_size = min (2*v.size) Sys.max_array_length in
+	if new_size <= v.size then invalid_arg "Vect.extend";
+	let new_elems = Array.make new_size v.elems.(0) in
+	Array.blit v.elems 0 new_elems 0 (v.size);
+	v.elems <- new_elems
+
+    let push v a = 
+      extend v;
+      v.elems.(v.size) <- a;
+      v.size <- v.size + 1
+
+    let push_pos v a =
+      let pos = v.size in
+      push v a;
+      pos
+
+    let popn v n =
+      v.size <- max 0 (v.size - n)
+
+    let pop v = popn v 1
+	
+    let get v n =
+      if v.size <= n then invalid_arg "Vect.get:index out of bounds";
+      v.elems.(n)
+
+    let get_last v n =
+      if v.size <= n then invalid_arg "Vect.get:index out of bounds";
+      v.elems.(v.size - n - 1)
+
+
+    let last v =
+      if Int.equal v.size 0 then invalid_arg "Vect.last:index out of bounds";
+      v.elems.(v.size - 1)
+
+    let clear v = v.size <- 0
+
+    let to_array v = Array.sub v.elems 0 v.size
+      
+  end
+
+let empty_args = [||]
+
+module Renv = 
+  struct
+
+    module ConstrHash =
+    struct
+      type t = constructor
+      let equal = eq_constructor
+      let hash = constructor_hash
+    end
+
+    module ConstrTable = Hashtbl.Make(ConstrHash)
+
+    type constructor_info = tag * int * int (* nparam nrealargs *)
+
+    type t = {
+	name_rel : name Vect.t;
+	construct_tbl : constructor_info ConstrTable.t;
+
+       }
+
+
+    let make () = {
+      name_rel = Vect.make 16 Anonymous;
+      construct_tbl = ConstrTable.create 111
+    }
+
+    let push_rel env id = Vect.push env.name_rel id
+
+    let push_rels env ids = 
+      Array.iter (push_rel env) ids
+
+    let pop env = Vect.pop env.name_rel
+	    
+    let popn env n =
+      for i = 1 to n do pop env done
+
+    let get env n =
+      Lrel (Vect.get_last env.name_rel (n-1), n)
+
+    let get_construct_info env c =
+      try ConstrTable.find env.construct_tbl c
+      with Not_found -> 
+	let ((mind,j), i) = c in
+	let oib = lookup_mind mind !global_env in
+	let oip = oib.mind_packets.(j) in
+	let tag,arity = oip.mind_reloc_tbl.(i-1) in
+	let nparams = oib.mind_nparams in
+	let r = (tag, nparams, arity) in
+	ConstrTable.add env.construct_tbl c r;
+	r
+  end
+
+(* What about pattern matching ?*)
+let is_lazy prefix t =
+  match kind_of_term t with
+  | App (f,args) ->
+     begin match kind_of_term f with
+     | Construct (c,_) ->
+	let entry = mkInd (fst c) in
+	(try
+	    let _ =
+	      Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+							  entry prefix c Llazy;
+	    in
+	    false
+	  with Not_found -> true)
+     | _ -> true
+     end
+  | LetIn _ -> true
+  | _ -> false
+
+let evar_value sigma ev = sigma.evars_val ev
+
+let evar_type sigma ev = sigma.evars_typ ev
+
+let meta_type sigma mv = sigma.evars_metas mv
+
+let empty_evars =
+  { evars_val = (fun _ -> None);
+    evars_typ = (fun _ -> assert false);
+    evars_metas = (fun _ -> assert false) }
+
+let empty_ids = [||]
+
+let rec lambda_of_constr env sigma c =
+  match kind_of_term c with
+  | Meta mv ->
+     let ty = meta_type sigma mv in
+     Lmeta (mv, lambda_of_constr env sigma ty)
+
+  | Evar ev ->
+     (match evar_value sigma ev with
+     | None ->
+	let ty = evar_type sigma ev in
+	Levar(ev, lambda_of_constr env sigma ty)
+     | Some t -> lambda_of_constr env sigma t)
+
+  | Cast (c, _, _) -> lambda_of_constr env sigma c
+
+  | Rel i -> Renv.get env i
+
+  | Var id -> Lvar id
+
+  | Sort s -> Lsort s
+
+  | Ind (ind,u as pind) ->
+      let prefix = get_mind_prefix !global_env (fst ind) in
+      Lind (prefix, pind)
+
+  | Prod(id, dom, codom) ->
+      let ld = lambda_of_constr env sigma dom in
+      Renv.push_rel env id;
+      let lc = lambda_of_constr env sigma codom in
+      Renv.pop env;
+      Lprod(ld,  Llam([|id|], lc))
+
+  | Lambda _ ->
+      let params, body = decompose_lam c in
+      let ids = get_names (List.rev params) in
+      Renv.push_rels env ids;
+      let lb = lambda_of_constr env sigma body in
+      Renv.popn env (Array.length ids);
+      mkLlam ids lb
+
+  | LetIn(id, def, _, body) ->
+      let ld = lambda_of_constr env sigma def in
+      Renv.push_rel env id;
+      let lb = lambda_of_constr env sigma body in
+      Renv.pop env;
+      Llet(id, ld, lb)
+
+  | App(f, args) -> lambda_of_app env sigma f args
+
+  | Const _ -> lambda_of_app env sigma c empty_args
+
+  | Construct _ ->  lambda_of_app env sigma c empty_args
+
+  | Proj (p, c) ->
+    let kn = Projection.constant p in
+      mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|]
+
+  | Case(ci,t,a,branches) ->  
+      let (mind,i as ind) = ci.ci_ind in
+      let mib = lookup_mind mind !global_env in
+      let oib = mib.mind_packets.(i) in
+      let tbl = oib.mind_reloc_tbl in 
+      (* Building info *)
+      let prefix = get_mind_prefix !global_env mind in
+      let annot_sw = 
+	    { asw_ind = ind;
+          asw_ci = ci;
+          asw_reloc = tbl; 
+          asw_finite = mib.mind_finite <> Decl_kinds.CoFinite;
+          asw_prefix = prefix}
+      in
+      (* translation of the argument *)
+      let la = lambda_of_constr env sigma a in
+      let entry = mkInd ind in
+      let la =
+	try
+	  Retroknowledge.get_native_before_match_info (!global_env).retroknowledge
+						      entry prefix (ind,1) la
+	with Not_found -> la
+      in
+      (* translation of the type *)
+      let lt = lambda_of_constr env sigma t in
+      (* translation of branches *)
+      let mk_branch i b =
+	let cn = (ind,i+1) in
+	let _, arity = tbl.(i) in
+	let b = lambda_of_constr env sigma b in
+	if Int.equal arity 0 then (cn, empty_ids, b)
+	else 
+	  match b with
+	  | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body)
+	  | _ -> 
+	      let ids = Array.make arity Anonymous in
+	      let args = make_args arity 1 in
+	      let ll = lam_lift arity b in
+	      (cn, ids, mkLapp  ll args) in
+      let bs = Array.mapi mk_branch branches in
+      Lcase(annot_sw, lt, la, bs)
+	
+  | Fix(rec_init,(names,type_bodies,rec_bodies)) ->
+      let ltypes = lambda_of_args env sigma 0 type_bodies in
+      Renv.push_rels env names;
+      let lbodies = lambda_of_args env sigma 0 rec_bodies in
+      Renv.popn env (Array.length names);
+      Lfix(rec_init, (names, ltypes, lbodies))
+	
+  | CoFix(init,(names,type_bodies,rec_bodies)) ->
+      let ltypes = lambda_of_args env sigma 0 type_bodies in 
+      Renv.push_rels env names;
+      let lbodies = lambda_of_args env sigma 0 rec_bodies in
+      Renv.popn env (Array.length names);
+      Lcofix(init, (names, ltypes, lbodies))
+
+and lambda_of_app env sigma f args =
+  match kind_of_term f with
+  | Const (kn,u as c) ->
+      let kn,u = get_allias !global_env c in
+      let cb = lookup_constant kn !global_env in
+      (try
+          let prefix = get_const_prefix !global_env kn in
+	  (* We delay the compilation of arguments to avoid an exponential behavior *)
+	  let f = Retroknowledge.get_native_compiling_info
+		    (!global_env).retroknowledge (mkConst kn) prefix in
+	  let args = lambda_of_args env sigma 0 args in
+	  f args
+      with Not_found ->
+      begin match cb.const_body with
+      | Def csubst -> (* TODO optimize if f is a proj and argument is known *)
+          if cb.const_inline_code then
+            lambda_of_app env sigma (Mod_subst.force_constr csubst) args
+          else
+          let prefix = get_const_prefix !global_env kn in
+          let t =
+            if is_lazy prefix (Mod_subst.force_constr csubst) then
+              mkLapp Lforce [|Lconst (prefix, (kn,u))|]
+            else Lconst (prefix, (kn,u))
+          in
+        mkLapp t (lambda_of_args env sigma 0 args)
+      | OpaqueDef _ | Undef _ ->
+          let prefix = get_const_prefix !global_env kn in
+          mkLapp (Lconst (prefix, (kn,u))) (lambda_of_args env sigma 0 args)
+      end)
+  | Construct (c,u) ->
+      let tag, nparams, arity = Renv.get_construct_info env c in
+      let expected = nparams + arity in
+      let nargs = Array.length args in
+      let prefix = get_mind_prefix !global_env (fst (fst c)) in
+      if Int.equal nargs expected then 
+      try
+	try
+	  Retroknowledge.get_native_constant_static_info
+                         (!global_env).retroknowledge
+                         f args
+          with NotClosed ->
+	    assert (Int.equal nparams 0); (* should be fine for int31 *)
+	    let args = lambda_of_args env sigma nparams args in
+	    Retroknowledge.get_native_constant_dynamic_info
+                           (!global_env).retroknowledge f prefix c args
+        with Not_found ->
+	  let args = lambda_of_args env sigma nparams args in
+	  makeblock !global_env c u tag args
+      else
+	let args = lambda_of_args env sigma 0 args in
+	(try
+	    Retroknowledge.get_native_constant_dynamic_info
+              (!global_env).retroknowledge f prefix c args
+	  with Not_found ->
+            mkLapp (Lconstruct (prefix, (c,u))) args)
+  | _ -> 
+      let f = lambda_of_constr env sigma f in
+      let args = lambda_of_args env sigma 0 args in
+      mkLapp f args
+	
+and lambda_of_args env sigma start args =
+  let nargs = Array.length args in
+  if start < nargs then
+    Array.init (nargs - start) 
+      (fun i -> lambda_of_constr env sigma args.(start + i))
+  else empty_args
+
+let optimize lam =
+  let lam = simplify subst_id lam in
+(*  if Flags.vm_draw_opt () then 
+    (msgerrnl (str "Simplify = \n" ++ pp_lam lam);flush_all()); 
+  let lam = remove_let subst_id lam in
+  if Flags.vm_draw_opt () then 
+    (msgerrnl (str "Remove let = \n" ++ pp_lam lam);flush_all()); *)
+  lam
+
+let lambda_of_constr env sigma c =
+  set_global_env env;
+  let env = Renv.make () in
+  let ids = List.rev_map (fun (id, _, _) -> id) !global_env.env_rel_context in
+  Renv.push_rels env (Array.of_list ids);
+  let lam = lambda_of_constr env sigma c in
+(*  if Flags.vm_draw_opt () then begin
+    (msgerrnl (str "Constr = \n" ++ pr_constr c);flush_all()); 
+    (msgerrnl (str "Lambda = \n" ++ pp_lam lam);flush_all()); 
+  end; *)
+  optimize lam
+
+let mk_lazy c =
+  mkLapp Llazy [|c|]
+
+(** Retroknowledge, to be removed once we move to primitive machine integers *)
+let compile_static_int31 fc args =
+  if not fc then raise Not_found else
+    Luint (UintVal
+    (Uint31.of_int (Array.fold_left
+       (fun temp_i -> fun t -> match kind_of_term t with
+          | Construct ((_,d),_) -> 2*temp_i+d-1
+          | _ -> raise NotClosed)
+       0 args)))
+
+let compile_dynamic_int31 fc prefix c args =
+  if not fc then raise Not_found else
+  Luint (UintDigits (prefix,c,args))
+
+(* We are relying here on the order of digits constructors *)
+let digits_from_uint digits_ind prefix i =
+  let d0 = Lconstruct (prefix, ((digits_ind, 1), Univ.Instance.empty)) in
+  let d1 = Lconstruct (prefix, ((digits_ind, 2), Univ.Instance.empty)) in
+  let digits = Array.make 31 d0 in
+  for k = 0 to 30 do
+    if Int.equal ((Uint31.to_int i lsr k) land 1) 1 then
+      digits.(30-k) <- d1
+  done;
+  digits
+
+let before_match_int31 digits_ind fc prefix c t =
+  if not fc then
+    raise Not_found
+  else
+  match t with
+  | Luint (UintVal i) ->
+     let digits = digits_from_uint digits_ind prefix i in
+     mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) digits
+  | Luint (UintDigits (prefix,c,args)) ->
+     mkLapp (Lconstruct (prefix,(c, Univ.Instance.empty))) args
+  | _ -> Luint (UintDecomp (prefix,c,t))
+
+let compile_prim prim kn fc prefix args =
+  if not fc then raise Not_found
+  else
+    Lprim(prefix, kn, prim, args)
diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli
new file mode 100644
index 00000000..6a97edc4
--- /dev/null
+++ b/kernel/nativelambda.mli
@@ -0,0 +1,43 @@
+(************************************************************************)
+(*  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 Names
+open Term
+open Pre_env
+open Nativevalues
+open Nativeinstr
+
+(** This file defines the lambda code generation phase of the native compiler *)
+type evars =
+    { evars_val : existential -> constr option;
+      evars_typ : existential -> types;
+      evars_metas : metavariable -> types }
+
+val empty_evars : evars
+
+val decompose_Llam : lambda -> Names.name array * lambda
+val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda
+
+val is_lazy : prefix -> constr -> bool
+val mk_lazy : lambda -> lambda
+
+val get_mind_prefix : env -> mutual_inductive -> string
+
+val get_allias : env -> pconstant -> pconstant
+
+val lambda_of_constr : env -> evars -> Constr.constr -> lambda
+
+val compile_static_int31 : bool -> Constr.constr array -> lambda
+
+val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array ->
+			    lambda
+
+val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda ->
+			 lambda
+
+val compile_prim : Primitives.t -> constant -> bool -> prefix -> lambda array ->
+		   lambda
diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml
new file mode 100644
index 00000000..dd47bc06
--- /dev/null
+++ b/kernel/nativelib.ml
@@ -0,0 +1,122 @@
+(************************************************************************)
+(*  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 Util
+open Nativevalues
+open Nativecode
+open Errors
+open Envars
+
+(** This file provides facilities to access OCaml compiler and dynamic linker,
+used by the native compiler. *)
+
+let get_load_paths =
+  ref (fun _ -> anomaly (Pp.str "get_load_paths not initialized") : unit -> string list)
+
+let open_header = ["Nativevalues";
+                   "Nativecode";
+                   "Nativelib";
+		   "Nativeconv";
+                   "Declaremods"]
+let open_header = List.map mk_open open_header
+
+(* Directory where compiled files are stored *)
+let output_dir = ".coq-native"
+
+(* Extension of genereted ml files, stored for debugging purposes *)
+let source_ext = ".native"
+
+(* Global settings and utilies for interface with OCaml *)
+let compiler_name =
+  if Dynlink.is_native then ocamlopt () else ocamlc ()
+
+let ( / ) = Filename.concat
+
+(* We have to delay evaluation of include_dirs because coqlib cannot be guessed
+until flags have been properly initialized *)
+let include_dirs () =
+  [Filename.temp_dir_name; coqlib () / "kernel"; coqlib () / "library"]
+
+(* Pointer to the function linking an ML object into coq's toplevel *)
+let load_obj = ref (fun x -> () : string -> unit)
+
+let rt1 = ref (dummy_value ())
+let rt2 = ref (dummy_value ())
+
+let get_ml_filename () =
+  let filename = Filename.temp_file "Coq_native" source_ext in
+  let prefix = Filename.chop_extension (Filename.basename filename) ^ "." in
+  filename, prefix
+
+let write_ml_code fn ?(header=[]) code =
+  let header = open_header@header in
+  let ch_out = open_out fn in
+  let fmt = Format.formatter_of_out_channel ch_out in
+  List.iter (pp_global fmt) (header@code);
+  close_out ch_out
+
+let call_compiler ml_filename =
+  let load_path = !get_load_paths () in
+  let load_path = List.map (fun dn -> dn / output_dir) load_path in
+  let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in
+  let f = Filename.chop_extension ml_filename in
+  let link_filename = f ^ ".cmo" in
+  let link_filename = Dynlink.adapt_filename link_filename in
+  let remove f = if Sys.file_exists f then Sys.remove f in
+  remove link_filename;
+  remove (f ^ ".cmi");
+  let args =
+    (if Dynlink.is_native then "-shared" else "-c")
+    ::"-o"::link_filename
+    ::"-rectypes"
+    ::"-w"::"a"
+    ::include_dirs
+    @ ["-impl"; ml_filename] in
+  if !Flags.debug then Pp.msg_debug (Pp.str (compiler_name ^ " " ^ (String.concat " " args)));
+  CUnix.sys_command compiler_name args = Unix.WEXITED 0, link_filename
+
+let compile fn code =
+  write_ml_code fn code;
+  let r = call_compiler fn in
+  if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn;
+  r
+
+let compile_library dir code fn =
+  let header = mk_library_header dir in
+  let fn = fn ^ source_ext in
+  let basename = Filename.basename fn in
+  let dirname = Filename.dirname fn in
+  let dirname = dirname / output_dir in
+  if not (Sys.file_exists dirname) then Unix.mkdir dirname 0o755;
+  let fn = dirname / basename in
+  write_ml_code fn ~header code;
+  let r = fst (call_compiler fn) in
+  if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn;
+  r
+
+(* call_linker links dynamically the code for constants in environment or a  *)
+(* conversion test. Silently fails if the file does not exist in bytecode    *)
+(* mode, since the standard library is not compiled to bytecode with default *)
+(* settings.                                                                 *)
+let call_linker ?(fatal=true) prefix f upds =
+  rt1 := dummy_value ();
+  rt2 := dummy_value ();
+  if Dynlink.is_native || Sys.file_exists f then
+  (try
+    if Dynlink.is_native then Dynlink.loadfile f else !load_obj f;
+    register_native_file prefix
+   with | Dynlink.Error e ->
+          let msg = "Dynlink error, " ^ Dynlink.error_message e in
+          if fatal then anomaly (Pp.str msg) else Pp.msg_warning (Pp.str msg)
+        | e when Errors.noncritical e ->
+          if fatal then anomaly (Errors.print e)
+	  else Pp.msg_warning (Errors.print_no_report e));
+  match upds with Some upds -> update_locations upds | _ -> ()
+
+let link_library ~prefix ~dirname ~basename =
+  let f = dirname / output_dir / basename in
+  call_linker ~fatal:false prefix f None
diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli
new file mode 100644
index 00000000..0941dc56
--- /dev/null
+++ b/kernel/nativelib.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  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 Nativecode
+
+(** This file provides facilities to access OCaml compiler and dynamic linker,
+used by the native compiler. *)
+
+(* Directory where compiled files are stored *)
+val output_dir : string
+
+val get_load_paths : (unit -> string list) ref
+
+val load_obj : (string -> unit) ref
+
+val get_ml_filename : unit -> string * string
+
+val compile : string -> global list -> bool * string
+
+val compile_library : Names.dir_path -> global list -> string -> bool
+
+val call_linker :
+  ?fatal:bool -> string -> string -> code_location_updates option -> unit
+
+val link_library : prefix:string -> dirname:string -> basename:string -> unit
+
+val rt1 : Nativevalues.t ref
+val rt2 : Nativevalues.t ref
diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml
new file mode 100644
index 00000000..914f577e
--- /dev/null
+++ b/kernel/nativelibrary.ml
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  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 Names
+open Declarations
+open Environ
+open Mod_subst
+open Modops
+open Nativecode
+open Nativelib
+
+(** This file implements separate compilation for libraries in the native
+compiler *)
+
+let rec translate_mod prefix mp env mod_expr acc =
+  match mod_expr with
+  | NoFunctor struc ->
+      let env' = add_structure mp struc empty_delta_resolver env in
+      List.fold_left (translate_field prefix mp env') acc struc
+  | MoreFunctor _ -> acc
+
+and translate_field prefix mp env acc (l,x) =
+  match x with
+  | SFBconst cb ->
+     let con = make_con mp empty_dirpath l in
+     (if !Flags.debug then
+	let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in
+	Pp.msg_debug (Pp.str msg));
+     compile_constant_field (pre_env env) prefix con acc cb
+  | SFBmind mb ->
+     (if !Flags.debug then
+	let id = mb.mind_packets.(0).mind_typename in
+	let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in
+	Pp.msg_debug (Pp.str msg));
+     compile_mind_field prefix mp l acc mb
+  | SFBmodule md ->
+     let mp = md.mod_mp in
+     (if !Flags.debug then
+	let msg =
+	  Printf.sprintf "Compiling module %s..." (ModPath.to_string mp)
+	in
+	Pp.msg_debug (Pp.str msg));
+     translate_mod prefix mp env md.mod_type acc
+  | SFBmodtype mdtyp ->
+     let mp = mdtyp.mod_mp in
+     (if !Flags.debug then
+	let msg =
+	  Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp)
+	in
+	Pp.msg_debug (Pp.str msg));
+     translate_mod prefix mp env mdtyp.mod_type acc
+
+let dump_library mp dp env mod_expr =
+  if !Flags.debug then Pp.msg_debug (Pp.str "Compiling library...");
+  match mod_expr with
+  | NoFunctor struc ->
+      let env = add_structure mp struc empty_delta_resolver env in
+      let prefix = mod_uid_of_dirpath dp ^ "." in
+      let t0 = Sys.time () in
+      clear_global_tbl ();
+      clear_symb_tbl ();
+      let mlcode =
+        List.fold_left (translate_field prefix mp env) [] struc
+      in
+      let t1 = Sys.time () in
+      let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in
+      let mlcode = add_header_comment (List.rev mlcode) time_info in
+      mlcode, get_symbols_tbl ()
+  | _ -> assert false
diff --git a/parsing/ppvernac.mli b/kernel/nativelibrary.mli
index 87b4fe56..a66fb715 100644
--- a/parsing/ppvernac.mli
+++ b/kernel/nativelibrary.mli
@@ -1,24 +1,17 @@
 (************************************************************************)
 (*  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 Genarg
-open Vernacexpr
 open Names
-open Nameops
-open Nametab
-open Util
-open Ppconstr
-open Pptactic
-open Glob_term
-open Pcoq
-open Libnames
-open Ppextend
-open Topconstr
+open Declarations
+open Environ
+open Nativecode
+
+(** This file implements separate compilation for libraries in the native
+compiler *)
 
-val pr_vernac : vernac_expr -> std_ppcmds
+val dump_library : module_path -> dir_path -> env -> module_signature ->
+  global list * symbol array
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
new file mode 100644
index 00000000..d7a21950
--- /dev/null
+++ b/kernel/nativevalues.ml
@@ -0,0 +1,576 @@
+(************************************************************************)
+(*  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 Term
+open Names
+open Errors
+open Util
+
+(** This modules defines the representation of values internally used by
+the native compiler *)
+
+type t = t -> t
+    
+type accumulator (* = t (* a block [0:code;atom;arguments] *) *)
+
+type tag = int
+ 
+type arity = int
+
+type reloc_table = (tag * arity) array
+
+type annot_sw = {
+    asw_ind : inductive;
+    asw_ci : case_info;
+    asw_reloc : reloc_table;
+    asw_finite : bool;
+    asw_prefix : string
+  }
+
+(* We compare only what is relevant for generation of ml code *)
+let eq_annot_sw asw1 asw2 =
+  eq_ind asw1.asw_ind asw2.asw_ind &&
+  String.equal asw1.asw_prefix asw2.asw_prefix
+
+open Hashset.Combine
+
+let hash_annot_sw asw =
+  combine (ind_hash asw.asw_ind) (String.hash asw.asw_prefix)
+
+type sort_annot = string * int
+
+type rec_pos = int array
+
+let eq_rec_pos = Array.equal Int.equal
+
+type atom = 
+  | Arel of int
+  | Aconstant of pconstant
+  | Aind of pinductive
+  | Asort of sorts
+  | Avar of identifier
+  | Acase of annot_sw * accumulator * t * (t -> t)
+  | Afix of t array * t array * rec_pos * int
+            (* types, bodies, rec_pos, pos *)
+  | Acofix of t array * t array * int * t
+  | Acofixe of t array * t array * int * t
+  | Aprod of name * t * (t -> t)
+  | Ameta of metavariable * t
+  | Aevar of existential * t
+  | Aproj of constant * accumulator
+
+let accumulate_tag = 0
+
+let accumulate_code (k:accumulator) (x:t) =
+  let o = Obj.repr k in
+  let osize = Obj.size o in
+  let r = Obj.new_block accumulate_tag (osize + 1) in
+  for i = 0 to osize - 1 do
+    Obj.set_field r i (Obj.field o i)
+  done;
+  Obj.set_field r osize (Obj.repr x);
+  (Obj.obj r:t)
+
+let rec accumulate (x:t) =
+  accumulate_code (Obj.magic accumulate) x
+
+let raccumulate = ref accumulate
+
+let mk_accu_gen rcode (a:atom) =
+(*  Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *)
+  let r = Obj.new_block 0 3 in
+  Obj.set_field r 0 (Obj.field (Obj.magic rcode) 0);
+  Obj.set_field r 1 (Obj.field (Obj.magic rcode) 1);
+  Obj.set_field r 2 (Obj.magic a);
+  (Obj.magic r:t);;
+
+let mk_accu (a:atom) = mk_accu_gen accumulate a
+
+let mk_rel_accu i = 
+  mk_accu (Arel i)
+
+let rel_tbl_size = 100 
+let rel_tbl = Array.init rel_tbl_size mk_rel_accu
+
+let mk_rel_accu i = 
+  if i < rel_tbl_size then rel_tbl.(i)
+  else mk_rel_accu i
+
+let mk_rels_accu lvl len =
+  Array.init len (fun i -> mk_rel_accu (lvl + i))
+
+let napply (f:t) (args: t array) =
+  Array.fold_left (fun f a -> f a) f args
+
+let mk_constant_accu kn u = 
+  mk_accu (Aconstant (kn,Univ.Instance.of_array u))
+
+let mk_ind_accu ind u = 
+  mk_accu (Aind (ind,Univ.Instance.of_array u))
+
+let mk_sort_accu s u =
+  match s with
+  | Prop _ -> mk_accu (Asort s)
+  | Type s ->
+     let u = Univ.Instance.of_array u in
+     let s = Univ.subst_instance_universe u s in
+     mk_accu (Asort (Type s))
+
+let mk_var_accu id = 
+  mk_accu (Avar id)
+
+let mk_sw_accu annot c p ac = 
+  mk_accu (Acase(annot,c,p,ac))
+
+let mk_prod_accu s dom codom =
+  mk_accu (Aprod (s,dom,codom))
+
+let mk_meta_accu mv ty =
+  mk_accu (Ameta (mv,ty))
+
+let mk_evar_accu ev ty =
+  mk_accu (Aevar (ev,ty))
+
+let mk_proj_accu kn c = 
+  mk_accu (Aproj (kn,c))
+
+let atom_of_accu (k:accumulator) =
+  (Obj.magic (Obj.field (Obj.magic k) 2) : atom)
+
+let set_atom_of_accu (k:accumulator) (a:atom) =
+  Obj.set_field (Obj.magic k) 2 (Obj.magic a)
+
+let accu_nargs (k:accumulator) =
+  let nargs = Obj.size (Obj.magic k) - 3 in
+(*  if nargs < 0 then Format.eprintf "nargs = %i\n" nargs; *)
+  assert (nargs >= 0);
+  nargs
+
+let args_of_accu (k:accumulator) =
+  let nargs = accu_nargs k in
+  let f i = (Obj.magic (Obj.field (Obj.magic k) (nargs-i+2)) : t) in
+  let t = Array.init nargs f in
+  Array.to_list t
+
+let is_accu x =
+  let o = Obj.repr x in
+  Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag
+
+(*let accumulate_fix_code (k:accumulator) (a:t) =
+  match atom_of_accu k with
+  | Afix(frec,_,rec_pos,_,_) ->
+      let nargs = accu_nargs k in
+      if nargs <> rec_pos || is_accu a then
+	accumulate_code k a
+      else
+        let r = ref frec in
+        for i = 0 to nargs - 1 do
+	  r := !r (arg_of_accu k i)
+        done;
+        !r a
+  | _ -> assert false
+
+
+let rec accumulate_fix (x:t) =
+  accumulate_fix_code (Obj.magic accumulate_fix) x
+
+let raccumulate_fix = ref accumulate_fix *)
+
+let is_atom_fix (a:atom) =
+  match a with
+  | Afix _ -> true
+  | _ -> false
+
+let mk_fix_accu rec_pos pos types bodies =
+  mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos))
+
+let mk_cofix_accu pos types norm =
+  mk_accu_gen accumulate (Acofix(types,norm,pos,(Obj.magic 0 : t)))
+
+let upd_cofix (cofix :t) (cofix_fun : t) =
+  let atom = atom_of_accu (Obj.magic cofix) in
+  match atom with
+  | Acofix (typ,norm,pos,_) ->
+      set_atom_of_accu (Obj.magic cofix) (Acofix(typ,norm,pos,cofix_fun))
+  | _ -> assert false
+  
+let force_cofix (cofix : t) = 
+  if is_accu cofix then
+    let accu = (Obj.magic cofix : accumulator) in
+    let atom = atom_of_accu accu in
+    match atom with
+    | Acofix(typ,norm,pos,f) ->
+	let f = ref f in
+    let args = List.rev (args_of_accu accu) in
+    List.iter (fun x -> f := !f x) args;
+	let v = !f (Obj.magic ()) in
+	set_atom_of_accu accu (Acofixe(typ,norm,pos,v));
+	v
+    | Acofixe(_,_,_,v) -> v 
+    | _ -> cofix
+  else cofix
+
+let mk_const tag = Obj.magic tag
+
+let mk_block tag args =
+  let nargs = Array.length args in
+  let r = Obj.new_block tag nargs in
+  for i = 0 to nargs - 1 do
+    Obj.set_field r i (Obj.magic args.(i))
+  done;
+  (Obj.magic r : t)
+
+(* Two instances of dummy_value should not be pointer equal, otherwise
+ comparing them as terms would succeed *)
+let dummy_value : unit -> t =
+  fun () _ -> anomaly ~label:"native" (Pp.str "Evaluation failed")
+
+let cast_accu v = (Obj.magic v:accumulator)
+
+let mk_int (x : int) = (Obj.magic x : t)
+(* Coq's booleans are reversed... *)
+let mk_bool (b : bool) = (Obj.magic (not b) : t)
+let mk_uint (x : Uint31.t) = (Obj.magic x : t)
+
+type block
+
+let block_size (b:block) =
+  Obj.size (Obj.magic b)
+
+let block_field (b:block) i = (Obj.magic (Obj.field (Obj.magic b) i) : t)
+
+let block_tag (b:block) = 
+  Obj.tag (Obj.magic b)
+
+type kind_of_value =
+  | Vaccu of accumulator
+  | Vfun of (t -> t)
+  | Vconst of int
+  | Vblock of block
+	
+let kind_of_value (v:t) =
+  let o = Obj.repr v in
+  if Obj.is_int o then Vconst (Obj.magic v)
+  else
+    let tag = Obj.tag o in
+    if Int.equal tag accumulate_tag then
+      Vaccu (Obj.magic v)
+    else 
+      if (tag < Obj.lazy_tag) then Vblock (Obj.magic v)
+      else
+        (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); 
+           or ??? what is 1002*)
+        Vfun v
+
+(** Support for machine integers *)
+
+let is_int (x:t) =
+  let o = Obj.repr x in
+  Obj.is_int o
+
+let val_to_int (x:t) = (Obj.magic x : int)
+
+let to_uint (x:t) = (Obj.magic x : Uint31.t)
+let of_uint (x: Uint31.t) = (Obj.magic x : t)
+
+let no_check_head0 x =
+ of_uint (Uint31.head0 (to_uint x))
+
+let head0 accu x =
+ if is_int x then  no_check_head0 x
+ else accu x
+
+let no_check_tail0 x =
+  of_uint (Uint31.tail0 (to_uint x))
+
+let tail0 accu x =
+ if is_int x then no_check_tail0 x
+ else accu x
+
+let no_check_add  x y =
+  of_uint (Uint31.add (to_uint x) (to_uint y))
+
+let add accu x y =
+  if is_int x && is_int y then no_check_add x y 
+  else accu x y
+
+let no_check_sub x y =
+     of_uint (Uint31.sub (to_uint x) (to_uint y))
+
+let sub accu x y =
+  if is_int x && is_int y then no_check_sub x y
+  else accu x y
+
+let no_check_mul x y =
+  of_uint (Uint31.mul (to_uint x) (to_uint y))
+
+let mul accu x y =
+  if is_int x && is_int y then no_check_mul x y
+  else accu x y
+
+let no_check_div x y =
+  of_uint (Uint31.div (to_uint x) (to_uint y))
+
+let div accu x y =
+  if is_int x && is_int y then no_check_div x y 
+  else accu x y
+
+let no_check_rem x y =
+  of_uint (Uint31.rem (to_uint x) (to_uint y))
+
+let rem accu x y =
+  if is_int x && is_int y then no_check_rem x y
+  else accu x y
+
+let no_check_l_sr x y =
+  of_uint (Uint31.l_sr (to_uint x) (to_uint y))
+
+let l_sr accu x y =
+  if is_int x && is_int y then no_check_l_sr x y
+  else accu x y
+
+let no_check_l_sl x y =
+  of_uint (Uint31.l_sl (to_uint x) (to_uint y))
+
+let l_sl accu x y =
+  if is_int x && is_int y then no_check_l_sl x y
+  else accu x y
+
+let no_check_l_and x y =
+  of_uint (Uint31.l_and (to_uint x) (to_uint y))
+
+let l_and accu x y =
+  if is_int x && is_int y then no_check_l_and x y
+  else accu x y
+
+let no_check_l_xor x y =
+  of_uint (Uint31.l_xor (to_uint x) (to_uint y))
+
+let l_xor accu x y =
+  if is_int x && is_int y then no_check_l_xor x y
+  else accu x y
+
+let no_check_l_or x y =
+  of_uint (Uint31.l_or (to_uint x) (to_uint y))
+
+let l_or accu x y =
+  if is_int x && is_int y then no_check_l_or x y
+  else accu x y
+
+type coq_carry = 
+  | Caccu of t
+  | C0 of t
+  | C1 of t
+
+type coq_pair = 
+  | Paccu of t
+  | PPair of t * t
+
+let mkCarry b i =
+  if b then (Obj.magic (C1(of_uint i)):t)
+  else (Obj.magic (C0(of_uint i)):t)
+
+let no_check_addc x y =
+  let s = Uint31.add (to_uint x) (to_uint y) in
+  mkCarry (Uint31.lt s (to_uint x)) s
+
+let addc accu x y =
+  if is_int x && is_int y then no_check_addc x y
+  else accu x y
+
+let no_check_subc x y =
+  let s = Uint31.sub (to_uint x) (to_uint y) in
+  mkCarry (Uint31.lt (to_uint x) (to_uint y)) s
+
+let subc accu x y =
+  if is_int x && is_int y then no_check_subc x y
+  else accu x y
+
+let no_check_addcarryc x y =
+  let s = 
+    Uint31.add (Uint31.add (to_uint x) (to_uint y))
+      (Uint31.of_int 1) in
+  mkCarry (Uint31.le s (to_uint x)) s
+
+let addcarryc accu x y =
+  if is_int x && is_int y then no_check_addcarryc x y
+  else accu x y 
+
+let no_check_subcarryc x y =
+  let s = 
+    Uint31.sub (Uint31.sub (to_uint x) (to_uint y))
+      (Uint31.of_int 1) in
+  mkCarry (Uint31.le (to_uint x) (to_uint y)) s
+
+let subcarryc accu x y =
+  if is_int x && is_int y then no_check_subcarryc x y
+  else accu x y 
+
+let of_pair (x, y) =
+  (Obj.magic (PPair(of_uint x, of_uint y)):t)
+
+let no_check_mulc x y =
+    of_pair(Uint31.mulc (to_uint x) (to_uint y))
+
+let mulc accu x y =
+  if is_int x && is_int y then no_check_mulc x y
+  else accu x y
+
+let no_check_diveucl x y =
+  let i1, i2 = to_uint x, to_uint y in
+  of_pair(Uint31.div i1 i2, Uint31.rem i1 i2)
+
+let diveucl accu x y =
+  if is_int x && is_int y then no_check_diveucl x y
+  else accu x y
+
+let no_check_div21 x y z =
+  let i1, i2, i3 = to_uint x, to_uint y, to_uint z in
+  of_pair (Uint31.div21 i1 i2 i3)
+
+let div21 accu x y z =
+  if is_int x && is_int y && is_int z then no_check_div21 x y z
+  else accu x y z
+
+let no_check_addmuldiv x y z =
+  let p, i, j = to_uint x, to_uint y, to_uint z in
+  let p' = Uint31.to_int p in
+  of_uint (Uint31.l_or 
+	     (Uint31.l_sl i p) 
+	     (Uint31.l_sr j (Uint31.of_int (31 - p'))))
+
+let addmuldiv accu x y z =
+  if is_int x && is_int y && is_int z then no_check_addmuldiv x y z
+  else accu x y z
+
+
+type coq_bool =
+  | Baccu of t
+  | Btrue
+  | Bfalse
+
+type coq_cmp =
+  | CmpAccu of t
+  | CmpEq 
+  | CmpLt
+  | CmpGt
+
+let no_check_eq x y =     
+  mk_bool (Uint31.equal (to_uint x) (to_uint y))
+
+let eq accu x y =
+  if is_int x && is_int y then no_check_eq x y
+  else accu x y
+
+let no_check_lt x y =
+  mk_bool (Uint31.lt (to_uint x) (to_uint y))
+
+let lt accu x y =
+  if is_int x && is_int y then no_check_lt x y
+  else accu x y
+
+let no_check_le x y =
+  mk_bool (Uint31.le (to_uint x) (to_uint y))
+
+let le accu x y =
+  if is_int x && is_int y then no_check_le x y
+  else accu x y
+
+let no_check_compare x y =
+  match Uint31.compare (to_uint x) (to_uint y) with
+  | x when x < 0 -> (Obj.magic CmpLt:t)
+  | 0 -> (Obj.magic CmpEq:t)
+  | _ -> (Obj.magic CmpGt:t)
+
+let compare accu x y =
+  if is_int x && is_int y then no_check_compare x y
+  else accu x y
+
+let hobcnv = Array.init 256 (fun i -> Printf.sprintf "%02x" i)
+let bohcnv = Array.init 256 (fun i -> i -
+                                      (if 0x30 <= i then 0x30 else 0) -
+                                      (if 0x41 <= i then 0x7 else 0) -
+                                      (if 0x61 <= i then 0x20 else 0))
+
+let hex_of_bin ch = hobcnv.(int_of_char ch)
+let bin_of_hex s = char_of_int (bohcnv.(int_of_char s.[0]) * 16 + bohcnv.(int_of_char s.[1]))
+
+let str_encode expr =
+  let mshl_expr = Marshal.to_string expr [] in
+  let payload = Buffer.create (String.length mshl_expr * 2) in
+  String.iter (fun c -> Buffer.add_string payload (hex_of_bin c)) mshl_expr;
+  Buffer.contents payload
+
+let str_decode s =
+  let mshl_expr_len = String.length s / 2 in
+  let mshl_expr = Buffer.create mshl_expr_len in
+  let buf = String.create 2 in
+  for i = 0 to mshl_expr_len - 1 do
+    String.blit s (2*i) buf 0 2;
+    Buffer.add_char mshl_expr (bin_of_hex buf)
+  done;
+  Marshal.from_string (Buffer.contents mshl_expr) 0
+
+(** Retroknowledge, to be removed when we switch to primitive integers *)
+
+(* This will be unsafe with 63-bits integers *)
+let digit_to_uint d = (Obj.magic d : Uint31.t)
+
+let mk_I31_accu c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17
+		  x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 =
+  if is_int x0 && is_int x1 && is_int x2 && is_int x3 && is_int x4 && is_int x5
+     && is_int x6 && is_int x7 && is_int x8 && is_int x9 && is_int x10
+     && is_int x11 && is_int x12 && is_int x13 && is_int x14 && is_int x15
+     && is_int x16 && is_int x17 && is_int x18 && is_int x19 && is_int x20
+     && is_int x21 && is_int x22 && is_int x23 && is_int x24 && is_int x25
+     && is_int x26 && is_int x27 && is_int x28 && is_int x29 && is_int x30
+  then
+    let r = digit_to_uint x0 in
+    let r = Uint31.add_digit r (digit_to_uint x1) in
+    let r = Uint31.add_digit r (digit_to_uint x2) in
+    let r = Uint31.add_digit r (digit_to_uint x3) in
+    let r = Uint31.add_digit r (digit_to_uint x4) in
+    let r = Uint31.add_digit r (digit_to_uint x5) in
+    let r = Uint31.add_digit r (digit_to_uint x6) in
+    let r = Uint31.add_digit r (digit_to_uint x7) in
+    let r = Uint31.add_digit r (digit_to_uint x8) in
+    let r = Uint31.add_digit r (digit_to_uint x9) in
+    let r = Uint31.add_digit r (digit_to_uint x10) in
+    let r = Uint31.add_digit r (digit_to_uint x11) in
+    let r = Uint31.add_digit r (digit_to_uint x12) in
+    let r = Uint31.add_digit r (digit_to_uint x13) in
+    let r = Uint31.add_digit r (digit_to_uint x14) in
+    let r = Uint31.add_digit r (digit_to_uint x15) in
+    let r = Uint31.add_digit r (digit_to_uint x16) in
+    let r = Uint31.add_digit r (digit_to_uint x17) in
+    let r = Uint31.add_digit r (digit_to_uint x18) in
+    let r = Uint31.add_digit r (digit_to_uint x19) in
+    let r = Uint31.add_digit r (digit_to_uint x20) in
+    let r = Uint31.add_digit r (digit_to_uint x21) in
+    let r = Uint31.add_digit r (digit_to_uint x22) in
+    let r = Uint31.add_digit r (digit_to_uint x23) in
+    let r = Uint31.add_digit r (digit_to_uint x24) in
+    let r = Uint31.add_digit r (digit_to_uint x25) in
+    let r = Uint31.add_digit r (digit_to_uint x26) in
+    let r = Uint31.add_digit r (digit_to_uint x27) in
+    let r = Uint31.add_digit r (digit_to_uint x28) in
+    let r = Uint31.add_digit r (digit_to_uint x29) in
+    let r = Uint31.add_digit r (digit_to_uint x30) in
+    mk_uint r
+  else
+    c x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
+      x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
+
+let decomp_uint c v =
+  if is_int v then
+    let r = ref c in
+    let v = val_to_int v in
+    for i = 30 downto 0 do
+      r := (!r) (mk_int ((v lsr i) land 1));
+    done;
+    !r
+  else v
diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli
new file mode 100644
index 00000000..79e35d4a
--- /dev/null
+++ b/kernel/nativevalues.mli
@@ -0,0 +1,187 @@
+(************************************************************************)
+(*  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 Term
+open Names
+
+(** This modules defines the representation of values internally used by
+the native compiler. Be careful when removing apparently dead code from this
+interface, as it may be used by programs generated at runtime. *)
+
+type t = t -> t
+
+type accumulator
+
+type tag = int
+type arity = int
+
+type reloc_table = (tag * arity) array
+
+type annot_sw = {
+    asw_ind : inductive;
+    asw_ci : case_info;
+    asw_reloc : reloc_table;
+    asw_finite : bool;
+    asw_prefix : string
+  }
+
+val eq_annot_sw : annot_sw -> annot_sw -> bool
+
+val hash_annot_sw : annot_sw -> int
+
+type sort_annot = string * int
+      
+type rec_pos = int array
+
+val eq_rec_pos : rec_pos -> rec_pos -> bool
+
+type atom =
+  | Arel of int
+  | Aconstant of pconstant
+  | Aind of pinductive
+  | Asort of sorts
+  | Avar of identifier
+  | Acase of annot_sw * accumulator * t * (t -> t) 
+  | Afix of t array * t array * rec_pos * int 
+  | Acofix of t array * t array * int * t
+  | Acofixe of t array * t array * int * t
+  | Aprod of name * t * (t -> t)
+  | Ameta of metavariable * t
+  | Aevar of existential * t
+  | Aproj of constant * accumulator
+
+(* Constructors *)
+
+val mk_accu : atom -> t
+val mk_rel_accu : int -> t
+val mk_rels_accu : int -> int -> t array
+val mk_constant_accu : constant -> Univ.Level.t array -> t
+val mk_ind_accu : inductive -> Univ.Level.t array -> t
+val mk_sort_accu : sorts -> Univ.Level.t array -> t
+val mk_var_accu : identifier -> t
+val mk_sw_accu : annot_sw -> accumulator -> t -> (t -> t)
+val mk_prod_accu : name -> t -> t -> t
+val mk_fix_accu : rec_pos  -> int -> t array -> t array -> t
+val mk_cofix_accu : int -> t array -> t array -> t
+val mk_meta_accu : metavariable -> t
+val mk_evar_accu : existential -> t -> t
+val mk_proj_accu : constant -> accumulator -> t
+val upd_cofix : t -> t -> unit
+val force_cofix : t -> t 
+val mk_const : tag -> t
+val mk_block : tag -> t array -> t
+
+val mk_bool : bool -> t
+val mk_int : int -> t
+val mk_uint : Uint31.t -> t
+
+val napply : t -> t array -> t
+(* Functions over accumulators *)
+
+val dummy_value : unit -> t
+val atom_of_accu : accumulator -> atom
+val args_of_accu : accumulator -> t list
+val accu_nargs : accumulator -> int
+
+val cast_accu : t -> accumulator
+(* Functions over block: i.e constructors *)
+    
+type block
+      
+val block_size : block -> int
+val block_field : block -> int -> t
+val block_tag : block -> int
+
+
+
+(* kind_of_value *)
+
+type kind_of_value =
+  | Vaccu of accumulator
+  | Vfun of (t -> t)
+  | Vconst of int
+  | Vblock of block
+
+val kind_of_value : t -> kind_of_value
+
+(* *)
+val is_accu : t -> bool
+
+val str_encode : 'a -> string
+val str_decode : string -> 'a
+
+(** Support for machine integers *)
+
+val val_to_int : t -> int
+val is_int : t -> bool
+
+(* function with check *)
+val head0 : t -> t -> t
+val tail0 : t -> t -> t
+
+val add : t -> t -> t -> t
+val sub : t -> t -> t -> t
+val mul : t -> t -> t -> t
+val div : t -> t -> t -> t
+val rem : t -> t -> t -> t
+
+val l_sr  : t -> t -> t -> t
+val l_sl  : t -> t -> t -> t
+val l_and : t -> t -> t -> t
+val l_xor : t -> t -> t -> t
+val l_or  : t -> t -> t -> t
+
+val addc      : t -> t -> t -> t
+val subc      : t -> t -> t -> t
+val addcarryc : t -> t -> t -> t
+val subcarryc : t -> t -> t -> t
+
+val mulc    : t -> t -> t -> t
+val diveucl : t -> t -> t -> t
+
+val div21     : t -> t -> t -> t -> t
+val addmuldiv : t -> t -> t -> t -> t
+
+val eq      : t -> t -> t -> t
+val lt      : t -> t -> t -> t
+val le      : t -> t -> t -> t
+val compare : t -> t -> t -> t 
+
+(* Function without check *)
+val no_check_head0 : t -> t
+val no_check_tail0 : t -> t
+
+val no_check_add : t -> t -> t
+val no_check_sub : t -> t -> t
+val no_check_mul : t -> t -> t
+val no_check_div : t -> t -> t
+val no_check_rem : t -> t -> t
+
+val no_check_l_sr  : t -> t -> t
+val no_check_l_sl  : t -> t -> t
+val no_check_l_and : t -> t -> t
+val no_check_l_xor : t -> t -> t
+val no_check_l_or  : t -> t -> t
+
+val no_check_addc      : t -> t -> t
+val no_check_subc      : t -> t -> t
+val no_check_addcarryc : t -> t -> t
+val no_check_subcarryc : t -> t -> t
+
+val no_check_mulc    : t -> t -> t
+val no_check_diveucl : t -> t -> t
+
+val no_check_div21     : t -> t -> t -> t
+val no_check_addmuldiv : t -> t -> t -> t
+
+val no_check_eq      : t -> t -> t
+val no_check_lt      : t -> t -> t
+val no_check_le      : t -> t -> t
+val no_check_compare : t -> t -> t 
+
+val mk_I31_accu : t
+val decomp_uint : t -> t -> t
diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml
new file mode 100644
index 00000000..9f4361f4
--- /dev/null
+++ b/kernel/opaqueproof.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 Names
+open Univ
+open Term
+open Mod_subst
+
+type work_list = (Instance.t * Id.t array) Cmap.t * 
+  (Instance.t * Id.t array) Mindmap.t
+
+type cooking_info = { 
+  modlist : work_list; 
+  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+type proofterm = (constr * Univ.universe_context_set) Future.computation
+type opaque =
+  | Indirect of substitution list * DirPath.t * int (* subst, lib, index *)
+  | Direct of cooking_info list * proofterm
+type opaquetab = (cooking_info list * proofterm) Int.Map.t * DirPath.t
+let empty_opaquetab = Int.Map.empty, DirPath.initial
+
+(* hooks *)
+let default_get_opaque dp _ =
+  Errors.error
+    ("Cannot access opaque proofs in library " ^ DirPath.to_string dp)
+let default_get_univ dp _ =
+  Errors.error
+    ("Cannot access universe constraints of opaque proofs in library " ^
+    DirPath.to_string dp)
+
+let get_opaque = ref default_get_opaque
+let get_univ = ref default_get_univ
+
+let set_indirect_opaque_accessor f = (get_opaque := f)
+let set_indirect_univ_accessor f = (get_univ := f)
+(* /hooks *)
+
+let create cu = Direct ([],cu)
+
+let turn_indirect dp o (prfs,odp) = match o with
+  | Indirect _ -> Errors.anomaly (Pp.str "Already an indirect opaque")
+  | Direct (d,cu) ->
+      let cu = Future.chain ~pure:true cu (fun (c, u) -> hcons_constr c, u) in
+      let id = Int.Map.cardinal prfs in
+      let prfs = Int.Map.add id (d,cu) prfs in
+      let ndp =
+        if DirPath.equal dp odp then odp
+        else if DirPath.equal odp DirPath.initial then dp
+        else Errors.anomaly
+          (Pp.str "Using the same opaque table for multiple dirpaths") in
+      Indirect ([],dp,id), (prfs, ndp)
+
+let subst_opaque sub = function
+  | Indirect (s,dp,i) -> Indirect (sub::s,dp,i)
+  | Direct _ -> Errors.anomaly (Pp.str "Substituting a Direct opaque")
+
+let iter_direct_opaque f = function
+  | Indirect _ -> Errors.anomaly (Pp.str "Not a direct opaque")
+  | Direct (d,cu) ->
+      Direct (d,Future.chain ~pure:true cu (fun (c, u) -> f c; c, u))
+
+let discharge_direct_opaque ~cook_constr ci = function
+  | Indirect _ -> Errors.anomaly (Pp.str "Not a direct opaque")
+  | Direct (d,cu) ->
+      Direct (ci::d,Future.chain ~pure:true cu (fun (c, u) -> cook_constr c, u))
+
+let join_opaque (prfs,odp) = function
+  | Direct (_,cu) -> ignore(Future.join cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp then
+        let fp = snd (Int.Map.find i prfs) in
+        ignore(Future.join fp)
+
+let uuid_opaque (prfs,odp) = function
+  | Direct (_,cu) -> Some (Future.uuid cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then Some (Future.uuid (snd (Int.Map.find i prfs)))
+      else None
+
+let force_proof (prfs,odp) = function
+  | Direct (_,cu) ->
+      fst(Future.force cu)
+  | Indirect (l,dp,i) ->
+      let pt =
+        if DirPath.equal dp odp
+        then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst
+        else !get_opaque dp i in
+      let c = Future.force pt in
+      force_constr (List.fold_right subst_substituted l (from_val c))
+
+let force_constraints (prfs,odp) = function
+  | Direct (_,cu) -> snd(Future.force cu)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then snd (Future.force (snd (Int.Map.find i prfs)))
+      else match !get_univ dp i with
+        | None -> Univ.ContextSet.empty
+        | Some u -> Future.force u
+
+let get_constraints (prfs,odp) = function
+  | Direct (_,cu) -> Some(Future.chain ~pure:true cu snd)
+  | Indirect (_,dp,i) ->
+      if DirPath.equal dp odp
+      then Some(Future.chain ~pure:true (snd (Int.Map.find i prfs)) snd)
+      else !get_univ dp i
+
+let get_proof (prfs,odp) = function
+  | Direct (_,cu) -> Future.chain ~pure:true cu fst
+  | Indirect (l,dp,i) ->
+      let pt =
+        if DirPath.equal dp odp
+        then Future.chain ~pure:true (snd (Int.Map.find i prfs)) fst
+        else !get_opaque dp i in
+      Future.chain ~pure:true pt (fun c ->
+        force_constr (List.fold_right subst_substituted l (from_val c)))
+ 
+module FMap = Future.UUIDMap
+
+let a_constr = Future.from_val (Term.mkRel 1)
+let a_univ = Future.from_val Univ.ContextSet.empty
+let a_discharge : cooking_info list = []
+
+let dump (otab,_) =
+  let n = Int.Map.cardinal otab in
+  let opaque_table = Array.make n a_constr in
+  let univ_table = Array.make n a_univ in
+  let disch_table = Array.make n a_discharge in
+  let f2t_map = ref FMap.empty in
+  Int.Map.iter (fun n (d,cu) ->
+    let c, u = Future.split2 ~greedy:true cu in
+    Future.sink u;
+    Future.sink c;
+    opaque_table.(n) <- c;
+    univ_table.(n) <- u;
+    disch_table.(n) <- d;
+    f2t_map := FMap.add (Future.uuid cu) n !f2t_map)
+  otab;
+  opaque_table, univ_table, disch_table, !f2t_map
diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli
new file mode 100644
index 00000000..87cebd62
--- /dev/null
+++ b/kernel/opaqueproof.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  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 Names
+open Term
+open Mod_subst
+open Int
+
+(** This module implements the handling of opaque proof terms.
+    Opauqe proof terms are special since:
+    - they can be lazily computed and substituted
+    - they are stoked in an optionally loaded segment of .vo files
+    An [opaque] proof terms holds the real data until fully discharged.
+    In this case it is called [direct].
+    When it is [turn_indirect] the data is relocated to an opaque table
+    and the [opaque] is turned into an index. *)
+
+type proofterm = (constr * Univ.universe_context_set) Future.computation
+type opaquetab
+type opaque
+
+val empty_opaquetab : opaquetab
+
+(** From a [proofterm] to some [opaque]. *)
+val create : proofterm -> opaque
+
+(** Turn a direct [opaque] into an indirect one, also hashconses constr.
+ *  The integer is an hint of the maximum id used so far *)
+val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab
+
+(** From a [opaque] back to a [constr]. This might use the
+    indirect opaque accessor configured below. *)
+val force_proof : opaquetab -> opaque -> constr
+val force_constraints : opaquetab -> opaque -> Univ.universe_context_set
+val get_proof : opaquetab -> opaque -> Term.constr Future.computation
+val get_constraints :
+  opaquetab -> opaque -> Univ.universe_context_set Future.computation option
+
+val subst_opaque : substitution -> opaque -> opaque
+val iter_direct_opaque : (constr -> unit) -> opaque -> opaque
+
+type work_list = (Univ.Instance.t * Id.t array) Cmap.t * 
+  (Univ.Instance.t * Id.t array) Mindmap.t
+
+type cooking_info = { 
+  modlist : work_list; 
+  abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } 
+
+(* The type has two caveats:
+   1) cook_constr is defined after
+   2) we have to store the input in the [opaque] in order to be able to
+      discharge it when turning a .vi into a .vo *)
+val discharge_direct_opaque :
+  cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque
+
+val uuid_opaque : opaquetab -> opaque -> Future.UUID.t option
+val join_opaque : opaquetab -> opaque -> unit
+
+val dump : opaquetab ->
+  Constr.t Future.computation array *
+  Univ.universe_context_set Future.computation array *
+  cooking_info list array *
+  int Future.UUIDMap.t
+
+(** When stored indirectly, opaque terms are indexed by their library
+    dirpath and an integer index. The following two functions activate
+    this indirect storage, by telling how to store and retrieve terms.
+    Default creator always returns [None], preventing the creation of
+    any indirect link, and default accessor always raises an error.
+*)
+
+val set_indirect_opaque_accessor :
+  (DirPath.t -> int -> Term.constr Future.computation) -> unit
+val set_indirect_univ_accessor :
+  (DirPath.t -> int -> Univ.universe_context_set Future.computation option) -> unit
+
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index 6ef1039e..557ed3d7 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.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        *)
@@ -15,36 +15,55 @@
 
 open Util
 open Names
-open Sign
+open Context
 open Univ
 open Term
 open Declarations
 
 (* The type of environments. *)
 
+(* The key attached to each constant is used by the VM to retrieve previous *)
+(* evaluations of the constant. It is essentially an index in the symbols table *)
+(* used by the VM. *)
+type key = int Ephemeron.key option ref 
 
-type key = int option ref
+(** Linking information for the native compiler. *)
 
-type constant_key = constant_body * key
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type constant_key = constant_body * (link_info ref * key)
+
+type mind_key = mutual_inductive_body * link_info ref
 
 type globals = {
   env_constants : constant_key Cmap_env.t;
-  env_inductives : mutual_inductive_body Mindmap_env.t;
+  env_inductives : mind_key Mindmap_env.t;
   env_modules : module_body MPmap.t;
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
-  env_engagement : engagement option
+  env_engagement : engagement option;
+  env_type_in_type : bool
 }
 
 type val_kind =
-    | VKvalue of values * Idset.t
+    | VKvalue of (values * Id.Set.t) Ephemeron.key
     | VKnone
 
 type lazy_val = val_kind ref
 
-type named_vals = (identifier * lazy_val) list
+let force_lazy_val vk = match !vk with
+| VKnone -> None
+| VKvalue v -> try Some (Ephemeron.get v) with Ephemeron.InvalidKey -> None
+
+let dummy_lazy_val () = ref VKnone
+let build_lazy_val vk key = vk := VKvalue (Ephemeron.create key)
+
+type named_vals = (Id.t * lazy_val) list
 
 type env = {
   env_globals       : globals;
@@ -54,7 +73,10 @@ type env = {
   env_rel_val       : lazy_val list;
   env_nb_rel        : int;
   env_stratification : stratification;
-  retroknowledge : Retroknowledge.retroknowledge }
+  env_conv_oracle   : Conv_oracle.oracle;
+  retroknowledge : Retroknowledge.retroknowledge;
+  indirect_pterms : Opaqueproof.opaquetab;
+}
 
 type named_context_val = named_context * named_vals
 
@@ -73,8 +95,11 @@ let empty_env = {
   env_nb_rel = 0;
   env_stratification = {
     env_universes = initial_universes;
-    env_engagement = None };
-  retroknowledge = Retroknowledge.initial_retroknowledge }
+    env_engagement = None;
+    env_type_in_type = false};
+  env_conv_oracle = Conv_oracle.empty;
+  retroknowledge = Retroknowledge.initial_retroknowledge;
+  indirect_pterms = Opaqueproof.empty_opaquetab }
 
 
 (* Rel context *)
@@ -90,12 +115,12 @@ let push_rel d env =
 
 let lookup_rel_val n env =
   try List.nth env.env_rel_val (n - 1)
-  with e when Errors.noncritical e -> raise Not_found
+  with Failure _ -> raise Not_found
 
 let env_of_rel n env =
   { env with
-    env_rel_context = Util.list_skipn n env.env_rel_context;
-    env_rel_val = Util.list_skipn n env.env_rel_val;
+    env_rel_context = Util.List.skipn n env.env_rel_context;
+    env_rel_val = Util.List.skipn n env.env_rel_val;
     env_nb_rel = env.env_nb_rel - n
   }
 
@@ -104,21 +129,27 @@ let env_of_rel n env =
 let push_named_context_val d (ctxt,vals) =
   let id,_,_ = d in
   let rval = ref VKnone in
-    Sign.add_named_decl d ctxt, (id,rval)::vals
-
-exception ASSERT of rel_context
+    add_named_decl d ctxt, (id,rval)::vals
 
 let push_named d env =
 (*  if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context);
   assert (env.env_rel_context = []); *)
   let id,body,_ = d in
   let rval = ref VKnone in
-    { env with
-      env_named_context = Sign.add_named_decl d env.env_named_context;
-      env_named_vals =  (id,rval):: env.env_named_vals }
+  { env_globals = env.env_globals;
+    env_named_context = Context.add_named_decl d env.env_named_context;
+    env_named_vals = (id, rval) :: env.env_named_vals;
+    env_rel_context = env.env_rel_context;
+    env_rel_val = env.env_rel_val;
+    env_nb_rel = env.env_nb_rel;
+    env_stratification = env.env_stratification;
+    env_conv_oracle = env.env_conv_oracle;
+    retroknowledge = env.retroknowledge;
+    indirect_pterms = env.indirect_pterms;
+  }
 
 let lookup_named_val id env =
-  snd(List.find (fun (id',_) -> id = id') env.env_named_vals)
+  snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals)
 
 (* Warning all the names should be different *)
 let env_of_named id env = env
@@ -133,5 +164,7 @@ let lookup_constant kn env =
 
 (* Mutual Inductives *)
 let lookup_mind kn env =
-  Mindmap_env.find kn env.env_globals.env_inductives
+  fst (Mindmap_env.find kn env.env_globals.env_inductives)
 
+let lookup_mind_key kn env =
+  Mindmap_env.find kn env.env_globals.env_inductives
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 85188b7b..03ac41b4 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -1,43 +1,49 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Sign
-open Univ
 open Term
+open Context
 open Declarations
+open Univ
 
 (** The type of environments. *)
 
+type link_info =
+  | Linked of string
+  | LinkedInteractive of string
+  | NotLinked
+
+type key = int Ephemeron.key option ref 
 
-type key = int option ref
+type constant_key = constant_body * (link_info ref * key)
 
-type constant_key = constant_body * key
+type mind_key = mutual_inductive_body * link_info ref
 
 type globals = {
   env_constants : constant_key Cmap_env.t;
-  env_inductives : mutual_inductive_body Mindmap_env.t;
+  env_inductives : mind_key Mindmap_env.t;
   env_modules : module_body MPmap.t;
   env_modtypes : module_type_body MPmap.t}
 
 type stratification = {
   env_universes : universes;
-  env_engagement : engagement option
+  env_engagement : engagement option;
+  env_type_in_type : bool
 }
 
-type val_kind =
-    | VKvalue of values * Idset.t
-    | VKnone
+type lazy_val
 
-type lazy_val = val_kind ref
+val force_lazy_val : lazy_val -> (values * Id.Set.t) option
+val dummy_lazy_val : unit -> lazy_val
+val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit
 
-type named_vals = (identifier * lazy_val) list
+type named_vals = (Id.t * lazy_val) list
 
 type env = {
     env_globals       : globals;
@@ -47,7 +53,10 @@ type env = {
     env_rel_val       : lazy_val list;
     env_nb_rel        : int;
     env_stratification : stratification;
-    retroknowledge : Retroknowledge.retroknowledge }
+    env_conv_oracle   : Conv_oracle.oracle;
+    retroknowledge : Retroknowledge.retroknowledge;
+    indirect_pterms : Opaqueproof.opaquetab;
+}
 
 type named_context_val = named_context * named_vals
 
@@ -67,8 +76,8 @@ val env_of_rel     : int -> env -> env
 val push_named_context_val  :
     named_declaration -> named_context_val -> named_context_val
 val push_named       : named_declaration -> env -> env
-val lookup_named_val : identifier -> env -> lazy_val
-val env_of_named     : identifier -> env -> env
+val lookup_named_val : Id.t -> env -> lazy_val
+val env_of_named     : Id.t -> env -> env
 
 (** Global constants *)
 
@@ -77,5 +86,5 @@ val lookup_constant_key : constant -> env -> constant_key
 val lookup_constant : constant -> env -> constant_body
 
 (** Mutual Inductives *)
+val lookup_mind_key : mutual_inductive -> env -> mind_key
 val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
-
diff --git a/kernel/primitives.ml b/kernel/primitives.ml
new file mode 100644
index 00000000..649eb125
--- /dev/null
+++ b/kernel/primitives.ml
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  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 t =
+  | Int31head0
+  | Int31tail0
+  | Int31add
+  | Int31sub
+  | Int31mul
+  | Int31div
+  | Int31mod
+(*
+  | Int31lsr
+  | Int31lsl
+ *)
+  | Int31land
+  | Int31lor
+  | Int31lxor
+  | Int31addc
+  | Int31subc
+  | Int31addcarryc
+  | Int31subcarryc
+  | Int31mulc
+  | Int31diveucl
+  | Int31div21
+  | Int31addmuldiv
+  | Int31eq
+  | Int31lt
+  | Int31le
+  | Int31compare
+
+let hash = function
+  | Int31head0 -> 1
+  | Int31tail0 -> 2
+  | Int31add -> 3
+  | Int31sub -> 4
+  | Int31mul -> 5
+  | Int31div -> 6
+  | Int31mod -> 7
+(*
+  | Int31lsr -> 8
+  | Int31lsl -> 9
+ *)
+  | Int31land -> 10
+  | Int31lor -> 11
+  | Int31lxor -> 12
+  | Int31addc -> 13
+  | Int31subc -> 14
+  | Int31addcarryc -> 15
+  | Int31subcarryc -> 16
+  | Int31mulc -> 17
+  | Int31diveucl -> 18
+  | Int31div21 -> 19
+  | Int31addmuldiv -> 20
+  | Int31eq -> 21
+  | Int31lt -> 22
+  | Int31le -> 23
+  | Int31compare -> 24
+
+let to_string = function
+  | Int31head0 -> "head0"
+  | Int31tail0 -> "tail0"
+  | Int31add -> "add"
+  | Int31sub -> "sub"
+  | Int31mul -> "mul"
+  | Int31div -> "div"
+  | Int31mod -> "mod"
+(*
+  | Int31lsr -> "l_sr"
+  | Int31lsl -> "l_sl"
+ *)
+  | Int31land -> "l_and"
+  | Int31lor -> "l_or"
+  | Int31lxor -> "l_xor"
+  | Int31addc -> "addc"
+  | Int31subc -> "subc"
+  | Int31addcarryc -> "addcarryc"
+  | Int31subcarryc -> "subcarryc"
+  | Int31mulc -> "mulc"
+  | Int31diveucl -> "diveucl"
+  | Int31div21 -> "div21"
+  | Int31addmuldiv -> "addmuldiv"
+  | Int31eq -> "eq"
+  | Int31lt -> "lt"
+  | Int31le -> "le"
+  | Int31compare -> "compare"
diff --git a/toplevel/ide_slave.mli b/kernel/primitives.mli
index 8b0ad168..9f99264a 100644
--- a/toplevel/ide_slave.mli
+++ b/kernel/primitives.mli
@@ -1,17 +1,39 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** [Ide_slave] : an implementation of [Ide_intf], i.e. mainly an interp
-    function and a rewind function. This specialized loop is triggered
-    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
-    the only one using this mode, but we try here to be as generic as
-    possible, so this may change in the future... *)
+type t =
+  | Int31head0
+  | Int31tail0
+  | Int31add
+  | Int31sub
+  | Int31mul
+  | Int31div
+  | Int31mod
+(*
+  | Int31lsr
+  | Int31lsl
+ *)
+  | Int31land
+  | Int31lor
+  | Int31lxor
+  | Int31addc
+  | Int31subc
+  | Int31addcarryc
+  | Int31subcarryc
+  | Int31mulc
+  | Int31diveucl
+  | Int31div21
+  | Int31addmuldiv
+  | Int31eq
+  | Int31lt
+  | Int31le
+  | Int31compare
 
-val init_stdout : unit -> unit
+val hash : t -> int
 
-val loop : unit -> unit
+val to_string : t -> string
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 9982d4ba..4153b323 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.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        *)
@@ -15,23 +15,29 @@
 (* Equal inductive types by Jacek Chrzaszcz as part of the module
    system, Aug 2002 *)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Univ
-open Declarations
 open Environ
 open Closure
 open Esubst
 
-let unfold_reference ((ids, csts), infos) k =
-  match k with
-    | VarKey id when not (Idpred.mem id ids) -> None
-    | ConstKey cst when not (Cpred.mem cst csts) -> None
-    | _ -> unfold_reference infos k
+let left2right = ref false
 
+let conv_key k =
+  match k with
+    VarKey id -> 
+    VarKey id
+  | ConstKey (cst,_) -> 
+     ConstKey cst
+  | RelKey n -> RelKey n
+		       
 let rec is_empty_stack = function
-    [] -> true
+  [] -> true
   | Zupdate _::s -> is_empty_stack s
   | Zshift _::s -> is_empty_stack s
   | _ -> false
@@ -51,20 +57,24 @@ let el_stack el stk =
 let compare_stack_shape stk1 stk2 =
   let rec compare_rec bal stk1 stk2 =
   match (stk1,stk2) with
-      ([],[]) -> bal=0
+      ([],[]) -> Int.equal bal 0
     | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2
     | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2
     | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2
     | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2
-    | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) ->
-        bal=0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
+    | (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) ->
+        Int.equal 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
+        Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
     | (_,_) -> false in
   compare_rec 0 stk1 stk2
 
 type lft_constr_stack_elt =
     Zlapp of (lift * fconstr) array
+  | Zlproj of 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
@@ -83,9 +93,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,e),(l,pstk)) ->
+                (l,Zlcase(ci,l,mk_clos e p,Array.map (mk_clos e) br)::pstk)
             | (Zcase(ci,p,br),(l,pstk)) ->
                 (l,Zlcase(ci,l,p,br)::pstk)) in
   snd (pure_rec lfts stk)
@@ -94,17 +108,17 @@ let pure_stack lfts stk =
 (*                   Reduction Functions                                    *)
 (****************************************************************************)
 
-let whd_betaiota t =
-  whd_val (create_clos_infos betaiota empty_env) (inject t)
+let whd_betaiota env t =
+  whd_val (create_clos_infos betaiota env) (inject t)
 
-let nf_betaiota t =
-  norm_val (create_clos_infos betaiota empty_env) (inject t)
+let nf_betaiota env t =
+  norm_val (create_clos_infos betaiota env) (inject t)
 
-let whd_betaiotazeta x =
+let whd_betaiotazeta env x =
   match kind_of_term x with
     | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _|
        Prod _|Lambda _|Fix _|CoFix _) -> x
-    | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x)
+    | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x)
 
 let whd_betadeltaiota env t =
   match kind_of_term t with
@@ -126,14 +140,14 @@ let beta_appvect c v =
         Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl
       | _ -> applist (substl env t, stack) in
   stacklam [] c (Array.to_list v)
-
+    
 let betazeta_appvect n c v =
   let rec stacklam n env t stack =
-    if n = 0 then applist (substl env t, stack) else
+    if Int.equal n 0 then applist (substl env t, stack) else
     match kind_of_term t, stack with
         Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
       | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack
-      | _ -> anomaly "Not enough lambda/let's" in
+      | _ -> anomaly (Pp.str "Not enough lambda/let's") in
   stacklam n [] c (Array.to_list v)
 
 (********************************************************************)
@@ -141,19 +155,76 @@ let betazeta_appvect n c v =
 (********************************************************************)
 
 (* Conversion utility functions *)
-type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
-type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints
+type 'a conversion_function = env -> 'a -> 'a -> unit
+type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
+type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a trans_universe_conversion_function = 
+  Names.transparent_state -> 'a universe_conversion_function
 
 exception NotConvertible
 exception NotConvertibleVect of int
 
+
+(* Convertibility of sorts *)
+
+(* The sort cumulativity is
+
+    Prop <= Set <= Type 1 <= ... <= Type i <= ...
+
+    and this holds whatever Set is predicative or impredicative
+*)
+
+type conv_pb =
+  | CONV
+  | CUMUL
+
+let is_cumul = function CUMUL -> true | CONV -> false
+
+type 'a universe_compare = 
+  { (* Might raise NotConvertible *)
+    compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a;
+    compare_instances: bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a;
+  } 
+
+type 'a universe_state = 'a * 'a universe_compare
+
+type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
+
+type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+
+let sort_cmp_universes env pb s0 s1 (u, check) =
+  (check.compare env pb s0 s1 u, check)
+
+let convert_instances flex u u' (s, check) =
+  (check.compare_instances flex u u' s, check)
+
+let conv_table_key infos k1 k2 cuniv =
+  if k1 == k2 then cuniv else
+  match k1, k2 with
+  | ConstKey (cst, u), ConstKey (cst', u') when eq_constant_key cst cst' ->
+    if Univ.Instance.equal u u' then cuniv
+    else 
+      let flex = evaluable_constant cst (info_env infos) 
+	&& RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst)
+      in convert_instances flex u u' cuniv
+  | VarKey id, VarKey id' when Id.equal id id' -> cuniv
+  | RelKey n, RelKey n' when Int.equal n n' -> cuniv
+  | _ -> raise NotConvertible
+
 let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
   let rec cmp_rec pstk1 pstk2 cuniv =
     match (pstk1,pstk2) with
       | (z1::s1, z2::s2) ->
           let cu1 = cmp_rec s1 s2 cuniv in
           (match (z1,z2) with
-            | (Zlapp a1,Zlapp a2) -> array_fold_right2 f a1 a2 cu1
+            | (Zlapp a1,Zlapp a2) -> 
+	      if !left2right then
+		Array.fold_left2 (fun cu x y -> f x y cu) cu1 a1 a2
+	      else Array.fold_right2 f a1 a2 cu1
+	    | (Zlproj (c1,l1),Zlproj (c2,l2)) -> 
+	      if not (eq_constant c1 c2) then 
+		raise NotConvertible
+	      else cu1
             | (Zlfix(fx1,a1),Zlfix(fx2,a2)) ->
                 let cu2 = f fx1 fx2 cu1 in
                 cmp_rec a1 a2 cu2
@@ -161,52 +232,21 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv =
                 if not (fmind ci1.ci_ind ci2.ci_ind) then
 		  raise NotConvertible;
 		let cu2 = f (l1,p1) (l2,p2) cu1 in
-                array_fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2
+                Array.fold_right2 (fun c1 c2 -> f (l1,c1) (l2,c2)) br1 br2 cu2
             | _ -> assert false)
       | _ -> cuniv in
   if compare_stack_shape stk1 stk2 then
     cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv
   else raise NotConvertible
 
-(* Convertibility of sorts *)
-
-(* The sort cumulativity is
-
-    Prop <= Set <= Type 1 <= ... <= Type i <= ...
-
-    and this holds whatever Set is predicative or impredicative
-*)
-
-type conv_pb =
-  | CONV
-  | CUMUL
-
-let sort_cmp pb s0 s1 cuniv =
-  match (s0,s1) with
-    | (Prop c1, Prop c2) when pb = CUMUL ->
-        if c1 = Null or c2 = Pos then cuniv   (* Prop <= Set *)
-        else raise NotConvertible
-    | (Prop c1, Prop c2) ->
-        if c1 = c2 then cuniv else raise NotConvertible
-    | (Prop c1, Type u) when pb = CUMUL -> assert (is_univ_variable u); cuniv
-    | (Type u1, Type u2) ->
-	assert (is_univ_variable u2);
-	(match pb with
-           | CONV -> enforce_eq u1 u2 cuniv
-	   | CUMUL -> enforce_geq u2 u1 cuniv)
-    | (_, _) -> raise NotConvertible
-
-
-let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint
-
-let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint
-
 let rec no_arg_available = function
   | [] -> true
   | Zupdate _ :: stk -> no_arg_available stk
   | Zshift _ :: stk -> no_arg_available stk
-  | Zapp v :: stk -> Array.length v = 0 && no_arg_available stk
+  | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk
+  | Zproj _ :: _ -> true
   | Zcase _ :: _ -> true
+  | ZcaseT _ :: _ -> true
   | Zfix _ :: _ -> true
 
 let rec no_nth_arg_available n = function
@@ -217,7 +257,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
@@ -225,30 +267,45 @@ 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 (_,_,p) :: _ -> 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 unfold_projection infos p c =
+  let unf = Projection.unfolded p in
+    if unf || RedFlags.red_set infos.i_flags (RedFlags.fCONST (Projection.constant p)) then
+      (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with
+      | Some pb -> 
+	let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+		       Projection.constant p) in
+	  Some (c, s)
+      | None -> None)
+  else None
+
 (* Conversion between  [lft1]term1 and [lft2]term2 *)
 let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv =
   eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
 
 (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
 and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
-  Util.check_for_interrupt ();
+  Control.check_for_interrupt ();
   (* First head reduce both terms *)
+  let whd = whd_stack (infos_with_reds infos betaiotazeta) in
   let rec whd_both (t1,stk1) (t2,stk2) =
-    let st1' = whd_stack (snd infos) t1 stk1 in
-    let st2' = whd_stack (snd infos) t2 stk2 in
+    let st1' = whd t1 stk1 in
+    let st2' = whd t2 stk2 in
     (* Now, whd_stack on term2 might have modified st1 (due to sharing),
        and st1 might not be in whnf anymore. If so, we iterate ccnv. *)
     if in_whnf st1' then (st1',st2') else whd_both st1' st2' in
@@ -263,143 +320,228 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
 	(match kind_of_term a1, kind_of_term a2 with
 	   | (Sort s1, Sort s2) ->
 	       if not (is_empty_stack v1 && is_empty_stack v2) then
-		 anomaly "conversion was given ill-typed terms (Sort)";
-	       sort_cmp cv_pb s1 s2 cuniv
+		 anomaly (Pp.str "conversion was given ill-typed terms (Sort)");
+	       sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv
 	   | (Meta n, Meta m) ->
-               if n=m
+               if Int.equal n m
 	       then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
                else raise NotConvertible
 	   | _ -> raise NotConvertible)
     | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) ->
-        if ev1=ev2 then
-          let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
+        if Evar.equal ev1 ev2 then
+          let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
           convert_vect l2r infos el1 el2
             (Array.map (mk_clos env1) args1)
-            (Array.map (mk_clos env2) args2) u1
+            (Array.map (mk_clos env2) args2) cuniv
         else raise NotConvertible
 
     (* 2 index known to be bound to no constant *)
     | (FRel n, FRel m) ->
-        if reloc_rel n el1 = reloc_rel m el2
+        if Int.equal (reloc_rel n el1) (reloc_rel m el2)
         then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
         else raise NotConvertible
 
     (* 2 constants, 2 local defined vars or 2 defined rels *)
     | (FFlex fl1, FFlex fl2) ->
-	(try (* try first intensional equality *)
-	  if eq_table_key fl1 fl2
-          then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
-          else raise NotConvertible
-        with NotConvertible ->
-          (* else the oracle tells which constant is to be expanded *)
-          let (app1,app2) =
-            if Conv_oracle.oracle_order l2r fl1 fl2 then
-              match unfold_reference infos fl1 with
-                | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
-                | None ->
-                    (match unfold_reference infos fl2 with
-                      | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
-		      | None -> raise NotConvertible)
-            else
-	      match unfold_reference infos fl2 with
-                | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2))
-                | None ->
-                    (match unfold_reference infos fl1 with
-                    | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
-		    | None -> raise NotConvertible) in
-          eqappr cv_pb l2r infos app1 app2 cuniv)
-
+      (try
+	 let cuniv = conv_table_key infos fl1 fl2 cuniv in
+	   convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+       with NotConvertible ->
+           (* else the oracle tells which constant is to be expanded *)
+	 let oracle = Closure.oracle_of_infos infos in
+         let (app1,app2) =
+           if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then
+	     match unfold_reference infos fl1 with
+             | Some def1 -> ((lft1, whd def1 v1), appr2)
+             | None ->
+               (match unfold_reference infos fl2 with
+               | Some def2 -> (appr1, (lft2, whd def2 v2))
+	       | None -> raise NotConvertible)
+           else
+	     match unfold_reference infos fl2 with
+             | Some def2 -> (appr1, (lft2, whd def2 v2))
+             | None ->
+               (match unfold_reference infos fl1 with
+               | Some def1 -> ((lft1, whd def1 v1), appr2)
+	       | None -> raise NotConvertible) 
+	 in
+           eqappr cv_pb l2r infos app1 app2 cuniv)
+
+    | (FProj (p1,c1), FProj (p2, c2)) ->
+      (* Projections: prefer unfolding to first-order unification,
+	 which will happen naturally if the terms c1, c2 are not in constructor
+	 form *)
+      (match unfold_projection infos p1 c1 with
+      | Some (def1,s1) -> 
+	eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv
+      | None ->
+	match unfold_projection infos p2 c2 with
+	| Some (def2,s2) ->
+	  eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv
+	| None -> 
+          if Constant.equal (Projection.constant p1) (Projection.constant p2)
+	     && compare_stack_shape v1 v2 then
+	    let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in
+	      convert_stacks l2r infos lft1 lft2 v1 v2 u1
+	  else (* Two projections in WHNF: unfold *)
+	    raise NotConvertible)
+
+    | (FProj (p1,c1), t2) ->
+      (match unfold_projection infos p1 c1 with
+      | Some (def1,s1) ->
+         eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv
+      | None -> 
+	 (match t2 with 
+	  | FFlex fl2 ->
+	     (match unfold_reference infos fl2 with
+              | Some def2 ->
+		 eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv
+              | None -> raise NotConvertible)
+	  | _ -> raise NotConvertible))
+      
+    | (t1, FProj (p2,c2)) ->
+      (match unfold_projection infos p2 c2 with
+      | Some (def2,s2) -> 
+         eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv
+      | None -> 
+	 (match t1 with 
+	  | FFlex fl1 ->
+	     (match unfold_reference infos fl1 with
+              | Some def1 ->
+		 eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv
+              | None -> raise NotConvertible)
+	  | _ -> raise NotConvertible))
+      
     (* other constructors *)
     | (FLambda _, FLambda _) ->
         (* Inconsistency: we tolerate that v1, v2 contain shift and update but
            we throw them away *)
         if not (is_empty_stack v1 && is_empty_stack v2) then
-	  anomaly "conversion was given ill-typed terms (FLambda)";
+	  anomaly (Pp.str "conversion was given ill-typed terms (FLambda)");
         let (_,ty1,bd1) = destFLambda mk_clos hd1 in
         let (_,ty2,bd2) = destFLambda mk_clos hd2 in
-        let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
-        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+        let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
+        ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv
 
     | (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
         if not (is_empty_stack v1 && is_empty_stack v2) then
-	  anomaly "conversion was given ill-typed terms (FProd)";
+	  anomaly (Pp.str "conversion was given ill-typed terms (FProd)");
 	(* Luo's system *)
-        let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
-        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1
+        let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
+        ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv
 
     (* Eta-expansion on the fly *)
     | (FLambda _, _) ->
-        if v1 <> [] then
-	  anomaly "conversion was given unreduced term (FLambda)";
+        let () = match v1 with
+        | [] -> ()
+        | _ ->
+          anomaly (Pp.str "conversion was given unreduced term (FLambda)")
+        in
         let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
 	eqappr CONV l2r infos
 	  (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv
     | (_, FLambda _) ->
-        if v2 <> [] then
-	  anomaly "conversion was given unreduced term (FLambda)";
+        let () = match v2 with
+        | [] -> ()
+        | _ ->
+	  anomaly (Pp.str "conversion was given unreduced term (FLambda)")
+	in
         let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
 	eqappr CONV l2r infos
 	  (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv
-
+	
     (* only one constant, defined var or defined rel *)
-    | (FFlex fl1, _)      ->
-        (match unfold_reference infos fl1 with
-           | Some def1 ->
-	       eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
-           | None -> raise NotConvertible)
-    | (_, FFlex fl2)      ->
-        (match unfold_reference infos fl2 with
-           | Some def2 ->
-	       eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
-           | None -> raise NotConvertible)
-
+    | (FFlex fl1, c2)      ->
+       (match unfold_reference infos fl1 with
+	| Some def1 ->
+	   eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv
+	| None -> 
+	   match c2 with
+	   | FConstruct ((ind2,j2),u2) ->
+	      (try
+	      let v2, v1 =
+		eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1)
+	      in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	      with Not_found -> raise NotConvertible)
+	   | _ -> raise NotConvertible)
+       
+    | (c1, FFlex fl2)      ->
+       (match unfold_reference infos fl2 with
+        | Some def2 ->
+	   eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv
+        | None -> 
+	   match c1 with
+	   | FConstruct ((ind1,j1),u1) ->
+ 	      (try let v1, v2 =
+	     	     eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2)
+	     	   in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	       with Not_found -> raise NotConvertible)
+	   | _ -> raise NotConvertible)
+       
     (* Inductive types:  MutInd MutConstruct Fix Cofix *)
 
-    | (FInd ind1, FInd ind2) ->
+    | (FInd (ind1,u1), FInd (ind2,u2)) ->
         if eq_ind ind1 ind2
 	then
-          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	  (let cuniv = convert_instances false u1 u2 cuniv in
+             convert_stacks l2r infos lft1 lft2 v1 v2 cuniv)
         else raise NotConvertible
 
-    | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
-	if j1 = j2 && eq_ind ind1 ind2
+    | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) ->
+	if Int.equal j1 j2 && eq_ind ind1 ind2
 	then
-          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+	  (let cuniv = convert_instances false u1 u2 cuniv in
+           convert_stacks l2r infos lft1 lft2 v1 v2 cuniv)
         else raise NotConvertible
-
-    | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
-	if op1 = op2
+	  
+    (* Eta expansion of records *)
+    | (FConstruct ((ind1,j1),u1), _) ->
+      (try
+    	 let v1, v2 =
+    	   eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2)
+    	 in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+       with Not_found -> raise NotConvertible)
+
+    | (_, FConstruct ((ind2,j2),u2)) ->
+      (try
+    	 let v2, v1 =
+    	   eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1)
+    	 in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+       with Not_found -> raise NotConvertible)
+
+    | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) ->
+	if Int.equal i1 i2 && Array.equal Int.equal op1 op2
 	then
 	  let n = Array.length cl1 in
           let fty1 = Array.map (mk_clos e1) tys1 in
           let fty2 = Array.map (mk_clos e2) tys2 in
           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-	  let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
-          let u2 =
+	  let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let cuniv =
             convert_vect l2r infos
-	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
-          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in
+          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
         else raise NotConvertible
 
     | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
-        if op1 = op2
+        if Int.equal op1 op2
         then
 	  let n = Array.length cl1 in
           let fty1 = Array.map (mk_clos e1) tys1 in
           let fty2 = Array.map (mk_clos e2) tys2 in
           let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
           let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
-          let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
-          let u2 =
+          let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+          let cuniv =
 	    convert_vect l2r infos
-	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
-          convert_stacks l2r infos lft1 lft2 v1 v2 u2
+	      (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in
+          convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
         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 *)
@@ -407,53 +549,193 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
 
 and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
   compare_stacks
-    (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c)
+    (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv)
     (eq_ind)
     lft1 stk1 lft2 stk2 cuniv
 
 and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
   let lv1 = Array.length v1 in
   let lv2 = Array.length v2 in
-  if lv1 = lv2
+  if Int.equal lv1 lv2
   then
-    let rec fold n univ =
-      if n >= lv1 then univ
+    let rec fold n cuniv =
+      if n >= lv1 then cuniv
       else
-        let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in
-        fold (n+1) u1 in
+        let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in
+        fold (n+1) cuniv in
     fold 0 cuniv
   else raise NotConvertible
 
-let clos_fconv trans cv_pb l2r evars env t1 t2 =
-  let infos = trans, create_clos_infos ~evars betaiotazeta env in
-  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint
+let clos_fconv trans cv_pb l2r evars env univs t1 t2 =
+  let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in
+  let infos = create_clos_infos ~evars reds env in
+  ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs
+
+
+let check_eq univs u u' = 
+  if not (check_eq univs u u') then raise NotConvertible
+
+let check_leq univs u u' = 
+  if not (check_leq univs u u') then raise NotConvertible
+
+let check_sort_cmp_universes env pb s0 s1 univs =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) when is_cumul pb ->
+      begin match c1, c2 with
+      | Null, _ | _, Pos -> () (* Prop <= Set *)
+      | _ -> raise NotConvertible
+      end
+    | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible
+    | (Prop c1, Type u) ->
+	if not (type_in_type env) then
+	let u0 = univ_of_sort s0 in
+	(match pb with
+	| CUMUL -> check_leq univs u0 u
+	| CONV -> check_eq univs u0 u)
+    | (Type u, Prop c) -> raise NotConvertible
+    | (Type u1, Type u2) ->
+        if not (type_in_type env) then
+	(match pb with
+	| CUMUL -> check_leq univs u1 u2
+	| CONV -> check_eq univs u1 u2)
+
+let checked_sort_cmp_universes env pb s0 s1 univs =
+  check_sort_cmp_universes env pb s0 s1 univs; univs
+
+let check_convert_instances _flex u u' univs =
+  if Univ.Instance.check_eq univs u u' then univs
+  else raise NotConvertible
+
+let checked_universes =
+  { compare = checked_sort_cmp_universes;
+    compare_instances = check_convert_instances }
+
+let infer_eq (univs, cstrs as cuniv) u u' =
+  if Univ.check_eq univs u u' then cuniv
+  else
+    univs, (Univ.enforce_eq u u' cstrs)
 
-let trans_fconv reds cv_pb l2r evars env t1 t2 =
-  if eq_constr t1 t2 then empty_constraint
-  else clos_fconv reds cv_pb l2r evars env t1 t2
+let infer_leq (univs, cstrs as cuniv) u u' =
+  if Univ.check_leq univs u u' then cuniv
+  else
+    let cstrs' = Univ.enforce_leq u u' cstrs in
+      univs, cstrs'
+
+let infer_cmp_universes env pb s0 s1 univs =
+  match (s0,s1) with
+    | (Prop c1, Prop c2) when is_cumul pb ->
+      begin match c1, c2 with
+      | Null, _ | _, Pos -> univs (* Prop <= Set *)
+      | _ -> raise NotConvertible
+      end
+    | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible
+    | (Prop c1, Type u) ->
+      let u0 = univ_of_sort s0 in
+	(match pb with
+	| CUMUL -> infer_leq univs u0 u
+	| CONV -> infer_eq univs u0 u)
+    | (Type u, Prop c) -> raise NotConvertible
+    | (Type u1, Type u2) ->
+        if not (type_in_type env) then
+	(match pb with
+	| CUMUL -> infer_leq univs u1 u2
+	| CONV -> infer_eq univs u1 u2)
+        else univs
+
+let infer_convert_instances flex u u' (univs,cstrs) =
+  (univs, Univ.enforce_eq_instances u u' cstrs)
+
+let infered_universes : (Univ.universes * Univ.Constraint.t) universe_compare = 
+  { compare = infer_cmp_universes;
+    compare_instances = infer_convert_instances }
+
+let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 =
+  let b = 
+    if cv_pb = CUMUL then leq_constr_univs univs t1 t2 
+    else eq_constr_univs univs t1 t2
+  in
+    if b then ()
+    else 
+      let _ = clos_fconv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in
+	()
+
+(* Profiling *)
+let trans_fconv_universes = 
+  if Flags.profile then
+    let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in
+      Profile.profile8 trans_fconv_universes_key trans_fconv_universes
+  else trans_fconv_universes
+
+let trans_fconv reds cv_pb l2r evars env = 
+  trans_fconv_universes reds cv_pb l2r evars env (universes env)
 
 let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None)
 let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars
 let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars
 
-let fconv = trans_fconv (Idpred.full, Cpred.full)
+let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = 
+  trans_fconv_universes reds CONV l2r evars
+let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = 
+  trans_fconv_universes reds CUMUL l2r evars
+
+let fconv = trans_fconv (Id.Pred.full, Cpred.full)
 
 let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None)
 let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars
 let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars
 
 let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
-  array_fold_left2_i
-    (fun i c t1 t2 ->
-      let c' =
-        try conv_leq ~l2r ~evars env t1 t2
-        with NotConvertible -> raise (NotConvertibleVect i) in
-      union_constraints c c')
-    empty_constraint
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq ~l2r ~evars env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
     v1
     v2
 
+let generic_conv cv_pb l2r evars reds env univs t1 t2 =
+  let (s, _) = 
+    clos_fconv reds cv_pb l2r evars env univs t1 t2 
+  in s
+
+let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 =
+  let b, cstrs =
+    if cv_pb == CUMUL then Constr.leq_constr_univs_infer univs t1 t2
+    else Constr.eq_constr_univs_infer univs t1 t2
+  in
+    if b then cstrs
+    else
+      let univs = ((univs, Univ.Constraint.empty), infered_universes) in
+      let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in
+	cstrs
+
+(* Profiling *)
+let infer_conv_universes = 
+  if Flags.profile then 
+    let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" in
+      Profile.profile8 infer_conv_universes_key infer_conv_universes
+  else infer_conv_universes
+
+let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state)
+    env univs t1 t2 = 
+  infer_conv_universes CONV l2r evars ts env univs t1 t2
+
+let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) 
+    env univs t1 t2 = 
+  infer_conv_universes CUMUL l2r evars ts env univs t1 t2
+
 (* option for conversion *)
+let nat_conv = ref (fun cv_pb sigma ->
+		    fconv cv_pb false (sigma.Nativelambda.evars_val))
+let set_nat_conv f = nat_conv := f
+
+let native_conv cv_pb sigma env t1 t2 =
+  if eq_constr t1 t2 then ()
+  else begin
+    let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in
+    let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in
+    !nat_conv cv_pb sigma env t1 t2 
+  end
 
 let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
 let set_vm_conv f = vm_conv := f
@@ -500,7 +782,7 @@ let conv env t1 t2 =
 let hnf_prod_app env t n =
   match kind_of_term (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
@@ -518,7 +800,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
@@ -530,10 +812,28 @@ let dest_prod_assum env =
         let d = (x,Some b,t) in
 	prodec_rec (push_rel d env) (add_rel_decl 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 kind_of_term rty with
+    | Lambda (x,t,c)  ->
+        let d = (x,None,t) in
+	lamec_rec (push_rel d env) (add_rel_decl d l) c
+    | LetIn (x,b,t,c) ->
+        let d = (x,Some b,t) in
+	lamec_rec (push_rel d env) (add_rel_decl d l) c
+    | Cast (c,_,_)    -> lamec_rec env l c
+    | _               -> l,rty
+  in
+  lamec_rec env empty_rel_context
+
 exception NotArity
 
 let dest_arity env c =
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 7ce8ee8b..6ced5c49 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -1,40 +1,62 @@
 (************************************************************************)
 (*  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 Term
+open Context
 open Environ
-open Closure
+
+val left2right : bool ref
 
 (***********************************************************************
   s Reduction functions *)
 
-val whd_betaiotazeta        : constr -> constr
+val whd_betaiotazeta        : env -> constr -> constr
 val whd_betadeltaiota       : env -> constr -> constr
 val whd_betadeltaiota_nolet : env -> constr -> constr
 
-val whd_betaiota      : constr -> constr
-val nf_betaiota      : constr -> constr
+val whd_betaiota     : env -> constr -> constr
+val nf_betaiota      : env -> constr -> constr
 
 (***********************************************************************
   s conversion functions *)
 
 exception NotConvertible
 exception NotConvertibleVect of int
-type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints
-type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints
+
+type 'a conversion_function = env -> 'a -> 'a -> unit
+type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function
+type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit
+type 'a trans_universe_conversion_function = 
+  Names.transparent_state -> 'a universe_conversion_function
 
 type conv_pb = CONV | CUMUL
 
-val sort_cmp :
-    conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints
+type 'a universe_compare = 
+  { (* Might raise NotConvertible *)
+    compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a;
+    compare_instances: bool (* Instance of a flexible constant? *) -> 
+		       Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a;
+  } 
+
+type 'a universe_state = 'a * 'a universe_compare
+
+type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a -> 'b
+
+type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints
+
+val check_sort_cmp_universes :
+  env -> conv_pb -> sorts -> sorts -> Univ.universes -> unit
 
-val conv_sort      : sorts conversion_function
-val conv_sort_leq  : sorts conversion_function
+(* val sort_cmp : *)
+(*     conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *)
+
+(* val conv_sort      : sorts conversion_function *)
+(* val conv_sort_leq  : sorts conversion_function *)
 
 val trans_conv_cmp       : ?l2r:bool -> conv_pb -> constr trans_conversion_function
 val trans_conv           :
@@ -42,6 +64,11 @@ val trans_conv           :
 val trans_conv_leq       :
   ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
 
+val trans_conv_universes     :
+  ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function
+val trans_conv_leq_universes :
+  ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function
+
 val conv_cmp       : ?l2r:bool -> conv_pb -> constr conversion_function
 val conv           :
   ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
@@ -50,10 +77,22 @@ val conv_leq       :
 val conv_leq_vecti :
   ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
 
+val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> 
+  ?ts:Names.transparent_state -> constr infer_conversion_function
+val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> 
+  ?ts:Names.transparent_state -> types infer_conversion_function
+
+val generic_conv : conv_pb -> bool -> (existential->constr option) -> 
+  Names.transparent_state -> (constr,'a) generic_conversion_function
+
 (** option for conversion *)
 val set_vm_conv : (conv_pb -> types conversion_function) -> unit
 val vm_conv : conv_pb -> types conversion_function
 
+val set_nat_conv :
+  (conv_pb -> Nativelambda.evars -> types conversion_function) -> unit
+val native_conv : conv_pb -> Nativelambda.evars -> types conversion_function
+
 val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit
 val default_conv     : conv_pb -> ?l2r:bool -> types conversion_function
 val default_conv_leq : ?l2r:bool -> types conversion_function
@@ -75,6 +114,7 @@ val hnf_prod_applist : env -> types -> constr list -> types
 
 val dest_prod       : env -> types -> rel_context * types
 val dest_prod_assum : env -> types -> rel_context * types
+val dest_lam_assum  : env -> types -> rel_context * types
 
 exception NotArity
 
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index bbb8491e..cc307f14 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.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        *)
@@ -13,22 +13,17 @@
 (* This file defines the knowledge that the kernel is able to optimize
    for evaluation in the bytecode virtual machine *)
 
-open Term
 open Names
+open Term
 
-(* Type declarations, these types shouldn't be exported they are accessed
-   through specific functions. As being mutable and all it is wiser *)
-(* These types are put into two distinct categories: proactive and reactive.
-   Proactive information allows to find the name of a combinator, constructor
-   or inductive type handling a specific function.
-   Reactive information is, on the other hand, everything you need to know
-   about a specific name.*)
+(* The retroknowledge defines a bijective correspondance between some
+   [entry]-s (which are, in fact, merely terms) and [field]-s which
+   are roles assigned to these entries. *)
 
 (* aliased type for clarity purpose*)
-type entry =  (constr, types) kind_of_term
+type entry = Constr.t
 
-(* the following types correspond to the different "things"
-   the kernel can learn about. These are the fields of the proactive knowledge*)
+(* [field]-s are the roles the kernel can learn of. *)
 type nat_field =
   | NatType
   | NatPlus
@@ -47,6 +42,7 @@ type n_field =
 type int31_field =
   | Int31Bits
   | Int31Type
+  | Int31Constructor
   | Int31Twice
   | Int31TwicePlusOne
   | Int31Phi
@@ -61,15 +57,19 @@ type int31_field =
   | Int31TimesC
   | Int31Div21
   | Int31Div
+  | Int31Diveucl
   | Int31AddMulDiv
   | Int31Compare
   | Int31Head0
   | Int31Tail0
+  | Int31Lor
+  | Int31Land
+  | Int31Lxor
 
 type field =
- (* | KEq
-  | KNat of nat_field
-  | KN of n_field *)
+  (* | KEq
+     | KNat of nat_field
+     | KN of n_field *)
   | KInt31 of string*int31_field
 
 
@@ -80,28 +80,26 @@ type flags = {fastcomputation : bool}
 
 
 
-(*A definition of maps from strings to pro_int31, to be able
-  to have any amount of coq representation for the 31bits integers *)
+(* The [proactive] knowledge contains the mapping [field->entry]. *)
 
 module Proactive =
   Map.Make (struct type t = field let compare = compare end)
 
 type proactive = entry Proactive.t
 
-(* the reactive knowledge is represented as a functionaly map
-   from the type of terms (actually it is the terms whose outermost
-   layer is unfolded (typically by Term.kind_of_term)) to the
-   type reactive_end which is a record containing all the kind of reactive
-   information needed *)
-(* todo: because of the bug with output state, reactive_end should eventually
-   contain no function. A forseen possibility is to make it a map from
-   a finite type describing the fields to the field of proactive retroknowledge
-   (and then to make as many functions as needed in environ.ml) *)
+(* The [reactive] knowledge contains the mapping
+   [entry->field]. Fields are later to be interpreted as a
+   [reactive_info]. *)
+
+module EntryOrd =
+struct
+  type t = entry
+  let compare = Constr.compare
+end
 
-module Reactive =
-  Map.Make (struct type t = entry let compare = compare end)
+module Reactive = Map.Make (EntryOrd)
 
-type reactive_end = {(*information required by the compiler of the VM *)
+type reactive_info = {(*information required by the compiler of the VM *)
   vm_compiling :
       (*fastcomputation flag -> continuation -> result *)
       (bool->Cbytecodes.comp_env->constr array ->
@@ -119,11 +117,27 @@ type reactive_end = {(*information required by the compiler of the VM *)
   (* fastcomputation flag -> cont -> result *)
   vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option;
   (* tag (= compiled int for instance) -> result *)
-  vm_decompile_const : (int -> Term.constr) option}
+  vm_decompile_const : (int -> Term.constr) option;
+
+  native_compiling :
+      (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array ->
+       Nativeinstr.lambda) option;
+
+  native_constant_static :
+      (bool -> constr array -> Nativeinstr.lambda) option;
 
+  native_constant_dynamic :
+      (bool -> Nativeinstr.prefix -> constructor ->
+       Nativeinstr.lambda array -> Nativeinstr.lambda) option;
 
+  native_before_match : (bool -> Nativeinstr.prefix -> constructor ->
+			 Nativeinstr.lambda -> Nativeinstr.lambda) option
 
-and reactive = reactive_end Reactive.t
+}
+
+
+
+and reactive = field Reactive.t
 
 and retroknowledge = {flags : flags; proactive : proactive; reactive : reactive}
 
@@ -150,125 +164,96 @@ let initial_retroknowledge =
    proactive = initial_proactive;
    reactive = initial_reactive }
 
-let empty_reactive_end =
+let empty_reactive_info =
   { vm_compiling = None ;
     vm_constant_static = None;
     vm_constant_dynamic = None;
     vm_before_match = None;
-    vm_decompile_const = None }
+    vm_decompile_const = None;
+    native_compiling = None;
+    native_constant_static = None;
+    native_constant_dynamic = None;
+    native_before_match = None;
+  }
 
 
 
+(* adds a binding [entry<->field]. *)
+let add_field knowledge field entry =
+  {knowledge with
+    proactive = Proactive.add field entry knowledge.proactive;
+    reactive = Reactive.add entry field knowledge.reactive}
 
 (* acces functions for proactive retroknowledge *)
-let add_field knowledge field value =
-  {knowledge with proactive = Proactive.add field value knowledge.proactive}
-
 let mem knowledge field =
   Proactive.mem field knowledge.proactive
 
-let remove knowledge field =
-  {knowledge with proactive = Proactive.remove field knowledge.proactive}
-
 let find knowledge field =
   Proactive.find field knowledge.proactive
 
 
+let (dispatch,dispatch_hook) = Hook.make ()
 
-
+let dispatch_reactive entry retroknowledge =
+  Hook.get dispatch retroknowledge entry (Reactive.find entry retroknowledge.reactive)
 
 (*access functions for reactive retroknowledge*)
 
 (* used for compiling of functions (add, mult, etc..) *)
 let get_vm_compiling_info knowledge key =
-  match (Reactive.find key knowledge.reactive).vm_compiling
+  match (dispatch_reactive key knowledge).vm_compiling
   with
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
 (* used for compilation of fully applied constructors *)
 let get_vm_constant_static_info knowledge key =
-  match (Reactive.find key knowledge.reactive).vm_constant_static
+  match (dispatch_reactive key knowledge).vm_constant_static
   with
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
 (* used for compilation of partially applied constructors *)
 let get_vm_constant_dynamic_info knowledge key =
-  match (Reactive.find key knowledge.reactive).vm_constant_dynamic
+  match (dispatch_reactive key knowledge).vm_constant_dynamic
   with
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
 let get_vm_before_match_info knowledge key =
-  match (Reactive.find key knowledge.reactive).vm_before_match
+  match (dispatch_reactive key knowledge).vm_before_match
   with
     | None -> raise Not_found
     | Some f -> f knowledge.flags.fastcomputation
 
 let get_vm_decompile_constant_info knowledge key =
-  match (Reactive.find key knowledge.reactive).vm_decompile_const
+  match (dispatch_reactive key knowledge).vm_decompile_const
   with
     | None -> raise Not_found
     | Some f -> f
 
+let get_native_compiling_info knowledge key =
+  match (dispatch_reactive key knowledge).native_compiling
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
 
+(* used for compilation of fully applied constructors *)
+let get_native_constant_static_info knowledge key =
+  match (dispatch_reactive key knowledge).native_constant_static
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
 
-(* functions manipulating reactive knowledge *)
-let add_vm_compiling_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_compiling = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_compiling = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_constant_static_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_constant_static = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_constant_static = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_constant_dynamic_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_constant_dynamic = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_constant_dynamic = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_before_match_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_before_match = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_before_match = Some nfo}
-       knowledge.reactive
-  }
-
-let add_vm_decompile_constant_info knowledge value nfo =
-  {knowledge with reactive =
-   try
-     Reactive.add value
-       {(Reactive.find value (knowledge.reactive)) with vm_decompile_const = Some nfo}
-       knowledge.reactive
-   with Not_found ->
-     Reactive.add value {empty_reactive_end with vm_decompile_const = Some nfo}
-       knowledge.reactive
-  }
+(* used for compilation of partially applied constructors *)
+let get_native_constant_dynamic_info knowledge key =
+  match (dispatch_reactive key knowledge).native_constant_dynamic
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
 
-let clear_info knowledge value =
-  {knowledge with reactive = Reactive.remove value knowledge.reactive}
+let get_native_before_match_info knowledge key =
+  match (dispatch_reactive key knowledge).native_before_match
+  with
+    | None -> raise Not_found
+    | Some f -> f knowledge.flags.fastcomputation
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 0b1d8c69..9a63deb7 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.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        *)
@@ -12,7 +12,7 @@ open Term
 type retroknowledge
 
 (** aliased type for clarity purpose*)
-type entry =  (constr, types) kind_of_term
+type entry = Constr.t
 
 (** the following types correspond to the different "things"
    the kernel can learn about.*)
@@ -34,6 +34,7 @@ type n_field =
 type int31_field =
   | Int31Bits
   | Int31Type
+  | Int31Constructor
   | Int31Twice
   | Int31TwicePlusOne
   | Int31Phi
@@ -48,10 +49,14 @@ type int31_field =
   | Int31TimesC
   | Int31Div21
   | Int31Div
+  | Int31Diveucl
   | Int31AddMulDiv
   | Int31Compare
   | Int31Head0
   | Int31Tail0
+  | Int31Lor
+  | Int31Land
+  | Int31Lxor
 
 type field =
 
@@ -115,38 +120,69 @@ val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes
 val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr
 
 
-(** the following functions are solely used in Pre_env and Environ to implement
-   the functions  register and unregister (and mem) of Environ *)
-val add_field : retroknowledge -> field -> entry -> retroknowledge
-val mem : retroknowledge -> field -> bool
-val remove : retroknowledge -> field -> retroknowledge
-val find : retroknowledge -> field -> entry
+val get_native_compiling_info  : retroknowledge -> entry -> Nativeinstr.prefix ->
+				 Nativeinstr.lambda array -> Nativeinstr.lambda
 
-(** the following function manipulate the reactive information of values
-   they are only used by the functions of Pre_env, and Environ to implement
-   the functions register and unregister of Environ *)
-val add_vm_compiling_info : retroknowledge-> entry ->
-                            (bool -> Cbytecodes.comp_env -> constr array -> int ->
-                            Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
-                            retroknowledge
-val add_vm_constant_static_info : retroknowledge-> entry ->
-                                  (bool->constr array->
-                                      Cbytecodes.structured_constant) ->
-                                  retroknowledge
-val add_vm_constant_dynamic_info : retroknowledge-> entry ->
-                                   (bool -> Cbytecodes.comp_env ->
-                                   Cbytecodes.block array -> int ->
-                                   Cbytecodes.bytecodes -> Cbytecodes.bytecodes) ->
-                                   retroknowledge
-val add_vm_before_match_info : retroknowledge -> entry ->
-                              (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) ->
-                              retroknowledge
+val get_native_constant_static_info : retroknowledge -> entry ->
+                                      constr array -> Nativeinstr.lambda
 
-val add_vm_decompile_constant_info : retroknowledge -> entry ->
-                                    (int -> constr) -> retroknowledge
+val get_native_constant_dynamic_info : retroknowledge -> entry ->
+                                       Nativeinstr.prefix -> constructor ->
+				       Nativeinstr.lambda array ->
+				       Nativeinstr.lambda
 
+val get_native_before_match_info : retroknowledge -> entry ->
+				   Nativeinstr.prefix -> constructor ->
+				   Nativeinstr.lambda -> Nativeinstr.lambda
 
-val clear_info : retroknowledge-> entry -> retroknowledge
 
+(** the following functions are solely used in Pre_env and Environ to implement
+   the functions  register and unregister (and mem) of Environ *)
+val add_field : retroknowledge -> field -> entry -> retroknowledge
+val mem : retroknowledge -> field -> bool
+(* val remove : retroknowledge -> field -> retroknowledge *)
+val find : retroknowledge -> field -> entry
 
 
+(** Dispatching type for the above [get_*] functions. *)
+type reactive_info = {(*information required by the compiler of the VM *)
+  vm_compiling :
+      (*fastcomputation flag -> continuation -> result *)
+      (bool->Cbytecodes.comp_env->constr array ->
+       int->Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  vm_constant_static :
+      (*fastcomputation flag -> constructor -> args -> result*)
+      (bool->constr array->Cbytecodes.structured_constant)
+      option;
+  vm_constant_dynamic :
+      (*fastcomputation flag -> constructor -> reloc -> args -> sz -> cont -> result *)
+      (bool->Cbytecodes.comp_env->Cbytecodes.block array->int->
+         Cbytecodes.bytecodes->Cbytecodes.bytecodes)
+      option;
+  (* fastcomputation flag -> cont -> result *)
+  vm_before_match : (bool -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) option;
+  (* tag (= compiled int for instance) -> result *)
+  vm_decompile_const : (int -> Term.constr) option;
+
+  native_compiling :
+      (bool -> Nativeinstr.prefix -> Nativeinstr.lambda array ->
+       Nativeinstr.lambda) option;
+
+  native_constant_static :
+      (bool -> constr array -> Nativeinstr.lambda) option;
+
+  native_constant_dynamic :
+      (bool -> Nativeinstr.prefix -> constructor ->
+       Nativeinstr.lambda array -> Nativeinstr.lambda) option;
+
+  native_before_match : (bool -> Nativeinstr.prefix -> constructor ->
+			 Nativeinstr.lambda -> Nativeinstr.lambda) option
+
+}
+
+val empty_reactive_info : reactive_info
+
+(** Hook to be set after the compiler are installed to dispatch fields
+    into the above [get_*] functions. *)
+val dispatch_hook : (retroknowledge -> entry -> field -> reactive_info) Hook.t
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index f9f206dd..20cecc84 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.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        *)
@@ -25,13 +25,13 @@
      [,] |-
 
    push_named_assum(a,T):
-   
+
      E[Delta,Gamma] |-_G
      ------------------------
      E[Delta,Gamma,a:T] |-_G'
 
    push_named_def(a,t,T):
-   
+
      E[Delta,Gamma] |-_G
      ---------------------------
      E[Delta,Gamma,a:=t:T] |-_G'
@@ -59,668 +59,803 @@
 
 open Util
 open Names
-open Univ
-open Term
-open Reduction
-open Sign
 open Declarations
-open Inductive
-open Environ
-open Entries
-open Typeops
-open Type_errors
-open Indtypes
-open Term_typing
-open Modops
-open Subtyping
-open Mod_typing
-open Mod_subst
-
-
-type modvariant =
-  | NONE
-  | SIG of (* funsig params *) (mod_bound_id * module_type_body) list
-  | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list
-  | LIBRARY of dir_path
 
-type module_info =
-    {modpath : module_path;
-     label : label;
-     variant : modvariant;
-     resolver : delta_resolver;
-     resolver_of_param : delta_resolver;}
+(** {6 Safe environments }
+
+  Fields of [safe_environment] :
+
+  - [env] : the underlying environment (cf Environ)
+  - [modpath] : the current module name
+  - [modvariant] :
+    * NONE before coqtop initialization (or when -notop is used)
+    * LIBRARY at toplevel of a compilation or a regular coqtop session
+    * STRUCT (params,oldsenv) : inside a local module, with
+      module parameters [params] and earlier environment [oldsenv]
+    * SIG (params,oldsenv) : same for a local module type
+  - [modresolver] : delta_resolver concerning the module content
+  - [paramresolver] : delta_resolver concerning the module parameters
+  - [revstruct] : current module content, most recent declarations first
+  - [modlabels] and [objlabels] : names defined in the current module,
+      either for modules/modtypes or for constants/inductives.
+      These fields could be deduced from [revstruct], but they allow faster
+      name freshness checks.
+ - [univ] and [future_cst] : current and future universe constraints
+ - [engagement] : are we Set-impredicative?
+ - [type_in_type] : does the universe hierarchy collapse?
+ - [required] : names and digests of Require'd libraries since big-bang.
+      This field will only grow
+ - [loads] : list of libraries Require'd inside the current module.
+      They will be propagated to the upper module level when
+      the current module ends.
+ - [local_retroknowledge]
 
-let set_engagement_opt oeng env =
-  match oeng with
-      Some eng -> set_engagement eng env
-    | _ -> env
+*)
 
-type library_info = dir_path * Digest.t
+type vodigest =
+  | Dvo_or_vi of Digest.t        (* The digest of the seg_lib part *)
+  | Dvivo of Digest.t * Digest.t (* The digest of the seg_lib + seg_univ part *)
 
-type safe_environment =
-    { old : safe_environment;
-      env : env;
-      modinfo : module_info;
-      modlabels : Labset.t;
-      objlabels : Labset.t;
-      revstruct : structure_body;
-      univ : Univ.constraints;
-      engagement : engagement option;
-      imports : library_info list;
-      loads : (module_path * module_body) list;
-      local_retroknowledge : Retroknowledge.action list}
-
-let exists_modlabel l senv = Labset.mem l senv.modlabels
-let exists_objlabel l senv = Labset.mem l senv.objlabels
+let digest_match ~actual ~required =
+  match actual, required with
+  | Dvo_or_vi d1, Dvo_or_vi d2
+  | Dvivo (d1,_), Dvo_or_vi d2 -> String.equal d1 d2
+  | Dvivo (d1,e1), Dvivo (d2,e2) -> String.equal d1 d2 && String.equal e1 e2
+  | Dvo_or_vi _, Dvivo _ -> false
 
-let check_modlabel l senv =
-  if exists_modlabel l senv then error_existing_label l
-let check_objlabel l senv =
-  if exists_objlabel l senv then error_existing_label l
+type library_info = DirPath.t * vodigest
 
-let check_objlabels ls senv =
-  Labset.iter (fun l -> check_objlabel l senv) ls
+(** Functor and funsig parameters, most recent first *)
+type module_parameters = (MBId.t * module_type_body) list
 
-let labels_of_mib mib =
-  let add,get =
-    let labels = ref Labset.empty in
-    (fun id -> labels := Labset.add (label_of_id id) !labels),
-    (fun () -> !labels)
-  in
-  let visit_mip mip =
-    add mip.mind_typename;
-    Array.iter add mip.mind_consnames
-  in
-  Array.iter visit_mip mib.mind_packets;
-  get ()
+module DPMap = Map.Make(DirPath)
 
-(* a small hack to avoid variants and an unused case in all functions *)
-let rec empty_environment =
-  { old = empty_environment;
-    env = empty_env;
-    modinfo = {
-      modpath = initial_path;
-      label = mk_label "_";
-      variant = NONE;
-      resolver = empty_delta_resolver;
-      resolver_of_param = empty_delta_resolver};
-    modlabels = Labset.empty;
-    objlabels = Labset.empty;
+type safe_environment =
+  { env : Environ.env;
+    modpath : module_path;
+    modvariant : modvariant;
+    modresolver : Mod_subst.delta_resolver;
+    paramresolver : Mod_subst.delta_resolver;
+    revstruct : structure_body;
+    modlabels : Label.Set.t;
+    objlabels : Label.Set.t;
+    univ : Univ.constraints;
+    future_cst : Univ.constraints Future.computation list;
+    engagement : engagement option;
+    type_in_type : bool;
+    required : vodigest DPMap.t;
+    loads : (module_path * module_body) list;
+    local_retroknowledge : Retroknowledge.action list }
+
+and modvariant =
+  | NONE
+  | LIBRARY
+  | SIG of module_parameters * safe_environment (** saved env *)
+  | STRUCT of module_parameters * safe_environment (** saved env *)
+
+let rec library_dp_of_senv senv =
+  match senv.modvariant with
+  | NONE | LIBRARY -> ModPath.dp senv.modpath
+  | SIG(_,senv) -> library_dp_of_senv senv
+  | STRUCT(_,senv) -> library_dp_of_senv senv
+
+let empty_environment =
+  { env = Environ.empty_env;
+    modpath = initial_path;
+    modvariant = NONE;
+    modresolver = Mod_subst.empty_delta_resolver;
+    paramresolver = Mod_subst.empty_delta_resolver;
     revstruct = [];
-    univ = Univ.empty_constraint;
+    modlabels = Label.Set.empty;
+    objlabels = Label.Set.empty;
+    future_cst = [];
+    univ = Univ.Constraint.empty;
     engagement = None;
-    imports = [];
+    type_in_type = false;
+    required = DPMap.empty;
     loads = [];
     local_retroknowledge = [] }
 
+let is_initial senv =
+  match senv.revstruct, senv.modvariant with
+  | [], NONE -> ModPath.equal senv.modpath initial_path
+  | _ -> false
+
+let delta_of_senv senv = senv.modresolver,senv.paramresolver
+
+(** The safe_environment state monad *)
+
+type safe_transformer0 = safe_environment -> safe_environment
+type 'a safe_transformer = safe_environment -> 'a * safe_environment
+
+
+(** {6 Engagement } *)
+
+let set_engagement_opt env = function
+  | Some c -> Environ.set_engagement c env
+  | None -> env
+
+let set_engagement c senv =
+  { senv with
+    env = Environ.set_engagement c senv.env;
+    engagement = Some c }
+
+(** Check that the engagement [c] expected by a library matches
+    the current (initial) one *)
+let check_engagement env c =
+  match Environ.engagement env, c with
+  | None, Some ImpredicativeSet ->
+    Errors.error "Needs option -impredicative-set."
+  | _ -> ()
+
+let set_type_in_type senv = 
+  { senv with
+    env = Environ.set_type_in_type senv.env;
+    type_in_type = true }
+
+(** {6 Stm machinery } *)
+
+let get_opaque_body env cbo =
+  match cbo.const_body with
+  | Undef _ -> assert false
+  | Def _ -> `Nothing
+  | OpaqueDef opaque ->
+      `Opaque
+        (Opaqueproof.force_proof (Environ.opaque_tables env) opaque,
+         Opaqueproof.force_constraints (Environ.opaque_tables env) opaque)
+
+let sideff_of_con env c =
+  let cbo = Environ.lookup_constant c env.env in
+  SEsubproof (c, cbo, get_opaque_body env.env cbo)
+let sideff_of_scheme kind env cl =
+  SEscheme(
+    List.map (fun (i,c) ->
+      let cbo = Environ.lookup_constant c env.env in
+      i, c, cbo, get_opaque_body env.env cbo) cl,
+    kind)
+
 let env_of_safe_env senv = senv.env
 let env_of_senv = env_of_safe_env
 
+type constraints_addition =
+  Now of Univ.constraints | Later of Univ.constraints Future.computation
+
 let add_constraints cst senv =
+  match cst with
+  | Later fc -> 
+    {senv with future_cst = fc :: senv.future_cst}
+  | Now cst ->
   { senv with
     env = Environ.add_constraints cst senv.env;
-    univ = Univ.union_constraints cst senv.univ }
+    univ = Univ.Constraint.union cst senv.univ }
 
-let constraints_of_sfb = function
-  | SFBconst cb -> cb.const_constraints
-  | SFBmind mib -> mib.mind_constraints
-  | SFBmodtype mtb -> mtb.typ_constraints
-  | SFBmodule mb -> mb.mod_constraints
+let add_constraints_list cst senv =
+  List.fold_right add_constraints cst senv
 
-(* A generic function for adding a new field in a same environment.
-   It also performs the corresponding [add_constraints]. *)
+let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx))
+let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx))
 
-type generic_name =
-  | C of constant
-  | I of mutual_inductive
-  | MT of module_path
-  | M
+let is_curmod_library senv =
+  match senv.modvariant with LIBRARY -> true | _ -> false
 
-let add_field ((l,sfb) as field) gn senv =
-  let mlabs,olabs = match sfb with
-    | SFBmind mib ->
-      let l = labels_of_mib mib in
-      check_objlabels l senv; (Labset.empty,l)
-    | SFBconst _ ->
-      check_objlabel l senv; (Labset.empty, Labset.singleton l)
-    | SFBmodule _ | SFBmodtype _ ->
-      check_modlabel l senv; (Labset.singleton l, Labset.empty)
-  in
-  let senv = add_constraints (constraints_of_sfb sfb) senv in
-  let env' = match sfb, gn with
-    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
-    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
-    | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
-    | SFBmodule mb, M -> Modops.add_module mb senv.env
-    | _ -> assert false
-  in
-  { senv with
-    env = env';
-    modlabels = Labset.union mlabs senv.modlabels;
-    objlabels = Labset.union olabs senv.objlabels;
-    revstruct = field :: senv.revstruct }
+let join_safe_environment ?(except=Future.UUIDSet.empty) e =
+  Modops.join_structure except (Environ.opaque_tables e.env) e.revstruct;
+  List.fold_left
+    (fun e fc ->
+       if Future.UUIDSet.mem (Future.uuid fc) except then e
+       else add_constraints (Now (Future.join fc)) e)
+    {e with future_cst = []} e.future_cst
 
-(* Applying a certain function to the resolver of a safe environment *)
+(** {6 Various checks } *)
 
-let update_resolver f senv =
-  let mi = senv.modinfo in
-  { senv with modinfo = { mi with resolver = f mi.resolver }}
+let exists_modlabel l senv = Label.Set.mem l senv.modlabels
+let exists_objlabel l senv = Label.Set.mem l senv.objlabels
 
+let check_modlabel l senv =
+  if exists_modlabel l senv then Modops.error_existing_label l
 
-(* universal lifting, used for the "get" operations mostly *)
-let retroknowledge f senv =
-  Environ.retroknowledge f (env_of_senv senv)
+let check_objlabel l senv =
+  if exists_objlabel l senv then Modops.error_existing_label l
 
-let register senv field value by_clause =
-  (* todo : value closed, by_clause safe, by_clause of the proper type*)
-  (* spiwack : updates the safe_env with the information that the register
-     action has to be performed (again) when the environement is imported *)
-  {senv with
-    env = Environ.register senv.env field value;
-    local_retroknowledge =
-      Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
-  }
+let check_objlabels ls senv =
+  Label.Set.iter (fun l -> check_objlabel l senv) ls
+
+(** Are we closing the right module / modtype ?
+    No user error here, since the opening/ending coherence
+    is now verified in [vernac_end_segment] *)
+
+let check_current_label lab = function
+  | MPdot (_,l) -> assert (Label.equal lab l)
+  | _ -> assert false
 
-(* spiwack : currently unused *)
-let unregister senv field  =
-  (*spiwack: todo: do things properly or delete *)
-  {senv with env = Environ.unregister senv.env field}
-(* /spiwack *)
+let check_struct = function
+  | STRUCT (params,oldsenv) -> params, oldsenv
+  | NONE | LIBRARY | SIG _ -> assert false
 
+let check_sig = function
+  | SIG (params,oldsenv) -> params, oldsenv
+  | NONE | LIBRARY | STRUCT _ -> assert false
 
+let check_current_library dir senv = match senv.modvariant with
+  | LIBRARY -> assert (ModPath.equal senv.modpath (MPfile dir))
+  | NONE | STRUCT _ | SIG _ -> assert false (* cf Lib.end_compilation *)
 
+(** When operating on modules, we're normally outside sections *)
 
+let check_empty_context senv =
+  assert (Environ.empty_context senv.env)
 
+(** When adding a parameter to the current module/modtype,
+    it must have been freshly started *)
 
+let check_empty_struct senv =
+  assert (List.is_empty senv.revstruct
+          && List.is_empty senv.loads)
 
+(** When starting a library, the current environment should be initial
+    i.e. only composed of Require's *)
 
+let check_initial senv = assert (is_initial senv)
 
+(** When loading a library, its dependencies should be already there,
+    with the correct digests. *)
 
-(* Insertion of section variables. They are now typed before being
-   added to the environment. *)
+let check_required current_libs needed =
+  let check (id,required) =
+    try
+      let actual = DPMap.find id current_libs in
+      if not(digest_match ~actual ~required) then
+        Errors.error
+          ("Inconsistent assumptions over module "^(DirPath.to_string id)^".")
+    with Not_found ->
+      Errors.error ("Reference to unknown module "^(DirPath.to_string id)^".")
+  in
+  Array.iter check needed
+
+
+(** {6 Insertion of section variables} *)
+
+(** They are now typed before being added to the environment.
+    Same as push_named, but check that the variable is not already
+    there. Should *not* be done in Environ because tactics add temporary
+    hypothesis many many times, and the check performed here would
+    cost too much. *)
 
-(* Same as push_named, but check that the variable is not already
-   there. Should *not* be done in Environ because tactics add temporary
-   hypothesis many many times, and the check performed here would
-   cost too much. *)
 let safe_push_named (id,_,_ as d) env =
   let _ =
     try
-      let _ = lookup_named id env in
-      error ("Identifier "^string_of_id id^" already defined.")
+      let _ = Environ.lookup_named id env in
+      Errors.error ("Identifier "^Id.to_string id^" already defined.")
     with Not_found -> () in
   Environ.push_named d env
 
-let push_named_def (id,b,topt) senv =
-  let (c,typ,cst) = translate_local_def senv.env (b,topt) in
-  let senv' = add_constraints cst senv in
+
+let push_named_def (id,de) senv =
+  let c,typ,univs = Term_typing.translate_local_def senv.env id de in
+  let senv' = push_context univs senv in
+  let c, senv' = match c with
+    | Def c -> Mod_subst.force_constr c, senv'
+    | OpaqueDef o ->
+        Opaqueproof.force_proof (Environ.opaque_tables senv'.env) o,
+        push_context_set
+          (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o)
+          senv'
+    | _ -> assert false in
   let env'' = safe_push_named (id,Some c,typ) senv'.env in
-  (cst, {senv' with env=env''})
+    {senv' with env=env''}
 
-let push_named_assum (id,t) senv =
-  let (t,cst) = translate_local_assum senv.env t in
-  let senv' = add_constraints cst senv in
+let push_named_assum ((id,t),ctx) senv =
+  let senv' = push_context_set ctx senv in
+  let t = Term_typing.translate_local_assum senv'.env t in
   let env'' = safe_push_named (id,None,t) senv'.env in
-  (cst, {senv' with env=env''})
+    {senv' with env=env''}
+
+
+(** {6 Insertion of new declarations to current environment } *)
+
+let labels_of_mib mib =
+  let add,get =
+    let labels = ref Label.Set.empty in
+    (fun id -> labels := Label.Set.add (Label.of_id id) !labels),
+    (fun () -> !labels)
+  in
+  let visit_mip mip =
+    add mip.mind_typename;
+    Array.iter add mip.mind_consnames
+  in
+  Array.iter visit_mip mib.mind_packets;
+  get ()
+
+let globalize_constant_universes env cb =
+  if cb.const_polymorphic then
+    [Now Univ.Constraint.empty]
+  else
+    let cstrs = Univ.UContext.constraints cb.const_universes in
+      Now cstrs ::  
+	(match cb.const_body with
+	| (Undef _ | Def _) -> []
+	| OpaqueDef lc ->
+	  match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with
+	  | None -> []
+	  | Some fc ->
+            match Future.peek_val fc with
+            | None -> [Later (Future.chain ~pure:true fc Univ.ContextSet.constraints)]
+            | Some c -> [Now (Univ.ContextSet.constraints c)])
+      
+let globalize_mind_universes mb =
+  if mb.mind_polymorphic then
+    [Now Univ.Constraint.empty]
+  else
+    [Now (Univ.UContext.constraints mb.mind_universes)]
+
+let constraints_of_sfb env sfb = 
+  match sfb with
+  | SFBconst cb -> globalize_constant_universes env cb
+  | SFBmind mib -> globalize_mind_universes mib
+  | SFBmodtype mtb -> [Now mtb.mod_constraints]
+  | SFBmodule mb -> [Now mb.mod_constraints]
+
+(** A generic function for adding a new field in a same environment.
+    It also performs the corresponding [add_constraints]. *)
+
+type generic_name =
+  | C of constant
+  | I of mutual_inductive
+  | M (** name already known, cf the mod_mp field *)
+  | MT (** name already known, cf the mod_mp field *)
+
+let add_field ((l,sfb) as field) gn senv =
+  let mlabs,olabs = match sfb with
+    | SFBmind mib ->
+      let l = labels_of_mib mib in
+      check_objlabels l senv; (Label.Set.empty,l)
+    | SFBconst _ ->
+      check_objlabel l senv; (Label.Set.empty, Label.Set.singleton l)
+    | SFBmodule _ | SFBmodtype _ ->
+      check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty)
+  in
+  let cst = constraints_of_sfb senv.env sfb in
+  let senv = add_constraints_list cst senv in
+  let env' = match sfb, gn with
+    | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+    | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+    | SFBmodtype mtb, MT -> Environ.add_modtype mtb senv.env
+    | SFBmodule mb, M -> Modops.add_module mb senv.env
+    | _ -> assert false
+  in
+  { senv with
+    env = env';
+    revstruct = field :: senv.revstruct;
+    modlabels = Label.Set.union mlabs senv.modlabels;
+    objlabels = Label.Set.union olabs senv.objlabels }
 
+(** Applying a certain function to the resolver of a safe environment *)
 
-(* Insertion of constants and parameters in environment. *)
+let update_resolver f senv = { senv with modresolver = f senv.modresolver }
 
+(** Insertion of constants and parameters in environment *)
 type global_declaration =
-  | ConstantEntry of constant_entry
+  | ConstantEntry of Entries.constant_entry
   | GlobalRecipe of Cooking.recipe
 
 let add_constant dir l decl senv =
-  let kn = make_con senv.modinfo.modpath dir l in
+  let kn = make_con senv.modpath dir l in
   let cb = match decl with
-    | ConstantEntry ce -> translate_constant senv.env kn ce
+    | ConstantEntry ce -> Term_typing.translate_constant senv.env kn ce
     | GlobalRecipe r ->
-      let cb = translate_recipe senv.env kn r in
-      if dir = empty_dirpath then hcons_const_body cb else cb
+      let cb = Term_typing.translate_recipe senv.env kn r in
+      if DirPath.is_empty dir then Declareops.hcons_const_body cb else cb
+  in
+  let cb, otab = match cb.const_body with
+    | OpaqueDef lc when DirPath.is_empty dir ->
+      (* In coqc, opaque constants outside sections will be stored
+         indirectly in a specific table *)
+      let od, otab =
+        Opaqueproof.turn_indirect
+          (library_dp_of_senv senv) lc (Environ.opaque_tables senv.env) in
+      { cb with const_body = OpaqueDef od }, otab
+    | _ -> cb, (Environ.opaque_tables senv.env)
   in
+  let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in
   let senv' = add_field (l,SFBconst cb) (C kn) senv in
   let senv'' = match cb.const_body with
     | Undef (Some lev) ->
-      update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv'
+      update_resolver
+        (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv'
     | _ -> senv'
   in
   kn, senv''
 
-(* Insertion of inductive types. *)
+(** Insertion of inductive types *)
+
+let check_mind mie lab =
+  let open Entries in
+  match mie.mind_entry_inds with
+  | [] -> assert false (* empty inductive entry *)
+  | oie::_ ->
+    (* The label and the first inductive type name should match *)
+    assert (Id.equal (Label.to_id lab) oie.mind_entry_typename)
 
 let add_mind dir l mie senv =
-  if mie.mind_entry_inds = [] then
-    anomaly "empty inductive types declaration";
-            (* this test is repeated by translate_mind *)
-  let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in
-  if l <> label_of_id id then
-    anomaly ("the label of inductive packet and its first inductive"^
-	     " type do not match");
-  let kn = make_mind senv.modinfo.modpath dir l in
-  let mib = translate_mind senv.env kn mie in
-  let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in
-  let senv' = add_field (l,SFBmind mib) (I kn) senv in
-  kn, senv'
-
-(* Insertion of module types *)
-
-let add_modtype l mte inl senv =
-  let mp = MPdot(senv.modinfo.modpath, l) in
-  let mtb = translate_module_type senv.env mp inl mte  in
-  let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in
+  let () = check_mind mie l in
+  let kn = make_mind senv.modpath dir l in
+  let mib = Term_typing.translate_mind senv.env kn mie in
+  let mib =
+    match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib
+  in
+  kn, add_field (l,SFBmind mib) (I kn) senv
+
+(** Insertion of module types *)
+
+let add_modtype l params_mte inl senv =
+  let mp = MPdot(senv.modpath, l) in
+  let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte  in
+  let senv' = add_field (l,SFBmodtype mtb) MT senv in
   mp, senv'
 
-(* full_add_module adds module with universes and constraints *)
+(** full_add_module adds module with universes and constraints *)
+
 let full_add_module mb senv =
-  let senv = add_constraints mb.mod_constraints senv in
-  { senv with env = Modops.add_module mb senv.env }
+  let senv = add_constraints (Now mb.mod_constraints) senv in
+  let dp = ModPath.dp mb.mod_mp in
+  let linkinfo = Nativecode.link_info_of_dirpath dp in
+  { senv with env = Modops.add_linked_module mb linkinfo senv.env }
+
+let full_add_module_type mp mt senv =
+  let senv = add_constraints (Now mt.mod_constraints) senv in
+  { senv with env = Modops.add_module_type mp mt senv.env }
 
-(* Insertion of modules *)
+(** Insertion of modules *)
 
 let add_module l me inl senv =
-  let mp = MPdot(senv.modinfo.modpath, l) in
-  let mb = translate_module senv.env mp inl me in
+  let mp = MPdot(senv.modpath, l) in
+  let mb = Mod_typing.translate_module senv.env mp inl me in
   let senv' = add_field (l,SFBmodule mb) M senv in
-  let senv'' = match mb.mod_type with
-    | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv'
-    | _ -> senv'
+  let senv'' =
+    if Modops.is_functor mb.mod_type then senv'
+    else update_resolver (Mod_subst.add_delta_resolver mb.mod_delta) senv'
   in
-  mp,mb.mod_delta,senv''
+  (mp,mb.mod_delta),senv''
 
-(* Interactive modules *)
+
+(** {6 Starting / ending interactive modules and module types } *)
 
 let start_module l senv =
-  check_modlabel l senv;
- let mp = MPdot(senv.modinfo.modpath, l) in
- let modinfo = { modpath = mp;
-		 label = l;
-		 variant = STRUCT [];
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
- in
-   mp, { old = senv;
-	 env = senv.env;
-	 modinfo = modinfo;
-	 modlabels = Labset.empty;
-	 objlabels = Labset.empty;
-	 revstruct = [];
-         univ = Univ.empty_constraint;
-         engagement = None;
-	 imports = senv.imports;
-	 loads = [];
-	 (* spiwack : not sure, but I hope it's correct *)
-         local_retroknowledge = [] }
+  let () = check_modlabel l senv in
+  let () = check_empty_context senv in
+  let mp = MPdot(senv.modpath, l) in
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = STRUCT ([],senv);
+    required = senv.required }
 
-let end_module l restype senv =
-  let oldsenv = senv.old in
-  let modinfo = senv.modinfo in
-  let mp = senv.modinfo.modpath in
-  let restype =
-    Option.map
-      (fun (res,inl) -> translate_module_type senv.env mp inl res) restype in
-  let params,is_functor =
-    match modinfo.variant with
-      | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end ()
-      | STRUCT params -> params, (List.length params > 0)
-  in
-  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
-  if not (empty_context senv.env) then error_non_empty_local_context None;
-  let functorize_struct tb =
-    List.fold_left
-      (fun mtb (arg_id,arg_b) ->
-	SEBfunctor(arg_id,arg_b,mtb))
-      tb
-      params
-  in
-   let auto_tb =
-     SEBstruct (List.rev senv.revstruct)
-  in
-   let mexpr,mod_typ,mod_typ_alg,resolver,cst = 
-    match restype with
-      | None ->  let mexpr = functorize_struct auto_tb in
-	 mexpr,mexpr,None,modinfo.resolver,empty_constraint
-      | Some mtb ->
-	  let auto_mtb = {
-	    typ_mp = senv.modinfo.modpath;
-	    typ_expr = auto_tb;
-	    typ_expr_alg = None;
-	    typ_constraints = empty_constraint;
-	    typ_delta = empty_delta_resolver} in
-	  let cst = check_subtypes senv.env auto_mtb
-	    mtb in
-	  let mod_typ = functorize_struct mtb.typ_expr in
-	  let mexpr = functorize_struct auto_tb in
-	  let typ_alg = 
-	    Option.map functorize_struct mtb.typ_expr_alg in
-	    mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
-  in
-  let cst = union_constraints cst senv.univ in
-  let mb =
-    { mod_mp = mp;
-      mod_expr = Some mexpr;
-      mod_type = mod_typ;
-      mod_type_alg = mod_typ_alg;
-      mod_constraints = cst;
-      mod_delta = resolver;
-      mod_retroknowledge = senv.local_retroknowledge }
-  in
-  let newenv = oldsenv.env in
-  let newenv = set_engagement_opt senv.engagement newenv in
-  let senv'= {senv with env = newenv; univ = cst} in
-  let senv' =
-    List.fold_left
-      (fun env (_,mb) -> full_add_module mb env) 
-      senv'
-      (List.rev senv'.loads)
-  in
-  let newenv = Environ.add_constraints cst senv'.env in
-  let newenv =
-    Modops.add_module mb newenv in 
-  let modinfo = match mb.mod_type with
-      SEBstruct _ -> 
-	{ oldsenv.modinfo with
-	    resolver = 
-	    add_delta_resolver resolver oldsenv.modinfo.resolver}
-    | _ -> oldsenv.modinfo
-  in
-    mp,resolver,{ old = oldsenv.old;
-		  env = newenv;
-		  modinfo = modinfo;
-		  modlabels = Labset.add l oldsenv.modlabels;
-		  objlabels = oldsenv.objlabels;
-		  revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
-		  univ = Univ.union_constraints senv'.univ oldsenv.univ;
-		  (* engagement is propagated to the upper level *)
-		  engagement = senv'.engagement;
-		  imports = senv'.imports;
-		  loads = senv'.loads@oldsenv.loads;
-		  local_retroknowledge =
-	senv'.local_retroknowledge@oldsenv.local_retroknowledge }
-
-
-(* Include for module and module type*)
- let add_include me is_module inl senv =
-   let sign,cst,resolver =
-     if is_module then
-       let sign,_,resolver,cst =
-	 translate_struct_include_module_entry senv.env
-	   senv.modinfo.modpath inl me in
-	 sign,cst,resolver
-     else
-       let mtb = 
-	 translate_module_type senv.env 
-	   senv.modinfo.modpath inl me in
-       mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta
-   in
-   let senv = add_constraints cst senv in
-   let mp_sup = senv.modinfo.modpath in
-     (* Include Self support  *)
-   let rec compute_sign sign mb resolver senv = 
-     match sign with
-     | SEBfunctor(mbid,mtb,str) ->
-	 let cst_sub = check_subtypes senv.env mb mtb in
-	 let senv = add_constraints cst_sub senv in
-	 let mpsup_delta =
-	   inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta
-	 in
-	 let subst = map_mbid mbid mp_sup mpsup_delta in
-	 let resolver = subst_codom_delta_resolver subst resolver in
-	   (compute_sign 
-	     (subst_struct_expr subst str) mb resolver senv)
-     | str -> resolver,str,senv
-   in
-   let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup;
-				      typ_expr = SEBstruct (List.rev senv.revstruct);
-				      typ_expr_alg = None;
-				      typ_constraints = empty_constraint;
-				      typ_delta = senv.modinfo.resolver} resolver senv
-   in
-   let str = match sign with
-     | SEBstruct(str_l) -> str_l
-     | _ -> error ("You cannot Include a higher-order structure.")
-   in
-   let senv = update_resolver (add_delta_resolver resolver) senv
-   in
-   let add senv ((l,elem) as field) =
-     let new_name = match elem with
-       | SFBconst _ ->
-	   let kn = make_kn mp_sup empty_dirpath l in
-	   C (constant_of_delta_kn resolver kn)
-       | SFBmind _ ->
-	   let kn = make_kn mp_sup empty_dirpath l in
-	   I (mind_of_delta_kn resolver kn)
-       | SFBmodule _ -> M
-       | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l))
-     in
-     add_field field new_name senv
-   in
-   resolver,(List.fold_left add senv str)
-
-(* Adding parameters to modules or module types *)
+let start_modtype l senv =
+  let () = check_modlabel l senv in
+  let () = check_empty_context senv in
+  let mp = MPdot(senv.modpath, l) in
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = SIG ([], senv);
+    required = senv.required }
+
+(** Adding parameters to the current module or module type.
+    This module should have been freshly started. *)
 
 let add_module_parameter mbid mte inl senv =
-  if  senv.revstruct <> [] or senv.loads <> [] then
-    anomaly "Cannot add a module parameter to a non empty module";
-  let mtb = translate_module_type senv.env (MPbound mbid) inl mte in
-  let senv = 
-    full_add_module (module_body_of_type (MPbound mbid) mtb) senv
+  let () = check_empty_struct senv in
+  let mp = MPbound mbid in
+  let mtb = Mod_typing.translate_modtype senv.env mp inl ([],mte) in
+  let senv = full_add_module_type mp mtb senv in
+  let new_variant = match senv.modvariant with
+    | STRUCT (params,oldenv) -> STRUCT ((mbid,mtb) :: params, oldenv)
+    | SIG (params,oldenv) -> SIG ((mbid,mtb) :: params, oldenv)
+    | _ -> assert false
   in
-  let new_variant = match senv.modinfo.variant with
-    | STRUCT params -> STRUCT ((mbid,mtb) :: params)
-    | SIG params -> SIG ((mbid,mtb) :: params)
-    | _ ->
-	anomaly "Module parameters can only be added to modules or signatures"  
+  let new_paramresolver =
+    if Modops.is_functor mtb.mod_type then senv.paramresolver
+    else Mod_subst.add_delta_resolver mtb.mod_delta senv.paramresolver
   in
-    
-  let resolver_of_param = match mtb.typ_expr with
-      SEBstruct _ -> mtb.typ_delta
-    | _ -> empty_delta_resolver
+  mtb.mod_delta,
+  { senv with
+    modvariant = new_variant;
+    paramresolver = new_paramresolver }
+
+let functorize params init =
+  List.fold_left (fun e (mbid,mt) -> MoreFunctor(mbid,mt,e)) init params
+
+let propagate_loads senv =
+  List.fold_left
+    (fun env (_,mb) -> full_add_module mb env)
+    senv
+    (List.rev senv.loads)
+
+(** Build the module body of the current module, taking in account
+    a possible return type (_:T) *)
+
+let functorize_module params mb =
+  let f x = functorize params x in
+  { mb with
+    mod_expr = Modops.implem_smartmap f f mb.mod_expr;
+    mod_type = f mb.mod_type;
+    mod_type_alg = Option.map f mb.mod_type_alg }
+
+let build_module_body params restype senv =
+  let struc = NoFunctor (List.rev senv.revstruct) in
+  let restype' = Option.map (fun (ty,inl) -> (([],ty),inl)) restype in
+  let mb =
+    Mod_typing.finalize_module senv.env senv.modpath
+      (struc,None,senv.modresolver,senv.univ) restype'
   in
-    mtb.typ_delta, { old = senv.old;
-		     env = senv.env;
-		     modinfo = { senv.modinfo with 
-				   variant = new_variant;
-				   resolver_of_param = add_delta_resolver
-			      resolver_of_param senv.modinfo.resolver_of_param};
-		     modlabels = senv.modlabels;
-		     objlabels = senv.objlabels;
-		     revstruct = [];
-		     univ = senv.univ;
-		     engagement = senv.engagement;
-		     imports = senv.imports;
-		     loads = [];
-		     local_retroknowledge = senv.local_retroknowledge }
-      
-
-(* Interactive module types *)
+  let mb' = functorize_module params mb in
+  { mb' with mod_retroknowledge = senv.local_retroknowledge }
+
+(** Returning back to the old pre-interactive-module environment,
+    with one extra component and some updated fields
+    (constraints, required, etc) *)
+
+let propagate_senv newdef newenv newresolver senv oldsenv =
+  let now_cst, later_cst = List.partition Future.is_val senv.future_cst in
+  (* This asserts that after Paral-ITP, standard vo compilation is behaving
+   * exctly as before: the same universe constraints are added to modules *)
+  if !Flags.compilation_mode = Flags.BuildVo &&
+     !Flags.async_proofs_mode = Flags.APoff then assert(later_cst = []);
+  { oldsenv with
+    env = newenv;
+    modresolver = newresolver;
+    revstruct = newdef::oldsenv.revstruct;
+    modlabels = Label.Set.add (fst newdef) oldsenv.modlabels;
+    univ =
+      List.fold_left (fun acc cst ->
+        Univ.Constraint.union acc (Future.force cst))
+      (Univ.Constraint.union senv.univ oldsenv.univ)
+      now_cst;
+    future_cst = later_cst @ oldsenv.future_cst;
+    (* engagement is propagated to the upper level *)
+    engagement = senv.engagement;
+    required = senv.required;
+    loads = senv.loads@oldsenv.loads;
+    local_retroknowledge =
+            senv.local_retroknowledge@oldsenv.local_retroknowledge }
 
-let start_modtype l senv =
-  check_modlabel l senv;
- let mp = MPdot(senv.modinfo.modpath, l) in
- let modinfo = { modpath = mp;
-		 label = l;
-		 variant = SIG [];
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
- in
-  mp, { old = senv;
-	env = senv.env;
-	modinfo = modinfo;
-	modlabels = Labset.empty;
-	objlabels = Labset.empty;
-	revstruct = [];
-        univ = Univ.empty_constraint;
-        engagement = None;
-	imports = senv.imports;
-	loads = [] ;
-	(* spiwack: not 100% sure, but I think it should be like that *)
-        local_retroknowledge = []}
+let end_module l restype senv =
+  let mp = senv.modpath in
+  let params, oldsenv = check_struct senv.modvariant in
+  let () = check_current_label l mp in
+  let () = check_empty_context senv in
+  let mbids = List.rev_map fst params in
+  let mb = build_module_body params restype senv in
+  let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in
+  let newenv = set_engagement_opt newenv senv.engagement in
+  let senv'=
+    propagate_loads { senv with
+      env = newenv;
+      univ = Univ.Constraint.union senv.univ mb.mod_constraints} in
+  let newenv = Environ.add_constraints mb.mod_constraints senv'.env in
+  let newenv = Modops.add_module mb newenv in
+  let newresolver =
+    if Modops.is_functor mb.mod_type then oldsenv.modresolver
+    else Mod_subst.add_delta_resolver mb.mod_delta oldsenv.modresolver
+  in
+  (mp,mbids,mb.mod_delta),
+  propagate_senv (l,SFBmodule mb) newenv newresolver senv' oldsenv
+
+let build_mtb mp sign cst delta =
+  { mod_mp = mp;
+    mod_expr = Abstract;
+    mod_type = sign;
+    mod_type_alg = None;
+    mod_constraints = cst;
+    mod_delta = delta;
+    mod_retroknowledge = [] }
 
 let end_modtype l senv =
-  let oldsenv = senv.old in
-  let modinfo = senv.modinfo in
-  let params =
-    match modinfo.variant with
-      | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end ()
-      | SIG params -> params
+  let mp = senv.modpath in
+  let params, oldsenv = check_sig senv.modvariant in
+  let () = check_current_label l mp in
+  let () = check_empty_context senv in
+  let mbids = List.rev_map fst params in
+  let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in
+  let newenv = Environ.add_constraints senv.univ newenv in
+  let newenv = set_engagement_opt newenv senv.engagement in
+  let senv' = propagate_loads {senv with env=newenv} in
+  let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in
+  let mtb = build_mtb mp auto_tb senv'.univ senv.modresolver in
+  let newenv = Environ.add_modtype mtb senv'.env in
+  let newresolver = oldsenv.modresolver in
+  (mp,mbids),
+  propagate_senv (l,SFBmodtype mtb) newenv newresolver senv' oldsenv
+
+(** {6 Inclusion of module or module type } *)
+
+let add_include me is_module inl senv =
+  let open Mod_typing in
+  let mp_sup = senv.modpath in
+  let sign,cst,resolver =
+    if is_module then
+      let sign,_,reso,cst = translate_mse_incl senv.env mp_sup inl me in
+      sign,cst,reso
+    else
+      let mtb = translate_modtype senv.env mp_sup inl ([],me) in
+      mtb.mod_type,mtb.mod_constraints,mtb.mod_delta
   in
-  if l <> modinfo.label then error_incompatible_labels l modinfo.label;
-  if not (empty_context senv.env) then error_non_empty_local_context None;
-  let auto_tb =
-     SEBstruct (List.rev senv.revstruct)
+  let senv = add_constraints (Now cst) senv in
+  (* Include Self support  *)
+  let rec compute_sign sign mb resolver senv =
+    match sign with
+    | MoreFunctor(mbid,mtb,str) ->
+      let cst_sub = Subtyping.check_subtypes senv.env mb mtb in
+      let senv = add_constraints (Now cst_sub) senv in
+      let mpsup_delta =
+	Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta
+      in
+      let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in
+      let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in
+      compute_sign (Modops.subst_signature subst str) mb resolver senv
+    | str -> resolver,str,senv
   in
-  let mtb_expr =
-    List.fold_left
-      (fun mtb (arg_id,arg_b) ->
-	 SEBfunctor(arg_id,arg_b,mtb))
-      auto_tb
-      params
+  let resolver,sign,senv =
+    let struc = NoFunctor (List.rev senv.revstruct) in
+    let mtb = build_mtb mp_sup struc Univ.Constraint.empty senv.modresolver in
+    compute_sign sign mtb resolver senv
   in
-  let mp = MPdot (oldsenv.modinfo.modpath, l) in
-  let newenv = oldsenv.env in
-  let newenv = Environ.add_constraints senv.univ  newenv in
-  let newenv = set_engagement_opt senv.engagement newenv in
-  let senv = {senv with env=newenv} in
-  let senv =
-    List.fold_left
-      (fun env (mp,mb) -> full_add_module mb env)
-      senv
-      (List.rev senv.loads)
+  let str = match sign with
+    | NoFunctor struc -> struc
+    | MoreFunctor _ -> Modops.error_higher_order_include ()
   in
-  let mtb = {typ_mp = mp;
-    typ_expr = mtb_expr;
-    typ_expr_alg = None;
-    typ_constraints = senv.univ;
-    typ_delta = senv.modinfo.resolver} in
-  let newenv =
-    Environ.add_modtype mp mtb senv.env
+  let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv
   in
-    mp, { old = oldsenv.old;
-	  env = newenv;
-	  modinfo = oldsenv.modinfo;
-	  modlabels = Labset.add l oldsenv.modlabels;
-	  objlabels = oldsenv.objlabels;
-	  revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
-          univ = Univ.union_constraints senv.univ oldsenv.univ;
-          engagement = senv.engagement;
-	  imports = senv.imports;
-	  loads = senv.loads@oldsenv.loads;
-          (* spiwack : if there is a bug with retroknowledge in nested modules
-             it's likely to come from here *)
-          local_retroknowledge = 
-        senv.local_retroknowledge@oldsenv.local_retroknowledge}
-
-let current_modpath senv = senv.modinfo.modpath
-let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param
-
-(* Check that the engagement expected by a library matches the initial one *)
-let check_engagement env c =
-  match Environ.engagement env, c with
-    | Some ImpredicativeSet, Some ImpredicativeSet -> ()
-    | _, None -> ()
-    | _, Some ImpredicativeSet ->
-        error "Needs option -impredicative-set."
-
-let set_engagement c senv =
-  {senv with
-    env = Environ.set_engagement c senv.env;
-    engagement = Some c }
+  let add senv ((l,elem) as field) =
+    let new_name = match elem with
+      | SFBconst _ ->
+        C (Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp_sup l))
+      | SFBmind _ ->
+	I (Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp_sup l))
+      | SFBmodule _ -> M
+      | SFBmodtype _ -> MT
+    in
+    add_field field new_name senv
+  in
+  resolver, List.fold_left add senv str
 
-(* Libraries = Compiled modules *)
+(** {6 Libraries, i.e. compiled modules } *)
 
-type compiled_library =
-    dir_path * module_body * library_info list * engagement option
+type compiled_library = {
+  comp_name : DirPath.t;
+  comp_mod : module_body;
+  comp_deps : library_info array;
+  comp_enga : engagement option;
+  comp_natsymbs : Nativecode.symbol array
+}
 
-(* We check that only initial state Require's were performed before
-   [start_library] was called *)
+type native_library = Nativecode.global list
 
-let is_empty senv =
-  senv.revstruct = [] &&
-  senv.modinfo.modpath = initial_path &&
-  senv.modinfo.variant = NONE
+(** FIXME: MS: remove?*)
+let current_modpath senv = senv.modpath
+let current_dirpath senv = Names.ModPath.dp (current_modpath senv)
 
 let start_library dir senv =
-  if not (is_empty senv) then
-    anomaly "Safe_typing.start_library: environment should be empty";
-  let dir_path,l =
-    match (repr_dirpath dir) with
-	[] -> anomaly "Empty dirpath in Safe_typing.start_library"
-      | hd::tl ->
-	  make_dirpath tl, label_of_id hd
-  in
+  check_initial senv;
+  assert (not (DirPath.is_empty dir));
   let mp = MPfile dir in
-  let modinfo = {modpath = mp;
-		 label = l;
-		 variant = LIBRARY dir;
-		 resolver = empty_delta_resolver;
-		 resolver_of_param = empty_delta_resolver}
+  mp,
+  { empty_environment with
+    env = senv.env;
+    modpath = mp;
+    modvariant = LIBRARY;
+    required = senv.required }
+
+let export ?except senv dir =
+  let senv =
+    try join_safe_environment ?except senv
+    with e ->
+      let e = Errors.push e in
+      Errors.errorlabstrm "export" (Errors.iprint e)
   in
-  mp, { old = senv;
-	env = senv.env;
-	modinfo = modinfo;
-	modlabels = Labset.empty;
-	objlabels = Labset.empty;
-	revstruct = [];
-        univ = Univ.empty_constraint;
-        engagement = None;
-	imports = senv.imports;
-	loads = [];
-        local_retroknowledge = [] }
-
-let pack_module senv =
-  {mod_mp=senv.modinfo.modpath;
-   mod_expr=None;
-   mod_type= SEBstruct (List.rev senv.revstruct);
-   mod_type_alg=None;
-   mod_constraints=empty_constraint;
-   mod_delta=senv.modinfo.resolver;
-   mod_retroknowledge=[];
-  }
-
-let export senv dir =
-  let modinfo = senv.modinfo in
-  begin
-    match modinfo.variant with
-      | LIBRARY dp ->
-	  if dir <> dp then
-	    anomaly "We are not exporting the right library!"
-      | _ ->
-	  anomaly "We are not exporting the library"
-  end;
-  (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then
-    (* error_export_simple *) (); *)
-    let str = SEBstruct (List.rev senv.revstruct) in
-    let mp = senv.modinfo.modpath in
-    let mb = 
+  assert(senv.future_cst = []);
+  let () = check_current_library dir senv in
+  let mp = senv.modpath in
+  let str = NoFunctor (List.rev senv.revstruct) in
+  let mb =
     { mod_mp = mp;
-      mod_expr = Some str;
+      mod_expr = FullStruct;
       mod_type = str;
       mod_type_alg = None;
       mod_constraints = senv.univ;
-      mod_delta = senv.modinfo.resolver;
-      mod_retroknowledge = senv.local_retroknowledge}
+      mod_delta = senv.modresolver;
+      mod_retroknowledge = senv.local_retroknowledge
+    }
+  in
+  let ast, values =
+    if !Flags.no_native_compiler then [], [||]
+    else
+      Nativelibrary.dump_library mp dir senv.env str
+  in
+  let lib = {
+    comp_name = dir;
+    comp_mod = mb;
+    comp_deps = Array.of_list (DPMap.bindings senv.required);
+    comp_enga = Environ.engagement senv.env;
+    comp_natsymbs = values }
   in
-   mp, (dir,mb,senv.imports,engagement senv.env)
+  mp, lib, ast
+
+(* cst are the constraints that were computed by the vi2vo step and hence are
+ * not part of the mb.mod_constraints field (but morally should be) *)
+let import lib cst vodigest senv =
+  check_required senv.required lib.comp_deps;
+  check_engagement senv.env lib.comp_enga;
+  let mp = MPfile lib.comp_name in
+  let mb = lib.comp_mod in
+  let env = Environ.add_constraints mb.mod_constraints senv.env in
+  let env = Environ.push_context_set cst env in
+  (mp, lib.comp_natsymbs),
+  { senv with
+    env =
+      (let linkinfo =
+	 Nativecode.link_info_of_dirpath lib.comp_name
+       in
+       Modops.add_linked_module mb linkinfo env);
+    modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver;
+    required = DPMap.add lib.comp_name vodigest senv.required;
+    loads = (mp,mb)::senv.loads }
 
+(** {6 Safe typing } *)
 
-let check_imports senv needed =
-  let imports = senv.imports in
-  let check (id,stamp) =
-    try
-      let actual_stamp = List.assoc id imports in
-      if stamp <> actual_stamp then
-	error
-	  ("Inconsistent assumptions over module "^(string_of_dirpath id)^".")
-    with Not_found ->
-      error ("Reference to unknown module "^(string_of_dirpath id)^".")
-  in
-  List.iter check needed
+type judgment = Environ.unsafe_judgment
+
+let j_val j = j.Environ.uj_val
+let j_type j = j.Environ.uj_type
 
+let typing senv = Typeops.infer (env_of_senv senv)
 
+(** {6 Retroknowledge / native compiler } *)
+
+(** universal lifting, used for the "get" operations mostly *)
+let retroknowledge f senv =
+  Environ.retroknowledge f (env_of_senv senv)
+
+let register field value by_clause senv =
+  (* todo : value closed, by_clause safe, by_clause of the proper type*)
+  (* spiwack : updates the safe_env with the information that the register
+     action has to be performed (again) when the environement is imported *)
+  { senv with
+    env = Environ.register senv.env field value;
+    local_retroknowledge =
+      Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
+  }
+
+(* This function serves only for inlining constants in native compiler for now,
+but it is meant to become a replacement for environ.register *)
+let register_inline kn senv =
+  let open Environ in
+  let open Pre_env in
+  if not (evaluable_constant kn senv.env) then
+    Errors.error "Register inline: an evaluable constant is expected";
+  let env = pre_env senv.env in
+  let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in
+  let cb = {cb with const_inline_code = true} in
+  let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in
+  let new_globals = { env.env_globals with env_constants = new_constants } in
+  let env = { env with env_globals = new_globals } in
+  { senv with env = env_of_pre_env env }
+
+let add_constraints c = add_constraints (Now c)
+
+
+(* NB: The next old comment probably refers to [propagate_loads] above.
+   When a Require is done inside a module, we'll redo this require
+   at the upper level after the module is ended, and so on.
+   This is probably not a big deal anyway, since these Require's
+   inside modules should be pretty rare. Maybe someday we could
+   brutally forbid this tricky "feature"... *)
 
 (* we have an inefficiency: Since loaded files are added to the
 environment every time a module is closed, their components are
-calculated many times. Thic could be avoided in several ways:
+calculated many times. This could be avoided in several ways:
 
 1 - for each file create a dummy environment containing only this
 file's components, merge this environment with the global
@@ -731,170 +866,6 @@ loaded by side-effect once and for all (like it is done in OCaml).
 Would this be correct with respect to undo's and stuff ?
 *)
 
-let import (dp,mb,depends,engmt) digest senv =
-  check_imports senv depends;
-  check_engagement senv.env engmt;
-  let mp = MPfile dp in
-  let env = senv.env in
-  let env = Environ.add_constraints mb.mod_constraints env in
-  let env = Modops.add_module mb env in
-  mp, { senv with
-	  env = env;
-	  modinfo = 
-      {senv.modinfo with 
-	 resolver = 
-	    add_delta_resolver mb.mod_delta senv.modinfo.resolver};
-	  imports = (dp,digest)::senv.imports;
-	  loads = (mp,mb)::senv.loads }
-
-
- (* Store the body of modules' opaque constants inside a table.  
-
-    This module is used during the serialization and deserialization
-    of vo files. 
-
-    By adding an indirection to the opaque constant definitions, we
-    gain the ability not to load them. As these constant definitions
-    are usually big terms, we save a deserialization time as well as
-    some memory space. *)
-module LightenLibrary : sig
-  type table 
-  type lightened_compiled_library 
-  val save : compiled_library -> lightened_compiled_library * table
-  val load : load_proof:Flags.load_proofs -> table Lazy.t
-    -> lightened_compiled_library -> compiled_library
-end = struct
-
-  (* The table is implemented as an array of [constr_substituted].
-     Keys are hence integers. To avoid changing the [compiled_library]
-     type, we brutally encode integers into [lazy_constr]. This isn't
-     pretty, but shouldn't be dangerous since the produced structure
-     [lightened_compiled_library] is abstract and only meant for writing
-     to .vo via Marshal (which doesn't care about types).
-  *)
-  type table = constr_substituted array
-  let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr)
-  let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
-
-  (* To avoid any future misuse of the lightened library that could 
-     interpret encoded keys as real [constr_substituted], we hide 
-     these kind of values behind an abstract datatype. *)
-  type lightened_compiled_library = compiled_library
-
-  (* Map a [compiled_library] to another one by just updating 
-     the opaque term [t] to [on_opaque_const_body t]. *)
-  let traverse_library on_opaque_const_body =
-    let rec traverse_module mb =
-      match mb.mod_expr with 
-	  None -> 
-	    { mb with
-		mod_expr = None;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }
-	| Some impl when impl == mb.mod_type-> 
-	    let mtb =  traverse_modexpr mb.mod_type in 
-	      { mb with
-		  mod_expr = Some mtb;
-		  mod_type = mtb;
-	      }    
-	| Some impl -> 
-	    { mb with
-		mod_expr = Option.map traverse_modexpr mb.mod_expr;
-		mod_type = traverse_modexpr mb.mod_type;
-	    }    
-    and traverse_struct struc =
-      let traverse_body (l,body) = (l,match body with
-	| SFBconst cb when is_opaque cb ->
-	  SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
-	| (SFBconst _ | SFBmind _ ) as x ->
-	  x
-	| SFBmodule m -> 
-	  SFBmodule (traverse_module m)
-	| SFBmodtype m -> 
-	  SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
-      in
-      List.map traverse_body struc
-	
-    and traverse_modexpr = function
-      | SEBfunctor (mbid,mty,mexpr) ->
-	SEBfunctor (mbid,
-		    ({mty with
-		      typ_expr = traverse_modexpr mty.typ_expr}),
-		    traverse_modexpr mexpr)
-      | SEBident mp as x -> x
-      | SEBstruct (struc) ->
-	SEBstruct  (traverse_struct struc)
-      | SEBapply (mexpr,marg,u) ->
-	SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
-      | SEBwith (seb,wdcl) ->
-	SEBwith (traverse_modexpr seb,wdcl)
-    in
-    fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s) 
-
-  (* To disburden a library from opaque definitions, we simply 
-     traverse it and add an indirection between the module body 
-     and its reference to a [const_body]. *)
-  let save library = 
-    let ((insert    : constant_def -> constant_def),
-	 (get_table : unit -> table)) = 
-      (* We use an integer as a key inside the table. *)
-      let counter = ref (-1) in
-
-      (* During the traversal, the table is implemented by a list 
-	 to get constant time insertion. *)
-      let opaque_definitions = ref [] in
-      
-      ((* Insert inside the table. *) 
-	(fun def ->
-	  let opaque_definition = match def with
-	    | OpaqueDef lc -> force_lazy_constr lc
-	    | _ -> assert false
-	  in
-	  incr counter;
-	  opaque_definitions := opaque_definition :: !opaque_definitions;
-	  OpaqueDef (key_as_lazy_constr !counter)),
-
-       (* Get the final table representation. *)
-       (fun () -> Array.of_list (List.rev !opaque_definitions)))
-    in
-    let lightened_library = traverse_library insert library in
-    (lightened_library, get_table ())
-
-  (* Loading is also a traversing that decodes the embedded keys that
-     are inside the [lightened_library]. If the [load_proof] flag is
-     set, we lookup inside the table to graft the
-     [constr_substituted]. Otherwise, we set the [const_body] field
-     to [None]. 
-  *)
-  let load ~load_proof (table : table Lazy.t) lightened_library =
-    let decode_key = function
-      | Undef _ | Def _ -> assert false
-      | OpaqueDef k ->
-	  let k = key_of_lazy_constr k in
-	  let access key =
-	    try (Lazy.force table).(key)
-	    with e when Errors.noncritical e ->
-              error "Error while retrieving an opaque body"
-	  in
-	  match load_proof with
-	    | Flags.Force ->
-	      let lc = Lazy.lazy_from_val (access k) in
-	      OpaqueDef (make_lazy_constr lc)
-	    | Flags.Lazy ->
-	      let lc = lazy (access k) in
-	      OpaqueDef (make_lazy_constr lc)
-	    | Flags.Dont ->
-	      Undef None
-    in
-    traverse_library decode_key lightened_library
-
-end
-
-type judgment = unsafe_judgment
-
-let j_val j = j.uj_val
-let j_type j = j.uj_type
-
-let safe_infer senv = infer (env_of_senv senv)
-
-let typing senv = Typeops.typing (env_of_senv senv)
+let set_strategy e k l = { e with env =
+   (Environ.set_oracle e.env
+      (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) }
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index dada3001..abd5cd7a 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -1,150 +1,179 @@
 (************************************************************************)
 (*  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 Declarations
-open Entries
-open Mod_subst
+
+type vodigest =
+  | Dvo_or_vi of Digest.t        (* The digest of the seg_lib part *)
+  | Dvivo of Digest.t * Digest.t (* The digest of the seg_lib + seg_univ part *)
+
+val digest_match : actual:vodigest -> required:vodigest -> bool
 
 (** {6 Safe environments } *)
 
-(** Since we are now able to type terms, we can
-  define an abstract type of safe environments, where objects are
-  typed before being added.
+(** Since we are now able to type terms, we can define an abstract type
+    of safe environments, where objects are typed before being added.
 
-  We also add [open_structure] and [close_section], [close_module] to
-  provide functionnality for sections and interactive modules
+    We also provide functionality for modules : [start_module], [end_module],
+    etc.
 *)
 
 type safe_environment
 
+val empty_environment : safe_environment
+
+val is_initial : safe_environment -> bool
+
 val env_of_safe_env : safe_environment -> Environ.env
 
-val empty_environment : safe_environment
-val is_empty : safe_environment -> bool
+(** The safe_environment state monad *)
+
+type safe_transformer0 = safe_environment -> safe_environment
+type 'a safe_transformer = safe_environment -> 'a * safe_environment
+
+
+(** {6 Stm machinery } *)
+
+val sideff_of_con : safe_environment -> constant -> Declarations.side_effect
+val sideff_of_scheme :
+  string -> safe_environment -> (inductive * constant) list ->
+    Declarations.side_effect
+
+val is_curmod_library : safe_environment -> bool
+
+(* safe_environment has functional data affected by lazy computations,
+ * thus this function returns a new safe_environment *)
+val join_safe_environment :
+  ?except:Future.UUIDSet.t -> safe_environment -> safe_environment
+
+(** {6 Enriching a safe environment } *)
+
+(** Insertion of local declarations (Local or Variables) *)
 
-(** Adding and removing local declarations (Local or Variables) *)
 val push_named_assum :
-  identifier * types -> safe_environment ->
-    Univ.constraints * safe_environment
+  (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0
 val push_named_def :
-  identifier * constr * types option -> safe_environment ->
-    Univ.constraints * safe_environment
+  Id.t * Entries.definition_entry -> safe_transformer0
+
+(** Insertion of global axioms or definitions *)
 
-(** Adding global axioms or definitions *)
 type global_declaration =
-  | ConstantEntry of constant_entry
+  | ConstantEntry of Entries.constant_entry
   | GlobalRecipe of Cooking.recipe
 
 val add_constant :
-  dir_path -> label -> global_declaration -> safe_environment ->
-      constant * safe_environment
+  DirPath.t -> Label.t -> global_declaration -> constant safe_transformer
 
 (** Adding an inductive type *)
+
 val add_mind :
-  dir_path -> label -> mutual_inductive_entry -> safe_environment ->
-    mutual_inductive * safe_environment
+  DirPath.t -> Label.t -> Entries.mutual_inductive_entry ->
+    mutual_inductive safe_transformer
 
-(** Adding a module *)
-val add_module :
-  label -> module_entry -> inline -> safe_environment
-    -> module_path * delta_resolver * safe_environment
+(** Adding a module or a module type *)
 
-(** Adding a module type *)
+val add_module :
+  Label.t -> Entries.module_entry -> Declarations.inline ->
+    (module_path * Mod_subst.delta_resolver) safe_transformer
 val add_modtype :
-  label -> module_struct_entry -> inline -> safe_environment
-    -> module_path * safe_environment
+  Label.t -> Entries.module_type_entry -> Declarations.inline ->
+    module_path safe_transformer
 
 (** Adding universe constraints *)
+
+val push_context_set :
+  Univ.universe_context_set -> safe_transformer0
+
+val push_context :
+  Univ.universe_context -> safe_transformer0
+
 val add_constraints :
-  Univ.constraints -> safe_environment -> safe_environment
+  Univ.constraints -> safe_transformer0
+
+(* (\** Generator of universes *\) *)
+(* val next_universe : int safe_transformer *)
 
-(** Settin the strongly constructive or classical logical engagement *)
-val set_engagement : engagement -> safe_environment -> safe_environment
+(** Setting the strongly constructive or classical logical engagement *)
+val set_engagement : Declarations.engagement -> safe_transformer0
 
+(** Collapsing the type hierarchy *)
+val set_type_in_type : safe_transformer0
 
 (** {6 Interactive module functions } *)
 
-val start_module :
-  label -> safe_environment -> module_path * safe_environment
+val start_module : Label.t -> module_path safe_transformer
 
-val end_module :
-  label -> (module_struct_entry * inline) option
-      -> safe_environment -> module_path * delta_resolver * safe_environment 
+val start_modtype : Label.t -> module_path safe_transformer
 
 val add_module_parameter :
-  mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment
+  MBId.t -> Entries.module_struct_entry -> Declarations.inline ->
+    Mod_subst.delta_resolver safe_transformer
+
+(** The optional result type is given without its functorial part *)
 
-val start_modtype :
-  label -> safe_environment -> module_path * safe_environment
+val end_module :
+  Label.t -> (Entries.module_struct_entry * Declarations.inline) option ->
+    (module_path * MBId.t list * Mod_subst.delta_resolver) safe_transformer
 
-val end_modtype :
-  label -> safe_environment -> module_path * safe_environment
+val end_modtype : Label.t -> (module_path * MBId.t list) safe_transformer
 
 val add_include :
-  module_struct_entry -> bool -> inline -> safe_environment ->
-   delta_resolver * safe_environment
+  Entries.module_struct_entry -> bool -> Declarations.inline ->
+   Mod_subst.delta_resolver safe_transformer
 
-val pack_module : safe_environment -> module_body
 val current_modpath : safe_environment -> module_path
-val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
-  
 
-(** Loading and saving compilation units *)
+val current_dirpath : safe_environment -> dir_path
 
-(** exporting and importing modules *)
-type compiled_library
+(** {6 Libraries : loading and saving compilation units } *)
 
-val start_library : dir_path -> safe_environment
-      -> module_path * safe_environment
+type compiled_library
 
-val export : safe_environment -> dir_path
-      -> module_path * compiled_library
+type native_library = Nativecode.global list
 
-val import : compiled_library -> Digest.t -> safe_environment
-      -> module_path * safe_environment
+val start_library : DirPath.t -> module_path safe_transformer
 
-(** Remove the body of opaque constants *)
+val export :
+  ?except:Future.UUIDSet.t ->
+  safe_environment -> DirPath.t ->
+    module_path * compiled_library * native_library
 
-module LightenLibrary :
-sig
-  type table
-  type lightened_compiled_library
-  val save : compiled_library -> lightened_compiled_library * table
-  val load : load_proof:Flags.load_proofs -> table Lazy.t ->
-    lightened_compiled_library -> compiled_library
-end
+(* Constraints are non empty iff the file is a vi2vo *)
+val import : compiled_library -> Univ.universe_context_set -> vodigest ->
+  (module_path * Nativecode.symbol array) safe_transformer
 
-(** {6 Typing judgments } *)
+(** {6 Safe typing judgments } *)
 
 type judgment
 
-val j_val : judgment -> constr
-val j_type : judgment -> constr
+val j_val : judgment -> Term.constr
+val j_type : judgment -> Term.constr
 
-(** Safe typing of a term returning a typing judgment and universe
-   constraints to be added to the environment for the judgment to
-   hold. It is guaranteed that the constraints are satisfiable
- *)
-val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
+(** The safe typing of a term returns a typing judgment. *)
+val typing : safe_environment -> Term.constr -> judgment
 
-val typing : safe_environment -> constr -> judgment
+(** {6 Queries } *)
 
-(** {7 Query } *)
+val exists_objlabel : Label.t -> safe_environment -> bool
 
-val exists_objlabel : label -> safe_environment -> bool
+val delta_of_senv :
+  safe_environment -> Mod_subst.delta_resolver * Mod_subst.delta_resolver
 
-(*spiwack: safe retroknowledge functionalities *)
+(** {6 Retroknowledge / Native compiler } *)
 
 open Retroknowledge
 
 val retroknowledge : (retroknowledge-> 'a) -> safe_environment -> 'a
 
-val register : safe_environment -> field -> Retroknowledge.entry -> constr
-                                         -> safe_environment
+val register :
+  field -> Retroknowledge.entry -> Term.constr -> safe_transformer0
+
+val register_inline : constant -> safe_transformer0
+
+val set_strategy :
+  safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment
diff --git a/kernel/sign.ml b/kernel/sign.ml
deleted file mode 100644
index 15c5e435..00000000
--- a/kernel/sign.ml
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
-   rebuilding of Coq around a purely functional abstract type-checker,
-   Aug 1999 *)
-(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
-   Herbelin and Bruno Barras *)
-
-(* This file defines types and combinators regarding indexes-based and
-   names-based contexts *)
-
-open Names
-open Util
-open Term
-
-(*s Signatures of named hypotheses. Used for section variables and
-    goal assumptions. *)
-
-type named_context = named_declaration list
-
-let empty_named_context = []
-
-let add_named_decl d sign = d::sign
-
-let rec lookup_named id = function
-  | (id',_,_ as decl) :: _ when id=id' -> decl
-  | _ :: sign -> lookup_named id sign
-  | [] -> raise Not_found
-
-let named_context_length = List.length
-let named_context_equal = list_equal eq_named_declaration
-
-let vars_of_named_context = List.map (fun (id,_,_) -> id)
-
-let instance_from_named_context sign =
-  let rec inst_rec = function
-    | (id,None,_) :: sign -> mkVar id :: inst_rec sign
-    | _ :: sign -> inst_rec sign
-    | [] -> [] in
-  Array.of_list (inst_rec sign)
-
-let fold_named_context f l ~init = List.fold_right f l init
-let fold_named_context_reverse f ~init l = List.fold_left f init l
-
-(*s Signatures of ordered section variables *)
-type section_context = named_context
-
-let fold_rel_context f l ~init:x = List.fold_right f l x
-let fold_rel_context_reverse f ~init:x l = List.fold_left f x l
-
-let map_context f l =
-  let map_decl (n, body_o, typ as decl) =
-    let body_o' = Option.smartmap f body_o in
-    let typ' = f typ in
-      if body_o' == body_o && typ' == typ then decl else
-	(n, body_o', typ')
-  in
-    list_smartmap map_decl l
-
-let map_rel_context = map_context
-let map_named_context = map_context
-
-let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
-let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b)
-
-(* Push named declarations on top of a rel context *)
-(* Bizarre. Should be avoided. *)
-let push_named_to_rel_context hyps ctxt =
-  let rec push = function
-    | (id,b,t) :: l ->
-	let s, hyps = push l in
-	let d = (Name id, Option.map (subst_vars s) b, subst_vars s t) in
-	id::s, d::hyps
-    | [] -> [],[] in
-  let s, hyps = push hyps in
-  let rec subst = function
-    | d :: l ->
-	let n, ctxt = subst l in
-	(n+1), (map_rel_declaration (substn_vars n s) d)::ctxt
-    | [] -> 1, hyps in
-  snd (subst ctxt)
diff --git a/kernel/sign.mli b/kernel/sign.mli
deleted file mode 100644
index 6014b5e9..00000000
--- a/kernel/sign.mli
+++ /dev/null
@@ -1,64 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Term
-
-(** {6 Signatures of ordered named declarations } *)
-
-type named_context = named_declaration list
-type section_context = named_context
-
-val empty_named_context : named_context
-val add_named_decl : named_declaration -> named_context -> named_context
-val vars_of_named_context : named_context -> identifier list
-
-val lookup_named : identifier -> named_context -> named_declaration
-
-(** number of declarations *)
-val named_context_length : named_context -> int
-
-(** named context equality *)
-val named_context_equal : named_context -> named_context -> bool
-
-(** {6 Recurrence on [named_context]: older declarations processed first } *)
-val fold_named_context :
-  (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-
-(** newer declarations first *)
-val fold_named_context_reverse :
-  ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
-
-(** {6 Section-related auxiliary functions } *)
-val instance_from_named_context : named_context -> constr array
-
-(** {6 ... } *)
-(** Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices *)
-
-val push_named_to_rel_context : named_context -> rel_context -> rel_context
-
-(** {6 Recurrence on [rel_context]: older declarations processed first } *)
-val fold_rel_context :
-  (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-
-(** newer declarations first *)
-val fold_rel_context_reverse :
-  ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
-
-(** {6 Map function of [rel_context] } *)
-val map_rel_context : (constr -> constr) -> rel_context -> rel_context
-
-(** {6 Map function of [named_context] } *)
-val map_named_context : (constr -> constr) -> named_context -> named_context
-
-(** {6 Map function of [rel_context] } *)
-val iter_rel_context : (constr -> unit) -> rel_context -> unit
-
-(** {6 Map function of [named_context] } *)
-val iter_named_context : (constr -> unit) -> named_context -> unit
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
new file mode 100644
index 00000000..ae86d686
--- /dev/null
+++ b/kernel/sorts.ml
@@ -0,0 +1,107 @@
+(************************************************************************)
+(*  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 Univ
+
+type contents = Pos | Null
+
+type family = InProp | InSet | InType
+
+type t =
+  | Prop of contents                      (* proposition types *)
+  | Type of universe
+
+let prop = Prop Null
+let set = Prop Pos
+let type1 = Type type1_univ
+
+let univ_of_sort = function
+  | Type u -> u
+  | Prop Pos -> Universe.type0
+  | Prop Null -> Universe.type0m
+
+let sort_of_univ u =
+  if is_type0m_univ u then Prop Null
+  else if is_type0_univ u then Prop Pos
+  else Type u
+
+let compare s1 s2 =
+  if s1 == s2 then 0 else
+  match s1, s2 with
+  | Prop c1, Prop c2 ->
+    begin match c1, c2 with
+    | Pos, Pos | Null, Null -> 0
+    | Pos, Null -> -1
+    | Null, Pos -> 1
+    end
+  | Type u1, Type u2 -> Universe.compare u1 u2
+  | Prop _, Type _ -> -1
+  | Type _, Prop _ -> 1
+
+let equal s1 s2 = Int.equal (compare s1 s2) 0
+
+let is_prop = function
+  | Prop Null -> true
+  | Type u when Universe.equal Universe.type0m u -> true
+  | _ -> false
+
+let is_set = function
+  | Prop Pos -> true
+  | Type u when Universe.equal Universe.type0 u -> true
+  | _ -> false
+
+let is_small = function
+  | Prop _ -> true
+  | Type u -> is_small_univ u
+
+let family = function
+  | Prop Null -> InProp
+  | Prop Pos -> InSet
+  | Type _ -> InType
+
+let family_equal = (==)
+
+open Hashset.Combine
+
+let hash = function
+| Prop p ->
+  let h = match p with
+  | Pos -> 0
+  | Null -> 1
+  in
+  combinesmall 1 h
+| Type u ->
+  let h = Hashtbl.hash u in (** FIXME *)
+  combinesmall 2 h
+
+module List = struct
+  let mem = List.memq
+  let intersect l l' = CList.intersect family_equal l l'
+end
+
+module Hsorts =
+  Hashcons.Make(
+    struct
+      type _t = t
+      type t = _t
+      type u = universe -> universe
+
+      let hashcons huniv = function
+        | Type u as c -> 
+	  let u' = huniv u in 
+	    if u' == u then c else Type u'
+        | s -> s
+      let equal s1 s2 = match (s1,s2) with
+        | (Prop c1, Prop c2) -> c1 == c2
+        | (Type u1, Type u2) -> u1 == u2
+        |_ -> false
+
+      let hash = Hashtbl.hash (** FIXME *)
+    end)
+
+let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ
diff --git a/kernel/sorts.mli b/kernel/sorts.mli
new file mode 100644
index 00000000..cd65b231
--- /dev/null
+++ b/kernel/sorts.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {6 The sorts of CCI. } *)
+
+type contents = Pos | Null
+
+type family = InProp | InSet | InType
+
+type t =
+| Prop of contents       (** Prop and Set *)
+| Type of Univ.universe  (** Type *)
+
+val set  : t
+val prop : t
+val type1  : t
+
+val equal : t -> t -> bool
+val compare : t -> t -> int
+val hash : t -> int
+
+val is_set : t -> bool
+val is_prop : t -> bool
+val is_small : t -> bool
+val family : t -> family
+
+val hcons : t -> t
+
+val family_equal : family -> family -> bool
+
+module List : sig
+  val mem : family -> family list -> bool
+  val intersect : family list -> family list -> family list
+end
+
+val univ_of_sort : t -> Univ.universe
+val sort_of_univ : Univ.universe -> t
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index d17d7bb0..db155e6c 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.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        *)
@@ -17,12 +17,11 @@ open Names
 open Univ
 open Term
 open Declarations
-open Environ
+open Declareops
 open Reduction
 open Inductive
 open Modops
 open Mod_subst
-open Entries
 (*i*)
 
 (* This local type is used to subtype a constant with a constructor or
@@ -41,65 +40,81 @@ 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 (string_of_mp 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 (string_of_mp 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
 
 
-let check_conv_error error why cst f env a1 a2 =
-  try
-    union_constraints cst (f env a1 a2)
-  with
-      NotConvertible -> error why
+let check_conv_error error why cst poly u f env a1 a2 =
+  try 
+    let a1 = Vars.subst_instance_constr u a1 in
+    let a2 = Vars.subst_instance_constr u a2 in
+    let cst' = f env (Environ.universes env) a1 a2 in
+      if poly then 
+	if Constraint.is_empty cst' then cst
+	else error (IncompatiblePolymorphism (env, a1, a2))
+      else Constraint.union cst cst'
+  with NotConvertible -> error why
 
 (* for now we do not allow reorderings *)
 
 let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2= 
-  let kn1 = make_mind mp1 empty_dirpath l in
-  let kn2 = make_mind mp2 empty_dirpath l in
+  let kn1 = KerName.make2 mp1 l in
+  let kn2 = KerName.make2 mp2 l in
   let error why = error_signature_mismatch l spec2 why in
-  let check_conv why cst f = check_conv_error error why cst f in
+  let check_conv why cst poly u f = check_conv_error error why cst poly u f in
   let mib1 =
     match info1 with
-      | IndType ((_,0), mib) -> subst_mind subst1 mib
+      | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib
       | _ -> error (InductiveFieldExpected mib2)
   in
-  let mib2 =  subst_mind subst2 mib2 in
+  let poly = 
+    if not (mib1.mind_polymorphic == mib2.mind_polymorphic) then
+      error (PolymorphicStatusExpected mib2.mind_polymorphic)
+    else mib2.mind_polymorphic
+  in
+  let u = 
+    if poly then 
+      Errors.error ("Checking of subtyping of polymorphic" ^
+		       " inductive types not implemented")
+    else Instance.empty
+  in
+  let mib2 =  Declareops.subst_mind_body subst2 mib2 in
   let check_inductive_type cst name env t1 t2 =
 
     (* Due to sort-polymorphism in inductive types, the conclusions of
@@ -133,40 +148,44 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
 	error (NotConvertibleInductiveField name)
       | _ -> (s1, s2) in
     check_conv (NotConvertibleInductiveField name)
-      cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+      cst poly u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
   in
 
   let check_packet cst p1 p2 =
-    let check f why = if f p1 <> f p2 then error why in
-      check (fun p -> p.mind_consnames) NotSameConstructorNamesField;
-      check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField;
+    let check f test why = if not (test (f p1) (f p2)) then error why in
+      check (fun p -> p.mind_consnames) (Array.equal Id.equal) NotSameConstructorNamesField;
+      check (fun p -> p.mind_typename) Id.equal NotSameInductiveNameInBlockField;
       (* nf_lc later *)
       (* nf_arity later *)
       (* user_lc ignored *)
       (* user_arity ignored *)
-      check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
+      check (fun p -> p.mind_nrealargs) Int.equal (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
       (* kelim ignored *)
       (* listrec ignored *)
       (* finite done *)
       (* nparams done *)
       (* params_ctxt done because part of the inductive types *)
       (* Don't check the sort of the type if polymorphic *)
-      let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
-      in
+      let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in
+      let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in
+      let cst = Constraint.union cst1 (Constraint.union cst2 cst) in
+      let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in
 	cst
   in
+  let mind = mind_of_kn kn1 in
   let check_cons_types i cst p1 p2 =
-    array_fold_left3
-      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2)
+    Array.fold_left3
+      (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst
+	poly u infer_conv env t1 t2)
       cst
       p2.mind_consnames
-      (arities_of_specif kn1 (mib1,p1))
-      (arities_of_specif kn1 (mib2,p2))
+      (arities_of_specif (mind,u) (mib1,p1))
+      (arities_of_specif (mind,u) (mib2,p2))
   in
-  let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in
-  check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x);
-  check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x);
-  assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
+  let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in
+  check (fun mib -> mib.mind_finite<>Decl_kinds.CoFinite) (==) (fun x -> FiniteInductiveFieldExpected x);
+  check (fun mib -> mib.mind_ntypes) Int.equal (fun x -> InductiveNumbersFieldExpected x);
+  assert (List.is_empty mib1.mind_hyps && List.is_empty mib2.mind_hyps);
   assert (Array.length mib1.mind_packets >= 1
 	    && Array.length mib2.mind_packets >= 1);
 
@@ -175,49 +194,50 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
   (* at the time of checking the inductive arities in check_packet. *)
   (* Notice that we don't expect the local definitions to match: only *)
   (* the inductive types and constructors types have to be convertible *)
-  check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x);
+  check (fun mib -> mib.mind_nparams) Int.equal (fun x -> InductiveParamsNumberField x);
 
   begin
-  match mind_of_delta reso2 kn2  with
-      | kn2' when kn2=kn2' -> ()
-      | kn2' -> 
-	  if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then 
-	    error NotEqualInductiveAliases
+    let kn2' = kn_of_delta reso2 kn2 in
+    if KerName.equal kn2 kn2' ||
+       MutInd.equal (mind_of_delta_kn reso1 kn1)
+                    (subst_mind subst2 (MutInd.make kn2 kn2'))
+    then ()
+    else error NotEqualInductiveAliases
   end;
   (* we check that records and their field names are preserved. *)
-  check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x);
-  if mib1.mind_record then begin
+  check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x);
+  if mib1.mind_record <> None then begin
     let rec names_prod_letin t = match kind_of_term t with
       | Prod(n,_,t) -> n::(names_prod_letin t)
       | LetIn(n,_,_,t) -> n::(names_prod_letin t)
       | Cast(t,_,_) -> names_prod_letin t
       | _ -> []
     in
-    assert (Array.length mib1.mind_packets = 1);
-    assert (Array.length mib2.mind_packets = 1);
-    assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
-    assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
+    assert (Int.equal (Array.length mib1.mind_packets) 1);
+    assert (Int.equal (Array.length mib2.mind_packets) 1);
+    assert (Int.equal (Array.length mib1.mind_packets.(0).mind_user_lc) 1);
+    assert (Int.equal (Array.length mib2.mind_packets.(0).mind_user_lc) 1);
     check (fun mib ->
       let nparamdecls = List.length mib.mind_params_ctxt in
       let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in
-      snd (list_chop nparamdecls names))
+      snd (List.chop nparamdecls names)) (List.equal Name.equal)
       (fun x -> RecordProjectionsExpected x);
   end;
   (* we first check simple things *)
   let cst =
-    array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
+    Array.fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets
   in
   (* and constructor types in the end *)
   let cst =
-    array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
+    Array.fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets
   in
     cst
 
     
 let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = 
   let error why = error_signature_mismatch l spec2 why in
-  let check_conv cst f = check_conv_error error cst f in
-  let check_type cst env t1 t2 =
+  let check_conv cst poly u f = check_conv_error error cst poly u f in
+  let check_type poly u cst env t1 t2 =
 
     let err = NotConvertibleTypeField (env, t1, t2) in
 
@@ -264,18 +284,47 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 	  t1,t2
       else
         (t1,t2) in
-    check_conv err cst conv_leq env t1 t2
+      check_conv err cst poly u infer_conv_leq env t1 t2
   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*)
-      let typ1 = Typeops.type_of_constant_type env cb1.const_type in
-      let typ2 = Typeops.type_of_constant_type env cb2.const_type in
-      let cst = check_type cst env typ1 typ2 in
+      let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in
+      let cb1 = Declareops.subst_const_body subst1 cb1 in
+      let cb2 = Declareops.subst_const_body subst2 cb2 in
+      (* Start by checking universes *)
+      let poly = 
+	if not (cb1.const_polymorphic == cb2.const_polymorphic) then
+	  error (PolymorphicStatusExpected cb2.const_polymorphic)
+	else cb2.const_polymorphic
+      in
+      let cst', env', u = 
+	if poly then 
+	  let ctx1 = Univ.instantiate_univ_context cb1.const_universes in
+	  let ctx2 = Univ.instantiate_univ_context cb2.const_universes in
+	  let inst1, ctx1 = Univ.UContext.dest ctx1 in
+	  let inst2, ctx2 = Univ.UContext.dest ctx2 in
+	    if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then
+	      error IncompatibleInstances
+	    else 
+	      let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in
+	      let cstrs = Univ.Constraint.union cstrs ctx2 in
+		try 
+		  (* The environment with the expected universes plus equality 
+		     of the body instances with the expected instance *)
+		  let env = Environ.add_constraints cstrs env in
+		    (* Check that the given definition does not add any constraint over
+		       the expected ones, so that it can be used in place of the original. *)
+		    if Univ.check_constraints ctx1 (Environ.universes env) then
+		      cstrs, env, inst2
+		    else error (IncompatibleConstraints ctx1)
+		with Univ.UniverseInconsistency incon -> 
+		  error (IncompatibleUniverses incon)
+	else cst, env, Univ.Instance.empty
+      in
+      (* Now check types *)
+      let typ1 = Typeops.type_of_constant_type env' cb1.const_type in
+      let typ2 = Typeops.type_of_constant_type env' cb2.const_type in
+      let cst = check_type poly u cst env' typ1 typ2 in
       (* Now we check the bodies:
 	 - A transparent constant can only be implemented by a compatible
 	   transparent constant.
@@ -290,39 +339,47 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
 	    | Def lc1 ->
 	      (* NB: cb1 might have been strengthened and appear as transparent.
 		 Anyway [check_conv] will handle that afterwards. *)
-	      let c1 = Declarations.force lc1 in
-	      let c2 = Declarations.force lc2 in
-	      check_conv NotConvertibleBodyField cst conv env c1 c2))
+	      let c1 = Mod_subst.force_constr lc1 in
+	      let c2 = Mod_subst.force_constr lc2 in
+	      check_conv NotConvertibleBodyField cst poly u infer_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 DefinitionFieldExpected;
-      let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
+      let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in
+      if Declareops.constant_has_body cb2 then error DefinitionFieldExpected;
+      let u1 = inductive_instance mind1 in
+      let arity1,cst1 = constrained_type_of_inductive env 
+	((mind1,mind1.mind_packets.(i)),u1) in
+      let cst2 =
+        Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in 
       let typ2 = Typeops.type_of_constant_type env cb2.const_type in
+      let cst = Constraint.union cst (Constraint.union cst1 cst2) in
       let error = NotConvertibleTypeField (env, arity1, typ2) in
-       check_conv error cst conv_leq env arity1 typ2
+       check_conv error cst false Univ.Instance.empty infer_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 DefinitionFieldExpected;
-      let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
+      let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in
+      if Declareops.constant_has_body cb2 then error DefinitionFieldExpected;
+      let u1 = inductive_instance mind1 in
+      let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in
+      let cst2 =
+        Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in
       let ty2 = Typeops.type_of_constant_type env cb2.const_type in
+      let cst = Constraint.union cst (Constraint.union cst1 cst2) in
       let error = NotConvertibleTypeField (env, ty1, ty2) in
-       check_conv error cst conv env ty1 ty2
+       check_conv error cst false Univ.Instance.empty infer_conv env ty1 ty2
 
 let rec check_modules cst env msb1 msb2 subst1 subst2 =
-  let mty1 = module_type_of_module None msb1 in
-  let mty2 =  module_type_of_module None msb2 in
-  let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
-    cst
+  let mty1 = module_type_of_module msb1 in
+  let mty2 =  module_type_of_module msb2 in
+  check_modtypes cst env mty1 mty2 subst1 subst2 false
 
 and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= 
   let map1 = make_labmap mp1 sig1 in
@@ -344,67 +401,62 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
 	      | Modtype mtb -> mtb
 	      | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
 	    in
-	    let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
-	      (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
-	      check_modtypes cst 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 cst env mtb1 mtb2 subst1 subst2 true
   in
     List.fold_left check_one_body cst sig2
 
-and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = 
-  if mtb1==mtb2 then cst else 
-  let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in
-  let rec check_structure cst env str1 str2 equiv subst1 subst2 = 
-	match str1,str2 with
-	  | SEBstruct (list1), 
-	    SEBstruct (list2) -> 
-	      if equiv then
-		let subst2 = 
-		  add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
-		Univ.union_constraints 
-		  (check_signatures cst env
-		     mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
-		  mtb1.typ_delta mtb2.typ_delta) 
-		  (check_signatures cst env 
-		     mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1
-		  mtb2.typ_delta  mtb1.typ_delta)
-	      else
-		check_signatures cst env
-		  mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
-		  mtb1.typ_delta  mtb2.typ_delta
-	  | SEBfunctor (arg_id1,arg_t1,body_t1),
-	      SEBfunctor (arg_id2,arg_t2,body_t2) ->
-	      let subst1 = 
-		(join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in
-	      let cst = check_modtypes cst env 
-		arg_t2 arg_t1 subst2 subst1
-		equiv in 
-		(* contravariant *)
-	      let env = add_module 
-		(module_body_of_type (MPbound arg_id2) arg_t2) env 
-	      in
-	      let env = match body_t1 with
-		  SEBstruct str -> 
-		    add_module {mod_mp = mtb1.typ_mp;
-				mod_expr = None;
-				mod_type = subst_struct_expr subst1 body_t1;
-				mod_type_alg= None;
-				mod_constraints=mtb1.typ_constraints;
-				mod_retroknowledge = [];
-				mod_delta = mtb1.typ_delta} env
-		| _ -> env
-	      in
-		check_structure cst env body_t1 body_t2 equiv 
-		  subst1
-		  subst2
-	  | _ , _ -> error_incompatible_modtypes mtb1 mtb2
-      in
-     if mtb1'== mtb2' then cst
-     else check_structure cst env mtb1' mtb2' equiv subst1 subst2
+and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
+  if mtb1==mtb2 || mtb1.mod_type == mtb2.mod_type then cst
+  else
+    let rec check_structure cst env str1 str2 equiv subst1 subst2 =
+      match str1,str2 with
+      |NoFunctor list1,
+       NoFunctor list2 ->
+	if equiv then
+	  let subst2 = add_mp mtb2.mod_mp mtb1.mod_mp mtb1.mod_delta subst2 in
+          let cst1 = check_signatures cst env
+	    mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2
+	    mtb1.mod_delta mtb2.mod_delta
+          in
+          let cst2 = check_signatures cst env
+	    mtb2.mod_mp list2 mtb1.mod_mp list1 subst2 subst1
+	    mtb2.mod_delta  mtb1.mod_delta
+	  in
+	  Univ.Constraint.union cst1 cst2
+	else
+	  check_signatures cst env
+	    mtb1.mod_mp list1 mtb2.mod_mp list2 subst1 subst2
+	    mtb1.mod_delta  mtb2.mod_delta
+      |MoreFunctor (arg_id1,arg_t1,body_t1),
+       MoreFunctor (arg_id2,arg_t2,body_t2) ->
+        let mp2 = MPbound arg_id2 in
+	let subst1 = join (map_mbid arg_id1 mp2 arg_t2.mod_delta) subst1 in
+	let cst = check_modtypes cst env arg_t2 arg_t1 subst2 subst1 equiv in
+        (* contravariant *)
+	let env = add_module_type mp2 arg_t2 env in
+	let env =
+          if Modops.is_functor body_t1 then env
+          else add_module
+            {mod_mp = mtb1.mod_mp;
+	     mod_expr = Abstract;
+	     mod_type = subst_signature subst1 body_t1;
+	     mod_type_alg = None;
+	     mod_constraints = mtb1.mod_constraints;
+	     mod_retroknowledge = [];
+	     mod_delta = mtb1.mod_delta} env
+	in
+	check_structure cst env body_t1 body_t2 equiv subst1 subst2
+      | _ , _ -> error_incompatible_modtypes mtb1 mtb2
+    in
+    check_structure cst env mtb1.mod_type mtb2.mod_type equiv subst1 subst2
 
 let check_subtypes env sup super =
-  let env = add_module 
-		(module_body_of_type sup.typ_mp sup) env in
-  check_modtypes empty_constraint env 
-    (strengthen sup sup.typ_mp) super empty_subst
-    (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
+  let env = add_module_type sup.mod_mp sup env in
+  check_modtypes Univ.Constraint.empty env
+    (strengthen sup sup.mod_mp) super empty_subst
+    (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false
 
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index 32d108fe..443f5037 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.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/kernel/term.ml b/kernel/term.ml
index 38302463..7bf4c818 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -1,284 +1,201 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
-(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
-(* Extension to mutual inductive constructions by Christine Paulin for
-   Coq V5.10.2 *)
-(* Extension to co-inductive constructions by Eduardo Gimenez *)
-(* Optimization of substitution functions by Chet Murthy *)
-(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
-(* Hash-consing by Bruno Barras in Feb 1998 *)
-(* Restructuration of Coq of the type-checking kernel by Jean-Christophe 
-   Filliâtre, 1999 *)
-(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
-(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
-
-(* This file defines the internal syntax of the Calculus of
-   Inductive Constructions (CIC) terms together with constructors,
-   destructors, iterators and basic functions *)
-
 open Util
 open Pp
+open Errors
 open Names
-open Univ
-open Esubst
+open Context
+open Vars
 
+(**********************************************************************)
+(**         Redeclaration of types from module Constr                 *)
+(**********************************************************************)
 
-type existential_key = int
-type metavariable = int
+type contents = Sorts.contents = Pos | Null
 
-(* This defines the strategy to use for verifiying a Cast *)
-(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
-(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
-type cast_kind = VMcast | DEFAULTcast | REVERTcast
+type sorts = Sorts.t =
+  | Prop of contents       (** Prop and Set *)
+  | Type of Univ.universe  (** Type *)
 
-(* 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 vars of each constructor *)
-    ci_pp_info    : case_printing (* not interpreted by the kernel *)
-  }
+type sorts_family = Sorts.family = InProp | InSet | InType
 
-(* Sorts. *)
+type constr = Constr.t
+(** Alias types, for compatibility. *)
 
-type contents = Pos | Null
+type types = Constr.t
+(** Same as [constr], for documentation purposes. *)
 
-type sorts =
-  | Prop of contents                      (* proposition types *)
-  | Type of universe
+type existential_key = Constr.existential_key
+type existential = Constr.existential
 
-let prop_sort = Prop Null
-let set_sort = Prop Pos
-let type1_sort = Type type1_univ
+type metavariable = Constr.metavariable
 
-type sorts_family = InProp | InSet | InType
+type case_style = Constr.case_style =
+  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 
-let family_of_sort = function
-  | Prop Null -> InProp
-  | Prop Pos -> InSet
-  | Type _ -> InType
+type case_printing = Constr.case_printing =
+  { ind_tags : bool list; cstr_tags : bool list array; style : case_style }
+
+type case_info = Constr.case_info =
+  { ci_ind        : inductive;
+    ci_npar       : int;
+    ci_cstr_ndecls : int array;
+    ci_cstr_nargs : int array;
+    ci_pp_info    : case_printing
+  }
+
+type cast_kind = Constr.cast_kind =
+  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
 
 (********************************************************************)
 (*       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 rec_declaration = Constr.rec_declaration
+type fixpoint = Constr.fixpoint
+type cofixpoint = Constr.cofixpoint
+type 'constr pexistential = 'constr Constr.pexistential
 type ('constr, 'types) prec_declaration =
-    name array * 'types array * 'constr array
-type ('constr, 'types) pfixpoint =
-    (int array * int) * ('constr, 'types) prec_declaration
-type ('constr, 'types) pcofixpoint =
-    int * ('constr, 'types) prec_declaration
-
-(* [Var] is used for named variables and [Rel] for variables as
-   de Bruijn indices. *)
-type ('constr, 'types) kind_of_term =
+  ('constr, 'types) Constr.prec_declaration
+type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
+type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
+type 'a puniverses = 'a Univ.puniverses
+
+(** Simply type aliases *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
+
+type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term =
   | Rel       of int
-  | Var       of identifier
+  | Var       of Id.t
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
   | Cast      of 'constr * cast_kind * 'types
-  | Prod      of name * 'types * 'types
-  | Lambda    of name * 'types * 'constr
-  | LetIn     of name * 'constr * 'types * 'constr
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
   | App       of 'constr * 'constr array
-  | Const     of constant
-  | Ind       of inductive
-  | Construct of constructor
+  | Const     of pconstant
+  | Ind       of pinductive
+  | Construct of pconstructor
   | Case      of case_info * 'constr * 'constr * 'constr array
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
 
-(* constr is the fixpoint of the previous type. Requires option
-   -rectypes of the Caml compiler to be set *)
-type constr = (constr,constr) kind_of_term
-
-type existential = existential_key * constr array
-type rec_declaration = name array * constr array * constr array
-type fixpoint = (int array * int) * rec_declaration
-type cofixpoint = int * rec_declaration
-
-
-(*********************)
-(* Term constructors *)
-(*********************)
-
-(* Constructs a DeBrujin index with number n *)
-let rels =
-  [|Rel  1;Rel  2;Rel  3;Rel  4;Rel  5;Rel  6;Rel  7; Rel  8;
-    Rel  9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|]
-
-let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
-
-(* Construct a type *)
-let mkProp   = Sort prop_sort
-let mkSet    = Sort set_sort
-let mkType u = Sort (Type u)
-let mkSort   = function
-  | Prop Null -> mkProp (* Easy sharing *)
-  | Prop Pos -> mkSet
-  | s -> Sort s
-
-(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast (t1,k2,t2) =
-  match t1 with
-  | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2)
-  | _ -> Cast (t1,k2,t2)
-
-(* Constructs the product (x:t1)t2 *)
-let mkProd (x,t1,t2) = Prod (x,t1,t2)
-
-(* Constructs the abstraction [x:t1]t2 *)
-let mkLambda (x,t1,t2) = Lambda (x,t1,t2)
-
-(* Constructs [x=c_1:t]c_2 *)
-let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2)
-
-(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
-(* We ensure applicative terms have at least one argument and the
-   function is not itself an applicative term *)
-let mkApp (f, a) =
-  if Array.length a = 0 then f else
-    match f with
-      | App (g, cl) -> App (g, Array.append cl a)
-      | _ -> App (f, a)
-
-(* Constructs a constant *)
-let mkConst c = Const c
-
-(* Constructs an existential variable *)
-let mkEvar e = Evar e
-
-(* Constructs the ith (co)inductive type of the block named kn *)
-let mkInd m = Ind m
-
-(* Constructs the jth constructor of the ith (co)inductive type of the
-   block named kn. The array of terms correspond to the variables
-   introduced in the section *)
-let mkConstruct c = Construct c
-
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
-let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
-
-(* If recindxs = [|i1,...in|]
-      funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
+type values = Constr.values
 
-      mkFix ((recindxs,i),(funnames,typarray,bodies))
-
-   constructs the ith function of the block
-
-    Fixpoint f1 [ctx1] : t1 := b1
-    with     f2 [ctx2] : t2 := b2
-    ...
-    with     fn [ctxn] : tn := bn.
-
-   where the lenght of the jth context is ij.
-*)
-
-let mkFix fix = Fix fix
-
-(* If funnames = [|f1,...fn|]
-      typarray = [|t1,...tn|]
-      bodies   = [|b1,...bn|]
-   then
-
-      mkCoFix (i,(funnames,typsarray,bodies))
-
-   constructs the ith function of the block
-
-    CoFixpoint f1 : t1 := b1
-    with       f2 : t2 := b2
-    ...
-    with       fn : tn := bn.
-*)
-let mkCoFix cofix= CoFix cofix
-
-(* Constructs an existential variable named "?n" *)
-let mkMeta  n =  Meta n
-
-(* Constructs a Variable named id *)
-let mkVar id = Var id
-
-
-(************************************************************************)
-(*    kind_of_term = constructions as seen by the user                 *)
-(************************************************************************)
+(**********************************************************************)
+(**         Redeclaration of functions from module Constr             *)
+(**********************************************************************)
 
-(* User view of [constr]. For [App], it is ensured there is at
-   least one argument and the function is not itself an applicative
-   term *)
+let set_sort  = Sorts.set
+let prop_sort = Sorts.prop
+let type1_sort  = Sorts.type1
+let sorts_ord = Sorts.compare
+let is_prop_sort = Sorts.is_prop
+let family_of_sort = Sorts.family
+let univ_of_sort = Sorts.univ_of_sort
+let sort_of_univ = Sorts.sort_of_univ
+
+(** {6 Term constructors. } *)
+
+let mkRel = Constr.mkRel
+let mkVar = Constr.mkVar
+let mkMeta = Constr.mkMeta
+let mkEvar = Constr.mkEvar
+let mkSort = Constr.mkSort
+let mkProp = Constr.mkProp
+let mkSet  = Constr.mkSet 
+let mkType = Constr.mkType
+let mkCast = Constr.mkCast
+let mkProd = Constr.mkProd
+let mkLambda = Constr.mkLambda
+let mkLetIn = Constr.mkLetIn
+let mkApp = Constr.mkApp
+let mkConst = Constr.mkConst
+let mkProj = Constr.mkProj
+let mkInd = Constr.mkInd
+let mkConstruct = Constr.mkConstruct
+let mkConstU = Constr.mkConstU
+let mkIndU = Constr.mkIndU
+let mkConstructU = Constr.mkConstructU
+let mkConstructUi = Constr.mkConstructUi
+let mkCase = Constr.mkCase
+let mkFix = Constr.mkFix
+let mkCoFix = Constr.mkCoFix
 
-let kind_of_term c = c
+(**********************************************************************)
+(**         Aliases of functions from module Constr                   *)
+(**********************************************************************)
 
-(* Experimental, used in Presburger contrib *)
-type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
-  | CastType   of 'types * 'types
-  | ProdType   of name * 'types * 'types
-  | LetInType  of name * 'constr * 'types * 'types
-  | AtomicType of 'constr * 'constr array
+let eq_constr = Constr.equal
+let eq_constr_univs = Constr.eq_constr_univs
+let leq_constr_univs = Constr.leq_constr_univs
+let eq_constr_nounivs = Constr.eq_constr_nounivs
+
+let kind_of_term = Constr.kind
+let constr_ord = Constr.compare
+let fold_constr = Constr.fold
+let map_puniverses = Constr.map_puniverses
+let map_constr = Constr.map
+let map_constr_with_binders = Constr.map_with_binders
+let iter_constr = Constr.iter
+let iter_constr_with_binders = Constr.iter_with_binders
+let compare_constr = Constr.compare_head
+let hash_constr = Constr.hash
+let hcons_sorts = Sorts.hcons
+let hcons_constr = Constr.hcons
+let hcons_types = Constr.hcons
 
-let kind_of_type = function
-  | Sort s -> SortType s
-  | Cast (c,_,t) -> CastType (c, t)
-  | Prod (na,t,c) -> ProdType (na, t, c)
-  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
-  | App (c,l) -> AtomicType (c, l)
-  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
-    -> AtomicType (c,[||])
-  | (Lambda _ | Construct _) -> failwith "Not a type"
+(**********************************************************************)
+(**         HERE BEGINS THE INTERESTING STUFF                         *)
+(**********************************************************************)
 
 (**********************************************************************)
 (*          Non primitive term destructors                            *)
 (**********************************************************************)
 
 (* Destructor operations : partial functions
-   Raise invalid_arg "dest*" if the const has not the expected form *)
+   Raise [DestKO] if the const has not the expected form *)
+
+exception DestKO
 
 (* Destructs a DeBrujin index *)
 let destRel c = match kind_of_term c with
   | Rel n -> n
-  | _ -> invalid_arg "destRel"
+  | _ -> raise DestKO
 
 (* Destructs an existential variable *)
 let destMeta c = match kind_of_term c with
   | Meta n -> n
-  | _ -> invalid_arg "destMeta"
+  | _ -> raise DestKO
 
 let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
-let isMetaOf mv c = match kind_of_term c with Meta mv' -> mv = mv' | _ -> false
+let isMetaOf mv c =
+  match kind_of_term c with Meta mv' -> Int.equal mv mv' | _ -> false
 
 (* Destructs a variable *)
 let destVar c = match kind_of_term c with
   | Var id -> id
-  | _ -> invalid_arg "destVar"
+  | _ -> raise DestKO
 
 (* Destructs a type *)
 let isSort c = match kind_of_term c with
-  | Sort s -> true
+  | Sort _ -> true
   | _ -> false
 
 let destSort c = match kind_of_term c with
   | Sort s -> s
-  | _ -> invalid_arg "destSort"
+  | _ -> raise DestKO
 
 let rec isprop c = match kind_of_term c with
   | Sort (Prop _) -> true
@@ -300,11 +217,9 @@ let rec is_Type c = match kind_of_term c with
   | Cast (c,_,_) -> is_Type c
   | _ -> false
 
-let is_small = function
-  | Prop _ -> true
-  | _ -> false
+let is_small = Sorts.is_small
 
-let iskind c = isprop c or is_Type c
+let iskind c = isprop c || is_Type c
 
 (* Tests if an evar *)
 let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
@@ -316,18 +231,20 @@ let isEvar_or_Meta c = match kind_of_term c with
 (* Destructs a casted term *)
 let destCast c = match kind_of_term c with
   | Cast (t1,k,t2) -> (t1,k,t2)
-  | _ -> invalid_arg "destCast"
+  | _ -> raise DestKO
 
 let isCast c = match kind_of_term c with Cast _ -> true | _ -> false
 
 
 (* Tests if a de Bruijn index *)
 let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
-let isRelN n c = match kind_of_term c with Rel n' -> n = n' | _ -> false
+let isRelN n c =
+  match kind_of_term c with Rel n' -> Int.equal n n' | _ -> false
 
 (* Tests if a variable *)
 let isVar c = match kind_of_term c with Var _ -> true | _ -> false
-let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false
+let isVarId id c =
+  match kind_of_term c with Var id' -> Id.equal id id' | _ -> false
 
 (* Tests if an inductive *)
 let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
@@ -335,28 +252,28 @@ let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
 (* Destructs the product (x:t1)t2 *)
 let destProd c = match kind_of_term c with
   | Prod (x,t1,t2) -> (x,t1,t2)
-  | _ -> invalid_arg "destProd"
+  | _ -> raise DestKO
 
 let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false
 
 (* Destructs the abstraction [x:t1]t2 *)
 let destLambda c = match kind_of_term c with
   | Lambda (x,t1,t2) -> (x,t1,t2)
-  | _ -> invalid_arg "destLambda"
+  | _ -> raise DestKO
 
 let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
 
 (* Destructs the let [x:=b:t1]t2 *)
 let destLetIn c = match kind_of_term c with
   | LetIn (x,b,t1,t2) -> (x,b,t1,t2)
-  | _ -> invalid_arg "destLetIn"
+  | _ -> raise DestKO
 
 let isLetIn c =  match kind_of_term c with LetIn _ -> true | _ -> false
 
 (* Destructs an application *)
 let destApp c = match kind_of_term c with
   | App (f,a) -> (f, a)
-  | _ -> invalid_arg "destApplication"
+  | _ -> raise DestKO
 
 let destApplication = destApp
 
@@ -365,43 +282,49 @@ let isApp c = match kind_of_term c with App _ -> true | _ -> false
 (* Destructs a constant *)
 let destConst c = match kind_of_term c with
   | Const kn -> kn
-  | _ -> invalid_arg "destConst"
+  | _ -> raise DestKO
 
 let isConst c = match kind_of_term c with Const _ -> true | _ -> false
 
 (* Destructs an existential variable *)
 let destEvar c = match kind_of_term c with
   | Evar (kn, a as r) -> r
-  | _ -> invalid_arg "destEvar"
+  | _ -> raise DestKO
 
 (* Destructs a (co)inductive type named kn *)
 let destInd c = match kind_of_term c with
   | Ind (kn, a as r) -> r
-  | _ -> invalid_arg "destInd"
+  | _ -> raise DestKO
 
 (* Destructs a constructor *)
 let destConstruct c = match kind_of_term c with
   | Construct (kn, a as r) -> r
-  | _ -> invalid_arg "dest"
+  | _ -> raise DestKO
 
 let isConstruct c = match kind_of_term c with Construct _ -> true | _ -> false
 
 (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
 let destCase c = match kind_of_term c with
   | Case (ci,p,c,v) -> (ci,p,c,v)
-  | _ -> anomaly "destCase"
+  | _ -> raise DestKO
 
 let isCase c =  match kind_of_term c with Case _ -> true | _ -> false
 
+let isProj c =  match kind_of_term c with Proj _ -> true | _ -> false
+
+let destProj c = match kind_of_term c with
+  | Proj (p, c) -> (p, c)
+  | _ -> raise DestKO
+
 let destFix c = match kind_of_term c with
   | Fix fix -> fix
-  | _ -> invalid_arg "destFix"
+  | _ -> raise DestKO
 
 let isFix c =  match kind_of_term c with Fix _ -> true | _ -> false
 
 let destCoFix c = match kind_of_term c with
   | CoFix cofix -> cofix
-  | _ -> invalid_arg "destCoFix"
+  | _ -> raise DestKO
 
 let isCoFix c =  match kind_of_term c with CoFix _ -> true | _ -> false
 
@@ -413,7 +336,7 @@ let rec strip_outer_cast c = match kind_of_term c with
   | Cast (c,_,_) -> strip_outer_cast c
   | _ -> c
 
-(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
+(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
 
 let under_outer_cast f c =  match kind_of_term c with
   | Cast (b,k,t) -> mkCast (f b, k, f t)
@@ -428,12 +351,12 @@ let rec under_casts f c = match kind_of_term c with
 (******************************************************************)
 
 (* flattens application lists throwing casts in-between *)
-let rec collapse_appl c = match kind_of_term c with
+let collapse_appl c = match kind_of_term c with
   | App (f,cl) ->
       let rec collapse_rec f cl2 =
         match kind_of_term (strip_outer_cast f) with
-	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
-	| _ -> mkApp (f,cl2)
+        | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
+        | _ -> mkApp (f,cl2)
       in
       collapse_rec f cl
   | _ -> c
@@ -443,431 +366,15 @@ let decompose_app c =
     | App (f,cl) -> (f, Array.to_list cl)
     | _ -> (c,[])
 
-(****************************************************************************)
-(*              Functions to recur through subterms                         *)
-(****************************************************************************)
-
-(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
-   starting from [acc] and proceeding from left to right according to
-   the usual representation of the constructions; it is not recursive *)
-
-let fold_constr f acc c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> acc
-  | Cast (c,_,t) -> f (f acc c) t
-  | Prod (_,t,c) -> f (f acc t) c
-  | Lambda (_,t,c) -> f (f acc t) c
-  | LetIn (_,b,t,c) -> f (f (f acc b) t) c
-  | App (c,l) -> Array.fold_left f (f acc c) l
-  | Evar (_,l) -> Array.fold_left f acc l
-  | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl
-  | Fix (_,(lna,tl,bl)) ->
-      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
-  | CoFix (_,(lna,tl,bl)) ->
-      let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in
-      Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd
-
-(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
-
-let iter_constr f c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> ()
-  | Cast (c,_,t) -> f c; f t
-  | Prod (_,t,c) -> f t; f c
-  | Lambda (_,t,c) -> f t; f c
-  | LetIn (_,b,t,c) -> f b; f t; f c
-  | App (c,l) -> f c; Array.iter f l
-  | Evar (_,l) -> Array.iter f l
-  | Case (_,p,c,bl) -> f p; f c; Array.iter f bl
-  | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
-  | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl
-
-(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
-
-let iter_constr_with_binders g f n c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> ()
-  | Cast (c,_,t) -> f n c; f n t
-  | Prod (_,t,c) -> f n t; f (g n) c
-  | Lambda (_,t,c) -> f n t; f (g n) c
-  | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c
-  | App (c,l) -> f n c; Array.iter (f n) l
-  | Evar (_,l) -> Array.iter (f n) l
-  | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl
-  | Fix (_,(_,tl,bl)) ->
-      Array.iter (f n) tl;
-      Array.iter (f (iterate g (Array.length tl) n)) bl
-  | CoFix (_,(_,tl,bl)) ->
-      Array.iter (f n) tl;
-      Array.iter (f (iterate g (Array.length tl) n)) bl
-
-(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
-
-let map_constr f c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> c
-  | Cast (c,k,t) -> mkCast (f c, k, f t)
-  | Prod (na,t,c) -> mkProd (na, f t, f c)
-  | Lambda (na,t,c) -> mkLambda (na, f t, f c)
-  | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c)
-  | App (c,l) -> mkApp (f c, Array.map f l)
-  | Evar (e,l) -> mkEvar (e, Array.map f l)
-  | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl)
-  | Fix (ln,(lna,tl,bl)) ->
-      mkFix (ln,(lna,Array.map f tl,Array.map f bl))
-  | CoFix(ln,(lna,tl,bl)) ->
-      mkCoFix (ln,(lna,Array.map f tl,Array.map f bl))
-
-(* [map_constr_with_binders g f n c] maps [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
-
-let map_constr_with_binders g f l c = match kind_of_term c with
-  | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
-    | Construct _) -> c
-  | Cast (c,k,t) -> mkCast (f l c, k, f l t)
-  | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c)
-  | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c)
-  | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c)
-  | App (c,al) -> mkApp (f l c, Array.map (f l) al)
-  | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
-  | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
-  | Fix (ln,(lna,tl,bl)) ->
-      let l' = iterate g (Array.length tl) l in
-      mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-  | CoFix(ln,(lna,tl,bl)) ->
-      let l' = iterate g (Array.length tl) l in
-      mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl))
-
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's,
-   application associativity, binders name and Cases annotations are
-   not taken into account *)
-
-
-let compare_constr f t1 t2 =
-  match kind_of_term t1, kind_of_term t2 with
-  | Rel n1, Rel n2 -> n1 = n2
-  | Meta m1, Meta m2 -> m1 = m2
-  | Var id1, Var id2 -> id1 = id2
-  | Sort s1, Sort s2 -> s1 = s2
-  | Cast (c1,_,_), _ -> f c1 t2
-  | _, Cast (c2,_,_) -> f t1 c2
-  | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
-  | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
-  | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
-  | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
-  | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
-  | App (c1,l1), App (c2,l2) ->
-    Array.length l1 = Array.length l2 &&
-      f c1 c2 && array_for_all2 f l1 l2
-  | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
-  | Const c1, Const c2 -> eq_constant c1 c2
-  | Ind c1, Ind c2 -> eq_ind c1 c2
-  | Construct c1, Construct c2 -> eq_constructor c1 c2
-  | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-      f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2
-  | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
-  | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-      ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
-  | _ -> false
-
-(*******************************)
-(*  alpha conversion functions *)
-(*******************************)
-
-(* alpha conversion : ignore print names and casts *)
-
-let rec eq_constr m n =
-  (m==n) or
-  compare_constr eq_constr m n
-
-let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
-
-let constr_ord_int f t1 t2 =
-  let (=?) f g i1 i2 j1 j2=
-    let c=f i1 i2 in
-    if c=0 then g j1 j2 else c in
-  let (==?) fg h i1 i2 j1 j2 k1 k2=
-    let c=fg i1 i2 j1 j2 in
-    if c=0 then h k1 k2 else c in
-  match kind_of_term t1, kind_of_term t2 with
-    | Rel n1, Rel n2 -> n1 - n2
-    | Meta m1, Meta m2 -> m1 - m2
-    | Var id1, Var id2 -> id_ord id1 id2
-    | Sort s1, Sort s2 -> Pervasives.compare s1 s2
-    | Cast (c1,_,_), _ -> f c1 t2
-    | _, Cast (c2,_,_) -> f t1 c2
-    | Prod (_,t1,c1), Prod (_,t2,c2)
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
-	(f =? f) t1 t2 c1 c2
-    | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
-	((f =? f) ==? f) b1 b2 t1 t2 c1 c2
-    | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
-    | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
-    | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2
-    | Evar (e1,l1), Evar (e2,l2) ->
-	((-) =? (array_compare f)) e1 e2 l1 l2
-    | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2)
-    | Ind (spx, ix), Ind (spy, iy) ->
-	let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c
-    | Construct ((spx, ix), jx), Construct ((spy, iy), jy) ->
-	let c = jx - jy in if c = 0 then
-	  (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c)
-	else c
-    | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
-	ln1 ln2 tl1 tl2 bl1 bl2
-    | t1, t2 -> Pervasives.compare t1 t2
-
-let rec constr_ord m n=
-  constr_ord_int constr_ord m n
-
-(***************************************************************************)
-(*     Type of assumptions                                                 *)
-(***************************************************************************)
-
-type types = constr
-
-type strategy = types option
-
-type named_declaration = identifier * constr option * types
-type rel_declaration = name * constr option * types
-
-let map_named_declaration f (id, v, ty) = (id, Option.map f v, f ty)
-let map_rel_declaration = map_named_declaration
-
-let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
-let fold_rel_declaration = fold_named_declaration
-
-let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
-let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
-
-let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
-let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
-
-let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
-  id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
-
-let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
-  n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
-
-(***************************************************************************)
-(*     Type of local contexts (telescopes)                                 *)
-(***************************************************************************)
-
-(*s Signatures of ordered optionally named variables, intended to be
-   accessed by de Bruijn indices (to represent bound variables) *)
-
-type rel_context = rel_declaration list
-
-let empty_rel_context = []
-
-let add_rel_decl d ctxt = d::ctxt
-
-let rec lookup_rel n sign =
-  match n, sign with
-  | 1, decl :: _ -> decl
-  | n, _ :: sign -> lookup_rel (n-1) sign
-  | _, []        -> raise Not_found
-
-let rel_context_length = List.length
-
-let rel_context_nhyps hyps =
-  let rec nhyps acc = function
-    | [] -> acc
-    | (_,None,_)::hyps -> nhyps (1+acc) hyps
-    | (_,Some _,_)::hyps -> nhyps acc hyps in
-  nhyps 0 hyps
+let decompose_appvect c =
+  match kind_of_term c with
+    | App (f,cl) -> (f, cl)
+    | _ -> (c,[||])
 
 (****************************************************************************)
 (*              Functions for dealing with constr terms                     *)
 (****************************************************************************)
 
-(*********************)
-(*     Occurring     *)
-(*********************)
-
-exception LocalOccur
-
-(* (closedn n M) raises FreeVar if a variable of height greater than n
-   occurs in M, returns () otherwise *)
-
-let closedn n c =
-  let rec closed_rec n c = match kind_of_term c with
-    | Rel m -> if m>n then raise LocalOccur
-    | _ -> iter_constr_with_binders succ closed_rec n c
-  in
-  try closed_rec n c; true with LocalOccur -> false
-
-(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
-
-let closed0 = closedn 0
-
-(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
-
-let noccurn n term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel m -> if m = n then raise LocalOccur
-    | _ -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with LocalOccur -> false
-
-(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
-  for n <= p < n+m *)
-
-let noccur_between n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel(p) -> if n<=p && p<n+m then raise LocalOccur
-    | _        -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with LocalOccur -> false
-
-(* Checking function for terms containing existential variables.
- The function [noccur_with_meta] considers the fact that
- each existential variable (as well as each isevar)
- in the term appears applied to its local context,
- which may contain the CoFix variables. These occurrences of CoFix variables
- are not considered *)
-
-let noccur_with_meta n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p -> if n<=p & p<n+m then raise LocalOccur
-    | App(f,cl) ->
-	(match kind_of_term f with
-           | Cast (c,_,_) when isMeta c -> ()
-           | Meta _ -> ()
-	   | _ -> iter_constr_with_binders succ occur_rec n c)
-    | Evar (_, _) -> ()
-    | _ -> iter_constr_with_binders succ occur_rec n c
-  in
-  try (occur_rec n term; true) with LocalOccur -> false
-
-
-(*********************)
-(*      Lifting      *)
-(*********************)
-
-(* The generic lifting function *)
-let rec exliftn el c = match kind_of_term c with
-  | Rel i -> mkRel(reloc_rel i el)
-  | _ -> map_constr_with_binders el_lift exliftn el c
-
-(* Lifting the binding depth across k bindings *)
-
-let liftn n k =
-  match el_liftn (pred k) (el_shft n el_id) with
-    | ELID -> (fun c -> c)
-    | el -> exliftn el
-
-let lift n = liftn n 1
-
-(*********************)
-(*   Substituting    *)
-(*********************)
-
-(* (subst1 M c) substitutes M for Rel(1) in c
-   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
-   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
-
-(* 1st : general case *)
-
-type info = Closed | Open | Unknown
-type 'a substituend = { mutable sinfo: info; sit: 'a }
-
-let rec lift_substituend depth s =
-  match s.sinfo with
-    | Closed -> s.sit
-    | Open -> lift depth s.sit
-    | Unknown ->
-        s.sinfo <- if closed0 s.sit then Closed else Open;
-        lift_substituend depth s
-
-let make_substituend c = { sinfo=Unknown; sit=c }
-
-let substn_many lamv n c =
-  let lv = Array.length lamv in
-  if lv = 0 then c
-  else
-    let rec substrec depth c = match kind_of_term c with
-      | Rel k     ->
-          if k<=depth then c
-          else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1)
-          else mkRel (k-lv)
-      | _ -> map_constr_with_binders succ substrec depth c in
-    substrec n c
-
-(*
-let substkey = Profile.declare_profile "substn_many";;
-let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
-*)
-
-let substnl laml n =
-  substn_many (Array.map make_substituend (Array.of_list laml)) n
-let substl laml = substnl laml 0
-let subst1 lam = substl [lam]
-
-let substnl_decl laml k = map_rel_declaration (substnl laml k)
-let substl_decl laml = substnl_decl laml 0
-let subst1_decl lam = substl_decl [lam]
-let substnl_named laml k = map_named_declaration (substnl laml k)
-let substl_named_decl = substl_decl
-let subst1_named_decl = subst1_decl
-
-(* (thin_val sigma) removes identity substitutions from sigma *)
-
-let rec thin_val = function
-  | [] -> []
-  | (((id,{ sit = v }) as s)::tl) when isVar v ->
-      if id = destVar v then thin_val tl else s::(thin_val tl)
-  | h::tl -> h::(thin_val tl)
-
-(* (replace_vars sigma M) applies substitution sigma to term M *)
-let replace_vars var_alist =
-  let var_alist =
-    List.map (fun (str,c) -> (str,make_substituend c)) var_alist in
-  let var_alist = thin_val var_alist in
-  let rec substrec n c = match kind_of_term c with
-    | Var x ->
-        (try lift_substituend n (List.assoc x var_alist)
-         with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec n c
-  in
-  if var_alist = [] then (function x -> x) else substrec 0
-
-(*
-let repvarkey = Profile.declare_profile "replace_vars";;
-let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
-*)
-
-(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
-let subst_var str = replace_vars [(str, mkRel 1)]
-
-(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
-let substn_vars p vars =
-  let _,subst =
-    List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars
-  in replace_vars (List.rev subst)
-
-let subst_vars = substn_vars 1
-
 (***************************)
 (* Other term constructors *)
 (***************************)
@@ -947,7 +454,7 @@ let appvectc f l = mkApp (f,l)
 (* to_lambda n (x1:T1)...(xn:Tn)T =
  * [x1:T1]...[xn:Tn]T *)
 let rec to_lambda n prod =
-  if n = 0 then
+  if Int.equal n 0 then
     prod
   else
     match kind_of_term prod with
@@ -956,7 +463,7 @@ let rec to_lambda n prod =
       | _   -> errorlabstrm "to_lambda" (mt ())
 
 let rec to_prod n lam =
-  if n=0 then
+  if Int.equal n 0 then
     lam
   else
     match kind_of_term lam with
@@ -972,8 +479,8 @@ let prod_app t n =
   match kind_of_term (strip_outer_cast t) with
     | Prod (_,_,b) -> subst1 n b
     | _ ->
-	errorlabstrm "prod_app"
-	  (str"Needed a product, but didn't find one" ++ fnl ())
+        errorlabstrm "prod_app"
+          (str"Needed a product, but didn't find one" ++ fnl ())
 
 
 (* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
@@ -1014,7 +521,7 @@ let decompose_lam =
 let decompose_prod_n n =
   if n < 0 then error "decompose_prod_n: 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 kind_of_term c with
       | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)   -> prodec_rec l n c
@@ -1027,7 +534,7 @@ let decompose_prod_n n =
 let decompose_lam_n n =
   if n < 0 then error "decompose_lam_n: 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 kind_of_term c with
       | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
       | Cast (c,_,_)     -> lamdec_rec l n c
@@ -1065,7 +572,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 kind_of_term c with
     | Prod (x,t,c)    -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c
@@ -1082,7 +589,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 kind_of_term c with
     | Lambda (x,t,c)  -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c
     | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c
@@ -1138,7 +645,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 []
 
@@ -1152,262 +659,23 @@ let rec isArity c =
   | Sort _          -> true
   | _               -> false
 
-(*******************)
-(*  hash-consing   *)
-(*******************)
-
-(* Hash-consing of [constr] does not use the module [Hashcons] because
-   [Hashcons] is not efficient on deep tree-like data
-   structures. Indeed, [Hashcons] is based the (very efficient)
-   generic hash function [Hashtbl.hash], which computes the hash key
-   through a depth bounded traversal of the data structure to be
-   hashed. As a consequence, for a deep [constr] like the natural
-   number 1000 (S (S (... (S O)))), the same hash is assigned to all
-   the sub [constr]s greater than the maximal depth handled by
-   [Hashtbl.hash]. This entails a huge number of collisions in the
-   hash table and leads to cubic hash-consing in this worst-case.
-
-   In order to compute a hash key that is independent of the data
-   structure depth while being constant-time, an incremental hashing
-   function must be devised. A standard implementation creates a cache
-   of the hashing function by decorating each node of the hash-consed
-   data structure with its hash key. In that case, the hash function
-   can deduce the hash key of a toplevel data structure by a local
-   computation based on the cache held on its substructures.
-   Unfortunately, this simple implementation introduces a space
-   overhead that is damageable for the hash-consing of small [constr]s
-   (the most common case). One can think of an heterogeneous
-   distribution of caches on smartly chosen nodes, but this is forbidden
-   by the use of generic equality in Coq source code. (Indeed, this forces
-   each [constr] to have a unique canonical representation.)
-
-   Given that hash-consing proceeds inductively, we can nonetheless
-   computes the hash key incrementally during hash-consing by changing
-   a little the signature of the hash-consing function: it now returns
-   both the hash-consed term and its hash key. This simple solution is
-   implemented in the following code: it does not introduce a space
-   overhead in [constr], that's why the efficiency is unchanged for
-   small [constr]s. Besides, it does handle deep [constr]s without
-   introducing an unreasonable number of collisions in the hash table.
-   Some benchmarks make us think that this implementation of
-   hash-consing is linear in the size of the hash-consed data
-   structure for our daily use of Coq.
-*)
-
-let array_eqeq t1 t2 =
-  t1 == t2 ||
-  (Array.length t1 = Array.length t2 &&
-   let rec aux i =
-     (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1))
-   in aux 0)
-
-let equals_constr t1 t2 =
-  match t1, t2 with
-    | Rel n1, Rel n2 -> n1 == n2
-    | Meta m1, Meta m2 -> m1 == m2
-    | Var id1, Var id2 -> id1 == id2
-    | Sort s1, Sort s2 -> s1 == s2
-    | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2
-    | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-    | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
-    | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
-      n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
-    | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2
-    | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2
-    | Const c1, Const c2 -> c1 == c2
-    | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
-    | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
-      sp1 == sp2 & i1 = i2 & j1 = j2
-    | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
-      ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2
-    | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_eqeq lna1 lna2
-      & array_eqeq tl1 tl2
-      & array_eqeq bl1 bl2
-    | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
-      ln1 = ln2
-      & array_eqeq lna1 lna2
-      & array_eqeq tl1 tl2
-      & array_eqeq bl1 bl2
-    | _ -> false
-
-(** Note that the following Make has the side effect of creating
-    once and for all the table we'll use for hash-consing all constr *)
-
-module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end)
-
-open Hashtbl_alt.Combine
-
-(* [hcons_term hash_consing_functions constr] computes an hash-consed
-   representation for [constr] using [hash_consing_functions] on
-   leaves. *)
-let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
-
-  (* Note : we hash-cons constr arrays *in place* *)
-
-  let rec hash_term_array t =
-    let accu = ref 0 in
-    for i = 0 to Array.length t - 1 do
-      let x, h = sh_rec t.(i) in
-      accu := combine !accu h;
-      t.(i) <- x
-    done;
-    !accu
-
-  and hash_term t =
-    match t with
-      | Var i ->
-	(Var (sh_id i), combinesmall 1 (Hashtbl.hash i))
-      | Sort s ->
-	(Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s))
-      | Cast (c, k, t) ->
-	let c, hc = sh_rec c in
-	let t, ht = sh_rec t in
-	(Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht))
-      | Prod (na,t,c) ->
-	let t, ht = sh_rec t
-	and c, hc = sh_rec c in
-	(Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc))
-      | Lambda (na,t,c) ->
-	let t, ht = sh_rec t
-	and c, hc = sh_rec c in
-	(Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc))
-      | LetIn (na,b,t,c) ->
-	let b, hb = sh_rec b in
-	let t, ht = sh_rec t in
-	let c, hc = sh_rec c in
-	(LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc))
-      | App (c,l) ->
-	let c, hc = sh_rec c in
-	let hl = hash_term_array l in
-	(App (c, l), combinesmall 7 (combine hl hc))
-      | Evar (e,l) ->
-	let hl = hash_term_array l in
-	(* since the array have been hashed in place : *)
-	(t, combinesmall 8 (combine (Hashtbl.hash e) hl))
-      | Const c ->
-	(Const (sh_con c), combinesmall 9 (Hashtbl.hash c))
-      | Ind ((kn,i) as ind) ->
-	(Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i))
-      | Construct (((kn,i),j) as c)->
-	(Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j))
-      | Case (ci,p,c,bl) ->
-	let p, hp = sh_rec p
-	and c, hc = sh_rec c in
-	let hbl = hash_term_array bl in
-	let hbl = combine (combine hc hp) hbl in
-	(Case (sh_ci ci, p, c, bl), combinesmall 11 hbl)
-      | Fix (ln,(lna,tl,bl)) ->
-	let hbl = hash_term_array  bl in
-	let htl = hash_term_array  tl in
-	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
-	(* since the three arrays have been hashed in place : *)
-	(t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl)))
-      | CoFix(ln,(lna,tl,bl)) ->
-	let hbl = hash_term_array bl in
-	let htl = hash_term_array tl in
-	Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
-	(* since the three arrays have been hashed in place : *)
-	(t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl)))
-      | Meta n ->
-	(t, combinesmall 15 n)
-      | Rel n ->
-	(t, combinesmall 16 n)
-
-  and sh_rec t =
-    let (y, h) = hash_term t in
-    (* [h] must be positive. *)
-    let h = h land 0x3FFFFFFF in
-    (H.may_add_and_get h y, h)
+(** Kind of type *)
 
-  in
-  (* Make sure our statically allocated Rels (1 to 16) are considered
-     as canonical, and hence hash-consed to themselves *)
-  ignore (hash_term_array rels);
-
-  fun t -> fst (sh_rec t)
-
-(* Exported hashing fonction on constr, used mainly in plugins.
-   Appears to have slight differences from [snd (hash_term t)] above ? *)
-
-let rec hash_constr t =
-  match kind_of_term t with
-    | Var i -> combinesmall 1 (Hashtbl.hash i)
-    | Sort s -> combinesmall 2 (Hashtbl.hash s)
-    | Cast (c, _, _) -> hash_constr c
-    | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c))
-    | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c))
-    | LetIn (_, b, t, c) ->
-      combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c))
-    | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l))
-    | App (c,l) ->
-      combinesmall 7 (combine (hash_term_array l) (hash_constr c))
-    | Evar (e,l) ->
-      combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l))
-    | Const c ->
-      combinesmall 9 (Hashtbl.hash c)	(* TODO: proper hash function for constants *)
-    | Ind (kn,i) ->
-      combinesmall 9 (combine (Hashtbl.hash kn) i)
-    | Construct ((kn,i),j) ->
-      combinesmall 10 (combine3 (Hashtbl.hash kn) i j)
-    | Case (_ , p, c, bl) ->
-      combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl))
-    | Fix (ln ,(_, tl, bl)) ->
-      combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
-    | CoFix(ln, (_, tl, bl)) ->
-       combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
-    | Meta n -> combinesmall 15 n
-    | Rel n -> combinesmall 16 n
-
-and hash_term_array t =
-  Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t
-
-module Hsorts =
-  Hashcons.Make(
-    struct
-      type t = sorts
-      type u = universe -> universe
-      let hash_sub huniv = function
-          Prop c -> Prop c
-        | Type u -> Type (huniv u)
-      let equal s1 s2 =
-        match (s1,s2) with
-            (Prop c1, Prop c2) -> c1=c2
-          | (Type u1, Type u2) -> u1 == u2
-          |_ -> false
-      let hash = Hashtbl.hash
-    end)
-
-module Hcaseinfo =
-  Hashcons.Make(
-    struct
-      type t = case_info
-      type u = inductive -> inductive
-      let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind }
-      let equal ci ci' =
-	ci.ci_ind == ci'.ci_ind &&
-	ci.ci_npar = ci'.ci_npar &&
-	ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *)
-	ci.ci_pp_info = ci'.ci_pp_info  (* we use (=) on purpose *)
-      let hash = Hashtbl.hash
-    end)
-
-let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ
-let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind
-
-let hcons_constr =
-  hcons_term
-    (hcons_sorts,
-     hcons_caseinfo,
-     hcons_construct,
-     hcons_ind,
-     hcons_con,
-     hcons_name,
-     hcons_ident)
-
-let hcons_types = hcons_constr
-
-(*******)
-(* Type of abstract machine values *)
-type values
+(* Experimental, used in Presburger contrib *)
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of Name.t * 'types * 'types
+  | LetInType  of Name.t * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+let kind_of_type t = match kind_of_term t with
+  | Sort s -> SortType s
+  | Cast (c,_,t) -> CastType (c, t)
+  | Prod (na,t,c) -> ProdType (na, t, c)
+  | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+  | App (c,l) -> AtomicType (c, l)
+  | (Rel _ | Meta _ | Var _ | Evar _ | Const _ 
+  | Proj _ | Case _ | Fix _ | CoFix _ | Ind _)
+    -> AtomicType (t,[||])
+  | (Lambda _ | Construct _) -> failwith "Not a type"
diff --git a/kernel/term.mli b/kernel/term.mli
index 33d3daaf..501aaf74 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -1,237 +1,101 @@
 (************************************************************************)
 (*  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 Context
 
+(** {5 Redeclaration of types from module Constr and Sorts}
 
-(** {6 The sorts of CCI. } *)
+    This reexports constructors of inductive types defined in module [Constr],
+    for compatibility purposes. Refer to this module for further info.
 
-type contents = Pos | Null
+*)
+
+type contents = Sorts.contents = Pos | Null
 
-type sorts =
+type sorts = Sorts.t =
   | Prop of contents       (** Prop and Set *)
   | Type of Univ.universe  (** Type *)
 
-val set_sort  : sorts
-val prop_sort : sorts
-val type1_sort  : sorts
+type sorts_family = Sorts.family = InProp | InSet | InType
 
-(** {6 The sorts family of CCI. } *)
+type 'a puniverses = 'a Univ.puniverses
 
-type sorts_family = InProp | InSet | InType
+(** Simply type aliases *)
+type pconstant = constant puniverses
+type pinductive = inductive puniverses
+type pconstructor = constructor puniverses
 
-val family_of_sort : sorts -> sorts_family
+type constr = Constr.constr
+(** Alias types, for compatibility. *)
+
+type types = Constr.types
+(** Same as [constr], for documentation purposes. *)
 
-(** {6 Useful types } *)
+type existential_key = Constr.existential_key
 
-(** {6 Existential variables } *)
-type existential_key = int
+type existential = Constr.existential
 
-(** {6 Existential variables } *)
-type metavariable = int
+type metavariable = Constr.metavariable
 
-(** {6 Case annotation } *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle 
-  | RegularStyle (** infer printing form from number of constructor *)
-type case_printing =
-  { ind_nargs : int; (** length of the arity of the inductive type *)
-    style     : case_style }
+type case_style = Constr.case_style =
+  LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
 
-(** the integer is the number of real args, needed for reduction *)
-type case_info =
+type case_printing = Constr.case_printing =
+  { ind_tags : bool list; cstr_tags : bool list array; style : case_style }
+
+type case_info = Constr.case_info =
   { ci_ind        : inductive;
     ci_npar       : int;
-    ci_cstr_ndecls : int array; (** number of real args of each constructor *)
-    ci_pp_info    : case_printing (** not interpreted by the kernel *)
+    ci_cstr_ndecls : int array;
+    ci_cstr_nargs : int array;
+    ci_pp_info    : case_printing
   }
 
-(** {6 The type of constructions } *)
-
-type constr
-
-(** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
-   and application grouping *)
-val eq_constr : constr -> constr -> bool
-
-(** [types] is the same as [constr] but is intended to be used for
-   documentation to indicate that such or such function specifically works
-   with {e types} (i.e. terms of type a sort).
-   (Rem:plurial form since [type] is a reserved ML keyword) *)
-
-type types = constr
-
-(** {5 Functions for dealing with constr terms. }
-  The following functions are intended to simplify and to uniform the
-  manipulation of terms. Some of these functions may be overlapped with
-  previous ones. *)
-
-(** {6 Term constructors. } *)
-
-(** Constructs a DeBrujin index (DB indices begin at 1) *)
-val mkRel : int -> constr
-
-(** Constructs a Variable *)
-val mkVar : identifier -> constr
-
-(** Constructs an patvar named "?n" *)
-val mkMeta : metavariable -> constr
-
-(** Constructs an existential variable *)
-type existential = existential_key * constr array
-val mkEvar : existential -> constr
-
-(** Construct a sort *)
-val mkSort : sorts -> types
-val mkProp : types
-val mkSet  : types
-val mkType : Univ.universe -> types
-
-
-(** This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast | REVERTcast
-
-(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
-   type t{_ 2} (that means t2 is declared as the type of t1). *)
-val mkCast : constr * cast_kind * constr -> constr
-
-(** Constructs the product [(x:t1)t2] *)
-val mkProd : name * types * types -> types
-val mkNamedProd : identifier -> types -> types -> types
+type cast_kind = Constr.cast_kind =
+  VMcast | NATIVEcast | DEFAULTcast | REVERTcast
 
-(** non-dependent product [t1 -> t2], an alias for
-   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
-   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
-*)
-val mkArrow : types -> types -> constr
-
-(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
-val mkLambda : name * types * constr -> constr
-val mkNamedLambda : identifier -> types -> constr -> constr
-
-(** Constructs the product [let x = t1 : t2 in t3] *)
-val mkLetIn : name * constr * types * constr -> constr
-val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
-
-(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
-   {% $(f~t_1~\dots~t_n)$ %}. *)
-val mkApp : constr * constr array -> constr
-
-(** Constructs a constant 
-   The array of terms correspond to the variables introduced in the section *)
-val mkConst : constant -> constr
-
-(** Inductive types *)
-
-(** Constructs the ith (co)inductive type of the block named kn 
-   The array of terms correspond to the variables introduced in the section *)
-val mkInd : inductive -> constr
-
-(** Constructs the jth constructor of the ith (co)inductive type of the
-   block named kn. The array of terms correspond to the variables
-   introduced in the section *)
-val mkConstruct : constructor -> constr
-
-(** Constructs a destructor of inductive type.
-    
-    [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac] 
-    presented as describe in [ci].
-
-    [p] stucture is [fun args x -> "return clause"]
-
-    [ac]{^ ith} element is ith constructor case presented as 
-    {e lambda construct_args (without params). case_term } *)
-val mkCase : case_info * constr * constr * constr array -> constr
-
-(** If [recindxs = [|i1,...in|]]
-      [funnames = [|f1,.....fn|]]
-      [typarray = [|t1,...tn|]]
-      [bodies   = [|b1,.....bn|]]
-   then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
-   constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
-
-    [Fixpoint f1 [ctx1] = b1
-     with     f2 [ctx2] = b2
-     ...
-     with     fn [ctxn] = bn.]
-
-   where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
-*)
-type rec_declaration = name array * types array * constr array
-type fixpoint = (int array * int) * rec_declaration
-val mkFix : fixpoint -> constr
-
-(** If [funnames = [|f1,.....fn|]]
-      [typarray = [|t1,...tn|]]
-      [bodies   = [b1,.....bn]] 
-   then [mkCoFix (i, (funnames, typarray, bodies))]
-   constructs the ith function of the block
-   
-    [CoFixpoint f1 = b1
-     with       f2 = b2
-     ...
-     with       fn = bn.]
- *)
-type cofixpoint = int * rec_declaration
-val mkCoFix : cofixpoint -> constr
-
-
-(** {6 Concrete type for making pattern-matching. } *)
-
-(** [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 rec_declaration = Constr.rec_declaration
+type fixpoint = Constr.fixpoint
+type cofixpoint = Constr.cofixpoint
+type 'constr pexistential = 'constr Constr.pexistential
 type ('constr, 'types) prec_declaration =
-    name array * 'types array * 'constr array
-type ('constr, 'types) pfixpoint =
-    (int array * int) * ('constr, 'types) prec_declaration
-type ('constr, 'types) pcofixpoint =
-    int * ('constr, 'types) prec_declaration
+  ('constr, 'types) Constr.prec_declaration
+type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint
+type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint
 
-type ('constr, 'types) kind_of_term =
+type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term =
   | Rel       of int
-  | Var       of identifier
+  | Var       of Id.t
   | Meta      of metavariable
   | Evar      of 'constr pexistential
   | Sort      of sorts
   | Cast      of 'constr * cast_kind * 'types
-  | Prod      of name * 'types * 'types
-  | Lambda    of name * 'types * 'constr
-  | LetIn     of name * 'constr * 'types * 'constr
+  | Prod      of Name.t * 'types * 'types
+  | Lambda    of Name.t * 'types * 'constr
+  | LetIn     of Name.t * 'constr * 'types * 'constr
   | App       of 'constr * 'constr array
-  | Const     of constant
-  | Ind       of inductive
-  | Construct of constructor
+  | Const     of constant puniverses
+  | Ind       of inductive puniverses
+  | Construct of constructor puniverses
   | Case      of case_info * 'constr * 'constr * 'constr array
   | Fix       of ('constr, 'types) pfixpoint
   | CoFix     of ('constr, 'types) pcofixpoint
+  | Proj      of projection * 'constr
 
-(** User view of [constr]. For [App], it is ensured there is at
-   least one argument and the function is not itself an applicative
-   term *)
+type values = Constr.values
 
-val kind_of_term : constr -> (constr, types) kind_of_term
-
-(** Experimental, used in Presburger contrib *)
-type ('constr, 'types) kind_of_type =
-  | SortType   of sorts
-  | CastType   of 'types * 'types
-  | ProdType   of name * 'types * 'types
-  | LetInType  of name * 'constr * 'types * 'types
-  | AtomicType of 'constr * 'constr array
-
-val kind_of_type : types -> (constr, types) kind_of_type
-
-(** {6 Simple term case analysis. } *)
+(** {5 Simple term case analysis. } *)
 
 val isRel  : constr -> bool
 val isRelN : int -> constr -> bool
 val isVar  : constr -> bool
-val isVarId : identifier -> constr -> bool
+val isVarId : Id.t -> constr -> bool
 val isInd  : constr -> bool
 val isEvar : constr -> bool
 val isMeta : constr -> bool
@@ -248,6 +112,7 @@ val isConstruct : constr -> bool
 val isFix : constr -> bool
 val isCoFix : constr -> bool
 val isCase : constr -> bool
+val isProj : constr -> bool
 
 val is_Prop : constr -> bool
 val is_Set  : constr -> bool
@@ -257,9 +122,11 @@ val iskind : constr -> bool
 val is_small : sorts -> bool
 
 
-(** {6 Term destructors } *)
+(** {5 Term destructors } *)
 (** Destructor operations are partial functions and
-    @raise Invalid_argument "dest*" if the term has not the expected form. *)
+    @raise DestKO if the term has not the expected form. *)
+
+exception DestKO
 
 (** Destructs a DeBrujin index *)
 val destRel : constr -> int
@@ -268,7 +135,7 @@ val destRel : constr -> int
 val destMeta : constr -> metavariable
 
 (** Destructs a variable *)
-val destVar : constr -> identifier
+val destVar : constr -> Id.t
 
 (** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether
    [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *)
@@ -278,13 +145,13 @@ val destSort : constr -> sorts
 val destCast : constr -> constr * cast_kind * constr
 
 (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
-val destProd : types -> name * types * types
+val destProd : types -> Name.t * types * types
 
 (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
-val destLambda : constr -> name * types * constr
+val destLambda : constr -> Name.t * types * constr
 
 (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
-val destLetIn : constr -> name * constr * types * constr
+val destLetIn : constr -> Name.t * constr * types * constr
 
 (** Destructs an application *)
 val destApp : constr -> constr * constr array
@@ -295,17 +162,20 @@ val destApplication : constr -> constr * constr array
 (** Decompose any term as an applicative term; the list of args can be empty *)
 val decompose_app : constr -> constr * constr list
 
+(** Same as [decompose_app], but returns an array. *)
+val decompose_appvect : constr -> constr * constr array
+
 (** Destructs a constant *)
-val destConst : constr -> constant
+val destConst : constr -> constant puniverses
 
 (** Destructs an existential variable *)
 val destEvar : constr -> existential
 
 (** Destructs a (co)inductive type *)
-val destInd : constr -> inductive
+val destInd : constr -> inductive puniverses
 
 (** Destructs a constructor *)
-val destConstruct : constr -> constructor
+val destConstruct : constr -> constructor puniverses
 
 (** Destructs a [match c as x in I args return P with ... |
 Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
@@ -314,6 +184,9 @@ return P in t1], or [if c then t1 else t2])
 where [info] is pretty-printing information *)
 val destCase : constr -> case_info * constr * constr * constr array
 
+(** Destructs a projection *)
+val destProj : constr -> projection * constr
+
 (** Destructs the {% $ %}i{% $ %}th function of the block
    [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
     with    f{_ 2} ctx{_ 2} = b{_ 2}
@@ -326,54 +199,18 @@ val destFix : constr -> fixpoint
 val destCoFix : constr -> cofixpoint
 
 
-(** {6 Local } *)
-(** A {e declaration} has the form [(name,body,type)]. It is either an
-    {e assumption} if [body=None] or a {e definition} if
-    [body=Some actualbody]. It is referred by {e name} if [na] is an
-    identifier or by {e relative index} if [na] is not an identifier
-    (in the latter case, [na] is of type [name] but just for printing
-    purpose) *)
-
-type named_declaration = identifier * constr option * types
-type rel_declaration = name * constr option * types
-
-val map_named_declaration :
-  (constr -> constr) -> named_declaration -> named_declaration
-val map_rel_declaration :
-  (constr -> constr) -> rel_declaration -> rel_declaration
-
-val fold_named_declaration :
-  (constr -> 'a -> 'a) -> named_declaration -> 'a -> 'a
-val fold_rel_declaration :
-  (constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
-
-val exists_named_declaration :
-  (constr -> bool) -> named_declaration -> bool
-val exists_rel_declaration :
-  (constr -> bool) -> rel_declaration -> bool
-
-val for_all_named_declaration :
-  (constr -> bool) -> named_declaration -> bool
-val for_all_rel_declaration :
-  (constr -> bool) -> rel_declaration -> bool
+(** {5 Derived constructors} *)
 
-val eq_named_declaration :
-  named_declaration -> named_declaration -> bool
-
-val eq_rel_declaration :
-    rel_declaration -> rel_declaration -> bool
-
-(** {6 Contexts of declarations referred to by de Bruijn indices } *)
-
-(** In [rel_context], more recent declaration is on top *)
-type rel_context = rel_declaration list
-
-val empty_rel_context : rel_context
-val add_rel_decl : rel_declaration -> rel_context -> rel_context
+(** non-dependent product [t1 -> t2], an alias for
+   [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
+   Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
+*)
+val mkArrow : types -> types -> constr
 
-val lookup_rel : int -> rel_context -> rel_declaration
-val rel_context_length : rel_context -> int
-val rel_context_nhyps : rel_context -> int
+(** Named version of the functions from [Term]. *)
+val mkNamedLambda : Id.t -> types -> constr -> constr
+val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr
+val mkNamedProd : Id.t -> types -> types -> types
 
 (** Constructs either [(x:t)c] or [[x=b:t]c] *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
@@ -385,7 +222,7 @@ val mkNamedProd_wo_LetIn : named_declaration -> types -> types
 val mkLambda_or_LetIn : rel_declaration -> constr -> constr
 val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
 
-(** {6 Other term constructors. } *)
+(** {5 Other term constructors. } *)
 
 (** [applist (f,args)] and its variants work as [mkApp] *)
 
@@ -396,24 +233,24 @@ val appvectc : constr -> constr array -> constr
 
 (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b]
    where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
-val prodn : int -> (name * constr) list -> constr -> constr
+val prodn : int -> (Name.t * constr) list -> constr -> constr
 
 (** [compose_prod l b]
    @return [forall (x_1:T_1)...(x_n:T_n), b]
    where [l] is [(x_n,T_n)...(x_1,T_1)].
    Inverse of [decompose_prod]. *)
-val compose_prod : (name * constr) list -> constr -> constr
+val compose_prod : (Name.t * constr) list -> constr -> constr
 
 (** [lamn n l b]
     @return [fun (x_1:T_1)...(x_n:T_n) => b]
    where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
-val lamn : int -> (name * constr) list -> constr -> constr
+val lamn : int -> (Name.t * constr) list -> constr -> constr
 
 (** [compose_lam l b]
    @return [fun (x_1:T_1)...(x_n:T_n) => b]
    where [l] is [(x_n,T_n)...(x_1,T_1)].
    Inverse of [it_destLam] *)
-val compose_lam : (name * constr) list -> constr -> constr
+val compose_lam : (Name.t * constr) list -> constr -> constr
 
 (** [to_lambda n l]
    @return [fun (x_1:T_1)...(x_n:T_n) => T]
@@ -434,24 +271,24 @@ val prod_applist : constr -> constr list -> constr
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
 val it_mkProd_or_LetIn : types -> rel_context -> types
 
-(** {6 Other term destructors. } *)
+(** {5 Other term destructors. } *)
 
 (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair
    {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *)
-val decompose_prod : constr -> (name*constr) list * constr
+val decompose_prod : constr -> (Name.t*constr) list * constr
 
 (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair
    {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *)
-val decompose_lam : constr -> (name*constr) list * constr
+val decompose_lam : constr -> (Name.t*constr) list * constr
 
 (** Given a positive integer n, transforms a product term
    {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %}
    into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *)
-val decompose_prod_n : int -> constr -> (name * constr) list * constr
+val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr
 
 (** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term
    {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *)
-val decompose_lam_n : int -> constr -> (name * constr) list * constr
+val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr
 
 (** Extract the premisses and the conclusion of a term of the form
    "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *)
@@ -505,7 +342,7 @@ val under_casts : (constr -> constr) -> constr -> constr
 (** Apply a function under components of Cast if any *)
 val under_outer_cast : (constr -> constr) -> constr -> constr
 
-(** {6 ... } *)
+(** {5 ... } *)
 (** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
     Such a term can canonically be seen as the pair of a context of types
     and of a sort *)
@@ -521,117 +358,125 @@ val destArity : types -> arity
 (** Tells if a term has the form of an arity *)
 val isArity : types -> bool
 
-(** {6 Occur checks } *)
+(** {5 Kind of type} *)
+
+type ('constr, 'types) kind_of_type =
+  | SortType   of sorts
+  | CastType   of 'types * 'types
+  | ProdType   of Name.t * 'types * 'types
+  | LetInType  of Name.t * 'constr * 'types * 'types
+  | AtomicType of 'constr * 'constr array
+
+val kind_of_type : types -> (constr, types) kind_of_type
 
-(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
-val closedn : int -> constr -> bool
+(** {5 Redeclaration of stuff from module [Sorts]} *)
 
-(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
-val closed0 : constr -> bool
+val set_sort  : sorts
+(** Alias for Sorts.set *)
 
-(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
-val noccurn : int -> constr -> bool
+val prop_sort : sorts
+(** Alias for Sorts.prop *)
 
-(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
-  for n <= p < n+m *)
-val noccur_between : int -> int -> constr -> bool
+val type1_sort  : sorts
+(** Alias for Sorts.type1 *)
 
-(** Checking function for terms containing existential- or
-   meta-variables.  The function [noccur_with_meta] does not consider
-   meta-variables applied to some terms (intended to be its local
-   context) (for existential variables, it is necessarily the case) *)
-val noccur_with_meta : int -> int -> constr -> bool
+val sorts_ord : sorts -> sorts -> int
+(** Alias for Sorts.compare *)
 
-(** {6 Relocation and substitution } *)
+val is_prop_sort : sorts -> bool
+(** Alias for Sorts.is_prop *)
 
-(** [exliftn el c] lifts [c] with lifting [el] *)
-val exliftn : Esubst.lift -> constr -> constr
+val family_of_sort : sorts -> sorts_family
+(** Alias for Sorts.family *)
 
-(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
-val liftn : int -> int -> constr -> constr
+(** {5 Redeclaration of stuff from module [Constr]}
 
-(** [lift n c] lifts by [n] the positive indexes in [c] *)
-val lift : int -> constr -> constr
+    See module [Constr] for further info. *)
 
-(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
-    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
-    accordingly indexes in [a1],...,[an] *)
-val substnl : constr list -> int -> constr -> constr
-val substl : constr list -> constr -> constr
-val subst1 : constr -> constr -> constr
+(** {6 Term constructors. } *)
 
-val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration
-val substl_decl : constr list -> rel_declaration -> rel_declaration
-val subst1_decl : constr -> rel_declaration -> rel_declaration
+val mkRel : int -> constr
+val mkVar : Id.t -> constr
+val mkMeta : metavariable -> constr
+val mkEvar : existential -> constr
+val mkSort : sorts -> types
+val mkProp : types
+val mkSet  : types
+val mkType : Univ.universe -> types
+val mkCast : constr * cast_kind * constr -> constr
+val mkProd : Name.t * types * types -> types
+val mkLambda : Name.t * types * constr -> constr
+val mkLetIn : Name.t * constr * types * constr -> constr
+val mkApp : constr * constr array -> constr
+val mkConst : constant -> constr
+val mkProj : projection * constr -> constr
+val mkInd : inductive -> constr
+val mkConstruct : constructor -> constr
+val mkConstU : constant puniverses -> constr
+val mkIndU : inductive puniverses -> constr
+val mkConstructU : constructor puniverses -> constr
+val mkConstructUi : (pinductive * int) -> constr
+val mkCase : case_info * constr * constr * constr array -> constr
+val mkFix : fixpoint -> constr
+val mkCoFix : cofixpoint -> constr
 
-val subst1_named_decl : constr -> named_declaration -> named_declaration
-val substl_named_decl : constr list -> named_declaration -> named_declaration
+(** {6 Aliases} *)
 
-val replace_vars : (identifier * constr) list -> constr -> constr
-val subst_var : identifier -> constr -> constr
+val eq_constr : constr -> constr -> bool
+(** Alias for [Constr.equal] *)
 
-(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
-   if two names are identical, the one of least indice is kept *)
-val subst_vars : identifier list -> constr -> constr
+(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts,
+   application grouping and the universe constraints in [u]. *)
+val eq_constr_univs : constr Univ.check_function
 
-(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
-   if two names are identical, the one of least indice is kept *)
-val substn_vars : int -> identifier list -> constr -> constr
+(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo 
+    alpha, casts, application grouping and the universe constraints in [u]. *)
+val leq_constr_univs : constr Univ.check_function
 
+(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping and ignoring universe instances. *)
+val eq_constr_nounivs : constr -> constr -> bool
 
-(** {6 Functionals working on the immediate subterm of a construction } *)
+val kind_of_term : constr -> (constr, types) kind_of_term
+(** Alias for [Constr.kind] *)
 
-(** [fold_constr f acc c] folds [f] on the immediate subterms of [c]
-   starting from [acc] and proceeding from left to right according to
-   the usual representation of the constructions; it is not recursive *)
+val constr_ord : constr -> constr -> int
+(** Alias for [Constr.compare] *)
 
 val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
-
-(** [map_constr f c] maps [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
+(** Alias for [Constr.fold] *)
 
 val map_constr : (constr -> constr) -> constr -> constr
-
-(** [map_constr_with_binders g f n c] maps [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
+(** Alias for [Constr.map] *)
 
 val map_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
+(** Alias for [Constr.map_with_binders] *)
 
-(** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
-   not recursive and the order with which subterms are processed is
-   not specified *)
+val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses
+val univ_of_sort : sorts -> Univ.universe
+val sort_of_univ : Univ.universe -> sorts
 
 val iter_constr : (constr -> unit) -> constr -> unit
-
-(** [iter_constr_with_binders g f n c] iters [f n] on the immediate
-   subterms of [c]; it carries an extra data [n] (typically a lift
-   index) which is processed by [g] (which typically add 1 to [n]) at
-   each binder traversal; it is not recursive and the order with which
-   subterms are processed is not specified *)
+(** Alias for [Constr.iter] *)
 
 val iter_constr_with_binders :
   ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
-
-(** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
-   the immediate subterms of [c1] of [c2] if needed; Cast's, binders
-   name and Cases annotations are not taken into account *)
+(** Alias for [Constr.iter_with_binders] *)
 
 val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
+(** Alias for [Constr.compare_head] *)
 
-val constr_ord : constr -> constr -> int
 val hash_constr : constr -> int
+(** Alias for [Constr.hash] *)
 
 (*********************************************************************)
 
 val hcons_sorts : sorts -> sorts
-val hcons_constr : constr -> constr
-val hcons_types : types -> types
+(** Alias for [Constr.hashcons_sorts] *)
 
-(**************************************)
+val hcons_constr : constr -> constr
+(** Alias for [Constr.hashcons] *)
 
-type values
+val hcons_types : types -> types
+(** Alias for [Constr.hashcons] *)
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 8932ce5e..a3441aa3 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.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        *)
@@ -12,147 +12,286 @@
 (* This module provides the main entry points for type-checking basic
    declarations *)
 
+open Errors
 open Util
 open Names
 open Univ
 open Term
-open Reduction
-open Sign
+open Context
 open Declarations
-open Inductive
 open Environ
 open Entries
-open Type_errors
-open Indtypes
 open Typeops
+open Fast_typeops
 
-let constrain_type env j cst1 = function
-  | None ->
-      make_polymorphic_if_constant_for_ind env j, cst1
-  | Some t ->
-      let (tj,cst2) = infer_type env t in
-      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
+let constrain_type env j poly subst = function
+  | `None -> 
+    if not poly then (* Old-style polymorphism *)
+      make_polymorphic_if_constant_for_ind env j
+    else RegularArity (Vars.subst_univs_level_constr subst j.uj_type)
+  | `Some t ->
+      let tj = infer_type env t in
+      let _ = judge_of_cast env j DEFAULTcast tj in
 	assert (eq_constr t tj.utj_val);
-	let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in
-	  NonPolymorphicType t, cstrs
-
-let local_constrain_type env j cst1 = function
-  | None ->
-      j.uj_type, cst1
-  | Some t ->
-      let (tj,cst2) = infer_type env t in
-      let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
-      assert (eq_constr t tj.utj_val);
-      t, union_constraints (union_constraints cst1 cst2) cst3
-
-let translate_local_def env (b,topt) =
-  let (j,cst) = infer env b in
-  let (typ,cst) = local_constrain_type env j cst topt in
-    (j.uj_val,typ,cst)
+	RegularArity (Vars.subst_univs_level_constr subst t)
+  | `SomeWJ (t, tj) ->
+      let tj = infer_type env t in
+      let _ = judge_of_cast env j DEFAULTcast tj in
+	assert (eq_constr t tj.utj_val);
+	RegularArity (Vars.subst_univs_level_constr subst t)
 
-let translate_local_assum env t =
-  let (j,cst) = infer env t in
-  let t = Typeops.assumption_of_judgment env j in
-    (t,cst)
-
-(*
-
-(* Same as push_named, but check that the variable is not already
-   there. Should *not* be done in Environ because tactics add temporary
-   hypothesis many many times, and the check performed here would
-   cost too much. *)
-let safe_push_named (id,_,_ as d) env =
-  let _ =
-    try
-      let _ = lookup_named id env in
-      error ("Identifier "^string_of_id id^" already defined.")
-    with Not_found -> () in
-  push_named d env
-
-let push_named_def = push_rel_or_named_def safe_push_named
-let push_rel_def = push_rel_or_named_def push_rel
-
-let push_rel_or_named_assum push (id,t) env =
-  let (j,cst) = safe_infer env t in
-  let t = Typeops.assumption_of_judgment env j in
-  let env' = add_constraints cst env in
-  let env'' = push (id,None,t) env' in
-  (cst,env'')
+let map_option_typ = function None -> `None | Some x -> `Some x
+
+(* Insertion of constants and parameters in environment. *)
 
-let push_named_assum = push_rel_or_named_assum push_named
-let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env)
+let mk_pure_proof c = (c, Univ.ContextSet.empty), Declareops.no_seff
 
-let push_rels_with_univ vars env =
-  List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars
-*)
+let handle_side_effects env body side_eff =
+  let handle_sideff t se =
+    let cbl = match se with
+      | SEsubproof (c,cb,b) -> [c,cb,b]
+      | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl in
+    let not_exists (c,_,_) =
+      try ignore(Environ.lookup_constant c env); false
+      with Not_found -> true in 
+    let cbl = List.filter not_exists cbl in
+    let cname c = 
+      let name = string_of_con c in
+      for i = 0 to String.length name - 1 do
+        if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done;
+      Name (id_of_string name) in
+    let rec sub c i x = match kind_of_term x with
+      | Const (c', _) when eq_constant c c' -> mkRel i
+      | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in
+    let rec sub_body c u b i x = match kind_of_term x with
+      | Const (c',u') when eq_constant c c' -> 
+	Vars.subst_instance_constr u' b
+      | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub_body c u b i x) i x in
+    let fix_body (c,cb,b) t =
+      match cb.const_body, b with
+      | Def b, _ ->
+          let b = Mod_subst.force_constr b in
+	  let poly = cb.const_polymorphic in
+	    if not poly then
+              let b_ty = Typeops.type_of_constant_type env cb.const_type in
+              let t = sub c 1 (Vars.lift 1 t) in
+		mkLetIn (cname c, b, b_ty, t)
+	    else 
+	      let univs = cb.const_universes in
+		sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t)
+      | OpaqueDef _, `Opaque (b,_) -> 
+	  let poly = cb.const_polymorphic in
+	    if not poly then
+              let b_ty = Typeops.type_of_constant_type env cb.const_type in
+              let t = sub c 1 (Vars.lift 1 t) in
+		mkApp (mkLambda (cname c, b_ty, t), [|b|]) 
+	    else
+	      let univs = cb.const_universes in
+		sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t)
+      | _ -> assert false
+    in
+      List.fold_right fix_body cbl t
+  in
+  (* CAVEAT: we assure a proper order *)
+  Declareops.fold_side_effects handle_sideff body
+    (Declareops.uniquize_side_effects side_eff)
 
+let hcons_j j =
+  { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} 
 
-(* Insertion of constants and parameters in environment. *)
+let feedback_completion_typecheck =
+  Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete)
+  
+let subst_instance_j s j =
+  { uj_val = Vars.subst_univs_level_constr s j.uj_val;
+    uj_type = Vars.subst_univs_level_constr s j.uj_type }
 
-let infer_declaration env dcl =
+let infer_declaration env kn dcl =
   match dcl with
+  | ParameterEntry (ctx,poly,(t,uctx),nl) ->
+      let env = push_context uctx env in
+      let j = infer env t in
+      let abstract = poly && not (Option.is_empty kn) in
+      let usubst, univs = Univ.abstract_universes abstract uctx in
+      let c = Typeops.assumption_of_judgment env j in
+      let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in
+	Undef nl, RegularArity t, None, poly, univs, false, ctx
+
+  | DefinitionEntry ({ const_entry_type = Some typ;
+                       const_entry_opaque = true;
+		       const_entry_polymorphic = false} as c) ->
+      let env = push_context c.const_entry_universes env in
+      let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
+      let tyj = infer_type env typ in
+      let proofterm =
+        Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) ->
+          let body = handle_side_effects env body side_eff in
+	  let env' = push_context_set ctx env in
+          let j = infer env' body in
+          let j = hcons_j j in
+	  let subst = Univ.LMap.empty in
+          let _typ = constrain_type env' j c.const_entry_polymorphic subst
+	    (`SomeWJ (typ,tyj)) in
+          feedback_completion_typecheck feedback_id;
+          j.uj_val, ctx) in
+      let def = OpaqueDef (Opaqueproof.create proofterm) in
+      def, RegularArity typ, None, c.const_entry_polymorphic, 
+	c.const_entry_universes,
+	c.const_entry_inline_code, c.const_entry_secctx
+
   | DefinitionEntry c ->
-      let (j,cst) = infer env c.const_entry_body in
-      let j =
-        {uj_val = hcons_constr j.uj_val;
-         uj_type = hcons_constr j.uj_type} in
-      let (typ,cst) = constrain_type env j cst c.const_entry_type in
-      let def =
-	if c.const_entry_opaque
-	then OpaqueDef (Declarations.opaque_from_val j.uj_val)
-	else Def (Declarations.from_val j.uj_val)
+      let env = push_context c.const_entry_universes env in
+      let { const_entry_type = typ; const_entry_opaque = opaque } = c in
+      let { const_entry_body = body; const_entry_feedback = feedback_id } = c in
+      let (body, ctx), side_eff = Future.join body in
+      assert(Univ.ContextSet.is_empty ctx);
+      let body = handle_side_effects env body side_eff in
+      let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in
+      let usubst, univs = Univ.abstract_universes abstract c.const_entry_universes in
+      let j = infer env body in
+      let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in
+      let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in
+      let def = 
+	if opaque then OpaqueDef (Opaqueproof.create (Future.from_val (def, Univ.ContextSet.empty)))
+	else Def (Mod_subst.from_val def) 
       in
-      def, typ, cst, c.const_entry_secctx
-  | ParameterEntry (ctx,t,nl) ->
-      let (j,cst) = infer env t in
-      let t = hcons_constr (Typeops.assumption_of_judgment env j) in
-      Undef nl, NonPolymorphicType t, cst, ctx
+	feedback_completion_typecheck feedback_id;
+	def, typ, None, c.const_entry_polymorphic,
+        univs, c.const_entry_inline_code, c.const_entry_secctx
+
+  | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} ->
+    let mib, _ = Inductive.lookup_mind_specif env (ind,0) in
+    let kn, pb = 
+      match mib.mind_record with
+      | Some (Some (id, kns, pbs)) -> 
+	if i < Array.length pbs then
+	  kns.(i), pbs.(i)
+	else assert false
+      | _ -> assert false
+    in
+    let term, typ = pb.proj_eta in
+      Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb,
+      mib.mind_polymorphic, mib.mind_universes, false, None
 
 let global_vars_set_constant_type env = function
-  | NonPolymorphicType t -> global_vars_set env t
-  | PolymorphicArity (ctx,_) ->
-      Sign.fold_rel_context
+  | RegularArity t -> global_vars_set env t
+  | TemplateArity (ctx,_) ->
+      Context.fold_rel_context
         (fold_rel_declaration
-	  (fun t c -> Idset.union (global_vars_set env t) c))
-      ctx ~init:Idset.empty
-
-let build_constant_declaration env kn (def,typ,cst,ctx) =
-  let hyps = 
-    let inferred =
-      let ids_typ = global_vars_set_constant_type env typ in
-      let ids_def = match def with
-      | Undef _ -> Idset.empty
-      | Def cs -> global_vars_set env (Declarations.force cs)
-      | OpaqueDef lc -> 
-          global_vars_set env (Declarations.force_opaque lc) in
-      keep_hyps env (Idset.union ids_typ ids_def) in
-    let declared = match ctx with
-      | None -> inferred 
-      | Some declared -> declared in
-    let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in
+	  (fun t c -> Id.Set.union (global_vars_set env t) c))
+      ctx ~init:Id.Set.empty
+
+let record_aux env s1 s2 =
+  let v =
+    String.concat " "
+      (List.map (fun (id, _,_) -> Id.to_string id)
+        (keep_hyps env (Id.Set.union s1 s2))) in
+  Aux_file.record_in_aux "context_used" v
+
+let suggest_proof_using = ref (fun _ _ _ _ _ -> ())
+let set_suggest_proof_using f = suggest_proof_using := f
+
+let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) =
+  let check declared inferred =
+    let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in
     let inferred_set, declared_set = mk_set inferred, mk_set declared in
-    if not (Idset.subset inferred_set declared_set) then
-      error ("The following section variable are used but not declared:\n"^
-        (String.concat ", " (List.map string_of_id
-          (Idset.elements (Idset.diff inferred_set declared_set)))));
-    declared in
-  let tps = Cemitcodes.from_val (compile_constant_body env def) in
+    if not (Id.Set.subset inferred_set declared_set) then
+      let l = Id.Set.elements (Idset.diff inferred_set declared_set) in
+      let n = List.length l in
+      errorlabstrm "" (Pp.(str "The following section " ++
+        str (String.plural n "variable") ++
+        str " " ++ str (String.conjugate_verb_to_be n) ++
+        str " used but not declared:" ++
+        fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in
+  (* We try to postpone the computation of used section variables *)
+  let hyps, def =
+    let context_ids = List.map pi1 (named_context env) in
+    match ctx with
+    | None when not (List.is_empty context_ids) -> 
+        (* No declared section vars, and non-empty section context:
+           we must look at the body NOW, if any *)
+        let ids_typ = global_vars_set_constant_type env typ in
+        let ids_def = match def with
+        | Undef _ -> Idset.empty
+        | Def cs -> global_vars_set env (Mod_subst.force_constr cs)
+        | OpaqueDef lc ->
+            let vars =
+              global_vars_set env
+                (Opaqueproof.force_proof (opaque_tables env) lc) in
+            (* we force so that cst are added to the env immediately after *)
+            ignore(Opaqueproof.force_constraints (opaque_tables env) lc);
+            !suggest_proof_using kn env vars ids_typ context_ids;
+            if !Flags.compilation_mode = Flags.BuildVo then
+              record_aux env ids_typ vars;
+            vars
+        in
+        keep_hyps env (Idset.union ids_typ ids_def), def
+    | None ->
+        if !Flags.compilation_mode = Flags.BuildVo then
+          record_aux env Id.Set.empty Id.Set.empty;
+        [], def (* Empty section context: no need to check *)
+    | Some declared ->
+        (* We use the declared set and chain a check of correctness *)
+        declared,
+        match def with
+        | Undef _ as x -> x (* nothing to check *)
+        | Def cs as x ->
+            let ids_typ = global_vars_set_constant_type env typ in
+            let ids_def = global_vars_set env (Mod_subst.force_constr cs) in
+            let inferred = keep_hyps env (Idset.union ids_typ ids_def) in
+            check declared inferred;
+            x
+        | OpaqueDef lc -> (* In this case we can postpone the check *)
+            OpaqueDef (Opaqueproof.iter_direct_opaque (fun c ->
+              let ids_typ = global_vars_set_constant_type env typ in
+              let ids_def = global_vars_set env c in
+              let inferred = keep_hyps env (Idset.union ids_typ ids_def) in
+              check declared inferred) lc) in
+  let tps = 
+    (* FIXME: incompleteness of the bytecode vm: we compile polymorphic 
+       constants like opaque definitions. *)
+    if poly then Cemitcodes.from_val Cemitcodes.BCconstant
+    else
+      match proj with
+      | None -> Cemitcodes.from_val (compile_constant_body env def)
+      | Some pb ->
+	Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body)))
+  in
   { const_hyps = hyps;
     const_body = def;
     const_type = typ;
+    const_proj = proj;
     const_body_code = tps;
-    const_constraints = cst }
+    const_polymorphic = poly;
+    const_universes = univs;
+    const_inline_code = inline_code }
+
 
 (*s Global and local constant declaration. *)
 
 let translate_constant env kn ce =
-  build_constant_declaration env kn (infer_declaration env ce)
+  build_constant_declaration kn env (infer_declaration env (Some kn) ce)
+
+let translate_local_assum env t =
+  let j = infer env t in
+  let t = Typeops.assumption_of_judgment env j in
+    t
 
 let translate_recipe env kn r =
-  build_constant_declaration env kn 
-    (let def,typ,cst,hyps = Cooking.cook_constant env r in
-     def,typ,cst,Some hyps)
+  build_constant_declaration kn env (Cooking.cook_constant env r)
+
+let translate_local_def env id centry =
+  let def,typ,proj,poly,univs,inline_code,ctx =
+    infer_declaration env None (DefinitionEntry centry) in
+  let typ = type_of_constant_type env typ in
+  def, typ, univs
 
 (* Insertion of inductive types. *)
 
-let translate_mind env kn mie = check_inductive env kn mie
+let translate_mind env kn mie = Indtypes.check_inductive env kn mie
+
+let handle_entry_side_effects env ce = { ce with
+  const_entry_body = Future.chain ~greedy:true ~pure:true
+    ce.const_entry_body (fun ((body, ctx), side_eff) ->
+      (handle_side_effects env body side_eff, ctx), Declareops.no_seff);
+}
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index bcc2ca0d..696fc3d2 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.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        *)
@@ -9,29 +9,40 @@
 open Names
 open Term
 open Univ
-open Declarations
-open Inductive
 open Environ
+open Declarations
 open Entries
-open Typeops
 
-val translate_local_def : env -> constr * types option ->
-  constr * types * Univ.constraints
+val translate_local_def : env -> Id.t -> definition_entry ->
+  constant_def * types * constant_universes
 
-val translate_local_assum : env -> types ->
-  types * Univ.constraints
+val translate_local_assum : env -> types -> types
 
-val infer_declaration : env -> constant_entry ->
-  constant_def * constant_type * constraints * Sign.section_context option
+val mk_pure_proof : constr -> proof_output
 
-val build_constant_declaration : env -> 'a ->
-  constant_def * constant_type * constraints * Sign.section_context option -> 
-    constant_body
+val handle_side_effects : env -> constr -> Declareops.side_effects -> constr
+(** Returns the term where side effects have been turned into let-ins or beta
+    redexes. *)
+
+val handle_entry_side_effects : env -> definition_entry -> definition_entry
+(** Same as {!handle_side_effects} but applied to entries. Only modifies the
+    {!Entries.const_entry_body} field. It is meant to get a term out of a not
+    yet type checked proof. *)
 
 val translate_constant : env -> constant -> constant_entry -> constant_body
 
 val translate_mind :
   env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
 
-val translate_recipe :
-  env -> constant -> Cooking.recipe -> constant_body
+val translate_recipe : env -> constant -> Cooking.recipe -> constant_body
+
+(** Internal functions, mentioned here for debug purpose only *)
+
+val infer_declaration : env -> constant option -> 
+  constant_entry -> Cooking.result
+
+val build_constant_declaration :
+  constant -> env -> Cooking.result -> constant_body
+
+val set_suggest_proof_using :
+  (constant -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> unit) -> unit
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 0a920e40..33c4172e 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.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,7 +8,6 @@
 
 open Names
 open Term
-open Sign
 open Environ
 open Reduction
 
@@ -31,6 +30,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -42,26 +42,27 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ReferenceVariables of identifier * constr
+  | 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
+  | WrongCaseInfo of pinductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * constructor * constr * constr
-  | Generalization of (name * types) * unsafe_judgment
+  | IllFormedBranch of constr * pconstructor * constr * constr
+  | Generalization of (Name.t * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
+  | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array
   | IllTypedRecBody of
-      int * name array * unsafe_judgment array * types array
+      int * Name.t array * unsafe_judgment array * types array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
-let nfj {uj_val=c;uj_type=ct} =
-  {uj_val=c;uj_type=nf_betaiota ct}
+let nfj env {uj_val=c;uj_type=ct} =
+  {uj_val=c;uj_type=nf_betaiota env ct}
 
 let error_unbound_rel env n =
   raise (TypeError (env, UnboundRel n))
@@ -75,8 +76,8 @@ let error_not_type env j =
 let error_assumption env j =
   raise (TypeError (env, BadAssumption j))
 
-let error_reference_variables env id =
-  raise (TypeError (env, ReferenceVariables id))
+let error_reference_variables env id c =
+  raise (TypeError (env, ReferenceVariables (id,c)))
 
 let error_elim_arity env ind aritylst c pj okinds =
   raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds)))
@@ -85,11 +86,11 @@ let error_case_not_inductive env j =
   raise (TypeError (env, CaseNotInductive j))
 
 let error_number_branches env cj expn =
-  raise (TypeError (env, NumberBranches (nfj cj,expn)))
+  raise (TypeError (env, NumberBranches (nfj env cj,expn)))
 
 let error_ill_formed_branch env c i actty expty =
   raise (TypeError (env,
-    IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty)))
+    IllFormedBranch (c,i,nf_betaiota env actty, nf_betaiota env expty)))
 
 let error_generalization env nvar c =
   raise (TypeError (env, Generalization (nvar,c)))
@@ -115,3 +116,5 @@ let error_elim_explain kp ki =
   | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
   | _ -> WrongArity
 
+let error_unsatisfied_constraints env c =
+  raise (TypeError (env, UnsatisfiedConstraints c))
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index c62cd446..7b3d2f1c 100644
--- a/kernel/type_errors.mli
+++ b/kernel/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        *)
@@ -31,6 +31,7 @@ type guard_error =
   | RecCallInCaseArg of constr
   | RecCallInCasePred of constr
   | NotGuardedForm of constr
+  | ReturnPredicateNotCoInductive of constr
 
 type arity_error =
   | NonInformativeToInformative
@@ -42,21 +43,22 @@ type type_error =
   | UnboundVar of variable
   | NotAType of unsafe_judgment
   | BadAssumption of unsafe_judgment
-  | ReferenceVariables of constr
-  | ElimArity of inductive * sorts_family list * constr * unsafe_judgment
+  | ReferenceVariables of identifier * constr
+  | 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
+  | WrongCaseInfo of pinductive * case_info
   | NumberBranches of unsafe_judgment * int
-  | IllFormedBranch of constr * constructor * constr * constr
-  | Generalization of (name * types) * unsafe_judgment
+  | IllFormedBranch of constr * pconstructor * constr * constr
+  | Generalization of (Name.t * types) * unsafe_judgment
   | ActualType of unsafe_judgment * types
   | CantApplyBadType of
       (int * constr * constr) * unsafe_judgment * unsafe_judgment array
   | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array
-  | IllFormedRecBody of guard_error * name array * int * env * unsafe_judgment array
+  | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array
   | IllTypedRecBody of
-      int * name array * unsafe_judgment array * types array
+      int * Name.t array * unsafe_judgment array * types array
+  | UnsatisfiedConstraints of Univ.constraints
 
 exception TypeError of env * type_error
 
@@ -68,19 +70,19 @@ val error_not_type : env -> unsafe_judgment -> 'a
 
 val error_assumption : env -> unsafe_judgment -> 'a
 
-val error_reference_variables : env -> constr -> 'a
+val error_reference_variables : env -> identifier -> 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
 
 val error_number_branches : env -> unsafe_judgment -> int -> 'a
 
-val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a
+val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a
 
-val error_generalization : env -> name * types -> unsafe_judgment -> 'a
+val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a
 
 val error_actual_type : env -> unsafe_judgment -> types -> 'a
 
@@ -92,9 +94,11 @@ val error_cant_apply_bad_type :
       unsafe_judgment -> unsafe_judgment array -> 'a
 
 val error_ill_formed_rec_body :
-  env -> guard_error -> name array -> int -> env -> unsafe_judgment array -> 'a
+  env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a
 
 val error_ill_typed_rec_body  :
-  env -> int -> name array -> unsafe_judgment array -> types array -> 'a
+  env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a
 
 val error_elim_explain : sorts_family -> sorts_family -> arity_error
+
+val error_unsatisfied_constraints : env -> Univ.constraints -> 'a
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 8b27cf91..2642b186 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -1,36 +1,40 @@
 (************************************************************************)
 (*  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 Term
+open Vars
+open Context
 open Declarations
-open Sign
 open Environ
 open Entries
 open Reduction
 open Inductive
 open Type_errors
 
-let conv_leq l2r = default_conv CUMUL ~l2r
+let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y
 
 let conv_leq_vecti env v1 v2 =
-  array_fold_left2_i
-    (fun i c t1 t2 ->
-      let c' =
-        try default_conv CUMUL env t1 t2
-        with NotConvertible -> raise (NotConvertibleVect i) in
-      union_constraints c c')
-    empty_constraint
+  Array.fold_left2_i
+    (fun i _ t1 t2 ->
+      try conv_leq false env t1 t2
+      with NotConvertible -> raise (NotConvertibleVect i))
+    ()
     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 j =
   match kind_of_term(whd_betadeltaiota env j.uj_type) with
@@ -67,9 +71,9 @@ let judge_of_prop_contents = function
 (* Type of Type(i). *)
 
 let judge_of_type u =
-  let uu = super u in
-  { uj_val = mkType u;
-    uj_type = mkType uu }
+  let uu = Universe.super u in
+    { uj_val = mkType u;
+      uj_type = mkType uu }
 
 (*s Type of a de Bruijn index. *)
 
@@ -91,82 +95,106 @@ let judge_of_variable 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 =
-  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")
+(* Checks if a context of variables can be instantiated by the
+   variables of the current env.
+   Order does not have to be checked assuming that all names are distinct *)
+let check_hyps_inclusion env c sign =
+  Context.fold_named_context
+    (fun (id,b1,ty1) () ->
+      try
+        let (_,b2,ty2) = lookup_named id env in
+        conv env ty2 ty1;
+        (match b2,b1 with
+        | None, None -> ()
+        | None, Some _ ->
+            (* This is wrong, because we don't know if the body is
+               needed or not for typechecking: *) ()
+        | Some _, None -> raise NotConvertible
+        | Some b2, Some b1 -> conv env b2 b1);
+      with Not_found | NotConvertible | Option.Heterogeneous ->
+        error_reference_variables env id c)
     sign
     ~init:()
 
-
-let check_args env c hyps =
-  try check_hyps_inclusion env hyps
-  with UserError _ | Not_found ->
-    error_reference_variables env c
-
-
-(* Checks if the given context of variables [hyps] is included in the
-   current context of [env]. *)
-(*
-let check_hyps id env hyps =
-  let hyps' = named_context env in
-  if not (hyps_inclusion env hyps hyps') then
-    error_reference_variables env id
-*)
 (* Instantiation of terms on real arguments. *)
 
 (* Make a type polymorphic if an arity *)
 
 let extract_level env p =
   let _,c = dest_prod_assum env p in
-  match kind_of_term c with Sort (Type u) -> Some u | _ -> None
+  match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None
 
-let extract_context_levels env =
-  List.fold_left
-    (fun l (_,b,p) -> if b=None then extract_level env p::l else l) []
+let extract_context_levels env l =
+  let fold l (_, b, p) = match b with
+  | None -> extract_level env p :: l
+  | _ -> l
+  in
+  List.fold_left fold [] l
 
 let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} =
   let params, ccl = dest_prod_assum env t in
   match kind_of_term ccl with
   | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) ->
       let param_ccls = extract_context_levels env params in
-      let s = { poly_param_levels = param_ccls; poly_level = u} in
-      PolymorphicArity (params,s)
+      let s = { template_param_levels = param_ccls; template_level = u} in
+      TemplateArity (params,s)
   | _ ->
-      NonPolymorphicType t
+      RegularArity t
 
 (* 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 cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ty, cu = constant_type env cst in
+    type_of_constant_type_knowing_parameters env ty paramtyps, cu
+
+let type_of_constant_knowing_parameters_in env cst paramtyps =
+  let cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ty = constant_type_in env cst in
+    type_of_constant_type_knowing_parameters env ty paramtyps
+
 let type_of_constant_type env t =
-  type_of_constant_knowing_parameters env t [||]
+  type_of_constant_type_knowing_parameters env t [||]
 
 let type_of_constant env cst =
-  type_of_constant_type env (constant_type env cst)
+  type_of_constant_knowing_parameters env cst [||]
 
-let judge_of_constant_knowing_parameters env cst jl =
-  let c = mkConst cst in
-  let cb = lookup_constant cst env in
-  let _ = check_args env c cb.const_hyps in
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in
-  make_judge c t
+let type_of_constant_in env cst =
+  let cb = lookup_constant (fst cst) env in
+  let _ = check_hyps_inclusion env (mkConstU cst) cb.const_hyps in
+  let ar = constant_type_in env cst in
+    type_of_constant_type_knowing_parameters env ar [||]
+
+let judge_of_constant_knowing_parameters env (kn,u as cst) args =
+  let c = mkConstU cst in
+  let ty, cu = type_of_constant_knowing_parameters env cst args in
+  let _ = Environ.check_constraints cu env in
+    make_judge c ty
 
 let judge_of_constant env cst =
   judge_of_constant_knowing_parameters env cst [||]
 
+let type_of_projection env (p,u) =
+  let cst = Projection.constant p in
+  let cb = lookup_constant cst env in
+  match cb.const_proj with
+  | Some pb -> 
+    if cb.const_polymorphic then
+      Vars.subst_instance_constr u pb.proj_type
+    else pb.proj_type
+  | None -> raise (Invalid_argument "type_of_projection: not a projection")
+
+
 (* Type of a lambda-abstraction. *)
 
 (* [judge_of_abstraction env name var j] implements the rule
@@ -192,18 +220,16 @@ let judge_of_letin env name defj typj j =
 (* Type of an application. *)
 
 let judge_of_apply env funj argjv =
-  let rec apply_rec n typ cst = function
+  let rec apply_rec n typ = function
     | [] ->
 	{ uj_val  = mkApp (j_val funj, Array.map j_val argjv);
-          uj_type = typ },
-	cst
+          uj_type = typ }
     | hj::restjl ->
         (match kind_of_term (whd_betadeltaiota env typ) with
           | Prod (_,c1,c2) ->
 	      (try
-		let c = conv_leq false env hj.uj_type c1 in
-		let cst' = union_constraints cst c in
-		apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
+		 let () = conv_leq false env hj.uj_type c1 in
+		   apply_rec (n+1) (subst1 hj.uj_val c2) restjl
 	      with NotConvertible ->
 		error_cant_apply_bad_type env
 		  (n,c1, hj.uj_type)
@@ -214,7 +240,6 @@ let judge_of_apply env funj argjv =
   in
   apply_rec 1
     funj.uj_type
-    empty_constraint
     (Array.to_list argjv)
 
 (* Type of product *)
@@ -227,18 +252,20 @@ let sort_of_product env domsort rangsort =
     | (Prop _,  Prop Pos) -> rangsort
     (* Product rule (Type,Set,?) *)
     | (Type u1, Prop Pos) ->
-        if engagement env = Some ImpredicativeSet then
+        begin match engagement env with
+        | Some ImpredicativeSet ->
           (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
           rangsort
-        else
+        | _ ->
           (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
-          Type (sup u1 type0_univ)
+          Type (Universe.sup Universe.type0 u1)
+        end
     (* Product rule (Prop,Type_i,Type_i) *)
-    | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
+    | (Prop Pos,  Type u2)  -> Type (Universe.sup Universe.type0 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 (Universe.sup u1 u2)
 
 (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule
 
@@ -272,13 +299,17 @@ let judge_of_cast env cj k tj =
           vm_conv CUMUL env cj.uj_type expected_type
       | DEFAULTcast ->
           mkCast (cj.uj_val, k, expected_type),
-          conv_leq false env cj.uj_type expected_type
+          default_conv ~l2r:false CUMUL env cj.uj_type expected_type
       | REVERTcast ->
           cj.uj_val,
-          conv_leq true env cj.uj_type expected_type in
-    { uj_val = c;
-      uj_type = expected_type },
-    cst
+          default_conv ~l2r:true CUMUL env cj.uj_type expected_type
+      | NATIVEcast ->
+	 let sigma = Nativelambda.empty_evars in
+         mkCast (cj.uj_val, k, expected_type),
+         native_conv CUMUL sigma env cj.uj_type expected_type
+    in
+      { uj_val = c;
+	uj_type = expected_type }
   with NotConvertible ->
     error_actual_type env cj expected_type
 
@@ -296,50 +327,70 @@ let judge_of_cast env 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 jl =
-  let c = mkInd ind in
-  let (mib,mip) = lookup_mind_specif env ind in
-  check_args env c mib.mind_hyps;
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in
-  make_judge c t
+let judge_of_inductive_knowing_parameters env (ind,u as indu) args =
+  let c = mkIndU indu in
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env c mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive_knowing_parameters 
+    env (spec,u) args
+  in
+    check_constraints cst env;
+    make_judge c t
 
-let judge_of_inductive env ind =
-  judge_of_inductive_knowing_parameters env ind [||]
+let judge_of_inductive env (ind,u as indu) =
+  let c = mkIndU indu in
+  let (mib,mip) as spec = lookup_mind_specif env ind in
+  check_hyps_inclusion env c mib.mind_hyps;
+  let t,cst = Inductive.constrained_type_of_inductive env (spec,u) in
+    check_constraints cst env;
+    (make_judge c t)
 
 (* Constructors. *)
 
-let judge_of_constructor env c =
-  let constr = mkConstruct c in
+let judge_of_constructor env (c,u as cu) =
+  let constr = mkConstructU cu in
   let _ =
     let ((kn,_),_) = c in
     let mib = lookup_mind kn env in
-    check_args env constr mib.mind_hyps in
+    check_hyps_inclusion env constr mib.mind_hyps in
   let specif = lookup_mind_specif env (inductive_of_constructor c) in
-  make_judge constr (type_of_constructor c specif)
+  let t,cst = constrained_type_of_constructor cu specif in
+  let () = check_constraints cst env in
+    (make_judge constr t)
 
 (* Case. *)
 
-let check_branch_types env ind cj (lfj,explft) =
+let check_branch_types env (ind,u) cj (lfj,explft) =
   try conv_leq_vecti env (Array.map j_type lfj) explft
   with
       NotConvertibleVect i ->
-        error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
+        error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i)
     | Invalid_argument _ ->
         error_number_branches env cj (Array.length explft)
 
 let judge_of_case env ci pj cj lfj =
-  let indspec =
+  let (pind, _ as indspec) =
     try find_rectype env cj.uj_type
     with Not_found -> error_case_not_inductive env cj in
-  let _ = check_case_info env (fst indspec) ci in
-  let (bty,rslty,univ) =
+  let _ = check_case_info env pind ci in
+  let (bty,rslty) =
     type_case_branches env indspec pj cj.uj_val in
-  let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in
+  let () = check_branch_types env pind cj (lfj,bty) in
   ({ uj_val  = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
                        Array.map j_val lfj);
-     uj_type = rslty },
-  union_constraints univ univ')
+     uj_type = rslty })
+
+let judge_of_projection env p cj =
+  let pb = lookup_projection p env in
+  let (ind,u), args =
+    try find_rectype env cj.uj_type
+    with Not_found -> error_case_not_inductive env cj
+  in
+    assert(eq_mind pb.proj_ind (fst ind));
+    let ty = Vars.subst_instance_constr u pb.Declarations.proj_type in
+    let ty = substl (cj.uj_val :: List.rev args) ty in
+      {uj_val = mkProj (p,cj.uj_val);
+       uj_type = ty}
 
 (* Fixpoints. *)
 
@@ -348,7 +399,7 @@ let judge_of_case env ci pj cj lfj =
 
 let type_fixpoint env lna lar vdefj =
   let lt = Array.length vdefj in
-  assert (Array.length lar = lt);
+  assert (Int.equal (Array.length lar) lt);
   try
     conv_leq_vecti env (Array.map j_type vdefj) (Array.map (fun ty -> lift lt ty) lar)
   with NotConvertibleVect i ->
@@ -357,166 +408,155 @@ let type_fixpoint env lna lar vdefj =
 (************************************************************************)
 (************************************************************************)
 
-(* This combinator adds the universe constraints both in the local
-   graph and in the universes of the environment. This is to ensure
-   that the infered local graph is satisfiable. *)
-let univ_combinator (cst,univ) (j,c') =
-  (j,(union_constraints cst c', merge_constraints c' univ))
-
 (* The typing machine. *)
     (* ATTENTION : faudra faire le typage du contexte des Const,
     Ind et Constructsi un jour cela devient des constructions
     arbitraires et non plus des variables *)
-let rec execute env cstr cu =
+let rec execute env cstr =
   match kind_of_term cstr with
     (* Atomic terms *)
     | Sort (Prop c) ->
-	(judge_of_prop_contents c, cu)
-
+      judge_of_prop_contents c
+	
     | Sort (Type u) ->
-	(judge_of_type u, cu)
+      judge_of_type u
 
     | Rel n ->
-	(judge_of_relative env n, cu)
+      judge_of_relative env n
 
     | Var id ->
-	(judge_of_variable env id, cu)
+      judge_of_variable env id
 
     | Const c ->
-        (judge_of_constant env c, cu)
+      judge_of_constant env c
+	
+    | Proj (p, c) ->
+        let cj = execute env c in
+          judge_of_projection env p cj
 
     (* Lambda calculus operators *)
     | App (f,args) ->
-        let (jl,cu1) = execute_array env args cu in
-	let (j,cu2) =
+        let jl = execute_array env args in
+	let j =
 	  match kind_of_term f with
-	    | Ind ind ->
+	    | Ind ind when Environ.template_polymorphic_pind ind env ->
 		(* Sort-polymorphism of inductive types *)
-		judge_of_inductive_knowing_parameters env ind jl, cu1
-	    | Const cst ->
+	      let args = Array.map (fun j -> lazy j.uj_type) jl in
+		judge_of_inductive_knowing_parameters env ind args
+	    | Const cst when Environ.template_polymorphic_pconstant cst env ->
 		(* Sort-polymorphism of constant *)
-		judge_of_constant_knowing_parameters env cst jl, cu1
+	      let args = Array.map (fun j -> lazy j.uj_type) jl in
+		judge_of_constant_knowing_parameters env cst args
 	    | _ ->
 		(* No sort-polymorphism *)
-		execute env f cu1
+		execute env f
 	in
-	univ_combinator cu2 (judge_of_apply env j jl)
+	  judge_of_apply env j jl
 
     | Lambda (name,c1,c2) ->
-        let (varj,cu1) = execute_type env c1 cu in
-	let env1 = push_rel (name,None,varj.utj_val) env in
-        let (j',cu2) = execute env1 c2 cu1 in
-        (judge_of_abstraction env name varj j', cu2)
+      let varj = execute_type env c1 in
+      let env1 = push_rel (name,None,varj.utj_val) env in
+      let j' = execute env1 c2 in
+        judge_of_abstraction env name varj j'
 
     | Prod (name,c1,c2) ->
-        let (varj,cu1) = execute_type env c1 cu in
-	let env1 = push_rel (name,None,varj.utj_val) env in
-        let (varj',cu2) = execute_type env1 c2 cu1 in
-	(judge_of_product env name varj varj', cu2)
+      let varj = execute_type env c1 in
+      let env1 = push_rel (name,None,varj.utj_val) env in
+      let varj' = execute_type env1 c2 in
+	judge_of_product env name varj varj'
 
     | LetIn (name,c1,c2,c3) ->
-        let (j1,cu1) = execute env c1 cu in
-        let (j2,cu2) = execute_type env c2 cu1 in
-        let (_,cu3) =
-	  univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in
-        let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
-        let (j',cu4) = execute env1 c3 cu3 in
-        (judge_of_letin env name j1 j2 j', cu4)
+      let j1 = execute env c1 in
+      let j2 = execute_type env c2 in
+      let _ = judge_of_cast env j1 DEFAULTcast j2 in
+      let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
+      let j' = execute env1 c3 in
+        judge_of_letin env name j1 j2 j'
 
     | Cast (c,k, t) ->
-        let (cj,cu1) = execute env c cu in
-        let (tj,cu2) = execute_type env t cu1 in
-	univ_combinator cu2
-          (judge_of_cast env cj k tj)
+      let cj = execute env c in
+      let tj = execute_type env t in
+        judge_of_cast env cj k tj
 
     (* Inductive types *)
     | Ind ind ->
-	(judge_of_inductive env ind, cu)
+      judge_of_inductive env ind
 
     | Construct c ->
-	(judge_of_constructor env c, cu)
+      judge_of_constructor env c
 
     | Case (ci,p,c,lf) ->
-        let (cj,cu1) = execute env c cu in
-        let (pj,cu2) = execute env p cu1 in
-        let (lfj,cu3) = execute_array env lf cu2 in
-        univ_combinator cu3
-          (judge_of_case env ci pj cj lfj)
+        let cj = execute env c in
+        let pj = execute env p in
+        let lfj = execute_array env lf in
+          judge_of_case env ci pj cj lfj
 
     | Fix ((vn,i as vni),recdef) ->
-        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
-        let fix = (vni,recdef') in
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let fix = (vni,recdef') in
         check_fix env fix;
-	(make_judge (mkFix fix) fix_ty, cu1)
-
+	make_judge (mkFix fix) fix_ty
+	  
     | CoFix (i,recdef) ->
-        let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in
-        let cofix = (i,recdef') in
+      let (fix_ty,recdef') = execute_recdef env recdef i in
+      let cofix = (i,recdef') in
         check_cofix env cofix;
-	(make_judge (mkCoFix cofix) fix_ty, cu1)
-
+	(make_judge (mkCoFix cofix) fix_ty)
+	  
     (* 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 cu =
-  let (j,cu1) = execute env constr cu in
-  (type_judgment env j, cu1)
+and execute_type env constr =
+  let j = execute env constr in
+    type_judgment env j
 
-and execute_recdef env (names,lar,vdef) i cu =
-  let (larj,cu1) = execute_array env lar cu in
+and execute_recdef env (names,lar,vdef) i =
+  let larj = execute_array env lar in
   let lara = Array.map (assumption_of_judgment env) larj in
   let env1 = push_rec_types (names,lara,vdef) env in
-  let (vdefj,cu2) = execute_array env1 vdef cu1 in
+  let vdefj = execute_array env1 vdef in
   let vdefv = Array.map j_val vdefj in
-  let cst = type_fixpoint env1 names lara vdefj in
-  univ_combinator cu2
-    ((lara.(i),(names,lara,vdefv)),cst)
+  let () = type_fixpoint env1 names lara vdefj in
+    (lara.(i),(names,lara,vdefv))
 
-and execute_array env = array_fold_map' (execute env)
+and execute_array env = Array.map (execute env)
 
 (* Derived functions *)
 let infer env constr =
-  let (j,(cst,_)) =
-    execute env constr (empty_constraint, universes env) in
-  assert (eq_constr j.uj_val constr);
-  (j, cst)
+  let j = execute env constr in
+    assert (eq_constr j.uj_val constr);
+    j
+
+(* let infer_key = Profile.declare_profile "infer" *)
+(* let infer = Profile.profile2 infer_key infer *)
 
 let infer_type env constr =
-  let (j,(cst,_)) =
-    execute_type env constr (empty_constraint, universes env) in
-  (j, cst)
+  let j = execute_type env constr in
+    j
 
 let infer_v env cv =
-  let (jv,(cst,_)) =
-    execute_array env cv (empty_constraint, universes env) in
-  (jv, cst)
+  let jv = execute_array env cv in
+    jv
 
 (* Typing of several terms. *)
 
 let infer_local_decl env id = function
   | LocalDef c ->
-      let (j,cst) = infer env c in
-      (Name id, Some j.uj_val, j.uj_type), cst
+      let j = infer env c in
+      (Name id, Some j.uj_val, j.uj_type)
   | LocalAssum c ->
-      let (j,cst) = infer env c in
-      (Name id, None, assumption_of_judgment env j), cst
+      let j = infer env c in
+      (Name id, None, assumption_of_judgment env j)
 
 let infer_local_decls env decls =
   let rec inferec env = function
   | (id, d) :: l ->
-      let env, l, cst1 = inferec env l in
-      let d, cst2 = infer_local_decl env id d in
-      push_rel d env, add_rel_decl d l, union_constraints cst1 cst2
-  | [] -> env, empty_rel_context, empty_constraint in
+      let (env, l) = inferec env l in
+      let d = infer_local_decl env id d in
+	(push_rel d env, add_rel_decl d l)
+  | [] -> (env, empty_rel_context) in
   inferec env decls
-
-(* Exported typing functions *)
-
-let typing env c =
-  let (j,cst) = infer env c in
-  let _ = add_constraints cst env in
-  j
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 5ce419b3..010b2b6f 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.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        *)
@@ -9,19 +9,26 @@
 open Names
 open Univ
 open Term
+open Context
 open Environ
 open Entries
 open Declarations
 
-(** {6 Typing functions (not yet tagged as safe) } *)
+(** {6 Typing functions (not yet tagged as safe) }
 
-val infer      : env -> constr       -> unsafe_judgment * constraints
-val infer_v    : env -> constr array -> unsafe_judgment array * constraints
-val infer_type : env -> types        -> unsafe_type_judgment * constraints
+    They return unsafe judgments that are "in context" of a set of 
+    (local) universe variables (the ones that appear in the term)
+    and associated constraints. In case of polymorphic definitions,
+    these variables and constraints will be generalized.
+ *)
+
+
+val infer      : env -> constr       -> unsafe_judgment
+val infer_v    : env -> constr array -> unsafe_judgment array
+val infer_type : env -> types        -> unsafe_type_judgment
 
 val infer_local_decls :
-  env -> (identifier * local_entry) list
-    -> env * rel_context * constraints
+  env -> (Id.t * local_entry) list -> (env * rel_context)
 
 (** {6 Basic operations of the typing machine. } *)
 
@@ -32,8 +39,10 @@ val assumption_of_judgment :  env -> unsafe_judgment -> types
 val type_judgment          :  env -> unsafe_judgment -> unsafe_type_judgment
 
 (** {6 Type of sorts. } *)
-val judge_of_prop_contents : contents -> unsafe_judgment
-val judge_of_type          : universe -> unsafe_judgment
+val judge_of_prop : unsafe_judgment
+val judge_of_set  : unsafe_judgment
+val judge_of_prop_contents  : contents -> unsafe_judgment
+val judge_of_type           : universe -> unsafe_judgment
 
 (** {6 Type of a bound variable. } *)
 val judge_of_relative : env -> int -> unsafe_judgment
@@ -42,65 +51,81 @@ val judge_of_relative : env -> int -> unsafe_judgment
 val judge_of_variable : env -> variable -> unsafe_judgment
 
 (** {6 type of a constant } *)
-val judge_of_constant : env -> constant -> unsafe_judgment
+
+val judge_of_constant : env -> pconstant -> unsafe_judgment
 
 val judge_of_constant_knowing_parameters :
-  env -> constant -> unsafe_judgment array -> unsafe_judgment
+  env -> pconstant -> types Lazy.t array -> unsafe_judgment
+
+(** {6 type of an applied projection } *)
+
+val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment
 
 (** {6 Type of application. } *)
 val judge_of_apply :
   env -> unsafe_judgment -> unsafe_judgment array
-    -> unsafe_judgment * constraints
+    -> unsafe_judgment
 
 (** {6 Type of an abstraction. } *)
 val judge_of_abstraction :
-  env -> name -> unsafe_type_judgment -> unsafe_judgment
+  env -> Name.t -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
+val sort_of_product : env -> sorts -> sorts -> sorts
+
 (** {6 Type of a product. } *)
 val judge_of_product :
-  env -> name -> unsafe_type_judgment -> unsafe_type_judgment
+  env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment
     -> unsafe_judgment
 
 (** s Type of a let in. *)
 val judge_of_letin :
-  env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
+  env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
     -> unsafe_judgment
 
 (** {6 Type of a cast. } *)
 val judge_of_cast :
   env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
-    unsafe_judgment * constraints
+  unsafe_judgment
 
 (** {6 Inductive types. } *)
 
-val judge_of_inductive : env -> inductive -> unsafe_judgment
+val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment
 
-val judge_of_inductive_knowing_parameters :
-  env -> inductive -> unsafe_judgment array -> unsafe_judgment
+(* val judge_of_inductive_knowing_parameters : *)
+(*   env -> inductive -> unsafe_judgment array -> unsafe_judgment *)
 
-val judge_of_constructor : env -> constructor -> unsafe_judgment
+val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment
 
 (** {6 Type of Cases. } *)
 val judge_of_case : env -> case_info
   -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
-    -> unsafe_judgment * constraints
+    -> unsafe_judgment
 
 (** Typecheck general fixpoint (not checking guard conditions) *)
-val type_fixpoint : env -> name array -> types array
-    -> unsafe_judgment array -> constraints
-
-(** Kernel safe typing but applicable to partial proofs *)
-val typing : env -> constr -> unsafe_judgment
+val type_fixpoint : env -> Name.t array -> types array
+    -> unsafe_judgment array -> unit
 
-val type_of_constant : env -> constant -> types
+val type_of_constant : env -> pconstant -> types constrained
 
 val type_of_constant_type : env -> constant_type -> types
 
+val type_of_projection : env -> Names.projection puniverses -> types
+
+val type_of_constant_in : env -> pconstant -> types
+
+val type_of_constant_type_knowing_parameters :
+  env -> constant_type -> types Lazy.t array -> types
+
 val type_of_constant_knowing_parameters :
-  env -> constant_type -> constr array -> types
+  env -> pconstant -> types Lazy.t array -> types constrained
+
+val type_of_constant_knowing_parameters_in :
+  env -> pconstant -> types Lazy.t array -> types
 
 (** Make a type polymorphic if an arity *)
 val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
   constant_type
 
+(** Check that hyps are included in env and fails with error otherwise *)
+val check_hyps_inclusion : env -> constr -> section_context -> unit
diff --git a/kernel/uint31.ml b/kernel/uint31.ml
new file mode 100644
index 00000000..3a0da2f6
--- /dev/null
+++ b/kernel/uint31.ml
@@ -0,0 +1,153 @@
+  (* Invariant: For arch64 all extra bytes are set to 0 *)
+type t = int 
+    
+  (* to be used only on 32 bits achitectures *)
+let maxuint31 = Int32.of_string "0x7FFFFFFF"
+let uint_32 i =  Int32.logand (Int32.of_int i) maxuint31
+    
+let select f32 f64 = if Sys.word_size = 64 then f64 else f32
+ 
+    (* conversion to an int *)
+let to_int i = i 
+
+let of_int_32 i = i
+let of_int_64 i = i land 0x7FFFFFFF
+
+let of_int = select of_int_32 of_int_64
+let of_uint i = i
+ 	
+    (* convertion of an uint31 to a string *)
+let to_string_32 i = Int32.to_string (uint_32 i)
+let to_string_64 = string_of_int 
+
+let to_string = select to_string_32 to_string_64
+let of_string s = 
+  let i32 = Int32.of_string s in
+  if Int32.compare Int32.zero i32 <= 0
+      && Int32.compare i32 maxuint31 <= 0 
+  then Int32.to_int i32
+  else raise (Failure "int_of_string")
+
+      
+
+    (* logical shift *)
+let l_sl x y = 
+  of_int (if 0 <= y && y < 31 then x lsl y else 0)
+    
+let l_sr x y = 
+  if 0 <= y && y < 31 then x lsr y else 0
+    
+let l_and x y = x land y
+let l_or x y = x lor y
+let l_xor x y = x lxor y
+
+    (* addition of int31 *)
+let add x y = of_int (x + y)
+ 
+    (* subtraction *)
+let sub x y = of_int (x - y)
+   
+    (* multiplication *)
+let mul x y = of_int (x * y)
+    
+    (* exact multiplication *)
+let mulc_32 x y =
+  let x = Int64.of_int32 (uint_32 x) in
+  let y = Int64.of_int32 (uint_32 y) in
+  let m = Int64.mul x y in
+  let l = Int64.to_int m in
+  let h = Int64.to_int (Int64.shift_right_logical m 31) in
+  h,l
+
+let mulc_64 x y =
+  let m = x * y in
+  let l = of_int_64 m in
+  let h = of_int_64 (m lsr 31) in
+  h, l
+let mulc = select mulc_32 mulc_64
+
+    (* division *)
+let div_32 x y = 
+  if y = 0 then 0 else
+  Int32.to_int (Int32.div (uint_32 x) (uint_32 y)) 
+let div_64 x y = if y = 0 then 0 else  x / y
+let div = select div_32 div_64
+    
+    (* modulo *)
+let rem_32 x y = 
+  if y = 0 then 0 
+  else Int32.to_int (Int32.rem (uint_32 x) (uint_32 y))
+let rem_64 x y = if y = 0 then 0 else x mod y
+let rem = select rem_32 rem_64
+    
+    (* division of two numbers by one *)
+let div21_32 xh xl y =
+  if y = 0 then (0,0) 
+  else
+    let x = 
+      Int64.logor 
+	(Int64.shift_left (Int64.of_int32 (uint_32 xh)) 31) 
+	(Int64.of_int32 (uint_32 xl)) in
+    let y = Int64.of_int32 (uint_32 y) in
+    let q = Int64.div x y in
+    let r = Int64.rem x y in
+    Int64.to_int q, Int64.to_int r
+let div21_64 xh xl y =
+  if y = 0 then (0,0) 
+  else
+    let x = (xh lsl 31) lor xl in
+    let q = x / y in
+    let r = x mod y in
+    q, r
+let div21 = select div21_32 div21_64
+    
+    (* comparison *)
+let lt_32 x y = (x lxor 0x40000000) < (y lxor 0x40000000)
+
+(* Do not remove the type information it is really important for 
+   efficiency *)
+let lt_64 (x:int) (y:int) = x < y
+let lt = select lt_32 lt_64
+
+let le_32 x y = 
+ (x lxor 0x40000000) <= (y lxor 0x40000000)
+
+(* Do not remove the type information it is really important for
+   efficiency *)
+let le_64 (x:int) (y:int) = x <= y
+let le = select le_32 le_64
+
+let equal (x:int) (y:int) = x == y
+    
+let cmp_32 x y = Int32.compare (uint_32 x) (uint_32 y)
+(* Do not remove the type information it is really important for 
+   efficiency *)
+let cmp_64 (x:int) (y:int) = compare x y
+let compare = select cmp_32 cmp_64
+  
+    (* head tail *)
+
+let head0 x =
+  let r = ref 0 in
+  let x = ref x in
+  if !x land 0x7FFF0000 = 0 then r := !r + 15
+  else x := !x lsr 15;
+  if !x land 0xFF00 = 0 then (x := !x lsl 8; r := !r + 8);
+  if !x land 0xF000 = 0 then (x := !x lsl 4; r := !r + 4);
+  if !x land 0xC000 = 0 then (x := !x lsl 2; r := !r + 2);
+  if !x land 0x8000 = 0 then (x := !x lsl 1; r := !r + 1);
+  if !x land 0x8000 = 0 then (               r := !r + 1);
+  !r;;
+
+let tail0 x =
+  let r = ref 0 in
+  let x = ref x in
+  if !x land 0xFFFF = 0 then (x := !x lsr 16; r := !r + 16);
+  if !x land 0xFF = 0   then (x := !x lsr 8;  r := !r + 8);
+  if !x land 0xF = 0    then (x := !x lsr 4;  r := !r + 4);
+  if !x land 0x3 = 0    then (x := !x lsr 2;  r := !r + 2);
+  if !x land 0x1 = 0    then (                r := !r + 1);
+  !r
+
+let add_digit x d =
+  (x lsl 1) lor d
diff --git a/kernel/uint31.mli b/kernel/uint31.mli
new file mode 100644
index 00000000..e8b98080
--- /dev/null
+++ b/kernel/uint31.mli
@@ -0,0 +1,41 @@
+type t
+
+      (* conversion to int *)
+val to_int : t -> int
+val of_int : int -> t
+val of_uint : int -> t
+
+     (* convertion to a string *)
+val to_string : t -> string
+val of_string : string -> t
+
+      (* logical operations *)
+val l_sl    : t -> t -> t
+val l_sr    : t -> t -> t
+val l_and   : t -> t -> t
+val l_xor   : t -> t -> t
+val l_or    : t -> t -> t
+
+      (* Arithmetic operations *) 
+val add     : t -> t -> t
+val sub     : t -> t -> t
+val mul     : t -> t -> t
+val div     : t -> t -> t
+val rem     : t -> t -> t
+      
+      (* Specific arithmetic operations *)
+val mulc    : t -> t -> t * t
+val div21   : t -> t -> t -> t * t
+      
+      (* comparison *)
+val lt      : t -> t -> bool
+val equal   : t -> t -> bool
+val le      : t -> t -> bool
+val compare : t -> t -> int
+
+      (* head and tail *)
+val head0   : t -> t
+val tail0   : t -> t
+
+(** Used by retroknowledge *)
+val add_digit : t -> t -> t
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 822f6ca6..08e9fee0 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.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        *)
@@ -10,10 +10,13 @@
 (* 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] *)
+(* Support for universe polymorphism by MS [2014] *)
 
-(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, 
+   Pierre-Marie Pédrot *)
 
 open Pp
+open Errors
 open Util
 
 (* Universes are stratified by a partial ordering $\le$.
@@ -28,40 +31,337 @@ open Util
    union-find algorithm. The assertions $<$ and $\le$ are represented by
    adjacency lists *)
 
-module UniverseLevel = struct
+module type Hashconsed =
+sig
+  type t
+  val hash : t -> int
+  val equal : t -> t -> bool
+  val hcons : t -> t
+end
 
-  type t =
-    | Set
-    | Level of Names.dir_path * int
+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 mem : elt -> t -> bool
+    val remove : elt -> t -> t
+    val to_list : t -> elt list
+    val compare : (elt -> elt -> int) -> t -> t -> int
+  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
 
-  (* A specialized comparison function: we compare the [int] part
-     first (this property is used by the [check_sorted] function
-     below). This way, most of the time, the [dir_path] part is not
-     considered. *)
+  let 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)
+
+  let rec mem x = function
+  | Nil -> false
+  | Cons (y, _, l) -> H.equal x y || mem x l
+
+  let rec compare cmp l1 l2 = match l1, l2 with
+  | Nil, Nil -> 0
+  | Cons (x1, h1, l1), Cons (x2, h2, l2) ->
+    let c = Int.compare h1 h2 in
+    if c == 0 then
+      let c = cmp x1 x2 in
+      if c == 0 then
+        compare cmp l1 l2
+      else c
+    else c
+  | Cons _, Nil -> 1
+  | Nil, Cons _ -> -1
+
+  end
+end
 
-  let compare u v = match u,v with
+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 (dp1, i1), Level (dp2, i2) ->
+    | Level (i1, dp1), Level (i2, dp2) ->
       if i1 < i2 then -1
       else if i1 > i2 then 1
-      else compare dp1 dp2
+      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 to_string = function
+  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 natural_compare u v =
+    if u == v then 0
+    else RawLevel.compare (data u) (data v)
+	    
+  let to_string x = 
+    match data x with
+    | Prop -> "Prop"
     | Set -> "Set"
-    | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+    | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n
+    | Var n -> "Var(" ^ string_of_int n ^ ")"
+
+  let pr u = str (to_string u)
+
+  let apart u v =
+    match data u, data v with
+    | Prop, Set | Set, Prop -> true
+    | _ -> false
+
+  let vars = Array.init 20 (fun i -> make (Var i))
+
+  let var n = 
+    if n < 20 then vars.(n) else make (Var n)
+
+  let var_index u =
+    match data u with
+    | Var n -> Some n | _ -> None
+
+  let make m n = make (Level (n, Names.DirPath.hcons m))
+
+end
+
+(** Level maps *)
+module LMap = struct 
+  module M = HMap.Make (Level)
+  include M
+
+  let union l r = 
+    merge (fun k l r -> 
+      match l, r with
+      | Some _, _ -> l
+      | _, _ -> r) l r
+
+  let subst_union l r = 
+    merge (fun k l r -> 
+      match l, r with
+      | Some (Some _), _ -> l
+      | Some None, None -> l
+      | _, _ -> r) l r
+
+  let diff ext orig =
+    fold (fun u v acc -> 
+      if mem u orig then acc 
+      else add u v acc)
+      ext empty
+
+  let pr f m =
+    h 0 (prlist_with_sep fnl (fun (u, v) ->
+      Level.pr u ++ f v) (bindings m))
+end
+
+module LSet = struct
+  include LMap.Set
+
+  let pr prl s =
+    str"{" ++ prlist_with_sep spc prl (elements s) ++ str"}"
+
+  let of_array l =
+    Array.fold_left (fun acc x -> add x acc) empty l
+
 end
 
-module UniverseLMap = Map.Make (UniverseLevel)
-module UniverseLSet = Set.Make (UniverseLevel)
 
-type universe_level = UniverseLevel.t
+type 'a universe_map = 'a LMap.t
+
+type universe_level = Level.t
 
-let compare_levels = UniverseLevel.compare
+type universe_level_subst_fn = universe_level -> universe_level
+
+type universe_set = LSet.t
 
 (* An algebraic universe [universe] is either a universe variable
-   [UniverseLevel.t] or a formal universe known to be greater than some
+   [Level.t] or a formal universe known to be greater than some
    universe variables and strictly greater than some (other) universe
    variables
 
@@ -72,121 +372,354 @@ let compare_levels = UniverseLevel.compare
    maximum of two algebraic universes
 *)
 
-type universe =
-  | Atom of UniverseLevel.t
-  | Max of UniverseLevel.t list * UniverseLevel.t list
-
-let make_universe_level (m,n) = UniverseLevel.Level (m,n)
-let make_universe l = Atom l
-let make_univ c = Atom (make_universe_level c)
+module Universe =
+struct
+  (* Invariants: non empty, sorted and without duplicates *)
 
-let universe_level = function
-  | Atom l -> Some l
-  | Max _ -> None
-
-let pr_uni_level u = str (UniverseLevel.to_string u)
+  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 compare u v =
+      if u == v then 0
+      else 
+	let (x, n) = u and (x', n') = v in
+	  if Int.equal n n' then Level.compare x x'
+	  else n - n'
+
+    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 is_small = function
+      | (l,0) -> Level.is_small 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 pr_with f (v, n) = 
+      if Int.equal n 0 then f v
+      else f v ++ str"+" ++ int n
+
+    let is_level = function
+      | (v, 0) -> true
+      | _ -> false
+
+    let level = function
+      | (v,0) -> Some v
+      | _ -> None
+	
+    let get_level (v,n) = v
+
+    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
+    
+  let compare_expr = Expr.compare
+
+  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 hash = Huniv.hash
+
+  let compare x y =
+    if x == y then 0
+    else 
+      let hx = Huniv.hash x and hy = Huniv.hash y in
+      let c = Int.compare hx hy in 
+	if c == 0 then
+	  Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y
+	else c
+
+  let rec hcons = function
+  | Nil -> Huniv.nil
+  | Cons (x, _, l) -> Huniv.cons x (hcons l)
+
+  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 pr_uni = function
-  | Atom u ->
-      pr_uni_level u
-  | Max ([],[u]) ->
-      str "(" ++ pr_uni_level u ++ str ")+1"
-  | Max (gel,gtl) ->
+  let pr_with f l = match l with
+    | Cons (u, _, Nil) -> Expr.pr_with f u
+    | _ -> 
       str "max(" ++ hov 0
-       (prlist_with_sep pr_comma pr_uni_level gel ++
-	  (if gel <> [] & gtl <> [] then pr_comma () else mt ()) ++
-	prlist_with_sep pr_comma
-	  (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++
-      str ")"
-
-(* Returns the formal universe that lies juste above the universe variable u.
-   Used to type the sort u. *)
-let super = function
-  | Atom u ->
-      Max ([],[u])
-  | Max _ ->
-      anomaly ("Cannot take the successor of a non variable universe:\n"^
-               "(maybe a bugged tactic)")
-
-(* Returns the formal universe that is greater than the universes u and v.
-   Used to type the products. *)
-let sup u v =
-  match u,v with
-    | Atom u, Atom v ->
-	if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[])
-    | u, Max ([],[]) -> u
-    | Max ([],[]), v -> v
-    | Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
-    | Max (gel,gtl), Atom v -> Max (list_add_set v gel,gtl)
-    | Max (gel,gtl), Max (gel',gtl') ->
-	let gel'' = list_union gel gel' in
-	let gtl'' = list_union gtl gtl' in
-	Max (list_subtract gel'' gtl'',gtl'')
+	(prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++
+        str ")"
 
-(* Comparison on this type is pointer equality *)
-type canonical_arc =
-    { univ: UniverseLevel.t;
-      lt: UniverseLevel.t list;
-      le: UniverseLevel.t list;
-      rank: int }
+  let is_level l = match l with
+    | Cons (l, _, Nil) -> Expr.is_level l
+    | _ -> false
 
-let terminal u = {univ=u; lt=[]; le=[]; rank=0}
+  let level l = match l with
+    | Cons (l, _, Nil) -> Expr.level l
+    | _ -> None
 
-(* A UniverseLevel.t is either an alias for another one, or a canonical one,
-   for which we know the universes that are above *)
+  let levels l = 
+    fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty
 
-type univ_entry =
-    Canonical of canonical_arc
-  | Equiv of UniverseLevel.t
+  let is_small u = 
+    match u with
+    | Cons (l, _, Nil) -> Expr.is_small l
+    | _ -> false
 
+  (* The lower predicative level of the hierarchy that contains (impredicative)
+     Prop and singleton inductive types *)
+  let type0m = tip Expr.prop
 
-type universes = univ_entry UniverseLMap.t
+  (* The level of sets *)
+  let type0 = tip Expr.set
 
-let enter_equiv_arc u v g =
-  UniverseLMap.add u (Equiv v) g
+  (* 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 enter_arc ca g =
-  UniverseLMap.add ca.univ (Canonical ca) g
+  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 = 
+    if is_small l then type1
+    else
+      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
 
-(* The lower predicative level of the hierarchy that contains (impredicative)
-   Prop and singleton inductive types *)
-let type0m_univ = Max ([],[])
+end
 
-let is_type0m_univ = function
-  | Max ([],[]) -> true
-  | _ -> false
+type universe = Universe.t
 
 (* The level of predicative Set *)
-let type0_univ = Atom UniverseLevel.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 is_small_univ = Universe.is_small
+let pr_uni = Universe.pr
 
-let is_type0_univ = function
-  | Atom UniverseLevel.Set -> true
-  | Max ([UniverseLevel.Set], []) -> msg_warn "Non canonical Set"; true
-  | u -> false
+let sup = Universe.sup
+let super = Universe.super
 
-let is_univ_variable = function
-  | Atom a when a<>UniverseLevel.Set -> true
-  | _ -> false
+open Universe
 
-(* When typing [Prop] and [Set], there is no constraint on the level,
-   hence the definition of [type1_univ], the type of [Prop] *)
+let universe_level = Universe.level
 
-let type1_univ = Max ([], [UniverseLevel.Set])
+type status = Unset | SetLe | SetLt
 
-let initial_universes = UniverseLMap.empty
-let is_initial_universes = UniverseLMap.is_empty
+(* 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;
+      mutable status : status;
+      (** Guaranteed to be unset out of the [compare_neq] functions. It is used
+          to do an imperative traversal of the graph, ensuring a O(1) check that
+          a node has already been visited. Quite performance critical indeed. *)
+    }
+
+let arc_is_le arc = match arc.status with
+| Unset -> false
+| SetLe | SetLt -> true
+
+let arc_is_lt arc = match arc.status with
+| Unset | SetLe -> false
+| SetLt -> true
+
+let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false; status = Unset}
+
+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 equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+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 *)
 
-(* Every UniverseLevel.t has a unique canonical arc representative *)
+type univ_entry =
+    Canonical of canonical_arc
+  | Equiv of Level.t
+
+type universes = univ_entry UMap.t
+
+(** Used to cleanup universes if a traversal function is interrupted before it
+    has the opportunity to do it itself. *)
+let unsafe_cleanup_universes g =
+  let iter _ arc = match arc with
+  | Equiv _ -> ()
+  | Canonical arc -> arc.status <- Unset
+  in
+  UMap.iter iter g
+
+let rec cleanup_universes g =
+  try unsafe_cleanup_universes g
+  with e ->
+    (** The only way unsafe_cleanup_universes may raise an exception is when
+        a serious error (stack overflow, out of memory) occurs, or a signal is
+        sent. In this unlikely event, we relaunch the cleanup until we finally
+        succeed. *)
+    cleanup_universes g; raise e
+
+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
 
-(* repr : universes -> UniverseLevel.t -> canonical_arc *)
+(* 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 UniverseLMap.find u g
-      with Not_found -> anomalylabstrm "Univ.repr"
-	  (str"Universe " ++ pr_uni_level u ++ str" undefined")
+      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
@@ -194,14 +727,12 @@ let repr g u =
   in
   repr_rec u
 
-let can g = List.map (repr g)
-
 (* [safe_repr] also search for the canonical representative, but
    if the graph doesn't contain the searched universe, we add it. *)
 
 let safe_repr g u =
   let rec safe_repr_rec u =
-    match UniverseLMap.find u g with
+    match UMap.find u g with
       | Equiv v -> safe_repr_rec v
       | Canonical arc -> arc
   in
@@ -225,8 +756,8 @@ let reprleq g arcu =
   searchrec [] arcu.le
 
 
-(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *)
-(* between u v = {w|u<=w<=v, w canonical}          *)
+(* 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 =
@@ -258,10 +789,20 @@ let between g arcu arcv =
    Otherwise, between g u v = []
  *)
 
+type constraint_type = Lt | Le | Eq
+
+type explanation = (constraint_type * universe) list
 
-type order = EQ | LT | LE | NLE
+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] ?
+(** [fast_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.
@@ -279,46 +820,179 @@ type order = EQ | LT | LE | NLE
   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.
+
+  We do the traversal imperatively, setting the [status] flag on visited nodes.
+  This ensures O(1) check, but it also requires unsetting the flag when leaving
+  the function. Some special care has to be taken in order to ensure we do not
+  recover a messed up graph at the end. This occurs in particular when the
+  traversal raises an exception. Even though the code below is exception-free,
+  OCaml may still raise random exceptions, essentially fatal exceptions or
+  signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note
+  also that the use of an imperative solution does make this function
+  thread-unsafe. For now we do not check universes in different threads, but if
+  ever this is to be done, we would need some lock somewhere.
+
 *)
 
-let compare_neq strict g arcu arcv =
-  let rec cmp c lt_done le_done = function
-  | [],[] -> c
+let get_explanation strict g arcu arcv =
+  (* [c] characterizes whether (and how) arcv has already been related
+     to arcu among the lt_done,le_done universe *)
+  let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with
+  | [],[] -> (to_revert, c)
+  | (arc,p)::lt_todo, le_todo ->
+    if arc_is_lt arc then
+      cmp c to_revert lt_todo le_todo
+    else
+      let rec find lt_todo lt le = match le with
+      | [] ->
+        begin match lt with
+        | [] ->
+          let () = arc.status <- SetLt in
+          cmp c (arc :: to_revert) lt_todo le_todo
+        | u :: lt ->
+          let arc = repr g u in
+          let p = (Lt, make u) :: p in
+          if arc == arcv then
+            if strict then (to_revert, p) else (to_revert, p)
+          else find ((arc, p) :: lt_todo) lt le
+        end
+      | u :: le ->
+        let arc = repr g u in
+        let p = (Le, make u) :: p in
+        if arc == arcv then
+          if strict then (to_revert, p) else (to_revert, p)
+        else find ((arc, p) :: lt_todo) lt le
+      in
+      find lt_todo arc.lt arc.le
+  | [], (arc,p)::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 p to_revert [] le_todo else (to_revert, p)
+    else
+      if arc_is_le arc then
+        cmp c to_revert [] le_todo
+      else
+        let rec find lt_todo lt = match lt with
+        | [] ->
+          let fold accu u =
+            let p = (Le, make u) :: p in
+            let node = (repr g u, p) in
+            node :: accu
+          in
+          let le_new = List.fold_left fold le_todo arc.le in
+          let () = arc.status <- SetLe in
+          cmp c (arc :: to_revert) lt_todo le_new
+        | u :: lt ->
+          let arc = repr g u in
+          let p = (Lt, make u) :: p in
+          if arc == arcv then
+            if strict then (to_revert, p) else (to_revert, p)
+          else find ((arc, p) :: lt_todo) lt
+        in
+        find [] arc.lt
+  in
+  try
+    let (to_revert, c) = cmp [] [] [] [(arcu, [])] in
+    (** Reset all the touched arcs. *)
+    let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+    List.rev c
+  with e ->
+    (** Unlikely event: fatal error or signal *)
+    let () = cleanup_universes g in
+    raise e
+
+let get_explanation strict g arcu arcv =
+  if !Flags.univ_print then Some (get_explanation strict g arcu arcv)
+  else None
+
+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 to_revert lt_todo le_todo = match lt_todo, le_todo with
+  | [],[] -> (to_revert, c)
   | arc::lt_todo, le_todo ->
-    if List.memq arc lt_done then
-      cmp c lt_done le_done (lt_todo,le_todo)
+    if arc_is_lt arc then
+      cmp c to_revert lt_todo le_todo
     else
-      let lt_new = can g (arc.lt@arc.le) in
-      if List.memq arcv lt_new then
-	if strict then LT else LE
-      else cmp c (arc::lt_done) le_done (lt_new@lt_todo,le_todo)
+      let rec find lt_todo lt le = match le with
+      | [] ->
+        begin match lt with
+        | [] ->
+          let () = arc.status <- SetLt in
+          cmp c (arc :: to_revert) lt_todo le_todo
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then (to_revert, FastLT) else (to_revert, FastLE)
+          else find (arc :: lt_todo) lt le
+        end
+      | u :: le ->
+        let arc = repr g u in
+        if arc == arcv then
+          if strict then (to_revert, FastLT) else (to_revert, 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 LE lt_done le_done ([],le_todo) else LE
+      if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE)
     else
-      if (List.memq arc lt_done) || (List.memq arc le_done) then
-	cmp c lt_done le_done ([],le_todo)
+      if arc_is_le arc then
+        cmp c to_revert [] le_todo
       else
-	let lt_new = can g arc.lt in
-	if List.memq arcv lt_new then
-	  if strict then LT else LE
-	else
-	  let le_new = can g arc.le in
-	  cmp c lt_done (arc::le_done) (lt_new, le_new@le_todo)
+        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
+          let () = arc.status <- SetLe in
+          cmp c (arc :: to_revert) lt_todo le_new
+        | u :: lt ->
+          let arc = repr g u in
+          if arc == arcv then
+            if strict then (to_revert, FastLT) else (to_revert, FastLE)
+          else find (arc :: lt_todo) lt
+        in
+        find [] arc.lt
   in
-  cmp NLE [] [] ([],[arcu])
+  try
+    let (to_revert, c) = cmp FastNLE [] [] [arcu] in
+    (** Reset all the touched arcs. *)
+    let () = List.iter (fun arc -> arc.status <- Unset) to_revert in
+    c
+  with e ->
+    (** Unlikely event: fatal error or signal *)
+    let () = cleanup_universes g in
+    raise e
 
-let compare g arcu arcv =
-  if arcu == arcv then EQ else compare_neq true g arcu arcv
+let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv
 
-let is_leq g arcu arcv =
-  arcu == arcv || (compare_neq false g arcu arcv = LE)
+let fast_compare g arcu arcv =
+  if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv
 
-let is_lt g arcu arcv = (compare g arcu arcv = LT)
+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
@@ -329,60 +1003,84 @@ let is_lt g arcu arcv = (compare g arcu arcv = LT)
    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_geq], used in coqchk *)
+(** * Universe checks [check_eq] and [check_leq], used in coqchk *)
+
+(** First, checks on universe levels *)
 
-let compare_eq g u v =
+let check_equal g u v =
   let g, arcu = safe_repr g u in
   let _, arcv = safe_repr g v in
   arcu == arcv
 
-type check_function = universes -> universe -> universe -> bool
+let check_eq_level g u v = u == v || check_equal g u v
 
-let incl_list cmp l1 l2 =
-  List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1
+let is_set_arc u = Level.is_set u.univ
+let is_prop_arc u = Level.is_prop u.univ
+let get_prop_arc g = snd (safe_repr g Level.prop)
 
-let compare_list cmp l1 l2 =
-  incl_list cmp l1 l2 && incl_list cmp l2 l1
-
-let rec check_eq g u v =
-  match (u,v) with
-    | Atom ul, Atom vl -> compare_eq g ul vl
-    | Max(ule,ult), Max(vle,vlt) ->
-        (* TODO: remove elements of lt in le! *)
-        compare_list (compare_eq g) ule vle &&
-        compare_list (compare_eq g) ult vlt
-    | _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
-
-let compare_greater g strict u v =
+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 arcv arcu
+    is_lt g arcu arcv
   else
-    arcv == snd (safe_repr g UniverseLevel.Set) || is_leq g arcv arcu
-
-(*
-let compare_greater g strict u v =
-  let b = compare_greater g strict u v in
-  ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
-  b
-*)
-let check_geq g u v =
-  match u, v with
-    | Atom ul, Atom vl -> compare_greater g false ul vl
-    | Atom ul, Max(le,lt) ->
-        List.for_all (fun vl -> compare_greater g false ul vl) le &&
-        List.for_all (fun vl -> compare_greater g true ul vl) lt
-    | _ -> anomaly "check_greater"
+    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] *)
 
-(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(** 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
-  enter_arc arcu' g, arcu'
+  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 =
@@ -390,13 +1088,17 @@ let setlt_if (g,arcu) v =
   if is_lt g arcu arcv then g, arcu
   else setlt g arcu arcv
 
-(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* 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
-  enter_arc arcu' g, arcu'
-
+  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 =
@@ -404,32 +1106,32 @@ let setleq_if (g,arcu) v =
   if is_leq g arcu arcv then g, arcu
   else setleq g arcu arcv
 
-(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* 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 arc.rank >= max_rank
+      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 "Univ.between"
+      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
+          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')
+    (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
@@ -437,13 +1139,13 @@ let merge g arcu arcv =
   let g_arcu = List.fold_left setleq_if g_arcu w' in
   fst g_arcu
 
-(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *)
+(* 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 arc1.rank <> arc2.rank then 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
@@ -457,107 +1159,241 @@ let merge_disc g arc1 arc2 =
 (* Universe inconsistency: error raised when trying to enforce a relation
    that would create a cycle in the graph of universes. *)
 
-type constraint_type = Lt | Le | Eq
+type univ_inconsistency = constraint_type * universe * universe * explanation option
 
-exception UniverseInconsistency of constraint_type * universe * universe
+exception UniverseInconsistency of univ_inconsistency
 
-let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v))
+let error_inconsistency o u v (p:explanation option) =
+  raise (UniverseInconsistency (o,make u,make v,p))
+
+(* enforc_univ_eq : Level.t -> Level.t -> unit *)
+(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
 
-(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *)
+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 ->
+      let p = get_explanation_strict g arcu arcv in
+      error_inconsistency Eq v u p
+    | FastLE -> merge g arcu arcv
+    | FastNLE ->
+      (match fast_compare g arcv arcu with
+      | FastLT ->
+        let p = get_explanation_strict g arcv arcu in
+        error_inconsistency Eq u v p
+      | 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 compare g arcv arcu with
-    | LT -> error_inconsistency Le u v
-    | LE -> merge g arcv arcu
-    | NLE -> fst (setleq g arcu arcv)
-    | EQ -> anomaly "Univ.compare"
-
-(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
-(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
-let enforce_univ_eq u v g =
-  let g,arcu = safe_repr g u in
-  let g,arcv = safe_repr g v in
-  match compare g arcu arcv with
-    | EQ -> g
-    | LT -> error_inconsistency Eq u v
-    | LE -> merge g arcu arcv
-    | NLE ->
-	(match compare g arcv arcu with
-           | LT -> error_inconsistency Eq u v
-           | LE -> merge g arcv arcu
-           | NLE -> merge_disc g arcu arcv
-           | EQ -> anomaly "Univ.compare")
+  else
+    match fast_compare g arcv arcu with
+    | FastLT ->
+      let p = get_explanation_strict g arcv arcu in
+      error_inconsistency Le u v p
+    | 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 compare g arcu arcv with
-    | LT -> g
-    | LE -> fst (setlt g arcu arcv)
-    | EQ -> error_inconsistency Lt u v
-    | NLE ->
-      if is_leq g arcv arcu then error_inconsistency Lt u v
-      else fst (setlt g arcu arcv)
-
-(* Constraints and sets of consrtaints. *)
-
-type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t
+    match fast_compare g arcu arcv with
+    | FastLT -> g
+    | FastLE -> fst (setlt g arcu arcv)
+    | FastEQ -> error_inconsistency Lt u v (Some [(Eq,make 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) ->
+        let p = get_explanation false g arcv arcu  in
+        error_inconsistency Lt u v p
+
+let empty_universes = UMap.empty
+
+(* Prop = Set is forbidden here. *)
+let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty
+
+let is_initial_universes g = UMap.equal (==) g initial_universes
+
+let add_universe vlev g = 
+  let v = terminal vlev in
+  let proparc = get_prop_arc g in
+    enter_arc {proparc with le=vlev::proparc.le}
+      (enter_arc v g)
+      
+(* 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
+      
+let pr_constraint_type op = 
+  let op_str = match op with
+    | Lt -> " < "
+    | Le -> " <= "
+    | Eq -> " = "
+  in str op_str
+
+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(
-  struct
-    type t = univ_constraint
-    let compare (u,c,v) (u',c',v') =
-      let i = Pervasives.compare c c' in
-      if i <> 0 then i
-      else
-	let i' = UniverseLevel.compare u u' in
-	if i' <> 0 then i'
-	else UniverseLevel.compare v v'
-  end)
+module Constraint = 
+struct 
+  module S = Set.Make(UConstraintOrd)
+  include S
 
-type constraints = Constraint.t
+  let pr prl c =
+    fold (fun (u1,op,u2) pp_std ->
+      pp_std ++ prl u1 ++ pr_constraint_type op ++
+	prl u2 ++ fnl () )  c (str "")
+
+end
 
 let empty_constraint = Constraint.empty
-let is_empty_constraint = Constraint.is_empty
+let union_constraint = Constraint.union
+let eq_constraint = Constraint.equal
+let merge_constraints c g =
+  Constraint.fold enforce_constraint c g
 
-let union_constraints = Constraint.union
+type constraints = Constraint.t
 
-type constraint_function =
-    universe -> universe -> constraints -> constraints
+module Hconstraint =
+  Hashcons.Make(
+    struct
+      type t = univ_constraint
+      type u = universe_level -> universe_level
+      let hashcons hul (l1,k,l2) = (hul l1, k, hul l2)
+      let equal (l1,k,l2) (l1',k',l2') =
+	l1 == l1' && k == k' && l2 == l2'
+      let hash = Hashtbl.hash
+    end)
 
-let constraint_add_leq v u c =
-  if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c
+module Hconstraints =
+  Hashcons.Make(
+    struct
+      type t = constraints
+      type u = univ_constraint -> univ_constraint
+      let hashcons huc s =
+	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
+      let equal s s' =
+	List.for_all2eq (==)
+	  (Constraint.elements s)
+	  (Constraint.elements s')
+      let hash = Hashtbl.hash
+    end)
+
+let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Hconstraint.hcons Level.hcons
+let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate Hconstraints.hcons hcons_constraint
+
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
+
+let constraints_of (_, cst) = cst
 
-let enforce_geq u v c =
-  match u, v with
-  | Atom u, Atom v -> constraint_add_leq v u c
-  | Atom u, Max (gel,gtl) ->
-      let d = List.fold_right (fun v -> constraint_add_leq v u) gel c in
-      List.fold_right (fun v -> Constraint.add (v,Lt,u)) gtl d
-  | _ -> anomaly "A universe bound can only be a variable"
+(** Constraint functions. *)
+
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+let enforce_eq_level u v c =
+  (* We discard trivial constraints like u=u *)
+  if Level.equal u v then c 
+  else if Level.apart u v then
+    error_inconsistency Eq u v None
+  else Constraint.add (u,Eq,v) c
 
 let enforce_eq u v c =
-  match (u,v) with
-    | Atom u, Atom v -> Constraint.add (u,Eq,v) c
-    | _ -> anomaly "A universe comparison can only happen between variables"
+  match Universe.level u, Universe.level v with
+    | Some u, Some v -> enforce_eq_level u v c
+    | _ -> anomaly (Pp.str "A universe comparison can only happen between variables")
 
-let merge_constraints c g =
-  Constraint.fold enforce_constraint c g
+let check_univ_eq u v = Universe.equal u v
+
+let enforce_eq u v c =
+  if check_univ_eq u v then c
+  else enforce_eq u v c
+
+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, None))
+	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 =
+  let open Universe.Huniv in
+  match v with
+  | Cons (v, _, Nil) ->
+    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 enforce_leq_level u v c =
+  if Level.equal u v then c else Constraint.add (u,Le,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
+
+let enforce_univ_constraint (u,d,v) =
+  match d with
+  | Eq -> enforce_eq u v
+  | Le -> enforce_leq u v
+  | Lt -> enforce_leq (super u) v
 
 (* Normalization *)
 
 let lookup_level u g =
-  try Some (UniverseLMap.find u g) with Not_found -> None
+  try Some (UMap.find u g) with Not_found -> None
 
 (** [normalize_universes g] returns a graph where all edges point
     directly to the canonical representent of their target. The output
@@ -571,20 +1407,20 @@ let normalize_universes g =
     | Some x -> x, cache
     | None -> match Lazy.force arc with
     | None ->
-      u, UniverseLMap.add u u cache
+      u, UMap.add u u cache
     | Some (Canonical {univ=v; lt=_; le=_}) ->
-      v, UniverseLMap.add u v cache
+      v, UMap.add u v cache
     | Some (Equiv v) ->
       let v, cache = visit v (lazy (lookup_level v g)) cache in
-      v, UniverseLMap.add u v cache
+      v, UMap.add u v cache
   in
-  let cache = UniverseLMap.fold
+  let cache = UMap.fold
     (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
-    g UniverseLMap.empty
+    g UMap.empty
   in
-  let repr x = UniverseLMap.find x cache in
+  let repr x = UMap.find x cache in
   let lrepr us = List.fold_left
-    (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us
+    (fun e x -> LSet.add (repr x) e) LSet.empty us
   in
   let canonicalize u = function
     | Equiv _ -> Equiv (repr u)
@@ -592,355 +1428,674 @@ let normalize_universes g =
       assert (u == v);
       (* avoid duplicates and self-loops *)
       let lt = lrepr lt and le = lrepr le in
-      let le = UniverseLSet.filter
-        (fun x -> x != u && not (UniverseLSet.mem x lt)) le
+      let le = LSet.filter
+        (fun x -> x != u && not (LSet.mem x lt)) le
       in
-      UniverseLSet.iter (fun x -> assert (x != u)) lt;
+      LSet.iter (fun x -> assert (x != u)) lt;
       Canonical {
         univ = v;
-        lt = UniverseLSet.elements lt;
-        le = UniverseLSet.elements le;
-	rank = rank
+        lt = LSet.elements lt;
+        le = LSet.elements le;
+	rank = rank;
+	predicative = false;
+	status = Unset;
       }
   in
-  UniverseLMap.mapi canonicalize g
-
-(** [check_sorted g sorted]: [g] being a universe graph, [sorted]
-    being a map to levels, checks that all constraints in [g] are
-    satisfied in [sorted]. *)
-let check_sorted g sorted =
-  let get u = try UniverseLMap.find u sorted with
-    | Not_found -> assert false
-  in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with
-    | Equiv v -> assert (lu = get v)
-    | Canonical {univ=u'; lt=lt; le=le} ->
-      assert (u == u');
-      List.iter (fun v -> assert (lu <= get v)) le;
-      List.iter (fun v -> assert (lu < get v)) lt) g
-
-(**
-  Bellman-Ford algorithm with a few customizations:
-    - [weight(eq|le) = 0], [weight(lt) = -1]
-    - a [le] edge is initially added from [bottom] to all other
-      vertices, and [bottom] is used as the source vertex
-*)
-let bellman_ford bottom g =
-  assert (lookup_level bottom g = None);
-  let ( << ) a b = match a, b with
-    | _, None -> true
-    | None, _ -> false
-    | Some x, Some y -> x < y
-  and ( ++ ) a y = match a with
-    | None -> None
-    | Some x -> Some (x-y)
-  and push u x m = match x with
-    | None -> m
-    | Some y -> UniverseLMap.add u y m
+  UMap.mapi canonicalize g
+
+let constraints_of_universes g =
+  let constraints_of u v acc =
+    match v with
+    | Canonical {univ=u; lt=lt; le=le} ->
+      let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in
+      let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in
+	acc
+    | Equiv v -> Constraint.add (u,Eq,v) acc
   in
-  let relax u v uv distances =
-    let x = lookup_level u distances ++ uv in
-    if x << lookup_level v distances then push v x distances
-    else distances
+  UMap.fold constraints_of g Constraint.empty
+
+let constraints_of_universes g =
+  constraints_of_universes (normalize_universes g)
+
+(** Longest path algorithm. This is used to compute the minimal number of
+    universes required if the only strict edge would be the Lt one. This
+    algorithm assumes that the given universes constraints are a almost DAG, in
+    the sense that there may be {Eq, Le}-cycles. This is OK for consistent
+    universes, which is the only case where we use this algorithm. *)
+
+(** Adjacency graph *)
+type graph = constraint_type LMap.t LMap.t
+
+exception Connected
+
+(** Check connectedness *)
+let connected x y (g : graph) =
+  let rec connected x target seen g =
+    if Level.equal x target then raise Connected
+    else if not (LSet.mem x seen) then
+      let seen = LSet.add x seen in
+      let fold z _ seen = connected z target seen g in
+      let neighbours = try LMap.find x g with Not_found -> LMap.empty in
+      LMap.fold fold neighbours seen
+    else seen
   in
-  let init = UniverseLMap.add bottom 0 UniverseLMap.empty in
-  let vertices = UniverseLMap.fold (fun u arc res ->
-    let res = UniverseLSet.add u res in
-    match arc with
-      | Equiv e -> UniverseLSet.add e res
-      | Canonical {univ=univ; lt=lt; le=le} ->
-        assert (u == univ);
-        let add res v = UniverseLSet.add v res in
-        let res = List.fold_left add res le in
-        let res = List.fold_left add res lt in
-        res) g UniverseLSet.empty
+  try ignore(connected x y LSet.empty g); false with Connected -> true
+
+let add_edge x y v (g : graph) =
+  try
+    let neighbours = LMap.find x g in
+    let neighbours = LMap.add y v neighbours in
+    LMap.add x neighbours g
+  with Not_found ->
+    LMap.add x (LMap.singleton y v) g
+
+(** We want to keep the graph DAG. If adding an edge would cause a cycle, that
+    would necessarily be an {Eq, Le}-cycle, otherwise there would have been a
+    universe inconsistency. Therefore we may omit adding such a cycling edge
+    without changing the compacted graph. *)
+let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g
+
+(** Construct the DAG and its inverse at the same time. *)
+let make_graph g : (graph * graph) =
+  let fold u arc accu = match arc with
+  | Equiv v ->
+    let (dir, rev) = accu in
+    (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev)
+  | Canonical { univ; lt; le; } ->
+    let () = assert (u == univ) in
+    let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in
+    let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in
+    (** Order is important : lt after le, because of the possible redundancy
+        between [le] and [lt] in a canonical arc. This way, the [lt] constraint
+        is the last one set, which is correct because it implies [le]. *)
+    let accu = List.fold_left fold_le accu le in
+    let accu = List.fold_left fold_lt accu lt in
+    accu
   in
-  let g =
-    let node = Canonical {
-      univ = bottom;
-      lt = [];
-      le = UniverseLSet.elements vertices;
-      rank = 0
-    } in UniverseLMap.add bottom node g
+  UMap.fold fold g (LMap.empty, LMap.empty)
+
+(** Construct a topological order out of a DAG. *)
+let rec topological_fold u g rem seen accu =
+  let is_seen =
+    try
+      let status = LMap.find u seen in
+      assert status; (** If false, not a DAG! *)
+      true
+    with Not_found -> false
   in
-  let rec iter count accu =
-    if count <= 0 then
-      accu
-    else
-      let accu = UniverseLMap.fold (fun u arc res -> match arc with
-        | Equiv e -> relax e u 0 (relax u e 0 res)
-        | Canonical {univ=univ; lt=lt; le=le} ->
-          assert (u == univ);
-          let res = List.fold_left (fun res v -> relax u v 0 res) res le in
-          let res = List.fold_left (fun res v -> relax u v 1 res) res lt in
-          res) g accu
-      in iter (count-1) accu
+  if not is_seen then
+    let rem = LMap.remove u rem in
+    let seen = LMap.add u false seen in
+    let neighbours = try LMap.find u g with Not_found -> LMap.empty in
+    let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in
+    let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in
+    (rem, LMap.add u true seen, u :: accu)
+  else (rem, seen, accu)
+
+let rec topological g rem seen accu =
+  let node = try Some (LMap.choose rem) with Not_found -> None in
+  match node with
+  | None -> accu
+  | Some (u, _) ->
+    let rem, seen, accu = topological_fold u g rem seen accu in
+    topological g rem seen accu
+
+(** Compute the longest path from any vertex. *)
+let constraint_cost = function
+| Eq | Le -> 0
+| Lt -> 1
+
+(** This algorithm browses the graph in topological order, computing for each
+    encountered node the length of the longest path leading to it. Should be
+    O(|V|) or so (modulo map representation). *)
+let rec flatten_graph rem (rev : graph) map mx = match rem with
+| [] -> map, mx
+| u :: rem ->
+  let prev = try LMap.find u rev with Not_found -> LMap.empty in
+  let fold v cstr accu =
+    let v_cost = LMap.find v map in
+    max (v_cost + constraint_cost cstr) accu
   in
-  let distances = iter (UniverseLSet.cardinal vertices) init in
-  let () = UniverseLMap.iter (fun u arc ->
-    let lu = lookup_level u distances in match arc with
-      | Equiv v ->
-        let lv = lookup_level v distances in
-        assert (not (lu << lv) && not (lv << lu))
-      | Canonical {univ=univ; lt=lt; le=le} ->
-        assert (u == univ);
-        List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le;
-        List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g
-  in distances
+  let u_cost = LMap.fold fold prev 0 in
+  let map = LMap.add u u_cost map in
+  flatten_graph rem rev map (max mx u_cost)
 
 (** [sort_universes g] builds a map from universes in [g] to natural
     numbers. It outputs a graph containing equivalence edges from each
     level appearing in [g] to [Type.n], and [lt] edges between the
     [Type.n]s. The output graph should imply the input graph (and the
+    [Type.n]s. The output graph should imply the input graph (and the
     implication will be strict most of the time), but is not
     necessarily minimal. Note: the result is unspecified if the input
     graph already contains [Type.n] nodes (calling a module Type is
     probably a bad idea anyway). *)
 let sort_universes orig =
-  let mp = Names.make_dirpath [Names.id_of_string "Type"] in
-  let rec make_level accu g i =
-    let type0 = UniverseLevel.Level (mp, i) in
-    let distances = bellman_ford type0 g in
-    let accu, continue = UniverseLMap.fold (fun u x (accu, continue) ->
-      let continue = continue || x < 0 in
-      let accu =
-        if x = 0 && u != type0 then UniverseLMap.add u i accu
-        else accu
-      in accu, continue) distances (accu, false)
-    in
-    let filter x = not (UniverseLMap.mem x accu) in
-    let push g u =
-      if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g
-    in
-    let g = UniverseLMap.fold (fun u arc res -> match arc with
-      | Equiv v as x ->
-        begin match filter u, filter v with
-          | true, true -> UniverseLMap.add u x res
-          | true, false -> push res u
-          | false, true -> push res v
-          | false, false -> res
-        end
-      | Canonical {univ=v; lt=lt; le=le; rank=r} ->
-        assert (u == v);
-        if filter u then
-          let lt = List.filter filter lt in
-          let le = List.filter filter le in
-          UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res
-        else
-          let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
-          let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
-          res) g UniverseLMap.empty
-    in
-    if continue then make_level accu g (i+1) else i, accu
+  let (dir, rev) = make_graph orig in
+  let order = topological dir dir LMap.empty [] in
+  let compact, max = flatten_graph order rev LMap.empty 0 in
+  let mp = Names.DirPath.make [Names.Id.of_string "Type"] in
+  let types = Array.init (max + 1) (fun n -> Level.make mp n) in
+  (** Old universes are made equal to [Type.n] *)
+  let fold u level accu = UMap.add u (Equiv types.(level)) accu in
+  let sorted = LMap.fold fold compact UMap.empty in
+  (** Add all [Type.n] nodes *)
+  let fold i accu u =
+    if 0 < i then
+      let pred = types.(i - 1) in
+      let arc = {univ = u; lt = [pred]; le = []; rank = 0; predicative = false; status = Unset; } in
+      UMap.add u (Canonical arc) accu
+    else accu
   in
-  let max, levels = make_level UniverseLMap.empty orig 0 in
-  (* defensively check that the result makes sense *)
-  check_sorted orig levels;
-  let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
-  let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
-  let g =
-    let rec aux i g =
-      if i < max then
-        let u = types.(i) in
-        let g = UniverseLMap.add u (Canonical {
-          univ = u;
-          le = [];
-          lt = [types.(i+1)];
-	  rank = 1
-        }) g in aux (i+1) g
-      else g
-    in aux 0 g
-  in g
+  Array.fold_left_i fold sorted types
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur in a universe *)
+
+let univ_level_mem u v = Huniv.mem (Expr.make u) v
+
+let univ_level_rem u v min = 
+  match Universe.level v with
+  | Some u' -> if Level.equal u u' then min else v
+  | None -> Huniv.remove (Universe.Expr.make u) v
 
+(* Is u mentionned in v (or equals to v) ? *)
+
+
+(**********************************************************************)
+(** Universe polymorphism                                             *)
 (**********************************************************************)
-(* Tools for sort-polymorphic inductive types                         *)
 
-(* Temporary inductive type levels *)
+(** A universe level substitution, note that no algebraic universes are
+    involved *)
 
-let fresh_level =
-  let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n)
+type universe_level_subst = universe_level universe_map
 
-let fresh_local_univ () = Atom (fresh_level ())
+(** A full substitution might involve algebraic universes *)
+type universe_subst = universe universe_map
 
-(* Miscellaneous functions to remove or test local univ assumed to
-   occur only in the le constraints *)
+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 of_array : Level.t array -> t
+    val to_array : t -> Level.t array
 
-let make_max = function
-  | ([u],[]) -> Atom u
-  | (le,lt) -> Max (le,lt)
+    val append : t -> t -> t
+    val equal : t -> t -> bool
+    val length : t -> int
 
-let remove_large_constraint u = function
-  | Atom u' as x -> if u = u' then Max ([],[]) else x
-  | Max (le,lt) -> make_max (list_remove u le,lt)
+    val hcons : t -> t
+    val hash : t -> int
 
-let is_direct_constraint u = function
-  | Atom u' -> u = u'
-  | Max (le,lt) -> List.mem u le
+    val share : t -> t * int
 
-(*
-   Solve a system of universe constraint of the form
+    val subst_fn : universe_level_subst_fn -> t -> t
+    
+    val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+    val levels : t -> LSet.t
+    val check_eq : t check_function 
+end = 
+struct
+  type t = Level.t array
 
-   u_s11, ..., u_s1p1, w1 <= u1
-   ...
-   u_sn1, ..., u_snpn, wn <= un
+  let empty : t = [||]
 
-where
+  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 hash = HInstancestruct.hash
+    
+  let share a = (hcons a, hash a)
+	      
+  let empty = hcons [||]
+
+  let is_empty x = Int.equal (Array.length x) 0
+
+  let append x y =
+    if Array.length x = 0 then y
+    else if Array.length y = 0 then x 
+    else Array.append x y
+
+  let of_array a = a
+
+  let to_array a = a
+
+  let length a = Array.length a
+
+  let subst_fn fn t = 
+    let t' = CArray.smartmap fn t in
+      if t' == t then t else t'
+
+  let levels x = LSet.of_array x
+
+  let pr =
+    prvect_with_sep spc
+
+  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)
 
-  - the ui (1 <= i <= n) are universe variables,
-  - the sjk select subsets of the ui for each equations,
-  - the wi are arbitrary complex universes that do not mention the ui.
+end
+
+let enforce_eq_instances x y = 
+  let ax = Instance.to_array x and ay = Instance.to_array y in
+    if Array.length ax != Array.length ay then
+      anomaly (Pp.(++) (Pp.str "Invalid argument: enforce_eq_instances called with")
+		 (Pp.str " instances of different lengths"));
+    CArray.fold_right2 enforce_eq_level ax ay
+
+type universe_instance = Instance.t
+
+type 'a puniverses = 'a * Instance.t
+let out_punivs (x, y) = x
+let in_punivs x = (x, Instance.empty)
+let eq_puniverses f (x, u) (y, u') =
+  f x y && Instance.equal u u'
+
+(** A context of universe levels with universe constraints,
+    representiong local universe variables and constraints *)
+
+module UContext =
+struct
+  type t = Instance.t constrained
+
+  let make x = x
+
+  (** Universe contexts (variables as a list) *)
+  let empty = (Instance.empty, Constraint.empty)
+  let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst
+
+  let pr prl (univs, cst as ctx) =
+    if is_empty ctx then mt() else
+      Instance.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst)
+
+  let hcons (univs, cst) =
+    (Instance.hcons univs, hcons_constraints cst)
+
+  let instance (univs, cst) = univs
+  let constraints (univs, cst) = cst
+
+  let union (univs, cst) (univs', cst') =
+    Instance.append univs univs', Constraint.union cst cst'
+      
+  let dest x = x
+end
+
+type universe_context = UContext.t
+let hcons_universe_context = UContext.hcons
+
+(** A set of universes with universe constraints.
+    We linearize the set to a list after typechecking. 
+    Beware, representation could change.
 *)
 
-let is_direct_sort_constraint s v = match s with
-  | Some u -> is_direct_constraint u v
-  | None -> false
-
-let solve_constraints_system levels level_bounds =
-  let levels =
-    Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom"))
-      levels in
-  let v = Array.copy level_bounds in
-  let nind = Array.length v in
-  for i=0 to nind-1 do
-    for j=0 to nind-1 do
-      if i<>j & is_direct_sort_constraint levels.(j) v.(i) then
-	v.(i) <- sup v.(i) level_bounds.(j)
-    done;
-    for j=0 to nind-1 do
-      match levels.(j) with
-      | Some u -> v.(i) <- remove_large_constraint u v.(i)
-      | None -> ()
-    done
-  done;
-  v
-
-let subst_large_constraint u u' v =
-  match u with
-  | Atom u ->
-      if is_direct_constraint u v then sup u' (remove_large_constraint u v)
-      else v
-  | _ ->
-      anomaly "expect a universe level"
-
-let subst_large_constraints =
-  List.fold_right (fun (u,u') -> subst_large_constraint u u')
-
-let no_upper_constraints u cst =
-  match u with
-  | Atom u -> Constraint.for_all (fun (u1,_,_) -> u1 <> u) cst
-  | Max _ -> anomaly "no_upper_constraints"
+module ContextSet =
+struct
+  type t = universe_set constrained
 
-(* Is u mentionned in v (or equals to v) ? *)
+  let empty = (LSet.empty, Constraint.empty)
+  let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst
+
+  let of_set s = (s, Constraint.empty)
+  let singleton l = of_set (LSet.singleton l)
+  let of_instance i = of_set (Instance.levels i)
 
-let univ_depends u v =
-  match u, v with
-    | Atom u, Atom v -> u = v
-    | Atom u, Max (gel,gtl) -> List.mem u gel || List.mem u gtl
-    | _ -> anomaly "univ_depends given a non-atomic 1st arg"
+  let union (univs, cst as x) (univs', cst' as y) =
+    if x == y then x
+    else LSet.union univs univs', Constraint.union cst cst'
 
-(* Pretty-printing *)
+  let append (univs, cst) (univs', cst') =
+    let univs = LSet.fold LSet.add univs univs' in
+    let cst = Constraint.fold Constraint.add cst cst' in
+    (univs, cst)
 
-let pr_arc = function
+  let diff (univs, cst) (univs', cst') =
+    LSet.diff univs univs', Constraint.diff cst cst'
+
+  let add_universe u (univs, cst) =
+    LSet.add u univs, cst
+
+  let add_constraints cst' (univs, cst) =
+    univs, Constraint.union cst cst'
+
+  let add_instance inst (univs, cst) =
+    let v = Instance.to_array inst in
+    let fold accu u = LSet.add u accu in
+    let univs = Array.fold_left fold univs v in
+    (univs, cst)
+
+  let sort_levels a = 
+    Array.sort Level.natural_compare a; a
+
+  let to_context (ctx, cst) =
+    (Instance.of_array (sort_levels (Array.of_list (LSet.elements ctx))), cst)
+
+  let of_context (ctx, cst) =
+    (Instance.levels ctx, cst)
+
+  let pr prl (univs, cst as ctx) =
+    if is_empty ctx then mt() else
+      LSet.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst)
+
+  let constraints (univs, cst) = cst
+  let levels (univs, cst) = univs
+
+end
+
+type universe_context_set = ContextSet.t
+
+(** A value in a universe context (resp. context set). *)
+type 'a in_universe_context = 'a * universe_context
+type 'a in_universe_context_set = 'a * universe_context_set
+
+(** Substitutions. *)
+
+let empty_subst = LMap.empty
+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'
+
+let subst_univs_level_instance subst i =
+  let i' = Instance.subst_fn (subst_univs_level_level subst) i in
+    if i == i' then i
+    else i'
+	
+let subst_univs_level_constraint subst (u,d,v) =
+  let u' = subst_univs_level_level subst u 
+  and v' = subst_univs_level_level subst v in
+    if d != Lt && Level.equal u' v' then None
+    else Some (u',d,v')
+
+let subst_univs_level_constraints subst csts =
+  Constraint.fold 
+    (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c))
+    csts Constraint.empty 
+
+(** 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
+
+let subst_univs_level fn l = 
+  try Some (fn l)
+  with Not_found -> None
+
+let subst_univs_constraint fn (u,d,v as c) cstrs =
+  let u' = subst_univs_level fn u in
+  let v' = subst_univs_level fn v in
+  match u', v' with
+  | None, None -> Constraint.add c cstrs
+  | Some u, None -> enforce_univ_constraint (u,d,make v) cstrs
+  | None, Some v -> enforce_univ_constraint (make u,d,v) cstrs
+  | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs
+
+let subst_univs_constraints subst csts =
+  Constraint.fold 
+    (fun c cstrs -> subst_univs_constraint subst c cstrs)
+    csts Constraint.empty 
+
+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
+
+let make_instance_subst i = 
+  let arr = Instance.to_array i in
+    Array.fold_left_i (fun i acc l ->
+      LMap.add l (Level.var i) acc)
+      LMap.empty arr
+
+let make_inverse_instance_subst i = 
+  let arr = Instance.to_array i in
+    Array.fold_left_i (fun i acc l ->
+      LMap.add (Level.var i) l acc)
+      LMap.empty arr
+
+let abstract_universes poly ctx =
+  let instance = UContext.instance ctx in
+    if poly then
+      let subst = make_instance_subst instance in
+      let cstrs = subst_univs_level_constraints subst 
+	(UContext.constraints ctx)
+      in
+      let ctx = UContext.make (instance, cstrs) in
+	subst, ctx
+    else empty_level_subst, ctx
+
+(** Pretty-printing *)
+
+let pr_arc prl = function
   | _, Canonical {univ=u; lt=[]; le=[]} ->
       mt ()
   | _, Canonical {univ=u; lt=lt; le=le} ->
-      pr_uni_level u ++ str " " ++
+      let opt_sep = match lt, le with
+      | [], _ | _, [] -> mt ()
+      | _ -> spc ()
+      in
+      prl u ++ str " " ++
       v 0
-        (prlist_with_sep pr_spc (fun v -> str "< " ++ pr_uni_level v) lt ++
-	 (if lt <> [] & le <> [] then spc () else mt()) ++
-         prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++
+        (pr_sequence (fun v -> str "< " ++ prl v) lt ++
+	 opt_sep ++
+         pr_sequence (fun v -> str "<= " ++ prl v) le) ++
       fnl ()
   | u, Equiv v ->
-      pr_uni_level u  ++ str " = " ++ pr_uni_level v ++ fnl ()
+      prl u  ++ str " = " ++ prl v ++ fnl ()
 
-let pr_universes g =
-  let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in
-  prlist pr_arc graph
+let pr_universes prl g =
+  let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in
+  prlist (pr_arc prl) graph
 
-let pr_constraints c =
-  Constraint.fold (fun (u1,op,u2) pp_std ->
-		     let op_str = match op with
-		       | Lt -> " < "
-		       | Le -> " <= "
-		       | Eq -> " = "
-		     in pp_std ++  pr_uni_level u1 ++ str op_str ++
-			  pr_uni_level u2 ++ fnl () )  c (str "")
+let pr_constraints prl = Constraint.pr prl
+
+let pr_universe_context = UContext.pr
+
+let pr_universe_context_set = ContextSet.pr
+
+let pr_universe_subst = 
+  LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ())
+
+let pr_universe_level_subst = 
+  LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ())
 
 (* Dumping constraints to a file *)
 
 let dump_universes output g =
   let dump_arc u = function
     | Canonical {univ=u; lt=lt; le=le} ->
-	let u_str = UniverseLevel.to_string u in
-	List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt;
-	List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le
+	let u_str = Level.to_string u in
+	List.iter (fun v -> output Lt (Level.to_string v) u_str) lt;
+	List.iter (fun v -> output Le (Level.to_string v) u_str) le
     | Equiv v ->
-      output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v)
+      output Eq (Level.to_string u) (Level.to_string v)
   in
-    UniverseLMap.iter dump_arc g
-
-(* Hash-consing *)
-
-module Hunivlevel =
-  Hashcons.Make(
-    struct
-      type t = universe_level
-      type u = Names.dir_path -> Names.dir_path
-      let hash_sub hdir = function
-	| UniverseLevel.Set -> UniverseLevel.Set
-	| UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n)
-      let equal l1 l2 = match l1,l2 with
-	| UniverseLevel.Set, UniverseLevel.Set -> true
-	| UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') ->
-	  n == n' && d == d'
-	| _ -> false
-      let hash = Hashtbl.hash
-    end)
+  UMap.iter dump_arc g
 
-module Huniv =
+module Huniverse_set = 
   Hashcons.Make(
     struct
-      type t = universe
+      type t = universe_set
       type u = universe_level -> universe_level
-      let hash_sub hdir = function
-	| Atom u -> Atom (hdir u)
-	| Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl)
-      let equal u v =
-	match u, v with
-	  | Atom u, Atom v -> u == v
-	  | Max (gel,gtl), Max (gel',gtl') ->
-	      (list_for_all2eq (==) gel gel') &&
-              (list_for_all2eq (==) gtl gtl')
-	  | _ -> false
+      let hashcons huc s =
+	LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty
+      let equal s s' =
+	LSet.equal s s'
       let hash = Hashtbl.hash
     end)
 
-let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath
-let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel
+let hcons_universe_set = 
+  Hashcons.simple_hcons Huniverse_set.generate Huniverse_set.hcons Level.hcons
 
-module Hconstraint =
-  Hashcons.Make(
-    struct
-      type t = univ_constraint
-      type u = universe_level -> universe_level
-      let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2)
-      let equal (l1,k,l2) (l1',k',l2') =
-	l1 == l1' && k = k' && l2 == l2'
-      let hash = Hashtbl.hash
-    end)
+let hcons_universe_context_set (v, c) = 
+  (hcons_universe_set v, hcons_constraints c)
 
-module Hconstraints =
-  Hashcons.Make(
-    struct
-      type t = constraints
-      type u = univ_constraint -> univ_constraint
-      let hash_sub huc s =
-	Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
-      let equal s s' =
-	list_for_all2eq (==)
-	  (Constraint.elements s)
-	  (Constraint.elements s')
-      let hash = Hashtbl.hash
-    end)
+let hcons_univ x = Universe.hcons x
 
-let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel
-let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint
+let explain_universe_inconsistency prl (o,u,v,p) =
+  let pr_uni = Universe.pr_with prl in
+  let pr_rel = function
+    | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" 
+  in
+  let reason = match p with
+    | None | Some [] -> mt()
+    | Some p ->
+      str " because" ++ spc() ++ pr_uni v ++
+	prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v)
+	p ++
+	(if Universe.equal (snd (List.last p)) u then mt() else
+	    (spc() ++ str "= " ++ pr_uni u)) 
+  in
+    str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++
+      pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")"
+
+let compare_levels = Level.compare
+let eq_levels = Level.equal
+let equal_universes = Universe.equal
+
+
+let subst_instance_constraints = 
+  if Flags.profile then 
+    let key = Profile.declare_profile "subst_instance_constraints" in
+      Profile.profile2 key subst_instance_constraints
+  else subst_instance_constraints
+
+let merge_constraints = 
+  if Flags.profile then 
+    let key = Profile.declare_profile "merge_constraints" in
+      Profile.profile2 key merge_constraints
+  else merge_constraints
+let check_constraints =
+  if Flags.profile then
+    let key = Profile.declare_profile "check_constraints" in
+      Profile.profile2 key check_constraints
+  else check_constraints
+
+let check_eq = 
+  if Flags.profile then
+    let check_eq_key = Profile.declare_profile "check_eq" in
+      Profile.profile3 check_eq_key check_eq
+  else check_eq
+
+let check_leq = 
+  if Flags.profile then 
+    let check_leq_key = Profile.declare_profile "check_leq" in
+      Profile.profile3 check_leq_key check_leq
+  else check_leq
diff --git a/kernel/univ.mli b/kernel/univ.mli
index d6a9b56f..7aaf2ffe 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.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,60 +8,189 @@
 
 (** Universes. *)
 
-type universe_level
-type universe
+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. *)
 
-module UniverseLSet : Set.S with type elt = universe_level
+  val set : t
+  val prop : t
+  (** The set and prop universe levels. *)
 
-(** 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 is_small : t -> bool
+  (** Is the universe set or prop? *)
+
+  val compare : t -> t -> int
+  (** Comparison function *)
+
+  val equal : t -> t -> bool
+  (** Equality function *)
+
+  val hash : t -> int
+
+  val make : Names.DirPath.t -> int -> t
+  (** Create a new universe level from a unique identifier and an associated
+      module path. *)
+
+  val pr : t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+
+  val var : int -> t
+
+  val var_index : t -> int option
+end
+
+type universe_level = Level.t
+(** Alias name. *)
+
+(** Sets of universe levels *)
+module LSet : 
+sig 
+  include CSig.SetS with type elt = universe_level
+	      
+  val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+end
+
+type universe_set = LSet.t
+
+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 type0m_univ : universe  (** image of Prop in the universes hierarchy *)
-val type0_univ : universe  (** image of Set in the universes hierarchy *)
-val type1_univ : universe  (** the universe of the type of Prop/Set *)
+  val compare : t -> t -> int
+  (** Comparison function *)
 
-val make_universe_level : Names.dir_path * int -> universe_level
-val make_universe : universe_level -> universe
-val make_univ : Names.dir_path * int -> universe
+  val equal : t -> t -> bool
+  (** Equality function on formal universes *)
+
+  val hash : t -> int
+  (** Hash function *)
+
+  val make : Level.t -> t
+  (** Create a universe representing the given level. *)
+
+  val pr : t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+
+  val pr_with : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+
+  val is_level : t -> bool
+  (** Test if the universe is a level or an algebraic universe. *)
+
+  val level : t -> Level.t option
+  (** Try to get a level out of a universe, returns [None] if it
+      is an algebraic universe. *)
+
+  val levels : t -> LSet.t
+  (** Get the levels inside the universe, forgetting about increments *)
+
+  val super : t -> t
+  (** The universe strictly above *)
+    
+  val sup   : t -> t -> t
+  (** The l.u.b. of 2 universes *)
+
+  val type0m : t  
+  (** image of Prop in the universes hierarchy *)
+  
+  val type0 : t  
+  (** image of Set in the universes hierarchy *)
+  
+  val type1 : t 
+  (** the universe of the type of Prop/Set *)
+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 is_small_univ : universe -> bool
+
+val sup : universe -> universe -> universe
+val super : universe -> universe
 
 val universe_level : universe -> universe_level option
-val compare_levels : universe_level -> universe_level -> int
 
-(** The type of a universe *)
-val super : universe -> universe
+(** [univ_level_mem l u] Is l is mentionned in u ? *)
+
+val univ_level_mem : universe_level -> universe -> bool
 
-(** The max of 2 universes *)
-val sup   : universe -> universe -> universe
+(** [univ_level_rem u v min] removes [u] from [v], resulting in [min]
+    if [v] was exactly [u]. *)
+
+val univ_level_rem : universe_level -> universe -> universe -> universe
 
 (** {6 Graphs of universes. } *)
 
 type universes
 
-type check_function = universes -> universe -> universe -> bool
-val check_geq : check_function
-val check_eq : check_function
+type 'a check_function = universes -> 'a -> 'a -> bool
+val check_leq : universe check_function
+val check_eq : universe check_function
 
 (** The empty graph of universes *)
+val empty_universes : universes
+
+(** The initial graph of universes: Prop < Set *)
 val initial_universes : universes
+
 val is_initial_universes : universes -> bool
 
+val sort_universes : universes -> universes
+
+(** Adds a universe to the graph, ensuring it is >= Prop. *)
+val add_universe : universe_level -> universes -> universes
+
 (** {6 Constraints. } *)
 
-type constraints
+type constraint_type = Lt | Le | Eq
+type univ_constraint = universe_level * constraint_type * universe_level
+
+module Constraint : sig
+ include Set.S with type elt = univ_constraint
+end
+
+type constraints = Constraint.t
 
 val empty_constraint : constraints
-val union_constraints : constraints -> constraints -> constraints
+val union_constraint : constraints -> constraints -> constraints
+val eq_constraint : constraints -> constraints -> bool
+
+(** A value with universe constraints. *)
+type 'a constrained = 'a * constraints
 
-val is_empty_constraint : constraints -> bool
+(** Constrained *)
+val constraints_of : 'a constrained -> constraints
 
-type constraint_function = universe -> universe -> constraints -> constraints
+(** Enforcing constraints. *)
 
-val enforce_geq : constraint_function
-val enforce_eq : constraint_function
+type 'a constraint_function = 'a -> 'a -> constraints -> constraints
+
+val enforce_eq : universe constraint_function
+val enforce_leq : universe constraint_function
+val enforce_eq_level : universe_level constraint_function
+val enforce_leq_level : universe_level constraint_function
 
 (** {6 ... } *)
 (** Merge of constraints in a universes graph.
@@ -69,38 +198,231 @@ val enforce_eq : constraint_function
   universes graph. It raises the exception [UniverseInconsistency] if the
   constraints are not satisfiable. *)
 
-type constraint_type = Lt | Le | Eq
+(** 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 explanation = (constraint_type * universe) list
+type univ_inconsistency = constraint_type * universe * universe * explanation option
+
+exception UniverseInconsistency of univ_inconsistency
+
+val enforce_constraint : univ_constraint -> universes -> universes
+val merge_constraints : constraints -> universes -> universes
 
-exception UniverseInconsistency of constraint_type * universe * universe
+val constraints_of_universes : universes -> constraints
 
-val merge_constraints : constraints -> universes -> universes
-val normalize_universes : universes -> universes
-val sort_universes : universes -> universes
+val check_constraint  : universes -> univ_constraint -> bool
+val check_constraints : constraints -> universes -> bool
+
+(** {6 Support for universe polymorphism } *)
+
+(** Polymorphic maps from universe levels to 'a *)
+module LMap : 
+sig
+  include CMap.ExtS with type key = universe_level and module Set := LSet
+
+  val union : 'a t -> 'a t -> 'a t
+  (** [union x y] favors the bindings in the first map. *)
+
+  val diff : 'a t -> 'a t -> 'a t
+  (** [diff x y] removes bindings from x that appear in y (whatever the value). *)
 
-(** {6 Support for sort-polymorphic inductive types } *)
+  val subst_union : 'a option t -> 'a option t -> 'a option t
+  (** [subst_union x y] favors the bindings of the first map that are [Some],
+      otherwise takes y's bindings. *)
 
-val fresh_local_univ : unit -> universe
+  val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+  (** Pretty-printing *)
+end
 
-val solve_constraints_system : universe option array -> universe array ->
-  universe array
+type 'a universe_map = 'a LMap.t
 
-val subst_large_constraint : universe -> universe -> universe -> universe
+(** {6 Substitution} *)
 
-val subst_large_constraints :
-  (universe * universe) list -> universe -> universe
+type universe_subst_fn = universe_level -> universe
+type universe_level_subst_fn = universe_level -> universe_level
 
-val no_upper_constraints : universe -> constraints -> bool
+(** A full substitution, might involve algebraic universes *)
+type universe_subst = universe universe_map
+type universe_level_subst = universe_level universe_map
 
-(** Is u mentionned in v (or equals to v) ? *)
+val level_subst_of : universe_subst_fn -> universe_level_subst_fn
 
-val univ_depends : universe -> universe -> bool
+(** {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 of_array : Level.t array -> t
+  val to_array : t -> Level.t array
+
+  val append : t -> t -> t
+  (** To concatenate two instances, used for discharge *)
+
+  val equal : t -> t -> bool
+  (** Equality *)
+
+  val length : t -> int
+  (** Instance length *)
+
+  val hcons : t -> t
+  (** Hash-consing. *)
+
+  val hash : t -> int
+  (** Hash value *)
+
+  val share : t -> t * int
+  (** Simultaneous hash-consing and hash-value computation *)
+
+  val subst_fn : universe_level_subst_fn -> t -> t
+  (** Substitution by a level-to-level function. *)
+
+  val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds
+  (** Pretty-printing, no comments *)
+
+  val levels : t -> LSet.t
+  (** The set of levels in the instance *)
+
+  val check_eq : t check_function 
+  (** Check equality of instances w.r.t. a universe graph *)
+end
+
+type universe_instance = Instance.t
+
+val enforce_eq_instances : universe_instance constraint_function
+
+type 'a puniverses = 'a * universe_instance
+val out_punivs : 'a puniverses -> 'a
+val in_punivs : 'a -> 'a puniverses
+
+val eq_puniverses : ('a -> 'a -> bool) -> 'a puniverses -> 'a puniverses -> bool
+
+(** A vector of universe levels with universe constraints,
+    representiong local universe variables and associated constraints *)
+
+module UContext :
+sig 
+  type t
+
+  val make : Instance.t constrained -> t
+
+  val empty : t
+  val is_empty : t -> bool
+    
+  val instance : t -> Instance.t
+  val constraints : t -> constraints
+
+  val dest : t -> Instance.t * constraints
+
+  (** Keeps the order of the instances *)
+  val union : t -> t -> t
+
+end
+
+type universe_context = UContext.t
+
+(** Universe contexts (as sets) *)
+
+module ContextSet :
+sig 
+  type t = universe_set constrained
+
+  val empty : t
+  val is_empty : t -> bool
+
+  val singleton : universe_level -> t
+  val of_instance : Instance.t -> t
+  val of_set : universe_set -> t
+
+  val union : t -> t -> t
+
+  val append : t -> t -> t
+  (** Variant of {!union} which is more efficient when the left argument is
+      much smaller than the right one. *)
+
+  val diff : t -> t -> t
+  val add_universe : universe_level -> t -> t
+  val add_constraints : constraints -> t -> t
+  val add_instance : Instance.t -> t -> t
+
+  (** Arbitrary choice of linear order of the variables *)
+  val to_context : t -> universe_context
+  val of_context : universe_context -> t
+
+  val constraints : t -> constraints
+  val levels : t -> universe_set
+end
+
+(** A set of universes with universe constraints.
+    We linearize the set to a list after typechecking. 
+    Beware, representation could change.
+*)
+type universe_context_set = ContextSet.t
+
+(** A value in a universe context (resp. context set). *)
+type 'a in_universe_context = 'a * universe_context
+type 'a in_universe_context_set = 'a * universe_context_set
+
+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
+val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints
+val subst_univs_level_instance : universe_level_subst -> universe_instance -> universe_instance
+
+(** Level to universe substitutions. *)
+
+val empty_subst : universe_subst
+val is_empty_subst : universe_subst -> bool
+val make_subst : universe_subst -> universe_subst_fn
+
+val subst_univs_universe : universe_subst_fn -> universe -> universe
+val subst_univs_constraints : universe_subst_fn -> constraints -> constraints
+
+(** 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
+
+val abstract_universes : bool -> universe_context -> universe_level_subst * universe_context
+
+(** 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_uni_level : universe_level -> Pp.std_ppcmds
-val pr_uni : universe -> Pp.std_ppcmds
-val pr_universes : universes -> Pp.std_ppcmds
-val pr_constraints : constraints -> Pp.std_ppcmds
+val pr_universes : (Level.t -> Pp.std_ppcmds) -> universes -> Pp.std_ppcmds
+val pr_constraint_type : constraint_type -> Pp.std_ppcmds
+val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds
+val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds
+val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds
+val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> 
+  univ_inconsistency -> Pp.std_ppcmds
+
+val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds
+val pr_universe_subst : universe_subst -> Pp.std_ppcmds
 
 (** {6 Dumping to a file } *)
 
@@ -110,6 +432,17 @@ val dump_universes :
 
 (** {6 Hash-consing } *)
 
-val hcons_univlevel : universe_level -> universe_level
 val hcons_univ : universe -> universe
 val hcons_constraints : constraints -> constraints
+val hcons_universe_set : universe_set -> universe_set
+val hcons_universe_context : universe_context -> universe_context
+val hcons_universe_context_set : universe_context_set -> universe_context_set 
+
+(******)
+
+(* deprecated: use qualified names instead *)
+val compare_levels : universe_level -> universe_level -> int
+val eq_levels : universe_level -> universe_level -> bool
+
+(** deprecated: Equality of formal universe expressions. *)
+val equal_universes : universe -> universe -> bool
diff --git a/kernel/vars.ml b/kernel/vars.ml
new file mode 100644
index 00000000..88c1e103
--- /dev/null
+++ b/kernel/vars.ml
@@ -0,0 +1,341 @@
+(************************************************************************)
+(*  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 Names
+open Esubst
+open Context
+
+(*********************)
+(*     Occurring     *)
+(*********************)
+
+exception LocalOccur
+
+(* (closedn n M) raises FreeVar if a variable of height greater than n
+   occurs in M, returns () otherwise *)
+
+let closedn n c =
+  let rec closed_rec n c = match Constr.kind c with
+    | Constr.Rel m -> if m>n then raise LocalOccur
+    | _ -> Constr.iter_with_binders succ closed_rec n c
+  in
+  try closed_rec n c; true with LocalOccur -> false
+
+(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+
+let closed0 c = closedn 0 c
+
+(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M  *)
+
+let noccurn n term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel m -> if Int.equal m n then raise LocalOccur
+    | _ -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try occur_rec n term; true with LocalOccur -> false
+
+(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M
+  for n <= p < n+m *)
+
+let noccur_between n m term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur
+    | _        -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try occur_rec n term; true with LocalOccur -> false
+
+(* Checking function for terms containing existential variables.
+ The function [noccur_with_meta] considers the fact that
+ each existential variable (as well as each isevar)
+ in the term appears applied to its local context,
+ which may contain the CoFix variables. These occurrences of CoFix variables
+ are not considered *)
+
+let isMeta c = match Constr.kind c with
+| Constr.Meta _ -> true
+| _ -> false
+
+let noccur_with_meta n m term =
+  let rec occur_rec n c = match Constr.kind c with
+    | Constr.Rel p -> if n<=p && p<n+m then raise LocalOccur
+    | Constr.App(f,cl) ->
+        (match Constr.kind f with
+           | Constr.Cast (c,_,_) when isMeta c -> ()
+           | Constr.Meta _ -> ()
+           | _ -> Constr.iter_with_binders succ occur_rec n c)
+    | Constr.Evar (_, _) -> ()
+    | _ -> Constr.iter_with_binders succ occur_rec n c
+  in
+  try (occur_rec n term; true) with LocalOccur -> false
+
+(*********************)
+(*      Lifting      *)
+(*********************)
+
+(* The generic lifting function *)
+let rec exliftn el c = match Constr.kind c with
+  | Constr.Rel i -> Constr.mkRel(reloc_rel i el)
+  | _ -> Constr.map_with_binders el_lift exliftn el c
+
+(* Lifting the binding depth across k bindings *)
+
+let liftn n k c =
+  match el_liftn (pred k) (el_shft n el_id) with
+    | ELID -> c
+    | el -> exliftn el c
+
+let lift n = liftn n 1
+
+(*********************)
+(*   Substituting    *)
+(*********************)
+
+(* (subst1 M c) substitutes M for Rel(1) in c
+   we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel
+   M1,...,Mn for respectively Rel(1),...,Rel(n) in c *)
+
+(* 1st : general case *)
+
+type info = Closed | Open | Unknown
+type 'a substituend = { mutable sinfo: info; sit: 'a }
+
+let lift_substituend depth s =
+  match s.sinfo with
+    | Closed -> s.sit
+    | Open -> lift depth s.sit
+    | Unknown ->
+      let sit = s.sit in
+      if closed0 sit then
+        let () = s.sinfo <- Closed in
+        sit
+      else
+        let () = s.sinfo <- Open in
+        lift depth sit
+
+let make_substituend c = { sinfo=Unknown; sit=c }
+
+let substn_many lamv n c =
+  let lv = Array.length lamv in
+  if Int.equal lv 0 then c
+  else
+    let rec substrec depth c = match Constr.kind c with
+      | Constr.Rel k     ->
+          if k<=depth then c
+          else if k-depth <= lv then lift_substituend depth (Array.unsafe_get lamv (k-depth-1))
+          else Constr.mkRel (k-lv)
+      | _ -> Constr.map_with_binders succ substrec depth c in
+    substrec n c
+
+(*
+let substkey = Profile.declare_profile "substn_many";;
+let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;;
+*)
+
+let make_subst = function
+| [] -> [||]
+| hd :: tl ->
+  let len = List.length tl in
+  let subst = Array.make (1 + len) (make_substituend hd) in
+  let s = ref tl in
+  for i = 1 to len do
+    match !s with
+    | [] -> assert false
+    | x :: tl ->
+      Array.unsafe_set subst i (make_substituend x);
+      s := tl
+  done;
+  subst
+
+let substnl laml n c = substn_many (make_subst laml) n c
+let substl laml c = substn_many (make_subst laml) 0 c
+let subst1 lam c = substn_many [|make_substituend lam|] 0 c
+
+let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r
+let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r
+let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r
+
+let substnl_named_decl laml k d =
+  map_named_declaration (fun c -> substnl laml k c) d
+let substl_named_decl laml d =
+  map_named_declaration (fun c -> substnl laml 0 c) d
+let subst1_named_decl lam d =
+  map_named_declaration (fun c -> subst1 lam c) d
+
+(* (thin_val sigma) removes identity substitutions from sigma *)
+
+let rec thin_val = function
+  | [] -> []
+  | (id, c) :: tl ->
+    match Constr.kind c with
+    | Constr.Var v ->
+      if Id.equal id v then thin_val tl
+      else (id, make_substituend c) :: (thin_val tl)
+    | _ -> (id, make_substituend c) :: (thin_val tl)
+
+let rec find_var id = function
+| [] -> raise Not_found
+| (idc, c) :: subst ->
+  if Id.equal id idc then c
+  else find_var id subst
+
+(* (replace_vars sigma M) applies substitution sigma to term M *)
+let replace_vars var_alist x =
+  let var_alist = thin_val var_alist in
+  match var_alist with
+  | [] -> x
+  | _ ->
+    let rec substrec n c = match Constr.kind c with
+    | Constr.Var x ->
+      (try lift_substituend n (find_var x var_alist)
+      with Not_found -> c)
+    | _ -> Constr.map_with_binders succ substrec n c
+    in
+    substrec 0 x
+
+(*
+let repvarkey = Profile.declare_profile "replace_vars";;
+let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;;
+*)
+
+(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+let subst_var str t = replace_vars [(str, Constr.mkRel 1)] t
+
+(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *)
+let substn_vars p vars c =
+  let _,subst =
+    List.fold_left (fun (n,l) var -> ((n+1),(var,Constr.mkRel n)::l)) (p,[]) vars
+  in replace_vars (List.rev subst) c
+
+let subst_vars subst c = substn_vars 1 subst c
+
+(** Universe substitutions *)
+open Constr
+
+let subst_univs_fn_puniverses fn =
+  let f = Univ.Instance.subst_fn fn in
+    fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u')
+
+let subst_univs_fn_constr f c =
+  let changed = ref false in
+  let fu = Univ.subst_univs_universe f in
+  let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in
+  let rec aux t = 
+    match kind t with
+    | Sort (Sorts.Type u) -> 
+      let u' = fu u in
+	if u' == u then t else 
+	  (changed := true; mkSort (Sorts.sort_of_univ u'))
+    | Const (c, u) -> 
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkConstU (c, u'))
+    | Ind (i, u) ->
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkIndU (i, u'))
+    | Construct (c, u) ->
+      let u' = fi u in 
+	if u' == u then t
+	else (changed := true; mkConstructU (c, u'))
+    | _ -> map aux t
+  in 
+  let c' = aux c in
+    if !changed then c' else c
+
+let subst_univs_constr subst c =
+  if Univ.is_empty_subst subst then c
+  else 
+    let f = Univ.make_subst subst in
+      subst_univs_fn_constr f c
+
+let subst_univs_constr = 
+  if Flags.profile then
+    let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" in
+      Profile.profile2 subst_univs_constr_key subst_univs_constr
+  else subst_univs_constr
+
+let subst_univs_level_constr subst c =
+  if Univ.is_empty_level_subst subst then c
+  else 
+    let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in
+    let changed = ref false in
+    let rec aux t = 
+      match kind 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; mkConstU (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; mkIndU (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; mkConstructU (c, u'))
+      | Sort (Sorts.Type u) -> 
+         let u' = Univ.subst_univs_level_universe subst u in
+	   if u' == u then t else 
+	     (changed := true; mkSort (Sorts.sort_of_univ u'))
+      | _ -> Constr.map aux t
+    in
+    let c' = aux c in
+      if !changed then c' else c
+
+let subst_univs_level_context s = 
+  map_rel_context (subst_univs_level_constr s)
+      
+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 kind 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; mkConstU (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; mkIndU (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; mkConstructU (c, u'))
+      | Sort (Sorts.Type u) -> 
+         let u' = Univ.subst_instance_universe subst u in
+	   if u' == u then t else 
+	     (changed := true; mkSort (Sorts.sort_of_univ u'))
+      | _ -> Constr.map aux t
+    in
+    let c' = aux c in
+      if !changed then c' else c
+
+(* let substkey = Profile.declare_profile "subst_instance_constr";; *)
+(* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst 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
+
+type id_key = pconstant tableKey
+let eq_id_key x y = Names.eq_table_key (Univ.eq_puniverses Constant.equal) x y
diff --git a/kernel/vars.mli b/kernel/vars.mli
new file mode 100644
index 00000000..fdd4603b
--- /dev/null
+++ b/kernel/vars.mli
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  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 Names
+open Constr
+open Context
+
+(** {6 Occur checks } *)
+
+(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+val closedn : int -> constr -> bool
+
+(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+val closed0 : constr -> bool
+
+(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M]  *)
+val noccurn : int -> constr -> bool
+
+(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+  for n <= p < n+m *)
+val noccur_between : int -> int -> constr -> bool
+
+(** Checking function for terms containing existential- or
+   meta-variables.  The function [noccur_with_meta] does not consider
+   meta-variables applied to some terms (intended to be its local
+   context) (for existential variables, it is necessarily the case) *)
+val noccur_with_meta : int -> int -> constr -> bool
+
+(** {6 Relocation and substitution } *)
+
+(** [exliftn el c] lifts [c] with lifting [el] *)
+val exliftn : Esubst.lift -> constr -> constr
+
+(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
+val liftn : int -> int -> constr -> constr
+
+(** [lift n c] lifts by [n] the positive indexes in [c] *)
+val lift : int -> constr -> constr
+
+(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+    for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
+    accordingly indexes in [a1],...,[an] and [c] *)
+val substnl : constr list -> int -> constr -> constr
+val substl : constr list -> constr -> constr
+val subst1 : constr -> constr -> constr
+
+val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration
+val substl_decl : constr list -> rel_declaration -> rel_declaration
+val subst1_decl : constr -> rel_declaration -> rel_declaration
+
+val substnl_named_decl : constr list -> int -> named_declaration -> named_declaration
+val subst1_named_decl : constr -> named_declaration -> named_declaration
+val substl_named_decl : constr list -> named_declaration -> named_declaration
+
+val replace_vars : (Id.t * constr) list -> constr -> constr
+(** (subst_var str t) substitute (VAR str) by (Rel 1) in t *)
+val subst_var : Id.t -> constr -> constr
+
+(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+   if two names are identical, the one of least indice is kept *)
+val subst_vars : Id.t list -> constr -> constr
+
+(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+   if two names are identical, the one of least indice is kept *)
+val substn_vars : int -> Id.t list -> constr -> constr
+
+(** {3 Substitution of universes} *)
+
+open Univ
+
+val subst_univs_fn_constr : universe_subst_fn -> constr -> constr
+val subst_univs_fn_puniverses : universe_level_subst_fn -> 
+  'a puniverses -> 'a puniverses
+
+val subst_univs_constr : universe_subst -> constr -> constr
+
+(** Level substitutions for polymorphism. *)
+
+val subst_univs_level_constr : universe_level_subst -> constr -> constr
+val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_context
+
+(** Instance substitution for polymorphism. *)
+val subst_instance_constr : universe_instance -> constr -> constr
+val subst_instance_context : universe_instance -> rel_context -> rel_context
+
+type id_key = pconstant tableKey
+val eq_id_key : id_key -> id_key -> bool
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index 4d0edc68..80b15f8b 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -1,5 +1,5 @@
+open Util
 open Names
-open Declarations
 open Term
 open Environ
 open Conv_oracle
@@ -16,8 +16,8 @@ let val_of_constr env c =
 
 let compare_zipper z1 z2 =
   match z1, z2 with
-  | Zapp args1, Zapp args2 -> nargs args1 = nargs args2
-  | Zfix(f1,args1), Zfix(f2,args2) ->  nargs args1 = nargs args2
+  | Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2)
+  | Zfix(f1,args1), Zfix(f2,args2) ->  Int.equal (nargs args1) (nargs args2)
   | Zswitch _, Zswitch _ -> true
   | _ , _ -> false
 
@@ -32,7 +32,7 @@ let rec compare_stack stk1 stk2 =
 (* Conversion *)
 let conv_vect fconv vect1 vect2 cu =
   let n = Array.length vect1 in
-  if n = Array.length vect2 then
+  if Int.equal n (Array.length vect2) then
     let rcu = ref cu in
     for i = 0 to n - 1 do
       rcu := fconv vect1.(i) vect2.(i) !rcu
@@ -42,193 +42,206 @@ let conv_vect fconv vect1 vect2 cu =
 
 let infos = ref (create_clos_infos betaiotazeta Environ.empty_env)
 
-let rec conv_val pb k v1 v2 cu =
+let eq_table_key = Names.eq_table_key eq_constant
+
+let rec conv_val env pb k v1 v2 cu =
   if v1 == v2 then cu
-  else conv_whd pb k (whd_val v1) (whd_val v2) cu
+  else conv_whd env pb k (whd_val v1) (whd_val v2) cu
 
-and conv_whd pb k whd1 whd2 cu =
+and conv_whd env pb k whd1 whd2 cu =
   match whd1, whd2 with
-  | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu
+  | Vsort s1, Vsort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu
   | Vprod p1, Vprod p2 ->
-      let cu = conv_val CONV k (dom p1) (dom p2) cu in
-      conv_fun pb k (codom p1) (codom p2) cu
-  | Vfun f1, Vfun f2 -> conv_fun CONV k f1 f2 cu
-  | Vfix (f1,None), Vfix (f2,None) -> conv_fix k f1 f2 cu
+      let cu = conv_val env CONV k (dom p1) (dom p2) cu in
+      conv_fun env pb k (codom p1) (codom p2) cu
+  | Vfun f1, Vfun f2 -> conv_fun env CONV k f1 f2 cu
+  | Vfix (f1,None), Vfix (f2,None) -> conv_fix env k f1 f2 cu
   | Vfix (f1,Some args1), Vfix(f2,Some args2) ->
       if nargs args1 <> nargs args2 then raise NotConvertible
-      else conv_arguments k args1 args2 (conv_fix k f1 f2 cu)
-  | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu
+      else conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)
+  | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix env k cf1 cf2 cu
   | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) ->
       if nargs args1 <> nargs args2 then raise NotConvertible
-      else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu)
+      else conv_arguments env k args1 args2 (conv_cofix env k cf1 cf2 cu)
   | Vconstr_const i1, Vconstr_const i2 ->
-      if i1 = i2 then cu else raise NotConvertible
+      if Int.equal i1 i2 then cu else raise NotConvertible
   | Vconstr_block b1, Vconstr_block b2 ->
       let sz = bsize b1 in
-      if btag b1 = btag b2 && sz = bsize b2 then
+      if Int.equal (btag b1) (btag b2) && Int.equal sz (bsize b2) then
 	let rcu = ref cu in
 	for i = 0 to sz - 1 do
-	  rcu := conv_val CONV k (bfield b1 i) (bfield b2 i) !rcu
+	  rcu := conv_val env CONV k (bfield b1 i) (bfield b2 i) !rcu
 	done;
 	!rcu
       else raise NotConvertible
   | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
-      conv_atom pb k a1 stk1 a2 stk2 cu
+      conv_atom env pb k a1 stk1 a2 stk2 cu
   | Vfun _, _ | _, Vfun _ ->
-      conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
+      conv_val env CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
   | _, Vatom_stk(Aiddef(_,v),stk) ->
-      conv_whd pb k whd1 (force_whd v stk) cu
+      conv_whd env pb k whd1 (force_whd v stk) cu
   | Vatom_stk(Aiddef(_,v),stk), _ ->
-      conv_whd pb k (force_whd v stk) whd2 cu
+      conv_whd env pb k (force_whd v stk) whd2 cu
   | _, _ -> raise NotConvertible
 
-and conv_atom pb k a1 stk1 a2 stk2 cu =
+and conv_atom env pb k a1 stk1 a2 stk2 cu =
   match a1, a2 with
-  | Aind (kn1,i1), Aind(kn2,i2) ->
-      if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2
+  | Aind ind1, Aind ind2 ->
+      if eq_puniverses eq_ind ind1 ind2 && compare_stack stk1 stk2
       then
-	conv_stack k stk1 stk2 cu
+	conv_stack env k stk1 stk2 cu
       else raise NotConvertible
   | Aid ik1, Aid ik2 ->
-      if ik1 = ik2 && compare_stack stk1 stk2 then
-	conv_stack k stk1 stk2 cu
+      if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then
+	conv_stack env k stk1 stk2 cu
       else raise NotConvertible
   | Aiddef(ik1,v1), Aiddef(ik2,v2) ->
       begin
 	try
-	  if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then
-	    conv_stack k stk1 stk2 cu
+	  if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then
+	    conv_stack env k stk1 stk2 cu
 	  else raise NotConvertible
 	with NotConvertible ->
-	  if oracle_order false ik1 ik2 then
-            conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
-          else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
+	  if oracle_order Univ.out_punivs (oracle_of_infos !infos) 
+	    false ik1 ik2 then
+            conv_whd env pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
+          else conv_whd env pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
       end
   | Aiddef(ik1,v1), _ ->
-      conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
+      conv_whd env pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu
   | _, Aiddef(ik2,v2) ->
-      conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
+      conv_whd env pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu
   | _, _ -> raise NotConvertible
 
-and conv_stack k stk1 stk2 cu =
+and conv_stack env k stk1 stk2 cu =
   match stk1, stk2 with
   | [], [] -> cu
   | Zapp args1 :: stk1, Zapp args2 :: stk2 ->
-      conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu)
+      conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu)
   | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 ->
-      conv_stack k stk1 stk2
-	(conv_arguments k args1 args2 (conv_fix k f1 f2 cu))
+      conv_stack env k stk1 stk2
+	(conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu))
   | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 ->
       if check_switch sw1 sw2 then
 	let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in
-	let rcu = ref (conv_val CONV k vt1 vt2 cu) in
+	let rcu = ref (conv_val env CONV k vt1 vt2 cu) in
 	let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in
 	for i = 0 to Array.length b1 - 1 do
 	  rcu :=
-	    conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
+	    conv_val env CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu
 	done;
-	conv_stack k stk1 stk2 !rcu
+	conv_stack env k stk1 stk2 !rcu
       else raise NotConvertible
   | _, _ -> raise NotConvertible
 
-and conv_fun pb k f1 f2 cu =
+and conv_fun env pb k f1 f2 cu =
   if f1 == f2 then cu
   else
     let arity,b1,b2 = decompose_vfun2 k f1 f2 in
-    conv_val pb (k+arity) b1 b2 cu
+    conv_val env pb (k+arity) b1 b2 cu
 
-and conv_fix k f1 f2 cu =
+and conv_fix env k f1 f2 cu =
   if f1 == f2 then cu
   else
     if check_fix f1 f2 then
       let bf1, tf1 = reduce_fix k f1 in
       let bf2, tf2 = reduce_fix k f2 in
-      let cu = conv_vect (conv_val CONV k) tf1 tf2 cu in
-      conv_vect (conv_fun CONV (k + Array.length tf1)) bf1 bf2 cu
+      let cu = conv_vect (conv_val env CONV k) tf1 tf2 cu in
+      conv_vect (conv_fun env CONV (k + Array.length tf1)) bf1 bf2 cu
     else raise NotConvertible
 
-and conv_cofix k cf1 cf2 cu =
+and conv_cofix env k cf1 cf2 cu =
   if cf1 == cf2 then cu
   else
     if check_cofix cf1 cf2 then
       let bcf1, tcf1 = reduce_cofix k cf1 in
       let bcf2, tcf2 = reduce_cofix k cf2 in
-      let cu = conv_vect (conv_val CONV k) tcf1 tcf2 cu in
-      conv_vect (conv_val CONV (k + Array.length tcf1)) bcf1 bcf2 cu
+      let cu = conv_vect (conv_val env CONV k) tcf1 tcf2 cu in
+      conv_vect (conv_val env CONV (k + Array.length tcf1)) bcf1 bcf2 cu
     else raise NotConvertible
 
-and conv_arguments k args1 args2 cu =
+and conv_arguments env k args1 args2 cu =
   if args1 == args2 then cu
   else
     let n = nargs args1 in
-    if n = nargs args2 then
+    if Int.equal n (nargs args2) then
       let rcu = ref cu in
       for i = 0 to n - 1 do
-	rcu := conv_val CONV k (arg args1 i) (arg args2 i) !rcu
+	rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu
       done;
       !rcu
     else raise NotConvertible
 
-let rec conv_eq pb t1 t2 cu =
+let rec eq_puniverses f (x,l1) (y,l2) cu =
+  if f x y then conv_universes l1 l2 cu
+  else raise NotConvertible
+
+and conv_universes l1 l2 cu =
+  if Univ.Instance.equal l1 l2 then cu else raise NotConvertible
+
+let rec conv_eq env pb t1 t2 cu =
   if t1 == t2 then cu
   else
     match kind_of_term t1, kind_of_term t2 with
     | Rel n1, Rel n2 ->
-	if n1 = n2 then cu else raise NotConvertible
+	if Int.equal n1 n2 then cu else raise NotConvertible
     | Meta m1, Meta m2 ->
-	if m1 = m2 then cu else raise NotConvertible
+	if Int.equal m1 m2 then cu else raise NotConvertible
     | Var id1, Var id2 ->
-	if id1 = id2 then cu else raise NotConvertible
-    | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu
-    | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu
-    | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu
+	if Id.equal id1 id2 then cu else raise NotConvertible
+    | Sort s1, Sort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu
+    | Cast (c1,_,_), _ -> conv_eq env pb c1 t2 cu
+    | _, Cast (c2,_,_) -> conv_eq env pb t1 c2 cu
     | Prod (_,t1,c1), Prod (_,t2,c2) ->
-	conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu)
-    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu
+	conv_eq env pb c1 c2 (conv_eq env CONV t1 t2 cu)
+    | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq env CONV c1 c2 cu
     | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
-	conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu)
+	conv_eq env pb c1 c2 (conv_eq env CONV b1 b2 cu)
     | App (c1,l1), App (c2,l2) ->
-	conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu)
+	conv_eq_vect env l1 l2 (conv_eq env CONV c1 c2 cu)
     | Evar (e1,l1), Evar (e2,l2) ->
-	if e1 = e2 then conv_eq_vect l1 l2 cu
+	if Evar.equal e1 e2 then conv_eq_vect env l1 l2 cu
+	else raise NotConvertible
+    | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu
+    | Proj (p1,c1), Proj (p2,c2) ->
+	if eq_constant (Projection.constant p1) (Projection.constant p2) then
+	  conv_eq env pb c1 c2 cu 
 	else raise NotConvertible
-    | Const c1, Const c2 ->
-	if eq_constant c1 c2 then cu else raise NotConvertible
     | Ind c1, Ind c2 ->
-	if eq_ind c1 c2 then cu else raise NotConvertible
+       eq_puniverses eq_ind c1 c2 cu
     | Construct c1, Construct c2 ->
-	if eq_constructor c1 c2 then cu else raise NotConvertible
+       eq_puniverses eq_constructor c1 c2 cu
     | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
-	let pcu = conv_eq CONV p1 p2 cu in
-	let ccu = conv_eq CONV c1 c2 pcu in
-	conv_eq_vect bl1 bl2 ccu
-    | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
-	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	let pcu = conv_eq env CONV p1 p2 cu in
+	let ccu = conv_eq env CONV c1 c2 pcu in
+	conv_eq_vect env bl1 bl2 ccu
+    | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) ->
+	if Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu)
 	else raise NotConvertible
     | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
-	if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu)
+	if Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu)
 	else raise NotConvertible
     | _ -> raise NotConvertible
 
-and conv_eq_vect vt1 vt2 cu =
+and conv_eq_vect env vt1 vt2 cu =
   let len = Array.length vt1 in
-  if len = Array.length vt2 then
+  if Int.equal len (Array.length vt2) then
     let rcu = ref cu in
     for i = 0 to len-1 do
-      rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu
+      rcu := conv_eq env CONV vt1.(i) vt2.(i) !rcu
     done; !rcu
   else raise NotConvertible
 
 let vconv pb env t1 t2 =
-  let cu =
-    try conv_eq pb t1 t2 empty_constraint
+  infos := create_clos_infos betaiotazeta env;
+  let _cu =
+    try conv_eq env pb t1 t2 (universes env)
     with NotConvertible ->
-      infos := create_clos_infos betaiotazeta env;
       let v1 = val_of_constr env t1 in
       let v2 = val_of_constr env t2 in
-      let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in
+      let cu = conv_val env pb (nb_rel env) v1 v2 (universes env) in
       cu
-  in cu
+  in ()
 
 let _ = Reduction.set_vm_conv vconv
 
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index fde0912a..096d31ac 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  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 Environ
 open Reduction
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 9ff369e5..2cc1efe4 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.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,7 +8,6 @@
 
 open Names
 open Term
-open Conv_oracle
 open Cbytecodes
 
 external set_drawinstr : unit -> unit = "coq_set_drawinstr"
@@ -43,7 +42,6 @@ let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0)
 
 external mkAccuCode : int -> tcode = "coq_makeaccu"
 external mkPopStopCode : int -> tcode = "coq_pushpop"
-external mkAccuCond : int -> tcode = "coq_accucond"
 
 external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode"
 external int_tcode : tcode -> int -> int = "coq_int_tcode"
@@ -139,10 +137,11 @@ type vswitch = {
 (* Generally the first field is a code pointer.                           *)
 
 (* Do not edit this type without editing C code, especially "coq_values.h" *)
+
 type atom =
-  | Aid of id_key
-  | Aiddef of id_key * values
-  | Aind of inductive
+  | Aid of Vars.id_key
+  | Aiddef of Vars.id_key * values
+  | Aind of pinductive
 
 (* Zippers *)
 
@@ -171,7 +170,7 @@ type whd =
 
 let rec whd_accu a stk =
   let stk =
-    if Obj.size a = 2 then stk
+    if Int.equal (Obj.size a) 2 then stk
     else Zapp (Obj.obj a) :: stk in
   let at = Obj.field a 1 in
   match Obj.tag at with
@@ -213,7 +212,7 @@ let whd_val : values -> whd =
       let tag = Obj.tag o in
       if tag = accu_tag then
 	(
-	if Obj.size o = 1 then Obj.obj o (* sort *)
+	if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *)
 	else
 	  if is_accumulate (fun_code o) then whd_accu o []
 	  else (Vprod(Obj.obj o)))
@@ -224,7 +223,7 @@ let whd_val : values -> whd =
 	   | 1 -> Vfix(Obj.obj o, None)
 	   | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o))
 	   | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), [])
-	   | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work")
+	   | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work"))
 	else Vconstr_block(Obj.obj o)
 
 
@@ -251,13 +250,13 @@ let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2
 let arg args i =
   if  0 <= i && i < (nargs args) then
     val_of_obj (Obj.field (Obj.repr args) (i+2))
-  else raise (Invalid_argument
+  else invalid_arg
 		("Vm.arg size = "^(string_of_int (nargs args))^
-		 " acces "^(string_of_int i)))
+		 " acces "^(string_of_int i))
 
 let apply_arguments vf vargs =
   let n = nargs vargs in
-  if n = 0 then vf
+  if Int.equal n 0 then vf
   else
    begin
      push_ra stop;
@@ -267,7 +266,7 @@ let apply_arguments vf vargs =
 
 let apply_vstack vf vstk =
   let n = Array.length vstk in
-  if n = 0 then vf
+  if Int.equal n 0 then vf
   else
     begin
       push_ra stop;
@@ -306,27 +305,33 @@ let val_of_str_const str = val_of_obj (obj_of_str_const str)
 
 let val_of_atom a = val_of_obj (obj_of_atom a)
 
-let idkey_tbl = Hashtbl.create 31
+module IdKeyHash =
+struct
+  type t = pconstant tableKey
+  let equal = Names.eq_table_key (Univ.eq_puniverses Constant.equal)
+  open Hashset.Combine
+  let hash = function
+  | ConstKey (c,u) -> combinesmall 1 (Constant.hash c)
+  | VarKey id -> combinesmall 2 (Id.hash id)
+  | RelKey i -> combinesmall 3 (Int.hash i)
+end
+
+module KeyTable = Hashtbl.Make(IdKeyHash)
+
+let idkey_tbl = KeyTable.create 31
 
 let val_of_idkey key =
-  try Hashtbl.find idkey_tbl key
+  try KeyTable.find idkey_tbl key
   with Not_found ->
     let v = val_of_atom (Aid key) in
-    Hashtbl.add idkey_tbl key v;
+    KeyTable.add idkey_tbl key v;
     v
 
 let val_of_rel k = val_of_idkey (RelKey k)
-let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v))
 
 let val_of_named id = val_of_idkey (VarKey id)
-let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v))
 
 let val_of_constant c = val_of_idkey (ConstKey c)
-let val_of_constant_def n c v =
-  let res = Obj.new_block accu_tag 2 in
-  Obj.set_field res 0 (Obj.repr (mkAccuCond n));
-  Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v)));
-  val_of_obj res
 
 external val_of_annot_switch : annot_switch -> values = "%identity"
 
@@ -497,7 +502,7 @@ let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b)
 let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b)
 let bfield b i =
   if 0 <= i && i < (bsize b) then val_of_obj (Obj.field (Obj.repr b) i)
-  else raise (Invalid_argument "Vm.bfield")
+  else invalid_arg "Vm.bfield"
 
 
 (* Functions over vswitch *)
@@ -511,7 +516,7 @@ let type_of_switch sw =
   interprete sw.sw_type_code crazy_val sw.sw_env 0
 
 let branch_arg k (tag,arity) =
-  if arity = 0 then  ((Obj.magic tag):values)
+  if Int.equal arity 0 then  ((Obj.magic tag):values)
   else
     let b = Obj.new_block tag arity in
     for i = 0 to arity - 1 do
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 58228eb8..295ea83c 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -1,7 +1,6 @@
 open Names
 open Term
 open Cbytecodes
-open Cemitcodes
 
 (** Efficient Virtual Machine *)
 
@@ -25,9 +24,9 @@ type vswitch
 type arguments
 
 type atom =
-  | Aid of id_key
-  | Aiddef of id_key * values
-  | Aind of inductive
+  | Aid of Vars.id_key
+  | Aiddef of Vars.id_key * values
+  | Aind of pinductive
 
 (** Zippers *)
 
@@ -53,15 +52,9 @@ type whd =
 (** Constructors *)
 
 val val_of_str_const : structured_constant -> values
-
 val val_of_rel : int -> values
-val val_of_rel_def : int -> values -> values
-
-val val_of_named : identifier -> values
-val val_of_named_def : identifier -> values -> values
-
-val val_of_constant : constant -> values
-val val_of_constant_def : int -> constant -> values -> values
+val val_of_named : Id.t -> values
+val val_of_constant : pconstant -> values
 
 external val_of_annot_switch : annot_switch -> values = "%identity"
 
diff --git a/lib/aux_file.ml b/lib/aux_file.ml
new file mode 100644
index 00000000..c9018c9e
--- /dev/null
+++ b/lib/aux_file.ml
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* The file format is a header
+ *     ("COQAUX%d %s %s\n" version hex_hash path)
+ * followed by an arbitrary number of entries
+ *     ("%d %d %s %S\n" loc_begin loc_end key value)  *)
+
+open Filename
+
+let version = 1
+
+let oc = ref None
+
+let aux_file_name_for vfile =
+  dirname vfile ^ "/." ^ chop_extension(basename vfile) ^ ".aux"
+
+let mk_absolute vfile =
+  let vfile = CUnix.remove_path_dot vfile in
+  if Filename.is_relative vfile then CUnix.correct_path vfile (Sys.getcwd ())
+  else vfile
+
+let start_aux_file_for vfile =
+  let vfile = mk_absolute vfile in
+  oc := Some (open_out (aux_file_name_for vfile));
+  Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n"
+    version (Digest.to_hex (Digest.file vfile)) vfile
+
+let stop_aux_file () =
+  close_out (Option.get !oc);
+  oc := None
+
+let recording () = not (Option.is_empty !oc)
+
+module H = Map.Make(struct type t = int * int let compare = compare end)
+module M = Map.Make(String)
+type data = string M.t
+type aux_file = data H.t
+
+let empty_aux_file = H.empty
+
+let get aux loc key = M.find key (H.find (Loc.unloc loc) aux)
+
+let record_in_aux_at loc key v =
+  Option.iter (fun oc ->
+    let i, j = Loc.unloc loc in
+    Printf.fprintf oc "%d %d %s %S\n" i j key v)
+  !oc
+
+let current_loc = ref Loc.ghost
+
+let record_in_aux_set_at loc = current_loc := loc
+
+let record_in_aux key v = record_in_aux_at !current_loc key v
+
+let set h loc k v =
+  let m = try H.find loc h with Not_found -> M.empty in
+  H.add loc (M.add k v m) h
+
+let load_aux_file_for vfile =
+  let vfile = mk_absolute vfile in
+  let ret3 x y z = x, y, z in
+  let ret4 x y z t = x, y, z, t in
+  let h = ref empty_aux_file in
+  let add loc k v = h := set !h loc k v in
+  let aux_fname = aux_file_name_for vfile in
+  try
+    let ic = open_in aux_fname in
+    let ver, hash, fname = Scanf.fscanf ic "COQAUX%d %s %s\n" ret3 in
+    if ver <> version then raise (Failure "aux file version mismatch");
+    if fname <> vfile then
+      raise (Failure "aux file name mismatch");
+    let only_dummyloc = Digest.to_hex (Digest.file vfile) <> hash in
+    while true do
+      let i, j, k, v = Scanf.fscanf ic "%d %d %s %S\n" ret4 in
+      if not only_dummyloc || (i = 0 && j = 0) then add (i,j) k v;
+    done;
+    raise End_of_file
+  with
+  | End_of_file -> !h
+  | Sys_error s | Scanf.Scan_failure s
+  | Failure s | Invalid_argument s ->
+     Flags.if_verbose
+       Pp.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s);
+     empty_aux_file
+
+let set h loc k v = set h (Loc.unloc loc) k v
diff --git a/parsing/tactic_printer.mli b/lib/aux_file.mli
index 2348706f..e340fc65 100644
--- a/parsing/tactic_printer.mli
+++ b/lib/aux_file.mli
@@ -1,23 +1,22 @@
 (************************************************************************)
 (*  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 Sign
-open Evd
-open Tacexpr
-open Proof_type
+type aux_file
 
-(** These are the entry points for tactics, proof trees, ... *)
+val load_aux_file_for : string -> aux_file
+val get : aux_file -> Loc.t -> string -> string
+val empty_aux_file : aux_file
+val set : aux_file -> Loc.t -> string -> string -> aux_file
 
-val print_proof : evar_map -> named_context -> proof_tree -> std_ppcmds
-val pr_rule     : rule -> std_ppcmds
-val pr_tactic   : tactic_expr -> std_ppcmds
-val print_script :
-  ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds
-val print_treescript :
-  ?nochange:bool -> evar_map -> proof_tree -> std_ppcmds
+val start_aux_file_for : string -> unit
+val stop_aux_file : unit -> unit 
+val recording : unit -> bool
+
+val record_in_aux_at : Loc.t -> string -> string -> unit
+val record_in_aux : string -> string -> unit
+val record_in_aux_set_at : Loc.t -> unit
diff --git a/lib/backtrace.ml b/lib/backtrace.ml
new file mode 100644
index 00000000..b3b8bdea
--- /dev/null
+++ b/lib/backtrace.ml
@@ -0,0 +1,116 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type raw_frame =
+| Known_location of bool   (* is_raise *)
+  * string (* filename *)
+  * int    (* line number *)
+  * int    (* start char *)
+  * int    (* end char *)
+| Unknown_location of bool (*is_raise*)
+
+type location = {
+  loc_filename : string;
+  loc_line : int;
+  loc_start : int;
+  loc_end : int;
+}
+
+type frame = { frame_location : location option; frame_raised : bool; }
+
+external get_exception_backtrace: unit -> raw_frame array option
+  = "caml_get_exception_backtrace"
+
+type t = raw_frame array list
+(** List of partial raw stack frames, in reverse order *)
+
+let empty = []
+
+let of_raw = function
+| Unknown_location r ->
+  { frame_location = None; frame_raised = r; }
+| Known_location (r, file, line, st, en) ->
+  let loc = {
+    loc_filename = file;
+    loc_line = line;
+    loc_start = st;
+    loc_end = en;
+  } in
+  { frame_location = Some loc; frame_raised = r; }
+
+let rec repr_aux accu = function
+| [] -> accu
+| fragment :: stack ->
+  let len = Array.length fragment in
+  let rec append accu i =
+    if i = len then accu
+    else append (of_raw fragment.(i) :: accu) (succ i)
+  in
+  repr_aux (append accu 0) stack
+
+let repr bt = repr_aux [] (List.rev bt)
+
+let push stack = match get_exception_backtrace () with
+| None -> []
+| Some frames -> frames :: stack
+
+(** Utilities *)
+
+let print_frame frame =
+  let raise = if frame.frame_raised then "raise" else "frame" in
+  match frame.frame_location with
+  | None -> Printf.sprintf "%s @ unknown" raise
+  | Some loc ->
+    Printf.sprintf "%s @ file \"%s\", line %d, characters %d-%d"
+      raise loc.loc_filename loc.loc_line loc.loc_start loc.loc_end
+
+(** Exception manipulation *)
+
+let backtrace : t Exninfo.t = Exninfo.make ()
+
+let is_recording = ref false
+
+let record_backtrace b =
+  let () = Printexc.record_backtrace b in
+  is_recording := b
+
+let get_backtrace e =
+  Exninfo.get e backtrace
+
+let add_backtrace e =
+  if !is_recording then
+    (** This must be the first function call, otherwise the stack may be
+        destroyed *)
+    let current = get_exception_backtrace () in
+    let info = Exninfo.info e in
+    begin match current with
+    | None -> (e, info)
+    | Some fragment ->
+      let bt = match get_backtrace info with
+      | None -> []
+      | Some bt -> bt
+      in
+      let bt = fragment :: bt in
+      (e, Exninfo.add info backtrace bt)
+    end
+  else
+    let info = Exninfo.info e in
+    (e, info)
+
+let app_backtrace ~src ~dst =
+  if !is_recording then
+    match get_backtrace src with
+    | None -> dst
+    | Some bt ->
+      match get_backtrace dst with
+      | None ->
+        Exninfo.add dst backtrace bt
+      | Some nbt ->
+        let bt = bt @ nbt in
+        Exninfo.add dst backtrace bt
+  else dst
diff --git a/lib/backtrace.mli b/lib/backtrace.mli
new file mode 100644
index 00000000..dd82165b
--- /dev/null
+++ b/lib/backtrace.mli
@@ -0,0 +1,96 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** * Low-level management of OCaml backtraces.
+
+  Currently, OCaml manages its backtraces in a very imperative way. That is to
+  say, it only keeps track of the stack destroyed by the last raised exception.
+  So we have to be very careful when using this module not to do silly things.
+
+  Basically, you need to manually handle the reraising of exceptions. In order
+  to do so, each time the backtrace is lost, you must [push] the stack fragment.
+  This essentially occurs whenever a [with] handler is crossed.
+
+*)
+
+(** {5 Backtrace information} *)
+
+type location = {
+  loc_filename : string;
+  loc_line : int;
+  loc_start : int;
+  loc_end : int;
+}
+(** OCaml debugging information for function calls. *)
+
+type frame = { frame_location : location option; frame_raised : bool; }
+(** A frame contains two informations: its optional physical location, and
+    whether it raised the exception or let it pass through. *)
+
+type t
+(** Type of backtraces. They're essentially stack of frames. *)
+
+val empty : t
+(** Empty frame stack. *)
+
+val push : t -> t
+(** Add the current backtrace information to a given backtrace. *)
+
+val repr : t -> frame list
+(** Represent a backtrace as a list of frames. Leftmost element is the outermost
+    call. *)
+
+(** {5 Utilities} *)
+
+val print_frame : frame -> string
+(** Represent a frame. *)
+
+(** {5 Exception handling} *)
+
+val record_backtrace : bool -> unit
+(** Whether to activate the backtrace recording mechanism. Note that it will
+    only work whenever the program was compiled with the [debug] flag. *)
+
+val get_backtrace : Exninfo.info -> t option
+(** Retrieve the optional backtrace coming with the exception. *)
+
+val add_backtrace : exn -> Exninfo.iexn
+(** Add the current backtrace information to the given exception.
+
+    The intended use case is of the form: {[
+
+    try foo
+      with
+      | Bar -> bar
+      | err -> let err = add_backtrace err in baz
+
+    ]}
+
+    WARNING: any intermediate code between the [with] and the handler may
+    modify the backtrace. Yes, that includes [when] clauses. Ideally, what you
+    should do is something like: {[
+
+    try foo
+      with err ->
+        let err = add_backtrace err in
+        match err with
+        | Bar -> bar
+        | err -> baz
+
+    ]}
+
+    I admit that's a bit heavy, but there is not much to do...
+
+*)
+
+val app_backtrace : src:Exninfo.info -> dst:Exninfo.info -> Exninfo.info
+(** Append the backtrace from [src] to [dst]. The returned exception is [dst]
+    except for its backtrace information. This is targeted at container
+    exceptions, that is, exceptions that contain exceptions. This way, one can
+    transfer the backtrace from the container to the underlying exception, as if
+    the latter was the one originally raised. *)
diff --git a/lib/bigint.ml b/lib/bigint.ml
index 42a71f83..e739c7a1 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.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        *)
@@ -43,11 +43,11 @@ let size =
 
 let format_size =
   (* How to parametrize a printf format *)
-  if size = 4 then Printf.sprintf "%04d"
-  else if size = 9 then Printf.sprintf "%09d"
+  if Int.equal size 4 then Printf.sprintf "%04d"
+  else if Int.equal size 9 then Printf.sprintf "%09d"
   else fun n ->
     let rec aux j l n =
-      if j=size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
+      if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10)
     in String.concat "" (aux 0 [] n)
 
 (* The base is 10^size *)
@@ -63,27 +63,31 @@ module ArrayInt = struct
 
 (* Basic numbers *)
 let zero = [||]
-let neg_one = [|-1|]
+
+let is_zero = function
+| [||] -> true
+| _ -> false
 
 (* An array is canonical when
    - it is empty
    - it is [|-1|]
    - its first bloc is in [-base;-1[U]0;base[
      and the other blocs are in [0;base[. *)
-
+(*
 let canonical n =
   let ok x = (0 <= x && x < base) in
-  let rec ok_tail k = (k = 0) || (ok n.(k) && ok_tail (k-1)) in
-  let ok_init x = (-base <= x && x < base && x <> -1 && x <> 0)
+  let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in
+  let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0))
   in
-  (n = [||]) || (n = [|-1|]) ||
+  (is_zero n) || (match n with [|-1|] -> true | _ -> false) ||
     (ok_init n.(0) && ok_tail (Array.length n - 1))
+*)
 
 (* [normalize_pos] : removing initial blocks of 0 *)
 
 let normalize_pos n =
   let k = ref 0 in
-  while !k < Array.length n & n.(!k) = 0 do incr k done;
+  while !k < Array.length n && Int.equal n.(!k) 0 do incr k done;
   Array.sub n !k (Array.length n - !k)
 
 (* [normalize_neg] : avoid (-1) as first bloc.
@@ -92,32 +96,32 @@ let normalize_pos n =
 
 let normalize_neg n =
   let k = ref 1 in
-  while !k < Array.length n & n.(!k) = base - 1 do incr k done;
+  while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done;
   let n' = Array.sub n !k (Array.length n - !k) in
-  if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
+  if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n')
 
 (* [normalize] : avoid 0 and (-1) as first bloc.
    input: an array with first bloc in [-base;base[ and others in [0;base[
    output: a canonical array *)
 
-let rec normalize n =
-  if Array.length n = 0 then n
-  else if n.(0) = -1 then normalize_neg n
-  else if n.(0) = 0 then normalize_pos n
+let normalize n =
+  if Int.equal (Array.length n) 0 then n
+  else if Int.equal n.(0) (-1) then normalize_neg n
+  else if Int.equal n.(0) 0 then normalize_pos n
   else n
 
 (* Opposite (expects and returns canonical arrays) *)
 
 let neg m =
-  if m = zero then zero else
+  if is_zero m then zero else
   let n = Array.copy m in
   let i = ref (Array.length m - 1) in
-  while !i > 0 & n.(!i) = 0 do decr i done;
-  if !i = 0 then begin
+  while !i > 0 && Int.equal n.(!i) 0 do decr i done;
+  if Int.equal !i 0 then begin
     n.(0) <- - n.(0);
     (* n.(0) cannot be 0 since m is canonical *)
-    if n.(0) = -1 then normalize_neg n
-    else if n.(0) = base then (n.(0) <- 0; Array.append [| 1 |] n)
+    if Int.equal n.(0) (-1) then normalize_neg n
+    else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n)
     else n
   end else begin
     (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *)
@@ -132,10 +136,10 @@ let neg m =
 
 let push_carry r j =
   let j = ref j in
-  while !j > 0 & r.(!j) < 0 do
+  while !j > 0 && r.(!j) < 0 do
     r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1
   done;
-  while !j > 0 & r.(!j) >= base do
+  while !j > 0 && r.(!j) >= base do
     r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1
   done;
   (* here r.(0) could be in [-2*base;2*base-1] *)
@@ -144,7 +148,7 @@ let push_carry r j =
   else normalize r (* in case r.(0) is 0 or -1 *)
 
 let add_to r a j =
-  if a = zero then r else begin
+  if is_zero a then r else begin
   for i = Array.length r - 1 downto j+1 do
     r.(i) <- r.(i) + a.(i-j);
     if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1)
@@ -158,7 +162,7 @@ let add n m =
   if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d)
 
 let sub_to r a j =
-  if a = zero then r else begin
+  if is_zero a then r else begin
   for i = Array.length r - 1 downto j+1 do
     r.(i) <- r.(i) - a.(i-j);
     if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1)
@@ -172,10 +176,10 @@ let sub n m =
   if d >= 0 then sub_to (Array.copy n) m d
   else let r = neg m in add_to r n (Array.length r - Array.length n)
 
-let rec mult m n =
-  if m = zero or n = zero then zero else
+let mult m n =
+  if is_zero m || is_zero n then zero else
   let l = Array.length m + Array.length n in
-  let r = Array.create l 0 in
+  let r = Array.make l 0 in
   for i = Array.length m - 1 downto 0 do
     for j = Array.length n - 1 downto 0 do
       let p = m.(i) * n.(j) + r.(i+j+1) in
@@ -184,49 +188,62 @@ let rec mult m n =
         then (p + 1) / base - 1, (p + 1) mod base + base - 1
         else p / base, p mod base in
       r.(i+j+1) <- s;
-      if q <> 0 then r.(i+j) <- r.(i+j) + q;
+      if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q;
     done
   done;
   normalize r
 
 (* Comparisons *)
 
-let is_strictly_neg n = n<>[||] && n.(0) < 0
-let is_strictly_pos n = n<>[||] && n.(0) > 0
-let is_neg_or_zero n = n=[||] or n.(0) < 0
-let is_pos_or_zero n = n=[||] or n.(0) > 0
+let is_strictly_neg n = not (is_zero n) && n.(0) < 0
+let is_strictly_pos n = not (is_zero n) && n.(0) > 0
+let is_neg_or_zero n = is_zero n || n.(0) < 0
+let is_pos_or_zero n = is_zero n || n.(0) > 0
+
+(* Is m without its i first blocs less then n without its j first blocs ?
+   Invariant : |m|-i = |n|-j *)
 
 let rec less_than_same_size m n i j =
   i < Array.length m &&
-  (m.(i) < n.(j) or (m.(i) = n.(j) && less_than_same_size m n (i+1) (j+1)))
+  (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1)))
 
 let less_than m n =
   if is_strictly_neg m then
-    is_pos_or_zero n or Array.length m > Array.length n
-      or (Array.length m = Array.length n && less_than_same_size m n 0 0)
+    is_pos_or_zero n || Array.length m > Array.length n
+      || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)
   else
-    is_strictly_pos n && (Array.length m < Array.length n or
-    (Array.length m = Array.length n && less_than_same_size m n 0 0))
+    is_strictly_pos n && (Array.length m < Array.length n ||
+    (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0))
 
 (* For this equality test it is critical that n and m are canonical *)
 
-let equal m n = (m = n)
+let rec array_eq len v1 v2 i =
+  if Int.equal len i then true
+  else
+    Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i)
+
+let equal m n =
+  let lenm = Array.length m in
+  let lenn = Array.length n in
+  (Int.equal lenm lenn) && (array_eq lenm m n 0)
+
+(* Is m without its k top blocs less than n ? *)
 
 let less_than_shift_pos k m n =
   (Array.length m - k < Array.length n)
-  or (Array.length m - k = Array.length n && less_than_same_size m n k 0)
+  || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0)
 
 let rec can_divide k m d i =
-  (i = Array.length d) or
-  (m.(k+i) > d.(i)) or
-  (m.(k+i) = d.(i) && can_divide k m d (i+1))
+  (Int.equal i (Array.length d)) ||
+  (m.(k+i) > d.(i)) ||
+  (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1))
 
 (* For two big nums m and d and a small number q,
    computes m - d * q * base^(|m|-|d|-k) in-place (in m).
    Both m d and q are positive. *)
 
 let sub_mult m d q k =
-  if q <> 0 then
+  if not (Int.equal q 0) then
   for i = Array.length d - 1 downto 0 do
     let v = d.(i) * q in
     m.(k+i) <- m.(k+i) - v mod base;
@@ -249,17 +266,17 @@ let euclid m d =
   let isnegm, m =
     if is_strictly_neg m then (-1),neg m else 1,Array.copy m in
   let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in
-  if d = zero then raise Division_by_zero;
+  if is_zero d then raise Division_by_zero;
   let q,r =
     if less_than m d then (zero,m) else
     let ql = Array.length m - Array.length d in
-    let q = Array.create (ql+1) 0 in
+    let q = Array.make (ql+1) 0 in
     let i = ref 0 in
     while not (less_than_shift_pos !i m d) do
-      if m.(!i)=0 then incr i else
+      if Int.equal m.(!i) 0 then incr i else
       if can_divide !i m d 0 then begin
         let v =
-          if Array.length d > 1 && d.(0) <> m.(!i) then
+          if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then
             (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1)
           else
             m.(!i) / d.(0) in
@@ -276,30 +293,30 @@ let euclid m d =
       end
     done;
     (normalize q, normalize m) in
-  (if isnegd * isnegm = -1 then neg q else q),
-  (if isnegm = -1 then neg r else r)
+  (if Int.equal (isnegd * isnegm) (-1) then neg q else q),
+  (if Int.equal isnegm (-1) then neg r else r)
 
 (* Parsing/printing ordinary 10-based numbers *)
 
 let of_string s =
   let len = String.length s in
-  let isneg = len > 1 & s.[0] = '-' in
+  let isneg = len > 1 && s.[0] == '-' in
   let d = ref (if isneg then 1 else 0) in
-  while !d < len && s.[!d] = '0' do incr d done;
-  if !d = len then zero else
+  while !d < len && s.[!d] == '0' do incr d done;
+  if Int.equal !d len then zero else
   let r = (len - !d) mod size in
   let h = String.sub s (!d) r in
-  let e = if h<>"" then 1 else 0 in
+  let e = match h with "" -> 0 | _ -> 1 in
   let l = (len - !d) / size in
-  let a = Array.create (l + e) 0 in
-  if e=1 then a.(0) <- int_of_string h;
-  for i=1 to l do
+  let a = Array.make (l + e) 0 in
+  if Int.equal e 1 then a.(0) <- int_of_string h;
+  for i = 1 to l do
     a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size)
   done;
   if isneg then neg a else a
 
 let to_string_pos sgn n =
-   if Array.length n = 0 then "0" else
+   if Int.equal (Array.length n) 0 then "0" else
      sgn ^
      String.concat ""
       (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n)))
@@ -337,7 +354,7 @@ let mkarray n =
   t
 
 let ints_of_int n =
-  if n = 0 then [| |]
+  if Int.equal n 0 then [| |]
   else if small n then [| n |]
   else mkarray n
 
@@ -346,8 +363,8 @@ let of_int n =
 
 let of_ints n =
   let n = normalize n in (* TODO: using normalize here seems redundant now *)
-  if n = zero then Obj.repr 0 else
-  if Array.length n = 1 then Obj.repr n.(0) else
+  if is_zero n then Obj.repr 0 else
+  if Int.equal (Array.length n) 1 then Obj.repr n.(0) else
   Obj.repr n
 
 let coerce_to_int = (Obj.magic : Obj.t -> int)
@@ -361,7 +378,7 @@ let int_of_ints =
   let maxi = mkarray max_int and mini = mkarray min_int in
   fun t ->
     let l = Array.length t in
-    if (l > 3) || (l = 3 && (less_than maxi t || less_than t mini))
+    if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini))
     then failwith "Bigint.to_int: too large";
     let sum = ref 0 in
     let pow = ref 1 in
@@ -379,28 +396,28 @@ let app_pair f (m, n) =
   (f m, f n)
 
 let add m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m + coerce_to_int n)
   else of_ints (add (to_ints m) (to_ints n))
 
 let sub m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m - coerce_to_int n)
   else of_ints (sub (to_ints m) (to_ints n))
 
 let mult m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then of_int (coerce_to_int m * coerce_to_int n)
   else of_ints (mult (to_ints m) (to_ints n))
 
 let euclid m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then app_pair of_int
     (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n)
   else app_pair of_ints (euclid (to_ints m) (to_ints n))
 
 let less_than m n =
-  if Obj.is_int m & Obj.is_int n
+  if Obj.is_int m && Obj.is_int n
   then coerce_to_int m < coerce_to_int n
   else less_than (to_ints m) (to_ints n)
 
@@ -420,14 +437,17 @@ let mult_2 n = add n n
 
 let div2_with_rest n =
   let (q,b) = euclid n two in
-  (q, b = one)
+  (q, b == one)
 
 let is_strictly_neg n = is_strictly_neg (to_ints n)
 let is_strictly_pos n = is_strictly_pos (to_ints n)
 let is_neg_or_zero n = is_neg_or_zero (to_ints n)
 let is_pos_or_zero n = is_pos_or_zero (to_ints n)
 
-let equal m n = (m = n)
+let equal m n =
+  if Obj.is_block m && Obj.is_block n then
+    ArrayInt.equal (Obj.obj m) (Obj.obj n)
+  else m == n
 
 (* spiwack: computes n^m *)
 (* The basic idea of the algorithm is that n^(2m) = (n^2)^m *)
@@ -441,7 +461,7 @@ let pow  =
       odd_rest
     else
       let quo = m lsr 1 (* i.e. m/2 *)
-      and odd = (m land 1) <> 0 in
+      and odd = not (Int.equal (m land 1) 0) in
       pow_aux
 	(if odd then mult n odd_rest else odd_rest)
 	(mult n n)
diff --git a/lib/bigint.mli b/lib/bigint.mli
index dd2cdea6..02e3c1ad 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.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        *)
@@ -11,6 +11,8 @@
 type bigint
 
 val of_string : string -> bigint
+(** May raise a Failure just as [int_of_string] on non-numerical strings *)
+
 val to_string : bigint -> string
 
 val of_int : int -> bigint
diff --git a/lib/cArray.ml b/lib/cArray.ml
new file mode 100644
index 00000000..16034543
--- /dev/null
+++ b/lib/cArray.ml
@@ -0,0 +1,528 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+  include S
+  val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+  val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+  val is_empty : 'a array -> bool
+  val exists : ('a -> bool) -> 'a array -> bool
+  val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all : ('a -> bool) -> 'a array -> bool
+  val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all3 : ('a -> 'b -> 'c -> bool) ->
+    'a array -> 'b array -> 'c array -> bool
+  val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+    'a array -> 'b array -> 'c array -> 'd array -> bool
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+  val findi : (int -> 'a -> bool) -> 'a array -> int option
+  val hd : 'a array -> 'a
+  val tl : 'a array -> 'a array
+  val last : 'a array -> 'a
+  val cons : 'a -> 'a array -> 'a array
+  val rev : 'a array -> unit
+  val fold_right_i :
+    (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+  val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val fold_right2 :
+    ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+  val fold_left2 :
+    ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left3 :
+    ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+  val fold_left2_i :
+    (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+  val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+  val chop : int -> 'a array -> 'a array * 'a array
+  val smartmap : ('a -> 'a) -> 'a array -> 'a array
+  val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+  val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+  val map_left : ('a -> 'b) -> 'a array -> 'b array
+  val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+  val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+  val fold_map2' :
+    ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+  val distinct : 'a array -> bool
+  val rev_of_list : 'a list -> 'a array
+  val rev_to_list : 'a array -> 'a list
+  val filter_with : bool list -> 'a array -> 'a array
+end
+
+include Array
+
+let uget = Array.unsafe_get
+
+(* Arrays *)
+
+let compare cmp v1 v2 =
+  if v1 == v2 then 0
+  else
+    let len = Array.length v1 in
+    let c = Int.compare len (Array.length v2) in
+    if c <> 0 then c else
+      let rec loop i =
+        if i < 0 then 0
+        else
+          let x = uget v1 i in
+          let y = uget v2 i in
+          let c = cmp x y in
+          if c <> 0 then c
+          else loop (i - 1)
+      in
+      loop (len - 1)
+
+let equal cmp t1 t2 =
+  if t1 == t2 then true else
+    let len = Array.length t1 in
+    if not (Int.equal len (Array.length t2)) then false
+    else
+      let rec aux i =
+        if i < 0 then true
+        else
+          let x = uget t1 i in
+          let y = uget t2 i in
+          cmp x y && aux (pred i)
+      in
+      aux (len - 1)
+
+let is_empty array = Int.equal (Array.length array) 0
+
+let exists f v =
+  let rec exrec = function
+    | -1 -> false
+    | n -> f (uget v n) || (exrec (n-1))
+  in
+  exrec ((Array.length v)-1)
+
+let exists2 f v1 v2 =
+  let rec exrec = function
+    | -1 -> false
+    | n -> f (uget v1 n) (uget v2 n) || (exrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && exrec (lv1-1)
+
+let for_all f v =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v n) in
+      ans && (allrec (n-1))
+  in
+  allrec ((Array.length v)-1)
+
+let for_all2 f v1 v2 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n) (uget v2 n) in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && allrec (pred lv1)
+
+let for_all3 f v1 v2 v3 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n)
+        (uget v2 n) (uget v3 n)
+      in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
+
+let for_all4 f v1 v2 v3 v4 =
+  let rec allrec = function
+    | -1 -> true
+    | n ->
+      let ans = f (uget v1 n)
+        (uget v2 n) (uget v3 n) (uget v4 n)
+      in
+      ans && (allrec (n-1))
+  in
+  let lv1 = Array.length v1 in
+  lv1 = Array.length v2 &&
+  lv1 = Array.length v3 &&
+  lv1 = Array.length v4 &&
+  allrec (pred lv1)
+
+let for_all_i f i v =
+  let len = Array.length v in
+  let rec allrec i n =
+    n = len || f i (uget v n) && allrec (i+1) (n+1) in
+  allrec i 0
+
+exception Found of int
+
+let findi (pred: int -> 'a -> bool) (arr: 'a array) : int option =
+  try
+    for i=0 to Array.length arr - 1 do
+      if pred i (uget arr i) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let hd v =
+  match Array.length v with
+    | 0 -> failwith "Array.hd"
+    | _ -> uget v 0
+
+let tl v =
+  match Array.length v with
+    | 0 -> failwith "Array.tl"
+    | n -> Array.sub v 1 (pred n)
+
+let last v =
+  match Array.length v with
+    | 0 -> failwith "Array.last"
+    | n -> uget v (pred n)
+
+let cons e v =
+  let len = Array.length v in
+  let ans = Array.make (Array.length v + 1) e in
+  let () = Array.blit v 0 ans 1 len in
+  ans
+
+let rev t =
+  let n=Array.length t in
+    if n <=0 then ()
+    else
+      for i = 0 to pred (n/2) do
+        let tmp = uget t ((pred n)-i) in
+        Array.unsafe_set t ((pred n)-i) (uget t i);
+        Array.unsafe_set t i tmp
+      done
+
+let fold_right_i f v a =
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f k (uget v k) a) k in
+  fold a (Array.length v)
+
+let fold_left_i f v a =
+  let n = Array.length a in
+  let rec fold i v = if i = n then v else fold (succ i) (f i v (uget a i)) in
+  fold 0 v
+
+let fold_right2 f v1 v2 a =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n=0 then a
+    else
+      let k = n-1 in
+      fold (f (uget v1 k) (uget v2 k) a) k in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_right2";
+  fold a lv1
+
+let fold_left2 f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a else fold (f a (uget v1 n) (uget v2 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left2_i f a v1 v2 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a else fold (f n a (uget v1 n) (uget v2 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 then invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left3 f a v1 v2 v3 =
+  let lv1 = Array.length v1 in
+  let rec fold a n =
+    if n >= lv1 then a
+    else fold (f a (uget v1 n) (uget v2 n) (uget v3 n)) (succ n)
+  in
+  if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
+    invalid_arg "Array.fold_left2";
+  fold a 0
+
+let fold_left_from n f a v =
+  let len = Array.length v in
+  let () = if n < 0 then invalid_arg "Array.fold_left_from" in
+  let rec fold a n =
+    if n >= len then a else fold (f a (uget v n)) (succ n)
+  in
+  fold a n
+
+let rev_of_list = function
+| [] -> [| |]
+| x :: l ->
+  let len = List.length l in
+  let ans = Array.make (succ len) x in
+  let rec set i = function
+  | [] -> ()
+  | x :: l ->
+    Array.unsafe_set ans i x;
+    set (pred i) l
+  in
+  let () = set (len - 1) l in
+  ans
+
+let map_to_list f v =
+  List.map f (Array.to_list v)
+
+let map_of_list f l =
+  let len = List.length l in
+  let rec fill i v = function
+  | [] -> ()
+  | x :: l ->
+    Array.unsafe_set v i (f x);
+    fill (succ i) v l
+  in
+  match l with
+  | [] -> [||]
+  | x :: l ->
+    let ans = Array.make len (f x) in
+    let () = fill 1 ans l in
+    ans
+
+let chop n v =
+  let vlen = Array.length v in
+  if n > vlen then failwith "Array.chop";
+  (Array.sub v 0 n, Array.sub v n (vlen-n))
+
+(* If none of the elements is changed by f we return ar itself.
+   The while loop looks for the first such an element.
+   If found, we break here and the new array is produced,
+   but f is not re-applied to elements that are already checked *)
+let smartmap f (ar : 'a array) =
+  let len = Array.length ar in
+  let i = ref 0 in
+  let break = ref true in
+  let temp = ref None in
+  while !break && (!i < len) do
+    let v = Array.unsafe_get ar !i in
+    let v' = f v in
+    if v == v' then incr i
+    else begin
+      break := false;
+      temp := Some v';
+    end
+  done;
+  if !i < len then begin
+    (** The array is not the same as the original one *)
+    let ans : 'a array = Array.copy ar in
+    let v = match !temp with None -> assert false | Some x -> x in
+    Array.unsafe_set ans !i v;
+    incr i;
+    while !i < len do
+      let v = Array.unsafe_get ar !i in
+      let v' = f v in
+      if v != v' then Array.unsafe_set ans !i v';
+      incr i
+    done;
+    ans
+  end else ar
+
+(** Same as [smartmap] but threads a state meanwhile *)
+let smartfoldmap f accu (ar : 'a array) =
+  let len = Array.length ar in
+  let i = ref 0 in
+  let break = ref true in
+  let r = ref accu in
+  (** This variable is never accessed unset *)
+  let temp = ref None in
+  while !break && (!i < len) do
+    let v = Array.unsafe_get ar !i in
+    let (accu, v') = f !r v in
+    r := accu;
+    if v == v' then incr i
+    else begin
+      break := false;
+      temp := Some v';
+    end
+  done;
+  if !i < len then begin
+    let ans : 'a array = Array.copy ar in
+    let v = match !temp with None -> assert false | Some x -> x in
+    Array.unsafe_set ans !i v;
+    incr i;
+    while !i < len do
+      let v = Array.unsafe_get ar !i in
+      let (accu, v') = f !r v in
+      r := accu;
+      if v != v' then Array.unsafe_set ans !i v';
+      incr i
+    done;
+    !r, ans
+  end else !r, ar
+
+let map2 f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f (uget v1 0) (uget v2 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f (uget v1 i) (uget v2 i))
+    done;
+    res
+  end
+
+let map2_i f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len1 len2) then invalid_arg "Array.map2" in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f i (uget v1 i) (uget v2 i))
+    done;
+    res
+  end
+
+let map3 f v1 v2 v3 =
+  let len1 = Array.length v1 in
+  let () =
+    if len1 <> Array.length v2 || len1 <> Array.length v3
+    then invalid_arg "Array.map3"
+  in
+  if Int.equal len1 0 then
+    [| |]
+  else begin
+    let res = Array.make len1 (f (uget v1 0) (uget v2 0) (uget v3 0)) in
+    for i = 1 to pred len1 do
+      Array.unsafe_set res i (f (uget v1 i) (uget v2 i) (uget v3 i))
+    done;
+    res
+  end
+
+let map_left f a = (* Ocaml does not guarantee Array.map is LR *)
+  let l = Array.length a in (* (even if so), then we rewrite it *)
+  if Int.equal l 0 then [||] else begin
+    let r = Array.make l (f (uget a 0)) in
+    for i = 1 to l - 1 do
+      Array.unsafe_set r i (f (uget a i))
+    done;
+    r
+  end
+
+let iter2 f v1 v2 =
+  let len1 = Array.length v1 in
+  let len2 = Array.length v2 in
+  let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in
+  for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) done
+
+let pure_functional = false
+
+let fold_map' f v e =
+if pure_functional then
+  let (l,e) =
+    Array.fold_right
+      (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
+      v ([],e) in
+  (Array.of_list l,e)
+else
+  let e' = ref e in
+  let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
+  (v',!e')
+
+let fold_map f e v =
+  let e' = ref e in
+  let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
+  (!e',v')
+
+let fold_map2' f v1 v2 e =
+  let e' = ref e in
+  let v' =
+    map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
+  in
+  (v',!e')
+
+
+let distinct v =
+  let visited = Hashtbl.create 23 in
+  try
+    Array.iter
+      (fun x ->
+        if Hashtbl.mem visited x then raise Exit
+        else Hashtbl.add visited x x)
+      v;
+    true
+  with Exit -> false
+
+let rev_to_list a =
+  let rec tolist i res =
+    if i >= Array.length a then res else tolist (i+1) (uget a i :: res) in
+  tolist 0 []
+
+let filter_with filter v =
+  Array.of_list (CList.filter_with filter (Array.to_list v))
+
+module Fun1 =
+struct
+
+  let map f arg v = match v with
+  | [| |] -> [| |]
+  | _ ->
+    let len = Array.length v in
+    let x0 = Array.unsafe_get v 0 in
+    let ans = Array.make len (f arg x0) in
+    for i = 1 to pred len do
+      let x = Array.unsafe_get v i in
+      Array.unsafe_set ans i (f arg x)
+    done;
+    ans
+
+  let smartmap f arg (ar : 'a array) =
+    let len = Array.length ar in
+    let i = ref 0 in
+    let break = ref true in
+    let temp = ref None in
+    while !break && (!i < len) do
+      let v = Array.unsafe_get ar !i in
+      let v' = f arg v in
+      if v == v' then incr i
+      else begin
+        break := false;
+        temp := Some v';
+      end
+    done;
+    if !i < len then begin
+      (** The array is not the same as the original one *)
+      let ans : 'a array = Array.copy ar in
+      let v = match !temp with None -> assert false | Some x -> x in
+      Array.unsafe_set ans !i v;
+      incr i;
+      while !i < len do
+        let v = Array.unsafe_get ar !i in
+        let v' = f arg v in
+        if v != v' then Array.unsafe_set ans !i v';
+        incr i
+      done;
+      ans
+    end else ar
+
+  let iter f arg v =
+    let len = Array.length v in
+    for i = 0 to pred len do
+      let x = uget v i in
+      f arg x
+    done
+
+end
diff --git a/lib/cArray.mli b/lib/cArray.mli
new file mode 100644
index 00000000..39c35e2d
--- /dev/null
+++ b/lib/cArray.mli
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+module type S = module type of Array
+
+module type ExtS =
+sig
+  include S
+  val compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
+  (** First size comparison, then lexicographic order. *)
+
+  val equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
+  (** Lift equality to array type. *)
+
+  val is_empty : 'a array -> bool
+  (** True whenever the array is empty. *)
+
+  val exists : ('a -> bool) -> 'a array -> bool
+  (** As [List.exists] but on arrays. *)
+
+  val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+
+  val for_all : ('a -> bool) -> 'a array -> bool
+  val for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
+  val for_all3 : ('a -> 'b -> 'c -> bool) ->
+    'a array -> 'b array -> 'c array -> bool
+  val for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
+    'a array -> 'b array -> 'c array -> 'd array -> bool
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
+
+  val findi : (int -> 'a -> bool) -> 'a array -> int option
+
+  val hd : 'a array -> 'a
+  (** First element of an array, or [Failure "Array.hd"] if empty. *)
+
+  val tl : 'a array -> 'a array
+  (** Remaining part of [hd], or [Failure "Array.tl"] if empty. *)
+
+  val last : 'a array -> 'a
+  (** Last element of an array, or [Failure "Array.last"] if empty. *)
+
+  val cons : 'a -> 'a array -> 'a array
+  (** Append an element on the left. *)
+
+  val rev : 'a array -> unit
+  (** In place reversal. *)
+
+  val fold_right_i :
+    (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
+  val fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+  val fold_right2 :
+    ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+  val fold_left2 :
+    ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left3 :
+    ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
+  val fold_left2_i :
+    (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+  val fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+
+  val map_to_list : ('a -> 'b) -> 'a array -> 'b list
+  (** Composition of [map] and [to_list]. *)
+
+  val map_of_list : ('a -> 'b) -> 'a list -> 'b array
+  (** Composition of [map] and [of_list]. *)
+
+  val chop : int -> 'a array -> 'a array * 'a array
+  (** [chop i a] returns [(a1, a2)] s.t. [a = a1 + a2] and [length a1 = n].
+      Raise [Failure "Array.chop"] if [i] is not a valid index. *)
+
+  val smartmap : ('a -> 'a) -> 'a array -> 'a array
+  (** [smartmap f a] behaves as [map f a] but returns [a] instead of a copy when
+      [f x == x] for all [x] in [a]. *)
+
+  val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array
+  (** Same as [smartmap] but threads an additional state left-to-right. *)
+
+  val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
+
+  val map_left : ('a -> 'b) -> 'a array -> 'b array
+  (** As [map] but guaranteed to be left-to-right. *)
+
+  val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
+  (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *)
+
+  val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
+  val fold_map2' :
+    ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
+
+  val distinct : 'a array -> bool
+  (** Return [true] if every element of the array is unique (for default 
+      equality). *)
+
+  val rev_of_list : 'a list -> 'a array
+  (** [rev_of_list l] is equivalent to [Array.of_list (List.rev l)]. *)
+
+  val rev_to_list : 'a array -> 'a list
+  (** [rev_to_list a] is equivalent to [List.rev (List.of_array a)]. *)
+
+  val filter_with : bool list -> 'a array -> 'a array
+  (** [filter_with b a] selects elements of [a] whose corresponding element in
+      [b] is [true].  Raise [Invalid_argument _] when sizes differ. *)
+
+end
+
+include ExtS
+
+module Fun1 :
+sig
+  val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array
+  (** [Fun1.map f x v = map (f x) v] *)
+
+  val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array
+  (** [Fun1.smartmap f x v = smartmap (f x) v] *)
+
+  val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit
+  (** [Fun1.iter f x v = iter (f x) v] *)
+
+end
+(** The functions defined in this module are the same as the main ones, except
+    that they are all higher-order, and their function arguments have an
+    additional parameter. This allows us to prevent closure creation in critical
+    cases. *)
diff --git a/lib/cList.ml b/lib/cList.ml
new file mode 100644
index 00000000..0ac372d8
--- /dev/null
+++ b/lib/cList.ml
@@ -0,0 +1,785 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+module type S = module type of List
+
+module type ExtS =
+sig
+  include S
+  val compare : 'a cmp -> 'a list cmp
+  val equal : 'a eq -> 'a list eq
+  val is_empty : 'a list -> bool
+  val init : int -> (int -> 'a) -> 'a list
+  val mem_f : 'a eq -> 'a -> 'a list -> bool
+  val add_set : 'a eq -> 'a -> 'a list -> 'a list
+  val eq_set : 'a eq -> 'a list -> 'a list -> bool
+  val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+  val union : 'a eq -> 'a list -> 'a list -> 'a list
+  val unionq : 'a list -> 'a list -> 'a list
+  val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+  val subtractq : 'a list -> 'a list -> 'a list
+  val interval : int -> int -> int list
+  val make : int -> 'a -> 'a list
+  val assign : 'a list -> int -> 'a -> 'a list
+  val distinct : 'a list -> bool
+  val distinct_f : 'a cmp -> 'a list -> bool
+  val duplicates : 'a eq -> 'a list -> 'a list
+  val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+  val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+  val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+  val filter_with : bool list -> 'a list -> 'a list
+  val smartmap : ('a -> 'a) -> 'a list -> 'a list
+  val map_left : ('a -> 'b) -> 'a list -> 'b list
+  val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+  val map2_i :
+    (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+  val map4 :
+    ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
+  val filteri :
+    (int -> 'a -> bool) -> 'a list -> 'a list
+  val smartfilter : ('a -> bool) -> 'a list -> 'a list
+  val index : 'a eq -> 'a -> 'a list -> int
+  val index0 : 'a eq -> 'a -> 'a list -> int
+  val iteri :  (int -> 'a -> unit) -> 'a list -> unit
+  val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+  val fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+  val fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+  val fold_right_and_left :
+      ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+  val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+  val except : 'a eq -> 'a -> 'a list -> 'a list
+  val remove : 'a eq -> 'a -> 'a list -> 'a list
+  val remove_first : ('a -> bool) -> 'a list -> 'a list
+  val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+  val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+  val sep_last : 'a list -> 'a * 'a list
+  val find_map : ('a -> 'b option) -> 'a list -> 'b
+  val uniquize : 'a list -> 'a list
+  val sort_uniquize : 'a cmp -> 'a list -> 'a list
+  val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+  val subset : 'a list -> 'a list -> bool
+  val chop : int -> 'a list -> 'a list * 'a list
+  exception IndexOutOfRange
+  val goto : int -> 'a list -> 'a list * 'a list
+  val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+  val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+  val firstn : int -> 'a list -> 'a list
+  val last : 'a list -> 'a
+  val lastn : int -> 'a list -> 'a list
+  val skipn : int -> 'a list -> 'a list
+  val skipn_at_least : int -> 'a list -> 'a list
+  val addn : int -> 'a -> 'a list -> 'a list
+  val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+  val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+  val drop_last : 'a list -> 'a list
+  val map_append : ('a -> 'b list) -> 'a list -> 'b list
+  val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+  val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+  val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+  val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+  val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+  val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+  val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+  val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+  val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+  val combinations : 'a list list -> 'a list list
+  val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+  val cartesians_filter :
+    ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+  val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+  module type MonoS = sig
+    type elt
+    val equal : elt list -> elt list -> bool
+    val mem : elt -> elt list -> bool
+    val assoc : elt -> (elt * 'a) list -> 'a
+    val mem_assoc : elt -> (elt * 'a) list -> bool
+    val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+    val mem_assoc_sym : elt -> ('a * elt) list -> bool
+  end
+
+end
+
+include List
+
+(** Tail-rec implementation of usual functions. This is a well-known trick used
+    in, for instance, ExtLib and Batteries. *)
+
+type 'a cell = {
+  head : 'a;
+  mutable tail : 'a list;
+}
+
+external cast : 'a cell -> 'a list = "%identity"
+
+let rec map_loop f p = function
+| [] -> ()
+| x :: l ->
+  let c = { head = f x; tail = [] } in
+  p.tail <- cast c;
+  map_loop f c l
+
+let map f = function
+| [] -> []
+| x :: l ->
+  let c = { head = f x; tail = [] } in
+  map_loop f c l;
+  cast c
+
+let rec map2_loop f p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  let c = { head = f x y; tail = [] } in
+  p.tail <- cast c;
+  map2_loop f c l1 l2
+| _ -> invalid_arg "List.map2"
+
+let map2 f l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+  let c = { head = f x y; tail = [] } in
+  map2_loop f c l1 l2;
+  cast c
+| _ -> invalid_arg "List.map2"
+
+let rec append_loop p tl = function
+| [] -> p.tail <- tl
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  p.tail <- cast c;
+  append_loop c tl l
+
+let append l1 l2 = match l1 with
+| [] -> l2
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  append_loop c l2 l;
+  cast c
+
+let rec copy p = function
+| [] -> p
+| x :: l ->
+  let c = { head = x; tail = [] } in
+  p.tail <- cast c;
+  copy c l
+
+let rec init_loop len f p i =
+  if Int.equal i len then ()
+  else
+    let c = { head = f i; tail = [] } in
+    p.tail <- cast c;
+    init_loop len f c (succ i)
+
+let init len f =
+  if len < 0 then invalid_arg "List.init"
+  else if Int.equal len 0 then []
+  else
+    let c = { head = f 0; tail = [] } in
+    init_loop len f c 1;
+    cast c
+
+let rec concat_loop p = function
+| [] -> ()
+| x :: l -> concat_loop (copy p x) l
+
+let concat l =
+  let dummy = { head = Obj.magic 0; tail = [] } in
+  concat_loop dummy l;
+  dummy.tail
+
+let flatten = concat
+
+let rec split_loop p q = function
+| [] -> ()
+| (x, y) :: l ->
+  let cl = { head = x; tail = [] } in
+  let cr = { head = y; tail = [] } in
+  p.tail <- cast cl;
+  q.tail <- cast cr;
+  split_loop cl cr l
+
+let split = function
+| [] -> [], []
+| (x, y) :: l ->
+  let cl = { head = x; tail = [] } in
+  let cr = { head = y; tail = [] } in
+  split_loop cl cr l;
+  (cast cl, cast cr)
+
+let rec combine_loop p l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  let c = { head = (x, y); tail = [] } in
+  p.tail <- cast c;
+  combine_loop c l1 l2
+| _ -> invalid_arg "List.combine"
+
+let combine l1 l2 = match l1, l2 with
+| [], [] -> []
+| x :: l1, y :: l2 ->
+  let c = { head = (x, y); tail = [] } in
+  combine_loop c l1 l2;
+  cast c
+| _ -> invalid_arg "List.combine"
+
+let rec filter_loop f p = function
+| [] -> ()
+| x :: l ->
+  if f x then
+    let c = { head = x; tail = [] } in
+    let () = p.tail <- cast c in
+    filter_loop f c l
+  else
+    filter_loop f p l
+
+let filter f l =
+  let c = { head = Obj.magic 0; tail = [] } in
+  filter_loop f c l;
+  c.tail
+
+(** FIXME: Already present in OCaml 4.00 *)
+
+let rec map_i_loop f i p = function
+| [] -> ()
+| x :: l ->
+  let c = { head = f i x; tail = [] } in
+  p.tail <- cast c;
+  map_i_loop f (succ i) c l
+
+let map_i f i = function
+| [] -> []
+| x :: l ->
+  let c = { head = f i x; tail = [] } in
+  map_i_loop f (succ i) c l;
+  cast c
+
+(** Extensions of OCaml Stdlib *)
+
+let rec compare cmp l1 l2 =
+  if l1 == l2 then 0 else
+  match l1,l2 with
+      [], [] -> 0
+    | _::_, [] -> 1
+    | [], _::_ -> -1
+    | x1::l1, x2::l2 ->
+        (match cmp x1 x2 with
+           | 0 -> compare cmp l1 l2
+           | c -> c)
+
+let rec equal cmp l1 l2 =
+  l1 == l2 ||
+  match l1, l2 with
+    | [], [] -> true
+    | x1 :: l1, x2 :: l2 ->
+      cmp x1 x2 && equal cmp l1 l2
+    | _ -> false
+
+let is_empty = function
+| [] -> true
+| _ -> false
+
+let mem_f cmp x l = List.exists (cmp x) l
+
+let intersect cmp l1 l2 =
+  filter (fun x -> mem_f cmp x l2) l1
+
+let union cmp l1 l2 =
+  let rec urec = function
+    | [] -> l2
+    | a::l -> if mem_f cmp a l2 then urec l else a::urec l
+  in
+  urec l1
+
+let subtract cmp l1 l2 =
+  if is_empty l2 then l1
+  else List.filter (fun x -> not (mem_f cmp x l2)) l1
+
+let unionq l1 l2 = union (==) l1 l2
+let subtractq l1 l2 = subtract (==) l1 l2
+
+let interval n m =
+  let rec interval_n (l,m) =
+    if n > m then l else interval_n (m::l, pred m)
+  in
+  interval_n ([], m)
+
+let addn n v =
+  let rec aux n l =
+    if Int.equal n 0 then l
+    else aux (pred n) (v :: l)
+  in
+  if n < 0 then invalid_arg "List.addn"
+  else aux n
+
+let make n v = addn n v []
+
+let assign l n e =
+  let rec assrec stk l i = match l, i with
+    | ((h::t), 0) -> List.rev_append stk (e :: t)
+    | ((h::t), n) -> assrec (h :: stk) t (pred n)
+    | ([], _) -> failwith "List.assign"
+  in
+  assrec [] l n
+
+let rec smartmap f l = match l with
+    [] -> l
+  | h::tl ->
+      let h' = f h and tl' = smartmap f tl in
+        if h'==h && tl'==tl then l
+        else h'::tl'
+
+let map_left = map
+
+let map2_i f i l1 l2 =
+  let rec map_i i = function
+    | ([], []) -> []
+    | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
+    | (_, _) -> invalid_arg "map2_i"
+  in
+  map_i i (l1,l2)
+
+let map3 f l1 l2 l3 =
+  let rec map = function
+    | ([], [], []) -> []
+    | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
+    | (_, _, _) -> invalid_arg "map3"
+  in
+  map (l1,l2,l3)
+
+let map4 f l1 l2 l3 l4 =
+  let rec map = function
+    | ([], [], [], []) -> []
+    | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
+    | (_, _, _, _) -> invalid_arg "map4"
+  in
+  map (l1,l2,l3,l4)
+
+let rec smartfilter f l = match l with
+    [] -> l
+  | h::tl ->
+      let tl' = smartfilter f tl in
+        if f h then
+          if tl' == tl then l
+          else h :: tl'
+        else tl'
+
+let rec index_f f x l n = match l with
+| [] -> raise Not_found
+| y :: l -> if f x y then n else index_f f x l (succ n)
+
+let index f x l = index_f f x l 1
+
+let index0 f x l = index_f f x l 0
+
+let fold_left_until f accu s =
+  let rec aux accu = function
+    | [] -> accu
+    | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs in
+  aux accu s
+
+let fold_right_i f i l =
+  let rec it_f i l a = match l with
+    | [] -> a
+    | b::l -> f (i-1) b (it_f (i-1) l a)
+  in
+  it_f (List.length l + i) l
+
+let fold_left_i f =
+  let rec it_list_f i a = function
+    | [] -> a
+    | b::l -> it_list_f (i+1) (f i a b) l
+  in
+  it_list_f
+
+let rec fold_left3 f accu l1 l2 l3 =
+  match (l1, l2, l3) with
+    ([], [], []) -> accu
+  | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3
+  | (_, _, _) -> invalid_arg "List.fold_left3"
+
+(* [fold_right_and_left f [a1;...;an] hd =
+   f (f (... (f (f hd
+                   an
+                   [an-1;...;a1])
+              an-1
+              [an-2;...;a1])
+         ...)
+        a2
+        [a1])
+     a1
+     []] *)
+
+let fold_right_and_left f l hd =
+  let rec aux tl = function
+    | [] -> hd
+    | a::l -> let hd = aux (a::tl) l in f hd a tl
+   in aux [] l
+
+let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l
+
+let for_all_i p =
+  let rec for_all_p i = function
+    | [] -> true
+    | a::l -> p i a && for_all_p (i+1) l
+  in
+  for_all_p
+
+let except cmp x l = List.filter (fun y -> not (cmp x y)) l
+
+let remove = except (* Alias *)
+
+let rec remove_first p = function
+  | b::l when p b -> l
+  | b::l -> b::remove_first p l
+  | [] -> raise Not_found
+
+let insert p v l =
+  let rec insrec = function
+    | [] -> [v]
+    | h::tl -> if p v h then v::h::tl else h::insrec tl
+  in
+  insrec l
+
+let add_set cmp x l = if mem_f cmp x l then l else x :: l
+
+(** List equality up to permutation (but considering multiple occurrences) *)
+
+let eq_set cmp l1 l2 =
+  let rec aux l1 = function
+  | [] -> is_empty l1
+  | a::l2 -> aux (remove_first (cmp a) l1) l2 in
+  try aux l1 l2 with Not_found -> false
+
+let for_all2eq f l1 l2 =
+  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
+
+let filteri p =
+  let rec filter_i_rec i = function
+    | [] -> []
+    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+  in
+  filter_i_rec 0
+
+let rec sep_last = function
+  | [] -> failwith "sep_last"
+  | hd::[] -> (hd,[])
+  | hd::tl -> let (l,tl) = sep_last tl in (l,hd::tl)
+
+let rec find_map f = function
+| [] -> raise Not_found
+| x :: l ->
+  match f x with
+  | None -> find_map f l
+  | Some y -> y
+
+(* FIXME: we should avoid relying on the generic hash function,
+   just as we'd better avoid Pervasives.compare *)
+
+let uniquize l =
+  let visited = Hashtbl.create 23 in
+  let rec aux acc changed = function
+    | h::t -> if Hashtbl.mem visited h then aux acc true t else
+          begin
+            Hashtbl.add visited h h;
+            aux (h::acc) changed t
+          end
+    | [] -> if changed then List.rev acc else l
+  in aux [] false l
+
+(** [sort_uniquize] might be an alternative to the hashtbl-based
+    [uniquize], when the order of the elements is irrelevant *)
+
+let rec uniquize_sorted cmp = function
+  | a::b::l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a::l)
+  | a::l -> a::uniquize_sorted cmp l
+  | [] -> []
+
+let sort_uniquize cmp l = uniquize_sorted cmp (List.sort cmp l)
+
+(* FIXME: again, generic hash function *)
+
+let distinct l =
+  let visited = Hashtbl.create 23 in
+  let rec loop = function
+    | h::t ->
+        if Hashtbl.mem visited h then false
+        else
+          begin
+            Hashtbl.add visited h h;
+            loop t
+          end
+    | [] -> true
+  in loop l
+
+let distinct_f cmp l =
+  let rec loop = function
+    | a::b::_ when Int.equal (cmp a b) 0 -> false
+    | a::l -> loop l
+    | [] -> true
+  in loop (List.sort cmp l)
+
+let rec merge_uniq cmp l1 l2 =
+  match l1, l2 with
+  | [], l2 -> l2
+  | l1, [] -> l1
+  | h1 :: t1, h2 :: t2 ->
+      let c = cmp h1 h2 in
+      if Int.equal c 0
+      then h1 :: merge_uniq cmp t1 t2
+      else if c <= 0
+      then h1 :: merge_uniq cmp t1 l2
+      else h2 :: merge_uniq cmp l1 t2
+
+let rec duplicates cmp = function
+  | [] -> []
+  | x::l ->
+      let l' = duplicates cmp l in
+      if mem_f cmp x l then add_set cmp x l' else l'
+
+let rec filter2_loop f p q l1 l2 = match l1, l2 with
+| [], [] -> ()
+| x :: l1, y :: l2 ->
+  if f x y then
+    let c1 = { head = x; tail = [] } in
+    let c2 = { head = y; tail = [] } in
+    let () = p.tail <- cast c1 in
+    let () = q.tail <- cast c2 in
+    filter2_loop f c1 c2 l1 l2
+  else
+    filter2_loop f p q l1 l2
+| _ -> invalid_arg "List.filter2"
+
+let filter2 f l1 l2 =
+  let c1 = { head = Obj.magic 0; tail = [] } in
+  let c2 = { head = Obj.magic 0; tail = [] } in
+  filter2_loop f c1 c2 l1 l2;
+  (c1.tail, c2.tail)
+
+let rec map_filter f = function
+  | [] -> []
+  | x::l ->
+      let l' = map_filter f l in
+      match f x with None -> l' | Some y -> y::l'
+
+let map_filter_i f =
+  let rec aux i = function
+    | [] -> []
+    | x::l ->
+      let l' = aux (succ i) l in
+        match f i x with None -> l' | Some y -> y::l'
+  in aux 0
+
+let rec filter_with filter l = match filter, l with
+| [], [] -> []
+| true :: filter, x :: l -> x :: filter_with filter l
+| false :: filter, _ :: l -> filter_with filter l
+| _ -> invalid_arg "List.filter_with"
+
+(* FIXME: again, generic hash function *)
+
+let subset l1 l2 =
+  let t2 = Hashtbl.create 151 in
+  List.iter (fun x -> Hashtbl.add t2 x ()) l2;
+  let rec look = function
+    | [] -> true
+    | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
+  in
+  look l1
+
+(** [goto i l] splits [l] into two lists [(l1,l2)] such that
+    [(List.rev l1)++l2=l] and [l1] has length [i].  It raises
+    [IndexOutOfRange] when [i] is negative or greater than the
+    length of [l]. *)
+exception IndexOutOfRange
+let goto n l =
+  let rec goto i acc = function
+    | tl when Int.equal i 0 -> (acc, tl)
+    | h::t -> goto (pred i) (h::acc) t
+    | [] -> raise IndexOutOfRange
+  in
+  goto n [] l
+
+(* [chop i l] splits [l] into two lists [(l1,l2)] such that
+   [l1++l2=l] and [l1] has length [i].
+   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+
+let chop n l =
+  try let (h,t) = goto n l in (List.rev h,t)
+  with IndexOutOfRange -> failwith "List.chop"
+    (* spiwack: should raise [IndexOutOfRange] but I'm afraid of missing
+       a try/with when replacing the exception. *)
+
+(* [split_when p l] splits [l] into two lists [(l1,a::l2)] such that
+    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
+    If there is no such [a], then it returns [(l,[])] instead *)
+let split_when p =
+  let rec split_when_loop x y =
+    match y with
+      | []      -> (List.rev x,[])
+      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
+  in
+  split_when_loop []
+
+let rec split3 = function
+  | [] -> ([], [], [])
+  | (x,y,z)::l ->
+      let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz)
+
+let firstn n l =
+  let rec aux acc = function
+    | (0, l) -> List.rev acc
+    | (n, (h::t)) -> aux (h::acc) (pred n, t)
+    | _ -> failwith "firstn"
+  in
+  aux [] (n,l)
+
+let rec last = function
+  | [] -> failwith "List.last"
+  | [x] -> x
+  | _ :: l -> last l
+
+let lastn n l =
+  let len = List.length l in
+  let rec aux m l =
+    if Int.equal m n then l else aux (m - 1) (List.tl l)
+  in
+  if len < n then failwith "lastn" else aux len l
+
+let rec skipn n l = match n,l with
+  | 0, _ -> l
+  | _, [] -> failwith "List.skipn"
+  | n, _::l -> skipn (pred n) l
+
+let skipn_at_least n l =
+  try skipn n l with Failure _ -> []
+
+let prefix_of cmp prefl l =
+  let rec prefrec = function
+    | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2)
+    | ([], _) -> true
+    | _ -> false
+  in
+  prefrec (prefl,l)
+
+(** if [l=p++t] then [drop_prefix p l] is [t] else [l] *)
+
+let drop_prefix cmp p l =
+  let rec drop_prefix_rec = function
+    | (h1::tp, h2::tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl)
+    | ([], tl) -> tl
+    | _ -> l
+  in
+  drop_prefix_rec (p,l)
+
+let map_append f l = List.flatten (List.map f l)
+
+let map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
+
+let share_tails l1 l2 =
+  let rec shr_rev acc = function
+    | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
+    | (l1,l2) -> (List.rev l1, List.rev l2, acc)
+  in
+  shr_rev [] (List.rev l1, List.rev l2)
+
+let rec fold_map f e = function
+  |  []  -> (e,[])
+  |  h::t ->
+       let e',h' = f e h in
+       let e'',t' = fold_map f e' t in
+         e'',h'::t'
+
+(* (* tail-recursive version of the above function *)
+let fold_map f e l =
+  let g (e,b') h =
+    let (e',h') = f e h in
+      (e',h'::b')
+  in
+  let (e',lrev) = List.fold_left g (e,[]) l in
+    (e',List.rev lrev)
+*)
+
+(* The same, based on fold_right, with the effect accumulated on the right *)
+let fold_map' f l e =
+  List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
+
+let map_assoc f = List.map (fun (x,a) -> (x,f a))
+
+let rec assoc_f f a = function
+  | (x, e) :: xs -> if f a x then e else assoc_f f a xs
+  | [] -> raise Not_found
+
+let remove_assoc_f f a l =
+  try remove_first (fun (x,_) -> f a x) l with Not_found -> l
+
+let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l
+
+(* A generic cartesian product: for any operator (**),
+   [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+   and so on if there are more elements in the lists. *)
+
+let cartesian op l1 l2 =
+  map_append (fun x -> List.map (op x) l2) l1
+
+(* [cartesians] is an n-ary cartesian product: it iterates
+   [cartesian] over a list of lists.  *)
+
+let cartesians op init ll =
+  List.fold_right (cartesian op) ll [init]
+
+(* combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
+
+let combinations l = cartesians (fun x l -> x::l) [] l
+
+let rec combine3 x y z = 
+  match x, y, z with
+  | [], [], [] -> []
+  | (x :: xs), (y :: ys), (z :: zs) ->
+      (x, y, z) :: combine3 xs ys zs
+  | _, _, _ -> invalid_arg "List.combine3"
+  
+(* Keep only those products that do not return None *)
+
+let cartesian_filter op l1 l2 =
+  map_append (fun x -> map_filter (op x) l2) l1
+
+(* Keep only those products that do not return None *)
+
+let cartesians_filter op init ll =
+  List.fold_right (cartesian_filter op) ll [init]
+
+(* Drop the last element of a list *)
+
+let rec drop_last = function
+  | [] -> assert false
+  | hd :: [] -> []
+  | hd :: tl -> hd :: drop_last tl
+
+(* Factorize lists of pairs according to the left argument *)
+let rec factorize_left cmp = function
+  | (a,b)::l ->
+      let al,l' = partition (fun (a',_) -> cmp a a') l in
+      (a,(b::List.map snd al)) :: factorize_left cmp l'
+  | [] -> []
+
+module type MonoS = sig
+  type elt
+  val equal : elt list -> elt list -> bool
+  val mem : elt -> elt list -> bool
+  val assoc : elt -> (elt * 'a) list -> 'a
+  val mem_assoc : elt -> (elt * 'a) list -> bool
+  val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+  val mem_assoc_sym : elt -> ('a * elt) list -> bool
+end
diff --git a/lib/cList.mli b/lib/cList.mli
new file mode 100644
index 00000000..19eeb250
--- /dev/null
+++ b/lib/cList.mli
@@ -0,0 +1,229 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+type 'a cmp = 'a -> 'a -> int
+type 'a eq = 'a -> 'a -> bool
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of List
+
+module type ExtS =
+sig
+  include S
+
+  val compare : 'a cmp -> 'a list cmp
+  (** Lexicographic order on lists. *)
+
+  val equal : 'a eq -> 'a list eq
+  (** Lifts equality to list type. *)
+
+  val is_empty : 'a list -> bool
+  (** Checks whether a list is empty *)
+
+  val init : int -> (int -> 'a) -> 'a list
+  (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. *)
+
+  val mem_f : 'a eq -> 'a -> 'a list -> bool
+  (* Same as [List.mem], for some specific equality *)
+
+  val add_set : 'a eq -> 'a -> 'a list -> 'a list
+  (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l]
+      otherwise. *)
+
+  val eq_set : 'a eq -> 'a list eq
+  (** Test equality up to permutation (but considering multiple occurrences) *)
+
+  val intersect : 'a eq -> 'a list -> 'a list -> 'a list
+  val union : 'a eq -> 'a list -> 'a list -> 'a list
+  val unionq : 'a list -> 'a list -> 'a list
+  val subtract : 'a eq -> 'a list -> 'a list -> 'a list
+  val subtractq : 'a list -> 'a list -> 'a list
+
+  val interval : int -> int -> int list
+  (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when 
+      [j <= i]. *)
+
+  val make : int -> 'a -> 'a list
+  (** [make n x] returns a list made of [n] times [x]. Raise
+      [Invalid_argument "List.make"] if [n] is negative. *)
+
+  val assign : 'a list -> int -> 'a -> 'a list
+  (** [assign l i x] set the [i]-th element of [l] to [x], starting from [0]. *)
+
+  val distinct : 'a list -> bool
+  (** Return [true] if all elements of the list are distinct. *)
+
+  val distinct_f : 'a cmp -> 'a list -> bool
+
+  val duplicates : 'a eq -> 'a list -> 'a list
+  (** Return the list of unique elements which appear at least twice. Elements
+      are kept in the order of their first appearance. *)
+
+  val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+  val map_filter : ('a -> 'b option) -> 'a list -> 'b list
+  val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
+
+  val filter_with : bool list -> 'a list -> 'a list
+  (** [filter_with b a] selects elements of [a] whose corresponding element in
+      [b] is [true]. Raise [Invalid_argument _] when sizes differ. *)
+
+  val smartmap : ('a -> 'a) -> 'a list -> 'a list
+  (** [smartmap f [a1...an] = List.map f [a1...an]] but if for all i
+    [f ai == ai], then [smartmap f l == l] *)
+
+  val map_left : ('a -> 'b) -> 'a list -> 'b list
+  (** As [map] but ensures the left-to-right order of evaluation. *)
+
+  val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+  (** As [map] but with the index, which starts from [0]. *)
+
+  val map2_i :
+    (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
+  val map3 :
+    ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+  val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list ->
+    'd list -> 'e list
+  val filteri : (int -> 'a -> bool) -> 'a list -> 'a list
+
+  val smartfilter : ('a -> bool) -> 'a list -> 'a list
+  (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
+    [f ai = true], then [smartfilter f l == l] *)
+
+  val index : 'a eq -> 'a -> 'a list -> int
+  (** [index] returns the 1st index of an element in a list (counting from 1). *)
+
+  val index0 : 'a eq -> 'a -> 'a list -> int
+  (** [index0] behaves as [index] except that it starts counting at 0. *)
+
+  val iteri :  (int -> 'a -> unit) -> 'a list -> unit
+  (** As [iter] but with the index argument (starting from 0). *)
+
+  val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c
+  (** acts like [fold_left f acc s] while [f] returns
+      [Cont acc']; it stops returning [c] as soon as [f] returns [Stop c]. *)
+
+  val fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
+  val fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
+  val fold_right_and_left :
+      ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
+  val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
+  val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
+  val except : 'a eq -> 'a -> 'a list -> 'a list
+  val remove : 'a eq -> 'a -> 'a list -> 'a list
+
+  val remove_first : ('a -> bool) -> 'a list -> 'a list
+  (** Remove the first element satisfying a predicate, or raise [Not_found] *)
+
+  val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
+  (** Insert at the (first) position so that if the list is ordered wrt to the
+      total order given as argument, the order is preserved *)
+
+  val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+  val sep_last : 'a list -> 'a * 'a list
+
+  val find_map : ('a -> 'b option) -> 'a list -> 'b
+  (** Returns the first element that is mapped to [Some _]. Raise [Not_found] if
+      there is none. *)
+
+  val uniquize : 'a list -> 'a list
+  (** Return the list of elements without duplicates.
+      This is the list unchanged if there was none. *)
+
+  val sort_uniquize : 'a cmp -> 'a list -> 'a list
+  (** Return a sorted and de-duplicated version of a list,
+      according to some comparison function. *)
+
+  val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list
+  (** Merge two sorted lists and preserves the uniqueness property. *)
+
+  val subset : 'a list -> 'a list -> bool
+
+  val chop : int -> 'a list -> 'a list * 'a list
+  (** [chop i l] splits [l] into two lists [(l1,l2)] such that
+      [l1++l2=l] and [l1] has length [i].  It raises [Failure] when [i]
+      is negative or greater than the length of [l] *)
+
+  exception IndexOutOfRange
+  val goto: int -> 'a list -> 'a list * 'a list
+  (** [goto i l] splits [l] into two lists [(l1,l2)] such that
+      [(List.rev l1)++l2=l] and [l1] has length [i].  It raises
+      [IndexOutOfRange] when [i] is negative or greater than the
+      length of [l]. *)
+
+
+  val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+  val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
+  val firstn : int -> 'a list -> 'a list
+  val last : 'a list -> 'a
+  val lastn : int -> 'a list -> 'a list
+  val skipn : int -> 'a list -> 'a list
+  val skipn_at_least : int -> 'a list -> 'a list
+
+  val addn : int -> 'a -> 'a list -> 'a list
+  (** [addn n x l] adds [n] times [x] on the left of [l]. *)
+
+  val prefix_of : 'a eq -> 'a list -> 'a list -> bool
+  (** [prefix_of l1 l2] returns [true] if [l1] is a prefix of [l2], [false]
+      otherwise. *)
+
+  val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list
+  (** [drop_prefix p l] returns [t] if [l=p++t] else return [l]. *)
+
+  val drop_last : 'a list -> 'a list
+
+  val map_append : ('a -> 'b list) -> 'a list -> 'b list
+  (** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)]. *)
+
+  val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
+  (** As [map_append]. Raises [Invalid_argument _] if the two lists don't have 
+      the same length. *)
+
+  val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
+
+  val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+  (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
+    where [(e_i,k_i)=f e_{i-1} l_i] *)
+
+  val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
+  val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+  val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b
+  val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list
+  val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool
+
+  val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+  (** A generic cartesian product: for any operator (**),
+    [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
+    and so on if there are more elements in the lists. *)
+
+  val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
+  (** [cartesians] is an n-ary cartesian product: it iterates
+    [cartesian] over a list of lists.  *)
+
+  val combinations : 'a list list -> 'a list list
+  (** combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
+
+  val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+
+  val cartesians_filter :
+    ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
+  (** Keep only those products that do not return None *)
+
+  val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list
+
+  module type MonoS = sig
+    type elt
+    val equal : elt list -> elt list -> bool
+    val mem : elt -> elt list -> bool
+    val assoc : elt -> (elt * 'a) list -> 'a
+    val mem_assoc : elt -> (elt * 'a) list -> bool
+    val remove_assoc : elt -> (elt * 'a) list -> (elt * 'a) list
+    val mem_assoc_sym : elt -> ('a * elt) list -> bool
+  end
+end
+
+include ExtS
diff --git a/lib/cMap.ml b/lib/cMap.ml
new file mode 100644
index 00000000..cf590d96
--- /dev/null
+++ b/lib/cMap.ml
@@ -0,0 +1,168 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+  include Map.S
+  module Set : CSig.SetS with type elt = key
+  val update : key -> 'a -> 'a t -> 'a t
+  val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+  val domain : 'a t -> Set.t
+  val bind : (key -> 'a) -> Set.t -> 'a t
+  val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val smartmap : ('a -> 'a) -> 'a t -> 'a t
+  val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+  module Unsafe :
+  sig
+    val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+  end
+end
+
+module MapExt (M : Map.OrderedType) :
+sig
+  type 'a map = 'a Map.Make(M).t
+  val update : M.t -> 'a -> 'a map -> 'a map
+  val modify : M.t -> (M.t -> 'a -> 'a) -> 'a map -> 'a map
+  val domain : 'a map -> Set.Make(M).t
+  val bind : (M.t -> 'a) -> Set.Make(M).t -> 'a map
+  val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+  val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b
+  val smartmap : ('a -> 'a) -> 'a map -> 'a map
+  val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map
+  module Unsafe :
+  sig
+    val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map
+  end
+end =
+struct
+  (** This unsafe module is a way to access to the actual implementations of
+      OCaml sets and maps without reimplementing them ourselves. It is quite
+      dubious that these implementations will ever be changed... Nonetheless,
+      if this happens, we can still implement a less clever version of [domain].
+  *)
+
+  type 'a map = 'a Map.Make(M).t
+  type set = Set.Make(M).t
+
+  type 'a _map =
+  | MEmpty
+  | MNode of 'a map * M.t * 'a * 'a map * int
+
+  type _set =
+  | SEmpty
+  | SNode of set * M.t * set * int
+
+  let map_prj : 'a map -> 'a _map = Obj.magic
+  let map_inj : 'a _map -> 'a map = Obj.magic
+  let set_prj : set -> _set = Obj.magic
+  let set_inj : _set -> set = Obj.magic
+
+  let rec update k v (s : 'a map) : 'a map = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k', v', r, h) ->
+    let c = M.compare k k' in
+    if c < 0 then
+      let l' = update k v l in
+      if l == l' then s
+      else map_inj (MNode (l', k', v', r, h))
+    else if c = 0 then
+      if v' == v then s
+      else map_inj (MNode (l, k', v, r, h))
+    else
+      let r' = update k v r in
+      if r == r' then s
+      else map_inj (MNode (l, k', v', r', h))
+
+  let rec modify k f (s : 'a map) : 'a map = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k', v, r, h) ->
+    let c = M.compare k k' in
+    if c < 0 then
+      let l' = modify k f l in
+      if l == l' then s
+      else map_inj (MNode (l', k', v, r, h))
+    else if c = 0 then
+      let v' = f k' v in
+      if v' == v then s
+      else map_inj (MNode (l, k', v', r, h))
+    else
+      let r' = modify k f r in
+      if r == r' then s
+      else map_inj (MNode (l, k', v, r', h))
+
+  let rec domain (s : 'a map) : set = match map_prj s with
+  | MEmpty -> set_inj SEmpty
+  | MNode (l, k, _, r, h) ->
+    set_inj (SNode (domain l, k, domain r, h))
+  (** This function is essentially identity, but OCaml current stdlib does not
+      take advantage of the similarity of the two structures, so we introduce
+      this unsafe loophole. *)
+
+  let rec bind f (s : set) : 'a map = match set_prj s with
+  | SEmpty -> map_inj MEmpty
+  | SNode (l, k, r, h) ->
+    map_inj (MNode (bind f l, k, f k, bind f r, h))
+  (** Dual operation of [domain]. *)
+
+  let rec fold_left f (s : 'a map) accu = match map_prj s with
+  | MEmpty -> accu
+  | MNode (l, k, v, r, h) ->
+    let accu = f k v (fold_left f l accu) in
+    fold_left f r accu
+
+  let rec fold_right f (s : 'a map) accu = match map_prj s with
+  | MEmpty -> accu
+  | MNode (l, k, v, r, h) ->
+    let accu = f k v (fold_right f r accu) in
+    fold_right f l accu
+
+  let rec smartmap f (s : 'a map) = match map_prj s with
+  | MEmpty -> map_inj MEmpty
+  | MNode (l, k, v, r, h) ->
+    let l' = smartmap f l in
+    let r' = smartmap f r in
+    let v' = f v in
+    if l == l' && r == r' && v == v' then s
+    else map_inj (MNode (l', k, v', r', h))
+
+  let rec smartmapi f (s : 'a map) = match map_prj s with
+  | MEmpty -> map_inj MEmpty
+  | MNode (l, k, v, r, h) ->
+    let l' = smartmapi f l in
+    let r' = smartmapi f r in
+    let v' = f k v in
+    if l == l' && r == r' && v == v' then s
+    else map_inj (MNode (l', k, v', r', h))
+
+  module Unsafe =
+  struct
+
+    let rec map f (s : 'a map) : 'b map = match map_prj s with
+    | MEmpty -> map_inj MEmpty
+    | MNode (l, k, v, r, h) ->
+      let (k, v) = f k v in
+      map_inj (MNode (map f l, k, v, map f r, h))
+
+  end
+
+end
+
+module Make(M : Map.OrderedType) =
+struct
+  include Map.Make(M)
+  include MapExt(M)
+end
diff --git a/lib/cMap.mli b/lib/cMap.mli
new file mode 100644
index 00000000..23d3801e
--- /dev/null
+++ b/lib/cMap.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {5 Extended version of OCaml's maps} *)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Map.S
+
+module type ExtS =
+sig
+  include Map.S
+  (** The underlying Map library *)
+
+  module Set : CSig.SetS with type elt = key
+  (** Sets used by the domain function *)
+
+  val update : key -> 'a -> 'a t -> 'a t
+  (** Same as [add], but expects the key to be present, and thus faster.
+      @raise Not_found when the key is unbound in the map. *)
+
+  val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t
+  (** Apply the given function to the binding of the given key.
+      @raise Not_found when the key is unbound in the map. *)
+
+  val domain : 'a t -> Set.t
+  (** Recover the set of keys defined in the map. *)
+
+  val bind : (key -> 'a) -> Set.t -> 'a t
+  (** [bind f s] transform the set [x1; ...; xn] into [x1 := f x1; ...;
+      xn := f xn]. *)
+
+  val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** Alias for {!fold}, to easily track where we depend on fold order. *)
+
+  val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** Folding keys in decreasing order. *)
+
+  val smartmap : ('a -> 'a) -> 'a t -> 'a t
+  (** As [map] but tries to preserve sharing. *)
+
+  val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t
+  (** As [mapi] but tries to preserve sharing. *)
+
+  module Unsafe :
+  sig
+    val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t
+    (** As the usual [map], but also allows modifying the key of a binding.
+        It is required that the mapping function [f] preserves key equality,
+        i.e.: for all (k : key) (x : 'a), compare (fst (f k x)) k = 0. *)
+  end
+
+end
+
+module Make(M : Map.OrderedType) : ExtS with
+  type key = M.t
+  and type 'a t = 'a Map.Make(M).t
+  and module Set := Set.Make(M)
diff --git a/lib/cObj.ml b/lib/cObj.ml
new file mode 100644
index 00000000..7f3ee185
--- /dev/null
+++ b/lib/cObj.ml
@@ -0,0 +1,203 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(*s Logical and physical size of ocaml values. *)
+
+(** {6 Logical sizes} *)
+
+let c = ref 0
+let s = ref 0
+let b = ref 0
+let m = ref 0
+
+let rec obj_stats d t =
+  if Obj.is_int t then m := max d !m
+  else if Obj.tag t >= Obj.no_scan_tag then
+    if Obj.tag t = Obj.string_tag then
+      (c := !c + Obj.size t; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_tag then
+      (s := !s + 2; b := !b + 1; m := max d !m)
+    else if Obj.tag t = Obj.double_array_tag then
+      (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
+    else (b := !b + 1; m := max d !m)
+  else
+    let n = Obj.size t in
+    s := !s + n; b := !b + 1;
+    block_stats (d + 1) (n - 1) t
+
+and block_stats d i t =
+  if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
+
+let obj_stats a =
+  c := 0; s:= 0; b:= 0; m:= 0;
+  obj_stats 0 (Obj.repr a);
+  (!c, !s + !b, !m)
+
+(** {6 Physical sizes} *)
+
+(*s Pointers already visited are stored in a hash-table, where
+    comparisons are done using physical equality. *)
+
+module H = Hashtbl.Make(
+  struct
+    type t = Obj.t
+    let equal = (==)
+    let hash = Hashtbl.hash
+  end)
+
+let node_table = (H.create 257 : unit H.t)
+
+let in_table o = try H.find node_table o; true with Not_found -> false
+
+let add_in_table o = H.add node_table o ()
+
+let reset_table () = H.clear node_table
+
+(*s Objects are traversed recursively, as soon as their tags are less than
+    [no_scan_tag]. [count] records the numbers of words already visited. *)
+
+let size_of_double = Obj.size (Obj.repr 1.0)
+
+let count = ref 0
+
+let rec traverse t =
+  if not (in_table t) && Obj.is_block t then begin
+    add_in_table t;
+    let n = Obj.size t in
+    let tag = Obj.tag t in
+    if tag < Obj.no_scan_tag then
+      begin
+        count := !count + 1 + n;
+        for i = 0 to n - 1 do traverse (Obj.field t i) done
+      end
+    else if tag = Obj.string_tag then
+      count := !count + 1 + n
+    else if tag = Obj.double_tag then
+      count := !count + size_of_double
+    else if tag = Obj.double_array_tag then
+      count := !count + 1 + size_of_double * n
+    else
+      incr count
+  end
+
+(*s Sizes of objects in words and in bytes. The size in bytes is computed
+    system-independently according to [Sys.word_size]. *)
+
+let size o =
+  reset_table ();
+  count := 0;
+  traverse (Obj.repr o);
+  !count
+
+let size_b o = (size o) * (Sys.word_size / 8)
+
+let size_kb o = (size o) / (8192 / Sys.word_size)
+
+(** {6 Physical sizes with sharing} *)
+
+(** This time, all the size of objects are computed with respect
+    to a larger object containing them all, and we only count
+    the new blocks not already seen earlier in the left-to-right
+    visit of the englobing object.
+
+    The very same object could have a zero size or not, depending
+    of the occurrence we're considering in the englobing object.
+    For speaking of occurrences, we use an [int list] for a path
+    of field indexes from the outmost block to the one we're looking.
+    In the list, the leftmost integer is the field index in the deepest
+    block.
+*)
+
+(** We now store in the hashtable the size (with sharing), and
+    also the position of the first occurrence of the object *)
+
+let node_sizes = (H.create 257 : (int*int list) H.t)
+let get_size o = H.find node_sizes o
+let add_size o n pos = H.replace node_sizes o (n,pos)
+let reset_sizes () = H.clear node_sizes
+let global_object = ref (Obj.repr 0)
+
+(** [sum n f] is [f 0 + f 1 + ... + f (n-1)], evaluated from left to right *)
+
+let sum n f =
+  let rec loop k acc = if k >= n then acc else loop (k+1) (acc + f k)
+  in loop 0 0
+
+(** Recursive visit of the main object, filling the hashtable *)
+
+let rec compute_size o pos =
+  if not (Obj.is_block o) then 0
+  else
+    try
+      let _ = get_size o in 0 (* already seen *)
+    with Not_found ->
+      let n = Obj.size o in
+      add_size o (-1) pos (* temp size, for cyclic values *);
+      let tag = Obj.tag o in
+      let size =
+        if tag < Obj.no_scan_tag then
+          1 + n + sum n (fun i -> compute_size (Obj.field o i) (i::pos))
+        else if tag = Obj.string_tag then
+          1 + n
+        else if tag = Obj.double_tag then
+          size_of_double
+        else if tag = Obj.double_array_tag then
+          size_of_double * n
+        else
+          1
+      in
+      add_size o size pos;
+      size
+
+(** Provides the global object in which we'll search shared sizes *)
+
+let register_shared_size t =
+  let o = Obj.repr t in
+  reset_sizes ();
+  global_object := o;
+  ignore (compute_size o [])
+
+(** Shared size of an object with respect to the global object given
+    by the last [register_shared_size] *)
+
+let shared_size pos o =
+  if not (Obj.is_block o) then 0
+  else
+    let size,pos' =
+      try get_size o
+      with Not_found -> failwith "shared_size: unregistered structure ?"
+    in
+    match pos with
+      | Some p when p <> pos' -> 0
+      | _ -> size
+
+let shared_size_of_obj t = shared_size None (Obj.repr t)
+
+(** Shared size of the object at some positiion in the global object given
+    by the last [register_shared_size] *)
+
+let shared_size_of_pos pos =
+  let rec obj_of_pos o = function
+    | [] -> o
+    | n::pos' ->
+      let o' = obj_of_pos o pos' in
+      assert (Obj.is_block o' && n < Obj.size o');
+      Obj.field o' n
+  in
+  shared_size (Some pos) (obj_of_pos !global_object pos)
+
+
+(*s Total size of the allocated ocaml heap. *)
+
+let heap_size () =
+  let stat = Gc.stat ()
+  and control = Gc.get () in
+  let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
+  (max_words_total * (Sys.word_size / 8))
+
+let heap_size_kb () = (heap_size () + 1023) / 1024
diff --git a/lib/cObj.mli b/lib/cObj.mli
new file mode 100644
index 00000000..16933a4a
--- /dev/null
+++ b/lib/cObj.mli
@@ -0,0 +1,59 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** {6 Physical size of an ocaml value.}
+
+  These functions explore objects recursively and may allocate a lot. *)
+
+val size : 'a -> int
+(** Physical size of an object in words. *)
+
+val size_b : 'a -> int
+(** Same as [size] in bytes. *)
+
+val size_kb : 'a -> int
+(** Same as [size] in kilobytes. *)
+
+(** {6 Physical size of an ocaml value with sharing.} *)
+
+(** This time, all the size of objects are computed with respect
+    to a larger object containing them all, and we only count
+    the new blocks not already seen earlier in the left-to-right
+    visit of the englobing object. *)
+
+(** Provides the global object in which we'll search shared sizes *)
+
+val register_shared_size : 'a -> unit
+
+(** Shared size (in word) of an object with respect to the global object
+    given by the last [register_shared_size]. *)
+
+val shared_size_of_obj : 'a -> int
+
+(** Same, with an object indicated by its occurrence in the global
+    object. The very same object could have a zero size or not, depending
+    of the occurrence we're considering in the englobing object.
+    For speaking of occurrences, we use an [int list] for a path
+    of field indexes (leftmost = deepest block, rightmost = top block of the
+    global object). *)
+
+val shared_size_of_pos : int list -> int
+
+(** {6 Logical size of an OCaml value.} *)
+
+val obj_stats : 'a -> int * int * int
+(** Return the (logical) value size, the string size, and the maximum depth of
+    the object. This loops on cyclic structures. *)
+
+(** {6 Total size of the allocated ocaml heap. } *)
+
+val heap_size : unit -> int
+(** Heap size, in words. *)
+
+val heap_size_kb : unit -> int
+(** Heap size, in kilobytes. *)
diff --git a/lib/cSet.ml b/lib/cSet.ml
new file mode 100644
index 00000000..d7d5c70b
--- /dev/null
+++ b/lib/cSet.ml
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
+end
+
+module type S = Set.S
+
+module Make(M : OrderedType)= Set.Make(M)
+
+module type HashedType =
+sig
+  type t
+  val hash : t -> int
+end
+
+module Hashcons(M : OrderedType)(H : HashedType with type t = M.t)  =
+struct
+  module Set = Make(M)
+
+  type set = Set.t
+  type _set =
+  | SEmpty
+  | SNode of set * M.t * set * int
+
+  let set_prj : set -> _set = Obj.magic
+  let set_inj : _set -> set = Obj.magic
+
+  let rec spine s accu = match set_prj s with
+  | SEmpty -> accu
+  | SNode (l, v, r, _) -> spine l ((v, r) :: accu)
+
+  let rec umap f s = match set_prj s with
+  | SEmpty -> set_inj SEmpty
+  | SNode (l, v, r, h) ->
+    let l' = umap f l in
+    let r' = umap f r in
+    let v' = f v in
+    set_inj (SNode (l', v', r', h))
+
+  let rec eqeq s1 s2 = match s1, s2 with
+  | [], [] -> true
+  | (v1, r1) :: s1, (v2, r2) :: s2 ->
+      v1 == v2 && eqeq (spine r1 s1) (spine r2 s2)
+  | _ -> false
+
+  module Hashed =
+  struct
+    open Hashset.Combine
+    type t = set
+    type u = M.t -> M.t
+    let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 [])
+    let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0
+    let hashcons = umap
+  end
+
+  include Hashcons.Make(Hashed)
+
+end
diff --git a/ide/undo_lablgtk_lt26.mli b/lib/cSet.mli
index b13509e6..e5505410 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/lib/cSet.mli
@@ -1,33 +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        *)
 (************************************************************************)
 
-(* An undoable view class *)
-
-class undoable_view : Gtk.text_view Gtk.obj ->
-object
-  inherit GText.view
-  method undo : bool
-  method redo : bool
-  method clear_undo : unit
+module type OrderedType =
+sig
+  type t
+  val compare : t -> t -> int
 end
 
-val undoable_view :
-    ?buffer:GText.buffer ->
-    ?editable:bool ->
-    ?cursor_visible:bool ->
-    ?justification:GtkEnums.justification ->
-    ?wrap_mode:GtkEnums.wrap_mode ->
-    ?border_width:int ->
-    ?width:int ->
-    ?height:int ->
-    ?packing:(GObj.widget -> unit) ->
-    ?show:bool ->
-    unit ->
-  undoable_view
+module type S = Set.S
+
+module Make(M : OrderedType) : S
+  with type elt = M.t
+  and type t = Set.Make(M).t
 
+module type HashedType =
+sig
+  type t
+  val hash : t -> int
+end
 
+module Hashcons (M : OrderedType) (H : HashedType with type t = M.t) : Hashcons.S with
+  type t = Set.Make(M).t
+  and type u = M.t -> M.t
+(** Create hash-consing for sets. The hashing function provided must be
+    compatible with the comparison function. *)
diff --git a/lib/cSig.mli b/lib/cSig.mli
new file mode 100644
index 00000000..2a8bda29
--- /dev/null
+++ b/lib/cSig.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Missing pervasive types from OCaml stdlib *)
+
+type ('a, 'b) union = Inl of 'a | Inr of 'b
+(** Union type *)
+
+type 'a until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
+
+module type SetS =
+sig
+    type elt
+    type t
+    val empty: t
+    val is_empty: t -> bool
+    val mem: elt -> t -> bool
+    val add: elt -> t -> t
+    val singleton: elt -> t
+    val remove: elt -> t -> t
+    val union: t -> t -> t
+    val inter: t -> t -> t
+    val diff: t -> t -> t
+    val compare: t -> t -> int
+    val equal: t -> t -> bool
+    val subset: t -> t -> bool
+    val iter: (elt -> unit) -> t -> unit
+    val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all: (elt -> bool) -> t -> bool
+    val exists: (elt -> bool) -> t -> bool
+    val filter: (elt -> bool) -> t -> t
+    val partition: (elt -> bool) -> t -> t * t
+    val cardinal: t -> int
+    val elements: t -> elt list
+    val min_elt: t -> elt
+    val max_elt: t -> elt
+    val choose: t -> elt
+    val split: elt -> t -> t * bool * t
+end
+(** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml
+    documentation for more information. *)
diff --git a/lib/cStack.ml b/lib/cStack.ml
new file mode 100644
index 00000000..4acb2930
--- /dev/null
+++ b/lib/cStack.ml
@@ -0,0 +1,42 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+exception Empty = Stack.Empty
+
+type 'a t = {
+  mutable stack : 'a list;
+}
+
+let create () = { stack = [] }
+
+let push x s = s.stack <- x :: s.stack
+
+let pop = function
+  | { stack = [] } -> raise Stack.Empty
+  | { stack = x::xs } as s -> s.stack <- xs; x
+
+let top = function
+  | { stack = [] } -> raise Stack.Empty
+  | { stack = x::_ } -> x
+
+let to_list { stack = s } = s
+
+let find f s = List.find f (to_list s)
+
+let find_map f s = CList.find_map f s.stack
+
+let fold_until f accu s = CList.fold_left_until f accu s.stack
+
+let is_empty { stack = s } = s = []
+
+let iter f { stack = s } = List.iter f s
+
+let clear s = s.stack <- []
+
+let length { stack = s } = List.length s
+
diff --git a/lib/cStack.mli b/lib/cStack.mli
new file mode 100644
index 00000000..8dde1d1a
--- /dev/null
+++ b/lib/cStack.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Extended interface for OCaml stacks. *)
+
+type 'a t
+
+exception Empty
+(** Alias for Stack.Empty. *)
+
+val create : unit -> 'a t
+(** Create an empty stack. *)
+
+val push : 'a -> 'a t -> unit
+(** Add an element to a stack. *)
+
+val find : ('a -> bool) -> 'a t -> 'a
+(** Find the first element satisfying the predicate.
+    @raise Not_found it there is none. *)
+
+val is_empty : 'a t -> bool
+(** Whether a stack is empty. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iterate a function over elements, from the last added one. *)
+
+val clear : 'a t -> unit
+(** Empty a stack. *)
+
+val length : 'a t -> int
+(** Length of a stack. *)
+
+val pop  : 'a t -> 'a
+(** Remove and returns the first element of the stack.
+    @raise Empty if empty. *)
+
+val top  : 'a t -> 'a
+(** Remove the first element of the stack without modifying it.
+    @raise Empty if empty. *)
+
+val to_list : 'a t -> 'a list
+(** Convert to a list. *)
+
+val find_map : ('a -> 'b option) -> 'a t -> 'b
+(** Find the first element that returns [Some _].
+    @raise Not_found it there is none. *)
+
+val fold_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a t -> 'c
+(** Like CList.fold_left_until.
+    The stack is traversed from the top and is not altered. *)
+
diff --git a/lib/cString.ml b/lib/cString.ml
new file mode 100644
index 00000000..250b7cee
--- /dev/null
+++ b/lib/cString.ml
@@ -0,0 +1,174 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type S = module type of String
+
+module type ExtS =
+sig
+  include S
+  external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+  val hash : string -> int
+  val is_empty : string -> bool
+  val explode : string -> string list
+  val implode : string list -> string
+  val strip : string -> string
+  val map : (char -> char) -> string -> string
+  val drop_simple_quotes : string -> string
+  val string_index_from : string -> int -> string -> int
+  val string_contains : where:string -> what:string -> bool
+  val plural : int -> string -> string
+  val conjugate_verb_to_be : int -> string
+  val ordinal : int -> string
+  val split : char -> string -> string list
+  val is_sub : string -> string -> int -> bool
+  module Set : Set.S with type elt = t
+  module Map : CMap.ExtS with type key = t and module Set := Set
+  module List : CList.MonoS with type elt = t
+  val hcons : string -> string
+end
+
+include String
+
+external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+
+let rec hash len s i accu =
+  if i = len then accu
+  else
+    let c = Char.code (String.unsafe_get s i) in
+    hash len s (succ i) (accu * 19 + c)
+
+let hash s =
+  let len = String.length s in
+  hash len s 0 0
+
+let explode s =
+  let rec explode_rec n =
+    if n >= String.length s then
+      []
+    else
+      String.make 1 (String.get s n) :: explode_rec (succ n)
+  in
+  explode_rec 0
+
+let implode sl = String.concat "" sl
+
+let is_blank = function
+  | ' ' | '\r' | '\t' | '\n' -> true
+  | _ -> false
+
+let is_empty s = String.length s = 0
+
+let strip s =
+  let n = String.length s in
+  let rec lstrip_rec i =
+    if i < n && is_blank s.[i] then
+      lstrip_rec (i+1)
+    else i
+  in
+  let rec rstrip_rec i =
+    if i >= 0 && is_blank s.[i] then
+      rstrip_rec (i-1)
+    else i
+  in
+  let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
+  String.sub s a (b-a+1)
+
+let map f s =
+  let l = String.length s in
+  let r = String.create l in
+  for i = 0 to (l - 1) do r.[i] <- f (s.[i]) done;
+  r
+
+let drop_simple_quotes s =
+  let n = String.length s in
+  if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
+(* substring searching... *)
+
+(* gdzie = where, co = what *)
+(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
+let rec raw_is_sub gdzie gl gi co cl ci =
+  (ci>=cl) ||
+  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
+   (raw_is_sub gdzie gl (gi+1) co cl (ci+1)))
+
+let rec raw_str_index i gdzie l c co cl =
+  (* First adapt to ocaml 3.11 new semantics of index_from *)
+  if (i+cl > l) then raise Not_found;
+  (* Then proceed as in ocaml < 3.11 *)
+  let i' = String.index_from gdzie i c in
+    if (i'+cl <= l) && (raw_is_sub gdzie l i' co cl 0) then i' else
+      raw_str_index (i'+1) gdzie l c co cl
+
+let string_index_from gdzie i co =
+  if co="" then i else
+    raw_str_index i gdzie (String.length gdzie)
+      (String.unsafe_get co 0) co (String.length co)
+
+let string_contains ~where ~what =
+  try
+    let _ = string_index_from where 0 what in true
+  with
+      Not_found -> false
+
+let is_sub p s off =
+  let lp = String.length p in
+  let ls = String.length s in
+  if ls < off + lp then false
+  else
+    let rec aux i =
+      if lp <= i then true
+      else
+        let cp = String.unsafe_get p i in
+        let cs = String.unsafe_get s (off + i) in
+        if cp = cs then aux (succ i) else false
+    in
+    aux 0
+
+let plural n s = if n<>1 then s^"s" else s
+
+let conjugate_verb_to_be n = if n<>1 then "are" else "is"
+
+let ordinal n =
+  let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
+  string_of_int n ^ s
+
+(* string parsing *)
+
+let split c s =
+  let len = String.length s in
+  let rec split n =
+    try
+      let pos = String.index_from s n c in
+      let dir = String.sub s n (pos-n) in
+      dir :: split (succ pos)
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if Int.equal len 0 then [] else split 0
+
+module Self =
+struct
+  type t = string
+  let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map = CMap.Make(Self)
+
+module List = struct
+  type elt = string
+  let mem id l = List.exists (fun s -> equal id s) l
+  let assoc id l = CList.assoc_f equal id l
+  let remove_assoc id l = CList.remove_assoc_f equal id l
+  let mem_assoc id l = List.exists (fun (a,_) -> equal id a) l
+  let mem_assoc_sym id l = List.exists (fun (_,b) -> equal id b) l
+  let equal l l' = CList.equal equal l l'
+end
+
+let hcons = Hashcons.simple_hcons Hashcons.Hstring.generate Hashcons.Hstring.hcons ()
diff --git a/lib/cString.mli b/lib/cString.mli
new file mode 100644
index 00000000..4fa9e1e9
--- /dev/null
+++ b/lib/cString.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Module type [S] is the one from OCaml Stdlib. *)
+module type S = module type of String
+
+module type ExtS =
+sig
+  include S
+  (** We include the standard library *)
+
+  external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+  (** Equality on strings *)
+
+  val hash : string -> int
+  (** Hashing on strings. Should be compatible with generic one. *)
+
+  val is_empty : string -> bool
+  (** Test whether a string is empty. *)
+
+  val explode : string -> string list
+  (** [explode "x1...xn"] returns [["x1"; ...; "xn"]] *)
+
+  val implode : string list -> string
+  (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *)
+
+  val strip : string -> string
+  (** Remove the surrounding blank characters from a string *)
+
+  val map : (char -> char) -> string -> string
+  (** Apply a function on a string character-wise. *)
+
+  val drop_simple_quotes : string -> string
+  (** Remove the eventual first surrounding simple quotes of a string. *)
+
+  val string_index_from : string -> int -> string -> int
+  (** As [index_from], but takes a string instead of a char as pattern argument *)
+
+  val string_contains : where:string -> what:string -> bool
+  (** As [contains], but takes a string instead of a char as pattern argument *)
+
+  val plural : int -> string -> string
+  (** [plural n s] adds a optional 's' to the [s] when [2 <= n]. *)
+
+  val conjugate_verb_to_be : int -> string
+  (** [conjugate_verb_to_be] returns "is" when [n=1] and "are" otherwise *)
+
+  val ordinal : int -> string
+  (** Generate the ordinal number in English. *)
+
+  val split : char -> string -> string list
+  (** [split c s] splits [s] into sequences separated by [c], excluded. *)
+
+  val is_sub : string -> string -> int -> bool
+  (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *)
+
+  (** {6 Generic operations} **)
+
+  module Set : Set.S with type elt = t
+  (** Finite sets on [string] *)
+
+  module Map : CMap.ExtS with type key = t and module Set := Set
+  (** Finite maps on [string] *)
+
+  module List : CList.MonoS with type elt = t
+  (** Association lists with [string] as keys *)
+
+  val hcons : string -> string
+  (** Hashconsing on [string] *)
+
+end
+
+include ExtS
diff --git a/lib/cThread.ml b/lib/cThread.ml
new file mode 100644
index 00000000..55bb6fd6
--- /dev/null
+++ b/lib/cThread.ml
@@ -0,0 +1,76 @@
+(************************************************************************)
+(*  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 thread_ic = in_channel
+
+let prepare_in_channel_for_thread_friendly_io ic =
+  Unix.set_nonblock (Unix.descr_of_in_channel ic); ic
+
+let safe_wait_timed_read fd time =
+  try Thread.wait_timed_read fd time
+  with Unix.Unix_error (Unix.EINTR, _, _) ->
+    (** On Unix, the above function may raise this exception when it is
+        interrupted by a signal. (It uses Unix.select internally.) *)
+    false
+
+let thread_friendly_read_fd fd s ~off ~len =
+  let rec loop () =
+    try Unix.read fd s off len
+    with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) ->
+      while not (safe_wait_timed_read fd 1.0) do Thread.yield () done;
+      loop ()
+  in 
+    loop ()
+
+let thread_friendly_read ic s ~off ~len =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    thread_friendly_read_fd fd s ~off ~len
+  with Unix.Unix_error _ -> 0
+
+let really_read_fd fd s off len =
+  let i = ref 0 in
+  while !i < len do
+    let off = off + !i in
+    let len = len - !i in
+    let r = thread_friendly_read_fd fd s ~off ~len in
+    if r = 0 then raise End_of_file;
+    i := !i + r
+  done
+
+let thread_friendly_really_read ic s ~off ~len =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    really_read_fd fd s off len
+  with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_really_read_line ic =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    let b = Buffer.create 1024 in
+    let s = String.make 1 '\000' in
+    while s <> "\n" do
+      let n = thread_friendly_read_fd fd s ~off:0 ~len:1 in
+      if n = 0 then raise End_of_file;
+      if s <> "\n" then Buffer.add_string b s;
+    done;
+    Buffer.contents b
+  with Unix.Unix_error _ -> raise End_of_file
+
+let thread_friendly_input_value ic =
+  try
+    let fd = Unix.descr_of_in_channel ic in
+    let header = String.create Marshal.header_size in
+    really_read_fd fd header 0 Marshal.header_size;
+    let body_size = Marshal.data_size header 0 in
+    let msg = String.create (body_size + Marshal.header_size) in
+    String.blit header 0 msg 0 Marshal.header_size;
+    really_read_fd fd msg Marshal.header_size body_size;
+    Marshal.from_string msg 0
+  with Unix.Unix_error _ -> raise End_of_file
+
diff --git a/lib/cThread.mli b/lib/cThread.mli
new file mode 100644
index 00000000..8b110f3f
--- /dev/null
+++ b/lib/cThread.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* As of OCaml 4.01.0 input_value and input do not quite work well
+ * with threads.  The symptom is the following.  Two threads, each
+ * of them blocked on a read (on different channels).  One is not
+ * woken up even if data is available.  When the other one gets data
+ * then the stuck one is eventually unblocked too.  Unix.select with
+ * an unbounded wait has the same problem. *)
+
+(* Use only the following functions on the channel *)
+type thread_ic
+val prepare_in_channel_for_thread_friendly_io : in_channel -> thread_ic
+
+val thread_friendly_input_value : thread_ic -> 'a
+val thread_friendly_read :
+  thread_ic -> string -> off:int -> len:int -> int
+val thread_friendly_really_read :
+  thread_ic -> string -> off:int -> len:int -> unit
+val thread_friendly_really_read_line : thread_ic -> string
+
diff --git a/lib/cUnix.ml b/lib/cUnix.ml
new file mode 100644
index 00000000..4a1fc762
--- /dev/null
+++ b/lib/cUnix.ml
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Files and load path. *)
+
+type physical_path = string
+type load_path = physical_path list
+
+let physical_path_of_string s = s
+let string_of_physical_path p = p
+
+let path_to_list p =
+  let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in
+    Str.split sep p
+
+(* Some static definitions concerning filenames *)
+
+let dirsep = Filename.dir_sep (* Unix: "/" *)
+let dirsep_len = String.length dirsep
+let curdir = Filename.concat Filename.current_dir_name "" (* Unix: "./" *)
+let curdir_len = String.length curdir
+
+(* Hints to partially detects if two paths refer to the same directory *)
+
+(** cut path [p] after all the [/] that come at position [pos]. *)
+let rec cut_after_dirsep p pos =
+  if CString.is_sub dirsep p pos then
+    cut_after_dirsep p (pos + dirsep_len)
+  else
+    String.sub p pos (String.length p - pos)
+
+(** remove all initial "./" in a path unless the path is exactly "./" *)
+let rec remove_path_dot p =
+  if CString.is_sub curdir p 0 then
+    if String.length p = curdir_len
+    then Filename.current_dir_name
+    else remove_path_dot (cut_after_dirsep p curdir_len)
+  else
+    p
+
+(** If a path [p] starts with the current directory $PWD then
+    [strip_path p] returns the sub-path relative to $PWD.
+    Any leading "./" are also removed from the result. *)
+let strip_path p =
+  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
+  if CString.is_sub cwd p 0 then
+    remove_path_dot (cut_after_dirsep p (String.length cwd))
+  else
+    remove_path_dot p
+
+let canonical_path_name p =
+  let current = Sys.getcwd () in
+  try
+    Sys.chdir p;
+    let p' = Sys.getcwd () in
+    Sys.chdir current;
+    p'
+  with Sys_error _ ->
+    (* We give up to find a canonical name and just simplify it... *)
+    strip_path p
+
+let make_suffix name suffix =
+  if Filename.check_suffix name suffix then name else (name ^ suffix)
+
+let get_extension f =
+  let pos = try String.rindex f '.' with Not_found -> String.length f in
+  String.sub f pos (String.length f - pos)
+
+let correct_path f dir =
+  if Filename.is_relative f then Filename.concat dir f else f
+
+let file_readable_p name =
+  try Unix.access name [Unix.R_OK];true
+  with Unix.Unix_error (_, _, _) -> false
+
+(* As for [Unix.close_process], a [Unix.waipid] that ignores all [EINTR] *)
+
+let rec waitpid_non_intr pid =
+  try snd (Unix.waitpid [] pid)
+  with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
+(** [run_command com] launches command [com] (via /bin/sh),
+    and returns the contents of stdout and stderr. If given, [~hook]
+    is called on each elements read on stdout or stderr. *)
+
+let run_command ?(hook=(fun _ ->())) c =
+  let result = Buffer.create 127 in
+  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
+  let buff = String.make 127 ' ' in
+  let buffe = String.make 127 ' ' in
+  let n = ref 0 in
+  let ne = ref 0 in
+  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
+    !n+ !ne <> 0
+  do
+    let r = String.sub buff 0 !n in (hook r; Buffer.add_string result r);
+    let r = String.sub buffe 0 !ne in (hook r; Buffer.add_string result r);
+  done;
+  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
+
+(** [sys_command] launches program [prog] with arguments [args].
+    It behaves like [Sys.command], except that we rely on
+    [Unix.create_process], it's hardly more complex and avoids dealing
+    with shells. In particular, no need to quote arguments
+    (against whitespace or other funny chars in paths), hence no need
+    to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+let sys_command prog args =
+  let argv = Array.of_list (prog::args) in
+  let pid = Unix.create_process prog argv Unix.stdin Unix.stdout Unix.stderr in
+  waitpid_non_intr pid
+
+(*
+  checks if two file names refer to the same (existing) file by
+  comparing their device and inode.
+  It seems that under Windows, inode is always 0, so we cannot
+  accurately check if
+
+*)
+(* Optimised for partial application (in case many candidates must be
+   compared to f1). *)
+let same_file f1 =
+  try
+    let s1 = Unix.stat f1 in
+    (fun f2 ->
+      try
+        let s2 = Unix.stat f2 in
+        s1.Unix.st_dev = s2.Unix.st_dev &&
+          if Sys.os_type = "Win32" then f1 = f2
+          else s1.Unix.st_ino = s2.Unix.st_ino
+      with
+          Unix.Unix_error _ -> false)
+  with
+      Unix.Unix_error _ -> (fun _ -> false)
diff --git a/lib/cUnix.mli b/lib/cUnix.mli
new file mode 100644
index 00000000..2d0d202d
--- /dev/null
+++ b/lib/cUnix.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {5 System utilities} *)
+
+type physical_path = string
+type load_path = physical_path list
+
+val physical_path_of_string : string -> physical_path
+val string_of_physical_path : physical_path -> string
+
+val canonical_path_name : string -> string
+
+(** remove all initial "./" in a path *)
+val remove_path_dot : string -> string
+
+(** If a path [p] starts with the current directory $PWD then
+    [strip_path p] returns the sub-path relative to $PWD.
+    Any leading "./" are also removed from the result. *)
+val strip_path : string -> string
+
+(** correct_path f dir = dir/f if f is relative *)
+val correct_path : string -> string -> string
+
+val path_to_list : string -> string list
+
+(** [make_suffix file suf] catenate [file] with [suf] when
+    [file] does not already end with [suf]. *)
+val make_suffix : string -> string -> string
+
+(** Return the extension of a file, i.e. its smaller suffix starting
+    with "." if any, or "" otherwise. *)
+val get_extension : string -> string
+
+val file_readable_p : string -> bool
+
+(** {6 Executing commands } *)
+
+(** [run_command com] launches command [com], and returns
+    the contents of stdout and stderr. If given, [~hook]
+    is called on each elements read on stdout or stderr. *)
+
+val run_command :
+  ?hook:(string->unit) -> string -> Unix.process_status * string
+
+(** [sys_command] launches program [prog] with arguments [args].
+    It behaves like [Sys.command], except that we rely on
+    [Unix.create_process], it's hardly more complex and avoids dealing
+    with shells. In particular, no need to quote arguments
+    (against whitespace or other funny chars in paths), hence no need
+    to care about the different quoting conventions of /bin/sh and cmd.exe. *)
+
+val sys_command : string -> string list -> Unix.process_status
+
+(** A version of [Unix.waitpid] immune to EINTR exceptions *)
+
+val waitpid_non_intr : int -> Unix.process_status
+
+(** checks if two file names refer to the same (existing) file *)
+val same_file : string -> string -> bool
+
diff --git a/lib/gmapl.mli b/lib/canary.ml
index 5b81459b..23d7bd21 100644
--- a/lib/gmapl.mli
+++ b/lib/canary.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        *)
 (************************************************************************)
 
-(** Maps from ['a] to lists of ['b]. *)
+type t = Obj.t
 
-type ('a,'b) t
+let obj = Obj.new_block Obj.closure_tag 0
+  (** This is an empty closure block. In the current implementation, it is
+      sufficient to allow marshalling but forbid equality. Sadly still allows
+      hash. *)
+  (** FIXME : use custom blocks somehow. *)
 
-val empty : ('a,'b) t
-val mem :  'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b list -> unit) -> ('a,'b) t -> unit
-val map : ('b list -> 'c list) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b list -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
+module type Obj = sig type t end
 
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b list
-val remove : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
+module Make(M : Obj) =
+struct
+  type canary = t
+  type t = (canary * M.t)
+
+  let prj (_, x) = x
+  let inj x = (obj, x)
+end
diff --git a/library/goptionstyp.mli b/lib/canary.mli
index f23055b5..c0ba86a7 100644
--- a/library/goptionstyp.mli
+++ b/lib/canary.mli
@@ -1,26 +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        *)
 (************************************************************************)
 
-(** Some types used in the generic option mechanism (Goption) *)
+type t
+(** Type of canaries. Canaries are used to ensure that an object does not use
+    generic operations. *)
 
-(** Placing them here in a pure interface avoid some dependency issues
-    when compiling CoqIDE *)
+val obj : t
+(** Canary. In the current implementation, this object is marshallable,
+    forbids generic comparison but still allows generic hashes. *)
 
-type option_name = string list
+module type Obj = sig type t end
 
-type option_value =
-  | BoolValue   of bool
-  | IntValue    of int option
-  | StringValue of string
-
-type option_state = {
-  opt_sync  : bool;
-  opt_depr  : bool;
-  opt_name  : string;
-  opt_value : option_value;
-}
+module Make(M : Obj) :
+sig
+  type t
+  val prj : t -> M.t
+  val inj : M.t -> t
+end
+(** Adds a canary to any type. *)
diff --git a/lib/clib.mllib b/lib/clib.mllib
new file mode 100644
index 00000000..2da81c95
--- /dev/null
+++ b/lib/clib.mllib
@@ -0,0 +1,39 @@
+Coq_config
+
+Terminal
+Canary
+Hook
+Hashset
+Hashcons
+CSet
+CMap
+Int
+HMap
+Option
+Store
+Exninfo
+Backtrace
+IStream
+Pp_control
+Flags
+Control
+Loc
+Serialize
+Deque
+CObj
+CList
+CString
+CArray
+CStack
+Util
+Stateid
+Feedback
+Pp
+Xml_lexer
+Xml_parser
+Xml_printer
+Richpp
+CUnix
+Envars
+Aux_file
+Monad
diff --git a/lib/control.ml b/lib/control.ml
new file mode 100644
index 00000000..673a75a2
--- /dev/null
+++ b/lib/control.ml
@@ -0,0 +1,91 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*s interruption *)
+
+let interrupt = ref false
+
+let steps = ref 0
+
+let are_we_threading = lazy (
+  match !Flags.async_proofs_mode with
+  | Flags.APon -> true
+  | _ -> false)
+
+let check_for_interrupt () =
+  if !interrupt then begin interrupt := false; raise Sys.Break end;
+  incr steps;
+  if !steps = 1000 && Lazy.force are_we_threading then begin
+    Thread.delay 0.001;
+    steps := 0;
+  end
+
+(** This function does not work on windows, sigh... *)
+let unix_timeout n f e =
+  let timeout_handler _ = raise e in
+  let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
+  let _ = Unix.alarm n in
+  let restore_timeout () =
+    let _ = Unix.alarm 0 in
+    Sys.set_signal Sys.sigalrm psh
+  in
+  try
+    let res = f () in
+    restore_timeout ();
+    res
+  with e ->
+    let e = Backtrace.add_backtrace e in
+    restore_timeout ();
+    Exninfo.iraise e
+
+let windows_timeout n f e =
+  let killed = ref false in
+  let exited = ref false in
+  let thread init =
+    while not !killed do
+      let cur = Unix.time () in
+      if float_of_int n <= cur -. init then begin
+        interrupt := true;
+        exited := true;
+        Thread.exit ()
+      end;
+      Thread.delay 0.5
+    done
+  in
+  let init = Unix.time () in
+  let _id = Thread.create thread init in
+  try
+    let res = f () in
+    let () = killed := true in
+    let cur = Unix.time () in
+    (** The thread did not interrupt, but the computation took longer than
+        expected. *)
+    let () = if float_of_int n <= cur -. init then begin
+      exited := true;
+      raise Sys.Break
+    end in
+    res
+  with
+  | Sys.Break ->
+    (** Just in case, it could be a regular Ctrl+C *)
+    if not !exited then begin killed := true; raise Sys.Break end
+    else raise e
+  | e ->
+    let () = killed := true in
+    let e = Backtrace.add_backtrace e in
+    Exninfo.iraise e
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+let timeout_fun = match Sys.os_type with
+| "Unix" | "Cygwin" -> ref { timeout = unix_timeout }
+| _ -> ref { timeout = windows_timeout }
+
+let set_timeout f = timeout_fun := f
+
+let timeout n f e = !timeout_fun.timeout n f e
diff --git a/lib/control.mli b/lib/control.mli
new file mode 100644
index 00000000..2a496bca
--- /dev/null
+++ b/lib/control.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Global control of Coq. *)
+
+val interrupt : bool ref
+(** Coq interruption: set the following boolean reference to interrupt Coq
+    (it eventually raises [Break], simulating a Ctrl-C) *)
+
+val check_for_interrupt : unit -> unit
+(** Use this function as a potential yield function. If {!interrupt} has been
+    set, il will raise [Sys.Break]. *)
+
+val timeout : int -> (unit -> 'a) -> exn -> 'a
+(** [timeout n f e] tries to compute [f], and if it fails to do so before [n]
+    seconds, it raises [e] instead. *)
+
+type timeout = { timeout : 'a. int -> (unit -> 'a) -> exn -> 'a }
+
+val set_timeout : timeout -> unit
+(** Set a particular timeout function. *)
diff --git a/lib/deque.ml b/lib/deque.ml
new file mode 100644
index 00000000..c04d5993
--- /dev/null
+++ b/lib/deque.ml
@@ -0,0 +1,97 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+exception Empty
+
+type 'a t = {
+  face : 'a list;
+  rear : 'a list;
+  lenf : int;
+  lenr : int;
+}
+
+let rec split i accu l = match l with
+| [] ->
+  if Int.equal i 0 then (accu, []) else invalid_arg "split"
+| t :: q ->
+  if Int.equal i 0 then (accu, l)
+  else split (pred i) (t :: accu) q
+
+let balance q =
+  let avg = (q.lenf + q.lenr) / 2 in
+  let dif = q.lenf + q.lenr - avg in
+  if q.lenf > succ (2 * q.lenr) then
+    let (ff, fr) = split avg [] q.face in
+    { face = List.rev ff ; rear = q.rear @ List.rev fr; lenf = avg; lenr = dif }
+  else if q.lenr > succ (2 * q.lenf) then
+    let (rf, rr) = split avg [] q.rear in
+    { face = q.face @ List.rev rr ; rear = List.rev rf; lenf = dif; lenr = avg }
+  else q
+
+let empty = {
+  face = [];
+  rear = [];
+  lenf = 0;
+  lenr = 0;
+}
+
+let lcons x q =
+  balance { q with lenf = succ q.lenf; face = x :: q.face }
+
+let lhd q = match q.face with
+| [] ->
+  begin match q.rear with
+  | [] -> raise Empty
+  | t :: _ -> t
+  end
+| t :: _ -> t
+
+let ltl q = match q.face with
+| [] ->
+  begin match q.rear with
+  | [] -> raise Empty
+  | t :: _ -> empty
+  end
+| t :: r -> balance { q with lenf = pred q.lenf; face = r }
+
+let rcons x q =
+  balance { q with lenr = succ q.lenr; rear = x :: q.rear }
+
+let rhd q = match q.rear with
+| [] ->
+  begin match q.face with
+  | [] -> raise Empty
+  | t :: r -> t
+  end
+| t :: _ -> t
+
+let rtl q = match q.rear with
+| [] ->
+  begin match q.face with
+  | [] -> raise Empty
+  | t :: r -> empty
+  end
+| t :: r ->
+  balance { q with lenr = pred q.lenr; rear = r }
+
+let rev q = {
+  face = q.rear;
+  rear = q.face;
+  lenf = q.lenr;
+  lenr = q.lenf;
+}
+
+let length q = q.lenf + q.lenr
+
+let is_empty q = Int.equal (length q) 0
+
+let filter f q =
+  let fold (accu, len) x = if f x then (x :: accu, succ len) else (accu, len) in
+  let (rf, lenf) = List.fold_left fold ([], 0) q.face in
+  let (rr, lenr) = List.fold_left fold ([], 0) q.rear in
+  balance { face = List.rev rf; rear = List.rev rr; lenf = lenf; lenr = lenr }
diff --git a/lib/deque.mli b/lib/deque.mli
new file mode 100644
index 00000000..fd644e3c
--- /dev/null
+++ b/lib/deque.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Purely functional, double-ended queues *)
+
+(** This module implements the banker's deque, from Okasaki. Most operations are
+    amortized O(1). *)
+
+type +'a t
+
+exception Empty
+
+(** {5 Constructor} *)
+
+val empty : 'a t
+
+(** The empty deque. *)
+
+(** {5 Left-side operations} *)
+
+val lcons : 'a -> 'a t -> 'a t
+(** Pushes an element on the left side of the deque. *)
+
+val lhd : 'a t -> 'a
+(** Returns the leftmost element in the deque. Raises [Empty] when empty. *)
+
+val ltl : 'a t -> 'a t
+(** Returns the left-tail of the deque. Raises [Empty] when empty. *)
+
+(** {5 Right-side operations} *)
+
+val rcons : 'a -> 'a t -> 'a t
+(** Same as [lcons] but on the right side. *)
+
+val rhd : 'a t -> 'a
+(** Same as [lhd] but on the right side. *)
+
+val rtl : 'a t -> 'a t
+(** Same as [ltl] but on the right side. *)
+
+(** {5 Operations} *)
+
+val rev : 'a t -> 'a t
+(** Reverse deque. *)
+
+val length : 'a t -> int
+(** Length of a deque. *)
+
+val is_empty : 'a t -> bool
+(** Emptyness of a deque. *)
+
+val filter : ('a -> bool) -> 'a t -> 'a t
+(** Filters the deque *)
diff --git a/lib/dyn.ml b/lib/dyn.ml
index e756297f..63def9a1 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -1,25 +1,49 @@
 (************************************************************************)
 (*  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 Util
+open Errors
 
 (* Dynamics, programmed with DANGER !!! *)
 
-type t = string * Obj.t
+type t = int * Obj.t
 
-let dyntab = ref ([] : string list)
+let dyntab = ref (Int.Map.empty : string Int.Map.t)
+(** Instead of working with tags as strings, which are costly, we use their
+    hash. We ensure unicity of the hash in the [create] function. If ever a
+    collision occurs, which is unlikely, it is sufficient to tweak the offending
+    dynamic tag. *)
 
-let create s =
-  if List.mem s !dyntab then
-    anomaly ("Dyn.create: already declared dynamic " ^ s);
-  dyntab := s :: !dyntab;
-  ((fun v -> (s,Obj.repr v)),
-   (fun (s',rv) ->
-      if s = s' then Obj.magic rv else failwith "dyn_out"))
+let create (s : string) =
+  let hash = Hashtbl.hash s in
+  let () =
+    if Int.Map.mem hash !dyntab then
+      let old = Int.Map.find hash !dyntab in
+      let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in
+      anomaly ~label:"Dyn.create" msg
+  in
+  let () = dyntab := Int.Map.add hash s !dyntab in
+  let infun v = (hash, Obj.repr v) in
+  let outfun (nh, rv) =
+    if Int.equal hash nh then Obj.magic rv
+    else
+      let msg = (Pp.str ("dyn_out: expected " ^ s)) in
+      anomaly msg
+  in
+  (infun, outfun)
 
-let tag (s,_) = s
+let has_tag (s, _) tag =
+  let hash = Hashtbl.hash (tag : string) in
+  Int.equal s hash
+
+let tag (s,_) =
+  try Int.Map.find s !dyntab
+  with Not_found ->
+    let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in
+    anomaly msg
+
+let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 3ddde2b6..4a713472 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.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        *)
@@ -12,3 +12,5 @@ type t
 
 val create : string -> ('a -> t) * (t -> 'a)
 val tag : t -> string
+val has_tag : t -> string -> bool
+val pointer_equal : t -> t -> bool
diff --git a/lib/envars.ml b/lib/envars.ml
index 3040dd41..b0eed838 100644
--- a/lib/envars.ml
+++ b/lib/envars.ml
@@ -1,130 +1,219 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(* This file gathers environment variables needed by Coq to run (such
-   as coqlib) *)
+open Util
 
-let (//) s1 s2 = s1 ^ "/" ^ s2
+(** {1 Helper functions} *)
 
-let coqbin =
-  System.canonical_path_name (Filename.dirname Sys.executable_name)
+let getenv_else s dft = try Sys.getenv s with Not_found -> dft ()
 
-(* The following only makes sense when executables are running from
-   source tree (e.g. during build or in local mode). *)
-let coqroot = Filename.dirname coqbin
+let safe_getenv warning n =
+  getenv_else n (fun () ->
+    warning ("Environment variable "^n^" not found: using '$"^n^"' .");
+    ("$"^n)
+  )
 
-(* On win32, we add coqbin to the PATH at launch-time (this used to be
-   done in a .bat script). *)
+let ( / ) a b =
+  if Filename.is_relative b then a ^ "/" ^ b else b
 
-let _ =
-  if Coq_config.arch = "win32" then
-    Unix.putenv "PATH" (coqbin ^ ";" ^ System.getenv_else "PATH" "")
+let coqify d = d / "coq"
 
-let exe s = s ^ Coq_config.exec_extension
+let opt2list = function None -> [] | Some x -> [x]
 
-let reldir instdir testfile oth =
-  let rpath = if Coq_config.local then [] else instdir in
-  let out = List.fold_left (//) coqroot rpath in
-  if Sys.file_exists (out//testfile) then out else oth ()
-
-let guess_coqlib () =
-  let file = "states/initial.coq" in
-    reldir (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) file
-      (fun () ->
-        let coqlib = match Coq_config.coqlib with
-          | Some coqlib -> coqlib
-          | None -> coqroot
-        in
-        if Sys.file_exists (coqlib//file)
-        then coqlib
-        else Util.error "cannot guess a path for Coq libraries; please use -coqlib option")
-
-let coqlib () =
-  if !Flags.coqlib_spec then !Flags.coqlib else
-    (if !Flags.boot then coqroot else guess_coqlib ())
-
-let docdir () =
-  reldir (if Coq_config.arch = "win32" then ["doc"] else ["share";"doc";"coq"]) "html" (fun () -> Coq_config.docdir)
+let home ~warn =
+  getenv_else "HOME" (fun () ->
+    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
+      getenv_else "USERPROFILE" (fun () ->
+	warn ("Cannot determine user home directory, using '.' .");
+	Filename.current_dir_name))
 
 let path_to_list p =
-  let sep = if Sys.os_type = "Win32" then ';' else ':' in
-    Util.split_string_at sep p
+  let sep = if String.equal Sys.os_type "Win32" then ';' else ':' in
+    String.split sep p
+
+let user_path () =
+  path_to_list (Sys.getenv "PATH") (* may raise Not_found *)
+
+let rec which l f =
+  match l with
+    | [] ->
+      raise Not_found
+    | p :: tl ->
+      if Sys.file_exists (p / f) then
+	p
+      else
+	which tl f
+
+let expand_path_macros ~warn s =
+  let rec expand_atom s i =
+    let l = String.length s in
+    if i<l && (Util.is_digit s.[i] || Util.is_letter s.[i] || s.[i] == '_')
+    then expand_atom s (i+1)
+    else i in
+  let rec expand_macros s i =
+    let l = String.length s in
+    if Int.equal i l then s else
+      match s.[i] with
+	| '$' ->
+	  let n = expand_atom s (i+1) in
+	  let v = safe_getenv warn (String.sub s (i+1) (n-i-1)) in
+	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
+	  expand_macros s (i + String.length v)
+	| '~' when Int.equal i 0 ->
+	  let n = expand_atom s (i+1) in
+	  let v =
+	    if Int.equal n (i + 1) then home ~warn
+	    else (Unix.getpwnam (String.sub s (i+1) (n-i-1))).Unix.pw_dir
+	  in
+	  let s = v^(String.sub s n (l-n)) in
+	  expand_macros s (String.length v)
+	| c -> expand_macros s (i+1)
+  in expand_macros s 0
+
+(** {1 Paths} *)
+
+(** {2 Coq paths} *)
+
+let relative_base =
+  Filename.dirname (Filename.dirname Sys.executable_name)
 
-let xdg_data_home =
-    (System.getenv_else "XDG_DATA_HOME" (System.home//".local/share"))//"coq"
+let coqbin =
+  CUnix.canonical_path_name (Filename.dirname Sys.executable_name)
 
-let xdg_config_home =
-  (System.getenv_else "XDG_CONFIG_HOME" (System.home//".config"))//"coq"
+(** The following only makes sense when executables are running from
+    source tree (e.g. during build or in local mode). *)
+let coqroot =
+  Filename.dirname coqbin
 
-let xdg_data_dirs =
-  (try
-    List.map (fun dir -> dir//"coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
-  with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"])
-    @ (match Coq_config.datadir with |None -> [] |Some datadir -> [datadir])
+(** On win32, we add coqbin to the PATH at launch-time (this used to be
+    done in a .bat script). *)
+let _ =
+  if Coq_config.arch_is_win32 then
+    Unix.putenv "PATH" (coqbin ^ ";" ^ getenv_else "PATH" (fun () -> ""))
+
+(** [check_file_else ~dir ~file oth] checks if [file] exists in
+    the installation directory [dir] given relatively to [coqroot].
+    If this Coq is only locally built, then [file] must be in [coqroot].
+    If the check fails, then [oth ()] is evaluated. *)
+let check_file_else ~dir ~file oth =
+  let path = if Coq_config.local then coqroot else coqroot / dir in
+  if Sys.file_exists (path / file) then path else oth ()
+
+let guess_coqlib fail =
+  let prelude = "theories/Init/Prelude.vo" in
+  let dir = if Coq_config.arch_is_win32 then "lib" else "lib/coq" in
+  check_file_else ~dir ~file:prelude
+    (fun () ->
+      let coqlib = match Coq_config.coqlib with
+        | Some coqlib -> coqlib
+        | None -> coqroot
+      in
+      if Sys.file_exists (coqlib / prelude) then coqlib
+      else
+        fail "cannot guess a path for Coq libraries; please use -coqlib option")
+
+(** coqlib is now computed once during coqtop initialization *)
+
+let set_coqlib ~fail =
+  if not !Flags.coqlib_spec then
+    let lib = if !Flags.boot then coqroot else guess_coqlib fail in
+    Flags.coqlib := lib
+
+let coqlib () = !Flags.coqlib
 
-let xdg_dirs =
-  let dirs = xdg_data_home :: xdg_data_dirs
-  in
-  List.rev (List.filter Sys.file_exists dirs)
+let docdir () =
+  let dir = if Coq_config.arch_is_win32 then "doc" else "share/doc/coq" in
+  check_file_else ~dir ~file:"html" (fun () -> Coq_config.docdir)
 
 let coqpath =
-  try
-    let path = Sys.getenv "COQPATH" in
-      List.rev (List.filter Sys.file_exists (path_to_list path))
-  with Not_found -> []
+  let coqpath = getenv_else "COQPATH" (fun () -> "") in
+  let make_search_path path =
+    let paths = path_to_list path in
+    let valid_paths = List.filter Sys.file_exists paths in
+    List.rev valid_paths
+  in
+  make_search_path coqpath
 
-let rec which l f =
-  match l with
-    | [] -> raise Not_found
-    | p :: tl ->
-	if Sys.file_exists (p//f)
-	then p
-	else which tl f
+(** {2 Caml paths} *)
 
-let guess_camlbin () =
-  let path = Sys.getenv "PATH" in (* may raise Not_found *)
-  let lpath = path_to_list path in
-    which lpath (exe "ocamlc")
+let exe s = s ^ Coq_config.exec_extension
 
-let guess_camlp4bin () =
-  let path = Sys.getenv "PATH" in (* may raise Not_found *)
-  let lpath = path_to_list path in
-    which lpath (exe Coq_config.camlp4)
+let guess_camlbin () = which (user_path ()) (exe "ocamlc")
 
 let camlbin () =
   if !Flags.camlbin_spec then !Flags.camlbin else
     if !Flags.boot then Coq_config.camlbin else
-      try guess_camlbin () with e when e <> Sys.Break -> Coq_config.camlbin
+      try guess_camlbin () with Not_found -> Coq_config.camlbin
+
+let ocamlc () = camlbin () / Coq_config.ocamlc
+
+let ocamlopt () = camlbin () / Coq_config.ocamlopt
 
 let camllib () =
-  if !Flags.boot
-  then Coq_config.camllib
+  if !Flags.boot then
+    Coq_config.camllib
   else
-    let camlbin = camlbin () in
-    let com = (camlbin//"ocamlc") ^ " -where" in
-    let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in
-    Util.strip res
+    let _, res = CUnix.run_command (ocamlc () ^ " -where") in
+    String.strip res
+
+(** {2 Camlp4 paths} *)
+
+let guess_camlp4bin () = which (user_path ()) (exe Coq_config.camlp4)
 
 let camlp4bin () =
   if !Flags.camlp4bin_spec then !Flags.camlp4bin else
     if !Flags.boot then Coq_config.camlp4bin else
-      try guess_camlp4bin () with e when e <> Sys.Break ->
+      try guess_camlp4bin ()
+      with Not_found ->
         let cb = camlbin () in
-	if Sys.file_exists (cb//(exe Coq_config.camlp4)) then cb
-	else Coq_config.camlp4bin
+        if Sys.file_exists (cb / exe Coq_config.camlp4) then cb
+        else Coq_config.camlp4bin
+
+let camlp4 () = camlp4bin () / exe Coq_config.camlp4
 
 let camlp4lib () =
-  if !Flags.boot
-  then Coq_config.camlp4lib
+  if !Flags.boot then
+    Coq_config.camlp4lib
   else
-    let camlp4bin = camlp4bin () in
-    let com = (camlp4bin//Coq_config.camlp4) ^ " -where" in
-    let ex,res = System.run_command (fun x -> x) (fun _ -> ()) com in
+    let ex, res = CUnix.run_command (camlp4 () ^ " -where") in
     match ex with
-      |Unix.WEXITED 0 -> Util.strip res
-      |_ -> "/dev/null"
+      | Unix.WEXITED 0 -> String.strip res
+      | _ -> "/dev/null"
+
+(** {1 XDG utilities} *)
+
+let xdg_data_home warn =
+  coqify
+    (getenv_else "XDG_DATA_HOME" (fun () -> (home ~warn) / ".local/share"))
+
+let xdg_config_home warn =
+  coqify
+    (getenv_else "XDG_CONFIG_HOME" (fun () -> (home ~warn) / ".config"))
+
+let xdg_data_dirs warn =
+  let sys_dirs =
+    try
+      List.map coqify (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
+    with
+      | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "share"]
+      | Not_found -> ["/usr/local/share/coq";"/usr/share/coq"]
+  in
+  xdg_data_home warn :: sys_dirs @ opt2list Coq_config.datadir
+
+let xdg_config_dirs warn =
+  let sys_dirs =
+    try
+      List.map coqify (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
+    with
+      | Not_found when String.equal Sys.os_type "Win32" -> [relative_base / "config"]
+      | Not_found -> ["/etc/xdg/coq"]
+  in
+  xdg_config_home warn :: sys_dirs @ opt2list Coq_config.configdir
+
+let xdg_dirs ~warn =
+  List.filter Sys.file_exists (xdg_data_dirs warn)
diff --git a/lib/envars.mli b/lib/envars.mli
index 023b54c0..b62b9f28 100644
--- a/lib/envars.mli
+++ b/lib/envars.mli
@@ -1,25 +1,80 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** This file gathers environment variables needed by Coq to run (such
-   as coqlib) *)
+(** This file provides a high-level interface to the environment variables 
+    needed by Coq to run (such as coqlib). The values of these variables
+    may come from different sources (shell environment variables, 
+    command line options, options set at the time Coq was build). *)
 
+(** [expand_path_macros warn s] substitutes environment variables 
+    in a string by their values. This function also takes care of
+    substituting path of the form '~X' by an absolute path. 
+    Use [warn] as a message displayer. *)
+val expand_path_macros : warn:(string -> unit) -> string -> string
+
+(** [home warn] returns the root of the user directory, depending
+    on the OS. This information is usually stored in the $HOME 
+    environment variable on POSIX shells. If no such variable 
+    exists, then other common names are tried (HOMEDRIVE, HOMEPATH,
+    USERPROFILE). If all of them fail, [warn] is called. *)
+val home : warn:(string -> unit) -> string
+
+(** [coqlib] is the path to the Coq library. *)
 val coqlib : unit -> string
+
+(** [set_coqlib] must be runned once before any access to [coqlib] *)
+val set_coqlib : fail:(string -> string) -> unit
+
+(** [docdir] is the path to the Coq documentation. *)
 val docdir : unit -> string
+
+(** [coqbin] is the name of the current executable. *)
 val coqbin : string
+
+(** [coqroot] is the path to [coqbin]. 
+    The following value only makes sense when executables are running from
+    source tree (e.g. during build or in local mode). 
+*)
 val coqroot : string
-(* coqpath is stored in reverse order, since that is the order it
- * gets added to the searc path *)
-val xdg_config_home : string
-val xdg_dirs : string list
+
+(** [coqpath] is the standard path to coq. 
+    Notice that coqpath is stored in reverse order, since that is 
+    the order it gets added to the search path. *)
 val coqpath : string list
 
+(** [camlbin ()] is the path to the ocaml binaries. *)
 val camlbin : unit -> string
-val camlp4bin : unit -> string
+
+(** [camllib ()] is the path to the ocaml standard library. *)
 val camllib : unit -> string
+
+(** [ocamlc ()] is the ocaml bytecode compiler that compiled this Coq. *)
+val ocamlc   : unit -> string
+
+(** [ocamlc ()] is the ocaml native compiler that compiled this Coq. *)
+val ocamlopt : unit -> string
+
+(** [camlp4bin ()] is the path to the camlp4 binary. *)
+val camlp4bin : unit -> string
+
+(** [camlp4lib ()] is the path to the camlp4 library. *)
 val camlp4lib : unit -> string
+
+(** [camlp4 ()] is the camlp4 utility. *)
+val camlp4 : unit -> string
+
+(** Coq tries to honor the XDG Base Directory Specification to access
+    the user's configuration files.
+
+    see [http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html]
+*)
+val xdg_config_home : (string -> unit) -> string
+val xdg_data_home   : (string -> unit) -> string
+val xdg_config_dirs : (string -> unit) -> string list
+val xdg_data_dirs   : (string -> unit) -> string list
+val xdg_dirs : warn : (string -> unit) -> string list
diff --git a/lib/ephemeron.ml b/lib/ephemeron.ml
new file mode 100644
index 00000000..b36904ca
--- /dev/null
+++ b/lib/ephemeron.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  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 key_type = int
+
+type boxed_key = key_type ref ref
+
+let mk_key : unit -> boxed_key =
+  (* TODO: take a random value here. Is there a random function in OCaml? *) 
+  let bid = ref 0 in
+  (* According to OCaml Gc module documentation, Pervasives.ref is one of the
+     few ways of getting a boxed value the compiler will never alias. *)
+  fun () -> incr bid; Pervasives.ref (Pervasives.ref !bid)
+
+(* A phantom type to preserve type safety *)
+type 'a key = boxed_key
+
+(* Comparing keys with == grants that if a key is unmarshalled (in the same
+   process where it was created or in another one) it is not mistaken for
+   an already existing one (unmarshal has no right to alias).  If the initial
+   value of bid is taken at random, then one also avoids potential collisions *)
+module HT = Hashtbl.Make(struct
+  type t = key_type ref
+  let equal k1 k2 = k1 == k2
+  let hash id = !id
+end)
+
+(* A key is the (unique) value inside a boxed key, hence it does not
+   keep its corresponding boxed key reachable (replacing key_type by boxed_key
+   would make the key always reachable) *)
+let values : Obj.t HT.t = HT.create 1001
+
+(* To avoid a race contidion between the finalization function and
+   get/create on the values hashtable, the finalization function just
+   enqueues in an imperative list the item to be collected.  Being the list
+   imperative, even if the Gc enqueue an item while run_collection is operating,
+   the tail of the list is eventually set to Empty on completion.
+   Kudos to the authors of Why3 that came up with this solution for their
+   implementation of weak hash tables! *)
+type imperative_list = cell ref
+and cell = Empty | Item of key_type ref * imperative_list
+
+let collection_queue : imperative_list ref = ref (ref Empty)
+
+let enqueue x = collection_queue := ref (Item (!x, !collection_queue))
+
+let run_collection () =
+  let rec aux l = match !l with
+    | Empty -> ()
+    | Item (k, tl) -> HT.remove values k; aux tl in
+  let l = !collection_queue in
+  aux l;
+  l := Empty
+
+(* The only reference to the boxed key is the one returned, when the user drops
+   it the value eventually disappears from the values table above *)
+let create (v : 'a) : 'a key =
+  run_collection ();
+  let k = mk_key () in
+  HT.add values !k (Obj.repr v);
+  Gc.finalise enqueue k;
+  k
+
+(* Avoid raising Not_found *)
+exception InvalidKey
+let get (k : 'a key) : 'a =
+  run_collection ();
+  try Obj.obj (HT.find values !k)
+  with Not_found -> raise InvalidKey
+
+(* Simple utils *)
+let default k v =
+  try get k
+  with InvalidKey -> v
+
+let iter_opt k f =
+  match
+    try Some (get k)
+    with InvalidKey -> None
+  with
+  | None -> ()
+  | Some v -> f v
+
+let clear () = run_collection ()
diff --git a/lib/ephemeron.mli b/lib/ephemeron.mli
new file mode 100644
index 00000000..195b23db
--- /dev/null
+++ b/lib/ephemeron.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Use case:
+     You have a data structure that needs to be marshalled but it contains
+     unmarshallable data (like a closure, or a file descriptor).  Actually
+     you don't need this data to be preserved by marshalling, it just happens
+     to be there.
+     You could produced a trimmed down data structure, but then, once
+     unmarshalled, you can't used the very same code to process it, unless you
+     re-inject the trimmed down data structure into the standard one, using
+     dummy values for the unmarshallable stuff.
+     Similarly you could change your data structure turning all types [bad]
+     into [bad option], then just before marshalling you set all values of type
+     [bad option] to [None].  Still this pruning may be expensive and you have
+     to code it.
+
+   Desiderata:
+     The marshalling operation automatically discards values that cannot be
+     marshalled or cannot be properly unmarshalled.
+
+   Proposed solution:
+     Turn all occurrences of [bad] into [bad key] in your data structure.
+     Use [crate bad_val] to obtain a unique key [k] for [bad_val], and store
+     [k] in the data structure.  Use [get k] to obtain [bad_val].
+
+     An ['a key] can always be marshalled.  When marshalled, a key loses its
+     value.  The function [get] raises Not_found on unmarshalled keys.
+     
+     If a key is garbage collected, the corresponding value is garbage
+     collected too (unless extra references to it exist).
+     In short no memory management hassle, keys can just replace their
+     corresponding value in the data structure.  *)
+
+type 'a key
+
+val create : 'a -> 'a key
+
+(* May raise InvalidKey *)
+exception InvalidKey
+val get : 'a key -> 'a
+
+(* These never fail. *)
+val iter_opt : 'a key -> ('a -> unit) -> unit
+val default : 'a key -> 'a -> 'a
+
+val clear : unit -> unit
diff --git a/lib/errors.ml b/lib/errors.ml
index 6affea23..ab331d6a 100644
--- a/lib/errors.ml
+++ b/lib/errors.ml
@@ -8,8 +8,40 @@
 
 open Pp
 
-(* spiwack: it might be reasonable to decide and move the declarations
-   of Anomaly and so on to this module so as not to depend on Util. *)
+(** Aliases *)
+
+let push = Backtrace.add_backtrace
+
+(* Errors *)
+
+exception Anomaly of string option * std_ppcmds (* System errors *)
+
+let make_anomaly ?label pp =
+  Anomaly (label, pp)
+
+let anomaly ?loc ?label pp = match loc with
+  | None -> raise (Anomaly (label, pp))
+  | Some loc -> Loc.raise loc (Anomaly (label, pp))
+
+let is_anomaly = function
+| Anomaly _ -> true
+| _ -> false
+
+exception UserError of string * std_ppcmds (* User errors *)
+let error string = raise (UserError("_", str string))
+let errorlabstrm l pps = raise (UserError(l,pps))
+
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
+let todo s = prerr_string ("TODO: "^s^"\n")
+
+let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
+let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
+
+exception Timeout
+exception Drop
+exception Quit
 
 let handle_stack = ref []
 
@@ -34,14 +66,24 @@ let rec print_gen bottom stk e =
     In usual situation, the [handle_stack] is treated as it if was always
     non-empty with [print_anomaly] as its bottom handler. *)
 
-let where s =
+let where = function
+| None -> mt ()
+| Some s ->
   if !Flags.debug then str ("in "^s^":") ++ spc () else mt ()
 
 let raw_anomaly e = match e with
-  | Util.Anomaly (s,pps) -> where s ++ pps ++ str "."
+  | Anomaly (s, pps) -> where s ++ pps ++ str "."
   | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".")
   | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".")
 
+let print_backtrace e = match Backtrace.get_backtrace e with
+| None -> mt ()
+| Some bt ->
+  let bt = Backtrace.repr bt in
+  let pr_frame f = str (Backtrace.print_frame f) in
+  let bt = prlist_with_sep fnl pr_frame bt in
+  fnl () ++ hov 0 bt
+
 let print_anomaly askreport e =
   if askreport then
     hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.")
@@ -49,20 +91,20 @@ let print_anomaly askreport e =
     hov 0 (raw_anomaly e)
 
 (** The standard exception printer *)
-let print e = print_gen (print_anomaly true) !handle_stack e
+let print ?(info = Exninfo.null) e =
+  print_gen (print_anomaly true) !handle_stack e ++ print_backtrace info
+
+let iprint (e, info) = print ~info e
 
 (** Same as [print], except that the "Please report" part of an anomaly
     isn't printed (used in Ltac debugging). *)
 let print_no_report e = print_gen (print_anomaly false) !handle_stack e
 
-(** Same as [print], except that anomalies are not printed but re-raised
-    (used for the Fail command) *)
-let print_no_anomaly e = print_gen (fun e -> raise e) !handle_stack e
-
 (** Predefined handlers **)
 
 let _ = register_handler begin function
-  | Util.UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps)
+  | UserError(s, pps) ->
+    hov 0 (str "Error: " ++ where (Some s) ++ pps)
   | _ -> raise Unhandled
 end
 
@@ -70,10 +112,9 @@ end
     by inner functions during a [vernacinterp]. They should be handled
     only at the very end of interp, to be displayed to the user. *)
 
-(** NB: in the 8.4 branch, for maximal compatibility, anomalies
-    are considered non-critical *)
-
 let noncritical = function
-  | Sys.Break | Out_of_memory | Stack_overflow -> false
+  | Sys.Break | Out_of_memory | Stack_overflow
+  | Assert_failure _ | Match_failure _ | Anomaly _
+  | Timeout | Drop | Quit -> false
+  | Invalid_argument "equal: functional value" -> false
   | _ -> true
-
diff --git a/lib/errors.mli b/lib/errors.mli
index ae4d0b85..e4096a7e 100644
--- a/lib/errors.mli
+++ b/lib/errors.mli
@@ -6,9 +6,53 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
+open Pp
+
 (** This modules implements basic manipulations of errors for use
     throughout Coq's code. *)
 
+(** {6 Error handling} *)
+
+val push : exn -> Exninfo.iexn
+(** Alias for [Backtrace.add_backtrace]. *)
+
+(** {6 Generic errors.}
+
+ [Anomaly] is used for system errors and [UserError] for the
+   user's ones. *)
+
+val make_anomaly : ?label:string -> std_ppcmds -> exn
+(** Create an anomaly. *)
+
+val anomaly : ?loc:Loc.t -> ?label:string -> std_ppcmds -> 'a
+(** Raise an anomaly, with an optional location and an optional
+    label identifying the anomaly. *)
+
+val is_anomaly : exn -> bool
+(** Check whether a given exception is an anomaly.
+    This is mostly provided for compatibility. Please avoid doing specific
+    tricks with anomalies thanks to it. See rather [noncritical] below. *)
+
+exception UserError of string * std_ppcmds
+val error : string -> 'a
+val errorlabstrm : string -> std_ppcmds -> 'a
+val user_err_loc : Loc.t * string * std_ppcmds -> 'a
+
+exception AlreadyDeclared of std_ppcmds
+val alreadydeclared : std_ppcmds -> 'a
+
+val invalid_arg_loc : Loc.t * string -> 'a
+
+(** [todo] is for running of an incomplete code its implementation is
+   "do nothing" (or print a message), but this function should not be
+   used in a released code *)
+
+val todo : string -> unit
+
+exception Timeout
+exception Drop
+exception Quit
+
 (** [register_handler h] registers [h] as a handler.
     When an expression is printed with [print e], it
     goes through all registered handles (the most
@@ -30,20 +74,16 @@ exception Unhandled
 val register_handler : (exn -> Pp.std_ppcmds) -> unit
 
 (** The standard exception printer *)
-val print : exn -> Pp.std_ppcmds
+val print : ?info:Exninfo.info -> exn -> Pp.std_ppcmds
+val iprint : Exninfo.iexn -> Pp.std_ppcmds
 
 (** Same as [print], except that the "Please report" part of an anomaly
     isn't printed (used in Ltac debugging). *)
 val print_no_report : exn -> Pp.std_ppcmds
 
-(** Same as [print], except that anomalies are not printed but re-raised
-    (used for the Fail command) *)
-val print_no_anomaly : exn -> Pp.std_ppcmds
-
 (** Critical exceptions shouldn't be catched and ignored by mistake
     by inner functions during a [vernacinterp]. They should be handled
     only in [Toplevel.do_vernac] (or Ideslave), to be displayed to the user.
-    Typical example: [Sys.Break]. In the 8.4 branch, for maximal
-    compatibility, anomalies are not considered as critical...
+    Typical example: [Sys.Break], [Assert_failure], [Anomaly] ...
 *)
 val noncritical : exn -> bool
diff --git a/lib/exninfo.ml b/lib/exninfo.ml
new file mode 100644
index 00000000..d049dc6c
--- /dev/null
+++ b/lib/exninfo.ml
@@ -0,0 +1,104 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Enriched exceptions have an additional field at the end of their usual data
+    containing a pair composed of the distinguishing [token] and the backtrace
+    information. We discriminate the token by pointer equality. *)
+
+module Store = Store.Make(struct end)
+
+type 'a t = 'a Store.field
+
+type info = Store.t
+
+type iexn = exn * info
+
+let make = Store.field
+let add = Store.set
+let get = Store.get
+let null = Store.empty
+
+exception Unique
+
+let dummy = (Unique, Store.empty)
+
+let current : (int * iexn) list ref = ref []
+(** List associating to each thread id the latest exception raised by an
+    instrumented raise (i.e. {!raise} from this module). It is shared between
+    threads, so we must take care of this when modifying it.
+
+    Invariants: all index keys are unique in the list.
+*)
+
+let lock = Mutex.create ()
+
+let rec remove_assoc (i : int) = function
+| [] -> []
+| (j, v) :: rem as l ->
+  if i = j then rem
+  else
+    let ans = remove_assoc i rem in
+    if rem == ans then l
+    else (j, v) :: ans
+
+let rec find_and_remove_assoc (i : int) = function
+| [] -> dummy, []
+| (j, v) :: rem as l ->
+  if i = j then (v, rem)
+  else
+    let (r, ans) = find_and_remove_assoc i rem in
+    if rem == ans then (r, l)
+    else (r, (j, v) :: ans)
+
+let iraise e =
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := (id, e) :: remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise (fst e)
+
+let raise ?info e = match info with
+| None ->
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise e
+| Some i ->
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let () = current := (id, (e, i)) :: remove_assoc id !current in
+  let () = Mutex.unlock lock in
+  raise e
+
+let find_and_remove () =
+  let () = Mutex.lock lock in
+  let id = Thread.id (Thread.self ()) in
+  let (v, l) = find_and_remove_assoc id !current in
+  let () = current := l in
+  let () = Mutex.unlock lock in
+  v
+
+let info e =
+  let (src, data) = find_and_remove () in
+  if src == e then
+    (** Slightly unsound, some exceptions may not be unique up to pointer
+        equality. Though, it should be quite exceptional to be in a situation
+        where the following holds:
+
+        1. An argument-free exception is raised through the enriched {!raise};
+        2. It is not captured by any enriched with-clause (which would reset
+            the current data);
+        3. The same exception is raised through the standard raise, accessing
+            the wrong data.
+    . *)
+    data
+  else
+    (** Mismatch: the raised exception is not the one stored, either because the
+        previous raise was not instrumented, or because something went wrong. *)
+    Store.empty
diff --git a/lib/exninfo.mli b/lib/exninfo.mli
new file mode 100644
index 00000000..c960ac7c
--- /dev/null
+++ b/lib/exninfo.mli
@@ -0,0 +1,39 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Additional information worn by exceptions. *)
+
+type 'a t
+(** Information containing a given type. *)
+
+type info
+(** All information *)
+
+type iexn = exn * info
+(** Information-wearing exceptions *)
+
+val make : unit -> 'a t
+(** Create a new piece of information. *)
+
+val null : info
+(** No information *)
+
+val add : info -> 'a t -> 'a -> info
+(** Add information to an exception. *)
+
+val get : info -> 'a t -> 'a option
+(** Get information worn by an exception. Returns [None] if undefined. *)
+
+val info : exn -> info
+(** Retrieve the information of the last exception raised. *)
+
+val iraise : iexn -> 'a
+(** Raise the given enriched exception. *)
+
+val raise : ?info:info -> exn -> 'a
+(** Raise the given exception with additional information. *)
diff --git a/lib/explore.ml b/lib/explore.ml
index 31a96774..3d57fc08 100644
--- a/lib/explore.ml
+++ b/lib/explore.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        *)
@@ -21,7 +21,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   type position = int list
 
-  let msg_with_position p pp =
+  let msg_with_position (p : position) pp =
     let rec pp_rec = function
       | [] -> mt ()
       | [i] -> int i
@@ -50,7 +50,7 @@ module Make = functor(S : SearchProblem) -> struct
     in
     explore [1] s
 
-  (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
+  (*s Breadth first search. We use functional FIFOS à la Okasaki. *)
 
   type 'a queue = 'a list * 'a list
 
@@ -58,7 +58,7 @@ module Make = functor(S : SearchProblem) -> struct
 
   let empty = [],[]
 
-  let push x (h,t) = (x::h,t)
+  let push x (h,t) : _ queue = (x::h,t)
 
   let pop = function
     | h, x::t -> x, (h,t)
diff --git a/lib/explore.mli b/lib/explore.mli
index aaf11229..f3679188 100644
--- a/lib/explore.mli
+++ b/lib/explore.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/lib/feedback.ml b/lib/feedback.ml
new file mode 100644
index 00000000..a5e16ea0
--- /dev/null
+++ b/lib/feedback.ml
@@ -0,0 +1,171 @@
+(************************************************************************)
+(*  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 Xml_datatype
+open Serialize
+
+type message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+let of_message_level = function
+  | Debug s ->
+      Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s]
+  | Info -> Serialize.constructor "message_level" "info" []
+  | Notice -> Serialize.constructor "message_level" "notice" []
+  | Warning -> Serialize.constructor "message_level" "warning" []
+  | Error -> Serialize.constructor "message_level" "error" []
+let to_message_level =
+  Serialize.do_match "message_level" (fun s args -> match s with
+  | "debug" -> Debug (Serialize.raw_string args)
+  | "info" -> Info
+  | "notice" -> Notice
+  | "warning" -> Warning
+  | "error" -> Error
+  | _ -> raise Serialize.Marshal_error)
+
+let of_message msg =
+  let lvl = of_message_level msg.message_level in
+  let content = Serialize.of_string msg.message_content in
+  Xml_datatype.Element ("message", [], [lvl; content])
+let to_message xml = match xml with
+  | Xml_datatype.Element ("message", [], [lvl; content]) -> {
+      message_level = to_message_level lvl;
+      message_content = Serialize.to_string content }
+  | _ -> raise Serialize.Marshal_error
+
+let is_message = function
+  | Xml_datatype.Element ("message", _, _) -> true
+  | _ -> false
+
+
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+type feedback_content =
+  | Processed
+  | Incomplete
+  | Complete
+  | ErrorMsg of Loc.t * string
+  | ProcessingIn of string
+  | InProgress of int
+  | WorkerStatus of string * string
+  | Goals of Loc.t * string
+  | AddedAxiom
+  | GlobRef of Loc.t * string * string * string * string
+  | GlobDef of Loc.t * string * string * string
+  | FileDependency of string option * string
+  | FileLoaded of string * string
+  | Custom of Loc.t * string * xml
+  | Message of message
+
+type feedback = {
+  id : edit_or_state_id;
+  contents : feedback_content;
+  route : route_id;
+}
+
+let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
+  | "addedaxiom", _ -> AddedAxiom
+  | "processed", _ -> Processed
+  | "processingin", [where] -> ProcessingIn (to_string where)
+  | "incomplete", _ -> Incomplete
+  | "complete", _ -> Complete
+  | "globref", [loc; filepath; modpath; ident; ty] ->
+       GlobRef(to_loc loc, to_string filepath,
+         to_string modpath, to_string ident, to_string ty)
+  | "globdef", [loc; ident; secpath; ty] ->
+       GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty)
+  | "errormsg", [loc;  s] -> ErrorMsg (to_loc loc, to_string s)
+  | "inprogress", [n] -> InProgress (to_int n)
+  | "workerstatus", [ns] ->
+       let n, s = to_pair to_string to_string ns in
+       WorkerStatus(n,s)
+  | "goals", [loc;s] -> Goals (to_loc loc, to_string s)
+  | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x)
+  | "filedependency", [from; dep] ->
+      FileDependency (to_option to_string from, to_string dep)
+  | "fileloaded", [dirpath; filename] ->
+      FileLoaded (to_string dirpath, to_string filename)
+  | "message", [m] -> Message (to_message m)
+  | _ -> raise Marshal_error)
+let of_feedback_content = function
+  | AddedAxiom -> constructor "feedback_content" "addedaxiom" []
+  | Processed -> constructor "feedback_content" "processed" []
+  | ProcessingIn where ->
+      constructor "feedback_content" "processingin" [of_string where]
+  | Incomplete -> constructor "feedback_content" "incomplete" []
+  | Complete -> constructor "feedback_content" "complete" []
+  | GlobRef(loc, filepath, modpath, ident, ty) ->
+      constructor "feedback_content" "globref" [
+        of_loc loc;
+        of_string filepath;
+        of_string modpath;
+        of_string ident;
+        of_string ty ]
+  | GlobDef(loc, ident, secpath, ty) ->
+      constructor "feedback_content" "globdef" [
+        of_loc loc;
+        of_string ident;
+        of_string secpath;
+        of_string ty ]
+  | ErrorMsg(loc, s) ->
+      constructor "feedback_content" "errormsg" [of_loc loc; of_string s]
+  | InProgress n -> constructor "feedback_content" "inprogress" [of_int n]
+  | WorkerStatus(n,s) ->
+      constructor "feedback_content" "workerstatus"
+        [of_pair of_string of_string (n,s)]
+  | Goals (loc,s) ->
+      constructor "feedback_content" "goals" [of_loc loc;of_string s]
+  | Custom (loc, name, x) ->
+      constructor "feedback_content" "custom" [of_loc loc; of_string name; x]
+  | FileDependency (from, depends_on) ->
+      constructor "feedback_content" "filedependency" [
+        of_option of_string from;
+        of_string depends_on]
+  | FileLoaded (dirpath, filename) ->
+      constructor "feedback_content" "fileloaded" [
+        of_string dirpath;
+        of_string filename ]
+  | Message m -> constructor "feedback_content" "message" [ of_message m ]
+
+let of_edit_or_state_id = function
+  | Edit id -> ["object","edit"], of_edit_id id
+  | State id -> ["object","state"], Stateid.to_xml id
+
+let of_feedback msg =
+  let content = of_feedback_content msg.contents in
+  let obj, id = of_edit_or_state_id msg.id in
+  let route = string_of_int msg.route in
+  Element ("feedback", obj @ ["route",route], [id;content])
+let to_feedback xml = match xml with
+  | Element ("feedback", ["object","edit";"route",route], [id;content]) -> {
+      id = Edit(to_edit_id id);
+      route = int_of_string route;
+      contents = to_feedback_content content }
+  | Element ("feedback", ["object","state";"route",route], [id;content]) -> { 
+      id = State(Stateid.of_xml id);
+      route = int_of_string route;
+      contents = to_feedback_content content }
+  | _ -> raise Marshal_error
+
+let is_feedback = function
+  | Element ("feedback", _, _) -> true
+  | _ -> false
+
+let default_route = 0
diff --git a/lib/feedback.mli b/lib/feedback.mli
new file mode 100644
index 00000000..52a0e9fe
--- /dev/null
+++ b/lib/feedback.mli
@@ -0,0 +1,68 @@
+(************************************************************************)
+(*  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 Xml_datatype
+
+(* Old plain messages (used to be in Pp) *)
+type message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+val of_message : message -> xml
+val to_message : xml -> message
+val is_message : xml -> bool
+
+
+(** Coq "semantic" infos obtained during parsing/execution *)
+type edit_id = int
+type state_id = Stateid.t
+type edit_or_state_id = Edit of edit_id | State of state_id
+type route_id = int
+
+val default_route : route_id
+
+type feedback_content =
+  (* STM mandatory data (must be displayed) *)
+  | Processed
+  | Incomplete
+  | Complete
+  | ErrorMsg of Loc.t * string
+  (* STM optional data *)
+  | ProcessingIn of string
+  | InProgress of int
+  | WorkerStatus of string * string
+  (* Generally useful metadata *)
+  | Goals of Loc.t * string
+  | AddedAxiom
+  | GlobRef of Loc.t * string * string * string * string
+  | GlobDef of Loc.t * string * string * string
+  | FileDependency of string option * string
+  | FileLoaded of string * string
+  (* Extra metadata *)
+  | Custom of Loc.t * string * xml
+  (* Old generic messages *)
+  | Message of message
+
+type feedback = {
+  id : edit_or_state_id;       (* The document part concerned *)
+  contents : feedback_content;  (* The payload *)
+  route : route_id;            (* Extra routing info *)
+}
+
+val of_feedback : feedback -> xml
+val to_feedback : xml -> feedback
+val is_feedback : xml -> bool
+
diff --git a/lib/flags.ml b/lib/flags.ml
index f6d98ba5..c8e7f7af 100644
--- a/lib/flags.ml
+++ b/lib/flags.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,47 +8,116 @@
 
 let with_option o f x =
   let old = !o in o:=true;
-  try let r = f x in o := old; r
-  with reraise -> o := old; raise reraise
+   try let r = f x in if !o = true then o := old; r
+   with reraise ->
+     let reraise = Backtrace.add_backtrace reraise in
+     let () = o := old in
+     Exninfo.iraise reraise
+
+let with_options ol f x =
+  let vl = List.map (!) ol in
+  let () = List.iter (fun r -> r := true) ol in
+  try
+    let r = f x in
+    let () = List.iter2 (:=) ol vl in r
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = List.iter2 (:=) ol vl in
+    Exninfo.iraise reraise
 
 let without_option o f x =
   let old = !o in o:=false;
+  try let r = f x in if !o = false then o := old; r
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = o := old in
+    Exninfo.iraise reraise
+
+let with_extra_values o l f x =
+  let old = !o in o:=old@l;
   try let r = f x in o := old; r
-  with reraise -> o := old; raise reraise
+  with reraise ->
+    let reraise = Backtrace.add_backtrace reraise in
+    let () = o := old in
+    Exninfo.iraise reraise
 
 let boot = ref false
-
+let load_init = ref true
 let batch_mode = ref false
 
-let debug = ref false
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+let compilation_mode = ref BuildVo
+
+type async_proofs = APoff | APonLazy | APon
+let async_proofs_mode = ref APoff
+type cache = Force
+let async_proofs_cache = ref None
+let async_proofs_n_workers = ref 1
+let async_proofs_n_tacworkers = ref 2
+let async_proofs_private_flags = ref None
+let async_proofs_full = ref false
+let async_proofs_never_reopen_branch = ref false
+let async_proofs_flags_for_workers = ref []
+let async_proofs_worker_id = ref "master"
+type priority = Low | High
+let async_proofs_worker_priority = ref Low
+let string_of_priority = function Low -> "low" | High -> "high"
+let priority_of_string = function
+  | "low" -> Low
+  | "high" -> High
+  | _ -> raise (Invalid_argument "priority_of_string")
+
+let async_proofs_is_worker () =
+  !async_proofs_worker_id <> "master"
+let async_proofs_is_master () =
+  !async_proofs_mode = APon && !async_proofs_worker_id = "master"
 
-let print_emacs = ref false
+let debug = ref false
+let in_debugger = ref false
+let in_toplevel = ref false
 
-let term_quality = ref false
+let profile = false
 
-let xml_export = ref false
+let print_emacs = ref false
+let coqtop_ui = ref false
 
-type load_proofs = Force | Lazy | Dont
+let ide_slave = ref false
+let ideslave_coqtop_flags = ref None
 
-let load_proofs = ref Lazy
+let time = ref false
 
 let raw_print = ref false
 
 let record_print = ref true
 
+let univ_print = ref false
+
+let we_are_parsing = ref false
+
 (* Compatibility mode *)
 
 (* Current means no particular compatibility consideration.
    For correct comparisons, this constructor should remain the last one. *)
 
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
+
 let compat_version = ref Current
-let version_strictly_greater v = !compat_version > v
+
+let version_strictly_greater v = match !compat_version, v with
+| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false
+| V8_3, (V8_3 | V8_4 | Current) -> false
+| V8_4, (V8_4 | Current) -> false
+| Current, Current -> false
+| V8_3, V8_2 -> true
+| V8_4, (V8_2 | V8_3) -> true
+| Current, (V8_2 | V8_3 | V8_4) -> true
+
 let version_less_or_equal v = not (version_strictly_greater v)
 
 let pr_version = function
   | V8_2 -> "8.2"
   | V8_3 -> "8.3"
+  | V8_4 -> "8.4"
   | Current -> "current"
 
 (* Translate *)
@@ -73,7 +142,23 @@ let auto_intros = ref true
 let make_auto_intros flag = auto_intros := flag
 let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros
 
-let hash_cons_proofs = ref true
+let universe_polymorphism = ref false
+let make_universe_polymorphism b = universe_polymorphism := b
+let is_universe_polymorphism () = !universe_polymorphism
+
+let local_polymorphic_flag = ref None
+let use_polymorphic_flag () = 
+  match !local_polymorphic_flag with 
+  | Some p -> local_polymorphic_flag := None; p
+  | None -> is_universe_polymorphism ()
+let make_polymorphic_flag b =
+  local_polymorphic_flag := Some b
+
+(** [program_mode] tells that Program mode has been activated, either
+    globally via [Set Program] or locally via the Program command prefix. *)
+
+let program_mode = ref false
+let is_program_mode () = !program_mode
 
 let warn = ref true
 let make_warn flag = warn := flag;  ()
@@ -85,28 +170,8 @@ let print_hyps_limit = ref (None : int option)
 let set_print_hyps_limit n = print_hyps_limit := n
 let print_hyps_limit () = !print_hyps_limit
 
-(* A list of the areas of the system where "unsafe" operation
- * has been requested *)
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-let unsafe_set = ref Stringset.empty
-let add_unsafe s = unsafe_set := Stringset.add s !unsafe_set
-let is_unsafe s = Stringset.mem s !unsafe_set
-
 (* Flags for external tools *)
 
-let subst_command_placeholder s t =
-  let buff = Buffer.create (String.length s + String.length t) in
-  let i = ref 0 in
-  while (!i < String.length s) do
-    if s.[!i] = '%' & !i+1 < String.length s & s.[!i+1] = 's'
-    then (Buffer.add_string buff t;incr i)
-    else Buffer.add_char buff s.[!i];
-    incr i
-  done;
-  Buffer.contents buff
-
 let browser_cmd_fmt =
  try
   let coq_netscape_remote_var = "COQREMOTEBROWSER" in
@@ -122,21 +187,9 @@ let is_standard_doc_url url =
   url = Coq_config.wwwrefman ||
   url = wwwcompatprefix ^ String.sub Coq_config.wwwrefman n (n'-n)
 
-(* same as in System, but copied here because of dependencies *)
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  Sys.chdir p;
-  let result = Sys.getcwd () in
-  Sys.chdir current;
-  result
-
 (* Options for changing coqlib *)
 let coqlib_spec = ref false
-let coqlib = ref (
-  (* same as Envars.coqroot, but copied here because of dependencies *)
-  Filename.dirname
-    (canonical_path_name (Filename.dirname Sys.executable_name))
-)
+let coqlib = ref "(not initialized yet)"
 
 (* Options for changing camlbin (used by coqmktop) *)
 let camlbin_spec = ref false
@@ -152,3 +205,11 @@ let default_inline_level = 100
 let inline_level = ref default_inline_level
 let set_inline_level = (:=) inline_level
 let get_inline_level () = !inline_level
+
+(* Disabling native code compilation for conversion and normalization *)
+let no_native_compiler = ref Coq_config.no_native_compiler
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+let print_mod_uid = ref false
+
+let tactic_context_compat = ref false
diff --git a/lib/flags.mli b/lib/flags.mli
index ede4629c..756d3b85 100644
--- a/lib/flags.mli
+++ b/lib/flags.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        *)
@@ -9,24 +9,51 @@
 (** Global options of the system. *)
 
 val boot : bool ref
+val load_init : bool ref
 
 val batch_mode : bool ref
+type compilation_mode = BuildVo | BuildVio | Vio2Vo
+val compilation_mode : compilation_mode ref
+
+type async_proofs = APoff | APonLazy | APon
+val async_proofs_mode : async_proofs ref
+type cache = Force
+val async_proofs_cache : cache option ref
+val async_proofs_n_workers : int ref
+val async_proofs_n_tacworkers : int ref
+val async_proofs_private_flags : string option ref
+val async_proofs_is_worker : unit -> bool
+val async_proofs_is_master : unit -> bool
+val async_proofs_full : bool ref
+val async_proofs_never_reopen_branch : bool ref
+val async_proofs_flags_for_workers : string list ref
+val async_proofs_worker_id : string ref
+type priority = Low | High
+val async_proofs_worker_priority : priority ref
+val string_of_priority : priority -> string
+val priority_of_string : string -> priority
 
 val debug : bool ref
+val in_debugger : bool ref
+val in_toplevel : bool ref
+
+val profile : bool
 
 val print_emacs : bool ref
+val coqtop_ui : bool ref
 
-val term_quality : bool ref
+val ide_slave : bool ref
+val ideslave_coqtop_flags : string option ref
 
-val xml_export : bool ref
+val time : bool ref
 
-type load_proofs = Force | Lazy | Dont
-val load_proofs : load_proofs ref
+val we_are_parsing : bool ref
 
 val raw_print : bool ref
 val record_print : bool ref
+val univ_print : bool ref
 
-type compat_version = V8_2 | V8_3 | Current
+type compat_version = V8_2 | V8_3 | V8_4 | Current
 val compat_version : compat_version ref
 val version_strictly_greater : compat_version -> bool
 val version_less_or_equal : compat_version -> bool
@@ -48,25 +75,37 @@ val if_verbose : ('a -> unit) -> 'a -> unit
 val make_auto_intros : bool -> unit
 val is_auto_intros : unit -> bool
 
+val program_mode : bool ref
+val is_program_mode : unit -> bool
+
+(** Global universe polymorphism flag. *)
+val make_universe_polymorphism : bool -> unit
+val is_universe_polymorphism : unit -> bool
+
+(** Local universe polymorphism flag. *)
+val make_polymorphic_flag : bool -> unit
+val use_polymorphic_flag : unit -> bool
+
 val make_warn : bool -> unit
 val if_warn : ('a -> unit) -> 'a -> unit
 
-val hash_cons_proofs : bool ref
-
-(** Temporary activate an option (to activate option [o] on [f x y z],
+(** Temporarily activate an option (to activate option [o] on [f x y z],
    use [with_option o (f x y) z]) *)
 val with_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
-(** Temporary deactivate an option *)
+(** As [with_option], but on several flags. *)
+val with_options : bool ref list -> ('a -> 'b) -> 'a -> 'b
+
+(** Temporarily deactivate an option *)
 val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b
 
+(** Temporarily extends the reference to a list *)
+val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b
+
 (** If [None], no limit *)
 val set_print_hyps_limit : int option -> unit
 val print_hyps_limit : unit -> int option
 
-val add_unsafe : string -> unit
-val is_unsafe : string -> bool
-
 (** Options for external tools *)
 
 (** Returns string format for default browser to use from Coq or CoqIDE *)
@@ -74,9 +113,6 @@ val browser_cmd_fmt : string
 
 val is_standard_doc_url : string -> bool
 
-(** Substitute %s in the first chain by the second chain *)
-val subst_command_placeholder : string -> string -> string
-
 (** Options for specifying where coq librairies reside *)
 val coqlib_spec : bool ref
 val coqlib : string ref
@@ -91,3 +127,13 @@ val camlp4bin : string ref
 val set_inline_level : int -> unit
 val get_inline_level : unit -> int
 val default_inline_level : int
+
+(* Disabling native code compilation for conversion and normalization *)
+val no_native_compiler : bool ref
+
+(* Print the mod uid associated to a vo file by the native compiler *)
+val print_mod_uid : bool ref
+
+val tactic_context_compat : bool ref
+(** Set to [true] to trigger the compatibility bugged context matching (old
+    context vs. appcontext) is set. *)
diff --git a/lib/fmap.ml b/lib/fmap.ml
deleted file mode 100644
index 8ca56fe7..00000000
--- a/lib/fmap.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-
-module Make = functor (X:Map.OrderedType) -> struct
-  type key = X.t
-  type 'a t =
-        Empty
-      | Node of 'a t * key * 'a * 'a t * int
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let height = function
-        Empty -> 0
-      | Node(_,_,_,_,h) -> h
-
-    let create l x d r =
-      let hl = height l and hr = height r in
-      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let bal l x d r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Map.bal"
-        | Node(ll, lv, ld, lr, _) ->
-            if height ll >= height lr then
-              create ll lv ld (create lr x d r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Map.bal"
-              | Node(lrl, lrv, lrd, lrr, _)->
-                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Map.bal"
-        | Node(rl, rv, rd, rr, _) ->
-            if height rr >= height rl then
-              create (create l x d rl) rv rd rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Map.bal"
-              | Node(rll, rlv, rld, rlr, _) ->
-                  create (create l x d rll) rlv rld (create rlr rv rd rr)
-            end
-      end else
-        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let rec add x data = function
-        Empty ->
-          Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) ->
-          let c = X.compare x v in
-          if c = 0 then
-            Node(l, x, data, r, h)
-          else if c < 0 then
-            bal (add x data l) v d r
-          else
-            bal l v d (add x data r)
-
-    let rec find x = function
-        Empty ->
-          raise Not_found
-      | Node(l, v, d, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then d
-          else find x (if c < 0 then l else r)
-
-    let rec mem x = function
-        Empty ->
-          false
-      | Node(l, v, d, r, _) ->
-          let c = X.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec min_binding = function
-        Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
-
-    let rec remove_min_binding = function
-        Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
-      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
-    let merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (_, _) ->
-          let (x, d) = min_binding t2 in
-          bal t1 x d (remove_min_binding t2)
-
-    let rec remove x = function
-        Empty ->
-          Empty
-      | Node(l, v, d, r, h) ->
-          let c = X.compare x v in
-          if c = 0 then
-            merge l r
-          else if c < 0 then
-            bal (remove x l) v d r
-          else
-            bal l v d (remove x r)
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, d, r, _) ->
-          iter f l; f v d; iter f r
-
-    let rec map f = function
-        Empty               -> Empty
-      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
-    (* Maintien de fold_right par compatibilité (changé en fold_left dans
-       ocaml-3.09.0) *)
-
-    let rec fold f m accu =
-      match m with
-        Empty -> accu
-      | Node(l, v, d, r, _) ->
-          fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
-    let dom m = fold (fun x _ acc -> x::acc) m []
-
-    let rng m = fold (fun _ y acc -> y::acc) m []
-
-    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
-end
diff --git a/lib/fmap.mli b/lib/fmap.mli
deleted file mode 100644
index 2c8dedd7..00000000
--- a/lib/fmap.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-
-module Make : functor (X : Map.OrderedType) ->
-sig
-  type key = X.t
-  type 'a t
-
-val empty : 'a t
-val is_empty : 'a t -> bool
-val add : key -> 'a -> 'a t -> 'a t
-val find : key -> 'a t -> 'a
-val remove : key -> 'a t -> 'a t
-val mem :  key -> 'a t -> bool
-val iter : (key -> 'a -> unit) -> 'a t -> unit
-val map : ('a -> 'b) -> 'a t -> 'b t
-val fold : (key -> 'a -> 'c -> 'c) -> 'a t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : 'a t -> key list
-val rng : 'a t -> 'a list
-val to_list : 'a t -> (key * 'a) list
-end
- 
diff --git a/lib/fset.ml b/lib/fset.ml
deleted file mode 100644
index 567feaa7..00000000
--- a/lib/fset.ml
+++ /dev/null
@@ -1,235 +0,0 @@
-module Make = functor (X : Set.OrderedType) ->
-struct
-  
-  type elt = X.t
-    type t = Empty | Node of t * elt * t * int
-
-
-    (* Sets are represented by balanced binary trees (the heights of the
-       children differ by at most 2 *)
-
-    let height = function
-        Empty -> 0
-      | Node(_, _, _, h) -> h
-
-    (* Creates a new node with left son l, value x and right son r.
-       l and r must be balanced and | height l - height r | <= 2.
-       Inline expansion of height for better speed. *)
-
-    let create l x r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
-      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    (* Same as create, but performs one step of rebalancing if necessary.
-       Assumes l and r balanced.
-       Inline expansion of create for better speed in the most frequent case
-       where no rebalancing is required. *)
-
-    let bal l x r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Set.bal"
-        | Node(ll, lv, lr, _) ->
-            if height ll >= height lr then
-              create ll lv (create lr x r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Set.bal"
-              | Node(lrl, lrv, lrr, _)->
-                  create (create ll lv lrl) lrv (create lrr x r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Set.bal"
-        | Node(rl, rv, rr, _) ->
-            if height rr >= height rl then
-              create (create l x rl) rv rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Set.bal"
-              | Node(rll, rlv, rlr, _) ->
-                  create (create l x rll) rlv (create rlr rv rr)
-            end
-      end else
-        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    (* Same as bal, but repeat rebalancing until the final result
-       is balanced. *)
-
-    let rec join l x r =
-      match bal l x r with
-        Empty -> invalid_arg "Set.join"
-      | Node(l', x', r', _) as t' ->
-          let d = height l' - height r' in
-          if d < -2 or d > 2 then join l' x' r' else t'
-
-    (* Merge two trees l and r into one.
-       All elements of l must precede the elements of r.
-       Assumes | height l - height r | <= 2. *)
-
-    let rec merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          bal l1 v1 (bal (merge r1 l2) v2 r2)
-
-    (* Same as merge, but does not assume anything about l and r. *)
-
-    let rec concat t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          join l1 v1 (join (concat r1 l2) v2 r2)
-
-    (* Splitting *)
-
-    let rec split x = function
-        Empty ->
-          (Empty, None, Empty)
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then (l, Some v, r)
-          else if c < 0 then
-            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
-          else
-            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
-
-    (* Implementation of the set operations *)
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let rec mem x = function
-        Empty -> false
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec add x = function
-        Empty -> Node(Empty, x, Empty, 1)
-      | Node(l, v, r, _) as t ->
-          let c = X.compare x v in
-          if c = 0 then t else
-          if c < 0 then bal (add x l) v r else bal l v (add x r)
-
-    let singleton x = Node(Empty, x, Empty, 1)
-
-    let rec remove x = function
-        Empty -> Empty
-      | Node(l, v, r, _) ->
-          let c = X.compare x v in
-          if c = 0 then merge l r else
-          if c < 0 then bal (remove x l) v r else bal l v (remove x r)
-
-    let rec union s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> t2
-      | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
-          if h1 >= h2 then
-            if h2 = 1 then add v2 s1 else begin
-              let (l2, _, r2) = split v1 s2 in
-              join (union l1 l2) v1 (union r1 r2)
-            end
-          else
-            if h1 = 1 then add v1 s2 else begin
-              let (l1, _, r1) = split v2 s1 in
-              join (union l1 l2) v2 (union r1 r2)
-            end
-
-    let rec inter s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> Empty
-      | (Node(l1, v1, r1, _), t2) ->
-          match split v1 t2 with
-            (l2, None, r2) ->
-              concat (inter l1 l2) (inter r1 r2)
-          | (l2, Some _, r2) ->
-              join (inter l1 l2) v1 (inter r1 r2)
-
-    let rec diff s1 s2 =
-      match (s1, s2) with
-        (Empty, t2) -> Empty
-      | (t1, Empty) -> t1
-      | (Node(l1, v1, r1, _), t2) ->
-          match split v1 t2 with
-            (l2, None, r2) ->
-              join (diff l1 l2) v1 (diff r1 r2)
-          | (l2, Some _, r2) ->
-              concat (diff l1 l2) (diff r1 r2)
-
-    let rec compare_aux l1 l2 =
-        match (l1, l2) with
-        ([], []) -> 0
-      | ([], _)  -> -1
-      | (_, []) -> 1
-      | (Empty :: t1, Empty :: t2) ->
-          compare_aux t1 t2
-      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
-          let c = compare v1 v2 in
-          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
-      | (Node(l1, v1, r1, _) :: t1, t2) ->
-          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
-      | (t1, Node(l2, v2, r2, _) :: t2) ->
-          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
-
-    let compare s1 s2 =
-      compare_aux [s1] [s2]
-
-    let equal s1 s2 =
-      compare s1 s2 = 0
-
-    let rec subset s1 s2 =
-      match (s1, s2) with
-        Empty, _ ->
-          true
-      | _, Empty ->
-          false
-      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
-          let c = X.compare v1 v2 in
-          if c = 0 then
-            subset l1 l2 && subset r1 r2
-          else if c < 0 then
-            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
-          else
-            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, r, _) -> iter f l; f v; iter f r
-
-    let rec fold f s accu =
-      match s with
-        Empty -> accu
-      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))
-
-    let rec cardinal = function
-        Empty -> 0
-      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
-
-    let rec elements_aux accu = function
-        Empty -> accu
-      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
-
-    let elements s =
-      elements_aux [] s
-
-    let rec min_elt = function
-        Empty -> raise Not_found
-      | Node(Empty, v, r, _) -> v
-      | Node(l, v, r, _) -> min_elt l
-
-    let rec max_elt = function
-        Empty -> raise Not_found
-      | Node(l, v, Empty, _) -> v
-      | Node(l, v, r, _) -> max_elt r
-
-    let choose = min_elt
-end
diff --git a/lib/fset.mli b/lib/fset.mli
deleted file mode 100644
index b1751d0b..00000000
--- a/lib/fset.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-module Make : functor (X : Set.OrderedType) ->
-sig
-  type elt = X.t
-  type  t
-
-val empty :  t
-val is_empty :  t -> bool
-val mem : elt ->  t -> bool
-val add : elt ->  t ->  t
-val singleton : elt ->  t
-val remove : elt -> t -> t
-val union : t -> t -> t
-val inter : t -> t -> t
-val diff : t -> t -> t
-val compare : t -> t -> int
-val equal : t -> t -> bool
-val subset : t -> t -> bool
-val iter : ( elt -> unit) -> t -> unit
-val fold : (elt -> 'b -> 'b) -> t -> 'b -> 'b
-val cardinal : t -> int
-val elements : t -> elt list
-val min_elt : t -> elt
-val max_elt : t -> elt
-val choose : t -> elt
-end
diff --git a/lib/future.ml b/lib/future.ml
new file mode 100644
index 00000000..2f1ce5e4
--- /dev/null
+++ b/lib/future.ml
@@ -0,0 +1,220 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* To deal with side effects we have to save/restore the system state *)
+let freeze = ref (fun () -> assert false : unit -> Dyn.t)
+let unfreeze = ref (fun _ -> () : Dyn.t -> unit)
+let set_freeze f g = freeze := f; unfreeze := g
+
+exception NotReady
+exception NotHere
+let _ = Errors.register_handler (function
+  | NotReady ->
+      Pp.strbrk("The value you are asking for is not ready yet. " ^
+                "Please wait or pass "^
+                "the \"-async-proofs off\" option to CoqIDE to disable "^
+                "asynchronous script processing.")
+  | NotHere ->
+      Pp.strbrk("The value you are asking for is not available "^
+                "in this process. If you really need this, pass "^
+                "the \"-async-proofs off\" option to CoqIDE to disable "^
+                "asynchronous script processing.")
+  | _ -> raise Errors.Unhandled)
+
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+let id x = prerr_endline "Future: no fix_exn.\nYou have probably created a Future.computation from a value without passing the ~fix_exn argument.  You probably want to chain with an already existing future instead."; x
+
+module UUID = struct
+  type t = int
+  let invalid = 0
+  let fresh =
+    let count = ref invalid in
+    fun () -> incr count; !count
+
+  let compare = compare
+  let equal = (==)
+end
+
+module UUIDMap = Map.Make(UUID)
+module UUIDSet = Set.Make(UUID)
+
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+
+(* Val is not necessarily a final state, so the
+   computation restarts from the state stocked into Val *)
+and 'a comp =
+  | Delegated of (unit -> unit)
+  | Closure of (unit -> 'a)
+  | Val of 'a * Dyn.t option
+  | Exn of Exninfo.iexn  (* Invariant: this exception is always "fixed" as in fix_exn *)
+
+and 'a comput =
+  | Ongoing of (UUID.t * fix_exn * 'a comp ref) Ephemeron.key
+  | Finished of 'a
+
+and 'a computation = 'a comput ref
+
+let create ?(uuid=UUID.fresh ()) f x =
+  ref (Ongoing (Ephemeron.create (uuid, f, Pervasives.ref x)))
+let get x =
+  match !x with
+  | Finished v -> UUID.invalid, id, ref (Val (v,None))
+  | Ongoing x ->
+      try Ephemeron.get x
+      with Ephemeron.InvalidKey ->
+        UUID.invalid, id, ref (Exn (NotHere, Exninfo.null))
+
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn  ]
+
+let is_over kx = let _, _, x = get kx in match !x with
+  | Val _ | Exn _ -> true
+  | Closure _ | Delegated _ -> false
+
+let is_val kx = let _, _, x = get kx in match !x with
+  | Val _ -> true
+  | Exn _ | Closure _ | Delegated _ -> false
+
+let is_exn kx = let _, _, x = get kx in match !x with
+  | Exn _ -> true
+  | Val _ | Closure _ | Delegated _ -> false
+
+let peek_val kx = let _, _, x = get kx in match !x with
+  | Val (v, _) -> Some v
+  | Exn _ | Closure _ | Delegated _ -> None
+
+let uuid kx = let id, _, _ = get kx in id
+
+let from_val ?(fix_exn=id) v = create fix_exn (Val (v, None))
+let from_here ?(fix_exn=id) v = create fix_exn (Val (v, Some (!freeze ())))
+
+let fix_exn_of ck = let _, fix_exn, _ = get ck in fix_exn
+
+let create_delegate ?(blocking=true) fix_exn =
+  let assignement signal ck = fun v ->
+    let _, fix_exn, c = get ck in
+    assert (match !c with Delegated _ -> true | _ -> false);
+    begin match v with
+    | `Val v -> c := Val (v, None)
+    | `Exn e -> c := Exn (fix_exn e)
+    | `Comp f -> let _, _, comp = get f in c := !comp end;
+    signal () in
+  let wait, signal =
+    if not blocking then (fun () -> raise NotReady), ignore else
+    let lock = Mutex.create () in
+    let cond = Condition.create () in
+    (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock),
+    (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in
+  let ck = create fix_exn (Delegated wait) in
+  ck, assignement signal ck
+
+(* TODO: get rid of try/catch to be stackless *)
+let rec compute ~pure ck : 'a value =
+  let _, fix_exn, c = get ck in
+  match !c with
+  | Val (x, _) -> `Val x
+  | Exn (e, info) -> `Exn (e, info)
+  | Delegated wait -> wait (); compute ~pure ck
+  | Closure f ->
+      try
+        let data = f () in
+        let state = if pure then None else Some (!freeze ()) in
+        c := Val (data, state); `Val data
+      with e ->
+        let e = Errors.push e in
+        let e = fix_exn e in
+        match e with
+        | (NotReady, _) -> `Exn e
+        | _ -> c := Exn e; `Exn e
+
+let force ~pure x = match compute ~pure x with
+  | `Val v -> v
+  | `Exn e -> Exninfo.iraise e
+
+let chain ~pure ck f =
+  let uuid, fix_exn, c = get ck in
+  create ~uuid fix_exn (match !c with
+  | Closure _ | Delegated _ -> Closure (fun () -> f (force ~pure ck))
+  | Exn _ as x -> x
+  | Val (v, None) when pure -> Closure (fun () -> f v)
+  | Val (v, Some _) when pure -> Closure (fun () -> f v)
+  | Val (v, Some state) -> Closure (fun () -> !unfreeze state; f v)
+  | Val (v, None) ->
+      match !ck with
+      | Finished _ -> Errors.anomaly(Pp.str
+          "Future.chain ~pure:false call on an already joined computation")
+      | Ongoing _ -> Errors.anomaly(Pp.strbrk(
+          "Future.chain ~pure:false call on a pure computation. "^
+          "This can happen if the computation was initial created with "^
+          "Future.from_val or if it was Future.chain ~pure:true with a "^
+          "function and later forced.")))
+
+let create fix_exn f = create fix_exn (Closure f)
+
+let replace kx y =
+  let _, _, x = get kx in
+  match !x with
+  | Exn _ -> x := Closure (fun () -> force ~pure:false y)
+  | _ -> Errors.anomaly
+           (Pp.str "A computation can be replaced only if is_exn holds")
+
+let purify f x =
+  let state = !freeze () in
+  try
+    let v = f x in
+    !unfreeze state;
+    v
+  with e ->
+    let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let transactify f x =
+  let state = !freeze () in
+  try f x
+  with e ->
+    let e = Errors.push e in !unfreeze state; Exninfo.iraise e
+
+let purify_future f x = if is_over x then f x else purify f x
+let compute x = purify_future (compute ~pure:false) x
+let force ~pure x = purify_future (force ~pure) x
+let chain ?(greedy=true) ~pure x f =
+  let y = chain ~pure x f in
+  if is_over x && greedy then ignore(force ~pure y);
+  y
+let force x = force ~pure:false x
+
+let join kx =
+  let v = force kx in
+  kx := Finished v;
+  v
+
+let sink kx = if is_val kx then ignore(join kx)
+
+let split2 ?greedy x =
+  chain ?greedy ~pure:true x (fun x -> fst x),
+  chain ?greedy ~pure:true x (fun x -> snd x)
+
+let map2 ?greedy f x l =
+  CList.map_i (fun i y ->
+    let xi = chain ?greedy ~pure:true x (fun x ->
+        try List.nth x i
+        with Failure _ | Invalid_argument _ ->
+          Errors.anomaly (Pp.str "Future.map2 length mismatch")) in
+    f xi y) 0 l
+
+let print f kx =
+  let open Pp in
+  let (uid, _, x) = get kx in
+  let uid =
+    if UUID.equal uid UUID.invalid then str "[#]"
+    else str "[" ++ int uid ++ str "]"
+  in
+  match !x with
+  | Delegated _ -> str "Delegated" ++ uid
+  | Closure _ -> str "Closure" ++ uid
+  | Val (x, None) -> str "PureVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Val (x, Some _) -> str "StateVal" ++ uid ++ spc () ++ hov 0 (f x)
+  | Exn (e, _) -> str "Exn"  ++ uid ++ spc () ++ hov 0 (str (Printexc.to_string e))
diff --git a/lib/future.mli b/lib/future.mli
new file mode 100644
index 00000000..8a4fa0bd
--- /dev/null
+++ b/lib/future.mli
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Futures: asynchronous computations with some purity enforcing
+ *
+ * A Future.computation is like a lazy_t but with some extra bells and whistles
+ * to deal with imperative code and eventual delegation to a slave process.
+ *
+ * Example of a simple scenario taken into account:
+ *
+ *   let f = Future.from_here (number_of_constants (Global.env())) in
+ *   let g = Future.chain ~pure:false f (fun n ->
+ *             n = number_of_constants (Global.env())) in
+ *   ...
+ *   Lemmas.save_named ...;
+ *   ...
+ *   let b = Future.force g in
+ *
+ * The Future.computation f holds a (immediate, no lazy here) value.
+ * We then chain to obtain g that (will) hold false if (when it will be
+ * run) the global environment has a different number of constants, true
+ * if nothing changed.
+ * Before forcing g, we add to the global environment one more constant.
+ * When finally we force g.  Its value is going to be *true*.
+ * This because Future.from_here stores in the computation not only the initial
+ * value but the entire system state.  When g is forced the state is restored,
+ * hence Global.env() returns the environment that was actual when f was
+ * created.
+ * Last, forcing g is run protecting the system state, hence when g finishes,
+ * the actual system state is restored.
+ *
+ * If you compare this with lazy_t, you see that the value returned is *false*,
+ * that is counter intuitive and error prone.
+ *
+ * Still not all computations are impure and access/alter the system state.
+ * This class can be optimized by using ~pure:true, but there is no way to
+ * statically check if this flag is misused, hence use it with care.
+ *
+ * Other differences with lazy_t is that a future computation that produces
+ * and exception can be substituted for another computation of the same type.
+ * Moreover a future computation can be delegated to another execution entity
+ * that will be allowed to set the result.  Finally future computations can
+ * always be marshalled: if they were joined before marshalling, they will
+ * hold the computed value (assuming it is itself marshallable), otherwise
+ * they will become invalid and accessing them raises a private exception.
+ *)
+
+(* Each computation has a unique id that is inherited by each offspring
+ * computation (chain, split, map...).  Joined computations lose it.  *)
+module UUID : sig
+  type t
+  val invalid : t
+
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+end
+
+module UUIDMap : Map.S with type key = UUID.t
+module UUIDSet : Set.S with type elt = UUID.t
+
+exception NotReady
+
+type 'a computation
+type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ]
+type fix_exn = Exninfo.iexn -> Exninfo.iexn
+
+(* Build a computation, no snapshot of the global state is taken.  If you need
+   to grab a copy of the state start with from_here () and then chain.
+   fix_exn is used to enrich any exception raised
+   by forcing the computations or any computation that is chained after
+   it. It is used by STM to attach errors to their corresponding states,
+   and to communicate to the code catching the exception a valid state id. *)
+val create : fix_exn -> (unit -> 'a) -> 'a computation
+
+(* Usually from_val is used to create "fake" futures, to use the same API
+   as if a real asynchronous computations was there.  In this case fixing
+   the exception is not needed, but *if* the future is chained, the fix_exn
+   argument should really be given *)
+val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* Like from_val, but also takes a snapshot of the global state.  Morally
+   the value is not just the 'a but also the global system state *)
+val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation
+
+(* To get the fix_exn of a computation and build a Tacexpr.declaration_hook.
+ * When a future enters the environment a corresponding hook is run to perform
+ * some work.  If this fails, then its failure has to be annotated with the
+ * same state id that corresponds to the future computation end.  I.e. Qed
+ * is split into two parts, the lazy one (the future) and the eagher one
+ * (the hook), both performing some computations for the same state id. *)
+val fix_exn_of : 'a computation -> fix_exn
+
+(* Run remotely, returns the function to assign.
+   If not blocking (the default) it raises NotReady if forced before the
+   delage assigns it. *)
+type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation]
+val create_delegate :
+  ?blocking:bool -> fix_exn -> 'a computation * ('a assignement -> unit)
+
+(* Given a computation that is_exn, replace it by another one *)
+val replace : 'a computation -> 'a computation -> unit
+
+(* Inspect a computation *)
+val is_over : 'a computation -> bool
+val is_val : 'a computation -> bool
+val is_exn : 'a computation -> bool
+val peek_val : 'a computation -> 'a option
+val uuid : 'a computation -> UUID.t
+
+(* [chain greedy pure c f] chains computation [c] with [f].
+ * The [greedy] and [pure] parameters are tricky:
+ * [pure]:
+ *   When pure is true, the returned computation will not keep a copy
+ *   of the global state.
+ *   [let c' = chain ~pure:true c f in let c'' = chain ~pure:false c' g in]
+ *   is invalid.  It works if one forces [c''] since the whole computation
+ *   will be executed in one go.  It will not work, and raise an anomaly, if
+ *   one forces c' and then c''.
+ *   [join c; chain ~pure:false c g] is invalid and fails at runtime.
+ *   [force c; chain ~pure:false c g] is correct.
+ * [greedy]:
+ *   The [greedy] parameter forces immediately the new computation if
+ *   the old one is_over (Exn or Val). Defaults to true. *)
+val chain : ?greedy:bool -> pure:bool ->
+  'a computation -> ('a -> 'b) -> 'b computation
+
+(* Forcing a computation *)
+val force : 'a computation -> 'a
+val compute : 'a computation -> 'a value
+
+(* Final call, no more *inpure* chain allowed since the state is lost.
+ * Also the fix_exn function is lost, hence error reporting can be incomplete
+ * in a computation obtained by chaining on a joined future. *)
+val join : 'a computation -> 'a
+
+(* Call this before stocking the future.  If it is_val then it is joined *)
+val sink : 'a computation -> unit
+
+(*** Utility functions ************************************************* ***)
+val split2 : ?greedy:bool ->
+  ('a * 'b) computation -> 'a computation * 'b computation
+val map2 : ?greedy:bool ->
+  ('a computation -> 'b -> 'c) ->
+     'a list computation -> 'b list -> 'c list
+
+(* Once set_freeze is called we can purify a computation *)
+val purify : ('a -> 'b) -> 'a -> 'b
+(* And also let a function alter the state but backtrack if it raises exn *)
+val transactify : ('a -> 'b) -> 'a -> 'b
+
+(** Debug: print a computation given an inner printing function. *)
+val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds
+
+(* These functions are needed to get rid of side effects.
+   Thy are set for the outermos layer of the system, since they have to
+   deal with the whole system state. *)
+val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit
diff --git a/lib/genarg.ml b/lib/genarg.ml
new file mode 100644
index 00000000..42458ecb
--- /dev/null
+++ b/lib/genarg.ml
@@ -0,0 +1,235 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+
+type argument_type =
+  (* Basic types *)
+  | IntOrVarArgType
+  | IdentArgType
+  | VarArgType
+  (* Specific types *)
+  | GenArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | OpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | ListArgType of argument_type
+  | OptArgType of argument_type
+  | PairArgType of argument_type * argument_type
+  | ExtraArgType of string
+
+let rec argument_type_eq arg1 arg2 = match arg1, arg2 with
+| IntOrVarArgType, IntOrVarArgType -> true
+| IdentArgType, IdentArgType -> true
+| VarArgType, VarArgType -> true
+| GenArgType, GenArgType -> true
+| ConstrArgType, ConstrArgType -> true
+| ConstrMayEvalArgType, ConstrMayEvalArgType -> true
+| QuantHypArgType, QuantHypArgType -> true
+| OpenConstrArgType, OpenConstrArgType -> true
+| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true
+| BindingsArgType, BindingsArgType -> true
+| RedExprArgType, RedExprArgType -> true
+| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2
+| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2
+| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) ->
+  argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r
+| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2
+| _ -> false
+
+let rec pr_argument_type = function
+| IntOrVarArgType -> str "int_or_var"
+| IdentArgType -> str "ident"
+| VarArgType -> str "var"
+| GenArgType -> str "genarg"
+| ConstrArgType -> str "constr"
+| ConstrMayEvalArgType -> str "constr_may_eval"
+| QuantHypArgType -> str "qhyp"
+| OpenConstrArgType -> str "open_constr"
+| ConstrWithBindingsArgType -> str "constr_with_bindings"
+| BindingsArgType -> str "bindings"
+| RedExprArgType -> str "redexp"
+| ListArgType t -> pr_argument_type t ++ spc () ++ str "list"
+| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt"
+| PairArgType (t1, t2) ->
+    str "("++ pr_argument_type t1 ++ spc () ++
+    str "*" ++ spc () ++ pr_argument_type t2 ++ str ")"
+| ExtraArgType s -> str s
+
+type ('raw, 'glob, 'top) genarg_type = argument_type
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision *)
+
+(* Dynamics but tagged by a type expression *)
+
+type rlevel
+type glevel
+type tlevel
+
+type 'a generic_argument = argument_type * Obj.t
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+let rawwit t = t
+let glbwit t = t
+let topwit t = t
+
+let wit_list t = ListArgType t
+
+let wit_opt t = OptArgType t
+
+let wit_pair t1 t2 = PairArgType (t1,t2)
+
+let in_gen t o = (t,Obj.repr o)
+let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen"
+let genarg_tag (s,_) = s
+
+let has_type (t, v) u = argument_type_eq t u
+
+let unquote x = x
+
+type ('a,'b) abstract_argument_type = argument_type
+type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
+type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type
+type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type
+
+type ('a, 'b, 'c, 'l) cast = Obj.t
+
+let raw = Obj.obj
+let glb = Obj.obj
+let top = Obj.obj
+
+type ('r, 'l) unpacker =
+  { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj)
+
+(** Type transformers *)
+
+type ('r, 'l) list_unpacker =
+  { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+let list_unpack pack (t, obj) = match t with
+| ListArgType t -> pack.list_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) opt_unpacker =
+  { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+let opt_unpack pack (t, obj) = match t with
+| OptArgType t -> pack.opt_unpacker t (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+type ('r, 'l) pair_unpacker =
+  { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+    ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+    (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+let pair_unpack pack (t, obj) = match t with
+| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj)
+| _ -> failwith "out_gen"
+
+(** Creating args *)
+
+let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty
+
+let create_arg opt name =
+  if String.Map.mem name !arg0_map then
+    Errors.anomaly (str "generic argument already declared: " ++ str name)
+  else
+    let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in
+    ExtraArgType name
+
+let make0 = create_arg
+
+let default_empty_value t =
+  let rec aux = function
+  | ListArgType _ -> Some (Obj.repr [])
+  | OptArgType _ -> Some (Obj.repr None)
+  | PairArgType(t1, t2) ->
+      (match aux t1, aux t2 with
+      | Some v1, Some v2 -> Some (Obj.repr (v1, v2))
+      | _ -> None)
+  | ExtraArgType s ->
+    String.Map.find s !arg0_map
+  | _ -> None in
+  match aux t with
+  | Some v -> Some (Obj.obj v)
+  | None -> None
+
+(** Registering genarg-manipulating functions *)
+
+module type GenObj =
+sig
+  type ('raw, 'glb, 'top) obj
+  val name : string
+  val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+end
+
+module Register (M : GenObj) =
+struct
+  let arg0_map =
+    ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t)
+
+  let register0 arg f = match arg with
+  | ExtraArgType s ->
+    if String.Map.mem s !arg0_map then
+      let msg = str M.name ++ str " function already registered: " ++ str s in
+      Errors.anomaly msg
+    else
+      arg0_map := String.Map.add s (Obj.magic f) !arg0_map
+  | _ -> assert false
+
+  let get_obj0 name =
+    try String.Map.find name !arg0_map
+    with Not_found ->
+      match M.default (ExtraArgType name) with
+      | None ->
+        Errors.anomaly (str M.name ++ str " function not found: " ++ str name)
+      | Some obj -> obj
+
+  (** For now, the following function is quite dummy and should only be applied
+      to an extra argument type, otherwise, it will badly fail. *)
+  let obj t = match t with
+  | ExtraArgType s -> Obj.magic (get_obj0 s)
+  | _ -> assert false
+
+end
+
+(** Hackish part *)
+
+let arg0_names = ref (String.Map.empty : string String.Map.t)
+(** We use this table to associate a name to a given witness, to use it with
+    the extension mechanism. This is REALLY ad-hoc, but I do not know how to
+    do so nicely either. *)
+
+let register_name0 t name = match t with
+| ExtraArgType s ->
+  let () = assert (not (String.Map.mem s !arg0_names)) in
+  arg0_names := String.Map.add s name !arg0_names
+| _ -> failwith "register_name0"
+
+let get_name0 name =
+  String.Map.find name !arg0_names
+
+module Unsafe =
+struct
+
+let inj tpe x = (tpe, x)
+let prj (_, x) = x
+
+end
diff --git a/lib/genarg.mli b/lib/genarg.mli
new file mode 100644
index 00000000..a269f927
--- /dev/null
+++ b/lib/genarg.mli
@@ -0,0 +1,278 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** The route of a generic argument, from parsing to evaluation.
+In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc.
+
+{% \begin{%}verbatim{% }%}
+             parsing          in_raw                            out_raw
+   char stream ---> raw_object ---> raw_object generic_argument -------+
+                          encapsulation                          decaps|
+                                                                       |
+                                                                       V
+                                                                   raw_object
+                                                                       |
+                                                         globalization |
+                                                                       V
+                                                                   glob_object
+                                                                       |
+                                                                encaps |
+                                                               in_glob |
+                                                                       V
+                                                           glob_object generic_argument
+                                                                       |
+          out                          in                     out_glob |
+  object <--- object generic_argument <--- object <--- glob_object <---+
+    |   decaps                       encaps      interp           decaps
+    |
+    V
+effective use
+{% \end{%}verbatim{% }%}
+
+To distinguish between the uninterpreted (raw), globalized and
+interpreted worlds, we annotate the type [generic_argument] by a
+phantom argument which is either [constr_expr], [glob_constr] or
+[constr].
+
+Transformation for each type :
+{% \begin{%}verbatim{% }%}
+tag                            raw open type            cooked closed type
+
+BoolArgType                    bool                      bool
+IntArgType                     int                       int
+IntOrVarArgType                int or_var                int
+StringArgType                  string (parsed w/ "")     string
+PreIdentArgType                string (parsed w/o "")    (vernac only)
+IdentArgType true              identifier                identifier
+IdentArgType false             identifier (pattern_ident) identifier
+IntroPatternArgType            intro_pattern_expr        intro_pattern_expr
+VarArgType                     identifier located        identifier
+RefArgType                     reference                 global_reference
+QuantHypArgType                quantified_hypothesis     quantified_hypothesis
+ConstrArgType                  constr_expr               constr
+ConstrMayEvalArgType           constr_expr may_eval      constr
+OpenConstrArgType              open_constr_expr          open_constr
+ConstrWithBindingsArgType      constr_expr with_bindings constr with_bindings
+BindingsArgType                constr_expr bindings      constr bindings
+List0ArgType of argument_type
+List1ArgType of argument_type
+OptArgType of argument_type
+ExtraArgType of string         '_a                      '_b
+{% \end{%}verbatim{% }%}
+*)
+
+(** {5 Generic types} *)
+
+type ('raw, 'glob, 'top) genarg_type
+(** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized
+    one, and ['top] the internalized one. *)
+
+type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type
+(** Alias for concision when the three types agree. *)
+
+val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Create a new generic type of argument: force to associate
+    unique ML types at each of the three levels. *)
+
+val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type
+(** Alias for [make0]. *)
+
+(** {5 Specialized types} *)
+
+(** All of [rlevel], [glevel] and [tlevel] must be non convertible
+   to ensure the injectivity of the type inference from type
+   ['co generic_argument] to [('a,'co) abstract_argument_type];
+   this guarantees that, for 'co fixed, the type of
+   out_gen is monomorphic over 'a, hence type-safe
+*)
+
+type rlevel
+type glevel
+type tlevel
+
+type ('a, 'co) abstract_argument_type
+(** Type at level ['co] represented by an OCaml value of type ['a]. *)
+
+type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type
+(** Specialized type at raw level. *)
+
+type 'a glob_abstract_argument_type = ('a, glevel) abstract_argument_type
+(** Specialized type at globalized level. *)
+
+type 'a typed_abstract_argument_type = ('a, tlevel) abstract_argument_type
+(** Specialized type at internalized level. *)
+
+(** {6 Projections} *)
+
+val rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type
+(** Projection on the raw type constructor. *)
+
+val glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type
+(** Projection on the globalized type constructor. *)
+
+val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type
+(** Projection on the internalized type constructor. *)
+
+(** {5 Generic arguments} *)
+
+type 'a generic_argument
+(** A inhabitant of ['level generic_argument] is a inhabitant of some type at
+    level ['level], together with the representation of this type. *)
+
+type raw_generic_argument = rlevel generic_argument
+type glob_generic_argument = glevel generic_argument
+type typed_generic_argument = tlevel generic_argument
+
+(** {6 Constructors} *)
+
+val in_gen : ('a, 'co) abstract_argument_type -> 'a -> 'co generic_argument
+(** [in_gen t x] embeds an argument of type [t] into a generic argument. *)
+
+val out_gen : ('a, 'co) abstract_argument_type -> 'co generic_argument -> 'a
+(** [out_gen t x] recovers an argument of type [t] from a generic argument. It
+    fails if [x] has not the right dynamic type. *)
+
+val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool
+(** [has_type v t] tells whether [v] has type [t]. If true, it ensures that
+    [out_gen t v] will not raise a dynamic type exception. *)
+
+(** {6 Destructors} *)
+
+type ('a, 'b, 'c, 'l) cast
+
+val raw : ('a, 'b, 'c, rlevel) cast -> 'a
+val glb : ('a, 'b, 'c, glevel) cast -> 'b
+val top : ('a, 'b, 'c, tlevel) cast -> 'c
+
+type ('r, 'l) unpacker =
+  { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r }
+
+val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r
+(** Existential-type destructors. *)
+
+(** {6 Manipulation of generic arguments}
+
+Those functions fail if they are applied to an argument which has not the right
+dynamic type. *)
+
+type ('r, 'l) list_unpacker =
+  { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a list, 'b list, 'c list, 'l) cast -> 'r }
+
+val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) opt_unpacker =
+  { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type ->
+    ('a option, 'b option, 'c option, 'l) cast -> 'r }
+
+val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r
+
+type ('r, 'l) pair_unpacker =
+  { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2.
+    ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+    (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r }
+
+val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r
+
+(** {6 Type reification} *)
+
+type argument_type =
+  (** Basic types *)
+  | IntOrVarArgType
+  | IdentArgType
+  | VarArgType
+  (** Specific types *)
+  | GenArgType
+  | ConstrArgType
+  | ConstrMayEvalArgType
+  | QuantHypArgType
+  | OpenConstrArgType
+  | ConstrWithBindingsArgType
+  | BindingsArgType
+  | RedExprArgType
+  | ListArgType of argument_type
+  | OptArgType of argument_type
+  | PairArgType of argument_type * argument_type
+  | ExtraArgType of string
+
+val argument_type_eq : argument_type -> argument_type -> bool
+
+val pr_argument_type : argument_type -> Pp.std_ppcmds
+(** Print a human-readable representation for a given type. *)
+
+val genarg_tag : 'a generic_argument -> argument_type
+
+val unquote : ('a, 'co) abstract_argument_type -> argument_type
+
+(** {6 Registering genarg-manipulating functions}
+
+  This is boilerplate code used here and there in the code of Coq. *)
+
+module type GenObj =
+sig
+  type ('raw, 'glb, 'top) obj
+  (** An object manipulating generic arguments. *)
+
+  val name : string
+  (** A name for such kind of manipulation, e.g. [interp]. *)
+
+  val default : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) obj option
+  (** A generic object when there is no registered object for this type. *)
+end
+
+module Register (M : GenObj) :
+sig
+  val register0 : ('raw, 'glb, 'top) genarg_type ->
+    ('raw, 'glb, 'top) M.obj -> unit
+  (** Register a ground type manipulation function. *)
+
+  val obj : ('raw, 'glb, 'top) genarg_type -> ('raw, 'glb, 'top) M.obj
+  (** Recover a manipulation function at a given type. *)
+
+end
+
+(** {5 Basic generic type constructors} *)
+
+(** {6 Parameterized types} *)
+
+val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type
+val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type
+val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type ->
+  ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type
+
+(** {5 Magic used by the parser} *)
+
+val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option
+
+val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit
+(** Used by the extension to give a name to types. The string should be the
+    absolute path of the argument witness, e.g.
+    [register_name0 wit_toto "MyArg.wit_toto"]. *)
+
+val get_name0 : string -> string
+(** Return the absolute path of a given witness. *)
+
+(** {5 Unsafe loophole} *)
+
+module Unsafe :
+sig
+
+(** Unsafe magic functions. Not for kids. This is provided here as a loophole to
+    escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *)
+
+val inj : argument_type -> Obj.t -> 'lev generic_argument
+(** Injects an object as generic argument. !!!BEWARE!!! only do this as
+    [inj tpe x] where:
+
+    1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type];
+    2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *)
+
+val prj : 'lev generic_argument -> Obj.t
+(** Recover the contents of a generic argument. *)
+
+end
diff --git a/lib/gmap.ml b/lib/gmap.ml
deleted file mode 100644
index e1c68da0..00000000
--- a/lib/gmap.ml
+++ /dev/null
@@ -1,140 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Maps using the generic comparison function of ocaml. Code borrowed from
-   the ocaml standard library (Copyright 1996, INRIA). *)
-
-    type ('a,'b) t =
-        Empty
-      | Node of ('a,'b) t * 'a * 'b * ('a,'b) t * int
-
-    let empty = Empty
-
-    let is_empty = function Empty -> true | _ -> false
-
-    let height = function
-        Empty -> 0
-      | Node(_,_,_,_,h) -> h
-
-    let create l x d r =
-      let hl = height l and hr = height r in
-      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let bal l x d r =
-      let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
-      if hl > hr + 2 then begin
-        match l with
-          Empty -> invalid_arg "Map.bal"
-        | Node(ll, lv, ld, lr, _) ->
-            if height ll >= height lr then
-              create ll lv ld (create lr x d r)
-            else begin
-              match lr with
-                Empty -> invalid_arg "Map.bal"
-              | Node(lrl, lrv, lrd, lrr, _)->
-                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
-            end
-      end else if hr > hl + 2 then begin
-        match r with
-          Empty -> invalid_arg "Map.bal"
-        | Node(rl, rv, rd, rr, _) ->
-            if height rr >= height rl then
-              create (create l x d rl) rv rd rr
-            else begin
-              match rl with
-                Empty -> invalid_arg "Map.bal"
-              | Node(rll, rlv, rld, rlr, _) ->
-                  create (create l x d rll) rlv rld (create rlr rv rd rr)
-            end
-      end else
-        Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
-    let rec add x data = function
-        Empty ->
-          Node(Empty, x, data, Empty, 1)
-      | Node(l, v, d, r, h) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then
-            Node(l, x, data, r, h)
-          else if c < 0 then
-            bal (add x data l) v d r
-          else
-            bal l v d (add x data r)
-
-    let rec find x = function
-        Empty ->
-          raise Not_found
-      | Node(l, v, d, r, _) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then d
-          else find x (if c < 0 then l else r)
-
-    let rec mem x = function
-        Empty ->
-          false
-      | Node(l, v, d, r, _) ->
-          let c = Pervasives.compare x v in
-          c = 0 || mem x (if c < 0 then l else r)
-
-    let rec min_binding = function
-        Empty -> raise Not_found
-      | Node(Empty, x, d, r, _) -> (x, d)
-      | Node(l, x, d, r, _) -> min_binding l
-
-    let rec remove_min_binding = function
-        Empty -> invalid_arg "Map.remove_min_elt"
-      | Node(Empty, x, d, r, _) -> r
-      | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
-    let merge t1 t2 =
-      match (t1, t2) with
-        (Empty, t) -> t
-      | (t, Empty) -> t
-      | (_, _) ->
-          let (x, d) = min_binding t2 in
-          bal t1 x d (remove_min_binding t2)
-
-    let rec remove x = function
-        Empty ->
-          Empty
-      | Node(l, v, d, r, h) ->
-          let c = Pervasives.compare x v in
-          if c = 0 then
-            merge l r
-          else if c < 0 then
-            bal (remove x l) v d r
-          else
-            bal l v d (remove x r)
-
-    let rec iter f = function
-        Empty -> ()
-      | Node(l, v, d, r, _) ->
-          iter f l; f v d; iter f r
-
-    let rec map f = function
-        Empty               -> Empty
-      | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
-
-    (* Maintien de fold_right par compatibilité (changé en fold_left dans
-       ocaml-3.09.0) *)
-
-    let rec fold f m accu =
-      match m with
-        Empty -> accu
-      | Node(l, v, d, r, _) ->
-          fold f l (f v d (fold f r accu))
-
-(* Added with respect to ocaml standard library. *)
-
-    let dom m = fold (fun x _ acc -> x::acc) m []
-
-    let rng m = fold (fun _ y acc -> y::acc) m []
-
-    let to_list m = fold (fun x y acc -> (x,y)::acc) m []
-
diff --git a/lib/gmap.mli b/lib/gmap.mli
deleted file mode 100644
index c2fb7d26..00000000
--- a/lib/gmap.mli
+++ /dev/null
@@ -1,28 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Maps using the generic comparison function of ocaml. Same interface as
-   the module [Map] from the ocaml standard library. *)
-
-type ('a,'b) t
-
-val empty : ('a,'b) t
-val is_empty : ('a,'b) t -> bool
-val add : 'a -> 'b -> ('a,'b) t -> ('a,'b) t
-val find : 'a -> ('a,'b) t -> 'b
-val remove : 'a -> ('a,'b) t -> ('a,'b) t
-val mem :  'a -> ('a,'b) t -> bool
-val iter : ('a -> 'b -> unit) -> ('a,'b) t -> unit
-val map : ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
-val fold : ('a -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'c -> 'c
-
-(** Additions with respect to ocaml standard library. *)
-
-val dom : ('a,'b) t -> 'a list
-val rng : ('a,'b) t -> 'b list
-val to_list : ('a,'b) t -> ('a * 'b) list
diff --git a/lib/hMap.ml b/lib/hMap.ml
new file mode 100644
index 00000000..f902eded
--- /dev/null
+++ b/lib/hMap.ml
@@ -0,0 +1,332 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type HashedType =
+sig
+  type t
+  val compare : t -> t -> int
+  val hash : t -> int
+end
+
+module SetMake(M : HashedType) =
+struct
+  (** Hash Sets use hashes to prevent doing too many comparison tests. They
+      associate to each hash the set of keys having that hash.
+
+      Invariants:
+
+      1. There is no empty set in the intmap.
+      2. All values in the same set have the same hash, which is the int to
+         which it is associated in the intmap.
+  *)
+
+  module Set = Set.Make(M)
+
+  type elt = M.t
+
+  type t = Set.t Int.Map.t
+
+  let empty = Int.Map.empty
+
+  let is_empty = Int.Map.is_empty
+
+  let mem x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      Set.mem x m
+    with Not_found -> false
+
+  let add x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      let m = Set.add x m in
+      Int.Map.update h m s
+    with Not_found ->
+      let m = Set.singleton x in
+      Int.Map.add h m s
+
+  let singleton x =
+    let h = M.hash x in
+    let m = Set.singleton x in
+    Int.Map.singleton h m
+
+  let remove x s =
+    let h = M.hash x in
+    try
+      let m = Int.Map.find h s in
+      let m = Set.remove x m in
+      if Set.is_empty m then
+        Int.Map.remove h s
+      else
+        Int.Map.update h m s
+    with Not_found -> s
+
+  let union s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | (Some _ as m), None | None, (Some _ as m) -> m
+    | Some m1, Some m2 -> Some (Set.union m1 m2)
+    in
+    Int.Map.merge fu s1 s2
+
+  let inter s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | Some _, None | None, Some _ -> None
+    | Some m1, Some m2 ->
+      let m = Set.inter m1 m2 in
+      if Set.is_empty m then None else Some m
+    in
+    Int.Map.merge fu s1 s2
+
+  let diff s1 s2 =
+    let fu _ m1 m2 = match m1, m2 with
+    | None, None -> None
+    | (Some _ as m), None -> m
+    | None, Some _ -> None
+    | Some m1, Some m2 ->
+      let m = Set.diff m1 m2 in
+      if Set.is_empty m then None else Some m
+    in
+    Int.Map.merge fu s1 s2
+
+  let compare s1 s2 = Int.Map.compare Set.compare s1 s2
+
+  let equal s1 s2 = Int.Map.equal Set.equal s1 s2
+
+  let subset s1 s2 =
+    let check h m1 =
+      let m2 = try Int.Map.find h s2 with Not_found -> Set.empty in
+      Set.subset m1 m2
+    in
+    Int.Map.for_all check s1
+
+  let iter f s =
+    let fi _ m = Set.iter f m in
+    Int.Map.iter fi s
+
+  let fold f s accu =
+    let ff _ m accu = Set.fold f m accu in
+    Int.Map.fold ff s accu
+
+  let for_all f s =
+    let ff _ m = Set.for_all f m in
+    Int.Map.for_all ff s
+
+  let exists f s =
+    let fe _ m = Set.exists f m in
+    Int.Map.exists fe s
+
+  let filter f s =
+    let ff m = Set.filter f m in
+    let s = Int.Map.map ff s in
+    Int.Map.filter (fun _ m -> not (Set.is_empty m)) s
+
+  let partition f s =
+    let fold h m (sl, sr) =
+      let (ml, mr) = Set.partition f m in
+      let sl = if Set.is_empty ml then sl else Int.Map.add h ml sl in
+      let sr = if Set.is_empty mr then sr else Int.Map.add h mr sr in
+      (sl, sr)
+    in
+    Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+  let cardinal s =
+    let fold _ m accu = accu + Set.cardinal m in
+    Int.Map.fold fold s 0
+
+  let elements s =
+    let fold _ m accu = Set.fold (fun x accu -> x :: accu) m accu in
+    Int.Map.fold fold s []
+
+  let min_elt _ = assert false (** Cannot be implemented efficiently *)
+
+  let max_elt _ = assert false (** Cannot be implemented efficiently *)
+
+  let choose s =
+    let (_, m) = Int.Map.choose s in
+    Set.choose m
+
+  let split s x = assert false (** Cannot be implemented efficiently *)
+
+end
+
+module Make(M : HashedType) =
+struct
+  (** This module is essentially the same as SetMake, except that we have maps
+      instead of sets in the intmap. Invariants are the same. *)
+  module Set = SetMake(M)
+  module Map = CMap.Make(M)
+
+  type key = M.t
+
+  type 'a t = 'a Map.t Int.Map.t
+
+  let empty = Int.Map.empty
+
+  let is_empty = Int.Map.is_empty
+
+  let mem k s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      Map.mem k m
+    with Not_found -> false
+
+  let add k x s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      let m = Map.add k x m in
+      Int.Map.update h m s
+    with Not_found ->
+      let m = Map.singleton k x in
+      Int.Map.add h m s
+
+  let singleton k x =
+    let h = M.hash k in
+    Int.Map.singleton h (Map.singleton k x)
+
+  let remove k s =
+    let h = M.hash k in
+    try
+      let m = Int.Map.find h s in
+      let m = Map.remove k m in
+      if Map.is_empty m then
+        Int.Map.remove h s
+      else
+        Int.Map.update h m s
+    with Not_found -> s
+
+  let merge f s1 s2 =
+    let fm h m1 m2 = match m1, m2 with
+    | None, None -> None
+    | Some m, None ->
+      let m = Map.merge f m Map.empty in
+      if Map.is_empty m then None
+      else Some m
+    | None, Some m ->
+      let m = Map.merge f Map.empty m in
+      if Map.is_empty m then None
+      else Some m
+    | Some m1, Some m2 ->
+      let m = Map.merge f m1 m2 in
+      if Map.is_empty m then None
+      else Some m
+    in
+    Int.Map.merge fm s1 s2
+
+  let compare f s1 s2 =
+    let fc m1 m2 = Map.compare f m1 m2 in
+    Int.Map.compare fc s1 s2
+
+  let equal f s1 s2 =
+    let fe m1 m2 = Map.equal f m1 m2 in
+    Int.Map.equal fe s1 s2
+
+  let iter f s =
+    let fi _ m = Map.iter f m in
+    Int.Map.iter fi s
+
+  let fold f s accu =
+    let ff _ m accu = Map.fold f m accu in
+    Int.Map.fold ff s accu
+
+  let for_all f s =
+    let ff _ m = Map.for_all f m in
+    Int.Map.for_all ff s
+
+  let exists f s =
+    let fe _ m = Map.exists f m in
+    Int.Map.exists fe s
+
+  let filter f s =
+    let ff m = Map.filter f m in
+    let s = Int.Map.map ff s in
+    Int.Map.filter (fun _ m -> not (Map.is_empty m)) s
+
+  let partition f s =
+    let fold h m (sl, sr) =
+      let (ml, mr) = Map.partition f m in
+      let sl = if Map.is_empty ml then sl else Int.Map.add h ml sl in
+      let sr = if Map.is_empty mr then sr else Int.Map.add h mr sr in
+      (sl, sr)
+    in
+    Int.Map.fold fold s (Int.Map.empty, Int.Map.empty)
+
+  let cardinal s =
+    let fold _ m accu = accu + Map.cardinal m in
+    Int.Map.fold fold s 0
+
+  let bindings s =
+    let fold _ m accu = Map.fold (fun k x accu -> (k, x) :: accu) m accu in
+    Int.Map.fold fold s []
+
+  let min_binding _ = assert false (** Cannot be implemented efficiently *)
+
+  let max_binding _ = assert false (** Cannot be implemented efficiently *)
+
+  let fold_left _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+  let fold_right _ _ _ = assert false (** Cannot be implemented efficiently *)
+
+  let choose s =
+    let (_, m) = Int.Map.choose s in
+    Map.choose m
+
+  let find k s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    Map.find k m
+
+  let split k s = assert false (** Cannot be implemented efficiently *)
+
+  let map f s =
+    let fs m = Map.map f m in
+    Int.Map.map fs s
+
+  let mapi f s =
+    let fs m = Map.mapi f m in
+    Int.Map.map fs s
+
+  let modify k f s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    let m = Map.modify k f m in
+    Int.Map.update h m s
+
+  let bind f s =
+    let fb m = Map.bind f m in
+    Int.Map.map fb s
+
+  let domain s = Int.Map.map Map.domain s
+
+  let update k x s =
+    let h = M.hash k in
+    let m = Int.Map.find h s in
+    let m = Map.update k x m in
+    Int.Map.update h m s
+
+  let smartmap f s =
+    let fs m = Map.smartmap f m in
+    Int.Map.smartmap fs s
+
+  let smartmapi f s =
+    let fs m = Map.smartmapi f m in
+    Int.Map.smartmap fs s
+
+  module Unsafe =
+  struct
+    let map f s =
+      let fs m = Map.Unsafe.map f m in
+      Int.Map.map fs s
+  end
+
+end
diff --git a/lib/hMap.mli b/lib/hMap.mli
new file mode 100644
index 00000000..cdf933b2
--- /dev/null
+++ b/lib/hMap.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type HashedType =
+sig
+  type t
+  val compare : t -> t -> int
+  (** Total ordering *)
+  val hash : t -> int
+  (** Hashing function compatible with [compare], i.e. [compare x y = 0] implies
+      [hash x = hash y]. *)
+end
+
+(** Hash maps are maps that take advantage of having a hash on keys. This is
+    essentially a hash table, except that it uses purely functional maps instead
+    of arrays.
+
+    CAVEAT: order-related functions like [fold] or [iter] do not respect the
+    provided order anymore! It's your duty to do something sensible to prevent
+    this if you need it. In particular, [min_binding] and [max_binding] are now
+    made meaningless.
+*)
+module Make(M : HashedType) : CMap.ExtS with type key = M.t
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index d310713e..752e2634 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.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        *)
@@ -13,42 +13,39 @@
 (* [t] is the type of object to hash-cons
  * [u] is the type of hash-cons functions for the sub-structures
  *   of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...).
- * [hash_sub u x] is a function that hash-cons the sub-structures of x using
+ * [hashcons u x] is a function that hash-cons the sub-structures of x using
  *   the hash-consing functions u provides.
  * [equal] is a comparison function. It is allowed to use physical equality
- *   on the sub-terms hash-consed by the hash_sub function.
+ *   on the sub-terms hash-consed by the hashcons function.
  * [hash] is the hash function given to the Hashtbl.Make function
  *
  * Note that this module type coerces to the argument of Hashtbl.Make.
  *)
 
-module type Comp =
+module type HashconsedType =
   sig
     type t
     type u
-    val hash_sub :  u -> t -> t
+    val hashcons :  u -> t -> t
     val equal : t -> t -> bool
     val hash : t -> int
   end
 
-(* The output is a function f such that
- * [f ()] has the side-effect of creating (internally) a hash-table of the
- *   hash-consed objects. The result is a function taking the sub-hashcons
- *   functions and an object, and hashcons it. It does not really make sense
- *   to call f() with different sub-hcons functions. That's why we use the
- *   wrappers simple_hcons, recursive_hcons, ... The latter just take as
- *   argument the sub-hcons functions (the tables are created at that moment),
- *   and returns the hcons function for t.
- *)
+(** The output is a function [generate] such that [generate args] creates a
+    hash-table of the hash-consed objects, together with [hcons], a function
+    taking a table and an object, and hashcons it. For simplicity of use, we use
+    the wrapper functions defined below. *)
 
 module type S =
   sig
     type t
     type u
-    val f : unit -> (u -> t -> t)
+    type table
+    val generate : u -> table
+    val hcons : table -> t -> t
   end
 
-module Make(X:Comp) =
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) =
   struct
     type t = X.t
     type u = X.u
@@ -58,34 +55,29 @@ module Make(X:Comp) =
      * w.r.t (=), although the equality on keys is X.equal. This is
      * granted since we hcons the subterms before looking up in the table.
      *)
-    module Htbl = Hashtbl.Make(
-      struct type t=X.t
-             type u=X.u
-             let hash=X.hash
-             let equal x1 x2 = (*incr comparaison;*) X.equal x1 x2
-      end)
-
-    (* The table is created when () is applied.
-     * Hashconsing is then very simple:
-     *  1- hashcons the subterms using hash_sub and u
-     *  2- look up in the table, if we do not get a hit, we add it
-     *)
-    let f () =
+    module Htbl = Hashset.Make(X)
+
+    type table = (Htbl.t * u)
+
+    let generate u =
       let tab = Htbl.create 97 in
-        (fun u x ->
-           let y = X.hash_sub u x in
-            (* incr acces;*)
-             try let r = Htbl.find tab y in(* incr succes;*) r
-             with Not_found -> Htbl.add tab y y; y)
+      (tab, u)
+
+    let hcons (tab, u) x =
+      let y = X.hashcons u x in
+      Htbl.repr (X.hash y) y tab
+
   end
 
 (* A few usefull wrappers:
- * takes as argument the function f above and build a function of type
+ * takes as argument the function [generate] above and build a function of type
  * u -> t -> t that creates a fresh table each time it is applied to the
  * sub-hcons functions. *)
 
 (* For non-recursive types it is quite easy. *)
-let simple_hcons h u = h () u
+let simple_hcons h f u =
+  let table = h u in
+  fun x -> f table x
 
 (* For a recursive type T, we write the module of sig Comp with u equals
  * to (T -> T) * u0
@@ -93,28 +85,14 @@ let simple_hcons h u = h () u
  * The second one to hashcons the other sub-structures.
  * We just have to take the fixpoint of h
  *)
-let recursive_hcons h u =
-  let hc = h () in
-  let rec hrec x = hc (hrec,u) x in
+let recursive_hcons h f u =
+  let loop = ref (fun _ -> assert false) in
+  let self x = !loop x in
+  let table = h (self, u) in
+  let hrec x = f table x in
+  let () = loop := hrec in
   hrec
 
-(* If the structure may contain loops, use this one. *)
-let recursive_loop_hcons h u =
-  let hc = h () in
-  let rec hrec visited x =
-    if List.memq x visited then x
-    else hc (hrec (x::visited),u) x
-  in
-  hrec []
-
-(* For 2 mutually recursive types *)
-let recursive2_hcons h1 h2 u1 u2 =
-  let hc1 = h1 () in
-  let hc2 = h2 () in
-  let rec hrec1 x = hc1 (hrec1,hrec2,u1) x
-  and hrec2 x = hc2 (hrec1,hrec2,u2) x
-  in (hrec1,hrec2)
-
 (* A set of global hashcons functions *)
 let hashcons_resets = ref []
 let init() = List.iter (fun f -> f()) !hashcons_resets
@@ -132,15 +110,48 @@ let register_hcons h u =
 (* Basic hashcons modules for string and obj. Integers do not need be
    hashconsed.  *)
 
+module type HashedType = sig type t val hash : t -> int end
+
+(* list *)
+module Hlist (D:HashedType) =
+  Make(
+    struct
+      type t = D.t list
+      type u = (t -> t) * (D.t -> D.t)
+      let hashcons (hrec,hdata) = function
+        | x :: l -> hdata x :: hrec l
+        | l -> l
+      let equal l1 l2 =
+        l1 == l2 ||
+          match l1, l2 with
+          | [], [] -> true
+          | x1::l1, x2::l2 -> x1==x2 && l1==l2
+          | _ -> false
+      let rec hash accu = function
+      | [] -> accu
+      | x :: l ->
+        let accu = Hashset.Combine.combine (D.hash x) accu in
+        hash accu l
+      let hash l = hash 0 l
+    end)
+
 (* string *)
 module Hstring = Make(
   struct
     type t = string
     type u = unit
-    let hash_sub () s =(* incr accesstr;*) s
-    let equal s1 s2 =(* incr comparaisonstr;
-      if*) s1=s2(* then (incr successtr; true) else false*)
-    let hash = Hashtbl.hash
+    let hashcons () s =(* incr accesstr;*) s
+    external equal : string -> string -> bool = "caml_string_equal" "noalloc"
+    (** Copy from CString *)
+    let rec hash len s i accu =
+      if i = len then accu
+      else
+        let c = Char.code (String.unsafe_get s i) in
+        hash len s (succ i) (accu * 19 + c)
+
+    let hash s =
+      let len = String.length s in
+      hash len s 0 0
   end)
 
 (* Obj.t *)
@@ -148,10 +159,10 @@ exception NotEq
 
 (* From CAMLLIB/caml/mlvalues.h *)
 let no_scan_tag = 251
-let tuple_p obj = Obj.is_block obj & (Obj.tag obj < no_scan_tag)
+let tuple_p obj = Obj.is_block obj && (Obj.tag obj < no_scan_tag)
 
 let comp_obj o1 o2 =
-  if tuple_p o1 & tuple_p o2 then
+  if tuple_p o1 && tuple_p o2 then
     let n1 = Obj.size o1 and n2 = Obj.size o2 in
       if n1=n2 then
         try
@@ -176,7 +187,7 @@ module Hobj = Make(
   struct
     type t = Obj.t
     type u = (Obj.t -> Obj.t) * unit
-    let hash_sub (hrec,_) = hash_obj hrec
+    let hashcons (hrec,_) = hash_obj hrec
     let equal = comp_obj
     let hash = Hashtbl.hash
   end)
@@ -186,8 +197,8 @@ module Hobj = Make(
  *)
 (* string : string -> string *)
 (* obj : Obj.t -> Obj.t *)
-let string = register_hcons (simple_hcons Hstring.f) ()
-let obj = register_hcons (recursive_hcons Hobj.f) ()
+let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) ()
+let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) ()
 
 (* The unsafe polymorphic hashconsing function *)
 let magic_hash (c : 'a) =
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index d2aa6462..60a9ee01 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.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,43 +8,81 @@
 
 (** Generic hash-consing. *)
 
-module type Comp =
+(** {6 Hashconsing functorial interface} *)
+
+module type HashconsedType =
   sig
+    (** {6 Generic hashconsing signature}
+
+        Given an equivalence relation [equal], a hashconsing function is a
+        function that associates the same canonical element to two elements
+        related by [equal]. Usually, the element chosen is canonical w.r.t.
+        physical equality [(==)], so as to reduce memory consumption and
+        enhance efficiency of equality tests.
+
+        In order to ensure canonicality, we need a way to remember the element
+        associated to a class of equivalence; this is done using the table type
+        generated by the [Make] functor.
+    *)
+
     type t
+    (** Type of objects to hashcons. *)
     type u
-    val hash_sub :  u -> t -> t
+    (** Type of hashcons functions for the sub-structures contained in [t].
+        Usually a tuple of functions. *)
+    val hashcons :  u -> t -> t
+    (** The actual hashconsing function, using its fist argument to recursively
+        hashcons substructures. It should be compatible with [equal], that is
+        [equal x (hashcons f x) = true]. *)
     val equal : t -> t -> bool
+    (** A comparison function. It is allowed to use physical equality
+        on the sub-terms hashconsed by the [hashcons] function, but it should be
+        insensible to shallow copy of the compared object. *)
     val hash : t -> int
+    (** A hash function passed to the underlying hashtable structure. [hash]
+        should be compatible with [equal], i.e. if [equal x y = true] then
+        [hash x = hash y]. *)
   end
 
 module type S =
   sig
     type t
+    (** Type of objects to hashcons. *)
     type u
-    val f : unit -> (u -> t -> t)
+    (** Type of hashcons functions for the sub-structures contained in [t]. *)
+    type table
+    (** Type of hashconsing tables *)
+    val generate : u -> table
+    (** This create a hashtable of the hashconsed objects. *)
+    val hcons : table -> t -> t
+    (** Perform the hashconsing of the given object within the table. *)
   end
 
-module Make(X:Comp) : (S with type t = X.t and type u = X.u)
+module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u)
+(** Create a new hashconsing, given canonicalization functions. *)
 
-val simple_hcons : (unit -> 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_hcons : (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive_loop_hcons :
-    (unit -> ('t -> 't) * 'u -> 't -> 't) -> ('u -> 't -> 't)
-val recursive2_hcons :
-  (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u1 -> 't1 -> 't1) ->
-    (unit -> ('t1 -> 't1) * ('t2 -> 't2) * 'u2 -> 't2 -> 't2) ->
-      'u1 -> 'u2 -> ('t1 -> 't1) * ('t2 -> 't2)
+(** {6 Wrappers} *)
 
-(** Declaring and reinitializing global hash-consing functions *)
+(** These are intended to be used together with instances of the [Make]
+    functor. *)
 
-val init : unit -> unit
-val register_hcons : ('u -> 't -> 't) -> ('u -> 't -> 't)
+val simple_hcons : ('u -> 'tab) -> ('tab -> 't -> 't) -> 'u -> 't -> 't
+(** [simple_hcons f sub obj] creates a new table each time it is applied to any
+    sub-hash function [sub]. *)
 
-module Hstring : (S with type t = string and type u = unit)
-module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+val recursive_hcons : (('t -> 't) * 'u -> 'tab) -> ('tab -> 't -> 't) -> ('u -> 't -> 't)
+(** As [simple_hcons] but intended to be used with well-founded data structures. *)
+
+(** {6 Hashconsing of usual structures} *)
 
-val string : string -> string
-val obj : Obj.t -> Obj.t
+module type HashedType = sig type t val hash : t -> int end
 
-val magic_hash : 'a -> 'a
+module Hstring : (S with type t = string and type u = unit)
+(** Hashconsing of strings.  *)
 
+module Hlist (D:HashedType) :
+  (S with type t = D.t list and type u = (D.t list -> D.t list)*(D.t->D.t))
+(** Hashconsing of lists.  *)
+
+module Hobj : (S with type t = Obj.t and type u = (Obj.t -> Obj.t) * unit)
+(** Hashconsing of OCaml values. *)
diff --git a/lib/hashset.ml b/lib/hashset.ml
new file mode 100644
index 00000000..6bec81c7
--- /dev/null
+++ b/lib/hashset.ml
@@ -0,0 +1,203 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+    OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+    Here, the responsibility of computing the hash function is now
+    given to the caller, which makes possible the interleaving of the
+    hash key computation and the hash-consing. *)
+
+module type EqType = sig
+  type t
+  val equal : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  type t
+  val create : int -> t
+  val clear : t -> unit
+  val repr : int -> elt -> t -> elt
+end
+
+module Make (E : EqType) =
+  struct
+
+  type elt = E.t
+
+  let emptybucket = Weak.create 0
+
+  type t = {
+    mutable table : elt Weak.t array;
+    mutable hashes : int array array;
+    mutable limit : int;               (* bucket size limit *)
+    mutable oversize : int;            (* number of oversize buckets *)
+    mutable rover : int;               (* for internal bookkeeping *)
+  }
+
+  let get_index t h = (h land max_int) mod (Array.length t.table)
+
+  let limit = 7
+  let over_limit = 2
+
+  let create sz =
+    let sz = if sz < 7 then 7 else sz in
+    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+    {
+      table = Array.make sz emptybucket;
+      hashes = Array.make sz [| |];
+      limit = limit;
+      oversize = 0;
+      rover = 0;
+    }
+
+  let clear t =
+    for i = 0 to Array.length t.table - 1 do
+      t.table.(i) <- emptybucket;
+      t.hashes.(i) <- [| |];
+    done;
+    t.limit <- limit;
+    t.oversize <- 0
+
+  let iter_weak f t =
+    let rec iter_bucket i j b =
+      if i >= Weak.length b then () else
+      match Weak.check b i with
+      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+      | false -> iter_bucket (i+1) j b
+    in
+    for i = 0 to pred (Array.length t.table) do
+      iter_bucket 0 i (Array.unsafe_get t.table i)
+    done
+
+  let rec count_bucket i b accu =
+    if i >= Weak.length b then accu else
+    count_bucket (i+1) b (accu + (if Weak.check b i then 1 else 0))
+
+  let min x y = if x - y < 0 then x else y
+
+  let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length
+  let prev_sz n = ((n - 3) * 2 + 2) / 3
+
+  let test_shrink_bucket t =
+    let bucket = t.table.(t.rover) in
+    let hbucket = t.hashes.(t.rover) in
+    let len = Weak.length bucket in
+    let prev_len = prev_sz len in
+    let live = count_bucket 0 bucket 0 in
+    if live <= prev_len then begin
+      let rec loop i j =
+        if j >= prev_len then begin
+          if Weak.check bucket i then loop (i + 1) j
+          else if Weak.check bucket j then begin
+            Weak.blit bucket j bucket i 1;
+            hbucket.(i) <- hbucket.(j);
+            loop (i + 1) (j - 1);
+          end else loop i (j - 1);
+        end;
+      in
+      loop 0 (Weak.length bucket - 1);
+      if prev_len = 0 then begin
+        t.table.(t.rover) <- emptybucket;
+        t.hashes.(t.rover) <- [| |];
+      end else begin
+        Obj.truncate (Obj.repr bucket) (prev_len + 1);
+        Obj.truncate (Obj.repr hbucket) prev_len;
+      end;
+      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+    end;
+    t.rover <- (t.rover + 1) mod (Array.length t.table)
+
+  let rec resize t =
+    let oldlen = Array.length t.table in
+    let newlen = next_sz oldlen in
+    if newlen > oldlen then begin
+      let newt = create newlen in
+      let add_weak ob oh oi =
+        let setter nb ni _ = Weak.blit ob oi nb ni 1 in
+        let h = oh.(oi) in
+        add_aux newt setter None h (get_index newt h);
+      in
+      iter_weak add_weak t;
+      t.table <- newt.table;
+      t.hashes <- newt.hashes;
+      t.limit <- newt.limit;
+      t.oversize <- newt.oversize;
+      t.rover <- t.rover mod Array.length newt.table;
+    end else begin
+      t.limit <- max_int;             (* maximum size already reached *)
+      t.oversize <- 0;
+    end
+
+  and add_aux t setter d h index =
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = Weak.length bucket in
+    let rec loop i =
+      if i >= sz then begin
+        let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in
+        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
+        let newbucket = Weak.create newsz in
+        let newhashes = Array.make newsz 0 in
+        Weak.blit bucket 0 newbucket 0 sz;
+        Array.blit hashes 0 newhashes 0 sz;
+        setter newbucket sz d;
+        newhashes.(sz) <- h;
+        t.table.(index) <- newbucket;
+        t.hashes.(index) <- newhashes;
+        if sz <= t.limit && newsz > t.limit then begin
+          t.oversize <- t.oversize + 1;
+          for i = 0 to over_limit do test_shrink_bucket t done;
+        end;
+        if t.oversize > Array.length t.table / over_limit then resize t
+      end else if Weak.check bucket i then begin
+        loop (i + 1)
+      end else begin
+        setter bucket i d;
+        hashes.(i) <- h
+      end
+    in
+    loop 0
+
+  let find_or h t d ifnotfound =
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = Weak.length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound index
+      else if h = hashes.(i) then begin
+        match Weak.get bucket i with
+        | Some v when E.equal v d -> v
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+  let repr h d t =
+    let ifnotfound index = add_aux t Weak.set (Some d) h index; d in
+    find_or h t d ifnotfound
+
+end
+
+module Combine = struct
+    (* These are helper functions to combine the hash keys in a similar
+       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
+       be prime numbers. There were chosen empirically. Notice that the
+       problem of hashing trees is hard and there are plenty of study on
+       this topic. Therefore, there must be room for improvement here. *)
+    let alpha = 65599
+    let beta  = 7
+    let combine x y     = x * alpha + y
+    let combine3 x y z   = combine x (combine y z)
+    let combine4 x y z t = combine x (combine3 y z t)
+    let combine5 x y z t u = combine x (combine4 y z t u)
+    let combinesmall x y = beta * x + y
+end
diff --git a/lib/hashset.mli b/lib/hashset.mli
new file mode 100644
index 00000000..537f3418
--- /dev/null
+++ b/lib/hashset.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Adapted from Damien Doligez, projet Para, INRIA Rocquencourt,
+    OCaml stdlib. *)
+
+(** The following functor is a specialized version of [Weak.Make].
+    Here, the responsibility of computing the hash function is now
+    given to the caller, which makes possible the interleaving of the
+    hash key computation and the hash-consing. *)
+
+module type EqType = sig
+  type t
+  val equal : t -> t -> bool
+end
+
+module type S = sig
+  type elt
+  (** Type of hashsets elements. *)
+  type t
+  (** Type of hashsets. *)
+  val create : int -> t
+  (** [create n] creates a fresh hashset with initial size [n]. *)
+  val clear : t -> unit
+  (** Clear the contents of a hashset. *)
+  val repr : int -> elt -> t -> elt
+  (** [repr key constr set] uses [key] to look for [constr]
+      in the hashet [set]. If [constr] is in [set], returns the
+      specific representation that is stored in [set]. Otherwise,
+      [constr] is stored in [set] and will be used as the canonical
+      representation of this value in the future. *)
+end
+
+module Make (E : EqType) : S with type elt = E.t
+
+module Combine : sig
+  val combine : int -> int -> int
+  val combinesmall : int -> int -> int
+  val combine3 : int -> int -> int -> int
+  val combine4 : int -> int -> int -> int -> int
+  val combine5 : int -> int -> int -> int -> int -> int
+end
diff --git a/lib/hashtbl_alt.ml b/lib/hashtbl_alt.ml
deleted file mode 100644
index 14b439ec..00000000
--- a/lib/hashtbl_alt.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
-   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
-   with [constr] used both as a key and as an image.  Thus, in each
-   cell of the internal bucketlist, there are two representations of
-   the same value. In this implementation, there is only one.
-
-   Besides, the responsibility of computing the hash function is now
-   given to the caller, which makes possible the interleaving of the
-   hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
-  type t
-  val equals : t -> t -> bool
-end
-
-module type S = sig
-  type elt
-  (* [may_add_and_get key constr] uses [key] to look for [constr]
-     in the hash table [H]. If [constr] is in [H], returns the
-     specific representation that is stored in [H]. Otherwise,
-     [constr] is stored in [H] and will be used as the canonical
-     representation of this value in the future. *)
-  val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) =
-  struct
-
-    type elt = E.t
-
-    type bucketlist = Empty | Cons of elt * int * bucketlist
-
-    let initial_size = 19991
-    let table_data = ref (Array.make initial_size Empty)
-    let table_size = ref 0
-
-    let resize () =
-      let odata = !table_data in
-      let osize = Array.length odata in
-    let nsize = min (2 * osize + 1) Sys.max_array_length in
-    if nsize <> osize then begin
-      let ndata = Array.create nsize Empty in
-      let rec insert_bucket = function
-	| Empty -> ()
-	| Cons (key, hash, rest) ->
-          let nidx = hash mod nsize in
-          ndata.(nidx) <- Cons (key, hash, ndata.(nidx));
-          insert_bucket rest
-      in
-      for i = 0 to osize - 1 do insert_bucket odata.(i) done;
-      table_data := ndata
-    end
-
-  let add hash key =
-    let odata = !table_data in
-    let osize = Array.length odata in
-    let i = hash mod osize in
-    odata.(i) <- Cons (key, hash, odata.(i));
-    incr table_size;
-    if !table_size > osize lsl 1 then resize ()
-
-  let find_rec hash key bucket =
-    let rec aux = function
-      | Empty ->
-	add hash key; key
-      | Cons (k, h, rest) ->
-	if hash == h && E.equals key k then k else aux rest
-    in
-    aux bucket
-
-  let may_add_and_get hash key =
-    let odata = !table_data in
-    match odata.(hash mod (Array.length odata)) with
-      |	Empty -> add hash key; key
-      | Cons (k1, h1, rest1) ->
-	if hash == h1 && E.equals key k1 then k1 else
-	  match rest1 with
-            | Empty -> add hash key; key
-	    | Cons (k2, h2, rest2) ->
-              if hash == h2 && E.equals key k2 then k2 else
-		match rest2 with
-		  | Empty -> add hash key; key
-		  | Cons (k3, h3, rest3) ->
-		    if hash == h3 && E.equals key k3 then k3
-		    else find_rec hash key rest3
-
-end
-
-module Combine = struct
-    (* These are helper functions to combine the hash keys in a similar
-       way as [Hashtbl.hash] does. The constants [alpha] and [beta] must
-       be prime numbers. There were chosen empirically. Notice that the
-       problem of hashing trees is hard and there are plenty of study on
-       this topic. Therefore, there must be room for improvement here. *)
-    let alpha = 65599
-    let beta  = 7
-    let combine x y     = x * alpha + y
-    let combine3 x y z   = combine x (combine y z)
-    let combine4 x y z t = combine x (combine3 y z t)
-    let combinesmall x y = beta * x + y
-end
diff --git a/lib/hashtbl_alt.mli b/lib/hashtbl_alt.mli
deleted file mode 100644
index f14fd90f..00000000
--- a/lib/hashtbl_alt.mli
+++ /dev/null
@@ -1,41 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* The following module is a specialized version of [Hashtbl] that is
-   a better space saver. Actually, [Hashcons] instanciates [Hashtbl.t]
-   with [constr] used both as a key and as an image.  Thus, in each
-   cell of the internal bucketlist, there are two representations of
-   the same value. In this implementation, there is only one.
-
-   Besides, the responsibility of computing the hash function is now
-   given to the caller, which makes possible the interleaving of the
-   hash key computation and the hash-consing. *)
-
-module type Hashtype = sig
-  type t
-  val equals : t -> t -> bool
-end
-
-module type S = sig
-  type elt
-  (* [may_add_and_get key constr] uses [key] to look for [constr]
-     in the hash table [H]. If [constr] is in [H], returns the
-     specific representation that is stored in [H]. Otherwise,
-     [constr] is stored in [H] and will be used as the canonical
-     representation of this value in the future. *)
-  val may_add_and_get : int -> elt -> elt
-end
-
-module Make (E : Hashtype) : S with type elt = E.t
-
-module Combine : sig
-  val combine : int -> int -> int
-  val combinesmall : int -> int -> int
-  val combine3 : int -> int -> int -> int
-  val combine4 : int -> int -> int -> int -> int
-end
diff --git a/lib/heap.ml b/lib/heap.ml
index 372cecfc..a19bc0d1 100644
--- a/lib/heap.ml
+++ b/lib/heap.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        *)
@@ -51,101 +51,86 @@ exception EmptyHeap
 
 module Functional(X : Ordered) = struct
 
-  (* Heaps are encoded as complete binary trees, i.e., binary trees
-     which are full expect, may be, on the bottom level where it is filled
-     from the left.
-     These trees also enjoy the heap property, namely the value of any node
-     is greater or equal than those of its left and right subtrees.
-
-     There are 4 kinds of complete binary trees, denoted by 4 constructors:
-     [FFF] for a full binary tree (and thus 2 full subtrees);
-     [PPF] for a partial tree with a partial left subtree and a full
-     right subtree;
-     [PFF] for a partial tree with a full left subtree and a full right subtree
-     (but of different heights);
-     and [PFP] for a partial tree with a full left subtree and a partial
-     right subtree. *)
+  (* Heaps are encoded as Braun trees, that are binary trees
+     where size r <= size l <= size r + 1 for each node Node (l, x, r) *)
 
   type t =
-    | Empty
-    | FFF of t * X.t * t (* full    (full,    full) *)
-    | PPF of t * X.t * t (* partial (partial, full) *)
-    | PFF of t * X.t * t (* partial (full,    full) *)
-    | PFP of t * X.t * t (* partial (full,    partial) *)
+    | Leaf
+    | Node of t * X.t * t
 
   type elt = X.t
 
-  let empty = Empty
+  let empty = Leaf
 
-  (* smart constructors for insertion *)
-  let p_f l x r = match l with
-    | Empty | FFF _ -> PFF (l, x, r)
-    | _ -> PPF (l, x, r)
-
-  let pf_ l x = function
-    | Empty | FFF _ as r -> FFF (l, x, r)
-    | r -> PFP (l, x, r)
+  let is_empty t = t = Leaf
 
   let rec add x = function
-    | Empty ->
-	FFF (Empty, x, Empty)
-    (* insertion to the left *)
-    | FFF (l, y, r) | PPF (l, y, r) ->
-	if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r
-    (* insertion to the right *)
-    | PFF (l, y, r) | PFP (l, y, r) ->
-	if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r)
+    | Leaf ->
+        Node (Leaf, x, Leaf)
+    | Node (l, y, r) ->
+        if X.compare x y >= 0 then
+          Node (add y r, x, l)
+        else
+          Node (add x r, y, l)
+
+  let rec extract = function
+    | Leaf ->
+        assert false
+    | Node (Leaf, y, r) ->
+        assert (r = Leaf);
+        y, Leaf
+    | Node (l, y, r) ->
+        let x, l = extract l in
+        x, Node (r, y, l)
+
+  let is_above x = function
+    | Leaf -> true
+    | Node (_, y, _) -> X.compare x y >= 0
+
+  let rec replace_min x = function
+    | Node (l, _, r) when is_above x l && is_above x r ->
+        Node (l, x, r)
+    | Node ((Node (_, lx, _) as l), _, r) when is_above lx r ->
+        (* lx <= x, rx necessarily *)
+        Node (replace_min x l, lx, r)
+    | Node (l, _, (Node (_, rx, _) as r)) ->
+        (* rx <= x, lx necessarily *)
+        Node (l, rx, replace_min x r)
+    | Leaf | Node (Leaf, _, _) | Node (_, _, Leaf) ->
+        assert false
+
+  (* merges two Braun trees [l] and [r],
+     with the assumption that [size r <= size l <= size r + 1] *)
+  let rec merge l r = match l, r with
+    | _, Leaf ->
+        l
+    | Node (ll, lx, lr), Node (_, ly, _) ->
+        if X.compare lx ly >= 0 then
+          Node (r, lx, merge ll lr)
+        else
+          let x, l = extract l in
+          Node (replace_min x r, ly, l)
+    | Leaf, _ ->
+        assert false (* contradicts the assumption *)
 
   let maximum = function
-    | Empty -> raise EmptyHeap
-    | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x
-
-  (* smart constructors for removal; note that they are different
-     from the ones for insertion! *)
-  let p_f l x r = match l with
-    | Empty | FFF _ -> FFF (l, x, r)
-    | _ -> PPF (l, x, r)
-
-  let pf_ l x = function
-    | Empty | FFF _ as r -> PFF (l, x, r)
-    | r -> PFP (l, x, r)
-
-  let rec remove = function
-    | Empty ->
-	raise EmptyHeap
-    | FFF (Empty, _, Empty) ->
-	Empty
-    | PFF (l, _, Empty) ->
-	l
-    (* remove on the left *)
-    | PPF (l, x, r) | PFF (l, x, r) ->
-        let xl = maximum l in
-	let xr = maximum r in
-	let l' = remove l in
-	if X.compare xl xr >= 0 then
-	  p_f l' xl r
-	else
-	  p_f l' xr (add xl (remove r))
-    (* remove on the right *)
-    | FFF (l, x, r) | PFP (l, x, r) ->
-        let xl = maximum l in
-	let xr = maximum r in
-	let r' = remove r in
-	if X.compare xl xr > 0 then
-	  pf_ (add xr (remove l)) xl r'
-	else
-	  pf_ l xr r'
+    | Leaf -> raise EmptyHeap
+    | Node (_, x, _) -> x
+
+  let remove = function
+    | Leaf ->
+        raise EmptyHeap
+    | Node (l, _, r) ->
+        merge l r
 
   let rec iter f = function
-    | Empty ->
-	()
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
-	iter f l; f x; iter f r
+    | Leaf -> ()
+    | Node (l, x, r) -> iter f l; f x; iter f r
 
   let rec fold f h x0 = match h with
-    | Empty ->
+    | Leaf ->
 	x0
-    | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) ->
+    | Node (l, x, r) ->
 	fold f l (fold f r (f x x0))
 
 end
diff --git a/lib/heap.mli b/lib/heap.mli
index ee86e814..a69de34c 100644
--- a/lib/heap.mli
+++ b/lib/heap.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/lib/hook.ml b/lib/hook.ml
new file mode 100644
index 00000000..0aa373c2
--- /dev/null
+++ b/lib/hook.ml
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  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 'a content =
+| Unset
+| Default of 'a
+| Set of 'a
+
+type 'a t = 'a content ref
+
+type 'a value = 'a t
+
+let get (hook : 'a value) = match !hook with
+| Unset -> assert false
+| Default data | Set data -> data
+
+let set (hook : 'a t) data = match !hook with
+| Unset | Default _ -> hook := Set data
+| Set _ -> assert false
+
+let make ?default () =
+  let data = match default with
+  | None -> Unset
+  | Some data -> Default data
+  in
+  let ans = ref data in
+  (ans, ans)
diff --git a/lib/hook.mli b/lib/hook.mli
new file mode 100644
index 00000000..d10f2c86
--- /dev/null
+++ b/lib/hook.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module centralizes the notions of hooks. Hooks are pointers that are to
+    be set at runtime exactly once. *)
+
+type 'a t
+(** The type of hooks containing ['a]. Hooks can only be set. *)
+
+type 'a value
+(** The content part of a hook. *)
+
+val make : ?default:'a -> unit -> ('a value * 'a t)
+(** Create a new hook together with a way to retrieve its runtime value. *)
+
+val get : 'a value -> 'a
+(** Access the content of a hook. If it was not set yet, try to recover the
+    default value if there is one.
+    @raise Assert_failure if undefined. *)
+
+val set : 'a t -> 'a -> unit
+(** Register a hook. Assertion failure if already registered. *)
diff --git a/lib/iStream.ml b/lib/iStream.ml
new file mode 100644
index 00000000..f9351d4b
--- /dev/null
+++ b/lib/iStream.ml
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  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 ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+
+type 'a node = ('a,'a t) u
+
+and 'a t = 'a node Lazy.t
+
+let empty = Lazy.lazy_from_val Nil
+
+let cons x s = Lazy.lazy_from_val (Cons (x, s))
+
+let thunk = Lazy.lazy_from_fun
+
+let rec make_node f s = match f s with
+| Nil -> Nil
+| Cons (x, s) -> Cons (x, make f s)
+
+and make f s = lazy (make_node f s)
+
+let rec force s = match Lazy.force s with
+| Nil -> ()
+| Cons (_, s) -> force s
+
+let force s = force s; s
+
+let is_empty s = match Lazy.force s with
+| Nil -> true
+| Cons (_, _) -> false
+
+let peek = Lazy.force
+
+let rec of_list = function
+| [] -> empty
+| x :: l -> cons x (of_list l)
+
+let rec to_list s = match Lazy.force s with
+| Nil -> []
+| Cons (x, s) -> x :: (to_list s)
+
+let rec iter f s = match Lazy.force s with
+| Nil -> ()
+| Cons (x, s) -> f x; iter f s
+
+let rec map_node f = function
+| Nil -> Nil
+| Cons (x, s) -> Cons (f x, map f s)
+
+and map f s = lazy (map_node f (Lazy.force s))
+
+let rec app_node n1 s2 = match n1 with
+| Nil -> Lazy.force s2
+| Cons (x, s1) -> Cons (x, app s1 s2)
+
+and app s1 s2 = lazy (app_node (Lazy.force s1) s2)
+
+let rec fold f accu s = match Lazy.force s with
+| Nil -> accu
+| Cons (x, s) -> fold f (f accu x) s
+
+let rec map_filter_node f = function
+| Nil -> Nil
+| Cons (x, s) ->
+  begin match f x with
+  | None -> map_filter_node f (Lazy.force s)
+  | Some y -> Cons (y, map_filter f s)
+  end
+
+and map_filter f s = lazy (map_filter_node f (Lazy.force s))
+
+let rec concat_node = function
+| Nil -> Nil
+| Cons (s, sl) -> app_node (Lazy.force s) (concat sl)
+
+and concat (s : 'a t t) =
+  lazy (concat_node (Lazy.force s))
+
+let rec concat_map_node f = function
+| Nil -> Nil
+| Cons (x,s) -> app_node (Lazy.force (f x)) (concat_map f s)
+
+and concat_map f l = lazy (concat_map_node f (Lazy.force l))
diff --git a/lib/iStream.mli b/lib/iStream.mli
new file mode 100644
index 00000000..8cb12af4
--- /dev/null
+++ b/lib/iStream.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {5 Purely functional streams}
+
+  Contrarily to OCaml module [Stream], these are meant to be used purely
+  functionally. This implies in particular that accessing an element does not
+  discard it. *)
+
+type +'a t
+(** Type of pure streams. *)
+
+type ('a,'r) u =
+| Nil
+| Cons of 'a * 'r
+(** View type to decompose and build streams. *)
+
+(** {6 Constructors} *)
+
+val empty : 'a t
+(** The empty stream. *)
+
+val cons : 'a -> 'a t -> 'a t
+(** Append an element in front of a stream. *)
+
+val thunk : (unit -> ('a,'a t) u) -> 'a t
+(** Internalize the lazyness of a stream. *)
+
+val make : ('a -> ('b, 'a) u) -> 'a -> 'b t
+(** Coiteration constructor. *)
+
+(** {6 Destructors} *)
+
+val is_empty : 'a t -> bool
+(** Whethere a stream is empty. *)
+
+val peek : 'a t -> ('a , 'a t) u
+(** Return the head and the tail of a stream, if any. *)
+
+(** {6 Standard operations}
+
+    All stream-returning functions are lazy. The other ones are eager. *)
+
+val app : 'a t -> 'a t -> 'a t
+(** Append two streams. Not tail-rec. *)
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+(** Mapping of streams. Not tail-rec. *)
+
+val iter : ('a -> unit) -> 'a t -> unit
+(** Iteration over streams. *)
+
+val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a
+(** Fold over streams. *)
+
+val concat : 'a t t -> 'a t
+(** Appends recursively a stream of streams. *)
+
+val map_filter : ('a -> 'b option) -> 'a t -> 'b t
+(** Mixing [map] and [filter]. Not tail-rec. *)
+
+val concat_map : ('a -> 'b t) -> 'a t -> 'b t
+(** [concat_map f l] is the same as [concat (map f l)]. *)
+
+(** {6 Conversions} *)
+
+val of_list : 'a list -> 'a t
+(** Convert a list into a stream. *)
+
+val to_list : 'a t -> 'a list
+(** Convert a stream into a list. *)
+
+(** {6 Other}*)
+
+val force : 'a t -> 'a t
+(** Forces the whole stream. *)
diff --git a/lib/int.ml b/lib/int.ml
new file mode 100644
index 00000000..d9917657
--- /dev/null
+++ b/lib/int.ml
@@ -0,0 +1,237 @@
+(************************************************************************)
+(*  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 t = int
+
+external equal : int -> int -> bool = "%eq"
+
+external compare : int -> int -> int = "caml_int_compare"
+
+let hash i = i land 0x3FFFFFFF
+
+module Self =
+struct
+  type t = int
+  let compare = compare
+end
+
+module Set = Set.Make(Self)
+module Map =
+struct
+  include CMap.Make(Self)
+
+  type 'a map = 'a CMap.Make(Self).t
+
+  type 'a _map =
+  | MEmpty
+  | MNode of 'a map * int * 'a * 'a map * int
+
+  let map_prj : 'a map -> 'a _map = Obj.magic
+
+  let rec find i s = match map_prj s with
+  | MEmpty -> raise Not_found
+  | MNode (l, k, v, r, h) ->
+    if i < k then find i l
+    else if i = k then v
+    else find i r
+end
+
+module List = struct
+  let mem = List.memq
+  let assoc = List.assq
+  let mem_assoc = List.mem_assq
+  let remove_assoc = List.remove_assq
+end
+
+let min (i : int) j = if i < j then i else j
+
+(** Utility function *)
+let rec next from upto =
+  if from < upto then next (2 * from + 1) upto
+  else from
+
+
+module PArray =
+struct
+
+  type 'a t = 'a data ref
+  and 'a data =
+  | Root of 'a option array
+  | DSet of int * 'a option * 'a t
+
+  let empty n = ref (Root (Array.make n None))
+
+  let rec rerootk t k = match !t with
+  | Root _ -> k ()
+  | DSet (i, v, t') ->
+    let next () = match !t' with
+    | Root a as n ->
+      let v' = Array.unsafe_get a i in
+      let () = Array.unsafe_set a i v in
+      let () = t := n in
+      let () = t' := DSet (i, v', t) in
+      k ()
+    | DSet _ -> assert false
+    in
+    rerootk t' next
+
+  let reroot t = rerootk t (fun () -> ())
+
+  let get t i =
+  let () = assert (0 <= i) in
+  match !t with
+  | Root a ->
+    if Array.length a <= i then None
+    else Array.unsafe_get a i
+  | DSet _ ->
+    let () = reroot t in
+    match !t with
+    | Root a ->
+      if Array.length a <= i then None
+      else Array.unsafe_get a i
+    | DSet _ -> assert false
+
+  let set t i v =
+    let () = assert (0 <= i) in
+    let () = reroot t in
+    match !t with
+    | DSet _ -> assert false
+    | Root a as n ->
+      let len = Array.length a in
+      if i < len then
+        let old = Array.unsafe_get a i in
+        if old == v then t
+        else
+          let () = Array.unsafe_set a i v in
+          let res = ref n in
+          let () = t := DSet (i, old, res) in
+          res
+      else match v with
+      | None -> t (** Nothing to do! *)
+      | Some _ -> (** we must resize *)
+        let nlen = next len (succ i) in
+        let nlen = min nlen Sys.max_array_length in
+        let () = assert (i < nlen) in
+        let a' = Array.make nlen None in
+        let () = Array.blit a 0 a' 0 len in
+        let () = Array.unsafe_set a' i v in
+        let res = ref (Root a') in
+        let () = t := DSet (i, None, res) in
+        res
+
+end
+
+module PMap =
+struct
+
+  type key = int
+
+  (** Invariants:
+
+    1. an empty map is always [Empty].
+    2. the set of the [Map] constructor remembers the present keys.
+  *)
+  type 'a t = Empty | Map of Set.t * 'a PArray.t
+
+  let empty = Empty
+
+  let is_empty = function
+  | Empty -> true
+  | Map _ -> false
+
+  let singleton k x =
+    let len = next 19 (k + 1) in
+    let len = min Sys.max_array_length len in
+    let v = PArray.empty len in
+    let v = PArray.set v k (Some x) in
+    let s = Set.singleton k in
+    Map (s, v)
+
+  let add k x = function
+  | Empty -> singleton k x
+  | Map (s, v) ->
+    let s = match PArray.get v k with
+    | None -> Set.add k s
+    | Some _ -> s
+    in
+    let v = PArray.set v k (Some x) in
+    Map (s, v)
+
+  let remove k = function
+  | Empty -> Empty
+  | Map (s, v) ->
+    let s = Set.remove k s in
+    if Set.is_empty s then Empty
+    else
+      let v = PArray.set v k None in
+      Map (s, v)
+
+  let mem k = function
+  | Empty -> false
+  | Map (_, v) ->
+    match PArray.get v k with
+    | None -> false
+    | Some _ -> true
+
+  let find k = function
+  | Empty -> raise Not_found
+  | Map (_, v) ->
+    match PArray.get v k with
+    | None -> raise Not_found
+    | Some x -> x
+
+  let iter f = function
+  | Empty -> ()
+  | Map (s, v) ->
+    let iter k = match PArray.get v k with
+    | None -> ()
+    | Some x -> f k x
+    in
+    Set.iter iter s
+
+  let fold f m accu = match m with
+  | Empty -> accu
+  | Map (s, v) ->
+    let fold k accu = match PArray.get v k with
+    | None -> accu
+    | Some x -> f k x accu
+    in
+    Set.fold fold s accu
+
+  let exists f m = match m with
+  | Empty -> false
+  | Map (s, v) ->
+    let exists k = match PArray.get v k with
+    | None -> false
+    | Some x -> f k x
+    in
+    Set.exists exists s
+
+  let for_all f m = match m with
+  | Empty -> true
+  | Map (s, v) ->
+    let for_all k = match PArray.get v k with
+    | None -> true
+    | Some x -> f k x
+    in
+    Set.for_all for_all s
+
+  let cast = function
+  | Empty -> Map.empty
+  | Map (s, v) ->
+    let bind k = match PArray.get v k with
+    | None -> assert false
+    | Some x -> x
+    in
+    Map.bind bind s
+
+  let domain = function
+  | Empty -> Set.empty
+  | Map (s, _) -> s
+
+end
diff --git a/lib/int.mli b/lib/int.mli
new file mode 100644
index 00000000..c910bda6
--- /dev/null
+++ b/lib/int.mli
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** A native integer module with usual utility functions. *)
+
+type t = int
+
+external equal : t -> t -> bool = "%eq"
+
+external compare : t -> t -> int = "caml_int_compare"
+
+val hash : t -> int
+
+module Set : Set.S with type elt = t
+module Map : CMap.ExtS with type key = t and module Set := Set
+
+module List : sig
+  val mem : int -> int list -> bool
+  val assoc : int -> (int * 'a) list -> 'a
+  val mem_assoc : int -> (int * 'a) list -> bool
+  val remove_assoc : int -> (int * 'a) list -> (int * 'a) list
+end
+
+module PArray :
+sig
+  type 'a t
+  (** Persistent, auto-resizable arrays. The [get] and [set] functions never
+      fail whenever the index is between [0] and [Sys.max_array_length - 1]. *)
+  val empty : int -> 'a t
+  (** The empty array, with a given starting size. *)
+  val get : 'a t -> int -> 'a option
+  (** Get a value at the given index. Returns [None] if undefined. *)
+  val set : 'a t -> int -> 'a option -> 'a t
+  (** Set/unset a value at the given index. *)
+end
+
+module PMap :
+sig
+  type key = int
+  type 'a t
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val mem : key -> 'a t -> bool
+  val add : key -> 'a -> 'a t -> 'a t
+  val singleton : key -> 'a -> 'a t
+  val remove : key -> 'a t -> 'a t
+(*   val merge : (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t *)
+(*   val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int *)
+(*   val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool *)
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val for_all : (key -> 'a -> bool) -> 'a t -> bool
+  val exists : (key -> 'a -> bool) -> 'a t -> bool
+(*   val filter : (key -> 'a -> bool) -> 'a t -> 'a t *)
+(*   val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t *)
+(*   val cardinal : 'a t -> int *)
+(*   val bindings : 'a t -> (key * 'a) list *)
+(*   val min_binding : 'a t -> key * 'a *)
+(*   val max_binding : 'a t -> key * 'a *)
+(*   val choose : 'a t -> key * 'a *)
+(*   val split : key -> 'a t -> 'a t * 'a option * 'a t *)
+  val find : key -> 'a t -> 'a
+(*   val map : ('a -> 'b) -> 'a t -> 'b t *)
+(*   val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t *)
+  val domain : 'a t -> Set.t
+  val cast : 'a t -> 'a Map.t
+end
+(** This is a (partial) implementation of a [Map] interface on integers, except
+    that it internally uses persistent arrays. This ensures O(1) accesses in
+    non-backtracking cases. It is thus better suited for zero-starting,
+    contiguous keys, or otherwise a lot of space will be empty. To keep track of
+    the present keys, a binary tree is also used, so that adding a key is
+    still logarithmic. It is therefore essential that most of the operations
+    are accesses and not add/removes. *)
diff --git a/lib/lib.mllib b/lib/lib.mllib
index db79b5c2..f3f6ad8f 100644
--- a/lib/lib.mllib
+++ b/lib/lib.mllib
@@ -1,31 +1,20 @@
-Xml_lexer
-Xml_parser
-Xml_utils
-Pp_control
-Pp
-Compat
-Flags
-Segmenttree
-Unicodetable
-Util
 Errors
 Bigint
-Hashcons
 Dyn
+Segmenttree
+Unicodetable
+Unicode
 System
-Envars
-Gmap
-Fset
-Fmap
-Tries
-Gmapl
+CThread
+Spawn
+Trie
 Profile
 Explore
 Predicate
 Rtree
 Heap
-Option
-Dnet
-Store
 Unionfind
-Hashtbl_alt
+Genarg
+Ephemeron
+Future
+RemoteCounter
diff --git a/lib/loc.ml b/lib/loc.ml
new file mode 100644
index 00000000..b62677d4
--- /dev/null
+++ b/lib/loc.ml
@@ -0,0 +1,79 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Locations management *)
+
+
+type t = {
+  fname : string; (** filename *)
+  line_nb : int; (** start line number *)
+  bol_pos : int; (** position of the beginning of start line *)
+  line_nb_last : int; (** end line number *)
+  bol_pos_last : int; (** position of the beginning of end line *)
+  bp : int; (** start position *)
+  ep : int; (** end position *)
+}
+
+let create fname line_nb bol_pos (bp, ep) = {
+  fname = fname; line_nb = line_nb; bol_pos = bol_pos;
+  line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; }
+
+let make_loc (bp, ep) = {
+  fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+  bp = bp; ep = ep; }
+
+let ghost = {
+  fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
+  bp = 0; ep = 0; }
+
+let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *)
+
+let merge loc1 loc2 =
+  if loc1.bp < loc2.bp then
+    if loc1.ep < loc2.ep then {
+      fname = loc1.fname;
+      line_nb = loc1.line_nb;
+      bol_pos = loc1.bol_pos;
+      line_nb_last = loc2.line_nb_last;
+      bol_pos_last = loc2.bol_pos_last;
+      bp = loc1.bp; ep = loc2.ep; }
+    else loc1
+  else if loc2.ep < loc1.ep then {
+    fname = loc2.fname;
+    line_nb = loc2.line_nb;
+    bol_pos = loc2.bol_pos;
+    line_nb_last = loc1.line_nb_last;
+    bol_pos_last = loc1.bol_pos_last;
+    bp = loc2.bp; ep = loc1.ep; }
+  else loc2
+
+let unloc loc = (loc.bp, loc.ep)
+
+let represent loc = (loc.fname, loc.line_nb, loc.bol_pos, loc.bp, loc.ep)
+
+let dummy_loc = ghost
+let join_loc = merge
+
+(** Located type *)
+
+type 'a located = t * 'a
+let located_fold_left f x (_,a) = f x a
+let located_iter2 f (_,a) (_,b) = f a b
+let down_located f (_,a) = f a
+
+(** Exceptions *)
+
+let location : t Exninfo.t = Exninfo.make ()
+
+let add_loc e loc = Exninfo.add e location loc
+
+let get_loc e = Exninfo.get e location
+
+let raise loc e =
+  let info = Exninfo.add Exninfo.null location loc in
+  Exninfo.iraise (e, info)
diff --git a/lib/loc.mli b/lib/loc.mli
new file mode 100644
index 00000000..7a9a9ffd
--- /dev/null
+++ b/lib/loc.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {5 Basic types} *)
+
+type t
+
+type 'a located = t * 'a
+(** Embed a location in a type *)
+
+(** {5 Location manipulation} *)
+
+(** This is inherited from CAMPL4/5. *)
+
+val create : string -> int -> int -> (int * int) -> t
+(** Create a location from a filename, a line number, a position of the
+    beginning of the line and a pair of start and end position *)
+
+val unloc : t -> int * int
+(** Return the start and end position of a location *)
+
+val make_loc : int * int -> t
+(** Make a location out of its start and end position *)
+
+val ghost : t
+(** Dummy location *)
+
+val is_ghost : t -> bool
+(** Test whether the location is meaningful *)
+
+val merge : t -> t -> t
+
+val represent : t -> (string * int * int * int * int)
+(** Return the arguments given in [create] *)
+
+(** {5 Located exceptions} *)
+
+val add_loc : Exninfo.info -> t -> Exninfo.info
+(** Adding location to an exception *)
+
+val get_loc : Exninfo.info -> t option
+(** Retrieving the optional location of an exception *)
+
+val raise : t -> exn -> 'a
+(** [raise loc e] is the same as [Pervasives.raise (add_loc e loc)]. *)
+
+(** {5 Location utilities} *)
+
+val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
+val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+
+val down_located : ('a -> 'b) -> 'a located -> 'b
+(** Projects out a located object *)
+
+(** {5 Backward compatibility} *)
+
+val dummy_loc : t
+(** Same as [ghost] *)
+
+val join_loc : t -> t -> t
+(** Same as [merge] *)
diff --git a/lib/monad.ml b/lib/monad.ml
new file mode 100644
index 00000000..4a52684d
--- /dev/null
+++ b/lib/monad.ml
@@ -0,0 +1,157 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+    [Make] functor. *)
+module type Def = sig
+
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (>>) : unit t -> 'a t -> 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+  (** The monadic laws must hold:
+      - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+      - [return a >>= f] = [f a]
+      - [x>>=return] = [x]
+
+      As well as the following identities:
+      - [x >> y] = [x >>= fun () -> y]
+      - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+module type ListS = sig
+
+  type 'a t
+
+  (** [List.map f l] maps [f] on the elements of [l] in left to right
+      order. *)
+  val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** [List.map f l] maps [f] on the elements of [l] in right to left
+      order. *)
+  val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** Like the regular [List.fold_right]. The monadic effects are
+      threaded right to left.
+
+      Note: many monads behave poorly with right-to-left order. For
+      instance a failure monad would still have to traverse the
+      whole list in order to fail and failure needs to be propagated
+      through the rest of the list in binds which are now
+      spurious. It is also the worst case for substitution monads
+      (aka free monads), exposing the quadratic behaviour.*)
+  val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+  (** Like the regular [List.fold_left]. The monadic effects are
+      threaded left to right. It is tail-recursive if the [(>>=)]
+      operator calls its second argument in a tail position. *)
+  val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+  (** Like the regular [List.iter]. The monadic effects are threaded
+      left to right. It is tail-recurisve if the [>>] operator calls
+      its second argument in a tail position. *)
+  val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+  (** {6 Two-list iterators} *)
+
+  (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+      simultaneously on two lists. Runs [r] (presumably an
+      exception-raising computation) if both lists do not have the
+      same length. *)
+  val fold_left2 : 'a t ->
+    ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+  include Def
+
+  (** List combinators *)
+  module List : ListS with type 'a t := 'a t
+
+end
+
+
+module Make (M:Def) : S with type +'a t = 'a M.t = struct
+
+  include M
+
+  module List = struct
+
+    (* The combinators are loop-unrolled to spare a some monadic binds
+       (it is a common optimisation to treat the last of a list of
+       bind specially) and hopefully gain some efficiency using fewer
+       jump. *)
+
+    let rec map f = function
+      | [] -> return []
+      | [a] ->
+          M.map (fun a' -> [a']) (f a)
+      | a::b::l ->
+          f a >>= fun a' ->
+          f b >>= fun b' ->
+          M.map (fun l' -> a'::b'::l') (map f l)
+
+    let rec map_right f = function
+      | [] -> return []
+      | [a] ->
+          M.map (fun a' -> [a']) (f a)
+      | a::b::l ->
+          map f l >>= fun l' ->
+          f b >>= fun b' ->
+          M.map (fun a' -> a'::b'::l') (f a)
+
+    let rec fold_right f l x =
+      match l with
+      | [] -> return x
+      | [a] -> f a x
+      | a::b::l ->
+          fold_right f l x >>= fun acc ->
+          f b acc >>= fun acc ->
+          f a acc
+
+    let rec fold_left f x = function
+      | [] -> return x
+      | [a] -> f x a
+      | a::b::l ->
+          f x a >>= fun x' ->
+          f x' b >>= fun x'' ->
+          fold_left f x'' l
+
+    let rec iter f = function
+      | [] -> return ()
+      | [a] -> f a
+      | a::b::l -> f a >> f b >> iter f l
+
+
+
+    let rec fold_left2 r f x l1 l2 =
+      match l1,l2 with
+      | [] , [] -> return x
+      | [a] , [b] -> f x a b
+      | a1::a2::l1 , b1::b2::l2 ->
+          f x a1 b1 >>= fun x' ->
+          f x' a2 b2 >>= fun x'' ->
+          fold_left2 r f x'' l1 l2
+      | _ , _ -> r
+
+  end
+
+end
+
+
+
diff --git a/lib/monad.mli b/lib/monad.mli
new file mode 100644
index 00000000..c8655efa
--- /dev/null
+++ b/lib/monad.mli
@@ -0,0 +1,90 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+
+(** Combinators on monadic computations. *)
+
+
+(** A definition of monads, each of the combinators is used in the
+    [Make] functor. *)
+module type Def = sig
+
+  type +'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (>>) : unit t -> 'a t -> 'a t
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+(** The monadic laws must hold:
+    - [(x>>=f)>>=g] = [x>>=fun x' -> (f x'>>=g)]
+    - [return a >>= f] = [f a]
+    - [x>>=return] = [x]
+
+    As well as the following identities:
+    - [x >> y] = [x >>= fun () -> y]
+    - [map f x] = [x >>= fun x' -> f x'] *)
+
+end
+
+
+(** List combinators *)
+module type ListS = sig
+
+  type 'a t
+
+  (** [List.map f l] maps [f] on the elements of [l] in left to right
+      order. *)
+  val map : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** [List.map f l] maps [f] on the elements of [l] in right to left
+      order. *)
+  val map_right : ('a -> 'b t) -> 'a list -> 'b list t
+
+  (** Like the regular [List.fold_right]. The monadic effects are
+      threaded right to left.
+
+      Note: many monads behave poorly with right-to-left order. For
+      instance a failure monad would still have to traverse the
+      whole list in order to fail and failure needs to be propagated
+      through the rest of the list in binds which are now
+      spurious. It is also the worst case for substitution monads
+      (aka free monads), exposing the quadratic behaviour.*)
+  val fold_right : ('a -> 'b -> 'b t) -> 'a list -> 'b -> 'b t
+
+  (** Like the regular [List.fold_left]. The monadic effects are
+      threaded left to right. It is tail-recursive if the [(>>=)]
+      operator calls its second argument in a tail position. *)
+  val fold_left : ('a -> 'b -> 'a t) -> 'a -> 'b list -> 'a t
+
+  (** Like the regular [List.iter]. The monadic effects are threaded
+      left to right. It is tail-recurisve if the [>>] operator calls
+      its second argument in a tail position. *)
+  val iter : ('a -> unit t) -> 'a list -> unit t
+
+
+  (** {6 Two-list iterators} *)
+
+  (** [fold_left2 r f s l1 l2] behaves like {!fold_left} but acts
+      simultaneously on two lists. Runs [r] (presumably an
+      exception-raising computation) if both lists do not have the
+      same length. *)
+  val fold_left2 : 'a t ->
+    ('a -> 'b -> 'c -> 'a t) -> 'a -> 'b list -> 'c list -> 'a t
+
+end
+
+module type S = sig
+
+  include Def
+
+  module List : ListS with type 'a t := 'a t
+
+end
+
+(** Expands the monadic definition to extra combinators. *)
+module Make (M:Def) : S with type +'a t = 'a M.t
diff --git a/lib/option.ml b/lib/option.ml
index d6df7063..9ea1a769 100644
--- a/lib/option.ml
+++ b/lib/option.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        *)
@@ -19,6 +19,26 @@ let has_some = function
   | None -> false
   | _ -> true
 
+let is_empty = function
+| None -> true
+| Some _ -> false
+
+(** Lifting equality onto option types. *)
+let equal f x y = match x, y with
+| None, None -> true
+| Some x, Some y -> f x y
+| _, _ -> false
+
+let compare f x y = match x, y with
+| None, None -> 0
+| Some x, Some y -> f x y
+| None, Some _ -> -1
+| Some _, None -> 1
+
+let hash f = function
+| None -> 0
+| Some x -> f x
+
 exception IsNone
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
@@ -44,6 +64,14 @@ let flatten = function
   | _ -> None
 
 
+(** [append x y] is the first element of the concatenation of [x] and
+    [y] seen as lists. *)
+let append o1 o2 =
+  match o1 with
+  | Some _ -> o1
+  | None  -> o2
+
+
 (** {6 "Iterators"} ***)
 
 (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing
@@ -153,21 +181,11 @@ module List =
   let rec flatten = function
     | x::l -> cons x (flatten l)
     | [] -> []
-end
-
 
+  let rec find f = function
+    |[] -> None
+    |h :: t -> match f h with
+	 |None -> find f t
+	 |x -> x
 
-(** {6 Miscelaneous Primitives} *)
-
-module Misc =
- struct
-  (** [Misc.compare f x y] lifts the equality predicate [f] to
-      option types. That is, if both [x] and [y] are [None] then
-      it returns [true], if they are bothe [Some _] then
-      [f] is called. Otherwise it returns [false]. *)
-   let compare f x y =
-     match x,y with
-     | None, None -> true
-     | Some z, Some w -> f z w
-     | _,_ -> false
 end
diff --git a/lib/option.mli b/lib/option.mli
index 121d6500..d9ad0e11 100644
--- a/lib/option.mli
+++ b/lib/option.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        *)
@@ -13,11 +13,26 @@
    they actually are similar considering ['a option] as a type
    of lists with at most one element. *)
 
+exception IsNone
+
 (** [has_some x] is [true] if [x] is of the form [Some y] and [false]
     otherwise.  *)
 val has_some : 'a option -> bool
 
-exception IsNone
+(** Negation of [has_some] *)
+val is_empty : 'a option -> bool
+
+(** [equal f x y] lifts the equality predicate [f] to
+    option types. That is, if both [x] and [y] are [None] then
+    it returns [true], if they are both [Some _] then
+    [f] is called. Otherwise it returns [false]. *)
+val equal : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+
+(** Same as [equal], but with comparison. *)
+val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int
+
+(** Lift a hash to option types. *)
+val hash : ('a -> int) -> 'a option -> int
 
 (** [get x] returns [y] where [x] is [Some y]. It raises IsNone
     if [x] equals [None]. *)
@@ -32,6 +47,12 @@ val init : bool -> 'a -> 'a option
 (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *)
 val flatten : 'a option option -> 'a option
 
+(** [append x y] is the first element of the concatenation of [x] and
+    [y] seen as lists.  In other words, [append (Some a) y] is [Some
+    a], [append None (Some b)] is [Some b], and [append None None] is
+    [None]. *)
+val append : 'a option -> 'a option -> 'a option
+
 
 (** {6 "Iterators"} ***)
 
@@ -67,7 +88,7 @@ val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
 (** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *)
 val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option
 
-(** [cata e f x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
+(** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *)
 val cata : ('a -> 'b) -> 'b -> 'a option -> 'b
 
 (** {6 More Specific Operations} ***)
@@ -100,16 +121,6 @@ module List : sig
   (** [List.flatten l] is the list of all the [y]s such that [l] contains
       [Some y] (in the same order). *)
   val flatten : 'a option list -> 'a list
-end
-
 
-(** {6 Miscelaneous Primitives} *)
-
-module Misc : sig
-  (** [Misc.compare f x y] lifts the equality predicate [f] to
-      option types. That is, if both [x] and [y] are [None] then
-      it returns [true], if they are bothe [Some _] then
-      [f] is called. Otherwise it returns [false]. *)
-   val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool
+  val find : ('a -> 'b option) -> 'a list -> 'b option
 end
-
diff --git a/lib/pp.ml b/lib/pp.ml
new file mode 100644
index 00000000..234d2344
--- /dev/null
+++ b/lib/pp.ml
@@ -0,0 +1,591 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module Glue : sig
+
+  (* A left associative glue implements efficient glue operator
+     when used as left associative.  If glue is denoted ++ then
+
+        a ++ b ++ c ++ d = ((a ++ b) ++ c) ++ d = [d] @ ([c] @ ([b] @  [a]))
+
+     I.e. if the short list is the second argument
+  *)
+  type 'a t
+
+  val atom : 'a -> 'a t
+  val glue : 'a t -> 'a t -> 'a t
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val iter : ('a -> unit) -> 'a t -> unit
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
+end = struct
+
+  type 'a t = 'a list
+
+  let atom x = [x]
+  let glue x y = y @ x
+  let empty = []
+  let is_empty x = x = []
+
+  let iter f g = List.iter f (List.rev g)
+  let map = List.map
+end
+
+module Tag :
+sig
+  type t 
+  type 'a key
+  val create : string -> 'a key
+  val inj : 'a -> 'a key -> t
+  val prj : t -> 'a key -> 'a option
+end =
+struct
+  (** See module {Dyn} for more details. *)
+
+  type t = int * Obj.t
+
+  type 'a key = int
+
+  let dyntab = ref (Int.Map.empty : string Int.Map.t)
+
+  let create (s : string) =
+    let hash = Hashtbl.hash s in
+    let () = assert (not (Int.Map.mem hash !dyntab)) in
+    let () = dyntab := Int.Map.add hash s !dyntab in
+    hash
+
+  let inj x h = (h, Obj.repr x)
+
+  let prj (nh, rv) h =
+    if Int.equal h nh then Some (Obj.magic rv)
+    else None
+
+end
+
+open Pp_control
+
+(* This should not be used outside of this file. Use
+   Flags.print_emacs instead. This one is updated when reading
+   command line options. This was the only way to make [Pp] depend on
+   an option without creating a circularity: [Flags] -> [Util] ->
+   [Pp] -> [Flags] *)
+let print_emacs = ref false
+
+(* The different kinds of blocks are:
+   \begin{description}
+   \item[hbox:] Horizontal block no line breaking;
+   \item[vbox:] Vertical block each break leads to a new line;
+   \item[hvbox:] Horizontal-vertical block: same as vbox, except if
+      this block is small enough to fit on a single line
+   \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
+      only when necessary to print the content of the block
+   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
+      (except if no mark yet on the reste of the line)
+   \end{description}
+ *)
+
+let comments = ref []
+
+let rec split_com comacc acc pos = function
+    [] -> comments := List.rev acc; comacc
+  | ((b,e),c as com)::coms ->
+      (* Take all comments that terminates before pos, or begin exactly
+         at pos (used to print comments attached after an expression) *)
+      if e<=pos || pos=b then split_com (c::comacc) acc pos coms
+      else  split_com comacc (com::acc) pos coms
+
+
+type block_type =
+  | Pp_hbox of int
+  | Pp_vbox of int
+  | Pp_hvbox of int
+  | Pp_hovbox of int
+  | Pp_tbox
+
+type str_token =
+| Str_def of string
+| Str_len of string * int (** provided length *)
+
+type 'a ppcmd_token =
+  | Ppcmd_print of 'a
+  | Ppcmd_box of block_type * ('a ppcmd_token Glue.t)
+  | Ppcmd_print_break of int * int
+  | Ppcmd_set_tab
+  | Ppcmd_print_tbreak of int * int
+  | Ppcmd_white_space of int
+  | Ppcmd_force_newline
+  | Ppcmd_print_if_broken
+  | Ppcmd_open_box of block_type
+  | Ppcmd_close_box
+  | Ppcmd_close_tbox
+  | Ppcmd_comment of int
+  | Ppcmd_open_tag of Tag.t
+  | Ppcmd_close_tag
+
+type 'a ppdir_token =
+  | Ppdir_ppcmds of 'a ppcmd_token Glue.t
+  | Ppdir_print_newline
+  | Ppdir_print_flush
+
+type ppcmd = str_token ppcmd_token
+
+type std_ppcmds = ppcmd Glue.t
+
+type 'a ppdirs = 'a ppdir_token Glue.t
+
+let (++) = Glue.glue
+
+let app = Glue.glue
+
+let is_empty g = Glue.is_empty g
+
+let rewrite f p =
+  let strtoken = function
+    | Str_len (s, n) ->
+      let s' = f s in
+      Str_len (s', String.length s')
+    | Str_def s ->
+      Str_def (f s)
+  in
+  let rec ppcmd_token = function
+    | Ppcmd_print x -> Ppcmd_print (strtoken x)
+    | Ppcmd_box (bt, g) -> Ppcmd_box (bt, Glue.map ppcmd_token g)
+    | p -> p
+  in
+  Glue.map ppcmd_token p
+
+(* Compute length of an UTF-8 encoded string
+   Rem 1 : utf8_length <= String.length (equal if pure ascii)
+   Rem 2 : if used for an iso8859_1 encoded string, the result is
+   wrong in very rare cases. Such a wrong case corresponds to any
+   sequence of a character in range 192..253 immediately followed by a
+   character in range 128..191 (typical case in french is "déçu" which
+   is counted 3 instead of 4); then no real harm to use always
+   utf8_length even if using an iso8859_1 encoding *)
+
+let utf8_length s =
+  let len = String.length s
+  and cnt = ref 0
+  and nc = ref 0
+  and p = ref 0 in
+  while !p < len do
+    begin
+      match s.[!p] with
+      | '\000'..'\127' -> nc := 0 (* ascii char *)
+      | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
+      | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
+      | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
+      | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
+      | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
+      | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
+      | '\254'..'\255' -> nc := 0 (* invalid byte *)
+    end ;
+    incr p ;
+    while !p < len && !nc > 0 do
+      match s.[!p] with
+      | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
+      | _ (* not a continuation byte *) -> nc := 0
+    done ;
+    incr cnt
+  done ;
+  !cnt
+
+(* formatting commands *)
+let str s = Glue.atom(Ppcmd_print (Str_def s))
+let stras (i, s) = Glue.atom(Ppcmd_print (Str_len (s, i)))
+let brk (a,b) = Glue.atom(Ppcmd_print_break (a,b))
+let tbrk (a,b) = Glue.atom(Ppcmd_print_tbreak (a,b))
+let tab () = Glue.atom(Ppcmd_set_tab)
+let fnl () = Glue.atom(Ppcmd_force_newline)
+let pifb () = Glue.atom(Ppcmd_print_if_broken)
+let ws n = Glue.atom(Ppcmd_white_space n)
+let comment n = Glue.atom(Ppcmd_comment n)
+
+(* derived commands *)
+let mt () = Glue.empty
+let spc () = Glue.atom(Ppcmd_print_break (1,0))
+let cut () = Glue.atom(Ppcmd_print_break (0,0))
+let align () = Glue.atom(Ppcmd_print_break (0,0))
+let int n = str (string_of_int n)
+let real r = str (string_of_float r)
+let bool b = str (string_of_bool b)
+let strbrk s =
+  let rec aux p n =
+    if n < String.length s then
+      if s.[n] = ' ' then
+        if p = n then spc() :: aux (n+1) (n+1)
+        else str (String.sub s p (n-p)) :: spc () :: aux (n+1) (n+1)
+      else aux p (n + 1)
+    else if p = n then [] else [str (String.sub s p (n-p))]
+  in List.fold_left (++) Glue.empty (aux 0 0)
+
+let ismt = is_empty
+
+(* boxing commands *)
+let h n s = Glue.atom(Ppcmd_box(Pp_hbox n,s))
+let v n s = Glue.atom(Ppcmd_box(Pp_vbox n,s))
+let hv n s = Glue.atom(Ppcmd_box(Pp_hvbox n,s))
+let hov n s = Glue.atom(Ppcmd_box(Pp_hovbox n,s))
+let t s = Glue.atom(Ppcmd_box(Pp_tbox,s))
+
+(* Opening and closing of boxes *)
+let hb n = Glue.atom(Ppcmd_open_box(Pp_hbox n))
+let vb n = Glue.atom(Ppcmd_open_box(Pp_vbox n))
+let hvb n = Glue.atom(Ppcmd_open_box(Pp_hvbox n))
+let hovb n = Glue.atom(Ppcmd_open_box(Pp_hovbox n))
+let tb () = Glue.atom(Ppcmd_open_box Pp_tbox)
+let close () = Glue.atom(Ppcmd_close_box)
+let tclose () = Glue.atom(Ppcmd_close_tbox)
+
+(* Opening and closed of tags *)
+let open_tag t = Glue.atom(Ppcmd_open_tag t)
+let close_tag () = Glue.atom(Ppcmd_close_tag)
+let tag t s = open_tag t ++ s ++ close_tag ()
+let eval_ppcmds l = l
+
+(* In new syntax only double quote char is escaped by repeating it *)
+let escape_string s =
+  let rec escape_at s i =
+    if i<0 then s
+    else if s.[i] == '"' then
+      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
+      escape_at s' (i-1)
+    else escape_at s (i-1) in
+  escape_at s (String.length s - 1)
+
+let qstring s = str ("\""^escape_string s^"\"")
+let qs = qstring
+let quote s = h 0 (str "\"" ++ s ++ str "\"")
+
+(* This flag tells if the last printed comment ends with a newline, to
+  avoid empty lines *)
+let com_eol = ref false
+
+let com_brk ft = com_eol := false
+let com_if ft f =
+  if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
+  else Lazy.force f
+
+let rec pr_com ft s =
+  let (s1,os) =
+    try
+      let n = String.index s '\n' in
+      String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
+    with Not_found -> s,None in
+  com_if ft (Lazy.lazy_from_val());
+(*  let s1 =
+    if String.length s1 <> 0 && s1.[0] = ' ' then
+      (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
+    else s1 in*)
+  Format.pp_print_as ft (utf8_length s1) s1;
+  match os with
+      Some s2 ->
+        if Int.equal (String.length s2) 0 then (com_eol := true)
+        else
+          (Format.pp_force_newline ft (); pr_com ft s2)
+    | None -> ()
+
+type tag_handler = Tag.t -> Format.tag
+
+(* pretty printing functions *)
+let pp_dirs ?pp_tag ft =
+  let pp_open_box = function
+    | Pp_hbox n   -> Format.pp_open_hbox ft ()
+    | Pp_vbox n   -> Format.pp_open_vbox ft n
+    | Pp_hvbox n  -> Format.pp_open_hvbox ft n
+    | Pp_hovbox n -> Format.pp_open_hovbox ft n
+    | Pp_tbox     -> Format.pp_open_tbox ft ()
+  in
+  let rec pp_cmd = function
+    | Ppcmd_print tok         ->
+        begin match tok with
+        | Str_def s ->
+          let n = utf8_length s in
+          com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+        | Str_len (s, n) ->
+          com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
+        end
+    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
+        com_if ft (Lazy.lazy_from_val());
+        pp_open_box bty ;
+        if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss;
+        Format.pp_close_box ft ()
+    | Ppcmd_open_box bty      -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
+    | Ppcmd_close_box         -> Format.pp_close_box ft ()
+    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
+    | Ppcmd_white_space n     ->
+        com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
+    | Ppcmd_print_break(m,n)  ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
+    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
+    | Ppcmd_print_tbreak(m,n) ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
+    | Ppcmd_force_newline     ->
+        com_brk ft; Format.pp_force_newline ft ()
+    | Ppcmd_print_if_broken   ->
+        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
+    | Ppcmd_comment i         ->
+        let coms = split_com [] [] i !comments in
+(*        Format.pp_open_hvbox ft 0;*)
+        List.iter (pr_com ft) coms(*;
+        Format.pp_close_box ft ()*)
+    | Ppcmd_open_tag tag ->
+      begin match pp_tag with
+      | None -> ()
+      | Some f -> Format.pp_open_tag ft (f tag)
+      end
+    | Ppcmd_close_tag ->
+      begin match pp_tag with
+      | None -> ()
+      | Some _ -> Format.pp_close_tag ft ()
+      end
+  in
+  let pp_dir = function
+    | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream
+    | Ppdir_print_newline    ->
+        com_brk ft; Format.pp_print_newline ft ()
+    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
+  in
+  fun (dirstream : _ ppdirs) ->
+    try
+      Glue.iter pp_dir dirstream; com_brk ft
+    with reraise ->
+      let reraise = Backtrace.add_backtrace reraise in
+      let () = Format.pp_print_flush ft () in
+      Exninfo.iraise reraise
+
+
+
+(* pretty print on stdout and stderr *)
+
+(* Special chars for emacs, to detect warnings inside goal output *)
+let emacs_quote_start = String.make 1 (Char.chr 254)
+let emacs_quote_end = String.make 1 (Char.chr 255)
+
+let emacs_quote_info_start = "<infomsg>"
+let emacs_quote_info_end = "</infomsg>"
+
+let emacs_quote g =
+  if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end
+  else hov 0 g
+
+let emacs_quote_info g =
+  if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end
+  else hov 0 g
+
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp_with ?pp_tag ft strm =
+  pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm))
+
+let ppnl_with ft strm =
+  pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ())))
+
+let pp_flush_with ft = Format.pp_print_flush ft
+
+(* pretty printing functions WITH FLUSH *)
+let msg_with ft strm =
+  pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush))
+
+let msgnl_with ft strm =
+  pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_newline))
+
+(* pretty printing functions WITHOUT FLUSH *)
+let pp        x = pp_with   !std_ft x
+let ppnl      x = ppnl_with !std_ft x
+let pperr     x = pp_with   !err_ft x
+let pperrnl   x = ppnl_with !err_ft x
+let message   s = ppnl      (str s)
+let pp_flush  x = Format.pp_print_flush !std_ft x
+let pperr_flush x = Format.pp_print_flush !err_ft x
+let flush_all () =
+  flush stderr; flush stdout; pp_flush (); pperr_flush ()
+
+(* pretty printing functions WITH FLUSH *)
+let msg x = msg_with !std_ft x
+let msgnl x = msgnl_with !std_ft x
+let msgerr x = msg_with !err_ft x
+let msgerrnl x = msgnl_with !err_ft x
+
+(* Logging management *)
+
+type message_level =  Feedback.message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = Feedback.message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+let of_message = Feedback.of_message
+let to_message = Feedback.to_message
+let is_message = Feedback.is_message
+
+type logger = message_level -> std_ppcmds -> unit
+
+let make_body info s =
+  emacs_quote (hov 0 (info ++ spc () ++ s))
+
+let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm)
+let warnbody strm = make_body (str "Warning:") strm
+let errorbody strm = make_body (str "Error:") strm
+let infobody strm = emacs_quote_info strm
+
+let std_logger ~id:_ level msg = match level with
+| Debug _ -> msgnl (debugbody msg)
+| Info -> msgnl (hov 0 msg)
+| Notice -> msgnl msg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody msg)) ()
+| Error -> msgnl_with !err_ft (errorbody msg)
+
+let emacs_logger ~id:_ level mesg = match level with
+| Debug _ -> msgnl (debugbody mesg)
+| Info -> msgnl (infobody mesg)
+| Notice -> msgnl mesg
+| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody mesg)) ()
+| Error -> msgnl_with !err_ft (errorbody mesg)
+
+let logger = ref std_logger
+
+let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger
+let make_pp_nonemacs() = print_emacs:=false; logger := std_logger
+
+
+let feedback_id = ref (Feedback.Edit 0)
+let feedback_route = ref Feedback.default_route
+
+(* If mixing some output and a goal display, please use msg_warning,
+   so that interfaces (proofgeneral for example) can easily dispatch
+   them to different windows. *)
+
+let msg_info x = !logger ~id:!feedback_id Info x
+let msg_notice x = !logger ~id:!feedback_id Notice x
+let msg_warning x = !logger ~id:!feedback_id Warning x
+let msg_error x = !logger ~id:!feedback_id Error x
+let msg_debug x = !logger ~id:!feedback_id (Debug "_") x
+
+let set_logger l = logger := (fun ~id:_ lvl msg -> l lvl msg)
+
+let std_logger lvl msg = std_logger ~id:!feedback_id lvl msg
+
+(** Feedback *)
+
+let feeder = ref ignore
+let set_id_for_feedback ?(route=Feedback.default_route) i =
+  feedback_id := i; feedback_route := route
+let feedback ?state_id ?edit_id ?route what =
+  !feeder {
+     Feedback.contents = what;
+     Feedback.route = Option.default !feedback_route route;
+     Feedback.id =
+       match state_id, edit_id with
+       | Some id, _ -> Feedback.State id
+       | None, Some eid -> Feedback.Edit eid
+       | None, None -> !feedback_id;
+  }
+let set_feeder f = feeder := f
+let get_id_for_feedback () = !feedback_id, !feedback_route
+
+(** Utility *)
+
+let string_of_ppcmds c =
+  msg_with Format.str_formatter c;
+  Format.flush_str_formatter ()
+
+let log_via_feedback () = logger := (fun ~id lvl msg ->
+  !feeder {
+     Feedback.contents = Feedback.Message {
+       message_level = lvl;
+       message_content = string_of_ppcmds msg };
+     Feedback.route = !feedback_route;
+     Feedback.id = id })
+
+(* Copy paste from Util *)
+
+let pr_comma () = str "," ++ spc ()
+let pr_semicolon () = str ";" ++ spc ()
+let pr_bar () = str "|" ++ spc ()
+let pr_arg pr x = spc () ++ pr x
+let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
+let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
+
+let pr_nth n =
+  int n ++ str (match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th")
+
+(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
+
+let prlist pr l = List.fold_left (fun x e -> x ++ pr e) Glue.empty l
+
+(* unlike all other functions below, [prlist] works lazily.
+   if a strict behavior is needed, use [prlist_strict] instead.
+   evaluation is done from left to right. *)
+
+let prlist_sep_lastsep no_empty sep lastsep elem =
+  let rec start = function
+    |[] -> mt ()
+    |[e] -> elem e
+    |h::t -> let e = elem h in
+        if no_empty && ismt e then start t else
+          let rec aux = function
+            |[] -> mt ()
+            |h::t ->
+               let e = elem h and r = aux t in
+                 if no_empty && ismt e then r else
+                   if ismt r
+                   then let s = lastsep () in s ++ e
+                   else let s = sep () in s ++ e ++ r
+          in let r = aux t in e ++ r
+  in start
+
+let prlist_strict pr l = prlist_sep_lastsep true mt mt pr l
+(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
+   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+let prlist_with_sep sep pr l = prlist_sep_lastsep false sep sep pr l
+(* Print sequence of objects separated by space (unless an element is empty) *)
+let pr_sequence pr l = prlist_sep_lastsep true spc spc pr l
+(* [pr_enum pr [a ; b ; ... ; c]] outputs
+   [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
+let pr_enum pr l = prlist_sep_lastsep true pr_comma (fun () -> str " and" ++ spc ()) pr l
+
+let pr_vertical_list pr = function
+  | [] -> str "none" ++ fnl ()
+  | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep fnl pr l) ++ fnl ()
+
+(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
+   [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
+
+let prvecti_with_sep sep elem v =
+  let rec pr i =
+    if Int.equal i 0 then
+      elem 0 v.(0)
+    else
+      let r = pr (i-1) and s = sep () and e = elem i v.(i) in
+      r ++ s ++ e
+  in
+  let n = Array.length v in
+  if Int.equal n 0 then mt () else pr (n - 1)
+
+(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
+
+let prvecti elem v = prvecti_with_sep mt elem v
+
+(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
+   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
+
+let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
+
+(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
+
+let prvect elem v = prvect_with_sep mt elem v
+
+let surround p = hov 1 (str"(" ++ p ++ str")")
diff --git a/lib/pp.ml4 b/lib/pp.ml4
deleted file mode 100644
index f13a3d16..00000000
--- a/lib/pp.ml4
+++ /dev/null
@@ -1,351 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp_control
-
-(* This should not be used outside of this file. Use
-   Flags.print_emacs instead. This one is updated when reading
-   command line options. This was the only way to make [Pp] depend on
-   an option without creating a circularity: [Flags. -> [Util] ->
-   [Pp] -> [Flags. *)
-let print_emacs = ref false
-let make_pp_emacs() = print_emacs:=true
-let make_pp_nonemacs() = print_emacs:=false
-
-(* The different kinds of blocks are:
-   \begin{description}
-   \item[hbox:] Horizontal block no line breaking;
-   \item[vbox:] Vertical block each break leads to a new line;
-   \item[hvbox:] Horizontal-vertical block: same as vbox, except if
-      this block is small enough to fit on a single line
-   \item[hovbox:] Horizontal or Vertical block: breaks lead to new line
-      only when necessary to print the content of the block
-   \item[tbox:] Tabulation block: go to tabulation marks and no line breaking
-      (except if no mark yet on the reste of the line)
-   \end{description}
- *)
-
-let comments = ref []
-
-let rec split_com comacc acc pos = function
-    [] -> comments := List.rev acc; comacc
-  | ((b,e),c as com)::coms ->
-      (* Take all comments that terminates before pos, or begin exactly
-         at pos (used to print comments attached after an expression) *)
-      if e<=pos || pos=b then split_com (c::comacc) acc pos coms
-      else  split_com comacc (com::acc) pos coms
-
-
-type block_type =
-  | Pp_hbox of int
-  | Pp_vbox of int
-  | Pp_hvbox of int
-  | Pp_hovbox of int
-  | Pp_tbox
-
-type 'a ppcmd_token =
-  | Ppcmd_print of 'a
-  | Ppcmd_box of block_type * ('a ppcmd_token Stream.t)
-  | Ppcmd_print_break of int * int
-  | Ppcmd_set_tab
-  | Ppcmd_print_tbreak of int * int
-  | Ppcmd_white_space of int
-  | Ppcmd_force_newline
-  | Ppcmd_print_if_broken
-  | Ppcmd_open_box of block_type
-  | Ppcmd_close_box
-  | Ppcmd_close_tbox
-  | Ppcmd_comment of int
-
-type 'a ppdir_token =
-  | Ppdir_ppcmds of 'a ppcmd_token Stream.t
-  | Ppdir_print_newline
-  | Ppdir_print_flush
-
-type ppcmd = (int*string) ppcmd_token
-
-type std_ppcmds = ppcmd Stream.t
-
-type 'a ppdirs = 'a ppdir_token Stream.t
-
-(* Compute length of an UTF-8 encoded string
-   Rem 1 : utf8_length <= String.length (equal if pure ascii)
-   Rem 2 : if used for an iso8859_1 encoded string, the result is
-   wrong in very rare cases. Such a wrong case corresponds to any
-   sequence of a character in range 192..253 immediately followed by a
-   character in range 128..191 (typical case in french is "déçu" which
-   is counted 3 instead of 4); then no real harm to use always
-   utf8_length even if using an iso8859_1 encoding *)
-
-let utf8_length s =
-  let len = String.length s
-  and cnt = ref 0
-  and nc = ref 0
-  and p = ref 0 in
-  while !p < len do
-    begin
-      match s.[!p] with
-      | '\000'..'\127' -> nc := 0 (* ascii char *)
-      | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *)
-      |	'\192'..'\223' -> nc := 1 (* expect 1 continuation byte *)
-      |	'\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *)
-      |	'\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *)
-      |	'\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *)
-      |	'\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *)
-      |	'\254'..'\255' -> nc := 0 (* invalid byte *)
-    end ;
-    incr p ;
-    while !p < len && !nc > 0 do
-      match s.[!p] with
-      |	'\128'..'\191' (* next continuation byte *) -> incr p ; decr nc
-      |	_ (* not a continuation byte *) -> nc := 0
-    done ;
-    incr cnt
-  done ;
-  !cnt
-
-(* formatting commands *)
-let str s = [< 'Ppcmd_print (utf8_length s,s) >]
-let stras (i,s) = [< 'Ppcmd_print (i,s) >]
-let brk (a,b) = [< 'Ppcmd_print_break (a,b) >]
-let tbrk (a,b) = [< 'Ppcmd_print_tbreak (a,b) >]
-let tab () = [< 'Ppcmd_set_tab >]
-let fnl () = [< 'Ppcmd_force_newline >]
-let pifb () = [< 'Ppcmd_print_if_broken >]
-let ws n = [< 'Ppcmd_white_space n >]
-let comment n = [< ' Ppcmd_comment n >]
-
-(* derived commands *)
-let mt () = [< >]
-let spc () = [< 'Ppcmd_print_break (1,0) >]
-let cut () = [< 'Ppcmd_print_break (0,0) >]
-let align () = [< 'Ppcmd_print_break (0,0) >]
-let int n = str (string_of_int n)
-let real r = str (string_of_float r)
-let bool b = str (string_of_bool b)
-let strbrk s =
-  let rec aux p n =
-    if n < String.length s then
-      if s.[n] = ' ' then
-	if p=n then [< spc (); aux (n+1) (n+1) >]
-	else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >]
-      else aux p (n+1)
-    else if p=n then [< >] else [< str (String.sub s p (n-p)) >]
-  in aux 0 0
-
-let ismt s = try let _ = Stream.empty s in true with Stream.Failure -> false
-
-(* boxing commands *)
-let h n s = [< 'Ppcmd_box(Pp_hbox n,s) >]
-let v n s = [< 'Ppcmd_box(Pp_vbox n,s) >]
-let hv n s = [< 'Ppcmd_box(Pp_hvbox n,s) >]
-let hov n s = [< 'Ppcmd_box(Pp_hovbox n,s) >]
-let t s = [< 'Ppcmd_box(Pp_tbox,s) >]
-
-(* Opening and closing of boxes *)
-let hb n = [< 'Ppcmd_open_box(Pp_hbox n) >]
-let vb n = [< 'Ppcmd_open_box(Pp_vbox n) >]
-let hvb n = [< 'Ppcmd_open_box(Pp_hvbox n) >]
-let hovb n = [< 'Ppcmd_open_box(Pp_hovbox n) >]
-let tb () = [< 'Ppcmd_open_box Pp_tbox >]
-let close () = [< 'Ppcmd_close_box >]
-let tclose () = [< 'Ppcmd_close_tbox >]
-
-let (++) = Stream.iapp
-
-let rec eval_ppcmds l =
-  let rec aux l =
-    try
-      let a = match Stream.next l with
-      | Ppcmd_box (b,s) -> Ppcmd_box (b,eval_ppcmds s)
-      | a -> a in
-      let rest = aux l in
-      a :: rest
-    with Stream.Failure -> [] in
-  Stream.of_list (aux l)
-
-(* In new syntax only double quote char is escaped by repeating it *)
-let rec escape_string s =
-  let rec escape_at s i =
-    if i<0 then s
-    else if s.[i] == '"' then
-      let s' = String.sub s 0 i^"\""^String.sub s i (String.length s - i) in
-      escape_at s' (i-1)
-    else escape_at s (i-1) in
-  escape_at s (String.length s - 1)
-
-let qstring s = str ("\""^escape_string s^"\"")
-let qs = qstring
-let quote s = h 0 (str "\"" ++ s ++ str "\"")
-
-let rec xmlescape ppcmd =
-  let rec escape what withwhat (len, str) =
-    try
-      let pos = String.index str what in
-      let (tlen, tail) =
-        escape what withwhat ((len - pos - 1),
-          (String.sub str (pos + 1) (len - pos - 1)))
-      in
-      (pos + tlen + String.length withwhat, String.sub str 0 pos ^ withwhat ^ tail)
-    with Not_found -> (len, str)
-  in
-  match ppcmd with
-    | Ppcmd_print (len, str) ->
-        Ppcmd_print (escape '"' "&quot;"
-          (escape '<' "&lt;" (escape '&' "&amp;" (len, str))))
-      (* In XML we always print whole content so we can npeek the whole stream *)
-    | Ppcmd_box (x, str) -> Ppcmd_box (x, Stream.of_list
-        (List.map xmlescape (Stream.npeek max_int str)))
-    | x -> x
-
-
-(* This flag tells if the last printed comment ends with a newline, to
-  avoid empty lines *)
-let com_eol = ref false
-
-let com_brk ft = com_eol := false
-let com_if ft f =
-  if !com_eol then (com_eol := false; Format.pp_force_newline ft ())
-  else Lazy.force f
-
-let rec pr_com ft s =
-  let (s1,os) =
-    try
-      let n = String.index s '\n' in
-      String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1))
-    with Not_found -> s,None in
-  com_if ft (Lazy.lazy_from_val());
-(*  let s1 =
-    if String.length s1 <> 0 && s1.[0] = ' ' then
-      (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1))
-    else s1 in*)
-  Format.pp_print_as ft (utf8_length s1) s1;
-  match os with
-      Some s2 ->
-        if String.length s2 = 0 then (com_eol := true)
-        else
-          (Format.pp_force_newline ft (); pr_com ft s2)
-    | None -> ()
-
-(* pretty printing functions *)
-let pp_dirs ft =
-  let pp_open_box = function
-    | Pp_hbox n   -> Format.pp_open_hbox ft ()
-    | Pp_vbox n   -> Format.pp_open_vbox ft n
-    | Pp_hvbox n  -> Format.pp_open_hvbox ft n
-    | Pp_hovbox n -> Format.pp_open_hovbox ft n
-    | Pp_tbox     -> Format.pp_open_tbox ft ()
-  in
-  let rec pp_cmd = function
-    | Ppcmd_print(n,s)        ->
-        com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s
-    | Ppcmd_box(bty,ss)       -> (* Prevent evaluation of the stream! *)
-        com_if ft (Lazy.lazy_from_val());
-        pp_open_box bty ;
-        if not (Format.over_max_boxes ()) then Stream.iter pp_cmd ss;
-        Format.pp_close_box ft ()
-    | Ppcmd_open_box bty      -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty
-    | Ppcmd_close_box         -> Format.pp_close_box ft ()
-    | Ppcmd_close_tbox        -> Format.pp_close_tbox ft ()
-    | Ppcmd_white_space n     ->
-        com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0))
-    | Ppcmd_print_break(m,n)  ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n))
-    | Ppcmd_set_tab           -> Format.pp_set_tab ft ()
-    | Ppcmd_print_tbreak(m,n) ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n))
-    | Ppcmd_force_newline     ->
-        com_brk ft; Format.pp_force_newline ft ()
-    | Ppcmd_print_if_broken   ->
-        com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ()))
-    | Ppcmd_comment i         ->
-        let coms = split_com [] [] i !comments in
-(*        Format.pp_open_hvbox ft 0;*)
-        List.iter (pr_com ft) coms(*;
-        Format.pp_close_box ft ()*)
-  in
-  let pp_dir = function
-    | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream
-    | Ppdir_print_newline    ->
-        com_brk ft; Format.pp_print_newline ft ()
-    | Ppdir_print_flush      -> Format.pp_print_flush ft ()
-  in
-  fun dirstream ->
-    try
-      Stream.iter pp_dir dirstream; com_brk ft
-    with
-      | reraise -> Format.pp_print_flush ft () ; raise reraise
-
-
-(* pretty print on stdout and stderr *)
-
-(* Special chars for emacs, to detect warnings inside goal output *)
-let emacs_quote_start = String.make 1 (Char.chr 254)
-let emacs_quote_end = String.make 1 (Char.chr 255)
-
-let emacs_quote strm =
-  if !print_emacs then
-    [< str emacs_quote_start; hov 0 strm; str emacs_quote_end >]
-  else hov 0 strm
-
-let warnbody strm = emacs_quote (str "Warning: " ++ strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm >]
-
-let ppnl_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds [< strm ; 'Ppcmd_force_newline >] >]
-
-let default_warn_with ft strm = ppnl_with ft (warnbody strm)
-
-let pp_warn_with = ref default_warn_with
-
-let set_warning_function pp_warn = pp_warn_with := pp_warn
-
-let warn_with ft strm = !pp_warn_with ft strm
-
-let warning_with ft string = warn_with ft (str string)
-
-let pp_flush_with ft = Format.pp_print_flush ft
-
-(* pretty printing functions WITH FLUSH *)
-let msg_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_flush >]
-
-let msgnl_with ft strm =
-  pp_dirs ft [< 'Ppdir_ppcmds strm ; 'Ppdir_print_newline >]
-
-let msg_warning_with ft strm =
-  msgnl_with ft (warnbody strm)
-
-(* pretty printing functions WITHOUT FLUSH *)
-let pp        x = pp_with   !std_ft x
-let ppnl      x = ppnl_with !std_ft x
-let pperr     x = pp_with   !err_ft x
-let pperrnl   x = ppnl_with !err_ft x
-let message   s = ppnl      (str s)
-let warning   x = warning_with !err_ft x
-let warn      x = warn_with    !err_ft x
-let pp_flush  x = Format.pp_print_flush !std_ft x
-let flush_all() = flush stderr; flush stdout; pp_flush()
-
-(* pretty printing functions WITH FLUSH *)
-let msg x = msg_with !std_ft x
-let msgnl x = msgnl_with !std_ft x
-let msgerr x = msg_with !err_ft x
-let msgerrnl x = msgnl_with !err_ft x
-let msg_warning x = msg_warning_with !err_ft x
-let msg_warn x = msg_warning (str x)
-
-(* Same specific display in emacs as warning, but without the "Warning:" *)
-let msg_debug x = msgnl (emacs_quote x)
-
-let string_of_ppcmds c =
-  msg_with Format.str_formatter c;
-  Format.flush_str_formatter ()
diff --git a/lib/pp.mli b/lib/pp.mli
index 695bcbc0..5dd2686d 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  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_control
-
 (** Modify pretty printing functions behavior for emacs ouput (special
    chars inserted at some places). This function should called once in
    module [Options], that's all. *)
@@ -16,11 +14,9 @@ val make_pp_nonemacs:unit -> unit
 
 (** Pretty-printers. *)
 
-type ppcmd
-
-type std_ppcmds = ppcmd Stream.t
+type std_ppcmds
 
-(** {6 Formatting commands. } *)
+(** {6 Formatting commands} *)
 
 val str  : string -> std_ppcmds
 val stras : int * string -> std_ppcmds
@@ -36,15 +32,24 @@ val ismt : std_ppcmds -> bool
 val comment : int -> std_ppcmds
 val comments : ((int * int) * string) list ref
 
-(** {6 Concatenation. } *)
+(** {6 Manipulation commands} *)
 
-val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+val app : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Concatenation. *)
 
-(** {6 Evaluation. } *)
+val (++) : std_ppcmds -> std_ppcmds -> std_ppcmds
+(** Infix alias for [app]. *)
 
 val eval_ppcmds : std_ppcmds -> std_ppcmds
+(** Force computation. *)
+
+val is_empty : std_ppcmds -> bool
+(** Test emptyness. *)
 
-(** {6 Derived commands. } *)
+val rewrite : (string -> string) -> std_ppcmds -> std_ppcmds
+(** [rewrite f pps] applies [f] to all strings that appear in [pps]. *)
+
+(** {6 Derived commands} *)
 
 val spc : unit -> std_ppcmds
 val cut : unit -> std_ppcmds
@@ -57,9 +62,7 @@ val qs : string -> std_ppcmds
 val quote : std_ppcmds -> std_ppcmds
 val strbrk : string -> std_ppcmds
 
-val xmlescape : ppcmd -> ppcmd
-
-(** {6 Boxing commands. } *)
+(** {6 Boxing commands} *)
 
 val h : int -> std_ppcmds -> std_ppcmds
 val v : int -> std_ppcmds -> std_ppcmds
@@ -67,7 +70,7 @@ val hv : int -> std_ppcmds -> std_ppcmds
 val hov : int -> std_ppcmds -> std_ppcmds
 val t : std_ppcmds -> std_ppcmds
 
-(** {6 Opening and closing of boxes. } *)
+(** {6 Opening and closing of boxes} *)
 
 val hb : int -> std_ppcmds
 val vb : int -> std_ppcmds
@@ -77,48 +80,200 @@ val tb : unit -> std_ppcmds
 val close : unit -> std_ppcmds
 val tclose : unit -> std_ppcmds
 
-(** {6 Pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+(** {6 Opening and closing of tags} *)
 
-val pp_with : Format.formatter -> std_ppcmds -> unit
-val ppnl_with : Format.formatter -> std_ppcmds -> unit
-val warning_with : Format.formatter -> string -> unit
-val warn_with : Format.formatter -> std_ppcmds -> unit
-val pp_flush_with : Format.formatter -> unit -> unit
+module Tag :
+sig
+  type t
+  (** Type of tags. Tags are dynamic types comparable to {Dyn.t}. *)
 
-val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit
+  type 'a key
+  (** Keys used to inject tags *)
 
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%}. } *)
+  val create : string -> 'a key
+  (** Create a key with the given name. Two keys cannot share the same name, if
+      ever this is the case this function raises an assertion failure. *)
 
-val msg_with : Format.formatter -> std_ppcmds -> unit
-val msgnl_with : Format.formatter -> std_ppcmds -> unit
+  val inj : 'a -> 'a key -> t
+  (** Inject an object into a tag. *)
+
+  val prj : t -> 'a key -> 'a option
+  (** Project an object from a tag. *)
+end
+
+type tag_handler = Tag.t -> Format.tag
+
+val tag : Tag.t -> std_ppcmds -> std_ppcmds
+val open_tag : Tag.t -> std_ppcmds
+val close_tag : unit -> std_ppcmds
+
+(** {6 Sending messages to the user} *)
+type message_level = Feedback.message_level =
+  | Debug of string
+  | Info
+  | Notice
+  | Warning
+  | Error
+
+type message = Feedback.message = {
+  message_level : message_level;
+  message_content : string;
+}
+
+type logger = message_level -> std_ppcmds -> unit
+
+(** {6 output functions}
+
+[msg_notice] do not put any decoration on output by default. If
+possible don't mix it with goal output (prefer msg_info or
+msg_warning) so that interfaces can dispatch outputs easily. Once all
+interfaces use the xml-like protocol this constraint can be
+relaxed. *)
+(* Should we advertise these functions more? Should they be the ONLY
+   allowed way to output something? *)
+
+val msg_info : std_ppcmds -> unit
+(** Message that displays information, usually in verbose mode, such as [Foobar
+    is defined] *)
+
+val msg_notice : std_ppcmds -> unit
+(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *)
+
+val msg_warning : std_ppcmds -> unit
+(** Message indicating that something went wrong, but without serious
+    consequences. *)
+
+val msg_error : std_ppcmds -> unit
+(** Message indicating that something went really wrong, though still
+    recoverable; otherwise an exception would have been raised. *)
+
+val msg_debug : std_ppcmds -> unit
+(** For debugging purposes *)
+
+val std_logger : logger
+(** Standard logging function *)
+
+val set_logger : logger -> unit
+
+val log_via_feedback : unit -> unit
+
+val of_message : message -> Xml_datatype.xml
+val to_message : Xml_datatype.xml -> message
+val is_message : Xml_datatype.xml -> bool
+
+
+(** {6 Feedback sent, even asynchronously, to the user interface} *)
+
+(* This stuff should be available to most of the system, line msg_* above.
+ * But I'm unsure this is the right place, especially for the global edit_id.
+ *
+ * Morally the parser gets a string and an edit_id, and gives back an AST.
+ * Feedbacks during the parsing phase are attached to this edit_id.
+ * The interpreter assignes an exec_id to the ast, and feedbacks happening
+ * during interpretation are attached to the exec_id.
+ * Only one among state_id and edit_id can be provided. *)
+
+val feedback :
+  ?state_id:Feedback.state_id -> ?edit_id:Feedback.edit_id ->
+  ?route:Feedback.route_id -> Feedback.feedback_content -> unit
+
+val set_id_for_feedback :
+  ?route:Feedback.route_id -> Feedback.edit_or_state_id -> unit
+val set_feeder : (Feedback.feedback -> unit) -> unit
+val get_id_for_feedback : unit -> Feedback.edit_or_state_id * Feedback.route_id
+
+(** {6 Utilities} *)
 
+val string_of_ppcmds : std_ppcmds -> string
+
+(** {6 Printing combinators} *)
+
+val pr_comma : unit -> std_ppcmds
+(** Well-spaced comma. *)
+
+val pr_semicolon : unit -> std_ppcmds
+(** Well-spaced semicolon. *)
+
+val pr_bar : unit -> std_ppcmds
+(** Well-spaced pipe bar. *)
+
+val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
+(** Adds a space in front of its argument. *)
+
+val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Inner object preceded with a space if [Some], nothing otherwise. *)
+
+val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
+(** Same as [pr_opt] but without the leading space. *)
+
+val pr_nth : int -> std_ppcmds
+(** Ordinal number with the correct suffix (i.e. "st", "nd", "th", etc.). *)
+
+val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Concatenation of the list contents, without any separator.
+
+    Unlike all other functions below, [prlist] works lazily. If a strict
+    behavior is needed, use [prlist_strict] instead. *)
+
+val prlist_strict :  ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Same as [prlist], but strict. *)
+
+val prlist_with_sep :
+   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [prlist_with_sep sep pr [a ; ... ; c]] outputs
+    [pr a ++ sep() ++ ... ++ sep() ++ pr c]. *)
+
+val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist], but on arrays. *)
+
+val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect]. *)
+
+val prvect_with_sep :
+   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** As [prlist_with_sep], but on arrays. *)
+
+val prvecti_with_sep :
+   (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
+(** Indexed version of [prvect_with_sep]. *)
 
-(** {6 ... } *)
-(** The following functions are instances of the previous ones on
-  [std_ft] and [err_ft]. *)
+val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** [pr_enum pr [a ; b ; ... ; c]] outputs
+    [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c]. *)
+
+val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+(** Sequence of objects separated by space (unless an element is empty). *)
+
+val surround : std_ppcmds -> std_ppcmds
+(** Surround with parenthesis. *)
+
+val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
+
+(** {6 Low-level pretty-printing functions {% \emph{%}without flush{% }%}. } *)
+
+val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit
 
 (** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *)
 
+(** These functions are low-level interface to printing and should not be used
+    in usual code. Consider using the [msg_*] function family instead. *)
+
 val pp : std_ppcmds -> unit
 val ppnl : std_ppcmds -> unit
 val pperr : std_ppcmds -> unit
 val pperrnl : std_ppcmds -> unit
-val message : string -> unit       (** = pPNL *)
-val warning : string -> unit
-val warn : std_ppcmds -> unit
+val pperr_flush : unit -> unit
 val pp_flush : unit -> unit
 val flush_all: unit -> unit
 
-(** {6 Pretty-printing functions {% \emph{%}with flush{% }%} on [stdout] and [stderr]. } *)
+(** {6 Deprecated functions} *)
+
+(** DEPRECATED. Do not use in newly written code. *)
+
+val msg_with : Format.formatter -> std_ppcmds -> unit
 
 val msg : std_ppcmds -> unit
 val msgnl : std_ppcmds -> unit
 val msgerr : std_ppcmds -> unit
 val msgerrnl : std_ppcmds -> unit
-val msg_warning : std_ppcmds -> unit
-val msg_warn : string -> unit
-
-(** Same specific display in emacs as warning, but without the "Warning:" **)
-val msg_debug : std_ppcmds -> unit
-
-val string_of_ppcmds : std_ppcmds -> string
+val message : string -> unit       (** = pPNL *)
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 94fdb881..0d224c03 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.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        *)
@@ -82,6 +82,7 @@ let set_depth_boxes v =
 let get_margin () = Some (Format.pp_get_margin !std_ft ())
 let set_margin v =
   let v = match v with None -> default_margin | Some v -> v in
+  Format.pp_set_margin Format.str_formatter v;
   Format.pp_set_margin !std_ft v;
   Format.pp_set_margin !deep_ft v
 
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index 2c2d00f3..28d2e299 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.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/lib/predicate.ml b/lib/predicate.ml
index e419aa6e..a60b3dad 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -54,8 +54,8 @@ module Make(Ord: OrderedType) =
     let full = (true,EltSet.empty)
 
     (* assumes the set is infinite *)
-    let is_empty (b,s) = not b & EltSet.is_empty s
-    let is_full (b,s) = b & EltSet.is_empty s
+    let is_empty (b,s) = not b && EltSet.is_empty s
+    let is_full (b,s) = b && EltSet.is_empty s
 
     let mem x (b,s) =
       if b then not (EltSet.mem x s) else EltSet.mem x s
@@ -92,6 +92,6 @@ module Make(Ord: OrderedType) =
         | ((true,_),(false,_)) -> false
 
     let equal (b1,s1) (b2,s2) =
-      b1=b2 & EltSet.equal s1 s2
+      b1=b2 && EltSet.equal s1 s2
 
   end
diff --git a/lib/profile.ml b/lib/profile.ml
index 0e4c2ebf..c55064ca 100644
--- a/lib/profile.ml
+++ b/lib/profile.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        *)
@@ -221,7 +221,7 @@ let loops = 10000
 let time_overhead_A_D () =
   let e = create_record () in
   let before = get_time () in
-  for i=1 to loops do
+  for _i = 1 to loops do
     (* This is a copy of profile1 for overhead estimation *)
     let dw = dummy_spent_alloc () in
     match !dummy_stack with [] -> assert false | p::_ ->
@@ -245,7 +245,7 @@ let time_overhead_A_D () =
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
-  for i=1 to loops do () done;
+  for _i = 1 to loops do () done;
   let afterloop = get_time () in
   float_of_int ((after - before) - (afterloop - beforeloop))
   /. float_of_int loops
@@ -253,18 +253,18 @@ let time_overhead_A_D () =
 let time_overhead_B_C () =
   let dummy_x = 0 in
   let before = get_time () in
-  for i=1 to loops do
+  for _i = 1 to loops do
     try
       dummy_last_alloc := get_alloc ();
       let _r = dummy_f dummy_x in
       let _dw = dummy_spent_alloc () in
       let _dt = get_time () in
       ()
-    with e when e <> Sys.Break -> assert false
+    with e when Errors.noncritical e -> assert false
   done;
   let after = get_time () in
   let beforeloop =  get_time () in
-  for i=1 to loops do () done;
+  for _i = 1 to loops do () done;
   let afterloop = get_time () in
   float_of_int ((after - before) - (afterloop - beforeloop))
   /. float_of_int loops
@@ -279,7 +279,7 @@ let format_profile (table, outside, total) =
   Printf.printf
     "%-23s  %9s %9s %10s %10s %10s\n"
     "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls ";
-  let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in
+  let l = List.sort (fun (_,{tottime=p}) (_,{tottime=p'}) -> p' - p) table in
   List.iter (fun (name,e) ->
     Printf.printf
       "%-23s %9.2f %9.2f %10.0f %10.0f %6d %6d\n"
@@ -352,7 +352,7 @@ let close_profile print =
 let print_profile () = close_profile true
 
 let declare_profile name =
-  if name = "___outside___" or name = "___total___" then
+  if name = "___outside___" || name = "___total___" then
     failwith ("Error: "^name^" is a reserved keyword");
   let e = create_record () in
   prof_table := (name,e)::!prof_table;
@@ -657,80 +657,57 @@ let profile7 e f a b c d g h i =
     last_alloc := get_alloc ();
     raise reraise
 
-(* Some utilities to compute the logical and physical sizes and depth
-   of ML objects *)
-
-let c = ref 0
-let s = ref 0
-let b = ref 0
-let m = ref 0
-
-let rec obj_stats d t =
-  if Obj.is_int t then m := max d !m
-  else if Obj.tag t >= Obj.no_scan_tag then
-    if Obj.tag t = Obj.string_tag then
-      (c := !c + Obj.size t; b := !b + 1; m := max d !m)
-    else if Obj.tag t = Obj.double_tag then
-      (s := !s + 2; b := !b + 1; m := max d !m)
-    else if Obj.tag t = Obj.double_array_tag then
-      (s := !s + 2 * Obj.size t; b := !b + 1; m := max d !m)
-    else (b := !b + 1; m := max d !m)
-  else
-    let n = Obj.size t in
-    s := !s + n; b := !b + 1;
-    block_stats (d + 1) (n - 1) t
-
-and block_stats d i t =
-  if i >= 0 then (obj_stats d (Obj.field t i); block_stats d (i-1) t)
-
-let obj_stats a =
-  c := 0; s:= 0; b:= 0; m:= 0;
-  obj_stats 0 (Obj.repr a);
-  (!c, !s + !b, !m)
-
-module H = Hashtbl.Make(
-  struct
-    type t = Obj.t
-    let equal = (==)
-    let hash o = Hashtbl.hash (Obj.magic o : int)
-  end)
-
-let tbl = H.create 13
-
-let rec obj_shared_size s t =
-  if Obj.is_int t then s
-  else if H.mem tbl t then s
-  else begin
-    H.add tbl t ();
-    let n = Obj.size t in
-    if Obj.tag t >= Obj.no_scan_tag then
-      if Obj.tag t = Obj.string_tag then (c := !c + n; s + 1)
-      else if Obj.tag t = Obj.double_tag then s + 3
-      else if Obj.tag t = Obj.double_array_tag then s + 2 * n + 1
-      else s + 1
-    else
-      block_shared_size (s + n + 1) (n - 1) t
-  end
-
-and block_shared_size s i t =
-  if i < 0 then s
-  else block_shared_size (obj_shared_size s (Obj.field t i)) (i-1) t
-
-let obj_shared_size a =
-  H.clear tbl;
-  c := 0;
-  let s = obj_shared_size 0 (Obj.repr a) in
-  (!c, s)
+let profile8 e f a b c d g h i j =
+  let dw = spent_alloc () in
+  match !stack with [] -> assert false | p::_ ->
+  (* We add spent alloc since last measure to current caller own/total alloc *)
+  ajoute_ownalloc p dw;
+  ajoute_totalloc p dw;
+  e.owncount <- e.owncount + 1;
+  if not (p==e) then stack := e::!stack;
+  let totalloc0 = e.totalloc in
+  let intcount0 = e.intcount in
+  let t = get_time () in
+  try
+    last_alloc := get_alloc ();
+    let r = f a b c d g h i j in
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    r
+  with reraise ->
+    let dw = spent_alloc () in
+    let dt = get_time () - t in
+    e.tottime <- e.tottime + dt; e.owntime <- e.owntime + dt;
+    ajoute_ownalloc e dw;
+    ajoute_totalloc e dw;
+    p.owntime <- p.owntime - dt;
+    ajoute_totalloc p (e.totalloc -. totalloc0);
+    p.intcount <- p.intcount + e.intcount - intcount0 + 1;
+    p.immcount <- p.immcount + 1;
+    if not (p==e) then
+      (match !stack with [] -> assert false | _::s -> stack := s);
+    last_alloc := get_alloc ();
+    raise reraise
 
 let print_logical_stats a =
-  let (c, s, d) = obj_stats a in
+  let (c, s, d) = CObj.obj_stats a in
   Printf.printf "Expanded size: %10d (str: %8d) Depth: %6d\n" (s+c) c d
 
 let print_stats a =
-  let (c1, s, d) = obj_stats a in
-  let (c2, o) = obj_shared_size a in
-  Printf.printf "Size: %8d (str: %8d) (exp: %10d)  Depth: %6d\n"
-    (o + c2) c2 (s + c1) d
+  let (c1, s, d) = CObj.obj_stats a in
+  let c2 = CObj.size a in
+  Printf.printf "Size: %8d (exp: %10d)  Depth: %6d\n"
+    c2 (s + c1) d
 (*
 let _ = Gc.set { (Gc.get()) with Gc.verbose = 13 }
 *)
diff --git a/lib/profile.mli b/lib/profile.mli
index 1e45ceed..e3221cd2 100644
--- a/lib/profile.mli
+++ b/lib/profile.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        *)
@@ -100,6 +100,10 @@ val profile7 :
   profile_key ->
   ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h)
     -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h
+val profile8 :
+  profile_key ->
+  ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i)
+    -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h -> 'i
 
 
 (** Some utilities to compute the logical and physical sizes and depth
@@ -113,12 +117,3 @@ val print_logical_stats : 'a -> unit
    This function allocates itself a lot (the same order of magnitude
    as the physical size of its argument) *)
 val print_stats : 'a -> unit
-
-(** Return logical size (first for strings, then for not strings),
-   (in words) and depth of its argument 
-   This function allocates itself a lot *)
-val obj_stats : 'a -> int * int * int
-
-(** Return physical size of its argument (string part and rest) 
-   This function allocates itself a lot *)
-val obj_shared_size : 'a -> int * int
diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml
new file mode 100644
index 00000000..f4d7bb7b
--- /dev/null
+++ b/lib/remoteCounter.ml
@@ -0,0 +1,48 @@
+(************************************************************************)
+(*  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 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+type remote_counters_status = (string * Obj.t) list
+
+let counters : remote_counters_status ref = ref []
+
+let (!!) x = !(!x)
+
+let new_counter ~name a ~incr ~build =
+  assert(not (List.mem_assoc name !counters));
+  let data = ref (ref a) in
+  counters := (name, Obj.repr data) :: !counters;
+  let m = Mutex.create () in
+  let mk_thsafe_getter f () =
+    (* - slaves must use a remote counter getter, not this one! *)
+    (* - in the main process there is a race condition between slave
+         managers (that are threads) and the main thread, hence the mutex *)
+    if Flags.async_proofs_is_worker () then
+      Errors.anomaly(Pp.str"Slave processes must install remote counters");
+    Mutex.lock m; let x = f () in Mutex.unlock m;
+    build x in
+  let getter = ref(mk_thsafe_getter (fun () -> !data := incr !!data; !!data)) in
+  let installer f =
+    if not (Flags.async_proofs_is_worker ()) then
+      Errors.anomaly(Pp.str"Only slave processes can install a remote counter");
+    getter := f in
+  (fun () -> !getter ()), installer
+
+let backup () = !counters
+
+let snapshot () =
+  List.map (fun (n,v) -> n, Obj.repr (ref (ref !!(Obj.obj v)))) !counters
+
+let restore l =
+  List.iter (fun (name, data) ->
+    assert(List.mem_assoc name !counters);
+    let dataref = Obj.obj (List.assoc name !counters) in
+    !dataref := !!(Obj.obj data))
+  l
diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli
new file mode 100644
index 00000000..f3eca418
--- /dev/null
+++ b/lib/remoteCounter.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Remote counters are *global* counters for fresh ids.  In the master/slave
+ * scenario, the slave installs a getter that asks the master for a fresh
+ * value.  In the scenario of a slave that runs after the death of the master
+ * on some marshalled data, a backup of all counters status should be taken and
+ * restored to avoid reusing ids.
+ * Counters cannot be created by threads, they must be created once and forall
+ * as toplevel module declarations. *)
+
+
+type 'a getter = unit -> 'a
+type 'a installer = ('a getter) -> unit
+
+val new_counter : name:string ->
+  'a -> incr:('a -> 'a) -> build:('a -> 'b) -> 'b getter * 'b installer
+
+type remote_counters_status
+val backup : unit -> remote_counters_status
+(* like backup but makes a copy so that further increment does not alter
+ * the snapshot *)
+val snapshot : unit -> remote_counters_status
+val restore : remote_counters_status -> unit
diff --git a/lib/richpp.ml b/lib/richpp.ml
new file mode 100644
index 00000000..745b7d2a
--- /dev/null
+++ b/lib/richpp.ml
@@ -0,0 +1,177 @@
+(************************************************************************)
+(*  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 Xml_datatype
+
+type 'annotation located = {
+  annotation : 'annotation option;
+  startpos   : int;
+  endpos     : int
+}
+
+let rich_pp annotate ppcmds =
+  (** First, we use Format to introduce tags inside
+      the pretty-printed document.
+
+      Each inserted tag is a fresh index that we keep in sync with the contents
+      of annotations.
+  *)
+  let annotations = ref [] in
+  let index = ref (-1) in
+  let pp_tag obj =
+    let () = incr index in
+    let () = annotations := obj :: !annotations in
+    string_of_int !index
+  in
+
+  let tagged_pp = Format.(
+
+    (** Warning: The following instructions are valid only if
+        [str_formatter] is not used for another purpose in
+        Pp.pp_with. *)
+
+    let ft = str_formatter in
+
+    (** We reuse {!Format} standard way of producing tags
+        inside pretty-printing. *)
+    pp_set_tags ft true;
+
+    (** The whole output must be a valid document. To that
+        end, we nest the document inside a tag named <pp>. *)
+    pp_open_tag ft "pp";
+
+    (** XML ignores spaces. The problem is that our pretty-printings
+        are based on spaces to indent. To solve that problem, we
+        systematically output non-breakable spaces, which are properly
+        honored by XML.
+
+        To do so, we reconfigure the [str_formatter] temporarily by
+        hijacking the function that output spaces. *)
+    let out, flush, newline, std_spaces =
+      pp_get_all_formatter_output_functions ft ()
+    in
+    let set = pp_set_all_formatter_output_functions ft ~out ~flush ~newline in
+    set ~spaces:(fun k ->
+      for i = 0 to k - 1 do
+        Buffer.add_string stdbuf "&nbsp;"
+      done
+    );
+
+    (** Some characters must be escaped in XML. This is done by the
+        following rewriting of the strings held by pretty-printing
+        commands. *)
+    Pp.(pp_with ~pp_tag ft (rewrite Xml_printer.pcdata_to_string ppcmds));
+
+    (** Insert </pp>. *)
+    pp_close_tag ft ();
+
+    (** Get the final string. *)
+    let output = flush_str_formatter () in
+
+    (** Finalize by restoring the state of the [str_formatter] and the
+        default behavior of Format. By the way, there may be a bug here:
+        there is no {!Format.pp_get_tags} and therefore if the tags flags
+        was already set to true before executing this piece of code, the
+        state of Format is not restored. *)
+    set ~spaces:std_spaces;
+    pp_set_tags ft false;
+    output
+  )
+  in
+  (** Second, we retrieve the final function that relates
+      each tag to an annotation. *)
+  let objs = CArray.rev_of_list !annotations in
+  let get index = annotate objs.(index) in
+
+  (** Third, we parse the resulting string. It is a valid XML
+      document (in the sense of Xml_parser). As blanks are
+      meaningful we deactivate canonicalization in the XML
+      parser. *)
+  let xml_pp =
+    try
+      Xml_parser.(parse ~do_not_canonicalize:true (make (SString tagged_pp)))
+    with Xml_parser.Error e ->
+      Printf.eprintf
+        "Broken invariant (RichPp): \n\
+         The output semi-structured pretty-printing is ill-formed.\n\
+         Please report.\n\
+         %s"
+        (Xml_parser.error e);
+      exit 1
+  in
+
+  (** Fourth, the low-level XML is turned into a high-level
+      semi-structured document that contains a located annotation in
+      every node. During the traversal of the low-level XML document,
+      we build a raw string representation of the pretty-print. *)
+  let rec node buffer = function
+    | Element (index, [], cs) ->
+      let startpos, endpos, cs = children buffer cs in
+      let annotation = try get (int_of_string index) with _ -> None in
+      (Element (index, { annotation; startpos; endpos }, cs), endpos)
+
+    | PCData s ->
+      Buffer.add_string buffer s;
+      (PCData s, Buffer.length buffer)
+
+    | _ ->
+      assert false (* Because of the form of XML produced by Format. *)
+
+  and children buffer cs =
+    let startpos   = Buffer.length buffer in
+    let cs, endpos =
+      List.fold_left (fun (cs, endpos) c ->
+        let c, endpos = node buffer c in
+        (c :: cs, endpos)
+      ) ([], startpos) cs
+    in
+    (startpos, endpos, List.rev cs)
+  in
+  let pp_buffer = Buffer.create 13 in
+  let xml, _ = node pp_buffer xml_pp in
+
+  (** We return the raw pretty-printing and its annotations tree. *)
+  (Buffer.contents pp_buffer, xml)
+
+let annotations_positions xml =
+  let rec node accu = function
+    | Element (_, { annotation = Some annotation; startpos; endpos }, cs) ->
+      children ((annotation, (startpos, endpos)) :: accu) cs
+    | Element (_, _, cs) ->
+      children accu cs
+    | _ ->
+      accu
+  and children accu cs =
+    List.fold_left node accu cs
+  in
+  node [] xml
+
+let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
+  let rec node = function
+    | Element (index, { annotation; startpos; endpos }, cs) ->
+      let attributes =
+        [ "startpos", string_of_int startpos;
+          "endpos", string_of_int endpos
+        ]
+        @ (match annotation with
+          | None -> []
+          | Some annotation -> attributes_of_annotation annotation
+        )
+      in
+      let tag =
+        match annotation with
+          | None -> index
+          | Some annotation -> tag_of_annotation annotation
+      in
+      Element (tag, attributes, List.map node cs)
+    | PCData s ->
+      PCData s
+  in
+  node xml
+
+
diff --git a/lib/richpp.mli b/lib/richpp.mli
new file mode 100644
index 00000000..446ee1a0
--- /dev/null
+++ b/lib/richpp.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module offers semi-structured pretty-printing. *)
+
+(** Each annotation of the semi-structured document refers to the
+    substring it annotates. *)
+type 'annotation located = {
+  annotation : 'annotation option;
+  startpos   : int;
+  endpos     : int
+}
+
+(** [rich_pp get_annotations ppcmds] returns the interpretation
+    of [ppcmds] as a string as well as a semi-structured document
+    that represents (located) annotations of this string.
+    The [get_annotations] function is used to convert tags into the desired
+    annotation. If this function returns [None], then no annotation is put. *)
+val rich_pp :
+  (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds ->
+  string * 'annotation located Xml_datatype.gxml
+
+(** [annotations_positions ssdoc] returns a list associating each
+    annotations with its position in the string from which [ssdoc] is
+    built. *)
+val annotations_positions :
+  'annotation located Xml_datatype.gxml ->
+  ('annotation * (int * int)) list
+
+(** [xml_of_rich_pp ssdoc] returns an XML representation of the
+    semi-structured document [ssdoc]. *)
+val xml_of_rich_pp :
+  ('annotation -> string) ->
+  ('annotation -> (string * string) list) ->
+  'annotation located Xml_datatype.gxml ->
+  Xml_datatype.xml
diff --git a/lib/rtree.ml b/lib/rtree.ml
index cfac6aa4..f395c086 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.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,17 +8,15 @@
 
 open Util
 
-
 (* Type of regular trees:
    - Param denotes tree variables (like de Bruijn indices)
      the first int is the depth of the occurrence, and the second int
-     is the index in the array of trees introduced at that depth
+     is the index in the array of trees introduced at that depth.
+     Warning: Param's indices both start at 0!
    - Node denotes the usual tree node, labelled with 'a
    - Rec(j,v1..vn) introduces infinite tree. It denotes
      v(j+1) with parameters 0..n-1 replaced by
      Rec(0,v1..vn)..Rec(n-1,v1..vn) respectively.
-     Parameters n and higher denote parameters global to the
-     current Rec node (as usual in de Bruijn binding system)
  *)
 type 'a t =
     Param of int * int
@@ -36,27 +34,26 @@ let rec lift_rtree_rec depth n = function
   | Rec(j,defs) ->
       Rec(j, Array.map (lift_rtree_rec (depth+1) n) defs)
 
-let lift n t = if n=0 then t else lift_rtree_rec 0 n t
+let lift n t = if Int.equal n 0 then t else lift_rtree_rec 0 n t
 
 (* The usual subst operation *)
 let rec subst_rtree_rec depth sub = function
     Param (i,j) as t ->
       if i < depth then t
-      else if i-depth < Array.length sub then
-        lift depth sub.(i-depth).(j)
-      else Param (i-Array.length sub,j)
+      else if i = depth then
+        lift depth (Rec (j, sub))
+      else Param (i - 1, j)
   | Node (l,sons) -> Node (l,Array.map (subst_rtree_rec depth sub) sons)
   | Rec(j,defs) ->
       Rec(j, Array.map (subst_rtree_rec (depth+1) sub) defs)
 
-let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t
+let subst_rtree sub t = subst_rtree_rec 0 sub t
 
 (* To avoid looping, we must check that every body introduces a node
    or a parameter *)
 let rec expand = function
   | Rec(j,defs) ->
-      let sub = Array.init (Array.length defs) (fun i -> Rec(i,defs)) in
-      expand (subst_rtree sub defs.(j))
+      expand (subst_rtree defs defs.(j))
   | t -> t
 
 (* Given a vector of n bodies, builds the n mutual recursive trees.
@@ -65,12 +62,13 @@ let rec expand = function
    directly one of the parameters of depth 0. Some care is taken to
    accept definitions like  rec X=Y and Y=f(X,Y) *)
 let mk_rec defs =
-  let rec check histo d =
-    match expand d with
-        Param(0,j) when List.mem j histo -> failwith "invalid rec call"
-      | Param(0,j) -> check (j::histo) defs.(j)
-      | _ -> () in
-  Array.mapi (fun i d -> check [i] d; Rec(i,defs)) defs
+  let rec check histo d = match expand d with
+  | Param (0, j) ->
+    if Int.Set.mem j histo then failwith "invalid rec call"
+    else check (Int.Set.add j histo) defs.(j)
+  | _ -> ()
+  in
+  Array.mapi (fun i d -> check (Int.Set.singleton i) d; Rec(i,defs)) defs
 (*
 let v(i,j) = lift i (mk_rec_calls(j+1)).(j);;
 let r = (mk_rec[|(mk_rec[|v(1,0)|]).(0)|]).(0);;
@@ -100,69 +98,96 @@ let rec map f t = match t with
   | Node (a,sons) -> Node (f a, Array.map (map f) sons)
   | Rec(j,defs) -> Rec (j, Array.map (map f) defs)
 
-let rec smartmap f t = match t with
+let smartmap f t = match t with
     Param _ -> t
   | Node (a,sons) ->
-      let a'=f a and sons' = Util.array_smartmap (map f) sons in
-	if a'==a && sons'==sons then
-	  t
-	else
-	  Node (a',sons')
+      let a'=f a and sons' = Array.smartmap (map f) sons in
+      if a'==a && sons'==sons then t
+      else Node (a',sons')
   | Rec(j,defs) ->
-      let defs' = Util.array_smartmap (map f) defs in
-	if defs'==defs then
-	  t
-	else
-	  Rec(j,defs')
-
-(* Fixpoint operator on trees:
-   f is the body of the fixpoint. Arguments passed to f are:
-   - a boolean telling if the subtree has already been seen
-   - the current subtree
-   - a function to make recursive calls on subtrees
- *)
-let fold f t =
-  let rec fold histo t =
-    let seen = List.mem t histo in
-    let nhisto = if not seen then t::histo else histo in
-    f seen (expand t) (fold nhisto) in
-  fold [] t
-
-
-(* Tests if a given tree is infinite, i.e. has an branch of infinte length. *)
-let is_infinite t = fold
-  (fun seen t is_inf ->
-    seen ||
-    (match t with
-        Node(_,v) -> array_exists is_inf v
-      | Param _ -> false
-      | _ -> assert false))
-  t
-
-let fold2 f t x =
-  let rec fold histo t x =
-    let seen = List.mem (t,x) histo in
-    let nhisto = if not seen then (t,x)::histo else histo in
-    f seen (expand t) x (fold nhisto) in
-  fold [] t x
-
-let compare_rtree f = fold2
-  (fun seen t1 t2 cmp ->
-    seen ||
-    let b = f t1 t2 in
-    if b < 0 then false
-    else if b > 0 then true
-    else match expand t1, expand t2 with
-        Node(_,v1), Node(_,v2) when Array.length v1 = Array.length v2 ->
-          array_for_all2 cmp v1 v2
-      | _ -> false)
-
-let eq_rtree cmp t1 t2 =
-  t1 == t2 || t1=t2 ||
-  compare_rtree
-    (fun t1 t2 ->
-      if cmp (fst(dest_node t1)) (fst(dest_node t2)) then 0
-      else (-1)) t1 t2
+      let defs' = Array.smartmap (map f) defs in
+      if defs'==defs then t
+      else Rec(j,defs')
+
+(** Structural equality test, parametrized by an equality on elements *)
+
+let rec raw_eq cmp t t' = match t, t' with
+  | Param (i,j), Param (i',j') -> Int.equal i i' && Int.equal j j'
+  | Node (x, a), Node (x', a') -> cmp x x' && Array.equal (raw_eq cmp) a a'
+  | Rec (i, a), Rec (i', a') -> Int.equal i i' && Array.equal (raw_eq cmp) a a'
+  | _ -> false
+
+let raw_eq2 cmp (t,u) (t',u') = raw_eq cmp t t' && raw_eq cmp u u'
+
+(** Equivalence test on expanded trees. It is parametrized by two
+    equalities on elements:
+    - [cmp] is used when checking for already seen trees
+    - [cmp'] is used when comparing node labels. *)
+
+let equiv cmp cmp' =
+  let rec compare histo t t' =
+    List.mem_f (raw_eq2 cmp) (t,t') histo ||
+    match expand t, expand t' with
+    | Node(x,v), Node(x',v') ->
+        cmp' x x' &&
+        Int.equal (Array.length v) (Array.length v') &&
+        Array.for_all2 (compare ((t,t')::histo)) v v'
+    | _ -> false
+  in compare []
+
+(** The main comparison on rtree tries first physical equality, then
+    the structural one, then the logical equivalence *)
+
+let equal cmp t t' =
+  t == t' || raw_eq cmp t t' || equiv cmp cmp t t'
+
+(** Deprecated alias *)
+let eq_rtree = equal
+
+(** Intersection of rtrees of same arity *)
+let rec inter cmp interlbl def n histo t t' =
+  try
+    let (i,j) = List.assoc_f (raw_eq2 cmp) (t,t') histo in
+    Param (n-i-1,j)
+  with Not_found ->
+  match t, t' with
+  | Param (i,j), Param (i',j') ->
+      assert (Int.equal i i' && Int.equal j j'); t
+  | Node (x, a), Node (x', a') ->
+      (match interlbl x x' with
+      | None -> mk_node def [||]
+      | Some x'' -> Node (x'', Array.map2 (inter cmp interlbl def n histo) a a'))
+  | Rec (i,v), Rec (i',v') ->
+     (* If possible, we preserve the shape of input trees *)
+     if Int.equal i i' && Int.equal (Array.length v) (Array.length v') then
+       let histo = ((t,t'),(n,i))::histo in
+       Rec(i, Array.map2 (inter cmp interlbl def (n+1) histo) v v')
+     else
+     (* Otherwise, mutually recursive trees are transformed into nested trees *)
+       let histo = ((t,t'),(n,0))::histo in
+       Rec(0, [|inter cmp interlbl def (n+1) histo (expand t) (expand t')|])
+  | Rec _, _ -> inter cmp interlbl def n histo (expand t) t'
+  | _ , Rec _ -> inter cmp interlbl def n histo t (expand t')
+  | _ -> assert false
+
+let inter cmp interlbl def t t' = inter cmp interlbl def 0 [] t t'
+
+(** Inclusion of rtrees. We may want a more efficient implementation. *)
+let incl cmp interlbl def t t' =
+  equal cmp t (inter cmp interlbl def t t')
+
+(** Tests if a given tree is infinite, i.e. has a branch of infinite length.
+   This corresponds to a cycle when visiting the expanded tree.
+   We use a specific comparison to detect already seen trees. *)
+
+let is_infinite cmp t =
+  let rec is_inf histo t =
+    List.mem_f (raw_eq cmp) t histo ||
+    match expand t with
+    | Node (_,v) -> Array.exists (is_inf (t::histo)) v
+    | _ -> false
+  in
+  is_inf [] t
 
 (* Pretty-print a tree (not so pretty) *)
 open Pp
@@ -173,11 +198,11 @@ let rec pp_tree prl t =
     | Node(lab,[||]) -> hov 2 (str"("++prl lab++str")")
     | Node(lab,v) ->
         hov 2 (str"("++prl lab++str","++brk(1,0)++
-               Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str")")
+               prvect_with_sep pr_comma (pp_tree prl) v++str")")
     | Rec(i,v) ->
-        if Array.length v = 0 then str"Rec{}"
-        else if Array.length v = 1 then
+        if Int.equal (Array.length v) 0 then str"Rec{}"
+        else if Int.equal (Array.length v) 1 then
           hov 2 (str"Rec{"++pp_tree prl v.(0)++str"}")
         else
           hov 2 (str"Rec{"++int i++str","++brk(1,0)++
-                 Util.prvect_with_sep Util.pr_comma (pp_tree prl) v++str"}")
+                 prvect_with_sep pr_comma (pp_tree prl) v++str"}")
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 8b12fee1..0b9424b8 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** Type of regular tree with nodes labelled by values of type 'a 
+(** Type of regular tree with nodes labelled by values of type 'a
    The implementation uses de Bruijn indices, so binding capture
    is avoided by the lift operator (see example below) *)
 type 'a t
@@ -49,22 +49,26 @@ val dest_node  : 'a t -> 'a * 'a t array
 (** dest_param is not needed for closed trees (i.e. with no free variable) *)
 val dest_param : 'a t -> int * int
 
-(** Tells if a tree has an infinite branch *)
-val is_infinite : 'a t -> bool
-
-(** [compare_rtree f t1 t2] compares t1 t2 (top-down).
-   f is called on each node: if the result is negative then the
-   traversal ends on false, it is is positive then deeper nodes are
-   not examined, and the traversal continues on respective siblings,
-   and if it is 0, then the traversal continues on sons, pairwise.
-   In this latter case, if the nodes do not have the same number of
-   sons, then the traversal ends on false.
-   In case of loop, the traversal is successful and it resumes on
-   siblings.
- *)
-val compare_rtree : ('a t -> 'b t -> int) -> 'a t -> 'b t -> bool
+(** Tells if a tree has an infinite branch. The first arg is a comparison
+    used to detect already seen elements, hence loops *)
+val is_infinite : ('a -> 'a -> bool) -> 'a t -> bool
 
-val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** [Rtree.equiv eq eqlab t1 t2] compares t1 t2 (top-down).
+   If t1 and t2 are both nodes, [eqlab] is called on their labels,
+   in case of success deeper nodes are examined.
+   In case of loop (detected via structural equality parametrized
+   by [eq]), then the comparison is successful. *)
+val equiv :
+  ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+(** [Rtree.equal eq t1 t2] compares t1 and t2, first via physical
+    equality, then by structural equality (using [eq] on elements),
+    then by logical equivalence [Rtree.equiv eq eq] *)
+val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+val inter : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> 'a t
+
+val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t -> bool
 
 (** Iterators *)
 
@@ -72,9 +76,9 @@ val map : ('a -> 'b) -> 'a t -> 'b t
 
 (** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *)
 val smartmap : ('a -> 'a) -> 'a t -> 'a t
-val fold : (bool -> 'a t -> ('a t -> 'b) -> 'b) -> 'a t -> 'b
-val fold2 :
-  (bool -> 'a t -> 'b -> ('a t -> 'b -> 'c) -> 'c) -> 'a t -> 'b -> 'c
 
 (** A rather simple minded pretty-printer *)
 val pp_tree : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+
+val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+(** @deprecated Same as [Rtree.equal] *)
diff --git a/lib/serialize.ml b/lib/serialize.ml
new file mode 100644
index 00000000..aa2e3f02
--- /dev/null
+++ b/lib/serialize.ml
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  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 Xml_datatype
+
+exception Marshal_error
+
+(** Utility functions *)
+
+let rec get_attr attr = function
+  | [] -> raise Not_found
+  | (k, v) :: l when CString.equal k attr -> v
+  | _ :: l -> get_attr attr l
+
+let massoc x l =
+  try get_attr x l
+  with Not_found -> raise Marshal_error
+
+let constructor t c args = Element (t, ["val", c], args)
+let do_match t mf = function
+  | Element (s, attrs, args) when CString.equal s t ->
+      let c = massoc "val" attrs in
+      mf c args
+  | _ -> raise Marshal_error
+
+let singleton = function
+  | [x] -> x
+  | _ -> raise Marshal_error
+
+let raw_string = function
+  | [] -> ""
+  | [PCData s] -> s
+  | _ -> raise Marshal_error
+
+(** Base types *)
+
+let of_unit () = Element ("unit", [], [])
+let to_unit : xml -> unit = function
+  | Element ("unit", [], []) -> ()
+  | _ -> raise Marshal_error
+
+let of_bool (b : bool) : xml =
+  if b then constructor "bool" "true" []
+  else constructor "bool" "false" []
+let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
+  | "true" -> true
+  | "false" -> false
+  | _ -> raise Marshal_error)
+
+let of_list (f : 'a -> xml) (l : 'a list) =
+  Element ("list", [], List.map f l)
+let to_list (f : xml -> 'a) : xml -> 'a list = function
+  | Element ("list", [], l) -> List.map f l
+  | _ -> raise Marshal_error
+
+let of_option (f : 'a -> xml) : 'a option -> xml = function
+  | None -> Element ("option", ["val", "none"], [])
+  | Some x -> Element ("option", ["val", "some"], [f x])
+let to_option (f : xml -> 'a) : xml -> 'a option = function
+  | Element ("option", ["val", "none"], []) -> None
+  | Element ("option", ["val", "some"], [x]) -> Some (f x)
+  | _ -> raise Marshal_error
+
+let of_string (s : string) : xml = Element ("string", [], [PCData s])
+let to_string : xml -> string = function
+  | Element ("string", [], l) -> raw_string l
+  | _ -> raise Marshal_error
+
+let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
+let to_int : xml -> int = function
+  | Element ("int", [], [PCData s]) ->
+    (try int_of_string s with Failure _ -> raise Marshal_error)
+  | _ -> raise Marshal_error
+
+let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml =
+  Element ("pair", [], [f (fst x); g (snd x)])
+let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
+  | Element ("pair", [], [x; y]) -> (f x, g y)
+  | _ -> raise Marshal_error
+
+let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function
+  | CSig.Inl x -> Element ("union", ["val","in_l"], [f x])
+  | CSig.Inr x -> Element ("union", ["val","in_r"], [g x])
+let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function
+  | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x)
+  | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x)
+  | _ -> raise Marshal_error
+
+(** More elaborate types *)
+
+let of_edit_id i = Element ("edit_id",["val",string_of_int i],[])
+let to_edit_id = function
+  | Element ("edit_id",["val",i],[]) ->
+      let id = int_of_string i in
+      assert (id <= 0 );
+      id
+  | _ -> raise Marshal_error
+
+let of_loc loc =
+  let start, stop = Loc.unloc loc in
+  Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[])
+let to_loc xml =
+  match xml with
+  | Element ("loc", l,[]) ->
+      (try
+        let start = massoc "start" l in
+        let stop = massoc "stop" l in
+        Loc.make_loc (int_of_string start, int_of_string stop)
+      with Not_found | Invalid_argument _ -> raise Marshal_error)
+  | _ -> raise Marshal_error
+
diff --git a/lib/serialize.mli b/lib/serialize.mli
new file mode 100644
index 00000000..34d3e054
--- /dev/null
+++ b/lib/serialize.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  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 Xml_datatype
+
+exception Marshal_error
+
+val massoc: string -> (string * string) list -> string
+val constructor: string -> string -> xml list -> xml
+val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b
+val singleton: 'a list -> 'a
+val raw_string: xml list -> string
+val of_unit: unit -> xml
+val to_unit: xml -> unit
+val of_bool: bool -> xml
+val to_bool: xml -> bool
+val of_list: ('a -> xml) -> 'a list -> xml
+val to_list: (xml -> 'a) -> xml -> 'a list
+val of_option: ('a -> xml) -> 'a option -> xml
+val to_option: (xml -> 'a) -> xml -> 'a option
+val of_string: string -> xml
+val to_string: xml -> string
+val of_int: int -> xml
+val to_int: xml -> int
+val of_pair: ('a -> xml) -> ('b -> xml) -> 'a * 'b -> xml
+val to_pair: (xml -> 'a) -> (xml -> 'b) -> xml -> 'a * 'b
+val of_union: ('a -> xml) -> ('b -> xml) -> ('a, 'b) CSig.union -> xml
+val to_union: (xml -> 'a) -> (xml -> 'b) -> xml -> ('a, 'b) CSig.union
+val of_edit_id: int -> xml
+val to_edit_id: xml -> int
+val of_loc : Loc.t -> xml
+val to_loc : xml -> Loc.t
diff --git a/lib/spawn.ml b/lib/spawn.ml
new file mode 100644
index 00000000..9b63be70
--- /dev/null
+++ b/lib/spawn.ml
@@ -0,0 +1,258 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+let proto_version = 0
+let prefer_sock = Sys.os_type = "Win32"
+let accept_timeout = 2.0
+
+let pr_err s = Printf.eprintf "(Spawn  ,%d) %s\n%!" (Unix.getpid ()) s
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+type req = ReqDie | ReqStats | Hello of int * int
+type resp = RespStats of Gc.stat
+
+module type Control = sig
+  type handle
+
+  val kill : handle -> unit
+  val stats : handle -> Gc.stat
+  val wait : handle -> Unix.process_status
+  val unixpid : handle -> int
+  val uid : handle -> string
+  val is_alive : handle -> bool
+
+end
+
+module type Empty = sig end
+
+module type MainLoopModel = sig
+  type async_chan
+  type condition
+  type watch_id
+
+  val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+  val remove_watch : watch_id -> unit
+  val read_all : async_chan -> string
+  val async_chan_of_file : Unix.file_descr -> async_chan
+  val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* Common code *)
+let assert_ b s = if not b then Errors.anomaly (Pp.str s)
+
+let mk_socket_channel () =
+  let open Unix in
+  let s = socket PF_INET SOCK_STREAM 0 in
+  bind s (ADDR_INET (inet_addr_loopback,0));
+  listen s 1;
+  match getsockname s with
+  | ADDR_INET(host, port) ->
+      s, string_of_inet_addr host ^":"^ string_of_int port
+  | _ -> assert false
+
+let accept s =
+  let r, _, _ = Unix.select [s] [] [] accept_timeout in
+  if r = [] then raise (Failure (Printf.sprintf
+    "The spawned process did not connect back in %2.1fs" accept_timeout));
+  let cs, _ = Unix.accept s in
+  Unix.close s;
+  let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in
+  set_binary_mode_in cin true;
+  set_binary_mode_out cout true;
+  cs, cin, cout
+
+let handshake cin cout =
+  try
+    output_value cout (Hello (proto_version,Unix.getpid ())); flush cout;
+    match input_value cin with
+    | Hello(v, pid) when v = proto_version ->
+        prerr_endline (Printf.sprintf "Handshake with %d OK" pid);
+        pid
+    | _ -> raise (Failure "handshake protocol")
+  with
+  | Failure s | Invalid_argument s | Sys_error s ->
+      pr_err ("Handshake failed: "  ^ s); raise (Failure "handshake")
+  | End_of_file ->
+      pr_err "Handshake failed: End_of_file"; raise (Failure "handshake")
+
+let spawn_sock env prog args =
+  let main_sock, main_sock_name = mk_socket_channel () in
+  let extra = [| prog; "-main-channel"; main_sock_name |] in
+  let args = Array.append extra args in
+  prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+  let pid =
+    Unix.create_process_env prog args env Unix.stdin Unix.stdout Unix.stderr in
+  if pid = 0 then begin
+    Unix.sleep 1; (* to avoid respawning like crazy *)
+    raise (Failure "create_process failed")
+  end;
+  let cs, cin, cout = accept main_sock in
+  pid, cin, cout, cs
+
+let spawn_pipe env prog args =
+  let master2worker_r,master2worker_w = Unix.pipe () in
+  let worker2master_r,worker2master_w = Unix.pipe () in
+  let extra = [| prog; "-main-channel"; "stdfds" |] in
+  let args = Array.append extra args in
+  Unix.set_close_on_exec master2worker_w;
+  Unix.set_close_on_exec worker2master_r;
+  prerr_endline ("EXEC: " ^ String.concat " " (Array.to_list args));
+  let pid =
+    Unix.create_process_env
+      prog args env master2worker_r worker2master_w Unix.stderr in
+  if pid = 0 then begin
+    Unix.sleep 1; (* to avoid respawning like crazy *)
+    raise (Failure "create_process failed")
+  end;
+  prerr_endline ("PID " ^ string_of_int pid);
+  Unix.close master2worker_r;
+  Unix.close worker2master_w;
+  let cin = Unix.in_channel_of_descr worker2master_r in
+  let cout = Unix.out_channel_of_descr master2worker_w in
+  set_binary_mode_in cin true;
+  set_binary_mode_out cout true;
+  pid, cin, cout, worker2master_r
+
+let filter_args args =
+  let rec aux = function
+    | "-control-channel" :: _ :: rest -> aux rest
+    | "-main-channel" :: _ :: rest -> aux rest
+    | x :: rest -> x :: aux rest
+    | [] -> [] in
+  Array.of_list (aux (Array.to_list args))
+
+let spawn_with_control prefer_sock env prog args =
+  let control_sock, control_sock_name = mk_socket_channel () in
+  let extra = [| "-control-channel"; control_sock_name |] in
+  let args = Array.append extra (filter_args args) in
+  let (pid, cin, cout, s), is_sock =
+    if Sys.os_type <> "Unix" || prefer_sock
+    then spawn_sock env prog args, true
+    else spawn_pipe env prog args, false in
+  let _, oob_resp, oob_req = accept control_sock in
+  pid, oob_resp, oob_req, cin, cout, s, is_sock
+
+let output_death_sentence pid oob_req =
+  prerr_endline ("death sentence for " ^ pid);
+  try output_value oob_req ReqDie; flush oob_req
+  with e -> prerr_endline ("death sentence: " ^ Printexc.to_string e)
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) = struct
+
+type process = {
+  cin  : in_channel;
+  cout : out_channel;
+  oob_resp : in_channel;
+  oob_req  : out_channel;
+  gchan : ML.async_chan;
+  pid : int;
+  mutable watch : ML.watch_id option;
+  mutable alive : bool;
+}
+
+type callback = ML.condition list -> read_all:(unit -> string) -> bool
+type handle = process
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) =
+  p.alive <- false;
+  if not alive then prerr_endline "This process is already dead"
+  else begin try
+    Option.iter ML.remove_watch watch;
+    output_death_sentence (uid p) oob_req;
+    close_in_noerr cin;
+    close_out_noerr cout;
+    if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+    p.watch <- None
+  with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ())
+    prog args callback
+=
+  let pid, oob_resp, oob_req, cin, cout, main, is_sock =
+    spawn_with_control prefer_sock env prog args in
+  Unix.set_nonblock main;
+  let gchan =
+    if is_sock then ML.async_chan_of_socket main
+    else ML.async_chan_of_file main in
+  let alive, watch = true, None in
+  let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in
+  p.watch <- Some (
+    ML.add_watch ~callback:(fun cl ->
+      try
+        let live = callback cl ~read_all:(fun () -> ML.read_all gchan) in
+        if not live then kill p;
+        live
+      with e when Errors.noncritical e ->
+        pr_err ("Async reader raised: " ^ (Printexc.to_string e));
+        kill p;
+        false) gchan
+  );
+  p, cout
+
+let stats { oob_req; oob_resp; alive } =
+  assert_ alive "This process is dead";
+  output_value oob_req ReqStats;
+  flush oob_req;
+  input_value oob_resp
+
+let rec wait p =
+  try snd (Unix.waitpid [] p.pid)
+  with
+  | Unix.Unix_error (Unix.EINTR, _, _) -> wait p
+  | Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
+
+module Sync(T : Empty) = struct
+
+type process = {
+  cin  : in_channel;
+  cout : out_channel;
+  oob_resp : in_channel;
+  oob_req  : out_channel;
+  pid : int;
+  mutable alive : bool;
+}
+
+type handle = process
+
+let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) prog args =
+  let pid, oob_resp, oob_req, cin, cout, _, _ =
+    spawn_with_control prefer_sock env prog args in
+  { cin; cout; pid; oob_resp; oob_req; alive = true }, cin, cout
+
+let is_alive p = p.alive
+let uid { pid; } = string_of_int pid
+let unixpid { pid = pid; } = pid
+
+let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) =
+  p.alive <- false;
+  if not alive then prerr_endline "This process is already dead"
+  else begin try
+    output_death_sentence (uid p) oob_req;
+    close_in_noerr cin;
+    close_out_noerr cout;
+    if Sys.os_type = "Unix" then Unix.kill unixpid 9;
+  with e -> prerr_endline ("kill: "^Printexc.to_string e) end
+
+let stats { oob_req; oob_resp; alive } =
+  assert_ alive "This process is dead";
+  output_value oob_req ReqStats;
+  flush oob_req;
+  let RespStats g = input_value oob_resp in g
+
+let wait { pid = unixpid } =
+  try snd (Unix.waitpid [] unixpid)
+  with Unix.Unix_error _ -> Unix.WEXITED 0o400
+
+end
diff --git a/lib/spawn.mli b/lib/spawn.mli
new file mode 100644
index 00000000..8022573b
--- /dev/null
+++ b/lib/spawn.mli
@@ -0,0 +1,81 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* This module implements spawning/killing managed processes with a
+ * synchronous or asynchronous comunication channel that works with
+ * threads or with a glib like main loop model.
+ *
+ * This module requires no threads and no main loop model.  It takes care
+ * of using the fastest communication channel given the underlying OS and
+ * the requested kind of communication.
+ *
+ * The spawned process must use the Spawned module to init its communication
+ * channels.
+ *)
+
+(* This is the control panel for managed processes *)
+module type Control = sig
+  type handle
+
+  val kill : handle -> unit
+  val stats : handle -> Gc.stat
+  val wait : handle -> Unix.process_status
+  val unixpid : handle -> int
+  
+  (* What is used in debug messages *)
+  val uid : handle -> string
+
+  val is_alive : handle -> bool
+end
+
+(* Abstraction to work with both threads and main loop models *)
+module type Empty = sig end
+
+module type MainLoopModel = sig
+  type async_chan
+  type condition
+  type watch_id
+
+  val add_watch : callback:(condition list -> bool) -> async_chan -> watch_id
+  val remove_watch : watch_id -> unit
+  val read_all : async_chan -> string
+  val async_chan_of_file : Unix.file_descr -> async_chan
+  val async_chan_of_socket : Unix.file_descr -> async_chan
+end
+
+(* spawn a process and read its output asynchronously *)
+module Async(ML : MainLoopModel) : sig
+  type process
+
+  (* If the returned value is false the callback is never called again and
+   * the process is killed *)
+  type callback = ML.condition list -> read_all:(unit -> string) -> bool
+  
+  val spawn :
+    ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+      callback -> process * out_channel
+
+  include Control with type handle = process
+end
+
+(* spawn a process and read its output synchronously *)
+module Sync(T : Empty) : sig
+  type process
+  
+  val spawn :
+    ?prefer_sock:bool -> ?env:string array -> string -> string array ->
+      process * in_channel * out_channel
+
+  include Control with type handle = process
+end
+
+(* This is exported to separate the Spawned module, that for simplicity assumes
+ * Threads so it is in a separate file *)
+type req = ReqDie | ReqStats | Hello of int * int
+val proto_version : int
+type resp = RespStats of Gc.stat
diff --git a/lib/stateid.ml b/lib/stateid.ml
new file mode 100644
index 00000000..59cf206e
--- /dev/null
+++ b/lib/stateid.ml
@@ -0,0 +1,50 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t = int
+let initial = 1
+let dummy = 0
+let fresh, in_range =
+  let cur = ref initial in
+  (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur)
+let to_string = string_of_int
+let of_int id = assert(in_range id); id
+let to_int id = id
+let newer_than id1 id2 = id1 > id2
+
+let of_xml = function
+  | Element ("state_id",["val",i],[]) ->
+      let id = int_of_string i in
+      (* Coqide too to parse ids too, but cannot check if they are valid.
+       * Hence we check for validity only if we are an ide slave. *)
+      if !Flags.ide_slave then assert(in_range id);
+      id
+  | _ -> raise (Invalid_argument "to_state_id")
+let to_xml i = Element ("state_id",["val",string_of_int i],[])
+
+let state_id_info : (t * t) Exninfo.t = Exninfo.make ()
+let add exn ?(valid = initial) id =
+  Exninfo.add exn state_id_info (valid, id)
+let get exn = Exninfo.get exn state_id_info
+
+let equal = Int.equal
+let compare = Int.compare
+
+module Set = Set.Make(struct type t = int let compare = compare end)
+
+type ('a,'b) request = {
+  exn_info : t * t;
+  stop : t;
+  document : 'b;
+  loc : Loc.t;
+  uuid     : 'a;
+  name     : string
+}
+
diff --git a/lib/stateid.mli b/lib/stateid.mli
new file mode 100644
index 00000000..2c12c30c
--- /dev/null
+++ b/lib/stateid.mli
@@ -0,0 +1,45 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Xml_datatype
+
+type t
+
+val equal : t -> t -> bool
+val compare : t -> t -> int
+
+module Set : Set.S with type elt = t
+
+val initial : t
+val dummy : t
+val fresh : unit -> t
+val to_string : t -> string
+val of_int : int -> t
+val to_int : t -> int
+val newer_than : t -> t -> bool
+
+(* XML marshalling *)
+val to_xml : t -> xml
+val of_xml : xml -> t
+
+(* Attaches to an exception the concerned state id, plus an optional
+ * state id that is a valid state id before the error.
+ * Backtracking to the valid id is safe.
+ * The initial_state_id is assumed to be safe. *)
+val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info
+val get : Exninfo.info -> (t * t) option
+
+type ('a,'b) request = {
+  exn_info : t * t;
+  stop : t;
+  document : 'b;
+  loc : Loc.t;
+  uuid     : 'a;
+  name     : string
+}
+
diff --git a/lib/store.ml b/lib/store.ml
index 28eb65c8..a1788f7d 100644
--- a/lib/store.ml
+++ b/lib/store.ml
@@ -6,56 +6,86 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(*** This module implements an "untyped store", in this particular case we
-        see it as an extensible record whose fields are left unspecified. ***)
+(** This module implements an "untyped store", in this particular case
+    we see it as an extensible record whose fields are left
+    unspecified. ***)
 
-(* We give a short implementation of a universal type. This is mostly equivalent
-    to what is proposed by module Dyn.ml, except that it requires no explicit tag. *)
-module type Universal = sig
-  type t
-  
-  type 'a etype = {
-     put : 'a -> t ;
-     get : t -> 'a option
-  }
+(** We use a dynamic "name" allocator. But if we needed to serialise
+    stores, we might want something static to avoid troubles with
+    plugins order. *)
 
-  val embed : unit -> 'a etype
+module type T =
+sig
 end
 
-(* We use a dynamic "name" allocator. But if we needed to serialise stores, we
-might want something static to avoid troubles with plugins order. *)
+module type S =
+sig
+  type t
+  type 'a field
+  val empty : t
+  val set : t -> 'a field -> 'a -> t
+  val get : t -> 'a field -> 'a option
+  val remove : t -> 'a field -> t
+  val merge : t -> t -> t
+  val field : unit -> 'a field
+end
 
-let next =
-  let count = ref 0 in fun () ->
-  let n = !count in
-  incr count;
-  n
+module Make (M : T) : S =
+struct
 
-type t = Obj.t Util.Intmap.t
+  let next =
+    let count = ref 0 in fun () ->
+      let n = !count in
+      incr count;
+      n
 
-module Field = struct
-  type 'a field = {
-    set : 'a -> t -> t ;
-    get : t -> 'a option ;
-    remove : t -> t 
-  }
-  type 'a t = 'a field
-end
+  type t = Obj.t option array
+  (** Store are represented as arrays. For small values, which is typicial,
+      is slightly quicker than other implementations. *)
+
+type 'a field = int
+
+let allocate len : t = Array.make len None
+
+let empty : t = [||]
 
-open Field
-
-let empty = Util.Intmap.empty
-
-let field () =
-  let fid = next () in
-  let set a s =
-    Util.Intmap.add fid (Obj.repr a) s
-  in
-  let get s =
-    try Some (Obj.obj (Util.Intmap.find fid s))
-    with Not_found -> None
-  in
-  let remove s =
-    Util.Intmap.remove fid s
-  in
-  { set = set ; get = get ; remove = remove }
+let set (s : t) (i : 'a field) (v : 'a) : t =
+  let len = Array.length s in
+  let nlen = if i < len then len else succ i in
+  let () = assert (0 <= i) in
+  let ans = allocate nlen in
+  Array.blit s 0 ans 0 len;
+  Array.unsafe_set ans i (Some (Obj.repr v));
+  ans
+
+let get (s : t) (i : 'a field) : 'a option =
+  let len = Array.length s in
+  if len <= i then None
+  else Obj.magic (Array.unsafe_get s i)
+
+let remove (s : t) (i : 'a field) =
+  let len = Array.length s in
+  let () = assert (0 <= i) in
+  let ans = allocate len in
+  Array.blit s 0 ans 0 len;
+  if i < len then Array.unsafe_set ans i None;
+  ans
+
+let merge (s1 : t) (s2 : t) : t =
+  let len1 = Array.length s1 in
+  let len2 = Array.length s2 in
+  let nlen = if len1 < len2 then len2 else len1 in
+  let ans = allocate nlen in
+  (** Important: No more allocation from here. *)
+  Array.blit s2 0 ans 0 len2;
+  for i = 0 to pred len1 do
+    let v = Array.unsafe_get s1 i in
+    match v with
+    | None -> ()
+    | Some _ -> Array.unsafe_set ans i v
+  done;
+  ans
+
+let field () = next ()
+
+end
diff --git a/lib/store.mli b/lib/store.mli
index 5df0c99a..8eab314e 100644
--- a/lib/store.mli
+++ b/lib/store.mli
@@ -9,17 +9,38 @@
 (*** This module implements an "untyped store", in this particular case we
         see it as an extensible record whose fields are left unspecified. ***)
 
-type t
-
-module Field : sig
-  type 'a field = {
-    set : 'a -> t -> t ;
-    get : t -> 'a option ;
-    remove : t -> t 
-  }
-  type 'a t = 'a field
+module type T =
+sig
+(** FIXME: Waiting for first-class modules... *)
 end
 
-val empty : t
+module type S =
+sig
+  type t
+  (** Type of stores *)
 
-val field : unit -> 'a Field.field
+  type 'a field
+  (** Type of field of such stores *)
+
+  val empty : t
+  (** Empty store *)
+
+  val set : t -> 'a field -> 'a -> t
+  (** Set a field *)
+
+  val get : t -> 'a field -> 'a option
+  (** Get the value of a field, if any *)
+
+  val remove : t -> 'a field -> t
+  (** Unset the value of the field *)
+
+  val merge : t -> t -> t
+  (** [merge s1 s2] adds all the fields of [s1] into [s2]. *)
+
+  val field : unit -> 'a field
+  (** Create a new field *)
+
+end
+
+module Make (M : T) : S
+(** Create a new store type. *)
diff --git a/lib/system.ml b/lib/system.ml
index 8f436366..73095f9c 100644
--- a/lib/system.ml
+++ b/lib/system.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        *)
@@ -9,126 +9,10 @@
 (* $Id$ *)
 
 open Pp
+open Errors
 open Util
 open Unix
 
-(* Expanding shell variables and home-directories *)
-
-let safe_getenv_def var def =
-  try
-    Sys.getenv var
-  with Not_found ->
-    warning ("Environment variable "^var^" not found: using '"^def^"' .");
-    flush_all ();
-    def
-
-let getenv_else s dft = try Sys.getenv s with Not_found -> dft
-
-(* On win32, the home directory is probably not in $HOME, but in
-   some other environment variable *)
-
-let home =
-  try Sys.getenv "HOME" with Not_found ->
-    try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
-      try Sys.getenv "USERPROFILE" with Not_found ->
-	warning ("Cannot determine user home directory, using '.' .");
-	flush_all ();
-	Filename.current_dir_name
-
-let safe_getenv n = safe_getenv_def n ("$"^n)
-
-let rec expand_atom s i =
-  let l = String.length s in
-  if i<l && (is_digit s.[i] or is_letter s.[i] or s.[i] = '_')
-  then expand_atom s (i+1)
-  else i
-
-let rec expand_macros s i =
-  let l = String.length s in
-  if i=l then s else
-    match s.[i] with
-      | '$' ->
-	  let n = expand_atom s (i+1) in
-	  let v = safe_getenv (String.sub s (i+1) (n-i-1)) in
-	  let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in
-	  expand_macros s (i + String.length v)
-      | '~' when i = 0 ->
-	  let n = expand_atom s (i+1) in
-	  let v =
-	    if n=i+1 then home
-	    else (getpwnam (String.sub s (i+1) (n-i-1))).pw_dir
-	  in
-	  let s = v^(String.sub s n (l-n)) in
-	  expand_macros s (String.length v)
-      | c -> expand_macros s (i+1)
-
-let expand_path_macros s = expand_macros s 0
-
-(* Files and load path. *)
-
-type physical_path = string
-type load_path = physical_path list
-
-let physical_path_of_string s = s
-let string_of_physical_path p = p
-
-(* 
- * Split a path into a list of directories. A one-liner with Str, but Coq
- * doesn't seem to use this library at all, so here is a slighly longer version.
- *)
-
-let lpath_from_path path path_separator =
-  let n = String.length path in
-  let rec aux i l =
-    if i < n then
-      let j =
-        try String.index_from path i path_separator
-        with Not_found -> n
-      in
-      let dir = String.sub path i (j-i) in
-      aux (j+1) (dir::l)
-    else
-      l
-  in List.rev (aux 0 [])
-
-(* Hints to partially detects if two paths refer to the same repertory *)
-let rec remove_path_dot p =
-  let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *)
-  let n = String.length curdir in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = curdir then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    p
-
-let strip_path p =
-  let cwd = Filename.concat (Sys.getcwd ()) "" in (* Unix: "`pwd`/" *)
-  let n = String.length cwd in
-  let l = String.length p in
-  if l > n && String.sub p 0 n = cwd then
-    let n' =
-      let sl = String.length Filename.dir_sep in
-      let i = ref n in
-	while !i <= l - sl && String.sub p !i sl = Filename.dir_sep do i := !i + sl done; !i in
-    remove_path_dot (String.sub p n' (l - n'))
-  else
-    remove_path_dot p
-
-let canonical_path_name p =
-  let current = Sys.getcwd () in
-  try
-    Sys.chdir p;
-    let p' = Sys.getcwd () in
-    Sys.chdir current;
-    p'
-  with Sys_error _ ->
-    (* We give up to find a canonical name and just simplify it... *)
-    strip_path p
-
 (* All subdirectories, recursively *)
 
 let exists_dir dir =
@@ -139,9 +23,9 @@ let skipped_dirnames = ref ["CVS"; "_darcs"]
 let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames
 
 let ok_dirname f =
-  f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) &&
-  try ignore (check_ident f); true
-  with e when e <> Sys.Break -> false
+  not (String.is_empty f) && f.[0] != '.' &&
+  not (String.List.mem f !skipped_dirnames) &&
+  (match Unicode.ident_refutation f with None -> true | _ -> false)
 
 let all_subdirs ~unix_path:root =
   let l = ref [] in
@@ -154,11 +38,13 @@ let all_subdirs ~unix_path:root =
 	if ok_dirname f then
 	  let file = Filename.concat dir f in
 	  try
-	    if (stat file).st_kind = S_DIR then begin
-	      let newrel = rel@[f] in
+            begin match (stat file).st_kind with
+	    | S_DIR ->
+	      let newrel = rel @ [f] in
 	      add file newrel;
 	      traverse file newrel
-	    end
+            | _ -> ()
+            end
 	  with Unix_error (e,s1,s2) -> ()
       done
     with End_of_file ->
@@ -167,28 +53,43 @@ let all_subdirs ~unix_path:root =
   if exists_dir root then traverse root [];
   List.rev !l
 
+let rec search paths test =
+  match paths with
+  | [] -> []
+  | lpe :: rem -> test lpe @ search rem test
+
 let where_in_path ?(warn=true) path filename =
-  let rec search = function
-    | lpe :: rem ->
-	let f = Filename.concat lpe filename in
-	  if Sys.file_exists f
-	  then (lpe,f) :: search rem
-	  else search rem
-    | [] -> [] in
-  let rec check_and_warn l =
-    match l with
-      | [] -> raise Not_found
-      | (lpe, f) :: l' ->
-	  if warn & l' <> [] then
-	    msg_warning
-	      (str filename ++ str " has been found in" ++ spc () ++
-	       hov 0 (str "[ " ++
-	         hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
-		   (fun (lpe,_) -> str lpe) l)
-	         ++ str " ];") ++ fnl () ++
-	       str "loading " ++ str f);
-	  (lpe, f) in
-  check_and_warn (search path)
+  let check_and_warn l = match l with
+  | [] -> raise Not_found
+  | (lpe, f) :: l' ->
+    let () = match l' with
+    | _ :: _ when warn ->
+      msg_warning
+        (str filename ++ str " has been found in" ++ spc () ++
+          hov 0 (str "[ " ++
+            hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon())
+              (fun (lpe,_) -> str lpe) l)
+            ++ str " ];") ++ fnl () ++
+          str "loading " ++ str f)
+    | _ -> ()
+    in
+    (lpe, f)
+  in
+  check_and_warn (search path (fun lpe ->
+    let f = Filename.concat lpe filename in
+    if Sys.file_exists f then [lpe,f] else []))
+
+let where_in_path_rex path rex =
+  search path (fun lpe ->
+    try
+      let files = Sys.readdir lpe in
+      CList.map_filter (fun name ->
+        try
+          ignore(Str.search_forward rex name 0);
+          Some (lpe,Filename.concat lpe name)
+        with Not_found -> None)
+      (Array.to_list files)
+    with Sys_error _ -> [])
 
 let find_file_in_path ?(warn=true) paths filename =
   if not (Filename.is_implicit filename) then
@@ -209,56 +110,87 @@ let is_in_path lpath filename =
   try ignore (where_in_path ~warn:false lpath filename); true
   with Not_found -> false
 
-let path_separator = if Sys.os_type = "Unix" then ':' else ';'
-
 let is_in_system_path filename =
-  let path = try Sys.getenv "PATH" 
+  let path = try Sys.getenv "PATH"
              with Not_found -> error "system variable PATH not found" in
-  let lpath = lpath_from_path path path_separator in
+  let lpath = CUnix.path_to_list path in
   is_in_path lpath filename
 
-let make_suffix name suffix =
-  if Filename.check_suffix name suffix then name else (name ^ suffix)
-
-let file_readable_p name =
-  try access name [R_OK];true with Unix_error (_, _, _) -> false
-
 let open_trapping_failure name =
   try open_out_bin name
-  with e when e <> Sys.Break -> error ("Can't open " ^ name)
+  with e when Errors.noncritical e -> error ("Can't open " ^ name)
 
 let try_remove filename =
   try Sys.remove filename
-  with e when e <> Sys.Break ->
-    msgnl (str"Warning: " ++ str"Could not remove file " ++
-             str filename ++ str" which is corrupted!" )
+  with e when Errors.noncritical e ->
+    msg_warning
+      (str"Could not remove file " ++ str filename ++ str" which is corrupted!")
 
-let marshal_out ch v = Marshal.to_channel ch v []
+let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.")
+
+let input_binary_int f ch =
+  try input_binary_int ch
+  with
+  | End_of_file -> error_corrupted f "premature end of file"
+  | Failure s -> error_corrupted f s
+let output_binary_int ch x = output_binary_int ch x; flush ch
+
+let marshal_out ch v = Marshal.to_channel ch v []; flush ch
 let marshal_in filename ch =
   try Marshal.from_channel ch
   with
-    | End_of_file -> error "corrupted file: reached end of file"
-    | Failure _ (* e.g. "truncated object" *) ->
-        error (filename ^ " is corrupted, try to rebuild it.")
+  | End_of_file -> error_corrupted filename "premature end of file"
+  | Failure s -> error_corrupted filename s
+
+let digest_out = Digest.output
+let digest_in filename ch =
+  try Digest.input ch
+  with
+  | End_of_file -> error_corrupted filename "premature end of file"
+  | Failure s -> error_corrupted filename s
+
+let marshal_out_segment f ch v =
+  let start = pos_out ch in
+  output_binary_int ch 0;  (* dummy value for stop *)
+  marshal_out ch v;
+  let stop = pos_out ch in
+  seek_out ch start;
+  output_binary_int ch stop;
+  seek_out ch stop;
+  digest_out ch (Digest.file f)
+
+let marshal_in_segment f ch =
+  let stop = (input_binary_int f ch : int) in
+  let v = marshal_in f ch in
+  let digest = digest_in f ch in
+  v, stop, digest
+
+let skip_in_segment f ch =
+  let stop = (input_binary_int f ch : int) in
+  seek_in ch stop;
+  stop, digest_in f ch
 
 exception Bad_magic_number of string
 
-let raw_extern_intern magic suffix =
-  let extern_state name =
-    let filename = make_suffix name suffix in
+let raw_extern_intern magic =
+  let extern_state filename =
     let channel = open_trapping_failure filename in
     output_binary_int channel magic;
-    filename,channel
+    filename, channel
   and intern_state filename =
-    let channel = open_in_bin filename in
-    if input_binary_int channel <> magic then
-      raise (Bad_magic_number filename);
-    channel
+    try
+      let channel = open_in_bin filename in
+      if not (Int.equal (input_binary_int filename channel) magic) then
+        raise (Bad_magic_number filename);
+      channel
+    with
+    | End_of_file -> error_corrupted filename "premature end of file"
+    | Failure s | Sys_error s -> error_corrupted filename s
   in
   (extern_state,intern_state)
 
-let extern_intern ?(warn=true) magic suffix =
-  let (raw_extern,raw_intern) = raw_extern_intern magic suffix in
+let extern_intern ?(warn=true) magic =
+  let (raw_extern,raw_intern) = raw_extern_intern magic in
   let extern_state name val_0 =
     try
       let (filename,channel) = raw_extern name in
@@ -266,11 +198,13 @@ let extern_intern ?(warn=true) magic suffix =
         marshal_out channel val_0;
         close_out channel
       with reraise ->
-	begin try_remove filename; raise reraise end
+	let reraise = Errors.push reraise in
+        let () = try_remove filename in
+        iraise reraise
     with Sys_error s -> error ("System error: " ^ s)
   and intern_state paths name =
     try
-      let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in
+      let _,filename = find_file_in_path ~warn paths name in
       let channel = raw_intern filename in
       let v = marshal_in filename channel in
       close_in channel;
@@ -284,79 +218,47 @@ let with_magic_number_check f a =
   try f a
   with Bad_magic_number fname ->
     errorlabstrm "with_magic_number_check"
-    (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++ 
+    (str"File " ++ str fname ++ strbrk" has bad magic number." ++ spc () ++
     strbrk "It is corrupted or was compiled with another version of Coq.")
 
-(* Communication through files with another executable *)
-
-let connect writefun readfun com =
-  let name = Filename.basename com in
-  let tmp_to = Filename.temp_file ("coq-"^name^"-in") ".xml" in
-  let tmp_from = Filename.temp_file ("coq-"^name^"-out") ".xml" in
-  let ch_to_in,ch_to_out =
-    try open_in tmp_to, open_out tmp_to
-    with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in
-  let ch_from_in,ch_from_out =
-    try open_in tmp_from, open_out tmp_from
-    with Sys_error s ->
-      close_out ch_to_out; close_in ch_to_in;
-      error ("Cannot set connection from "^com^"("^s^")") in
-  writefun ch_to_out;
-  close_out ch_to_out;
-  let pid =
-    let ch_to' = Unix.descr_of_in_channel ch_to_in in
-    let ch_from' = Unix.descr_of_out_channel ch_from_out in
-    try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout
-    with Unix.Unix_error (err,_,_) ->
-      close_in ch_to_in; close_in ch_from_in; close_out ch_from_out;
-      unlink tmp_from; unlink tmp_to;
-      error ("Cannot execute "^com^"("^(Unix.error_message err)^")") in
-  close_in ch_to_in;
-  close_out ch_from_out;
-  (match snd (Unix.waitpid [] pid) with
-    | Unix.WEXITED 127 -> error (com^": cannot execute")
-    | Unix.WEXITED 0 -> ()
-    | _ -> error (com^" exited abnormally"));
-  let a = readfun ch_from_in in
-  close_in ch_from_in;
-  unlink tmp_from;
-  unlink tmp_to;
-  a
-
-let run_command converter f c =
-  let result = Buffer.create 127 in
-  let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
-  let buff = String.make 127 ' ' in
-  let buffe = String.make 127 ' ' in
-  let n = ref 0 in
-  let ne = ref 0 in
-
-  while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ;
-    !n+ !ne <> 0
-  do
-    let r = converter (String.sub buff 0 !n) in
-    f r;
-    Buffer.add_string result r;
-    let r = converter (String.sub buffe 0 !ne) in
-    f r;
-    Buffer.add_string result r
-  done;
-  (Unix.close_process_full (cin,cout,cerr),  Buffer.contents result)
-
 (* Time stamps. *)
 
 type time = float * float * float
 
 let get_time () =
-  let t = times ()  in
-  (time(), t.tms_utime, t.tms_stime)
+  let t = Unix.times ()  in
+  (Unix.gettimeofday(), t.tms_utime, t.tms_stime)
 
-let time_difference (t1,_,_) (t2,_,_) = t2 -. t1
+(* Keep only 3 significant digits *)
+let round f = (floor (f *. 1e3)) *. 1e-3
+
+let time_difference (t1,_,_) (t2,_,_) = round (t2 -. t1)
 
 let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) =
-  real (stopreal -. startreal) ++ str " secs " ++
+  real (round (stopreal -. startreal)) ++ str " secs " ++
   str "(" ++
-  real ((-.) ustop ustart) ++ str "u" ++
+  real (round (ustop -. ustart)) ++ str "u" ++
   str "," ++
-  real ((-.) sstop sstart) ++ str "s" ++
+  real (round (sstop -. sstart)) ++ str "s" ++
   str ")"
+
+let with_time time f x =
+  let tstart = get_time() in
+  let msg = if time then "" else "Finished transaction in " in
+  try
+    let y = f x in
+    let tend = get_time() in
+    let msg2 = if time then "" else " (successful)" in
+    msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+    y
+  with e ->
+    let tend = get_time() in
+    let msg = if time then "" else "Finished failing transaction in " in
+    let msg2 = if time then "" else " (failure)" in
+    msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2);
+    raise e
+
+let process_id () =
+  if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id
+  else Printf.sprintf "master:%d" (Thread.id (Thread.self ()))
+    
diff --git a/lib/system.mli b/lib/system.mli
index b56e65a4..a3d66d57 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** System utilities *)
+(** {5 Coqtop specific system utilities} *)
 
 (** {6 Files and load paths} *)
 
@@ -14,63 +14,50 @@
     given by the user. For efficiency, we keep the full path (field
     [directory]), the root path and the path relative to the root. *)
 
-type physical_path = string
-type load_path = physical_path list
-
-val canonical_path_name : string -> string
-
 val exclude_search_in_dirname : string -> unit
 
-val all_subdirs : unix_path:string -> (physical_path * string list) list
-val is_in_path : load_path -> string -> bool
+val all_subdirs : unix_path:string -> (CUnix.physical_path * string list) list
+val is_in_path : CUnix.load_path -> string -> bool
 val is_in_system_path : string -> bool
-val where_in_path : ?warn:bool -> load_path -> string -> physical_path * string
-
-val physical_path_of_string : string -> physical_path
-val string_of_physical_path : physical_path -> string
-
-val make_suffix : string -> string -> string
-val file_readable_p : string -> bool
-
-val expand_path_macros : string -> string
-val getenv_else : string -> string -> string
-val home : string
+val where_in_path :
+  ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
+val where_in_path_rex :
+  CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list
 
 val exists_dir : string -> bool
 
 val find_file_in_path :
-  ?warn:bool -> load_path -> string -> physical_path * string
+  ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string
 
 (** {6 I/O functions } *)
 (** Generic input and output functions, parameterized by a magic number
   and a suffix. The intern functions raise the exception [Bad_magic_number]
   when the check fails, with the full file name. *)
 
-val marshal_out : out_channel -> 'a -> unit
-val marshal_in : string -> in_channel -> 'a
-
 exception Bad_magic_number of string
 
-val raw_extern_intern : int -> string ->
+val raw_extern_intern : int ->
   (string -> string * out_channel) * (string -> in_channel)
 
-val extern_intern : ?warn:bool -> int -> string ->
-  (string -> 'a -> unit) * (load_path -> string -> 'a)
+val extern_intern : ?warn:bool -> int ->
+  (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a)
 
 val with_magic_number_check : ('a -> 'b) -> 'a -> 'b
 
-(** {6 Sending/receiving once with external executable } *)
+(** Clones of Marshal.to_channel (with flush) and
+    Marshal.from_channel (with nice error message) *)
+
+val marshal_out : out_channel -> 'a -> unit
+val marshal_in : string -> in_channel -> 'a
 
-val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a
+(** Clones of Digest.output and Digest.input (with nice error message) *)
 
-(** {6 Executing commands } *)
-(** [run_command converter f com] launches command [com], and returns
-    the contents of stdout and stderr that have been processed with
-    [converter]; the processed contents of stdout and stderr is also
-    passed to [f] *)
+val digest_out : out_channel -> Digest.t -> unit
+val digest_in : string -> in_channel -> Digest.t
 
-val run_command : (string -> string) -> (string -> unit) -> string ->
-  Unix.process_status * string
+val marshal_out_segment : string -> out_channel -> 'a -> unit
+val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t
+val skip_in_segment : string -> in_channel -> int * Digest.t
 
 (** {6 Time stamps.} *)
 
@@ -79,3 +66,8 @@ type time
 val get_time : unit -> time
 val time_difference : time -> time -> float (** in seconds *)
 val fmt_time_difference : time -> time -> Pp.std_ppcmds
+
+val with_time : bool -> ('a -> 'b) -> 'a -> 'b
+
+(** {6 Name of current process.} *)
+val process_id : unit -> string
diff --git a/lib/terminal.ml b/lib/terminal.ml
new file mode 100644
index 00000000..1e6c2557
--- /dev/null
+++ b/lib/terminal.ml
@@ -0,0 +1,284 @@
+(************************************************************************)
+(*  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 color = [
+  `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+  fg_color : color option;
+  bg_color : color option;
+  bold : bool option;
+  italic : bool option;
+  underline : bool option;
+  negative : bool option;
+}
+
+let set o1 o2 = match o1 with
+| None -> o2
+| Some _ ->
+  match o2 with
+  | None -> o1
+  | Some _ -> o2
+
+let default = {
+  fg_color = None;
+  bg_color = None;
+  bold = None;
+  italic = None;
+  underline = None;
+  negative = None;
+}
+
+let make ?fg_color ?bg_color ?bold ?italic ?underline ?negative ?style () =
+  let st = match style with
+  | None -> default
+  | Some st -> st
+  in
+  {
+    fg_color = set st.fg_color fg_color;
+    bg_color = set st.bg_color bg_color;
+    bold = set st.bold bold;
+    italic = set st.italic italic;
+    underline = set st.underline underline;
+    negative = set st.negative negative;
+  }
+
+let merge s1 s2 =
+  {
+    fg_color = set s1.fg_color s2.fg_color;
+    bg_color = set s1.bg_color s2.bg_color;
+    bold = set s1.bold s2.bold;
+    italic = set s1.italic s2.italic;
+    underline = set s1.underline s2.underline;
+    negative = set s1.negative s2.negative;
+  }
+
+let base_color = function
+| `DEFAULT -> 9
+| `BLACK -> 0
+| `RED -> 1
+| `GREEN -> 2
+| `YELLOW -> 3
+| `BLUE -> 4
+| `MAGENTA -> 5
+| `CYAN -> 6
+| `WHITE -> 7
+| `LIGHT_BLACK -> 0
+| `LIGHT_RED -> 1
+| `LIGHT_GREEN -> 2
+| `LIGHT_YELLOW -> 3
+| `LIGHT_BLUE -> 4
+| `LIGHT_MAGENTA -> 5
+| `LIGHT_CYAN -> 6
+| `LIGHT_WHITE -> 7
+| _ -> invalid_arg "base_color"
+
+let extended_color off = function
+| `INDEX i -> [off + 8; 5; i]
+| `RGB (r, g, b) -> [off + 8; 2; r; g; b]
+| _ -> invalid_arg "extended_color"
+
+let is_light = function
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE -> true
+| _ -> false
+
+let is_extended = function
+| `INDEX _ | `RGB _ -> true
+| _ -> false
+
+let eval st =
+  let fg = match st.fg_color with
+  | None -> []
+  | Some c ->
+    if is_light c then [90 + base_color c]
+    else if is_extended c then extended_color 30 c
+    else [30 + base_color c]
+  in
+  let bg = match st.bg_color with
+  | None -> []
+  | Some c ->
+    if is_light c then [100 + base_color c]
+    else if is_extended c then extended_color 40 c
+    else [40 + base_color c]
+  in
+  let bold = match st.bold with
+  | None -> []
+  | Some true -> [1]
+  | Some false -> [22]
+  in
+  let italic = match st.italic with
+  | None -> []
+  | Some true -> [3]
+  | Some false -> [23]
+  in
+  let underline = match st.underline with
+  | None -> []
+  | Some true -> [4]
+  | Some false -> [24]
+  in
+  let negative = match st.negative with
+  | None -> []
+  | Some true -> [7]
+  | Some false -> [27]
+  in
+  let tags = fg @ bg @ bold @ italic @ underline @ negative in
+  let tags = List.map string_of_int tags in
+  Printf.sprintf "\027[%sm" (String.concat ";" tags)
+
+let reset = "\027[0m"
+
+let reset_style = {
+  fg_color = Some `DEFAULT;
+  bg_color = Some `DEFAULT;
+  bold = Some false;
+  italic = Some false;
+  underline = Some false;
+  negative = Some false;
+}
+
+let has_style t = Unix.isatty t
+
+let split c s =
+  let len = String.length s in
+  let rec split n =
+    try
+      let pos = String.index_from s n c in
+      let dir = String.sub s n (pos-n) in
+      dir :: split (succ pos)
+    with
+      | Not_found -> [String.sub s n (len-n)]
+  in
+  if len = 0 then [] else split 0
+
+let check_char i = if i < 0 || i > 255 then invalid_arg "check_char"
+
+let parse_color off rem = match off with
+| 0 -> (`BLACK, rem)
+| 1 -> (`RED, rem)
+| 2 -> (`GREEN, rem)
+| 3 -> (`YELLOW, rem)
+| 4 -> (`BLUE, rem)
+| 5 -> (`MAGENTA, rem)
+| 6 -> (`CYAN, rem)
+| 7 -> (`WHITE, rem)
+| 9 -> (`DEFAULT, rem)
+| 8 ->
+  begin match rem with
+  | 5 :: i :: rem ->
+    check_char i;
+    (`INDEX i, rem)
+  | 2 :: r :: g :: b :: rem ->
+    check_char r;
+    check_char g;
+    check_char b;
+    (`RGB (r, g, b), rem)
+  | _ -> invalid_arg "parse_color"
+  end
+| _ -> invalid_arg "parse_color"
+
+let set_light = function
+| `BLACK -> `LIGHT_BLACK
+| `RED -> `LIGHT_RED
+| `GREEN -> `LIGHT_GREEN
+| `YELLOW -> `LIGHT_YELLOW
+| `BLUE -> `LIGHT_BLUE
+| `MAGENTA -> `LIGHT_MAGENTA
+| `CYAN -> `LIGHT_CYAN
+| `WHITE -> `LIGHT_WHITE
+| _ -> invalid_arg "parse_color"
+
+let rec parse_style style = function
+| [] -> style
+| 0 :: rem ->
+  let style = merge style reset_style in
+  parse_style style rem
+| 1 :: rem ->
+  let style = make ~style ~bold:true () in
+  parse_style style rem
+| 3 :: rem ->
+  let style = make ~style ~italic:true () in
+  parse_style style rem
+| 4 :: rem ->
+  let style = make ~style ~underline:true () in
+  parse_style style rem
+| 7 :: rem ->
+  let style = make ~style ~negative:true () in
+  parse_style style rem
+| 22 :: rem ->
+  let style = make ~style ~bold:false () in
+  parse_style style rem
+| 23 :: rem ->
+  let style = make ~style ~italic:false () in
+  parse_style style rem
+| 24 :: rem ->
+  let style = make ~style ~underline:false () in
+  parse_style style rem
+| 27 :: rem ->
+  let style = make ~style ~negative:false () in
+  parse_style style rem
+| code :: rem when (30 <= code && code < 40) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~fg_color:color () in
+  parse_style style rem
+| code :: rem when (40 <= code && code < 50) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~bg_color:color () in
+  parse_style style rem
+| code :: rem when (90 <= code && code < 100) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~fg_color:(set_light color) () in
+  parse_style style rem
+| code :: rem when (100 <= code && code < 110) ->
+  let color, rem = parse_color (code mod 10) rem in
+  let style = make ~style ~bg_color:(set_light color) () in
+  parse_style style rem
+| _ :: rem -> parse_style style rem
+
+(** Parse LS_COLORS-like strings *)
+let parse s =
+  let defs = split ':' s in
+  let fold accu s = match split '=' s with
+  | [name; attrs] ->
+    let attrs = split ';' attrs in
+    let accu =
+      try
+        let attrs = List.map int_of_string attrs in
+        let attrs = parse_style (make ()) attrs in
+        (name, attrs) :: accu
+      with _ -> accu
+    in
+    accu
+  | _ -> accu
+  in
+  List.fold_left fold [] defs
diff --git a/lib/terminal.mli b/lib/terminal.mli
new file mode 100644
index 00000000..f308ede3
--- /dev/null
+++ b/lib/terminal.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  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 color = [
+  `DEFAULT
+| `BLACK
+| `RED
+| `GREEN
+| `YELLOW
+| `BLUE
+| `MAGENTA
+| `CYAN
+| `WHITE
+| `LIGHT_BLACK
+| `LIGHT_RED
+| `LIGHT_GREEN
+| `LIGHT_YELLOW
+| `LIGHT_BLUE
+| `LIGHT_MAGENTA
+| `LIGHT_CYAN
+| `LIGHT_WHITE
+| `INDEX of int
+| `RGB of (int * int * int)
+]
+
+type style = {
+  fg_color : color option;
+  bg_color : color option;
+  bold : bool option;
+  italic : bool option;
+  underline : bool option;
+  negative : bool option;
+}
+
+val make : ?fg_color:color -> ?bg_color:color ->
+  ?bold:bool -> ?italic:bool -> ?underline:bool ->
+  ?negative:bool -> ?style:style -> unit -> style
+(** Create a style from the given flags. It is derived from the optional
+    [style] argument if given. *)
+
+val merge : style -> style -> style
+(** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *)
+
+val eval : style -> string
+(** Generate an escape sequence from a style. *)
+
+val reset : string
+(** This escape sequence resets all attributes. *)
+
+val has_style : Unix.file_descr -> bool
+(** Whether an output file descriptor handles styles. Very heuristic, only
+    checks it is a terminal. *)
+
+val parse : string -> (string * style) list
+(** Parse strings describing terminal styles in the LS_COLORS syntax. For
+    robustness, ignore meaningless entries and drops undefined styles. *)
diff --git a/lib/trie.ml b/lib/trie.ml
new file mode 100644
index 00000000..e369e6ad
--- /dev/null
+++ b/lib/trie.ml
@@ -0,0 +1,89 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type S =
+sig
+  type label
+  type data
+  type t
+  val empty : t
+  val get : t -> data
+  val next : t -> label -> t
+  val labels : t -> label list
+  val add : label list -> data -> t -> t
+  val remove : label list -> data -> t -> t
+  val iter : (label list -> data -> unit) -> t -> unit
+end
+
+module type Grp =
+sig
+  type t
+  val nil : t
+  val is_nil : t -> bool
+  val add : t -> t -> t
+  val sub : t -> t -> t
+end
+
+module Make (Y : Map.OrderedType) (X : Grp) =
+struct
+
+module T_codom = Map.Make(Y)
+
+type data = X.t
+type label = Y.t
+type t = Node of X.t * t T_codom.t
+
+let codom_for_all f m =
+  let fold key v accu = f v && accu in
+  T_codom.fold fold m true
+
+let empty = Node (X.nil, T_codom.empty)
+
+let next (Node (_,m)) lbl = T_codom.find lbl m
+
+let get (Node (hereset,_)) = hereset
+
+let labels (Node (_,m)) =
+  (** FIXME: this is order-dependent. Try to find a more robust presentation? *)
+  List.rev (T_codom.fold (fun x _ acc -> x::acc) m [])
+
+let is_empty_node (Node(a,b)) = (X.is_nil a) && (T_codom.is_empty b)
+
+let assure_arc m lbl =
+  if T_codom.mem lbl m then
+    m
+  else
+    T_codom.add lbl (Node (X.nil,T_codom.empty)) m
+
+let cleanse_arcs (Node (hereset,m)) =
+  let m = if codom_for_all is_empty_node m then T_codom.empty else m in
+  Node(hereset, m)
+
+let rec at_path f (Node (hereset,m)) = function
+  | [] ->
+      cleanse_arcs (Node(f hereset,m))
+  | h::t ->
+      let m = assure_arc m h in
+      cleanse_arcs (Node(hereset,
+                         T_codom.add h (at_path f (T_codom.find h m) t) m))
+
+let add path v tm =
+  at_path (fun hereset -> X.add v hereset) tm path
+
+let remove path v tm =
+  at_path (fun hereset -> X.sub hereset v) tm path
+
+let iter f tlm =
+  let rec apprec pfx (Node(hereset,m)) =
+    let path = List.rev pfx in
+    f path hereset;
+    T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
+  in
+  apprec [] tlm
+
+end
diff --git a/lib/trie.mli b/lib/trie.mli
new file mode 100644
index 00000000..81847485
--- /dev/null
+++ b/lib/trie.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Generic functorized trie data structure. *)
+
+module type S =
+sig
+  (** A trie is a generalization of the map data structure where the keys are
+      themselves lists. *)
+
+  type label
+  (** Keys of the trie structure are [label list]. *)
+
+  type data
+  (** Data on nodes of tries are finite sets of [data]. *)
+
+  type t
+  (** The trie data structure. Essentially a finite map with keys [label list]
+      and content [data Set.t]. *)
+
+  val empty : t
+  (** The empty trie. *)
+
+  val get : t -> data
+  (** Get the data at the current node. *)
+
+  val next : t -> label -> t
+  (** [next t lbl] returns the subtrie of [t] pointed by [lbl].
+      @raise Not_found if there is none. *)
+
+  val labels : t -> label list
+  (** Get the list of defined labels at the current node. *)
+
+  val add : label list -> data -> t -> t
+  (** [add t path v] adds [v] at path [path] in [t]. *)
+
+  val remove : label list -> data -> t -> t
+  (** [remove t path v] removes [v] from path [path] in [t]. *)
+
+  val iter : (label list -> data -> unit) -> t -> unit
+  (** Apply a function to all contents. *)
+
+end
+
+module type Grp =
+sig
+  type t
+  val nil : t
+  val is_nil : t -> bool
+  val add : t -> t -> t
+  val sub : t -> t -> t
+end
+
+module Make (Label : Set.OrderedType) (Data : Grp) : S
+  with type label = Label.t and type data = Data.t
+(** Generating functor, for a given type of labels and data. *)
diff --git a/lib/tries.ml b/lib/tries.ml
deleted file mode 100644
index 60b466b7..00000000
--- a/lib/tries.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-
-
-module Make = 
-  functor (X : Set.OrderedType) ->
-    functor (Y : Map.OrderedType) ->
-struct
-  module T_dom = Fset.Make(X) 
-  module T_codom = Fmap.Make(Y) 
-
-  type t = Node of T_dom.t * t T_codom.t
-
-  let codom_to_list m = T_codom.fold (fun x y l -> (x,y)::l) m []
-
-  let codom_rng m = T_codom.fold (fun _ y acc -> y::acc) m []
-
-  let codom_dom m = T_codom.fold (fun x _ acc -> x::acc) m []
-
-  let empty = Node (T_dom.empty, T_codom.empty)
-
-  let map (Node (_,m)) lbl = T_codom.find lbl m
-
-  let xtract (Node (hereset,_)) = T_dom.elements hereset
-    
-  let dom (Node (_,m)) = codom_dom m
-
-  let in_dom (Node (_,m)) lbl = T_codom.mem lbl m
-
-  let is_empty_node (Node(a,b)) = (T_dom.elements a = []) & (codom_to_list b = [])
-
-let assure_arc m lbl =
-  if T_codom.mem lbl m then 
-    m
-  else 
-    T_codom.add lbl (Node (T_dom.empty,T_codom.empty)) m
-
-let cleanse_arcs (Node (hereset,m)) =
-  let l = codom_rng m in 
-  Node(hereset, if List.for_all is_empty_node l then T_codom.empty else m)
-
-let rec at_path f (Node (hereset,m)) = function
-  | [] -> 
-      cleanse_arcs (Node(f hereset,m))
-  | h::t ->
-      let m = assure_arc m h in 
-      cleanse_arcs (Node(hereset,
-                         T_codom.add h (at_path f (T_codom.find h m) t) m))
-
-let add tm (path,v) =
-  at_path (fun hereset -> T_dom.add v hereset) tm path
-    
-let rmv tm (path,v) =
-  at_path (fun hereset -> T_dom.remove v hereset) tm path
-
-let app f tlm = 
-  let rec apprec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
-    T_dom.iter (fun v -> f(path,v)) hereset;
-    T_codom.iter (fun l tm -> apprec (l::pfx) tm) m
-  in 
-  apprec [] tlm
-    
-let to_list tlm = 
-  let rec torec pfx (Node(hereset,m)) =
-    let path = List.rev pfx in 
-    List.flatten((List.map (fun v -> (path,v)) (T_dom.elements hereset))::
-		 (List.map (fun (l,tm) -> torec (l::pfx) tm) (codom_to_list m)))
-  in 
-  torec [] tlm
-
-end
diff --git a/lib/tries.mli b/lib/tries.mli
deleted file mode 100644
index 8e837677..00000000
--- a/lib/tries.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-
-
-
-
-
-module Make :
-  functor (X : Set.OrderedType) ->
-    functor (Y : Map.OrderedType) ->
-sig
-     
-  type t 
-    
-  val empty : t
-      
-  (** Work on labels, not on paths. *)
-
-  val map : t -> Y.t -> t
-
-  val xtract : t -> X.t list
-    
-  val dom : t -> Y.t list
-
-  val in_dom : t -> Y.t -> bool
-
-  (** Work on paths, not on labels. *)
-
-  val add : t -> Y.t list * X.t -> t
-  
-  val rmv : t -> Y.t list * X.t -> t 
-
-  val app : ((Y.t list * X.t) -> unit) -> t -> unit
-    
-  val to_list : t -> (Y.t list * X.t) list
-end
diff --git a/lib/unicode.ml b/lib/unicode.ml
new file mode 100644
index 00000000..1765e93d
--- /dev/null
+++ b/lib/unicode.ml
@@ -0,0 +1,241 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(* The following table stores classes of Unicode characters that
+   are used by the lexer. There are 3 different classes so 2 bits are
+   allocated for each character. We only use 16 bits over the 31 bits
+   to simplify the masking process. (This choice seems to be a good
+   trade-off between speed and space after some benchmarks.) *)
+
+(* A 256ko table, initially filled with zeros. *)
+let table = Array.make (1 lsl 17) 0
+
+(* Associate a 2-bit pattern to each status at position [i].
+   Only the 3 lowest bits of [i] are taken into account to
+   define the position of the pattern in the word.
+   Notice that pattern "00" means "undefined". *)
+let mask i = function
+  | Letter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
+  | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
+  | Symbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
+
+(* Helper to reset 2 bits in a word. *)
+let reset_mask i =
+  lnot (3 lsl ((i land 7) lsl 1))
+
+(* Initialize the lookup table from a list of segments, assigning
+   a status to every character of each segment. The order of these
+   assignments is relevant: it is possible to assign status [s] to
+   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
+   between [c1] and [c2]. *)
+let mk_lookup_table_from_unicode_tables_for status tables =
+  List.iter
+    (List.iter
+       (fun (c1, c2) ->
+          for i = c1 to c2 do
+            table.(i lsr 3) <-
+              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
+          done))
+    tables
+
+(* Look up into the table and interpret the found pattern. *)
+let lookup x =
+  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
+    if      v = 1 then Letter
+    else if v = 2 then IdentPart
+    else if v = 3 then Symbol
+    else raise Unsupported
+
+(* [classify] discriminates between 3 different kinds of
+   symbols based on the standard unicode classification (extracted from
+   Camomile). *)
+let classify =
+  let single c = [ (c, c) ] in
+    (* General tables. *)
+    mk_lookup_table_from_unicode_tables_for Symbol
+      [
+        Unicodetable.sm;           (* Symbol, maths.                    *)
+        Unicodetable.sc;           (* Symbol, currency.                 *)
+        Unicodetable.so;           (* Symbol, modifier.                 *)
+        Unicodetable.pd;           (* Punctation, dash.                 *)
+        Unicodetable.pc;           (* Punctation, connector.            *)
+        Unicodetable.pe;           (* Punctation, open.                 *)
+        Unicodetable.ps;           (* Punctation, close.                *)
+        Unicodetable.pi;           (* Punctation, initial quote.        *)
+        Unicodetable.pf;           (* Punctation, final quote.          *)
+        Unicodetable.po;           (* Punctation, other.                *)
+      ];
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        Unicodetable.lu;           (* Letter, uppercase.                *)
+        Unicodetable.ll;           (* Letter, lowercase.                *)
+        Unicodetable.lt;           (* Letter, titlecase.                *)
+        Unicodetable.lo;           (* Letter, others.                   *)
+      ];
+    mk_lookup_table_from_unicode_tables_for IdentPart
+      [
+        Unicodetable.nd;           (* Number, decimal digits.           *)
+        Unicodetable.nl;           (* Number, letter.                   *)
+        Unicodetable.no;           (* Number, other.                    *)
+      ];
+
+    (* Workaround. Some characters seems to be missing in
+       Camomile's category tables. We add them manually. *)
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        [(0x01D00, 0x01D7F)];      (* Phonetic Extensions.              *)
+        [(0x01D80, 0x01DBF)];      (* Phonetic Extensions Suppl.        *)
+        [(0x01DC0, 0x01DFF)];      (* Combining Diacritical Marks Suppl.*)
+      ];
+
+    (* Exceptions (from a previous version of this function).           *)
+    mk_lookup_table_from_unicode_tables_for Symbol
+      [
+        [(0x000B2, 0x000B3)];      (* Superscript 2-3.                  *)
+        single 0x000B9;            (* Superscript 1.                    *)
+        single 0x02070;            (* Superscript 0.                    *)
+        [(0x02074, 0x02079)];      (* Superscript 4-9.                  *)
+        single 0x0002E;            (* Dot.                              *)
+      ];
+    mk_lookup_table_from_unicode_tables_for Letter
+      [
+        single 0x005F;             (* Underscore.                       *)
+        single 0x00A0;             (* Non breaking space.               *)
+      ];
+    mk_lookup_table_from_unicode_tables_for IdentPart
+      [
+        single 0x0027;             (* Special space.                    *)
+      ];
+    (* Lookup *)
+    lookup
+
+exception End_of_input
+
+let utf8_of_unicode n =
+  if n < 128 then
+    String.make 1 (Char.chr n)
+  else if n < 2048 then
+    let s = String.make 2 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[0] <- Char.chr (192 + n / 64);
+      s
+    end
+  else if n < 65536 then
+    let s = String.make 3 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[1] <- Char.chr (128 + (n / 64) mod 64);
+      s.[0] <- Char.chr (224 + n / 4096);
+      s
+    end
+  else
+    let s = String.make 4 (Char.chr (128 + n mod 64)) in
+    begin
+      s.[2] <- Char.chr (128 + (n / 64) mod 64);
+      s.[1] <- Char.chr (128 + (n / 4096) mod 64);
+      s.[0] <- Char.chr (240 + n / 262144);
+      s
+    end
+
+let next_utf8 s i =
+  let err () = invalid_arg "utf8" in
+  let l = String.length s - i in
+  if l = 0 then raise End_of_input
+  else let a = Char.code s.[i] in if a <= 0x7F then
+    1, a
+  else if a land 0x40 = 0 || l = 1 then err ()
+  else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
+  else if a land 0x20 = 0 then
+    2, (a land 0x1F) lsl 6 + (b land 0x3F)
+  else if l = 2 then err ()
+  else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
+  else if a land 0x10 = 0 then
+    3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
+  else if l = 3 then err ()
+  else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
+  else if a land 0x08 = 0 then
+    4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
+       (c land 0x3F) lsl 6 + (d land 0x3F)
+  else err ()
+
+(* Check the well-formedness of an identifier *)
+
+let initial_refutation j n s =
+  match classify n with
+  | Letter -> None
+  | _ ->
+      let c = String.sub s 0 j in
+      Some (false,
+            "Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+
+let trailing_refutation i j n s =
+  match classify n with
+  | Letter | IdentPart -> None
+  | _ ->
+      let c = String.sub s i j in
+      Some (false,
+            "Invalid character '"^c^"' in identifier \""^s^"\".")
+
+let ident_refutation s =
+  if s = ".." then None else try
+    let j, n = next_utf8 s 0 in
+      match initial_refutation j n s with
+        |None ->
+           begin try
+             let rec aux i =
+               let j, n = next_utf8 s i in
+                 match trailing_refutation i j n s with
+                   |None -> aux (i + j)
+                   |x -> x
+             in aux j
+           with End_of_input -> None
+           end
+        |x -> x
+  with
+  | End_of_input -> Some (true,"The empty string is not an identifier.")
+  | Unsupported -> Some (true,s^": unsupported character in utf8 sequence.")
+  | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.")
+
+let lowercase_unicode =
+  let tree = Segmenttree.make Unicodetable.to_lower in
+  fun unicode ->
+    try
+      match Segmenttree.lookup unicode tree with
+        | `Abs c -> c
+        | `Delta d -> unicode + d
+    with Not_found -> unicode
+
+let lowercase_first_char s =
+  assert (s <> "");
+  let j, n = next_utf8 s 0 in
+  utf8_of_unicode (lowercase_unicode n)
+
+(** For extraction, we need to encode unicode character into ascii ones *)
+
+let is_basic_ascii s =
+  let ok = ref true in
+  String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
+  !ok
+
+let ascii_of_ident s =
+  if is_basic_ascii s then s else
+    let i = ref 0 and out = ref "" in
+    begin try while true do
+      let j, n = next_utf8 s !i in
+      out :=
+        if n >= 128
+        then Printf.sprintf "%s__U%04x_" !out n
+        else Printf.sprintf "%s%c" !out s.[!i];
+      i := !i + j
+    done with End_of_input -> () end;
+    !out
diff --git a/lib/unicode.mli b/lib/unicode.mli
new file mode 100644
index 00000000..098f6c91
--- /dev/null
+++ b/lib/unicode.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Unicode utilities *)
+
+type status = Letter | IdentPart | Symbol
+
+exception Unsupported
+
+(** Classify a unicode char into 3 classes, or raise [Unsupported] *)
+val classify : int -> status
+
+(** Check whether a given string be used as a legal identifier.
+    - [None] means yes
+    - [Some (b,s)] means no, with explanation [s] and severity [b] *)
+val ident_refutation : string -> (bool * string) option
+
+(** First char of a string, converted to lowercase *)
+val lowercase_first_char : string -> string
+
+(** For extraction, turn a unicode string into an ascii-only one *)
+val is_basic_ascii : string -> bool
+val ascii_of_ident : string -> string
diff --git a/lib/unionfind.ml b/lib/unionfind.ml
index 300e8b0e..c44aa736 100644
--- a/lib/unionfind.ml
+++ b/lib/unionfind.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        *)
@@ -53,7 +53,28 @@ module type PartitionSig = sig
 
 end
 
-module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
+module type SetS =
+sig
+  type t
+  type elt
+  val singleton : elt -> t
+  val union : t -> t -> t
+  val choose : t -> elt
+  val iter : (elt -> unit) -> t -> unit
+end
+
+module type MapS =
+sig
+  type key
+  type +'a t
+  val empty : 'a t
+  val find : key -> 'a t -> 'a
+  val add : key -> 'a -> 'a t -> 'a t
+  val mem : key -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+
+module Make (S:SetS)(M:MapS with type key = S.elt) = struct
 
   type elt = S.elt
   type set = S.t
@@ -101,7 +122,7 @@ module Make (S:Set.S)(M:Map.S with type key = S.elt) = struct
 
   let union_set s p =
     try
-      let x = S.min_elt s in
+      let x = S.choose s in
       S.iter (fun y -> union x y p) s
     with Not_found -> ()
 
diff --git a/lib/unionfind.mli b/lib/unionfind.mli
index 0db9ff08..310d5e2a 100644
--- a/lib/unionfind.mli
+++ b/lib/unionfind.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        *)
@@ -51,7 +51,30 @@ module type PartitionSig = sig
 
 end
 
+module type SetS =
+sig
+  type t
+  type elt
+  val singleton : elt -> t
+  val union : t -> t -> t
+  val choose : t -> elt
+  val iter : (elt -> unit) -> t -> unit
+end
+(** Minimal interface for sets, subtype of stdlib's Set. *)
+
+module type MapS =
+sig
+  type key
+  type +'a t
+  val empty : 'a t
+  val find : key -> 'a t -> 'a
+  val add : key -> 'a -> 'a t -> 'a t
+  val mem : key -> 'a t -> bool
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+end
+(** Minimal interface for maps, subtype of stdlib's Map. *)
+
 module Make :
-  functor (S:Set.S) ->
-    functor (M:Map.S with type key = S.elt) ->
+  functor (S:SetS) ->
+    functor (M:MapS with type key = S.elt) ->
       PartitionSig with type elt = S.elt and type set = S.t
diff --git a/lib/util.ml b/lib/util.ml
index 4f14b83a..a8c25f74 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,47 +6,6 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-open Pp
-open Compat
-
-(* Errors *)
-
-exception Anomaly of string * std_ppcmds  (* System errors *)
-let anomaly string = raise (Anomaly(string, str string))
-let anomalylabstrm string pps = raise (Anomaly(string,pps))
-
-exception UserError of string * std_ppcmds (* User errors *)
-let error string = raise (UserError("_", str string))
-let errorlabstrm l pps = raise (UserError(l,pps))
-
-exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
-let alreadydeclared pps = raise (AlreadyDeclared(pps))
-
-let todo s = prerr_string ("TODO: "^s^"\n")
-
-exception Timeout
-
-type loc = Loc.t
-let dummy_loc = Loc.ghost
-let join_loc = Loc.merge
-let make_loc = make_loc
-let unloc = unloc
-
-(* raising located exceptions *)
-type 'a located = loc * 'a
-let anomaly_loc (loc,s,strm) = Loc.raise loc (Anomaly (s,strm))
-let user_err_loc (loc,s,strm) = Loc.raise loc (UserError (s,strm))
-let invalid_arg_loc (loc,s) = Loc.raise loc (Invalid_argument s)
-
-let located_fold_left f x (_,a) = f x a
-let located_iter2 f (_,a) (_,b) = f a b
-let down_located f (_,a) = f a
-
-(* Like Exc_located, but specifies the outermost file read, the filename
-   associated to the location of the error, and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
 (* Mapping under pairs *)
 
 let on_fst f (a,b) = (f a,b)
@@ -65,1195 +24,64 @@ let pi1 (a,_,_) = a
 let pi2 (_,a,_) = a
 let pi3 (_,_,a) = a
 
-(* Projection operator *)
-
-let down_fst f x = f (fst x)
-let down_snd f x = f (snd x)
-
 (* Characters *)
 
-let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z')
+let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
 let is_digit c = (c >= '0' && c <= '9')
 let is_ident_tail c =
-  is_letter c or is_digit c or c = '\'' or c = '_'
+  is_letter c || is_digit c || c = '\'' || c = '_'
 let is_blank = function
   | ' ' | '\r' | '\t' | '\n' -> true
   | _ -> false
 
-(* Strings *)
-
-let explode s =
-  let rec explode_rec n =
-    if n >= String.length s then
-      []
-    else
-      String.make 1 (String.get s n) :: explode_rec (succ n)
-  in
-  explode_rec 0
-
-let implode sl = String.concat "" sl
-
-let strip s =
-  let n = String.length s in
-  let rec lstrip_rec i =
-    if i < n && is_blank s.[i] then
-      lstrip_rec (i+1)
-    else i
-  in
-  let rec rstrip_rec i =
-    if i >= 0 && is_blank s.[i] then
-      rstrip_rec (i-1)
-    else i
-  in
-  let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
-  String.sub s a (b-a+1)
-
-let drop_simple_quotes s =
-  let n = String.length s in
-  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
-
-(* substring searching... *)
-
-(* gdzie = where, co = what *)
-(* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
-let rec is_sub gdzie gl gi co cl ci =
-  (ci>=cl) ||
-  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
-   (is_sub gdzie gl (gi+1) co cl (ci+1)))
-
-let rec raw_str_index i gdzie l c co cl =
-  (* First adapt to ocaml 3.11 new semantics of index_from *)
-  if (i+cl > l) then raise Not_found;
-  (* Then proceed as in ocaml < 3.11 *)
-  let i' = String.index_from gdzie i c in
-    if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
-      raw_str_index (i'+1) gdzie l c co cl
-
-let string_index_from gdzie i co =
-  if co="" then i else
-    raw_str_index i gdzie (String.length gdzie)
-      (String.unsafe_get co 0) co (String.length co)
-
-let string_string_contains ~where ~what =
-  try
-    let _ = string_index_from where 0 what in true
-  with
-      Not_found -> false
-
-let plural n s = if n<>1 then s^"s" else s
-
-let ordinal n =
-  let s = match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in
-  string_of_int n ^ s
-
-(* string parsing *)
-
-let split_string_at c s =
-  let len = String.length s in
-  let rec split n =
-    try
-      let pos = String.index_from s n c in
-      let dir = String.sub s n (pos-n) in
-      dir :: split (succ pos)
-    with
-      | Not_found -> [String.sub s n (len-n)]
-  in
-  if len = 0 then [] else split 0
-
-let parse_loadpath s =
-  let l = split_string_at '/' s in
-  if List.mem "" l then
-    invalid_arg "parse_loadpath: find an empty dir in loadpath";
-  l
-
-module Stringset = Set.Make(struct type t = string let compare = compare end)
-
-module Stringmap = Map.Make(struct type t = string let compare = compare end)
-
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
-
-exception UnsupportedUtf8
-
-(* The following table stores classes of Unicode characters that
-   are used by the lexer. There are 3 different classes so 2 bits are
-   allocated for each character. We only use 16 bits over the 31 bits
-   to simplify the masking process. (This choice seems to be a good
-   trade-off between speed and space after some benchmarks.) *)
-
-(* A 256ko table, initially filled with zeros. *)
-let table = Array.create (1 lsl 17) 0
-
-(* Associate a 2-bit pattern to each status at position [i]. 
-   Only the 3 lowest bits of [i] are taken into account to 
-   define the position of the pattern in the word. 
-   Notice that pattern "00" means "undefined". *)
-let mask i = function
-  | UnicodeLetter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
-  | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
-  | UnicodeSymbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
-
-(* Helper to reset 2 bits in a word. *)
-let reset_mask i =
-  lnot (3 lsl ((i land 7) lsl 1))
-
-(* Initialize the lookup table from a list of segments, assigning
-   a status to every character of each segment. The order of these
-   assignments is relevant: it is possible to assign status [s] to
-   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
-   between [c1] and [c2]. *)
-let mk_lookup_table_from_unicode_tables_for status tables =
-  List.iter
-    (List.iter
-       (fun (c1, c2) ->
-          for i = c1 to c2 do
-            table.(i lsr 3) <-
-              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
-          done))
-    tables
-
-(* Look up into the table and interpret the found pattern. *)
-let lookup x =
-  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
-    if      v = 1 then UnicodeLetter
-    else if v = 2 then UnicodeIdentPart
-    else if v = 3 then UnicodeSymbol
-    else raise UnsupportedUtf8
-
-(* [classify_unicode] discriminates between 3 different kinds of
-   symbols based on the standard unicode classification (extracted from
-   Camomile). *)
-let classify_unicode =
-  let single c = [ (c, c) ] in
-    (* General tables. *)
-    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
-      [
-        Unicodetable.sm;           (* Symbol, maths.             *)
-        Unicodetable.sc;           (* Symbol, currency.          *)
-        Unicodetable.so;           (* Symbol, modifier.          *)
-        Unicodetable.pd;           (* Punctation, dash.          *)
-        Unicodetable.pc;           (* Punctation, connector.     *)
-        Unicodetable.pe;           (* Punctation, open.          *)
-        Unicodetable.ps;           (* Punctation, close.         *)
-        Unicodetable.pi;           (* Punctation, initial quote. *)
-        Unicodetable.pf;           (* Punctation, final quote.   *)
-        Unicodetable.po;           (* Punctation, other.         *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeLetter
-      [
-        Unicodetable.lu;           (* Letter, uppercase.         *)
-        Unicodetable.ll;           (* Letter, lowercase.         *)
-        Unicodetable.lt;           (* Letter, titlecase.         *)
-        Unicodetable.lo;           (* Letter, others.            *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
-      [
-        Unicodetable.nd;           (* Number, decimal digits.    *)
-        Unicodetable.nl;           (* Number, letter.            *)
-        Unicodetable.no;           (* Number, other.             *)
-      ];
-    (* Exceptions (from a previous version of this function). *)
-    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
-      [
-        single 0x000B2;            (* Squared.                   *)
-        single 0x0002E;            (* Dot.                       *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeLetter
-      [
-        single 0x005F;             (* Underscore.                *)
-        single 0x00A0;             (* Non breaking space.        *)
-      ];
-    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
-      [
-        single 0x0027;             (* Special space.             *)
-      ];
-    (* Lookup *)
-    lookup
-
-exception End_of_input
-
-let utf8_of_unicode n =
-  if n < 128 then
-    String.make 1 (Char.chr n)
-  else if n < 2048 then
-    let s = String.make 2 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[0] <- Char.chr (192 + n / 64);
-      s
-    end
-  else if n < 65536 then
-    let s = String.make 3 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[1] <- Char.chr (128 + (n / 64) mod 64);
-      s.[0] <- Char.chr (224 + n / 4096);
-      s
-    end
-  else
-    let s = String.make 4 (Char.chr (128 + n mod 64)) in
-    begin
-      s.[2] <- Char.chr (128 + (n / 64) mod 64);
-      s.[1] <- Char.chr (128 + (n / 4096) mod 64);
-      s.[0] <- Char.chr (240 + n / 262144);
-      s
-    end
-
-let next_utf8 s i =
-  let err () = invalid_arg "utf8" in
-  let l = String.length s - i in
-  if l = 0 then raise End_of_input
-  else let a = Char.code s.[i] in if a <= 0x7F then
-    1, a
-  else if a land 0x40 = 0 or l = 1 then err ()
-  else let b = Char.code s.[i+1] in if b land 0xC0 <> 0x80 then err ()
-  else if a land 0x20 = 0 then
-    2, (a land 0x1F) lsl 6 + (b land 0x3F)
-  else if l = 2 then err ()
-  else let c = Char.code s.[i+2] in if c land 0xC0 <> 0x80 then err ()
-  else if a land 0x10 = 0 then
-    3, (a land 0x0F) lsl 12 + (b land 0x3F) lsl 6 + (c land 0x3F)
-  else if l = 3 then err ()
-  else let d = Char.code s.[i+3] in if d land 0xC0 <> 0x80 then err ()
-  else if a land 0x08 = 0 then
-    4, (a land 0x07) lsl 18 + (b land 0x3F) lsl 12 +
-       (c land 0x3F) lsl 6 + (d land 0x3F)
-  else err ()
-
-(* Check the well-formedness of an identifier *)
+module Empty =
+struct
+  type t
+  let abort (x : t) = assert false
+end
 
-let check_initial handle j n s =
-  match classify_unicode n with
-  | UnicodeLetter -> ()
-  | _ ->
-      let c = String.sub s 0 j in
-      handle ("Invalid character '"^c^"' at beginning of identifier \""^s^"\".")
+(* Strings *)
 
-let check_trailing handle i j n s =
-  match classify_unicode n with
-  | UnicodeLetter | UnicodeIdentPart -> ()
-  | _ ->
-      let c = String.sub s i j in
-      handle ("Invalid character '"^c^"' in identifier \""^s^"\".")
+module String : CString.ExtS = CString
 
-let check_ident_gen handle s =
+let subst_command_placeholder s t =
+  let buff = Buffer.create (String.length s + String.length t) in
   let i = ref 0 in
-  if s <> ".." then try
-    let j, n = next_utf8 s 0 in
-    check_initial handle j n s;
-    i := !i + j;
-    try
-      while true do
-	let j, n = next_utf8 s !i in
-	check_trailing handle !i j n s;
-	i := !i + j
-      done
-    with End_of_input -> ()
-  with
-  | End_of_input -> error "The empty string is not an identifier."
-  | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.")
-  | Invalid_argument _ -> error (s^": invalid utf8 sequence.")
-
-let check_ident_soft = check_ident_gen warning
-let check_ident = check_ident_gen error
-
-let lowercase_unicode =
-  let tree = Segmenttree.make Unicodetable.to_lower in
-  fun unicode ->
-    try
-      match Segmenttree.lookup unicode tree with
-	| `Abs c -> c
-	| `Delta d -> unicode + d
-    with Not_found -> unicode
-
-let lowercase_first_char_utf8 s =
-  assert (s <> "");
-  let j, n = next_utf8 s 0 in
-  utf8_of_unicode (lowercase_unicode n)
-
-(** For extraction, we need to encode unicode character into ascii ones *)
-
-let ascii_of_ident s =
-  let check_ascii s =
-    let ok = ref true in
-    String.iter (fun c -> if Char.code c >= 128 then ok := false) s;
-    !ok
-  in
-  if check_ascii s then s else
-    let i = ref 0 and out = ref "" in
-    begin try while true do
-      let j, n = next_utf8 s !i in
-      out :=
-	if n >= 128
-	then Printf.sprintf "%s__U%04x_" !out n
-	else Printf.sprintf "%s%c" !out s.[!i];
-      i := !i + j
-    done with End_of_input -> () end;
-    !out
+  while (!i < String.length s) do
+    if s.[!i] = '%' && !i+1 < String.length s && s.[!i+1] = 's'
+    then (Buffer.add_string buff t;incr i)
+    else Buffer.add_char buff s.[!i];
+    incr i
+  done;
+  Buffer.contents buff
 
 (* Lists *)
 
-let rec list_compare cmp l1 l2 =
-  match l1,l2 with
-      [], [] -> 0
-    | _::_, [] -> 1
-    | [], _::_ -> -1
-    | x1::l1, x2::l2 ->
-	(match cmp x1 x2 with
-	   | 0 -> list_compare cmp l1 l2
-	   | c -> c)
-
-let rec list_equal cmp l1 l2 =
-  match l1, l2 with
-    | [], [] -> true
-    | x1 :: l1, x2 :: l2 ->
-      cmp x1 x2 && list_equal cmp l1 l2
-    | _ -> false
-
-let list_intersect l1 l2 =
-  List.filter (fun x -> List.mem x l2) l1
-
-let list_union l1 l2 =
-  let rec urec = function
-    | [] -> l2
-    | a::l -> if List.mem a l2 then urec l else a::urec l
-  in
-  urec l1
-
-let list_unionq l1 l2 =
-  let rec urec = function
-    | [] -> l2
-    | a::l -> if List.memq a l2 then urec l else a::urec l
-  in
-  urec l1
-
-let list_subtract l1 l2 =
-  if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
-
-let list_subtractq l1 l2 =
-  if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
-
-let list_tabulate f len =
-  let rec tabrec n =
-    if n = len then [] else (f n)::(tabrec (n+1))
-  in
-  tabrec 0
-
-let list_addn n v =
-  let rec aux n l =
-    if n = 0 then l
-    else aux (pred n) (v::l)
-  in
-    if n < 0 then invalid_arg "list_addn"
-    else aux n
-
-let list_make n v = list_addn n v []
-
-let list_assign l n e =
-  let rec assrec stk = function
-    | ((h::t), 0) -> List.rev_append stk (e::t)
-    | ((h::t), n) -> assrec (h::stk) (t, n-1)
-    | ([], _) -> failwith "list_assign"
-  in
-  assrec [] (l,n)
-
-let rec list_smartmap f l = match l with
-    [] -> l
-  | h::tl ->
-      let h' = f h and tl' = list_smartmap f tl in
-	if h'==h && tl'==tl then l
-	else h'::tl'
-
-let list_map_left f = (* ensures the order in case of side-effects *)
-  let rec map_rec = function
-    | [] -> []
-    | x::l -> let v = f x in v :: map_rec l
-  in
-  map_rec
-
-let list_map_i f =
-  let rec map_i_rec i = function
-    | [] -> []
-    | x::l -> let v = f i x in v :: map_i_rec (i+1) l
-  in
-  map_i_rec
-
-let list_map2_i f i l1 l2 =
-  let rec map_i i = function
-    | ([], []) -> []
-    | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
-    | (_, _) -> invalid_arg "map2_i"
-  in
-  map_i i (l1,l2)
-
-let list_map3 f l1 l2 l3 =
-  let rec map = function
-    | ([], [], []) -> []
-    | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
-    | (_, _, _) -> invalid_arg "map3"
-  in
-  map (l1,l2,l3)
-
-let list_map4 f l1 l2 l3 l4 =
-  let rec map = function
-    | ([], [], [], []) -> []
-    | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
-    | (_, _, _, _) -> invalid_arg "map4"
-  in
-  map (l1,l2,l3,l4)
-
-let list_map_to_array f l =
-  Array.of_list (List.map f l)
-
-let rec list_smartfilter f l = match l with
-    [] -> l
-  | h::tl ->
-      let tl' = list_smartfilter f tl in
-	if f h then
-	  if tl' == tl then l
-	  else h :: tl'
-	else tl'
-	  
-let list_index_f f x =
-  let rec index_x n = function
-    | y::l -> if f x y then n else index_x (succ n) l
-    | [] -> raise Not_found
-  in
-  index_x 1
-
-let list_index0_f f x l = list_index_f f x l - 1
-
-let list_index x =
-  let rec index_x n = function
-    | y::l -> if x = y then n else index_x (succ n) l
-    | [] -> raise Not_found
-  in
-  index_x 1
-
-let list_index0 x l = list_index x l - 1
-
-let list_unique_index x =
-  let rec index_x n = function
-    | y::l ->
-	if x = y then
-	  if List.mem x l then raise Not_found
-	  else n
-	else index_x (succ n) l
-    | [] -> raise Not_found
-  in index_x 1
-
-let list_fold_right_i f i l =
-  let rec it_list_f i l a = match l with
-    | [] -> a
-    | b::l -> f (i-1) b (it_list_f (i-1) l a)
-  in
-  it_list_f (List.length l + i) l
-
-let list_fold_left_i f =
-  let rec it_list_f i a = function
-    | [] -> a
-    | b::l -> it_list_f (i+1) (f i a b) l
-  in
-  it_list_f
-
-let rec list_fold_left3 f accu l1 l2 l3 =
-  match (l1, l2, l3) with
-    ([], [], []) -> accu
-  | (a1::l1, a2::l2, a3::l3) -> list_fold_left3 f (f accu a1 a2 a3) l1 l2 l3
-  | (_, _, _) -> invalid_arg "list_fold_left3"
-
-(* [list_fold_right_and_left f [a1;...;an] hd =
-   f (f (... (f (f hd
-                   an
-                   [an-1;...;a1])
-              an-1
-              [an-2;...;a1])
-         ...)
-        a2
-        [a1])
-     a1
-     []] *)
-
-let rec list_fold_right_and_left f l hd =
-  let rec aux tl = function
-    | [] -> hd
-    | a::l -> let hd = aux (a::tl) l in f hd a tl
-   in aux [] l
-
-let list_iter3 f l1 l2 l3 =
-  let rec iter = function
-    | ([], [], []) -> ()
-    | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3)
-    | (_, _, _) -> invalid_arg "map3"
-  in
-  iter (l1,l2,l3)
-
-let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
-
-let list_for_all_i p =
-  let rec for_all_p i = function
-    | [] -> true
-    | a::l -> p i a && for_all_p (i+1) l
-  in
-  for_all_p
-
-let list_except x l = List.filter (fun y -> not (x = y)) l
-
-let list_remove = list_except (* Alias *)
-
-let rec list_remove_first a = function
-  | b::l when a = b -> l
-  | b::l -> b::list_remove_first a l
-  | [] -> raise Not_found
-
-let rec list_remove_assoc_in_triple x = function
-  | [] -> []
-  | (y,_,_ as z)::l -> if x = y then l else z::list_remove_assoc_in_triple x l
-
-let rec list_assoc_snd_in_triple x = function
-    [] -> raise Not_found
-  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_snd_in_triple x l
-
-let list_add_set x l = if List.mem x l then l else x::l
-
-let list_eq_set l1 l2 =
-  let rec aux l1 = function
-  | [] -> l1 = []
-  | a::l2 -> aux (list_remove_first a l1) l2 in
-  try aux l1 l2 with Not_found -> false
-
-let list_for_all2eq f l1 l2 =
-  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
-
-let list_filter_i p =
-  let rec filter_i_rec i = function
-    | [] -> []
-    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
-  in
-  filter_i_rec 0
-
-let rec list_sep_last = function
-  | [] -> failwith "sep_last"
-  | hd::[] -> (hd,[])
-  | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
-
-let list_try_find_i f =
-  let rec try_find_f n = function
-    | [] -> failwith "try_find_i"
-    | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
-  in
-  try_find_f
-
-let list_try_find f =
-  let rec try_find_f = function
-    | [] -> failwith "try_find"
-    | h::t -> try f h with Failure _ -> try_find_f t
-  in
-  try_find_f
-
-let list_uniquize l =
-  let visited = Hashtbl.create 23 in
-  let rec aux acc = function
-    | h::t -> if Hashtbl.mem visited h then aux acc t else
-	  begin
-	    Hashtbl.add visited h h;
-	    aux (h::acc) t
-	  end
-    | [] -> List.rev acc
-  in aux [] l
-
-let rec list_distinct l =
-  let visited = Hashtbl.create 23 in
-  let rec loop = function
-    | h::t ->
-	if Hashtbl.mem visited h then false
-	else
-	  begin
-	    Hashtbl.add visited h h;
-	    loop t
-	  end
-    | [] -> true
-  in loop l
-
-let rec list_merge_uniq cmp l1 l2 =
-  match l1, l2 with
-  | [], l2 -> l2
-  | l1, [] -> l1
-  | h1 :: t1, h2 :: t2 ->
-      let c = cmp h1 h2 in
-      if c = 0
-      then h1 :: list_merge_uniq cmp t1 t2
-      else if c <= 0
-      then h1 :: list_merge_uniq cmp t1 l2
-      else h2 :: list_merge_uniq cmp l1 t2
-
-let rec list_duplicates = function
-  | [] -> []
-  | x::l ->
-      let l' = list_duplicates l in
-      if List.mem x l then list_add_set x l' else l'
-
-let rec list_filter2 f = function
-  | [], [] as p -> p
-  | d::dp, l::lp ->
-     let (dp',lp' as p) = list_filter2 f (dp,lp) in
-      if f d l then d::dp', l::lp' else p
-  | _ -> invalid_arg "list_filter2"
-
-let rec list_map_filter f = function
-  | [] -> []
-  | x::l ->
-      let l' = list_map_filter f l in
-      match f x with None -> l' | Some y -> y::l'
-
-let list_map_filter_i f =
-  let rec aux i = function
-    | [] -> []
-    | x::l ->
-      let l' = aux (succ i) l in
-	match f i x with None -> l' | Some y -> y::l'
-  in aux 0
-
-let list_filter_along f filter l =
-  snd (list_filter2 (fun b c -> f b) (filter,l))
-
-let list_filter_with filter l =
-  list_filter_along (fun x -> x) filter l
-
-let list_subset l1 l2 =
-  let t2 = Hashtbl.create 151 in
-  List.iter (fun x -> Hashtbl.add t2 x ()) l2;
-  let rec look = function
-    | [] -> true
-    | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
-  in
-  look l1
-
-(* [list_chop i l] splits [l] into two lists [(l1,l2)] such that
-   [l1++l2=l] and [l1] has length [i].
-   It raises [Failure] when [i] is negative or greater than the length of [l]  *)
-
-let list_chop n l =
-  let rec chop_aux i acc = function
-    | tl when i=0 -> (List.rev acc, tl)
-    | h::t -> chop_aux (pred i) (h::acc) t
-    | [] -> failwith "list_chop"
-  in
-  chop_aux n [] l
-
-(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
-    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
-    If there is no such [a], then it returns [(l,[])] instead *)
-let list_split_when p =
-  let rec split_when_loop x y =
-    match y with
-      | []      -> (List.rev x,[])
-      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
-  in
-  split_when_loop []
-
-(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
-   [l1] satisfy [p] and elements of [l2] do not; order is preserved *)
-let list_split_by p =
-  let rec split_by_loop = function
-  | []   -> ([],[])
-  | a::l ->
-      let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2)
-  in
-  split_by_loop
-
-let rec list_split3 = function
-  | [] -> ([], [], [])
-  | (x,y,z)::l ->
-      let (rx, ry, rz) = list_split3 l in (x::rx, y::ry, z::rz)
-
-let rec list_insert_in_class f a = function
-  | [] -> [[a]]
-  | (b::_ as l)::classes when f a b -> (a::l)::classes
-  | l::classes -> l :: list_insert_in_class f a classes
-
-let list_partition_by f l =
-  List.fold_right (list_insert_in_class f) l []
-
-let list_firstn n l =
-  let rec aux acc = function
-    | (0, l) -> List.rev acc
-    | (n, (h::t)) -> aux (h::acc) (pred n, t)
-    | _ -> failwith "firstn"
-  in
-  aux [] (n,l)
-
-let rec list_last = function
-  | [] -> failwith "list_last"
-  | [x] -> x
-  | _ :: l -> list_last l
-
-let list_lastn n l =
-  let len = List.length l in
-  let rec aux m l =
-    if m = n then l else aux (m - 1) (List.tl l)
-  in
-  if len < n then failwith "lastn" else aux len l
-
-let rec list_skipn n l = match n,l with
-  | 0, _ -> l
-  | _, [] -> failwith "list_skipn"
-  | n, _::l -> list_skipn (pred n) l
-
-let rec list_skipn_at_least n l =
-  try list_skipn n l with Failure _ -> []
-
-let list_prefix_of prefl l =
-  let rec prefrec = function
-    | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
-    | ([], _) -> true
-    | (_, _) -> false
-  in
-    prefrec (prefl,l)
-
-let list_drop_prefix p l =
-(* if l=p++t then return t else l *)
-  let rec list_drop_prefix_rec = function
-    | ([], tl) -> Some tl
-    | (_, []) -> None
-    | (h1::tp, h2::tl) ->
-	if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
-  in
-    match list_drop_prefix_rec (p,l) with
-      | Some r -> r
-      | None -> l
-
-let list_map_append f l = List.flatten (List.map f l)
-let list_join_map = list_map_append   (* Alias *)
-
-let list_map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2)
-
-let list_share_tails l1 l2 =
-  let rec shr_rev acc = function
-    | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
-    | (l1,l2) -> (List.rev l1, List.rev l2, acc)
-  in
-  shr_rev [] (List.rev l1, List.rev l2)
-
-let rec list_fold_map f e = function
-  |  []  -> (e,[])
-  |  h::t ->
-       let e',h' = f e h in
-       let e'',t' = list_fold_map f e' t in
-         e'',h'::t'
-
-(* (* tail-recursive version of the above function *)
-let list_fold_map f e l =
-  let g (e,b') h =
-    let (e',h') = f e h in
-      (e',h'::b')
-  in
-  let (e',lrev) = List.fold_left g (e,[]) l in
-    (e',List.rev lrev)
-*)
-
-(* The same, based on fold_right, with the effect accumulated on the right *)
-let list_fold_map' f l e =
-  List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e)
-
-let list_map_assoc f = List.map (fun (x,a) -> (x,f a))
-
-let rec list_assoc_f f a = function
-  | (x, e) :: xs -> if f a x then e else list_assoc_f f a xs
-  | [] -> raise Not_found
-
-(* Specification:
-   - =p= is set equality (double inclusion)
-   - f such that \forall l acc, (f l acc) =p= append (f l []) acc
-   - let g = fun x -> f x [] in
-   - union_map f l acc =p= append (flatten (map g l)) acc
- *)
-let list_union_map f l acc =
-  List.fold_left
-    (fun x y -> f y x)
-    acc
-    l
-
-(* A generic cartesian product: for any operator (**),
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
-   and so on if there are more elements in the lists. *)
-
-let rec list_cartesian op l1 l2 =
-  list_map_append (fun x -> List.map (op x) l2) l1
-
-(* [list_cartesians] is an n-ary cartesian product: it iterates
-   [list_cartesian] over a list of lists.  *)
-
-let list_cartesians op init ll =
-  List.fold_right (list_cartesian op) ll [init]
-
-(* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
-
-let list_combinations l = list_cartesians (fun x l -> x::l) [] l
-
-let rec list_combine3 x y z = 
-  match x, y, z with
-  | [], [], [] -> []
-  | (x :: xs), (y :: ys), (z :: zs) ->
-      (x, y, z) :: list_combine3 xs ys zs
-  | _, _, _ -> raise (Invalid_argument "list_combine3")
-  
-(* Keep only those products that do not return None *)
-
-let rec list_cartesian_filter op l1 l2 =
-  list_map_append (fun x -> list_map_filter (op x) l2) l1
+module List : CList.ExtS = CList
 
-(* Keep only those products that do not return None *)
-
-let rec list_cartesians_filter op init ll =
-  List.fold_right (list_cartesian_filter op) ll [init]
-
-(* Drop the last element of a list *)
-
-let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl -> hd :: list_drop_last tl
-
-(* Factorize lists of pairs according to the left argument *)
-let rec list_factorize_left = function
-  | (a,b)::l ->
-      let al,l' = list_split_by (fun (a',b) -> a=a') l in
-      (a,(b::List.map snd al)) :: list_factorize_left l'
-  | [] ->
-      []
+let (@) = CList.append
 
 (* Arrays *)
 
-let array_compare item_cmp v1 v2 =
-  let c = compare (Array.length v1) (Array.length v2) in
-  if c<>0 then c else
-    let rec cmp = function
-	-1 -> 0
-      | i ->
-	  let c' = item_cmp v1.(i) v2.(i) in
-	  if c'<>0 then c'
-	  else cmp (i-1) in
-    cmp (Array.length v1 - 1)
-
-let array_equal cmp t1 t2 =
-  Array.length t1 = Array.length t2 &&
-  let rec aux i =
-    (i = Array.length t1) || (cmp t1.(i) t2.(i) && aux (i + 1))
-  in aux 0
-
-let array_exists f v =
-  let rec exrec = function
-    | -1 -> false
-    | n -> (f v.(n)) || (exrec (n-1))
-  in
-  exrec ((Array.length v)-1)
-
-let array_for_all f v =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v.(n)) && (allrec (n-1))
-  in
-  allrec ((Array.length v)-1)
-
-let array_for_all2 f v1 v2 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && allrec (pred lv1)
-
-let array_for_all3 f v1 v2 v3 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
-
-let array_for_all4 f v1 v2 v3 v4 =
-  let rec allrec = function
-    | -1 -> true
-    | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
-  in
-  let lv1 = Array.length v1 in
-  lv1 = Array.length v2 &&
-  lv1 = Array.length v3 &&
-  lv1 = Array.length v4 &&
-    allrec (pred lv1)
-
-let array_for_all_i f i v =
-  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in
-  allrec i 0
-
-exception Found of int
-
-let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    None
-  with Found i -> Some i
-
-let array_hd v =
-  match Array.length v with
-    | 0 -> failwith "array_hd"
-    | _ -> v.(0)
+module Array : CArray.ExtS = CArray
 
-let array_tl v =
-  match Array.length v with
-    | 0 -> failwith "array_tl"
-    | n -> Array.sub v 1 (pred n)
+(* Sets *)
 
-let array_last v =
-  match Array.length v with
-    | 0 -> failwith "array_last"
-    | n -> v.(pred n)
+module Set = CSet
 
-let array_cons e v = Array.append [|e|] v
+(* Maps *)
 
-let array_rev t =
-  let n=Array.length t in
-    if n <=0 then ()
-    else
-      let tmp=ref t.(0) in
-      for i=0 to pred (n/2) do
-	tmp:=t.((pred n)-i);
-	t.((pred n)-i)<- t.(i);
-	t.(i)<- !tmp
-      done
+module Map = CMap
 
-let array_fold_right_i f v a =
-  let rec fold a n =
-    if n=0 then a
-    else
-      let k = n-1 in
-      fold (f k v.(k) a) k in
-  fold a (Array.length v)
+(* Stacks *)
 
-let array_fold_left_i f v a =
-  let n = Array.length a in
-  let rec fold i v = if i = n then v else fold (succ i) (f i v a.(i)) in
-  fold 0 v
-
-let array_fold_right2 f v1 v2 a =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n=0 then a
-    else
-      let k = n-1 in
-      fold (f v1.(k) v2.(k) a) k in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_right2";
-  fold a lv1
-
-let array_fold_left2 f a v1 v2 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left2_i f a v1 v2 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left3 f a v1 v2 v3 =
-  let lv1 = Array.length v1 in
-  let rec fold a n =
-    if n >= lv1 then a else fold (f a v1.(n) v2.(n) v3.(n)) (succ n)
-  in
-  if Array.length v2 <> lv1 || Array.length v3 <> lv1 then
-    invalid_arg "array_fold_left2";
-  fold a 0
-
-let array_fold_left_from n f a v =
-  let rec fold a n =
-    if n >= Array.length v then a else fold (f a v.(n)) (succ n)
-  in
-  fold a n
-
-let array_fold_right_from n f v a =
-  let rec fold n =
-    if n >= Array.length v then a else f v.(n) (fold (succ n))
-  in
-  fold n
-
-let array_app_tl v l =
-  if Array.length v = 0 then invalid_arg "array_app_tl";
-  array_fold_right_from 1 (fun e l -> e::l) v l
-
-let array_list_of_tl v =
-  if Array.length v = 0 then invalid_arg "array_list_of_tl";
-  array_fold_right_from 1 (fun e l -> e::l) v []
-
-let array_map_to_list f v =
-  List.map f (Array.to_list v)
-
-let array_chop n v =
-  let vlen = Array.length v in
-  if n > vlen then failwith "array_chop";
-  (Array.sub v 0 n, Array.sub v n (vlen-n))
-
-exception Local of int
-
-(* If none of the elements is changed by f we return ar itself.
-   The for loop looks for the first such an element.
-   If found it is temporarily stored in a ref and the new array is produced,
-   but f is not re-applied to elements that are already checked *)
-let array_smartmap f ar =
-  let ar_size = Array.length ar in
-  let aux = ref None in
-  try
-    for i = 0 to ar_size-1 do
-      let a = ar.(i) in
-      let a' = f a in
-	if a != a' then (* pointer (in)equality *) begin
-	  aux := Some a';
-	  raise (Local i)
-	end
-    done;
-    ar
-  with
-      Local i ->
-	let copy j =
-	  if j<i then ar.(j)
-	  else if j=i then
-	    match !aux with Some a' -> a' | None -> failwith "Error"
-	  else f (ar.(j))
-	in
-	  Array.init ar_size copy
-
-let array_map2 f v1 v2 =
-  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f v1.(i) v2.(i)
-    done;
-    res
-  end
-
-let array_map2_i f v1 v2 =
-  if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f i v1.(i) v2.(i)
-    done;
-    res
-  end
-
-let array_map3 f v1 v2 v3 =
-  if Array.length v1 <> Array.length v2 ||
-     Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
-  if Array.length v1 == 0 then
-    [| |]
-  else begin
-    let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
-    for i = 1 to pred (Array.length v1) do
-      res.(i) <- f v1.(i) v2.(i) v3.(i)
-    done;
-    res
-  end
-
-let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *)
-  let l = Array.length a in (* (even if so), then we rewrite it *)
-  if l = 0 then [||] else begin
-    let r = Array.create l (f a.(0)) in
-    for i = 1 to l - 1 do
-      r.(i) <- f a.(i)
-    done;
-    r
-  end
-
-let array_map_left_pair f a g b =
-  let l = Array.length a in
-  if l = 0 then [||],[||] else begin
-    let r = Array.create l (f a.(0)) in
-    let s = Array.create l (g b.(0)) in
-    for i = 1 to l - 1 do
-      r.(i) <- f a.(i);
-      s.(i) <- g b.(i)
-    done;
-    r, s
-  end
-
-let array_iter2 f v1 v2 =
-  let n = Array.length v1 in
-  if Array.length v2 <> n then invalid_arg "array_iter2"
-  else for i = 0 to n - 1 do f v1.(i) v2.(i) done
-
-let pure_functional = false
-
-let array_fold_map' f v e =
-if pure_functional then
-  let (l,e) =
-    Array.fold_right
-      (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
-      v ([],e) in
-  (Array.of_list l,e)
-else
-  let e' = ref e in
-  let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in
-  (v',!e')
-
-let array_fold_map f e v =
-  let e' = ref e in
-  let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in
-  (!e',v')
-
-let array_fold_map2' f v1 v2 e =
-  let e' = ref e in
-  let v' =
-    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
-  in
-  (v',!e')
-
-let array_distinct v =
-  let visited = Hashtbl.create 23 in
-  try
-    Array.iter
-      (fun x ->
-        if Hashtbl.mem visited x then raise Exit
-        else Hashtbl.add visited x x)
-      v;
-    true
-  with Exit -> false
-
-let array_union_map f a acc =
-  Array.fold_left
-    (fun x y -> f y x)
-    acc
-    a
-
-let array_rev_to_list a =
-  let rec tolist i res =
-    if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
-  tolist 0 []
-
-let array_filter_along f filter v =
-  Array.of_list (list_filter_along f filter (Array.to_list v))
-
-let array_filter_with filter v =
-  Array.of_list (list_filter_with filter (Array.to_list v))
-
-(* Stream *)
-
-let stream_nth n st =
-  try List.nth (Stream.npeek (n+1) st) n
-  with Failure _ -> raise Stream.Failure
-
-let stream_njunk n st =
-  for i = 1 to n do Stream.junk st done
+module Stack = CStack
 
 (* Matrices *)
 
 let matrix_transpose mat =
   List.fold_right (List.map2 (fun p c -> p::c)) mat
-    (if mat = [] then [] else List.map (fun _ -> []) (List.hd mat))
+    (if List.is_empty mat then [] else List.map (fun _ -> []) (List.hd mat))
 
 (* Functions *)
 
@@ -1263,18 +91,28 @@ let compose f g x = f (g x)
 
 let const x _ = x
 
-let iterate f =
-  let rec iterate_f n x =
-    if n <= 0 then x else iterate_f (pred n) (f x)
+let iterate =
+  let rec iterate_f f n x =
+    if n <= 0 then x else iterate_f f (pred n) (f x)
   in
   iterate_f
 
 let repeat n f x =
-  for i = 1 to n do f x done
+  let rec loop i = if i <> 0 then (f x; loop (i - 1)) in loop n
+
+let app_opt f x =
+  match f with
+  | Some f -> f x
+  | None -> x
 
-let iterate_for a b f x =
-  let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
-  iterate a x
+(* Stream *)
+
+let stream_nth n st =
+  try List.nth (Stream.npeek (n+1) st) n
+  with Failure _ -> raise Stream.Failure
+
+let stream_njunk n st =
+  repeat n Stream.junk st
 
 (* Delayed computations *)
 
@@ -1284,245 +122,13 @@ let delayed_force f = f ()
 
 (* Misc *)
 
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset = Set.Make(struct type t = int let compare = compare end)
-
-module Intmap = Map.Make(struct type t = int let compare = compare end)
-
-let intmap_in_dom x m =
-  try let _ = Intmap.find x m in true with Not_found -> false
-
-let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
-
-let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
-
-let interval n m =
-  let rec interval_n (l,m) =
-    if n > m then l else interval_n (m::l,pred m)
-  in
-  interval_n ([],m)
-
-
-let map_succeed f =
-  let rec map_f = function
-    | [] -> []
-    |  h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
-  in
-  map_f
-
-(* Pretty-printing *)
-
-let pr_spc = spc
-let pr_fnl = fnl
-let pr_int = int
-let pr_str = str
-let pr_comma () = str "," ++ spc ()
-let pr_semicolon () = str ";" ++ spc ()
-let pr_bar () = str "|" ++ spc ()
-let pr_arg pr x = spc () ++ pr x
-let pr_opt pr = function None -> mt () | Some x -> pr_arg pr x
-let pr_opt_no_spc pr = function None -> mt () | Some x -> pr x
-
-let nth n = str (ordinal n)
-
-(* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
-
-let rec prlist elem l = match l with
-  | []   -> mt ()
-  | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
-
-(* unlike all other functions below, [prlist] works lazily.
-   if a strict behavior is needed, use [prlist_strict] instead.
-   evaluation is done from left to right. *)
-
-let rec prlist_strict elem l = match l with
-  | []   -> mt ()
-  | h::t ->
-      let e = elem h in let r = prlist_strict elem t in e++r
-
-(* [prlist_with_sep sep pr [a ; ... ; c]] outputs
-   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let rec prlist_with_sep sep elem l = match l with
-  | []   -> mt ()
-  | [h]  -> elem h
-  | h::t ->
-      let e = elem h and s = sep() and r = prlist_with_sep sep elem t in
-      e ++ s ++ r
-
-(* Print sequence of objects separated by space (unless an element is empty) *)
-
-let rec pr_sequence elem = function
-  | []   -> mt ()
-  | [h]  -> elem h
-  | h::t ->
-      let e = elem h and r = pr_sequence elem t in
-      if e = mt () then r else e ++ spc () ++ r
-
-(* [pr_enum pr [a ; b ; ... ; c]] outputs
-   [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
-
-let pr_enum pr l =
-  let c,l' = list_sep_last l in
-  prlist_with_sep pr_comma pr l' ++
-  (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c
-
-let pr_vertical_list pr = function
-  | [] -> str "none" ++ fnl ()
-  | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
-
-(* [prvecti_with_sep sep pr [|a0 ; ... ; an|]] outputs
-   [pr 0 a0 ++ sep() ++ ... ++ sep() ++ pr n an] *)
-
-let prvecti_with_sep sep elem v =
-  let rec pr i =
-    if i = 0 then
-      elem 0 v.(0)
-    else
-      let r = pr (i-1) and s = sep () and e = elem i v.(i) in
-      r ++ s ++ e
-  in
-  let n = Array.length v in
-  if n = 0 then mt () else pr (n - 1)
-
-(* [prvecti pr [|a0 ; ... ; an|]] outputs [pr 0 a0 ++ ... ++ pr n an] *)
-
-let prvecti elem v = prvecti_with_sep mt elem v
-
-(* [prvect_with_sep sep pr [|a ; ... ; c|]] outputs
-   [pr a ++ sep() ++ ... ++ sep() ++ pr c] *)
-
-let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v
-
-(* [prvect pr [|a ; ... ; c|]] outputs [pr a ++ ... ++ pr c] *)
-
-let prvect elem v = prvect_with_sep mt elem v
-
-let pr_located pr (loc,x) =
-  if Flags.do_beautify() && loc<>dummy_loc then
-    let (b,e) = unloc loc in
-    comment b ++ pr x ++ comment e
-  else pr x
-
-let surround p = hov 1 (str"(" ++ p ++ str")")
-
-(*s Memoization *)
-
-let memo1_eq eq f =
-  let m = ref None in
-  fun x ->
-    match !m with
-        Some(x',y') when eq x x' -> y'
-      | _ -> let y = f x in m := Some(x,y); y
-
-let memo1_1 f = memo1_eq (==) f
-let memo1_2 f =
-  let f' =
-    memo1_eq (fun (x,y) (x',y') -> x==x' && y==y') (fun (x,y) -> f x y) in
-  (fun x y -> f'(x,y))
-
-(* Memorizes the last n distinct calls to f. Since there is no hash,
-   Efficient only for small n. *)
-let memon_eq eq n f =
-  let cache = ref [] in (* the cache: a stack *)
-  let m = ref 0 in      (* usage of the cache *)
-  let rec find x = function
-    | (x',y')::l when eq x x' -> y', l (* cell is moved to the top *)
-    | [] -> (* we assume n>0, so creating one memo cell is OK *)
-        incr m; (f x, [])
-    | [_] when !m>=n -> f x,[] (* cache is full: dispose of last cell *)
-    | p::l (* not(eq x (fst p)) *) -> let (y,l') = find x l in (y, p::l')
-  in
-  (fun x ->
-    let (y,l) = find x !cache in
-    cache := (x,y)::l;
-    y)
-
-
-(*s Size of ocaml values. *)
-
-module Size = struct
-
-  (*s Pointers already visited are stored in a hash-table, where
-      comparisons are done using physical equality. *)
-
-  module H = Hashtbl.Make(
-    struct
-      type t = Obj.t
-      let equal = (==)
-      let hash o = Hashtbl.hash (Obj.magic o : int)
-    end)
-
-  let node_table = (H.create 257 : unit H.t)
-
-  let in_table o = try H.find node_table o; true with Not_found -> false
-
-  let add_in_table o = H.add node_table o ()
-
-  let reset_table () = H.clear node_table
-
-  (*s Objects are traversed recursively, as soon as their tags are less than
-      [no_scan_tag]. [count] records the numbers of words already visited. *)
-
-  let size_of_double = Obj.size (Obj.repr 1.0)
-
-  let count = ref 0
-
-  let rec traverse t =
-    if not (in_table t) then begin
-      add_in_table t;
-      if Obj.is_block t then begin
-	let n = Obj.size t in
-	let tag = Obj.tag t in
-	if tag < Obj.no_scan_tag then begin
-	  count := !count + 1 + n;
-	  for i = 0 to n - 1 do
-      	    let f = Obj.field t i in
-	    if Obj.is_block f then traverse f
-	  done
-	end else if tag = Obj.string_tag then
-	  count := !count + 1 + n
-	else if tag = Obj.double_tag then
-	  count := !count + size_of_double
-	else if tag = Obj.double_array_tag then
-	  count := !count + 1 + size_of_double * n
-	else
-	  incr count
-      end
-    end
-
-  (*s Sizes of objects in words and in bytes. The size in bytes is computed
-      system-independently according to [Sys.word_size]. *)
-
-  let size_w o =
-    reset_table ();
-    count := 0;
-    traverse (Obj.repr o);
-    !count
-
-  let size_b o = (size_w o) * (Sys.word_size / 8)
-
-  let size_kb o = (size_w o) / (8192 / Sys.word_size)
-
-end
-
-let size_w = Size.size_w
-let size_b = Size.size_b
-let size_kb = Size.size_kb
-
-(*s Total size of the allocated ocaml heap. *)
-
-let heap_size () =
-  let stat = Gc.stat ()
-  and control = Gc.get () in
-  let max_words_total = stat.Gc.heap_words + control.Gc.minor_heap_size in
-  (max_words_total * (Sys.word_size / 8))
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
 
-let heap_size_kb () = (heap_size () + 1023) / 1024
+let map_union f g = function
+  | Inl a -> Inl (f a)
+  | Inr b -> Inr (g b)
 
-(*s interruption *)
+type iexn = Exninfo.iexn
 
-let interrupt = ref false
-let check_for_interrupt () =
-  if !interrupt then begin interrupt := false; raise Sys.Break end
+let iraise = Exninfo.iraise
diff --git a/lib/util.mli b/lib/util.mli
index 530e838a..4fce809c 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -1,73 +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        *)
 (************************************************************************)
 
-open Pp
-open Compat
-
 (** This module contains numerous utility functions on strings, lists,
    arrays, etc. *)
 
-(** {6 ... } *)
-(** Errors. [Anomaly] is used for system errors and [UserError] for the
-   user's ones. *)
-
-exception Anomaly of string * std_ppcmds
-val anomaly : string -> 'a
-val anomalylabstrm : string -> std_ppcmds -> 'a
-
-exception UserError of string * std_ppcmds
-val error : string -> 'a
-val errorlabstrm : string -> std_ppcmds -> 'a
-
-exception AlreadyDeclared of std_ppcmds
-val alreadydeclared : std_ppcmds -> 'a
-
-(** [todo] is for running of an incomplete code its implementation is
-   "do nothing" (or print a message), but this function should not be
-   used in a released code *)
-
-val todo : string -> unit
-
-exception Timeout
-
-type loc = Loc.t
-
-type 'a located = loc * 'a
-
-val unloc : loc -> int * int
-val make_loc : int * int -> loc
-val dummy_loc : loc
-val join_loc : loc -> loc -> loc
-
-val anomaly_loc : loc * string * std_ppcmds -> 'a
-val user_err_loc : loc * string * std_ppcmds -> 'a
-val invalid_arg_loc : loc * string -> 'a
-val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
-val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
-val down_located : ('a -> 'b) -> 'a located -> 'b
-
-(** Like [Exc_located], but specifies the outermost file read, the
-   input buffer associated to the location of the error (or the module name
-   if boolean is true), and the error itself. *)
-
-exception Error_in_file of string * (bool * string * loc) * exn
-
 (** Mapping under pairs *)
 
 val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
 val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
 val map_pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b
 
-(** Going down pairs *)
-
-val down_fst : ('a -> 'b) -> 'a * 'c -> 'b
-val down_snd : ('a -> 'b) -> 'c * 'a -> 'b
-
 (** Mapping under triple *)
 
 val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd
@@ -87,216 +34,42 @@ val is_digit : char -> bool
 val is_ident_tail : char -> bool
 val is_blank : char -> bool
 
+(** {6 Empty type} *)
+
+module Empty :
+sig
+  type t
+  val abort : t -> 'a
+end
+
 (** {6 Strings. } *)
 
-val explode : string -> string list
-val implode : string list -> string
-val strip : string -> string
-val drop_simple_quotes : string -> string
-val string_index_from : string -> int -> string -> int
-val string_string_contains : where:string -> what:string -> bool
-val plural : int -> string -> string
-val ordinal : int -> string
-val split_string_at : char -> string -> string list
+module String : CString.ExtS
 
-val parse_loadpath : string -> string list
+(** Substitute %s in the first chain by the second chain *)
+val subst_command_placeholder : string -> string -> string
 
-module Stringset : Set.S with type elt = string
-module Stringmap : Map.S with type key = string
+(** {6 Lists. } *)
 
-type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
+module List : CList.ExtS
 
-exception UnsupportedUtf8
+val (@) : 'a list -> 'a list -> 'a list
 
-val classify_unicode : int -> utf8_status
-val check_ident : string -> unit
-val check_ident_soft : string -> unit
-val lowercase_first_char_utf8 : string -> string
-val ascii_of_ident : string -> string
+(** {6 Arrays. } *)
 
-(** {6 Lists. } *)
+module Array : CArray.ExtS
 
-val list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
-val list_equal : ('a -> 'a -> bool) -> 'a list -> 'a list -> bool
-val list_add_set : 'a -> 'a list -> 'a list
-val list_eq_set : 'a list -> 'a list -> bool
-val list_intersect : 'a list -> 'a list -> 'a list
-val list_union : 'a list -> 'a list -> 'a list
-val list_unionq : 'a list -> 'a list -> 'a list
-val list_subtract : 'a list -> 'a list -> 'a list
-val list_subtractq : 'a list -> 'a list -> 'a list
-
-(** [list_tabulate f n] builds [[f 0; ...; f (n-1)]] *)
-val list_tabulate : (int -> 'a) -> int -> 'a list
-val list_make : int -> 'a -> 'a list
-val list_assign : 'a list -> int -> 'a -> 'a list
-val list_distinct : 'a list -> bool
-val list_duplicates : 'a list -> 'a list
-val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
-val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
-val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
-val list_filter_with : bool list -> 'a list -> 'a list
-val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list
-
-(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
-   [ f ai == ai], then [list_smartmap f l==l] *)
-val list_smartmap : ('a -> 'a) -> 'a list -> 'a list
-val list_map_left : ('a -> 'b) -> 'a list -> 'b list
-val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
-val list_map2_i :
-  (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list
-val list_map3 :
-  ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
-val list_map4 :
-  ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
-val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array
-val list_filter_i :
-  (int -> 'a -> bool) -> 'a list -> 'a list
-
-(** [list_smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i
-   [f ai = true], then [list_smartfilter f l==l] *)
-val list_smartfilter : ('a -> bool) -> 'a list -> 'a list
-
-(** [list_index] returns the 1st index of an element in a list (counting from 1) *)
-val list_index : 'a -> 'a list -> int
-val list_index_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-
-(** [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *)
-val list_unique_index : 'a -> 'a list -> int
-
-(** [list_index0] behaves as [list_index] except that it starts counting at 0 *)
-val list_index0 : 'a -> 'a list -> int
-val list_index0_f : ('a -> 'a -> bool) -> 'a -> 'a list -> int
-val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit
-val list_iter_i :  (int -> 'a -> unit) -> 'a list -> unit
-val list_fold_right_i :  (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b
-val list_fold_left_i :  (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a
-val list_fold_right_and_left :
-    ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a
-val list_fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a
-val list_for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool
-val list_except : 'a -> 'a list -> 'a list
-val list_remove : 'a -> 'a list -> 'a list
-val list_remove_first : 'a -> 'a list -> 'a list
-val list_remove_assoc_in_triple : 'a -> ('a * 'b * 'c) list -> ('a * 'b * 'c) list
-val list_assoc_snd_in_triple : 'a -> ('a * 'b * 'c) list -> 'b
-val list_for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
-val list_sep_last : 'a list -> 'a * 'a list
-val list_try_find_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b
-val list_try_find : ('a -> 'b) -> 'a list -> 'b
-val list_uniquize : 'a list -> 'a list
-
-(** merges two sorted lists and preserves the uniqueness property: *)
-val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
-val list_subset : 'a list -> 'a list -> bool
-val list_chop : int -> 'a list -> 'a list * 'a list
-(* former [list_split_at] was a duplicate of [list_chop] *)
-val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
-val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
-val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
-val list_firstn : int -> 'a list -> 'a list
-val list_last : 'a list -> 'a
-val list_lastn : int -> 'a list -> 'a list
-val list_skipn : int -> 'a list -> 'a list
-val list_skipn_at_least : int -> 'a list -> 'a list
-val list_addn : int -> 'a -> 'a list -> 'a list
-val list_prefix_of : 'a list -> 'a list -> bool
-
-(** [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *)
-val list_drop_prefix : 'a list -> 'a list -> 'a list
-val list_drop_last : 'a list -> 'a list
-
-(** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)] *)
-val list_map_append : ('a -> 'b list) -> 'a list -> 'b list
-val list_join_map : ('a -> 'b list) -> 'a list -> 'b list
-
-(** raises [Invalid_argument] if the two lists don't have the same length *)
-val list_map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list
-val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list
-
-(** [list_fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]]
-   where [(e_i,k_i)=f e_{i-1} l_i] *)
-val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
-val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a
-val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
-val list_assoc_f : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
-
-(** A generic cartesian product: for any operator (**),
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
-   and so on if there are more elements in the lists. *)
-val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
-
-(** [list_cartesians] is an n-ary cartesian product: it iterates
-   [list_cartesian] over a list of lists.  *)
-val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
-
-(** list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
-val list_combinations : 'a list list -> 'a list list
-val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
-
-(** Keep only those products that do not return None *)
-val list_cartesian_filter :
-  ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
-val list_cartesians_filter :
-  ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
-
-val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
-val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list
+(** {6 Sets. } *)
 
-(** {6 Arrays. } *)
+module Set : module type of CSet
 
-val array_compare : ('a -> 'a -> int) -> 'a array -> 'a array -> int
-val array_equal : ('a -> 'a -> bool) -> 'a array -> 'a array -> bool
-val array_exists : ('a -> bool) -> 'a array -> bool
-val array_for_all : ('a -> bool) -> 'a array -> bool
-val array_for_all2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
-val array_for_all3 : ('a -> 'b -> 'c -> bool) ->
-  'a array -> 'b array -> 'c array -> bool
-val array_for_all4 : ('a -> 'b -> 'c -> 'd -> bool) ->
-  'a array -> 'b array -> 'c array -> 'd array -> bool
-val array_for_all_i : (int -> 'a -> bool) -> int -> 'a array -> bool
-val array_find_i : (int -> 'a -> bool) -> 'a array -> int option
-val array_hd : 'a array -> 'a
-val array_tl : 'a array -> 'a array
-val array_last : 'a array -> 'a
-val array_cons : 'a -> 'a array -> 'a array
-val array_rev : 'a array -> unit
-val array_fold_right_i :
-  (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a
-val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right2 :
-  ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
-val array_fold_left2 :
-  ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left3 :
-  ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b array -> 'c array -> 'd array -> 'a
-val array_fold_left2_i :
-  (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
-val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
-val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_app_tl : 'a array -> 'a list -> 'a list
-val array_list_of_tl : 'a array -> 'a list
-val array_map_to_list : ('a -> 'b) -> 'a array -> 'b list
-val array_chop : int -> 'a array -> 'a array * 'a array
-val array_smartmap : ('a -> 'a) -> 'a array -> 'a array
-val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
-val array_map3 :
-  ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array
-val array_map_left : ('a -> 'b) -> 'a array -> 'b array
-val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array ->
-  'b array * 'd array
-val array_iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
-val array_fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c
-val array_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array
-val array_fold_map2' :
-  ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c
-val array_distinct : 'a array -> bool
-val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
-val array_rev_to_list : 'a array -> 'a list
-val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array
-val array_filter_with : bool list -> 'a array -> 'a array
+(** {6 Maps. } *)
+
+module Map : module type of CMap
+
+(** {6 Stacks.} *)
+
+module Stack : module type of CStack
 
 (** {6 Streams. } *)
 
@@ -314,7 +87,7 @@ val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
 val const : 'a -> 'b -> 'a
 val iterate : ('a -> 'a) -> int -> 'a -> 'a
 val repeat : int -> ('a -> unit) -> 'a -> unit
-val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
+val app_opt : ('a -> 'a) option -> 'a -> 'a
 
 (** {6 Delayed computations. } *)
 
@@ -322,90 +95,18 @@ type 'a delayed = unit -> 'a
 
 val delayed_force : 'a delayed -> 'a
 
-(** {6 Misc. } *)
-
-type ('a,'b) union = Inl of 'a | Inr of 'b
-
-module Intset : Set.S with type elt = int
-
-module Intmap : Map.S with type key = int
-
-val intmap_in_dom : int -> 'a Intmap.t -> bool
-val intmap_to_list : 'a Intmap.t -> (int * 'a) list
-val intmap_inv : 'a Intmap.t -> 'a -> int list
-
-val interval : int -> int -> int list
-
-
-(** In [map_succeed f l] an element [a] is removed if [f a] raises 
-   [Failure _] otherwise behaves as [List.map f l] *)
+(** {6 Enriched exceptions} *)
 
-val map_succeed : ('a -> 'b) -> 'a list -> 'b list
+type iexn = Exninfo.iexn
 
-(** {6 Pretty-printing. } *)
+val iraise : iexn -> 'a
 
-val pr_spc : unit -> std_ppcmds
-val pr_fnl : unit -> std_ppcmds
-val pr_int : int -> std_ppcmds
-val pr_str : string -> std_ppcmds
-val pr_comma : unit -> std_ppcmds
-val pr_semicolon : unit -> std_ppcmds
-val pr_bar : unit -> std_ppcmds
-val pr_arg : ('a -> std_ppcmds) -> 'a -> std_ppcmds
-val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val pr_opt_no_spc : ('a -> std_ppcmds) -> 'a option -> std_ppcmds
-val nth : int -> std_ppcmds
-
-val prlist : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-
-(** unlike all other functions below, [prlist] works lazily.
-   if a strict behavior is needed, use [prlist_strict] instead. *)
-val prlist_strict :  ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val prlist_with_sep :
-   (unit -> std_ppcmds) -> ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val prvect : ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti : (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvect_with_sep :
-   (unit -> std_ppcmds) -> ('a -> std_ppcmds) -> 'a array -> std_ppcmds
-val prvecti_with_sep :
-   (unit -> std_ppcmds) -> (int -> 'a -> std_ppcmds) -> 'a array -> std_ppcmds
-val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds
-val pr_enum : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val pr_located : ('a -> std_ppcmds) -> 'a located -> std_ppcmds
-val pr_sequence : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
-val surround : std_ppcmds -> std_ppcmds
-
-(** {6 Memoization. } *)
-
-(** General comments on memoization:
-   - cache is created whenever the function is supplied (because of
-      ML's polymorphic value restriction).
-   - cache is never flushed (unless the memoized fun is GC'd)
- 
-   One cell memory: memorizes only the last call *)
-val memo1_1 : ('a -> 'b) -> ('a -> 'b)
-val memo1_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'c)
-
-(** with custom equality (used to deal with various arities) *)
-val memo1_eq : ('a -> 'a -> bool) -> ('a -> 'b) -> ('a -> 'b)
-
-(** Memorizes the last [n] distinct calls. Efficient only for small [n]. *)
-val memon_eq : ('a -> 'a -> bool) -> int -> ('a -> 'b) -> ('a -> 'b)
-
-(** {6 Size of an ocaml value (in words, bytes and kilobytes). } *)
-
-val size_w : 'a -> int
-val size_b : 'a -> int
-val size_kb : 'a -> int
-
-(** {6 Total size of the allocated ocaml heap. } *)
+(** {6 Misc. } *)
 
-val heap_size : unit -> int
-val heap_size_kb : unit -> int
+type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b
+(** Union type *)
 
-(** {6 ... } *)
-(** Coq interruption: set the following boolean reference to interrupt Coq
-    (it eventually raises [Break], simulating a Ctrl-C) *)
+val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union
 
-val interrupt : bool ref
-val check_for_interrupt : unit -> unit
+type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a
+(** Used for browsable-until structures. *)
diff --git a/lib/xml_datatype.mli b/lib/xml_datatype.mli
new file mode 100644
index 00000000..f61ba032
--- /dev/null
+++ b/lib/xml_datatype.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** ['a gxml] is the type for semi-structured documents. They generalize
+    XML by allowing any kind of attributes. *)
+type 'a gxml =
+  | Element of (string * 'a * 'a gxml list)
+  | PCData of string
+
+(** [xml] is a semi-structured documents where attributes are association
+    lists from string to string. *)
+type xml = (string * string) list gxml
+
+
diff --git a/lib/xml_lexer.mli b/lib/xml_lexer.mli
index a1ca0576..e61cb055 100644
--- a/lib/xml_lexer.mli
+++ b/lib/xml_lexer.mli
@@ -38,7 +38,7 @@ type token =
 type pos = int * int * int * int
 
 val init : Lexing.lexbuf -> unit 
-val close : Lexing.lexbuf -> unit
+val close : unit -> unit
 val token : Lexing.lexbuf -> token
 val pos : Lexing.lexbuf -> pos
-val restore : pos -> unit
\ No newline at end of file
+val restore : pos -> unit
diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll
index 5b06e720..a33be9da 100644
--- a/lib/xml_lexer.mll
+++ b/lib/xml_lexer.mll
@@ -20,24 +20,24 @@
 open Lexing
 
 type error =
-	| EUnterminatedComment
-	| EUnterminatedString
-	| EIdentExpected
-	| ECloseExpected
-	| ENodeExpected
-	| EAttributeNameExpected
-	| EAttributeValueExpected
-	| EUnterminatedEntity
+        | EUnterminatedComment
+        | EUnterminatedString
+        | EIdentExpected
+        | ECloseExpected
+        | ENodeExpected
+        | EAttributeNameExpected
+        | EAttributeValueExpected
+        | EUnterminatedEntity
 
 exception Error of error
 
 type pos = int * int * int * int
 
 type token =
-	| Tag of string * (string * string) list * bool
-	| PCData of string
-	| Endtag of string
-	| Eof
+        | Tag of string * (string * string) list * bool
+        | PCData of string
+        | Endtag of string
+        | Eof
 
 let last_pos = ref 0
 and current_line = ref 0
@@ -48,39 +48,40 @@ let tmp = Buffer.create 200
 let idents = Hashtbl.create 0
 
 let _ = begin
-	Hashtbl.add idents "gt;" ">";
-	Hashtbl.add idents "lt;" "<";
-	Hashtbl.add idents "amp;" "&";
-	Hashtbl.add idents "apos;" "'";
-	Hashtbl.add idents "quot;" "\"";
+        Hashtbl.add idents "nbsp;" " ";
+        Hashtbl.add idents "gt;" ">";
+        Hashtbl.add idents "lt;" "<";
+        Hashtbl.add idents "amp;" "&";
+        Hashtbl.add idents "apos;" "'";
+        Hashtbl.add idents "quot;" "\"";
 end
 
 let init lexbuf =
-	current_line := 1;
-	current_line_start := lexeme_start lexbuf;
-	last_pos := !current_line_start
+        current_line := 1;
+        current_line_start := lexeme_start lexbuf;
+        last_pos := !current_line_start
 
 let close lexbuf =
-	Buffer.reset tmp
+        Buffer.reset tmp
 
 let pos lexbuf =
-	!current_line ,	!current_line_start ,
-	!last_pos ,
-	lexeme_start lexbuf
+        !current_line , !current_line_start ,
+        !last_pos ,
+        lexeme_start lexbuf
 
 let restore (cl,cls,lp,_) =
-	current_line := cl;
-	current_line_start := cls;
-	last_pos := lp
+        current_line := cl;
+        current_line_start := cls;
+        last_pos := lp
 
 let newline lexbuf =
-	incr current_line;
-	last_pos := lexeme_end lexbuf;
-	current_line_start := !last_pos
+        incr current_line;
+        last_pos := lexeme_end lexbuf;
+        current_line_start := !last_pos
 
 let error lexbuf e =
-	last_pos := lexeme_start lexbuf;
-	raise (Error e)
+        last_pos := lexeme_start lexbuf;
+        raise (Error e)
 
 }
 
@@ -92,100 +93,100 @@ let entitychar = ['A'-'Z' 'a'-'z']
 let pcchar = [^ '\r' '\n' '<' '>' '&']
 
 rule token = parse
-	| newline | (newline break) | break
-		{
-			newline lexbuf;
+        | newline | (newline break) | break
+                {
+                        newline lexbuf;
                         PCData "\n"
-		}
-	| "<!--"
-		{
-			last_pos := lexeme_start lexbuf;
-			comment lexbuf;
-			token lexbuf
-		}
-	| "<?"
-		{
-			last_pos := lexeme_start lexbuf;
-			header lexbuf;
-			token lexbuf;
-		}
-	| '<' space* '/' space*
-		{
-			last_pos := lexeme_start lexbuf;
-			let tag = ident_name lexbuf in
-			ignore_spaces lexbuf;
-			close_tag lexbuf;
-			Endtag tag
-		}
-	| '<' space*
-		{
-			last_pos := lexeme_start lexbuf;
-			let tag = ident_name lexbuf in
-			ignore_spaces lexbuf;
-			let attribs, closed = attributes lexbuf in
-			Tag(tag, attribs, closed)
-		}
-	| "&#"
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (lexeme lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| '&'
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (entity lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| pcchar+
-		{
-			last_pos := lexeme_start lexbuf;
-			Buffer.reset tmp;
-			Buffer.add_string tmp (lexeme lexbuf);
-			PCData (pcdata lexbuf)
-		}
-	| eof { Eof }
-	| _
-		{ error lexbuf ENodeExpected }
+                }
+        | "<!--"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        comment lexbuf;
+                        token lexbuf
+                }
+        | "<?"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        header lexbuf;
+                        token lexbuf;
+                }
+        | '<' space* '/' space*
+                {
+                        last_pos := lexeme_start lexbuf;
+                        let tag = ident_name lexbuf in
+                        ignore_spaces lexbuf;
+                        close_tag lexbuf;
+                        Endtag tag
+                }
+        | '<' space*
+                {
+                        last_pos := lexeme_start lexbuf;
+                        let tag = ident_name lexbuf in
+                        ignore_spaces lexbuf;
+                        let attribs, closed = attributes lexbuf in
+                        Tag(tag, attribs, closed)
+                }
+        | "&#"
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | '&'
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (entity lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | pcchar+
+                {
+                        last_pos := lexeme_start lexbuf;
+                        Buffer.reset tmp;
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        PCData (pcdata lexbuf)
+                }
+        | eof { Eof }
+        | _
+                { error lexbuf ENodeExpected }
 
 and ignore_spaces = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			ignore_spaces lexbuf
-		}
-	| space +
-		{ ignore_spaces lexbuf }
-	| ""
-		{ () }
+                {
+                        newline lexbuf;
+                        ignore_spaces lexbuf
+                }
+        | space +
+                { ignore_spaces lexbuf }
+        | ""
+                { () }
 
 and comment = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			comment lexbuf
-		}
-	| "-->"
-		{ () }
-	| eof
-		{ raise (Error EUnterminatedComment) }
-	| _
-		{ comment lexbuf }
+                {
+                        newline lexbuf;
+                        comment lexbuf
+                }
+        | "-->"
+                { () }
+        | eof
+                { raise (Error EUnterminatedComment) }
+        | _
+                { comment lexbuf }
 
 and header = parse
         | newline | (newline break) | break
-		{
-			newline lexbuf;
-			header lexbuf
-		}
-	| "?>"
-		{ () }
-	| eof
-		{ error lexbuf ECloseExpected }
-	| _
-		{ header lexbuf }
+                {
+                        newline lexbuf;
+                        header lexbuf
+                }
+        | "?>"
+                { () }
+        | eof
+                { error lexbuf ECloseExpected }
+        | _
+                { header lexbuf }
 
 and pcdata = parse
         | newline | (newline break) | break
@@ -194,112 +195,112 @@ and pcdata = parse
                         newline lexbuf;
                         pcdata lexbuf
                 }
-	| pcchar+
-		{
-			Buffer.add_string tmp (lexeme lexbuf);
-			pcdata lexbuf
-		}
-	| "&#"
-		{
-			Buffer.add_string tmp (lexeme lexbuf);
-			pcdata lexbuf;
-		}
-	| '&'
-		{
-			Buffer.add_string tmp (entity lexbuf);
-			pcdata lexbuf
-		}
-	| ""
-		{ Buffer.contents tmp }
+        | pcchar+
+                {
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        pcdata lexbuf
+                }
+        | "&#"
+                {
+                        Buffer.add_string tmp (lexeme lexbuf);
+                        pcdata lexbuf;
+                }
+        | '&'
+                {
+                        Buffer.add_string tmp (entity lexbuf);
+                        pcdata lexbuf
+                }
+        | ""
+                { Buffer.contents tmp }
 
 and entity = parse
-	| entitychar+ ';'
-		{
-			let ident = lexeme lexbuf in
-			try
-				Hashtbl.find idents (String.lowercase ident)
-			with
-				Not_found -> "&" ^ ident
-		}
-	| _ | eof
-		{ raise (Error EUnterminatedEntity) }
+        | entitychar+ ';'
+                {
+                        let ident = lexeme lexbuf in
+                        try
+                                Hashtbl.find idents (String.lowercase ident)
+                        with
+                                Not_found -> "&" ^ ident
+                }
+        | _ | eof
+                { raise (Error EUnterminatedEntity) }
 
 and ident_name = parse
-	| identchar+
-		{ lexeme lexbuf }
-	| _ | eof
-		{ error lexbuf EIdentExpected }
+        | identchar+
+                { lexeme lexbuf }
+        | _ | eof
+                { error lexbuf EIdentExpected }
 
 and close_tag = parse
-	| '>'
-		{ () }
-	| _ | eof
-		{ error lexbuf ECloseExpected }
+        | '>'
+                { () }
+        | _ | eof
+                { error lexbuf ECloseExpected }
 
 and attributes = parse
-	| '>'
-		{ [], false }
-	| "/>"
-		{ [], true }
-	| "" (* do not read a char ! *)
-		{
-			let key = attribute lexbuf in
-			let data = attribute_data lexbuf in
-			ignore_spaces lexbuf;
-			let others, closed = attributes lexbuf in
-			(key, data) :: others, closed
-		}
+        | '>'
+                { [], false }
+        | "/>"
+                { [], true }
+        | "" (* do not read a char ! *)
+                {
+                        let key = attribute lexbuf in
+                        let data = attribute_data lexbuf in
+                        ignore_spaces lexbuf;
+                        let others, closed = attributes lexbuf in
+                        (key, data) :: others, closed
+                }
 
 and attribute = parse
-	| identchar+
-		{ lexeme lexbuf }
-	| _ | eof
-		{ error lexbuf EAttributeNameExpected }
+        | identchar+
+                { lexeme lexbuf }
+        | _ | eof
+                { error lexbuf EAttributeNameExpected }
 
 and attribute_data = parse
-	| space* '=' space* '"'
-		{
-			Buffer.reset tmp;
-			last_pos := lexeme_end lexbuf;
-			dq_string lexbuf
-		}
-	| space* '=' space* '\''
-		{
-			Buffer.reset tmp;
-			last_pos := lexeme_end lexbuf;
-			q_string lexbuf
-		}
-	| _ | eof
-		{ error lexbuf EAttributeValueExpected }
+        | space* '=' space* '"'
+                {
+                        Buffer.reset tmp;
+                        last_pos := lexeme_end lexbuf;
+                        dq_string lexbuf
+                }
+        | space* '=' space* '\''
+                {
+                        Buffer.reset tmp;
+                        last_pos := lexeme_end lexbuf;
+                        q_string lexbuf
+                }
+        | _ | eof
+                { error lexbuf EAttributeValueExpected }
 
 and dq_string = parse
-	| '"'
-		{ Buffer.contents tmp }
-	| '\\' [ '"' '\\' ]
-		{
-			Buffer.add_char tmp (lexeme_char lexbuf 1);
-			dq_string lexbuf
-		}
-	| eof
-		{ raise (Error EUnterminatedString) }
-	| _
-		{ 
-			Buffer.add_char tmp (lexeme_char lexbuf 0);
-			dq_string lexbuf
-		}
+        | '"'
+                { Buffer.contents tmp }
+        | '\\' [ '"' '\\' ]
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 1);
+                        dq_string lexbuf
+                }
+        | eof
+                { raise (Error EUnterminatedString) }
+        | _
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 0);
+                        dq_string lexbuf
+                }
 
 and q_string = parse
-	| '\''
-		{ Buffer.contents tmp }
-	| '\\' [ '\'' '\\' ]
-		{
-			Buffer.add_char tmp (lexeme_char lexbuf 1);
-			q_string lexbuf
-		}
-	| eof
-		{ raise (Error EUnterminatedString) }
-	| _
-		{ 
-			Buffer.add_char tmp (lexeme_char lexbuf 0);
-			q_string lexbuf
-		}
+        | '\''
+                { Buffer.contents tmp }
+        | '\\' [ '\'' '\\' ]
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 1);
+                        q_string lexbuf
+                }
+        | eof
+                { raise (Error EUnterminatedString) }
+        | _
+                {
+                        Buffer.add_char tmp (lexeme_char lexbuf 0);
+                        q_string lexbuf
+                }
diff --git a/lib/xml_parser.ml b/lib/xml_parser.ml
index 600796f7..8db3f9e8 100644
--- a/lib/xml_parser.ml
+++ b/lib/xml_parser.ml
@@ -19,30 +19,29 @@
  *)
 
 open Printf
+open Xml_datatype
 
-type xml = 
-        | Element of (string * (string * string) list * xml list)
-        | PCData of string
+type xml = Xml_datatype.xml
 
 type error_pos = {
-        eline : int;
-        eline_start : int;
-        emin : int;
-        emax : int;
+  eline : int;
+  eline_start : int;
+  emin : int;
+  emax : int;
 }
 
 type error_msg =
-        | UnterminatedComment
-        | UnterminatedString
-        | UnterminatedEntity
-        | IdentExpected
-        | CloseExpected
-        | NodeExpected
-        | AttributeNameExpected
-        | AttributeValueExpected
-        | EndOfTagExpected of string
-        | EOFExpected
-	| Empty
+  | UnterminatedComment
+  | UnterminatedString
+  | UnterminatedEntity
+  | IdentExpected
+  | CloseExpected
+  | NodeExpected
+  | AttributeNameExpected
+  | AttributeValueExpected
+  | EndOfTagExpected of string
+  | EOFExpected
+  | Empty
 
 type error = error_msg * error_pos
 
@@ -51,21 +50,16 @@ exception Error of error
 exception File_not_found of string
 
 type t = {
-	mutable check_eof : bool;
-	mutable concat_pcdata : bool;
+  mutable check_eof : bool;
+  mutable concat_pcdata : bool;
+  source : Lexing.lexbuf;
+  stack : Xml_lexer.token Stack.t;
 }
 
-type source = 
-	| SFile of string
-	| SChannel of in_channel
-	| SString of string
-	| SLexbuf of Lexing.lexbuf
-
-type state = {
-	source : Lexing.lexbuf;
-	stack : Xml_lexer.token Stack.t;
-	xparser : t;
-}
+type source =
+  | SChannel of in_channel
+  | SString of string
+  | SLexbuf of Lexing.lexbuf
 
 exception Internal_error of error_msg
 exception NoMoreData
@@ -86,152 +80,153 @@ let is_blank s =
   !i = len
 
 let _raises e f =
-	xml_error := e;
-	file_not_found := f
-
-let make () =
-	{
-		check_eof = true;
-		concat_pcdata = true;
-	}
+  xml_error := e;
+  file_not_found := f
+
+let make source =
+  let source = match source with
+    | SChannel chan -> Lexing.from_channel chan
+    | SString s -> Lexing.from_string s
+    | SLexbuf lexbuf -> lexbuf
+  in
+  let () = Xml_lexer.init source in
+  {
+    check_eof = false;
+    concat_pcdata = true;
+    source = source;
+    stack = Stack.create ();
+  }
 
 let check_eof p v = p.check_eof <- v
-let concat_pcdata p v = p.concat_pcdata <- v
 
 let pop s =
-	try
-		Stack.pop s.stack
-	with
-		Stack.Empty ->
-			Xml_lexer.token s.source
+  try
+    Stack.pop s.stack
+  with
+      Stack.Empty ->
+        Xml_lexer.token s.source
 
 let push t s =
-	Stack.push t s.stack
+  Stack.push t s.stack
 
 let canonicalize l =
   let has_elt = List.exists (function Element _ -> true | _ -> false) l in
   if has_elt then List.filter (function PCData s -> not (is_blank s) | _ -> true) l
   else l
 
-let rec read_node s =
-	match pop s with
-	| Xml_lexer.PCData s -> PCData s
-	| Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
-	| Xml_lexer.Tag (tag, attr, false) ->
-          let elements = read_elems tag s in
-          Element (tag, attr, canonicalize elements)
-	| t ->
-		push t s;
-		raise NoMoreData
-and
-	read_elems tag s =
-		let elems = ref [] in
-		(try
-                  while true do
-                    let node = read_node s in
-                    match node, !elems with
-                    | PCData c , (PCData c2) :: q ->
-                      elems := PCData (c2 ^ c) :: q
-                    | _, l ->
-                      elems := node :: l
-                  done
-		with
-			NoMoreData -> ());
-		match pop s with
-		| Xml_lexer.Endtag s when s = tag -> List.rev !elems
-		| t -> raise (Internal_error (EndOfTagExpected tag))
-
-let rec read_xml s =
-  let node = read_node s in
-  match node with
-  | Element _ -> node
-  | PCData c ->
-    if is_blank c then read_xml s
-    else raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
+let rec read_xml do_not_canonicalize s =
+  let rec read_node s =
+    match pop s with
+      | Xml_lexer.PCData s -> PCData s
+      | Xml_lexer.Tag (tag, attr, true) -> Element (tag, attr, [])
+      | Xml_lexer.Tag (tag, attr, false) ->
+        let elements = read_elems tag s in
+        let elements =
+          if do_not_canonicalize then elements else canonicalize elements
+        in
+        Element (tag, attr, elements)
+      | t ->
+        push t s;
+        raise NoMoreData
+
+  and read_elems tag s =
+    let elems = ref [] in
+    (try
+       while true do
+         let node = read_node s in
+         match node, !elems with
+           | PCData c , (PCData c2) :: q ->
+             elems := PCData (c2 ^ c) :: q
+           | _, l ->
+             elems := node :: l
+       done
+     with
+         NoMoreData -> ());
+    match pop s with
+      | Xml_lexer.Endtag s when s = tag -> List.rev !elems
+      | t -> raise (Internal_error (EndOfTagExpected tag))
+  in
+  match read_node s with
+    | (Element _) as node ->
+      node
+    | PCData c ->
+      if is_blank c then
+        read_xml do_not_canonicalize s
+      else
+        raise (Xml_lexer.Error Xml_lexer.ENodeExpected)
 
 let convert = function
-	| Xml_lexer.EUnterminatedComment -> UnterminatedComment
-	| Xml_lexer.EUnterminatedString -> UnterminatedString
-	| Xml_lexer.EIdentExpected -> IdentExpected
-	| Xml_lexer.ECloseExpected -> CloseExpected
-	| Xml_lexer.ENodeExpected -> NodeExpected
-	| Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
-	| Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
-	| Xml_lexer.EUnterminatedEntity -> 	UnterminatedEntity
-
-let error_of_exn stk = function
-  | NoMoreData when Stack.pop stk = Xml_lexer.Eof -> Empty
+  | Xml_lexer.EUnterminatedComment -> UnterminatedComment
+  | Xml_lexer.EUnterminatedString -> UnterminatedString
+  | Xml_lexer.EIdentExpected -> IdentExpected
+  | Xml_lexer.ECloseExpected -> CloseExpected
+  | Xml_lexer.ENodeExpected -> NodeExpected
+  | Xml_lexer.EAttributeNameExpected -> AttributeNameExpected
+  | Xml_lexer.EAttributeValueExpected -> AttributeValueExpected
+  | Xml_lexer.EUnterminatedEntity ->      UnterminatedEntity
+
+let error_of_exn xparser = function
+  | NoMoreData when pop xparser = Xml_lexer.Eof -> Empty
   | NoMoreData -> NodeExpected
   | Internal_error e -> e
   | Xml_lexer.Error e -> convert e
-  | e -> raise e
-
-let do_parse xparser source =
-        let stk = Stack.create() in
-	try
-		Xml_lexer.init source;
-		let s = { source = source; xparser = xparser; stack = stk } in
-		let x = read_xml s in
-		if xparser.check_eof && pop s <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
-		Xml_lexer.close source;
-		x
-	with e when e <> Sys.Break ->
-	  Xml_lexer.close source;
-	  raise (!xml_error (error_of_exn stk e) source)
-
-let parse p = function
-	| SChannel ch -> do_parse p (Lexing.from_channel ch)
-	| SString str -> do_parse p (Lexing.from_string str)
-	| SLexbuf lex -> do_parse p lex
-	| SFile fname ->
-		let ch = (try open_in fname with Sys_error _ -> raise (!file_not_found fname)) in
-		try
-			let x = do_parse p (Lexing.from_channel ch) in
-			close_in ch;
-			x
-		with
-			reraise ->
-				close_in ch;
-				raise reraise
-
+  | e ->
+    (*let e = Errors.push e in: We do not record backtrace here. *)
+    raise e
+
+let do_parse do_not_canonicalize xparser =
+  try
+    Xml_lexer.init xparser.source;
+    let x = read_xml do_not_canonicalize xparser in
+    if xparser.check_eof && pop xparser <> Xml_lexer.Eof then raise (Internal_error EOFExpected);
+    Xml_lexer.close ();
+    x
+  with any ->
+    Xml_lexer.close ();
+    raise (!xml_error (error_of_exn xparser any) xparser.source)
+
+let parse ?(do_not_canonicalize=false) p =
+  do_parse do_not_canonicalize p
 
 let error_msg = function
-        | UnterminatedComment -> "Unterminated comment"
-        | UnterminatedString -> "Unterminated string"
-        | UnterminatedEntity -> "Unterminated entity"
-        | IdentExpected -> "Ident expected"
-        | CloseExpected -> "Element close expected"
-        | NodeExpected -> "Xml node expected"
-        | AttributeNameExpected -> "Attribute name expected"
-        | AttributeValueExpected -> "Attribute value expected"
-        | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
-        | EOFExpected -> "End of file expected"
-	| Empty -> "Empty"
+  | UnterminatedComment -> "Unterminated comment"
+  | UnterminatedString -> "Unterminated string"
+  | UnterminatedEntity -> "Unterminated entity"
+  | IdentExpected -> "Ident expected"
+  | CloseExpected -> "Element close expected"
+  | NodeExpected -> "Xml node expected"
+  | AttributeNameExpected -> "Attribute name expected"
+  | AttributeValueExpected -> "Attribute value expected"
+  | EndOfTagExpected tag -> sprintf "End of tag expected : '%s'" tag
+  | EOFExpected -> "End of file expected"
+  | Empty -> "Empty"
 
 let error (msg,pos) =
-        if pos.emin = pos.emax then
-                sprintf "%s line %d character %d" (error_msg msg) pos.eline (pos.emin - pos.eline_start)
-        else
-                sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
-        
+  if pos.emin = pos.emax then
+    sprintf "%s line %d character %d" (error_msg msg) pos.eline
+      (pos.emin - pos.eline_start)
+  else
+    sprintf "%s line %d characters %d-%d" (error_msg msg) pos.eline
+      (pos.emin - pos.eline_start) (pos.emax - pos.eline_start)
+
 let line e = e.eline
 
-let range e = 
-        e.emin - e.eline_start , e.emax - e.eline_start
+let range e =
+  e.emin - e.eline_start , e.emax - e.eline_start
 
 let abs_range e =
-        e.emin , e.emax
+  e.emin , e.emax
 
 let pos source =
-        let line, lstart, min, max = Xml_lexer.pos source in
-        {
-                eline = line;
-                eline_start = lstart;
-                emin = min;
-                emax = max;
-        }
-
-let () = _raises (fun x p -> 
+  let line, lstart, min, max = Xml_lexer.pos source in
+  {
+    eline = line;
+    eline_start = lstart;
+    emin = min;
+    emax = max;
+  }
+
+let () = _raises (fun x p ->
         (* local cast : Xml.error_msg -> error_msg *)
-        Error (x, pos p))
-        (fun f -> File_not_found f)
+  Error (x, pos p))
+  (fun f -> File_not_found f)
diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli
index cc9bcd33..cefb4af8 100644
--- a/lib/xml_parser.mli
+++ b/lib/xml_parser.mli
@@ -27,9 +27,7 @@
 
 (** An Xml node is either
         [Element (tag-name, attributes, children)] or [PCData text] *)
-type xml = 
-        | Element of (string * (string * string) list * xml list)
-        | PCData of string
+type xml = Xml_datatype.xml
 
 (** Abstract type for an Xml parser. *)
 type t
@@ -59,7 +57,7 @@ type error_msg =
         | AttributeValueExpected
         | EndOfTagExpected of string
         | EOFExpected
-	| Empty
+        | Empty
 
 type error = error_msg * error_pos
 
@@ -71,7 +69,7 @@ exception File_not_found of string
 val error : error -> string
 
 (** Get the Xml error message as a string. *)
-val error_msg : error_msg -> string 
+val error_msg : error_msg -> string
 
 (** Get the line the error occured at. *)
 val line : error_pos -> int
@@ -85,21 +83,24 @@ val abs_range : error_pos -> int * int
 val pos : Lexing.lexbuf -> error_pos
 
 (** Several kind of resources can contain Xml documents. *)
-type source = 
-	| SFile of string
-	| SChannel of in_channel
-	| SString of string
-	| SLexbuf of Lexing.lexbuf
+type source =
+| SChannel of in_channel
+| SString of string
+| SLexbuf of Lexing.lexbuf
 
 (** This function returns a new parser with default options. *)
-val make : unit -> t
+val make : source -> t
 
-(** When a Xml document is parsed, the parser will check that the end of the
+(** When a Xml document is parsed, the parser may check that the end of the
  document is reached, so for example parsing ["<A/><B/>"] will fail instead
- of returning only the A element. You can turn off this check by setting
- [check_eof] to [false] {i (by default, check_eof is true)}. *)
+ of returning only the A element. You can turn on this check by setting
+ [check_eof] to [true] {i (by default, check_eof is false, unlike
+ in the original Xmllight)}. *)
 val check_eof : t -> bool -> unit
 
 (** Once the parser is configurated, you can run the parser on a any kind
- of xml document source to parse its contents into an Xml data structure. *)
-val parse :  t -> source -> xml
+    of xml document source to parse its contents into an Xml data structure.
+
+    When [do_not_canonicalize] is set, the XML document is given as
+    is, without trying to remove blank PCDATA elements. *)
+val parse : ?do_not_canonicalize:bool -> t -> xml
diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml
new file mode 100644
index 00000000..eeddd53c
--- /dev/null
+++ b/lib/xml_printer.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(*  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 Xml_datatype
+
+type xml = Xml_datatype.xml
+
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+type t = target
+
+let make x = x
+
+let buffer_pcdata tmp text =
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let l = String.length text in
+  for p = 0 to l-1 do
+    match text.[p] with
+      | ' ' -> output "&nbsp;";
+      | '>' -> output "&gt;"
+      | '<' -> output "&lt;"
+      | '&' ->
+        if p < l - 1 && text.[p + 1] = '#' then
+          output' '&'
+        else
+          output "&amp;"
+      | '\'' -> output "&apos;"
+      | '"' -> output "&quot;"
+      | c -> output' c
+  done
+
+let buffer_attr tmp (n,v) =
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  output' ' ';
+  output n;
+  output "=\"";
+  let l = String.length v in
+  for p = 0 to l - 1 do
+    match v.[p] with
+      | '\\' -> output "\\\\"
+      | '"' -> output "\\\""
+      | c -> output' c
+  done;
+  output' '"'
+
+let to_buffer tmp x =
+  let pcdata = ref false in
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let rec loop = function
+    | Element (tag,alist,[]) ->
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output "/>";
+      pcdata := false;
+    | Element (tag,alist,l) ->
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output' '>';
+      pcdata := false;
+      List.iter loop l;
+      output "</";
+      output tag;
+      output' '>';
+      pcdata := false;
+    | PCData text ->
+      if !pcdata then output' ' ';
+      buffer_pcdata tmp text;
+      pcdata := true;
+  in
+  loop x
+
+let pcdata_to_string s =
+  let b = Buffer.create 13 in
+  buffer_pcdata b s;
+  Buffer.contents b
+
+let to_string x =
+  let b = Buffer.create 200 in
+  to_buffer b x;
+  Buffer.contents b
+
+let to_string_fmt x =
+  let tmp = Buffer.create 200 in
+  let output = Buffer.add_string tmp in
+  let output' = Buffer.add_char tmp in
+  let rec loop ?(newl=false) tab = function
+    | Element (tag, alist, []) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output "/>";
+      if newl then output' '\n';
+    | Element (tag, alist, [PCData text]) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output ">";
+      buffer_pcdata tmp text;
+      output "</";
+      output tag;
+      output' '>';
+      if newl then output' '\n';
+    | Element (tag, alist, l) ->
+      output tab;
+      output' '<';
+      output tag;
+      List.iter (buffer_attr tmp) alist;
+      output ">\n";
+      List.iter (loop ~newl:true (tab^"  ")) l;
+      output tab;
+      output "</";
+      output tag;
+      output' '>';
+      if newl then output' '\n';
+    | PCData text ->
+      buffer_pcdata tmp text;
+      if newl then output' '\n';
+  in
+  loop "" x;
+  Buffer.contents tmp
+
+let print t xml =
+  let tmp, flush = match t with
+    | TChannel oc ->
+      let b = Buffer.create 200 in
+      b, (fun () -> Buffer.output_buffer oc b; flush oc)
+    | TBuffer b ->
+      b, (fun () -> ())
+  in
+  to_buffer tmp xml;
+  flush ()
diff --git a/lib/xml_printer.mli b/lib/xml_printer.mli
new file mode 100644
index 00000000..e21eca28
--- /dev/null
+++ b/lib/xml_printer.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  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 xml = Xml_datatype.xml
+
+type t
+type target = TChannel of out_channel | TBuffer of Buffer.t
+
+val make : target -> t
+
+(** Print the xml data structure to a source into a compact xml string (without
+ any user-readable formating ). *)
+val print : t -> xml -> unit
+
+(** Print the xml data structure into a compact xml string (without
+ any user-readable formating ). *)
+val to_string : xml -> string
+
+(** Print the xml data structure into an user-readable string with
+ tabs and lines break between different nodes. *)
+val to_string_fmt : xml -> string
+
+(** Print PCDATA as a string by escaping XML entities. *)
+val pcdata_to_string : string -> string
diff --git a/lib/xml_utils.ml b/lib/xml_utils.ml
deleted file mode 100644
index 31003586..00000000
--- a/lib/xml_utils.ml
+++ /dev/null
@@ -1,223 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
-
-open Printf
-open Xml_parser
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-let default_parser = Xml_parser.make()
-
-let parse (p:Xml_parser.t) (source:Xml_parser.source) =
-	(* local cast Xml.xml -> xml *)
-	(Obj.magic Xml_parser.parse p source : xml)
-
-let parse_in ch = parse default_parser (Xml_parser.SChannel ch)
-let parse_string str = parse default_parser (Xml_parser.SString str)
-
-let parse_file f = parse default_parser (Xml_parser.SFile f)
-
-let tag = function
-	| Element (tag,_,_) -> tag
-	| x -> raise (Not_element x)
-
-let pcdata = function 
-	| PCData text -> text
-	| x -> raise (Not_pcdata x)
-
-let attribs = function 
-	| Element (_,attr,_) -> attr
-	| x -> raise (Not_element x)
-
-let attrib x att =
-	match x with
-	| Element (_,attr,_) ->
-		(try
-			let att = String.lowercase att in
-			snd (List.find (fun (n,_) -> String.lowercase n = att) attr)
-		with
-			Not_found ->
-				raise (No_attribute att))
-	| x ->
-		raise (Not_element x)
-
-let children = function
-	| Element (_,_,clist) -> clist
-	| x -> raise (Not_element x)
-
-(*let enum = function
-	| Element (_,_,clist) -> List.to_enum clist
-	| x -> raise (Not_element x)
-*)
-
-let iter f = function
-	| Element (_,_,clist) -> List.iter f clist
-	| x -> raise (Not_element x)
-
-let map f = function
-	| Element (_,_,clist) -> List.map f clist
-	| x -> raise (Not_element x)
-
-let fold f v = function
-	| Element (_,_,clist) -> List.fold_left f v clist
-	| x -> raise (Not_element x)
-
-let tmp = Buffer.create 200
-
-let buffer_pcdata text =
-	let l = String.length text in
-	for p = 0 to l-1 do 
-		match text.[p] with
-		| '>' -> Buffer.add_string tmp "&gt;"
-		| '<' -> Buffer.add_string tmp "&lt;"
-		| '&' ->
-			if p < l-1 && text.[p+1] = '#' then
-				Buffer.add_char tmp '&'
-			else
-				Buffer.add_string tmp "&amp;"
-		| '\'' -> Buffer.add_string tmp "&apos;"
-		| '"' -> Buffer.add_string tmp "&quot;"
-		| c -> Buffer.add_char tmp c
-	done
-
-let print_pcdata chan text =
-  let l = String.length text in
-  for p = 0 to l-1 do 
-    match text.[p] with
-    | '>' -> Printf.fprintf chan "&gt;"
-    | '<' -> Printf.fprintf chan "&lt;"
-    | '&' ->
-            if p < l-1 && text.[p+1] = '#' then
-                    Printf.fprintf chan "&"
-            else
-                    Printf.fprintf chan "&amp;"
-    | '\'' -> Printf.fprintf chan "&apos;"
-    | '"' -> Printf.fprintf chan "&quot;"
-    | c -> Printf.fprintf chan "%c" c
-  done
-
-let buffer_attr (n,v) =
-	Buffer.add_char tmp ' ';
-	Buffer.add_string tmp n;
-	Buffer.add_string tmp "=\"";
-	let l = String.length v in
-	for p = 0 to l-1 do
-		match v.[p] with
-		| '\\' -> Buffer.add_string tmp "\\\\"
-		| '"' -> Buffer.add_string tmp "\\\""
-		| c -> Buffer.add_char tmp c
-	done;
-	Buffer.add_char tmp '"'
-
-let rec print_attr chan (n, v) =
-  Printf.fprintf chan " %s=\"" n;
-  let l = String.length v in
-  for p = 0 to l-1 do
-          match v.[p] with
-          | '\\' -> Printf.fprintf chan "\\\\"
-          | '"' -> Printf.fprintf chan  "\\\""
-          | c -> Printf.fprintf chan "%c" c
-  done;
-  Printf.fprintf chan "\""
-
-let print_attrs chan l = List.iter (print_attr chan) l
-
-let rec print_xml chan = function
-| Element (tag, alist, []) ->
-  Printf.fprintf chan "<%s%a/>" tag print_attrs alist;
-| Element (tag, alist, l) ->
-  Printf.fprintf chan "<%s%a>%a</%s>" tag print_attrs alist
-  (fun chan -> List.iter (print_xml chan)) l tag
-| PCData text ->
-  print_pcdata chan text
-
-let to_string x = 
-	let pcdata = ref false in
-	let rec loop = function
-		| Element (tag,alist,[]) ->
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp "/>";
-			pcdata := false;
-		| Element (tag,alist,l) ->
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_char tmp '>';
-			pcdata := false;
-			List.iter loop l;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			pcdata := false;
-		| PCData text ->
-			if !pcdata then Buffer.add_char tmp ' ';
-			buffer_pcdata text;
-			pcdata := true;
-	in
-	Buffer.reset tmp;
-	loop x;
-	let s = Buffer.contents tmp in
-	Buffer.reset tmp;
-	s
-
-let to_string_fmt x =
-	let rec loop ?(newl=false) tab = function
-		| Element (tag,alist,[]) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp "/>";
-			if newl then Buffer.add_char tmp '\n';
-		| Element (tag,alist,[PCData text]) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp ">";
-			buffer_pcdata text;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			if newl then Buffer.add_char tmp '\n';
-		| Element (tag,alist,l) ->
-			Buffer.add_string tmp tab;
-			Buffer.add_char tmp '<';
-			Buffer.add_string tmp tag;
-			List.iter buffer_attr alist;
-			Buffer.add_string tmp ">\n";
-			List.iter (loop ~newl:true (tab^"  ")) l;
-			Buffer.add_string tmp tab;
-			Buffer.add_string tmp "</";
-			Buffer.add_string tmp tag;
-			Buffer.add_char tmp '>';
-			if newl then Buffer.add_char tmp '\n';
-		| PCData text ->
-			buffer_pcdata text;
-			if newl then Buffer.add_char tmp '\n';
-	in
-	Buffer.reset tmp;
-	loop "" x;
-	let s = Buffer.contents tmp in
-	Buffer.reset tmp;
-	s
diff --git a/lib/xml_utils.mli b/lib/xml_utils.mli
deleted file mode 100644
index 4a4a1309..00000000
--- a/lib/xml_utils.mli
+++ /dev/null
@@ -1,93 +0,0 @@
-(*
- * Xml Light, an small Xml parser/printer with DTD support.
- * Copyright (C) 2003 Nicolas Cannasse (ncannasse@motion-twin.com)
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
- *)
-
-(** Xml Light
- 
-  Xml Light is a minimal Xml parser & printer for OCaml.
-  It provide few functions to parse a basic Xml document into
-  an OCaml data structure and to print back the data structures
-  to an Xml document.
-
-  Xml Light has also support for {b DTD} (Document Type Definition).
-
-  {i (c)Copyright 2002-2003 Nicolas Cannasse}
-*)
-
-open Xml_parser
-
-(** {6 Xml Functions} *)
-
-exception Not_element of xml
-exception Not_pcdata of xml
-exception No_attribute of string
-
-(** [tag xdata] returns the tag value of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val tag : xml -> string
-
-(** [pcdata xdata] returns the PCData value of the xml node.
- Raise {!Xml.Not_pcdata} if the xml is not a PCData *)
-val pcdata : xml -> string
-
-(** [attribs xdata] returns the attribute list of the xml node.
- First string if the attribute name, second string is attribute value.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attribs : xml -> (string * string) list 
-
-(** [attrib xdata "href"] returns the value of the ["href"]
- attribute of the xml node (attribute matching is case-insensitive).
- Raise {!Xml.No_attribute} if the attribute does not exists in the node's
- attribute list 
- Raise {!Xml.Not_element} if the xml is not an element *)
-val attrib : xml -> string -> string
-
-(** [children xdata] returns the children list of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-val children : xml -> xml list
-
-(*** [enum xdata] returns the children enumeration of the xml node
- Raise {!Xml.Not_element} if the xml is not an element *)
-(* val enum : xml -> xml Enum.t *)
-
-(** [iter f xdata] calls f on all children of the xml node.
- Raise {!Xml.Not_element} if the xml is not an element *)
-val iter : (xml -> unit) -> xml -> unit
-
-(** [map f xdata] is equivalent to [List.map f (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val map : (xml -> 'a) -> xml -> 'a list
-
-(** [fold f init xdata] is equivalent to
- [List.fold_left f init (Xml.children xdata)]
- Raise {!Xml.Not_element} if the xml is not an element *)
-val fold : ('a -> xml -> 'a) -> 'a -> xml -> 'a
-
-(** {6 Xml Printing} *)
-
-(** Print the xml data structure to a channel into a compact xml string (without
- any user-readable formating ). *)
-val print_xml : out_channel -> xml -> unit
-
-(** Print the xml data structure into a compact xml string (without
- any user-readable formating ). *)
-val to_string : xml -> string
-
-(** Print the xml data structure into an user-readable string with
- tabs and lines break between different nodes. *)
-val to_string_fmt : xml -> string
diff --git a/library/assumptions.ml b/library/assumptions.ml
index 273ddb55..04ee14fb 100644
--- a/library/assumptions.ml
+++ b/library/assumptions.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        *)
@@ -14,20 +14,19 @@
 (* Initial author: Arnaud Spiwack
    Module-traversing code: Pierre Letouzey *)
 
+open Pp
+open Errors
 open Util
 open Names
-open Sign
-open Univ
 open Term
 open Declarations
 open Mod_subst
 
-let cst_ord k1 k2 = kn_ord (canonical_con k1) (canonical_con k2)
-
 type context_object =
-  | Variable of identifier (* A section variable or a Let definition *)
+  | Variable of Id.t (* A section variable or a Let definition *)
   | Axiom of constant      (* An axiom or a constant. *)
   | Opaque of constant     (* An opaque constant. *)
+  | Transparent of constant
 
 (* Defines a set of [assumption] *)
 module OrderedContextObject =
@@ -35,13 +34,17 @@ struct
   type t = context_object
   let compare x y =
       match x , y with
-      | Variable i1 , Variable i2 -> id_ord i1 i2
-      | Axiom k1 , Axiom k2 -> cst_ord k1 k2
-      | Opaque k1 , Opaque k2 -> cst_ord k1 k2
-      | Variable _ , Axiom _ -> -1
+      | Variable i1 , Variable i2 -> Id.compare i1 i2
+      | Axiom k1 , Axiom k2 -> con_ord k1 k2
+      | Opaque k1 , Opaque k2 -> con_ord k1 k2
+      | Transparent k1 , Transparent k2 -> con_ord k1 k2
       | Axiom _ , Variable _ -> 1
-      | Opaque _ , _ -> -1
-      | _, Opaque _ -> 1
+      | Opaque _ , Variable _
+      | Opaque _ , Axiom _ -> 1
+      | Transparent _ , Variable _
+      | Transparent _ , Axiom _
+      | Transparent _ , Opaque _ -> 1
+      | _ , _ -> -1
 end
 
 module ContextObjectSet = Set.Make (OrderedContextObject)
@@ -56,14 +59,31 @@ let modcache = ref (MPmap.empty : structure_body MPmap.t)
 
 let rec search_mod_label lab = function
   | [] -> raise Not_found
-  | (l,SFBmodule mb) :: _ when l = lab -> mb
+  | (l, SFBmodule mb) :: _ when Label.equal l lab -> mb
   | _ :: fields -> search_mod_label lab fields
 
 let rec search_cst_label lab = function
   | [] -> raise Not_found
-  | (l,SFBconst cb) :: _ when l = lab -> cb
+  | (l, SFBconst cb) :: _ when Label.equal l lab -> cb
   | _ :: fields -> search_cst_label lab fields
 
+(* TODO: using [empty_delta_resolver] below is probably slightly incorrect. But:
+    a) I don't see currently what should be used instead
+    b) this shouldn't be critical for Print Assumption. At worse some
+       constants will have a canonical name which is non-canonical,
+       leading to failures in [Global.lookup_constant], but our own
+       [lookup_constant] should work.
+*)
+
+let rec fields_of_functor f subs mp0 args = function
+  |NoFunctor a -> f subs mp0 args a
+  |MoreFunctor (mbid,_,e) ->
+    match args with
+    | [] -> assert false (* we should only encounter applied functors *)
+    | mpa :: args ->
+      let subs = add_mbid mbid mpa empty_delta_resolver (*TODO*) subs in
+      fields_of_functor f subs mp0 args e
+
 let rec lookup_module_in_impl mp =
   try Global.lookup_module mp
   with Not_found ->
@@ -87,46 +107,32 @@ and fields_of_mp mp =
   let mb = lookup_module_in_impl mp in
   let fields,inner_mp,subs = fields_of_mb empty_subst mb [] in
   let subs =
-    if inner_mp = mp then subs
+    if mp_eq inner_mp mp then subs
     else add_mp inner_mp mp mb.mod_delta subs
   in
-  Modops.subst_signature subs fields
+  Modops.subst_structure subs fields
 
-and fields_of_mb subs mb args =
-  let seb = match mb.mod_expr with
-    | None -> mb.mod_type (* cf. Declare Module *)
-    | Some seb -> seb
-  in
-  fields_of_seb subs mb.mod_mp seb args
+and fields_of_mb subs mb args = match mb.mod_expr with
+  |Algebraic expr -> fields_of_expression subs mb.mod_mp args expr
+  |Struct sign -> fields_of_signature subs mb.mod_mp args sign
+  |Abstract|FullStruct -> fields_of_signature subs mb.mod_mp args mb.mod_type
 
-(* TODO: using [empty_delta_resolver] below in [fields_of_seb]
-   is probably slightly incorrect. But:
-    a) I don't see currently what should be used instead
-    b) this shouldn't be critical for Print Assumption. At worse some
-       constants will have a canonical name which is non-canonical,
-       leading to failures in [Global.lookup_constant], but our own
-       [lookup_constant] should work.
-*)
+(** The Abstract case above corresponds to [Declare Module] *)
 
-and fields_of_seb subs mp0 seb args = match seb with
-  | SEBstruct l ->
-    assert (args = []);
-    l, mp0, subs
-  | SEBident mp ->
+and fields_of_signature x =
+  fields_of_functor
+    (fun subs mp0 args struc ->
+      assert (List.is_empty args);
+      (struc, mp0, subs)) x
+
+and fields_of_expr subs mp0 args = function
+  |MEident mp ->
     let mb = lookup_module_in_impl (subst_mp subs mp) in
     fields_of_mb subs mb args
-  | SEBapply (seb1,seb2,_) ->
-    (match seb2 with
-      | SEBident mp2 -> fields_of_seb subs mp0 seb1 (mp2::args)
-      | _ -> assert false) (* only legal application is to module names *)
-  | SEBfunctor (mbid,mtb,seb) ->
-    (match args with
-      | [] -> assert false (* we should only encounter applied functors *)
-      | mpa :: args ->
-	let subs = add_mbid mbid mpa empty_delta_resolver subs in
-	fields_of_seb subs mp0 seb args)
-  | SEBwith _ -> assert false (* should not appear in a mod_expr
-				   or mod_type field *)
+  |MEapply (me1,mp2) -> fields_of_expr subs mp0 (mp2::args) me1
+  |MEwith _ -> assert false (* no 'with' in [mod_expr] *)
+
+and fields_of_expression x = fields_of_functor fields_of_expr x
 
 let lookup_constant_in_impl cst fallback =
   try
@@ -143,16 +149,16 @@ let lookup_constant_in_impl cst fallback =
        - The label has not been found in the structure. This is an error *)
     match fallback with
       | Some cb -> cb
-      | None -> anomaly ("Print Assumption: unknown constant "^string_of_con cst)
+      | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst)
 
 let lookup_constant cst =
   try
     let cb = Global.lookup_constant cst in
-    if constant_has_body cb then cb
+    if Declareops.constant_has_body cb then cb
     else lookup_constant_in_impl cst (Some cb)
   with Not_found -> lookup_constant_in_impl cst None
 
-let assumptions ?(add_opaque=false) st (* t *) =
+let assumptions ?(add_opaque=false) ?(add_transparent=false) st (* t *) =
   modcache := MPmap.empty;
   let (idts,knst) = st in
   (* Infix definition for chaining function that accumulate
@@ -181,7 +187,7 @@ let assumptions ?(add_opaque=false) st (* t *) =
        a "Let" definition, in the former it is an assumption of [t],
        in the latter is must be unfolded like a Const.
     The other cases are straightforward recursion.
-    Calls to the environment are memoized, thus avoiding to explore
+    Calls to the environment are memoized, thus avoiding exploration of
     the DAG of the environment as if it was a tree (can cause
     exponential behavior and prevent the algorithm from terminating
     in reasonable time). [s] is a set of [context_object], representing
@@ -198,7 +204,7 @@ let assumptions ?(add_opaque=false) st (* t *) =
 	| Case (_,e1,e2,e_array) -> (iter e1)**(iter e2)**(iter_array e_array)
 	| Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) ->
           (iter_array e1_array) ** (iter_array e2_array)
-	| Const kn -> do_memoize_kn kn
+	| Const (kn,_) -> do_memoize_kn kn
 	| _ -> identity2 (* closed atomic types + rel *)
     and iter_array a = Array.fold_right (fun e f -> (iter e)**f) a identity2
     in iter t s acc
@@ -216,23 +222,23 @@ let assumptions ?(add_opaque=false) st (* t *) =
   and add_kn kn s acc =
     let cb = lookup_constant kn in
     let do_type cst =
-      let ctype =
-	match cb.Declarations.const_type with
-	| PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level)
-	| NonPolymorphicType t -> t
-      in
+      let ctype = Global.type_of_global_unsafe (Globnames.ConstRef kn) in
 	(s,ContextObjectMap.add cst ctype acc)
     in
     let (s,acc) =
-      if add_opaque && Declarations.constant_has_body cb
-	&& (Declarations.is_opaque cb || not (Cpred.mem kn knst))
-      then
-	do_type (Opaque kn)
-      else (s,acc)
+      if Declareops.constant_has_body cb then
+        if Declareops.is_opaque cb || not (Cpred.mem kn knst) then
+          (** it is opaque *)
+          if add_opaque then do_type (Opaque kn)
+          else (s, acc)
+        else
+          if add_transparent then do_type (Transparent kn)
+          else (s, acc)
+      else (s, acc)
     in
-      match Declarations.body_of_constant cb with
+      match Global.body_of_constant_body cb with
       | None -> do_type (Axiom kn)
-      | Some body -> do_constr (Declarations.force body) s acc
+      | Some body -> do_constr body s acc
 
   and do_memoize_kn kn =
     try_and_go (Axiom kn) (add_kn kn)
diff --git a/library/assumptions.mli b/library/assumptions.mli
index 7756c575..0a2c62f5 100644
--- a/library/assumptions.mli
+++ b/library/assumptions.mli
@@ -1,28 +1,30 @@
 (************************************************************************)
 (*  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 Util
 open Names
 open Term
-open Environ
 
 (** A few declarations for the "Print Assumption" command
     @author spiwack *)
 type context_object =
-  | Variable of identifier (** A section variable or a Let definition *)
-  | Axiom of constant      (** An axiom or a constant. *)
-  | Opaque of constant     (** An opaque constant. *)
+  | Variable of Id.t  (** A section variable or a Let definition *)
+  | Axiom of constant       (** An axiom or a constant. *)
+  | Opaque of constant      (** An opaque constant. *)
+  | Transparent of constant (** A transparent constant *)
 
 (** AssumptionSet.t is a set of [assumption] *)
-module OrderedContextObject :  Set.OrderedType with type t = context_object
-module ContextObjectMap : Map.S with type key = context_object
+module ContextObjectSet : Set.S with type elt = context_object
+module ContextObjectMap : Map.ExtS
+  with type key = context_object and module Set := ContextObjectSet
 
 (** collects all the assumptions (optionally including opaque definitions)
    on which a term relies (together with their type) *)
 val assumptions :
-  ?add_opaque:bool -> transparent_state -> constr ->
+  ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> constr ->
     Term.types ContextObjectMap.t
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
deleted file mode 100644
index ee7acec4..00000000
--- a/library/decl_kinds.ml
+++ /dev/null
@@ -1,125 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Libnames
-
-(* Informal mathematical status of declarations *)
-
-type locality =
-  | Local
-  | Global
-
-type theorem_kind =
-  | Theorem
-  | Lemma
-  | Fact
-  | Remark
-  | Property
-  | Proposition
-  | Corollary
-
-type definition_object_kind =
-  | Definition
-  | Coercion
-  | SubClass
-  | CanonicalStructure
-  | Example
-  | Fixpoint
-  | CoFixpoint
-  | Scheme
-  | StructureComponent
-  | IdentityCoercion
-  | Instance
-  | Method
-
-type assumption_object_kind = Definitional | Logical | Conjectural
-
-(* [assumption_kind]
-
-                |  Local      | Global
-   ------------------------------------
-   Definitional |  Variable   | Parameter
-   Logical      |  Hypothesis | Axiom
-
-*)
-type assumption_kind = locality * assumption_object_kind
-
-type definition_kind = locality * definition_object_kind
-
-(* Kinds used in proofs *)
-
-type goal_object_kind =
-  | DefinitionBody of definition_object_kind
-  | Proof of theorem_kind
-
-type goal_kind = locality * goal_object_kind
-
-(* Kinds used in library *)
-
-type logical_kind =
-  | IsAssumption of assumption_object_kind
-  | IsDefinition of definition_object_kind
-  | IsProof of theorem_kind
-
-(* Utils *)
-
-let logical_kind_of_goal_kind = function
-  | DefinitionBody d -> IsDefinition d
-  | Proof s -> IsProof s
-
-let string_of_theorem_kind = function
-  | Theorem -> "Theorem"
-  | Lemma -> "Lemma"
-  | Fact -> "Fact"
-  | Remark -> "Remark"
-  | Property -> "Property"
-  | Proposition -> "Proposition"
-  | Corollary -> "Corollary"
-
-let string_of_definition_kind def =
-  match def with
-  | Local, Coercion -> "Coercion Local"
-  | Global, Coercion -> "Coercion"
-  | Local, Definition -> "Let"
-  | Global, Definition -> "Definition"
-  | Local, SubClass -> "Local SubClass"
-  | Global, SubClass -> "SubClass"
-  | Global, CanonicalStructure -> "Canonical Structure"
-  | Global, Example -> "Example"
-  | Local, (CanonicalStructure|Example) ->
-      anomaly "Unsupported local definition kind"
-  | Local, Instance -> "Instance"
-  | Global, Instance -> "Global Instance"
-  | _, (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method)
-      -> anomaly "Internal definition kind"
-
-(* Strength *)
-
-let strength_of_global = function
-  | VarRef _ -> Local
-  | IndRef _ | ConstructRef _ | ConstRef _ -> Global
-
-let string_of_strength = function
-  | Local -> "Local"
-  | Global -> "Global"
-
-
-(* Recursive power *)
-
-(* spiwack: this definition might be of use in the kernel, for now I do not
-                   push them deeper than needed, though. *)
-type recursivity_kind =
-  | Finite (* = inductive *)
-  | CoFinite (* = coinductive *)
-  | BiFinite (* = non-recursive, like in "Record" definitions *)
-
-(* helper, converts to "finiteness flag" booleans *)
-let recursivity_flag_of_kind = function
-  | Finite | BiFinite -> true
-  | CoFinite -> false
diff --git a/library/declare.ml b/library/declare.ml
index d6413d3d..7f42a747 100644
--- a/library/declare.ml
+++ b/library/declare.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        *)
@@ -9,12 +9,13 @@
 (** This module is about the low-level declaration of logical objects *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Libnames
+open Globnames
 open Nameops
 open Term
-open Sign
 open Declarations
 open Entries
 open Libobject
@@ -31,55 +32,44 @@ type internal_flag =
   | KernelSilent  (* kernel action, no message is displayed *)
   | UserVerbose   (* user action, a message is displayed *)
 
-(** XML output hooks *)
-
-let xml_declare_variable = ref (fun (sp:object_name) -> ())
-let xml_declare_constant = ref (fun (sp:internal_flag * constant)-> ())
-let xml_declare_inductive = ref (fun (sp:internal_flag * object_name) -> ())
-
-let if_xml f x = if !Flags.xml_export then f x else ()
-
-let set_xml_declare_variable f = xml_declare_variable := if_xml f
-let set_xml_declare_constant f = xml_declare_constant := if_xml f
-let set_xml_declare_inductive f = xml_declare_inductive := if_xml f
-
-let cache_hook = ref ignore
-let add_cache_hook f = cache_hook := f
-
 (** Declaration of section variables and local definitions *)
 
 type section_variable_entry =
-  | SectionLocalDef of constr * types option * bool (* opacity *)
-  | SectionLocalAssum of types * bool (* Implicit status *)
+  | SectionLocalDef of definition_entry
+  | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *)
 
-type variable_declaration = dir_path * section_variable_entry * logical_kind
+type variable_declaration = DirPath.t * section_variable_entry * logical_kind
 
 let cache_variable ((sp,_),o) =
   match o with
-  | Inl cst -> Global.add_constraints cst
+  | Inl ctx -> Global.push_context_set ctx
   | Inr (id,(p,d,mk)) ->
   (* Constr raisonne sur les noms courts *)
   if variable_exists id then
     alreadydeclared (pr_id id ++ str " already exists");
-  let impl,opaq,cst = match d with (* Fails if not well-typed *)
-    | SectionLocalAssum (ty, impl) ->
-        let cst = Global.push_named_assum (id,ty) in
-	let impl = if impl then Lib.Implicit else Lib.Explicit in
-	impl, true, cst
-    | SectionLocalDef (c,t,opaq) ->
-        let cst = Global.push_named_def (id,c,t) in
-        Lib.Explicit, opaq, cst in
+
+  let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *)
+    | SectionLocalAssum ((ty,ctx),poly,impl) ->
+      let () = Global.push_named_assum ((id,ty),ctx) in
+      let impl = if impl then Implicit else Explicit in
+	impl, true, poly, ctx
+    | SectionLocalDef (de) ->
+      let () = Global.push_named_def (id,de) in
+        Explicit, de.const_entry_opaque, de.const_entry_polymorphic, 
+	(Univ.ContextSet.of_context de.const_entry_universes) in
   Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id);
-  add_section_variable id impl;
+  add_section_variable id impl poly ctx;
   Dischargedhypsmap.set_discharged_hyps sp [];
-  add_variable_data id (p,opaq,cst,mk)
+  add_variable_data id (p,opaq,ctx,poly,mk)
 
 let discharge_variable (_,o) = match o with
-  | Inr (id,_) -> Some (Inl (variable_constraints id))
+  | Inr (id,_) -> 
+    if variable_polymorphic id then None
+    else Some (Inl (variable_context id))
   | Inl _ -> Some o
 
 type variable_obj =
-    (Univ.constraints, identifier * variable_declaration) union
+    (Univ.ContextSet.t, Id.t * variable_declaration) union
 
 let inVariable : variable_obj -> obj =
   declare_object { (default_object "VARIABLE") with
@@ -93,70 +83,90 @@ let declare_variable id obj =
   declare_var_implicits id;
   Notation.declare_ref_arguments_scope (VarRef id);
   Heads.declare_head (EvalVarRef id);
-  !xml_declare_variable oname;
   oname
 
 
 (** Declaration of constants and parameters *)
 
+type constant_obj = {
+  cst_decl : global_declaration;
+  cst_hyps : Dischargedhypsmap.discharged_hyps;
+  cst_kind : logical_kind;
+  cst_locl : bool;
+}
+
 type constant_declaration = constant_entry * logical_kind
 
 (* At load-time, the segment starting from the module name to the discharge *)
 (* section (if Remark or Fact) is needed to access a construction *)
-let load_constant i ((sp,kn),(_,_,kind)) =
+let load_constant i ((sp,kn), obj) =
   if Nametab.exists_cci sp then
     alreadydeclared (pr_id (basename sp) ++ str " already exists");
   let con = Global.constant_of_delta_kn kn in
   Nametab.push (Nametab.Until i) sp (ConstRef con);
-  add_constant_kind con kind
+  add_constant_kind con obj.cst_kind
 
 (* Opening means making the name without its module qualification available *)
-let open_constant i ((sp,kn),_) =
-  let con = Global.constant_of_delta_kn kn in
-    Nametab.push (Nametab.Exactly i) sp (ConstRef con)
+let open_constant i ((sp,kn), obj) =
+  (** Never open a local definition *)
+  if obj.cst_locl then ()
+  else
+    let con = Global.constant_of_delta_kn kn in
+    Nametab.push (Nametab.Exactly i) sp (ConstRef con);
+    match (Global.lookup_constant con).const_body with
+    | (Def _ | Undef _) -> ()
+    | OpaqueDef lc ->
+        match Opaqueproof.get_constraints (Global.opaque_tables ())lc with
+        | Some f when Future.is_val f -> Global.push_context_set (Future.force f)
+        | _ -> ()
 
 let exists_name id =
-  variable_exists id or Global.exists_objlabel (label_of_id id)
+  variable_exists id || Global.exists_objlabel (Label.of_id id)
 
 let check_exists sp =
   let id = basename sp in
   if exists_name id then alreadydeclared (pr_id id ++ str " already exists")
 
-let cache_constant ((sp,kn),(cdt,dhyps,kind)) =
+let cache_constant ((sp,kn), obj) =
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
-  check_exists sp;
-  let kn' = Global.add_constant dir id cdt in
-  assert (kn' = constant_of_kn kn);
+  let () = check_exists sp in
+  let kn' = Global.add_constant dir id obj.cst_decl in
+  assert (eq_constant kn' (constant_of_kn kn));
   Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn));
-  add_section_constant kn' (Global.lookup_constant kn').const_hyps;
-  Dischargedhypsmap.set_discharged_hyps sp dhyps;
-  add_constant_kind (constant_of_kn kn) kind;
-  !cache_hook sp
+  let cst = Global.lookup_constant kn' in
+  add_section_constant (cst.const_proj <> None) kn' cst.const_hyps;
+  Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps;
+  add_constant_kind (constant_of_kn kn) obj.cst_kind
 
 let discharged_hyps kn sechyps =
   let (_,dir,_) = repr_kn kn in
   let args = Array.to_list (instance_from_variable_context sechyps) in
-  List.rev (List.map (Libnames.make_path dir) args)
+  List.rev_map (Libnames.make_path dir) args
 
-let discharge_constant ((sp,kn),(cdt,dhyps,kind)) =
+let discharge_constant ((sp, kn), obj) =
   let con = constant_of_kn kn in
-  let cb = Global.lookup_constant con in
-  let repl = replacement_context () in
-  let sechyps = section_segment_of_constant con in
-  let recipe = { d_from=cb; d_modlist=repl; d_abstract=named_of_variable_context sechyps } in
-  Some (GlobalRecipe recipe,(discharged_hyps kn sechyps)@dhyps,kind)
+  let from = Global.lookup_constant con in
+  let modlist = replacement_context () in
+  let hyps,subst,uctx = section_segment_of_constant con in
+  let new_hyps = (discharged_hyps kn hyps) @ obj.cst_hyps in
+  let abstract = (named_of_variable_context hyps, subst, uctx) in
+  let new_decl = GlobalRecipe{ from; info = { Opaqueproof.modlist; abstract}} in
+  Some { obj with cst_hyps = new_hyps; cst_decl = new_decl; }
 
 (* Hack to reduce the size of .vo: we keep only what load/open needs *)
-let dummy_constant_entry = ConstantEntry (ParameterEntry (None,mkProp,None))
-
-let dummy_constant (ce,_,mk) = dummy_constant_entry,[],mk
+let dummy_constant_entry = 
+  ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None))
+
+let dummy_constant cst = {
+  cst_decl = dummy_constant_entry;
+  cst_hyps = [];
+  cst_kind = cst.cst_kind;
+  cst_locl = cst.cst_locl;
+}
 
 let classify_constant cst = Substitute (dummy_constant cst)
 
-type constant_obj =
-    global_declaration * Dischargedhypsmap.discharged_hyps * logical_kind
-
 let inConstant : constant_obj -> obj =
   declare_object { (default_object "CONSTANT") with
     cache_function = cache_constant;
@@ -166,23 +176,125 @@ let inConstant : constant_obj -> obj =
     subst_function = ident_subst_function;
     discharge_function = discharge_constant }
 
-let declare_constant_common id dhyps (cd,kind) =
-  let (sp,kn) = add_leaf id (inConstant (cd,dhyps,kind)) in
+let declare_constant_common id cst =
+  let (sp,kn) = add_leaf id (inConstant cst) in
   let c = Global.constant_of_delta_kn kn in
   declare_constant_implicits c;
   Heads.declare_head (EvalConstRef c);
   Notation.declare_ref_arguments_scope (ConstRef c);
   c
 
-let declare_constant ?(internal = UserVerbose) id (cd,kind) =
-  let kn = declare_constant_common id [] (ConstantEntry cd,kind) in
-  !xml_declare_constant (internal,kn);
+let definition_entry ?(opaque=false) ?(inline=false) ?types 
+    ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Declareops.no_seff) body =
+  { const_entry_body = Future.from_val ((body,Univ.ContextSet.empty), eff);
+    const_entry_secctx = None;
+    const_entry_type = types;
+    const_entry_polymorphic = poly;
+    const_entry_universes = univs;
+    const_entry_opaque = opaque;
+    const_entry_feedback = None;
+    const_entry_inline_code = inline}
+
+let declare_scheme = ref (fun _ _ -> assert false)
+let set_declare_scheme f = declare_scheme := f
+let declare_sideff env fix_exn se =
+  let cbl, scheme = match se with
+    | SEsubproof (c, cb, pt) -> [c, cb, pt], None
+    | SEscheme (cbl, k) ->
+        List.map (fun (_,c,cb,pt) -> c,cb,pt) cbl, Some (cbl,k) in
+  let id_of c = Names.Label.to_id (Names.Constant.label c) in
+  let pt_opaque_of cb pt =
+    match cb, pt with
+    | { const_body = Def sc }, _ -> (Mod_subst.force_constr sc, Univ.ContextSet.empty), false
+    | { const_body = OpaqueDef _ }, `Opaque(pt,univ) -> (pt, univ), true
+    | _ -> assert false
+  in
+  let ty_of cb =
+    match cb.Declarations.const_type with
+    | Declarations.RegularArity t -> Some t 
+    | Declarations.TemplateArity _ -> None in
+  let cst_of cb pt =
+    let pt, opaque = pt_opaque_of cb pt in
+    let univs, subst = 
+      if cb.const_polymorphic then
+	let univs = Univ.instantiate_univ_context cb.const_universes in
+	  univs, Vars.subst_instance_constr (Univ.UContext.instance univs)
+      else cb.const_universes, fun x -> x
+    in
+    let pt = (subst (fst pt), snd pt) in
+    let ty = Option.map subst (ty_of cb) in
+    { cst_decl = ConstantEntry (DefinitionEntry {
+        const_entry_body = Future.from_here ~fix_exn (pt, Declareops.no_seff);
+        const_entry_secctx = Some cb.Declarations.const_hyps;
+        const_entry_type = ty;
+        const_entry_opaque = opaque;
+        const_entry_inline_code = false;
+        const_entry_feedback = None;
+	const_entry_polymorphic = cb.const_polymorphic;
+	const_entry_universes = univs;
+    });
+    cst_hyps = [] ;
+    cst_kind =  Decl_kinds.IsDefinition Decl_kinds.Definition;
+    cst_locl = true;
+  } in
+  let exists c =
+    try ignore(Environ.lookup_constant c env); true
+    with Not_found -> false in 
+  let knl =
+    CList.map_filter (fun (c,cb,pt) ->
+      if exists c then None
+      else Some (c,declare_constant_common (id_of c) (cst_of cb pt))) cbl in
+  match scheme with
+  | None -> ()
+  | Some (inds_consts,kind) ->
+      !declare_scheme kind (Array.of_list
+         (List.map (fun (c,kn) ->
+             CList.find_map (fun (x,c',_,_) ->
+               if Constant.equal c c' then Some (x,kn) else None) inds_consts)
+           knl))
+
+let declare_constant ?(internal = UserVerbose) ?(local = false) id (cd, kind) =
+  let cd = (* We deal with side effects of non-opaque constants *)
+    match cd with
+    | Entries.DefinitionEntry ({
+      const_entry_opaque = false; const_entry_body = bo } as de)
+    | Entries.DefinitionEntry ({
+      const_entry_polymorphic = true; const_entry_body = bo } as de)
+      ->
+        let _, seff = Future.force bo in
+        if Declareops.side_effects_is_empty seff then cd
+        else begin
+          let seff = Declareops.uniquize_side_effects seff in
+          Declareops.iter_side_effects
+            (declare_sideff (Global.env ()) (Future.fix_exn_of bo)) seff;
+          Entries.DefinitionEntry { de with
+            const_entry_body = Future.chain ~pure:true bo (fun (pt, _) ->
+              pt, Declareops.no_seff) }
+        end
+    | _ -> cd
+  in
+  let cst = {
+    cst_decl = ConstantEntry cd;
+    cst_hyps = [] ;
+    cst_kind = kind;
+    cst_locl = local;
+  } in
+  let kn = declare_constant_common id cst in
   kn
 
+let declare_definition ?(internal=UserVerbose) 
+  ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false)
+  ?(poly=false) id ?types (body,ctx) =
+  let cb = 
+    definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body
+  in
+    declare_constant ~internal ~local id
+      (Entries.DefinitionEntry cb, Decl_kinds.IsDefinition kind)
+
 (** Declaration of inductive blocks *)
 
 let declare_inductive_argument_scopes kn mie =
-  list_iter_i (fun i {mind_entry_consnames=lc} ->
+  List.iteri (fun i {mind_entry_consnames=lc} ->
     Notation.declare_ref_arguments_scope (IndRef (kn,i));
     for j=1 to List.length lc do
       Notation.declare_ref_arguments_scope (ConstructRef ((kn,i),j));
@@ -223,24 +335,24 @@ let cache_inductive ((sp,kn),(dhyps,mie)) =
   let id = basename sp in
   let _,dir,_ = repr_kn kn in
   let kn' = Global.add_mind dir id mie in
-  assert (kn'= mind_of_kn kn);
-  add_section_kn kn' (Global.lookup_mind kn').mind_hyps;
+  assert (eq_mind kn' (mind_of_kn kn));
+  let mind = Global.lookup_mind kn' in
+  add_section_kn kn' mind.mind_hyps;
   Dischargedhypsmap.set_discharged_hyps sp dhyps;
-  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names;
-  List.iter (fun (sp,_) -> !cache_hook sp) (inductive_names sp kn mie)
-
+  List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names
 
 let discharge_inductive ((sp,kn),(dhyps,mie)) =
   let mind = Global.mind_of_delta_kn kn in
   let mie = Global.lookup_mind mind in
   let repl = replacement_context () in
-  let sechyps = section_segment_of_mutual_inductive mind in
+  let sechyps,usubst,uctx = section_segment_of_mutual_inductive mind in
   Some (discharged_hyps kn sechyps,
-        Discharge.process_inductive (named_of_variable_context sechyps) repl mie)
+        Discharge.process_inductive (named_of_variable_context sechyps,uctx) repl mie)
 
 let dummy_one_inductive_entry mie = {
   mind_entry_typename = mie.mind_entry_typename;
   mind_entry_arity = mkProp;
+  mind_entry_template = false;
   mind_entry_consnames = mie.mind_entry_consnames;
   mind_entry_lc = []
 }
@@ -248,9 +360,12 @@ let dummy_one_inductive_entry mie = {
 (* Hack to reduce the size of .vo: we keep only what load/open needs *)
 let dummy_inductive_entry (_,m) = ([],{
   mind_entry_params = [];
-  mind_entry_record = false;
-  mind_entry_finite = true;
-  mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds })
+  mind_entry_record = None;
+  mind_entry_finite = Decl_kinds.BiFinite;
+  mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds;
+  mind_entry_polymorphic = false;
+  mind_entry_universes = Univ.UContext.empty;
+  mind_entry_private = None })
 
 type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry
 
@@ -263,25 +378,38 @@ let inInductive : inductive_obj -> obj =
     subst_function = ident_subst_function;
     discharge_function = discharge_inductive }
 
+let declare_projections mind =
+  let spec,_ = Inductive.lookup_mind_specif (Global.env ()) (mind,0) in
+    match spec.mind_record with
+    | Some (Some (_, kns, pjs)) -> 
+      Array.iteri (fun i kn -> 
+	let id = Label.to_id (Constant.label kn) in
+	let entry = {proj_entry_ind = mind; proj_entry_arg = i} in
+	let kn' = declare_constant id (ProjectionEntry entry,
+				       IsDefinition StructureComponent) 
+	in
+	  assert(eq_constant kn kn')) kns; true
+    | Some None | None -> false
+
 (* for initial declaration *)
-let declare_mind isrecord mie =
+let declare_mind mie =
   let id = match mie.mind_entry_inds with
     | ind::_ -> ind.mind_entry_typename
-    | [] -> anomaly "cannot declare an empty list of inductives" in
+    | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in
   let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in
   let mind = Global.mind_of_delta_kn kn in
+  let isprim = declare_projections mind in
   declare_mib_implicits mind;
   declare_inductive_argument_scopes mind mie;
-  !xml_declare_inductive (isrecord,oname);
-  oname
+  oname, isprim
 
 (* Declaration messages *)
 
-let pr_rank i = str (ordinal (i+1))
+let pr_rank i = pr_nth (i+1)
 
 let fixpoint_message indexes l =
-  Flags.if_verbose msgnl (match l with
-  | [] -> anomaly "no recursive definition"
+  Flags.if_verbose msg_info (match l with
+  | [] -> anomaly (Pp.str "no recursive definition")
   | [id] -> pr_id id ++ str " is recursively defined" ++
       (match indexes with
 	 | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)"
@@ -290,13 +418,13 @@ let fixpoint_message indexes l =
 		  spc () ++ str "are recursively defined" ++
 		  match indexes with
 		    | Some a -> spc () ++ str "(decreasing respectively on " ++
-			prlist_with_sep pr_comma pr_rank (Array.to_list a) ++
+			prvect_with_sep pr_comma pr_rank a ++
 			str " arguments)"
 		    | None -> mt ()))
 
 let cofixpoint_message l =
-  Flags.if_verbose msgnl (match l with
-  | [] -> anomaly "No corecursive definition."
+  Flags.if_verbose msg_info (match l with
+  | [] -> anomaly (Pp.str "No corecursive definition.")
   | [id] -> pr_id id ++ str " is corecursively defined"
   | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++
                     spc () ++ str "are corecursively defined"))
@@ -305,7 +433,57 @@ let recursive_message isfix i l =
   (if isfix then fixpoint_message i else cofixpoint_message) l
 
 let definition_message id =
-  Flags.if_verbose msgnl (pr_id id ++ str " is defined")
+  Flags.if_verbose msg_info (pr_id id ++ str " is defined")
 
 let assumption_message id =
-  Flags.if_verbose msgnl (pr_id id ++ str " is assumed")
+  Flags.if_verbose msg_info (pr_id id ++ str " is assumed")
+
+(** Global universe names, in a different summary *)
+
+type universe_names = 
+    (Univ.universe_level Idmap.t * Id.t Univ.LMap.t)
+
+let input_universes : universe_names -> Libobject.obj =
+  let open Libobject in 
+    declare_object
+    { (default_object "Global universe name state") with
+      cache_function = (fun (na, pi) -> Universes.set_global_universe_names pi);
+      load_function = (fun _ (_, pi) -> Universes.set_global_universe_names pi);
+      discharge_function = (fun (_, a) -> Some a);
+      classify_function = (fun a -> Keep a) }
+
+let do_universe l =
+  let glob = Universes.global_universe_names () in
+  let glob' = 
+    List.fold_left (fun (idl,lid) (l, id) ->
+      let lev = Universes.new_univ_level (Global.current_dirpath ()) in
+	(Idmap.add id lev idl, Univ.LMap.add lev id lid))
+      glob l
+  in
+    Lib.add_anonymous_leaf (input_universes glob')
+
+
+let input_constraints : Univ.constraints -> Libobject.obj =
+  let open Libobject in 
+    declare_object
+    { (default_object "Global universe constraints") with
+      cache_function = (fun (na, c) -> Global.add_constraints c);
+      load_function = (fun _ (_, c) -> Global.add_constraints c);
+      discharge_function = (fun (_, a) -> Some a);
+      classify_function = (fun a -> Keep a) }
+
+let do_constraint l = 
+  let u_of_id = 
+    let names, _ = Universes.global_universe_names () in
+      fun (loc, id) -> 
+	try Idmap.find id names
+	with Not_found ->
+	  user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id)	    
+  in
+  let constraints = List.fold_left (fun acc (l, d, r) ->
+    let lu = u_of_id l and ru = u_of_id r in
+      Univ.Constraint.add (lu, d, ru) acc)
+    Univ.Constraint.empty l
+  in
+    Lib.add_anonymous_leaf (input_constraints constraints)
+  
diff --git a/library/declare.mli b/library/declare.mli
index 2de128bd..03b66271 100644
--- a/library/declare.mli
+++ b/library/declare.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        *)
@@ -9,12 +9,7 @@
 open Names
 open Libnames
 open Term
-open Sign
-open Declarations
 open Entries
-open Indtypes
-open Safe_typing
-open Nametab
 open Decl_kinds
 
 (** This module provides the official functions to declare new variables,
@@ -24,15 +19,13 @@ open Decl_kinds
    reset works properly --- and will fill some global tables such as
    [Nametab] and [Impargs]. *)
 
-open Nametab
-
 (** Declaration of local constructions (Variable/Hypothesis/Local) *)
 
 type section_variable_entry =
-  | SectionLocalDef of constr * types option * bool (** opacity *)
-  | SectionLocalAssum of types * bool (** Implicit status *)
+  | SectionLocalDef of definition_entry
+  | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *)
 
-type variable_declaration = dir_path * section_variable_entry * logical_kind
+type variable_declaration = DirPath.t * section_variable_entry * logical_kind
 
 val declare_variable : variable -> variable_declaration -> object_name
 
@@ -54,29 +47,43 @@ type internal_flag =
   | KernelSilent
   | UserVerbose
 
+(* Defaut definition entries, transparent with no secctx or proj information *)
+val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> 
+  ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Declareops.side_effects ->
+  constr -> definition_entry
+
 val declare_constant :
- ?internal:internal_flag -> identifier -> constant_declaration -> constant
+ ?internal:internal_flag -> ?local:bool -> Id.t -> constant_declaration -> constant
 
-(** [declare_mind me] declares a block of inductive types with
-   their constructors in the current section; it returns the path of
-   the whole block (boolean must be true iff it is a record) *)
-val declare_mind : internal_flag -> mutual_inductive_entry -> object_name
+val declare_definition : 
+  ?internal:internal_flag -> ?opaque:bool -> ?kind:definition_object_kind ->
+  ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> 
+  constr Univ.in_universe_context_set -> constant
 
-(** Hooks for XML output *)
-val set_xml_declare_variable : (object_name -> unit) -> unit
-val set_xml_declare_constant : (internal_flag * constant -> unit) -> unit
-val set_xml_declare_inductive : (internal_flag * object_name -> unit) -> unit
+(** Since transparent constant's side effects are globally declared, we
+ *  need that *)
+val set_declare_scheme :
+  (string -> (inductive * constant) array -> unit) -> unit
 
-(** Hook for the cache function of constants and inductives *)
-val add_cache_hook : (full_path -> unit) -> unit
+(** [declare_mind me] declares a block of inductive types with
+   their constructors in the current section; it returns the path of
+   the whole block and a boolean indicating if it is a primitive record. *)
+val declare_mind : mutual_inductive_entry -> object_name * bool
 
 (** Declaration messages *)
 
-val definition_message : identifier -> unit
-val assumption_message : identifier -> unit
-val fixpoint_message : int array option -> identifier list -> unit
-val cofixpoint_message : identifier list -> unit
+val definition_message : Id.t -> unit
+val assumption_message : Id.t -> unit
+val fixpoint_message : int array option -> Id.t list -> unit
+val cofixpoint_message : Id.t list -> unit
 val recursive_message : bool (** true = fixpoint *) ->
-  int array option -> identifier list -> unit
+  int array option -> Id.t list -> unit
+
+val exists_name : Id.t -> bool
+
+
+
+(** Global universe names and constraints *)
 
-val exists_name : identifier -> bool
+val do_universe : Id.t Loc.located list -> unit
+val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 6b33e4b7..cc7c4d7f 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -1,53 +1,24 @@
 (************************************************************************)
 (*  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
 open Declarations
 open Entries
 open Libnames
 open Libobject
-open Lib
-open Nametab
 open Mod_subst
+open Vernacexpr
+open Misctypes
 
-(** Rigid / flexible signature *)
-
-type 'a module_signature =
-  | Enforce of 'a (** ... : T *)
-  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
-
-(** Should we adapt a few scopes during functor application ? *)
-
-type scope_subst = (string * string) list
-
-let scope_subst = ref (Stringmap.empty : string Stringmap.t)
-
-let add_scope_subst sc sc' =
-  scope_subst := Stringmap.add sc sc' !scope_subst
-
-let register_scope_subst scl =
-  List.iter (fun (sc1,sc2) -> add_scope_subst sc1 sc2) scl
-
-let subst_scope sc =
- try Stringmap.find sc !scope_subst with Not_found -> sc
-
-let reset_scope_subst () =
-  scope_subst := Stringmap.empty
-
-(** Which inline annotations should we honor, either None or the ones
-    whose level is less or equal to the given integer *)
-
-type inline =
-  | NoInline
-  | DefaultInline
-  | InlineAt of int
+(** {6 Inlining levels} *)
 
 let default_inline () = Some (Flags.get_inline_level ())
 
@@ -56,57 +27,93 @@ let inl2intopt = function
   | InlineAt i -> Some i
   | DefaultInline -> default_inline ()
 
-type funct_app_annot =
-  { ann_inline : inline;
-    ann_scope_subst : scope_subst }
+(** {6 Substitutive objects}
 
-let inline_annot a = inl2intopt a.ann_inline
+   - The list of bound identifiers is nonempty only if the objects
+     are owned by a functor
 
-type 'a annotated = ('a * funct_app_annot)
+   - Then comes either the object segment itself (for interactive
+     modules), or a compact way to store derived objects (path to
+     a earlier module + subtitution).
+*)
 
+type algebraic_objects =
+  | Objs of Lib.lib_objects
+  | Ref of module_path * substitution
 
-(* modules and components *)
+type substitutive_objects = MBId.t list * algebraic_objects
 
-(* OBSOLETE This type is a functional closure of substitutive lib_objects.
+(** ModSubstObjs : a cache of module substitutive objects
 
-   The first part is a partial substitution (which will be later
-   applied to lib_objects when completed).
+   This table is common to modules and module types.
+   -  For a Module M:=N, the objects of N will be reloaded
+      with M after substitution.
+   -  For a Module M:SIG:=..., the module M gets its objects from SIG
 
-   The second one is a list of bound identifiers which is nonempty
-   only if the objects are owned by a fuctor
+   Invariants:
+   - A alias (i.e. a module path inside a Ref constructor) should
+     never lead to another alias, but rather to a concrete Objs
+     constructor.
 
-   The third one is the "self" ident of the signature (or structure),
-   which should be substituted in lib_objects with the real name of
-   the module.
+   We will plug later a handler dealing with missing entries in the
+   cache. Such missing entries may come from inner parts of module
+   types, which aren't registered by the standard libobject machinery.
+*)
 
-   The fourth one is the segment itself which can contain references
-   to identifiers in the domain of the substitution or in other two
-   parts. These references are invalid in the current scope and
-   therefore must be substitued with valid names before use.
+module ModSubstObjs :
+ sig
+   val set : module_path -> substitutive_objects -> unit
+   val get : module_path -> substitutive_objects
+   val set_missing_handler : (module_path -> substitutive_objects) -> unit
+ end =
+ struct
+   let table =
+     Summary.ref (MPmap.empty : substitutive_objects MPmap.t)
+       ~name:"MODULE-SUBSTOBJS"
+   let missing_handler = ref (fun mp -> assert false)
+   let set_missing_handler f = (missing_handler := f)
+   let set mp objs = (table := MPmap.add mp objs !table)
+   let get mp =
+     try MPmap.find mp !table with Not_found -> !missing_handler mp
+ end
 
-*)
-type substitutive_objects =
-     mod_bound_id list * module_path * lib_objects
+(** Some utilities about substitutive objects :
+    substitution, expansion *)
+
+let sobjs_no_functor (mbids,_) = List.is_empty mbids
+
+let subst_aobjs sub = function
+  | Objs o -> Objs (Lib.subst_objects sub o)
+  | Ref (mp, sub0) -> Ref (mp, join sub0 sub)
+
+let subst_sobjs sub (mbids,aobjs) = (mbids, subst_aobjs sub aobjs)
+
+let expand_aobjs = function
+  | Objs o -> o
+  | Ref (mp, sub) ->
+    match ModSubstObjs.get mp with
+      | (_,Objs o) -> Lib.subst_objects sub o
+      | _ -> assert false (* Invariant : any alias points to concrete objs *)
 
+let expand_sobjs (_,aobjs) = expand_aobjs aobjs
 
-(* For each module, we store the following things:
 
-   In modtab_substobjs: substitutive_objects
-     when we will do Module M:=N, the objects of N will be reloaded
-     with M after substitution
+(** {6 ModObjs : a cache of module objects}
 
-   In modtab_objects: "substituted objects" @ "keep objects"
+   For each module, we also store a cache of
+   "prefix", "substituted objects", "keep objects".
+   This is used for instance to implement the "Import" command.
 
-   substituted objects -
+   substituted objects :
      roughly the objects above after the substitution - we need to
      keep them to call open_object when the module is opened (imported)
 
-   keep objects -
+   keep objects :
      The list of non-substitutive objects - as above, for each of
      them we will call open_object when the module is opened
 
    (Some) Invariants:
-   * If the module is a functor, the two latter lists are empty.
+   * If the module is a functor, it won't appear in this cache.
 
    * Module objects in substitutive_objects part have empty substituted
      objects.
@@ -114,190 +121,88 @@ type substitutive_objects =
    * Modules which where created with Module M:=mexpr or with
      Module M:SIG. ... End M. have the keep list empty.
 *)
-let modtab_substobjs =
-  ref (MPmap.empty : substitutive_objects MPmap.t)
-let modtab_objects =
-  ref (MPmap.empty : (object_prefix * lib_objects) MPmap.t)
-
-
-(* currently started interactive module (if any) - its arguments (if it
-   is a functor) and declared output type *)
-let openmod_info =
-  ref ((MPfile(initial_dir),[],None,[])
-	 : module_path *  mod_bound_id list *
-           (module_struct_entry * int option) option *
-	   module_type_body list)
-
-(* The library_cache here is needed to avoid recalculations of
-   substituted modules object during "reloading" of libraries *)
-let library_cache = ref Dirmap.empty
-
-let _ = Summary.declare_summary "MODULE-INFO"
-	  { Summary.freeze_function = (fun () ->
-					 !modtab_substobjs,
-					 !modtab_objects,
-					 !openmod_info,
-					 !library_cache);
-	    Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) ->
-					   modtab_substobjs := sobjs;
-					   modtab_objects := objs;
-					   openmod_info := info;
-					   library_cache := libcache);
-	    Summary.init_function = (fun () ->
-				       modtab_substobjs := MPmap.empty;
-				       modtab_objects := MPmap.empty;
-				       openmod_info := ((MPfile(initial_dir),
-							 [],None,[]));
-				       library_cache := Dirmap.empty) }
-
-(* auxiliary functions to transform full_path and kernel_name given
-   by Lib into module_path and dir_path needed for modules *)
 
-let mp_of_kn kn =
-  let mp,sec,l = repr_kn kn in
-    if sec=empty_dirpath then
-      MPdot (mp,l)
-    else
-      anomaly ("Non-empty section in module name!" ^ string_of_kn kn)
-
-let dir_of_sp sp =
-  let dir,id = repr_path sp in
-    add_dirpath_suffix dir id
-
-(* Subtyping checks *)
-
-let check_sub mtb sub_mtb_l =
-  (* The constraints are checked and forgot immediately : *)
-  ignore (List.fold_right
-	    (fun sub_mtb env ->
-	       Environ.add_constraints
-		 (Subtyping.check_subtypes env mtb sub_mtb) env)
-	    sub_mtb_l (Global.env()))
+type module_objects = object_prefix * Lib.lib_objects * Lib.lib_objects
 
-(* This function checks if the type calculated for the module [mp] is
-   a subtype of all signatures in [sub_mtb_l]. Uses only the global
-   environment. *)
-
-let check_subtypes mp sub_mtb_l =
-  let mb =
-    try Global.lookup_module mp
-    with Not_found -> assert false
-  in
-  let mtb = Modops.module_type_of_module None mb in
-  check_sub mtb sub_mtb_l
+module ModObjs :
+ sig
+   val set : module_path -> module_objects -> unit
+   val get : module_path -> module_objects (* may raise Not_found *)
+   val all : unit -> module_objects MPmap.t
+ end =
+ struct
+   let table =
+     Summary.ref (MPmap.empty : module_objects MPmap.t)
+       ~name:"MODULE-OBJS"
+   let set mp objs = (table := MPmap.add mp objs !table)
+   let get mp = MPmap.find mp !table
+   let all () = !table
+ end
 
-(* Same for module type [mp] *)
 
-let check_subtypes_mt mp sub_mtb_l =
-  let mtb =
-    try Global.lookup_modtype mp
-    with Not_found -> assert false
-  in
-  check_sub mtb sub_mtb_l
+(** {6 Name management}
 
-(* Create a functor type entry *)
+    Auxiliary functions to transform full_path and kernel_name given
+    by Lib into module_path and DirPath.t needed for modules
+*)
 
-let funct_entry args m =
-  List.fold_right
-    (fun (arg_id,(arg_t,_)) mte -> MSEfunctor (arg_id,arg_t,mte))
-    args m
+let mp_of_kn kn =
+  let mp,sec,l = repr_kn kn in
+  assert (DirPath.is_empty sec);
+  MPdot (mp,l)
 
-(* Prepare the module type list for check of subtypes *)
+let dir_of_sp sp =
+  let dir,id = repr_path sp in
+  add_dirpath_suffix dir id
 
-let build_subtypes interp_modtype mp args mtys =
-  List.map
-    (fun (m,ann) ->
-       let inl = inline_annot ann in
-       let mte = interp_modtype (Global.env()) m in
-       let mtb = Mod_typing.translate_module_type (Global.env()) mp inl mte in
-       let funct_mtb =
-	 List.fold_right
-           (fun (arg_id,(arg_t,arg_inl)) mte ->
-              let arg_t =
-		Mod_typing.translate_module_type (Global.env())
-		  (MPbound arg_id) arg_inl arg_t
-	      in
-              SEBfunctor(arg_id,arg_t,mte))
-           args mtb.typ_expr
-       in
-       { mtb with typ_expr = funct_mtb })
-    mtys
 
+(** {6 Declaration of module substitutive objects} *)
 
-(* These functions register the visibility of the module and iterates
-   through its components. They are called by plenty module functions *)
+(** These functions register the visibility of the module and iterates
+    through its components. They are called by plenty of module functions *)
 
-let compute_visibility exists what i dir dirinfo =
+let consistency_checks exists dir dirinfo =
   if exists then
-    if
-      try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo
-      with Not_found -> false
-    then
-      Nametab.Exactly i
-    else
-      errorlabstrm (what^"_module")
-	(pr_dirpath dir ++ str " should already exist!")
+    let globref =
+      try Nametab.locate_dir (qualid_of_dirpath dir)
+      with Not_found ->
+        anomaly (pr_dirpath dir ++ str " should already exist!")
+    in
+    assert (eq_global_dir_reference globref dirinfo)
   else
     if Nametab.exists_dir dir then
-      errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists")
-    else
-      Nametab.Until i
-(*
-let do_load_and_subst_module i dir mp substobjs keep =
-  let prefix = (dir,(mp,empty_dirpath)) in
-  let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
-  let vis = compute_visibility false "load_and_subst" i dir dirinfo in
-  let objects = compute_subst_objects mp substobjs resolver in
-  Nametab.push_dir vis dir dirinfo;
-  modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
-  match objects with
-  | Some (subst,seg) ->
-      let seg = load_and_subst_objects (i+1) prefix subst seg in
-      modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects;
-      load_objects (i+1) prefix keep;
-      Some (seg@keep)
-  | None ->
-      None
-*)
-
-let do_module exists what iter_objects i dir mp substobjs keep=
-  let prefix = (dir,(mp,empty_dirpath)) in
-  let dirinfo = DirModule (dir,(mp,empty_dirpath)) in
-  let vis = compute_visibility exists what i dir dirinfo in
-    Nametab.push_dir vis dir dirinfo;
-    modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs;
-    match substobjs with
-	([],mp1,objs) -> 
-	  modtab_objects := MPmap.add mp (prefix,objs@keep) !modtab_objects;
-	  iter_objects (i+1) prefix (objs@keep)  
-      | (mbids,_,_) ->  ()
-
-let conv_names_do_module exists what iter_objects i
-      (sp,kn) substobjs =
-  let dir,mp = dir_of_sp sp, mp_of_kn kn in
-  do_module exists what iter_objects i dir mp substobjs []
-
-(* Interactive modules and module types cannot be recached! cache_mod*
-   functions can be called only once (and "end_mod*" set the flag to
-   false then)
-*)
-let cache_module ((sp,kn),substobjs) =
-  let dir,mp = dir_of_sp sp, mp_of_kn kn in
-    do_module false "cache" load_objects 1 dir mp substobjs []
-
-(* When this function is called the module itself is already in the
-   environment. This function loads its objects only *)
-
-let load_module i (oname,substobjs) =
-  conv_names_do_module false "load" load_objects i oname substobjs
-
-let open_module i (oname,substobjs) =
-  conv_names_do_module true "open" open_objects i oname substobjs
-
-let subst_module (subst,(mbids,mp,objs)) =
-  (mbids,subst_mp subst mp, subst_objects subst objs)
-
-let classify_module substobjs = Substitute substobjs
+      anomaly (pr_dirpath dir ++ str " already exists")
+
+let compute_visibility exists i =
+  if exists then Nametab.Exactly i else Nametab.Until i
+
+(** Iterate some function [iter_objects] on all components of a module *)
+
+let do_module exists iter_objects i dir mp sobjs kobjs =
+  let prefix = (dir,(mp,DirPath.empty)) in
+  let dirinfo = DirModule prefix in
+  consistency_checks exists dir dirinfo;
+  Nametab.push_dir (compute_visibility exists i) dir dirinfo;
+  ModSubstObjs.set mp sobjs;
+  (* If we're not a functor, let's iter on the internal components *)
+  if sobjs_no_functor sobjs then begin
+    let objs = expand_sobjs sobjs in
+    ModObjs.set mp (prefix,objs,kobjs);
+    iter_objects (i+1) prefix objs;
+    iter_objects (i+1) prefix kobjs
+  end
+
+let do_module' exists iter_objects i ((sp,kn),sobjs) =
+  do_module exists iter_objects i (dir_of_sp sp) (mp_of_kn kn) sobjs []
+
+(** Nota: Interactive modules and module types cannot be recached!
+    This used to be checked here via a flag along the substobjs. *)
+
+let cache_module = do_module' false Lib.load_objects 1
+let load_module = do_module' false Lib.load_objects
+let open_module = do_module' true Lib.open_objects
+let subst_module (subst,sobjs) = subst_sobjs subst sobjs
+let classify_module sobjs = Substitute sobjs
 
 let (in_module : substitutive_objects -> obj),
     (out_module : obj -> substitutive_objects) =
@@ -308,755 +213,748 @@ let (in_module : substitutive_objects -> obj),
     subst_function = subst_module;
     classify_function = classify_module }
 
-let cache_keep _ = anomaly "This module should not be cached!"
 
-let load_keep i ((sp,kn),seg) =
-  let mp = mp_of_kn kn in
-  let prefix = dir_of_sp sp, (mp,empty_dirpath) in
-    begin
-      try
-	let prefix',objects = MPmap.find mp !modtab_objects in
-	  if prefix' <> prefix then
-	    anomaly "Two different modules with the same path!";
-	  modtab_objects := MPmap.add mp (prefix,objects@seg) !modtab_objects;
-      with
-	  Not_found -> anomaly "Keep objects before substitutive"
-    end;
-    load_objects i prefix seg
-
-let open_keep i ((sp,kn),seg) =
-  let dirpath,mp = dir_of_sp sp, mp_of_kn kn in
-    open_objects i (dirpath,(mp,empty_dirpath)) seg
-
-let in_modkeep : lib_objects -> obj =
-  declare_object {(default_object "MODULE KEEP OBJECTS") with
+(** {6 Declaration of module keep objects} *)
+
+let cache_keep _ = anomaly (Pp.str "This module should not be cached!")
+
+let load_keep i ((sp,kn),kobjs) =
+  (* Invariant : seg isn't empty *)
+  let dir = dir_of_sp sp and mp = mp_of_kn kn in
+  let prefix = (dir,(mp,DirPath.empty)) in
+  let prefix',sobjs,kobjs0 =
+    try ModObjs.get mp
+    with Not_found -> assert false (* a substobjs should already be loaded *)
+  in
+  assert (eq_op prefix' prefix);
+  assert (List.is_empty kobjs0);
+  ModObjs.set mp (prefix,sobjs,kobjs);
+  Lib.load_objects i prefix kobjs
+
+let open_keep i ((sp,kn),kobjs) =
+  let dir = dir_of_sp sp and mp = mp_of_kn kn in
+  let prefix = (dir,(mp,DirPath.empty)) in
+  Lib.open_objects i prefix kobjs
+
+let in_modkeep : Lib.lib_objects -> obj =
+  declare_object {(default_object "MODULE KEEP") with
     cache_function = cache_keep;
     load_function = load_keep;
     open_function = open_keep }
 
-(* we remember objects for a module type. In case of a declaration:
-   Module M:SIG:=...
-   The module M gets its objects from SIG
-*)
-let modtypetab =
-  ref (MPmap.empty : substitutive_objects MPmap.t)
 
-(* currently started interactive module type. We remember its arguments
-   if it is a functor type *)
-let openmodtype_info =
-  ref ([],[] : mod_bound_id list * module_type_body list)
+(** {6 Declaration of module type substitutive objects} *)
 
-let _ = Summary.declare_summary "MODTYPE-INFO"
-	  { Summary.freeze_function = (fun () ->
-					 !modtypetab,!openmodtype_info);
-	    Summary.unfreeze_function = (fun ft ->
-					   modtypetab := fst ft;
-					   openmodtype_info := snd ft);
-	    Summary.init_function = (fun () ->
-				       modtypetab := MPmap.empty;
-				       openmodtype_info := [],[]) }
+(** Nota: Interactive modules and module types cannot be recached!
+    This used to be checked more properly here. *)
 
+let do_modtype i sp mp sobjs =
+  if Nametab.exists_modtype sp then
+    anomaly (pr_path sp ++ str " already exists");
+  Nametab.push_modtype (Nametab.Until i) sp mp;
+  ModSubstObjs.set mp sobjs
 
-let cache_modtype ((sp,kn),(entry,modtypeobjs,sub_mty_l)) =
-  let mp = mp_of_kn kn in
+let cache_modtype ((sp,kn),sobjs) = do_modtype 1 sp (mp_of_kn kn) sobjs
+let load_modtype i ((sp,kn),sobjs) = do_modtype i sp (mp_of_kn kn) sobjs
+let subst_modtype (subst,sobjs) = subst_sobjs subst sobjs
+let classify_modtype sobjs = Substitute sobjs
 
-  (* We enrich the global environment *)
-  let _ =
-    match entry with
-      | None ->
-	  anomaly "You must not recache interactive module types!"
-      | Some (mte,inl) ->
-	  if mp <> Global.add_modtype (basename sp) mte inl then
-	    anomaly "Kernel and Library names do not match"
+let open_modtype i ((sp,kn),_) =
+  let mp = mp_of_kn kn in
+  let mp' =
+    try Nametab.locate_modtype (qualid_of_path sp)
+    with Not_found ->
+      anomaly (pr_path sp ++ str " should already exist!");
   in
+  assert (ModPath.equal mp mp');
+  Nametab.push_modtype (Nametab.Exactly i) sp mp
 
-  (* Using declare_modtype should lead here, where we check
-     that any given subtyping is indeed accurate *)
-  check_subtypes_mt mp sub_mty_l;
+let (in_modtype : substitutive_objects -> obj),
+    (out_modtype : obj -> substitutive_objects) =
+  declare_object_full {(default_object "MODULE TYPE") with
+      cache_function = cache_modtype;
+      open_function = open_modtype;
+      load_function = load_modtype;
+      subst_function = subst_modtype;
+      classify_function = classify_modtype }
 
-  if Nametab.exists_modtype sp then
-    errorlabstrm "cache_modtype"
-      (pr_path sp ++ str " already exists") ;
 
-  Nametab.push_modtype (Nametab.Until 1) sp mp;
+(** {6 Declaration of substitutive objects for Include} *)
 
-  modtypetab := MPmap.add mp modtypeobjs !modtypetab
+let do_include do_load do_open i ((sp,kn),aobjs) =
+  let dir = Libnames.dirpath sp in
+  let mp = KerName.modpath kn in
+  let prefix = (dir,(mp,DirPath.empty)) in
+  let o = expand_aobjs aobjs in
+  if do_load then Lib.load_objects i prefix o;
+  if do_open then Lib.open_objects i prefix o
 
+let cache_include = do_include true true 1
+let load_include = do_include true false
+let open_include = do_include false true
+let subst_include (subst,aobjs) = subst_aobjs subst aobjs
+let classify_include aobjs = Substitute aobjs
 
-let load_modtype i ((sp,kn),(entry,modtypeobjs,_)) =
-  assert (entry = None);
+let (in_include : algebraic_objects -> obj),
+    (out_include : obj -> algebraic_objects) =
+  declare_object_full {(default_object "INCLUDE") with
+    cache_function = cache_include;
+    load_function = load_include;
+    open_function = open_include;
+    subst_function = subst_include;
+    classify_function = classify_include }
 
-  if Nametab.exists_modtype sp then
-    errorlabstrm "cache_modtype"
-      (pr_path sp ++ str " already exists") ;
 
-  Nametab.push_modtype (Nametab.Until i) sp (mp_of_kn kn);
+(** {6 Handler for missing entries in ModSubstObjs} *)
 
-  modtypetab := MPmap.add (mp_of_kn kn) modtypeobjs !modtypetab
+(** Since the inner of Module Types are not added by default to
+    the ModSubstObjs table, we compensate this by explicit traversal
+    of Module Types inner objects when needed. Quite a hack... *)
 
+let mp_id mp id = MPdot (mp, Label.of_id id)
 
-let open_modtype i ((sp,kn),(entry,_,_)) =
-  assert (entry = None);
+let rec register_mod_objs mp (id,obj) = match object_tag obj with
+  | "MODULE" -> ModSubstObjs.set (mp_id mp id) (out_module obj)
+  | "MODULE TYPE" -> ModSubstObjs.set (mp_id mp id) (out_modtype obj)
+  | "INCLUDE" ->
+    List.iter (register_mod_objs mp) (expand_aobjs (out_include obj))
+  | _ -> ()
 
-  if
-    try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn)
-    with Not_found -> true
-  then
-    errorlabstrm ("open_modtype")
-      (pr_path sp ++ str " should already exist!");
+let handle_missing_substobjs mp = match mp with
+  | MPdot (mp',l) ->
+    let objs = expand_sobjs (ModSubstObjs.get mp') in
+    List.iter (register_mod_objs mp') objs;
+    ModSubstObjs.get mp
+  | _ ->
+    assert false (* Only inner parts of module types should be missing *)
 
-  Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn)
+let () = ModSubstObjs.set_missing_handler handle_missing_substobjs
 
-let subst_modtype (subst,(entry,(mbids,mp,objs),_)) =
-  assert (entry = None);
-  (entry,(mbids,subst_mp subst mp,subst_objects subst objs),[])
 
-let classify_modtype (_,substobjs,_) =
-  Substitute (None,substobjs,[])
 
-type modtype_obj =
-    (module_struct_entry * Entries.inline) option (* will be None in vo *)
-    * substitutive_objects
-    * module_type_body list
+(** {6 From module expression to substitutive objects} *)
 
-let in_modtype : modtype_obj -> obj =
-    declare_object {(default_object "MODULE TYPE") with
-      cache_function = cache_modtype;
-      open_function = open_modtype;
-      load_function = load_modtype;
-      subst_function = subst_modtype;
-      classify_function = classify_modtype }
+(** Turn a chain of [MSEapply] into the head module_path and the
+    list of module_path parameters (deepest param coming first).
+    The left part of a [MSEapply] must be either [MSEident] or
+    another [MSEapply]. *)
 
-let rec replace_module_object idl (mbids,mp,lib_stack) (mbids2,mp2,objs) mp1 =
-  if mbids<>[] then anomaly "Unexpected functor objects";
-  let rec replace_idl = function
-    | _,[] -> []
-    | id::idl,(id',obj)::tail when id = id' ->
-      if object_tag obj <> "MODULE" then anomaly "MODULE expected!";
-      let substobjs =
-	if idl = [] then
-	  let mp' = MPdot(mp, label_of_id id) in
-	  mbids, mp', subst_objects (map_mp mp1 mp' empty_delta_resolver) objs
-	else
-	  replace_module_object idl (out_module obj) (mbids2,mp2,objs) mp
-      in
-      (id, in_module substobjs)::tail
-    | idl,lobj::tail -> lobj::replace_idl (idl,tail)
-  in
-  (mbids, mp, replace_idl (idl,lib_stack))
-
-let discr_resolver mb = match mb.mod_type with
-  | SEBstruct _ -> Some mb.mod_delta
-  | _ -> None (* when mp is a functor *)
-
-(* Small function to avoid module typing during substobjs retrivial  *)
-let rec get_objs_modtype_application env = function
-| MSEident mp -> 
-    MPmap.find mp !modtypetab,Environ.lookup_modtype mp env,[]
-| MSEapply (fexpr, MSEident mp) -> 
-    let objs,mtb,mp_l= get_objs_modtype_application env fexpr in
-      objs,mtb,mp::mp_l
-| MSEapply (_,mexpr) ->
-    Modops.error_application_to_not_path mexpr
-| _ -> error "Application of a non-functor."
+let get_applications mexpr =
+  let rec get params = function
+    | MEident mp -> mp, params
+    | MEapply (fexpr, mp) -> get (mp::params) fexpr
+    | MEwith _ -> error "Non-atomic functor application."
+  in get [] mexpr
+
+(** Create the substitution corresponding to some functor applications *)
 
 let rec compute_subst env mbids sign mp_l inl =
   match mbids,mp_l with
     | _,[] -> mbids,empty_subst
     | [],r -> error "Application of a functor with too few arguments."
     | mbid::mbids,mp::mp_l ->
-	let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in
+	let farg_id, farg_b, fbody_b = Modops.destr_functor sign in
 	let mb = Environ.lookup_module mp env in
 	let mbid_left,subst = compute_subst env mbids fbody_b mp_l inl in
-	let resolver = match discr_resolver mb with
-	  | None -> empty_delta_resolver
-	  | Some mp_delta ->
-	      Modops.inline_delta_resolver env inl mp farg_id farg_b mp_delta
+	let resolver =
+          if Modops.is_functor mb.mod_type then empty_delta_resolver
+          else
+            Modops.inline_delta_resolver env inl mp farg_id farg_b mb.mod_delta
 	in
 	mbid_left,join (map_mbid mbid mp resolver) subst
 
-let rec get_modtype_substobjs env mp_from inline = function
-    MSEident ln -> 
-      MPmap.find ln !modtypetab 
-  | MSEfunctor (mbid,_,mte) ->
-      let (mbids, mp, objs) = get_modtype_substobjs env mp_from inline mte in
-	(mbid::mbids, mp, objs)
-  | MSEwith (mty, With_Definition _) ->
-      get_modtype_substobjs env mp_from inline mty
-  | MSEwith (mty, With_Module (idl,mp1)) -> 
-      let substobjs = get_modtype_substobjs env mp_from inline mty in
-      let modobjs = MPmap.find mp1 !modtab_substobjs in
-	replace_module_object idl substobjs modobjs mp1
-  | MSEapply (fexpr, MSEident mp) as me ->
-      let (mbids, mp1, objs),mtb_mp1,mp_l =
-	get_objs_modtype_application env me in
-      let mbids_left,subst =
-	compute_subst env mbids mtb_mp1.typ_expr (List.rev mp_l) inline
-      in
-      (mbids_left, mp1,subst_objects subst objs)
-  | MSEapply (_,mexpr) ->
-      Modops.error_application_to_not_path mexpr
-
-(* push names of bound modules (and their components) to Nametab *)
-(* add objects associated to them *)
-let process_module_bindings argids args =
-  let process_arg id (mbid,(mty,ann)) =
-    let dir = make_dirpath [id] in
-    let mp = MPbound mbid in
-    let (mbids,mp_from,objs) =
-      get_modtype_substobjs (Global.env()) mp (inline_annot ann) mty in
-    let substobjs = (mbids,mp,subst_objects
-		       (map_mp mp_from mp empty_delta_resolver) objs)in
-      do_module false "start" load_objects 1 dir mp substobjs []
+(** Create the objects of a "with Module" structure. *)
+
+let rec replace_module_object idl mp0 objs0 mp1 objs1 =
+  match idl, objs0 with
+  | _,[] -> []
+  | id::idl,(id',obj)::tail when Id.equal id id' ->
+    assert (object_has_tag obj "MODULE");
+    let mp_id = MPdot(mp0, Label.of_id id) in
+    let objs = match idl with
+      | [] -> Lib.subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1
+      | _ ->
+        let objs_id = expand_sobjs (out_module obj) in
+        replace_module_object idl mp_id objs_id mp1 objs1
     in
-      List.iter2 process_arg argids args
-
-(* Same with module_type_body *)
-
-let rec seb2mse = function
-  | SEBident mp -> MSEident mp
-  | SEBapply (s,s',_) -> MSEapply(seb2mse s, seb2mse s')
-  | SEBwith (s,With_module_body (l,mp)) -> MSEwith(seb2mse s,With_Module(l,mp))
-  | SEBwith (s,With_definition_body(l,cb)) ->
-      (match cb.const_body with
-	| Def c -> MSEwith(seb2mse s,With_Definition(l,Declarations.force c))
-	| _ -> assert false)
-  | _ -> failwith "seb2mse: received a non-atomic seb"
-
-let process_module_seb_binding mbid seb =
-  process_module_bindings [id_of_mbid mbid]
-    [mbid,
-     (seb2mse seb,
-      { ann_inline = DefaultInline; ann_scope_subst = [] })]
-
-let intern_args interp_modtype (idl,(arg,ann)) =
-  let inl = inline_annot ann in
+    (id, in_module ([], Objs objs))::tail
+  | idl,lobj::tail -> lobj::replace_module_object idl mp0 tail mp1 objs1
+
+let type_of_mod mp env = function
+  |true -> (Environ.lookup_module mp env).mod_type
+  |false -> (Environ.lookup_modtype mp env).mod_type
+
+let rec get_module_path = function
+  |MEident mp -> mp
+  |MEwith (me,_) -> get_module_path me
+  |MEapply (me,_) -> get_module_path me
+
+(** Substitutive objects of a module expression (or module type) *)
+
+let rec get_module_sobjs is_mod env inl = function
+  |MEident mp ->
+    begin match ModSubstObjs.get mp with
+    |(mbids,Objs _) when not (ModPath.is_bound mp) ->
+      (mbids,Ref (mp, empty_subst)) (* we create an alias *)
+    |sobjs -> sobjs
+    end
+  |MEwith (mty, WithDef _) -> get_module_sobjs is_mod env inl mty
+  |MEwith (mty, WithMod (idl,mp1)) ->
+    assert (not is_mod);
+    let sobjs0 = get_module_sobjs is_mod env inl mty in
+    assert (sobjs_no_functor sobjs0);
+    (* For now, we expanse everything, to be safe *)
+    let mp0 = get_module_path mty in
+    let objs0 = expand_sobjs sobjs0 in
+    let objs1 = expand_sobjs (ModSubstObjs.get mp1) in
+    ([], Objs (replace_module_object idl mp0 objs0 mp1 objs1))
+  |MEapply _ as me ->
+    let mp1, mp_l = get_applications me in
+    let mbids, aobjs = get_module_sobjs is_mod env inl (MEident mp1) in
+    let typ = type_of_mod mp1 env is_mod in
+    let mbids_left,subst = compute_subst env mbids typ mp_l inl in
+    (mbids_left, subst_aobjs subst aobjs)
+
+let get_functor_sobjs is_mod env inl (params,mexpr) =
+  let (mbids, aobjs) = get_module_sobjs is_mod env inl mexpr in
+  (List.map fst params @ mbids, aobjs)
+
+
+(** {6 Handling of module parameters} *)
+
+(** For printing modules, [process_module_binding] adds names of
+    bound module (and its components) to Nametab. It also loads
+    objects associated to it. *)
+
+let process_module_binding mbid me =
+  let dir = DirPath.make [MBId.to_id mbid] in
+  let mp = MPbound mbid in
+  let sobjs = get_module_sobjs false (Global.env()) (default_inline ()) me in
+  let subst = map_mp (get_module_path me) mp empty_delta_resolver in
+  let sobjs = subst_sobjs subst sobjs in
+  do_module false Lib.load_objects 1 dir mp sobjs []
+
+(** Process a declaration of functor parameter(s) (Id1 .. Idn : Typ)
+    i.e. possibly multiple names with the same module type.
+    Global environment is updated on the fly.
+    Objects in these parameters are also loaded.
+    Output is accumulated on top of [acc] (in reverse order). *)
+
+let intern_arg interp_modast acc (idl,(typ,ann)) =
+  let inl = inl2intopt ann in
   let lib_dir = Lib.library_dp() in
-  let mbids = List.map (fun (_,id) -> make_mbid lib_dir id) idl in
-  let mty = interp_modtype (Global.env()) arg in
-  let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in
-  let (mbi,mp_from,objs) = get_modtype_substobjs (Global.env())
-    (MPbound (List.hd mbids)) inl mty in
-  List.map2
-    (fun dir mbid ->
-       let resolver = Global.add_module_parameter mbid mty inl in
-       let mp = MPbound mbid in
-       let substobjs = (mbi,mp,subst_objects
-			  (map_mp mp_from mp resolver) objs) in
-	 do_module false "interp" load_objects 1 dir mp substobjs [];
-	 (mbid,(mty,inl)))
-    dirs mbids
-
-let start_module_ interp_modtype export id args res fs =
-  let mp = Global.start_module id in
-  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-  let res_entry_o, sub_body_l = match res with
-    | Enforce (res,ann) ->
-        let inl = inline_annot ann in
-	let mte = interp_modtype (Global.env()) res in
-	let _ = Mod_typing.translate_struct_type_entry (Global.env()) inl mte in
-	Some (mte,inl), []
-    | Check resl ->
-	None, build_subtypes interp_modtype mp arg_entries resl
-  in
-  let mbids = List.map fst arg_entries in
-  openmod_info:=(mp,mbids,res_entry_o,sub_body_l);
-  let prefix = Lib.start_module export id mp fs in
-  Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
-  Lib.add_frozen_state (); mp
+  let env = Global.env() in
+  let mty,_ = interp_modast env ModType typ in
+  let sobjs = get_module_sobjs false env inl mty in
+  let mp0 = get_module_path mty in
+  List.fold_left
+    (fun acc (_,id) ->
+      let dir = DirPath.make [id] in
+      let mbid = MBId.make lib_dir id in
+      let mp = MPbound mbid in
+      let resolver = Global.add_module_parameter mbid mty inl in
+      let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in
+      do_module false Lib.load_objects 1 dir mp sobjs [];
+      (mbid,mty,inl)::acc)
+    acc idl
+
+(** Process a list of declarations of functor parameters
+    (Id11 .. Id1n : Typ1)..(Idk1 .. Idkm : Typk)
+    Global environment is updated on the fly.
+    The calls to [interp_modast] should be interleaved with these
+    env updates, otherwise some "with Definition" could be rejected.
+    Returns a list of mbids and entries (in reversed order).
+
+    This used to be a [List.concat (List.map ...)], but this should
+    be more efficient and independent of [List.map] eval order.
+*)
 
+let intern_args interp_modast params =
+  List.fold_left (intern_arg interp_modast) [] params
 
-let end_module () =
 
-  let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in
-  let mp,mbids, res_o, sub_l = !openmod_info in
-  let substitute, keep, special = Lib.classify_segment lib_stack in
-
-  let mp_from,substobjs, keep, special = try
-    match res_o with
-      | None ->
-	  (* the module is not sealed *)
-	  None,( mbids, mp, substitute), keep, special
-      | Some (MSEident ln as mty, inline) ->
-	  let (mbids1,mp1,objs) =
-	    get_modtype_substobjs (Global.env()) mp inline mty in
-	  Some mp1,(mbids@mbids1,mp1,objs), [], []
-      | Some (MSEwith _ as mty, inline) ->
-	  let (mbids1,mp1,objs) =
-	    get_modtype_substobjs (Global.env()) mp inline mty in
-	  Some mp1,(mbids@mbids1,mp1,objs), [], []
-      | Some (MSEfunctor _, _) ->
-	  anomaly "Funsig cannot be here..."
-      | Some (MSEapply _ as mty, inline) ->
-	  let (mbids1,mp1,objs) =
-	    get_modtype_substobjs (Global.env()) mp inline mty in
-	  Some mp1,(mbids@mbids1,mp1,objs), [], []
-  with
-	Not_found -> anomaly "Module objects not found..."
-  in
-    (* must be called after get_modtype_substobjs, because of possible
-     dependencies on functor arguments *)
+(** {6 Auxiliary functions concerning subtyping checks} *)
 
-  let id = basename (fst oldoname) in
-  let mp,resolver = Global.end_module fs id res_o in
+let check_sub mtb sub_mtb_l =
+  (* The constraints are checked and forgot immediately : *)
+  ignore (List.fold_right
+	    (fun sub_mtb env ->
+	       Environ.add_constraints
+		 (Subtyping.check_subtypes env mtb sub_mtb) env)
+	    sub_mtb_l (Global.env()))
 
-  check_subtypes mp sub_l;
+(** This function checks if the type calculated for the module [mp] is
+    a subtype of all signatures in [sub_mtb_l]. Uses only the global
+    environment. *)
 
-(* we substitute objects if the module is 
-   sealed by a signature (ie. mp_from != None *)
-  let substobjs = match mp_from,substobjs with
-      None,_ -> substobjs
-    | Some mp_from,(mbids,_,objs) ->
-	(mbids,mp,subst_objects (map_mp mp_from mp resolver) objs) 
+let check_subtypes mp sub_mtb_l =
+  let mb =
+    try Global.lookup_module mp with Not_found -> assert false
   in
-  let node = in_module substobjs in
-  let objects =
-    if keep = [] || mbids <> [] then
-      special@[node]   (* no keep objects or we are defining a functor *)
-    else
-      special@[node;in_modkeep keep]   (* otherwise *)
+  let mtb = Modops.module_type_of_module mb in
+  check_sub mtb sub_mtb_l
+
+(** Same for module type [mp] *)
+
+let check_subtypes_mt mp sub_mtb_l =
+  let mtb =
+    try Global.lookup_modtype mp with Not_found -> assert false
   in
-  let newoname = Lib.add_leaves id objects in
+  check_sub mtb sub_mtb_l
 
-    if (fst newoname) <> (fst oldoname) then
-      anomaly "Names generated on start_ and end_module do not match";
-    if mp_of_kn (snd newoname) <> mp then
-      anomaly "Kernel and Library names do not match";
+(** Create a params entry.
+    In [args], the youngest module param now comes first. *)
 
-    Lib.add_frozen_state () (* to prevent recaching *);
-    mp
+let mk_params_entry args =
+  List.rev_map (fun (mbid,arg_t,_) -> (mbid,arg_t)) args
 
+(** Create a functor type struct.
+    In [args], the youngest module param now comes first. *)
 
+let mk_funct_type env args seb0 =
+  List.fold_left
+    (fun seb (arg_id,arg_t,arg_inl) ->
+      let mp = MPbound arg_id in
+      let arg_t = Mod_typing.translate_modtype env mp arg_inl ([],arg_t) in
+      MoreFunctor(arg_id,arg_t,seb))
+    seb0 args
 
-let module_objects mp =
-  let prefix,objects = MPmap.find mp !modtab_objects in
-    segment_of_objects prefix objects
+(** Prepare the module type list for check of subtypes *)
 
+let build_subtypes interp_modast env mp args mtys =
+  List.map
+    (fun (m,ann) ->
+       let inl = inl2intopt ann in
+       let mte,_ = interp_modast env ModType m in
+       let mtb = Mod_typing.translate_modtype env mp inl ([],mte) in
+       { mtb with mod_type = mk_funct_type env args mtb.mod_type })
+    mtys
 
 
-(************************************************************************)
-(* libraries *)
+(** {6 Current module information}
 
-type library_name = dir_path
+    This information is stored by each [start_module] for use
+    in a later [end_module]. *)
 
-(* The first two will form substitutive_objects, the last one is keep *)
-type library_objects =
-    module_path * lib_objects * lib_objects
+type current_module_info = {
+  cur_typ : (module_struct_entry * int option) option; (** type via ":" *)
+  cur_typs : module_type_body list (** types via "<:" *)
+}
 
+let default_module_info = { cur_typ = None; cur_typs = [] }
 
-let register_library dir cenv objs digest =
-  let mp = MPfile dir in
-  let substobjs, keep =
-  try 
-    ignore(Global.lookup_module mp);
-    (* if it's in the environment, the cached objects should be correct *)
-    Dirmap.find dir !library_cache
-  with Not_found ->
-    if mp <> Global.import cenv digest then
-      anomaly "Unexpected disk module name";
-    let mp,substitute,keep = objs in
-    let substobjs = [], mp, substitute in
-    let modobjs = substobjs, keep in
-    library_cache := Dirmap.add dir modobjs !library_cache;
-      modobjs
-  in
-    do_module false "register_library" load_objects 1 dir mp substobjs keep
+let openmod_info = Summary.ref default_module_info ~name:"MODULE-INFO"
 
-let start_library dir =
-  let mp = Global.start_library dir in
-  openmod_info:=mp,[],None,[];
-  Lib.start_compilation dir mp;
-  Lib.add_frozen_state ()
 
-let end_library_hook = ref ignore
-let set_end_library_hook f = end_library_hook := f
+(** {6 Current module type information}
 
-let end_library dir =
-  !end_library_hook();
-  let prefix, lib_stack = Lib.end_compilation dir in
-  let mp,cenv = Global.export dir in
-  let substitute, keep, _ = Lib.classify_segment lib_stack in
-    cenv,(mp,substitute,keep)
+   This information is stored by each [start_modtype] for use
+   in a later [end_modtype]. *)
 
+let openmodtype_info =
+  Summary.ref ([] : module_type_body list) ~name:"MODTYPE-INFO"
 
-(* implementation of Export M and Import M *)
 
+(** {6 Modules : start, end, declare} *)
 
-let really_import_module mp =
-  let prefix,objects = MPmap.find mp !modtab_objects in
-    open_objects 1 prefix objects
+module RawModOps = struct
 
+let start_module interp_modast export id args res fs =
+  let mp = Global.start_module id in
+  let arg_entries_r = intern_args interp_modast args in
+  let env = Global.env () in
+  let res_entry_o, subtyps = match res with
+    | Enforce (res,ann) ->
+        let inl = inl2intopt ann in
+	let mte,_ = interp_modast env ModType res in
+        (* We check immediately that mte is well-formed *)
+	let _ = Mod_typing.translate_mse env None inl mte in
+	Some (mte,inl), []
+    | Check resl ->
+	None, build_subtypes interp_modast env mp arg_entries_r resl
+  in
+  openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps };
+  let prefix = Lib.start_module export id mp fs in
+  Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix);
+  Lib.add_frozen_state (); mp
 
-let cache_import (_,(_,mp)) =
-(* for non-substitutive exports:
-  let mp = Nametab.locate_module (qualid_of_dirpath dir) in  *)
-  really_import_module mp
+let end_module () =
+  let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in
+  let substitute, keep, special = Lib.classify_segment lib_stack in
+  let m_info = !openmod_info in
 
-let classify_import (export,_ as obj) =
-  if export then Substitute obj else Dispose
+  (* For sealed modules, we use the substitutive objects of their signatures *)
+  let sobjs0, keep, special = match m_info.cur_typ with
+    | None -> ([], Objs substitute), keep, special
+    | Some (mty, inline) ->
+      get_module_sobjs false (Global.env()) inline mty, [], []
+  in
+  let id = basename (fst oldoname) in
+  let mp,mbids,resolver = Global.end_module fs id m_info.cur_typ in
+  let sobjs = let (ms,objs) = sobjs0 in (mbids@ms,objs) in
 
-let subst_import (subst,(export,mp as obj)) =
-   let mp' = subst_mp subst mp in
-    if mp'==mp then obj else
-      (export,mp')
+  check_subtypes mp m_info.cur_typs;
 
-let in_import =
-  declare_object {(default_object "IMPORT MODULE") with
-		    cache_function = cache_import;
-		    open_function = (fun i o -> if i=1 then cache_import o);
-		    subst_function = subst_import;
-		    classify_function = classify_import }
+  (* We substitute objects if the module is sealed by a signature *)
+  let sobjs =
+    match m_info.cur_typ with
+      | None -> sobjs
+      | Some (mty, _) ->
+        subst_sobjs (map_mp (get_module_path mty) mp resolver) sobjs
+  in
+  let node = in_module sobjs in
+  (* We add the keep objects, if any, and if this isn't a functor *)
+  let objects = match keep, mbids with
+    | [], _ | _, _ :: _ -> special@[node]
+    | _ -> special@[node;in_modkeep keep]
+  in
+  let newoname = Lib.add_leaves id objects in
 
+  (* Name consistency check : start_ vs. end_module, kernel vs. library *)
+  assert (eq_full_path (fst newoname) (fst oldoname));
+  assert (ModPath.equal (mp_of_kn (snd newoname)) mp);
 
-let import_module export mp =
-  Lib.add_anonymous_leaf (in_import (export,mp))
+  Lib.add_frozen_state () (* to prevent recaching *);
+  mp
 
-(************************************************************************)
-(* module types *)
+let declare_module interp_modast id args res mexpr_o fs =
+  (* We simulate the beginning of an interactive module,
+     then we adds the module parameters to the global env. *)
+  let mp = Global.start_module id in
+  let arg_entries_r = intern_args interp_modast args in
+  let params = mk_params_entry arg_entries_r in
+  let env = Global.env () in
+  let mty_entry_o, subs, inl_res = match res with
+    | Enforce (mty,ann) ->
+        Some (fst (interp_modast env ModType mty)), [], inl2intopt ann
+    | Check mtys ->
+	None, build_subtypes interp_modast env mp arg_entries_r mtys,
+        default_inline ()
+  in
+  let mexpr_entry_o, inl_expr = match mexpr_o with
+    | None -> None, default_inline ()
+    | Some (mexpr,ann) ->
+      Some (fst (interp_modast env Module mexpr)), inl2intopt ann
+  in
+  let entry = match mexpr_entry_o, mty_entry_o with
+    | None, None -> assert false (* No body, no type ... *)
+    | None, Some typ -> MType (params, typ)
+    | Some body, otyp -> MExpr (params, body, otyp)
+  in
+  let sobjs, mp0 = match entry with
+    | MType (_,mte) | MExpr (_,_,Some mte) ->
+      get_functor_sobjs false env inl_res (params,mte), get_module_path mte
+    | MExpr (_,me,None) ->
+      get_functor_sobjs true env inl_expr (params,me), get_module_path me
+  in
+  (* Undo the simulated interactive building of the module
+     and declare the module as a whole *)
+  Summary.unfreeze_summaries fs;
+  let inl = match inl_expr with
+  | None -> None
+  | _ -> inl_res
+  in
+  let mp_env,resolver = Global.add_module id entry inl in
+
+  (* Name consistency check : kernel vs. library *)
+  assert (ModPath.equal mp (mp_of_kn (Lib.make_kn id)));
+  assert (ModPath.equal mp mp_env);
+
+  check_subtypes mp subs;
 
-let start_modtype_ interp_modtype id args mtys fs =
+  let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in
+  ignore (Lib.add_leaf id (in_module sobjs));
+  mp
+
+end
+
+(** {6 Module types : start, end, declare} *)
+
+module RawModTypeOps = struct
+
+let start_modtype interp_modast id args mtys fs =
   let mp = Global.start_modtype id in
-  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-  let sub_mty_l = build_subtypes interp_modtype mp arg_entries mtys in
-  let mbids = List.map fst arg_entries in
-  openmodtype_info := mbids, sub_mty_l;
+  let arg_entries_r = intern_args interp_modast args in
+  let env = Global.env () in
+  let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in
+  openmodtype_info := sub_mty_l;
   let prefix = Lib.start_modtype id mp fs in
   Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix);
   Lib.add_frozen_state (); mp
 
-
 let end_modtype () =
   let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in
   let id = basename (fst oldoname) in
   let substitute, _, special = Lib.classify_segment lib_stack in
-  let mbids, sub_mty_l = !openmodtype_info in
-  let mp = Global.end_modtype fs id in
-  let modtypeobjs = mbids, mp, substitute in
+  let sub_mty_l = !openmodtype_info in
+  let mp, mbids = Global.end_modtype fs id in
+  let modtypeobjs = (mbids, Objs substitute) in
   check_subtypes_mt mp sub_mty_l;
-  let oname = Lib.add_leaves id (special@[in_modtype (None, modtypeobjs,[])])
+  let oname = Lib.add_leaves id (special@[in_modtype modtypeobjs])
   in
-  if fst oname <> fst oldoname then
-    anomaly
-      "Section paths generated on start_ and end_modtype do not match";
-  if (mp_of_kn (snd oname)) <> mp then
-    anomaly
-      "Kernel and Library names do not match";
+  (* Check name consistence : start_ vs. end_modtype, kernel vs. library *)
+  assert (eq_full_path (fst oname) (fst oldoname));
+  assert (ModPath.equal (mp_of_kn (snd oname)) mp);
 
   Lib.add_frozen_state ()(* to prevent recaching *);
   mp
 
-
-let declare_modtype_ interp_modtype id args mtys (mty,ann) fs =
-  let inl = inline_annot ann in
-  let mmp = Global.start_modtype id in
-  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-  let entry = funct_entry arg_entries (interp_modtype (Global.env()) mty) in
-  (* NB: check of subtyping will be done in cache_modtype *)
-  let sub_mty_l = build_subtypes interp_modtype mmp arg_entries mtys in
-  let (mbids,mp_from,objs) = get_modtype_substobjs (Global.env()) mmp inl entry in
-  (* Undo the simulated interactive building of the module type *)
-  (* and declare the module type as a whole *)
-
-  register_scope_subst ann.ann_scope_subst;
-  let substobjs = (mbids,mmp,
-		   subst_objects (map_mp mp_from mmp empty_delta_resolver) objs)
-  in
-  reset_scope_subst ();
+let declare_modtype interp_modast id args mtys (mty,ann) fs =
+  let inl = inl2intopt ann in
+  (* We simulate the beginning of an interactive module,
+     then we adds the module parameters to the global env. *)
+  let mp = Global.start_modtype id in
+  let arg_entries_r = intern_args interp_modast args in
+  let params = mk_params_entry arg_entries_r in
+  let env = Global.env () in
+  let entry = params, fst (interp_modast env ModType mty) in
+  let sub_mty_l = build_subtypes interp_modast env mp arg_entries_r mtys in
+  let sobjs = get_functor_sobjs false env inl entry in
+  let subst = map_mp (get_module_path (snd entry)) mp empty_delta_resolver in
+  let sobjs = subst_sobjs subst sobjs in
+
+  (* Undo the simulated interactive building of the module type
+     and declare the module type as a whole *)
   Summary.unfreeze_summaries fs;
-  ignore (add_leaf id (in_modtype (Some (entry,inl), substobjs, sub_mty_l)));
-  mmp
-
-
-(* Small function to avoid module typing during substobjs retrivial  *)
-let rec get_objs_module_application env = function
-| MSEident mp -> 
-    MPmap.find mp !modtab_substobjs,Environ.lookup_module mp env,[]
-| MSEapply (fexpr, MSEident mp) -> 
-    let objs,mtb,mp_l= get_objs_module_application env fexpr in
-      objs,mtb,mp::mp_l
-| MSEapply (_,mexpr) ->
-    Modops.error_application_to_not_path mexpr
-| _ -> error "Application of a non-functor."
-
-
-let rec get_module_substobjs env mp_from inl = function
-  | MSEident mp -> MPmap.find mp !modtab_substobjs
-  | MSEfunctor (mbid,mty,mexpr) ->
-       let (mbids, mp, objs) = get_module_substobjs env mp_from inl mexpr in
-	(mbid::mbids, mp, objs)
-  | MSEapply (fexpr, MSEident mp) as me ->
-      let (mbids, mp1, objs),mb_mp1,mp_l =
-	get_objs_module_application env me
-      in
-      let mbids_left,subst =
-	compute_subst env mbids mb_mp1.mod_type (List.rev mp_l) inl in
-      (mbids_left, mp1,subst_objects subst objs)
-  | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr
-  | MSEwith (mty, With_Definition _) -> get_module_substobjs env mp_from inl mty
-  | MSEwith (mty, With_Module (idl,mp)) -> assert false
-
-
-let declare_module_ interp_modtype interp_modexpr id args res mexpr_o fs =
-  let mmp = Global.start_module id in
-  let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in
-
-  let funct f m = funct_entry arg_entries (f (Global.env ()) m) in
-  let env = Global.env() in
-  let mty_entry_o, subs, inl_res = match res with
-    | Enforce (mty,ann) ->
-        Some (funct interp_modtype mty), [], inline_annot ann
-    | Check mtys ->
-	None, build_subtypes interp_modtype mmp arg_entries mtys,
-        default_inline ()
-  in
- 
-  (*let subs = List.map (Mod_typing.translate_module_type env mmp) mty_sub_l in  *)
-  let mexpr_entry_o, inl_expr, scl = match mexpr_o with
-    | None -> None, default_inline (), []
-    | Some (mexpr,ann) ->
-      Some (funct interp_modexpr mexpr), inline_annot ann, ann.ann_scope_subst
 
-  in
-  let entry =
-    {mod_entry_type = mty_entry_o;
-     mod_entry_expr = mexpr_entry_o }
-  in
+  (* We enrich the global environment *)
+  let mp_env = Global.add_modtype id entry inl in
 
-  let substobjs =
-    match entry with
-      | {mod_entry_type = Some mte} -> get_modtype_substobjs env mmp inl_res mte
-      | {mod_entry_expr = Some mexpr} -> get_module_substobjs env mmp inl_expr mexpr
-      | _ -> anomaly "declare_module: No type, no body ..."
-  in
-  let (mbids,mp_from,objs) = substobjs in
-  (* Undo the simulated interactive building of the module *)
-  (* and declare the module as a whole *)
-  Summary.unfreeze_summaries fs;
-  let mp = mp_of_kn (Lib.make_kn id) in
-  let inl = if inl_expr = None then None else inl_res in (*PLTODO *)
-  let mp_env,resolver = Global.add_module id entry inl in
+  (* Name consistency check : kernel vs. library *)
+  assert (ModPath.equal mp_env mp);
 
-  if mp_env <> mp then anomaly "Kernel and Library names do not match";
+  (* Subtyping checks *)
+  check_subtypes_mt mp sub_mty_l;
 
-  
-  check_subtypes mp subs;
-  register_scope_subst scl;
-  let substobjs = (mbids,mp_env,
-		   subst_objects(map_mp mp_from mp_env resolver) objs) in
-  reset_scope_subst ();
-  ignore (add_leaf
-	    id
-	    (in_module substobjs));
-  mmp
-
-(* Include *)
-
-let rec subst_inc_expr subst me =
-  match me with
-    | MSEident mp -> MSEident (subst_mp subst mp)
-    | MSEwith (me,With_Module(idl,mp)) ->
-	MSEwith (subst_inc_expr subst me,
-		 With_Module(idl,subst_mp subst mp))
-    | MSEwith (me,With_Definition(idl,const))->
-	let const1 = Mod_subst.from_val const in
-	let force = Mod_subst.force subst_mps in
-	MSEwith (subst_inc_expr subst me,
-		 With_Definition(idl,force (subst_substituted
-					   subst const1)))
-    | MSEapply (me1,me2) ->
-	MSEapply (subst_inc_expr subst me1,
-		  subst_inc_expr subst me2)
-    | MSEfunctor(mbid,me1,me2) ->
-        MSEfunctor (mbid, subst_inc_expr subst me1, subst_inc_expr subst me2)
-
-let lift_oname (sp,kn) =
-  let mp,_,_ = Names.repr_kn kn in
-  let dir,_ = Libnames.repr_path sp in
-    (dir,mp)
-
-let cache_include (oname,(me,(mbis,mp1,objs))) =
-  let dir,mp1 = lift_oname oname in
-  let prefix = (dir,(mp1,empty_dirpath)) in
-    load_objects 1 prefix objs;
-    open_objects 1 prefix objs
-
-let load_include  i (oname,(me,(mbis,mp1,objs))) =
-  let dir,mp1 = lift_oname oname in
-  let prefix = (dir,(mp1,empty_dirpath)) in
-    load_objects i prefix objs
-
-let open_include i (oname,(me,(mbis,mp1,objs))) =
-  let dir,mp1 = lift_oname oname in
-  let prefix = (dir,(mp1,empty_dirpath)) in
-    open_objects i prefix objs
-
-let subst_include (subst,(me,substobj)) =
-  let (mbids,mp,objs) = substobj in
-  let substobjs = (mbids,subst_mp subst mp,subst_objects subst objs) in
-    (subst_inc_expr subst me,substobjs)
-
-let classify_include (me,substobjs) = Substitute (me,substobjs)
-
-type include_obj = module_struct_entry * substitutive_objects
-
-let (in_include : include_obj -> obj),
-    (out_include : obj -> include_obj) =
-  declare_object_full {(default_object "INCLUDE") with
-    cache_function = cache_include;
-    load_function = load_include;
-    open_function = open_include;
-    subst_function = subst_include;
-    classify_function = classify_include }
+  ignore (Lib.add_leaf id (in_modtype sobjs));
+  mp
 
-let rec include_subst env mb mbids sign inline =
-  match mbids with
-    | [] -> empty_subst
-    | mbid::mbids ->
-	let farg_id, farg_b, fbody_b = Modops.destr_functor env sign in
-	let subst = include_subst env mb mbids fbody_b inline in
-	let mp_delta =
-	  Modops.inline_delta_resolver env inline mb.mod_mp
-	    farg_id farg_b mb.mod_delta
-	in
-	join (map_mbid mbid mb.mod_mp mp_delta) subst
-
-exception NothingToDo
-
-let get_includeself_substobjs env objs me is_mod inline =
-  try
-    let mb_mp = match me with
-      | MSEident mp ->
-	  if is_mod then
-	    Environ.lookup_module mp env
-	  else
-	    Modops.module_body_of_type mp (Environ.lookup_modtype mp env)
-      | MSEapply(fexpr, MSEident p) as mexpr ->
-	  let _,mb_mp,mp_l =
-	    if is_mod then
-	      get_objs_module_application env mexpr
-	    else
-	      let o,mtb_mp,mp_l = get_objs_modtype_application env mexpr in
-	      o,Modops.module_body_of_type mtb_mp.typ_mp mtb_mp,mp_l
-	  in
-	  List.fold_left
-	    (fun mb _ ->
-	       match mb.mod_type with
-		 |  SEBfunctor(_,_,str) -> {mb with mod_type = str}
-		 | _ -> error "Application of a functor with too much arguments.")
-	    mb_mp mp_l
-      | _ -> raise NothingToDo
+end
+
+(** {6 Include} *)
+
+module RawIncludeOps = struct
+
+let rec include_subst env mp reso mbids sign inline = match mbids with
+  | [] -> empty_subst
+  | mbid::mbids ->
+    let farg_id, farg_b, fbody_b = Modops.destr_functor sign in
+    let subst = include_subst env mp reso mbids fbody_b inline in
+    let mp_delta =
+      Modops.inline_delta_resolver env inline mp farg_id farg_b reso
     in
-    let (mbids,mp_self,objects) = objs in
-    let mb = Global.pack_module() in
-    let subst = include_subst env mb mbids mb_mp.mod_type inline in
-    ([],mp_self,subst_objects subst objects)
-  with NothingToDo -> objs
+    join (map_mbid mbid mp mp_delta) subst
 
+let rec decompose_functor mpl typ =
+  match mpl, typ with
+  | [], _ -> typ
+  | _::mpl, MoreFunctor(_,_,str) -> decompose_functor mpl str
+  | _ -> error "Application of a functor with too much arguments."
 
+exception NoIncludeSelf
 
+let type_of_incl env is_mod = function
+  |MEident mp -> type_of_mod mp env is_mod
+  |MEapply _ as me ->
+    let mp0, mp_l = get_applications me in
+    decompose_functor mp_l (type_of_mod mp0 env is_mod)
+  |MEwith _ -> raise NoIncludeSelf
 
-let declare_one_include_inner annot (me,is_mod) =
+let declare_one_include interp_modast (me_ast,annot) =
   let env = Global.env() in
-  let mp1,_ = current_prefix () in
-  let inl = inline_annot annot in
-  let (mbids,mp,objs)=
-    if is_mod then
-      get_module_substobjs env mp1 inl me
-    else
-      get_modtype_substobjs env mp1 inl me in
-  let (mbids,mp,objs) =
-    if mbids <> [] then
-      get_includeself_substobjs env (mbids,mp,objs) me is_mod inl
-    else
-      (mbids,mp,objs) in
-  let id = current_mod_id() in
-  let resolver =  Global.add_include me is_mod inl in
-  register_scope_subst annot.ann_scope_subst;
-  let substobjs = (mbids,mp1,
-		   subst_objects (map_mp mp mp1 resolver) objs) in
-  reset_scope_subst ();
-  ignore (add_leaf id (in_include (me, substobjs)))
-
-let declare_one_include interp_struct (me_ast,annot) =
-  declare_one_include_inner annot
-    (interp_struct (Global.env()) me_ast)
-
-let declare_include_ interp_struct me_asts =
-  List.iter (declare_one_include interp_struct) me_asts
-
-(** Versions of earlier functions taking care of the freeze/unfreeze
-    of summaries *)
+  let me,kind = interp_modast env ModAny me_ast in
+  let is_mod = (kind == Module) in
+  let cur_mp = Lib.current_mp () in
+  let inl = inl2intopt annot in
+  let mbids,aobjs = get_module_sobjs is_mod env inl me in
+  let subst_self =
+    try
+      if List.is_empty mbids then raise NoIncludeSelf;
+      let typ = type_of_incl env is_mod me in
+      let reso,_ = Safe_typing.delta_of_senv (Global.safe_env ()) in
+      include_subst env cur_mp reso mbids typ inl
+    with NoIncludeSelf -> empty_subst
+  in
+  let base_mp = get_module_path me in
+  let resolver = Global.add_include me is_mod inl in
+  let subst = join subst_self (map_mp base_mp cur_mp resolver) in
+  let aobjs = subst_aobjs subst aobjs in
+  ignore (Lib.add_leaf (Lib.current_mod_id ()) (in_include aobjs))
+
+let declare_include interp me_asts =
+  List.iter (declare_one_include interp) me_asts
+
+end
+
+
+(** {6 Module operations handling summary freeze/unfreeze} *)
 
 let protect_summaries f =
-  let fs = Summary.freeze_summaries () in
+  let fs = Summary.freeze_summaries ~marshallable:`No in
   try f fs
   with reraise ->
     (* Something wrong: undo the whole process *)
-    Summary.unfreeze_summaries fs; raise reraise
+    let reraise = Errors.push reraise in
+    let () = Summary.unfreeze_summaries fs in
+    iraise reraise
+
+let start_module interp export id args res =
+  protect_summaries (RawModOps.start_module interp export id args res)
 
-let declare_include interp_struct me_asts =
-  protect_summaries
-    (fun _ -> declare_include_ interp_struct me_asts)
+let end_module = RawModOps.end_module
 
-let declare_modtype interp_mt interp_mix id args mtys mty_l =
+let declare_module interp id args mtys me_l =
+  let declare_me fs = match me_l with
+    | [] -> RawModOps.declare_module interp id args mtys None fs
+    | [me] -> RawModOps.declare_module interp id args mtys (Some me) fs
+    | me_l ->
+	ignore (RawModOps.start_module interp None id args mtys fs);
+	RawIncludeOps.declare_include interp me_l;
+	RawModOps.end_module ()
+  in
+  protect_summaries declare_me
+
+let start_modtype interp id args mtys =
+  protect_summaries (RawModTypeOps.start_modtype interp id args mtys)
+
+let end_modtype = RawModTypeOps.end_modtype
+
+let declare_modtype interp id args mtys mty_l =
   let declare_mt fs = match mty_l with
     | [] -> assert false
-    | [mty] -> declare_modtype_ interp_mt id args mtys mty fs
+    | [mty] -> RawModTypeOps.declare_modtype interp id args mtys mty fs
     | mty_l ->
-	ignore (start_modtype_ interp_mt id args mtys fs);
-	declare_include_ interp_mix mty_l;
-	end_modtype ()
+	ignore (RawModTypeOps.start_modtype interp id args mtys fs);
+	RawIncludeOps.declare_include interp mty_l;
+	RawModTypeOps.end_modtype ()
   in
   protect_summaries declare_mt
 
-let start_modtype interp_modtype id args mtys =
-  protect_summaries (start_modtype_ interp_modtype id args mtys)
+let declare_include interp me_asts =
+  protect_summaries (fun _ -> RawIncludeOps.declare_include interp me_asts)
 
-let declare_module interp_mt interp_me interp_mix id args mtys me_l =
-  let declare_me fs = match me_l with
-    | [] -> declare_module_ interp_mt interp_me id args mtys None fs
-    | [me] -> declare_module_ interp_mt interp_me id args mtys (Some me) fs
-    | me_l ->
-	ignore (start_module_ interp_mt None id args mtys fs);
-	declare_include_ interp_mix me_l;
-	end_module ()
+
+(** {6 Libraries} *)
+
+type library_name = DirPath.t
+
+(** A library object is made of some substitutive objects
+    and some "keep" objects. *)
+
+type library_objects = Lib.lib_objects * Lib.lib_objects
+
+(** For the native compiler, we cache the library values *)
+
+type library_values = Nativecode.symbol array
+let library_values =
+  Summary.ref (Dirmap.empty : library_values Dirmap.t) ~name:"LIBVALUES"
+
+let register_library dir cenv (objs:library_objects) digest univ =
+  let mp = MPfile dir in
+  let () =
+    try
+      (* Is this library already loaded ? *)
+      ignore(Global.lookup_module mp);
+    with Not_found ->
+      (* If not, let's do it now ... *)
+      let mp', values = Global.import cenv univ digest in
+      if not (ModPath.equal mp mp') then
+        anomaly (Pp.str "Unexpected disk module name");
+      library_values := Dirmap.add dir values !library_values
   in
-  protect_summaries declare_me
+  let sobjs,keepobjs = objs in
+  do_module false Lib.load_objects 1 dir mp ([],Objs sobjs) keepobjs
+
+let get_library_symbols_tbl dir = Dirmap.find dir !library_values
+
+let start_library dir =
+  let mp = Global.start_library dir in
+  openmod_info := default_module_info;
+  Lib.start_compilation dir mp;
+  Lib.add_frozen_state ()
+
+let end_library ?except dir =
+  let oname = Lib.end_compilation_checks dir in
+  let mp,cenv,ast = Global.export ?except dir in
+  let prefix, lib_stack = Lib.end_compilation oname in
+  assert (ModPath.equal mp (MPfile dir));
+  let substitute, keep, _ = Lib.classify_segment lib_stack in
+  cenv,(substitute,keep),ast
+
+
+
+(** {6 Implementation of Import and Export commands} *)
+
+let really_import_module mp =
+  (* May raise Not_found for unknown module and for functors *)
+  let prefix,sobjs,keepobjs = ModObjs.get mp in
+  Lib.open_objects 1 prefix sobjs;
+  Lib.open_objects 1 prefix keepobjs
+
+let cache_import (_,(_,mp)) = really_import_module mp
 
-let start_module interp_modtype export id args res =
- protect_summaries (start_module_ interp_modtype export id args res)
+let open_import i obj =
+  if Int.equal i 1 then cache_import obj
+
+let classify_import (export,_ as obj) =
+  if export then Substitute obj else Dispose
+
+let subst_import (subst,(export,mp as obj)) =
+  let mp' = subst_mp subst mp in
+  if mp'==mp then obj else (export,mp')
+
+let in_import : bool * module_path -> obj =
+  declare_object {(default_object "IMPORT MODULE") with
+    cache_function = cache_import;
+    open_function = open_import;
+    subst_function = subst_import;
+    classify_function = classify_import }
+
+let import_module export mp =
+  Lib.add_anonymous_leaf (in_import (export,mp))
 
 
-(*s Iterators. *)
+(** {6 Iterators} *)
 
 let iter_all_segments f =
-  let _ =
-    MPmap.iter
-      (fun _ (prefix,objects) ->
-	 let rec apply_obj (id,obj) = match object_tag obj with 
-	   | "INCLUDE" -> 
-	       let (_,(_,_,objs)) =  out_include obj in 
-		 List.iter apply_obj objs
-		   
-	   | _ -> f (make_oname prefix id) obj in
-	   List.iter apply_obj objects)
-      !modtab_objects
+  let rec apply_obj prefix (id,obj) = match object_tag obj with
+    | "INCLUDE" ->
+      let objs = expand_aobjs (out_include obj) in
+      List.iter (apply_obj prefix) objs
+    | _ -> f (make_oname prefix id) obj
   in
-  let rec apply_node = function
-    | sp, Leaf o -> f sp o
+  let apply_mod_obj _ (prefix,substobjs,keepobjs) =
+    List.iter (apply_obj prefix) substobjs;
+    List.iter (apply_obj prefix) keepobjs
+  in
+  let apply_node = function
+    | sp, Lib.Leaf o -> f sp o
     | _ -> ()
   in
-    List.iter apply_node (Lib.contents_after None)
+  MPmap.iter apply_mod_obj (ModObjs.all ());
+  List.iter apply_node (Lib.contents ())
+
+
+(** {6 Some types used to shorten declaremods.mli} *)
+
+type 'modast module_interpretor =
+  Environ.env -> Misctypes.module_kind -> 'modast ->
+    Entries.module_struct_entry * Misctypes.module_kind
+
+type 'modast module_params =
+  (Id.t Loc.located list * ('modast * inline)) list
+
 
+(** {6 Debug} *)
 
 let debug_print_modtab _ =
   let pr_seg = function
     | [] -> str "[]"
     | l -> str ("[." ^ string_of_int (List.length l) ^ ".]")
   in
-  let pr_modinfo mp (prefix,objects) s =
+  let pr_modinfo mp (prefix,substobjs,keepobjs) s =
     s ++ str (string_of_mp mp) ++ (spc ())
-    ++ (pr_seg (segment_of_objects prefix objects))
+    ++ (pr_seg (Lib.segment_of_objects prefix (substobjs@keepobjs)))
   in
-  let modules = MPmap.fold pr_modinfo !modtab_objects (mt ()) in
-    hov 0 modules
+  let modules = MPmap.fold pr_modinfo (ModObjs.all ()) (mt ()) in
+  hov 0 modules
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 5019b659..c3578ec4 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -1,77 +1,42 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Entries
-open Environ
-open Libnames
-open Libobject
-open Lib
-
-(** This modules provides official functions to declare modules and
-  module types *)
-
-(** Rigid / flexible signature *)
-
-type 'a module_signature =
-  | Enforce of 'a (** ... : T *)
-  | Check of 'a list (** ... <: T1 <: T2, possibly empty *)
-
-(** Should we adapt a few scopes during functor application ? *)
-
-type scope_subst = (string * string) list
-
-val subst_scope : string -> string
-
-(** Which inline annotations should we honor, either None or the ones
-   whose level is less or equal to the given integer *)
-
-type inline =
-  | NoInline
-  | DefaultInline
-  | InlineAt of int
-
-(** The type of annotations for functor applications *)
-
-type funct_app_annot =
-  { ann_inline : inline;
-    ann_scope_subst : scope_subst }
-
-type 'a annotated = ('a * funct_app_annot)
+open Vernacexpr
 
 (** {6 Modules } *)
 
-(** [declare_module interp_modtype interp_modexpr id fargs typ expr]
-   declares module [id], with type constructed by [interp_modtype]
-   from functor arguments [fargs] and [typ] and with module body
-   constructed by [interp_modtype] from functor arguments [fargs] and
-   by [interp_modexpr] from [expr]. At least one of [typ], [expr] must
-   be non-empty.
+type 'modast module_interpretor =
+  Environ.env -> Misctypes.module_kind -> 'modast ->
+    Entries.module_struct_entry * Misctypes.module_kind
+
+type 'modast module_params =
+  (Id.t Loc.located list * ('modast * inline)) list
 
-   The [bool] in [typ] tells if the module must be abstracted [true]
-   with respect to the module type or merely matched without any
-   restriction [false].
-*)
+(** [declare_module interp_modast id fargs typ exprs]
+   declares module [id], with structure constructed by [interp_modast]
+   from functor arguments [fargs], with final type [typ].
+   [exprs] is usually of length 1 (Module definition with a concrete
+   body), but it could also be empty ("Declare Module", with non-empty [typ]),
+   or multiple (body of the shape M <+ N <+ ...). *)
 
 val declare_module :
-  (env -> 'modast -> module_struct_entry) ->
-  (env -> 'modast -> module_struct_entry) ->
-  (env -> 'modast -> module_struct_entry * bool) ->
-  identifier ->
-  (identifier located list * ('modast annotated)) list ->
-  ('modast annotated) module_signature ->
-  ('modast annotated) list -> module_path
-
-val start_module : (env -> 'modast -> module_struct_entry) ->
-  bool option -> identifier ->
-  (identifier located list * ('modast annotated)) list ->
-  ('modast annotated) module_signature -> module_path
+  'modast module_interpretor ->
+  Id.t ->
+  'modast module_params ->
+  ('modast * inline) module_signature ->
+  ('modast * inline) list -> module_path
+
+val start_module :
+  'modast module_interpretor ->
+  bool option -> Id.t ->
+  'modast module_params ->
+  ('modast * inline) module_signature -> module_path
 
 val end_module : unit -> module_path
 
@@ -79,49 +44,49 @@ val end_module : unit -> module_path
 
 (** {6 Module types } *)
 
-val declare_modtype : (env -> 'modast -> module_struct_entry) ->
-  (env -> 'modast -> module_struct_entry * bool) ->
-  identifier ->
-  (identifier located list * ('modast annotated)) list ->
-  ('modast annotated) list ->
-  ('modast annotated) list ->
+(** [declare_modtype interp_modast id fargs typs exprs]
+    Similar to [declare_module], except that the types could be multiple *)
+
+val declare_modtype :
+  'modast module_interpretor ->
+  Id.t ->
+  'modast module_params ->
+  ('modast * inline) list ->
+  ('modast * inline) list ->
   module_path
 
-val start_modtype : (env -> 'modast -> module_struct_entry) ->
-  identifier -> (identifier located list * ('modast annotated)) list ->
-  ('modast annotated) list -> module_path
+val start_modtype :
+  'modast module_interpretor ->
+  Id.t ->
+  'modast module_params ->
+  ('modast * inline) list -> module_path
 
 val end_modtype : unit -> module_path
 
 
-(** {6 ... } *)
-(** Objects of a module. They come in two lists: the substitutive ones
-  and the other *)
-
-val module_objects : module_path -> library_segment
-
-
 (** {6 Libraries i.e. modules on disk } *)
 
-type library_name = dir_path
+type library_name = DirPath.t
 
 type library_objects
 
 val register_library :
   library_name ->
-    Safe_typing.compiled_library -> library_objects -> Digest.t -> unit
+  Safe_typing.compiled_library -> library_objects -> Safe_typing.vodigest ->
+  Univ.universe_context_set -> unit
+
+val get_library_symbols_tbl : library_name -> Nativecode.symbol array
 
 val start_library : library_name -> unit
 
 val end_library :
-  library_name -> Safe_typing.compiled_library * library_objects
-
-(** set a function to be executed at end_library *)
-val set_end_library_hook : (unit -> unit) -> unit
+  ?except:Future.UUIDSet.t -> library_name ->
+    Safe_typing.compiled_library * library_objects * Safe_typing.native_library
 
 (** [really_import_module mp] opens the module [mp] (in a Caml sense).
    It modifies Nametab and performs the [open_object] function for
-   every object of the module. *)
+   every object of the module. Raises [Not_found] when [mp] is unknown
+   or when [mp] corresponds to a functor. *)
 
 val really_import_module : module_path -> unit
 
@@ -133,8 +98,8 @@ val import_module : bool -> module_path -> unit
 
 (** Include  *)
 
-val declare_include : (env -> 'struct_expr -> module_struct_entry * bool) ->
-  ('struct_expr annotated) list -> unit
+val declare_include :
+  'modast module_interpretor -> ('modast * inline) list -> unit
 
 (** {6 ... } *)
 (** [iter_all_segments] iterate over all segments, the modules'
@@ -142,17 +107,16 @@ val declare_include : (env -> 'struct_expr -> module_struct_entry * bool) ->
     in an arbitrary order. The given function is applied to all leaves
     (together with their section path). *)
 
-val iter_all_segments : (object_name -> obj -> unit) -> unit
+val iter_all_segments :
+  (Libnames.object_name -> Libobject.obj -> unit) -> unit
 
 
 val debug_print_modtab : unit -> Pp.std_ppcmds
 
-(*i val debug_print_modtypetab : unit -> Pp.std_ppcmds i*)
-
-(** For translator *)
-val process_module_bindings : module_ident list ->
-  (mod_bound_id * (module_struct_entry annotated)) list -> unit
+(** For printing modules, [process_module_binding] adds names of
+    bound module (and its components) to Nametab. It also loads
+    objects associated to it. It may raise a [Failure] when the
+    bound module hasn't an atomic type. *)
 
-(** For Printer *)
-val process_module_seb_binding :
-  mod_bound_id -> Declarations.struct_expr_body -> unit
+val process_module_binding :
+  MBId.t -> Declarations.module_alg_expr -> unit
diff --git a/library/decls.ml b/library/decls.ml
index a20d438f..8d5085f7 100644
--- a/library/decls.ml
+++ b/library/decls.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        *)
@@ -9,45 +9,37 @@
 (** This module registers tables for some non-logical informations
      associated declarations *)
 
+open Util
 open Names
-open Term
-open Sign
+open Context
 open Decl_kinds
 open Libnames
 
 (** Datas associated to section variables and local definitions *)
 
 type variable_data =
-    dir_path * bool (* opacity *) * Univ.constraints * logical_kind
+  DirPath.t * bool (* opacity *) * Univ.universe_context_set * polymorphic * logical_kind
 
-let vartab = ref (Idmap.empty : variable_data Idmap.t)
+let vartab =
+  Summary.ref (Id.Map.empty : variable_data Id.Map.t) ~name:"VARIABLE"
 
-let _ = Summary.declare_summary "VARIABLE"
-  { Summary.freeze_function = (fun () -> !vartab);
-    Summary.unfreeze_function = (fun ft -> vartab := ft);
-    Summary.init_function = (fun () -> vartab := Idmap.empty) }
+let add_variable_data id o = vartab := Id.Map.add id o !vartab
 
-let add_variable_data id o = vartab := Idmap.add id o !vartab
-
-let variable_path id = let (p,_,_,_) = Idmap.find id !vartab in p
-let variable_opacity id = let (_,opaq,_,_) = Idmap.find id !vartab in opaq
-let variable_kind id = let (_,_,_,k) = Idmap.find id !vartab in k
-let variable_constraints id = let (_,_,cst,_) = Idmap.find id !vartab in cst
+let variable_path id = let (p,_,_,_,_) = Id.Map.find id !vartab in p
+let variable_opacity id = let (_,opaq,_,_,_) = Id.Map.find id !vartab in opaq
+let variable_kind id = let (_,_,_,_,k) = Id.Map.find id !vartab in k
+let variable_context id = let (_,_,ctx,_,_) = Id.Map.find id !vartab in ctx
+let variable_polymorphic id = let (_,_,_,p,_) = Id.Map.find id !vartab in p
 
 let variable_secpath id =
   let dir = drop_dirpath_prefix (Lib.library_dp()) (variable_path id) in
   make_qualid dir id
 
-let variable_exists id = Idmap.mem id !vartab
+let variable_exists id = Id.Map.mem id !vartab
 
 (** Datas associated to global parameters and constants *)
 
-let csttab = ref (Cmap.empty : logical_kind Cmap.t)
-
-let _ = Summary.declare_summary "CONSTANT"
-	  { Summary.freeze_function = (fun () -> !csttab);
-	    Summary.unfreeze_function = (fun ft -> csttab := ft);
-	    Summary.init_function = (fun () -> csttab := Cmap.empty) }
+let csttab = Summary.ref (Cmap.empty : logical_kind Cmap.t) ~name:"CONSTANT"
 
 let add_constant_kind kn k = csttab := Cmap.add kn k !csttab
 
@@ -65,7 +57,7 @@ let initialize_named_context_for_proof () =
 let last_section_hyps dir =
   fold_named_context
     (fun (id,_,_) sec_ids ->
-      try if dir=variable_path id then id::sec_ids else sec_ids
+      try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids
       with Not_found -> sec_ids)
     (Environ.named_context (Global.env()))
     ~init:[]
diff --git a/library/decls.mli b/library/decls.mli
index 6cd7887e..ac0d907d 100644
--- a/library/decls.mli
+++ b/library/decls.mli
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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 Sign
 open Libnames
 open Decl_kinds
 
@@ -18,14 +17,15 @@ open Decl_kinds
 (** Registration and access to the table of variable *)
 
 type variable_data =
-    dir_path * bool (** opacity *) * Univ.constraints * logical_kind
+  DirPath.t * bool (** opacity *) * Univ.universe_context_set * polymorphic * logical_kind
 
 val add_variable_data : variable -> variable_data -> unit
-val variable_path : variable -> dir_path
+val variable_path : variable -> DirPath.t
 val variable_secpath : variable -> qualid
 val variable_kind : variable -> logical_kind
 val variable_opacity : variable -> bool
-val variable_constraints : variable -> Univ.constraints
+val variable_context : variable -> Univ.universe_context_set
+val variable_polymorphic : variable -> polymorphic
 val variable_exists : variable -> bool
 
 (** Registration and access to the table of constants *)
@@ -40,4 +40,4 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val
 
 (** Miscellaneous functions *)
 
-val last_section_hyps : dir_path -> identifier list
+val last_section_hyps : DirPath.t -> Id.t list
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
index f95b6c03..e4280334 100644
--- a/library/dischargedhypsmap.ml
+++ b/library/dischargedhypsmap.ml
@@ -1,47 +1,19 @@
 (************************************************************************)
 (*  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 Util
 open Libnames
-open Names
-open Term
-open Reduction
-open Declarations
-open Environ
-open Inductive
-open Libobject
-open Lib
-open Nametab
 
 type discharged_hyps = full_path list
 
-let discharged_hyps_map = ref Spmap.empty
+let discharged_hyps_map = Summary.ref Spmap.empty ~name:"discharged_hypothesis"
 
 let set_discharged_hyps sp hyps =
   discharged_hyps_map := Spmap.add sp hyps !discharged_hyps_map
 
 let get_discharged_hyps sp =
-  try
-   Spmap.find sp !discharged_hyps_map
-  with Not_found ->
-    []
-
-(*s Registration as global tables and rollback. *)
-
-let init () =
-  discharged_hyps_map := Spmap.empty
-
-let freeze () = !discharged_hyps_map
-
-let unfreeze dhm = discharged_hyps_map := dhm
-
-let _ =
-  Summary.declare_summary "discharged_hypothesis"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+  try Spmap.find sp !discharged_hyps_map with Not_found -> []
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
index 03405c32..73689201 100644
--- a/library/dischargedhypsmap.mli
+++ b/library/dischargedhypsmap.mli
@@ -1,20 +1,17 @@
 (************************************************************************)
 (*  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 Libnames
-open Term
-open Environ
-open Nametab
 
 type discharged_hyps = full_path list
 
-(** Discharged hypothesis. Here we store the discharged hypothesis of each 
-    constant or inductive type declaration.                                *)
+(** Discharged hypothesis. Here we store the discharged hypothesis of each
+    constant or inductive type declaration. *)
 
 val set_discharged_hyps : full_path -> discharged_hyps -> unit
 val get_discharged_hyps : full_path -> discharged_hyps
diff --git a/library/global.ml b/library/global.ml
index 96e522a7..875097e4 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -1,180 +1,258 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Term
-open Sign
 open Environ
-open Safe_typing
-open Summary
 
-(* We introduce here the global environment of the system, and we declare it
-   as a synchronized table. *)
+(** We introduce here the global environment of the system,
+    and we declare it as a synchronized table. *)
 
-let global_env = ref empty_environment
+let global_env_summary_name = "Global environment"
 
-let safe_env () = !global_env
+module GlobalSafeEnv : sig
 
-let env () = env_of_safe_env !global_env
+  val safe_env : unit -> Safe_typing.safe_environment
+  val set_safe_env : Safe_typing.safe_environment -> unit
+  val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit
 
-let env_is_empty () = is_empty !global_env
+end = struct
 
-let _ =
-  declare_summary "Global environment"
-    { freeze_function = (fun () -> !global_env);
+let global_env = ref Safe_typing.empty_environment
+
+let join_safe_environment ?except () =
+  global_env := Safe_typing.join_safe_environment ?except !global_env
+
+let () =
+  Summary.declare_summary global_env_summary_name
+    { Summary.freeze_function = (function
+        | `Yes -> join_safe_environment (); !global_env
+        | `No -> !global_env
+        | `Shallow -> !global_env);
       unfreeze_function = (fun fr -> global_env := fr);
-      init_function = (fun () -> global_env := empty_environment) }
+      init_function = (fun () -> global_env := Safe_typing.empty_environment) }
 
-(* Then we export the functions of [Typing] on that environment. *)
+let assert_not_parsing () =
+  if !Flags.we_are_parsing then
+    Errors.anomaly (
+      Pp.strbrk"The global environment cannot be accessed during parsing")
 
-let universes () = universes (env())
-let named_context () = named_context (env())
-let named_context_val () = named_context_val (env())
+let safe_env () = assert_not_parsing(); !global_env
 
-let push_named_assum a =
-  let (cst,env) = push_named_assum a !global_env in
-  global_env := env;
-  cst
-let push_named_def d =
-  let (cst,env) = push_named_def d !global_env in
-  global_env := env;
-  cst
+let set_safe_env e = global_env := e
 
+end
 
-let add_thing add dir id thing =
-  let kn, newenv = add dir (label_of_id id) thing !global_env in
-    global_env := newenv;
-    kn
+let safe_env = GlobalSafeEnv.safe_env
+let join_safe_environment ?except () =
+  GlobalSafeEnv.join_safe_environment ?except ()
 
-let add_constant = add_thing add_constant
-let add_mind = add_thing add_mind
-let add_modtype x y inl = add_thing (fun _ x y -> add_modtype x y inl) () x y
+let env () = Safe_typing.env_of_safe_env (safe_env ())
 
+let env_is_initial () = Safe_typing.is_initial (safe_env ())
 
-let add_module id me inl =
-  let l = label_of_id id in
-  let mp,resolve,new_env = add_module l me inl !global_env in
-    global_env := new_env;
-    mp,resolve
-    
+(** Turn ops over the safe_environment state monad to ops on the global env *)
 
-let add_constraints c = global_env := add_constraints c !global_env
+let globalize0 f = GlobalSafeEnv.set_safe_env (f (safe_env ()))
 
-let set_engagement c = global_env := set_engagement c !global_env
+let globalize f =
+  let res,env = f (safe_env ()) in GlobalSafeEnv.set_safe_env env; res
 
-let add_include me is_module inl =
-  let resolve,newenv = add_include me is_module inl !global_env in
-    global_env := newenv;
-    resolve
+let globalize_with_summary fs f =
+  let res,env = f (safe_env ()) in
+  Summary.unfreeze_summaries fs;
+  GlobalSafeEnv.set_safe_env env;
+  res
 
-let start_module id =
-  let l = label_of_id id in
-  let mp,newenv = start_module l !global_env in
-    global_env := newenv;
-    mp
+(** [Safe_typing] operations, now operating on the global environment *)
 
-let end_module fs id mtyo =
-  let l = label_of_id id in
-  let mp,resolve,newenv = end_module l mtyo !global_env in
-    Summary.unfreeze_summaries fs;
-    global_env := newenv;
-    mp,resolve
+let i2l = Label.of_id
 
+let push_named_assum a = globalize0 (Safe_typing.push_named_assum a)
+let push_named_def d = globalize0 (Safe_typing.push_named_def d)
+let add_constraints c = globalize0 (Safe_typing.add_constraints c)
+let push_context_set c = globalize0 (Safe_typing.push_context_set c)
+let push_context c = globalize0 (Safe_typing.push_context c)
 
-let add_module_parameter mbid mte inl =
-  let resolve,newenv = add_module_parameter mbid mte inl !global_env in
-    global_env := newenv;
-    resolve
+let set_engagement c = globalize0 (Safe_typing.set_engagement c)
+let set_type_in_type () = globalize0 (Safe_typing.set_type_in_type)
+let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d)
+let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie)
+let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl)
+let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl)
+let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl)
 
+let start_module id = globalize (Safe_typing.start_module (i2l id))
+let start_modtype id = globalize (Safe_typing.start_modtype (i2l id))
 
-let start_modtype id =
-  let l = label_of_id id in
-  let mp,newenv = start_modtype l !global_env in
-    global_env := newenv;
-    mp
+let end_module fs id mtyo =
+  globalize_with_summary fs (Safe_typing.end_module (i2l id) mtyo)
 
 let end_modtype fs id =
-  let l = label_of_id id in
-  let kn,newenv = end_modtype l !global_env in
-    Summary.unfreeze_summaries fs;
-    global_env := newenv;
-    kn
+  globalize_with_summary fs (Safe_typing.end_modtype (i2l id))
 
-let pack_module () = 
-  pack_module !global_env
+let add_module_parameter mbid mte inl =
+  globalize (Safe_typing.add_module_parameter mbid mte inl)
 
+(** Queries on the global environment *)
 
+let universes () = universes (env())
+let named_context () = named_context (env())
+let named_context_val () = named_context_val (env())
 
 let lookup_named id = lookup_named id (env())
 let lookup_constant kn = lookup_constant kn (env())
 let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind
+let lookup_pinductive (ind,_) = Inductive.lookup_mind_specif (env()) ind
 let lookup_mind kn = lookup_mind kn (env())
 
 let lookup_module mp = lookup_module mp (env())
 let lookup_modtype kn = lookup_modtype kn (env())
 
+let exists_objlabel id = Safe_typing.exists_objlabel id (safe_env ())
+
+let opaque_tables () = Environ.opaque_tables (env ())
+let body_of_constant_body cb = Declareops.body_of_constant (opaque_tables ()) cb
+let body_of_constant cst = body_of_constant_body (lookup_constant cst)
+let constraints_of_constant_body cb =
+  Declareops.constraints_of_constant (opaque_tables ()) cb
+let universes_of_constant_body cb =
+  Declareops.universes_of_constant (opaque_tables ()) cb
+
+(** Operations on kernel names *)
+
 let constant_of_delta_kn kn =
-  let resolver,resolver_param = (delta_of_senv !global_env) in
+  let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ())
+  in
   (* TODO : are resolver and resolver_param orthogonal ?
      the effect of resolver is lost if resolver_param isn't
      trivial at that spot. *)
-    Mod_subst.constant_of_delta resolver_param
-      (Mod_subst.constant_of_delta_kn resolver kn)
+  Mod_subst.constant_of_deltas_kn resolver_param resolver kn
 
 let mind_of_delta_kn kn =
-  let resolver,resolver_param = (delta_of_senv !global_env) in
+  let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ())
+  in
   (* TODO idem *)
-    Mod_subst.mind_of_delta resolver_param
-      (Mod_subst.mind_of_delta_kn resolver kn)
-
-let exists_objlabel id = exists_objlabel id !global_env
-
-let start_library dir =
-  let mp,newenv = start_library dir !global_env in
-    global_env := newenv;
-    mp
-
-let export s = export !global_env s
+  Mod_subst.mind_of_deltas_kn resolver_param resolver kn
 
-let import cenv digest =
-  let mp,newenv = import cenv digest !global_env in
-    global_env := newenv;
-    mp
+(** Operations on libraries *)
 
+let start_library dir = globalize (Safe_typing.start_library dir)
+let export ?except s = Safe_typing.export ?except (safe_env ()) s
+let import c u d = globalize (Safe_typing.import c u d)
 
 
-(*s Function to get an environment from the constants part of the global
+(** Function to get an environment from the constants part of the global
     environment and a given context. *)
 
 let env_of_context hyps =
   reset_with_named_context hyps (env())
 
-open Libnames
+open Globnames
 
-let type_of_reference env = function
+(** Build a fresh instance for a given context, its associated substitution and 
+    the instantiated constraints. *)
+
+let type_of_global_unsafe r = 
+  let env = env() in
+  match r with
   | VarRef id -> Environ.named_type id env
-  | ConstRef c -> Typeops.type_of_constant env c
+  | ConstRef c -> 
+     let cb = Environ.lookup_constant c env in 
+     let univs =
+       Declareops.universes_of_polymorphic_constant
+         (Environ.opaque_tables env) cb in
+     let ty = Typeops.type_of_constant_type env cb.Declarations.const_type in
+       Vars.subst_instance_constr (Univ.UContext.instance univs) ty
   | IndRef ind ->
-     let specif = Inductive.lookup_mind_specif env ind in
-      Inductive.type_of_inductive env specif
+     let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in
+     let inst = 
+       if mib.Declarations.mind_polymorphic then 
+	 Univ.UContext.instance mib.Declarations.mind_universes
+       else Univ.Instance.empty
+     in
+       Inductive.type_of_inductive env (specif, inst)
   | ConstructRef cstr ->
-     let specif =
-      Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
-       Inductive.type_of_constructor cstr specif
-
-let type_of_global t = type_of_reference (env ()) t
-
+     let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+     let inst = Univ.UContext.instance mib.Declarations.mind_universes in
+       Inductive.type_of_constructor (cstr,inst) specif
+
+let type_of_global_in_context env r = 
+  let open Declarations in
+  match r with
+  | VarRef id -> Environ.named_type id env, Univ.UContext.empty
+  | ConstRef c -> 
+     let cb = Environ.lookup_constant c env in 
+     let univs =
+       Declareops.universes_of_polymorphic_constant
+         (Environ.opaque_tables env) cb in
+       Typeops.type_of_constant_type env cb.Declarations.const_type, univs
+  | IndRef ind ->
+     let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in
+     let univs = 
+       if mib.mind_polymorphic then mib.mind_universes 
+       else Univ.UContext.empty
+     in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs
+  | ConstructRef cstr ->
+     let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+     let univs = 
+       if mib.mind_polymorphic then mib.mind_universes 
+       else Univ.UContext.empty
+     in
+     let inst = Univ.UContext.instance univs in
+       Inductive.type_of_constructor (cstr,inst) specif, univs
+
+let universes_of_global env r = 
+  let open Declarations in
+    match r with
+    | VarRef id -> Univ.UContext.empty
+    | ConstRef c -> 
+      let cb = Environ.lookup_constant c env in 
+	Declareops.universes_of_polymorphic_constant
+          (Environ.opaque_tables env) cb
+    | IndRef ind ->
+      let (mib, oib) = Inductive.lookup_mind_specif env ind in
+	Univ.instantiate_univ_context mib.mind_universes 
+    | ConstructRef cstr ->
+      let (mib,oib) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+	Univ.instantiate_univ_context mib.mind_universes 
+
+let universes_of_global gr = 
+  universes_of_global (env ()) gr
+
+let is_polymorphic r = 
+  let env = env() in 
+  match r with
+  | VarRef id -> false
+  | ConstRef c -> Environ.polymorphic_constant c env
+  | IndRef ind -> Environ.polymorphic_ind ind env
+  | ConstructRef cstr -> Environ.polymorphic_ind (inductive_of_constructor cstr) env
+
+let is_template_polymorphic r = 
+  let env = env() in 
+  match r with
+  | VarRef id -> false
+  | ConstRef c -> Environ.template_polymorphic_constant c env
+  | IndRef ind -> Environ.template_polymorphic_ind ind env
+  | ConstructRef cstr -> Environ.template_polymorphic_ind (inductive_of_constructor cstr) env
+
+let current_dirpath () = 
+  Safe_typing.current_dirpath (safe_env ())
+
+let with_global f = 
+  let (a, ctx) = f (env ()) (current_dirpath ()) in
+    push_context_set ctx; a
 
 (* spiwack: register/unregister functions for retroknowledge *)
 let register field value by_clause =
-  let entry = kind_of_term value in
-  let senv = Safe_typing.register !global_env field entry by_clause in
-  global_env := senv
+  globalize0 (Safe_typing.register field value by_clause)
+
+let register_inline c = globalize0 (Safe_typing.register_inline c)
 
+let set_strategy k l =
+  GlobalSafeEnv.set_safe_env (Safe_typing.set_strategy (safe_env ()) k l)
 
diff --git a/library/global.mli b/library/global.mli
index e1cd5c7b..af23d9b7 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -1,106 +1,143 @@
 (************************************************************************)
 (*  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 Univ
-open Term
-open Declarations
-open Entries
-open Indtypes
-open Mod_subst
-open Safe_typing
-
-(** This module defines the global environment of Coq.  The functions
+
+(** This module defines the global environment of Coq. The functions
    below are exactly the same as the ones in [Safe_typing], operating on
    that global environment. [add_*] functions perform name verification,
    i.e. check that the name given as argument match those provided by
    [Safe_typing]. *)
 
-
-
-val safe_env : unit -> safe_environment
+val safe_env : unit -> Safe_typing.safe_environment
 val env : unit -> Environ.env
 
-val env_is_empty : unit -> bool
+val env_is_initial : unit -> bool
 
-val universes : unit -> universes
+val universes : unit -> Univ.universes
 val named_context_val : unit -> Environ.named_context_val
-val named_context : unit -> Sign.named_context
+val named_context : unit -> Context.named_context
 
-val env_is_empty : unit -> bool
+(** {6 Enriching the global environment } *)
 
-(** {6 Extending env with variables and local definitions } *)
-val push_named_assum : (identifier * types) -> Univ.constraints
-val push_named_def   : (identifier * constr * types option) -> Univ.constraints
+(** Changing the (im)predicativity of the system *)
+val set_engagement : Declarations.engagement -> unit
+val set_type_in_type : unit -> unit
 
-(** {6 ... } *)
-(** Adding constants, inductives, modules and module types.  All these
-  functions verify that given names match those generated by kernel *)
+(** Variables, Local definitions, constants, inductive types *)
+
+val push_named_assum : (Id.t * Constr.types) Univ.in_universe_context_set -> unit
+val push_named_def   : (Id.t * Entries.definition_entry) -> unit
 
 val add_constant :
-  dir_path -> identifier -> global_declaration -> constant
-val add_mind        :
-  dir_path -> identifier -> mutual_inductive_entry -> mutual_inductive
-
-val add_module      :
- identifier -> module_entry -> inline -> module_path * delta_resolver
-val add_modtype     :
- identifier -> module_struct_entry -> inline -> module_path
-val add_include :
- module_struct_entry -> bool -> inline -> delta_resolver
+  DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant
+val add_mind :
+  DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive
 
-val add_constraints : constraints -> unit
+(** Extra universe constraints *)
+val add_constraints : Univ.constraints -> unit
 
-val set_engagement : engagement -> unit
+val push_context : Univ.universe_context -> unit
+val push_context_set : Univ.universe_context_set -> unit
 
-(** {6 Interactive modules and module types }
-   Both [start_*] functions take the [dir_path] argument to create a
-   [mod_self_id]. This should be the name of the compilation unit. *)
+(** Non-interactive modules and module types *)
 
-(** [start_*] functions return the [module_path] valid for components
-   of the started module / module type *)
+val add_module :
+  Id.t -> Entries.module_entry -> Declarations.inline ->
+    module_path * Mod_subst.delta_resolver
+val add_modtype :
+  Id.t -> Entries.module_type_entry -> Declarations.inline -> module_path
+val add_include :
+  Entries.module_struct_entry -> bool -> Declarations.inline ->
+    Mod_subst.delta_resolver
 
-val start_module : identifier -> module_path
+(** Interactive modules and module types *)
 
-val end_module : Summary.frozen ->identifier ->
-  (module_struct_entry * inline) option -> module_path * delta_resolver
+val start_module : Id.t -> module_path
+val start_modtype : Id.t -> module_path
 
-val add_module_parameter :
- mod_bound_id -> module_struct_entry -> inline -> delta_resolver
+val end_module : Summary.frozen -> Id.t ->
+  (Entries.module_struct_entry * Declarations.inline) option ->
+    module_path * MBId.t list * Mod_subst.delta_resolver
 
-val start_modtype : identifier -> module_path
-val end_modtype : Summary.frozen -> identifier -> module_path
-val pack_module : unit -> module_body
+val end_modtype : Summary.frozen -> Id.t -> module_path * MBId.t list
 
+val add_module_parameter :
+  MBId.t -> Entries.module_struct_entry -> Declarations.inline ->
+    Mod_subst.delta_resolver
+
+(** {6 Queries in the global environment } *)
+
+val lookup_named     : variable -> Context.named_declaration
+val lookup_constant  : constant -> Declarations.constant_body
+val lookup_inductive : inductive ->
+  Declarations.mutual_inductive_body * Declarations.one_inductive_body
+val lookup_pinductive : Constr.pinductive -> 
+  Declarations.mutual_inductive_body * Declarations.one_inductive_body
+val lookup_mind      : mutual_inductive -> Declarations.mutual_inductive_body
+val lookup_module    : module_path -> Declarations.module_body
+val lookup_modtype   : module_path -> Declarations.module_type_body
+val exists_objlabel  : Label.t -> bool
 
-(** Queries *)
-val lookup_named     : variable -> named_declaration
-val lookup_constant  : constant -> constant_body
-val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body
-val lookup_mind      : mutual_inductive -> mutual_inductive_body
-val lookup_module    : module_path -> module_body
-val lookup_modtype   : module_path -> module_type_body
 val constant_of_delta_kn : kernel_name -> constant
 val mind_of_delta_kn : kernel_name -> mutual_inductive
-val exists_objlabel  : label -> bool
 
-(** Compiled modules *)
-val start_library : dir_path -> module_path
-val export : dir_path -> module_path * compiled_library
-val import : compiled_library -> Digest.t -> module_path
+val opaque_tables : unit -> Opaqueproof.opaquetab
+val body_of_constant : constant -> Term.constr option
+val body_of_constant_body : Declarations.constant_body -> Term.constr option
+val constraints_of_constant_body :
+  Declarations.constant_body -> Univ.constraints
+val universes_of_constant_body :
+  Declarations.constant_body -> Univ.universe_context
+
+(** {6 Compiled libraries } *)
+
+val start_library : DirPath.t -> module_path
+val export : ?except:Future.UUIDSet.t -> DirPath.t ->
+  module_path * Safe_typing.compiled_library * Safe_typing.native_library
+val import :
+  Safe_typing.compiled_library -> Univ.universe_context_set -> Safe_typing.vodigest ->
+  module_path * Nativecode.symbol array
+
+(** {6 Misc } *)
 
-(** {6 ... } *)
 (** Function to get an environment from the constants part of the global
  * environment and a given context. *)
 
-val type_of_global : Libnames.global_reference -> types
 val env_of_context : Environ.named_context_val -> Environ.env
 
+val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit
+
+val is_polymorphic : Globnames.global_reference -> bool
+val is_template_polymorphic : Globnames.global_reference -> bool
+
+val type_of_global_in_context : Environ.env -> 
+  Globnames.global_reference -> Constr.types Univ.in_universe_context
+val type_of_global_unsafe : Globnames.global_reference -> Constr.types 
+
+(** Returns the universe context of the global reference (whatever it's polymorphic status is). *)
+val universes_of_global : Globnames.global_reference -> Univ.universe_context
+
+(** {6 Retroknowledge } *)
+
+val register :
+  Retroknowledge.field -> Term.constr -> Term.constr -> unit
+
+val register_inline : constant -> unit
+
+(** {6 Oracle } *)
+
+val set_strategy : Names.constant Names.tableKey -> Conv_oracle.level -> unit
+
+(* Modifies the global state, registering new universes *)
+
+val current_dirpath : unit -> Names.dir_path
+
+val with_global : (Environ.env -> Names.dir_path -> 'a Univ.in_universe_context_set) -> 'a
 
-(** spiwack: register/unregister function for retroknowledge *)
-val register : Retroknowledge.field -> constr -> constr -> unit
+val global_env_summary_name : string
diff --git a/library/globnames.ml b/library/globnames.ml
new file mode 100644
index 00000000..5eb091af
--- /dev/null
+++ b/library/globnames.ml
@@ -0,0 +1,247 @@
+(************************************************************************)
+(*  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 Util
+open Errors
+open Names
+open Term
+open Mod_subst
+open Libnames
+
+(*s Global reference is a kernel side type for all references together *)
+type global_reference =
+  | VarRef of variable
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+let isVarRef = function VarRef _ -> true | _ -> false
+let isConstRef = function ConstRef _ -> true | _ -> false
+let isIndRef = function IndRef _ -> true | _ -> false
+let isConstructRef = function ConstructRef _ -> true | _ -> false
+
+let eq_gr gr1 gr2 =
+  gr1 == gr2 || match gr1,gr2 with
+    | ConstRef con1, ConstRef con2 -> eq_constant con1 con2
+    | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2
+    | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2
+    | VarRef v1, VarRef v2 -> Id.equal v1 v2
+    | _ -> false
+
+let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef"
+let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef"
+let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef"
+let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef"
+
+let subst_constructor subst (ind,j as ref) =
+  let ind' = subst_ind subst ind in
+    if ind==ind' then ref, mkConstruct ref
+    else (ind',j), mkConstruct (ind',j)
+
+let subst_global_reference subst ref = match ref with
+  | VarRef var -> ref
+  | ConstRef kn ->
+    let kn' = subst_constant subst kn in
+      if kn==kn' then ref else ConstRef kn'
+  | IndRef ind ->
+    let ind' = subst_ind subst ind in
+      if ind==ind' then ref else IndRef ind'
+  | ConstructRef ((kn,i),j as c) ->
+    let c',t = subst_constructor subst c in
+      if c'==c then ref else ConstructRef c'
+
+let subst_global subst ref = match ref with
+  | VarRef var -> ref, mkVar var
+  | ConstRef kn ->
+     let kn',t = subst_con_kn subst kn in
+      if kn==kn' then ref, mkConst kn else ConstRef kn', t
+  | IndRef ind ->
+      let ind' = subst_ind subst ind in
+      if ind==ind' then ref, mkInd ind else IndRef ind', mkInd ind'
+  | ConstructRef ((kn,i),j as c) ->
+      let c',t = subst_constructor subst c in
+	if c'==c then ref,t else ConstructRef c', t
+
+let canonical_gr = function
+  | ConstRef con -> ConstRef(constant_of_kn(canonical_con con))
+  | IndRef (kn,i) -> IndRef(mind_of_kn(canonical_mind kn),i)
+  | ConstructRef ((kn,i),j )-> ConstructRef((mind_of_kn(canonical_mind kn),i),j)
+  | VarRef id -> VarRef id
+
+let global_of_constr c = match kind_of_term c with
+  | Const (sp,u) -> ConstRef sp
+  | Ind (ind_sp,u) -> IndRef ind_sp
+  | Construct (cstr_cp,u) -> ConstructRef cstr_cp
+  | Var id -> VarRef id
+  |  _ -> raise Not_found
+
+let is_global c t =
+  match c, kind_of_term t with
+  | ConstRef c, Const (c', _) -> eq_constant c c'
+  | IndRef i, Ind (i', _) -> eq_ind i i'
+  | ConstructRef i, Construct (i', _) -> eq_constructor i i'
+  | VarRef id, Var id' -> id_eq id id'
+  | _ -> false
+
+let printable_constr_of_global = function
+  | VarRef id -> mkVar id
+  | ConstRef sp -> mkConst sp
+  | ConstructRef sp -> mkConstruct sp
+  | IndRef sp -> mkInd sp
+
+let reference_of_constr = global_of_constr
+
+let global_eq_gen eq_cst eq_ind eq_cons x y =
+  x == y ||
+  match x, y with
+  | ConstRef cx, ConstRef cy -> eq_cst cx cy
+  | IndRef indx, IndRef indy -> eq_ind indx indy
+  | ConstructRef consx, ConstructRef consy -> eq_cons consx consy
+  | VarRef v1, VarRef v2 -> Id.equal v1 v2
+  | (VarRef _ | ConstRef _ | IndRef _ | ConstructRef _), _ -> false
+
+let global_ord_gen ord_cst ord_ind ord_cons x y =
+  if x == y then 0
+  else match x, y with
+  | ConstRef cx, ConstRef cy -> ord_cst cx cy
+  | IndRef indx, IndRef indy -> ord_ind indx indy
+  | ConstructRef consx, ConstructRef consy -> ord_cons consx consy
+  | VarRef v1, VarRef v2 -> Id.compare v1 v2
+
+  | VarRef _, (ConstRef _ | IndRef _ | ConstructRef _) -> -1
+  | ConstRef _, VarRef _ -> 1
+  | ConstRef _, (IndRef _ | ConstructRef _) -> -1
+  | IndRef _, (VarRef _ | ConstRef _) -> 1
+  | IndRef _, ConstructRef _ -> -1
+  | ConstructRef _, (VarRef _ | ConstRef _ | IndRef _) -> 1
+
+let global_hash_gen hash_cst hash_ind hash_cons gr =
+  let open Hashset.Combine in
+  match gr with
+  | ConstRef c -> combinesmall 1 (hash_cst c)
+  | IndRef i -> combinesmall 2 (hash_ind i)
+  | ConstructRef c -> combinesmall 3 (hash_cons c)
+  | VarRef id -> combinesmall 4 (Id.hash id)
+
+(* By default, [global_reference] are ordered on their canonical part *)
+
+module RefOrdered = struct
+  open Constant.CanOrd
+  type t = global_reference
+  let compare gr1 gr2 =
+    global_ord_gen compare ind_ord constructor_ord gr1 gr2
+  let equal gr1 gr2 = global_eq_gen equal eq_ind eq_constructor gr1 gr2
+  let hash gr = global_hash_gen hash ind_hash constructor_hash gr
+end
+
+module RefOrdered_env = struct
+  open Constant.UserOrd
+  type t = global_reference
+  let compare gr1 gr2 =
+    global_ord_gen compare ind_user_ord constructor_user_ord gr1 gr2
+  let equal gr1 gr2 =
+    global_eq_gen equal eq_user_ind eq_user_constructor gr1 gr2
+  let hash gr = global_hash_gen hash ind_user_hash constructor_user_hash gr
+end
+
+module Refmap = HMap.Make(RefOrdered)
+module Refset = Refmap.Set
+
+(* Alternative sets and maps indexed by the user part of the kernel names *)
+
+module Refmap_env = HMap.Make(RefOrdered_env)
+module Refset_env = Refmap_env.Set
+
+(* Extended global references *)
+
+type syndef_name = kernel_name
+
+type extended_global_reference =
+  | TrueGlobal of global_reference
+  | SynDef of syndef_name
+
+(* We order [extended_global_reference] via their user part
+   (cf. pretty printer) *)
+
+module ExtRefOrdered = struct
+  type t = extended_global_reference
+
+  let equal x y =
+    x == y ||
+    match x, y with
+    | TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.equal rx ry
+    | SynDef knx, SynDef kny -> KerName.equal knx kny
+    | (TrueGlobal _ | SynDef _), _ -> false
+
+  let compare x y =
+    if x == y then 0
+    else match x, y with
+      | TrueGlobal rx, TrueGlobal ry -> RefOrdered_env.compare rx ry
+      | SynDef knx, SynDef kny -> kn_ord knx kny
+      | TrueGlobal _, SynDef _ -> -1
+      | SynDef _, TrueGlobal _ -> 1
+
+  open Hashset.Combine
+
+  let hash = function
+  | TrueGlobal gr -> combinesmall 1 (RefOrdered_env.hash gr)
+  | SynDef kn -> combinesmall 2 (KerName.hash kn)
+
+end
+
+type global_reference_or_constr = 
+  | IsGlobal of global_reference
+  | IsConstr of constr
+
+(** {6 Temporary function to brutally form kernel names from section paths } *)
+
+let encode_mind dir id = MutInd.make2 (MPfile dir) (Label.of_id id)
+
+let encode_con dir id = Constant.make2 (MPfile dir) (Label.of_id id)
+
+let check_empty_section dp =
+  if not (DirPath.is_empty dp) then
+    anomaly (Pp.str "Section part should be empty!")
+
+let decode_mind kn =
+  let rec dir_of_mp = function
+    | MPfile dir -> DirPath.repr dir
+    | MPbound mbid ->
+	let _,_,dp = MBId.repr mbid in
+	let id = MBId.to_id mbid in
+	  id::(DirPath.repr dp)
+    | MPdot(mp,l) -> (Label.to_id l)::(dir_of_mp mp)
+  in
+  let mp,sec_dir,l = repr_mind kn in
+  check_empty_section sec_dir;
+  (DirPath.make (dir_of_mp mp)),Label.to_id l
+
+let decode_con kn =
+  let mp,sec_dir,l = repr_con kn in
+  check_empty_section sec_dir;
+  match mp with
+    | MPfile dir -> (dir,Label.to_id l)
+    | _ -> anomaly (Pp.str "MPfile expected!")
+
+(** Popping one level of section in global names.
+    These functions are meant to be used during discharge:
+    user and canonical kernel names must be equal. *)
+
+let pop_con con =
+  let (mp,dir,l) = repr_con con in
+  Names.make_con mp (pop_dirpath dir) l
+
+let pop_kn kn =
+  let (mp,dir,l) = repr_mind kn in
+  Names.make_mind mp (pop_dirpath dir) l
+
+let pop_global_reference = function
+  | ConstRef con -> ConstRef (pop_con con)
+  | IndRef (kn,i) -> IndRef (pop_kn kn,i)
+  | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j)
+  | VarRef id -> anomaly (Pp.str "VarRef not poppable")
diff --git a/library/globnames.mli b/library/globnames.mli
new file mode 100644
index 00000000..253c20ba
--- /dev/null
+++ b/library/globnames.mli
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  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 Util
+open Names
+open Term
+open Mod_subst
+
+(** {6 Global reference is a kernel side type for all references together } *)
+type global_reference =
+  | VarRef of variable
+  | ConstRef of constant
+  | IndRef of inductive
+  | ConstructRef of constructor
+
+val isVarRef : global_reference -> bool
+val isConstRef : global_reference -> bool
+val isIndRef : global_reference -> bool
+val isConstructRef : global_reference -> bool
+
+val eq_gr : global_reference -> global_reference -> bool
+val canonical_gr : global_reference -> global_reference
+
+val destVarRef : global_reference -> variable
+val destConstRef : global_reference -> constant
+val destIndRef : global_reference -> inductive
+val destConstructRef : global_reference -> constructor
+
+val is_global : global_reference -> constr -> bool
+
+val subst_constructor : substitution -> constructor -> constructor * constr
+val subst_global : substitution -> global_reference -> global_reference * constr
+val subst_global_reference : substitution -> global_reference -> global_reference
+
+(** This constr is not safe to be typechecked, universe polymorphism is not 
+    handled here: just use for printing *)
+val printable_constr_of_global : global_reference -> constr
+
+(** Turn a construction denoting a global reference into a global reference;
+   raise [Not_found] if not a global reference *)
+val global_of_constr : constr -> global_reference
+
+(** Obsolete synonyms for constr_of_global and global_of_constr *)
+val reference_of_constr : constr -> global_reference
+
+module RefOrdered : sig
+  type t = global_reference
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module RefOrdered_env : sig
+  type t = global_reference
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+module Refset : CSig.SetS with type elt = global_reference
+module Refmap : Map.ExtS
+  with type key = global_reference and module Set := Refset
+
+module Refset_env : CSig.SetS with type elt = global_reference
+module Refmap_env : Map.ExtS
+  with type key = global_reference and module Set := Refset_env
+
+(** {6 Extended global references } *)
+
+type syndef_name = kernel_name
+
+type extended_global_reference =
+  | TrueGlobal of global_reference
+  | SynDef of syndef_name
+
+module ExtRefOrdered : sig
+  type t = extended_global_reference
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val hash : t -> int
+end
+
+type global_reference_or_constr = 
+  | IsGlobal of global_reference
+  | IsConstr of constr
+
+(** {6 Temporary function to brutally form kernel names from section paths } *)
+
+val encode_mind : DirPath.t -> Id.t -> mutual_inductive
+val decode_mind : mutual_inductive -> DirPath.t * Id.t
+val encode_con : DirPath.t -> Id.t -> constant
+val decode_con : constant -> DirPath.t * Id.t
+
+(** {6 Popping one level of section in global names } *)
+
+val pop_con : constant -> constant
+val pop_kn : mutual_inductive-> mutual_inductive
+val pop_global_reference : global_reference -> global_reference
diff --git a/library/goptions.ml b/library/goptions.ml
index d92fe262..4aea3368 100644
--- a/library/goptions.ml
+++ b/library/goptions.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        *)
@@ -9,17 +9,25 @@
 (* This module manages customization parameters at the vernacular level     *)
 
 open Pp
+open Errors
 open Util
 open Libobject
-open Names
 open Libnames
-open Term
-open Nametab
 open Mod_subst
 
-open Goptionstyp
+type option_name = string list
+type option_value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
 
-type option_name = Goptionstyp.option_name
+(** Summary of an option status *)
+type option_state = {
+  opt_sync  : bool;
+  opt_depr  : bool;
+  opt_name  : string;
+  opt_value : option_value;
+}
 
 (****************************************************************************)
 (* 0- Common things                                                         *)
@@ -45,6 +53,7 @@ module MakeTable =
    (A : sig
 	  type t
 	  type key
+	  val compare : t -> t -> int
 	  val table : (string * key table_of_A) list ref
 	  val encode : key -> t
 	  val subst : substitution -> t -> t
@@ -62,29 +71,22 @@ module MakeTable =
     let nick = nickname A.key
 
     let _ =
-      if List.mem_assoc nick !A.table then
+      if String.List.mem_assoc nick !A.table then
 	error "Sorry, this table name is already used."
 
-    module MySet = Set.Make (struct type t = A.t let compare = compare end)
+    module MySet = Set.Make (struct type t = A.t let compare = A.compare end)
 
-    let t = ref (MySet.empty : MySet.t)
-
-    let _ =
-      if A.synchronous then
-	let freeze () = !t in
-	let unfreeze c = t := c in
-	let init () = t := MySet.empty in
-	Summary.declare_summary nick
-          { Summary.freeze_function = freeze;
-            Summary.unfreeze_function = unfreeze;
-            Summary.init_function = init }
+    let t =
+      if A.synchronous
+      then Summary.ref MySet.empty ~name:nick
+      else ref MySet.empty
 
     let (add_option,remove_option) =
       if A.synchronous then
         let cache_options (_,(f,p)) = match f with
           | GOadd -> t := MySet.add p !t
           | GOrmv -> t := MySet.remove p !t in
-        let load_options i o = if i=1 then cache_options o in
+        let load_options i o = if Int.equal i 1 then cache_options o in
 	let subst_options (subst,(f,p as obj)) = 
 	  let p' = A.subst subst p in
 	    if p' == p then obj else
@@ -105,12 +107,12 @@ module MakeTable =
          (fun c -> t := MySet.remove c !t))
 
     let print_table table_name printer table =
-      msg (str table_name ++
+      pp (str table_name ++
 	   (hov 0
-	      (if MySet.is_empty table then str "None" ++ fnl ()
+	      (if MySet.is_empty table then str " None" ++ fnl ()
                else MySet.fold
-		 (fun a b -> printer a ++ spc () ++ b)
-		 table (mt ()) ++ fnl ())))
+		 (fun a b -> spc () ++ printer a ++ b)
+		 table (mt ()) ++ str "." ++ fnl ())))
 
     class table_of_A () =
     object
@@ -119,7 +121,7 @@ module MakeTable =
       method mem x =
 	let y = A.encode x in
         let answer = MySet.mem y !t in
-        msg (A.member_message y answer ++ fnl ())
+        msg_info (A.member_message y answer)
       method print = print_table A.title A.printer !t
     end
 
@@ -130,7 +132,7 @@ module MakeTable =
 
 let string_table = ref []
 
-let get_string_table k = List.assoc (nickname k) !string_table
+let get_string_table k = String.List.assoc (nickname k) !string_table
 
 module type StringConvertArg =
 sig
@@ -144,6 +146,7 @@ module StringConvert = functor (A : StringConvertArg) ->
 struct
   type t = string
   type key = string
+  let compare = String.compare
   let table = string_table
   let encode x = x
   let subst _ x = x
@@ -159,11 +162,12 @@ module MakeStringTable =
 
 let ref_table = ref []
 
-let get_ref_table k = List.assoc (nickname k) !ref_table
+let get_ref_table k = String.List.assoc (nickname k) !ref_table
 
 module type RefConvertArg =
 sig
   type t
+  val compare : t -> t -> int
   val encode : reference -> t
   val subst : substitution -> t -> t
   val printer : t -> std_ppcmds
@@ -177,6 +181,7 @@ module RefConvert = functor (A : RefConvertArg) ->
 struct
   type t = A.t
   type key = reference
+  let compare = A.compare
   let table = ref_table
   let encode = A.encode
   let subst = A.subst
@@ -201,10 +206,13 @@ type 'a option_sig = {
   optread  : unit -> 'a;
   optwrite : 'a -> unit }
 
-type option_type = bool * (unit -> option_value) -> (option_value -> unit)
+module OptionOrd =
+struct
+  type t = option_name
+  let compare opt1 opt2 = List.compare String.compare opt1 opt2
+end
 
-module OptionMap =
-  Map.Make (struct  type t = option_name let compare = compare end)
+module OptionMap = Map.Make(OptionOrd)
 
 let value_tab = ref OptionMap.empty
 
@@ -216,11 +224,10 @@ let check_key key = try
   let _ = get_option key in
   error "Sorry, this option name is already used."
 with Not_found ->
-  if List.mem_assoc (nickname key) !string_table
-    or List.mem_assoc (nickname key) !ref_table
+  if String.List.mem_assoc (nickname key) !string_table
+    || String.List.mem_assoc (nickname key) !ref_table
   then error "Sorry, this option name is already used."
 
-open Summary
 open Libobject
 open Lib
 
@@ -251,10 +258,10 @@ let declare_option cast uncast
 		       discharge_function = (fun (_,v) -> Some v);
 		       load_function = (fun _ (_,v) -> write v)}
     in
-    let _ = declare_summary (nickname key)
-	     { freeze_function = read;
-	       unfreeze_function = write;
-	       init_function = (fun () -> write default) }
+    let _ = Summary.declare_summary (nickname key)
+	     { Summary.freeze_function = (fun _ -> read ());
+	       Summary.unfreeze_function = write;
+	       Summary.init_function = (fun () -> write default) }
     in
     begin fun v -> add_anonymous_leaf (decl_obj v) end ,
     begin fun v -> add_anonymous_leaf (ldecl_obj v) end ,
@@ -273,15 +280,15 @@ type 'a write_function = 'a -> unit
 let declare_int_option =
   declare_option
     (fun v -> IntValue v)
-    (function IntValue v -> v | _ -> anomaly "async_option")
+    (function IntValue v -> v | _ -> anomaly (Pp.str "async_option"))
 let declare_bool_option =
   declare_option
     (fun v -> BoolValue v)
-    (function BoolValue v -> v | _ -> anomaly "async_option")
+    (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option"))
 let declare_string_option =
   declare_option
     (fun v -> StringValue v)
-    (function StringValue v -> v | _ -> anomaly "async_option")
+    (function StringValue v -> v | _ -> anomaly (Pp.str "async_option"))
 
 (* 3- User accessible commands *)
 
@@ -326,12 +333,12 @@ let set_int_option_value_gen locality =
   set_option_value locality check_int_value
 let set_bool_option_value_gen locality key v =
   try set_option_value locality check_bool_value key v
-  with UserError (_,s) -> Flags.if_warn msg_warning s
+  with UserError (_,s) -> msg_warning s
 let set_string_option_value_gen locality =
   set_option_value locality check_string_value
 let unset_option_value_gen locality key =
   try set_option_value locality check_unset_value key ()
-  with UserError (_,s) -> Flags.if_warn msg_warning s
+  with UserError (_,s) -> msg_warning s
 
 let set_int_option_value = set_int_option_value_gen None
 let set_bool_option_value = set_bool_option_value_gen None
@@ -346,19 +353,16 @@ let msg_option_value (name,v) =
     | IntValue (Some n) -> int n
     | IntValue None   -> str "undefined"
     | StringValue s   -> str s
-(*     | IdentValue r    -> pr_global_env Idset.empty r *)
+(*     | IdentValue r    -> pr_global_env Id.Set.empty r *)
 
 let print_option_value key =
   let (name, depr, (_,read,_,_,_)) = get_option key in
   let s = read () in
   match s with
     | BoolValue b ->
-	msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++
-	     fnl ())
+	msg_info (str ("The "^name^" mode is "^(if b then "on" else "off")))
     | _ ->
-	msg (str ("Current value of "^name^" is ") ++
-	     msg_option_value (name,s) ++ fnl ())
-
+	msg_info (str ("Current value of "^name^" is ") ++ msg_option_value (name, s))
 
 let get_tables () =
   let tables = !value_tab in
@@ -379,27 +383,26 @@ let print_tables () =
     if depr then msg ++ str " [DEPRECATED]" ++ fnl ()
     else msg ++ fnl ()
   in
-  msg
-    (str "Synchronous options:" ++ fnl () ++
-     OptionMap.fold
-       (fun key (name, depr, (sync,read,_,_,_)) p ->
-	  if sync then p ++ print_option key name (read ()) depr
-	  else p)
-       !value_tab (mt ()) ++
-     str "Asynchronous options:" ++ fnl () ++
-     OptionMap.fold
-       (fun key (name, depr, (sync,read,_,_,_)) p ->
-	  if sync then p
-	  else p ++ print_option key name (read ()) depr)
-       !value_tab (mt ()) ++
-     str "Tables:" ++ fnl () ++
-     List.fold_right
-       (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
-       !string_table (mt ()) ++
-     List.fold_right
-       (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
-       !ref_table (mt ()) ++
-     fnl ()
-    )
+  str "Synchronous options:" ++ fnl () ++
+    OptionMap.fold
+      (fun key (name, depr, (sync,read,_,_,_)) p ->
+        if sync then p ++ print_option key name (read ()) depr
+        else p)
+      !value_tab (mt ()) ++
+  str "Asynchronous options:" ++ fnl () ++
+    OptionMap.fold
+      (fun key (name, depr, (sync,read,_,_,_)) p ->
+        if sync then p
+        else p ++ print_option key name (read ()) depr)
+      !value_tab (mt ()) ++
+  str "Tables:" ++ fnl () ++
+    List.fold_right
+      (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
+      !string_table (mt ()) ++
+    List.fold_right
+      (fun (nickkey,_) p -> p ++ str ("  "^nickkey) ++ fnl ())
+      !ref_table (mt ()) ++
+    fnl ()
+
 
 
diff --git a/library/goptions.mli b/library/goptions.mli
index 1b51a7f7..1c44f890 100644
--- a/library/goptions.mli
+++ b/library/goptions.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        *)
@@ -44,14 +44,10 @@
    (synchronous = consistent with the resetting commands)                   *)
 
 open Pp
-open Util
-open Names
 open Libnames
-open Term
-open Nametab
 open Mod_subst
 
-type option_name = Goptionstyp.option_name
+type option_name = string list
 
 (** {6 Tables. } *)
 
@@ -90,6 +86,7 @@ module MakeRefTable :
   functor
     (A : sig
            type t
+           val compare : t -> t -> int
            val encode : reference -> t
 	   val subst : substitution -> t -> t
            val printer : t -> std_ppcmds
@@ -164,7 +161,20 @@ val set_string_option_value : option_name -> string -> unit
 
 val print_option_value : option_name -> unit
 
-val get_tables : unit -> Goptionstyp.option_state OptionMap.t
-val print_tables : unit -> unit
+type option_value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
+
+(** Summary of an option status *)
+type option_state = {
+  opt_sync  : bool;
+  opt_depr  : bool;
+  opt_name  : string;
+  opt_value : option_value;
+}
+
+val get_tables : unit -> option_state OptionMap.t
+val print_tables : unit -> std_ppcmds
 
 val error_undeclared_key : option_name -> 'a
diff --git a/library/heads.ml b/library/heads.ml
index f49d1cb5..5c153b06 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -1,19 +1,18 @@
 (************************************************************************)
 (*  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 Names
 open Term
+open Vars
 open Mod_subst
 open Environ
-open Libnames
-open Nameops
+open Globnames
 open Libobject
 open Lib
 
@@ -39,38 +38,25 @@ type head_approximation =
 
 module Evalreford = struct
   type t = evaluable_global_reference
-  let compare x y = 
-     let make_name = function
-      | EvalConstRef con -> 
-	  EvalConstRef(constant_of_kn(canonical_con con))
-      | k -> k
-     in 
-       Pervasives.compare (make_name x) (make_name y)
+  let compare gr1 gr2 = match gr1, gr2 with
+  | EvalVarRef id1, EvalVarRef id2 -> Id.compare id1 id2
+  | EvalVarRef _, EvalConstRef _ -> -1
+  | EvalConstRef c1, EvalConstRef c2 ->
+    Constant.CanOrd.compare c1 c2
+  | EvalConstRef _, EvalVarRef _ -> 1
 end
 
 module Evalrefmap =
   Map.Make (Evalreford)
 
 
-let head_map = ref Evalrefmap.empty
-
-let init () = head_map := Evalrefmap.empty
-
-let freeze () = !head_map
-
-let unfreeze hm = head_map := hm
-
-let _ =
-  Summary.declare_summary "Head_decl"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+let head_map = Summary.ref Evalrefmap.empty ~name:"Head_decl"
 
 let variable_head id  = Evalrefmap.find (EvalVarRef id) !head_map
 let constant_head cst = Evalrefmap.find (EvalConstRef cst) !head_map
 
 let kind_of_head env t =
-  let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with
+  let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta env t) with
   | Rel n when n > k -> NotImmediatelyComputableHead
   | Rel n -> FlexibleHead (k,k+1-n,List.length l,b)
   | Var id ->
@@ -80,18 +66,27 @@ let kind_of_head env t =
         match pi2 (lookup_named id env) with
         | Some c -> aux k l c b
         | None -> NotImmediatelyComputableHead)
-  | Const cst ->
+  | Const (cst,_) ->
       (try on_subterm k l b (constant_head cst)
        with Not_found -> assert false)
   | Construct _ | CoFix _ ->
       if b then NotImmediatelyComputableHead else ConstructorHead
   | Sort _ | Ind _ | Prod _ -> RigidHead RigidType
   | Cast (c,_,_) -> aux k l c b
-  | Lambda (_,_,c) when l = [] -> assert (not b); aux (k+1) [] c b
-  | Lambda (_,_,c) -> aux k (List.tl l) (subst1 (List.hd l) c) b
+  | Lambda (_,_,c) ->
+    begin match l with
+    | [] ->
+      let () = assert (not b) in
+      aux (k + 1) [] c b
+    | h :: l -> aux k l (subst1 h c) b
+    end
   | LetIn _ -> assert false
   | Meta _ | Evar _ -> NotImmediatelyComputableHead
   | App (c,al) -> aux k (Array.to_list al @ l) c b
+  | Proj (p,c) ->
+      (try on_subterm k (c :: l) b (constant_head (Projection.constant p))
+       with Not_found -> assert false)
+
   | Case (_,_,c,_) -> aux k [] c true
   | Fix ((i,j),_) ->
       let n = i.(j) in
@@ -113,18 +108,26 @@ let kind_of_head env t =
           k+n-m,[],a
         else
           (* enough arguments to [cst] *)
-          k,list_skipn n l,List.nth l (i-1) in
-      let l' = list_tabulate (fun _ -> mkMeta 0) q @ rest in
-      aux k' l' a (with_subcase or with_case)
+          k,List.skipn n l,List.nth l (i-1) in
+      let l' = List.make q (mkMeta 0) @ rest in
+      aux k' l' a (with_subcase || with_case)
   | ConstructorHead when with_case -> NotImmediatelyComputableHead
   | x -> x
   in aux 0 [] t false
 
+(* FIXME: maybe change interface here *)
 let compute_head = function
 | EvalConstRef cst ->
-    (match constant_opt_value (Global.env()) cst with
+   let env = Global.env() in
+   let cb = Environ.lookup_constant cst env in
+   let is_Def = function Declarations.Def _ -> true | _ -> false in
+   let body = 
+     if cb.Declarations.const_proj = None && is_Def cb.Declarations.const_body
+     then Declareops.body_of_constant (Environ.opaque_tables env) cb else None 
+   in
+     (match body with
      | None -> RigidHead (RigidParameter cst)
-     | Some c -> kind_of_head (Global.env()) c)
+     | Some c -> kind_of_head env c)
 | EvalVarRef id ->
     (match pi2 (Global.lookup_named id) with
      | Some c when not (Decls.variable_opacity id) ->
@@ -147,8 +150,8 @@ let cache_head o =
 
 let subst_head_approximation subst = function
   | RigidHead (RigidParameter cst) as k ->
-      let cst,c = subst_con subst cst in
-      if isConst c && eq_constant (destConst c) cst then
+      let cst,c = subst_con_kn subst cst in
+      if isConst c && eq_constant (fst (destConst c)) cst then
         (* A change of the prefix of the constant *)
         k
       else
@@ -181,15 +184,3 @@ let inHead : head_obj -> obj =
 let declare_head c =
   let hd = compute_head c in
   add_anonymous_leaf (inHead (c,hd))
-
-(** Printing *)
-
-let pr_head = function
-| RigidHead (RigidParameter cst) -> str "rigid constant " ++ pr_con cst
-| RigidHead (RigidType) -> str "rigid type"
-| RigidHead (RigidVar id) -> str "rigid variable " ++ pr_id id
-| ConstructorHead -> str "constructor"
-| FlexibleHead (k,n,p,b) -> int n ++ str "th of " ++ int k ++ str " binders applied to " ++ int p ++ str " arguments" ++ (if b then str " (with case)" else mt())
-| NotImmediatelyComputableHead -> str "unknown"
-
-
diff --git a/library/heads.mli b/library/heads.mli
index 9ec49648..52f43824 100644
--- a/library/heads.mli
+++ b/library/heads.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/library/impargs.ml b/library/impargs.ml
index a6770cb8..4b0e2e3d 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -1,26 +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 Errors
 open Util
 open Names
-open Libnames
+open Globnames
 open Term
 open Reduction
 open Declarations
 open Environ
-open Inductive
 open Libobject
 open Lib
-open Nametab
 open Pp
-open Topconstr
+open Constrexpr
 open Termops
 open Namegen
+open Decl_kinds
 
 (*s Flags governing the computation of implicit arguments *)
 
@@ -74,14 +74,15 @@ let with_implicits flags f x =
     let rslt = f x in
     implicit_args := oflags;
     rslt
-  with reraise -> begin
-    implicit_args := oflags;
-    raise reraise
-  end
+  with reraise ->
+    let reraise = Errors.push reraise in
+    let () = implicit_args := oflags in
+    iraise reraise
 
 let set_maximality imps b =
   (* Force maximal insertion on ending implicits (compatibility) *)
-  b || List.for_all ((<>) None) imps
+  let is_set x = match x with None -> false | _ -> true in
+  b || List.for_all is_set imps
 
 (*s Computation of implicit arguments *)
 
@@ -112,6 +113,18 @@ type argument_position =
   | Conclusion
   | Hyp of int
 
+let argument_position_eq p1 p2 = match p1, p2 with
+| Conclusion, Conclusion -> true
+| Hyp h1, Hyp h2 -> Int.equal h1 h2
+| _ -> false
+
+let explicitation_eq ex1 ex2 = match ex1, ex2 with
+| ExplByPos (i1, id1), ExplByPos (i2, id2) ->
+  Int.equal i1 i2 && Option.equal Id.equal id1 id2
+| ExplByName id1, ExplByName id2 ->
+  Id.equal id1 id2
+| _ -> false
+
 type implicit_explanation =
   | DepRigid of argument_position
   | DepFlex of argument_position
@@ -131,10 +144,10 @@ let update pos rig (na,st) =
       | Some (DepRigid n as x) ->
           if argument_less (pos,n) then DepRigid pos else x
       | Some (DepFlexAndRigid (fpos,rpos) as x) ->
-          if argument_less (pos,fpos) or pos=fpos then DepRigid pos else
+          if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos else
           if argument_less (pos,rpos) then DepFlexAndRigid (fpos,pos) else x
       | Some (DepFlex fpos) ->
-          if argument_less (pos,fpos) or pos=fpos then DepRigid pos
+          if argument_less (pos,fpos) || argument_position_eq pos fpos then DepRigid pos
           else DepFlexAndRigid (fpos,pos)
       | Some Manual -> assert false
   else
@@ -155,20 +168,21 @@ let is_flexible_reference env bound depth f =
     | Rel n when n >= bound+depth -> (* inductive type *) false
     | Rel n when n >= depth -> (* previous argument *) true
     | Rel n -> (* since local definitions have been expanded *) false
-    | Const kn ->
+    | Const (kn,_) ->
         let cb = Environ.lookup_constant kn env in
 	(match cb.const_body with Def _ -> true | _ -> false)
     | Var id ->
-        let (_,value,_) = Environ.lookup_named id env in value <> None
+        let (_, value, _) = Environ.lookup_named id env in
+        begin match value with None -> false | _ -> true end
     | Ind _ | Construct _ -> false
     |  _ -> true
 
 let push_lift d (e,n) = (push_rel d e,n+1)
 
 let is_reversible_pattern bound depth f l =
-  isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) &
-  array_for_all (fun c -> isRel c & destRel c < depth) l &
-  array_distinct l
+  isRel f && let n = destRel f in (n < bound+depth) && (n >= depth) &&
+  Array.for_all (fun c -> isRel c && destRel c < depth) l &&
+  Array.distinct l
 
 (* Precondition: rels in env are for inductive types only *)
 let add_free_rels_until strict strongly_strict revpat bound env m pos acc =
@@ -176,15 +190,18 @@ let add_free_rels_until strict strongly_strict revpat bound env m pos acc =
     let hd = if strict then whd_betadeltaiota env c else c in
     let c = if strongly_strict then hd else c in
     match kind_of_term hd with
-    | Rel n when (n < bound+depth) & (n >= depth) ->
+    | Rel n when (n < bound+depth) && (n >= depth) ->
 	let i = bound + depth - n - 1 in
         acc.(i) <- update pos rig acc.(i)
-    | App (f,l) when revpat & is_reversible_pattern bound depth f l ->
+    | App (f,l) when revpat && is_reversible_pattern bound depth f l ->
 	let i = bound + depth - destRel f - 1 in
 	acc.(i) <- update pos rig acc.(i)
-    | App (f,_) when rig & is_flexible_reference env bound depth f ->
+    | App (f,_) when rig && is_flexible_reference env bound depth f ->
 	if strict then () else
           iter_constr_with_full_binders push_lift (frec false) ed c
+    | Proj (p,c) when rig ->
+      if strict then () else
+        iter_constr_with_full_binders push_lift (frec false) ed c	  
     | Case _ when rig ->
 	if strict then () else
           iter_constr_with_full_binders push_lift (frec false) ed c
@@ -192,12 +209,14 @@ let add_free_rels_until strict strongly_strict revpat bound env m pos acc =
     | _ ->
         iter_constr_with_full_binders push_lift (frec rig) ed c
   in
-  frec true (env,1) m; acc
+  let () = if not (Vars.noccur_between 1 bound m) then frec true (env,1) m in
+  acc
 
 let rec is_rigid_head t = match kind_of_term t with
   | Rel _ | Evar _ -> false
   | Ind _ | Const _ | Var _ | Sort _ -> true
   | Case (_,_,f,_) -> is_rigid_head f
+  | Proj (p,c) -> true
   | App (f,args) ->
       (match kind_of_term f with
 	| Fix ((fi,i),_) -> is_rigid_head (args.(fi.(i)))
@@ -238,7 +257,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t =
 
 let compute_implicits_flags env f all t =
   compute_implicits_gen
-    (f.strict or f.strongly_strict) f.strongly_strict
+    (f.strict || f.strongly_strict) f.strongly_strict
     f.reversible_pattern f.contextual all env t
 
 let compute_auto_implicits env flags enriching t =
@@ -256,7 +275,7 @@ type force_inference = bool (* true = always infer, never turn into evar/subgoal
 
 type implicit_status =
     (* None = Not implicit *)
-    (identifier * implicit_explanation * (maximal_insertion * force_inference)) option
+    (Id.t * implicit_explanation * (maximal_insertion * force_inference)) option
 
 type implicit_side_condition = DefaultImpArgs | LessArgsThan of int
 
@@ -267,23 +286,23 @@ let is_status_implicit = function
   | _ -> true
 
 let name_of_implicit = function
-  | None -> anomaly "Not an implicit argument"
+  | None -> anomaly (Pp.str "Not an implicit argument")
   | Some (id,_,_) -> id
 
 let maximal_insertion_of = function
   | Some (_,_,(b,_)) -> b
-  | None -> anomaly "Not an implicit argument"
+  | None -> anomaly (Pp.str "Not an implicit argument")
 
 let force_inference_of = function
   | Some (_, _, (_, b)) -> b
-  | None -> anomaly "Not an implicit argument"
+  | None -> anomaly (Pp.str "Not an implicit argument")
 
 (* [in_ctx] means we know the expected type, [n] is the index of the argument *)
 let is_inferable_implicit in_ctx n = function
   | None -> false
-  | Some (_,DepRigid (Hyp p),_) -> in_ctx or n >= p
+  | Some (_,DepRigid (Hyp p),_) -> in_ctx || n >= p
   | Some (_,DepFlex (Hyp p),_) -> false
-  | Some (_,DepFlexAndRigid (_,Hyp q),_) -> in_ctx or n >= q
+  | Some (_,DepFlexAndRigid (_,Hyp q),_) -> in_ctx || n >= q
   | Some (_,DepRigid Conclusion,_) -> in_ctx
   | Some (_,DepFlex Conclusion,_) -> false
   | Some (_,DepFlexAndRigid (_,Conclusion),_) -> in_ctx
@@ -300,7 +319,7 @@ let positions_of_implicits (_,impls) =
 
 let rec prepare_implicits f = function
   | [] -> []
-  | (Anonymous, Some _)::_ -> anomaly "Unnamed implicit"
+  | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit")
   | (Name id, Some imp)::imps ->
       let imps' = prepare_implicits f imps in
       Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps'
@@ -310,7 +329,7 @@ let set_implicit id imp insmax =
   (id,(match imp with None -> Manual | Some imp -> imp),insmax)
 
 let rec assoc_by_pos k = function
-    (ExplByPos (k', x), b) :: tl when k = k' -> (x,b), tl
+    (ExplByPos (k', x), b) :: tl when Int.equal k k' -> (x,b), tl
   | hd :: tl -> let (x, tl) = assoc_by_pos k tl in x, hd :: tl
   | [] -> raise Not_found
 
@@ -318,9 +337,9 @@ let check_correct_manual_implicits autoimps l =
   List.iter (function
     | ExplByName id,(b,fi,forced) ->
 	if not forced then
-	  error ("Wrong or non-dependent implicit argument name: "^(string_of_id id)^".")
+	  error ("Wrong or non-dependent implicit argument name: "^(Id.to_string id)^".")
     | ExplByPos (i,_id),_t ->
-	if i<1 or i>List.length autoimps then
+	if i<1 || i>List.length autoimps then
 	  error ("Bad implicit argument number: "^(string_of_int i)^".")
 	else
 	  errorlabstrm ""
@@ -332,34 +351,41 @@ let set_manual_implicits env flags enriching autoimps l =
     try
       let (id, (b, fi, fo)), l' = assoc_by_pos k l in
 	if fo then
-	  let id = match id with Some id -> id | None -> id_of_string ("arg_" ^ string_of_int k) in
+	  let id = match id with Some id -> id | None -> Id.of_string ("arg_" ^ string_of_int k) in
 	    l', Some (id,Manual,(b,fi))
 	else l, None
     with Not_found -> l, None
   in
-  if not (list_distinct l) then
+  if not (List.distinct l) then
     error ("Some parameters are referred more than once.");
   (* Compare with automatic implicits to recover printing data and names *)
   let rec merge k l = function
   | (Name id,imp)::imps ->
       let l',imp,m =
 	try
-	  let (b, fi, fo) = List.assoc (ExplByName id) l in
-	  List.remove_assoc (ExplByName id) l, (Some Manual), (Some (b, fi))
+          let eq = explicitation_eq in
+	  let (b, fi, fo) = List.assoc_f eq (ExplByName id) l in
+	  List.remove_assoc_f eq (ExplByName id) l, (Some Manual), (Some (b, fi))
 	with Not_found ->
 	try
 	  let (id, (b, fi, fo)), l' = assoc_by_pos k l in
 	    l', (Some Manual), (Some (b,fi))
 	with Not_found ->
-	  l,imp, if enriching && imp <> None then Some (flags.maximal,true) else None
+          let m = match enriching, imp with
+          | true, Some _ -> Some (flags.maximal, true)
+          | _ -> None
+          in
+          l, imp, m
       in
       let imps' = merge (k+1) l' imps in
-      let m = Option.map (fun (b,f) -> set_maximality imps' b, f) m in
+      let m = Option.map (fun (b,f) -> 
+	(* match imp with Some Manual -> (b,f) *)
+	(* | _ ->  *)set_maximality imps' b, f) m in
       Option.map (set_implicit id imp) m :: imps'
   | (Anonymous,imp)::imps ->
       let l', forced = try_forced k l in
 	forced :: merge (k+1) l' imps
-  | [] when l = [] -> []
+  | [] when begin match l with [] -> true | _ -> false end -> []
   | [] ->
       check_correct_manual_implicits autoimps l;
       []
@@ -376,13 +402,14 @@ let compute_semi_auto_implicits env f manual t =
       let _,autoimpls = compute_auto_implicits env f f.auto t in
       [DefaultImpArgs, set_manual_implicits env f f.auto autoimpls manual]
 
-let compute_implicits env t = compute_semi_auto_implicits env !implicit_args [] t
-
 (*s Constants. *)
 
 let compute_constant_implicits flags manual cst =
   let env = Global.env () in
-  compute_semi_auto_implicits env flags manual (Typeops.type_of_constant env cst)
+  let cb = Environ.lookup_constant cst env in
+  let ty = Typeops.type_of_constant_type env cb.const_type in
+  let impls = compute_semi_auto_implicits env flags manual ty in
+    impls
 
 (*s Inductives and constructors. Their implicit arguments are stored
    in an array, indexed by the inductive number, of pairs $(i,v)$ where
@@ -394,14 +421,15 @@ let compute_mib_implicits flags manual kn =
   let mib = lookup_mind kn env in
   let ar =
     Array.to_list
-      (Array.map  (* No need to lift, arities contain no de Bruijn *)
-        (fun mip ->
-	  (Name mip.mind_typename, None, type_of_inductive env (mib,mip)))
+      (Array.mapi  (* No need to lift, arities contain no de Bruijn *)
+        (fun i mip ->
+	  (** No need to care about constraints here *)
+	  (Name mip.mind_typename, None, Global.type_of_global_unsafe (IndRef (kn,i))))
         mib.mind_packets) in
   let env_ar = push_rel_context ar env in
   let imps_one_inductive i mip =
     let ind = (kn,i) in
-    let ar = type_of_inductive env (mib,mip) in
+    let ar = Global.type_of_global_unsafe (IndRef ind) in
     ((IndRef ind,compute_semi_auto_implicits env flags manual ar),
      Array.mapi (fun j c ->
        (ConstructRef (ind,j+1),compute_semi_auto_implicits env_ar flags manual c))
@@ -412,7 +440,7 @@ let compute_mib_implicits flags manual kn =
 let compute_all_mib_implicits flags manual kn =
   let imps = compute_mib_implicits flags manual kn in
   List.flatten
-    (array_map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps)
+    (Array.map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps)
 
 (*s Variables. *)
 
@@ -434,7 +462,7 @@ let compute_global_implicits flags manual = function
 (* Merge a manual explicitation with an implicit_status list *)
 
 let merge_impls (cond,oldimpls) (_,newimpls) =
-  let oldimpls,usersuffiximpls = list_chop (List.length newimpls) oldimpls in
+  let oldimpls,usersuffiximpls = List.chop (List.length newimpls) oldimpls in
   cond, (List.map2 (fun orig ni ->
     match orig with
     | Some (_, Manual, _) -> orig
@@ -453,7 +481,7 @@ type implicit_discharge_request =
   | ImplInteractive of global_reference * implicits_flags *
       implicit_interactive_request
 
-let implicits_table = ref Refmap.empty
+let implicits_table = Summary.ref Refmap.empty ~name:"implicits"
 
 let implicits_of_global ref =
   try
@@ -466,7 +494,7 @@ let implicits_of_global ref =
       List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l
     with Not_found -> l
     | Invalid_argument _ ->
-        anomaly "renamings list and implicits list have different lenghts"
+        anomaly (Pp.str "renamings list and implicits list have different lenghts")
   with Not_found -> [DefaultImpArgs,[]]
 
 let cache_implicits_decl (ref,imps) =
@@ -481,16 +509,23 @@ let subst_implicits_decl subst (r,imps as o) =
   let r' = fst (subst_global subst r) in if r==r' then o else (r',imps)
 
 let subst_implicits (subst,(req,l)) =
-  (ImplLocal,list_smartmap (subst_implicits_decl subst) l)
+  (ImplLocal,List.smartmap (subst_implicits_decl subst) l)
 
 let impls_of_context ctx =
-  List.rev_map (fun (id,impl,_,_) -> if impl = Lib.Implicit then Some (id, Manual, (true,true)) else None)
-    (List.filter (fun (_,_,b,_) -> b = None) ctx)
+  let map (id, impl, _, _) = match impl with
+  | Implicit -> Some (id, Manual, (true, true))
+  | _ -> None
+  in
+  let is_set (_, _, b, _) = match b with
+  | None -> true
+  | Some _ -> false
+  in
+  List.rev_map map (List.filter is_set ctx)
 
 let section_segment_of_reference = function
-  | ConstRef con -> section_segment_of_constant con
+  | ConstRef con -> pi1 (section_segment_of_constant con)
   | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
-      section_segment_of_mutual_inductive kn
+    pi1 (section_segment_of_mutual_inductive kn)
   | _ -> []
 
 let adjust_side_condition p = function
@@ -515,9 +550,10 @@ let discharge_implicits (_,(req,l)) =
   | ImplConstant (con,flags) ->
     (try
       let con' = pop_con con in
-      let vars = section_segment_of_constant con in
+      let vars,_,_ = section_segment_of_constant con in
       let extra_impls = impls_of_context vars in
-      let l' = [ConstRef con',List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in
+      let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in
+      let l' = [ConstRef con',newimpls] in
 	Some (ImplConstant (con',flags),l')
     with Not_found -> (* con not defined in this section *) Some (req,l))
   | ImplMutualInductive (kn,flags) ->
@@ -560,13 +596,14 @@ let rebuild_implicits (req,l) =
 	  if flags.auto then
 	    let newimpls = List.hd (compute_global_implicits flags [] ref) in
 	    let p = List.length (snd newimpls) - userimplsize in
-	    let newimpls = on_snd (list_firstn p) newimpls in
+	    let newimpls = on_snd (List.firstn p) newimpls in
 	    [ref,List.map (fun o -> merge_impls o newimpls) oldimpls]
 	  else
 	    [ref,oldimpls]
 
-let classify_implicits (req,_ as obj) =
-  if req = ImplLocal then Dispose else Substitute obj
+let classify_implicits (req,_ as obj) = match req with
+| ImplLocal -> Dispose
+| _ -> Substitute obj
 
 type implicits_obj =
     implicit_discharge_request *
@@ -603,14 +640,14 @@ let declare_constant_implicits con =
 
 let declare_mib_implicits kn =
   let flags = !implicit_args in
-  let imps = array_map_to_list
+  let imps = Array.map_to_list
     (fun (ind,cstrs) -> ind::(Array.to_list cstrs))
     (compute_mib_implicits flags [] kn) in
     add_anonymous_leaf
       (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps))
 
 (* Declare manual implicits *)
-type manual_explicitation = Topconstr.explicitation * (bool * bool * bool)
+type manual_explicitation = Constrexpr.explicitation * (bool * bool * bool)
 
 type manual_implicits = manual_explicitation list
 
@@ -632,10 +669,14 @@ let check_rigidity isrigid =
   if not isrigid then
     errorlabstrm "" (strbrk "Multiple sequences of implicit arguments available only for references that cannot be applied to an arbitrarily large number of arguments.")
 
+let projection_implicits env p impls = 
+  let pb = Environ.lookup_projection p env in
+    CList.skipn_at_least pb.Declarations.proj_npars impls
+
 let declare_manual_implicits local ref ?enriching l =
   let flags = !implicit_args in
   let env = Global.env () in
-  let t = Global.type_of_global ref in
+  let t = Global.type_of_global_unsafe ref in
   let enriching = Option.default flags.auto enriching in
   let isrigid,autoimpls = compute_auto_implicits env flags enriching t in
   let l' = match l with
@@ -645,7 +686,7 @@ let declare_manual_implicits local ref ?enriching l =
     | _ ->
 	check_rigidity isrigid;
 	let l = List.map (fun imps -> (imps,List.length imps)) l in
-	let l = Sort.list (fun (_,n1) (_,n2) -> n1 > n2) l in
+	let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in
 	check_inclusion l;
 	let nargs = List.length autoimpls in
 	List.map (fun (imps,n) ->
@@ -658,8 +699,9 @@ let declare_manual_implicits local ref ?enriching l =
     add_anonymous_leaf (inImplicits (req,[ref,l']))
 
 let maybe_declare_manual_implicits local ref ?enriching l =
-  if l = [] then ()
-  else declare_manual_implicits local ref ?enriching [l]
+  match l with
+  | [] -> ()
+  | _ -> declare_manual_implicits local ref ?enriching [l]
 
 let extract_impargs_data impls =
   let rec aux p = function
@@ -677,7 +719,7 @@ let lift_implicits n =
 let make_implicits_list l = [DefaultImpArgs, l]
 
 let rec drop_first_implicits p l =
-  if p = 0 then l else match l with
+  if Int.equal p 0 then l else match l with
   | _,[] as x -> x
   | DefaultImpArgs,imp::impls ->
       drop_first_implicits (p-1) (DefaultImpArgs,impls)
@@ -691,18 +733,6 @@ let rec select_impargs_size n = function
   | (LessArgsThan p, impls)::l ->
       if n <= p then impls else select_impargs_size n l
 
-let rec select_stronger_impargs = function
+let select_stronger_impargs = function
   | [] -> [] (* Tolerance for (DefaultImpArgs,[]) *)
   | (_,impls)::_ -> impls
-
-(*s Registration as global tables *)
-
-let init () = implicits_table := Refmap.empty
-let freeze () = !implicits_table
-let unfreeze t = implicits_table := t
-
-let _ =
-  Summary.declare_summary "implicits"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
diff --git a/library/impargs.mli b/library/impargs.mli
index 9038ca88..1d3a73e9 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -1,16 +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 Names
-open Libnames
+open Globnames
 open Term
 open Environ
-open Nametab
 
 (** {6 Implicit Arguments } *)
 (** Here we store the implicit arguments. Notice that we
@@ -68,7 +67,7 @@ type implicit_explanation =
 type maximal_insertion = bool (** true = maximal contextual insertion *)
 type force_inference = bool (** true = always infer, never turn into evar/subgoal *)
 
-type implicit_status = (identifier * implicit_explanation * 
+type implicit_status = (Id.t * implicit_explanation * 
 			  (maximal_insertion * force_inference)) option
     (** [None] = Not implicit *)
 
@@ -78,7 +77,7 @@ type implicits_list = implicit_side_condition * implicit_status list
 
 val is_status_implicit : implicit_status -> bool
 val is_inferable_implicit : bool -> int -> implicit_status -> bool
-val name_of_implicit : implicit_status -> identifier
+val name_of_implicit : implicit_status -> Id.t
 val maximal_insertion_of : implicit_status -> bool
 val force_inference_of : implicit_status -> bool
 
@@ -87,7 +86,7 @@ val positions_of_implicits : implicits_list -> int list
 (** A [manual_explicitation] is a tuple of a positional or named explicitation with
    maximal insertion, force inference and force usage flags. Forcing usage makes
    the argument implicit even if the automatic inference considers it not inferable. *)
-type manual_explicitation = Topconstr.explicitation * 
+type manual_explicitation = Constrexpr.explicitation *
     (maximal_insertion * force_inference * bool)
 
 type manual_implicits = manual_explicitation list
@@ -95,7 +94,7 @@ type manual_implicits = manual_explicitation list
 val compute_implicits_with_manual : env -> types -> bool ->
   manual_implicits -> implicit_status list
 
-val compute_implicits_names : env -> types -> name list
+val compute_implicits_names : env -> types -> Name.t list
 
 (** {6 Computation of implicits (done using the global environment). } *)
 
@@ -130,6 +129,9 @@ val make_implicits_list : implicit_status list -> implicits_list list
 
 val drop_first_implicits : int -> implicits_list -> implicits_list
 
+val projection_implicits : env -> projection -> implicit_status list -> 
+  implicit_status list
+
 val select_impargs_size : int -> implicits_list list -> implicit_status list
 
 val select_stronger_impargs : implicits_list list -> implicit_status list
@@ -143,3 +145,5 @@ type implicit_discharge_request =
   | ImplInteractive of global_reference * implicits_flags *
       implicit_interactive_request
 
+val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool
+(** Equality on [explicitation]. *)
diff --git a/library/keys.ml b/library/keys.ml
new file mode 100644
index 00000000..3d277476
--- /dev/null
+++ b/library/keys.ml
@@ -0,0 +1,170 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Keys for unification and indexing *)
+
+open Globnames
+open Term
+open Libobject
+
+type key = 
+  | KGlob of global_reference
+  | KLam 
+  | KLet
+  | KProd
+  | KSort
+  | KEvar
+  | KCase 
+  | KFix 
+  | KCoFix
+  | KRel 
+  | KMeta
+
+module KeyOrdered = struct
+  type t = key
+
+  let hash gr =
+    match gr with
+    | KGlob gr -> 10 + RefOrdered.hash gr
+    | KLam -> 0
+    | KLet -> 1
+    | KProd -> 2
+    | KSort -> 3
+    | KEvar -> 4
+    | KCase -> 5
+    | KFix -> 6
+    | KCoFix -> 7
+    | KRel -> 8
+    | KMeta -> 9
+
+  let compare gr1 gr2 =
+    match gr1, gr2 with
+    | KGlob gr1, KGlob gr2 -> RefOrdered.compare gr1 gr2
+    | _, KGlob _ -> -1
+    | KGlob _, _ -> 1
+    | k, k' -> Int.compare (hash k) (hash k')
+    
+  let equal k1 k2 =
+    match k1, k2 with
+    | KGlob gr1, KGlob gr2 -> RefOrdered.equal gr1 gr2
+    | _, KGlob _ -> false
+    | KGlob _, _ -> false
+    | k, k' -> k == k'
+end
+
+module Keymap = HMap.Make(KeyOrdered)
+module Keyset = Keymap.Set
+
+(* Mapping structure for references to be considered equivalent *)
+
+type keys = Keyset.t Keymap.t
+
+let keys = Summary.ref Keymap.empty ~name:"Keys_decl"
+
+let add_kv k v m =
+  try Keymap.modify k (fun k' vs -> Keyset.add v vs) m
+  with Not_found -> Keymap.add k (Keyset.singleton v) m
+
+let add_keys k v = 
+  keys := add_kv k v (add_kv v k !keys)
+
+let equiv_keys k k' =
+  k == k' || KeyOrdered.equal k k' ||
+    try Keyset.mem k' (Keymap.find k !keys)
+    with Not_found -> false
+
+(** Registration of keys as an object *)
+
+let load_keys _ (_,(ref,ref')) =
+  add_keys ref ref'
+
+let cache_keys o =
+  load_keys 1 o
+
+let subst_key subst k = 
+  match k with
+  | KGlob gr -> KGlob (subst_global_reference subst gr)
+  | _ -> k
+
+let subst_keys (subst,(k,k')) =
+  (subst_key subst k, subst_key subst k')
+
+let discharge_key = function
+  | KGlob g when Lib.is_in_section g ->
+    if isVarRef g then None else Some (KGlob (pop_global_reference g))
+  | x -> Some x
+
+let discharge_keys (_,(k,k')) =
+  match discharge_key k, discharge_key k' with 
+  | Some x, Some y -> Some (x, y)
+  | _ -> None
+
+let rebuild_keys (ref,ref') = (ref, ref')
+
+type key_obj = key * key
+
+let inKeys : key_obj -> obj =
+  declare_object {(default_object "KEYS") with
+    cache_function = cache_keys;
+    load_function = load_keys;
+    subst_function = subst_keys;
+    classify_function = (fun x -> Substitute x);
+    discharge_function = discharge_keys;
+    rebuild_function = rebuild_keys }
+
+let declare_equiv_keys ref ref' =
+  Lib.add_anonymous_leaf (inKeys (ref,ref'))
+
+let constr_key c =
+  let open Globnames in 
+  try 
+    let rec aux k = 
+      match kind_of_term k with
+      | Const (c, _) -> KGlob (ConstRef c)
+      | Ind (i, u) -> KGlob (IndRef i)
+      | Construct (c,u) -> KGlob (ConstructRef c)
+      | Var id -> KGlob (VarRef id)
+      | App (f, _) -> aux f
+      | Proj (p, _) -> KGlob (ConstRef (Names.Projection.constant p))
+      | Cast (p, _, _) -> aux p
+      | Lambda _ -> KLam 
+      | Prod _ -> KProd
+      | Case _ -> KCase
+      | Fix _ -> KFix
+      | CoFix _ -> KCoFix
+      | Rel _ -> KRel
+      | Meta _ -> raise Not_found
+      | Evar _ -> raise Not_found
+      | Sort _ -> KSort 
+      | LetIn _ -> KLet
+    in Some (aux c)
+  with Not_found -> None
+
+open Pp
+
+let pr_key pr_global = function
+  | KGlob gr -> pr_global gr
+  | KLam -> str"Lambda"
+  | KLet -> str"Let"
+  | KProd -> str"Product"
+  | KSort -> str"Sort"
+  | KEvar -> str"Evar"
+  | KCase -> str"Case"
+  | KFix -> str"Fix"
+  | KCoFix -> str"CoFix"
+  | KRel -> str"Rel"
+  | KMeta -> str"Meta"
+
+let pr_keyset pr_global v = 
+  prlist_with_sep spc (pr_key pr_global) (Keyset.elements v)
+
+let pr_mapping pr_global k v = 
+  pr_key pr_global k ++ str" <-> " ++ pr_keyset pr_global v
+
+let pr_keys pr_global =
+  Keymap.fold (fun k v acc -> pr_mapping pr_global k v ++ fnl () ++ acc) !keys (mt())
diff --git a/library/keys.mli b/library/keys.mli
new file mode 100644
index 00000000..bfbb4c58
--- /dev/null
+++ b/library/keys.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(*  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 Globnames
+
+type key
+
+val declare_equiv_keys : key -> key -> unit
+(** Declare two keys as being equivalent. *)
+
+val equiv_keys : key -> key -> bool
+(** Check equivalence of keys. *)
+
+val constr_key : Term.constr -> key option
+(** Compute the head key of a term. *)
+
+val pr_keys : (global_reference -> Pp.std_ppcmds) -> Pp.std_ppcmds
+(** Pretty-print the mapping *)
diff --git a/library/kindops.ml b/library/kindops.ml
new file mode 100644
index 00000000..56048647
--- /dev/null
+++ b/library/kindops.ml
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  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 Decl_kinds
+
+(** Operations about types defined in [Decl_kinds] *)
+
+let logical_kind_of_goal_kind = function
+  | DefinitionBody d -> IsDefinition d
+  | Proof s -> IsProof s
+
+let string_of_theorem_kind = function
+  | Theorem -> "Theorem"
+  | Lemma -> "Lemma"
+  | Fact -> "Fact"
+  | Remark -> "Remark"
+  | Property -> "Property"
+  | Proposition -> "Proposition"
+  | Corollary -> "Corollary"
+
+let string_of_definition_kind def =
+  let (locality, poly, kind) = def in
+  let error () = Errors.anomaly (Pp.str "Internal definition kind") in
+  match kind with
+  | Definition ->
+    begin match locality with
+    | Discharge -> "Let"
+    | Local -> "Local Definition"
+    | Global -> "Definition"
+    end
+  | Example ->
+    begin match locality with
+    | Discharge -> error ()
+    | Local -> "Local Example"
+    | Global -> "Example"
+    end
+  | Coercion ->
+    begin match locality with
+    | Discharge -> error ()
+    | Local -> "Local Coercion"
+    | Global -> "Coercion"
+    end
+  | SubClass ->
+    begin match locality with
+    | Discharge -> error ()
+    | Local -> "Local SubClass"
+    | Global -> "SubClass"
+    end
+  | CanonicalStructure ->
+    begin match locality with
+    | Discharge -> error ()
+    | Local -> error ()
+    | Global -> "Canonical Structure"
+    end
+  | Instance ->
+    begin match locality with
+    | Discharge -> error ()
+    | Local -> "Instance"
+    | Global -> "Global Instance"
+    end
+  | (StructureComponent|Scheme|CoFixpoint|Fixpoint|IdentityCoercion|Method) ->
+    Errors.anomaly (Pp.str "Internal definition kind")
diff --git a/library/kindops.mli b/library/kindops.mli
new file mode 100644
index 00000000..cd2e39cf
--- /dev/null
+++ b/library/kindops.mli
@@ -0,0 +1,15 @@
+(************************************************************************)
+(*  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 Decl_kinds
+
+(** Operations about types defined in [Decl_kinds] *)
+
+val logical_kind_of_goal_kind : goal_object_kind -> logical_kind
+val string_of_theorem_kind : theorem_kind -> string
+val string_of_definition_kind : definition_kind -> string
diff --git a/library/lib.ml b/library/lib.ml
index f18bbac6..9977b666 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -1,17 +1,18 @@
 (************************************************************************)
 (*  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 Libnames
+open Globnames
 open Nameops
 open Libobject
-open Summary
 
 type is_type = bool (* Module Type or just Module *)
 type export = bool option (* None for a Module Type *)
@@ -29,7 +30,7 @@ and library_entry = object_name * node
 
 and library_segment = library_entry list
 
-type lib_objects =  (Names.identifier * obj) list
+type lib_objects =  (Names.Id.t * obj) list
 
 let module_kind is_type =
   if is_type then "module type" else "module"
@@ -37,8 +38,8 @@ let module_kind is_type =
 let iter_objects f i prefix =
   List.iter (fun (id,obj) -> f i (make_oname prefix id, obj))
 
-let load_objects = iter_objects load_object
-let open_objects = iter_objects open_object
+let load_objects i pr = iter_objects load_object i pr
+let open_objects i pr = iter_objects open_object i pr
 
 let subst_objects subst seg = 
   let subst_one = fun (id,obj as node) ->
@@ -46,7 +47,7 @@ let subst_objects subst seg =
       if obj' == obj then node else
 	(id, obj')
   in
-    list_smartmap subst_one seg
+    List.smartmap subst_one seg
 
 (*let load_and_subst_objects i prefix subst seg =
   List.rev (List.fold_left (fun seg (id,obj as node) ->
@@ -59,7 +60,7 @@ let classify_segment seg =
   let rec clean ((substl,keepl,anticipl) as acc) = function
     | (_,CompilingLibrary _) :: _ | [] -> acc
     | ((sp,kn),Leaf o) :: stk ->
-	let id = Names.id_of_label (Names.label kn) in
+	let id = Names.Label.to_id (Names.label kn) in
 	  (match classify_object o with
 	     | Dispose -> clean acc stk
 	     | Keep o' ->
@@ -90,7 +91,7 @@ let segment_of_objects prefix =
    sections, but on the contrary there are many constructions of section
    paths based on the library path. *)
 
-let initial_prefix = default_library,(Names.initial_path,Names.empty_dirpath)
+let initial_prefix = default_library,(Names.initial_path,Names.DirPath.empty)
 
 let lib_stk = ref ([] : library_segment)
 
@@ -103,15 +104,13 @@ let library_dp () =
    module path and relative section path *)
 let path_prefix = ref initial_prefix
 
-let sections_depth () =
-  List.length (Names.repr_dirpath (snd (snd !path_prefix)))
-
-let sections_are_opened () =
-  match Names.repr_dirpath (snd (snd !path_prefix)) with
-      [] -> false
-    | _ -> true
-
 let cwd () = fst !path_prefix
+let current_prefix () = snd !path_prefix
+let current_mp () = fst (snd !path_prefix)
+let current_sections () = snd (snd !path_prefix)
+
+let sections_depth () = List.length (Names.DirPath.repr (current_sections ()))
+let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ()))
 
 let cwd_except_section () =
   Libnames.pop_dirpath_n (sections_depth ()) (cwd ())
@@ -122,26 +121,14 @@ let current_dirpath sec =
 
 let make_path id = Libnames.make_path (cwd ()) id
 
-let make_path_except_section id = Libnames.make_path (cwd_except_section ()) id
-
-let path_of_include () =
-  let dir = Names.repr_dirpath (cwd ()) in
-  let new_dir = List.tl dir in
-  let id = List.hd dir in
-    Libnames.make_path (Names.make_dirpath new_dir) id
-
-let current_prefix () = snd !path_prefix
+let make_path_except_section id =
+  Libnames.make_path (cwd_except_section ()) id
 
 let make_kn id =
   let mp,dir = current_prefix () in
-    Names.make_kn mp dir (Names.label_of_id id)
-
-let make_con id =
-  let mp,dir = current_prefix () in
-    Names.make_con mp dir (Names.label_of_id id)
+  Names.make_kn mp dir (Names.Label.of_id id)
 
-
-let make_oname id = make_path id, make_kn id
+let make_oname id = Libnames.make_oname !path_prefix id
 
 let recalc_path_prefix () =
   let rec recalc = function
@@ -155,7 +142,7 @@ let recalc_path_prefix () =
 
 let pop_path_prefix () =
   let dir,(mp,sec) = !path_prefix in
-    path_prefix := fst (split_dirpath dir), (mp, fst (split_dirpath sec))
+  path_prefix := pop_dirpath dir, (mp, pop_dirpath sec)
 
 let find_entry_p p =
   let rec find = function
@@ -164,13 +151,6 @@ let find_entry_p p =
   in
   find !lib_stk
 
-let find_split_p p =
-  let rec find = function
-    | [] -> raise Not_found
-    | ent::l -> if p ent then ent,l else find l
-  in
-  find !lib_stk
-
 let split_lib_gen test =
   let rec collect after equal = function
     | hd::before when test hd -> collect after (hd::equal) before
@@ -194,16 +174,23 @@ let split_lib_gen test =
       | None -> error "no such entry"
       | Some r -> r
 
-let split_lib sp = split_lib_gen (fun x -> fst x = sp)
+let eq_object_name (fp1, kn1) (fp2, kn2) =
+  eq_full_path fp1 fp2 && Names.KerName.equal kn1 kn2
+
+let split_lib sp =
+  let is_sp (nsp, _) = eq_object_name sp nsp in
+  split_lib_gen is_sp
 
 let split_lib_at_opening sp =
-  let is_sp = function
-    | x,(OpenedSection _|OpenedModule _|CompilingLibrary _) -> x = sp
+  let is_sp (nsp, obj) = match obj with
+    | OpenedSection _ | OpenedModule _ | CompilingLibrary _ ->
+      eq_object_name nsp sp
     | _ -> false
   in
-  let a,s,b = split_lib_gen is_sp in
-  assert (List.tl s = []);
-  (a,List.hd s,b)
+  let a, s, b = split_lib_gen is_sp in
+  match s with
+  | [obj] -> (a, obj, b)
+  | _ -> assert false
 
 (* Adding operations. *)
 
@@ -212,16 +199,13 @@ let add_entry sp node =
 
 let anonymous_id =
   let n = ref 0 in
-  fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n))
+  fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n))
 
 let add_anonymous_entry node =
-  let id = anonymous_id () in
-  let name = make_oname id in
-  add_entry name node;
-  name
+  add_entry (make_oname (anonymous_id ())) node
 
 let add_leaf id obj =
-  if fst (current_prefix ()) = Names.initial_path then
+  if Names.ModPath.equal (current_mp ()) Names.initial_path then
     error ("No session module started (use -top dir)");
   let oname = make_oname id in
   cache_object (oname,obj);
@@ -250,7 +234,8 @@ let add_anonymous_leaf obj =
   add_entry oname (Leaf obj)
 
 let add_frozen_state () =
-  let _ = add_anonymous_entry (FrozenState (freeze_summaries())) in ()
+  add_anonymous_entry
+    (FrozenState (Summary.freeze_summaries ~marshallable:`No))
 
 (* Modules. *)
 
@@ -271,19 +256,17 @@ let current_mod_id () =
 
 
 let start_mod is_type export id mp fs =
-  let dir = add_dirpath_suffix (fst !path_prefix) id in
-  let prefix = dir,(mp,Names.empty_dirpath) in
-  let sp = make_path id in
-  let oname = sp, make_kn id in
+  let dir = add_dirpath_suffix (cwd ()) id in
+  let prefix = dir,(mp,Names.DirPath.empty) in
   let exists =
-    if is_type then Nametab.exists_cci sp else Nametab.exists_module dir
+    if is_type then Nametab.exists_cci (make_path id)
+    else Nametab.exists_module dir
   in
   if exists then
     errorlabstrm "open_module" (pr_id id ++ str " already exists");
-  add_entry oname (OpenedModule (is_type,export,prefix,fs));
+  add_entry (make_oname id) (OpenedModule (is_type,export,prefix,fs));
   path_prefix := prefix;
   prefix
-(*  add_frozen_state () must be called in declaremods *)
 
 let start_module = start_mod false
 let start_modtype = start_mod true None
@@ -297,7 +280,7 @@ let end_mod is_type =
   let oname,fs =
     try match find_entry_p is_opening_node with
       | oname,OpenedModule (ty,_,_,fs) ->
-	if ty = is_type then oname,fs
+	if ty == is_type then oname, fs
 	else error_still_opened (module_kind ty) oname
       | oname,OpenedSection _ -> error_still_opened "section" oname
       | _ -> assert false
@@ -308,31 +291,29 @@ let end_mod is_type =
   add_entry oname (ClosedModule (List.rev (mark::after)));
   let prefix = !path_prefix in
   recalc_path_prefix ();
-  (* add_frozen_state must be called after processing the module,
-     because we cannot recache interactive modules  *)
   (oname, prefix, fs, after)
 
 let end_module () = end_mod false
 let end_modtype () = end_mod true
 
-let contents_after = function
-  | None -> !lib_stk
-  | Some sp -> let (after,_,_) = split_lib sp in after
+let contents () = !lib_stk
+
+let contents_after sp = let (after,_,_) = split_lib sp in after
 
 (* Modules. *)
 
 (* TODO: use check_for_module ? *)
 let start_compilation s mp =
-  if !comp_name <> None then
+  if !comp_name != None then
     error "compilation unit is already started";
-  if snd (snd (!path_prefix)) <> Names.empty_dirpath then
+  if not (Names.DirPath.is_empty (current_sections ())) then
     error "some sections are already opened";
-  let prefix = s, (mp, Names.empty_dirpath) in
-  let _ = add_anonymous_entry (CompilingLibrary prefix) in
+  let prefix = s, (mp, Names.DirPath.empty) in
+  let () = add_anonymous_entry (CompilingLibrary prefix) in
   comp_name := Some s;
   path_prefix := prefix
 
-let end_compilation dir =
+let end_compilation_checks dir =
   let _ =
     try match snd (find_entry_p is_opening_node) with
       | OpenedSection _ -> error "There are some open sections."
@@ -347,42 +328,48 @@ let end_compilation dir =
     try match find_entry_p is_opening_lib with
       |	(oname, CompilingLibrary prefix) -> oname
       | _ -> assert false
-    with Not_found -> anomaly "No module declared"
+    with Not_found -> anomaly (Pp.str "No module declared")
   in
   let _ =
     match !comp_name with
-      | None -> anomaly "There should be a module name..."
+      | None -> anomaly (Pp.str "There should be a module name...")
       | Some m ->
-	  if m <> dir then anomaly
-	    ("The current open module has name "^ (Names.string_of_dirpath m) ^
-	       " and not " ^ (Names.string_of_dirpath m));
+	  if not (Names.DirPath.equal m dir) then anomaly
+	    (str "The current open module has name" ++ spc () ++ pr_dirpath m ++
+             spc () ++ str "and not" ++ spc () ++ pr_dirpath m);
   in
+  oname
+
+let end_compilation oname =
   let (after,mark,before) = split_lib_at_opening oname in
   comp_name := None;
   !path_prefix,after
 
 (* Returns true if we are inside an opened module or module type *)
 
-let is_module_gen which =
+let is_module_gen which check =
   let test = function
     | _, OpenedModule (ty,_,_,_) -> which ty
     | _ -> false
   in
   try
-    let _ = find_entry_p test in true
+    match find_entry_p test with
+    | _, OpenedModule (ty,_,_,_) -> check ty
+    | _ -> assert false
   with Not_found -> false
 
-let is_module_or_modtype () = is_module_gen (fun _ -> true)
-let is_modtype () = is_module_gen (fun b -> b)
-let is_module () = is_module_gen (fun b -> not b)
+let is_module_or_modtype () = is_module_gen (fun _ -> true) (fun _ -> true)
+let is_modtype () = is_module_gen (fun b -> b) (fun _ -> true)
+let is_modtype_strict () = is_module_gen (fun _ -> true) (fun b -> b)
+let is_module () = is_module_gen (fun b -> not b) (fun _ -> true)
 
 (* Returns the opening node of a given name *)
 let find_opening_node id =
   try
     let oname,entry = find_entry_p is_opening_node in
     let id' = basename (fst oname) in
-    if id <> id' then
-      error ("Last block to end has name "^(Names.string_of_id id')^".");
+    if not (Names.Id.equal id id') then
+      error ("Last block to end has name "^(Names.Id.to_string id')^".");
     entry
   with Not_found -> error "There is nothing to end."
 
@@ -394,29 +381,39 @@ let find_opening_node id =
    - the list of variables on which each inductive depends in this section
    - the list of substitution to do at section closing
 *)
-type binding_kind = Explicit | Implicit
 
-type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types
+type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types
+
 type variable_context = variable_info list
-type abstr_list = variable_context Names.Cmap.t * variable_context Names.Mindmap.t
+type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t
+		  
+type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t
 
 let sectab =
-  ref ([] : ((Names.identifier * binding_kind) list * Cooking.work_list * abstr_list) list)
+  Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind * 
+		Decl_kinds.polymorphic * Univ.universe_context_set) list *
+		        Opaqueproof.work_list * abstr_list) list)
+    ~name:"section-context"
 
 let add_section () =
-  sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),(Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab
+  sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty),
+                (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab
 
-let add_section_variable id impl =
+let add_section_variable id impl poly ctx =
   match !sectab with
     | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *)
     | (vars,repl,abs)::sl ->
-	sectab := ((id,impl)::vars,repl,abs)::sl
+	sectab := ((id,impl,poly,ctx)::vars,repl,abs)::sl
 
 let extract_hyps (secs,ohyps) =
   let rec aux = function
-    | ((id,impl)::idl,(id',b,t)::hyps) when id=id' -> (id',impl,b,t) :: aux (idl,hyps)
-    | (id::idl,hyps) -> aux (idl,hyps)
-    | [], _ -> []
+    | ((id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' ->
+      let l, r = aux (idl,hyps) in 
+	(id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r
+    | ((_,_,poly,ctx)::idl,hyps) -> 
+        let l, r = aux (idl,hyps) in
+          l, if poly then Univ.ContextSet.union r ctx else r
+    | [], _ -> [],Univ.ContextSet.empty
   in aux (secs,ohyps)
 
 let instance_from_variable_context sign =
@@ -426,23 +423,25 @@ let instance_from_variable_context sign =
     | [] -> [] in
   Array.of_list (inst_rec sign)
 
-let named_of_variable_context = List.map (fun (id,_,b,t) -> (id,b,t))
-
+let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx
+  
 let add_section_replacement f g hyps =
   match !sectab with
   | [] -> ()
   | (vars,exps,abs)::sl ->
-    let sechyps = extract_hyps (vars,hyps) in
+    let sechyps,ctx = extract_hyps (vars,hyps) in
+    let ctx = Univ.ContextSet.to_context ctx in
+    let subst, ctx = Univ.abstract_universes true ctx in
     let args = instance_from_variable_context (List.rev sechyps) in
-    sectab := (vars,f args exps,g sechyps abs)::sl
+    sectab := (vars,f (Univ.UContext.instance ctx,args) exps,g (sechyps,subst,ctx) abs)::sl
 
 let add_section_kn kn =
   let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in
-  add_section_replacement f f
+    add_section_replacement f f
 
-let add_section_constant kn =
+let add_section_constant is_projection kn =
   let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in
-  add_section_replacement f f
+    add_section_replacement f f
 
 let replacement_context () = pi2 (List.hd !sectab)
 
@@ -452,13 +451,11 @@ let section_segment_of_constant con =
 let section_segment_of_mutual_inductive kn =
   Names.Mindmap.find kn (snd (pi3 (List.hd !sectab)))
 
-let rec list_mem_assoc x = function
-  | [] -> raise Not_found
-  | (a,_)::l -> compare a x = 0 or list_mem_assoc x l
-
 let section_instance = function
   | VarRef id ->
-      if list_mem_assoc id (pi1 (List.hd !sectab)) then [||]
+      if List.exists (fun (id',_,_,_) -> Names.id_eq id id') 
+	(pi1 (List.hd !sectab))
+      then Univ.Instance.empty, [||]
       else raise Not_found
   | ConstRef con ->
       Names.Cmap.find con (fst (pi2 (List.hd !sectab)))
@@ -468,39 +465,27 @@ let section_instance = function
 let is_in_section ref =
   try ignore (section_instance ref); true with Not_found -> false
 
-let init_sectab () = sectab := []
-let freeze_sectab () = !sectab
-let unfreeze_sectab s = sectab := s
-
-let _ =
-  Summary.declare_summary "section-context"
-    { Summary.freeze_function = freeze_sectab;
-      Summary.unfreeze_function = unfreeze_sectab;
-      Summary.init_function = init_sectab }
+let full_replacement_context () = List.map pi2 !sectab
+let full_section_segment_of_constant con =
+  List.map (fun (vars,_,(x,_)) -> fun hyps ->
+    named_of_variable_context
+      (try pi1 (Names.Cmap.find con x)
+       with Not_found -> fst (extract_hyps (vars, hyps)))) !sectab
 
 (*************)
 (* Sections. *)
 
-(* XML output hooks *)
-let xml_open_section = ref (fun id -> ())
-let xml_close_section = ref (fun id -> ())
-
-let set_xml_open_section f = xml_open_section := f
-let set_xml_close_section f = xml_close_section := f
-
 let open_section id =
   let olddir,(mp,oldsec) = !path_prefix in
   let dir = add_dirpath_suffix olddir id in
   let prefix = dir, (mp, add_dirpath_suffix oldsec id) in
-  let name = make_path id, make_kn id (* this makes little sense however *) in
   if Nametab.exists_section dir then
     errorlabstrm "open_section" (pr_id id ++ str " already exists.");
-  let fs = freeze_summaries() in
-  add_entry name (OpenedSection (prefix, fs));
+  let fs = Summary.freeze_summaries ~marshallable:`No in
+  add_entry (make_oname id) (OpenedSection (prefix, fs));
   (*Pushed for the lifetime of the section: removed by unfrozing the summary*)
   Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix);
   path_prefix := prefix;
-  if !Flags.xml_export then !xml_open_section id;
   add_section ()
 
 
@@ -514,7 +499,7 @@ let discharge_item ((sp,_ as oname),e) =
   | FrozenState _ -> None
   | ClosedSection _ | ClosedModule _ -> None
   | OpenedSection _ | OpenedModule _ | CompilingLibrary _ ->
-      anomaly "discharge_item"
+      anomaly (Pp.str "discharge_item")
 
 let close_section () =
   let oname,fs =
@@ -529,92 +514,34 @@ let close_section () =
   let full_olddir = fst !path_prefix in
   pop_path_prefix ();
   add_entry oname (ClosedSection (List.rev (mark::secdecls)));
-  if !Flags.xml_export then !xml_close_section (basename (fst oname));
   let newdecls = List.map discharge_item secdecls in
   Summary.unfreeze_summaries fs;
   List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls;
-  Cooking.clear_cooking_sharing ();
   Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir)
 
-(*****************)
-(* Backtracking. *)
-
-let (inLabel : int -> obj), (outLabel : obj -> int) =
-  declare_object_full {(default_object "DOT") with
-				classify_function = (fun _ -> Dispose)}
-
-let recache_decl = function
-  | (sp, Leaf o) -> cache_object (sp,o)
-  | (_,OpenedSection _) -> add_section ()
-  | _ -> ()
-
-let recache_context ctx =
-  List.iter recache_decl ctx
-
-let is_frozen_state = function (_,FrozenState _) -> true | _ -> false
-
-let set_lib_stk new_lib_stk =
-  lib_stk := new_lib_stk;
-  recalc_path_prefix ();
-  let spf = match find_entry_p is_frozen_state with
-    | (sp, FrozenState f) -> unfreeze_summaries f; sp
-    | _ -> assert false
-  in
-  let (after,_,_) = split_lib spf in
-  try
-    recache_context after
-  with
-    | Not_found -> error "Tried to set environment to an incoherent state."
-
-let reset_to_gen test =
-  let (_,_,before) = split_lib_gen test in
-  set_lib_stk before
-
-let reset_to sp = reset_to_gen (fun x -> fst x = sp)
-
-let first_command_label = 1
-
-let mark_end_of_command, current_command_label, reset_command_label =
-  let n = ref (first_command_label-1) in
-  (fun () ->
-    match !lib_stk with
-        (_,Leaf o)::_ when object_tag o = "DOT" -> ()
-      | _ -> incr n;add_anonymous_leaf (inLabel !n)),
-  (fun () -> !n),
-  (fun x -> n:=x;add_anonymous_leaf (inLabel x))
-
-let is_label_n n x =
-  match x with
-    | (sp,Leaf o) when object_tag o = "DOT" && n = outLabel o -> true
-    | _ -> false
-
-(** Reset the label registered by [mark_end_of_command()] with number n,
-    which should be strictly in the past. *)
-
-let reset_label n =
-  if n >= current_command_label () then
-    error "Cannot backtrack to the current label or a future one";
-  reset_to_gen (is_label_n n);
-  (* forget state numbers after n only if reset succeeded *)
-  reset_command_label n
-
-(** Search the last label registered before defining [id] *)
-
-let label_before_name (loc,id) =
-  let found = ref false in
-  let search = function
-    | (_,Leaf o) when !found && object_tag o = "DOT" -> true
-    | (sp,_) -> (if id = snd (repr_path (fst sp)) then found := true); false
-  in
-  match find_entry_p search with
-    | (_,Leaf o) -> outLabel o
-    | _ -> raise Not_found
-
 (* State and initialization. *)
 
-type frozen = Names.dir_path option * library_segment
-
-let freeze () = (!comp_name, !lib_stk)
+type frozen = Names.DirPath.t option * library_segment
+
+let freeze ~marshallable =
+  match marshallable with
+  | `Shallow ->
+    (* TASSI: we should do something more sensible here *)
+    let lib_stk =
+      CList.map_filter (function
+        | _, Leaf _ -> None
+        | n, (CompilingLibrary _ as x) -> Some (n,x)
+        | n, OpenedModule (it,e,op,_) ->
+               Some(n,OpenedModule(it,e,op,Summary.empty_frozen))
+        | n, ClosedModule _ -> Some (n,ClosedModule [])
+        | n, OpenedSection (op, _) ->
+               Some(n,OpenedSection(op,Summary.empty_frozen))
+        | n, ClosedSection _ -> Some (n,ClosedSection [])
+        | _, FrozenState _ -> None)
+      !lib_stk in
+    !comp_name, lib_stk
+  | _ ->
+    !comp_name, !lib_stk
 
 let unfreeze (mn,stk) =
   comp_name := mn;
@@ -622,57 +549,49 @@ let unfreeze (mn,stk) =
   recalc_path_prefix ()
 
 let init () =
-  lib_stk := [];
-  add_frozen_state ();
-  comp_name := None;
-  path_prefix := initial_prefix;
-  init_summaries()
+  unfreeze (None,[]);
+  Summary.init_summaries ();
+  add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *)
 
 (* Misc *)
 
-let mp_of_global ref =
-  match ref with
-    | VarRef id -> fst (current_prefix ())
-    | ConstRef cst -> Names.con_modpath cst
-    | IndRef ind -> Names.ind_modpath ind
-    | ConstructRef constr -> Names.constr_modpath constr
-
-let rec dp_of_mp modp =
-  match modp with
-    | Names.MPfile dp -> dp
-    | Names.MPbound _ -> library_dp ()
-    | Names.MPdot (mp,_) -> dp_of_mp mp
-
-let rec split_mp mp =
-  match mp with
-    | Names.MPfile dp -> dp,  Names.empty_dirpath
-    | Names.MPdot (prfx, lbl) ->
-	let mprec, dprec = split_mp prfx in
-	  mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec))
-    | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in  library_dp(), Names.make_dirpath [id]
-
-let split_modpath mp =
-  let rec aux = function
-    | Names.MPfile dp -> dp, []
-    | Names.MPbound mbid ->
-	library_dp (), [Names.id_of_mbid mbid]
-    | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in
-			      (mp', Names.id_of_label l :: lab)
-  in
-  let (mp, l) = aux mp in
-    mp, l
-
-let library_part ref =
-  match ref with
-    | VarRef id -> library_dp ()
-    | _ -> dp_of_mp (mp_of_global ref)
+let mp_of_global = function
+  |VarRef id -> current_mp ()
+  |ConstRef cst -> Names.con_modpath cst
+  |IndRef ind -> Names.ind_modpath ind
+  |ConstructRef constr -> Names.constr_modpath constr
+
+let rec dp_of_mp = function
+  |Names.MPfile dp -> dp
+  |Names.MPbound _ -> library_dp ()
+  |Names.MPdot (mp,_) -> dp_of_mp mp
+
+let rec split_mp = function
+  |Names.MPfile dp -> dp, Names.DirPath.empty
+  |Names.MPdot (prfx, lbl) ->
+    let mprec, dprec = split_mp prfx in
+    mprec, Libnames.add_dirpath_suffix dprec (Names.Label.to_id lbl)
+  |Names.MPbound mbid ->
+    let (_,id,dp) = Names.MBId.repr mbid in
+    library_dp (), Names.DirPath.make [id]
+
+let rec split_modpath = function
+  |Names.MPfile dp -> dp, []
+  |Names.MPbound mbid -> library_dp (), [Names.MBId.to_id mbid]
+  |Names.MPdot (mp,l) ->
+    let (dp,ids) = split_modpath mp in
+    (dp, Names.Label.to_id l :: ids)
+
+let library_part = function
+  |VarRef id -> library_dp ()
+  |ref -> dp_of_mp (mp_of_global ref)
 
 let remove_section_part ref =
   let sp = Nametab.path_of_global ref in
   let dir,_ = repr_path sp in
   match ref with
   | VarRef id ->
-      anomaly "remove_section_part not supported on local variables"
+      anomaly (Pp.str "remove_section_part not supported on local variables")
   | _ ->
       if is_dirpath_prefix_of dir (cwd ()) then
         (* Not yet (fully) discharged *)
@@ -684,36 +603,30 @@ let remove_section_part ref =
 (************************)
 (* Discharging names *)
 
-let pop_kn kn =
-  let (mp,dir,l) = Names.repr_mind kn in
-  Names.make_mind mp (pop_dirpath dir) l
-
-let pop_con con =
-  let (mp,dir,l) = Names.repr_con con in
-  Names.make_con mp (pop_dirpath dir) l
-
 let con_defined_in_sec kn =
   let _,dir,_ = Names.repr_con kn in
-  dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
+  not (Names.DirPath.is_empty dir) &&
+  Names.DirPath.equal (pop_dirpath dir) (current_sections ())
 
 let defined_in_sec kn =
   let _,dir,_ = Names.repr_mind kn in
-  dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ())
+  not (Names.DirPath.is_empty dir) &&
+  Names.DirPath.equal (pop_dirpath dir) (current_sections ())
 
 let discharge_global = function
   | ConstRef kn when con_defined_in_sec kn ->
-      ConstRef (pop_con kn)
+      ConstRef (Globnames.pop_con kn)
   | IndRef (kn,i) when defined_in_sec kn ->
-      IndRef (pop_kn kn,i)
+      IndRef (Globnames.pop_kn kn,i)
   | ConstructRef ((kn,i),j) when defined_in_sec kn ->
-      ConstructRef ((pop_kn kn,i),j)
+      ConstructRef ((Globnames.pop_kn kn,i),j)
   | r -> r
 
 let discharge_kn kn =
-  if defined_in_sec kn then pop_kn kn else kn
+  if defined_in_sec kn then Globnames.pop_kn kn else kn
 
 let discharge_con cst =
-  if con_defined_in_sec cst then pop_con cst else cst
+  if con_defined_in_sec cst then Globnames.pop_con cst else cst
 
 let discharge_inductive (kn,i) =
   (discharge_kn kn,i)
diff --git a/library/lib.mli b/library/lib.mli
index d546d1ff..9c4d26c5 100644
--- a/library/lib.mli
+++ b/library/lib.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        *)
@@ -27,7 +27,7 @@ type node =
 
 and library_segment = (Libnames.object_name * node) list
 
-type lib_objects = (Names.identifier * Libobject.obj) list
+type lib_objects = (Names.Id.t * Libobject.obj) list
 
 (** {6 Object iteration functions. } *)
 
@@ -53,36 +53,38 @@ val segment_of_objects :
 (** Adding operations (which call the [cache] method, and getting the
   current list of operations (most recent ones coming first). *)
 
-val add_leaf : Names.identifier -> Libobject.obj -> Libnames.object_name
+val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name
 val add_anonymous_leaf : Libobject.obj -> unit
 
 (** this operation adds all objects with the same name and calls [load_object]
    for each of them *)
-val add_leaves : Names.identifier -> Libobject.obj list -> Libnames.object_name
+val add_leaves : Names.Id.t -> Libobject.obj list -> Libnames.object_name
 
 val add_frozen_state : unit -> unit
 
 (** {6 ... } *)
+
+(** The function [contents] gives access to the current entire segment *)
+
+val contents : unit -> library_segment
+
 (** The function [contents_after] returns the current library segment,
-  starting from a given section path. If not given, the entire segment
-  is returned. *)
+  starting from a given section path. *)
 
-val contents_after : Libnames.object_name option -> library_segment
+val contents_after : Libnames.object_name -> library_segment
 
 (** {6 Functions relative to current path } *)
 
 (** User-side names *)
-val cwd : unit -> Names.dir_path
-val cwd_except_section : unit -> Names.dir_path
-val current_dirpath : bool -> Names.dir_path (* false = except sections *)
-val make_path : Names.identifier -> Libnames.full_path
-val make_path_except_section : Names.identifier -> Libnames.full_path
-val path_of_include : unit -> Libnames.full_path
+val cwd : unit -> Names.DirPath.t
+val cwd_except_section : unit -> Names.DirPath.t
+val current_dirpath : bool -> Names.DirPath.t (* false = except sections *)
+val make_path : Names.Id.t -> Libnames.full_path
+val make_path_except_section : Names.Id.t -> Libnames.full_path
 
 (** Kernel-side names *)
-val current_prefix : unit -> Names.module_path * Names.dir_path
-val make_kn : Names.identifier -> Names.kernel_name
-val make_con : Names.identifier -> Names.constant
+val current_mp : unit -> Names.module_path
+val make_kn : Names.Id.t -> Names.kernel_name
 
 (** Are we inside an opened section *)
 val sections_are_opened : unit -> bool
@@ -91,11 +93,14 @@ val sections_depth : unit -> int
 (** Are we inside an opened module type *)
 val is_module_or_modtype : unit -> bool
 val is_modtype : unit -> bool
+(* [is_modtype_strict] checks not only if we are in a module type, but
+   if the latest module started is a module type.  *)
+val is_modtype_strict : unit -> bool
 val is_module : unit -> bool
 val current_mod_id : unit -> Names.module_ident
 
 (** Returns the opening node of a given name *)
-val find_opening_node : Names.identifier -> node
+val find_opening_node : Names.Id.t -> node
 
 (** {6 Modules and module types } *)
 
@@ -121,88 +126,68 @@ val end_modtype :
 
 (** {6 Compilation units } *)
 
-val start_compilation : Names.dir_path -> Names.module_path -> unit
-val end_compilation : Names.dir_path -> Libnames.object_prefix * library_segment
+val start_compilation : Names.DirPath.t -> Names.module_path -> unit
+val end_compilation_checks : Names.DirPath.t -> Libnames.object_name
+val end_compilation :
+  Libnames.object_name-> Libnames.object_prefix * library_segment
 
-(** The function [library_dp] returns the [dir_path] of the current
+(** The function [library_dp] returns the [DirPath.t] of the current
    compiling library (or [default_library]) *)
-val library_dp : unit -> Names.dir_path
+val library_dp : unit -> Names.DirPath.t
 
 (** Extract the library part of a name even if in a section *)
-val dp_of_mp : Names.module_path -> Names.dir_path
-val split_mp : Names.module_path -> Names.dir_path * Names.dir_path
-val split_modpath : Names.module_path -> Names.dir_path * Names.identifier list
-val library_part :  Libnames.global_reference -> Names.dir_path
-val remove_section_part : Libnames.global_reference -> Names.dir_path
+val dp_of_mp : Names.module_path -> Names.DirPath.t
+val split_mp : Names.module_path -> Names.DirPath.t * Names.DirPath.t
+val split_modpath : Names.module_path -> Names.DirPath.t * Names.Id.t list
+val library_part :  Globnames.global_reference -> Names.DirPath.t
+val remove_section_part : Globnames.global_reference -> Names.DirPath.t
 
 (** {6 Sections } *)
 
-val open_section : Names.identifier -> unit
+val open_section : Names.Id.t -> unit
 val close_section : unit -> unit
 
-(** {6 Backtracking } *)
-
-(** NB: The next commands are low-level ones, do not use them directly
-    otherwise the command history stack in [Backtrack] will be out-of-sync.
-    Also note that [reset_initial] is now [reset_label first_command_label] *)
-
-(** Adds a "dummy" entry in lib_stk with a unique new label number. *)
-val mark_end_of_command : unit -> unit
-
-(** Returns the current label number *)
-val current_command_label : unit -> int
-
-(** The first label number *)
-val first_command_label : int
-
-(** [reset_label n] resets [lib_stk] to the label n registered by
-   [mark_end_of_command()]. It forgets anything registered after
-   this label. The label should be strictly in the past. *)
-val reset_label : int -> unit
-
-(** search the label registered immediately before adding some definition *)
-val label_before_name : Names.identifier Util.located -> int
-
 (** {6 We can get and set the state of the operations (used in [States]). } *)
 
 type frozen
 
-val freeze : unit -> frozen
+val freeze : marshallable:Summary.marshallable -> frozen
 val unfreeze : frozen -> unit
 
 val init : unit -> unit
 
-(** XML output hooks *)
-val set_xml_open_section : (Names.identifier -> unit) -> unit
-val set_xml_close_section : (Names.identifier -> unit) -> unit
-
-type binding_kind = Explicit | Implicit
-
 (** {6 Section management for discharge } *)
-type variable_info = Names.identifier * binding_kind * Term.constr option * Term.types
-type variable_context = variable_info list
+type variable_info = Names.Id.t * Decl_kinds.binding_kind *
+    Term.constr option * Term.types
+type variable_context = variable_info list 
+type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t
 
-val instance_from_variable_context : variable_context -> Names.identifier array
-val named_of_variable_context : variable_context -> Sign.named_context
+val instance_from_variable_context : variable_context -> Names.Id.t array
+val named_of_variable_context : variable_context -> Context.named_context
 
-val section_segment_of_constant : Names.constant -> variable_context
-val section_segment_of_mutual_inductive: Names.mutual_inductive -> variable_context
+val section_segment_of_constant : Names.constant -> abstr_info
+val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info
 
-val section_instance : Libnames.global_reference -> Names.identifier array
-val is_in_section : Libnames.global_reference -> bool
+val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array
+val is_in_section : Globnames.global_reference -> bool
 
-val add_section_variable : Names.identifier -> binding_kind -> unit
+val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit
 
-val add_section_constant : Names.constant -> Sign.named_context -> unit
-val add_section_kn : Names.mutual_inductive -> Sign.named_context -> unit
-val replacement_context : unit ->
-  (Names.identifier array Names.Cmap.t * Names.identifier array Names.Mindmap.t)
+val add_section_constant : bool (* is_projection *) -> 
+  Names.constant -> Context.named_context -> unit
+val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit
+val replacement_context : unit -> Opaqueproof.work_list
 
 (** {6 Discharge: decrease the section level if in the current section } *)
 
 val discharge_kn :  Names.mutual_inductive -> Names.mutual_inductive
 val discharge_con : Names.constant -> Names.constant
-val discharge_global : Libnames.global_reference -> Libnames.global_reference
+val discharge_global : Globnames.global_reference -> Globnames.global_reference
 val discharge_inductive : Names.inductive -> Names.inductive
 
+(* discharging a constant in one go *)
+val full_replacement_context : unit -> Opaqueproof.work_list list
+val full_section_segment_of_constant :
+  Names.constant -> (Context.named_context -> Context.named_context) list
+
 
diff --git a/library/libnames.ml b/library/libnames.ml
index db97eae9..f2a9d041 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -1,214 +1,112 @@
 (************************************************************************)
 (*  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
-open Nameops
-open Term
-open Mod_subst
-
-(*s Global reference is a kernel side type for all references together *)
-type global_reference =
-  | VarRef of variable
-  | ConstRef of constant
-  | IndRef of inductive
-  | ConstructRef of constructor
-
-let isVarRef = function VarRef _ -> true | _ -> false
-let isConstRef = function ConstRef _ -> true | _ -> false
-let isIndRef = function IndRef _ -> true | _ -> false
-let isConstructRef = function ConstructRef _ -> true | _ -> false
-
-let eq_gr gr1 gr2 =
-  match gr1,gr2 with 
-    | ConstRef con1, ConstRef con2 -> eq_constant con1 con2
-    | IndRef kn1,IndRef kn2 -> eq_ind kn1 kn2
-    | ConstructRef kn1,ConstructRef kn2 -> eq_constructor kn1 kn2
-    | _,_ -> gr1=gr2
-
-let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef"
-let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef"
-let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef"
-let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef"
-
-let subst_constructor subst ((kn,i),j as ref) =
-  let kn' = subst_ind subst kn in
-    if kn==kn' then ref, mkConstruct ref
-    else ((kn',i),j), mkConstruct ((kn',i),j)
-
-let subst_global subst ref = match ref with
-  | VarRef var -> ref, mkVar var
-  | ConstRef kn ->
-     let kn',t = subst_con subst kn in
-      if kn==kn' then ref, mkConst kn else ConstRef kn', t
-  | IndRef (kn,i) ->
-      let kn' = subst_ind subst kn in
-      if kn==kn' then ref, mkInd (kn,i) else IndRef(kn',i), mkInd (kn',i)
-  | ConstructRef ((kn,i),j as c) ->
-      let c',t = subst_constructor subst c in
-	if c'==c then ref,t else ConstructRef c', t
-
-let canonical_gr = function
-  | ConstRef con -> ConstRef(constant_of_kn(canonical_con con))
-  | IndRef (kn,i) -> IndRef(mind_of_kn(canonical_mind kn),i)
-  | ConstructRef ((kn,i),j )-> ConstructRef((mind_of_kn(canonical_mind kn),i),j)
-  | VarRef id -> VarRef id
-
-let global_of_constr c = match kind_of_term c with
-  | Const sp -> ConstRef sp
-  | Ind ind_sp -> IndRef ind_sp
-  | Construct cstr_cp -> ConstructRef cstr_cp
-  | Var id -> VarRef id
-  |  _ -> raise Not_found
-
-let constr_of_global = function
-  | VarRef id -> mkVar id
-  | ConstRef sp -> mkConst sp
-  | ConstructRef sp -> mkConstruct sp
-  | IndRef sp -> mkInd sp
-
-let constr_of_reference = constr_of_global
-let reference_of_constr = global_of_constr
-
-let global_ord_gen fc fmi x y =
-  let ind_ord (indx,ix) (indy,iy) =
-    let c = Pervasives.compare ix iy in
-    if c = 0 then kn_ord (fmi indx) (fmi indy) else c
-  in
-  match x, y with
-    | ConstRef cx, ConstRef cy -> kn_ord (fc cx) (fc cy)
-    | IndRef indx, IndRef indy -> ind_ord indx indy
-    | ConstructRef (indx,jx), ConstructRef (indy,jy) ->
-      let c = Pervasives.compare jx jy in
-      if c = 0 then ind_ord indx indy else c
-    | _, _ -> Pervasives.compare x y
-
-let global_ord_can = global_ord_gen canonical_con canonical_mind
-let global_ord_user = global_ord_gen user_con user_mind
-
-(* By default, [global_reference] are ordered on their canonical part *)
-
-module RefOrdered = struct
-  type t = global_reference
-  let compare = global_ord_can
-end
-
-module RefOrdered_env = struct
-  type t = global_reference
-  let compare = global_ord_user
-end
-
-module Refset = Set.Make(RefOrdered)
-module Refmap = Map.Make(RefOrdered)
-
-(* Extended global references *)
-
-type syndef_name = kernel_name
-
-type extended_global_reference =
-  | TrueGlobal of global_reference
-  | SynDef of syndef_name
-
-(* We order [extended_global_reference] via their user part
-   (cf. pretty printer) *)
-
-module ExtRefOrdered = struct
-  type t = extended_global_reference
-  let compare x y =
-    match x, y with
-      | TrueGlobal rx, TrueGlobal ry -> global_ord_user rx ry
-      | SynDef knx, SynDef kny -> kn_ord knx kny
-      | _, _ -> Pervasives.compare x y
-end
 
 (**********************************************)
 
-let pr_dirpath sl = (str (string_of_dirpath sl))
+let pr_dirpath sl = (str (DirPath.to_string sl))
 
 (*s Operations on dirpaths *)
 
-(* Pop the last n module idents *)
-let pop_dirpath_n n dir =
-  make_dirpath (list_skipn n (repr_dirpath dir))
+let split_dirpath d = match DirPath.repr d with
+  | id :: l -> DirPath.make l, id
+  | _ -> failwith "split_dirpath"
 
-let pop_dirpath p = match repr_dirpath p with
-  | [] -> anomaly "dirpath_prefix: empty dirpath"
-  | _::l -> make_dirpath l
+let pop_dirpath p = match DirPath.repr p with
+  | _::l -> DirPath.make l
+  | [] -> failwith "pop_dirpath"
+
+(* Pop the last n module idents *)
+let pop_dirpath_n n dir = DirPath.make (List.skipn n (DirPath.repr dir))
 
 let is_dirpath_prefix_of d1 d2 =
-  list_prefix_of (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
+  List.prefix_of Id.equal
+    (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2))
 
 let chop_dirpath n d =
-  let d1,d2 = list_chop n (List.rev (repr_dirpath d)) in
-    make_dirpath (List.rev d1), make_dirpath (List.rev d2)
+  let d1,d2 = List.chop n (List.rev (DirPath.repr d)) in
+  DirPath.make (List.rev d1), DirPath.make (List.rev d2)
 
 let drop_dirpath_prefix d1 d2 =
-  let d = Util.list_drop_prefix (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) in
-    make_dirpath (List.rev d)
-
-let append_dirpath d1 d2 = make_dirpath (repr_dirpath d2 @ repr_dirpath d1)
+  let d =
+    List.drop_prefix Id.equal
+      (List.rev (DirPath.repr d1)) (List.rev (DirPath.repr d2))
+  in
+  DirPath.make (List.rev d)
 
-(* To know how qualified a name should be to be understood in the current env*)
-let add_dirpath_prefix id d = make_dirpath (repr_dirpath d @ [id])
+let append_dirpath d1 d2 = DirPath.make (DirPath.repr d2 @ DirPath.repr d1)
 
-let split_dirpath d =
-  let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l)
+let add_dirpath_prefix id d = DirPath.make (DirPath.repr d @ [id])
 
-let add_dirpath_suffix p id = make_dirpath (id :: repr_dirpath p)
+let add_dirpath_suffix p id = DirPath.make (id :: DirPath.repr p)
 
 (* parsing *)
 let parse_dir s =
   let len = String.length s in
   let rec decoupe_dirs dirs n =
-    if n = len && n > 0 then error (s ^ " is an invalid path.");
+    if Int.equal n len && n > 0 then error (s ^ " is an invalid path.");
     if n >= len then dirs else
     let pos =
       try
 	String.index_from s n '.'
       with Not_found -> len
     in
-    if pos = n then error (s ^ " is an invalid path.");
+    if Int.equal pos n then error (s ^ " is an invalid path.");
     let dir = String.sub s n (pos-n) in
-    decoupe_dirs ((id_of_string dir)::dirs) (pos+1)
+    decoupe_dirs ((Id.of_string dir)::dirs) (pos+1)
   in
     decoupe_dirs [] 0
 
 let dirpath_of_string s =
-  make_dirpath (if s = "" then [] else parse_dir s)
-
-let string_of_dirpath = Names.string_of_dirpath
+  let path = match s with
+  | "" -> []
+  | _ -> parse_dir s
+  in
+  DirPath.make path
 
+let string_of_dirpath = Names.DirPath.to_string
 
-module Dirset = Set.Make(struct type t = dir_path let compare = compare end)
-module Dirmap = Map.Make(struct type t = dir_path let compare = compare end)
+module Dirset = Set.Make(DirPath)
+module Dirmap = Map.Make(DirPath)
 
 (*s Section paths are absolute names *)
 
 type full_path = {
-  dirpath : dir_path ;
-  basename : identifier }
+  dirpath : DirPath.t ;
+  basename : Id.t }
+
+let dirpath sp = sp.dirpath
+let basename sp = sp.basename
 
 let make_path pa id = { dirpath = pa; basename = id }
 
 let repr_path { dirpath = pa; basename = id } = (pa,id)
 
+let eq_full_path p1 p2 =
+  Id.equal p1.basename p2.basename &&
+  DirPath.equal p1.dirpath p2.dirpath
+
 (* parsing and printing of section paths *)
 let string_of_path sp =
   let (sl,id) = repr_path sp in
-  if repr_dirpath sl = [] then string_of_id id
-  else (string_of_dirpath sl) ^ "." ^ (string_of_id id)
+  match DirPath.repr sl with
+  | [] -> Id.to_string id
+  | _ -> (DirPath.to_string sl) ^ "." ^ (Id.to_string id)
 
 let sp_ord sp1 sp2 =
   let (p1,id1) = repr_path sp1
   and (p2,id2) = repr_path sp2 in
-  let p_bit = compare p1 p2 in
-  if p_bit = 0 then id_ord id1 id2 else p_bit
+  let p_bit = DirPath.compare p1 p2 in
+  if Int.equal p_bit 0 then Id.compare id1 id2 else p_bit
 
 module SpOrdered =
   struct
@@ -218,9 +116,6 @@ module SpOrdered =
 
 module Spmap = Map.Make(SpOrdered)
 
-let dirpath sp = let (p,_) = repr_path sp in p
-let basename sp = let (_,id) = repr_path sp in id
-
 let path_of_string s =
   try
     let dir, id = split_dirpath (dirpath_of_string s) in
@@ -232,34 +127,8 @@ let pr_path sp = str (string_of_path sp)
 
 let restrict_path n sp =
   let dir, s = repr_path sp in
-  let dir' = list_firstn n (repr_dirpath dir) in
-  make_path (make_dirpath dir') s
-
-let encode_mind dir id = make_mind (MPfile dir) empty_dirpath (label_of_id id)
-
-let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id)
-
-let decode_mind kn =
-  let rec dir_of_mp = function
-    | MPfile dir -> repr_dirpath dir
-    | MPbound mbid -> 
-	let _,_,dp = repr_mbid mbid in
-	let id = id_of_mbid mbid in
-	  id::(repr_dirpath dp)
-    | MPdot(mp,l) -> (id_of_label l)::(dir_of_mp mp)
-  in
-  let mp,sec_dir,l = repr_mind kn in
-    if (repr_dirpath sec_dir) = [] then
-     (make_dirpath (dir_of_mp mp)),id_of_label l
-    else
-      anomaly "Section part should be empty!"
-
-let decode_con kn =
-  let mp,sec_dir,l = repr_con kn in
-    match mp,(repr_dirpath sec_dir) with
-	MPfile dir,[] -> (dir,id_of_label l)
-      | _ , [] -> anomaly "MPfile expected!"
-      | _ -> anomaly "Section part should be empty!"
+  let dir' = List.firstn n (DirPath.repr dir) in
+  make_path (DirPath.make dir') s
 
 (*s qualified names *)
 type qualid = full_path
@@ -267,44 +136,51 @@ type qualid = full_path
 let make_qualid = make_path
 let repr_qualid = repr_path
 
+let qualid_eq = eq_full_path
+
 let string_of_qualid = string_of_path
 let pr_qualid = pr_path
 
 let qualid_of_string = path_of_string
 
 let qualid_of_path sp = sp
-let qualid_of_ident id = make_qualid empty_dirpath id
+let qualid_of_ident id = make_qualid DirPath.empty id
 let qualid_of_dirpath dir =
   let (l,a) = split_dirpath dir in
   make_qualid l a
 
 type object_name = full_path * kernel_name
 
-type object_prefix = dir_path * (module_path * dir_path)
+type object_prefix = DirPath.t * (module_path * DirPath.t)
 
 let make_oname (dirpath,(mp,dir)) id =
-  make_path dirpath id, make_kn mp dir (label_of_id id)
+  make_path dirpath id, make_kn mp dir (Label.of_id id)
 
-(* to this type are mapped dir_path's in the nametab *)
+(* to this type are mapped DirPath.t's in the nametab *)
 type global_dir_reference =
   | DirOpenModule of object_prefix
   | DirOpenModtype of object_prefix
   | DirOpenSection of object_prefix
   | DirModule of object_prefix
-  | DirClosedSection of dir_path
+  | DirClosedSection of DirPath.t
       (* this won't last long I hope! *)
 
-(*  | ModRef mp ->
-      let mp' = subst_modpath subst mp in if mp==mp' then ref else
-          ModRef mp'
-  | ModTypeRef kn ->
-      let kn' = subst_kernel_name subst kn in if kn==kn' then ref else
-          ModTypeRef kn'
-*)
+let eq_op (d1, (mp1, p1)) (d2, (mp2, p2)) =
+  DirPath.equal d1 d2 &&
+  DirPath.equal p1 p2 &&
+  mp_eq mp1 mp2
+
+let eq_global_dir_reference r1 r2 = match r1, r2 with
+| DirOpenModule op1, DirOpenModule op2 -> eq_op op1 op2
+| DirOpenModtype op1, DirOpenModtype op2 -> eq_op op1 op2
+| DirOpenSection op1, DirOpenSection op2 -> eq_op op1 op2
+| DirModule op1, DirModule op2 -> eq_op op1 op2
+| DirClosedSection dp1, DirClosedSection dp2 -> DirPath.equal dp1 dp2
+| _ -> false
 
 type reference =
-  | Qualid of qualid located
-  | Ident of identifier located
+  | Qualid of qualid Loc.located
+  | Ident of Id.t Loc.located
 
 let qualid_of_reference = function
   | Qualid (loc,qid) -> loc, qid
@@ -312,31 +188,44 @@ let qualid_of_reference = function
 
 let string_of_reference = function
   | Qualid (loc,qid) -> string_of_qualid qid
-  | Ident (loc,id) -> string_of_id id
+  | Ident (loc,id) -> Id.to_string id
 
 let pr_reference = function
   | Qualid (_,qid) -> pr_qualid qid
-  | Ident (_,id) -> pr_id id
+  | Ident (_,id) -> str (Id.to_string id)
 
 let loc_of_reference = function
   | Qualid (loc,qid) -> loc
   | Ident (loc,id) -> loc
 
-(* popping one level of section in global names *)
-
-let pop_con con =
-  let (mp,dir,l) = repr_con con in
-  Names.make_con mp (pop_dirpath dir) l
-
-let pop_kn kn =
-  let (mp,dir,l) = repr_mind kn in
-  Names.make_mind mp (pop_dirpath dir) l
-
-let pop_global_reference = function
-  | ConstRef con -> ConstRef (pop_con con)
-  | IndRef (kn,i) -> IndRef (pop_kn kn,i)
-  | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j)
-  | VarRef id -> anomaly "VarRef not poppable"
+let eq_reference r1 r2 = match r1, r2 with
+| Qualid (_, q1), Qualid (_, q2) -> qualid_eq q1 q2
+| Ident (_, id1), Ident (_, id2) -> Id.equal id1 id2
+| _ -> false
+
+let join_reference ns r =
+  match ns , r with
+    Qualid (_, q1), Qualid (loc, q2) ->
+      let (dp1,id1) = repr_qualid q1 in
+      let (dp2,id2) = repr_qualid q2 in
+      Qualid (loc,
+	      make_qualid
+		(append_dirpath (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1))) dp2)
+		id2)
+  | Qualid (_, q1), Ident (loc, id2) ->
+    let (dp1,id1) = repr_qualid q1 in
+    Qualid (loc,
+	    make_qualid
+	      (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1)))
+	      id2)
+  | Ident (_, id1), Qualid (loc, q2) ->
+    let (dp2,id2) = repr_qualid q2 in
+    Qualid (loc, make_qualid
+      (append_dirpath (dirpath_of_string (Names.Id.to_string id1)) dp2)
+      id2)
+  | Ident (_, id1), Ident (loc, id2) ->
+    Qualid (loc, make_qualid
+      (dirpath_of_string (Names.Id.to_string id1)) id2)
 
 (* Deprecated synonyms *)
 
diff --git a/library/libnames.mli b/library/libnames.mli
index 8d026f42..3b5feb94 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -1,115 +1,57 @@
 (************************************************************************)
 (*  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 Pp
+open Loc
 open Names
-open Term
-open Mod_subst
-
-(** {6 Global reference is a kernel side type for all references together } *)
-type global_reference =
-  | VarRef of variable
-  | ConstRef of constant
-  | IndRef of inductive
-  | ConstructRef of constructor
-
-val isVarRef : global_reference -> bool
-val isConstRef : global_reference -> bool
-val isIndRef : global_reference -> bool
-val isConstructRef : global_reference -> bool
-
-val eq_gr : global_reference -> global_reference -> bool
-val canonical_gr : global_reference -> global_reference
-
-val destVarRef : global_reference -> variable
-val destConstRef : global_reference -> constant
-val destIndRef : global_reference -> inductive
-val destConstructRef : global_reference -> constructor
-
-
-val subst_constructor : substitution -> constructor -> constructor * constr
-val subst_global : substitution -> global_reference -> global_reference * constr
-
-(** Turn a global reference into a construction *)
-val constr_of_global : global_reference -> constr
-
-(** Turn a construction denoting a global reference into a global reference;
-   raise [Not_found] if not a global reference *)
-val global_of_constr : constr -> global_reference
-
-(** Obsolete synonyms for constr_of_global and global_of_constr *)
-val constr_of_reference : global_reference -> constr
-val reference_of_constr : constr -> global_reference
-
-module RefOrdered : sig
-  type t = global_reference
-  val compare : global_reference -> global_reference -> int
-end
-
-module RefOrdered_env : sig
-  type t = global_reference
-  val compare : global_reference -> global_reference -> int
-end
-
-module Refset : Set.S with type elt = global_reference
-module Refmap : Map.S with type key = global_reference
-
-(** {6 Extended global references } *)
-
-type syndef_name = kernel_name
-
-type extended_global_reference =
-  | TrueGlobal of global_reference
-  | SynDef of syndef_name
-
-module ExtRefOrdered : sig
-  type t = extended_global_reference
-  val compare : t -> t -> int
-end
 
 (** {6 Dirpaths } *)
-val pr_dirpath : dir_path -> Pp.std_ppcmds
+(** FIXME: ought to be in Names.dir_path *)
 
-val dirpath_of_string : string -> dir_path
-val string_of_dirpath : dir_path -> string
+val pr_dirpath : DirPath.t -> Pp.std_ppcmds
 
-(** Pop the suffix of a [dir_path] *)
-val pop_dirpath : dir_path -> dir_path
+val dirpath_of_string : string -> DirPath.t
+val string_of_dirpath : DirPath.t -> string
+
+(** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *)
+val pop_dirpath : DirPath.t -> DirPath.t
 
 (** Pop the suffix n times *)
-val pop_dirpath_n : int -> dir_path -> dir_path
+val pop_dirpath_n : int -> DirPath.t -> DirPath.t
 
-(** Give the immediate prefix and basename of a [dir_path] *)
-val split_dirpath : dir_path -> dir_path * identifier
+(** Immediate prefix and basename of a [DirPath.t]. May raise [Failure] *)
+val split_dirpath : DirPath.t -> DirPath.t * Id.t
 
-val add_dirpath_suffix : dir_path -> module_ident -> dir_path
-val add_dirpath_prefix : module_ident -> dir_path -> dir_path
+val add_dirpath_suffix : DirPath.t -> module_ident -> DirPath.t
+val add_dirpath_prefix : module_ident -> DirPath.t -> DirPath.t
 
-val chop_dirpath : int -> dir_path -> dir_path * dir_path
-val append_dirpath : dir_path -> dir_path -> dir_path
+val chop_dirpath : int -> DirPath.t -> DirPath.t * DirPath.t
+val append_dirpath : DirPath.t -> DirPath.t -> DirPath.t
 
-val drop_dirpath_prefix : dir_path -> dir_path -> dir_path
-val is_dirpath_prefix_of : dir_path -> dir_path -> bool
+val drop_dirpath_prefix : DirPath.t -> DirPath.t -> DirPath.t
+val is_dirpath_prefix_of : DirPath.t -> DirPath.t -> bool
 
-module Dirset : Set.S with type elt = dir_path
-module Dirmap : Map.S with type key = dir_path
+module Dirset : Set.S with type elt = DirPath.t
+module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset
 
 (** {6 Full paths are {e absolute} paths of declarations } *)
 type full_path
 
+val eq_full_path : full_path -> full_path -> bool
+
 (** Constructors of [full_path] *)
-val make_path : dir_path -> identifier -> full_path
+val make_path : DirPath.t -> Id.t -> full_path
 
 (** Destructors of [full_path] *)
-val repr_path : full_path -> dir_path * identifier
-val dirpath : full_path -> dir_path
-val basename : full_path -> identifier
+val repr_path : full_path -> DirPath.t * Id.t
+val dirpath : full_path -> DirPath.t
+val basename : full_path -> Id.t
 
 (** Parsing and printing of section path as ["coq_root.module.id"] *)
 val path_of_string : string -> full_path
@@ -120,14 +62,6 @@ module Spmap  : Map.S with type key = full_path
 
 val restrict_path : int -> full_path -> full_path
 
-(** {6 Temporary function to brutally form kernel names from section paths } *)
-
-val encode_mind : dir_path -> identifier -> mutual_inductive
-val decode_mind : mutual_inductive -> dir_path * identifier
-val encode_con : dir_path -> identifier -> constant
-val decode_con : constant -> dir_path * identifier
-
-
 (** {6 ... } *)
 (** A [qualid] is a partially qualified ident; it includes fully
     qualified names (= absolute names) and all intermediate partial
@@ -136,19 +70,21 @@ val decode_con : constant -> dir_path * identifier
 
 type qualid
 
-val make_qualid : dir_path -> identifier -> qualid
-val repr_qualid : qualid -> dir_path * identifier
+val make_qualid : DirPath.t -> Id.t -> qualid
+val repr_qualid : qualid -> DirPath.t * Id.t
+
+val qualid_eq : qualid -> qualid -> bool
 
 val pr_qualid : qualid -> std_ppcmds
 val string_of_qualid : qualid -> string
 val qualid_of_string : string -> qualid
 
-(** Turns an absolute name, a dirpath, or an identifier into a
+(** Turns an absolute name, a dirpath, or an Id.t into a
    qualified name denoting the same name *)
 
 val qualid_of_path : full_path -> qualid
-val qualid_of_dirpath : dir_path -> qualid
-val qualid_of_ident : identifier -> qualid
+val qualid_of_dirpath : DirPath.t -> qualid
+val qualid_of_ident : Id.t -> qualid
 
 (** Both names are passed to objects: a "semantic" [kernel_name], which
    can be substituted and a "syntactic" [full_path] which can be printed
@@ -156,19 +92,24 @@ val qualid_of_ident : identifier -> qualid
 
 type object_name = full_path * kernel_name
 
-type object_prefix = dir_path * (module_path * dir_path)
+type object_prefix = DirPath.t * (module_path * DirPath.t)
+
+val eq_op : object_prefix -> object_prefix -> bool
 
-val make_oname : object_prefix -> identifier -> object_name
+val make_oname : object_prefix -> Id.t -> object_name
 
-(** to this type are mapped [dir_path]'s in the nametab *)
+(** to this type are mapped [DirPath.t]'s in the nametab *)
 type global_dir_reference =
   | DirOpenModule of object_prefix
   | DirOpenModtype of object_prefix
   | DirOpenSection of object_prefix
   | DirModule of object_prefix
-  | DirClosedSection of dir_path
+  | DirClosedSection of DirPath.t
       (** this won't last long I hope! *)
 
+val eq_global_dir_reference : 
+  global_dir_reference -> global_dir_reference -> bool
+
 (** {6 ... } *)
 (** A [reference] is the user-level notion of name. It denotes either a
     global name (referred either by a qualified name or by a single
@@ -176,20 +117,16 @@ type global_dir_reference =
 
 type reference =
   | Qualid of qualid located
-  | Ident of identifier located
+  | Ident of Id.t located
 
+val eq_reference : reference -> reference -> bool
 val qualid_of_reference : reference -> qualid located
 val string_of_reference : reference -> string
 val pr_reference : reference -> std_ppcmds
-val loc_of_reference : reference -> loc
-
-(** {6 Popping one level of section in global names } *)
-
-val pop_con : constant -> constant
-val pop_kn : mutual_inductive-> mutual_inductive
-val pop_global_reference : global_reference -> global_reference
+val loc_of_reference : reference -> Loc.t
+val join_reference : reference -> reference -> reference
 
 (** Deprecated synonyms *)
 
-val make_short_qualid : identifier -> qualid (** = qualid_of_ident *)
+val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *)
 val qualid_of_sp : full_path -> qualid (** = qualid_of_path *)
diff --git a/library/libobject.ml b/library/libobject.ml
index ee1c94b9..5f2a2127 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -1,15 +1,12 @@
 (************************************************************************)
 (*  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 Util
-open Names
 open Libnames
-open Mod_subst
 
 (* The relax flag is used to make it possible to load files while ignoring
    failures to incorporate some objects.  This can be useful when one
@@ -32,11 +29,11 @@ type 'a object_declaration = {
   load_function : int -> object_name * 'a -> unit;
   open_function : int -> object_name * 'a -> unit;
   classify_function : 'a -> 'a substitutivity;
-  subst_function :  substitution * 'a -> 'a;
+  subst_function : Mod_subst.substitution * 'a -> 'a;
   discharge_function : object_name * 'a -> 'a option;
   rebuild_function : 'a -> 'a }
 
-let yell s = anomaly s
+let yell s = Errors.anomaly (Pp.str s)
 
 let default_object s = {
   object_name = s;
@@ -69,12 +66,13 @@ type dynamic_object_declaration = {
   dyn_cache_function : object_name * obj -> unit;
   dyn_load_function : int -> object_name * obj -> unit;
   dyn_open_function : int -> object_name * obj -> unit;
-  dyn_subst_function : substitution * obj -> obj;
+  dyn_subst_function : Mod_subst.substitution * obj -> obj;
   dyn_classify_function : obj -> obj substitutivity;
   dyn_discharge_function : object_name * obj -> obj option;
   dyn_rebuild_function : obj -> obj }
 
-let object_tag lobj = Dyn.tag lobj
+let object_tag = Dyn.tag
+let object_has_tag = Dyn.has_tag
 
 let cache_tab =
   (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t)
@@ -82,36 +80,18 @@ let cache_tab =
 let declare_object_full odecl =
   let na = odecl.object_name in
   let (infun,outfun) = Dyn.create na in
-  let cacher (oname,lobj) =
-    if Dyn.tag lobj = na then odecl.cache_function (oname,outfun lobj)
-    else anomaly "somehow we got the wrong dynamic object in the cachefun"
-  and loader i (oname,lobj) =
-    if Dyn.tag lobj = na then odecl.load_function i (oname,outfun lobj)
-    else anomaly "somehow we got the wrong dynamic object in the loadfun"
-  and opener i (oname,lobj) =
-    if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj)
-    else anomaly "somehow we got the wrong dynamic object in the openfun"
-  and substituter (sub,lobj) = 
-    if Dyn.tag lobj = na then 
-      infun (odecl.subst_function (sub,outfun lobj))
-    else anomaly "somehow we got the wrong dynamic object in the substfun"
-  and classifier lobj =
-    if Dyn.tag lobj = na then
-      match odecl.classify_function (outfun lobj) with
-	| Dispose -> Dispose
-	| Substitute obj -> Substitute (infun obj)
-	| Keep obj -> Keep (infun obj)
-	| Anticipate (obj) -> Anticipate (infun obj)
-    else
-      anomaly "somehow we got the wrong dynamic object in the classifyfun"
+  let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj)
+  and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj)
+  and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj)
+  and substituter (sub,lobj) = infun (odecl.subst_function (sub,outfun lobj))
+  and classifier lobj = match odecl.classify_function (outfun lobj) with
+  | Dispose -> Dispose
+  | Substitute obj -> Substitute (infun obj)
+  | Keep obj -> Keep (infun obj)
+  | Anticipate (obj) -> Anticipate (infun obj)
   and discharge (oname,lobj) =
-    if Dyn.tag lobj = na then
-      Option.map infun (odecl.discharge_function (oname,outfun lobj))
-    else
-      anomaly "somehow we got the wrong dynamic object in the dischargefun"
-  and rebuild lobj =
-    if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj))
-    else anomaly "somehow we got the wrong dynamic object in the rebuildfun"
+    Option.map infun (odecl.discharge_function (oname,outfun lobj))
+  and rebuild lobj = infun (odecl.rebuild_function (outfun lobj))
   in
   Hashtbl.add cache_tab na { dyn_cache_function = cacher;
 			     dyn_load_function = loader;
diff --git a/library/libobject.mli b/library/libobject.mli
index 9e41b7fa..09938189 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  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 Libnames
 open Mod_subst
 
@@ -45,7 +44,9 @@ open Mod_subst
 
    * a substitution function, performing the substitution;
      this function should be declared for substitutive objects
-     only (see above)
+     only (see above). NB: the substitution might now be delayed
+     instead of happening at module creation, so this function
+     should _not_ depend on the current environment
 
    * a discharge function, that is applied at section closing time to
      collect the data necessary to rebuild the discharged form of the
@@ -98,6 +99,7 @@ val declare_object :
   'a object_declaration -> ('a -> obj)
 
 val object_tag : obj -> string
+val object_has_tag : obj -> string -> bool
 
 val cache_object : object_name * obj -> unit
 val load_object : int -> object_name * obj -> unit
diff --git a/library/library.ml b/library/library.ml
index 681c55c7..b078e2c4 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -1,182 +1,62 @@
 (************************************************************************)
 (*  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
 open Libnames
 open Nameops
-open Safe_typing
 open Libobject
 open Lib
-open Nametab
-
-(*************************************************************************)
-(*s Load path. Mapping from physical to logical paths etc.*)
-
-type logical_path = dir_path
-
-let load_paths = ref ([] : (System.physical_path * logical_path * bool) list)
-
-let get_load_paths () = List.map pi1 !load_paths
-
-let find_logical_path phys_dir =
-  let phys_dir = System.canonical_path_name phys_dir in
-  match List.filter (fun (p,d,_) -> p = phys_dir) !load_paths with
-  | [_,dir,_] -> dir
-  | [] -> Nameops.default_root_prefix
-  | l -> anomaly ("Two logical paths are associated to "^phys_dir)
-
-let is_in_load_paths phys_dir =
-  let dir = System.canonical_path_name phys_dir in
-  let lp = get_load_paths () in
-  let check_p = fun p -> (String.compare dir p) == 0 in
-    List.exists check_p lp
-
-let remove_load_path dir =
-  load_paths := List.filter (fun (p,d,_) -> p <> dir) !load_paths
-
-let add_load_path isroot (phys_path,coq_path) =
-  let phys_path = System.canonical_path_name phys_path in
-    match List.filter (fun (p,d,_) -> p = phys_path) !load_paths with
-      | [_,dir,_] ->
-	  if coq_path <> dir
-            (* If this is not the default -I . to coqtop *)
-            && not
-            (phys_path = System.canonical_path_name Filename.current_dir_name
-		&& coq_path = Nameops.default_root_prefix)
-	  then
-	    begin
-              (* Assume the user is concerned by library naming *)
-	      if dir <> Nameops.default_root_prefix then
-		Flags.if_warn msg_warning
-		  (str phys_path ++ strbrk " was previously bound to " ++
-		   pr_dirpath dir ++ strbrk "; it is remapped to " ++
-		   pr_dirpath coq_path);
-	      remove_load_path phys_path;
-	      load_paths := (phys_path,coq_path,isroot) :: !load_paths;
-	    end
-      | [] ->
-	  load_paths := (phys_path,coq_path,isroot) :: !load_paths;
-      | _ -> anomaly ("Two logical paths are associated to "^phys_path)
-
-let extend_path_with_dirpath p dir =
-  List.fold_left Filename.concat p
-    (List.map string_of_id (List.rev (repr_dirpath dir)))
-
-let root_paths_matching_dir_path dir =
-  let rec aux = function
-  | [] -> []
-  | (p,d,true) :: l when is_dirpath_prefix_of d dir ->
-      let suffix = drop_dirpath_prefix d dir in
-      extend_path_with_dirpath p suffix :: aux l
-  | _ :: l -> aux l in
-  aux !load_paths
-
-(* Root p is bound to A.B.C.D and we require file C.D.E.F *)
-(* We may mean A.B.C.D.E.F, or A.B.C.D.C.D.E.F *)
-
-(* Root p is bound to A.B.C.C and we require file C.C.E.F *)
-(* We may mean A.B.C.C.E.F, or A.B.C.C.C.E.F, or A.B.C.C.C.C.E.F *)
-
-let intersections d1 d2 =
-  let rec aux d1 =
-    if d1 = empty_dirpath then [d2] else
-      let rest = aux (snd (chop_dirpath 1 d1)) in
-      if is_dirpath_prefix_of d1 d2 then drop_dirpath_prefix d1 d2 :: rest
-      else rest in
-  aux d1
-
-let loadpaths_matching_dir_path dir =
-  let rec aux = function
-  | [] -> []
-  | (p,d,true) :: l ->
-      let inters = intersections d dir in
-      List.map (fun tl -> (extend_path_with_dirpath p tl,append_dirpath d tl))
-	inters @
-	aux l
-  | (p,d,_) :: l ->
-      (extend_path_with_dirpath p dir,append_dirpath d dir) :: aux l in
-  aux !load_paths
-
-let get_full_load_paths () = List.map (fun (a,b,c) -> (a,b)) !load_paths
 
 (************************************************************************)
 (*s Modules on disk contain the following informations (after the magic
     number, and before the digest). *)
 
-type compilation_unit_name = dir_path
+type compilation_unit_name = DirPath.t
 
 type library_disk = {
   md_name : compilation_unit_name;
-  md_compiled : LightenLibrary.lightened_compiled_library;
+  md_compiled : Safe_typing.compiled_library;
   md_objects : Declaremods.library_objects;
-  md_deps : (compilation_unit_name * Digest.t) list;
-  md_imports : compilation_unit_name list }
+  md_deps : (compilation_unit_name * Safe_typing.vodigest) array;
+  md_imports : compilation_unit_name array }
 
 (*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_compiled : compiled_library;
+  library_compiled : Safe_typing.compiled_library;
   library_objects : Declaremods.library_objects;
-  library_deps : (compilation_unit_name * Digest.t) list;
-  library_imports : compilation_unit_name list;
-  library_digest : Digest.t }
-
-module LibraryOrdered =
-  struct
-    type t = dir_path
-    let compare d1 d2 =
-      Pervasives.compare
-        (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2))
-  end
+  library_deps : (compilation_unit_name * Safe_typing.vodigest) array;
+  library_imports : compilation_unit_name array;
+  library_digests : Safe_typing.vodigest;
+  library_extra_univs : Univ.universe_context_set;
+}
 
+module LibraryOrdered = DirPath
 module LibraryMap = Map.Make(LibraryOrdered)
 module LibraryFilenameMap = Map.Make(LibraryOrdered)
 
 (* This is a map from names to loaded libraries *)
-let libraries_table = ref LibraryMap.empty
+let libraries_table = Summary.ref LibraryMap.empty ~name:"LIBRARY"
 
 (* This is the map of loaded libraries filename *)
 (* (not synchronized so as not to be caught in the states on disk) *)
 let libraries_filename_table = ref LibraryFilenameMap.empty
 
 (* These are the _ordered_ sets of loaded, imported and exported libraries *)
-let libraries_loaded_list = ref []
-let libraries_imports_list = ref []
-let libraries_exports_list = ref []
-
-let freeze () =
-  !libraries_table,
-  !libraries_loaded_list,
-  !libraries_imports_list,
-  !libraries_exports_list
-
-let unfreeze (mt,mo,mi,me) =
-  libraries_table := mt;
-  libraries_loaded_list := mo;
-  libraries_imports_list := mi;
-  libraries_exports_list := me
-
-let init () =
-  libraries_table := LibraryMap.empty;
-  libraries_loaded_list := [];
-  libraries_imports_list := [];
-  libraries_exports_list := []
-
-let _ =
-  Summary.declare_summary "MODULES"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD"
+let libraries_imports_list = Summary.ref [] ~name:"LIBRARY-IMPORT"
+let libraries_exports_list = Summary.ref [] ~name:"LIBRARY-EXPORT"
 
 (* various requests to the tables *)
 
@@ -186,7 +66,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 register_library_filename dir f =
   (* Not synchronized: overwrite the previous binding if one existed *)
@@ -209,7 +89,7 @@ let library_is_loaded dir =
   with Not_found -> false
 
 let library_is_opened dir =
-  List.exists (fun m -> m.library_name = dir) !libraries_imports_list
+  List.exists (fun m -> DirPath.equal m.library_name dir) !libraries_imports_list
 
 let loaded_libraries () =
   List.map (fun m -> m.library_name) !libraries_loaded_list
@@ -221,9 +101,17 @@ let opened_libraries () =
      be performed first, thus the libraries_loaded_list ... *)
 
 let register_loaded_library m =
+  let link m =
+    let dirname = Filename.dirname (library_full_filename m.library_name) in
+    let prefix = Nativecode.mod_uid_of_dirpath m.library_name ^ "." in
+    let f = prefix ^ "cmo" in
+    let f = Dynlink.adapt_filename f in
+    if not !Flags.no_native_compiler then
+      Nativelib.link_library ~prefix ~dirname ~basename:f
+  in
   let rec aux = function
-    | [] -> [m]
-    | m'::_ as l when m'.library_name = m.library_name -> l
+    | [] -> link m; [m]
+    | m'::_ as l when DirPath.equal m'.library_name m.library_name -> l
     | m'::l' -> m' :: aux l' in
   libraries_loaded_list := aux !libraries_loaded_list;
   libraries_table := LibraryMap.add m.library_name m !libraries_table
@@ -237,7 +125,7 @@ let register_loaded_library m =
 let rec remember_last_of_each l m =
   match l with
   | [] -> [m]
-  | m'::l' when m'.library_name = m.library_name -> remember_last_of_each l' m
+  | m'::l' when DirPath.equal m'.library_name m.library_name -> remember_last_of_each l' m
   | m'::l' -> m' :: remember_last_of_each l' m
 
 let register_open_library export m =
@@ -251,14 +139,14 @@ let register_open_library export m =
 (* [open_library export explicit m] opens library [m] if not already
    opened _or_ if explicitly asked to be (re)opened *)
 
-let eq_lib_name m1 m2 = m1.library_name = m2.library_name
+let eq_lib_name m1 m2 = DirPath.equal m1.library_name m2.library_name
 
 let open_library export explicit_libs m =
   if
     (* Only libraries indirectly to open are not reopen *)
     (* Libraries explicitly mentionned by the user are always reopen *)
     List.exists (eq_lib_name m) explicit_libs
-    or not (library_is_opened m.library_name)
+    || not (library_is_opened m.library_name)
   then begin
     register_open_library export m;
     Declaremods.really_import_module (MPfile m.library_name)
@@ -275,7 +163,7 @@ let open_libraries export modl =
     List.fold_left
       (fun l m ->
          let subimport =
-           List.fold_left
+           Array.fold_left
              (fun l m -> remember_last_of_each l (try_find_library m))
              l m.library_imports
          in remember_last_of_each subimport m)
@@ -287,7 +175,7 @@ let open_libraries export modl =
 (* import and export  -  synchronous operations*)
 
 let open_import i (_,(dir,export)) =
-  if i=1 then
+  if Int.equal i 1 then
     (* even if the library is already imported, we re-import it *)
     (* if not (library_is_opened dir) then *)
       open_libraries export [try_find_library dir]
@@ -300,7 +188,7 @@ let subst_import (_,o) = o
 let classify_import (_,export as obj) =
   if export then Substitute obj else Dispose
 
-let in_import : dir_path * bool -> obj =
+let in_import : DirPath.t * bool -> obj =
   declare_object {(default_object "IMPORT LIBRARY") with
        cache_function = cache_import;
        open_function = open_import;
@@ -314,7 +202,7 @@ let in_import : dir_path * bool -> obj =
 (*s Loading from disk to cache (preparation phase) *)
 
 let (raw_extern_library, raw_intern_library) =
-  System.raw_extern_intern Coq_config.vo_magic_number ".vo"
+  System.raw_extern_intern Coq_config.vo_magic_number
 
 (************************************************************************)
 (*s Locate absolute or partially qualified library names in the path *)
@@ -326,130 +214,233 @@ type library_location = LibLoaded | LibInPath
 let locate_absolute_library dir =
   (* Search in loadpath *)
   let pref, base = split_dirpath dir in
-  let loadpath = root_paths_matching_dir_path pref in
-  if loadpath = [] then raise LibUnmappedDir;
-  try
-    let name = (string_of_id base)^".vo" in
-    let _, file = System.where_in_path ~warn:false loadpath name in
-    (dir, file)
-  with Not_found ->
-  (* Last chance, removed from the file system but still in memory *)
-  if library_is_loaded dir then
-    (dir, library_full_filename dir)
-  else
-    raise LibNotFound
+  let loadpath = Loadpath.expand_root_path pref in
+  let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in
+  let find ext =
+    try
+      let name = Id.to_string base ^ ext in
+      let _, file = System.where_in_path ~warn:false loadpath name in
+      [file]
+    with Not_found -> [] in
+  match find ".vo" @ find ".vio" with
+  | [] -> raise LibNotFound
+  | [file] -> dir, file
+  | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) ->
+       msg_warning (str"Loading " ++ str vi ++ str " instead of " ++
+         str vo ++ str " because it is more recent");
+       dir, vi
+  | [vo;vi] -> dir, vo
+  | _ -> assert false
 
 let locate_qualified_library warn qid =
-  try
-    (* Search library in loadpath *)
-    let dir, base = repr_qualid qid in
-    let loadpath = loadpaths_matching_dir_path dir in
-    if loadpath = [] then raise LibUnmappedDir;
-    let name = string_of_id base ^ ".vo" in
-    let lpath, file = System.where_in_path ~warn (List.map fst loadpath) name in
-    let dir = add_dirpath_suffix (List.assoc lpath loadpath) base in
-    (* Look if loaded *)
-    if library_is_loaded dir then (LibLoaded, dir, library_full_filename dir)
-    (* Otherwise, look for it in the file system *)
-    else (LibInPath, dir, file)
-  with Not_found -> raise LibNotFound
-
-let explain_locate_library_error qid = function
-  | LibUnmappedDir ->
-      let prefix, _ = repr_qualid qid in
-      errorlabstrm "load_absolute_library_from"
-      (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++
-      str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
-  | LibNotFound ->
-      errorlabstrm "load_absolute_library_from"
-      (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath")
-  | e -> raise e
+  (* Search library in loadpath *)
+  let dir, base = repr_qualid qid in
+  let loadpath = Loadpath.expand_path dir in
+  let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in
+  let find ext =
+    try
+      let name = Id.to_string base ^ ext in
+      let lpath, file =
+        System.where_in_path ~warn (List.map fst loadpath) name in
+      [lpath, file]
+    with Not_found -> [] in
+  let lpath, file =
+    match find ".vo" @ find ".vio" with
+    | [] -> raise LibNotFound
+    | [lpath, file] -> lpath, file
+    | [lpath_vo, vo; lpath_vi, vi]
+      when Unix.((stat vo).st_mtime < (stat vi).st_mtime) ->
+       msg_warning (str"Loading " ++ str vi ++ str " instead of " ++
+         str vo ++ str " because it is more recent");
+       lpath_vi, vi
+    | [lpath_vo, vo; _ ] -> lpath_vo, vo
+    | _ -> assert false
+  in
+  let dir = add_dirpath_suffix (String.List.assoc lpath loadpath) base in
+  (* Look if loaded *)
+  if library_is_loaded dir then (LibLoaded, dir,library_full_filename dir)
+  (* Otherwise, look for it in the file system *)
+  else (LibInPath, dir, file)
+
+let error_unmapped_dir qid =
+  let prefix, _ = repr_qualid qid in
+  errorlabstrm "load_absolute_library_from"
+    (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++
+     str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ())
+
+let error_lib_not_found qid =
+  errorlabstrm "load_absolute_library_from"
+    (str"Cannot find library " ++ pr_qualid qid ++ str" in loadpath")
 
 let try_locate_absolute_library dir =
   try
     locate_absolute_library dir
-  with e when Errors.noncritical e ->
-    explain_locate_library_error (qualid_of_dirpath dir) e
+  with
+    | LibUnmappedDir -> error_unmapped_dir (qualid_of_dirpath dir)
+    | LibNotFound -> error_lib_not_found (qualid_of_dirpath dir)
 
 let try_locate_qualified_library (loc,qid) =
   try
     let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in
     dir,f
+  with
+    | LibUnmappedDir -> error_unmapped_dir qid
+    | LibNotFound -> error_lib_not_found qid
+
+(************************************************************************)
+(** {6 Tables of opaque proof terms} *)
+
+(** We now store opaque proof terms apart from the rest of the environment.
+    See the [Indirect] contructor in [Lazyconstr.lazy_constr]. This way,
+    we can quickly load a first half of a .vo file without these opaque
+    terms, and access them only when a specific command (e.g. Print or
+    Print Assumptions) needs it. *)
+
+exception Faulty
+
+(** Fetching a table of opaque terms at position [pos] in file [f],
+    expecting to find first a copy of [digest]. *)
+
+let fetch_table what dp (f,pos,digest) =
+  let dir_path = Names.DirPath.to_string dp in
+  try
+    msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path);
+    let ch = System.with_magic_number_check raw_intern_library f in
+    let () = seek_in ch pos in
+    if not (String.equal (System.digest_in f ch) digest) then raise Faulty;
+    let table, pos', digest' = System.marshal_in_segment f ch in
+    let () = close_in ch in
+    let ch' = open_in f in
+    if not (String.equal (Digest.channel ch' pos') digest') then raise Faulty;
+    let () = close_in ch' in
+    table
   with e when Errors.noncritical e ->
-    explain_locate_library_error qid e
+    error
+      ("The file "^f^" (bound to " ^ dir_path ^
+      ") is inaccessible or corrupted,\n" ^
+      "cannot load some "^what^" in it.\n")
+
+(** Delayed / available tables of opaque terms *)
+
+type 'a table_status =
+  | ToFetch of string * int * Digest.t
+  | Fetched of 'a Future.computation array
+
+let opaque_tables =
+  ref (LibraryMap.empty : (Term.constr table_status) LibraryMap.t)
+let univ_tables =
+  ref (LibraryMap.empty : (Univ.universe_context_set table_status) LibraryMap.t)
+
+let add_opaque_table dp st =
+  opaque_tables := LibraryMap.add dp st !opaque_tables
+let add_univ_table dp st =
+  univ_tables := LibraryMap.add dp st !univ_tables
+
+let access_table fetch_table add_table tables dp i =
+  let t = match LibraryMap.find dp tables with
+    | Fetched t -> t
+    | ToFetch (f,pos,digest) ->
+      let t = fetch_table dp (f,pos,digest) in
+      add_table dp (Fetched t);
+      t
+  in
+  assert (i < Array.length t); t.(i)
+
+let access_opaque_table dp i =
+  access_table
+    (fetch_table "opaque proofs")
+    add_opaque_table !opaque_tables dp i
+let access_univ_table dp i =
+  try
+    Some (access_table 
+            (fetch_table "universe contexts of opaque proofs")
+            add_univ_table !univ_tables dp i)
+  with Not_found -> None
 
+let () =
+  Opaqueproof.set_indirect_opaque_accessor access_opaque_table;
+  Opaqueproof.set_indirect_univ_accessor access_univ_table
 
 (************************************************************************)
 (* Internalise libraries *)
 
-let mk_library md table digest =
-  let md_compiled =
-    LightenLibrary.load ~load_proof:!Flags.load_proofs table md.md_compiled
-  in {
+type seg_lib = library_disk
+type seg_univ = (* true = vivo, false = vi *)
+  Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool
+type seg_discharge = Opaqueproof.cooking_info list array
+type seg_proofs = Term.constr Future.computation array
+
+let mk_library md digests univs =
+  {
     library_name     = md.md_name;
-    library_compiled = md_compiled;
+    library_compiled = md.md_compiled;
     library_objects  = md.md_objects;
     library_deps     = md.md_deps;
     library_imports  = md.md_imports;
-    library_digest    = digest
+    library_digests  = digests;
+    library_extra_univs = univs;
   }
 
-let fetch_opaque_table (f,pos,digest) =
-  try
-    let ch = System.with_magic_number_check raw_intern_library f in
-    seek_in ch pos;
-    if System.marshal_in f ch <> digest then failwith "File changed!";
-    let table = (System.marshal_in f ch : LightenLibrary.table) in
-    close_in ch;
-    table
-  with e when Errors.noncritical e ->
-    error
-      ("The file "^f^" is inaccessible or has changed,\n" ^
-       "cannot load some opaque constant bodies in it.\n")
-
 let intern_from_file f =
   let ch = System.with_magic_number_check raw_intern_library f in
-  let lmd = System.marshal_in f ch in
-  let pos = pos_in ch in
-  let digest = System.marshal_in f ch in
-  let table = lazy (fetch_opaque_table (f,pos,digest)) in
-  register_library_filename lmd.md_name f;
-  let library = mk_library lmd table digest in
+  let (lmd : seg_lib), pos, digest_lmd = System.marshal_in_segment f ch in
+  let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in
+  let _ = System.skip_in_segment f ch in
+  let pos, digest = System.skip_in_segment f ch in
   close_in ch;
-  library
-
-let rec intern_library needed (dir, f) =
+  register_library_filename lmd.md_name f;
+  add_opaque_table lmd.md_name (ToFetch (f,pos,digest));
+  let open Safe_typing in
+  match univs with
+  | None -> mk_library lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty
+  | Some (utab,uall,true) ->
+      add_univ_table lmd.md_name (Fetched utab);
+      mk_library lmd (Dvivo (digest_lmd,digest_u)) uall
+  | Some (utab,_,false) ->
+      add_univ_table lmd.md_name (Fetched utab);
+      mk_library lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty
+
+module DPMap = Map.Make(DirPath)
+
+let deps_to_string deps =
+  Array.fold_left (fun s (n, _) -> s^"\n  - "^(DirPath.to_string n)) "" deps
+
+let rec intern_library (needed, contents) (dir, f) from =
+  Pp.feedback(Feedback.FileDependency (from, f));
   (* Look if in the current logical environment *)
-  try find_library dir, needed
+  try find_library dir, (needed, contents)
   with Not_found ->
   (* Look if already listed and consequently its dependencies too *)
-  try List.assoc dir needed, needed
+  try DPMap.find dir contents, (needed, contents)
   with Not_found ->
   (* [dir] is an absolute name which matches [f] which must be in loadpath *)
   let m = intern_from_file f in
-  if dir <> m.library_name then
+  if not (DirPath.equal dir m.library_name) then
     errorlabstrm "load_physical_library"
       (str ("The file " ^ f ^ " contains library") ++ spc () ++
        pr_dirpath m.library_name ++ spc () ++ str "and not library" ++
        spc() ++ pr_dirpath dir);
-  m, intern_library_deps needed dir m
+  Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f));
+  m, intern_library_deps (needed, contents) dir m (Some f)
 
-and intern_library_deps needed dir m =
-  (dir,m)::List.fold_left (intern_mandatory_library dir) needed m.library_deps
+and intern_library_deps libs dir m from =
+  let needed, contents = Array.fold_left (intern_mandatory_library dir from) libs m.library_deps in
+  (dir :: needed, DPMap.add dir m contents )
 
-and intern_mandatory_library caller needed (dir,d) =
-  let m,needed = intern_library needed (try_locate_absolute_library dir) in
-  if d <> m.library_digest then
-    errorlabstrm "" (strbrk ("Compiled library "^(string_of_dirpath caller)^
-	   ".vo makes inconsistent assumptions over library "
-	   ^(string_of_dirpath dir)));
-  needed
+and intern_mandatory_library caller from libs (dir,d) =
+  let m, libs = intern_library libs (try_locate_absolute_library dir) from in
+  if not (Safe_typing.digest_match ~actual:m.library_digests ~required:d) then
+    errorlabstrm "" (strbrk ("Compiled library "^ DirPath.to_string caller ^
+      ".vo makes inconsistent assumptions over library " ^
+      DirPath.to_string dir));
+  libs
 
-let rec_intern_library needed mref =
-  let _,needed = intern_library needed mref in needed
+let rec_intern_library libs mref =
+  let _, libs = intern_library libs mref None in
+  libs
 
 let check_library_short_name f dir = function
-  | Some id when id <> snd (split_dirpath dir) ->
+  | Some id when not (Id.equal id (snd (split_dirpath dir))) ->
       errorlabstrm "check_library_short_name"
       (str ("The file " ^ f ^ " contains library") ++ spc () ++
       pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++
@@ -463,18 +454,24 @@ let rec_intern_by_filename_only id f =
   (* We check no other file containing same library is loaded *)
   if library_is_loaded m.library_name then
     begin
-      Flags.if_warn msg_warning
+      msg_warning
 	(pr_dirpath m.library_name ++ str " is already loaded from file " ++
 	str (library_full_filename m.library_name));
       m.library_name, []
     end
  else
-    let needed = intern_library_deps [] m.library_name m in
+    let needed, contents = intern_library_deps ([], DPMap.empty) m.library_name m (Some f) in
+    let needed = List.map (fun dir -> dir, DPMap.find dir contents) needed in
     m.library_name, needed
 
+let native_name_from_filename f =
+  let ch = System.with_magic_number_check raw_intern_library f in
+  let (lmd : seg_lib), pos, digest_lmd = System.marshal_in_segment f ch in
+  Nativecode.mod_uid_of_dirpath lmd.md_name
+
 let rec_intern_library_from_file idopt f =
   (* A name is specified, we have to check it contains library id *)
-  let paths = get_load_paths () in
+  let paths = Loadpath.get_paths () in
   let _, f =
     System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in
   rec_intern_by_filename_only idopt f
@@ -496,14 +493,13 @@ let rec_intern_library_from_file idopt f =
     which recursively loads its dependencies)
 *)
 
-type library_reference = dir_path list * bool option
-
 let register_library m =
   Declaremods.register_library
     m.library_name
     m.library_compiled
     m.library_objects
-    m.library_digest;
+    m.library_digests
+    m.library_extra_univs;
   register_loaded_library m
 
 (* Follow the semantics of Anticipate object:
@@ -526,7 +522,7 @@ let discharge_require (_,o) = Some o
 
 (* open_function is never called from here because an Anticipate object *)
 
-type require_obj = library_t list * dir_path list * bool option
+type require_obj = library_t list * DirPath.t list * bool option
 
 let in_require : require_obj -> obj =
   declare_object {(default_object "REQUIRE") with
@@ -539,12 +535,9 @@ let in_require : require_obj -> obj =
 (* Require libraries, import them if [export <> None], mark them for export
    if [export = Some true] *)
 
-let xml_require = ref (fun d -> ())
-let set_xml_require f = xml_require := f
-
 let require_library_from_dirpath modrefl export =
-  let needed = List.fold_left rec_intern_library [] modrefl in
-  let needed = List.rev_map snd needed in
+  let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in
+  let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in
   let modrefl = List.map fst modrefl in
     if Lib.is_module_or_modtype () then
       begin
@@ -555,7 +548,6 @@ let require_library_from_dirpath modrefl export =
       end
     else
       add_anonymous_leaf (in_require (needed,modrefl,export));
-    if !Flags.xml_export then List.iter !xml_require modrefl;
   add_frozen_state ()
 
 let require_library qidl export =
@@ -572,7 +564,6 @@ let require_library_from_file idopt file export =
   end
   else
     add_anonymous_leaf (in_require (needed,[modref],export));
-  if !Flags.xml_export then !xml_require modref;
   add_frozen_state ()
 
 (* the function called by Vernacentries.vernac_import *)
@@ -597,28 +588,73 @@ let import_module export (loc,qid) =
 (*s Initializing the compilation of a library. *)
 
 let check_coq_overwriting p id =
-  let l = repr_dirpath p in
-  if not !Flags.boot && l <> [] && string_of_id (list_last l) = "Coq" then
+  let l = DirPath.repr p in
+  let is_empty = match l with [] -> true | _ -> false in
+  if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then
     errorlabstrm ""
-      (strbrk ("Cannot build module "^string_of_dirpath p^"."^string_of_id id^
+      (strbrk ("Cannot build module "^DirPath.to_string p^"."^Id.to_string id^
       ": it starts with prefix \"Coq\" which is reserved for the Coq library."))
 
+(* Verifies that a string starts by a letter and do not contain
+   others caracters than letters, digits, or `_` *)
+
+let check_module_name s =
+  let msg c =
+    strbrk "Invalid module name: " ++ str s ++ strbrk " character " ++
+    (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++
+    strbrk " is not allowed in module names\n"
+  in
+  let err c = errorlabstrm "" (msg c) in
+  match String.get s 0 with
+    | 'a' .. 'z' | 'A' .. 'Z' ->
+        for i = 1 to (String.length s)-1 do
+          match String.get s i with
+            | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_'  -> ()
+            | c -> err c
+        done
+    | c -> err c
+
 let start_library f =
-  let paths = get_load_paths () in
-  let _,longf =
+  let paths = Loadpath.get_paths () in
+  let _, longf =
     System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in
-  let ldir0 = find_logical_path (Filename.dirname longf) in
-  let id = id_of_string (Filename.basename f) in
+  let ldir0 =
+    try
+      let lp = Loadpath.find_load_path (Filename.dirname longf) in
+      Loadpath.logical lp
+    with Not_found -> Nameops.default_root_prefix
+  in
+  let file = Filename.basename f in
+  let id = Id.of_string file in
+  check_module_name file;
   check_coq_overwriting ldir0 id;
   let ldir = add_dirpath_suffix ldir0 id in
   Declaremods.start_library ldir;
   ldir,longf
 
+let load_library_todo f =
+  let paths = Loadpath.get_paths () in
+  let _, longf =
+    System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in
+  let f = longf^"io" in
+  let ch = System.with_magic_number_check raw_intern_library f in
+  let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in
+  let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in
+  let (s3 : seg_discharge option), _, _ = System.marshal_in_segment f ch in
+  let tasks, _, _ = System.marshal_in_segment f ch in
+  let (s5 : seg_proofs), _, _ = System.marshal_in_segment f ch in
+  close_in ch;
+  if tasks = None then errorlabstrm "restart" (str"not a .vio file");
+  if s2 = None then errorlabstrm "restart" (str"not a .vio file");
+  if s3 = None then errorlabstrm "restart" (str"not a .vio file");
+  if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file");
+  longf, s1, Option.get s2, Option.get s3, Option.get tasks, s5
+
 (************************************************************************)
 (*s [save_library dir] ends library [dir] and save it to the disk. *)
 
 let current_deps () =
-  List.map (fun m -> (m.library_name, m.library_digest)) !libraries_loaded_list
+  List.map (fun m -> m.library_name, m.library_digests) !libraries_loaded_list
 
 let current_reexports () =
   List.map (fun m -> m.library_name) !libraries_exports_list
@@ -629,34 +665,85 @@ let error_recursively_dependent_library dir =
      strbrk " to save current library because" ++
      strbrk " it already depends on a library of this name.")
 
+(* We now use two different digests in a .vo file. The first one
+   only covers half of the file, without the opaque table. It is
+   used for identifying this version of this library : this digest
+   is the one leading to "inconsistent assumptions" messages.
+   The other digest comes at the very end, and covers everything
+   before it. This one is used for integrity check of the whole
+   file when loading the opaque table. *)
+
 (* Security weakness: file might have been changed on disk between
    writing the content and computing the checksum... *)
-let save_library_to dir f =
-  let cenv, seg = Declaremods.end_library dir in
-  let cenv, table = LightenLibrary.save cenv in
+
+let save_library_to ?todo dir f otab =
+  let f, except = match todo with
+    | None ->
+        assert(!Flags.compilation_mode = Flags.BuildVo);
+        f ^ "o", Future.UUIDSet.empty
+    | Some (l,_) ->
+        f ^ "io",
+        List.fold_left (fun e r -> Future.UUIDSet.add r.Stateid.uuid e)
+          Future.UUIDSet.empty l in
+  let cenv, seg, ast = Declaremods.end_library ~except dir in
+  let opaque_table, univ_table, disch_table, f2t_map = Opaqueproof.dump otab in
+  let tasks, utab, dtab =
+    match todo with
+    | None -> None, None, None
+    | Some (tasks, rcbackup) ->
+        let tasks =
+          List.map Stateid.(fun r ->
+            { r with uuid = Future.UUIDMap.find r.uuid f2t_map }) tasks in
+        Some (tasks,rcbackup),
+        Some (univ_table,Univ.ContextSet.empty,false),
+        Some disch_table in
+  let except =
+    Future.UUIDSet.fold (fun uuid acc ->
+      Int.Set.add (Future.UUIDMap.find uuid f2t_map) acc)
+      except Int.Set.empty in
+  let is_done_or_todo i x = Future.is_val x || Int.Set.mem i except in
+  Array.iteri (fun i x ->
+    if not(is_done_or_todo i x) then Errors.errorlabstrm "library"
+      Pp.(str"Proof object "++int i++str" is not checked nor to be checked"))
+    opaque_table;
   let md = {
     md_name = dir;
     md_compiled = cenv;
     md_objects = seg;
-    md_deps = current_deps ();
-    md_imports = current_reexports () } in
-  if List.mem_assoc dir md.md_deps then
+    md_deps = Array.of_list (current_deps ());
+    md_imports = Array.of_list (current_reexports ()) } in
+  if Array.exists (fun (d,_) -> DirPath.equal d dir) md.md_deps then
     error_recursively_dependent_library dir;
+  (* Open the vo file and write the magic number *)
   let (f',ch) = raw_extern_library f in
   try
-    System.marshal_out ch md;
-    flush ch;
-    (* The loading of the opaque definitions table is optional whereas
-       the digest is loaded all the time. As a consequence, the digest
-       must be serialized before the table (if we want to keep the
-       current simple layout of .vo files). This also entails that the
-       digest does not take opaque terms into account anymore. *)
-    let di = Digest.file f' in
-    System.marshal_out ch di;
-    System.marshal_out ch table;
-    close_out ch
-  with reraise ->
-    msg_warn ("Removed file "^f'); close_out ch; Sys.remove f'; raise reraise
+    (* Writing vo payload *)
+    System.marshal_out_segment f' ch (md           : seg_lib);
+    System.marshal_out_segment f' ch (utab         : seg_univ option);
+    System.marshal_out_segment f' ch (dtab         : seg_discharge option);
+    System.marshal_out_segment f' ch (tasks        : 'tasks option);
+    System.marshal_out_segment f' ch (opaque_table : seg_proofs);
+    close_out ch;
+    (* Writing native code files *)
+    if not !Flags.no_native_compiler then
+      let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in
+      if not (Nativelib.compile_library dir ast fn) then
+        msg_error (str"Could not compile the library to native code. Skipping.")
+   with reraise ->
+    let reraise = Errors.push reraise in
+    let () = msg_warning (str ("Removed file "^f')) in
+    let () = close_out ch in
+    let () = Sys.remove f' in
+    iraise reraise
+
+let save_library_raw f lib univs proofs =
+  let (f',ch) = raw_extern_library (f^"o") in
+  System.marshal_out_segment f' ch (lib        : seg_lib);
+  System.marshal_out_segment f' ch (Some univs : seg_univ option);
+  System.marshal_out_segment f' ch (None       : seg_discharge option);
+  System.marshal_out_segment f' ch (None       : 'tasks option);
+  System.marshal_out_segment f' ch (proofs     : seg_proofs);
+  close_out ch
 
 (************************************************************************)
 (*s Display the memory use of a library. *)
@@ -666,5 +753,16 @@ open Printf
 let mem s =
   let m = try_find_library s in
   h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)"
-		 (size_kb m) (size_kb m.library_compiled)
-		 (size_kb m.library_objects)))
+		 (CObj.size_kb m) (CObj.size_kb m.library_compiled)
+		 (CObj.size_kb m.library_objects)))
+
+module StringOrd = struct type t = string let compare = String.compare end
+module StringSet = Set.Make(StringOrd)
+
+let get_used_load_paths () =
+  StringSet.elements
+    (List.fold_left (fun acc m -> StringSet.add
+      (Filename.dirname (library_full_filename m.library_name)) acc)
+       StringSet.empty !libraries_loaded_list)
+
+let _ = Nativelib.get_load_paths := get_used_load_paths
diff --git a/library/library.mli b/library/library.mli
index 630b9f58..13d83a5c 100644
--- a/library/library.mli
+++ b/library/library.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        *)
 (************************************************************************)
 
-open Util
+open Loc
 open Names
 open Libnames
-open Libobject
 
 (** This module provides functions to load, open and save
   libraries. Libraries correspond to the subclass of modules that
@@ -23,60 +22,62 @@ open Libobject
 (** Require = load in the environment + open (if the optional boolean
     is not [None]); mark also for export if the boolean is [Some true] *)
 val require_library : qualid located list -> bool option -> unit
-val require_library_from_dirpath : (dir_path * string) list -> bool option -> unit
+val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit
 val require_library_from_file :
-  identifier option -> System.physical_path -> bool option -> unit
+  Id.t option -> CUnix.physical_path -> bool option -> unit
 
 (** {6 ... } *)
+
+(** Segments of a library *)
+type seg_lib
+type seg_univ = (* cst, all_cst, finished? *)
+  Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool
+type seg_discharge = Opaqueproof.cooking_info list array
+type seg_proofs = Term.constr Future.computation array
+
 (** Open a module (or a library); if the boolean is true then it's also
    an export otherwise just a simple import *)
 val import_module : bool -> qualid located -> unit
 
 (** {6 Start the compilation of a library } *)
-val start_library : string -> dir_path * string
+val start_library : string -> DirPath.t * string
 
 (** {6 End the compilation of a library and save it to a ".vo" file } *)
-val save_library_to : dir_path -> string -> unit
+val save_library_to :
+  ?todo:((Future.UUID.t,'document) Stateid.request list * 'counters) ->
+  DirPath.t -> string -> Opaqueproof.opaquetab -> unit
+
+val load_library_todo :
+  string -> string * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs
+val save_library_raw : string -> seg_lib -> seg_univ -> seg_proofs -> unit
 
 (** {6 Interrogate the status of libraries } *)
 
   (** - Tell if a library is loaded or opened *)
-val library_is_loaded : dir_path -> bool
-val library_is_opened : dir_path -> bool
+val library_is_loaded : DirPath.t -> bool
+val library_is_opened : DirPath.t -> bool
 
   (** - Tell which libraries are loaded or imported *)
-val loaded_libraries : unit -> dir_path list
-val opened_libraries : unit -> dir_path list
+val loaded_libraries : unit -> DirPath.t list
+val opened_libraries : unit -> DirPath.t list
 
   (** - Return the full filename of a loaded library. *)
-val library_full_filename : dir_path -> string
+val library_full_filename : DirPath.t -> string
 
   (** - Overwrite the filename of all libraries (used when restoring a state) *)
 val overwrite_library_filenames : string -> unit
 
-(** {6 Hook for the xml exportation of libraries } *)
-val set_xml_require : (dir_path -> unit) -> unit
-
-(** {6 ... } *)
-(** Global load paths: a load path is a physical path in the file
-    system; to each load path is associated a Coq [dir_path] (the "logical"
-    path of the physical path) *)
-
-val get_load_paths : unit -> System.physical_path list
-val get_full_load_paths : unit -> (System.physical_path * dir_path) list
-val add_load_path : bool -> System.physical_path * dir_path -> unit
-val remove_load_path : System.physical_path -> unit
-val find_logical_path : System.physical_path -> dir_path
-val is_in_load_paths : System.physical_path -> bool
-
 (** {6 Locate a library in the load paths } *)
 exception LibUnmappedDir
 exception LibNotFound
 type library_location = LibLoaded | LibInPath
 
 val locate_qualified_library :
-  bool -> qualid -> library_location * dir_path * System.physical_path
-val try_locate_qualified_library : qualid located -> dir_path * string
+  bool -> qualid -> library_location * DirPath.t * CUnix.physical_path
+val try_locate_qualified_library : qualid located -> DirPath.t * string
 
 (** {6 Statistics: display the memory use of a library. } *)
-val mem : dir_path -> Pp.std_ppcmds
+val mem : DirPath.t -> Pp.std_ppcmds
+
+(** {6 Native compiler. } *)
+val native_name_from_filename : string -> string
diff --git a/library/library.mllib b/library/library.mllib
index e8b5a7a4..eca28c82 100644
--- a/library/library.mllib
+++ b/library/library.mllib
@@ -1,16 +1,20 @@
 Nameops
 Libnames
+Globnames
 Libobject
 Summary
 Nametab
 Global
+Universes
 Lib
 Declaremods
+Loadpath
 Library
 States
-Decl_kinds
+Kindops
 Dischargedhypsmap
 Goptions
 Decls
 Heads
-Assumptions
\ No newline at end of file
+Assumptions
+Keys
diff --git a/library/loadpath.ml b/library/loadpath.ml
new file mode 100644
index 00000000..5876eedd
--- /dev/null
+++ b/library/loadpath.ml
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Errors
+open Names
+open Libnames
+
+type path_type = ImplicitPath | ImplicitRootPath | RootPath
+
+(** Load paths. Mapping from physical to logical paths. *)
+
+type t = {
+  path_physical : CUnix.physical_path;
+  path_logical : DirPath.t;
+  path_type : path_type;
+}
+
+let load_paths = Summary.ref ([] : t list) ~name:"LOADPATHS"
+
+let logical p = p.path_logical
+
+let physical p = p.path_physical
+
+let get_load_paths () = !load_paths
+
+let get_paths () = List.map physical !load_paths
+
+let anomaly_too_many_paths path =
+  anomaly (str "Several logical paths are associated to" ++ spc () ++ str path)
+
+let find_load_path phys_dir =
+  let phys_dir = CUnix.canonical_path_name phys_dir in
+  let filter p = String.equal p.path_physical phys_dir in
+  let paths = List.filter filter !load_paths in
+  match paths with
+  | [] -> raise Not_found
+  | [p] -> p
+  | _ -> anomaly_too_many_paths phys_dir
+
+let is_in_load_paths phys_dir =
+  let dir = CUnix.canonical_path_name phys_dir in
+  let lp = get_load_paths () in
+  let check_p p = String.equal dir p.path_physical in
+  List.exists check_p lp
+
+let remove_load_path dir =
+  let filter p = not (String.equal p.path_physical dir) in
+  load_paths := List.filter filter !load_paths
+
+let add_load_path phys_path path_type coq_path =
+  let phys_path = CUnix.canonical_path_name phys_path in
+  let filter p = String.equal p.path_physical phys_path in
+  let binding = {
+    path_logical = coq_path;
+    path_physical = phys_path;
+    path_type = path_type;
+  } in
+  match List.filter filter !load_paths with
+  | [] ->
+    load_paths := binding :: !load_paths
+  | [p] ->
+    let dir = p.path_logical in
+    if not (DirPath.equal coq_path dir)
+      (* If this is not the default -I . to coqtop *)
+      && not
+      (String.equal phys_path (CUnix.canonical_path_name Filename.current_dir_name)
+          && DirPath.equal coq_path (Nameops.default_root_prefix))
+    then
+      begin
+        (* Assume the user is concerned by library naming *)
+        if not (DirPath.equal dir Nameops.default_root_prefix) then
+          msg_warning
+            (str phys_path ++ strbrk " was previously bound to " ++
+              pr_dirpath dir ++ strbrk "; it is remapped to " ++
+              pr_dirpath coq_path);
+        remove_load_path phys_path;
+        load_paths := binding :: !load_paths;
+      end
+  | _ -> anomaly_too_many_paths phys_path
+
+let extend_path_with_dirpath p dir =
+  List.fold_left Filename.concat p
+    (List.rev_map Id.to_string (DirPath.repr dir))
+
+let expand_root_path dir =
+  let rec aux = function
+  | [] -> []
+  | p :: l ->
+    if p.path_type <> ImplicitPath && is_dirpath_prefix_of p.path_logical dir then
+      let suffix = drop_dirpath_prefix p.path_logical dir in
+      extend_path_with_dirpath p.path_physical suffix :: aux l
+    else aux l
+  in
+  aux !load_paths
+
+(* Root p is bound to A.B.C.D and we require file C.D.E.F *)
+(* We may mean A.B.C.D.E.F, or A.B.C.D.C.D.E.F *)
+
+(* Root p is bound to A.B.C.C and we require file C.C.E.F *)
+(* We may mean A.B.C.C.E.F, or A.B.C.C.C.E.F, or A.B.C.C.C.C.E.F *)
+
+let intersections d1 d2 =
+  let rec aux d1 =
+    if DirPath.is_empty d1 then [d2] else
+      let rest = aux (snd (chop_dirpath 1 d1)) in
+      if is_dirpath_prefix_of d1 d2 then drop_dirpath_prefix d1 d2 :: rest
+      else rest in
+  aux d1
+
+let expand p dir =
+  let ph = extend_path_with_dirpath p.path_physical dir in
+  let log = append_dirpath p.path_logical dir in
+  (ph, log)
+
+let expand_path dir =
+  let rec aux = function
+  | [] -> []
+  | p :: l ->
+    match p.path_type with
+    | ImplicitPath -> expand p dir :: aux l
+    | ImplicitRootPath ->
+      let inters = intersections p.path_logical dir in
+      List.map (expand p) inters @ aux l
+    | RootPath ->
+      if is_dirpath_prefix_of p.path_logical dir then
+	expand p (drop_dirpath_prefix p.path_logical dir) :: aux l
+      else aux l in
+  aux !load_paths
diff --git a/library/loadpath.mli b/library/loadpath.mli
new file mode 100644
index 00000000..62dc5d59
--- /dev/null
+++ b/library/loadpath.mli
@@ -0,0 +1,58 @@
+(************************************************************************)
+(*  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 Names
+
+(** * Load paths.
+
+  A load path is a physical path in the file system; to each load path is
+  associated a Coq [DirPath.t] (the "logical" path of the physical path).
+
+*)
+
+type path_type =
+  | ImplicitPath     (** Can be implicitly appended to a logical path. *)
+  | ImplicitRootPath (** Can be implicitly appended to the suffix of a logical path. *)
+  | RootPath         (** Can only be a prefix of a logical path. *)
+
+type t
+(** Type of loadpath bindings. *)
+
+val physical : t -> CUnix.physical_path
+(** Get the physical path (filesystem location) of a loadpath. *)
+
+val logical : t -> DirPath.t
+(** Get the logical path (Coq module hierarchy) of a loadpath. *)
+
+val get_load_paths : unit -> t list
+(** Get the current loadpath association. *)
+
+val get_paths : unit -> CUnix.physical_path list
+(** Same as [get_load_paths] but only get the physical part. *)
+
+val add_load_path : CUnix.physical_path -> path_type -> DirPath.t -> unit
+(** [add_load_path phys type log] adds the binding [phys := log] to the current
+    loadpaths. *)
+
+val remove_load_path : CUnix.physical_path -> unit
+(** Remove the current logical path binding associated to a given physical path,
+    if any. *)
+
+val find_load_path : CUnix.physical_path -> t
+(** Get the binding associated to a physical path. Raises [Not_found] if there
+    is none. *)
+
+val is_in_load_paths : CUnix.physical_path -> bool
+(** Whether a physical path is currently bound. *)
+
+val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list
+(** Given a relative logical path, associate the list of absolute physical and
+    logical paths which are possible expansions of it. *)
+
+val expand_root_path : DirPath.t -> CUnix.physical_path list
+(** As [expand_path] but restricts to root loadpaths. *)
diff --git a/library/nameops.ml b/library/nameops.ml
index e733d19d..02b085a7 100644
--- a/library/nameops.ml
+++ b/library/nameops.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        *)
@@ -12,7 +12,7 @@ open Names
 
 (* Identifiers *)
 
-let pr_id id = str (string_of_id id)
+let pr_id id = str (Id.to_string id)
 
 let pr_name = function
   | Anonymous -> str "_"
@@ -24,20 +24,20 @@ let code_of_0 = Char.code '0'
 let code_of_9 = Char.code '9'
 
 let cut_ident skip_quote s =
-  let s = string_of_id s in
+  let s = Id.to_string s in
   let slen = String.length s in
   (* [n'] is the position of the first non nullary digit *)
   let rec numpart n n' =
-    if n = 0 then
+    if Int.equal n 0 then
       (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *)
       slen
     else
       let c = Char.code (String.get s (n-1)) in
-      if c = code_of_0 && n <> slen then
+      if Int.equal c code_of_0 && not (Int.equal n slen) then
 	numpart (n-1) n'
       else if code_of_0 <= c && c <= code_of_9 then
 	numpart (n-1) (n-1)
-      else if skip_quote & (c = Char.code '\'' || c = Char.code '_') then
+      else if skip_quote && (Int.equal c (Char.code '\'') || Int.equal c (Char.code '_')) then
 	numpart (n-1) (n-1)
       else
 	n'
@@ -46,9 +46,9 @@ let cut_ident skip_quote s =
 
 let repr_ident s =
   let numstart = cut_ident false s in
-  let s = string_of_id s in
+  let s = Id.to_string s in
   let slen = String.length s in
-  if numstart = slen then
+  if Int.equal numstart slen then
     (s, None)
   else
     (String.sub s 0 numstart,
@@ -58,24 +58,24 @@ let make_ident sa = function
   | Some n ->
       let c = Char.code (String.get sa (String.length sa -1)) in
       let s =
-        if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n)
+        if c < code_of_0 || c > code_of_9 then sa ^ (string_of_int n)
         else sa ^ "_" ^ (string_of_int n) in
-      id_of_string s
-  | None -> id_of_string (String.copy sa)
+      Id.of_string s
+  | None -> Id.of_string (String.copy sa)
 
 let root_of_id id =
   let suffixstart = cut_ident true id in
-  id_of_string (String.sub (string_of_id id) 0 suffixstart)
+  Id.of_string (String.sub (Id.to_string id) 0 suffixstart)
 
 (* Rem: semantics is a bit different, if an ident starts with toto00 then
   after successive renamings it comes to toto09, then it goes on with toto10 *)
 let lift_subscript id =
-  let id = string_of_id id in
+  let id = Id.to_string id in
   let len = String.length id in
   let rec add carrypos =
     let c = id.[carrypos] in
     if is_digit c then
-      if c = '9' then begin
+      if Int.equal (Char.code c) (Char.code '9') then begin
 	assert (carrypos>0);
 	add (carrypos-1)
       end
@@ -93,20 +93,20 @@ let lift_subscript id =
       end;
       newid
     end
-  in id_of_string (add (len-1))
+  in Id.of_string (add (len-1))
 
 let has_subscript id =
-  let id = string_of_id id in
+  let id = Id.to_string id in
   is_digit (id.[String.length id - 1])
 
 let forget_subscript id =
   let numstart = cut_ident false id in
   let newid = String.make (numstart+1) '0' in
-  String.blit (string_of_id id) 0 newid 0 numstart;
-  (id_of_string newid)
+  String.blit (Id.to_string id) 0 newid 0 numstart;
+  (Id.of_string newid)
 
-let add_suffix id s = id_of_string (string_of_id id ^ s)
-let add_prefix s id = id_of_string (s ^ string_of_id id)
+let add_suffix id s = Id.of_string (Id.to_string id ^ s)
+let add_prefix s id = Id.of_string (s ^ Id.to_string id)
 
 let atompart_of_id id = fst (repr_ident id)
 
@@ -114,7 +114,7 @@ let atompart_of_id id = fst (repr_ident id)
 
 let out_name = function
   | Name id -> id
-  | Anonymous -> failwith "out_name: expects a defined name"
+  | Anonymous -> failwith "Nameops.out_name"
 
 let name_fold f na a =
   match na with
@@ -136,13 +136,14 @@ let name_fold_map f e = function
   | Name id -> let (e,id) = f e id in (e,Name id)
   | Anonymous -> e,Anonymous
 
-let pr_lab l = str (string_of_label l)
+let pr_lab l = str (Label.to_string l)
 
-let default_library = Names.initial_dir (* = ["Top"] *)
+let default_library = Names.DirPath.initial (* = ["Top"] *)
 
 (*s Roots of the space of absolute names *)
-let coq_root = id_of_string "Coq"
-let default_root_prefix = make_dirpath []
+let coq_string = "Coq"
+let coq_root = Id.of_string coq_string
+let default_root_prefix = DirPath.empty
 
 (* Metavariables *)
 let pr_meta = Pp.int
diff --git a/library/nameops.mli b/library/nameops.mli
index 9571d2a3..23432ae2 100644
--- a/library/nameops.mli
+++ b/library/nameops.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        *)
@@ -9,43 +9,46 @@
 open Names
 
 (** Identifiers and names *)
-val pr_id : identifier -> Pp.std_ppcmds
-val pr_name : name -> Pp.std_ppcmds
+val pr_id : Id.t -> Pp.std_ppcmds
+val pr_name : Name.t -> Pp.std_ppcmds
 
-val make_ident : string -> int option -> identifier
-val repr_ident : identifier -> string * int option
+val make_ident : string -> int option -> Id.t
+val repr_ident : Id.t -> string * int option
 
-val atompart_of_id : identifier -> string  (** remove trailing digits *)
-val root_of_id : identifier -> identifier (** remove trailing digits, ' and _ *)
+val atompart_of_id : Id.t -> string  (** remove trailing digits *)
+val root_of_id : Id.t -> Id.t (** remove trailing digits, ' and _ *)
 
-val add_suffix : identifier -> string -> identifier
-val add_prefix : string -> identifier -> identifier
+val add_suffix : Id.t -> string -> Id.t
+val add_prefix : string -> Id.t -> Id.t
 
-val has_subscript    : identifier -> bool
-val lift_subscript   : identifier -> identifier
-val forget_subscript : identifier -> identifier
+val has_subscript    : Id.t -> bool
+val lift_subscript   : Id.t -> Id.t
+val forget_subscript : Id.t -> Id.t
 
-val out_name : name -> identifier
+val out_name : Name.t -> Id.t
+(** [out_name] associates [id] to [Name id]. Raises [Failure "Nameops.out_name"]
+    otherwise. *)
 
-val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a
-val name_iter : (identifier -> unit) -> name -> unit
-val name_cons : name -> identifier list -> identifier list
-val name_app : (identifier -> identifier) -> name -> name
-val name_fold_map : ('a -> identifier -> 'a * identifier) -> 'a -> name -> 'a * name
+val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a
+val name_iter : (Id.t -> unit) -> Name.t -> unit
+val name_cons : Name.t -> Id.t list -> Id.t list
+val name_app : (Id.t -> Id.t) -> Name.t -> Name.t
+val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t
 
 
-val pr_lab : label -> Pp.std_ppcmds
+val pr_lab : Label.t -> Pp.std_ppcmds
 
 (** some preset paths *)
 
-val default_library : dir_path
+val default_library : DirPath.t
 
 (** This is the root of the standard library of Coq *)
-val coq_root : module_ident
+val coq_root : module_ident (** "Coq" *)
+val coq_string : string (** "Coq" *)
 
 (** This is the default root prefix for developments which doesn't
    mention a root *)
-val default_root_prefix : dir_path
+val default_root_prefix : DirPath.t
 
 (** Metavariables *)
 val pr_meta : Term.metavariable -> Pp.std_ppcmds
diff --git a/library/nametab.ml b/library/nametab.ml
index 9e8b22b0..6af1e686 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -1,29 +1,24 @@
 (************************************************************************)
 (*  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 Compat
 open Pp
 open Names
 open Libnames
-open Nameops
-open Declarations
+open Globnames
 
 
 exception GlobalizationError of qualid
-exception GlobalizationConstantError of qualid
 
 let error_global_not_found_loc loc q =
   Loc.raise loc (GlobalizationError q)
 
-let error_global_constant_not_found_loc loc q =
-  Loc.raise loc (GlobalizationConstantError q)
-
 let error_global_not_found q = raise (GlobalizationError q)
 
 (* Kinds of global names *)
@@ -43,14 +38,20 @@ type visibility = Until of int | Exactly of int
 (* Data structure for nametabs *******************************************)
 
 
-(* This module type will be instantiated by [full_path] of [dir_path] *)
+(* This module type will be instantiated by [full_path] of [DirPath.t] *)
 (* The [repr] function is assumed to return the reversed list of idents. *)
 module type UserName = sig
   type t
+  val equal : t -> t -> bool
   val to_string : t -> string
-  val repr : t -> identifier * module_ident list
+  val repr : t -> Id.t * module_ident list
 end
 
+module type EqualityType =
+sig
+  type t
+  val equal : t -> t -> bool
+end
 
 (* A ['a t] is a map from [user_name] to ['a], with possible lookup by
    partially qualified names of type [qualid]. The mapping of
@@ -62,68 +63,76 @@ end
    the same object.
 *)
 module type NAMETREE = sig
-  type 'a t
+  type elt
+  type t
   type user_name
 
-  val empty : 'a t
-  val push : visibility -> user_name -> 'a -> 'a t -> 'a t
-  val locate : qualid -> 'a t -> 'a
-  val find : user_name -> 'a t -> 'a
-  val exists : user_name -> 'a t -> bool
-  val user_name : qualid -> 'a t -> user_name
-  val shortest_qualid : Idset.t -> user_name -> 'a t -> qualid
-  val find_prefixes : qualid -> 'a t -> 'a list
+  val empty : t
+  val push : visibility -> user_name -> elt -> t -> t
+  val locate : qualid -> t -> elt
+  val find : user_name -> t -> elt
+  val exists : user_name -> t -> bool
+  val user_name : qualid -> t -> user_name
+  val shortest_qualid : Id.Set.t -> user_name -> t -> qualid
+  val find_prefixes : qualid -> t -> elt list
 end
 
-module Make(U:UserName) : NAMETREE with type user_name = U.t
-				     =
+module Make (U : UserName) (E : EqualityType) : NAMETREE
+  with type user_name = U.t and type elt = E.t =
 struct
+  type elt = E.t
 
   type user_name = U.t
 
-  type 'a path_status =
+  type path_status =
       Nothing
-    | Relative of user_name * 'a
-    | Absolute of user_name * 'a
+    | Relative of user_name * elt
+    | Absolute of user_name * elt
 
   (* Dictionaries of short names *)
-  type 'a nametree = ('a path_status * 'a nametree ModIdmap.t)
+  type nametree =
+      { path : path_status;
+	map : nametree ModIdmap.t }
 
-  type 'a t = 'a nametree Idmap.t
+  let mktree p m = { path=p; map=m }
+  let empty_tree = mktree Nothing ModIdmap.empty
 
-  let empty = Idmap.empty
+  type t = nametree Id.Map.t
+
+  let empty = Id.Map.empty
 
   (* [push_until] is used to register [Until vis] visibility and
      [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*)
 
-  let rec push_until uname o level (current,dirmap) = function
+  let rec push_until uname o level tree = function
     | modid :: path ->
-	let mc =
-	  try ModIdmap.find modid dirmap
-	  with Not_found -> (Nothing, ModIdmap.empty)
-	in
+        let modify _ mc = push_until uname o (level-1) mc path in
+        let map =
+          try ModIdmap.modify modid modify tree.map
+          with Not_found ->
+            let ptab = modify () empty_tree in
+            ModIdmap.add modid ptab tree.map
+        in
 	let this =
           if level <= 0 then
-	    match current with
+	    match tree.path with
 	      | Absolute (n,_) ->
 		  (* This is an absolute name, we must keep it
 		     otherwise it may become unaccessible forever *)
-		  Flags.if_warn
 		    msg_warning (str ("Trying to mask the absolute name \""
 			     ^ U.to_string n ^ "\"!"));
-		  current
+		  tree.path
 	      | Nothing
 	      | Relative _ -> Relative (uname,o)
-          else current
+          else tree.path
 	in
-	let ptab' = push_until uname o (level-1) mc path in
-	  (this, ModIdmap.add modid ptab' dirmap)
+	mktree this map
     | [] ->
-	match current with
+	match tree.path with
 	  | Absolute (uname',o') ->
-	      if o'=o then begin
-		assert (uname=uname');
-		current, dirmap
+	      if E.equal o' o then begin
+		assert (U.equal uname uname');
+		tree
 		  (* we are putting the same thing for the second time :) *)
 	      end
 	      else
@@ -133,56 +142,56 @@ struct
 		error ("Cannot mask the absolute name \""
 		       ^ U.to_string uname' ^ "\"!")
 	  | Nothing
-	  | Relative _ -> Absolute (uname,o), dirmap
-
-
-let rec push_exactly uname o level (current,dirmap) = function
-  | modid :: path ->
-      let mc =
-	try ModIdmap.find modid dirmap
-	with Not_found -> (Nothing, ModIdmap.empty)
-      in
-        if level = 0 then
-	  let this =
-	    match current with
-	      | Absolute (n,_) ->
-		  (* This is an absolute name, we must keep it
-		     otherwise it may become unaccessible forever *)
-		  Flags.if_warn
-		    msg_warning (str ("Trying to mask the absolute name \""
-			     ^ U.to_string n ^ "\"!"));
-		  current
-	      | Nothing
-	      | Relative _ -> Relative (uname,o)
-	  in
-	    (this, dirmap)
-	else (* not right level *)
-	  let ptab' = push_exactly uname o (level-1) mc path in
-	    (current, ModIdmap.add modid ptab' dirmap)
-  | [] ->
-      anomaly "Prefix longer than path! Impossible!"
+	  | Relative _ -> mktree (Absolute (uname,o)) tree.map
+
+
+let rec push_exactly uname o level tree = function
+| [] ->
+  anomaly (Pp.str "Prefix longer than path! Impossible!")
+| modid :: path ->
+  if Int.equal level 0 then
+    let this =
+      match tree.path with
+        | Absolute (n,_) ->
+            (* This is an absolute name, we must keep it
+                otherwise it may become unaccessible forever *)
+              msg_warning (str ("Trying to mask the absolute name \""
+                        ^ U.to_string n ^ "\"!"));
+            tree.path
+        | Nothing
+        | Relative _ -> Relative (uname,o)
+    in
+    mktree this tree.map
+  else (* not right level *)
+    let modify _ mc = push_exactly uname o (level-1) mc path in
+    let map =
+      try ModIdmap.modify modid modify tree.map
+      with Not_found ->
+        let ptab = modify () empty_tree in
+        ModIdmap.add modid ptab tree.map
+    in
+    mktree tree.path map
 
 
 let push visibility uname o tab =
   let id,dir = U.repr uname in
-  let ptab =
-    try Idmap.find id tab
-    with Not_found -> (Nothing, ModIdmap.empty)
-  in
-  let ptab' = match visibility with
+  let modify _ ptab = match visibility with
     | Until i -> push_until uname o (i-1) ptab dir
     | Exactly i -> push_exactly uname o (i-1) ptab dir
   in
-    Idmap.add id ptab' tab
+  try Id.Map.modify id modify tab
+  with Not_found ->
+    let ptab = modify () empty_tree in
+    Id.Map.add id ptab tab
 
 
-let rec search (current,modidtab) = function
-  | modid :: path -> search (ModIdmap.find modid modidtab) path
-  | [] -> current
+let rec search tree = function
+  | modid :: path -> search (ModIdmap.find modid tree.map) path
+  | [] -> tree.path
 
 let find_node qid tab =
   let (dir,id) = repr_qualid qid in
-    search (Idmap.find id tab) (repr_dirpath dir)
+    search (Id.Map.find id tab) (DirPath.repr dir)
 
 let locate qid tab =
   let o = match find_node qid tab with
@@ -200,7 +209,7 @@ let user_name qid tab =
 
 let find uname tab =
   let id,l = U.repr uname in
-    match search (Idmap.find id tab) l with
+    match search (Id.Map.find id tab) l with
 	Absolute (_,o) -> o
       | _ -> raise Not_found
 
@@ -213,36 +222,38 @@ let exists uname tab =
 
 let shortest_qualid ctx uname tab =
   let id,dir = U.repr uname in
-  let hidden = Idset.mem id ctx in
-  let rec find_uname pos dir (path,tab) = match path with
+  let hidden = Id.Set.mem id ctx in
+  let rec find_uname pos dir tree =
+    let is_empty = match pos with [] -> true | _ -> false in
+    match tree.path with
     | Absolute (u,_) | Relative (u,_)
-          when u=uname && not(pos=[] && hidden) -> List.rev pos
+          when U.equal u uname && not (is_empty && hidden) -> List.rev pos
     | _ ->
 	match dir with
 	    [] -> raise Not_found
-	  | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tab)
+	  | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tree.map)
   in
-  let ptab = Idmap.find id tab in
+  let ptab = Id.Map.find id tab in
   let found_dir = find_uname [] dir ptab in
-    make_qualid (make_dirpath found_dir) id
+    make_qualid (DirPath.make found_dir) id
 
 let push_node node l =
   match node with
-  | Absolute (_,o) | Relative (_,o) when not (List.mem o l) -> o::l
+  | Absolute (_,o) | Relative (_,o) when not (List.mem_f E.equal o l) -> o::l
   | _ -> l
 
 let rec flatten_idmap tab l =
-  ModIdmap.fold (fun _ (current,idtab) l ->
-    flatten_idmap idtab (push_node current l)) tab l
+  let f _ tree l = flatten_idmap tree.map (push_node tree.path l) in
+  ModIdmap.fold f tab l
 
-let rec search_prefixes (current,modidtab) = function
-  | modid :: path -> search_prefixes (ModIdmap.find modid modidtab) path
-  | [] -> List.rev (flatten_idmap  modidtab (push_node current []))
+let rec search_prefixes tree = function
+  | modid :: path -> search_prefixes (ModIdmap.find modid tree.map) path
+  | [] -> List.rev (flatten_idmap tree.map (push_node tree.path []))
 
 let find_prefixes qid tab =
   try
     let (dir,id) = repr_qualid qid in
-    search_prefixes (Idmap.find id tab) (repr_dirpath dir)
+    search_prefixes (Id.Map.find id tab) (DirPath.repr dir)
   with Not_found -> []
 
 end
@@ -251,49 +262,65 @@ end
 
 (* Global name tables *************************************************)
 
-module SpTab = Make (struct
-		       type t = full_path
-		       let to_string = string_of_path
-		       let repr sp =
-			 let dir,id = repr_path sp in
-			   id, (repr_dirpath dir)
-		     end)
+module FullPath =
+struct
+  type t = full_path
+  let equal = eq_full_path
+  let to_string = string_of_path
+  let repr sp =
+    let dir,id = repr_path sp in
+      id, (DirPath.repr dir)
+end
+
+module ExtRefEqual = ExtRefOrdered
+module KnEqual = Names.KerName
+module MPEqual = Names.ModPath
 
+module ExtRefTab = Make(FullPath)(ExtRefEqual)
+module KnTab = Make(FullPath)(KnEqual)
+module MPTab = Make(FullPath)(MPEqual)
 
-type ccitab = extended_global_reference SpTab.t
-let the_ccitab = ref (SpTab.empty : ccitab)
+type ccitab = ExtRefTab.t
+let the_ccitab = ref (ExtRefTab.empty : ccitab)
 
-type kntab = kernel_name SpTab.t
-let the_tactictab = ref (SpTab.empty : kntab)
+type kntab = KnTab.t
+let the_tactictab = ref (KnTab.empty : kntab)
 
-type mptab = module_path SpTab.t
-let the_modtypetab = ref (SpTab.empty : mptab)
+type mptab = MPTab.t
+let the_modtypetab = ref (MPTab.empty : mptab)
+
+module DirPath' =
+struct
+  include DirPath
+  let repr dir = match DirPath.repr dir with
+    | [] -> anomaly (Pp.str "Empty dirpath")
+    | id :: l -> (id, l)
+end
 
+module GlobDir =
+struct
+  type t = global_dir_reference
+  let equal = eq_global_dir_reference
+end
 
-module DirTab = Make(struct
-		       type t = dir_path
-		       let to_string = string_of_dirpath
-		       let repr dir = match repr_dirpath dir with
-			 | [] -> anomaly "Empty dirpath"
-			 | id::l -> (id,l)
-		     end)
+module DirTab = Make(DirPath')(GlobDir)
 
 (* If we have a (closed) module M having a submodule N, than N does not
    have the entry in [the_dirtab]. *)
-type dirtab = global_dir_reference DirTab.t
+type dirtab = DirTab.t
 let the_dirtab = ref (DirTab.empty : dirtab)
 
 
 (* Reversed name tables ***************************************************)
 
 (* This table translates extended_global_references back to section paths *)
-module Globrevtab = Map.Make(ExtRefOrdered)
+module Globrevtab = HMap.Make(ExtRefOrdered)
 
 type globrevtab = full_path Globrevtab.t
 let the_globrevtab = ref (Globrevtab.empty : globrevtab)
 
 
-type mprevtab = dir_path MPmap.t
+type mprevtab = DirPath.t MPmap.t
 let the_modrevtab = ref (MPmap.empty : mprevtab)
 
 type mptrevtab = full_path MPmap.t
@@ -312,19 +339,19 @@ let the_tacticrevtab = ref (KNmap.empty : knrevtab)
 let push_xref visibility sp xref =
   match visibility with
     | Until _ ->
-	the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab;
 	the_globrevtab := Globrevtab.add xref sp !the_globrevtab
     | _ ->
 	begin
-	  if SpTab.exists sp !the_ccitab then
-	    match SpTab.find sp !the_ccitab with
+	  if ExtRefTab.exists sp !the_ccitab then
+	    match ExtRefTab.find sp !the_ccitab with
 	      | TrueGlobal( ConstRef _) | TrueGlobal( IndRef _) |
 		    TrueGlobal( ConstructRef _) as xref ->
-		  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+		  the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab;
 	      | _ -> 
-		  the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+		  the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab;
 	    else
-	      the_ccitab := SpTab.push visibility sp xref !the_ccitab;
+	      the_ccitab := ExtRefTab.push visibility sp xref !the_ccitab;
 	end
 
 let push_cci visibility sp ref =
@@ -337,13 +364,13 @@ let push_syndef visibility sp kn =
 let push = push_cci
 
 let push_modtype vis sp kn =
-  the_modtypetab := SpTab.push vis sp kn !the_modtypetab;
+  the_modtypetab := MPTab.push vis sp kn !the_modtypetab;
   the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab
 
 (* This is for tactic definition names *)
 
 let push_tactic vis sp kn =
-  the_tactictab := SpTab.push vis sp kn !the_tactictab;
+  the_tactictab := KnTab.push vis sp kn !the_tactictab;
   the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab
 
 
@@ -359,22 +386,22 @@ let push_dir vis dir dir_ref =
 
 
 (* This should be used when syntactic definitions are allowed *)
-let locate_extended qid = SpTab.locate qid !the_ccitab
+let locate_extended qid = ExtRefTab.locate qid !the_ccitab
 
 (* This should be used when no syntactic definitions is expected *)
 let locate qid = match locate_extended qid with
   | TrueGlobal ref -> ref
   | SynDef _ -> raise Not_found
-let full_name_cci qid = SpTab.user_name qid !the_ccitab
+let full_name_cci qid = ExtRefTab.user_name qid !the_ccitab
 
 let locate_syndef qid = match locate_extended qid with
   | TrueGlobal _ -> raise Not_found
   | SynDef kn -> kn
 
-let locate_modtype qid = SpTab.locate qid !the_modtypetab
-let full_name_modtype qid = SpTab.user_name qid !the_modtypetab
+let locate_modtype qid = MPTab.locate qid !the_modtypetab
+let full_name_modtype qid = MPTab.user_name qid !the_modtypetab
 
-let locate_tactic qid = SpTab.locate qid !the_tactictab
+let locate_tactic qid = KnTab.locate qid !the_tactictab
 
 let locate_dir qid = DirTab.locate qid !the_dirtab
 
@@ -396,9 +423,15 @@ let locate_section qid =
 
 let locate_all qid =
   List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l)
-    (SpTab.find_prefixes qid !the_ccitab) []
+    (ExtRefTab.find_prefixes qid !the_ccitab) []
+
+let locate_extended_all qid = ExtRefTab.find_prefixes qid !the_ccitab
 
-let locate_extended_all qid = SpTab.find_prefixes qid !the_ccitab
+let locate_extended_all_tactic qid = KnTab.find_prefixes qid !the_tactictab
+
+let locate_extended_all_dir qid = DirTab.find_prefixes qid !the_dirtab
+
+let locate_extended_all_modtype qid = MPTab.find_prefixes qid !the_modtypetab
 
 (* Derived functions *)
 
@@ -408,11 +441,11 @@ let locate_constant qid =
     | _ -> raise Not_found
 
 let global_of_path sp =
-  match SpTab.find sp !the_ccitab with
+  match ExtRefTab.find sp !the_ccitab with
     | TrueGlobal ref -> ref
     | _ -> raise Not_found
 
-let extended_global_of_path sp = SpTab.find sp !the_ccitab
+let extended_global_of_path sp = ExtRefTab.find sp !the_ccitab
 
 let global r =
   let (loc,qid) = qualid_of_reference r in
@@ -427,7 +460,7 @@ let global r =
 
 (* Exists functions ********************************************************)
 
-let exists_cci sp = SpTab.exists sp !the_ccitab
+let exists_cci sp = ExtRefTab.exists sp !the_ccitab
 
 let exists_dir dir = DirTab.exists dir !the_dirtab
 
@@ -435,13 +468,15 @@ let exists_section = exists_dir
 
 let exists_module = exists_dir
 
-let exists_modtype sp = SpTab.exists sp !the_modtypetab
+let exists_modtype sp = MPTab.exists sp !the_modtypetab
+
+let exists_tactic kn = KnTab.exists kn !the_tactictab
 
 (* Reverse locate functions ***********************************************)
 
 let path_of_global ref =
   match ref with
-    | VarRef id -> make_path empty_dirpath id
+    | VarRef id -> make_path DirPath.empty id
     | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab
 
 let dirpath_of_global ref =
@@ -459,37 +494,37 @@ let dirpath_of_module mp =
 let path_of_tactic kn =
   KNmap.find kn !the_tacticrevtab
 
+let path_of_modtype mp =
+  MPmap.find mp !the_modtyperevtab
+
 (* Shortest qualid functions **********************************************)
 
 let shortest_qualid_of_global ctx ref =
   match ref with
-    | VarRef id -> make_qualid empty_dirpath id
+    | VarRef id -> make_qualid DirPath.empty id
     | _ ->
         let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in
-        SpTab.shortest_qualid ctx sp !the_ccitab
+        ExtRefTab.shortest_qualid ctx sp !the_ccitab
 
 let shortest_qualid_of_syndef ctx kn =
   let sp = path_of_syndef kn in
-    SpTab.shortest_qualid ctx sp !the_ccitab
+    ExtRefTab.shortest_qualid ctx sp !the_ccitab
 
 let shortest_qualid_of_module mp =
   let dir = MPmap.find mp !the_modrevtab in
-    DirTab.shortest_qualid Idset.empty dir !the_dirtab
+    DirTab.shortest_qualid Id.Set.empty dir !the_dirtab
 
 let shortest_qualid_of_modtype kn =
   let sp = MPmap.find kn !the_modtyperevtab in
-    SpTab.shortest_qualid Idset.empty sp !the_modtypetab
+    MPTab.shortest_qualid Id.Set.empty sp !the_modtypetab
 
 let shortest_qualid_of_tactic kn =
   let sp = KNmap.find kn !the_tacticrevtab in
-    SpTab.shortest_qualid Idset.empty sp !the_tactictab
+    KnTab.shortest_qualid Id.Set.empty sp !the_tactictab
 
 let pr_global_env env ref =
-  (* Il est important de laisser le let-in, car les streams s'évaluent
-  paresseusement : il faut forcer l'évaluation pour capturer
-  l'éventuelle levée d'une exception (le cas échoit dans le debugger) *)
-  let s = string_of_qualid (shortest_qualid_of_global env ref) in
-  (str s)
+  try str (string_of_qualid (shortest_qualid_of_global env ref))
+  with Not_found as e -> prerr_endline "pr_global_env not found"; raise e
 
 let global_inductive r =
   match global r with
@@ -504,22 +539,10 @@ let global_inductive r =
 (********************************************************************)
 (* Registration of tables as a global table and rollback            *)
 
-type frozen = ccitab * dirtab * kntab * kntab
-    * globrevtab * mprevtab * knrevtab * knrevtab
-
-let init () =
-  the_ccitab := SpTab.empty;
-  the_dirtab := DirTab.empty;
-  the_modtypetab := SpTab.empty;
-  the_tactictab := SpTab.empty;
-  the_globrevtab := Globrevtab.empty;
-  the_modrevtab := MPmap.empty;
-  the_modtyperevtab := MPmap.empty;
-  the_tacticrevtab := KNmap.empty
-
-
+type frozen = ccitab * dirtab * mptab * kntab
+    * globrevtab * mprevtab * mptrevtab * knrevtab
 
-let freeze () =
+let freeze _ : frozen =
   !the_ccitab,
   !the_dirtab,
   !the_modtypetab,
@@ -543,7 +566,7 @@ let _ =
   Summary.declare_summary "names"
     { Summary.freeze_function = freeze;
       Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+      Summary.init_function = Summary.nop }
 
 (* Deprecated synonyms *)
 
diff --git a/library/nametab.mli b/library/nametab.mli
index 79ea119b..e3aeb675 100644
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -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 Util
 open Pp
 open Names
 open Libnames
+open Globnames
 
 (** This module contains the tables for globalization. *)
 
@@ -17,7 +17,7 @@ open Libnames
     qualified names (qualid). There are three classes of names:
 
     - 1a) internal kernel names: [kernel_name], [constant], [inductive],
-         [module_path], [dir_path]
+         [module_path], [DirPath.t]
 
     - 1b) other internal names: [global_reference], [syndef_name],
         [extended_global_reference], [global_dir_reference], ...
@@ -33,7 +33,7 @@ open Libnames
 
      Registers the [object_reference] to be referred to by the
      [full_user_name] (and its suffixes according to [visibility]).
-     [full_user_name] can either be a [full_path] or a [dir_path].
+     [full_user_name] can either be a [full_path] or a [DirPath.t].
    }
    {- [exists : full_user_name -> bool]
 
@@ -51,19 +51,17 @@ open Libnames
    {- [shortest_qualid_of : object_reference -> user_name]
 
      The [user_name] can be for example the shortest non ambiguous [qualid] or
-     the [full_user_name] or [identifier]. Such a function can also have a
+     the [full_user_name] or [Id.t]. Such a function can also have a
      local context argument.}}
 
 *)
 
 
 exception GlobalizationError of qualid
-exception GlobalizationConstantError of qualid
 
 (** Raises a globalization error *)
-val error_global_not_found_loc : loc -> qualid -> 'a
+val error_global_not_found_loc : Loc.t -> qualid -> 'a
 val error_global_not_found     : qualid -> 'a
-val error_global_constant_not_found_loc : loc -> qualid -> 'a
 
 (** {6 Register visibility of things } *)
 
@@ -79,7 +77,7 @@ type visibility = Until of int | Exactly of int
 
 val push : visibility -> full_path -> global_reference -> unit
 val push_modtype : visibility -> full_path -> module_path -> unit
-val push_dir : visibility -> dir_path -> global_dir_reference -> unit
+val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit
 val push_syndef : visibility -> full_path -> syndef_name -> unit
 
 type ltac_constant = kernel_name
@@ -98,7 +96,7 @@ val locate_syndef : qualid -> syndef_name
 val locate_modtype : qualid -> module_path
 val locate_dir : qualid -> global_dir_reference
 val locate_module : qualid -> module_path
-val locate_section : qualid -> dir_path
+val locate_section : qualid -> DirPath.t
 val locate_tactic : qualid -> ltac_constant
 
 (** These functions globalize user-level references into global
@@ -113,6 +111,9 @@ val global_inductive : reference -> inductive
 
 val locate_all : qualid -> global_reference list
 val locate_extended_all : qualid -> extended_global_reference list
+val locate_extended_all_tactic : qualid -> ltac_constant list
+val locate_extended_all_dir : qualid -> global_dir_reference list
+val locate_extended_all_modtype : qualid -> module_path list
 
 (** Mapping a full path to a global reference *)
 
@@ -123,15 +124,16 @@ val extended_global_of_path : full_path -> extended_global_reference
 
 val exists_cci : full_path -> bool
 val exists_modtype : full_path -> bool
-val exists_dir : dir_path -> bool
-val exists_section : dir_path -> bool (** deprecated synonym of [exists_dir] *)
-val exists_module : dir_path -> bool (** deprecated synonym of [exists_dir] *)
+val exists_dir : DirPath.t -> bool
+val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *)
+val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *)
+val exists_tactic : full_path -> bool (** deprecated synonym of [exists_dir] *)
 
 (** {6 These functions locate qualids into full user names } *)
 
 val full_name_cci : qualid -> full_path
 val full_name_modtype : qualid -> full_path
-val full_name_module : qualid -> dir_path
+val full_name_module : qualid -> DirPath.t
 
 (** {6 Reverse lookup }
   Finding user names corresponding to the given
@@ -142,25 +144,28 @@ val full_name_module : qualid -> dir_path
 
 val path_of_syndef : syndef_name -> full_path
 val path_of_global : global_reference -> full_path
-val dirpath_of_module : module_path -> dir_path
+val dirpath_of_module : module_path -> DirPath.t
+val path_of_modtype : module_path -> full_path
 val path_of_tactic : ltac_constant -> full_path
 
 (** Returns in particular the dirpath or the basename of the full path
    associated to global reference *)
 
-val dirpath_of_global : global_reference -> dir_path
-val basename_of_global : global_reference -> identifier
+val dirpath_of_global : global_reference -> DirPath.t
+val basename_of_global : global_reference -> Id.t
 
-(** Printing of global references using names as short as possible *)
-val pr_global_env : Idset.t -> global_reference -> std_ppcmds
+(** Printing of global references using names as short as possible.
+    @raise Not_found when the reference is not in the global tables. *)
+val pr_global_env : Id.Set.t -> global_reference -> std_ppcmds
 
 
 (** The [shortest_qualid] functions given an object with [user_name]
    Coq.A.B.x, try to find the shortest among x, B.x, A.B.x and
-   Coq.A.B.x that denotes the same object. *)
+   Coq.A.B.x that denotes the same object.
+   @raise Not_found for unknown objects. *)
 
-val shortest_qualid_of_global : Idset.t -> global_reference -> qualid
-val shortest_qualid_of_syndef : Idset.t -> syndef_name -> qualid
+val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid
+val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid
 val shortest_qualid_of_modtype : module_path -> qualid
 val shortest_qualid_of_module : module_path -> qualid
 val shortest_qualid_of_tactic : ltac_constant -> qualid
diff --git a/library/states.ml b/library/states.ml
index 768fbb23..a1c2a095 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -1,46 +1,46 @@
 (************************************************************************)
 (*  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 Util
 open System
 
 type state = Lib.frozen * Summary.frozen
 
-let freeze () =
-  (Lib.freeze(), Summary.freeze_summaries())
+let summary_of_state = snd
+
+let freeze ~marshallable =
+  (Lib.freeze ~marshallable, Summary.freeze_summaries ~marshallable)
 
 let unfreeze (fl,fs) =
   Lib.unfreeze fl;
   Summary.unfreeze_summaries fs
 
 let (extern_state,intern_state) =
+  let ensure_suffix f = CUnix.make_suffix f ".coq" in
   let (raw_extern, raw_intern) =
-    extern_intern Coq_config.state_magic_number ".coq" in
+    extern_intern Coq_config.state_magic_number in
   (fun s ->
-    if !Flags.load_proofs <> Flags.Force then
-      Util.error "Write State only works with option -force-load-proofs";
-    raw_extern s (freeze())),
+    let s = ensure_suffix s in
+    raw_extern s (freeze ~marshallable:`Yes)),
   (fun s ->
-    unfreeze
-      (with_magic_number_check (raw_intern (Library.get_load_paths ())) s);
+    let s = ensure_suffix s in
+    let paths = Loadpath.get_paths () in
+    unfreeze (with_magic_number_check (raw_intern paths) s);
     Library.overwrite_library_filenames s)
 
 (* Rollback. *)
 
-let with_heavy_rollback f h x =
-  let st = freeze () in
-  try
-    f x
-  with reraise ->
-    let e = h reraise in (unfreeze st; raise e)
-
 let with_state_protection f x =
-  let st = freeze () in
+  let st = freeze ~marshallable:`No in
   try
     let a = f x in unfreeze st; a
   with reraise ->
-    (unfreeze st; raise reraise)
+    let reraise = Errors.push reraise in
+    (unfreeze st; iraise reraise)
+
+let with_state_protection_on_exception = Future.transactify
diff --git a/library/states.mli b/library/states.mli
index 9474d831..66de1490 100644
--- a/library/states.mli
+++ b/library/states.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        *)
@@ -17,19 +17,22 @@ val intern_state : string -> unit
 val extern_state : string -> unit
 
 type state
-val freeze : unit -> state
+val freeze : marshallable:Summary.marshallable -> state
 val unfreeze : state -> unit
 
-(** {6 Rollback } *)
+val summary_of_state : state -> Summary.frozen
 
-(** [with_heavy_rollback f x] applies [f] to [x] and restores the
-  state of the whole system as it was before the evaluation if an exception
-  is raised. *)
-val with_heavy_rollback : ('a -> 'b) -> (exn -> exn) -> 'a -> 'b
+(** {6 Rollback } *)
 
 (** [with_state_protection f x] applies [f] to [x] and restores the
-  state of the whole system as it was before the evaluation of f *)
+  state of the whole system as it was before applying [f] *)
 
 val with_state_protection : ('a -> 'b) -> 'a -> 'b
 
+(** [with_state_protection_on_exception f x] applies [f] to [x] and restores the
+  state of the whole system as it was before applying [f] only if an
+  exception is raised.  Unlike [with_state_protection] it also takes into
+  account the proof state *)
+
+val with_state_protection_on_exception : ('a -> 'b) -> 'a -> 'b
 
diff --git a/library/summary.ml b/library/summary.ml
index 4e7a1f8e..7e7628a1 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -1,25 +1,28 @@
 (************************************************************************)
 (*  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
 
+type marshallable = [ `Yes | `No | `Shallow ]
 type 'a summary_declaration = {
-  freeze_function : unit -> 'a;
+  freeze_function : marshallable -> 'a;
   unfreeze_function : 'a -> unit;
   init_function : unit -> unit }
 
-let summaries =
-  (Hashtbl.create 17 : (string, Dyn.t summary_declaration) Hashtbl.t)
+let summaries = ref Int.Map.empty
 
-let internal_declare_summary sumname sdecl =
-  let (infun,outfun) = Dyn.create sumname in
-  let dyn_freeze () = infun (sdecl.freeze_function())
+let mangle id = id ^ "-SUMMARY"
+
+let internal_declare_summary hash sumname sdecl =
+  let (infun, outfun) = Dyn.create (mangle sumname) in
+  let dyn_freeze b = infun (sdecl.freeze_function b)
   and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum)
   and dyn_init = sdecl.init_function in
   let ddecl = {
@@ -27,30 +30,148 @@ let internal_declare_summary sumname sdecl =
     unfreeze_function = dyn_unfreeze;
     init_function = dyn_init }
   in
-  if Hashtbl.mem summaries sumname then
-    anomalylabstrm "Summary.declare_summary"
-      (str "Cannot declare a summary twice: " ++ str sumname);
-  Hashtbl.add summaries sumname ddecl
+  summaries := Int.Map.add hash (sumname, ddecl) !summaries
+
+let all_declared_summaries = ref Int.Set.empty
+
+let summary_names = ref []
+let name_of_summary name =
+  try List.assoc name !summary_names
+  with Not_found -> "summary name not found"
 
 let declare_summary sumname decl =
-  internal_declare_summary (sumname^"-SUMMARY") decl
+  let hash = String.hash sumname in
+  let () = if Int.Map.mem hash !summaries then
+    let (name, _) = Int.Map.find hash !summaries in
+    anomaly ~label:"Summary.declare_summary"
+      (str "Colliding summary names: " ++ str sumname ++ str " vs. " ++ str name)
+  in
+  all_declared_summaries := Int.Set.add hash !all_declared_summaries;
+  summary_names := (hash, sumname) :: !summary_names;
+  internal_declare_summary hash sumname decl
+
+type frozen = {
+  summaries : (int * Dyn.t) list;
+  (** Ordered list w.r.t. the first component. *)
+  ml_module : Dyn.t option;
+  (** Special handling of the ml_module summary. *)
+}
 
-type frozen = Dyn.t Stringmap.t
+let empty_frozen = { summaries = []; ml_module = None; }
 
-let freeze_summaries () =
-  let m = ref Stringmap.empty in
-  Hashtbl.iter
-    (fun id decl -> m := Stringmap.add id (decl.freeze_function()) !m)
-    summaries;
-  !m
+let ml_modules = "ML-MODULES"
+let ml_modules_summary = String.hash ml_modules
 
+let freeze_summaries ~marshallable : frozen =
+  let fold id (_, decl) accu =
+    (* to debug missing Lazy.force
+    if marshallable <> `No then begin
+      prerr_endline ("begin marshalling " ^ id);
+      ignore(Marshal.to_string (decl.freeze_function marshallable) []);
+      prerr_endline ("end marshalling " ^ id);
+    end;
+    /debug *)
+    let state = decl.freeze_function marshallable in
+    if Int.equal id ml_modules_summary then { accu with ml_module = Some state }
+    else { accu with summaries = (id, state) :: accu.summaries }
+  in
+  Int.Map.fold_right fold !summaries empty_frozen
 
 let unfreeze_summaries fs =
-  Hashtbl.iter
-    (fun id decl ->
-       try decl.unfreeze_function (Stringmap.find id fs)
-       with Not_found -> decl.init_function())
-    summaries
+  (* The unfreezing of [ml_modules_summary] has to be anticipated since it
+   * may modify the content of [summaries] ny loading new ML modules *)
+  let (_, decl) =
+    try Int.Map.find ml_modules_summary !summaries
+    with Not_found -> anomaly (str "Undeclared summary " ++ str ml_modules)
+  in
+  let () = match fs.ml_module with
+  | None -> anomaly (str "Undeclared summary " ++ str ml_modules)
+  | Some state -> decl.unfreeze_function state
+  in
+  let fold id (_, decl) states =
+    if Int.equal id ml_modules_summary then states
+    else match states with
+    | [] ->
+      let () = decl.init_function () in
+      []
+    | (nid, state) :: rstates ->
+      if Int.equal id nid then
+        let () = decl.unfreeze_function state in rstates
+      else
+        let () = decl.init_function () in states
+  in
+  let fold id decl state =
+    try fold id decl state
+    with e when Errors.noncritical e ->
+      let e = Errors.push e in
+      Printf.eprintf "Error unfrezing summay %s\n%s\n%!"
+        (name_of_summary id) (Pp.string_of_ppcmds (Errors.iprint e));
+      iraise e
+  in
+  (** We rely on the order of the frozen list, and the order of folding *)
+  ignore (Int.Map.fold_left fold !summaries fs.summaries)
 
 let init_summaries () =
-  Hashtbl.iter (fun _ decl -> decl.init_function()) summaries
+  Int.Map.iter (fun _ (_, decl) -> decl.init_function ()) !summaries
+
+(** For global tables registered statically before the end of coqtop
+    launch, the following empty [init_function] could be used. *)
+
+let nop () = ()
+
+(** Selective freeze *)
+
+type frozen_bits = (int * Dyn.t) list
+
+let ids_of_string_list complement ids =
+  if not complement then List.map String.hash ids
+  else
+    let fold accu id =
+      let id = String.hash id in
+      Int.Set.remove id accu
+    in
+    let ids = List.fold_left fold !all_declared_summaries ids in
+    Int.Set.elements ids
+
+let freeze_summary ~marshallable ?(complement=false) ids =
+  let ids = ids_of_string_list complement ids in
+  List.map (fun id ->
+    let (_, summary) = Int.Map.find id !summaries in
+    id, summary.freeze_function marshallable)
+  ids
+
+let unfreeze_summary datas =
+  List.iter
+    (fun (id, data) ->
+      let (name, summary) = Int.Map.find id !summaries in
+      try summary.unfreeze_function data
+      with e ->
+        let e = Errors.push e in
+        prerr_endline ("Exception unfreezing " ^ name);
+        iraise e)
+  datas
+
+let surgery_summary { summaries; ml_module } bits =
+  let summaries = List.map (fun (id, _ as orig) ->
+      try id, List.assoc id bits
+      with Not_found -> orig)
+    summaries in
+  { summaries; ml_module }
+
+let project_summary { summaries; ml_module } ?(complement=false) ids =
+  let ids = ids_of_string_list complement ids in
+  List.filter (fun (id, _) -> List.mem id ids) summaries
+
+let pointer_equal l1 l2 =
+  CList.for_all2eq
+    (fun (id1,v1) (id2,v2) -> id1 = id2 && Dyn.pointer_equal v1 v2) l1 l2
+
+(** All-in-one reference declaration + registration *)
+
+let ref ?(freeze=fun _ r -> r) ~name x =
+  let r = ref x in
+  declare_summary name
+    { freeze_function = (fun b -> freeze b !r);
+      unfreeze_function = ((:=) r);
+      init_function = (fun () -> r := x) };
+  r
diff --git a/library/summary.mli b/library/summary.mli
index 9705af65..48c9390d 100644
--- a/library/summary.mli
+++ b/library/summary.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        *)
@@ -9,22 +9,65 @@
 (** This module registers the declaration of global tables, which will be kept
    in synchronization during the various backtracks of the system. *)
 
+type marshallable =
+  [ `Yes       (* Full data will be marshalled to disk                        *)
+  | `No        (* Full data will be store in memory, e.g. for Undo            *)
+  | `Shallow ] (* Only part of the data will be marshalled to a slave process *)
+
 type 'a summary_declaration = {
-  freeze_function : unit -> 'a;
+  (** freeze_function [true] is for marshalling to disk. 
+   *  e.g. lazy must be forced *)
+  freeze_function : marshallable -> 'a;
   unfreeze_function : 'a -> unit;
   init_function : unit -> unit }
 
+(** For tables registered during the launch of coqtop, the [init_function]
+    will be run only once, during an [init_summaries] done at the end of
+    coqtop initialization. For tables registered later (for instance
+    during a plugin dynlink), [init_function] is used when unfreezing
+    an earlier frozen state that doesn't contain any value for this table.
+
+    Beware: for tables registered dynamically after the initialization
+    of Coq, their init functions may not be run immediately. It is hence
+    the responsability of plugins to initialize themselves properly.
+*)
+
 val declare_summary : string -> 'a summary_declaration -> unit
 
+(** All-in-one reference declaration + summary registration.
+    It behaves just as OCaml's standard [ref] function, except
+    that a [declare_summary] is done, with [name] as string.
+    The [init_function] restores the reference to its initial value.
+    The [freeze_function] can be overridden *)
+
+val ref : ?freeze:(marshallable -> 'a -> 'a) -> name:string -> 'a -> 'a ref
+
+(** Special name for the summary of ML modules.  This summary entry is
+    special because its unfreeze may load ML code and hence add summary
+    entries.  Thus is has to be recognizable, and handled appropriately *)
+val ml_modules : string
+
+(** For global tables registered statically before the end of coqtop
+    launch, the following empty [init_function] could be used. *)
+
+val nop : unit -> unit
+
+(** The type [frozen] is a snapshot of the states of all the registered
+    tables of the system. *)
+
 type frozen
 
-val freeze_summaries : unit -> frozen
+val empty_frozen : frozen
+val freeze_summaries : marshallable:marshallable -> frozen
 val unfreeze_summaries : frozen -> unit
 val init_summaries : unit -> unit
 
-(** Beware: if some code is dynamically loaded via dynlink after the
-    initialization of Coq, the init functions of any summary declared
-    by this code may not be run. It is hence the responsability of
-    plugins to initialize themselves properly.
-*)
+(** The type [frozen_bits] is a snapshot of some of the registered tables *)
+type frozen_bits
 
+val freeze_summary :
+  marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits
+val unfreeze_summary : frozen_bits -> unit
+val surgery_summary : frozen -> frozen_bits -> frozen
+val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits
+val pointer_equal : frozen_bits -> frozen_bits -> bool
diff --git a/library/universes.ml b/library/universes.ml
new file mode 100644
index 00000000..79070763
--- /dev/null
+++ b/library/universes.ml
@@ -0,0 +1,1006 @@
+(************************************************************************)
+(*  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 Util
+open Pp
+open Names
+open Term
+open Environ
+open Univ
+
+type universe_names = 
+    Univ.universe_level Idmap.t * Id.t Univ.LMap.t
+
+let global_universes = Summary.ref ~name:"Global universe names" 
+  ((Idmap.empty, Univ.LMap.empty) : universe_names)
+
+let global_universe_names () = !global_universes
+let set_global_universe_names s = global_universes := s
+
+let pr_with_global_universes l = 
+  try Nameops.pr_id (LMap.find l (snd !global_universes))
+  with Not_found -> Level.pr l
+
+type universe_constraint_type = ULe | UEq | ULub
+
+type universe_constraint = universe * universe_constraint_type * universe
+
+module Constraints = struct
+  module S = Set.Make(
+  struct 
+    type t = universe_constraint
+
+    let compare_type c c' =
+      match c, c' with
+      | ULe, ULe -> 0
+      | ULe, _ -> -1
+      | _, ULe -> 1
+      | UEq, UEq -> 0
+      | UEq, _ -> -1
+      | ULub, ULub -> 0
+      | ULub, _ -> 1
+      
+    let compare (u,c,v) (u',c',v') =
+      let i = compare_type c c' in
+	if Int.equal i 0 then
+	  let i' = Universe.compare u u' in
+	    if Int.equal i' 0 then Universe.compare v v'
+	    else 
+	      if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0
+	      else i'
+	else i
+  end)
+  
+  include S
+  
+  let add (l,d,r as cst) s = 
+    if Universe.equal l r then s
+    else add cst s
+
+  let tr_dir = function
+    | ULe -> Le
+    | UEq -> Eq
+    | ULub -> Eq
+
+  let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ "
+
+  let pr c =
+    fold (fun (u1,op,u2) pp_std ->
+	pp_std ++ Universe.pr u1 ++ str (op_str op) ++
+	Universe.pr u2 ++ fnl ()) c (str "")
+
+  let equal x y = 
+    x == y || equal x y
+
+end
+
+type universe_constraints = Constraints.t
+type 'a universe_constrained = 'a * universe_constraints
+
+type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints
+
+let enforce_eq_instances_univs strict x y c = 
+  let d = if strict then ULub else UEq in
+  let ax = Instance.to_array x and ay = Instance.to_array y in
+    if Array.length ax != Array.length ay then
+      Errors.anomaly (Pp.str "Invalid argument: enforce_eq_instances_univs called with" ++
+	       Pp.str " instances of different lengths");
+    CArray.fold_right2
+      (fun x y -> Constraints.add (Universe.make x, d, Universe.make y))
+      ax ay c
+
+let subst_univs_universe_constraint fn (u,d,v) =
+  let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in
+    if Universe.equal u' v' then None
+    else Some (u',d,v')
+
+let subst_univs_universe_constraints subst csts =
+  Constraints.fold 
+    (fun c -> Option.fold_right Constraints.add (subst_univs_universe_constraint subst c))
+    csts Constraints.empty 
+
+
+let to_constraints g s = 
+  let tr (x,d,y) acc =
+    let add l d l' acc = Constraint.add (l,Constraints.tr_dir d,l') acc in
+      match Universe.level x, d, Universe.level y with
+      | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc
+      | _, ULe, Some l' -> enforce_leq x y acc
+      | _, ULub, _ -> acc
+      | _, d, _ -> 
+	let f = if d == ULe then check_leq else check_eq in
+	  if f g x y then acc else 
+	    raise (Invalid_argument 
+		   "to_constraints: non-trivial algebraic constraint between universes")
+  in Constraints.fold tr s Constraint.empty
+
+let eq_constr_univs_infer univs m n =
+  if m == n then true, Constraints.empty
+  else 
+    let cstrs = ref Constraints.empty in
+    let eq_universes strict = Univ.Instance.check_eq univs in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else
+	    (cstrs := Constraints.add (u1, UEq, u2) !cstrs;
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in
+      res, !cstrs
+
+let leq_constr_univs_infer univs m n =
+  if m == n then true, Constraints.empty
+  else 
+    let cstrs = ref Constraints.empty in
+    let eq_universes strict l l' = Univ.Instance.check_eq univs l l' in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_eq univs u1 u2 then true
+	  else (cstrs := Constraints.add (u1, UEq, u2) !cstrs;
+		true)
+    in
+    let leq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else 
+	let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
+	  if Univ.check_leq univs u1 u2 then true
+	  else
+	    (cstrs := Constraints.add (u1, ULe, u2) !cstrs; 
+	     true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      Constr.compare_head_gen_leq eq_universes eq_sorts leq_sorts 
+	eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+    let res = compare_leq m n in
+      res, !cstrs
+
+let eq_constr_universes m n =
+  if m == n then true, Constraints.empty
+  else 
+    let cstrs = ref Constraints.empty in
+    let eq_universes strict l l' = 
+      cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	(cstrs := Constraints.add 
+	   (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs;
+	 true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in
+      res, !cstrs
+
+let leq_constr_universes m n =
+  if m == n then true, Constraints.empty
+  else 
+    let cstrs = ref Constraints.empty in
+    let eq_universes strict l l' = 
+      cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else (cstrs := Constraints.add 
+	      (Sorts.univ_of_sort s1,UEq,Sorts.univ_of_sort s2) !cstrs; 
+	    true)
+    in
+    let leq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else 
+	(cstrs := Constraints.add 
+	   (Sorts.univ_of_sort s1,ULe,Sorts.univ_of_sort s2) !cstrs; 
+	 true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n
+    in
+    let rec compare_leq m n =
+      Constr.compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n
+    and leq_constr' m n = m == n || compare_leq m n in
+    let res = compare_leq m n in
+      res, !cstrs
+
+let compare_head_gen_proj env equ eqs eqc' m n =
+  match kind_of_term m, kind_of_term n with
+  | Proj (p, c), App (f, args)
+  | App (f, args), Proj (p, c) -> 
+    (match kind_of_term f with
+    | Const (p', u) when eq_constant (Projection.constant p) p' -> 
+      let pb = Environ.lookup_projection p env in
+      let npars = pb.Declarations.proj_npars in
+	if Array.length args == npars + 1 then
+	  eqc' c args.(npars)
+	else false
+    | _ -> false)
+  | _ -> Constr.compare_head_gen equ eqs eqc' m n
+    
+let eq_constr_universes_proj env m n =
+  if m == n then true, Constraints.empty
+  else 
+    let cstrs = ref Constraints.empty in
+    let eq_universes strict l l' = 
+      cstrs := enforce_eq_instances_univs strict l l' !cstrs; true in
+    let eq_sorts s1 s2 = 
+      if Sorts.equal s1 s2 then true
+      else
+	(cstrs := Constraints.add 
+	   (Sorts.univ_of_sort s1, UEq, Sorts.univ_of_sort s2) !cstrs;
+	 true)
+    in
+    let rec eq_constr' m n = 
+      m == n ||	compare_head_gen_proj env eq_universes eq_sorts eq_constr' m n
+    in
+    let res = eq_constr' m n in
+      res, !cstrs
+
+(* Generator of levels *)
+let new_univ_level, set_remote_new_univ_level =
+  RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1)
+    ~build:(fun n -> Univ.Level.make (Global.current_dirpath ()) n)
+
+let new_univ_level _ = new_univ_level ()
+  (* Univ.Level.make db (new_univ_level ()) *)
+
+let fresh_level () = new_univ_level (Global.current_dirpath ())
+
+(* TODO: remove *)
+let new_univ dp = Univ.Universe.make (new_univ_level dp)
+let new_Type dp = mkType (new_univ dp)
+let new_Type_sort dp = Type (new_univ dp)
+
+let fresh_universe_instance ctx =
+  Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) 
+    (UContext.instance ctx)
+
+let fresh_instance_from_context ctx =
+  let inst = fresh_universe_instance ctx in
+  let constraints = instantiate_univ_constraints inst ctx in
+    inst, constraints
+
+let fresh_instance ctx =
+  let ctx' = ref LSet.empty in
+  let inst = 
+    Instance.subst_fn (fun v -> 
+      let u = new_univ_level (Global.current_dirpath ()) in
+	ctx' := LSet.add u !ctx'; u) 
+      (UContext.instance ctx)
+  in !ctx', inst
+
+let existing_instance ctx inst = 
+  let () = 
+    let a1 = Instance.to_array inst 
+    and a2 = Instance.to_array (UContext.instance ctx) in
+    let len1 = Array.length a1 and len2 = Array.length a2 in 
+      if not (len1 == len2) then
+	Errors.errorlabstrm "Universes"
+	  (str "Polymorphic constant expected " ++ int len2 ++ 
+	     str" levels but was given " ++ int len1)
+      else ()
+  in LSet.empty, inst
+
+let fresh_instance_from ctx inst =
+  let ctx', inst = 
+    match inst with 
+    | Some inst -> existing_instance ctx inst
+    | None -> fresh_instance ctx 
+  in
+  let constraints = instantiate_univ_constraints inst ctx in
+    inst, (ctx', constraints)
+
+let unsafe_instance_from ctx =
+  (Univ.UContext.instance ctx, ctx)
+    
+(** Fresh universe polymorphic construction *)
+
+let fresh_constant_instance env c inst =
+  let cb = lookup_constant c env in
+    if cb.Declarations.const_polymorphic then
+      let inst, ctx =
+        fresh_instance_from
+          (Declareops.universes_of_constant (Environ.opaque_tables env) cb) inst
+      in
+	((c, inst), ctx)
+    else ((c,Instance.empty), ContextSet.empty)
+
+let fresh_inductive_instance env ind inst = 
+  let mib, mip = Inductive.lookup_mind_specif env ind in
+    if mib.Declarations.mind_polymorphic then
+      let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in
+	((ind,inst), ctx)
+    else ((ind,Instance.empty), ContextSet.empty)
+
+let fresh_constructor_instance env (ind,i) inst = 
+  let mib, mip = Inductive.lookup_mind_specif env ind in
+    if mib.Declarations.mind_polymorphic then
+      let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in
+	(((ind,i),inst), ctx)
+    else (((ind,i),Instance.empty), ContextSet.empty)
+
+let unsafe_constant_instance env c =
+  let cb = lookup_constant c env in
+    if cb.Declarations.const_polymorphic then
+      let inst, ctx = unsafe_instance_from
+        (Declareops.universes_of_constant (Environ.opaque_tables env) cb) in
+	((c, inst), ctx)
+    else ((c,Instance.empty), UContext.empty)
+
+let unsafe_inductive_instance env ind = 
+  let mib, mip = Inductive.lookup_mind_specif env ind in
+    if mib.Declarations.mind_polymorphic then
+      let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in
+	((ind,inst), ctx)
+    else ((ind,Instance.empty), UContext.empty)
+
+let unsafe_constructor_instance env (ind,i) = 
+  let mib, mip = Inductive.lookup_mind_specif env ind in
+    if mib.Declarations.mind_polymorphic then
+      let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in
+	(((ind,i),inst), ctx)
+    else (((ind,i),Instance.empty), UContext.empty)
+
+open Globnames
+
+let fresh_global_instance ?names env gr =
+  match gr with
+  | VarRef id -> mkVar id, ContextSet.empty
+  | ConstRef sp -> 
+     let c, ctx = fresh_constant_instance env sp names in
+       mkConstU c, ctx
+  | ConstructRef sp ->
+     let c, ctx = fresh_constructor_instance env sp names in
+       mkConstructU c, ctx
+  | IndRef sp -> 
+     let c, ctx = fresh_inductive_instance env sp names in
+       mkIndU c, ctx
+
+let fresh_constant_instance env sp = 
+  fresh_constant_instance env sp None
+
+let fresh_inductive_instance env sp = 
+  fresh_inductive_instance env sp None
+
+let fresh_constructor_instance env sp = 
+  fresh_constructor_instance env sp None
+
+let unsafe_global_instance env gr =
+  match gr with
+  | VarRef id -> mkVar id, UContext.empty
+  | ConstRef sp -> 
+     let c, ctx = unsafe_constant_instance env sp in
+       mkConstU c, ctx
+  | ConstructRef sp ->
+     let c, ctx = unsafe_constructor_instance env sp in
+       mkConstructU c, ctx
+  | IndRef sp -> 
+     let c, ctx = unsafe_inductive_instance env sp in
+       mkIndU c, ctx
+
+let constr_of_global gr =
+  let c, ctx = fresh_global_instance (Global.env ()) gr in
+    if not (Univ.ContextSet.is_empty ctx) then
+      if Univ.LSet.is_empty (Univ.ContextSet.levels ctx) then 
+	(* Should be an error as we might forget constraints, allow for now
+	   to make firstorder work with "using" clauses *)
+	c
+      else raise (Invalid_argument 
+		    ("constr_of_global: globalization of polymorphic reference " ^ 
+			Pp.string_of_ppcmds (Nametab.pr_global_env Id.Set.empty gr) ^
+			" would forget universes."))
+    else c
+
+let constr_of_reference = constr_of_global
+
+let unsafe_constr_of_global gr =
+  unsafe_global_instance (Global.env ()) gr
+
+let constr_of_global_univ (gr,u) =
+  match gr with
+  | VarRef id -> mkVar id
+  | ConstRef sp -> mkConstU (sp,u)
+  | ConstructRef sp -> mkConstructU (sp,u)
+  | IndRef sp -> mkIndU (sp,u)
+
+let fresh_global_or_constr_instance env = function
+  | IsConstr c -> c, ContextSet.empty
+  | IsGlobal gr -> fresh_global_instance env gr
+
+let global_of_constr c =
+  match kind_of_term c with
+  | Const (c, u) -> ConstRef c, u
+  | Ind (i, u) -> IndRef i, u
+  | Construct (c, u) -> ConstructRef c, u
+  | Var id -> VarRef id, Instance.empty
+  | _ -> raise Not_found
+
+let global_app_of_constr c =
+  match kind_of_term c with
+  | Const (c, u) -> (ConstRef c, u), None
+  | Ind (i, u) -> (IndRef i, u), None
+  | Construct (c, u) -> (ConstructRef c, u), None
+  | Var id -> (VarRef id, Instance.empty), None
+  | Proj (p, c) -> (ConstRef (Projection.constant p), Instance.empty), Some c
+  | _ -> raise Not_found
+
+open Declarations
+
+let type_of_reference env r =
+  match r with
+  | VarRef id -> Environ.named_type id env, ContextSet.empty
+  | ConstRef c ->
+     let cb = Environ.lookup_constant c env in
+     let ty = Typeops.type_of_constant_type env cb.const_type in
+       if cb.const_polymorphic then
+	 let inst, ctx = fresh_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) None in
+	   Vars.subst_instance_constr inst ty, ctx
+       else ty, ContextSet.empty
+
+  | IndRef ind ->
+     let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in
+       if mib.mind_polymorphic then
+	 let inst, ctx = fresh_instance_from mib.mind_universes None in
+	 let ty = Inductive.type_of_inductive env (specif, inst) in
+	   ty, ctx
+       else
+	 let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in
+	   ty, ContextSet.empty
+  | ConstructRef cstr ->
+     let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+       if mib.mind_polymorphic then
+	 let inst, ctx = fresh_instance_from mib.mind_universes None in
+	   Inductive.type_of_constructor (cstr,inst) specif, ctx
+       else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty
+
+let type_of_global t = type_of_reference (Global.env ()) t
+
+let unsafe_type_of_reference env r =
+  match r with
+  | VarRef id -> Environ.named_type id env
+  | ConstRef c ->
+     let cb = Environ.lookup_constant c env in
+       Typeops.type_of_constant_type env cb.const_type
+
+  | IndRef ind ->
+     let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in
+     let (_, inst), _ = unsafe_inductive_instance env ind in
+       Inductive.type_of_inductive env (specif, inst)
+
+  | ConstructRef (ind, _ as cstr) ->
+     let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+     let (_, inst), _ = unsafe_inductive_instance env ind in
+       Inductive.type_of_constructor (cstr,inst) specif
+
+let unsafe_type_of_global t = unsafe_type_of_reference (Global.env ()) t
+
+let fresh_sort_in_family env = function
+  | InProp -> prop_sort, ContextSet.empty
+  | InSet -> set_sort, ContextSet.empty
+  | InType -> 
+    let u = fresh_level () in
+      Type (Univ.Universe.make u), ContextSet.singleton u
+
+let new_sort_in_family sf =
+  fst (fresh_sort_in_family (Global.env ()) sf)
+
+let extend_context (a, ctx) (ctx') =
+  (a, ContextSet.union ctx ctx')
+
+let new_global_univ () =
+  let u = fresh_level () in
+    (Univ.Universe.make u, ContextSet.singleton u)
+
+(** Simplification *)
+
+module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap)
+
+let add_list_map u t map =
+  try
+    let l = LMap.find u map in
+    LMap.update u (t :: l) map
+  with Not_found ->
+    LMap.add u [t] map
+
+module UF = LevelUnionFind
+
+(** Precondition: flexible <= ctx *)
+let choose_canonical ctx flexible algs s =
+  let global = LSet.diff s ctx in
+  let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in
+    (** If there is a global universe in the set, choose it *)
+    if not (LSet.is_empty global) then
+      let canon = LSet.choose global in
+	canon, (LSet.remove canon global, rigid, flexible)
+    else (** No global in the equivalence class, choose a rigid one *)
+	if not (LSet.is_empty rigid) then
+	  let canon = LSet.choose rigid in
+	    canon, (global, LSet.remove canon rigid, flexible)
+	else (** There are only flexible universes in the equivalence
+		 class, choose a non-algebraic. *)
+	  let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in
+	    if not (LSet.is_empty nonalgs) then
+	      let canon = LSet.choose nonalgs in
+		canon, (global, rigid, LSet.remove canon flexible)
+	    else
+	      let canon = LSet.choose algs in
+		canon, (global, rigid, LSet.remove canon flexible)
+
+let subst_univs_fn_puniverses lsubst (c, u as cu) =
+  let u' = Instance.subst_fn lsubst u in
+    if u' == u then cu else (c, u')
+
+let nf_evars_and_universes_opt_subst f subst =
+  let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in
+  let lsubst = Univ.level_subst_of subst in
+  let rec aux c =
+    match kind_of_term c with
+    | Evar (evk, args) ->
+      let args = Array.map aux args in
+      (match try f (evk, args) with Not_found -> None with
+      | None -> c
+      | Some c -> aux c)
+    | Const pu -> 
+      let pu' = subst_univs_fn_puniverses lsubst pu in
+	if pu' == pu then c else mkConstU pu'
+    | Ind pu ->
+      let pu' = subst_univs_fn_puniverses lsubst pu in
+	if pu' == pu then c else mkIndU pu'
+    | Construct pu ->
+      let pu' = subst_univs_fn_puniverses lsubst pu in
+	if pu' == pu then c else mkConstructU pu'
+    | Sort (Type u) ->
+      let u' = Univ.subst_univs_universe subst u in
+	if u' == u then c else mkSort (sort_of_univ u')
+    | _ -> map_constr aux c
+  in aux
+
+let fresh_universe_context_set_instance ctx =
+  if ContextSet.is_empty ctx then LMap.empty, ctx
+  else
+    let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in
+    let univs',subst = LSet.fold
+      (fun u (univs',subst) ->
+	let u' = fresh_level () in
+	  (LSet.add u' univs', LMap.add u u' subst))
+      univs (LSet.empty, LMap.empty)
+    in
+    let cst' = subst_univs_level_constraints subst cst in
+      subst, (univs', cst')
+
+let normalize_univ_variable ~find ~update =
+  let rec aux cur =
+    let b = find cur in
+    let b' = subst_univs_universe aux b in
+      if Universe.equal b' b then b
+      else update cur b'
+  in aux
+
+let normalize_univ_variable_opt_subst ectx =
+  let find l = 
+    match Univ.LMap.find l !ectx with
+    | Some b -> b
+    | None -> raise Not_found
+  in
+  let update l b =
+    assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true);
+    ectx := Univ.LMap.add l (Some b) !ectx; b
+  in normalize_univ_variable ~find ~update
+
+let normalize_univ_variable_subst subst =
+  let find l = Univ.LMap.find l !subst in
+  let update l b =
+    assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true);
+    subst := Univ.LMap.add l b !subst; b in
+    normalize_univ_variable ~find ~update
+
+let normalize_universe_opt_subst subst =
+  let normlevel = normalize_univ_variable_opt_subst subst in
+    subst_univs_universe normlevel
+
+let normalize_universe_subst subst =
+  let normlevel = normalize_univ_variable_subst subst in
+    subst_univs_universe normlevel
+
+let normalize_opt_subst ctx = 
+  let ectx = ref ctx in
+  let normalize = normalize_univ_variable_opt_subst ectx in
+  let () =
+    Univ.LMap.iter (fun u v ->
+      if Option.is_empty v then ()
+      else try ignore(normalize u) with Not_found -> assert(false)) ctx 
+  in !ectx
+
+type universe_opt_subst = universe option universe_map
+	  
+let make_opt_subst s = 
+  fun x -> 
+    (match Univ.LMap.find x s with
+    | Some u -> u
+    | None -> raise Not_found)
+
+let subst_opt_univs_constr s = 
+  let f = make_opt_subst s in
+    Vars.subst_univs_fn_constr f
+
+
+let normalize_univ_variables ctx = 
+  let ctx = normalize_opt_subst ctx in
+  let undef, def, subst =
+    Univ.LMap.fold (fun u v (undef, def, subst) -> 
+      match v with
+      | None -> (Univ.LSet.add u undef, def, subst)
+      | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst))
+    ctx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty)
+  in ctx, undef, def, subst
+
+let pr_universe_body = function
+  | None -> mt ()
+  | Some v -> str" := " ++ Univ.Universe.pr v
+
+let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body
+
+exception Found of Level.t
+let find_inst insts v =
+  try LMap.iter (fun k (enf,alg,v') ->
+    if not alg && enf && Universe.equal v' v then raise (Found k))
+	insts; raise Not_found
+  with Found l -> l
+
+let compute_lbound left =
+ (** The universe variable was not fixed yet.
+     Compute its level using its lower bound. *)
+  let sup l lbound = 
+    match lbound with
+    | None -> Some l
+    | Some l' -> Some (Universe.sup l l')
+  in
+    List.fold_left (fun lbound (d, l) -> 
+      if d == Le (* l <= ?u *) then sup l lbound
+      else (* l < ?u *) 
+	(assert (d == Lt); 
+	 if not (Universe.level l == None) then
+	   sup (Universe.super l) lbound
+	 else None))
+      None left
+  
+let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) =
+  if enforce then
+    let inst = Universe.make u in
+    let cstrs' = enforce_leq lbound inst cstrs in
+      (ctx, us, LSet.remove u algs, 
+       LMap.add u (enforce,alg,lbound) insts, cstrs'), (enforce, alg, inst)
+  else (* Actually instantiate *)
+    (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs,
+     LMap.add u (enforce,alg,lbound) insts, cstrs), (enforce, alg, lbound)
+
+type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t
+
+let pr_constraints_map cmap =
+  LMap.fold (fun l cstrs acc -> 
+    Level.pr l ++ str " => " ++ 
+      prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl ()
+    ++ acc)
+    cmap (mt ())
+	
+let minimize_univ_variables ctx us algs left right cstrs =
+  let left, lbounds = 
+    Univ.LMap.fold (fun r lower (left, lbounds as acc)  ->
+      if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc
+      else (* Fixed universe, just compute its glb for sharing *)
+	let lbounds' = 
+	  match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with
+	  | None -> lbounds
+	  | Some lbound -> LMap.add r (true, false, lbound) lbounds
+	in (Univ.LMap.remove r left, lbounds'))
+      left (left, Univ.LMap.empty)
+  in
+  let rec instance (ctx', us, algs, insts, cstrs as acc) u =
+    let acc, left = 
+      try let l = LMap.find u left in
+	    List.fold_left (fun (acc, left') (d, l) -> 
+	      let acc', (enf,alg,l') = aux acc l in
+		(* if alg then assert(not alg); *)
+		let l' = 
+		  if enf then Universe.make l 
+		  else l' 
+		(* match Universe.level l' with Some _ -> l' | None -> Universe.make l  *)
+		in
+		  acc', (d, l') :: left') (acc, []) l
+      with Not_found -> acc, []
+    and right =
+      try Some (LMap.find u right)
+      with Not_found -> None
+    in
+    let instantiate_lbound lbound =
+      let alg = LSet.mem u algs in
+      if alg then
+	 (* u is algebraic and has no upper bound constraints: we
+	    instantiate it with it's lower bound, if any *)
+	 instantiate_with_lbound u lbound true false acc
+      else (* u is non algebraic *)
+	match Universe.level lbound with
+	| Some l -> (* The lowerbound is directly a level *) 
+	  (* u is not algebraic but has no upper bounds,
+	     we instantiate it with its lower bound if it is a 
+	     different level, otherwise we keep it. *)
+	  if not (Level.equal l u) && not (LSet.mem l algs) then
+	    (* if right = None then. Should check that u does not 
+	       have upper constraints that are not already in right *)
+	      instantiate_with_lbound u lbound false false acc
+	    (* else instantiate_with_lbound u lbound false true acc *)
+	  else
+	    (* assert false: l can't be alg *)
+	    acc, (true, false, lbound)
+	| None -> 
+	  try 
+	    (* if right <> None then raise Not_found; *)
+	    (* Another universe represents the same lower bound, 
+	       we can share them with no harm. *)
+	    let can = find_inst insts lbound in
+	      instantiate_with_lbound u (Universe.make can) false false acc
+	  with Not_found -> 
+	    (* We set u as the canonical universe representing lbound *)
+	    instantiate_with_lbound u lbound false true acc
+    in
+    let acc' acc = 
+      match right with
+      | None -> acc
+      | Some cstrs -> 
+	let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in
+	  if List.is_empty dangling then acc
+	  else
+	    let ((ctx', us, algs, insts, cstrs), (enf,_,inst as b)) = acc in
+	    let cstrs' = List.fold_left (fun cstrs (d, r) -> 
+	      if d == Univ.Le then
+		enforce_leq inst (Universe.make r) cstrs
+	      else 
+		try let lev = Option.get (Universe.level inst) in
+		      Constraint.add (lev, d, r) cstrs
+		with Option.IsNone -> assert false)
+	      cstrs dangling
+	    in
+	      (ctx', us, algs, insts, cstrs'), b
+    in
+      if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u))
+      else
+	let lbound = compute_lbound left in
+	  match lbound with
+	  | None -> (* Nothing to do *)
+	    acc' (acc, (true, false, Universe.make u))
+	  | Some lbound ->
+	    acc' (instantiate_lbound lbound)
+  and aux (ctx', us, algs, seen, cstrs as acc) u =
+    try acc, LMap.find u seen 
+    with Not_found -> instance acc u
+  in
+    LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> 
+      if v == None then fst (aux acc u)
+      else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs)
+      us (ctx, us, algs, lbounds, cstrs)
+      
+let normalize_context_set ctx us algs = 
+  let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in
+  let uf = UF.create () in
+  let csts = 
+    (* We first put constraints in a normal-form: all self-loops are collapsed
+       to equalities. *)
+    let g = Univ.merge_constraints csts Univ.empty_universes in
+      Univ.constraints_of_universes g
+  in
+  let noneqs =
+    Constraint.fold (fun (l,d,r) noneqs ->
+      if d == Eq then (UF.union l r uf; noneqs) 
+      else Constraint.add (l,d,r) noneqs)
+    csts Constraint.empty
+  in
+  let partition = UF.partition uf in
+  let flex x = LMap.mem x us in
+  let ctx, subst, eqs = List.fold_left (fun (ctx, subst, cstrs) s -> 
+    let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in
+    (* Add equalities for globals which can't be merged anymore. *)
+    let cstrs = LSet.fold (fun g cst -> 
+      Constraint.add (canon, Univ.Eq, g) cst) global
+      cstrs 
+    in
+    let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in 
+    let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in 
+      (LSet.diff (LSet.diff ctx rigid) flexible, subst, cstrs))
+    (ctx, LMap.empty, Constraint.empty) partition
+  in
+  (* Noneqs is now in canonical form w.r.t. equality constraints, 
+     and contains only inequality constraints. *)
+  let noneqs = subst_univs_level_constraints subst noneqs in
+  let us = LMap.fold (fun u v acc -> LMap.add u (Some (Universe.make v)) acc) subst us in
+  (* Compute the left and right set of flexible variables, constraints
+     mentionning other variables remain in noneqs. *)
+  let noneqs, ucstrsl, ucstrsr = 
+    Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> 
+      let lus = LMap.mem l us 
+      and rus = LMap.mem r us
+      in
+      let ucstrsl' = 
+	if lus then add_list_map l (d, r) ucstrsl
+	else ucstrsl
+      and ucstrsr' = 
+	add_list_map r (d, l) ucstrsr
+      in 
+      let noneqs = 
+	if lus || rus then noneq 
+	else Constraint.add cstr noneq
+      in (noneqs, ucstrsl', ucstrsr'))
+    noneqs (Constraint.empty, LMap.empty, LMap.empty)
+  in
+  (* Now we construct the instantiation of each variable. *)
+  let ctx', us, algs, inst, noneqs = 
+    minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs
+  in
+  let us = normalize_opt_subst us in
+    (us, algs), (ctx', Constraint.union noneqs eqs)
+
+(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *)
+(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *)
+
+let universes_of_constr c =
+  let rec aux s c = 
+    match kind_of_term c with
+    | Const (_, u) | Ind (_, u) | Construct (_, u) ->
+      LSet.union (Instance.levels u) s
+    | Sort u when not (Sorts.is_small u) -> 
+      let u = univ_of_sort u in
+	LSet.union (Universe.levels u) s
+    | _ -> fold_constr aux s c
+  in aux LSet.empty c
+
+let restrict_universe_context (univs,csts) s =
+  (* Universes that are not necessary to typecheck the term.
+     E.g. univs introduced by tactics and not used in the proof term. *)
+  let diff = LSet.diff univs s in
+  let rec aux diff candid univs ness = 
+    let (diff', candid', univs', ness') = 
+      Constraint.fold
+	(fun (l, d, r as c) (diff, candid, univs, csts) ->
+	  if not (LSet.mem l diff) then
+	    (LSet.remove r diff, candid, univs, Constraint.add c csts)
+	  else if not (LSet.mem r diff) then
+	    (LSet.remove l diff, candid, univs, Constraint.add c csts)
+	  else (diff, Constraint.add c candid, univs, csts))
+	candid (diff, Constraint.empty, univs, ness)
+    in
+      if ness' == ness then (LSet.diff univs diff', ness)
+      else aux diff' candid' univs' ness'
+  in aux diff csts univs Constraint.empty
+
+let simplify_universe_context (univs,csts) =
+  let uf = UF.create () in
+  let noneqs =
+    Constraint.fold (fun (l,d,r) noneqs ->
+      if d == Eq && (LSet.mem l univs || LSet.mem r univs) then 
+	(UF.union l r uf; noneqs)
+      else Constraint.add (l,d,r) noneqs)
+      csts Constraint.empty
+  in
+  let partition = UF.partition uf in
+  let flex x = LSet.mem x univs in
+  let subst, univs', csts' = List.fold_left (fun (subst, univs, cstrs) s -> 
+    let canon, (global, rigid, flexible) = choose_canonical univs flex LSet.empty s in
+    (* Add equalities for globals which can't be merged anymore. *)
+    let cstrs = LSet.fold (fun g cst -> 
+      Constraint.add (canon, Univ.Eq, g) cst) (LSet.union global rigid)
+      cstrs 
+    in
+    let subst = LSet.fold (fun f -> LMap.add f canon)
+      flexible subst
+    in (subst, LSet.diff univs flexible, cstrs))
+    (LMap.empty, univs, noneqs) partition
+  in
+  (* Noneqs is now in canonical form w.r.t. equality constraints, 
+     and contains only inequality constraints. *)
+  let csts' = subst_univs_level_constraints subst csts' in
+    (univs', csts'), subst
+
+let is_small_leq (l,d,r) =
+  Level.is_small l && d == Univ.Le
+
+(* Prop < i <-> Set+1 <= i <-> Set < i *)
+let translate_cstr (l,d,r as cstr) =
+  if Level.equal Level.prop l && d == Univ.Lt then
+    (Level.set, d, r)
+  else cstr
+
+let refresh_constraints univs (ctx, cstrs) =
+  let cstrs', univs' = 
+    Univ.Constraint.fold (fun c (cstrs', univs as acc) -> 
+      let c = translate_cstr c in
+      if Univ.check_constraint univs c && not (is_small_leq c) then acc
+      else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs))
+      cstrs (Univ.Constraint.empty, univs)
+  in ((ctx, cstrs'), univs')
+
+
+(**********************************************************************)
+(* Tools for sort-polymorphic inductive types                         *)
+
+(* Miscellaneous functions to remove or test local univ assumed to
+   occur only in the le constraints *)
+
+(*
+   Solve a system of universe constraint of the form
+
+   u_s11, ..., u_s1p1, w1 <= u1
+   ...
+   u_sn1, ..., u_snpn, wn <= un
+
+where
+
+  - the ui (1 <= i <= n) are universe variables,
+  - the sjk select subsets of the ui for each equations,
+  - the wi are arbitrary complex universes that do not mention the ui.
+*)
+
+let is_direct_sort_constraint s v = match s with
+  | Some u -> univ_level_mem u v
+  | None -> false
+
+let solve_constraints_system levels level_bounds level_min =
+  let open Univ in
+  let levels =
+    Array.mapi (fun i o ->
+      match o with
+      | Some u ->
+	(match Universe.level u with 
+	| Some u -> Some u 
+	| _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None)
+      | None -> None)
+      levels in
+  let v = Array.copy level_bounds in
+  let nind = Array.length v in
+  let clos = Array.map (fun _ -> Int.Set.empty) levels in
+  (* First compute the transitive closure of the levels dependencies *)
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then
+	clos.(i) <- Int.Set.add j clos.(i);
+    done;
+  done;
+  let rec closure () = 
+    let continue = ref false in
+      Array.iteri (fun i deps -> 
+	let deps' = 
+	  Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps
+	in 
+	  if Int.Set.equal deps deps' then ()
+	  else (clos.(i) <- deps'; continue := true))
+	clos;
+      if !continue then closure ()
+      else ()
+  in 
+  closure ();
+  for i=0 to nind-1 do
+    for j=0 to nind-1 do
+      if not (Int.equal i j) && Int.Set.mem j clos.(i) then
+	(v.(i) <- Universe.sup v.(i) level_bounds.(j);
+	 level_min.(i) <- Universe.sup level_min.(i) level_min.(j))
+    done;
+    for j=0 to nind-1 do
+      match levels.(j) with
+      | Some u -> v.(i) <- univ_level_rem u v.(i) level_min.(i)
+      | None -> ()
+    done
+  done;
+  v
diff --git a/library/universes.mli b/library/universes.mli
new file mode 100644
index 00000000..f2f68d32
--- /dev/null
+++ b/library/universes.mli
@@ -0,0 +1,253 @@
+(************************************************************************)
+(*  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 Util
+open Pp
+open Names
+open Term
+open Context
+open Environ
+open Locus
+open Univ
+
+(** Universes *)
+
+type universe_names = 
+  Univ.universe_level Idmap.t * Id.t Univ.LMap.t
+
+val global_universe_names : unit -> universe_names
+val set_global_universe_names : universe_names -> unit
+
+val pr_with_global_universes : Level.t -> Pp.std_ppcmds
+
+(** The global universe counter *)
+val set_remote_new_univ_level : universe_level RemoteCounter.installer
+
+(** Side-effecting functions creating new universe levels. *)
+
+val new_univ_level : Names.dir_path -> universe_level
+val new_univ : Names.dir_path -> universe
+val new_Type : Names.dir_path -> types
+val new_Type_sort : Names.dir_path -> sorts
+
+val new_global_univ : unit -> universe in_universe_context_set
+val new_sort_in_family : sorts_family -> sorts
+
+(** {6 Constraints for type inference}
+    
+    When doing conversion of universes, not only do we have =/<= constraints but
+    also Lub constraints which correspond to unification of two levels which might
+    not be necessary if unfolding is performed.
+*)
+
+type universe_constraint_type = ULe | UEq | ULub
+
+type universe_constraint = universe * universe_constraint_type * universe
+module Constraints : sig
+  include Set.S with type elt = universe_constraint
+		       
+  val pr : t -> Pp.std_ppcmds
+end
+
+type universe_constraints = Constraints.t
+type 'a universe_constrained = 'a * universe_constraints
+type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints
+
+val subst_univs_universe_constraints : universe_subst_fn -> 
+  universe_constraints -> universe_constraints
+
+val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function
+
+val to_constraints : universes -> universe_constraints -> constraints
+
+(** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts,
+   application grouping, the universe constraints in [u] and additional constraints [c]. *)
+val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained
+
+(** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b]
+    modulo alpha, casts, application grouping, the universe constraints
+    in [u] and additional constraints [c]. *)
+val leq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained
+
+(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts,
+    application grouping and the universe constraints in [c]. *)
+val eq_constr_universes : constr -> constr -> bool universe_constrained
+
+(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo
+    alpha, casts, application grouping and the universe constraints in [c]. *)
+val leq_constr_universes : constr -> constr -> bool universe_constrained
+
+(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts,
+    application grouping and the universe constraints in [c]. *)
+val eq_constr_universes_proj : env -> constr -> constr -> bool universe_constrained
+
+(** Build a fresh instance for a given context, its associated substitution and 
+    the instantiated constraints. *)
+
+val fresh_instance_from_context : universe_context -> 
+  universe_instance constrained
+
+val fresh_instance_from : universe_context -> universe_instance option ->
+  universe_instance in_universe_context_set
+
+val fresh_sort_in_family : env -> sorts_family -> 
+  sorts in_universe_context_set
+val fresh_constant_instance : env -> constant ->
+  pconstant in_universe_context_set
+val fresh_inductive_instance : env -> inductive ->
+  pinductive in_universe_context_set
+val fresh_constructor_instance : env -> constructor ->
+  pconstructor in_universe_context_set
+
+val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> 
+  constr in_universe_context_set
+
+val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> 
+  constr in_universe_context_set
+
+(** Get fresh variables for the universe context.
+    Useful to make tactics that manipulate constrs in universe contexts polymorphic. *)
+val fresh_universe_context_set_instance : universe_context_set -> 
+  universe_level_subst * universe_context_set
+
+(** Raises [Not_found] if not a global reference. *)
+val global_of_constr : constr -> Globnames.global_reference puniverses
+
+val global_app_of_constr : constr -> Globnames.global_reference puniverses * constr option
+
+val constr_of_global_univ : Globnames.global_reference puniverses -> constr
+
+val extend_context : 'a in_universe_context_set -> universe_context_set -> 
+  'a in_universe_context_set
+
+(** Simplification and pruning of constraints:
+    [normalize_context_set ctx us]
+
+    - Instantiate the variables in [us] with their most precise
+    universe levels respecting the constraints.
+
+    - Normalizes the context [ctx] w.r.t. equality constraints, 
+    choosing a canonical universe in each equivalence class 
+    (a global one if there is one) and transitively saturate
+    the constraints w.r.t to the equalities. *)
+
+module UF : Unionfind.PartitionSig with type elt = universe_level
+
+type universe_opt_subst = universe option universe_map
+
+val make_opt_subst : universe_opt_subst -> universe_subst_fn
+
+val subst_opt_univs_constr : universe_opt_subst -> constr -> constr
+
+val normalize_context_set : universe_context_set -> 
+  universe_opt_subst (* The defined and undefined variables *) ->
+  universe_set (* univ variables that can be substituted by algebraics *) -> 
+  (universe_opt_subst * universe_set) in_universe_context_set
+
+val normalize_univ_variables : universe_opt_subst -> 
+  universe_opt_subst * universe_set * universe_set * universe_subst
+
+val normalize_univ_variable : 
+  find:(universe_level -> universe) ->
+  update:(universe_level -> universe -> universe) ->
+  universe_level -> universe
+
+val normalize_univ_variable_opt_subst : universe_opt_subst ref ->
+  (universe_level -> universe)
+
+val normalize_univ_variable_subst : universe_subst ref ->
+  (universe_level -> universe)
+
+val normalize_universe_opt_subst : universe_opt_subst ref ->
+  (universe -> universe)
+
+val normalize_universe_subst : universe_subst ref ->
+  (universe -> universe)
+
+(** Create a fresh global in the global environment, without side effects.
+    BEWARE: this raises an ANOMALY on polymorphic constants/inductives: 
+    the constraints should be properly added to an evd. 
+    See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for
+    the proper way to get a fresh copy of a global reference. *)
+val constr_of_global : Globnames.global_reference -> constr
+
+(** ** DEPRECATED ** synonym of [constr_of_global] *)
+val constr_of_reference : Globnames.global_reference -> constr
+
+(** [unsafe_constr_of_global gr] turns [gr] into a constr, works on polymorphic
+    references by taking the original universe instance that is not recorded 
+    anywhere. The constraints are forgotten as well. DO NOT USE in new code. *)
+val unsafe_constr_of_global : Globnames.global_reference -> constr in_universe_context
+
+(** Returns the type of the global reference, by creating a fresh instance of polymorphic 
+    references and computing their instantiated universe context. (side-effect on the
+    universe counter, use with care). *)
+val type_of_global : Globnames.global_reference -> types in_universe_context_set
+
+(** [unsafe_type_of_global gr] returns [gr]'s type, works on polymorphic
+    references by taking the original universe instance that is not recorded 
+    anywhere. The constraints are forgotten as well. 
+    USE with care. *)
+val unsafe_type_of_global : Globnames.global_reference -> types
+
+(** Full universes substitutions into terms *)
+
+val nf_evars_and_universes_opt_subst : (existential -> constr option) -> 
+  universe_opt_subst -> constr -> constr
+
+(** Shrink a universe context to a restricted set of variables *)
+
+val universes_of_constr : constr -> universe_set
+val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set
+val simplify_universe_context : universe_context_set -> 
+  universe_context_set * universe_level_subst
+
+val refresh_constraints : universes -> universe_context_set -> universe_context_set * universes
+
+(** Pretty-printing *)
+
+val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds
+
+(* For tracing *)
+
+type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t
+
+val pr_constraints_map : constraints_map -> Pp.std_ppcmds
+
+val choose_canonical : universe_set -> (Level.t -> bool) (* flexibles *) -> universe_set -> universe_set -> 
+  universe_level * (universe_set * universe_set * universe_set)
+    
+val compute_lbound : (constraint_type * Univ.universe) list -> universe option
+
+val instantiate_with_lbound : 
+  Univ.LMap.key ->
+  Univ.universe ->
+  bool ->
+  bool ->
+  Univ.LSet.t * Univ.universe option Univ.LMap.t *
+    Univ.LSet.t *
+    (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints ->
+  (Univ.LSet.t * Univ.universe option Univ.LMap.t *
+    Univ.LSet.t *
+     (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints) *
+    (bool * bool * Univ.universe)
+
+val minimize_univ_variables : 
+           Univ.LSet.t ->
+           Univ.universe option Univ.LMap.t ->
+           Univ.LSet.t ->
+  constraints_map -> constraints_map ->
+           Univ.constraints ->
+           Univ.LSet.t * Univ.universe option Univ.LMap.t *
+	     Univ.LSet.t *
+           (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints
+
+(** {6 Support for old-style sort-polymorphism } *)
+
+val solve_constraints_system : universe option array -> universe array -> universe array ->
+  universe array
diff --git a/man/coqdep.1 b/man/coqdep.1
index e9e0dd3e..5a6cd609 100644
--- a/man/coqdep.1
+++ b/man/coqdep.1
@@ -78,10 +78,6 @@ of each Coq file given as argument and complete (if needed)
 the list of Caml modules. The new command is printed on
 the standard output. No dependency is computed with this option.
 .TP 
-.BI \-slash
-Prints paths using a slash instead of the OS specific separator. This
-option is useful when developping under Cygwin.
-.TP
 .BI \-I \ directory
 The files .v .ml .mli of the directory
 .IR directory \&
diff --git a/man/coqide.1 b/man/coqide.1
index 9862ebb2..3fa7f0e4 100644
--- a/man/coqide.1
+++ b/man/coqide.1
@@ -40,17 +40,9 @@ to logical
 .B \-src
 Add source directories in the include path.
 .TP
-.BI \-is\  f ,\ \-inputstate\  f
-Read state from
-.IR f .coq.
-.TP
 .B \-nois
 Start with an empty state.
 .TP
-.BI \-outputstate\  f
-Write state in file
-.IR f .coq.
-.TP
 .BI \-load\-ml\-object\  f
 Load ML object file
 .IR f .
@@ -93,12 +85,6 @@ Verbosely compile Coq file
 (implies
 .BR -batch ).
 .TP
-.B \-opt
-Run the native-code version of Coq or Coq_SearchIsos.
-.TP
-.B \-byte
-Run the bytecode version of Coq or Coq_SearchIsos.
-.TP
 .B \-where
 Print Coq's standard library location and exit.
 .TP
@@ -135,12 +121,6 @@ Set sort Set impredicative.
 .TP
 .B \-dont\-load\-proofs
 Don't load opaque proofs in memory.
-.TP
-.B \-xml
-Export XML files either to the hierarchy rooted in
-the directory
-.B COQ_XML_LIBRARY_ROOT
-(if set) or to stdout (if unset).
 
 
 .SH SEE ALSO
diff --git a/man/coqtop.1 b/man/coqtop.1
index fff813bb..1bc4629d 100644
--- a/man/coqtop.1
+++ b/man/coqtop.1
@@ -47,20 +47,10 @@ set the toplevel name to be
 instead of Top
 
 .TP
-.BI \-inputstate \ filename, \ \-is \ filename 
-read state from file
-.I filename.coq
-
-.TP
 .B \-nois
 start with an empty initial state
 
 .TP
-.BI \-outputstate filename
-write state in file
-.I filename.coq
-
-.TP
 .BI \-load\-ml\-object \ filename
 load ML object file
 .I filenname
@@ -110,14 +100,6 @@ verbosely compile Coq file
 )
 
 .TP
-.B \-opt
-run the native\-code version of Coq
-
-.TP
-.B \-byte
-run the bytecode version of Coq
-
-.TP
 .B \-where
 print Coq's standard library location and exit
 
@@ -170,17 +152,6 @@ set sort Set impredicative
 .B \-dont\-load\-proofs
 don't load opaque proofs in memory
 
-.TP
-.B \-xml
-export XML files either to the hierarchy rooted in
-the directory $COQ_XML_LIBRARY_ROOT (if set) or to
-stdout (if unset)
-
-.TP
-.B \-quality
-improve the legibility of the proof terms produced by
-some tactics
-
 .SH SEE ALSO
 
 .BR coqc (1),
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 5b873fce..097a1042 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -58,7 +58,7 @@ let _ = begin
   Options.ocamllex := A Coq_config.ocamllex;
 end
 
-let w32 = (Coq_config.arch = "win32")
+let w32 = Coq_config.arch_is_win32
 
 let w32pref = "i586-mingw32msvc"
 let w32ocamlc = w32pref^"-ocamlc"
@@ -76,21 +76,18 @@ end
 
 let use_camlp5 = (Coq_config.camlp4 = "camlp5")
 
-let camlp4lib = if w32 then w32lib^"ocaml/camlp5" else Coq_config.camlp4lib
-
 let camlp4args =
   if use_camlp5 then [A "pa_extend.cmo";A "q_MLast.cmo";A "pa_macro.cmo"]
   else []
 
 let ocaml = A Coq_config.ocaml
 let camlp4o = S ((A Coq_config.camlp4o) :: camlp4args)
-let camlp4incl = S[A"-I"; A camlp4lib]
+let camlp4incl = S[A"-I"; A Coq_config.camlp4lib]
 let camlp4compat = Sh Coq_config.camlp4compat
 let opt = (Coq_config.best = "opt")
 let ide = Coq_config.has_coqide
 let hasdynlink = Coq_config.has_natdynlink
 let os5fix = (Coq_config.natdynlinkflag = "os5fixme")
-let flag_dynlink = if hasdynlink then A"-DHasDynlink" else N
 let dep_dynlink = if hasdynlink then N else Sh"-natdynlink no"
 let lablgtkincl = Sh Coq_config.coqideincl
 let local = Coq_config.local
@@ -106,15 +103,16 @@ let _build = Options.build_dir
 (** Abbreviations about files *)
 
 let core_libs =
-  ["lib/lib"; "kernel/kernel"; "library/library";
+  ["lib/clib"; "lib/lib"; "kernel/kernel"; "library/library";
    "pretyping/pretyping"; "interp/interp";  "proofs/proofs";
-   "parsing/parsing"; "tactics/tactics"; "toplevel/toplevel";
-   "parsing/highparsing"; "tactics/hightactics"]
+   "parsing/parsing"; "printing/printing"; "tactics/tactics";
+   "stm/stm"; "toplevel/toplevel";  "parsing/highparsing";
+   "tactics/hightactics"]
 let core_cma = List.map (fun s -> s^".cma") core_libs
 let core_cmxa = List.map (fun s -> s^".cmxa") core_libs
 let core_mllib = List.map (fun s -> s^".mllib") core_libs
 
-let tolink = "scripts/tolink.ml"
+let tolink = "tools/tolink.ml"
 
 let c_headers_base =
   ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; "int64_emul.h";
@@ -128,9 +126,7 @@ let copcodes = "kernel/copcodes.ml"
 
 let libcoqrun = "kernel/byterun/libcoqrun.a"
 
-let initialcoq = "states/initial.coq"
-let init_vo = ["theories/Init/Prelude.vo";"theories/Init/Logic_Type.vo"]
-let makeinitial = "states/MakeInitial.v"
+let init_vo = "theories/Init/Prelude.vo"
 
 let nmake = "theories/Numbers/Natural/BigN/NMake_gen.v"
 let nmakegen = "theories/Numbers/Natural/BigN/NMake_gen.ml"
@@ -160,7 +156,7 @@ let coqdepdeps = theoriesv @ pluginsv @ pluginsmllib
 let coqtop = "toplevel/coqtop"
 let coqide = "ide/coqide"
 let coqdepboot = "tools/coqdep_boot"
-let coqmktop = "scripts/coqmktop"
+let coqmktop = "tools/coqmktop"
 
 (** The list of binaries to build:
     (name of link in bin/, name in _build, install both or only best) *)
@@ -172,7 +168,7 @@ let all_binaries =
  [ "coqtop", coqtop, Both;
    "coqide", "ide/coqide_main", Ide;
    "coqmktop", coqmktop, Both;
-   "coqc", "scripts/coqc", Both;
+   "coqc", "tools/coqc", Both;
    "coqchk", "checker/main", Both;
    "coqdep_boot", coqdepboot, Best;
    "coqdep", "tools/coqdep", Best;
@@ -264,9 +260,9 @@ let extra_rules () = begin
        let lines = List.map (fun s -> s^"\n") lines in
        let line0 = "\n(* Adapted variables for ocamlbuild *)\n" in
        (* TODO : line2 isn't completely accurate with respect to ./configure:
-	  the case of -local -coqrunbyteflags foo isn't supported *)
+	  the case of -local -vmbyteflags foo isn't supported *)
        let line1 =
-	 "let coqrunbyteflags = \"-dllib -lcoqrun\"\n"
+	 "let vmbyteflags = [\"-dllib\";\"-lcoqrun\"]\n"
        in
        Echo (lines @ (if local then [line0;line1] else []),
 	     "coq_config.ml"));
@@ -280,8 +276,8 @@ let extra_rules () = begin
 	      T(tags_of_pathname ml4 ++ "p4option"); camlp4compat;
 	      A"-o"; Px ml; A"-impl"; P ml4]));
 
-  flag_and_dep ["p4mod"; "use_grammar"] (P "parsing/grammar.cma");
-  flag_and_dep ["p4mod"; "use_constr"] (P "parsing/q_constr.cmo");
+  flag_and_dep ["p4mod"; "use_grammar"] (P "grammar/grammar.cma");
+  flag_and_dep ["p4mod"; "use_constr"] (P "grammar/q_constr.cmo");
 
   flag_and_dep ["p4mod"; "use_compat5"] (P "tools/compat5.cmo");
   flag_and_dep ["p4mod"; "use_compat5b"] (P "tools/compat5b.cmo");
@@ -303,38 +299,17 @@ let extra_rules () = begin
   mlp_cmo "tools/compat5b";
   end;
 
-  ocaml_lib ~extern:true ~dir:camlp4lib ~tag_name:"use_camlpX"
-    ~byte:true ~native:true (if use_camlp5 then "gramlib" else "camlp4lib");
-
-(** Special case of toplevel/mltop.ml4:
-    - mltop.ml will be the old mltop.optml and be used to obtain mltop.cmx
-    - we add a special mltop.ml4 --> mltop.cmo rule, before all the others
-*)
-  flag ["is_mltop"; "p4option"] flag_dynlink;
-
-(*TODO: this is rather ugly for a simple file, we should try to
-        benefit more from predefined rules *)
-  let mltop = "toplevel/mltop" in
-  let ml4 = mltop^".ml4" and mlo = mltop^".cmo" and
-      ml = mltop^".ml" and mld = mltop^".ml.depends"
-  in
-  rule "mltop_byte" ~deps:[ml4;mld]  ~prod:mlo ~insert:`top
-    (fun env build ->
-       Ocaml_compiler.prepare_compile build ml;
-       Cmd (S [!Options.ocamlc; A"-c"; A"-pp";
-	       Quote (S [camlp4o; T(tags_of_pathname ml4 ++ "p4mod");
-			 A"-DByte";A"-DHasDynlink";camlp4compat;A"-impl"]);
-	       A"-rectypes"; A"-impl"; P ml4]));
-
-(** All caml files are compiled with -rectypes and +camlp4/5
+(** All caml files are compiled with +camlp4/5
     and ide files need +lablgtk2 *)
 
-  flag ["compile"; "ocaml"] (S [A"-rectypes"; camlp4incl]);
+  flag ["compile"; "ocaml"] (S [A"-thread";A"-rectypes"; camlp4incl]);
   flag ["link"; "ocaml"] (S [A"-rectypes"; camlp4incl]);
   flag ["ocaml"; "ide"; "compile"] lablgtkincl;
   flag ["ocaml"; "ide"; "link"] lablgtkincl;
-  flag ["ocaml"; "ide"; "link"; "byte"] (S [A"lablgtk.cma"; A"gtkThread.cmo"]);
-  flag ["ocaml"; "ide"; "link"; "native"] (S [A"lablgtk.cmxa"; A"gtkThread.cmx"]);
+  flag ["ocaml"; "ide"; "link"; "byte"]
+    (S [A"lablgtk.cma"; A"lablgtksourceview2.cma"]);
+  flag ["ocaml"; "ide"; "link"; "native"]
+    (S [A"lablgtk.cmxa"; A"lablgtksourceview2.cmxa"]);
 
 (** C code for the VM *)
 
@@ -342,7 +317,7 @@ let extra_rules () = begin
   flag ["compile"; "c"] cflags;
   dep ["ocaml"; "use_libcoqrun"; "compile"] [libcoqrun];
   dep ["ocaml"; "use_libcoqrun"; "link"; "native"] [libcoqrun];
-  flag ["ocaml"; "use_libcoqrun"; "link"; "byte"] (Sh Coq_config.coqrunbyteflags);
+  flag ["ocaml"; "use_libcoqrun"; "link"; "byte"] (Sh Coq_config.vmbyteflags);
 
   (* we need to use a different ocamlc. For now we copy the rule *)
   if w32 then
@@ -383,8 +358,8 @@ let extra_rules () = begin
        let core_mods = String.concat " " (List.map cat core_mllib) in
        let core_cmas = String.concat " " core_cma in
        Echo (["let copts = \"-cclib -lcoqrun\"\n";
-	      "let core_libs = \"coq_config.cmo "^core_cmas^"\"\n";
-	      "let core_objs = \"Coq_config "^core_mods^"\"\n"],
+	      "let core_libs = \""^core_cmas^"\"\n";
+	      "let core_objs = \""^core_mods^"\"\n"],
 	     tolink));
 
 (** For windows, building coff object file from a .rc (for the icon) *)
@@ -395,41 +370,29 @@ let extra_rules () = begin
        Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc;
 	       A "--output-format";A "coff";A "--output"; Px o]));
 
-(** Embed the Coq icon inside the windows version of Coqide *)
+(** The windows version of Coqide is now a console-free win32 app,
+    which moreover contains the Coq icon. If necessary, the mkwinapp
+    tool can be used later to restore or suppress the console of Coqide. *)
 
   if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico];
-  if w32 then flag ["link"; "ocaml"; "program"; "ide"] (P w32ico);
-
-(** Ealier we tried to make Coqide a console-free win32 app,
-    but that was troublesome (unavailable stdout/stderr, issues
-    with the stop button,...). If somebody really want to try again,
-    the extra args to add are :
-      [A "-ccopt"; A "-link -Wl,-subsystem,windows"]
-    Other solution: use the mkwinapp tool. *)
 
-(** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
-    Let's tweak that... *)
-
-  if w32 then begin
-    ocaml_lib "tools/win32hack";
-    List.iter (fun (_,s,_) -> tag_file (s^".native") ["use_win32hack"])
-      all_binaries
-  end;
+  if w32 then flag ["link"; "ocaml"; "program"; "ide"]
+    (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]);
 
 (** Coqtop *)
 
   let () =
     let fo = coqtop^".native" and fb = coqtop^".byte" in
     let depsall = (if w32 then [w32ico] else [])@[coqmktop_boot;libcoqrun] in
-    let depso = "coq_config.cmx" :: core_cmxa in
-    let depsb = "coq_config.cmo" :: core_cma in
+    let depso =  core_cmxa in
+    let depsb =  core_cma in
     let w32flag =
       if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico])
     in
     if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top
-      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;camlp4incl;A"-o";Px fo]);
+      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;A"-thread";camlp4incl;A"-o";Px fo]);
     rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top
-      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;camlp4incl;A"-o";Px fb]);
+      (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;A"-thread";camlp4incl;A"-o";Px fb]);
   in
 
 (** Coq files dependencies *)
@@ -440,7 +403,7 @@ let extra_rules () = begin
     (fun env _ ->
        let v = env "%.v" and vd = env "%.v.depends" in
        (** NB: this relies on all .v files being already in _build. *)
-       Cmd (S [P coqdep_boot;dep_dynlink;A"-slash";P v;Sh">";Px vd]));
+       Cmd (S [P coqdep_boot;dep_dynlink;P v;Sh">";Px vd]));
 
 (** Coq files compilation *)
 
@@ -461,8 +424,8 @@ let extra_rules () = begin
   in
 
   let coq_v_rule d init =
-    let bootflag = if init then A"-nois" else N in
-    let gendep = if init then coqtopbest else initialcoq in
+    let bootflag = if init then A"-noinit" else N in
+    let gendep = if init then coqtopbest else init_vo in
     rule (d^".v.vo")
       ~prods:[d^"%.vo";d^"%.glob"] ~deps:[gendep;d^"%.v";d^"%.v.depends"]
       (fun env build ->
@@ -473,12 +436,6 @@ let extra_rules () = begin
   coq_v_rule "theories/Init/" true;
   coq_v_rule "" false;
 
-(** Initial state *)
-
-  rule "initial.coq" ~prod:initialcoq ~deps:(makeinitial::init_vo)
-    (cmd [P coqtopbest;A"-boot";A"-batch";A"-nois";A"-notop";A"-silent";
-	  A"-l";P makeinitial; A"-outputstate";Px initialcoq]);
-
 (** Generation of _plugin_mod.ml files *)
 
   rule "_mod.ml" ~prod:"%_plugin_mod.ml" ~dep:"%_plugin.mllib"
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
deleted file mode 100644
index 1fc429c6..00000000
--- a/parsing/argextend.ml4
+++ /dev/null
@@ -1,340 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "tools/compat5b.cmo" i*)
-
-open Genarg
-open Q_util
-open Egrammar
-open Pcoq
-open Compat
-
-let loc = Util.dummy_loc
-let default_loc = <:expr< Util.dummy_loc >>
-
-let rec make_rawwit loc = function
-  | BoolArgType -> <:expr< Genarg.rawwit_bool >>
-  | IntArgType -> <:expr< Genarg.rawwit_int >>
-  | IntOrVarArgType -> <:expr< Genarg.rawwit_int_or_var >>
-  | StringArgType -> <:expr< Genarg.rawwit_string >>
-  | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >>
-  | IntroPatternArgType -> <:expr< Genarg.rawwit_intro_pattern >>
-  | IdentArgType b -> <:expr< Genarg.rawwit_ident_gen $mlexpr_of_bool b$ >>
-  | VarArgType -> <:expr< Genarg.rawwit_var >>
-  | RefArgType -> <:expr< Genarg.rawwit_ref >>
-  | SortArgType -> <:expr< Genarg.rawwit_sort >>
-  | ConstrArgType -> <:expr< Genarg.rawwit_constr >>
-  | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >>
-  | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >>
-  | RedExprArgType -> <:expr< Genarg.rawwit_red_expr >>
-  | OpenConstrArgType (b1,b2) -> <:expr< Genarg.rawwit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >>
-  | ConstrWithBindingsArgType -> <:expr< Genarg.rawwit_constr_with_bindings >>
-  | BindingsArgType -> <:expr< Genarg.rawwit_bindings >>
-  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >>
-  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >>
-  | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >>
-  | PairArgType (t1,t2) ->
-      <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >>
-  | ExtraArgType s ->
-    <:expr<
-      let module WIT = struct
-        open Extrawit;
-        value wit = $lid:"rawwit_"^s$;
-      end in WIT.wit >>
-
-let rec make_globwit loc = function
-  | BoolArgType -> <:expr< Genarg.globwit_bool >>
-  | IntArgType -> <:expr< Genarg.globwit_int >>
-  | IntOrVarArgType -> <:expr< Genarg.globwit_int_or_var >>
-  | StringArgType -> <:expr< Genarg.globwit_string >>
-  | PreIdentArgType -> <:expr< Genarg.globwit_pre_ident >>
-  | IntroPatternArgType -> <:expr< Genarg.globwit_intro_pattern >>
-  | IdentArgType b -> <:expr< Genarg.globwit_ident_gen $mlexpr_of_bool b$ >>
-  | VarArgType -> <:expr< Genarg.globwit_var >>
-  | RefArgType -> <:expr< Genarg.globwit_ref >>
-  | QuantHypArgType -> <:expr< Genarg.globwit_quant_hyp >>
-  | SortArgType -> <:expr< Genarg.globwit_sort >>
-  | ConstrArgType -> <:expr< Genarg.globwit_constr >>
-  | ConstrMayEvalArgType -> <:expr< Genarg.globwit_constr_may_eval >>
-  | RedExprArgType -> <:expr< Genarg.globwit_red_expr >>
-  | OpenConstrArgType (b1,b2) -> <:expr< Genarg.globwit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >>
-  | ConstrWithBindingsArgType -> <:expr< Genarg.globwit_constr_with_bindings >>
-  | BindingsArgType -> <:expr< Genarg.globwit_bindings >>
-  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >>
-  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >>
-  | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >>
-  | PairArgType (t1,t2) ->
-      <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >>
-  | ExtraArgType s ->
-    <:expr<
-      let module WIT = struct
-        open Extrawit;
-        value wit = $lid:"globwit_"^s$;
-      end in WIT.wit >>
-
-let rec make_wit loc = function
-  | BoolArgType -> <:expr< Genarg.wit_bool >>
-  | IntArgType -> <:expr< Genarg.wit_int >>
-  | IntOrVarArgType -> <:expr< Genarg.wit_int_or_var >>
-  | StringArgType -> <:expr< Genarg.wit_string >>
-  | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >>
-  | IntroPatternArgType -> <:expr< Genarg.wit_intro_pattern >>
-  | IdentArgType b -> <:expr< Genarg.wit_ident_gen $mlexpr_of_bool b$ >>
-  | VarArgType -> <:expr< Genarg.wit_var >>
-  | RefArgType -> <:expr< Genarg.wit_ref >>
-  | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >>
-  | SortArgType -> <:expr< Genarg.wit_sort >>
-  | ConstrArgType -> <:expr< Genarg.wit_constr >>
-  | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >>
-  | RedExprArgType -> <:expr< Genarg.wit_red_expr >>
-  | OpenConstrArgType (b1,b2) -> <:expr< Genarg.wit_open_constr_gen ($mlexpr_of_bool b1$,$mlexpr_of_bool b2$) >>
-  | ConstrWithBindingsArgType -> <:expr< Genarg.wit_constr_with_bindings >>
-  | BindingsArgType -> <:expr< Genarg.wit_bindings >>
-  | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >>
-  | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >>
-  | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >>
-  | PairArgType (t1,t2) ->
-      <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >>
-  | ExtraArgType s ->
-    <:expr<
-      let module WIT = struct
-        open Extrawit;
-        value wit = $lid:"wit_"^s$;
-      end in WIT.wit >>
-
-let has_extraarg =
-  List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true | _ -> false)
-
-let statically_known_possibly_empty s (prods,_) =
-  List.for_all (function
-    | GramNonTerminal(_,ExtraArgType s',_,_) ->
-        (* For ExtraArg we don't know (we'll have to test dynamically) *)
-        (* unless it is a recursive call *)
-        s <> s'
-    | GramNonTerminal(_,(OptArgType _|List0ArgType _),_,_) ->
-        (* Opt and List0 parses the empty string *)
-        true
-    | _ ->
-        (* This consumes a token for sure *) false)
-      prods
-
-let possibly_empty_subentries loc (prods,act) =
-  let bind_name p v e = match p with
-    | None -> e
-    | Some id ->
-        let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in
-  let rec aux = function
-    | [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >>
-    | GramNonTerminal(_,OptArgType _,_,p) :: tl ->
-        bind_name p <:expr< None >> (aux tl)
-    | GramNonTerminal(_,List0ArgType _,_,p) :: tl ->
-        bind_name p <:expr< [] >> (aux tl)
-    | GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl ->
-        (* We check at runtime if extraarg s parses "epsilon" *)
-        let s = match p with None -> "_" | Some id -> Names.string_of_id id in
-        <:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with
-          [ None -> raise Exit
-          | Some v -> v ] in $aux tl$ >>
-    | _ -> assert false (* already filtered out *) in
-  if has_extraarg prods then
-    (* Needs a dynamic check; catch all exceptions if ever some rhs raises *)
-    (* an exception rather than returning a value; *)
-    (* declares loc because some code can refer to it; *)
-    (* ensures loc is used to avoid "unused variable" warning *)
-    (true, <:expr< try Some $aux prods$ with [ e when Errors.noncritical e -> None ] >>)
-  else
-    (* Static optimisation *)
-    (false, aux prods)
-
-let make_possibly_empty_subentries loc s cl =
-  let cl = List.filter (statically_known_possibly_empty s) cl in
-  if cl = [] then
-    <:expr< None >>
-  else
-    let rec aux = function
-    | (true, e) :: l ->
-        <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >>
-    | (false, e) :: _ ->
-        <:expr< Some $e$ >>
-    | [] ->
-        <:expr< None >> in
-    aux (List.map (possibly_empty_subentries loc) cl)
-
-let make_act loc act pil =
-  let rec make = function
-    | [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >>
-    | GramNonTerminal (_,t,_,Some p) :: tl ->
-	let p = Names.string_of_id p in
-	<:expr<
-          Pcoq.Gram.action
-            (fun $lid:p$ ->
-               let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$)
-        >>
-    | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl ->
-	<:expr< Pcoq.Gram.action (fun _ -> $make tl$) >> in
-  make (List.rev pil)
-
-let make_prod_item = function
-  | GramTerminal s -> <:expr< Pcoq.gram_token_of_string $str:s$ >>
-  | GramNonTerminal (_,_,g,_) ->
-      <:expr< Pcoq.symbol_of_prod_entry_key $mlexpr_of_prod_entry_key g$ >>
-
-let make_rule loc (prods,act) =
-  <:expr< ($mlexpr_of_list make_prod_item prods$,$make_act loc act prods$) >>
-
-let declare_tactic_argument loc s (typ, pr, f, g, h) cl =
-  let rawtyp, rawpr, globtyp, globpr = match typ with
-    | `Uniform typ -> typ, pr, typ, pr
-    | `Specialized (a, b, c, d) -> a, b, c, d
-  in
-  let glob = match g with
-    | None ->
-	<:expr< fun e x ->
-          out_gen $make_globwit loc rawtyp$
-            (Tacinterp.intern_genarg e
-               (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >>
-    | Some f -> <:expr< $lid:f$>> in
-  let interp = match f with
-    | None ->
-	<:expr< fun ist gl x ->
-	  let (sigma,a_interp) =
-	    Tacinterp.interp_genarg ist gl
-               (Genarg.in_gen $make_globwit loc globtyp$ x)
-	  in
-          (sigma , out_gen $make_wit loc globtyp$ a_interp)>>
-    | Some f -> <:expr< $lid:f$>> in
-  let substitute = match h with
-    | None ->
-	<:expr< fun s x ->
-          out_gen $make_globwit loc globtyp$
-	    (Tacinterp.subst_genarg s
-               (Genarg.in_gen $make_globwit loc globtyp$ x)) >>
-    | Some f -> <:expr< $lid:f$>> in
-  let se = mlexpr_of_string s in
-  let wit = <:expr< $lid:"wit_"^s$ >> in
-  let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
-  let globwit = <:expr< $lid:"globwit_"^s$ >> in
-  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
-  let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in
-  declare_str_items loc
-   [ <:str_item<
-      value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
-      Genarg.create_arg $default_value$ $se$>>;
-     <:str_item<
-      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
-     <:str_item< do {
-      Tacinterp.add_interp_genarg $se$
-        ((fun e x ->
-          (Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))),
-        (fun ist gl x ->
-	  let (sigma,a_interp) = $interp$ ist gl (out_gen $globwit$ x) in
-          (sigma , Genarg.in_gen $wit$ a_interp)),
-        (fun subst x ->
-          (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x)))));
-      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
-	(None, [(None, None, $rules$)]);
-      Pptactic.declare_extra_genarg_pprule
-        ($rawwit$, $lid:rawpr$)
-        ($globwit$, $lid:globpr$)
-        ($wit$, $lid:pr$) }
-     >> ]
-
-let declare_vernac_argument loc s pr cl =
-  let se = mlexpr_of_string s in
-  let wit = <:expr< $lid:"wit_"^s$ >> in
-  let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
-  let globwit = <:expr< $lid:"globwit_"^s$ >> in
-  let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
-  let pr_rules = match pr with
-    | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >>
-    | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in
-  declare_str_items loc
-   [ <:str_item<
-      value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel),
-             ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel),
-              $lid:"rawwit_"^s$) = Genarg.create_arg None $se$ >>;
-     <:str_item<
-      value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
-    <:str_item< do {
-      Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))
-	(None, [(None, None, $rules$)]);
-      Pptactic.declare_extra_genarg_pprule
-        ($rawwit$, $pr_rules$)
-        ($globwit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not globwit printer")
-        ($wit$, fun _ _ _ _ -> Util.anomaly "vernac argument needs not wit printer") }
-      >> ]
-
-open Vernacexpr
-open Pcoq
-open Pcaml
-open PcamlSig
-
-EXTEND
-  GLOBAL: str_item;
-  str_item:
-    [ [ "ARGUMENT"; "EXTEND"; s = entry_name;
-        header = argextend_header;
-        OPT "|"; l = LIST1 argrule SEP "|";
-        "END" ->
-         declare_tactic_argument loc s header l
-      | "VERNAC"; "ARGUMENT"; "EXTEND"; s = entry_name;
-        pr = OPT ["PRINTED"; "BY"; pr = LIDENT -> pr];
-        OPT "|"; l = LIST1 argrule SEP "|";
-        "END" ->
-         declare_vernac_argument loc s pr l ] ]
-  ;
-  argextend_header:
-    [ [ "TYPED"; "AS"; typ = argtype;
-        "PRINTED"; "BY"; pr = LIDENT;
-        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
-        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
-        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ] ->
-        (`Uniform typ, pr, f, g, h)
-      | "PRINTED"; "BY"; pr = LIDENT;
-        f = OPT [ "INTERPRETED"; "BY"; f = LIDENT -> f ];
-        g = OPT [ "GLOBALIZED"; "BY"; f = LIDENT -> f ];
-        h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ];
-        "RAW_TYPED"; "AS"; rawtyp = argtype;
-        "RAW_PRINTED"; "BY"; rawpr = LIDENT;
-        "GLOB_TYPED"; "AS"; globtyp = argtype;
-        "GLOB_PRINTED"; "BY"; globpr = LIDENT ->
-        (`Specialized (rawtyp, rawpr, globtyp, globpr), pr, f, g, h) ] ]
-  ;
-  argtype:
-    [ "2"
-      [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ]
-    | "1"
-      [ e = argtype; LIDENT "list" -> List0ArgType e
-      | e = argtype; LIDENT "option" -> OptArgType e ]
-    | "0"
-      [ e = LIDENT -> fst (interp_entry_name false None e "")
-      | "("; e = argtype; ")" -> e ] ]
-  ;
-  argrule:
-    [ [ "["; l = LIST0 genarg; "]"; "->"; "["; e = Pcaml.expr; "]" -> (l,e) ] ]
-  ;
-  genarg:
-    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name false None e "" in
-	GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
-        let t, g = interp_entry_name false None e sep in
-	GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | s = STRING ->
-	  if String.length s > 0 && Util.is_letter s.[0] then
-	    Lexer.add_keyword s;
-          GramTerminal s
-    ] ]
-  ;
-  entry_name:
-    [ [ s = LIDENT -> s
-      | UIDENT -> failwith "Argument entry names must be lowercase"
-      ] ]
-  ;
-  END
-
diff --git a/lib/compat.ml4 b/parsing/compat.ml4
index 73cbc6d6..eba1d2b8 100644
--- a/lib/compat.ml4
+++ b/parsing/compat.ml4
@@ -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        *)
@@ -12,31 +12,59 @@
 
 IFDEF CAMLP5 THEN
 
-module Loc = struct
+module CompatLoc = struct
   include Ploc
-  exception Exc_located = Exc
   let ghost = dummy
   let merge = encl
 end
 
-let make_loc = Loc.make_unlined
-let unloc loc = (Loc.first_pos loc, Loc.last_pos loc)
+exception Exc_located = Ploc.Exc
 
+IFDEF CAMLP5_6_00 THEN
+let ploc_make_loc fname lnb pos bpep = Ploc.make_loc fname lnb pos bpep ""
+let ploc_file_name = Ploc.file_name
 ELSE
+let ploc_make_loc fname lnb pos bpep = Ploc.make lnb pos bpep
+let ploc_file_name _ = ""
+END
+
+let of_coqloc loc =
+  let (fname, lnb, pos, bp, ep) = Loc.represent loc in
+  ploc_make_loc fname lnb pos (bp,ep)
+
+let to_coqloc loc =
+  Loc.create (ploc_file_name loc) (Ploc.line_nb loc)
+    (Ploc.bol_pos loc) (Ploc.first_pos loc, Ploc.last_pos loc)
+
+let make_loc = Ploc.make_unlined
+
+ELSE
+
+module CompatLoc = Camlp4.PreCast.Loc
+
+exception Exc_located = CompatLoc.Exc_located
 
-module Loc = Camlp4.PreCast.Loc
+let of_coqloc loc =
+  let (fname, lnb, pos, bp, ep) = Loc.represent loc in
+  CompatLoc.of_tuple (fname, 0, 0, bp, 0, 0, ep, false)
 
-let make_loc (start,stop) =
-  Loc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
-let unloc loc = (Loc.start_off loc, Loc.stop_off loc)
+let to_coqloc loc =
+  Loc.create (CompatLoc.file_name loc) (CompatLoc.start_line loc)
+    (CompatLoc.start_bol loc) (CompatLoc.start_off loc, CompatLoc.stop_off loc)
+
+let make_loc (start, stop) =
+  CompatLoc.of_tuple ("", 0, 0, start, 0, 0, stop, false)
 
 END
 
+let (!@) = to_coqloc
+
 (** Misc module emulation *)
 
 IFDEF CAMLP5 THEN
 
 module PcamlSig = struct end
+module Token = Token
 
 ELSE
 
@@ -52,22 +80,58 @@ END
 (** Grammar auxiliary types *)
 
 IFDEF CAMLP5 THEN
-type gram_assoc = Gramext.g_assoc = NonA | RightA | LeftA
-type gram_position = Gramext.position =
-  | First
-  | Last
-  | Before of string
-  | After of string
-  | Like of string (** dont use it, not in camlp4 *)
-  | Level of string
+
+let to_coq_assoc = function
+| Gramext.RightA -> Extend.RightA
+| Gramext.LeftA -> Extend.LeftA
+| Gramext.NonA -> Extend.NonA
+
+let of_coq_assoc = function
+| Extend.RightA -> Gramext.RightA
+| Extend.LeftA -> Gramext.LeftA
+| Extend.NonA -> Gramext.NonA
+
+let of_coq_position = function
+| Extend.First -> Gramext.First
+| Extend.Last -> Gramext.Last
+| Extend.Before s -> Gramext.Before s
+| Extend.After s -> Gramext.After s
+| Extend.Level s -> Gramext.Level s
+
+let to_coq_position = function
+| Gramext.First -> Extend.First
+| Gramext.Last -> Extend.Last
+| Gramext.Before s -> Extend.Before s
+| Gramext.After s -> Extend.After s
+| Gramext.Level s -> Extend.Level s
+| Gramext.Like _ -> assert false (** dont use it, not in camlp4 *)
+
 ELSE
-type gram_assoc = PcamlSig.Grammar.assoc = NonA | RightA | LeftA
-type gram_position = PcamlSig.Grammar.position =
-  | First
-  | Last
-  | Before of string
-  | After of string
-  | Level of string
+
+let to_coq_assoc = function
+| PcamlSig.Grammar.RightA -> Extend.RightA
+| PcamlSig.Grammar.LeftA -> Extend.LeftA
+| PcamlSig.Grammar.NonA -> Extend.NonA
+
+let of_coq_assoc = function
+| Extend.RightA -> PcamlSig.Grammar.RightA
+| Extend.LeftA -> PcamlSig.Grammar.LeftA
+| Extend.NonA -> PcamlSig.Grammar.NonA
+
+let of_coq_position = function
+| Extend.First -> PcamlSig.Grammar.First
+| Extend.Last -> PcamlSig.Grammar.Last
+| Extend.Before s -> PcamlSig.Grammar.Before s
+| Extend.After s -> PcamlSig.Grammar.After s
+| Extend.Level s -> PcamlSig.Grammar.Level s
+
+let to_coq_position = function
+| PcamlSig.Grammar.First -> Extend.First
+| PcamlSig.Grammar.Last -> Extend.Last
+| PcamlSig.Grammar.Before s -> Extend.Before s
+| PcamlSig.Grammar.After s -> Extend.After s
+| PcamlSig.Grammar.Level s -> Extend.Level s
+
 END
 
 
@@ -87,7 +151,7 @@ end
 ELSE
 
 module type LexerSig =
-  Camlp4.Sig.Lexer with module Loc = Loc and type Token.t = Tok.t
+  Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t
 
 END
 
@@ -103,13 +167,13 @@ module type GrammarSig = sig
   type action = Gramext.g_action
   type production_rule = symbol list * action
   type single_extend_statment =
-      string option * gram_assoc option * production_rule list
+      string option * Gramext.g_assoc option * production_rule list
   type extend_statment =
-      gram_position option * single_extend_statment list
+      Gramext.position option * single_extend_statment list
   val action : 'a -> action
   val entry_create : string -> 'a entry
   val entry_parse : 'a entry -> parsable -> 'a
-  val entry_print : 'a entry -> unit
+  val entry_print : Format.formatter -> 'a entry -> unit
   val srules' : production_rule list -> symbol
   val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a
 end
@@ -122,16 +186,18 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct
   type action = Gramext.g_action
   type production_rule = symbol list * action
   type single_extend_statment =
-      string option * gram_assoc option * production_rule list
+      string option * Gramext.g_assoc option * production_rule list
   type extend_statment =
-      gram_position option * single_extend_statment list
+      Gramext.position option * single_extend_statment list
   let action = Gramext.action
   let entry_create = Entry.create
-  let entry_parse = Entry.parse
+  let entry_parse e p =
+    try Entry.parse e p
+    with Exc_located (loc,e) -> Loc.raise (to_coqloc loc) e
 IFDEF CAMLP5_6_02_1 THEN
-  let entry_print x = Entry.print !Pp_control.std_ft x
+  let entry_print ft x = Entry.print ft x
 ELSE
-  let entry_print = Entry.print
+  let entry_print _ x = Entry.print x
 END
   let srules' = Gramext.srules
   let parse_tokens_after_filter = Entry.parse_token
@@ -141,7 +207,7 @@ ELSE
 
 module type GrammarSig = sig
   include Camlp4.Sig.Grammar.Static
-    with module Loc = Loc and type Token.t = Tok.t
+    with module Loc = CompatLoc and type Token.t = Tok.t
   type 'a entry = 'a Entry.t
   type action = Action.t
   type parsable
@@ -149,11 +215,13 @@ module type GrammarSig = sig
   val action : 'a -> action
   val entry_create : string -> 'a entry
   val entry_parse : 'a entry -> parsable -> 'a
-  val entry_print : 'a entry -> unit
+  val entry_print : Format.formatter -> 'a entry -> unit
   val srules' : production_rule list -> symbol
 end
 
 module GrammarMake (L:LexerSig) : GrammarSig = struct
+  (* We need to refer to Coq's module Loc before it is hidden by include *)
+  let raise_coq_loc loc e = Loc.raise (to_coqloc loc) e
   include Camlp4.Struct.Grammar.Static.Make (L)
   type 'a entry = 'a Entry.t
   type action = Action.t
@@ -161,8 +229,10 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct
   let parsable s = s
   let action = Action.mk
   let entry_create = Entry.mk
-  let entry_parse e s = parse e (*FIXME*)Loc.ghost s
-  let entry_print x = Entry.print !Pp_control.std_ft x
+  let entry_parse e s =
+    try parse e (*FIXME*)CompatLoc.ghost s
+    with Exc_located (loc,e) -> raise_coq_loc loc e
+  let entry_print ft x = Entry.print ft x
   let srules' = srules (entry_create "dummy")
 end
 
@@ -240,3 +310,16 @@ let expl_anti loc e = <:expr< $anti:e$ >>
 ELSE
 let expl_anti _loc e = e (* FIXME: understand someday if we can do better *)
 END
+
+(** Qualified names in OCaml *)
+
+IFDEF CAMLP5 THEN
+let qualified_name loc path name =
+  let fold dir accu = <:expr< $uid:dir$.$accu$ >> in
+  List.fold_right fold path <:expr< $lid:name$ >>
+ELSE
+let qualified_name loc path name =
+  let fold dir accu = Ast.IdAcc (loc, Ast.IdUid (loc, dir), accu) in
+  let path = List.fold_right fold path (Ast.IdLid (loc, name)) in
+  Ast.ExId (loc, path)
+END
diff --git a/parsing/egrammar.ml b/parsing/egramcoq.ml
index 6deb7622..01194c60 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egramcoq.ml
@@ -1,24 +1,22 @@
 (************************************************************************)
 (*  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 Compat
+open Errors
 open Util
 open Pcoq
 open Extend
-open Ppextend
-open Topconstr
-open Genarg
+open Constrexpr
+open Notation_term
 open Libnames
-open Nameops
 open Tacexpr
 open Names
-open Vernacexpr
+open Egramml
 
 (**************************************************************************)
 (*
@@ -48,8 +46,8 @@ open Vernacexpr
 (** Declare Notations grammar rules                                   *)
 
 let constr_expr_of_name (loc,na) = match na with
-  | Anonymous -> CHole (loc,None)
-  | Name id -> CRef (Ident (loc,id))
+  | Anonymous -> CHole (loc,None,Misctypes.IntroAnonymous,None)
+  | Name id -> CRef (Ident (loc,id), None)
 
 let cases_pattern_expr_of_name (loc,na) = match na with
   | Anonymous -> CPatAtom (loc,None)
@@ -57,16 +55,16 @@ let cases_pattern_expr_of_name (loc,na) = match na with
 
 type grammar_constr_prod_item =
   | GramConstrTerminal of Tok.t
-  | GramConstrNonTerminal of constr_prod_entry_key * identifier option
+  | GramConstrNonTerminal of constr_prod_entry_key * Id.t option
   | GramConstrListMark of int * bool
-    (* tells action rule to make a list of the n previous parsed items; 
+    (* tells action rule to make a list of the n previous parsed items;
        concat with last parsed list if true *)
 
 let make_constr_action
-  (f : loc -> constr_notation_substitution -> constr_expr) pil =
+  (f : Loc.t -> constr_notation_substitution -> constr_expr) pil =
   let rec make (constrs,constrlists,binders as fullsubst) = function
   | [] ->
-      Gram.action (fun loc -> f loc fullsubst)
+      Gram.action (fun (loc:CompatLoc.t) -> f (!@loc) fullsubst)
   | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
       (* parse a non-binding item *)
       Gram.action (fun _ -> make fullsubst tl)
@@ -78,13 +76,13 @@ let make_constr_action
 	  make (v :: constrs, constrlists, binders) tl)
     | ETReference ->
         Gram.action (fun (v:reference) ->
-	  make (CRef v :: constrs, constrlists, binders) tl)
+	  make (CRef (v,None) :: constrs, constrlists, binders) tl)
     | ETName ->
-        Gram.action (fun (na:name located) ->
+        Gram.action (fun (na:Loc.t * Name.t) ->
 	  make (constr_expr_of_name na :: constrs, constrlists, binders) tl)
     | ETBigint ->
         Gram.action (fun (v:Bigint.bigint) ->
-	  make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl)
+	  make (CPrim(Loc.ghost,Numeral v) :: constrs, constrlists, binders) tl)
     | ETConstrList (_,n) ->
 	Gram.action (fun (v:constr_expr list) ->
 	  make (constrs, v::constrlists, binders) tl)
@@ -98,7 +96,7 @@ let make_constr_action
 	failwith "Unexpected entry of type cases pattern")
   | GramConstrListMark (n,b) :: tl ->
       (* Rebuild expansions of ConstrList *)
-      let heads,constrs = list_chop n constrs in
+      let heads,constrs = List.chop n constrs in
       let constrlists =
 	if b then (heads@List.hd constrlists)::List.tl constrlists
 	else heads::constrlists
@@ -107,13 +105,17 @@ let make_constr_action
   make ([],[],[]) (List.rev pil)
 
 let check_cases_pattern_env loc (env,envlist,hasbinders) =
-  if hasbinders then error_invalid_pattern_notation loc else (env,envlist)
+  if hasbinders then Topconstr.error_invalid_pattern_notation loc
+  else (env,envlist)
 
 let make_cases_pattern_action
-  (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
+  (f : Loc.t -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
   let rec make (env,envlist,hasbinders as fullenv) = function
   | [] ->
-      Gram.action (fun loc -> f loc (check_cases_pattern_env loc fullenv))
+      Gram.action
+	(fun (loc:CompatLoc.t) ->
+	  let loc = !@loc in
+	  f loc (check_cases_pattern_env loc fullenv))
   | (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
       (* parse a non-binding item *)
       Gram.action (fun _ -> make fullenv tl)
@@ -125,13 +127,13 @@ let make_cases_pattern_action
           make (v::env, envlist, hasbinders) tl)
     | ETReference ->
         Gram.action (fun (v:reference) ->
-	  make (CPatAtom (dummy_loc,Some v) :: env, envlist, hasbinders) tl)
+	  make (CPatAtom (Loc.ghost,Some v) :: env, envlist, hasbinders) tl)
     | ETName ->
-        Gram.action (fun (na:name located) ->
+        Gram.action (fun (na:Loc.t * Name.t) ->
 	  make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl)
     | ETBigint ->
         Gram.action (fun (v:Bigint.bigint) ->
-	  make (CPatPrim (dummy_loc,Numeral v) :: env, envlist, hasbinders) tl)
+	  make (CPatPrim (Loc.ghost,Numeral v) :: env, envlist, hasbinders) tl)
     | ETConstrList (_,_) ->
         Gram.action  (fun (vl:cases_pattern_expr list) ->
 	  make (env, vl :: envlist, hasbinders) tl)
@@ -142,10 +144,10 @@ let make_cases_pattern_action
 	Gram.action (fun (v:local_binder list list) ->
 	  make (env, envlist, true) tl)
     | (ETPattern | ETOther _) ->
-        anomaly "Unexpected entry of type cases pattern or other")
+        anomaly (Pp.str "Unexpected entry of type cases pattern or other"))
   | GramConstrListMark (n,b) :: tl ->
       (* Rebuild expansions of ConstrList *)
-      let heads,env = list_chop n env in
+      let heads,env = List.chop n env in
       if b then
         make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl
       else
@@ -171,169 +173,158 @@ let prepare_empty_levels forpat (pos,p4assoc,name,reinit) =
   grammar_extend entry reinit (pos,[(name, p4assoc, [])])
 
 let pure_sublevels level symbs =
-  map_succeed
-    (function s ->
-       let i = level_of_snterml s in
-       if level = Some i then failwith "";
-       i)
-    symbs
+  let filter s =
+    try
+      let i = level_of_snterml s in
+      begin match level with
+      | Some j when Int.equal i j -> None
+      | _ -> Some i
+      end
+    with Failure _ -> None
+  in
+  List.map_filter filter symbs
 
 let extend_constr (entry,level) (n,assoc) mkact forpat rules =
   List.fold_left (fun nb pt ->
   let symbs = make_constr_prod_item assoc n forpat pt in
   let pure_sublevels = pure_sublevels level symbs in
   let needed_levels = register_empty_levels forpat pure_sublevels in
+  let map_level (pos, ass1, name, ass2) =
+    (Option.map of_coq_position pos, Option.map of_coq_assoc ass1, name, ass2) in
+  let needed_levels = List.map map_level needed_levels in
   let pos,p4assoc,name,reinit = find_position forpat assoc level in
   let nb_decls = List.length needed_levels + 1 in
   List.iter (prepare_empty_levels forpat) needed_levels;
-  grammar_extend entry reinit (pos,[(name, p4assoc, [symbs, mkact pt])]);
+  grammar_extend entry reinit (Option.map of_coq_position pos,
+    [(name, Option.map of_coq_assoc p4assoc, [symbs, mkact pt])]);
   nb_decls) 0 rules
 
-let extend_constr_notation (n,assoc,ntn,rules) =
+type notation_grammar = {
+  notgram_level : int;
+  notgram_assoc : gram_assoc option;
+  notgram_notation : notation;
+  notgram_prods : grammar_constr_prod_item list list;
+  notgram_typs : notation_var_internalization_type list;
+}
+
+let extend_constr_constr_notation ng =
+  let level = ng.notgram_level in
+  let mkact loc env = CNotation (loc, ng.notgram_notation, env) in
+  let e = interp_constr_entry_key false (ETConstr (level, ())) in
+  let ext = (ETConstr (level, ()), ng.notgram_assoc) in
+  extend_constr e ext (make_constr_action mkact) false ng.notgram_prods
+
+let extend_constr_pat_notation ng =
+  let level = ng.notgram_level in
+  let mkact loc env = CPatNotation (loc, ng.notgram_notation, env, []) in
+  let e = interp_constr_entry_key true (ETConstr (level, ())) in
+  let ext = ETConstr (level, ()), ng.notgram_assoc in
+  extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods
+
+let extend_constr_notation ng =
   (* Add the notation in constr *)
-  let mkact loc env = CNotation (loc,ntn,env) in
-  let e = interp_constr_entry_key false (ETConstr (n,())) in
-  let nb = extend_constr e (ETConstr(n,()),assoc) (make_constr_action mkact) false rules in
+  let nb = extend_constr_constr_notation ng in
   (* Add the notation in cases_pattern *)
-  let mkact loc env = CPatNotation (loc,ntn,env) in
-  let e = interp_constr_entry_key true (ETConstr (n,())) in
-  let nb' = extend_constr e (ETConstr (n,()),assoc) (make_cases_pattern_action mkact)
-    true rules in
-  nb+nb'
-
-(**********************************************************************)
-(** Making generic actions in type generic_argument                   *)
-
-let make_generic_action
-  (f:loc -> ('b * raw_generic_argument) list -> 'a) pil =
-  let rec make env = function
-    | [] ->
-	Gram.action (fun loc -> f loc env)
-    | None :: tl -> (* parse a non-binding item *)
-        Gram.action (fun _ -> make env tl)
-    | Some (p, t) :: tl -> (* non-terminal *)
-        Gram.action (fun v -> make ((p,in_generic t v) :: env) tl) in
-  make [] (List.rev pil)
-
-let make_rule univ f g pt =
-  let (symbs,ntl) = List.split (List.map g pt) in
-  let act = make_generic_action f ntl in
-  (symbs, act)
-
-(**********************************************************************)
-(** Grammar extensions declared at ML level                           *)
-
-type grammar_prod_item =
-  | GramTerminal of string
-  | GramNonTerminal of
-      loc * argument_type * prod_entry_key * identifier option
-
-let make_prod_item = function
-  | GramTerminal s -> (gram_token_of_string s, None)
-  | GramNonTerminal (_,t,e,po) ->
-      (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po)
-
-(* Tactic grammar extensions *)
-
-let extend_tactic_grammar s gl =
-  let univ = get_univ "tactic" in
-  let mkact loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in
-  let rules = List.map (make_rule univ mkact make_prod_item) gl in
-  maybe_uncurry (Gram.extend Tactic.simple_tactic)
-    (None,[(None, None, List.rev rules)])
-
-(* Vernac grammar extensions *)
-
-let vernac_exts = ref []
-let get_extend_vernac_grammars () = !vernac_exts
-
-let extend_vernac_command_grammar s nt gl =
-  let nt = Option.default Vernac_.command nt in
-  vernac_exts := (s,gl) :: !vernac_exts;
-  let univ = get_univ "vernac" in
-  let mkact loc l = VernacExtend (s,List.map snd l) in
-  let rules = List.map (make_rule univ mkact make_prod_item) gl in
-  maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
+  let nb' = extend_constr_pat_notation ng in
+  nb + nb'
 
 (**********************************************************************)
 (** Grammar declaration for Tactic Notation (Coq level)               *)
 
 let get_tactic_entry n =
-  if n = 0 then
+  if Int.equal n 0 then
     weaken_entry Tactic.simple_tactic, None
-  else if n = 5 then
+  else if Int.equal n 5 then
     weaken_entry Tactic.binder_tactic, None
   else if 1<=n && n<5 then
-    weaken_entry Tactic.tactic_expr, Some (Compat.Level (string_of_int n))
+    weaken_entry Tactic.tactic_expr, Some (Extend.Level (string_of_int n))
   else
     error ("Invalid Tactic Notation level: "^(string_of_int n)^".")
 
-(* Declaration of the tactic grammar rule *)
+(**********************************************************************)
+(** State of the grammar extensions                                   *)
 
-let head_is_ident = function GramTerminal _::_ -> true | _ -> false
-
-let add_tactic_entry (key,lev,prods,tac) =
-  let univ = get_univ "tactic" in
-  let entry, pos = get_tactic_entry lev in
-  let rules =
-    if lev = 0 then begin
-      if not (head_is_ident prods) then
-	error "Notation for simple tactic must start with an identifier.";
-      let mkact s tac loc l =
-	(TacAlias(loc,s,l,tac):raw_atomic_tactic_expr) in
-      make_rule univ (mkact key tac) make_prod_item prods
-    end
-    else
-      let mkact s tac loc l =
-	(TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in
-      make_rule univ (mkact key tac) make_prod_item prods in
+type tactic_grammar = {
+  tacgram_level : int;
+  tacgram_prods : grammar_prod_item list;
+}
+
+type all_grammar_command =
+  | Notation of Notation.level * notation_grammar
+  | TacticGrammar of KerName.t * tactic_grammar
+  | MLTacticGrammar of ml_tactic_name * grammar_prod_item list list
+
+(** ML Tactic grammar extensions *)
+
+let add_ml_tactic_entry name prods =
+  let entry = weaken_entry Tactic.simple_tactic in
+  let mkact loc l : raw_tactic_expr = Tacexpr.TacML (loc, name, List.map snd l) in
+  let rules = List.map (make_rule mkact) prods in
   synchronize_level_positions ();
-  grammar_extend entry None (pos,[(None, None, List.rev [rules])]);
+  grammar_extend entry None (None ,[(None, None, List.rev rules)]);
   1
 
-(**********************************************************************)
-(** State of the grammar extensions                                   *)
+(* Declaration of the tactic grammar rule *)
 
-type notation_grammar =
-    int * gram_assoc option * notation * grammar_constr_prod_item list list
+let head_is_ident tg = match tg.tacgram_prods with
+| GramTerminal _::_ -> true
+| _ -> false
 
-type all_grammar_command =
-  | Notation of
-	 (precedence * tolerability list) *
-	  notation_var_internalization_type list *
-	  notation_grammar
-  | TacticGrammar of
-      (string * int * grammar_prod_item list *
-         (dir_path * Tacexpr.glob_tactic_expr))
+(** Tactic grammar extensions *)
+
+let add_tactic_entry kn tg =
+  let entry, pos = get_tactic_entry tg.tacgram_level in
+  let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in
+  let () =
+    if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then
+      error "Notation for simple tactic must start with an identifier."
+  in
+  let rules = make_rule mkact tg.tacgram_prods in
+  synchronize_level_positions ();
+  grammar_extend entry None (Option.map of_coq_position pos,[(None, None, List.rev [rules])]);
+  1
 
 let (grammar_state : (int * all_grammar_command) list ref) = ref []
 
 let extend_grammar gram =
   let nb = match gram with
-  | Notation (_,_,a) -> extend_constr_notation a
-  | TacticGrammar g -> add_tactic_entry g in
+  | Notation (_,a) -> extend_constr_notation a
+  | TacticGrammar (kn, g) -> add_tactic_entry kn g
+  | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr
+  in
   grammar_state := (nb,gram) :: !grammar_state
 
-let recover_notation_grammar ntn prec =
-  let l = map_succeed (function
-    | _, Notation (prec',vars,(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' ->
-	 vars, x
-    | _ ->
-	 failwith "") !grammar_state in
-  assert (List.length l = 1);
-  List.hd l
+let extend_constr_grammar pr ntn =
+  extend_grammar (Notation (pr, ntn))
+
+let extend_tactic_grammar kn ntn =
+  extend_grammar (TacticGrammar (kn, ntn))
+
+let extend_ml_tactic_grammar name ntn =
+  extend_grammar (MLTacticGrammar (name, ntn))
+
+let recover_constr_grammar ntn prec =
+  let filter = function
+  | _, Notation (prec', ng) when
+      Notation.level_eq prec prec' &&
+      String.equal ntn ng.notgram_notation -> Some ng
+  | _ -> None
+  in
+  match List.map_filter filter !grammar_state with
+  | [x] -> x
+  | _ -> assert false
 
 (* Summary functions: the state of the lexer is included in that of the parser.
    Because the grammar affects the set of keywords when adding or removing
    grammar rules. *)
-type frozen_t = all_grammar_command list * Lexer.frozen_t
+type frozen_t = (int * all_grammar_command) list * Lexer.frozen_t
 
-let freeze () = (!grammar_state, Lexer.freeze ())
+let freeze _ : frozen_t = (!grammar_state, Lexer.freeze ())
 
 (* We compare the current state of the grammar and the state to unfreeze,
    by computing the longest common suffixes *)
 let factorize_grams l1 l2 =
-  if l1 == l2 then ([], [], l1) else list_share_tails l1 l2
+  if l1 == l2 then ([], [], l1) else List.share_tails l1 l2
 
 let number_of_entries gcl =
   List.fold_left (fun n (p,_) -> n + p) 0 gcl
@@ -345,24 +336,50 @@ let unfreeze (grams, lex) =
   remove_levels n;
   grammar_state := common;
   Lexer.unfreeze lex;
-  List.iter extend_grammar (List.rev (List.map snd redo))
-
-let init_grammar () =
-  remove_grammars (number_of_entries !grammar_state);
-  grammar_state := []
+  List.iter extend_grammar (List.rev_map snd redo)
 
-let init () =
-  init_grammar ()
-
-open Summary
+(** No need to provide an init function : the grammar state is
+    statically available, and already empty initially, while
+    the lexer state should not be resetted, since it contains
+    keywords declared in g_*.ml4 *)
 
 let _ =
-  declare_summary "GRAMMAR_LEXER"
-    { freeze_function = freeze;
-      unfreeze_function = unfreeze;
-      init_function = init }
+  Summary.declare_summary "GRAMMAR_LEXER"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = Summary.nop }
 
 let with_grammar_rule_protection f x =
-  let fs = freeze () in
+  let fs = freeze false in
   try let a = f x in unfreeze fs; a
-  with reraise -> unfreeze fs; raise reraise
+  with reraise ->
+    let reraise = Errors.push reraise in
+    let () = unfreeze fs in
+    iraise reraise
+
+(**********************************************************************)
+(** Ltac quotations                                                   *)
+
+let ltac_quotations = ref String.Set.empty
+
+let create_ltac_quotation name cast wit e =
+  let () =
+    if String.Set.mem name !ltac_quotations then
+      failwith ("Ltac quotation " ^ name ^ " already registered")
+  in
+  let () = ltac_quotations := String.Set.add name !ltac_quotations in
+(*   let level = Some "1" in *)
+  let level = None in
+  let assoc = Some (of_coq_assoc Extend.RightA) in
+  let rule = [
+    gram_token_of_string name;
+    gram_token_of_string ":";
+    symbol_of_prod_entry_key (Agram (Gram.Entry.name e));
+  ] in
+  let action v _ _ loc =
+    let loc = !@loc in
+    let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in
+    TacArg (loc, arg)
+  in
+  let gram = (level, assoc, [rule, Gram.action action]) in
+  maybe_uncurry (Gram.extend Tactic.tactic_expr) (None, [gram])
diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli
new file mode 100644
index 00000000..2b0f7da8
--- /dev/null
+++ b/parsing/egramcoq.mli
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  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 Names
+open Constrexpr
+open Notation_term
+open Pcoq
+open Extend
+open Genarg
+open Egramml
+
+(** Mapping of grammar productions to camlp4 actions *)
+
+(** This is the part specific to Coq-level Notation and Tactic Notation.
+    For the ML-level tactic and vernac extensions, see Egramml. *)
+
+(** For constr notations *)
+
+type grammar_constr_prod_item =
+  | GramConstrTerminal of Tok.t
+  | GramConstrNonTerminal of constr_prod_entry_key * Id.t option
+  | GramConstrListMark of int * bool
+    (* tells action rule to make a list of the n previous parsed items;
+       concat with last parsed list if true *)
+
+type notation_grammar = {
+  notgram_level : int;
+  notgram_assoc : gram_assoc option;
+  notgram_notation : notation;
+  notgram_prods : grammar_constr_prod_item list list;
+  notgram_typs : notation_var_internalization_type list;
+}
+
+type tactic_grammar = {
+  tacgram_level : int;
+  tacgram_prods : grammar_prod_item list;
+}
+
+(** {5 Adding notations} *)
+
+val extend_constr_grammar : Notation.level -> notation_grammar -> unit
+(** Add a term notation rule to the parsing system. *)
+
+val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit
+(** Add a tactic notation rule to the parsing system. This produces a TacAlias
+    tactic with the provided kernel name. *)
+
+val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> grammar_prod_item list list -> unit
+(** Add a ML tactic notation rule to the parsing system. This produces a
+    TacML tactic with the provided string as name. *)
+
+val recover_constr_grammar : notation -> Notation.level -> notation_grammar
+(** For a declared grammar, returns the rule + the ordered entry types
+    of variables in the rule (for use in the interpretation) *)
+
+val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b
+
+(** {5 Adding tactic quotations} *)
+
+val create_ltac_quotation : string -> ('grm Loc.located -> 'raw) ->
+  ('raw, 'glb, 'top) genarg_type -> 'grm Gram.entry -> unit
+(** [create_ltac_quotation name f wit e] adds a quotation rule to Ltac, that is,
+    Ltac grammar now accepts arguments of the form ["name" ":" <e>], and
+    generates a generic argument using [f] on the entry parsed by [e]. *)
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
deleted file mode 100644
index 094b4203..00000000
--- a/parsing/egrammar.mli
+++ /dev/null
@@ -1,75 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Compat
-open Util
-open Names
-open Topconstr
-open Pcoq
-open Extend
-open Vernacexpr
-open Ppextend
-open Glob_term
-open Genarg
-open Mod_subst
-
-(** Mapping of grammar productions to camlp4 actions
-    Used for Coq-level Notation and Tactic Notation,
-    and for ML-level tactic and vernac extensions
- *)
-
-(** For constr notations *)
-
-type grammar_constr_prod_item =
-  | GramConstrTerminal of Tok.t
-  | GramConstrNonTerminal of constr_prod_entry_key * identifier option
-  | GramConstrListMark of int * bool
-    (* tells action rule to make a list of the n previous parsed items; 
-       concat with last parsed list if true *)
-
-type notation_grammar =
-    int * gram_assoc option * notation * grammar_constr_prod_item list list
-
-(** For tactic and vernac notations *)
-
-type grammar_prod_item =
-  | GramTerminal of string
-  | GramNonTerminal of loc * argument_type *
-      prod_entry_key * identifier option
-
-(** Adding notations *)
-
-type all_grammar_command =
-  | Notation of
-	 (precedence * tolerability list)
-	  * notation_var_internalization_type list
-	   (** not needed for defining grammar, hosted by egrammar for
-	       transmission to interp_aconstr (via recover_notation_grammar) *)
-	  * notation_grammar
-  | TacticGrammar of
-      (string * int * grammar_prod_item list *
-         (dir_path * Tacexpr.glob_tactic_expr))
-
-val extend_grammar : all_grammar_command -> unit
-
-val extend_tactic_grammar :
-  string -> grammar_prod_item list list -> unit
-
-val extend_vernac_command_grammar :
-  string -> vernac_expr Gram.entry option -> grammar_prod_item list list -> unit
-
-val get_extend_vernac_grammars :
- unit -> (string * grammar_prod_item list list) list
-
-(** For a declared grammar, returns the rule + the ordered entry types
-    of variables in the rule (for use in the interpretation) *)
-val recover_notation_grammar :
-  notation -> (precedence * tolerability list) ->
-  notation_var_internalization_type list * notation_grammar
-
-val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b
diff --git a/parsing/egramml.ml b/parsing/egramml.ml
new file mode 100644
index 00000000..8fe03b36
--- /dev/null
+++ b/parsing/egramml.ml
@@ -0,0 +1,63 @@
+(************************************************************************)
+(*  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 Util
+open Compat
+open Names
+open Pcoq
+open Genarg
+open Vernacexpr
+
+(** Making generic actions in type generic_argument *)
+
+let make_generic_action
+  (f:Loc.t -> ('b * raw_generic_argument) list -> 'a) pil =
+  let rec make env = function
+    | [] ->
+	Gram.action (fun loc -> f (to_coqloc loc) env)
+    | None :: tl -> (* parse a non-binding item *)
+        Gram.action (fun _ -> make env tl)
+    | Some (p, t) :: tl -> (* non-terminal *)
+        Gram.action (fun v -> make ((p, Unsafe.inj t v) :: env) tl) in
+  make [] (List.rev pil)
+
+(** Grammar extensions declared at ML level *)
+
+type grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal of
+      Loc.t * argument_type * prod_entry_key * Id.t option
+
+let make_prod_item = function
+  | GramTerminal s -> (gram_token_of_string s, None)
+  | GramNonTerminal (_,t,e,po) ->
+      (symbol_of_prod_entry_key e, Option.map (fun p -> (p,t)) po)
+
+let make_rule mkact pt =
+  let (symbs,ntl) = List.split (List.map make_prod_item pt) in
+  let act = make_generic_action mkact ntl in
+  (symbs, act)
+
+(** Vernac grammar extensions *)
+
+let vernac_exts = ref []
+
+let get_extend_vernac_rule (s, i) =
+  try
+    let find ((name, j), _) = String.equal name s && Int.equal i j in
+    let (_, rules) = List.find find !vernac_exts in
+    rules
+  with
+  | Failure _ -> raise Not_found
+
+let extend_vernac_command_grammar s nt gl =
+  let nt = Option.default Vernac_.command nt in
+  vernac_exts := (s,gl) :: !vernac_exts;
+  let mkact loc l = VernacExtend (s,List.map snd l) in
+  let rules = [make_rule mkact gl] in
+  maybe_uncurry (Gram.extend nt) (None,[(None, None, List.rev rules)])
diff --git a/parsing/egramml.mli b/parsing/egramml.mli
new file mode 100644
index 00000000..9ebb5b83
--- /dev/null
+++ b/parsing/egramml.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Mapping of grammar productions to camlp4 actions. *)
+
+(** This is the part specific to vernac extensions.
+    For the Coq-level Notation and Tactic Notation, see Egramcoq. *)
+
+type grammar_prod_item =
+  | GramTerminal of string
+  | GramNonTerminal of Loc.t * Genarg.argument_type *
+      Pcoq.prod_entry_key * Names.Id.t option
+
+val extend_vernac_command_grammar :
+  Vernacexpr.extend_name -> Vernacexpr.vernac_expr Pcoq.Gram.entry option ->
+    grammar_prod_item list -> unit
+
+val get_extend_vernac_rule : Vernacexpr.extend_name -> grammar_prod_item list
+
+(** Utility function reused in Egramcoq : *)
+
+val make_rule :
+  (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'b) ->
+  grammar_prod_item list -> Pcoq.Gram.symbol list * Pcoq.Gram.action
diff --git a/parsing/extend.ml b/parsing/extend.ml
deleted file mode 100644
index 620e2ac2..00000000
--- a/parsing/extend.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Compat
-open Util
-
-(** Entry keys for constr notations *)
-
-type side = Left | Right
-
-type production_position =
-  | BorderProd of side * gram_assoc option
-  | InternalProd
-
-type production_level =
-  | NextLevel
-  | NumLevel of int
-
-type ('lev,'pos) constr_entry_key_gen =
-  | ETName | ETReference | ETBigint
-  | ETBinder of bool (* true=open, as in "fun .."; false as in "let f .. :=" *)
-  | ETConstr of ('lev * 'pos)
-  | ETPattern
-  | ETOther of string * string
-  | ETConstrList of ('lev * 'pos) * Tok.t list
-  | ETBinderList of bool * Tok.t list
-
-(**  Entries level (left-hand-side of grammar rules) *)
-
-type constr_entry_key =
-    (int,unit) constr_entry_key_gen
-
-(** Entries used in productions (in right-hand side of grammar rules) *)
-
-type constr_prod_entry_key =
-    (production_level,production_position) constr_entry_key_gen
-
-(** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *)
-
-type simple_constr_prod_entry_key =
-    (production_level,unit) constr_entry_key_gen
diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml
deleted file mode 100644
index aaf64523..00000000
--- a/parsing/extrawit.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Genarg
-
-(* This file defines extra argument types *)
-
-(* Tactics as arguments *)
-
-let tactic_main_level = 5
-
-let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg None "tactic0"
-let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg None "tactic1"
-let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg None "tactic2"
-let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg None "tactic3"
-let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg None "tactic4"
-let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg None "tactic5"
-
-let wit_tactic = function
-  | 0 -> wit_tactic0
-  | 1 -> wit_tactic1
-  | 2 -> wit_tactic2
-  | 3 -> wit_tactic3
-  | 4 -> wit_tactic4
-  | 5 -> wit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let globwit_tactic = function
-  | 0 -> globwit_tactic0
-  | 1 -> globwit_tactic1
-  | 2 -> globwit_tactic2
-  | 3 -> globwit_tactic3
-  | 4 -> globwit_tactic4
-  | 5 -> globwit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let rawwit_tactic = function
-  | 0 -> rawwit_tactic0
-  | 1 -> rawwit_tactic1
-  | 2 -> rawwit_tactic2
-  | 3 -> rawwit_tactic3
-  | 4 -> rawwit_tactic4
-  | 5 -> rawwit_tactic5
-  | n -> anomaly ("Unavailable tactic level: "^string_of_int n)
-
-let tactic_genarg_level s =
-  if String.length s = 7 && String.sub s 0 6 = "tactic" then
-    let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48)
-    else None
-  else None
-
-let is_tactic_genarg = function
-| ExtraArgType s -> tactic_genarg_level s <> None
-| _ -> false
diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli
deleted file mode 100644
index d8f36928..00000000
--- a/parsing/extrawit.mli
+++ /dev/null
@@ -1,49 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Genarg
-open Tacexpr
-
-(** This file defines extra argument types *)
-
-(** Tactics as arguments *)
-
-val tactic_main_level : int
-
-val rawwit_tactic : int -> (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic : int -> (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic : int -> (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic0 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic0 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic0 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic1 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic1 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic1 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic2 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic2 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic2 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic3 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic3 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic3 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic4 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic4 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic4 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val rawwit_tactic5 : (raw_tactic_expr,rlevel) abstract_argument_type
-val globwit_tactic5 : (glob_tactic_expr,glevel) abstract_argument_type
-val wit_tactic5 : (glob_tactic_expr,tlevel) abstract_argument_type
-
-val is_tactic_genarg : argument_type -> bool
-
-val tactic_genarg_level : string -> int option
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index 325c1cec..8246df28 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -1,23 +1,27 @@
 (************************************************************************)
 (*  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 Pcoq
-open Constr
-open Prim
-open Glob_term
-open Term
 open Names
 open Libnames
-open Topconstr
+open Constrexpr
+open Constrexpr_ops
 open Util
 open Tok
 open Compat
+open Misctypes
+open Decl_kinds
+
+open Pcoq
+open Pcoq.Prim
+open Pcoq.Constr
+
+(* TODO: avoid this redefinition without an extra dep to Notation_ops *)
+let ldots_var = Id.of_string ".."
 
 let constr_kw =
   [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for";
@@ -29,32 +33,34 @@ let _ = List.iter Lexer.add_keyword constr_kw
 
 let mk_cast = function
     (c,(_,None)) -> c
-  | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty))
+  | (c,(_,Some ty)) ->
+    let loc = Loc.merge (constr_loc c) (constr_loc ty)
+    in CCast(loc, c, CastConv ty)
+
+let binder_of_name expl (loc,na) =
+  LocalRawAssum ([loc, na], Default expl,
+    CHole (loc, Some (Evar_kinds.BinderType na), IntroAnonymous, None))
 
 let binders_of_names l =
-  List.map (fun (loc, na) ->
-    LocalRawAssum ([loc, na], Default Explicit,
-		   CHole (loc, Some (Evd.BinderType na)))) l
+  List.map (binder_of_name Explicit) l
 
 let binders_of_lidents l =
-  List.map (fun (loc, id) ->
-    LocalRawAssum ([loc, Name id], Default Glob_term.Explicit,
-		  CHole (loc, Some (Evd.BinderType (Name id))))) l
+  List.map (fun (loc, id) -> binder_of_name Explicit (loc, Name id)) l
 
 let mk_fixb (id,bl,ann,body,(loc,tyc)) =
   let ty = match tyc with
       Some ty -> ty
-    | None -> CHole (loc, None) in
+    | None -> CHole (loc, None, IntroAnonymous, None) in
   (id,ann,bl,ty,body)
 
 let mk_cofixb (id,bl,ann,body,(loc,tyc)) =
   let _ = Option.map (fun (aloc,_) ->
-    Util.user_err_loc
+    Errors.user_err_loc
       (aloc,"Constr:mk_cofixb",
        Pp.str"Annotation forbidden in cofix expression.")) (fst ann) in
   let ty = match tyc with
       Some ty -> ty
-    | None -> CHole (loc, None) in
+    | None -> CHole (loc, None, IntroAnonymous, None) in
   (id,bl,ty,body)
 
 let mk_fix(loc,kw,id,dcls) =
@@ -82,7 +88,7 @@ let lpar_id_coloneq =
                   (match get_tok (stream_nth 2 strm) with
                     | KEYWORD ":=" ->
                         stream_njunk 3 strm;
-                        Names.id_of_string s
+                        Names.Id.of_string s
 	            | _ -> err ())
               | _ -> err ())
         | _ -> err ())
@@ -96,7 +102,7 @@ let impl_ident_head =
 	      | IDENT ("wf"|"struct"|"measure") -> err ()
 	      | IDENT s ->
 		  stream_njunk 2 strm;
-		  Names.id_of_string s
+		  Names.Id.of_string s
 	      | _ -> err ())
 	| _ -> err ())
 
@@ -108,7 +114,7 @@ let name_colon =
             (match get_tok (stream_nth 1 strm) with
               | KEYWORD ":" ->
                   stream_njunk 2 strm;
-                  Name (Names.id_of_string s)
+                  Name (Names.Id.of_string s)
               | _ -> err ())
 	| KEYWORD "_" ->
           (match get_tok (stream_nth 1 strm) with
@@ -129,10 +135,10 @@ GEXTEND Gram
     [ [ id = Prim.ident -> id
 
       (* This is used in quotations and Syntax *)
-      | id = METAIDENT -> id_of_string id ] ]
+      | id = METAIDENT -> Id.of_string id ] ]
   ;
   Prim.name:
-    [ [ "_" -> (loc, Anonymous) ] ]
+    [ [ "_" -> (!@loc, Anonymous) ] ]
   ;
   global:
     [ [ r = Prim.reference -> r ] ]
@@ -144,65 +150,77 @@ GEXTEND Gram
     [ [ c = lconstr -> c ] ]
   ;
   sort:
-    [ [ "Set"  -> GProp Pos
-      | "Prop" -> GProp Null
-      | "Type" -> GType None ] ]
+    [ [ "Set"  -> GSet
+      | "Prop" -> GProp
+      | "Type" -> GType []
+      | "Type"; "@{"; u = universe; "}" -> GType (List.map Id.to_string u)
+      ] ]
+  ;
+  universe:
+    [ [ "max("; ids = LIST1 ident SEP ","; ")" -> ids
+      | id = ident -> [id]
+      ] ]
   ;
   lconstr:
     [ [ c = operconstr LEVEL "200" -> c ] ]
   ;
   constr:
     [ [ c = operconstr LEVEL "8" -> c
-      | "@"; f=global -> CAppExpl(loc,(None,f),[]) ] ]
+      | "@"; f=global; i = instance -> CAppExpl(!@loc,(None,f,i),[]) ] ]
   ;
   operconstr:
     [ "200" RIGHTA
       [ c = binder_constr -> c ]
     | "100" RIGHTA
       [ c1 = operconstr; "<:"; c2 = binder_constr ->
-                 CCast(loc,c1, CastConv (VMcast,c2))
+                 CCast(!@loc,c1, CastVM c2)
       | c1 = operconstr; "<:"; c2 = SELF ->
-                 CCast(loc,c1, CastConv (VMcast,c2))
+                 CCast(!@loc,c1, CastVM c2)
+      | c1 = operconstr; "<<:"; c2 = binder_constr ->
+                 CCast(!@loc,c1, CastNative c2)
+      | c1 = operconstr; "<<:"; c2 = SELF ->
+                 CCast(!@loc,c1, CastNative c2)
       | c1 = operconstr; ":";c2 = binder_constr ->
-                 CCast(loc,c1, CastConv (DEFAULTcast,c2))
+                 CCast(!@loc,c1, CastConv c2)
       | c1 = operconstr; ":"; c2 = SELF ->
-                 CCast(loc,c1, CastConv (DEFAULTcast,c2))
+                 CCast(!@loc,c1, CastConv c2)
       | c1 = operconstr; ":>" ->
-                 CCast(loc,c1, CastCoerce) ]
+                 CCast(!@loc,c1, CastCoerce) ]
     | "99" RIGHTA [ ]
-    | "90" RIGHTA
-      [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2)
-      | c1 = operconstr; "->"; c2 = SELF -> CArrow(loc,c1,c2)]
+    | "90" RIGHTA [ ]
     | "10" LEFTA
-      [ f=operconstr; args=LIST1 appl_arg -> CApp(loc,(None,f),args)
-      | "@"; f=global; args=LIST0 NEXT -> CAppExpl(loc,(None,f),args)
+      [ f=operconstr; args=LIST1 appl_arg -> CApp(!@loc,(None,f),args)
+      | "@"; f=global; i = instance; args=LIST0 NEXT -> CAppExpl(!@loc,(None,f,i),args)
       | "@"; (locid,id) = pattern_identref; args=LIST1 identref ->
-          let args = List.map (fun x -> CRef (Ident x), None) args in
-          CApp(loc,(None,CPatVar(locid,(true,id))),args) ]
+          let args = List.map (fun x -> CRef (Ident x,None), None) args in
+          CApp(!@loc,(None,CPatVar(locid,id)),args) ]
     | "9"
         [ ".."; c = operconstr LEVEL "0"; ".." ->
-          CAppExpl (loc,(None,Ident (loc,Topconstr.ldots_var)),[c]) ]
+          CAppExpl (!@loc,(None,Ident (!@loc,ldots_var),None),[c]) ]
     | "8" [ ]
     | "1" LEFTA
       [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" ->
-	CApp(loc,(Some (List.length args+1),CRef f),args@[c,None])
+	CApp(!@loc,(Some (List.length args+1),CRef (f,None)),args@[c,None])
       | c=operconstr; ".("; "@"; f=global;
         args=LIST0 (operconstr LEVEL "9"); ")" ->
-        CAppExpl(loc,(Some (List.length args+1),f),args@[c])
-      | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ]
+        CAppExpl(!@loc,(Some (List.length args+1),f,None),args@[c])
+      | c=operconstr; "%"; key=IDENT -> CDelimiters (!@loc,key,c) ]
     | "0"
       [ c=atomic_constr -> c
       | c=match_constr -> c
       | "("; c = operconstr LEVEL "200"; ")" ->
           (match c with
               CPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
-                CNotation(loc,"( _ )",([c],[],[]))
+                CNotation(!@loc,"( _ )",([c],[],[]))
             | _ -> c)
       | "{|"; c = record_declaration; "|}" -> c
       | "`{"; c = operconstr LEVEL "200"; "}" ->
-	  CGeneralization (loc, Implicit, None, c)
+	  CGeneralization (!@loc, Implicit, None, c)
       | "`("; c = operconstr LEVEL "200"; ")" ->
-	  CGeneralization (loc, Explicit, None, c)
+	  CGeneralization (!@loc, Explicit, None, c)
+      | "$("; tac = Tactic.tactic; ")$" ->
+          let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in
+          CHole (!@loc, None, IntroAnonymous, Some arg)
       ] ]
   ;
   forall:
@@ -212,74 +230,96 @@ GEXTEND Gram
     [ [ "fun" -> () ] ]
   ;
   record_declaration:
-    [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (loc, None, fs)
+    [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (!@loc, None, fs)
 (*       | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *)
-(* 	  CRecord (loc, Some c, fs) *)
+(* 	  CRecord (!@loc, Some c, fs) *)
     ] ]
   ;
   record_field_declaration:
     [ [ id = global; params = LIST0 identref; ":="; c = lconstr ->
-      (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ]
+      (id, abstract_constr_expr c (binders_of_lidents params)) ] ]
   ;
   binder_constr:
     [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" ->
-          mkCProdN loc bl c
+          mkCProdN (!@loc) bl c
       | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" ->
-          mkCLambdaN loc bl c
+          mkCLambdaN (!@loc) bl c
       | "let"; id=name; bl = binders; ty = type_cstr; ":=";
         c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
-          let loc1 = join_loc (local_binders_loc bl) (constr_loc c1) in
-          CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
+          let loc1 =
+	    Loc.merge (local_binders_loc bl) (constr_loc c1)
+	  in
+          CLetIn(!@loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
       | "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" ->
           let fixp = mk_single_fix fx in
           let (li,id) = match fixp with
               CFix(_,id,_) -> id
             | CCoFix(_,id,_) -> id
             | _ -> assert false in
-          CLetIn(loc,(li,Name id),fixp,c)
+          CLetIn(!@loc,(li,Name id),fixp,c)
       | "let"; lb = ["("; l=LIST0 name SEP ","; ")" -> l | "()" -> []];
 	  po = return_type;
 	  ":="; c1 = operconstr LEVEL "200"; "in";
           c2 = operconstr LEVEL "200" ->
-          CLetTuple (loc,lb,po,c1,c2)
+          CLetTuple (!@loc,lb,po,c1,c2)
       | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200";
           "in"; c2 = operconstr LEVEL "200" ->
-	    CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)])
+	    CCases (!@loc, LetPatternStyle, None, [(c1,(None,None))], [(!@loc, [(!@loc,[p])], c2)])
       | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200";
 	  rt = case_type; "in"; c2 = operconstr LEVEL "200" ->
-	    CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(loc, [(loc, [p])], c2)])
-      | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200";
+	    CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(!@loc, [(!@loc, [p])], c2)])
+      | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200";
 	  ":="; c1 = operconstr LEVEL "200"; rt = case_type;
           "in"; c2 = operconstr LEVEL "200" ->
-	    CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(loc, [(loc, [p])], c2)])
+	    CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(!@loc, [(!@loc, [p])], c2)])
       | "if"; c=operconstr LEVEL "200"; po = return_type;
 	"then"; b1=operconstr LEVEL "200";
         "else"; b2=operconstr LEVEL "200" ->
-          CIf (loc, c, po, b1, b2)
+          CIf (!@loc, c, po, b1, b2)
       | c=fix_constr -> c ] ]
   ;
   appl_arg:
     [ [ id = lpar_id_coloneq; c=lconstr; ")" ->
-	  (c,Some (loc,ExplByName id))
+	  (c,Some (!@loc,ExplByName id))
       | c=operconstr LEVEL "9" -> (c,None) ] ]
   ;
   atomic_constr:
-    [ [ g=global -> CRef g
-      | s=sort -> CSort (loc,s)
-      | n=INT -> CPrim (loc, Numeral (Bigint.of_string n))
-      | s=string -> CPrim (loc, String s)
-      | "_" -> CHole (loc, None)
-      | id=pattern_ident -> CPatVar(loc,(false,id)) ] ]
+    [ [ g=global; i=instance -> CRef (g,i)
+      | s=sort -> CSort (!@loc,s)
+      | n=INT -> CPrim (!@loc, Numeral (Bigint.of_string n))
+      | s=string -> CPrim (!@loc, String s)
+      | "_" -> CHole (!@loc, None, IntroAnonymous, None)
+      | "?"; "["; id=ident; "]"  -> CHole (!@loc, None, IntroIdentifier id, None)
+      | "?"; "["; id=pattern_ident; "]"  -> CHole (!@loc, None, IntroFresh id, None)
+      | id=pattern_ident; inst = evar_instance -> CEvar(!@loc,id,inst) ] ]
+  ;
+  inst:
+    [ [ id = ident; ":="; c = lconstr -> (id,c) ] ]
+  ;
+  evar_instance:
+    [ [ "@{"; l = LIST1 inst SEP ";"; "}" -> l
+      | -> [] ] ]
+  ;
+  instance:
+    [ [ "@{"; l = LIST1 level; "}" -> Some l
+      | -> None ] ]
+  ;
+  level:
+    [ [ "Set" -> GSet
+      | "Prop" -> GProp
+      | "Type" -> GType None
+      | id = ident -> GType (Some (Id.to_string id))
+      ] ]
   ;
   fix_constr:
     [ [ fx1=single_fix -> mk_single_fix fx1
       | (_,kw,dcl1)=single_fix; "with"; dcls=LIST1 fix_decl SEP "with";
         "for"; id=identref ->
-          mk_fix(loc,kw,id,dcl1::dcls)
+          mk_fix(!@loc,kw,id,dcl1::dcls)
     ] ]
   ;
   single_fix:
-    [ [ kw=fix_kw; dcl=fix_decl -> (loc,kw,dcl) ] ]
+    [ [ kw=fix_kw; dcl=fix_decl -> (!@loc,kw,dcl) ] ]
   ;
   fix_kw:
     [ [ "fix" -> true
@@ -292,14 +332,14 @@ GEXTEND Gram
   ;
   match_constr:
     [ [ "match"; ci=LIST1 case_item SEP ","; ty=OPT case_type; "with";
-        br=branches; "end" -> CCases(loc,RegularStyle,ty,ci,br) ] ]
+        br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ]
   ;
   case_item:
     [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
   ;
   pred_pattern:
     [ [ ona = OPT ["as"; id=name -> id];
-        ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
+        ty = OPT ["in"; t=pattern -> t] -> (ona,ty) ] ]
   ;
   case_type:
     [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
@@ -316,11 +356,11 @@ GEXTEND Gram
     [ [ OPT"|"; br=LIST0 eqn SEP "|" -> br ] ]
   ;
   mult_pattern:
-    [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (loc,pl) ] ]
+    [ [ pl = LIST1 pattern LEVEL "99" SEP "," -> (!@loc,pl) ] ]
   ;
   eqn:
     [ [ pll = LIST1 mult_pattern SEP "|";
-        "=>"; rhs = lconstr -> (loc,pll,rhs) ] ]
+        "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ]
   ;
   recordpattern:
     [ [ id = global; ":="; pat = pattern -> (id, pat) ] ]
@@ -328,42 +368,44 @@ GEXTEND Gram
   pattern:
     [ "200" RIGHTA [ ]
     | "100" RIGHTA
-      [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (loc,p::pl) ]
+      [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (!@loc,p::pl) ]
     | "99" RIGHTA [ ]
     | "10" LEFTA
       [ p = pattern; "as"; id = ident ->
-	  CPatAlias (loc, p, id) ]
+	  CPatAlias (!@loc, p, id) ]
     | "9" RIGHTA
       [ p = pattern; lp = LIST1 NEXT ->
         (match p with
-          | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp)
-          | _ -> Util.user_err_loc
+	  | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp)
+	  | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp)
+	  | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp)
+          | _ -> Errors.user_err_loc
               (cases_pattern_expr_loc p, "compound_pattern",
-               Pp.str "Constructor expected."))
+               Pp.str "Such pattern cannot have arguments."))
       |"@"; r = Prim.reference; lp = LIST1 NEXT ->
-        CPatCstrExpl (loc, r, lp) ]
+        CPatCstr (!@loc, r, lp, []) ]
     | "1" LEFTA
-      [ c = pattern; "%"; key=IDENT -> CPatDelimiters (loc,key,c) ]
+      [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ]
     | "0"
-      [ r = Prim.reference -> CPatAtom (loc,Some r)
-      | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (loc, pat)
-      | "_" -> CPatAtom (loc,None)
+      [ r = Prim.reference -> CPatAtom (!@loc,Some r)
+      | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (!@loc, pat)
+      | "_" -> CPatAtom (!@loc,None)
       | "("; p = pattern LEVEL "200"; ")" ->
           (match p with
               CPatPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
-                CPatNotation(loc,"( _ )",([p],[]))
+                CPatNotation(!@loc,"( _ )",([p],[]),[])
             | _ -> p)
-      | n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n))
-      | s = string -> CPatPrim (loc, String s) ] ]
+      | n = INT -> CPatPrim (!@loc, Numeral (Bigint.of_string n))
+      | s = string -> CPatPrim (!@loc, String s) ] ]
   ;
   impl_ident_tail:
-    [ [ "}" -> fun id -> LocalRawAssum([id], Default Implicit, CHole(loc, None))
-    | idl=LIST1 name; ":"; c=lconstr; "}" ->
-        (fun id -> LocalRawAssum (id::idl,Default Implicit,c))
-    | idl=LIST1 name; "}" ->
-        (fun id -> LocalRawAssum (id::idl,Default Implicit,CHole (loc, None)))
+    [ [ "}" -> binder_of_name Implicit
+    | nal=LIST1 name; ":"; c=lconstr; "}" ->
+        (fun na -> LocalRawAssum (na::nal,Default Implicit,c))
+    | nal=LIST1 name; "}" ->
+        (fun na -> LocalRawAssum (na::nal,Default Implicit,CHole (Loc.join_loc (fst na) !@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)))
     | ":"; c=lconstr; "}" ->
-	(fun id -> LocalRawAssum ([id],Default Implicit,c))
+	(fun na -> LocalRawAssum ([na],Default Implicit,c))
     ] ]
   ;
   fixannot:
@@ -373,9 +415,12 @@ GEXTEND Gram
 	rel=OPT constr; "}" -> (id, CMeasureRec (m,rel))
     ] ]
   ;
+  impl_name_head:
+    [ [ id = impl_ident_head -> (!@loc,Name id) ] ]
+  ;
   binders_fixannot:
-    [ [ id = impl_ident_head; assum = impl_ident_tail; bl = binders_fixannot ->
-          (assum (loc, Name id) :: fst bl), snd bl
+    [ [ na = impl_name_head; assum = impl_ident_tail; bl = binders_fixannot ->
+          (assum na :: fst bl), snd bl
       | f = fixannot -> [], f
       | b = binder; bl = binders_fixannot -> b @ fst bl, snd bl
       | -> [], (None, CStructRec)
@@ -391,8 +436,8 @@ GEXTEND Gram
       | id = name; idl = LIST0 name; bl = binders ->
           binders_of_names (id::idl) @ bl
       | id1 = name; ".."; id2 = name ->
-          [LocalRawAssum ([id1;(loc,Name ldots_var);id2],
-	                  Default Explicit,CHole (loc,None))]
+          [LocalRawAssum ([id1;(!@loc,Name ldots_var);id2],
+	                  Default Explicit,CHole (!@loc, None, IntroAnonymous, None))]
       | bl = closed_binder; bl' = binders ->
 	  bl@bl'
     ] ]
@@ -401,7 +446,7 @@ GEXTEND Gram
     [ [ l = LIST0 binder -> List.flatten l ] ]
   ;
   binder:
-    [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))]
+    [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (!@loc, None, IntroAnonymous, None))]
       | bl = closed_binder -> bl ] ]
   ;
   closed_binder:
@@ -412,15 +457,15 @@ GEXTEND Gram
       | "("; id=name; ":="; c=lconstr; ")" ->
           [LocalRawDef (id,c)]
       | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" ->
-          [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))]
+          [LocalRawDef (id,CCast (Loc.merge (constr_loc t) (!@loc),c, CastConv t))]
       | "{"; id=name; "}" ->
-          [LocalRawAssum ([id],Default Implicit,CHole (loc, None))]
+          [LocalRawAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))]
       | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" ->
           [LocalRawAssum (id::idl,Default Implicit,c)]
       | "{"; id=name; ":"; c=lconstr; "}" ->
           [LocalRawAssum ([id],Default Implicit,c)]
       | "{"; id=name; idl=LIST1 name; "}" ->
-          List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl)
+          List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (!@loc, None, IntroAnonymous, None))) (id::idl)
       | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" ->
 	  List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc
       | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" ->
@@ -428,17 +473,17 @@ GEXTEND Gram
     ] ]
   ;
   typeclass_constraint:
-    [ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c
+    [ [ "!" ; c = operconstr LEVEL "200" -> (!@loc, Anonymous), true, c
       | "{"; id = name; "}"; ":" ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" ->
 	  id, expl, c
       | iid=name_colon ; expl = [ "!" -> true | -> false ] ; c = operconstr LEVEL "200" ->
-	  (loc, iid), expl, c
+	  (!@loc, iid), expl, c
       | c = operconstr LEVEL "200" ->
-	  (loc, Anonymous), false, c
+	  (!@loc, Anonymous), false, c
     ] ]
   ;
 
   type_cstr:
-    [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ]
+    [ [ c=OPT [":"; c=lconstr -> c] -> (!@loc,c) ] ]
   ;
   END;;
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
index 34615ad1..b4d96e5c 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -1,21 +1,23 @@
 (************************************************************************)
 (*  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 Topconstr
-open Glob_term
+open Compat
+open Constrexpr
 open Tacexpr
-open Vernacexpr
+open Misctypes
+open Genarg
+open Genredexpr
+open Tok (* necessary for camlp4 *)
+
 open Pcoq
-open Prim
-open Tactic
-open Tok
+open Pcoq.Prim
+open Pcoq.Tactic
 
 let fail_default_value = ArgArg 0
 
@@ -23,10 +25,14 @@ let arg_of_expr = function
     TacArg (loc,a) -> a
   | e -> Tacexp (e:raw_tactic_expr)
 
+let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) ()
+let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n
+let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat
+
 (* Tactics grammar rules *)
 
 GEXTEND Gram
-  GLOBAL: tactic Vernac_.command tactic_expr binder_tactic tactic_arg
+  GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg
           constr_may_eval;
 
   tactic_then_last:
@@ -44,29 +50,44 @@ GEXTEND Gram
       | -> ([TacId []], None)
     ] ]
   ;
+  tactic_then_locality: (* [true] for the local variant [TacThens] and [false]
+                           for [TacExtend] *)
+  [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ]
+  ;
   tactic_expr:
     [ "5" RIGHTA
       [ te = binder_tactic -> te ]
     | "4" LEFTA
-      [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, [||], ta1, [||])
-      | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,  [||], ta1, [||])
-      | ta0 = tactic_expr; ";"; "["; (first,tail) = tactic_then_gen; "]" ->
-	  match tail with
-	  | Some (t,last) -> TacThen (ta0, Array.of_list first, t, last)
-	  | None -> TacThens (ta0,first) ]
+      [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1)
+      | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1)
+      | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" ->
+	  match l , tail with
+          | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last))
+	  | true  , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last)
+          | false , None -> TacThen (ta0,TacDispatch first)
+	  | true  , None -> TacThens (ta0,first) ]
     | "3" RIGHTA
       [ IDENT "try"; ta = tactic_expr -> TacTry ta
       | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta)
       | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta)
+      | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta)
       | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta
       | IDENT "progress"; ta = tactic_expr -> TacProgress ta
+      | IDENT "once"; ta = tactic_expr -> TacOnce ta
+      | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta
+      | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta
 (*To do: put Abstract in Refiner*)
       | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None)
       | IDENT "abstract"; tc = NEXT; "using";  s = ident ->
           TacAbstract (tc,Some s) ]
 (*End of To do*)
     | "2" RIGHTA
-      [ ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1)
+      [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1)
+      | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) 
+      | IDENT "tryif" ; ta = tactic_expr ;
+              "then" ; tat = tactic_expr ;
+              "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae)
+      | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1)
       | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ]
     | "1" RIGHTA
       [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" ->
@@ -81,23 +102,25 @@ GEXTEND Gram
       | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" ->
 	  TacSolve l
       | IDENT "idtac"; l = LIST0 message_token -> TacId l
-      | IDENT "fail"; n = [ n = int_or_var -> n | -> fail_default_value ];
-	  l = LIST0 message_token -> TacFail (n,l)
-      | IDENT "external"; com = STRING; req = STRING; la = LIST1 tactic_arg ->
-	  TacArg (loc,TacExternal (loc,com,req,la))
-      | st = simple_tactic -> TacAtom (loc,st)
-      | a = may_eval_arg -> TacArg(loc,a)
-      | IDENT "constr"; ":"; id = METAIDENT ->
-          TacArg(loc,MetaIdArg (loc,false,id))
+      | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ];
+	  l = LIST0 message_token -> TacFail (g,n,l)
+      | st = simple_tactic -> st
       | IDENT "constr"; ":"; c = Constr.constr ->
-          TacArg(loc,ConstrMayEval(ConstrTerm c))
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern ->
-	  TacArg(loc,IntroPattern ipat)
+          TacArg(!@loc,ConstrMayEval(ConstrTerm c))
+      | a = tactic_top_or_arg -> TacArg(!@loc,a)
       | r = reference; la = LIST0 tactic_arg ->
-          TacArg(loc,TacCall (loc,r,la)) ]
+          TacArg(!@loc,TacCall (!@loc,r,la)) ]
     | "0"
       [ "("; a = tactic_expr; ")" -> a
-      | a = tactic_atom -> TacArg (loc,a) ] ]
+      | "["; ">"; (tf,tail) = tactic_then_gen; "]" ->
+          begin match tail with
+          | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl)
+          | None -> TacDispatch tf
+          end
+      | a = tactic_atom -> TacArg (!@loc,a) ] ]
+  ;
+  failkw:
+  [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ]
   ;
   (* binder_tactic: level 5 of tactic_expr *)
   binder_tactic:
@@ -112,21 +135,26 @@ GEXTEND Gram
   (* Tactic arguments *)
   tactic_arg:
     [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a
-      | IDENT "ltac"; ":"; n = natural -> Integer n
-      | IDENT "ipattern"; ":"; ipat = simple_intropattern -> IntroPattern ipat
-      | a = may_eval_arg -> a
+      | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n)
+      | a = tactic_top_or_arg -> a
       | r = reference -> Reference r
       | c = Constr.constr -> ConstrMayEval (ConstrTerm c)
       (* Unambigous entries: tolerated w/o "ltac:" modifier *)
-      | id = METAIDENT -> MetaIdArg (loc,true,id)
-      | "()" -> TacVoid ] ]
+      | id = METAIDENT -> MetaIdArg (!@loc,true,id)
+      | "()" -> TacGeneric (genarg_of_unit ()) ] ]
   ;
-  may_eval_arg:
-    [ [ c = constr_eval -> ConstrMayEval c
-      | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l ] ]
+  (* Can be used as argument and at toplevel in tactic expressions. *)
+  tactic_top_or_arg:
+    [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c
+      | IDENT "ipattern"; ":"; ipat = simple_intropattern ->
+        TacGeneric (genarg_of_ipattern ipat)
+      | c = constr_eval -> ConstrMayEval c
+      | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l
+      | IDENT "type_term"; c=uconstr -> TacPretype c
+      | IDENT "numgoals" -> TacNumgoals ] ]
   ;
   fresh_id:
-    [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (loc,id) ] ]
+    [ [ s = STRING -> ArgArg s | id = ident -> ArgVar (!@loc,id) ] ]
   ;
   constr_eval:
     [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr ->
@@ -141,13 +169,15 @@ GEXTEND Gram
       | c = Constr.constr -> ConstrTerm c ] ]
   ;
   tactic_atom:
-    [ [ id = METAIDENT -> MetaIdArg (loc,true,id)
-      | n = integer -> Integer n
-      | r = reference -> TacCall (loc,r,[])
-      | "()" -> TacVoid ] ]
+    [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id)
+      | n = integer -> TacGeneric (genarg_of_int n)
+      | r = reference -> TacCall (!@loc,r,[])
+      | "()" -> TacGeneric (genarg_of_unit ()) ] ]
   ;
   match_key:
-    [ [ "match" -> false | "lazymatch" -> true ] ]
+    [ [ "match" -> Once
+      | "lazymatch" -> Select
+      | "multimatch" -> General ] ]
   ;
   input_fun:
     [ [ "_" -> None
@@ -162,9 +192,11 @@ GEXTEND Gram
   match_pattern:
     [ [ IDENT "context";  oid = OPT Constr.ident;
           "["; pc = Constr.lconstr_pattern; "]" ->
-        Subterm (false,oid, pc)
+        let mode = not (!Flags.tactic_context_compat) in
+        Subterm (mode, oid, pc)
       | IDENT "appcontext";  oid = OPT Constr.ident;
           "["; pc = Constr.lconstr_pattern; "]" ->
+        msg_warning (strbrk "appcontext is deprecated");
         Subterm (true,oid, pc)
       | pc = Constr.lconstr_pattern -> Term pc ] ]
   ;
@@ -175,10 +207,10 @@ GEXTEND Gram
 	  let t, ty =
 	    match mpv with
 	    | Term t -> (match t with
-	      | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty)
+	      | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty)
 	      | _ -> mpv, None)
 	    | _ -> mpv, None
-	  in Def (na, t, Option.default (Term (CHole (dummy_loc, None))) ty)
+	  in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty)
     ] ]
   ;
   match_context_rule:
@@ -201,7 +233,7 @@ GEXTEND Gram
       | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ]
   ;
   message_token:
-    [ [ id = identref -> MsgIdent (AI id)
+    [ [ id = identref -> MsgIdent id
       | s = STRING -> MsgString s
       | n = integer -> MsgInt n ] ]
   ;
@@ -221,9 +253,4 @@ GEXTEND Gram
   tactic:
     [ [ tac = tactic_expr -> tac ] ]
   ;
-  Vernac_.command:
-    [ [ IDENT "Ltac";
-        l = LIST1 tacdef_body SEP "with" ->
-          VernacDeclareTacticDefinition (use_module_locality (), true, l) ] ]
-  ;
   END
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index e0aae9a6..84da9c42 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -1,25 +1,24 @@
 (************************************************************************)
 (*  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 Pcoq
+open Compat
 open Names
 open Libnames
-open Topconstr
-open Tok
-open Compat
+open Tok (* necessary for camlp4 *)
+
+open Pcoq
+open Pcoq.Prim
 
 let prim_kw = ["{"; "}"; "["; "]"; "("; ")"; "'"]
 let _ = List.iter Lexer.add_keyword prim_kw
 
-open Prim
-open Nametab
 
-let local_make_qualid l id = make_qualid (make_dirpath l) id
+let local_make_qualid l id = make_qualid (DirPath.make l) id
 
 let my_int_of_string loc s =
   try
@@ -29,7 +28,7 @@ let my_int_of_string loc s =
     if n > 1024 * 2048 then raise Exit;
     n
   with Failure _ | Exit ->
-    Util.user_err_loc (loc,"",Pp.str "Cannot support a so large number.")
+    Errors.user_err_loc (loc,"",Pp.str "Cannot support a so large number.")
 
 GEXTEND Gram
   GLOBAL:
@@ -40,22 +39,22 @@ GEXTEND Gram
     [ [ s = IDENT -> s ] ]
   ;
   ident:
-    [ [ s = IDENT -> id_of_string s ] ]
+    [ [ s = IDENT -> Id.of_string s ] ]
   ;
   pattern_ident:
     [ [ LEFTQMARK; id = ident -> id ] ]
   ;
   pattern_identref:
-    [ [ id = pattern_ident -> (loc, id) ] ]
+    [ [ id = pattern_ident -> (!@loc, id) ] ]
   ;
   var: (* as identref, but interpret as a term identifier in ltac *)
-    [ [ id = ident -> (loc,id) ] ]
+    [ [ id = ident -> (!@loc, id) ] ]
   ;
   identref:
-    [ [ id = ident -> (loc,id) ] ]
+    [ [ id = ident -> (!@loc, id) ] ]
   ;
   field:
-    [ [ s = FIELD -> id_of_string s ] ]
+    [ [ s = FIELD -> Id.of_string s ] ]
   ;
   fields:
     [ [ id = field; (l,id') = fields -> (l@[id],id')
@@ -63,8 +62,8 @@ GEXTEND Gram
       ] ]
   ;
   fullyqualid:
-    [ [ id = ident; (l,id')=fields -> loc,id::List.rev (id'::l)
-      | id = ident -> loc,[id]
+    [ [ id = ident; (l,id')=fields -> !@loc,id::List.rev (id'::l)
+      | id = ident -> !@loc,[id]
       ] ]
   ;
   basequalid:
@@ -73,46 +72,46 @@ GEXTEND Gram
       ] ]
   ;
   name:
-    [ [ IDENT "_" -> (loc, Anonymous)
-      | id = ident -> (loc, Name id) ] ]
+    [ [ IDENT "_" -> (!@loc, Anonymous)
+      | id = ident -> (!@loc, Name id) ] ]
   ;
   reference:
     [ [ id = ident; (l,id') = fields ->
-        Qualid (loc, local_make_qualid (l@[id]) id')
-      | id = ident -> Ident (loc,id)
+        Qualid (!@loc, local_make_qualid (l@[id]) id')
+      | id = ident -> Ident (!@loc,id)
       ] ]
   ;
   by_notation:
-    [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (loc,s,sc) ] ]
+    [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (!@loc, s, sc) ] ]
   ;
   smart_global:
-    [ [ c = reference -> Genarg.AN c
-      | ntn = by_notation -> Genarg.ByNotation ntn ] ]
+    [ [ c = reference -> Misctypes.AN c
+      | ntn = by_notation -> Misctypes.ByNotation ntn ] ]
   ;
   qualid:
-    [ [ qid = basequalid -> loc, qid ] ]
+    [ [ qid = basequalid -> !@loc, qid ] ]
   ;
   ne_string:
     [ [ s = STRING ->
-        if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string."); s
+        if s="" then Errors.user_err_loc(!@loc, "", Pp.str"Empty string."); s
     ] ]
   ;
   ne_lstring:
-    [ [ s = ne_string -> (loc,s) ] ]
+    [ [ s = ne_string -> (!@loc, s) ] ]
   ;
   dirpath:
     [ [ id = ident; l = LIST0 field ->
-        make_dirpath (l@[id]) ] ]
+        DirPath.make (List.rev (id::l)) ] ]
   ;
   string:
     [ [ s = STRING -> s ] ]
   ;
   integer:
-    [ [ i = INT      -> my_int_of_string loc i
-      | "-"; i = INT -> - my_int_of_string loc i ] ]
+    [ [ i = INT      -> my_int_of_string (!@loc) i
+      | "-"; i = INT -> - my_int_of_string (!@loc) i ] ]
   ;
   natural:
-    [ [ i = INT -> my_int_of_string loc i ] ]
+    [ [ i = INT -> my_int_of_string (!@loc) i ] ]
   ;
   bigint: (* Negative numbers are dealt with specially *)
     [ [ i = INT -> (Bigint.of_string i) ] ]
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 557972ce..27f14c79 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -1,24 +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        *)
 (************************************************************************)
 
-open Pcoq
-open Pp
-open Tactic
-open Util
-open Vernac_
-open Topconstr
+open Compat
+open Constrexpr
 open Vernacexpr
-open Prim
-open Constr
+open Misctypes
 open Tok
 
+open Pcoq
+open Pcoq.Tactic
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Vernac_
+
 let thm_token = G_vernac.thm_token
 
+let hint_proof_using e = function
+  | Some _ as x -> x
+  | None -> match Proof_using.get_default_proof_using () with
+     | None -> None
+     | Some s -> Some (Gram.entry_parse e (Gram.parsable (Stream.of_string s)))
+
 (* Proof commands *)
 GEXTEND Gram
   GLOBAL: command;
@@ -29,12 +36,13 @@ GEXTEND Gram
   ;
   command:
     [ [ IDENT "Goal"; c = lconstr -> VernacGoal c
-      | IDENT "Proof" -> VernacProof (None,None)
+      | IDENT "Proof" ->
+          VernacProof (None,hint_proof_using G_vernac.section_subset_descr None)
       | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn
       | IDENT "Proof"; "with"; ta = tactic; 
-        l = OPT [ "using"; l = LIST0 identref  -> l ] ->
-          VernacProof (Some ta, l)
-      | IDENT "Proof"; "using"; l = LIST0 identref; 
+        l = OPT [ "using"; l = G_vernac.section_subset_descr -> l ] ->
+          VernacProof (Some ta,hint_proof_using G_vernac.section_subset_descr l)
+      | IDENT "Proof"; "using"; l = G_vernac.section_subset_descr;
         ta = OPT [ "with"; ta = tactic -> ta ] ->
           VernacProof (ta,Some l)
       | IDENT "Proof"; c = lconstr -> VernacExactProof c
@@ -70,6 +78,7 @@ GEXTEND Gram
       | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode
       | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript
       | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials
+      | IDENT "Show"; IDENT "Universes" -> VernacShow ShowUniverses
       | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree
       | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames
       | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof
@@ -81,29 +90,35 @@ GEXTEND Gram
       (* Hints for Auto and EAuto *)
       | IDENT "Create"; IDENT "HintDb" ;
 	  id = IDENT ; b = [ "discriminated" -> true | -> false ] ->
-	    VernacCreateHintDb (use_module_locality (), id, b)
+	    VernacCreateHintDb (id, b)
       | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases ->
-	  VernacRemoveHints (use_module_locality (), dbnames, ids)
+	  VernacRemoveHints (dbnames, ids)
       | IDENT "Hint"; local = obsolete_locality; h = hint;
 	  dbnames = opt_hintbases ->
-	  VernacHints (enforce_module_locality local,dbnames, h)
+	  VernacHints (local,dbnames, h)
       (* Declare "Resolve" explicitly so as to be able to later extend with
          "Resolve ->" and "Resolve <-" *)
-      | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural;
+      | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; 
+	  pri = OPT [ "|"; i = natural -> i ];
 	  dbnames = opt_hintbases ->
-	  VernacHints (use_module_locality (),dbnames,
-	    HintsResolve (List.map (fun x -> (n, true, x)) lc))
+	  VernacHints (false,dbnames,
+	    HintsResolve (List.map (fun x -> (pri, true, x)) lc))
       ] ];
-
   obsolete_locality:
     [ [ IDENT "Local" -> true | -> false ] ]
   ;
+  reference_or_constr:
+   [ [ r = global -> HintsReference r
+     | c = constr -> HintsConstr c ] ]
+  ;
   hint:
-    [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural ->
-          HintsResolve (List.map (fun x -> (n, true, x)) lc)
-      | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc
+    [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; 
+	pri = OPT [ "|"; i = natural -> i ] ->
+          HintsResolve (List.map (fun x -> (pri, true, x)) lc)
+      | IDENT "Immediate"; lc = LIST1 reference_or_constr -> HintsImmediate lc
       | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true)
       | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false)
+      | IDENT "Mode"; l = global; m = mode -> HintsMode (l, m)
       | IDENT "Unfold"; lqid = LIST1 global -> HintsUnfold lqid
       | IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc
       | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>";
@@ -112,6 +127,9 @@ GEXTEND Gram
     ;
   constr_body:
     [ [ ":="; c = lconstr -> c
-      | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Glob_term.CastConv (Term.DEFAULTcast,t)) ] ]
+      | ":"; t = lconstr; ":="; c = lconstr -> CCast(!@loc,c,CastConv t) ] ]
+  ;
+  mode:
+    [ [ l = LIST1 ["+" -> true | "-" -> false] -> l ] ]
   ;
 END
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index 820a1f16..b42b2c6d 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -1,24 +1,28 @@
 (************************************************************************)
 (*  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 Pcoq
+open Errors
 open Util
 open Tacexpr
-open Glob_term
-open Genarg
-open Topconstr
+open Genredexpr
+open Constrexpr
 open Libnames
-open Termops
 open Tok
 open Compat
+open Misctypes
+open Locus
+open Decl_kinds
+
+open Pcoq
 
-let all_with delta = make_red_flag [FBeta;FIota;FZeta;delta]
+
+let all_with delta = Redops.make_red_flag [FBeta;FIota;FZeta;delta]
 
 let tactic_kw = [ "->"; "<-" ; "by" ]
 let _ = List.iter Lexer.add_keyword tactic_kw
@@ -73,18 +77,18 @@ let check_for_coloneq =
   Gram.Entry.of_parser "lpar_id_colon"
     (fun strm ->
       let rec skip_to_rpar p n =
-	match get_tok (list_last (Stream.npeek n strm)) with
+	match get_tok (List.last (Stream.npeek n strm)) with
         | KEYWORD "(" -> skip_to_rpar (p+1) (n+1)
-        | KEYWORD ")" -> if p=0 then n+1 else skip_to_rpar (p-1) (n+1)
+        | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1)
 	| KEYWORD "." -> err ()
 	| _ -> skip_to_rpar p (n+1) in
       let rec skip_names n =
-	match get_tok (list_last (Stream.npeek n strm)) with
+	match get_tok (List.last (Stream.npeek n strm)) with
         | IDENT _ | KEYWORD "_" -> skip_names (n+1)
 	| KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *)
 	| _ -> err () in
       let rec skip_binders n =
-	match get_tok (list_last (Stream.npeek n strm)) with
+	match get_tok (List.last (Stream.npeek n strm)) with
         | KEYWORD "(" -> skip_binders (skip_names (n+1))
         | IDENT _ | KEYWORD "_" -> skip_binders (n+1)
 	| KEYWORD ":=" -> ()
@@ -110,39 +114,41 @@ let mk_fix_tac (loc,id,bl,ann,ty) =
         [([_],_,_)], None -> 1
       | _, Some x ->
           let ids = List.map snd (List.flatten (List.map pi1 bl)) in
-          (try list_index (snd x) ids
+          (try List.index Names.Name.equal (snd x) ids
           with Not_found -> error "No such fix variable.")
       | _ -> error "Cannot guess decreasing argument of fix." in
   (id,n,CProdN(loc,bl,ty))
 
 let mk_cofix_tac (loc,id,bl,ann,ty) =
   let _ = Option.map (fun (aloc,_) ->
-    Util.user_err_loc
+    user_err_loc
       (aloc,"Constr:mk_cofix_tac",
        Pp.str"Annotation forbidden in cofix expression.")) ann in
   (id,CProdN(loc,bl,ty))
 
 (* Functions overloaded by quotifier *)
-let induction_arg_of_constr (c,lbind as clbind) =
-  if lbind = NoBindings then
-    try ElimOnIdent (constr_loc c,snd(coerce_to_id c))
-    with e when Errors.noncritical e -> ElimOnConstr clbind
-  else ElimOnConstr clbind
+let induction_arg_of_constr (c,lbind as clbind) = match lbind with
+  | NoBindings ->
+    begin
+      try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c))
+      with e when Errors.noncritical e -> ElimOnConstr clbind
+    end
+  | _ -> ElimOnConstr clbind
 
 let mkTacCase with_evar = function
-  | [ElimOnConstr cl,(None,None)],None,None ->
-      TacCase (with_evar,cl)
+  | [(clear,ElimOnConstr cl),(None,None),None],None ->
+      TacCase (with_evar,(clear,cl))
   (* Reinterpret numbers as a notation for terms *)
-  | [ElimOnAnonHyp n,(None,None)],None,None ->
+  | [(clear,ElimOnAnonHyp n),(None,None),None],None ->
       TacCase (with_evar,
-        (CPrim (dummy_loc, Numeral (Bigint.of_int n)),
-	 NoBindings))
+        (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)),
+	 NoBindings)))
   (* Reinterpret ident as notations for variables in the context *)
   (* because we don't know if they are quantified or not *)
-  | [ElimOnIdent id,(None,None)],None,None ->
-      TacCase (with_evar,(CRef (Ident id),NoBindings))
+  | [(clear,ElimOnIdent id),(None,None),None],None ->
+      TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings)))
   | ic ->
-      if List.exists (function (ElimOnAnonHyp _,_) -> true | _ -> false) (pi1 ic)
+      if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic)
       then
 	error "Use of numbers as direct arguments of 'case' is not supported.";
       TacInductionDestruct (false,with_evar,ic)
@@ -150,146 +156,156 @@ let mkTacCase with_evar = function
 let rec mkCLambdaN_simple_loc loc bll c =
   match bll with
   | ((loc1,_)::_ as idl,bk,t) :: bll ->
-      CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (join_loc loc1 loc) bll c)
+      CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c)
   | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c
   | [] -> c
 
-let mkCLambdaN_simple bl c =
-  if bl=[] then c
-  else
-    let loc = join_loc (fst (List.hd (pi1 (List.hd bl)))) (constr_loc c) in
+let mkCLambdaN_simple bl c = match bl with
+  | [] -> c
+  | h :: _ ->
+    let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in
     mkCLambdaN_simple_loc loc bl c
 
-let loc_of_ne_list l = join_loc (fst (List.hd l)) (fst (list_last l))
+let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l))
 
 let map_int_or_var f = function
-  | Glob_term.ArgArg x -> Glob_term.ArgArg (f x)
-  | Glob_term.ArgVar _ as y -> y
-
-let all_concl_occs_clause = { onhyps=Some[]; concl_occs=all_occurrences_expr }
+  | ArgArg x -> ArgArg (f x)
+  | ArgVar _ as y -> y
 
-let has_no_specified_occs cl =
-  (cl.onhyps = None || 
-    List.for_all (fun ((occs,_),_) -> occs = all_occurrences_expr)
-    (Option.get cl.onhyps))
-  && (cl.concl_occs = all_occurrences_expr 
-      || cl.concl_occs = no_occurrences_expr)
+let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences }
 
 let merge_occurrences loc cl = function
   | None ->
-      if has_no_specified_occs cl then (None, cl)
+      if Locusops.clause_with_generic_occurrences cl then (None, cl)
       else
 	user_err_loc (loc,"",str "Found an \"at\" clause without \"with\" clause.")
-  | Some (occs,p) ->
-      (Some p,
-      if occs = all_occurrences_expr then cl
-      else if cl = all_concl_occs_clause then { onhyps=Some[]; concl_occs=occs }
-      else match cl.onhyps with
-      | Some [(occs',id),l] when
-	  occs' = all_occurrences_expr && cl.concl_occs = no_occurrences_expr ->
-	  { cl with onhyps=Some[(occs,id),l] }
+  | Some (occs, p) ->
+    let ans = match occs with
+    | AllOccurrences -> cl
+    | _ ->
+      begin match cl with
+      | { onhyps = Some []; concl_occs = AllOccurrences } ->
+        { onhyps = Some []; concl_occs = occs }
+      | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } ->
+        { cl with onhyps = Some [(occs, id), l] }
       | _ ->
-	  if has_no_specified_occs cl then
-	    user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.")
-	  else
-	    user_err_loc (loc,"",str "Cannot use clause \"at\" twice."))
+        if Locusops.clause_with_generic_occurrences cl then
+          user_err_loc (loc,"",str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.")
+        else
+          user_err_loc (loc,"",str "Cannot use clause \"at\" twice.")
+      end
+    in
+    (Some p, ans)
 
 (* Auxiliary grammar rules *)
 
 GEXTEND Gram
   GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis
-  bindings red_expr int_or_var open_constr casted_open_constr open_constr_wTC
-  simple_intropattern;
+  bindings red_expr int_or_var open_constr uconstr
+  simple_intropattern clause_dft_concl;
 
   int_or_var:
-    [ [ n = integer  -> Glob_term.ArgArg n
-      | id = identref -> Glob_term.ArgVar id ] ]
+    [ [ n = integer  -> ArgArg n
+      | id = identref -> ArgVar id ] ]
   ;
   nat_or_var:
-    [ [ n = natural  -> Glob_term.ArgArg n
-      | id = identref -> Glob_term.ArgVar id ] ]
+    [ [ n = natural  -> ArgArg n
+      | id = identref -> ArgVar id ] ]
   ;
   (* An identifier or a quotation meta-variable *)
   id_or_meta:
-    [ [ id = identref -> AI id
-
-      (* This is used in quotations *)
-      | id = METAIDENT -> MetaId (loc,id) ] ]
+    [ [ id = identref -> id ] ]
   ;
   open_constr:
     [ [ c = constr -> ((),c) ] ]
   ;
-  open_constr_wTC:
-    [ [ c = constr -> ((),c) ] ]
-  ;
-  casted_open_constr:
-    [ [ c = constr -> ((),c) ] ]
+  uconstr:
+    [ [ c = constr -> c ] ]
   ;
   induction_arg:
-    [ [ n = natural -> ElimOnAnonHyp n
-      | c = constr_with_bindings -> induction_arg_of_constr c
+    [ [ n = natural -> (None,ElimOnAnonHyp n)
+      | c = constr_with_bindings -> (None,induction_arg_of_constr c)
+      | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c)
     ] ]
   ;
+  constr_with_bindings_arg:
+    [ [ ">"; c = constr_with_bindings -> (Some true,c)
+      | c = constr_with_bindings -> (None,c) ] ]
+  ;
   quantified_hypothesis:
     [ [ id = ident -> NamedHyp id
       | n = natural -> AnonHyp n ] ]
   ;
   conversion:
     [ [ c = constr -> (None, c)
-      | c1 = constr; "with"; c2 = constr -> (Some (all_occurrences_expr,c1),c2)
+      | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2)
       | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr ->
           (Some (occs,c1), c2) ] ]
   ;
   occs_nums:
-    [ [ nl = LIST1 nat_or_var -> no_occurrences_expr_but nl
+    [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl
       | "-"; n = nat_or_var; nl = LIST0 int_or_var ->
 	  (* have used int_or_var instead of nat_or_var for compatibility *)
-	   all_occurrences_expr_but (List.map (map_int_or_var abs) (n::nl)) ] ]
+	   AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ]
   ;
   occs:
-    [ [ "at"; occs = occs_nums -> occs | -> all_occurrences_expr ] ]
+    [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ]
   ;
   pattern_occ:
     [ [ c = constr; nl = occs -> (nl,c) ] ]
   ;
+  ref_or_pattern_occ:
+    (* If a string, it is interpreted as a ref
+       (anyway a Coq string does not reduce) *)
+    [ [ c = smart_global; nl = occs -> nl,Inl c
+      | c = constr; nl = occs -> nl,Inr c ] ]
+  ;
   unfold_occ:
     [ [ c = smart_global; nl = occs -> (nl,c) ] ]
   ;
   intropatterns:
-    [ [ l = LIST0 simple_intropattern -> l ]]
+    [ [ l = LIST0 nonsimple_intropattern -> l ]]
   ;
-  disjunctive_intropattern:
-    [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> loc,IntroOrAndPattern tc
-      | "()" -> loc,IntroOrAndPattern [[]]
-      | "("; si = simple_intropattern; ")" -> loc,IntroOrAndPattern [[si]]
+  or_and_intropattern:
+    [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc
+      | "()" -> [[]]
+      | "("; si = simple_intropattern; ")" -> [[si]]
       | "("; si = simple_intropattern; ",";
-             tc = LIST1 simple_intropattern SEP "," ; ")" ->
-	       loc,IntroOrAndPattern [si::tc]
+             tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc]
       | "("; si = simple_intropattern; "&";
 	     tc = LIST1 simple_intropattern SEP "&" ; ")" ->
 	  (* (A & B & C) is translated into (A,(B,C)) *)
 	  let rec pairify = function
-	    | ([]|[_]|[_;_]) as l -> IntroOrAndPattern [l]
-	    | t::q -> IntroOrAndPattern [[t;(loc_of_ne_list q,pairify q)]]
-	  in loc,pairify (si::tc) ] ]
+	    | ([]|[_]|[_;_]) as l -> [l]
+	    | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]]
+	  in pairify (si::tc) ] ]
+  ;
+  equality_intropattern:
+    [ [ "->" -> IntroRewrite true
+      | "<-" -> IntroRewrite false
+      | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ]
   ;
   naming_intropattern:
-    [ [ prefix = pattern_ident -> loc, IntroFresh prefix
-      | "?" -> loc, IntroAnonymous
-      | id = ident -> loc, IntroIdentifier id
-      | "*" -> loc, IntroForthcoming true
-      | "**" -> loc, IntroForthcoming false ] ]
+    [ [ prefix = pattern_ident -> IntroFresh prefix
+      | "?" -> IntroAnonymous
+      | id = ident -> IntroIdentifier id ] ]
+  ;
+  nonsimple_intropattern:
+    [ [ l = simple_intropattern -> l
+      | "*" -> !@loc, IntroForthcoming true
+      | "**" -> !@loc, IntroForthcoming false ]]
   ;
   simple_intropattern:
-    [ [ pat = disjunctive_intropattern -> pat
-      | pat = naming_intropattern -> pat
-      | "_" -> loc, IntroWildcard
-      | "->" -> loc, IntroRewrite true
-      | "<-" -> loc, IntroRewrite false ] ]
+    [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat)
+      | pat = equality_intropattern -> !@loc, IntroAction pat
+      | "_" -> !@loc, IntroAction IntroWildcard 
+      | pat = simple_intropattern; "/"; c = constr ->
+          !@loc, IntroAction (IntroApplyOn (c,pat))
+      | pat = naming_intropattern -> !@loc, IntroNaming pat ] ]
   ;
   simple_binding:
-    [ [ "("; id = ident; ":="; c = lconstr; ")" -> (loc, NamedHyp id, c)
-      | "("; n = natural; ":="; c = lconstr; ")" -> (loc, AnonHyp n, c) ] ]
+    [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c)
+      | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ]
   ;
   bindings:
     [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding ->
@@ -297,7 +313,7 @@ GEXTEND Gram
       | bl = LIST1 constr -> ImplicitBindings bl ] ]
   ;
   opt_bindings:
-    [ [ bl = bindings -> bl | -> NoBindings ] ]
+    [ [ bl = LIST1 bindings SEP "," -> bl | -> [NoBindings] ] ]
   ;
   constr_with_bindings:
     [ [ c = constr; l = with_bindings -> (c, l) ] ]
@@ -319,18 +335,20 @@ GEXTEND Gram
     ] ]
   ;
   strategy_flag:
-    [ [ s = LIST1 red_flag -> make_red_flag s
+    [ [ s = LIST1 red_flag -> Redops.make_red_flag s
       | d = delta_flag -> all_with d
     ] ]
   ;
   red_tactic:
     [ [ IDENT "red" -> Red false
       | IDENT "hnf" -> Hnf
-      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po)
       | IDENT "cbv"; s = strategy_flag -> Cbv s
+      | IDENT "cbn"; s = strategy_flag -> Cbn s
       | IDENT "lazy"; s = strategy_flag -> Lazy s
       | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta)
-      | IDENT "vm_compute" -> CbvVm
+      | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po
+      | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po
       | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
       | IDENT "fold"; cl = LIST1 constr -> Fold cl
       | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl ] ]
@@ -339,11 +357,13 @@ GEXTEND Gram
   red_expr:
     [ [ IDENT "red" -> Red false
       | IDENT "hnf" -> Hnf
-      | IDENT "simpl"; po = OPT pattern_occ -> Simpl po
+      | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po)
       | IDENT "cbv"; s = strategy_flag -> Cbv s
+      | IDENT "cbn"; s = strategy_flag -> Cbn s
       | IDENT "lazy"; s = strategy_flag -> Lazy s
       | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta)
-      | IDENT "vm_compute" -> CbvVm
+      | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po
+      | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po
       | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
       | IDENT "fold"; cl = LIST1 constr -> Fold cl
       | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl
@@ -369,7 +389,7 @@ GEXTEND Gram
       | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ ->
           {onhyps=Some hl; concl_occs=occs}
       | hl=LIST0 hypident_occ SEP"," ->
-          {onhyps=Some hl; concl_occs=no_occurrences_expr} ] ]
+          {onhyps=Some hl; concl_occs=NoOccurrences} ] ]
   ;
   clause_dft_concl:
     [ [ "in"; cl = in_clause -> cl
@@ -378,21 +398,23 @@ GEXTEND Gram
   ;
   clause_dft_all:
     [ [ "in"; cl = in_clause -> cl
-      | -> {onhyps=None; concl_occs=all_occurrences_expr} ] ]
+      | -> {onhyps=None; concl_occs=AllOccurrences} ] ]
   ;
   opt_clause:
-    [ [ "in"; cl = in_clause -> Some cl | -> None ] ]
+    [ [ "in"; cl = in_clause -> Some cl
+      | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs}
+      | -> None ] ]
   ;
   concl_occ:
     [ [ "*"; occs = occs -> occs
-      | -> no_occurrences_expr ] ]
+      | -> NoOccurrences ] ]
   ;
   in_hyp_list:
     [ [ "in"; idl = LIST1 id_or_meta -> idl
       | -> [] ] ]
   ;
   in_hyp_as:
-    [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat)
+    [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat)
       | -> None ] ]
   ;
   orient:
@@ -401,13 +423,13 @@ GEXTEND Gram
       | -> true ]]
   ;
   simple_binder:
-    [ [ na=name -> ([na],Default Explicit,CHole (loc, None))
+    [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None))
       | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c)
     ] ]
   ;
   fixdecl:
     [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot;
-        ":"; ty=lconstr; ")" -> (loc,id,bl,ann,ty) ] ]
+        ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ]
   ;
   fixannot:
     [ [ "{"; IDENT "struct"; id=name; "}" -> Some id
@@ -415,7 +437,7 @@ GEXTEND Gram
   ;
   cofixdecl:
     [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" ->
-        (loc,id,bl,None,ty) ] ]
+        (!@loc, id, bl, None, ty) ] ]
   ;
   bindings_with_parameters:
     [ [ check_for_coloneq; "(";  id = ident; bl = LIST0 simple_binder;
@@ -430,6 +452,16 @@ GEXTEND Gram
     [ [ "using"; l = LIST1 constr SEP "," -> l
       | -> [] ] ]
   ;
+  trivial:
+    [ [ IDENT "trivial" -> Off
+      | IDENT "info_trivial" -> Info
+      | IDENT "debug"; IDENT "trivial" -> Debug ] ]
+  ;
+  auto:
+    [ [ IDENT "auto" -> Off
+      | IDENT "info_auto" -> Info
+      | IDENT "debug"; IDENT "auto" -> Debug ] ]
+  ;
   eliminator:
     [ [ "using"; el = constr_with_bindings -> el ] ]
   ;
@@ -437,18 +469,22 @@ GEXTEND Gram
     [ [ "as"; ipat = simple_intropattern -> Some ipat
       | -> None ] ]
   ;
-  with_inversion_names:
-    [ [ "as"; ipat = simple_intropattern -> Some ipat
+  or_and_intropattern_loc:
+    [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat)
+      | locid = identref -> ArgVar locid ] ]
+  ;
+  as_or_and_ipat:
+    [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat
       | -> None ] ]
   ;
   eqn_ipat:
-    [ [ IDENT "eqn"; ":"; id = naming_intropattern -> Some id
-      | IDENT "_eqn"; ":"; id = naming_intropattern ->
+    [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat)
+      | IDENT "_eqn"; ":"; pat = naming_intropattern ->
         let msg = "Obsolete syntax \"_eqn:H\" could be replaced by \"eqn:H\"" in
-        msg_warning (strbrk msg); Some id
+        msg_warning (strbrk msg); Some (!@loc, pat)
       | IDENT "_eqn" ->
         let msg = "Obsolete syntax \"_eqn\" could be replaced by \"eqn:?\"" in
-        msg_warning (strbrk msg); Some (loc, IntroAnonymous)
+        msg_warning (strbrk msg); Some (!@loc, IntroAnonymous)
       | -> None ] ]
   ;
   as_name:
@@ -466,215 +502,186 @@ GEXTEND Gram
     [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ]
   ;
   rewriter :
-    [ [ "!"; c = constr_with_bindings -> (RepeatPlus,c)
-      | ["?"| LEFTQMARK]; c = constr_with_bindings -> (RepeatStar,c)
-      | n = natural; "!"; c = constr_with_bindings -> (Precisely n,c)
-      |	n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings -> (UpTo n,c)
-      | n = natural; c = constr_with_bindings -> (Precisely n,c)
-      | c = constr_with_bindings -> (Precisely 1, c)
+    [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c))
+      | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c)
+      | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c))
+      |	n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c)
+      | n = natural; c = constr_with_bindings_arg -> (Precisely n,c)
+      | c = constr_with_bindings -> (Precisely 1, (None,c))
       ] ]
   ;
   oriented_rewriter :
     [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ]
   ;
   induction_clause:
-    [ [ c = induction_arg; pat = as_ipat; eq = eqn_ipat -> (c,(eq,pat)) ] ]
+    [ [ c = induction_arg; pat = as_or_and_ipat; eq = eqn_ipat; cl = opt_clause
+        -> (c,(eq,pat),cl) ] ]
   ;
   induction_clause_list:
-    [ [ ic = LIST1 induction_clause SEP ",";
-	el = OPT eliminator; cl = opt_clause -> (ic,el,cl) ] ]
+    [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator;
+        cl_tolerance = opt_clause ->
+        (* Condition for accepting "in" at the end by compatibility *)
+        match ic,el,cl_tolerance with
+        | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el)
+        | _,_,Some _ -> err ()
+        | _,_,None -> (ic,el) ]]
   ;
   move_location:
     [ [ IDENT "after"; id = id_or_meta -> MoveAfter id
       | IDENT "before"; id = id_or_meta -> MoveBefore id
-      | "at"; IDENT "bottom" -> MoveToEnd true
-      | "at"; IDENT "top" -> MoveToEnd false ] ]
+      | "at"; IDENT "top" -> MoveFirst
+      | "at"; IDENT "bottom" -> MoveLast ] ]
   ;
   simple_tactic:
     [ [
       (* Basic tactics *)
-        IDENT "intros"; IDENT "until"; id = quantified_hypothesis ->
-	  TacIntrosUntil id
-      | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl
+        IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl)
       | IDENT "intro"; id = ident; hto = move_location ->
-	  TacIntroMove (Some id, hto)
-      | IDENT "intro"; hto = move_location -> TacIntroMove (None, hto)
-      | IDENT "intro"; id = ident -> TacIntroMove (Some id, no_move)
-      | IDENT "intro" -> TacIntroMove (None, no_move)
-
-      | IDENT "assumption" -> TacAssumption
-      | IDENT "exact"; c = constr -> TacExact c
-      | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c
-      | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c
-
-      | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ",";
-          inhyp = in_hyp_as -> TacApply (true,false,cl,inhyp)
-      | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP ",";
-          inhyp = in_hyp_as -> TacApply (true,true,cl,inhyp)
-      | IDENT "simple"; IDENT "apply"; cl = LIST1 constr_with_bindings SEP ",";
-          inhyp = in_hyp_as -> TacApply (false,false,cl,inhyp)
-      | IDENT "simple"; IDENT "eapply"; cl = LIST1 constr_with_bindings SEP",";
-          inhyp = in_hyp_as -> TacApply (false,true,cl,inhyp)
-      | IDENT "elim"; cl = constr_with_bindings; el = OPT eliminator ->
-          TacElim (false,cl,el)
-      | IDENT "eelim"; cl = constr_with_bindings; el = OPT eliminator ->
-          TacElim (true,cl,el)
-      | IDENT "elimtype"; c = constr -> TacElimType c
-      | IDENT "case"; icl = induction_clause_list -> mkTacCase false icl
-      | IDENT "ecase"; icl = induction_clause_list -> mkTacCase true icl
-      | IDENT "casetype"; c = constr -> TacCaseType c
-      | "fix"; n = natural -> TacFix (None,n)
-      | "fix"; id = ident; n = natural -> TacFix (Some id,n)
+	  TacAtom (!@loc, TacIntroMove (Some id, hto))
+      | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto))
+      | IDENT "intro"; id = ident -> TacAtom (!@loc, TacIntroMove (Some id, MoveLast))
+      | IDENT "intro" -> TacAtom (!@loc, TacIntroMove (None, MoveLast))
+
+      | IDENT "exact"; c = constr -> TacAtom (!@loc, TacExact c)
+
+      | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp))
+      | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp))
+      | IDENT "simple"; IDENT "apply";
+          cl = LIST1 constr_with_bindings_arg SEP ",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp))
+      | IDENT "simple"; IDENT "eapply";
+          cl = LIST1 constr_with_bindings_arg SEP",";
+          inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp))
+      | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator ->
+          TacAtom (!@loc, TacElim (false,cl,el))
+      | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator ->
+          TacAtom (!@loc, TacElim (true,cl,el))
+      | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl)
+      | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl)
+      | "fix"; n = natural -> TacAtom (!@loc, TacFix (None,n))
+      | "fix"; id = ident; n = natural -> TacAtom (!@loc, TacFix (Some id,n))
       | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl ->
-	  TacMutualFix (false,id,n,List.map mk_fix_tac fd)
-      | "cofix" -> TacCofix None
-      | "cofix"; id = ident -> TacCofix (Some id)
+	  TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd))
+      | "cofix" -> TacAtom (!@loc, TacCofix None)
+      | "cofix"; id = ident -> TacAtom (!@loc, TacCofix (Some id))
       | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl ->
-	  TacMutualCofix (false,id,List.map mk_cofix_tac fd)
+	  TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd))
 
       | IDENT "pose"; (id,b) = bindings_with_parameters ->
-	  TacLetTac (Names.Name id,b,nowhere,true,None)
+	  TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None))
       | IDENT "pose"; b = constr; na = as_name ->
-	  TacLetTac (na,b,nowhere,true,None)
+	  TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None))
       | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl ->
-	  TacLetTac (Names.Name id,c,p,true,None)
+	  TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None))
       | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl ->
-          TacLetTac (na,c,p,true,None)
+          TacAtom (!@loc, TacLetTac (na,c,p,true,None))
       | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat;
           p = clause_dft_all ->
-          TacLetTac (na,c,p,false,e)
+          TacAtom (!@loc, TacLetTac (na,c,p,false,e))
 
-      (* Begin compatibility *)
+      (* Alternative syntax for "pose proof c as id" *)
       | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
 	  c = lconstr; ")" ->
-	  TacAssert (None,Some (loc,IntroIdentifier id),c)
+	  TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
+
+      (* Alternative syntax for "assert c as id by tac" *)
       | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
 	  c = lconstr; ")"; tac=by_tactic ->
-	  TacAssert (Some tac,Some (loc,IntroIdentifier id),c)
-      (* End compatibility *)
+	  TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
+
+      (* Alternative syntax for "enough c as id by tac" *)
+      | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+	  c = lconstr; ")"; tac=by_tactic ->
+	  TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c))
 
       | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic ->
-	  TacAssert (Some tac,ipat,c)
+	  TacAtom (!@loc, TacAssert (true,Some tac,ipat,c))
       | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat ->
-	  TacAssert (None,ipat,c)
+	  TacAtom (!@loc, TacAssert (true,None,ipat,c))
+      | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic ->
+	  TacAtom (!@loc, TacAssert (false,Some tac,ipat,c))
 
-      | IDENT "cut"; c = constr -> TacCut c
       | IDENT "generalize"; c = constr ->
-	  TacGeneralize [((all_occurrences_expr,c),Names.Anonymous)]
+	  TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)])
       | IDENT "generalize"; c = constr; l = LIST1 constr ->
-	  let gen_everywhere c = ((all_occurrences_expr,c),Names.Anonymous) in
-          TacGeneralize (List.map gen_everywhere (c::l))
+	  let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in
+          TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l)))
       | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs;
           na = as_name;
           l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] ->
-          TacGeneralize (((nl,c),na)::l)
-      | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c
-
-      | IDENT "specialize"; n = OPT natural; lcb = constr_with_bindings ->
-	  TacSpecialize (n,lcb)
-      | IDENT "lapply"; c = constr -> TacLApply c
+          TacAtom (!@loc, TacGeneralize (((nl,c),na)::l))
+      | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c)
 
       (* Derived basic tactics *)
-      | IDENT "simple"; IDENT"induction"; h = quantified_hypothesis ->
-          TacSimpleInductionDestruct (true,h)
       | IDENT "induction"; ic = induction_clause_list ->
-	  TacInductionDestruct (true,false,ic)
+	  TacAtom (!@loc, TacInductionDestruct (true,false,ic))
       | IDENT "einduction"; ic = induction_clause_list ->
-	  TacInductionDestruct(true,true,ic)
+	  TacAtom (!@loc, TacInductionDestruct(true,true,ic))
       | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis;
-	  h2 = quantified_hypothesis -> TacDoubleInduction (h1,h2)
-      | IDENT "simple"; IDENT "destruct"; h = quantified_hypothesis ->
-          TacSimpleInductionDestruct (false,h)
+	  h2 = quantified_hypothesis -> TacAtom (!@loc, TacDoubleInduction (h1,h2))
       | IDENT "destruct"; icl = induction_clause_list ->
-	  TacInductionDestruct(false,false,icl)
+	  TacAtom (!@loc, TacInductionDestruct(false,false,icl))
       | IDENT "edestruct";  icl = induction_clause_list ->
-	  TacInductionDestruct(false,true,icl)
-      | IDENT "decompose"; IDENT "record" ; c = constr -> TacDecomposeAnd c
-      | IDENT "decompose"; IDENT "sum"; c = constr -> TacDecomposeOr c
-      | IDENT "decompose"; "["; l = LIST1 smart_global; "]"; c = constr
-        -> TacDecompose (l,c)
+	  TacAtom (!@loc, TacInductionDestruct(false,true,icl))
 
       (* Automation tactic *)
-      | IDENT "trivial"; lems = auto_using; db = hintbases ->
-          TacTrivial (Off,lems,db)
-      | IDENT "info_trivial"; lems = auto_using; db = hintbases ->
-          TacTrivial (Info,lems,db)
-      | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases ->
-          TacTrivial (Debug,lems,db)
-
-      | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
-          TacAuto (Off,n,lems,db)
-      | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using;
-          db = hintbases -> TacAuto (Info,n,lems,db)
-      | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using;
-          db = hintbases -> TacAuto (Debug,n,lems,db)
+      | d = trivial; lems = auto_using; db = hintbases -> TacAtom (!@loc, TacTrivial (d,lems,db))
+      | d = auto; n = OPT int_or_var; lems = auto_using; db = hintbases ->
+          TacAtom (!@loc, TacAuto (d,n,lems,db))
 
       (* Context management *)
-      | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l)
-      | IDENT "clear"; l = LIST0 id_or_meta -> TacClear (l=[], l)
-      | IDENT "clearbody"; l = LIST1 id_or_meta -> TacClearBody l
+      | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l))
+      | IDENT "clear"; l = LIST0 id_or_meta ->
+        let is_empty = match l with [] -> true | _ -> false in
+        TacAtom (!@loc, TacClear (is_empty, l))
+      | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l)
       | IDENT "move"; hfrom = id_or_meta; hto = move_location ->
-	  TacMove (true,hfrom,hto)
-      | IDENT "rename"; l = LIST1 rename SEP "," -> TacRename l
-      | IDENT "revert"; l = LIST1 id_or_meta -> TacRevert l
+	  TacAtom (!@loc, TacMove (hfrom,hto))
+      | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l)
 
       (* Constructors *)
-      | IDENT "left";   bl = with_bindings -> TacLeft  (false,bl)
-      | IDENT "eleft";  bl = with_bindings -> TacLeft  (true,bl)
-      | IDENT "right";  bl = with_bindings -> TacRight (false,bl)
-      | IDENT "eright"; bl = with_bindings -> TacRight (true,bl)
-      | IDENT "split";  bl = with_bindings -> TacSplit (false,false,[bl])
-      | IDENT "esplit"; bl = with_bindings -> TacSplit (true,false,[bl])
-      | "exists"; bll = LIST1 opt_bindings SEP "," -> TacSplit (false,true,bll)
-      | IDENT "eexists"; bll = LIST1 opt_bindings SEP "," ->
-	  TacSplit (true,true,bll)
-      | IDENT "constructor"; n = nat_or_var; l = with_bindings ->
-	  TacConstructor (false,n,l)
-      | IDENT "econstructor"; n = nat_or_var; l = with_bindings ->
-	  TacConstructor (true,n,l)
-      | IDENT "constructor"; t = OPT tactic -> TacAnyConstructor (false,t)
-      | IDENT "econstructor"; t = OPT tactic -> TacAnyConstructor (true,t)
-
+      | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll))
+      | IDENT "eexists"; bll = opt_bindings ->
+	  TacAtom (!@loc, TacSplit (true,bll))
       (* Equivalence relations *)
-      | IDENT "reflexivity" -> TacReflexivity
-      | IDENT "symmetry"; cl = clause_dft_concl -> TacSymmetry cl
-      | IDENT "transitivity"; c = constr -> TacTransitivity (Some c)
-      | IDENT "etransitivity" -> TacTransitivity None
+      | IDENT "symmetry"; "in"; cl = in_clause -> TacAtom (!@loc, TacSymmetry cl)
 
       (* Equality and inversion *)
       | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ",";
-	  cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (false,l,cl,t)
+	  cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t))
       | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ",";
-	  cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (true,l,cl,t)
+	  cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t))
       | IDENT "dependent"; k =
 	  [ IDENT "simple"; IDENT "inversion" -> SimpleInversion
 	  | IDENT "inversion" -> FullInversion
 	  | IDENT "inversion_clear" -> FullInversionClear ];
 	  hyp = quantified_hypothesis;
-	  ids = with_inversion_names; co = OPT ["with"; c = constr -> c] ->
-	    TacInversion (DepInversion (k,co,ids),hyp)
+	  ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] ->
+	    TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp))
       | IDENT "simple"; IDENT "inversion";
-	  hyp = quantified_hypothesis; ids = with_inversion_names;
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
 	  cl = in_hyp_list ->
-	    TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)
+	    TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp))
       | IDENT "inversion";
-	  hyp = quantified_hypothesis; ids = with_inversion_names;
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
 	  cl = in_hyp_list ->
-	    TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)
+	    TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp))
       | IDENT "inversion_clear";
-	  hyp = quantified_hypothesis; ids = with_inversion_names;
+	  hyp = quantified_hypothesis; ids = as_or_and_ipat;
 	  cl = in_hyp_list ->
-	    TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)
+	    TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp))
       | IDENT "inversion"; hyp = quantified_hypothesis;
 	  "using"; c = constr; cl = in_hyp_list ->
-	    TacInversion (InversionUsing (c,cl), hyp)
+	    TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp))
 
       (* Conversion *)
-      | r = red_tactic; cl = clause_dft_concl -> TacReduce (r, cl)
+      | r = red_tactic; cl = clause_dft_concl -> TacAtom (!@loc, TacReduce (r, cl))
       (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *)
       | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl ->
-	  let p,cl = merge_occurrences loc cl oc in
-	  TacChange (p,c,cl)
+	  let p,cl = merge_occurrences (!@loc) cl oc in
+	  TacAtom (!@loc, TacChange (p,c,cl))
     ] ]
   ;
 END;;
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index 75cd7d67..70a8ec55 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -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,24 +8,23 @@
 
 open Pp
 open Compat
-open Tok
+open Errors
 open Util
 open Names
-open Topconstr
+open Constrexpr
+open Constrexpr_ops
 open Extend
 open Vernacexpr
-open Pcoq
-open Tactic
 open Decl_kinds
-open Genarg
-open Ppextend
-open Goptions
-open Declaremods
+open Misctypes
+open Tok (* necessary for camlp4 *)
 
-open Prim
-open Constr
-open Vernac_
-open Module
+open Pcoq
+open Pcoq.Tactic
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Vernac_
+open Pcoq.Module
 
 let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ]
 let _ = List.iter Lexer.add_keyword vernac_kw
@@ -33,7 +32,7 @@ let _ = List.iter Lexer.add_keyword vernac_kw
 (* Rem: do not join the different GEXTEND into one, it breaks native *)
 (* compilation on PowerPC and Sun architectures *)
 
-let check_command = Gram.entry_create "vernac:check_command"
+let query_command = Gram.entry_create "vernac:query_command"
 
 let tactic_mode = Gram.entry_create "vernac:tactic_command"
 let noedit_mode = Gram.entry_create "vernac:noedit_command"
@@ -47,6 +46,7 @@ let record_field = Gram.entry_create "vernac:record_field"
 let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion"
 let subgoal_command = Gram.entry_create "proof_mode:subgoal_command"
 let instance_name = Gram.entry_create "vernac:instance_name"
+let section_subset_descr = Gram.entry_create "vernac:section_subset_descr"
 
 let command_entry = ref noedit_mode
 let set_command_entry e = command_entry := e
@@ -63,81 +63,118 @@ let _ = Proof_global.register_proof_mode {Proof_global.
 					    reset = set_noedit_mode
 					 }
 
+let make_bullet s =
+  let n = String.length s in
+  match s.[0] with
+  | '-' -> Dash n
+  | '+' -> Plus n
+  | '*' -> Star n
+  | _ -> assert false
+
 let default_command_entry =
   Gram.Entry.of_parser "command_entry"
     (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm)
 
-let no_hook _ _ = ()
 GEXTEND Gram
   GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command;
   vernac: FIRST
-    [ [ IDENT "Time"; v = vernac -> VernacTime v
+    [ [ IDENT "Time"; l = vernac_list -> VernacTime l
       | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v)
       | IDENT "Fail"; v = vernac -> VernacFail v
-      | locality; v = vernac_aux -> v ] ]
+
+      | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v)
+      | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v)
+
+      (* Stm backdoor *)
+      | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument
+      | IDENT "Stm"; IDENT "Finish"; "." -> VernacStm Finish
+      | IDENT "Stm"; IDENT "Wait"; "." -> VernacStm Wait
+      | IDENT "Stm"; IDENT "PrintDag"; "." -> VernacStm PrintDag
+      | IDENT "Stm"; IDENT "Observe"; id = INT; "." ->
+          VernacStm (Observe (Stateid.of_int (int_of_string id)))
+      | IDENT "Stm"; IDENT "Command"; v = vernac_aux -> VernacStm (Command v)
+      | IDENT "Stm"; IDENT "PGLast"; v = vernac_aux -> VernacStm (PGLast v)
+
+      | v = vernac_poly -> v ] 
+    ]
+  ;
+  vernac_poly: 
+    [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v)
+      | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) 
+      | v = vernac_aux -> v ]
+    ]
   ;
   vernac_aux:
     (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *)
     (* "." is still in the stream and discard_to_dot works correctly         *)
-    [ [ g = gallina; "." -> g
+    [ [ IDENT "Program"; g = gallina; "." -> VernacProgram g
+      | IDENT "Program"; g = gallina_ext; "." -> VernacProgram g
+      | g = gallina; "." -> g
       | g = gallina_ext; "." -> g
       | c = command; "." -> c
       | c = syntax; "." -> c
-      | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l
       | c = subprf -> c
     ] ]
   ;
+  vernac_list:
+    [ [ c = located_vernac -> [c] ] ]
+  ;
   vernac_aux: LAST
     [ [ prfcom = default_command_entry -> prfcom ] ]
   ;
-  locality:
-    [ [ IDENT "Local" -> locality_flag := Some (loc,true)
-      | IDENT "Global" -> locality_flag := Some (loc,false)
-      | -> locality_flag := None ] ]
-  ;
   noedit_mode:
     [ [ c = subgoal_command -> c None] ]
   ;
+
+  selector:
+    [ [ n=natural; ":" -> SelectNth n
+      | "["; id = ident; "]"; ":" -> SelectId id
+      | IDENT "all" ; ":" -> SelectAll
+      | IDENT "par" ; ":" -> SelectAllParallel ] ]
+  ;
+
   tactic_mode:
-  [ [ gln = OPT[n=natural; ":" -> n];
+  [ [ gln = OPT selector;
       tac = subgoal_command -> tac gln ] ]
   ;
 
   subprf:
-  [ [
-      "-" -> VernacBullet Dash
-    | "*" -> VernacBullet Star
-    | "+" -> VernacBullet Plus
+  [ [ s = BULLET -> VernacBullet (make_bullet s)
     | "{" -> VernacSubproof None
     | "}" -> VernacEndSubproof
     ] ]
   ;
 
-
-
   subgoal_command: 
-    [ [ c = check_command; "." -> fun g -> c g
-      | tac = Tactic.tactic;
+    [ [ c = query_command; "." ->
+                  begin function
+                    | Some (SelectNth g) -> c (Some g)
+                    | None -> c None
+                    | _ ->
+                        VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector."))
+                  end
+      | info = OPT [IDENT "Info";n=natural -> n];
+        tac = Tactic.tactic;
         use_dft_tac = [ "." -> false | "..." -> true ] ->
-          (fun g ->
-            let g = Option.default 1 g in
-            VernacSolve(g,tac,use_dft_tac)) ] ]
+        (fun g ->
+            let g = Option.default (Proof_global.get_default_goal_selector ()) g in
+            VernacSolve(g,info,tac,use_dft_tac)) ] ]
   ;
   located_vernac:
-    [ [ v = vernac -> loc, v ] ]
+    [ [ v = vernac -> !@loc, v ] ]
   ;
 END
 
 let test_plurial_form = function
   | [(_,([_],_))] ->
       Flags.if_verbose msg_warning
-   (str "Keywords Variables/Hypotheses/Parameters expect more than one assumption")
+   (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption")
   | _ -> ()
 
 let test_plurial_form_types = function
   | [([_],_)] ->
       Flags.if_verbose msg_warning
-   (str "Keywords Implicit Types expect more than one type")
+   (strbrk "Keywords Implicit Types expect more than one type")
   | _ -> ()
 
 (* Gallina declarations *)
@@ -150,39 +187,42 @@ GEXTEND Gram
     [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr;
         l = LIST0
           [ "with"; id = identref; bl = binders; ":"; c = lconstr ->
-            (Some id,(bl,c,None)) ] ->
-          VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook)
+          (Some id,(bl,c,None)) ] ->
+          VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false)
       | stre = assumption_token; nl = inline; bl = assum_list ->
 	  VernacAssumption (stre, nl, bl)
       | stre = assumptions_token; nl = inline; bl = assum_list ->
 	  test_plurial_form bl;
 	  VernacAssumption (stre, nl, bl)
-      | (f,d) = def_token; id = identref; b = def_body ->
-          VernacDefinition (d, id, b, f)
+      | d = def_token; id = identref; b = def_body ->
+          VernacDefinition (d, id, b)
+      | IDENT "Let"; id = identref; b = def_body ->
+          VernacDefinition ((Some Discharge, Definition), id, b)
       (* Gallina inductive declarations *)
-      | f = finite_token;
+      | priv = private_token; f = finite_token;
         indl = LIST1 inductive_definition SEP "with" ->
 	  let (k,f) = f in
 	  let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in
-          VernacInductive (f,false,indl)
+          VernacInductive (priv,f,indl)
       | "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
-          VernacFixpoint recs
+          VernacFixpoint (None, recs)
+      | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" ->
+          VernacFixpoint (Some Discharge, recs)
       | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
-          VernacCoFixpoint corecs
+          VernacCoFixpoint (None, corecs)
+      | IDENT "Let"; "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" ->
+          VernacCoFixpoint (Some Discharge, corecs)
       | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l
       | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from";
-	l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ]
-  ;
-  gallina_ext:
-    [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref;
-        ps = binders;
-	s = OPT [ ":"; s = lconstr -> s ];
-	cfs = [ ":="; l = constructor_list_or_record_decl -> l
-	  | -> RecordDecl (None, []) ] ->
-	  let (recf,indf) = b in
-	    VernacInductive (indf,infer,[((oc,name),ps,s,recf,cfs),[]])
+	      l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l)
+      | IDENT "Register"; IDENT "Inline"; id = identref ->
+          VernacRegister(id, RegisterInline)
+      | IDENT "Universe"; l = LIST1 identref -> VernacUniverse l
+      | IDENT "Universes"; l = LIST1 identref -> VernacUniverse l
+      | IDENT "Constraint"; l = LIST1 univ_constraint SEP "," -> VernacConstraint l
   ] ]
   ;
+
   thm_token:
     [ [ "Theorem" -> Theorem
       | IDENT "Lemma" -> Lemma
@@ -193,50 +233,48 @@ GEXTEND Gram
       | IDENT "Property" -> Property ] ]
   ;
   def_token:
-    [ [ "Definition" ->
-	no_hook, (Global, Definition)
-      | IDENT "Let" ->
-	no_hook, (Local, Definition)
-      | IDENT "Example" ->
-	no_hook, (Global, Example)
-      | IDENT "SubClass"  ->
-          Class.add_subclass_hook, (use_locality_exp (), SubClass) ] ]
+    [ [ "Definition" -> (None, Definition)
+      | IDENT "Example" -> (None, Example)
+      | IDENT "SubClass" -> (None, SubClass) ] ]
   ;
   assumption_token:
-    [ [ "Hypothesis" -> (Local, Logical)
-      | "Variable" -> (Local, Definitional)
-      | "Axiom" -> (Global, Logical)
-      | "Parameter" -> (Global, Definitional)
-      | IDENT "Conjecture" -> (Global, Conjectural) ] ]
+    [ [ "Hypothesis" -> (Some Discharge, Logical)
+      | "Variable" -> (Some Discharge, Definitional)
+      | "Axiom" -> (None, Logical)
+      | "Parameter" -> (None, Definitional)
+      | IDENT "Conjecture" -> (None, Conjectural) ] ]
   ;
   assumptions_token:
-    [ [ IDENT "Hypotheses" -> (Local, Logical)
-      | IDENT "Variables" -> (Local, Definitional)
-      | IDENT "Axioms" -> (Global, Logical)
-      | IDENT "Parameters" -> (Global, Definitional) ] ]
+    [ [ IDENT "Hypotheses" -> (Some Discharge, Logical)
+      | IDENT "Variables" -> (Some Discharge, Definitional)
+      | IDENT "Axioms" -> (None, Logical)
+      | IDENT "Parameters" -> (None, Definitional) ] ]
   ;
   inline:
-    [ [ IDENT "Inline"; "("; i = INT; ")" -> Some (int_of_string i)
-      | IDENT "Inline" -> Some (Flags.get_inline_level())
-      | -> None] ]
+    [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i)
+      | IDENT "Inline" -> DefaultInline
+      | -> NoInline] ]
+  ;
+  univ_constraint:
+    [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ];
+	r = identref -> (l, ord, r) ] ]
   ;
   finite_token:
     [ [ "Inductive" -> (Inductive_kw,Finite)
-      | "CoInductive" -> (CoInductive,CoFinite) ] ]
-  ;
-  infer_token:
-    [ [ IDENT "Infer" -> true | -> false ] ]
-  ;
-  record_token:
-    [ [ IDENT "Record" -> (Record,BiFinite)
+      | "CoInductive" -> (CoInductive,CoFinite)
+      | "Variant" -> (Variant,BiFinite)
+      | IDENT "Record" -> (Record,BiFinite)
       | IDENT "Structure" -> (Structure,BiFinite)
       | IDENT "Class" -> (Class true,BiFinite) ] ]
   ;
+  private_token:
+    [ [ IDENT "Private" -> true | -> false ] ]
+  ;
   (* Simple definitions *)
   def_body:
     [ [ bl = binders; ":="; red = reduce; c = lconstr ->
       (match c with
-          CCast(_,c, Glob_term.CastConv (Term.DEFAULTcast,t)) -> DefineBody (bl, red, c, Some t)
+          CCast(_,c, CastConv t) -> DefineBody (bl, red, c, Some t)
         | _ -> DefineBody (bl, red, c, None))
     | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
 	DefineBody (bl, red, c, Some t)
@@ -256,10 +294,14 @@ GEXTEND Gram
     | -> [] ] ]
   ;
   (* Inductives and records *)
+  opt_constructors_or_fields:
+    [ [ ":="; lc = constructor_list_or_record_decl -> lc
+      | -> RecordDecl (None, []) ] ]
+  ;
   inductive_definition:
-    [ [ id = identref; oc = opt_coercion; indpar = binders;
+    [ [ oc = opt_coercion; id = identref; indpar = binders;
         c = OPT [ ":"; c = lconstr -> c ];
-        ":="; lc = constructor_list_or_record_decl; ntn = decl_notation ->
+        lc=opt_constructors_or_fields; ntn = decl_notation ->
 	   (((oc,id),indpar,c,lc),ntn) ] ]
   ;
   constructor_list_or_record_decl:
@@ -296,7 +338,7 @@ GEXTEND Gram
   ;
   type_cstr:
     [ [ ":"; c=lconstr -> c
-      | -> CHole (loc, None) ] ]
+      | -> CHole (!@loc, None, Misctypes.IntroAnonymous, None) ] ]
   ;
   (* Inductive schemes *)
   scheme:
@@ -333,19 +375,19 @@ GEXTEND Gram
   ;
   record_binder_body:
     [ [ l = binders; oc = of_type_with_opt_coercion;
-         t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t))
+         t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t))
       | l = binders; oc = of_type_with_opt_coercion;
          t = lconstr; ":="; b = lconstr -> fun id ->
-	   (oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
+	   (oc,DefExpr (id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t)))
       | l = binders; ":="; b = lconstr -> fun id ->
          match b with
-	 | CCast(_,b, Glob_term.CastConv (_, t)) ->
-	     (None,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
+	 | CCast(_,b, (CastConv t|CastVM t|CastNative t)) ->
+	     (None,DefExpr(id,mkCLambdaN (!@loc) l b,Some (mkCProdN (!@loc) l t)))
          | _ ->
-	     (None,DefExpr(id,mkCLambdaN loc l b,None)) ] ]
+	     (None,DefExpr(id,mkCLambdaN (!@loc) l b,None)) ] ]
   ;
   record_binder:
-    [ [ id = name -> (None,AssumExpr(id,CHole (loc, None)))
+    [ [ id = name -> (None,AssumExpr(id,CHole (!@loc, None, Misctypes.IntroAnonymous, None)))
       | id = name; f = record_binder_body -> f id ] ]
   ;
   assum_list:
@@ -356,15 +398,15 @@ GEXTEND Gram
   ;
   simple_assum_coe:
     [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr ->
-        (oc <> None,(idl,c)) ] ]
+        (not (Option.is_empty oc),(idl,c)) ] ]
   ;
 
   constructor_type:
     [[ l = binders;
       t= [ coe = of_type_with_opt_coercion; c = lconstr ->
-	            fun l id -> (coe <> None,(id,mkCProdN loc l c))
+	            fun l id -> (not (Option.is_empty coe),(id,mkCProdN (!@loc) l c))
             |  ->
-		 fun l id -> (false,(id,mkCProdN loc l (CHole (loc, None)))) ]
+		 fun l id -> (false,(id,mkCProdN (!@loc) l (CHole (!@loc, None, Misctypes.IntroAnonymous, None)))) ]
 	 -> t l
      ]]
 ;
@@ -382,10 +424,20 @@ GEXTEND Gram
   ;
 END
 
+let only_identrefs =
+  Gram.Entry.of_parser "test_only_identrefs"
+    (fun strm ->
+      let rec aux n =
+      match get_tok (Util.stream_nth n strm) with
+        | KEYWORD "." -> ()
+        | KEYWORD ")" -> ()
+        | IDENT _ -> aux (n+1)
+        | _ -> raise Stream.Failure in
+      aux 0)
 
 (* Modules and Sections *)
 GEXTEND Gram
-  GLOBAL: gallina_ext module_expr module_type;
+  GLOBAL: gallina_ext module_expr module_type section_subset_descr;
 
   gallina_ext:
     [ [ (* Interactive module declaration *)
@@ -407,18 +459,24 @@ GEXTEND Gram
       (* This end a Section a Module or a Module Type *)
       | IDENT "End"; id = identref -> VernacEndSegment id
 
+      (* Naming a set of section hyps *)
+      | IDENT "Collection"; id = identref; ":="; expr = section_subset_descr ->
+          VernacNameSectionHypSet (id, expr)
+
       (* Requiring an already compiled module *)
       | IDENT "Require"; export = export_token; qidl = LIST1 global ->
-          VernacRequire (export, None, qidl)
-      | IDENT "Require"; export = export_token; filename = ne_string ->
-	  VernacRequireFrom (export, None, filename)
+          VernacRequire (export, qidl)
+      | IDENT "From" ; ns = global ; IDENT "Require"; export = export_token
+	; qidl = LIST1 global ->
+	let qidl = List.map (Libnames.join_reference ns) qidl in
+	VernacRequire (export, qidl)
       | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl)
       | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl)
       | IDENT "Include"; e = module_type_inl; l = LIST0 ext_module_expr ->
 	  VernacInclude(e::l)
       | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type ->
 	  Flags.if_verbose
-            msg_warning (str "Include Type is deprecated; use Include instead");
+            msg_warning (strbrk "Include Type is deprecated; use Include instead");
           VernacInclude(e::l) ] ]
   ;
   export_token:
@@ -451,32 +509,19 @@ GEXTEND Gram
       | -> [] ] ]
   ;
   functor_app_annot:
-    [ [ IDENT "inline"; "at"; IDENT "level"; i = INT ->
-        [InlineAt (int_of_string i)], []
-      | IDENT "no"; IDENT "inline" -> [NoInline], []
-      | IDENT "scope"; sc1 = IDENT; IDENT "to"; sc2 = IDENT -> [], [sc1,sc2]
-      ] ]
-  ;
-  functor_app_annots:
-    [ [ "["; l = LIST1 functor_app_annot SEP ","; "]" ->
-        let inl,scs = List.split l in
-	let inl = match List.concat inl with
-	  | [] -> DefaultInline
-	  | [inl] -> inl
-	  | _ -> error "Functor application with redundant inline annotations"
-	in { ann_inline = inl; ann_scope_subst = List.concat scs }
-      | -> { ann_inline = DefaultInline; ann_scope_subst = [] }
+    [ [ "["; IDENT "inline"; "at"; IDENT "level"; i = INT; "]" ->
+        InlineAt (int_of_string i)
+      | "["; IDENT "no"; IDENT "inline"; "]" -> NoInline
+      | -> DefaultInline
       ] ]
   ;
   module_expr_inl:
-    [ [ "!"; me = module_expr ->
-        (me, { ann_inline = NoInline; ann_scope_subst = []})
-      | me = module_expr; a = functor_app_annots -> (me,a) ] ]
+    [ [ "!"; me = module_expr -> (me,NoInline)
+      | me = module_expr; a = functor_app_annot -> (me,a) ] ]
   ;
   module_type_inl:
-    [ [ "!"; me = module_type ->
-        (me, { ann_inline = NoInline; ann_scope_subst = []})
-      | me = module_type; a = functor_app_annots -> (me,a) ] ]
+    [ [ "!"; me = module_type -> (me,NoInline)
+      | me = module_type; a = functor_app_annot -> (me,a) ] ]
   ;
   (* Module binder  *)
   module_binder:
@@ -486,7 +531,7 @@ GEXTEND Gram
   (* Module expressions *)
   module_expr:
     [ [ me = module_expr_atom -> me
-      | me1 = module_expr; me2 = module_expr_atom -> CMapply (loc,me1,me2)
+      | me1 = module_expr; me2 = module_expr_atom -> CMapply (!@loc,me1,me2)
       ] ]
   ;
   module_expr_atom:
@@ -502,11 +547,28 @@ GEXTEND Gram
   module_type:
     [ [ qid = qualid -> CMident qid
       | "("; mt = module_type; ")" -> mt
-      | mty = module_type; me = module_expr_atom -> CMapply (loc,mty,me)
+      | mty = module_type; me = module_expr_atom -> CMapply (!@loc,mty,me)
       | mty = module_type; "with"; decl = with_declaration ->
-          CMwith (loc,mty,decl)
+          CMwith (!@loc,mty,decl)
       ] ]
   ;
+  section_subset_descr:
+    [ [ IDENT "All" -> SsAll
+      | "Type" -> SsType
+      | only_identrefs; l = LIST0 identref -> SsExpr (SsSet l)
+      | e = section_subset_expr -> SsExpr e ] ]
+  ;
+  section_subset_expr:
+    [ "35" 
+      [ "-"; e = section_subset_expr -> SsCompl e ]
+    | "50"
+      [ e1 = section_subset_expr; "-"; e2 = section_subset_expr->SsSubstr(e1,e2)
+      | e1 = section_subset_expr; "+"; e2 = section_subset_expr->SsUnion(e1,e2)]
+    | "0"
+      [ i = identref -> SsSet [i]
+      | "("; only_identrefs; l = LIST0 identref; ")"-> SsSet l
+      | "("; e = section_subset_expr; ")"-> e ] ]
+  ;
 END
 
 (* Extensions: implicits, coercions, etc. *)
@@ -516,12 +578,12 @@ GEXTEND Gram
   gallina_ext:
     [ [ (* Transparent and Opaque *)
         IDENT "Transparent"; l = LIST1 smart_global ->
-          VernacSetOpacity (use_non_locality (),[Conv_oracle.transparent,l])
+          VernacSetOpacity (Conv_oracle.transparent, l)
       | IDENT "Opaque"; l = LIST1 smart_global ->
-          VernacSetOpacity (use_non_locality (),[Conv_oracle.Opaque, l])
+          VernacSetOpacity (Conv_oracle.Opaque, l)
       | IDENT "Strategy"; l =
-          LIST1 [ lev=strategy_level; "["; q=LIST1 smart_global; "]" -> (lev,q)] ->
-            VernacSetOpacity (use_locality (),l)
+          LIST1 [ v=strategy_level; "["; q=LIST1 smart_global; "]" -> (v,q)] ->
+            VernacSetStrategy l
       (* Canonical structure *)
       | IDENT "Canonical"; IDENT "Structure"; qid = global ->
 	  VernacCanonical (AN qid)
@@ -531,50 +593,50 @@ GEXTEND Gram
           d = def_body ->
           let s = coerce_reference_to_id qid in
 	  VernacDefinition
-	    ((Global,CanonicalStructure),(dummy_loc,s),d,
-	     (fun _ -> Recordops.declare_canonical_structure))
+	    ((Some Global,CanonicalStructure),(Loc.ghost,s),d)
 
       (* Coercions *)
       | IDENT "Coercion"; qid = global; d = def_body ->
           let s = coerce_reference_to_id qid in
-	  VernacDefinition ((use_locality_exp (),Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+	  VernacDefinition ((None,Coercion),(Loc.ghost,s),d)
       | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body ->
            let s = coerce_reference_to_id qid in
-	  VernacDefinition ((enforce_locality_exp true,Coercion),(dummy_loc,s),d,Class.add_coercion_hook)
+	  VernacDefinition ((Some Decl_kinds.Local,Coercion),(Loc.ghost,s),d)
       | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref;
          ":"; s = class_rawexpr; ">->"; t = class_rawexpr ->
-	   VernacIdentityCoercion (enforce_locality_exp true, f, s, t)
+	   VernacIdentityCoercion (true, f, s, t)
       | IDENT "Identity"; IDENT "Coercion"; f = identref; ":";
          s = class_rawexpr; ">->"; t = class_rawexpr ->
-	   VernacIdentityCoercion (use_locality_exp (), f, s, t)
+	   VernacIdentityCoercion (false, f, s, t)
       | IDENT "Coercion"; IDENT "Local"; qid = global; ":";
 	 s = class_rawexpr; ">->"; t = class_rawexpr ->
-	  VernacCoercion (enforce_locality_exp true, AN qid, s, t)
+	  VernacCoercion (true, AN qid, s, t)
       | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":";
 	 s = class_rawexpr; ">->"; t = class_rawexpr ->
-	  VernacCoercion (enforce_locality_exp true, ByNotation ntn, s, t)
+	  VernacCoercion (true, ByNotation ntn, s, t)
       | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->";
          t = class_rawexpr ->
-	  VernacCoercion (use_locality_exp (), AN qid, s, t)
+	  VernacCoercion (false, AN qid, s, t)
       | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->";
          t = class_rawexpr ->
-	  VernacCoercion (use_locality_exp (), ByNotation ntn, s, t)
+	  VernacCoercion (false, ByNotation ntn, s, t)
 
       | IDENT "Context"; c = binders ->
 	  VernacContext c
 
       | IDENT "Instance"; namesup = instance_name; ":";
-	 expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200";
+	 expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200";
 	 pri = OPT [ "|"; i = natural -> i ] ;
-	 props = [ ":="; "{"; r = record_declaration; "}" -> Some r |
-	     ":="; c = lconstr -> Some c | -> None ] ->
-	   VernacInstance (false, not (use_section_locality ()),
-			   snd namesup, (fst namesup, expl, t), props, pri)
+	 props = [ ":="; "{"; r = record_declaration; "}" -> Some (true,r) |
+	     ":="; c = lconstr -> Some (false,c) | -> None ] ->
+	   VernacInstance (false,snd namesup,(fst namesup,expl,t),props,pri)
 
-      | IDENT "Existing"; IDENT "Instance"; id = global ->
-	  VernacDeclareInstances (not (use_section_locality ()), [id])
-      | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global ->
-	  VernacDeclareInstances (not (use_section_locality ()), ids)
+      | IDENT "Existing"; IDENT "Instance"; id = global;
+          pri = OPT [ "|"; i = natural -> i ] ->
+	  VernacDeclareInstances ([id], pri)
+      | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global;
+          pri = OPT [ "|"; i = natural -> i ] ->
+	  VernacDeclareInstances (ids, pri)
 
       | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is
 
@@ -586,17 +648,17 @@ GEXTEND Gram
         | "/" -> [`Slash]
         | "("; items = LIST1 argument_spec; ")"; sc = OPT scope ->
             let f x = match sc, x with
-            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x
             | Some _, Some _ -> error "scope declared twice" in
             List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items
         | "["; items = LIST1 argument_spec; "]"; sc = OPT scope ->
             let f x = match sc, x with
-            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x
             | Some _, Some _ -> error "scope declared twice" in
             List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items
         | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope ->
             let f x = match sc, x with
-            | None, x -> x | x, None -> Option.map (fun y -> loc, y) x
+            | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x
             | Some _, Some _ -> error "scope declared twice" in
             List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items
         ] -> l ] SEP ",";
@@ -609,31 +671,30 @@ GEXTEND Gram
            | [] -> narg, impl in
          let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in
          let nargs, rest = List.hd nargs, List.tl nargs in
-         if List.exists ((<>) nargs) rest then
+         if List.exists (fun arg -> not (Int.equal arg nargs)) rest then
            error "All arguments lists must have the same length";
          let err_incompat x y =
            error ("Options \""^x^"\" and \""^y^"\" are incompatible") in
-         if nargs > 0 && List.mem `SimplNeverUnfold mods then
+         if nargs > 0 && List.mem `ReductionNeverUnfold mods then
            err_incompat "simpl never" "/";
-         if List.mem `SimplNeverUnfold mods &&
-            List.mem `SimplDontExposeCase mods then
+         if List.mem `ReductionNeverUnfold mods &&
+            List.mem `ReductionDontExposeCase mods then
            err_incompat "simpl never" "simpl nomatch";
-         VernacArguments (use_section_locality(), qid, impl, nargs, mods)
+         VernacArguments (qid, impl, nargs, mods)
 
      (* moved there so that camlp5 factors it with the previous rule *)
      | IDENT "Arguments"; IDENT "Scope"; qid = smart_global;
        "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" ->
-	   Flags.if_verbose
-             msg_warning (str "Arguments Scope is deprecated; use Arguments instead");
-	 VernacArgumentsScope (use_section_locality (),qid,scl)
+        msg_warning (strbrk "Arguments Scope is deprecated; use Arguments instead");
+        VernacArgumentsScope (qid,scl)
 
       (* Implicit *)
       | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global;
 	   pos = LIST0 [ "["; l = LIST0 implicit_name; "]" ->
 	     List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] ->
 	   Flags.if_verbose
-             msg_warning (str "Implicit Arguments is deprecated; use Arguments instead");
-	   VernacDeclareImplicits (use_section_locality (),qid,pos)
+             msg_warning (strbrk "Implicit Arguments is deprecated; use Arguments instead");
+	   VernacDeclareImplicits (qid,pos)
 
       | IDENT "Implicit"; "Type"; bl = reserv_list ->
 	   VernacReserve bl
@@ -647,15 +708,16 @@ GEXTEND Gram
 	     | IDENT "No"; IDENT "Variables" -> None
 	     | ["Variable" | IDENT "Variables"];
 		  idl = LIST1 identref -> Some idl ] ->
-	     VernacGeneralizable (use_non_locality (), gen) ] ]
+	     VernacGeneralizable gen ] ]
   ;
   arguments_modifier:
-    [ [ IDENT "simpl"; IDENT "nomatch" -> [`SimplDontExposeCase]
-      | IDENT "simpl"; IDENT "never" -> [`SimplNeverUnfold]
+    [ [ IDENT "simpl"; IDENT "nomatch" -> [`ReductionDontExposeCase]
+      | IDENT "simpl"; IDENT "never" -> [`ReductionNeverUnfold]
       | IDENT "default"; IDENT "implicits" -> [`DefaultImplicits]
       | IDENT "clear"; IDENT "implicits" -> [`ClearImplicits]
       | IDENT "clear"; IDENT "scopes" -> [`ClearScopes]
       | IDENT "rename" -> [`Rename]
+      | IDENT "assert" -> [`Assert]
       | IDENT "extra"; IDENT "scopes" -> [`ExtraScopes]
       | IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" ->
           [`ClearImplicits; `ClearScopes]
@@ -674,7 +736,7 @@ GEXTEND Gram
   ;
   argument_spec: [
        [ b = OPT "!"; id = name ; s = OPT scope ->
-       snd id, b <> None, Option.map (fun x -> loc, x) s
+       snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s
     ]
   ];
   strategy_level:
@@ -688,7 +750,7 @@ GEXTEND Gram
     [ [ name = identref; sup = OPT binders ->
 	  (let (loc,id) = name in (loc, Name id)),
           (Option.default [] sup)
-      | -> (loc, Anonymous), []  ] ]
+      | -> (!@loc, Anonymous), []  ] ]
   ;
   reserv_list:
     [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ]
@@ -703,18 +765,20 @@ GEXTEND Gram
 END
 
 GEXTEND Gram
-  GLOBAL: command check_command class_rawexpr;
+  GLOBAL: command query_command class_rawexpr;
 
   command:
-    [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l
+    [ [ IDENT "Ltac";
+        l = LIST1 tacdef_body SEP "with" ->
+          VernacDeclareTacticDefinition (true, l)
+
+      | IDENT "Comments"; l = LIST0 comment -> VernacComments l
 
       (* Hack! Should be in grammar_ext, but camlp4 factorize badly *)
       | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":";
-	 expl = [ "!" -> Glob_term.Implicit | -> Glob_term.Explicit ] ; t = operconstr LEVEL "200";
+	 expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200";
 	 pri = OPT [ "|"; i = natural -> i ] ->
-	   VernacInstance (true, not (use_section_locality ()),
-			   snd namesup, (fst namesup, expl, t),
-			   None, pri)
+	   VernacInstance (true, snd namesup, (fst namesup, expl, t), None, pri)
 
       (* System directory *)
       | IDENT "Pwd" -> VernacChdir None
@@ -729,7 +793,7 @@ GEXTEND Gram
 	s = [ s = ne_string -> s | s = IDENT -> s ] ->
 	  VernacLoad (verbosely, s)
       | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 ne_string ->
-	  VernacDeclareMLModule (use_locality (), l)
+	  VernacDeclareMLModule l
 
       | IDENT "Locate"; l = locatable -> VernacLocate l
 
@@ -759,44 +823,32 @@ GEXTEND Gram
 	  VernacPrint (PrintModuleType qid)
       | IDENT "Print"; IDENT "Module"; qid = global ->
 	  VernacPrint (PrintModule qid)
+      | IDENT "Print"; IDENT "Namespace" ; ns = dirpath ->
+          VernacPrint (PrintNamespace ns)
       | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n)
-      | IDENT "About"; qid = smart_global -> VernacPrint (PrintAbout qid)
-
-      (* Searching the environment *)
-      | IDENT "Search"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchHead c, l)
-      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchPattern c, l)
-      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
-	  VernacSearch (SearchRewrite c, l)
-      | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries ->
-	  let (sl,m) = l in VernacSearch (SearchAbout (s::sl), m)
-      (* compatibility format of SearchAbout, with "[ ... ]" *)
-      | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]";
-	  l = in_or_out_modules -> VernacSearch (SearchAbout sl, l)
 
       | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
 	  VernacAddMLPath (false, dir)
       | IDENT "Add"; IDENT "Rec"; IDENT "ML"; IDENT "Path"; dir = ne_string ->
 	  VernacAddMLPath (true, dir)
 
-      (* Pour intervenir sur les tables de param�ètres *)
+      (* For acting on parameter tables *)
       | "Set"; table = option_table; v = option_value ->
-  	  VernacSetOption (use_locality_full(),table,v)
+  	  VernacSetOption (table,v)
       | "Set"; table = option_table ->
-  	  VernacSetOption (use_locality_full(),table,BoolValue true)
+  	  VernacSetOption (table,BoolValue true)
       | IDENT "Unset"; table = option_table ->
-  	  VernacUnsetOption (use_locality_full(),table)
+  	  VernacUnsetOption table
 
       | IDENT "Print"; IDENT "Table"; table = option_table ->
 	  VernacPrintOption table
 
       | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value
         -> VernacAddOption ([table;field], v)
-      (* Un value global ci-dessous va �être cach�é par un field au dessus! *)
-      (* En fait, on donne priorit�é aux tables secondaires *)
-      (* Pas de syntaxe pour les tables tertiaires pour cause de conflit *)
-      (* (mais de toutes fa�çons, pas utilis�ées) *)
+      (* A global value below will be hidden by a field above! *)
+      (* In fact, we give priority to secondary tables *)
+      (* No syntax for tertiary tables due to conflict *)
+      (* (but they are unused anyway) *)
       | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value ->
           VernacAddOption ([table], v)
 
@@ -810,13 +862,31 @@ GEXTEND Gram
       | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value ->
 	  VernacRemoveOption ([table], v) ]] 
   ;
-  check_command: (* TODO: rapprocher Eval et Check *)
+  query_command: (* TODO: rapprocher Eval et Check *)
     [ [ IDENT "Eval"; r = Tactic.red_expr; "in"; c = lconstr ->
           fun g -> VernacCheckMayEval (Some r, g, c)
       | IDENT "Compute"; c = lconstr ->
-	  fun g -> VernacCheckMayEval (Some Glob_term.CbvVm, g, c)
+	  fun g -> VernacCheckMayEval (Some (Genredexpr.CbvVm None), g, c)
       | IDENT "Check"; c = lconstr ->
-	  fun g -> VernacCheckMayEval (None, g, c) ] ]
+	 fun g -> VernacCheckMayEval (None, g, c)
+      (* Searching the environment *)
+      | IDENT "About"; qid = smart_global ->
+	 fun g -> VernacPrint (PrintAbout (qid,g))
+      | IDENT "SearchHead"; c = constr_pattern; l = in_or_out_modules ->
+	  fun g -> VernacSearch (SearchHead c,g, l)
+      | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules ->
+	  fun g -> VernacSearch (SearchPattern c,g, l)
+      | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules ->
+	  fun g -> VernacSearch (SearchRewrite c,g, l)
+      | IDENT "Search"; s = searchabout_query; l = searchabout_queries ->
+	  let (sl,m) = l in fun g -> VernacSearch (SearchAbout (s::sl),g, m)
+      (* compatibility: SearchAbout *)
+      | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries ->
+	  fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m)
+      (* compatibility: SearchAbout with "[ ... ]" *)
+      | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]";
+	  l = in_or_out_modules -> fun g -> VernacSearch (SearchAbout sl,g, l)
+      ] ]
   ;
   printable:
     [ [ IDENT "Term"; qid = smart_global -> PrintName qid
@@ -832,6 +902,7 @@ GEXTEND Gram
 
       | IDENT "ML"; IDENT "Path" -> PrintMLLoadPath
       | IDENT "ML"; IDENT "Modules" -> PrintMLModules
+      | IDENT "Debug"; IDENT "GC" -> PrintDebugGC
       | IDENT "Graph" -> PrintGraph
       | IDENT "Classes" ->  PrintClasses
       | IDENT "TypeClasses" -> PrintTypeClasses
@@ -854,8 +925,12 @@ GEXTEND Gram
       | IDENT "Implicit"; qid = smart_global -> PrintImplicit qid
       | IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (false, fopt)
       | IDENT "Sorted"; IDENT "Universes"; fopt = OPT ne_string -> PrintUniverses (true, fopt)
-      | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, qid)
-      | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, qid) ] ]
+      | IDENT "Assumptions"; qid = smart_global -> PrintAssumptions (false, false, qid)
+      | IDENT "Opaque"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, false, qid)
+      | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (false, true, qid)
+      | IDENT "All"; IDENT "Dependencies"; qid = smart_global -> PrintAssumptions (true, true, qid)
+      | IDENT "Strategy"; qid = smart_global -> PrintStrategy (Some qid)
+      | IDENT "Strategies" -> PrintStrategy None ] ]
   ;
   class_rawexpr:
     [ [ IDENT "Funclass" -> FunClass
@@ -863,7 +938,8 @@ GEXTEND Gram
       | qid = smart_global -> RefClass qid ] ]
   ;
   locatable:
-    [ [ qid = smart_global -> LocateTerm qid
+    [ [ qid = smart_global -> LocateAny qid
+      | IDENT "Term"; qid = smart_global -> LocateTerm qid
       | IDENT "File"; f = ne_string -> LocateFile f
       | IDENT "Library"; qid = global -> LocateLibrary qid
       | IDENT "Module"; qid = global -> LocateModule qid
@@ -938,16 +1014,16 @@ GEXTEND Gram
 
 (* Tactic Debugger *)
       |	IDENT "Debug"; IDENT "On" ->
-          VernacSetOption (None,["Ltac";"Debug"], BoolValue true)
+          VernacSetOption (["Ltac";"Debug"], BoolValue true)
 
       |	IDENT "Debug"; IDENT "Off" ->
-          VernacSetOption (None,["Ltac";"Debug"], BoolValue false)
+          VernacSetOption (["Ltac";"Debug"], BoolValue false)
 
 (* registration of a custom reduction *)
 
       | IDENT "Declare"; IDENT "Reduction"; s = IDENT; ":=";
          r = Tactic.red_expr ->
-	   VernacDeclareReduction (use_locality(),s,r)
+	   VernacDeclareReduction (s,r)
 
  ] ];
     END
@@ -960,31 +1036,33 @@ GEXTEND Gram
 
   syntax:
    [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT ->
-         VernacOpenCloseScope (enforce_section_locality local,true,sc)
+         VernacOpenCloseScope (local,(true,sc))
 
      | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT ->
-         VernacOpenCloseScope (enforce_section_locality local,false,sc)
+         VernacOpenCloseScope (local,(false,sc))
 
      | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT ->
 	 VernacDelimiters (sc,key)
 
      | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with";
-       refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl)
+       refl = LIST1 smart_global -> VernacBindScope (sc,refl)
 
      | IDENT "Infix"; local = obsolete_locality;
 	 op = ne_lstring; ":="; p = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-         VernacInfix (enforce_module_locality local,(op,modl),p,sc)
+         VernacInfix (local,(op,modl),p,sc)
      | IDENT "Notation"; local = obsolete_locality; id = identref;
 	 idl = LIST0 ident; ":="; c = constr; b = only_parsing ->
            VernacSyntacticDefinition
-	     (id,(idl,c),enforce_module_locality local,b)
+	     (id,(idl,c),local,b)
      | IDENT "Notation"; local = obsolete_locality; s = ne_lstring; ":=";
 	 c = constr;
          modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ];
 	 sc = OPT [ ":"; sc = IDENT -> sc ] ->
-           VernacNotation (enforce_module_locality local,c,(s,modl),sc)
+           VernacNotation (local,c,(s,modl),sc)
+     | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING ->
+           VernacNotationAddFormat (n,s,fmt)
 
      | IDENT "Tactic"; IDENT "Notation"; n = tactic_level;
 	 pil = LIST1 production_item; ":="; t = Tactic.tactic
@@ -994,12 +1072,12 @@ GEXTEND Gram
 	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] ->
 	   Metasyntax.check_infix_modifiers l;
 	   let (loc,s) = s in
-	   VernacSyntaxExtension (use_module_locality(),((loc,"x '"^s^"' y"),l))
+	   VernacSyntaxExtension (false,((loc,"x '"^s^"' y"),l))
 
      | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality;
 	 s = ne_lstring;
 	 l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]
-	 -> VernacSyntaxExtension (enforce_module_locality local,(s,l))
+	 -> VernacSyntaxExtension (local,(s,l))
 
      (* "Print" "Grammar" should be here but is in "command" entry in order
         to factorize with other "Print"-based vernac entries *)
@@ -1031,7 +1109,11 @@ GEXTEND Gram
         SetOnlyParsing Flags.Current
       | IDENT "compat"; s = STRING ->
         SetOnlyParsing (Coqinit.get_compat_version s)
-      | IDENT "format"; s = [s = STRING -> (loc,s)] -> SetFormat s
+      | IDENT "format"; s1 = [s = STRING -> (!@loc,s)];
+                        s2 = OPT [s = STRING -> (!@loc,s)] ->
+          begin match s1, s2 with
+          | (_,k), Some s -> SetFormat(k,s)
+          | s, None -> SetFormat ("text",s) end
       | x = IDENT; ","; l = LIST1 [id = IDENT -> id ] SEP ","; "at";
         lev = level -> SetItemLevel (x::l,lev)
       | x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev)
@@ -1049,6 +1131,6 @@ GEXTEND Gram
     [ [ s = ne_string -> TacTerm s
       | nt = IDENT;
         po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ];
-                   ")" -> (p,sep) ] -> TacNonTerm (loc,nt,po) ] ]
+                   ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ]
   ;
 END
diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4
index 6f5e378a..84e4a573 100644
--- a/parsing/g_xml.ml4
+++ b/parsing/g_xml.ml4
@@ -1,32 +1,34 @@
 (************************************************************************)
 (*  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 Names
-open Term
 open Pcoq
 open Glob_term
-open Genarg
 open Tacexpr
 open Libnames
-
-open Nametab
+open Globnames
 open Detyping
-open Tok
+open Misctypes
+open Decl_kinds
+open Genredexpr
+open Tok (* necessary for camlp4 *)
 
 (* Generic xml parser without raw data *)
 
-type attribute = string * (loc * string)
-type xml = XmlTag of loc * string * attribute list * xml list
+type attribute = string * (Loc.t * string)
+type xml = XmlTag of Loc.t * string * attribute list * xml list
 
 let check_tags loc otag ctag =
-  if otag <> ctag then
+  if not (String.equal otag ctag) then
     user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++
       str "does not match open xml tag " ++ str otag ++ str ".")
 
@@ -41,27 +43,22 @@ GEXTEND Gram
   xml:
     [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml;
         "<"; "/"; ctag = IDENT; ">"  ->
-	  check_tags loc otag ctag;
-	  XmlTag (loc,ctag,attrs,l)
+	  check_tags (!@loc) otag ctag;
+	  XmlTag (!@loc,ctag,attrs,l)
       | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" ->
-	  XmlTag (loc,tag,attrs,[])
+	  XmlTag (!@loc,tag,attrs,[])
     ] ]
   ;
   attr:
-    [ [ name = IDENT; "="; data = STRING -> (name, (loc, data)) ] ]
+    [ [ name = IDENT; "="; data = STRING -> (name, (!@loc, data)) ] ]
   ;
 END
 
 (* Errors *)
 
-let error_expect_two_arguments loc =
-  user_err_loc (loc,"",str "wrong number of arguments (expect two).")
-
-let error_expect_one_argument loc =
-  user_err_loc (loc,"",str "wrong number of arguments (expect one).")
-
-let error_expect_no_argument loc =
-  user_err_loc (loc,"",str "wrong number of arguments (expect none).")
+let error_bad_arity loc n =
+  let s = match n with 0 -> "none" | 1 -> "one" | 2 -> "two" | _ -> "many" in
+  user_err_loc (loc,"",str ("wrong number of arguments (expect "^s^")."))
 
 (* Interpreting attributes *)
 
@@ -70,33 +67,49 @@ let nmtoken (loc,a) =
   with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.")
 
 let get_xml_attr s al =
-  try List.assoc s al
+  try String.List.assoc s al
   with Not_found -> error ("No attribute "^s)
 
 (* Interpreting specific attributes *)
 
-let ident_of_cdata (loc,a) = id_of_string a
+let ident_of_cdata (loc,a) = Id.of_string a
 
 let uri_of_data s =
-  let n = String.index s ':' in
-  let p = String.index s '.' in
-  let s = String.sub s (n+2) (p-n-2) in
-  for i=0 to String.length s - 1 do if s.[i]='/' then s.[i]<-'.' done;
-  qualid_of_string s
-
-let constant_of_cdata (loc,a) = Nametab.locate_constant (uri_of_data a)
-
-let global_of_cdata (loc,a) = Nametab.locate (uri_of_data a)
+  try
+    let n = String.index s ':' in
+    let p = String.index s '.' in
+    let s = String.sub s (n+2) (p-n-2) in
+    for i = 0 to String.length s - 1 do
+      match s.[i] with
+      | '/' -> s.[i] <- '.'
+      | _ -> ()
+    done;
+    qualid_of_string s
+  with Not_found | Invalid_argument _ ->
+    error ("Malformed URI \""^s^"\"")
+
+let constant_of_cdata (loc,a) =
+  let q = uri_of_data a in
+  try Nametab.locate_constant q
+  with Not_found -> error ("No such constant "^string_of_qualid q)
+
+let global_of_cdata (loc,a) =
+  let q = uri_of_data a in
+  try Nametab.locate q
+  with Not_found -> error ("No such global "^string_of_qualid q)
 
 let inductive_of_cdata a = match global_of_cdata a with
-    | IndRef (kn,_) -> kn
-    | _ -> anomaly "XML parser: not an inductive"
+  | IndRef (kn,_) -> kn
+  | _ -> error (string_of_qualid (uri_of_data (snd a)) ^" is not an inductive")
 
-let ltacref_of_cdata (loc,a) = (loc,locate_tactic (uri_of_data a))
+let ltacref_of_cdata (loc,a) =
+  let q = uri_of_data a in
+  try (loc,Nametab.locate_tactic q)
+  with Not_found -> error ("No such ltac "^string_of_qualid q)
 
 let sort_of_cdata (loc,a) = match a with
-  | "Prop" -> GProp Null
-  | "Set" -> GProp Pos
+  | "Prop" -> GProp
+  | "Set" -> GSet
   | "Type" -> GType None
   | _ -> user_err_loc (loc,"",str "sort expected.")
 
@@ -105,7 +118,7 @@ let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al)
 let get_xml_inductive_kn al =
   inductive_of_cdata (* uriType apparent synonym of uri *)
     (try get_xml_attr "uri" al
-     with e when Errors.noncritical e -> get_xml_attr "uriType" al)
+     with UserError _ -> get_xml_attr "uriType" al)
 
 let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al)
 
@@ -116,7 +129,7 @@ let get_xml_constructor al =
   (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al))
 
 let get_xml_binder al =
-  try Name (ident_of_cdata (List.assoc "binder" al))
+  try Name (ident_of_cdata (String.List.assoc "binder" al))
   with Not_found -> Anonymous
 
 let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al)
@@ -125,7 +138,7 @@ let get_xml_name al = ident_of_cdata (get_xml_attr "name" al)
 
 let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al)
 
-let get_xml_no al = nmtoken (get_xml_attr "no" al)
+let get_xml_no al = Evar.unsafe_of_int (nmtoken (get_xml_attr "no" al))
 
 (* A leak in the xml dtd: arities of constructor need to know global env *)
 
@@ -133,8 +146,8 @@ let compute_branches_lengths ind =
   let (_,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
   mip.Declarations.mind_consnrealdecls
 
-let compute_inductive_nargs ind =
-  Inductiveops.inductive_nargs (Global.env()) ind
+let compute_inductive_ndecls ind =
+  Inductiveops.inductive_nrealdecls ind
 
 (* Interpreting constr as a glob_constr *)
 
@@ -144,17 +157,17 @@ let rec interp_xml_constr = function
   | XmlTag (loc,"VAR",al,[]) ->
       error "XML parser: unable to interp free variables"
   | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) ->
-      let body,decls = list_sep_last xl in
+      let body,decls = List.sep_last xl in
       let ctx = List.map interp_xml_decl decls in
       List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b))
 	ctx (interp_xml_target body)
   | XmlTag (loc,"PROD",al,(_::_ as xl)) ->
-      let body,decls = list_sep_last xl in
+      let body,decls = List.sep_last xl in
       let ctx = List.map interp_xml_decl decls in
       List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b))
 	ctx (interp_xml_target body)
   | XmlTag (loc,"LETIN",al,(_::_ as xl)) ->
-      let body,defs = list_sep_last xl in
+      let body,defs = List.sep_last xl in
       let ctx = List.map interp_xml_def defs in
       List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b))
         ctx (interp_xml_target body)
@@ -164,48 +177,48 @@ let rec interp_xml_constr = function
       (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) ->
       GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl)
   | XmlTag (loc,"META",al,xl) ->
-      GEvar (loc, get_xml_no al, Some (List.map interp_xml_substitution xl))
+      GEvar (loc, get_xml_name al, Some (List.map interp_xml_substitution xl))
   | XmlTag (loc,"CONST",al,[]) ->
-      GRef (loc, ConstRef (get_xml_constant al))
+      GRef (loc, ConstRef (get_xml_constant al), None)
   | XmlTag (loc,"MUTCASE",al,x::y::yl) ->
       let ind = get_xml_inductive al in
       let p = interp_xml_patternsType x in
       let tm = interp_xml_inductiveTerm y in
       let vars = compute_branches_lengths ind in
-      let brs = list_map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl
+      let brs = List.map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl
       in
       let mat = simple_cases_matrix_of_branches ind brs in
-      let nparams,n = compute_inductive_nargs ind in
-      let nal,rtn = return_type_of_predicate ind nparams n p in
+      let n = compute_inductive_ndecls ind in
+      let nal,rtn = return_type_of_predicate ind n p in
       GCases (loc,RegularStyle,rtn,[tm,nal],mat)
   | XmlTag (loc,"MUTIND",al,[]) ->
-      GRef (loc, IndRef (get_xml_inductive al))
+      GRef (loc, IndRef (get_xml_inductive al), None)
   | XmlTag (loc,"MUTCONSTRUCT",al,[]) ->
-      GRef (loc, ConstructRef (get_xml_constructor al))
+      GRef (loc, ConstructRef (get_xml_constructor al), None)
   | XmlTag (loc,"FIX",al,xl) ->
       let li,lnct = List.split (List.map interp_xml_FixFunction xl) in
-      let ln,lc,lt = list_split3 lnct in
+      let ln,lc,lt = List.split3 lnct in
       let lctx = List.map (fun _ -> []) ln in
       GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt)
   | XmlTag (loc,"COFIX",al,xl) ->
-      let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in
+      let ln,lc,lt = List.split3 (List.map interp_xml_CoFixFunction xl) in
       GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt)
   | XmlTag (loc,"CAST",al,[x1;x2]) ->
-      GCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2))
+      GCast (loc, interp_xml_term x1, CastConv (interp_xml_type x2))
   | XmlTag (loc,"SORT",al,[]) ->
       GSort (loc, get_xml_sort al)
   | XmlTag (loc,s,_,_) ->
       user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".")
 
 and interp_xml_tag s = function
-  | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl)
+  | XmlTag (loc,tag,al,xl) when String.equal tag s -> (loc,al,xl)
   | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "",
     str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".")
 
 and interp_xml_constr_alias s x =
   match interp_xml_tag s x with
     | (_,_,[x]) -> interp_xml_constr x
-    | (loc,_,_) -> error_expect_one_argument loc
+    | (loc,_,_) -> error_bad_arity loc 1
 
 and interp_xml_term x = interp_xml_constr_alias "term" x
 and interp_xml_type x = interp_xml_constr_alias "type" x
@@ -215,13 +228,16 @@ and interp_xml_pattern x = interp_xml_constr_alias "pattern" x
 and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x
 and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x
 and interp_xml_arg x = interp_xml_constr_alias "arg" x
-and interp_xml_substitution x = interp_xml_constr_alias "substitution" x
+and interp_xml_substitution x =
+  match interp_xml_tag "substitution" x with
+    _, al, [x] -> get_xml_name al, interp_xml_constr x
+  | loc, _, _ -> error_bad_arity loc 1
                      (* no support for empty substitution from official dtd *)
 
 and interp_xml_decl_alias s x =
   match interp_xml_tag s x with
     | (_,al,[x]) -> (get_xml_binder al, interp_xml_constr x)
-    | (loc,_,_) -> error_expect_one_argument loc
+    | (loc,_,_) -> error_bad_arity loc 1
 
 and interp_xml_def x = interp_xml_decl_alias "def" x
 and interp_xml_decl x = interp_xml_decl_alias "decl" x
@@ -229,20 +245,14 @@ and interp_xml_decl x = interp_xml_decl_alias "decl" x
 and interp_xml_recursionOrder x =
   let (loc, al, l) = interp_xml_tag "RecursionOrder" x in
   let (locs, s) = get_xml_attr "type" al in
-    match s with
-	"Structural" ->
-	  (match l with [] -> GStructRec
-	     | _ -> error_expect_no_argument loc)
-      | "WellFounded" ->
-	  (match l with
-	       [c] -> GWfRec (interp_xml_type c)
-	     | _ -> error_expect_one_argument loc)
-      | "Measure" ->
-	  (match l with
-	       [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r))
-	     | _ -> error_expect_two_arguments loc)
-      | _ ->
-          user_err_loc (locs,"",str "Invalid recursion order.")
+  match s, l with
+  | "Structural", [] -> GStructRec
+  | "Structural", _ -> error_bad_arity loc 0
+  | "WellFounded", [c] -> GWfRec (interp_xml_type c)
+  | "WellFounded", _ -> error_bad_arity loc 1
+  | "Measure", [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r))
+  | "Measure", _ -> error_bad_arity loc 2
+  | _ -> user_err_loc (locs,"",str "Invalid recursion order.")
 
 and interp_xml_FixFunction x =
   match interp_xml_tag "FixFunction" x with
@@ -254,14 +264,14 @@ and interp_xml_FixFunction x =
       ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec),
        (get_xml_name al, interp_xml_type x1, interp_xml_body x2))
   | (loc,_,_) ->
-      error_expect_one_argument loc
+      error_bad_arity loc 1
 
 and interp_xml_CoFixFunction x =
   match interp_xml_tag "CoFixFunction" x with
   | (loc,al,[x1;x2]) ->
       (get_xml_name al, interp_xml_type x1, interp_xml_body x2)
     | (loc,_,_) ->
-	error_expect_one_argument loc
+	error_bad_arity loc 1
 
 (* Interpreting tactic argument *)
 
diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib
deleted file mode 100644
index ba393e63..00000000
--- a/parsing/grammar.mllib
+++ /dev/null
@@ -1,88 +0,0 @@
-Coq_config
-
-Profile
-Pp_control
-Pp
-Compat
-Flags
-Segmenttree
-Unicodetable
-Util
-Errors
-Bigint
-Dyn
-Hashcons
-Predicate
-Rtree
-Option
-Store
-Hashtbl_alt
-
-Names
-Univ
-Esubst
-Term
-Mod_subst
-Sign
-Cbytecodes
-Copcodes
-Cemitcodes
-Declarations
-Retroknowledge
-Pre_env
-Cbytegen
-Environ
-Conv_oracle
-Closure
-Reduction
-Type_errors
-Entries
-Modops
-Inductive
-Typeops
-Indtypes
-Cooking
-Term_typing
-Subtyping
-Mod_typing
-Safe_typing
-
-Nameops
-Libnames
-Summary
-Nametab
-Libobject
-Lib
-Goptions
-Decl_kinds
-Global
-Termops
-Namegen
-Evd
-Reductionops
-Inductiveops
-Glob_term
-Detyping
-Pattern
-Topconstr
-Genarg
-Ppextend
-Tacexpr
-Tok
-Lexer
-Extend
-Vernacexpr
-Extrawit
-Pcoq
-Q_util
-Q_coqast
-
-Egrammar
-Argextend
-Tacextend
-Vernacextend
-
-G_prim
-G_tactic
-G_ltac
-G_constr
diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib
index eed6caea..13ed8046 100644
--- a/parsing/highparsing.mllib
+++ b/parsing/highparsing.mllib
@@ -4,3 +4,4 @@ G_prim
 G_proofs
 G_tactic
 G_ltac
+G_obligations
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index 82ae2dc8..8e839296 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -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        *)
@@ -14,7 +14,8 @@ open Tok
 (* Dictionaries: trees annotated with string options, each node being a map
    from chars to dictionaries (the subtrees). A trie, in other words. *)
 
-module CharMap = Map.Make (struct type t = char let compare = compare end)
+module CharOrd = struct type t = char let compare : char -> char -> int = compare end
+module CharMap = Map.Make (CharOrd)
 
 type ttree = {
   node : string option;
@@ -86,27 +87,28 @@ module Error = struct
   let to_string x =
     "Syntax Error: Lexer: " ^
       (match x with
-	 | Illegal_character -> "Illegal character"
-	 | Unterminated_comment -> "Unterminated comment"
-	 | Unterminated_string -> "Unterminated string"
-	 | Undefined_token -> "Undefined token"
-	 | Bad_token tok -> Format.sprintf "Bad token %S" tok
-	 | UnsupportedUnicode x ->
-	     Printf.sprintf "Unsupported Unicode character (0x%x)" x)
+         | Illegal_character -> "Illegal character"
+         | Unterminated_comment -> "Unterminated comment"
+         | Unterminated_string -> "Unterminated string"
+         | Undefined_token -> "Undefined token"
+         | Bad_token tok -> Format.sprintf "Bad token %S" tok
+         | UnsupportedUnicode x ->
+             Printf.sprintf "Unsupported Unicode character (0x%x)" x)
 
-  let print ppf x = Format.fprintf ppf "%s@." (to_string x)
+  (* Require to fix the Camlp4 signature *)
+  let print ppf x = Pp.pp_with ppf (Pp.str (to_string x))
 
 end
 open Error
 
-let err loc str = Loc.raise (make_loc loc) (Error.E str)
+let err loc str = Loc.raise (Loc.make_loc loc) (Error.E str)
 
 let bad_token str = raise (Error.E (Bad_token str))
 
 (* Lexer conventions on tokens *)
 
 type token_kind =
-  | Utf8Token of (utf8_status * int)
+  | Utf8Token of (Unicode.status * int)
   | AsciiChar
   | EmptyStream
 
@@ -130,38 +132,38 @@ let utf8_char_size cs = function
 let njunk n = Util.repeat n Stream.junk
 
 let check_utf8_trailing_byte cs c =
-  if Char.code c land 0xC0 <> 0x80 then error_utf8 cs
+  if not (Int.equal (Char.code c land 0xC0) 0x80) then error_utf8 cs
 
 (* Recognize utf8 blocks (of length less than 4 bytes) *)
 (* but don't certify full utf8 compliance (e.g. no emptyness check) *)
 let lookup_utf8_tail c cs =
   let c1 = Char.code c in
-  if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs
+  if Int.equal (c1 land 0x40) 0 || Int.equal (c1 land 0x38) 0x38 then error_utf8 cs
   else
     let n, unicode =
-      if c1 land 0x20 = 0 then
+      if Int.equal (c1 land 0x20) 0 then
       match Stream.npeek 2 cs with
       | [_;c2] ->
-	  check_utf8_trailing_byte cs c2;
-	  2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F)
+          check_utf8_trailing_byte cs c2;
+          2, (c1 land 0x1F) lsl 6 + (Char.code c2 land 0x3F)
       | _ -> error_utf8 cs
-      else if c1 land 0x10 = 0 then
+      else if Int.equal (c1 land 0x10) 0 then
       match Stream.npeek 3 cs with
       | [_;c2;c3] ->
-	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
-	  3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 +
-	  (Char.code c3 land 0x3F)
+          check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
+          3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 +
+          (Char.code c3 land 0x3F)
       | _ -> error_utf8 cs
       else match Stream.npeek 4 cs with
       | [_;c2;c3;c4] ->
-	  check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
-	  check_utf8_trailing_byte cs c4;
-	  4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 +
-	  (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F)
+          check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3;
+          check_utf8_trailing_byte cs c4;
+          4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 +
+          (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F)
       | _ -> error_utf8 cs
     in
-    try classify_unicode unicode, n
-    with UnsupportedUtf8 ->
+    try Unicode.classify unicode, n
+    with Unicode.Unsupported ->
       njunk n cs; error_unsupported_unicode_character n unicode cs
 
 let lookup_utf8 cs =
@@ -170,17 +172,18 @@ let lookup_utf8 cs =
     | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail c cs)
     | None -> EmptyStream
 
-let unlocated f x =
-  try f x with Loc.Exc_located (_,exc) -> raise exc
+let unlocated f x = f x
+  (** FIXME: should we still unloc the exception? *)
+(*   try f x with Loc.Exc_located (_, exc) -> raise exc *)
 
 let check_keyword str =
   let rec loop_symb = parser
     | [< ' (' ' | '\n' | '\r' | '\t' | '"') >] -> bad_token str
     | [< s >] ->
-	match unlocated lookup_utf8 s with
-	| Utf8Token (_,n) -> njunk n s; loop_symb s
-	| AsciiChar -> Stream.junk s; loop_symb s
-	| EmptyStream -> ()
+        match unlocated lookup_utf8 s with
+        | Utf8Token (_,n) -> njunk n s; loop_symb s
+        | AsciiChar -> Stream.junk s; loop_symb s
+        | EmptyStream -> ()
   in
   loop_symb (Stream.of_string str)
 
@@ -188,7 +191,8 @@ let check_keyword_to_add s =
   try check_keyword s
   with Error.E (UnsupportedUnicode unicode) ->
     Flags.if_verbose msg_warning
-      (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x which will not be parsable." s unicode))
+      (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x \
+                               which will not be parsable." s unicode))
 
 let check_ident str =
   let rec loop_id intail = parser
@@ -197,11 +201,13 @@ let check_ident str =
     | [< ' ('0'..'9' | ''') when intail; s >] ->
         loop_id true s
     | [< s >] ->
-	match unlocated lookup_utf8 s with
-	| Utf8Token (UnicodeLetter, n) -> njunk n s; loop_id true s
-	| Utf8Token (UnicodeIdentPart, n) when intail -> njunk n s; loop_id true s
-	| EmptyStream -> ()
-	| Utf8Token _ | AsciiChar -> bad_token str
+        match unlocated lookup_utf8 s with
+        | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s
+        | Utf8Token (Unicode.IdentPart, n) when intail ->
+          njunk n s;
+          loop_id true s
+        | EmptyStream -> ()
+        | Utf8Token _ | AsciiChar -> bad_token str
   in
   loop_id false (Stream.of_string str)
 
@@ -229,14 +235,7 @@ let remove_keyword str =
 type frozen_t = ttree
 
 let freeze () = !token_tree
-
-let unfreeze tt =
-  token_tree := tt
-
-let init () =
-  unfreeze empty_ttree
-
-let _ = init()
+let unfreeze tt = (token_tree := tt)
 
 (* The string buffering machinery *)
 
@@ -260,8 +259,8 @@ let rec ident_tail len = parser
       ident_tail (store len c) s
   | [< s >] ->
       match lookup_utf8 s with
-      | Utf8Token ((UnicodeIdentPart | UnicodeLetter), n) ->
-	  ident_tail (nstore n len s) s
+      | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) ->
+          ident_tail (nstore n len s) s
       | _ -> len
 
 let rec number len = parser
@@ -274,28 +273,36 @@ let rec string in_comments bp len = parser
   | [< ''('; s >] ->
       (parser
         | [< ''*'; s >] ->
-            string (Option.map succ in_comments) bp (store (store len '(') '*') s
+            string
+              (Option.map succ in_comments)
+              bp (store (store len '(') '*')
+              s
         | [< >] ->
-	    string in_comments bp (store len '(') s) s
+            string in_comments bp (store len '(') s) s
   | [< ''*'; s >] ->
       (parser
         | [< '')'; s >] ->
-            if in_comments = Some 0 then
-	      msg_warning (str "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment.");
+            let () = match in_comments with
+            | Some 0 ->
+                msg_warning
+                  (strbrk
+                     "Not interpreting \"*)\" as the end of current \
+                      non-terminated comment because it occurs in a \
+                      non-terminated string of the comment.")
+            | _ -> ()
+            in
             let in_comments = Option.map pred in_comments in
- 	    string in_comments bp (store (store len '*') ')') s
+            string in_comments bp (store (store len '*') ')') s
         | [< >] ->
-	    string in_comments bp (store len '*') s) s
+            string in_comments bp (store len '*') s) s
   | [< 'c; s >] -> string in_comments bp (store len c) s
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
 
-(* Hook for exporting comment into xml theory files *)
-let xml_output_comment = ref (fun _ -> ())
-let set_xml_output_comment f = xml_output_comment := f
-
 (* Utilities for comments in beautify *)
 let comment_begin = ref None
-let comm_loc bp = if !comment_begin=None then comment_begin := Some bp
+let comm_loc bp = match !comment_begin with
+| None -> comment_begin := Some bp
+| _ -> ()
 
 let current = Buffer.create 8192
 let between_com = ref true
@@ -318,9 +325,9 @@ let push_char c =
   if
     !between_com || List.mem c ['\n';'\r'] ||
     (List.mem c [' ';'\t']&&
-     (Buffer.length current = 0 ||
+     (Int.equal (Buffer.length current) 0 ||
       not (let s = Buffer.contents current in
-	   List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r'])))
+           List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r'])))
   then
     real_push_char c
 
@@ -333,15 +340,14 @@ let null_comment s =
 
 let comment_stop ep =
   let current_s = Buffer.contents current in
-  if !Flags.xml_export && Buffer.length current > 0 &&
-    (!between_com || not(null_comment current_s)) then
-      !xml_output_comment current_s;
   (if Flags.do_beautify() && Buffer.length current > 0 &&
     (!between_com || not(null_comment current_s)) then
     let bp = match !comment_begin with
         Some bp -> bp
       | None ->
-          msgerrnl(str"No begin location for comment '"++str current_s ++str"' ending at  "++int ep);
+          msgerrnl(str "No begin location for comment '"
+                   ++ str current_s ++str"' ending at  "
+                   ++ int ep);
           ep-1 in
     Pp.comments := ((bp,ep),current_s) :: !Pp.comments);
   Buffer.clear current;
@@ -353,8 +359,11 @@ let rec comm_string bp = parser
   | [< ''"' >] -> push_string "\""
   | [< ''\\'; _ =
            (parser [< ' ('"' | '\\' as c) >] ->
-             if c='"' then real_push_char c;
-             real_push_char c
+              let () = match c with
+              | '"' -> real_push_char c
+              | _ -> ()
+              in
+              real_push_char c
                  | [< >] -> real_push_char '\\'); s >]
      -> comm_string bp s
   | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string
@@ -388,26 +397,26 @@ let rec progress_further last nj tt cs =
 and update_longest_valid_token last nj tt cs =
   match tt.node with
   | Some _ as last' ->
-      for i=1 to nj do Stream.junk cs done;
-      progress_further last' 0 tt cs
+    stream_njunk nj cs;
+    progress_further last' 0 tt cs
   | None ->
-      progress_further last nj tt cs
+    progress_further last nj tt cs
 
 (* nj is the number of char peeked since last valid token *)
 (* n the number of char in utf8 block *)
 and progress_utf8 last nj n c tt cs =
   try
     let tt = CharMap.find c tt.branch in
-    if n=1 then
+    if Int.equal n 1 then
       update_longest_valid_token last (nj+n) tt cs
     else
-      match Util.list_skipn (nj+1) (Stream.npeek (nj+n) cs) with
-      | l when List.length l = n-1 ->
-	 List.iter (check_utf8_trailing_byte cs) l;
-	 let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in
-	 update_longest_valid_token last (nj+n) tt cs
+      match Util.List.skipn (nj+1) (Stream.npeek (nj+n) cs) with
+      | l when Int.equal (List.length l) (n - 1) ->
+         List.iter (check_utf8_trailing_byte cs) l;
+         let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in
+         update_longest_valid_token last (nj+n) tt cs
       | _ ->
-	  error_utf8 cs
+          error_utf8 cs
   with Not_found ->
     last
 
@@ -420,6 +429,14 @@ let find_keyword id s =
   | None -> raise Not_found
   | Some c -> KEYWORD c
 
+let process_sequence bp c cs =
+  let rec aux n cs =
+    match Stream.peek cs with
+    | Some c' when c == c' -> Stream.junk cs; aux (n+1) cs
+    | _ -> BULLET (String.make n c), (bp, Stream.count cs)
+  in
+  aux 1 cs
+
 (* Must be a special token *)
 let process_chars bp c cs =
   let t = progress_from_byte None (-1) !token_tree cs c in
@@ -427,9 +444,9 @@ let process_chars bp c cs =
   match t with
     | Some t -> (KEYWORD t, (bp, ep))
     | None ->
-	let ep' = bp + utf8_char_size cs c in
-	njunk (ep' - ep) cs;
-	err (bp, ep') Undefined_token
+        let ep' = bp + utf8_char_size cs c in
+        njunk (ep' - ep) cs;
+        err (bp, ep') Undefined_token
 
 let token_of_special c s = match c with
   | '$' -> METAIDENT s
@@ -444,8 +461,8 @@ let parse_after_special c bp =
       token_of_special c (get_buff len)
   | [< s >] ->
       match lookup_utf8 s with
-      | Utf8Token (UnicodeLetter, n) ->
-	  token_of_special c (get_buff (ident_tail (nstore n 0 s) s))
+      | Utf8Token (Unicode.Letter, n) ->
+          token_of_special c (get_buff (ident_tail (nstore n 0 s) s))
       | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s)
 
 (* Parse what follows a question mark *)
@@ -455,9 +472,10 @@ let parse_after_qmark bp s =
     | Some ('a'..'z' | 'A'..'Z' | '_') -> LEFTQMARK
     | None -> KEYWORD "?"
     | _ ->
-	match lookup_utf8 s with
-	  | Utf8Token (UnicodeLetter, _) -> LEFTQMARK
-	  | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp '?' s)
+        match lookup_utf8 s with
+          | Utf8Token (Unicode.Letter, _) -> LEFTQMARK
+          | AsciiChar | Utf8Token _ | EmptyStream ->
+            fst (process_chars bp '?' s)
 
 let blank_or_eof cs =
   match Stream.peek cs with
@@ -476,11 +494,19 @@ let rec next_token = parser bp
       comment_stop bp;
       (* We enforce that "." should either be part of a larger keyword,
          for instance ".(", or followed by a blank or eof. *)
-      if t = KEYWORD "." then begin
-	if not (blank_or_eof s) then err (bp,ep+1) Undefined_token;
-	if Flags.do_beautify() then between_com := true;
-      end;
+      let () = match t with
+      | KEYWORD ("." | "...") ->
+        if not (blank_or_eof s) then err (bp,ep+1) Undefined_token;
+        between_com := true;
+      | _ -> ()
+      in
       (t, (bp,ep))
+  | [< ' ('-'|'+'|'*' as c); s >] ->
+      let t,new_between_com =
+        if !between_com then process_sequence bp c s,true
+        else process_chars bp c s,false
+      in
+      comment_stop bp; between_com := new_between_com; t
   | [< ''?'; s >] ep ->
       let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp))
   | [< ' ('a'..'z' | 'A'..'Z' | '_' as c);
@@ -499,23 +525,25 @@ let rec next_token = parser bp
         | [< ''*'; s >] ->
             comm_loc bp;
             push_string "(*";
-	    comment bp s;
-	    next_token s
+            comment bp s;
+            next_token s
         | [< t = process_chars bp c >] -> comment_stop bp; t >] ->
       t
   | [< s >] ->
       match lookup_utf8 s with
-	| Utf8Token (UnicodeLetter, n) ->
-	    let len = ident_tail (nstore n 0 s) s in
-	    let id = get_buff len in
-	    let ep = Stream.count s in
-	    comment_stop bp;
-	    (try find_keyword id s with Not_found -> IDENT id), (bp, ep)
-	| AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) ->
-	    let t = process_chars bp (Stream.next s) s in
-	    comment_stop bp; t
-	| EmptyStream ->
-	    comment_stop bp; (EOI, (bp, bp + 1))
+        | Utf8Token (Unicode.Letter, n) ->
+            let len = ident_tail (nstore n 0 s) s in
+            let id = get_buff len in
+            let ep = Stream.count s in
+            comment_stop bp;
+            (try find_keyword id s with Not_found -> IDENT id), (bp, ep)
+        | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart), _) ->
+            let t = process_chars bp (Stream.next s) s in
+            let new_between_com = match t with
+              (KEYWORD ("{"|"}"),_) -> !between_com | _ -> false in
+            comment_stop bp; between_com := new_between_com; t
+        | EmptyStream ->
+            comment_stop bp; (EOI, (bp, bp + 1))
 
 (* (* Debug: uncomment this for tracing tokens seen by coq...*)
 let next_token s =
@@ -537,10 +565,9 @@ let loct_add loct i loc = Hashtbl.add loct i loc
 
 let current_location_table = ref (loct_create ())
 
-type location_table = (int, loc) Hashtbl.t
+type location_table = (int, CompatLoc.t) Hashtbl.t
 let location_table () = !current_location_table
 let restore_location_table t = current_location_table := t
-let location_function n = loct_func !current_location_table n
 
 (** {6 The lexer of Coq} *)
 
@@ -575,7 +602,7 @@ let func cs =
     Stream.from
       (fun i ->
          let (tok, loc) = next_token cs in
-	 loct_add loct i (make_loc loc); Some tok)
+         loct_add loct i (make_loc loc); Some tok)
   in
   current_location_table := loct;
   (ts, loct_func loct)
@@ -595,10 +622,10 @@ ELSE (* official camlp4 for ocaml >= 3.10 *)
 
 module M_ = Camlp4.ErrorHandler.Register (Error)
 
-module Loc = Loc
+module Loc = CompatLoc
 module Token = struct
   include Tok (* Cf. tok.ml *)
-  module Loc = Loc
+  module Loc = CompatLoc
   module Error = Camlp4.Struct.EmptyError
   module Filter = struct
     type token_filter = (Tok.t * Loc.t) Stream.t -> (Tok.t * Loc.t) Stream.t
@@ -631,14 +658,14 @@ let is_ident_not_keyword s =
 
 let is_number s =
   let rec aux i =
-    String.length s = i or
+    Int.equal (String.length s) i ||
     match s.[i] with '0'..'9' -> aux (i+1) | _ -> false
   in aux 0
 
 let strip s =
   let len =
     let rec loop i len =
-      if i = String.length s then len
+      if Int.equal i (String.length s) then len
       else if s.[i] == ' ' then loop (i + 1) len
       else loop (i + 1) (len + 1)
     in
@@ -656,7 +683,7 @@ let strip s =
 
 let terminal s =
   let s = strip s in
-  if s = "" then Util.error "empty token.";
+  let () = match s with "" -> Errors.error "empty token." | _ -> () in
   if is_ident_not_keyword s then IDENT s
   else if is_number s then INT s
   else KEYWORD s
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index cb6b694c..2b9bd37d 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -1,19 +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 Util
-
 val add_keyword : string -> unit
 val remove_keyword : string -> unit
 val is_keyword : string -> bool
 
-val location_function : int -> loc
+(* val location_function : int -> Loc.t *)
 
 (** for coqdoc *)
 type location_table
@@ -27,14 +24,11 @@ val check_keyword : string -> unit
 type frozen_t
 val freeze : unit -> frozen_t
 val unfreeze : frozen_t -> unit
-val init : unit -> unit
 
 type com_state
 val com_state: unit -> com_state
 val restore_com_state: com_state -> unit
 
-val set_xml_output_comment : (string -> unit) -> unit
-
 val terminal : string -> Tok.t
 
 (** The lexer of Coq: *)
diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib
index 84a08d54..a0cb8319 100644
--- a/parsing/parsing.mllib
+++ b/parsing/parsing.mllib
@@ -1,11 +1,6 @@
-Extend
-Extrawit
+Tok
+Compat
+Lexer
 Pcoq
-Egrammar
-G_xml
-Ppconstr
-Printer
-Pptactic
-Tactic_printer
-Printmod
-Prettyp
+Egramml
+Egramcoq
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index 7949a77d..cf6435fe 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -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,17 +8,13 @@
 
 open Pp
 open Compat
-open Tok
+open Errors
 open Util
-open Names
 open Extend
-open Libnames
-open Glob_term
-open Topconstr
 open Genarg
-open Tacexpr
-open Extrawit
-open Ppextend
+open Stdarg
+open Constrarg
+open Tok (* necessary for camlp4 *)
 
 (** The parser of Coq *)
 
@@ -32,6 +28,7 @@ let warning_verbose = ref true
 IFDEF CAMLP5 THEN
 open Gramext
 ELSE
+open PcamlSig.Grammar
 open G
 END
 
@@ -82,7 +79,7 @@ type prod_entry_key =
   | Aself
   | Anext
   | Atactic of int
-  | Agram of G.internal_entry
+  | Agram of string
   | Aentry of string * string
 
 (** [grammar_object] is the superclass of all grammar entries *)
@@ -111,7 +108,6 @@ let weaken_entry x = Gramobj.weaken_entry x
 
 module type Gramtypes =
 sig
-  open Decl_kinds
   val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry
   val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry
 end
@@ -120,8 +116,8 @@ module Gramtypes : Gramtypes =
 struct
   let inGramObj rawwit = in_typed_entry (unquote rawwit)
   let outGramObj (a:'a raw_abstract_argument_type) o =
-    if type_of_typed_entry o <> unquote a
-      then anomaly "outGramObj: wrong type";
+    if not (argument_type_eq (type_of_typed_entry o) (unquote a))
+      then anomaly ~label:"outGramObj" (str "wrong type");
     (* downcast from grammar_object *)
     Obj.magic (object_of_typed_entry o)
 end
@@ -139,10 +135,13 @@ open Gramtypes
     In [single_extend_statement], first two parameters are name and
     assoc iff a level is created *)
 
+(** Type of reinitialization data *)
+type gram_reinit = gram_assoc * gram_position
+
 type ext_kind =
   | ByGrammar of
       grammar_object G.entry
-      * gram_assoc option (** for reinitialization if ever needed *)
+      * gram_reinit option (** for reinitialization if ever needed *)
       * G.extend_statment
   | ByEXTEND of (unit -> unit) * (unit -> unit)
 
@@ -150,28 +149,18 @@ type ext_kind =
 
 let camlp4_state = ref []
 
-(** Deletion
-
-   Caveat: deletion is not the converse of extension: when an
-   empty level is extended, deletion removes the level instead
-   of keeping it empty. This has an effect on the empty levels 8,
-   99 and 200. We didn't find a good solution to this problem
-   (e.g. using G.extend to know if the level exists results in a
-   printed error message as side effect). As a consequence an
-   extension at 99 or 8 (and for pattern 200 too) inside a section
-   corrupts the parser. *)
+(** Deletion *)
 
 let grammar_delete e reinit (pos,rls) =
   List.iter
     (fun (n,ass,lev) ->
       List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev))
     (List.rev rls);
-  if reinit <> None then
+  match reinit with
+  | Some (a,ext) ->
     let lev = match pos with Some (Level n) -> n | _ -> assert false in
-    let pos =
-      if lev = "200" then First
-      else After (string_of_int (int_of_string lev + 1)) in
-    maybe_uncurry (G.extend e) (Some pos, [Some lev,reinit,[]])
+    maybe_uncurry (G.extend e) (Some ext, [Some lev,Some a,[]])
+  | None -> ()
 
 (** The apparent parser of Coq; encapsulate G to keep track
     of the extensions. *)
@@ -213,9 +202,10 @@ let grammar_extend e reinit ext =
 let rec remove_grammars n =
   if n>0 then
     (match !camlp4_state with
-       | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove"
+       | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove")
        | ByGrammar(g,reinit,ext)::t ->
-           grammar_delete g reinit ext;
+           let f (a,b) = (of_coq_assoc a, of_coq_position b) in
+           grammar_delete g (Option.map f reinit) ext;
            camlp4_state := t;
            remove_grammars (n-1)
        | ByEXTEND (undo,redo)::t ->
@@ -270,7 +260,7 @@ let get_univ s =
   try
     Hashtbl.find univ_tab s
   with Not_found ->
-    anomaly ("Unknown grammar universe: "^s)
+    anomaly (Pp.str ("Unknown grammar universe: "^s))
 
 let get_entry (u, utab) s = Hashtbl.find utab s
 
@@ -283,14 +273,14 @@ let new_entry etyp (u, utab) s =
 let create_entry (u, utab) s etyp =
   try
     let e = Hashtbl.find utab s in
-    if type_of_typed_entry e <> etyp then
+    if not (argument_type_eq (type_of_typed_entry e) etyp) then
       failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type");
     e
   with Not_found ->
     new_entry etyp (u, utab) s
 
 let create_constr_entry s =
-  outGramObj rawwit_constr (create_entry uconstr s ConstrArgType)
+  outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType)
 
 let create_generic_entry s wit =
   outGramObj wit (create_entry utactic s (unquote wit))
@@ -310,22 +300,22 @@ module Prim =
 
     (* Entries that can be refered via the string -> Gram.entry table *)
     (* Typically for tactic or vernac extensions *)
-    let preident = gec_gen rawwit_pre_ident "preident"
-    let ident = gec_gen rawwit_ident "ident"
-    let natural = gec_gen rawwit_int "natural"
-    let integer = gec_gen rawwit_int "integer"
+    let preident = gec_gen (rawwit wit_pre_ident) "preident"
+    let ident = gec_gen (rawwit wit_ident) "ident"
+    let natural = gec_gen (rawwit wit_int) "natural"
+    let integer = gec_gen (rawwit wit_int) "integer"
     let bigint = Gram.entry_create "Prim.bigint"
-    let string = gec_gen rawwit_string "string"
-    let reference = make_gen_entry uprim rawwit_ref "reference"
+    let string = gec_gen (rawwit wit_string) "string"
+    let reference = make_gen_entry uprim (rawwit wit_ref) "reference"
     let by_notation = Gram.entry_create "by_notation"
     let smart_global = Gram.entry_create "smart_global"
 
     (* parsed like ident but interpreted as a term *)
-    let var = gec_gen rawwit_var "var"
+    let var = gec_gen (rawwit wit_var) "var"
 
     let name = Gram.entry_create "Prim.name"
     let identref = Gram.entry_create "Prim.identref"
-    let pattern_ident = gec_gen rawwit_pattern_ident "pattern_ident"
+    let pattern_ident = Gram.entry_create "pattern_ident"
     let pattern_identref = Gram.entry_create "pattern_identref"
 
     (* A synonym of ident - maybe ident will be located one day *)
@@ -342,7 +332,7 @@ module Prim =
 
 module Constr =
   struct
-    let gec_constr = make_gen_entry uconstr rawwit_constr
+    let gec_constr = make_gen_entry uconstr (rawwit wit_constr)
 
     (* Entries that can be refered via the string -> Gram.entry table *)
     let constr = gec_constr "constr"
@@ -350,9 +340,9 @@ module Constr =
     let constr_eoi = eoi_entry constr
     let lconstr = gec_constr "lconstr"
     let binder_constr = create_constr_entry "binder_constr"
-    let ident = make_gen_entry uconstr rawwit_ident "ident"
-    let global = make_gen_entry uconstr rawwit_ref "global"
-    let sort = make_gen_entry uconstr rawwit_sort "sort"
+    let ident = make_gen_entry uconstr (rawwit wit_ident) "ident"
+    let global = make_gen_entry uconstr (rawwit wit_ref) "global"
+    let sort = make_gen_entry uconstr (rawwit wit_sort) "sort"
     let pattern = Gram.entry_create "constr:pattern"
     let constr_pattern = gec_constr "constr_pattern"
     let lconstr_pattern = gec_constr "lconstr_pattern"
@@ -380,33 +370,37 @@ module Tactic =
     (* Entries that can be refered via the string -> Gram.entry table *)
     (* Typically for tactic user extensions *)
     let open_constr =
-      make_gen_entry utactic (rawwit_open_constr_gen (false,false)) "open_constr"
-    let casted_open_constr =
-      make_gen_entry utactic (rawwit_open_constr_gen (true,false)) "casted_open_constr"
-    let open_constr_wTC =
-      make_gen_entry utactic (rawwit_open_constr_gen (false,true)) "open_constr_wTC"
+      make_gen_entry utactic (rawwit wit_open_constr) "open_constr"
     let constr_with_bindings =
-      make_gen_entry utactic rawwit_constr_with_bindings "constr_with_bindings"
+      make_gen_entry utactic (rawwit wit_constr_with_bindings) "constr_with_bindings"
     let bindings =
-      make_gen_entry utactic rawwit_bindings "bindings"
-    let constr_may_eval = make_gen_entry utactic rawwit_constr_may_eval "constr_may_eval"
+      make_gen_entry utactic (rawwit wit_bindings) "bindings"
+    let constr_may_eval = make_gen_entry utactic (rawwit wit_constr_may_eval) "constr_may_eval"
+    let uconstr =
+      make_gen_entry utactic (rawwit wit_uconstr) "uconstr"
     let quantified_hypothesis =
-      make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis"
-    let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var"
-    let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr"
+      make_gen_entry utactic (rawwit wit_quant_hyp) "quantified_hypothesis"
+    let int_or_var = make_gen_entry utactic (rawwit wit_int_or_var) "int_or_var"
+    let red_expr = make_gen_entry utactic (rawwit wit_red_expr) "red_expr"
     let simple_intropattern =
-      make_gen_entry utactic rawwit_intro_pattern "simple_intropattern"
+      make_gen_entry utactic (rawwit wit_intro_pattern) "simple_intropattern"
+    let clause_dft_concl = 
+      make_gen_entry utactic (rawwit wit_clause_dft_concl) "clause"
+
 
     (* Main entries for ltac *)
     let tactic_arg = Gram.entry_create "tactic:tactic_arg"
     let tactic_expr = Gram.entry_create "tactic:tactic_expr"
     let binder_tactic = Gram.entry_create "tactic:binder_tactic"
 
-    let tactic = make_gen_entry utactic (rawwit_tactic tactic_main_level) "tactic"
+    let tactic = make_gen_entry utactic (rawwit wit_tactic) "tactic"
 
     (* Main entry for quotations *)
     let tactic_eoi = eoi_entry tactic
 
+    (* For Ltac definition *)
+    let tacdef_body = Gram.entry_create "tactic:tacdef_body"
+
   end
 
 module Vernac_ =
@@ -426,7 +420,7 @@ module Vernac_ =
 
     GEXTEND Gram
     main_entry:
-      [ [ a = vernac -> Some (loc,a) | EOI -> None ] ]
+      [ [ a = vernac -> Some (!@loc, a) | EOI -> None ] ]
     ;
     END
 
@@ -450,24 +444,23 @@ let main_entry = Vernac_.main_entry
 let constr_level = string_of_int
 
 let default_levels =
-  [200,RightA,false;
-   100,RightA,false;
-   99,RightA,true;
-   90,RightA,false;
-   10,RightA,false;
-   9,RightA,false;
-   8,RightA,true;
-   1,LeftA,false;
-   0,RightA,false]
+  [200,Extend.RightA,false;
+   100,Extend.RightA,false;
+   99,Extend.RightA,true;
+   10,Extend.RightA,false;
+   9,Extend.RightA,false;
+   8,Extend.RightA,true;
+   1,Extend.LeftA,false;
+   0,Extend.RightA,false]
 
 let default_pattern_levels =
-  [200,RightA,true;
-   100,RightA,false;
-   99,RightA,true;
-   10,LeftA,false;
-   9,RightA,false;
-   1,LeftA,false;
-   0,RightA,false]
+  [200,Extend.RightA,true;
+   100,Extend.RightA,false;
+   99,Extend.RightA,true;
+   10,Extend.LeftA,false;
+   9,Extend.RightA,false;
+   1,Extend.LeftA,false;
+   0,Extend.RightA,false]
 
 let level_stack =
   ref [(default_levels, default_pattern_levels)]
@@ -475,27 +468,30 @@ let level_stack =
 (* At a same level, LeftA takes precedence over RightA and NoneA *)
 (* In case, several associativity exists for a level, we make two levels, *)
 (* first LeftA, then RightA and NoneA together *)
-open Ppextend
 
 let admissible_assoc = function
-  | LeftA, Some (RightA | NonA) -> false
-  | RightA, Some LeftA -> false
+  | Extend.LeftA, Some (Extend.RightA | Extend.NonA) -> false
+  | Extend.RightA, Some Extend.LeftA -> false
   | _ -> true
 
 let create_assoc = function
-  | None -> RightA
+  | None -> Extend.RightA
   | Some a -> a
 
 let error_level_assoc p current expected =
   let pr_assoc = function
-    | LeftA -> str "left"
-    | RightA -> str "right"
-    | NonA -> str "non" in
+    | Extend.LeftA -> str "left"
+    | Extend.RightA -> str "right"
+    | Extend.NonA -> str "non" in
   errorlabstrm ""
     (str "Level " ++ int p ++ str " is already declared " ++
      pr_assoc current ++ str " associative while it is now expected to be " ++
      pr_assoc expected ++ str " associative.")
 
+let create_pos = function
+  | None -> Extend.First
+  | Some lev -> Extend.After (constr_level lev)
+
 let find_position_gen forpat ensure assoc lev =
   let ccurrent,pcurrent as current = List.hd !level_stack in
   match lev with
@@ -507,9 +503,10 @@ let find_position_gen forpat ensure assoc lev =
       let init = ref None in
       let rec add_level q = function
         | (p,_,_ as pa)::l when p > n -> pa :: add_level (Some p) l
-        | (p,a,reinit)::l when p = n ->
+        | (p,a,reinit)::l when Int.equal p n ->
             if reinit then
-	      let a' = create_assoc assoc in (init := Some a'; (p,a',false)::l)
+	      let a' = create_assoc assoc in
+              (init := Some (a',create_pos q); (p,a',false)::l)
 	    else if admissible_assoc (a,assoc) then
 	      raise Exit
             else
@@ -522,35 +519,38 @@ let find_position_gen forpat ensure assoc lev =
 	  else (add_level None ccurrent, pcurrent) in
         level_stack := updated:: !level_stack;
 	let assoc = create_assoc assoc in
-        if !init = None then
+        begin match !init with
+        | None ->
 	  (* Create the entry *)
-	  (if !after = None then Some First
-	   else Some (After (constr_level (Option.get !after)))),
-	   Some assoc, Some (constr_level n), None
-        else
+	   Some (create_pos !after), Some assoc, Some (constr_level n), None
+        | _ ->
 	  (* The reinit flag has been updated *)
-	   Some (Level (constr_level n)), None, None, !init
+	   Some (Extend.Level (constr_level n)), None, None, !init
+        end
       with
 	  (* Nothing has changed *)
           Exit ->
             level_stack := current :: !level_stack;
 	    (* Just inherit the existing associativity and name (None) *)
-	    Some (Level (constr_level n)), None, None, None
+	    Some (Extend.Level (constr_level n)), None, None, None
 
 let remove_levels n =
-  level_stack := list_skipn n !level_stack
+  level_stack := List.skipn n !level_stack
 
 let rec list_mem_assoc_triple x = function
   | [] -> false
-  | (a,b,c) :: l -> a = x or list_mem_assoc_triple x l
+  | (a,b,c) :: l -> Int.equal a x || list_mem_assoc_triple x l
 
 let register_empty_levels forpat levels =
-  map_succeed (fun n ->
-    let levels = (if forpat then snd else fst) (List.hd !level_stack) in
-    if not (list_mem_assoc_triple n levels) then
-      find_position_gen forpat true None (Some n)
-    else
-      failwith "") levels
+  let filter n =
+    try
+      let levels = (if forpat then snd else fst) (List.hd !level_stack) in
+      if not (list_mem_assoc_triple n levels) then
+        Some (find_position_gen forpat true None (Some n))
+      else None
+    with Failure _ -> None
+  in
+  List.map_filter filter levels
 
 let find_position forpat assoc level =
   find_position_gen forpat false assoc level
@@ -564,8 +564,14 @@ let synchronize_level_positions () =
 
 (* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *)
 let camlp4_assoc = function
-  | Some NonA | Some RightA -> RightA
-  | None | Some LeftA -> LeftA
+  | Some Extend.NonA | Some Extend.RightA -> Extend.RightA
+  | None | Some Extend.LeftA -> Extend.LeftA
+
+let assoc_eq al ar = match al, ar with
+| Extend.NonA, Extend.NonA
+| Extend.RightA, Extend.RightA
+| Extend.LeftA, Extend.LeftA -> true
+| _, _ -> false
 
 (* [adjust_level assoc from prod] where [assoc] and [from] are the name
    and associativity of the level where to add the rule; the meaning of
@@ -580,27 +586,30 @@ let adjust_level assoc from = function
   | (NumLevel n,BorderProd (_,None)) -> Some (Some (n,true))
 (* Compute production name on the right side *)
   (* If NonA or LeftA on the right-hand side, set to NEXT *)
-  | (NumLevel n,BorderProd (Right,Some (NonA|LeftA))) ->
+  | (NumLevel n,BorderProd (Right,Some (Extend.NonA|Extend.LeftA))) ->
       Some None
   (* If RightA on the right-hand side, set to the explicit (current) level *)
-  | (NumLevel n,BorderProd (Right,Some RightA)) ->
+  | (NumLevel n,BorderProd (Right,Some Extend.RightA)) ->
       Some (Some (n,true))
 (* Compute production name on the left side *)
   (* If NonA on the left-hand side, adopt the current assoc ?? *)
-  | (NumLevel n,BorderProd (Left,Some NonA)) -> None
+  | (NumLevel n,BorderProd (Left,Some Extend.NonA)) -> None
   (* If the expected assoc is the current one, set to SELF *)
-  | (NumLevel n,BorderProd (Left,Some a)) when a = camlp4_assoc assoc ->
+  | (NumLevel n,BorderProd (Left,Some a)) when assoc_eq a (camlp4_assoc assoc) ->
       None
   (* Otherwise, force the level, n or n-1, according to expected assoc *)
   | (NumLevel n,BorderProd (Left,Some a)) ->
-      if a = LeftA then Some (Some (n,true)) else Some None
+    begin match a with
+    | Extend.LeftA -> Some (Some (n, true))
+    | _ -> Some None
+    end
   (* None means NEXT *)
   | (NextLevel,_) -> Some None
 (* Compute production name elsewhere *)
   | (NumLevel n,InternalProd) ->
       match from with
-	| ETConstr (p,()) when p = n+1 -> Some None
-	| ETConstr (p,()) -> Some (Some (n,n=p))
+	| ETConstr (p,()) when Int.equal p (n + 1) -> Some None
+	| ETConstr (p,()) -> Some (Some (n, Int.equal n p))
 	| _ -> Some (Some (n,false))
 
 let compute_entry allow_create adjust forpat = function
@@ -609,15 +618,16 @@ let compute_entry allow_create adjust forpat = function
        else weaken_entry Constr.operconstr),
       adjust (n,q), false
   | ETName -> weaken_entry Prim.name, None, false
-  | ETBinder true -> anomaly "Should occur only as part of BinderList"
+  | ETBinder true -> anomaly (Pp.str "Should occur only as part of BinderList")
   | ETBinder false -> weaken_entry Constr.binder, None, false
   | ETBinderList (true,tkl) ->
-      assert (tkl=[]); weaken_entry Constr.open_binders, None, false
-  | ETBinderList (false,_) -> anomaly "List of entries cannot be registered."
+    let () = match tkl with [] -> () | _ -> assert false in
+    weaken_entry Constr.open_binders, None, false
+  | ETBinderList (false,_) -> anomaly (Pp.str "List of entries cannot be registered.")
   | ETBigint -> weaken_entry Prim.bigint, None, false
   | ETReference -> weaken_entry Constr.global, None, false
   | ETPattern -> weaken_entry Constr.pattern, None, false
-  | ETConstrList _ -> anomaly "List of entries cannot be registered."
+  | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.")
   | ETOther (u,n) ->
       let u = get_univ u in
       let e =
@@ -645,10 +655,11 @@ let is_self from e =
   match from, e with
       ETConstr(n,()), ETConstr(NumLevel n',
         BorderProd(Right, _ (* Some(NonA|LeftA) *))) -> false
-    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> n=n'
+    | ETConstr(n,()), ETConstr(NumLevel n',BorderProd(Left,_)) -> Int.equal n n'
     | (ETName,ETName | ETReference, ETReference | ETBigint,ETBigint
       | ETPattern, ETPattern) -> true
-    | ETOther(s1,s2), ETOther(s1',s2') -> s1=s1' & s2=s2'
+    | ETOther(s1,s2), ETOther(s1',s2') ->
+      String.equal s1 s1' && String.equal s2 s2'
     | _ -> false
 
 let is_binder_level from e =
@@ -716,10 +727,23 @@ let rec symbol_of_prod_entry_key = function
   | Atactic 5 -> Snterm (Gram.Entry.obj Tactic.binder_tactic)
   | Atactic n ->
       Snterml (Gram.Entry.obj Tactic.tactic_expr, string_of_int n)
-  | Agram s -> Snterm s
+  | Agram s ->
+    let e =
+      try
+      (** ppedrot: we should always generate Agram entries which have already
+          been registered, so this should not fail. *)
+        let (u, s) = match String.split ':' s with
+        | u :: s :: [] -> (u, s)
+        | _ -> raise Not_found
+        in
+        get_entry (get_univ u) s
+      with Not_found ->
+        Errors.anomaly (str "Unregistered grammar entry: " ++ str s)
+    in
+    Snterm (Gram.Entry.obj (object_of_typed_entry e))
   | Aentry (u,s) ->
-      Snterm (Gram.Entry.obj
-	(object_of_typed_entry (get_entry (get_univ u) s)))
+    let e = get_entry (get_univ u) s in
+    Snterm (Gram.Entry.obj (object_of_typed_entry e))
 
 let level_of_snterml = function
   | Snterml (_,l) -> int_of_string l
@@ -728,44 +752,83 @@ let level_of_snterml = function
 (**********************************************************************)
 (* Interpret entry names of the form "ne_constr_list" as entry keys   *)
 
+let coincide s pat off =
+  let len = String.length pat in
+  let break = ref true in
+  let i = ref 0 in
+  while !break && !i < len do
+    let c = Char.code s.[off + !i] in
+    let d = Char.code pat.[!i] in
+    break := Int.equal c d;
+    incr i
+  done;
+  !break
+
+let tactic_level s =
+  if Int.equal (String.length s) 7 && coincide s "tactic" 0 then
+    let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48)
+    else None
+  else None
+
+let type_of_entry u s =
+  type_of_typed_entry (get_entry u s)
+
 let rec interp_entry_name static up_level s sep =
   let l = String.length s in
-  if l > 8 & String.sub s 0 3 = "ne_" & String.sub s (l-5) 5 = "_list" then
+  if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then
     let t, g = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in
-    List1ArgType t, Alist1 g
-  else if l > 12 & String.sub s 0 3 = "ne_" &
-                   String.sub s (l-9) 9 = "_list_sep" then
+    ListArgType t, Alist1 g
+  else if l > 12 && coincide s "ne_" 0 &&
+                   coincide s "_list_sep" (l-9) then
     let t, g = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in
-    List1ArgType t, Alist1sep (g,sep)
-  else if l > 5 & String.sub s (l-5) 5 = "_list" then
+    ListArgType t, Alist1sep (g,sep)
+  else if l > 5 && coincide s "_list" (l-5) then
     let t, g = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in
-    List0ArgType t, Alist0 g
-  else if l > 9 & String.sub s (l-9) 9 = "_list_sep" then
+    ListArgType t, Alist0 g
+  else if l > 9 && coincide s "_list_sep" (l-9) then
     let t, g = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in
-    List0ArgType t, Alist0sep (g,sep)
-  else if l > 4 & String.sub s (l-4) 4 = "_opt" then
+    ListArgType t, Alist0sep (g,sep)
+  else if l > 4 && coincide s "_opt" (l-4) then
     let t, g = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in
     OptArgType t, Aopt g
-  else if l > 5 & String.sub s (l-5) 5 = "_mods" then
+  else if l > 5 && coincide s "_mods" (l-5) then
     let t, g = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in
-    List0ArgType t, Amodifiers g
+    ListArgType t, Amodifiers g
   else
-    let s = if s = "hyp" then "var" else s in
+    let s = match s with "hyp" -> "var" | _ -> s in
+    let check_lvl n = match up_level with
+    | None -> false
+    | Some m -> Int.equal m n
+                && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *)
+                && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *)
+    in
     let t, se =
-      match Extrawit.tactic_genarg_level s with
-	| Some n when Some n = up_level & up_level <> Some 5 -> None, Aself
-	| Some n when Some (n+1) = up_level & up_level <> Some 5 -> None, Anext
-	| Some n -> None, Atactic n
-	| None ->
-      try Some (get_entry uprim s), Aentry ("prim",s) with Not_found ->
-      try Some (get_entry uconstr s), Aentry ("constr",s) with Not_found ->
-      try Some (get_entry utactic s), Aentry ("tactic",s) with Not_found ->
+      match tactic_level s with
+      | Some n ->
+        (** Quite ad-hoc *)
+        let t = unquote (rawwit wit_tactic) in
+        let se =
+          if check_lvl n then Aself
+          else if check_lvl (n + 1) then Anext
+          else Atactic n
+        in
+        (Some t, se)
+      | None ->
+      try Some (type_of_entry uprim s), Aentry ("prim",s) with Not_found ->
+      try Some (type_of_entry uconstr s), Aentry ("constr",s) with Not_found ->
+      try Some (type_of_entry utactic s), Aentry ("tactic",s) with Not_found ->
 	if static then
 	  error ("Unknown entry "^s^".")
 	else
 	  None, Aentry ("",s) in
     let t =
       match t with
-	| Some t -> type_of_typed_entry t
+	| Some t -> t
 	| None -> ExtraArgType s in
     t, se
+
+let list_entry_names () =
+  let add_entry key (entry, _) accu = (key, entry) :: accu in
+  let ans = Hashtbl.fold add_entry (snd uprim) [] in
+  let ans = Hashtbl.fold add_entry (snd uconstr) ans in
+  Hashtbl.fold add_entry (snd utactic) ans
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 1b04b117..dbd2aadf 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -1,21 +1,22 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
-open Glob_term
 open Extend
 open Vernacexpr
 open Genarg
-open Topconstr
+open Constrexpr
 open Tacexpr
 open Libnames
 open Compat
+open Misctypes
+open Genredexpr
 
 (** The parser of Coq *)
 
@@ -102,10 +103,13 @@ val gram_token_of_string : string -> Gram.symbol
 (** The superclass of all grammar entries *)
 type grammar_object
 
+(** Type of reinitialization data *)
+type gram_reinit = gram_assoc * gram_position
+
 (** Add one extension at some camlp4 position of some camlp4 entry *)
 val grammar_extend :
   grammar_object Gram.entry ->
-  gram_assoc option (** for reinitialization if ever needed *) ->
+  gram_reinit option (** for reinitialization if ever needed *) ->
   Gram.extend_statment -> unit
 
 (** Remove the last n extensions *)
@@ -153,29 +157,28 @@ val create_generic_entry : string -> ('a, rlevel) abstract_argument_type ->
 
 module Prim :
   sig
-    open Util
     open Names
     open Libnames
     val preident : string Gram.entry
-    val ident : identifier Gram.entry
-    val name : name located Gram.entry
-    val identref : identifier located Gram.entry
-    val pattern_ident : identifier Gram.entry
-    val pattern_identref : identifier located Gram.entry
-    val base_ident : identifier Gram.entry
+    val ident : Id.t Gram.entry
+    val name : Name.t located Gram.entry
+    val identref : Id.t located Gram.entry
+    val pattern_ident : Id.t Gram.entry
+    val pattern_identref : Id.t located Gram.entry
+    val base_ident : Id.t Gram.entry
     val natural : int Gram.entry
     val bigint : Bigint.bigint Gram.entry
     val integer : int Gram.entry
     val string : string Gram.entry
     val qualid : qualid located Gram.entry
-    val fullyqualid : identifier list located Gram.entry
+    val fullyqualid : Id.t list located Gram.entry
     val reference : reference Gram.entry
-    val by_notation : (loc * string * string option) Gram.entry
+    val by_notation : (Loc.t * string * string option) Gram.entry
     val smart_global : reference or_by_notation Gram.entry
-    val dirpath : dir_path Gram.entry
+    val dirpath : DirPath.t Gram.entry
     val ne_string : string Gram.entry
     val ne_lstring : string located Gram.entry
-    val var : identifier located Gram.entry
+    val var : Id.t located Gram.entry
   end
 
 module Constr :
@@ -185,7 +188,7 @@ module Constr :
     val lconstr : constr_expr Gram.entry
     val binder_constr : constr_expr Gram.entry
     val operconstr : constr_expr Gram.entry
-    val ident : identifier Gram.entry
+    val ident : Id.t Gram.entry
     val global : reference Gram.entry
     val sort : glob_sort Gram.entry
     val pattern : cases_pattern_expr Gram.entry
@@ -195,8 +198,8 @@ module Constr :
     val binder : local_binder list Gram.entry (* closed_binder or variable *)
     val binders : local_binder list Gram.entry (* list of binder *)
     val open_binders : local_binder list Gram.entry
-    val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.entry
-    val typeclass_constraint : (name located * bool * constr_expr) Gram.entry
+    val binders_fixannot : (local_binder list * (Id.t located option * recursion_order_expr)) Gram.entry
+    val typeclass_constraint : (Name.t located * bool * constr_expr) Gram.entry
     val record_declaration : constr_expr Gram.entry
     val appl_arg : (constr_expr * explicitation located option) Gram.entry
   end
@@ -209,28 +212,27 @@ module Module :
 
 module Tactic :
   sig
-    open Glob_term
     val open_constr : open_constr_expr Gram.entry
-    val open_constr_wTC : open_constr_expr Gram.entry
-    val casted_open_constr : open_constr_expr Gram.entry
     val constr_with_bindings : constr_expr with_bindings Gram.entry
     val bindings : constr_expr bindings Gram.entry
     val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry
+    val uconstr : constr_expr Gram.entry
     val quantified_hypothesis : quantified_hypothesis Gram.entry
     val int_or_var : int or_var Gram.entry
     val red_expr : raw_red_expr Gram.entry
-    val simple_tactic : raw_atomic_tactic_expr Gram.entry
-    val simple_intropattern : Genarg.intro_pattern_expr located Gram.entry
+    val simple_tactic : raw_tactic_expr Gram.entry
+    val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry
+    val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry
     val tactic_arg : raw_tactic_arg Gram.entry
     val tactic_expr : raw_tactic_expr Gram.entry
     val binder_tactic : raw_tactic_expr Gram.entry
     val tactic : raw_tactic_expr Gram.entry
     val tactic_eoi : raw_tactic_expr Gram.entry
+    val tacdef_body : (reference * bool * raw_tactic_expr) Gram.entry
   end
 
 module Vernac_ :
   sig
-    open Decl_kinds
     val gallina : vernac_expr Gram.entry
     val gallina_ext : vernac_expr Gram.entry
     val command : vernac_expr Gram.entry
@@ -241,7 +243,7 @@ module Vernac_ :
   end
 
 (** The main entry: reads an optional vernac command *)
-val main_entry : (loc * vernac_expr) option Gram.entry
+val main_entry : (Loc.t * vernac_expr) option Gram.entry
 
 (** Mapping formal entries into concrete ones *)
 
@@ -271,7 +273,7 @@ type prod_entry_key =
   | Aself
   | Anext
   | Atactic of int
-  | Agram of Gram.internal_entry
+  | Agram of string
   | Aentry of string * string
 
 (** Binding general entry keys to symbols *)
@@ -284,19 +286,22 @@ val symbol_of_prod_entry_key :
 val interp_entry_name : bool (** true to fail on unknown entry *) ->
   int option -> string -> string -> entry_type * prod_entry_key
 
+(** Recover the list of all known tactic notation entries. *)
+val list_entry_names : unit -> (string * entry_type) list
+
 (** Registering/resetting the level of a constr entry *)
 
 val find_position :
   bool (** true if for creation in pattern entry; false if in constr entry *) ->
-  gram_assoc option -> int option ->
-    gram_position option * gram_assoc option * string option *
-    (** for reinitialization: *) gram_assoc option
+  Extend.gram_assoc option -> int option ->
+    Extend.gram_position option * Extend.gram_assoc option * string option *
+    (** for reinitialization: *) gram_reinit option
 
 val synchronize_level_positions : unit -> unit
 
 val register_empty_levels : bool -> int list ->
-    (gram_position option * gram_assoc option *
-     string option * gram_assoc option) list
+    (Extend.gram_position option * Extend.gram_assoc option *
+     string option * gram_reinit option) list
 
 val remove_levels : int -> unit
 
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
deleted file mode 100644
index 4fde091d..00000000
--- a/parsing/ppconstr.ml
+++ /dev/null
@@ -1,654 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Util
-open Pp
-open Nametab
-open Names
-open Nameops
-open Libnames
-open Ppextend
-open Topconstr
-open Term
-open Pattern
-open Glob_term
-open Constrextern
-open Termops
-(*i*)
-
-let sep_v = fun _ -> str"," ++ spc()
-let pr_tight_coma () = str "," ++ cut ()
-
-let latom = 0
-let lprod = 200
-let llambda = 200
-let lif = 200
-let lletin = 200
-let lletpattern = 200
-let lfix = 200
-let larrow = 90
-let lcast = 100
-let larg = 9
-let lapp = 10
-let lposint = 0
-let lnegint = 35 (* must be consistent with Notation "- x" *)
-let ltop = (200,E)
-let lproj = 1
-let ldelim = 1
-let lsimpleconstr = (8,E)
-let lsimplepatt = (1,E)
-
-let prec_less child (parent,assoc) =
-  if parent < 0 && child = lprod then true
-  else
-    let parent = abs parent in
-    match assoc with
-      | E -> (<=) child parent
-      | L -> (<) child parent
-      | Prec n -> child<=n
-      | Any -> true
-
-let prec_of_prim_token = function
-  | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
-  | String _ -> latom
-
-open Notation
-
-let print_hunks n pr pr_binders (terms,termlists,binders) unp =
-  let env = ref terms and envlist = ref termlists and bll = ref binders in
-  let pop r = let a = List.hd !r in r := List.tl !r; a in
-  let rec aux = function
-  | [] -> mt ()
-  | UnpMetaVar (_,prec) :: l ->
-      let c = pop env in pr (n,prec) c ++ aux l
-  | UnpListMetaVar (_,prec,sl) :: l ->
-      let cl = pop envlist in
-      let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in
-      let pp2 = aux l in
-      pp1 ++ pp2
-  | UnpBinderListMetaVar (_,isopen,sl) :: l ->
-      let cl = pop bll in pr_binders (fun () -> aux sl) isopen cl ++ aux l
-  | UnpTerminal s :: l -> str s ++ aux l
-  | UnpBox (b,sub) :: l ->
-      (* Keep order: side-effects *)
-      let pp1 = ppcmd_of_box b (aux sub) in
-      let pp2 = aux l in
-      pp1 ++ pp2
-  | UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in
-  aux unp
-
-let pr_notation pr pr_binders s env =
-  let unpl, level = find_notation_printing_rule s in
-  print_hunks level pr pr_binders env unpl, level
-
-let pr_delimiters key strm =
-  strm ++ str ("%"^key)
-
-let pr_generalization bk ak c =
-  let hd, tl =
-    match bk with
-    | Implicit -> "{", "}"
-    | Explicit -> "(", ")"
-  in (* TODO: syntax Abstraction Kind *)
-    str "`" ++ str hd ++ c ++ str tl
-
-let pr_com_at n =
-  if Flags.do_beautify() && n <> 0 then comment n
-  else mt()
-
-let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
-
-let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
-
-let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
-
-let pr_universe = Univ.pr_uni
-
-let pr_glob_sort = function
-  | GProp Term.Null -> str "Prop"
-  | GProp Term.Pos -> str "Set"
-  | GType u -> hov 0 (str "Type" ++ pr_opt (pr_in_comment pr_universe) u)
-
-let pr_id = pr_id
-let pr_name = pr_name
-let pr_qualid = pr_qualid
-let pr_patvar = pr_id
-
-let pr_expl_args pr (a,expl) =
-  match expl with
-  | None -> pr (lapp,L) a
-  | Some (_,ExplByPos (n,_id)) ->
-      anomaly("Explicitation by position not implemented")
-  | Some (_,ExplByName id) ->
-      str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
-
-let pr_opt_type pr = function
-  | CHole _ -> mt ()
-  | t -> cut () ++ str ":" ++ pr t
-
-let pr_opt_type_spc pr = function
-  | CHole _ -> mt ()
-  | t ->  str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
-
-let pr_lident (loc,id) =
-  if loc <> dummy_loc then
-    let (b,_) = unloc loc in
-    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
-  else pr_id id
-
-let pr_lname = function
-    (loc,Name id) -> pr_lident (loc,id)
-  | lna -> pr_located pr_name lna
-
-let pr_or_var pr = function
-  | ArgArg x -> pr x
-  | ArgVar (loc,s) -> pr_lident (loc,s)
-
-let pr_prim_token = function
-  | Numeral n -> str (Bigint.to_string n)
-  | String s -> qs s
-
-let pr_evar pr n l =
-  hov 0 (str (Evd.string_of_existential n) ++
-  (match l with
-   | Some l ->
-       spc () ++ pr_in_comment
-         (fun l ->
-	   str"[" ++ hov 0 (prlist_with_sep pr_comma (pr ltop) l) ++ str"]")
-         (List.rev l)
-   | None -> mt()))
-
-let las = lapp
-let lpator = 100
-let lpatrec = 0
-
-let rec pr_patt sep inh p =
-  let (strm,prec) = match p with
-  | CPatRecord (_, l) ->
-      let pp (c, p) =
-	pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p in
-      str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec
-  | CPatAlias (_,p,id) ->
-      pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
-  | CPatCstr (_,c,[]) -> pr_reference c, latom
-  | CPatCstr (_,c,args) ->
-      pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
-  | CPatCstrExpl (_,c,args) ->
-      str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
-  | CPatAtom (_,None) -> str "_", latom
-  | CPatAtom (_,Some r) -> pr_reference r, latom
-  | CPatOr (_,pl) ->
-      hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
-  | CPatNotation (_,"( _ )",([p],[])) ->
-      pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
-  | CPatNotation (_,s,(l,ll)) ->
-      pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[])
-  | CPatPrim (_,p) -> pr_prim_token p, latom
-  | CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimplepatt p), 1
-  in
-  let loc = cases_pattern_expr_loc p in
-  pr_with_comments loc
-    (sep() ++ if prec_less prec inh then strm else surround strm)
-
-let pr_patt = pr_patt mt
-
-let pr_eqn pr (loc,pl,rhs) =
-  let pl = List.map snd pl in
-  spc() ++ hov 4
-    (pr_with_comments loc
-      (str "| " ++
-      hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
-             ++ str " =>") ++
-      pr_sep_com spc (pr ltop) rhs))
-
-let begin_of_binder = function
-    LocalRawDef((loc,_),_) -> fst (unloc loc)
-  | LocalRawAssum((loc,_)::_,_,_) -> fst (unloc loc)
-  | _ -> assert false
-
-let begin_of_binders = function
-  | b::_ -> begin_of_binder b
-  | _ -> 0
-
-let surround_impl k p =
-  match k with
-  | Explicit -> str"(" ++ p ++ str")"
-  | Implicit -> str"{" ++ p ++ str"}"
-
-let surround_implicit k p =
-  match k with
-  | Explicit -> p
-  | Implicit -> (str"{" ++ p ++ str"}")
-
-let pr_binder many pr (nal,k,t) =
-  match k with
-    | Generalized (b, b', t') ->
-      assert (b=Implicit);
-      begin match nal with
-	|[loc,Anonymous] ->
-	  hov 1 (str"`" ++ (surround_impl b'
-			      ((if t' then str "!" else mt ()) ++ pr t)))
-	|[loc,Name id] ->
-	  hov 1 (str "`" ++ (surround_impl b'
-			       (pr_lident (loc,id) ++ str " : " ++
-				  (if t' then str "!" else mt()) ++ pr t)))
-	|_ -> anomaly "List of generalized binders have alwais one element."
-      end
-    | Default b ->
-      match t with
-	| CHole _ ->
-	  let s = prlist_with_sep spc pr_lname nal in
-	  hov 1 (surround_implicit b s)
-	| _ ->
-	  let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in
-	  hov 1 (if many then surround_impl b s else surround_implicit b s)
-
-let pr_binder_among_many pr_c = function
-  | LocalRawAssum (nal,k,t) ->
-      pr_binder true pr_c (nal,k,t)
-  | LocalRawDef (na,c) ->
-      let c,topt = match c with
-        | CCast(_,c, CastConv (_,t)) -> c, t
-        | _ -> c, CHole (dummy_loc, None) in
-      surround (pr_lname na ++ pr_opt_type pr_c topt ++
-         str":=" ++ cut() ++ pr_c c)
-
-let pr_undelimited_binders sep pr_c =
-  prlist_with_sep sep (pr_binder_among_many pr_c)
-
-let pr_delimited_binders kw sep pr_c bl =
-  let n = begin_of_binders bl in
-  match bl with
-  | [LocalRawAssum (nal,k,t)] ->
-      pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t)
-  | LocalRawAssum _ :: _ as bdl ->
-      pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl
-  | _ -> assert false
-
-let pr_binders_gen pr_c sep is_open =
-  if is_open then pr_delimited_binders mt sep pr_c
-  else pr_undelimited_binders sep pr_c
-
-let rec extract_prod_binders = function
-(*  | CLetIn (loc,na,b,c) as x ->
-      let bl,c = extract_prod_binders c in
-      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
-  | CProdN (loc,[],c) ->
-      extract_prod_binders c
-  | CProdN (loc,(nal,bk,t)::bl,c) ->
-      let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
-      LocalRawAssum (nal,bk,t) :: bl, c
-  | c -> [], c
-
-let rec extract_lam_binders = function
-(*  | CLetIn (loc,na,b,c) as x ->
-      let bl,c = extract_lam_binders c in
-      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
-  | CLambdaN (loc,[],c) ->
-      extract_lam_binders c
-  | CLambdaN (loc,(nal,bk,t)::bl,c) ->
-      let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
-      LocalRawAssum (nal,bk,t) :: bl, c
-  | c -> [], c
-
-let split_lambda = function
-  | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c)
-  | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
-  | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c))
-  | _ -> anomaly "ill-formed fixpoint body"
-
-let rename na na' t c =
-  match (na,na') with
-    | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c)
-    | (_,Name id), (_,Anonymous) -> (na,t,c)
-    | _ -> (na',t,c)
-
-let split_product na' = function
-  | CArrow (loc,t,c) -> (na',t,c)
-  | CProdN (loc,[[na],bk,t],c) -> rename na na' t c
-  | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
-  | CProdN (loc,(na::nal,bk,t)::bl,c) ->
-      rename na na' t (CProdN(loc,(nal,bk,t)::bl,c))
-  | _ -> anomaly "ill-formed fixpoint body"
-
-let rec split_fix n typ def =
-  if n = 0 then ([],typ,def)
-  else
-    let (na,_,def) = split_lambda def in
-    let (na,t,typ) = split_product na typ in
-    let (bl,typ,def) = split_fix (n-1) typ def in
-    (LocalRawAssum ([na],default_binder_kind,t)::bl,typ,def)
-
-let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
-  let pr_body =
-    if dangling_with_for then pr_dangling else pr in
-  pr_id id ++ str" " ++
-  hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++
-  pr_opt_type_spc pr t ++ str " :=" ++
-  pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
-
-let pr_guard_annot pr_aux bl (n,ro) =
-  match n with
-    | None -> mt ()
-    | Some (loc, id) ->
-      match (ro : Topconstr.recursion_order_expr) with
-	| CStructRec ->
-	  let names_of_binder = function
-	    | LocalRawAssum (nal,_,_) -> nal
-	    | LocalRawDef (_,_) -> []
-	  in let ids = List.flatten (List.map names_of_binder bl) in
-	     if List.length ids > 1 then
-	       spc() ++ str "{struct " ++ pr_id id ++ str"}"
-	     else mt()
-	| CWfRec c ->
-	  spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}"
-	| CMeasureRec (m,r) ->
-	  spc() ++ str "{measure " ++ pr_aux m ++ spc() ++ pr_id id++
-	    (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}"
-
-let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) =
-  let annot = pr_guard_annot (pr lsimpleconstr) bl ro in
-    pr_recursive_decl pr prd dangling_with_for id bl annot t c
-
-let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =
-  pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
-
-let pr_recursive pr_decl id = function
-  | [] -> anomaly "(co)fixpoint with no definition"
-  | [d1] -> pr_decl false d1
-  | dl ->
-      prlist_with_sep (fun () -> fnl() ++ str "with ")
-        (pr_decl true) dl ++
-      fnl() ++ str "for " ++ pr_id id
-
-let pr_asin pr (na,indnalopt) =
-  (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
-    | Some na -> spc () ++ str "as " ++  pr_lname na
-    | None -> mt ()) ++
-  (match indnalopt with
-    | None -> mt ()
-    | Some t -> spc () ++ str "in " ++ pr lsimpleconstr t)
-
-let pr_case_item pr (tm,asin) =
-  hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
-
-let pr_case_type pr po =
-  match po with
-    | None | Some (CHole _) -> mt()
-    | Some p ->
-        spc() ++ hov 2 (str "return" ++ pr_sep_com spc (pr lsimpleconstr) p)
-
-let pr_simple_return_type pr na po =
-  (match na with
-    | Some (_,Name id) ->
-        spc () ++ str "as " ++  pr_id id
-    | _ -> mt ()) ++
-  pr_case_type pr po
-
-let pr_proj pr pr_app a f l =
-  hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
-
-let pr_appexpl pr f l =
-      hov 2 (
-	str "@" ++ pr_reference f ++
-	prlist (pr_sep_com spc (pr (lapp,L))) l)
-
-let pr_app pr a l =
-  hov 2 (
-    pr (lapp,L) a  ++
-    prlist (fun a -> spc () ++ pr_expl_args pr a) l)
-
-let pr_forall () = str"forall" ++ spc ()
-
-let pr_fun () = str"fun" ++ spc ()
-
-let pr_fun_sep = str " =>"
-
-
-let pr_dangling_with_for sep pr inherited a =
-  match a with
-  | (CFix (_,_,[_])|CCoFix(_,_,[_])) -> pr sep (latom,E) a
-  | _ -> pr sep inherited a
-
-let pr pr sep inherited a =
-  let (strm,prec) = match a with
-  | CRef r -> pr_reference r, latom
-  | CFix (_,id,fix) ->
-      hov 0 (str"fix " ++
-             pr_recursive
-               (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix),
-      lfix
-  | CCoFix (_,id,cofix) ->
-      hov 0 (str "cofix " ++
-             pr_recursive
-              (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix),
-      lfix
-  | CArrow (_,a,b) ->
-      hov 0 (pr mt (larrow,L) a ++ str " ->" ++
-             pr (fun () ->brk(1,0)) (-larrow,E) b),
-      larrow
-  | CProdN _ ->
-      let (bl,a) = extract_prod_binders a in
-      hov 0 (
-	hov 2 (pr_delimited_binders pr_forall spc
-                 (pr mt ltop) bl) ++
-        str "," ++ pr spc ltop a),
-      lprod
-  | CLambdaN _ ->
-      let (bl,a) = extract_lam_binders a in
-      hov 0 (
-        hov 2 (pr_delimited_binders pr_fun spc
-                (pr mt ltop) bl) ++
-	       pr_fun_sep ++ pr spc ltop a),
-      llambda
-  | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
-      when x=x' ->
-      hv 0 (
-        hov 2 (str "let " ++ pr mt ltop fx ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CLetIn (_,x,a,b) ->
-      hv 0 (
-        hov 2 (str "let " ++ pr_lname x ++ str " :=" ++
-               pr spc ltop a ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CAppExpl (_,(Some i,f),l) ->
-      let l1,l2 = list_chop i l in
-      let c,l1 = list_sep_last l1 in
-      let p = pr_proj (pr mt) pr_appexpl c f l1 in
-      if l2<>[] then
-	p ++ prlist (pr spc (lapp,L)) l2, lapp
-      else
-	p, lproj
-  | CAppExpl (_,(None,Ident (_,var)),[t])
-  | CApp (_,(_,CRef(Ident(_,var))),[t,None])
-        when var = Topconstr.ldots_var ->
-      hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), larg
-  | CAppExpl (_,(None,f),l) -> pr_appexpl (pr mt) f l, lapp
-  | CApp (_,(Some i,f),l) ->
-      let l1,l2 = list_chop i l in
-      let c,l1 = list_sep_last l1 in
-      assert (snd c = None);
-      let p = pr_proj (pr mt) pr_app (fst c) f l1 in
-      if l2<>[] then
-	p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp
-      else
-	p, lproj
-  | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp
-  | CRecord (_,w,l) ->
-      let beg =
-	match w with
-	| None -> spc ()
-	| Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc ()
-      in
-	hv 0 (str"{|" ++ beg ++
-	      prlist_with_sep pr_semicolon
-		(fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l
-	      ++ str" |}"), latom
-
-  | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
-      hv 0 (
-	str "let '" ++
-	  hov 0 (pr_patt ltop p ++
-		 pr_asin (pr_dangling_with_for mt pr) asin ++
-		 str " :=" ++ pr spc ltop c ++
-		 pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++
-		 str " in" ++ pr spc ltop b)),
-	lletpattern
-  | CCases(_,_,rtntypopt,c,eqns) ->
-      v 0
-        (hv 0 (str "match" ++ brk (1,2) ++
-		  hov 0 (
-		    prlist_with_sep sep_v
-		      (pr_case_item (pr_dangling_with_for mt pr)) c
-		    ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt) ++
-		  spc () ++ str "with") ++
-		  prlist (pr_eqn (pr mt)) eqns ++ spc() ++ str "end"),
-      latom
-  | CLetTuple (_,nal,(na,po),c,b) ->
-      hv 0 (
-        str "let " ++
-	hov 0 (str "(" ++
-               prlist_with_sep sep_v pr_lname nal ++
-               str ")" ++
-	       pr_simple_return_type (pr mt) na po ++ str " :=" ++
-               pr spc ltop c ++ str " in") ++
-        pr spc ltop b),
-      lletin
-  | CIf (_,c,(na,po),b1,b2) ->
-      (* On force les parenthèses autour d'un "if" sous-terme (même si le
-	 parsing est lui plus tolérant) *)
-      hv 0 (
-	hov 1 (str "if " ++ pr mt ltop c ++ pr_simple_return_type (pr mt) na po) ++
-	spc () ++
-	hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
-	hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
-      lif
-
-  | CHole _ -> str "_", latom
-  | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom
-  | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom
-  | CSort (_,s) -> pr_glob_sort s, latom
-  | CCast (_,a,CastConv (k,b)) ->
-      let s = match k with VMcast -> "<:" | DEFAULTcast | REVERTcast -> ":" in
-      hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b),
-      lcast
-  | CCast (_,a,CastCoerce) ->
-      hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"),
-      lcast
-  | CNotation (_,"( _ )",([t],[],[])) ->
-      pr (fun()->str"(") (max_int,L) t ++ str")", latom
-  | CNotation (_,s,env) ->
-      pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env
-  | CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt ltop c), latom
-  | CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
-  | CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt (ldelim,E) a), ldelim
-  in
-  let loc = constr_loc a in
-  pr_with_comments loc
-    (sep() ++ if prec_less prec inherited then strm else surround strm)
-
-type term_pr = {
-  pr_constr_expr   : constr_expr -> std_ppcmds;
-  pr_lconstr_expr  : constr_expr -> std_ppcmds;
-  pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
-  pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
-}
-
-type precedence =  Ppextend.precedence * Ppextend.parenRelation
-let modular_constr_pr = pr
-let rec fix rf x =rf (fix rf) x
-let pr = fix modular_constr_pr mt
-
-let pr_simpleconstr = function
-  | CAppExpl (_,(None,f),[]) -> str "@" ++ pr_reference f
-  | c -> pr lsimpleconstr c
-
-let default_term_pr = {
-  pr_constr_expr   = pr_simpleconstr;
-  pr_lconstr_expr  = pr ltop;
-  pr_constr_pattern_expr  = pr_simpleconstr;
-  pr_lconstr_pattern_expr = pr ltop
-}
-
-let term_pr = ref default_term_pr
-
-let set_term_pr = (:=) term_pr
-
-let pr_constr_expr c   = !term_pr.pr_constr_expr   c
-let pr_lconstr_expr c  = !term_pr.pr_lconstr_expr  c
-let pr_constr_pattern_expr c  = !term_pr.pr_constr_pattern_expr  c
-let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c
-
-let pr_cases_pattern_expr = pr_patt ltop
-
-let pr_binders = pr_undelimited_binders spc (pr ltop)
-
-let pr_with_occurrences pr occs =
-  match occs with
-    ((false,[]),c) -> pr c
-  | ((nowhere_except_in,nl),c) ->
-      hov 1 (pr c ++ spc() ++ str"at " ++
-        (if nowhere_except_in then mt() else str "- ") ++
-        hov 0 (prlist_with_sep spc (pr_or_var int) nl))
-
-let pr_red_flag pr r =
-  (if r.rBeta then pr_arg str "beta" else mt ()) ++
-  (if r.rIota then pr_arg str "iota" else mt ()) ++
-  (if r.rZeta then pr_arg str "zeta" else mt ()) ++
-  (if r.rConst = [] then
-     if r.rDelta then pr_arg str "delta"
-     else mt ()
-   else
-     pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
-     hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
-
-open Genarg
-
-let pr_metaid id = str"?" ++ pr_id id
-
-let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function
-  | Red false -> str "red"
-  | Hnf -> str "hnf"
-  | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_pattern) o
-  | Cbv f ->
-      if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then
-	str "compute"
-      else
-	hov 1 (str "cbv" ++ pr_red_flag pr_ref f)
-  | Lazy f ->
-      hov 1 (str "lazy" ++ pr_red_flag pr_ref f)
-  | Unfold l ->
-      hov 1 (str "unfold" ++ spc() ++
-             prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l)
-  | Fold l -> hov 1 (str "fold" ++ prlist (pr_arg pr_constr) l)
-  | Pattern l ->
-      hov 1 (str "pattern" ++
-        pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l)
-
-  | Red true -> error "Shouldn't be accessible from user."
-  | ExtraRedExpr s -> str s
-  | CbvVm -> str "vm_compute"
-
-let rec pr_may_eval test prc prlc pr2 pr3 = function
-  | ConstrEval (r,c) ->
-      hov 0
-        (str "eval" ++ brk (1,1) ++
-         pr_red_expr (prc,prlc,pr2,pr3) r ++
-	 str " in" ++ spc() ++ prc c)
-  | ConstrContext ((_,id),c) ->
-      hov 0
-	(str "context " ++ pr_id id ++ spc () ++
-	 str "[" ++ prlc c ++ str "]")
-  | ConstrTypeOf c -> hov 1 (str "type of" ++ spc() ++ prc c)
-  | ConstrTerm c when test c -> h 0 (str "(" ++ prc c ++ str ")")
-  | ConstrTerm c -> prc c
-
-let pr_may_eval a = pr_may_eval (fun _ -> false) a
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
deleted file mode 100644
index bc3a6668..00000000
--- a/parsing/ppconstr.mli
+++ /dev/null
@@ -1,102 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Environ
-open Term
-open Libnames
-open Pcoq
-open Glob_term
-open Topconstr
-open Names
-open Util
-open Genarg
-
-val extract_lam_binders :
-  constr_expr -> local_binder list * constr_expr
-val extract_prod_binders :
-  constr_expr -> local_binder list * constr_expr
-val split_fix :
-  int -> constr_expr -> constr_expr ->
-  local_binder list *  constr_expr * constr_expr
-
-val prec_less : int -> int * Ppextend.parenRelation -> bool
-
-val pr_tight_coma : unit -> std_ppcmds
-
-val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
-val pr_metaid : identifier -> std_ppcmds
-
-val pr_lident : identifier located -> std_ppcmds
-val pr_lname : name located -> std_ppcmds
-
-val pr_with_comments : loc -> std_ppcmds -> std_ppcmds
-val pr_com_at : int -> std_ppcmds
-val pr_sep_com :
-  (unit -> std_ppcmds) ->
-  (constr_expr -> std_ppcmds) ->
-  constr_expr -> std_ppcmds
-
-val pr_id : identifier -> std_ppcmds
-val pr_name : name -> std_ppcmds
-val pr_qualid : qualid -> std_ppcmds
-val pr_patvar : patvar -> std_ppcmds
-
-val pr_with_occurrences :
-  ('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds
-val pr_red_expr :
-  ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
-  ('a,'b,'c) red_expr_gen -> std_ppcmds
-val pr_may_eval :
-  ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
-  ('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds
-
-val pr_glob_sort : glob_sort -> std_ppcmds
-val pr_guard_annot : (constr_expr -> std_ppcmds) ->
-  local_binder list ->
-  ('a * Names.identifier) option * recursion_order_expr ->
-  std_ppcmds
-
-val pr_binders : local_binder list -> std_ppcmds
-val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
-val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
-val pr_constr_expr : constr_expr -> std_ppcmds
-val pr_lconstr_expr : constr_expr -> std_ppcmds
-val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
-
-type term_pr = {
-  pr_constr_expr   : constr_expr -> std_ppcmds;
-  pr_lconstr_expr  : constr_expr -> std_ppcmds;
-  pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
-  pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
-}
-
-val set_term_pr : term_pr -> unit
-val default_term_pr : term_pr
-
-(** The modular constr printer.
-    [modular_constr_pr pr s p t] prints the head of the term [t] and calls
-    [pr] on its subterms.
-    [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
-    and [ltop] for "lconstr" printers (spiwack: we might need more
-    specification here).
-    We can make a new modular constr printer by overriding certain branches,
-    for instance if we want to build a printer which prints "Prop" as "Omega"
-    instead we can proceed as follows:
-    let my_modular_constr_pr pr s p = function
-      | CSort (_,GProp Null) -> str "Omega"
-      | t -> modular_constr_pr pr s p t
-    Which has the same type. We can turn a modular printer into a printer by
-    taking its fixpoint. *)
-
-type precedence
-val lsimpleconstr : precedence
-val ltop : precedence
-val modular_constr_pr :
-               ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
-                (unit->std_ppcmds) -> precedence  -> constr_expr -> std_ppcmds
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
deleted file mode 100644
index fa573c8a..00000000
--- a/parsing/pptactic.ml
+++ /dev/null
@@ -1,1072 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Names
-open Namegen
-open Util
-open Tacexpr
-open Glob_term
-open Topconstr
-open Genarg
-open Libnames
-open Pattern
-open Ppextend
-open Ppconstr
-open Printer
-
-let pr_global x = Nametab.pr_global_env Idset.empty x
-
-type grammar_terminals = string option list
-
-  (* Extensions *)
-let prtac_tab = Hashtbl.create 17
-
-let declare_extra_tactic_pprule (s,tags,prods) =
-  Hashtbl.add prtac_tab (s,tags) prods
-
-let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags)
-
-type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) ->
-    (constr_expr -> std_ppcmds) ->
-    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a glob_extra_genarg_printer =
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) ->
-    (Term.constr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-let genarg_pprule = ref Stringmap.empty
-
-let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) =
-  let s = match unquote wit with
-    | ExtraArgType s -> s
-    | _ -> error
-	"Can declare a pretty-printing rule only for extra argument types."
-  in
-  let f prc prlc prtac x = f prc prlc prtac (out_gen rawwit x) in
-  let g prc prlc prtac x = g prc prlc prtac (out_gen globwit x) in
-  let h prc prlc prtac x = h prc prlc prtac (out_gen wit x) in
-  genarg_pprule := Stringmap.add s (f,g,h) !genarg_pprule
-
-let pr_arg pr x = spc () ++ pr x
-
-let pr_or_var pr = function
-  | ArgArg x -> pr x
-  | ArgVar (_,s) -> pr_id s
-
-let pr_or_metaid pr = function
-  | AI x -> pr x
-  | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable"
-
-let pr_and_short_name pr (c,_) = pr c
-
-let pr_or_by_notation f = function
-  | AN v -> f v
-  | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
-
-let pr_located pr (loc,x) = pr x
-
-let pr_evaluable_reference = function
-  | EvalVarRef id -> pr_id id
-  | EvalConstRef sp -> pr_global (Libnames.ConstRef sp)
-
-let pr_quantified_hypothesis = function
-  | AnonHyp n -> int n
-  | NamedHyp id -> pr_id id
-
-let pr_binding prc = function
-  | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
-
-let pr_bindings prc prlc = function
-  | ImplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-      prlist_with_sep spc prc l
-  | ExplicitBindings l ->
-      brk (1,1) ++ str "with" ++ brk (1,1) ++
-        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | NoBindings -> mt ()
-
-let pr_bindings_no_with prc prlc = function
-  | ImplicitBindings l ->
-      brk (1,1) ++
-      prlist_with_sep spc prc l
-  | ExplicitBindings l ->
-      brk (1,1) ++
-        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | NoBindings -> mt ()
-
-let pr_with_bindings prc prlc (c,bl) =
-  prc c ++ hv 0 (pr_bindings prc prlc bl)
-
-let pr_with_constr prc = function
-  | None -> mt ()
-  | Some c -> spc () ++ hov 1 (str "with" ++ spc () ++ prc c)
-
-let rec pr_message_token prid = function
-  | MsgString s -> qs s
-  | MsgInt n -> int n
-  | MsgIdent id -> prid id
-
-let pr_fresh_ids = prlist (fun s -> spc() ++ pr_or_var qs s)
-
-let with_evars ev s = if ev then "e" ^ s else s
-
-let if_pattern_ident b pr c = (if b then str "?" else mt()) ++ pr c
-
-let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) =
-  match Genarg.genarg_tag x with
-  | BoolArgType -> str (if out_gen rawwit_bool x then "true" else "false")
-  | IntArgType -> int (out_gen rawwit_int x)
-  | IntOrVarArgType -> pr_or_var pr_int (out_gen rawwit_int_or_var x)
-  | StringArgType -> str "\"" ++ str (out_gen rawwit_string x) ++ str "\""
-  | PreIdentArgType -> str (out_gen rawwit_pre_ident x)
-  | IntroPatternArgType -> pr_intro_pattern (out_gen rawwit_intro_pattern x)
-  | IdentArgType b -> if_pattern_ident b pr_id (out_gen rawwit_ident x)
-  | VarArgType -> pr_located pr_id (out_gen rawwit_var x)
-  | RefArgType -> prref (out_gen rawwit_ref x)
-  | SortArgType -> pr_glob_sort (out_gen rawwit_sort x)
-  | ConstrArgType -> prc (out_gen rawwit_constr x)
-  | ConstrMayEvalArgType ->
-      pr_may_eval prc prlc (pr_or_by_notation prref) prpat
-        (out_gen rawwit_constr_may_eval x)
-  | QuantHypArgType -> pr_quantified_hypothesis (out_gen rawwit_quant_hyp x)
-  | RedExprArgType ->
-      pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat)
-        (out_gen rawwit_red_expr x)
-  | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (rawwit_open_constr_gen (b1,b2)) x))
-  | ConstrWithBindingsArgType ->
-      pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x)
-  | BindingsArgType ->
-      pr_bindings_no_with prc prlc (out_gen rawwit_bindings x)
-  | List0ArgType _ ->
-      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
-	(fold_list0 (fun a l -> a::l) x []))
-  | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
-	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_raw_generic prc prlc prtac prpat prref) (mt()) x)
-  | PairArgType _ ->
-      hov 0
-        (fold_pair
-	  (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prpat prref)
-            [a;b])
-	  x)
-  | ExtraArgType s ->
-      try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x
-      with Not_found -> str "[no printer for " ++ str s ++ str "]"
-
-
-let rec pr_glob_generic prc prlc prtac prpat x =
-  match Genarg.genarg_tag x with
-  | BoolArgType -> str (if out_gen globwit_bool x then "true" else "false")
-  | IntArgType -> int (out_gen globwit_int x)
-  | IntOrVarArgType -> pr_or_var pr_int (out_gen globwit_int_or_var x)
-  | StringArgType -> str "\"" ++ str (out_gen globwit_string x) ++ str "\""
-  | PreIdentArgType -> str (out_gen globwit_pre_ident x)
-  | IntroPatternArgType -> pr_intro_pattern (out_gen globwit_intro_pattern x)
-  | IdentArgType b -> if_pattern_ident b pr_id (out_gen globwit_ident x)
-  | VarArgType -> pr_located pr_id (out_gen globwit_var x)
-  | RefArgType -> pr_or_var (pr_located pr_global) (out_gen globwit_ref x)
-  | SortArgType -> pr_glob_sort (out_gen globwit_sort x)
-  | ConstrArgType -> prc (out_gen globwit_constr x)
-  | ConstrMayEvalArgType ->
-      pr_may_eval prc prlc
-        (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat
-        (out_gen globwit_constr_may_eval x)
-  | QuantHypArgType ->
-      pr_quantified_hypothesis (out_gen globwit_quant_hyp x)
-  | RedExprArgType ->
-      pr_red_expr
-        (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat)
-        (out_gen globwit_red_expr x)
-  | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (globwit_open_constr_gen (b1,b2)) x))
-  | ConstrWithBindingsArgType ->
-      pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x)
-  | BindingsArgType ->
-      pr_bindings_no_with prc prlc (out_gen globwit_bindings x)
-  | List0ArgType _ ->
-      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat)
-	(fold_list0 (fun a l -> a::l) x []))
-  | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_glob_generic prc prlc prtac prpat)
-	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_glob_generic prc prlc prtac prpat) (mt()) x)
-  | PairArgType _ ->
-      hov 0
-        (fold_pair
-	  (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac prpat) [a;b])
-	  x)
-  | ExtraArgType s ->
-      try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x
-      with Not_found -> str "[no printer for " ++ str s ++ str "]"
-
-open Closure
-
-let rec pr_generic prc prlc prtac prpat x =
-  match Genarg.genarg_tag x with
-  | BoolArgType -> str (if out_gen wit_bool x then "true" else "false")
-  | IntArgType -> int (out_gen wit_int x)
-  | IntOrVarArgType -> pr_or_var pr_int (out_gen wit_int_or_var x)
-  | StringArgType -> str "\"" ++ str (out_gen wit_string x) ++ str "\""
-  | PreIdentArgType -> str (out_gen wit_pre_ident x)
-  | IntroPatternArgType -> pr_intro_pattern (out_gen wit_intro_pattern x)
-  | IdentArgType b -> if_pattern_ident b pr_id (out_gen wit_ident x)
-  | VarArgType -> pr_id (out_gen wit_var x)
-  | RefArgType -> pr_global (out_gen wit_ref x)
-  | SortArgType -> pr_sort (out_gen wit_sort x)
-  | ConstrArgType -> prc (out_gen wit_constr x)
-  | ConstrMayEvalArgType -> prc (out_gen wit_constr_may_eval x)
-  | QuantHypArgType -> pr_quantified_hypothesis (out_gen wit_quant_hyp x)
-  | RedExprArgType ->
-      pr_red_expr (prc,prlc,pr_evaluable_reference,prpat)
-        (out_gen wit_red_expr x)
-  | OpenConstrArgType (b1,b2) -> prc (snd (out_gen (wit_open_constr_gen (b1,b2)) x))
-  | ConstrWithBindingsArgType ->
-      let (c,b) = (out_gen wit_constr_with_bindings x).Evd.it in
-      pr_with_bindings prc prlc (c,b)
-  | BindingsArgType ->
-      pr_bindings_no_with prc prlc (out_gen wit_bindings x).Evd.it
-  | List0ArgType _ ->
-      hov 0 (pr_sequence (pr_generic prc prlc prtac prpat)
-	(fold_list0 (fun a l -> a::l) x []))
-  | List1ArgType _ ->
-      hov 0 (pr_sequence (pr_generic prc prlc prtac prpat)
-	(fold_list1 (fun a l -> a::l) x []))
-  | OptArgType _ -> hov 0 (fold_opt (pr_generic prc prlc prtac prpat) (mt()) x)
-  | PairArgType _ ->
-      hov 0
-        (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac prpat)
-          [a;b])
-	  x)
-  | ExtraArgType s ->
-      try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x
-      with Not_found -> str "[no printer for " ++ str s ++ str "]"
-
-let rec tacarg_using_rule_token pr_gen = function
-  | Some s :: l, al -> str s :: tacarg_using_rule_token pr_gen (l,al)
-  | None :: l, a :: al ->
-      let print_it =
-        match genarg_tag a with
-        | OptArgType _ -> fold_opt (fun _ -> true) false a
-        | _ -> true
-      in
-      let r = tacarg_using_rule_token pr_gen (l,al) in
-      if print_it then pr_gen a :: r else r
-  | [], [] -> []
-  | _ -> failwith "Inconsistent arguments of extended tactic"
-
-let pr_tacarg_using_rule pr_gen l=
-  pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l)
-
-let pr_extend_gen pr_gen lev s l =
-  try
-    let tags = List.map genarg_tag l in
-    let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
-    let p = pr_tacarg_using_rule pr_gen (pl,l) in
-    if lev' > lev then surround p else p
-  with Not_found ->
-    str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)"
-
-let pr_raw_extend prc prlc prtac prpat =
-  pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
-let pr_glob_extend prc prlc prtac prpat =
-  pr_extend_gen (pr_glob_generic prc prlc prtac prpat)
-let pr_extend prc prlc prtac prpat =
-  pr_extend_gen (pr_generic prc prlc prtac prpat)
-
-(**********************************************************************)
-(* The tactic printer                                                 *)
-
-let strip_prod_binders_expr n ty =
-  let rec strip_ty acc n ty =
-    match ty with
-        Topconstr.CProdN(_,bll,a) ->
-          let nb =
-            List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
-	  let bll = List.map (fun (x, _, y) -> x, y) bll in
-            if nb >= n then (List.rev (bll@acc)), a
-            else strip_ty (bll@acc) (n-nb) a
-      | Topconstr.CArrow(_,a,b) ->
-          if n=1 then
-            (List.rev (([(dummy_loc,Anonymous)],a)::acc), b)
-          else strip_ty (([(dummy_loc,Anonymous)],a)::acc) (n-1) b
-      | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-let pr_ltac_or_var pr = function
-  | ArgArg x -> pr x
-  | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
-
-let pr_ltac_constant sp =
-  pr_qualid (Nametab.shortest_qualid_of_tactic sp)
-
-let pr_evaluable_reference_env env = function
-  | EvalVarRef id -> pr_id id
-  | EvalConstRef sp ->
-      Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp)
-
-let pr_esubst prc l =
-  let pr_qhyp = function
-      (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
-    | (_,NamedHyp id,c) ->
-        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
-  in
-  prlist_with_sep spc pr_qhyp l
-
-let pr_bindings_gen for_ex prlc prc = function
-  | ImplicitBindings l ->
-      spc () ++
-      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
-            prlist_with_sep spc prc l)
-  | ExplicitBindings l ->
-      spc () ++
-      hv 2 ((if for_ex then mt() else str "with" ++ spc ()) ++
-            pr_esubst prlc l)
-  | NoBindings -> mt ()
-
-let pr_bindings prlc prc = pr_bindings_gen false prlc prc
-
-let pr_with_bindings prlc prc (c,bl) =
-  hov 1 (prc c ++ pr_bindings prlc prc bl)
-
-let pr_as_ipat pat = str "as " ++ pr_intro_pattern pat
-let pr_eqn_ipat pat = str "eqn:" ++ pr_intro_pattern pat
-
-let pr_with_induction_names = function
-  | None, None -> mt ()
-  | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat)
-  | None, Some ipat -> spc () ++ hov 1 (pr_as_ipat ipat)
-  | Some eqpat, Some ipat ->
-    spc () ++ hov 1 (pr_as_ipat ipat ++ spc () ++ pr_eqn_ipat eqpat)
-
-let pr_as_intro_pattern ipat =
-  spc () ++ hov 1 (str "as" ++ spc () ++ pr_intro_pattern ipat)
-
-let pr_with_inversion_names = function
-  | None -> mt ()
-  | Some ipat -> pr_as_intro_pattern ipat
-
-let pr_as_ipat = function
-  | None -> mt ()
-  | Some ipat -> pr_as_intro_pattern ipat
-
-let pr_as_name = function
-  | Anonymous -> mt ()
-  | Name id -> str " as " ++ pr_lident (dummy_loc,id)
-
-let pr_pose_as_style prc na c =
-  spc() ++ prc c ++ pr_as_name na
-
-let pr_pose prlc prc na c = match na with
-  | Anonymous -> spc() ++ prc c
-  | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
-
-let pr_assertion _prlc prc ipat c = match ipat with
-(* Use this "optimisation" or use only the general case ?
-  | IntroIdentifier id ->
-      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
-*)
-  | ipat ->
-      spc() ++ prc c ++ pr_as_ipat ipat
-
-let pr_assumption prlc prc ipat c = match ipat with
-(* Use this "optimisation" or use only the general case ?
-  | IntroIdentifier id ->
-      spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
-*)
-  | ipat ->
-      spc() ++ prc c ++ pr_as_ipat ipat
-
-let pr_by_tactic prt = function
-  | TacId [] -> mt ()
-  | tac -> spc() ++ str "by " ++ prt tac
-
-let pr_hyp_location pr_id = function
-  | occs, Termops.InHyp -> spc () ++ pr_with_occurrences pr_id occs
-  | occs, Termops.InHypTypeOnly ->
-      spc () ++
-      pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs
-  | occs, Termops.InHypValueOnly ->
-      spc () ++
-      pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs
-
-let pr_in pp = spc () ++ hov 0 (str "in" ++ pp)
-
-let pr_simple_hyp_clause pr_id = function
-  | [] -> mt ()
-  | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
-
-let pr_in_hyp_as pr_id = function
-  | None -> mt ()
-  | Some (id,ipat) -> pr_simple_hyp_clause pr_id [id] ++ pr_as_ipat ipat
-
-let pr_clauses default_is_concl pr_id = function
-  | { onhyps=Some []; concl_occs=occs }
-      when occs = all_occurrences_expr & default_is_concl = Some true -> mt ()
-  | { onhyps=None; concl_occs=occs }
-      when occs = all_occurrences_expr & default_is_concl = Some false -> mt ()
-  | { onhyps=None; concl_occs=occs } ->
-      if occs = no_occurrences_expr then pr_in (str " * |-")
-      else pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
-  | { onhyps=Some l; concl_occs=occs } ->
-      pr_in
-        (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++
-	 (if occs = no_occurrences_expr then mt ()
-	  else pr_with_occurrences (fun () -> str" |- *") (occs,())))
-
-let pr_orient b = if b then mt () else str "<- "
-
-let pr_multi = function
-  | Precisely 1 -> mt ()
-  | Precisely n -> pr_int n ++ str "!"
-  | UpTo n -> pr_int n ++ str "?"
-  | RepeatStar -> str "?"
-  | RepeatPlus -> str "!"
-
-let pr_induction_arg prlc prc = function
-  | ElimOnConstr c -> pr_with_bindings prlc prc c
-  | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
-  | ElimOnAnonHyp n -> int n
-
-let pr_induction_kind = function
-  | SimpleInversion -> str "simple inversion"
-  | FullInversion -> str "inversion"
-  | FullInversionClear -> str "inversion_clear"
-
-let pr_lazy lz = if lz then str "lazy" else mt ()
-
-let pr_match_pattern pr_pat = function
-  | Term a -> pr_pat a
-  | Subterm (b,None,a) -> (if b then str"appcontext [" else str "context [") ++ pr_pat a ++ str "]"
-  | Subterm (b,Some id,a) ->
-      (if b then str"appcontext " else str "context ") ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
-
-let pr_match_hyps pr_pat = function
-  | Hyp (nal,mp) ->
-      pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
-  | Def (nal,mv,mp) ->
-      pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv
-      ++ str ":" ++ pr_match_pattern pr_pat mp
-
-let pr_match_rule m pr pr_pat = function
-  | Pat ([],mp,t) when m ->
-      pr_match_pattern pr_pat mp ++
-      spc () ++ str "=>" ++ brk (1,4) ++ pr t
-(*
-  | Pat (rl,mp,t) ->
-      hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++
-        (if rl <> [] then spc () else mt ()) ++
-         hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
-	 str "=>" ++ brk (1,4) ++ pr t))
-*)
-  | Pat (rl,mp,t) ->
-      hov 0 (
-	hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++
-        (if rl <> [] then spc () else mt ()) ++
-        hov 0 (
-	  str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
-	  str "=>" ++ brk (1,4) ++ pr t))
-  | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
-
-let pr_funvar = function
-  | None -> spc () ++ str "_"
-  | Some id -> spc () ++ pr_id id
-
-let pr_let_clause k pr (id,(bl,t)) =
-  hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++
-         str " :=" ++ brk (1,1) ++ pr (TacArg (dummy_loc,t)))
-
-let pr_let_clauses recflag pr = function
-  | hd::tl ->
-      hv 0
-        (pr_let_clause (if recflag then "let rec " else "let ") pr hd ++
-         prlist (fun t -> spc () ++ pr_let_clause "with " pr t) tl)
-  | [] -> anomaly "LetIn must declare at least one binding"
-
-let pr_seq_body pr tl =
-  hv 0 (str "[ " ++
-        prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
-        str " ]")
-
-let pr_opt_tactic pr = function
-  | TacId [] -> mt ()
-  | t -> pr t
-
-let pr_then_gen pr tf tm tl =
-  hv 0 (str "[ " ++
-        prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++
-	pr_opt_tactic pr tm ++ str ".." ++
-	prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl ++
-        str " ]")
-
-let pr_hintbases = function
-  | None -> spc () ++ str "with *"
-  | Some [] -> mt ()
-  | Some l ->
-      spc () ++ hov 2 (str "with" ++ prlist (fun s -> spc () ++ str s) l)
-
-let pr_auto_using prc = function
-  | [] -> mt ()
-  | l -> spc () ++
-      hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
-
-let string_of_debug = function
-  | Off -> ""
-  | Debug -> "debug "
-  | Info -> "info_"
-
-let pr_then () = str ";"
-
-let ltop = (5,E)
-let lseq = 4
-let ltactical = 3
-let lorelse = 2
-let llet = 5
-let lfun = 5
-let lcomplete = 1
-let labstract = 3
-let lmatch = 1
-let latom = 0
-let lcall = 1
-let leval = 1
-let ltatom = 1
-let linfo = 5
-
-let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
-
-open Closure
-
-(** A printer for tactics that polymorphically works on the three
-    "raw", "glob" and "typed" levels; in practice, the environment is
-    used only at the glob and typed level: it is used to feed the
-    constr printers *)
-
-let make_pr_tac
-  (pr_tac_level,pr_constr,pr_lconstr,pr_pat,
-   pr_cst,pr_ind,pr_ref,pr_ident,
-   pr_extend,strip_prod_binders) env =
-
-(* The environment is not used by the tactic printer: it is passed to the
-   constr and cst printers; hence we can make some abbreviations *)
-let pr_constr = pr_constr env in
-let pr_lconstr = pr_lconstr env in
-let pr_lpat = pr_pat true in
-let pr_pat = pr_pat false in
-let pr_cst = pr_cst env in
-let pr_ind = pr_ind env in
-let pr_tac_level = pr_tac_level env in
-
-(* Other short cuts *)
-let pr_bindings = pr_bindings pr_lconstr pr_constr in
-let pr_ex_bindings = pr_bindings_gen true pr_lconstr pr_constr in
-let pr_with_bindings = pr_with_bindings pr_lconstr pr_constr in
-let pr_extend = pr_extend pr_constr pr_lconstr pr_tac_level pr_pat in
-let pr_red_expr = pr_red_expr (pr_constr,pr_lconstr,pr_cst,pr_pat) in
-
-let pr_constrarg c = spc () ++ pr_constr c in
-let pr_lconstrarg c = spc () ++ pr_lconstr c in
-let pr_intarg n = spc () ++ int n in
-
-(* Some printing combinators *)
-let pr_eliminator cb = str "using" ++ pr_arg pr_with_bindings cb in
-
-let extract_binders = function
-  | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
-  | body -> ([],body) in
-
-let pr_binder_fix (nal,t) =
-(*  match t with
-  | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
-  | _ ->*)
-    let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr_lconstr t in
-    spc() ++ hov 1 (str"(" ++ s ++ str")") in
-
-let pr_fix_tac (id,n,c) =
-  let rec set_nth_name avoid n = function
-      (nal,ty)::bll ->
-        if n <= List.length nal then
-          match list_chop (n-1) nal with
-              _, (_,Name id) :: _ -> id, (nal,ty)::bll
-            | bef, (loc,Anonymous) :: aft ->
-                let id = next_ident_away (id_of_string"y") avoid in
-                id, ((bef@(loc,Name id)::aft, ty)::bll)
-            | _ -> assert false
-        else
-          let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
-          (id,(nal,ty)::bll')
-    | [] -> assert false in
-  let (bll,ty) = strip_prod_binders n c in
-  let names =
-    List.fold_left
-      (fun ln (nal,_) -> List.fold_left
-          (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
-          ln nal)
-      [] bll in
-  let idarg,bll = set_nth_name names n bll in
-  let annot =
-    if List.length names = 1 then mt()
-    else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in
-  hov 1 (str"(" ++ pr_id id ++
-        prlist pr_binder_fix bll ++ annot ++ str" :" ++
-        pr_lconstrarg ty ++ str")") in
-(*  spc() ++
-  hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
-    c)
-*)
-let pr_cofix_tac (id,c) =
-  hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
-
-  (* Printing tactics as arguments *)
-let rec pr_atom0 = function
-  | TacIntroPattern [] -> str "intros"
-  | TacIntroMove (None,hto) when hto = no_move -> str "intro"
-  | TacAssumption -> str "assumption"
-  | TacAnyConstructor (false,None) -> str "constructor"
-  | TacAnyConstructor (true,None) -> str "econstructor"
-  | TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial")
-  | TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto")
-  | TacReflexivity -> str "reflexivity"
-  | TacClear (true,[]) -> str "clear"
-  | t -> str "(" ++ pr_atom1 t ++ str ")"
-
-  (* Main tactic printer *)
-and pr_atom1 = function
-  | TacExtend (loc,s,l) ->
-      pr_with_comments loc (pr_extend 1 s l)
-  | TacAlias (loc,s,l,_) ->
-      pr_with_comments loc (pr_extend 1 s (List.map snd l))
-
-  (* Basic tactics *)
-  | TacIntroPattern [] as t -> pr_atom0 t
-  | TacIntroPattern (_::_ as p) ->
-      hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p)
-  | TacIntrosUntil h ->
-      hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h)
-  | TacIntroMove (None,hto) as t when hto = no_move -> pr_atom0 t
-  | TacIntroMove (Some id,hto) when hto = no_move -> str "intro " ++ pr_id id
-  | TacIntroMove (ido,hto) ->
-      hov 1 (str"intro" ++ pr_opt pr_id ido ++ pr_move_location pr_ident hto)
-  | TacAssumption as t -> pr_atom0 t
-  | TacExact c -> hov 1 (str "exact" ++ pr_constrarg c)
-  | TacExactNoCheck c -> hov 1 (str "exact_no_check" ++ pr_constrarg c)
-  | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c)
-  | TacApply (a,ev,cb,inhyp) ->
-      hov 1 ((if a then mt() else str "simple ") ++
-             str (with_evars ev "apply") ++ spc () ++
-             prlist_with_sep pr_comma pr_with_bindings cb ++
-             pr_in_hyp_as pr_ident inhyp)
-  | TacElim (ev,cb,cbo) ->
-      hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++
-        pr_opt pr_eliminator cbo)
-  | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c)
-  | TacCase (ev,cb) ->
-      hov 1 (str (with_evars ev "case") ++ spc () ++ pr_with_bindings cb)
-  | TacCaseType c -> hov 1 (str "casetype" ++ pr_constrarg c)
-  | TacFix (ido,n) -> hov 1 (str "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
-  | TacMutualFix (hidden,id,n,l) ->
-      if hidden then str "idtac" (* should caught before! *) else
-      hov 1 (str "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++
-             str"with " ++ prlist_with_sep spc pr_fix_tac l)
-  | TacCofix ido -> hov 1 (str "cofix" ++ pr_opt pr_id ido)
-  | TacMutualCofix (hidden,id,l) ->
-      if hidden then str "idtac" (* should be caught before! *) else
-      hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++
-             str"with " ++ prlist_with_sep spc pr_cofix_tac l)
-  | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c)
-  | TacAssert (Some tac,ipat,c) ->
-      hov 1 (str "assert" ++
-             pr_assumption pr_lconstr pr_constr ipat c ++
-             pr_by_tactic (pr_tac_level ltop) tac)
-  | TacAssert (None,ipat,c) ->
-      hov 1 (str "pose proof" ++
-             pr_assertion pr_lconstr pr_constr ipat c)
-  | TacGeneralize l ->
-      hov 1 (str "generalize" ++ spc () ++
-             prlist_with_sep pr_comma (fun (cl,na) ->
-	       pr_with_occurrences pr_constr cl ++ pr_as_name na)
-	     l)
-  | TacGeneralizeDep c ->
-      hov 1 (str "generalize" ++ spc () ++ str "dependent" ++
-             pr_constrarg c)
-  | TacLetTac (na,c,cl,true,_) when cl = nowhere ->
-      hov 1 (str "pose" ++ pr_pose pr_lconstr pr_constr na c)
-  | TacLetTac (na,c,cl,b,e) ->
-      hov 1 ((if b then str "set" else str "remember") ++
-             (if b then pr_pose pr_lconstr else pr_pose_as_style)
-	        pr_constr na c ++
-             pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
-             pr_clauses (Some b) pr_ident cl)
-(*  | TacInstantiate (n,c,ConclLocation ()) ->
-      hov 1 (str "instantiate" ++ spc() ++
-             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
-                    pr_lconstrarg c ++ str ")" ))
-  | TacInstantiate (n,c,HypLocation (id,hloc)) ->
-      hov 1 (str "instantiate" ++ spc() ++
-             hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
-                    pr_lconstrarg c ++ str ")" )
-	     ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None)))
-*)
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) ->
-      hov 1 (str "simple " ++ str (if isrec then "induction" else "destruct")
-             ++ pr_arg pr_quantified_hypothesis h)
-  | TacInductionDestruct (isrec,ev,(l,el,cl)) ->
-      hov 1 (str (with_evars ev (if isrec then "induction" else "destruct")) ++
-             spc () ++
-             prlist_with_sep pr_comma (fun (h,ids) ->
-	       pr_induction_arg pr_lconstr pr_constr h ++
-	       pr_with_induction_names ids) l ++
-             pr_opt pr_eliminator el ++
-	     pr_opt_no_spc (pr_clauses None pr_ident) cl)
-  | TacDoubleInduction (h1,h2) ->
-      hov 1
-        (str "double induction" ++
-         pr_arg pr_quantified_hypothesis h1 ++
- 	 pr_arg pr_quantified_hypothesis h2)
-  | TacDecomposeAnd c ->
-      hov 1 (str "decompose record" ++ pr_constrarg c)
-  | TacDecomposeOr c ->
-      hov 1 (str "decompose sum" ++ pr_constrarg c)
-  | TacDecompose (l,c) ->
-      hov 1 (str "decompose" ++ spc () ++
-        hov 0 (str "[" ++ prlist_with_sep spc pr_ind l
-	  ++ str "]" ++ pr_constrarg c))
-  | TacSpecialize (n,c) ->
-      hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++
-             pr_with_bindings c)
-  | TacLApply c ->
-      hov 1 (str "lapply" ++ pr_constrarg c)
-
-  (* Automation tactics *)
-  | TacTrivial (_,[],Some []) as x -> pr_atom0 x
-  | TacTrivial (d,lems,db) ->
-      hov 0 (str (string_of_debug d ^ "trivial") ++
-             pr_auto_using pr_constr lems ++ pr_hintbases db)
-  | TacAuto (_,None,[],Some []) as x -> pr_atom0 x
-  | TacAuto (d,n,lems,db) ->
-      hov 0 (str (string_of_debug d ^ "auto") ++
-	     pr_opt (pr_or_var int) n ++
-             pr_auto_using pr_constr lems ++ pr_hintbases db)
-
-  (* Context management *)
-  | TacClear (true,[]) as t -> pr_atom0 t
-  | TacClear (keep,l) ->
-      hov 1 (str "clear" ++ spc () ++ (if keep then str "- " else mt ()) ++
-             prlist_with_sep spc pr_ident l)
-  | TacClearBody l ->
-      hov 1 (str "clearbody" ++ spc () ++ prlist_with_sep spc pr_ident l)
-  | TacMove (b,id1,id2) ->
-      (* Rem: only b = true is available for users *)
-      assert b;
-      hov 1
-        (str "move" ++ brk (1,1) ++ pr_ident id1 ++
-	 pr_move_location pr_ident id2)
-  | TacRename l ->
-      hov 1
-        (str "rename" ++ brk (1,1) ++
-         prlist_with_sep
-	   (fun () -> str "," ++ brk (1,1))
-	   (fun (i1,i2) ->
-	      pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2)
-	   l)
-  | TacRevert l ->
-      hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l)
-
-  (* Constructors *)
-  | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l)
-  | TacRight (ev,l) -> hov 1 (str (with_evars ev "right") ++ pr_bindings l)
-  | TacSplit (ev,false,l) -> hov 1 (str (with_evars ev "split") ++ prlist_with_sep pr_comma pr_bindings l)
-  | TacSplit (ev,true,l) -> hov 1 (str (with_evars ev "exists") ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l)
-  | TacAnyConstructor (ev,Some t) ->
-      hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t)
-  | TacAnyConstructor (ev,None) as t -> pr_atom0 t
-  | TacConstructor (ev,n,l) ->
-      hov 1 (str (with_evars ev "constructor") ++
-             pr_or_var pr_intarg n ++ pr_bindings l)
-
-  (* Conversion *)
-  | TacReduce (r,h) ->
-      hov 1 (pr_red_expr r ++
-             pr_clauses (Some true) pr_ident h)
-  | TacChange (op,c,h) ->
-      hov 1 (str "change" ++ brk (1,1) ++
-      (match op with
-          None -> mt()
-        | Some p -> pr_pat p ++ spc () ++ str "with ") ++
-      pr_constr c ++ pr_clauses (Some true) pr_ident h)
-
-  (* Equivalence relations *)
-  | TacReflexivity as x -> pr_atom0 x
-  | TacSymmetry cls -> str "symmetry" ++ pr_clauses (Some true) pr_ident cls
-  | TacTransitivity (Some c) -> str "transitivity" ++ pr_constrarg c
-  | TacTransitivity None -> str "etransitivity"
-
-  (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) ->
-      hov 1 (str (with_evars ev "rewrite") ++ spc () ++
-	     prlist_with_sep
-	     (fun () -> str ","++spc())
-	     (fun (b,m,c) ->
-		pr_orient b ++ pr_multi m ++ pr_with_bindings c)
-	     l
-	     ++ pr_clauses (Some true) pr_ident cl
-	     ++	(match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt()))
-  | TacInversion (DepInversion (k,c,ids),hyp) ->
-      hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++
-      pr_quantified_hypothesis hyp ++
-      pr_with_inversion_names ids ++ pr_with_constr pr_constr c)
-  | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
-      hov 1 (pr_induction_kind k ++ spc () ++
-      pr_quantified_hypothesis hyp ++
-      pr_with_inversion_names ids ++ pr_simple_hyp_clause pr_ident cl)
-  | TacInversion (InversionUsing (c,cl),hyp) ->
-      hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++
-      spc () ++ str "using" ++ spc () ++ pr_constr c ++
-      pr_simple_hyp_clause pr_ident cl)
-
-in
-
-let rec pr_tac inherited tac =
-  let (strm,prec) = match tac with
-  | TacAbstract (t,None) ->
-      str "abstract " ++ pr_tac (labstract,L) t, labstract
-  | TacAbstract (t,Some s) ->
-      hov 0
-       (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++
-        str "using " ++ pr_id s),
-      labstract
-  | TacLetIn (recflag,llc,u) ->
-      let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in
-      v 0
-       (hv 0 (pr_let_clauses recflag (pr_tac ltop) llc ++ str " in") ++
-       fnl () ++ pr_tac (llet,E) u),
-      llet
-  | TacMatch (lz,t,lrul) ->
-      hov 0 (pr_lazy lz ++ str "match " ++ pr_tac ltop t ++ str " with"
-        ++ prlist
-	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule true (pr_tac ltop) pr_lpat r)
-	lrul
-        ++ fnl() ++ str "end"),
-      lmatch
-  | TacMatchGoal (lz,lr,lrul) ->
-      hov 0 (pr_lazy lz ++
-	str (if lr then "match reverse goal with" else "match goal with")
-	++ prlist
-	  (fun r -> fnl () ++ str "| " ++
-            pr_match_rule false (pr_tac ltop) pr_lpat r)
-	lrul
-        ++ fnl() ++ str "end"),
-      lmatch
-  | TacFun (lvar,body) ->
-      hov 2 (str "fun" ++
-        prlist pr_funvar lvar ++ str " =>" ++ spc () ++
-        pr_tac (lfun,E) body),
-      lfun
-  | TacThens (t,tl) ->
-      hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++
-             pr_seq_body (pr_tac ltop) tl),
-      lseq
-  | TacThen (t1,[||],t2,[||]) ->
-      hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++
-             pr_tac (lseq,L) t2),
-      lseq
-  | TacThen (t1,tf,t2,tl) ->
-      hov 1 (pr_tac (lseq,E) t1 ++ pr_then () ++ spc () ++
-             pr_then_gen (pr_tac ltop) tf t2 tl),
-      lseq
-  | TacTry t ->
-      hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t),
-      ltactical
-  | TacDo (n,t) ->
-      hov 1 (str "do " ++ pr_or_var int n ++ spc () ++
-             pr_tac (ltactical,E) t),
-      ltactical
-  | TacTimeout (n,t) ->
-      hov 1 (str "timeout " ++ pr_or_var int n ++ spc () ++
-             pr_tac (ltactical,E) t),
-      ltactical
-  | TacRepeat t ->
-      hov 1 (str "repeat" ++ spc () ++ pr_tac (ltactical,E) t),
-      ltactical
-  | TacProgress t ->
-      hov 1 (str "progress" ++ spc () ++ pr_tac (ltactical,E) t),
-      ltactical
-  | TacInfo t ->
-      hov 1 (str "info" ++ spc () ++ pr_tac (ltactical,E) t),
-      linfo
-  | TacOrelse (t1,t2) ->
-      hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++
-             pr_tac (lorelse,E) t2),
-      lorelse
-  | TacFail (n,l) ->
-      hov 1 (str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++
-      prlist (pr_arg (pr_message_token pr_ident)) l), latom
-  | TacFirst tl ->
-      str "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
-  | TacSolve tl ->
-      str "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
-  | TacComplete t ->
-      pr_tac (lcomplete,E) t, lcomplete
-  | TacId l ->
-      str "idtac" ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom
-  | TacAtom (loc,TacAlias (_,s,l,_)) ->
-      pr_with_comments loc
-        (pr_extend (level_of inherited) s (List.map snd l)),
-      latom
-  | TacAtom (loc,t) ->
-      pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom
-  | TacArg(_,Tacexp e) -> pr_tac_level (latom,E) e, latom
-  | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
-      str "constr:" ++ pr_constr c, latom
-  | TacArg(_,ConstrMayEval c) ->
-      pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c, leval
-  | TacArg(_,TacFreshId l) -> str "fresh" ++ pr_fresh_ids l, latom
-  | TacArg(_,Integer n) -> int n, latom
-  | TacArg(_,TacCall(loc,f,[])) -> pr_ref f, latom
-  | TacArg(_,TacCall(loc,f,l)) ->
-      pr_with_comments loc
-        (hov 1 (pr_ref f ++ spc () ++
-         prlist_with_sep spc pr_tacarg l)),
-      lcall
-  | TacArg (_,a) -> pr_tacarg a, latom
-  in
-  if prec_less prec inherited then strm
-  else str"(" ++ strm ++ str")"
-
-and pr_tacarg = function
-  | TacDynamic (loc,t) ->
-      pr_with_comments loc (str ("<dynamic ["^(Dyn.tag t)^"]>"))
-  | MetaIdArg (loc,true,s) -> pr_with_comments loc (str ("$" ^ s))
-  | MetaIdArg (loc,false,s) -> pr_with_comments loc (str ("constr: $" ^ s))
-  | IntroPattern ipat -> str "ipattern:" ++ pr_intro_pattern ipat
-  | TacVoid -> str "()"
-  | Reference r -> pr_ref r
-  | ConstrMayEval c -> pr_may_eval pr_constr pr_lconstr pr_cst pr_pat c
-  | TacFreshId l -> str "fresh" ++ pr_fresh_ids l
-  | TacExternal (_,com,req,la) ->
-      str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++
-      spc() ++ prlist_with_sep spc pr_tacarg la
-  | (TacCall _|Tacexp _|Integer _) as a ->
-      str "ltac:" ++ pr_tac (latom,E) (TacArg (dummy_loc,a))
-
-in (pr_tac, pr_match_rule)
-
-let strip_prod_binders_glob_constr n (ty,_) =
-  let rec strip_ty acc n ty =
-    if n=0 then (List.rev acc, (ty,None)) else
-      match ty with
-          Glob_term.GProd(loc,na,Explicit,a,b) ->
-            strip_ty (([dummy_loc,na],(a,None))::acc) (n-1) b
-        | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-let strip_prod_binders_constr n ty =
-  let rec strip_ty acc n ty =
-    if n=0 then (List.rev acc, ty) else
-      match Term.kind_of_term ty with
-          Term.Prod(na,a,b) ->
-            strip_ty (([dummy_loc,na],a)::acc) (n-1) b
-        | _ -> error "Cannot translate fix tactic: not enough products" in
-  strip_ty [] n ty
-
-let drop_env f _env = f
-
-let pr_constr_or_lconstr_pattern_expr b =
-  if b then pr_lconstr_pattern_expr else pr_constr_pattern_expr
-
-let rec raw_printers =
-    (pr_raw_tactic_level,
-     drop_env pr_constr_expr,
-     drop_env pr_lconstr_expr,
-     pr_constr_or_lconstr_pattern_expr,
-     drop_env (pr_or_by_notation pr_reference),
-     drop_env (pr_or_by_notation pr_reference),
-     pr_reference,
-     pr_or_metaid pr_lident,
-     pr_raw_extend,
-     strip_prod_binders_expr)
-
-and pr_raw_tactic_level env n (t:raw_tactic_expr) =
-  fst (make_pr_tac raw_printers env) n t
-
-let pr_and_constr_expr pr (c,_) = pr c
-
-let pr_pat_and_constr_expr b (c,_) =
-  pr_and_constr_expr ((if b then pr_lglob_constr_env else pr_glob_constr_env)
-    (Global.env())) c
-
-let rec glob_printers =
-    (pr_glob_tactic_level,
-     (fun env -> pr_and_constr_expr (pr_glob_constr_env env)),
-     (fun env -> pr_and_constr_expr (pr_lglob_constr_env env)),
-     pr_pat_and_constr_expr,
-     (fun env -> pr_or_var (pr_and_short_name (pr_evaluable_reference_env env))),
-     (fun env -> pr_or_var (pr_inductive env)),
-     pr_ltac_or_var (pr_located pr_ltac_constant),
-     pr_lident,
-     pr_glob_extend,
-     strip_prod_binders_glob_constr)
-
-and pr_glob_tactic_level env n (t:glob_tactic_expr) =
-  fst (make_pr_tac glob_printers env) n t
-
-let pr_constr_or_lconstr_pattern b =
-  if b then pr_lconstr_pattern else pr_constr_pattern
-
-let typed_printers =
-    (pr_glob_tactic_level,
-     pr_constr_env,
-     pr_lconstr_env,
-     pr_constr_or_lconstr_pattern,
-     pr_evaluable_reference_env,
-     pr_inductive,
-     pr_ltac_constant,
-     pr_id,
-     pr_extend,
-     strip_prod_binders_constr)
-
-let pr_tactic_level env = fst (make_pr_tac typed_printers env)
-
-let pr_raw_tactic env = pr_raw_tactic_level env ltop
-let pr_glob_tactic env = pr_glob_tactic_level env ltop
-let pr_tactic env = pr_tactic_level env ltop
-
-let _ = Tactic_debug.set_tactic_printer
-  (fun x -> pr_glob_tactic (Global.env()) x)
-
-let _ = Tactic_debug.set_match_pattern_printer
-  (fun env hyp -> pr_match_pattern (pr_constr_pattern_env env) hyp)
-
-let _ = Tactic_debug.set_match_rule_printer
-  (fun rl ->
-    pr_match_rule false (pr_glob_tactic (Global.env())) 
-      (fun (_,p) -> pr_constr_pattern p) rl)
-
-open Extrawit
-
-let pr_tac_polymorphic n _ _ prtac = prtac (n,E)
-
-let _ = for i=0 to 5 do
-  declare_extra_genarg_pprule
-  (rawwit_tactic i, pr_tac_polymorphic i)
-  (globwit_tactic i, pr_tac_polymorphic i)
-  (wit_tactic i, pr_tac_polymorphic i)
-done
-
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
deleted file mode 100644
index c5953da1..00000000
--- a/parsing/pptactic.mli
+++ /dev/null
@@ -1,100 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Genarg
-open Tacexpr
-open Pretyping
-open Proof_type
-open Topconstr
-open Glob_term
-open Pattern
-open Ppextend
-open Environ
-open Evd
-
-val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
-val pr_or_metaid : ('a -> std_ppcmds) -> 'a or_metaid -> std_ppcmds
-val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
-val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
-
-type 'a raw_extra_genarg_printer =
-    (constr_expr -> std_ppcmds) ->
-    (constr_expr -> std_ppcmds) ->
-    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a glob_extra_genarg_printer =
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (glob_constr_and_expr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-type 'a extra_genarg_printer =
-    (Term.constr -> std_ppcmds) ->
-    (Term.constr -> std_ppcmds) ->
-    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-    'a -> std_ppcmds
-
-  (** if the boolean is false then the extension applies only to old syntax *)
-val declare_extra_genarg_pprule :
-  ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) ->
-  ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) ->
-  ('b typed_abstract_argument_type * 'b extra_genarg_printer) -> unit
-
-type grammar_terminals = string option list
-
-  (** if the boolean is false then the extension applies only to old syntax *)
-val declare_extra_tactic_pprule :
-  string * argument_type list * (int * grammar_terminals) -> unit
-
-val exists_extra_tactic_pprule : string -> argument_type list -> bool
-
-val pr_raw_generic :
-  (constr_expr -> std_ppcmds) ->
-  (constr_expr -> std_ppcmds) ->
-  (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-  (constr_expr -> std_ppcmds) ->
-  (Libnames.reference -> std_ppcmds) -> rlevel generic_argument ->
-    std_ppcmds
-
-val pr_raw_extend:
-  (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
-  (tolerability -> raw_tactic_expr -> std_ppcmds) ->
-  (constr_expr -> std_ppcmds) -> int ->
-    string -> raw_generic_argument list -> std_ppcmds
-
-val pr_glob_extend:
-  (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) ->
-  (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-  (glob_constr_pattern_and_expr -> std_ppcmds) -> int ->
-    string -> glob_generic_argument list -> std_ppcmds
-
-val pr_extend :
-  (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
-  (tolerability -> glob_tactic_expr -> std_ppcmds) ->
-  (constr_pattern -> std_ppcmds) -> int ->
-    string -> typed_generic_argument list -> std_ppcmds
-
-val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
-
-val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds
-
-val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds
-
-val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
-
-val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds
-
-val pr_hintbases : string list option -> std_ppcmds
-
-val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
-
-val pr_bindings :
-  ('constr -> std_ppcmds) ->
-  ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml
deleted file mode 100644
index 98c02567..00000000
--- a/parsing/ppvernac.ml
+++ /dev/null
@@ -1,979 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Names
-open Nameops
-open Nametab
-open Compat
-open Util
-open Extend
-open Vernacexpr
-open Ppconstr
-open Pptactic
-open Glob_term
-open Genarg
-open Pcoq
-open Libnames
-open Ppextend
-open Topconstr
-open Decl_kinds
-open Tacinterp
-open Declaremods
-
-let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
-
-let pr_lident (loc,id) =
-  if loc <> dummy_loc then
-    let (b,_) = unloc loc in
-    pr_located pr_id (make_loc (b,b+String.length(string_of_id id)),id)
-  else pr_id id
-
-let string_of_fqid fqid =
- String.concat "." (List.map string_of_id fqid)
-
-let pr_fqid fqid = str (string_of_fqid fqid)
-
-let pr_lfqid (loc,fqid) =
-  if loc <> dummy_loc then
-   let (b,_) = unloc loc in
-    pr_located pr_fqid (make_loc (b,b+String.length(string_of_fqid fqid)),fqid)
-  else
-   pr_fqid fqid
-
-let pr_lname = function
-    (loc,Name id) -> pr_lident (loc,id)
-  | lna -> pr_located pr_name lna
-
-let pr_smart_global = pr_or_by_notation pr_reference
-
-let pr_ltac_ref = Libnames.pr_reference
-
-let pr_module = Libnames.pr_reference
-
-let pr_import_module = Libnames.pr_reference
-
-let sep_end = function
-  | VernacBullet _
-  | VernacSubproof None
-  | VernacEndSubproof -> str""
-  | _ -> str"."
-
-(* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *)
-
-let pr_raw_tactic_env l env t =
-  pr_glob_tactic env (Tacinterp.glob_tactic_env l env t)
-
-let pr_gen env t =
-  pr_raw_generic
-    pr_constr_expr
-    pr_lconstr_expr
-    (pr_raw_tactic_level env) pr_constr_expr pr_reference t
-
-let pr_raw_tactic tac = pr_raw_tactic (Global.env()) tac
-
-let rec extract_signature = function
-  | [] -> []
-  | Egrammar.GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
-  | _::l -> extract_signature l
-
-let rec match_vernac_rule tys = function
-    [] -> raise Not_found
-  | pargs::rls ->
-      if extract_signature pargs = tys then pargs
-      else match_vernac_rule tys rls
-
-let sep = fun _ -> spc()
-let sep_v2 = fun _ -> str"," ++ spc()
-
-let pr_ne_sep sep pr = function
-    [] -> mt()
-  | l -> sep() ++ pr l
-
-let pr_set_entry_type = function
-  | ETName -> str"ident"
-  | ETReference -> str"global"
-  | ETPattern -> str"pattern"
-  | ETConstr _ -> str"constr"
-  | ETOther (_,e) -> str e
-  | ETBigint -> str "bigint"
-  | ETBinder true -> str "binder"
-  | ETBinder false -> str "closed binder"
-  | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type"
-
-let strip_meta id =
-  let s = string_of_id id in
-  if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
-  else id
-
-let pr_production_item = function
-  | TacNonTerm (loc,nt,Some (p,sep)) ->
-      let pp_sep = if sep <> "" then str "," ++ quote (str sep) else mt () in
-      str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")"
-  | TacNonTerm (loc,nt,None) -> str nt
-  | TacTerm s -> qs s
-
-let pr_comment pr_c = function
-  | CommentConstr c -> pr_c c
-  | CommentString s -> qs s
-  | CommentInt n -> int n
-
-let pr_in_out_modules = function
-  | SearchInside l -> spc() ++ str"inside" ++ spc() ++ prlist_with_sep sep pr_module l
-  | SearchOutside [] -> mt()
-  | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l
-
-let pr_search_about (b,c) =
-  (if b then str "-" else mt()) ++
-  match c with
-  | SearchSubPattern p -> pr_constr_pattern_expr p
-  | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
-
-let pr_search a b pr_p = match a with
-  | SearchHead c -> str"Search" ++ spc() ++ pr_p c ++ pr_in_out_modules b
-  | SearchPattern c -> str"SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
-  | SearchRewrite c -> str"SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
-  | SearchAbout sl -> str"SearchAbout" ++ spc() ++ str "[" ++ prlist_with_sep spc pr_search_about sl ++ str "]" ++ pr_in_out_modules b
-
-let pr_locality_full = function
-  | None -> mt()
-  | Some true -> str"Local "
-  | Some false -> str"Global "
-let pr_locality local = if local then str "Local " else str ""
-let pr_non_locality local = if local then str "" else str "Global "
-let pr_section_locality local =
-  if Lib.sections_are_opened () && not local then str "Global "
-  else if not (Lib.sections_are_opened ()) && local then str "Local "
-  else mt ()
-
-let pr_explanation (e,b,f) =
-  let a = match e with
-  | ExplByPos (n,_) -> anomaly "No more supported"
-  | ExplByName id -> pr_id id in
-  let a = if f then str"!" ++ a else a in
-    if b then str "[" ++ a ++ str "]" else a
-
-let pr_option_ref_value = function
-  | QualidRefValue id -> pr_reference id
-  | StringRefValue s -> qs s
-
-let pr_printoption table b =
-  prlist_with_sep spc str table ++
-  pr_opt (prlist_with_sep sep pr_option_ref_value) b
-
-let pr_set_option a b =
-  let pr_opt_value = function
-    | IntValue None -> assert false
-    (* This should not happen because of the grammar *)
-    | IntValue (Some n) -> spc() ++ int n
-    | StringValue s -> spc() ++ str s
-    | BoolValue b -> mt()
-  in pr_printoption a None ++ pr_opt_value b
-
-let pr_topcmd _ = str"(* <Warning> : No printer for toplevel commands *)"
-
-let pr_destruct_location = function
-  | Tacexpr.ConclLocation ()  -> str"Conclusion"
-  | Tacexpr.HypLocation b -> if b then str"Discardable Hypothesis" else str"Hypothesis"
-
-let pr_opt_hintbases l = match l with
-  | [] -> mt()
-  | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
-
-let pr_hints local db h pr_c pr_pat =
-  let opth = pr_opt_hintbases db  in
-  let pph =
-    match h with
-    | HintsResolve l ->
-        str "Resolve " ++ prlist_with_sep sep
-	  (fun (pri, _, c) -> pr_c c ++
-	    match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ())
-	  l
-    | HintsImmediate l ->
-        str"Immediate" ++ spc() ++ prlist_with_sep sep pr_c l
-    | HintsUnfold l ->
-        str "Unfold " ++ prlist_with_sep sep pr_reference l
-    | HintsTransparency (l, b) ->
-        str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep
-	  pr_reference l
-    | HintsConstructors c ->
-        str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c
-    | HintsExtern (n,c,tac) ->
-	let pat = match c with None -> mt () | Some pat -> pr_pat pat in
-          str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
-          spc() ++ pr_raw_tactic tac
-  in
-  hov 2 (str"Hint "++pr_locality local ++ pph ++ opth)
-
-let pr_with_declaration pr_c = function
-  | CWith_Definition (id,c) ->
-      let p = pr_c c in
-      str"Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
-  | CWith_Module (id,qid) ->
-      str"Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
-      pr_located pr_qualid qid
-
-let rec pr_module_ast pr_c = function
-  | CMident qid -> spc () ++ pr_located pr_qualid qid
-  | CMwith (_,mty,decl) ->
-      let m = pr_module_ast pr_c mty in
-      let p = pr_with_declaration pr_c decl in
-      m ++ spc() ++ str"with" ++ spc() ++ p
-  | CMapply (_,me1,(CMident _ as me2)) ->
-      pr_module_ast pr_c me1 ++ spc() ++ pr_module_ast pr_c me2
-  | CMapply (_,me1,me2) ->
-      pr_module_ast pr_c me1 ++ spc() ++
-      hov 1 (str"(" ++ pr_module_ast pr_c me2 ++ str")")
-
-let pr_annot { ann_inline = ann; ann_scope_subst = scl } =
-  let sep () = if scl=[] then mt () else str "," in
-  if ann = DefaultInline && scl = [] then mt ()
-  else
-    str " [" ++
-    (match ann with
-      | DefaultInline -> mt ()
-      | NoInline -> str "no inline" ++ sep ()
-      | InlineAt i -> str "inline at level " ++ int i ++ sep ()) ++
-    prlist_with_sep (fun () -> str ", ")
-      (fun (sc1,sc2) -> str ("scope "^sc1^" to "^sc2)) scl ++
-    str "]"
-
-let pr_module_ast_inl pr_c (mast,ann) =
-  pr_module_ast pr_c mast ++ pr_annot ann
-
-let pr_of_module_type prc = function
-  | Enforce mty -> str ":" ++ pr_module_ast_inl prc mty
-  | Check mtys ->
-      prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl prc m) mtys
-
-let pr_require_token = function
-  | Some true -> str "Export "
-  | Some false -> str "Import "
-  | None -> mt()
-
-let pr_module_vardecls pr_c (export,idl,(mty,inl)) =
-  let m = pr_module_ast pr_c mty in
-  (* Update the Nametab for interpreting the body of module/modtype *)
-  let lib_dir = Lib.library_dp() in
-  List.iter (fun (_,id) ->
-    Declaremods.process_module_bindings [id]
-      [make_mbid lib_dir id,
-       (Modintern.interp_modtype (Global.env()) mty, inl)]) idl;
-  (* Builds the stream *)
-  spc() ++
-  hov 1 (str"(" ++ pr_require_token export ++
-   prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
-
-let pr_module_binders l pr_c =
-  (* Effet de bord complexe pour garantir la declaration des noms des
-  modules parametres dans la Nametab des l'appel de pr_module_binders
-  malgre l'aspect paresseux des streams *)
-  let ml = List.map (pr_module_vardecls pr_c) l in
-  prlist (fun id -> id) ml
-
-let pr_module_binders_list l pr_c = pr_module_binders l pr_c
-
-let pr_type_option pr_c = function
-  | CHole (loc, k) -> mt()
-  | _ as c -> brk(0,2) ++ str":" ++ pr_c c
-
-let pr_decl_notation prc ((loc,ntn),c,scopt) =
-  fnl () ++ str "where " ++ qs ntn ++ str " := " ++ prc c ++
-  pr_opt (fun sc -> str ": " ++ str sc) scopt
-
-let pr_binders_arg =
-  pr_ne_sep spc pr_binders
-
-let pr_and_type_binders_arg bl =
-  pr_binders_arg bl
-
-let pr_onescheme (idop,schem) =
-  match schem with
-  | InductionScheme (dep,ind,s) ->
-    (match idop with
-      | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
-      | None -> spc ()
-    ) ++
-    hov 0 ((if dep then str"Induction for" else str"Minimality for")
-    ++ spc() ++ pr_smart_global ind) ++ spc() ++
-    hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s)
-  | CaseScheme (dep,ind,s) ->
-    (match idop with
-      | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
-      | None -> spc ()
-    ) ++
-    hov 0 ((if dep then str"Elimination for" else str"Case for")
-    ++ spc() ++ pr_smart_global ind) ++ spc() ++
-    hov 0 (str"Sort" ++ spc() ++ pr_glob_sort s)
-  | EqualityScheme ind ->
-    (match idop with
-      | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
-      | None -> spc()
-    ) ++
-    hov 0 (str"Equality for")
-    ++ spc() ++ pr_smart_global ind
-
-let begin_of_inductive = function
-    [] -> 0
-  | (_,((loc,_),_))::_ -> fst (unloc loc)
-
-let pr_class_rawexpr = function
-  | FunClass -> str"Funclass"
-  | SortClass -> str"Sortclass"
-  | RefClass qid -> pr_smart_global qid
-
-let pr_assumption_token many = function
-  | (Local,Logical) ->
-      str (if many then "Hypotheses" else "Hypothesis")
-  | (Local,Definitional) ->
-      str (if many then "Variables" else "Variable")
-  | (Global,Logical) ->
-      str (if many then "Axioms" else "Axiom")
-  | (Global,Definitional) ->
-      str (if many then "Parameters" else "Parameter")
-  | (Global,Conjectural) -> str"Conjecture"
-  | (Local,Conjectural) ->
-      anomaly "Don't know how to beautify a local conjecture"
-
-let pr_params pr_c (xl,(c,t)) =
-  hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
-         (if c then str":>" else str":" ++
-         spc() ++ pr_c t))
-
-let rec factorize = function
-  | [] -> []
-  | (c,(idl,t))::l ->
-      match factorize l with
-	| (xl,t')::l' when t' = (c,t) -> (idl@xl,t')::l'
-	| l' -> (idl,(c,t))::l'
-
-let pr_ne_params_list pr_c l =
-  match factorize l with
-    | [p] -> pr_params pr_c p
-    | l ->
-	prlist_with_sep spc
-          (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l
-(*
-  prlist_with_sep pr_semicolon (pr_params pr_c)
-*)
-
-let pr_thm_token k = str (string_of_theorem_kind k)
-
-let pr_syntax_modifier = function
-  | SetItemLevel (l,NextLevel) ->
-      prlist_with_sep sep_v2 str l ++
-      spc() ++ str"at next level"
-  | SetItemLevel (l,NumLevel n) ->
-      prlist_with_sep sep_v2 str l ++
-      spc() ++ str"at level" ++ spc() ++ int n
-  | SetLevel n -> str"at level" ++ spc() ++ int n
-  | SetAssoc LeftA -> str"left associativity"
-  | SetAssoc RightA -> str"right associativity"
-  | SetAssoc NonA -> str"no associativity"
-  | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
-  | SetOnlyParsing Flags.Current -> str"only parsing"
-  | SetOnlyParsing v -> str("compat \"" ^ Flags.pr_version v ^ "\"")
-  | SetFormat s -> str"format " ++ pr_located qs s
-
-let pr_syntax_modifiers = function
-  | [] -> mt()
-  | l -> spc() ++
-      hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
-
-let print_level n =
-  if n <> 0 then str " (at level " ++ int n ++ str ")" else mt ()
-
-let pr_grammar_tactic_rule n (_,pil,t) =
-  hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++
-    hov 0 (prlist_with_sep sep pr_production_item pil ++
-    spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
-
-let pr_statement head (id,(bl,c,guard)) =
-  assert (id<>None);
-  hov 1
-    (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++
-    (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
-    pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++
-    str":" ++ pr_spc_lconstr c)
-
-(**************************************)
-(* Pretty printer for vernac commands *)
-(**************************************)
-let make_pr_vernac pr_constr pr_lconstr =
-
-let pr_constrarg c = spc () ++ pr_constr c in
-let pr_lconstrarg c = spc () ++ pr_lconstr c in
-let pr_intarg n = spc () ++ int n in
-let pr_oc = function 
-    None -> str" :"
-  | Some true -> str" :>"
-  | Some false -> str" :>>"
-in
-let pr_record_field ((x, pri), ntn) =
-  let prx = match x with
-    | (oc,AssumExpr (id,t)) ->
-	hov 1 (pr_lname id ++
-	       pr_oc oc ++ spc() ++
-	       pr_lconstr_expr t)
-    | (oc,DefExpr(id,b,opt)) -> (match opt with
-      | Some t ->
-          hov 1 (pr_lname id ++
-                 pr_oc oc ++ spc() ++
-                 pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
-      | None ->
-          hov 1 (pr_lname id ++ str" :=" ++ spc() ++
-                    pr_lconstr b)) in
-  let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
-    prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
-in
-let pr_record_decl b c fs =
-    pr_opt pr_lident c ++ str"{"  ++
-    hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
-in
-
-let rec pr_vernac = function
-
-  (* Proof management *)
-  | VernacAbortAll -> str "Abort All"
-  | VernacRestart -> str"Restart"
-  | VernacUnfocus -> str"Unfocus"
-  | VernacUnfocused -> str"Unfocused"
-  | VernacGoal c -> str"Goal" ++ pr_lconstrarg c
-  | VernacAbort id -> str"Abort" ++ pr_opt pr_lident id
-  | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
-  | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i
-  | VernacBacktrack (i,j,k) ->
-      str "Backtrack" ++  spc() ++ prlist_with_sep sep int [i;j;k]
-  | VernacFocus i -> str"Focus" ++ pr_opt int i
-  | VernacShow s ->
-      let pr_goal_reference = function
-        | OpenSubgoals -> mt ()
-        | NthGoal n -> spc () ++ int n
-        | GoalId n -> spc () ++ str n in
-      let pr_showable = function
-	| ShowGoal n -> str"Show" ++ pr_goal_reference n
-	| ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n
-	| ShowProof -> str"Show Proof"
-	| ShowNode -> str"Show Node"
-	| ShowScript -> str"Show Script"
-	| ShowExistentials -> str"Show Existentials"
-	| ShowTree -> str"Show Tree"
-	| ShowProofNames -> str"Show Conjectures"
-	| ShowIntros b -> str"Show " ++ (if b then str"Intros" else str"Intro")
-	| ShowMatch id -> str"Show Match " ++ pr_lident id
-	| ShowThesis -> str "Show Thesis"
-      in pr_showable s
-  | VernacCheckGuard -> str"Guarded"
-
-  (* Resetting *)
-  | VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
-  | VernacResetInitial -> str"Reset Initial"
-  | VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i
-  | VernacBackTo i -> str"BackTo" ++ pr_intarg i
-
-  (* State management *)
-  | VernacWriteState s -> str"Write State" ++ spc () ++ qs s
-  | VernacRestoreState s -> str"Restore State" ++ spc() ++ qs s
-
-  (* Control *)
-  | VernacList l ->
-      hov 2 (str"[" ++ spc() ++
-             prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l
-             ++ spc() ++ str"]")
-  | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose"
-  ++ spc()) else spc()  ++ qs s
-  | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v
-  | VernacTimeout(n,v) -> str"Timeout " ++ int n ++ spc() ++ pr_vernac v
-  | VernacFail v -> str"Fail" ++ spc() ++ pr_vernac v
-
-  (* Syntax *)
-  | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e)
-  | VernacOpenCloseScope (local,opening,sc) ->
-      pr_section_locality local ++ 
-      str (if opening then "Open " else "Close ") ++
-      str "Scope" ++ spc() ++ str sc
-  | VernacDelimiters (sc,key) ->
-      str"Delimit Scope" ++ spc () ++ str sc ++
-      spc() ++ str "with " ++ str key
-  | VernacBindScope (sc,cll) ->
-      str"Bind Scope" ++ spc () ++ str sc ++
-      spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll
-  | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function
-      |	None -> str"_"
-      |	Some sc -> str sc in
-    pr_section_locality local ++ str"Arguments Scope" ++ spc() ++ 
-    pr_smart_global q
-    ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
-  | VernacInfix (local,((_,s),mv),q,sn) -> (* A Verifier *)
-      hov 0 (hov 0 (pr_locality local ++ str"Infix "
-      ++ qs s ++ str " :=" ++ pr_constrarg q) ++
-      pr_syntax_modifiers mv ++
-      (match sn with
-    | None -> mt()
-    | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
-  | VernacNotation (local,c,((_,s),l),opt) ->
-      let ps =
-	let n = String.length s in
-	if n > 2 & s.[0] = '\'' & s.[n-1] = '\''
-	then
-          let s' = String.sub s 1 (n-2) in
-          if String.contains s' '\'' then qs s else str s'
-	else qs s in
-      hov 2 (pr_locality local ++ str"Notation" ++ spc() ++ ps ++
-      str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
-      (match opt with
-        | None -> mt()
-        | Some sc -> str" :" ++ spc() ++ str sc))
-  | VernacSyntaxExtension (local,(s,l)) ->
-      pr_locality local ++ str"Reserved Notation" ++ spc() ++ pr_located qs s ++
-      pr_syntax_modifiers l
-
-  (* Gallina *)
-  | VernacDefinition (d,id,b,f) -> (* A verifier... *)
-      let pr_def_token dk = str (string_of_definition_kind dk) in
-      let pr_reduce = function
-        | None -> mt()
-        | Some r ->
-            str"Eval" ++ spc() ++
-            pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
-            str" in" ++ spc() in
-      let pr_def_body = function
-        | DefineBody (bl,red,body,d) ->
-            let ty = match d with
-              | None -> mt()
-              | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
-	    in
-            (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
-        | ProveBody (bl,t) ->
-            (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
-      let (binds,typ,c) = pr_def_body b in
-      hov 2 (pr_def_token d ++ spc() ++ pr_lident id ++ binds ++ typ ++
-      (match c with
-        | None -> mt()
-        | Some cc -> str" :=" ++ spc() ++ cc))
-
-  | VernacStartTheoremProof (ki,l,_,_) ->
-      hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
-             prlist (pr_statement (spc () ++ str "with")) (List.tl l))
-
-  | VernacEndProof Admitted -> str"Admitted"
-  | VernacEndProof (Proved (opac,o)) -> (match o with
-    | None -> if opac then str"Qed" else str"Defined"
-    | Some (id,th) -> (match th with
-      |	None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id
-      |	Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id))
-  | VernacExactProof c ->
-      hov 2 (str"Proof" ++ pr_lconstrarg c)
-  | VernacAssumption (stre,_,l) ->
-      let n = List.length (List.flatten (List.map fst (List.map snd l))) in
-      hov 2
-        (pr_assumption_token (n > 1) stre ++ spc() ++
-	 pr_ne_params_list pr_lconstr_expr l)
-  | VernacInductive (f,i,l) ->
-
-      let pr_constructor (coe,(id,c)) =
-        hov 2 (pr_lident id ++ str" " ++
-               (if coe then str":>" else str":") ++
-                pr_spc_lconstr c) in
-      let pr_constructor_list b l = match l with
-        | Constructors [] -> mt()
-        | Constructors l ->
-            pr_com_at (begin_of_inductive l) ++
-            fnl() ++
-            str (if List.length l = 1 then "   " else " | ") ++
-            prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
-       | RecordDecl (c,fs) ->
-	    spc() ++
-	    pr_record_decl b c fs in
-      let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) =
-	hov 0 (
-	    str key ++ spc() ++
-	      (if i then str"Infer " else str"") ++
-              (if coe then str"> " else str"") ++ pr_lident id ++
-              pr_and_type_binders_arg indpar ++ spc() ++
-	      Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++
-	      str" :=") ++ pr_constructor_list k lc ++
-	    prlist (pr_decl_notation pr_constr) ntn
-      in
-      let key =
-        let (_,_,_,k,_),_ = List.hd l in
-	match k with Record -> "Record" | Structure -> "Structure"
-	  | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
-	  | Class _ -> "Class" in
-      hov 1 (pr_oneind key (List.hd l)) ++
-      (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
-
-
-  | VernacFixpoint recs ->
-      let pr_onerec = function
-        | ((loc,id),ro,bl,type_,def),ntn ->
-            let annot = pr_guard_annot pr_lconstr_expr bl ro in
-            pr_id id ++ pr_binders_arg bl ++ annot
-            ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
-            ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
-	    prlist (pr_decl_notation pr_constr) ntn
-      in
-      hov 0 (str "Fixpoint" ++ spc() ++
-        prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onerec recs)
-
-  | VernacCoFixpoint corecs ->
-      let pr_onecorec (((loc,id),bl,c,def),ntn) =
-        pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
-        spc() ++ pr_lconstr_expr c ++
-        pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
-	prlist (pr_decl_notation pr_constr) ntn
-      in
-      hov 0 (str "CoFixpoint" ++ spc() ++
-      prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs)
-  | VernacScheme l ->
-      hov 2 (str"Scheme" ++ spc() ++
-             prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l)
-  | VernacCombinedScheme (id, l) ->
-      hov 2 (str"Combined Scheme" ++ spc() ++
-	       pr_lident id ++ spc() ++ str"from" ++ spc() ++
-	       prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
-
-
-  (* Gallina extensions *)
-  | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id)
-  | VernacEndSegment id -> hov 2 (str"End" ++ spc() ++ pr_lident id)
-  | VernacRequire (exp,spe,l) -> hov 2
-      (str "Require" ++ spc() ++ pr_require_token exp ++
-      (match spe with
-      |	None -> mt()
-      |	Some flag ->
-          (if flag then str"Specification" else str"Implementation") ++
-          spc ()) ++
-      prlist_with_sep sep pr_module l)
-  | VernacImport (f,l) ->
-      (if f then str"Export" else str"Import") ++ spc() ++
-      prlist_with_sep sep pr_import_module l
-  | VernacCanonical q -> str"Canonical Structure" ++ spc() ++ pr_smart_global q
-  | VernacCoercion (s,id,c1,c2) ->
-      hov 1 (
-	str"Coercion" ++ (match s with | Local -> spc() ++
-	  str"Local" ++ spc() | Global -> spc()) ++
-	pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
-	spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
-  | VernacIdentityCoercion (s,id,c1,c2) ->
-      hov 1 (
-	str"Identity Coercion" ++ (match s with | Local -> spc() ++
-	  str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++
-	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
-	spc() ++ pr_class_rawexpr c2)
-
- | VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) ->
-     hov 1 (
-       pr_non_locality (not glob) ++
-       (if abst then str"Declare " else mt ()) ++
-       str"Instance" ++ 
-       (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | 
-	Anonymous -> mt ()) ++
-       pr_and_type_binders_arg sup ++
-       str":" ++ spc () ++	 
-       pr_constr_expr cl ++ spc () ++
-	 (match props with
-	  | Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p
-	  | None -> mt()))
-
- | VernacContext l ->
-     hov 1 (
-       str"Context" ++ spc () ++ pr_and_type_binders_arg l)
-
-
- | VernacDeclareInstances (glob, ids) ->
-     hov 1 (pr_non_locality (not glob) ++
-               str"Existing" ++ spc () ++ str(plural (List.length ids) "Instance") ++
-               spc () ++ prlist_with_sep spc pr_reference ids)
-
- | VernacDeclareClass id ->
-     hov 1 (str"Existing" ++ spc () ++ str"Class" ++ spc () ++ pr_reference id)
-
-  (* Modules and Module Types *)
-  | VernacDefineModule (export,m,bl,tys,bd) ->
-      let b = pr_module_binders_list bl pr_lconstr in
-      hov 2 (str"Module" ++ spc() ++ pr_require_token export ++
-               pr_lident m ++ b ++
-               pr_of_module_type pr_lconstr tys ++
-	       (if bd = [] then mt () else str ":= ") ++
-	       prlist_with_sep (fun () -> str " <+ ")
-	        (pr_module_ast_inl pr_lconstr) bd)
-  | VernacDeclareModule (export,id,bl,m1) ->
-      let b = pr_module_binders_list bl pr_lconstr in
-	hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++
-             pr_lident id ++ b ++
-             pr_module_ast_inl pr_lconstr m1)
-  | VernacDeclareModuleType (id,bl,tyl,m) ->
-      let b = pr_module_binders_list bl pr_lconstr in
-      let pr_mt = pr_module_ast_inl pr_lconstr in
-	hov 2 (str"Module Type " ++ pr_lident id ++ b ++
-		 prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++
-		 (if m = [] then mt () else str ":= ") ++
-		 prlist_with_sep (fun () -> str " <+ ") pr_mt m)
-  | VernacInclude (mexprs) ->
-      let pr_m = pr_module_ast_inl pr_lconstr in
-      hov 2 (str"Include " ++
-	     prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
-  (* Solving *)
-  | VernacSolve (i,tac,deftac) ->
-      (if i = 1 then mt() else int i ++ str ": ") ++
-      pr_raw_tactic tac
-      ++ (try if deftac then str ".." else mt ()
-      with UserError _|Loc.Exc_located _ -> mt())
-
-  | VernacSolveExistential (i,c) ->
-      str"Existential " ++ int i ++ pr_lconstrarg c
-
-  (* Auxiliary file and library management *)
-  | VernacRequireFrom (exp,spe,f) -> hov 2
-      (str"Require" ++ spc() ++ pr_require_token exp ++
-      (match spe with
-        | None -> mt()
-        | Some false -> str"Implementation" ++ spc()
-        | Some true -> str"Specification" ++ spc ()) ++
-      qs f)
-  | VernacAddLoadPath (fl,s,d) -> hov 2
-      (str"Add" ++
-       (if fl then str" Rec " else spc()) ++
-       str"LoadPath" ++ spc() ++ qs s ++
-       (match d with
-         | None -> mt()
-         | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir))
-  | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s
-  | VernacAddMLPath (fl,s) ->
-      str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s
-  | VernacDeclareMLModule (local, l) ->
-      pr_locality local ++
-      hov 2 (str"Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
-  | VernacChdir s -> str"Cd" ++ pr_opt qs s
-
-  (* Commands *)
-  | VernacDeclareTacticDefinition (local,rc,l) ->
-      let pr_tac_body (id, redef, body) =
-        let idl, body =
-          match body with
-	    | Tacexpr.TacFun (idl,b) -> idl,b
-            | _ -> [], body in
-        pr_ltac_ref id ++
-	prlist (function None -> str " _"
-                       | Some id -> spc () ++ pr_id id) idl
-	++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++
-	let idl = List.map Option.get (List.filter (fun x -> not (x=None)) idl)in
-        pr_raw_tactic_env
-	  (idl @ List.map coerce_reference_to_id
-	    (List.map (fun (x, _, _) -> x) (List.filter (fun (_, redef, _) -> not redef) l)))
-	  (Global.env())
-	  body in
-      hov 1
-        (pr_locality local ++ str "Ltac " ++
-        prlist_with_sep (fun () -> fnl() ++ str"with ") pr_tac_body l)
-  | VernacCreateHintDb (local,dbname,b) ->
-      hov 1 (pr_locality local ++ str "Create HintDb " ++ 
-		str dbname ++ (if b then str" discriminated" else mt ()))
-  | VernacRemoveHints (local, dbnames, ids) ->
-      hov 1 (pr_locality local ++ str "Remove Hints " ++
-	       prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++ 
-	       pr_opt_hintbases dbnames)
-  | VernacHints (local,dbnames,h) ->
-      pr_hints local dbnames h pr_constr pr_constr_pattern_expr
-  | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) ->
-      hov 2
-        (pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++
-	 prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++
-         pr_syntax_modifiers
-	   (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v]))
-  | VernacDeclareImplicits (local,q,[]) ->
-      hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++ 
-	pr_smart_global q)
-  | VernacDeclareImplicits (local,q,impls) ->
-      hov 1 (pr_section_locality local ++ str"Implicit Arguments " ++ 
-	spc() ++ pr_smart_global q ++ spc() ++
-	prlist_with_sep spc (fun imps ->
-	  str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
-	  impls)
-  | VernacArguments (local, q, impl, nargs, mods) ->
-      hov 2 (pr_section_locality local ++ str"Arguments" ++ spc() ++
-        pr_smart_global q ++
-      let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
-      let pr_if b x = if b then x else str "" in
-      let pr_br imp max x = match imp, max with
-        | true, false -> str "[" ++ x ++ str "]"
-        | true, true -> str "{" ++ x ++ str "}"
-        | _ -> x in
-      let rec aux n l =
-        match n, l with
-        | 0, l -> spc () ++ str"/" ++ aux ~-1 l
-        | _, [] -> mt()
-        | n, (id,k,s,imp,max) :: tl ->
-            spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
-            aux (n-1) tl in
-      prlist_with_sep (fun () -> str", ") (aux nargs) impl ++
-      if mods <> [] then str" : " else str"" ++
-      prlist_with_sep (fun () -> str", " ++ spc()) (function
-        | `SimplDontExposeCase -> str "simpl nomatch"
-        | `SimplNeverUnfold -> str "simpl never"
-        | `DefaultImplicits -> str "default implicits"
-        | `Rename -> str "rename"
-        | `ExtraScopes -> str "extra scopes"
-        | `ClearImplicits -> str "clear implicits"
-        | `ClearScopes -> str "clear scopes")
-        mods)
-  | VernacReserve bl ->
-      let n = List.length (List.flatten (List.map fst bl)) in
-      hov 2 (str"Implicit Type" ++
-        str (if n > 1 then "s " else " ") ++
-        pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
-  | VernacGeneralizable (local, g) ->
-      hov 1 (pr_locality local ++ str"Generalizable Variable" ++
-		match g with
-		| None -> str "s none"
-		| Some [] -> str "s all"
-		| Some idl ->
-		    str (if List.length idl > 1 then "s " else " ") ++
-		      prlist_with_sep spc pr_lident idl)
-  | VernacSetOpacity(b,[k,l]) when k=Conv_oracle.transparent ->
-      hov 1 (str"Transparent" ++ pr_non_locality b ++
-             spc() ++ prlist_with_sep sep pr_smart_global l)
-  | VernacSetOpacity(b,[Conv_oracle.Opaque,l]) ->
-      hov 1 (str"Opaque" ++ pr_non_locality b ++
-             spc() ++ prlist_with_sep sep pr_smart_global l)
-  | VernacSetOpacity (local,l) ->
-      let pr_lev = function
-          Conv_oracle.Opaque -> str"opaque"
-        | Conv_oracle.Expand -> str"expand"
-        | l when l = Conv_oracle.transparent -> str"transparent"
-        | Conv_oracle.Level n -> int n in
-      let pr_line (l,q) =
-        hov 2 (pr_lev l ++ spc() ++
-               str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]") in
-      hov 1 (pr_non_locality local ++ str"Strategy" ++ spc() ++
-             hv 0 (prlist_with_sep sep pr_line l))
-  | VernacUnsetOption (l,na) ->
-      hov 1 (pr_locality_full l ++ str"Unset" ++ spc() ++ pr_printoption na None)
-  | VernacSetOption (l,na,v) ->
-      hov 2 (pr_locality_full l ++ str"Set" ++ spc() ++ pr_set_option na v)
-  | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l))
-  | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l))
-  | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l))
-  | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None)
-  | VernacCheckMayEval (r,io,c) ->
-      let pr_mayeval r c = match r with
-      | Some r0 ->
-          hov 2 (str"Eval" ++ spc() ++
-          pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
-          spc() ++ str"in" ++ spc () ++ pr_lconstr c)
-      | None -> hov 2 (str"Check" ++ spc() ++ pr_lconstr c)
-      in
-      (if io = None then mt() else int (Option.get io) ++ str ": ") ++
-      pr_mayeval r c
-  | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c)
-  | VernacDeclareReduction (b,s,r) ->
-     pr_locality b ++ str "Declare Reduction " ++ str s ++ str " := " ++
-     pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
-  | VernacPrint p ->
-      let pr_printable = function
-	| PrintFullContext -> str"Print All"
-	| PrintSectionContext s ->
-            str"Print Section" ++ spc() ++ Libnames.pr_reference s
-	| PrintGrammar ent ->
-            str"Print Grammar" ++ spc() ++ str ent
-	| PrintLoadPath dir -> str"Print LoadPath" ++ pr_opt pr_dirpath dir
-	| PrintModules -> str"Print Modules"
-	| PrintMLLoadPath -> str"Print ML Path"
-	| PrintMLModules -> str"Print ML Modules"
-	| PrintGraph -> str"Print Graph"
-	| PrintClasses -> str"Print Classes"
-	| PrintTypeClasses -> str"Print TypeClasses"
-	| PrintInstances qid -> str"Print Instances" ++ spc () ++ pr_smart_global qid
-	| PrintLtac qid -> str"Print Ltac" ++ spc() ++ pr_ltac_ref qid
-	| PrintCoercions -> str"Print Coercions"
-	| PrintCoercionPaths (s,t) -> str"Print Coercion Paths" ++ spc() ++ pr_class_rawexpr s ++ spc() ++ pr_class_rawexpr t
-	| PrintCanonicalConversions -> str"Print Canonical Structures"
-	| PrintTables -> str"Print Tables"
-	| PrintHintGoal -> str"Print Hint"
-	| PrintHint qid -> str"Print Hint" ++ spc() ++ pr_smart_global qid
-	| PrintHintDb -> str"Print Hint *"
-	| PrintHintDbName s -> str"Print HintDb" ++ spc() ++ str s
-	| PrintRewriteHintDbName s -> str"Print Rewrite HintDb" ++ spc() ++ str s
-	| PrintUniverses (b, fopt) -> Printf.ksprintf str "Print %sUniverses" (if b then "Sorted " else "") ++ pr_opt str fopt
-	| PrintName qid -> str"Print" ++ spc()  ++ pr_smart_global qid
-	| PrintModuleType qid -> str"Print Module Type" ++ spc() ++ pr_reference qid
-	| PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid
-	| PrintInspect n -> str"Inspect" ++ spc() ++ int n
-	| PrintScopes -> str"Print Scopes"
-	| PrintScope s -> str"Print Scope" ++ spc() ++ str s
-	| PrintVisibility s -> str"Print Visibility" ++ pr_opt str s
-	| PrintAbout qid -> str"About" ++ spc()  ++ pr_smart_global qid
-	| PrintImplicit qid -> str"Print Implicit" ++ spc()  ++ pr_smart_global qid
-(* spiwack: command printing all the axioms and section variables used in a
-         term *)
-	| PrintAssumptions (b,qid) -> (if b then str"Print Assumptions" else str"Print Opaque Dependencies")
-	    ++ spc() ++ pr_smart_global qid
-      in pr_printable p
-  | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr
-  | VernacLocate loc ->
-      let pr_locate =function
-	| LocateTerm qid -> pr_smart_global qid
-	| LocateFile f -> str"File" ++ spc() ++ qs f
-	| LocateLibrary qid -> str"Library" ++ spc () ++ pr_module qid
-	| LocateModule qid -> str"Module" ++ spc () ++ pr_module qid
-	| LocateTactic qid -> str"Ltac" ++ spc () ++ pr_ltac_ref qid
-      in str"Locate" ++ spc() ++ pr_locate loc
-  | VernacComments l ->
-      hov 2
-        (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l)
-  | VernacNop -> mt()
-
-  (* Toplevel control *)
-  | VernacToplevelControl exn -> pr_topcmd exn
-
-  (* For extension *)
-  | VernacExtend (s,c) -> pr_extend s c
-  | VernacProof (None, None) -> str "Proof"
-  | VernacProof (None, Some l) -> str "Proof using" ++spc()++ prlist pr_lident l
-  | VernacProof (Some te, None) -> str "Proof with" ++ spc() ++ pr_raw_tactic te
-  | VernacProof (Some te, Some l) -> 
-      str "Proof using" ++spc()++ prlist pr_lident l ++ spc() ++
-      str "with" ++ spc() ++pr_raw_tactic te
-  | VernacProofMode s -> str ("Proof Mode "^s)
-  | VernacBullet b -> begin match b with
-      | Dash -> str"-"
-      | Star -> str"*"
-      | Plus -> str"+"
-  end ++ spc()
-  | VernacSubproof None -> str "{"
-  | VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i
-  | VernacEndSubproof -> str "}"
-
-and pr_extend s cl =
-  let pr_arg a =
-    try pr_gen (Global.env()) a
-    with Failure _ -> str ("<error in "^s^">") in
-  try
-    let rls = List.assoc s (Egrammar.get_extend_vernac_grammars()) in
-    let rl = match_vernac_rule (List.map Genarg.genarg_tag cl) rls in
-    let start,rl,cl =
-      match rl with
-      | Egrammar.GramTerminal s :: rl -> str s, rl, cl
-      | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl
-      | [] -> anomaly "Empty entry" in
-    let (pp,_) =
-      List.fold_left
-        (fun (strm,args) pi ->
-          let pp,args = match pi with
-          | Egrammar.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args)
-          | Egrammar.GramTerminal s -> (str s, args) in
-          (strm ++ spc() ++ pp), args)
-        (start,cl) rl in
-    hov 1 pp
-  with Not_found ->
-    hov 1 (str ("TODO("^s) ++ prlist_with_sep sep pr_arg cl ++ str ")")
-
-in pr_vernac
-
-let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v
diff --git a/parsing/printmod.ml b/parsing/printmod.ml
deleted file mode 100644
index ad791de9..00000000
--- a/parsing/printmod.ml
+++ /dev/null
@@ -1,279 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Util
-open Names
-open Declarations
-open Nameops
-open Libnames
-open Goptions
-
-(** Note: there is currently two modes for printing modules.
-    - The "short" one, that just prints the names of the fields.
-    - The "rich" one, that also tries to print the types of the fields.
-    The short version used to be the default behavior, but now we print
-    types by default. The following option allows to change this.
-    Technically, the environments in this file are either None in
-    the "short" mode or (Some env) in the "rich" one.
-*)
-
-let short = ref false
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "short module printing";
-      optkey   = ["Short";"Module";"Printing"];
-      optread  = (fun () -> !short) ;
-      optwrite = ((:=) short) }
-
-let get_new_id locals id =
-  let rec get_id l id =
-    let dir = make_dirpath [id] in
-      if not (Nametab.exists_module dir) then
-	id
-      else
-	get_id (id::l) (Namegen.next_ident_away id l)
-  in
-    get_id (List.map snd locals) id
-
-let rec print_local_modpath locals = function
-  | MPbound mbid -> pr_id (List.assoc mbid locals)
-  | MPdot(mp,l) ->
-      print_local_modpath locals mp ++ str "." ++ pr_lab l
-  | MPfile _ -> raise Not_found
-
-let print_modpath locals mp =
-  try (* must be with let because streams are lazy! *)
-    let qid = Nametab.shortest_qualid_of_module mp in
-      pr_qualid qid
-  with
-    | Not_found -> print_local_modpath locals mp
-
-let print_kn locals kn =
-  try
-    let qid = Nametab.shortest_qualid_of_modtype kn in
-      pr_qualid qid
-  with
-      Not_found ->
-	try
-	  print_local_modpath locals kn
-	with
-	    Not_found -> print_modpath locals kn
-
-(** Each time we have to print a non-globally visible structure,
-    we place its elements in a fake fresh namespace. *)
-
-let mk_fake_top =
-  let r = ref 0 in
-  fun () -> incr r; id_of_string ("FAKETOP"^(string_of_int !r))
-
-let nametab_register_dir mp =
-  let id = mk_fake_top () in
-  let dir = make_dirpath [id] in
-  Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,empty_dirpath)))
-
-(** Nota: the [global_reference] we register in the nametab below
-    might differ from internal ones, since we cannot recreate here
-    the canonical part of constant and inductive names, but only
-    the user names. This works nonetheless since we search now
-    [Nametab.the_globrevtab] modulo user name. *)
-
-let nametab_register_body mp dir (l,body) =
-  let push id ref =
-    Nametab.push (Nametab.Until (1+List.length (repr_dirpath dir)))
-      (make_path dir id) ref
-  in
-  match body with
-    | SFBmodule _ -> () (* TODO *)
-    | SFBmodtype _ -> () (* TODO *)
-    | SFBconst _ ->
-      push (id_of_label l) (ConstRef (make_con mp empty_dirpath l))
-    | SFBmind mib ->
-      let mind = make_mind mp empty_dirpath l in
-      Array.iteri
-	(fun i mip ->
-	  push mip.mind_typename (IndRef (mind,i));
-	  Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1)))
-	    mip.mind_consnames)
-	mib.mind_packets
-
-let nametab_register_module_body mp struc =
-  (* If [mp] is a globally visible module, we simply import it *)
-  try Declaremods.really_import_module mp
-  with Not_found ->
-    (* Otherwise we try to emulate an import by playing with nametab *)
-    nametab_register_dir mp;
-    List.iter (nametab_register_body mp empty_dirpath) struc
-
-let nametab_register_module_param mbid seb =
-  (* For algebraic seb, we use a Declaremods function that converts into mse *)
-  try Declaremods.process_module_seb_binding mbid seb
-  with e when Errors.noncritical e ->
-    (* Otherwise, for expanded structure, we try to play with the nametab *)
-    match seb with
-      | SEBstruct struc ->
-        let mp = MPbound mbid in
-        let dir = make_dirpath [id_of_mbid mbid] in
-        nametab_register_dir mp;
-        List.iter (nametab_register_body mp dir) struc
-      | _ -> ()
-
-let print_body is_impl env mp (l,body) =
-  let name = str (string_of_label l) in
-  hov 2 (match body with
-    | SFBmodule _ -> str "Module " ++ name
-    | SFBmodtype _ -> str "Module Type " ++ name
-    | SFBconst cb ->
-      (match cb.const_body with
-	| Def _ -> str "Definition "
-	| OpaqueDef _ when is_impl -> str "Theorem "
-	| _ -> str "Parameter ") ++ name ++
-      (match env with
-	  | None -> mt ()
-	  | Some env ->
-	    str " :" ++ spc () ++
-	    hov 0 (Printer.pr_ltype_env env
-		     (Typeops.type_of_constant_type env cb.const_type)) ++
-	    (match cb.const_body with
-	      | Def l when is_impl ->
-		spc () ++
-		hov 2 (str ":= " ++
-		       Printer.pr_lconstr_env env (Declarations.force l))
-	      | _ -> mt ()) ++
-            str ".")
-    | SFBmind mib ->
-      try
-	let env = Option.get env in
-	Printer.pr_mutual_inductive_body env (make_mind mp empty_dirpath l) mib
-      with e when Errors.noncritical e ->
-	(if mib.mind_finite then str "Inductive " else str "CoInductive")
-	++ name)
-
-let print_struct is_impl env mp struc =
-  prlist_with_sep spc (print_body is_impl env mp) struc
-
-let rec flatten_app mexpr l = match mexpr with
-  | SEBapply (mexpr, SEBident arg,_) -> flatten_app mexpr (arg::l)
-  | SEBident mp -> mp::l
-  | _ -> assert false
-
-let rec print_modtype env mp locals mty =
-  match mty with
-    | SEBident kn -> print_kn locals kn
-    | SEBfunctor (mbid,mtb1,mtb2) ->
-      let mp1 = MPbound mbid in
-      let env' = Option.map
-	  (Modops.add_module (Modops.module_body_of_type mp1 mtb1)) env in
-      let seb1 = Option.default mtb1.typ_expr mtb1.typ_expr_alg in
-      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals
-      in
-      nametab_register_module_param mbid seb1;
-      hov 2 (str "Funsig" ++ spc () ++ str "(" ++
-	       pr_id (id_of_mbid mbid) ++ str ":" ++
-	       print_modtype env mp1 locals seb1 ++
-	       str ")" ++ spc() ++ print_modtype env' mp locals' mtb2)
-  | SEBstruct (sign) ->
-      let env' = Option.map
-	(Modops.add_signature mp sign Mod_subst.empty_delta_resolver) env in
-      nametab_register_module_body mp sign;
-      hv 2 (str "Sig" ++ spc () ++ print_struct false env' mp sign ++
-	    brk (1,-2) ++ str "End")
-  | SEBapply _ ->
-      let lapp = flatten_app mty [] in
-      let fapp = List.hd lapp in
-      let mapp = List.tl lapp in
-      hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++
-		 prlist_with_sep spc (print_modpath locals) mapp ++ str")")
-  | SEBwith(seb,With_definition_body(idl,cb))->
-      let env' = None in (* TODO: build a proper environment if env <> None *)
-      let s = (String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype env' mp locals seb ++ spc() ++ str "with" ++ spc() ++
-	       str "Definition"++ spc() ++ str s ++ spc() ++  str ":="++ spc())
-  | SEBwith(seb,With_module_body(idl,mp))->
-      let s =(String.concat "." (List.map string_of_id idl)) in
-      hov 2 (print_modtype env mp locals seb ++ spc() ++ str "with" ++ spc() ++
-	       str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc())
-
-let rec print_modexpr env mp locals mexpr = match mexpr with
-  | SEBident mp -> print_modpath locals mp
-  | SEBfunctor (mbid,mty,mexpr) ->
-      let mp' = MPbound mbid in
-      let env' = Option.map
-	(Modops.add_module (Modops.module_body_of_type mp' mty)) env in
-      let typ = Option.default mty.typ_expr mty.typ_expr_alg in
-      let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in
-      nametab_register_module_param mbid typ;
-      hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++
-	     str ":" ++ print_modtype env mp' locals typ ++
-      str ")" ++ spc () ++ print_modexpr env' mp locals' mexpr)
-  | SEBstruct struc ->
-      let env' = Option.map
-	(Modops.add_signature mp struc Mod_subst.empty_delta_resolver) env in
-      nametab_register_module_body mp struc;
-      hv 2 (str "Struct" ++ spc () ++ print_struct true env' mp struc ++
-	    brk (1,-2) ++ str "End")
-  | SEBapply _ ->
-      let lapp = flatten_app mexpr [] in
-      hov 3 (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")")
-  | SEBwith (_,_)-> anomaly "Not available yet"
-
-
-let rec printable_body dir =
-  let dir = pop_dirpath dir in
-    dir = empty_dirpath ||
-    try
-      match Nametab.locate_dir (qualid_of_dirpath dir) with
-	  DirOpenModtype _ -> false
-	| DirModule _ | DirOpenModule _ -> printable_body dir
-	| _ -> true
-    with
-	Not_found -> true
-
-(** Since we might play with nametab above, we should reset to prior
-    state after the printing *)
-
-let print_modexpr' env mp mexpr =
-  States.with_state_protection (fun e -> eval_ppcmds (print_modexpr env mp [] e)) mexpr
-let print_modtype' env mp mty =
-  States.with_state_protection (fun e -> eval_ppcmds (print_modtype env mp [] e)) mty
-
-let print_module' env mp with_body mb =
-  let name = print_modpath [] mp in
-  let body = match with_body, mb.mod_expr with
-    | false, _
-    | true, None -> mt()
-    | true, Some mexpr ->
-	spc () ++ str ":= " ++ print_modexpr' env mp mexpr
-  in
-  let modtype = brk (1,1) ++ str": " ++ print_modtype' env mp mb.mod_type
-  in
-  hv 0 (str "Module " ++ name ++ modtype ++ body)
-
-exception ShortPrinting
-
-let print_module with_body mp =
-  let me = Global.lookup_module mp in
-  try
-    if !short then raise ShortPrinting;
-    print_module' (Some (Global.env ())) mp with_body me ++ fnl ()
-  with e when Errors.noncritical e ->
-    print_module' None mp with_body me ++ fnl ()
-
-let print_modtype kn =
-  let mtb = Global.lookup_modtype kn in
-  let name = print_kn [] kn in
-  hv 1
-    (str "Module Type " ++ name ++ str " =" ++ spc () ++
-     (try
-	if !short then raise ShortPrinting;
-	print_modtype' (Some (Global.env ())) kn mtb.typ_expr
-      with e when Errors.noncritical e ->
-	print_modtype' None kn mtb.typ_expr))
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
deleted file mode 100644
index 7bcd1cf2..00000000
--- a/parsing/tacextend.ml4
+++ /dev/null
@@ -1,238 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "tools/compat5b.cmo" i*)
-
-open Util
-open Genarg
-open Q_util
-open Q_coqast
-open Argextend
-open Pcoq
-open Extrawit
-open Egrammar
-open Compat
-
-let rec make_patt = function
-  | [] -> <:patt< [] >>
-  | GramNonTerminal(loc',_,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      <:patt< [ $lid:p$ :: $make_patt l$ ] >>
-  | _::l -> make_patt l
-
-let rec make_when loc = function
-  | [] -> <:expr< True >>
-  | GramNonTerminal(loc',t,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      let l = make_when loc l in
-      let loc = join_loc loc' loc in
-      let t = mlexpr_of_argtype loc' t in
-      <:expr< Genarg.genarg_tag $lid:p$ = $t$ && $l$ >>
-  | _::l -> make_when loc l
-
-let rec make_let e = function
-  | [] -> e
-  | GramNonTerminal(loc,t,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      let loc = join_loc loc (MLast.loc_of_expr e) in
-      let e = make_let e l in
-      let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in
-      <:expr< let $lid:p$ = $v$ in $e$ >>
-  | _::l -> make_let e l
-
-let rec extract_signature = function
-  | [] -> []
-  | GramNonTerminal (_,t,_,_) :: l -> t :: extract_signature l
-  | _::l -> extract_signature l
-
-let check_unicity s l =
-  let l' = List.map (fun (l,_) -> extract_signature l) l in
-  if not (Util.list_distinct l') then
-    Pp.warning_with !Pp_control.err_ft
-      ("Two distinct rules of tactic entry "^s^" have the same\n"^
-      "non-terminals in the same order: put them in distinct tactic entries")
-
-let make_clause (pt,e) =
-  (make_patt pt,
-   vala (Some (make_when (MLast.loc_of_expr e) pt)),
-   make_let e pt)
-
-let make_fun_clauses loc s l =
-  check_unicity s l;
-  Compat.make_fun loc (List.map make_clause l)
-
-let rec make_args = function
-  | [] -> <:expr< [] >>
-  | GramNonTerminal(loc,t,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      <:expr< [ Genarg.in_gen $make_wit loc t$ $lid:p$ :: $make_args l$ ] >>
-  | _::l -> make_args l
-
-let rec make_eval_tactic e = function
-  | [] -> e
-  | GramNonTerminal(loc,tag,_,Some p)::l when is_tactic_genarg tag ->
-      let p = Names.string_of_id p in
-      let loc = join_loc loc (MLast.loc_of_expr e) in
-      let e = make_eval_tactic e l in
-      <:expr< let $lid:p$ = $lid:p$ in $e$ >>
-  | _::l -> make_eval_tactic e l
-
-let rec make_fun e = function
-  | [] -> e
-  | GramNonTerminal(loc,_,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      <:expr< fun $lid:p$ -> $make_fun e l$ >>
-  | _::l -> make_fun e l
-
-let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function
-  | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >>
-  | GramNonTerminal (loc,nt,_,sopt) -> <:expr< None >>
-
-let make_prod_item = function
-  | GramTerminal s -> <:expr< Egrammar.GramTerminal $str:s$ >>
-  | GramNonTerminal (loc,nt,g,sopt) ->
-      <:expr< Egrammar.GramNonTerminal $default_loc$ $mlexpr_of_argtype loc nt$
-      $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >>
-
-let mlexpr_of_clause =
-  mlexpr_of_list (fun (a,b) -> mlexpr_of_list make_prod_item a)
-
-let rec make_tags loc = function
-  | [] -> <:expr< [] >>
-  | GramNonTerminal(loc',t,_,Some p)::l ->
-      let l = make_tags loc l in
-      let loc = join_loc loc' loc in
-      let t = mlexpr_of_argtype loc' t in
-      <:expr< [ $t$ :: $l$ ] >>
-  | _::l -> make_tags loc l
-
-let make_one_printing_rule se (pt,e) =
-  let level = mlexpr_of_int 0 in (* only level 0 supported here *)
-  let loc = MLast.loc_of_expr e in
-  let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in
-  <:expr< ($se$, $make_tags loc pt$, ($level$, $prods$)) >>
-
-let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
-
-let rec possibly_empty_subentries loc = function
-  | [] -> []
-  | (s,prodsl) :: l ->
-    let rec aux = function
-    | [] -> (false,<:expr< None >>)
-    | prods :: rest ->
-      try
-        let l = List.map (function
-        | GramNonTerminal(_,(List0ArgType _|
-                             OptArgType _|
-                             ExtraArgType _ as t),_,_)->
-            (* This possibly parses epsilon *)
-            let rawwit = make_rawwit loc t in
-            <:expr< match Genarg.default_empty_value $rawwit$ with
-                    [ None -> failwith ""
-                    | Some v ->
-                        Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign
-                          (Genarg.in_gen $rawwit$ v) ] >>
-        | GramTerminal _ | GramNonTerminal(_,_,_,_) ->
-            (* This does not parse epsilon (this Exit is static time) *)
-             raise Exit) prods in
-        if has_extraarg prods then
-          (true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$
-                        with [ Failure "" -> $snd (aux rest)$ ] >>)
-        else
-          (true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>)
-      with Exit -> aux rest in
-    let (nonempty,v) = aux prodsl in
-    if nonempty then (s,v) :: possibly_empty_subentries loc l
-    else possibly_empty_subentries loc l
-
-let possibly_atomic loc prods =
-  let l = list_map_filter (function
-    | GramTerminal s :: l, _ -> Some (s,l)
-    | _ -> None) prods in
-  possibly_empty_subentries loc (list_factorize_left l)
-
-let declare_tactic loc s cl =
-  let se = mlexpr_of_string s in
-  let pp = make_printing_rule se cl in
-  let gl = mlexpr_of_clause cl in
-  let hide_tac (p,e) =
-    (* reste a definir les fonctions cachees avec des noms frais *)
-    let stac = "h_"^s in
-    let e =
-      make_fun
-        <:expr<
-          Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$
-        >>
-      p in
-    <:str_item< value $lid:stac$ = $e$ >>
-  in
-  let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in
-  let atomic_tactics =
-    mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x))
-      (possibly_atomic loc cl) in
-  declare_str_items loc
-   (hidden @
-    [ <:str_item< do {
-      try
-        let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in
-        List.iter
-          (fun (s,l) -> match l with
-           [ Some l ->
-              Tacinterp.add_primitive_tactic s
-              (Tacexpr.TacAtom($default_loc$,
-                 Tacexpr.TacExtend($default_loc$,$se$,l)))
-           | None -> () ])
-          $atomic_tactics$
-      with [ e when Errors.noncritical e ->
-	    Pp.msg_warning
-	      (Stream.iapp
-	        (Pp.str ("Exception in tactic extend " ^ $se$ ^": "))
-	        (Errors.print e)) ];
-      Egrammar.extend_tactic_grammar $se$ $gl$;
-      List.iter Pptactic.declare_extra_tactic_pprule $pp$; } >>
-    ])
-
-open Pcaml
-open PcamlSig
-
-EXTEND
-  GLOBAL: str_item;
-  str_item:
-    [ [ "TACTIC"; "EXTEND"; s = tac_name;
-        OPT "|"; l = LIST1 tacrule SEP "|";
-        "END" ->
-         declare_tactic loc s l ] ]
-  ;
-  tacrule:
-    [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]"
-        ->
-	  if match List.hd l with GramNonTerminal _ -> true | _ -> false then
-	    (* En attendant la syntaxe de tacticielles *)
-	    failwith "Tactic syntax must start with an identifier";
-	  (l,e)
-    ] ]
-  ;
-  tacargs:
-    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name false None e "" in
-        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
-        let t, g = interp_entry_name false None e sep in
-        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | s = STRING ->
-	if s = "" then Util.user_err_loc (loc,"",Pp.str "Empty terminal.");
-        GramTerminal s
-    ] ]
-  ;
-  tac_name:
-    [ [ s = LIDENT -> s
-      | s = UIDENT -> s
-    ] ]
-  ;
-  END
-
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
deleted file mode 100644
index 9355a2a5..00000000
--- a/parsing/tactic_printer.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Util
-open Sign
-open Evd
-open Tacexpr
-open Proof_type
-open Logic
-open Printer
-
-let pr_tactic = function
-  | TacArg (_,Tacexp t) ->
-      (*top tactic from tacinterp*)
-      Pptactic.pr_glob_tactic (Global.env()) t
-  | t ->
-      Pptactic.pr_tactic (Global.env()) t
-
-let pr_rule = function
-  | Prim r -> hov 0 (pr_prim_rule r)
-  | Nested(cmpd,_) ->
-      begin
-	match cmpd with
-	  | Tactic (texp,_) -> hov 0 (pr_tactic texp)
-      end
-  | Daimon -> str "<Daimon>"
-  | Decl_proof _ -> str "proof"
-
-let uses_default_tac = function
-  | Nested(Tactic(_,dflt),_) -> dflt
-  | _ -> false
-
-(* Does not print change of evars *)
-let pr_rule_dot = function
-  | Prim Change_evars ->str "PC: ch_evars" ++  mt ()
-      (* PC: this might be redundant *)
-  | r ->
-      pr_rule r ++ if uses_default_tac r then str "..." else str"."
-
-let pr_rule_dot_fnl = function
-  | Nested (Tactic (TacAtom (_,(TacMutualFix (true,_,_,_)
-                              | TacMutualCofix (true,_,_))),_),_) ->
-      (* Very big hack to not display hidden tactics in "Theorem with" *)
-      (* (would not scale!) *)
-      mt ()
-   | Prim Change_evars -> mt ()
-   | r -> pr_rule_dot r ++ fnl ()
-
-exception Different
-
-let rec print_proof sigma osign pf =
-  (* spiwack: [osign] is currently ignored, not sure if this function is even used. *)
-  let hyps = Environ.named_context_of_val (Goal.V82.hyps sigma pf.goal) in
-  match pf.ref with
-    | None ->
-	hov 0 (pr_goal {sigma = sigma; it=pf.goal })
-    | Some(r,spfl) ->
-    	hov 0
-	  (hov 0 (pr_goal {sigma = sigma; it=pf.goal }) ++
-	   spc () ++ str" BY " ++
-	   hov 0 (pr_rule r) ++ fnl () ++
-	   str"  " ++
-	   hov 0 (prlist_with_sep pr_fnl (print_proof sigma hyps) spfl))
-
-let pr_change sigma gl =
-  str"change " ++
-  pr_lconstr_env (Goal.V82.env sigma gl) (Goal.V82.concl sigma gl) ++ str"."
-
-let print_decl_script tac_printer ?(nochange=true) sigma pf =
-  let rec print_prf pf =
-  match pf.ref with
-    | None ->
-	(if nochange then
-	   (str"<Your Proof Text here>")
-	 else
-	   pr_change sigma pf.goal)
-	++ fnl ()
-    | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)"
-    | Some (Prim Change_evars,[subpf]) -> print_prf subpf
-    | _ -> anomaly "Not Applicable" in
-  print_prf pf
-
-let print_script ?(nochange=true) sigma pf =
-  let rec print_prf pf =
-  match pf.ref with
-    | None ->
-        (if nochange then
-	   (str"<Your Tactic Text here>")
-	 else
-	   pr_change sigma pf.goal)
-	++ fnl ()
-    | Some(Decl_proof opened,script) ->
-	assert (List.length script = 1);
-	begin
-	  if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())
-	end ++
-	  begin
-	    hov 0 (str "proof." ++ fnl () ++
-		     print_decl_script print_prf
-		     ~nochange sigma (List.hd script))
-	  end ++ fnl () ++
-	  begin
-	    if opened then mt () else (str "end proof." ++ fnl ())
-	  end
-    | Some(Daimon,spfl) ->
-	((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++
-	   prlist_with_sep pr_fnl print_prf spfl )
-    | Some(rule,spfl) ->
-	((if nochange then (mt ()) else (pr_change sigma pf.goal ++ fnl ())) ++
-	   pr_rule_dot_fnl rule ++
-	   prlist_with_sep pr_fnl print_prf spfl ) in
-  print_prf pf
-
-(* printed by Show Script command *)
-
-let print_treescript ?(nochange=true) sigma pf =
-  let rec print_prf pf =
-    match pf.ref with
-    | None ->
-        if nochange then
-	  str"<Your Proof Text here>"
-	else pr_change sigma pf.goal
-    | Some(Decl_proof opened,script) ->
-	assert (List.length script = 1);
-	begin
-	  if nochange then mt () else pr_change sigma pf.goal ++ fnl ()
-	end ++
-	hov 0
-	  begin str "proof." ++ fnl () ++
-	    print_decl_script print_prf ~nochange sigma (List.hd script)
-	  end ++ fnl () ++
-	begin
-	  if opened then mt () else (str "end proof." ++ fnl ())
-	end
-    | Some(Daimon,spfl) ->
-	(if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++
-	prlist_with_sep pr_fnl (print_script ~nochange sigma) spfl
-    | Some(r,spfl) ->
-        let indent = if List.length spfl >= 2 then 1 else 0 in
-        (if nochange then mt () else pr_change sigma pf.goal ++ fnl ()) ++
-        hv indent (pr_rule_dot_fnl r ++ prlist_with_sep fnl print_prf spfl)
-  in hov 0 (print_prf pf)
-
-let rec print_info_script sigma osign pf =
-  let sign = Goal.V82.hyps sigma pf.goal in
-  match pf.ref with
-    | None -> (mt ())
-    | Some(r,spfl) ->
-        (pr_rule r ++
-           match spfl with
-             | [pf1] ->
-                 if pf1.ref = None then
-		   (str "." ++ fnl ())
-                 else
-		   (str";" ++ brk(1,3) ++
-		      print_info_script sigma
-		      (Environ.named_context_of_val sign) pf1)
-             | _ -> (str"." ++ fnl () ++
-                       prlist_with_sep pr_fnl
-                         (print_info_script sigma
-			    (Environ.named_context_of_val sign)) spfl))
-
-let format_print_info_script sigma osign pf =
-  hov 0 (print_info_script sigma osign pf)
-
-
diff --git a/parsing/tok.ml b/parsing/tok.ml
index 5b9aed6d..efd57968 100644
--- a/parsing/tok.ml
+++ b/parsing/tok.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        *)
@@ -17,8 +17,22 @@ type t =
   | INT of string
   | STRING of string
   | LEFTQMARK
+  | BULLET of string
   | EOI
 
+let equal t1 t2 = match t1, t2 with
+| KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2
+| METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2
+| PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2
+| IDENT s1, IDENT s2 -> CString.equal s1 s2
+| FIELD s1, FIELD s2 -> CString.equal s1 s2
+| INT s1, INT s2 -> CString.equal s1 s2
+| STRING s1, STRING s2 -> CString.equal s1 s2
+| LEFTQMARK, LEFTQMARK -> true
+| BULLET s1, BULLET s2 -> CString.equal s1 s2
+| EOI, EOI -> true
+| _ -> false
+
 let extract_string = function
   | KEYWORD s -> s
   | IDENT s -> s
@@ -28,6 +42,7 @@ let extract_string = function
   | FIELD s -> s
   | INT s -> s
   | LEFTQMARK -> "?"
+  | BULLET s -> s
   | EOI -> ""
 
 let to_string = function
@@ -39,13 +54,16 @@ let to_string = function
   | INT s -> Format.sprintf "INT %s" s
   | STRING s -> Format.sprintf "STRING %S" s
   | LEFTQMARK -> "LEFTQMARK"
+  | BULLET s -> Format.sprintf "STRING %S" s
   | EOI -> "EOI"
 
 let match_keyword kwd = function
   | KEYWORD kwd' when kwd = kwd' -> true
   | _ -> false
 
-let print ppf tok = Format.fprintf ppf "%s" (to_string tok)
+(* Needed to fix Camlp4 signature.
+ Cannot use Pp because of silly Tox -> Compat -> Pp dependency *)
+let print ppf tok = Format.pp_print_string ppf (to_string tok)
 
 (** For camlp5, conversion from/to [Plexing.pattern],
     and a match function analoguous to [Plexing.default_match] *)
@@ -59,6 +77,7 @@ let of_pattern = function
   | "INT", s -> INT s
   | "STRING", s -> STRING s
   | "LEFTQMARK", _ -> LEFTQMARK
+  | "BULLET", s -> BULLET s
   | "EOI", _ -> EOI
   | _ -> failwith "Tok.of_pattern: not a constructor"
 
@@ -71,6 +90,7 @@ let to_pattern = function
   | INT s -> "INT", s
   | STRING s -> "STRING", s
   | LEFTQMARK -> "LEFTQMARK", ""
+  | BULLET s -> "BULLET", s
   | EOI -> "EOI", ""
 
 let match_pattern =
@@ -84,7 +104,8 @@ let match_pattern =
     | "INT", "" -> (function INT s -> s | _ -> err ())
     | "STRING", "" -> (function STRING s -> s | _ -> err ())
     | "LEFTQMARK", "" -> (function LEFTQMARK -> ""  | _ -> err ())
+    | "BULLET", "" ->  (function BULLET s -> s  | _ -> err ())
     | "EOI", "" -> (function EOI -> "" | _ -> err ())
     | pat ->
 	let tok = of_pattern pat in
-	function tok' -> if tok = tok' then snd pat else err ()
+	function tok' -> if equal tok tok' then snd pat else err ()
diff --git a/parsing/tok.mli b/parsing/tok.mli
index 50a51198..feee1983 100644
--- a/parsing/tok.mli
+++ b/parsing/tok.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        *)
@@ -17,10 +17,12 @@ type t =
   | INT of string
   | STRING of string
   | LEFTQMARK
+  | BULLET of string
   | EOI
 
 val extract_string : t -> string
 val to_string : t -> string
+(* Needed to fit Camlp4 signature *)
 val print : Format.formatter -> t -> unit
 val match_keyword : string -> t -> bool
 (** for camlp5 *)
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
deleted file mode 100644
index 1df5fbbd..00000000
--- a/parsing/vernacextend.ml4
+++ /dev/null
@@ -1,105 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "tools/compat5b.cmo" i*)
-
-open Util
-open Genarg
-open Q_util
-open Q_coqast
-open Argextend
-open Tacextend
-open Pcoq
-open Egrammar
-open Compat
-
-let rec make_let e = function
-  | [] -> e
-  | GramNonTerminal(loc,t,_,Some p)::l ->
-      let p = Names.string_of_id p in
-      let loc = join_loc loc (MLast.loc_of_expr e) in
-      let e = make_let e l in
-      <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >>
-  | _::l -> make_let e l
-
-let check_unicity s l =
-  let l' = List.map (fun (_,l,_) -> extract_signature l) l in
-  if not (Util.list_distinct l') then
-    Pp.warning_with !Pp_control.err_ft
-      ("Two distinct rules of entry "^s^" have the same\n"^
-      "non-terminals in the same order: put them in distinct vernac entries")
-
-let make_clause (_,pt,e) =
-  (make_patt pt,
-   vala (Some (make_when (MLast.loc_of_expr e) pt)),
-   make_let e pt)
-
-let make_fun_clauses loc s l =
-  check_unicity s l;
-  Compat.make_fun loc (List.map make_clause l)
-
-let mlexpr_of_clause =
-  mlexpr_of_list
-    (fun (a,b,c) -> mlexpr_of_list make_prod_item 
-       (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b))
-
-let declare_command loc s nt cl =
-  let se = mlexpr_of_string s in
-  let gl = mlexpr_of_clause cl in
-  let funcl = make_fun_clauses loc s cl in
-  declare_str_items loc
-    [ <:str_item< do {
-	try Vernacinterp.vinterp_add $se$ $funcl$
-	with [ e when Errors.noncritical e ->
-	  Pp.msg_warning
-	    (Stream.iapp
-	       (Pp.str ("Exception in vernac extend " ^ $se$ ^": "))
-	       (Errors.print e)) ];
-	Egrammar.extend_vernac_command_grammar $se$ $nt$ $gl$
-      } >> ]
-
-open Pcaml
-open PcamlSig
-
-EXTEND
-  GLOBAL: str_item;
-  str_item:
-    [ [ "VERNAC"; "COMMAND"; "EXTEND"; s = UIDENT;
-        OPT "|"; l = LIST1 rule SEP "|";
-        "END" ->
-         declare_command loc s <:expr<None>> l 
-      | "VERNAC"; nt = LIDENT ; "EXTEND"; s = UIDENT;
-        OPT "|"; l = LIST1 rule SEP "|";
-        "END" ->
-          declare_command loc s <:expr<Some $lid:nt$>> l ] ]
-  ;
-  (* spiwack: comment-by-guessing: it seems that the isolated string (which
-      otherwise could have been another argument) is not passed to the
-      VernacExtend interpreter function to discriminate between the clauses. *)
-  rule:
-    [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]"
-        ->
-      if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty.");
-      (Some s,l,<:expr< fun () -> $e$ >>)
-      | "[" ; "-" ; l = LIST1 args ; "]" ; "->" ; "[" ; e = Pcaml.expr ; "]" ->
-	  (None,l,<:expr< fun () -> $e$ >>)
-    ] ]
-  ;
-  args:
-    [ [ e = LIDENT; "("; s = LIDENT; ")" ->
-        let t, g = interp_entry_name false None e "" in
-        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" ->
-        let t, g = interp_entry_name false None e sep in
-        GramNonTerminal (loc, t, g, Some (Names.id_of_string s))
-      | s = STRING ->
-        GramTerminal s
-    ] ]
-  ;
-  END
-;;
diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v
new file mode 100644
index 00000000..bc5a3900
--- /dev/null
+++ b/plugins/btauto/Algebra.v
@@ -0,0 +1,591 @@
+Require Import Bool PArith DecidableClass Omega ROmega.
+
+Ltac bool :=
+repeat match goal with
+| [ H : ?P && ?Q = true |- _ ] =>
+  apply andb_true_iff in H; destruct H
+| |- ?P && ?Q = true =>
+  apply <- andb_true_iff; split
+end.
+
+Arguments decide P /H.
+
+Hint Extern 5 => progress bool.
+
+Ltac define t x H :=
+set (x := t) in *; assert (H : t = x) by reflexivity; clearbody x.
+
+Lemma Decidable_sound : forall P (H : Decidable P),
+                          decide P = true -> P.
+Proof.
+intros P H Hp; apply -> Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_complete : forall P (H : Decidable P),
+  P -> decide P = true.
+Proof.
+intros P H Hp; apply <- Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_sound_alt : forall P (H : Decidable P),
+   ~ P -> decide P = false.
+Proof.
+intros P [wit spec] Hd; destruct wit; simpl; tauto. 
+Qed.
+
+Lemma Decidable_complete_alt : forall P (H : Decidable P),
+  decide P = false -> ~ P.
+Proof.
+  intros P [wit spec] Hd Hc; simpl in *; intuition congruence.
+Qed.
+
+Ltac try_rewrite :=
+repeat match goal with
+| [ H : ?P |- _ ] => rewrite H
+end.
+
+(* We opacify here decide for proofs, and will make it transparent for
+   reflexive tactics later on. *)
+
+Global Opaque decide.
+
+Ltac tac_decide :=
+match goal with
+| [ H : @decide ?P ?D = true |- _ ] => apply (@Decidable_sound P D) in H
+| [ H : @decide ?P ?D = false |- _ ] => apply (@Decidable_complete_alt P D) in H
+| [ |- @decide ?P ?D = true ] => apply (@Decidable_complete P D)
+| [ |- @decide ?P ?D = false ] => apply (@Decidable_sound_alt P D)
+| [ |- negb ?b = true ] => apply negb_true_iff
+| [ |- negb ?b = false ] => apply negb_false_iff
+| [ H : negb ?b = true |- _ ] => apply negb_true_iff in H
+| [ H : negb ?b = false |- _ ] => apply negb_false_iff in H
+end.
+
+Ltac try_decide := repeat tac_decide.
+
+Ltac make_decide P := match goal with
+| [ |- context [@decide P ?D] ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ X : context [@decide P ?D] |- _ ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+end.
+
+Ltac case_decide := match goal with
+| [ |- context [@decide ?P ?D] ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ X : context [@decide ?P ?D] |- _ ] =>
+  let b := fresh "b" in
+  let H := fresh "H" in
+  define (@decide P D) b H; destruct b; try_decide
+| [ |- context [Pos.compare ?x ?y] ] =>
+  destruct (Pos.compare_spec x y); try (exfalso; zify; romega)
+| [ X : context [Pos.compare ?x ?y] |- _ ] =>
+  destruct (Pos.compare_spec x y); try (exfalso; zify; romega)
+end.
+
+Section Definitions.
+
+(** * Global, inductive definitions. *)
+
+(** A Horner polynomial is either a constant, or a product P × (i + Q), where i 
+  is a variable. *)
+
+Inductive poly :=
+| Cst : bool -> poly
+| Poly : poly -> positive -> poly -> poly.
+
+(* TODO: We should use [positive] instead of [nat] to encode variables, for 
+ efficiency purpose. *)
+
+Inductive null : poly -> Prop :=
+| null_intro : null (Cst false).
+
+(** Polynomials satisfy a uniqueness condition whenever they are valid. A 
+  polynomial [p] satisfies [valid n p] whenever it is well-formed and each of 
+  its variable indices is < [n]. *)
+
+Inductive valid : positive -> poly -> Prop :=
+| valid_cst : forall k c, valid k (Cst c)
+| valid_poly : forall k p i q,
+  Pos.lt i k -> ~ null q -> valid i p -> valid (Pos.succ i) q -> valid k (Poly p i q).
+
+(** Linear polynomials are valid polynomials in which every variable appears at 
+  most once. *)
+
+Inductive linear : positive -> poly -> Prop :=
+| linear_cst : forall k c, linear k (Cst c)
+| linear_poly : forall k p i q, Pos.lt i k -> ~ null q ->
+  linear i p -> linear i q -> linear k (Poly p i q).
+
+End Definitions.
+
+Section Computational.
+
+Program Instance Decidable_PosEq : forall (p q : positive), Decidable (p = q) :=
+  { Decidable_witness := Pos.eqb p q }.
+Next Obligation.
+apply Pos.eqb_eq.
+Qed.
+
+Program Instance Decidable_PosLt : forall p q, Decidable (Pos.lt p q) :=
+  { Decidable_witness := Pos.ltb p q }.
+Next Obligation.
+apply Pos.ltb_lt.
+Qed.
+
+Program Instance Decidable_PosLe : forall p q, Decidable (Pos.le p q) :=
+  { Decidable_witness := Pos.leb p q }.
+Next Obligation.
+apply Pos.leb_le.
+Qed.
+
+(** * The core reflexive part. *)
+
+Hint Constructors valid.
+
+Fixpoint beq_poly pl pr :=
+match pl with
+| Cst cl =>
+  match pr with
+  | Cst cr => decide (cl = cr)
+  | Poly _ _ _ => false
+  end
+| Poly pl il ql =>
+  match pr with
+  | Cst _ => false
+  | Poly pr ir qr =>
+    decide (il = ir) && beq_poly pl pr && beq_poly ql qr
+  end
+end.
+
+(* We could do that with [decide equality] but dependency in proofs is heavy *)
+Program Instance Decidable_eq_poly : forall (p q : poly), Decidable (eq p q) := {
+  Decidable_witness := beq_poly p q
+}.
+
+Next Obligation.
+split.
+revert q; induction p; intros [] ?; simpl in *; bool; try_decide;
+  f_equal; first [intuition congruence|auto].
+revert q; induction p; intros [] Heq; simpl in *; bool; try_decide; intuition;
+  try injection Heq; first[congruence|intuition].
+Qed.
+
+Program Instance Decidable_null : forall p, Decidable (null p) := {
+  Decidable_witness := match p with Cst false => true | _ => false end
+}.
+Next Obligation.
+split.
+  destruct p as [[]|]; first [discriminate|constructor].
+  inversion 1; trivial.
+Qed.
+
+Definition list_nth {A} p (l : list A) def :=
+  Pos.peano_rect (fun _ => list A -> A)
+    (fun l => match l with nil => def | cons t l => t end)
+    (fun _ F l => match l with nil => def | cons t l => F l end) p l.
+
+Fixpoint eval var (p : poly) :=
+match p with
+| Cst c => c
+| Poly p i q =>
+  let vi := list_nth i var false in
+  xorb (eval var p) (andb vi (eval var q))
+end.
+
+Fixpoint valid_dec k p :=
+match p with
+| Cst c => true
+| Poly p i q =>
+  negb (decide (null q)) && decide (i < k)%positive &&
+    valid_dec i p && valid_dec (Pos.succ i) q
+end.
+
+Program Instance Decidable_valid : forall n p, Decidable (valid n p) := {
+  Decidable_witness := valid_dec n p
+}.
+Next Obligation.
+split.
+  revert n; induction p; unfold valid_dec in *; intuition; bool; try_decide; auto.
+  intros H; induction H; unfold valid_dec in *; bool; try_decide; auto.
+Qed.
+
+(** Basic algebra *)
+
+(* Addition of polynomials *)
+
+Fixpoint poly_add pl {struct pl} :=
+match pl with
+| Cst cl =>
+  fix F pr := match pr with
+  | Cst cr => Cst (xorb cl cr)
+  | Poly pr ir qr => Poly (F pr) ir qr
+  end
+| Poly pl il ql =>
+  fix F pr {struct pr} := match pr with
+  | Cst cr => Poly (poly_add pl pr) il ql
+  | Poly pr ir qr =>
+    match Pos.compare il ir with
+    | Eq =>
+      let qs := poly_add ql qr in
+      (* Ensure validity *)
+      if decide (null qs) then poly_add pl pr
+      else Poly (poly_add pl pr) il qs
+    | Gt => Poly (poly_add pl (Poly pr ir qr)) il ql
+    | Lt => Poly (F pr) ir qr
+    end
+  end
+end.
+
+(* Multiply a polynomial by a constant *)
+
+Fixpoint poly_mul_cst v p :=
+match p with
+| Cst c => Cst (andb c v)
+| Poly p i q =>
+  let r := poly_mul_cst v q in
+  (* Ensure validity *)
+  if decide (null r) then poly_mul_cst v p
+  else Poly (poly_mul_cst v p) i r
+end.
+
+(* Multiply a polynomial by a monomial *)
+
+Fixpoint poly_mul_mon k p :=
+match p with
+| Cst c =>
+  if decide (null p) then p
+  else Poly (Cst false) k p
+| Poly p i q =>
+  if decide (i <= k)%positive then Poly (Cst false) k (Poly p i q)
+  else Poly (poly_mul_mon k p) i (poly_mul_mon k q)
+end.
+
+(* Multiplication of polynomials *)
+
+Fixpoint poly_mul pl {struct pl} :=
+match pl with
+| Cst cl => poly_mul_cst cl
+| Poly pl il ql =>
+  fun pr =>
+    (* Multiply by a factor *)
+    let qs := poly_mul ql pr in
+    (* Ensure validity *)
+    if decide (null qs) then poly_mul pl pr
+    else poly_add (poly_mul pl pr) (poly_mul_mon il qs)
+end.
+
+(** Quotienting a polynomial by the relation X_i^2 ~ X_i *)
+
+(* Remove the multiple occurences of monomials x_k *)
+
+Fixpoint reduce_aux k p :=
+match p with
+| Cst c => Cst c
+| Poly p i q =>
+  if decide (i = k) then poly_add (reduce_aux k p) (reduce_aux k q)
+  else
+    let qs := reduce_aux i q in
+    (* Ensure validity *)
+    if decide (null qs) then (reduce_aux k p)
+    else Poly (reduce_aux k p) i qs
+end.
+
+(* Rewrite any x_k ^ {n + 1} to x_k *)
+
+Fixpoint reduce p :=
+match p with
+| Cst c => Cst c
+| Poly p i q =>
+  let qs := reduce_aux i q in
+  (* Ensure validity *)
+  if decide (null qs) then reduce p
+  else Poly (reduce p) i qs
+end.
+
+End Computational.
+
+Section Validity.
+
+(* Decision procedure of validity *)
+
+Hint Constructors valid linear.
+
+Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p.
+Proof.
+intros k l p H Hl; induction H; constructor; eauto.
+now eapply Pos.lt_le_trans; eassumption.
+Qed.
+
+Lemma linear_le_compat : forall k l p, linear k p -> (k <= l)%positive -> linear l p.
+Proof.
+intros k l p H; revert l; induction H; constructor; eauto; zify; romega.
+Qed.
+
+Lemma linear_valid_incl : forall k p, linear k p -> valid k p.
+Proof.
+intros k p H; induction H; constructor; auto.
+eapply valid_le_compat; eauto; zify; romega.
+Qed.
+
+End Validity.
+
+Section Evaluation.
+
+(* Useful simple properties *)
+
+Lemma eval_null_zero : forall p var, null p -> eval var p = false.
+Proof.
+intros p var []; reflexivity.
+Qed.
+
+Lemma eval_extensional_eq_compat : forall p var1 var2,
+  (forall x, list_nth x var1 false = list_nth x var2 false) -> eval var1 p = eval var2 p.
+Proof.
+intros p var1 var2 H; induction p; simpl; try_rewrite; auto.
+Qed.
+
+Lemma eval_suffix_compat : forall k p var1 var2,
+  (forall i, (i < k)%positive -> list_nth i var1 false = list_nth i var2 false) -> valid k p ->
+  eval var1 p = eval var2 p.
+Proof.
+intros k p var1 var2 Hvar Hv; revert var1 var2 Hvar.
+induction Hv; intros var1 var2 Hvar; simpl; [now auto|].
+rewrite Hvar; [|now auto]; erewrite (IHHv1 var1 var2).
+  + erewrite (IHHv2 var1 var2); [ring|].
+    intros; apply Hvar; zify; omega.
+  + intros; apply Hvar; zify; omega.
+Qed.
+
+End Evaluation.
+
+Section Algebra.
+
+(* Compatibility with evaluation *)
+
+Lemma poly_add_compat : forall pl pr var, eval var (poly_add pl pr) = xorb (eval var pl) (eval var pr).
+Proof.
+intros pl; induction pl; intros pr var; simpl.
++ induction pr; simpl; auto; solve [try_rewrite; ring].
++ induction pr; simpl; auto; try solve [try_rewrite; simpl; ring].
+  destruct (Pos.compare_spec p p0); repeat case_decide; simpl; first [try_rewrite; ring|idtac].
+    try_rewrite; ring_simplify; repeat rewrite xorb_assoc.
+    match goal with [ |- context [xorb (andb ?b1 ?b2) (andb ?b1 ?b3)] ] =>
+      replace (xorb (andb b1 b2) (andb b1 b3)) with (andb b1 (xorb b2 b3)) by ring
+    end.
+    rewrite <- IHpl2.
+    match goal with [ H : null ?p |- _ ] => rewrite (eval_null_zero _ _ H) end; ring.
+    simpl; rewrite IHpl1; simpl; ring.
+Qed.
+
+Lemma poly_mul_cst_compat : forall v p var,
+  eval var (poly_mul_cst v p) = andb v (eval var p).
+Proof.
+intros v p; induction p; intros var; simpl; [ring|].
+case_decide; simpl; try_rewrite; [ring_simplify|ring].
+replace (v && list_nth p2 var false && eval var p3) with (list_nth p2 var false && (v && eval var p3)) by ring.
+rewrite <- IHp2; inversion H; simpl; ring.
+Qed.
+
+Lemma poly_mul_mon_compat : forall i p var,
+  eval var (poly_mul_mon i p) = (list_nth i var false && eval var p).
+Proof.
+intros i p var; induction p; simpl; case_decide; simpl; try_rewrite; try ring.
+inversion H; ring.
+match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end.
+match goal with [ |- ?u = ?t ] => set (x := t); destruct x; reflexivity end.
+Qed.
+
+Lemma poly_mul_compat : forall pl pr var, eval var (poly_mul pl pr) = andb (eval var pl) (eval var pr).
+Proof.
+intros pl; induction pl; intros pr var; simpl.
+  apply poly_mul_cst_compat.
+  case_decide; simpl.
+    rewrite IHpl1; ring_simplify.
+    replace (eval var pr && list_nth p var false && eval var pl2)
+    with (list_nth p var false && (eval var pl2 && eval var pr)) by ring.
+    now rewrite <- IHpl2; inversion H; simpl; ring.
+    rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring.
+Qed.
+
+Hint Extern 5 =>
+match goal with
+| [ |- (Pos.max ?x ?y <= ?z)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (?z <= Pos.max ?x ?y)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (Pos.max ?x ?y < ?z)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| [ |- (?z < Pos.max ?x ?y)%positive ] =>
+  apply Pos.max_case_strong; intros; zify; romega
+| _ => zify; omega
+end.
+Hint Resolve Pos.le_max_r Pos.le_max_l.
+
+Hint Constructors valid linear.
+
+(* Compatibility of validity w.r.t algebraic operations *)
+
+Lemma poly_add_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr ->
+  valid (Pos.max kl kr) (poly_add pl pr).
+Proof.
+intros kl kr pl pr Hl Hr; revert kr pr Hr; induction Hl; intros kr pr Hr; simpl.
+{ eapply valid_le_compat; [clear k|apply Pos.le_max_r].
+  now induction Hr; auto. }
+{  assert (Hle : (Pos.max (Pos.succ i) kr <= Pos.max k kr)%positive) by auto.
+  apply (valid_le_compat (Pos.max (Pos.succ i) kr)); [|assumption].
+  clear - IHHl1 IHHl2 Hl2 Hr H0; induction Hr.
+    constructor; auto.
+      now rewrite <- (Pos.max_id i); intuition.
+    destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition).
+      + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto.
+      + apply (valid_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; zify; romega.
+      + apply (valid_le_compat (Pos.max (Pos.succ i0) (Pos.succ i0))); [now auto|]; rewrite Pos.max_id; zify; romega.
+      + apply (valid_le_compat (Pos.max (Pos.succ i) i0)); intuition.
+      + apply (valid_le_compat (Pos.max i (Pos.succ i0))); intuition.
+}
+Qed.
+
+Lemma poly_mul_cst_valid_compat : forall k v p, valid k p -> valid k (poly_mul_cst v p).
+Proof.
+intros k v p H; induction H; simpl; [now auto|].
+case_decide; [|now auto].
+eapply (valid_le_compat i); [now auto|zify; romega].
+Qed.
+
+Lemma poly_mul_mon_null_compat : forall i p, null (poly_mul_mon i p) -> null p.
+Proof.
+intros i p; induction p; simpl; case_decide; simpl; inversion 1; intuition.
+Qed.
+
+Lemma poly_mul_mon_valid_compat : forall k i p,
+  valid k p -> valid (Pos.max (Pos.succ i) k) (poly_mul_mon i p).
+Proof.
+intros k i p H; induction H; simpl poly_mul_mon; case_decide; intuition.
++ apply (valid_le_compat (Pos.succ i)); auto; constructor; intuition.
+  - match goal with [ H : null ?p |- _ ] => solve[inversion H] end.
++ apply (valid_le_compat k); auto; constructor; intuition.
+  - assert (X := poly_mul_mon_null_compat); intuition eauto.
+  - cutrewrite <- (Pos.max (Pos.succ i) i0 = i0); intuition.
+  - cutrewrite <- (Pos.max (Pos.succ i) (Pos.succ i0) = Pos.succ i0); intuition.
+Qed.
+
+Lemma poly_mul_valid_compat : forall kl kr pl pr, valid kl pl -> valid kr pr ->
+  valid (Pos.max kl kr) (poly_mul pl pr).
+Proof.
+intros kl kr pl pr Hl Hr; revert kr pr Hr.
+induction Hl; intros kr pr Hr; simpl.
++ apply poly_mul_cst_valid_compat; auto.
+  apply (valid_le_compat kr); now auto.
++ apply (valid_le_compat (Pos.max (Pos.max i kr) (Pos.max (Pos.succ i) (Pos.max (Pos.succ i) kr)))).
+  - case_decide.
+    { apply (valid_le_compat (Pos.max i kr)); auto. }
+    { apply poly_add_valid_compat; auto.
+      now apply poly_mul_mon_valid_compat; intuition. }
+  - repeat apply Pos.max_case_strong; zify; omega.
+Qed.
+
+(* Compatibility of linearity wrt to linear operations *)
+
+Lemma poly_add_linear_compat : forall kl kr pl pr, linear kl pl -> linear kr pr ->
+  linear (Pos.max kl kr) (poly_add pl pr).
+Proof.
+intros kl kr pl pr Hl; revert kr pr; induction Hl; intros kr pr Hr; simpl.
++ apply (linear_le_compat kr); [|apply Pos.max_case_strong; zify; omega].
+  now induction Hr; constructor; auto.
++ apply (linear_le_compat (Pos.max kr (Pos.succ i))); [|now auto].
+  induction Hr; simpl.
+  - constructor; auto.
+    replace i with (Pos.max i i) by (apply Pos.max_id); intuition.
+  - destruct (Pos.compare_spec i i0); subst; try case_decide; repeat (constructor; intuition).
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 i0)); [now auto|]; rewrite Pos.max_id; auto. }
+    { apply (linear_le_compat (Pos.max i0 (Pos.succ i))); intuition. }
+    { apply (linear_le_compat (Pos.max i (Pos.succ i0))); intuition. }
+Qed.
+
+End Algebra.
+
+Section Reduce.
+
+(* A stronger version of the next lemma *)
+
+Lemma reduce_aux_eval_compat : forall k p var, valid (Pos.succ k) p ->
+  (list_nth k var false && eval var (reduce_aux k p) = list_nth k var false && eval var p).
+Proof.
+intros k p var; revert k; induction p; intros k Hv; simpl; auto.
+inversion Hv; case_decide; subst.
++ rewrite poly_add_compat; ring_simplify.
+  specialize (IHp1 k); specialize (IHp2 k).
+  destruct (list_nth k var false); ring_simplify; [|now auto].
+  rewrite <- (andb_true_l (eval var p1)), <- (andb_true_l (eval var p3)).
+  rewrite <- IHp2; auto; rewrite <- IHp1; [ring|].
+  apply (valid_le_compat k); [now auto|zify; omega].
++ remember (list_nth k var false) as b; destruct b; ring_simplify; [|now auto].
+  case_decide; simpl.
+  - rewrite <- (IHp2 p2); [inversion H|now auto]; simpl.
+    replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring); rewrite <- (IHp1 k).
+    { rewrite <- Heqb; ring. }
+    { apply (valid_le_compat p2); [auto|zify; omega]. }
+  - rewrite (IHp2 p2); [|now auto].
+    replace (eval var p1) with (list_nth k var false && eval var p1) by (rewrite <- Heqb; ring).
+    rewrite <- (IHp1 k); [rewrite <- Heqb; ring|].
+    apply (valid_le_compat p2); [auto|zify; omega].
+Qed.
+
+(* Reduction preserves evaluation by boolean assignations *)
+
+Lemma reduce_eval_compat : forall k p var, valid k p ->
+  eval var (reduce p) = eval var p.
+Proof.
+intros k p var H; induction H; simpl; auto.
+case_decide; try_rewrite; simpl.
++ rewrite <- reduce_aux_eval_compat; auto; inversion H3; simpl; ring.
++ repeat rewrite reduce_aux_eval_compat; try_rewrite; now auto.
+Qed.
+
+Lemma reduce_aux_le_compat : forall k l p, valid k p -> (k <= l)%positive ->
+  reduce_aux l p = reduce_aux k p.
+Proof.
+intros k l p; revert k l; induction p; intros k l H Hle; simpl; auto.
+inversion H; subst; repeat case_decide; subst; try (exfalso; zify; omega).
++ apply IHp1; [|now auto]; eapply valid_le_compat; [eauto|zify; omega].
++ f_equal; apply IHp1; auto.
+  now eapply valid_le_compat; [eauto|zify; omega].
+Qed.
+
+(* Reduce projects valid polynomials into linear ones *)
+
+Lemma linear_reduce_aux : forall i p, valid (Pos.succ i) p -> linear i (reduce_aux i p).
+Proof.
+intros i p; revert i; induction p; intros i Hp; simpl.
++ constructor.
++ inversion Hp; subst; case_decide; subst.
+  - rewrite <- (Pos.max_id i) at 1; apply poly_add_linear_compat.
+    { apply IHp1; eapply valid_le_compat; [eassumption|zify; omega]. }
+    { intuition. }
+  - case_decide.
+  { apply IHp1; eapply valid_le_compat; [eauto|zify; omega]. }
+  { constructor; try (zify; omega); auto.
+    erewrite (reduce_aux_le_compat p2); [|assumption|zify; omega].
+    apply IHp1; eapply valid_le_compat; [eauto|]; zify; omega. }
+Qed.
+
+Lemma linear_reduce : forall k p, valid k p -> linear k (reduce p).
+Proof.
+intros k p H; induction H; simpl.
++ now constructor.
++ case_decide.
+  - eapply linear_le_compat; [eauto|zify; omega].
+  - constructor; auto.
+    apply linear_reduce_aux; auto.
+Qed.
+
+End Reduce.
diff --git a/plugins/btauto/Btauto.v b/plugins/btauto/Btauto.v
new file mode 100644
index 00000000..d3331ccf
--- /dev/null
+++ b/plugins/btauto/Btauto.v
@@ -0,0 +1,3 @@
+Require Import Algebra Reflect.
+
+Declare ML Module "btauto_plugin".
diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v
new file mode 100644
index 00000000..3bd7cd62
--- /dev/null
+++ b/plugins/btauto/Reflect.v
@@ -0,0 +1,398 @@
+Require Import Bool DecidableClass Algebra Ring PArith ROmega Omega.
+
+Section Bool.
+
+(* Boolean formulas and their evaluations *)
+
+Inductive formula :=
+| formula_var : positive -> formula
+| formula_btm : formula
+| formula_top : formula
+| formula_cnj : formula -> formula -> formula
+| formula_dsj : formula -> formula -> formula
+| formula_neg : formula -> formula
+| formula_xor : formula -> formula -> formula
+| formula_ifb : formula -> formula -> formula -> formula.
+
+Fixpoint formula_eval var f := match f with
+| formula_var x => list_nth x var false 
+| formula_btm => false
+| formula_top => true
+| formula_cnj fl fr => (formula_eval var fl) && (formula_eval var fr)
+| formula_dsj fl fr => (formula_eval var fl) || (formula_eval var fr)
+| formula_neg f => negb (formula_eval var f)
+| formula_xor fl fr => xorb (formula_eval var fl) (formula_eval var fr)
+| formula_ifb fc fl fr =>
+  if formula_eval var fc then formula_eval var fl else formula_eval var fr
+end.
+
+End Bool.
+
+(* Translation of formulas into polynomials *)
+
+Section Translation.
+
+(* This is straightforward. *)
+
+Fixpoint poly_of_formula f := match f with
+| formula_var x => Poly (Cst false) x (Cst true) 
+| formula_btm => Cst false
+| formula_top => Cst true
+| formula_cnj fl fr =>
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_mul pl pr
+| formula_dsj fl fr =>
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_add (poly_add pl pr) (poly_mul pl pr)
+| formula_neg f => poly_add (Cst true) (poly_of_formula f)
+| formula_xor fl fr => poly_add (poly_of_formula fl) (poly_of_formula fr)
+| formula_ifb fc fl fr =>
+  let pc := poly_of_formula fc in
+  let pl := poly_of_formula fl in
+  let pr := poly_of_formula fr in
+  poly_add pr (poly_add (poly_mul pc pl) (poly_mul pc pr))
+end.
+
+Opaque poly_add.
+
+(* Compatibility of translation wrt evaluation *)
+
+Lemma poly_of_formula_eval_compat : forall var f,
+  eval var (poly_of_formula f) = formula_eval var f.
+Proof.
+intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto.
+  now simpl; match goal with [ |- ?t = ?u ] => destruct u; reflexivity end.
+  rewrite poly_mul_compat, IHf1, IHf2; ring.
+  repeat rewrite poly_add_compat.
+  rewrite poly_mul_compat; try_rewrite.
+  now match goal with [ |- ?t = ?x || ?y ] => destruct x; destruct y; reflexivity end.
+  rewrite poly_add_compat; try_rewrite.
+  now match goal with [ |- ?t = negb ?x ] => destruct x; reflexivity end.
+  rewrite poly_add_compat; congruence.
+  rewrite ?poly_add_compat, ?poly_mul_compat; try_rewrite.
+  match goal with
+    [ |- ?t = if ?b1 then ?b2 else ?b3 ] => destruct b1; destruct b2; destruct b3; reflexivity
+  end.
+Qed.
+
+Hint Extern 5 => change 0 with (min 0 0).
+Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat.
+Local Hint Constructors valid.
+Hint Extern 5 => zify; omega.
+
+(* Compatibility with validity *)
+
+Lemma poly_of_formula_valid_compat : forall f, exists n, valid n (poly_of_formula f).
+Proof.
+intros f; induction f; simpl.
++ exists (Pos.succ p); constructor; intuition; inversion H.
++ exists 1%positive; auto.
++ exists 1%positive; auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max (Pos.max n1 n2) (Pos.max n1 n2)); auto.
++ destruct IHf as [n Hn]; exists (Pos.max 1 n); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; exists (Pos.max n1 n2); auto.
++ destruct IHf1 as [n1 Hn1]; destruct IHf2 as [n2 Hn2]; destruct IHf3 as [n3 Hn3]; eexists; eauto.
+Qed.
+
+(* The soundness lemma ; alas not complete! *)
+
+Lemma poly_of_formula_sound : forall fl fr var,
+  poly_of_formula fl = poly_of_formula fr -> formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+rewrite Heq; reflexivity.
+Qed.
+
+End Translation.
+
+Section Completeness.
+
+(* Lemma reduce_poly_of_formula_simpl : forall fl fr var,
+  simpl_eval (var_of_list var) (reduce (poly_of_formula fl)) = simpl_eval (var_of_list var) (reduce (poly_of_formula fr)) ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Hrw.
+do 2 rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); [|assumption].
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); [|assumption].
+do 2 rewrite <- eval_simpl_eval_compat; assumption.
+Qed. *)
+
+(* Soundness of the method ; immediate *)
+
+Lemma reduce_poly_of_formula_sound : forall fl fr var,
+  reduce (poly_of_formula fl) = reduce (poly_of_formula fr) ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros fl fr var Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto.
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto.
+rewrite Heq; reflexivity.
+Qed.
+
+Definition make_last {A} n (x def : A) :=
+  Pos.peano_rect (fun _ => list A)
+    (cons x nil)
+    (fun _ F => cons def F) n.
+
+(* Replace the nth element of a list *)
+
+Fixpoint list_replace l n b :=
+match l with
+| nil => make_last n b false
+| cons a l =>
+  Pos.peano_rect _
+    (cons b l) (fun n _ => cons a (list_replace l n b)) n
+end.
+
+(** Extract a non-null witness from a polynomial *)
+
+Existing Instance Decidable_null.
+
+Fixpoint boolean_witness p :=
+match p with
+| Cst c => nil
+| Poly p i q =>
+  if decide (null p) then
+    let var := boolean_witness q in
+    list_replace var i true
+  else
+    let var := boolean_witness p in
+    list_replace var i false
+end.
+
+Lemma list_nth_base : forall A (def : A) l,
+  list_nth 1 l def = match l with nil => def | cons x _ => x end.
+Proof.
+intros A def l; unfold list_nth.
+rewrite Pos.peano_rect_base; reflexivity.
+Qed.
+
+Lemma list_nth_succ : forall A n (def : A) l,
+  list_nth (Pos.succ n) l def =
+    match l with nil => def | cons _ l => list_nth n l def end.
+Proof.
+intros A def l; unfold list_nth.
+rewrite Pos.peano_rect_succ; reflexivity.
+Qed.
+
+Lemma list_nth_nil : forall A n (def : A),
+  list_nth n nil def = def.
+Proof.
+intros A n def; induction n using Pos.peano_rect.
++ rewrite list_nth_base; reflexivity.
++ rewrite list_nth_succ; reflexivity.
+Qed.
+
+Lemma make_last_nth_1 : forall A n i x def, i <> n ->
+  list_nth i (@make_last A n x def) def = def.
+Proof.
+intros A n; induction n using Pos.peano_rect; intros i x def Hd;
+  unfold make_last; simpl.
++ induction i using Pos.peano_case; [elim Hd; reflexivity|].
+  rewrite list_nth_succ, list_nth_nil; reflexivity.
++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def).
+  induction i using Pos.peano_case.
+  - rewrite list_nth_base; reflexivity.
+  - rewrite list_nth_succ; apply IHn; zify; omega.
+Qed.
+
+Lemma make_last_nth_2 : forall A n x def, list_nth n (@make_last A n x def) def = x.
+Proof.
+intros A n; induction n using Pos.peano_rect; intros x def; simpl.
++ reflexivity.
++ unfold make_last; rewrite Pos.peano_rect_succ; fold (make_last n x def).
+  rewrite list_nth_succ; auto.
+Qed.
+
+Lemma list_replace_nth_1 : forall var i j x, i <> j ->
+  list_nth i (list_replace var j x) false = list_nth i var false.
+Proof.
+intros var; induction var; intros i j x Hd; simpl.
++ rewrite make_last_nth_1, list_nth_nil; auto.
++ induction j using Pos.peano_rect.
+  - rewrite Pos.peano_rect_base.
+    induction i using Pos.peano_rect; [now elim Hd; auto|].
+    rewrite 2list_nth_succ; reflexivity.
+  - rewrite Pos.peano_rect_succ.
+    induction i using Pos.peano_rect.
+    { rewrite 2list_nth_base; reflexivity. }
+    { rewrite 2list_nth_succ; apply IHvar; zify; omega. }
+Qed.
+
+Lemma list_replace_nth_2 : forall var i x, list_nth i (list_replace var i x) false = x.
+Proof.
+intros var; induction var; intros i x; simpl.
++ now apply make_last_nth_2.
++ induction i using Pos.peano_rect.
+  - rewrite Pos.peano_rect_base, list_nth_base; reflexivity.
+  - rewrite Pos.peano_rect_succ, list_nth_succ; auto.
+Qed.
+
+(* The witness is correct only if the polynomial is linear *)
+
+Lemma boolean_witness_nonzero : forall k p, linear k p -> ~ null p ->
+  eval (boolean_witness p) p = true.
+Proof.
+intros k p Hl Hp; induction Hl; simpl.
+  destruct c; [reflexivity|elim Hp; now constructor].
+  case_decide.
+    rewrite eval_null_zero; [|assumption]; rewrite list_replace_nth_2; simpl.
+    match goal with [ |- (if ?b then true else false) = true ] =>
+      assert (Hrw : b = true); [|rewrite Hrw; reflexivity]
+    end.
+    erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto].
+    now intros j Hd; apply list_replace_nth_1; zify; omega.
+    rewrite list_replace_nth_2, xorb_false_r.
+    erewrite eval_suffix_compat; [now eauto| |now apply linear_valid_incl; eauto].
+    now intros j Hd; apply list_replace_nth_1; zify; omega.
+Qed.
+
+(* This should be better when using the [vm_compute] tactic instead of plain reflexivity. *)
+
+Lemma reduce_poly_of_formula_sound_alt : forall var fl fr,
+  reduce (poly_add (poly_of_formula fl) (poly_of_formula fr)) = Cst false ->
+  formula_eval var fl = formula_eval var fr.
+Proof.
+intros var fl fr Heq.
+repeat rewrite <- poly_of_formula_eval_compat.
+destruct (poly_of_formula_valid_compat fl) as [nl Hl].
+destruct (poly_of_formula_valid_compat fr) as [nr Hr].
+rewrite <- (reduce_eval_compat nl (poly_of_formula fl)); auto.
+rewrite <- (reduce_eval_compat nr (poly_of_formula fr)); auto.
+rewrite <- xorb_false_l; change false with (eval var (Cst false)).
+rewrite <- poly_add_compat, <- Heq.
+repeat rewrite poly_add_compat.
+rewrite (reduce_eval_compat nl); [|assumption].
+rewrite (reduce_eval_compat (Pos.max nl nr)); [|apply poly_add_valid_compat; assumption].
+rewrite (reduce_eval_compat nr); [|assumption].
+rewrite poly_add_compat; ring.
+Qed.
+
+(* The completeness lemma *)
+
+(* Lemma reduce_poly_of_formula_complete : forall fl fr,
+  reduce (poly_of_formula fl) <> reduce (poly_of_formula fr) ->
+  {var | formula_eval var fl <> formula_eval var fr}.
+Proof.
+intros fl fr H.
+pose (p := poly_add (reduce (poly_of_formula fl)) (poly_opp (reduce (poly_of_formula fr)))).
+pose (var := boolean_witness p).
+exists var.
+  intros Hc; apply (f_equal Z_of_bool) in Hc.
+  assert (Hfl : linear 0 (reduce (poly_of_formula fl))).
+    now destruct (poly_of_formula_valid_compat fl) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto.
+  assert (Hfr : linear 0 (reduce (poly_of_formula fr))).
+    now destruct (poly_of_formula_valid_compat fr) as [n Hn]; apply (linear_le_compat n); [|now auto]; apply linear_reduce; auto.
+  repeat rewrite <- poly_of_formula_eval_compat in Hc.
+  define (decide (null p)) b Hb; destruct b; tac_decide.
+    now elim H; apply (null_sub_implies_eq 0 0); fold p; auto;
+    apply linear_valid_incl; auto.
+  elim (boolean_witness_nonzero 0 p); auto.
+    unfold p; rewrite <- (min_id 0); apply poly_add_linear_compat; try apply poly_opp_linear_compat; now auto.
+    unfold p at 2; rewrite poly_add_compat, poly_opp_compat.
+    destruct (poly_of_formula_valid_compat fl) as [nl Hnl].
+    destruct (poly_of_formula_valid_compat fr) as [nr Hnr].
+    repeat erewrite reduce_eval_compat; eauto.
+    fold var; rewrite Hc; ring.
+Defined. *)
+
+End Completeness.
+
+(* Reification tactics *)
+
+(* For reflexivity purposes, that would better be transparent *)
+
+Global Transparent decide poly_add.
+
+(* Ltac append_var x l k :=
+match l with
+| nil => constr: (k, cons x l)
+| cons x _ => constr: (k, l)
+| cons ?y ?l =>
+  let ans := append_var x l (S k) in
+  match ans with (?k, ?l) => constr: (k, cons y l) end
+end.
+
+Ltac build_formula t l :=
+match t with
+| true => constr: (formula_top, l)
+| false => constr: (formula_btm, l)
+| ?fl && ?fr =>
+  match build_formula fl l with (?tl, ?l) =>
+    match build_formula fr l with (?tr, ?l) =>
+      constr: (formula_cnj tl tr, l)
+    end
+  end
+| ?fl || ?fr =>
+  match build_formula fl l with (?tl, ?l) =>
+    match build_formula fr l with (?tr, ?l) =>
+      constr: (formula_dsj tl tr, l)
+    end
+  end
+| negb ?f =>
+  match build_formula f l with (?t, ?l) =>
+    constr: (formula_neg t, l)
+  end
+| _ =>
+  let ans := append_var t l 0 in
+  match ans with (?k, ?l) => constr: (formula_var k, l) end
+end.
+
+(* Extract a counterexample from a polynomial and display it *)
+
+Ltac counterexample p l :=
+  let var := constr: (boolean_witness p) in
+  let var := eval vm_compute in var in
+  let rec print l vl :=
+    match l with
+    | nil => idtac
+    | cons ?x ?l =>
+      match vl with
+      | nil =>
+        idtac x ":=" "false"; print l (@nil bool)
+      | cons ?v ?vl =>
+        idtac x ":=" v; print l vl
+      end
+    end
+  in
+  idtac "Counter-example:"; print l var.
+
+Ltac btauto_reify :=
+lazymatch goal with
+| [ |- @eq bool ?t ?u ] =>
+  lazymatch build_formula t (@nil bool) with
+  | (?fl, ?l) =>
+    lazymatch build_formula u l with
+    | (?fr, ?l) =>
+      change (formula_eval l fl = formula_eval l fr)
+    end
+  end
+| _ => fail "Cannot recognize a boolean equality"
+end.
+
+(* The long-awaited tactic *)
+
+Ltac btauto :=
+lazymatch goal with
+| [ |- @eq bool ?t ?u ] =>
+  lazymatch build_formula t (@nil bool) with
+  | (?fl, ?l) =>
+    lazymatch build_formula u l with
+    | (?fr, ?l) =>
+      change (formula_eval l fl = formula_eval l fr);
+      apply reduce_poly_of_formula_sound_alt;
+      vm_compute; (reflexivity || fail "Not a tautology")
+    end
+  end
+| _ => fail "Cannot recognize a boolean equality"
+end. *)
diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mllib
new file mode 100644
index 00000000..319a9c30
--- /dev/null
+++ b/plugins/btauto/btauto_plugin.mllib
@@ -0,0 +1,3 @@
+Refl_btauto
+G_btauto
+Btauto_plugin_mod
diff --git a/theories/Logic/Classical_Type.v b/plugins/btauto/g_btauto.ml4
index 90d55160..8e00b1c1 100644
--- a/theories/Logic/Classical_Type.v
+++ b/plugins/btauto/g_btauto.ml4
@@ -1,14 +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        *)
 (************************************************************************)
 
-(** This file is obsolete, use Classical.v instead *)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
 
-(** Classical Logic for Type *)
+DECLARE PLUGIN "btauto_plugin"
+
+TACTIC EXTEND btauto
+| [ "btauto" ] -> [ Refl_btauto.Btauto.tac ]
+END
 
-Require Export Classical_Prop.
-Require Export Classical_Pred_Type.
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml
new file mode 100644
index 00000000..57268a9c
--- /dev/null
+++ b/plugins/btauto/refl_btauto.ml
@@ -0,0 +1,260 @@
+
+let contrib_name = "btauto"
+
+let init_constant dir s =
+  let find_constant contrib dir s =
+    Universes.constr_of_global (Coqlib.find_reference contrib dir s)
+  in
+  find_constant contrib_name dir s
+
+let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s)
+
+let get_inductive dir s =
+  let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in
+  Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ()))
+
+let decomp_term (c : Term.constr) =
+  Term.kind_of_term (Term.strip_outer_cast c)
+
+let lapp c v  = Term.mkApp (Lazy.force c, v)
+
+let (===) = Term.eq_constr
+
+module CoqList = struct
+  let path = ["Init"; "Datatypes"]
+  let typ = get_constant path "list"
+  let _nil = get_constant path "nil"
+  let _cons = get_constant path "cons"
+
+  let cons ty h t = lapp _cons [|ty; h ; t|]
+  let nil ty = lapp _nil [|ty|]
+  let rec of_list ty = function
+    | [] -> nil ty
+    | t::q -> cons ty t (of_list ty q)
+  let type_of_list ty = lapp typ [|ty|]
+
+end
+
+module CoqPositive = struct
+  let path = ["Numbers"; "BinNums"]
+  let typ = get_constant path "positive"
+  let _xH = get_constant path "xH"
+  let _xO = get_constant path "xO"
+  let _xI = get_constant path "xI"
+
+  (* A coq nat from an int *)
+  let rec of_int n =
+    if n <= 1 then Lazy.force _xH
+    else
+      let ans = of_int (n / 2) in
+      if n mod 2 = 0 then lapp _xO [|ans|]
+      else lapp _xI [|ans|]
+
+end
+
+module Env = struct
+
+  module ConstrHashed = struct
+    type t = Term.constr
+    let equal = Term.eq_constr
+    let hash = Term.hash_constr
+  end
+
+  module ConstrHashtbl = Hashtbl.Make (ConstrHashed)
+
+  type t = (int ConstrHashtbl.t * int ref)
+
+  let add (tbl, off) (t : Term.constr) =
+    try ConstrHashtbl.find tbl t 
+    with
+    | Not_found -> 
+      let i = !off in 
+      let () = ConstrHashtbl.add tbl t i in
+      let () = incr off in
+      i
+
+  let empty () = (ConstrHashtbl.create 16, ref 1)
+
+  let to_list (env, _) =
+    (* we need to get an ordered list *)
+    let fold constr key accu = (key, constr) :: accu in
+    let l = ConstrHashtbl.fold fold env [] in
+    let sorted_l = List.sort (fun p1 p2 -> Int.compare (fst p1) (fst p2)) l in
+    List.map snd sorted_l
+
+end
+
+module Bool = struct
+
+  let typ = get_constant ["Init"; "Datatypes"] "bool"
+  let ind = get_inductive ["Init"; "Datatypes"] "bool"
+  let trueb = get_constant ["Init"; "Datatypes"] "true"
+  let falseb = get_constant ["Init"; "Datatypes"] "false"
+  let andb = get_constant ["Init"; "Datatypes"] "andb"
+  let orb = get_constant ["Init"; "Datatypes"] "orb"
+  let xorb = get_constant ["Init"; "Datatypes"] "xorb"
+  let negb = get_constant ["Init"; "Datatypes"] "negb"
+
+  type t =
+  | Var of int
+  | Const of bool
+  | Andb of t * t
+  | Orb of t * t
+  | Xorb of t * t
+  | Negb of t
+  | Ifb of t * t * t
+
+  let quote (env : Env.t) (c : Term.constr) : t =
+    let trueb = Lazy.force trueb in
+    let falseb = Lazy.force falseb in
+    let andb = Lazy.force andb in
+    let orb = Lazy.force orb in
+    let xorb = Lazy.force xorb in
+    let negb = Lazy.force negb in
+
+    let rec aux c = match decomp_term c with
+    | Term.App (head, args) ->
+      if head === andb && Array.length args = 2 then
+        Andb (aux args.(0), aux args.(1))
+      else if head === orb && Array.length args = 2 then
+        Orb (aux args.(0), aux args.(1))
+      else if head === xorb && Array.length args = 2 then
+        Xorb (aux args.(0), aux args.(1))
+      else if head === negb && Array.length args = 1 then
+        Negb (aux args.(0))
+      else Var (Env.add env c)
+    | Term.Case (info, r, arg, pats) ->
+      let is_bool =
+        let i = info.Term.ci_ind in
+        Names.eq_ind i (Lazy.force ind)
+      in
+      if is_bool then
+        Ifb ((aux arg), (aux pats.(0)), (aux pats.(1)))
+      else
+        Var (Env.add env c)
+    | _ ->
+      if c === falseb then Const false
+      else if c === trueb then Const true
+      else Var (Env.add env c)
+    in
+    aux c
+
+end
+
+module Btauto = struct
+
+  open Pp
+
+  let eq = get_constant ["Init"; "Logic"]  "eq"
+
+  let f_var = get_constant ["btauto"; "Reflect"] "formula_var"
+  let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm"
+  let f_top = get_constant ["btauto"; "Reflect"] "formula_top"
+  let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj"
+  let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj"
+  let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg"
+  let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor"
+  let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb"
+
+  let eval = get_constant ["btauto"; "Reflect"] "formula_eval"
+  let witness = get_constant ["btauto"; "Reflect"] "boolean_witness"
+
+  let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt"
+
+  let rec convert = function
+  | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|]
+  | Bool.Const true -> Lazy.force f_top
+  | Bool.Const false -> Lazy.force f_btm
+  | Bool.Andb (b1, b2) -> lapp f_cnj [|convert b1; convert b2|]
+  | Bool.Orb (b1, b2) -> lapp f_dsj [|convert b1; convert b2|]
+  | Bool.Negb b -> lapp f_neg [|convert b|]
+  | Bool.Xorb (b1, b2) -> lapp f_xor [|convert b1; convert b2|]
+  | Bool.Ifb (b1, b2, b3) -> lapp f_ifb [|convert b1; convert b2; convert b3|]
+
+  let convert_env env : Term.constr = 
+    CoqList.of_list (Lazy.force Bool.typ) env
+
+  let reify env t = lapp eval [|convert_env env; convert t|]
+
+  let print_counterexample p env gl =
+    let var = lapp witness [|p|] in
+    (* Compute an assignment that dissatisfies the goal *)
+    let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in
+    let rec to_list l = match decomp_term l with
+    | Term.App (c, _)
+      when c === (Lazy.force CoqList._nil) -> []
+    | Term.App (c, [|_; h; t|])
+      when c === (Lazy.force CoqList._cons) ->
+      if h === (Lazy.force Bool.trueb) then (true :: to_list t)
+      else if h === (Lazy.force Bool.falseb) then (false :: to_list t)
+      else invalid_arg "to_list"
+    | _ -> invalid_arg "to_list"
+    in
+    let concat sep = function
+    | [] -> mt ()
+    | h :: t ->
+      let rec aux = function
+      | [] -> mt ()
+      | x :: t -> (sep ++ x ++ aux t)
+      in
+      h ++ aux t
+    in
+    let msg =
+      try
+        let var = to_list var in
+        let assign = List.combine env var in
+        let map_msg (key, v) =
+          let b = if v then str "true" else str "false" in
+          let term = Printer.pr_constr key in
+          term ++ spc () ++ str ":=" ++ spc () ++ b
+        in
+        let assign = List.map map_msg assign in
+        let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in
+        str "Not a tautology:" ++ spc () ++ l
+      with e when Errors.noncritical e -> (str "Not a tautology")
+    in
+    Tacticals.tclFAIL 0 msg gl
+
+  let try_unification env =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let eq = Lazy.force eq in
+      let t = decomp_term concl in
+      match t with
+      | Term.App (c, [|typ; p; _|]) when c === eq ->
+      (* should be an equality [@eq poly ?p (Cst false)] *)
+          let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in
+          tac
+      | _ ->
+          let msg = str "Btauto: Internal error" in
+          Tacticals.New.tclFAIL 0 msg
+    end
+
+  let tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let eq = Lazy.force eq in
+      let bool = Lazy.force Bool.typ in
+      let t = decomp_term concl in
+      match t with
+      | Term.App (c, [|typ; tl; tr|])
+          when typ === bool && c === eq ->
+          let env = Env.empty () in
+          let fl = Bool.quote env tl in
+          let fr = Bool.quote env tr in
+          let env = Env.to_list env in
+          let fl = reify env fl in
+          let fr = reify env fr in
+          let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in
+          Tacticals.New.tclTHENLIST [
+            Tactics.change_concl changed_gl;
+            Tactics.apply (Lazy.force soundness);
+            Proofview.V82.tactic (Tactics.normalise_vm_in_concl);
+            try_unification env
+          ]
+      | _ ->
+          let msg = str "Cannot recognize a boolean equality" in
+          Tacticals.New.tclFAIL 0 msg
+    end
+
+end
diff --git a/plugins/btauto/vo.itarget b/plugins/btauto/vo.itarget
new file mode 100644
index 00000000..1f72d3ef
--- /dev/null
+++ b/plugins/btauto/vo.itarget
@@ -0,0 +1,3 @@
+Algebra.vo
+Reflect.vo
+Btauto.vo
diff --git a/plugins/cc/README b/plugins/cc/README
index 073b140e..c616b5da 100644
--- a/plugins/cc/README
+++ b/plugins/cc/README
@@ -3,7 +3,7 @@ cctac: congruence-closure for coq
 
 author: Pierre Corbineau, 
 	Stage de DEA au LSV, ENS Cachan
-	Thèse au LRI, Université Paris Sud XI 
+	Thèse au LRI, Université Paris Sud XI 
 
 Files :
 
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index 056ae3a9..29bca862 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.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,22 +8,24 @@
 
 (* This file implements the basic congruence-closure algorithm by *)
 (* Downey,Sethi and Tarjan. *)
+(* Plus some e-matching and constructor handling by P. Corbineau *)
 
+open Errors
 open Util
 open Pp
 open Goptions
 open Names
 open Term
+open Vars
 open Tacmach
 open Evd
-open Proof_type
 
 let init_size=5
 
 let cc_verbose=ref false
 
-let debug f x =
-  if !cc_verbose then f x
+let debug x =
+  if !cc_verbose then msg_debug x
 
 let _=
   let gdopt=
@@ -42,32 +44,39 @@ module ST=struct
 
   (* l: sign -> term r: term -> sign *)
 
-  type t = {toterm:(int*int,int) Hashtbl.t;
-	    tosign:(int,int*int) Hashtbl.t}
+  module IntTable = Hashtbl.Make(Int)
+  module IntPair =
+  struct
+    type t = int * int
+    let equal (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
+    let hash (i, j) = Hashset.Combine.combine (Int.hash i) (Int.hash j)
+  end
+  module IntPairTable = Hashtbl.Make(IntPair)
+
+  type t = {toterm: int IntPairTable.t;
+	    tosign: (int * int) IntTable.t}
 
   let empty ()=
-    {toterm=Hashtbl.create init_size;
-     tosign=Hashtbl.create init_size}
+    {toterm=IntPairTable.create init_size;
+     tosign=IntTable.create init_size}
 
   let enter t sign st=
-    if Hashtbl.mem st.toterm sign then
-	anomaly "enter: signature already entered"
+    if IntPairTable.mem st.toterm sign then
+	anomaly ~label:"enter" (Pp.str "signature already entered")
     else
-	Hashtbl.replace st.toterm sign t;
-	Hashtbl.replace st.tosign t sign
-
-  let query sign st=Hashtbl.find st.toterm sign
+	IntPairTable.replace st.toterm sign t;
+	IntTable.replace st.tosign t sign
 
-  let rev_query term st=Hashtbl.find st.tosign term
+  let query sign st=IntPairTable.find st.toterm sign
 
   let delete st t=
-    try let sign=Hashtbl.find st.tosign t in
-	Hashtbl.remove st.toterm sign;
-	Hashtbl.remove st.tosign t
+    try let sign=IntTable.find st.tosign t in
+	IntPairTable.remove st.toterm sign;
+	IntTable.remove st.tosign t
     with
 	Not_found -> ()
 
-  let rec delete_set st s = Intset.iter (delete st) s
+  let delete_set st s = Int.Set.iter (delete st) s
 
 end
 
@@ -84,45 +93,78 @@ type pa_mark=
     Fmark of pa_fun
   | Cmark of pa_constructor
 
-module PacMap=Map.Make(struct
-			 type t=pa_constructor
-			 let compare=Pervasives.compare end)
+module PacOrd =
+struct
+  type t = pa_constructor
+  let compare { cnode = cnode0; arity = arity0; args = args0 }
+              { cnode = cnode1; arity = arity1; args = args1 } =
+    let cmp = Int.compare cnode0 cnode1 in
+    if cmp = 0 then
+      let cmp' = Int.compare arity0 arity1 in
+      if cmp' = 0 then
+        List.compare Int.compare args0 args1
+      else
+        cmp'
+    else
+      cmp
+end
+
+module PafOrd =
+struct
+  type t = pa_fun
+  let compare { fsym = fsym0; fnargs = fnargs0 } { fsym = fsym1; fnargs = fnargs1 } =
+    let cmp = Int.compare fsym0 fsym1 in
+    if cmp = 0 then
+      Int.compare fnargs0 fnargs1
+    else
+      cmp
+end
 
-module PafMap=Map.Make(struct
-			 type t=pa_fun
-			 let compare=Pervasives.compare end)
+module PacMap=Map.Make(PacOrd)
+module PafMap=Map.Make(PafOrd)
 
 type cinfo=
-    {ci_constr: constructor; (* inductive type *)
+    {ci_constr: pconstructor; (* inductive type *)
      ci_arity: int;     (* # args *)
      ci_nhyps: int}     (* # projectable args *)
 
+let family_eq f1 f2 = match f1, f2 with
+| InProp, InProp
+| InSet, InSet
+| InType, InType -> true
+| _ -> false
+
 type term=
     Symb of constr
   | Product of sorts_family * sorts_family
-  | Eps of identifier
+  | Eps of Id.t
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
 let rec term_equal t1 t2 =
   match t1, t2 with
-    | Symb c1, Symb c2 -> eq_constr c1 c2
-    | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2
-    | Eps i1, Eps i2 -> id_ord i1 i2 = 0
+    | Symb c1, Symb c2 -> eq_constr_nounivs c1 c2
+    | Product (s1, t1), Product (s2, t2) -> family_eq s1 s2 && family_eq t1 t2
+    | Eps i1, Eps i2 -> Id.equal i1 i2
     | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2
-    | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1},
-      Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} ->
-      i1 = i2 && j1 = j2 && eq_constructor c1 c2
-    | _ -> t1 = t2
+    | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1},
+      Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} ->
+      Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *)
+    | _ -> false
+
+open Hashset.Combine
 
-open Hashtbl_alt.Combine
+let hash_sorts_family = function
+| InProp -> 0
+| InSet -> 1
+| InType -> 2
 
 let rec hash_term = function
   | Symb c -> combine 1 (hash_constr c)
-  | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2)
-  | Eps i -> combine 3 (Hashtbl.hash i)
+  | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2)
+  | Eps i -> combine 3 (Id.hash i)
   | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2)
-  | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j
+  | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j
 
 type ccpattern =
     PApp of term * ccpattern list (* arguments are reversed *)
@@ -151,14 +193,16 @@ type patt_kind =
   | Creates_variables
 
 type quant_eq =
-    {qe_hyp_id: identifier;
-     qe_pol: bool;
-     qe_nvars:int;
-     qe_lhs: ccpattern;
-     qe_lhs_valid:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
+  {
+    qe_hyp_id: Id.t;
+    qe_pol: bool;
+    qe_nvars:int;
+    qe_lhs: ccpattern;
+    qe_lhs_valid:patt_kind;
+    qe_rhs: ccpattern;
+    qe_rhs_valid:patt_kind
+  }
+    
 let swap eq : equality =
   let swap_rule=match eq.rule with
       Congruence -> Congruence
@@ -174,12 +218,11 @@ type inductive_status =
 
 type representative=
     {mutable weight:int;
-     mutable lfathers:Intset.t;
-     mutable fathers:Intset.t;
+     mutable lfathers:Int.Set.t;
+     mutable fathers:Int.Set.t;
      mutable inductive_status: inductive_status;
      class_type : Term.types;
-     mutable functions: Intset.t PafMap.t;
-     mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
+     mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *)
 
 type cl = Rep of representative| Eqto of int*equality
 
@@ -188,12 +231,13 @@ type vertex = Leaf| Node of (int*int)
 type node =
     {mutable clas:cl;
      mutable cpath: int;
+     mutable constructors: int PacMap.t;
      vertex:vertex;
      term:term}
 
 module Constrhash = Hashtbl.Make
   (struct type t = constr
-	  let equal = eq_constr
+	  let equal = eq_constr_nounivs
 	  let hash = hash_constr
    end)
 module Typehash = Constrhash
@@ -205,9 +249,9 @@ module Termhash = Hashtbl.Make
    end)
 
 module Identhash = Hashtbl.Make
-  (struct type t = identifier
-	  let equal = Pervasives.(=)
-	  let hash = Hashtbl.hash
+  (struct type t = Id.t
+	  let equal = Id.equal
+	  let hash = Id.hash
    end)
 
 type forest=
@@ -221,45 +265,54 @@ type forest=
 type state =
     {uf: forest;
      sigtable:ST.t;
-     mutable terms: Intset.t;
+     mutable terms: Int.Set.t;
      combine: equality Queue.t;
      marks: (int * pa_mark) Queue.t;
      mutable diseq: disequality list;
      mutable quant: quant_eq list;
-     mutable pa_classes: Intset.t;
+     mutable pa_classes: Int.Set.t;
      q_history: (int array) Identhash.t;
      mutable rew_depth:int;
      mutable changed:bool;
-     by_type: Intset.t Typehash.t;
+     by_type: Int.Set.t Typehash.t;
      mutable gls:Proof_type.goal Tacmach.sigma}
 
 let dummy_node =
-  {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
-   cpath=min_int;
-   vertex=Leaf;
-   term=Symb (mkRel min_int)}
-
+  {
+    clas=Eqto (min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
+    cpath=min_int;
+    constructors=PacMap.empty;
+    vertex=Leaf;
+    term=Symb (mkRel min_int)
+  }
+
+let empty_forest() =
+  {
+    max_size=init_size;
+    size=0;
+    map=Array.make init_size dummy_node;
+    epsilons=[];
+    axioms=Constrhash.create init_size;
+    syms=Termhash.create init_size
+  }
+    
 let empty depth gls:state =
-  {uf=
-     {max_size=init_size;
-      size=0;
-      map=Array.create init_size dummy_node;
-      epsilons=[];
-      axioms=Constrhash.create init_size;
-      syms=Termhash.create init_size};
-  terms=Intset.empty;
-  combine=Queue.create ();
-  marks=Queue.create ();
-  sigtable=ST.empty ();
-  diseq=[];
-  quant=[];
-  pa_classes=Intset.empty;
-  q_history=Identhash.create init_size;
-  rew_depth=depth;
-  by_type=Constrhash.create init_size;
-  changed=false;
-  gls=gls}
-
+  {
+    uf= empty_forest ();
+    terms=Int.Set.empty;
+    combine=Queue.create ();
+    marks=Queue.create ();
+    sigtable=ST.empty ();
+    diseq=[];
+    quant=[];
+    pa_classes=Int.Set.empty;
+    q_history=Identhash.create init_size;
+    rew_depth=depth;
+    by_type=Constrhash.create init_size;
+    changed=false;
+    gls=gls
+  }
+    
 let forest state = state.uf
 
 let compress_path uf i j = uf.map.(j).cpath<-i
@@ -274,15 +327,25 @@ let find uf i= find_aux uf [] i
 let get_representative uf i=
   match uf.map.(i).clas with
       Rep r -> r
-    | _ -> anomaly "get_representative: not a representative"
+    | _ -> anomaly ~label:"get_representative" (Pp.str "not a representative")
+
+let get_constructors uf i= uf.map.(i).constructors
 
 let find_pac uf i pac =
-  PacMap.find pac (get_representative uf i).constructors
+  PacMap.find pac (get_constructors uf i)
+
+let rec find_oldest_pac uf i pac=
+  try PacMap.find pac (get_constructors uf i) with
+    Not_found -> 
+      match uf.map.(i).clas with 
+	Eqto (j,_) -> find_oldest_pac uf j pac
+      | Rep _ -> raise Not_found
+     
 
 let get_constructor_info uf i=
   match uf.map.(i).term with
       Constructor cinfo->cinfo
-    | _ -> anomaly "get_constructor: not a constructor"
+    | _ -> anomaly ~label:"get_constructor" (Pp.str "not a constructor")
 
 let size uf i=
   (get_representative uf i).weight
@@ -294,13 +357,13 @@ let epsilons uf = uf.epsilons
 let add_lfather uf i t=
   let r=get_representative uf i in
     r.weight<-r.weight+1;
-    r.lfathers<-Intset.add t r.lfathers;
-    r.fathers <-Intset.add t r.fathers
+    r.lfathers<-Int.Set.add t r.lfathers;
+    r.fathers <-Int.Set.add t r.fathers
 
 let add_rfather uf i t=
   let r=get_representative uf i in
     r.weight<-r.weight+1;
-    r.fathers <-Intset.add t r.fathers
+    r.fathers <-Int.Set.add t r.fathers
 
 exception Discriminable of int * pa_constructor * int * pa_constructor
 
@@ -313,21 +376,21 @@ let tail_pac p=
 let fsucc paf =
   {paf with fnargs=succ paf.fnargs}
 
-let add_pac rep pac t =
-  if not (PacMap.mem pac rep.constructors) then
-    rep.constructors<-PacMap.add pac t rep.constructors
+let add_pac node pac t =
+  if not (PacMap.mem pac node.constructors) then
+    node.constructors<-PacMap.add pac t node.constructors
 
 let add_paf rep paf t =
   let already =
-    try PafMap.find paf rep.functions with Not_found -> Intset.empty in
-    rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
+    try PafMap.find paf rep.functions with Not_found -> Int.Set.empty in
+    rep.functions<- PafMap.add paf (Int.Set.add t already) rep.functions
 
 let term uf i=uf.map.(i).term
 
 let subterms uf i=
   match uf.map.(i).vertex with
       Node(j,k) -> (j,k)
-    | _ -> anomaly "subterms: not a node"
+    | _ -> anomaly ~label:"subterms" (Pp.str "not a node")
 
 let signature uf i=
   let j,k=subterms uf i in (find uf j,find uf k)
@@ -335,9 +398,9 @@ let signature uf i=
 let next uf=
   let size=uf.size in
   let nsize= succ size in
-    if nsize=uf.max_size then
+    if Int.equal nsize uf.max_size then
       let newmax=uf.max_size * 3 / 2 + 1 in
-      let newmap=Array.create newmax dummy_node in
+      let newmap=Array.make newmax dummy_node in
 	begin
 	  uf.max_size<-newmax;
 	  Array.blit uf.map 0 newmap 0 size;
@@ -349,46 +412,63 @@ let next uf=
 
 let new_representative typ =
   {weight=0;
-   lfathers=Intset.empty;
-   fathers=Intset.empty;
+   lfathers=Int.Set.empty;
+   fathers=Int.Set.empty;
    inductive_status=Unknown;
    class_type=typ;
-   functions=PafMap.empty;
-   constructors=PacMap.empty}
+   functions=PafMap.empty}
 
 (* rebuild a constr from an applicative term *)
 
-let _A_ = Name (id_of_string "A")
-let _B_ = Name (id_of_string "A")
+let _A_ = Name (Id.of_string "A")
+let _B_ = Name (Id.of_string "A")
 let _body_ =  mkProd(Anonymous,mkRel 2,mkRel 2)
 
 let cc_product s1 s2 =
-  mkLambda(_A_,mkSort(Termops.new_sort_in_family s1),
-	   mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_))
+  mkLambda(_A_,mkSort(Universes.new_sort_in_family s1),
+	   mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_))
 
 let rec constr_of_term = function
-    Symb s->s
+    Symb s-> applist_projection s []
   | Product(s1,s2) -> cc_product s1 s2
   | Eps id -> mkVar id
-  | Constructor cinfo -> mkConstruct cinfo.ci_constr
+  | Constructor cinfo -> mkConstructU cinfo.ci_constr
   | Appli (s1,s2)->
       make_app [(constr_of_term s2)] s1
 and make_app l=function
     Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
-  | other -> applistc (constr_of_term other) l
+  | other -> 
+    applist_proj other l
+and applist_proj c l =
+  match c with
+  | Symb s -> applist_projection s l
+  | _ -> applistc (constr_of_term c) l
+and applist_projection c l =
+  match kind_of_term c with
+  | Const c when Environ.is_projection (fst c) (Global.env()) ->
+    let p = Projection.make (fst c) false in
+    (match l with 
+    | [] -> (* Expand the projection *)
+      let ty,_ = Typeops.type_of_constant (Global.env ()) c in
+      let pb = Environ.lookup_projection p (Global.env()) in
+      let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in
+	it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx
+    | hd :: tl ->
+      applistc (mkProj (p, hd)) tl)
+  | _ -> applistc c l
 
 let rec canonize_name c =
   let func =  canonize_name in
     match kind_of_term c with
-      | Const kn ->
+      | Const (kn,u) ->
 	  let canon_const = constant_of_kn (canonical_con kn) in 
-	    (mkConst canon_const)
-      | Ind (kn,i) ->
+	    (mkConstU (canon_const,u))
+      | Ind ((kn,i),u) ->
 	  let canon_mind = mind_of_kn (canonical_mind kn) in
-	    (mkInd (canon_mind,i))
-      | Construct ((kn,i),j) ->
+	    (mkIndU ((canon_mind,i),u))
+      | Construct (((kn,i),j),u) ->
 	  let canon_mind = mind_of_kn (canonical_mind kn) in
-	    mkConstruct ((canon_mind,i),j) 
+	    mkConstructU (((canon_mind,i),j),u)
       | Prod (na,t,ct) ->
 	  mkProd (na,func t, func ct)
       | Lambda (na,t,ct) ->
@@ -396,16 +476,22 @@ let rec canonize_name c =
       | LetIn (na,b,t,ct) ->
 	  mkLetIn (na, func b,func t,func ct)
       | App (ct,l) ->
-	  mkApp (func ct,array_smartmap func l)
+	  mkApp (func ct,Array.smartmap func l)
+      | Proj(p,c) ->
+	let p' = Projection.map (fun kn ->
+          constant_of_kn (canonical_con kn)) p in 
+	  (mkProj (p', func c))
       | _ -> c
 
 (* rebuild a term from a pattern and a substitution *)
 
 let build_subst uf subst =
-  Array.map (fun i ->
-	       try term uf i
-	       with e when Errors.noncritical e ->
-                 anomaly "incomplete matching") subst
+  Array.map
+    (fun i ->
+      try term uf i
+      with e when Errors.noncritical e ->
+        anomaly (Pp.str "incomplete matching"))
+    subst
 
 let rec inst_pattern subst = function
     PVar i ->
@@ -415,8 +501,8 @@ let rec inst_pattern subst = function
 	(fun spat f -> Appli (f,inst_pattern subst spat))
 	   args t
 
-let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
-  Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]"
+let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++
+  Termops.print_constr (constr_of_term (term uf i)) ++ str "]"
 
 let pr_term t = str "[" ++
   Termops.print_constr (constr_of_term t) ++ str "]"
@@ -426,7 +512,8 @@ let rec add_term state t=
     try Termhash.find uf.syms t with
 	Not_found ->
 	  let b=next uf in
-	  let typ = pf_type_of state.gls (constr_of_term t) in
+          let trm = constr_of_term t in
+	  let typ = pf_type_of state.gls trm in
 	  let typ = canonize_name typ in
 	  let new_node=
 	    match t with
@@ -437,20 +524,23 @@ let rec add_term state t=
 		    Queue.add (b,Fmark paf) state.marks;
 		    {clas= Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex= Leaf;
 		     term= t}
 	      | Eps id ->
 		  {clas= Rep (new_representative typ);
 		   cpath= -1;
+		   constructors=PacMap.empty;
 		   vertex= Leaf;
 		   term= t}
 	      | Appli (t1,t2) ->
 		  let i1=add_term state t1 and i2=add_term state t2 in
 		    add_lfather uf (find uf i1) b;
 		    add_rfather uf (find uf i2) b;
-		    state.terms<-Intset.add b state.terms;
+		    state.terms<-Int.Set.add b state.terms;
 		    {clas= Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex= Node(i1,i2);
 		     term= t}
 	      | Constructor cinfo ->
@@ -465,15 +555,16 @@ let rec add_term state t=
 		    Queue.add (b,Cmark pac) state.marks;
 		    {clas=Rep (new_representative typ);
 		     cpath= -1;
+		     constructors=PacMap.empty;
 		     vertex=Leaf;
 		     term=t}
 	  in
 	    uf.map.(b)<-new_node;
 	    Termhash.add uf.syms t b;
 	    Typehash.replace state.by_type typ
-	      (Intset.add b
+	      (Int.Set.add b
 		 (try Typehash.find state.by_type typ with
-		      Not_found -> Intset.empty));
+		      Not_found -> Int.Set.empty));
 	    b
 
 let add_equality state c s t=
@@ -503,23 +594,23 @@ let is_redundant state id args =
     let prev_args = Identhash.find_all state.q_history id in
     List.exists
       (fun old_args ->
-	 Util.array_for_all2 (fun i j -> i = find state.uf j)
+	 Util.Array.for_all2 (fun i j -> Int.equal i (find state.uf j))
          norm_args old_args)
       prev_args
     with Not_found -> false
 
 let add_inst state (inst,int_subst) =
-  check_for_interrupt ();
+  Control.check_for_interrupt ();
   if state.rew_depth > 0 then
   if is_redundant state inst.qe_hyp_id int_subst then
-    debug msgnl (str "discarding redundant (dis)equality")
+    debug (str "discarding redundant (dis)equality")
   else
     begin
       Identhash.add state.q_history inst.qe_hyp_id int_subst;
       let subst = build_subst (forest state) int_subst in
       let prfhead= mkVar inst.qe_hyp_id in
       let args = Array.map constr_of_term subst in
-      let _ = array_rev args in (* highest deBruijn index first *)
+      let _ = Array.rev args in (* highest deBruijn index first *)
       let prf= mkApp(prfhead,args) in
 	  let s = inst_pattern subst inst.qe_lhs
 	  and t = inst_pattern subst inst.qe_rhs in
@@ -527,20 +618,18 @@ let add_inst state (inst,int_subst) =
 	    state.rew_depth<-pred state.rew_depth;
 	    if inst.qe_pol then
 	      begin
-		debug (fun () ->
-		  msgnl
-		   (str "Adding new equality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
-			   pr_term s ++ str " == " ++ pr_term t ++ str "]")) ();
+		debug (
+		   (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
+	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
+			   pr_term s ++ str " == " ++ pr_term t ++ str "]"));
 		add_equality state prf s t
 	      end
 	    else
 	      begin
-		debug (fun () ->
-		  msgnl
-		   (str "Adding new disequality, depth="++ int state.rew_depth);
-	          msgnl (str "  [" ++ Termops.print_constr prf ++ str " : " ++
-			   pr_term s ++ str " <> " ++ pr_term t ++ str "]")) ();
+		debug (
+		   (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
+	          (str "  [" ++ Termops.print_constr prf ++ str " : " ++
+			   pr_term s ++ str " <> " ++ pr_term t ++ str "]"));
 		add_disequality state (Hyp prf) s t
 	      end
   end
@@ -552,75 +641,77 @@ let link uf i j eq = (* links i -> j *)
 
 let rec down_path uf i l=
   match uf.map.(i).clas with
-      Eqto(j,t)->down_path uf j (((i,j),t)::l)
+      Eqto (j,eq) ->down_path uf j (((i,j),eq)::l)
     | Rep _ ->l
 
+let eq_pair (i1, j1) (i2, j2) = Int.equal i1 i2 && Int.equal j1 j2
+
 let rec min_path=function
     ([],l2)->([],l2)
   | (l1,[])->(l1,[])
-  | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2)
+  | (((c1,t1)::q1),((c2,t2)::q2)) when eq_pair c1 c2 -> min_path (q1,q2)
   | cpl -> cpl
 
 let join_path uf i j=
-  assert (find uf i=find uf j);
+  assert (Int.equal (find uf i) (find uf j));
   min_path (down_path uf i [],down_path uf j [])
 
 let union state i1 i2 eq=
-  debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++
-		 str " and " ++ pr_idx_term state i2 ++ str ".")) ();
+  debug (str "Linking " ++ pr_idx_term state.uf i1 ++
+		 str " and " ++ pr_idx_term state.uf i2 ++ str ".");
   let r1= get_representative state.uf i1
   and r2= get_representative state.uf i2 in
     link state.uf i1 i2 eq;
     Constrhash.replace state.by_type r1.class_type
-      (Intset.remove i1
+      (Int.Set.remove i1
 	 (try Constrhash.find state.by_type r1.class_type with
-	      Not_found -> Intset.empty));
-    let f= Intset.union r1.fathers r2.fathers in
-      r2.weight<-Intset.cardinal f;
+	      Not_found -> Int.Set.empty));
+    let f= Int.Set.union r1.fathers r2.fathers in
+      r2.weight<-Int.Set.cardinal f;
       r2.fathers<-f;
-      r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
+      r2.lfathers<-Int.Set.union r1.lfathers r2.lfathers;
       ST.delete_set state.sigtable r1.fathers;
-      state.terms<-Intset.union state.terms r1.fathers;
+      state.terms<-Int.Set.union state.terms r1.fathers;
       PacMap.iter
 	(fun pac b -> Queue.add (b,Cmark pac) state.marks)
-	r1.constructors;
+	state.uf.map.(i1).constructors;
       PafMap.iter
-	(fun paf -> Intset.iter
+	(fun paf -> Int.Set.iter
 	   (fun b -> Queue.add (b,Fmark paf) state.marks))
 	r1.functions;
       match r1.inductive_status,r2.inductive_status with
 	  Unknown,_ -> ()
 	| Partial pac,Unknown ->
 	    r2.inductive_status<-Partial pac;
-	    state.pa_classes<-Intset.remove i1 state.pa_classes;
-	    state.pa_classes<-Intset.add i2 state.pa_classes
+	    state.pa_classes<-Int.Set.remove i1 state.pa_classes;
+	    state.pa_classes<-Int.Set.add i2 state.pa_classes
 	| Partial _ ,(Partial _ |Partial_applied) ->
-	    state.pa_classes<-Intset.remove i1 state.pa_classes
+	    state.pa_classes<-Int.Set.remove i1 state.pa_classes
 	| Partial_applied,Unknown ->
 	    r2.inductive_status<-Partial_applied
 	| Partial_applied,Partial _ ->
-	    state.pa_classes<-Intset.remove i2 state.pa_classes;
+	    state.pa_classes<-Int.Set.remove i2 state.pa_classes;
 	    r2.inductive_status<-Partial_applied
 	| Total cpl,Unknown -> r2.inductive_status<-Total cpl;
 	| Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks
 	| _,_ -> ()
 
 let merge eq state = (* merge and no-merge *)
-  debug (fun () -> msgnl
-    (str "Merging " ++ pr_idx_term state eq.lhs ++
-       str " and " ++ pr_idx_term state eq.rhs ++ str ".")) ();
+  debug
+    (str "Merging " ++ pr_idx_term state.uf eq.lhs ++
+       str " and " ++ pr_idx_term state.uf eq.rhs ++ str ".");
   let uf=state.uf in
   let i=find uf eq.lhs
   and j=find uf eq.rhs in
-    if i<>j then
+    if not (Int.equal i j) then
       if (size uf i)<(size uf j) then
 	union state i j eq
       else
 	union state j i (swap eq)
 
 let update t state = (* update 1 and 2 *)
-  debug (fun () -> msgnl
-    (str "Updating term " ++ pr_idx_term state t ++ str ".")) ();
+  debug
+    (str "Updating term " ++ pr_idx_term state.uf t ++ str ".");
   let (i,j) as sign = signature state.uf t in
   let (u,v) = subterms state.uf t in
   let rep = get_representative state.uf i in
@@ -628,12 +719,12 @@ let update t state = (* update 1 and 2 *)
       match rep.inductive_status with
 	  Partial _ ->
 	    rep.inductive_status <- Partial_applied;
-	    state.pa_classes <- Intset.remove i state.pa_classes
+	    state.pa_classes <- Int.Set.remove i state.pa_classes
 	| _ -> ()
     end;
     PacMap.iter
       (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks)
-      rep.constructors;
+      (get_constructors state.uf i);
     PafMap.iter
       (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks)
       rep.functions;
@@ -645,12 +736,13 @@ let update t state = (* update 1 and 2 *)
 
 let process_function_mark t rep paf state  =
   add_paf rep paf t;
-  state.terms<-Intset.union rep.lfathers state.terms
+  state.terms<-Int.Set.union rep.lfathers state.terms
 
 let process_constructor_mark t i rep pac state =
-    match rep.inductive_status with
+     add_pac state.uf.map.(i) pac t;
+     match rep.inductive_status with
 	Total (s,opac) ->
-	  if pac.cnode <> opac.cnode then (* Conflict *)
+	  if not (Int.equal pac.cnode opac.cnode) then (* Conflict *)
 	    raise (Discriminable (s,opac,t,pac))
 	  else (* Match *)
 	    let cinfo = get_constructor_info state.uf pac.cnode in
@@ -662,26 +754,26 @@ let process_constructor_mark t i rep pac state =
 			{lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
 			state.combine;
 		      f (n-1) q1 q2
-		  | _-> anomaly
-		      "add_pacs : weird error in injection subterms merge"
+		  | _-> anomaly ~label:"add_pacs"
+		      (Pp.str "weird error in injection subterms merge")
 	    in f cinfo.ci_nhyps opac.args pac.args
       | Partial_applied | Partial _ ->
-	  add_pac rep pac t;
-	  state.terms<-Intset.union rep.lfathers state.terms
+(*	  add_pac state.uf.map.(i) pac t; *)
+	  state.terms<-Int.Set.union rep.lfathers state.terms
       | Unknown ->
-	  if pac.arity = 0 then
+	  if Int.equal pac.arity 0 then
 	    rep.inductive_status <- Total (t,pac)
 	  else
 	    begin
-	      add_pac rep pac t;
-	      state.terms<-Intset.union rep.lfathers state.terms;
+	     (* add_pac state.uf.map.(i) pac t; *)
+	      state.terms<-Int.Set.union rep.lfathers state.terms;
 	      rep.inductive_status <- Partial pac;
-	      state.pa_classes<- Intset.add i state.pa_classes
+	      state.pa_classes<- Int.Set.add i state.pa_classes
 	    end
 
 let process_mark t m state =
-  debug (fun () -> msgnl
-    (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) ();
+  debug
+    (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str ".");
   let i=find state.uf t in
   let rep=get_representative state.uf i in
     match m with
@@ -696,14 +788,15 @@ type explanation =
 let check_disequalities state =
   let uf=state.uf in
   let rec check_aux = function
-      dis::q ->
-	debug (fun () -> msg
-	(str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++
-	 pr_idx_term state dis.rhs ++ str " ... ")) ();
-	if find uf dis.lhs=find uf dis.rhs then
-	  begin debug msgnl (str "Yes");Some dis end
-	else
-	  begin debug msgnl (str "No");check_aux q end
+    | dis::q ->
+        let (info, ans) =
+          if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis)
+          else (str "No", check_aux q)
+        in
+        let _ = debug
+        (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
+         pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in
+        ans
     | [] -> None
   in
     check_aux state.diseq
@@ -720,13 +813,13 @@ let one_step state =
 	  true
       with Queue.Empty ->
 	try
-	  let t = Intset.choose state.terms in
-	    state.terms<-Intset.remove t state.terms;
+	  let t = Int.Set.choose state.terms in
+	    state.terms<-Int.Set.remove t state.terms;
 	    update t state;
 	    true
 	with Not_found -> false
 
-let __eps__ = id_of_string "_eps_"
+let __eps__ = Id.of_string "_eps_"
 
 let new_state_var typ state =
   let id = pf_get_new_id __eps__ state.gls in
@@ -752,10 +845,10 @@ let complete_one_class state i=
 	let ct = app (term state.uf i) typ pac.arity in
 	  state.uf.epsilons <- pac :: state.uf.epsilons;
 	  ignore (add_term state ct)
-    | _ -> anomaly "wrong incomplete class"
+    | _ -> anomaly (Pp.str "wrong incomplete class")
 
 let complete state =
-  Intset.iter (complete_one_class state) state.pa_classes
+  Int.Set.iter (complete_one_class state) state.pa_classes
 
 type matching_problem =
 {mp_subst : int array;
@@ -773,14 +866,14 @@ let make_fun_table state =
 	       (fun paf _ ->
 		  let elem =
 		    try PafMap.find paf !funtab
-		    with Not_found -> Intset.empty in
-		    funtab:= PafMap.add paf (Intset.add i elem) !funtab)
+		    with Not_found -> Int.Set.empty in
+		    funtab:= PafMap.add paf (Int.Set.add i elem) !funtab)
 	       rep.functions
 	 | _ -> ()) state.uf.map;
     !funtab
 
 
-let rec do_match state res pb_stack =
+let do_match state res pb_stack =
   let mp=Stack.pop pb_stack in
     match mp.mp_stack with
 	[] ->
@@ -795,13 +888,13 @@ let rec do_match state res pb_stack =
 		      Stack.push {mp with mp_stack=remains} pb_stack
 		    end
 		  else
-		    if mp.mp_subst.(pred i) = cl then
+		    if Int.equal mp.mp_subst.(pred i) cl then
 		      Stack.push {mp with mp_stack=remains} pb_stack
 		    else (* mismatch for non-linear variable in pattern *) ()
 	      | PApp (f,[]) ->
 		  begin
 		    try let j=Termhash.find uf.syms f in
-		      if find uf j =cl then
+		      if Int.equal (find uf j) cl then
 			Stack.push {mp with mp_stack=remains} pb_stack
 		    with Not_found -> ()
 		  end
@@ -819,7 +912,7 @@ let rec do_match state res pb_stack =
 			     mp_stack=
 			      (PApp(f,rem_args),s) ::
 				(last_arg,t) :: remains} pb_stack in
-		      Intset.iter aux good_terms
+		      Int.Set.iter aux good_terms
 		  with Not_found -> ()
 
 let paf_of_patt syms = function
@@ -836,21 +929,21 @@ let init_pb_stack state =
     begin
       let good_classes =
 	match inst.qe_lhs_valid with
-	  Creates_variables -> Intset.empty
+	  Creates_variables -> Int.Set.empty
 	| Normal ->
 	    begin
 	      try
 		let paf= paf_of_patt syms inst.qe_lhs in
 		  PafMap.find paf funtab
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end
 	| Trivial typ ->
 	    begin
 	      try
 		Typehash.find state.by_type typ
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end in
-	Intset.iter (fun i ->
+	Int.Set.iter (fun i ->
 		       Stack.push
 			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
@@ -859,21 +952,21 @@ let init_pb_stack state =
     begin
       let good_classes =
 	match inst.qe_rhs_valid with
-	  Creates_variables -> Intset.empty
+	  Creates_variables -> Int.Set.empty
 	| Normal ->
 	    begin
 	      try
 		let paf= paf_of_patt syms inst.qe_rhs in
 		  PafMap.find paf funtab
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end
 	| Trivial typ ->
 	    begin
 	      try
 		Typehash.find state.by_type typ
-	      with Not_found -> Intset.empty
+	      with Not_found -> Int.Set.empty
 	    end in
-	Intset.iter (fun i ->
+	Int.Set.iter (fun i ->
 		       Stack.push
 			 {mp_subst = Array.make inst.qe_nvars (-1);
 			  mp_inst=inst;
@@ -886,28 +979,28 @@ let find_instances state =
   let pb_stack= init_pb_stack state in
   let res =ref [] in
   let _ =
-    debug msgnl (str "Running E-matching algorithm ... ");
+    debug (str "Running E-matching algorithm ... ");
     try
       while true do
-	check_for_interrupt ();
+	Control.check_for_interrupt ();
 	do_match state res pb_stack
       done;
-      anomaly "get out of here !"
+      anomaly (Pp.str "get out of here !")
     with Stack.Empty -> () in
     !res
 
 let rec execute first_run state =
-  debug msgnl (str "Executing ... ");
+  debug (str "Executing ... ");
   try
     while
-      check_for_interrupt ();
+      Control.check_for_interrupt ();
       one_step state do ()
     done;
     match check_disequalities state with
 	None ->
-	  if not(Intset.is_empty state.pa_classes) then
+	  if not(Int.Set.is_empty state.pa_classes) then
 	    begin
-	      debug msgnl (str "First run was incomplete, completing ... ");
+	      debug (str "First run was incomplete, completing ... ");
 	      complete state;
 	      execute false state
 	    end
@@ -922,12 +1015,12 @@ let rec execute first_run state =
 		  end
 		else
 	      begin
-		debug msgnl (str "Out of instances ... ");
+		debug (str "Out of instances ... ");
 		None
 	      end
 	    else
 	      begin
-		debug msgnl (str "Out of depth ... ");
+		debug (str "Out of depth ... ");
 		None
 	      end
       | Some dis -> Some
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index e4713728..c72843d5 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.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        *)
@@ -10,40 +10,39 @@ open Util
 open Term
 open Names
 
+type pa_constructor =
+    { cnode : int;
+      arity : int;
+      args  : int list}
+
+type pa_fun=
+    {fsym:int;
+     fnargs:int}
+
+
+module PafMap : Map.S with type key = pa_fun
+module PacMap : Map.S with type key = pa_constructor
+
 type cinfo =
-    {ci_constr: constructor; (* inductive type *)
+    {ci_constr: pconstructor; (* inductive type *)
      ci_arity: int;     (* # args *)
      ci_nhyps: int}     (* # projectable args *)
 
 type term =
     Symb of constr
   | Product of sorts_family * sorts_family
-  | Eps of identifier
+  | Eps of Id.t
   | Appli of term*term
   | Constructor of cinfo (* constructor arity + nhyps *)
 
-val term_equal : term -> term -> bool
+module Constrhash : Hashtbl.S with type key = constr
+module Termhash : Hashtbl.S with type key = term
 
-type patt_kind =
-    Normal
-  | Trivial of types
-  | Creates_variables
 
 type ccpattern =
     PApp of term * ccpattern list
   | PVar of int
 
-type pa_constructor =
-    { cnode : int;
-      arity : int;
-      args  : int list}
-
-module PacMap : Map.S with type key = pa_constructor
-
-type forest
-
-type state
-
 type rule=
     Congruence
   | Axiom of constr * bool
@@ -61,17 +60,67 @@ type equality = rule eq
 
 type disequality = from eq
 
+type patt_kind =
+    Normal
+  | Trivial of types
+  | Creates_variables
+
+type quant_eq=
+    {qe_hyp_id: Id.t;
+     qe_pol: bool;
+     qe_nvars:int;
+     qe_lhs: ccpattern;
+     qe_lhs_valid:patt_kind;
+     qe_rhs: ccpattern;
+     qe_rhs_valid:patt_kind}
+
+type inductive_status =
+    Unknown
+  | Partial of pa_constructor
+  | Partial_applied
+  | Total of (int * pa_constructor)
+
+type representative=
+    {mutable weight:int;
+     mutable lfathers:Int.Set.t;
+     mutable fathers:Int.Set.t;
+     mutable inductive_status: inductive_status;
+     class_type : Term.types;
+     mutable functions: Int.Set.t PafMap.t} (*pac -> term = app(constr,t) *)
+
+type cl = Rep of representative| Eqto of int*equality
+
+type vertex = Leaf| Node of (int*int)
+
+type node =
+    {mutable clas:cl;
+     mutable cpath: int;
+     mutable constructors: int PacMap.t;
+     vertex:vertex;
+     term:term}
+
+type forest=
+    {mutable max_size:int;
+     mutable size:int;
+     mutable map: node array;
+     axioms: (term*term) Constrhash.t;
+     mutable epsilons: pa_constructor list;
+     syms: int Termhash.t}
+
+type state
+
 type explanation =
     Discrimination of (int*pa_constructor*int*pa_constructor)
   | Contradiction of disequality
   | Incomplete
 
-module Constrhash : Hashtbl.S with type key = constr
-module Termhash : Hashtbl.S with type key = term
+type matching_problem
+
+val term_equal : term -> term -> bool
 
 val constr_of_term : term -> constr
 
-val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
+val debug : Pp.std_ppcmds -> unit
 
 val forest : state -> forest
 
@@ -87,7 +136,7 @@ val add_equality : state -> constr -> term -> term -> unit
 
 val add_disequality : state -> from -> term -> term -> unit
 
-val add_quant : state -> identifier -> bool ->
+val add_quant : state -> Id.t -> bool ->
   int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
 
 val tail_pac : pa_constructor -> pa_constructor
@@ -96,6 +145,8 @@ val find : forest -> int -> int
 
 val find_pac : forest -> int -> pa_constructor -> int
 
+val find_oldest_pac : forest -> int -> pa_constructor -> int
+
 val term : forest -> int -> term
 
 val get_constructor_info : forest -> int -> cinfo
@@ -105,25 +156,7 @@ val subterms : forest -> int -> int * int
 val join_path : forest -> int -> int ->
   ((int * int) * equality) list * ((int * int) * equality) list
 
-type quant_eq=
-    {qe_hyp_id: identifier;
-     qe_pol: bool;
-     qe_nvars:int;
-     qe_lhs: ccpattern;
-     qe_lhs_valid:patt_kind;
-     qe_rhs: ccpattern;
-     qe_rhs_valid:patt_kind}
-
-
-type pa_fun=
-    {fsym:int;
-     fnargs:int}
-
-type matching_problem
-
-module PafMap: Map.S with type key = pa_fun
-
-val make_fun_table : state -> Intset.t PafMap.t
+val make_fun_table : state -> Int.Set.t PafMap.t
 
 val do_match :  state ->
     (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
@@ -136,8 +169,9 @@ val find_instances : state -> (quant_eq * int array) list
 
 val execute : bool -> state -> explanation option
 
+val pr_idx_term : forest -> int -> Pp.std_ppcmds
 
-
+val empty_forest: unit -> forest
 
 
 
@@ -161,7 +195,7 @@ type term =
 
 type rule =
     Congruence
-  | Axiom of Names.identifier
+  | Axiom of Names.Id.t
   | Injection of int*int*int*int
 
 type equality =
@@ -207,19 +241,19 @@ val process_rec : UF.t -> equality list -> int list
 val cc : UF.t -> unit
 
 val make_uf :
-  (Names.identifier * (term * term)) list -> UF.t
+  (Names.Id.t * (term * term)) list -> UF.t
 
 val add_one_diseq : UF.t -> (term * term) -> int * int
 
 val add_disaxioms :
-  UF.t -> (Names.identifier * (term * term)) list ->
-  (Names.identifier * (int * int)) list
+  UF.t -> (Names.Id.t * (term * term)) list ->
+  (Names.Id.t * (int * int)) list
 
 val check_equal : UF.t -> int * int -> bool
 
 val find_contradiction : UF.t ->
-  (Names.identifier * (int * int)) list ->
-  (Names.identifier * (int * int))
+  (Names.Id.t * (int * int)) list ->
+  (Names.Id.t * (int * int))
 *)
 
 
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index 037e9f66..42c03234 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.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        *)
@@ -9,10 +9,10 @@
 (* This file uses the (non-compressed) union-find structure to generate *)
 (* proof-trees that will be transformed into proof-terms in cctac.ml4   *)
 
-open Util
-open Names
+open Errors
 open Term
 open Ccalgo
+open Pp
 
 type rule=
     Ax of constr
@@ -20,7 +20,7 @@ type rule=
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int
+  | Inject of proof*pconstructor*int*int
 and proof =
     {p_lhs:term;p_rhs:term;p_rule:rule}
 
@@ -47,7 +47,7 @@ let rec ptrans p1 p3=
 	{p_lhs=p1.p_lhs;
 	 p_rhs=p3.p_rhs;
 	 p_rule=Trans (p1,p3)}
-      else anomaly "invalid cc transitivity"
+      else anomaly (Pp.str "invalid cc transitivity")
 
 let rec psym p =
   match p.p_rule with
@@ -85,67 +85,72 @@ let rec nth_arg t n=
 	if n>0 then
 	  nth_arg t1 (n-1)
 	else t2
-    | _ -> anomaly "nth_arg: not enough args"
+    | _ -> anomaly ~label:"nth_arg" (Pp.str "not enough args")
 
 let pinject p c n a =
   {p_lhs=nth_arg p.p_lhs (n-a);
    p_rhs=nth_arg p.p_rhs (n-a);
    p_rule=Inject(p,c,n,a)}
 
-let build_proof uf=
+let rec equal_proof uf i j=
+  debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  if i=j then prefl (term uf i) else
+    let (li,lj)=join_path uf i j in
+    ptrans (path_proof uf i li) (psym (path_proof uf j lj))
+      
+and edge_proof uf ((i,j),eq)=
+  debug (str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let pi=equal_proof uf i eq.lhs in
+  let pj=psym (equal_proof uf j eq.rhs) in
+  let pij=
+    match eq.rule with
+      Axiom (s,reversed)->
+	if reversed then psymax (axioms uf) s
+	else pax (axioms uf) s
+    | Congruence ->congr_proof uf eq.lhs eq.rhs
+    | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) 
+      let p=ind_proof uf ti ipac tj jpac in
+      let cinfo= get_constructor_info uf ipac.cnode in
+      pinject p cinfo.ci_constr cinfo.ci_nhyps k in  
+  ptrans (ptrans pi pij) pj
+  
+and constr_proof uf i ipac=
+  debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20));
+  let t=find_oldest_pac uf i ipac in
+  let eq_it=equal_proof uf i t in
+  if ipac.args=[] then
+    eq_it
+  else
+    let fipac=tail_pac ipac in
+    let (fi,arg)=subterms uf t in
+    let targ=term uf arg in
+    let p=constr_proof uf fi fipac in
+    ptrans eq_it (pcongr p (prefl targ))
+      
+and path_proof uf i l=
+  debug (str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++
+	   (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}");
+  match l with
+  | [] -> prefl (term uf i)
+  | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x)
+    
+and congr_proof uf i j=
+  debug (str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let (i1,i2) = subterms uf i
+  and (j1,j2) = subterms uf j in
+  pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2)
+    
+and ind_proof uf i ipac j jpac=
+   debug (str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+  let p=equal_proof uf i j
+  and p1=constr_proof uf i ipac
+  and p2=constr_proof uf j jpac in
+  ptrans (psym p1) (ptrans p p2)
 
-  let axioms = axioms uf in
-
-  let rec equal_proof i j=
-    if i=j then prefl (term uf i) else
-      let (li,lj)=join_path uf i j in
-	ptrans (path_proof i li) (psym (path_proof j lj))
-
-  and edge_proof ((i,j),eq)=
-    let pi=equal_proof i eq.lhs in
-    let pj=psym (equal_proof j eq.rhs) in
-    let pij=
-      match eq.rule with
-	  Axiom (s,reversed)->
-	    if reversed then psymax axioms s
-	    else pax axioms s
-	| Congruence ->congr_proof eq.lhs eq.rhs
-	| Injection (ti,ipac,tj,jpac,k) ->
-	    let p=ind_proof ti ipac tj jpac in
-	    let cinfo= get_constructor_info uf ipac.cnode in
-	      pinject p cinfo.ci_constr cinfo.ci_nhyps k
-    in  ptrans (ptrans pi pij) pj
-
-  and constr_proof i t ipac=
-    if ipac.args=[] then
-      equal_proof i t
-    else
-      let npac=tail_pac ipac in
-      let (j,arg)=subterms uf t in
-      let targ=term uf arg in
-      let rj=find uf j in
-      let u=find_pac uf rj npac in
-      let p=constr_proof j u npac in
-	ptrans (equal_proof i t) (pcongr p (prefl targ))
-
-  and path_proof i=function
-      [] -> prefl (term uf i)
-    | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x)
-
-  and congr_proof i j=
-    let (i1,i2) = subterms uf i
-    and (j1,j2) = subterms uf j in
-      pcongr (equal_proof i1 j1) (equal_proof i2 j2)
-
-  and ind_proof i ipac j jpac=
-    let p=equal_proof i j
-    and p1=constr_proof i i ipac
-    and p2=constr_proof j j jpac in
-      ptrans (psym p1) (ptrans p p2)
-  in
-    function
-	`Prove (i,j) -> equal_proof i j
-      | `Discr (i,ci,j,cj)-> ind_proof i ci j cj
+let build_proof uf=
+  function
+  | `Prove (i,j) -> equal_proof uf i j
+  | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj
 
 
 
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
index d55d3ef7..0e0eb6d2 100644
--- a/plugins/cc/ccproof.mli
+++ b/plugins/cc/ccproof.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        *)
@@ -16,14 +16,44 @@ type rule=
   | Refl of term
   | Trans of proof*proof
   | Congr of proof*proof
-  | Inject of proof*constructor*int*int
+  | Inject of proof*pconstructor*int*int
 and proof =
     private {p_lhs:term;p_rhs:term;p_rule:rule}
 
+(** Proof smart constructors *)
+
+val prefl:term -> proof
+
+val pcongr: proof -> proof -> proof
+
+val ptrans: proof -> proof -> proof
+
+val psym: proof -> proof
+
+val pax : (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t ->
+           Ccalgo.Constrhash.key -> proof
+
+val psymax :  (Ccalgo.term * Ccalgo.term) Ccalgo.Constrhash.t ->
+           Ccalgo.Constrhash.key -> proof
+
+val pinject :  proof -> pconstructor -> int -> int -> proof
+
+(** Proof building functions *)
+
+val equal_proof : forest -> int -> int -> proof
+
+val edge_proof : forest -> (int*int)*equality -> proof
+
+val path_proof : forest -> int -> ((int*int)*equality) list -> proof
+
+val congr_proof :  forest -> int -> int -> proof
+
+val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof
+
+(** Main proof building function *)
+
 val build_proof :
   forest ->
   [ `Discr of int * pa_constructor * int * pa_constructor
   | `Prove of int * int ] -> proof
 
-
-
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 60d42916..7110e5b2 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -1,49 +1,39 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
-
 (* This file is the interface between the c-c algorithm and Coq *)
 
 open Evd
-open Proof_type
 open Names
-open Libnames
-open Nameops
 open Inductiveops
 open Declarations
 open Term
+open Vars
 open Tacmach
 open Tactics
-open Tacticals
 open Typing
 open Ccalgo
-open Tacinterp
 open Ccproof
 open Pp
+open Errors
 open Util
-open Format
-
-let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
-
-let _f_equal = constant ["Init";"Logic"] "f_equal"
-
-let _eq_rect = constant ["Init";"Logic"] "eq_rect"
-
-let _refl_equal = constant ["Init";"Logic"] "eq_refl"
 
-let _sym_eq = constant ["Init";"Logic"] "eq_sym"
+let reference dir s = Coqlib.gen_reference "CC" dir s
 
-let _trans_eq = constant ["Init";"Logic"] "eq_trans"
-
-let _eq = constant ["Init";"Logic"] "eq"
-
-let _False = constant ["Init";"Logic"] "False"
+let _f_equal = reference ["Init";"Logic"] "f_equal"
+let _eq_rect = reference ["Init";"Logic"] "eq_rect"
+let _refl_equal = reference ["Init";"Logic"] "eq_refl"
+let _sym_eq = reference ["Init";"Logic"] "eq_sym"
+let _trans_eq = reference ["Init";"Logic"] "eq_trans"
+let _eq = reference ["Init";"Logic"] "eq"
+let _False = reference ["Init";"Logic"] "False"
+let _True = reference ["Init";"Logic"] "True"
+let _I = reference ["Init";"Logic"] "I"
 
 let whd env=
   let infos=Closure.create_clos_infos Closure.betaiotazeta env in
@@ -55,7 +45,8 @@ let whd_delta env=
 
 (* decompose member of equality in an applicative format *)
 
-let sf_of env sigma c = family_of_sort (sort_of env sigma c)
+(** FIXME: evar leak *)
+let sf_of env sigma c = family_of_sort (sort_of env (ref sigma) c)
 
 let rec decompose_term env sigma t=
     match kind_of_term (whd env t) with
@@ -70,32 +61,37 @@ let rec decompose_term env sigma t=
 	Appli(Appli(Product (sort_a,sort_b) ,
 		    decompose_term env sigma a),
 	      decompose_term env sigma b)
-    | Construct c->
-	let (mind,i_ind),i_con = c in 
+    | Construct c ->
+	let (((mind,i_ind),i_con),u)= c in 
 	let canon_mind = mind_of_kn (canonical_mind mind) in
 	let canon_ind = canon_mind,i_ind in
 	let (oib,_)=Global.lookup_inductive (canon_ind) in
-	let nargs=mis_constructor_nargs_env env (canon_ind,i_con) in
-	  Constructor {ci_constr= (canon_ind,i_con);
+	let nargs=constructor_nallargs_env env (canon_ind,i_con) in
+	  Constructor {ci_constr= ((canon_ind,i_con),u);
 		       ci_arity=nargs;
 		       ci_nhyps=nargs-oib.mind_nparams}
     | Ind c -> 
-	let mind,i_ind = c in 
+	let (mind,i_ind),u = c in 
 	let canon_mind = mind_of_kn (canonical_mind mind) in
-	let canon_ind = canon_mind,i_ind in  (Symb (mkInd canon_ind))
-    | Const c -> 
+	let canon_ind = canon_mind,i_ind in  (Symb (mkIndU (canon_ind,u)))
+    | Const (c,u) -> 
 	let canon_const = constant_of_kn (canonical_con c) in 
-	  (Symb (mkConst canon_const))
+	  (Symb (mkConstU (canon_const,u)))
+    | Proj (p, c) -> 
+	let canon_const kn = constant_of_kn (canonical_con kn) in 
+	let p' = Projection.map canon_const p in
+	  (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c))
     | _ ->if closed0 t then (Symb t) else raise Not_found
 
 (* decompose equality in members and type *)
+open Globnames
 
 let atom_of_constr env sigma term =
   let wh =  (whd_delta env term) in
   let kot = kind_of_term wh in
     match kot with
       App (f,args)->
-	  if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+	if is_global _eq f && Int.equal (Array.length args) 3
 	  then `Eq (args.(0),
 		   decompose_term env sigma args.(1),
 		   decompose_term env sigma args.(2))
@@ -107,9 +103,9 @@ let rec pattern_of_constr env sigma c =
       App (f,args)->
 	let pf = decompose_term env sigma f in
 	let pargs,lrels = List.split
-	  (array_map_to_list (pattern_of_constr env sigma) args) in
+	  (Array.map_to_list (pattern_of_constr env sigma) args) in
 	  PApp (pf,List.rev pargs),
-	List.fold_left Intset.union Intset.empty lrels
+	List.fold_left Int.Set.union Int.Set.empty lrels
     | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
 	let b = Termops.pop _b in
 	let pa,sa = pattern_of_constr env sigma a in
@@ -117,11 +113,11 @@ let rec pattern_of_constr env sigma c =
 	let sort_b = sf_of env sigma b in
 	let sort_a = sf_of env sigma a in
 	  PApp(Product (sort_a,sort_b),
-	       [pa;pb]),(Intset.union sa sb)
-    | Rel i -> PVar i,Intset.singleton i
+	       [pa;pb]),(Int.Set.union sa sb)
+    | Rel i -> PVar i,Int.Set.singleton i
     | _ ->
 	let pf = decompose_term env sigma c in
-	  PApp (pf,[]),Intset.empty
+	  PApp (pf,[]),Int.Set.empty
 
 let non_trivial = function
     PVar _ -> false
@@ -129,23 +125,21 @@ let non_trivial = function
 
 let patterns_of_constr env sigma nrels term=
   let f,args=
-    try destApp (whd_delta env term)
-    with e when Errors.noncritical e -> raise Not_found
-  in
-	if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+    try destApp (whd_delta env term) with DestKO -> raise Not_found in
+	if is_global _eq f && Int.equal (Array.length args) 3
 	then
 	  let patt1,rels1 = pattern_of_constr env sigma args.(1)
 	  and patt2,rels2 = pattern_of_constr env sigma args.(2) in
 	  let valid1 =
-	    if Intset.cardinal rels1 <> nrels then Creates_variables
+	    if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables
 	    else if non_trivial patt1 then Normal
 	    else Trivial args.(0)
 	  and valid2 =
-	    if Intset.cardinal rels2 <> nrels then Creates_variables
+	    if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables
 	    else if non_trivial patt2 then Normal
 	    else Trivial args.(0) in
-	    if valid1 <> Creates_variables
-	      || valid2 <> Creates_variables  then
+	    if valid1 != Creates_variables
+	      || valid2 != Creates_variables  then
 	      nrels,valid1,patt1,valid2,patt2
 	    else raise Not_found
 	else raise Not_found
@@ -153,7 +147,7 @@ let patterns_of_constr env sigma nrels term=
 let rec quantified_atom_of_constr env sigma nrels term =
   match kind_of_term (whd_delta env term) with
       Prod (id,atom,ff) -> 
-	if eq_constr ff (Lazy.force _False) then
+	if is_global _False ff then
 	  let patts=patterns_of_constr env sigma nrels atom in
 	      `Nrule patts
 	else 
@@ -165,7 +159,7 @@ let rec quantified_atom_of_constr env sigma nrels term =
 let litteral_of_constr env sigma term=
   match kind_of_term (whd_delta env term) with
     | Prod (id,atom,ff) -> 
-	if eq_constr ff (Lazy.force _False) then
+	if is_global _False ff then
 	  match (atom_of_constr env sigma atom) with
 	      `Eq(t,a,b) -> `Neq(t,a,b)
 	    | `Other(p) -> `Nother(p)
@@ -182,7 +176,7 @@ let litteral_of_constr env sigma term=
 
 (* store all equalities from the context *)
 
-let rec make_prb gls depth additionnal_terms =
+let make_prb gls depth additionnal_terms =
   let env=pf_env gls in
   let sigma=sig_sig gls in
   let state = empty depth gls in
@@ -213,9 +207,9 @@ let rec make_prb gls depth additionnal_terms =
 		 neg_hyps:=(cid,nh):: !neg_hyps
 	     | `Rule patts -> add_quant state id true patts
 	     | `Nrule patts -> add_quant state id false patts
-	 end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it));
+	 end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it));
     begin
-      match atom_of_constr env sigma (pf_concl gls) with
+      match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with
 	  `Eq (t,a,b) -> add_disequality state Goal a b
 	|	`Other g ->
 		  List.iter
@@ -226,226 +220,256 @@ let rec make_prb gls depth additionnal_terms =
 
 (* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
 
-let build_projection intype outtype (cstr:constructor) special default gls=
+let build_projection intype outtype (cstr:pconstructor) special default gls=
   let env=pf_env gls in
-  let (h,argv) =
-    try destApp intype with
-	Invalid_argument _ -> (intype,[||])  in
-  let ind=destInd h in
-  let types=Inductiveops.arities_of_constructors env ind in
+  let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in
+  let ind,u=destInd h in
+  let types=Inductiveops.arities_of_constructors env (ind,u) in
   let lp=Array.length types in
-  let ci=pred (snd cstr) in
+  let ci=pred (snd(fst cstr)) in
   let branch i=
-    let ti=Term.prod_appvect types.(i) argv in
+    let ti= prod_appvect types.(i) argv in
     let rc=fst (decompose_prod_assum ti) in
     let head=
-      if i=ci then special else default in
+      if Int.equal i ci then special else default in
       it_mkLambda_or_LetIn head rc in
   let branches=Array.init lp branch in
   let casee=mkRel 1 in
   let pred=mkLambda(Anonymous,intype,outtype) in
   let case_info=make_case_info (pf_env gls) ind RegularStyle in
   let body= mkCase(case_info, pred, casee, branches) in
-  let id=pf_get_new_id (id_of_string "t") gls in
+  let id=pf_get_new_id (Id.of_string "t") gls in
     mkLambda(Name id,intype,body)
 
 (* generate an adhoc tactic following the proof tree  *)
 
 let _M =mkMeta
 
-let rec proof_tac p gls =
+let app_global f args k = 
+  Tacticals.pf_constr_of_global f (fun fc -> k (mkApp (fc, args)))
+
+let new_app_global f args k = 
+  Tacticals.New.pf_constr_of_global f (fun fc -> k (mkApp (fc, args)))
+
+let new_refine c = Proofview.V82.tactic (refine c)
+
+let rec proof_tac p : unit Proofview.tactic =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of t = Tacmach.New.pf_type_of gl t in
+  try (* type_of can raise exceptions *)
   match p.p_rule with
-      Ax c -> exact_check c gls
+      Ax c -> exact_check c
     | SymAx c ->
 	let l=constr_of_term p.p_lhs and
 	    r=constr_of_term p.p_rhs in
-        let typ = Termops.refresh_universes (pf_type_of gls l) in
-	  exact_check
-	    (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls
+        let typ = (* Termops.refresh_universes *) type_of l in
+        new_app_global _sym_eq [|typ;r;l;c|] exact_check
     | Refl t ->
 	let lr = constr_of_term t in
-	let typ = Termops.refresh_universes (pf_type_of gls lr) in
-	exact_check
-	   (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls
+	let typ = (* Termops.refresh_universes *) type_of lr in
+        new_app_global _refl_equal [|typ;constr_of_term t|] exact_check
     | Trans (p1,p2)->
 	let t1 = constr_of_term p1.p_lhs and
 	    t2 = constr_of_term p1.p_rhs and
 	    t3 = constr_of_term p2.p_rhs in
-	let typ = Termops.refresh_universes (pf_type_of gls t2) in
-	let prf =
-	  mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in
-	  tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls
+	let typ = (* Termops.refresh_universes *) (type_of t2) in
+	let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in
+          Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]
     | Congr (p1,p2)->
 	let tf1=constr_of_term p1.p_lhs
 	and tx1=constr_of_term p2.p_lhs
 	and tf2=constr_of_term p1.p_rhs
 	and tx2=constr_of_term p2.p_rhs in
-	let typf = Termops.refresh_universes (pf_type_of gls tf1) in
-	let typx = Termops.refresh_universes (pf_type_of gls tx1) in
-	let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in
-	let id = pf_get_new_id (id_of_string "f") gls in
+	let typf = (* Termops.refresh_universes  *)(type_of tf1) in
+	let typx = (* Termops.refresh_universes *) (type_of tx1) in
+	let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in
+        let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in
 	let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
 	let lemma1 =
-	  mkApp(Lazy.force _f_equal,
-		[|typf;typfx;appx1;tf1;tf2;_M 1|]) in
+	  app_global _f_equal
+		[|typf;typfx;appx1;tf1;tf2;_M 1|] in
 	let lemma2=
-	  mkApp(Lazy.force _f_equal,
-		[|typx;typfx;tf2;tx1;tx2;_M 1|]) in
+	  app_global _f_equal
+		[|typx;typfx;tf2;tx1;tx2;_M 1|] in
 	let prf =
-	  mkApp(Lazy.force _trans_eq,
+	  app_global _trans_eq
 		[|typfx;
 		  mkApp(tf1,[|tx1|]);
 		  mkApp(tf2,[|tx1|]);
-		  mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in
-	  tclTHENS (refine prf)
-	    [tclTHEN (refine lemma1) (proof_tac p1);
-  	     tclFIRST
-	       [tclTHEN (refine lemma2) (proof_tac p2);
+		  mkApp(tf2,[|tx2|]);_M 2;_M 3|] in
+	  Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine))
+	    [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1);
+  	     Tacticals.New.tclFIRST
+	       [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2);
 		reflexivity;
-		fun gls ->
-		  errorlabstrm  "Congruence"
+                Proofview.tclZERO (UserError ("Congruence" ,
 		    (Pp.str
-		       "I don't know how to handle dependent equality")]] gls
+		       "I don't know how to handle dependent equality")))]]
   | Inject (prf,cstr,nargs,argind) ->
 	 let ti=constr_of_term prf.p_lhs in
 	 let tj=constr_of_term prf.p_rhs in
 	 let default=constr_of_term p.p_lhs in
-	 let intype = Termops.refresh_universes (pf_type_of gls ti) in
-	 let outtype = Termops.refresh_universes (pf_type_of gls default) in
+	 let intype = (* Termops.refresh_universes *) (type_of ti) in
+	 let outtype = (* Termops.refresh_universes *) (type_of default) in
 	 let special=mkRel (1+nargs-argind) in
-	 let proj=build_projection intype outtype cstr special default gls in
+         let proj =
+           Tacmach.New.of_old (build_projection intype outtype cstr special default) gl
+         in
 	 let injt=
-	   mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in
-	   tclTHEN (refine injt) (proof_tac prf) gls
+           app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in
+	   Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)
+  with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
-let refute_tac c t1 t2 p gls =
+let refute_tac c t1 t2 p =
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let intype = Termops.refresh_universes (pf_type_of gls tt1) in
-  let neweq=
-    mkApp(Lazy.force _eq,
-	  [|intype;tt1;tt2|]) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
+  let intype =
+    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl
+  in
+  let neweq= new_app_global _eq [|intype;tt1;tt2|] in
+  let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
   let false_t=mkApp (c,[|mkVar hid|]) in
-    tclTHENS (assert_tac (Name hid) neweq)
-      [proof_tac p; simplest_elim false_t] gls
+    Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+      [proof_tac p; simplest_elim false_t]
+  end
 
-let convert_to_goal_tac c t1 t2 p gls =
+let refine_exact_check c gl =
+  let evm, _ = pf_apply e_type_of gl c in
+    Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl
+
+let convert_to_goal_tac c t1 t2 p = 
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
-  let sort = Termops.refresh_universes (pf_type_of gls tt2) in
-  let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in
-  let e=pf_get_new_id (id_of_string "e") gls in
-  let x=pf_get_new_id (id_of_string "X") gls in
+  let sort =
+    Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl
+  in
+  let neweq= new_app_global _eq [|sort;tt1;tt2|] in
+  let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in
+  let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
   let identity=mkLambda (Name x,sort,mkRel 1) in
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|sort;tt1;identity;c;tt2;mkVar e|]) in
-    tclTHENS (assert_tac (Name e) neweq)
-      [proof_tac p;exact_check endt] gls
+  let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
+    Tacticals.New.tclTHENS (neweq (assert_before (Name e)))
+      [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
+  end
 
-let convert_to_hyp_tac c1 t1 c2 t2 p gls =
+let convert_to_hyp_tac c1 t1 c2 t2 p =
+  Proofview.Goal.nf_enter begin fun gl ->
   let tt2=constr_of_term t2 in
-  let h=pf_get_new_id (id_of_string "H") gls in
+  let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in
   let false_t=mkApp (c2,[|mkVar h|]) in
-    tclTHENS (assert_tac (Name h) tt2)
+    Tacticals.New.tclTHENS (assert_before (Name h) tt2)
       [convert_to_goal_tac c1 t1 t2 p;
-       simplest_elim false_t] gls
-
-let discriminate_tac cstr p gls =
-  let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
-  let intype = Termops.refresh_universes (pf_type_of gls t1) in
-  let concl=pf_concl gls in
-  let outsort = mkType (Termops.new_univ ()) in
-  let xid=pf_get_new_id (id_of_string "X") gls in
-  let tid=pf_get_new_id (id_of_string "t") gls in
-  let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
-  let trivial=pf_type_of gls identity in
-  let outtype = mkType (Termops.new_univ ()) in
-  let pred=mkLambda(Name xid,outtype,mkRel 1) in
-  let hid=pf_get_new_id (id_of_string "Heq") gls in
-  let proj=build_projection intype outtype cstr trivial concl gls in
-  let injt=mkApp (Lazy.force _f_equal,
-		  [|intype;outtype;proj;t1;t2;mkVar hid|]) in
-  let endt=mkApp (Lazy.force _eq_rect,
-		  [|outtype;trivial;pred;identity;concl;injt|]) in
-  let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in
-    tclTHENS (assert_tac (Name hid) neweq)
-      [proof_tac p;exact_check endt] gls
+       simplest_elim false_t]
+  end
+
+let discriminate_tac (cstr,u as cstru) p =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
+    let intype =
+      Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl
+    in
+    let concl = Proofview.Goal.concl gl in
+    (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in  *)
+    (* let outsort = mkSort outsort in *)
+    let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
+    (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *)
+    (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *)
+    let identity = Universes.constr_of_global _I in
+    (* let trivial=pf_type_of gls identity in *)
+    let trivial = Universes.constr_of_global _True in
+    let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in 
+    let outtype = mkSort outtype in
+    let pred=mkLambda(Name xid,outtype,mkRel 1) in
+    let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
+    let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in
+    let injt=app_global _f_equal
+                    [|intype;outtype;proj;t1;t2;mkVar hid|] in
+    let endt k =
+      injt (fun injt ->
+        app_global _eq_rect
+          [|outtype;trivial;pred;identity;concl;injt|] k) in
+    let neweq=new_app_global _eq [|intype;t1;t2|] in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm)
+      (Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+        [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
+  end
 
 (* wrap everything *)
 
 let build_term_to_complete uf meta pac =
   let cinfo = get_constructor_info uf pac.cnode in
   let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
-  let dummy_args = List.rev (list_tabulate meta pac.arity) in
+  let dummy_args = List.rev (List.init pac.arity meta) in
   let all_args = List.rev_append real_args dummy_args in
-    applistc (mkConstruct cinfo.ci_constr) all_args
-
-let cc_tactic depth additionnal_terms gls=
-  Coqlib.check_required_library ["Coq";"Init";"Logic"];
-  let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
-  let state = make_prb gls depth additionnal_terms in
-  let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
-  let sol = execute true state in
-  let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
-  let uf=forest state in
+    applistc (mkConstructU cinfo.ci_constr) all_args
+
+let cc_tactic depth additionnal_terms =
+  Proofview.Goal.nf_enter begin fun gl ->
+    Coqlib.check_required_library Coqlib.logic_module_name;
+    let _ = debug (Pp.str "Reading subgoal ...") in
+    let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in
+    let _ = debug (Pp.str "Problem built, solving ...") in
+    let sol = execute true state in
+    let _ = debug (Pp.str "Computation completed.") in
+    let uf=forest state in
     match sol with
-	None -> tclFAIL 0 (str "congruence failed") gls
-      | Some reason ->
-	  debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
-	  match reason with
-	      Discrimination (i,ipac,j,jpac) ->
-		let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
-		let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
-		  discriminate_tac cstr p gls
-	    | Incomplete ->
-		let metacnt = ref 0 in
-		let newmeta _ = incr metacnt; _M !metacnt in
-		let terms_to_complete =
-		  List.map
-		    (build_term_to_complete uf newmeta)
-		    (epsilons uf) in
-		  Pp.msgnl
-		    (Pp.str "Goal is solvable by congruence but \
+      None -> Tacticals.New.tclFAIL 0 (str "congruence failed")
+    | Some reason ->
+	debug (Pp.str "Goal solved, generating proof ...");
+	match reason with
+	  Discrimination (i,ipac,j,jpac) ->
+	    let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
+	    let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
+	    discriminate_tac cstr p
+	| Incomplete ->
+            let env = Proofview.Goal.env gl in
+	    let metacnt = ref 0 in
+	    let newmeta _ = incr metacnt; _M !metacnt in
+	    let terms_to_complete =
+	      List.map
+		(build_term_to_complete uf newmeta)
+		(epsilons uf) in
+	    Pp.msg_info
+	      (Pp.str "Goal is solvable by congruence but \
  some arguments are missing.");
-		  Pp.msgnl
-		    (Pp.str "  Try " ++
-		     hov 8
-		       begin
-			 str "\"congruence with (" ++
-			 prlist_with_sep
-			   (fun () -> str ")" ++ pr_spc () ++ str "(")
-			   (Termops.print_constr_env (pf_env gls))
-			   terms_to_complete ++
-			 str ")\","
-		       end);
-		  Pp.msgnl
-		    (Pp.str "  replacing metavariables by arbitrary terms.");
-		  tclFAIL 0 (str "Incomplete") gls
-	    | Contradiction dis ->
-		let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
-		let ta=term uf dis.lhs and tb=term uf dis.rhs in
-		  match dis.rule with
-		      Goal -> proof_tac p gls
-		    | Hyp id -> refute_tac id ta tb p gls
-		    | HeqG id ->
-			convert_to_goal_tac id ta tb p gls
-		    | HeqnH (ida,idb) ->
-			convert_to_hyp_tac ida ta idb tb p gls
-
+	    Pp.msg_info
+	      (Pp.str "  Try " ++
+		 hov 8
+		 begin
+		   str "\"congruence with (" ++
+		     prlist_with_sep
+		     (fun () -> str ")" ++ spc () ++ str "(")
+		     (Termops.print_constr_env env)
+		     terms_to_complete ++
+		     str ")\","
+		 end ++
+		 Pp.str "  replacing metavariables by arbitrary terms.");
+	    Tacticals.New.tclFAIL 0 (str "Incomplete")
+	| Contradiction dis ->
+	    let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
+	    let ta=term uf dis.lhs and tb=term uf dis.rhs in
+	    match dis.rule with
+	      Goal -> proof_tac p
+	    | Hyp id -> refute_tac id ta tb p
+	    | HeqG id ->
+		convert_to_goal_tac id ta tb p
+	    | HeqnH (ida,idb) ->
+		convert_to_hyp_tac ida ta idb tb p
+  end
 
 let cc_fail gls =
   errorlabstrm  "Congruence" (Pp.str "congruence failed.")
 
 let congruence_tac depth l =
-  tclORELSE
-    (tclTHEN (tclREPEAT introf) (cc_tactic depth l))
-    cc_fail
+  Tacticals.New.tclORELSE
+    (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l))
+    (Proofview.V82.tactic cc_fail)
 
 (* Beware: reflexivity = constructor 1 = apply refl_equal
    might be slow now, let's rather do something equivalent
    to a "simple apply refl_equal" *)
 
-let simple_reflexivity () = apply (Lazy.force _refl_equal)
-
 (* The [f_equal] tactic.
 
    It mimics the use of lemmas [f_equal], [f_equal2], etc.
@@ -453,22 +477,35 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal)
    the fact that congruence is called internally.
 *)
 
-let f_equal gl =
-  let cut_eq c1 c2 =
-    let ty = Termops.refresh_universes (pf_type_of gl c1) in
-    tclTHENTRY
-      (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|])))
-      (simple_reflexivity ())
-  in
-  try match kind_of_term (pf_concl gl) with
-    | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) ->
-	begin match kind_of_term t, kind_of_term t' with
-	  | App (f,v), App (f',v') when Array.length v = Array.length v' ->
+let f_equal =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let cut_eq c1 c2 =
+      try (* type_of can raise an exception *)
+        let ty = (* Termops.refresh_universes *) (type_of c1) in
+        if eq_constr_nounivs c1 c2 then Proofview.tclUNIT ()
+        else
+          Tacticals.New.tclTRY (Tacticals.New.tclTHEN
+          ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut)
+          (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)))
+      with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+    in
+    Proofview.tclORELSE
+      begin match kind_of_term concl with
+      | App (r,[|_;t;t'|]) when Globnames.is_global _eq r ->
+	  begin match kind_of_term t, kind_of_term t' with
+	  | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') ->
 	      let rec cuts i =
-		if i < 0 then tclTRY (congruence_tac 1000 [])
-		else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
-	      in cuts (Array.length v - 1) gl
-	  | _ -> tclIDTAC gl
-	end
-    | _ -> tclIDTAC gl
-  with Type_errors.TypeError _ -> tclIDTAC gl
+		if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 [])
+		else Tacticals.New.tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
+	      in cuts (Array.length v - 1)
+	  | _ -> Proofview.tclUNIT ()
+	  end
+      | _ -> Proofview.tclUNIT ()
+      end
+      begin function (e, info) -> match e with
+        | Type_errors.TypeError _ -> Proofview.tclUNIT ()
+        | e -> Proofview.tclZERO ~info e
+      end
+  end
diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
index 60a1b2ec..7c1d9f1c 100644
--- a/plugins/cc/cctac.mli
+++ b/plugins/cc/cctac.mli
@@ -1,6 +1,7 @@
+
 (************************************************************************)
 (*  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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -9,12 +10,12 @@
 open Term
 open Proof_type
 
-val proof_tac: Ccproof.proof -> Proof_type.tactic
+val proof_tac: Ccproof.proof -> unit Proofview.tactic
 
-val cc_tactic : int -> constr list -> tactic
+val cc_tactic : int -> constr list ->  unit Proofview.tactic
 
 val cc_fail : tactic
 
-val congruence_tac : int -> constr list -> tactic
+val congruence_tac : int -> constr list -> unit Proofview.tactic
 
-val f_equal : tactic
+val f_equal : unit Proofview.tactic
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 8b3fe770..aa31c6f0 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -1,16 +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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Cctac
-open Tactics
-open Tacticals
+
+DECLARE PLUGIN "cc_plugin"
 
 (* Tactic registration *)
 
diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
index 86b5e95b..7467604a 100644
--- a/plugins/decl_mode/decl_expr.mli
+++ b/plugins/decl_mode/decl_expr.mli
@@ -1,22 +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 Names
-open Util
 open Tacexpr
 
 type 'it statement =
-    {st_label:name;
+    {st_label:Name.t;
      st_it:'it}
 
 type thesis_kind =
     Plain
-  | For of identifier
+  | For of Id.t
 
 type 'this or_thesis =
     This of 'this
@@ -60,8 +59,8 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr =
   | Pconsider of 'constr*('hyp,'constr) hyp list
   | Pclaim of 'constr statement
   | Pfocus of 'constr statement
-  | Pdefine of identifier * 'hyp list * 'constr
-  | Pcast of identifier or_thesis * 'constr
+  | Pdefine of Id.t * 'hyp list * 'constr
+  | Pcast of Id.t or_thesis * 'constr
   | Psuppose of ('hyp,'constr) hyp list
   | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list)
   | Ptake of 'constr list
@@ -77,15 +76,15 @@ type ('hyp,'constr,'pat,'tac) gen_proof_instr=
 
 
 type raw_proof_instr =
-    ((identifier*(Topconstr.constr_expr option)) located,
-     Topconstr.constr_expr,
-     Topconstr.cases_pattern_expr,
+    ((Id.t*(Constrexpr.constr_expr option)) Loc.located,
+     Constrexpr.constr_expr,
+     Constrexpr.cases_pattern_expr,
      raw_tactic_expr) gen_proof_instr
 
 type glob_proof_instr =
-    ((identifier*(Genarg.glob_constr_and_expr option)) located,
-     Genarg.glob_constr_and_expr,
-     Topconstr.cases_pattern_expr,
+    ((Id.t*(Tacexpr.glob_constr_and_expr option)) Loc.located,
+     Tacexpr.glob_constr_and_expr,
+     Constrexpr.cases_pattern_expr,
      Tacexpr.glob_tactic_expr) gen_proof_instr
 
 type proof_pattern =
@@ -94,7 +93,7 @@ type proof_pattern =
      pat_constr: Term.constr;
      pat_typ: Term.types;
      pat_pat: Glob_term.cases_pattern;
-     pat_expr: Topconstr.cases_pattern_expr}
+     pat_expr: Constrexpr.cases_pattern_expr}
 
 type proof_instr =
     (Term.constr statement,
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 60988dd1..1c56586c 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -1,27 +1,29 @@
 (************************************************************************)
 (*  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 Topconstr
-open Tacinterp
-open Tacmach
+open Constrexpr
+open Tacintern
 open Decl_expr
 open Decl_mode
-open Pretyping.Default
+open Pretyping
 open Glob_term
 open Term
+open Vars
 open Pp
-open Compat
+open Decl_kinds
+open Misctypes
 
 (* INTERN *)
 
-let glob_app (loc,hd,args) = if args =[] then hd else GApp(loc,hd,args)
+let glob_app (loc,hd,args) = if List.is_empty args then hd else GApp(loc,hd,args)
 
 let intern_justification_items globs =
   Option.map (List.map (intern_constr globs))
@@ -41,8 +43,7 @@ let intern_constr_or_thesis globs = function
   | This c -> This (intern_constr globs c)
 
 let add_var id globs=
-  let l1,l2=globs.ltacvars in
-    {globs with ltacvars= (id::l1),(id::l2)}
+    {globs with ltacvars = Id.Set.add id globs.ltacvars}
 
 let add_name nam globs=
  match nam with
@@ -56,7 +57,7 @@ let intern_hyp iconstr globs = function
       Hprop (intern_statement iconstr globs st)
 
 let intern_hyps iconstr globs hyps =
-  snd (list_fold_map (intern_hyp iconstr) globs hyps)
+  snd (List.fold_map (intern_hyp iconstr) globs hyps)
 
 let intern_cut intern_it globs cut=
   let nglobs,nstat=intern_it globs cut.cut_stat in
@@ -73,10 +74,10 @@ let intern_hyp_list args globs =
   let intern_one globs (loc,(id,opttyp)) =
     (add_var id globs),
     (loc,(id,Option.map (intern_constr globs) opttyp)) in
-  list_fold_map intern_one globs args
+  List.fold_map intern_one globs args
 
 let intern_suffices_clause globs (hyps,c) =
-  let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
+  let nglobs,nhyps = List.fold_map (intern_hyp intern_constr) globs hyps in
     nglobs,(nhyps,intern_constr_or_thesis nglobs c)
 
 let intern_fundecl args body globs=
@@ -93,10 +94,11 @@ let rec add_vars_of_simple_pattern globs = function
 	(UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
   | CPatDelimiters (_,_,p) ->
       add_vars_of_simple_pattern globs p
-  | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) ->
-      List.fold_left add_vars_of_simple_pattern globs pl
-  | CPatNotation(_,_,(pl,pll)) ->
-      List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
+  | CPatCstr (_,_,pl1,pl2) ->
+    List.fold_left add_vars_of_simple_pattern
+      (List.fold_left add_vars_of_simple_pattern globs pl1) pl2
+  | CPatNotation(_,_,(pl,pll),pl') ->
+      List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll))
   | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
   |  _  -> globs
 
@@ -135,33 +137,33 @@ let rec intern_bare_proof_instr globs = function
   | Pcast (id,typ) ->
       Pcast (id,intern_constr globs typ)
 
-let rec intern_proof_instr globs instr=
+let intern_proof_instr globs instr=
   {emph = instr.emph;
    instr = intern_bare_proof_instr globs instr.instr}
 
 (* INTERP *)
 
-let interp_justification_items sigma env =
-    Option.map (List.map (fun c ->understand sigma env (fst c)))
+let interp_justification_items env sigma =
+    Option.map (List.map (fun c -> fst (*FIXME*)(understand env sigma (fst c))))
 
-let interp_constr check_sort sigma env c =
+let interp_constr check_sort env sigma c =
   if check_sort then
-    understand_type sigma env (fst c)
+    fst (understand env sigma ~expected_type:IsType (fst c) (* FIXME *))
   else
-    understand sigma env (fst c)
+    fst (understand env sigma (fst c))
 
 let special_whd env =
   let infos=Closure.create_clos_infos Closure.betadeltaiota env in
     (fun t -> Closure.whd_val infos (Closure.inject t))
 
-let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
+let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
 
 let decompose_eq env id =
   let typ = Environ.named_type id env in
   let whd = special_whd env typ in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3
+	  if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3
 	  then args.(0)
 	  else error "Previous step is not an equality."
       | _ -> error "Previous step is not an equality."
@@ -170,30 +172,30 @@ let get_eq_typ info env =
   let typ = decompose_eq env (get_last env) in
     typ
 
-let interp_constr_in_type typ sigma env c =
-  understand sigma env (fst c) ~expected_type:typ
+let interp_constr_in_type typ env sigma c =
+  fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*)
 
-let interp_statement interp_it sigma env st =
+let interp_statement interp_it env sigma st =
   {st_label=st.st_label;
-   st_it=interp_it sigma env st.st_it}
+   st_it=interp_it env sigma st.st_it}
 
-let interp_constr_or_thesis check_sort sigma env = function
+let interp_constr_or_thesis check_sort env sigma = function
     Thesis n -> Thesis n
-  | This c -> This (interp_constr check_sort sigma env c)
+  | This c -> This (interp_constr check_sort env sigma c)
 
 let abstract_one_hyp inject h glob =
   match h with
       Hvar (loc,(id,None)) ->
-	GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)
+	GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)
     | Hvar (loc,(id,Some typ)) ->
-	GProd (dummy_loc,Name id, Explicit, fst typ, glob)
+	GProd (Loc.ghost,Name id, Explicit, fst typ, glob)
     | Hprop st ->
-	GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob)
+	GProd (Loc.ghost,st.st_label, Explicit, inject st.st_it, glob)
 
 let glob_constr_of_hyps inject hyps head =
   List.fold_right (abstract_one_hyp inject) hyps head
 
-let glob_prop = GSort (dummy_loc,GProp Null)
+let glob_prop = GSort (Loc.ghost,GProp)
 
 let rec match_hyps blend names constr = function
     [] -> [],substl names constr
@@ -210,13 +212,13 @@ let rec match_hyps blend names constr = function
       let rhyps,head = match_hyps blend qnames body q in
 	qhyp::rhyps,head
 
-let interp_hyps_gen inject blend sigma env hyps head =
-  let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in
+let interp_hyps_gen inject blend env sigma hyps head =
+  let constr= fst(*FIXME*) (understand env sigma (glob_constr_of_hyps inject hyps head)) in
     match_hyps blend [] constr hyps
 
-let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop)
+let interp_hyps env sigma hyps = fst (interp_hyps_gen fst (fun x _ -> x) env sigma hyps glob_prop)
 
-let dummy_prefix= id_of_string "__"
+let dummy_prefix= Id.of_string "__"
 
 let rec deanonymize ids =
   function
@@ -234,34 +236,34 @@ let rec deanonymize ids =
 
 let rec glob_of_pat =
   function
-      PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
+      PatVar (loc,Anonymous) -> anomaly (Pp.str "Anonymous pattern variable")
     | PatVar (loc,Name id) ->
 	  GVar (loc,id)
     | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
 	let mind= fst (Global.lookup_inductive ind) in
 	let rec add_params n q =
 	  if n<=0 then q else
-	    add_params (pred n) (GHole(dummy_loc,
-				       Evd.TomatchTypeParameter(ind,n))::q) in
+	    add_params (pred n) (GHole(Loc.ghost,
+				       Evar_kinds.TomatchTypeParameter(ind,n), Misctypes.IntroAnonymous, None)::q) in
 	    let args = List.map glob_of_pat lpat in
-	      glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr),
+	      glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None),
 		   add_params mind.Declarations.mind_nparams args)
 
 let prod_one_hyp = function
     (loc,(id,None)) ->
       (fun glob ->
-	 GProd (dummy_loc,Name id, Explicit,
-		GHole (loc,Evd.BinderType (Name id)), glob))
+	 GProd (Loc.ghost,Name id, Explicit,
+		GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob))
   | (loc,(id,Some typ)) ->
       (fun glob ->
-	 GProd (dummy_loc,Name id, Explicit, fst typ, glob))
+	 GProd (Loc.ghost,Name id, Explicit, fst typ, glob))
 
 let prod_one_id (loc,id) glob =
-  GProd (dummy_loc,Name id, Explicit,
-	 GHole (loc,Evd.BinderType (Name id)), glob)
+  GProd (Loc.ghost,Name id, Explicit,
+	 GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)
 
 let let_in_one_alias (id,pat) glob =
-  GLetIn (dummy_loc,Name id, glob_of_pat pat, glob)
+  GLetIn (Loc.ghost,Name id, glob_of_pat pat, glob)
 
 let rec bind_primary_aliases map pat =
   match pat with
@@ -275,7 +277,7 @@ let rec bind_primary_aliases map pat =
 	  List.fold_left bind_primary_aliases map1 lpat
 
 let bind_secondary_aliases map subst =
-  List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst
+  Id.Map.fold (fun ids idp map -> (ids,Id.List.assoc idp map)::map) subst map
 
 let bind_aliases patvars subst patt =
   let map = bind_primary_aliases [] patt in
@@ -285,10 +287,10 @@ let bind_aliases patvars subst patt =
 let interp_pattern env pat_expr =
   let patvars,pats = Constrintern.intern_pattern env pat_expr in
     match pats with
-	[] -> anomaly "empty pattern list"
+	[] -> anomaly (Pp.str "empty pattern list")
       | [subst,patt] ->
 	  (patvars,bind_aliases patvars subst patt,patt)
-      | _  -> anomaly "undetected disjunctive pattern"
+      | _  -> anomaly (Pp.str "undetected disjunctive pattern")
 
 let rec match_args dest names constr = function
     [] -> [],names,substl names constr
@@ -314,9 +316,9 @@ let rec match_aliases names constr = function
       let args,bnames,body = match_aliases qnames body q in
 	st::args,bnames,body
 
-let detype_ground c = Detyping.detype false [] [] c
+let detype_ground env c = Detyping.detype false [] env Evd.empty c
 
-let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
+let interp_cases info env sigma params (pat:cases_pattern_expr) hyps =
   let et,pinfo =
     match info.pm_stack with
 	Per(et,pi,_,_)::_ -> et,pi
@@ -325,31 +327,31 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
   let num_params = pinfo.per_nparams in
   let _ =
     let expected = mib.Declarations.mind_nparams - num_params in
-      if List.length params <> expected then
+      if not (Int.equal (List.length params) expected) then
 	errorlabstrm "suppose it is" 
 	  (str "Wrong number of extra arguments: " ++ 
-	     (if expected = 0 then str "none" else int expected) ++ spc () ++
+	     (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++
 	     str "expected.") in
   let app_ind =
-    let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
-    let rparams = List.map detype_ground pinfo.per_params in
+    let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in
+    let rparams = List.map (detype_ground env) pinfo.per_params in
     let rparams_rec =
       List.map
 	(fun (loc,(id,_)) ->
 	   GVar (loc,id)) params in
     let dum_args=
-      list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
-	oib.Declarations.mind_nrealargs in
-      glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
+      List.init oib.Declarations.mind_nrealargs
+	(fun _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark (Evar_kinds.Define false),Misctypes.IntroAnonymous, None)) in
+      glob_app(Loc.ghost,rind,rparams@rparams_rec@dum_args) in
   let pat_vars,aliases,patt = interp_pattern env pat in
   let inject = function
-      Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null)
+      Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp)
     | Thesis (For rec_occ) ->
-	if not (List.mem rec_occ pat_vars) then
+	if not (Id.List.mem rec_occ pat_vars) then
 	  errorlabstrm "suppose it is"
 	    (str "Variable " ++ Nameops.pr_id rec_occ ++
 	       str " does not occur in pattern.");
-	Glob_term.GSort(dummy_loc,GProp Null)
+	Glob_term.GSort(Loc.ghost,GProp)
     | This (c,_) -> c in
   let term1 = glob_constr_of_hyps inject hyps glob_prop in
   let loc_ids,npatt =
@@ -357,13 +359,13 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
     let npatt= deanonymize rids patt in
       List.rev (fst !rids),npatt in
   let term2 =
-    GLetIn(dummy_loc,Anonymous,
-	   GCast(dummy_loc,glob_of_pat npatt,
-		 CastConv (DEFAULTcast,app_ind)),term1) in
+    GLetIn(Loc.ghost,Anonymous,
+	   GCast(Loc.ghost,glob_of_pat npatt,
+		 CastConv app_ind),term1) in
   let term3=List.fold_right let_in_one_alias aliases term2 in
   let term4=List.fold_right prod_one_id loc_ids term3 in
   let term5=List.fold_right prod_one_hyp params term4 in
-  let constr = understand  sigma env term5 in
+  let constr = fst (understand env sigma term5)(*FIXME*) in
   let tparams,nam4,rest4 = match_args destProd [] constr params in
   let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in
   let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in
@@ -380,22 +382,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
 	     pat_pat=patt;
 	     pat_expr=pat},thyps
 
-let interp_cut interp_it sigma env cut=
-  let nenv,nstat = interp_it sigma env cut.cut_stat in
+let interp_cut interp_it env sigma cut=
+  let nenv,nstat = interp_it env sigma cut.cut_stat in
     {cut with
        cut_stat=nstat;
-       cut_by=interp_justification_items sigma nenv cut.cut_by}
+       cut_by=interp_justification_items nenv sigma cut.cut_by}
 
-let interp_no_bind interp_it sigma env x =
-  env,interp_it sigma env x
+let interp_no_bind interp_it env sigma x =
+  env,interp_it env sigma x
 
-let interp_suffices_clause sigma env (hyps,cot)=
+let interp_suffices_clause env sigma (hyps,cot)=
   let (locvars,_) as res =
     match cot with
 	This (c,_) ->
-	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
+	  let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) env sigma hyps c in
 	  nhyps,This nc
-      | Thesis Plain as th  -> interp_hyps sigma env hyps,th
+      | Thesis Plain as th  -> interp_hyps env sigma hyps,th
       | Thesis (For n) -> error "\"thesis for\" is not applicable here." in
   let push_one hyp env0 =
     match hyp with
@@ -406,66 +408,66 @@ let interp_suffices_clause sigma env (hyps,cot)=
   let nenv = List.fold_right push_one locvars env in
     nenv,res
 
-let interp_casee sigma env = function
-    Real c -> Real (understand sigma env (fst c))
-  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut)
+let interp_casee env sigma = function
+    Real c -> Real (fst (understand env sigma (fst c)))(*FIXME*)
+  | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) env sigma cut)
 
 let abstract_one_arg = function
     (loc,(id,None)) ->
       (fun glob ->
-	 GLambda (dummy_loc,Name id, Explicit,
-		GHole (loc,Evd.BinderType (Name id)), glob))
+	 GLambda (Loc.ghost,Name id, Explicit,
+		GHole (loc,Evar_kinds.BinderType (Name id),Misctypes.IntroAnonymous,None), glob))
   | (loc,(id,Some typ)) ->
       (fun glob ->
-	 GLambda (dummy_loc,Name id, Explicit, fst typ, glob))
+	 GLambda (Loc.ghost,Name id, Explicit, fst typ, glob))
 
 let glob_constr_of_fun args body =
   List.fold_right abstract_one_arg args (fst body)
 
-let interp_fun sigma env args body =
-  let constr=understand sigma env (glob_constr_of_fun args body) in
+let interp_fun env sigma args body =
+  let constr=fst (*FIXME*) (understand env sigma (glob_constr_of_fun args body)) in
     match_args destLambda [] constr args
 
-let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function
-    Pthus i -> Pthus (interp_bare_proof_instr info sigma env i)
-  | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i)
-  | Phence i -> Phence (interp_bare_proof_instr info sigma env i)
+let rec interp_bare_proof_instr info env sigma = function
+    Pthus i -> Pthus (interp_bare_proof_instr info env sigma i)
+  | Pthen i -> Pthen (interp_bare_proof_instr info env sigma i)
+  | Phence i -> Phence (interp_bare_proof_instr info env sigma i)
   | Pcut c -> Pcut (interp_cut
 		      (interp_no_bind (interp_statement
 					 (interp_constr_or_thesis true)))
-		      sigma env c)
+		      env sigma c)
   | Psuffices c ->
-      Psuffices (interp_cut interp_suffices_clause sigma env c)
+      Psuffices (interp_cut interp_suffices_clause env sigma c)
   | Prew (s,c) -> Prew (s,interp_cut
 			  (interp_no_bind (interp_statement
 			     (interp_constr_in_type (get_eq_typ info env))))
-			  sigma env c)
+			  env sigma c)
 
-  | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
+  | Psuppose hyps -> Psuppose (interp_hyps env sigma hyps)
   | Pcase (params,pat,hyps) ->
-      let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in
+      let tparams,tpat,thyps = interp_cases info env sigma params pat hyps in
 	Pcase (tparams,tpat,thyps)
   | Ptake witl ->
-      Ptake (List.map (fun c -> understand sigma env (fst c)) witl)
-  | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c,
-				     interp_hyps sigma env hyps)
-  | Pper (et,c) -> Pper (et,interp_casee sigma env c)
+      Ptake (List.map (fun c -> fst (*FIXME*) (understand env sigma (fst c))) witl)
+  | Pconsider (c,hyps) -> Pconsider (interp_constr false env sigma c,
+				     interp_hyps env sigma hyps)
+  | Pper (et,c) -> Pper (et,interp_casee env sigma c)
   | Pend bt -> Pend bt
   | Pescape -> Pescape
-  | Passume hyps -> Passume (interp_hyps sigma env hyps)
-  | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps)
-  | Plet hyps -> Plet (interp_hyps sigma env hyps)
-  | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st)
-  | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st)
+  | Passume hyps -> Passume (interp_hyps env sigma hyps)
+  | Pgiven hyps -> Pgiven (interp_hyps env sigma hyps)
+  | Plet hyps -> Plet (interp_hyps env sigma hyps)
+  | Pclaim st -> Pclaim (interp_statement (interp_constr true) env sigma st)
+  | Pfocus st -> Pfocus (interp_statement (interp_constr true) env sigma st)
   | Pdefine (id,args,body) ->
-      let nargs,_,nbody = interp_fun sigma env args body in
+      let nargs,_,nbody = interp_fun env sigma args body in
 	Pdefine (id,nargs,nbody)
   | Pcast (id,typ) ->
-      Pcast(id,interp_constr true sigma env typ)
+      Pcast(id,interp_constr true env sigma typ)
 
-let rec interp_proof_instr info sigma env instr=
+let interp_proof_instr info env sigma instr=
   {emph = instr.emph;
-   instr = interp_bare_proof_instr info sigma env instr.instr}
+   instr = interp_bare_proof_instr info env sigma instr.instr}
 
 
 
diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli
index f7227946..b3d6f82b 100644
--- a/plugins/decl_mode/decl_interp.mli
+++ b/plugins/decl_mode/decl_interp.mli
@@ -1,16 +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 Tacinterp
+open Tacintern
 open Decl_expr
-open Mod_subst
 
 
 val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr
 val interp_proof_instr : Decl_mode.pm_info ->
-  Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr
+  Environ.env -> Evd.evar_map -> glob_proof_instr -> proof_instr
diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
index 55742386..d169dc13 100644
--- a/plugins/decl_mode/decl_mode.ml
+++ b/plugins/decl_mode/decl_mode.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        *)
@@ -9,9 +9,9 @@
 open Names
 open Term
 open Evd
+open Errors
 open Util
 
-
 let daimon_flag = ref false
 
 let set_daimon_flag () = daimon_flag:=true
@@ -20,15 +20,13 @@ let get_daimon_flag () = !daimon_flag
 
 
 
-(* Information associated to goals. *)
-open Store.Field
 
 type split_tree=
-    Skip_patt of Idset.t * split_tree
-  | Split_patt of Idset.t * inductive *
-		(bool array * (Idset.t * split_tree) option) array
+    Skip_patt of Id.Set.t * split_tree
+  | Split_patt of Id.Set.t * inductive *
+		(bool array * (Id.Set.t * split_tree) option) array
   | Close_patt of split_tree
-  | End_patt of (identifier * (int * int))
+  | End_patt of (Id.t * (int * int))
 
 type elim_kind =
     EK_dep of split_tree
@@ -48,7 +46,7 @@ type per_info =
      per_wf:recpath}
 
 type stack_info =
-    Per of Decl_expr.elim_type * per_info * elim_kind * identifier list
+    Per of Decl_expr.elim_type * per_info * elim_kind * Id.t list
   | Suppose_case
   | Claim
   | Focus_claim
@@ -69,27 +67,27 @@ let mode_of_pftreestate pts =
   (* spiwack: it used to be "top_goal_..." but this should be fine *)
   let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
   let goal = List.hd goals in
-    if info.get (Goal.V82.extra sigma goal) = None then
-      Mode_tactic 
-    else
-      Mode_proof
+  match Store.get (Goal.V82.extra sigma goal) info with
+  | None -> Mode_tactic 
+  | Some _ -> Mode_proof
 	  
 let get_current_mode () =
-  try
+  try 
     mode_of_pftreestate (Pfedit.get_pftreestate ())
-  with e when Errors.noncritical e -> Mode_none
+  with Proof_global.NoCurrentProof -> Mode_none
 
 let check_not_proof_mode str =
- if get_current_mode () = Mode_proof then
-   error str
+ match get_current_mode () with
+ | Mode_proof -> error str
+ | _ -> ()
 
 let get_info sigma gl=
-  match info.get (Goal.V82.extra sigma gl) with
+  match Store.get (Goal.V82.extra sigma gl) info with
   | None ->  invalid_arg "get_info"
   | Some pm -> pm
 
 let try_get_info sigma gl =
-  info.get (Goal.V82.extra sigma gl)
+  Store.get (Goal.V82.extra sigma gl) info
 
 let get_stack pts =
   let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
@@ -102,11 +100,13 @@ let proof_cond = Proof.no_cond proof_focus
 
 let focus p =
   let inf = get_stack p in
-  Proof.focus proof_cond inf 1 p
+  Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1)
 
-let unfocus = Proof.unfocus proof_focus
+let unfocus () =
+  Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ())
 
-let maximal_unfocus = Proof_global.maximal_unfocus proof_focus
+let maximal_unfocus () = 
+  Proof_global.simple_with_current_proof (fun _ -> Proof.maximal_unfocus proof_focus)
 
 let get_top_stack pts =
   try
@@ -116,8 +116,7 @@ let get_top_stack pts =
     let info = get_info sigma gl in
     info.pm_stack
 
-let get_last env =
-  try
-    let (id,_,_) =  List.hd (Environ.named_context env) in id
-  with Invalid_argument _ -> error "no previous statement to use"
+let get_last env = match Environ.named_context env with
+  | (id,_,_)::_ -> id
+  | [] -> error "no previous statement to use"
 
diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli
index b36f2333..2864ba18 100644
--- a/plugins/decl_mode/decl_mode.mli
+++ b/plugins/decl_mode/decl_mode.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        *)
@@ -9,7 +9,6 @@
 open Names
 open Term
 open Evd
-open Tacmach
 
 val set_daimon_flag : unit -> unit
 val clear_daimon_flag : unit -> unit
@@ -27,11 +26,11 @@ val get_current_mode : unit -> command_mode
 val check_not_proof_mode : string -> unit
 
 type split_tree=
-    Skip_patt of Idset.t * split_tree
-  | Split_patt of Idset.t * inductive *
-		(bool array * (Idset.t * split_tree) option) array
+    Skip_patt of Id.Set.t * split_tree
+  | Split_patt of Id.Set.t * inductive *
+		(bool array * (Id.Set.t * split_tree) option) array
   | Close_patt of split_tree
-  | End_patt of (identifier * (int * int))
+  | End_patt of (Id.t * (int * int))
 
 type elim_kind =
     EK_dep of split_tree
@@ -51,7 +50,7 @@ type per_info =
      per_wf:recpath}
 
 type stack_info =
-    Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list
+    Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list
   | Suppose_case
   | Claim
   | Focus_claim
@@ -59,7 +58,7 @@ type stack_info =
 type pm_info =
     {pm_stack : stack_info list }
 
-val info : pm_info Store.Field.t
+val info : pm_info Store.field
 
 val get_info : Evd.evar_map -> Proof_type.goal -> pm_info
 
@@ -69,10 +68,12 @@ val get_stack : Proof.proof -> stack_info list
 
 val get_top_stack : Proof.proof -> stack_info list
 
-val get_last:  Environ.env -> identifier
+val get_last:  Environ.env -> Id.t
+(** [get_last] raises a [UserError] when it cannot find a previous
+    statement in the environment. *)
 
 val focus : Proof.proof -> unit
 
-val unfocus : Proof.proof -> unit
+val unfocus : unit -> unit
 
-val maximal_unfocus : Proof.proof -> unit
+val maximal_unfocus : unit -> unit
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index e69f2bb6..9d25681d 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -1,34 +1,34 @@
 (************************************************************************)
 (*  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 Pp
 open Evd
 
-open Refiner
-open Proof_type
 open Tacmach
-open Tacinterp
+open Tacintern
 open Decl_expr
 open Decl_mode
 open Decl_interp
 open Glob_term
+open Glob_ops
 open Names
 open Nameops
 open Declarations
 open Tactics
 open Tacticals
 open Term
+open Vars
 open Termops
 open Namegen
-open Reductionops
 open Goptions
-
+open Misctypes
 
 (* Strictness option *)
 
@@ -49,20 +49,21 @@ let _ =
 
 let tcl_change_info_gen info_gen =
   (fun gls ->
+     let it = sig_it gls in
      let concl = pf_concl gls in
-     let hyps = Goal.V82.hyps (project gls) (sig_it gls) in
-     let extra = Goal.V82.extra (project gls) (sig_it gls) in
+     let hyps = Goal.V82.hyps (project gls) it in
+     let extra = Goal.V82.extra (project gls) it in
      let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in
-     let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in
-     { it = [gl] ; sigma= sigma } )
-
-open Store.Field
+     let sigma = Goal.V82.partial_solution sigma it ev in
+     { it = [gl] ; sigma= sigma; } )
 
-let tcl_change_info info gls =  
-  let info_gen = Decl_mode.info.set info in
+let tcl_change_info info gls =
+  let info_gen s = Store.set s Decl_mode.info info in
   tcl_change_info_gen info_gen gls
 
-let tcl_erase_info gls =  tcl_change_info_gen (Decl_mode.info.remove) gls
+let tcl_erase_info gls =
+  let info_gen s = Store.remove s Decl_mode.info in
+  tcl_change_info_gen info_gen gls
 
 let special_whd gl=
   let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
@@ -74,7 +75,7 @@ let special_nf gl=
 
 let is_good_inductive env ind =
   let mib,oib = Inductive.lookup_mind_specif env ind in
-    oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
+    Int.equal oib.mind_nrealargs 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
 
 let check_not_per pts =
   if not (Proof.is_done pts) then
@@ -90,7 +91,7 @@ let mk_evd metalist gls =
     meta_declare meta typ evd in
     List.fold_right add_one metalist evd0
 
-let is_tmp id = (string_of_id id).[0] = '_'
+let is_tmp id = (Id.to_string id).[0] == '_'
 
 let tmp_ids gls =
   let ctx = pf_hyps gls in
@@ -108,7 +109,7 @@ let clean_tmp gls =
     clean_all (tmp_ids gls) gls
 
 let assert_postpone id t =
-  assert_tac (Name id) t
+  assert_before (Name id) t
 
 (* start a proof *)
 
@@ -118,7 +119,7 @@ let start_proof_tac gls=
   tcl_change_info info gls
 
 let go_to_proof_mode () =
-  Pfedit.by start_proof_tac;
+  ignore (Pfedit.by (Proofview.V82.tactic start_proof_tac));
   let p = Proof_global.give_me_the_proof () in
   Decl_mode.focus p
 
@@ -126,50 +127,34 @@ let go_to_proof_mode () =
 
 let daimon_tac gls =
   set_daimon_flag ();
-  {it=[];sigma=sig_sig gls}
-
-
-(* marking closed blocks *)
-
-let rec is_focussing_instr = function
-    Pthus i | Pthen i | Phence i -> is_focussing_instr i
-  | Pescape | Pper _ | Pclaim _ | Pfocus _
-  | Psuppose _ | Pcase (_,_,_)  -> true
-  | _ -> false
-
-let mark_rule_as_done = function
-    Decl_proof true -> Decl_proof false
-  | Decl_proof false ->
-      anomaly "already marked as done"
-  | _ -> anomaly "mark_rule_as_done"
-
+  {it=[];sigma=sig_sig gls;}
 
 (* post-instruction focus management *)
 
 (* spiwack: This used to fail if there was no focusing command
    above, but I don't think it ever happened. I hope it doesn't mess
    things up*)
-let goto_current_focus pts = 
-  Decl_mode.maximal_unfocus pts
+let goto_current_focus () = 
+  Decl_mode.maximal_unfocus ()
 
-let goto_current_focus_or_top pts =
-  goto_current_focus pts
+let goto_current_focus_or_top () =
+  goto_current_focus ()
 
 (* return *)
 
-let close_tactic_mode pts =
-  try goto_current_focus pts
+let close_tactic_mode () =
+  try goto_current_focus ()
   with Not_found ->
     error "\"return\" cannot be used outside of Declarative Proof Mode."
 
 let return_from_tactic_mode () =
-  close_tactic_mode (Proof_global.give_me_the_proof ())
+  close_tactic_mode ()
 
 (* end proof/claim *)
 
 let close_block bt pts =
     if Proof.no_focused_goal pts then
-      goto_current_focus pts
+      goto_current_focus ()
     else
       let stack =
 	if Proof.is_done pts then
@@ -179,7 +164,7 @@ let close_block bt pts =
       in
       match bt,stack with
 	B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
-	  (goto_current_focus pts)
+	  (goto_current_focus ())
       | _, Claim::_ ->
 	  error "\"end claim\" expected."
       | _, Focus_claim::_ ->
@@ -192,7 +177,7 @@ let close_block bt pts =
 		ET_Case_analysis -> error "\"end cases\" expected."
 	      | ET_Induction ->  error "\"end induction\" expected."
 	  end
-      | _,_ -> anomaly "Lonely suppose on stack."
+      | _,_ -> anomaly (Pp.str "Lonely suppose on stack.")
 
 
 (* utility for suppose / suppose it is *)
@@ -202,15 +187,15 @@ let close_previous_case pts =
     Proof.is_done pts
   then
     match get_top_stack pts with
-	Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
+	Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occured ...")
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus (pts)
+	  goto_current_focus ()
       | _ -> error "Not inside a proof per cases or induction."
   else
     match get_stack pts with
 	Per (et,_,_,_) :: _ -> ()
       | Suppose_case :: Per (et,_,_,_) :: _ ->
-	  goto_current_focus ((pts))
+	  goto_current_focus ()
       | _ -> error "Not inside a proof per cases or induction."
 
 (* Proof instructions *)
@@ -225,38 +210,38 @@ let filter_hyps f gls =
       tclTRY (clear [id])  in
     tclMAP filter_aux (pf_hyps gls) gls
 
-let local_hyp_prefix = id_of_string "___"
+let local_hyp_prefix = Id.of_string "___"
 
 let add_justification_hyps keep items gls =
   let add_aux c gls=
     match kind_of_term c with
 	Var id ->
-	  keep:=Idset.add id !keep;
+	  keep:=Id.Set.add id !keep;
 	  tclIDTAC gls
       | _ ->
 	  let id=pf_get_new_id local_hyp_prefix gls in
-	    keep:=Idset.add id !keep;
-	    tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
-              (thin_body [id]) gls in
+	    keep:=Id.Set.add id !keep;
+	    tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere))
+              (Proofview.V82.of_tactic (clear_body [id])) gls in
     tclMAP add_aux items gls
 
 let prepare_goal items gls =
-  let tokeep = ref Idset.empty in
+  let tokeep = ref Id.Set.empty in
   let auxres = add_justification_hyps tokeep items gls in
    tclTHENLIST
      [ (fun _ -> auxres);
-       filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls
+       filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls
 
 let my_automation_tac = ref
-  (fun gls -> anomaly "No automation registered")
+  (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered")))
 
 let register_automation_tac tac = my_automation_tac:= tac
 
-let automation_tac gls = !my_automation_tac gls
+let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac)
 
 let justification tac gls=
     tclORELSE
-      (tclSOLVE [tclTHEN tac assumption])
+      (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)])
       (fun gls ->
 	 if get_strictness () then
 	   error "Insufficient justification."
@@ -267,7 +252,7 @@ let justification tac gls=
 	   end) gls
 
 let default_justification elems gls=
-  justification (tclTHEN (prepare_goal elems) automation_tac) gls
+  justification (tclTHEN (prepare_goal elems) (Proofview.V82.of_tactic automation_tac)) gls
 
 (* code for conclusion refining *)
 
@@ -302,21 +287,21 @@ type stackd_elt =
 
 let rec replace_in_list m l = function
     [] -> raise Not_found
-  | c::q -> if m=fst c then l@q else c::replace_in_list m l q
+  | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q
 
 let enstack_subsubgoals env se stack gls=
   let hd,params = decompose_app (special_whd gls se.se_type) in
     match kind_of_term hd with
-	Ind ind when is_good_inductive env ind ->
+	Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *)
 	  let mib,oib=
 	    Inductive.lookup_mind_specif env ind in
           let gentypes=
-            Inductive.arities_of_constructors ind (mib,oib) in
+            Inductive.arities_of_constructors indu (mib,oib) in
 	  let process i gentyp =
-	    let constructor = mkConstruct(ind,succ i)
+	    let constructor = mkConstructU ((ind,succ i),u)
 	      (* constructors numbering*) in
 	    let appterm = applist (constructor,params) in
-	    let apptype = Term.prod_applist gentyp params in
+	    let apptype = prod_applist gentyp params in
 	    let rc,_ = Reduction.dest_prod env apptype in
 	    let rec meta_aux last lenv = function
 		[] -> (last,lenv,[])
@@ -352,7 +337,7 @@ let rec nf_list evd =
 	if meta_defined evd m then
 	    nf_list evd others
 	else
-	  (m,nf_meta evd typ)::nf_list evd others
+	  (m,Reductionops.nf_meta evd typ)::nf_list evd others
 
 let find_subsubgoal c ctyp skip submetas gls =
   let env= pf_env gls in
@@ -372,7 +357,7 @@ let find_subsubgoal c ctyp skip submetas gls =
       try
 	let unifier =
 	  Unification.w_unify env se.se_evd Reduction.CUMUL
-	    ~flags:Unification.elim_flags ctyp se.se_type in
+	    ~flags:(Unification.elim_flags ()) ctyp se.se_type in
 	  if n <= 0 then
 	      {se with
 		 se_evd=meta_assign se.se_meta
@@ -387,23 +372,23 @@ let find_subsubgoal c ctyp skip submetas gls =
 	  dfs n
 	end in
   let nse= try dfs skip with Stack.Empty -> raise Not_found in
-    nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0)
+    nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0)
 
 let concl_refiner metas body gls =
   let concl = pf_concl gls in
   let evd = sig_sig gls in
   let env = pf_env gls in
-  let sort = family_of_sort (Typing.sort_of env evd concl) in
+  let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in
   let rec aux env avoid subst = function
-      [] -> anomaly "concl_refiner: cannot happen"
+      [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen")
     | (n,typ)::rest ->
 	let _A = subst_meta subst typ in
 	let x = id_of_name_using_hdchar env _A Anonymous in
 	let _x = fresh_id avoid x gls in
 	let nenv = Environ.push_named (_x,None,_A) env in
-	let asort = family_of_sort (Typing.sort_of nenv evd _A) in
+	let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in
 	let nsubst = (n,mkVar _x)::subst in
-	  if rest = [] then
+	  if List.is_empty rest then
 	    asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
 	  else
 	    let bsort,_B,nbody =
@@ -451,8 +436,8 @@ let thus_tac c ctyp submetas gls =
       find_subsubgoal c ctyp 0 submetas gls
     with Not_found ->
       error "I could not relate this statement to the thesis." in
-  if list = [] then
-    exact_check proof gls
+  if List.is_empty list then
+    Proofview.V82.of_tactic (exact_check proof) gls
   else
     let refiner = concl_refiner list proof gls in
       Tactics.refine refiner gls
@@ -465,12 +450,13 @@ let mk_stat_or_thesis info gls = function
       error "\"thesis for ...\" is not applicable here."
   | Thesis Plain -> pf_concl gls
 
-let just_tac _then cut info gls0 = 
-  let last_item = if _then then 
-      let last_id = try get_last (pf_env gls0) with Failure _ -> 
-		error "\"then\" and \"hence\" require at least one previous fact"  in
-		[mkVar last_id]
-	    else []  
+let just_tac _then cut info gls0 =
+  let last_item =
+    if _then then
+      try [mkVar (get_last (pf_env gls0))]
+      with UserError _ ->
+	error "\"then\" and \"hence\" require at least one previous fact"
+    else []
   in
   let items_tac gls = 
     match cut.cut_by with
@@ -479,9 +465,9 @@ let just_tac _then cut info gls0 =
   let method_tac gls =
     match cut.cut_using with
         None ->
-	  automation_tac gls
+	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
     justification (tclTHEN items_tac method_tac) gls0
 
 let instr_cut mkstat _thus _then cut gls0 =
@@ -489,28 +475,27 @@ let instr_cut mkstat _thus _then cut gls0 =
   let stat = cut.cut_stat in
   let (c_id,_) = match stat.st_label with
       Anonymous ->
-	pf_get_new_id (id_of_string "_fact") gls0,false
+	pf_get_new_id (Id.of_string "_fact") gls0,false
     | Name id -> id,true in
   let c_stat = mkstat info gls0 stat.st_it in
   let thus_tac gls=
     if _thus then
       thus_tac (mkVar c_id) c_stat [] gls
     else tclIDTAC gls in
-    tclTHENS (assert_postpone c_id c_stat)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat))
       [tclTHEN tcl_erase_info (just_tac _then cut info);
        thus_tac] gls0
 
 
-
 (* iterated equality *)
-let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
+let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
 
 let decompose_eq id gls =
   let typ = pf_get_hyp_typ gls id in
   let whd =  (special_whd gls typ) in
     match kind_of_term whd with
 	App (f,args)->
-	  if eq_constr f _eq && (Array.length args)=3
+	  if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3
 	  then (args.(0),
 		args.(1),
 		args.(2))
@@ -520,8 +505,7 @@ let decompose_eq id gls =
 let instr_rew _thus rew_side cut gls0 =
   let last_id =
     try get_last (pf_env gls0)
-    with e when Errors.noncritical e ->
-      error "No previous equality."
+    with UserError _ -> error "No previous equality."
   in
   let typ,lhs,rhs = decompose_eq last_id gls0 in
   let items_tac gls =
@@ -531,14 +515,14 @@ let instr_rew _thus rew_side cut gls0 =
   let method_tac gls =
     match cut.cut_using with
         None ->
-	  automation_tac gls
+	  Proofview.V82.of_tactic automation_tac gls
       | Some tac ->
-	  (Tacinterp.eval_tactic tac) gls in
+	  Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
   let just_tac gls =
     justification (tclTHEN items_tac method_tac) gls in
   let (c_id,_) = match cut.cut_stat.st_label with
       Anonymous ->
-	pf_get_new_id (id_of_string "_eq") gls0,false
+	pf_get_new_id (Id.of_string "_eq") gls0,false
     | Name id -> id,true in
   let thus_tac new_eq gls=
     if _thus then
@@ -546,28 +530,27 @@ let instr_rew _thus rew_side cut gls0 =
     else tclIDTAC gls in
     match rew_side with
 	Lhs ->
-	  let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
+	  let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in
+	    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq))
 	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity lhs)
-		    [just_tac;exact_check (mkVar last_id)]);
+		 (tclTHENS (Proofview.V82.of_tactic (transitivity lhs))
+		    [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]);
 	       thus_tac new_eq] gls0
       | Rhs ->
-	  let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
-	    tclTHENS (assert_postpone c_id new_eq)
+	  let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in
+	    tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq))
 	      [tclTHEN tcl_erase_info
-		 (tclTHENS (transitivity rhs)
-		    [exact_check (mkVar last_id);just_tac]);
+		 (tclTHENS (Proofview.V82.of_tactic (transitivity rhs))
+		    [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]);
 	       thus_tac new_eq] gls0
 
 
-
 (* tactics for claim/focus *)
 
 let instr_claim _thus st gls0 =
   let info = get_its_info gls0 in
   let (id,_) = match st.st_label with
-      Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false
+      Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false
     | Name id -> id,true in
   let thus_tac gls=
     if _thus then
@@ -575,7 +558,7 @@ let instr_claim _thus st gls0 =
     else tclIDTAC gls in
   let ninfo1 = {pm_stack=
       (if _thus then Focus_claim else Claim)::info.pm_stack} in
-    tclTHENS (assert_postpone id st.st_it)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id st.st_it))
       [thus_tac;
        tcl_change_info ninfo1] gls0
 
@@ -584,10 +567,10 @@ let instr_claim _thus st gls0 =
 let push_intro_tac coerce nam gls =
       let (hid,_) =
 	match nam with
-	    Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false
+	    Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false
 	  | Name id -> id,true in
 	tclTHENLIST
-	  [intro_mustbe_force hid;
+	  [Proofview.V82.of_tactic (intro_mustbe_force hid);
 	   coerce hid]
 	  gls
 
@@ -597,7 +580,7 @@ let assume_tac hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       convert_hyp (id,None,st.st_it)) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_hyps_or_theses hyps gls =
@@ -607,7 +590,7 @@ let assume_hyps_or_theses hyps gls =
 	   tclTHEN
 	     (push_intro_tac
 		(fun id ->
-		   convert_hyp (id,None,c)) nam)
+		   Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam)
        | Hprop {st_label=nam;st_it=Thesis (tk)} ->
 	   tclTHEN
 	     (push_intro_tac
@@ -619,7 +602,7 @@ let assume_st hyps gls =
     (fun st ->
        tclTHEN
 	 (push_intro_tac
-	    (fun id -> convert_hyp (id,None,st.st_it)) st.st_label))
+	    (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 let assume_st_letin hyps gls =
@@ -628,7 +611,7 @@ let assume_st_letin hyps gls =
        tclTHEN
 	 (push_intro_tac
 	    (fun id ->
-	       convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label))
+	       Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label))
 	 hyps tclIDTAC gls
 
 (* suffices *)
@@ -653,12 +636,12 @@ let rec build_applist prod = function
     [] -> [],prod
   | n::q ->
       let (_,typ,_) = destProd prod in
-      let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in
+      let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in
 	(n,typ)::ctx,head
 
 let instr_suffices _then cut gls0 =
   let info = get_its_info gls0 in
-  let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in
+  let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in
   let ctx,hd = cut.cut_stat in
   let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in
   let metas = metas_from 1 ctx in
@@ -666,7 +649,7 @@ let instr_suffices _then cut gls0 =
   let c_term = applist (mkVar c_id,List.map mkMeta metas) in
   let thus_tac gls=
     thus_tac c_term c_head c_ctx gls in
-   tclTHENS (assert_postpone c_id c_stat)
+   tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat))
      [tclTHENLIST
 	 [ assume_tac ctx;
 	   tcl_erase_info;
@@ -680,13 +663,13 @@ let conjunction_arity id gls =
   let hd,params = decompose_app (special_whd gls typ) in
   let env =pf_env gls in
     match kind_of_term hd with
-	Ind ind when is_good_inductive env ind ->
+	Ind (ind,u as indu) when is_good_inductive env ind ->
 	  let mib,oib=
 	    Inductive.lookup_mind_specif env ind in
           let gentypes=
-            Inductive.arities_of_constructors ind (mib,oib) in
-	  let _ = if Array.length gentypes <> 1 then raise Not_found in
-	  let apptype = Term.prod_applist gentypes.(0) params in
+            Inductive.arities_of_constructors indu (mib,oib) in
+	  let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in
+	  let apptype = prod_applist gentypes.(0) params in
 	  let rc,_ = Reduction.dest_prod env apptype in
 	    List.length rc
       | _ -> raise Not_found
@@ -695,9 +678,9 @@ let rec intron_then n ids ltac gls =
   if n<=0 then
     ltac ids gls
   else
-    let id = pf_get_new_id (id_of_string "_tmp") gls in
+    let id = pf_get_new_id (Id.of_string "_tmp") gls in
       tclTHEN
-	(intro_mustbe_force id)
+	(Proofview.V82.of_tactic (intro_mustbe_force id))
 	(intron_then (pred n) (id::ids) ltac) gls
 
 
@@ -710,9 +693,9 @@ let rec consider_match may_intro introduced available expected gls =
     | [],hyps ->
 	if may_intro then
 	  begin
- 	    let id = pf_get_new_id (id_of_string "_tmp") gls in
+ 	    let id = pf_get_new_id (Id.of_string "_tmp") gls in
 	      tclIFTHENELSE
-		(intro_mustbe_force id)
+		(Proofview.V82.of_tactic (intro_mustbe_force id))
 		(consider_match true [] [id] hyps)
 		(fun _ ->
 		   error "Not enough sub-hypotheses to match statements.")
@@ -722,14 +705,14 @@ let rec consider_match may_intro introduced available expected gls =
 	  error "Not enough sub-hypotheses to match statements."
 	    (* should tell which ones *)
     | id::rest_ids,(Hvar st | Hprop st)::rest ->
-	tclIFTHENELSE (convert_hyp (id,None,st.st_it))
+	tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it)))
 	  begin
 	    match st.st_label with
 		Anonymous ->
 		  consider_match may_intro ((id,false)::introduced) rest_ids rest
 	      | Name hid ->
 		  tclTHENLIST
-		    [rename_hyp [id,hid];
+		    [Proofview.V82.of_tactic (rename_hyp [id,hid]);
 		     consider_match may_intro ((hid,true)::introduced) rest_ids rest]
 	  end
 	  begin
@@ -738,7 +721,7 @@ let rec consider_match may_intro introduced available expected gls =
 		 try conjunction_arity id gls with
 		     Not_found -> error "Matching hypothesis not found." in
 		 tclTHENLIST
-		   [general_case_analysis false (mkVar id,NoBindings);
+		   [Proofview.V82.of_tactic (simplest_case (mkVar id));
 		    intron_then nhyps []
 		      (fun l -> consider_match may_intro introduced
 			 (List.rev_append l rest_ids) expected)] gls)
@@ -750,9 +733,9 @@ let consider_tac c hyps gls =
       Var id ->
 	consider_match false [] [id] hyps gls
     | _ ->
-	let id = pf_get_new_id (id_of_string "_tmp") gls in
+	let id = pf_get_new_id (Id.of_string "_tmp") gls in
 	tclTHEN
-	  (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c)
+	  (Proofview.V82.of_tactic (pose_proof (Name id) c))
  	  (consider_match false [] [id] hyps) gls
 
 
@@ -783,7 +766,7 @@ let rec build_function args body =
 
 let define_tac id args body gls =
   let t = build_function args body in
-    letin_tac None (Name id) t None Tacexpr.nowhere gls
+    Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls
 
 (* tactics for reconsider *)
 
@@ -791,11 +774,11 @@ let cast_tac id_or_thesis typ gls =
   match id_or_thesis with
       This id ->
 	let (_,body,_) = pf_get_hyp gls id in
-	  convert_hyp (id,body,typ) gls
+	  Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls
     | Thesis (For _ ) ->
 	error "\"thesis for ...\" is not applicable here."
     | Thesis Plain ->
-          convert_concl typ DEFAULTcast gls
+          Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls
 
 (* per cases *)
 
@@ -804,7 +787,7 @@ let is_rec_pos (main_ind,wft) =
       None -> false
     | Some index ->
 	match fst (Rtree.dest_node wft) with
-	    Mrec (_,i) when i = index -> true
+	    Mrec (_,i) when Int.equal i index -> true
 	  | _ -> false
 
 let rec constr_trees (main_ind,wft) ind =
@@ -841,7 +824,7 @@ let map_tree id_fun mapi = function
 
 
 let start_tree env ind rp =
-  init_tree Idset.empty ind rp (fun _ _ -> None)
+  init_tree Id.Set.empty ind rp (fun _ _ -> None)
 
 let build_per_info etype casee gls =
   let concl=pf_concl gls in
@@ -849,17 +832,17 @@ let build_per_info etype casee gls =
   let ctyp=pf_type_of gls casee in
   let is_dep = dependent casee concl in
   let hd,args = decompose_app (special_whd gls ctyp) in
-  let ind =
+  let (ind,u) =
     try
       destInd hd
-    with e when Errors.noncritical e ->
+    with DestKO ->
       error "Case analysis must be done on an inductive object." in
   let mind,oind = Global.lookup_inductive ind in
   let nparams,index =
     match etype with
 	ET_Induction -> mind.mind_nparams_rec,Some (snd ind)
       | _ -> mind.mind_nparams,None in
-  let params,real_args = list_chop nparams args in
+  let params,real_args = List.chop nparams args in
   let abstract_obj c body =
     let typ=pf_type_of gls c in
       lambda_create env (typ,subst_term c body) in
@@ -889,8 +872,8 @@ let per_tac etype casee gls=
 	      {pm_stack=
 		  Per(etype,per_info,ek,[])::info.pm_stack} gls
       | Virtual cut ->
-	  assert (cut.cut_stat.st_label=Anonymous);
-	  let id = pf_get_new_id (id_of_string "anonymous_matched") gls in
+	  assert (cut.cut_stat.st_label == Anonymous);
+	  let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in
 	  let c = mkVar id in
 	  let modified_cut =
 	    {cut with cut_stat={cut.cut_stat with st_label=Name id}} in
@@ -914,17 +897,17 @@ let register_nodep_subcase id= function
 	  | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s
 	  | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"."
       end
-  | _ -> anomaly "wrong stack state"
+  | _ -> anomaly (Pp.str "wrong stack state")
 
 let suppose_tac hyps gls0 =
   let info = get_its_info gls0 in
   let thesis = pf_concl gls0 in
-  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
+  let id = pf_get_new_id (Id.of_string "subcase_") gls0 in
   let clause = build_product hyps thesis in
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let old_clauses,stack = register_nodep_subcase id info.pm_stack in
   let ninfo2 = {pm_stack=stack} in
-    tclTHENS (assert_postpone id clause)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause))
       [tclTHENLIST [tcl_change_info ninfo1;
 		    assume_tac hyps;
 		    clear old_clauses];
@@ -949,17 +932,17 @@ let rec tree_of_pats ((id,_) as cpl) pats =
 	  | (patt,rp) :: rest_args ->
 	      match patt with
 		  PatVar (_,v) ->
-		    Skip_patt (Idset.singleton id,
+		    Skip_patt (Id.Set.singleton id,
 			       tree_of_pats cpl (rest_args::stack))
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		    let nexti i ati =
-		      if i = pred cnum then
+		      if Int.equal i (pred cnum) then
 			let nargs =
-			  list_map_i (fun j a -> (a,ati.(j))) 0 args in
-			  Some (Idset.singleton id,
+			  List.map_i (fun j a -> (a,ati.(j))) 0 args in
+			  Some (Id.Set.singleton id,
 				tree_of_pats cpl (nargs::rest_args::stack))
 		      else None
-		      in init_tree Idset.empty ind rp nexti
+		      in init_tree Id.Set.empty ind rp nexti
 
 let rec add_branch ((id,_) as cpl) pats tree=
   match pats with
@@ -968,7 +951,7 @@ let rec add_branch ((id,_) as cpl) pats tree=
 	  match tree with
 	      End_patt cpl0 -> End_patt cpl0
 		(* this ensures precedence for overlapping patterns *)
-	    | _ -> anomaly "tree is expected to end here"
+	    | _ -> anomaly (Pp.str "tree is expected to end here")
 	end
     | args::stack ->
 	match args with
@@ -977,7 +960,7 @@ let rec add_branch ((id,_) as cpl) pats tree=
 		match tree with
 		   Close_patt t ->
 		     Close_patt (add_branch cpl stack t)
-		  | _ -> anomaly "we should pop here"
+		  | _ -> anomaly (Pp.str "we should pop here")
 	      end
 	  | (patt,rp) :: rest_args ->
 	      match patt with
@@ -985,23 +968,23 @@ let rec add_branch ((id,_) as cpl) pats tree=
 		    begin
 		      match tree with
 			  Skip_patt (ids,t) ->
-			    Skip_patt (Idset.add id ids,
+			    Skip_patt (Id.Set.add id ids,
 				       add_branch cpl (rest_args::stack) t)
 			| Split_patt (_,_,_) ->
-			    map_tree (Idset.add id)
+			    map_tree (Id.Set.add id)
 			      (fun i bri ->
 				 append_branch cpl 1 (rest_args::stack) bri)
 			      tree
-			| _ -> anomaly "No pop/stop expected here"
+			| _ -> anomaly (Pp.str "No pop/stop expected here")
 		    end
 		| PatCstr (_,(ind,cnum),args,nam) ->
 		      match tree with
 			Skip_patt (ids,t) ->
 			  let nexti i ati =
-			    if i = pred cnum then
+			    if Int.equal i (pred cnum) then
 			      let nargs =
-				list_map_i (fun j a -> (a,ati.(j))) 0 args in
-				Some (Idset.add id ids,
+				List.map_i (fun j a -> (a,ati.(j))) 0 args in
+				Some (Id.Set.add id ids,
 				      add_branch cpl (nargs::rest_args::stack)
 					(skip_args t ids (Array.length ati)))
 			    else
@@ -1009,57 +992,57 @@ let rec add_branch ((id,_) as cpl) pats tree=
 				    skip_args t ids (Array.length ati))
 			  in init_tree ids ind rp nexti
 		      | Split_patt (_,ind0,_) ->
-			  if (ind <> ind0) then error
+			  if (not (eq_ind ind ind0)) then error
 			    (* this can happen with coercions *)
 	                    "Case pattern belongs to wrong inductive type.";
 			  let mapi i ati bri =
-			    if i = pred cnum then
+			    if Int.equal i (pred cnum) then
 			      let nargs =
-				list_map_i (fun j a -> (a,ati.(j))) 0 args in
+				List.map_i (fun j a -> (a,ati.(j))) 0 args in
 				append_branch cpl 0
 				  (nargs::rest_args::stack) bri
 			    else bri in
 			    map_tree_rp rp (fun ids -> ids) mapi tree
-		      | _ -> anomaly "No pop/stop expected here"
+		      | _ -> anomaly (Pp.str "No pop/stop expected here")
 and append_branch ((id,_) as cpl) depth pats = function
     Some (ids,tree) ->
-      Some (Idset.add id ids,append_tree cpl depth pats tree)
+      Some (Id.Set.add id ids,append_tree cpl depth pats tree)
   | None ->
-      Some (Idset.singleton id,tree_of_pats cpl pats)
+      Some (Id.Set.singleton id,tree_of_pats cpl pats)
 and append_tree ((id,_) as cpl) depth pats tree =
   if depth<=0 then add_branch cpl pats tree
   else match tree with
       Close_patt t ->
 	Close_patt (append_tree cpl (pred depth) pats t)
     | Skip_patt (ids,t) ->
-	Skip_patt (Idset.add id ids,append_tree cpl depth pats t)
-    | End_patt _ -> anomaly "Premature end of branch"
+	Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t)
+    | End_patt _ -> anomaly (Pp.str "Premature end of branch")
     | Split_patt (_,_,_) ->
-	map_tree (Idset.add id)
+	map_tree (Id.Set.add id)
 	  (fun i bri -> append_branch cpl (succ depth) pats bri) tree
 
 (* suppose it is *)
 
 let rec st_assoc id = function
     [] -> raise Not_found
-  | st::_ when st.st_label = id  -> st.st_it
+  | st::_ when Name.equal st.st_label id  -> st.st_it
   | _ :: rest -> st_assoc id rest
 
 let thesis_for obj typ per_info env=
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
-  let ind = destInd cind in
-  let _ = if ind <> per_info.per_ind then
+  let ind,u = destInd cind in
+  let _ = if not (eq_ind ind per_info.per_ind) then
     errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
+      ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++
 	 str"cannot give an induction hypothesis (wrong inductive type).") in
-  let params,args = list_chop per_info.per_nparams all_args in
+  let params,args = List.chop per_info.per_nparams all_args in
   let _ = if not (List.for_all2 eq_constr params per_info.per_params) then
     errorlabstrm "thesis_for"
-      ((Printer.pr_constr_env env obj) ++ spc () ++
+      ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++
 	 str "cannot give an induction hypothesis (wrong parameters).") in
   let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in
-    compose_prod rc (whd_beta Evd.empty hd2)
+    compose_prod rc (Reductionops.whd_beta Evd.empty hd2)
 
 let rec build_product_dep pat_info per_info args body gls =
   match args with
@@ -1119,18 +1102,18 @@ let rec register_dep_subcase id env per_info pat = function
 
 let case_tac params pat_info hyps gls0 =
   let info = get_its_info gls0 in
-  let id = pf_get_new_id (id_of_string "subcase_") gls0 in
+  let id = pf_get_new_id (Id.of_string "subcase_") gls0 in
   let et,per_info,ek,old_clauses,rest =
     match info.pm_stack with
 	Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest)
-      | _ -> anomaly "wrong place for cases" in
+      | _ -> anomaly (Pp.str "wrong place for cases") in
   let clause = build_dep_clause params pat_info per_info hyps gls0 in
   let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in
   let nek = 
     register_dep_subcase (id,(List.length params,List.length hyps)) 
       (pf_env gls0) per_info pat_info.pat_pat ek in  
   let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
-    tclTHENS (assert_postpone id clause)
+    tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause))
       [tclTHENLIST
 	 [tcl_change_info ninfo1;
 	  assume_st (params@pat_info.pat_vars);
@@ -1141,14 +1124,14 @@ let case_tac params pat_info hyps gls0 =
 
 (* end cases *)
 
-type instance_stack =
-    (constr option*(constr list) list) list
+type ('a, 'b) instance_stack =
+    ('b * (('a option * constr list) list)) list
 
-let initial_instance_stack ids =
+let initial_instance_stack ids : (_, _) instance_stack =
   List.map (fun id -> id,[None,[]]) ids
 
 let push_one_arg arg = function
-    [] -> anomaly "impossible"
+    [] -> anomaly (Pp.str "impossible")
   | (head,args) :: ctx ->
       ((head,(arg::args)) :: ctx)
 
@@ -1157,7 +1140,7 @@ let push_arg arg stacks =
 
 
 let push_one_head c ids (id,stack) =
-  let head = if Idset.mem id ids then Some c else None in
+  let head = if Id.Set.mem id ids then Some c else None in
     id,(head,[]) :: stack
 
 let push_head c ids stacks =
@@ -1166,7 +1149,7 @@ let push_head c ids stacks =
 let pop_one (id,stack) =
   let nstack=
     match stack with
-	[] -> anomaly "impossible"
+	[] -> anomaly (Pp.str "impossible")
       | [c] as l -> l
       | (Some head,args)::(head0,args0)::ctx ->
 	  let arg = applist (head,(List.rev args)) in
@@ -1183,13 +1166,13 @@ let hrec_for fix_id per_info gls obj_id =
   let typ=pf_get_hyp_typ gls obj_id in
   let rc,hd1=decompose_prod typ in
   let cind,all_args=decompose_app typ in
-  let ind = destInd cind in assert (ind=per_info.per_ind);
-  let params,args= list_chop per_info.per_nparams all_args in
+  let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind);
+  let params,args= List.chop per_info.per_nparams all_args in
   assert begin
     try List.for_all2 eq_constr params per_info.per_params with
         Invalid_argument _ -> false end;
   let hd2 = applist (mkVar fix_id,args@[obj]) in
-    compose_lam rc (whd_beta gls.sigma hd2)
+    compose_lam rc (Reductionops.whd_beta gls.sigma hd2)
 
 
 let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
@@ -1202,18 +1185,18 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	  execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls
     | End_patt (id,(nparams,nhyps)),[] -> 
 	begin
-	  match List.assoc id args with
+	  match Id.List.assoc id args with
 	      [None,br_args] -> 
 		let all_metas = 
-		  list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps)  in
-		let param_metas,hyp_metas = list_chop nparams all_metas in
+		  List.init (nparams + nhyps) (fun n -> mkMeta (succ n))  in
+		let param_metas,hyp_metas = List.chop nparams all_metas in
 		  tclTHEN
-		    (tclDO nhrec introf)
+		    (tclDO nhrec (Proofview.V82.of_tactic introf))
 		    (tacnext 
 		       (applist (mkVar id,
 				 List.append param_metas 
 				   (List.rev_append br_args hyp_metas)))) gls
-	    | _ -> anomaly "wrong stack size"
+	    | _ -> anomaly (Pp.str "wrong stack size")
 	end
     | Split_patt (ids,ind,br), casee::next_objs ->
 	let (mind,oind) as spec = Global.lookup_inductive ind in
@@ -1222,18 +1205,19 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	let env=pf_env gls in
 	let ctyp=pf_type_of gls casee in
 	let hd,all_args = decompose_app (special_whd gls ctyp) in
-	let _ = assert (destInd hd = ind) in (* just in case *)
-	let params,real_args = list_chop nparams all_args in
+	let ind', u = destInd hd in
+	let _ = assert (eq_ind ind' ind) in (* just in case *)
+	let params,real_args = List.chop nparams all_args in
 	let abstract_obj c body =
 	  let typ=pf_type_of gls c in
 	    lambda_create env (typ,subst_term c body) in
 	let elim_pred = List.fold_right abstract_obj
 	  real_args (lambda_create env (ctyp,subst_term casee concl)) in
 	let case_info = Inductiveops.make_case_info env ind RegularStyle in
-	let gen_arities = Inductive.arities_of_constructors ind spec in
+	let gen_arities = Inductive.arities_of_constructors (ind,u) spec in
 	let f_ids typ =
 	  let sign =
-	    (prod_assum (Term.prod_applist typ params)) in
+	    (prod_assum (prod_applist typ params)) in
 	    find_intro_names sign gls in
 	let constr_args_ids = Array.map f_ids gen_arities in
 	let case_term =
@@ -1243,7 +1227,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	  let args_ids = constr_args_ids.(i) in
 	  let rec aux n = function
 	      [] ->
-		assert (n=Array.length recargs);
+		assert (Int.equal n (Array.length recargs));
 		next_objs,[],nhrec
 	    | id :: q ->
 		let objs,recs,nrec = aux (succ n) q in
@@ -1252,7 +1236,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 		  else (mkVar id::objs),recs,nrec in
 	  let objs,recs,nhrec = aux 0 args_ids in
 	    tclTHENLIST
-	      [tclMAP intro_mustbe_force args_ids;
+	      [tclMAP (fun id -> Proofview.V82.of_tactic (intro_mustbe_force id)) args_ids;
 	       begin
 		 fun gls1 ->
 		   let hrecs =
@@ -1269,7 +1253,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 		 | Some (sub_ids,tree) ->
 		     let br_args =
 		       List.filter
-			 (fun (id,_) -> Idset.mem id sub_ids) args in
+			 (fun (id,_) -> Id.Set.mem id sub_ids) args in
 		     let construct =
 		       applist (mkConstruct(ind,succ i),params) in
 		     let p_args =
@@ -1280,22 +1264,24 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
 	    (refine case_term)
 	    (Array.mapi branch_tac br) gls
     | Split_patt (_, _, _) , [] ->
-	anomaly "execute_cases : Nothing to split"
+	anomaly ~label:"execute_cases " (Pp.str "Nothing to split")
     | Skip_patt _ , [] ->
-	anomaly "execute_cases : Nothing to skip"
+	anomaly ~label:"execute_cases " (Pp.str "Nothing to skip")
     | End_patt (_,_) , _ :: _  ->
-	anomaly "execute_cases : End of branch with garbage left"
-
-let understand_my_constr c gls =
-  let env = pf_env gls in
-  let nc = names_of_rel_context env in
-  let rawc = Detyping.detype false [] nc c in
-  let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc ->  map_glob_constr frob rc in
-    Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc)
+	anomaly ~label:"execute_cases " (Pp.str "End of branch with garbage left")
+
+let understand_my_constr env sigma c concl =
+  let env = env in
+  let rawc = Detyping.detype false [] env Evd.empty c in
+  let rec frob = function
+    | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None)
+    | rc ->  map_glob_constr frob rc
+  in
+  Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc)
 
 let my_refine c gls =
-  let oc = understand_my_constr c gls in
-  Refine.refine oc gls
+  let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+  Proofview.V82.of_tactic (Tactics.New.refine oc) gls
 
 (* end focus/claim *)
 
@@ -1304,43 +1290,41 @@ let end_tac et2 gls =
   let et1,pi,ek,clauses =
     match info.pm_stack with
 	Suppose_case::_ ->
-	  anomaly "This case should already be trapped"
+	  anomaly (Pp.str "This case should already be trapped")
       | Claim::_ ->
 	  error "\"end claim\" expected."
       | Focus_claim::_ ->
 	  error "\"end focus\" expected."
       | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses)
       | [] ->
-	  anomaly "This case should already be trapped" in
-  let et =
-    if et1 <> et2 then
-      match et1 with
-	  ET_Case_analysis ->
-	    error "\"end cases\" expected."
-	| ET_Induction ->
-	    error "\"end induction\" expected."
-    else et1 in
+	  anomaly (Pp.str "This case should already be trapped") in
+  let et = match et1, et2 with
+  | ET_Case_analysis, ET_Case_analysis -> et1
+  | ET_Induction, ET_Induction -> et1
+  | ET_Case_analysis, _ -> error "\"end cases\" expected."
+  | ET_Induction, _ -> error "\"end induction\" expected."
+  in
     tclTHEN
       tcl_erase_info
       begin
 	match et,ek with
 	    _,EK_unknown ->
-	      tclSOLVE [simplest_elim pi.per_casee]
+	      tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)]
 	  | ET_Case_analysis,EK_nodep ->
 	      tclTHEN
-		(general_case_analysis false (pi.per_casee,NoBindings))
+		(Proofview.V82.of_tactic (simplest_case pi.per_casee))
 		(default_justification (List.map mkVar clauses))
 	  | ET_Induction,EK_nodep ->
 	      tclTHENLIST
 		[generalize (pi.per_args@[pi.per_casee]);
-		 simple_induct (AnonHyp (succ (List.length pi.per_args)));
+		 Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args))));
 		 default_justification (List.map mkVar clauses)]
 	  | ET_Case_analysis,EK_dep tree ->
 		 execute_cases Anonymous pi 
 		   (fun c -> tclTHENLIST 
 		      [my_refine c;
 		       clear clauses;
-		       justification assumption])
+		       justification (Proofview.V82.of_tactic assumption)])
 		   (initial_instance_stack clauses) [pi.per_casee] 0 tree
 	  | ET_Induction,EK_dep tree ->
 	      let nargs = (List.length pi.per_args) in
@@ -1348,20 +1332,20 @@ let end_tac et2 gls =
 		  begin
 		    fun gls0 ->
 		      let fix_id =
-			pf_get_new_id (id_of_string "_fix") gls0 in
+			pf_get_new_id (Id.of_string "_fix") gls0 in
 		      let c_id =
-			pf_get_new_id (id_of_string "_main_arg") gls0 in
+			pf_get_new_id (Id.of_string "_main_arg") gls0 in
 			tclTHENLIST
 			  [fix (Some fix_id) (succ nargs);
-			   tclDO nargs introf;
-			   intro_mustbe_force c_id;
+			   tclDO nargs (Proofview.V82.of_tactic introf);
+			   Proofview.V82.of_tactic (intro_mustbe_force c_id);
 			   execute_cases (Name fix_id) pi
 			     (fun c ->
 				tclTHENLIST
 				  [clear [fix_id];
 				   my_refine c;
 				   clear clauses;
-				   justification assumption])
+				   justification (Proofview.V82.of_tactic assumption)])
 			     (initial_instance_stack clauses)
 			     [mkVar c_id]  0 tree] gls0
 		  end
@@ -1409,7 +1393,7 @@ let rec do_proof_instr_gen _thus _then instr =
     | Psuppose hyps      -> suppose_tac hyps
     | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps
     | Pend (B_elim et) -> end_tac et
-    | Pend _ -> anomaly "Not applicable"
+    | Pend _ -> anomaly (Pp.str "Not applicable")
     | Pescape -> escape_tac
 
 let eval_instr {instr=instr} =
@@ -1454,33 +1438,33 @@ let rec postprocess pts instr =
 	  in
 	    try
 	      Inductiveops.control_only_guard env pfterm;
-	      goto_current_focus_or_top pts
+	      goto_current_focus_or_top ()
  	    with
 		Type_errors.TypeError(env,
 				      Type_errors.IllFormedRecBody(_,_,_,_,_)) ->
-		  anomaly "\"end induction\" generated an ill-formed fixpoint"
+		  anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint")
 	end
     | Pend _ ->
-	goto_current_focus_or_top (pts)
+	goto_current_focus_or_top ()
 
 let do_instr raw_instr pts =
   let has_tactic = preprocess pts raw_instr.instr in
   begin
     if has_tactic then
-      let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
-      let gl = { it=List.hd gls ; sigma=sigma } in
+            let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in
+      let gl = { it=List.hd gls ; sigma=sigma; } in
       let env=  pf_env gl in
-      let ist = {ltacvars = ([],[]); ltacrecvars = [];
-		 gsigma = sigma; genv = env} in
+      let ist = {ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = env} in
       let glob_instr = intern_proof_instr ist raw_instr in
       let instr =
-	interp_proof_instr (get_its_info gl) sigma env glob_instr in
-      Pfedit.by (tclTHEN (eval_instr instr) clean_tmp)
+	interp_proof_instr (get_its_info gl) env sigma glob_instr in
+      ignore (Pfedit.by (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp)))
     else () end;
   postprocess pts raw_instr.instr;
   (* spiwack: this should restore a compatible semantics with
      v8.3 where we never stayed focused on 0 goal. *)
-  Decl_mode.maximal_unfocus pts
+  Proof_global.set_proof_mode "Declarative" ;
+  Decl_mode.maximal_unfocus ()
 
 let proof_instr raw_instr =
   let p = Proof_global.give_me_the_proof () in
diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli
index 48986c2d..f86bfea7 100644
--- a/plugins/decl_mode/decl_proof_instr.mli
+++ b/plugins/decl_mode/decl_proof_instr.mli
@@ -1,12 +1,11 @@
 (************************************************************************)
 (*  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 Refiner
 open Names
 open Term
 open Tacmach
@@ -15,9 +14,9 @@ open Decl_mode
 val go_to_proof_mode: unit -> unit
 val return_from_tactic_mode: unit -> unit
 
-val register_automation_tac: tactic -> unit
+val register_automation_tac: unit Proofview.tactic -> unit
 
-val automation_tac : tactic
+val automation_tac : unit Proofview.tactic
 
 val concl_refiner:
   Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
@@ -28,27 +27,27 @@ val proof_instr: Decl_expr.raw_proof_instr -> unit
 val tcl_change_info : Decl_mode.pm_info -> tactic
 
 val execute_cases :
-    Names.name ->
+    Name.t ->
     Decl_mode.per_info ->
     (Term.constr -> Proof_type.tactic) ->
-    (Names.Idset.elt * (Term.constr option * Term.constr list) list) list ->
+    (Id.Set.elt * (Term.constr option * Term.constr list) list) list ->
     Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic
 
 val tree_of_pats : 
-  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree
 
 val add_branch : 
-  identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val append_branch :
-  identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
-  (Names.Idset.t * Decl_mode.split_tree) option ->
-  (Names.Idset.t * Decl_mode.split_tree) option
+  Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+  (Id.Set.t * Decl_mode.split_tree) option ->
+  (Id.Set.t * Decl_mode.split_tree) option
 
 val append_tree :
-  identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+  Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
   split_tree -> split_tree
 
 val build_dep_clause :   Term.types Decl_expr.statement list ->
@@ -58,7 +57,7 @@ val build_dep_clause :   Term.types Decl_expr.statement list ->
     Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types
 
 val register_dep_subcase :    
-    Names.identifier * (int * int) ->
+    Id.t * (int * int) ->
     Environ.env ->
     Decl_mode.per_info ->
     Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
@@ -69,41 +68,41 @@ val thesis_for :     Term.constr ->
 val close_previous_case : Proof.proof -> unit
 
 val pop_stacks :
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val push_head :   Term.constr ->
-  Names.Idset.t ->
-  (Names.identifier *
+  Id.Set.t ->
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val push_arg : Term.constr ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list ->
-  (Names.identifier *
+  (Id.t *
      (Term.constr option * Term.constr list) list) list
 
 val hrec_for:
-    Names.identifier ->
+    Id.t ->
     Decl_mode.per_info -> Proof_type.goal Tacmach.sigma ->
-    Names.identifier -> Term.constr
+    Id.t -> Term.constr
 
 val consider_match :
    bool ->
-    (Names.Idset.elt*bool) list ->
-    Names.Idset.elt list ->
+    (Id.Set.elt*bool) list ->
+    Id.Set.elt list ->
     (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
     Proof_type.tactic
 
 val init_tree:
-    Names.Idset.t ->
-    Names.inductive ->
+    Id.Set.t ->
+    inductive ->
     int option * Declarations.wf_paths ->
     (int ->
      (int option * Declarations.recarg Rtree.t) array ->
-     (Names.Idset.t * Decl_mode.split_tree) option) ->
+     (Id.Set.t * Decl_mode.split_tree) option) ->
     Decl_mode.split_tree
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index 9a1e00ee..03929b3b 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -1,35 +1,33 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
-
-(* arnaud: veiller à l'aspect tutorial des commentaires *)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
+open Util
+open Compat
 open Pp
-open Tok
 open Decl_expr
 open Names
-open Term
-open Genarg
 open Pcoq
+open Vernacexpr
+open Tok (* necessary for camlp4 *)
 
 open Pcoq.Constr
 open Pcoq.Tactic
-open Pcoq.Vernac_
 
 let pr_goal gs =
   let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in
-  let env = Goal.V82.unfiltered_env sigma g in
+  let env = Goal.V82.env sigma g in
   let preamb,thesis,penv,pc =
     (str "     *** Declarative Mode ***" ++ fnl ()++fnl ()),
     (str "thesis := "  ++ fnl ()),
-    Printer.pr_context_of env,
-    Printer.pr_goal_concl_style_env env (Goal.V82.concl sigma g)
+    Printer.pr_context_of env sigma,
+    Printer.pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
   in
     preamb ++
     str"  " ++ hv 0 (penv ++ fnl () ++
@@ -37,7 +35,7 @@ let pr_goal gs =
 		       str "============================" ++ fnl ()  ++
 		       thesis ++ str " " ++  pc) ++ fnl ()
 
-(* arnaud: rebrancher ça 
+(* arnaud: rebrancher ça ?
 let pr_open_subgoals () =
   let p = Proof_global.give_me_the_proof () in
   let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in
@@ -45,29 +43,27 @@ let pr_open_subgoals () =
   pr_subgoals close_cmd sigma goals
 *)
 
-let pr_proof_instr instr = 
-  Util.anomaly "Cannot print a proof_instr"
+let pr_raw_proof_instr _ _ _ instr =
+  Errors.anomaly (Pp.str "Cannot print a proof_instr")
     (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller
                      dans cette direction
        Ppdecl_proof.pr_proof_instr (Global.env()) instr
     *)
-let pr_raw_proof_instr instr =
-  Util.anomaly "Cannot print a raw proof_instr"
-let pr_glob_proof_instr instr =
-  Util.anomaly "Cannot print a non-interpreted proof_instr"
+let pr_proof_instr _ _ _ instr = Empty.abort instr
+let pr_glob_proof_instr _ _ _ instr = Empty.abort instr
 
 let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
   Decl_interp.interp_proof_instr 
     (Decl_mode.get_info sigma gl)
-    (sigma)
     (Goal.V82.env sigma gl)
+    (sigma)
 
 let vernac_decl_proof () = 
   let pf = Proof_global.give_me_the_proof () in
   if Proof.is_done pf then 
-    Util.error "Nothing left to prove here."
+    Errors.error "Nothing left to prove here."
   else
-    Proof.transaction pf begin fun () ->
+    begin
       Decl_proof_instr.go_to_proof_mode () ;
       Proof_global.set_proof_mode "Declarative" ;
       Vernacentries.print_subgoals ()
@@ -75,24 +71,18 @@ let vernac_decl_proof () =
 
 (* spiwack: some bureaucracy is not performed here *)
 let vernac_return () =
-  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+  begin
     Decl_proof_instr.return_from_tactic_mode () ;
     Proof_global.set_proof_mode "Declarative" ;
     Vernacentries.print_subgoals ()
   end
 
 let vernac_proof_instr instr =
-  Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+  begin
     Decl_proof_instr.proof_instr instr;
     Vernacentries.print_subgoals ()
   end
 
-(* We create a new parser entry [proof_mode]. The Declarative proof mode
-    will replace the normal parser entry for tactics with this one. *)
-let proof_mode = Gram.entry_create "vernac:proof_command"
-(* Auxiliary grammar entry. *)
-let proof_instr = Gram.entry_create "proofmode:instr"
-
 (* Before we can write an new toplevel command (see below) 
     which takes a [proof_instr] as argument, we need to declare
     how to parse it, print it, globalise it and interprete it.
@@ -101,33 +91,28 @@ let proof_instr = Gram.entry_create "proofmode:instr"
     indirect through the [proof_instr] grammar entry. *)
 (* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *)
 
-(* [Genarg.create_arg] creates a new embedding into Genarg. *)
-let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) =
-  Genarg.create_arg None "proof_instr"
-let _ = Tacinterp.add_interp_genarg "proof_instr"
-  begin
-  begin fun e x -> (* declares the globalisation function *)
-    Genarg.in_gen globwit_proof_instr 
-      (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x))
-  end,
-  begin fun ist gl x -> (* declares the interpretation function *)
-    Tacmach.project gl ,
-    Genarg.in_gen wit_proof_instr 
-      (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x))
-  end,
-  begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *)
-   end
+(* Only declared at raw level, because only used in vernac commands. *)
+let wit_proof_instr : (raw_proof_instr, Empty.t, Empty.t) Genarg.genarg_type =
+  Genarg.make0 None "proof_instr"
+
+(* We create a new parser entry [proof_mode]. The Declarative proof mode
+    will replace the normal parser entry for tactics with this one. *)
+let proof_mode : vernac_expr Gram.entry =
+  Gram.entry_create "vernac:proof_command"
+(* Auxiliary grammar entry. *)
+let proof_instr : raw_proof_instr Gram.entry =
+  Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr)
 
-let _ = Pptactic.declare_extra_genarg_pprule
-  (rawwit_proof_instr, pr_raw_proof_instr)
-  (globwit_proof_instr, pr_glob_proof_instr)
-  (wit_proof_instr, pr_proof_instr)
+let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr
+  pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr
+
+let classify_proof_instr _ = VtProofStep false, VtLater
 
 (* We use the VERNAC EXTEND facility with a custom non-terminal
     to populate [proof_mode] with a new toplevel interpreter.
     The "-" indicates that the rule does not start with a distinguished
     string. *)
-VERNAC proof_mode EXTEND ProofInstr
+VERNAC proof_mode EXTEND ProofInstr CLASSIFIED BY classify_proof_instr
   [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ]
 END
 
@@ -140,7 +125,7 @@ GEXTEND Gram
   GLOBAL: proof_mode ;
 
   proof_mode: LAST
-    [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ]
+    [ [ c=G_vernac.subgoal_command -> c (Some (Vernacexpr.SelectNth 1)) ] ]
   ;
 END  
 
@@ -171,12 +156,11 @@ let _ =
 				       end
 				   }
 
-(* Two new vernacular commands *)
 VERNAC COMMAND EXTEND DeclProof
-  [ "proof" ] -> [ vernac_decl_proof () ]
+[ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ]
 END
 VERNAC COMMAND EXTEND  DeclReturn
-  [ "return" ] -> [ vernac_return () ]
+[ "return" ] => [ VtProofMode "Classic", VtNow ] -> [ vernac_return () ]
 END
 
 let none_is_empty = function
@@ -192,7 +176,7 @@ GLOBAL: proof_instr;
   statement :
     [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c}
      | i=ident -> {st_label=Anonymous;
-		   st_it=Topconstr.CRef (Libnames.Ident (loc, i))}
+		   st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)}
      | c=constr -> {st_label=Anonymous;st_it=c}
      ]];
   constr_or_thesis :
@@ -205,7 +189,7 @@ GLOBAL: proof_instr;
     |
       [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot}
       | i=ident -> {st_label=Anonymous;
-		    st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))}
+		    st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))}
       | c=constr -> {st_label=Anonymous;st_it=This c}
       ]
     ];
@@ -273,7 +257,7 @@ GLOBAL: proof_instr;
   ;
   (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*)
   loc_id: 
-    [[ id=ident -> fun x -> (loc,(id,x)) ]];
+    [[ id=ident -> fun x -> (!@loc,(id,x)) ]];
   hyp:
     [[ id=loc_id -> id None ;
      | id=loc_id ; ":" ; c=constr -> id (Some c)]]
@@ -405,5 +389,3 @@ GLOBAL: proof_instr;
     [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]]
   ;
 END;;
-
- 
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 102da8cc..27308666 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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 Util
+open Errors
 open Pp
 open Decl_expr
 open Names
@@ -20,6 +20,8 @@ let pr_label = function
     Anonymous -> mt ()
   | Name id -> pr_id id ++ spc () ++ str ":" ++ spc ()
 
+let pr_constr env c = pr_constr env Evd.empty c
+
 let pr_justification_items env = function
     Some [] -> mt ()
   | Some (_::_ as l) ->
@@ -75,7 +77,7 @@ and print_vars pconstr gtyp env sep _be _have vars =
       begin
 	let nenv =
 	  match st.st_label with
-	      Anonymous -> anomaly "anonymous variable"
+	      Anonymous -> anomaly (Pp.str "anonymous variable")
 	    | Name id -> Environ.push_named (id,None,st.st_it) env in
 	let pr_sep = if sep then pr_comma () else mt () in
 		spc() ++ pr_sep ++
@@ -173,14 +175,14 @@ let rec pr_bare_proof_instr _then _thus env = function
       str "per" ++ spc () ++ pr_elim_type et ++ spc () ++
       pr_casee env c
   | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et
-  | _ -> anomaly "unprintable instruction"
+  | _ -> anomaly (Pp.str "unprintable instruction")
 
 let pr_emph = function
     0 -> str "    "
   | 1 -> str "*   "
   | 2 -> str "**  "
   | 3 -> str "*** "
-  | _ -> anomaly "unknown emphasis"
+  | _ -> anomaly (Pp.str "unknown emphasis")
 
 let pr_proof_instr env instr =
   pr_emph instr.emph ++ spc () ++
diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v
new file mode 100644
index 00000000..0d5a93b0
--- /dev/null
+++ b/plugins/derive/Derive.v
@@ -0,0 +1 @@
+Declare ML Module "derive_plugin".
\ No newline at end of file
diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml
new file mode 100644
index 00000000..439b1a5c
--- /dev/null
+++ b/plugins/derive/derive.ml
@@ -0,0 +1,104 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+let map_const_entry_body (f:Term.constr->Term.constr) (x:Entries.const_entry_body)
+    : Entries.const_entry_body =
+  Future.chain ~pure:true x begin fun ((b,ctx),fx) ->
+    (f b , ctx) , fx
+  end
+
+(** [start_deriving f suchthat lemma] starts a proof of [suchthat]
+    (which can contain references to [f]) in the context extended by
+    [f:=?x]. When the proof ends, [f] is defined as the value of [?x]
+    and [lemma] as the proof. *)
+let start_deriving f suchthat lemma =
+
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let kind = Decl_kinds.(Global,false,DefinitionBody Definition) in
+
+  (** create a sort variable for the type of [f] *)
+  (* spiwack: I don't know what the rigidity flag does, picked the one
+     that looked the most general. *)
+  let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in
+  let f_type_type = Term.mkSort f_type_sort in
+  (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *)
+  let goals =
+    let open Proofview in
+        TCons ( env , sigma , f_type_type , (fun sigma f_type ->
+        TCons ( env , sigma , f_type , (fun sigma ef ->
+        let env' = Environ.push_named (f , (Some ef) , f_type) env in
+        let evdref = ref sigma in
+        let suchthat = Constrintern.interp_type_evars env' evdref suchthat in
+        TCons ( env' , !evdref , suchthat , (fun sigma _ ->
+        TNil sigma))))))
+    in
+
+    (** The terminator handles the registering of constants when the proof is closed. *)
+    let terminator com =
+      let open Proof_global in
+      (** Extracts the relevant information from the proof. [Admitted]
+          and [Save] result in user errors. [opaque] is [true] if the
+          proof was concluded by [Qed], and [false] if [Defined]. [f_def]
+          and [lemma_def] correspond to the proof of [f] and of
+          [suchthat], respectively. *)
+      let (opaque,f_def,lemma_def) =
+        match com with
+        | Admitted -> Errors.error"Admitted isn't supported in Derive."
+        | Proved (_,Some _,_) ->
+            Errors.error"Cannot save a proof of Derive with an explicit name."
+        | Proved (opaque, None, obj) ->
+            match Proof_global.(obj.entries) with
+            | [_;f_def;lemma_def] ->
+                opaque , f_def , lemma_def
+            | _ -> assert false
+      in
+      (** The opacity of [f_def] is adjusted to be [false], as it
+          must. Then [f] is declared in the global environment. *)
+      let f_def = { f_def with Entries.const_entry_opaque = false } in
+      let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in
+      let f_kn = Declare.declare_constant f f_def in
+      let f_kn_term = Term.mkConst f_kn in
+      (** In the type and body of the proof of [suchthat] there can be
+          references to the variable [f]. It needs to be replaced by
+          references to the constant [f] declared above. This substitution
+          performs this precise action. *)
+      let substf c = Vars.replace_vars [f,f_kn_term] c in
+      (** Extracts the type of the proof of [suchthat]. *)
+      let lemma_pretype =
+        match Entries.(lemma_def.const_entry_type) with
+        | Some t -> t
+        | None -> assert false (* Proof_global always sets type here. *)
+      in
+      (** The references of [f] are subsituted appropriately. *)
+      let lemma_type = substf lemma_pretype in
+      (** The same is done in the body of the proof. *)
+      let lemma_body =
+        map_const_entry_body substf Entries.(lemma_def.const_entry_body)
+      in
+      let lemma_def = let open Entries in { lemma_def with
+        const_entry_body = lemma_body ;
+        const_entry_type = Some lemma_type ;
+        const_entry_opaque = opaque ; }
+      in
+      let lemma_def =
+        Entries.DefinitionEntry lemma_def ,
+        Decl_kinds.(IsProof Proposition)
+      in
+      ignore (Declare.declare_constant lemma lemma_def)
+      in
+
+  let () = Proof_global.start_dependent_proof lemma kind goals terminator in
+  let _ = Proof_global.with_current_proof begin fun _ p ->
+    Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p
+  end in
+  ()
+
+
+
+
diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli
new file mode 100644
index 00000000..b49ef6b9
--- /dev/null
+++ b/plugins/derive/derive.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** [start_deriving f suchthat lemma] starts a proof of [suchthat]
+    (which can contain references to [f]) in the context extended by
+    [f:=?x]. When the proof ends, [f] is defined as the value of [?x]
+    and [lemma] as the proof. *)
+val start_deriving : Names.Id.t -> Constrexpr.constr_expr -> Names.Id.t -> unit
diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mllib
new file mode 100644
index 00000000..5ee0fc6d
--- /dev/null
+++ b/plugins/derive/derive_plugin.mllib
@@ -0,0 +1,2 @@
+Derive
+G_derive
diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4
new file mode 100644
index 00000000..c031e3bc
--- /dev/null
+++ b/plugins/derive/g_derive.ml4
@@ -0,0 +1,16 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma"  i*)
+
+let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater)
+
+VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command
+| [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] ->
+     [ Derive.start_deriving f suchthat lemma ]
+END
diff --git a/plugins/derive/vo.itarget b/plugins/derive/vo.itarget
new file mode 100644
index 00000000..b4809821
--- /dev/null
+++ b/plugins/derive/vo.itarget
@@ -0,0 +1 @@
+Derive.vo
\ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
index 3a06c0a3..9dbda821 100644
--- a/plugins/extraction/ExtrOcamlBasic.v
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -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/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
index 78544d44..4cc76d86 100644
--- a/plugins/extraction/ExtrOcamlBigIntConv.v
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -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        *)
@@ -10,7 +10,7 @@
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 Require Import Arith ZArith.
@@ -105,4 +105,4 @@ Definition check :=
 Extraction "/tmp/test.ml" check test.
 
 ... and we check that test=check
-*)
\ No newline at end of file
+*)
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
index 424a42c5..eb43d69f 100644
--- a/plugins/extraction/ExtrOcamlIntConv.v
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -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/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
index 926b8c6c..1386c2ad 100644
--- a/plugins/extraction/ExtrOcamlNatBigInt.v
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -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        *)
@@ -13,7 +13,7 @@ Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 (** Disclaimer: trying to obtain efficient certified programs
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
index 105298e0..5f653ee1 100644
--- a/plugins/extraction/ExtrOcamlNatInt.v
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -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/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v
index aee3c386..ce8025bf 100644
--- a/plugins/extraction/ExtrOcamlString.v
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -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/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 6e98a377..3d59669a 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -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        *)
@@ -13,7 +13,7 @@ Require Import ExtrOcamlBasic.
 
 (** NB: The extracted code should be linked with [nums.cm(x)a]
     from ocaml's stdlib and with the wrapper [big.ml] that
-    simlifies the use of [Big_int] (it could be found in the sources
+    simplifies the use of [Big_int] (it can be found in the sources
     of Coq). *)
 
 (** Disclaimer: trying to obtain efficient certified programs
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
index ea001c80..79d67495 100644
--- a/plugins/extraction/ExtrOcamlZInt.v
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -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        *)
@@ -43,7 +43,7 @@ Extract Constant Pos.max => "Pervasives.max".
 Extract Constant Pos.compare =>
  "fun x y -> if x=y then Eq else if x<y then Lt else Gt".
 Extract Constant Pos.compare_cont =>
- "fun x y c -> if x=y then c else if x<y then Lt else Gt".
+ "fun c x y -> if x=y then c else if x<y then Lt else Gt".
 
 
 Extract Constant N.add => "(+)".
diff --git a/plugins/extraction/README b/plugins/extraction/README
index 64c871fd..458ba0de 100644
--- a/plugins/extraction/README
+++ b/plugins/extraction/README
@@ -6,7 +6,7 @@
 What is it ?
 ------------
 
-The extraction is a mechanism allowing to produce functional code
+The extraction is a mechanism that produces functional code
 (Ocaml/Haskell/Scheme) out of any Coq terms (either programs or
 proofs).
 
@@ -14,7 +14,7 @@ Who did it ?
 ------------
 
 The current implementation (from version 7.0 up to now) has been done
-by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
+by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
 by C. Paulin. 
 
 An earlier implementation (versions 6.x) was due to B. Werner and
@@ -118,7 +118,7 @@ Axioms, and then "Extract Constant ..."
 
 
 [1]:
-Exécution de termes de preuves: une nouvelle méthode d'extraction 
+Exécution de termes de preuves: une nouvelle méthode d'extraction 
 pour le Calcul des Constructions Inductives, Pierre Letouzey,
 DEA thesis, 2000, 
 http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz
@@ -129,7 +129,7 @@ Types 2002 Post-Workshop Proceedings.
 http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz
 
 [3]: 
-Programmation fonctionnelle certifiée: l'extraction de programmes
+Programmation fonctionnelle certifiée: l'extraction de programmes
 dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004.
 http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz
 http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz
diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml
index 2fd0e1b5..f2a965c9 100644
--- a/plugins/extraction/big.ml
+++ b/plugins/extraction/big.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        *)
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 558b8359..21819aa8 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.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        *)
@@ -9,23 +9,20 @@
 open Pp
 open Util
 open Names
-open Term
-open Declarations
 open Namegen
 open Nameops
 open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
-open Modutil
-open Mod_subst
 
 let string_of_id id =
-  let s = Names.string_of_id id in
+  let s = Names.Id.to_string id in
   for i = 0 to String.length s - 2 do
-    if s.[i] = '_' && s.[i+1] = '_' then warning_id s
+    if s.[i] == '_' && s.[i+1] == '_' then warning_id s
   done;
-  ascii_of_ident s
+  Unicode.ascii_of_ident s
 
 let is_mp_bound = function MPbound _ -> true | _ -> false
 
@@ -42,7 +39,7 @@ let pp_apply st par args = match args with
 (** Same as [pp_apply], but with also protection of the head by parenthesis *)
 
 let pp_apply2 st par args =
-  let par' = args <> [] || par in
+  let par' = not (List.is_empty args) || par in
   pp_apply (pp_par par' st) par args
 
 let pr_binding = function
@@ -82,20 +79,20 @@ let is_digit = function
 
 let begins_with_CoqXX s =
   let n = String.length s in
-  n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' &&
+  n >= 4 && s.[0] == 'C' && s.[1] == 'o' && s.[2] == 'q' &&
   let i = ref 3 in
   try while !i < n do
-    if s.[!i] = '_' then i:=n (*Stop*)
+    if s.[!i] == '_' then i:=n (*Stop*)
     else if is_digit s.[!i] then incr i
     else raise Not_found
   done; true
   with Not_found -> false
 
 let unquote s =
-  if lang () <> Scheme then s
+  if lang () != Scheme then s
   else
     let s = String.copy s in
-    for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
+    for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done;
     s
 
 let rec qualify delim = function
@@ -112,17 +109,28 @@ let pseudo_qualify = qualify "__"
 let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
 let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
 
-let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let lowercase_id id = Id.of_string (String.uncapitalize (string_of_id id))
 let uppercase_id id =
   let s = string_of_id id in
-  assert (s<>"");
-  if s.[0] = '_' then id_of_string ("Coq_"^s)
-  else id_of_string (String.capitalize s)
+  assert (not (String.is_empty s));
+  if s.[0] == '_' then Id.of_string ("Coq_"^s)
+  else Id.of_string (String.capitalize s)
 
 type kind = Term | Type | Cons | Mod
 
+module KOrd =
+struct
+  type t = kind * string
+  let compare (k1, s1) (k2, s2) =
+    let c = Pervasives.compare k1 k2 (** OK *) in
+    if c = 0 then String.compare s1 s2
+    else c
+end
+
+module KMap = Map.Make(KOrd)
+
 let upperkind = function
-  | Type -> lang () = Haskell
+  | Type -> lang () == Haskell
   | Term -> false
   | Cons | Mod -> true
 
@@ -131,12 +139,12 @@ let kindcase_id k id =
 
 (*s de Bruijn environments for programs *)
 
-type env = identifier list * Idset.t
+type env = Id.t list * Id.Set.t
 
 (*s Generic renaming issues for local variable names. *)
 
 let rec rename_id id avoid =
-  if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id
+  if Id.Set.mem id avoid then rename_id (lift_subscript id) avoid else id
 
 let rec rename_vars avoid = function
   | [] ->
@@ -148,14 +156,14 @@ let rec rename_vars avoid = function
   | id :: idl ->
       let (idl, avoid) = rename_vars avoid idl in
       let id = rename_id (lowercase_id id) avoid in
-      (id :: idl, Idset.add id avoid)
+      (id :: idl, Id.Set.add id avoid)
 
 let rename_tvars avoid l =
   let rec rename avoid = function
     | [] -> [],avoid
     | id :: idl ->
 	let id = rename_id (lowercase_id id) avoid in
-	let idl, avoid = rename (Idset.add id avoid) idl in
+	let idl, avoid = rename (Id.Set.add id avoid) idl in
 	(id :: idl, avoid) in
   fst (rename avoid l)
 
@@ -165,7 +173,7 @@ let push_vars ids (db,avoid) =
 
 let get_db_name n (db,_) =
   let id = List.nth db (pred n) in
-  if id = dummy_name then id_of_string "__" else id
+  if Id.equal id dummy_name then Id.of_string "__" else id
 
 
 (*S Renamings of global objects. *)
@@ -182,37 +190,44 @@ let set_phase, get_phase =
   let ph = ref Impl in ((:=) ph), (fun () -> !ph)
 
 let set_keywords, get_keywords =
-  let k = ref Idset.empty in
+  let k = ref Id.Set.empty in
   ((:=) k), (fun () -> !k)
 
 let add_global_ids, get_global_ids =
-  let ids = ref Idset.empty in
+  let ids = ref Id.Set.empty in
   register_cleanup (fun () -> ids := get_keywords ());
-  let add s = ids := Idset.add s !ids
+  let add s = ids := Id.Set.add s !ids
   and get () = !ids
   in (add,get)
 
 let empty_env () = [], get_global_ids ()
 
-let mktable autoclean =
-  let h = Hashtbl.create 97 in
-  if autoclean then register_cleanup (fun () -> Hashtbl.clear h);
-  (Hashtbl.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h)
-
 (* We might have built [global_reference] whose canonical part is
    inaccurate. We must hence compare only the user part,
    hence using a Hashtbl might be incorrect *)
 
+let mktable_id autoclean =
+  let m = ref Id.Map.empty in
+  let clear () = m := Id.Map.empty in
+  if autoclean then register_cleanup clear;
+  (fun r v -> m := Id.Map.add r v !m), (fun r -> Id.Map.find r !m), clear
+
 let mktable_ref autoclean =
   let m = ref Refmap'.empty in
   let clear () = m := Refmap'.empty in
   if autoclean then register_cleanup clear;
   (fun r v -> m := Refmap'.add r v !m), (fun r -> Refmap'.find r !m), clear
 
+let mktable_modpath autoclean =
+  let m = ref MPmap.empty in
+  let clear () = m := MPmap.empty in
+  if autoclean then register_cleanup clear;
+  (fun r v -> m := MPmap.add r v !m), (fun r -> MPmap.find r !m), clear
+
 (* A table recording objects in the first level of all MPfile *)
 
 let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content =
-  mktable false
+  mktable_modpath false
 
 let get_mpfiles_content mp =
   try get_mpfiles_content mp
@@ -258,7 +273,7 @@ let params_ren_add, params_ren_mem =
 
 type visible_layer = { mp : module_path;
 		       params : module_path list;
-		       content : ((kind*string),label) Hashtbl.t }
+		       mutable content : Label.t KMap.t; }
 
 let pop_visible, push_visible, get_visible =
   let vis = ref [] in
@@ -269,35 +284,47 @@ let pop_visible, push_visible, get_visible =
       | v :: vl ->
 	  vis := vl;
 	  (* we save the 1st-level-content of MPfile for later use *)
-	  if get_phase () = Impl && modular () && is_modfile v.mp
+	  if get_phase () == Impl && modular () && is_modfile v.mp
 	  then add_mpfiles_content v.mp v.content
   and push mp mps =
-    vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis
+    vis := { mp = mp; params = mps; content = KMap.empty } :: !vis
   and get () = !vis
   in (pop,push,get)
 
 let get_visible_mps () = List.map (function v -> v.mp) (get_visible ())
 let top_visible () = match get_visible () with [] -> assert false | v::_ -> v
 let top_visible_mp () = (top_visible ()).mp
-let add_visible ks l = Hashtbl.add (top_visible ()).content ks l
+let add_visible ks l =
+  let visible = top_visible () in
+  visible.content <- KMap.add ks l visible.content
 
 (* table of local module wrappers used to provide non-ambiguous names *)
 
+module DupOrd =
+struct
+  type t = ModPath.t * Label.t
+  let compare (mp1, l1) (mp2, l2) =
+    let c = Label.compare l1 l2 in
+    if Int.equal c 0 then ModPath.compare mp1 mp2 else c
+end
+
+module DupMap = Map.Make(DupOrd)
+
 let add_duplicate, check_duplicate =
-  let index = ref 0 and dups = ref Gmap.empty in
-  register_cleanup (fun () -> index := 0; dups := Gmap.empty);
+  let index = ref 0 and dups = ref DupMap.empty in
+  register_cleanup (fun () -> index := 0; dups := DupMap.empty);
   let add mp l =
      incr index;
-     let ren = "Coq__" ^ string_of_int (!index) in
-     dups := Gmap.add (mp,l) ren !dups
-  and check mp l = Gmap.find (mp, l) !dups
+     let ren = "Coq__" ^ string_of_int !index in
+     dups := DupMap.add (mp,l) ren !dups
+  and check mp l = DupMap.find (mp, l) !dups
   in (add,check)
 
 type reset_kind = AllButExternal | Everything
 
 let reset_renaming_tables flag =
   do_cleanup ();
-  if flag = Everything then clear_mpfiles_content ()
+  if flag == Everything then clear_mpfiles_content ()
 
 (*S Renaming functions *)
 
@@ -312,8 +339,8 @@ let modular_rename k id =
     if upperkind k then "Coq_",is_upper else "coq_",is_lower
   in
   if not (is_ok s) ||
-    (Idset.mem id (get_keywords ())) ||
-    (String.length s >= 4 && String.sub s 0 4 = prefix)
+    (Id.Set.mem id (get_keywords ())) ||
+    (String.length s >= 4 && String.equal (String.sub s 0 4) prefix)
   then prefix ^ s
   else s
 
@@ -321,10 +348,10 @@ let modular_rename k id =
     with unique numbers *)
 
 let modfstlev_rename =
-  let add_prefixes,get_prefixes,_ = mktable true in
+  let add_prefixes,get_prefixes,_ = mktable_id true in
   fun l ->
-    let coqid = id_of_string "Coq" in
-    let id = id_of_label l in
+    let coqid = Id.of_string "Coq" in
+    let id = Label.to_id l in
     try
       let coqset = get_prefixes id in
       let nextcoq = next_ident_away coqid coqset in
@@ -343,23 +370,26 @@ let rec mp_renaming_fun mp = match mp with
   | _ when not (modular ()) && at_toplevel mp -> [""]
   | MPdot (mp,l) ->
       let lmp = mp_renaming mp in
-      if lmp = [""] then (modfstlev_rename l)::lmp
-      else (modular_rename Mod (id_of_label l))::lmp
+      let mp = match lmp with
+      | [""] -> modfstlev_rename l
+      | _ -> modular_rename Mod (Label.to_id l)
+      in
+      mp ::lmp
   | MPbound mbid ->
-      let s = modular_rename Mod (id_of_mbid mbid) in
+      let s = modular_rename Mod (MBId.to_id mbid) in
       if not (params_ren_mem mp) then [s]
-      else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i]
+      else let i,_,_ = MBId.repr mbid in [s^"__"^string_of_int i]
   | MPfile _ ->
       assert (modular ()); (* see [at_toplevel] above *)
-      assert (get_phase () = Pre);
-      let current_mpfile = (list_last (get_visible ())).mp in
-      if mp <> current_mpfile then mpfiles_add mp;
+      assert (get_phase () == Pre);
+      let current_mpfile = (List.last (get_visible ())).mp in
+      if not (ModPath.equal mp current_mpfile) then mpfiles_add mp;
       [string_of_modfile mp]
 
 (* ... and its version using a cache *)
 
 and mp_renaming =
-  let add,get,_ = mktable true in
+  let add,get,_ = mktable_modpath true in
   fun x ->
     try if is_mp_bound (base_mp x) then raise Not_found; get x
     with Not_found -> let y = mp_renaming_fun x in add x y; y
@@ -370,17 +400,17 @@ and mp_renaming =
 let ref_renaming_fun (k,r) =
   let mp = modpath_of_r r in
   let l = mp_renaming mp in
-  let l = if lang () <> Ocaml && not (modular ()) then [""] else l in
+  let l = if lang () != Ocaml && not (modular ()) then [""] else l in
   let s =
     let idg = safe_basename_of_global r in
-    if l = [""] (* this happens only at toplevel of the monolithic case *)
-    then
-      let globs = Idset.elements (get_global_ids ()) in
+    match l with
+    | [""] -> (* this happens only at toplevel of the monolithic case *)
+      let globs = Id.Set.elements (get_global_ids ()) in
       let id = next_ident_away (kindcase_id k idg) globs in
       string_of_id id
-    else modular_rename k idg
+    | _ -> modular_rename k idg
   in
-  add_global_ids (id_of_string s);
+  add_global_ids (Id.of_string s);
   s::l
 
 (* Cached version of the last function *)
@@ -399,27 +429,30 @@ let ref_renaming =
 
 let rec clash mem mp0 ks = function
   | [] -> false
-  | mp :: _ when mp = mp0 -> false
+  | mp :: _ when ModPath.equal mp mp0 -> false
   | mp :: _ when mem mp ks -> true
   | _ :: mpl -> clash mem mp0 ks mpl
 
 let mpfiles_clash mp0 ks =
-  clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks
+  clash (fun mp k -> KMap.mem k (get_mpfiles_content mp)) mp0 ks
     (List.rev (mpfiles_list ()))
 
 let rec params_lookup mp0 ks = function
   | [] -> false
-  | param :: _ when mp0 = param -> true
+  | param :: _ when ModPath.equal mp0 param -> true
   | param :: params ->
-      if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param;
+      let () = match ks with
+      | (Mod, mp) when String.equal (List.hd (mp_renaming param)) mp -> params_ren_add param
+      | _ -> ()
+      in
       params_lookup mp0 ks params
 
 let visible_clash mp0 ks =
   let rec clash = function
     | [] -> false
-    | v :: _ when v.mp = mp0 -> false
+    | v :: _ when ModPath.equal v.mp mp0 -> false
     | v :: vis ->
-	let b = Hashtbl.mem v.content ks in
+	let b = KMap.mem ks v.content in
 	if b && not (is_mp_bound mp0) then true
 	else begin
 	  if b then params_ren_add mp0;
@@ -433,9 +466,9 @@ let visible_clash mp0 ks =
 let visible_clash_dbg mp0 ks =
   let rec clash = function
     | [] -> None
-    | v :: _ when v.mp = mp0 -> None
+    | v :: _ when ModPath.equal v.mp mp0 -> None
     | v :: vis ->
-	try Some (v.mp,Hashtbl.find v.content ks)
+	try Some (v.mp,KMap.find ks v.content)
 	with Not_found ->
 	  if params_lookup mp0 ks v.params then None
 	  else clash vis
@@ -455,7 +488,7 @@ let opened_libraries () =
     let to_open =
       List.filter
 	(fun mp ->
-	   not (List.exists (Hashtbl.mem (get_mpfiles_content mp)) used_ks))
+	   not (List.exists (fun k -> KMap.mem k (get_mpfiles_content mp)) used_ks))
 	used_files
     in
     mpfiles_clear ();
@@ -476,7 +509,7 @@ let opened_libraries () =
 
 let pp_duplicate k' prefix mp rls olab =
   let rls', lbl =
-    if k'<>Mod then
+    if k' != Mod then
       (* Here rls=[s], the ref to print is <prefix>.<s>, and olab<>None *)
       rls, Option.get olab
     else
@@ -485,7 +518,7 @@ let pp_duplicate k' prefix mp rls olab =
   in
   try dottify (check_duplicate prefix lbl :: rls')
   with Not_found ->
-    assert (get_phase () = Pre); (* otherwise it's too late *)
+    assert (get_phase () == Pre); (* otherwise it's too late *)
     add_duplicate prefix lbl; dottify rls
 
 let fstlev_ks k = function
@@ -498,8 +531,8 @@ let fstlev_ks k = function
 
 let pp_ocaml_local k prefix mp rls olab =
   (* what is the largest prefix of [mp] that belongs to [visible]? *)
-  assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
-  let rls' = list_skipn (mp_length prefix) rls in
+  assert (k != Mod || not (ModPath.equal mp prefix)); (* mp as whole module isn't in itself *)
+  let rls' = List.skipn (mp_length prefix) rls in
   let k's = fstlev_ks k rls' in
   (* Reference r / module path mp is of the form [<prefix>.s.<...>]. *)
   if not (visible_clash prefix k's) then dottify rls'
@@ -510,7 +543,7 @@ let pp_ocaml_local k prefix mp rls olab =
 
 let pp_ocaml_bound base rls =
   (* clash with a MPbound will be detected and fixed by renaming this MPbound *)
-  if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls));
+  if get_phase () == Pre then ignore (visible_clash base (Mod,List.hd rls));
   dottify rls
 
 (* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *)
@@ -519,7 +552,7 @@ let pp_ocaml_extern k base rls = match rls with
   | [] -> assert false
   | base_s :: rls' ->
       if (not (modular ())) (* Pseudo qualification with "" *)
-	|| (rls' = [])  (* Case of a file A.v used as a module later *)
+	|| (List.is_empty rls')  (* Case of a file A.v used as a module later *)
 	|| (not (mpfiles_mem base)) (* Module not opened *)
 	|| (mpfiles_clash base (fstlev_ks k rls')) (* Conflict in opened files *)
 	|| (visible_clash base (fstlev_ks k rls')) (* Local conflict *)
@@ -549,7 +582,7 @@ let pp_haskell_gen k mp rls = match rls with
   | s::rls' ->
     let str = pseudo_qualify rls' in
     let str = if is_upper str && not (upperkind k) then ("_"^str) else str in
-    let prf = if base_mp mp <> top_visible_mp () then s ^ "." else "" in
+    let prf = if not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in
     prf ^ str
 
 (* Main name printing function for a reference *)
@@ -559,7 +592,7 @@ let pp_global k r =
   assert (List.length ls > 1);
   let s = List.hd ls in
   let mp,_,l = repr_of_r r in
-  if mp = top_visible_mp () then
+  if ModPath.equal mp (top_visible_mp ()) then
     (* simpliest situation: definition of r (or use in the same context) *)
     (* we update the visible environment *)
     (add_visible (k,s) l; unquote s)
@@ -575,7 +608,7 @@ let pp_global k r =
 let pp_module mp =
   let ls = mp_renaming mp in
   match mp with
-    | MPdot (mp0,l) when mp0 = top_visible_mp () ->
+    | MPdot (mp0,l) when ModPath.equal mp0 (top_visible_mp ()) ->
 	(* simpliest situation: definition of mp (or use in the same context) *)
 	(* we update the visible environment *)
 	let s = List.hd ls in
@@ -587,7 +620,7 @@ let pp_module mp =
     the constants are directly turned into chars *)
 
 let mk_ind path s =
-  make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s)
+  MutInd.make2 (MPfile (dirpath_of_string path)) (Label.make s)
 
 let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii"
 
@@ -598,7 +631,7 @@ let check_extract_ascii () =
       | Haskell -> "Char"
       | _ -> raise Not_found
     in
-    find_custom (IndRef (ind_ascii,0)) = char_type
+    String.equal (find_custom (IndRef (ind_ascii, 0))) (char_type)
   with Not_found -> false
 
 let is_list_cons l =
@@ -606,14 +639,16 @@ let is_list_cons l =
 
 let is_native_char = function
   | MLcons(_,ConstructRef ((kn,0),1),l) ->
-    kn = ind_ascii && check_extract_ascii () && is_list_cons l
+    MutInd.equal kn ind_ascii && check_extract_ascii () && is_list_cons l
   | _ -> false
 
-let pp_native_char c =
+let get_native_char c =
   let rec cumul = function
     | [] -> 0
     | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
     | _ -> assert false
   in
   let l = match c with MLcons(_,_,l) -> l | _ -> assert false in
-  str ("'"^Char.escaped (Char.chr (cumul l))^"'")
+  Char.chr (cumul l)
+
+let pp_native_char c = str ("'"^Char.escaped (get_native_char c)^"'")
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
index 7375f2d4..a8ab4fd3 100644
--- a/plugins/extraction/common.mli
+++ b/plugins/extraction/common.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        *)
 (************************************************************************)
 
 open Names
-open Libnames
+open Globnames
 open Miniml
-open Mlutil
 open Pp
 
 (** By default, in module Format, you can do horizontal placing of blocks
@@ -33,17 +32,17 @@ val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds
 val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
 
-val pr_binding : identifier list -> std_ppcmds
+val pr_binding : Id.t list -> std_ppcmds
 
-val rename_id : identifier -> Idset.t -> identifier
+val rename_id : Id.t -> Id.Set.t -> Id.t
 
-type env = identifier list * Idset.t
+type env = Id.t list * Id.Set.t
 val empty_env : unit -> env
 
-val rename_vars: Idset.t -> identifier list -> env
-val rename_tvars: Idset.t -> identifier list -> identifier list
-val push_vars : identifier list -> env -> identifier list * env
-val get_db_name : int -> env -> identifier
+val rename_vars: Id.Set.t -> Id.t list -> env
+val rename_tvars: Id.Set.t -> Id.t list -> Id.t list
+val push_vars : Id.t list -> env -> Id.t list * env
+val get_db_name : int -> env -> Id.t
 
 type phase = Pre | Impl | Intf
 
@@ -63,13 +62,13 @@ val top_visible_mp : unit -> module_path
 val push_visible : module_path -> module_path list -> unit
 val pop_visible : unit -> unit
 
-val check_duplicate : module_path -> label -> string
+val check_duplicate : module_path -> Label.t -> string
 
 type reset_kind = AllButExternal | Everything
 
 val reset_renaming_tables : reset_kind -> unit
 
-val set_keywords : Idset.t -> unit
+val set_keywords : Id.Set.t -> unit
 
 (** For instance: [mk_ind "Coq.Init.Datatypes" "nat"] *)
 
@@ -80,4 +79,5 @@ val mk_ind : string -> string -> mutual_inductive
     the constants are directly turned into chars *)
 
 val is_native_char : ml_ast -> bool
+val get_native_char : ml_ast -> char
 val pp_native_char : ml_ast -> std_ppcmds
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 84088292..42e69d34 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -1,18 +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        *)
 (************************************************************************)
 
+open Miniml
 open Term
 open Declarations
 open Names
 open Libnames
+open Globnames
 open Pp
+open Errors
 open Util
-open Miniml
 open Table
 open Extraction
 open Modutil
@@ -24,33 +26,41 @@ open Mod_subst
 (***************************************)
 
 let toplevel_env () =
-  let seg = Lib.contents_after None in
   let get_reference = function
     | (_,kn), Lib.Leaf o ->
 	let mp,_,l = repr_kn kn in
-	let seb = match Libobject.object_tag o with
-	  | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
-	  | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn))
-	  | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l)))
+	begin match Libobject.object_tag o with
+	  | "CONSTANT" ->
+            let constant = Global.lookup_constant (constant_of_kn kn) in
+            Some (l, SFBconst constant)
+	  | "INDUCTIVE" ->
+            let inductive = Global.lookup_mind (mind_of_kn kn) in
+            Some (l, SFBmind inductive)
+	  | "MODULE" ->
+            let modl = Global.lookup_module (MPdot (mp, l)) in
+            Some (l, SFBmodule modl)
 	  | "MODULE TYPE" ->
-	      SFBmodtype (Global.lookup_modtype (MPdot (mp,l)))
-	  | _ -> failwith "caught"
-	in l,seb
-    | _ -> failwith "caught"
+            let modtype = Global.lookup_modtype (MPdot (mp, l)) in
+            Some (l, SFBmodtype modtype)
+          | "INCLUDE" -> error "No extraction of toplevel Include yet."
+	  | _ -> None
+        end
+    | _ -> None
   in
-  SEBstruct (List.rev (map_succeed get_reference seg))
+  List.rev (List.map_filter get_reference (Lib.contents ()))
 
 
 let environment_until dir_opt =
   let rec parse = function
-    | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
+    | [] when Option.is_empty dir_opt -> [Lib.current_mp (), toplevel_env ()]
     | [] -> []
     | d :: l ->
-	match (Global.lookup_module (MPfile d)).mod_expr with
-	  | Some meb ->
-	      if dir_opt = Some d then [MPfile d, meb]
-	      else (MPfile d, meb) :: (parse l)
-	  | _ -> assert false
+      let meb =
+        Modops.destr_nofunctor (Global.lookup_module (MPfile d)).mod_type
+      in
+      match dir_opt with
+      | Some d' when DirPath.equal d d' -> [MPfile d, meb]
+      | _ -> (MPfile d, meb) :: (parse l)
   in parse (Library.loaded_libraries ())
 
 
@@ -61,16 +71,12 @@ module type VISIT = sig
   (* Reset the dependencies by emptying the visit lists *)
   val reset : unit -> unit
 
-  (* Add the module_path and all its prefixes to the mp visit list *)
-  val add_mp : module_path -> unit
-
-  (* Same, but we'll keep all fields of these modules *)
+  (* Add the module_path and all its prefixes to the mp visit list.
+     We'll keep all fields of these modules. *)
   val add_mp_all : module_path -> unit
 
-  (* Add kernel_name / constant / reference / ... in the visit lists.
+  (* Add reference / ... in the visit lists.
      These functions silently add the mp of their arg in the mp list *)
-  val add_ind : mutual_inductive -> unit
-  val add_con : constant -> unit
   val add_ref : global_reference -> unit
   val add_decl_deps : ml_decl -> unit
   val add_spec_deps : ml_spec -> unit
@@ -84,9 +90,6 @@ module type VISIT = sig
 end
 
 module Visit : VISIT = struct
-  (* What used to be in a single KNset should now be split into a KNset
-     (for inductives and modules names) and a Cset_env for constants
-     (and still the remaining MPset) *)
   type must_visit =
       { mutable ind : KNset.t; mutable con : KNset.t;
 	mutable mp : MPset.t; mutable mp_all : MPset.t }
@@ -122,6 +125,15 @@ module Visit : VISIT = struct
   let add_spec_deps = spec_iter_references add_ref add_ref add_ref
 end
 
+let add_field_label mp = function
+  | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab))
+  | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0))
+  | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab))
+
+let rec add_labels mp = function
+  | MoreFunctor (_,_,m) -> add_labels mp m
+  | NoFunctor sign -> List.iter (add_field_label mp) sign
+
 exception Impossible
 
 let check_arity env cb =
@@ -131,31 +143,31 @@ let check_arity env cb =
 let check_fix env cb i =
   match cb.const_body with
     | Def lbody ->
-	(match kind_of_term (Declarations.force lbody) with
-	  | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
-	  | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
+	(match kind_of_term (Mod_subst.force_constr lbody) with
+	  | Fix ((_,j),recd) when Int.equal i j -> check_arity env cb; (true,recd)
+	  | CoFix (j,recd) when Int.equal i j -> check_arity env cb; (false,recd)
 	  | _ -> raise Impossible)
     | Undef _ | OpaqueDef _ -> raise Impossible
 
 let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) =
-  na1 = na2 &&
-  array_equal eq_constr ca1 ca2 &&
-  array_equal eq_constr ta1 ta2
+  Array.equal Name.equal na1 na2 &&
+  Array.equal eq_constr ca1 ca2 &&
+  Array.equal eq_constr ta1 ta2
 
 let factor_fix env l cb msb =
   let _,recd as check = check_fix env cb 0 in
   let n = Array.length (let fi,_,_ = recd in fi) in
-  if n = 1 then [|l|], recd, msb
+  if Int.equal n 1 then [|l|], recd, msb
   else begin
     if List.length msb < n-1 then raise Impossible;
-    let msb', msb'' = list_chop (n-1) msb in
+    let msb', msb'' = List.chop (n-1) msb in
     let labels = Array.make n l in
-    list_iter_i
+    List.iteri
       (fun j ->
 	 function
 	   | (l,SFBconst cb') ->
 	       let check' = check_fix env cb' (j+1) in
-	       if not (fst check = fst check' &&
+	       if not ((fst check : bool) == (fst check') &&
 		   prec_declaration_equal (snd check) (snd check'))
 	       then raise Impossible;
 	       labels.(j+1) <- l;
@@ -163,113 +175,102 @@ let factor_fix env l cb msb =
     labels, recd, msb''
   end
 
-(** Expanding a [struct_expr_body] into a version without abbreviations
+(** Expanding a [module_alg_expr] into a version without abbreviations
     or functor applications. This is done via a detour to entries
     (hack proposed by Elie)
 *)
 
-let rec seb2mse = function
-  | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s')
-  | SEBident mp -> Entries.MSEident mp
-  | _ -> failwith "seb2mse: received a non-atomic seb"
-
-let expand_seb env mp seb =
-  let seb,_,_,_ =
-    let inl = Some (Flags.get_inline_level()) in
-    Mod_typing.translate_struct_module_entry env mp inl (seb2mse seb)
-  in seb
-
-(** When possible, we use the nicer, shorter, algebraic type structures
-    instead of the expanded ones. *)
-
-let my_type_of_mb mb =
-  let m0 = mb.mod_type in
-  match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0
-
-let my_type_of_mtb mtb =
-  let m0 = mtb.typ_expr in
-  match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0
+let expand_mexpr env mp me =
+  let inl = Some (Flags.get_inline_level()) in
+  let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in
+  sign
 
 (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
     To check with Elie. *)
 
-let rec msid_of_seb = function
-  | SEBident mp -> mp
-  | SEBwith (seb,_) -> msid_of_seb seb
+let rec mp_of_mexpr = function
+  | MEident mp -> mp
+  | MEwith (seb,_) -> mp_of_mexpr seb
   | _ -> assert false
 
-let env_for_mtb_with_def env mp seb idl =
-  let sig_b = match seb with
-    | SEBstruct(sig_b) -> sig_b
-    | _ -> assert false
-  in
-  let l = label_of_id (List.hd idl) in
-  let spot = function (l',SFBconst _) -> l = l' | _ -> false in
-  let before = fst (list_split_when spot sig_b) in
-  Modops.add_signature mp before empty_delta_resolver env
+let env_for_mtb_with_def env mp me idl =
+  let struc = Modops.destr_nofunctor me in
+  let l = Label.of_id (List.hd idl) in
+  let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in
+  let before = fst (List.split_when spot struc) in
+  Modops.add_structure mp before empty_delta_resolver env
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
    to specifications. *)
 
-let rec extract_sfb_spec env mp = function
+let rec extract_structure_spec env mp = function
   | [] -> []
   | (l,SFBconst cb) :: msig ->
-      let kn = make_con mp empty_dirpath l in
+      let kn = Constant.make2 mp l in
       let s = extract_constant_spec env kn cb in
-      let specs = extract_sfb_spec env mp msig in
+      let specs = extract_structure_spec env mp msig in
       if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
   | (l,SFBmind _) :: msig ->
-      let mind = make_mind mp empty_dirpath l in
+      let mind = MutInd.make2 mp l in
       let s = Sind (mind, extract_inductive env mind) in
-      let specs = extract_sfb_spec env mp msig in
+      let specs = extract_structure_spec env mp msig in
       if logical_spec s then specs
       else begin Visit.add_spec_deps s; (l,Spec s) :: specs end
   | (l,SFBmodule mb) :: msig ->
-      let specs = extract_sfb_spec env mp msig in
-      let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in
+      let specs = extract_structure_spec env mp msig in
+      let spec = extract_mbody_spec env mb.mod_mp mb in
       (l,Smodule spec) :: specs
   | (l,SFBmodtype mtb) :: msig ->
-      let specs = extract_sfb_spec env mp msig in
-      let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in
+      let specs = extract_structure_spec env mp msig in
+      let spec = extract_mbody_spec env mtb.mod_mp mtb in
       (l,Smodtype spec) :: specs
 
-(* From [struct_expr_body] to specifications *)
+(* From [module_expression] to specifications *)
 
-(* Invariant: the [seb] given to [extract_seb_spec] should either come
+(* Invariant: the [me] given to [extract_mexpr_spec] should either come
    from a [mod_type] or [type_expr] field, or their [_alg] counterparts.
-   This way, any encountered [SEBident] should be a true module type.
+   This way, any encountered [MEident] should be a true module type.
 *)
 
-and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
-  | SEBident mp -> Visit.add_mp_all mp; MTident mp
-  | SEBwith(seb',With_definition_body(idl,cb))->
-      let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in
-      let mt = extract_seb_spec env mp1 (seb,seb') in
-      (match extract_with_type env' cb with (* cb peut contenir des kn  *)
+and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with
+  | MEident mp -> Visit.add_mp_all mp; MTident mp
+  | MEwith(me',WithDef(idl,c))->
+      let env' = env_for_mtb_with_def env (mp_of_mexpr me') me_struct idl in
+      let mt = extract_mexpr_spec env mp1 (me_struct,me') in
+      (match extract_with_type env' c with (* cb may contain some kn *)
 	 | None -> mt
 	 | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
-  | SEBwith(seb',With_module_body(idl,mp))->
+  | MEwith(me',WithMod(idl,mp))->
       Visit.add_mp_all mp;
-      MTwith(extract_seb_spec env mp1 (seb,seb'),
-	     ML_With_module(idl,mp))
-  | SEBfunctor (mbid, mtb, seb_alg') ->
-      let seb' = match seb with
-	| SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb'
+      MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp))
+  | MEapply _ -> extract_msignature_spec env mp1 me_struct
+
+and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with
+  | MoreFunctor (mbid, mtb, me_alg') ->
+      let me_struct' = match me_struct with
+	| MoreFunctor (mbid',_,me') when MBId.equal mbid' mbid -> me'
 	| _ -> assert false
       in
       let mp = MPbound mbid in
-      let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in
-      MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb),
-		extract_seb_spec env' mp1 (seb',seb_alg'))
-  | SEBstruct (msig) ->
-      let env' = Modops.add_signature mp1 msig empty_delta_resolver env in
-      MTsig (mp1, extract_sfb_spec env' mp1 msig)
-  | SEBapply _ ->
-      if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb)
-      else assert false
-
+      let env' = Modops.add_module_type mp mtb env in
+      MTfunsig (mbid, extract_mbody_spec env mp mtb,
+		extract_mexpression_spec env' mp1 (me_struct',me_alg'))
+  | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m)
+
+and extract_msignature_spec env mp1 = function
+  | NoFunctor struc ->
+      let env' = Modops.add_structure mp1 struc empty_delta_resolver env in
+      MTsig (mp1, extract_structure_spec env' mp1 struc)
+  | MoreFunctor (mbid, mtb, me) ->
+      let mp = MPbound mbid in
+      let env' = Modops.add_module_type mp mtb env in
+      MTfunsig (mbid, extract_mbody_spec env mp mtb,
+		extract_msignature_spec env' mp1 me)
 
+and extract_mbody_spec env mp mb = match mb.mod_type_alg with
+  | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty)
+  | None -> extract_msignature_spec env mp mb.mod_type
 
 (* From a [structure_body] (i.e. a list of [structure_field_body])
    to implementations.
@@ -278,88 +279,117 @@ and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
    important: last to first ensures correct dependencies.
 *)
 
-let rec extract_sfb env mp all = function
+let rec extract_structure env mp ~all = function
   | [] -> []
-  | (l,SFBconst cb) :: msb ->
+  | (l,SFBconst cb) :: struc ->
       (try
-	 let vl,recd,msb = factor_fix env l cb msb in
-	 let vc = Array.map (make_con mp empty_dirpath) vl in
-	 let ms = extract_sfb env mp all msb in
-	 let b = array_exists Visit.needed_con vc in
+	 let vl,recd,struc = factor_fix env l cb struc in
+	 let vc = Array.map (Constant.make2 mp) vl in
+	 let ms = extract_structure env mp ~all struc in
+	 let b = Array.exists Visit.needed_con vc in
 	 if all || b then
 	   let d = extract_fixpoint env vc recd in
 	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms
        with Impossible ->
-	 let ms = extract_sfb env mp all msb in
-	 let c = make_con mp empty_dirpath l in
+	 let ms = extract_structure env mp ~all struc in
+	 let c = Constant.make2 mp l in
 	 let b = Visit.needed_con c in
 	 if all || b then
 	   let d = extract_constant env c cb in
 	   if (not b) && (logical_decl d) then ms
 	   else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
 	 else ms)
-  | (l,SFBmind mib) :: msb ->
-      let ms = extract_sfb env mp all msb in
-      let mind = make_mind mp empty_dirpath l in
+  | (l,SFBmind mib) :: struc ->
+      let ms = extract_structure env mp ~all struc in
+      let mind = MutInd.make2 mp l in
       let b = Visit.needed_ind mind in
       if all || b then
 	let d = Dind (mind, extract_inductive env mind) in
 	if (not b) && (logical_decl d) then ms
 	else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
       else ms
-  | (l,SFBmodule mb) :: msb ->
-      let ms = extract_sfb env mp all msb in
+  | (l,SFBmodule mb) :: struc ->
+      let ms = extract_structure env mp ~all struc in
       let mp = MPdot (mp,l) in
-      if all || Visit.needed_mp mp then
-	(l,SEmodule (extract_module env mp true mb)) :: ms
+      let all' = all || Visit.needed_mp_all mp in
+      if all' || Visit.needed_mp mp then
+	(l,SEmodule (extract_module env mp ~all:all' mb)) :: ms
       else ms
-  | (l,SFBmodtype mtb) :: msb ->
-      let ms = extract_sfb env mp all msb in
+  | (l,SFBmodtype mtb) :: struc ->
+      let ms = extract_structure env mp ~all struc in
       let mp = MPdot (mp,l) in
-       if all || Visit.needed_mp mp then
-	(l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms
+      if all || Visit.needed_mp mp then
+        (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms
       else ms
 
-(* From [struct_expr_body] to implementations *)
+(* From [module_expr] and [module_expression] to implementations *)
 
-and extract_seb env mp all = function
-  | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml ->
-      (* in Haskell/Scheme, we expand everything *)
-      extract_seb env mp all (expand_seb env mp seb)
-  | SEBident mp ->
+and extract_mexpr env mp = function
+  | MEwith _ -> assert false (* no 'with' syntax for modules *)
+  | me when lang () != Ocaml ->
+      (* In Haskell/Scheme, we expand everything.
+         For now, we also extract everything, dead code will be removed later
+         (see [Modutil.optimize_struct]. *)
+      extract_msignature env mp ~all:true (expand_mexpr env mp me)
+  | MEident mp ->
       if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false;
-      Visit.add_mp_all mp; MEident mp
-  | SEBapply (meb, meb',_) ->
-      MEapply (extract_seb env mp true meb,
-	       extract_seb env mp true meb')
-  | SEBfunctor (mbid, mtb, meb) ->
+      Visit.add_mp_all mp; Miniml.MEident mp
+  | MEapply (me, arg) ->
+      Miniml.MEapply (extract_mexpr env mp me,
+	              extract_mexpr env mp (MEident arg))
+
+and extract_mexpression env mp = function
+  | NoFunctor me -> extract_mexpr env mp me
+  | MoreFunctor (mbid, mtb, me) ->
+      let mp1 = MPbound mbid in
+      let env' = Modops.add_module_type mp1 mtb	env in
+      Miniml.MEfunctor
+        (mbid,
+         extract_mbody_spec env mp1 mtb,
+	 extract_mexpression env' mp me)
+
+and extract_msignature env mp ~all = function
+  | NoFunctor struc ->
+      let env' = Modops.add_structure mp struc empty_delta_resolver env in
+      Miniml.MEstruct (mp,extract_structure env' mp ~all struc)
+  | MoreFunctor (mbid, mtb, me) ->
       let mp1 = MPbound mbid in
-      let env' = Modops.add_module (Modops.module_body_of_type  mp1 mtb)
-	env  in
-      MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb),
-		 extract_seb env' mp true meb)
-  | SEBstruct (msb) ->
-      let env' = Modops.add_signature mp msb empty_delta_resolver env in
-      MEstruct (mp,extract_sfb env' mp all msb)
-  | SEBwith (_,_) -> anomaly "Not available yet"
-
-and extract_module env mp all mb =
+      let env' = Modops.add_module_type mp1 mtb	env in
+      Miniml.MEfunctor
+        (mbid,
+         extract_mbody_spec env mp1 mtb,
+	 extract_msignature env' mp ~all me)
+
+and extract_module env mp ~all mb =
   (* A module has an empty [mod_expr] when :
      - it is a module variable (for instance X inside a Module F [X:SIG])
      - it is a module assumption (Declare Module).
      Since we look at modules from outside, we shouldn't have variables.
      But a Declare Module at toplevel seems legal (cf #2525). For the
      moment we don't support this situation. *)
-  match mb.mod_expr with
-    | None -> error_no_module_expr mp
-    | Some me ->
-      { ml_mod_expr = extract_seb env mp all me;
-	ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) }
-
-
-let unpack = function MEstruct (_,sel) -> sel | _ -> assert false
+  let impl = match mb.mod_expr with
+    | Abstract -> error_no_module_expr mp
+    | Algebraic me -> extract_mexpression env mp me
+    | Struct sign ->
+      (* This module has a signature, otherwise it would be FullStruct.
+         We extract just the elements required by this signature. *)
+      let () = add_labels mp mb.mod_type in
+      extract_msignature env mp ~all:false sign
+    | FullStruct -> extract_msignature env mp ~all mb.mod_type
+  in
+  (* Slight optimization: for modules without explicit signatures
+     ([FullStruct] case), we build the type out of the extracted
+     implementation *)
+  let typ = match mb.mod_expr with
+    | FullStruct ->
+      assert (Option.is_empty mb.mod_type_alg);
+      mtyp_of_mexpr impl
+    | _ -> extract_mbody_spec env mp mb
+  in
+  { ml_mod_expr = impl;
+    ml_mod_type = typ }
 
 let mono_environment refs mpl =
   Visit.reset ();
@@ -368,7 +398,8 @@ let mono_environment refs mpl =
   let env = Global.env () in
   let l = List.rev (environment_until None) in
   List.rev_map
-    (fun (mp,m) -> mp, unpack (extract_seb env mp (Visit.needed_mp_all mp) m))
+    (fun (mp,struc) ->
+      mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc)
     l
 
 (**************************************)
@@ -383,7 +414,7 @@ let descr () = match lang () with
 (* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli"
    Works similarly for the other languages. *)
 
-let default_id = id_of_string "Main"
+let default_id = Id.of_string "Main"
 
 let mono_filename f =
   let d = descr () in
@@ -396,10 +427,10 @@ let mono_filename f =
 	  else f
 	in
 	let id =
-	  if lang () <> Haskell then default_id
+	  if lang () != Haskell then default_id
 	  else
-            try id_of_string (Filename.basename f)
-	    with e when Errors.noncritical e ->
+            try Id.of_string (Filename.basename f)
+	    with UserError _ ->
               error "Extraction: provided filename is not a valid identifier"
 	in
 	Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id
@@ -409,7 +440,7 @@ let mono_filename f =
 let module_filename mp =
   let f = file_of_modfile mp in
   let d = descr () in
-  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f
+  Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, Id.of_string f
 
 (*s Extraction of one decl to stdout. *)
 
@@ -420,8 +451,9 @@ let print_one_decl struc mp decl =
   ignore (d.pp_struct struc);
   set_phase Impl;
   push_visible mp [];
-  msgnl (d.pp_decl decl);
-  pop_visible ()
+  let ans = d.pp_decl decl in
+  pop_visible ();
+  ans
 
 (*s Extraction of a ml struct to a file. *)
 
@@ -449,31 +481,39 @@ let formatter dry file =
       (* note: max_indent should be < margin above, otherwise it's ignored *)
   ft
 
+let get_comment () =
+  let s = file_comment () in
+  if String.is_empty s then None
+  else
+    let split_comment = Str.split (Str.regexp "[ \t\n]+") s in
+    Some (prlist_with_sep spc str split_comment)
+
 let print_structure_to_file (fn,si,mo) dry struc =
   Buffer.clear buf;
   let d = descr () in
   reset_renaming_tables AllButExternal;
   let unsafe_needs = {
-    mldummy = struct_ast_search ((=) MLdummy) struc;
+    mldummy = struct_ast_search ((==) MLdummy) struc;
     tdummy = struct_type_search Mlutil.isDummy struc;
-    tunknown = struct_type_search ((=) Tunknown) struc;
+    tunknown = struct_type_search ((==) Tunknown) struc;
     magic =
-      if lang () <> Haskell then false
+      if lang () != Haskell then false
       else struct_ast_search (function MLmagic _ -> true | _ -> false) struc }
   in
   (* First, a dry run, for computing objects to rename or duplicate *)
   set_phase Pre;
   let devnull = formatter true None in
-  msg_with devnull (d.pp_struct struc);
+  pp_with devnull (d.pp_struct struc);
   let opened = opened_libraries () in
   (* Print the implementation *)
   let cout = if dry then None else Option.map open_out fn in
   let ft = formatter dry cout in
+  let comment = get_comment () in
   begin try
     (* The real printing of the implementation *)
     set_phase Impl;
-    msg_with ft (d.preamble mo opened unsafe_needs);
-    msg_with ft (d.pp_struct struc);
+    pp_with ft (d.preamble mo comment opened unsafe_needs);
+    pp_with ft (d.pp_struct struc);
     Option.iter close_out cout;
   with reraise ->
     Option.iter close_out cout; raise reraise
@@ -486,8 +526,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
        let ft = formatter false (Some cout) in
        begin try
 	 set_phase Intf;
-	 msg_with ft (d.sig_preamble mo opened unsafe_needs);
-	 msg_with ft (d.pp_sig (signature_of_structure struc));
+	 pp_with ft (d.sig_preamble mo comment opened unsafe_needs);
+	 pp_with ft (d.pp_sig (signature_of_structure struc));
 	 close_out cout;
        with reraise ->
 	 close_out cout; raise reraise
@@ -495,8 +535,8 @@ let print_structure_to_file (fn,si,mo) dry struc =
        info_file si)
     (if dry then None else si);
   (* Print the buffer content via Coq standard formatter (ok with coqide). *)
-  if Buffer.length buf <> 0 then begin
-    Pp.message (Buffer.contents buf);
+  if not (Int.equal (Buffer.length buf) 0) then begin
+    Pp.msg_info (str (Buffer.contents buf));
     Buffer.reset buf
   end
 
@@ -515,7 +555,7 @@ let init modular library =
   set_modular modular;
   set_library library;
   reset ();
-  if modular && lang () = Scheme then error_scheme ()
+  if modular && lang () == Scheme then error_scheme ()
 
 let warns () =
   warning_opaques (access_opaque ());
@@ -531,7 +571,7 @@ let rec locate_ref = function
       let mpo = try Some (Nametab.locate_module q) with Not_found -> None
       and ro =
         try Some (Smartlocate.global_with_alias r)
-        with e when Errors.noncritical e -> None
+        with Nametab.GlobalizationError _ | UserError _ -> None
       in
       match mpo, ro with
 	| None, None -> Nametab.error_global_not_found q
@@ -576,7 +616,7 @@ let separate_extraction lr =
     is \verb!Extraction! [qualid]. *)
 
 let simple_extraction r =
-  Vernacentries.dump_global (Genarg.AN r);
+  Vernacentries.dump_global (Misctypes.AN r);
   match locate_ref [r] with
   | ([], [mp]) as p -> full_extr None p
   | [r],[] ->
@@ -584,9 +624,13 @@ let simple_extraction r =
       let struc = optimize_struct ([r],[]) (mono_environment [r] []) in
       let d = get_decl_in_structure r struc in
       warns ();
-      if is_custom r then msgnl (str "(** User defined extraction *)");
-      print_one_decl struc (modpath_of_r r) d;
-      reset ()
+      let flag =
+        if is_custom r then str "(** User defined extraction *)" ++ fnl()
+        else mt ()
+      in
+      let ans = flag ++ print_one_decl struc (modpath_of_r r) d in
+      reset ();
+      Pp.msg_info ans
   | _ -> assert false
 
 
@@ -602,9 +646,9 @@ let extraction_library is_rec m =
   Visit.add_mp_all (MPfile dir_m);
   let env = Global.env () in
   let l = List.rev (environment_until (Some dir_m)) in
-  let select l (mp,meb) =
+  let select l (mp,struc) =
     if Visit.needed_mp mp
-    then (mp, unpack (extract_seb env mp true meb)) :: l
+    then (mp, extract_structure env mp true struc) :: l
     else l
   in
   let struc = List.fold_left select [] l in
@@ -612,9 +656,22 @@ let extraction_library is_rec m =
   warns ();
   let print = function
     | (MPfile dir as mp, sel) as e ->
-	let dry = not is_rec && dir <> dir_m in
+	let dry = not is_rec && not (DirPath.equal dir dir_m) in
 	print_structure_to_file (module_filename mp) dry [e]
     | _ -> assert false
   in
   List.iter print struc;
   reset ()
+
+let structure_for_compute c =
+  init false false;
+  let env = Global.env () in
+  let ast, mlt = Extraction.extract_constr env c in
+  let ast = Mlutil.normalize ast in
+  let refs = ref Refset.empty in
+  let add_ref r = refs := Refset.add r !refs in
+  let () = ast_iter_references add_ref add_ref add_ref ast in
+  let refs = Refset.elements !refs in
+  let struc = optimize_struct (refs,[]) (mono_environment refs []) in
+  let flatstruc = List.map snd (List.flatten (List.map snd struc)) in
+  flatstruc, ast, mlt
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 31f5a620..e5fe76f5 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.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        *)
@@ -10,11 +10,12 @@
 
 open Names
 open Libnames
+open Globnames
 
 val simple_extraction : reference -> unit
 val full_extraction : string option -> reference list -> unit
 val separate_extraction : reference list -> unit
-val extraction_library : bool -> identifier -> unit
+val extraction_library : bool -> Id.t -> unit
 
 (* For debug / external output via coqtop.byte + Drop : *)
 
@@ -24,4 +25,10 @@ val mono_environment :
 (* Used by the Relation Extraction plugin *)
 
 val print_one_decl :
-  Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit
+  Miniml.ml_structure -> module_path -> Miniml.ml_decl -> Pp.std_ppcmds
+
+(* Used by Extraction Compute *)
+
+val structure_for_compute :
+  Term.constr ->
+    Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index a5b1e3c6..080512b2 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.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        *)
@@ -10,7 +10,10 @@
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Declarations
+open Declareops
 open Environ
 open Reduction
 open Reductionops
@@ -19,9 +22,7 @@ open Termops
 open Inductiveops
 open Recordops
 open Namegen
-open Summary
-open Libnames
-open Nametab
+open Globnames
 open Miniml
 open Table
 open Mlutil
@@ -36,13 +37,13 @@ let none = Evd.empty
 
 let type_of env c =
   try
-    let polyprop = (lang() = Haskell) in
+    let polyprop = (lang() == Haskell) in
     Retyping.get_type_of ~polyprop env none (strip_outer_cast c)
   with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
 
 let sort_of env c =
   try
-    let polyprop = (lang() = Haskell) in
+    let polyprop = (lang() == Haskell) in
     Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
   with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
 
@@ -55,8 +56,8 @@ let sort_of env c =
      More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with
      [s = Set], [Prop] or [Type]
    \item [Default] denotes the other cases. It may be inexact after
-     instanciation. For example [(X:Type)X] is [Default] and may give [Set]
-     after instanciation, which is rather [TypeScheme]
+     instantiation. For example [(X:Type)X] is [Default] and may give [Set]
+     after instantiation, which is rather [TypeScheme]
    \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
    \item [Info] is the opposite. The same example [(X:Type)X] shows
      that an [Info] term might in fact be [Logic] later on.
@@ -71,17 +72,19 @@ type flag = info * scheme
 (*s [flag_of_type] transforms a type [t] into a [flag].
   Really important function. *)
 
-let rec flag_of_type env t =
+let rec flag_of_type env t : flag =
   let t = whd_betadeltaiota env none t in
   match kind_of_term t with
     | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
-    | Sort (Prop Null) -> (Logic,TypeScheme)
+    | Sort s when Sorts.is_prop s -> (Logic,TypeScheme)
     | Sort _ -> (Info,TypeScheme)
-    | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
+    | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default)
 
 (*s Two particular cases of [flag_of_type]. *)
 
-let is_default env t = (flag_of_type env t = (Info, Default))
+let is_default env t = match flag_of_type env t with
+| (Info, Default) -> true
+| _ -> false
 
 exception NotDefault of kill_reason
 
@@ -91,7 +94,9 @@ let check_default env t =
     | Logic,_ -> raise (NotDefault Kother)
     | _ -> ()
 
-let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
+let is_info_scheme env t = match flag_of_type env t with
+| (Info, TypeScheme) -> true
+| _ -> false
 
 (*s [type_sign] gernerates a signature aimed at treating a type application. *)
 
@@ -109,16 +114,31 @@ let rec type_scheme_nb_args env c =
 	if is_info_scheme env t then n+1 else n
     | _ -> 0
 
-let _ = register_type_scheme_nb_args type_scheme_nb_args
+let _ = Hook.set type_scheme_nb_args_hook type_scheme_nb_args
 
 (*s [type_sign_vl] does the same, plus a type var list. *)
 
+(* When generating type variables, we avoid any ' in their names
+   (otherwise this may cause a lexer conflict in ocaml with 'a').
+   We also get rid of unicode characters. Anyway, since type variables
+   are local, the created name is just a matter of taste...
+   See also Bug #3227 *)
+
+let make_typvar n vl =
+  let id = id_of_name n in
+  let id' =
+    let s = Id.to_string id in
+    if not (String.contains s '\'') && Unicode.is_basic_ascii s then id
+    else id_of_name Anonymous
+  in
+  next_ident_away id' vl
+
 let rec type_sign_vl env c =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) ->
 	let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
 	if not (is_info_scheme env t) then Kill Kother::s, vl
-	else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
+	else Keep::s, (make_typvar n vl) :: vl
     | _ -> [],[]
 
 let rec nb_default_params env c =
@@ -136,7 +156,8 @@ let sign_with_implicits r s nb_params =
     | [] -> []
     | sign::s ->
 	let sign' =
-	  if sign = Keep && List.mem i implicits then Kill Kother else sign
+	  if sign == Keep && Int.List.mem i implicits
+          then Kill Kother else sign
 	in sign' :: add_impl (succ i) s
   in
   add_impl (1+nb_params) s
@@ -145,11 +166,11 @@ let sign_with_implicits r s nb_params =
 
 let rec handle_exn r n fn_name = function
   | MLexn s ->
-      (try Scanf.sscanf s "UNBOUND %d"
+      (try Scanf.sscanf s "UNBOUND %d%!"
 	 (fun i ->
 	    assert ((0 < i) && (i <= n));
 	    MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
-       with e when Errors.noncritical e -> MLexn s)
+       with Scanf.Scan_failure _ | End_of_file -> MLexn s)
   | a -> ast_map (handle_exn r n fn_name) a
 
 (*S Management of type variable contexts. *)
@@ -170,8 +191,8 @@ let db_from_sign s =
   an inductive type (see just below). *)
 
 let rec db_from_ind dbmap i =
-  if i = 0 then []
-  else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
+  if Int.equal i 0 then []
+  else (try Int.Map.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
 
 (*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument
   of a constructor corresponds to the j-th type var of the ML inductive. *)
@@ -185,34 +206,43 @@ let rec db_from_ind dbmap i =
 
 let parse_ind_args si args relmax =
   let rec parse i j = function
-    | [] -> Intmap.empty
+    | [] -> Int.Map.empty
     | Kill _ :: s -> parse (i+1) j s
     | Keep :: s ->
       (match kind_of_term args.(i-1) with
-	 | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
+	 | Rel k -> Int.Map.add (relmax+1-k) j (parse (i+1) (j+1) s)
 	 | _ -> parse (i+1) (j+1) s)
   in parse 1 1 si
 
 let oib_equal o1 o2 =
-  id_ord o1.mind_typename o2.mind_typename = 0 &&
-  list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt &&
-  begin match o1.mind_arity, o2.mind_arity with
-  | Monomorphic {mind_user_arity=c1; mind_sort=s1},
-    Monomorphic {mind_user_arity=c2; mind_sort=s2} ->
-      eq_constr c1 c2 && s1 = s2
-  | ma1, ma2 -> ma1 = ma2 end &&
-  o1.mind_consnames = o2.mind_consnames
+  Id.equal o1.mind_typename o2.mind_typename &&
+  List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt &&
+    begin
+      match o1.mind_arity, o2.mind_arity with
+      | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} ->
+	eq_constr c1 c2 && Sorts.equal s1 s2
+      | TemplateArity p1, TemplateArity p2 ->
+	let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in
+	  List.equal eq p1.template_param_levels p2.template_param_levels &&
+	    Univ.Universe.equal p1.template_level p2.template_level
+      | _, _ -> false
+    end &&
+    Array.equal Id.equal o1.mind_consnames o2.mind_consnames
+
+let eq_record x y =
+  Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y
 
 let mib_equal m1 m2 =
-  array_equal oib_equal m1.mind_packets m1.mind_packets &&
-  m1.mind_record = m2.mind_record &&
-  m1.mind_finite = m2.mind_finite &&
-  m1.mind_ntypes = m2.mind_ntypes &&
-  list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps &&
-  m1.mind_nparams = m2.mind_nparams &&
-  m1.mind_nparams_rec = m2.mind_nparams_rec &&
-  list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt &&
-  m1.mind_constraints = m2.mind_constraints
+  Array.equal oib_equal m1.mind_packets m1.mind_packets &&
+  eq_record m1.mind_record m2.mind_record &&
+  (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite &&
+  Int.equal m1.mind_ntypes m2.mind_ntypes &&
+  List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps &&
+  Int.equal m1.mind_nparams m2.mind_nparams &&
+  Int.equal m1.mind_nparams_rec m2.mind_nparams_rec &&
+  List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt &&
+  (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *)
+  (* m1.mind_universes = m2.mind_universes *)
 
 (*S Extraction of a type. *)
 
@@ -235,7 +265,7 @@ let rec extract_type env db j c args =
 	   | [] -> assert false (* A lambda cannot be a type. *)
 	   | a :: args -> extract_type env db j (subst1 a d) args)
     | Prod (n,t,d) ->
-	assert (args = []);
+	assert (List.is_empty args);
 	let env' = push_rel_assum (n,t) env in
 	(match flag_of_type env t with
 	   | (Info, Default) ->
@@ -255,10 +285,10 @@ let rec extract_type env db j c args =
 	       (match expand env mld with
 		  | Tdummy d -> Tdummy d
 		  | _ ->
-		      let reason = if lvl=TypeScheme then Ktype else Kother in
+		      let reason = if lvl == TypeScheme then Ktype else Kother in
 		      Tarr (Tdummy reason, mld)))
     | Sort _ -> Tdummy Ktype (* The two logical cases. *)
-    | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
+    | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kother
     | Rel n ->
 	(match lookup_rel n env with
            | (_,Some t,_) -> extract_type env db j (lift n t) args
@@ -266,11 +296,11 @@ let rec extract_type env db j c args =
 	       (* Asks [db] a translation for [n]. *)
 	       if n > List.length db then Tunknown
 	       else let n' = List.nth db (n-1) in
-	       if n' = 0 then Tunknown else Tvar n')
-    | Const kn ->
+	       if Int.equal n' 0 then Tunknown else Tvar n')
+    | Const (kn,u as c) ->
 	let r = ConstRef kn in
 	let cb = lookup_constant kn env in
-	let typ = Typeops.type_of_constant_type env cb.const_type in
+	let typ,_ = Typeops.type_of_constant env c in
 	(match flag_of_type env typ with
 	   | (Logic,_) -> assert false (* Cf. logical cases above *)
 	   | (Info, TypeScheme) ->
@@ -279,23 +309,23 @@ let rec extract_type env db j c args =
 		  | Undef _ | OpaqueDef _ -> mlt
 		  | Def _ when is_custom r -> mlt
 		  | Def lbody ->
-		      let newc = applist (Declarations.force lbody, args) in
+		      let newc = applist (Mod_subst.force_constr lbody, args) in
 		      let mlt' = extract_type env db j newc [] in
 		      (* ML type abbreviations interact badly with Coq *)
 		      (* reduction, so [mlt] and [mlt'] might be different: *)
 		      (* The more precise is [mlt'], extracted after reduction *)
 		      (* The shortest is [mlt], which use abbreviations *)
 		      (* If possible, we take [mlt], otherwise [mlt']. *)
-		      if expand env mlt = expand env mlt' then mlt else mlt')
+		      if eq_ml_type (expand env mlt) (expand env mlt') then mlt else mlt')
 	   | (Info, Default) ->
                (* Not an ML type, for example [(c:forall X, X->X) Type nat] *)
 	       (match cb.const_body with
 		  | Undef _  | OpaqueDef _ -> Tunknown (* Brutal approx ... *)
 		  | Def lbody ->
 		      (* We try to reduce. *)
-		      let newc = applist (Declarations.force lbody, args) in
+		      let newc = applist (Mod_subst.force_constr lbody, args) in
 		      extract_type env db j newc []))
-    | Ind (kn,i) ->
+    | Ind ((kn,i),u) ->
 	let s = (extract_ind env kn).ind_packets.(i).ip_sign in
 	extract_type_app env db (IndRef (kn,i),s) args
     | Case _ | Fix _ | CoFix _ -> Tunknown
@@ -308,7 +338,7 @@ let rec extract_type env db j c args =
 and extract_type_app env db (r,s) args =
   let ml_args =
     List.fold_right
-      (fun (b,c) a -> if b=Keep then
+      (fun (b,c) a -> if b == Keep then
 	 let p = List.length (fst (splay_prod env none (type_of env c))) in
          let db = iterate (fun l -> 0 :: l) p db in
          (extract_type_scheme env db c p) :: a
@@ -326,7 +356,7 @@ and extract_type_app env db (r,s) args =
 (* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
 
 and extract_type_scheme env db c p =
-  if p=0 then extract_type env db 0 c []
+  if Int.equal p 0 then extract_type env db 0 c []
   else
     let c = whd_betaiotazeta Evd.empty c in
     match kind_of_term c with
@@ -335,7 +365,7 @@ and extract_type_scheme env db c p =
       | _ ->
           let rels = fst (splay_prod env none (type_of env c)) in
           let env = push_rels_assum rels env in
-          let eta_args = List.rev_map mkRel (interval 1 p) in
+          let eta_args = List.rev_map mkRel (List.interval 1 p) in
           extract_type env db 0 (lift p c) eta_args
 
 
@@ -356,9 +386,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
        When at toplevel of the monolithic case, we cannot do much
        (cf Vector and bug #2570) *)
     let equiv =
-      if lang () <> Ocaml ||
+      if lang () != Ocaml ||
 	 (not (modular ()) && at_toplevel (mind_modpath kn)) ||
-	 kn_ord (canonical_mind kn) (user_mind kn) = 0
+	 KerName.equal (canonical_mind kn) (user_mind kn)
       then
 	NoEquiv
       else
@@ -375,32 +405,34 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     (* First pass: we store inductive signatures together with *)
     (* their type var list. *)
     let packets =
-      Array.map
-	(fun mip ->
-	   let b = snd (mind_arity mip) <> InProp in
-	   let ar = Inductive.type_of_inductive env (mib,mip) in
-	   let s,v = if b then type_sign_vl env ar else [],[] in
+      Array.mapi
+	(fun i mip ->
+	   let (ind,u), ctx = 
+	     Universes.fresh_inductive_instance env (kn,i) in
+	   let ar = Inductive.type_of_inductive env ((mib,mip),u) in
+	   let info = (fst (flag_of_type env ar) = Info) in
+	   let s,v = if info then type_sign_vl env ar else [],[] in
 	   let t = Array.make (Array.length mip.mind_nf_lc) [] in
 	   { ip_typename = mip.mind_typename;
 	     ip_consnames = mip.mind_consnames;
-	     ip_logical = (not b);
+	     ip_logical = not info;
 	     ip_sign = s;
 	     ip_vars = v;
-	     ip_types = t })
+	     ip_types = t }, u)
 	mib.mind_packets
     in
 
     add_ind kn mib
       {ind_kind = Standard;
        ind_nparams = npar;
-       ind_packets = packets;
+       ind_packets = Array.map fst packets;
        ind_equiv = equiv
       };
     (* Second pass: we extract constructors *)
     for i = 0 to mib.mind_ntypes - 1 do
-      let p = packets.(i) in
+      let p,u = packets.(i) in
       if not p.ip_logical then
-	let types = arities_of_constructors env (kn,i) in
+	let types = arities_of_constructors env ((kn,i),u) in
 	for j = 0 to Array.length types - 1 do
 	  let t = snd (decompose_prod_n npar types.(j)) in
 	  let prods,head = dest_prod epar t in
@@ -420,18 +452,18 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	let ip = (kn, 0) in
 	let r = IndRef ip in
 	if is_custom r then raise (I Standard);
-	if not mib.mind_finite then raise (I Coinductive);
-	if mib.mind_ntypes <> 1 then raise (I Standard);
-	let p = packets.(0) in
+	if mib.mind_finite == Decl_kinds.CoFinite then raise (I Coinductive);
+	if not (Int.equal mib.mind_ntypes 1) then raise (I Standard);
+	let p,u = packets.(0) in
 	if p.ip_logical then raise (I Standard);
-	if Array.length p.ip_types <> 1 then raise (I Standard);
+	if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard);
 	let typ = p.ip_types.(0) in
 	let l = List.filter (fun t -> not (isDummy (expand env t))) typ in
 	if not (keep_singleton ()) &&
-	    List.length l = 1 && not (type_mem_kn kn (List.hd l))
+	    Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l))
 	then raise (I Singleton);
-	if l = [] then raise (I Standard);
-	if not mib.mind_record then raise (I Standard);
+	if List.is_empty l then raise (I Standard);
+	if Option.is_empty mib.mind_record then raise (I Standard);
 	(* Now we're sure it's a record. *)
 	(* First, we find its field names. *)
 	let rec names_prod t = match kind_of_term t with
@@ -441,10 +473,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	  | _ -> []
 	in
 	let field_names =
-	  list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
-	assert (List.length field_names = List.length typ);
+	  List.skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
+	assert (Int.equal (List.length field_names) (List.length typ));
 	let projs = ref Cset.empty in
-	let mp,d,_ = repr_mind kn in
+	let mp = MutInd.modpath kn in
 	let rec select_fields l typs = match l,typs with
 	  | [],[] -> []
 	  | _::l, typ::typs when isDummy (expand env typ) ->
@@ -452,9 +484,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	  | Anonymous::l, typ::typs ->
 	      None :: (select_fields l typs)
 	  | Name id::l, typ::typs ->
-	      let knp = make_con mp d (label_of_id id) in
+	      let knp = Constant.make2 mp (Label.of_id id) in
 	      (* Is it safe to use [id] for projections [foo.id] ? *)
-	      if List.for_all ((=) Keep) (type2signature env typ)
+	      if List.for_all ((==) Keep) (type2signature env typ)
 	      then projs := Cset.add knp !projs;
 	      Some (ConstRef knp) :: (select_fields l typs)
 	  | _ -> assert false
@@ -465,9 +497,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
 	(* If so, we use this information. *)
 	begin try
 	  let n = nb_default_params env
-            (Inductive.type_of_inductive env (mib,mip0))
+            (Inductive.type_of_inductive env ((mib,mip0),u))
 	  in
-	  let check_proj kn = if Cset.mem kn !projs then add_projection n kn in
+	  let check_proj kn = if Cset.mem kn !projs then add_projection n kn ip
+          in
 	  List.iter (Option.iter check_proj) (lookup_projections ip)
 	with Not_found -> ()
 	end;
@@ -476,7 +509,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
     in
     let i = {ind_kind = ind_info;
 	     ind_nparams = npar;
-	     ind_packets = packets;
+	     ind_packets = Array.map fst packets;
 	     ind_equiv = equiv }
     in
     add_ind kn mib i;
@@ -495,7 +528,7 @@ and extract_type_cons env db dbmap c i =
   match kind_of_term (whd_betadeltaiota env none c) with
     | Prod (n,t,d) ->
 	let env' = push_rel_assum (n,t) env in
-	let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
+	let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in
 	let l = extract_type_cons env' db' dbmap d (i+1) in
 	(extract_type env db 0 t []) :: l
     | _ -> []
@@ -511,13 +544,14 @@ and mlt_env env r = match r with
 	   | _ -> None
        with Not_found ->
 	 let cb = Environ.lookup_constant kn env in
-	 let typ = Typeops.type_of_constant_type env cb.const_type in
+	 let typ = Typeops.type_of_constant_type env cb.const_type
+ (* FIXME not sure if we should instantiate univs here *) in
 	 match cb.const_body with
 	   | Undef _ | OpaqueDef _ -> None
 	   | Def l_body ->
 	       (match flag_of_type env typ with
 		  | Info,TypeScheme ->
-		      let body = Declarations.force l_body in
+		      let body = Mod_subst.force_constr l_body in
 		      let s,vl = type_sign_vl env typ in
 		      let db = db_from_sign s in
 		      let t = extract_type_scheme env db body (List.length s)
@@ -539,7 +573,7 @@ let record_constant_type env kn opt_typ =
     lookup_type kn
   with Not_found ->
     let typ = match opt_typ with
-      | None -> Typeops.type_of_constant env kn
+      | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type
       | Some typ -> typ
     in let mlt = extract_type env [] 1 typ []
     in let schema = (type_maxvar mlt, mlt)
@@ -594,10 +628,12 @@ let rec extract_term env mle mlt c args =
 	with NotDefault d ->
 	  let mle' = Mlenv.push_std_type mle (Tdummy d) in
 	  ast_pop (extract_term env' mle' mlt c2 args'))
-    | Const kn ->
-	extract_cst_app env mle mlt kn args
-    | Construct cp ->
-	extract_cons_app env mle mlt cp args
+    | Const (kn,u) ->
+	extract_cst_app env mle mlt kn u args
+    | Construct (cp,u) ->
+	extract_cons_app env mle mlt cp u args
+    | Proj (p, c) ->
+        extract_cst_app env mle mlt (Projection.constant p) Univ.Instance.empty (c :: args)
     | Rel n ->
 	(* As soon as the expected [mlt] for the head is known, *)
 	(* we unify it with an fresh copy of the stored type of [Rel n]. *)
@@ -645,14 +681,15 @@ and make_mlargs env e s args typs =
 
 (*s Extraction of a constant applied to arguments. *)
 
-and extract_cst_app env mle mlt kn args =
+and extract_cst_app env mle mlt kn u args =
   (* First, the [ml_schema] of the constant, in expanded version. *)
   let nb,t = record_constant_type env kn None in
   let schema = nb, expand env t in
   (* Can we instantiate types variables for this constant ? *)
   (* In Ocaml, inside the definition of this constant, the answer is no. *)
   let instantiated =
-    if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
+    if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints
+    then var2var' (snd schema)
     else instantiation schema
   in
   (* Then the expected type of this constant. *)
@@ -674,14 +711,14 @@ and extract_cst_app env mle mlt kn args =
   (* The ml arguments, already expunged from known logical ones *)
   let mla = make_mlargs env mle s args metas in
   let mla =
-    if magic1 || lang () <> Ocaml then mla
+    if magic1 || lang () != Ocaml then mla
     else
       try
         (* for better optimisations later, we discard dependent args
            of projections and replace them by fake args that will be
            removed during final pretty-print. *)
-	let l,l' = list_chop (projection_arity (ConstRef kn)) mla in
-	if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
+	let l,l' = List.chop (projection_arity (ConstRef kn)) mla in
+	if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
 	else mla
       with e when Errors.noncritical e -> mla
   in
@@ -689,7 +726,7 @@ and extract_cst_app env mle mlt kn args =
      one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
      accordingly. *)
   let optdummy = match sign_kind s_full with
-    | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy]
+    | UnsafeLogicalSig when lang () != Haskell -> [MLdummy]
     | _ -> []
   in
   (* Different situations depending of the number of arguments: *)
@@ -702,7 +739,7 @@ and extract_cst_app env mle mlt kn args =
     (* Partially applied function with some logical arg missing.
        We complete via eta and expunge logical args. *)
     let ls' = ls-la in
-    let s' = list_skipn la s in
+    let s' = List.skipn la s in
     let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
     let e = anonym_or_dummy_lams (mlapp head mla) s' in
     put_magic_if magic2 (remove_n_lams (List.length optdummy) e)
@@ -717,14 +754,14 @@ and extract_cst_app env mle mlt kn args =
    they are fixed, and thus are not used for the computation.
    \end{itemize} *)
 
-and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u args =
   (* First, we build the type of the constructor, stored in small pieces. *)
   let mi = extract_ind env kn in
   let params_nb = mi.ind_nparams in
   let oi = mi.ind_packets.(i) in
   let nb_tvars = List.length oi.ip_vars
   and types = List.map (expand env) oi.ip_types.(j-1) in
-  let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in
+  let list_tvar = List.map (fun i -> Tvar i) (List.interval 1 nb_tvars) in
   let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
   let type_cons = instantiation (nb_tvars, type_cons) in
   (* Then, the usual variables [s], [ls], [la], ... *)
@@ -734,7 +771,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let la = List.length args in
   assert (la <= ls + params_nb);
   let la' = max 0 (la - params_nb) in
-  let args' = list_lastn la' args in
+  let args' = List.lastn la' args in
   (* Now, we build the expected type of the constructor *)
   let metas = List.map new_meta args' in
   (* If stored and expected types differ, then magic! *)
@@ -742,7 +779,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
   let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
   let magic2 = needs_magic (a, mlt) in
   let head mla =
-    if mi.ind_kind = Singleton then
+    if mi.ind_kind == Singleton then
       put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
     else
       let typeargs = match snd (type_decomp type_cons) with
@@ -759,11 +796,11 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
       (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
   else
     let mla = make_mlargs env mle s args' metas in
-    if la = ls + params_nb
+    if Int.equal la (ls + params_nb)
     then put_magic_if (magic2 && not magic1) (head mla)
     else (* [ params_nb <= la <= ls + params_nb ] *)
       let ls' = params_nb + ls - la in
-      let s' = list_lastn ls' s in
+      let s' = List.lastn ls' s in
       let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
       put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
 
@@ -772,22 +809,22 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
 and extract_case env mle ((kn,i) as ip,c,br) mlt =
   (* [br]: bodies of each branch (in functional form) *)
   (* [ni]: number of arguments without parameters in each branch *)
-  let ni = mis_constr_nargs_env env ip in
+  let ni = constructors_nrealargs_env env ip in
   let br_size = Array.length br in
-  assert (Array.length ni = br_size);
-  if br_size = 0 then begin
+  assert (Int.equal (Array.length ni) br_size);
+  if Int.equal br_size 0 then begin
     add_recursors env kn; (* May have passed unseen if logical ... *)
     MLexn "absurd case"
   end else
     (* [c] has an inductive type, and is not a type scheme type. *)
     let t = type_of env c in
     (* The only non-informative case: [c] is of sort [Prop] *)
-    if (sort_of env t) = InProp then
+    if (sort_of env t) == InProp then
       begin
 	add_recursors env kn; (* May have passed unseen if logical ... *)
 	(* Logical singleton case: *)
 	(* [match c with C i j k -> t] becomes [t'] *)
-	assert (br_size = 1);
+	assert (Int.equal br_size 1);
 	let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
 	let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in
 	let e = extract_maybe_term env mle mlt br.(0) in
@@ -816,13 +853,13 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
 	let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
 	(List.rev ids, Pusual r, e')
       in
-      if mi.ind_kind = Singleton then
+      if mi.ind_kind == Singleton then
 	begin
 	  (* Informative singleton case: *)
 	  (* [match c with C i -> t] becomes [let i = c' in t'] *)
-	  assert (br_size = 1);
+	  assert (Int.equal br_size 1);
 	  let (ids,_,e') = extract_branch 0 in
-	  assert (List.length ids = 1);
+	  assert (Int.equal (List.length ids) 1);
 	  MLletin (tmp_id (List.hd ids),a,e')
 	end
       else
@@ -838,7 +875,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
   let metas = Array.map new_meta fi in
   metas.(i) <- mlt;
   let mle = Array.fold_left Mlenv.push_type mle metas in
-  let ei = array_map2 (extract_maybe_term env mle) metas ci in
+  let ei = Array.map2 (extract_maybe_term env mle) metas ci in
   MLfix (i, Array.map id_of_name fi, ei)
 
 (*S ML declarations. *)
@@ -846,14 +883,14 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
 (* [decomp_lams_eta env c t] finds the number [n] of products in the type [t],
    and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
 
-let rec decomp_lams_eta_n n m env c t =
+let decomp_lams_eta_n n m env c t =
   let rels = fst (splay_prod_n env none n t) in
   let rels = List.map (fun (id,_,c) -> (id,c)) rels in
   let rels',c = decompose_lam c in
   let d = n - m in
   (* we'd better keep rels' as long as possible. *)
-  let rels = (list_firstn d rels) @ rels' in
-  let eta_args = List.rev_map mkRel (interval 1 d) in
+  let rels = (List.firstn d rels) @ rels' in
+  let eta_args = List.rev_map mkRel (List.interval 1 d) in
   rels, applist (lift d c,eta_args)
 
 (* Let's try to identify some situation where extracted code
@@ -864,7 +901,7 @@ let rec gentypvar_ok c = match kind_of_term c with
   | App (c,v) ->
       (* if all arguments are variables, these variables will
 	 disappear after extraction (see [empty_s] below) *)
-      array_for_all isRel v && gentypvar_ok c
+      Array.for_all isRel v && gentypvar_ok c
   | Cast (c,_,_) -> gentypvar_ok c
   | _ -> false
 
@@ -891,26 +928,26 @@ let extract_std_constant env kn body typ =
     and m = nb_lam body in
     if n <= m then decompose_lam_n n body
     else
-      let s,s' = list_chop m s in
-      if List.for_all ((=) Keep) s' &&
-	(lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
+      let s,s' = List.chop m s in
+      if List.for_all ((==) Keep) s' &&
+	(lang () == Haskell || sign_kind s != UnsafeLogicalSig)
       then decompose_lam_n m body
       else decomp_lams_eta_n n m env body typ
   in
   (* Should we do one eta-expansion to avoid non-generalizable '_a ? *)
   let rels, c =
     let n = List.length rels in
-    let s,s' = list_chop n s in
+    let s,s' = List.chop n s in
     let k = sign_kind s in
-    let empty_s = (k = EmptySig || k = SafeLogicalSig) in
-    if lang () = Ocaml && empty_s && not (gentypvar_ok c)
-      && s' <> [] && type_maxvar t <> 0
+    let empty_s = (k == EmptySig || k == SafeLogicalSig) in
+    if lang () == Ocaml && empty_s && not (gentypvar_ok c)
+      && not (List.is_empty s') && not (Int.equal (type_maxvar t) 0)
     then decomp_lams_eta_n (n+1) n env body typ
     else rels,c
   in
   let n = List.length rels in
-  let s = list_firstn n s in
-  let l,l' = list_chop n l in
+  let s = List.firstn n s in
+  let l,l' = List.chop n l in
   let t' = type_recomp (l',t') in
   (* The initial ML environment. *)
   let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
@@ -948,7 +985,7 @@ let extract_fixpoint env vkn (fi,ti,ci) =
   (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
   let sub = List.rev_map mkConst kns in
   for i = 0 to n-1 do
-    if sort_of env ti.(i) <> InProp then begin
+    if sort_of env ti.(i) != InProp then begin
       let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
       terms.(i) <- e;
       types.(i) <- t;
@@ -988,17 +1025,21 @@ let extract_constant env kn cb =
     | (Info,TypeScheme) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_typ_ax ()
-	  | Def c -> mk_typ (force c)
+	  | Def c -> mk_typ (Mod_subst.force_constr c)
 	  | OpaqueDef c ->
 	    add_opaque r;
-	    if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ())
+	    if access_opaque () then
+              mk_typ (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+            else mk_typ_ax ())
     | (Info,Default) ->
         (match cb.const_body with
 	  | Undef _ -> warn_info (); mk_ax ()
-	  | Def c -> mk_def (force c)
+	  | Def c -> mk_def (Mod_subst.force_constr c)
 	  | OpaqueDef c ->
 	    add_opaque r;
-	    if access_opaque () then mk_def (force_opaque c) else mk_ax ())
+	    if access_opaque () then
+              mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c)
+            else mk_ax ())
 
 let extract_constant_spec env kn cb =
   let r = ConstRef kn in
@@ -1012,27 +1053,32 @@ let extract_constant_spec env kn cb =
 	  | Undef _ | OpaqueDef _ -> Stype (r, vl, None)
 	  | Def body ->
 	      let db = db_from_sign s in
-	      let t = extract_type_scheme env db (force body) (List.length s)
+              let body = Mod_subst.force_constr body in
+	      let t = extract_type_scheme env db body (List.length s)
 	      in Stype (r, vl, Some t))
     | (Info, Default) ->
 	let t = snd (record_constant_type env kn (Some typ)) in
 	Sval (r, type_expunge env t)
 
-let extract_with_type env cb =
-  let typ = Typeops.type_of_constant_type env cb.const_type in
+let extract_with_type env c =
+  let typ = type_of env c in
   match flag_of_type env typ with
     | (Info, TypeScheme) ->
 	let s,vl = type_sign_vl env typ in
 	let db = db_from_sign s in
-	let c = match cb.const_body with
-	  | Def body -> force body
-	  (* A "with Definition ..." is necessarily transparent *)
-	  | Undef _ | OpaqueDef _ -> assert false
-	in
 	let t = extract_type_scheme env db c (List.length s) in
 	Some (vl, t)
     | _ -> None
 
+let extract_constr env c =
+  reset_meta_count ();
+  let typ = type_of env c in
+  match flag_of_type env typ with
+    | (_,TypeScheme) -> MLdummy, Tdummy Ktype
+    | (Logic,_) -> MLdummy, Tdummy Kother
+    | (Info,Default) ->
+      let mlt = extract_type env [] 1 typ [] in
+      extract_term env Mlenv.empty mlt c [], mlt
 
 let extract_inductive env kn =
   let ind = extract_ind env kn in
@@ -1043,7 +1089,7 @@ let extract_inductive env kn =
       | [] -> []
       | t::l ->
 	  let l' = filter (succ i) l in
-	  if isDummy (expand env t) || List.mem i implicits then l'
+	  if isDummy (expand env t) || Int.List.mem i implicits then l'
 	  else t::l'
     in filter (1+ind.ind_nparams) l
   in
@@ -1058,9 +1104,9 @@ let logical_decl = function
   | Dterm (_,MLdummy,Tdummy _) -> true
   | Dtype (_,[],Tdummy _) -> true
   | Dfix (_,av,tv) ->
-      (array_for_all ((=) MLdummy) av) &&
-      (array_for_all isDummy tv)
-  | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+      (Array.for_all ((==) MLdummy) av) &&
+      (Array.for_all isDummy tv)
+  | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
 
 (*s Is a [ml_spec] logical ? *)
@@ -1068,5 +1114,5 @@ let logical_decl = function
 let logical_spec = function
   | Stype (_, [], Some (Tdummy _)) -> true
   | Sval (_,Tdummy _) -> true
-  | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+  | Sind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets
   | _ -> false
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index f10f3589..6bd2541b 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.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        *)
@@ -12,20 +12,25 @@ open Names
 open Term
 open Declarations
 open Environ
-open Libnames
 open Miniml
 
 val extract_constant : env -> constant -> constant_body -> ml_decl
 
 val extract_constant_spec : env -> constant -> constant_body -> ml_spec
 
-val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option
+(** For extracting "module ... with ..." declaration *)
+
+val extract_with_type : env -> constr -> ( Id.t list * ml_type ) option
 
 val extract_fixpoint :
   env -> constant array -> (constr, types) prec_declaration -> ml_decl
 
 val extract_inductive : env -> mutual_inductive -> ml_ind
 
+(** For extraction compute *)
+
+val extract_constr : env -> constr -> ml_ast * ml_type
+
 (*s Is a [ml_decl] or a [ml_spec] logical ? *)
 
 val logical_decl : ml_decl -> bool
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index a2b6b14a..3caa558f 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -1,17 +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        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 (* ML names *)
 
-open Vernacexpr
-open Pcoq
 open Genarg
 open Pp
 open Names
@@ -35,7 +33,7 @@ let pr_int_or_id _ _ _ = function
 ARGUMENT EXTEND int_or_id
   TYPED AS int_or_id
   PRINTED BY pr_int_or_id
-| [ preident(id) ] -> [ ArgId (id_of_string id) ]
+| [ preident(id) ] -> [ ArgId (Id.of_string id) ]
 | [ integer(i) ] -> [ ArgInt i ]
 END
 
@@ -53,7 +51,7 @@ END
 
 (* Extraction commands *)
 
-VERNAC COMMAND EXTEND Extraction
+VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY
 (* Extraction in the Coq toplevel *)
 | [ "Extraction" global(x) ] -> [ simple_extraction x ]
 | [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ]
@@ -63,85 +61,85 @@ VERNAC COMMAND EXTEND Extraction
   -> [ full_extraction (Some f) l ]
 END
 
-VERNAC COMMAND EXTEND SeparateExtraction
+VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY
 (* Same, with content splitted in several files *)
 | [ "Separate" "Extraction" ne_global_list(l) ]
   -> [ separate_extraction l ]
 END
 
 (* Modular extraction (one Coq library = one ML module) *)
-VERNAC COMMAND EXTEND ExtractionLibrary
+VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY
 | [ "Extraction" "Library" ident(m) ]
   -> [ extraction_library false m ]
 END
 
-VERNAC COMMAND EXTEND RecursiveExtractionLibrary
+VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY
 | [ "Recursive" "Extraction" "Library" ident(m) ]
   -> [ extraction_library true m ]
 END
 
 (* Target Language *)
-VERNAC COMMAND EXTEND ExtractionLanguage
+VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF
 | [ "Extraction" "Language" language(l) ]
   -> [ extraction_language l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInline
+VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF
 (* Custom inlining directives *)
 | [ "Extraction" "Inline" ne_global_list(l) ]
   -> [ extraction_inline true l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionNoInline
+VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF
 | [ "Extraction" "NoInline" ne_global_list(l) ]
   -> [ extraction_inline false l ]
 END
 
-VERNAC COMMAND EXTEND PrintExtractionInline
+VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Inline" ]
-  -> [ print_extraction_inline () ]
+  -> [ msg_info (print_extraction_inline ()) ]
 END
 
-VERNAC COMMAND EXTEND ResetExtractionInline
+VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF
 | [ "Reset" "Extraction" "Inline" ]
   -> [ reset_extraction_inline () ]
 END
 
-VERNAC COMMAND EXTEND ExtractionImplicit
+VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF
 (* Custom implicit arguments of some csts/inds/constructors *)
 | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ]
   -> [ extraction_implicit r l ]
 END
 
-VERNAC COMMAND EXTEND ExtractionBlacklist
+VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF
 (* Force Extraction to not use some filenames *)
 | [ "Extraction" "Blacklist" ne_ident_list(l) ]
   -> [ extraction_blacklist l ]
 END
 
-VERNAC COMMAND EXTEND PrintExtractionBlacklist
+VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY
 | [ "Print" "Extraction" "Blacklist" ]
-  -> [ print_extraction_blacklist () ]
+  -> [ msg_info (print_extraction_blacklist ()) ]
 END
 
-VERNAC COMMAND EXTEND ResetExtractionBlacklist
+VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF
 | [ "Reset" "Extraction" "Blacklist" ]
   -> [ reset_extraction_blacklist () ]
 END
 
 
 (* Overriding of a Coq object by an ML one *)
-VERNAC COMMAND EXTEND ExtractionConstant
+VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF
 | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
   -> [ extract_constant_inline false x idl y ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInlinedConstant
+VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF
 | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
   -> [ extract_constant_inline true x [] y ]
 END
 
-VERNAC COMMAND EXTEND ExtractionInductive
+VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF
 | [ "Extract" "Inductive" global(x) "=>"
     mlname(id) "[" mlname_list(idl) "]" string_opt(o) ]
   -> [ extract_inductive x id idl o ]
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 4f9c6a71..5e08fef5 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.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        *)
@@ -9,10 +9,11 @@
 (*s Production of Haskell syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
@@ -20,38 +21,47 @@ open Common
 
 (*s Haskell renaming issues. *)
 
-let pr_lower_id id = str (String.uncapitalize (string_of_id id))
-let pr_upper_id id = str (String.capitalize (string_of_id id))
+let pr_lower_id id = str (String.uncapitalize (Id.to_string id))
+let pr_upper_id id = str (String.capitalize (Id.to_string id))
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
   [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
     "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance";
     "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
     "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
-  Idset.empty
+  Id.Set.empty
 
-let preamble mod_name used_modules usf =
+let pp_comment s = str "-- " ++ s ++ fnl ()
+let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}"
+
+let preamble mod_name comment used_modules usf =
   let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n")
   in
   (if not usf.magic then mt ()
    else
-     str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++
-     str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n")
+     str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++
+     str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}")
+  ++ fnl () ++ fnl ()
+  ++
+  (match comment with
+    | None -> mt ()
+    | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ())
   ++
   str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++
   str "import qualified Prelude" ++ fnl () ++
   prlist pp_import used_modules ++ fnl () ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if not usf.magic then mt ()
    else str "\
-\nunsafeCoerce :: a -> b\
 \n#ifdef __GLASGOW_HASKELL__\
 \nimport qualified GHC.Base\
+\nunsafeCoerce :: a -> b\
 \nunsafeCoerce = GHC.Base.unsafeCoerce#\
 \n#else\
 \n-- HUGS\
 \nimport qualified IOExts\
+\nunsafeCoerce :: a -> b\
 \nunsafeCoerce = IOExts.unsafeCoerce\
 \n#endif" ++ fnl2 ())
   ++
@@ -74,19 +84,15 @@ let pp_global k r =
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let kn_sig =
-  let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in
-  make_mind specif empty_dirpath (mk_label "sig")
-
 let rec pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ -> assert false
     | Tvar i ->
       (try pr_id (List.nth vl (pred i))
-       with e when Errors.noncritical e -> (str "a" ++ int i))
+       with Failure _ -> (str "a" ++ int i))
     | Tglob (r,[]) -> pp_global Type r
     | Tglob (IndRef(kn,0),l)
-	when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" ->
+	when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") ->
 	  pp_type true vl (List.hd l)
     | Tglob (r,l) ->
 	  pp_par par
@@ -140,7 +146,7 @@ let rec pp_expr par env args =
     | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (_,r,a) as c ->
-        assert (args=[]);
+        assert (List.is_empty args);
         begin match a with
 	  | _ when is_native_char c -> pp_native_char c
 	  | [] -> pp_global Cons r
@@ -151,13 +157,13 @@ let rec pp_expr par env args =
 			prlist_with_sep spc (pp_expr true env []) a)
 	end
     | MLtuple l ->
-        assert (args=[]);
+        assert (List.is_empty args);
         pp_boxed_tuple (pp_expr true env []) l
     | MLcase (_,t, pv) when is_custom_match pv ->
         if not (is_regular_match pv) then
 	  error "Cannot mix yet user-given match and general patterns.";
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
@@ -185,7 +191,7 @@ let rec pp_expr par env args =
 
 and pp_cons_pat par r ppl =
   pp_par par
-    (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl)
+    (pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ prlist_with_sep spc identity ppl)
 
 and pp_gen_pat par ids env = function
   | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l)
@@ -205,7 +211,7 @@ and pp_pat env pv =
   prvecti
     (fun i x ->
        pp_one_pat env pv.(i) ++
-       if i = Array.length pv - 1 then str "}" else
+       if Int.equal i (Array.length pv - 1) then str "}" else
 	 (str ";" ++ fnl ()))
     pv
 
@@ -218,7 +224,7 @@ and pp_fix par env i (ids,bl) args =
        (v 1 (str "let {" ++ fnl () ++
 	     prvect_with_sep (fun () -> str ";" ++ fnl ())
 	       (fun (fi,ti) -> pp_function env (pr_id fi) ti)
-	       (array_map2 (fun a b -> a,b) ids bl) ++
+	       (Array.map2 (fun a b -> a,b) ids bl) ++
 	     str "}") ++
         fnl () ++ str "in " ++ pp_apply (pr_id ids.(i)) false args))
 
@@ -231,8 +237,6 @@ and pp_function env f t =
 
 (*s Pretty-printing of inductive types declaration. *)
 
-let pp_comment s = str "-- " ++ s ++ fnl ()
-
 let pp_logical_ind packet =
   pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
   pp_comment (str "with constructors : " ++
@@ -243,7 +247,7 @@ let pp_singleton kn packet =
   let l' = List.rev l in
   hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++
 	 prlist_with_sep spc pr_id l ++
-	 (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
+	 (if not (List.is_empty l) then str " " else mt ()) ++ str "=" ++ spc () ++
 	 pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
 	 pp_comment (str "singleton inductive, whose constructor was " ++
 		     pr_id packet.ip_consnames.(0)))
@@ -258,10 +262,10 @@ let pp_one_ind ip pl cv =
       	       	prlist_with_sep
 		  (fun () -> (str " ")) (pp_type true pl) l))
   in
-  str (if Array.length cv = 0 then "type " else "data ") ++
+  str (if Array.is_empty cv then "type " else "data ") ++
   pp_global Type (IndRef ip) ++
   prlist_strict (fun id -> str " " ++ pr_lower_id id) pl ++ str " =" ++
-  if Array.length cv = 0 then str " () -- empty inductive"
+  if Array.is_empty cv then str " () -- empty inductive"
   else
     (fnl () ++ str " " ++
      v 0 (str "  " ++
@@ -286,7 +290,7 @@ let rec pp_ind first kn i ind =
 (*s Pretty-printing of a declaration. *)
 
 let pp_decl = function
-  | Dind (kn,i) when i.ind_kind = Singleton ->
+  | Dind (kn,i) when i.ind_kind == Singleton ->
       pp_singleton kn i.ind_packets.(0) ++ fnl ()
   | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
   | Dtype (r, l, t) ->
@@ -299,7 +303,7 @@ let pp_decl = function
 	    prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s
 	  with Not_found ->
 	    prlist (fun id -> pr_id id ++ str " ") l ++
-	    if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
+	    if t == Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
 	    else str "=" ++ spc () ++ pp_type false l t
 	in
 	hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 ()
@@ -310,7 +314,7 @@ let pp_decl = function
       prvecti
 	(fun i r ->
 	  let void = is_inline_custom r ||
-	    (not (is_custom r) && defs.(i) = MLexn "UNUSED")
+	    (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false)
 	  in
 	  if void then mt ()
 	  else
@@ -359,7 +363,7 @@ let haskell_descr = {
   preamble = preamble;
   pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ());
+  sig_preamble = (fun _ _ _ _ -> mt ());
   pp_sig = (fun _ -> mt ());
   pp_decl = pp_decl;
 }
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
index b00fc42f..99559bce 100644
--- a/plugins/extraction/haskell.mli
+++ b/plugins/extraction/haskell.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/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index fbb1c116..1e491d36 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.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        *)
@@ -9,9 +9,8 @@
 (*s Target language for extraction: a core ML called MiniML. *)
 
 open Pp
-open Util
 open Names
-open Libnames
+open Globnames
 
 (* The [signature] type is used to know how many arguments a CIC
    object expects, and what these arguments will become in the ML
@@ -66,11 +65,11 @@ type inductive_kind =
 *)
 
 type ml_ind_packet = {
-  ip_typename : identifier;
-  ip_consnames : identifier array;
+  ip_typename : Id.t;
+  ip_consnames : Id.t array;
   ip_logical : bool;
   ip_sign : signature;
-  ip_vars : identifier list;
+  ip_vars : Id.t list;
   ip_types : (ml_type list) array
 }
 
@@ -92,8 +91,8 @@ type ml_ind = {
 
 type ml_ident =
   | Dummy
-  | Id of identifier
-  | Tmp of identifier
+  | Id of Id.t
+  | Tmp of Id.t
 
 (** We now store some typing information on constructors
     and cases to avoid type-unsafe optimisations. This will be
@@ -117,7 +116,7 @@ and ml_ast =
   | MLcons   of ml_type * global_reference * ml_ast list
   | MLtuple  of ml_ast list
   | MLcase   of ml_type * ml_ast * ml_branch array
-  | MLfix    of int * identifier array * ml_ast array
+  | MLfix    of int * Id.t array * ml_ast array
   | MLexn    of string
   | MLdummy
   | MLaxiom
@@ -134,13 +133,13 @@ and ml_pattern =
 
 type ml_decl =
   | Dind  of mutual_inductive * ml_ind
-  | Dtype of global_reference * identifier list * ml_type
+  | Dtype of global_reference * Id.t list * ml_type
   | Dterm of global_reference * ml_ast * ml_type
   | Dfix  of global_reference array * ml_ast array * ml_type array
 
 type ml_spec =
   | Sind  of mutual_inductive * ml_ind
-  | Stype of global_reference * identifier list * ml_type option
+  | Stype of global_reference * Id.t list * ml_type option
   | Sval  of global_reference * ml_type
 
 type ml_specif =
@@ -150,15 +149,15 @@ type ml_specif =
 
 and ml_module_type =
   | MTident of module_path
-  | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
+  | MTfunsig of MBId.t * ml_module_type * ml_module_type
   | MTsig of module_path * ml_module_sig
   | MTwith of ml_module_type * ml_with_declaration
 
 and ml_with_declaration =
-  | ML_With_type of identifier list * identifier list * ml_type
-  | ML_With_module of identifier list * module_path
+  | ML_With_type of Id.t list * Id.t list * ml_type
+  | ML_With_module of Id.t list * module_path
 
-and ml_module_sig = (label * ml_specif) list
+and ml_module_sig = (Label.t * ml_specif) list
 
 type ml_structure_elem =
   | SEdecl of ml_decl
@@ -167,11 +166,11 @@ type ml_structure_elem =
 
 and ml_module_expr =
   | MEident of module_path
-  | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr
+  | MEfunctor of MBId.t * ml_module_type * ml_module_expr
   | MEstruct of module_path * ml_module_structure
   | MEapply of ml_module_expr * ml_module_expr
 
-and ml_module_structure = (label * ml_structure_elem) list
+and ml_module_structure = (Label.t * ml_structure_elem) list
 
 and ml_module =
     { ml_mod_expr : ml_module_expr;
@@ -184,6 +183,8 @@ type ml_structure = (module_path * ml_module_structure) list
 
 type ml_signature = (module_path * ml_module_sig) list
 
+type ml_flat_structure = ml_structure_elem list
+
 type unsafe_needs = {
   mldummy : bool;
   tdummy : bool;
@@ -192,16 +193,22 @@ type unsafe_needs = {
 }
 
 type language_descr = {
-  keywords : Idset.t;
+  keywords : Id.Set.t;
 
   (* Concerning the source file *)
   file_suffix : string;
-  preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  (* the second argument is a comment to add to the preamble *)
+  preamble :
+    Id.t -> std_ppcmds option -> module_path list -> unsafe_needs ->
+    std_ppcmds;
   pp_struct : ml_structure -> std_ppcmds;
 
   (* Concerning a possible interface file *)
   sig_suffix : string option;
-  sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+  (* the second argument is a comment to add to the preamble *)
+  sig_preamble :
+    Id.t -> std_ppcmds option -> module_path list -> unsafe_needs ->
+    std_ppcmds;
   pp_sig : ml_signature -> std_ppcmds;
 
   (* for an isolated declaration print *)
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 1462d3e7..9fdb0205 100644
--- a/plugins/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -1,17 +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 Pp
 open Util
 open Names
 open Libnames
-open Nametab
+open Globnames
 open Table
 open Miniml
 (*i*)
@@ -23,14 +22,14 @@ exception Impossible
 
 (*S Names operations. *)
 
-let anonymous_name = id_of_string "x"
-let dummy_name = id_of_string "_"
+let anonymous_name = Id.of_string "x"
+let dummy_name = Id.of_string "_"
 
 let anonymous = Id anonymous_name
 
 let id_of_name = function
   | Anonymous -> anonymous_name
-  | Name id when id = dummy_name -> anonymous_name
+  | Name id when Id.equal id dummy_name -> anonymous_name
   | Name id -> id
 
 let id_of_mlid = function
@@ -54,6 +53,22 @@ let new_meta _ =
   incr meta_count;
   Tmeta {id = !meta_count; contents = None}
 
+let rec eq_ml_type t1 t2 = match t1, t2 with
+| Tarr (tl1, tr1), Tarr (tl2, tr2) ->
+  eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2
+| Tglob (gr1, t1), Tglob (gr2, t2) ->
+  eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2
+| Tvar i1, Tvar i2 -> Int.equal i1 i2
+| Tvar' i1, Tvar' i2 -> Int.equal i1 i2
+| Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2
+| Tdummy k1, Tdummy k2 -> k1 == k2
+| Tunknown, Tunknown -> true
+| Taxiom, Taxiom -> true
+| _ -> false
+
+and eq_ml_meta m1 m2 =
+ Int.equal m1.id m2.id && Option.equal eq_ml_type m1.contents m2.contents
+
 (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
 
 let type_subst_list l t =
@@ -86,7 +101,7 @@ let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
 
 let rec type_occurs alpha t =
   match t with
-  | Tmeta {id=beta; contents=None} -> alpha = beta
+  | Tmeta {id=beta; contents=None} -> Int.equal alpha beta
   | Tmeta {contents=Some u} -> type_occurs alpha u
   | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
   | Tglob (r,l) -> List.exists (type_occurs alpha) l
@@ -95,7 +110,7 @@ let rec type_occurs alpha t =
 (*s Most General Unificator *)
 
 let rec mgu = function
-  | Tmeta m, Tmeta m' when m.id = m'.id -> ()
+  | Tmeta m, Tmeta m' when Int.equal m.id m'.id -> ()
   | Tmeta m, t | t, Tmeta m ->
     (match m.contents with
       | Some u -> mgu (u, t)
@@ -103,21 +118,24 @@ let rec mgu = function
       | None -> m.contents <- Some t)
   | Tarr(a, b), Tarr(a', b') ->
       mgu (a, a'); mgu (b, b')
-  | Tglob (r,l), Tglob (r',l') when r = r' ->
+  | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' ->
        List.iter mgu (List.combine l l')
-  | (Tdummy _, _ | _, Tdummy _) when lang() = Haskell -> ()
+  | (Tdummy _, _ | _, Tdummy _) when lang() == Haskell -> ()
   | Tdummy _, Tdummy _ -> ()
-  | t, u when t = u -> () (* for Tvar, Tvar', Tunknown, Taxiom *)
+  | Tvar i, Tvar j when Int.equal i j -> ()
+  | Tvar' i, Tvar' j when  Int.equal i j -> ()
+  | Tunknown, Tunknown -> ()
+  | Taxiom, Taxiom -> ()
   | _ -> raise Impossible
 
 let needs_magic p = try mgu p; false with Impossible -> true
 
-let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a
+let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a
 
-let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a
+let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a
 
 let generalizable a =
-  lang () <> Ocaml ||
+  lang () != Ocaml ||
     match a with
       | MLapp _ -> false
       | _ -> true (* TODO, this is just an approximation for the moment *)
@@ -148,7 +166,7 @@ module Mlenv = struct
   (* [find_free] finds the free meta in a type. *)
 
   let rec find_free set = function
-    | Tmeta m when m.contents = None -> Metaset.add m set
+    | Tmeta m when Option.is_empty m.contents -> Metaset.add m set
     | Tmeta {contents = Some t} -> find_free set t
     | Tarr (a,b) -> find_free (find_free set a) b
     | Tglob (_,l) -> List.fold_left find_free set l
@@ -172,12 +190,12 @@ module Mlenv = struct
 
   let generalization mle t =
     let c = ref 0 in
-    let map = ref (Intmap.empty : int Intmap.t) in
-    let add_new i = incr c; map := Intmap.add i !c !map; !c in
+    let map = ref (Int.Map.empty : int Int.Map.t) in
+    let add_new i = incr c; map := Int.Map.add i !c !map; !c in
     let rec meta2var t = match t with
       | Tmeta {contents=Some u} -> meta2var u
       | Tmeta ({id=i} as m) ->
-	  (try Tvar (Intmap.find i !map)
+	  (try Tvar (Int.Map.find i !map)
 	   with Not_found ->
 	     if Metaset.mem m mle.free then t
 	     else Tvar (add_new i))
@@ -225,21 +243,6 @@ let type_maxvar t =
     | _ -> n
   in parse 0 t
 
-(*s What are the type variables occurring in [t]. *)
-
-let intset_union_map_list f l =
-  List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l
-
-let intset_union_map_array f a =
-  Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a
-
-let rec type_listvar = function
-  | Tmeta {contents = Some t} -> type_listvar t
-  | Tvar i | Tvar' i -> Intset.singleton i
-  | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b)
-  | Tglob (_,l) -> intset_union_map_list type_listvar l
-  | _ -> Intset.empty
-
 (*s From [a -> b -> c] to [[a;b],c]. *)
 
 let rec type_decomp = function
@@ -283,13 +286,13 @@ let type_simpl = type_expand (fun _ -> None)
 (*s Generating a signature from a ML type. *)
 
 let type_to_sign env t = match type_expand env t with
-  | Tdummy d -> Kill d
+  | Tdummy d when not (conservative_types ()) -> Kill d
   | _ -> Keep
 
 let type_to_signature env t =
   let rec f = function
     | Tmeta {contents = Some t} -> f t
-    | Tarr (Tdummy d, b) -> Kill d :: f b
+    | Tarr (Tdummy d, b) when not (conservative_types ())  -> Kill d :: f b
     | Tarr (_, b) -> Keep :: f b
     | _ -> []
   in f (type_expand env t)
@@ -318,7 +321,7 @@ let rec sign_kind = function
 	| NonLogicalSig -> NonLogicalSig
 	| UnsafeLogicalSig -> UnsafeLogicalSig
 	| SafeLogicalSig | EmptySig ->
-	    if k = Kother then UnsafeLogicalSig else SafeLogicalSig
+	    if k == Kother then UnsafeLogicalSig else SafeLogicalSig
 
 (* Removing the final [Keep] in a signature *)
 
@@ -326,17 +329,17 @@ let rec sign_no_final_keeps = function
   | [] -> []
   | k :: s ->
       let s' = k :: sign_no_final_keeps s in
-      if s' = [Keep] then [] else s'
+      match s' with [Keep] -> [] | _ -> s'
 
 (*s Removing [Tdummy] from the top level of a ML type. *)
 
 let type_expunge_from_sign env s t =
   let rec expunge s t =
-    if s = [] then t else match t with
+    if List.is_empty s then t else match t with
       | Tmeta {contents = Some t} -> expunge s t
       | Tarr (a,b) ->
 	  let t = expunge (List.tl s) b in
-	  if List.hd s = Keep then Tarr (a, t) else t
+	  if List.hd s == Keep then Tarr (a, t) else t
       | Tglob (r,l) ->
 	  (match env r with
 	     | Some mlt -> expunge s (type_subst_list l mlt)
@@ -344,7 +347,7 @@ let type_expunge_from_sign env s t =
       | _ -> assert false
   in
   let t = expunge (sign_no_final_keeps s) t in
-  if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then
+  if lang () != Haskell && sign_kind s == UnsafeLogicalSig then
     Tarr (Tdummy Kother, t)
   else t
 
@@ -353,7 +356,55 @@ let type_expunge env t =
 
 (*S Generic functions over ML ast terms. *)
 
-let mlapp f a = if a = [] then f else MLapp (f,a)
+let mlapp f a = if List.is_empty a then f else MLapp (f,a)
+
+(** Equality *)
+
+let eq_ml_ident i1 i2 = match i1, i2 with
+| Dummy, Dummy -> true
+| Id id1, Id id2 -> Id.equal id1 id2
+| Tmp id1, Tmp id2 -> Id.equal id1 id2
+| _ -> false
+
+let rec eq_ml_ast t1 t2 = match t1, t2 with
+| MLrel i1, MLrel i2 ->
+  Int.equal i1 i2
+| MLapp (f1, t1), MLapp (f2, t2) ->
+  eq_ml_ast f1 f2 && List.equal eq_ml_ast t1 t2
+| MLlam (na1, t1), MLlam (na2, t2) ->
+  eq_ml_ident na1 na2 && eq_ml_ast t1 t2
+| MLletin (na1, c1, t1), MLletin (na2, c2, t2) ->
+  eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2
+| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2
+| MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) ->
+  eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2
+| MLtuple t1, MLtuple t2 ->
+  List.equal eq_ml_ast t1 t2
+| MLcase (t1, c1, p1), MLcase (t2, c2, p2) ->
+  eq_ml_type t1 t2 && eq_ml_ast c1 c2 && Array.equal eq_ml_branch p1 p2
+| MLfix (i1, id1, t1), MLfix (i2, id2, t2) ->
+  Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2
+| MLexn e1, MLexn e2 -> String.equal e1 e2
+| MLdummy, MLdummy -> true
+| MLaxiom, MLaxiom -> true
+| MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2
+| _ -> false
+
+and eq_ml_pattern p1 p2 = match p1, p2 with
+| Pcons (gr1, p1), Pcons (gr2, p2) ->
+  eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2
+| Ptuple p1, Ptuple p2 ->
+  List.equal eq_ml_pattern p1 p2
+| Prel i1, Prel i2 ->
+  Int.equal i1 i2
+| Pwild, Pwild -> true
+| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2
+| _ -> false
+
+and eq_ml_branch (id1, p1, t1) (id2, p2, t2) =
+  List.equal eq_ml_ident id1 id2 &&
+  eq_ml_pattern p1 p2 &&
+  eq_ml_ast t1 t2
 
 (*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care
    of the number of bingings crossed before reaching the [MLrel]. *)
@@ -428,7 +479,7 @@ let ast_iter f = function
 
 let ast_occurs k t =
   try
-    ast_iter_rel (fun i -> if i = k then raise Found) t; false
+    ast_iter_rel (fun i -> if Int.equal i k then raise Found) t; false
   with Found -> true
 
 (*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)]
@@ -444,7 +495,7 @@ let ast_occurs_itvl k k' t =
 
 let nb_occur_match =
   let rec nb k = function
-    | MLrel i -> if i = k then 1 else 0
+    | MLrel i -> if Int.equal i k then 1 else 0
     | MLcase(_,a,v) ->
         (nb k a) +
 	Array.fold_left
@@ -466,7 +517,7 @@ let ast_lift k t =
   let rec liftrec n = function
     | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
     | a -> ast_map_lift liftrec n a
-  in if k = 0 then t else liftrec 0 t
+  in if Int.equal k 0 then t else liftrec 0 t
 
 let ast_pop t = ast_lift (-1) t
 
@@ -490,7 +541,7 @@ let ast_subst e =
   let rec subst n = function
     | MLrel i as a ->
 	let i' = i-n in
-	if i'=1 then ast_lift n e
+	if Int.equal i' 1 then ast_lift n e
 	else if i'<1 then a
 	else MLrel (i-1)
     | a -> ast_map_lift subst n a
@@ -525,17 +576,18 @@ let has_deep_pattern br =
     | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l)
     | Pusual _ | Prel _ | Pwild -> false
   in
-  array_exists (function (_,pat,_) -> deep pat) br
+  Array.exists (function (_,pat,_) -> deep pat) br
 
 let is_regular_match br =
-  if Array.length br = 0 then false (* empty match becomes MLexn *)
+  if Array.is_empty br then false (* empty match becomes MLexn *)
   else
     try
       let get_r (ids,pat,c) =
 	match pat with
 	  | Pusual r -> r
 	  | Pcons (r,l) ->
-	    if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l))
+            let is_rel i = function Prel j -> Int.equal i j | _ -> false in
+	    if not (List.for_all_i is_rel 1 (List.rev l))
 	    then raise Impossible;
 	    r
 	  | _ -> raise Impossible
@@ -544,7 +596,11 @@ let is_regular_match br =
 	| ConstructRef (ind,_) -> ind
 	| _ -> raise Impossible
       in
-      array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br
+      let is_ref i tr = match get_r tr with
+      | ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1)
+      | _ -> false
+      in
+      Array.for_all_i is_ref 0 br
     with Impossible -> false
 
 (*S Operations concerning lambdas. *)
@@ -562,7 +618,7 @@ let collect_lams =
 
 let collect_n_lams =
   let rec collect acc n t =
-    if n = 0 then acc,t
+    if Int.equal n 0 then acc,t
     else match t with
       | MLlam(id,t) -> collect (id::acc) (n-1) t
       | _ -> assert false
@@ -571,7 +627,7 @@ let collect_n_lams =
 (*s [remove_n_lams] just removes some [MLlam]. *)
 
 let rec remove_n_lams n t =
-  if n = 0 then t
+  if Int.equal n 0 then t
   else match t with
       | MLlam(_,t) -> remove_n_lams (n-1) t
       | _ -> assert false
@@ -609,7 +665,7 @@ let rec anonym_or_dummy_lams a = function
 (*s The following function creates [MLrel n;...;MLrel 1] *)
 
 let rec eta_args n =
-  if n = 0 then [] else (MLrel n)::(eta_args (pred n))
+  if Int.equal n 0 then [] else (MLrel n)::(eta_args (pred n))
 
 (*s Same, but filtered by a signature. *)
 
@@ -621,25 +677,26 @@ let rec eta_args_sign n = function
 (*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
 
 let rec test_eta_args_lift k n = function
-  | [] -> n=0
-  | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
+  | [] -> Int.equal n 0
+  | MLrel m :: q -> Int.equal (k+n) m && (test_eta_args_lift k (pred n) q)
+  | _ -> false
 
 (*s Computes an eta-reduction. *)
 
 let eta_red e =
   let ids,t = collect_lams e in
   let n = List.length ids in
-  if n = 0 then e
+  if Int.equal n 0 then e
   else match t with
     | MLapp (f,a) ->
 	let m = List.length a in
 	let ids,body,args =
-	  if m = n then
+	  if Int.equal m n then
 	    [], f, a
 	  else if m < n then
-	    list_skipn m ids, f, a
+	    List.skipn m ids, f, a
 	  else (* m > n *)
-	    let a1,a2 = list_chop (m-n) a in
+	    let a1,a2 = List.chop (m-n) a in
 	    [], MLapp (f,a1), a2
 	in
 	let p = List.length args in
@@ -715,7 +772,7 @@ let branch_as_fun typ (l,p,c) =
 	if i'<1 then c
 	else if i'>nargs then MLrel (i-nargs+1)
 	else raise Impossible
-    | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1)
+    | MLcons _ as cons' when eq_ml_ast cons' (ast_lift n cons) -> MLrel (n+1)
     | a -> ast_map_lift genrec n a
   in genrec 0 c
 
@@ -739,27 +796,33 @@ let branch_as_cst (l,_,c) =
    When searching for the best factorisation below, we'll try both.
 *)
 
-(* The following structure allows to record which element occurred
+(* The following structure allows recording which element occurred
    at what position, and then finally return the most frequent
    element and its positions. *)
 
 let census_add, census_max, census_clean =
-  let h = Hashtbl.create 13 in
-  let clear () = Hashtbl.clear h in
-  let add e i =
-    let s = try Hashtbl.find h e with Not_found -> Intset.empty in
-    Hashtbl.replace h e (Intset.add i s)
+  let h = ref [] in
+  let clearf () = h := [] in
+  let rec add k v = function
+  | [] -> raise Not_found
+  | (k', s) as p :: l ->
+    if eq_ml_ast k k' then (k', Int.Set.add v s) :: l
+    else p :: add k v l
+  in
+  let addf k i =
+    try h := add k i !h
+    with Not_found -> h := (k, Int.Set.singleton i) :: !h
   in
-  let max e0 =
-    let len = ref 0 and lst = ref Intset.empty and elm = ref e0 in
-    Hashtbl.iter
-      (fun e s ->
-	 let n = Intset.cardinal s in
+  let maxf k =
+    let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in
+    List.iter
+      (fun (e, s) ->
+	 let n = Int.Set.cardinal s in
 	 if n > !len then begin len := n; lst := s; elm := e end)
-      h;
+      !h;
     (!elm,!lst)
   in
-  (add,max,clear)
+  (addf,maxf,clearf)
 
 (* [factor_branches] return the longest possible list of branches
    that have the same factorization, either as a function or as a
@@ -771,7 +834,7 @@ let is_opt_pat (_,p,_) = match p with
   | _ -> false
 
 let factor_branches o typ br =
-  if array_exists is_opt_pat br then None (* already optimized *)
+  if Array.exists is_opt_pat br then None (* already optimized *)
   else begin
     census_clean ();
     for i = 0 to Array.length br - 1 do
@@ -782,8 +845,8 @@ let factor_branches o typ br =
     done;
     let br_factor, br_set = census_max MLdummy in
     census_clean ();
-    let n = Intset.cardinal br_set in
-    if n = 0 then None
+    let n = Int.Set.cardinal br_set in
+    if Int.equal n 0 then None
     else if Array.length br >= 2 && n < 2 then None
     else Some (br_factor, br_set)
   end
@@ -794,17 +857,17 @@ let rec merge_ids ids ids' = match ids,ids' with
   | [],l -> l
   | l,[] -> l
   | i::ids, i'::ids' ->
-      (if i = Dummy then i' else i) :: (merge_ids ids ids')
+      (if i == Dummy then i' else i) :: (merge_ids ids ids')
 
 let is_exn = function MLexn _ -> true | _ -> false
 
-let rec permut_case_fun br acc =
+let permut_case_fun br acc =
   let nb = ref max_int in
   Array.iter (fun (_,_,t) ->
 		let ids, c = collect_lams t in
 		let n = List.length ids in
 		if (n < !nb) && (not (is_exn c)) then nb := n) br;
-  if !nb = max_int || !nb = 0 then ([],br)
+  if Int.equal !nb  max_int || Int.equal !nb 0 then ([],br)
   else begin
     let br = Array.copy br in
     let ids = ref [] in
@@ -837,16 +900,16 @@ let rec iota_red i lift br ((typ,r,a) as cons) =
   if i >= Array.length br then raise Impossible;
   let (ids,p,c) = br.(i) in
   match p with
-    | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons
+    | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons
     | Pusual r' ->
       let c = named_lams (List.rev ids) c in
       let c = ast_lift lift c
       in MLapp (c,a)
-    | Prel 1 when List.length ids = 1 ->
+    | Prel 1 when Int.equal (List.length ids) 1 ->
       let c = MLlam (List.hd ids, c) in
       let c = ast_lift lift c
       in MLapp(c,[MLcons(typ,r,a)])
-    | Pwild when ids = [] -> ast_lift lift c
+    | Pwild when List.is_empty ids -> ast_lift lift c
     | _ -> raise Impossible (* TODO: handle some more cases *)
 
 (* [iota_gen] is an extension of [iota_red] where we allow to
@@ -872,15 +935,11 @@ let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false
     Unfolding them leads to more natural code (and more dummy removal) *)
 
 let is_program_branch = function
-  | Id id ->
-    let s = string_of_id id in
-    let br = "program_branch_" in
-    let n = String.length br in
-    (try
-       ignore (int_of_string (String.sub s n (String.length s - n)));
-       String.sub s 0 n = br
-     with e when Errors.noncritical e -> false)
   | Tmp _ | Dummy -> false
+  | Id id ->
+    let s = Id.to_string id in
+    try Scanf.sscanf s "program_branch_%d%!" (fun _ -> true)
+    with Scanf.Scan_failure _ | End_of_file -> false
 
 let expand_linear_let o id e =
    o.opt_lin_let || is_tmp id || is_program_branch id || is_imm_apply e
@@ -901,7 +960,7 @@ let rec simpl o = function
       if
 	(is_atomic c) || (is_atomic e) ||
 	(let n = nb_occur_match e in
-	 (n = 0 || (n=1 && expand_linear_let o id e)))
+	 (Int.equal n 0 || (Int.equal n 1 && expand_linear_let o id e)))
       then
 	simpl o (ast_subst c e)
       else
@@ -954,14 +1013,14 @@ and simpl_case o typ br e =
     (* Swap the case and the lam if possible *)
     let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in
     let n = List.length ids in
-    if n <> 0 then
+    if not (Int.equal n 0) then
       simpl o (named_lams ids (MLcase (typ, ast_lift n e, br)))
     else
       (* Can we merge several branches as the same constant or function ? *)
-      if lang() = Scheme || is_custom_match br
+      if lang() == Scheme || is_custom_match br
       then MLcase (typ, e, br)
       else match factor_branches o typ br with
-	| Some (f,ints) when Intset.cardinal ints = Array.length br ->
+	| Some (f,ints) when Int.equal (Int.Set.cardinal ints) (Array.length br) ->
 	  (* If all branches have been factorized, we remove the match *)
 	  simpl o (MLletin (Tmp anonymous_name, e, f))
 	| Some (f,ints) ->
@@ -970,7 +1029,7 @@ and simpl_case o typ br e =
 	    else ([], Pwild, ast_pop f)
 	  in
 	  let brl = Array.to_list br in
-	  let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in
+	  let brl_opt = List.filteri (fun i _ -> not (Int.Set.mem i ints)) brl in
 	  let brl_opt = brl_opt @ [last_br] in
 	  MLcase (typ, e, Array.of_list brl_opt)
 	| None -> MLcase (typ, e, br)
@@ -996,9 +1055,9 @@ let rec select_via_bl l args = match l,args with
 
 let kill_some_lams bl (ids,c) =
   let n = List.length bl in
-  let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in
-  if n = n' then ids,c
-  else if n' = 0 then [],ast_lift (-n) c
+  let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in
+  if Int.equal n n' then ids,c
+  else if Int.equal n' 0 then [],ast_lift (-n) c
   else begin
     let v = Array.make n None in
     let rec parse_ids i j = function
@@ -1016,15 +1075,15 @@ let kill_some_lams bl (ids,c) =
 let kill_dummy_lams c =
   let ids,c = collect_lams c in
   let bl = List.map sign_of_id ids in
-  if not (List.mem Keep bl) then raise Impossible;
+  if not (List.memq Keep bl) then raise Impossible;
   let rec fst_kill n = function
     | [] -> raise Impossible
     | Kill _ :: bl -> n
     | Keep :: bl -> fst_kill (n+1) bl
   in
   let skip = max 0 ((fst_kill 0 bl) - 1) in
-  let ids_skip, ids = list_chop skip ids in
-  let _, bl = list_chop skip bl in
+  let ids_skip, ids = List.chop skip ids in
+  let _, bl = List.chop skip bl in
   let c = named_lams ids_skip c in
   let ids',c = kill_some_lams bl (ids,c) in
   ids, named_lams ids' c
@@ -1052,7 +1111,7 @@ let case_expunge s e =
   let m = List.length s in
   let n = nb_lams e in
   let p = if m <= n then collect_n_lams m e
-  else eta_expansion_sign (list_skipn n s) (collect_lams e) in
+  else eta_expansion_sign (List.skipn n s) (collect_lams e) in
   kill_some_lams (List.rev s) p
 
 (*s [term_expunge] takes a function [fun idn ... id1 -> c]
@@ -1061,10 +1120,10 @@ let case_expunge s e =
   if all lambdas are logical dummy and the target language is strict. *)
 
 let term_expunge s (ids,c) =
-  if s = [] then c
+  if List.is_empty s then c
   else
     let ids,c = kill_some_lams (List.rev s) (ids,c) in
-    if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then
+    if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then
       MLlam (Dummy, ast_lift 1 c)
     else named_lams ids c
 
@@ -1076,7 +1135,7 @@ let kill_dummy_args ids r t =
   let m = List.length ids in
   let bl = List.rev_map sign_of_id ids in
   let rec found n = function
-    | MLrel r' when r' = r + n -> true
+    | MLrel r' when Int.equal r' (r + n) -> true
     | MLmagic e -> found n e
     | _ -> false
   in
@@ -1086,7 +1145,7 @@ let kill_dummy_args ids r t =
 	let a = List.map (killrec n) a in
 	let a = List.map (ast_lift k) a in
 	let a = select_via_bl bl (a @ (eta_args k)) in
-	named_lams (list_firstn k ids) (MLapp (ast_lift k e, a))
+	named_lams (List.firstn k ids) (MLapp (ast_lift k e, a))
     | e when found n e ->
 	let a = select_via_bl bl (eta_args m) in
 	named_lams ids (MLapp (ast_lift m e, a))
@@ -1153,7 +1212,7 @@ let normalize a =
   let o = optims () in
   let rec norm a =
     let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in
-    if a = a' then a else norm a'
+    if eq_ml_ast a a' then a else norm a'
   in norm a
 
 (*S Special treatment of fixpoint for pretty-printing purpose. *)
@@ -1165,7 +1224,7 @@ let general_optimize_fix f ids n args m c =
     | MLrel j when v.(j-1)>=0 ->
 	if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
     | _ -> raise Impossible
-  in list_iter_i aux args;
+  in List.iteri aux args;
   let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
   let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in
   let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
@@ -1176,7 +1235,7 @@ let optimize_fix a =
   else
     let ids,a' = collect_lams a in
     let n = List.length ids in
-    if n = 0 then a
+    if Int.equal n 0 then a
     else match a' with
       | MLfix(_,[|f|],[|c|]) ->
 	  let new_f = MLapp (MLrel (n+1),eta_args n) in
@@ -1244,7 +1303,7 @@ let rec non_stricts add cand = function
       let cand = if add then 1::cand else cand in
       pop 1 (non_stricts add cand t)
   | MLrel n ->
-      List.filter ((<>) n) cand
+      List.filter (fun m -> not (Int.equal m n)) cand
   | MLapp (t,l)->
       let cand = non_stricts false cand t in
       List.fold_left (non_stricts false) cand l
@@ -1268,7 +1327,7 @@ let rec non_stricts add cand = function
 	   let n = List.length i in
 	   let cand = lift n cand in
 	   let cand = pop n (non_stricts add cand t) in
-	   Sort.merge (<=) cand c) [] v
+	   List.merge Int.compare cand c) [] v
 	(* [merge] may duplicates some indices, but I don't mind. *)
   | MLmagic t ->
       non_stricts add cand t
@@ -1304,7 +1363,7 @@ let is_not_strict t =
    restriction for the moment.
 *)
 
-open Declarations
+open Declareops
 
 let inline_test r t =
   if not (auto_inline ()) then false
@@ -1312,7 +1371,7 @@ let inline_test r t =
     let c = match r with ConstRef c -> c | _ -> assert false in
     let has_body =
       try constant_has_body (Global.lookup_constant c)
-      with e when Errors.noncritical e -> false
+      with Not_found -> false
     in
     has_body &&
       (let t1 = eta_red t in
@@ -1320,10 +1379,8 @@ let inline_test r t =
        not (is_fix t2) && ml_size t < 12 && is_not_strict t)
 
 let con_of_string s =
-  let null = empty_dirpath in
-  match repr_dirpath (dirpath_of_string s) with
-    | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id)
-    | [] -> assert false
+  let d, id = Libnames.split_dirpath (dirpath_of_string s) in
+  Constant.make2 (MPfile d) (Label.of_id id)
 
 let manual_inline_set =
   List.fold_right (fun x -> Cset_env.add (con_of_string x))
@@ -1355,6 +1412,6 @@ let inline r t =
   not (to_keep r) (* The user DOES want to keep it *)
   && not (is_inline_custom r)
   && (to_inline r (* The user DOES want to inline it *)
-     || (lang () <> Haskell && not (is_projection r) &&
+     || (lang () != Haskell && not (is_projection r) &&
          (is_recursor r || manual_inline r || inline_test r t)))
 
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index 94e6ae69..0a71d2c8 100644
--- a/plugins/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.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        *)
 (************************************************************************)
 
-open Util
 open Names
-open Term
-open Libnames
+open Globnames
 open Miniml
 open Table
 
@@ -68,6 +66,7 @@ val type_to_signature : abbrev_map -> ml_type -> signature
 val type_expunge : abbrev_map -> ml_type -> ml_type
 val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type
 
+val eq_ml_type : ml_type -> ml_type -> bool
 val isDummy : ml_type -> bool
 val isKill : sign -> bool
 
@@ -78,10 +77,10 @@ val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast
 (*s Special identifiers. [dummy_name] is to be used for dead code
     and will be printed as [_] in concrete (Caml) code. *)
 
-val anonymous_name : identifier
-val dummy_name : identifier
-val id_of_name : name -> identifier
-val id_of_mlid : ml_ident -> identifier
+val anonymous_name : Id.t
+val dummy_name : Id.t
+val id_of_name : Name.t -> Id.t
+val id_of_mlid : ml_ident -> Id.t
 val tmp_id : ml_ident -> ml_ident
 
 (*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index 2c923241..8158ac64 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -1,27 +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 Names
-open Declarations
-open Environ
-open Libnames
+open Globnames
+open Errors
 open Util
 open Miniml
 open Table
 open Mlutil
-open Mod_subst
 
 (*S Functions upon ML modules. *)
 
 let rec msid_of_mt = function
   | MTident mp -> mp
   | MTwith(mt,_)-> msid_of_mt mt
-  | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+  | _ -> anomaly ~label:"extraction" (Pp.str "the With operator isn't applied to a name")
 
 (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
    [ml_structure]. *)
@@ -32,16 +30,16 @@ let se_iter do_decl do_spec do_mp =
     | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
     | MTwith (mt,ML_With_type(idl,l,t))->
 	let mp_mt = msid_of_mt mt in
-	let l',idl' = list_sep_last idl in
+	let l',idl' = List.sep_last idl in
 	let mp_w =
-	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+	  List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
 	in
-	let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in
+	let r = ConstRef (Constant.make2 mp_w (Label.of_id l')) in
 	mt_iter mt; do_decl (Dtype(r,l,t))
     | MTwith (mt,ML_With_module(idl,mp))->
         let mp_mt = msid_of_mt mt in
         let mp_w =
-	  List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl
+	  List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl
 	in
 	mt_iter mt; do_mp mp_w; do_mp mp
     | MTsig (_, sign) -> List.iter spec_iter sign
@@ -110,13 +108,13 @@ let ind_iter_references do_term do_cons do_type kn ind =
   let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in
   let packet_iter ip p =
     do_type (IndRef ip);
-    if lang () = Ocaml then
+    if lang () == Ocaml then
       (match ind.ind_equiv with
 	 | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip));
 	 | _ -> ());
     Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types
   in
-  if lang () = Ocaml then record_iter_references do_term ind.ind_kind;
+  if lang () == Ocaml then record_iter_references do_term ind.ind_kind;
     Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
 
 let decl_iter_references do_term do_cons do_type =
@@ -199,6 +197,11 @@ let rec msig_of_ms = function
 let signature_of_structure s =
   List.map (fun (mp,ms) -> mp,msig_of_ms ms) s
 
+let rec mtyp_of_mexpr = function
+  | MEfunctor (id,ty,e) -> MTfunsig (id,ty, mtyp_of_mexpr e)
+  | MEstruct (mp,str) -> MTsig (mp, msig_of_ms str)
+  | _ -> assert false
+
 
 (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
 
@@ -208,18 +211,18 @@ let is_modular = function
 
 let rec search_structure l m = function
   | [] -> raise Not_found
-  | (lab,d)::_ when lab=l && is_modular d = m -> d
+  | (lab,d)::_ when Label.equal lab l && (is_modular d : bool) == m -> d
   | _::fields -> search_structure l m fields
 
 let get_decl_in_structure r struc =
   try
     let base_mp,ll = labels_of_ref r in
     if not (at_toplevel base_mp) then error_not_visible r;
-    let sel = List.assoc base_mp struc in
+    let sel = List.assoc_f ModPath.equal base_mp struc in
     let rec go ll sel = match ll with
       | [] -> assert false
       | l :: ll ->
-	  match search_structure l (ll<>[]) sel with
+	  match search_structure l (not (List.is_empty ll)) sel with
 	    | SEdecl d -> d
 	    | SEmodtype m -> assert false
 	    | SEmodule m ->
@@ -228,7 +231,7 @@ let get_decl_in_structure r struc =
 		  | _ -> error_not_visible r
     in go ll sel
   with Not_found ->
-    anomaly "reference not found in extracted structure"
+    anomaly (Pp.str "reference not found in extracted structure")
 
 
 (*s Optimization of a [ml_structure]. *)
@@ -251,7 +254,7 @@ let dfix_to_mlfix rv av i =
 	(try MLrel (n + (Refmap'.find refe s)) with Not_found -> t)
     | _ -> ast_map_lift subst n t
   in
-  let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in
+  let ids = Array.map (fun r -> Label.to_id (label_of_r r)) rv in
   let c = Array.map (subst 0) av
   in MLfix(i, ids, c)
 
@@ -297,8 +300,6 @@ and optim_me to_appear s = function
    For non-library extraction, we recompute a minimal set of dependencies
    for first-level definitions (no module pruning yet). *)
 
-exception NoDepCheck
-
 let base_r = function
   | ConstRef c as r -> r
   | IndRef (kn,_) -> IndRef (kn,0)
@@ -353,7 +354,7 @@ let rec depcheck_se = function
     let se' = depcheck_se se in
     let refs = declared_refs d in
     let refs' = List.filter is_needed refs in
-    if refs' = [] then
+    if List.is_empty refs' then
       (List.iter remove_info_axiom refs;
        List.iter remove_opaque refs;
        se')
@@ -362,7 +363,7 @@ let rec depcheck_se = function
       (* Hack to avoid extracting unused part of a Dfix *)
       match d with
 	| Dfix (rv,trms,tys) when (List.for_all is_custom refs') ->
-	  let trms' =  Array.create (Array.length rv) (MLexn "UNUSED") in
+	  let trms' =  Array.make (Array.length rv) (MLexn "UNUSED") in
 	  ((l,SEdecl (Dfix (rv,trms',tys))) :: se')
 	| _ -> (compute_deps_decl d; t::se')
     end
@@ -376,14 +377,22 @@ let rec depcheck_struct = function
   | (mp,lse)::struc ->
       let struc' = depcheck_struct struc in
       let lse' = depcheck_se lse in
-      if lse' = [] then struc' else (mp,lse')::struc'
+      if List.is_empty lse' then struc' else (mp,lse')::struc'
+
+let is_prefix pre s =
+  let len = String.length pre in
+  let rec is_prefix_aux i =
+    if Int.equal i len then true
+    else pre.[i] == s.[i] && is_prefix_aux (succ i)
+  in
+  is_prefix_aux 0
 
 let check_implicits = function
   | MLexn s ->
-      if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then
+      if String.length s > 8 && (s.[0] == 'U' || s.[0] == 'I') then
 	begin
-	  if String.sub s 0 7 = "UNBOUND" then assert false;
-	  if String.sub s 0 8 = "IMPLICIT" then
+	  if is_prefix "UNBOUND" s then assert false;
+	  if is_prefix "IMPLICIT" s then
 	    error_non_implicit (String.sub s 9 (String.length s - 9));
 	end;
       false
@@ -397,7 +406,7 @@ let optimize_struct to_appear struc =
   in
   ignore (struct_ast_search check_implicits opt_struc);
   if library () then
-    List.filter (fun (_,lse) -> lse<>[]) opt_struc
+    List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc
   else begin
     reset_needed ();
     List.iter add_needed (fst to_appear);
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
index 58d8167d..ca32f029 100644
--- a/plugins/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -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 Names
-open Declarations
-open Environ
-open Libnames
+open Globnames
 open Miniml
-open Mod_subst
 
 (*s Functions upon ML modules. *)
 
@@ -20,11 +17,14 @@ val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
 
 type do_ref = global_reference -> unit
 
+val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit
 val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
 val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
 
 val signature_of_structure : ml_structure -> ml_signature
 
+val mtyp_of_mexpr : ml_module_expr -> ml_module_type
+
 val msid_of_mt : ml_module_type -> module_path
 
 val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 70e71eeb..30ac3d3f 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.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        *)
@@ -9,25 +9,21 @@
 (*s Production of Ocaml syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
-open Libnames
+open Globnames
 open Table
 open Miniml
 open Mlutil
 open Modutil
 open Common
-open Declarations
 
 
 (*s Some utility functions. *)
 
-let pp_tvar id =
-  let s = string_of_id id in
-  if String.length s < 2 || s.[1]<>'\''
-  then str ("'"^s)
-  else str ("' "^s)
+let pp_tvar id = str ("'" ^ Id.to_string id)
 
 let pp_abst = function
   | [] -> mt ()
@@ -36,10 +32,10 @@ let pp_abst = function
       str " ->" ++ spc ()
 
 let pp_parameters l =
-  (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
+  (pp_boxed_tuple pp_tvar l ++ space_if (not (List.is_empty l)))
 
 let pp_string_parameters l =
-  (pp_boxed_tuple str l ++ space_if (l<>[]))
+  (pp_boxed_tuple str l ++ space_if (not (List.is_empty l)))
 
 let pp_letin pat def body =
   let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in
@@ -48,7 +44,7 @@ let pp_letin pat def body =
 (*s Ocaml renaming issues. *)
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
   [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
     "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
     "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
@@ -57,22 +53,30 @@ let keywords =
     "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
     "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
     "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ]
-  Idset.empty
+  Id.Set.empty
 
 let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
 
-let preamble _ used_modules usf =
+let pp_comment s = str "(* " ++ hov 0 s ++ str " *)"
+
+let pp_header_comment = function
+  | None -> mt ()
+  | Some com -> pp_comment com ++ fnl () ++ fnl ()
+
+let preamble _ comment used_modules usf =
+  pp_header_comment comment ++
   prlist pp_open used_modules ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++
   (if usf.mldummy then
      str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n"
    else mt ()) ++
   (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ())
 
-let sig_preamble _ used_modules usf =
+let sig_preamble _ comment used_modules usf =
+  pp_header_comment comment ++ fnl () ++ fnl () ++
   prlist pp_open used_modules ++
-  (if used_modules = [] then mt () else fnl ()) ++
+  (if List.is_empty used_modules then mt () else fnl ()) ++
   (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt())
 
 (*s The pretty-printer for Ocaml syntax*)
@@ -93,7 +97,7 @@ let is_infix r =
   is_inline_custom r &&
   (let s = find_custom r in
    let l = String.length s in
-   l >= 2 && s.[0] = '(' && s.[l-1] = ')')
+   l >= 2 && s.[0] == '(' && s.[l-1] == ')')
 
 let get_infix r =
   let s = find_custom r in
@@ -110,22 +114,21 @@ let pp_one_field r i = function
 
 let pp_field r fields i = pp_one_field r i (List.nth fields i)
 
-let pp_fields r fields = list_map_i (pp_one_field r) 0 fields
+let pp_fields r fields = List.map_i (pp_one_field r) 0 fields
 
 (*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
     are needed or not. *)
 
-let rec pp_type par vl t =
+let pp_type par vl t =
   let rec pp_rec par = function
     | Tmeta _ | Tvar' _ | Taxiom -> assert false
     | Tvar i -> (try pp_tvar (List.nth vl (pred i))
-		 with e when Errors.noncritical e ->
-                   (str "'a" ++ int i))
+                 with Failure _ -> (str "'a" ++ int i))
     | Tglob (r,[a1;a2]) when is_infix r ->
 	pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2)
     | Tglob (r,[]) -> pp_global Type r
     | Tglob (IndRef(kn,0),l)
-	when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" ->
+	when not (keep_singleton ()) && MutInd.equal kn (mk_ind "Coq.Init.Specif" "sig") ->
 	pp_tuple_light pp_rec l
     | Tglob (r,l) ->
 	pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
@@ -149,7 +152,7 @@ let is_bool_patt p s =
       | Pcons (r,[]) -> r
       | _ -> raise Not_found
     in
-    find_custom r = s
+    String.equal (find_custom r) s
   with Not_found -> false
 
 
@@ -186,7 +189,7 @@ let rec pp_expr par env args =
 	hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2))
     | MLglob r ->
 	(try
-	   let args = list_skipn (projection_arity r) args in
+	   let args = List.skipn (projection_arity r) args in
 	   let record = List.hd args in
 	   pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args)
 	 with e when Errors.noncritical e -> apply (pp_global Term r))
@@ -203,35 +206,35 @@ let rec pp_expr par env args =
     | MLaxiom ->
 	pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
     | MLcons (_,r,a) as c ->
-        assert (args=[]);
+        assert (List.is_empty args);
         begin match a with
 	  | _ when is_native_char c -> pp_native_char c
 	  | [a1;a2] when is_infix r ->
 	    let pp = pp_expr true env [] in
 	    pp_par par (pp a1 ++ str (get_infix r) ++ pp a2)
 	  | _ when is_coinductive r ->
-	    let ne = (a<>[]) in
+	    let ne = not (List.is_empty a) in
 	    let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in
 	    pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple))
 	  | [] -> pp_global Cons r
 	  | _ ->
 	    let fds = get_record_fields r in
-	    if fds <> [] then
+	    if not (List.is_empty fds) then
 	      pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a)
 	    else
 	      let tuple = pp_tuple (pp_expr true env []) a in
-	      if str_global Cons r = "" (* hack Extract Inductive prod *)
+	      if String.is_empty (str_global Cons r) (* hack Extract Inductive prod *)
 	      then tuple
 	      else pp_par par (pp_global Cons r ++ spc () ++ tuple)
 	end
     | MLtuple l ->
-        assert (args = []);
+        assert (List.is_empty args);
         pp_boxed_tuple (pp_expr true env []) l
     | MLcase (_, t, pv) when is_custom_match pv ->
         if not (is_regular_match pv) then
 	  error "Cannot mix yet user-given match and general patterns.";
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in
@@ -250,7 +253,7 @@ let rec pp_expr par env args =
         (try pp_record_proj par env typ t pv args
 	 with Impossible ->
 	   (* Second, can this match be printed as a let-in ? *)
-	   if Array.length pv = 1 then
+	   if Int.equal (Array.length pv) 1 then
 	     let s1,s2 = pp_one_pat env pv.(0) in
 	     hv 0 (apply2 (pp_letin s1 head s2))
 	   else
@@ -265,8 +268,8 @@ let rec pp_expr par env args =
 and pp_record_proj par env typ t pv args =
   (* Can a match be printed as a mere record projection ? *)
   let fields = record_fields_of_type typ in
-  if fields = [] then raise Impossible;
-  if Array.length pv <> 1 then raise Impossible;
+  if List.is_empty fields then raise Impossible;
+  if not (Int.equal (Array.length pv) 1) then raise Impossible;
   if has_deep_pattern pv then raise Impossible;
   let (ids,pat,body) = pv.(0) in
   let n = List.length ids in
@@ -277,7 +280,7 @@ and pp_record_proj par env typ t pv args =
     | _ -> raise Impossible
   in
   let rec lookup_rel i idx = function
-    | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l
+    | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l
     | Pwild :: l -> lookup_rel i (idx+1) l
     | _ -> raise Impossible
   in
@@ -301,15 +304,15 @@ and pp_record_pat (fields, args) =
    str " }"
 
 and pp_cons_pat r ppl =
-  if is_infix r && List.length ppl = 2 then
+  if is_infix r && Int.equal (List.length ppl) 2 then
     List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl)
   else
     let fields = get_record_fields r in
-    if fields <> [] then pp_record_pat (pp_fields r fields, ppl)
-    else if str_global Cons r = "" then
+    if not (List.is_empty fields) then pp_record_pat (pp_fields r fields, ppl)
+    else if String.is_empty (str_global Cons r) then
       pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *)
     else
-      pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl
+      pp_global Cons r ++ space_if (not (List.is_empty ppl)) ++ pp_boxed_tuple identity ppl
 
 and pp_gen_pat ids env = function
   | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l)
@@ -339,7 +342,7 @@ and pp_pat env pv =
     (fun i x ->
        let s1,s2 = pp_one_pat env x in
        hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++
-       if i = Array.length pv - 1 then mt () else fnl ())
+       if Int.equal i (Array.length pv - 1) then mt () else fnl ())
     pv
 
 and pp_function env t =
@@ -347,7 +350,7 @@ and pp_function env t =
   let bl,env' = push_vars (List.map id_of_mlid bl) env in
   match t' with
     | MLcase(Tglob(r,_),MLrel 1,pv) when
-	not (is_coinductive r) && get_record_fields r = [] &&
+	not (is_coinductive r) && List.is_empty (get_record_fields r) &&
 	not (is_custom_match pv) ->
 	if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then
 	  pr_binding (List.rev (List.tl bl)) ++
@@ -371,7 +374,7 @@ and pp_fix par env i (ids,bl) args =
 	  prvect_with_sep
       	    (fun () -> fnl () ++ str "and ")
 	    (fun (fi,ti) -> pr_id fi ++ pp_function env ti)
-	    (array_map2 (fun id b -> (id,b)) ids bl) ++
+	    (Array.map2 (fun id b -> (id,b)) ids bl) ++
 	  fnl () ++
 	  hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
 
@@ -390,7 +393,7 @@ let pp_Dfix (rv,c,t) =
       (if init then failwith "empty phrase" else mt ())
     else
       let void = is_inline_custom rv.(i) ||
-	(not (is_custom rv.(i)) && c.(i) = MLexn "UNUSED")
+	(not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false)
       in
       if void then pp init (i+1)
       else
@@ -413,20 +416,19 @@ let pp_equiv param_list name = function
   | RenEquiv ren, _  ->
       str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
 
-let pp_comment s = str "(* " ++ s ++ str " *)"
 
 let pp_one_ind prefix ip_equiv pl name cnames ctyps =
   let pl = rename_tvars keywords pl in
   let pp_constructor i typs =
-    (if i=0 then mt () else fnl ()) ++
+    (if Int.equal i 0 then mt () else fnl ()) ++
     hov 3 (str "| " ++ cnames.(i) ++
-	   (if typs = [] then mt () else str " of ") ++
+	   (if List.is_empty typs then mt () else str " of ") ++
 	   prlist_with_sep
 	    (fun () -> spc () ++ str "* ") (pp_type true pl) typs)
   in
   pp_parameters pl ++ str prefix ++ name ++
   pp_equiv pl name ip_equiv ++ str " =" ++
-  if Array.length ctyps = 0 then str " unit (* empty inductive *)"
+  if Int.equal (Array.length ctyps) 0 then str " unit (* empty inductive *)"
   else fnl () ++ v 0 (prvecti pp_constructor ctyps)
 
 let pp_logical_ind packet =
@@ -525,7 +527,7 @@ let pp_decl = function
 	    pp_string_parameters ids, str "=" ++ spc () ++ str s
 	  with Not_found ->
 	    pp_parameters l,
-	    if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
+	    if t == Taxiom then str "(* AXIOM TO BE REALIZED *)"
 	    else str "=" ++ spc () ++ pp_type false l t
 	in
 	hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
@@ -632,7 +634,7 @@ and pp_module_type params = function
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MTsig (mp, sign) ->
       push_visible mp params;
-      let l = map_succeed pp_specif sign in
+      let l = List.map pp_specif sign in
       pop_visible ();
       str "sig " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
@@ -640,11 +642,11 @@ and pp_module_type params = function
   | MTwith(mt,ML_With_type(idl,vl,typ)) ->
       let ids = pp_parameters (rename_tvars keywords vl) in
       let mp_mt = msid_of_mt mt in
-      let l,idl' = list_sep_last idl in
+      let l,idl' = List.sep_last idl in
       let mp_w =
-	List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+	List.fold_left (fun mp l -> MPdot(mp,Label.of_id l)) mp_mt idl'
       in
-      let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in
+      let r = ConstRef (Constant.make2 mp_w (Label.of_id l)) in
       push_visible mp_mt [];
       let pp_w = str " with type " ++ ids ++ pp_global Type r in
       pop_visible();
@@ -652,7 +654,7 @@ and pp_module_type params = function
   | MTwith(mt,ML_With_module(idl,mp)) ->
       let mp_mt = msid_of_mt mt in
       let mp_w =
-	List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl
+	List.fold_left (fun mp id -> MPdot(mp,Label.of_id id)) mp_mt idl
       in
       push_visible mp_mt [];
       let pp_w = str " with module " ++ pp_modname mp_w in
@@ -672,7 +674,7 @@ let rec pp_structure_elem = function
   | (l,SEmodule m) ->
       let typ =
         (* virtual printing of the type, in order to have a correct mli later*)
-	if Common.get_phase () = Pre then
+	if Common.get_phase () == Pre then
 	  str ": " ++ pp_module_type [] m.ml_mod_type
 	else mt ()
       in
@@ -705,7 +707,7 @@ and pp_module_expr params = function
       str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
   | MEstruct (mp, sel) ->
       push_visible mp params;
-      let l = map_succeed pp_structure_elem sel in
+      let l = List.map pp_structure_elem sel in
       pop_visible ();
       str "struct " ++ fnl () ++
       v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
index 36035b5a..4e796792 100644
--- a/plugins/extraction/ocaml.mli
+++ b/plugins/extraction/ocaml.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/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index f7fa3383..69dea25a 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.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        *)
@@ -9,10 +9,9 @@
 (*s Production of Scheme syntax. *)
 
 open Pp
+open Errors
 open Util
 open Names
-open Nameops
-open Libnames
 open Miniml
 open Mlutil
 open Table
@@ -21,22 +20,29 @@ open Common
 (*s Scheme renaming issues. *)
 
 let keywords =
-  List.fold_right (fun s -> Idset.add (id_of_string s))
+  List.fold_right (fun s -> Id.Set.add (Id.of_string s))
     [ "define"; "let"; "lambda"; "lambdas"; "match";
       "apply"; "car"; "cdr";
       "error"; "delay"; "force"; "_"; "__"]
-    Idset.empty
+    Id.Set.empty
 
-let preamble _ _ usf =
+let pp_comment s = str";; "++h 0 s++fnl ()
+
+let pp_header_comment = function
+  | None -> mt ()
+  | Some com -> pp_comment com ++ fnl () ++ fnl ()
+
+let preamble _ comment _ usf =
+  pp_header_comment comment ++
   str ";; This extracted scheme code relies on some additional macros\n" ++
-  str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++
+  str ";; available at http://www.pps.univ-paris-diderot.fr/~letouzey/scheme\n" ++
   str "(load \"macros_extr.scm\")\n\n" ++
   (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
 
 let pr_id id =
-  let s = string_of_id id in
+  let s = Id.to_string id in
   for i = 0 to String.length s - 1 do
-    if s.[i] = '\'' then s.[i] <- '~'
+    if s.[i] == '\'' then s.[i] <- '~'
   done;
   str s
 
@@ -86,11 +92,11 @@ let rec pp_expr env args =
     | MLglob r ->
 	apply (pp_global Term r)
     | MLcons (_,r,args') ->
-	assert (args=[]);
+	assert (List.is_empty args);
 	let st =
 	  str "`" ++
 	  paren (pp_global Cons r ++
-		 (if args' = [] then mt () else spc ()) ++
+		 (if List.is_empty args' then mt () else spc ()) ++
 		 prlist_with_sep spc (pp_cons_args env) args')
 	in
 	if is_coinductive r then paren (str "delay " ++ st) else st
@@ -99,7 +105,7 @@ let rec pp_expr env args =
 	error "Cannot handle general patterns in Scheme yet."
     | MLcase (_,t,pv) when is_custom_match pv ->
 	let mkfun (ids,_,e) =
-	  if ids <> [] then named_lams (List.rev ids) e
+	  if not (List.is_empty ids) then named_lams (List.rev ids) e
 	  else dummy_lams (ast_lift 1 e) 1
 	in
 	apply
@@ -129,7 +135,7 @@ let rec pp_expr env args =
 and pp_cons_args env = function
   | MLcons (_,r,args) when is_coinductive r ->
       paren (pp_global Cons r ++
-	     (if args = [] then mt () else spc ()) ++
+	     (if List.is_empty args then mt () else spc ()) ++
 	     prlist_with_sep spc (pp_cons_args env) args)
   | e -> str "," ++ pp_expr env [] e
 
@@ -141,7 +147,7 @@ and pp_one_pat env (ids,p,t) =
   in
   let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
   let args =
-    if ids = [] then mt ()
+    if List.is_empty ids then mt ()
     else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
   in
   (pp_global Cons r ++ args), (pp_expr env' [] t)
@@ -161,7 +167,7 @@ and pp_fix env j (ids,bl) args =
 	       (prvect_with_sep fnl
 		  (fun (fi,ti) ->
 		     paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti)))
-		  (array_map2 (fun id b -> (id,b)) ids bl)) ++
+		  (Array.map2 (fun id b -> (id,b)) ids bl)) ++
 	     fnl () ++
       	     hov 2 (pp_apply (pr_id (ids.(j))) true args))))
 
@@ -177,7 +183,7 @@ let pp_decl = function
       prvecti
 	(fun i r ->
 	  let void = is_inline_custom r ||
-	    (not (is_custom r) && defs.(i) = MLexn "UNUSED")
+	    (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false)
 	  in
 	  if void then mt ()
 	  else
@@ -222,7 +228,7 @@ let scheme_descr = {
   preamble = preamble;
   pp_struct = pp_struct;
   sig_suffix = None;
-  sig_preamble = (fun _ _ _ -> mt ());
+  sig_preamble = (fun _ _ _ _ -> mt ());
   pp_sig = (fun _ -> mt ());
   pp_decl = pp_decl;
 }
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
index 2a2bf48e..f0e36e09 100644
--- a/plugins/extraction/scheme.mli
+++ b/plugins/extraction/scheme.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/plugins/extraction/table.ml b/plugins/extraction/table.ml
index eaa64fef..44d760cc 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.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        *)
@@ -11,10 +11,11 @@ open Term
 open Declarations
 open Nameops
 open Namegen
-open Summary
 open Libobject
 open Goptions
 open Libnames
+open Globnames
+open Errors
 open Util
 open Pp
 open Miniml
@@ -22,14 +23,14 @@ open Miniml
 (** Sets and maps for [global_reference] that use the "user" [kernel_name]
     instead of the canonical one *)
 
-module Refmap' = Map.Make(RefOrdered_env)
-module Refset' = Set.Make(RefOrdered_env)
+module Refmap' = Refmap_env
+module Refset' = Refset_env
 
 (*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
 
 let occur_kn_in_ref kn = function
   | IndRef (kn',_)
-  | ConstructRef ((kn',_),_) -> kn = kn'
+  | ConstructRef ((kn',_),_) -> Names.eq_mind kn kn'
   | ConstRef _ -> false
   | VarRef _ -> assert false
 
@@ -54,21 +55,19 @@ let is_modfile = function
   | _ -> false
 
 let raw_string_of_modfile = function
-  | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f)))
+  | MPfile f -> String.capitalize (Id.to_string (List.hd (DirPath.repr f)))
   | _ -> assert false
 
-let current_toplevel () = fst (Lib.current_prefix ())
-
 let is_toplevel mp =
-  mp = initial_path || mp = current_toplevel ()
+  ModPath.equal mp initial_path || ModPath.equal mp (Lib.current_mp ())
 
 let at_toplevel mp =
   is_modfile mp || is_toplevel mp
 
-let rec mp_length mp =
-  let mp0 = current_toplevel () in
+let mp_length mp =
+  let mp0 = Lib.current_mp () in
   let rec len = function
-    | mp when mp = mp0 -> 1
+    | mp when ModPath.equal mp mp0 -> 1
     | MPdot (mp,_) -> 1 + len mp
     | _ -> 1
   in len mp
@@ -80,7 +79,7 @@ let rec prefixes_mp mp = match mp with
   | _ -> MPset.singleton mp
 
 let rec get_nth_label_mp n = function
-  | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
+  | MPdot (mp,l) -> if Int.equal n 1 then l else get_nth_label_mp (n-1) mp
   | _ -> failwith "get_nth_label: not enough MPdot"
 
 let common_prefix_from_list mp0 mpl =
@@ -91,12 +90,12 @@ let common_prefix_from_list mp0 mpl =
   in f mpl
 
 let rec parse_labels2 ll mp1 = function
-  | mp when mp1=mp -> mp,ll
+  | mp when ModPath.equal mp1 mp -> mp,ll
   | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
   | mp -> mp,ll
 
 let labels_of_ref r =
-  let mp_top = current_toplevel () in
+  let mp_top = Lib.current_mp () in
   let mp,_,l = repr_of_r r in
   parse_labels2 [l] mp_top mp
 
@@ -138,7 +137,7 @@ let is_coinductive r =
     | IndRef (kn,_) -> kn
     | _ -> assert false
   in
-  try Mindmap_env.find kn !inductive_kinds = Coinductive
+  try Mindmap_env.find kn !inductive_kinds == Coinductive
   with Not_found -> false
 
 let is_coinductive_type = function
@@ -163,40 +162,39 @@ let record_fields_of_type = function
 (*s Recursors table. *)
 
 (* NB: here we can use the equivalence between canonical
-   and user constant names : Cset is fine, no need for [Cset_env] *)
+   and user constant names. *)
 
-let recursors = ref Cset.empty
-let init_recursors () = recursors := Cset.empty
+let recursors = ref KNset.empty
+let init_recursors () = recursors := KNset.empty
 
-let add_recursors env kn =
-  let mk_con id =
-    make_con_equiv
-      (modpath (user_mind kn))
-      (modpath (canonical_mind kn))
-      empty_dirpath (label_of_id id)
+let add_recursors env ind =
+  let kn = MutInd.canonical ind in
+  let mk_kn id =
+    KerName.make (KerName.modpath kn) DirPath.empty (Label.of_id id)
   in
-  let mib = Environ.lookup_mind kn env in
+  let mib = Environ.lookup_mind ind env in
   Array.iter
     (fun mip ->
        let id = mip.mind_typename in
-       let c_rec = mk_con (Nameops.add_suffix id "_rec")
-       and c_rect = mk_con (Nameops.add_suffix id "_rect") in
-       recursors := Cset.add c_rec (Cset.add c_rect !recursors))
+       let kn_rec = mk_kn (Nameops.add_suffix id "_rec")
+       and kn_rect = mk_kn (Nameops.add_suffix id "_rect") in
+       recursors := KNset.add kn_rec (KNset.add kn_rect !recursors))
     mib.mind_packets
 
 let is_recursor = function
-  | ConstRef kn -> Cset.mem kn !recursors
+  | ConstRef c -> KNset.mem (Constant.canonical c) !recursors
   | _ -> false
 
 (*s Record tables. *)
 
 (* NB: here, working modulo name equivalence is ok *)
 
-let projs = ref (Refmap.empty : int Refmap.t)
+let projs = ref (Refmap.empty : (inductive*int) Refmap.t)
 let init_projs () = projs := Refmap.empty
-let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs
+let add_projection n kn ip = projs := Refmap.add (ConstRef kn) (ip,n) !projs
 let is_projection r = Refmap.mem r !projs
-let projection_arity r = Refmap.find r !projs
+let projection_arity r = snd (Refmap.find r !projs)
+let projection_info r = Refmap.find r !projs
 
 (*s Table of used axioms *)
 
@@ -240,11 +238,11 @@ let safe_basename_of_global r =
   let last_chance r =
     try Nametab.basename_of_global r
     with Not_found ->
-      anomaly "Inductive object unknown to extraction and not globally visible"
+      anomaly (Pp.str "Inductive object unknown to extraction and not globally visible")
   in
   match r with
-    | ConstRef kn -> id_of_label (con_label kn)
-    | IndRef (kn,0) -> id_of_label (mind_label kn)
+    | ConstRef kn -> Label.to_id (con_label kn)
+    | IndRef (kn,0) -> Label.to_id (mind_label kn)
     | IndRef (kn,i) ->
       (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename
        with Not_found -> last_chance r)
@@ -254,8 +252,8 @@ let safe_basename_of_global r =
     | VarRef _ -> assert false
 
 let string_of_global r =
- try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
- with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r)
+ try string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty r)
+ with Not_found -> Id.to_string (safe_basename_of_global r)
 
 let safe_pr_global r = str (string_of_global r)
 
@@ -263,15 +261,15 @@ let safe_pr_global r = str (string_of_global r)
 
 let safe_pr_long_global r =
   try Printer.pr_global r
-  with e when Errors.noncritical e -> match r with
+  with Not_found -> match r with
     | ConstRef kn ->
 	let mp,_,l = repr_con kn in
-	str ((string_of_mp mp)^"."^(string_of_label l))
+	str ((string_of_mp mp)^"."^(Label.to_string l))
     | _ -> assert false
 
 let pr_long_mp mp =
-  let lid = repr_dirpath (Nametab.dirpath_of_module mp) in
-  str (String.concat "." (List.map string_of_id (List.rev lid)))
+  let lid = DirPath.repr (Nametab.dirpath_of_module mp) in
+  str (String.concat "." (List.rev_map Id.to_string lid))
 
 let pr_long_global ref = pr_path (Nametab.path_of_global ref)
 
@@ -281,18 +279,18 @@ let err s = errorlabstrm "Extraction" s
 
 let warning_axioms () =
   let info_axioms = Refset'.elements !info_axioms in
-  if info_axioms = [] then ()
+  if List.is_empty info_axioms then ()
   else begin
-    let s = if List.length info_axioms = 1 then "axiom" else "axioms" in
+    let s = if Int.equal (List.length info_axioms) 1 then "axiom" else "axioms" in
     msg_warning
       (str ("The following "^s^" must be realized in the extracted code:")
        ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms)
        ++ str "." ++ fnl ())
   end;
   let log_axioms = Refset'.elements !log_axioms in
-  if log_axioms = [] then ()
+  if List.is_empty log_axioms then ()
   else begin
-    let s = if List.length log_axioms = 1 then "axiom was" else "axioms were"
+    let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were"
     in
     msg_warning
       (str ("The following logical "^s^" encountered:") ++
@@ -302,14 +300,11 @@ let warning_axioms () =
        str "Having invalid logical axiom in the environment when extracting" ++
        spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
        fnl ())
-  end;
-  if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then
-    msg_warning
-      (str "Some of these axioms might be due to option -dont-load-proofs.")
+  end
 
 let warning_opaques accessed =
   let opaques = Refset'.elements !opaques in
-  if opaques = [] then ()
+  if List.is_empty opaques then ()
   else
     let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in
     if accessed then
@@ -337,7 +332,7 @@ let warning_both_mod_and_cst q mp r =
 
 let error_axiom_scheme r i =
   err (str "The type scheme axiom " ++ spc () ++
-       safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++
+       safe_pr_global r ++ spc () ++ str "needs " ++ int i ++
        str " type variable(s).")
 
 let check_inside_module () =
@@ -409,9 +404,9 @@ let error_MPfile_as_mod mp b =
 let msg_non_implicit r n id =
   let name = match id with
     | Anonymous -> ""
-    | Name id -> "(" ^ string_of_id id ^ ") "
+    | Name id -> "(" ^ Id.to_string id ^ ") "
   in
-  "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
+  "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
 
 let error_non_implicit msg =
   err (str (msg ^ " still occurs after extraction.") ++
@@ -420,16 +415,16 @@ let error_non_implicit msg =
 let check_loaded_modfile mp = match base_mp mp with
   | MPfile dp ->
       if not (Library.library_is_loaded dp) then begin
-	match base_mp (current_toplevel ()) with
-	  | MPfile dp' when dp<>dp' ->
-	      err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+	match base_mp (Lib.current_mp ()) with
+	  | MPfile dp' when not (DirPath.equal dp dp') ->
+	      err (str ("Please load library "^(DirPath.to_string dp^" first.")))
 	  | _ -> ()
       end
   | _ -> ()
 
 let info_file f =
-  Flags.if_verbose message
-    ("The file "^f^" has been created by extraction.")
+  Flags.if_verbose msg_info
+    (str ("The file "^f^" has been created by extraction."))
 
 
 (*S The Extraction auxiliary commands *)
@@ -481,7 +476,7 @@ type opt_flag =
       opt_lin_let : bool;   (* 512 *)
       opt_lin_beta : bool } (* 1024 *)
 
-let kth_digit n k = (n land (1 lsl k) <> 0)
+let kth_digit n k = not (Int.equal (n land (1 lsl k)) 0)
 
 let flag_of_int n =
     { opt_kill_dum = kth_digit n 0;
@@ -518,7 +513,7 @@ let _ = declare_bool_option
            optdepr = false;
 	   optname = "Extraction Optimize";
 	   optkey = ["Extraction"; "Optimize"];
-	   optread = (fun () -> !int_flag_ref <> 0);
+	   optread = (fun () -> not (Int.equal !int_flag_ref 0));
 	   optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
 
 let _ = declare_int_option
@@ -531,12 +526,37 @@ let _ = declare_int_option
                           | None -> chg_flag 0
                           | Some i -> chg_flag (max i 0))}
 
+(* This option controls whether "dummy lambda" are removed when a
+   toplevel constant is defined. *)
+let conservative_types_ref = ref false
+let conservative_types () = !conservative_types_ref
+
+let _ = declare_bool_option
+  {optsync = true;
+   optdepr = false;
+   optname = "Extraction Conservative Types";
+   optkey = ["Extraction"; "Conservative"; "Types"];
+   optread = (fun () -> !conservative_types_ref);
+   optwrite = (fun b -> conservative_types_ref := b) }
+
+
+(* Allows to print a comment at the beginning of the output files *)
+let file_comment_ref = ref ""
+let file_comment () = !file_comment_ref
+
+let _ = declare_string_option
+  {optsync = true;
+   optdepr = false;
+   optname = "Extraction File Comment";
+   optkey = ["Extraction"; "File"; "Comment"];
+   optread = (fun () -> !file_comment_ref);
+   optwrite = (fun s -> file_comment_ref := s) }
 
 (*s Extraction Lang *)
 
 type lang = Ocaml | Haskell | Scheme
 
-let lang_ref = ref Ocaml
+let lang_ref = Summary.ref Ocaml ~name:"ExtrLang"
 
 let lang () = !lang_ref
 
@@ -546,18 +566,13 @@ let extr_lang : lang -> obj =
        cache_function = (fun (_,l) -> lang_ref := l);
        load_function = (fun _ (_,l) -> lang_ref := l)}
 
-let _ = declare_summary "Extraction Lang"
-	  { freeze_function = (fun () -> !lang_ref);
-	    unfreeze_function = ((:=) lang_ref);
-	    init_function = (fun () -> lang_ref := Ocaml) }
-
 let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
 
 (*s Extraction Inline/NoInline *)
 
 let empty_inline_table = (Refset'.empty,Refset'.empty)
 
-let inline_table = ref empty_inline_table
+let inline_table = Summary.ref empty_inline_table ~name:"ExtrInline"
 
 let to_inline r = Refset'.mem r (fst !inline_table)
 
@@ -584,11 +599,6 @@ let inline_extraction : bool * global_reference list -> obj =
         (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
     }
 
-let _ = declare_summary "Extraction Inline"
-	  { freeze_function = (fun () -> !inline_table);
-	    unfreeze_function = ((:=) inline_table);
-	    init_function = (fun () -> inline_table := empty_inline_table) }
-
 (* Grammar entries. *)
 
 let extraction_inline b l =
@@ -604,7 +614,6 @@ let extraction_inline b l =
 let print_extraction_inline () =
   let (i,n)= !inline_table in
   let i'= Refset'.filter (function ConstRef _ -> true | _ -> false) i in
-  msg
     (str "Extraction Inline:" ++ fnl () ++
      Refset'.fold
        (fun r p ->
@@ -626,15 +635,15 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
 
 (*s Extraction Implicit *)
 
-type int_or_id = ArgInt of int | ArgId of identifier
+type int_or_id = ArgInt of int | ArgId of Id.t
 
-let implicits_table = ref Refmap'.empty
+let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit"
 
 let implicits_of_global r =
  try Refmap'.find r !implicits_table with Not_found -> []
 
 let add_implicits r l =
-  let typ = Global.type_of_global r in
+  let typ = Global.type_of_global_unsafe r in
   let rels,_ =
     decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
   let names = List.rev_map fst rels in
@@ -645,7 +654,7 @@ let add_implicits r l =
 	else err (int i ++ str " is not a valid argument number for " ++
 		  safe_pr_global r)
     | ArgId id ->
-	(try list_index (Name id) names
+	(try List.index Name.equal (Name id) names
 	 with Not_found ->
 	   err (str "No argument " ++ pr_id id ++ str " for " ++
 		safe_pr_global r))
@@ -664,11 +673,6 @@ let implicit_extraction : global_reference * int_or_id list -> obj =
        subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l))
     }
 
-let _ = declare_summary "Extraction Implicit"
-	  { freeze_function = (fun () -> !implicits_table);
-	    unfreeze_function = ((:=) implicits_table);
-	    init_function = (fun () -> implicits_table := Refmap'.empty) }
-
 (* Grammar entries. *)
 
 let extraction_implicit r l =
@@ -678,21 +682,21 @@ let extraction_implicit r l =
 
 (*s Extraction Blacklist of filenames not to use while extracting *)
 
-let blacklist_table = ref Idset.empty
+let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist"
 
 let modfile_ids = ref []
 let modfile_mps = ref MPmap.empty
 
 let reset_modfile () =
-  modfile_ids := Idset.elements !blacklist_table;
+  modfile_ids := Id.Set.elements !blacklist_table;
   modfile_mps := MPmap.empty
 
 let string_of_modfile mp =
   try MPmap.find mp !modfile_mps
   with Not_found ->
-    let id = id_of_string (raw_string_of_modfile mp) in
+    let id = Id.of_string (raw_string_of_modfile mp) in
     let id' = next_ident_away id !modfile_ids in
-    let s' = string_of_id id' in
+    let s' = Id.to_string id' in
     modfile_ids := id' :: !modfile_ids;
     modfile_mps := MPmap.add mp s' !modfile_mps;
     s'
@@ -701,16 +705,16 @@ let string_of_modfile mp =
 
 let file_of_modfile mp =
   let s0 = match mp with
-    | MPfile f -> string_of_id (List.hd (repr_dirpath f))
+    | MPfile f -> Id.to_string (List.hd (DirPath.repr f))
     | _ -> assert false
   in
   let s = String.copy (string_of_modfile mp) in
-  if s.[0] <> s0.[0] then s.[0] <- s0.[0];
+  if s.[0] != s0.[0] then s.[0] <- s0.[0];
   s
 
 let add_blacklist_entries l =
   blacklist_table :=
-    List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s)))
+    List.fold_right (fun s -> Id.Set.add (Id.of_string (String.capitalize s)))
       l !blacklist_table
 
 (* Registration of operations for rollback. *)
@@ -723,40 +727,33 @@ let blacklist_extraction : string list -> obj =
        subst_function = (fun (_,x) -> x)
     }
 
-let _ = declare_summary "Extraction Blacklist"
-	  { freeze_function = (fun () -> !blacklist_table);
-	    unfreeze_function = ((:=) blacklist_table);
-	    init_function = (fun () -> blacklist_table := Idset.empty) }
-
 (* Grammar entries. *)
 
 let extraction_blacklist l =
-  let l = List.rev_map string_of_id l in
+  let l = List.rev_map Id.to_string l in
   Lib.add_anonymous_leaf (blacklist_extraction l)
 
 (* Printing part *)
 
 let print_extraction_blacklist () =
-  msgnl
-    (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table))
+  prlist_with_sep fnl pr_id (Id.Set.elements !blacklist_table)
 
 (* Reset part *)
 
 let reset_blacklist : unit -> obj =
   declare_object
     {(default_object "Reset Extraction Blacklist") with
-       cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
-       load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)}
+       cache_function = (fun (_,_)-> blacklist_table := Id.Set.empty);
+       load_function = (fun _ (_,_)-> blacklist_table := Id.Set.empty)}
 
 let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ())
 
 (*s Extract Constant/Inductive. *)
 
 (* UGLY HACK: to be defined in [extraction.ml] *)
-let use_type_scheme_nb_args, register_type_scheme_nb_args =
-  let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r
+let (use_type_scheme_nb_args, type_scheme_nb_args_hook) = Hook.make ()
 
-let customs = ref Refmap'.empty
+let customs = Summary.ref Refmap'.empty ~name:"ExtrCustom"
 
 let add_custom r ids s = customs := Refmap'.add r (ids,s) !customs
 
@@ -768,13 +765,13 @@ let find_custom r = snd (Refmap'.find r !customs)
 
 let find_type_custom r = Refmap'.find r !customs
 
-let custom_matchs = ref Refmap'.empty
+let custom_matchs = Summary.ref Refmap'.empty ~name:"ExtrCustomMatchs"
 
 let add_custom_match r s =
   custom_matchs := Refmap'.add r s !custom_matchs
 
 let indref_of_match pv =
-  if Array.length pv = 0 then raise Not_found;
+  if Array.is_empty pv then raise Not_found;
   let (_,pat,_) = pv.(0) in
   match pat with
     | Pusual (ConstructRef (ip,_)) -> IndRef ip
@@ -800,11 +797,6 @@ let in_customs : global_reference * string list * string -> obj =
         (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
     }
 
-let _ = declare_summary "ML extractions"
-	  { freeze_function = (fun () -> !customs);
-	    unfreeze_function = ((:=) customs);
-	    init_function = (fun () -> customs := Refmap'.empty) }
-
 let in_custom_matchs : global_reference * string -> obj =
   declare_object
     {(default_object "ML extractions custom matchs") with
@@ -814,11 +806,6 @@ let in_custom_matchs : global_reference * string -> obj =
        subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s))
     }
 
-let _ = declare_summary "ML extractions custom match"
-	  { freeze_function = (fun () -> !custom_matchs);
-	    unfreeze_function = ((:=) custom_matchs);
-	    init_function = (fun () -> custom_matchs := Refmap'.empty) }
-
 (* Grammar entries. *)
 
 let extract_constant_inline inline r ids s =
@@ -827,12 +814,12 @@ let extract_constant_inline inline r ids s =
   match g with
     | ConstRef kn ->
 	let env = Global.env () in
-	let typ = Typeops.type_of_constant env kn in
+	let typ = Global.type_of_global_unsafe (ConstRef kn) in
 	let typ = Reduction.whd_betadeltaiota env typ in
 	if Reduction.is_arity env typ
 	  then begin
-	    let nargs = use_type_scheme_nb_args env typ in
-	    if List.length ids <> nargs then error_axiom_scheme g nargs
+	    let nargs = Hook.get use_type_scheme_nb_args env typ in
+	    if not (Int.equal (List.length ids) nargs) then error_axiom_scheme g nargs
 	  end;
 	Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,ids,s))
@@ -847,12 +834,12 @@ let extract_inductive r s l optstr =
     | IndRef ((kn,i) as ip) ->
 	let mib = Global.lookup_mind kn in
 	let n = Array.length mib.mind_packets.(i).mind_consnames in
-	if n <> List.length l then error_nb_cons ();
+	if not (Int.equal n (List.length l)) then error_nb_cons ();
 	Lib.add_anonymous_leaf (inline_extraction (true,[g]));
 	Lib.add_anonymous_leaf (in_customs (g,[],s));
 	Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s)))
 	  optstr;
-	list_iter_i
+	List.iteri
 	  (fun j s ->
 	     let g = ConstructRef (ip,succ j) in
 	     Lib.add_anonymous_leaf (inline_extraction (true,[g]));
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 14792f8f..1acbe355 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.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,13 +8,14 @@
 
 open Names
 open Libnames
+open Globnames
 open Miniml
 open Declarations
 
-module Refset' : Set.S with type elt = global_reference
+module Refset' : CSig.SetS with type elt = global_reference
 module Refmap' : Map.S with type key = global_reference
 
-val safe_basename_of_global : global_reference -> identifier
+val safe_basename_of_global : global_reference -> Id.t
 
 (*s Warning and Error messages. *)
 
@@ -29,7 +30,7 @@ val error_inductive : global_reference -> 'a
 val error_nb_cons : unit -> 'a
 val error_module_clash : module_path -> module_path -> 'a
 val error_no_module_expr : module_path -> 'a
-val error_singleton_become_prop : identifier -> 'a
+val error_singleton_become_prop : Id.t -> 'a
 val error_unknown_module : qualid -> 'a
 val error_scheme : unit -> 'a
 val error_not_visible : global_reference -> 'a
@@ -37,7 +38,7 @@ val error_MPfile_as_mod : module_path -> bool -> 'a
 val check_inside_module : unit -> unit
 val check_inside_section : unit -> unit
 val check_loaded_modfile : module_path -> unit
-val msg_non_implicit : global_reference -> int -> name -> string
+val msg_non_implicit : global_reference -> int -> Name.t -> string
 val error_non_implicit : string -> 'a
 
 val info_file : string -> unit
@@ -45,10 +46,9 @@ val info_file : string -> unit
 (*s utilities about [module_path] and [kernel_names] and [global_reference] *)
 
 val occur_kn_in_ref : mutual_inductive -> global_reference -> bool
-val repr_of_r : global_reference -> module_path * dir_path * label
+val repr_of_r : global_reference -> module_path * DirPath.t * Label.t
 val modpath_of_r : global_reference -> module_path
-val label_of_r : global_reference -> label
-val current_toplevel : unit -> module_path
+val label_of_r : global_reference -> Label.t
 val base_mp : module_path -> module_path
 val is_modfile : module_path -> bool
 val string_of_modfile : module_path -> string
@@ -60,8 +60,8 @@ val mp_length : module_path -> int
 val prefixes_mp : module_path -> MPset.t
 val common_prefix_from_list :
   module_path -> module_path list -> module_path option
-val get_nth_label_mp : int -> module_path -> label
-val labels_of_ref : global_reference -> module_path * label list
+val get_nth_label_mp : int -> module_path -> Label.t
+val labels_of_ref : global_reference -> module_path * Label.t list
 
 (*s Some table-related operations *)
 
@@ -85,9 +85,10 @@ val record_fields_of_type : ml_type -> global_reference option list
 val add_recursors : Environ.env -> mutual_inductive -> unit
 val is_recursor : global_reference -> bool
 
-val add_projection : int -> constant -> unit
+val add_projection : int -> constant -> inductive -> unit
 val is_projection : global_reference -> bool
 val projection_arity : global_reference -> int
+val projection_info : global_reference -> inductive * int (* arity *)
 
 val add_info_axiom : global_reference -> unit
 val remove_info_axiom : global_reference -> unit
@@ -131,6 +132,14 @@ type opt_flag =
 
 val optims :  unit -> opt_flag
 
+(*s Controls whether dummy lambda are removed *)
+
+val conservative_types : unit -> bool
+
+(*s A comment to print at the beginning of the files *)
+
+val file_comment : unit -> string
+
 (*s Target language. *)
 
 type lang = Ocaml | Haskell | Scheme
@@ -162,7 +171,7 @@ val implicits_of_global : global_reference -> int list
 (*s Table for user-given custom ML extractions. *)
 
 (* UGLY HACK: registration of a function defined in [extraction.ml] *)
-val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
+val type_scheme_nb_args_hook : (Environ.env -> Term.constr -> int) Hook.t
 
 val is_custom : global_reference -> bool
 val is_inline_custom : global_reference -> bool
@@ -176,7 +185,7 @@ val find_custom_match : ml_branch array -> string
 
 val extraction_language : lang -> unit
 val extraction_inline : bool -> reference list -> unit
-val print_extraction_inline : unit -> unit
+val print_extraction_inline : unit -> Pp.std_ppcmds
 val reset_extraction_inline : unit -> unit
 val extract_constant_inline :
   bool -> reference -> string list -> string -> unit
@@ -184,14 +193,14 @@ val extract_inductive :
   reference -> string -> string list -> string option -> unit
 
 
-type int_or_id = ArgInt of int | ArgId of identifier
+type int_or_id = ArgInt of int | ArgId of Id.t
 val extraction_implicit : reference -> int_or_id list -> unit
 
 (*s Table of blacklisted filenames *)
 
-val extraction_blacklist : identifier list -> unit
+val extraction_blacklist : Id.t list -> unit
 val reset_extraction_blacklist : unit -> unit
-val print_extraction_blacklist : unit -> unit
+val print_extraction_blacklist : unit -> Pp.std_ppcmds
 
 
 
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
deleted file mode 100644
index 89f824e5..00000000
--- a/plugins/field/LegacyField_Compl.v
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-
-Definition assoc_2nd :=
-  (fix assoc_2nd_rec (A:Type) (B:Set)
-                     (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
-                     (lst:list (prod A B)) {struct lst} :
-   B -> A -> A :=
-     fun (key:B) (default:A) =>
-       match lst with
-       | nil => default
-       | (v,e) :: l =>
-           match eq_dec e key with
-           | left _ => v
-           | right _ => assoc_2nd_rec A B eq_dec l key default
-           end
-       end).
-
-Definition mem :=
-  (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2})
-           (a:A) (l:list A) {struct l} : bool :=
-     match l with
-     | nil => false
-     | a1 :: l1 =>
-         match eq_dec a a1 with
-         | left _ => true
-         | right _ => mem A eq_dec a l1
-         end
-     end).
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
deleted file mode 100644
index 8a55d582..00000000
--- a/plugins/field/LegacyField_Tactic.v
+++ /dev/null
@@ -1,431 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-Require Import LegacyRing.
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-
-(**** Interpretation A --> ExprA ****)
-
-Ltac get_component a s := eval cbv beta iota delta [a] in (a s).
-
-Ltac body_of s := eval cbv beta iota delta [s] in s.
-
-Ltac mem_assoc var lvar :=
-  match constr:lvar with
-  | nil => constr:false
-  | ?X1 :: ?X2 =>
-      match constr:(X1 = var) with
-      | (?X1 = ?X1) => constr:true
-      | _ => mem_assoc var X2
-      end
-  end.
-
-Ltac number lvar :=
-  let rec number_aux lvar cpt :=
-    match constr:lvar with
-    | (@nil ?X1) => constr:(@nil (prod X1 nat))
-    | ?X2 :: ?X3 =>
-        let l2 := number_aux X3 (S cpt) in
-        constr:((X2,cpt) :: l2)
-    end
-  in number_aux lvar 0.
-
-Ltac build_varlist FT trm :=
-  let rec seek_var lvar trm :=
-    let AT := get_component A FT
-    with AzeroT := get_component Azero FT
-    with AoneT := get_component Aone FT
-    with AplusT := get_component Aplus FT
-    with AmultT := get_component Amult FT
-    with AoppT := get_component Aopp FT
-    with AinvT := get_component Ainv FT in
-    match constr:trm with
-    | AzeroT => lvar
-    | AoneT => lvar
-    | (AplusT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AmultT ?X1 ?X2) =>
-        let l1 := seek_var lvar X1 in
-        seek_var l1 X2
-    | (AoppT ?X1) => seek_var lvar X1
-    | (AinvT ?X1) => seek_var lvar X1
-    | ?X1 =>
-        let res := mem_assoc X1 lvar in
-        match constr:res with
-        | true => lvar
-        | false => constr:(X1 :: lvar)
-        end
-    end in
-  let AT := get_component A FT in
-  let lvar := seek_var (@nil AT) trm in
-  number lvar.
-
-Ltac assoc elt lst :=
-  match constr:lst with
-  | nil => fail
-  | (?X1,?X2) :: ?X3 =>
-      match constr:(elt = X1) with
-      | (?X1 = ?X1) => constr:X2
-      | _ => assoc elt X3
-      end
-  end.
-
-Ltac interp_A FT lvar trm :=
-  let AT := get_component A FT
-  with AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | AzeroT => constr:EAzero
-  | AoneT => constr:EAone
-  | (AplusT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAplus e1 e2)
-  | (AmultT ?X1 ?X2) =>
-      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
-      constr:(EAmult e1 e2)
-  | (AoppT ?X1) =>
-      let e := interp_A FT lvar X1 in
-      constr:(EAopp e)
-  | (AinvT ?X1) => let e := interp_A FT lvar X1 in
-                   constr:(EAinv e)
-  | ?X1 => let idx := assoc X1 lvar in
-           constr:(EAvar idx)
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Generation of the multiplier ****)
-
-Ltac remove e l :=
-  match constr:l with
-  | nil => l
-  | e :: ?X2 => constr:X2
-  | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
-  end.
-
-Ltac union l1 l2 :=
-  match constr:l1 with
-  | nil => l2
-  | ?X2 :: ?X3 =>
-      let nl2 := remove X2 l2 in
-      let nl := union X3 nl2 in
-      constr:(X2 :: nl)
-  end.
-
-Ltac raw_give_mult trm :=
-  match constr:trm with
-  | (EAinv ?X1) => constr:(X1 :: nil)
-  | (EAopp ?X1) => raw_give_mult X1
-  | (EAplus ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      union l1 l2
-  | (EAmult ?X1 ?X2) =>
-      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
-      eval compute in (app l1 l2)
-  | _ => constr:(@nil ExprA)
-  end.
-
-Ltac give_mult trm :=
-  let ltrm := raw_give_mult trm in
-  constr:(mult_of_list ltrm).
-
-(**** Associativity ****)
-
-Ltac apply_assoc FT lvar trm :=
-  let t := eval compute in (assoc trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (assoc_correct FT trm); change (assoc trm) with t
-  end.
-
-(**** Distribution *****)
-
-Ltac apply_distrib FT lvar trm :=
-  let t := eval compute in (distrib trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (distrib_correct FT trm);
-       change (distrib trm) with t
-  end.
-
-(**** Multiplication by the inverse product ****)
-
-Ltac grep_mult := match goal with
-                  | id:(interp_ExprA _ _ _ <> _) |- _ => id
-                  end.
-
-Ltac weak_reduce :=
-  match goal with
-  |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
-      cbv beta iota zeta
-       delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
-             Aone Aplus Amult Aopp Ainv]
-  end.
-
-Ltac multiply mul :=
-  match goal with
-  |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
-      let AzeroT := get_component Azero FT in
-      cut (interp_ExprA FT X2 mul <> AzeroT);
-       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
-       | weak_reduce;
-          (let AoneT := get_component Aone ltac:(body_of FT)
-           with AmultT := get_component Amult ltac:(body_of FT) in
-           try
-             match goal with
-             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
-             end; clear FT X2) ]
-  end.
-
-Ltac apply_multiply FT lvar trm :=
-  let t := eval compute in (multiply trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (multiply_correct FT trm);
-       change (multiply trm) with t
-  end.
-
-(**** Permutations and simplification ****)
-
-Ltac apply_inverse mul FT lvar trm :=
-  let t := eval compute in (inverse_simplif mul trm) in
-  match constr:(t = trm) with
-  | (?X1 = ?X1) => idtac
-  | _ =>
-      rewrite <- (inverse_correct FT trm mul);
-       [ change (inverse_simplif mul trm) with t | assumption ]
-  end.
-(**** Inverse test ****)
-
-Ltac strong_fail tac := first [ tac | fail 2 ].
-
-Ltac inverse_test_aux FT trm :=
-  let AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  match constr:trm with
-  | (AinvT _) => fail 1
-  | (AoppT ?X1) =>
-      strong_fail ltac:(inverse_test_aux FT X1; idtac)
-  | (AplusT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | (AmultT ?X1 ?X2) =>
-      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
-  | _ => idtac
-  end.
-
-Ltac inverse_test FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
-  end.
-
-(**** Field itself ****)
-
-Ltac apply_simplif sfun :=
-  match goal with
-  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) =>
-  sfun X1 X2 X3
-  end;
-   match goal with
-   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) =>
-   sfun X1 X2 X3
-   end.
-
-Ltac unfolds FT :=
-  match get_component Aminus FT with
-  | Some ?X1 => unfold X1
-  | _ => idtac
-  end;
-  match get_component Adiv FT with
-  | Some ?X1 => unfold X1
-  | _ => idtac
-  end.
-
-Ltac reduce FT :=
-  let AzeroT := get_component Azero FT
-  with AoneT := get_component Aone FT
-  with AplusT := get_component Aplus FT
-  with AmultT := get_component Amult FT
-  with AoppT := get_component Aopp FT
-  with AinvT := get_component Ainv FT in
-  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] ||
-     compute).
-
-Ltac field_gen_aux FT :=
-  let AplusT := get_component Aplus FT in
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      let lvar := build_varlist FT (AplusT X1 X2) in
-      let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
-      let mul := give_mult (EAplus trm1 trm2) in
-      cut
-        (let ft := FT in
-         let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
-        [ compute; auto
-        | intros ft vm; apply_simplif apply_distrib;
-           apply_simplif apply_assoc; multiply mul;
-           [ apply_simplif apply_multiply;
-              apply_simplif ltac:(apply_inverse mul);
-              (let id := grep_mult in
-               clear id; weak_reduce; clear ft vm; first
-              [ inverse_test FT; legacy ring | field_gen_aux FT ])
-           | idtac ] ]
-  end.
-
-Ltac field_gen FT :=
-  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
-
-(*****************************)
-(*    Term Simplification    *)
-(*****************************)
-
-(**** Minus and division expansions ****)
-
-Ltac init_exp FT trm :=
-  let e :=
-   (match get_component Aminus FT with
-    | Some ?X1 => eval cbv beta delta [X1] in trm
-    | _ => trm
-    end) in
-  match get_component Adiv FT with
-  | Some ?X1 => eval cbv beta delta [X1] in e
-  | _ => e
-  end.
-
-(**** Inverses simplification ****)
-
-Ltac simpl_inv trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAplus e1 e2)
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
-      constr:(EAmult e1 e2)
-  | (EAopp ?X1) => let e := simpl_inv X1 in
-                   constr:(EAopp e)
-  | (EAinv ?X1) => SimplInvAux X1
-  | ?X1 => constr:X1
-  end
- with SimplInvAux trm :=
-  match constr:trm with
-  | (EAinv ?X1) => simpl_inv X1
-  | (EAmult ?X1 ?X2) =>
-      let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
-      constr:(EAmult e1 e2)
-  | ?X1 => let e := simpl_inv X1 in
-           constr:(EAinv e)
-  end.
-
-(**** Monom simplification ****)
-
-Ltac map_tactic fcn lst :=
-  match constr:lst with
-  | nil => lst
-  | ?X2 :: ?X3 =>
-      let r := fcn X2 with t := map_tactic fcn X3 in
-      constr:(r :: t)
-  end.
-
-Ltac build_monom_aux lst trm :=
-  match constr:lst with
-  | nil => eval compute in (assoc trm)
-  | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
-  end.
-
-Ltac build_monom lnum lden :=
-  let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
-  let ltot := eval compute in (app lnum ildn) in
-  let trm := build_monom_aux ltot EAone in
-  match constr:trm with
-  | (EAmult _ ?X1) => constr:X1
-  | ?X1 => constr:X1
-  end.
-
-Ltac simpl_monom_aux lnum lden trm :=
-  match constr:trm with
-  | (EAmult (EAinv ?X1) ?X2) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          simpl_monom_aux newlnum lden X2
-      | false => simpl_monom_aux lnum (X1 :: lden) X2
-      end
-  | (EAmult ?X1 ?X2) =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          simpl_monom_aux lnum newlden X2
-      | false => simpl_monom_aux (X1 :: lnum) lden X2
-      end
-  | (EAinv ?X1) =>
-      let mma := mem_assoc X1 lnum in
-      match constr:mma with
-      | true =>
-          let newlnum := remove X1 lnum in
-          build_monom newlnum lden
-      | false => build_monom lnum (X1 :: lden)
-      end
-  | ?X1 =>
-      let mma := mem_assoc X1 lden in
-      match constr:mma with
-      | true =>
-          let newlden := remove X1 lden in
-          build_monom lnum newlden
-      | false => build_monom (X1 :: lnum) lden
-      end
-  end.
-
-Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.
-
-Ltac simpl_all_monomials trm :=
-  match constr:trm with
-  | (EAplus ?X1 ?X2) =>
-      let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
-      constr:(EAplus e1 e2)
-  | ?X1 => simpl_monom X1
-  end.
-
-(**** Associativity and distribution ****)
-
-Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).
-
-(**** The tactic Field_Term ****)
-
-Ltac eval_weak_reduce trm :=
-  eval
-   cbv beta iota zeta
-    delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
-          Amult Aopp Ainv] in trm.
-
-Ltac field_term FT exp :=
-  let newexp := init_exp FT exp in
-  let lvar := build_varlist FT newexp in
-  let trm := interp_A FT lvar newexp in
-  let tma := eval compute in (assoc trm) in
-  let tsmp :=
-   simpl_all_monomials
-    ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
-  let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
-  (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
deleted file mode 100644
index 39926f65..00000000
--- a/plugins/field/LegacyField_Theory.v
+++ /dev/null
@@ -1,648 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import List.
-Require Import Peano_dec.
-Require Import LegacyRing.
-Require Import LegacyField_Compl.
-
-Record Field_Theory : Type :=
-  {A : Type;
-   Aplus : A -> A -> A;
-   Amult : A -> A -> A;
-   Aone : A;
-   Azero : A;
-   Aopp : A -> A;
-   Aeq : A -> A -> bool;
-   Ainv : A -> A;
-   Aminus : option (A -> A -> A);
-   Adiv : option (A -> A -> A);
-   RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
-   Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.
-
-(* The reflexion structure *)
-Inductive ExprA : Set :=
-  | EAzero : ExprA
-  | EAone : ExprA
-  | EAplus : ExprA -> ExprA -> ExprA
-  | EAmult : ExprA -> ExprA -> ExprA
-  | EAopp : ExprA -> ExprA
-  | EAinv : ExprA -> ExprA
-  | EAvar : nat -> ExprA.
-
-(**** Decidability of equality ****)
-
-Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
-Proof.
-  double induction e1 e2; try intros;
-   try (left; reflexivity) || (try (right; discriminate)).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red; intro; inversion H3; auto).
-  elim (H1 e0); intro y; elim (H2 e); intro y0;
-   try
-    (left; rewrite y; rewrite y0; auto) ||
-      (right; red; intro; inversion H3; auto).
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H1; auto.
-  elim (H0 e); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H1; auto.
-  elim (eq_nat_dec n n0); intro y.
-  left; rewrite y; auto.
-  right; red; intro; inversion H; auto.
-Defined.
-
-Definition eq_nat_dec := Eval compute in eq_nat_dec.
-Definition eqExprA := Eval compute in eqExprA_O.
-
-(**** Generation of the multiplier ****)
-
-Fixpoint mult_of_list (e:list ExprA) : ExprA :=
-  match e with
-  | nil => EAone
-  | e1 :: l1 => EAmult e1 (mult_of_list l1)
-  end.
-
-Section Theory_of_fields.
-
-Variable T : Field_Theory.
-
-Let AT := A T.
-Let AplusT := Aplus T.
-Let AmultT := Amult T.
-Let AoneT := Aone T.
-Let AzeroT := Azero T.
-Let AoppT := Aopp T.
-Let AeqT := Aeq T.
-Let AinvT := Ainv T.
-Let RTT := RT T.
-Let Th_inv_defT := Th_inv_def T.
-
-Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
- Azero T) (Aopp T) (Aeq T) (RT T).
-
-Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
-
-(***************************)
-(*    Lemmas to be used    *)
-(***************************)
-
-Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_assoc :
- forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_assoc :
- forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma AmultT_AplusT_distr :
- forall r1 r2 r3:AT,
-   AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
-Proof.
-  intros; legacy ring.
-Qed.
-
-Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
-Proof.
-  intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
-  legacy ring.
-  transitivity (AplusT (AplusT (AoppT r) r) r2).
-  repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
-  legacy ring.
-Qed.
-
-Lemma r_AmultT_mult :
- forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
-Proof.
-  intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
-  rewrite Th_inv_defT; [ symmetry ; apply AmultT_1l; auto | auto ].
-  transitivity (AmultT (AmultT (AinvT r) r) r2).
-  repeat rewrite AmultT_assoc; rewrite H; trivial.
-  rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
-Qed.
-
-Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
-Proof.
-  intro; legacy ring.
-Qed.
-
-Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
-Proof.
-  intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
-Qed.
-
-Lemma Rmult_neq_0_reg :
- forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
-Proof.
-  intros r1 r2 H; split; red; intro; apply H; rewrite H0; legacy ring.
-Qed.
-
-(************************)
-(*    Interpretation    *)
-(************************)
-
-(**** ExprA --> A ****)
-
-Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
- AT :=
-  match e with
-  | EAzero => AzeroT
-  | EAone => AoneT
-  | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
-  | EAopp e => Aopp T (interp_ExprA lvar e)
-  | EAinv e => Ainv T (interp_ExprA lvar e)
-  | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT
-  end.
-
-(************************)
-(*    Simplification    *)
-(************************)
-
-(**** Associativity ****)
-
-Definition merge_mult :=
-  (fix merge_mult (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAmult t1 t2 =>
-           match t2 with
-           | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2))
-           | _ => EAmult t1 (EAmult t2 e2)
-           end
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint assoc_mult (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e3 =>
-      match e1 with
-      | EAmult e1 e2 =>
-          merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
-            (assoc_mult e3)
-      | _ => EAmult e1 (assoc_mult e3)
-      end
-  | _ => e
-  end.
-
-Definition merge_plus :=
-  (fix merge_plus (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           match t2 with
-           | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2))
-           | _ => EAplus t1 (EAplus t2 e2)
-           end
-       | _ => EAplus e1 e2
-       end).
-
-Fixpoint assoc (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e3 =>
-      match e1 with
-      | EAplus e1 e2 =>
-          merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3)
-      | _ => EAplus (assoc_mult e1) (assoc e3)
-      end
-  | _ => assoc_mult e
-  end.
-
-Lemma merge_mult_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
-   interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_mult at 1; fold merge_mult;
- unfold interp_ExprA at 2; fold interp_ExprA;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
- fold interp_ExprA; unfold interp_ExprA at 5;
- fold interp_ExprA; auto.
-Qed.
-
-Lemma merge_mult_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try (intros; simpl; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AmultT (interp_ExprA lvar e2)
-     (AmultT (interp_ExprA lvar e4)
-        (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AmultT
-     (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
- simpl; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_mult_correct1 :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AmultT (interp_ExprA lvar (assoc_mult e1))
-     (interp_ExprA lvar (assoc_mult e2)) =
-   interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl; rewrite merge_mult_correct;
- simpl; rewrite merge_mult_correct; simpl;
- auto.
-Qed.
-
-Lemma assoc_mult_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-intros; simpl; legacy ring.
-simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
- rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite merge_mult_correct; simpl;
- rewrite merge_mult_correct; simpl; rewrite AmultT_assoc;
- rewrite assoc_mult_correct1; rewrite H2; simpl;
- rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
- fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
- rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
- rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
- legacy ring.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-Qed.
-
-Lemma merge_plus_correct1 :
- forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
-   interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
-Proof.
-intros e1 e2; generalize e1; generalize e2; clear e1 e2.
-simple induction e2; auto; intros.
-unfold merge_plus at 1; fold merge_plus;
- unfold interp_ExprA at 2; fold interp_ExprA;
- rewrite (H0 e e3 lvar); unfold interp_ExprA at 1;
- fold interp_ExprA; unfold interp_ExprA at 5;
- fold interp_ExprA; auto.
-Qed.
-
-Lemma merge_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
-Proof.
-simple induction e1; auto; intros.
-elim e0; try intros; try (simpl; legacy ring).
-unfold interp_ExprA in H2; fold interp_ExprA in H2;
- cut
-  (AplusT (interp_ExprA lvar e2)
-     (AplusT (interp_ExprA lvar e4)
-        (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
-   AplusT
-     (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
-        (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
-intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
- simpl; legacy ring.
-legacy ring.
-Qed.
-
-Lemma assoc_plus_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
-   interp_ExprA lvar (assoc (EAplus e1 e2)).
-Proof.
-simple induction e1; auto; intros.
-rewrite <- (H e0 lvar); simpl; rewrite merge_plus_correct;
- simpl; rewrite merge_plus_correct; simpl;
- auto.
-Qed.
-
-Lemma assoc_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
-Proof.
-simple induction e; auto; intros.
-elim e0; intros.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite merge_plus_correct; simpl;
- rewrite merge_plus_correct; simpl; rewrite AplusT_assoc;
- rewrite assoc_plus_correct; rewrite H2; simpl;
- apply
-  (r_AplusT_plus (interp_ExprA lvar (assoc e1))
-     (AplusT (interp_ExprA lvar (assoc e2))
-        (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
-     (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
-        (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
- rewrite
-  (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
-  ; rewrite assoc_plus_correct; rewrite H1; simpl;
- rewrite (H0 lvar);
- rewrite <-
-  (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
-     (interp_ExprA lvar e3) (interp_ExprA lvar e1))
-  ;
- rewrite
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
-     (interp_ExprA lvar e3));
- rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
- rewrite <-
-  (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
-     (interp_ExprA lvar e1)); apply AplusT_comm.
-unfold assoc; fold assoc; unfold interp_ExprA;
- fold interp_ExprA; rewrite assoc_mult_correct;
- rewrite (H0 lvar); simpl; auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-simpl; rewrite (H0 lvar); auto.
-unfold assoc; fold assoc; unfold interp_ExprA;
- fold interp_ExprA; rewrite assoc_mult_correct;
- simpl; auto.
-Qed.
-
-(**** Distribution *****)
-
-Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2)
-  | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e)
-  | e => e
-  end.
-
-Definition distrib_mult_right :=
-  (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA :=
-     fun e2:ExprA =>
-       match e1 with
-       | EAplus t1 t2 =>
-           EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
-       | _ => EAmult e1 e2
-       end).
-
-Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
-  match e1 with
-  | EAplus t1 t2 =>
-      EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2)
-  | _ => distrib_mult_right e2 e1
-  end.
-
-Fixpoint distrib_main (e:ExprA) : ExprA :=
-  match e with
-  | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2)
-  | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2)
-  | EAopp e => EAopp (distrib_main e)
-  | _ => e
-  end.
-
-Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).
-
-Lemma distrib_mult_right_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_right e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl; auto.
-rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
- rewrite (H0 e2 lvar); legacy ring.
-Qed.
-
-Lemma distrib_mult_left_correct :
- forall (e1 e2:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib_mult_left e1 e2) =
-   AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
-Proof.
-simple induction e1; try intros; simpl.
-rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl;
- apply AmultT_Or.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite AmultT_comm;
- rewrite
-  (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
-     (interp_ExprA lvar e0));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
- rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
- rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-rewrite distrib_mult_right_correct; simpl; apply AmultT_comm.
-Qed.
-
-Lemma distrib_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib; simpl; auto.
-simpl; rewrite <- (H lvar); rewrite <- (H0 lvar);
- unfold distrib; simpl; apply distrib_mult_left_correct.
-simpl; fold AoppT; rewrite <- (H lvar);
- unfold distrib; simpl; rewrite distrib_mult_right_correct;
- simpl; fold AoppT; legacy ring.
-Qed.
-
-(**** Multiplication by the inverse product ****)
-
-Lemma mult_eq :
- forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
-   interp_ExprA lvar e1 = interp_ExprA lvar e2.
-Proof.
-  simpl; intros;
-   apply
-    (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
-       (interp_ExprA lvar e2)); assumption.
-Qed.
-
-Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
-  | _ => EAmult a e
-  end.
-
-Definition multiply (e:ExprA) : ExprA :=
-  match e with
-  | EAmult a e1 => multiply_aux a e1
-  | _ => e
-  end.
-
-Lemma multiply_aux_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply_aux a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; simpl; intros; try rewrite merge_mult_correct;
- auto.
-  simpl; rewrite (H0 lvar); legacy ring.
-Qed.
-
-Lemma multiply_correct :
- forall (e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
-Proof.
-  simple induction e; simpl; auto.
-  intros; apply multiply_aux_correct.
-Qed.
-
-(**** Permutations and simplification ****)
-
-Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
-  match m with
-  | EAmult m0 m1 =>
-      match eqExprA m0 (EAinv a) with
-      | left _ => m1
-      | right _ => EAmult m0 (monom_remove a m1)
-      end
-  | _ =>
-      match eqExprA m (EAinv a) with
-      | left _ => EAone
-      | right _ => EAmult a m
-      end
-  end.
-
-Definition monom_simplif_rem :=
-  (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
-     fun m:ExprA =>
-       match a with
-       | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
-       | _ => monom_remove a m
-       end).
-
-Definition monom_simplif (a m:ExprA) : ExprA :=
-  match m with
-  | EAmult a' m' =>
-      match eqExprA a a' with
-      | left _ => monom_simplif_rem a m'
-      | right _ => m
-      end
-  | _ => m
-  end.
-
-Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
-  match e with
-  | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
-  | _ => monom_simplif a e
-  end.
-
-Lemma monom_remove_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_remove a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction e; intros.
-simpl; case (eqExprA EAzero (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-simpl; case (eqExprA EAone (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
- [ inversion e2 | simpl; trivial ].
-simpl; case (eqExprA e0 (EAinv a)); intros.
-rewrite e2; simpl; fold AinvT.
-rewrite <-
- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
-    (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
-simpl; rewrite H0; auto; legacy ring.
-simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a));
- intros; [ inversion e1 | simpl; trivial ].
-unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros.
-case (eqExprA e0 a); intros.
-rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto.
-inversion e1; simpl; exfalso; auto.
-simpl; trivial.
-unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros;
- [ inversion e0 | simpl; trivial ].
-Qed.
-
-Lemma monom_simplif_rem_correct :
- forall (a e:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif_rem a e) =
-   AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
-Proof.
-simple induction a; simpl; intros; try rewrite monom_remove_correct;
- auto.
-elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
- intros.
-rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
-legacy ring.
-Qed.
-
-Lemma monom_simplif_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; case (eqExprA a e0); intros.
-rewrite <- e2; apply monom_simplif_rem_correct; auto.
-simpl; trivial.
-Qed.
-
-Lemma inverse_correct :
- forall (e a:ExprA) (lvar:list (AT * nat)),
-   interp_ExprA lvar a <> AzeroT ->
-   interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
-Proof.
-simple induction e; intros; auto.
-simpl; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
-unfold inverse_simplif; rewrite monom_simplif_correct; auto.
-Qed.
-
-End Theory_of_fields.
-
-(* Compatibility *)
-Notation AplusT_sym := AplusT_comm (only parsing).
-Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
deleted file mode 100644
index 089ff1e8..00000000
--- a/plugins/field/field.ml4
+++ /dev/null
@@ -1,191 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Names
-open Pp
-open Proof_type
-open Tacinterp
-open Tacmach
-open Term
-open Typing
-open Util
-open Vernacinterp
-open Vernacexpr
-open Tacexpr
-open Mod_subst
-open Coqlib
-
-(* Interpretation of constr's *)
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-(* Construction of constants *)
-let constant dir s = gen_constant "Field" ("field"::dir) s
-let init_constant s = gen_constant_in_modules "Field" init_modules s
-
-(* To deal with the optional arguments *)
-let constr_of_opt a opt =
-  let ac = constr_of a in
-  let ac3 = mkArrow ac (mkArrow ac ac) in
-  match opt with
-  | None -> mkApp (init_constant "None",[|ac3|])
-  | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
-
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
-
-(* Table of theories *)
-let th_tab = ref (Cmap.empty : constr Cmap.t)
-
-let lookup env typ =
-  try Cmap.find typ !th_tab
-  with Not_found ->
-    errorlabstrm "field"
-      (str "No field is declared for type" ++ spc() ++
-      Printer.pr_lconstr_env env typ)
-
-let _ =
-  let init () = th_tab := Cmap.empty in
-  let freeze () = !th_tab in
-  let unfreeze fs = th_tab := fs in
-  Summary.declare_summary "field"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
-
-let load_addfield _ = ()
-let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab
-let subst_addfield (subst,(typ,th as obj)) =
-  let typ' = subst_mps subst typ in
-  let th' = subst_mps subst th in
-    if typ' == typ && th' == th then obj else
-      (typ',th')
-
-(* Declaration of the Add Field library object *)
-let in_addfield : types * constr -> Libobject.obj =
-  Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
-       Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
-       Libobject.cache_function = cache_addfield;
-       Libobject.subst_function = subst_addfield;
-       Libobject.classify_function = (fun a -> Libobject.Substitute a)}
-
-(* Adds a theory to the table *)
-let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
-  ainv_l =
-  begin
-    (try
-      Ring.add_theory true true false a None None None aplus amult aone azero
-        (Some aopp) aeq rth Quote.ConstrSet.empty
-     with | UserError("Add Semi Ring",_) -> ());
-    let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
-      [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
-    begin
-      let _ = type_of (Global.env ()) Evd.empty th in ();
-      Lib.add_anonymous_leaf (in_addfield (a,th))
-    end
-  end
-
-(* Vernac command declaration *)
-open Extend
-open Pcoq
-open Genarg
-
-VERNAC ARGUMENT EXTEND divarg
-| [ "div" ":=" constr(adiv) ] -> [ adiv ]
-END
-
-VERNAC ARGUMENT EXTEND minusarg
-| [ "minus" ":=" constr(aminus) ] -> [ aminus ]
-END
-
-(*
-(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*)
-VERNAC ARGUMENT EXTEND minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-*)
-
-(* For the translator, otherwise the code above is OK *)
-open Ppconstr
-let pp_minus_div_arg _prc _prlc _prt (omin,odiv) =
-  if omin=None && odiv=None then mt() else
-    spc() ++ str "with" ++
-    pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
-    pr_opt (fun c -> str "div := " ++ _prc c) odiv
-(*
-let () =
-  Pptactic.declare_extra_genarg_pprule true
-    (rawwit_minus_div_arg,pp_minus_div_arg)
-    (globwit_minus_div_arg,pp_minus_div_arg)
-    (wit_minus_div_arg,pp_minus_div_arg)
-*)
-ARGUMENT EXTEND minus_div_arg
-  TYPED AS constr_opt * constr_opt
-  PRINTED BY pp_minus_div_arg
-| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
-| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
-| [ ] -> [ None, None ]
-END
-
-VERNAC COMMAND EXTEND Field
-  [ "Add" "Legacy" "Field"
-      constr(a) constr(aplus) constr(amult) constr(aone)
-      constr(azero) constr(aopp) constr(aeq)
-      constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
-    -> [ let (aminus_o, adiv_o) = md in
-         add_field
-           (constr_of a) (constr_of aplus) (constr_of amult)
-           (constr_of aone) (constr_of azero) (constr_of aopp)
-           (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o)
-           (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ]
-END
-
-(* Guesses the type and calls field_gen with the right theory *)
-let field g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let typ =
-    try match Hipattern.match_with_equation (pf_concl g) with
-      | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t
-      | _ -> raise Exit
-    with Hipattern.NoEquationFound | Exit ->
-      error "The statement is not built from Leibniz' equality" in
-  let th = VConstr ([],lookup (pf_env g) typ) in
-  (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ())
-    <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
-
-(* Verifies that all the terms have the same type and gives the right theory *)
-let guess_theory env evc = function
-  | c::tl ->
-    let t = type_of env evc c in
-    if List.exists (fun c1 ->
-      not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then
-      errorlabstrm "Field:" (str" All the terms must have the same type")
-    else
-      lookup env t
-  | [] -> anomaly "Field: must have a non-empty constr list here"
-
-(* Guesses the type and calls Field_Term with the right theory *)
-let field_term l g =
-  Coqlib.check_required_library ["Coq";"field";"LegacyField"];
-  let env = (pf_env g)
-  and evc = (project g) in
-  let th = valueIn (VConstr ([],guess_theory env evc l))
-  and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in
-  (List.fold_right
-    (fun c a ->
-     let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
-     Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g
-
-(* Declaration of Field *)
-
-TACTIC EXTEND legacy_field
-| [ "legacy" "field" ] -> [ field ]
-| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
-END
diff --git a/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib
deleted file mode 100644
index 3c3e87af..00000000
--- a/plugins/field/field_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Field
-Field_plugin_mod
diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget
deleted file mode 100644
index 22b56f33..00000000
--- a/plugins/field/vo.itarget
+++ /dev/null
@@ -1,4 +0,0 @@
-LegacyField_Compl.vo
-LegacyField_Tactic.vo
-LegacyField_Theory.vo
-LegacyField.vo
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 79d4c5b5..62a8605a 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.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        *)
@@ -9,13 +9,12 @@
 open Hipattern
 open Names
 open Term
+open Vars
 open Termops
-open Reductionops
 open Tacmach
 open Util
 open Declarations
-open Libnames
-open Inductiveops
+open Globnames
 
 let qflag=ref true
 
@@ -23,11 +22,11 @@ let red_flags=ref Closure.betaiotazeta
 
 let (=?) f g i1 i2 j1 j2=
   let c=f i1 i2 in
-    if c=0 then g j1 j2 else c
+    if Int.equal c 0 then g j1 j2 else c
 
 let (==?) fg h i1 i2 j1 j2 k1 k2=
   let c=fg i1 i2 j1 j2 in
-    if c=0 then h k1 k2 else c
+    if Int.equal c 0 then h k1 k2 else c
 
 type ('a,'b) sum = Left of 'a | Right of 'b
 
@@ -44,7 +43,7 @@ let rec nb_prod_after n c=
     | _ -> 0
 
 let construct_nhyps ind gls =
-  let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+  let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in
   let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in
   let hyp = nb_prod_after nparams in
     Array.map hyp constr_types
@@ -52,12 +51,11 @@ let construct_nhyps ind gls =
 (* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
 let ind_hyps nevar ind largs gls=
   let types= Inductiveops.arities_of_constructors (pf_env gls) ind in
-  let lp=Array.length types in
-  let myhyps i=
-    let t1=Term.prod_applist types.(i) largs in
+  let myhyps t =
+    let t1=prod_applist t largs in
     let t2=snd (decompose_prod_n_assum nevar t1) in
       fst (decompose_prod_assum t2) in
-    Array.init lp myhyps
+    Array.map myhyps types
 
 let special_nf gl=
   let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
@@ -69,14 +67,14 @@ let special_whd gl=
 
 type kind_of_formula=
     Arrow of constr*constr
-  | False of inductive*constr list
-  | And of inductive*constr list*bool
-  | Or of inductive*constr list*bool
-  | Exists of inductive*constr list
+  | False of pinductive*constr list
+  | And of pinductive*constr list*bool
+  | Or of pinductive*constr list*bool
+  | Exists of pinductive*constr list
   | Forall of constr*constr
   | Atom of constr
 
-let rec kind_of_formula gl term =
+let kind_of_formula gl term =
   let normalize=special_nf gl in
   let cciterm=special_whd gl term in
     match match_with_imp_term cciterm with
@@ -87,26 +85,26 @@ let rec kind_of_formula gl term =
 	   |_->
 	      match match_with_nodep_ind cciterm with
 		  Some (i,l,n)->
-		    let ind=destInd i in
+		    let ind,u=destInd i in
 		    let (mib,mip) = Global.lookup_inductive ind in
 		    let nconstr=Array.length mip.mind_consnames in
-		      if nconstr=0 then
-			False(ind,l)
+		      if Int.equal nconstr 0 then
+			False((ind,u),l)
 		      else
 			let has_realargs=(n>0) in
 			let is_trivial=
 			  let is_constant c =
-			    nb_prod c = mib.mind_nparams in
-			    array_exists is_constant mip.mind_nf_lc in
+			    Int.equal (nb_prod c) mib.mind_nparams in
+			    Array.exists is_constant mip.mind_nf_lc in
 			  if Inductiveops.mis_is_recursive (ind,mib,mip) ||
 			    (has_realargs && not is_trivial)
 			  then
 			    Atom cciterm
 			  else
-			    if nconstr=1 then
-			      And(ind,l,is_trivial)
+			    if Int.equal nconstr 1 then
+			      And((ind,u),l,is_trivial)
 			    else
-			      Or(ind,l,is_trivial)
+			      Or((ind,u),l,is_trivial)
 		| _ ->
 		    match match_with_sigma_type cciterm with
 			Some (i,l)-> Exists((destInd i),l)
@@ -118,7 +116,7 @@ type side = Hyp | Concl | Hint
 
 let no_atoms = (false,{positive=[];negative=[]})
 
-let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
+let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *)
 
 let build_atoms gl metagen side cciterm =
   let trivial =ref false
@@ -144,9 +142,9 @@ let build_atoms gl metagen side cciterm =
 	  let g i _ (_,_,t) =
 	    build_rec env polarity (lift i t) in
 	  let f l =
-	    list_fold_left_i g (1-(List.length l)) () l in
+	    List.fold_left_i g (1-(List.length l)) () l in
 	    if polarity && (* we have a constant constructor *)
-	      array_exists (function []->true|_->false) v
+	      Array.exists (function []->true|_->false) v
 	    then trivial:=true;
 	    Array.iter f v
       | Exists(i,l)->
@@ -154,7 +152,7 @@ let build_atoms gl metagen side cciterm =
 	  let v =(ind_hyps 1 i l gl).(0) in
 	  let g i _ (_,_,t) =
 	    build_rec (var::env) polarity (lift i t) in
-	    list_fold_left_i g (2-(List.length l)) () v
+	    List.fold_left_i g (2-(List.length l)) () v
       | Forall(_,b)->
 	  let var=mkMeta (metagen true) in
 	    build_rec (var::env) polarity b
@@ -171,7 +169,7 @@ let build_atoms gl metagen side cciterm =
 	| Hyp      -> build_rec [] false cciterm
 	| Hint     ->
 	    let rels,head=decompose_prod cciterm in
-	    let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
+	    let env=List.rev_map (fun _->mkMeta (metagen true)) rels in
 	      build_rec env false head;trivial:=false (* special for hints *)
     end;
     (!trivial,
@@ -188,19 +186,19 @@ type right_pattern =
 
 type left_arrow_pattern=
     LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
+  | LLfalse of pinductive*constr list
+  | LLand of pinductive*constr list
+  | LLor of pinductive*constr list
   | LLforall of constr
-  | LLexists of inductive*constr list
+  | LLexists of pinductive*constr list
   | LLarrow of constr*constr*constr
 
 type left_pattern=
     Lfalse
-  | Land of inductive
-  | Lor of inductive
+  | Land of pinductive
+  | Lor of pinductive
   | Lforall of metavariable*constr*bool
-  | Lexists of inductive
+  | Lexists of pinductive
   | LA of constr*left_arrow_pattern
 
 type t={id:global_reference;
@@ -226,7 +224,7 @@ let build_formula side nam typ gl metagen=
 		  | And(_,_,_)        -> Rand
 		  | Or(_,_,_)         -> Ror
 		  | Exists (i,l) ->
-		      let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
+		      let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in
 			Rexists(m,d,trivial)
 		  | Forall (_,a) -> Rforall
 		  | Arrow (a,b) -> Rarrow in
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index 44bbb335..29ea1e77 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -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 Term
 open Names
-open Libnames
+open Term
+open Context
+open Globnames
 
 val qflag : bool ref
 
@@ -24,9 +25,9 @@ type ('a,'b) sum = Left of 'a | Right of 'b
 
 type counter = bool -> metavariable
 
-val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
+val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array
 
-val ind_hyps : int -> inductive -> constr list ->
+val ind_hyps : int -> pinductive -> constr list ->
   Proof_type.goal Tacmach.sigma -> rel_context array
 
 type atoms = {positive:constr list;negative:constr list}
@@ -48,19 +49,19 @@ type right_pattern =
 
 type left_arrow_pattern=
     LLatom
-  | LLfalse of inductive*constr list
-  | LLand of inductive*constr list
-  | LLor of inductive*constr list
+  | LLfalse of pinductive*constr list
+  | LLand of pinductive*constr list
+  | LLor of pinductive*constr list
   | LLforall of constr
-  | LLexists of inductive*constr list
+  | LLexists of pinductive*constr list
   | LLarrow of constr*constr*constr
 
 type left_pattern=
     Lfalse
-  | Land of inductive
-  | Lor of inductive
+  | Land of pinductive
+  | Lor of pinductive
   | Lforall of metavariable*constr*bool
-  | Lexists of inductive
+  | Lexists of pinductive
   | LA of constr*left_arrow_pattern
 
 type t={id: global_reference;
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 5b882036..c28da42a 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -1,25 +1,23 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma"  i*)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
 
 open Formula
 open Sequent
 open Ground
 open Goptions
-open Tactics
 open Tacticals
 open Tacinterp
-open Term
-open Names
-open Util
 open Libnames
 
+DECLARE PLUGIN "ground_plugin"
+
 (* declaring search depth as a global option *)
 
 let ground_depth=ref 3
@@ -57,16 +55,16 @@ let _=
 let (set_default_solver, default_solver, print_default_solver) = 
   Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver"
 
-VERNAC COMMAND EXTEND Firstorder_Set_Solver
+VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF
 | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [
     set_default_solver 
-      (Vernacexpr.use_section_locality ())
-      (Tacinterp.glob_tactic t) ]
+      (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (Tacintern.glob_tactic t) ]
 END
 
-VERNAC COMMAND EXTEND Firstorder_Print_Solver
+VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY
 | [ "Print" "Firstorder" "Solver" ] -> [
-    Pp.msgnl
+    Pp.msg_info
       (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ]
 END
 
@@ -82,10 +80,11 @@ let gen_ground_tac flag taco ids bases gl=
 	  | None-> snd (default_solver ()) in
       let startseq gl=
 	let seq=empty_seq !ground_depth in
-	extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
-      let result=ground_tac solver startseq gl in
+        let seq,gl = extend_with_ref_list ids seq gl in
+        extend_with_auto_hints bases seq gl in
+      let result=ground_tac (Proofview.V82.of_tactic solver) startseq gl in
 	qflag:=backup;result
-    with reraise ->qflag:=backup;raise reraise
+    with reraise -> qflag:=backup;raise reraise
 
 (* special for compatibility with Intuition
 
@@ -103,12 +102,13 @@ let normalize_evaluables=
 	   unfold_in_hyp (Lazy.force defined_connectives)
 	   (Tacexpr.InHypType id)) *)
 
+open Pp
 open Genarg
 open Ppconstr
 open Printer
-let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference
-let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global))
-let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global
+let pr_firstorder_using_raw _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_reference l
+let pr_firstorder_using_glob _ _ _ l = str "using " ++ prlist_with_sep pr_comma (pr_or_var (fun x -> (pr_global (snd x)))) l
+let pr_firstorder_using_typed _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_global l
 
 ARGUMENT EXTEND firstorder_using
   PRINTED BY pr_firstorder_using_typed
@@ -128,29 +128,31 @@ END
 
 TACTIC EXTEND firstorder
     [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) l [] ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ]
 |   [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) [] l ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ]
 |   [ "firstorder" tactic_opt(t) firstorder_using(l)
        "with" ne_preident_list(l') ] ->
-      [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
+      [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ]
 END
 
 TACTIC EXTEND gintuition
   [ "gintuition" tactic_opt(t) ] ->
-     [ gen_ground_tac false (Option.map eval_tactic t) [] [] ]
+     [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ]
 END
 
+open Proofview.Notations
 
-let default_declarative_automation gls =
-  tclORELSE
-    (tclORELSE (Auto.h_trivial [] None)
+let default_declarative_automation =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *)
+  Tacticals.New.tclORELSE
+    (Tacticals.New.tclORELSE (Auto.h_trivial [] None)
     (Cctac.congruence_tac !congruence_depth []))
-    (gen_ground_tac true
-       (Some (tclTHEN
+    (Proofview.V82.tactic (gen_ground_tac true
+       (Some (Tacticals.New.tclTHEN
 		(snd (default_solver ()))
 		(Cctac.congruence_tac !congruence_depth [])))
-       [] []) gls
+       [] []))
 
 
 
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 7c80b9bb..2248b669 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.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        *)
@@ -12,28 +12,27 @@ open Rules
 open Instances
 open Term
 open Tacmach
-open Tactics
 open Tacticals
-open Libnames
 
 let update_flags ()=
   let predref=ref Names.Cpred.empty in
   let f coe=
     try
-      let kn=destConst (Classops.get_coercion_value coe) in
+      let kn= fst (destConst (Classops.get_coercion_value coe)) in
 	predref:=Names.Cpred.add kn !predref
-    with Invalid_argument "destConst"-> () in
+    with DestKO -> ()
+  in
     List.iter f (Classops.coercions ());
     red_flags:=
     Closure.RedFlags.red_add_transparent
       Closure.betaiotazeta
-      (Names.Idpred.full,Names.Cpred.complement !predref)
+      (Names.Id.Pred.full,Names.Cpred.complement !predref)
 
 let ground_tac solver startseq gl=
   update_flags ();
   let rec toptac skipped seq gl=
     if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
-    then Pp.msgnl (Printer.pr_goal gl);
+    then Pp.msg_debug (Printer.pr_goal gl);
     tclORELSE (axiom_tac seq.gl seq)
       begin
 	try
@@ -120,5 +119,6 @@ let ground_tac solver startseq gl=
 		  end
 	    with Heap.EmptyHeap->solver
       end gl in
-    wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
+    let seq, gl' = startseq gl in
+    wrap (List.length (pf_hyps gl)) true (toptac []) seq gl'
 
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 380326e7..5b320786 100644
--- a/plugins/firstorder/ground.mli
+++ b/plugins/firstorder/ground.mli
@@ -1,11 +1,11 @@
 (************************************************************************)
 (*  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 ground_tac:     Tacmach.tactic ->
-  (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
+  (Proof_type.goal Tacmach.sigma -> Sequent.t * Proof_type.goal Tacmach.sigma) -> Tacmach.tactic
 
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index d45ab0c3..a88778c7 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -1,28 +1,27 @@
 (************************************************************************)
 (*  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 Formula
-open Sequent
 open Unify
 open Rules
+open Errors
 open Util
 open Term
+open Vars
 open Glob_term
 open Tacmach
 open Tactics
 open Tacticals
 open Termops
 open Reductionops
-open Declarations
 open Formula
 open Sequent
 open Names
-open Libnames
+open Misctypes
 
 let compare_instance inst1 inst2=
 	match inst1,inst2 with
@@ -30,18 +29,18 @@ let compare_instance inst1 inst2=
 	      (OrderedConstr.compare d1 d2)
 	  | Real((m1,c1),n1),Real((m2,c2),n2)->
 	      ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2
-	  | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
-	  | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
+	  | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1
+	  | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1
 
 let compare_gr id1 id2 =
   if id1==id2 then 0 else
     if id1==dummy_id then 1
     else if id2==dummy_id then -1
-    else Libnames.RefOrdered.compare id1 id2
+    else Globnames.RefOrdered.compare id1 id2
 
 module OrderedInstance=
 struct
-  type t=instance * Libnames.global_reference
+  type t=instance * Globnames.global_reference
   let compare (inst1,id1) (inst2,id2)=
     (compare_instance =? compare_gr) inst2 inst1 id2 id1
     (* we want a __decreasing__ total order *)
@@ -76,7 +75,7 @@ let match_one_quantified_hyp setref seq lf=
       Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
 	if do_sequent setref triv lf.id seq i dom lf.atoms then
 	  setref:=IS.add ((Phantom dom),lf.id) !setref
-    | _ ->anomaly "can't happen"
+    | _ -> anomaly (Pp.str "can't happen")
 
 let give_instances lf seq=
   let setref=ref IS.empty in
@@ -99,36 +98,36 @@ let rec collect_quantified seq=
 
 let dummy_constr=mkMeta (-1)
 
-let dummy_bvid=id_of_string "x"
+let dummy_bvid=Id.of_string "x"
 
-let mk_open_instance id gl m t=
+let mk_open_instance id idc gl m t=
   let env=pf_env gl in
   let evmap=Refiner.project gl in
   let var_id=
     if id==dummy_id then dummy_bvid else
-      let typ=pf_type_of gl (constr_of_global id) in
+      let typ=pf_type_of gl idc in
 	(* since we know we will get a product,
 	   reduction is not too expensive *)
       let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
 	match nam with
 	    Name id -> id
 	  | Anonymous ->  dummy_bvid in
-  let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
+  let revt=substl (List.init m (fun i->mkRel (m-i))) t in
   let rec aux n avoid=
-    if n=0 then [] else
+    if Int.equal n 0 then [] else
       let nid=(fresh_id avoid var_id gl) in
 	(Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in
   let nt=it_mkLambda_or_LetIn revt (aux m []) in
-  let rawt=Detyping.detype false [] [] nt in
+  let rawt=Detyping.detype false [] env evmap nt in
   let rec raux n t=
-    if n=0 then t else
+    if Int.equal n 0 then t else
       match t with
 	  GLambda(loc,name,k,_,t0)->
 	    let t1=raux (n-1) t0 in
-	      GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1)
-	| _-> anomaly "can't happen" in
+	      GLambda(loc,name,k,GHole (Loc.ghost,Evar_kinds.BinderType name,Misctypes.IntroAnonymous,None),t1)
+	| _-> anomaly (Pp.str "can't happen") in
   let ntt=try
-    Pretyping.Default.understand evmap env (raux m rawt)
+    fst (Pretyping.understand env evmap (raux m rawt))(*FIXME*)
   with e when Errors.noncritical e ->
     error "Untypable instance, maybe higher-order non-prenex quantification" in
     decompose_lam_n_assum m ntt
@@ -141,50 +140,53 @@ let left_instance_tac (inst,id) continue seq=
 	if lookup (id,None) seq then
 	  tclFAIL 0 (Pp.str "already done")
 	else
-	  tclTHENS (cut dom)
+	  tclTHENS (Proofview.V82.of_tactic (cut dom))
 	    [tclTHENLIST
-	       [introf;
+	       [Proofview.V82.of_tactic introf;
+                pf_constr_of_global id (fun idc ->
 		(fun gls->generalize
-		   [mkApp(constr_of_global id,
-			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
-		introf;
+		   [mkApp(idc,
+			  [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls));
+		Proofview.V82.of_tactic introf;
 		tclSOLVE [wrap 1 false continue
 			    (deepen (record (id,None) seq))]];
-	    tclTRY assumption]
+	    tclTRY (Proofview.V82.of_tactic assumption)]
     | Real((m,t) as c,_)->
 	if lookup (id,Some c) seq then
 	  tclFAIL 0 (Pp.str "already done")
 	else
 	  let special_generalize=
 	    if m>0 then
-	      fun gl->
-		let (rc,ot)= mk_open_instance id gl m t in
-		let gt=
-		  it_mkLambda_or_LetIn
-		    (mkApp(constr_of_global id,[|ot|])) rc in
-		  generalize [gt] gl
+	      pf_constr_of_global id (fun idc ->
+		fun gl->
+		  let (rc,ot) = mk_open_instance id idc gl m t in
+		  let gt=
+		    it_mkLambda_or_LetIn
+		      (mkApp(idc,[|ot|])) rc in
+		    generalize [gt] gl)
 	    else
-	      generalize [mkApp(constr_of_global id,[|t|])]
+	      pf_constr_of_global id (fun idc ->
+		generalize [mkApp(idc,[|t|])])
 	  in
 	    tclTHENLIST
 	      [special_generalize;
-	       introf;
+	       Proofview.V82.of_tactic introf;
 	       tclSOLVE
 		 [wrap 1 false continue (deepen (record (id,Some c) seq))]]
 
 let right_instance_tac inst continue seq=
   match inst with
       Phantom dom ->
-	tclTHENS (cut dom)
+	tclTHENS (Proofview.V82.of_tactic (cut dom))
 	[tclTHENLIST
-	   [introf;
+	   [Proofview.V82.of_tactic introf;
 	    (fun gls->
-	       split (Glob_term.ImplicitBindings
-			[mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
+	       Proofview.V82.of_tactic (split (ImplicitBindings
+			[mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls);
 	    tclSOLVE [wrap 0 true continue (deepen seq)]];
-	 tclTRY assumption]
+	 tclTRY (Proofview.V82.of_tactic assumption)]
     | Real ((0,t),_) ->
-	(tclTHEN (split (Glob_term.ImplicitBindings [t]))
+	(tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t])))
 	   (tclSOLVE [wrap 0 true continue (deepen seq)]))
     | Real ((m,t),_) ->
 	tclFAIL 0 (Pp.str "not implemented ... yet")
diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
index 709eb96f..2f69ad7b 100644
--- a/plugins/firstorder/instances.mli
+++ b/plugins/firstorder/instances.mli
@@ -1,15 +1,12 @@
 (************************************************************************)
 (*  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 Term
-open Tacmach
-open Names
-open Libnames
+open Globnames
 open Rules
 
 val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index b043ba5f..382d5409 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -1,22 +1,24 @@
 (************************************************************************)
 (*  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 Term
+open Vars
 open Tacmach
 open Tactics
 open Tacticals
 open Termops
-open Declarations
 open Formula
 open Sequent
-open Libnames
+open Globnames
+open Locus
 
 type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
 
@@ -25,13 +27,13 @@ type lseqtac= global_reference -> seqtac
 type 'a with_backtracking = tactic -> 'a
 
 let wrap n b continue seq gls=
-  check_for_interrupt ();
+  Control.check_for_interrupt ();
   let nc=pf_hyps gls in
   let env=pf_env gls in
   let rec aux i nc ctx=
     if i<=0 then seq else
       match nc with
-	  []->anomaly "Not the expected number of hyps"
+	  []->anomaly (Pp.str "Not the expected number of hyps")
 	| ((id,_,typ) as nd)::q->
 	    if occur_var env id (pf_concl gls) ||
 	      List.exists (occur_var_in_decl env id) ctx then
@@ -51,38 +53,38 @@ let clear_global=function
     VarRef id->clear [id]
   | _->tclIDTAC
 
-
 (* connection rules *)
 
 let axiom_tac t seq=
-  try exact_no_check (constr_of_global (find_left t seq))
+  try pf_constr_of_global (find_left t seq) exact_no_check
   with Not_found->tclFAIL 0 (Pp.str "No axiom link")
 
 let ll_atom_tac a backtrack id continue seq=
   tclIFTHENELSE
     (try
       tclTHENLIST
-	[generalize [mkApp(constr_of_global id,
-			   [|constr_of_global (find_left a seq)|])];
+	[pf_constr_of_global (find_left a seq) (fun left ->
+	  pf_constr_of_global id (fun id -> 
+	    generalize [mkApp(id, [|left|])]));
 	 clear_global id;
-	 intro]
+	 Proofview.V82.of_tactic intro]
     with Not_found->tclFAIL 0 (Pp.str "No link"))
     (wrap 1 false continue seq) backtrack
 
 (* right connectives rules *)
 
 let and_tac backtrack continue seq=
-  tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
+  tclIFTHENELSE (Proofview.V82.of_tactic simplest_split) (wrap 0 true continue seq) backtrack
 
 let or_tac backtrack continue seq=
   tclORELSE
-    (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
+    (Proofview.V82.of_tactic (any_constructor false (Some (Proofview.V82.tactic (tclCOMPLETE (wrap 0 true continue seq))))))
     backtrack
 
 let arrow_tac backtrack continue seq=
-  tclIFTHENELSE intro (wrap 1 true continue seq)
+  tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 1 true continue seq)
     (tclORELSE
-       (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq)))
+       (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 1 true continue seq)))
        backtrack)
 (* left connectives rules *)
 
@@ -90,9 +92,9 @@ let left_and_tac ind backtrack id continue seq gls=
  let n=(construct_nhyps ind gls).(0) in
    tclIFTHENELSE
      (tclTHENLIST
-      [simplest_elim (constr_of_global id);
+      [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim);
        clear_global id;
-       tclDO n intro])
+       tclDO n (Proofview.V82.of_tactic intro)])
      (wrap n false continue seq)
      backtrack gls
 
@@ -101,59 +103,58 @@ let left_or_tac ind backtrack id continue seq gls=
   let f n=
     tclTHENLIST
       [clear_global id;
-       tclDO n intro;
+       tclDO n (Proofview.V82.of_tactic intro);
        wrap n false continue seq] in
     tclIFTHENSVELSE
-      (simplest_elim (constr_of_global id))
+      (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim))
       (Array.map f v)
       backtrack gls
 
 let left_false_tac id=
-  simplest_elim (constr_of_global id)
+  Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)
 
 (* left arrow connective rules *)
 
 (* We use this function for false, and, or, exists *)
 
-let ll_ind_tac ind largs backtrack id continue seq gl=
-     let rcs=ind_hyps 0 ind largs gl in
+let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl=
+     let rcs=ind_hyps 0 indu largs gl in
      let vargs=Array.of_list largs in
-	     (* construire le terme  H->B, le generaliser etc *)
-     let myterm i=
+             (* construire le terme  H->B, le generaliser etc *)
+     let myterm idc i=
        let rc=rcs.(i) in
        let p=List.length rc in
-       let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in
+       let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in
        let vars=Array.init p (fun j->mkRel (p-j)) in
        let capply=mkApp ((lift p cstr),vars) in
-       let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
-	 it_mkLambda_or_LetIn head rc in
+       let head=mkApp ((lift p idc),[|capply|]) in
+         it_mkLambda_or_LetIn head rc in
        let lp=Array.length rcs in
-       let newhyps=list_tabulate myterm lp in
+       let newhyps idc =List.init lp (myterm idc) in
 	 tclIFTHENELSE
 	   (tclTHENLIST
-	      [generalize newhyps;
+	      [pf_constr_of_global id (fun idc -> generalize (newhyps idc));
 	       clear_global id;
-	       tclDO lp intro])
+	       tclDO lp (Proofview.V82.of_tactic intro)])
 	   (wrap lp false continue seq) backtrack gl
 
 let ll_arrow_tac a b c backtrack id continue seq=
   let cc=mkProd(Anonymous,a,(lift 1 b)) in
-  let d=mkLambda (Anonymous,b,
-		  mkApp ((constr_of_global id),
-			 [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
+  let d idc =mkLambda (Anonymous,b,
+		  mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
     tclORELSE
-      (tclTHENS (cut c)
+      (tclTHENS (Proofview.V82.of_tactic (cut c))
 	 [tclTHENLIST
-	    [introf;
+	    [Proofview.V82.of_tactic introf;
 	     clear_global id;
 	     wrap 1 false continue seq];
-	  tclTHENS (cut cc)
-            [exact_no_check (constr_of_global id);
+	  tclTHENS (Proofview.V82.of_tactic (cut cc))
+            [pf_constr_of_global id exact_no_check;
 	     tclTHENLIST
-	       [generalize [d];
+	       [pf_constr_of_global id (fun idc -> generalize [d idc]);
 		clear_global id;
-		introf;
-		introf;
+		Proofview.V82.of_tactic introf;
+		Proofview.V82.of_tactic introf;
 		tclCOMPLETE (wrap 2 true continue seq)]]])
       backtrack
 
@@ -161,9 +162,9 @@ let ll_arrow_tac a b c backtrack id continue seq=
 
 let forall_tac backtrack continue seq=
   tclORELSE
-    (tclIFTHENELSE intro (wrap 0 true continue seq)
+    (tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 0 true continue seq)
        (tclORELSE
-	  (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
+	  (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 0 true continue seq)))
 	  backtrack))
     (if !qflag then
        tclFAIL 0 (Pp.str "reversible in 1st order mode")
@@ -173,24 +174,25 @@ let forall_tac backtrack continue seq=
 let left_exists_tac ind backtrack id continue seq gls=
   let n=(construct_nhyps ind gls).(0) in
     tclIFTHENELSE
-      (simplest_elim (constr_of_global id))
+      (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim))
       (tclTHENLIST [clear_global id;
-                    tclDO n intro;
+                    tclDO n (Proofview.V82.of_tactic intro);
                     (wrap (n-1) false continue seq)])
       backtrack
       gls
 
 let ll_forall_tac prod backtrack id continue seq=
   tclORELSE
-    (tclTHENS (cut prod)
+    (tclTHENS (Proofview.V82.of_tactic (cut prod))
        [tclTHENLIST
-	  [intro;
+	  [Proofview.V82.of_tactic intro;
+           pf_constr_of_global id (fun idc ->
 	   (fun gls->
 	      let id0=pf_nth_hyp_id gls 1 in
-	      let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
-		tclTHEN (generalize [term]) (clear [id0]) gls);
+              let term=mkApp(idc,[|mkVar(id0)|]) in
+		tclTHEN (generalize [term]) (clear [id0]) gls));
 	   clear_global id;
-	   intro;
+	   Proofview.V82.of_tactic intro;
 	   tclCOMPLETE (wrap 1 false continue (deepen seq))];
 	tclCOMPLETE (wrap 0 true continue (deepen seq))])
     backtrack
@@ -202,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq=
 let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
 
 let defined_connectives=lazy
-  [all_occurrences,EvalConstRef (destConst (constant "not"));
-   all_occurrences,EvalConstRef (destConst (constant "iff"))]
+  [AllOccurrences,EvalConstRef (fst (destConst (constant "not")));
+   AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))]
 
 let normalize_evaluables=
   onAllHypsAndConcl
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
index d5fe398f..596e8535 100644
--- a/plugins/firstorder/rules.mli
+++ b/plugins/firstorder/rules.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        *)
@@ -9,7 +9,7 @@
 open Term
 open Tacmach
 open Names
-open Libnames
+open Globnames
 
 type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
 
@@ -19,7 +19,7 @@ type 'a with_backtracking = tactic -> 'a
 
 val wrap : int -> bool -> seqtac
 
-val basename_of_global: global_reference -> identifier
+val basename_of_global: global_reference -> Id.t
 
 val clear_global: global_reference -> tactic
 
@@ -33,19 +33,19 @@ val or_tac : seqtac with_backtracking
 
 val arrow_tac : seqtac with_backtracking
 
-val left_and_tac : inductive -> lseqtac with_backtracking
+val left_and_tac : pinductive -> lseqtac with_backtracking
 
-val left_or_tac : inductive -> lseqtac with_backtracking
+val left_or_tac : pinductive -> lseqtac with_backtracking
 
 val left_false_tac : global_reference -> tactic
 
-val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking
+val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking
 
 val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
 
 val forall_tac : seqtac with_backtracking
 
-val left_exists_tac : inductive -> lseqtac with_backtracking
+val left_exists_tac : pinductive -> lseqtac with_backtracking
 
 val ll_forall_tac : types -> lseqtac with_backtracking
 
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index 50cf14a9..2f7f21e4 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -1,18 +1,18 @@
 (************************************************************************)
 (*  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 Term
+open Errors
 open Util
 open Formula
 open Unify
 open Tacmach
-open Names
-open Libnames
+open Globnames
 open Pp
 
 let newcnt ()=
@@ -48,8 +48,6 @@ let priority = (* pure heuristics, <=0 for non reversible *)
 		| LLexists (_,_)   ->  50
 		| LLarrow  (_,_,_) -> -10
 
-let left_reversible lpat=(priority lpat)>0
-
 module OrderedFormula=
 struct
   type t=Formula.t
@@ -69,12 +67,14 @@ module Hitem=
 struct
   type t = h_item
   let compare (id1,co1) (id2,co2)=
-    (Libnames.RefOrdered.compare
-     =? (fun oc1 oc2 ->
-	   match oc1,oc2 with
-	       Some (m1,c1),Some (m2,c2) ->
-		 ((-) =? OrderedConstr.compare) m1 m2 c1 c2
-	     | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
+    let c = Globnames.RefOrdered.compare id1 id2 in
+    if c = 0 then
+      let cmp (i1, c1) (i2, c2) =
+        let c = Int.compare i1 i2 in
+        if c = 0 then OrderedConstr.compare c1 c2 else c
+      in
+      Option.compare cmp co1 co2
+    else c
 end
 
 module CM=Map.Make(OrderedConstr)
@@ -90,7 +90,7 @@ let cm_add typ nam cm=
 let cm_remove typ nam cm=
   try
     let l=CM.find typ cm in
-    let l0=List.filter (fun id->id<>nam) l in
+    let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in
       match l0 with
 	  []->CM.remove typ cm
 	| _ ->CM.add typ l0 cm
@@ -120,10 +120,10 @@ let lookup item seq=
 	let p (id2,o)=
 	  match o with
 	      None -> false
-	    | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in
+	    | Some ((m2,t2) as c2)-> Globnames.eq_gr id id2 && m2>m && more_general c2 c in
 	  History.exists p seq.history
 
-let rec add_formula side nam t seq gl=
+let add_formula side nam t seq gl=
   match build_formula side nam t gl seq.cnt with
       Left f->
 	begin
@@ -163,8 +163,6 @@ let find_left t seq=List.hd (CM.find t seq.context)
       left_reversible lpat
   with Heap.EmptyHeap -> false
 *)
-let no_formula seq=
-  seq.redexes=HP.empty
 
 let rec take_formula seq=
   let hd=HP.maximum seq.redexes
@@ -191,36 +189,36 @@ let empty_seq depth=
    depth=depth}
 
 let expand_constructor_hints =
-  list_map_append (function
+  List.map_append (function
     | IndRef ind ->
-	list_tabulate (fun i -> ConstructRef (ind,i+1))
-	  (Inductiveops.nconstructors ind)
+        List.init (Inductiveops.nconstructors ind)
+          (fun i -> ConstructRef (ind,i+1))
     | gr ->
 	[gr])
 
-let extend_with_ref_list l seq gl=
+let extend_with_ref_list l seq gl =
   let l = expand_constructor_hints l in
-  let f gr seq=
-    let c=constr_of_global gr in
+  let f gr (seq,gl) =
+    let gl, c = pf_eapply Evd.fresh_global gl gr in
     let typ=(pf_type_of gl c) in
-      add_formula Hyp gr typ seq gl in
-    List.fold_right f l seq
+      (add_formula Hyp gr typ seq gl,gl) in
+    List.fold_right f l (seq,gl)
 
-open Auto
+open Hints
 
 let extend_with_auto_hints l seq gl=
   let seqref=ref seq in
   let f p_a_t =
     match p_a_t.code with
-	Res_pf (c,_) | Give_exact c
+	Res_pf (c,_) | Give_exact (c,_)
       | Res_pf_THEN_trivial_fail (c,_) ->
 	  (try
-	     let gr=global_of_constr c in
+	     let gr = global_of_constr c in
 	     let typ=(pf_type_of gl c) in
 	       seqref:=add_formula Hint gr typ !seqref gl
 	   with Not_found->())
       | _-> () in
-  let g _ l = List.iter f l in
+  let g _ _ l = List.iter f l in
   let h dbname=
     let hdb=
       try
@@ -229,18 +227,18 @@ let extend_with_auto_hints l seq gl=
 	error ("Firstorder: "^dbname^" : No such Hint database") in
       Hint_db.iter g hdb in
     List.iter h l;
-    !seqref
+    !seqref, gl (*FIXME: forgetting about universes*)
 
 let print_cmap map=
   let print_entry c l s=
-    let xc=Constrextern.extern_constr false (Global.env ()) c in
+    let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty c in
       str "| " ++
-      Util.prlist Printer.pr_global l ++
+      prlist Printer.pr_global l ++
       str " : " ++
       Ppconstr.pr_constr_expr xc ++
       cut () ++
       s in
-    msgnl (v 0
+    (v 0
 	     (str "-----" ++
 	      cut () ++
 	      CM.fold print_entry map (mt ()) ++
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index 44b5ed3e..dc3f05be 100644
--- a/plugins/firstorder/sequent.mli
+++ b/plugins/firstorder/sequent.mli
@@ -1,17 +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 Term
-open Util
 open Formula
 open Tacmach
-open Names
-open Libnames
+open Globnames
 
 module OrderedConstr: Set.OrderedType with type t=constr
 
@@ -56,9 +54,9 @@ val take_formula : t -> Formula.t * t
 val empty_seq : int -> t
 
 val extend_with_ref_list : global_reference list ->
-  t -> Proof_type.goal sigma -> t
+  t -> Proof_type.goal sigma -> t * Proof_type.goal sigma
 
-val extend_with_auto_hints : Auto.hint_db_name list ->
-  t -> Proof_type.goal sigma -> t
+val extend_with_auto_hints : Hints.hint_db_name list ->
+  t -> Proof_type.goal sigma -> t * Proof_type.goal sigma
 
-val print_cmap: global_reference list CM.t -> unit
+val print_cmap: global_reference list CM.t -> Pp.std_ppcmds
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 00eb9981..0a172034 100644
--- a/plugins/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -1,16 +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 Util
-open Formula
-open Tacmach
 open Term
-open Names
+open Vars
 open Termops
 open Reductionops
 
@@ -34,7 +32,7 @@ let unif t1 t2=
     match kind_of_term t with
 	Meta i->
 	  (try
-	     head_reduce (List.assoc i !sigma)
+	     head_reduce (Int.List.assoc i !sigma)
 	   with Not_found->t)
       | _->t in
     Queue.add (t1,t2) bige;
@@ -44,17 +42,17 @@ let unif t1 t2=
       and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in
 	match (kind_of_term nt1),(kind_of_term nt2) with
 	    Meta i,Meta j->
-	      if i<>j then
+	      if not (Int.equal i j) then
 		if i<j then bind j nt1
 		else bind i nt2
 	  | Meta i,_ ->
 	      let t=subst_meta !sigma nt2 in
-		if Intset.is_empty (free_rels t) &&
+		if Int.Set.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
 	  | _,Meta i ->
 	      let t=subst_meta !sigma nt1 in
-		if Intset.is_empty (free_rels t) &&
+		if Int.Set.is_empty (free_rels t) &&
 		  not (occur_term (mkMeta i) t) then
 		    bind i t else raise (UFAIL(nt1,nt2))
 	  | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
@@ -65,7 +63,7 @@ let unif t1 t2=
 	      Queue.add (pa,pb) bige;
 	      Queue.add (ca,cb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then
+		if not (Int.equal l (Array.length vb)) then
 		  raise (UFAIL (nt1,nt2))
 		else
 		  for i=0 to l-1 do
@@ -74,13 +72,13 @@ let unif t1 t2=
 	  | App(ha,va),App(hb,vb)->
 	      Queue.add (ha,hb) bige;
 	      let l=Array.length va in
-		if l<>(Array.length vb) then
+		if not (Int.equal l (Array.length vb)) then
 		  raise (UFAIL (nt1,nt2))
 		else
 		  for i=0 to l-1 do
 		    Queue.add (va.(i),vb.(i)) bige
 		  done
-	  | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
+	  | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2))
     done;
       assert false
 	(* this place is unreachable but needed for the sake of typing *)
@@ -90,7 +88,7 @@ let value i t=
   let add x y=
     if x<0 then y else if y<0 then x else x+y in
   let rec vaux term=
-    if isMeta term && destMeta term = i then 0 else
+    if isMeta term && Int.equal (destMeta term) i then 0 else
       let f v t=add v (vaux t) in
       let vr=fold_constr f (-1) term in
 	if vr<0 then -1 else vr+1 in
@@ -107,7 +105,7 @@ let mk_rel_inst t=
     match kind_of_term t with
 	Meta n->
 	  (try
-	     mkRel (d+(List.assoc n !rel_env))
+	     mkRel (d+(Int.List.assoc n !rel_env))
 	   with Not_found->
 	     let m= !new_rel in
 	       incr new_rel;
@@ -119,7 +117,7 @@ let mk_rel_inst t=
 
 let unif_atoms i dom t1 t2=
   try
-    let t=List.assoc i (unif t1 t2) in
+    let t=Int.List.assoc i (unif t1 t2) in
       if isMeta t then Some (Phantom dom)
       else Some (Real(mk_rel_inst t,value i t1))
   with
@@ -127,7 +125,7 @@ let unif_atoms i dom t1 t2=
     | Not_found ->Some (Phantom dom)
 
 let renum_metas_from k n t= (* requires n = max (free_rels t) *)
-  let l=list_tabulate (fun i->mkMeta (k+i)) n in
+  let l=List.init n (fun i->mkMeta (k+i)) in
     substl l t
 
 let more_general (m1,t1) (m2,t2)=
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 697548be..15318546 100644
--- a/plugins/firstorder/unify.mli
+++ b/plugins/firstorder/unify.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/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 9c788788..1832de85 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -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,7 @@
 
 (* "Fourier's method to solve linear inequations/equations systems.".*)
 
-Require Export LegacyRing.
-Require Export LegacyField.
+Require Export Field.
 Require Export DiscrR.
 Require Export Fourier_util.
 Declare ML Module "fourier_plugin".
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index af2812c4..284d220a 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -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        *)
@@ -164,7 +164,7 @@ Qed.
 Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
 unfold not; intros.
 apply H.
-apply Rplus_lt_reg_r with x.
+apply Rplus_lt_reg_l with x.
 replace (x + 0) with x.
 replace (x + (y - x)) with y.
 try exact H0.
@@ -177,7 +177,7 @@ unfold not; intros.
 apply H.
 case H0; intros.
 left.
-apply Rplus_lt_reg_r with x.
+apply Rplus_lt_reg_l with x.
 replace (x + 0) with x.
 replace (x + (y - x)) with y.
 try exact H1.
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index c39c2387..50a5150d 100644
--- a/plugins/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -1,18 +1,18 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(* Méthode d'élimination de Fourier *)
-(* Référence:
+(* Méthode d'élimination de Fourier *)
+(* Référence:
 Auteur(s) : Fourier, Jean-Baptiste-Joseph
 
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
 
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
 
 Pages: 326-327
 
@@ -20,8 +20,8 @@ http://gallica.bnf.fr/
 *)
 
 (* Un peu de calcul sur les rationnels...
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
 *)
 type rational = {num:int;
                  den:int}
@@ -59,9 +59,9 @@ let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
 let rinf x y = x.num*y.den < y.num*x.den;;
 let rinfeq x y = x.num*y.den <= y.num*x.den;;
 
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
 c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
 *)
 
 type ineq = {coef:rational list;
@@ -70,8 +70,8 @@ type ineq = {coef:rational list;
 
 let pop x l = l:=x::(!l);;
 
-(* sépare la liste d'inéquations s selon que leur premier coefficient est
-négatif, nul ou positif. *)
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
+négatif, nul ou positif. *)
 let partitionne s =
    let lpos=ref [] in
    let lneg=ref [] in
@@ -85,44 +85,44 @@ let partitionne s =
              s;
    [!lneg;!lnul;!lpos]
 ;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
 =
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
  ...
- {équation n, [0;0;...;1], sn}]
+ {équation n, [0;0;...;1], sn}]
 *)
 let add_hist le =
    let n = List.length le in
-   let i=ref 0 in
+   let i = ref 0 in
    List.map (fun (ie,s) ->
-              let h =ref [] in
-              for k=1 to (n-(!i)-1) do pop r0 h; done;
+              let h = ref [] in
+              for _k = 1 to (n - (!i) - 1) do pop r0 h; done;
               pop r1 h;
-              for k=1 to !i do pop r0 h; done;
+              for _k = 1 to !i do pop r0 h; done;
               i:=!i+1;
               {coef=ie;hist=(!h);strict=s})
              le
 ;;
-(* additionne deux inéquations *)
+(* additionne deux inéquations *)
 let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
                       hist=List.map2 rplus ie1.hist ie2.hist;
 		      strict=ie1.strict || ie2.strict}
 ;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
+(* multiplication d'une inéquation par un rationnel (positif) *)
 let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
                      hist=List.map (fun x -> rmult a x) ie.hist;
 		     strict= ie.strict}
 ;;
-(* on enlève le premier coefficient *)
+(* on enlève le premier coefficient *)
 let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
 ;;
-(* le premier coefficient: "tête" de l'inéquation *)
+(* le premier coefficient: "tête" de l'inéquation *)
 let hd_coef ie = List.hd ie.coef
 ;;
 
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
 *)
 let deduce_add lneg lpos =
    let res=ref [] in
@@ -136,8 +136,8 @@ let deduce_add lneg lpos =
              lneg;
    !res
 ;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
 *)
 let deduce1 s =
     match (partitionne s) with
@@ -146,38 +146,37 @@ let deduce1 s =
     (List.map ie_tl lnul)@lnew
      |_->assert false
 ;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
+(* algorithme de Fourier: on élimine successivement toutes les variables.
 *)
 let deduce lie =
    let n = List.length (fst (List.hd lie)) in
    let lie=ref (add_hist lie) in
-   for i=1 to n-1 do
+   for _i = 1 to n - 1 do
       lie:= deduce1 !lie;
    done;
    !lie
 ;;
 
-(* donne [] si le système a des solutions,
+(* donne [] si le système a des solutions,
 sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
+où lc est la combinaison linéaire des inéquations de départ
 qui donne 0 < c si s=true
        ou 0 <= c sinon
-cette inéquation étant absurde.
+cette inéquation étant absurde.
 *)
+
+exception Contradiction of (rational * bool * rational list) list
+
 let unsolvable lie =
    let lr = deduce lie in
-   let res = ref [] in
-   (try (List.iter (fun e ->
-         match e with
-           {coef=[c];hist=lc;strict=s} ->
-		  if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
-                  then (res := [c,s,lc];
-			raise (Failure "contradiction found"))
-          |_->assert false)
-			     lr)
-   with e when Errors.noncritical e -> ());
-   !res
-;;
+   let check = function
+     | {coef=[c];hist=lc;strict=s} ->
+       if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
+       then raise (Contradiction [c,s,lc])
+     |_->assert false
+   in
+   try List.iter check lr; []
+   with Contradiction l -> l
 
 (* Exemples:
 
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 763383dd..8006a3e1 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.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,25 +8,24 @@
 
 
 
-(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
-des inéquations et équations sont entiers. En attendant la tactique Field.
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
+des inéquations et équations sont entiers. En attendant la tactique Field.
 *)
 
 open Term
 open Tactics
-open Clenv
 open Names
-open Libnames
+open Globnames
 open Tacticals
 open Tacmach
 open Fourier
 open Contradiction
 
 (******************************************************************************
-Opérations sur les combinaisons linéaires affines.
-La partie homogène d'une combinaison linéaire est en fait une table de hash
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash
 qui donne le coefficient d'un terme du calcul des constructions,
-qui est zéro si le terme n'y est pas.
+qui est zéro si le terme n'y est pas.
 *)
 
 module Constrhash = Hashtbl.Make
@@ -40,12 +39,11 @@ type flin = {fhom: rational Constrhash.t;
 
 let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};;
 
-let flin_coef f x = try (Constrhash.find f.fhom x) with Not_found -> r0;;
+let flin_coef f x = try Constrhash.find f.fhom x with Not_found -> r0;;
 
 let flin_add f x c =
     let cx = flin_coef f x in
-    Constrhash.remove f.fhom x;
-    Constrhash.add f.fhom x (rplus cx c);
+    Constrhash.replace f.fhom x (rplus cx c);
     f
 ;;
 let flin_add_cste f c =
@@ -75,24 +73,25 @@ let flin_emult a f =
 ;;
 
 (*****************************************************************************)
-open Vernacexpr
 
 type ineq = Rlt | Rle | Rgt | Rge
 
 let string_of_R_constant kn =
   match Names.repr_con kn with
     | MPfile dir, sec_dir, id when
-	sec_dir = empty_dirpath &&
-	string_of_dirpath dir = "Coq.Reals.Rdefinitions"
-	-> string_of_label id
+	sec_dir = DirPath.empty &&
+	DirPath.to_string dir = "Coq.Reals.Rdefinitions"
+	-> Label.to_string id
     | _ -> "constant_not_of_R"
 
 let rec string_of_R_constr c =
  match kind_of_term c with
    Cast (c,_,_) -> string_of_R_constr c
-  |Const c -> string_of_R_constant c
+  |Const (c,_) -> string_of_R_constant c
   | _ -> "not_of_constant"
 
+exception NoRational
+
 let rec rational_of_constr c =
   match kind_of_term c with
   | Cast (c,_,_) -> (rational_of_constr c)
@@ -114,15 +113,17 @@ let rec rational_of_constr c =
 	 | "Rminus" ->
 	     rminus (rational_of_constr args.(0))
                     (rational_of_constr args.(1))
-	 | _ -> failwith "not a rational")
-  | Const kn ->
+	 | _ -> raise NoRational)
+  | Const (kn,_) ->
       (match (string_of_R_constant kn) with
 	       "R1" -> r1
               |"R0" -> r0
-              |  _ -> failwith "not a rational")
-  |  _ -> failwith "not a rational"
+              |  _ -> raise NoRational)
+  |  _ -> raise NoRational
 ;;
 
+exception NoLinear
+
 let rec flin_of_constr c =
   try(
     match kind_of_term c with
@@ -138,39 +139,34 @@ let rec flin_of_constr c =
              flin_minus (flin_of_constr args.(0))
 	                (flin_of_constr args.(1))
 	 | "Rmult"->
-	     (try (let a=(rational_of_constr args.(0)) in
-                     try (let b = (rational_of_constr args.(1)) in
-			    (flin_add_cste (flin_zero()) (rmult a b)))
-		     with e when Errors.noncritical e ->
-                       (flin_add (flin_zero())
-				 args.(1)
-				 a))
-	      with e when Errors.noncritical e ->
-                (flin_add (flin_zero())
-			  args.(0)
-			  (rational_of_constr args.(1))))
+	     (try
+                let a = rational_of_constr args.(0) in
+                try
+                  let b = rational_of_constr args.(1) in
+		  flin_add_cste (flin_zero()) (rmult a b)
+		with NoRational ->
+                  flin_add (flin_zero()) args.(1) a
+	      with NoRational ->
+                flin_add (flin_zero()) args.(0)
+		  (rational_of_constr args.(1)))
 	 | "Rinv"->
-	     let a=(rational_of_constr args.(0)) in
-	       flin_add_cste (flin_zero()) (rinv a)
+	     let a = rational_of_constr args.(0) in
+	     flin_add_cste (flin_zero()) (rinv a)
 	 | "Rdiv"->
-	     (let b=(rational_of_constr args.(1)) in
-		try (let a = (rational_of_constr args.(0)) in
-		       (flin_add_cste (flin_zero()) (rdiv a b)))
-		with e when Errors.noncritical e ->
-                  (flin_add (flin_zero())
-		            args.(0)
-                            (rinv b)))
-         |_->assert false)
-  | Const c ->
+	     (let b = rational_of_constr args.(1) in
+	      try
+                let a = rational_of_constr args.(0) in
+	        flin_add_cste (flin_zero()) (rdiv a b)
+	      with NoRational ->
+                flin_add (flin_zero()) args.(0) (rinv b))
+         |_-> raise NoLinear)
+  | Const (c,_) ->
         (match (string_of_R_constant c) with
 	       "R1" -> flin_one ()
               |"R0" -> flin_zero ()
-              |_-> assert false)
-  |_-> assert false)
-  with e when Errors.noncritical e ->
-    flin_add (flin_zero())
-                     c
-	             r1
+              |_-> raise NoLinear)
+  |_-> raise NoLinear)
+  with NoRational | NoLinear -> flin_add (flin_zero()) c r1
 ;;
 
 let flin_to_alist f =
@@ -179,9 +175,9 @@ let flin_to_alist f =
     !res
 ;;
 
-(* Représentation des hypothèses qui sont des inéquations ou des équations.
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
 *)
-type hineq={hname:constr; (* le nom de l'hypothèse *)
+type hineq={hname:constr; (* le nom de l'hypothèse *)
             htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
             hleft:constr;
             hright:constr;
@@ -189,54 +185,57 @@ type hineq={hname:constr; (* le nom de l'hypothèse *)
             hstrict:bool}
 ;;
 
-(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
 *)
+
+exception NoIneq
+
 let ineq1_of_constr (h,t) =
     match (kind_of_term t) with
-       App (f,args) ->
-         (match kind_of_term f with
-           Const c when Array.length args = 2 ->
-             let t1= args.(0) in
-             let t2= args.(1) in
+      | App (f,args) ->
+        (match kind_of_term f with
+          | Const (c,_) when Array.length args = 2 ->
+            let t1= args.(0) in
+            let t2= args.(1) in
             (match (string_of_R_constant c) with
-		 "Rlt" -> [{hname=h;
+	      |"Rlt" -> [{hname=h;
                            htype="Rlt";
 		           hleft=t1;
 			   hright=t2;
 			   hflin= flin_minus (flin_of_constr t1)
                                              (flin_of_constr t2);
 			   hstrict=true}]
-		|"Rgt" -> [{hname=h;
+	      |"Rgt" -> [{hname=h;
                            htype="Rgt";
 		           hleft=t2;
 			   hright=t1;
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=true}]
-		|"Rle" -> [{hname=h;
+	      |"Rle" -> [{hname=h;
                            htype="Rle";
 		           hleft=t1;
 			   hright=t2;
 			   hflin= flin_minus (flin_of_constr t1)
                                              (flin_of_constr t2);
 			   hstrict=false}]
-		|"Rge" -> [{hname=h;
+	      |"Rge" -> [{hname=h;
                            htype="Rge";
 		           hleft=t2;
 			   hright=t1;
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=false}]
-                |_->assert false)
-          | Ind (kn,i) ->
-	      if IndRef(kn,i) = Coqlib.glob_eq then
-		           let t0= args.(0) in
-                           let t1= args.(1) in
-                           let t2= args.(2) in
-		    (match (kind_of_term t0) with
-                         Const c ->
-			   (match (string_of_R_constant c) with
-			      "R"->
+              |_-> raise NoIneq)
+          | Ind ((kn,i),_) ->
+            if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq;
+            let t0= args.(0) in
+            let t1= args.(1) in
+            let t2= args.(2) in
+	    (match (kind_of_term t0) with
+              | Const (c,_) ->
+		(match (string_of_R_constant c) with
+		  | "R"->
                          [{hname=h;
                            htype="eqTLR";
 		           hleft=t1;
@@ -251,20 +250,18 @@ let ineq1_of_constr (h,t) =
 			   hflin= flin_minus (flin_of_constr t2)
                                              (flin_of_constr t1);
 			   hstrict=false}]
-                           |_-> assert false)
-                         |_-> assert false)
-	      else
-		assert false
-          |_-> assert false)
-        |_-> assert false
+                  |_-> raise NoIneq)
+              |_-> raise NoIneq)
+          |_-> raise NoIneq)
+      |_-> raise NoIneq
 ;;
 
-(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
 *)
 
 let fourier_lineq lineq1 =
    let nvar=ref (-1) in
-   let hvar=Constrhash.create 50 in (* la table des variables des inéquations *)
+   let hvar=Constrhash.create 50 in (* la table des variables des inéquations *)
    List.iter (fun f ->
 		Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin
 				nvar:=(!nvar)+1;
@@ -273,7 +270,7 @@ let fourier_lineq lineq1 =
                   f.hflin.fhom)
              lineq1;
    let sys= List.map (fun h->
-               let v=Array.create ((!nvar)+1) r0 in
+               let v=Array.make ((!nvar)+1) r0 in
                Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c)
                   h.hflin.fhom;
                ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
@@ -345,14 +342,14 @@ let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le")
 let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp")
 
 (******************************************************************************
-Construction de la preuve en cas de succès de la méthode de Fourier,
+Construction de la preuve en cas de succès de la méthode de Fourier,
 i.e. on obtient une contradiction.
 *)
 let is_int x = (x.den)=1
 ;;
 
 (* fraction = couple (num,den) *)
-let rec rational_to_fraction x= (x.num,x.den)
+let rational_to_fraction x= (x.num,x.den)
 ;;
 
 (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
@@ -363,7 +360,7 @@ let int_to_real n =
    then get coq_R0
    else
      (let s=ref (get coq_R1) in
-      for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
+      for _i = 1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
       if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s)
 ;;
 (* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
@@ -379,11 +376,11 @@ let rational_to_real x =
 let tac_zero_inf_pos gl (n,d) =
    let tacn=ref (apply (get coq_Rlt_zero_1)) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do
-       tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
+   for _i = 1 to n - 1 do
+       tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
+   for _i = 1 to d - 1 do
+       tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (Tacticals.New.tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
 ;;
 
 (* preuve que 0<=n*1/d
@@ -393,11 +390,11 @@ let tac_zero_infeq_pos gl (n,d)=
                  then (apply (get coq_Rle_zero_zero))
                  else (apply (get coq_Rle_zero_1))) in
    let tacd=ref (apply (get coq_Rlt_zero_1)) in
-   for i=1 to n-1 do
-       tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
-   for i=1 to d-1 do
-       tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
-   (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
+   for  _i = 1 to n - 1 do
+       tacn:=(Tacticals.New.tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
+   for _i = 1 to d - 1 do
+       tacd:=(Tacticals.New.tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+   (Tacticals.New.tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
 ;;
 
 (* preuve que 0<(-n)*(1/d) => False
@@ -405,14 +402,14 @@ let tac_zero_infeq_pos gl (n,d)=
 let tac_zero_inf_false gl (n,d) =
     if n=0 then (apply (get coq_Rnot_lt0))
     else
-     (tclTHEN (apply (get coq_Rle_not_lt))
+     (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt))
 	      (tac_zero_infeq_pos gl (-n,d)))
 ;;
 
 (* preuve que 0<=(-n)*(1/d) => False
 *)
 let tac_zero_infeq_false gl (n,d) =
-     (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
+     (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
 	      (tac_zero_inf_pos gl (-n,d)))
 ;;
 
@@ -425,18 +422,16 @@ let my_cut c gl=
 
 let exact = exact_check;;
 
-let tac_use h = match h.htype with
-               "Rlt" -> exact h.hname
-              |"Rle" -> exact h.hname
-              |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt))
-                                (exact h.hname))
-              |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le))
-                                (exact h.hname))
-              |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le))
-                                (exact h.hname))
-              |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le))
-                                (exact h.hname))
-              |_->assert false
+let tac_use h =
+  let tac = exact h.hname in
+  match h.htype with
+    "Rlt" -> tac
+  |"Rle" -> tac
+  |"Rgt" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_gt_to_lt)) tac)
+  |"Rge" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_ge_to_le)) tac)
+  |"eqTLR" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) tac)
+  |"eqTRL" -> (Tacticals.New.tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) tac)
+  |_->assert false
 ;;
 
 (*
@@ -464,58 +459,61 @@ let mkAppL a =
    mkApp(List.hd l, Array.of_list (List.tl l))
 ;;
 
-(* Résolution d'inéquations linéaires dans R *)
-let rec fourier gl=
+exception GoalDone
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec fourier () =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
     Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
-    let goal = strip_outer_cast (pf_concl gl) in
-    let fhyp=id_of_string "new_hyp_for_fourier" in
-    (* si le but est une inéquation, on introduit son contraire,
-       et le but à prouver devient False *)
-    try (let tac =
-     match (kind_of_term goal) with
+    let goal = strip_outer_cast concl in
+    let fhyp=Id.of_string "new_hyp_for_fourier" in
+    (* si le but est une inéquation, on introduit son contraire,
+       et le but à prouver devient False *)
+    try 
+      match (kind_of_term goal) with
       App (f,args) ->
       (match (string_of_R_constr f) with
 	     "Rlt" ->
-	       (tclTHEN
-	         (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
+	       (Tacticals.New.tclTHEN
+	         (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_ge_lt))
 			  (intro_using  fhyp))
-		 fourier)
+		 (fourier ()))
 	    |"Rle" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_gt_le))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_gt_le))
 		       (intro_using  fhyp))
-			fourier)
+			(fourier ()))
 	    |"Rgt" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_le_gt))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_le_gt))
 		       (intro_using  fhyp))
-	      fourier)
+	      (fourier ()))
 	    |"Rge" ->
-	     (tclTHEN
-	      (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
+	     (Tacticals.New.tclTHEN
+	      (Tacticals.New.tclTHEN (apply (get coq_Rfourier_not_lt_ge))
 		       (intro_using  fhyp))
-	      fourier)
-	    |_->assert false)
-        |_->assert false
-      in tac gl)
-     with e when Errors.noncritical e ->
-    (* les hypothèses *)
+	      (fourier ()))
+	    |_-> raise GoalDone)
+        |_-> raise GoalDone
+     with GoalDone ->
+    (* les hypothèses *)
     let hyps = List.map (fun (h,t)-> (mkVar h,t))
-                        (list_of_sign (pf_hyps gl)) in
+                        (list_of_sign (Proofview.Goal.hyps gl)) in
     let lineq =ref [] in
     List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
-		        with e when Errors.noncritical e -> ())
+		        with NoIneq -> ())
               hyps;
-    (* lineq = les inéquations découlant des hypothèses *)
-    if !lineq=[] then Util.error "No inequalities";
+    (* lineq = les inéquations découlant des hypothèses *)
+    if !lineq=[] then Errors.error "No inequalities";
     let res=fourier_lineq (!lineq) in
-    let tac=ref tclIDTAC in
+    let tac=ref (Proofview.tclUNIT ()) in
     if res=[]
-    then Util.error "fourier failed"
-    (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
+    then Errors.error "fourier failed"
+    (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
     else (match res with
         [(cres,sres,lc)]->
-    (* lc=coefficients multiplicateurs des inéquations
+    (* lc=coefficients multiplicateurs des inéquations
        qui donnent 0<cres ou 0<=cres selon sres *)
 	(*print_string "Fourier's method can prove the goal...";flush stdout;*)
           let lutil=ref [] in
@@ -525,7 +523,7 @@ let rec fourier gl=
         		  then (lutil:=(h,c)::(!lutil)(*;
 				print_rational(c);print_string " "*)))
                     (List.combine (!lineq) lc);
-       (* on construit la combinaison linéaire des inéquation *)
+       (* on construit la combinaison linéaire des inéquation *)
              (match (!lutil) with
           (h1,c1)::lutil ->
 	  let s=ref (h1.hstrict) in
@@ -554,11 +552,11 @@ let rec fourier gl=
 	   let tc=rational_to_real cres in
        (* puis sa preuve *)
            let tac1=ref (if h1.hstrict
-                         then (tclTHENS (apply (get coq_Rfourier_lt))
+                         then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt))
                                  [tac_use h1;
                                   tac_zero_inf_pos  gl
                                       (rational_to_fraction c1)])
-                         else (tclTHENS (apply (get coq_Rfourier_le))
+                         else (Tacticals.New.tclTHENS (apply (get coq_Rfourier_le))
                                  [tac_use h1;
 				  tac_zero_inf_pos  gl
                                       (rational_to_fraction c1)])) in
@@ -566,20 +564,20 @@ let rec fourier gl=
            List.iter (fun (h,c)->
              (if (!s)
 	      then (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
+	            then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_lt))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
+	            else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt_le))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)]))
 	      else (if h.hstrict
-	            then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
+	            then tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_lt))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])
-	            else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
+	            else tac1:=(Tacticals.New.tclTHENS (apply (get coq_Rfourier_le_le))
 			       [!tac1;tac_use h;
 			        tac_zero_inf_pos  gl
                                       (rational_to_fraction c)])));
@@ -589,42 +587,43 @@ let rec fourier gl=
                       then tac_zero_inf_false gl (rational_to_fraction cres)
                       else tac_zero_infeq_false gl (rational_to_fraction cres)
            in
-           tac:=(tclTHENS (my_cut ineq)
-                     [tclTHEN (change_in_concl None
+           tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq))
+                     [Tacticals.New.tclTHEN (change_concl
 			       (mkAppL [| get coq_not; ineq|]
 				       ))
-		      (tclTHEN (apply (if sres then get coq_Rnot_lt_lt
+		      (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt
 					       else get coq_Rnot_le_le))
-			    (tclTHENS (Equality.replace
+			    (Tacticals.New.tclTHENS (Equality.replace
 				       (mkAppL [|get coq_Rminus;!t2;!t1|]
 					       )
 				       tc)
 		 	       [tac2;
-                                (tclTHENS
+                                (Tacticals.New.tclTHENS
 				  (Equality.replace
 				    (mkApp (get coq_Rinv,
 				      [|get coq_R1|]))
 				    (get coq_R1))
-(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
+(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
 
-      			        [tclORELSE
-                                   (Ring.polynom [])
-                                   tclIDTAC;
-					  (tclTHEN (apply (get coq_sym_eqT))
-						(apply (get coq_Rinv_1)))]
+      			        [Tacticals.New.tclORELSE
+                                   (* TODO : Ring.polynom []*) (Proofview.tclUNIT ())
+                                   (Proofview.tclUNIT ());
+				 Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq ->
+					  (Tacticals.New.tclTHEN (apply symeq)
+						(apply (get coq_Rinv_1))))]
 
 					 )
 				]));
                        !tac1]);
-	   tac:=(tclTHENS (cut (get coq_False))
-				  [tclTHEN intro (contradiction None);
+	   tac:=(Tacticals.New.tclTHENS (cut (get coq_False))
+				  [Tacticals.New.tclTHEN intro (contradiction None);
 				   !tac])
       |_-> assert false) |_-> assert false
 	  );
 (*    ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
-      (!tac gl)
+      !tac
 (*      ((tclABSTRACT None !tac) gl) *)
-
+  end
 ;;
 
 (*
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index c6c4d68f..d00f0564 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -1,15 +1,17 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open FourierR
 
+DECLARE PLUGIN "fourier_plugin"
+
 TACTIC EXTEND fourier
-  [ "fourierz" ] -> [ fourier ]
+  [ "fourierz" ] -> [ fourier () ]
 END
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index 51ede26e..a63941f0 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -1,10 +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        *)
 (************************************************************************)
+
+Require Import PeanoNat.
+
 Require Compare_dec.
 Require Wf_nat.
 
@@ -19,30 +22,29 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
   end.
 End Iter.
 
-Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
-  intro p; intro p'; change (S p <= S (S (p + p')));
-    apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
-    apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
+Theorem le_lt_SS x y : x <= y -> x < S (S y).
+Proof.
+ intros. now apply Nat.lt_succ_r, Nat.le_le_succ_r.
 Qed.
 
-
-Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
-  intro p; intro p'; change (S p' <= S (p + p'));
-    apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
-       apply Plus.le_plus_r.
+Theorem Splus_lt x y : y < S (x + y).
+Proof.
+ apply Nat.lt_succ_r. rewrite Nat.add_comm. apply Nat.le_add_r.
 Qed.
 
-Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
-intro x; intro y; intro H; change (S x <= S (S y));
-    apply le_S; apply Gt.gt_le_S; change (x < S y);
-    apply Lt.le_lt_n_Sm; exact H.
+Theorem SSplus_lt x y : x < S (S (x + y)).
+Proof.
+ apply le_lt_SS, Nat.le_add_r.
 Qed.
 
 Inductive max_type (m n:nat) : Set :=
   cmt : forall v, m <= v -> n <= v -> max_type m n.
 
-Definition max : forall m n:nat, max_type m n.
-intros m n; case (Compare_dec.le_gt_dec m n).
-intros h; exists n; [exact h | apply le_n].
-intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h].
+Definition max m n : max_type m n.
+Proof.
+ destruct (Compare_dec.le_gt_dec m n) as [h|h].
+ - exists n; [exact h | apply le_n].
+ - exists m; [apply le_n | apply Nat.lt_le_incl; exact h].
 Defined.
+
+Definition Acc_intro_generator_function := fun A R => @Acc_intro_generator A R 100.
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index b5876ffa..c8214ada 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,45 +1,37 @@
 open Printer
+open Errors
 open Util
 open Term
+open Vars
+open Context
 open Namegen
 open Names
 open Declarations
+open Declareops
 open Pp
-open Entries
-open Hiddentac
-open Evd
 open Tacmach
 open Proof_type
 open Tacticals
 open Tactics
 open Indfun_common
 open Libnames
+open Globnames
+open Misctypes
 
-let msgnl = Pp.msgnl
-
+(* let msgnl = Pp.msgnl *)
 
+(*
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
-  else ()
-
-let observennl strm =
-  if do_observe ()
-  then begin Pp.msg strm;Pp.pp_flush () end
+  then Pp.msg_debug strm
   else ()
 
-
-
-
 let do_observe_tac s tac g =
  try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
- with reraise ->
-   let e = Cerrors.process_vernac_interp_error reraise in
-   let goal =
-     try (Printer.pr_goal g)
-     with e when Errors.noncritical e -> assert false
-   in
-   msgnl (str "observation "++ s++str " raised exception " ++
+ with e ->
+   let e = Cerrors.process_vernac_interp_error e in
+   let goal = begin try (Printer.pr_goal g) with _ -> assert false end in
+   msg_debug (str "observation "++ s++str " raised exception " ++
 	    Errors.print e ++ str " on goal " ++ goal );
    raise e;;
 
@@ -49,16 +41,55 @@ let observe_tac_stream s tac g =
   else tac g
 
 let observe_tac s tac g = observe_tac_stream (str s) tac g
+  *)
+
+
+let debug_queue = Stack.create ()
+
+let rec print_debug_queue b e = 
+  if  not (Stack.is_empty debug_queue) 
+  then
+    begin
+      let lmsg,goal = Stack.pop debug_queue in 
+      if b then 
+	Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+      else
+	begin
+	  Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	end;
+      print_debug_queue false e;
+    end
 
-(* let tclTRYD tac =  *)
-(*   if  !Flags.debug  || do_observe () *)
-(*   then (fun g -> try (\* do_observe_tac ""  *\)tac g with _ -> tclIDTAC g) *)
-(*   else tac *)
+let observe strm =
+  if do_observe ()
+  then Pp.msg_debug strm
+  else ()
+
+let do_observe_tac s tac g = 
+  let goal = Printer.pr_goal g in
+  let lmsg = (str "observation : ") ++ s in 
+  Stack.push (lmsg,goal) debug_queue;
+  try 
+    let v = tac g in 
+    ignore(Stack.pop debug_queue);
+    v
+  with reraise ->
+    let reraise = Errors.push reraise in
+    if not (Stack.is_empty debug_queue)
+    then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+    iraise reraise
+
+let observe_tac_stream s tac g =
+  if do_observe ()
+  then do_observe_tac s tac g
+  else tac g
 
+let observe_tac s = observe_tac_stream (str s)
+  
 
 let list_chop ?(msg="") n l =
   try
-    list_chop n l
+    List.chop n l
   with Failure (msg') ->
     failwith (msg ^ msg')
 
@@ -70,17 +101,17 @@ let make_refl_eq constructor type_of_t t  =
 
 type pte_info =
     {
-      proving_tac : (identifier list ->  Tacmach.tactic);
+      proving_tac : (Id.t list ->  Tacmach.tactic);
       is_valid : constr -> bool
     }
 
-type ptes_info = pte_info Idmap.t
+type ptes_info = pte_info Id.Map.t
 
 type 'a dynamic_info =
     {
       nb_rec_hyps : int;
-      rec_hyps : identifier list ;
-      eq_hyps : identifier list;
+      rec_hyps : Id.t list ;
+      eq_hyps : Id.t list;
       info : 'a
     }
 
@@ -89,28 +120,17 @@ type body_info = constr dynamic_info
 
 let finish_proof dynamic_infos g =
   observe_tac "finish"
-    ( h_assumption)
+    (Proofview.V82.of_tactic assumption)
     g
 
 
 let refine c =
-  Tacmach.refine_no_check c
+  Tacmach.refine c
 
 let thin l =
   Tacmach.thin_no_check l
 
-
-let cut_replacing id t tac :tactic=
-  tclTHENS (cut t)
-    [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
-      tac
-    ]
-
-let intro_erasing id = tclTHEN (thin [id]) (introduction id)
-
-
-
-let rec_hyp_id = id_of_string "rec_hyp"
+let eq_constr u v = eq_constr_nounivs u v
 
 let is_trivial_eq t =
   let res =   try
@@ -157,11 +177,11 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
   fun g ->
     let prov_id = pf_get_new_id hyp_id g in
     tclTHENS
-      ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
+      ((* observe_tac msg *) Proofview.V82.of_tactic (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac))))
       [tclTHENLIST
       [
 	(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
-	(* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
+	(* observe_tac "change_hyp_with_using rename " *) (Proofview.V82.of_tactic (rename_hyp [prov_id,hyp_id]))
       ]] g
 
 exception TOREMOVE
@@ -171,7 +191,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) =
   let nb_intros = List.length context in
   tclTHENLIST
     [
-      tclDO nb_intros intro; (* introducing context *)
+      tclDO nb_intros (Proofview.V82.of_tactic intro); (* introducing context *)
       (fun g ->
 	 let context_hyps =
 	   fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
@@ -188,7 +208,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) =
 
 
 let find_rectype env c =
-  let (t, l) = decompose_app (Reduction.whd_betaiotazeta c) in
+  let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in
   match kind_of_term t with
   | Ind ind -> (t, l)
   | Construct _ -> (t,l)
@@ -216,7 +236,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
       failwith "NoChange";
     end
   in
-  let eq_constr = Reductionops.is_conv env sigma in
+  let eq_constr = Evarconv.e_conv env (ref sigma) in
   if not (noccurn 1 end_of_type)
   then nochange "dependent"; (* if end_of_type depends on this term we don't touch it  *)
     if not (isApp t) then nochange "not an equality";
@@ -245,12 +265,12 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	let t2 = destRel t2  in
 	begin
 	  try
-	    let t1' = Intmap.find t2 sub in
+	    let t1' = Int.Map.find t2 sub in
 	    if not (eq_constr t1 t1') then nochange "twice bound variable";
 	    sub
 	  with Not_found ->
 	    assert (closed0 t1);
-	    Intmap.add t2 t1 sub
+	    Int.Map.add t2 t1 sub
 	end
       else if isAppConstruct t1 && isAppConstruct t2
       then
@@ -264,18 +284,17 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
       else
 	if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2)  "cannot solve (diff)"
     in
-    let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in
+    let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in
     let sub = compute_substitution sub (fst t1) (fst t2) in
     let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *)
     let new_end_of_type =
       (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4
 	 Can be safely replaced by the next comment for Ocaml >= 3.08.4
       *)
-      let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
-      let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
+      let sub = Int.Map.bindings sub in
       List.fold_left (fun end_of_type (i,t)  -> lift 1 (substnl  [t] (i-1) end_of_type))
 	end_of_type_with_pop
-	sub''
+	sub
     in
     let old_context_length = List.length context + 1 in
     let witness_fun =
@@ -284,11 +303,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
 	      )
     in
     let new_type_of_hyp,ctxt_size,witness_fun =
-      list_fold_left_i
+      List.fold_left_i
 	(fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
 	   try
-	     let witness = Intmap.find i sub in
-	     if b' <> None then anomaly "can not redefine a rel!";
+	     let witness = Int.Map.find i sub in
+	     if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!");
 	     (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
 	   with Not_found  ->
 	     (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
@@ -304,12 +323,13 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
     in
     let prove_new_hyp : tactic =
       tclTHEN
-	(tclDO ctxt_size intro)
+	(tclDO ctxt_size (Proofview.V82.of_tactic intro))
 	(fun g ->
 	   let all_ids = pf_ids_of_hyps g in
 	   let new_ids,_  = list_chop ctxt_size all_ids in
 	   let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
-	   refine to_refine g
+	   let evm, _ = pf_apply Typing.e_type_of g to_refine in
+	     tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g
 	)
     in
     let simpl_eq_tac =
@@ -332,14 +352,14 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type  =
     new_ctxt,new_end_of_type,simpl_eq_tac
 
 
-let is_property ptes_info t_x full_type_of_hyp =
+let is_property (ptes_info:ptes_info) t_x full_type_of_hyp =
   if isApp t_x
   then
     let pte,args = destApp t_x in
-    if isVar pte && array_for_all closed0 args
+    if isVar pte && Array.for_all closed0 args
     then
       try
-	let info = Idmap.find (destVar pte) ptes_info in
+	let info = Id.Map.find (destVar pte) ptes_info in
 	info.is_valid full_type_of_hyp
       with Not_found -> false
     else false
@@ -352,10 +372,10 @@ let isLetIn t =
 
 
 let h_reduce_with_zeta =
-  h_reduce
-    (Glob_term.Cbv
-       {Glob_term.all_flags
-	with Glob_term.rDelta = false;
+  reduce
+    (Genredexpr.Cbv
+       {Redops.all_flags
+	with Genredexpr.rDelta = false;
        })
 
 
@@ -374,17 +394,17 @@ let rewrite_until_var arg_num eq_ids : tactic =
     then tclIDTAC g
     else
       match eq_ids with
-	| [] -> anomaly "Cannot find a way to prove recursive property";
+	| [] -> anomaly (Pp.str "Cannot find a way to prove recursive property");
 	| eq_id::eq_ids ->
 	    tclTHEN
-	      (tclTRY (Equality.rewriteRL (mkVar eq_id)))
+	      (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id))))
 	      (do_rewrite eq_ids)
 	      g
   in
   do_rewrite eq_ids
 
 
-let rec_pte_id = id_of_string "Hrec"
+let rec_pte_id = Id.of_string "Hrec"
 let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
   let coq_False = Coqlib.build_coq_False () in
   let coq_True = Coqlib.build_coq_True () in
@@ -398,13 +418,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	 decompose_prod_n_assum (List.length context) reduced_type_of_hyp
       in
         tclTHENLIST
-	[
-	  h_reduce_with_zeta
-	    (Tacticals.onHyp hyp_id)
-	  ;
-	  scan_type new_context new_typ_of_hyp
-
-	]
+	[ h_reduce_with_zeta (Locusops.onHyp hyp_id);
+	  scan_type new_context new_typ_of_hyp ]
     else if isProd type_of_hyp
     then
       begin
@@ -413,14 +428,14 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	if is_property ptes_infos t_x actual_real_type_of_hyp then
 	  begin
 	    let pte,pte_args =  (destApp t_x) in
-	    let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in
+	    let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in
 	    let popped_t' = Termops.pop t' in
 	    let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in
 	    let prove_new_type_of_hyp =
 	      let context_length = List.length context in
 	      tclTHENLIST
 		[
-		  tclDO context_length intro;
+		  tclDO context_length (Proofview.V82.of_tactic intro);
 		  (fun g ->
 		     let context_hyps_ids =
 		       fst (list_chop ~msg:"rec hyp : context_hyps"
@@ -434,7 +449,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 		     in
 (* 		     observe_tac "rec hyp " *)
 		       (tclTHENS
-		       (assert_tac (Name rec_pte_id) t_x)
+		       (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x))
 		       [
 			 (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps);
 (* 			observe_tac "prove rec hyp" *)
@@ -471,7 +486,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
 	  let prove_trivial =
 	    let nb_intro = List.length context in
 	    tclTHENLIST [
-	      tclDO nb_intro intro;
+	      tclDO nb_intro (Proofview.V82.of_tactic intro);
 	      (fun g ->
 		 let context_hyps =
 		   fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
@@ -533,7 +548,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
     thin [hyp_id],[]
 
 
-let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
+let clean_goal_with_heq ptes_infos continue_tac (dyn_infos:body_info) =
   fun g ->
     let env = pf_env g
     and sigma = project g
@@ -562,7 +577,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos  =
       ]
       g
 
-let heq_id = id_of_string "Heq"
+let heq_id = Id.of_string "Heq"
 
 let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
   fun g ->
@@ -570,12 +585,12 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
     tclTHENLIST
       [
 	(* We first introduce the variables *)
-	tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
+	tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps));
 	(* Then the equation itself *)
-	intro_using heq_id;
+	Proofview.V82.of_tactic (intro_using heq_id);
 	onLastHypId (fun heq_id -> tclTHENLIST [
 	(* Then the new hypothesis *)
-	tclMAP introduction_no_check dyn_infos.rec_hyps;
+	tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps;
 	observe_tac "after_introduction" (fun g' ->
 	   (* We get infos on the equations introduced*)
 	   let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
@@ -585,9 +600,9 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
 	       | App(f,[| _;_;args2 |]) -> args2
 	       | _ ->
 		   observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
-			      pr_lconstr_env (pf_env g') new_term_value_eq
+			      pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq
 			   );
-		   anomaly "cannot compute new term value"
+		   anomaly (Pp.str "cannot compute new term value")
 	   in
 	 let fun_body =
 	   mkLambda(Anonymous,
@@ -615,17 +630,20 @@ let my_orelse tac1 tac2 g =
 (*     observe (str "using snd tac since : " ++ Errors.print e); *)
     tac2 g
 
-let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
+let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id =
   let args = Array.of_list (List.map mkVar  args_id) in
   let instanciate_one_hyp hid =
     my_orelse
       ( (* we instanciate the hyp if possible  *)
 	fun g ->
 	  let prov_hid = pf_get_new_id hid g in
+	  let c = mkApp(mkVar hid,args) in
+	  let evm, _ = pf_apply Typing.e_type_of g c in
 	  tclTHENLIST[
-	    pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
+            Refiner.tclEVARS evm;
+	    Proofview.V82.of_tactic (pose_proof (Name prov_hid) c);
 	    thin [hid];
-	    h_rename [prov_hid,hid]
+	    Proofview.V82.of_tactic (rename_hyp [prov_hid,hid])
 	  ] g
       )
       ( (*
@@ -642,23 +660,23 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
 	)
       )
   in
-  if args_id = []
+  if List.is_empty args_id
   then
     tclTHENLIST [
-      tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+      tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps;
       do_prove hyps
     ]
   else
     tclTHENLIST
       [
-	tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+	tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps;
 	tclMAP instanciate_one_hyp hyps;
 	(fun g ->
 	   let all_g_hyps_id =
-	     List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
+	     List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty
 	   in
 	   let remaining_hyps =
-	     List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
+	     List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps
 	   in
 	   do_prove remaining_hyps g
 	  )
@@ -687,11 +705,11 @@ let build_proof
 		  in
 		  tclTHENSEQ
 		    [
-		      h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+		      Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
 		      thin dyn_infos.rec_hyps;
-		      pattern_option [(false,[1]),t] None;
+		      pattern_option [Locus.AllOccurrencesBut [1],t] None;
 		      (fun g -> observe_tac "toto" (
-			 tclTHENSEQ [h_simplest_case t;
+			 tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t);
 				     (fun g' ->
 					let g'_nb_prod = nb_prod (pf_concl g') in
 					let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
@@ -716,7 +734,7 @@ let build_proof
 		match kind_of_term( pf_concl g) with
 		  | Prod _ ->
 		      tclTHEN
-			intro
+			(Proofview.V82.of_tactic intro)
 			(fun g' ->
 			   let (id,_,_) = pf_last_hyp g' in
 			   let new_term =
@@ -746,6 +764,7 @@ let build_proof
 	      begin
 		match kind_of_term f with
 		  | App _ -> assert false (* we have collected all the app in decompose_app *)
+		  | Proj _ -> assert false (*FIXME*)
 		  | Var _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ | Sort _ | Prod _ ->
 		      let new_infos =
 			{ dyn_infos with
@@ -753,7 +772,7 @@ let build_proof
 			}
 		      in
 		      build_proof_args do_finalize new_infos  g
-		  | Const c when not (List.mem c fnames) ->
+		  | Const (c,_) when not (List.mem_f Constant.equal c fnames) ->
 		      let new_infos =
 			{ dyn_infos with
 			    info = (f,args)
@@ -775,9 +794,10 @@ let build_proof
 
 		      tclTHENLIST
 			[tclMAP
-			   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+			   (fun hyp_id ->
+			     h_reduce_with_zeta (Locusops.onHyp hyp_id))
 			   dyn_infos.rec_hyps;
-			 h_reduce_with_zeta Tacticals.onConcl;
+			 h_reduce_with_zeta Locusops.onConcl;
 			 build_proof do_finalize new_infos
 			]
 			g
@@ -797,6 +817,7 @@ let build_proof
 	  | Fix _ | CoFix _ ->
 	      error ( "Anonymous local (co)fixpoints are not handled yet")
 
+	  | Proj _ -> error "Prod"
 	  | Prod _ -> error "Prod"
 	  | LetIn _ ->
 	      let new_infos =
@@ -807,28 +828,28 @@ let build_proof
 
 	      tclTHENLIST
 		[tclMAP
-		   (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+		   (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id))
 		   dyn_infos.rec_hyps;
-		 h_reduce_with_zeta Tacticals.onConcl;
+		 h_reduce_with_zeta Locusops.onConcl;
 		 build_proof do_finalize new_infos
 		] g
-	  | Rel _ -> anomaly "Free var in goal conclusion !"
+	  | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
   and build_proof do_finalize dyn_infos g =
 (*     observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
-    observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
+    observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g
   and build_proof_args do_finalize dyn_infos (* f_args'  args *) :tactic =
     fun g ->
       let (f_args',args) = dyn_infos.info in
       let tac : tactic =
 	fun g ->
-	match args with
-	  | []  ->
+	  match args with
+	    | []  ->
 	      do_finalize {dyn_infos with info = f_args'} g
-	  | arg::args ->
-(* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
-(* 			fnl () ++  *)
-(* 			pr_goal (Tacmach.sig_it g) *)
-(* 			); *)
+	    | arg::args ->
+	      (* 		observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
+	      (* 			fnl () ++  *)
+	      (* 			pr_goal (Tacmach.sig_it g) *)
+	      (* 			); *)
 	      let do_finalize dyn_infos =
 		let new_arg = dyn_infos.info in
 		(* 		tclTRYD *)
@@ -842,14 +863,14 @@ let build_proof
 		g
       in
       (* observe_tac "build_proof_args" *) (tac ) g
-   in
-   let do_finish_proof dyn_infos =
+  in
+  let do_finish_proof dyn_infos =
      (* tclTRYD *) (clean_goal_with_heq
-      ptes_infos
-      finish_proof dyn_infos)
+		      ptes_infos
+		      finish_proof dyn_infos)
   in
-  (* observe_tac "build_proof" *)
-    (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
+    (* observe_tac "build_proof" *)
+  (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
 
 
 
@@ -863,18 +884,11 @@ let build_proof
 
 
 (* Proof of principles from structural functions *)
-let is_pte_type t =
-  isSort ((strip_prod t))
-
-let is_pte (_,_,t) = is_pte_type t
-
-
-
 
 type static_fix_info =
     {
       idx : int;
-      name : identifier;
+      name : Id.t;
       types : types;
       offset : int;
       nb_realargs : int;
@@ -901,9 +915,6 @@ let prove_rec_hyp fix_info  =
     is_valid = fun _ -> true
   }
 
-
-exception Not_Rec
-
 let generalize_non_dep hyp g =
 (*   observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
   let hyps = [hyp] in
@@ -911,17 +922,17 @@ let generalize_non_dep hyp g =
   let hyp_typ = pf_type_of g (mkVar hyp) in
   let to_revert,_ =
     Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
-      if List.mem hyp hyps
-	or List.exists (Termops.occur_var_in_decl env hyp) keep
-	or Termops.occur_var env hyp hyp_typ
-	or Termops.is_section_variable hyp (* should be dangerous *)
+      if Id.List.mem hyp hyps
+        || List.exists (Termops.occur_var_in_decl env hyp) keep
+	|| Termops.occur_var env hyp hyp_typ
+	|| Termops.is_section_variable hyp (* should be dangerous *)
       then (clear,decl::keep)
       else (hyp::clear,keep))
       ~init:([],[]) (pf_env g)
   in
 (*   observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
   tclTHEN
-    ((* observe_tac "h_generalize" *) (h_generalize  (List.map mkVar to_revert) ))
+    ((* observe_tac "h_generalize" *) (Simple.generalize  (List.map mkVar to_revert) ))
     ((* observe_tac "thin" *) (thin to_revert))
     g
 
@@ -936,11 +947,9 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 (*   observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
 (*   observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
 (*   observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
-  let f_def = Global.lookup_constant (destConst f) in
+  let f_def = Global.lookup_constant (fst (destConst f)) in
   let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
-  let f_body =
-    force (Option.get (body_of_constant f_def))
-  in
+  let f_body = Option.get (Global.body_of_constant_body f_def)in
   let params,f_body_with_params = decompose_lam_n nb_params f_body in
   let (_,num),(_,_,bodies) = destFix f_body_with_params in
   let fnames_with_params =
@@ -955,20 +964,20 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
   let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
 (*   observe (str "eq_rhs " ++  pr_lconstr eq_rhs); *)
   let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
-    (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
+    (Typeops.type_of_constant_type (Global.env ()) (*FIXME*)f_def.const_type) in
   let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
   let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in
-  let f_id = id_of_label (con_label (destConst f)) in
+  let f_id = Label.to_id (con_label (fst (destConst f))) in
   let prove_replacement =
     tclTHENSEQ
       [
-	tclDO (nb_params + rec_args_num + 1) intro;
+	tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro);
 	(* observe_tac "" *) (fun g ->
 	   let rec_id = pf_nth_hyp_id g 1 in
 	   tclTHENSEQ
 	     [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id);
-	      (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings));
-	      intros_reflexivity] g
+	      (* observe_tac "h_case" *) (Proofview.V82.of_tactic (simplest_case (mkVar rec_id)));
+	      (Proofview.V82.of_tactic intros_reflexivity)] g
 	)
       ]
   in
@@ -977,11 +986,12 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
       Ensures by: obvious
       i*)
     (mk_equation_id f_id)
-    (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-    lemma_type
-    (fun _ _ -> ());
-  Pfedit.by (prove_replacement);
-  Lemmas.save_named false
+    (Decl_kinds.Global, false, (Decl_kinds.Proof Decl_kinds.Theorem))
+  Evd.empty
+  lemma_type
+  (Lemmas.mk_hook (fun _ _ -> ()));
+  ignore (Pfedit.by (Proofview.V82.tactic prove_replacement));
+  Lemmas.save_proof (Vernacexpr.Proved(false,None))
 
 
 
@@ -989,10 +999,10 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
 let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
   let equation_lemma =
     try
-      let finfos = find_Function_infos (destConst f) in
+      let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in
       mkConst (Option.get finfos.equation_lemma)
     with (Not_found | Option.IsNone as e) ->
-      let f_id = id_of_label (con_label (destConst f)) in
+      let f_id = Label.to_id (con_label (fst (destConst f))) in
       (*i The next call to mk_equation_id is valid since we will construct the lemma
 	Ensures by: obvious
 	i*)
@@ -1001,12 +1011,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
       let _ =
 	match e with
 	  | Option.IsNone ->
-	      let finfos = find_Function_infos (destConst f) in
+	      let finfos = find_Function_infos (fst (destConst f)) in
 	      update_Function
 		{finfos with
 		   equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
 					      ConstRef c -> c
-					    | _ -> Util.anomaly "Not a constant"
+					    | _ -> Errors.anomaly (Pp.str "Not a constant")
 					 )
 		}
 	  | _ -> ()
@@ -1016,12 +1026,12 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
   in
   let nb_intro_to_do = nb_prod (pf_concl g) in
     tclTHEN
-      (tclDO nb_intro_to_do intro)
+      (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro))
       (
 	fun g' ->
 	  let just_introduced = nLastDecls nb_intro_to_do g' in
 	  let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
-	  tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
+	  tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g'
       )
       g
 
@@ -1034,7 +1044,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
       (fun na ->
 	 let new_id =
 	   match na with
-	       Name id -> fresh_id !avoid (string_of_id id)
+	       Name id -> fresh_id !avoid (Id.to_string id)
 	     | Anonymous -> fresh_id !avoid "H"
 	 in
 	 avoid := new_id :: !avoid;
@@ -1055,9 +1065,8 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
       }
     in
     let get_body const =
-      match body_of_constant (Global.lookup_constant const) with
-	| Some b ->
-	     let body = force b in
+      match Global.body_of_constant const with
+	| Some body ->
 	     Tacred.cbv_norm_flags
 	       (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
 	       (Global.env ())
@@ -1137,7 +1146,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		typess
 	    in
 	    let pte_to_fix,rev_info =
-	      list_fold_left_i
+	      List.fold_left_i
 		(fun i (acc_map,acc_info) (pte,_,_) ->
 		   let infos = info_array.(i) in
 		   let type_args,_ = decompose_prod infos.types in
@@ -1175,14 +1184,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		   in
 (* 		   observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++  *)
 (* 			      str " to " ++ Ppconstr.pr_id info.name); *)
-		   (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
+		   (Id.Map.add (Nameops.out_name pte) info acc_map,info::acc_info)
 		   )
 		0
-		(Idmap.empty,[])
+		(Id.Map.empty,[])
 		(List.rev princ_info.predicates)
 	    in
 	    pte_to_fix,List.rev rev_info
-	| _ -> Idmap.empty,[]
+	| _ -> Id.Map.empty,[]
     in
     let mk_fixes : tactic =
       let pre_info,infos = list_chop fun_num infos in
@@ -1194,19 +1203,19 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		(fun fi -> fi.name,fi.idx + 1 ,fi.types)
 		(pre_info@others_infos)
 	    in
-	    if other_fix_infos = []
+	    if List.is_empty other_fix_infos
 	    then
-	      (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
+	      (* observe_tac ("h_fix") *) (fix (Some this_fix_info.name) (this_fix_info.idx +1))
 	    else
-	      h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
-		other_fix_infos
-	| _ -> anomaly "Not a valid information"
+	      Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+		other_fix_infos 0
+	| _ -> anomaly (Pp.str "Not a valid information")
     in
     let first_tac : tactic = (* every operations until fix creations *)
       tclTHENSEQ
-	[ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
-	  (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
-	  (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
+	[ (* observe_tac "introducing params" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.params));
+	  (* observe_tac "introducing predictes" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.predicates));
+	  (* observe_tac "introducing branches" *) Proofview.V82.of_tactic (intros_using (List.rev_map id_of_decl princ_info.branches));
 	  (* observe_tac "building fixes" *) mk_fixes;
 	]
     in
@@ -1217,14 +1226,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	try
 	  let pte =
             try destVar pte
-            with e when Errors.noncritical e ->
-              anomaly "Property is not a variable"
+            with DestKO -> anomaly (Pp.str "Property is not a variable")
           in
-	  let fix_info = Idmap.find  pte ptes_to_fix in
+	  let fix_info = Id.Map.find  pte ptes_to_fix in
 	  let nb_args = fix_info.nb_realargs in
 	  tclTHENSEQ
 	    [
-	      (* observe_tac ("introducing args") *) (tclDO nb_args intro);
+	      (* observe_tac ("introducing args") *) (tclDO nb_args (Proofview.V82.of_tactic intro));
 	      (fun g -> (* replacement of the function by its body *)
 		 let args = nLastDecls nb_args g in
 		 let fix_body = fix_info.body_with_param in
@@ -1258,7 +1266,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		       build_proof
 			 interactive_proof
 			 (Array.to_list fnames)
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 		     in
 		     let prove_tac branches  =
 		       let dyn_infos =
@@ -1268,7 +1276,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 			 }
 		       in
 		       observe_tac "cleaning" (clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 			 do_prove
 			 dyn_infos)
 		     in
@@ -1288,7 +1296,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 	  let nb_args = min (princ_info.nargs) (List.length ctxt) in
 	  tclTHENSEQ
 	    [
-	      tclDO nb_args intro;
+	      tclDO nb_args (Proofview.V82.of_tactic intro);
 	      (fun g -> (* replacement of the function by its body *)
 		 let args = nLastDecls nb_args g in
 		 let args_id = List.map (fun (id,_,_) -> id) args in
@@ -1307,12 +1315,12 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 		 in
 		 let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
 		 tclTHENSEQ
-		   [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)];
+		   [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))];
 		    let do_prove =
 		      build_proof
 			interactive_proof
 			(Array.to_list fnames)
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 		    in
 		    let prove_tac branches  =
 		      let dyn_infos =
@@ -1322,7 +1330,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 			 }
 		      in
 		       clean_goal_with_heq
-			 (Idmap.map prove_rec_hyp ptes_to_fix)
+			 (Id.Map.map prove_rec_hyp ptes_to_fix)
 			 do_prove
 			 dyn_infos
 		    in
@@ -1346,15 +1354,13 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
 
 
 (* Proof of principles of general functions *)
-let h_id = Recdef.h_id
-and hrec_id = Recdef.hrec_id
-and acc_inv_id = Recdef.acc_inv_id
-and ltof_ref = Recdef.ltof_ref
-and acc_rel = Recdef.acc_rel
-and well_founded = Recdef.well_founded
-and h_intros = Recdef.h_intros
-and list_rewrite = Recdef.list_rewrite
-and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
+(* let  hrec_id =

+(* and acc_inv_id = Recdef.acc_inv_id *)
+(* and ltof_ref = Recdef.ltof_ref *)
+(* and acc_rel = Recdef.acc_rel *)
+(* and well_founded = Recdef.well_founded *)
+(* and list_rewrite = Recdef.list_rewrite *)
+(* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *)
 
 
 
@@ -1362,7 +1368,7 @@ and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
 
 let prove_with_tcc tcc_lemma_constr eqs : tactic =
   match !tcc_lemma_constr with
-    | None -> anomaly "No tcc proof !!"
+    | None -> anomaly (Pp.str "No tcc proof !!")
     | Some lemma ->
 	fun gls ->
 (* 	  let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *)
@@ -1387,14 +1393,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic =
   fun gls ->
     let eqs = List.map mkVar eqs in
     let rewrite =
-      tclFIRST (List.map Equality.rewriteRL eqs )
+      tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs )
     in
     let _,hrec_concl  = decompose_prod (pf_type_of gls (mkVar hrec)) in
-    let f_app = array_last (snd (destApp hrec_concl)) in
+    let f_app = Array.last (snd (destApp hrec_concl)) in
     let f =  (fst (destApp f_app)) in
     let rec backtrack : tactic =
       fun g ->
-	let f_app = array_last (snd (destApp (pf_concl g))) in
+	let f_app = Array.last (snd (destApp (pf_concl g))) in
 	match kind_of_term f_app with
 	  | App(f',_) when eq_constr f' f -> tclIDTAC g
 	  | _ -> tclTHEN rewrite backtrack g
@@ -1402,17 +1408,6 @@ let backtrack_eqs_until_hrec hrec eqs : tactic =
     backtrack gls
 
 
-
-let build_clause eqs =
-  {
-    Tacexpr.onhyps =
-      Some (List.map
-	      (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp)
-	      eqs
-	   );
-    Tacexpr.concl_occs = Glob_term.no_occurrences_expr
-  }
-
 let rec rewrite_eqs_in_eqs eqs =
   match eqs with
     | [] -> tclIDTAC
@@ -1422,8 +1417,9 @@ let rec rewrite_eqs_in_eqs eqs =
 	    (tclMAP
 	       (fun id gl ->
 		  observe_tac
-		    (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id))
-		    (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false))
+		    (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id))
+		    (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences
+			       true (* dep proofs also: *) true id (mkVar eq) false)))
 		    gl
 	       )
 	       eqs
@@ -1435,22 +1431,22 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
     (tclTHENSEQ
        [
 	 backtrack_eqs_until_hrec hrec eqs;
-	 (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
+	 (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *)
 	 (tclTHENS  (* We must have exactly ONE subgoal !*)
-	    (apply (mkVar hrec))
+	    (Proofview.V82.of_tactic (apply (mkVar hrec)))
 	    [ tclTHENSEQ
 		[
-		  keep (tcc_hyps@eqs);
-		  apply (Lazy.force acc_inv);
+		  (Proofview.V82.of_tactic (keep (tcc_hyps@eqs)));
+		  (Proofview.V82.of_tactic (apply (Lazy.force acc_inv)));
 		  (fun g ->
 		     if is_mes
 		     then
-		       unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+		       unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
 		     else tclIDTAC g
 		  );
 		  observe_tac "rew_and_finish"
 		    (tclTHENLIST
-		       [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
+		       [tclTRY(list_rewrite false (List.map (fun v -> (mkVar v,true)) eqs));
 			observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
 			 (observe_tac "finishing using"
 			   (
@@ -1458,7 +1454,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 				    Eauto.eauto_with_bases
 				      (true,5)
 				      [Evd.empty,Lazy.force refl_equal]
-				      [Auto.Hint_db.empty empty_transparent_state false]
+				      [Hints.Hint_db.empty empty_transparent_state false]
 				  )
 			   )
 			)
@@ -1471,13 +1467,13 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
 
 
 let is_valid_hypothesis predicates_name =
-  let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
+  let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in
   let is_pte typ =
     if isApp typ
     then
       let pte,_ = destApp typ in
       if isVar pte
-      then Idset.mem (destVar pte) predicates_name
+      then Id.Set.mem (destVar pte) predicates_name
       else false
     else false
   in
@@ -1499,7 +1495,7 @@ let prove_principle_for_gen
     fun na ->
       let new_id =
 	  match na with
-	    | Name id -> fresh_id !avoid (string_of_id id)
+	    | Name id -> fresh_id !avoid (Id.to_string id)
 	    | Anonymous -> fresh_id !avoid "H"
       in
       avoid := new_id :: !avoid;
@@ -1531,7 +1527,7 @@ let prove_principle_for_gen
 (* 	     str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
 (* 	     str "npost_rec_arg := " ++ int npost_rec_arg ); *)
   let (post_rec_arg,pre_rec_arg) =
-    Util.list_chop npost_rec_arg princ_info.args
+    Util.List.chop npost_rec_arg princ_info.args
   in
   let rec_arg_id =
     match List.rev post_rec_arg with
@@ -1542,25 +1538,25 @@ let prove_principle_for_gen
   let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
   let relation = substl subst_constrs relation in
   let input_type = substl subst_constrs rec_arg_type in
-  let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
+  let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in
   let acc_rec_arg_id =
-    Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
+    Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
   in
   let revert l =
-    tclTHEN (h_generalize (List.map mkVar l)) (clear l)
+    tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l)
   in
   let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
   let prove_rec_arg_acc g =
       ((* observe_tac "prove_rec_arg_acc"  *)
 	 (tclCOMPLETE
 	    (tclTHEN
-	       (assert_by (Name wf_thm_id)
+	       (Proofview.V82.of_tactic (assert_by (Name wf_thm_id)
 		  (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
+		  (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))))
 	       (
 		 (* observe_tac  *)
 (* 		   "apply wf_thm"  *)
-		 h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))
+		 Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])))
 	       )
 	    )
 	 )
@@ -1570,7 +1566,7 @@ let prove_principle_for_gen
   let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
   let lemma =
     match !tcc_lemma_ref with
-     | None -> anomaly ( "No tcc proof !!")
+     | None -> error "No tcc proof !!"
      | Some lemma -> lemma
   in
 (*   let rec list_diff del_list check_list = *)
@@ -1588,18 +1584,18 @@ let prove_principle_for_gen
     let hyps = pf_ids_of_hyps gls in
       let hid =
 	next_ident_away_in_goal
-	  (id_of_string "prov")
+	  (Id.of_string "prov")
 	  hyps
       in
       tclTHENSEQ
 	[
 	  generalize [lemma];
-	  h_intro hid;
-	  Elim.h_decompose_and (mkVar hid);
+	  Proofview.V82.of_tactic (Simple.intro hid);
+	  Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid));
 	  (fun g ->
 	     let new_hyps = pf_ids_of_hyps g in
-	     tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
-	     if !tcc_list = []
+	     tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps));
+	     if List.is_empty !tcc_list
 	     then
 	       begin
 		 tcc_list := [hid];
@@ -1617,22 +1613,22 @@ let prove_principle_for_gen
 	(List.rev_map (fun (na,_,_) -> Nameops.out_name na)
 	   (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
 	);
-      (* observe_tac "" *) (assert_by
+      (* observe_tac "" *) Proofview.V82.of_tactic (assert_by
 	 (Name acc_rec_arg_id)
  	 (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
-	 (prove_rec_arg_acc)
+	 (Proofview.V82.tactic prove_rec_arg_acc)
       );
 (*       observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
 (*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++  *)
 (* 			   str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
-      (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
+      (* observe_tac "h_fix " *) (fix (Some fix_id) (List.length args_ids + 1));
 (*       (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
       h_intros (List.rev (acc_rec_arg_id::args_ids));
-      Equality.rewriteLR (mkConst eq_ref);
+      Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref));
       (* observe_tac "finish" *) (fun gl' ->
 	 let body =
 	   let _,args = destApp (pf_concl gl') in
-	   array_last args
+	   Array.last args
 	 in
 	 let body_info rec_hyps =
 	   {
@@ -1677,14 +1673,14 @@ let prove_principle_for_gen
 	     is_valid = is_valid_hypothesis predicates_names
 	   }
 	 in
-	 let ptes_info : pte_info Idmap.t =
+	 let ptes_info : pte_info Id.Map.t =
 	   List.fold_left
 	     (fun map pte_id ->
-		Idmap.add pte_id
+		Id.Map.add pte_id
 		  pte_info
 		  map
 	     )
-	     Idmap.empty
+	     Id.Map.empty
 	     predicates_names
 	 in
 	 let make_proof rec_hyps =
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 04fcc8d4..545f8931 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,58 +1,25 @@
 open Printer
+open Errors
 open Util
 open Term
+open Vars
+open Context
 open Namegen
 open Names
-open Declarations
+open Declareops
 open Pp
 open Entries
-open Hiddentac
-open Evd
-open Tacmach
-open Proof_type
-open Tacticals
 open Tactics
 open Indfun_common
 open Functional_principles_proofs
+open Misctypes
 
 exception Toberemoved_with_rel of int*constr
 exception Toberemoved
 
-
-let pr_elim_scheme el =
-  let env = Global.env () in
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
-  let env = Environ.push_rel_context el.params env in
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
-  let env = Environ.push_rel_context el.predicates env in
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
-  let env = Environ.push_rel_context el.branches env in
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
-  let env = Environ.push_rel_context el.args env in
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
 let observe s =
   if do_observe ()
-  then Pp.msgnl s
-
-
-let pr_elim_scheme el =
-  let env = Global.env () in
-  let msg = str "params := " ++ Printer.pr_rel_context env el.params in
-  let env = Environ.push_rel_context el.params env in
-  let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
-  let env = Environ.push_rel_context el.predicates env in
-  let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
-  let env = Environ.push_rel_context el.branches env in
-  let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
-  let env = Environ.push_rel_context el.args env in
-  msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
-
-
-let observe s =
-  if do_observe ()
-  then Pp.msgnl s
+  then Pp.msg_debug s
 
 (*
    Transform an inductive induction principle into
@@ -63,14 +30,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let env = Global.env () in
   let env_with_params = Environ.push_rel_context princ_type_info.params env in
   let tbl = Hashtbl.create 792 in
-  let rec change_predicates_names (avoid:identifier list) (predicates:rel_context)  : rel_context =
+  let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context)  : rel_context =
     match predicates with
     | [] -> []
     |(Name x,v,t)::predicates ->
        let id =  Namegen.next_ident_away x avoid in
        Hashtbl.add tbl id x;
        (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
-    | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
+    | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ")
   in
   let avoid = (Termops.ids_of_context env_with_params ) in
   let princ_type_info =
@@ -91,7 +58,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
   in
   let new_predicates =
-    list_map_i
+    List.map_i
       change_predicate_sort
       0
       princ_type_info.predicates
@@ -99,16 +66,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
   let rel_as_kn =
     fst (match princ_type_info.indref with
-	   | Some (Libnames.IndRef ind) -> ind
+	   | Some (Globnames.IndRef ind) -> ind
 	   | _ -> error "Not a valid predicate"
 	)
   in
   let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
   let is_pte =
-    let set = List.fold_right Idset.add ptes_vars Idset.empty in
+    let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in
     fun t ->
       match kind_of_term t with
-	| Var id -> Idset.mem id set
+	| Var id -> Id.Set.mem id set
 	| _ -> false
   in
   let pre_princ =
@@ -126,17 +93,17 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
   let is_dom c =
     match kind_of_term c with
-      | Ind((u,_)) -> u = rel_as_kn
-      | Construct((u,_),_) -> u = rel_as_kn
+      | Ind((u,_),_) -> MutInd.equal u rel_as_kn
+      | Construct(((u,_),_),_) -> MutInd.equal u rel_as_kn
       | _ -> false
   in
   let get_fun_num c =
     match kind_of_term c with
-      | Ind(_,num) -> num
-      | Construct((_,num),_) -> num
+      | Ind((_,num),_) -> num
+      | Construct(((_,num),_),_) -> num
       | _ -> assert false
   in
-  let dummy_var = mkVar (id_of_string "________") in
+  let dummy_var = mkVar (Id.of_string "________") in
   let mk_replacement c i args =
     let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in
 (*     observe (str "replacing " ++ pr_lconstr c ++ str " by "  ++ pr_lconstr res); *)
@@ -157,7 +124,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
 	    compute_new_princ_type_for_binder  remove mkLambda env x t b
 	| Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
 	| App(f,args) when is_dom f ->
-	    let var_to_be_removed = destRel (array_last args) in
+	    let var_to_be_removed = destRel (Array.last args) in
 	    let num = get_fun_num f in
 	    raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
 	| App(f,args) ->
@@ -191,7 +158,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
     begin
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
-	let new_x : name = get_name (Termops.ids_of_context env) x in
+	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,None,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	 if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
@@ -220,7 +187,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
       try
 	let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
 	let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
-	let new_x : name = get_name (Termops.ids_of_context env) x in
+	let new_x : Name.t = get_name (Termops.ids_of_context env) x in
 	let new_env = Environ.push_rel (x,Some v,t) env in
 	let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
 	if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
@@ -255,7 +222,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
   in
   let pre_res =
     replace_vars
-      (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
+      (List.map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
       (lift (List.length ptes_vars) pre_res)
   in
   it_mkProd_or_LetIn
@@ -271,8 +238,10 @@ let change_property_sort toSort princ princName =
   let princ_info = compute_elim_sig princ in
   let change_sort_in_predicate (x,v,t) =
     (x,None,
-     let args,_ = decompose_prod t in
-     compose_prod args (mkSort toSort)
+     let args,ty = decompose_prod t in
+     let s = destSort ty in
+       Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty);
+       compose_prod args (mkSort toSort)
     )
   in
   let princName_as_constr = Constrintern.global_reference princName in
@@ -288,23 +257,6 @@ let change_property_sort toSort princ princName =
     )
     princ_info.params
 
-
-let pp_dur time time' =
-  str (string_of_float (System.time_difference time time'))
-
-(* let qed () = save_named true  *)
-let defined () =
-  try
-    Lemmas.save_named false
-  with
-    | UserError("extract_proof",msg) ->
-	Util.errorlabstrm
-	  "defined"
-	  ((try
-	      str "On goal : " ++ fnl () ++  pr_open_subgoals () ++ fnl ()
-	    with e when Errors.noncritical e -> mt ()
-	   ) ++msg)
-
 let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
   (* First we get the type of the old graph principle *)
   let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
@@ -319,23 +271,25 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro
   (*    Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
      observe (str "new_principle_type : " ++ pr_lconstr new_principle_type);
   let new_princ_name =
-    next_ident_away_in_goal (id_of_string "___________princ_________") []
+    next_ident_away_in_goal (Id.of_string "___________princ_________") []
   in
+  let hook = Lemmas.mk_hook (hook new_principle_type) in
   begin
     Lemmas.start_proof
       new_princ_name
-      (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-      new_principle_type
-      (hook new_principle_type)
+      (Decl_kinds.Global,false,(Decl_kinds.Proof Decl_kinds.Theorem))
+      (*FIXME*) Evd.empty
+    new_principle_type
+      hook
     ;
     (*       let _tim1 = System.get_time ()  in *)
-    Pfedit.by  (proof_tac (Array.map mkConst funs) mutr_nparams);
+    ignore (Pfedit.by  (Proofview.V82.tactic (proof_tac (Array.map mkConst funs) mutr_nparams)));
     (*       let _tim2 =  System.get_time ()  in *)
     (* 	begin *)
     (* 	  let dur1 = System.time_difference tim1 tim2 in *)
     (* 	  Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
     (* 	end; *)
-    get_proof_clean true
+    get_proof_clean true, Ephemeron.create hook
   end
 
 
@@ -347,7 +301,7 @@ let generate_functional_principle
   try
 
   let f = funs.(i) in
-  let type_sort = Termops.new_sort_in_family InType in
+  let type_sort = Universes.new_sort_in_family InType in
   let new_sorts =
     match sorts with
       | None -> Array.make (Array.length funs) (type_sort)
@@ -357,42 +311,35 @@ let generate_functional_principle
     match new_princ_name with
       | Some (id) -> id,id
       | None ->
-	  let id_of_f = id_of_label (con_label f) in
+	  let id_of_f = Label.to_id (con_label f) in
 	  id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
   in
   let names = ref [new_princ_name] in
-  let hook new_principle_type _ _  =
-    if sorts = None
+  let hook new_principle_type _ _ =
+    if Option.is_empty sorts
     then
-      (*     let id_of_f = id_of_label (con_label f) in *)
+      (*     let id_of_f = Label.to_id (con_label f) in *)
       let register_with_sort fam_sort =
-	let s = Termops.new_sort_in_family fam_sort in
+	let s = Universes.new_sort_in_family fam_sort in
 	let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
 	let value = change_property_sort s new_principle_type new_princ_name in
 	(*       Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
-	let ce =
-	  { const_entry_body = value;
-            const_entry_secctx = None;
-	    const_entry_type = None;
-	    const_entry_opaque = false }
-	in
+	let ce = Declare.definition_entry value in (*FIXME, no poly, nothing *)
 	ignore(
 	  Declare.declare_constant
 	    name
 	    (Entries.DefinitionEntry ce,
-	     Decl_kinds.IsDefinition (Decl_kinds.Scheme)
-	    )
+	     Decl_kinds.IsDefinition (Decl_kinds.Scheme))
 	);
-	Flags.if_verbose
-	  (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
-	  name;
+	Declare.definition_message name;
 	names := name :: !names
       in
       register_with_sort InProp;
       register_with_sort InSet
   in
-  let (id,(entry,g_kind,hook)) =
-    build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
+  let ((id,(entry,g_kind)),hook) =
+    build_functional_principle interactive_proof old_princ_type new_sorts funs i
+    proof_tac hook
   in
   (* Pr  1278 :
      Don't forget to close the goal if an error is raised !!!!
@@ -403,10 +350,10 @@ let generate_functional_principle
       begin
 	try
 	  let id = Pfedit.get_current_proof_name () in
-	  let s = string_of_id id in
+	  let s = Id.to_string id in
 	  let n = String.length "___________princ_________" in
 	  if String.length s >= n
-	  then if String.sub s 0 n = "___________princ_________"
+	  then if String.equal (String.sub s 0 n) "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -420,26 +367,25 @@ let generate_functional_principle
 exception Not_Rec
 
 let get_funs_constant mp dp =
-  let rec get_funs_constant const e : (Names.constant*int) array =
+  let get_funs_constant const e : (Names.constant*int) array =
     match kind_of_term ((strip_lam e)) with
       | Fix((_,(na,_,_))) ->
 	  Array.mapi
 	    (fun i na ->
 	       match na with
 		 | Name id ->
-		     let const = make_con mp dp (label_of_id id) in
+		     let const = make_con mp dp (Label.of_id id) in
 		     const,i
 		 | Anonymous ->
-		     anomaly "Anonymous fix"
+		     anomaly (Pp.str "Anonymous fix")
 	    )
 	    na
       | _ -> [|const,0|]
   in
   function const ->
     let find_constant_body const =
-      match body_of_constant (Global.lookup_constant const) with
-	| Some b ->
-	    let body = force b in
+      match Global.body_of_constant const with
+	| Some body ->
 	    let body = Tacred.cbv_norm_flags
 	      (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
 	      (Global.env ())
@@ -462,7 +408,7 @@ let get_funs_constant mp dp =
       let first_params = List.hd l_params  in
       List.iter
 	(fun params ->
-	   if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params)
+	   if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && eq_constr c1 c2) first_params params)
 	   then error "Not a mutal recursive block"
 	)
 	l_params
@@ -474,14 +420,15 @@ let get_funs_constant mp dp =
 	  match kind_of_term body with
 	    | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
 	    | _ ->
-		if is_first && (List.length l_bodies = 1)
+		if is_first && Int.equal (List.length l_bodies) 1
 		then raise Not_Rec
 		else error "Not a mutal recursive block"
 	in
 	let first_infos = extract_info true (List.hd l_bodies) in
 	let check body  = (* Hope this is correct *)
 	  let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) =
-	    ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2
+            Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 &&
+            Array.equal eq_constr ta1 ta2 && Array.equal eq_constr ca1 ca2
 	  in
 	  if not (eq_infos first_infos (extract_info false body))
 	  then  error "Not a mutal recursive block"
@@ -494,7 +441,7 @@ let get_funs_constant mp dp =
 exception No_graph_found
 exception Found_type of int
 
-let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list =
+let make_scheme (fas : (constant*glob_sort) list) : Entries.definition_entry list =
   let env = Global.env ()
   and sigma = Evd.empty in
   let funs = List.map fst fas in
@@ -513,26 +460,27 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
   let funs_indexes =
     let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
     List.map
-      (function const -> List.assoc const this_block_funs_indexes)
+      (function cst -> List.assoc_f Constant.equal cst this_block_funs_indexes)
       funs
   in
   let ind_list =
     List.map
       (fun (idx) ->
 	 let ind = first_fun_kn,idx in
-	 ind,true,prop_sort
+	   (ind,Univ.Instance.empty)(*FIXME*),true,prop_sort
       )
       funs_indexes
   in
+  let sigma, schemes = 
+    Indrec.build_mutual_induction_scheme env sigma ind_list
+  in
   let l_schemes =
-    List.map
-      (Typing.type_of env sigma)
-      (Indrec.build_mutual_induction_scheme env sigma ind_list)
+    List.map (Typing.type_of env sigma) schemes
   in
   let i = ref (-1) in
   let sorts =
     List.rev_map (fun (_,x) ->
-		Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+		Universes.new_sort_in_family (Pretyping.interp_elimination_sort x)
 	     )
       fas
   in
@@ -540,9 +488,9 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
   let first_type,other_princ_types =
     match l_schemes with
 	s::l_schemes -> s,l_schemes
-      | _ -> anomaly ""
+      | _ -> anomaly (Pp.str "")
   in
-  let (_,(const,_,_)) =
+  let ((_,(const,_)),_) =
     try
       build_functional_principle false
 	first_type
@@ -556,10 +504,10 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
       begin
 	try
 	  let id = Pfedit.get_current_proof_name () in
-	  let s = string_of_id id in
+	  let s = Id.to_string id in
 	  let n = String.length "___________princ_________" in
 	  if String.length s >= n
-	  then if String.sub s 0 n = "___________princ_________"
+	  then if String.equal (String.sub s 0 n) "___________princ_________"
 	  then Pfedit.delete_current_proof ()
 	  else ()
 	  else ()
@@ -574,13 +522,13 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
     let finfos = find_Function_infos this_block_funs.(0) in
     try
       let equation =  Option.get finfos.equation_lemma in
-      Declarations.is_opaque (Global.lookup_constant equation)
+      Declareops.is_opaque (Global.lookup_constant equation)
     with Option.IsNone -> (* non recursive definition *)
       false
   in
   let const = {const with const_entry_opaque = opacity } in
   (* The others are just deduced *)
-  if other_princ_types = []
+  if List.is_empty other_princ_types
   then
     [const]
   else
@@ -590,7 +538,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
       List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
     in
     let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
-    let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
+    let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*)
     let (idxs,_),(_,ta,_ as decl) = destFix fix in
     let other_result =
       List.map (* we can now compute the other principles *)
@@ -616,7 +564,7 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
 	   (* If we reach this point, the two principle are not mutually recursive
 	      We fall back to the previous method
 	   *)
-	     let (_,(const,_,_)) =
+	     let ((_,(const,_)),_) =
 	       build_functional_principle
 		 false
 		 (List.nth other_princ_types (!i - 1))
@@ -632,7 +580,8 @@ let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition
 	     Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt
 	   in
 	   {const with
-	      Entries.const_entry_body = princ_body;
+	      Entries.const_entry_body = 
+                (Future.from_val (Term_typing.mk_pure_proof princ_body));
 	      Entries.const_entry_type = Some scheme_type
 	   }
       )
@@ -648,11 +597,11 @@ let build_scheme fas =
 	 (fun (_,f,sort) ->
 	    let f_as_constant =
 	      try
-		match Nametab.global f with
-		  | Libnames.ConstRef c -> c
-		  | _ -> Util.error "Functional Scheme can only be used with functions"
+		match Smartlocate.global_with_alias f with
+		  | Globnames.ConstRef c -> c
+		  | _ -> Errors.error "Functional Scheme can only be used with functions"
 	      with Not_found ->
-	      	Util.error ("Cannot find "^ Libnames.string_of_reference f)
+	      	Errors.error ("Cannot find "^ Libnames.string_of_reference f)
 	    in
 	    (f_as_constant,sort)
 	 )
@@ -665,8 +614,7 @@ let build_scheme fas =
 	 (Declare.declare_constant
 	    princ_id
 	    (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
-       Flags.if_verbose
-	 (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+       Declare.definition_message princ_id
     )
     fas
     bodies_types;
@@ -681,10 +629,10 @@ let build_case_scheme fa =
 (*     Constrintern.global_reference  id *)
 (*   in  *)
   let funs =  (fun (_,f,_) ->
-		 try Libnames.constr_of_global (Nametab.global f)
+		 try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f))
 		 with Not_found ->
-		   Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
-  let first_fun = destConst  funs in
+		   Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
+  let first_fun,u = destConst  funs in
 
   let funs_mp,funs_dp,_ = Names.repr_con first_fun in
   let first_fun_kn = try fst (find_Function_infos  first_fun).graph_ind with Not_found -> raise No_graph_found in
@@ -696,16 +644,18 @@ let build_case_scheme fa =
   let prop_sort = InProp in
   let funs_indexes =
     let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
-    List.assoc (destConst funs) this_block_funs_indexes
+    List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes
   in
   let ind_fun =
 	 let ind = first_fun_kn,funs_indexes in
-	 ind,prop_sort
+	   (ind,Univ.Instance.empty)(*FIXME*),prop_sort
   in
-  let scheme_type =  (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun) in
+  let sigma, scheme = 
+    (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf)  ind_fun in
+  let scheme_type =  (Typing.type_of env sigma ) scheme in
   let sorts =
     (fun (_,_,x) ->
-       Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+       Universes.new_sort_in_family (Pretyping.interp_elimination_sort x)
     )
       fa
   in
@@ -722,6 +672,6 @@ let build_case_scheme fa =
       (Some princ_name)
       this_block_funs
       0
-      (prove_princ_for_struct false 0 [|destConst funs|])
+      (prove_princ_for_struct false 0 [|fst (destConst funs)|])
   in
   ()
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
index 1c02c16e..a16b834f 100644
--- a/plugins/funind/functional_principles_types.mli
+++ b/plugins/funind/functional_principles_types.mli
@@ -1,6 +1,6 @@
 open Names
 open Term
-
+open Misctypes
 
 val generate_functional_principle :
   (* do we accept interactive proving *)
@@ -10,7 +10,7 @@ val generate_functional_principle :
   (* *)
   sorts array option ->
   (* Name of the new principle *)
-  (identifier) option ->
+  (Id.t) option ->
   (* the compute functions to use   *)
   constant array ->
   (* We prove the nth- principle *)
@@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array ->
 
 exception No_graph_found
 
-val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list
+val make_scheme : (constant*glob_sort) list -> Entries.definition_entry list
 
-val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list ->  unit
-val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort)  ->  unit
+val build_scheme : (Id.t*Libnames.reference*glob_sort) list ->  unit
+val build_case_scheme : (Id.t*Libnames.reference*glob_sort)  ->  unit
 
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index ffaa2208..fd48ab59 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -1,35 +1,38 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+open Compat
 open Util
 open Term
+open Vars
 open Names
 open Pp
-open Topconstr
+open Constrexpr
 open Indfun_common
 open Indfun
 open Genarg
-open Pcoq
 open Tacticals
-open Constr
+open Misctypes
+
+DECLARE PLUGIN "recdef_plugin"
 
 let pr_binding prc = function
-  | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
-  | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+  | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
+  | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Glob_term.ImplicitBindings l ->
+  | ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc prc l
-  | Glob_term.ExplicitBindings l ->
+      pr_sequence prc l
+  | ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | Glob_term.NoBindings -> mt ()
+        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | NoBindings -> mt ()
 
 let pr_with_bindings prc prlc (c,bl) =
   prc c ++ hv 0 (pr_bindings prc prlc bl)
@@ -69,18 +72,23 @@ END
 TACTIC EXTEND newfuninv
    [ "functional" "inversion"  quantified_hypothesis(hyp) reference_opt(fname) ] ->
      [
-       Invfun.invfun hyp fname
+       Proofview.V82.tactic (Invfun.invfun hyp fname)
      ]
 END
 
 
-let pr_intro_as_pat prc _ _ pat =
+let pr_intro_as_pat _prc _ _ pat =
   match pat with
-    | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
+    | Some pat ->
+      spc () ++ str "as" ++ spc () ++ (* Miscprint.pr_intro_pattern prc  pat *)
+        str"<simple_intropattern>"
     | None -> mt ()
 
+let out_disjunctive = function
+  | loc, IntroAction (IntroOrAndPattern l) -> (loc,l)
+  | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected."
 
-ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
+ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat
 |   [ "as"  simple_intropattern(ipat) ] -> [ Some ipat ]
 | []  ->[ None ]
 END
@@ -96,7 +104,7 @@ TACTIC EXTEND newfunind
 	 | [c] -> c
 	 | c::cl -> applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
+       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ]
 END
 (***** debug only ***)
 TACTIC EXTEND snewfunind
@@ -107,11 +115,11 @@ TACTIC EXTEND snewfunind
 	 | [c] -> c
 	 | c::cl -> applist(c,cl)
        in
-       Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
+       Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ]
 END
 
 
-let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc
+let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
 
 ARGUMENT EXTEND constr_coma_sequence'
   TYPED AS constr_list
@@ -133,34 +141,37 @@ module Gram = Pcoq.Gram
 module Vernac = Pcoq.Vernac_
 module Tactic = Pcoq.Tactic
 
-module FunctionGram =
-struct
-  let gec s = Gram.entry_create ("Function."^s)
-		(* types *)
-  let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc"
-end
-open FunctionGram
+type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located
+
+let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) =
+  Genarg.create_arg None "function_rec_definition_loc"
+
+let function_rec_definition_loc =
+  Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
 
 GEXTEND Gram
   GLOBAL: function_rec_definition_loc ;
 
   function_rec_definition_loc:
-    [ [ g = Vernac.rec_definition -> loc, g ]]
+    [ [ g = Vernac.rec_definition -> !@loc, g ]]
     ;
 
-  END
-type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type
+END
 
-let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype),
-  (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype),
-  (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) =
-  Genarg.create_arg None "function_rec_definition_loc"
+(* TASSI: n'importe quoi ! *)
 VERNAC COMMAND EXTEND Function
-   ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] ->
-	[
-	  do_generate_principle false (List.map snd recsl);
-
-	]
+   ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")]
+    => [ let hard = List.exists (function
+           | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true
+           | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in
+         match
+           Vernac_classifier.classify_vernac
+             (Vernacexpr.VernacFixpoint(None, List.map snd recsl))
+         with
+         | Vernacexpr.VtSideff ids, _ when hard ->
+             Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater)
+         | x -> x ]
+    -> [ do_generate_principle false (List.map snd recsl) ]
 END
 
 let pr_fun_scheme_arg (princ_name,fun_name,s) =
@@ -175,23 +186,25 @@ END
 
 
 let warning_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in
   match e with
     | Building_graph e ->
 	Pp.msg_warning
 	  (str "Cannot define graph(s) for " ++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
+	     h 1 (pr_enum Libnames.pr_reference names) ++
 	     if do_observe () then (spc () ++ Errors.print e) else mt ())
     | Defining_principle e ->
 	Pp.msg_warning
 	  (str "Cannot define principle(s) for "++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++
+	     h 1 (pr_enum Libnames.pr_reference names) ++
 	     if do_observe () then Errors.print e else mt ())
     | _ -> raise e
 
 
 VERNAC COMMAND EXTEND NewFunctionalScheme
-   ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
+   ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ]
+   => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ]
+   ->
     [
       begin
 	try
@@ -202,13 +215,13 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
 	      | (_,fun_name,_)::_ ->
 		  begin
 		    begin
-		      make_graph (Nametab.global fun_name)
+		      make_graph (Smartlocate.global_with_alias fun_name)
 		    end
 		    ;
 		    try Functional_principles_types.build_scheme fas
 		    with Functional_principles_types.No_graph_found ->
-		      Util.error ("Cannot generate induction principle(s)")
-    		      | e when Errors.noncritical e ->
+		      Errors.error ("Cannot generate induction principle(s)")
+		      | e when Errors.noncritical e ->
 			  let names = List.map (fun (_,na,_) -> na) fas in
 			  warning_error names e
 
@@ -225,15 +238,14 @@ END
 (***** debug only ***)
 
 VERNAC COMMAND EXTEND NewFunctionalCase
-   ["Functional" "Case" fun_scheme_arg(fas) ] ->
-    [
-      Functional_principles_types.build_case_scheme fas
-    ]
+  ["Functional" "Case" fun_scheme_arg(fas) ]
+  => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ]
+  -> [ Functional_principles_types.build_case_scheme fas ]
 END
 
 (***** debug only ***)
-VERNAC COMMAND EXTEND GenerateGraph
-["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
+VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY
+["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ]
 END
 
 
@@ -273,7 +285,7 @@ let constr_head_match u t=
   if isApp u
   then
     let uhd,args= destApp u in
-    uhd=t
+    Constr.equal uhd t
   else false
 
 (** [hdMatchSub inu t] returns the list of occurrences of [t] in
@@ -296,22 +308,25 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
   else
     let f,args = decompose_app inu in
     let freeset = Termops.free_rels inu in
-    let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
-    {fname = f; largs = args; free = Util.Intset.is_empty freeset;
+    let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in
+    {fname = f; largs = args; free = Int.Set.is_empty freeset;
     max_rel = max_rel; onlyvars = List.for_all isVar args }
     ::subres
 
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+
 let mkEq typ c1 c2 =
-  mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
+  mkApp (make_eq(),[| typ; c1; c2|])
 
 
 let poseq_unsafe idunsafe cstr gl =
   let typ = Tacmach.pf_type_of gl cstr in
   tclTHEN
-    (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl)
+    (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl))
     (tclTHENFIRST
-      (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
-      Tactics.reflexivity)
+      (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr)))
+      (Proofview.V82.of_tactic Tactics.reflexivity))
     gl
 
 
@@ -357,7 +372,7 @@ let poseq_list_ids lcstr gl =
 let find_fapp (test:constr -> bool) g : fapp_info list =
   let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
   let res =
-    List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
+    List.fold_right (List.add_set Pervasives.(=)) pre_res [] in
   (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
   res)
 
@@ -367,7 +382,7 @@ let find_fapp (test:constr -> bool) g : fapp_info list =
     an occurence of function [id] in the conclusion of goal [g]. If
     [id]=[None] then calls to any function are selected. In any case
     [heuristic] is used to select the most pertinent occurrence. *)
-let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
+let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list)
     (nexttac:Proof_type.tactic) g =
   let test = match oid with
     | Some id ->
@@ -377,7 +392,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l
   let info_list = find_fapp test g in
   let ordered_info_list = heuristic info_list in
   prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
-  if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
+  if List.is_empty ordered_info_list then Errors.error "function not found in goal\n";
   let taclist: Proof_type.tactic list =
     List.map
       (fun info ->
@@ -419,10 +434,10 @@ TACTIC EXTEND finduction
     ["finduction" ident(id) natural_opt(oi)] ->
       [
 	match oi with
-	  | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
+	  | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0"
 	  | _ ->
 	      let heuristic = chose_heuristic oi in
-	      finduction (Some id) heuristic tclIDTAC
+	      Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC)
       ]
 END
 
@@ -432,13 +447,13 @@ TACTIC EXTEND fauto
     [ "fauto" tactic(tac)] ->
       [
 	let heuristic = chose_heuristic None in
-	finduction None heuristic (Tacinterp.eval_tactic tac)
+	Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac)))
       ]
   |
     [ "fauto" ] ->
       [
 	let heuristic = chose_heuristic None in
-	finduction None heuristic tclIDTAC
+	Proofview.V82.tactic (finduction None heuristic tclIDTAC)
       ]
 
 END
@@ -446,31 +461,31 @@ END
 
 TACTIC EXTEND poseq
   [ "poseq" ident(x) constr(c) ] ->
-      [ poseq x c ]
+      [ Proofview.V82.tactic (poseq x c) ]
 END
 
-VERNAC COMMAND EXTEND Showindinfo
+VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY
   [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
 END
 
-VERNAC COMMAND EXTEND MergeFunind
+VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF
   [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
       "with" "(" ident(id2) ne_ident_list(cl2)  ")" "using" ident(id) ] ->
      [
-       let f1 = Constrintern.interp_constr Evd.empty (Global.env())
-	 (CRef (Libnames.Ident (Util.dummy_loc,id1))) in
-       let f2 = Constrintern.interp_constr Evd.empty (Global.env())
-	 (CRef (Libnames.Ident (Util.dummy_loc,id2))) in
+       let f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty
+	 (CRef (Libnames.Ident (Loc.ghost,id1),None)) in
+       let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty
+	 (CRef (Libnames.Ident (Loc.ghost,id2),None)) in
        let f1type = Typing.type_of (Global.env()) Evd.empty f1 in
        let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
        let ar1 = List.length (fst (decompose_prod f1type)) in
        let ar2 = List.length (fst (decompose_prod f2type)) in
        let _ =
-	 if ar1 <> List.length cl1 then
-	   Util.error ("not the right number of arguments for " ^ string_of_id id1) in
+	 if not (Int.equal ar1 (List.length cl1)) then
+	   Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in
        let _ =
-	 if ar2 <> List.length cl2 then
-	   Util.error ("not the right number of arguments for " ^ string_of_id id2) in
+	 if not (Int.equal ar2 (List.length cl2)) then
+	   Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in
        Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2)  id
      ]
 END
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index b9e0e62a..a2577e2b 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -2,26 +2,30 @@ open Printer
 open Pp
 open Names
 open Term
+open Vars
 open Glob_term
-open Libnames
+open Glob_ops
+open Globnames
 open Indfun_common
+open Errors
 open Util
 open Glob_termops
+open Misctypes
 
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
+  then Pp.msg_debug strm
   else ()
-let observennl strm =
+(*let observennl strm =
   if do_observe ()
   then Pp.msg strm
-  else ()
+  else ()*)
 
 
 type binder_type =
-  | Lambda of name
-  | Prod of name
-  | LetIn of name
+  | Lambda of Name.t
+  | Prod of Name.t
+  | LetIn of Name.t
 
 type glob_context = (binder_type*glob_constr) list
 
@@ -54,7 +58,7 @@ type 'a build_entry_pre_return =
 type 'a build_entry_return =
     {
       result : 'a build_entry_pre_return list;
-      to_avoid : identifier list
+      to_avoid : Id.t list
     }
 
 (*
@@ -86,7 +90,7 @@ let combine_results
   in (* and then we flatten the map *)
   {
     result = List.concat pre_result;
-    to_avoid = list_union res1.to_avoid res2.to_avoid
+    to_avoid = List.union Id.equal res1.to_avoid res2.to_avoid
   }
 
 
@@ -111,9 +115,9 @@ let ids_of_binder =  function
 let rec change_vars_in_binder mapping = function
     [] -> []
   | (bt,t)::l ->
-      let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
+      let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in
       (bt,change_vars mapping t)::
-	(if idmap_is_empty new_mapping
+	(if Id.Map.is_empty new_mapping
 	 then l
 	 else change_vars_in_binder new_mapping l
 	)
@@ -122,7 +126,7 @@ let rec replace_var_by_term_in_binder x_id term = function
   | [] -> []
   | (bt,t)::l ->
       (bt,replace_var_by_term x_id term t)::
-	if List.mem x_id (ids_of_binder bt)
+	if Id.List.mem x_id (ids_of_binder bt)
 	then l
 	else replace_var_by_term_in_binder x_id term l
 
@@ -130,28 +134,28 @@ let add_bt_names bt = List.append (ids_of_binder bt)
 
 let apply_args ctxt body args =
   let need_convert_id avoid id =
-    List.exists (is_free_in id) args || List.mem id avoid
+    List.exists (is_free_in id) args || Id.List.mem id avoid
   in
   let need_convert avoid  bt =
     List.exists (need_convert_id avoid) (ids_of_binder bt)
   in
-  let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
+  let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) =
     match na with
-       | Name id when List.mem id avoid ->
+       | Name id when Id.List.mem id avoid ->
 	   let new_id = Namegen.next_ident_away id avoid in
-	   Name new_id,Idmap.add id new_id mapping,new_id::avoid
+	   Name new_id,Id.Map.add id new_id mapping,new_id::avoid
        | _ -> na,mapping,avoid
   in
-  let next_bt_away bt (avoid:identifier list) =
+  let next_bt_away bt (avoid:Id.t list) =
     match bt with
       | LetIn na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  LetIn new_na,mapping,new_avoid
       | Prod na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  Prod new_na,mapping,new_avoid
       | Lambda na ->
-	  let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid  in
+	  let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid  in
 	  Lambda new_na,mapping,new_avoid
   in
   let rec do_apply avoid ctxt body args =
@@ -170,7 +174,7 @@ let apply_args ctxt body args =
 	      let new_avoid =  id::avoid in
 	      let new_id = Namegen.next_ident_away id new_avoid in
 	      let new_avoid' = new_id :: new_avoid in
-	      let mapping = Idmap.add id new_id Idmap.empty in
+	      let mapping = Id.Map.add id new_id Id.Map.empty in
 	      let new_ctxt' = change_vars_in_binder mapping ctxt' in
 	      let new_body = change_vars mapping body in
 	      new_avoid',new_ctxt',new_body,new_id
@@ -266,11 +270,11 @@ let make_discr_match_el  =
   end
 *)
 let make_discr_match_brl i =
-  list_map_i
+  List.map_i
     (fun j (_,idl,patl,_) ->
-       if j=i
-       then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref))
-       else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref))
+       if Int.equal j i
+       then (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_True_ref))
+       else (Loc.ghost,idl,patl, mkGRef (Lazy.force coq_False_ref))
     )
     0
 (*
@@ -285,10 +289,6 @@ let make_discr_match brl =
 	   make_discr_match_el el,
 	   make_discr_match_brl i brl)
 
-let pr_name = function
-  | Name id -> Ppconstr.pr_id id
-  | Anonymous -> str "_"
-
 (**********************************************************************)
 (*  functions used to build case expression from lettuple and if ones *)
 (**********************************************************************)
@@ -304,18 +304,17 @@ let build_constructors_of_type ind' argl =
 		  Impargs.implicits_of_global constructref
 		in
 		let cst_narg =
-		  Inductiveops.mis_constructor_nargs_env
+		  Inductiveops.constructor_nallargs_env
 		    (Global.env ())
 		    construct
 		in
-		let argl = match argl with
-                | None ->
+		let argl =
+		  if List.is_empty argl
+		  then
  		    Array.to_list
-		      (Array.init cst_narg (fun _ -> mkGHole ())
+		      (Array.init (cst_narg - npar) (fun _ -> mkGHole ())
 		      )
-                | Some l ->
-	            Array.to_list
-		      (Array.init npar (fun _ -> mkGHole ()))@l
+		  else argl
 		in
 		let pat_as_term =
 		  mkGApp(mkGRef (ConstructRef(ind',i+1)),argl)
@@ -324,40 +323,6 @@ let build_constructors_of_type ind' argl =
 	     )
     ind.Declarations.mind_consnames
 
-(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
-let rec find_type_of nb b =
-  let f,_ = glob_decompose_app b in
-  match f with
-    | GRef(_,ref) ->
-	begin
-	  let ind_type  =
-	    match ref with
-	      | VarRef _ | ConstRef _ ->
-		  let constr_of_ref = constr_of_global ref in
-		  let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
-		  let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
-		  let ret_type,_ = decompose_app ret_type in
-		  if not (isInd ret_type) then
-		    begin
-(* 		      Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
-		      raise (Invalid_argument "not an inductive")
-		    end;
-		  destInd ret_type
-	      | IndRef ind -> ind
-	      | ConstructRef c -> fst c
-	  in
-	  let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
-	  if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
-	  then raise (Invalid_argument "find_type_of : not a valid inductive");
-	  ind_type
-	end
-    | GCast(_,b,_) -> find_type_of nb b
-    | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *)
-    | _ -> raise (Invalid_argument "not a ref")
-
-
-
-
 (******************)
 (* Main functions *)
 (******************)
@@ -368,14 +333,14 @@ let raw_push_named (na,raw_value,raw_typ) env =
   match na with
     | Anonymous -> env
     | Name id ->
-	let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
-	let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
+	let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in
+	let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType raw_typ in
 	Environ.push_named (id,value,typ) env
 
 
 let add_pat_variables pat typ env : Environ.env =
   let rec add_pat_variables env pat typ  : Environ.env =
-    observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
+    observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty);
 
     match pat with
       | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
@@ -385,14 +350,14 @@ let add_pat_variables pat typ env : Environ.env =
 	    with Not_found -> assert false
 	  in
 	  let constructors = Inductiveops.get_constructors env indf in
-	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
+	  let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in
 	  let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
 	  List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
   in
   let new_env = add_pat_variables  env pat typ in
   let res =
     fst (
-      Sign.fold_rel_context
+      Context.fold_rel_context
 	(fun (na,v,t) (env,ctxt) ->
 	 match na with
 	   | Anonymous -> assert false
@@ -411,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env =
 	~init:(env,[])
     )
   in
-  observe (str "new var env := " ++ Printer.pr_named_context_of res);
+  observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty);
   res
 
 
@@ -423,7 +388,7 @@ let rec pattern_to_term_and_type env typ  = function
 	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
+	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
 	  constr
       in
@@ -432,7 +397,7 @@ let rec pattern_to_term_and_type env typ  = function
 	with Not_found -> assert false
       in
       let constructors = Inductiveops.get_constructors env indf in
-      let constructor  = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
+      let constructor  = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in
       let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
       let _,cstl = Inductiveops.dest_ind_family indf in
       let csta = Array.of_list cstl in
@@ -440,7 +405,7 @@ let rec pattern_to_term_and_type env typ  = function
 	Array.to_list
 	  (Array.init
 	     (cst_narg - List.length patternl)
-	     (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
+	     (fun i -> Detyping.detype false [] env Evd.empty csta.(i))
 	  )
       in
       let patl_as_term =
@@ -508,12 +473,12 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		    | u::l -> 
 			match t with 
 			  | GLambda(loc,na,_,nat,b) -> 
-			      GLetIn(dummy_loc,na,u,aux b l)
+			      GLetIn(Loc.ghost,na,u,aux b l)
 			  | _ -> 
-			      GApp(dummy_loc,t,l)
+			      GApp(Loc.ghost,t,l)
 		in
 		build_entry_lc env funnames avoid (aux f args)
-	    | GVar(_,id) when Idset.mem id funnames ->
+	    | GVar(_,id) when Id.Set.mem id funnames ->
 		(* if we have [f t1 ... tn] with [f]$\in$[fnames]
 		   then we create a fresh variable [res],
 		   add [res] and its "value" (i.e. [res v1 ... vn]) to each
@@ -521,10 +486,10 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 		   a pseudo value "v1 ... vn".
 		   The "value" of this branch is then simply [res]
 		*)
-		let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
+		let rt_as_constr,ctx = Pretyping.understand env Evd.empty rt in
 		let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
-		let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
-		let res = fresh_id args_res.to_avoid "res" in
+		let res_raw_type = Detyping.detype false [] env Evd.empty rt_typ in
+		let res = fresh_id args_res.to_avoid "_res" in
 		let new_avoid = res::args_res.to_avoid in
 		let res_rt = mkGVar res in
 		let new_result =
@@ -568,7 +533,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 			let new_b =
 			  replace_var_by_term
 			    id
-			    (GVar(dummy_loc,id))
+			    (GVar(Loc.ghost,id))
 			    b
 			in
 			(Name new_id,new_b,new_avoid)
@@ -629,7 +594,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	   and combine the two result
 	*)
 	let v_res = build_entry_lc env funnames avoid v in
-	let v_as_constr = Pretyping.Default.understand Evd.empty env v in
+	let v_as_constr,ctx = Pretyping.understand env Evd.empty v in
 	let v_type = Typing.type_of env Evd.empty v_as_constr in
 	let new_env =
 	  match n with
@@ -645,7 +610,7 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 	let make_discr = make_discr_match brl in
 	build_entry_lc_from_case env funnames make_discr el brl avoid
     | GIf(_,b,(na,e_option),lhs,rhs) ->
-	let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	let b_as_constr,ctx = Pretyping.understand env Evd.empty b in
 	let b_typ = Typing.type_of env Evd.empty b_as_constr in
 	let (ind,_) =
 	  try Inductiveops.find_inductive env Evd.empty b_typ
@@ -654,11 +619,11 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 			       Printer.pr_glob_constr b ++ str " in " ++
 			       Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	in
-	let case_pats = build_constructors_of_type ind None in
-	assert (Array.length case_pats = 2);
+	let case_pats = build_constructors_of_type (fst ind) [] in
+	assert (Int.equal (Array.length case_pats) 2);
 	let brl =
-	  list_map_i
-	    (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
+	  List.map_i
+	    (fun i x -> (Loc.ghost,[],[case_pats.(i)],x))
 	    0
 	    [lhs;rhs]
 	in
@@ -670,14 +635,14 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
     | GLetTuple(_,nal,_,b,e) ->
 	begin
 	  let nal_as_glob_constr =
-	    Some (List.map
+	    List.map
 	      (function
 		   Name id -> mkGVar id
 		 | Anonymous -> mkGHole ()
 	      )
-	      nal)
+	      nal
 	  in
-	  let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+	  let b_as_constr,ctx = Pretyping.understand env Evd.empty b in
 	  let b_typ = Typing.type_of env Evd.empty b_as_constr in
 	  let (ind,_) =
 	    try Inductiveops.find_inductive env Evd.empty b_typ
@@ -686,10 +651,10 @@ let rec build_entry_lc env funnames avoid rt  : glob_constr build_entry_return =
 				 Printer.pr_glob_constr b ++ str " in " ++
 				 Printer.pr_glob_constr rt ++ str ". try again with a cast")
 	  in
-	  let case_pats = build_constructors_of_type ind nal_as_glob_constr in
-	  assert (Array.length case_pats = 1);
+	  let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in
+	  assert (Int.equal (Array.length case_pats) 1);
 	  let br =
-	    (dummy_loc,[],[case_pats.(0)],e)
+	    (Loc.ghost,[],[case_pats.(0)],e)
 	  in
 	  let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in
 	  build_entry_lc env funnames avoid match_expr
@@ -724,7 +689,7 @@ and build_entry_lc_from_case env funname make_discr
 	in
 	let types =
 	  List.map (fun (case_arg,_) ->
-		      let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
+		      let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in
 		      Typing.type_of env Evd.empty case_arg_as_constr
 		   ) el
 	in
@@ -746,7 +711,8 @@ and build_entry_lc_from_case env funname make_discr
 	{
 	  result = List.concat (List.map (fun r -> r.result) results);
 	  to_avoid =
-	    List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
+	    List.fold_left (fun acc r -> List.union Id.equal acc r.to_avoid)
+              [] results
 	}
 
 and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
@@ -761,7 +727,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 	   (will be used in the following recursive calls)
 	*)
 	let new_env = List.fold_right2 add_pat_variables patl types env in
-	let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list =
+	let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list =
 	  List.map2
 	    (fun pat typ ->
 	       fun avoid pat'_as_term ->
@@ -775,7 +741,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 			in
 			let raw_typ_of_id =
 			  Detyping.detype false []
-			    (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
+			    env_with_pat_ids Evd.empty typ_of_id
 			in
 			mkGProd (Name id,raw_typ_of_id,acc))
 		     pat_ids
@@ -816,18 +782,18 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
       	let those_pattern_preconds =
 	  (List.flatten
 	    (
-	      list_map3
+	      List.map3
 	      (fun pat e typ_as_constr ->
 		 let this_pat_ids = ids_of_pat pat in
-		 let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
+		 let typ = Detyping.detype false [] new_env Evd.empty typ_as_constr in
 		 let pat_as_term = pattern_to_term pat in
 		 List.fold_right
 		   (fun id  acc ->
-		      if Idset.mem id this_pat_ids
+		      if Id.Set.mem id this_pat_ids
 		      then (Prod (Name id),
 		      let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
 		      let raw_typ_of_id =
-			Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
+			Detyping.detype false [] new_env Evd.empty typ_of_id
 		      in
 		      raw_typ_of_id
 			   )::acc
@@ -871,14 +837,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
 
 let is_res id =
   try
-    String.sub (string_of_id id) 0 3 = "res"
+    String.equal (String.sub (Id.to_string id) 0 4) "_res"
   with Invalid_argument _ -> false
 
 
 
 let same_raw_term rt1 rt2 = 
   match rt1,rt2 with 
-    | GRef(_,r1), GRef (_,r2) -> r1=r2
+    | GRef(_,r1,_), GRef (_,r2,_) -> Globnames.eq_gr r1 r2
     | GHole _, GHole _ -> true
     | _ -> false
 let decompose_raw_eq lhs rhs = 
@@ -892,7 +858,7 @@ let decompose_raw_eq lhs rhs =
     observe (str "lrhs := " ++ int (List.length lrhs));
     let sllhs = List.length llhs in 
     let slrhs = List.length lrhs in 
-    if same_raw_term lhd rhd && sllhs = slrhs 
+    if same_raw_term lhd rhd && Int.equal sllhs slrhs 
     then
       (* let _ = assert false in  *)
       List.fold_right2 decompose_raw_eq	llhs lrhs acc
@@ -928,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			let new_t =
 			  mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
 			in
-			let t' = Pretyping.Default.understand Evd.empty env new_t in
+			let t',ctx = Pretyping.understand env Evd.empty new_t in
 			let new_env = Environ.push_rel (n,None,t') env in
 			let new_b,id_to_exclude =
 			  rebuild_cons new_env
@@ -937,18 +903,18 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 			    (depth + 1) b
 			in
 			mkGProd(n,new_t,new_b),
-			Idset.filter not_free_in_t id_to_exclude
+			Id.Set.filter not_free_in_t id_to_exclude
 		    | _ -> (* the first args is the name of the function! *)
 			assert false
 		end
-	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt])
-		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;GVar(loc3,id);rt])
+		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref)  && n == Anonymous
 		  ->
 		begin
 		  try
 		    observe (str "computing new type for eq : " ++ pr_glob_constr rt);
 		    let t' =
-		      try Pretyping.Default.understand Evd.empty env t
+		      try fst (Pretyping.understand env Evd.empty t)(*FIXME*)
                       with e when Errors.noncritical e -> raise Continue
 		    in
 		    let is_in_b = is_free_in id b in
@@ -970,36 +936,36 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    in
 		    mkGProd(n,t,new_b),id_to_exclude
 		  with Continue ->
-		    let jmeq = Libnames.IndRef (destInd (jmeq ())) in
-		    let ty' = Pretyping.Default.understand Evd.empty env ty in
+		    let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in
+		    let ty',ctx = Pretyping.understand env Evd.empty ty in
 		    let ind,args' = Inductive.find_inductive env ty' in
-		    let mib,_ = Global.lookup_inductive ind in
+		    let mib,_ = Global.lookup_inductive (fst ind) in
 		    let nparam = mib.Declarations.mind_nparams in
 		    let params,arg' =
-		      ((Util.list_chop nparam args'))
+		      ((Util.List.chop nparam args'))
 		    in
 		    let rt_typ =
-		       GApp(Util.dummy_loc,
-			    GRef (Util.dummy_loc,Libnames.IndRef ind),
+		       GApp(Loc.ghost,
+			    GRef (Loc.ghost,Globnames.IndRef (fst ind),None),
 			    (List.map
 			      (fun p -> Detyping.detype false []
-				 (Termops.names_of_rel_context env)
+				 env Evd.empty
 				 p) params)@(Array.to_list
 				      (Array.make
 					 (List.length args' - nparam)
 					 (mkGHole ()))))
 		    in
 		    let eq' =
-		      GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt])
+		      GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt])
 		    in
 		    observe (str "computing new type for jmeq : " ++ pr_glob_constr eq');
-		    let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
+		    let eq'_as_constr,ctx = Pretyping.understand env Evd.empty eq' in
 		    observe (str " computing new type for jmeq : done") ;
 		    let new_args =
 		      match kind_of_term eq'_as_constr with
 			| App(_,[|_;_;ty;_|]) ->
 			    let ty = Array.to_list (snd (destApp ty)) in
-			    let ty' = snd (Util.list_chop nparam ty) in
+			    let ty' = snd (Util.List.chop nparam ty) in
 			    List.fold_left2
 			      (fun acc var_as_constr arg ->
 				 if isRel var_as_constr
@@ -1011,11 +977,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 				     | Anonymous -> acc
 				     | Name id' ->
 					 (id',Detyping.detype false []
-					    (Termops.names_of_rel_context env)
+					    env
+                                            Evd.empty
 					    arg)::acc
 				 else if isVar var_as_constr
 				 then (destVar var_as_constr,Detyping.detype false []
-					 (Termops.names_of_rel_context env)
+					 env
+                                         Evd.empty
 					 arg)::acc
 				 else acc
 			      )
@@ -1041,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		     if is_in_b then b else  replace_var_by_term id rt b
 		    in
 		    let new_env =
-		      let t' = Pretyping.Default.understand Evd.empty env eq' in
+		      let t',ctx = Pretyping.understand env Evd.empty eq' in
 		      Environ.push_rel (n,None,t') env
 		    in
 		    let new_b,id_to_exclude =
@@ -1056,10 +1024,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  (* J.F:. keep this comment  it explain how to remove some meaningless equalities
 		     if keep_eq then
 		     mkGProd(n,t,new_b),id_to_exclude
-		     else new_b, Idset.add id id_to_exclude
+		     else new_b, Id.Set.add id id_to_exclude
 		  *)
-	    | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2])
-		when  eq_as_ref = Lazy.force Coqlib.coq_eq_ref  && n = Anonymous
+	    | GApp(loc1,GRef(loc2,eq_as_ref,_),[ty;rt1;rt2])
+		when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous
 		  ->
 	      begin
 		try 
@@ -1079,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		  else raise Continue
 	      with Continue -> 
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
-		let t' = Pretyping.Default.understand Evd.empty env t in
+		let t',ctx = Pretyping.understand env Evd.empty t in
 		let new_env = Environ.push_rel (n,None,t') env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
@@ -1088,14 +1056,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (depth + 1) b
 		in
 		match n with
-		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id
-			(Idset.filter not_free_in_t id_to_exclude)
-		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args ->
+		      new_b,Id.Set.remove id
+			(Id.Set.filter not_free_in_t id_to_exclude)
+		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	      end
 	    | _ ->
 		observe (str "computing new type for prod : " ++ pr_glob_constr rt);
-		let t' = Pretyping.Default.understand Evd.empty env t in
+		let t',ctx = Pretyping.understand env Evd.empty t in
 		let new_env = Environ.push_rel (n,None,t') env in
 		let new_b,id_to_exclude =
 		  rebuild_cons new_env
@@ -1104,17 +1072,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (depth + 1) b
 		in
 		match n with
-		  | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
-		      new_b,Idset.remove id
-			(Idset.filter not_free_in_t id_to_exclude)
-		  | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+		  | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args ->
+		      new_b,Id.Set.remove id
+			(Id.Set.filter not_free_in_t id_to_exclude)
+		  | _ -> mkGProd(n,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
 	end
     | GLambda(_,n,k,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_crossed_types = t :: crossed_types in
 	  observe (str "computing new type for lambda : " ++ pr_glob_constr rt);
-	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  let t',ctx = Pretyping.understand env Evd.empty t in
 	  match n with
 	    | Name id ->
 		let new_env = Environ.push_rel (n,None,t') env in
@@ -1124,19 +1092,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 		    (args@[mkGVar id])new_crossed_types
 		    (depth + 1 ) b
 		in
-		if Idset.mem id id_to_exclude && depth >= nb_args
+		if Id.Set.mem id id_to_exclude && depth >= nb_args
 		then
-		  new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+		  new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
 		else
-		  GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
-	    | _ -> anomaly "Should not have an anonymous function here"
+		  GProd(Loc.ghost,n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude
+	    | _ -> anomaly (Pp.str "Should not have an anonymous function here")
 		(* We have renamed all the anonymous functions during alpha_renaming phase *)
 
 	end
     | GLetIn(_,n,t,b) ->
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
-	  let t' = Pretyping.Default.understand Evd.empty env t in
+	  let t',ctx = Pretyping.understand env Evd.empty t in
 	  let type_t' = Typing.type_of env Evd.empty t' in
 	  let new_env = Environ.push_rel (n,Some t',type_t') env in
 	  let new_b,id_to_exclude =
@@ -1145,13 +1113,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      args (t::crossed_types)
 	      (depth + 1 ) b in
 	  match n with
-	    | Name id when Idset.mem id id_to_exclude && depth >= nb_args  ->
-		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
-	    | _ -> GLetIn(dummy_loc,n,t,new_b),
-		Idset.filter not_free_in_t id_to_exclude
+	    | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args  ->
+		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude)
+	    | _ -> GLetIn(Loc.ghost,n,t,new_b),
+		Id.Set.filter not_free_in_t id_to_exclude
 	end
     | GLetTuple(_,nal,(na,rto),t,b) ->
-	assert (rto=None);
+	assert (Option.is_empty rto);
 	begin
 	  let not_free_in_t id = not (is_free_in id t) in
 	  let new_t,id_to_exclude' =
@@ -1161,7 +1129,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      args (crossed_types)
 	      depth t
 	  in
-	  let t' = Pretyping.Default.understand Evd.empty env new_t in
+	  let t',ctx = Pretyping.understand env Evd.empty new_t in
 	  let new_env = Environ.push_rel (na,None,t') env in
 	  let new_b,id_to_exclude =
 	    rebuild_cons new_env
@@ -1170,15 +1138,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
 	      (depth + 1) b
 	  in
 (* 	  match n with  *)
-(* 	    | Name id when Idset.mem id id_to_exclude ->  *)
-(* 		new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
+(* 	    | Name id when Id.Set.mem id id_to_exclude ->  *)
+(* 		new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *)
 (* 	    | _ -> *)
-	  GLetTuple(dummy_loc,nal,(na,None),t,new_b),
-		Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
+	  GLetTuple(Loc.ghost,nal,(na,None),t,new_b),
+		Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude')
 
 	end
 
-    | _ -> mkGApp(mkGVar  relname,args@[rt]),Idset.empty
+    | _ -> mkGApp(mkGVar  relname,args@[rt]),Id.Set.empty
 
 
 (* debuging wrapper *)
@@ -1201,7 +1169,7 @@ let rebuild_cons env nb_args relname args crossed_types rt =
 *)
 let rec compute_cst_params relnames params = function
   | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params
-  | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+  | GApp(_,GVar(_,relname'),rtl) when Id.Set.mem relname' relnames ->
       compute_cst_params_from_app [] (params,rtl)
   | GApp(_,f,args) ->
       List.fold_left (compute_cst_params relnames) params (f::args)
@@ -1219,11 +1187,11 @@ and compute_cst_params_from_app acc (params,rtl) =
   match params,rtl with
     | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
     | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl'
-	when id_ord id id' == 0 && not is_defined ->
+	when Id.compare id id' == 0 && not is_defined ->
 	compute_cst_params_from_app (param::acc) (params',rtl')
     | _  -> List.rev acc
 
-let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts =
+let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts =
   let rels_params =
     Array.mapi
       (fun i args ->
@@ -1237,12 +1205,12 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b
   let l = ref [] in
   let _ =
     try
-      list_iter_i
+      List.iteri
 	(fun i ((n,nt,is_defined) as param) ->
-	   if array_for_all
+	   if Array.for_all
 	     (fun l ->
 		let (n',nt',is_defined') = List.nth l i in
-		n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined')
+		Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined')
 	     rels_params
 	   then
 	     l := param::!l
@@ -1255,22 +1223,23 @@ let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * b
 
 let rec rebuild_return_type rt =
   match rt with
-    | Topconstr.CProdN(loc,n,t') ->
-	Topconstr.CProdN(loc,n,rebuild_return_type t')
-    | Topconstr.CArrow(loc,t,t') ->
-	Topconstr.CArrow(loc,t,rebuild_return_type t')
-    | Topconstr.CLetIn(loc,na,t,t') ->
-	Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
-    | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None))
+    | Constrexpr.CProdN(loc,n,t') ->
+	Constrexpr.CProdN(loc,n,rebuild_return_type t')
+    | Constrexpr.CLetIn(loc,na,t,t') ->
+	Constrexpr.CLetIn(loc,na,t,rebuild_return_type t')
+    | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous],
+				       Constrexpr.Default Decl_kinds.Explicit,rt],
+			    Constrexpr.CSort(Loc.ghost,GType []))
 
 
 let do_build_inductive
-    funnames (funsargs: (Names.name * glob_constr * bool) list list)
-    returned_types
-    (rtl:glob_constr list) =
+      mp_dp
+      funnames (funsargs: (Name.t * glob_constr * bool) list list)
+      returned_types
+      (rtl:glob_constr list) =
   let _time1 = System.get_time () in
-(*   Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *)
-  let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
+  (*   Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *)
+  let funnames_as_set = List.fold_right Id.Set.add funnames Id.Set.empty in
   let funnames = Array.of_list funnames in
   let funsargs = Array.of_list funsargs in
   let returned_types = Array.of_list returned_types in
@@ -1281,12 +1250,22 @@ let do_build_inductive
     Ensures by: obvious
     i*)
   let relnames = Array.map mk_rel_id funnames in
-  let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
+  let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in
   (* Construction of the pseudo constructors *)
   let env =
     Array.fold_right
       (fun id env ->
-	 Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id))  env
+       let c =
+	 match mp_dp with
+	 | None -> (Constrintern.global_reference id)
+	 | Some(mp,dp) -> mkConst (make_con mp dp (Label.of_id id))
+       in
+       Environ.push_named (id,None,
+			   try
+			     Typing.type_of env Evd.empty c
+			   with Not_found ->
+			     raise (UserError("do_build_inductive", str "Cannot handle partial fixpoint"))
+			  )  env
       )
       funnames
       (Global.env ())
@@ -1294,19 +1273,19 @@ let do_build_inductive
   let resa = Array.map (build_entry_lc env  funnames_as_set []) rta in
   let env_with_graphs =
     let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-      let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list  =
+      let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
 	funargs
       in
       List.fold_right
 	(fun (n,t,is_defined) acc ->
 	   if is_defined
 	   then
-	     Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
+	     Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
 			      acc)
 	   else
-	     Topconstr.CProdN
-	       (dummy_loc,
-		[[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
+	     Constrexpr.CProdN
+	       (Loc.ghost,
+		[[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
 		acc
 	       )
 	)
@@ -1318,8 +1297,9 @@ let do_build_inductive
        Then save the graphs and reset Printing options to their primitive values
     *)
     let rel_arities = Array.mapi rel_arity funsargs in
-    Util.array_fold_left2 (fun env rel_name rel_ar ->
-			     Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
+    Util.Array.fold_left2 (fun env rel_name rel_ar ->
+			     Environ.push_named (rel_name,None, 
+						 fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities
   in
   (* and of the real constructors*)
   let constr i res =
@@ -1344,9 +1324,9 @@ let do_build_inductive
     (*i The next call to mk_rel_id is valid since we are constructing the graph
       Ensures by: obvious
       i*)
-    id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
+    Id.of_string ((Id.to_string (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
   in
-  let rel_constructors i rt : (identifier*glob_constr) list =
+  let rel_constructors i rt : (Id.t*glob_constr) list =
     next_constructor_id := (-1);
     List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
   in
@@ -1360,19 +1340,19 @@ let do_build_inductive
     rel_constructors
   in
   let rel_arity i funargs =  (* Reduilding arities (with parameters) *)
-    let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list  =
-      (snd (list_chop nrel_params funargs))
+    let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list  =
+      (snd (List.chop nrel_params funargs))
     in
     List.fold_right
       (fun (n,t,is_defined) acc ->
 	 if is_defined
 	 then
-	   Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
+	   Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t,
 			    acc)
 	 else
-	   Topconstr.CProdN
-	   (dummy_loc,
-	   [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
+	   Constrexpr.CProdN
+	   (Loc.ghost,
+	   [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t],
 	    acc
 	   )
       )
@@ -1384,31 +1364,40 @@ let do_build_inductive
      Then save the graphs and reset Printing options to their primitive values
   *)
   let rel_arities = Array.mapi rel_arity funsargs in
+  let rel_params_ids =
+    List.fold_left
+      (fun  acc (na,_,_) ->
+       match na with
+	 Anonymous -> acc
+       | Name id -> id::acc
+      )
+      []
+      rels_params
+  in
   let rel_params =
     List.map
       (fun (n,t,is_defined) ->
 	 if is_defined
 	 then
-	   Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t)
+	   Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t)
 	 else
-	 Topconstr.LocalRawAssum
-	   ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t)
+	 Constrexpr.LocalRawAssum
+	   ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t)
       )
       rels_params
   in
   let ext_rels_constructors =
     Array.map (List.map
       (fun (id,t) ->
-	 false,((dummy_loc,id),
-		Flags.with_option
-		  Flags.raw_print
-		  (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t)
+	 false,((Loc.ghost,id),
+		with_full_print
+		  (Constrextern.extern_glob_type Id.Set.empty) ((* zeta_normalize *) (alpha_rt rel_params_ids t))
 	       )
       ))
       (rel_constructors)
   in
   let rel_ind i ext_rel_constructors =
-    ((dummy_loc,relnames.(i)),
+    ((Loc.ghost,relnames.(i)),
     rel_params,
     Some rel_arities.(i),
     ext_rel_constructors),[]
@@ -1437,7 +1426,7 @@ let do_build_inductive
 (*   in *)
   let _time2 = System.get_time () in
   try
-    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true
+    with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds false false)) Decl_kinds.Finite
   with
     | UserError(s,msg) as e ->
 	let _time3 = System.get_time () in
@@ -1448,7 +1437,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
 	    ++ fnl () ++
 	    msg
 	in
@@ -1463,7 +1452,7 @@ let do_build_inductive
 	in
 	let msg =
 	  str "while trying to define"++ spc () ++
-	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+	    Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
 	    ++ fnl () ++
 	    Errors.print reraise
 	in
@@ -1472,9 +1461,9 @@ let do_build_inductive
 
 
 
-let build_inductive funnames funsargs returned_types rtl =
+let build_inductive mp_dp funnames funsargs returned_types rtl =
   try
-    do_build_inductive funnames funsargs returned_types rtl
+    do_build_inductive mp_dp funnames funsargs returned_types rtl
   with e when Errors.noncritical e -> raise (Building_graph e)
 
 
diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli
index 5c91292b..b0a05ec3 100644
--- a/plugins/funind/glob_term_to_relation.mli
+++ b/plugins/funind/glob_term_to_relation.mli
@@ -1,5 +1,4 @@
-
-
+open Names
 
 (*
   [build_inductive parametrize funnames funargs returned_types bodies]
@@ -8,9 +7,10 @@
 *)
 
 val build_inductive :
-  Names.identifier list -> (* The list of function name *)
-  (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
-  Topconstr.constr_expr list -> (* The list of function returned type *)
+  (ModPath.t * DirPath.t) option ->
+  Id.t list -> (* The list of function name *)
+  (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
+  Constrexpr.constr_expr list -> (* The list of function returned type *)
   Glob_term.glob_constr list -> (* the list of body *)
   unit
 
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 6cc932b1..291f835e 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,24 +1,25 @@
 open Pp
 open Glob_term
+open Errors
 open Util
 open Names
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-let idmap_is_empty m = m = Idmap.empty
+open Decl_kinds
+open Misctypes
 
 (*
    Some basic functions to rebuild glob_constr
-   In each of them the location is Util.dummy_loc
+   In each of them the location is Loc.ghost
 *)
-let mkGRef ref = GRef(dummy_loc,ref)
-let mkGVar id = GVar(dummy_loc,id)
-let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl)
-let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b)
-let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b)
-let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b)
-let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl)
-let mkGSort s = GSort(dummy_loc,s)
-let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous)
-let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
+let mkGRef ref = GRef(Loc.ghost,ref,None)
+let mkGVar id = GVar(Loc.ghost,id)
+let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl)
+let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b)
+let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b)
+let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b)
+let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl)
+let mkGSort s = GSort(Loc.ghost,s)
+let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None)
+let mkGCast(b,t) = GCast(Loc.ghost,b,CastConv t)
 
 (*
   Some basic functions to decompose glob_constrs
@@ -107,7 +108,7 @@ let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
    to [P1 \/ ( .... \/ Pn)]
 *)
 let rec glob_make_or_list = function
-  | [] -> raise (Invalid_argument "mk_or")
+  | [] -> invalid_arg "mk_or"
   | [e] -> e
   | e::l -> glob_make_or e (glob_make_or_list l)
 
@@ -115,7 +116,7 @@ let rec glob_make_or_list = function
 let remove_name_from_mapping mapping na =
   match na with
     | Anonymous -> mapping
-    | Name id -> Idmap.remove id mapping
+    | Name id -> Id.Map.remove id mapping
 
 let change_vars =
   let rec change_vars mapping rt =
@@ -124,7 +125,7 @@ let change_vars =
       | GVar(loc,id) ->
 	  let new_id =
 	    try
-	      Idmap.find id mapping
+	      Id.Map.find id mapping
 	    with Not_found -> id
 	  in
 	  GVar(loc,new_id)
@@ -179,13 +180,12 @@ let change_vars =
       | GRec _ -> error "Local (co)fixes are not supported"
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv (k,t)) ->
-	  GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,change_vars mapping b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,change_vars mapping b,
+		Miscops.map_cast_type (change_vars mapping) c)
   and change_vars_br mapping ((loc,idl,patl,res) as br) =
-    let new_mapping = List.fold_right Idmap.remove idl mapping in
-    if idmap_is_empty new_mapping
+    let new_mapping = List.fold_right Id.Map.remove idl mapping in
+    if Id.Map.is_empty new_mapping
     then br
     else (loc,idl,patl,change_vars new_mapping res)
   in
@@ -197,27 +197,27 @@ let rec alpha_pat excluded pat =
   match pat with
     | PatVar(loc,Anonymous) ->
 	let new_id = Indfun_common.fresh_id excluded "_x" in
-	PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
+	PatVar(loc,Name new_id),(new_id::excluded),Id.Map.empty
     | PatVar(loc,Name id) ->
-	if List.mem id excluded
+	if Id.List.mem id excluded
 	then
 	  let new_id = Namegen.next_ident_away id excluded in
 	  PatVar(loc,Name new_id),(new_id::excluded),
-	(Idmap.add id new_id Idmap.empty)
-	else pat,excluded,Idmap.empty
+	(Id.Map.add id new_id Id.Map.empty)
+	else pat,excluded,Id.Map.empty
     | PatCstr(loc,constr,patl,na) ->
 	let new_na,new_excluded,map =
 	  match na with
-	    | Name id when List.mem id excluded ->
+	    | Name id when Id.List.mem id excluded ->
 		let new_id = Namegen.next_ident_away id excluded in
-		Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
-	    | _ -> na,excluded,Idmap.empty
+		Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty
+	    | _ -> na,excluded,Id.Map.empty
 	in
 	let new_patl,new_excluded,new_map =
 	  List.fold_left
 	    (fun (patl,excluded,map) pat ->
 	       let new_pat,new_excluded,new_map = alpha_pat excluded pat in
-	       (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
+	       (new_pat::patl,new_excluded,Id.Map.fold Id.Map.add new_map map)
 	    )
 	    ([],new_excluded,map)
 	    patl
@@ -229,9 +229,9 @@ let alpha_patl excluded patl  =
     List.fold_left
       (fun (patl,excluded,map) pat ->
 	 let new_pat,new_excluded,new_map = alpha_pat excluded pat in
-	 new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
+	 new_pat::patl,new_excluded,(Id.Map.fold Id.Map.add new_map map)
       )
-      ([],excluded,Idmap.empty)
+      ([],excluded,Id.Map.empty)
       patl
   in
   (List.rev patl,new_excluded,map)
@@ -263,7 +263,7 @@ let rec alpha_rt excluded rt =
     match rt with
       | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt
       | GLambda(loc,Anonymous,k,t,b) ->
-	  let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
+	  let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in
 	  let new_excluded = new_id :: excluded in
 	  let new_t = alpha_rt new_excluded t in
 	  let new_b = alpha_rt new_excluded b in
@@ -279,10 +279,10 @@ let rec alpha_rt excluded rt =
     | GLambda(loc,Name id,k,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_excluded = new_id::excluded in
@@ -293,10 +293,10 @@ let rec alpha_rt excluded rt =
 	let new_id = Namegen.next_ident_away id excluded in
 	let new_excluded = new_id::excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_t = alpha_rt new_excluded t in
@@ -305,10 +305,10 @@ let rec alpha_rt excluded rt =
     | GLetIn(loc,Name id,t,b) ->
 	let new_id = Namegen.next_ident_away id excluded in
 	let t,b =
-	  if new_id = id
+	  if Id.equal new_id id
 	  then t,b
 	  else
-	    let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+	    let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in
 	    (t,replace b)
 	in
 	let new_excluded = new_id::excluded in
@@ -325,18 +325,18 @@ let rec alpha_rt excluded rt =
 		 | Anonymous -> (na::nal,excluded,mapping)
 		 | Name id ->
 		     let new_id = Namegen.next_ident_away id excluded in
-		     if new_id = id
+		     if Id.equal new_id id
 		     then
 		       na::nal,id::excluded,mapping
 		     else
-		       (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
+		       (Name new_id)::nal,id::excluded,(Id.Map.add id new_id mapping)
 	    )
-	    ([],excluded,Idmap.empty)
+	    ([],excluded,Id.Map.empty)
 	    nal
 	in
 	let new_nal = List.rev rev_new_nal in
 	let new_rto,new_t,new_b =
-	  if idmap_is_empty mapping
+	  if Id.Map.is_empty mapping
 	  then rto,t,b
 	  else let replace = change_vars mapping in
 	  (Option.map replace rto, t,replace b)
@@ -359,10 +359,9 @@ let rec alpha_rt excluded rt =
     | GRec _ -> error "Not handled GRec"
     | GSort _ -> rt
     | GHole _ -> rt
-    | GCast (loc,b,CastConv (k,t)) ->
-	GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
-    | GCast (loc,b,CastCoerce) ->
-	GCast(loc,alpha_rt excluded b,CastCoerce)
+    | GCast (loc,b,c) ->
+	GCast(loc,alpha_rt excluded b,
+	      Miscops.map_cast_type (alpha_rt excluded) c)
     | GApp(loc,f,args) ->
 	GApp(loc,
 	     alpha_rt excluded f,
@@ -385,14 +384,14 @@ and alpha_br excluded (loc,ids,patl,res) =
 let is_free_in id =
   let rec is_free_in = function
     | GRef _ ->  false
-    | GVar(_,id') -> id_ord id' id == 0
+    | GVar(_,id') -> Id.compare id' id == 0
     | GEvar _ -> false
     | GPatVar _ -> false
     | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
     | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) ->
 	let check_in_b =
 	  match n with
-	    | Name id' -> id_ord id' id <> 0
+	    | Name id' -> not (Id.equal id' id)
 	    | _ -> true
 	in
 	is_free_in t || (check_in_b && is_free_in b)
@@ -401,7 +400,7 @@ let is_free_in id =
 	  List.exists is_free_in_br brl
     | GLetTuple(_,nal,_,b,t) ->
 	let check_in_nal =
-	  not (List.exists (function Name id' -> id'= id | _ -> false) nal)
+	  not (List.exists (function Name id' -> Id.equal id' id | _ -> false) nal)
 	in
 	is_free_in t  || (check_in_nal && is_free_in b)
 
@@ -410,10 +409,10 @@ let is_free_in id =
     | GRec _ -> raise (UserError("",str "Not handled GRec"))
     | GSort _ -> false
     | GHole _ -> false
-    | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
+    | GCast (_,b,(CastConv t|CastVM t|CastNative t)) -> is_free_in b || is_free_in t
     | GCast (_,b,CastCoerce) -> is_free_in b
   and is_free_in_br (_,ids,_,rt) =
-    (not (List.mem id ids)) && is_free_in rt
+    (not (Id.List.mem id ids)) && is_free_in rt
   in
   is_free_in
 
@@ -425,7 +424,7 @@ let rec pattern_to_term  = function
 	mkGVar id
   | PatCstr(loc,constr,patternl,_) ->
       let cst_narg =
-	Inductiveops.mis_constructor_nargs_env
+	Inductiveops.constructor_nallargs_env
 	  (Global.env ())
 	  constr
       in
@@ -439,7 +438,7 @@ let rec pattern_to_term  = function
       let patl_as_term =
 	List.map pattern_to_term patternl
       in
-      mkGApp(mkGRef(Libnames.ConstructRef constr),
+      mkGApp(mkGRef(Globnames.ConstructRef constr),
 	     implicit_args@patl_as_term
 	    )
 
@@ -449,7 +448,7 @@ let replace_var_by_term x_id term =
   let rec replace_var_by_pattern rt =
     match rt with
       | GRef _ -> rt
-      | GVar(_,id) when id_ord id x_id == 0 -> term
+      | GVar(_,id) when Id.compare id x_id == 0 -> term
       | GVar _ -> rt
       | GEvar _ -> rt
       | GPatVar _ -> rt
@@ -458,7 +457,7 @@ let replace_var_by_term x_id term =
 	       replace_var_by_pattern rt',
 	       List.map replace_var_by_pattern rtl
 	      )
-      | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GLambda(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
       | GLambda(loc,name,k,t,b) ->
 	  GLambda(loc,
 		  name,
@@ -466,7 +465,7 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+      | GProd(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt
       | GProd(loc,name,k,t,b) ->
 	  GProd(loc,
 		  name,
@@ -474,7 +473,7 @@ let replace_var_by_term x_id term =
 		  replace_var_by_pattern t,
 		  replace_var_by_pattern b
 		 )
-      | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+      | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt
       | GLetIn(loc,name,def,b) ->
 	  GLetIn(loc,
 		 name,
@@ -482,7 +481,7 @@ let replace_var_by_term x_id term =
 		 replace_var_by_pattern b
 		)
       | GLetTuple(_,nal,_,_,_)
-	  when List.exists (function Name id -> id = x_id | _ -> false) nal  ->
+	  when List.exists (function Name id -> Id.equal id x_id | _ -> false) nal  ->
 	  rt
       | GLetTuple(loc,nal,(na,rto),def,b) ->
 	  GLetTuple(loc,
@@ -506,12 +505,11 @@ let replace_var_by_term x_id term =
       | GRec _ -> raise (UserError("",str "Not handled GRec"))
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv(k,t)) ->
-	  GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,replace_var_by_pattern b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,replace_var_by_pattern b,
+		Miscops.map_cast_type replace_var_by_pattern c)
   and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
-    if List.exists (fun id -> id_ord id x_id == 0) idl
+    if List.exists (fun id -> Id.compare id x_id == 0) idl
     then br
     else (loc,idl,patl,replace_var_by_pattern res)
   in
@@ -529,13 +527,12 @@ let rec are_unifiable_aux  = function
       match eq with
 	 | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
 	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
-	     if constructor2 <> constructor1
+	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with e when Errors.noncritical e ->
-                   anomaly "are_unifiable_aux"
+		 try (List.combine cpl1 cpl2) @ eqs
+		 with Invalid_argument _ -> anomaly (Pp.str "are_unifiable_aux")
 	       in
 	       are_unifiable_aux eqs'
 
@@ -552,13 +549,12 @@ let rec eq_cases_pattern_aux  = function
       match eq with
 	 | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
 	 | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
-	     if constructor2 <> constructor1
+	     if not (eq_constructor constructor2 constructor1)
 	     then raise NotUnifiable
 	     else
 	       let eqs' =
- 		 try  ((List.combine cpl1 cpl2)@eqs)
-		 with e when Errors.noncritical e ->
-                   anomaly "eq_cases_pattern_aux"
+		 try (List.combine cpl1 cpl2) @ eqs
+		 with Invalid_argument _ -> anomaly (Pp.str "eq_cases_pattern_aux")
 	       in
 	       eq_cases_pattern_aux eqs'
 	 | _ -> raise NotUnifiable
@@ -574,13 +570,13 @@ let eq_cases_pattern pat1 pat2 =
 let ids_of_pat =
   let rec ids_of_pat ids = function
     | PatVar(_,Anonymous) -> ids
-    | PatVar(_,Name id) -> Idset.add id ids
+    | PatVar(_,Name id) -> Id.Set.add id ids
     | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
   in
-  ids_of_pat Idset.empty
+  ids_of_pat Id.Set.empty
 
 let id_of_name = function
-  | Names.Anonymous -> id_of_string "x"
+  | Names.Anonymous -> Id.of_string "x"
   | Names.Name x -> x
 
 (* TODO: finish Rec caes *)
@@ -594,7 +590,7 @@ let ids_of_glob_constr c =
       | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
       | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
       | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
-      | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
+      | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
       | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc
       | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
       | GLetTuple (_,nal,(na,po),b,c) ->
@@ -605,7 +601,7 @@ let ids_of_glob_constr c =
       | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
   in
   (* build the set *)
-  List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c)
+  List.fold_left (fun acc x -> Id.Set.add x acc) Id.Set.empty (ids_of_glob_constr [] c)
 
 
 
@@ -662,10 +658,9 @@ let zeta_normalize =
       | GRec _ -> raise (UserError("",str "Not handled GRec"))
       | GSort _ -> rt
       | GHole _ -> rt
-      | GCast(loc,b,CastConv(k,t)) ->
-	  GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
-      | GCast(loc,b,CastCoerce) ->
-	  GCast(loc,zeta_normalize_term b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,zeta_normalize_term b,
+                Miscops.map_cast_type zeta_normalize_term c)
   and zeta_normalize_br (loc,idl,patl,res) =
     (loc,idl,patl,zeta_normalize_term res)
   in
@@ -680,7 +675,7 @@ let expand_as =
     match pat with
       | PatVar _ -> map
       | PatCstr(_,_,patl,Name id) ->
-	  Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
+	  Id.Map.add id (pattern_to_term pat) (List.fold_left add_as map patl)
       | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
   in
   let rec expand_as map rt =
@@ -689,7 +684,7 @@ let expand_as =
       | GVar(_,id) ->
 	  begin
 	    try
-	      Idmap.find id map
+	      Id.Map.find id map
 	    with Not_found -> rt
 	  end
       | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args)
@@ -703,12 +698,13 @@ let expand_as =
 	  GIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
 	      expand_as map br1, expand_as map br2)
       | GRec _ ->  error "Not handled GRec"
-      | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t))
-      | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce)
+      | GCast(loc,b,c) ->
+	  GCast(loc,expand_as map b,
+		Miscops.map_cast_type (expand_as map) c)
       | GCases(loc,sty,po,el,brl) ->
 	  GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
 		List.map (expand_as_br map) brl)
   and expand_as_br map (loc,idl,cpl,rt) =
     (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
   in
-  expand_as Idmap.empty
+  expand_as Id.Map.empty
diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli
index bfd15357..0f10636f 100644
--- a/plugins/funind/glob_termops.mli
+++ b/plugins/funind/glob_termops.mli
@@ -1,11 +1,9 @@
+open Names
 open Glob_term
-
-(* Ocaml 3.06 Map.S does not handle is_empty *)
-val idmap_is_empty : 'a Names.Idmap.t -> bool
-
+open Misctypes
 
 (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
-val get_pattern_id : cases_pattern -> Names.identifier list
+val get_pattern_id : cases_pattern -> Id.t list
 
 (* [pattern_to_term pat] returns a glob_constr corresponding to [pat].
    [pat] must not contain occurences of anonymous pattern
@@ -14,14 +12,14 @@ val pattern_to_term : cases_pattern -> glob_constr
 
 (*
    Some basic functions to rebuild glob_constr
-   In each of them the location is Util.dummy_loc
+   In each of them the location is Util.Loc.ghost
 *)
-val mkGRef : Libnames.global_reference -> glob_constr
-val mkGVar : Names.identifier -> glob_constr
+val mkGRef : Globnames.global_reference -> glob_constr
+val mkGVar : Id.t -> glob_constr
 val mkGApp  : glob_constr*(glob_constr list) -> glob_constr
-val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr
-val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr
-val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr
+val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr
+val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr
 val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr
 val mkGSort : glob_sort -> glob_constr
 val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *)
@@ -30,15 +28,15 @@ val mkGCast : glob_constr* glob_constr -> glob_constr
   Some basic functions to decompose glob_constrs
   These are analogous to the ones constrs
 *)
-val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod : glob_constr -> (Name.t*glob_constr) list * glob_constr
 val glob_decompose_prod_or_letin :
-  glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr
-val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr
+  glob_constr -> (Name.t*glob_constr option*glob_constr option) list * glob_constr
+val glob_decompose_prod_n : int -> glob_constr -> (Name.t*glob_constr) list * glob_constr
 val glob_decompose_prod_or_letin_n : int -> glob_constr ->
-  (Names.name*glob_constr option*glob_constr option) list * glob_constr
-val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list  ->  glob_constr
+  (Name.t*glob_constr option*glob_constr option) list * glob_constr
+val glob_compose_prod : glob_constr -> (Name.t*glob_constr) list  ->  glob_constr
 val glob_compose_prod_or_letin: glob_constr ->
-  (Names.name*glob_constr option*glob_constr option) list  ->  glob_constr
+  (Name.t*glob_constr option*glob_constr option) list  ->  glob_constr
 val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
 
 
@@ -60,7 +58,7 @@ val  glob_make_or_list : glob_constr list -> glob_constr
 
 
 (* Replace the var mapped in the glob_constr/context *)
-val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
+val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr
 
 
 
@@ -72,27 +70,27 @@ val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
    [avoid] with the variables appearing in the result.
 *)
   val alpha_pat :
-    Names.Idmap.key list ->
+    Id.Map.key list ->
     Glob_term.cases_pattern ->
-    Glob_term.cases_pattern * Names.Idmap.key list *
-      Names.identifier Names.Idmap.t
+    Glob_term.cases_pattern * Id.Map.key list *
+      Id.t Id.Map.t
 
 (* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
    conventions and  does not share bound variables with avoid
 *)
-val alpha_rt : Names.identifier list -> glob_constr -> glob_constr
+val alpha_rt : Id.t list -> glob_constr -> glob_constr
 
 (* same as alpha_rt but for case branches *)
-val alpha_br : Names.identifier list ->
-    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+val alpha_br : Id.t list ->
+    Loc.t * Id.t list * Glob_term.cases_pattern list *
     Glob_term.glob_constr ->
-    Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+    Loc.t * Id.t list * Glob_term.cases_pattern list *
     Glob_term.glob_constr
 
 
 (* Reduction function *)
 val replace_var_by_term  :
-  Names.identifier ->
+  Id.t ->
   Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr
 
 
@@ -100,7 +98,7 @@ val replace_var_by_term  :
 (*
    [is_free_in id rt] checks if [id] is a free variable in [rt]
 *)
-val is_free_in : Names.identifier -> glob_constr -> bool
+val is_free_in : Id.t -> glob_constr -> bool
 
 
 val are_unifiable : cases_pattern -> cases_pattern -> bool
@@ -109,13 +107,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
 
 
 (*
-   ids_of_pat : cases_pattern -> Idset.t
+   ids_of_pat : cases_pattern -> Id.Set.t
    returns the set of variables appearing in a pattern
 *)
-val   ids_of_pat : cases_pattern -> Names.Idset.t
+val   ids_of_pat : cases_pattern -> Id.Set.t
 
 (* TODO: finish this function (Fix not treated) *)
-val ids_of_glob_constr: glob_constr -> Names.Idset.t
+val ids_of_glob_constr: glob_constr -> Id.Set.t
 
 (*
    removing let_in construction in a glob_constr
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index d2c065a0..6dbd61cf 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -1,11 +1,16 @@
+open Errors
 open Util
 open Names
 open Term
 open Pp
 open Indfun_common
 open Libnames
+open Globnames
 open Glob_term
 open Declarations
+open Declareops
+open Misctypes
+open Decl_kinds
 
 let is_rec_info scheme_info =
   let test_branche min acc (_,_,br) =
@@ -14,15 +19,13 @@ let is_rec_info scheme_info =
 	it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
       let free_rels_in_br = Termops.free_rels new_branche in
       let max = min + scheme_info.Tactics.npredicates in
-      Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
+      Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br
     )
   in
-  Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
+  List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches)
 
 let choose_dest_or_ind scheme_info =
-    if is_rec_info scheme_info
-    then Tactics.new_induct false
-    else Tactics.new_destruct false
+  Tactics.induction_destruct (is_rec_info scheme_info) false
 
 let functional_induction with_clean c princl pat =
   Dumpglob.pause ();
@@ -33,7 +36,7 @@ let functional_induction with_clean c princl pat =
 	| None -> (* No principle is given let's find the good one *)
 	    begin
 	      match kind_of_term f with
-		| Const c' ->
+		| Const (c',u) ->
 		    let princ_option =
 		      let finfo = (* we first try to find out a graph on f *)
 			try find_Function_infos c'
@@ -54,7 +57,7 @@ let functional_induction with_clean c princl pat =
 			  (or f_rec, f_rect) i*)
 			let princ_name =
 			  Indrec.make_elimination_ident
-			    (id_of_label (con_label c'))
+			    (Label.to_id (con_label c'))
 			    (Tacticals.elimination_sort_of_goal g)
 			in
 			try
@@ -63,7 +66,7 @@ let functional_induction with_clean c princl pat =
 			  errorlabstrm "" (str "Cannot find induction principle for "
 					   ++Printer.pr_lconstr (mkConst c') )
 		    in
-		    (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ)
+		    (princ,NoBindings, Tacmach.pf_type_of g princ)
 		| _ -> raise (UserError("",str "functional induction must be used with a function" ))
 	    end
 	| Some ((princ,binding)) ->
@@ -75,50 +78,43 @@ let functional_induction with_clean c princl pat =
 	if princ_infos.Tactics.farg_in_concl
 	then [c] else []
       in
-      List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list)
+      let encoded_pat_as_patlist =
+        List.make (List.length args + List.length c_list - 1) None @ [pat] in
+      List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None))
+        (args@c_list) encoded_pat_as_patlist
     in
     let princ' = Some (princ,bindings) in
     let princ_vars =
       List.fold_right
-	(fun a acc ->
-	  try Idset.add (destVar a) acc
-	  with e when Errors.noncritical e -> acc
-	)
+	(fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc)
 	args
-	Idset.empty
+	Id.Set.empty
     in
-    let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
-    let old_idl = Idset.diff old_idl princ_vars in
+    let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in
+    let old_idl = Id.Set.diff old_idl princ_vars in
     let subst_and_reduce g =
       if with_clean
       then
 	let idl =
-	  map_succeed
-	    (fun id ->
-	       if Idset.mem id old_idl then failwith "subst_and_reduce";
-	       id
-	    )
+	  List.filter (fun id -> not (Id.Set.mem id old_idl))
 	    (Tacmach.pf_ids_of_hyps g)
 	in
 	let flag =
-	  Glob_term.Cbv
-	    {Glob_term.all_flags
-	     with Glob_term.rDelta = false;
+	  Genredexpr.Cbv
+	    {Redops.all_flags
+	     with Genredexpr.rDelta = false;
 	    }
 	in
 	Tacticals.tclTHEN
-	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl )
-	  (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
+	  (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl )
+	  (Tactics.reduce flag Locusops.allHypsAndConcl)
 	  g
       else Tacticals.tclIDTAC g
     in
     Tacticals.tclTHEN
-      (choose_dest_or_ind
+      (Proofview.V82.of_tactic (choose_dest_or_ind
 	 princ_infos
-	 args_as_induction_constr
-	 princ'
-	 (None,pat)
-         None)
+	 (args_as_induction_constr,princ')))
       subst_and_reduce
       g
   in
@@ -127,14 +123,14 @@ let functional_induction with_clean c princl pat =
 
 let rec abstract_glob_constr c = function
   | [] -> c
-  | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl)
-  | Topconstr.LocalRawAssum (idl,k,t)::bl ->
-      List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl
+  | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl)
+  | Constrexpr.LocalRawAssum (idl,k,t)::bl ->
+      List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl
         (abstract_glob_constr c bl)
 
-let interp_casted_constr_with_implicits sigma env impls c  =
-  Constrintern.intern_gen false sigma env ~impls
-    ~allow_patvar:false  ~ltacvars:([],[]) c
+let interp_casted_constr_with_implicits env sigma impls c  =
+  Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls
+    ~allow_patvar:false c
 
 (*
    Construct a fixpoint as a Glob_term
@@ -149,26 +145,21 @@ let build_newrecursive
   let (rec_sign,rec_impls) =
     List.fold_left
       (fun (env,impls) ((_,recname),bl,arityc,_) ->
-        let arityc = Topconstr.prod_constr_expr arityc bl in
-        let arity = Constrintern.interp_type sigma env0 arityc in
-	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
-        (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls))
+        let arityc = Constrexpr_ops.prod_constr_expr arityc bl in
+        let arity,ctx = Constrintern.interp_type env0 sigma arityc in
+	let evdref =  ref (Evd.from_env env0) in
+	let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in
+	let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in
+        (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls))
       (env0,Constrintern.empty_internalization_env) lnameargsardef in
   let recdef =
     (* Declare local notations *)
-    let fs = States.freeze() in
-    let def =
-      try
-	List.map
-	  (fun (_,bl,_,def)  ->
-             let def = abstract_glob_constr def bl in
-             interp_casted_constr_with_implicits
-	       sigma rec_sign rec_impls def
-	  )
-          lnameargsardef
-	with reraise ->
-	States.unfreeze fs; raise reraise in
-    States.unfreeze fs; def
+    let f (_,bl,_,def) =
+      let def = abstract_glob_constr def bl in
+      interp_casted_constr_with_implicits
+        rec_sign sigma rec_impls def
+    in
+    States.with_state_protection (List.map f) lnameargsardef
   in
   recdef,rec_impls
 
@@ -178,15 +169,15 @@ let build_newrecursive l =
        match body_opt with 
 	 | Some body -> 
 	     (fixna,bll,ar,body)
-	 | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given")
+	 | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given")
     ) l
   in
   build_newrecursive l'
 
 (* Checks whether or not the mutual bloc is recursive *)
-let rec is_rec names =
-  let names = List.fold_right Idset.add names Idset.empty in
-  let check_id id names =  Idset.mem id names in
+let is_rec names =
+  let names = List.fold_right Id.Set.add names Id.Set.empty in
+  let check_id id names =  Id.Set.mem id names in
   let rec lookup names = function
     | GVar(_,id) -> check_id id names
     | GRef _ | GEvar _ | GPatVar _ | GSort _ |  GHole _ -> false
@@ -195,11 +186,11 @@ let rec is_rec names =
     | GIf(_,b,_,lhs,rhs) ->
 	(lookup names b) || (lookup names lhs) || (lookup names rhs)
     | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b)  ->
-	lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
+	lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b
     | GLetTuple(_,nal,_,t,b) -> lookup names t ||
 	lookup
 	  (List.fold_left
-	     (fun acc na -> Nameops.name_fold Idset.remove na acc)
+	     (fun acc na -> Nameops.name_fold Id.Set.remove na acc)
 	     names
 	     nal
 	  )
@@ -209,7 +200,7 @@ let rec is_rec names =
 	List.exists (fun (e,_) -> lookup names e) el ||
 	  List.exists (lookup_br names) brl
   and lookup_br names (_,idl,_,rt) =
-    let new_names = List.fold_right Idset.remove idl names in
+    let new_names = List.fold_right Id.Set.remove idl names in
     lookup new_names rt
   in
   lookup names
@@ -217,8 +208,8 @@ let rec is_rec names =
 let rec local_binders_length = function
   (* Assume that no `{ ... } contexts occur *)
   | [] -> 0
-  | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl
-  | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+  | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl
+  | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
 
 let prepare_body ((name,_,args,types,_),_) rt =
   let n = local_binders_length args in
@@ -226,12 +217,14 @@ let prepare_body ((name,_,args,types,_),_) rt =
   let fun_args,rt' = chop_rlambda_n n rt in
   (fun_args,rt')
 
+let process_vernac_interp_error e =
+  fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))
 
 let derive_inversion fix_names =
   try
     (* we first transform the fix_names identifier into their corresponding constant *)
     let fix_names_as_constant =
-      List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names
+      List.map (fun id -> fst (destConst (Constrintern.global_reference id))) fix_names
     in
     (*
        Then we check that the graphs have been defined
@@ -248,38 +241,45 @@ let derive_inversion fix_names =
 	  Ensures by : register_built
 	  i*)
 	(List.map
-	   (fun id -> destInd (Constrintern.global_reference (mk_rel_id id)))
+	   (fun id -> fst (destInd (Constrintern.global_reference (mk_rel_id id))))
 	   fix_names
 	)
     with e when Errors.noncritical e ->
-      let e' = Cerrors.process_vernac_interp_error e in
+      let e' = process_vernac_interp_error e in
       msg_warning
 	(str "Cannot build inversion information" ++
 	   if do_observe () then (fnl() ++ Errors.print e') else mt ())
   with e when Errors.noncritical e -> ()
 
 let warning_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let e = process_vernac_interp_error e in
   let e_explain e =
     match e with
-      | ToShow e -> spc () ++ Errors.print e
-      | _ -> if do_observe () then (spc () ++ Errors.print e) else mt ()
+      | ToShow e -> 
+	let e = process_vernac_interp_error e in
+	spc () ++ Errors.print e
+      | _ -> 
+	if do_observe () 
+	then 
+	  let e = process_vernac_interp_error e in 
+	  (spc () ++ Errors.print e) 
+	else mt ()
   in
   match e with
     | Building_graph e ->
-	Pp.msg_warning
-	  (str "Cannot define graph(s) for " ++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     e_explain e)
+      Pp.msg_warning
+	(str "Cannot define graph(s) for " ++
+	   h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	   e_explain e)
     | Defining_principle e ->
-	Pp.msg_warning
-	  (str "Cannot define principle(s) for "++
-	     h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
-	     e_explain e)
+      Pp.msg_warning
+	(str "Cannot define principle(s) for "++
+	   h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+	   e_explain e)
     | _ -> raise e
 
 let error_error names e =
-  let e = Cerrors.process_vernac_interp_error e in
+  let e = process_vernac_interp_error e in
   let e_explain e =
     match e with
       | ToShow e -> spc () ++ Errors.print e
@@ -293,7 +293,7 @@ let error_error names e =
 	     e_explain e)
     | _ -> raise e
 
-let generate_principle  on_error
+let generate_principle  mp_dp on_error
     is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs  interactive_proof
     (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
       Tacmach.tactic) : unit =
@@ -303,14 +303,14 @@ let generate_principle  on_error
   let funs_types =  List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in
   try
     (* We then register the Inductive graphs of the functions  *)
-    Glob_term_to_relation.build_inductive names funs_args funs_types recdefs;
+    Glob_term_to_relation.build_inductive mp_dp names funs_args funs_types recdefs;
     if do_built
     then
       begin
 	(*i The next call to mk_rel_id is valid since we have just construct the graph
 	   Ensures by : do_built
 	i*)
-	let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
+	let f_R_mut = Ident (Loc.ghost,mk_rel_id (List.nth names 0)) in
 	let ind_kn =
 	  fst (locate_with_msg
 		 (pr_reference f_R_mut++str ": Not an inductive type!")
@@ -326,11 +326,10 @@ let generate_principle  on_error
 	in
 	let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
 	let _ =
-	  list_map_i
+	  List.map_i
 	    (fun i x ->
-	       let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
-	       let princ_type = Typeops.type_of_constant (Global.env()) princ
-	       in
+	       let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in
+	       let princ_type = Global.type_of_global_unsafe princ in
 	       Functional_principles_types.generate_functional_principle
 		 interactive_proof
 		 princ_type
@@ -352,15 +351,11 @@ let generate_principle  on_error
 let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
   match fixpoint_exprl with
     | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
-      let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
-	let ce,imps =
-	  Command.interp_definition bl None body (Some ret_type)
-	in
-	Command.declare_definition
-	  fname (Decl_kinds.Global,Decl_kinds.Definition)
-	  ce imps (fun _ _ -> ())
+      let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
+	Command.do_definition fname (Decl_kinds.Global,(*FIXME*)false,Decl_kinds.Definition)
+	  bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ()))
     | _ ->
-	Command.do_fixpoint fixpoint_exprl
+	Command.do_fixpoint Global false(*FIXME*) fixpoint_exprl
 
 let generate_correction_proof_wf f_ref tcc_lemma_ref
     is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
@@ -373,39 +368,39 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref
 let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
     pre_hook
     =
-  let type_of_f = Topconstr.prod_constr_expr ret_type args in
+  let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in
   let rec_arg_num =
     let names =
       List.map
 	snd
-	(Topconstr.names_of_local_assums args)
+	(Constrexpr_ops.names_of_local_assums args)
     in
     match wf_arg with
       | None ->
-	if List.length names = 1 then 1
+	if Int.equal (List.length names) 1 then 1
 	else error "Recursive argument must be specified"
       | Some wf_arg ->
-	  list_index (Name wf_arg) names
+	  List.index Name.equal (Name wf_arg) names
   in
   let unbounded_eq =
     let f_app_args =
-      Topconstr.CAppExpl
-	(dummy_loc,
-	 (None,(Ident (dummy_loc,fname))) ,
+      Constrexpr.CAppExpl
+	(Loc.ghost,
+	 (None,(Ident (Loc.ghost,fname)),None) ,
 	 (List.map
 	    (function
 	       | _,Anonymous -> assert false
-	       | _,Name e -> (Topconstr.mkIdentC e)
+	       | _,Name e -> (Constrexpr_ops.mkIdentC e)
 	    )
-	    (Topconstr.names_of_local_assums args)
+	    (Constrexpr_ops.names_of_local_assums args)
 	 )
 	)
     in
-    Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
+    Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))),
 		    [(f_app_args,None);(body,None)])
   in
-  let eq = Topconstr.prod_constr_expr unbounded_eq args in
-  let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
+  let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in
+  let hook (f_ref,_) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type
       nb_args relation =
     try
       pre_hook
@@ -433,7 +428,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
       | None ->
 	  begin
 	    match args with
-	      | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+	      | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
 	      | _ -> error "Recursive argument must be specified"
 	  end
       | Some wf_args ->
@@ -441,15 +436,15 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 	    match
 	      List.find
 		(function
-		   | Topconstr.LocalRawAssum(l,k,t) ->
+		   | Constrexpr.LocalRawAssum(l,k,t) ->
 		       List.exists
-			 (function (_,Name id) -> id =  wf_args | _ -> false)
+			 (function (_,Name id) -> Id.equal id wf_args | _ -> false)
 			 l
 		   | _ -> false
 		)
 		args
 	    with
-	      | Topconstr.LocalRawAssum(_,k,t)  ->	    t,wf_args
+	      | Constrexpr.LocalRawAssum(_,k,t)  ->	    t,wf_args
 	      | _ -> assert false
 	  with Not_found -> assert false
   in
@@ -457,31 +452,31 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
     match wf_rel_expr_opt with 
       | None ->
 	  let ltof =
-	    let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in
-	    Libnames.Qualid (dummy_loc,Libnames.qualid_of_path
-			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof")))
+	    let make_dir l = DirPath.make (List.rev_map Id.of_string l) in
+	    Libnames.Qualid (Loc.ghost,Libnames.qualid_of_path
+			       (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")))
 	  in
 	  let fun_from_mes =
 	    let applied_mes =
-	      Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg])    in
-	    Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes)
+	      Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg])    in
+	    Constrexpr_ops.mkLambdaC ([(Loc.ghost,Name wf_arg)],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes)
 	  in
 	  let wf_rel_from_mes =
-	    Topconstr.mkAppC(Topconstr.mkRefC  ltof,[wf_arg_type;fun_from_mes])
+	    Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC  ltof,[wf_arg_type;fun_from_mes])
 	  in
 	  wf_rel_from_mes,true
       | Some wf_rel_expr -> 
 	  let wf_rel_with_mes = 
-	    let a = Names.id_of_string "___a" in 
-	    let b = Names.id_of_string "___b" in 
-	    Topconstr.mkLambdaC(
-	      [dummy_loc,Name a;dummy_loc,Name b],
-	      Topconstr.Default Lib.Explicit,
+	    let a = Names.Id.of_string "___a" in 
+	    let b = Names.Id.of_string "___b" in 
+	    Constrexpr_ops.mkLambdaC(
+	      [Loc.ghost,Name a;Loc.ghost,Name b],
+	      Constrexpr.Default Explicit,
 	      wf_arg_type,
-	      Topconstr.mkAppC(wf_rel_expr,
+	      Constrexpr_ops.mkAppC(wf_rel_expr,
 			       [
-				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]);
-				Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b])
+				Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]);
+				Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b])
 			       ])
 			      )
 	  in
@@ -493,124 +488,62 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas
 let map_option f = function 
   | None -> None 
   | Some v -> Some (f v)
-    
-let decompose_lambda_n_assum_constr_expr = 
-  let rec decompose_lambda_n_assum_constr_expr acc n e = 
-  if n = 0 then (List.rev acc,e)
-  else
-    match e with 
-      | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e'
-      | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
-	let nal_length = List.length nal in 
-	if nal_length <= n 
-	then
-	  decompose_lambda_n_assum_constr_expr 
-	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
-	    (n - nal_length) 
-	    (Topconstr.CLambdaN(lambda_loc,bl,e')) 
-  	else
-	  let nal_keep,nal_expr = list_chop n nal in 
-	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
-	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
-	  )
-      | Topconstr.CLetIn(_, na,nav,e') -> 
-	decompose_lambda_n_assum_constr_expr 
-	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
-      | _ -> error "Not enough product or assumption"
-  in
-  decompose_lambda_n_assum_constr_expr []
-
-let decompose_prod_n_assum_constr_expr = 
-  let rec decompose_prod_n_assum_constr_expr acc n e = 
-    (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *)
-    (* 		str "e := " ++ Ppconstr.pr_lconstr_expr e); *)
-  if n = 0 then 
-    (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in  *)
-      (List.rev acc,e)
-  else
-    match e with 
-      | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e'
-      | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') ->
-	let nal_length = List.length nal in 
-	if nal_length <= n 
-	then
-	  (* let _ = Pp.msgnl (str "first case") in  *)
-	  decompose_prod_n_assum_constr_expr 
-	    (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) 
-	    (n - nal_length) 
-	    (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e')))
-  	else
-	  (* let _ = Pp.msgnl (str "second case") in  *)
-	  let nal_keep,nal_expr = list_chop n nal in 
-	  (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc),
-	   Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e')
-	  )
-      | Topconstr.CArrow(_,premisse,concl) -> 
-	(* let _ = Pp.msgnl (str "arrow case") in  *)
-	decompose_prod_n_assum_constr_expr 
-	  (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous],
-				   Topconstr.Default Lib.Explicit,premisse)
-	  ::acc)
-	  (pred n)
-	  concl
-      | Topconstr.CLetIn(_, na,nav,e') -> 
-	decompose_prod_n_assum_constr_expr 
-	  (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e'
-      | _ -> error "Not enough product or assumption"
-  in
-  decompose_prod_n_assum_constr_expr []
 
+open Constrexpr
 open Topconstr
-    
-let id_of_name = function 
-  | Name id -> id 
-  | _ -> assert false
 
- let rec rebuild_bl (aux,assoc) bl typ = 
+let make_assoc assoc l1 l2 =
+  let fold assoc a b = match a, b with
+  | (_, Name na), (_, Name id) -> Id.Map.add na id assoc
+  | _, _ -> assoc
+  in
+  List.fold_left2 fold assoc l1 l2
+
+let rec rebuild_bl (aux,assoc) bl typ = 
 	match bl,typ with 
 	  | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc)
-	  | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> 
+	  | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ ->
 	     rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ
-	  | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') ->
-	    rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
+	  | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') ->
+	    rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc)
 	      bl' typ'
 	  | _ -> assert false
       and rebuild_nal (aux,assoc) bk bl' nal lnal typ = 
 	match nal,typ with 
 	  | [], _ -> rebuild_bl (aux,assoc) bl' typ
-	  | na::nal,CArrow(_,nat,typ') -> 
-	    rebuild_nal 
-	      ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) 
-	      bk bl' nal (pred lnal) typ'
 	  | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ
 	  | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> 
 	    let lnal' = List.length nal' in 
 	    if lnal' >= lnal 
 	    then 
-	      let old_nal',new_nal' = list_chop lnal nal' in 
-	      rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal'))  (List.map id_of_name (List.map snd nal))) assoc)) bl' 
-		(if new_nal' = [] && rest = []
-		 then  typ' 
-		 else if new_nal' = [] 
-		 then CProdN(dummy_loc,rest,typ')
-		 else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ'))
+	      let old_nal',new_nal' = List.chop lnal nal' in
+	      let nassoc = make_assoc assoc old_nal' nal in
+	      let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in
+	      rebuild_bl ((assum :: aux), nassoc) bl' 
+		(if List.is_empty new_nal' && List.is_empty rest
+		 then typ'
+		 else if List.is_empty new_nal'
+		 then CProdN(Loc.ghost,rest,typ')
+		 else CProdN(Loc.ghost,((new_nal',bk',nal't)::rest),typ'))
 	    else 
-	      let captured_nal,non_captured_nal = list_chop lnal' nal in 
-	      rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc))
-		bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ'))
+	      let captured_nal,non_captured_nal = List.chop lnal' nal in
+	      let nassoc = make_assoc assoc nal' captured_nal in
+	      let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in
+	      rebuild_nal ((assum :: aux), nassoc)
+		bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ'))
 	  | _ -> assert false
 
 let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ
 
 let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = 
   let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in
-  let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in
+  let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in
   let constr_expr_typel = 
-    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in 
+    with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) typel in
   let fixpoint_exprl_with_new_bl = 
     List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> 
      
-      let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in 
+      let new_bl',new_ret_type,_ = rebuild_bl ([],Id.Map.empty) bl fix_typ in 
       (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
     )
       fixpoint_exprl constr_expr_typel 
@@ -618,23 +551,24 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex
   fixpoint_exprl_with_new_bl
   
 
-let do_generate_principle on_error register_built interactive_proof
+let do_generate_principle mp_dp on_error register_built interactive_proof
     (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit =
-  List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl;
+  List.iter (fun (_,l) -> if not (List.is_empty l) then error "Function does not support notations for now") fixpoint_exprl;
   let _is_struct =
     match fixpoint_exprl with
-      | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
+      | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] ->
  	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
 	      | _ -> assert false
 	  in 
 	  let fixpoint_exprl = [fixpoint_expr] in 
-	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in 
 	  let pre_hook =
 	    generate_principle
+	      mp_dp
 	      on_error
 	      true
 	      register_built
@@ -645,7 +579,7 @@ let do_generate_principle on_error register_built interactive_proof
 	  if register_built
 	  then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook;
 	  false
-      |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
+      |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] ->
  	  let ((((_,name),_,args,types,body)),_)  as fixpoint_expr =
 	    match recompute_binder_list [fixpoint_expr] with 
 	      | [e] -> e
@@ -654,9 +588,10 @@ let do_generate_principle on_error register_built interactive_proof
 	  let fixpoint_exprl = [fixpoint_expr] in 
 	  let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
 	  let using_lemmas = [] in
-	  let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in 
+	  let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in 
 	  let pre_hook =
 	    generate_principle
+	      mp_dp
 	      on_error
 	      true
 	      register_built
@@ -670,7 +605,7 @@ let do_generate_principle on_error register_built interactive_proof
       | _ ->
 	  List.iter (function ((_na,(_,ord),_args,_body,_type),_not) ->
 		       match ord with 
-			 | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> 
+			 | Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _ ->
 			     error
 			       ("Cannot use mutual definition with well-founded recursion or measure")
 			 | _ -> ()
@@ -685,6 +620,7 @@ let do_generate_principle on_error register_built interactive_proof
 	let is_rec = List.exists (is_rec fix_names) recdefs in
 	if register_built then register_struct is_rec fixpoint_exprl;
 	generate_principle
+	  mp_dp
 	  on_error
 	  false
 	  register_built
@@ -697,18 +633,15 @@ let do_generate_principle on_error register_built interactive_proof
   in
   ()
 
-open Topconstr
 let rec add_args id new_args b =
   match b with
-  | CRef r ->
+  | CRef (r,_) ->
       begin      match r with
-	| Libnames.Ident(loc,fname) when fname = id ->
-	    CAppExpl(dummy_loc,(None,r),new_args)
+	| Libnames.Ident(loc,fname) when Id.equal fname id ->
+	    CAppExpl(Loc.ghost,(None,r,None),new_args)
 	| _ -> b
       end
-  | CFix  _  | CCoFix _ -> anomaly "add_args : todo"
-  | CArrow(loc,b1,b2) ->
-      CArrow(loc,add_args id new_args  b1, add_args id new_args b2)
+  | CFix  _  | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo")
   | CProdN(loc,nal,b1) ->
       CProdN(loc,
 	     List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
@@ -719,12 +652,12 @@ let rec add_args id new_args b =
 	       add_args id new_args  b1)
   | CLetIn(loc,na,b1,b2) ->
       CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
-  | CAppExpl(loc,(pf,r),exprl) ->
+  | CAppExpl(loc,(pf,r,us),exprl) ->
       begin
 	match r with
-	| Libnames.Ident(loc,fname) when fname = id ->
-	    CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
-	| _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
+	| Libnames.Ident(loc,fname) when Id.equal fname id ->
+	    CAppExpl(loc,(pf,r,us),new_args@(List.map (add_args id new_args) exprl))
+	| _ -> CAppExpl(loc,(pf,r,us),List.map (add_args id new_args) exprl)
       end
   | CApp(loc,(pf,b),bl) ->
       CApp(loc,(pf,add_args id new_args b),
@@ -733,7 +666,7 @@ let rec add_args id new_args b =
       CCases(loc,sty,Option.map (add_args id new_args) b_option,
 	     List.map (fun (b,(na,b_option)) ->
 			 add_args id new_args b,
-			 (na,Option.map (add_args id new_args) b_option)) cel,
+			 (na, b_option)) cel,
 	     List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
 	    )
   | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
@@ -752,32 +685,29 @@ let rec add_args id new_args b =
   | CPatVar _ -> b
   | CEvar _ -> b
   | CSort _ -> b
-  | CCast(loc,b1,CastConv(ck,b2))  ->
-      CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
-  | CCast(loc,b1,CastCoerce) ->
-      CCast(loc,add_args id new_args b1,CastCoerce)
+  | CCast(loc,b1,b2)  ->
+      CCast(loc,add_args id new_args b1,
+	    Miscops.map_cast_type (add_args id new_args) b2)
   | CRecord (loc, w, pars) ->
       CRecord (loc,
 	       (match w with Some w -> Some (add_args id new_args w) | _ -> None),
 	       List.map (fun (e,o) -> e, add_args id new_args o) pars)
-  | CNotation _ -> anomaly "add_args : CNotation"
-  | CGeneralization _ -> anomaly "add_args : CGeneralization"
+  | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation")
+  | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization")
   | CPrim _ -> b
-  | CDelimiters _ -> anomaly "add_args : CDelimiters"
-exception Stop of  Topconstr.constr_expr
+  | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters")
+exception Stop of  Constrexpr.constr_expr
 
 
 (* [chop_n_arrow n t] chops the [n] first arrows in [t]
-   Acts on Topconstr.constr_expr
+   Acts on Constrexpr.constr_expr
 *)
 let rec chop_n_arrow n t =
   if n <= 0
   then t (* If we have already removed all the arrows then return the type *)
   else (* If not we check the form of [t] *)
     match t with
-      | Topconstr.CArrow(_,_,t) ->  (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
-	  chop_n_arrow (n-1) t
-      | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
+      | Constrexpr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
 					     either we need to discard more than the number of arrows contained
 					     in this product declaration then we just recall [chop_n_arrow] on
 					     the remaining number of arrow to chop and [t'] we discard it and
@@ -796,8 +726,8 @@ let rec chop_n_arrow n t =
 		      aux (n - nal_l) nal_ta'
 		    else
 		      let new_t' =
-			Topconstr.CProdN(dummy_loc,
-					((snd (list_chop n nal)),k,t'')::nal_ta',t')
+			Constrexpr.CProdN(Loc.ghost,
+					((snd (List.chop n nal)),k,t'')::nal_ta',t')
 		      in
 		      raise (Stop new_t')
 		in
@@ -806,13 +736,13 @@ let rec chop_n_arrow n t =
 	      chop_n_arrow new_n t'
 	    with Stop t -> t
 	  end
-      | _ -> anomaly "Not enough products"
+      | _ -> anomaly (Pp.str "Not enough products")
 
 
-let rec get_args b t : Topconstr.local_binder list *
-    Topconstr.constr_expr * Topconstr.constr_expr =
+let rec get_args b t : Constrexpr.local_binder list *
+    Constrexpr.constr_expr * Constrexpr.constr_expr =
   match b with
-    | Topconstr.CLambdaN (loc, (nal_ta), b') ->
+    | Constrexpr.CLambdaN (loc, (nal_ta), b') ->
 	begin
 	  let n =
 	    (List.fold_left (fun n (nal,_,_) ->
@@ -820,7 +750,7 @@ let rec get_args b t : Topconstr.local_binder list *
 	  in
 	  let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
 	  (List.map (fun (nal,k,ta) ->
-		       (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
+		       (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
 	end
     | _ -> [],b,t
 
@@ -836,17 +766,15 @@ let make_graph (f_ref:global_reference) =
       | _ -> raise (UserError ("", str "Not a function reference") )
   in
   Dumpglob.pause ();
-  (match body_of_constant c_body with
+  (match Global.body_of_constant_body c_body with
      | None -> error "Cannot build a graph over an axiom !"
-     | Some b ->
+     | Some body ->
 	 let env = Global.env () in
-	 let body = (force b) in
 	 let extern_body,extern_type =
-	   with_full_print
-	     (fun () ->
-		(Constrextern.extern_constr false env body,
-		 Constrextern.extern_type false env
-                   (Typeops.type_of_constant_type env c_body.const_type)
+	   with_full_print (fun () ->
+		(Constrextern.extern_constr false env Evd.empty body,
+		 Constrextern.extern_type false env Evd.empty
+                   ((*FIXNE*) Typeops.type_of_constant_type env c_body.const_type)
 		)
 	     )
 	     ()
@@ -854,7 +782,7 @@ let make_graph (f_ref:global_reference) =
 	 let (nal_tas,b,t)  = get_args extern_body extern_type in
 	 let expr_list =
 	   match b with
-	     | Topconstr.CFix(loc,l_id,fixexprl) ->
+	     | Constrexpr.CFix(loc,l_id,fixexprl) ->
 		 let l =
 		   List.map
 		     (fun (id,(n,recexp),bl,t,b) ->
@@ -863,34 +791,34 @@ let make_graph (f_ref:global_reference) =
 			  List.flatten
 			    (List.map
 			       (function
- 				  | Topconstr.LocalRawDef (na,_)-> []
-			      	  | Topconstr.LocalRawAssum (nal,_,_) ->
+				  | Constrexpr.LocalRawDef (na,_)-> []
+				  | Constrexpr.LocalRawAssum (nal,_,_) ->
 				      List.map
 					(fun (loc,n) ->
-					   CRef(Libnames.Ident(loc, Nameops.out_name n)))
+					   CRef(Libnames.Ident(loc, Nameops.out_name n),None))
 					nal
 			       )
 			       nal_tas
 			    )
 			in
 			let b' = add_args (snd id) new_args b in
-			(((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
+			(((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list))
 		     )
 		     fixexprl
 		 in
 		 l
 	     | _ ->
-		 let id = id_of_label (con_label c) in
-		 [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]]
+		let id = Label.to_id (con_label c) in
+		 [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]]
 	 in
-	 do_generate_principle error_error false false expr_list;
-	 (* We register the infos *)
 	 let mp,dp,_ = repr_con c in
+	 do_generate_principle (Some (mp,dp)) error_error  false false expr_list;
+	 (* We register the infos *)
 	 List.iter
-	   (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (label_of_id id)))
+	   (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id)))
 	   expr_list);
   Dumpglob.continue ()
 
-let do_generate_principle = do_generate_principle warning_error true
+let do_generate_principle = do_generate_principle None warning_error true
 
 
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
index e65b5808..e7206914 100644
--- a/plugins/funind/indfun.mli
+++ b/plugins/funind/indfun.mli
@@ -1,11 +1,4 @@
-open Util
-open Names
-open Term
-open Pp
-open Indfun_common
-open Libnames
-open Glob_term
-open Declarations
+open Misctypes
 
 val do_generate_principle :  
   bool -> 
@@ -16,9 +9,9 @@ val do_generate_principle :
 val functional_induction :  
   bool ->
   Term.constr ->
-  (Term.constr * Term.constr Glob_term.bindings) option ->
-  Genarg.intro_pattern_expr Util.located option ->
+  (Term.constr * Term.constr bindings) option ->
+  Tacexpr.or_and_intro_pattern option ->
   Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma
 
 
-val make_graph :  Libnames.global_reference -> unit
+val make_graph :  Globnames.global_reference -> unit
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index 827191b1..76f8c6d2 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -1,9 +1,9 @@
 open Names
 open Pp
-
 open Libnames
-
-let mk_prefix pre id = id_of_string (pre^(string_of_id id))
+open Globnames
+open Refiner
+let mk_prefix pre id = Id.of_string (pre^(Id.to_string id))
 let mk_rel_id = mk_prefix "R_"
 let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
 let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
@@ -12,10 +12,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation"
 let msgnl m =
   ()
 
-let invalid_argument s = raise (Invalid_argument s)
-
-
-let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid
+let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid
 
 let fresh_name avoid s = Name (fresh_id avoid s)
 
@@ -29,7 +26,7 @@ let array_get_start a =
       (Array.length a - 1)
       (fun i -> a.(i))
   with Invalid_argument "index out of bounds" ->
-    invalid_argument "array_get_start"
+    invalid_arg "array_get_start"
 
 let id_of_name = function
     Name id -> id
@@ -51,10 +48,8 @@ let locate_constant ref =
 
 
 let locate_with_msg msg f x =
-  try
-    f x
-  with
-    | Not_found -> raise (Util.UserError("", msg))
+  try f x
+  with Not_found -> raise (Errors.UserError("", msg))
 
 
 let filter_map filter f =
@@ -78,7 +73,7 @@ let chop_rlambda_n  =
 	  | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
 	  | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
 	  | _ ->
-	      raise (Util.UserError("chop_rlambda_n",
+	      raise (Errors.UserError("chop_rlambda_n",
 				    str "chop_rlambda_n: Not enough Lambdas"))
   in
   chop_lambda_n []
@@ -90,7 +85,7 @@ let chop_rprod_n  =
       else
 	match rt with
 	  | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
-	  | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+	  | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
   in
   chop_prod_n []
 
@@ -111,34 +106,27 @@ let list_add_set_eq eq_fun x l =
 
 let const_of_id id =
   let _,princ_ref =
-    qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
+    qualid_of_reference (Libnames.Ident (Loc.ghost,id))
   in
   try Nametab.locate_constant princ_ref
-  with Not_found -> Util.error ("cannot find "^ string_of_id id)
+  with Not_found -> Errors.error ("cannot find "^ Id.to_string id)
 
 let def_of_const t =
    match (Term.kind_of_term t) with
     Term.Const sp ->
-      (try (match Declarations.body_of_constant (Global.lookup_constant sp) with
-             | Some c -> Declarations.force c
+      (try (match Environ.constant_opt_value_in (Global.env()) sp with
+             | Some c -> c
 	     | _ -> assert false)
-       with e when Errors.noncritical e -> assert false)
+       with Not_found -> assert false)
     |_ -> assert false
 
 let coq_constant s =
   Coqlib.gen_constant_in_modules "RecursiveDefinition"
     Coqlib.init_modules s;;
 
-let constant sl s =
-  constr_of_global
-    (Nametab.locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
-
 let find_reference sl s =
-    (Nametab.locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+  let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
+  Nametab.locate (make_qualid dp (Id.of_string s))
 
 let eq = lazy(coq_constant "eq")
 let refl_equal = lazy(coq_constant "eq_refl")
@@ -147,47 +135,40 @@ let refl_equal = lazy(coq_constant "eq_refl")
 (* Copy of the standart save mechanism but without the much too  *)
 (* slow reduction function                                       *)
 (*****************************************************************)
-open Declarations
 open Entries
 open Decl_kinds
 open Declare
-let definition_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is defined")
 
+let definition_message = Declare.definition_message
 
-let save with_clean id const (locality,kind) hook =
-  let {const_entry_body = pft;
-       const_entry_secctx = _;
-       const_entry_type = tpo;
-       const_entry_opaque = opacity } = const in
+let get_locality = function
+| Discharge -> true
+| Local -> true
+| Global -> false
+
+let save with_clean id const (locality,_,kind) hook =
+  let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in
   let l,r = match locality with
-    | Local when Lib.sections_are_opened () ->
-        let k = logical_kind_of_goal_kind kind in
-	let c = SectionLocalDef (pft, tpo, opacity) in
+    | Discharge when Lib.sections_are_opened () ->
+        let k = Kindops.logical_kind_of_goal_kind kind in
+	let c = SectionLocalDef const in
 	let _ = declare_variable id (Lib.cwd(), c, k) in
 	(Local, VarRef id)
-    | Local ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn)
-    | Global ->
-        let k = logical_kind_of_goal_kind kind in
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	(Global, ConstRef kn) in
+    | Discharge | Local | Global ->
+        let local = get_locality locality in
+        let k = Kindops.logical_kind_of_goal_kind kind in
+        let kn = declare_constant id ~local (DefinitionEntry const, k) in
+	(locality, ConstRef kn)
+  in
   if with_clean then  Pfedit.delete_current_proof ();
-  hook l r;
+  Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
   definition_message id
 
 
 
 let cook_proof _ =
-  let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in
-  (id,(entry,strength,hook))
-
-let new_save_named opacity =
-  let id,(const,persistence,hook) = cook_proof true  in
-  let const = { const with const_entry_opaque = opacity } in
-  save true id const persistence hook
+  let (id,(entry,_,strength)) = Pfedit.cook_proof () in
+  (id,(entry,strength))
 
 let get_proof_clean do_reduce =
   let result = cook_proof do_reduce in
@@ -197,7 +178,8 @@ let get_proof_clean do_reduce =
 let with_full_print f a =
   let old_implicit_args = Impargs.is_implicit_args ()
   and old_strict_implicit_args =  Impargs.is_strict_implicit_args ()
-  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+  and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () 
+  in
   let old_rawprint = !Flags.raw_print in
   Flags.raw_print := true;
   Impargs.make_implicit_args false;
@@ -248,8 +230,9 @@ type function_info =
 (* let function_table = ref ([] : function_db) *)
 
 
-let from_function = ref Cmap.empty
-let from_graph = ref Indmap.empty
+let from_function = Summary.ref Cmap_env.empty ~name:"functions_db_fn"
+let from_graph = Summary.ref Indmap.empty ~name:"functions_db_gr"
+
 (*
 let rec do_cache_info finfo = function
   | [] -> raise Not_found
@@ -272,15 +255,14 @@ let cache_Function (_,(finfos)) =
 *)
 
 let cache_Function (_,finfos) =
-  from_function := Cmap.add finfos.function_constant finfos !from_function;
+  from_function := Cmap_env.add finfos.function_constant finfos !from_function;
   from_graph := Indmap.add finfos.graph_ind finfos !from_graph
 
 
 let load_Function _  = cache_Function
-let open_Function _ = cache_Function
 let subst_Function (subst,finfos) =
-  let do_subst_con c = fst (Mod_subst.subst_con subst c)
-  and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i)
+  let do_subst_con c = Mod_subst.subst_constant subst c
+  and do_subst_ind i = Mod_subst.subst_ind subst i
   in
   let function_constant' = do_subst_con finfos.function_constant in
   let graph_ind' = do_subst_ind finfos.graph_ind in
@@ -346,22 +328,29 @@ let discharge_Function (_,finfos) =
 	 }
 
 open Term
+
+let pr_ocst c =
+  Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) c (mt ())
+
 let pr_info f_info =
-  str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
-    str "function_constant_type := " ++
-    (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant))
-     with e when Errors.noncritical e -> mt ()) ++ fnl () ++
-    str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
-    str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
-    str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
-    str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
-    str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
-    str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
-    str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
+  str "function_constant := " ++
+  Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
+  str "function_constant_type := " ++
+  (try
+     Printer.pr_lconstr
+       (Global.type_of_global_unsafe (ConstRef f_info.function_constant))
+   with e when Errors.noncritical e -> mt ()) ++ fnl () ++
+  str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++
+  str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++
+  str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++
+  str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++
+  str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++
+  str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++
+  str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
 
 let pr_table tb =
-  let l = Cmap.fold (fun k v acc -> v::acc) tb [] in
-  Util.prlist_with_sep fnl pr_info l
+  let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in
+  Pp.prlist_with_sep fnl pr_info l
 
 let in_Function : function_info -> Libobject.obj =
   Libobject.declare_object
@@ -375,36 +364,16 @@ let in_Function : function_info -> Libobject.obj =
     }
 
 
-
-(* Synchronisation with reset *)
-let freeze () =
-  !from_function,!from_graph
-let unfreeze (functions,graphs) =
-(*   Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
-  from_function := functions;
-  from_graph := graphs
-
-let init () =
-(*   Pp.msgnl (str "reseting function_table");  *)
-  from_function := Cmap.empty;
-  from_graph := Indmap.empty
-
-let _ =
-  Summary.declare_summary "functions_db_sum"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-
 let find_or_none id =
   try Some
-    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
+    (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant")
     )
   with Not_found -> None
 
 
 
 let find_Function_infos f =
-  Cmap.find f !from_function
+  Cmap_env.find f !from_function
 
 
 let find_Function_of_graph ind =
@@ -416,7 +385,7 @@ let update_Function finfo =
 
 
 let add_Function is_general f =
-  let f_id = id_of_label (con_label f) in
+  let f_id = Label.to_id (con_label f) in
   let equation_lemma = find_or_none (mk_equation_id f_id)
   and correctness_lemma = find_or_none (mk_correct_id f_id)
   and completeness_lemma = find_or_none (mk_complete_id f_id)
@@ -425,7 +394,7 @@ let add_Function is_general f =
   and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
   and graph_ind =
     match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
-    with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
+    with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive")
   in
   let finfos =
     { function_constant = f;
@@ -475,8 +444,7 @@ let function_debug_sig =
 let _ = declare_bool_option function_debug_sig
 
 
-let do_observe () =
-  !function_debug = true
+let do_observe () = !function_debug 
 
 
 
@@ -499,25 +467,37 @@ exception Building_graph of exn
 exception Defining_principle of exn
 exception ToShow of exn
 
-let init_constant dir s =
-  try
-    Coqlib.gen_constant "Function" dir s
-  with e when Errors.noncritical e -> raise (ToShow e)
-
 let jmeq () =
   try
-    (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-     init_constant ["Logic";"JMeq"] "JMeq")
-  with e when Errors.noncritical e -> raise (ToShow e)
-
-let jmeq_rec () =
-  try
-    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-	  init_constant ["Logic";"JMeq"] "JMeq_rec"
+    Coqlib.check_required_library Coqlib.jmeq_module_name;
+    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq"
   with e when Errors.noncritical e -> raise (ToShow e)
 
 let jmeq_refl () =
   try
-    Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-    init_constant ["Logic";"JMeq"] "JMeq_refl"
+    Coqlib.check_required_library Coqlib.jmeq_module_name;
+    Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl"
   with e when Errors.noncritical e -> raise (ToShow e)
+
+let h_intros l =
+  tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l
+
+let h_id = Id.of_string "h"
+let hrec_id = Id.of_string "hrec"
+let well_founded = function () -> (coq_constant "well_founded")
+let acc_rel = function () -> (coq_constant "Acc")
+let acc_inv_id = function () -> (coq_constant "Acc_inv")
+let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
+let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
+
+let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *)
+  match r with
+      ConstRef sp -> EvalConstRef sp
+    | VarRef id -> EvalVarRef id
+    | _ -> assert false;;
+
+let list_rewrite (rev:bool) (eqs: (constr*bool) list) =
+  tclREPEAT
+    (List.fold_right
+       (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i)
+       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index e0076735..67ddf374 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -5,23 +5,21 @@ open Pp
    The mk_?_id function build different name w.r.t. a function
    Each of their use is justified in the code
 *)
-val mk_rel_id : identifier -> identifier
-val mk_correct_id : identifier -> identifier
-val mk_complete_id : identifier -> identifier
-val mk_equation_id : identifier -> identifier
+val mk_rel_id : Id.t -> Id.t
+val mk_correct_id : Id.t -> Id.t
+val mk_complete_id : Id.t -> Id.t
+val mk_equation_id : Id.t -> Id.t
 
 
 val msgnl : std_ppcmds -> unit
 
-val invalid_argument : string -> 'a
-
-val fresh_id : identifier list -> string -> identifier
-val fresh_name : identifier list -> string -> name
-val get_name : identifier list -> ?default:string -> name -> name
+val fresh_id : Id.t list -> string -> Id.t
+val fresh_name : Id.t list -> string -> Name.t
+val get_name : Id.t list -> ?default:string -> Name.t -> Name.t
 
 val array_get_start : 'a array -> 'a array
 
-val id_of_name : name -> identifier
+val id_of_name : Name.t -> Id.t
 
 val locate_ind : Libnames.reference -> inductive
 val locate_constant : Libnames.reference -> constant
@@ -36,38 +34,31 @@ val list_add_set_eq :
   ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list
 
 val chop_rlambda_n : int -> Glob_term.glob_constr ->
-  (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
+  (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr
 
 val chop_rprod_n : int -> Glob_term.glob_constr ->
-  (name*Glob_term.glob_constr) list * Glob_term.glob_constr
+  (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr
 
 val def_of_const : Term.constr -> Term.constr
 val eq : Term.constr Lazy.t
 val refl_equal : Term.constr Lazy.t
-val const_of_id: identifier -> constant
+val const_of_id: Id.t -> constant
 val jmeq : unit -> Term.constr
 val jmeq_refl : unit -> Term.constr
 
-(* [save_named] is a copy of [Command.save_named] but uses
-   [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast]
-*)
-
-val new_save_named : bool -> unit
-
-val save : bool -> identifier ->  Entries.definition_entry  -> Decl_kinds.goal_kind ->
-  Tacexpr.declaration_hook -> unit
+val save : bool -> Id.t -> Entries.definition_entry  -> Decl_kinds.goal_kind ->
+  unit Lemmas.declaration_hook Ephemeron.key -> unit
 
 (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
    abort the proof
 *)
 val get_proof_clean : bool ->
-  Names.identifier *
-    (Entries.definition_entry * Decl_kinds.goal_kind *
-       Tacexpr.declaration_hook)
+  Names.Id.t *
+    (Entries.definition_entry * Decl_kinds.goal_kind)
 
 
 
-(* [with_full_print f a] applies [f] to [a] in full printing environment
+(* [with_full_print f a] applies [f] to [a] in full printing environment.
 
    This function preserves the print settings
 *)
@@ -112,3 +103,14 @@ exception Defining_principle of exn
 exception ToShow of exn
 
 val is_strict_tcc : unit -> bool
+
+val h_intros: Names.Id.t list -> Proof_type.tactic
+val h_id :  Names.Id.t
+val hrec_id :  Names.Id.t
+val acc_inv_id :  Term.constr Util.delayed
+val ltof_ref : Globnames.global_reference Util.delayed
+val well_founded_ltof : Term.constr Util.delayed
+val acc_rel : Term.constr Util.delayed
+val well_founded : Term.constr Util.delayed
+val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference
+val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index c770c7ce..0c7b0a0b 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -1,39 +1,40 @@
 (************************************************************************)
 (*  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 Tacexpr
 open Declarations
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Pp
-open Libnames
+open Globnames
 open Tacticals
 open Tactics
 open Indfun_common
 open Tacmach
-open Sign
-open Hiddentac
+open Misctypes
 
 (* Some pretty printing function for debugging purpose *)
 
 let pr_binding prc  =
   function
-    | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
-    | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+    | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
 
 let pr_bindings prc prlc = function
-  | Glob_term.ImplicitBindings l ->
+  | ImplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-      Util.prlist_with_sep spc prc l
-  | Glob_term.ExplicitBindings l ->
+      pr_sequence prc l
+  | ExplicitBindings l ->
       brk (1,1) ++ str "with" ++ brk (1,1) ++
-        Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
-  | Glob_term.NoBindings -> mt ()
+        pr_sequence (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+  | NoBindings -> mt ()
 
 
 let pr_with_bindings prc prlc (c,bl) =
@@ -45,17 +46,17 @@ let pr_constr_with_binding prc (c,bl) :  Pp.std_ppcmds =
   pr_with_bindings prc prc  (c,bl)
 
 (* The local debuging mechanism *)
-let msgnl = Pp.msgnl
+(* let msgnl = Pp.msgnl *)
 
 let observe strm =
   if do_observe ()
-  then Pp.msgnl strm
+  then Pp.msg_debug strm
   else ()
 
-let observennl strm =
+(*let observennl strm =
   if do_observe ()
   then begin Pp.msg strm;Pp.pp_flush () end
-  else ()
+  else ()*)
 
 
 let do_observe_tac s tac g =
@@ -64,22 +65,25 @@ let do_observe_tac s tac g =
     with e when Errors.noncritical e -> assert false
   in
   try
-    let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
+    let v = tac g in
+    msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
   with reraise ->
-    let e' = Cerrors.process_vernac_interp_error reraise in
+    let reraise = Errors.push reraise in
+    let e = Cerrors.process_vernac_interp_error reraise in
     msgnl (str "observation "++ s++str " raised exception " ++
-	     Errors.print e' ++ str " on goal " ++ goal );
-    raise reraise;;
-
+	     Errors.iprint e ++ str " on goal " ++ goal );
+    iraise reraise;;
 
 
-let observe_tac_msg s tac g =
-   if do_observe ()
+let observe_tac_strm s tac g =
+  if do_observe ()
   then do_observe_tac s tac g
   else tac g
-    
-let observe_tac s tac g = 
-  observe_tac_msg (str s) tac g
+
+let observe_tac s tac g =
+  if do_observe ()
+  then do_observe_tac (str s) tac g
+  else tac g
 
 (* [nf_zeta] $\zeta$-normalization of a term *)
 let nf_zeta =
@@ -109,57 +113,47 @@ let id_to_constr id =
 
 let generate_type g_to_f f graph i =
   (*i we deduce the number of arguments of the function and its returned type from the graph i*)
-  let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph))  in
+  let gr,u = destInd graph in
+  let graph_arity = Inductive.type_of_inductive (Global.env()) 
+    (Global.lookup_inductive gr, u) in
   let ctxt,_ = decompose_prod_assum graph_arity in
   let fun_ctxt,res_type =
     match ctxt with
-      | [] | [_] -> anomaly "Not a valid context"
+      | [] | [_] -> anomaly (Pp.str "Not a valid context")
       | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
   in
-  let nb_args = List.length fun_ctxt in
-  let args_from_decl i decl =
-    match decl with
-      | (_,Some _,_) -> incr i; failwith "args_from_decl"
-      | _ -> let j = !i in incr i;mkRel (nb_args - j  + 1)
+  let rec args_from_decl i accu = function
+  | [] -> accu
+  | (_, Some _, _) :: l ->
+    args_from_decl (succ i) accu l
+  | _ :: l ->
+    let t = mkRel i in
+    args_from_decl (succ i) (t :: accu) l
   in
   (*i We need to name the vars [res] and [fv] i*)
-  let res_id =
-    Namegen.next_ident_away_in_goal
-      (id_of_string "res")
-      (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
-  in
-  let fv_id =
-    Namegen.next_ident_away_in_goal
-      (id_of_string "fv")
-      (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
-  in
+  let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in
+  let named_ctxt = List.map_filter filter fun_ctxt in
+  let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in
+  let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in
   (*i we can then type the argument to be applied to the function [f] i*)
-  let args_as_rels =
-    let i = ref 0 in
-    Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
-  in
-  let args_as_rels = Array.map Termops.pop args_as_rels in
+  let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in
   (*i
     the hypothesis [res = fv] can then be computed
     We will need to lift it by one in order to use it as a conclusion
     i*)
+  let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+  in
   let res_eq_f_of_args =
-    mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
+    mkApp(make_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
   in
   (*i
     The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
     We will need to lift it by one in order to use it as a conclusion
     i*)
-  let graph_applied =
-    let args_and_res_as_rels =
-      let i = ref 0 in
-      Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
-    in
-    let args_and_res_as_rels =
-      Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
-    in
-    mkApp(graph,args_and_res_as_rels)
-  in
+  let args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in
+  let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in
+  let graph_applied = mkApp(graph, args_and_res_as_rels) in
   (*i The [pre_context]  is the defined to be the context corresponding to
     \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,  \]
     i*)
@@ -178,7 +172,7 @@ let generate_type g_to_f f graph i =
    WARNING: while convertible, [type_of body] and [type] can be non equal
 *)
 let find_induction_principle f =
-  let f_as_constant =  match kind_of_term f with
+  let f_as_constant,u =  match kind_of_term f with
     | Const c' -> c'
     | _ -> error "Must be used with a function"
   in
@@ -195,7 +189,7 @@ let find_induction_principle f =
 (*     let fname =  *)
 (*       match kind_of_term f with  *)
 (* 	| Const c' ->  *)
-(* 	    id_of_label (con_label c')  *)
+(* 	    Label.to_id (con_label c')  *)
 (* 	| _ -> error "Must be used with a function"  *)
 (*     in *)
 
@@ -217,6 +211,11 @@ let rec generate_fresh_id x avoid i =
     let id = Namegen.next_ident_away_in_goal x avoid in
     id::(generate_fresh_id x (id::avoid) (pred i))
 
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+let make_eq_refl () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
+
 
 (* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
    is the tactic used to prove correctness lemma.
@@ -248,11 +247,266 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
        that is~:
        \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
     *)
+    (* we the get the definition of the graphs block *)
+    let graph_ind,u = destInd graphs_constr.(i) in
+    let kn = fst graph_ind in
+    let mib,_ = Global.lookup_inductive graph_ind in
+    (* and the principle to use in this lemma in $\zeta$ normal form *)
+    let f_principle,princ_type = schemes.(i) in
+    let princ_type =  nf_zeta princ_type in
+    let princ_infos = Tactics.compute_elim_sig princ_type in
+    (* The number of args of the function is then easilly computable *)
+    let nb_fun_args = nb_prod (pf_concl g)  - 2  in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
+    let ids = args_names@(pf_ids_of_hyps g) in
+    (* Since we cannot ensure that the funcitonnal principle is defined in the
+       environement and due to the bug #1174, we will need to pose the principle
+       using a name
+    *)
+    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in
+    let ids = principle_id :: ids in
+    (* We get the branches of the principle *)
+    let branches = List.rev princ_infos.branches in
+    (* and built the intro pattern for each of them *)
+    let intro_pats =
+      List.map
+	(fun (_,_,br_type) ->
+	   List.map
+	     (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id))
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+	)
+	branches
+    in
+    (* before building the full intro pattern for the principle *)
+    let eq_ind = make_eq () in
+    let eq_construct = mkConstructUi (destInd eq_ind, 1) in
+    (* The next to referencies will be used to find out which constructor to apply in each branch *)
+    let ind_number = ref 0
+    and min_constr_number = ref 0 in
+    (* The tactic to prove the ith branch of the principle *)
+    let prove_branche i g =
+      (* We get the identifiers of this branch *)
+      (*
+	let this_branche_ids =
+	List.fold_right
+	(fun (_,pat) acc ->
+	     match pat with
+	       | Genarg.IntroIdentifier id -> Id.Set.add id acc
+	| _ -> anomaly (Pp.str "Not an identifier")
+	)
+	(List.nth intro_pats (pred i))
+	Id.Set.empty
+      in
+	let pre_args g =
+	List.fold_right
+	  (fun (id,b,t) pre_args ->
+	    if Id.Set.mem id this_branche_ids
+	    then
+	      match b with
+		| None -> id::pre_args
+		| Some b -> pre_args
+	    else pre_args
+	  )
+	  (pf_hyps g)
+	  ([])
+      in
+      let pre_args g = List.rev (pre_args g) in 
+      let pre_tac g =
+	List.fold_right
+	  (fun (id,b,t) pre_tac ->
+	     if Id.Set.mem id this_branche_ids
+	     then
+	       match b with
+		 | None -> pre_tac
+		 | Some b ->
+		   tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac
+	     else pre_tac
+	  )
+	  (pf_hyps g)
+	  tclIDTAC
+      in
+*)     
+      let pre_args =
+      	List.fold_right
+      	  (fun (_,pat) acc ->
+      	     match pat with
+	       | IntroNaming (IntroIdentifier id) -> id::acc
+      	       | _ -> anomaly (Pp.str "Not an identifier")
+      	  )
+      	  (List.nth intro_pats (pred i))
+      	  []
+      in
+      (* and get the real args of the branch by unfolding the defined constant *)
+      (*
+	 We can then recompute the arguments of the constructor.
+	 For each [hid] introduced by this branch, if [hid] has type
+	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
+	 [ fv (hid fv (refl_equal fv)) ].
+	 If [hid] has another type the corresponding argument of the constructor is [hid]
+      *)
+      let constructor_args g =
+	List.fold_right
+	  (fun hid acc ->
+	     let type_of_hid = pf_type_of g (mkVar hid) in
+	     match kind_of_term type_of_hid with
+	       | Prod(_,_,t') ->
+		   begin
+		     match kind_of_term t' with
+		       | Prod(_,t'',t''') ->
+			   begin
+			     match kind_of_term t'',kind_of_term t''' with
+			       | App(eq,args), App(graph',_)
+				   when
+				     (eq_constr eq eq_ind) &&
+				       Array.exists  (eq_constr graph') graphs_constr ->
+				   (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+				    ::acc)
+			       | _ -> mkVar hid ::  acc
+			   end
+		       | _ -> mkVar hid :: acc
+		   end
+	       | _ -> mkVar hid :: acc
+	  ) pre_args []
+      in
+      (* in fact we must also add the parameters to the constructor args *)
+      let constructor_args g =
+	let params_id = fst (List.chop princ_infos.nparams args_names) in
+	(List.map mkVar params_id)@((constructor_args g))
+      in
+      (* We then get the constructor corresponding to this branch and
+	 modifies the references has needed i.e.
+	 if the constructor is the last one of the current inductive then
+	 add one the number of the inductive to take and add the number of constructor of the previous
+	 graph to the minimal constructor number
+      *)
+      let constructor =
+	let constructor_num = i - !min_constr_number in
+	let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
+	if constructor_num <= length
+	then
+	  begin
+	    (kn,!ind_number),constructor_num
+	  end
+	else
+	  begin
+	    incr ind_number;
+	    min_constr_number := !min_constr_number + length ;
+	    (kn,!ind_number),1
+	  end
+      in
+      (* we can then build the final proof term *)
+      let app_constructor g = applist((mkConstruct(constructor)),constructor_args g) in
+      (* an apply the tactic *)
+      let res,hres =
+	match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with
+	  | [res;hres] -> res,hres
+	  | _ -> assert false
+      in
+      (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *)
+      (
+	tclTHENSEQ
+	  [
+	    observe_tac("h_intro_patterns ")  (let l = (List.nth intro_pats (pred i)) in 
+					       match l with 
+						 | [] -> tclIDTAC 
+						 | _ -> Proofview.V82.of_tactic (intro_patterns l));
+	    (* unfolding of all the defined variables introduced by this branch *)
+	    (* observe_tac "unfolding" pre_tac; *)
+	    (* $zeta$ normalizing of the conclusion *)
+	    reduce
+	      (Genredexpr.Cbv
+		 { Redops.all_flags with
+		     Genredexpr.rDelta = false ;
+		     Genredexpr.rConst = []
+		 }
+	      )
+	      Locusops.onConcl;
+	    observe_tac ("toto ") tclIDTAC;
+    
+	    (* introducing the the result of the graph and the equality hypothesis *)
+	    observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]);
+	    (* replacing [res] with its value *)
+	    observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres)));
+	    (* Conclusion *)
+	    observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (app_constructor g)) g)  
+	  ]
+      )
+	g
+    in
+    (* end of branche proof *)
+    let lemmas =
+      Array.map
+	(fun (_,(ctxt,concl)) ->
+	   match ctxt with
+	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
+	     | hres::res::(x,_,t)::ctxt ->
+		 Termops.it_mkLambda_or_LetIn
+		   (Termops.it_mkProd_or_LetIn concl [hres;res])
+		   ((x,None,t)::ctxt)
+	)
+	lemmas_types_infos
+    in
+    let param_names = fst (List.chop princ_infos.nparams args_names) in
+    let params = List.map mkVar param_names in
+    let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
+    (* The bindings of the principle
+       that is the params of the principle and the different lemma types
+    *)
+    let bindings =
+      let params_bindings,avoid =
+	List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (*(Loc.ghost,Glob_term.NamedHyp id,p)*)p::bindings,id::avoid
+	  )
+	  ([],pf_ids_of_hyps g)
+	  princ_infos.params
+	  (List.rev params)
+      in
+      let lemmas_bindings =
+	List.rev (fst  (List.fold_left2
+	  (fun (bindings,avoid) (x,_,_) p ->
+	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+	     (*(Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))*) (nf_zeta p)::bindings,id::avoid)
+	  ([],avoid)
+	  princ_infos.predicates
+	  (lemmas)))
+      in
+      (* Glob_term.ExplicitBindings *) (params_bindings@lemmas_bindings)
+    in
+    tclTHENSEQ
+      [ 
+	observe_tac "principle" (Proofview.V82.of_tactic (assert_by
+	  (Name principle_id)
+	  princ_type
+	  (exact_check f_principle)));
+	observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names);
+	(* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty  ((mkApp (mkVar principle_id,Array.of_list bindings))))); *)
+	observe_tac "idtac" tclIDTAC;
+	tclTHEN_i
+	  (observe_tac "functional_induction" (
+	    (fun gl -> 
+	      let term = mkApp (mkVar principle_id,Array.of_list bindings) in
+	      let gl', _ty = pf_eapply Typing.e_type_of gl term in
+		Proofview.V82.of_tactic (apply term) gl')
+	   ))
+	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
+      ]
+      g
+
+
+(*
+let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
+  fun g ->
+    (* first of all we recreate the lemmas types to be used as predicates of the induction principle
+       that is~:
+       \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun  fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
+    *)
     let lemmas =
       Array.map
 	(fun (_,(ctxt,concl)) ->
 	   match ctxt with
-	     | [] | [_] | [_;_] -> anomaly "bad context"
+	     | [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
 	     | hres::res::(x,_,t)::ctxt ->
 		 Termops.it_mkLambda_or_LetIn
 		   (Termops.it_mkProd_or_LetIn concl [hres;res])
@@ -270,13 +524,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
     let princ_infos = Tactics.compute_elim_sig princ_type in
     (* The number of args of the function is then easilly computable *)
     let nb_fun_args = nb_prod (pf_concl g)  - 2  in
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* Since we cannot ensure that the funcitonnal principle is defined in the
        environement and due to the bug #1174, we will need to pose the principle
        using a name
     *)
-    let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in
+    let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in
     let ids = principle_id :: ids in
     (* We get the branches of the principle *)
     let branches = List.rev princ_infos.branches in
@@ -285,44 +539,43 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       List.map
 	(fun (_,_,br_type) ->
 	   List.map
-	     (fun id -> dummy_loc, Genarg.IntroIdentifier id)
-	     (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+	     (fun id -> Loc.ghost, Genarg.IntroIdentifier id)
+	     (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
 	)
 	branches
     in
     (* before building the full intro pattern for the principle *)
+    let pat = Some (Loc.ghost,Genarg.IntroOrAndPattern intro_pats) in
     let eq_ind = Coqlib.build_coq_eq () in
     let eq_construct = mkConstruct((destInd eq_ind),1) in
     (* The next to referencies will be used to find out which constructor to apply in each branch *)
     let ind_number = ref 0
     and min_constr_number = ref 0 in
     (* The tactic to prove the ith branch of the principle *)
-    let this_branche_ids empty add  i =
-      List.fold_right
-	(fun (_,pat) acc ->
-	  match pat with
-	  | Genarg.IntroIdentifier id -> add id acc
-	  | _ -> anomaly "Not an identifier"
-	)
-	(List.nth intro_pats (pred i))
-	empty
-    in
     let prove_branche i g =
       (* We get the identifiers of this branch *)
+      let this_branche_ids =
+	List.fold_right
+	  (fun (_,pat) acc ->
+	     match pat with
+	       | Genarg.IntroIdentifier id -> Id.Set.add id acc
+	       | _ -> anomaly (Pp.str "Not an identifier")
+	  )
+	  (List.nth intro_pats (pred i))
+	  Id.Set.empty
+      in
       (* and get the real args of the branch by unfolding the defined constant *)
       let pre_args,pre_tac =
 	List.fold_right
 	  (fun (id,b,t) (pre_args,pre_tac) ->
-	     if Idset.mem id (this_branche_ids Idset.empty Idset.add i)
+	     if Id.Set.mem id this_branche_ids
 	     then
 	       match b with
-		 | None -> 
-		   (id::pre_args,pre_tac)
+		 | None -> (id::pre_args,pre_tac)
 		 | Some b ->
 		     (pre_args,
-		      tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
+		      tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.AllOccurrences,EvalVarRef id])) allHyps) pre_tac
 		     )
-
 	     else (pre_args,pre_tac)
 	  )
 	  (pf_hyps g)
@@ -333,7 +586,6 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	 For each [hid] introduced by this branch, if [hid] has type
 	 $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
 	 [ fv (hid fv (refl_equal fv)) ].
-
 	 If [hid] has another type the corresponding argument of the constructor is [hid]
       *)
       let constructor_args =
@@ -350,9 +602,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 			       | App(eq,args), App(graph',_)
 				   when
 				     (eq_constr eq eq_ind) &&
-				       array_exists  (eq_constr graph') graphs_constr ->
-				 ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
-				  ::args.(2)::acc)
+				       Array.exists  (eq_constr graph') graphs_constr ->
+				   ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+				    ::args.(2)::acc)
 			       | _ -> mkVar hid ::  acc
 			   end
 		       | _ -> mkVar hid :: acc
@@ -362,7 +614,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       in
       (* in fact we must also add the parameters to the constructor args *)
       let constructor_args =
-	let params_id = fst (list_chop princ_infos.nparams args_names) in
+	let params_id = fst (List.chop princ_infos.nparams args_names) in
 	(List.map mkVar params_id)@(List.rev constructor_args)
       in
       (* We then get the constructor corresponding to this branch and
@@ -390,11 +642,11 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
       let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
       (* an apply the tactic *)
       let res,hres =
-	match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
+	match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with
 	  | [res;hres] -> res,hres
 	  | _ -> assert false
       in
-      observe_tac_msg (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor)
+      observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
       (
 	tclTHENSEQ
 	  [
@@ -414,13 +666,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	    (* replacing [res] with its value *)
 	    observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
 	    (* Conclusion *)
-	    observe_tac "exact" (h_exact app_constructor)
+	    observe_tac "exact" (exact_check app_constructor)
 	  ]
       )
 	g
     in
     (* end of branche proof *)
-    let param_names = fst (list_chop princ_infos.nparams args_names) in
+    let param_names = fst (List.chop princ_infos.nparams args_names) in
     let params = List.map mkVar param_names in
     let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
     (* The bindings of the principle
@@ -431,7 +683,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid
+	     (Loc.ghost,Glob_term.NamedHyp id,p)::bindings,id::avoid
 	  )
 	  ([],pf_ids_of_hyps g)
 	  princ_infos.params
@@ -441,7 +693,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	List.rev (fst  (List.fold_left2
 	  (fun (bindings,avoid) (x,_,_) p ->
 	     let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
-	     (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
+	     (Loc.ghost,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
 	  ([],avoid)
 	  princ_infos.predicates
 	  (lemmas)))
@@ -453,18 +705,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 	observe_tac "principle" (assert_by
 	  (Name principle_id)
 	  princ_type
-	  (h_exact f_principle));
+	  (exact_check f_principle));
 	tclTHEN_i
 	  (observe_tac "functional_induction" (
 	     fun g ->
 	       observe
 		 (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g))  (mkVar principle_id,bindings));
-	       h_apply false false [dummy_loc,(mkVar principle_id,bindings)] g
+	       functional_induction  false (applist(funs_constr.(i),List.map mkVar args_names))
+		 (Some (mkVar principle_id,bindings))
+		 pat g
 	   ))
-	  (fun i g -> observe_tac ("proving branche "^string_of_int i) 
-	    (tclTHEN (tclMAP h_intro (this_branche_ids [] (fun a b -> a::b) i)) (prove_branche i)) g )
+	  (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
       ]
       g
+*)
+
 
 (* [generalize_dependent_of x hyp g]
    generalize every hypothesis which depends of [x] but [hyp]
@@ -472,8 +727,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
 let generalize_dependent_of x hyp g =
   tclMAP
     (function
-       | (id,None,t) when not (id = hyp) &&
-	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
+       | (id,None,t) when not (Id.equal id hyp) &&
+	   (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id])
        | _ -> tclIDTAC
     )
     (pf_hyps g)
@@ -490,7 +745,7 @@ let  rec intros_with_rewrite g =
   observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
 and intros_with_rewrite_aux : tactic =
   fun g ->
-    let eq_ind = Coqlib.build_coq_eq () in
+    let eq_ind = make_eq () in
     match kind_of_term (pf_concl g) with
 	  | Prod(_,t,t') ->
 	      begin
@@ -498,66 +753,79 @@ and intros_with_rewrite_aux : tactic =
 		  | App(eq,args) when (eq_constr eq eq_ind)  ->
  		      if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
 		      then
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
-
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g
+		      else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) 
+		      then tclTHENSEQ[
+			unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))];
+			tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))
+			  (pf_ids_of_hyps g);
+			intros_with_rewrite
+		      ] g
+		      else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) 
+		      then tclTHENSEQ[
+			unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))];
+			tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))
+			  (pf_ids_of_hyps g);
+			intros_with_rewrite
+		      ] g
 		      else if isVar args.(1)
 		      then
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id;
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
 				     generalize_dependent_of (destVar args.(1)) id;
-				     tclTRY (Equality.rewriteLR (mkVar id));
+				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 				     intros_with_rewrite
 				   ]
 			  g
 		      else if isVar args.(2) 
 		      then 
-			let id = pf_get_new_id (id_of_string "y") g  in
-			tclTHENSEQ [ h_intro id;
+			let id = pf_get_new_id (Id.of_string "y") g  in
+			tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);
 				     generalize_dependent_of (destVar args.(2)) id;
-				     tclTRY (Equality.rewriteRL (mkVar id));
+				     tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id)));
 				     intros_with_rewrite
 				   ]
 			  g
 		      else
 			begin
-			  let id = pf_get_new_id (id_of_string "y") g  in
+			  let id = pf_get_new_id (Id.of_string "y") g  in
 			  tclTHENSEQ[
-			    h_intro id;
-			    tclTRY (Equality.rewriteLR (mkVar id));
+			    Proofview.V82.of_tactic (Simple.intro id);
+			    tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id)));
 			    intros_with_rewrite
 			  ] g
 			end
 		  | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
-		      Tauto.tauto g
+		      Proofview.V82.of_tactic Tauto.tauto g
 		  | Case(_,_,v,_) ->
 		      tclTHENSEQ[
-			h_case false (v,Glob_term.NoBindings);
+			Proofview.V82.of_tactic (simplest_case v);
 			intros_with_rewrite
 		      ] g
 		  | LetIn _ ->
 		      tclTHENSEQ[
-			h_reduce
-			  (Glob_term.Cbv
-			     {Glob_term.all_flags
-			      with Glob_term.rDelta = false;
+			reduce
+			  (Genredexpr.Cbv
+			     {Redops.all_flags
+			      with Genredexpr.rDelta = false;
 			     })
-			  onConcl
+			  Locusops.onConcl
 			;
 			intros_with_rewrite
 		      ] g
 		  | _ ->
-		      let id = pf_get_new_id (id_of_string "y") g  in
-		      tclTHENSEQ [ h_intro id;intros_with_rewrite] g
+		      let id = pf_get_new_id (Id.of_string "y") g  in
+		      tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g
 	      end
 	  | LetIn _ ->
 	      tclTHENSEQ[
-		h_reduce
-		  (Glob_term.Cbv
-		     {Glob_term.all_flags
-		      with Glob_term.rDelta = false;
+		reduce
+		  (Genredexpr.Cbv
+		     {Redops.all_flags
+		      with Genredexpr.rDelta = false;
 		     })
-		  onConcl
+		  Locusops.onConcl
 		;
 		intros_with_rewrite
 	      ] g
@@ -569,14 +837,14 @@ let rec reflexivity_with_destruct_cases g =
       match kind_of_term (snd (destApp (pf_concl g))).(2) with
 	| Case(_,_,v,_) ->
 	    tclTHENSEQ[
-	      h_case false (v,Glob_term.NoBindings);
-	      intros;
+	      Proofview.V82.of_tactic (simplest_case v);
+	      Proofview.V82.of_tactic intros;
 	      observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
 	    ]
-	| _ -> reflexivity
-    with e when Errors.noncritical e -> reflexivity
+        | _ -> Proofview.V82.of_tactic reflexivity
+    with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity
   in
-  let eq_ind =     Coqlib.build_coq_eq () in
+  let eq_ind = make_eq () in
   let discr_inject =
     Tacticals.onAllHypsAndConcl (
        fun sc g ->
@@ -586,15 +854,15 @@ let rec reflexivity_with_destruct_cases g =
 	       match kind_of_term  (pf_type_of g (mkVar id)) with
 		 | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
 		     if Equality.discriminable (pf_env g) (project g) t1 t2
-		     then Equality.discrHyp id g
+		     then Proofview.V82.of_tactic (Equality.discrHyp id) g
 		     else if Equality.injectable (pf_env g) (project g) t1 t2
-		     then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite]  g
+		     then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite]  g
 		     else tclIDTAC g
 		 | _ -> tclIDTAC g
     )
   in
   (tclFIRST
-    [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity;
+    [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity);
       observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ()));
       (*  We reach this point ONLY if
 	  the same value is matched (at least) two times
@@ -654,23 +922,24 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
        and compute a fresh name for each of them
     *)
     let nb_fun_args = nb_prod (pf_concl g)  - 2  in
-    let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+    let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in
     let ids = args_names@(pf_ids_of_hyps g) in
     (* and fresh names for res H and the principle (cf bug bug #1174) *)
     let res,hres,graph_principle_id =
-      match generate_fresh_id (id_of_string "z") ids 3 with
+      match generate_fresh_id (Id.of_string "z") ids 3 with
 	| [res;hres;graph_principle_id] -> res,hres,graph_principle_id
 	| _ -> assert false
     in
     let ids = res::hres::graph_principle_id::ids in
-    (* we also compute fresh names for each hyptohesis of each branche of the principle *)
+    (* we also compute fresh names for each hyptohesis of each branch
+       of the principle *)
     let branches = List.rev princ_infos.branches in
     let intro_pats =
       List.map
 	(fun (_,_,br_type) ->
 	   List.map
 	     (fun id -> id)
-	     (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
+	     (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type))
 	)
 	branches
     in
@@ -680,28 +949,34 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
     *)
     let rewrite_tac j ids : tactic =
       let graph_def = graphs.(j) in
-      let infos =  try find_Function_infos (destConst funcs.(j)) with Not_found ->  error "No graph found" in
-      if infos.is_general ||  Rtree.is_infinite graph_def.mind_recargs
+      let infos =
+        try find_Function_infos (fst (destConst funcs.(j)))
+        with Not_found ->  error "No graph found"
+      in
+      if infos.is_general
+        || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs
       then
 	let eq_lemma =
 	  try Option.get (infos).equation_lemma
-	  with Option.IsNone -> anomaly "Cannot find equation lemma"
+	  with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma")
 	in
 	tclTHENSEQ[
-	  tclMAP h_intro ids;
-	  Equality.rewriteLR (mkConst eq_lemma);
-	  (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *)
-	  h_reduce
-	    (Glob_term.Cbv
-	       {Glob_term.all_flags
-		with Glob_term.rDelta = false;
+	  tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids;
+	  Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma));
+	  (* Don't forget to $\zeta$ normlize the term since the principles
+             have been $\zeta$-normalized *)
+	  reduce
+	    (Genredexpr.Cbv
+	       {Redops.all_flags
+		with Genredexpr.rDelta = false;
 	       })
-	    onConcl
+	    Locusops.onConcl
 	  ;
-	  h_generalize (List.map mkVar ids);
+	  Simple.generalize (List.map mkVar ids);
 	  thin ids
 	]
-      else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))]
+      else
+        unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]
     in
     (* The proof of each branche itself *)
     let ind_number = ref 0 in
@@ -725,21 +1000,21 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 	(* we expand the definition of the function *)
         observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
 	(* introduce hypothesis with some rewrite *)
-        observe_tac "intros_with_rewrite" intros_with_rewrite;
+        observe_tac "intros_with_rewrite (all)" intros_with_rewrite;
 	(* The proof is (almost) complete *)
         observe_tac "reflexivity" (reflexivity_with_destruct_cases)
       ]
 	g
     in
-    let params_names = fst (list_chop princ_infos.nparams args_names) in
+    let params_names = fst (List.chop princ_infos.nparams args_names) in
     let params = List.map mkVar params_names in
     tclTHENSEQ
-      [ tclMAP h_intro (args_names@[res;hres]);
+      [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]);
 	observe_tac "h_generalize"
-	(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
-	h_intro graph_principle_id;
+	(Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
+	Proofview.V82.of_tactic (Simple.intro graph_principle_id);
 	observe_tac "" (tclTHEN_i
-	  (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings)))))
+	  (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings)))))
 	  (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
       ]
       g
@@ -747,7 +1022,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
 
 
 
-let do_save () = Lemmas.save_named false
+let do_save () = Lemmas.save_proof (Vernacexpr.Proved(false,None))
 
 
 (* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
@@ -758,15 +1033,14 @@ let do_save () = Lemmas.save_named false
 *)
 
 let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
-  let previous_state = States.freeze () in
   let funs = Array.of_list funs and graphs = Array.of_list graphs in
   let funs_constr = Array.map mkConst funs  in
-  try
+  States.with_state_protection_on_exception (fun () ->
     let graphs_constr = Array.map mkInd graphs in
     let lemmas_types_infos =
-      Util.array_map2_i
+      Util.Array.map2_i
 	(fun i f_constr graph ->
-	   let const_of_f = destConst f_constr in
+	   let const_of_f,u = destConst f_constr in
 	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type false const_of_f graph i
 	   in
@@ -783,15 +1057,15 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	 if the block contains only one function we can safely reuse [f_rect]
       *)
       try
-	if Array.length funs_constr <> 1 then raise Not_found;
+	if not (Int.equal (Array.length funs_constr) 1) then raise Not_found;
 	[| find_induction_principle funs_constr.(0) |]
       with Not_found ->
 	  Array.of_list
 	    (List.map
 	       (fun entry ->
-		  (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type )
+		  (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type )
 	       )
-	       (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs))
+	       (make_scheme (Array.map_to_list (fun const -> const,GType []) funs))
 	    )
     in
     let proving_tac =
@@ -799,28 +1073,29 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = id_of_label (con_label f_as_constant) in
+	 let f_id = Label.to_id (con_label f_as_constant) in
 	 (*i The next call to mk_correct_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	 i*)
 	 let lem_id = mk_correct_id f_id in
 	 Lemmas.start_proof lem_id
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by
-	   (observe_tac ("prove correctness ("^(string_of_id f_id)^")")
-	      (proving_tac i));
+	   (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem))
+                 (*FIXME*) Evd.empty
+	 (fst lemmas_types_infos.(i))
+           (Lemmas.mk_hook (fun _ _ -> ()));
+	 ignore (Pfedit.by
+	   (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")")
+	      (proving_tac i))));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in
 	 update_Function {finfo with correctness_lemma = Some lem_cst}
       )
       funs;
     let lemmas_types_infos =
-      Util.array_map2_i
+      Util.Array.map2_i
 	(fun i f_constr graph ->
-	   let const_of_f = destConst f_constr in
+	   let const_of_f = fst (destConst f_constr) in
 	   let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info =
 	     generate_type true  const_of_f graph i
 	   in
@@ -832,51 +1107,46 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
 	funs_constr
 	graphs_constr
     in
-    let kn,_ as graph_ind  = destInd graphs_constr.(0) in
+    let kn,_ as graph_ind  = fst (destInd graphs_constr.(0)) in
     let  mib,mip = Global.lookup_inductive graph_ind in
-    let schemes =
-      Array.of_list
+    let sigma, scheme = 
 	(Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty
 	   (Array.to_list
 	      (Array.mapi
-		 (fun i _ -> (kn,i),true,InType)
+		 (fun i _ -> ((kn,i),Univ.Instance.empty)(*FIXME*),true,InType)
 		 mib.Declarations.mind_packets
 	      )
 	   )
 	)
     in
+    let schemes =
+      Array.of_list scheme
+    in
     let proving_tac =
       prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
     in
     Array.iteri
       (fun i f_as_constant ->
-	 let f_id = id_of_label (con_label f_as_constant) in
+	 let f_id = Label.to_id (con_label f_as_constant) in
 	 (*i The next call to mk_complete_id is valid since we are constructing the lemma
 	     Ensures by: obvious
 	   i*)
 	 let lem_id = mk_complete_id f_id in
 	 Lemmas.start_proof lem_id
-	   (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
-	   (fst lemmas_types_infos.(i))
-	   (fun _ _ -> ());
-	 Pfedit.by
-	   (observe_tac ("prove completeness ("^(string_of_id f_id)^")")
-	      (proving_tac i));
+	   (Decl_kinds.Global,false(*FIXME*),(Decl_kinds.Proof Decl_kinds.Theorem))
+                            (*FIXME*) Evd.empty
+	 (fst lemmas_types_infos.(i))
+           (Lemmas.mk_hook (fun _ _ -> ()));
+	 ignore (Pfedit.by
+	   (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")")
+	      (proving_tac i))));
 	 do_save ();
 	 let finfo = find_Function_infos f_as_constant in
-	 let lem_cst = destConst (Constrintern.global_reference lem_id) in
+	 let lem_cst,u = destConst (Constrintern.global_reference lem_id) in
 	 update_Function {finfo with completeness_lemma = Some lem_cst}
       )
-      funs;
-  with reraise ->
-    (* In case of problem, we reset all the lemmas *)
-    Pfedit.delete_all_proofs ();
-    States.unfreeze previous_state;
-    raise reraise
-
-
-
-
+      funs)
+  ()
 
 (***********************************************)
 
@@ -890,13 +1160,13 @@ let revert_graph kn post_tac hid g =
     let typ = pf_type_of g (mkVar hid) in
     match kind_of_term typ with
       | App(i,args) when isInd i ->
-	  let ((kn',num) as ind') = destInd i in
-	  if kn = kn'
+	  let ((kn',num) as ind'),u = destInd i in
+	  if MutInd.equal kn kn'
 	  then (* We have generated a graph hypothesis so that we must change it if we can *)
 	    let info =
 	      try find_Function_of_graph ind'
 	      with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
-		anomaly "Cannot retrieve infos about a mutual block"
+		anomaly (Pp.str "Cannot retrieve infos about a mutual block")
 	    in
 	    (* if we can find a completeness lemma for this function
 	       then we can come back to the functional form. If not, we do nothing
@@ -904,12 +1174,12 @@ let revert_graph kn post_tac hid g =
 	    match info.completeness_lemma with
 	      | None -> tclIDTAC g
 	      | Some f_complete ->
-		  let f_args,res = array_chop (Array.length args - 1) args in
+		  let f_args,res = Array.chop (Array.length args - 1) args in
 		  tclTHENSEQ
 		    [
-		      h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+		      Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
 		      thin [hid];
-		      h_intro hid;
+		      Proofview.V82.of_tactic (Simple.intro hid);
 		      post_tac hid
 		    ]
 		    g
@@ -937,26 +1207,26 @@ let revert_graph kn post_tac hid g =
 
 let functional_inversion kn hid fconst f_correct : tactic =
   fun g ->
-    let old_ids = List.fold_right Idset.add  (pf_ids_of_hyps g) Idset.empty in
+    let old_ids = List.fold_right Id.Set.add  (pf_ids_of_hyps g) Id.Set.empty in
     let type_of_h = pf_type_of g (mkVar hid) in
     match kind_of_term type_of_h with
-      | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ())  ->
+      | App(eq,args) when eq_constr eq (make_eq ())  ->
 	  let pre_tac,f_args,res =
 	    match kind_of_term args.(1),kind_of_term args.(2) with
 	      | App(f,f_args),_ when eq_constr f fconst ->
-		  ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
+		  ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2))
 	      |_,App(f,f_args) when eq_constr f fconst ->
 		 ((fun hid -> tclIDTAC),f_args,args.(1))
 	      | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
 	  in
 	  tclTHENSEQ[
 	    pre_tac hid;
-	    h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
+	    Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
 	    thin [hid];
-	    h_intro hid;
-	    Inv.inv FullInversion None (Glob_term.NamedHyp hid);
+	    Proofview.V82.of_tactic (Simple.intro hid);
+	    Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid));
 	    (fun g ->
-	       let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in
+	       let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in
 	       tclMAP (revert_graph kn pre_tac)  (hid::new_ids)  g
 	    );
 	  ] g
@@ -968,14 +1238,16 @@ let invfun qhyp f  =
   let f =
     match f with
       | ConstRef f -> f
-      | _ -> raise (Util.UserError("",str "Not a function"))
+      | _ -> raise (Errors.UserError("",str "Not a function"))
   in
   try
     let finfos = find_Function_infos f in
     let f_correct = mkConst(Option.get finfos.correctness_lemma)
     and kn = fst finfos.graph_ind
     in
-    Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f)  f_correct) qhyp
+    Proofview.V82.of_tactic (
+      Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f)  f_correct)) qhyp
+    )
   with
     | Not_found ->  error "No graph found"
     | Option.IsNone  -> error "Cannot use equivalence with graph!"
@@ -985,16 +1257,17 @@ let invfun qhyp f g =
   match f with
     | Some f -> invfun qhyp f g
     | None ->
+        Proofview.V82.of_tactic begin
 	Tactics.try_intros_until
-	  (fun hid g ->
+	  (fun hid -> Proofview.V82.tactic begin fun g ->
 	     let hyp_typ = pf_type_of g (mkVar hid)  in
 	     match kind_of_term hyp_typ with
-	       | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+	       | App(eq,args) when eq_constr eq (make_eq ()) ->
 		   begin
 		     let f1,_ = decompose_app args.(1) in
 		     try
 		       if not (isConst f1) then failwith "";
-		       let finfos = find_Function_infos (destConst f1) in
+		       let finfos = find_Function_infos (fst (destConst f1)) in
 		       let f_correct = mkConst(Option.get finfos.correctness_lemma)
 		       and kn = fst finfos.graph_ind
 		       in
@@ -1003,14 +1276,14 @@ let invfun qhyp f g =
 		       try
 			 let f2,_ = decompose_app args.(2) in
 			 if not (isConst f2) then failwith "";
-			 let finfos = find_Function_infos (destConst f2) in
+			 let finfos = find_Function_infos (fst (destConst f2)) in
 			 let f_correct = mkConst(Option.get finfos.correctness_lemma)
 			 and kn = fst finfos.graph_ind
 			 in
 			 functional_inversion kn hid  f2 f_correct g
 		       with
 			 | Failure "" ->
-			     errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
+			     errorlabstrm "" (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function")
 			 | Option.IsNone  ->
 			     if do_observe ()
 			     then
@@ -1023,6 +1296,7 @@ let invfun qhyp f g =
 			     else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
 		   end
 	       | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
-	  )
+	  end)
 	  qhyp
+          end
 	  g
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index e1f10be2..ea699580 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.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,20 +8,23 @@
 
 (* Merging of induction principles. *)
 
-open Libnames
+open Globnames
 open Tactics
 open Indfun_common
+open Errors
 open Util
-open Topconstr
+open Constrexpr
 open Vernacexpr
 open Pp
 open Names
 open Term
+open Vars
+open Context
 open Termops
 open Declarations
-open Environ
 open Glob_term
 open Glob_termops
+open Decl_kinds
 
 (** {1 Utilities}  *)
 
@@ -48,33 +51,33 @@ let rec substitterm prof t by_t in_u =
 
 let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
 
-let understand = Pretyping.Default.understand Evd.empty (Global.env())
+let understand = Pretyping.understand (Global.env()) Evd.empty
 
 (** Operations on names and identifiers *)
 let id_of_name = function
-    Anonymous -> id_of_string "H"
+    Anonymous -> Id.of_string "H"
   | Name id   -> id;;
-let name_of_string str = Name (id_of_string str)
-let string_of_name nme = string_of_id (id_of_name nme)
+let name_of_string str = Name (Id.of_string str)
+let string_of_name nme = Id.to_string (id_of_name nme)
 
 (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
 let isVarf f x =
     match x with
-      | GVar (_,x) -> Pervasives.compare x f = 0
+      | GVar (_,x) -> Id.equal x f
       | _ -> false
 
 (** [ident_global_exist id] returns true if identifier [id] is linked
     in global environment. *)
 let ident_global_exist id =
   try
-    let ans = CRef (Libnames.Ident (dummy_loc,id)) in
-    let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
+    let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in
+    let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in
     true
   with e when Errors.noncritical e -> false
 
 (** [next_ident_fresh id] returns a fresh identifier (ie not linked in
     global env) with base [id]. *)
-let next_ident_fresh (id:identifier) =
+let next_ident_fresh (id:Id.t) =
     let res = ref id in
     while ident_global_exist !res do res := Nameops.lift_subscript !res done;
     !res
@@ -128,19 +131,15 @@ let prNamedRLDecl s lc =
     prstr "\n";
   end
 
-let showind (id:identifier) =
+let showind (id:Id.t) =
   let cstrid = Constrintern.global_reference id in
   let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
-  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
+  let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in
   List.iter (fun (nm, optcstr, tp) ->
     print_string (string_of_name nm^":");
     prconstr tp; print_string "\n")
     ib1.mind_arity_ctxt;
-  (match ib1.mind_arity with
-    | Monomorphic x ->
-        Printf.printf "arity :"; prconstr x.mind_user_arity
-    | Polymorphic x ->
-        Printf.printf "arity : universe?");
+    Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1);
   Array.iteri
     (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
     ib1.mind_user_lc
@@ -152,23 +151,15 @@ exception Found of int
 (* Array scanning *)
 
 let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
-    Array.length arr (* all elt are positive *)
-  with Found i -> i
-
-let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
-  let i = ref 0 in
-  Array.fold_left
-    (fun acc x ->
-      let res = f !i acc x in i := !i + 1; res)
-    acc arr
+match Array.findi pred arr with
+| None -> Array.length arr (* all elt are positive *)
+| Some i -> i
 
-(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
+(* Like List.chop but except that [i] is the size of the suffix of [l]. *)
 let list_chop_end i l =
   let size_prefix = List.length l -i in
   if size_prefix < 0 then failwith "list_chop_end"
-  else list_chop size_prefix l
+  else List.chop size_prefix l
 
 let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
   let i = ref 0 in
@@ -234,7 +225,7 @@ let linkmonad f lnkvar =
 let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
 
 (* This map is used to deal with debruijn linked indices. *)
-module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
+module Link = Map.Make (Int)
 
 let pr_links l =
   Printf.printf "links:\n";
@@ -254,7 +245,7 @@ type 'a merged_arg =
 
 type merge_infos =
     {
-      ident:identifier; (** new inductive name *)
+      ident:Id.t; (** new inductive name *)
       mib1: mutual_inductive_body;
       oib1: one_inductive_body;
       mib2: mutual_inductive_body;
@@ -357,17 +348,17 @@ let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
 
 (** {1 Utilities for merging} *)
 
-let ind1name = id_of_string "__ind1"
-let ind2name = id_of_string "__ind2"
+let ind1name = Id.of_string "__ind1"
+let ind2name = Id.of_string "__ind2"
 
 (** Performs verifications on two graphs before merging: they must not
     be co-inductive, and for the moment they must not be mutual
     either. *)
 let verify_inds mib1 mib2 =
-  if not mib1.mind_finite then error "First argument is coinductive";
-  if not mib2.mind_finite then error "Second argument is coinductive";
-  if mib1.mind_ntypes <> 1 then error "First argument is mutual";
-  if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
+  if mib1.mind_finite == Decl_kinds.CoFinite then error "First argument is coinductive";
+  if mib2.mind_finite == Decl_kinds.CoFinite then error "Second argument is coinductive";
+  if not (Int.equal mib1.mind_ntypes 1) then error "First argument is mutual";
+  if not (Int.equal mib2.mind_ntypes 1) then error "Second argument is mutual";
   ()
 
 (*
@@ -381,11 +372,11 @@ let build_raw_params prms_decl avoid =
   let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in
   let res,_ = glob_decompose_prod dummy_glob_constr in
   let comblist = List.combine prms_decl res in
-  comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr)))
+  comblist, res , (avoid @ (Id.Set.elements (ids_of_glob_constr dummy_glob_constr)))
 *)
 
 let ids_of_rawlist avoid rawl =
-    List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl)
+    List.fold_left Id.Set.union avoid (List.map ids_of_glob_constr rawl)
 
 
 
@@ -463,7 +454,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
       ([],[],[],[]) arity_ctxt in
 (*  let arity_ctxt2 =
     build_raw_params oib2.mind_arity_ctxt
-      (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
+      (Id.Set.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*)
   let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
   let _ = prstr "\n\n\n" in
   let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
@@ -514,16 +505,16 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable =
     | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
         let _ = prstr "\nICI1!\n";Pp.flush_all() in
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args)
+        GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args)
     | GApp(_,f1, arr1), GApp(_,f2,arr2)  -> raise NoMerge
     | GLetIn(_,nme,bdy,trm) , _ ->
         let _ = prstr "\nICI2!\n";Pp.flush_all() in
         let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3!\n";Pp.flush_all() in
         let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
            raise NoMerge
 
@@ -532,16 +523,16 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
   match c1 , c2 with
     | GApp(_,f1, arr1), GApp(_,f2,arr2) ->
         let args = filter_shift_stable lnk (arr1 @ arr2) in
-        GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args)
+        GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args)
           (* FIXME: what if the function appears in the body of the let? *)
     | GLetIn(_,nme,bdy,trm) , _ ->
         let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _, GLetIn(_,nme,bdy,trm) ->
         let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
         let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
-        GLetIn(dummy_loc,nme,bdy,newtrm)
+        GLetIn(Loc.ghost,nme,bdy,newtrm)
     | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
 
 
@@ -550,8 +541,8 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
    calls of branch 1 with all rec calls of branch 2. *)
 (* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
 let rec merge_rec_hyps shift accrec
-    (ltyp:(Names.name * glob_constr option * glob_constr option) list)
-    filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list =
+    (ltyp:(Name.t * glob_constr option * glob_constr option) list)
+    filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list =
   let mergeonehyp t reldecl =
     match reldecl with
       | (nme,x,Some (GApp(_,i,args) as ind))
@@ -567,11 +558,11 @@ let rec merge_rec_hyps shift accrec
     | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable
 
 
-let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift =
+let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift =
   List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
 
 
-let find_app (nme:identifier) ltyp =
+let find_app (nme:Id.t) ltyp =
   try
     ignore
       (List.map
@@ -591,9 +582,9 @@ let prnt_prod_or_letin nm letbdy typ =
 
 
 let rec merge_types shift accrec1
-    (ltyp1:(name * glob_constr option * glob_constr option) list)
-    (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2
-    : (name * glob_constr option * glob_constr option) list * glob_constr =
+    (ltyp1:(Name.t * glob_constr option * glob_constr option) list)
+    (concl1:glob_constr) (ltyp2:(Name.t * glob_constr option * glob_constr option) list) concl2
+    : (Name.t * glob_constr option * glob_constr option) list * glob_constr =
   let _ = prstr "MERGE_TYPES\n" in
   let _ = prstr "ltyp 1 : " in
   let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in
@@ -603,7 +594,7 @@ let rec merge_types shift accrec1
   let res =
     match ltyp1 with
       | [] ->
-          let isrec1 = (accrec1<>[]) in
+          let isrec1 = not (List.is_empty accrec1) in
           let isrec2 = find_app ind2name ltyp2 in
           let rechyps =
             if isrec1 && isrec2
@@ -657,22 +648,22 @@ let rec merge_types shift accrec1
     linked args [allargs2] to target args of [allargs1] as specified
     in [shift]. [allargs1] and [allargs2] are in reverse order.  Also
     returns the list of unlinked vars of [allargs2]. *)
-let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
+let build_link_map_aux (allargs1:Id.t array) (allargs2:Id.t array)
     (lnk:int merged_arg array) =
-  array_fold_lefti
+  Array.fold_left_i
     (fun i acc e ->
-      if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
+      if Int.equal i (Array.length lnk - 1) then acc (* functional arg, not in allargs *)
       else
         match e with
-          | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
+          | Prm_linked j | Arg_linked j -> Id.Map.add allargs2.(i) allargs1.(j) acc
           | _ -> acc)
-    Idmap.empty lnk
+    Id.Map.empty lnk
 
 let build_link_map allargs1 allargs2 lnk =
   let allargs1 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in
+    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs1) in
   let allargs2 =
-    Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
+    Array.of_list (List.rev_map (fun (x,_,_) -> id_of_name x) allargs2) in
   build_link_map_aux allargs1 allargs2 lnk
 
 
@@ -749,18 +740,18 @@ let fresh_cstror_suffix , cstror_suffix_init =
 (** [merge_constructor_id id1 id2 shift] returns the identifier of the
     new constructor from the id of the two merged constructor and
     the merging info. *)
-let merge_constructor_id id1 id2 shift:identifier =
-  let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
-  next_ident_fresh (id_of_string id)
+let merge_constructor_id id1 id2 shift:Id.t =
+  let id = Id.to_string shift.ident ^ "_" ^ fresh_cstror_suffix () in
+  next_ident_fresh (Id.of_string id)
 
 
 
 (** [merge_constructors lnk shift avoid] merges the two list of
     constructor [(name*type)]. These are translated to glob_constr
     first, each of them having distinct var names. *)
-let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
-    (typcstr1:(identifier * glob_constr) list)
-    (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list =
+let merge_constructors (shift:merge_infos) (avoid:Id.Set.t)
+    (typcstr1:(Id.t * glob_constr) list)
+    (typcstr2:(Id.t * glob_constr) list) : (Id.t * glob_constr) list =
   List.flatten
     (List.map
         (fun (id1,rawtyp1) ->
@@ -776,20 +767,20 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
 (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
     inductive bodies [oib1] and [oib2], linking with [lnk], params
     info in [shift], avoiding identifiers in [avoid]. *)
-let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
+let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
     (oib2:one_inductive_body) =
   (* building glob_constr type of constructors *)
   let mkrawcor nme avoid typ =
     (* first replace rel 1 by a varname *)
     let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in
-    Detyping.detype false (Idset.elements avoid) [] substindtyp in
+    Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in
   let lcstr1: glob_constr list =
     Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in
   (* add  to avoid all indentifiers of lcstr1 *)
-  let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in
+  let avoid2 = Id.Set.union avoid (ids_of_rawlist avoid lcstr1) in
   let lcstr2 =
     Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
-  let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
+  let avoid3 = Id.Set.union avoid (ids_of_rawlist avoid lcstr2) in
 
   let params1 =
     try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
@@ -810,14 +801,14 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
     [lnk]. [shift] information on parameters of the new inductive.
     For the moment, inductives are supposed to be non mutual.
 *)
-let rec merge_mutual_inductive_body
+let merge_mutual_inductive_body
     (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
   (* Mutual not treated, we take first ind body of each. *)
-  merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
+  merge_inductive_body shift Id.Set.empty mib1.mind_packets.(0) mib2.mind_packets.(0)
 
 
 let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *)
-  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x
+  Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Id.Set.empty) x
 
 let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
   let params = prms2 @ prms1 in
@@ -828,15 +819,15 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
         let _ = prNamedRConstr (string_of_name nme) tp in
         let _ = prstr "  ;  " in
         let typ = glob_constr_to_constr_expr tp in
-        LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc)
+        LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc)
       [] params in
-  let concl = Constrextern.extern_constr false (Global.env()) concl in
+  let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in
   let arity,_ =
     List.fold_left
       (fun (acc,env) (nm,_,c) ->
-        let typ = Constrextern.extern_constr false env c in
+        let typ = Constrextern.extern_constr false env Evd.empty c in
         let newenv = Environ.push_rel (nm,None,c) env in
-        CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
+        CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv)
       (concl,Global.env())
       (shift.funresprms2 @ shift.funresprms1
         @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
@@ -849,33 +840,22 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
     [rawlist], named ident.
     FIXME: params et cstr_expr (arity) *)
 let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
-    (rawlist:(identifier * glob_constr) list) =
-  let lident = dummy_loc, shift.ident in
+    (rawlist:(Id.t * glob_constr) list) =
+  let lident = Loc.ghost, shift.ident in
   let bindlist , cstr_expr = (* params , arities *)
     merge_rec_params_and_arity prms1 prms2 shift mkSet in
   let lcstor_expr : (bool * (lident * constr_expr)) list  =
     List.map (* zeta_normalize t ? *)
-      (fun (id,t) -> false, ((dummy_loc,id),glob_constr_to_constr_expr t))
+      (fun (id,t) -> false, ((Loc.ghost,id),glob_constr_to_constr_expr t))
       rawlist in
   lident , bindlist , Some cstr_expr , lcstor_expr
 
 
-
-let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
-  match rdecl with
-    | (nme,None,t) ->
-        let traw = Detyping.detype false [] [] t in
-        GProd (dummy_loc,nme,Explicit,traw,t2)
-    | (_,Some _,_) -> assert false
-
-
-
-
 let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
   match rdecl with
     | (nme,None,t) ->
-        let traw = Detyping.detype false [] [] t in
-        GProd (dummy_loc,nme,Explicit,traw,t2)
+        let traw = Detyping.detype false [] (Global.env()) Evd.empty t in
+        GProd (Loc.ghost,nme,Explicit,traw,t2)
     | (_,Some _,_) -> assert false
 
 
@@ -893,7 +873,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
   let _ = prstr "\nrawlist : " in
   let _ =
-    List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
+    List.iter (fun (nm,tp) -> prNamedRConstr (Id.to_string nm) tp;prstr "\n") rawlist in
   let _ = prstr "\nend rawlist\n" in
 (* FIX: retransformer en constr ici
    let shift_prm =
@@ -904,15 +884,16 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
   let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in
   (* Declare inductive *)
   let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in
-  let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in
+  let mie,impls = Command.interp_mutual_inductive indl [] 
+          false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in
   (* Declare the mutual inductive block with its associated schemes *)
-  ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls)
+  ignore (Command.declare_mutual_inductive_with_eliminations mie impls)
 
 
 (* Find infos on identifier id. *)
-let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
+let find_Function_infos_safe (id:Id.t): Indfun_common.function_info =
   let kn_of_id x =
-    let f_ref = Libnames.Ident (dummy_loc,x) in
+    let f_ref = Libnames.Ident (Loc.ghost,x) in
     locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref)
       locate_constant f_ref in
     try find_Function_infos (kn_of_id id)
@@ -927,8 +908,8 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
 
     Warning: For the moment, repetitions of an id in [args1] or
     [args2] are not supported. *)
-let merge (id1:identifier) (id2:identifier) (args1:identifier array)
-    (args2:identifier array) id : unit =
+let merge (id1:Id.t) (id2:Id.t) (args1:Id.t array)
+    (args2:Id.t array) id : unit =
   let finfo1 = find_Function_infos_safe id1 in
   let finfo2 = find_Function_infos_safe id2 in
   (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
@@ -938,7 +919,7 @@ let merge (id1:identifier) (id2:identifier) (args1:identifier array)
                  as above: vars may be linked inside args2?? *)
     Array.mapi
       (fun i c ->
-        match array_find_i (fun i x -> x=c) args1 with
+        match Array.findi (fun i x -> Id.equal x c) args1 with
           | Some j -> Linked j
           | None -> Unlinked)
       args2 in
@@ -955,7 +936,7 @@ let remove_last_arg c =
   let xnolast = List.rev (List.tl (List.rev x)) in
   compose_prod xnolast y
 
-let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l)
+let rec remove_n_fst_list n l = if Int.equal n 0 then l else remove_n_fst_list (n-1) (List.tl l)
 let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l))
 
 let remove_last_n_arg n c =
@@ -977,7 +958,7 @@ let funify_branches relinfo nfuns branch =
       | _ -> assert false in
   let is_dom c =
     match kind_of_term c with
-      | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct
+      | Ind(((u,_),_)) | Construct(((u,_),_),_) -> MutInd.equal u mut_induct
       | _ -> false in
   let _dom_i c =
     assert (is_dom c);
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index a33ae1d6..5558556e 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -1,59 +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 camlp4deps: "parsing/grammar.cma" i*)
-
 open Term
+open Vars
 open Namegen
 open Environ
-open Declarations
 open Entries
 open Pp
 open Names
 open Libnames
+open Globnames
 open Nameops
+open Errors
 open Util
-open Closure
-open RedFlags
 open Tacticals
-open Typing
 open Tacmach
 open Tactics
 open Nametab
-open Decls
 open Declare
 open Decl_kinds
 open Tacred
 open Proof_type
-open Vernacinterp
 open Pfedit
-open Topconstr
 open Glob_term
 open Pretyping
-open Pretyping.Default
-open Safe_typing
 open Constrintern
-open Hiddentac
+open Misctypes
+open Genredexpr
 
 open Equality
 open Auto
 open Eauto
 
-open Genarg
+open Indfun_common
 
 
-let compute_renamed_type gls c =
-  rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) []
-    (pf_type_of gls c)
 
-let qed () = Lemmas.save_named true
-let defined () = Lemmas.save_named false
+(* Ugly things which should not be here *)
+
+let coq_constant m s =
+  Coqlib.coq_constant "RecursiveDefinition" m s
+
+let arith_Nat = ["Arith";"PeanoNat";"Nat"]
+let arith_Lt = ["Arith";"Lt"]
+
+let coq_init_constant s =
+  Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s
+
+let find_reference sl s =
+  let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in
+  locate (make_qualid dp (Id.of_string s))
+
+let declare_fun f_id kind ?(ctx=Univ.UContext.empty) value =
+  let ce = definition_entry ~univs:ctx value (*FIXME *) in
+    ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
+
+let defined () = Lemmas.save_proof (Vernacexpr.Proved (false,None))
+
+let def_of_const t =
+   match (kind_of_term t) with
+    Const sp ->
+      (try (match constant_opt_value_in (Global.env ()) sp with
+             | Some c -> c
+	     | _ -> raise Not_found)
+       with Not_found ->
+	 anomaly (str "Cannot find definition of constant " ++
+		    (Id.print (Label.to_id (con_label (fst sp)))))
+      )
+     |_ -> assert false
+
+let type_of_const t =
+   match (kind_of_term t) with
+    Const sp -> Typeops.type_of_constant (Global.env()) sp
+    |_ -> assert false
+
+let constr_of_global x = 
+  fst (Universes.unsafe_constr_of_global x)
+
+let constant sl s = constr_of_global (find_reference sl s)
+
+let const_of_ref = function
+    ConstRef kn -> kn
+  | _ -> anomaly (Pp.str "ConstRef expected")
+
+
+let nf_zeta env =
+  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+    env
+    Evd.empty
+
+
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
+  let clos_norm_flags flgs env sigma t =
+    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
+  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
+
 
+
+
+
+
+(* Generic values *)
 let pf_get_new_ids idl g =
   let ids = pf_ids_of_hyps g in
   List.fold_right
@@ -61,14 +113,98 @@ let pf_get_new_ids idl g =
     idl
     []
 
-let pf_get_new_id id g =
-  List.hd (pf_get_new_ids [id] g)
+let compute_renamed_type gls c =
+  rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) []
+    (pf_type_of gls c)
+let h'_id = Id.of_string "h'"
+let teq_id = Id.of_string "teq"
+let ano_id = Id.of_string "anonymous"
+let x_id = Id.of_string "x"
+let k_id = Id.of_string "k"
+let v_id = Id.of_string "v"
+let def_id = Id.of_string "def"
+let p_id = Id.of_string "p"
+let rec_res_id = Id.of_string "rec_res";;
+let lt = function () -> (coq_init_constant "lt")
+let le = function () -> (coq_init_constant "le")
+let ex = function () -> (coq_init_constant "ex")
+let nat = function () -> (coq_init_constant "nat")
+let iter_ref () =  
+  try find_reference ["Recdef"] "iter" 
+  with Not_found -> error "module Recdef not loaded"
+let iter = function () -> (constr_of_global (delayed_force iter_ref))
+let eq = function () -> (coq_init_constant "eq")
+let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
+let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm")
+let le_trans = function () -> (coq_constant arith_Nat "le_trans")
+let le_lt_trans = function () -> (coq_constant arith_Nat "le_lt_trans")
+let lt_S_n = function () -> (coq_constant arith_Lt "lt_S_n")
+let le_n = function () -> (coq_init_constant "le_n")
+let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
+let coq_O = function () -> (coq_init_constant "O")
+let coq_S = function () -> (coq_init_constant "S")
+let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r")
+let max_ref = function () -> (find_reference ["Recdef"] "max")
+let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj"
+
+let f_S t = mkApp(delayed_force coq_S, [|t|]);;
 
-let h_intros l =
-  tclMAP h_intro l
+let rec n_x_id ids n =
+  if Int.equal n 0 then []
+  else let x = next_ident_away_in_goal x_id ids in
+          x::n_x_id (x::ids) (n-1);;
 
-let debug_queue = Stack.create ()
 
+let simpl_iter clause =
+  reduce
+    (Lazy
+       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
+    clause
+
+(* Others ugly things ... *)
+let (value_f:constr list -> global_reference -> constr) =
+  fun al fterm ->
+    let d0 = Loc.ghost in
+    let rev_x_id_l =
+      (
+	List.fold_left
+	  (fun x_id_l _ ->
+	     let x_id = next_ident_away_in_goal x_id x_id_l in
+	     x_id::x_id_l
+	  )
+	  []
+	  al
+      )
+    in
+    let context = List.map
+      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
+    in
+    let env = Environ.push_rel_context context (Global.env ()) in
+    let glob_body =
+      GCases
+	(d0,RegularStyle,None,
+	 [GApp(d0, GRef(d0,fterm,None), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
+	  (Anonymous,None)],
+	 [d0, [v_id], [PatCstr(d0,(destIndRef
+				     (delayed_force coq_sig_ref),1),
+			       [PatVar(d0, Name v_id);
+				PatVar(d0, Anonymous)],
+			       Anonymous)],
+	  GVar(d0,v_id)])
+    in
+    let body = fst (understand env Evd.empty glob_body)(*FIXME*) in
+    it_mkLambda_or_LetIn body context
+
+let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) =
+  fun f_id kind input_type fterm_ref ->
+    declare_fun f_id kind (value_f input_type fterm_ref);;
+
+
+
+(* Debuging mechanism *)
+let debug_queue = Stack.create ()
 
 let rec print_debug_queue b e = 
   if  not (Stack.is_empty debug_queue) 
@@ -76,267 +212,445 @@ let rec print_debug_queue b e =
     begin
       let lmsg,goal = Stack.pop debug_queue in 
       if b then 
-	msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+	Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
       else
 	begin
-	  msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+	  Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
 	end;
       print_debug_queue false e;
     end
 
-  
+let observe strm =
+  if do_observe ()
+  then Pp.msg_debug strm
+  else ()
+
 
 let do_observe_tac s tac g = 
   let goal = Printer.pr_goal g in
-  let lmsg = (str "recdef : ") ++ (str s) in 
+  let lmsg = (str "recdef : ") ++ s in 
+  observe (s++fnl());
   Stack.push (lmsg,goal) debug_queue;
   try 
     let v = tac g in 
     ignore(Stack.pop debug_queue);
     v
   with reraise ->
+    let reraise = Errors.push reraise in
     if not (Stack.is_empty debug_queue)
-    then
-      print_debug_queue true reraise;
-    raise reraise
+    then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+    iraise reraise
 
 let observe_tac s tac g =
-  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+  if do_observe ()
   then do_observe_tac s tac g
   else tac g
 
-let hyp_ids = List.map id_of_string
-    ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
-     "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];;
-
-let rec nthtl = function
-    l, 0 -> l  | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
-
-let hyp_id n l = List.nth l n;;
-
-let (x_id:identifier) = hyp_id 0 hyp_ids;;
-let (v_id:identifier) = hyp_id 1 hyp_ids;;
-let (k_id:identifier) = hyp_id 2 hyp_ids;;
-let (def_id:identifier) = hyp_id 3 hyp_ids;;
-let (p_id:identifier) = hyp_id 4 hyp_ids;;
-let (h_id:identifier) = hyp_id 5 hyp_ids;;
-let (n_id:identifier) = hyp_id 6 hyp_ids;;
-let (h'_id:identifier) = hyp_id 7 hyp_ids;;
-let (ano_id:identifier) = hyp_id 8 hyp_ids;;
-let (rec_res_id:identifier) = hyp_id 10 hyp_ids;;
-let (hspec_id:identifier) = hyp_id 11 hyp_ids;;
-let (heq_id:identifier) = hyp_id 12 hyp_ids;;
-let (hrec_id:identifier) = hyp_id 13 hyp_ids;;
-let (hex_id:identifier) = hyp_id 14 hyp_ids;;
-let (teq_id:identifier) = hyp_id 15 hyp_ids;;
-let (pmax_id:identifier) = hyp_id 16 hyp_ids;;
-let (hle_id:identifier) = hyp_id 17 hyp_ids;;
-
-let message s = if Flags.is_verbose () then msgnl(str s);;
+(* Conclusion tactics *)
 
-let def_of_const t =
-   match (kind_of_term t) with
-    Const sp ->
-      (try (match body_of_constant (Global.lookup_constant sp) with
-             | Some c -> Declarations.force c
-	     | _ -> assert false)
-       with e when Errors.noncritical e ->
-	 anomaly ("Cannot find definition of constant "^
-		    (string_of_id (id_of_label (con_label sp))))
-      )
-     |_ -> assert false
+(* The boolean value is_mes expresses that the termination is expressed
+  using a measure function instead of a well-founded relation. *)
+let tclUSER tac is_mes l g =
+  let clear_tac =
+    match l with
+      | None -> clear []
+      | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l)
+  in
+  tclTHENLIST
+    [
+      clear_tac;
+      if is_mes
+      then tclTHENLIST
+        [
+	  unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
+            (delayed_force Indfun_common.ltof_ref))];
+         tac
+	 ]
+      else tac
+    ]
+    g
 
-let type_of_const t =
-   match (kind_of_term t) with
-    Const sp -> Typeops.type_of_constant (Global.env()) sp
-    |_ -> assert false
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
+  if is_mes
+  then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl)
+  else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress)
+
+
+
+  
 
-let arg_type t =
-  match kind_of_term (def_of_const t) with
-      Lambda(a,b,c) -> b
-    | _ -> assert false;;
-
-let evaluable_of_global_reference r =
-  match r with
-      ConstRef sp -> EvalConstRef sp
-    | VarRef id -> EvalVarRef id
-    | _ -> assert false;;
-
-
-let rank_for_arg_list h =
-  let predicate a b =
-      try List.for_all2 eq_constr a b with
-        Invalid_argument _ -> false in
-  let rec rank_aux i = function
-  | [] -> None
-  | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
-  rank_aux 0;;
-
-let rec check_not_nested f t = 
-  match kind_of_term t with 
-    | App(g, _) when eq_constr f g -> 
-	errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
-    | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function")
-    | _ -> iter_constr (check_not_nested f) t 
-
-
-
-
-let rec (find_call_occs : int -> int -> constr -> constr ->
-  (constr list -> constr) * constr list list) =
- fun nb_arg nb_lam f expr ->
-  match (kind_of_term expr) with
-    App (g, args) when eq_constr g f ->
-      if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function");
-      Array.iter (check_not_nested f) args;
-      (fun l -> List.hd l), [Array.to_list args]
-  | App (g, args) ->
-     let (largs: constr list) = Array.to_list args in
-     let rec find_aux = function
-	 []    -> (fun x -> []), []
-       | a::upper_tl ->
-         (match find_aux upper_tl with
-          (cf, ((arg1::args) as args_for_upper_tl)) ->
-           (match find_call_occs nb_arg nb_lam f a with
-             cf2, (_ :: _ as other_args) ->
-               let rec avoid_duplicates args =
-                  match args with
-                  | [] -> (fun _ -> []), []
-                  | h::tl ->
-                      let recomb_tl, args_for_tl =
-                          avoid_duplicates tl in
-                    match rank_for_arg_list h args_for_upper_tl with
-                    | None ->
-                        (fun l -> List.hd l::recomb_tl(List.tl l)),
-                        h::args_for_tl
-                    | Some i ->
-                        (fun l -> List.nth l (i+List.length args_for_tl)::
-                            recomb_tl l),
-                        args_for_tl
-               in
-               let recombine, other_args' =
-                   avoid_duplicates other_args in
-	       let len1 = List.length other_args' in
-                   (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
-                     other_args'@args_for_upper_tl
-           | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
-	 | _, [] ->
-	   (match find_call_occs nb_arg nb_lam f a with
-	     cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
-	   | _, [] -> (fun x -> a::upper_tl), [])) in
-     begin
-       match (find_aux largs) with
-	   cf, [] -> (fun l -> mkApp(g, args)), []
-	 | cf, args ->
-	     (fun l -> mkApp (g, Array.of_list (cf l))), args
-     end
-  | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[])
-  | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function")
-  | Var(id) -> (fun l -> expr), []
-  | Meta(_) -> error "Found a metavariable. Can not treat such a term" 
-  | Evar(_) -> error "Found an evar. Can not treat such a term"
-  | Sort(_)  -> (fun l -> expr), []
-  | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b
-  | Prod(na,t,b) -> 
-    error "Found a product. Can not treat such a term"
-  | Lambda(na,t,b) ->
+(* Travelling term.
+   Both definitions of [f_terminate] and [f_equation] use the same generic 
+   travelling mechanism.
+*)
+
+(* [check_not_nested forbidden e] checks that [e] does not contains any variable 
+   of [forbidden]
+*)
+let check_not_nested forbidden e =
+  let rec check_not_nested e =  
+    match kind_of_term e with 
+      | Rel _ -> ()
+      | Var x ->
+        if Id.List.mem x forbidden
+        then error ("check_not_nested : failure "^Id.to_string x)
+      | Meta _ | Evar _ | Sort _ -> ()
+      | Cast(e,_,t) -> check_not_nested e;check_not_nested t
+      | Prod(_,t,b) -> check_not_nested t;check_not_nested b
+      | Lambda(_,t,b) -> check_not_nested t;check_not_nested b
+      | LetIn(_,v,t,b) -> check_not_nested t;check_not_nested b;check_not_nested v
+      | App(f,l) -> check_not_nested f;Array.iter check_not_nested l
+      | Proj (p,c) -> check_not_nested c
+      | Const _ -> ()
+      | Ind _ -> ()
+      | Construct _ -> ()
+      | Case(_,t,e,a) -> 
+	check_not_nested t;check_not_nested e;Array.iter check_not_nested a
+      | Fix _ -> error "check_not_nested : Fix"
+      | CoFix _ -> error "check_not_nested : Fix"
+  in
+  try 
+    check_not_nested e 
+  with UserError(_,p) -> 
+    errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p)
+
+(* ['a info] contains the local information for travelling *)
+type 'a infos = 
+    { nb_arg : int; (* function number of arguments *)
+      concl_tac : tactic; (* final tactic to finish proofs *)
+      rec_arg_id : Id.t; (*name of the declared recursive argument *)
+      is_mes : bool; (* type of recursion *)
+      ih : Id.t; (* induction hypothesis name *)
+      f_id : Id.t;  (* function name *)
+      f_constr : constr;  (* function term *)
+      f_terminate : constr; (* termination proof term *)
+      func : global_reference; (* functionnal reference *)
+      info : 'a;
+      is_main_branch : bool; (* on the main branch or on a matched expression *)
+      is_final : bool; (* final first order term or not *)
+      values_and_bounds : (Id.t*Id.t) list; 
+      eqs : Id.t list; 
+      forbidden_ids : Id.t list;
+      acc_inv : constr lazy_t;
+      acc_id : Id.t;
+      args_assoc : ((constr list)*constr) list;
+    }
+
+
+type ('a,'b) journey_info_tac = 
+    'a -> (* the arguments of the constructor *)
+    'b infos -> (* infos of the caller *)
+    ('b infos -> tactic) -> (* the continuation tactic of the caller *)
+    'b infos -> (* argument of the tactic *)
+    tactic
+       
+(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term
+*)
+type journey_info = 
+    { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac;
+      lambdA : ((Name.t*types*constr),constr) journey_info_tac;
+      casE : ((constr infos -> tactic) -> constr infos -> tactic) -> 
+	((case_info * constr * constr * constr array),constr) journey_info_tac;
+      otherS : (unit,constr) journey_info_tac;
+      apP : (constr*(constr list),constr) journey_info_tac;
+      app_reC : (constr*(constr list),constr) journey_info_tac;
+      message : string
+    }
+
+	       
+
+let rec add_vars forbidden e = 
+  match kind_of_term e with 
+    | Var x -> x::forbidden 
+    | _ -> fold_constr add_vars forbidden e 
+
+
+let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = 
+  fun g -> 
+    let rev_context,b = decompose_lam_n nb_lam e in 
+    let ids = List.fold_left (fun acc (na,_) -> 	
+      let pre_id = 
+	match na with 
+	  | Name x -> x 
+	  | Anonymous -> ano_id 
+      in
+      pre_id::acc
+    ) [] rev_context in 
+    let rev_ids = pf_get_new_ids (List.rev ids) g in 
+    let new_b = substl (List.map mkVar rev_ids) b in 
+    tclTHENLIST 
+      [
+	h_intros (List.rev rev_ids);
+	Proofview.V82.of_tactic (intro_using teq_id);
+	onLastHypId (fun heq -> 
+	  tclTHENLIST[
+	    thin to_intros;
+	    h_intros to_intros;
+	    (fun g' -> 
+	      let ty_teq = pf_type_of g' (mkVar heq) in
+	      let teq_lhs,teq_rhs =
+		let _,args = try destApp ty_teq with DestKO -> assert false in
+		args.(1),args.(2)
+	      in
+	      let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in 
+	      let new_infos = {
+		infos with 
+		  info = new_b';
+		  eqs = heq::infos.eqs;
+		  forbidden_ids = 
+		  if forbid_new_ids 
+		  then add_vars infos.forbidden_ids new_b'
+		  else infos.forbidden_ids
+	      } in 
+	      finalize_tac new_infos g' 
+	    )
+	  ]
+	)
+      ] g
+
+let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
+  match kind_of_term expr_info.info with 
+    | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint"
+    | Proj _ -> error "Function cannot treat projections"
+    | LetIn(na,b,t,e) -> 
       begin
-	match find_call_occs nb_arg (succ nb_lam) f b with
-	  | _, [] ->  (* Lambda are authorized as long as they do not contain
-			 recursives calls *)
-	      (fun l -> expr),[]
-	  | _ ->  error "Found a lambda which body contains a recursive call. Such terms are not allowed"
+	let new_continuation_tac = 
+	  jinfo.letiN (na,b,t,e) expr_info continuation_tac
+	in
+	travel jinfo new_continuation_tac 
+	  {expr_info with info = b; is_final=false}
       end
-  | LetIn(na,v,t,b) ->
+    | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !")
+    | Prod _ -> 
       begin
-	match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with
-	  | (_,[]),(_,[]) ->
-	      ((fun l -> expr), [])
-	  | (_,[]),(cf,(_::_ as l)) ->
-	      ((fun  l -> mkLetIn(na,v,t,cf l)),l)
-	  | (cf,(_::_ as l)),(_,[]) ->
-	      ((fun l -> mkLetIn(na,cf l,t,b)), l)
-	  | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed."
+	try
+	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info
+	with e when Errors.noncritical e ->
+	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
       end
-  | Const(_) -> (fun l -> expr), []
-  | Ind(_) -> (fun l -> expr), []
-  | Construct (_, _) -> (fun l -> expr), []
-  | Case(i,t,a,r) ->
-      (match find_call_occs nb_arg nb_lam f a with
-	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
-      | _ -> (fun l -> expr),[])
-  | Fix(_) -> error "Found a local fixpoint. Can not treat such a term"
-  | CoFix(_) -> error "Found a local cofixpoint : CoFix";;
-
-let coq_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition"
-    (Coqlib.init_modules @ Coqlib.arith_modules) s;;
-
-let coq_base_constant s =
-  Coqlib.gen_constant_in_modules "RecursiveDefinition"
-    (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;;
-
-let constant sl s =
-  constr_of_global
-    (locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+    | Lambda(n,t,b) -> 
+      begin
+	try
+	  check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
+	  jinfo.otherS () expr_info continuation_tac expr_info
+	with e when Errors.noncritical e ->
+	  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
+      end
+    | Case(ci,t,a,l) -> 
+      begin
+	let continuation_tac_a = 
+	  jinfo.casE 
+	    (travel jinfo) (ci,t,a,l) 
+	    expr_info continuation_tac in 
+	travel 
+	  jinfo continuation_tac_a 
+	  {expr_info with info = a; is_main_branch = false; 
+	    is_final = false}
+      end
+    | App _ -> 
+      let f,args = decompose_app expr_info.info in 
+      if eq_constr f (expr_info.f_constr) 
+      then jinfo.app_reC (f,args) expr_info continuation_tac expr_info 
+      else
+      begin
+	match kind_of_term f with 
+	  | App _ -> assert false (* f is coming from a decompose_app *)
+	  | Const _ | Construct _ | Rel _ | Evar _ | Meta _  | Ind _ 
+	  | Sort _ | Prod _ | Var _ -> 
+	    let new_infos = {expr_info with info=(f,args)} in 
+	    let new_continuation_tac = 
+	      jinfo.apP (f,args) expr_info continuation_tac in 
+	    travel_args jinfo
+	      expr_info.is_main_branch new_continuation_tac new_infos
+	  | Case _ ->  errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)")
+	  | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info)
+      end
+    | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t}
+    | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
+      let new_continuation_tac = 
+	jinfo.otherS () expr_info continuation_tac in
+      new_continuation_tac expr_info
+and travel_args jinfo is_final continuation_tac infos = 
+  let (f_args',args) = infos.info in 
+  match args with 
+    | [] -> 
+      continuation_tac {infos with info = f_args'; is_final = is_final}
+    | arg::args' -> 
+      let new_continuation_tac new_infos = 
+	let new_arg = new_infos.info in 
+	travel_args jinfo is_final
+	  continuation_tac
+	  {new_infos with info = (mkApp(f_args',[|new_arg|]),args')}
+      in
+      travel jinfo new_continuation_tac 
+	{infos with info=arg;is_final=false} 
+and travel jinfo continuation_tac expr_info = 
+  observe_tac 
+    (str jinfo.message ++ Printer.pr_lconstr expr_info.info) 
+    (travel_aux jinfo continuation_tac expr_info)
 
-let find_reference sl s =
-    (locate (make_qualid(Names.make_dirpath
-			   (List.map id_of_string (List.rev sl)))
-	       (id_of_string s)));;
+(* Termination proof *) 
 
-let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
-let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm")
-
-let le_trans = function () -> (coq_base_constant "le_trans")
-let le_lt_trans = function () -> (coq_base_constant "le_lt_trans")
-let lt_S_n = function () -> (coq_base_constant "lt_S_n")
-let le_n = function () -> (coq_base_constant "le_n")
-let refl_equal = function () -> (coq_base_constant "eq_refl")
-let eq = function () -> (coq_base_constant "eq")
-let ex = function () -> (coq_base_constant "ex")
-let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
-let coq_sig = function () -> (coq_base_constant "sig")
-let coq_O = function () -> (coq_base_constant "O")
-let coq_S = function () -> (coq_base_constant "S")
-
-let gt_antirefl = function () -> (coq_constant "gt_irrefl")
-let lt_n_O = function () -> (coq_base_constant "lt_n_O")
-let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn")
-
-let f_equal = function () -> (coq_constant "f_equal")
-let well_founded_induction = function () -> (coq_constant "well_founded_induction")
-let well_founded = function () -> (coq_constant "well_founded")
-let acc_rel = function () -> (coq_constant "Acc")
-let acc_inv_id = function () -> (coq_constant "Acc_inv")
-let well_founded_ltof = function () ->  (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
-let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded")
-let max_ref = function () -> (find_reference ["Recdef"] "max")
-let iter = function () -> (constr_of_global (delayed_force iter_ref))
-let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+let rec prove_lt hyple g = 
+  begin
+    try
+      let (varx,varz) = match decompose_app (pf_concl g) with
+        | _, x::z::_ when isVar x && isVar z -> x, z
+        | _ -> assert false
+      in
+      let h =
+	List.find (fun id ->
+          match decompose_app (pf_type_of g (mkVar id)) with
+            | _, t::_ -> eq_constr t varx
+            | _ -> false
+	) hyple
+      in
+      let y =
+	List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in
+      tclTHENLIST[
+	Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])));
+	observe_tac (str "prove_lt") (prove_lt hyple)
+      ]
+    with Not_found -> 
+      (
+	(
+	  tclTHENLIST[
+	    Proofview.V82.of_tactic (apply (delayed_force lt_S_n));
+	    (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption))
+	  ])
+      )
+  end
+    g
+
+let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = 
+  match lbounds with 
+    | [] -> 
+      let ids = pf_ids_of_hyps g in 
+      let s_max = mkApp(delayed_force coq_S, [|bound|]) in 
+      let k = next_ident_away_in_goal k_id ids in
+      let ids = k::ids in
+      let h' = next_ident_away_in_goal (h'_id) ids in
+      let ids = h'::ids in
+      let def = next_ident_away_in_goal def_id ids in
+      tclTHENLIST[
+	Proofview.V82.of_tactic (split (ImplicitBindings [s_max]));
+	Proofview.V82.of_tactic (intro_then
+	  (fun id -> 
+            Proofview.V82.tactic begin
+	    observe_tac (str "destruct_bounds_aux") 
+	      (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id)))
+		 [
+		   tclTHENLIST[Proofview.V82.of_tactic (intro_using h_id);
+			       Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])));
+			       Proofview.V82.of_tactic default_full_auto];
+		   tclTHENLIST[
+		     observe_tac (str "clearing k ") (clear [id]);
+		     h_intros [k;h';def];
+		     observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl);
+		     observe_tac (str "unfold functional")
+		       (unfold_in_concl[(Locus.OnlyOccurrences [1],
+					 evaluable_of_global_reference infos.func)]);
+		     observe_tac (str "test" ) (
+		       tclTHENLIST[
+			 list_rewrite true
+			   (List.fold_right 
+			      (fun e acc -> (mkVar e,true)::acc)
+			      infos.eqs
+			      (List.map (fun e -> (e,true)) rechyps)
+			   );
+		      (* list_rewrite true *)
+		      (*   (List.map (fun e -> (mkVar e,true)) infos.eqs) *)
+		      (*   ; *)
+			 
+			 (observe_tac (str "finishing") 
+			    (tclORELSE
+			       (Proofview.V82.of_tactic intros_reflexivity)
+			       (observe_tac (str "calling prove_lt") (prove_lt hyple))))])
+		   ]
+	      ]
+	      )end))
+	  ] g
+      | (_,v_bound)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_elim (mkVar v_bound));
+	clear [v_bound];
+	tclDO 2 (Proofview.V82.of_tactic intro);
+	onNthHypId 1 
+	  (fun p_hyp -> 
+	    (onNthHypId 2 
+	       (fun p ->  
+		 tclTHENLIST[
+		   Proofview.V82.of_tactic (simplest_elim 
+		     (mkApp(delayed_force max_constr, [| bound; mkVar p|])));
+		   tclDO 3 (Proofview.V82.of_tactic intro);
+		   onNLastHypsId 3 (fun lids -> 
+		     match lids with
+		       [hle2;hle1;pmax] -> 
+			 destruct_bounds_aux infos 
+			   ((mkVar pmax),
+			    hle1::hle2::hyple,(mkVar p_hyp)::rechyps) 
+			   l 
+		       | _ -> assert false) ;
+		 ]
+	       )
+	    )
+	  )
+      ] g
+
+let destruct_bounds infos = 
+  destruct_bounds_aux infos (delayed_force coq_O,[],[]) infos.values_and_bounds
+
+let terminate_app f_and_args expr_info continuation_tac infos = 
+    if expr_info.is_final && expr_info.is_main_branch 
+    then 
+      tclTHENLIST[
+	continuation_tac infos;
+	observe_tac (str "first split") 
+	  (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info])));
+	observe_tac (str "destruct_bounds (1)") (destruct_bounds infos)
+      ]
+    else continuation_tac infos
+
+let terminate_others _ expr_info continuation_tac infos = 
+  if expr_info.is_final && expr_info.is_main_branch 
+  then 
+    tclTHENLIST[
+	    continuation_tac infos;
+      observe_tac (str "first split") 
+	(Proofview.V82.of_tactic (split (ImplicitBindings [infos.info])));
+      observe_tac (str "destruct_bounds") (destruct_bounds infos)
+    ]
+  else continuation_tac infos
+
+let terminate_letin (na,b,t,e) expr_info continuation_tac info = 
+  let new_e = subst1 info.info e in 
+  let new_forbidden = 
+    let forbid = 
+      try 
+	check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b;
+	true
+      with e when Errors.noncritical e -> false
+    in
+    if forbid 
+    then 
+      match na with
+	| Anonymous -> info.forbidden_ids
+	| Name id -> id::info.forbidden_ids
+    else info.forbidden_ids 
+  in
+  continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} 
+
+let pf_type c tac gl = 
+  let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in
+    tclTHEN (Refiner.tclEVARS evars) (tac ty) gl
 
-let ltof_ref = function  () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
-let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
-
-(* These are specific to experiments in nat with lt as well_founded_relation, *)
-(*    but this should be made more general. *)
-let nat = function () -> (coq_base_constant "nat")
-let lt = function () -> (coq_base_constant "lt")
-
-(* This is simply an implementation of the case_eq tactic.  this code
-  should be replaced with the tactic defined in Ltac in Init/Tactics.v *)
-let  mkCaseEq a  : tactic =
-     (fun g ->
-       let type_of_a = pf_type_of g a in
-       tclTHENLIST
-         [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
-          (fun g2 ->
-	    change_in_concl None
-	     (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
-		  g2);
-	  simplest_case a] g);;
+let pf_typel l tac =
+  let rec aux tys l =
+    match l with
+    | [] -> tac (List.rev tys)
+    | hd :: tl -> pf_type hd (fun ty -> aux (ty::tys) tl)
+  in aux [] l
 
 (* This is like the previous one except that it also rewrite on all
   hypotheses except the ones given in the first argument.  All the
@@ -344,390 +658,355 @@ let  mkCaseEq a  : tactic =
   introduced back later; the result is the pair of the tactic and the
   list of hypotheses that have been generalized and cleared. *)
 let mkDestructEq :
-  identifier list -> constr -> goal sigma -> tactic * identifier list =
+  Id.t list -> constr -> goal sigma -> tactic * Id.t list =
   fun not_on_hyp expr g ->
   let hyps = pf_hyps g in
   let to_revert =
-    Util.map_succeed
-      (fun (id,_,t) ->
-        if List.mem id not_on_hyp || not (Termops.occur_term expr t)
-        then failwith "is_expr_context";
-        id) hyps in
+    Util.List.map_filter
+      (fun (id, _, t) ->
+        if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t)
+        then None else Some id) hyps in
   let to_revert_constr = List.rev_map mkVar to_revert in
   let type_of_expr = pf_type_of g expr in
-  let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
+  let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::
            to_revert_constr in
+    pf_typel new_hyps (fun _ ->
     tclTHENLIST
-     [h_generalize new_hyps;
+     [Simple.generalize new_hyps;
       (fun g2 ->
-	change_in_concl None
-	  (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
-      simplest_case expr], to_revert
-
-let rec  mk_intros_and_continue thin_intros (extra_eqn:bool)
-    cont_function (eqs:constr list) nb_lam (expr:constr) g =
-  observe_tac "mk_intros_and_continue" (
-  let finalize () =  	if extra_eqn then
-	  let teq = pf_get_new_id teq_id g in
-	    tclTHENLIST
-	      [ h_intro teq;
-		thin thin_intros;
-		h_intros thin_intros;
-
-		tclMAP
-		  (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false))
-		  (List.rev eqs);
-		(fun g1 ->
-		   let ty_teq = pf_type_of g1 (mkVar teq) in
-		   let teq_lhs,teq_rhs =
-		     let _,args =
-                       try destApp ty_teq
-                       with e when Errors.noncritical e ->
-                         Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false
-                     in
-		     args.(1),args.(2)
-		   in
-	           cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1
-		)
-	      ]
-	      
-	else
-	  tclTHENSEQ[
-	    thin thin_intros;
-	    h_intros thin_intros;
-	    cont_function eqs expr
-	  ] 
-  in
-  if nb_lam = 0
-  then finalize ()
-  else
-    match kind_of_term expr with
-      | Lambda (n, _, b) ->
-     	  let n1 =
-	    match n with
-      		Name x -> x
-              | Anonymous -> ano_id
-	  in
-     	  let new_n = pf_get_new_id n1 g in
-	  tclTHEN (h_intro new_n)
-	    (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
-	       (pred nb_lam) (subst1 (mkVar new_n) b)) 
-      | _ ->
-	  assert false) g
-(* 	  finalize () *)
-let const_of_ref = function
-    ConstRef kn -> kn
-  | _ -> anomaly "ConstRef expected"
+	Proofview.V82.of_tactic (change_in_concl None
+	  (fun sigma ->
+	    pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2);
+      Proofview.V82.of_tactic (simplest_case expr)]), to_revert
 
-let simpl_iter clause =
-  reduce
-    (Lazy
-       {rBeta=true;rIota=true;rZeta= true; rDelta=false;
-        rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
-(*     (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *)
-    clause
 
-(* The boolean value is_mes expresses that the termination is expressed
-  using a measure function instead of a well-founded relation. *)
-let tclUSER tac is_mes l g =
-  let clear_tac =
-    match l with
-      | None -> h_clear true []
-      | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
+let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
+  let b =
+    try
+      check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a;
+      false
+    with e when Errors.noncritical e ->
+      true
   in
-  tclTHENSEQ
-    [
-      clear_tac;
-      if is_mes
-      then tclTHEN
-             (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference
-                                      (delayed_force ltof_ref))])
-             tac
-      else tac
-    ]
+  let a' = infos.info in
+  let new_info =
+    {infos with
+      info = mkCase(ci,t,a',l);
+      is_main_branch = expr_info.is_main_branch;
+      is_final = expr_info.is_final} in
+  let destruct_tac,rev_to_thin_intro = 
+    mkDestructEq [expr_info.rec_arg_id] a' g in 
+  let to_thin_intro = List.rev rev_to_thin_intro in 
+  observe_tac (str "treating case " ++ int (Array.length l) ++ spc () ++ Printer.pr_lconstr a') 
+    (try
+      (tclTHENS
+	 destruct_tac
+	 (List.map_i (fun i e -> observe_tac (str "do treat case") (treat_case b to_thin_intro (next_step continuation_tac) ci.ci_cstr_ndecls.(i) e new_info)) 0 (Array.to_list l)
+	 ))
+    with 
+      | UserError("Refiner.thensn_tac3",_) 
+      | UserError("Refiner.tclFAIL_s",_) ->
+	(observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} )
+	))
     g
+    
+let terminate_app_rec (f,args) expr_info continuation_tac _ = 
+  List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids))
+    args;
+  begin
+    try 
+      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let new_infos = {expr_info with info = v} in 
+      tclTHENLIST[
+	continuation_tac new_infos;
+	if expr_info.is_final && expr_info.is_main_branch 
+	then
+	  tclTHENLIST[ 
+	    observe_tac (str "first split")
+	      (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info])));
+	    observe_tac (str "destruct_bounds (3)")
+	      (destruct_bounds new_infos)
+	  ]
+	else
+	  tclIDTAC			       
+      ]    
+    with Not_found -> 
+      observe_tac (str "terminate_app_rec not found") (tclTHENS
+	(Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args))))
+	[		
+	  tclTHENLIST[
+	    Proofview.V82.of_tactic (intro_using rec_res_id);
+	    Proofview.V82.of_tactic intro;
+	    onNthHypId 1 
+	      (fun v_bound -> 
+		(onNthHypId 2 
+		   (fun v ->  
+		     let new_infos = { expr_info with 
+		       info = (mkVar v); 
+		       values_and_bounds = 
+			 (v,v_bound)::expr_info.values_and_bounds; 
+		       args_assoc=(args,mkVar v)::expr_info.args_assoc
+		     } in
+		     tclTHENLIST[
+		       continuation_tac new_infos;
+		       if expr_info.is_final && expr_info.is_main_branch 
+		       then
+			 tclTHENLIST[ 
+			   observe_tac (str "first split") 
+			     (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info])));
+			   observe_tac (str "destruct_bounds (2)") 
+			     (destruct_bounds new_infos)
+			 ]
+		       else
+			 tclIDTAC			       
+		     ]    
+		   )
+		)
+	      )
+	  ];
+	  observe_tac (str "proving decreasing") (
+	    tclTHENS (* proof of args < formal args *)
+	      (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv)))
+	      [ 
+		observe_tac (str "assumption") (Proofview.V82.of_tactic assumption);
+		tclTHENLIST
+		  [
+		    tclTRY(list_rewrite true 
+			     (List.map 
+				(fun e -> mkVar e,true) 
+				expr_info.eqs
+			     )
+		    );
+		    tclUSER expr_info.concl_tac true 
+		      (Some (
+		      expr_info.ih::expr_info.acc_id::
+			(fun (x,y) -> y) 
+			(List.split expr_info.values_and_bounds)
+		       )
+		      );
+		  ]
+	      ])
+	])
+  end
 
+let terminate_info = 
+  { message = "prove_terminate with term ";
+    letiN = terminate_letin;
+    lambdA = (fun _ _ _ _ -> assert false);
+    casE = terminate_case;
+    otherS = terminate_others;
+    apP = terminate_app;
+    app_reC = terminate_app_rec;
+  }
 
-let list_rewrite (rev:bool) (eqs: constr list) =
-  tclREPEAT
-    (List.fold_right
-       (fun eq i -> tclORELSE (rewriteLR eq) i)
-       (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
-
-let base_leaf_terminate (func:global_reference) eqs expr =
-(*  let _ = msgnl (str "entering base_leaf") in *)
-  (fun g ->
-     let k',h =
-       match pf_get_new_ids [k_id;h_id] g with
-	   [k';h] -> k',h
-	 | _ -> assert false
-     in
-     tclTHENLIST
-     [observe_tac "first split" (split (ImplicitBindings [expr]));
-      observe_tac "second split"
-        (split (ImplicitBindings [delayed_force coq_O]));
-      observe_tac "intro k" (h_intro k');
-      observe_tac "case on k"
-        (tclTHENS (simplest_case (mkVar k'))
-        [(tclTHEN (h_intro h)
-          (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
-					 [| delayed_force coq_O |])))
-            default_auto)); tclIDTAC ]);
-      intros;
-      simpl_iter onConcl;
-      unfold_constr func;
-      list_rewrite true eqs;
-      default_auto] g);;
-
-(* La fonction est donnee en premier argument a la
-   fonctionnelle suivie d'autres Lambdas et de Case ...
-   Pour recuperer la fonction f a partir de la
-   fonctionnelle *)
-
-let get_f foncl =
-  match (kind_of_term (def_of_const foncl)) with
-      Lambda (Name f, _, _) -> f
-    |_ -> error "la fonctionnelle est mal definie";;
-
-
-let rec compute_le_proofs = function
-    [] -> assumption
-  | a::tl ->
-      tclORELSE assumption
-	(tclTHENS
-	   (fun g ->
-	      let le_trans = delayed_force le_trans in
-	      let t_le_trans = compute_renamed_type g le_trans in
-	      let m_id =
-		let _,_,t = destProd t_le_trans in
-		let na,_,_ = destProd t in
-		Nameops.out_name na
-	      in
-	      apply_with_bindings
-		(le_trans,
-		 ExplicitBindings[dummy_loc,NamedHyp m_id,a])
-		g)
-	   [compute_le_proofs tl;
-            tclORELSE (apply (delayed_force le_n)) assumption])
-
-let make_lt_proof pmax le_proof =
-  tclTHENS
-    (fun g ->
-       let le_lt_trans = delayed_force le_lt_trans in
-       let t_le_lt_trans = compute_renamed_type g le_lt_trans in
-       let m_id =
-	 let _,_,t = destProd t_le_lt_trans in
-	 let na,_,_ = destProd t in
-	 Nameops.out_name na
-       in
-       apply_with_bindings
-	 (le_lt_trans,
-	  ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
-    [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
-     tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
-
-let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
-  match cond_eqs with
-    [] -> tclIDTAC
-  | eq::eqs ->
-      (fun g ->
-	 let t_eq = compute_renamed_type g (mkVar eq) in
-	 let k_id,def_id =
-	   let k_na,_,t = destProd t_eq in
-	   let _,_,t  = destProd t in
-	   let def_na,_,_ = destProd t in
-	   Nameops.out_name k_na,Nameops.out_name def_na
-	 in
-	 tclTHENS
-	   (general_rewrite_bindings false Termops.all_occurrences
-	      (* dep proofs also: *) true true
-	      (mkVar eq,
-	       ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
-				dummy_loc, NamedHyp def_id, mkVar def]) false)
-	   [list_cond_rewrite k def pmax eqs le_proofs;
-            observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
-      )
+let prove_terminate = travel terminate_info
 
-let rec introduce_all_equalities func eqs values specs bound le_proofs
-    cond_eqs =
-  match specs with
-    [] ->
-      fun g ->
-	let ids = pf_ids_of_hyps g in
-	let s_max = mkApp(delayed_force coq_S, [|bound|]) in
-	let k = next_ident_away_in_goal k_id ids in
-        let ids = k::ids in
-	let h' = next_ident_away_in_goal (h'_id) ids in
-        let ids = h'::ids in
-	let def = next_ident_away_in_goal def_id ids in
-	tclTHENLIST
-	  [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
-	   observe_tac "introduce_all_equalities_final intro k" (h_intro  k);
-	   tclTHENS
-	     (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k)))
-	     [
-	       tclTHENLIST[h_intro h';
-			   simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]));
-			   default_full_auto];
-	       tclIDTAC
-	     ];
-	   observe_tac "clearing k " (clear [k]);
-	   observe_tac "intros k h' def" (h_intros [k;h';def]);
-	   observe_tac "simple_iter" (simpl_iter onConcl);
-	   observe_tac "unfold functional"
-	     (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
-	   observe_tac "rewriting equations"
-	     (list_rewrite true eqs);
-           observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite  k def bound cond_eqs le_proofs);
-	   observe_tac "refl equal" (apply (delayed_force refl_equal))] g
-  | spec1::specs ->
-      fun g ->
-	let ids = Termops.ids_of_named_context (pf_hyps g) in
-	let p = next_ident_away_in_goal p_id ids in
-        let ids = p::ids in
-	let pmax = next_ident_away_in_goal pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_ident_away_in_goal hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_ident_away_in_goal  hle_id ids in
-	let ids = hle2::ids in
-	let heq = next_ident_away_in_goal heq_id ids in
-	tclTHENLIST
-	  [simplest_elim (mkVar spec1);
-	   list_rewrite true eqs;
-	   h_intros [p; heq];
-	   simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
-	   h_intros [pmax; hle1; hle2];
-	   introduce_all_equalities func eqs values specs
-	     (mkVar pmax) ((mkVar pmax)::le_proofs)
-	     (heq::cond_eqs)] g;;
-
-let string_match s =
-  if String.length s < 3 then failwith "string_match";
-  try
-    for i = 0 to 3  do
-      if String.get s i <> String.get "Acc_" i then failwith "string_match"
-    done;
-  with Invalid_argument _ -> failwith "string_match"
-
-let retrieve_acc_var g =
-  (* Julien: I don't like this version .... *)
-  let hyps = pf_ids_of_hyps g  in
-  map_succeed
-    (fun id -> string_match (string_of_id id);id)
-    hyps
-
-let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
-    eqs  hrec args values specs =
-    (match args with
-    [] ->
-      tclTHENLIST
-	[observe_tac "split" (split(ImplicitBindings
-		 [context_fn (List.map mkVar (List.rev values))]));
-	 observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs
-	   (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])]
-  | arg::args ->
-      (fun g ->
-	let ids = Termops.ids_of_named_context (pf_hyps g) in
-	let rec_res = next_ident_away_in_goal rec_res_id ids in
-        let ids = rec_res::ids in
-	let hspec = next_ident_away_in_goal hspec_id ids in
-	let tac =
-	  observe_tac "introduce_all_values" (
-	    introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
-	      hrec args
-	      (rec_res::values)(hspec::specs)) in
-	(tclTHENS
-	   (observe_tac "elim h_rec"
-	      (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
-	   )
-	   [tclTHENLIST [h_intros [rec_res; hspec];
-			 tac];
-	    (tclTHENS
-		 (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
-		 [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
-		    (observe_tac "h_assumption" h_assumption)
-		 ;
-		  tclTHENLIST
-		    [
-		      tclTRY(list_rewrite true eqs);
-		      observe_tac "user proof"
-			(fun g ->
-			   tclUSER
-			     concl_tac
-			     is_mes
-			     (Some (hrec::hspec::(retrieve_acc_var g)@specs))
-			     g
-			)
-		    ]
-		 ]
-	    )
-	   ]) g)
 
-    )
+(* Equation proof *)
 
+let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = 
+  terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos
 
-let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr =
-  match find_call_occs nb_arg 0 f_constr expr with
-  | context_fn, args ->
-      observe_tac "introduce_all_values"
-	(introduce_all_values concl_tac is_mes acc_inv func context_fn eqs  hrec args  [] [])
+let rec prove_le g = 
+  let x,z = 
+    let _,args = decompose_app (pf_concl g) in 
+    (List.hd args,List.hd (List.tl args))
+  in 
+  tclFIRST[
+    Proofview.V82.of_tactic assumption;
+    Proofview.V82.of_tactic (apply (delayed_force le_n));
+    begin
+      try
+	let matching_fun = 
+	  pf_is_matching g
+	    (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in 
+	let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g)
+	in 
+	let y = 
+	  let _,args = decompose_app t in 
+	  List.hd (List.tl args)
+	in 
+	tclTHENLIST[
+	  Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|])));
+	  observe_tac (str "prove_le (rec)") (prove_le)
+	] 
+      with Not_found -> tclFAIL 0 (mt())
+    end;
+  ]
+    g
 
-let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier)
-  (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
-  let rec proveterminate (eqs:constr list) (expr:constr)  =
-    try
-      (*  let _ = msgnl (str "entering proveterminate") in *)
-      let v =
-        match (kind_of_term expr) with
-	  Case (ci, t, a, l) ->
-	  (match find_call_occs nb_arg 0 f_constr a with
-	    _,[] ->
-	    (fun g ->
-	      let destruct_tac, rev_to_thin_intro =
-                mkDestructEq rec_arg_id a g in
-		tclTHENS destruct_tac
-		  (list_map_i
-		    (fun i -> mk_intros_and_continue
-				(List.rev rev_to_thin_intro)
-				true
-				proveterminate
-				eqs
-				ci.ci_cstr_ndecls.(i))
-		    0 (Array.to_list l)) g)
-		  | _, _::_ ->
-		    (match find_call_occs  nb_arg 0 f_constr expr with
-	     	      _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr)
-		    | _, _:: _ ->
-		      observe_tac "rec_leaf"
-		      (rec_leaf is_mes acc_inv hrec  func eqs expr)))
-	  | _ ->
-            (match find_call_occs  nb_arg 0 f_constr expr with
-	      _,[] ->
-	      (try observe_tac "base_leaf" (base_leaf func eqs expr)
-	       with reraise ->
-                 (msgerrnl (str "failure in base case");raise reraise ))
-	    | _, _::_ ->
-	      observe_tac "rec_leaf"
-	        (rec_leaf is_mes acc_inv hrec func eqs expr)) in
-      v
-    with reraise ->
+let rec make_rewrite_list expr_info max = function 
+  | [] -> tclIDTAC
+  | (_,p,hp)::l -> 
+    observe_tac (str "make_rewrite_list") (tclTHENS
+      (observe_tac (str "rewrite heq on " ++ pr_id p ) (
+	(fun g -> 
+	  let t_eq = compute_renamed_type g (mkVar hp) in
+	  let k,def =
+	    let k_na,_,t = destProd t_eq in
+	    let _,_,t  = destProd t in
+	    let def_na,_,_ = destProd t in
+	    Nameops.out_name k_na,Nameops.out_name def_na
+	  in
+	  Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
+	    true (* dep proofs also: *) true 
+	    (mkVar hp,
+	     ExplicitBindings[Loc.ghost,NamedHyp def,
+			      expr_info.f_constr;Loc.ghost,NamedHyp k,
+			      (f_S max)]) false) g) )
+      )
+      [make_rewrite_list expr_info max l;
+       tclTHENLIST[ (* x < S max proof *)
+	 Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm));
+	 observe_tac (str "prove_le(2)") prove_le
+       ]
+      ] )
+
+let make_rewrite expr_info l hp max = 
+  tclTHENFIRST
+    (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l))
+    (observe_tac (str "make_rewrite") (tclTHENS
+       (fun g -> 
+	  let t_eq = compute_renamed_type g (mkVar hp) in
+	  let k,def =
+	    let k_na,_,t = destProd t_eq in
+	    let _,_,t  = destProd t in
+	    let def_na,_,_ = destProd t in
+	    Nameops.out_name k_na,Nameops.out_name def_na
+	  in
+	 observe_tac (str "general_rewrite_bindings")
+	   (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences
+	    true (* dep proofs also: *) true 
+	    (mkVar hp,
+	     ExplicitBindings[Loc.ghost,NamedHyp def,
+			      expr_info.f_constr;Loc.ghost,NamedHyp k,
+			      (f_S (f_S max))]) false)) g)
+       [observe_tac(str "make_rewrite finalize") (
+	 (* tclORELSE( h_reflexivity) *)
+	 (tclTHENLIST[
+	   simpl_iter Locusops.onConcl;
+	   observe_tac (str "unfold functional")
+	     (unfold_in_concl[(Locus.OnlyOccurrences [1],
+			       evaluable_of_global_reference expr_info.func)]);
+	   
+	   (list_rewrite true 
+	      (List.map (fun e -> mkVar e,true) expr_info.eqs));
+	   (observe_tac (str "h_reflexivity") (Proofview.V82.of_tactic intros_reflexivity))]))
+       ;
+	 tclTHENLIST[ (* x < S (S max) proof *)
+	 Proofview.V82.of_tactic (apply (delayed_force le_lt_SS));
+	 observe_tac (str "prove_le (3)") prove_le
+	 ]
+       ])  
+    )
+
+let rec compute_max rew_tac max l = 
+  match l with 
+    | [] -> rew_tac max
+    | (_,p,_)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_elim 
+	  (mkApp(delayed_force max_constr, [| max; mkVar p|])));
+	tclDO 3 (Proofview.V82.of_tactic intro);
+	onNLastHypsId 3 (fun lids -> 
+	  match lids with
+	    | [hle2;hle1;pmax] -> compute_max rew_tac (mkVar pmax) l 
+	    | _ -> assert false
+	)]
+
+let rec destruct_hex expr_info acc l = 
+  match l with 
+    | [] -> 
       begin
-        msgerrnl(str "failure in proveterminate");
-        raise reraise
+	match List.rev acc with 
+	  | [] -> tclIDTAC 
+	  | (_,p,hp)::tl  -> 
+	    observe_tac (str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl)
       end
-  in
-  proveterminate
+    | (v,hex)::l -> 
+      tclTHENLIST[
+	Proofview.V82.of_tactic (simplest_case (mkVar hex));
+	clear [hex];
+	tclDO 2 (Proofview.V82.of_tactic intro);
+	onNthHypId 1 (fun hp -> 
+	  onNthHypId 2 (fun p -> 
+	    observe_tac 
+	      (str "destruct_hex after " ++ pr_id hp ++ spc () ++ pr_id p)
+	      (destruct_hex expr_info ((v,p,hp)::acc) l)
+	  )
+	)
+      ]
+	
+let rec intros_values_eq expr_info acc = 
+  tclORELSE(
+    tclTHENLIST[
+      tclDO 2 (Proofview.V82.of_tactic intro);
+      onNthHypId 1 (fun hex -> 
+	(onNthHypId 2 (fun v -> intros_values_eq expr_info ((v,hex)::acc)))
+      )
+    ])
+    (tclCOMPLETE (
+      destruct_hex expr_info [] acc
+    ))
+
+let equation_others _ expr_info continuation_tac infos = 
+  if expr_info.is_final && expr_info.is_main_branch 
+  then 
+    tclTHEN 
+      (continuation_tac infos) 
+      (intros_values_eq expr_info [])
+  else continuation_tac infos
+
+let equation_app f_and_args expr_info continuation_tac infos = 
+    if expr_info.is_final && expr_info.is_main_branch 
+    then intros_values_eq expr_info []
+    else continuation_tac infos
+	    
+let equation_app_rec (f,args) expr_info continuation_tac info = 
+  begin
+    try
+      let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in
+      let new_infos = {expr_info with info = v} in
+      observe_tac (str "app_rec found") (continuation_tac new_infos)
+    with Not_found ->
+      if expr_info.is_final && expr_info.is_main_branch 
+      then 
+	tclTHENLIST
+	  [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
+	    continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc};
+	    observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info [])
+	  ]
+      else 
+	tclTHENLIST[
+  	  Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args)));
+	  observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc})
+	]
+  end
 
-let hyp_terminates nb_args func =
-  let a_arrow_b = arg_type (constr_of_global func) in
+let equation_info = 
+  {message = "prove_equation with term ";
+   letiN = (fun _ -> assert false);
+   lambdA = (fun _ _ _ _ -> assert false);
+   casE = equation_case;
+   otherS = equation_others;
+   apP = equation_app;
+   app_reC = equation_app_rec
+}
+    
+let prove_eq = travel equation_info
+
+(* wrappers *)
+(* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F
+*)
+let compute_terminate_type nb_args func =
+  let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in
   let rev_args,b = decompose_prod_n nb_args a_arrow_b in
   let left =
     mkApp(delayed_force iter,
 	  Array.of_list
 	    (lift 5 a_arrow_b:: mkRel 3::
 	       constr_of_global func::mkRel 1::
-	       List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
+	       List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
 	    )
 	 )
   in
@@ -744,18 +1023,12 @@ let hyp_terminates nb_args func =
 		  delayed_force nat,
 		  (mkProd (Name k_id, delayed_force nat,
 			   mkArrow cond result))))|])in
-  let value = mkApp(delayed_force coq_sig,
+  let value = mkApp(constr_of_global (delayed_force coq_sig_ref),
 		    [|b;
 		      (mkLambda (Name v_id, b, nb_iter))|]) in
   compose_prod rev_args value
 
 
-
-let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
-  if is_mes
-  then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
-  else tclUSER concl_tac is_mes names_to_suppress
-
 let termination_proof_header is_mes input_type ids args_id relation
     rec_arg_num rec_arg_id tac wf_tac : tactic =
   begin
@@ -763,14 +1036,14 @@ let termination_proof_header is_mes input_type ids args_id relation
       let nargs = List.length args_id in
       let pre_rec_args =
 	List.rev_map
-	  mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+	  mkVar (fst (List.chop (rec_arg_num - 1) args_id))
       in
       let relation = substl pre_rec_args relation in
       let input_type = substl pre_rec_args input_type in
-      let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in
+      let wf_thm = next_ident_away_in_goal (Id.of_string ("wf_R")) ids in
       let wf_rec_arg =
 	next_ident_away_in_goal
-	  (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
+	  (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))
 	  (wf_thm::ids)
       in
       let hrec = next_ident_away_in_goal hrec_id
@@ -787,46 +1060,46 @@ let termination_proof_header is_mes input_type ids args_id relation
 	(h_intros args_id)
 	(tclTHENS
 	   (observe_tac
-	      "first assert"
-	      (assert_tac
+	      (str "first assert")
+	      (Proofview.V82.of_tactic (assert_before
 		 (Name wf_rec_arg)
 		 (mkApp (delayed_force acc_rel,
 			 [|input_type;relation;mkVar rec_arg_id|])
 		 )
-	      )
+	      ))
 	   )
 	   [
 	     (* accesibility proof *)
 	     tclTHENS
 	       (observe_tac
-		  "second assert"
-		  (assert_tac
+		  (str "second assert")
+		  (Proofview.V82.of_tactic (assert_before
 		     (Name wf_thm)
 		     (mkApp (delayed_force well_founded,[|input_type;relation|]))
-		  )
+		  ))
 	       )
 	       [
 		 (* interactive proof that the relation is well_founded *)
-		 observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
+		 observe_tac (str "wf_tac") (wf_tac is_mes (Some args_id));
 		 (* this gives the accessibility argument *)
 		 observe_tac
-		   "apply wf_thm"
-		   (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
+		   (str "apply wf_thm")
+		   (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])))
 		   )
 	       ]
 	     ;
 	     (* rest of the proof *)
-	     tclTHENSEQ
-	       [observe_tac "generalize"
+	     tclTHENLIST
+	       [observe_tac (str "generalize")
 		  (onNLastHypsId (nargs+1)
 		     (tclMAP (fun id ->
-			tclTHEN (h_generalize [mkVar id]) (h_clear false [id]))
+			tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id]))
 		     ))
 	       ;
-		observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
+		observe_tac (str "fix") (fix (Some hrec) (nargs+1));
 		h_intros args_id;
-		h_intro wf_rec_arg;
-		observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
+		Proofview.V82.of_tactic (Simple.intro wf_rec_arg);
+		observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv)
 	       ]
 	   ]
 	) g
@@ -838,10 +1111,8 @@ let rec instantiate_lambda t l =
   match l with
   | [] -> t
   | a::l ->
-      let (bound_name, _, body) = destLambda t in
+      let (_, _, body) = destLambda t in
       instantiate_lambda (subst1 a body) l
-;;
-
 
 let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num  : tactic =
   begin
@@ -852,7 +1123,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
       let f_id =
 	match f_name with
 	  | Name f_id -> next_ident_away_in_goal f_id ids
-	  | Anonymous -> anomaly "Anonymous function"
+	  | Anonymous -> anomaly (Pp.str "Anonymous function")
       in
       let n_names_types,_ = decompose_lam_n nb_args body1 in
       let n_ids,ids =
@@ -862,7 +1133,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	       | Name id ->
 		   let n_id = next_ident_away_in_goal id ids in
 		   n_id::n_ids,n_id::ids
-	       | _ -> anomaly "anonymous argument"
+	       | _ -> anomaly (Pp.str "anonymous argument")
 	  )
 	  ([],(f_id::ids))
 	  n_names_types
@@ -877,20 +1148,28 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 	relation
 	rec_arg_num
 	rec_arg_id
-	(fun rec_arg_id hrec acc_inv g ->
-           (proveterminate
-	      nb_args
-	      [rec_arg_id]
-	      is_mes
-	      acc_inv
-	      hrec
-	      (mkVar f_id)
-	      func
-	      base_leaf_terminate
-	      (rec_leaf_terminate nb_args (mkVar f_id) concl_tac)
-	      []
-	      expr
-	   )
+	(fun rec_arg_id hrec acc_id acc_inv g -> 	      
+	  (prove_terminate (fun infos -> tclIDTAC) 
+	     { is_main_branch = true; (* we are on the main branche (i.e. still on a match ... with .... end *)
+	       is_final = true;      (* and on leaf (more or less) *)
+	       f_terminate = delayed_force coq_O;
+	       nb_arg = nb_args;
+	       concl_tac = concl_tac;
+	       rec_arg_id = rec_arg_id;
+	       is_mes = is_mes;
+	       ih = hrec;
+	       f_id = f_id;
+	       f_constr = mkVar f_id;
+	       func = func;
+	       info = expr;
+	       acc_inv = acc_inv;
+	       acc_id = acc_id;
+	       values_and_bounds = [];
+	       eqs = [];
+	       forbidden_ids = [];
+	       args_assoc = []
+	     }
+	  ) 
 	     g
 	)
 	(tclUSER_if_not_mes concl_tac)
@@ -900,7 +1179,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a
 let get_current_subgoals_types () =
   let p = Proof_global.give_me_the_proof () in
   let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in
-  List.map (Goal.V82.abstract_type sigma) sgs
+    sigma, List.map (Goal.V82.abstract_type sigma) sgs
 
 let build_and_l l =
   let and_constr =  Coqlib.build_coq_and () in
@@ -913,7 +1192,8 @@ let build_and_l l =
       | App(_,_) -> 
 	let (f,_) = decompose_app t in 
 	eq_constr f (well_founded ())
-      | _ -> false
+      | _ -> 
+	false
   in
   let compare t1 t2 = 
     let b1,b2= is_well_founded t1,is_well_founded t2 in 
@@ -928,7 +1208,7 @@ let build_and_l l =
 	let c,tac,nb = f pl in
 	mk_and p1 c,
 	tclTHENS
-	  (apply (constr_of_global conj_constr))
+	  (Proofview.V82.of_tactic (apply (constr_of_global conj_constr)))
 	  [tclIDTAC;
 	   tac
 	  ],nb+1
@@ -936,12 +1216,12 @@ let build_and_l l =
 
 
 let is_rec_res id =
-  let rec_res_name = string_of_id rec_res_id   in
-  let id_name = string_of_id id in
+  let rec_res_name = Id.to_string rec_res_id   in
+  let id_name = Id.to_string id in
   try
-    String.sub id_name 0 (String.length rec_res_name) = rec_res_name
-  with e when Errors.noncritical e -> false
-
+    String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name
+  with Invalid_argument _ -> false
+ 
 let clear_goals =
   let rec clear_goal t =
     match kind_of_term t with
@@ -957,12 +1237,12 @@ let clear_goals =
 
 
 let build_new_goal_type () =
-  let sub_gls_types = get_current_subgoals_types () in
+  let sigma, sub_gls_types = get_current_subgoals_types () in
   (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
   let sub_gls_types = clear_goals sub_gls_types in
-  (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+  (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
   let res = build_and_l sub_gls_types in
-  res
+    sigma, res
 
 let is_opaque_constant c =
   let cb = Global.lookup_constant c in
@@ -971,48 +1251,47 @@ let is_opaque_constant c =
     | Declarations.Undef _ -> true
     | Declarations.Def _ -> false
 
-let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
+let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal)   =
   (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *)
   let current_proof_name = get_current_proof_name () in
   let name = match goal_name with
     | Some s -> s
     | None   ->
-	try (add_suffix current_proof_name "_subproof")
+	try add_suffix current_proof_name "_subproof"
 	with e when Errors.noncritical e ->
-          anomaly "open_new_goal with an unamed theorem"
+          anomaly (Pp.str "open_new_goal with an unamed theorem")
   in
-  let sign = initialize_named_context_for_proof () in
   let na = next_global_ident_away name [] in
   if Termops.occur_existential gls_type then
-    Util.error "\"abstract\" cannot handle existentials";
+    Errors.error "\"abstract\" cannot handle existentials";
   let hook _ _ =
     let opacity =
-      let na_ref = Libnames.Ident (dummy_loc,na) in
-      let na_global = Nametab.global na_ref in
+      let na_ref = Libnames.Ident (Loc.ghost,na) in
+      let na_global = Smartlocate.global_with_alias na_ref in
       match na_global with
 	  ConstRef c -> is_opaque_constant c
-	| _ -> anomaly "equation_lemma: not a constant"
+	| _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant")
     in
-    let lemma = mkConst (Lib.make_con na) in
+    let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in
     ref_ := Some lemma ;
     let lid = ref [] in
     let h_num = ref (-1) in
-    Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
-    build_proof
+    Proof_global.discard_all ();
+    build_proof Evd.empty
       (  fun gls ->
 	   let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
-	   tclTHENSEQ
+	   tclTHENLIST
 	     [
-	       h_generalize [lemma];
-	       h_intro hid;
+	       Simple.generalize [lemma];
+	       Proofview.V82.of_tactic (Simple.intro hid);
 	       (fun g ->
 		  let ids = pf_ids_of_hyps g in
 		  tclTHEN
-		    (Elim.h_decompose_and (mkVar hid))
+		    (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)))
 		    (fun g ->
 		       let ids' = pf_ids_of_hyps g in
-		       lid := List.rev (list_subtract ids' ids);
-		       if !lid = [] then lid := [hid];
+		       lid := List.rev (List.subtract Id.equal ids' ids);
+		       if List.is_empty !lid then lid := [hid];
 		       tclIDTAC g
 		    )
 		    g
@@ -1021,40 +1300,39 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
       (fun g ->
 	 match kind_of_term (pf_concl g) with
 	   | App(f,_) when eq_constr f (well_founded ()) ->
-	       Auto.h_auto None [] (Some [])  g
+	       Proofview.V82.of_tactic (Auto.h_auto None [] (Some []))  g
 	   | _ ->
 	       incr h_num;
-	       (observe_tac "finishing using"
+	       (observe_tac (str "finishing using")
 		  (
 		    tclCOMPLETE(
 		      tclFIRST[
 			tclTHEN
-			  (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
+			  (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)))
 			  e_assumption;
 		      Eauto.eauto_with_bases
 			(true,5)
-			[Evd.empty,delayed_force refl_equal]
-			[Auto.Hint_db.empty empty_transparent_state false]
+			[Evd.empty,Lazy.force refl_equal]
+			[Hints.Hint_db.empty empty_transparent_state false]
 		      ]
 		    )
 		  )
 	       )
       		 g)
 ;
-    Lemmas.save_named opacity;
+    Lemmas.save_proof (Vernacexpr.Proved(opacity,None));
   in
-  start_proof
+  Lemmas.start_proof
     na
-    (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
-    sign
-    gls_type
-    hook ;
+    (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma)
+    sigma gls_type
+    (Lemmas.mk_hook hook);
   if Indfun_common.is_strict_tcc  ()
   then
-    by (tclIDTAC)
+    ignore (by (Proofview.V82.tactic (tclIDTAC)))
   else 
     begin
-      by (
+      ignore (by (Proofview.V82.tactic begin
 	fun g ->
 	  tclTHEN
 	    (decompose_and_tac)
@@ -1062,23 +1340,21 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_
 	       (tclFIRST
 	 	  (List.map
 	 	     (fun c ->
-	 		tclTHENSEQ
+	 		Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST
 	 		  [intros;
-	 		   h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
-	 		   tclCOMPLETE Auto.default_auto
-	 		  ]
+	 		   Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*);
+	 		   Tacticals.New.tclCOMPLETE Auto.default_auto
+	 		  ])
 	 	     )
 	 	     using_lemmas)
 	       ) tclIDTAC)
-	    g)
+	    g end))
     end;
   try
-    by tclIDTAC; (* raises UserError _ if the proof is complete *)
-    if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
+    ignore (by (Proofview.V82.tactic tclIDTAC)); (* raises UserError _ if the proof is complete *)
   with UserError _ ->
     defined ()
 
-;;
 
 
 let com_terminate
@@ -1090,25 +1366,28 @@ let com_terminate
     relation
     rec_arg_num
     thm_name using_lemmas
-    nb_args
+    nb_args ctx
     hook =
-  let start_proof (tac_start:tactic) (tac_end:tactic) =
+  let start_proof ctx (tac_start:tactic) (tac_end:tactic) =
     let (evmap, env) = Lemmas.get_current_context() in
-    start_proof thm_name
-      (Global, Proof Lemma) (Environ.named_context_val env)
-      (hyp_terminates nb_args fonctional_ref) hook;
+    Lemmas.start_proof thm_name
+      (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env)
+      ctx (compute_terminate_type nb_args fonctional_ref) hook;
 
-    by (observe_tac "starting_tac" tac_start);
-    by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
-				   input_type relation rec_arg_num ))
+    ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start)));
+    ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref
+    				   input_type relation rec_arg_num ))))
   in
-  start_proof tclIDTAC tclIDTAC;
+  start_proof ctx tclIDTAC tclIDTAC;
   try
-    let new_goal_type = build_new_goal_type () in
-    open_new_goal start_proof using_lemmas tcc_lemma_ref
+    let sigma, new_goal_type = build_new_goal_type () in
+    let sigma =
+      Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env
+    in
+    open_new_goal start_proof sigma
+      using_lemmas tcc_lemma_ref
       (Some tcc_lemma_name)
       (new_goal_type);
-
   with Failure "empty list of subgoals!" ->
     (* a non recursive function declared with measure ! *)
     defined ()
@@ -1116,301 +1395,87 @@ let com_terminate
 
 
 
-let ind_of_ref = function
-  | IndRef (ind,i) -> (ind,i)
-  | _ -> anomaly "IndRef expected"
-
-let (value_f:constr list -> global_reference -> constr) =
-  fun al fterm ->
-    let d0 = dummy_loc in
-    let rev_x_id_l =
-      (
-	List.fold_left
-	  (fun x_id_l _ ->
-	     let x_id = next_ident_away_in_goal x_id x_id_l in
-	     x_id::x_id_l
-	  )
-	  []
-	  al
-      )
-    in
-    let context = List.map
-      (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
-    in
-    let env = Environ.push_rel_context context (Global.env ()) in
-    let glob_body =
-      GCases
-	(d0,RegularStyle,None,
-	 [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l),
-	  (Anonymous,None)],
-	 [d0, [v_id], [PatCstr(d0,(ind_of_ref
-				     (delayed_force coq_sig_ref),1),
-			       [PatVar(d0, Name v_id);
-				PatVar(d0, Anonymous)],
-			       Anonymous)],
-	  GVar(d0,v_id)])
-    in
-    let body = understand Evd.empty env glob_body in
-    it_mkLambda_or_LetIn body context
-
-let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
-  fun f_id kind value ->
-    let ce = {const_entry_body = value;
-              const_entry_secctx = None;
-	      const_entry_type = None;
-	      const_entry_opaque = false } in
-      ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
-
-let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) =
-  fun f_id kind input_type fterm_ref ->
-    declare_fun f_id kind (value_f input_type fterm_ref);;
-
-let rec n_x_id ids n =
-  if n = 0 then []
-  else let x = next_ident_away_in_goal x_id ids in
-          x::n_x_id (x::ids) (n-1);;
 
 let start_equation (f:global_reference) (term_f:global_reference)
-  (cont_tactic:identifier list -> tactic) g =
+  (cont_tactic:Id.t list -> tactic) g =
   let ids = pf_ids_of_hyps g in
   let terminate_constr = constr_of_global term_f in
-  let nargs = nb_prod (type_of_const terminate_constr) in
+  let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in
   let x = n_x_id ids nargs in
   tclTHENLIST [
     h_intros x;
-    unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)];
-    observe_tac "simplest_case"
-      (simplest_case (mkApp (terminate_constr,
-                             Array.of_list (List.map mkVar x))));
-    observe_tac "prove_eq" (cont_tactic x)] g;;
-
-let base_leaf_eq func eqs f_id g =
-  let ids = pf_ids_of_hyps g in
-  let k = next_ident_away_in_goal k_id ids in
-  let p = next_ident_away_in_goal p_id (k::ids) in
-  let v = next_ident_away_in_goal v_id (p::k::ids) in
-  let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in
-  let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in
-  let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in
-    tclTHENLIST [
-      h_intros [v; hex];
-      simplest_elim (mkVar hex);
-      h_intros [p;heq1];
-      tclTRY
-	(rewriteRL
-	   (mkApp(mkVar heq1,
-		  [|mkApp (delayed_force coq_S, [|mkVar p|]);
-		    mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
-      simpl_iter onConcl;
-      tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
-      observe_tac "list_revrite" (list_rewrite true eqs);
-      apply (delayed_force refl_equal)] g;;
-
-let f_S t = mkApp(delayed_force coq_S, [|t|]);;
+    unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)];
+    observe_tac (str "simplest_case")
+      (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr,
+                             Array.of_list (List.map mkVar x)))));
+    observe_tac (str "prove_eq") (cont_tactic x)] g;;
 
-
-let rec introduce_all_values_eq cont_tac functional termine
-    f p heq1 pmax bounds le_proofs eqs ids =
-  function
-      [] ->
-       let heq2 = next_ident_away_in_goal heq_id ids in
-	tclTHENLIST
-	  [pose_proof (Name heq2)
-             (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
-           simpl_iter (onHyp heq2);
-           unfold_in_hyp [((true,[1]), evaluable_of_global_reference
-                             (global_of_constr functional))]
-             (heq2, Termops.InHyp);
-           tclTHENS
-	     (fun gls ->
-		let t_eq = compute_renamed_type gls (mkVar heq2) in
-		let def_id =
-		  let _,_,t  = destProd t_eq in let def_na,_,_ = destProd t in
-		  Nameops.out_name def_na
-		in
-		observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences
-		true (* dep proofs also: *) true (mkVar heq2,
-		 ExplicitBindings[dummy_loc,NamedHyp def_id,
-				  f]) false) gls)
-	     [tclTHENLIST
-		[observe_tac "list_rewrite" (list_rewrite true eqs);
-                 cont_tac pmax le_proofs];
-	      tclTHENLIST[apply (delayed_force le_lt_SS);
-			compute_le_proofs le_proofs]]]
-    | arg::args ->
-	let v' = next_ident_away_in_goal v_id ids in
-        let ids = v'::ids in
-	let hex' = next_ident_away_in_goal hex_id ids in
-        let ids = hex'::ids in
-	let p' = next_ident_away_in_goal p_id ids in
-        let ids = p'::ids in
-	let new_pmax = next_ident_away_in_goal pmax_id ids in
-        let ids = pmax::ids in
-	let hle1 = next_ident_away_in_goal hle_id ids in
-        let ids = hle1::ids in
-	let hle2 = next_ident_away_in_goal hle_id ids in
-        let ids = hle2::ids in
-	let heq = next_ident_away_in_goal heq_id ids in
-        let ids = heq::ids in
-	let heq2 = next_ident_away_in_goal heq_id ids in
-        let ids = heq2::ids in
-	tclTHENLIST
-	  [mkCaseEq(mkApp(termine, Array.of_list arg));
-	   h_intros [v'; hex'];
-	   simplest_elim(mkVar hex');
-	   h_intros [p'];
-	   simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
-							mkVar p'|]));
-	   h_intros [new_pmax;hle1;hle2];
-           introduce_all_values_eq
-              (fun pmax' le_proofs'->
-		tclTHENLIST
-		  [cont_tac pmax' le_proofs';
-		   h_intros [heq;heq2];
-		   observe_tac ("rewriteRL " ^ (string_of_id heq2))
-                     (tclTRY (rewriteLR (mkVar heq2)));
-		   tclTRY (tclTHENS
-		     ( fun g ->
-			 let t_eq = compute_renamed_type g (mkVar heq) in
-			 let k_id,def_id =
-			   let k_na,_,t = destProd t_eq in
-			   let _,_,t  = destProd t in
-			   let def_na,_,_ = destProd t in
-			   Nameops.out_name k_na,Nameops.out_name def_na
-			 in
-			 let c_b = (mkVar heq,
-			    ExplicitBindings
-			      [dummy_loc, NamedHyp k_id,
-			       f_S(mkVar pmax');
-			       dummy_loc, NamedHyp def_id, f])
-			 in
-			   observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true
-							       c_b false))
-			     g
-		     )
-		     [tclIDTAC;
-		      tclTHENLIST
-			[apply (delayed_force le_lt_n_Sm);
-			 compute_le_proofs le_proofs']])])
-	     functional termine f p heq1 new_pmax
-	     (p'::bounds)((mkVar pmax)::le_proofs) eqs
-             (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
-
-
-let rec_leaf_eq termine f ids functional eqs expr fn args =
-  let p = next_ident_away_in_goal p_id ids in
-  let ids = p::ids in
-  let v = next_ident_away_in_goal v_id ids in
-  let ids = v::ids in
-  let hex = next_ident_away_in_goal hex_id ids in
-  let ids = hex::ids in
-  let heq1 = next_ident_away_in_goal heq_id ids in
-  let ids = heq1::ids in
-  let hle1 = next_ident_away_in_goal hle_id ids in
-  let ids = hle1::ids in
-    tclTHENLIST
-      [observe_tac "intros v hex" (h_intros [v;hex]);
-       simplest_elim (mkVar hex);
-       h_intros [p;heq1];
-       h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
-       h_intros [hle1];
-       observe_tac "introduce_all_values_eq" (introduce_all_values_eq
-	 (fun _ _ -> tclIDTAC)
-	 functional termine f p heq1 p [] [] eqs ids args);
-       observe_tac "failing here" (apply (delayed_force refl_equal))]
-
-let rec prove_eq nb_arg  (termine:constr) (f:constr)(functional:global_reference)
-    (eqs:constr list) (expr:constr) =
-(*   tclTRY *)
-  observe_tac "prove_eq"  (match kind_of_term expr with
-     Case(ci,t,a,l) ->
-     (match find_call_occs nb_arg 0 f a with
-	_,[] ->
-	(fun g ->
-	  let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
-	  tclTHENS
-            destruct_tac
-	    (list_map_i
-	       (fun i -> mk_intros_and_continue
-                          (List.rev rev_to_thin_intro) true
-			  (prove_eq nb_arg termine f functional)
-			  eqs ci.ci_cstr_ndecls.(i))
-	       0 (Array.to_list l)) g)
-	   | _,_::_ ->
-	      (match find_call_occs nb_arg 0 f expr with
-		_,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f)
-	      | fn,args ->
-	        fun g ->
-		  let ids = Termops.ids_of_named_context (pf_hyps g) in
-	          observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids
-		    (constr_of_global functional)
-		    eqs expr fn args) g))
-       | _ ->
-	   (match find_call_occs nb_arg 0 f expr with
-		_,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f)
-	      | fn,args ->
-		  fun g ->
-		    let ids = Termops.ids_of_named_context (pf_hyps g) in
-		    observe_tac "rec_leaf_eq" (rec_leaf_eq
-		      termine f ids (constr_of_global functional)
-		      eqs expr fn args) g));;
-
-let (com_eqn : int -> identifier ->
+let (com_eqn : int -> Id.t ->
        global_reference -> global_reference -> global_reference
 	 -> constr -> unit) =
   fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type ->
     let opacity =
       match terminate_ref with
 	| ConstRef c -> is_opaque_constant c
-	| _ -> anomaly "terminate_lemma: not a constant"
+	| _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant")
     in
     let (evmap, env) = Lemmas.get_current_context() in
-    let f_constr = (constr_of_global f_ref) in
+    let evmap =
+      Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env
+    in
+    let f_constr = constr_of_global f_ref in
     let equation_lemma_type = subst1 f_constr equation_lemma_type in
-    (start_proof eq_name (Global, Proof Lemma)
-       (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
-     by
-       (start_equation f_ref terminate_ref
+    (Lemmas.start_proof eq_name (Global, false, Proof Lemma)
+       ~sign:(Environ.named_context_val env)
+       evmap
+       equation_lemma_type
+       (Lemmas.mk_hook (fun _ _ -> ()));
+     ignore (by
+       (Proofview.V82.tactic (start_equation f_ref terminate_ref
 	  (fun  x ->
-	     prove_eq nb_arg
-	       (constr_of_global terminate_ref)
-	       f_constr
-	       functional_ref
-	       []
-	       (instantiate_lambda
-	       	  (def_of_const (constr_of_global functional_ref))
-	       	  (f_constr::List.map mkVar x)
-	       )
+	     prove_eq (fun _ -> tclIDTAC)
+	       {nb_arg=nb_arg;
+		f_terminate = constr_of_global terminate_ref; 
+	        f_constr = f_constr; 
+		concl_tac = tclIDTAC;
+		func=functional_ref;
+		info=(instantiate_lambda
+	       		(def_of_const (constr_of_global functional_ref))
+	       		(f_constr::List.map mkVar x)
+		);
+		is_main_branch = true;
+		is_final = true;
+		values_and_bounds = [];
+		eqs = [];
+		forbidden_ids = [];
+		acc_inv = lazy (assert false);
+		acc_id = Id.of_string "____";
+		args_assoc = [];
+		f_id = Id.of_string "______";
+		rec_arg_id = Id.of_string "______";
+		is_mes = false;
+		ih = Id.of_string "______";
+	       }
 	  )
-       );
-(*      (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
+       ))); 
+     (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
 (*      Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
-     Flags.silently (fun () -> Lemmas.save_named opacity) () ;
+     Flags.silently (fun () -> Lemmas.save_proof (Vernacexpr.Proved(opacity,None))) () ; 
 (*      Pp.msgnl (str "eqn finished"); *)
-
     );;
 
-let nf_zeta env =
-  Reductionops.clos_norm_flags  (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-    env
-    Evd.empty
-
-let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta  *)
-  let clos_norm_flags flgs env sigma t =
-    Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
-  clos_norm_flags Closure.betaiotazeta  Environ.empty_env Evd.empty
-
 
 let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
     generate_induction_principle using_lemmas : unit =
-  let previous_label = Lib.current_command_label () in
-  let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
-  let env = push_named (function_name,None,function_type) (Global.env()) in
+  let env = Global.env() in
+  let evd = ref (Evd.from_env env) in
+  let function_type = interp_type_evars env evd type_of_f in
+  let env = push_named (function_name,None,function_type) env in
   (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type);  *)
-  let equation_lemma_type = 
-    nf_betaiotazeta
-      (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) 
-  in
+  let ty = interp_type_evars env evd ~impls:rec_impls eq in
+  let evm, nf = Evarutil.nf_evars_and_universes !evd in
+  let equation_lemma_type = nf_betaiotazeta (nf ty) in
+  let function_type = nf function_type in
  (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
   let res_vars,eq' = decompose_prod equation_lemma_type in
   let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in
@@ -1430,35 +1495,35 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
   let equation_id = add_suffix function_name "_equation" in
   let functional_id =  add_suffix function_name "_F" in
   let term_id = add_suffix function_name "_terminate" in
-  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in
+  let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) res in
   let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in  
   let relation =
-    interp_constr
-      Evd.empty
+    fst (*FIXME*)(interp_constr
       env_with_pre_rec_args
-      r
+      Evd.empty
+      r)
   in
   let tcc_lemma_name = add_suffix function_name "_tcc" in
   let tcc_lemma_constr = ref None in
   (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
-  let hook _ _ =
+  let hook _ _ = 
     let term_ref = Nametab.locate (qualid_of_ident term_id) in
     let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
-    let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in 
-(*     message "start second proof"; *)
-    let stop = ref false in
-    begin
-      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+    let _ = Table.extraction_inline true [Ident (Loc.ghost,term_id)] in 
+    (*     message "start second proof"; *)
+    let stop = 
+      try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type);
+	  false
       with e when Errors.noncritical e ->
 	begin
-	  if Tacinterp.get_debug () <> Tactic_debug.DebugOff
-	  then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e)
-	  else anomaly "Cannot create equation Lemma"
+	  if do_observe ()
+	  then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e)
+	  else anomaly (Pp.str "Cannot create equation Lemma")
 	  ;
-	  stop := true;
+	  true
 	end
-    end;
-    if not !stop
+    in
+    if not stop
     then
       let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in
       let f_ref = destConst (constr_of_global f_ref)
@@ -1471,9 +1536,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
 			 spc () ++ str"is defined" )++ fnl () ++
 		    h 1 (Ppconstr.pr_id equation_id ++
 			   spc () ++ str"is defined" )
-		 )
+      )
   in
-  try
+  States.with_state_protection_on_exception (fun () ->
     com_terminate
       tcc_lemma_name
       tcc_lemma_constr
@@ -1483,11 +1548,5 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
       term_id
       using_lemmas
       (List.length res_vars)
-      hook
-  with reraise ->
-    begin
-      (try ignore (Backtrack.backto previous_label)
-       with e when Errors.noncritical e -> ());
-      (*       anomaly "Cannot create termination Lemma" *)
-      raise reraise
-    end
+      evm (Lemmas.mk_hook hook))
+    ()
diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli
new file mode 100644
index 00000000..f60eedbe
--- /dev/null
+++ b/plugins/funind/recdef.mli
@@ -0,0 +1,20 @@
+
+
+(* val evaluable_of_global_reference : Libnames.global_reference -> Names.evaluable_global_reference *)
+val tclUSER_if_not_mes : 
+  Proof_type.tactic ->
+  bool -> 
+  Names.Id.t list option -> 
+  Proof_type.tactic
+val recursive_definition :  
+bool ->
+           Names.Id.t ->
+           Constrintern.internalization_env ->
+           Constrexpr.constr_expr ->
+           Constrexpr.constr_expr ->
+           int -> Constrexpr.constr_expr -> (Term.pconstant ->
+            Term.constr option ref ->
+            Term.pconstant ->
+            Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit
+
+
diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
deleted file mode 100644
index 04336747..00000000
--- a/plugins/micromega/CheckerMaker.v
+++ /dev/null
@@ -1,132 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-(*                                                                      *)
-(* Micromega: A reflexive tactic using the Positivstellensatz           *)
-(*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
-(*                                                                      *)
-(************************************************************************)
-
-(* FK: scheduled for deletion *)
-(*
-Require Import Setoid.
-Require Import Decidable.
-Require Import List.
-Require Import Refl.
-
-Set Implicit Arguments.
-
-Section CheckerMaker.
-
-(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
-Variable Formula : Type.
-
-Variable Env : Type.
-
-Variable eval : Env -> Formula -> Prop.
-
-Variable Formula' : Type.
-
-Variable eval' : Env -> Formula' -> Prop.
-
-Variable normalise : Formula -> Formula'.
-
-Variable negate : Formula -> Formula'.
-
-Hypothesis normalise_sound :
-  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
-
-Hypothesis negate_correct :
-  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
-
-Variable Witness : Type.
-
-Variable check_formulas' : list Formula' -> Witness -> bool.
-
-Hypothesis check_formulas'_sound :
-  forall (l : list Formula') (w : Witness),
-    check_formulas' l w = true ->
-      forall env : Env, make_impl (eval' env) l False.
-
-Definition normalise_list : list Formula -> list Formula' := map normalise.
-Definition negate_list : list Formula -> list Formula' := map negate.
-
-Definition check_formulas (l : list Formula) (w : Witness) : bool :=
-  check_formulas' (map normalise l) w.
-
-(* Contraposition of normalise_sound for lists *)
-Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
-  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
-Proof.
-intros env l; induction l as [| t l IH]; simpl in *.
-trivial.
-intros H1 H2. apply IH. apply H1. now apply normalise_sound.
-Qed.
-
-Theorem check_formulas_sound :
-  forall (l : list Formula) (w : Witness),
-    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
-Proof.
-unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
-pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
-intro H1. apply normalise_sound in H1.
-pose proof (check_formulas'_sound H env) as H2; simpl in H2.
-apply H2 in H1. now apply normalise_sound_contr.
-Qed.
-
-(* In check_conj_formulas', t2 is supposed to be a list of negations of
-formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
-check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
-inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
-A1 /\ A2 -> B1 /\ B2. *)
-
-Fixpoint check_conj_formulas'
-  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
-match t2 with
-| nil => true
-| t':: rt2 =>
-  match wits with
-  | nil => false
-  | w :: rwits =>
-    match check_formulas' (t':: t1) w with
-    | true => check_conj_formulas' t1 rwits rt2
-    | false => false
-    end
-  end
-end.
-
-(* checks whether the conjunction of t1 implies the conjunction of t2 *)
-
-Definition check_conj_formulas
-  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
-    check_conj_formulas' (normalise_list t1) wits (negate_list t2).
-
-Theorem check_conj_formulas_sound :
-  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
-    check_conj_formulas t1 wits t2 = true ->
-      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
-Proof.
-intro t1; induction t2 as [| a2 t2' IH].
-intros; apply make_impl_true.
-intros wits H env.
-unfold check_conj_formulas in H; simpl in H.
-destruct wits as [| w ws]; simpl in H. discriminate.
-case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
-intro H1; rewrite H1 in H; [| discriminate].
-assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
-now apply check_formulas'_sound with (w := w). clear H1.
-pose proof (IH ws H env) as H1. simpl in H2.
-assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
-by auto using normalise_sound_contr. clear H2.
-rewrite <- make_conj_impl in *.
-rewrite make_conj_cons. intro H2. split.
-apply <- negate_correct. intro; now elim H3. exact (H1 H2).
-Qed.
-
-End CheckerMaker.
-*)
\ No newline at end of file
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index 31c4a565..dd4d596f 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -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/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index 424f9f37..62a7333d 100644
--- a/plugins/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -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/plugins/micromega/Lia.v b/plugins/micromega/Lia.v
new file mode 100644
index 00000000..72425585
--- /dev/null
+++ b/plugins/micromega/Lia.v
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                                                                      *)
+(* Micromega: A reflexive tactic using the Positivstellensatz           *)
+(*                                                                      *)
+(*  Frédéric Besson (Irisa/Inria)      2013                             *)
+(*                                                                      *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import ZArith.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac preprocess :=
+  zify ; unfold Z.succ in * ; unfold Z.pred in *.
+
+Ltac lia :=
+  preprocess;
+  xlia ;
+  abstract (
+      intros __wit __varmap __ff ;
+      change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+Ltac nia :=
+  preprocess;
+  xnlia ;
+  abstract (
+      intros __wit __varmap __ff ;
+      change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 607eb2b6..22ddd549 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -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/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
index 2469f644..34b8bbdd 100644
--- a/plugins/micromega/OrderedRing.v
+++ b/plugins/micromega/OrderedRing.v
@@ -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        *)
@@ -85,9 +85,9 @@ Notation "x < y" := (rlt x y).
 
 
 Add Relation R req
-  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
-  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
-  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
 as sor_setoid.
 
 
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index 42c65b5a..675321d9 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -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        *)
@@ -16,35 +16,55 @@ Require Import ZMicromega.
 Require Import QMicromega.
 Require Import RMicromega.
 Require Import QArith.
-Require Export Ring_normalize.
 Require Import ZArith.
 Require Import Rdefinitions.
-Require Export RingMicromega.
+Require Import RingMicromega.
 Require Import VarMap.
 Require Tauto.
 Declare ML Module "micromega_plugin".
 
+Ltac preprocess := 
+    zify ; unfold Z.succ in * ; unfold Z.pred in *.
+
+Ltac lia :=
+  preprocess;
+  xlia ;
+  abstract (
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+Ltac nia :=
+  preprocess;
+  xnlia ;
+  abstract (
+  intros __wit __varmap __ff ;
+    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+      apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+
+
 Ltac xpsatz dom d :=
   let tac := lazymatch dom with
   | Z =>
     (sos_Z || psatz_Z d) ;
+      abstract(
     intros __wit __varmap __ff ;
     change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+    apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))
   | R =>
     (sos_R || psatz_R d) ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | Q =>
     (sos_Q || psatz_Q d) ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try  (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -53,26 +73,22 @@ Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
 
 Ltac psatzl dom :=
   let tac := lazymatch dom with
-  | Z =>
-    psatzl_Z ;
-    intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-    apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+  | Z => lia
   | Q =>
     psatzl_Q ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try (abstract(intros __wit __varmap __ff ;
         change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
-        apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | R =>
     unfold Rdiv in * ; 
     psatzl_R ;
     (* If csdp is not installed, the previous step might not produce any
     progress: the rest of the tactical will then fail. Hence the 'try'. *)
-    try (intros __wit __varmap __ff ;
+    try abstract((intros __wit __varmap __ff ;
         change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
-        apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+        apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
   | _ => fail "Unsupported domain"
   end in tac.
 
@@ -80,19 +96,6 @@ Ltac psatzl dom :=
 Ltac lra := 
   first [ psatzl R | psatzl Q ].
 
-Ltac lia :=
-  zify ; unfold Z.succ in * ;
-  (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ;
-  intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
-
-Ltac nia :=
-  zify ; unfold Z.succ in * ;
-  xnlia ;
-  intros __wit __varmap __ff ;
-    change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
-      apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
 
 
 (* Local Variables: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index cbd7e334..6c157def 100644
--- a/plugins/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -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        *)
@@ -66,7 +66,7 @@ Require Import EnvRing.
 Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
   match e with
     | PEc c =>  c
-    | PEX j =>  env j
+    | PEX _ j =>  env j
     | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
@@ -78,7 +78,7 @@ Lemma Qeval_expr_simpl : forall env e,
   Qeval_expr env e =
   match e with
     | PEc c =>  c
-    | PEX j =>  env j
+    | PEX _ j =>  env j
     | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
     | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
     | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 65911a72..e9ab6962 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -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        *)
@@ -243,7 +243,6 @@ Proof.
   unfold IQR ; intros.
   simpl.
   repeat rewrite mult_IZR.
-  simpl.  
   rewrite Pos2Nat.inj_mul.
   rewrite mult_INR.
   repeat INR_nat_of_P.
@@ -260,8 +259,8 @@ Proof.
   simpl.
   intros.
   unfold Qinv.
-  destruct x ; simpl in *.
-  destruct Qnum ; simpl.
+  destruct x.
+  destruct Qnum ; simpl in *.
   exfalso. auto with zarith.
   clear H.
   repeat INR_nat_of_P.
diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v
index 6072e582..499a8c4c 100644
--- a/plugins/micromega/Refl.v
+++ b/plugins/micromega/Refl.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index a2136506..a0545637 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -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        *)
@@ -57,7 +57,7 @@ Variables ceqb cleb : C -> C -> bool.
 Variable phi : C -> R.
 
 (* Power coefficients *)
-Variable E : Set. (* the type of exponents *)
+Variable E : Type. (* the type of exponents *)
 Variable pow_phi : N -> E.
 Variable rpow : R -> E -> R.
 
@@ -78,9 +78,9 @@ Record SORaddon := mk_SOR_addon {
 Variable addon : SORaddon.
 
 Add Relation R req
-  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
-  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
-  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
 as micomega_sor_setoid.
 
 Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
@@ -141,8 +141,8 @@ Qed.
 
 Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
 Definition PolEnv := Env R. (* For interpreting PolC *)
-Definition eval_pol (env : PolEnv) (p:PolC) : R :=
-   Pphi rplus rtimes phi env p.
+Definition eval_pol : PolEnv -> PolC -> R :=
+   Pphi rplus rtimes phi.
 
 Inductive Op1 : Set := (* relations with 0 *)
 | Equal (* == 0 *)
@@ -412,12 +412,12 @@ Proof.
   induction e.
   (* PsatzIn *)
   simpl ; intros.
-  destruct (nth_in_or_default n l (Pc cO, Equal)).
+  destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq].
   (* index is in bounds *)
-  apply H ; congruence.
+  apply H. congruence.
   (* index is out-of-bounds *)
   inversion H0.
-  rewrite e. simpl.
+  rewrite Heq. simpl.
   now apply  addon.(SORrm).(morph0).
   (* PsatzSquare *)
   simpl. intros. inversion H0.
@@ -679,7 +679,8 @@ match o with
 | OpGt => fun x y : R => y < x
 end.
 
-Definition  eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe.
+Definition  eval_pexpr : PolEnv -> PExpr C -> R :=
+ PEeval rplus rtimes rminus ropp phi pow_phi rpow.
 
 Record Formula (T:Type) : Type := {
   Flhs : PExpr T;
@@ -910,7 +911,7 @@ Proof.
   unfold pow_N. ring.
 Qed.
 
-Definition denorm (p : Pol C)  := xdenorm xH p.
+Definition denorm := xdenorm xH.
 
 Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
 Proof.
@@ -947,7 +948,7 @@ Variable phi_C_of_S :   forall c,  phiS c =  phi (C_of_S c).
 Fixpoint map_PExpr (e : PExpr S) : PExpr C :=
   match e with
     | PEc c => PEc (C_of_S c)
-    | PEX p => PEX _ p
+    | PEX _ p => PEX _ p
     | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2)
     | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2)
     | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2)
@@ -960,8 +961,8 @@ Definition map_Formula (f : Formula S)  : Formula C :=
     Build_Formula (map_PExpr l) o (map_PExpr r).
 
 
-Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R :=
-  PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e.
+Definition eval_sexpr : PolEnv -> PExpr S -> R :=
+  PEeval rplus rtimes rminus ropp phiS pow_phi rpow.
 
 Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop :=
   let (lhs, op, rhs) := f in
diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v
index a1d200ea..39d0c6b1 100644
--- a/plugins/micromega/Tauto.v
+++ b/plugins/micromega/Tauto.v
@@ -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        *)
@@ -31,10 +31,10 @@ Set Implicit Arguments.
 
   Fixpoint eval_f (A:Type)  (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
     match f with
-      | TT => True
-      | FF => False
+      | TT _ => True
+      | FF _ => False
       | A a =>  ev a
-      | X p => p
+      | X _ p => p
       | Cj e1 e2 => (eval_f  ev e1) /\ (eval_f ev e2)
       | D e1 e2  => (eval_f  ev e1) \/ (eval_f  ev e2)
       | N e     => ~ (eval_f  ev e)
@@ -54,9 +54,9 @@ Set Implicit Arguments.
 
   Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
     match f with
-      | TT => TT _
-      | FF => FF _
-      | X p => X _ p
+      | TT _ => TT _
+      | FF _ => FF _
+      | X _ p => X _ p
       | A a => A (fct a)
       | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
       | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
@@ -172,9 +172,9 @@ Set Implicit Arguments.
 
     Fixpoint xcnf (pol : bool) (f : BFormula Term)  {struct f}: cnf :=
       match f with
-        | TT => if pol then tt else ff
-        | FF => if pol then ff else tt
-        | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
+        | TT _ => if pol then tt else ff
+        | FF _ => if pol then ff else tt
+        | X _ p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
         | A x => if pol then normalise x else negate x
         | N e  => xcnf (negb pol) e
         | Cj e1 e2 =>
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 4391a01b..6e1fe222 100644
--- a/plugins/micromega/VarMap.v
+++ b/plugins/micromega/VarMap.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
index 7f748a0b..4c4b81a0 100644
--- a/plugins/micromega/ZCoeff.v
+++ b/plugins/micromega/ZCoeff.v
@@ -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        *)
@@ -41,19 +41,19 @@ Notation "x < y" := (rlt x y).
 
 Lemma req_refl : forall x, req x x.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (Equivalence_Reflexive,_,_).
   apply Equivalence_Reflexive.
 Qed.
 
 Lemma req_sym : forall x y, req x y -> req y x.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (_,Equivalence_Symmetric,_).
   apply Equivalence_Symmetric.
 Qed.
 
 Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
 Proof.
-  destruct sor.(SORsetoid).
+  destruct sor.(SORsetoid) as (_,_,Equivalence_Transitive).
   apply Equivalence_Transitive.
 Qed.
 
@@ -93,6 +93,7 @@ Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
 Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
 
 Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+Declare Equivalent Keys gen_order_phi_Z gen_phiZ.
 
 Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
 Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index 4aecb39a..84a8d13c 100644
--- a/plugins/micromega/ZMicromega.v
+++ b/plugins/micromega/ZMicromega.v
@@ -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        *)
@@ -62,7 +62,7 @@ Qed.
 Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
   match e with
     | PEc c => c
-    | PEX x => env x
+    | PEX _ x => env x
     | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
     | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
     | PEpow e1 n  => Z.pow (Zeval_expr env e1) (Z.of_N n)
@@ -155,12 +155,16 @@ Proof.
 Qed.
 
 Definition psub  := psub Z0  Z.add Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys psub RingMicromega.psub.
 
 Definition padd  := padd Z0  Z.add Zeq_bool.
+Declare Equivalent Keys padd RingMicromega.padd.
 
 Definition norm  := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool.
+Declare Equivalent Keys norm RingMicromega.norm.
 
 Definition eval_pol := eval_pol Z.add Z.mul (fun x => x).
+Declare Equivalent Keys eval_pol RingMicromega.eval_pol.
 
 Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
 Proof.
@@ -202,11 +206,10 @@ Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
 
 Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t.
 Proof.
-  Opaque padd.
-  unfold normalise, xnormalise  ; simpl; intros env t.
+  unfold normalise, xnormalise; cbn -[padd]; intros env t.
   rewrite Zeval_formula_compat.
   unfold eval_cnf, eval_clause.
-  destruct t as [lhs o rhs]; case_eq o; simpl;
+  destruct t as [lhs o rhs]; case_eq o; cbn -[padd];
     repeat rewrite eval_pol_sub;
       repeat rewrite eval_pol_add;
       repeat rewrite <- eval_pol_norm ; simpl in *;
@@ -216,7 +219,6 @@ Proof.
   generalize (eval_pexpr  Z.add Z.mul Z.sub Z.opp (fun x : Z => x)
     (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst;
     intuition (auto with zarith).
-  Transparent padd.
 Qed.
 
 Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
@@ -317,7 +319,7 @@ Qed.
 
 Require Import QArith.
 
-Inductive ZArithProof : Type :=
+Inductive ZArithProof :=
 | DoneProof
 | RatProof : ZWitness -> ZArithProof -> ZArithProof
 | CutProof : ZWitness -> ZArithProof -> ZArithProof
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index 32aeb993..b4f305dd 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.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        *)
@@ -76,7 +76,7 @@ let dev_form n_spec  p =
       let p = dev_form p in
       let n = C2Ml.n n in
       let rec pow n = 
-       if n = 0 
+       if Int.equal n 0 
        then Poly.constant (n_spec.number_to_num n_spec.unit)
        else Poly.product p (pow (n-1)) in
        pow n in
@@ -87,8 +87,8 @@ let monomial_to_polynomial mn =
  Monomial.fold 
   (fun v i acc -> 
      let v = Ml2C.positive v in
-     let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
-       if acc = Mc.PEc (Mc.Zpos Mc.XH)
+     let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+       if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
        then mn 
        else Mc.PEmul(mn,acc))
    mn 
@@ -105,10 +105,10 @@ let list_to_polynomial vars l =
   | c::l -> if c =/  (Int 0) then xtopoly p (i+1) l 
     else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
     let mn = 
-     if c =  Mc.PEc (Mc.Zpos Mc.XH)
+     if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
      then var i
      else Mc.PEmul (c,var i) in
-    let p' = if p = Mc.PEc Mc.Z0 then mn else
+    let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else
       Mc.PEadd (mn, p) in
      xtopoly p' (i+1) l in
   
@@ -116,7 +116,7 @@ let list_to_polynomial vars l =
 
 let rec fixpoint f x =
  let y' = f x in
-  if y' = x then y'
+  if Pervasives.(=) y' x then y'
   else fixpoint f y'
 
 let  rec_simpl_cone n_spec e = 
@@ -153,9 +153,9 @@ let factorise_linear_cone c =
  let factorise c1 c2 =
   match c1 , c2 with
    | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> 
-      if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+      if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
    | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> 
-      if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+      if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
    |  _     -> None in
   
  let rec rebuild_cone l pending  =
@@ -199,7 +199,7 @@ open Mfourier
 
 let constrain_monomial mn l  = 
  let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
-  if mn = Monomial.const
+  if Pervasives.(=) mn Monomial.const
   then  
    { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; 
      op = Eq ; 
@@ -230,6 +230,7 @@ let string_of_op = function
  | Mc.NonEqual -> "<> 0"
 
 
+module MonSet = Set.Make(Monomial)
 
 (* If the certificate includes at least one strict inequality, 
    the obtained polynomial can also be 0 *)
@@ -238,8 +239,6 @@ let build_linear_system l =
  (* Gather the monomials:  HINT add up of the polynomials ==> This does not work anymore *)
  let l' = List.map fst l in
 
- let module MonSet = Set.Make(Monomial) in
-
  let monomials = 
   List.fold_left (fun acc p -> 
                     Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) 
@@ -299,27 +298,28 @@ exception Found of Monomial.t
 
 exception Strict
 
+module MonMap = Map.Make(Monomial)
+
 let primal l = 
   let vr = ref 0 in
-  let module Mmn = Map.Make(Monomial) in
 
   let vect_of_poly map p =
     Poly.fold (fun mn vl (map,vect) -> 
-      if mn = Monomial.const 
+      if Pervasives.(=) mn Monomial.const 
       then (map,vect)
       else 
-	let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in
-	  (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in
+	let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
+	  (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
     
   let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
 
-  let cmp x y = Pervasives.compare (fst x) (fst y) in
+  let cmp x y = Int.compare (fst x) (fst y) in
 
    snd (List.fold_right (fun  (p,op) (map,l) ->
       let (mp,vect) = vect_of_poly map p in  
       let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
 
-	(mp,cstr::l)) l (Mmn.empty,[]))
+	(mp,cstr::l)) l (MonMap.empty,[]))
 
 let dual_raw_certificate (l:  (Poly.t * Mc.op1) list) = 
 (*  List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
@@ -332,8 +332,8 @@ let dual_raw_certificate (l:  (Poly.t * Mc.op1) list) =
     | Inl cert ->  Some (rats_to_ints (Vect.to_list cert)) 
        (* should not use rats_to_ints *)
   with x when Errors.noncritical x ->
-   if debug 
-   then (Printf.printf "raw certificate %s" (Printexc.to_string x);   
+   if debug
+   then (Printf.printf "raw certificate %s" (Printexc.to_string x);
          flush stdout) ;
    None
 
@@ -367,7 +367,7 @@ let linear_prover n_spec l  =
   let build_system n_spec l = 
     let li = List.combine l (interval 0 (List.length l -1)) in
     let (l1,l') = List.partition 
-      (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in
+      (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
       List.map 
 	(fun ((x,y),i) -> match y with
              Mc.NonEqual -> failwith "cannot happen"
@@ -378,7 +378,7 @@ let linear_prover n_spec l  =
 
 let linear_prover n_spec l  =
  try linear_prover n_spec l
- with x when x <> Sys.Break ->
+ with x when Errors.noncritical x ->
    (print_string (Printexc.to_string x); None)
 
 let linear_prover_with_cert spec l = 
@@ -394,7 +394,7 @@ let make_linear_system l =
  let monomials = List.fold_left (fun acc p -> Poly.addition p acc) 
   (Poly.constant (Int 0)) l' in
  let monomials = Poly.fold 
-  (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in
+  (fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in
   (List.map (fun (c,op) -> 
    {coeffs = Vect.from_list (List.map (fun mn ->  (Poly.get mn c)) monomials) ; 
     op = op ; 
@@ -406,9 +406,7 @@ let pplus x y = Mc.PEadd(x,y)
 let pmult x y = Mc.PEmul(x,y)
 let pconst x = Mc.PEc x
 let popp x = Mc.PEopp x
- 
-let debug = false
- 
+
 (* keep track of enumerated vectors *)
 let rec mem p x  l = 
  match l with  [] -> false | e::l -> if p x e then true else mem p x l
@@ -417,7 +415,7 @@ let rec remove_assoc p x l =
  match l with [] -> [] | e::l -> if p x (fst e) then
   remove_assoc p x l else e::(remove_assoc p x l) 
 
-let eq x y = Vect.compare x y = 0
+let eq x y = Int.equal (Vect.compare x y) 0
 
 let  remove e  l  = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
 
@@ -477,7 +475,7 @@ let rec scale_term t =
     let s1' = div_big_int s1 g in
     let s2' = div_big_int s2 g in
     let e = mult_big_int g (mult_big_int s1' s2') in
-     if (compare_big_int e unit_big_int) = 0
+     if Int.equal (compare_big_int e unit_big_int) 0
      then (unit_big_int, Add (y1,y2))
      else 	e, Add (Mul(Const (Big_int s2'), y1),
 		       Mul (Const (Big_int s1'), y2))
@@ -499,7 +497,7 @@ let get_index_of_ith_match f i l  =
    | [] -> failwith "bad index"
    | e::l -> if f e
      then 
-       (if j = i then res else get (j+1) (res+1) l )
+       (if Int.equal j i then res else get (j+1) (res+1) l )
      else get j (res+1) l in
   get 0 0 l
 
@@ -559,7 +557,7 @@ let  q_cert_of_pos  pos =
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
       Mc.PsatzC (Ml2C.q   n)
   | Square t -> Mc.PsatzSquare (term_to_q_pol  t)
   | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
@@ -590,7 +588,7 @@ let  z_cert_of_pos  pos =
   | Axiom_lt i ->  Mc.PsatzIn (Ml2C.nat i)
   | Monoid l  -> product l
   | Rational_eq n | Rational_le n | Rational_lt n -> 
-     if compare_num n (Int 0) = 0 then Mc.PsatzZ else
+     if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
       Mc.PsatzC (Ml2C.bigint (big_int_of_num  n))
   | Square t -> Mc.PsatzSquare (term_to_z_pol  t)
   | Eqmul (t, y) -> 
@@ -631,7 +629,7 @@ struct
     let rec xid_of_hyp i l = 
       match l with
       | [] -> failwith "id_of_hyp"
-      | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in
+      | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
       xid_of_hyp 0 l
 
 end
@@ -757,7 +755,7 @@ let check_sat (cstr,prf) =
 	  if eq_num gcd (Int 1)
 	  then Normalise(cstr,prf) 
 	  else
-	    if sign_num (mod_num cst gcd) = 0
+	    if Int.equal (sign_num (mod_num cst gcd)) 0
 	    then (* We can really normalise *)
 	      begin
 		assert (sign_num gcd >=1 ) ;
@@ -797,18 +795,18 @@ let pivot v (c1,p1) (c2,p2) =
     match Vect.get v v1 , Vect.get v v2 with
     | None , _ | _ , None -> None
     | Some a   , Some b   ->
-	if (sign_num a) * (sign_num b) = -1
+	if Int.equal ((sign_num a) * (sign_num b)) (-1)
 	then 
 	  let cv1 = abs_num b 
 	  and cv2 = abs_num a  in
 	    Some (xpivot cv1 cv2)
 	else 
-	  if op1 = Eq
+	  if op1 == Eq
           then 
 	    let cv1 = minus_num (b */ (Int (sign_num a)))
 	    and cv2 = abs_num a in
 	      Some (xpivot cv1 cv2)
-          else if op2 = Eq
+          else if op2 == Eq
 	  then
 	    let cv1 = abs_num b 
 	    and cv2 = minus_num (a */ (Int  (sign_num b))) in
@@ -817,7 +815,7 @@ let pivot v (c1,p1) (c2,p2) =
 	    
 exception FoundProof of  prf_rule
 
-let rec simpl_sys sys = 
+let simpl_sys sys = 
   List.fold_left (fun acc (c,p) -> 
 		    match check_sat (c,p) with
 		    | Tauto -> acc
@@ -831,7 +829,7 @@ let rec simpl_sys sys =
     Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
 *)
 let rec ext_gcd a b = 
-  if sign_big_int b = 0 
+  if Int.equal (sign_big_int b) 0 
   then (unit_big_int,zero_big_int)
   else
     let (q,r) = quomod_big_int a b in
@@ -852,7 +850,7 @@ let pp_ext_gcd a b =
 exception Result of (int * (proof * cstr_compat))
 
 let split_equations psys = 
-  List.partition (fun (c,p) -> c.op = Eq)
+  List.partition (fun (c,p) -> c.op == Eq)
 
 
 let extract_coprime (c1,p1) (c2,p2) = 
@@ -860,9 +858,9 @@ let extract_coprime (c1,p1) (c2,p2) =
     match vect1 , vect2 with
     | _ , [] | [], _ -> None
     | (v1,n1)::vect1' , (v2, n2) :: vect2' -> 
-	if v1 = v2
+	if Pervasives.(=) v1 v2
 	then 
-	  if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int  = 0
+	  if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
 	  then Some (v1,n1,n2)
 	  else 
 	    exist2 vect1' vect2'
@@ -871,7 +869,7 @@ let extract_coprime (c1,p1) (c2,p2) =
 	  then exist2 vect1' vect2
 	  else exist2 vect1 vect2' in
     
-    if c1.op = Eq && c2.op = Eq 
+    if c1.op == Eq && c2.op == Eq 
     then exist2 c1.coeffs c2.coeffs
     else None
 
@@ -928,7 +926,7 @@ let reduce_coprime psys =
 (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
 let reduce_unary psys = 
   let is_unary_equation (cstr,prf) = 
-    if cstr.op = Eq 
+    if cstr.op == Eq 
     then 
       try 
 	Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
@@ -944,12 +942,12 @@ let reduce_unary psys =
 let reduce_non_lin_unary psys = 
 
   let is_unary_equation (cstr,prf) = 
-    if cstr.op = Eq 
+    if cstr.op == Eq 
     then 
       try 
 	let x = fst (List.find (fun (x,n) ->  (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
 	let x' = LinPoly.MonT.retrieve x in
-	  if List.for_all (fun (y,_) -> y = x  || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs 
+	  if List.for_all (fun (y,_) -> Pervasives.(=) y x  || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs 
 	  then Some x
 	  else None
       with Not_found -> None
@@ -976,7 +974,7 @@ let reduce_var_change psys =
 	       Some ((x,v),(x',numerator v'))
 	   with Not_found -> rel_prime vect in
 
-  let rel_prime (cstr,prf) =  if cstr.op = Eq then rel_prime cstr.coeffs else None in
+  let rel_prime (cstr,prf) =  if cstr.op == Eq then rel_prime cstr.coeffs else None in
 
   let (oeq,sys) = extract rel_prime psys in
     
@@ -1007,7 +1005,7 @@ let reduce_var_change psys =
 
   let reduce_pivot psys = 
     let is_equation (cstr,prf) = 
-      if cstr.op = Eq
+      if cstr.op == Eq
       then
 	try 
 	  Some (fst (List.hd cstr.coeffs))
@@ -1067,7 +1065,7 @@ let reduce_var_change psys =
     (* For lia, there are no equations => these precautions are not needed *)
     (* For nlia, there are equations => do not enumerate over equations! *)
     let all_planes sys = 
-      let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in
+      let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
 	match eq with
 	  | [] -> List.rev_map (fun c -> c.coeffs) ineq
 	  | _  -> 
@@ -1197,8 +1195,6 @@ let reduce_var_change psys =
 
     let is_linear =  List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
 
-    let module MonMap = Map.Make(Monomial) in
-
     let collect_square = 
       List.fold_left (fun acc ((p,_),_) -> Poly.fold 
 			(fun m _ acc -> 
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 7e10464a..2812e36e 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.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        *)
@@ -16,6 +16,7 @@
 (*                                                                      *)
 (************************************************************************)
 
+open Pp
 open Mutils
 
 (**
@@ -44,7 +45,7 @@ type tag = Tag.t
 
 (**
   * An atom is of the form:
-  *   pExpr1 {<,>,=,<>,<=,>=} pExpr2
+  *   pExpr1 \{<,>,=,<>,<=,>=\} pExpr2
   * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are
   * parametrized by 'cst, which is used as the type of constants.
   *)
@@ -65,7 +66,7 @@ type 'cst formula =
   | C of 'cst formula * 'cst formula
   | D of 'cst formula * 'cst formula
   | N of 'cst formula
-  | I of 'cst formula * Names.identifier option * 'cst formula
+  | I of 'cst formula * Names.Id.t option * 'cst formula
 
 (**
   * Formula pretty-printer.
@@ -82,7 +83,7 @@ let rec pp_formula o f =
     | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)"
 	pp_formula f1
 	  (match n with
-	    | Some id -> Names.string_of_id id
+	    | Some id -> Names.Id.to_string id
 	    | None -> "") pp_formula f2
     | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
 
@@ -111,7 +112,7 @@ let rec ids_of_formula f =
 (**
   * A clause is a list of (tagged) nFormulas.
   * nFormulas are normalized formulas, i.e., of the form:
-  *   cPol {=,<>,>,>=} 0
+  *   cPol \{=,<>,>,>=\} 0
   * with cPol compact polynomials (see the Pol inductive type in EnvRing.v).
   *)
 
@@ -242,10 +243,10 @@ let rec add_term  t0 = function
   * MODULE: Ordered set of integers.
   *)
 
-module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+module ISet = Set.Make(Int)
 
 (**
-  * Given a set of integers s={i0,...,iN} and a list m, return the list of
+  * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of
   * elements of m that are at position i0,...,iN.
   *)
 
@@ -535,10 +536,10 @@ struct
 
   let get_left_construct term =
    match Term.kind_of_term term with
-    | Term.Construct(_,i) -> (i,[| |])
+    | Term.Construct((_,i),_) -> (i,[| |])
     | Term.App(l,rst) ->
        (match Term.kind_of_term l with
-        | Term.Construct(_,i) -> (i,rst)
+        | Term.Construct((_,i),_) -> (i,rst)
         |   _     -> raise ParseError
        )
     | _ ->   raise ParseError
@@ -577,7 +578,7 @@ struct
 
   let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
 
-  let rec dump_n x =
+  let dump_n x =
    match x with
     | Mc.N0 -> Lazy.force coq_N0
     | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
@@ -590,12 +591,12 @@ struct
 
   let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x)
 
-  let rec pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
+  let pp_n o x =  output_string o  (string_of_int (CoqToCaml.n x))
 
   let dump_pair t1 t2 dump_t1 dump_t2 (x,y) =
    Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
 
-  let rec parse_z term =
+  let parse_z term =
    let (i,c) = get_left_construct term in
     match i with
      | 1 -> Mc.Z0
@@ -622,7 +623,7 @@ struct
 
   let parse_q term =
      match Term.kind_of_term term with
-       | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
+       | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then
              {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
        else raise ParseError
    |  _ -> raise ParseError
@@ -780,7 +781,7 @@ struct
         Printf.fprintf o "0" in
     pp_cone o e
 
-  let rec dump_op = function
+  let dump_op = function
    | Mc.OpEq-> Lazy.force coq_OpEq
    | Mc.OpNEq-> Lazy.force coq_OpNEq
    | Mc.OpLe -> Lazy.force coq_OpLe
@@ -808,7 +809,7 @@ struct
 
   let assoc_const x l =
    try
-   snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+   snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l)
    with
      Not_found -> raise ParseError
 
@@ -830,25 +831,33 @@ struct
    coq_Qeq, Mc.OpEq
   ]
 
-  let parse_zop (op,args) =
+  let has_typ gl t1 typ = 
+   let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in
+   Constr.equal ty typ
+
+
+  let is_convertible gl t1 t2 = 
+   Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2
+
+  let parse_zop gl (op,args) =
    match kind_of_term op with
-    | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
-    |  Ind(n,0) ->
-        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_Z
+    | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1))
+    | Ind((n,0),_) ->
+        if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z)
         then (Mc.OpEq, args.(1), args.(2))
         else raise ParseError
     |   _ -> failwith "parse_zop"
 
-  let parse_rop (op,args) =
+  let parse_rop gl (op,args) =
     match kind_of_term op with
-     | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
-     |  Ind(n,0) ->
-        if op = Lazy.force coq_Eq &&   args.(0) = Lazy.force coq_R
+     | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1))
+     | Ind((n,0),_) ->
+        if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R)
         then (Mc.OpEq, args.(1), args.(2))
         else raise ParseError
     |   _ -> failwith "parse_zop"
 
-  let parse_qop (op,args) =
+  let parse_qop gl (op,args) =
     (assoc_const op qop_table, args.(0) , args.(1))
 
   let is_constant t = (* This is an approx *)
@@ -864,7 +873,7 @@ struct
 
   let assoc_ops x l =
    try
-     snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+     snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l)
    with
      Not_found -> Ukn "Oups"
 
@@ -901,10 +910,7 @@ struct
 
   let parse_expr parse_constant parse_exp ops_spec env term =
     if debug
-    then (Pp.pp (Pp.str "parse_expr: ");
-          Pp.pp (Printer.prterm term);
-          Pp.pp (Pp.str "\n");
-          Pp.pp_flush ());
+    then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
 
 (*
     let constant_or_variable env term =
@@ -941,7 +947,7 @@ struct
                            let (expr,env) = parse_expr env args.(0) in
                            let power = (parse_exp expr args.(1)) in
                              (power  , env)
-			 with e when e <> Sys.Break ->
+			 with e when Errors.noncritical e ->
                            (* if the exponent is a variable *)
                            let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
                        end
@@ -994,9 +1000,9 @@ struct
   let rec rconstant term =
    match Term.kind_of_term term with
     | Const x ->
-        if term = Lazy.force coq_R0
+        if Constr.equal term (Lazy.force coq_R0)
         then Mc.C0
-        else if term = Lazy.force coq_R1
+        else if Constr.equal term (Lazy.force coq_R1)
         then Mc.C1
         else raise ParseError
     | App(op,args) -> 
@@ -1010,8 +1016,8 @@ struct
 	  with
 	      ParseError -> 
 		match op with
-		  | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0))
-		  | op when op = Lazy.force coq_IQR  -> Mc.CQ (parse_q args.(0))
+		  | op when Constr.equal op (Lazy.force coq_Rinv) -> Mc.CInv(rconstant args.(0))
+		  | op when Constr.equal op (Lazy.force coq_IQR)  -> Mc.CQ (parse_q args.(0))
 (*		  | op when op = Lazy.force coq_IZR  -> Mc.CZ (parse_z args.(0))*)
 		  | _ ->  raise ParseError
 	end
@@ -1021,11 +1027,7 @@ struct
 
   let rconstant term = 
     if debug
-    then (Pp.pp_flush ();
-          Pp.pp (Pp.str "rconstant: ");
-          Pp.pp (Printer.prterm  term);
-          Pp.pp (Pp.str "\n");
-          Pp.pp_flush ());
+    then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ());
     let res = rconstant term in
       if debug then 
 	(Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ;
@@ -1063,26 +1065,22 @@ struct
         Mc.PEpow(expr,exp))
    rop_spec
 
-  let  parse_arith parse_op parse_expr env cstr =
+  let  parse_arith parse_op parse_expr env cstr gl =
    if debug
-   then (Pp.pp_flush ();
-         Pp.pp (Pp.str "parse_arith: ");
-         Pp.pp (Printer.prterm  cstr);
-         Pp.pp (Pp.str "\n");
-         Pp.pp_flush ());
+   then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm  cstr ++ fnl ());
    match kind_of_term cstr with
     | App(op,args) ->
-       let (op,lhs,rhs) = parse_op (op,args) in
+       let (op,lhs,rhs) = parse_op gl (op,args) in
        let (e1,env) = parse_expr env lhs in
        let (e2,env) = parse_expr env rhs in
         ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
     |  _ -> failwith "error : parse_arith(2)"
 
-  let parse_zarith = parse_arith  parse_zop parse_zexpr
+  let parse_zarith = parse_arith parse_zop parse_zexpr
 
-  let parse_qarith = parse_arith  parse_qop parse_qexpr
+  let parse_qarith = parse_arith parse_qop parse_qexpr
 
-  let parse_rarith = parse_arith  parse_rop parse_rexpr
+  let parse_rarith = parse_arith parse_rop parse_rexpr
 
   (* generic parsing of arithmetic expressions *)
 
@@ -1115,14 +1113,13 @@ struct
     * This is the big generic function for formula parsers.
     *)
   
-  let parse_formula parse_atom env tg term =
+  let parse_formula gl parse_atom env tg term =
 
     let parse_atom env tg t =
       try
-        let (at,env) = parse_atom env t in
+        let (at,env) = parse_atom env t gl in
         (A(at,tg,t), env,Tag.next tg)
-      with e when e <> Sys.Break -> (X(t),env,tg)
-    in
+      with e when Errors.noncritical e -> (X(t),env,tg) in
 
     let rec xparse_formula env tg term =
      match kind_of_term term with
@@ -1177,7 +1174,7 @@ struct
     | (e::l) ->
        let (name,expr,typ) = e in
         xset (Term.mkNamedLetIn
-               (Names.id_of_string name)
+               (Names.Id.of_string name)
                expr typ acc) l in
     xset concl l
 
@@ -1199,13 +1196,13 @@ let same_proof sg cl1 cl2 =
   match sg with
    | [] -> true
    | n::sg ->
-     (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false)
+     (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false)
       && (xsame_proof sg ) in
   xsame_proof sg
 
 let tags_of_clause tgs wit clause =
  let rec xtags tgs = function
-  | Mc.PsatzIn n -> Names.Idset.union tgs
+  | Mc.PsatzIn n -> Names.Id.Set.union tgs
      (snd (List.nth clause (CoqToCaml.nat n) ))
   | Mc.PsatzMulC(e,w) -> xtags tgs w
   | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2
@@ -1214,7 +1211,7 @@ let tags_of_clause tgs wit clause =
 
 (*let tags_of_cnf wits cnf =
  List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
-  Names.Idset.empty wits cnf *)
+  Names.Id.Set.empty wits cnf *)
 
 let find_witness prover polys1 = try_any prover polys1
 
@@ -1263,7 +1260,7 @@ let btree_of_array typ a  =
 let btree_of_array typ a =
  try
   btree_of_array typ a
- with x when x <> Sys.Break ->
+ with x when Errors.noncritical x ->
   failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
 
 let dump_varmap typ env =
@@ -1324,24 +1321,24 @@ let rec pp_proof_term o = function
 	(pp_psatz pp_z) c1 (pp_psatz pp_z) c2
      (pp_list "[" "]" pp_proof_term) rst
 
-let rec parse_hyps parse_arith env tg hyps =
+let rec parse_hyps gl parse_arith env tg hyps =
  match hyps with
   | [] -> ([],env,tg)
   | (i,t)::l ->
-     let (lhyps,env,tg) = parse_hyps parse_arith env tg l in
+     let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in
       try
-       let (c,env,tg) = parse_formula parse_arith env  tg t in
+       let (c,env,tg) = parse_formula gl parse_arith env  tg t in
 	((i,c)::lhyps, env,tg)
-      with e when e <> Sys.Break -> 		(lhyps,env,tg)
+      with e when Errors.noncritical e -> (lhyps,env,tg)
        (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
 
 
 (*exception ParseError*)
 
-let parse_goal parse_arith env hyps term =
+let parse_goal gl parse_arith env hyps term =
  (*  try*)
- let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in
- let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in
+ let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in
+ let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in
   (lhyps,f,env)
    (*  with Failure x -> raise ParseError*)
 
@@ -1385,22 +1382,31 @@ let rcst_domain_spec  = lazy {
   * witness.
   *)
 
-let micromega_order_change spec cert cert_typ env ff gl =
+
+
+let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic = 
+ let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in 
  let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in
- let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
+ let ff  = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
  let vm = dump_varmap (spec.typ) env in
-  Tactics.change_in_concl None
+ (* todo : directly generate the proof term - or generalize befor conversion? *)
+ Tacticals.tclTHENSEQ [
+  (fun gl -> 
+   Proofview.V82.of_tactic (Tactics.change_concl
    (set
      [
       ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
       ("__varmap", vm, Term.mkApp
        (Coqlib.gen_constant_in_modules "VarMap"
-	 [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|]));
+	 [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); 
       ("__wit", cert, cert_typ)
      ]
-     (Tacmach.pf_concl gl)
-   )
-   gl
+     (Tacmach.pf_concl gl))) gl);
+  Tactics.generalize env ;
+  Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ; 
+ ] 
+
+
 
 (**
   * The datastructures that aggregate prover attributes.
@@ -1476,7 +1482,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
           (pp_ml_list prover.pp_f) (List.map fst new_cl)   ;
           flush stdout
       end ; *)
-    let res = try prover.compact prf remap with x when x <> Sys.Break ->
+    let res = try prover.compact prf remap with x when Errors.noncritical x ->
       if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
       (* This should not happen -- this is the recovery plan... *)
       match prover.prover (List.map fst new_cl) with
@@ -1494,7 +1500,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
   let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
     let hyps_idx = prover.hyps prf in
     let hyps = selecti hyps_idx old_cl in
-      is_sublist hyps new_cl in
+      is_sublist Pervasives.(=) hyps new_cl in
 
   let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
 
@@ -1644,7 +1650,7 @@ let micromega_gen
   let concl = Tacmach.pf_concl gl in
   let hyps  = Tacmach.pf_hyps_types gl in
   try
-   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
    let env = Env.elements env in
    let spec = Lazy.force spec in
 
@@ -1658,8 +1664,6 @@ let micromega_gen
 		  (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
 	      ]) gl
   with
-(*   | Failure x -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str x) gl *)
    | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
    | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
       Tacticals.tclFAIL 0 (Pp.str 
@@ -1679,7 +1683,7 @@ let micromega_order_changer cert env ff gl =
  let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
  let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
  let vm = dump_varmap (typ) env in
-  Tactics.change_in_concl None
+  Proofview.V82.of_tactic (Tactics.change_concl
    (set
      [
       ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
@@ -1689,7 +1693,7 @@ let micromega_order_changer cert env ff gl =
       ("__wit", cert, cert_typ)
      ]
      (Tacmach.pf_concl gl)
-   )
+   ))
    gl
 
 
@@ -1710,7 +1714,7 @@ let micromega_genr prover gl =
   let concl = Tacmach.pf_concl gl in
   let hyps  = Tacmach.pf_hyps_types gl in
   try
-   let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in
+   let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
    let env = Env.elements env in
    let spec = Lazy.force spec in
 
@@ -1729,8 +1733,6 @@ let micromega_genr prover gl =
                 micromega_order_changer res' env (abstract_wrt_formula ff' ff)
               ]) gl
   with
-(*   | Failure x -> flush stdout ; Pp.pp_flush () ;
-      Tacticals.tclFAIL 0 (Pp.str x) gl *)
    | ParseError  -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
    | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
       Tacticals.tclFAIL 0 (Pp.str 
@@ -1760,7 +1762,7 @@ open Persistent_cache
 
 module Cache = PHashtable(struct
   type t = (provername * micromega_polys)
-  let equal = (=)
+  let equal = Pervasives.(=)
   let hash  = Hashtbl.hash
 end)
 
@@ -1954,7 +1956,7 @@ let non_linear_prover_Z str o  = {
 
 module CacheZ = PHashtable(struct
   type t = (Mc.z Mc.pol * Mc.op1) list
-  let equal = (=)
+  let equal = Pervasives.(=)
   let hash  = Hashtbl.hash
 end)
 
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
index b5c08300..b41f29c9 100644
--- a/plugins/micromega/csdpcert.ml
+++ b/plugins/micromega/csdpcert.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        *)
@@ -12,13 +12,11 @@
 (*                                                                      *)
 (************************************************************************)
 
-open Big_int
 open Num
 open Sos
 open Sos_types
 open Sos_lib
 
-
 module Mc = Micromega
 module Ml2C = Mutils.CamlToCoq
 module C2Ml = Mutils.CoqToCaml
@@ -55,13 +53,12 @@ struct
 end
 open M
 
-open List
 open Mutils
 
 
 
 
-let rec canonical_sum_to_string = function s -> failwith "not implemented"
+let canonical_sum_to_string = function s -> failwith "not implemented"
 
 let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
 
@@ -122,7 +119,7 @@ let real_nonlinear_prover d l =
     match kd with
      | Axiom_lt i -> poly_mul p y
      | Axiom_eq i -> poly_mul (poly_pow p 2) y
-     |   _        -> failwith "monoids") m (poly_const (Int 1)) , map  snd m))
+     |   _        -> failwith "monoids") m (poly_const (Int 1)) , List.map snd m))
    (sets_of_list neq) in
 
   let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
@@ -130,10 +127,10 @@ let real_nonlinear_prover d l =
     real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
 		      (ci,cc,snd m)) monoids) 0 in
 
-  let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
+  let proofs_ideal = List.map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
    cert_ideal (List.map snd eq) in
 
-  let proofs_cone = map term_of_sos cert_cone in
+  let proofs_cone = List.map term_of_sos cert_cone in
 
   let proof_ne =
    let (neq , lt) = List.partition
@@ -150,7 +147,7 @@ let real_nonlinear_prover d l =
    S (Some proof)
  with
   | Sos_lib.TooDeep -> S None
-  | x when x <> Sys.Break -> F (Printexc.to_string x)
+  | any -> F (Printexc.to_string any)
 
 (* This is somewhat buggy, over Z, strict inequality vanish... *)
 let pure_sos  l =
@@ -159,8 +156,8 @@ let pure_sos  l =
  (* If there is no strict inequality,
     I should nonetheless be able to try something - over Z  > is equivalent to -1  >= *)
  try
-  let l = List.combine l (interval 0 (length l -1)) in
-  let (lt,i) =  try (List.find (fun (x,_) -> snd x =  Mc.Strict) l)
+  let l = List.combine l (interval 0 (List.length l -1)) in
+  let (lt,i) =  try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l)
    with Not_found -> List.hd l in
   let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
   let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
@@ -174,7 +171,7 @@ let pure_sos  l =
     S (Some proof)
  with
 (*   | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
-   | x when x <> Sys.Break -> (* May be that could be refined *) S None
+   | any -> (* May be that could be refined *) S None
 
 
 
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 4270d5bb..1ac44a42 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -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        *)
@@ -14,65 +14,65 @@
 (*                                                                      *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Quote
-open Ring
-open Mutils
-open Glob_term
-open Util
+open Errors
+open Misctypes
+
+DECLARE PLUGIN "micromega_plugin"
 
 let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
   | ArgArg x -> x
 
 TACTIC EXTEND PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ]
-| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
+| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ]
+| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ]
 END
 
-TACTIC EXTEND ZOmicron
-[ "xlia"  ] -> [ Coq_micromega.xlia]
+TACTIC EXTEND Lia
+[ "xlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xlia) ]
 END
 
-TACTIC EXTEND Nlia
-[ "xnlia"  ] -> [ Coq_micromega.xnlia]
+TACTIC EXTEND Nia
+[ "xnlia"  ] -> [  Proofview.V82.tactic (Coq_micromega.xnlia) ]
 END
 
 
 
 TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
+| [ "sos_Z" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Z) ]
    END
 
 TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Coq_micromega.sos_Q]
+| [ "sos_Q" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_Q) ]
    END
 
 TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Coq_micromega.sos_R]
+| [ "sos_R" ] -> [  Proofview.V82.tactic (Coq_micromega.sos_R) ]
 END
 
-
+(*
 TACTIC EXTEND Omicron
-[ "psatzl_Z"  ] -> [ Coq_micromega.psatzl_Z]
+[ "psatzl_Z"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Z) ]
 END
+*)
 
-TACTIC EXTEND QOmicron
-[ "psatzl_Q"  ] -> [ Coq_micromega.psatzl_Q]
+TACTIC EXTEND LRA_Q
+[ "psatzl_Q"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_Q) ]
 END
 
-TACTIC EXTEND ROmicron
-[ "psatzl_R"  ] -> [ Coq_micromega.psatzl_R]
+TACTIC EXTEND LRA_R
+[ "psatzl_R"  ] -> [  Proofview.V82.tactic (Coq_micromega.psatzl_R) ]
 END
 
-TACTIC EXTEND RMicromega
-| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ]
-| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
+TACTIC EXTEND PsatzR
+| [ "psatz_R" int_or_var(i) ] -> [  Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ]
+| [ "psatz_R" ] -> [  Proofview.V82.tactic (Coq_micromega.psatz_R (-1)) ]
 END
 
-TACTIC EXTEND QMicromega
-| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
-| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
+TACTIC EXTEND PsatzQ
+| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ]
+| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ]
 END
 
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index 6effa4c4..88c1a783 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -3,13 +3,14 @@ module Utils = Mutils
 open Polynomial
 open Vect
 
-
 let map_option = Utils.map_option
 let from_option = Utils.from_option
 
 let debug = false
 type ('a,'b) lr = Inl of 'a | Inr of 'b
 
+let compare_float (p : float) q = Pervasives.compare p q
+
 (** Implementation of intervals *)
 module Itv =
 struct
@@ -18,10 +19,10 @@ struct
   type interval = num option * num option
       (** None models the absence of bound i.e. infinity *)
       (** As a result,
-	  - None , None   -> ]-oo,+oo[
-	  - None , Some v -> ]-oo,v]
-	  - Some v, None  -> [v,+oo[
-	  - Some v, Some v' -> [v,v']
+	  - None , None   -> \]-oo,+oo\[
+	  - None , Some v -> \]-oo,v\]
+	  - Some v, None  -> \[v,+oo\[
+	  - Some v, Some v' -> \[v,v'\]
       Intervals needs to be explicitely normalised.
       *)
 
@@ -89,7 +90,7 @@ type vector = Vect.t
     {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r
 **)
 
-module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end)
+module ISet = Set.Make(Int)
 
 
 module PSet = ISet
@@ -116,7 +117,7 @@ and cstr_info = {
 }
 
 
-(** A system of constraints has the form [{sys = s ; vars = v}].
+(** A system of constraints has the form [\{sys = s ; vars = v\}].
     [s] is a hashtable mapping a normalised vector to a [cstr_info] record where
     - [bound] is an interval
     - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint.
@@ -195,7 +196,7 @@ let pp_split_cstr o (vl,v,c,_) =
 let merge_cstr_info i1 i2 =
   let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
   and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
-    assert (p1 = p2 && n1 = n2) ;
+    assert (Int.equal p1 p2 && Int.equal n1 n2) ;
     match inter i1 i2 with
       | None -> None (* Could directly raise a system contradiction exception *)
       | Some bnd ->
@@ -207,7 +208,7 @@ let merge_cstr_info i1 i2 =
 *)
 
 let xadd_cstr vect cstr_info sys =
-  if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ;
+  if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
   try
     let info = System.find sys vect in
       match merge_cstr_info cstr_info !info with
@@ -235,7 +236,7 @@ let normalise_cstr vect cinfo =
 	  | (_,n)::_ ->  Cstr(
 	      (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect),
 			     let divn x = x // n in
-			       if sign_num n = 1
+			       if Int.equal (sign_num n) 1
 			       then{cinfo with bound = (map_option divn l , map_option  divn r) }
 			       else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)})
 
@@ -252,7 +253,7 @@ let count v =
       | [] -> (n,p)
       | (_,vl)::v -> let sg = sign_num vl in
 		       assert (sg <> 0) ;
-	  if sg = 1 then count n (p+1) v else count (n+1) p v in
+	  if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in
     count 0 0 v
 
 
@@ -304,7 +305,7 @@ let add (v1,c1)  (v2,c2)  =
   let rec xadd v1 v2  =
     match v1 , v2 with
       | (x1,n1)::v1' , (x2,n2)::v2' ->
-	  if x1 = x2
+	  if Int.equal x1 x2
 	  then
 	    let n' = (n1 // c1) +/ (n2 // c2) in
 	      if n' =/ Int 0 then xadd v1' v2'
@@ -352,7 +353,7 @@ let split x (vect: vector) info (l,m,r) =
               | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
 
           let lb,rb = info.bound in
-            if sign_num vl = 1
+            if Int.equal (sign_num vl) 1
             then  (cons_bound l lb,m,cons_bound r rb)
             else (* sign_num vl = -1 *)
               (cons_bound l rb,m,cons_bound r lb)
@@ -437,7 +438,7 @@ let elim_var_using_eq vr vect cst  prf sys =
 (** [size sys] computes the number of entries in the system of constraints *)
 let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
 
-module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+module IMap = Map.Make(Int)
 
 let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map ()
 
@@ -498,7 +499,7 @@ let pick_small_value bnd =
 	then ceiling_num i (* why not *) else i
 
 
-(** [solution s1 sys_l  = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)]
+(** [solution s1 sys_l  = Some(sn,\[(vn-1,sn-1);...; (v1,s1)\]\@sys_l)]
     then [sn] is a  system which contains only [black_v] -- if it existed in [s1]
     and [sn+1] is obtained by projecting [vn] out of [sn]
     @raise SystemContradiction if  system [s] has no solution
@@ -556,7 +557,7 @@ struct
             match  l1 with
             | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p
             | (vr,vl)::rl1 ->
-		if v = vr
+		if Int.equal v vr
 		then
 		  let cons_bound lst bd =
 		    match  bd with
@@ -564,7 +565,7 @@ struct
 		      | Some bnd -> info.neg+info.pos::lst in
 
 		  let lb,rb = info.bound in
-		    if sign_num vl = 1
+		    if Int.equal (sign_num vl) 1
 		    then  xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
 		    else  xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
 		else
@@ -590,7 +591,7 @@ struct
       (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s  in
                                       ((v,vl)::eval, ts)) v ([],sl)) in
 
-      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals
+      List.sort (fun x y -> compare_float (snd x) (snd y) ) evals
 
 
 end
@@ -615,7 +616,7 @@ struct
   let rec unroll_until v l =
     match l with
       | [] -> (false,[])
-      | (i,_)::rl -> if i = v
+      | (i,_)::rl -> if Int.equal i v
 	then (true,rl)
 	else if i < v then unroll_until v rl else (false,l)
 
@@ -632,7 +633,7 @@ struct
 
   let choose_primal_equation eqs sys_l =
 
-    (* Counts the number of equations refering to variable [v] --
+    (* Counts the number of equations referring to variable [v] --
        It looks like nb_cst is dead...
     *)
     let is_primal_equation_var v =
@@ -646,7 +647,7 @@ struct
 	| [] -> None
 	| (i,_)::vect ->
 	    let nb_eq = is_primal_equation_var i in
-	      if nb_eq = 2 
+	      if Int.equal nb_eq 2 
 	      then Some i else find_var vect in
 
     let rec find_eq_var eqs =
@@ -704,7 +705,7 @@ struct
 
 	      (*      pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
 
-	      List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs
+	      List.sort (fun x y -> Int.compare (snd x) (snd y) ) all_costs
 	| Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
 
 
@@ -727,9 +728,9 @@ struct
 	| Inl (s,_) ->
 	    try
 	      Some (bound_of_variable IMap.empty fresh s.sys)
-	    with
-	      x when x <> Sys.Break ->
-                Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+	    with x when Errors.noncritical x ->
+	      Printf.printf "optimise Exception : %s" (Printexc.to_string x);
+              None
 
 
   let find_point cstrs =
@@ -793,18 +794,18 @@ struct
       match Vect.get v v1 , Vect.get v v2 with
         | None , _ | _ , None -> None
         | Some a   , Some b   ->
-            if (sign_num a) * (sign_num b) = -1
+            if Int.equal ((sign_num a) * (sign_num b)) (-1)
             then 
 	      Some (add (p1,abs_num a) (p2,abs_num b) ,
                       {coeffs = add (v1,abs_num a) (v2,abs_num b) ;
                        op = add_op op1 op2 ;
                        cst = n1 // (abs_num a) +/ n2 // (abs_num b) })
-            else if op1 = Eq
+            else if op1 == Eq
             then Some (add (p1,minus_num (a // b)) (p2,Int 1),
                       {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
                        op     = add_op op1 op2;
                        cst    = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
-            else if op2 = Eq
+            else if op2 == Eq
 	    then
 	      Some (add (p2,minus_num (b // a)) (p1,Int 1),
                    {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
index 564126d2..0537cdbe 100644
--- a/plugins/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1499,7 +1499,7 @@ module N =
   
   (** val eqb : n -> n -> bool **)
   
-  let rec eqb n0 m =
+  let eqb n0 m =
     match n0 with
     | N0 ->
       (match m with
@@ -1693,7 +1693,7 @@ module N =
   
   (** val ldiff : n -> n -> n **)
   
-  let rec ldiff n0 m =
+  let ldiff n0 m =
     match n0 with
     | N0 -> N0
     | Npos p ->
@@ -2205,7 +2205,7 @@ module Z =
   
   (** val eqb : z -> z -> bool **)
   
-  let rec eqb x y =
+  let eqb x y =
     match x with
     | Z0 ->
       (match y with
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index 7f0dce04..a07cbec6 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.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        *)
@@ -31,7 +31,7 @@ let finally f rst =
       rst () ; res
   with reraise ->
     (try rst ()
-    with any  -> raise reraise
+    with any -> raise reraise
     ); raise reraise
 
 let map_option f x =
@@ -72,15 +72,15 @@ let rec map3 f l1 l2 l3 =
   match l1 , l2 ,l3 with
     | [] , [] , [] -> []
     | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3)
-    |      _   -> raise (Invalid_argument "map3")
+    |      _   -> invalid_arg "map3"
 
-let rec is_sublist l1 l2 =
+let rec is_sublist f l1 l2 =
   match l1 ,l2 with
     | [] ,_ -> true
     | e::l1', [] -> false
     | e::l1' , e'::l2' ->
-	if e = e' then is_sublist l1' l2'
-	else is_sublist l1 l2'
+	if f e e' then is_sublist f l1' l2'
+	else is_sublist f l1 l2'
 
 let list_try_find f =
   let rec try_find_f = function
@@ -89,7 +89,7 @@ let list_try_find f =
   in
   try_find_f
 
-let rec list_fold_right_elements f l =
+let list_fold_right_elements f l =
   let rec aux = function
     | [] -> invalid_arg "list_fold_right_elements"
     | [x] -> x
@@ -142,9 +142,9 @@ let rec rec_gcd_list c l  =
   | [] -> c
   | e::l -> rec_gcd_list (gcd_big_int  c (numerator e)) l
 
-let rec gcd_list l =
+let gcd_list l =
  let res = rec_gcd_list zero_big_int l in
-  if compare_big_int res zero_big_int = 0
+  if Int.equal (compare_big_int res zero_big_int) 0
   then unit_big_int else res
 
 let rats_to_ints l =
@@ -192,7 +192,7 @@ let  select_pos lpos l =
       match l with
        | []   -> failwith "select_pos"
        | e::l ->
-	  if i = j
+	  if Int.equal i j
 	  then e:: (xselect (i+1) rpos l)
 	  else xselect (i+1) lpos l in
   xselect 0 lpos l
@@ -269,19 +269,19 @@ struct
 
 
  let rec positive n =
-  if n=1 then XH
-  else if n land 1 = 1 then XI (positive (n lsr 1))
+  if Int.equal n 1 then XH
+  else if Int.equal (n land 1) 1 then XI (positive (n lsr 1))
   else  XO (positive (n lsr 1))
 
  let n nt =
   if nt < 0
   then assert false
-  else if nt = 0 then N0
+  else if Int.equal nt 0 then N0
   else Npos (positive nt)
 
  let rec index  n =
-  if n=1 then XH
-  else if n land 1 = 1 then XI (index (n lsr 1))
+  if Int.equal n 1 then XH
+  else if Int.equal (n land 1) 1 then XI (index (n lsr 1))
   else  XO (index (n lsr 1))
 
 
@@ -289,8 +289,8 @@ struct
   (*a.k.a path_of_int *)
   (* returns the list of digits of n in reverse order with initial 1 removed *)
   let rec digits_of_int n =
-   if n=1 then []
-   else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+   if Int.equal n 1 then []
+   else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1))
   in
    List.fold_right
     (fun b c -> (if b then XI c else XO c))
@@ -342,7 +342,7 @@ struct
    | [] -> 0 (* Equal *)
    | f::l ->
       let cmp = f () in
-       if cmp = 0 then compare_lexical l else cmp
+       if Int.equal cmp 0 then compare_lexical l else cmp
 
  let rec compare_list cmp l1 l2 =
   match l1 , l2 with
@@ -351,7 +351,7 @@ struct
    | _   , [] -> 1
    | e1::l1 , e2::l2 ->
       let c = cmp e1 e2 in
-       if c = 0 then compare_list cmp l1 l2 else c
+       if Int.equal c 0 then compare_list cmp l1 l2 else c
 
 (**
   * hash_list takes a hash function and a list, and computes an integer which
@@ -393,7 +393,7 @@ struct
   let from i = i
   let next i = i + 1
   let pp o i = output_string o (string_of_int i)
-  let compare : int -> int -> int = Pervasives.compare
+  let compare : int -> int -> int = Int.compare
 
 end
 
@@ -403,6 +403,12 @@ end
 
 module TagSet = Set.Make(Tag)
 
+(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *)
+
+let rec waitpid_non_intr pid =
+  try snd (Unix.waitpid [] pid)
+  with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid
+
 (**
   * Forking routine, plumbing the appropriate pipes where needed.
   *)
@@ -422,25 +428,33 @@ let command exe_path args vl =
     flush outch ;
 
   (* Wait for its completion *)
-    let _pid,status = Unix.waitpid [] pid in
+    let status = waitpid_non_intr pid in
 
       finally
         (* Recover the result *)
 	(fun () ->
 	  match status with
 	    | Unix.WEXITED 0 ->
-		let inch  = Unix.in_channel_of_descr stdout_read in
-		  begin try Marshal.from_channel inch 
-                        with x when x <> Sys.Break ->
-                          failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x))
-                  end
-	    | Unix.WEXITED i   -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
-	    | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
-	    | Unix.WSTOPPED i  -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
+		let inch = Unix.in_channel_of_descr stdout_read in
+		begin
+                  try Marshal.from_channel inch
+                  with any ->
+                    failwith
+                      (Printf.sprintf "command \"%s\" exited %s" exe_path
+                         (Printexc.to_string any))
+                end
+	    | Unix.WEXITED i   ->
+                failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i)
+	    | Unix.WSIGNALED i ->
+                failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i)
+	    | Unix.WSTOPPED i  ->
+                failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i))
         (* Cleanup  *)
 	(fun () ->
-	  List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ())
-            [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write])
+	  List.iter (fun x -> try Unix.close x with any -> ())
+            [stdin_read; stdin_write;
+             stdout_read; stdout_write;
+             stderr_read; stderr_write])
 
 (* Local Variables: *)
 (* coding: utf-8 *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index 2465617a..2dc0d003 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.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,11 +8,10 @@
 (*                                                                      *)
 (*  A persistent hashtable                                              *)
 (*                                                                      *)
-(*  Frédéric Besson (Inria Rennes) 2009-2011                            *)
+(*  Frédéric Besson (Inria Rennes) 2009-2014                            *)
 (*                                                                      *)
 (************************************************************************)
 
-
 module type PHashtable =
   sig
     type 'a t
@@ -84,7 +83,7 @@ let finally f rst =
       rst () ; res
   with reraise ->
     (try rst ()
-    with any  -> raise reraise
+    with any -> raise reraise
     ); raise reraise
 
 
@@ -93,26 +92,52 @@ let read_key_elem inch =
     Some (Marshal.from_channel inch)
   with
     | End_of_file -> None
-    | e when e <> Sys.Break -> raise InvalidTableFormat
-
-(** In win32, it seems that we should unlock the exact zone
-    that has been locked, and not the whole file *)
+    | e when Errors.noncritical e -> raise InvalidTableFormat
+
+(** 
+    We used to only lock/unlock regions.
+    Is-it more robust/portable to lock/unlock a fixed region e.g. [0;1]?  
+    In case of locking failure, the cache is not used.
+**)
+
+type lock_kind = Read | Write
+
+let lock kd fd = 
+ let pos = lseek fd 0 SEEK_CUR in 
+ let success   = 
+  try 
+   ignore (lseek fd 0 SEEK_SET);
+   let lk =  match kd with 
+    | Read  -> F_RLOCK 
+    | Write -> F_LOCK in  
+   lockf fd lk 1; true
+  with Unix.Unix_error(_,_,_) -> false in
+ ignore (lseek fd pos SEEK_SET) ; 
+ success
+
+let unlock fd = 
+  let pos = lseek fd 0 SEEK_CUR in
+  try 
+   ignore (lseek fd 0 SEEK_SET) ; 
+   lockf fd F_ULOCK 1
+  with 
+   Unix.Unix_error(_,_,_) -> ()    
+    (* Here, this is really bad news -- 
+       there is a pending lock which could cause a deadlock.
+       Should it be an anomaly or produce a warning ?
+    *);
+  ignore (lseek fd pos SEEK_SET) 
 
-let locked_start = ref 0
 
-let lock fd =
-  locked_start := lseek fd 0 SEEK_CUR;
-  lockf fd F_LOCK 0
+(* We make the assumption that an acquired lock can always be released *)
 
-let rlock fd =
-  locked_start := lseek fd 0 SEEK_CUR;
-  lockf fd F_RLOCK 0
+let do_under_lock kd fd f = 
+ if lock kd fd
+ then
+  finally f (fun () -> unlock fd)
+ else f ()
+  
 
-let unlock fd =
-  let pos = lseek fd 0 SEEK_CUR in
-  ignore (lseek fd !locked_start SEEK_SET);
-  lockf fd F_ULOCK 0;
-  ignore (lseek fd pos SEEK_SET)
 
 let open_in f =
   let flags = [O_RDONLY ; O_CREAT] in
@@ -128,37 +153,30 @@ let open_in f =
 	  xload () in
     try
       (* Locking of the (whole) file while reading *)
-      rlock finch;
-      finally 
-	(fun () -> xload () ) 
-	(fun () -> 
-	   unlock finch ;
-	   close_in_noerr inch ; 
-	) ;
+      do_under_lock Read finch xload ; 
+      close_in_noerr inch ; 
       {
-	outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
-	status = Open ;
-	htbl = htbl
+       outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ;
+       status = Open ;
+       htbl = htbl
       }
     with InvalidTableFormat ->
-      (* Try to keep as many entries as possible *)
-      begin
-	let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
-	let out =  (openfile f flags 0o666) in
-	let outch = out_channel_of_descr out in
-	  lock out;
-	  (try 
-	    Table.iter 
-	      (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
-	    flush outch ; 
-	  with e when e <> Sys.Break -> () )
-	    ;
-	    unlock out ; 
-	    { outch = outch ;
-	      status = Open ;
-	      htbl   = htbl
-	    }
-      end
+     (* The file is corrupted *)
+     begin
+      close_in_noerr inch ;
+      let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
+      let out =  (openfile f flags 0o666) in
+      let outch = out_channel_of_descr out in
+      do_under_lock Write out 
+       (fun () -> 
+	Table.iter 
+	  (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl;
+        flush outch) ; 
+      { outch = outch ;
+        status = Open ;
+        htbl   = htbl
+      }
+     end
 
 
 let close t =
@@ -172,22 +190,22 @@ let close t =
 
 let add t k e =
   let {outch = outch ; status = status ; htbl = tbl} = t in
-    if status = Closed
+    if status == Closed
     then raise UnboundTable
     else
       let fd = descr_of_out_channel outch in
       begin
-	Table.add tbl k e ;
-	lock fd;
-	ignore (lseek fd 0 SEEK_END);
-	Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
-	flush outch ;
-	unlock fd
+       Table.add tbl k e ;
+       do_under_lock Write fd 
+        (fun _ -> 
+         Marshal.to_channel outch (k,e) [Marshal.No_sharing] ;
+         flush outch
+        )
       end
 
 let find t k =
   let {outch = outch ; status = status ; htbl = tbl} = t in
-    if status = Closed
+    if status == Closed
     then raise UnboundTable
     else
       let res = Table.find tbl k in
diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml
index 9372cb66..b8b42a3f 100644
--- a/plugins/micromega/polynomial.ml
+++ b/plugins/micromega/polynomial.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        *)
@@ -44,7 +44,7 @@ end
  =
 struct
  (* A monomial is represented by a multiset of variables  *)
- module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
+ module Map = Map.Make(Int)
  open Map
  
  type t = int Map.t
@@ -65,8 +65,8 @@ struct
    fun m1 m2 -> 
      let s1 = sum_degree m1 
      and s2 = sum_degree m2 in
-       if s1 = s2 then Map.compare Pervasives.compare m1 m2
-       else Pervasives.compare s1 s2
+       if Int.equal s1 s2 then Map.compare Int.compare m1 m2
+       else Int.compare s1 s2
 
  let is_const m = (m = Map.empty)
   
@@ -218,7 +218,7 @@ struct
 
  let fold = P.fold
 
- let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p  true
+ let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p  true
 
  let compare = compare compare_num
 
@@ -241,8 +241,7 @@ module Vect =
     type var = int
     type t = (var * num) list
 
-(** [equal v1 v2 = true] if the vectors are syntactically equal.
-    ([num] is not handled by  [Pervasives.equal] *)
+(** [equal v1 v2 = true] if the vectors are syntactically equal. *)
 
     let rec equal v1 v2 =
       match v1 , v2 with
@@ -250,7 +249,7 @@ module Vect =
 	| [] , _    -> false
 	| _::_ , [] -> false
 	| (i1,n1)::v1 , (i2,n2)::v2 ->
-	    (i1 = i2) && n1 =/ n2 && equal v1 v2
+	    (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2
 
     let hash v =
       let rec hash i = function
@@ -294,7 +293,7 @@ module Vect =
       match t with
 	| [] -> cons i (f zero_num) []
 	| (k,v)::l ->
-	    match Pervasives.compare i k with
+	    match Int.compare i k with
 	  | 0 -> cons k (f v) l
 	  | -1 -> cons i (f zero_num) t
 	  |  1 -> (k,v) ::(update i f l)
@@ -304,7 +303,7 @@ module Vect =
       match t with
 	| [] -> cons i n []
 	| (k,v)::l ->
-	    match Pervasives.compare i k with
+	    match Int.compare i k with
 	      | 0 -> cons k n l
 	      | -1 -> cons i n t
 	      |  1 -> (k,v) :: (set i n l)
@@ -315,7 +314,7 @@ module Vect =
 	if Big_int.compare_big_int res Big_int.zero_big_int = 0
 	then Big_int.unit_big_int else res
 
-    let rec mul z t =
+    let mul z t =
       match z with
 	| Int 0 -> []
 	| Int 1 -> t
@@ -346,7 +345,7 @@ module Vect =
 
     let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical
       [
-	(fun () -> Pervasives.compare (fst x) (fst y));
+	(fun () -> Int.compare (fst x) (fst y));
 	(fun () -> compare_num (snd x) (snd y))])
 
     (** [tail v vect] returns
@@ -359,7 +358,7 @@ module Vect =
       match vect with
 	| [] -> None
 	| (v',vl)::vect' ->
-	    match Pervasives.compare v' v with
+	    match Int.compare v' v with
 	      | 0 -> Some (vl,vect) (* Ok, found *)
 	      | -1 -> tail v vect' (* Might be in the tail *)
 	      | _  -> None (* Hopeless *)
@@ -585,7 +584,7 @@ struct
   module MonT = 
   struct
     module MonoMap = Map.Make(Monomial)
-    module IntMap  = Map.Make(struct type t = int let compare = Pervasives.compare end)
+    module IntMap  = Map.Make(Int)
 	  
     (** A hash table might be preferable but requires a hash function. *)
     let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty)
@@ -615,7 +614,7 @@ struct
   end 
 
   let normalise (v,c) = 
-    (List.sort  (fun x y -> Pervasives.compare (fst x) (fst y)) v , c)
+    (List.sort  (fun x y -> Int.compare (fst x) (fst y)) v , c)
 
 
   let output_mon o (x,v) = 
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
index 6ddc48e7..cc89e2b9 100644
--- a/plugins/micromega/sos.ml
+++ b/plugins/micromega/sos.ml
@@ -1,16 +1,15 @@
 (* ========================================================================= *)
 (* - This code originates from John Harrison's HOL LIGHT 2.30                *)
 (*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
-(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
 (*   independent bits                                                        *)
-(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
 (* ========================================================================= *)
 
 (* ========================================================================= *)
 (* Nonlinear universal reals procedure using SOS decomposition.              *)
 (* ========================================================================= *)
 open Num;;
-open List;;
 open Sos_types;;
 open Sos_lib;;
 
@@ -40,7 +39,7 @@ let decimalize =
     let z = pow10(-e) */ y +/ Int 1 in
     let k = round_num(pow10 d */ z) in
     (if x </ Int 0 then "-0." else "0.") ^
-    implode(tl(explode(string_of_num k))) ^
+    implode(List.tl(explode(string_of_num k))) ^
     (if e = 0 then "" else "e"^string_of_int e);;
 
 (* ------------------------------------------------------------------------- *)
@@ -123,7 +122,7 @@ let vector_dot (v1:vector) (v2:vector) =
         (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));;
 
 let vector_of_list l =
-  let n = length l in
+  let n = List.length l in
   (n,itlist2 (|->) (1--n) l undefined :vector);;
 
 (* ------------------------------------------------------------------------- *)
@@ -176,9 +175,9 @@ let diagonal (v:vector) =
   ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
 
 let matrix_of_list l =
-  let m = length l in
+  let m = List.length l in
   if m = 0 then matrix_0 (0,0) else
-  let n = length (hd l) in
+  let n = List.length (List.hd l) in
   (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
 
 (* ------------------------------------------------------------------------- *)
@@ -201,11 +200,11 @@ let monomial_pow (m:monomial) k =
   else mapf (fun x -> k * x) m;;
 
 let monomial_divides (m1:monomial) (m2:monomial) =
-  foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
+  foldl (fun a x k -> tryapplyd m2 x 0 >= k && a) true m1;;
 
 let monomial_div (m1:monomial) (m2:monomial) =
   let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
-  if foldl (fun a x k -> k >= 0 & a) true m then m
+  if foldl (fun a x k -> k >= 0 && a) true m then m
   else failwith "monomial_div: non-divisible";;
 
 let monomial_degree x (m:monomial) = tryapplyd m x 0;;
@@ -227,7 +226,7 @@ let eval assig (p:poly) =
 
 let poly_0 = (undefined:poly);;
 
-let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
+let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;;
 
 let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
 
@@ -283,13 +282,13 @@ let poly_variables (p:poly) =
 (* Order monomials for human presentation.                                   *)
 (* ------------------------------------------------------------------------- *)
 
-let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;;
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 && k1 > k2;;
 
 let humanorder_monomial =
   let rec ord l1 l2 = match (l1,l2) with
     _,[] -> true
   | [],_ -> false
-  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in
+  | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 && ord t1 t2 in
   fun m1 m2 -> m1 = m2 or
                ord (sort humanorder_varpow (graph m1))
                    (sort humanorder_varpow (graph m2));;
@@ -302,14 +301,14 @@ let string_of_vector min_size max_size (v:vector) =
   let n_raw = dim v in
   if n_raw = 0 then "[]" else
   let n = max min_size (min n_raw max_size) in
-  let xs = map ((o) string_of_num (element v)) (1--n) in
+  let xs = List.map ((o) string_of_num (element v)) (1--n) in
   "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
   (if n_raw > max_size then ", ...]" else "]");;
 
 let string_of_matrix max_size (m:matrix) =
   let i_raw,j_raw = dimensions m in
   let i = min max_size i_raw and j = min max_size j_raw in
-  let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
+  let rstr = List.map (fun k -> string_of_vector j j (row k m)) (1--i) in
   "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
   (if j > max_size then "\n ...]" else "]");;
 
@@ -408,7 +407,7 @@ let rec poly_of_term t = match t with
 
 let sdpa_of_vector (v:vector) =
   let n = dim v in
-  let strs = map (o (decimalize 20)  (element v)) (1--n) in
+  let strs = List.map (o (decimalize 20)  (element v)) (1--n) in
   end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
 
 (* ------------------------------------------------------------------------- *)
@@ -445,15 +444,15 @@ let sdpa_of_matrix k (m:matrix) =
 (* ------------------------------------------------------------------------- *)
 
 let sdpa_of_problem comment obj mats =
-  let m = length mats - 1
-  and n,_ = dimensions (hd mats) in
+  let m = List.length mats - 1
+  and n,_ = dimensions (List.hd mats) in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   "1\n" ^
   string_of_int n ^ "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 (* ------------------------------------------------------------------------- *)
 (* More parser basics.                                                       *)
@@ -461,7 +460,7 @@ let sdpa_of_problem comment obj mats =
 
 let word s =
    end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
-              (map a (explode s));;
+              (List.map a (explode s));;
 let token s =
   many (some isspace) ++ word s ++ many (some isspace)
   >> (fun ((_,t),_) -> t);;
@@ -470,7 +469,7 @@ let decimal =
   let numeral = some isnum in
   let decimalint = atleast 1 numeral >> ((o) Num.num_of_string  implode) in
   let decimalfrac = atleast 1 numeral
-    >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
+    >> (fun s -> Num.num_of_string(implode s) // pow10 (List.length s)) in
   let decimalsig =
     decimalint ++ possibly (a "." ++ decimalfrac >> snd)
     >> (function (h,[x]) -> h +/ x | (h,_) -> h) in
@@ -626,13 +625,13 @@ let scale_then =
   fun solver obj mats ->
     let cd1 = itlist common_denominator mats (Int 1)
     and cd2 = common_denominator (snd obj)  (Int 1) in
-    let mats' = map (mapf (fun x -> cd1 */ x)) mats
+    let mats' = List.map (mapf (fun x -> cd1 */ x)) mats
     and obj' = vector_cmul cd2 obj in
     let max1 = itlist maximal_element mats' (Int 0)
     and max2 = maximal_element (snd obj') (Int 0) in
     let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
     and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
-    let mats'' = map (mapf (fun x -> x */ scal1)) mats'
+    let mats'' = List.map (mapf (fun x -> x */ scal1)) mats'
     and obj'' = vector_cmul scal2 obj' in
     solver obj'' mats'';;
 
@@ -651,7 +650,7 @@ let nice_vector n = mapa (nice_rational n);;
 
 let linear_program_basic a =
   let m,n = dimensions a in
-  let mats =  map (fun j -> diagonal (column j a)) (1--n)
+  let mats =  List.map (fun j -> diagonal (column j a)) (1--n)
   and obj = vector_const (Int 1) m in
   let rv,res = run_csdp false obj mats in
   if rv = 1 or rv = 2 then false
@@ -665,7 +664,7 @@ let linear_program_basic a =
 let linear_program a b =
   let m,n = dimensions a in
   if dim b <> m then failwith "linear_program: incompatible dimensions" else
-  let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n)
+  let mats = diagonal b :: List.map (fun j -> diagonal (column j a)) (1--n)
   and obj = vector_const (Int 1) m in
   let rv,res = run_csdp false obj mats in
   if rv = 1 or rv = 2 then false
@@ -679,10 +678,10 @@ let linear_program a b =
 (* ------------------------------------------------------------------------- *)
 
 let in_convex_hull pts pt =
-  let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
-  let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
-  let n = length pts + 1
-  and v = 2 * (length pt + 1) in
+  let pts1 = (1::pt) :: List.map (fun x -> 1::x) pts in
+  let pts2 = List.map (fun p -> List.map (fun x -> -x) p @ p) pts1 in
+  let n = List.length pts + 1
+  and v = 2 * (List.length pt + 1) in
   let m = v + n - 1 in
   let mat =
     (m,n),
@@ -700,8 +699,8 @@ let minimal_convex_hull =
     | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in
   let augment m ms = funpow 3 augment1 (m::ms) in
   fun mons ->
-    let mons' = itlist augment (tl mons) [hd mons] in
-    funpow (length mons') augment1 mons';;
+    let mons' = itlist augment (List.tl mons) [List.hd mons] in
+    funpow (List.length mons') augment1 mons';;
 
 (* ------------------------------------------------------------------------- *)
 (* Stuff for "equations" (generic A->num functions).                         *)
@@ -743,7 +742,7 @@ let eliminate_equations =
                   let b = tryapplyd e v (Int 0) in
                   if b =/ Int 0 then e else
                   equation_add e (equation_cmul (minus_num b // a) eq) in
-                eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
+                eliminate vs ((v |-> eq') (mapf elim dun)) (List.map elim oeqs)
             with Failure _ -> eliminate vs dun eqs in
   fun one vars eqs ->
     let assig = eliminate vars undefined eqs in
@@ -774,7 +773,7 @@ let eliminate_all_equations one =
           let b = tryapplyd e v (Int 0) in
           if b =/ Int 0 then e else
           equation_add e (equation_cmul (minus_num b // a) eq) in
-        eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
+        eliminate ((v |-> eq') (mapf elim dun)) (List.map elim oeqs) in
   fun eqs ->
     let assig = eliminate undefined eqs in
     let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
@@ -805,14 +804,14 @@ let solve_equations one eqs =
 
 let newton_polytope pol =
   let vars = poly_variables pol in
-  let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
-  and ds = map (fun x -> (degree x pol + 1) / 2) vars in
+  let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol)
+  and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in
   let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
   and mons' = minimal_convex_hull mons in
   let all' =
-    filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
-  map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
-                        vars m monomial_1) (rev all');;
+    List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in
+  List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
+                        vars m monomial_1) (List.rev all');;
 
 (* ------------------------------------------------------------------------- *)
 (* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form.  *)
@@ -851,10 +850,10 @@ let deration d =
     let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
             foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
     (c // (a */ a)),mapa (fun x -> a */ x) l in
-  let d' = map adj d in
+  let d' = List.map adj d in
   let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) //
           itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0)  in
-  (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
+  (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';;
 
 (* ------------------------------------------------------------------------- *)
 (* Enumeration of monomials with given multidegree bound.                    *)
@@ -865,8 +864,8 @@ let rec enumerate_monomials d vars =
   else if d = 0 then [undefined]
   else if vars = [] then [monomial_1] else
   let alts =
-    map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
-                  map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
+    List.map (fun k -> let oths = enumerate_monomials (d - k) (List.tl vars) in
+                  List.map (fun ks -> if k = 0 then ks else (List.hd vars |-> k) ks) oths)
         (0--d) in
   end_itlist (@) alts;;
 
@@ -883,7 +882,7 @@ let rec enumerate_products d pols =
   | (p,b)::ps -> let e = multidegree p in
                  if e = 0 then enumerate_products d ps else
                  enumerate_products d ps @
-                 map (fun (q,c) -> poly_mul p q,Product(b,c))
+                 List.map (fun (q,c) -> poly_mul p q,Product(b,c))
                      (enumerate_products (d - e) ps);;
 
 (* ------------------------------------------------------------------------- *)
@@ -936,15 +935,15 @@ let sdpa_of_blockdiagonal k m =
 (* ------------------------------------------------------------------------- *)
 
 let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
-  let m = length mats - 1 in
+  let m = List.length mats - 1 in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   string_of_int nblocks ^ "\n" ^
-  (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
+  (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^
   "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 (* ------------------------------------------------------------------------- *)
 (* Hence run CSDP on a problem in block diagonal form.                       *)
@@ -996,35 +995,35 @@ let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
 (* ------------------------------------------------------------------------- *)
 
 let blocks blocksizes bm =
-  map (fun (bs,b0) ->
+  List.map (fun (bs,b0) ->
         let m = foldl
           (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
           undefined bm in
         (((bs,bs),m):matrix))
-      (zip blocksizes (1--length blocksizes));;
+      (zip blocksizes (1--List.length blocksizes));;
 
 (* ------------------------------------------------------------------------- *)
 (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
 (* ------------------------------------------------------------------------- *)
 
 let real_positivnullstellensatz_general linf d eqs leqs pol =
-  let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
+  let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in
   let monoid =
     if linf then
       (poly_const num_1,Rational_lt num_1)::
-      (filter (fun (p,c) -> multidegree p <= d) leqs)
+      (List.filter (fun (p,c) -> multidegree p <= d) leqs)
     else enumerate_products d leqs in
-  let nblocks = length monoid in
+  let nblocks = List.length monoid in
   let mk_idmultiplier k p =
     let e = d - multidegree p in
     let mons = enumerate_monomials e vars in
-    let nons = zip mons (1--length mons) in
+    let nons = zip mons (1--List.length mons) in
     mons,
     itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
   let mk_sqmultiplier k (p,c) =
     let e = (d - multidegree p) / 2 in
     let mons = enumerate_monomials e vars in
-    let nons = zip mons (1--length mons) in
+    let nons = zip mons (1--List.length mons) in
     mons,
     itlist (fun (m1,n1) ->
       itlist (fun (m2,n2) a ->
@@ -1035,9 +1034,9 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
           (m |-> equation_add ((k,n1,n2) |=> c) e) a)
          nons)
        nons undefined in
-  let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
-  and idmonlist,ids =  unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
-  let blocksizes = map length sqmonlist in
+  let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid)
+  and idmonlist,ids =  unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in
+  let blocksizes = List.map List.length sqmonlist in
   let bigsum =
     itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
             (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
@@ -1053,10 +1052,10 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
                                 ((b,j,i) |-> c) (((b,i,j) |-> c) m))
           undefined allassig in
   let diagents = foldl
-    (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
+    (fun a (b,i,j) e -> if b > 0 && i = j then equation_add e a else a)
     undefined allassig in
-  let mats = map mk_matrix qvars
-  and obj = length pvs,
+  let mats = List.map mk_matrix qvars
+  and obj = List.length pvs,
             itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
                         undefined in
   let raw_vec = if pvs = [] then vector_0 0
@@ -1071,11 +1070,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
      (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
      (bmatrix_neg (el 0 mats)) in
     let allmats = blocks blocksizes blockmat in
-    vec,map diag allmats in
+    vec,List.map diag allmats in
   let vec,ratdias =
     if pvs = [] then find_rounding num_1
-    else tryfind find_rounding (map Num.num_of_int (1--31) @
-                                map pow2 (5--66)) in
+    else tryfind find_rounding (List.map Num.num_of_int (1--31) @
+                                List.map pow2 (5--66)) in
   let newassigs =
     itlist (fun k -> el (k - 1) pvs |-> element vec k)
            (1--dim vec) ((0,0,0) |=> Int(-1)) in
@@ -1088,11 +1087,11 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
   let mk_sos mons =
     let mk_sq (c,m) =
         c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
-                 (1--length mons) undefined in
-    map mk_sq in
-  let sqs = map2 mk_sos sqmonlist ratdias
-  and cfs = map poly_of_epoly ids in
-  let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
+                 (1--List.length mons) undefined in
+    List.map mk_sq in
+  let sqs = List.map2 mk_sos sqmonlist ratdias
+  and cfs = List.map poly_of_epoly ids in
+  let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in
   let eval_sq sqs = itlist
    (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
   let sanity =
@@ -1100,7 +1099,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol =
            (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
                     (poly_neg pol)) in
   if not(is_undefined sanity) then raise Sanity else
-  cfs,map (fun (a,b) -> snd a,b) msq;;
+  cfs,List.map (fun (a,b) -> snd a,b) msq;;
 
 (* ------------------------------------------------------------------------- *)
 (* Iterative deepening.                                                      *)
@@ -1138,7 +1137,7 @@ let monomial_order =
     else lexorder mon1 mon2;;
 
 let dest_poly p =
-  map (fun (m,c) -> c,dest_monomial m)
+  List.map (fun (m,c) -> c,dest_monomial m)
       (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
 
 (* ------------------------------------------------------------------------- *)
@@ -1164,7 +1163,7 @@ let term_of_cmonomial =
 let term_of_poly =
   fun p ->
     if p = poly_0 then Zero else
-    let cms = map term_of_cmonomial
+    let cms = List.map term_of_cmonomial
      (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
     end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
 
@@ -1173,7 +1172,7 @@ let term_of_sqterm (c,p) =
 
 let term_of_sos (pr,sqs) =
   if sqs = [] then pr
-  else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
+  else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));;
 
 (* ------------------------------------------------------------------------- *)
 (* Interface to HOL.                                                         *)
@@ -1236,7 +1235,7 @@ let REAL_NONLINEAR_SUBST_PROVER =
     match tm with
       Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm
     | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t))
-         when is_ratconst c & not (mem t fvs)
+         when is_ratconst c && not (mem t fvs)
           -> rat_of_term c,t
     | Comb(Comb(Const("real_add",_),s),t) ->
          (try substitutable_monomial (union (frees t) fvs) s
@@ -1292,10 +1291,10 @@ let REAL_SOSFIELD =
     with Failure _ -> REAL_SOS t
   and is_inv =
     let is_div = is_binop `(/):real->real->real` in
-    fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) &
+    fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) &&
               not(is_ratconst(rand tm)) in
   let BASIC_REAL_FIELD tm =
-    let is_freeinv t = is_inv t & free_in t tm in
+    let is_freeinv t = is_inv t && free_in t tm in
     let itms = setify(map rand (find_terms is_freeinv tm)) in
     let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in
     let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in
@@ -1371,14 +1370,14 @@ let SOS_RULE tm =
 
 let rec allpermutations l =
   if l = [] then [[]] else
-  itlist (fun h acc -> map (fun t -> h::t)
+  itlist (fun h acc -> List.map (fun t -> h::t)
                 (allpermutations (subtract l [h])) @ acc) l [];;
 
 let allvarorders l =
-  map (fun vlis x -> index x vlis) (allpermutations l);;
+  List.map (fun vlis x -> index x vlis) (allpermutations l);;
 
 let changevariables_monomial zoln (m:monomial) =
-  foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
+  foldl (fun a x k -> (List.assoc x zoln |-> k) a) monomial_1 m;;
 
 let changevariables zoln pol =
   foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
@@ -1390,7 +1389,7 @@ let changevariables zoln pol =
 
 let sdpa_of_vector (v:vector) =
   let n = dim v in
-  let strs = map (o (decimalize 20) (element v)) (1--n) in
+  let strs = List.map (o (decimalize 20) (element v)) (1--n) in
   end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
 
 let sdpa_of_blockdiagonal k m =
@@ -1412,15 +1411,15 @@ let sdpa_of_matrix k (m:matrix) =
      " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
 
 let sdpa_of_problem comment obj mats =
-  let m = length mats - 1
-  and n,_ = dimensions (hd mats) in
+  let m = List.length mats - 1
+  and n,_ = dimensions (List.hd mats) in
   "\"" ^ comment ^ "\"\n" ^
   string_of_int m ^ "\n" ^
   "1\n" ^
   string_of_int n ^ "\n" ^
   sdpa_of_vector obj ^
   itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
-          (1--length mats) mats "";;
+          (1--List.length mats) mats "";;
 
 let run_csdp dbg obj mats =
   let input_file = Filename.temp_file "sos" ".dat-s" in
@@ -1455,33 +1454,33 @@ let csdp obj mats =
 let sumofsquares_general_symmetry tool pol =
   let vars = poly_variables pol
   and lpps = newton_polytope pol in
-  let n = length lpps in
+  let n = List.length lpps in
   let sym_eqs =
-    let invariants = filter
+    let invariants = List.filter
      (fun vars' ->
         is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
      (allpermutations vars) in
-    let lpns = zip lpps (1--length lpps) in
+    let lpns = zip lpps (1--List.length lpps) in
     let lppcs =
-      filter (fun (m,(n1,n2)) -> n1 <= n2)
+      List.filter (fun (m,(n1,n2)) -> n1 <= n2)
              (allpairs
                (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
     let clppcs = end_itlist (@)
-       (map (fun ((m1,m2),(n1,n2)) ->
-                map (fun vars' ->
+       (List.map (fun ((m1,m2),(n1,n2)) ->
+                List.map (fun vars' ->
                         (changevariables_monomial (zip vars vars') m1,
                          changevariables_monomial (zip vars vars') m2),(n1,n2))
                     invariants)
             lppcs) in
-    let clppcs_dom = setify(map fst clppcs) in
-    let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
+    let clppcs_dom = setify(List.map fst clppcs) in
+    let clppcs_cls = List.map (fun d -> List.filter (fun (e,_) -> e = d) clppcs)
                          clppcs_dom in
-    let eqvcls = map (o setify (map snd)) clppcs_cls in
+    let eqvcls = List.map (o setify (List.map snd)) clppcs_cls in
     let mk_eq cls acc =
       match cls with
         [] -> raise Sanity
       | [h] -> acc
-      | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
+      | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
     itlist mk_eq eqvcls [] in
   let eqs = foldl (fun a x y -> y::a) []
    (itern 1 lpps (fun m1 n1 ->
@@ -1497,15 +1496,15 @@ let sumofsquares_general_symmetry tool pol =
   let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
   let qvars = (0,0)::pvs in
   let diagents =
-    end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
+    end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in
   let mk_matrix v =
    ((n,n),
     foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
                               if c =/ Int 0 then m else
                               ((j,i) |-> c) (((i,j) |-> c) m))
           undefined allassig :matrix) in
-  let mats = map mk_matrix qvars
-  and obj = length pvs,
+  let mats = List.map mk_matrix qvars
+  and obj = List.length pvs,
             itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
                 undefined in
   let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
@@ -1524,12 +1523,12 @@ let sumofsquares_general_symmetry tool pol =
        let mat = matrix_neg (el 0 mats) in
        deration(diag mat)
     else
-       tryfind find_rounding (map Num.num_of_int (1--31) @
-                              map pow2 (5--66)) in
+       tryfind find_rounding (List.map Num.num_of_int (1--31) @
+                              List.map pow2 (5--66)) in
   let poly_of_lin(d,v) =
     d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
-  let lins = map poly_of_lin dia in
-  let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
+  let lins = List.map poly_of_lin dia in
+  let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
   let sos = poly_cmul rat (end_itlist poly_add sqs) in
   if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
 
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
index d7314ccb..fc0b2fd4 100644
--- a/plugins/micromega/sos.mli
+++ b/plugins/micromega/sos.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/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml
index baf90d4d..f54914f2 100644
--- a/plugins/micromega/sos_lib.ml
+++ b/plugins/micromega/sos_lib.ml
@@ -2,13 +2,12 @@
 (* - This code originates from John Harrison's HOL LIGHT 2.30                *)
 (*   (see file LICENSE.sos for license, copyright and disclaimer)            *)
 (*   This code is the HOL LIGHT library code used by sos.ml                  *)
-(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL              *)
 (*   independent bits                                                        *)
-(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed  micromega       *)
 (* ========================================================================= *)
-open Sos_types
+
 open Num
-open List
 
 let debugging = ref false;;
 
@@ -16,11 +15,13 @@ let debugging = ref false;;
 (* Comparisons that are reflexive on NaN and also short-circuiting.          *)
 (* ------------------------------------------------------------------------- *)
 
-let (=?) = fun x y -> Pervasives.compare x y = 0;;
-let (<?) = fun x y -> Pervasives.compare x y < 0;;
-let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
-let (>?) = fun x y -> Pervasives.compare x y > 0;;
-let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+let cmp = Pervasives.compare (** FIXME *)
+
+let (=?) = fun x y -> cmp x y = 0;;
+let (<?) = fun x y -> cmp x y < 0;;
+let (<=?) = fun x y -> cmp x y <= 0;;
+let (>?) = fun x y -> cmp x y > 0;;
+let (>=?) = fun x y -> cmp x y >= 0;;
 
 (* ------------------------------------------------------------------------- *)
 (* Combinators.                                                              *)
@@ -53,7 +54,7 @@ let gcd_num n1 n2 =
   num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
 
 let lcm_num x y =
-  if x =/ num_0 & y =/ num_0 then num_0
+  if x =/ num_0 && y =/ num_0 then num_0
   else abs_num((x */ y) // gcd_num x y);;
 
 
@@ -62,7 +63,7 @@ let lcm_num x y =
 (* ------------------------------------------------------------------------- *)
 
 let rec el n l =
-  if n = 0 then hd l else el (n - 1) (tl l);;
+  if n = 0 then List.hd l else el (n - 1) (List.tl l);;
 
 
 (* ------------------------------------------------------------------------- *)
@@ -141,7 +142,7 @@ let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
 let rec forall p l =
   match l with
     [] -> true
-  | h::t -> p(h) & forall p t;;
+  | h::t -> p(h) && forall p t;;
 
 let rec tryfind f l =
   match l with
@@ -162,14 +163,14 @@ let index x =
 let rec mem x lis =
   match lis with
     [] -> false
-  | (h::t) -> x =? h or mem x t;;
+  | (h::t) -> x =? h || mem x t;;
 
 let insert x l =
   if mem x l then l else x::l;;
 
 let union l1 l2 = itlist insert l1 l2;;
 
-let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;;
 
 (* ------------------------------------------------------------------------- *)
 (* Merging and bottom-up mergesort.                                          *)
@@ -224,7 +225,7 @@ let rec sort cmp lis =
   match lis with
     [] -> []
   | piv::rest ->
-      let r,l = partition (cmp piv) rest in
+      let r,l = List.partition (cmp piv) rest in
       (sort cmp l) @ (piv::(sort cmp r));;
 
 (* ------------------------------------------------------------------------- *)
@@ -416,7 +417,7 @@ let (|=>) = fun x y -> (x |-> y) undefined;;
 let rec choose t =
   match t with
     Empty -> failwith "choose: completely undefined function"
-  | Leaf(h,l) -> hd l
+  | Leaf(h,l) -> List.hd l
   | Branch(b,p,t1,t2) -> choose t1;;
 
 (* ------------------------------------------------------------------------- *)
@@ -547,7 +548,7 @@ let fix err prs input =
   try prs input
   with Noparse -> failwith (err ^ " expected");;
 
-let rec listof prs sep err =
+let listof prs sep err =
   prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
 
 let possibly prs input =
@@ -583,7 +584,7 @@ let strings_of_file filename =
   let rec suck_lines acc =
     try let l = Pervasives.input_line fd in
         suck_lines (l::acc)
-    with End_of_file -> rev acc in
+    with End_of_file -> List.rev acc in
   let data = suck_lines [] in
   (Pervasives.close_in fd; data);;
 
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
index 351a3133..e9543714 100644
--- a/plugins/micromega/sos_types.ml
+++ b/plugins/micromega/sos_types.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        *)
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
index 30201308..bf6a1a7d 100644
--- a/plugins/micromega/vo.itarget
+++ b/plugins/micromega/vo.itarget
@@ -1,4 +1,3 @@
-CheckerMaker.vo
 EnvRing.vo
 Env.vo
 OrderedRing.vo
@@ -11,3 +10,4 @@ Tauto.vo
 VarMap.vo
 ZCoeff.vo
 ZMicromega.vo
+Lia.vo
\ No newline at end of file
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index f8929d58..eaf95e94 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -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        *)
@@ -98,7 +98,7 @@ Definition PhiR : list R -> PolZ -> R :=
     (InitialRing.gen_phiZ ring0 ring1 add mul opp)).
 
 Definition PEevalR : list R -> PEZ -> R :=
-   PEeval ring0 add mul sub opp
+   PEeval ring0 ring1 add mul sub opp
     (gen_phiZ ring0 ring1 add mul opp)
          N.to_nat pow.
 
@@ -241,7 +241,9 @@ Fixpoint interpret3 t fv {struct t}: R :=
   | (PEpow t1 t2) =>
        let v1  := interpret3 t1 fv in pow v1 (N.to_nat t2)
   | (PEc t1) => (IZR1 t1)
-  | (PEX n) => List.nth (pred (Pos.to_nat n)) fv 0
+  | PEO => 0
+  | PEI => 1
+  | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0
   end.
 
 
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
index 4bfcc436..8ff82454 100644
--- a/plugins/nsatz/ideal.ml
+++ b/plugins/nsatz/ideal.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        *)
@@ -16,7 +16,6 @@ a polynomial is a sorted list of (coefficient, monomial)
  *)
 
 open Utile
-open List
 
 exception NotInIdeal
 
@@ -134,7 +133,7 @@ let deg m = m.(0)
 
 let mult_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=0 to d do
     m''.(i)<- (m.(i)+m'.(i));
   done;
@@ -168,7 +167,7 @@ let compare_mon m m' =
 
 let div_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=0 to d do
     m''.(i)<- (m.(i)-m'.(i));
   done;
@@ -199,7 +198,7 @@ let set_deg m =
 (* lcm *)
 let ppcm_mon m m' =
   let d = nvar m in
-  let m'' = Array.create (d+1) 0 in
+  let m'' = Array.make (d+1) 0 in
   for i=1 to d do
     m''.(i)<- (max m.(i) m'.(i));
   done;
@@ -215,13 +214,13 @@ let ppcm_mon m m' =
 let repr p = p
 
 let equal =
-  Util.list_for_all2eq
+  Util.List.for_all2eq
     (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2)
 
 let hash p =
-  let c = map fst p in
-  let m = map snd p in
-  fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
+  let c = List.map fst p in
+  let m = List.map snd p in
+  List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
 
 module Hashpol = Hashtbl.Make(
   struct
@@ -236,9 +235,8 @@ module Hashpol = Hashtbl.Make(
 open Format
 
 let getvar lv i =
-  try (nth lv i)
-  with e when Errors.noncritical e ->
-    (fold_left (fun r x -> r^" "^x) "lv= " lv)
+  try (List.nth lv i)
+  with Failure _ -> (List.fold_left (fun r x -> r^" "^x) "lv= " lv)
     ^" i="^(string_of_int i)
 
 let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
@@ -363,8 +361,8 @@ let stringPcut p =
   (*Polynomesrec.nsP1:=20;*)
   nsP2:=10;
   let res =
-    if (length p)> !nsP2
-    then (stringP [hd p])^" + "^(string_of_int (length p))^" terms"
+    if (List.length p)> !nsP2
+    then (stringP [List.hd p])^" + "^(string_of_int (List.length p))^" terms"
     else  stringP p in
   (*Polynomesrec.nsP1:= max_int;*)
   nsP2:= max_int;
@@ -399,7 +397,7 @@ let zeroP = []
 
 (* returns a constant polynom ial with d variables *)
 let polconst d c =
-  let m = Array.create (d+1) 0 in
+  let m = Array.make (d+1) 0 in
   let m = set_deg m in 
   [(c,m)]
 
@@ -432,7 +430,7 @@ let coef_of_int x = P.of_num (Num.Int x)
 
 (* variable i *)
 let gen d i =
-  let m = Array.create (d+1) 0 in
+  let m = Array.make (d+1) 0 in
   m.(i) <- 1;
   let m = set_deg m in 
   [((coef_of_int 1),m)]
@@ -463,10 +461,10 @@ let puisP p n=
   match p with
     [] -> []
   |_ ->
-      let d = nvar (snd (hd p)) in
+      let d = nvar (snd (List.hd p)) in
       let rec puisP n =
 	match n with
-	  0 -> [coef1, Array.create (d+1) 0]
+	  0 -> [coef1, Array.make (d+1) 0]
 	| 1 -> p
 	|_ -> multP p (puisP (n-1))
       in puisP n
@@ -484,7 +482,7 @@ let contentPlist lp =
   match lp with
   |[] -> coef1
   |p::l1 ->
-      fold_left
+      List.fold_left
 	(fun r q ->
 	  if P.equal r coef1 || P.equal r coefm1
 	  then r
@@ -501,17 +499,17 @@ let polynom0 =  {pol = ref []; num = 0; sugar = 0}
    
 let ppol p = !(p.pol)
 
-let lm p = snd (hd (ppol p))
+let lm p = snd (List.hd (ppol p))
 
 let nallpol = ref 0
 
-let allpol = ref (Array.create 1000 polynom0)
+let allpol = ref (Array.make 1000 polynom0)
 
 let new_allpol p s =
   nallpol := !nallpol + 1;
   if !nallpol >= Array.length !allpol
   then
-    allpol := Array.append !allpol (Array.create !nallpol polynom0);
+    allpol := Array.append !allpol (Array.make !nallpol polynom0);
   let p = {pol = ref p; num = !nallpol; sugar = s} in
   !allpol.(!nallpol)<- p;
   p
@@ -521,7 +519,7 @@ let new_allpol p s =
 let rec selectdiv m l =
   match l with
     [] -> polynom0
-  |q::r -> let m'= snd (hd (ppol q)) in
+  |q::r -> let m'= snd (List.hd (ppol q)) in
     match (div_mon_test m m') with
       true -> q
     |false -> selectdiv m r
@@ -550,7 +548,7 @@ let div_coef a b = P.divP a b
 (* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *)
 
 let reduce2 p l =
-  let l = if nouveaux_pol_en_tete then rev l else l in
+  let l = if nouveaux_pol_en_tete then List.rev l else l in
   let rec reduce p =
     match p with
       [] -> (coef1,[])
@@ -601,8 +599,8 @@ let coefpoldep_set p q c =
 
 let initcoefpoldep d lp =
   poldep:=lp;
-  poldepcontent:= map (fun p -> contentP (ppol p)) lp;
-  iter
+  poldepcontent:= List.map (fun p -> contentP (ppol p)) lp;
+  List.iter
     (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1)))
     lp
 
@@ -610,7 +608,7 @@ let initcoefpoldep d lp =
    divides without pseudodivisions *)
 
 let reduce2_trace p l lcp =
-  let l = if nouveaux_pol_en_tete then rev l else l in
+  let l = if nouveaux_pol_en_tete then List.rev l else l in
   (* rend (lq,r), ou r = p + sum(lq) *)
   let rec reduce p =
     match p with
@@ -646,10 +644,10 @@ let reduce2_trace p l lcp =
      info ((stringP x)^"\n"))
      lq;
      info "ok\n";*)
-  (map2
+  (List.map2
      (fun c0 q ->
        let c =
-	 fold_left
+	 List.fold_left
 	   (fun x (a,m,s) ->
 	     if equal (ppol s) (ppol q)
 	     then
@@ -672,7 +670,7 @@ let pol_courant = ref polynom0
 let sugar_flag = ref true
 
 let compute_sugar p =
-  fold_left (fun s (a,m) -> max s m.(0)) 0 p
+  List.fold_left (fun s (a,m) -> max s m.(0)) 0 p
 
 let mk_polynom p = 
   new_allpol p (compute_sugar p)
@@ -680,12 +678,12 @@ let mk_polynom p =
 let spol ps qs=
   let p = ppol ps in
   let q = ppol qs in
-  let m = snd (hd p) in
-  let m'= snd (hd q) in
-  let a = fst (hd p) in
-  let b = fst (hd q) in
-  let p'= tl p in
-  let q'= tl q in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd q) in
+  let a = fst (List.hd p) in
+  let b = fst (List.hd q) in
+  let p'= List.tl p in
+  let q'= List.tl q in
   let c = (pgcdpos a b) in
   let m''=(ppcm_mon m m') in
   let m1 = div_mon m'' m in
@@ -709,8 +707,8 @@ let spol ps qs=
   
 
 let etrangers p p'=
-  let m = snd (hd p) in
-  let m'= snd (hd p') in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd p') in
   let d = nvar m in
   let res=ref true in
   let i=ref 1 in
@@ -723,9 +721,9 @@ let etrangers p p'=
 (* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *)
 
 let div_ppcm p p' p'' =
-  let m = snd (hd p) in
-  let m'= snd (hd p') in
-  let m''= snd (hd p'') in
+  let m = snd (List.hd p) in
+  let m'= snd (List.hd p') in
+  let m''= snd (List.hd p'') in
   let d = nvar m in
   let res=ref true in
   let i=ref 1 in
@@ -766,7 +764,7 @@ let slice i a q =
 
 (* sugar strategy *)
 
-let rec addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
+let addS x l =    l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
 			  
 let addSsugar x l =
   if !sugar_flag
@@ -823,10 +821,10 @@ let ordcpair ((i1,j1),m1) ((i2,j2),m2) =
   compare_mon m1 m2 
 
 let sortcpairs lcp = 
-  sort ordcpair lcp
+  List.sort ordcpair lcp
 
 let mergecpairs l1 l2 =
-  merge ordcpair l1 l2 
+  List.merge ordcpair l1 l2 
 
 let ord i j =
   if i<j then (i,j) else (j,i)
@@ -838,7 +836,7 @@ let cpair p q =
 	 ppcm_mon (lm p) (lm q))]
       
 let cpairs1 p lq =
-  sortcpairs (fold_left (fun r q -> r @ (cpair p q)) [] lq)
+  sortcpairs (List.fold_left (fun r q -> r @ (cpair p q)) [] lq)
     
 let cpairs lp =
   let rec aux l =
@@ -849,18 +847,18 @@ let cpairs lp =
     
     
 let critere2 ((i,j),m) lp lcp =
-  exists
+  List.exists
     (fun h ->
       h.num <> i && h.num <> j
         && (div_mon_test m (lm h))
 	&& (let c1 = ord i h.num in
-	not (exists (fun (c,_) -> c1 = c) lcp))
+	not (List.exists (fun (c,_) -> c1 = c) lcp))
 	&& (let c1 = ord j h.num in
-	not (exists (fun (c,_) -> c1 = c) lcp)))
+	not (List.exists (fun (c,_) -> c1 = c) lcp)))
     lp
 
 let critere3 ((i,j),m) lp lcp =
-  exists
+  List.exists
     (fun h ->
       h.num <> i && h.num <> j
         && (div_mon_test m (lm h))
@@ -881,8 +879,8 @@ let step = ref 0
 
 let infobuch p q =
   if !step = 0 
-  then (info ("[" ^ (string_of_int (length p))
-              ^ "," ^  (string_of_int (length q))
+  then (info ("[" ^ (string_of_int (List.length p))
+              ^ "," ^  (string_of_int (List.length q))
               ^ "]"))
 
 (* in lp new polynomials are at the end *)
@@ -900,13 +898,13 @@ let test_dans_ideal p lp lp0 =
   pol_courant:= mk_polynom r;
   if r=[]
   then (info "polynomial reduced to 0\n";
-	let lcp = map (fun q -> []) !poldep in
+	let lcp = List.map (fun q -> []) !poldep in
 	let c = !coef_courant in
 	let (lcq,r) = reduce2_trace (emultP c p) lp lcp in
 	info "r ok\n";
 	info ("r: "^(stringP r)^"\n");
         let res=ref  (emultP c p) in
-	iter2
+	List.iter2
 	  (fun cq q -> res:=plusP (!res) (multP cq (ppol q));
 	  )
 	  lcq !poldep;
@@ -916,22 +914,22 @@ let test_dans_ideal p lp lp0 =
 	  match lp with
 	  |[] -> []
 	  |p::lp ->
-	      (map
+	      (List.map
 		 (fun q -> coefpoldep_find p q)
 		 lp)::(aux lp)
 	in
 	let coefficient_multiplicateur = c in
-	let liste_polynomes_de_depart = rev lp0 in
+	let liste_polynomes_de_depart = List.rev lp0 in
 	let polynome_a_tester = p in
 	let liste_des_coefficients_intermediaires =
-	  (let lci = rev (aux (rev lp)) in
+	  (let lci = List.rev (aux (List.rev lp)) in
 	  let lci = ref lci (* (map rev lci) *) in
-	  iter (fun x -> lci := tl (!lci)) lp0;
+	  List.iter (fun x -> lci := List.tl (!lci)) lp0;
 	  !lci) in
 	let liste_des_coefficients =
-	  map
+	  List.map
 	    (fun cq -> emultP (coef_of_int (-1)) cq)
-	    (rev lcq) in
+	    (List.rev lcq) in
 	(liste_polynomes_de_depart,
 	 polynome_a_tester,
 	 {coef = coefficient_multiplicateur;
@@ -946,7 +944,7 @@ let test_dans_ideal p lp lp0 =
 let divide_rem_with_critical_pair = ref false
 
 let list_diff l x =
-  filter (fun y -> y <> x) l
+  List.filter (fun y -> y <> x) l
 
 let deg_hom p =
   match p with
@@ -984,12 +982,12 @@ let pbuchf pq p lp0=
 (*		info "pair reduced\n";*)
 		  a.pol := emultP ca (ppol a);
 		  let (lca,a0) = reduce2_trace (ppol a) lp
-		      (map (fun q -> emultP ca (coefpoldep_find a q))
+		      (List.map (fun q -> emultP ca (coefpoldep_find a q))
 			 !poldep) in
 (*		info "paire re-reduced";*)
 		  a.pol := a0;
 (*		  let a0 = new_allpol a0 sa in*)
-		  iter2 (fun c q ->
+		  List.iter2 (fun c q ->
 		    coefpoldep_remove a q;
 		    coefpoldep_set a q c) lca !poldep;
 		  let a0 = a in
@@ -1009,7 +1007,7 @@ let is_homogeneous p =
   match p with
   | [] -> true
   | (a,m)::p1 -> let d = m.(0) in
-    for_all (fun (b,m') -> m'.(0)=d) p1
+    List.for_all (fun (b,m') -> m'.(0)=d) p1
     
 (* returns
    c
@@ -1030,15 +1028,15 @@ let in_ideal d lp p =
   Hashtbl.clear hmon;
   Hashtbl.clear coefpoldep;
   nallpol := 0;
-  allpol := Array.create 1000 polynom0;
-  homogeneous := for_all is_homogeneous (p::lp);
+  allpol := Array.make 1000 polynom0;
+  homogeneous := List.for_all is_homogeneous (p::lp);
   if !homogeneous then info "homogeneous polynomials\n";
   info ("p: "^(stringPcut p)^"\n");
-  info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
+  info ("lp:\n"^(List.fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
   (*info ("p: "^(stringP p)^"\n");
   info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*)
 
-  let lp = map mk_polynom lp in
+  let lp = List.map mk_polynom lp in
   let p = mk_polynom p in
   initcoefpoldep d lp;
   coef_courant:=coef1;
@@ -1049,7 +1047,7 @@ let in_ideal d lp p =
     with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in
   info "computed\n";
 
-  (map ppol lp1, p1, cert)
+  (List.map ppol lp1, p1, cert)
     
 (* *)
 end
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
index a66bd44b..b4eb57ec 100644
--- a/plugins/nsatz/nsatz.ml4
+++ b/plugins/nsatz/nsatz.ml4
@@ -1,42 +1,24 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Pp
+open Errors
 open Util
-open Names
 open Term
-open Closure
-open Environ
-open Libnames
 open Tactics
-open Glob_term
-open Tacticals
-open Tacexpr
-open Pcoq
-open Tactic
-open Constr
-open Proof_type
 open Coqlib
-open Tacmach
-open Mod_subst
-open Tacinterp
-open Libobject
-open Printer
-open Declare
-open Decl_kinds
-open Entries
 
 open Num
-open Unix
 open Utile
 
+DECLARE PLUGIN "nsatz_plugin"
+
 (***********************************************************************
  Operations on coefficients
 *)
@@ -74,7 +56,7 @@ module BigInt = struct
   let to_int x = int_of_big_int x
   let hash x =
     try (int_of_big_int x)
-    with _-> 1
+    with Failure _ -> 1
   let puis = power_big_int_positive_int
 
   (* a et b positifs, résultat positif *)
@@ -156,7 +138,7 @@ type term =
 
 let const n =
   if eq_num n num_0 then Zero else Const n
-let pow(p,i) = if i=1 then p else Pow(p,i)
+let pow(p,i) = if Int.equal i 1 then p else Pow(p,i)
 let add = function
     (Zero,q) -> q
   | (p,Zero) -> p
@@ -212,7 +194,7 @@ let rec mkt_pos n =
     mkt_app pxI [mkt_pos (quo_num n num_2)]
 
 let mkt_n n =
-  if n=num_0
+  if Num.eq_num n num_0
   then Lazy.force nN0
   else mkt_app nNpos [mkt_pos n]
 
@@ -232,7 +214,7 @@ let rec mkt_term t  =  match t with
 | Add (t1,t2) -> mkt_app  ttadd [Lazy.force tz; mkt_term t1; mkt_term t2]
 | Sub (t1,t2) -> mkt_app  ttsub [Lazy.force tz; mkt_term t1; mkt_term t2]
 | Mul (t1,t2) -> mkt_app  ttmul [Lazy.force tz; mkt_term t1; mkt_term t2]
-| Pow (t1,n) ->  if (n = 0) then
+| Pow (t1,n) ->  if Int.equal n 0 then
     mkt_app ttconst [Lazy.force tz; mkt_z num_1]
 else
     mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)]
@@ -331,7 +313,7 @@ let term_pol_sparse np t=
     match t with
     | Zero -> zeroP
     | Const r ->
-	if r = num_0
+	if Num.eq_num r num_0
 	then zeroP
 	else polconst d (Poly.Pint (Coef.of_num r))
     | Var v ->
@@ -385,19 +367,19 @@ let pol_sparse_to_term n2 p =
 		if m.(k)>0
 		then i0:=k
 	      done;
-	      if !i0 = 0
+	      if Int.equal !i0 0
 	      then (r,d)
 	      else if !i0 > r
 	      then (!i0, m.(!i0))
-	      else if !i0 = r && m.(!i0)<d
+	      else if Int.equal !i0 r && m.(!i0)<d
 	      then (!i0, m.(!i0))
 	      else (r,d))
 	  (0,0)
 	  p in
-      if i0=0
+      if Int.equal i0 0
       then
 	let mp = ref (polrec_to_term a) in
-        if p1=[]
+        if List.is_empty p1
 	then !mp
 	else add(!mp,aux p1)
       else (
@@ -411,7 +393,7 @@ let pol_sparse_to_term n2 p =
 	     else p2:=(a,m)::(!p2))
 	  p;
 	let vm =
-	  if e0=1
+	  if Int.equal e0 1
 	  then Var (string_of_int (i0))
 	  else pow (Var (string_of_int (i0)),e0) in
 	add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2))))
@@ -419,13 +401,13 @@ let pol_sparse_to_term n2 p =
   aux p
 
 
-let rec remove_list_tail l i =
+let remove_list_tail l i =
   let rec aux l i =
-    if l=[]
+    if List.is_empty l
     then []
     else if i<0
     then l
-    else if i=0
+    else if Int.equal i 0
     then List.tl l
     else
       match l with
@@ -447,7 +429,7 @@ let rec remove_list_tail l i =
 let remove_zeros zero lci =
   let n = List.length (List.hd lci) in
   let m=List.length lci in
-  let u = Array.create m false in
+  let u = Array.make m false in
   let rec utiles k =
     if k>=m
     then ()
@@ -543,7 +525,7 @@ let theoremedeszeros_termes lp =
 	  let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
           info "cert ok\n";
 	  let lc = cert.last_comb::List.rev cert.gb_comb in
-	  match remove_zeros (fun x -> x=zeroP) lc with
+	  match remove_zeros (fun x -> equal x zeroP) lc with
 	  | [] -> assert false
 	  | (lq::lci) ->
 	      (* lci commence par les nouveaux polynomes *)
@@ -610,7 +592,7 @@ let nsatz_compute t =
   return_term lpol
 
 TACTIC EXTEND nsatz_compute
-| [ "nsatz_compute"  constr(lt) ] -> [ nsatz_compute lt ]
+| [ "nsatz_compute"  constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ]
 END
 
 
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
index 026b66c7..a9651304 100644
--- a/plugins/nsatz/polynom.ml
+++ b/plugins/nsatz/polynom.ml
@@ -1,14 +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        *)
 (************************************************************************)
 
 (* Recursive polynomials: R[x1]...[xn]. *)
-open Utile
 open Util
+open Utile
 
 (* 1. Coefficients: R *)
 
@@ -133,7 +133,7 @@ let x n = Prec (n,[|cf0;cf1|])
 let monome v n =
   match n with
       0->Pint coef1;
-    |_->let tmp = Array.create (n+1) (Pint coef0) in
+    |_->let tmp = Array.make (n+1) (Pint coef0) in
         tmp.(n)<-(Pint coef1);
         Prec (v, tmp)
 
@@ -159,28 +159,21 @@ let rec max_var_pol2 p =
       Pint _ -> 0
     |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v
 
-let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
+let max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
 
 (* equality between polynomials *)
 
 let rec equal p q =
   match (p,q) with
       (Pint a,Pint b) -> C.equal a b
-    |(Prec(x,p1),Prec(y,q1)) ->
-       if x<>y then false
-       else if (Array.length p1)<>(Array.length q1) then false
-       else (try (Array.iteri (fun i a -> if not (equal a q1.(i))
-			       then failwith "raté")
-		    p1;
-		  true)
-	     with e when Errors.noncritical e -> false)
+    |(Prec(x,p1),Prec(y,q1)) -> (Int.equal x y) && Array.for_all2 equal p1 q1
     | (_,_) -> false
 
 (* normalize polynomial: remove head zeros, coefficients are normalized
    if constant, returns the coefficient
 *)
 
-let rec norm p = match p with
+let norm p = match p with
     Pint _ -> p
   |Prec (x,a)->
      let d = (Array.length a -1) in
@@ -189,17 +182,17 @@ let rec norm p = match p with
 	 n:=!n-1;
        done;
        if !n<0 then Pint coef0
-       else if !n=0 then a.(0)
-       else if !n=d then p
-       else (let b=Array.create (!n+1) (Pint coef0) in
+       else if Int.equal !n 0 then a.(0)
+       else if Int.equal !n d then p
+       else (let b=Array.make (!n+1) (Pint coef0) in
                for i=0 to !n do b.(i)<-a.(i);done;
                Prec(x,b))
 
 
 (* degree in v, v >= max var of p *)
-let rec deg v p =
+let deg v p =
   match p with
-      Prec(x,p1) when x=v -> Array.length p1 -1
+      Prec(x,p1) when Int.equal x v -> Array.length p1 -1
     |_ -> 0
 
 
@@ -219,8 +212,8 @@ let rec copyP p =
 (* coefficient of degree i in v, v >= max var of p *)
 let coef v i p =
   match p with
-      Prec (x,p1) when x=v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
-    |_ -> if i=0 then p else Pint coef0
+      Prec (x,p1) when Int.equal x v  -> if i<(Array.length p1) then p1.(i) else Pint coef0
+    |_ -> if Int.equal i 0 then p else Pint coef0
 
 (* addition *)
 
@@ -243,7 +236,7 @@ let rec plusP p q =
                               Prec (x,p2))
           else
             (let n=max (deg x p) (deg x q) in
-             let r=Array.create (n+1) (Pint coef0) in
+             let r=Array.make (n+1) (Pint coef0) in
                for i=0 to n do
                  r.(i)<- plusP (coef x i p) (coef x i q);
                done;
@@ -275,15 +268,15 @@ let rec vars=function
 
 
 (* multiply p by v^n, v >= max_var p *)
-let rec multx n v p =
+let multx n v p =
   match p with
-      Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in
+      Prec (x,p1) when Int.equal x v -> let p2= Array.make ((Array.length p1)+n) (Pint coef0) in
         for i=0 to (Array.length p1)-1 do
           p2.(i+n)<-p1.(i);
         done;
         Prec (x,p2)
     |_ -> if equal p (Pint coef0) then (Pint coef0)
-       else (let p2=Array.create (n+1) (Pint coef0) in
+       else (let p2=Array.make (n+1) (Pint coef0) in
                p2.(n)<-p;
                Prec (v,p2))
 
@@ -313,14 +306,14 @@ let rec multP p q =
 
 
 (* derive p with variable v, v >= max_var p *)
-let rec deriv v p =
+let deriv v p =
   match p with
       Pint a -> Pint coef0
-    | Prec(x,p1) when x=v ->
+    | Prec(x,p1) when Int.equal x v ->
        let d = Array.length p1 -1 in
-         if d=1 then p1.(1)
+         if Int.equal d 1 then p1.(1)
          else
-           (let p2 = Array.create d (Pint coef0) in
+           (let p2 = Array.make d (Pint coef0) in
               for i=0 to d-1 do
 		p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1);
               done;
@@ -415,7 +408,7 @@ let rec string_of_Pcut p =
       and s=ref ""
       and sp=ref "" in
     let st0 = string_of_Pcut t.(0) in
-      if st0<>"0"
+      if not (String.equal st0 "0")
       then s:=st0;
     let fin = ref false in
     for i=(Array.length t)-1 downto 1 do
@@ -426,31 +419,31 @@ let rec string_of_Pcut p =
       else (
 	let si=string_of_Pcut  t.(i) in
 	sp:="";
-	if i=1
+	if Int.equal i 1
 	then (
-	  if si<>"0"
+	  if not (String.equal si "0")
 	  then (nsP:=(!nsP)-1;
-		if si="1"
+		if String.equal si "1"
 		then sp:=v
 		else
 		  (if (String.contains si '+')
 		  then sp:="("^si^")*"^v
 		  else sp:=si^"*"^v)))
 	else (
-	  if si<>"0"
+	  if not (String.equal si "0")
 	  then (nsP:=(!nsP)-1;
-		if si="1"
+		if String.equal si "1"
 		then sp:=v^"^"^(string_of_int i)
 		else (if (String.contains si '+')
 		then sp:="("^si^")*"^v^"^"^(string_of_int i)
 		else  sp:=si^"*"^v^"^"^(string_of_int i))));
-	if !sp<>"" && not (!fin)
+	if not (String.is_empty !sp) && not (!fin)
 	then (nsP:=(!nsP)-1;
-	      if !s=""
+	      if String.is_empty !s
 	      then s:=!sp
 	      else s:=(!s)^"+"^(!sp)));
     done;
-    if !s="" then (nsP:=(!nsP)-1;
+    if String.is_empty !s then (nsP:=(!nsP)-1;
 		   (s:="0"));
     !s
 
@@ -473,7 +466,7 @@ let print_lpoly lp = print_tpoly (Array.of_list lp)
 
 (* return (s,r) s.t. p = s*q+r *)
 let rec quo_rem_pol p q x =
-  if x=0
+  if Int.equal x 0
   then (match (p,q) with
           |(Pint a, Pint b) ->
 	     if C.equal (C.modulo a b) coef0
@@ -519,12 +512,11 @@ let divP p q=
 
 let div_pol_rat p q=
   let x = max (max_var_pol p) (max_var_pol q) in
-    try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q))
-				     (1+(deg x p) - (deg x q))))
-		   q x in
-         (* degueulasse, mais c 'est pour enlever un warning *)
-         if s==s then true else true)
-    with e when Errors.noncritical e -> false
+  try
+    let r = puisP (Pint(coef_int_tete q)) (1+(deg x p)-(deg x q)) in
+    let _ = div_pol (multP p r) q x in
+    true
+  with Failure _ -> false
 
 (***********************************************************************
   5. Pseudo-division and gcd with subresultants.
@@ -538,7 +530,7 @@ let div_pol_rat p q=
 let pseudo_div p q x =
   match q with
       Pint _ -> (cf0, q,1, p)
-    | Prec (v,q1) when x<>v -> (cf0, q,1, p)
+    | Prec (v,q1) when not (Int.equal x v) -> (cf0, q,1, p)
     | Prec (v,q1) ->
 	(
 	  (*  pr "pseudo_division: c^d*p = s*q + r";*)
@@ -575,13 +567,13 @@ and pgcd_pol p q x =
 
 and content_pol p x =
   match p with
-      Prec(v,p1) when v=x ->
+      Prec(v,p1) when Int.equal v x ->
         Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1
     | _ -> p
 
 and pgcd_coef_pol c p x =
   match p with
-      Prec(v,p1) when x=v ->
+      Prec(v,p1) when Int.equal x v ->
         Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c  p1
     |_ -> pgcd_pol_rec c p (x-1)
 
@@ -593,9 +585,9 @@ and pgcd_pol_rec p q x =
 	  then q
 	  else if equal q cf0
 	  then p
-	  else if (deg x q) = 0
+	  else if Int.equal (deg x q) 0
 	  then pgcd_coef_pol q p x
-	  else if (deg x p) = 0
+	  else if Int.equal (deg x p) 0
 	  then pgcd_coef_pol p q x
 	  else (
 	    let a = content_pol p x in
@@ -610,7 +602,7 @@ and pgcd_pol_rec p q x =
 	    res
 	   )
 
-(* Sub-résultants:
+(* Sub-résultants:
 
    ai*Ai = Qi*Ai+1 + bi*Ai+2
 
@@ -655,7 +647,7 @@ and gcd_sub_res_rec p q s c d x =
 
 and lazard_power c s d x =
   let res = ref c in
-    for i=1 to d-1 do
+    for _i = 1 to d - 1 do
       res:= div_pol ((!res)@@c) s x;
     done;
     !res
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
index 0f1e0481..9d46cd99 100644
--- a/plugins/nsatz/polynom.mli
+++ b/plugins/nsatz/polynom.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/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
index 17c8654b..8e2fc07c 100644
--- a/plugins/nsatz/utile.ml
+++ b/plugins/nsatz/utile.ml
@@ -26,20 +26,6 @@ let set_of_list_eq eq l =
    List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l;
    List.rev !res
 
-
-(* Memoization
-   f is compatible with nf: f(nf(x)) = f(x)
-*)
-
-let memos s memoire nf f x =
-   try (let v = Hashtbl.find memoire (nf x) in pr s;v)
-   with e when Errors.noncritical e ->
-     (pr "#";
-      let v = f x in
-      Hashtbl.add memoire (nf x) v;
-      v)
-
-
 (**********************************************************************
   Eléments minimaux pour un ordre partiel de division.
   E est un ensemble, avec une multiplication
@@ -95,7 +81,7 @@ let facteurs_liste div constant lp =
    c est un élément quelconque de E.
 *)
 let factorise_tableau div zero c f l1 =
-    let res = Array.create (Array.length f) (c,[]) in
+    let res = Array.make (Array.length f) (c,[]) in
     Array.iteri (fun i p ->
       let r = ref p in
       let li = ref [] in
diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli
index 83b2ac39..1f841575 100644
--- a/plugins/nsatz/utile.mli
+++ b/plugins/nsatz/utile.mli
@@ -10,10 +10,6 @@ val info : string -> unit
 val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
 val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list
 
-(* Memoization *)
-val memos :
-  string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b
-
 
 val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list
 val factorise_tableau :
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index 0192528c..7400d462 100644
--- a/plugins/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -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        *)
@@ -54,4 +54,4 @@ Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith.
 Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith.
 Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith.
 
-Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file
+Hint Extern 10 False => abstract omega: zarith.
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
index d23e3d13..9e5c1484 100644
--- a/plugins/omega/OmegaPlugin.v
+++ b/plugins/omega/OmegaPlugin.v
@@ -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/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
index ae445f3a..ee0f841c 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -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        *)
@@ -400,6 +400,5 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
 
 (** The complete Z-ification tactic *)
 
-Ltac zify :=
- repeat progress (zify_nat; zify_positive; zify_N); zify_op.
+Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op.
 
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 78d276da..37428c39 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.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        *)
@@ -9,38 +9,35 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (**************************************************************************)
 
+open Errors
 open Util
-open Pp
-open Reduction
-open Proof_type
 open Names
 open Nameops
 open Term
-open Declarations
-open Environ
-open Sign
-open Inductive
 open Tacticals
 open Tacmach
-open Evar_refiner
 open Tactics
-open Clenv
 open Logic
 open Libnames
+open Globnames
 open Nametab
 open Contradiction
+open Misctypes
 
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
 open OmegaSolver
 
 (* Added by JCF, 09/03/98 *)
 
-let elim_id id gl = simplest_elim (pf_global gl id) gl
-let resolve_id id gl = apply (pf_global gl id) gl
+let elim_id id =
+  Proofview.Goal.nf_enter begin fun gl ->
+    simplest_elim (Tacmach.New.pf_global id gl)
+  end
+let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl
 
 let timing timer_name f arg = f arg
 
@@ -51,20 +48,15 @@ let old_style_flag = ref false
 
 (* Should we reset all variable labels between two runs of omega ? *)
 
-let reset_flag = ref false
+let reset_flag = ref true
 
-(* Historical version of Coq do not perform such resets, and this
-   implies that omega is slightly non-deterministic: successive runs of
-   omega on the same problem may lead to distinct proof-terms.
-   At the very least, these terms will differ on the inner
+(* Coq < 8.5 was not performing such resets, hence omega was slightly
+   non-deterministic: successive runs of omega on the same problem may
+   lead to distinct proof-terms.
+   At the very least, these terms differed on the inner
    variable names, but they could even be non-convertible :
    the OmegaSolver relies on Hashtbl.iter, it can hence find a different
-   solution when variable indices differ.
-
-   Starting from Coq 8.4pl4, omega may be made stable via the option
-   [Set Stable Omega]. In the 8.4 branch, this option is unset by default
-   for compatibility. In Coq >= 8.5, this option is set by default.
-*)
+   solution when variable indices differ. *)
 
 let read f () = !f
 let write f x = f:=x
@@ -101,19 +93,12 @@ let _ =
 let _ =
   declare_bool_option
     { optsync  = true;
-      optdepr  = false;
+      optdepr  = true;
       optname  = "Omega automatic reset of generated names";
       optkey   = ["Stable";"Omega"];
       optread  = read reset_flag;
       optwrite = write reset_flag }
 
-let all_time        = timing "Omega     "
-let solver_time     = timing "Solver    "
-let exact_time      = timing "Rewrites  "
-let elim_time       = timing "Elim      "
-let simpl_time      = timing "Simpl     "
-let generalize_time = timing "Generalize"
-
 let intref, reset_all_references =
   let refs = ref [] in
   (fun n -> let r = ref n in refs := (r,n) :: !refs; r),
@@ -121,7 +106,7 @@ let intref, reset_all_references =
 
 let new_identifier =
   let cpt = intref 0 in
-  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
+  (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; Id.of_string s)
 
 let new_identifier_state =
   let cpt = intref 0 in
@@ -129,7 +114,7 @@ let new_identifier_state =
 
 let new_identifier_var =
   let cpt = intref 0 in
-  (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
+  (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; Id.of_string s)
 
 let new_id =
   let cpt = intref 0 in fun () -> incr cpt; !cpt
@@ -145,7 +130,7 @@ let display_var i = Printf.sprintf "X%d" i
 let intern_id,unintern_id,reset_intern_tables =
   let cpt = ref 0 in
   let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
-  (fun (name : identifier) ->
+  (fun (name : Id.t) ->
      try Hashtbl.find table name with Not_found ->
        let idx = !cpt in
        Hashtbl.add table name idx;
@@ -159,30 +144,33 @@ let intern_id,unintern_id,reset_intern_tables =
 
 let mk_then = tclTHENLIST
 
-let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c])
+let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c])
 
-let generalize_tac t = generalize_time (generalize t)
-let elim t = elim_time (simplest_elim t)
-let exact t = exact_time (Tactics.refine t)
-let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s]
+let generalize_tac t = generalize t
+let elim t = simplest_elim t
+let exact t = Tactics.refine t
+let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s]
 
 let rev_assoc k =
   let rec loop = function
-    | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l
+    | [] -> raise Not_found
+    | (v,k')::_ when Int.equal k k' -> v
+    | _ :: l -> loop l
   in
   loop
 
 let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags =
-  let l = ref ([]:(identifier * int) list) in
+  let l = ref ([]:(Id.t * int) list) in
   (fun h id -> l := (h,id):: !l),
-  (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
+  (fun h -> try Id.List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
   (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis"),
   (fun () -> l := [])
 
 let hide_constr,find_constr,clear_constr_tables,dump_tables =
-  let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
+  let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in
   (fun h id eg b -> l := (h,(id,eg,b)):: !l),
-  (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"),
+  (fun h ->
+    try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"),
   (fun () -> l := []),
   (fun () -> !l)
 
@@ -230,8 +218,6 @@ let coq_Zopp = lazy (zbase_constant "Z.opp")
 let coq_Zminus = lazy (zbase_constant "Z.sub")
 let coq_Zsucc = lazy (zbase_constant "Z.succ")
 let coq_Zpred = lazy (zbase_constant "Z.pred")
-let coq_Zgt = lazy (zbase_constant "Z.gt")
-let coq_Zle = lazy (zbase_constant "Z.le")
 let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat")
 let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add")
 let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul")
@@ -318,10 +304,10 @@ let coq_le = lazy (init_constant "le")
 let coq_lt = lazy (init_constant "lt")
 let coq_ge = lazy (init_constant "ge")
 let coq_gt = lazy (init_constant "gt")
-let coq_minus = lazy (init_constant "minus")
-let coq_plus = lazy (init_constant "plus")
-let coq_mult = lazy (init_constant "mult")
-let coq_pred = lazy (init_constant "pred")
+let coq_minus = lazy (init_constant "Nat.sub")
+let coq_plus = lazy (init_constant "Nat.add")
+let coq_mult = lazy (init_constant "Nat.mul")
+let coq_pred = lazy (init_constant "Nat.pred")
 let coq_nat = lazy (init_constant "nat")
 let coq_S = lazy (init_constant "S")
 let coq_O = lazy (init_constant "O")
@@ -363,11 +349,10 @@ let coq_iff = lazy (constant "iff")
 (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *)
 
 (* For unfold *)
-open Closure
 let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
-  | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
+  | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
       EvalConstRef kn
-  | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
+  | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant"))
 
 let sp_Zsucc =     lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc)
 let sp_Zpred =     lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred)
@@ -378,19 +363,20 @@ let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge)
 let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt)
 let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
 
-let mk_var v = mkVar (id_of_string v)
+let mk_var v = mkVar (Id.of_string v)
 let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |])
 let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
 let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
-let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |])
+let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()),
+			 [| Lazy.force coq_Z; t1; t2 |])
 let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |])
 let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |])
 let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |])
 let mk_and t1 t2 =  mkApp (build_coq_and (), [| t1; t2 |])
 let mk_or t1 t2 =  mkApp (build_coq_or (), [| t1; t2 |])
 let mk_not t = mkApp (build_coq_not (), [| t |])
-let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
-			      [| Lazy.force coq_comparison; t1; t2 |])
+let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()),
+			     [| Lazy.force coq_comparison; t1; t2 |])
 let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
 
 let mk_integer n =
@@ -419,7 +405,7 @@ type omega_proposition =
   | Kn
 
 type result =
-  | Kvar of identifier
+  | Kvar of Id.t
   | Kapp of omega_constant * constr list
   | Kimp of constr * constr
   | Kufo
@@ -434,7 +420,7 @@ type result =
 let destructurate_prop t =
   let c, args = decompose_app t in
   match kind_of_term c, args with
-    | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args)
+    | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args)
@@ -451,11 +437,11 @@ let destructurate_prop t =
     | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args)
     | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args)
-    | Const sp, args ->
+    | Const (sp,_), args ->
 	Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args)
-    | Construct csp , args ->
+    | Construct (csp,_) , args ->
 	Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args)
-    | Ind isp, args ->
+    | Ind (isp,_), args ->
 	Kapp (Other (string_of_path (path_of_global (IndRef isp))),args)
     | Var id,[] -> Kvar id
     | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
@@ -549,7 +535,6 @@ let context operation path (t : constr) =
       | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
 	  (mkLetIn (n,b,loop i p t,c))
       | (p, _) ->
-	  ppnl (Printer.pr_lconstr t);
 	  failwith ("abstract_path " ^ string_of_int(List.length p))
   in
   loop 1 path t
@@ -570,7 +555,6 @@ let occurence path (t : constr) =
     | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
     | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
     | (p, _) ->
-	ppnl (Printer.pr_lconstr t);
 	failwith ("occurence " ^ string_of_int(List.length p))
   in
   loop path t
@@ -578,19 +562,19 @@ let occurence path (t : constr) =
 let abstract_path typ path t =
   let term_occur = ref (mkRel 0) in
   let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in
-  mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur
+  mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur
 
 let focused_simpl path gl =
   let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
-  convert_concl_no_check newc DEFAULTcast gl
+  Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl
 
-let focused_simpl path = simpl_time (focused_simpl path)
+let focused_simpl path = focused_simpl path
 
 type oformula =
   | Oplus of oformula * oformula
   | Oinv of  oformula
   | Otimes of oformula * oformula
-  | Oatom of identifier
+  | Oatom of Id.t
   | Oz of bigint
   | Oufo of constr
 
@@ -602,7 +586,7 @@ let rec oprint = function
   | Otimes (t1,t2) ->
       print_string "("; oprint t1; print_string "*";
       oprint t2; print_string ")"
-  | Oatom s -> print_string (string_of_id s)
+  | Oatom s -> print_string (Id.to_string s)
   | Oz i -> print_string (string_of_bigint i)
   | Oufo f -> print_string "?"
 
@@ -629,11 +613,11 @@ let compile name kind =
 	let id = new_id () in
 	tag_hypothesis name id;
 	{kind = kind; body = List.rev accu; constant = n; id = id}
-    | _ -> anomaly "compile_equation"
+    | _ -> anomaly (Pp.str "compile_equation")
   in
   loop []
 
-let rec decompile af =
+let decompile af =
   let rec loop = function
     | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r)
     | [] -> Oz af.constant
@@ -648,10 +632,10 @@ let clever_rewrite_base_poly typ p result theorem gl =
   let t =
     applist
       (mkLambda
-	 (Name (id_of_string "P"),
+	 (Name (Id.of_string "P"),
 	  mkArrow typ mkProp,
           mkLambda
-	    (Name (id_of_string "H"),
+	    (Name (Id.of_string "H"),
 	     applist (mkRel 1,[result]),
 	     mkApp (Lazy.force coq_eq_ind_r,
 		       [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
@@ -724,10 +708,10 @@ let rec shuffle p (t1,t2) =
 	  Oplus(t2,t1)
 	else [],Oplus(t1,t2)
 
-let rec shuffle_mult p_init k1 e1 k2 e2 =
+let shuffle_mult p_init k1 e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
+	if Int.equal v1 v2 then
           let tac =
             clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
                               [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
@@ -781,10 +765,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 =
   in
   loop p_init (e1,e2)
 
-let rec shuffle_mult_right p_init e1 k2 e2 =
+let shuffle_mult_right p_init e1 k2 e2 =
   let rec loop p = function
     | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
+	if Int.equal v1 v2 then
           let tac =
             clever_rewrite p
               [[P_APP 1; P_APP 1; P_APP 1];
@@ -866,7 +850,7 @@ let rec scalar p n = function
   | Oz i -> [focused_simpl p],Oz(n*i)
   | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
 
-let rec scalar_norm p_init =
+let scalar_norm p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | (_::l) ->
@@ -877,7 +861,7 @@ let rec scalar_norm p_init =
   in
   loop p_init
 
-let rec norm_add p_init =
+let norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | _:: l ->
@@ -887,7 +871,7 @@ let rec norm_add p_init =
   in
   loop p_init
 
-let rec scalar_norm_add p_init =
+let scalar_norm_add p_init =
   let rec loop p = function
     | [] -> [focused_simpl p_init]
     | _ :: l ->
@@ -1015,7 +999,7 @@ let reduce_factor p = function
 
 let rec condense p = function
   | Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight f1 = weight f2 then begin
+      if Int.equal (weight f1) (weight f2) then begin
 	let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
 	let assoc_tac =
           clever_rewrite p
@@ -1031,7 +1015,7 @@ let rec condense p = function
   | Oplus(f1,Oz n) ->
       let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
   | Oplus(f1,f2) ->
-      if weight f1 = weight f2 then begin
+      if Int.equal (weight f1) (weight f2) then begin
 	let tac_shrink,t = shrink_pair p f1 f2 in
 	let tac,t' = condense p t in
 	tac_shrink :: tac,t'
@@ -1059,17 +1043,17 @@ let rec clear_zero p = function
   | t -> [],t
 
 let replay_history tactic_normalisation =
-  let aux  = id_of_string "auxiliary" in
-  let aux1 = id_of_string "auxiliary_1" in
-  let aux2 = id_of_string "auxiliary_2" in
+  let aux  = Id.of_string "auxiliary" in
+  let aux1 = Id.of_string "auxiliary_1" in
+  let aux2 = Id.of_string "auxiliary_2" in
   let izero = mk_integer zero in
-  let rec loop t =
+  let rec loop t : unit Proofview.tactic =
     match t with
       | HYP e :: l ->
 	  begin
 	    try
-	      tclTHEN
-		(List.assoc (hyp_of_tag e.id) tactic_normalisation)
+	      Tacticals.New.tclTHEN
+		(Id.List.assoc (hyp_of_tag e.id) tactic_normalisation)
 		(loop l)
 	    with Not_found -> loop l end
       | NEGATE_CONTRADICT (e2,e1,b) :: l ->
@@ -1080,16 +1064,16 @@ let replay_history tactic_normalisation =
 	  let k = if b then negone else one in
 	  let p_initial = [P_APP 1;P_TYPE] in
 	  let tac= shuffle_mult_right p_initial e1.body k e2.body in
-	  tclTHENLIST [
-	    (generalize_tac
+	  Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (generalize_tac
 	      [mkApp (Lazy.force coq_OMEGA17, [|
 		val_of eq1;
 		val_of eq2;
 		mk_integer k;
 		mkVar id1; mkVar id2 |])]);
-	    (mk_then tac);
+	    Proofview.V82.tactic (mk_then tac);
 	    (intros_using [aux]);
-	    (resolve_id aux);
+	    Proofview.V82.tactic (resolve_id aux);
             reflexivity
           ]
       | CONTRADICTION (e1,e2) :: l ->
@@ -1098,15 +1082,16 @@ let replay_history tactic_normalisation =
 	  let p_initial = [P_APP 2;P_TYPE] in
 	  let tac = shuffle_cancel p_initial e1.body in
 	  let solve_le =
-            let not_sup_sup = mkApp (build_coq_eq (), [|
+            let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()),
+				     [|
 					Lazy.force coq_comparison;
 					Lazy.force coq_Gt;
 					Lazy.force coq_Gt |])
 	    in
-            tclTHENS
-	      (tclTHENLIST [
-		(unfold sp_Zle);
-		(simpl_in_concl);
+            Tacticals.New.tclTHENS
+	      (Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zle);
+		Proofview.V82.tactic (simpl_in_concl);
 		intro;
 		(absurd not_sup_sup) ])
 	      [ assumption ; reflexivity ]
@@ -1117,7 +1102,7 @@ let replay_history tactic_normalisation =
 		      mkVar (hyp_of_tag e1.id);
 		      mkVar (hyp_of_tag e2.id) |])
 	  in
-	  tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
+	  Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (generalize_tac [theorem]) (mk_then tac))) (solve_le)
       | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
 	  let id = hyp_of_tag e1.id in
 	  let eq1 = val_of(decompile e1)
@@ -1127,34 +1112,34 @@ let replay_history tactic_normalisation =
 	  let rhs = mk_plus (mk_times eq2 kk) dd in
 	  let state_eg = mk_eq eq1 rhs in
 	  let tac = scalar_norm_add [P_APP 3] e2.body in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut state_eg)
-	    [ tclTHENS
-	        (tclTHENLIST [
+	    [ Tacticals.New.tclTHENS
+	        (Tacticals.New.tclTHENLIST [
 		  (intros_using [aux]);
-		  (generalize_tac
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA1,
 		      [| eq1; rhs; mkVar aux; mkVar id |])]);
-		  (clear [aux;id]);
+		  Proofview.V82.tactic (clear [aux;id]);
 		  (intros_using [id]);
 		  (cut (mk_gt kk dd)) ])
-	        [ tclTHENS
+	        [ Tacticals.New.tclTHENS
 		    (cut (mk_gt kk izero))
-		    [ tclTHENLIST [
+		    [ Tacticals.New.tclTHENLIST [
 		        (intros_using [aux1; aux2]);
-		        (generalize_tac
+		        (Proofview.V82.tactic (generalize_tac
 			  [mkApp (Lazy.force coq_Zmult_le_approx,
-			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
-		        (clear [aux1;aux2;id]);
+			    [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]));
+		        Proofview.V82.tactic (clear [aux1;aux2;id]);
 		        (intros_using [id]);
 		        (loop l) ];
-		      tclTHENLIST [
-			(unfold sp_Zgt);
-			(simpl_in_concl);
+		      Tacticals.New.tclTHENLIST [
+			(Proofview.V82.tactic (unfold sp_Zgt));
+			(Proofview.V82.tactic simpl_in_concl);
 			reflexivity ] ];
-		  tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
+		  Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ]
                 ];
-	      tclTHEN (mk_then tac) reflexivity ]
+	      Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
 
       | NOT_EXACT_DIVIDE (e1,k) :: l ->
 	  let c = floor_div e1.constant k in
@@ -1165,27 +1150,27 @@ let replay_history tactic_normalisation =
 	  let kk = mk_integer k
 	  and dd = mk_integer d in
 	  let tac = scalar_norm_add [P_APP 2] e2.body in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut (mk_gt dd izero))
-	    [ tclTHENS (cut (mk_gt kk dd))
-		[tclTHENLIST [
+	    [ Tacticals.New.tclTHENS (cut (mk_gt kk dd))
+		[Tacticals.New.tclTHENLIST [
 		  (intros_using [aux2;aux1]);
-		  (generalize_tac
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_OMEGA4,
                       [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
-		  (clear [aux1;aux2]);
-		  (unfold sp_not);
+		  Proofview.V82.tactic (clear [aux1;aux2]);
+		  Proofview.V82.tactic (unfold sp_not);
 		  (intros_using [aux]);
-		  (resolve_id aux);
-		  (mk_then tac);
+		  Proofview.V82.tactic (resolve_id aux);
+		  Proofview.V82.tactic (mk_then tac);
 		  assumption ] ;
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-		   simpl_in_concl;
+		 Tacticals.New.tclTHENLIST [
+		   Proofview.V82.tactic (unfold sp_Zgt);
+		   Proofview.V82.tactic simpl_in_concl;
 		   reflexivity ] ];
-              tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl;
+              Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zgt);
+                Proofview.V82.tactic simpl_in_concl;
 		reflexivity ] ]
       | EXACT_DIVIDE (e1,k) :: l ->
 	  let id = hyp_of_tag e1.id in
@@ -1194,38 +1179,38 @@ let replay_history tactic_normalisation =
 	  and eq2 = val_of(decompile e2) in
 	  let kk = mk_integer k in
 	  let state_eq = mk_eq eq1 (mk_times eq2 kk) in
-	  if e1.kind = DISE then
+	  if e1.kind == DISE then
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS
+            Tacticals.New.tclTHENS
 	      (cut state_eq)
-	      [tclTHENLIST [
+	      [Tacticals.New.tclTHENLIST [
 		(intros_using [aux1]);
-		(generalize_tac
+		Proofview.V82.tactic (generalize_tac
 		  [mkApp (Lazy.force coq_OMEGA18,
                     [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
-		(clear [aux1;id]);
+		Proofview.V82.tactic (clear [aux1;id]);
 		(intros_using [id]);
 		(loop l) ];
-	       tclTHEN (mk_then tac) reflexivity ]
+	       Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
 	  else
             let tac = scalar_norm [P_APP 3] e2.body in
-            tclTHENS (cut state_eq)
+            Tacticals.New.tclTHENS (cut state_eq)
 	      [
-		tclTHENS
+		Tacticals.New.tclTHENS
 		 (cut (mk_gt kk izero))
-		 [tclTHENLIST [
+		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   (generalize_tac
+		   Proofview.V82.tactic (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA3,
 		       [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
-		   (clear [aux1;aux2;id]);
+		   Proofview.V82.tactic (clear [aux1;aux2;id]);
 		   (intros_using [id]);
 		   (loop l) ];
-		  tclTHENLIST [
-		    (unfold sp_Zgt);
-                    simpl_in_concl;
+		  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (unfold sp_Zgt);
+                    Proofview.V82.tactic simpl_in_concl;
 		    reflexivity ] ];
-		tclTHEN (mk_then tac) reflexivity ]
+		Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
       | (MERGE_EQ(e3,e1,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
@@ -1238,16 +1223,16 @@ let replay_history tactic_normalisation =
 	      (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             scalar_norm [P_APP 3] e1.body
 	  in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut (mk_eq eq1 (mk_inv eq2)))
-	    [tclTHENLIST [
+	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
-	      (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
+	      Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
 	        [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
-	      (clear [id1;id2;aux]);
+	      Proofview.V82.tactic (clear [id1;id2;aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (mk_then tac) reflexivity]
+            Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity]
 
       | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
 	  let id = new_identifier ()
@@ -1271,21 +1256,21 @@ let replay_history tactic_normalisation =
               [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
             shuffle_mult_right p_initial
               orig.body m ({c= negone;v= v}::def.body) in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (cut theorem)
-	    [tclTHENLIST [
+	    [Tacticals.New.tclTHENLIST [
 	      (intros_using [aux]);
 	      (elim_id aux);
-	      (clear [aux]);
+	      Proofview.V82.tactic (clear [aux]);
 	      (intros_using [vid; aux]);
-	      (generalize_tac
+	      Proofview.V82.tactic (generalize_tac
 		[mkApp (Lazy.force coq_OMEGA9,
 		  [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
-	      (mk_then tac);
-	      (clear [aux]);
+	      Proofview.V82.tactic (mk_then tac);
+	      Proofview.V82.tactic (clear [aux]);
 	      (intros_using [id]);
 	      (loop l) ];
-            tclTHEN (exists_tac eq1) reflexivity ]
+            Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ]
       | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
 	  let id1 = new_identifier ()
 	  and id2 = new_identifier () in
@@ -1294,10 +1279,10 @@ let replay_history tactic_normalisation =
 	  let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
 	  let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
 	  let eq = val_of(decompile e) in
-	  tclTHENS
+	  Tacticals.New.tclTHENS
 	    (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
-	    [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
-             tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
+	    [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ];
+             Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]]
       | SUM(e3,(k1,e1),(k2,e2)) :: l ->
 	  let id = new_identifier () in
 	  tag_hypothesis id e3;
@@ -1305,7 +1290,7 @@ let replay_history tactic_normalisation =
 	  and id2 = hyp_of_tag e2.id in
 	  let eq1 = val_of(decompile e1)
 	  and eq2 = val_of(decompile e2) in
-	  if k1 =? one & e2.kind = EQUA then
+	  if k1 =? one && e2.kind == EQUA then
             let tac_thm =
               match e1.kind with
 		| EQUA -> Lazy.force coq_OMEGA5
@@ -1314,12 +1299,12 @@ let replay_history tactic_normalisation =
 	    in
             let kk = mk_integer k2 in
             let p_initial =
-              if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
+              if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
             let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
-            tclTHENLIST [
-	      (generalize_tac
+            Tacticals.New.tclTHENLIST [
+	      Proofview.V82.tactic (generalize_tac
                 [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
-	      (mk_then tac);
+	      Proofview.V82.tactic (mk_then tac);
 	      (intros_using [id]);
 	      (loop l)
             ]
@@ -1328,43 +1313,43 @@ let replay_history tactic_normalisation =
 	    and kk2 = mk_integer k2 in
 	    let p_initial = [P_APP 2;P_TYPE] in
 	    let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
-            tclTHENS (cut (mk_gt kk1 izero))
-	      [tclTHENS
+            Tacticals.New.tclTHENS (cut (mk_gt kk1 izero))
+	      [Tacticals.New.tclTHENS
 		 (cut (mk_gt kk2 izero))
-		 [tclTHENLIST [
+		 [Tacticals.New.tclTHENLIST [
 		   (intros_using [aux2;aux1]);
-		   (generalize_tac
+		   Proofview.V82.tactic (generalize_tac
 		     [mkApp (Lazy.force coq_OMEGA7, [|
 		       eq1;eq2;kk1;kk2;
 		       mkVar aux1;mkVar aux2;
 		       mkVar id1;mkVar id2 |])]);
-		   (clear [aux1;aux2]);
-		   (mk_then tac);
+		   Proofview.V82.tactic (clear [aux1;aux2]);
+		   Proofview.V82.tactic (mk_then tac);
 		   (intros_using [id]);
 		   (loop l) ];
-		 tclTHENLIST [
-		   (unfold sp_Zgt);
-                   simpl_in_concl;
+		 Tacticals.New.tclTHENLIST [
+		   Proofview.V82.tactic (unfold sp_Zgt);
+                   Proofview.V82.tactic simpl_in_concl;
 		   reflexivity ] ];
-	      tclTHENLIST [
-		(unfold sp_Zgt);
-                simpl_in_concl;
+	      Tacticals.New.tclTHENLIST [
+		Proofview.V82.tactic (unfold sp_Zgt);
+                Proofview.V82.tactic simpl_in_concl;
 		reflexivity ] ]
       | CONSTANT_NOT_NUL(e,k) :: l ->
-	  tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
+	  Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
       | CONSTANT_NUL(e) :: l ->
-	  tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
+	  Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity
       | CONSTANT_NEG(e,k) :: l ->
-	  tclTHENLIST [
-	    (generalize_tac [mkVar (hyp_of_tag e)]);
-            (unfold sp_Zle);
-	    simpl_in_concl;
-	    (unfold sp_not);
+	  Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]);
+            Proofview.V82.tactic (unfold sp_Zle);
+	    Proofview.V82.tactic simpl_in_concl;
+	    Proofview.V82.tactic (unfold sp_not);
 	    (intros_using [aux]);
-	    (resolve_id aux);
+	    Proofview.V82.tactic (resolve_id aux);
 	    reflexivity
           ]
-      | _ -> tclIDTAC
+      | _ -> Proofview.tclUNIT ()
   in
   loop
 
@@ -1382,21 +1367,21 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
       (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
       (tclTRY (clear [id]))
   in
-  if tac <> [] then
+  if not (List.is_empty tac) then
     let id' = new_identifier () in
-    ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
+    ((id',(Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (shift_left); Proofview.V82.tactic (mk_then tac); (intros_using [id']) ]))
           :: tactic,
      compile id' flag t' :: defs)
   else
     (tactic,defs)
 
 let destructure_omega gl tac_def (id,c) =
-  if atompart_of_id id = "State" then
+  if String.equal (atompart_of_id id) "State" then
     tac_def
   else
     try match destructurate_prop c with
       | Kapp(Eq,[typ;t1;t2])
-	when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
+	when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end ->
 	  let t = mk_plus t1 (mk_inv t2) in
 	  normalize_equation
 	    id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
@@ -1425,12 +1410,18 @@ let destructure_omega gl tac_def (id,c) =
 
 let reintroduce id =
   (* [id] cannot be cleared if dependent: protect it by a try *)
-  tclTHEN (tclTRY (clear [id])) (intro_using id)
+  Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) (intro_using id)
+
 
-let coq_omega gl =
+open Proofview.Notations
+
+let coq_omega =
+  Proofview.Goal.nf_enter begin fun gl ->
   clear_constr_tables ();
+  let hyps_types = Tacmach.New.pf_hyps_types gl in
+  let destructure_omega = Tacmach.New.of_old destructure_omega gl in
   let tactic_normalisation, system =
-    List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
+    List.fold_left destructure_omega ([],[]) hyps_types in
   let prelude,sys =
     List.fold_left
       (fun (tac,sys) (t,(v,th,b)) ->
@@ -1438,78 +1429,81 @@ let coq_omega gl =
            let id = new_identifier () in
            let i = new_id () in
            tag_hypothesis id i;
-           (tclTHENLIST [
+           (Tacticals.New.tclTHENLIST [
 	     (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
 	     (intros_using [v; id]);
 	     (elim_id id);
-	     (clear [id]);
+	     Proofview.V82.tactic (clear [id]);
 	     (intros_using [th;id]);
 	     tac ]),
            {kind = INEQ;
 	    body = [{v=intern_id v; c=one}];
             constant = zero; id = i} :: sys
 	 else
-           (tclTHENLIST [
+           (Tacticals.New.tclTHENLIST [
 	     (simplest_elim (applist (Lazy.force coq_new_var, [t])));
 	     (intros_using [v;th]);
 	     tac ]),
            sys)
-      (tclIDTAC,[]) (dump_tables ())
+      (Proofview.tclUNIT (),[]) (dump_tables ())
   in
   let system = system @ sys in
   if !display_system_flag then display_system display_var system;
   if !old_style_flag then begin
     try
       let _ = simplify (new_id,new_var_num,display_var) false system in
-      tclIDTAC gl
+      Proofview.tclUNIT ()
     with UNSOLVABLE ->
       let _,path = depend [] [] (history ()) in
       if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+      (Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path))
   end else begin
     try
       let path = simplify_strong (new_id,new_var_num,display_var) system in
       if !display_action_flag then display_action display_var path;
-      (tclTHEN prelude (replay_history tactic_normalisation path)) gl
-    with NO_CONTRADICTION -> error "Omega can't solve this system"
+      Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)
+    with NO_CONTRADICTION -> Proofview.tclZERO (UserError ("" , Pp.str"Omega can't solve this system"))
+  end
   end
 
-let coq_omega = solver_time coq_omega
+let coq_omega = coq_omega
 
-let nat_inject gl =
-  let rec explore p t =
+let nat_inject =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in
+  let rec explore p t : unit Proofview.tactic =
     try match destructurate_term t with
       | Kapp(Plus,[t1;t2]) ->
-          tclTHENLIST [
-	    (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
+          Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
               ((Lazy.force coq_inj_plus),[t1;t2]));
 	    (explore (P_APP 1 :: p) t1);
 	    (explore (P_APP 2 :: p) t2)
           ]
       | Kapp(Mult,[t1;t2]) ->
-          tclTHENLIST [
-	    (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
+          Tacticals.New.tclTHENLIST [
+	    Proofview.V82.tactic (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
               ((Lazy.force coq_inj_mult),[t1;t2]));
 	    (explore (P_APP 1 :: p) t1);
 	    (explore (P_APP 2 :: p) t2)
           ]
       | Kapp(Minus,[t1;t2]) ->
           let id = new_identifier () in
-          tclTHENS
-            (tclTHEN
+          Tacticals.New.tclTHENS
+            (Tacticals.New.tclTHEN
 	       (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1])))
 	       (intros_using [id]))
 	    [
-	      tclTHENLIST [
-	        (clever_rewrite_gen p
+	      Tacticals.New.tclTHENLIST [
+	        Proofview.V82.tactic (clever_rewrite_gen p
 		  (mk_minus (mk_inj t1) (mk_inj t2))
                   ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
 		(loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
 		(explore (P_APP 1 :: p) t1);
 		(explore (P_APP 2 :: p) t2) ];
-	      (tclTHEN
-		 (clever_rewrite_gen p (mk_integer zero)
-                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
+	      (Tacticals.New.tclTHEN
+		 (Proofview.V82.tactic (clever_rewrite_gen p (mk_integer zero)
+                    ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])))
 		 (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
 	    ]
       | Kapp(S,[t']) ->
@@ -1520,37 +1514,37 @@ let nat_inject gl =
               | _ -> false
             with e when catchable_exception e -> false
 	  in
-          let rec loop p t =
+          let rec loop p t : unit Proofview.tactic =
             try match destructurate_term t with
 		Kapp(S,[t]) ->
-                  (tclTHEN
-                     (clever_rewrite_gen p
+                  (Tacticals.New.tclTHEN
+                     (Proofview.V82.tactic (clever_rewrite_gen p
 			(mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
-			((Lazy.force coq_inj_S),[t]))
+			((Lazy.force coq_inj_S),[t])))
 		     (loop (P_APP 1 :: p) t))
               | _ -> explore p t
             with e when catchable_exception e -> explore p t
 	  in
-          if is_number t' then focused_simpl p else loop p t
+          if is_number t' then Proofview.V82.tactic (focused_simpl p) else loop p t
       | Kapp(Pred,[t]) ->
           let t_minus_one =
 	    mkApp (Lazy.force coq_minus, [| t;
 		      mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
-          tclTHEN
-            (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
-               ((Lazy.force coq_pred_of_minus),[t]))
+          Tacticals.New.tclTHEN
+            (Proofview.V82.tactic (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
+               ((Lazy.force coq_pred_of_minus),[t])))
             (explore p t_minus_one)
-      | Kapp(O,[]) -> focused_simpl p
-      | _ -> tclIDTAC
-    with e when catchable_exception e -> tclIDTAC
+      | Kapp(O,[]) -> Proofview.V82.tactic (focused_simpl p)
+      | _ -> Proofview.tclUNIT ()
+    with e when catchable_exception e -> Proofview.tclUNIT ()
 
   and loop = function
-    | [] -> tclIDTAC
+    | [] -> Proofview.tclUNIT ()
     | (i,t)::lit ->
 	  begin try match destructurate_prop t with
               Kapp(Le,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1558,8 +1552,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Lt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1567,8 +1561,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Ge,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1576,8 +1570,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Gt,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
                     [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1585,8 +1579,8 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Neq,[t1;t2]) ->
-		tclTHENLIST [
-		  (generalize_tac
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac
 		    [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
 		  (explore [P_APP 1; P_TYPE] t1);
 		  (explore [P_APP 2; P_TYPE] t2);
@@ -1594,9 +1588,9 @@ let nat_inject gl =
 		  (loop lit)
                 ]
             | Kapp(Eq,[typ;t1;t2]) ->
-		if pf_conv_x gl typ (Lazy.force coq_nat) then
-                  tclTHENLIST [
-		    (generalize_tac
+		if is_conv typ (Lazy.force coq_nat) then
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
 		      [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
 		    (explore [P_APP 2; P_TYPE] t1);
 		    (explore [P_APP 3; P_TYPE] t2);
@@ -1607,7 +1601,9 @@ let nat_inject gl =
 	    | _ -> loop lit
 	  with e when catchable_exception e -> loop lit end
   in
-  loop (List.rev (pf_hyps_types gl)) gl
+  let hyps_types = Tacmach.New.pf_hyps_types gl in
+  loop (List.rev hyps_types)
+  end
 
 let dec_binop = function
   | Zne -> coq_dec_Zne
@@ -1675,51 +1671,57 @@ let rec decidability gl t =
 let onClearedName id tac =
   (* We cannot ensure that hyps can be cleared (because of dependencies), *)
   (* so renaming may be necessary *)
-  tclTHEN
-    (tclTRY (clear [id]))
-    (fun gl ->
-      let id = fresh_id [] id gl in
-      tclTHEN (introduction id) (tac id) gl)
+  Tacticals.New.tclTHEN
+    (Proofview.V82.tactic (tclTRY (clear [id])))
+    (Proofview.Goal.nf_enter begin fun gl ->
+     let id = Tacmach.New.of_old (fresh_id [] id) gl in
+     Tacticals.New.tclTHEN (introduction id) (tac id)
+    end)
 
 let onClearedName2 id tac =
-  tclTHEN
-    (tclTRY (clear [id]))
-    (fun gl ->
-      let id1 = fresh_id [] (add_suffix id "_left") gl in
-      let id2 = fresh_id [] (add_suffix id "_right") gl in
-      tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] gl)
-
-let destructure_hyps gl =
-  let rec loop = function
-    | [] -> (tclTHEN nat_inject coq_omega)
-    | (i,body,t)::lit ->
-	begin try match destructurate_prop t with
+  Tacticals.New.tclTHEN
+    (Proofview.V82.tactic (tclTRY (clear [id])))
+    (Proofview.Goal.nf_enter begin fun gl ->
+     let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in
+     let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in
+      Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ]
+    end)
+
+let destructure_hyps =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of = Tacmach.New.pf_type_of gl in
+  let decidability = Tacmach.New.of_old decidability gl in
+  let pf_nf = Tacmach.New.of_old pf_nf gl in
+    let rec loop = function
+      | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega)
+      | (i,body,t)::lit ->
+	  begin try match destructurate_prop t with
 	  | Kapp(False,[]) -> elim_id i
           | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
           | Kapp(Or,[t1;t2]) ->
-              (tclTHENS
-                (elim_id i)
-                [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
-                  onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+              (Tacticals.New.tclTHENS
+                 (elim_id i)
+                 [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
+                   onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
           | Kapp(And,[t1;t2]) ->
-              tclTHEN
+              Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
 		  loop ((i1,None,t1)::(i2,None,t2)::lit)))
           | Kapp(Iff,[t1;t2]) ->
-	      tclTHEN
+	      Tacticals.New.tclTHEN
 		(elim_id i)
 		(onClearedName2 i (fun i1 i2 ->
 		  loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit)))
           | Kimp(t1,t2) ->
 	      (* t1 and t2 might be in Type rather than Prop.
 		 For t1, the decidability check will ensure being Prop. *)
-              if is_Prop (pf_type_of gl t2)
+              if is_Prop (type_of t2)
               then
-		let d1 = decidability gl t1 in
-		tclTHENLIST [
-		  (generalize_tac [mkApp (Lazy.force coq_imp_simp,
-                    [| t1; t2; d1; mkVar i|])]);
+		let d1 = decidability t1 in
+		Tacticals.New.tclTHENLIST [
+		  Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+                                                               [| t1; t2; d1; mkVar i|])]);
 		  (onClearedName i (fun i ->
 		    (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
                 ]
@@ -1727,135 +1729,138 @@ let destructure_hyps gl =
 		loop lit
           | Kapp(Not,[t]) ->
               begin match destructurate_prop t with
-		  Kapp(Or,[t1;t2]) ->
-                    tclTHENLIST [
-		      (generalize_tac
-                        [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
-                    ]
-		| Kapp(And,[t1;t2]) ->
-		    let d1 = decidability gl t1 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_and,
-				[| t1; t2; d1; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
-                    ]
-		| Kapp(Iff,[t1;t2]) ->
-		    let d1 = decidability gl t1 in
-		    let d2 = decidability gl t2 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_iff,
-				[| t1; t2; d1; d2; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,
-			        mk_or (mk_and t1 (mk_not t2))
-				      (mk_and (mk_not t1) t2))::lit))))
-                    ]
-		| Kimp(t1,t2) ->
+		Kapp(Or,[t1;t2]) ->
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+                                            [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
+                  ]
+	      | Kapp(And,[t1;t2]) ->
+		  let d1 = decidability t1 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_and,
+				                    [| t1; t2; d1; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
+                  ]
+	      | Kapp(Iff,[t1;t2]) ->
+		  let d1 = decidability t1 in
+		  let d2 = decidability t2 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_iff,
+				                    [| t1; t2; d1; d2; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,
+			      mk_or (mk_and t1 (mk_not t2))
+				(mk_and (mk_not t1) t2))::lit))))
+                  ]
+	      | Kimp(t1,t2) ->
 		    (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok.
 		       For t1, being decidable implies being Prop. *)
-		    let d1 = decidability gl t1 in
-                    tclTHENLIST [
-		      (generalize_tac
-		        [mkApp (Lazy.force coq_not_imp,
-				[| t1; t2; d1; mkVar i |])]);
-		      (onClearedName i (fun i ->
-                        (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
-                    ]
-		| Kapp(Not,[t]) ->
-		    let d = decidability gl t in
-                    tclTHENLIST [
-		      (generalize_tac
-			[mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
-		      (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
-                    ]
-		| Kapp(op,[t1;t2]) ->
-		    (try
-		      let thm = not_binop op in
-                      tclTHENLIST [
-			(generalize_tac
-			   [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
-			(onClearedName i (fun _ -> loop lit))
-                      ]
-		     with Not_found -> loop lit)
-		| Kapp(Eq,[typ;t1;t2]) ->
-                    if !old_style_flag then begin
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) ->
-                            tclTHENLIST [
-			      (simplest_elim
-				(mkApp
-                                  (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| Kapp(Z,_) ->
-                            tclTHENLIST [
-			      (simplest_elim
-				(mkApp
-				  (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
-			      (onClearedName i (fun _ -> loop lit))
-                            ]
-			| _ -> loop lit
-                    end else begin
-		      match destructurate_type (pf_nf gl typ) with
-			| Kapp(Nat,_) ->
-                               (tclTHEN
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
-			       (loop lit))
-			| Kapp(Z,_) ->
-                               (tclTHEN
-			       (convert_hyp_no_check
-                                  (i,body,
-				  (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
-			       (loop lit))
-			| _ -> loop lit
-                    end
-		| _ -> loop lit
+		  let d1 = decidability t1 in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+		                            [mkApp (Lazy.force coq_not_imp,
+				                    [| t1; t2; d1; mkVar i |])]);
+		    (onClearedName i (fun i ->
+                      (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
+                  ]
+	      | Kapp(Not,[t]) ->
+		  let d = decidability t in
+                  Tacticals.New.tclTHENLIST [
+		    Proofview.V82.tactic (generalize_tac
+			                    [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
+		    (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+                  ]
+	      | Kapp(op,[t1;t2]) ->
+		  (try
+		     let thm = not_binop op in
+                     Tacticals.New.tclTHENLIST [
+		       Proofview.V82.tactic (generalize_tac
+			                       [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
+		       (onClearedName i (fun _ -> loop lit))
+                     ]
+		   with Not_found -> loop lit)
+	      | Kapp(Eq,[typ;t1;t2]) ->
+                  if !old_style_flag then begin
+		    match destructurate_type (pf_nf typ) with
+		    | Kapp(Nat,_) ->
+                        Tacticals.New.tclTHENLIST [
+			  (simplest_elim
+			     (mkApp
+                                (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
+			  (onClearedName i (fun _ -> loop lit))
+                        ]
+		    | Kapp(Z,_) ->
+                        Tacticals.New.tclTHENLIST [
+			  (simplest_elim
+			     (mkApp
+				(Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
+			  (onClearedName i (fun _ -> loop lit))
+                        ]
+		    | _ -> loop lit
+                  end else begin
+		    match destructurate_type (pf_nf typ) with
+		    | Kapp(Nat,_) ->
+                        (Tacticals.New.tclTHEN
+			   (convert_hyp_no_check
+                                                    (i,body,
+				                     (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
+			   (loop lit))
+		    | Kapp(Z,_) ->
+                        (Tacticals.New.tclTHEN
+			   (convert_hyp_no_check
+                                                    (i,body,
+				                     (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+			   (loop lit))
+		    | _ -> loop lit
+                  end
+	      | _ -> loop lit
               end
           | _ -> loop lit
-	with
-	  | Undecidable -> loop lit
-	  | e when catchable_exception e -> loop lit
-	end
-  in
-  loop (pf_hyps gl) gl
+	    with
+	    | Undecidable -> loop lit
+	    | e when catchable_exception e -> loop lit
+	  end
+    in
+    let hyps = Proofview.Goal.hyps gl in
+    loop hyps
+  end
 
-let destructure_goal gl =
-  let concl = pf_concl gl in
-  let rec loop t =
-    match destructurate_prop t with
+let destructure_goal =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let decidability = Tacmach.New.of_old decidability gl in
+    let rec loop t =
+      match destructurate_prop t with
       | Kapp(Not,[t]) ->
-          (tclTHEN
-	     (tclTHEN (unfold sp_not) intro)
+          (Tacticals.New.tclTHEN
+	     (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro)
 	     destructure_hyps)
-      | Kimp(a,b) -> (tclTHEN intro (loop b))
+      | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b))
       | Kapp(False,[]) -> destructure_hyps
       | _ ->
-	let goal_tac =
-	  try
-	    let dec = decidability gl t in
-	    tclTHEN
-	      (Tactics.refine
-		 (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))
-	      intro
-	  with Undecidable -> Tactics.elim_type (build_coq_False ())
-	in
-	tclTHEN goal_tac destructure_hyps
-  in
-  (loop concl) gl
+	  let goal_tac =
+	    try
+	      let dec = decidability t in
+	      Tacticals.New.tclTHEN
+                (Proofview.V82.tactic (Tactics.refine
+		                         (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))
+	        intro
+	    with Undecidable -> Tactics.elim_type (build_coq_False ())
+	  in
+	  Tacticals.New.tclTHEN goal_tac destructure_hyps
+    in
+    (loop concl)
+  end
 
-let destructure_goal = all_time (destructure_goal)
+let destructure_goal = destructure_goal
 
-let omega_solver gl =
+let omega_solver =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [check_required_library] *)
   Coqlib.check_required_library ["Coq";"omega";"Omega"];
   reset_all ();
-  let result = destructure_goal gl in
-  (* if !display_time_flag then begin text_time ();
-     flush Pervasives.stdout end; *)
-  result
+  destructure_goal
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index b2a5b5dc..46bbe2fd 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -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        *)
@@ -9,14 +9,15 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (**************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "omega_plugin"
 
 open Coq_omega
-open Refiner
 
 let omega_tactic l =
   let tacs = List.map
@@ -25,12 +26,12 @@ let omega_tactic l =
        | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
        | "N" -> Tacinterp.interp <:tactic<zify_N>>
        | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Util.error ("No Omega knowledge base for type "^s))
-    (Util.list_uniquize (List.sort compare l))
+       | s -> Errors.error ("No Omega knowledge base for type "^s))
+    (Util.List.sort_uniquize String.compare l)
   in
-  tclTHEN
-    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
-    omega_solver
+  Tacticals.New.tclTHEN
+    (Tacticals.New.tclREPEAT (Tacticals.New.tclTHENLIST tacs))
+    (omega_solver)
 
 
 TACTIC EXTEND omega
@@ -39,7 +40,7 @@ END
 
 TACTIC EXTEND omega'
 | [ "omega" "with" ne_ident_list(l) ] ->
-    [ omega_tactic (List.map Names.string_of_id l) ]
+    [ omega_tactic (List.map Names.Id.to_string l) ]
 | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ]
 END
 
diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml
index 94ce4d50..67a1ff96 100644
--- a/plugins/omega/omega.ml
+++ b/plugins/omega/omega.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        *)
@@ -9,7 +9,7 @@
 (*                                                                        *)
 (* Omega: a solver of quantifier-free problems in Presburger Arithmetic   *)
 (*                                                                        *)
-(* Pierre Crégut (CNET, Lannion, France)                                  *)
+(* Pierre Crégut (CNET, Lannion, France)                                  *)
 (*                                                                        *)
 (* 13/10/2002 : modified to cope with an external numbering of equations  *)
 (*   and hypothesis. Its use for Omega is not more complex and it makes   *)
@@ -17,10 +17,9 @@
 (*   the number of source of numbering.                                   *)
 (**************************************************************************)
 
-open Names
-
 module type INT = sig
   type bigint
+  val equal : bigint -> bigint -> bool
   val less_than : bigint -> bigint -> bool
   val add : bigint -> bigint -> bigint
   val sub : bigint -> bigint -> bigint
@@ -34,26 +33,26 @@ end
 
 let debug = ref false
 
-module MakeOmegaSolver (Int:INT) = struct
-
-type bigint = Int.bigint
-let (<?) = Int.less_than
-let (<=?) x y = Int.less_than x y or x = y
-let (>?) x y = Int.less_than y x
-let (>=?) x y = Int.less_than y x or x = y
-let (=?) = (=)
-let (+) = Int.add
-let (-) = Int.sub
-let ( * ) = Int.mult
-let (/) x y = fst (Int.euclid x y)
-let (mod) x y = snd (Int.euclid x y)
-let zero = Int.zero
-let one = Int.one
+module MakeOmegaSolver (I:INT) = struct
+
+type bigint = I.bigint
+let (=?) = I.equal
+let (<?) = I.less_than
+let (<=?) x y = I.less_than x y || x = y
+let (>?) x y = I.less_than y x
+let (>=?) x y = I.less_than y x || x = y
+let (+) = I.add
+let (-) = I.sub
+let ( * ) = I.mult
+let (/) x y = fst (I.euclid x y)
+let (mod) x y = snd (I.euclid x y)
+let zero = I.zero
+let one = I.one
 let two = one + one
-let negone = Int.neg one
-let abs x = if Int.less_than x zero then Int.neg x else x
-let string_of_bigint = Int.to_string
-let neg = Int.neg
+let negone = I.neg one
+let abs x = if I.less_than x zero then I.neg x else x
+let string_of_bigint = I.to_string
+let neg = I.neg
 
 (* To ensure that polymorphic (<) is not used mistakenly on big integers *)
 (* Warning: do not use (=) either on big int *)
@@ -241,7 +240,7 @@ let add_event, history, clear_history =
   (fun () -> !accu),
   (fun () -> accu := [])
 
-let nf_linear = Sort.list (fun x y -> x.v > y.v)
+let nf_linear = List.sort (fun x y -> Pervasives.(-) y.v x.v)
 
 let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
 
@@ -303,16 +302,16 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
           end
   end else
     let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
-    if eq_flag=EQUA & x mod gcd <> zero then begin
+    if eq_flag=EQUA && x mod gcd <> zero then begin
       add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
-    end else if eq_flag=DISE & x mod gcd <> zero then begin
+    end else if eq_flag=DISE && x mod gcd <> zero then begin
       add_event (FORGET_C eq.id); []
     end else if gcd <> one then begin
       let c = floor_div x gcd in
       let d = x - c * gcd in
       let new_eq = {id=id; kind=eq_flag; constant=c;
                     body=map_eq_linear (fun c -> c / gcd) e} in
-      add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
+      add_event (if eq_flag=EQUA || eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
                  else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
       [new_eq]
     end else [eq]
@@ -352,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
   let new_eq = List.hd (normalize new_eq) in
   let eliminated_var, def = chop_var var new_eq.body in
   let other_equations =
-    Util.list_map_append
+    Util.List.map_append
       (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
   let inequations =
-    Util.list_map_append
+    Util.List.map_append
       (fun e ->
         normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
   let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
@@ -368,9 +367,9 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,
   if !debug then display_system print_var (e::other);
   try
     let v,def = chop_factor_1 e.body in
-    (Util.list_map_append
+    (Util.List.map_append
       (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
-     Util.list_map_append
+     Util.List.map_append
        (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
   with FACTOR1 ->
     eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
@@ -474,7 +473,7 @@ let select_variable system =
   Hashtbl.iter
     (fun v ({contents =  c}) ->
        incr var_cpt;
-       if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
+       if c <? !cmin || !vmin = (-1) then begin vmin := v; cmin := c end)
     table;
   if !var_cpt < 1 then raise SOLVED_SYSTEM;
   !vmin
@@ -523,7 +522,7 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
     failwith "disequation in simplify";
   clear_history ();
   List.iter (fun e -> add_event (HYP e)) system;
-  let system = Util.list_map_append normalize system in
+  let system = Util.List.map_append normalize system in
   let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
   let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
   let system = (eqs @ simp_eq,simp_ineq) in
@@ -547,30 +546,30 @@ let rec depend relie_on accu = function
   | act :: l ->
       begin match act with
 	| DIVIDE_AND_APPROX (e,_,_,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| EXACT_DIVIDE (e,_) ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| WEAKEN (e,_) ->
-            if List.mem e relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| SUM (e,(_,e1),(_,e2)) ->
-            if List.mem e relie_on then
+            if Int.List.mem e relie_on then
 	      depend (e1.id::e2.id::relie_on) (act::accu) l
             else
 	      depend relie_on accu l
 	| STATE {st_new_eq=e;st_orig=o} ->
-            if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
+            if Int.List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
             else depend relie_on accu l
 	| HYP e ->
-            if List.mem e.id relie_on then depend relie_on (act::accu) l
+            if Int.List.mem e.id relie_on then depend relie_on (act::accu) l
             else depend relie_on accu l
 	| FORGET_C _ -> depend relie_on accu l
 	| FORGET _ -> depend relie_on accu l
 	| FORGET_I _ -> depend relie_on accu l
 	| MERGE_EQ (e,e1,e2) ->
-            if List.mem e relie_on then
+            if Int.List.mem e relie_on then
 	      depend (e1.id::e2::relie_on) (act::accu) l
             else
 	      depend relie_on accu l
@@ -586,15 +585,6 @@ let rec depend relie_on accu = function
       end
   | [] -> relie_on, accu
 
-(*
-let depend relie_on accu trace =
-  Printf.printf "Longueur de la trace initiale : %d\n"
-    (trace_length trace + trace_length accu);
-  let rel',trace' = depend relie_on accu trace in
-  Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
-  rel',trace'
-*)
-
 let solve (new_eq_id,new_eq_var,print_var) system =
   try let _ = simplify new_eq_id false system in failwith "no contradiction"
   with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
@@ -658,7 +648,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
     | ([],ineqs,expl_map) -> ineqs,expl_map
   in
   try
-    let system = Util.list_map_append normalize system in
+    let system = Util.List.map_append normalize system in
     let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
     let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
     let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
@@ -674,7 +664,7 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
            try let _ = loop2 sys in raise NO_CONTRADICTION
            with UNSOLVABLE ->
              let relie_on,path = depend [] [] (history ()) in
-             let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
+             let dc,_ = List.partition (fun (_,id,_) -> Int.List.mem id relie_on) decomp in
              let red = List.map (fun (x,_,_) -> x) dc in
              (red,relie_on,decomp,path))
         sys_exploded
@@ -699,14 +689,16 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
           | [] -> failwith "solve" in
         let s1,s2 =
           List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
-        let s1' =
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
-        let s2' =
-	  List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
+        let remove_int (dep,ro,dc,pa) =
+          (Util.List.except Int.equal id dep,ro,dc,pa)
+        in
+        let s1' = List.map remove_int s1 in
+        let s2' = List.map remove_int s2 in
         let (r1,relie1) = solve s1'
 	and (r2,relie2) = solve s2' in
-	let (eq,id1,id2) = List.assoc id explode_map in
-	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
+	let (eq,id1,id2) = Int.List.assoc id explode_map in
+	[SPLIT_INEQ(eq,(id1,r1),(id2, r2))],
+        eq.id :: Util.List.union Int.equal relie1 relie2
       with FULL_SOLUTION (x0,x1) -> (x0,x1)
     in
     let act,relie_on = solve all_solutions in
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
index 787995ed..d8752f8b 100644
--- a/plugins/pluginsbyte.itarget
+++ b/plugins/pluginsbyte.itarget
@@ -1,4 +1,4 @@
-field/field_plugin.cma
+btauto/btauto_plugin.cma
 setoid_ring/newring_plugin.cma
 extraction/extraction_plugin.cma
 decl_mode/decl_mode_plugin.cma
@@ -8,9 +8,6 @@ fourier/fourier_plugin.cma
 romega/romega_plugin.cma
 omega/omega_plugin.cma
 micromega/micromega_plugin.cma
-xml/xml_plugin.cma
-subtac/subtac_plugin.cma
-ring/ring_plugin.cma
 cc/cc_plugin.cma
 nsatz/nsatz_plugin.cma
 funind/recdef_plugin.cma
@@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cma
 syntax/string_syntax_plugin.cma
 syntax/z_syntax_plugin.cma
 quote/quote_plugin.cma
+derive/derive_plugin.cma
\ No newline at end of file
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
index bd3cec01..220e5182 100644
--- a/plugins/pluginsdyn.itarget
+++ b/plugins/pluginsdyn.itarget
@@ -1,3 +1,4 @@
+btauto/btauto_plugin.cmxs
 field/field_plugin.cmxs
 setoid_ring/newring_plugin.cmxs
 extraction/extraction_plugin.cmxs
@@ -8,7 +9,6 @@ fourier/fourier_plugin.cmxs
 romega/romega_plugin.cmxs
 omega/omega_plugin.cmxs
 micromega/micromega_plugin.cmxs
-xml/xml_plugin.cmxs
 subtac/subtac_plugin.cmxs
 ring/ring_plugin.cmxs
 cc/cc_plugin.cmxs
@@ -21,3 +21,4 @@ syntax/r_syntax_plugin.cmxs
 syntax/string_syntax_plugin.cmxs
 syntax/z_syntax_plugin.cmxs
 quote/quote_plugin.cmxs
+derive/derive_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
index 5264ba37..04a1e711 100644
--- a/plugins/pluginsopt.itarget
+++ b/plugins/pluginsopt.itarget
@@ -1,4 +1,4 @@
-field/field_plugin.cmxa
+btauto/btauto_plugin.cmxa
 setoid_ring/newring_plugin.cmxa
 extraction/extraction_plugin.cmxa
 decl_mode/decl_mode_plugin.cmxa
@@ -8,9 +8,6 @@ fourier/fourier_plugin.cmxa
 romega/romega_plugin.cmxa
 omega/omega_plugin.cmxa
 micromega/micromega_plugin.cmxa
-xml/xml_plugin.cmxa
-subtac/subtac_plugin.cmxa
-ring/ring_plugin.cmxa
 cc/cc_plugin.cmxa
 nsatz/nsatz_plugin.cmxa
 funind/recdef_plugin.cmxa
@@ -21,3 +18,4 @@ syntax/r_syntax_plugin.cmxa
 syntax/string_syntax_plugin.cmxa
 syntax/z_syntax_plugin.cmxa
 quote/quote_plugin.cmxa
+derive/derive_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
index bab15ad0..a59bf29c 100644
--- a/plugins/pluginsvo.itarget
+++ b/plugins/pluginsvo.itarget
@@ -1,12 +1,12 @@
-field/vo.otarget
+btauto/vo.otarget
 fourier/vo.otarget
 funind/vo.otarget
 nsatz/vo.otarget
 micromega/vo.otarget
 omega/vo.otarget
 quote/vo.otarget
-ring/vo.otarget
 romega/vo.otarget
 rtauto/vo.otarget
 setoid_ring/vo.otarget
 extraction/vo.otarget
+derive/vo.otarget
\ No newline at end of file
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
index 92e5c75c..ca1a18e8 100644
--- a/plugins/quote/Quote.v
+++ b/plugins/quote/Quote.v
@@ -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/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index e2c9dbaa..e27fe7f4 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -1,22 +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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
-open Util
+open Names
+open Misctypes
 open Tacexpr
+open Geninterp
 open Quote
 
-let make_cont k x =
-  let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> k)) in
-  let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
-  let tac = <:tactic<let cont := $k in cont $x>> in
-  Tacinterp.interp tac
+DECLARE PLUGIN "quote_plugin"
+
+let loc = Loc.ghost
+let cont = (loc, Id.of_string "cont")
+let x = (loc, Id.of_string "x")
+
+let make_cont (k : glob_tactic_expr) (c : Constr.t) =
+  let c = Tacinterp.Value.of_constr c in
+  let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in
+  let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in
+  let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in
+  Tacinterp.eval_tactic_ist ist tac
 
 TACTIC EXTEND quote
   [ "quote" ident(f) ] -> [ quote f [] ]
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index 48c67089..637e0e28 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.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        *)
@@ -101,15 +101,14 @@
 
 
 (*i*)
-open Pp
+open Errors
 open Util
 open Names
 open Term
 open Pattern
-open Matching
+open Patternops
+open Constr_matching
 open Tacmach
-open Tactics
-open Tacexpr
 (*i*)
 
 (*s First, we need to access some Coq constants
@@ -190,16 +189,16 @@ let decomp_term c = kind_of_term (strip_outer_cast c)
   type [typ] *)
 
 let coerce_meta_out id =
-  let s = string_of_id id in
+  let s = Id.to_string id in
   int_of_string (String.sub s 1 (String.length s - 1))
 let coerce_meta_in n =
-  id_of_string ("M" ^ string_of_int n)
+  Id.of_string ("M" ^ string_of_int n)
 
 let compute_lhs typ i nargsi =
   match kind_of_term typ with
-    | Ind(sp,0) ->
+    | Ind((sp,0),u) ->
         let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
-        mkApp (mkConstruct ((sp,0),i+1), argsi)
+        mkApp (mkConstructU (((sp,0),i+1),u), argsi)
     | _ -> i_can't_do_that ()
 
 (*s This function builds the pattern from the RHS. Recursive calls are
@@ -208,29 +207,29 @@ let compute_lhs typ i nargsi =
 let compute_rhs bodyi index_of_f =
   let rec aux c =
     match kind_of_term c with
-      | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) ->
-          let i = destRel (array_last args) in
+      | App (j, args) when isRel j && Int.equal (destRel j) index_of_f (* recursive call *) ->
+          let i = destRel (Array.last args) in
 	  PMeta (Some (coerce_meta_in i))
       | App (f,args) ->
-          PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args)
+          PApp (snd (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args)
       | Cast (c,_,_) -> aux c
-      | _ -> snd (pattern_of_constr Evd.empty c)
+      | _ -> snd (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c)
   in
   aux bodyi
 
 (*s Now the function [compute_ivs] itself *)
 
-let compute_ivs gl f cs =
-  let cst =
-    try destConst f
-    with e when Errors.noncritical e -> i_can't_do_that ()
-  in
-  let body = Environ.constant_value (Global.env()) cst in
+let compute_ivs f cs gl =
+  let cst = try destConst f with DestKO -> i_can't_do_that () in
+  let body = Environ.constant_value_in (Global.env()) cst in
   match decomp_term body with
     | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
         let (args3, body3) = decompose_lam body2 in
         let nargs3 = List.length args3 in
-        begin match decomp_term body3 with
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let is_conv = Reductionops.is_conv env sigma in
+          begin match decomp_term body3 with
           | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
               let n_lhs_rhs = ref []
               and v_lhs = ref (None : constr option)
@@ -243,14 +242,13 @@ let compute_ivs gl f cs =
            (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
            (* REL 1 to REL nargsi are argsi (reverse order) *)
            (* First we test if the RHS is the RHS for constants *)
-                   if isRel bodyi && destRel bodyi = 1 then
+                   if isRel bodyi && Int.equal (destRel bodyi) 1 then
                      c_lhs := Some (compute_lhs (snd (List.hd args3))
                                       i nargsi)
            (* Then we test if the RHS is the RHS for variables *)
                    else begin match decompose_app bodyi with
                      | vmf, [_; _; a3; a4 ]
-                         when isRel a3 & isRel a4 &
-			   pf_conv_x gl vmf
+                         when isRel a3 && isRel a4 && is_conv vmf
                            (Lazy.force coq_varmap_find)->
                              v_lhs := Some (compute_lhs
                                               (snd (List.hd args3))
@@ -264,7 +262,7 @@ let compute_ivs gl f cs =
                    end)
                 lci;
 
-              if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
+              if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that ();
 
 	      (* The Cases predicate is a lambda; we assume no dependency *)
 	      let p = match kind_of_term p with
@@ -299,10 +297,10 @@ binary search trees (see file \texttt{Quote.v}) *)
    and variables (open terms) *)
 
 let rec closed_under cset t =
-  (ConstrSet.mem t cset) or
+  (ConstrSet.mem t cset) ||
   (match (kind_of_term t) with
      | Cast(c,_,_) -> closed_under cset c
-     | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
+     | App(f,l) -> closed_under cset f && Array.for_all (closed_under cset) l
      | _ -> false)
 
 (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
@@ -342,8 +340,8 @@ let path_of_int n =
   (* returns the list of digits of n in reverse order with
      initial 1 removed *)
   let rec digits_of_int n =
-    if n=1 then []
-    else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+    if Int.equal n 1 then []
+    else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1))
   in
   List.fold_right
     (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx
@@ -361,9 +359,9 @@ let path_of_int n =
 (* This function does not descend under binders (lambda and Cases) *)
 
 let rec subterm gl (t : constr) (t' : constr) =
-  (pf_conv_x gl t t') or
+  (pf_conv_x gl t t') ||
   (match (kind_of_term t) with
-     | App (f,args) -> array_exists (fun t -> subterm gl t t') args
+     | App (f,args) -> Array.exists (fun t -> subterm gl t t') args
      | Cast(t,_,_) -> (subterm gl t t')
      | _ -> false)
 
@@ -393,7 +391,7 @@ module Constrhash = Hashtbl.Make
   [ivs : inversion_scheme]\\
   [lc: constr list]\\
   [gl: goal sigma]\\ *)
-let quote_terms ivs lc gl =
+let quote_terms ivs lc =
   Coqlib.check_required_library ["Coq";"quote";"Quote"];
   let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
   let varlist = ref ([] : constr list) in (* list of variables *)
@@ -403,7 +401,7 @@ let quote_terms ivs lc gl =
       match l with
         | (lhs, rhs)::tail ->
             begin try
-              let s1 = matches rhs c in
+              let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs c) in
               let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
 	      in
               Termops.subst_meta s2 lhs
@@ -414,7 +412,7 @@ let quote_terms ivs lc gl =
                | None ->
                    begin match ivs.constant_lhs with
                      | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
-                     | None -> anomaly "invalid inversion scheme for quote"
+                     | None -> anomaly (Pp.str "invalid inversion scheme for quote")
                    end
                | Some var_lhs ->
                    begin match ivs.constant_lhs with
@@ -440,36 +438,43 @@ let quote_terms ivs lc gl =
     auxl ivs.normal_lhs_rhs
   in
   let lp = List.map aux lc in
-  (lp, (btree_of_array (Array.of_list (List.rev !varlist))
-          ivs.return_type ))
+    (lp, (btree_of_array (Array.of_list (List.rev !varlist))
+            ivs.return_type ))
 
 (*s actually we could "quote" a list of terms instead of a single
   term. Ring for example needs that, but Ring doesn't use Quote
   yet. *)
 
-let quote f lid gl =
-  let f = pf_global gl f in
-  let cl = List.map (pf_global gl) lid in
-  let ivs = compute_ivs gl f cl in
-  let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with
-    | [p], vm -> (p,vm)
-    | _ -> assert false
-  in
-  match ivs.variable_lhs with
-    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
-    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
-
-let gen_quote cont c f lid gl =
-  let f = pf_global gl f in
-  let cl = List.map (pf_global gl) lid in
-  let ivs = compute_ivs gl f cl in
-  let (p, vm) = match quote_terms ivs [c] gl with
+let quote f lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let f = Tacmach.New.pf_global f gl in
+    let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
+    let ivs = compute_ivs f cl gl in
+    let concl = Proofview.Goal.concl gl in
+    let quoted_terms = quote_terms ivs [concl] in
+    let (p, vm) = match quoted_terms with
+      | [p], vm -> (p,vm)
+      | _ -> assert false
+    in
+    match ivs.variable_lhs with
+    | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
+    | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
+  end
+
+let gen_quote cont c f lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let f = Tacmach.New.pf_global f gl in
+  let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
+  let ivs = compute_ivs f cl gl in
+  let quoted_terms = quote_terms ivs [c] in
+  let (p, vm) = match quoted_terms with
     | [p], vm -> (p,vm)
     | _ -> assert false
   in
   match ivs.variable_lhs with
-    | None -> cont (mkApp (f, [| p |])) gl
-    | Some _ -> cont (mkApp (f, [| vm; p |])) gl
+    | None -> cont (mkApp (f, [| p |]))
+    | Some _ -> cont (mkApp (f, [| vm; p |]))
+  end
 
 (*i
 
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
deleted file mode 100644
index 0d92973e..00000000
--- a/plugins/ring/LegacyArithRing.v
+++ /dev/null
@@ -1,88 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the naturals of Arith $*)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export Arith.
-Require Import Eqdep_dec.
-
-Local Open Scope nat_scope.
-
-Fixpoint nateq (n m:nat) {struct m} : bool :=
-  match n, m with
-  | O, O => true
-  | S n', S m' => nateq n' m'
-  | _, _ => false
-  end.
-
-Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; intros; try contradiction.
-  trivial.
-  unfold Is_true in H1.
-  rewrite (H n1 H1).
-  trivial.
-Qed.
-
-Hint Resolve nateq_prop: arithring.
-
-Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
-  split; intros; auto with arith arithring.
-(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
-  trivial.*)
-Defined.
-
-
-Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
-
-Goal forall n:nat, S n = 1 + n.
-intro; reflexivity.
-Save S_to_plus_one.
-
-(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
-   exp is already O and only for those occurrences than can be reached by going
-   down plus and mult operations  *)
-Ltac rewrite_S_to_plus_term t :=
-  match constr:t with
-  | 1 => constr:1
-  | (S ?X1) =>
-      let t1 := rewrite_S_to_plus_term X1 in
-      constr:(1 + t1)
-  | (?X1 + ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 + t2)
-  | (?X1 * ?X2) =>
-      let t1 := rewrite_S_to_plus_term X1
-      with t2 := rewrite_S_to_plus_term X2 in
-      constr:(t1 * t2)
-  | _ => constr:t
-  end.
-
-(* Apply S_to_plus on both sides of an equality *)
-Ltac rewrite_S_to_plus :=
-  match goal with
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 :=
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2)
-  |  |- (?X1 = ?X2) =>
-      try
-       let t1 :=
-       (**)  (**)
-       rewrite_S_to_plus_term X1
-       with t2 := rewrite_S_to_plus_term X2 in
-       change (t1 = t2)
-  end.
-
-Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
deleted file mode 100644
index b358251a..00000000
--- a/plugins/ring/LegacyNArithRing.v
+++ /dev/null
@@ -1,43 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the binary natural numbers *)
-
-Require Import Bool.
-Require Export LegacyRing.
-Require Export ZArith_base.
-Require Import NArith.
-Require Import Eqdep_dec.
-
-Definition Neq (n m:N) :=
-  match (n ?= m)%N with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
-  intros n m H; unfold Neq in H.
-  apply N.compare_eq.
-  destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq.
-  split.
-    apply N.add_comm.
-    apply N.add_assoc.
-    apply N.mul_comm.
-    apply N.mul_assoc.
-    apply N.add_0_l.
-    apply N.mul_1_l.
-    apply N.mul_0_l.
-    apply N.mul_add_distr_r.
-    apply Neq_prop.
-Qed.
-
-Add Legacy Semi Ring
-  N N.add N.mul 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
deleted file mode 100644
index 31b7cd7c..00000000
--- a/plugins/ring/LegacyRing.v
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-Require Export LegacyRing_theory.
-Require Export Quote.
-Require Export Ring_normalize.
-Require Export Ring_abstract.
-Declare ML Module "ring_plugin".
-
-(* As an example, we provide an instantation for bool. *)
-(* Other instatiations are given in ArithRing and ZArithRing in the
-   same directory *)
-
-Definition BoolTheory :
-  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
-split; simpl.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; destruct m; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; reflexivity.
-destruct n; destruct m; destruct p; reflexivity.
-destruct x; destruct y; reflexivity || simpl; tauto.
-Defined.
-
-Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
- [ true false ].
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
deleted file mode 100644
index 8f07ad26..00000000
--- a/plugins/ring/LegacyRing_theory.v
+++ /dev/null
@@ -1,374 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-
-Set Implicit Arguments.
-
-Section Theory_of_semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-(* There is also a "weakly decidable" equality on A. That means
-  that if (A_eq x y)=true then x=y but x=y can arise when
-  (A_eq x y)=false. On an abstract ring the function [x,y:A]false
-  is a good choice. The proof of A_eq_prop is in this case easy. *)
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-
-Record Semi_Ring_Theory : Prop :=
-  {SR_plus_comm : forall n m:A, n + m = m + n;
-   SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   SR_mult_comm : forall n m:A, n * m = m * n;
-   SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
-   SR_plus_zero_left : forall n:A, 0 + n = n;
-   SR_mult_one_left : forall n:A, 1 * n = n;
-   SR_mult_zero_left : forall n:A, 0 * n = 0;
-   SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-(*   SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
-   SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Semi_Ring_Theory.
-
-Let plus_comm := SR_plus_comm T.
-Let plus_assoc := SR_plus_assoc T.
-Let mult_comm := SR_mult_comm T.
-Let mult_assoc := SR_mult_assoc T.
-Let plus_zero_left := SR_plus_zero_left T.
-Let mult_one_left := SR_mult_one_left T.
-Let mult_zero_left := SR_mult_zero_left T.
-Let distr_left := SR_distr_left T.
-(*Let plus_reg_left := SR_plus_reg_left T.*)
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left (*plus_reg_left*).
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry ; eauto. Qed.
-
-Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry ; eauto. Qed.
-
-Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry ; eauto. Qed.
-
-Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry ; eauto. Qed.
-
-Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve SR_plus_permute SR_mult_permute.
-
-Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry ; apply SR_distr_right. Qed.
-
-Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; rewrite mult_comm; eauto.
-Qed.
-
-Lemma SR_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-Lemma SR_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma SR_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; auto.
-Qed.
-
-Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; auto.
-Qed.
-(*
-Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
-Qed.
-*)
-End Theory_of_semi_rings.
-
-Section Theory_of_rings.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x).
-
-Record Ring_Theory : Prop :=
-  {Th_plus_comm : forall n m:A, n + m = m + n;
-   Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
-   Th_mult_comm : forall n m:A, n * m = m * n;
-   Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
-   Th_plus_zero_left : forall n:A, 0 + n = n;
-   Th_mult_one_left : forall n:A, 1 * n = n;
-   Th_opp_def : forall n:A, n + - n = 0;
-   Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
-   Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
-
-Variable T : Ring_Theory.
-
-Let plus_comm := Th_plus_comm T.
-Let plus_assoc := Th_plus_assoc T.
-Let mult_comm := Th_mult_comm T.
-Let mult_assoc := Th_mult_assoc T.
-Let plus_zero_left := Th_plus_zero_left T.
-Let mult_one_left := Th_mult_one_left T.
-Let opp_def := Th_opp_def T.
-Let distr_left := Th_distr_left T.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
-symmetry ; eauto. Qed.
-
-Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
-symmetry ; eauto. Qed.
-
-Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
-symmetry ; eauto. Qed.
-
-Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
-intros.
-rewrite plus_assoc.
-elim (plus_comm m n).
-rewrite <- plus_assoc.
-reflexivity.
-Qed.
-
-Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
-intros.
-rewrite mult_assoc.
-elim (mult_comm m n).
-rewrite <- mult_assoc.
-reflexivity.
-Qed.
-
-Hint Resolve Th_plus_permute Th_mult_permute.
-
-Lemma aux1 : forall a:A, a + a = a -> a = 0.
-intros.
-generalize (opp_def a).
-pattern a at 1.
-rewrite <- H.
-rewrite <- plus_assoc.
-rewrite opp_def.
-elim plus_comm.
-rewrite plus_zero_left.
-trivial.
-Qed.
-
-Lemma Th_mult_zero_left : forall n:A, 0 * n = 0.
-intros.
-apply aux1.
-rewrite <- distr_left.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-Hint Resolve Th_mult_zero_left.
-
-Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
-symmetry ; eauto. Qed.
-
-Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z.
-intros.
-rewrite <- (plus_zero_left y).
-elim H0.
-elim plus_assoc.
-elim (plus_comm y z).
-rewrite plus_assoc.
-rewrite H.
-rewrite plus_zero_left.
-reflexivity.
-Qed.
-
-Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y.
-intros.
-apply (aux2 (x:=(x * y)));
- [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ].
-Qed.
-Hint Resolve Th_opp_mult_left.
-
-Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right : forall n:A, n + 0 = n.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_plus_zero_right2 : forall n:A, n = n + 0.
-intro; rewrite plus_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right : forall n:A, n * 1 = n.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_mult_one_right2 : forall n:A, n = n * 1.
-intro; elim mult_comm; eauto.
-Qed.
-
-Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y.
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y).
-intros; do 2 rewrite (mult_comm x); auto.
-Qed.
-
-Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y).
-intros.
-apply (aux2 (x:=(x + y)));
- [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc;
-    rewrite opp_def; rewrite plus_zero_left; auto
- | auto ].
-Qed.
-
-Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p).
-eauto. Qed.
-
-Lemma Th_opp_opp : forall n:A, - - n = n.
-intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ].
-Qed.
-Hint Resolve Th_opp_opp.
-
-Lemma Th_opp_opp2 : forall n:A, n = - - n.
-symmetry ; eauto. Qed.
-
-Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y.
-intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto.
-Qed.
-
-Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y.
-symmetry ; apply Th_mult_opp_opp. Qed.
-
-Lemma Th_opp_zero : - 0 = 0.
-rewrite <- (plus_zero_left (- 0)).
-auto. Qed.
-(*
-Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
-intros; generalize (f_equal (fun z => - n + z) H).
-repeat rewrite plus_assoc.
-rewrite (plus_comm (- n) n).
-rewrite opp_def.
-repeat rewrite Th_plus_zero_left; eauto.
-Qed.
-
-Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
-intros.
-eapply Th_plus_reg_left with n.
-rewrite (plus_comm n m).
-rewrite (plus_comm n p).
-auto.
-Qed.
-*)
-Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
-intros.
-repeat rewrite (mult_comm n).
-eauto.
-Qed.
-
-Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
-symmetry ; apply Th_distr_right.
-Qed.
-
-End Theory_of_rings.
-
-Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Ring_Theory_of :
-  forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A)
-    (Aopp:A -> A) (Aeq:A -> A -> bool),
-    Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
-    Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-intros until 1; case H.
-split; intros; simpl; eauto.
-Defined.
-
-(* Every ring can be viewed as a semi-ring : this property will be used
-  in Abstract_polynom. *)
-Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
deleted file mode 100644
index 472c91b4..00000000
--- a/plugins/ring/LegacyZArithRing.v
+++ /dev/null
@@ -1,35 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Instantiation of the Ring tactic for the binary integers of ZArith *)
-
-Require Export LegacyArithRing.
-Require Export ZArith_base.
-Require Import Eqdep_dec.
-Require Import LegacyRing.
-
-Definition Zeq (x y:Z) :=
-  match (x ?= y)%Z with
-  | Datatypes.Eq => true
-  | _ => false
-  end.
-
-Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
-  intros x y H; unfold Zeq in H.
-  apply Z.compare_eq.
-  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
-Qed.
-
-Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq.
-  split; intros; eauto with zarith.
-  apply Zeq_prop; assumption.
-Qed.
-
-(* NatConstants and NatTheory are defined in Ring_theory.v *)
-Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory
- [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
deleted file mode 100644
index 4aec3893..00000000
--- a/plugins/ring/Ring_abstract.v
+++ /dev/null
@@ -1,700 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-Require Import Ring_normalize.
-
-Section abstract_semi_rings.
-
-Inductive aspolynomial : Type :=
-  | ASPvar : index -> aspolynomial
-  | ASP0 : aspolynomial
-  | ASP1 : aspolynomial
-  | ASPplus : aspolynomial -> aspolynomial -> aspolynomial
-  | ASPmult : aspolynomial -> aspolynomial -> aspolynomial.
-
-Inductive abstract_sum : Type :=
-  | Nil_acs : abstract_sum
-  | Cons_acs : varlist -> abstract_sum -> abstract_sum.
-
-Fixpoint abstract_sum_merge (s1:abstract_sum) :
- abstract_sum -> abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      (fix asm_aux (s2:abstract_sum) : abstract_sum :=
-         match s2 with
-         | Cons_acs l2 t2 =>
-             if varlist_lt l1 l2
-             then Cons_acs l1 (abstract_sum_merge t1 s2)
-             else Cons_acs l2 (asm_aux t2)
-         | Nil_acs => s1
-         end)
-  | Nil_acs => fun s2 => s2
-  end.
-
-Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      if varlist_lt l1 l2
-      then Cons_acs l1 s2
-      else Cons_acs l2 (abstract_varlist_insert l1 t2)
-  | Nil_acs => Cons_acs l1 Nil_acs
-  end.
-
-Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} :
- abstract_sum :=
-  match s2 with
-  | Cons_acs l2 t2 =>
-      abstract_varlist_insert (varlist_merge l1 l2)
-        (abstract_sum_scalar l1 t2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum :=
-  match s1 with
-  | Cons_acs l1 t1 =>
-      abstract_sum_merge (abstract_sum_scalar l1 s2)
-        (abstract_sum_prod t1 s2)
-  | Nil_acs => Nil_acs
-  end.
-
-Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum :=
-  match p with
-  | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs
-  | ASP1 => Cons_acs Nil_var Nil_acs
-  | ASP0 => Nil_acs
-  | ASPplus l r =>
-      abstract_sum_merge (aspolynomial_normalize l)
-        (aspolynomial_normalize r)
-  | ASPmult l r =>
-      abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r)
-  end.
-
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Fixpoint interp_asp (p:aspolynomial) : A :=
-  match p with
-  | ASPvar i => interp_var Azero vm i
-  | ASP0 => Azero
-  | ASP1 => Aone
-  | ASPplus l r => Aplus (interp_asp l) (interp_asp r)
-  | ASPmult l r => Amult (interp_asp l) (interp_asp r)
-  end.
-
-(* Local *) Definition iacs_aux :=
-              (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A :=
-                 match s with
-                 | Nil_acs => a
-                 | Cons_acs l t =>
-                     Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 end).
-
-Definition interp_acs (s:abstract_sum) : A :=
-  match s with
-  | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Nil_acs => Azero
-  end.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Remark iacs_aux_ok :
- forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.
-
-Lemma abstract_varlist_insert_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  elim (varlist_lt l v); simpl.
-  eauto.
-  rewrite iacs_aux_ok.
-  rewrite H; auto.
-
-Qed.
-
-Lemma abstract_sum_merge_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
-
-Proof.
-  simple induction x.
-  trivial.
-  simple induction y; intros.
-
-  auto.
-
-  simpl; elim (varlist_lt v v0); simpl.
-  repeat rewrite iacs_aux_ok.
-  rewrite H; simpl; auto.
-
-  simpl in H0.
-  repeat rewrite iacs_aux_ok.
-  rewrite H0. simpl; auto.
-Qed.
-
-Lemma abstract_sum_scalar_ok :
- forall (l:varlist) (s:abstract_sum),
-   interp_acs (abstract_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
-Proof.
-  simple induction s.
-  simpl; eauto.
-
-  simpl; intros.
-  rewrite iacs_aux_ok.
-  rewrite abstract_varlist_insert_ok.
-  rewrite H.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  auto.
-Qed.
-
-Lemma abstract_sum_prod_ok :
- forall x y:abstract_sum,
-   interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).
-
-Proof.
-  simple induction x.
-  intros; simpl; eauto.
-
-  destruct y as [| v0 a0]; intros.
-
-  simpl; rewrite H; eauto.
-
-  unfold abstract_sum_prod; fold abstract_sum_prod.
-  rewrite abstract_sum_merge_ok.
-  rewrite abstract_sum_scalar_ok.
-  rewrite H; simpl; auto.
-Qed.
-
-Theorem aspolynomial_normalize_ok :
- forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
-Proof.
-  simple induction x; simpl; intros; trivial.
-  rewrite abstract_sum_merge_ok.
-  rewrite H; rewrite H0; eauto.
-  rewrite abstract_sum_prod_ok.
-  rewrite H; rewrite H0; eauto.
-Qed.
-
-End abstract_semi_rings.
-
-Section abstract_rings.
-
-(* In abstract polynomials there is no constants other
-   than 0 and 1. An abstract ring is a ring whose operations plus,
-   and mult are not functions but  constructors. In other words,
-   when c1 and c2 are closed,  (plus c1 c2) doesn't reduce to a closed
-   term. "closed" mean here "without plus and mult". *)
-
-(* this section is not parametrized by a (semi-)ring.
-   Nevertheless, they are two different types for semi-rings and rings
-   and there will be 2 correction theorems *)
-
-Inductive apolynomial : Type :=
-  | APvar : index -> apolynomial
-  | AP0 : apolynomial
-  | AP1 : apolynomial
-  | APplus : apolynomial -> apolynomial -> apolynomial
-  | APmult : apolynomial -> apolynomial -> apolynomial
-  | APopp : apolynomial -> apolynomial.
-
-(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
-   Invariant : the list is sorted and there is no varlist is present
-   with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
-
-Inductive signed_sum : Type :=
-  | Nil_varlist : signed_sum
-  | Plus_varlist : varlist -> signed_sum -> signed_sum
-  | Minus_varlist : varlist -> signed_sum -> signed_sum.
-
-Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      (fix ssm_aux (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Plus_varlist l1 (signed_sum_merge t1 s2)
-             else Plus_varlist l2 (ssm_aux t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Plus_varlist l1 (signed_sum_merge t1 s2)
-              else Minus_varlist l2 (ssm_aux t2)
-         | Nil_varlist => s1
-         end)
-  | Minus_varlist l1 t1 =>
-      (fix ssm_aux2 (s2:signed_sum) : signed_sum :=
-         match s2 with
-         | Plus_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then signed_sum_merge t1 t2
-             else
-              if varlist_lt l1 l2
-              then Minus_varlist l1 (signed_sum_merge t1 s2)
-              else Plus_varlist l2 (ssm_aux2 t2)
-         | Minus_varlist l2 t2 =>
-             if varlist_lt l1 l2
-             then Minus_varlist l1 (signed_sum_merge t1 s2)
-             else Minus_varlist l2 (ssm_aux2 t2)
-         | Nil_varlist => s1
-         end)
-  | Nil_varlist => fun s2 => s2
-  end.
-
-Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Plus_varlist l1 s2
-      else Plus_varlist l2 (plus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Plus_varlist l1 s2
-       else Minus_varlist l2 (plus_varlist_insert l1 t2)
-  | Nil_varlist => Plus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then t2
-      else
-       if varlist_lt l1 l2
-       then Minus_varlist l1 s2
-       else Plus_varlist l2 (minus_varlist_insert l1 t2)
-  | Minus_varlist l2 t2 =>
-      if varlist_lt l1 l2
-      then Minus_varlist l1 s2
-      else Minus_varlist l2 (minus_varlist_insert l1 t2)
-  | Nil_varlist => Minus_varlist l1 Nil_varlist
-  end.
-
-Fixpoint signed_sum_opp (s:signed_sum) : signed_sum :=
-  match s with
-  | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2)
-  | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-
-Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
- signed_sum :=
-  match s2 with
-  | Plus_varlist l2 t2 =>
-      minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Minus_varlist l2 t2 =>
-      plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum :=
-  match s1 with
-  | Plus_varlist l1 t1 =>
-      signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Minus_varlist l1 t1 =>
-      signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
-  | Nil_varlist => Nil_varlist
-  end.
-
-Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum :=
-  match p with
-  | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist
-  | AP1 => Plus_varlist Nil_var Nil_varlist
-  | AP0 => Nil_varlist
-  | APplus l r =>
-      signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r)
-  | APmult l r =>
-      signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r)
-  | APopp q => signed_sum_opp (apolynomial_normalize q)
-  end.
-
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-(* Local *) Definition isacs_aux :=
-              (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A :=
-                 match s with
-                 | Nil_varlist => a
-                 | Plus_varlist l t =>
-                     Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t)
-                 | Minus_varlist l t =>
-                     Aplus a
-                       (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
-                 end).
-
-Definition interp_sacs (s:signed_sum) : A :=
-  match s with
-  | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t
-  | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t
-  | Nil_varlist => Azero
-  end.
-
-Fixpoint interp_ap (p:apolynomial) : A :=
-  match p with
-  | APvar i => interp_var Azero vm i
-  | AP0 => Azero
-  | AP1 => Aone
-  | APplus l r => Aplus (interp_ap l) (interp_ap r)
-  | APmult l r => Amult (interp_ap l) (interp_ap r)
-  | APopp q => Aopp (interp_ap q)
-  end.
-
-Hint Resolve (Th_plus_comm T).
-Hint Resolve (Th_plus_assoc T).
-Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_comm T).
-Hint Resolve (Th_mult_assoc T).
-Hint Resolve (Th_mult_assoc2 T).
-Hint Resolve (Th_plus_zero_left T).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma isacs_aux_ok :
- forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
-
-Ltac solve1 v v0 H H0 :=
-  simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok;
-   [ rewrite H; simpl; auto | simpl in H0; rewrite H0; auto ].
-
-Lemma signed_sum_merge_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
-
-  simple induction x.
-  intro; simpl; auto.
-
-  simple induction y; intros.
-
-  auto.
-
-  solve1 v v0 H H0.
-
-  simpl; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T).
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
-      (interp_vl Amult Aone Azero vm v0)).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  simple induction y; intros.
-
-  auto.
-
-  simpl; generalize (varlist_eq_prop v v0).
-  elim (varlist_eq v v0); simpl.
-
-  intro Heq; rewrite (Heq I).
-  rewrite H.
-  repeat rewrite isacs_aux_ok.
-  rewrite (Th_plus_permute T).
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve1 v v0 H H0.
-
-  solve1 v v0 H H0.
-
-Qed.
-
-Ltac solve2 l v H :=
-  elim (varlist_lt l v); simpl; rewrite isacs_aux_ok;
-   [ auto | rewrite H; auto ].
-
-Lemma plus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_varlist_insert l s) =
-   Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  solve2 l v H.
-
-  simpl; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite (Th_opp_def T).
-  rewrite (Th_plus_zero_left T).
-  reflexivity.
-
-  solve2 l v H.
-
-Qed.
-
-Lemma minus_varlist_insert_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_varlist_insert l s) =
-   Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  generalize (varlist_eq_prop l v).
-  elim (varlist_eq l v); simpl.
-
-  intro Heq; rewrite (Heq I).
-  repeat rewrite isacs_aux_ok.
-  repeat rewrite (Th_plus_assoc T).
-  rewrite
-   (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
-      (interp_vl Amult Aone Azero vm v)).
-  rewrite (Th_opp_def T).
-  auto.
-
-  simpl; intros.
-  solve2 l v H.
-
-  simpl; intros; solve2 l v H.
-
-Qed.
-
-Lemma signed_sum_opp_ok :
- forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
-Proof.
-
-  simple induction s; simpl; intros.
-
-  symmetry ; apply (Th_opp_zero T).
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma plus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (plus_sum_scalar l s) =
-   Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
-Proof.
-
-  simple induction s.
-  trivial.
-
-  simpl; intros.
-  rewrite plus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  simpl; intros.
-  rewrite minus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  reflexivity.
-
-Qed.
-
-Lemma minus_sum_scalar_ok :
- forall (l:varlist) (s:signed_sum),
-   interp_sacs (minus_sum_scalar l s) =
-   Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
-Proof.
-
-  simple induction s; simpl; intros.
-
-  rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T).
-
-  simpl; intros.
-  rewrite minus_varlist_insert_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite (Th_plus_opp_opp T).
-  reflexivity.
-
-  simpl; intros.
-  rewrite plus_varlist_insert_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
-  rewrite H.
-  rewrite (Th_distr_right T).
-  rewrite <- (Th_opp_mult_right T).
-  rewrite <- (Th_plus_opp_opp T).
-  rewrite (Th_opp_opp T).
-  reflexivity.
-
-Qed.
-
-Lemma signed_sum_prod_ok :
- forall x y:signed_sum,
-   interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
-Proof.
-
-  simple induction x.
-
-  simpl; eauto 1.
-
-  intros; simpl.
-  rewrite signed_sum_merge_ok.
-  rewrite plus_sum_scalar_ok.
-  repeat rewrite isacs_aux_ok.
-  rewrite H.
-  auto.
-
-  intros; simpl.
-  repeat rewrite isacs_aux_ok.
-  rewrite signed_sum_merge_ok.
-  rewrite minus_sum_scalar_ok.
-  rewrite H.
-  rewrite (Th_distr_left T).
-  rewrite (Th_opp_mult_left T).
-  reflexivity.
-
-Qed.
-
-Theorem apolynomial_normalize_ok :
- forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
-Proof.
-  simple induction p; simpl; auto 1.
-  intros.
-    rewrite signed_sum_merge_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_prod_ok.
-    rewrite H; rewrite H0; reflexivity.
-  intros.
-    rewrite signed_sum_opp_ok.
-    rewrite H; reflexivity.
-Qed.
-
-End abstract_rings.
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
deleted file mode 100644
index 6306c4a7..00000000
--- a/plugins/ring/Ring_normalize.v
+++ /dev/null
@@ -1,897 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import LegacyRing_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  intros.
-  apply index_eq_prop.
-  generalize H.
-  case (index_eq n m); simpl; trivial; intros.
-  contradiction.
-Qed.
-
-Section semi_rings.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aeq : A -> A -> bool.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms
-  (the order on monoms is defined later)
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by :
-  - A constant is less than every monom
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples :
-  3 < x < y
-  x*y < x*y*y*z
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *)
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-ring polynomials *)
-Inductive spolynomial : Type :=
-  | SPvar : index -> spolynomial
-  | SPconst : A -> spolynomial
-  | SPplus : spolynomial -> spolynomial -> spolynomial
-  | SPmult : spolynomial -> spolynomial -> spolynomial.
-
-Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
-  match p with
-  | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SPconst c => Cons_monom c Nil_var Nil_monom
-  | SPplus l r =>
-      canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r)
-  | SPmult l r =>
-      canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r)
-  end.
-
-(* Deletion of useless 0 and 1 in canonical sums *)
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition spolynomial_simplify (x:spolynomial) :=
-  canonical_sum_simplify (spolynomial_normalize x).
-
-(* End definitions. *)
-
-(* Section interpretation. *)
-
-(*** Here a variable map is defined and the interpetation of a spolynom
-  acording to a certain variables map. Once again the choosen definition
-  is generic and could be changed ****)
-
-Variable vm : varmap A.
-
-(* Interpretation of list of variables
- * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
- * The unbound variables are mapped to 0. Normally this case sould
- * never occur. Since we want only to prove correctness theorems, which form
- * is : for any varmap and any spolynom ... this is a safe and pain-saving
- * choice *)
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-(* Local *) Definition ivl_aux :=
-              (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-                 match t with
-                 | Nil_var => interp_var x
-                 | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-                 end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-(* Local *) Definition interp_m (c:A) (l:varlist) :=
-              match l with
-              | Nil_var => c
-              | Cons_var x t => Amult c (ivl_aux x t)
-              end.
-
-(* Local *) Definition ics_aux :=
-              (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-                 match s with
-                 | Nil_monom => a
-                 | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-                 | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-                 end).
-
-(* Interpretation of a canonical sum *)
-Definition interp_cs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_sp (p:spolynomial) : A :=
-  match p with
-  | SPconst c => c
-  | SPvar i => interp_var i
-  | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2)
-  | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2)
-  end.
-
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SR_plus_comm T).
-Hint Resolve (SR_plus_assoc T).
-Hint Resolve (SR_plus_assoc2 T).
-Hint Resolve (SR_mult_comm T).
-Hint Resolve (SR_mult_assoc T).
-Hint Resolve (SR_mult_assoc2 T).
-Hint Resolve (SR_plus_zero_left T).
-Hint Resolve (SR_plus_zero_left2 T).
-Hint Resolve (SR_mult_one_left T).
-Hint Resolve (SR_mult_one_left2 T).
-Hint Resolve (SR_mult_zero_left T).
-Hint Resolve (SR_mult_zero_left2 T).
-Hint Resolve (SR_distr_left T).
-Hint Resolve (SR_distr_left2 T).
-(*Hint Resolve (SR_plus_reg_left T).*)
-Hint Resolve (SR_plus_permute T).
-Hint Resolve (SR_mult_permute T).
-Hint Resolve (SR_distr_right T).
-Hint Resolve (SR_distr_right2 T).
-Hint Resolve (SR_mult_zero_right T).
-Hint Resolve (SR_mult_zero_right2 T).
-Hint Resolve (SR_plus_zero_right T).
-Hint Resolve (SR_plus_zero_right2 T).
-Hint Resolve (SR_mult_one_right T).
-Hint Resolve (SR_mult_one_right2 T).
-(*Hint Resolve (SR_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   ivl_aux i v = Amult (interp_var i) (interp_vl v).
-Proof.
-  simple induction v; simpl; intros.
-  trivial.
-  rewrite H; trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
-Proof.
-  simple induction x.
-  simpl; trivial.
-  simple induction y.
-  simpl; trivial.
-  simpl; intros.
-  elim (index_lt i i0); simpl; intros.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H. simpl.
-  rewrite ivl_aux_ok.
-  eauto.
-
-  repeat rewrite ivl_aux_ok.
-  rewrite H0.
-  rewrite ivl_aux_ok.
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
-Proof.
-  simple induction s; simpl; intros.
-  trivial.
-  reflexivity.
-  reflexivity.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
-Proof.
-  destruct l as [| i v].
-  simpl; trivial.
-  reflexivity.
-Qed.
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
-
-simple induction x; simpl.
-trivial.
-
-simple induction y; simpl; intros.
-(* monom and nil *)
-eauto.
-
-(* monom and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-(* monom and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
-rewrite (SR_mult_one_left T).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-simple induction y; simpl; intros.
-(* varlist and nil *)
-trivial.
-
-(* varlist and monom *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-
-(* varlist and varlist *)
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl; repeat rewrite ics_aux_ok; rewrite H.
-repeat rewrite interp_m_ok.
-rewrite (SR_distr_left T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_one_left T).
-apply f_equal with (f := Aplus (interp_vl v0)).
-trivial.
-
-elim (varlist_lt v v0); simpl.
-repeat rewrite ics_aux_ok.
-rewrite H; simpl; rewrite ics_aux_ok; eauto.
-rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl;
- eauto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   interp_cs (monom_insert a l s) =
-   Aplus (Amult a (interp_vl l)) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl; rewrite interp_m_ok; trivial.
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
-intros; generalize s; simple induction s0.
-
-simpl; trivial.
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-
-simpl; intros.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok;
- repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
- rewrite (SR_mult_one_left T); eauto.
-elim (varlist_lt l v); simpl;
- [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
- | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
-    rewrite ics_aux_ok; eauto ].
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
-simple induction s.
-simpl; eauto.
-
-simpl; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-
-simpl; intros.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
-simple induction s.
-simpl; trivial.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl; intros.
-rewrite varlist_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   interp_cs (canonical_sum_scalar3 c l s) =
-   Amult c (Amult (interp_vl l) (interp_cs s)).
-simple induction s.
-simpl; repeat rewrite (SR_mult_zero_right T); reflexivity.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
-reflexivity.
-
-simpl; intros.
-rewrite monom_insert_ok.
-repeat rewrite ics_aux_ok.
-repeat rewrite interp_m_ok.
-rewrite H.
-rewrite varlist_merge_ok.
-repeat rewrite (SR_distr_right T).
-repeat rewrite <- (SR_mult_assoc T).
-repeat rewrite <- (SR_plus_assoc T).
-rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
-reflexivity.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
-simple induction x; simpl; intros.
-trivial.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar3_ok.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
-symmetry .
-eauto.
-
-rewrite canonical_sum_merge_ok.
-rewrite canonical_sum_scalar2_ok.
-rewrite ics_aux_ok.
-rewrite H.
-trivial.
-Qed.
-
-Theorem spolynomial_normalize_ok :
- forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
-simple induction p; simpl; intros.
-
-reflexivity.
-reflexivity.
-
-rewrite canonical_sum_merge_ok.
-rewrite H; rewrite H0.
-reflexivity.
-
-rewrite canonical_sum_prod_ok.
-rewrite H; rewrite H0.
-reflexivity.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
-simple induction s.
-
-reflexivity.
-
-(* cons_monom *)
-simpl; intros.
-generalize (SR_eq_prop T a Azero).
-elim (Aeq a Azero).
-intro Heq; rewrite (Heq I).
-rewrite H.
-rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite (SR_mult_zero_left T).
-trivial.
-
-intros; simpl.
-generalize (SR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intro Heq; rewrite (Heq I).
-simpl.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-rewrite (SR_mult_one_left T).
-reflexivity.
-
-simpl.
-repeat rewrite ics_aux_ok.
-rewrite interp_m_ok.
-rewrite H.
-reflexivity.
-
-(* cons_varlist *)
-simpl; intros.
-repeat rewrite ics_aux_ok.
-rewrite H.
-reflexivity.
-
-Qed.
-
-Theorem spolynomial_simplify_ok :
- forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
-intro.
-unfold spolynomial_simplify.
-rewrite canonical_sum_simplify_ok.
-apply spolynomial_normalize_ok.
-Qed.
-
-(* End properties. *)
-End semi_rings.
-
-Arguments Cons_varlist : default implicits.
-Arguments Cons_monom : default implicits.
-Arguments SPconst : default implicits.
-Arguments SPplus : default implicits.
-Arguments SPmult : default implicits.
-
-Section rings.
-
-(* Here the coercion between Ring and Semi-Ring will be useful *)
-
-Set Implicit Arguments.
-
-Variable A : Type.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable vm : varmap A.
-Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-Hint Resolve (Th_plus_comm T).
-Hint Resolve (Th_plus_assoc T).
-Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_comm T).
-Hint Resolve (Th_mult_assoc T).
-Hint Resolve (Th_mult_assoc2 T).
-Hint Resolve (Th_plus_zero_left T).
-Hint Resolve (Th_plus_zero_left2 T).
-Hint Resolve (Th_mult_one_left T).
-Hint Resolve (Th_mult_one_left2 T).
-Hint Resolve (Th_mult_zero_left T).
-Hint Resolve (Th_mult_zero_left2 T).
-Hint Resolve (Th_distr_left T).
-Hint Resolve (Th_distr_left2 T).
-(*Hint Resolve (Th_plus_reg_left T).*)
-Hint Resolve (Th_plus_permute T).
-Hint Resolve (Th_mult_permute T).
-Hint Resolve (Th_distr_right T).
-Hint Resolve (Th_distr_right2 T).
-Hint Resolve (Th_mult_zero_right T).
-Hint Resolve (Th_mult_zero_right2 T).
-Hint Resolve (Th_plus_zero_right T).
-Hint Resolve (Th_plus_zero_right2 T).
-Hint Resolve (Th_mult_one_right T).
-Hint Resolve (Th_mult_one_right2 T).
-(*Hint Resolve (Th_plus_reg_right T).*)
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-(*** Definitions *)
-
-Inductive polynomial : Type :=
-  | Pvar : index -> polynomial
-  | Pconst : A -> polynomial
-  | Pplus : polynomial -> polynomial -> polynomial
-  | Pmult : polynomial -> polynomial -> polynomial
-  | Popp : polynomial -> polynomial.
-
-Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A :=
-  match x with
-  | Pplus l r =>
-      canonical_sum_merge Aplus Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pmult l r =>
-      canonical_sum_prod Aplus Amult Aone (polynomial_normalize l)
-        (polynomial_normalize r)
-  | Pconst c => Cons_monom c Nil_var (Nil_monom A)
-  | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A)
-  | Popp p =>
-      canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-        (polynomial_normalize p)
-  end.
-
-Definition polynomial_simplify (x:polynomial) :=
-  canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x).
-
-Fixpoint spolynomial_of (x:polynomial) : spolynomial A :=
-  match x with
-  | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r)
-  | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r)
-  | Pconst c => SPconst c
-  | Pvar i => SPvar A i
-  | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_p (p:polynomial) : A :=
-  match p with
-  | Pconst c => c
-  | Pvar i => varmap_find Azero i vm
-  | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2)
-  | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2)
-  | Popp p1 => Aopp (interp_p p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma spolynomial_of_ok :
- forall p:polynomial,
-   interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
-simple induction p; reflexivity || (simpl; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H.
-rewrite (Th_opp_mult_left2 T).
-rewrite (Th_mult_one_left T).
-reflexivity.
-Qed.
-
-Theorem polynomial_normalize_ok :
- forall p:polynomial,
-   polynomial_normalize p =
-   spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
-simple induction p; reflexivity || (simpl; intros).
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl.
-elim
- (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
-    (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
- [ reflexivity
- | simpl; intros; rewrite H0; reflexivity
- | simpl; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem polynomial_simplify_ok :
- forall p:polynomial,
-   interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
-intro.
-unfold polynomial_simplify.
-rewrite spolynomial_of_ok.
-rewrite polynomial_normalize_ok.
-rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
-rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
-reflexivity.
-Qed.
-
-End rings.
-
-Infix "+" := Pplus : ring_scope.
-Infix "*" := Pmult : ring_scope.
-Notation "- x" := (Popp x) : ring_scope.
-Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
-
-Delimit Scope ring_scope with ring.
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
deleted file mode 100644
index e71be89a..00000000
--- a/plugins/ring/Setoid_ring_normalize.v
+++ /dev/null
@@ -1,1160 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Import Setoid_ring_theory.
-Require Import Quote.
-
-Set Implicit Arguments.
-
-Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
-Proof.
-  simple induction n; simple induction m; simpl;
-   try reflexivity || contradiction.
-  intros; rewrite (H i0); trivial.
-  intros; rewrite (H i0); trivial.
-Qed.
-
-Section setoid.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable plus_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Aplus a a1)  (Aplus a0 a2).
-Variable mult_morph :
- forall a a0:A, Aequiv a a0 ->
-   forall a1 a2:A, Aequiv a1 a2 ->
-     Aequiv (Amult a a1) (Amult a0 a2).
-Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve equiv_refl equiv_trans.
-Hint Immediate equiv_sym.
-
-Section semi_setoid_rings.
-
-(* Section definitions. *)
-
-
-(******************************************)
-(* Normal abtract Polynomials             *)
-(******************************************)
-(* DEFINITIONS :
-- A varlist is a sorted product of one or more variables : x, x*y*z
-- A monom is a constant, a varlist or the product of a constant by a varlist
-  variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
-- A canonical sum is either a monom or an ordered sum of monoms
-  (the order on monoms is defined later)
-- A normal polynomial it either a constant or a canonical sum or a constant
-  plus a canonical sum
-*)
-
-(* varlist is isomorphic to (list var), but we built a special inductive
-   for efficiency *)
-Inductive varlist : Type :=
-  | Nil_var : varlist
-  | Cons_var : index -> varlist -> varlist.
-
-Inductive canonical_sum : Type :=
-  | Nil_monom : canonical_sum
-  | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
-  | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
-
-(* Order on monoms *)
-
-(* That's the lexicographic order on varlist, extended by :
-  - A constant is less than every monom
-  - The relation between two varlist is preserved by multiplication by a
-  constant.
-
-  Examples :
-  3 < x < y
-  x*y < x*y*y*z
-  2*x*y < x*y*y*z
-  x*y < 54*x*y*y*z
-  4*x*y < 59*x*y*y*z
-*)
-
-Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Nil_var => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      andb (index_eq i j) (varlist_eq xrest yrest)
-  | _, _ => false
-  end.
-
-Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
-  match x, y with
-  | Nil_var, Cons_var _ _ => true
-  | Cons_var i xrest, Cons_var j yrest =>
-      if index_lt i j
-      then true
-      else andb (index_eq i j) (varlist_lt xrest yrest)
-  | _, _ => false
-  end.
-
-(* merges two variables lists *)
-Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
-  match l1 with
-  | Cons_var v1 t1 =>
-      (fix vm_aux (l2:varlist) : varlist :=
-         match l2 with
-         | Cons_var v2 t2 =>
-             if index_lt v1 v2
-             then Cons_var v1 (varlist_merge t1 l2)
-             else Cons_var v2 (vm_aux t2)
-         | Nil_var => l1
-         end)
-  | Nil_var => fun l2 => l2
-  end.
-
-(* returns the sum of two canonical sums  *)
-Fixpoint canonical_sum_merge (s1:canonical_sum) :
- canonical_sum -> canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      (fix csm_aux (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux t2)
-         | Nil_monom => s1
-         end)
-  | Cons_varlist l1 t1 =>
-      (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-         match s2 with
-         | Cons_monom c2 l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_monom c2 l2 (csm_aux2 t2)
-         | Cons_varlist l2 t2 =>
-             if varlist_eq l1 l2
-             then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
-             else
-              if varlist_lt l1 l2
-              then Cons_varlist l1 (canonical_sum_merge t1 s2)
-              else Cons_varlist l2 (csm_aux2 t2)
-         | Nil_monom => s1
-         end)
-  | Nil_monom => fun s2 => s2
-  end.
-
-(* Insertion of a monom in a canonical sum *)
-Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_monom c2 l2 (monom_insert c1 l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus c1 Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_monom c1 l1 s2
-       else Cons_varlist l2 (monom_insert c1 l1 t2)
-  | Nil_monom => Cons_monom c1 l1 Nil_monom
-  end.
-
-Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
- canonical_sum :=
-  match s2 with
-  | Cons_monom c2 l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone c2) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_monom c2 l2 (varlist_insert l1 t2)
-  | Cons_varlist l2 t2 =>
-      if varlist_eq l1 l2
-      then Cons_monom (Aplus Aone Aone) l1 t2
-      else
-       if varlist_lt l1 l2
-       then Cons_varlist l1 s2
-       else Cons_varlist l2 (varlist_insert l1 t2)
-  | Nil_monom => Cons_varlist l1 Nil_monom
-  end.
-
-(* Computes c0*s *)
-Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
-  | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes l0*s  *)
-Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
- canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Cons_varlist l t =>
-      varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* Computes c0*l0*s  *)
-Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
- (s:canonical_sum) {struct s} : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      monom_insert (Amult c0 c) (varlist_merge l0 l)
-        (canonical_sum_scalar3 c0 l0 t)
-  | Cons_varlist l t =>
-      monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
-  | Nil_monom => Nil_monom
-  end.
-
-(* returns the product of two canonical sums *)
-Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
- canonical_sum :=
-  match s1 with
-  | Cons_monom c1 l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Cons_varlist l1 t1 =>
-      canonical_sum_merge (canonical_sum_scalar2 l1 s2)
-        (canonical_sum_prod t1 s2)
-  | Nil_monom => Nil_monom
-  end.
-
-(* The type to represent concrete semi-setoid-ring polynomials *)
-
-Inductive setspolynomial : Type :=
-  | SetSPvar : index -> setspolynomial
-  | SetSPconst : A -> setspolynomial
-  | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
-  | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
-
-Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
-  match p with
-  | SetSPplus l r =>
-      canonical_sum_merge (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPmult l r =>
-      canonical_sum_prod (setspolynomial_normalize l)
-        (setspolynomial_normalize r)
-  | SetSPconst c => Cons_monom c Nil_var Nil_monom
-  | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  end.
-
-Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
-  match s with
-  | Cons_monom c l t =>
-      if Aeq c Azero
-      then canonical_sum_simplify t
-      else
-       if Aeq c Aone
-       then Cons_varlist l (canonical_sum_simplify t)
-       else Cons_monom c l (canonical_sum_simplify t)
-  | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
-  | Nil_monom => Nil_monom
-  end.
-
-Definition setspolynomial_simplify (x:setspolynomial) :=
-  canonical_sum_simplify (setspolynomial_normalize x).
-
-Variable vm : varmap A.
-
-Definition interp_var (i:index) := varmap_find Azero i vm.
-
-Definition ivl_aux :=
-  (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
-     match t with
-     | Nil_var => interp_var x
-     | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
-     end).
-
-Definition interp_vl (l:varlist) :=
-  match l with
-  | Nil_var => Aone
-  | Cons_var x t => ivl_aux x t
-  end.
-
-Definition interp_m (c:A) (l:varlist) :=
-  match l with
-  | Nil_var => c
-  | Cons_var x t => Amult c (ivl_aux x t)
-  end.
-
-Definition ics_aux :=
-  (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
-     match s with
-     | Nil_monom => a
-     | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
-     | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
-     end).
-
-Definition interp_setcs (s:canonical_sum) : A :=
-  match s with
-  | Nil_monom => Azero
-  | Cons_varlist l t => ics_aux (interp_vl l) t
-  | Cons_monom c l t => ics_aux (interp_m c l) t
-  end.
-
-Fixpoint interp_setsp (p:setspolynomial) : A :=
-  match p with
-  | SetSPconst c => c
-  | SetSPvar i => interp_var i
-  | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
-  | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
-  end.
-
-(* End interpretation. *)
-
-Unset Implicit Arguments.
-
-(* Section properties. *)
-
-Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.
-
-Hint Resolve (SSR_plus_comm T).
-Hint Resolve (SSR_plus_assoc T).
-Hint Resolve (SSR_plus_assoc2 S T).
-Hint Resolve (SSR_mult_comm T).
-Hint Resolve (SSR_mult_assoc T).
-Hint Resolve (SSR_mult_assoc2 S T).
-Hint Resolve (SSR_plus_zero_left T).
-Hint Resolve (SSR_plus_zero_left2 S T).
-Hint Resolve (SSR_mult_one_left T).
-Hint Resolve (SSR_mult_one_left2 S T).
-Hint Resolve (SSR_mult_zero_left T).
-Hint Resolve (SSR_mult_zero_left2 S T).
-Hint Resolve (SSR_distr_left T).
-Hint Resolve (SSR_distr_left2 S T).
-Hint Resolve (SSR_plus_reg_left T).
-Hint Resolve (SSR_plus_permute S plus_morph T).
-Hint Resolve (SSR_mult_permute S mult_morph T).
-Hint Resolve (SSR_distr_right S plus_morph T).
-Hint Resolve (SSR_distr_right2 S plus_morph T).
-Hint Resolve (SSR_mult_zero_right S T).
-Hint Resolve (SSR_mult_zero_right2 S T).
-Hint Resolve (SSR_plus_zero_right S T).
-Hint Resolve (SSR_plus_zero_right2 S T).
-Hint Resolve (SSR_mult_one_right S T).
-Hint Resolve (SSR_mult_one_right2 S T).
-Hint Resolve (SSR_plus_reg_right S T).
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
-Proof.
-  simple induction x; simple induction y; contradiction || (try reflexivity).
-  simpl; intros.
-  generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
-  rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
-Qed.
-
-Remark ivl_aux_ok :
- forall (v:varlist) (i:index),
-   Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
-Proof.
-  simple induction v; simpl; intros.
-  trivial.
-  rewrite (H i); trivial.
-Qed.
-
-Lemma varlist_merge_ok :
- forall x y:varlist,
-   Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
-Proof.
-  simple induction x.
-  simpl; trivial.
-  simple induction y.
-  simpl; trivial.
-  simpl; intros.
-  elim (index_lt i i0); simpl; intros.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
-  rewrite (H (Cons_var i0 v0)).
-  simpl.
-  rewrite (ivl_aux_ok v0 i0).
-  eauto.
-
-  rewrite (ivl_aux_ok v i).
-  rewrite (ivl_aux_ok v0 i0).
-  rewrite
-   (ivl_aux_ok
-      ((fix vm_aux (l2:varlist) : varlist :=
-          match l2 with
-          | Nil_var => Cons_var i v
-          | Cons_var v2 t2 =>
-              if index_lt i v2
-              then Cons_var i (varlist_merge v l2)
-              else Cons_var v2 (vm_aux t2)
-          end) v0) i0).
-  rewrite H0.
-  rewrite (ivl_aux_ok v i).
-  eauto.
-Qed.
-
-Remark ics_aux_ok :
- forall (x:A) (s:canonical_sum),
-   Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
-Proof.
- simple induction s; simpl; intros; trivial.
-Qed.
-
-Remark interp_m_ok :
- forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
-Proof.
-  destruct l as [| i v]; trivial.
-Qed.
-
-Hint Resolve ivl_aux_ok.
-Hint Resolve ics_aux_ok.
-Hint Resolve interp_m_ok.
-
-(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
-
-Lemma canonical_sum_merge_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_merge x y))
-     (Aplus (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl.
-trivial.
-
-simple induction y; simpl; intros.
-eauto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m a v0) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a a0) v0).
-rewrite (interp_m_ok a v0).
-rewrite (interp_m_ok a0 v0).
-setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult a0 (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
- .
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (ics_aux_ok (interp_m a0 v0) c0).
-rewrite (H (Cons_monom a0 v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_m a0 v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)).
-rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl;
- auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_m a v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H c0).
-rewrite (interp_m_ok (Aplus a Aone) v0).
-rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
- (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (Amult a (interp_vl v0))
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl.
-intro.
-rewrite
- (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_m a v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0).
-rewrite (H (Cons_varlist v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_vl v0) c0).
-auto.
-
-intro.
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_monom a v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_monom a v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl.
-auto.
-
-simple induction y; simpl; intros.
-trivial.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0).
-intros; rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
- rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult a (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c)
-       (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt v v0); simpl; intros.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_m a v0) c0).
-rewrite (H (Cons_monom a v0 c0)); simpl.
-rewrite (ics_aux_ok (interp_m a v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_m a v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
- simpl; auto.
-
-generalize (varlist_eq_prop v v0).
-elim (varlist_eq v v0); intros.
-rewrite (H1 I); simpl.
-rewrite
- (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
- ; rewrite (ics_aux_ok (interp_vl v0) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
-rewrite (interp_m_ok (Aplus Aone Aone) v0).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
- (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
-    (Aplus (interp_setcs c) (interp_setcs c0))) with
- (Aplus (Amult Aone (interp_vl v0))
-    (Aplus (Amult Aone (interp_vl v0))
-       (Aplus (interp_setcs c) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace
- (Aplus (Aplus (interp_vl v0) (interp_setcs c))
-    (Aplus (interp_vl v0) (interp_setcs c0))) with
- (Aplus (interp_vl v0)
-    (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
-[ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
-
-elim (varlist_lt v v0); simpl.
-rewrite
- (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
- ; rewrite (ics_aux_ok (interp_vl v) c);
- rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
- simpl.
-rewrite (ics_aux_ok (interp_vl v0) c0); auto.
-
-rewrite
- (ics_aux_ok (interp_vl v0)
-    ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
-        match s2 with
-        | Nil_monom => Cons_varlist v c
-        | Cons_monom c2 l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_monom c2 l2 (csm_aux2 t2)
-        | Cons_varlist l2 t2 =>
-            if varlist_eq v l2
-            then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
-            else
-             if varlist_lt v l2
-             then Cons_varlist v (canonical_sum_merge c s2)
-             else Cons_varlist l2 (csm_aux2 t2)
-        end) c0)); rewrite H0.
-rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
- simpl; auto.
-Qed.
-
-Lemma monom_insert_ok :
- forall (a:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (monom_insert a l s))
-     (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
-Proof.
-simple induction s; intros.
-simpl; rewrite (interp_m_ok a l); trivial.
-
-simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
-setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl; intros.
-rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
-auto.
-
-rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
- rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
-auto.
-
-simpl.
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus a Aone) v).
-setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
- (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
- [ idtac | trivial ].
-auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma varlist_insert_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (varlist_insert l s))
-     (Aplus (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
-setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
- rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H; auto.
-
-generalize (varlist_eq_prop l v); elim (varlist_eq l v).
-intro Hr; rewrite (Hr I); simpl.
-rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
- rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (interp_m_ok (Aplus Aone Aone) v).
-setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
- (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
- [ idtac | trivial ].
-setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
-
-elim (varlist_lt l v); simpl; intros; auto.
-rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
-rewrite H.
-rewrite (ics_aux_ok (interp_vl v) c); auto.
-Qed.
-
-Lemma canonical_sum_scalar_ok :
- forall (a:A) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar a s))
-     (Amult a (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_m a0 v) c).
-rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
-rewrite H.
-setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
- with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
- rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
-rewrite (interp_m_ok a v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar2_ok :
- forall (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar2 l s))
-     (Amult (interp_vl l) (interp_setcs s)).
-Proof.
-simple induction s; simpl; intros; auto.
-rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c)));
- [ idtac | trivial ].
-auto.
-
-rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-auto.
-Qed.
-
-Lemma canonical_sum_scalar3_ok :
- forall (c:A) (l:varlist) (s:canonical_sum),
-   Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
-     (Amult c (Amult (interp_vl l) (interp_setcs s))).
-Proof.
-simple induction s; simpl; intros.
-rewrite (SSR_mult_zero_right S T (interp_vl l)).
-auto.
-
-rewrite
- (monom_insert_ok (Amult c a) (varlist_merge l v)
-    (canonical_sum_scalar3 c l c0)).
-rewrite (ics_aux_ok (interp_m a v) c0).
-rewrite (interp_m_ok a v).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
- (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-    (Amult (interp_vl l) (interp_setcs c0)));
- [ idtac | trivial ].
-setoid_replace
- (Amult c
-    (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
-       (Amult (interp_vl l) (interp_setcs c0)))) with
- (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
- (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
- [ idtac | trivial ].
-auto.
-
-rewrite
- (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
- .
-rewrite (ics_aux_ok (interp_vl v) c0).
-rewrite H.
-rewrite (varlist_merge_ok l v).
-setoid_replace
- (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
-    (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
- (Amult c
-    (Aplus (Amult (interp_vl l) (interp_vl v))
-       (Amult (interp_vl l) (interp_setcs c0))));
- [ idtac | trivial ].
-auto.
-Qed.
-
-Lemma canonical_sum_prod_ok :
- forall x y:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_prod x y))
-     (Amult (interp_setcs x) (interp_setcs y)).
-Proof.
-simple induction x; simpl; intros.
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
-    (canonical_sum_prod c y)).
-rewrite (canonical_sum_scalar3_ok a v y).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H y).
-setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
- (Amult (Amult a (interp_vl v)) (interp_setcs y));
- [ idtac | trivial ].
-setoid_replace
- (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
- with
- (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
-    (Amult (interp_setcs c) (interp_setcs y)));
- [ idtac | trivial ].
-trivial.
-
-rewrite
- (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
- .
-rewrite (canonical_sum_scalar2_ok v y).
-rewrite (ics_aux_ok (interp_vl v) c).
-rewrite (H y).
-trivial.
-Qed.
-
-Theorem setspolynomial_normalize_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
-Proof.
-simple induction p; simpl; intros; trivial.
-rewrite
- (canonical_sum_merge_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-
-rewrite
- (canonical_sum_prod_ok (setspolynomial_normalize s)
-    (setspolynomial_normalize s0)).
-rewrite H; rewrite H0; trivial.
-Qed.
-
-Lemma canonical_sum_simplify_ok :
- forall s:canonical_sum,
-   Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
-Proof.
-simple induction s; simpl; intros.
-trivial.
-
-generalize (SSR_eq_prop T a Azero).
-elim (Aeq a Azero).
-simpl.
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H0 I).
-setoid_replace (Amult Azero (interp_vl v)) with Azero;
- [ idtac | trivial ].
-rewrite H.
-trivial.
-
-intros; simpl.
-generalize (SSR_eq_prop T a Aone).
-elim (Aeq a Aone).
-intros.
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite (interp_m_ok a v).
-rewrite (H1 I).
-simpl.
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-
-simpl.
-intros.
-rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
-rewrite (ics_aux_ok (interp_m a v) c).
-rewrite H; trivial.
-
-rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
-rewrite H.
-auto.
-Qed.
-
-Theorem setspolynomial_simplify_ok :
- forall p:setspolynomial,
-   Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
-Proof.
-intro.
-unfold setspolynomial_simplify.
-rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
-exact (setspolynomial_normalize_ok p).
-Qed.
-
-End semi_setoid_rings.
-
-Arguments Cons_varlist : default implicits.
-Arguments Cons_monom : default implicits.
-Arguments SetSPconst : default implicits.
-Arguments SetSPplus : default implicits.
-Arguments SetSPmult : default implicits.
-
-
-
-Section setoid_rings.
-
-Set Implicit Arguments.
-
-Variable vm : varmap A.
-Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.
-
-Hint Resolve (STh_plus_comm T).
-Hint Resolve (STh_plus_assoc T).
-Hint Resolve (STh_plus_assoc2 S T).
-Hint Resolve (STh_mult_comm T).
-Hint Resolve (STh_mult_assoc T).
-Hint Resolve (STh_mult_assoc2 S T).
-Hint Resolve (STh_plus_zero_left T).
-Hint Resolve (STh_plus_zero_left2 S T).
-Hint Resolve (STh_mult_one_left T).
-Hint Resolve (STh_mult_one_left2 S T).
-Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
-Hint Resolve (STh_distr_left T).
-Hint Resolve (STh_distr_left2 S T).
-Hint Resolve (STh_plus_reg_left S plus_morph T).
-Hint Resolve (STh_plus_permute S plus_morph T).
-Hint Resolve (STh_mult_permute S mult_morph T).
-Hint Resolve (STh_distr_right S plus_morph T).
-Hint Resolve (STh_distr_right2 S plus_morph T).
-Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
-Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
-Hint Resolve (STh_plus_zero_right S T).
-Hint Resolve (STh_plus_zero_right2 S T).
-Hint Resolve (STh_mult_one_right S T).
-Hint Resolve (STh_mult_one_right2 S T).
-Hint Resolve (STh_plus_reg_right S plus_morph T).
-Hint Resolve eq_refl eq_sym eq_trans.
-Hint Immediate T.
-
-
-(*** Definitions *)
-
-Inductive setpolynomial : Type :=
-  | SetPvar : index -> setpolynomial
-  | SetPconst : A -> setpolynomial
-  | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
-  | SetPopp : setpolynomial -> setpolynomial.
-
-Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
-  match x with
-  | SetPplus l r =>
-      canonical_sum_merge (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPmult l r =>
-      canonical_sum_prod (setpolynomial_normalize l)
-        (setpolynomial_normalize r)
-  | SetPconst c => Cons_monom c Nil_var Nil_monom
-  | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
-  | SetPopp p =>
-      canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
-  end.
-
-Definition setpolynomial_simplify (x:setpolynomial) :=
-  canonical_sum_simplify (setpolynomial_normalize x).
-
-Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
-  match x with
-  | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
-  | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
-  | SetPconst c => SetSPconst c
-  | SetPvar i => SetSPvar i
-  | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
-  end.
-
-(*** Interpretation *)
-
-Fixpoint interp_setp (p:setpolynomial) : A :=
-  match p with
-  | SetPconst c => c
-  | SetPvar i => varmap_find Azero i vm
-  | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
-  | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
-  | SetPopp p1 => Aopp (interp_setp p1)
-  end.
-
-(*** Properties *)
-
-Unset Implicit Arguments.
-
-Lemma setspolynomial_of_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
-simple induction p; trivial; simpl; intros.
-rewrite H; rewrite H0; trivial.
-rewrite H; rewrite H0; trivial.
-rewrite H.
-rewrite
- (STh_opp_mult_left2 S plus_morph mult_morph T Aone
-    (interp_setsp vm (setspolynomial_of s))).
-rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
-trivial.
-Qed.
-
-Theorem setpolynomial_normalize_ok :
- forall p:setpolynomial,
-   setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
-simple induction p; trivial; simpl; intros.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; rewrite H0; reflexivity.
-rewrite H; simpl.
-elim
- (canonical_sum_scalar3 (Aopp Aone) Nil_var
-    (setspolynomial_normalize (setspolynomial_of s)));
- [ reflexivity
- | simpl; intros; rewrite H0; reflexivity
- | simpl; intros; rewrite H0; reflexivity ].
-Qed.
-
-Theorem setpolynomial_simplify_ok :
- forall p:setpolynomial,
-   Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
-intro.
-unfold setpolynomial_simplify.
-rewrite (setspolynomial_of_ok p).
-rewrite setpolynomial_normalize_ok.
-rewrite
- (canonical_sum_simplify_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T)
-    (setspolynomial_normalize (setspolynomial_of p)))
- .
-rewrite
- (setspolynomial_normalize_ok vm
-    (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
-       plus_morph mult_morph T) (setspolynomial_of p))
- .
-trivial.
-Qed.
-
-End setoid_rings.
-
-End setoid.
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
deleted file mode 100644
index bb88f646..00000000
--- a/plugins/ring/Setoid_ring_theory.v
+++ /dev/null
@@ -1,425 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Bool.
-Require Export Setoid.
-
-Set Implicit Arguments.
-
-Section Setoid_rings.
-
-Variable A : Type.
-Variable Aequiv : A -> A -> Prop.
-
-Infix Local "==" := Aequiv (at level 70, no associativity).
-
-Variable S : Setoid_Theory A Aequiv.
-
-Add Setoid A Aequiv S as Asetoid.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-
-Infix "+" := Aplus (at level 50, left associativity).
-Infix "*" := Amult (at level 40, left associativity).
-Notation "0" := Azero.
-Notation "1" := Aone.
-Notation "- x" := (Aopp x).
-
-Variable plus_morph :
- forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
-Variable mult_morph :
-  forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
-Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.
-
-Add Morphism Aplus : Aplus_ext.
-intros; apply plus_morph; assumption.
-Qed.
-
-Add Morphism Amult : Amult_ext.
-intros; apply mult_morph; assumption.
-Qed.
-
-Add Morphism Aopp : Aopp_ext.
-exact opp_morph.
-Qed.
-
-Section Theory_of_semi_setoid_rings.
-
-Record Semi_Setoid_Ring_Theory : Prop :=
-  {SSR_plus_comm : forall n m:A, n + m == m + n;
-   SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   SSR_mult_comm : forall n m:A, n * m == m * n;
-   SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
-   SSR_plus_zero_left : forall n:A, 0 + n == n;
-   SSR_mult_one_left : forall n:A, 1 * n == n;
-   SSR_mult_zero_left : forall n:A, 0 * n == 0;
-   SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
-   SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Semi_Setoid_Ring_Theory.
-
-Let plus_comm := SSR_plus_comm T.
-Let plus_assoc := SSR_plus_assoc T.
-Let mult_comm := SSR_mult_comm T.
-Let mult_assoc := SSR_mult_assoc T.
-Let plus_zero_left := SSR_plus_zero_left T.
-Let mult_one_left := SSR_mult_one_left T.
-Let mult_zero_left := SSR_mult_zero_left T.
-Let distr_left := SSR_distr_left T.
-Let plus_reg_left := SSR_plus_reg_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left mult_zero_left distr_left plus_reg_left
-  equiv_refl (*equiv_sym*).
-Hint Immediate equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because
-  Auto does not symmetry *)
-Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto. Qed.
-
-Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve SSR_plus_permute SSR_mult_permute.
-
-Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-auto.
-Qed.
-
-Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply SSR_distr_right.
-Qed.
-
-Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n).
-intro; apply plus_reg_left with n; trivial.
-Qed.
-
-End Theory_of_semi_setoid_rings.
-
-Section Theory_of_setoid_rings.
-
-Record Setoid_Ring_Theory : Prop :=
-  {STh_plus_comm : forall n m:A, n + m == m + n;
-   STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
-   STh_mult_comm : forall n m:A, n * m == m * n;
-   STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
-   STh_plus_zero_left : forall n:A, 0 + n == n;
-   STh_mult_one_left : forall n:A, 1 * n == n;
-   STh_opp_def : forall n:A, n + - n == 0;
-   STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
-   STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
-
-Variable T : Setoid_Ring_Theory.
-
-Let plus_comm := STh_plus_comm T.
-Let plus_assoc := STh_plus_assoc T.
-Let mult_comm := STh_mult_comm T.
-Let mult_assoc := STh_mult_assoc T.
-Let plus_zero_left := STh_plus_zero_left T.
-Let mult_one_left := STh_mult_one_left T.
-Let opp_def := STh_opp_def T.
-Let distr_left := STh_distr_left T.
-Let equiv_refl := Seq_refl A Aequiv S.
-Let equiv_sym := Seq_sym A Aequiv S.
-Let equiv_trans := Seq_trans A Aequiv S.
-
-Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
-  mult_one_left opp_def distr_left equiv_refl equiv_sym.
-
-(* Lemmas whose form is x=y are also provided in form y=x because Auto does
-  not symmetry *)
-
-Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
-auto. Qed.
-
-Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
-auto. Qed.
-
-Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
-auto. Qed.
-
-Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
-auto. Qed.
-
-Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
-auto. Qed.
-
-Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
-auto. Qed.
-
-Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
-intros.
-rewrite (plus_assoc n m p).
-rewrite (plus_comm n m).
-rewrite <- (plus_assoc m n p).
-trivial.
-Qed.
-
-Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
-intros.
-rewrite (mult_assoc n m p).
-rewrite (mult_comm n m).
-rewrite <- (mult_assoc m n p).
-trivial.
-Qed.
-
-Hint Resolve STh_plus_permute STh_mult_permute.
-
-Lemma Saux1 : forall a:A, a + a == a -> a == 0.
-intros.
-rewrite <- (plus_zero_left a).
-rewrite (plus_comm 0 a).
-setoid_replace (a + 0) with (a + (a + - a)) by auto.
-rewrite (plus_assoc a a (- a)).
-rewrite H.
-apply opp_def.
-Qed.
-
-Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
-intros.
-apply Saux1.
-rewrite <- (distr_left 0 0 n).
-rewrite (plus_zero_left 0).
-trivial.
-Qed.
-Hint Resolve STh_mult_zero_left.
-
-Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
-auto.
-Qed.
-
-Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z.
-intros.
-rewrite <- (plus_zero_left y).
-rewrite <- H0.
-rewrite <- (plus_assoc x z y).
-rewrite (plus_comm z y).
-rewrite (plus_assoc x y z).
-rewrite H.
-auto.
-Qed.
-
-Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
-intros.
-apply Saux2 with (x * y); auto.
-rewrite <- (distr_left x (- x) y).
-rewrite (opp_def x).
-auto.
-Qed.
-Hint Resolve STh_opp_mult_left.
-
-Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
-auto.
-Qed.
-
-Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
-intro; rewrite (mult_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
-intro; rewrite (plus_comm n 0); auto.
-Qed.
-
-Lemma STh_mult_one_right : forall n:A, n * 1 == n.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
-intro; rewrite (mult_comm n 1); auto.
-Qed.
-
-Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
-intros.
-rewrite (mult_comm x y).
-rewrite (mult_comm x (- y)).
-auto.
-Qed.
-
-Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
-intros.
-apply Saux2 with (x + y); auto.
-rewrite (STh_plus_permute (x + y) (- x) (- y)).
-rewrite <- (plus_assoc x y (- y)).
-rewrite (opp_def y); rewrite (STh_plus_zero_right x).
-rewrite (STh_opp_def2 x); trivial.
-Qed.
-
-Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
-auto.
-Qed.
-
-Lemma STh_opp_opp : forall n:A, - - n == n.
-intro.
-apply Saux2 with (- n); auto.
-rewrite (plus_comm (- n) n); auto.
-Qed.
-Hint Resolve STh_opp_opp.
-
-Lemma STh_opp_opp2 : forall n:A, n == - - n.
-auto.
-Qed.
-
-Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
-intros.
-rewrite (STh_opp_mult_left2 x (- y)).
-rewrite (STh_opp_mult_right2 x y).
-trivial.
-Qed.
-
-Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
-intros.
-apply equiv_sym.
-apply STh_mult_opp_opp.
-Qed.
-
-Lemma STh_opp_zero : - 0 == 0.
-rewrite <- (plus_zero_left (- 0)).
-trivial.
-Qed.
-
-Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p.
-intros.
-rewrite <- (plus_zero_left m).
-rewrite <- (plus_zero_left p).
-rewrite <- (opp_def n).
-rewrite (plus_comm n (- n)).
-rewrite <- (plus_assoc (- n) n m).
-rewrite <- (plus_assoc (- n) n p).
-auto.
-Qed.
-
-Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
-intros.
-apply STh_plus_reg_left with n.
-rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
-Qed.
-
-Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
-intros.
-rewrite (mult_comm n (m + p)).
-rewrite (mult_comm n m).
-rewrite (mult_comm n p).
-trivial.
-Qed.
-
-Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
-intros.
-apply equiv_sym.
-apply STh_distr_right.
-Qed.
-
-End Theory_of_setoid_rings.
-
-Hint Resolve STh_mult_zero_left STh_plus_reg_left: core.
-
-Unset Implicit Arguments.
-
-Definition Semi_Setoid_Ring_Theory_of :
-  Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
-intros until 1; case H.
-split; intros; simpl; eauto.
-Defined.
-
-Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
- Semi_Setoid_Ring_Theory.
-
-
-
-Section product_ring.
-
-End product_ring.
-
-Section power_ring.
-
-End power_ring.
-
-End Setoid_rings.
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
deleted file mode 100644
index f2e904b1..00000000
--- a/plugins/ring/g_ring.ml4
+++ /dev/null
@@ -1,134 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Quote
-open Ring
-open Tacticals
-
-TACTIC EXTEND ring
-| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
-END
-
-(* The vernac commands "Add Ring" and co *)
-
-let cset_of_constrarg_list l =
-  List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
-
-VERNAC COMMAND EXTEND AddRing
-  [ "Add" "Legacy" "Ring"
-          constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory true false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Ring"
-      	  constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
-          constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory false false false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Abstract" "Ring"
-    	  constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aopp) constr(aeq) constr(t) ]
-  -> [ add_theory true true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Abstract" "Semi" "Ring"
-          constr(a) constr(aplus) constr(amult) constr(aone)
-          constr(azero) constr(aeq) constr(t) ]
-  -> [ add_theory false true false
-			 (constr_of a)
-			 None
-			 None
-			 None
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 ConstrSet.empty ]
-
-| [ "Add" "Legacy" "Setoid" "Ring"
-      	  constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult)
-	  constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
-	  constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory true false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = Some (constr_of om) })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 (Some (constr_of aopp))
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-
-| [ "Add" "Legacy" "Semi" "Setoid" "Ring"
-          constr(a) constr(aequiv) constr(asetth) constr(aplus)
-	  constr(amult) constr(aone) constr(azero) constr(aeq)
-          constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ]
-  -> [ add_theory false false true
-			 (constr_of a)
-			 (Some (constr_of aequiv))
-			 (Some (constr_of asetth))
-			 (Some {
-			    plusm = (constr_of pm);
-			    multm = (constr_of mm);
-			    oppm = None })
-			 (constr_of aplus)
-			 (constr_of amult)
-			 (constr_of aone)
-			 (constr_of azero)
-			 None
-			 (constr_of aeq)
-			 (constr_of t)
-			 (cset_of_constrarg_list l) ]
-END
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
deleted file mode 100644
index db88a05c..00000000
--- a/plugins/ring/ring.ml
+++ /dev/null
@@ -1,928 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* ML part of the Ring tactic *)
-
-open Pp
-open Util
-open Flags
-open Term
-open Names
-open Libnames
-open Nameops
-open Reductionops
-open Tacticals
-open Tacexpr
-open Tacmach
-open Printer
-open Equality
-open Vernacinterp
-open Vernacexpr
-open Libobject
-open Closure
-open Tacred
-open Tactics
-open Pattern
-open Hiddentac
-open Nametab
-open Quote
-open Mod_subst
-
-let mt_evd = Evd.empty
-let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
-
-let ring_dir = ["Coq";"ring"]
-let setoids_dir = ["Coq";"Setoids"]
-
-let ring_constant = Coqlib.gen_constant_in_modules "Ring"
-  [ring_dir@["LegacyRing_theory"];
-   ring_dir@["Setoid_ring_theory"];
-   ring_dir@["Ring_normalize"];
-   ring_dir@["Ring_abstract"];
-   setoids_dir@["Setoid"];
-   ring_dir@["Setoid_ring_normalize"]]
-
-(* Ring theory *)
-let coq_Ring_Theory = lazy (ring_constant "Ring_Theory")
-let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory")
-
-(* Setoid ring theory *)
-let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory")
-let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory")
-
-(* Ring normalize *)
-let coq_SPplus = lazy (ring_constant "SPplus")
-let coq_SPmult = lazy (ring_constant "SPmult")
-let coq_SPvar = lazy (ring_constant "SPvar")
-let coq_SPconst = lazy (ring_constant "SPconst")
-let coq_Pplus = lazy (ring_constant "Pplus")
-let coq_Pmult = lazy (ring_constant "Pmult")
-let coq_Pvar = lazy (ring_constant "Pvar")
-let coq_Pconst = lazy (ring_constant "Pconst")
-let coq_Popp = lazy (ring_constant "Popp")
-let coq_interp_sp = lazy (ring_constant "interp_sp")
-let coq_interp_p = lazy (ring_constant "interp_p")
-let coq_interp_cs = lazy (ring_constant "interp_cs")
-let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify")
-let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify")
-let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok")
-let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok")
-
-(* Setoid theory *)
-let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory")
-
-let coq_seq_refl = lazy(ring_constant "Seq_refl")
-let coq_seq_sym = lazy(ring_constant "Seq_sym")
-let coq_seq_trans = lazy(ring_constant "Seq_trans")
-
-(* Setoid Ring normalize *)
-let coq_SetSPplus = lazy (ring_constant "SetSPplus")
-let coq_SetSPmult = lazy (ring_constant "SetSPmult")
-let coq_SetSPvar = lazy (ring_constant "SetSPvar")
-let coq_SetSPconst = lazy (ring_constant "SetSPconst")
-let coq_SetPplus = lazy (ring_constant "SetPplus")
-let coq_SetPmult = lazy (ring_constant "SetPmult")
-let coq_SetPvar = lazy (ring_constant "SetPvar")
-let coq_SetPconst = lazy (ring_constant "SetPconst")
-let coq_SetPopp = lazy (ring_constant "SetPopp")
-let coq_interp_setsp = lazy (ring_constant "interp_setsp")
-let coq_interp_setp = lazy (ring_constant "interp_setp")
-let coq_interp_setcs = lazy (ring_constant "interp_setcs")
-let coq_setspolynomial_simplify =
-  lazy (ring_constant "setspolynomial_simplify")
-let coq_setpolynomial_simplify =
-  lazy (ring_constant "setpolynomial_simplify")
-let coq_setspolynomial_simplify_ok =
-  lazy (ring_constant "setspolynomial_simplify_ok")
-let coq_setpolynomial_simplify_ok =
-  lazy (ring_constant "setpolynomial_simplify_ok")
-
-(* Ring abstract *)
-let coq_ASPplus = lazy (ring_constant "ASPplus")
-let coq_ASPmult = lazy (ring_constant "ASPmult")
-let coq_ASPvar = lazy (ring_constant "ASPvar")
-let coq_ASP0 = lazy (ring_constant "ASP0")
-let coq_ASP1 = lazy (ring_constant "ASP1")
-let coq_APplus = lazy (ring_constant "APplus")
-let coq_APmult = lazy (ring_constant "APmult")
-let coq_APvar = lazy (ring_constant "APvar")
-let coq_AP0 = lazy (ring_constant "AP0")
-let coq_AP1 = lazy (ring_constant "AP1")
-let coq_APopp = lazy (ring_constant "APopp")
-let coq_interp_asp = lazy (ring_constant "interp_asp")
-let coq_interp_ap = lazy (ring_constant "interp_ap")
-let coq_interp_acs = lazy (ring_constant "interp_acs")
-let coq_interp_sacs = lazy (ring_constant "interp_sacs")
-let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
-let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
-let coq_aspolynomial_normalize_ok =
-  lazy (ring_constant "aspolynomial_normalize_ok")
-let coq_apolynomial_normalize_ok =
-  lazy (ring_constant "apolynomial_normalize_ok")
-
-(* Logic --> to be found in Coqlib *)
-open Coqlib
-
-let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
-
-(*********** Useful types and functions ************)
-
-module OperSet =
-  Set.Make (struct
-	      type t = global_reference
-	      let compare = (RefOrdered.compare : t->t->int)
-	    end)
-
-type morph =
-    { plusm : constr;
-      multm : constr;
-      oppm : constr option;
-    }
-
-type theory =
-    { th_ring : bool;                  (* false for a semi-ring *)
-      th_abstract : bool;
-      th_setoid : bool;                (* true for a setoid ring *)
-      th_equiv : constr option;
-      th_setoid_th : constr option;
-      th_morph : morph option;
-      th_a : constr;                   (* e.g. nat *)
-      th_plus : constr;
-      th_mult : constr;
-      th_one : constr;
-      th_zero : constr;
-      th_opp : constr option;          (* None if semi-ring *)
-      th_eq : constr;
-      th_t : constr;                   (* e.g. NatTheory *)
-      th_closed : ConstrSet.t;         (* e.g. [S; O] *)
-                                       (* Must be empty for an abstract ring *)
-    }
-
-(* Theories are stored in a table which is synchronised with the Reset
-   mechanism. *)
-
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
-
-let theories_map = ref Cmap.empty
-
-let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
-let theories_map_find c = Cmap.find c !theories_map
-let theories_map_mem c = Cmap.mem c !theories_map
-
-let _ =
-  Summary.declare_summary "tactic-ring-table"
-    { Summary.freeze_function = (fun () -> !theories_map);
-      Summary.unfreeze_function = (fun t -> theories_map := t);
-      Summary.init_function = (fun () -> theories_map := Cmap.empty) }
-
-(* declare a new type of object in the environment, "tactic-ring-theory"
-   The functions theory_to_obj and obj_to_theory do the conversions
-   between theories and environement objects. *)
-
-
-let subst_morph subst morph =
-  let plusm' = subst_mps subst morph.plusm in
-  let multm' = subst_mps subst morph.multm in
-  let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
-    if plusm' == morph.plusm
-      && multm' == morph.multm
-      && oppm' == morph.oppm then
-	morph
-    else
-      { plusm = plusm' ;
-	multm = multm' ;
-	oppm = oppm' ;
-      }
-
-let subst_set subst cset =
-  let same = ref true in
-  let copy_subst c newset =
-    let c' = subst_mps subst c in
-      if not (c' == c) then same := false;
-      ConstrSet.add c' newset
-  in
-  let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
-    if !same then cset else cset'
-
-let subst_theory subst th =
-  let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in
-  let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in
-  let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in
-  let th_a' = subst_mps subst th.th_a in
-  let th_plus' = subst_mps subst th.th_plus in
-  let th_mult' = subst_mps subst th.th_mult in
-  let th_one' = subst_mps subst th.th_one in
-  let th_zero' = subst_mps subst th.th_zero in
-  let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in
-  let th_eq' = subst_mps subst th.th_eq in
-  let th_t' = subst_mps subst th.th_t in
-  let th_closed' = subst_set subst th.th_closed in
-    if th_equiv' == th.th_equiv
-      && th_setoid_th' == th.th_setoid_th
-      && th_morph' == th.th_morph
-      && th_a' == th.th_a
-      && th_plus' == th.th_plus
-      && th_mult' == th.th_mult
-      && th_one' == th.th_one
-      && th_zero' == th.th_zero
-      && th_opp' == th.th_opp
-      && th_eq' == th.th_eq
-      && th_t' == th.th_t
-      && th_closed' == th.th_closed
-    then
-      th
-    else
-    { th_ring = th.th_ring ;
-      th_abstract = th.th_abstract ;
-      th_setoid = th.th_setoid ;
-      th_equiv = th_equiv' ;
-      th_setoid_th = th_setoid_th' ;
-      th_morph = th_morph' ;
-      th_a = th_a' ;
-      th_plus = th_plus' ;
-      th_mult = th_mult' ;
-      th_one = th_one' ;
-      th_zero = th_zero' ;
-      th_opp = th_opp' ;
-      th_eq = th_eq' ;
-      th_t = th_t' ;
-      th_closed = th_closed' ;
-    }
-
-
-let subst_th (subst,(c,th as obj)) =
-  let c' = subst_mps subst c in
-  let th' = subst_theory subst th in
-    if c' == c && th' == th then obj else
-      (c',th')
-
-
-let theory_to_obj : constr * theory -> obj =
-  let cache_th (_,(c, th)) = theories_map_add (c,th) in
-  declare_object {(default_object "tactic-ring-theory") with
-		    open_function = (fun i o -> if i=1 then cache_th o);
-                    cache_function = cache_th;
-		    subst_function = subst_th;
-		    classify_function = (fun x -> Substitute x) }
-
-(* from the set A, guess the associated theory *)
-(* With this simple solution, the theory to use is automatically guessed *)
-(* But only one theory can be declared for a given Set *)
-
-let guess_theory a =
-  try
-    theories_map_find a
-  with Not_found ->
-    errorlabstrm "Ring"
-      (str "No Declared Ring Theory for " ++
-	 pr_lconstr a ++ fnl () ++
-	 str "Use Add [Semi] Ring to declare it")
-
-(* Looks up an option *)
-
-let unbox = function
-  | Some w -> w
-  | None -> anomaly "Ring : Not in case of a setoid ring."
-
-(* Protects the convertibility test against undue exceptions when using it
-   with untyped terms *)
-
-let safe_pf_conv_x gl c1 c2 =
-  try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false
-
-
-(* Add a Ring or a Semi-Ring to the database after a type verification *)
-
-let implement_theory env t th args =
-  is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
-
-(* (\* The following test checks whether the provided morphism is the default *)
-(*    one for the given operation. In principle the test is too strict, since *)
-(*    it should possible to provide another proof for the same fact (proof *)
-(*    irrelevance). In particular, the error message is be not very explicative. *\) *)
-let states_compatibility_for env plus mult opp morphs =
- let check op compat = true in
-(*   is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *)
-(*    compat in *)
- check plus morphs.plusm &&
- check mult morphs.multm &&
- (match (opp,morphs.oppm) with
-     None, None -> true
-   | Some opp, Some compat -> check opp compat
-   | _,_ -> assert false)
-
-let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset =
-  if theories_map_mem a then errorlabstrm "Add Semi Ring"
-    (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
-       pr_lconstr a);
-  let env = Global.env () in
-    if (want_ring & want_setoid & (
-	not (implement_theory env t coq_Setoid_Ring_Theory
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])
-        ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))
-        )) then
-      errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
-    if (not want_ring & want_setoid & (
-        not (implement_theory env t coq_Semi_Setoid_Ring_Theory
-	  [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
-	not (implement_theory env (unbox asetth) coq_Setoid_Theory
-	  [| a; (unbox aequiv) |]) ||
-        not (states_compatibility_for env aplus amult aopp (unbox amorph))))
-    then
-      errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory");
-    if (want_ring & not want_setoid &
-	not (implement_theory env t coq_Ring_Theory
-	  [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then
-      errorlabstrm "addring" (str "Not a valid Ring theory");
-    if (not want_ring & not want_setoid &
-	not (implement_theory env t coq_Semi_Ring_Theory
-	  [| a; aplus; amult; aone; azero; aeq |])) then
-      errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
-    Lib.add_anonymous_leaf
-      (theory_to_obj
-	 (a, { th_ring = want_ring;
-	       th_abstract = want_abstract;
-	       th_setoid = want_setoid;
-	       th_equiv = aequiv;
-	       th_setoid_th = asetth;
-	       th_morph = amorph;
-	       th_a = a;
-	       th_plus = aplus;
-	       th_mult = amult;
-	       th_one = aone;
-	       th_zero = azero;
-	       th_opp = aopp;
-	       th_eq = aeq;
-	       th_t = t;
-	       th_closed = cset }))
-
-(******** The tactic itself *********)
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-module Constrhash = Hashtbl.Make
-  (struct type t = constr
-	  let equal = eq_constr
-	  let hash = hash_constr
-   end)
-
-let build_spolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the spolynom p by a recursive destructuration of c
-     and builds the varmap with side-effects *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SPconst, [|th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map
-    (fun p ->
-       (mkLApp (coq_interp_sp,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp (coq_interp_cs,
-               [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp (coq_spolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       th.th_eq; p|])) |]),
-	mkLApp (coq_spolynomial_simplify_ok,
-	        [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_polynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-            (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
-	    mkLApp(coq_Pplus,
-                  [|th.th_a; aux c1;
-	            mkLApp(coq_Popp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_Popp, [|th.th_a; aux c1|])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_Pconst, [|th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_p,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                 (unbox th.th_opp); v; p |])),
-	mkLApp(coq_interp_cs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_polynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_polynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi-ring theory (abstract)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_aspolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  (* aux creates the aspolynom p by a recursive destructuration of c
-     and builds the varmap with side-effects *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_asp,
-               [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; v; p |]),
-	mkLApp(coq_interp_acs,
-               [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
-	mkLApp(coq_spolynomial_simplify_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : ring theory (abstract)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_apolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_APplus, [| aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_APmult, [| aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-            (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
-	    mkLApp(coq_APplus,
-                   [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_APopp, [| aux c1 |])
-      | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
-      | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_APvar, [| path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_ap,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one;
-		  th.th_zero; (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_sacs,
-	       [| th.th_a; th.th_plus; th.th_mult;
-		  th.th_one; th.th_zero; (unbox th.th_opp); v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
-	mkLApp(coq_apolynomial_normalize_ok,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
-		  (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setpolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
-      (* The special case of Z.sub *)
-      | App (binop, [|c1; c2|])
-	  when safe_pf_conv_x gl c
-	    (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
-	      mkLApp(coq_SetPplus,
-                     [| th.th_a; aux c1;
-			mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |])
-      | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
-	  mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetPconst, [| th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_setp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
-                  (unbox th.th_opp); v; p |]),
-	mkLApp(coq_interp_setcs,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_setpolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       (unbox th.th_opp); th.th_eq; p |])) |]),
-	mkLApp(coq_setpolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp);
-                  th.th_eq; (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm; (unbox th.th_morph).multm;
-		  (unbox (unbox th.th_morph).oppm); v; th.th_t; p |])))
-    lp
-
-(*
-   gl : goal sigma
-   th : semi setoid ring theory (concrete)
-   cl : constr list [c1; c2; ...]
-
-Builds
-   - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
-  where c'i is convertible with ci and
-  c'i_eq_c''i is a proof of equality of c'i and c''i
-
-*)
-
-let build_setspolynom gl th lc =
-  let varhash  = (Constrhash.create 17 : constr Constrhash.t) in
-  let varlist = ref ([] : constr list) in (* list of variables *)
-  let counter = ref 1 in (* number of variables created + 1 *)
-  let rec aux c =
-    match (kind_of_term (strip_outer_cast c)) with
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
-	  mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
-      | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
-	  mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
-      | _ when closed_under th.th_closed c ->
-	  mkLApp(coq_SetSPconst, [| th.th_a; c |])
-      | _ ->
-	  try Constrhash.find varhash c
-	  with Not_found ->
-	    let newvar =
-              mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
-	    begin
-	      incr counter;
-	      varlist := c :: !varlist;
-	      Constrhash.add varhash c newvar;
-	      newvar
-	    end
-  in
-  let lp = List.map aux lc in
-  let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
-  List.map
-    (fun p ->
-       (mkLApp(coq_interp_setsp,
-	       [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
-	mkLApp(coq_interp_setcs,
-               [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
-		  pf_reduce cbv_betadeltaiota gl
-		    (mkLApp(coq_setspolynomial_simplify,
-			    [| th.th_a; th.th_plus; th.th_mult;
-			       th.th_one; th.th_zero;
-			       th.th_eq; p |])) |]),
-	mkLApp(coq_setspolynomial_simplify_ok,
-	       [| th.th_a; (unbox th.th_equiv); th.th_plus;
-                  th.th_mult; th.th_one; th.th_zero; th.th_eq;
-                  (unbox th.th_setoid_th);
-		  (unbox th.th_morph).plusm;
-                  (unbox th.th_morph).multm; v; th.th_t; p |])))
-    lp
-
-module SectionPathSet =
-  Set.Make(struct
-	     type t = full_path
-	     let compare = Pervasives.compare
-	   end)
-
-(* Avec l'uniformisation des red_kind, on perd ici sur la structure
-   SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
-let constants_to_unfold =
-(*  List.fold_right SectionPathSet.add *)
-  let transform s =
-    let sp = path_of_string s in
-    let dir, id = repr_path sp in
-      Libnames.encode_con dir id
-  in
-  List.map transform
-    [ "Coq.ring.Ring_normalize.interp_cs";
-      "Coq.ring.Ring_normalize.interp_var";
-      "Coq.ring.Ring_normalize.interp_vl";
-      "Coq.ring.Ring_abstract.interp_acs";
-      "Coq.ring.Ring_abstract.interp_sacs";
-      "Coq.quote.Quote.varmap_find";
-      (* anciennement des Local devenus Definition *)
-      "Coq.ring.Ring_normalize.ics_aux";
-      "Coq.ring.Ring_normalize.ivl_aux";
-      "Coq.ring.Ring_normalize.interp_m";
-      "Coq.ring.Ring_abstract.iacs_aux";
-      "Coq.ring.Ring_abstract.isacs_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_cs";
-      "Coq.ring.Setoid_ring_normalize.interp_var";
-      "Coq.ring.Setoid_ring_normalize.interp_vl";
-      "Coq.ring.Setoid_ring_normalize.ics_aux";
-      "Coq.ring.Setoid_ring_normalize.ivl_aux";
-      "Coq.ring.Setoid_ring_normalize.interp_m";
-    ]
-(*    SectionPathSet.empty *)
-
-(* Unfolds the functions interp and find_btree in the term c of goal gl *)
-open RedFlags
-let polynom_unfold_tac =
-  let flags =
-    (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
-  reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
-
-let polynom_unfold_tac_in_term gl =
-  let flags =
-    (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
-  in
-  cbv_norm_flags flags (pf_env gl) (project gl)
-
-(* lc : constr list *)
-(* th : theory associated to t *)
-(* op : clause (None for conclusion or Some id for hypothesis id) *)
-(* gl : goal  *)
-(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i))
-   where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
-   are guessed and such that c_i = (interp R RC v p_i) *)
-let raw_polynom th op lc gl =
-  (* first we sort the terms : if t' is a subterm of t it must appear
-     after t in the list. This is to avoid that the normalization of t'
-     modifies t in a non-desired way *)
-  let lc = sort_subterm gl lc in
-  let ltriplets =
-    if th.th_setoid then
-      if th.th_ring
-      then build_setpolynom gl th lc
-      else build_setspolynom gl th lc
-    else
-      if th.th_ring then
-	if th.th_abstract
-	then build_apolynom gl th lc
-	else build_polynom gl th lc
-      else
-	if th.th_abstract
-	then build_aspolynom gl th lc
-	else build_spolynom gl th lc in
-  let polynom_tac =
-    List.fold_right2
-      (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
-         let c'''i =
-	   if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i
-	 in
-         if !term_quality && safe_pf_conv_x gl c'''i ci then
-	   tac (* convertible terms *)
-         else if th.th_setoid
-	 then
-           (tclORELSE
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkLApp(coq_seq_sym,
-				  [| th.th_a; (unbox th.th_equiv);
-                                     (unbox th.th_setoid_th);
-				     c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS
-		 (tclORELSE
-                   (Equality.general_rewrite true
-		     Termops.all_occurrences true false c'i_eq_c''i)
-                   (Equality.general_rewrite false
-		     Termops.all_occurrences true false c'i_eq_c''i))
-                 [tac]))
-	 else
-           (tclORELSE
-              (tclORELSE
-		 (h_exact c'i_eq_c''i)
-		 (h_exact (mkApp(build_coq_eq_sym (),
-				 [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
-	      (tclTHENS
-		 (elim_type
-		    (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
-		 [ tac;
-                   h_exact c'i_eq_c''i ]))
-)
-      lc ltriplets polynom_unfold_tac
-  in
-  polynom_tac gl
-
-let guess_eq_tac th =
-  (tclORELSE reflexivity
-     (tclTHEN
-	polynom_unfold_tac
-        (tclTHEN
-	   (* Normalized sums associate on the right *)
-	   (tclREPEAT
-	      (tclTHENFIRST
-		 (apply (mkApp(build_coq_f_equal2 (),
-		               [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity))
-	   (tclTRY
-	      (tclTHENLAST
-		 (apply (mkApp(build_coq_f_equal2 (),
-			       [| th.th_a; th.th_a; th.th_a;
-				  th.th_plus |])))
-		 reflexivity)))))
-
-let guess_equiv_tac th =
-  (tclORELSE (apply (mkLApp(coq_seq_refl,
-			    [| th.th_a; (unbox th.th_equiv);
-			       (unbox th.th_setoid_th)|])))
-     (tclTHEN
-	polynom_unfold_tac
-	(tclREPEAT
-	   (tclORELSE
-	      (apply (unbox th.th_morph).plusm)
-	      (apply (unbox th.th_morph).multm)))))
-
-let match_with_equiv c = match (kind_of_term c) with
-  | App (e,a) ->
-      if (List.mem e []) (*  (Setoid_replace.equiv_list ())) *)
-      then Some (decompose_app c)
-      else None
-  | _ -> None
-
-let polynom lc gl =
-  Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
-  match lc with
-   (* If no argument is given, try to recognize either an equality or
-      a declared relation with arguments c1 ... cn,
-      do "Ring c1 c2 ... cn" and then try to apply the simplification
-      theorems declared for the relation *)
-    | [] ->
-	(try
-	  match Hipattern.match_with_equation (pf_concl gl) with
-	   | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) ->
-	       let th = guess_theory t in
-	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
-	   | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2)
-	       when safe_pf_conv_x gl t1 t2 ->
-	       let th = guess_theory t1 in
-	       (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
-	   | _ -> raise Exit
-	  with Hipattern.NoEquationFound | Exit ->
-	          (match match_with_equiv (pf_concl gl) with
-		     | Some (equiv, c1::args) ->
-			 let t = (pf_type_of gl c1) in
-			 let th = (guess_theory t) in
-			   if List.exists
-			     (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
-			   then
-			     errorlabstrm "Ring :"
-			       (str" All terms must have the same type");
-			   (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl
-		     | _ -> errorlabstrm "polynom :"
-			 (str" This goal is not an equality nor a setoid equivalence")))
-    (* Elsewhere, guess the theory, check that all terms have the same type
-       and apply raw_polynom *)
-    | c :: lc' ->
-	let t = pf_type_of gl c in
-	let th = guess_theory t in
-	  if List.exists
-	    (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
-	  then
-	    errorlabstrm "Ring :"
-	      (str" All terms must have the same type");
-	  (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib
deleted file mode 100644
index 3c5f995f..00000000
--- a/plugins/ring/ring_plugin.mllib
+++ /dev/null
@@ -1,3 +0,0 @@
-Ring
-G_ring
-Ring_plugin_mod
diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget
deleted file mode 100644
index da387be8..00000000
--- a/plugins/ring/vo.itarget
+++ /dev/null
@@ -1,10 +0,0 @@
-LegacyArithRing.vo
-LegacyNArithRing.vo
-LegacyRing_theory.vo
-LegacyRing.vo
-LegacyZArithRing.vo
-Ring_abstract.vo
-Ring_normalize.vo
-Setoid_ring_normalize.vo
-Setoid_ring_theory.vo
-Setoid_ring.vo
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index ab424c22..b84cf254 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -980,9 +980,9 @@ Inductive p_step : Set :=
   | P_STEP : step -> p_step
   | P_NOP : p_step.
 
-(* List of normalizations to perform : with a constructor of type
-   [p_step] allowing to visit both left and right branches, we would be
-   able to restrict to only one normalization by hypothesis.
+(* List of normalizations to perform : if the type [p_step] had a constructor
+   that indicated visiting both left and right branches, we would be able to
+   restrict ourselves to the case of only one normalization by hypothesis.
    And since all hypothesis are useful (otherwise they wouldn't be included),
    we would be able to replace [h_step] by a simple list. *)
 
@@ -990,7 +990,7 @@ Inductive h_step : Set :=
     pair_step : nat -> p_step -> h_step.
 
 (* \subsubsection{Rules for decomposing the hypothesis} *)
-(* This type allows to navigate in the logical constructors that
+(* This type allows navigation in the logical constructors that
    form the predicats of the hypothesis in order to decompose them.
    This allows in particular to extract one hypothesis from a
    conjunction with possibly the right level of negations. *)
@@ -1000,7 +1000,7 @@ Inductive direction : Set :=
   | D_right : direction
   | D_mono : direction.
 
-(* This type allows to extract useful components from hypothesis, either
+(* This type allows extracting useful components from hypothesis, either
    hypothesis generated by splitting a disjonction, or equations.
    The last constructor indicates how to solve the obtained system
    via the use of the trace type of Omega [t_omega] *)
@@ -1014,7 +1014,7 @@ Inductive e_step : Set :=
 (* For each reified data-type, we define an efficient equality test.
    It is not the one produced by [Decide Equality].
 
-   Then we prove two theorem allowing to eliminate such equalities :
+   Then we prove two theorem allowing elimination of such equalities :
    \begin{verbatim}
    (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
    (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
@@ -1284,7 +1284,7 @@ Qed.
 
 (* Extraire une hypothèse de la liste *)
 Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
-
+Unset Printing Notations.
 Theorem nth_valid :
  forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
  interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index fb45e816..21b0f78b 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -1,7 +1,7 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
@@ -19,27 +19,27 @@ let meaningful_submodule = [ "Z"; "N"; "Pos" ]
 
 let string_of_global r =
   let dp = Nametab.dirpath_of_global r in
-  let prefix = match Names.repr_dirpath dp with
+  let prefix = match Names.DirPath.repr dp with
     | [] -> ""
     | m::_ ->
-      let s = Names.string_of_id m in
-      if List.mem s meaningful_submodule then s^"." else ""
+      let s = Names.Id.to_string m in
+      if Util.String.List.mem s meaningful_submodule then s^"." else ""
   in
-  prefix^(Names.string_of_id (Nametab.basename_of_global r))
+  prefix^(Names.Id.to_string (Nametab.basename_of_global r))
 
 let destructurate t =
   let c, args = Term.decompose_app t in
   match Term.kind_of_term c, args with
-    | Term.Const sp, args ->
-	Kapp (string_of_global (Libnames.ConstRef sp), args)
-    | Term.Construct csp , args ->
-	Kapp (string_of_global (Libnames.ConstructRef csp), args)
-    | Term.Ind isp, args ->
-	Kapp (string_of_global (Libnames.IndRef isp), args)
-    | Term.Var id,[] -> Kvar(Names.string_of_id id)
+    | Term.Const (sp,_), args ->
+	Kapp (string_of_global (Globnames.ConstRef sp), args)
+    | Term.Construct (csp,_) , args ->
+	Kapp (string_of_global (Globnames.ConstructRef csp), args)
+    | Term.Ind (isp,_), args ->
+	Kapp (string_of_global (Globnames.IndRef isp), args)
+    | Term.Var id,[] -> Kvar(Names.Id.to_string id)
     | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
     | Term.Prod (Names.Name _,_,_),[] ->
-	Util.error "Omega: Not a quantifier-free goal"
+	Errors.error "Omega: Not a quantifier-free goal"
     | _ -> Kufo
 
 exception Destruct
@@ -48,9 +48,9 @@ let dest_const_apply t =
   let f,args = Term.decompose_app t in
   let ref =
   match Term.kind_of_term f with
-    | Term.Const sp      -> Libnames.ConstRef sp
-    | Term.Construct csp -> Libnames.ConstructRef csp
-    | Term.Ind isp       -> Libnames.IndRef isp
+    | Term.Const (sp,_)      -> Globnames.ConstRef sp
+    | Term.Construct (csp,_) -> Globnames.ConstructRef csp
+    | Term.Ind (isp,_)       -> Globnames.IndRef isp
     | _ -> raise Destruct
   in  Nametab.basename_of_global ref, args
 
@@ -71,7 +71,6 @@ let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module
 let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module
 
 (* Logic *)
-let coq_eq = lazy(init_constant  "eq")
 let coq_refl_equal = lazy(init_constant  "eq_refl")
 let coq_and = lazy(init_constant "and")
 let coq_not = lazy(init_constant "not")
@@ -211,19 +210,31 @@ let rec mk_nat = function
 
 (* Lists *)
 
-let coq_cons =  lazy (constant "cons")
-let coq_nil =  lazy (constant "nil")
+let mkListConst c = 
+  let r = 
+    Coqlib.gen_reference "" ["Init";"Datatypes"] c
+  in 
+  let inst = 
+    if Global.is_polymorphic r then fun u -> Univ.Instance.of_array [|u|]
+    else fun _ -> Univ.Instance.empty
+  in
+    fun u -> Term.mkConstructU (Globnames.destConstructRef r, inst u)
+
+let coq_cons univ typ = Term.mkApp (mkListConst "cons" univ, [|typ|])
+let coq_nil univ typ =  Term.mkApp (mkListConst "nil" univ, [|typ|])
 
-let mk_list typ l =
+let mk_list univ typ l =
   let rec loop = function
-    | [] ->
-	Term.mkApp (Lazy.force coq_nil, [|typ|])
+    | [] -> coq_nil univ typ
     | (step :: l) ->
-	Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
+	Term.mkApp (coq_cons univ typ, [| step; loop l |]) in
   loop l
 
-let mk_plist l = mk_list Term.mkProp l
+let mk_plist = 
+  let type1lev = Universes.new_univ_level (Global.current_dirpath ()) in
+    fun l -> mk_list type1lev Term.mkProp l
 
+let mk_list = mk_list Univ.Level.set
 let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
 
 
@@ -297,13 +308,13 @@ let coq_Zneg = lazy (bin_constant "Zneg")
 let recognize t =
   let rec loop t =
     let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
+    match Names.Id.to_string f,l with
        "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
      | "xO",[t] -> Bigint.mult Bigint.two (loop t)
      | "xH",[] -> Bigint.one
      | _ -> failwith "not a number" in
   let f,l = dest_const_apply t in
-    match Names.string_of_id f,l with
+    match Names.Id.to_string f,l with
         "Zpos",[t] -> loop t
       | "Zneg",[t] -> Bigint.neg (loop t)
       | "Z0",[] -> Bigint.zero
@@ -353,7 +364,7 @@ let parse_rel gl t =
 
 let is_scalar t =
   let rec aux t = match destructurate t with
-    | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2
+    | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2
     | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
     | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
     | _ -> false in
diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli
index b8db71e4..af50ea0f 100644
--- a/plugins/romega/const_omega.mli
+++ b/plugins/romega/const_omega.mli
@@ -1,7 +1,7 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
@@ -117,6 +117,7 @@ val do_seq : Term.constr -> Term.constr -> Term.constr
 val do_list : Term.constr list -> Term.constr
 
 val mk_nat : int -> Term.constr
+(** Precondition: the type of the list is in Set *)
 val mk_list : Term.constr -> Term.constr list -> Term.constr
 val mk_plist : Term.types list -> Term.types
 val mk_shuffle_list : Term.constr list -> Term.constr
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 2db86e00..0a99a26b 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -1,15 +1,16 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "romega_plugin"
 
 open Refl_omega
-open Refiner
 
 let romega_tactic l =
   let tacs = List.map
@@ -18,17 +19,17 @@ let romega_tactic l =
        | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
        | "N" -> Tacinterp.interp <:tactic<zify_N>>
        | "Z" -> Tacinterp.interp <:tactic<zify_op>>
-       | s -> Util.error ("No ROmega knowledge base for type "^s))
-    (Util.list_uniquize (List.sort compare l))
+       | s -> Errors.error ("No ROmega knowledge base for type "^s))
+    (Util.List.sort_uniquize String.compare l)
   in
-  tclTHEN
-    (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
-    (tclTHEN
+  Tacticals.New.tclTHEN
+    (Tacticals.New.tclREPEAT (Proofview.tclPROGRESS (Tacticals.New.tclTHENLIST tacs)))
+    (Tacticals.New.tclTHEN
        (* because of the contradiction process in (r)omega,
           we'd better leave as little as possible in the conclusion,
           for an easier decidability argument. *)
-       Tactics.intros
-       total_reflexive_omega_tactic)
+       (Tactics.intros)
+       (Proofview.V82.tactic total_reflexive_omega_tactic))
 
 
 TACTIC EXTEND romega
@@ -37,6 +38,6 @@ END
 
 TACTIC EXTEND romega'
 | [ "romega" "with" ne_ident_list(l) ] ->
-    [ romega_tactic (List.map Names.string_of_id l) ]
+    [ romega_tactic (List.map Names.Id.to_string l) ]
 | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ]
 END
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index e57230cb..8156e841 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -1,11 +1,12 @@
 (*************************************************************************
 
    PROJET RNRT Calife - 2001
-   Author: Pierre Crégut - France Télécom R&D
+   Author: Pierre Crégut - France Télécom R&D
    Licence : LGPL version 2.1
 
  *************************************************************************)
 
+open Pp
 open Util
 open Const_omega
 module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
@@ -16,7 +17,7 @@ open OmegaSolver
 let debug = ref false
 
 let show_goal gl =
-  if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl
+  if !debug then (); Tacticals.tclIDTAC gl
 
 let pp i = print_int i; print_newline (); flush stdout
 
@@ -37,9 +38,13 @@ type direction = Left of int | Right of int
 type occ_step = O_left | O_right | O_mono
 type occ_path = occ_step list
 
-(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
-   d'une liste de pas à partir de la racine de l'hypothèse *)
-type occurence = {o_hyp : Names.identifier; o_path : occ_path}
+let occ_step_eq s1 s2 = match s1, s2 with
+| O_left, O_left | O_right, O_right | O_mono, O_mono -> true
+| _ -> false
+
+(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
+   d'une liste de pas à partir de la racine de l'hypothèse *)
+type occurence = {o_hyp : Names.Id.t; o_path : occ_path}
 
 (* \subsection{refiable formulas} *)
 type oformula =
@@ -58,7 +63,7 @@ type oformula =
 (* Operators for comparison recognized by Omega *)
 type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
 
-(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
+(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
  * quantifications sont externes au langage) *)
 type oproposition =
     Pequa of Term.constr * oequation
@@ -70,19 +75,19 @@ type oproposition =
   | Pimp of int * oproposition * oproposition
   | Pprop of Term.constr
 
-(* Les équations ou proposiitions atomiques utiles du calcul *)
+(* Les équations ou proposiitions atomiques utiles du calcul *)
 and oequation = {
     e_comp: comparaison;		(* comparaison *)
     e_left: oformula;			(* formule brute gauche *)
     e_right: oformula;			(* formule brute droite *)
     e_trace: Term.constr;		(* tactique de normalisation *)
-    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
-    e_negated: bool;			(* vrai si apparait en position nié
-					   après normalisation *)
+    e_origin: occurence;		(* l'hypothèse dont vient le terme *)
+    e_negated: bool;			(* vrai si apparait en position nié
+					   après normalisation *)
     e_depends: direction  list;		(* liste des points de disjonction dont
-					   dépend l'accès à l'équation avec la
-					   direction (branche) pour y accéder *)
-    e_omega: afine		(* la fonction normalisée *)
+					   dépend l'accès à l'équation avec la
+					   direction (branche) pour y accéder *)
+    e_omega: afine		(* la fonction normalisée *)
   }
 
 (* \subsection{Proof context}
@@ -101,8 +106,8 @@ type environment = {
   mutable props : Term.constr list;
   (* Les variables introduites par omega *)
   mutable om_vars : (oformula * int) list;
-  (* Traduction des indices utilisés ici en les indices finaux utilisés par
-   * la tactique Omega après dénombrement des variables utiles *)
+  (* Traduction des indices utilisés ici en les indices finaux utilisés par
+   * la tactique Omega après dénombrement des variables utiles *)
   real_indices : (int,int) Hashtbl.t;
   mutable cnt_connectors : int;
   equations : (int,oequation) Hashtbl.t;
@@ -110,35 +115,35 @@ type environment = {
 }
 
 (* \subsection{Solution tree}
-   Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
-   d'un ensemble d'équation dont dépend la solution et d'une trace *)
-(* La liste des dépendances est triée et sans redondance *)
+   Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
+   d'un ensemble d'équation dont dépend la solution et d'une trace *)
+(* La liste des dépendances est triée et sans redondance *)
 type solution = {
   s_index : int;
   s_equa_deps : int list;
   s_trace : action list }
 
-(* Arbre de solution résolvant complètement un ensemble de systèmes *)
+(* Arbre de solution résolvant complètement un ensemble de systèmes *)
 type solution_tree =
     Leaf of solution
-    (* un noeud interne représente un point de branchement correspondant à
-       l'élimination d'un connecteur générant plusieurs buts
+    (* un noeud interne représente un point de branchement correspondant à
+       l'élimination d'un connecteur générant plusieurs buts
        (typ. disjonction). Le premier argument
        est l'identifiant du connecteur *)
   | Tree of int * solution_tree * solution_tree
 
-(* Représentation de l'environnement extrait du but initial sous forme de
-   chemins pour extraire des equations ou d'hypothèses *)
+(* Représentation de l'environnement extrait du but initial sous forme de
+   chemins pour extraire des equations ou d'hypothèses *)
 
 type context_content =
     CCHyp of occurence
   | CCEqua of int
 
 (* \section{Specific utility functions to handle base types} *)
-(* Nom arbitraire de l'hypothèse codant la négation du but final *)
-let id_concl = Names.id_of_string "__goal__"
+(* Nom arbitraire de l'hypothèse codant la négation du but final *)
+let id_concl = Names.Id.of_string "__goal__"
 
-(* Initialisation de l'environnement de réification de la tactique *)
+(* Initialisation de l'environnement de réification de la tactique *)
 let new_environment () = {
   terms = []; props = []; om_vars = []; cnt_connectors = 0;
   real_indices = Hashtbl.create 7;
@@ -146,29 +151,28 @@ let new_environment () = {
   constructors = Hashtbl.create 7;
 }
 
-(* Génération d'un nom d'équation *)
+(* Génération d'un nom d'équation *)
 let new_connector_id env =
    env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
 
-(* Calcul de la branche complémentaire *)
+(* Calcul de la branche complémentaire *)
 let barre = function Left x -> Right x | Right x -> Left x
 
-(* Identifiant associé à une branche *)
+(* Identifiant associé à une branche *)
 let indice = function Left x | Right x -> x
 
-(* Affichage de l'environnement de réification (termes et propositions) *)
+(* Affichage de l'environnement de réification (termes et propositions) *)
 let print_env_reification env =
   let rec loop c i = function
-      [] -> Printf.printf "  ===============================\n\n"
+      [] ->  str "  ===============================\n\n"
     | t :: l ->
-	Printf.printf "  (%c%02d) := " c i;
-	Pp.ppnl (Printer.pr_lconstr t);
-	Pp.flush_all ();
-	loop c (succ i) l in
-  print_newline ();
-  Printf.printf "  ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
-  Printf.printf "  ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms
-
+      let s = Printf.sprintf "(%c%02d)" c i in
+      spc () ++ str s ++ str " := " ++ Printer.pr_lconstr t ++ fnl () ++
+      loop c (succ i) l
+  in
+  let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in
+  let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in
+  msg_debug (prop_info ++ fnl () ++ term_info)
 
 (* \subsection{Gestion des environnements de variable pour Omega} *)
 (* generation d'identifiant d'equation pour Omega *)
@@ -185,75 +189,73 @@ let new_omega_var, rst_omega_var =
   (function () -> incr cpt; !cpt),
   (function () -> cpt:=0)
 
-(* Affichage des variables d'un système *)
+(* Affichage des variables d'un système *)
 
 let display_omega_var i = Printf.sprintf "OV%d" i
 
-(* Recherche la variable codant un terme pour Omega et crée la variable dans
-   l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
+(* Recherche la variable codant un terme pour Omega et crée la variable dans
+   l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
    le terme d'un monome (le plus souvent un atome) *)
 
 let intern_omega env t =
-  begin try List.assoc t env.om_vars
+  begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *)
   with Not_found ->
     let v = new_omega_var () in
     env.om_vars <- (t,v) :: env.om_vars; v
   end
 
-(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
-   variable est créée par Omega et où il faut la lier après coup à un atome
-   réifié introduit de force *)
+(* Ajout forcé d'un lien entre un terme et une variable  Cas où la
+   variable est créée par Omega et où il faut la lier après coup à un atome
+   réifié introduit de force *)
 let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
 
-(* Récupère le terme associé à une variable *)
+(* Récupère le terme associé à une variable *)
 let unintern_omega env id =
   let rec loop = function
 	[] -> failwith "unintern"
-      | ((t,j)::l) -> if id = j then t else loop l in
+      | ((t,j)::l) -> if Int.equal id j then t else loop l in
   loop env.om_vars
 
-(* \subsection{Gestion des environnements de variable pour la réflexion}
+(* \subsection{Gestion des environnements de variable pour la réflexion}
    Gestion des environnements de traduction entre termes des constructions
-   non réifiés et variables des termes reifies. Attention il s'agit de
-   l'environnement initial contenant tout. Il faudra le réduire après
+   non réifiés et variables des termes reifies. Attention il s'agit de
+   l'environnement initial contenant tout. Il faudra le réduire après
    calcul des variables utiles. *)
 
 let add_reified_atom t env =
-  try list_index0_f Term.eq_constr t env.terms
+  try List.index0 Term.eq_constr t env.terms
   with Not_found ->
     let i = List.length env.terms in
     env.terms <- env.terms @ [t]; i
 
 let get_reified_atom env =
-  try List.nth env.terms
-  with e when Errors.noncritical e -> failwith "get_reified_atom"
+  try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom"
 
 (* \subsection{Gestion de l'environnement de proposition pour Omega} *)
 (* ajout d'une proposition *)
 let add_prop env t =
-  try list_index0_f Term.eq_constr t env.props
+  try List.index0 Term.eq_constr t env.props
   with Not_found ->
     let i = List.length env.props in  env.props <- env.props @ [t]; i
 
-(* accès a une proposition *)
+(* accès a une proposition *)
 let get_prop v env =
-  try List.nth v env
-  with e when Errors.noncritical e -> failwith "get_prop"
+  try List.nth v env with Invalid_argument _ -> failwith "get_prop"
 
-(* \subsection{Gestion du nommage des équations} *)
+(* \subsection{Gestion du nommage des équations} *)
 (* Ajout d'une equation dans l'environnement de reification *)
 let add_equation env e =
   let id = e.e_omega.id in
   try let _ = Hashtbl.find env.equations id in ()
   with Not_found -> Hashtbl.add env.equations id e
 
-(* accès a une equation *)
+(* accès a une equation *)
 let get_equation env id =
   try Hashtbl.find env.equations id
   with Not_found as e ->
-    Printf.printf "Omega Equation %d non trouvée\n" id; raise e
+    Printf.printf "Omega Equation %d non trouvée\n" id; raise e
 
-(* Affichage des termes réifiés *)
+(* Affichage des termes réifiés *)
 let rec oprint ch = function
   | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
   | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2
@@ -287,7 +289,7 @@ let rec weight env = function
   | Oufo _ -> -1
   | Oatom _ as c -> (intern_omega env c)
 
-(* \section{Passage entre oformules et représentation interne de Omega} *)
+(* \section{Passage entre oformules et représentation interne de Omega} *)
 
 (* \subsection{Oformula vers Omega} *)
 
@@ -305,7 +307,7 @@ let omega_of_oformula env kind =
 
 (* \subsection{Omega vers Oformula} *)
 
-let rec oformula_of_omega env af =
+let oformula_of_omega env af =
   let rec loop = function
     | ({v=v; c=n}::r) ->
 	Oplus(Omult(unintern_omega env v,Oint n),loop r)
@@ -316,7 +318,7 @@ let app f v = mkApp(Lazy.force f,v)
 
 (* \subsection{Oformula vers COQ reel} *)
 
-let rec coq_of_formula env t =
+let coq_of_formula env t =
   let rec loop = function
   | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |]
   | Oopp t -> app Z.opp [| loop t |]
@@ -330,12 +332,12 @@ let rec coq_of_formula env t =
   | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in
   loop t
 
-(* \subsection{Oformula vers COQ reifié} *)
+(* \subsection{Oformula vers COQ reifié} *)
 
 let reified_of_atom env i =
   try Hashtbl.find env.real_indices i
   with Not_found ->
-    Printf.printf "Atome %d non trouvé\n" i;
+    Printf.printf "Atome %d non trouvé\n" i;
     Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
     raise Not_found
 
@@ -388,7 +390,7 @@ let reified_of_proposition env f =
   try reified_of_proposition env f
   with reraise -> pprint stderr f; raise reraise
 
-(* \subsection{Omega vers COQ réifié} *)
+(* \subsection{Omega vers COQ réifié} *)
 
 let reified_of_omega env body constant =
   let coeff_constant =
@@ -402,21 +404,18 @@ let reified_of_omega env body constant =
   List.fold_right mk_coeff body coeff_constant
 
 let reified_of_omega env body c  =
-  try
-    reified_of_omega env body c
-  with reraise ->
-    display_eq display_omega_var (body,c); raise reraise
+  try reified_of_omega env body c
+  with reraise -> display_eq display_omega_var (body,c); raise reraise
 
+(* \section{Opérations sur les équations}
+Ces fonctions préparent les traces utilisées par la tactique réfléchie
+pour faire des opérations de normalisation sur les équations.  *)
 
-(* \section{Opérations sur les équations}
-Ces fonctions préparent les traces utilisées par la tactique réfléchie
-pour faire des opérations de normalisation sur les équations.  *)
+(* \subsection{Extractions des variables d'une équation} *)
+(* Extraction des variables d'une équation. *)
+(* Chaque fonction retourne une liste triée sans redondance *)
 
-(* \subsection{Extractions des variables d'une équation} *)
-(* Extraction des variables d'une équation. *)
-(* Chaque fonction retourne une liste triée sans redondance *)
-
-let (@@) = list_merge_uniq compare
+let (@@) = List.merge_uniq compare
 
 let rec vars_of_formula = function
   | Oint _ -> []
@@ -455,7 +454,7 @@ let rec scalar n = function
  | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
  | Omult(t1,t2) ->
-     Util.error "Omega: Can't solve a goal with non-linear products"
+     Errors.error "Omega: Can't solve a goal with non-linear products"
  | (Oatom _ as t) -> do_list [], Omult(t,Oint n)
  | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
  | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
@@ -474,23 +473,23 @@ let rec negate = function
  | Omult(t1,Oint x) ->
      do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
  | Omult(t1,t2) ->
-     Util.error "Omega: Can't solve a goal with non-linear products"
+     Errors.error "Omega: Can't solve a goal with non-linear products"
  | (Oatom _ as t) ->
      do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
  | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
  | Oufo c -> do_list [], Oufo (Oopp c)
  | Ominus _ -> failwith "negate minus"
 
-let rec norm l = (List.length l)
+let norm l = (List.length l)
 
-(* \subsection{Mélange (fusion) de deux équations} *)
+(* \subsection{Mélange (fusion) de deux équations} *)
 (* \subsubsection{Version avec coefficients} *)
-let rec shuffle_path k1 e1 k2 e2 =
+let shuffle_path k1 e1 k2 e2 =
   let rec loop = function
       (({c=c1;v=v1}::l1) as l1'),
       (({c=c2;v=v2}::l2) as l2') ->
-	if v1 = v2 then
-          if k1*c1 + k2 * c2 = zero then (
+	if Int.equal v1 v2 then
+          if Bigint.equal (k1 * c1 + k2 * c2) zero then (
             Lazy.force coq_f_cancel :: loop (l1,l2))
           else (
             Lazy.force coq_f_equal :: loop (l1,l2) )
@@ -532,7 +531,7 @@ let rec shuffle env (t1,t2) =
 	do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
       else do_list [],Oplus(t1,t2)
 
-(* \subsection{Fusion avec réduction} *)
+(* \subsection{Fusion avec réduction} *)
 
 let shrink_pair f1 f2 =
   begin match f1,f2 with
@@ -546,7 +545,7 @@ let shrink_pair f1 f2 =
        Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
    | t1,t2 ->
        oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
-       flush Pervasives.stdout; Util.error "shrink.1"
+       flush Pervasives.stdout; Errors.error "shrink.1"
   end
 
 (* \subsection{Calcul d'une sous formule constante} *)
@@ -560,15 +559,15 @@ let reduce_factor = function
       let rec compute = function
           Oint n -> n
 	| Oplus(t1,t2) -> compute t1 + compute t2
-	| _ -> Util.error "condense.1" in
+	| _ -> Errors.error "condense.1" in
 	[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
-  | t -> Util.error "reduce_factor.1"
+  | t -> Errors.error "reduce_factor.1"
 
-(* \subsection{Réordonnancement} *)
+(* \subsection{Réordonnancement} *)
 
 let rec condense env = function
     Oplus(f1,(Oplus(f2,r) as t)) ->
-      if weight env f1 = weight env f2 then begin
+      if Int.equal (weight env f1) (weight env f2) then begin
 	let shrink_tac,t = shrink_pair f1 f2 in
 	let assoc_tac = Lazy.force coq_c_plus_assoc_l in
 	let tac_list,t' = condense env (Oplus(t,r)) in
@@ -582,7 +581,7 @@ let rec condense env = function
       let tac,f1' = reduce_factor f1 in
       [do_left (do_list tac)],Oplus(f1',Oint n)
   | Oplus(f1,f2) ->
-      if weight env f1 = weight env f2 then begin
+      if Int.equal (weight env f1) (weight env f2) then begin
 	let tac_shrink,t = shrink_pair f1 f2 in
 	let tac,t' = condense env t in
 	tac_shrink :: tac,t'
@@ -597,18 +596,18 @@ let rec condense env = function
       let final = Oplus(t',Oint zero) in
       tac @ [Lazy.force coq_c_red6], final
 
-(* \subsection{Elimination des zéros} *)
+(* \subsection{Elimination des zéros} *)
 
 let rec clear_zero = function
-   Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
+   Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal n zero ->
      let tac',t = clear_zero r in
      Lazy.force coq_c_red5 :: tac',t
   | Oplus(f,r) ->
       let tac,t = clear_zero r in
-      (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
+      (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t)
   | t -> [],t;;
 
-(* \subsection{Transformation des hypothèses} *)
+(* \subsection{Transformation des hypothèses} *)
 
 let rec reduce env = function
     Oplus(t1,t2) ->
@@ -643,7 +642,7 @@ let normalize_linear_term env t =
   let trace3,t3 = clear_zero t2 in
   do_list [trace1; do_list trace2; do_list trace3], t3
 
-(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
+(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
 let negate_oper = function
     Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
 
@@ -669,7 +668,7 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
 	  INEQ
   with e when Logic.catchable_exception e -> raise e
 
-(* \section{Compilation des hypothèses} *)
+(* \section{Compilation des hypothèses} *)
 
 let rec oformula_of_constr env t =
   match Z.parse_term t with
@@ -698,7 +697,7 @@ and binprop env (neg2,depends,origin,path)
     oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
   let t2' =
     oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
-  (* On numérote le connecteur dans l'environnement. *)
+  (* On numérote le connecteur dans l'environnement. *)
   c i t1' t2'
 
 and mk_equation env ctxt c connector t1 t2 =
@@ -737,7 +736,7 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
 	  (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
     | _ -> Pprop c
 
-(* Destructuration des hypothèses et de la conclusion *)
+(* Destructuration des hypothèses et de la conclusion *)
 
 let reify_gl env gl =
   let concl = Tacmach.pf_concl gl in
@@ -751,7 +750,7 @@ let reify_gl env gl =
       (i,t) :: lhyps ->
 	let t' = oproposition_of_constr env (false,[],i,[]) gl t in
 	if !debug then begin
-	  Printf.printf "  %s: " (Names.string_of_id i);
+	  Printf.printf "  %s: " (Names.Id.to_string i);
 	  pprint stdout t';
 	  Printf.printf "\n"
 	end;
@@ -816,13 +815,13 @@ let destructurate_hyps syst =
       (i,t) :: l ->
 	let l_syst1 = destructurate_pos_hyp i []  [] t in
 	let l_syst2 = loop l in
-	list_cartesian (@) l_syst1 l_syst2
+	List.cartesian (@) l_syst1 l_syst2
     | [] -> [[]] in
   loop syst
 
-(* \subsection{Affichage d'un système d'équation} *)
+(* \subsection{Affichage d'un système d'équation} *)
 
-(* Affichage des dépendances de système *)
+(* Affichage des dépendances de système *)
 let display_depend = function
     Left i -> Printf.printf " L%d" i
   | Right i -> Printf.printf " R%d" i
@@ -845,7 +844,7 @@ let display_systems syst_list =
 	 (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
 	    oformula_eq.e_origin.o_path));
     Printf.printf "\n  Origin: %s (negated : %s)\n\n"
-      (Names.string_of_id oformula_eq.e_origin.o_hyp)
+      (Names.Id.to_string oformula_eq.e_origin.o_hyp)
       (if oformula_eq.e_negated then "yes" else "no") in
 
   let display_system syst =
@@ -853,8 +852,8 @@ let display_systems syst_list =
     List.iter display_equation syst in
   List.iter display_system syst_list
 
-(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
-   calcul des hypothèses *)
+(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
+   calcul des hypothèses *)
 
 let rec hyps_used_in_trace = function
   | act :: l ->
@@ -866,9 +865,9 @@ let rec hyps_used_in_trace = function
       end
   | [] -> []
 
-(* Extraction des variables déclarées dans une équation. Permet ensuite
-   de les déclarer dans l'environnement de la procédure réflexive et
-   éviter les créations de variable au vol *)
+(* Extraction des variables déclarées dans une équation. Permet ensuite
+   de les déclarer dans l'environnement de la procédure réflexive et
+   éviter les créations de variable au vol *)
 
 let rec variable_stated_in_trace = function
   | act :: l ->
@@ -886,7 +885,7 @@ let rec variable_stated_in_trace = function
 
 let add_stated_equations env tree =
   (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
-     de définir dans le mauvais ordre *)
+     de définir dans le mauvais ordre *)
   let stated_equations =
     let cmpvar x y = Pervasives.(-) x.st_var y.st_var in
     let rec loop = function
@@ -895,15 +894,15 @@ let add_stated_equations env tree =
     in loop tree
   in
   let add_env st =
-    (* On retransforme la définition de v en formule reifiée *)
+    (* On retransforme la définition de v en formule reifiée *)
     let v_def = oformula_of_omega env st.st_def in
-    (* Notez que si l'ordre de création des variables n'est pas respecté,
+    (* Notez que si l'ordre de création des variables n'est pas respecté,
      * ca va planter *)
     let coq_v = coq_of_formula env v_def in
     let v = add_reified_atom coq_v env in
     (* Le terme qu'il va falloir introduire *)
     let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in
-    (* sa représentation sous forme d'équation mais non réifié car on n'a pas
+    (* sa représentation sous forme d'équation mais non réifié car on n'a pas
      * l'environnement pour le faire correctement *)
     let term_to_reify = (v_def,Oatom v) in
     (* enregistre le lien entre la variable omega et la variable Coq *)
@@ -911,18 +910,18 @@ let add_stated_equations env tree =
     (v, term_to_generalize,term_to_reify,st.st_def.id) in
  List.map add_env stated_equations
 
-(* Calcule la liste des éclatements à réaliser sur les hypothèses
-   nécessaires pour extraire une liste d'équations donnée *)
+(* Calcule la liste des éclatements à réaliser sur les hypothèses
+   nécessaires pour extraire une liste d'équations donnée *)
 
 (* PL: experimentally, the result order of the following function seems
    _very_ crucial for efficiency. No idea why. Do not remove the List.rev
-   or modify the current semantics of Util.list_union (some elements of first
+   or modify the current semantics of Util.List.union (some elements of first
    arg, then second arg), unless you know what you're doing. *)
 
 let rec get_eclatement env = function
     i :: r ->
       let l = try (get_equation env i).e_depends with Not_found -> [] in
-      list_union (List.rev l) (get_eclatement env r)
+      List.union Pervasives.(=) (List.rev l) (get_eclatement env r)
   | [] -> []
 
 let select_smaller l =
@@ -933,10 +932,14 @@ let filter_compatible_systems required systems =
   let rec select = function
       (x::l) ->
 	if List.mem x required then select l
-	else if List.mem (barre x) required then failwith "Exit"
+	else if List.mem (barre x) required then raise Exit
 	else x :: select l
-    | [] -> [] in
-  map_succeed (function (sol,splits) -> (sol,select splits)) systems
+    | [] -> []
+  in
+  List.map_filter
+    (function (sol, splits) ->
+      try Some (sol, select splits) with Exit -> None)
+    systems
 
 let rec equas_of_solution_tree = function
     Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2)
@@ -955,7 +958,7 @@ let really_useful_prop l_equa c =
     | Pnot t1 -> app coq_not [|real_of t1|]
     | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|]
     | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|]
-    (* Attention : implications sur le lifting des variables à comprendre ! *)
+    (* Attention : implications sur le lifting des variables à comprendre ! *)
     | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
     | Pprop t -> t in
   let rec loop c =
@@ -1015,10 +1018,10 @@ let rec solve_with_constraints all_solutions path =
 let find_path {o_hyp=id;o_path=p} env =
   let rec loop_path = function
       ([],l) -> Some l
-    | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
+    | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2)
     | _ -> None in
   let rec loop_id i = function
-      CCHyp{o_hyp=id';o_path=p'} :: l when id = id' ->
+      CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' ->
 	begin match loop_path (p',p) with
 	  Some r -> i,r
 	| None -> loop_id (succ i) l
@@ -1036,7 +1039,7 @@ let mk_direction_list l =
 (* \section{Rejouer l'historique} *)
 
 let get_hyp env_hyp i =
-  try list_index0 (CCEqua i) env_hyp
+  try List.index0 Pervasives.(=) (CCEqua i) env_hyp
   with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
 
 let replay_history env env_hyp =
@@ -1163,11 +1166,11 @@ and decompose_tree_hyps trace env ctxt = function
 
 (* \section{La fonction principale} *)
  (* Cette fonction construit la
-trace pour la procédure de décision réflexive.  A partir des résultats
-de l'extraction des systèmes, elle lance la résolution par Omega, puis
+trace pour la procédure de décision réflexive.  A partir des résultats
+de l'extraction des systèmes, elle lance la résolution par Omega, puis
 l'extraction d'un ensemble minimal de solutions permettant la
-résolution globale du système et enfin construit la trace qui permet
-de faire rejouer cette solution par la tactique réflexive. *)
+résolution globale du système et enfin construit la trace qui permet
+de faire rejouer cette solution par la tactique réflexive. *)
 
 let resolution env full_reified_goal systems_list =
   let num = ref 0 in
@@ -1178,7 +1181,7 @@ let resolution env full_reified_goal systems_list =
       simplify_strong
 	(new_omega_eq,new_omega_var,display_omega_var)
 	system in
-    (* calcule les hypotheses utilisées pour la solution *)
+    (* calcule les hypotheses utilisées pour la solution *)
     let vars = hyps_used_in_trace trace in
     let splits = get_eclatement env vars in
     if !debug then begin
@@ -1199,17 +1202,21 @@ let resolution env full_reified_goal systems_list =
     display_solution_tree stdout solution_tree;
     print_newline()
   end;
-  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
+  (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
   let useful_equa_id = equas_of_solution_tree solution_tree in
   (* recupere explicitement ces equations *)
   let equations = List.map (get_equation env) useful_equa_id in
-  let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
-  let l_hyps = id_concl :: list_remove id_concl l_hyps' in
+  let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
+  let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in
   let useful_hyps =
-    List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
+    List.map
+      (fun id -> List.assoc_f Names.Id.equal id full_reified_goal) l_hyps
+  in
   let useful_vars =
     let really_useful_vars = vars_of_equations equations in
-    let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in
+    let concl_vars =
+      vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal)
+    in
     really_useful_vars @@ concl_vars
   in
   (* variables a introduire *)
@@ -1218,8 +1225,8 @@ let resolution env full_reified_goal systems_list =
   let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in
   let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in
   (* L'environnement de base se construit en deux morceaux :
-     - les variables des équations utiles (et de la conclusion)
-     - les nouvelles variables declarées durant les preuves *)
+     - les variables des équations utiles (et de la conclusion)
+     - les nouvelles variables declarées durant les preuves *)
   let all_vars_env = useful_vars @ stated_vars in
   let basic_env =
     let rec loop i = function
@@ -1229,7 +1236,7 @@ let resolution env full_reified_goal systems_list =
       |	[] -> [] in
     loop 0 all_vars_env in
   let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in
-  (* On peut maintenant généraliser le but : env est a jour *)
+  (* On peut maintenant généraliser le but : env est a jour *)
   let l_reified_stated =
      List.map (fun (_,_,(l,r),_) ->
                  app coq_p_eq [| reified_of_formula env l;
@@ -1258,10 +1265,10 @@ let resolution env full_reified_goal systems_list =
       |	((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
       |	(O_right :: l) -> app coq_p_right [| loop l |] in
     let correct_index =
-      let i = list_index0 e.e_origin.o_hyp l_hyps in
+      let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in
       (* PL: it seems that additionnally introduced hyps are in the way during
              normalization, hence this index shifting... *)
-      if i=0 then 0 else Pervasives.(+) i (List.length to_introduce)
+      if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce)
     in
     app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in
   let normalization_trace =
@@ -1275,8 +1282,8 @@ let resolution env full_reified_goal systems_list =
 
   Tactics.generalize
     (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
-  Tactics.change_in_concl None reified >>
-  Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
+  Proofview.V82.of_tactic (Tactics.change_concl reified) >>
+  Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >>
   show_goal >>
   Tactics.normalise_vm_in_concl >>
   (*i Alternatives to the previous line:
@@ -1285,7 +1292,7 @@ let resolution env full_reified_goal systems_list =
    - Skip the conversion check and rely directly on the QED:
       Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >>
   i*)
-  Tactics.apply (Lazy.force coq_I)
+  Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I))
 
 let total_reflexive_omega_tactic gl =
   Coqlib.check_required_library ["Coq";"romega";"ROmega"];
@@ -1297,7 +1304,7 @@ let total_reflexive_omega_tactic gl =
   let systems_list = destructurate_hyps full_reified_goal in
   if !debug then display_systems systems_list;
   resolution env full_reified_goal systems_list gl
-  with NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
+  with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system"
 
 
 (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index fbfa1bfd..267cd472 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -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        *)
@@ -198,7 +198,7 @@ Theorem get_Full_Gt : forall S, Full S ->
 Proof.
 intros S W;induction W.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
+unfold index,get,push. simpl @contents.
 intros i e;rewrite Tget_Tadd.
 rewrite (Gt_Psucc _ _ e).
 unfold get in IHW.
@@ -209,7 +209,7 @@ Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
 intros [index0 contents0] F.
 case F.
 unfold empty,index,get,contents;intros;apply Tget_Tempty.
-unfold index,get,push;simpl contents.
+unfold push,index,get;simpl @contents.
 intros a S.
 rewrite Tget_Tadd.
 rewrite Psucc_Gt.
@@ -231,12 +231,12 @@ Proof.
 intros i a S F.
 case_eq (i ?= index S).
 intro e;rewrite (Pos.compare_eq _ _ e).
-destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
+destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd.
 rewrite Pos.compare_refl;reflexivity.
-intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
-simpl index in H;rewrite H;reflexivity.
+intros;destruct S;unfold get,push,index;simpl @contents;rewrite Tget_Tadd.
+simpl @index in H;rewrite H;reflexivity.
 intro H;generalize H;clear H.
-unfold get,push;simpl index;simpl contents.
+unfold get,push;simpl.
 rewrite Tget_Tadd;intro e;rewrite e.
 change (get i S=PNone).
 apply get_Full_Gt;auto.
@@ -260,7 +260,7 @@ Qed.
 Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
 intros [ind cont] F one; inversion F.
 reflexivity.
-simpl index in one;assert (h:=Pos.succ_not_1 (index S)).
+simpl @index in one;assert (h:=Pos.succ_not_1 (index S)).
 congruence.
 Qed.
 
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index f823cf74..61a160b2 100644
--- a/plugins/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -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/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index 4de2638b..7fefab3e 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -1,14 +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 camlp4deps: "parsing/grammar.cma"  i*)
+(*i camlp4deps: "grammar/grammar.cma"  i*)
+
+DECLARE PLUGIN "rtauto_plugin"
 
 TACTIC EXTEND rtauto
-  [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
+  [ "rtauto" ] -> [ Proofview.V82.tactic (Refl_tauto.rtauto_tac) ]
 END
 
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 2ace38bd..23510117 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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 Term
+open Errors
 open Util
 open Goptions
 
@@ -62,20 +62,35 @@ type form=
   | Conjunct of form * form
   | Disjunct of form * form
 
-type tag=int
-
-let decomp_form=function
-    Atom i -> Some (i,[])
-  | Arrow (f1,f2) -> Some (-1,[f1;f2])
-  | Bot -> Some (-2,[])
-  | Conjunct (f1,f2) -> Some (-3,[f1;f2])
-  | Disjunct (f1,f2) -> Some (-4,[f1;f2])
-
-module Fmap=Map.Make(struct type t=form let compare=compare end)
+module FOrd = struct
+  type t = form
+  let rec compare x y =
+    match x, y with
+    | Bot, Bot -> 0
+    | Bot, _ -> -1
+    | Atom _, Bot -> 1
+    | Atom a1, Atom a2 -> Int.compare a1 a2
+    | Atom _, _ -> -1
+    | Arrow _, (Bot | Atom _) -> 1
+    | Arrow (f1, g1), Arrow (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+    | Arrow _, _ -> -1
+    | Conjunct _, (Bot | Atom _ | Arrow _) -> 1
+    | Conjunct (f1, g1), Conjunct (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+    | Conjunct _, _ -> -1
+    | Disjunct _, (Bot | Atom _ | Arrow _ | Conjunct _) -> 1
+    | Disjunct (f1, g1), Disjunct (f2, g2) ->
+        let cmp = compare f1 f2 in
+        if cmp = 0 then compare g1 g2 else cmp
+end
+module Fmap = Map.Make(FOrd)
 
 type sequent =
-    {rev_hyps: form Intmap.t;
-     norev_hyps: form Intmap.t;
+    {rev_hyps: form Int.Map.t;
+     norev_hyps: form Int.Map.t;
      size:int;
      left:int Fmap.t;
      right:(int*form) list Fmap.t;
@@ -131,21 +146,21 @@ let add_step s sub =
     | SI_Or_r,[p] -> I_Or_r p
     | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
     | SD_Or i,[p] -> D_Or(i,p)
-    | _,_ -> anomaly "add_step: wrong arity"
+    | _,_ -> anomaly ~label:"add_step" (Pp.str "wrong arity")
 
 type 'a with_deps =
     {dep_it:'a;
      dep_goal:bool;
-     dep_hyps:Intset.t}
+     dep_hyps:Int.Set.t}
 
 type slice=
     {proofs_done:proof list;
      proofs_todo:sequent with_deps list;
      step:rule;
      needs_goal:bool;
-     needs_hyps:Intset.t;
+     needs_hyps:Int.Set.t;
      changes_goal:bool;
-     creates_hyps:Intset.t}
+     creates_hyps:Int.Set.t}
 
 type state =
     Complete of proof
@@ -153,7 +168,7 @@ type state =
 
 let project = function
     Complete prf -> prf
-  | Incomplete (_,_) -> anomaly "not a successful state"
+  | Incomplete (_,_) -> anomaly (Pp.str "not a successful state")
 
 let pop n prf =
   let nprf=
@@ -168,27 +183,27 @@ let rec fill stack proof =
     | slice::super ->
 	if
 	  !pruning &&
-	  slice.proofs_done=[] &&
+	  List.is_empty slice.proofs_done &&
 	  not (slice.changes_goal && proof.dep_goal) &&
-	  not (Intset.exists
-		 (fun i -> Intset.mem i proof.dep_hyps)
+	  not (Int.Set.exists
+		 (fun i -> Int.Set.mem i proof.dep_hyps)
 		 slice.creates_hyps)
 	then
 	  begin
 	    s_info.pruned_steps<-s_info.pruned_steps+1;
 	    s_info.pruned_branches<- s_info.pruned_branches +
 	    List.length slice.proofs_todo;
-	    let created_here=Intset.cardinal slice.creates_hyps in
+	    let created_here=Int.Set.cardinal slice.creates_hyps in
 	      s_info.pruned_hyps<-s_info.pruned_hyps+
 	      List.fold_left
-		(fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps)
+		(fun sum dseq -> sum + Int.Set.cardinal dseq.dep_hyps)
 		created_here slice.proofs_todo;
-	    fill super (pop (Intset.cardinal slice.creates_hyps) proof)
+	    fill super (pop (Int.Set.cardinal slice.creates_hyps) proof)
 	  end
 	else
 	  let dep_hyps=
-	    Intset.union slice.needs_hyps
-	      (Intset.diff proof.dep_hyps slice.creates_hyps) in
+	    Int.Set.union slice.needs_hyps
+	      (Int.Set.diff proof.dep_hyps slice.creates_hyps) in
 	  let dep_goal=
 	    slice.needs_goal ||
 	    ((not slice.changes_goal) && proof.dep_goal) in
@@ -235,7 +250,7 @@ let append stack (step,subgoals) =
 let embed seq=
   {dep_it=seq;
    dep_goal=false;
-   dep_hyps=Intset.empty}
+   dep_hyps=Int.Set.empty}
 
 let change_goal seq gl=
     {seq with
@@ -270,7 +285,7 @@ let add_hyp seqwd f=
 	     cnx=cnx}
       | Conjunct (_,_) | Disjunct (_,_) ->
 	  {seq with
-	     rev_hyps=Intmap.add num f seq.rev_hyps;
+	     rev_hyps=Int.Map.add num f seq.rev_hyps;
 	     size=num;
 	     left=left;
 	     right=right;
@@ -285,14 +300,14 @@ let add_hyp seqwd f=
 	    match f1 with
 		Conjunct (_,_) | Disjunct (_,_) ->
 		  {seq with
-		     rev_hyps=Intmap.add num f seq.rev_hyps;
+		     rev_hyps=Int.Map.add num f seq.rev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
 		     cnx=ncnx}
 	      | Arrow(_,_) ->
 		  {seq with
-		     norev_hyps=Intmap.add num f seq.norev_hyps;
+		     norev_hyps=Int.Map.add num f seq.norev_hyps;
 		     size=num;
 		     left=left;
 		     right=nright;
@@ -305,13 +320,13 @@ let add_hyp seqwd f=
 		     cnx=ncnx} in
     {seqwd with
        dep_it=nseq;
-       dep_hyps=Intset.add num seqwd.dep_hyps}
+       dep_hyps=Int.Set.add num seqwd.dep_hyps}
 
 exception Here_is of (int*form)
 
 let choose m=
   try
-    Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
+    Int.Map.iter (fun i f -> raise (Here_is (i,f))) m;
     raise Not_found
   with
       Here_is (i,f) -> (i,f)
@@ -322,11 +337,11 @@ let search_or seq=
       Disjunct (f1,f2) ->
 	[{dep_it = SI_Or_l;
 	  dep_goal = true;
-	  dep_hyps = Intset.empty},
+	  dep_hyps = Int.Set.empty},
 	 [change_goal (embed seq) f1];
 	 {dep_it = SI_Or_r;
 	  dep_goal = true;
-	  dep_hyps = Intset.empty},
+	  dep_hyps = Int.Set.empty},
 	 [change_goal (embed seq) f2]]
     | _ -> []
 
@@ -336,19 +351,19 @@ let search_norev seq=
     match f with
 	Arrow (Arrow (f1,f2),f3) ->
 	  let nseq =
-	    {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
+	    {seq with norev_hyps=Int.Map.remove i seq.norev_hyps} in
 	    goals:=
 	      ({dep_it=SD_Arrow(i);
 		dep_goal=false;
-		dep_hyps=Intset.singleton i},
+		dep_hyps=Int.Set.singleton i},
 	       [add_hyp
 		  (add_hyp
 		     (change_goal (embed nseq) f2)
 		     (Arrow(f2,f3)))
 		  f1;
 		add_hyp (embed nseq) f3]):: !goals
-      | _ -> anomaly "search_no_rev: can't happen" in
-    Intmap.iter add_one seq.norev_hyps;
+      | _ -> anomaly ~label:"search_no_rev" (Pp.str "can't happen") in
+    Int.Map.iter add_one seq.norev_hyps;
     List.rev !goals
 
 let search_in_rev_hyps seq=
@@ -357,8 +372,8 @@ let search_in_rev_hyps seq=
     let make_step step=
       {dep_it=step;
        dep_goal=false;
-       dep_hyps=Intset.singleton i} in
-    let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
+       dep_hyps=Int.Set.singleton i} in
+    let nseq={seq with rev_hyps=Int.Map.remove i seq.rev_hyps} in
       match f with
 	  Conjunct (f1,f2) ->
 	    [make_step (SE_And(i)),
@@ -372,7 +387,7 @@ let search_in_rev_hyps seq=
 	| Arrow (Disjunct (f1,f2),f0) ->
 	    [make_step (SD_Or(i)),
 	     [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
-	| _ -> anomaly "search_in_rev_hyps: can't happen"
+	| _ -> anomaly ~label:"search_in_rev_hyps" (Pp.str "can't happen")
   with
       Not_found -> search_norev seq
 
@@ -383,27 +398,27 @@ let search_rev seq=
 	  match f1 with
 	      Conjunct (_,_) | Disjunct (_,_) ->
 		{seq with cnx=next;
-		   rev_hyps=Intmap.remove j seq.rev_hyps}
+		   rev_hyps=Int.Map.remove j seq.rev_hyps}
 	    | Arrow (_,_) ->
 		{seq with cnx=next;
-		   norev_hyps=Intmap.remove j seq.norev_hyps}
+		   norev_hyps=Int.Map.remove j seq.norev_hyps}
 	    | _ ->
 		{seq with cnx=next} in
 	  [{dep_it=SE_Arrow(i,j);
 	    dep_goal=false;
-	    dep_hyps=Intset.add i (Intset.singleton j)},
+	    dep_hyps=Int.Set.add i (Int.Set.singleton j)},
 	   [add_hyp (embed nseq) f2]]
     | [] ->
 	match seq.gl with
 	    Arrow (f1,f2) ->
 	      [{dep_it=SI_Arrow;
 		dep_goal=true;
-		dep_hyps=Intset.empty},
+		dep_hyps=Int.Set.empty},
 	       [add_hyp (change_goal (embed seq) f2) f1]]
 	  | Conjunct (f1,f2) ->
 	      [{dep_it=SI_And;
 		dep_goal=true;
-		dep_hyps=Intset.empty},[change_goal (embed seq) f1;
+		dep_hyps=Int.Set.empty},[change_goal (embed seq) f1;
 					change_goal (embed seq) f2]]
 	  | _ -> search_in_rev_hyps seq
 
@@ -412,18 +427,18 @@ let search_all seq=
       Some i ->
 	[{dep_it=SE_False (i);
 	  dep_goal=false;
-	  dep_hyps=Intset.singleton i},[]]
+	  dep_hyps=Int.Set.singleton i},[]]
     | None ->
 	try
 	  let ax = Fmap.find seq.gl seq.left in
 	    [{dep_it=SAx (ax);
 	      dep_goal=true;
-	      dep_hyps=Intset.singleton ax},[]]
+	      dep_hyps=Int.Set.singleton ax},[]]
 	with Not_found -> search_rev seq
 
 let bare_sequent = embed
-		     {rev_hyps=Intmap.empty;
-		      norev_hyps=Intmap.empty;
+		     {rev_hyps=Int.Map.empty;
+		      norev_hyps=Int.Map.empty;
 		      size=0;
 		      left=Fmap.empty;
 		      right=Fmap.empty;
@@ -442,7 +457,7 @@ let success= function
 
 let branching = function
     Incomplete (seq,stack) ->
-      check_for_interrupt ();
+      Control.check_for_interrupt ();
       let successors = search_all seq in
       let _ =
 	match successors with
@@ -450,7 +465,7 @@ let branching = function
 	  | _::next ->
 	      s_info.nd_branching<-s_info.nd_branching+List.length next in
 	List.map (append stack) successors
-  | Complete prf -> anomaly "already succeeded"
+  | Complete prf -> anomaly (Pp.str "already succeeded")
 
 open Pp
 
@@ -471,11 +486,11 @@ and pp_atom= function
   | Atom n -> int n
   | f -> str "(" ++ hv 2 (pp_form f) ++ str ")"
 
-let pr_form f = msg (pp_form f)
+let pr_form f = pp_form f
 
 let pp_intmap map =
   let pp=ref (str "") in
-   Intmap.iter (fun i obj -> pp:= (!pp ++
+   Int.Map.iter (fun i obj -> pp:= (!pp ++
 		pp_form obj ++ cut ())) map;
     str "{ " ++ v 0 (!pp) ++ str " }"
 
@@ -532,7 +547,7 @@ let pp_info () =
 	int s_info.created_branches ++ str " created" ++ fnl () ++
 	str "Hypotheses : " ++
 	int s_info.created_hyps ++ str " created" ++ fnl () in
-    msgnl
+    msg_info
       ( str "Proof-search statistics :" ++ fnl () ++
 	count_info ++
 	str "Branch ends: " ++
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index 1aaafbe6..86a2fb66 100644
--- a/plugins/rtauto/proof_search.mli
+++ b/plugins/rtauto/proof_search.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        *)
@@ -40,7 +40,7 @@ val success: state -> bool
 
 val pp: state -> Pp.std_ppcmds
 
-val pr_form : form -> unit
+val pr_form : form -> Pp.std_ppcmds
 
 val reset_info : unit -> unit
 
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 7dedb44e..4ffc1f33 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.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,10 +8,9 @@
 
 module Search = Explore.Make(Proof_search)
 
+open Errors
 open Util
 open Term
-open Names
-open Evd
 open Tacmach
 open Proof_search
 
@@ -28,13 +27,6 @@ let li_False = lazy (destInd (logic_constant "False"))
 let li_and = lazy (destInd (logic_constant "and"))
 let li_or =  lazy (destInd (logic_constant "or"))
 
-let data_constant =
-  Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"]
-
-let l_true_equals_true =
-  lazy (mkApp(logic_constant "eq_refl",
-        [|data_constant "bool";data_constant "true"|]))
-
 let pos_constant =
   Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"]
 
@@ -103,7 +95,7 @@ let rec make_form atom_env gls term =
 	Prod(_,a,b) ->
 	  if not (Termops.dependent (mkRel 1) b) &&
 	    Retyping.get_sort_family_of
-	    (pf_env gls) (Tacmach.project gls) a = InProp
+	    (pf_env gls) (Tacmach.project gls) a == InProp
 	  then
 	    let fa=make_form atom_env gls a in
 	    let fb=make_form atom_env gls b in
@@ -112,25 +104,25 @@ let rec make_form atom_env gls term =
 	    make_atom atom_env (normalize term)
       | Cast(a,_,_) ->
 	  make_form atom_env gls a
-      | Ind ind ->
-	  if ind = Lazy.force li_False then
+      | Ind (ind, _) ->
+	  if Names.eq_ind ind (fst (Lazy.force li_False)) then
 	    Bot
 	  else
 	    make_atom atom_env (normalize term)
-      | App(hd,argv) when Array.length argv = 2 ->
+      | App(hd,argv) when Int.equal (Array.length argv) 2 ->
 	  begin
 	    try
-	      let ind = destInd hd in
-		if ind = Lazy.force li_and then
+	      let ind, _ = destInd hd in
+		if Names.eq_ind ind (fst (Lazy.force li_and)) then
 		  let fa=make_form atom_env gls argv.(0) in
 		  let fb=make_form atom_env gls argv.(1) in
 		    Conjunct (fa,fb)
-		else if ind = Lazy.force li_or then
+		else if Names.eq_ind ind (fst (Lazy.force li_or)) then
 		  let fa=make_form atom_env gls argv.(0) in
 		  let fb=make_form atom_env gls argv.(1) in
 		    Disjunct (fa,fb)
 		else make_atom atom_env (normalize term)
-	    with Invalid_argument _ -> make_atom atom_env (normalize term)
+	    with DestKO -> make_atom atom_env (normalize term)
 	  end
       | _ -> make_atom atom_env (normalize term)
 
@@ -143,7 +135,7 @@ let rec make_hyps atom_env gls lenv = function
 	make_hyps atom_env gls (typ::lenv) rest in
 	if List.exists (Termops.dependent (mkVar id)) lenv ||
 	  (Retyping.get_sort_family_of
-	     (pf_env gls) (Tacmach.project gls) typ <> InProp)
+	     (pf_env gls) (Tacmach.project gls) typ != InProp)
 	then
 	  hrec
 	else
@@ -151,7 +143,7 @@ let rec make_hyps atom_env gls lenv = function
 
 let rec build_pos n =
   if n<=1 then force node_count l_xH
-  else if n land 1 = 0 then
+  else if Int.equal (n land 1) 0 then
     mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
   else
     mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
@@ -269,22 +261,21 @@ let rtauto_tac gls=
   let gl=pf_concl gls in
   let _=
     if Retyping.get_sort_family_of
-      (pf_env gls) (Tacmach.project gls) gl <> InProp
+      (pf_env gls) (Tacmach.project gls) gl != InProp
     then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
   let glf=make_form gamma gls gl in
   let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in
   let formula=
     List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
-  let search_fun =
-    if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
-      Search.debug_depth_first
-    else
-      Search.depth_first in
+  let search_fun = match Tacinterp.get_debug() with
+  | Tactic_debug.DebugOn 0 -> Search.debug_depth_first
+  | _ -> Search.depth_first
+  in
   let _ =
     begin
       reset_info ();
       if !verbose then
-	msgnl (str "Starting proof-search ...");
+	msg_info (str "Starting proof-search ...");
     end in
   let search_start_time = System.get_time () in
   let prf =
@@ -294,10 +285,10 @@ let rtauto_tac gls=
   let search_end_time = System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof tree found in " ++
+      msg_info (str "Proof tree found in " ++
 	     System.fmt_time_difference search_start_time search_end_time);
       pp_info ();
-      msgnl (str "Building proof term ... ")
+      msg_info (str "Building proof term ... ")
     end in
   let build_start_time=System.get_time () in
   let _ = step_count := 0; node_count := 0 in
@@ -306,11 +297,11 @@ let rtauto_tac gls=
 		      build_form formula;
 		      build_proof [] 0 prf|]) in
   let term=
-    Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
+    applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
   let build_end_time=System.get_time () in
   let _ = if !verbose then
     begin
-      msgnl (str "Proof term built in " ++
+      msg_info (str "Proof term built in " ++
 	     System.fmt_time_difference build_start_time build_end_time ++
 	     fnl () ++
 	     str "Proof size : " ++ int !step_count ++
@@ -322,14 +313,14 @@ let rtauto_tac gls=
   let tac_start_time = System.get_time () in
   let result=
     if !check then
-      Tactics.exact_check term gls
+      Proofview.V82.of_tactic (Tactics.exact_check term) gls
     else
       Tactics.exact_no_check term gls in
   let tac_end_time = System.get_time () in
   let _ =
-    if !check then msgnl (str "Proof term type-checking is on");
+    if !check then msg_info (str "Proof term type-checking is on");
     if !verbose then
-      msgnl (str "Internal tactic executed in " ++
+      msg_info (str "Internal tactic executed in " ++
 	     System.fmt_time_difference tac_start_time tac_end_time) in
     result
 
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index 9f7db593..45fb50dc 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.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        *)
@@ -18,7 +18,7 @@ val make_hyps :
     atom_env ->
     Proof_type.goal Tacmach.sigma ->
     Term.types list ->
-    (Names.identifier * Term.types option * Term.types) list ->
-    (Names.identifier * Proof_search.form) list
+    (Names.Id.t * Term.types option * Term.types) list ->
+    (Names.Id.t * Proof_search.form) list
 
 val rtauto_tac : Proof_type.tactic
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 92e61583..e7d0cd8e 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -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/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 22448fd7..5dd1b86d 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -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/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
index f13f509a..4872c776 100644
--- a/plugins/setoid_ring/Cring.v
+++ b/plugins/setoid_ring/Cring.v
@@ -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        *)
@@ -21,6 +21,7 @@ Require Export Ncring_tac.
 Class Cring {R:Type}`{Rr:Ring R} := 
  cring_mul_comm: forall x y:R, x * y == y * x.
 
+
 Ltac reify_goal lvar lexpr lterm:=
   (*idtac lvar; idtac lexpr; idtac lterm;*)
   match lexpr with
@@ -30,10 +31,10 @@ Ltac reify_goal lvar lexpr lterm:=
           |- (?op ?u1 ?u2) =>
            change (op 
              (@Ring_polynom.PEeval
-               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
                (@Ring_theory.pow_N _ 1 multiplication) lvar e1)
              (@Ring_polynom.PEeval
-               _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+               _ zero one _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
                (@Ring_theory.pow_N _ 1 multiplication) lvar e2))
         end
   end.
diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
index d2ab9e0f..4de2efe3 100644
--- a/plugins/setoid_ring/Field.v
+++ b/plugins/setoid_ring/Field.v
@@ -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/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
index 34a3018b..f867c6d0 100644
--- a/plugins/setoid_ring/Field_tac.v
+++ b/plugins/setoid_ring/Field_tac.v
@@ -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        *)
@@ -10,55 +10,67 @@ Require Import Ring_tac BinList Ring_polynom InitialRing.
 Require Export Field_theory.
 
  (* syntaxification *)
- Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+ Ltac mkFieldexpr C Cst CstPow rO rI radd rmul rsub ropp rdiv rinv rpow t fv :=
  let rec mkP t :=
     let f :=
     match Cst t with
     | InitialRing.NotConstant =>
         match t with
+        | rO => 
+          fun _ => constr:(@FEO C)
+        | rI => 
+          fun _ => constr:(@FEI C)
         | (radd ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEadd e1 e2)
+          let e2 := mkP t2 in constr:(@FEadd C e1 e2)
         | (rmul ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEmul e1 e2)
+          let e2 := mkP t2 in constr:(@FEmul C e1 e2)
         | (rsub ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEsub e1 e2)
+          let e2 := mkP t2 in constr:(@FEsub C e1 e2)
         | (ropp ?t1) =>
-          fun _ => let e1 := mkP t1 in constr:(FEopp e1)
+          fun _ => let e1 := mkP t1 in constr:(@FEopp C e1)
         | (rdiv ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(FEdiv e1 e2)
+          let e2 := mkP t2 in constr:(@FEdiv C e1 e2)
         | (rinv ?t1) =>
-          fun _ => let e1 := mkP t1 in constr:(FEinv e1)
+          fun _ => let e1 := mkP t1 in constr:(@FEinv C e1)
         | (rpow ?t1 ?n) =>
           match CstPow n with
           | InitialRing.NotConstant =>
             fun _ =>
             let p := Find_at t fv in
             constr:(@FEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(@FEpow C e1 c)
           end
         | _ =>
           fun _ =>
           let p := Find_at t fv in
           constr:(@FEX C p)
         end
-    | ?c => fun _ => constr:(FEc c)
+    | ?c => fun _ => constr:(@FEc C c)
     end in
     f ()
  in mkP t.
 
-Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac FFV Cst CstPow rO rI add mul sub opp div inv pow t fv :=
  let rec TFV t fv :=
   match Cst t with
   | InitialRing.NotConstant =>
       match t with
+      | rO => fv
+      | rI => fv
       | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
       | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
@@ -83,60 +95,60 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
 Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
   let FLD :=
     match type of L1 with
-    | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+    | context [req (@FEeval ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
                                       ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
         (fun proj =>
            proj Cst_tac Pow_tac pre post
-             req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
+             req rO rI radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
     | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
     end in
   F FLD.
 
 Ltac get_FldPre FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        pre).
 
 Ltac get_FldPost FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        post).
 
 Ltac get_L1 FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L1).
 
 Ltac get_SimplifyEqLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L2).
 
 Ltac get_SimplifyLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L3).
 
 Ltac get_L4 FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        L4).
 
 Ltac get_CondLemma FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        cond_ok).
 
 Ltac get_FldEq FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
        req).
 
@@ -146,33 +158,33 @@ Ltac get_FldCarrier FLD :=
 
 Ltac get_RingFV FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       FV Cst_tac Pow_tac radd rmul rsub ropp rpow).
+       FV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow).
 
 Ltac get_FFV FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+       FFV Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow).
 
 Ltac get_RingMeta FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).
+       mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow).
 
 Ltac get_Meta FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+       mkFieldexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rdiv rinv rpow).
 
 Ltac get_Hyp_tac FLD :=
   FLD ltac:
-      (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+      (fun Cst_tac Pow_tac pre post req r0 r1 radd rmul rsub ropp rdiv rinv rpow C
            L1 L2 L3 L4 cond_ok =>
-       let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+       let mkPol := mkPolexpr C Cst_tac Pow_tac r0 r1 radd rmul rsub ropp rpow in
        fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
 
 Ltac get_FEeval FLD :=
@@ -180,8 +192,8 @@ Ltac get_FEeval FLD :=
   match type of L1 with
   | context
     [(@FEeval
-      ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
-       constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
+      ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
+       constr:(@FEeval R r0 r1 add mul sub opp div inv C phi Cpow powphi pow)
   | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
   end.
 
@@ -201,8 +213,7 @@ Ltac fold_field_cond req :=
 Ltac simpl_PCond FLD :=
   let req := get_FldEq FLD in
   let lemma := get_CondLemma FLD in
-  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; 
-       clear lock_def lock);
+  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock); 
   protect_fv "field_cond";
   fold_field_cond req;
   try exact I.
@@ -210,8 +221,7 @@ Ltac simpl_PCond FLD :=
 Ltac simpl_PCond_BEURK FLD :=
   let req := get_FldEq FLD in
   let lemma := get_CondLemma FLD in
-  try (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; 
-       clear lock_def lock);
+  (apply lemma; intros lock lock_def; vm_compute; rewrite lock_def; clear lock_def lock);
   protect_fv "field_cond";
   fold_field_cond req.
 
@@ -544,10 +554,9 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
          let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
          match s_spec with
          | mkhypo ?ss_spec =>
-           let field_ok3 := constr:(field_ok2 _ ss_spec) in
            match d_spec with
            | mkhypo ?dd_spec =>
-             let field_ok := constr:(field_ok3 _ dd_spec) in
+             let field_ok := constr:(field_ok2 _ dd_spec) in
              let mk_lemma lemma :=
               constr:(lemma _ _ _  _ _ _  _ _ _ _
                    set ext_r inv_m afth
@@ -563,7 +572,7 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
              (fun f =>
                f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
                   cond1_ok cond2_ok)
-           | _ => fail 4 "field: bad coefficiant division specification"
+           | _ => fail 4 "field: bad coefficient division specification"
            end
          | _ => fail 3 "field: bad sign specification"
          end
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index 75d3ad86..0f5c49b0 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -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        *)
@@ -9,123 +9,179 @@
 Require Ring.
 Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms.
 Require Import ZArith_base.
-(*Require Import Omega.*)
 Set Implicit Arguments.
+(* Set Universe Polymorphism. *)
 
 Section MakeFieldPol.
 
-(* Field elements *)
- Variable R:Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
- Variable (rdiv : R -> R ->  R) (rinv : R ->  R).
- Variable req : R -> R -> Prop.
-
- Notation "0" := rO. Notation "1" := rI.
- Notation "x + y" := (radd x y).  Notation "x * y " := (rmul x y).
- Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
- Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
- Notation "x == y" := (req x y) (at level 70, no associativity).
-
- (* Equality properties *)
- Variable Rsth : Equivalence req.
- Variable Reqe : ring_eq_ext radd rmul ropp req.
- Variable SRinv_ext : forall p q, p == q ->  / p == / q.
-
- (* Field properties *)
-  Record almost_field_theory : Prop := mk_afield {
-    AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
-    AF_1_neq_0 : ~ 1 == 0;
-    AFdiv_def : forall p q, p / q == p * / q;
-    AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
-  }.
+(* Field elements : R *)
+
+Variable R:Type.
+Bind Scope R_scope with R.
+Delimit Scope R_scope with ring.
+Local Open Scope R_scope.
+
+Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+Variable (rdiv : R->R->R) (rinv : R->R).
+Variable req : R -> R -> Prop.
+
+Notation "0" := rO : R_scope.
+Notation "1" := rI : R_scope.
+Infix "+" := radd : R_scope.
+Infix "-" := rsub : R_scope.
+Infix "*" := rmul : R_scope.
+Infix "/" := rdiv : R_scope.
+Notation "- x" := (ropp x) : R_scope.
+Notation "/ x" := (rinv x) : R_scope.
+Infix "==" := req (at level 70, no associativity) : R_scope.
+
+(* Equality properties *)
+Variable Rsth : Equivalence req.
+Variable Reqe : ring_eq_ext radd rmul ropp req.
+Variable SRinv_ext : forall p q, p == q ->  / p == / q.
+
+(* Field properties *)
+Record almost_field_theory : Prop := mk_afield {
+ AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
+ AF_1_neq_0 : ~ 1 == 0;
+ AFdiv_def : forall p q, p / q == p * / q;
+ AFinv_l : forall p, ~ p == 0 ->  / p * p == 1
+}.
 
 Section AlmostField.
 
- Variable AFth : almost_field_theory.
- Let ARth := AFth.(AF_AR).
- Let rI_neq_rO := AFth.(AF_1_neq_0).
- Let rdiv_def := AFth.(AFdiv_def).
- Let rinv_l := AFth.(AFinv_l).
+Variable AFth : almost_field_theory.
+Let ARth := AFth.(AF_AR).
+Let rI_neq_rO := AFth.(AF_1_neq_0).
+Let rdiv_def := AFth.(AFdiv_def).
+Let rinv_l := AFth.(AFinv_l).
 
- (* Coefficients *)
- Variable C: Type.
- Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
- Variable ceqb : C->C->bool.
- Variable phi : C -> R.
+Add Morphism radd : radd_ext. Proof. exact (Radd_ext Reqe). Qed.
+Add Morphism rmul : rmul_ext. Proof. exact (Rmul_ext Reqe). Qed.
+Add Morphism ropp : ropp_ext. Proof. exact (Ropp_ext Reqe). Qed.
+Add Morphism rsub : rsub_ext. Proof. exact (ARsub_ext Rsth Reqe ARth). Qed.
+Add Morphism rinv : rinv_ext. Proof. exact SRinv_ext. Qed.
 
- Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
-                               cO cI cadd cmul csub copp ceqb phi.
+Let eq_trans := Setoid.Seq_trans _ _ Rsth.
+Let eq_sym := Setoid.Seq_sym _ _ Rsth.
+Let eq_refl := Setoid.Seq_refl _ _ Rsth.
 
-Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
+Let radd_0_l := ARadd_0_l ARth.
+Let radd_comm := ARadd_comm ARth.
+Let radd_assoc := ARadd_assoc ARth.
+Let rmul_1_l := ARmul_1_l ARth.
+Let rmul_0_l := ARmul_0_l ARth.
+Let rmul_comm := ARmul_comm ARth.
+Let rmul_assoc := ARmul_assoc ARth.
+Let rdistr_l := ARdistr_l ARth.
+Let ropp_mul_l := ARopp_mul_l ARth.
+Let ropp_add := ARopp_add ARth.
+Let rsub_def := ARsub_def ARth.
+
+Let radd_0_r := ARadd_0_r Rsth ARth.
+Let rmul_0_r := ARmul_0_r Rsth ARth.
+Let rmul_1_r := ARmul_1_r Rsth ARth.
+Let ropp_0 := ARopp_zero Rsth Reqe ARth.
+Let rdistr_r := ARdistr_r Rsth Reqe ARth.
+
+(* Coefficients : C *)
+
+Variable C: Type.
+Bind Scope C_scope with C.
+Delimit Scope C_scope with coef.
+
+Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+Variable ceqb : C->C->bool.
+Variable phi : C -> R.
+
+Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+                              cO cI cadd cmul csub copp ceqb phi.
+
+Notation "0" := cO : C_scope.
+Notation "1" := cI : C_scope.
+Infix "+" := cadd : C_scope.
+Infix "-" := csub : C_scope.
+Infix "*" := cmul : C_scope.
+Notation "- x" := (copp x) : C_scope.
+Infix "=?" := ceqb : C_scope.
+Notation "[ x ]" := (phi x) (at level 0).
+
+Let phi_0 := CRmorph.(morph0).
+Let phi_1 := CRmorph.(morph1).
+
+Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c =? c')%coef.
 Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-case (ceqb c1 c2); auto.
+generalize (CRmorph.(morph_eq) c c').
+destruct (c =? c')%coef; auto.
 Qed.
 
+(* Power coefficients : Cpow *)
 
- (* C notations *)
- Notation "x +! y" := (cadd x y) (at level 50).
- Notation "x *! y " := (cmul x y) (at level 40).
- Notation "x -! y " := (csub x y) (at level 50).
- Notation "-! x" := (copp x) (at level 35).
- Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
- Notation "[ x ]" := (phi x) (at level 0).
+Variable Cpow : Type.
+Variable Cp_phi : N -> Cpow.
+Variable rpow : R -> Cpow -> R.
+Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+(* sign function *)
+Variable get_sign : C -> option C.
+Variable get_sign_spec : sign_theory copp ceqb get_sign.
 
+Variable cdiv:C -> C -> C*C.
+Variable cdiv_th : div_theory req cadd cmul phi cdiv.
 
- (* Useful tactics *)
-  Add Morphism radd : radd_ext.  exact (Radd_ext Reqe). Qed.
-  Add Morphism rmul : rmul_ext.  exact (Rmul_ext Reqe). Qed.
-  Add Morphism ropp : ropp_ext.  exact (Ropp_ext Reqe). Qed.
-  Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
-  Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
+Let rpow_pow := pow_th.(rpow_pow_N).
 
-Let eq_trans := Setoid.Seq_trans _ _ Rsth.
-Let eq_sym := Setoid.Seq_sym _ _ Rsth.
-Let eq_refl := Setoid.Seq_refl _ _ Rsth.
+(* Polynomial expressions : (PExpr C) *)
+
+Bind Scope PE_scope with PExpr.
+Delimit Scope PE_scope with poly.
+
+Notation NPEeval := (PEeval rO rI radd rmul rsub ropp phi Cp_phi rpow).
+Notation "P @ l" := (NPEeval l P) (at level 10, no associativity).
+
+Arguments PEc _ _%coef.
+
+Notation "0" := (PEc 0) : PE_scope.
+Notation "1" := (PEc 1) : PE_scope.
+Infix "+" := PEadd : PE_scope.
+Infix "-" := PEsub : PE_scope.
+Infix "*" := PEmul : PE_scope.
+Notation "- e" := (PEopp e) : PE_scope.
+Infix "^" := PEpow : PE_scope.
+
+Definition NPEequiv e e' := forall l, e@l == e'@l.
+Infix "===" := NPEequiv (at level 70, no associativity) : PE_scope.
 
-Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
-Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
-             (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
-Hint Resolve (ARadd_0_l  ARth) (ARadd_comm  ARth) (ARadd_assoc ARth)
-             (ARmul_1_l  ARth) (ARmul_0_l  ARth)
-             (ARmul_comm  ARth) (ARmul_assoc ARth) (ARdistr_l  ARth)
-             (ARopp_mul_l ARth) (ARopp_add  ARth)
-             (ARsub_def  ARth) .
-
- (* Power coefficients *)
- Variable Cpow : Type.
- Variable Cp_phi : N -> Cpow.
- Variable rpow : R -> Cpow -> R.
- Variable pow_th : power_theory rI rmul req Cp_phi rpow.
- (* sign function *)
- Variable get_sign : C -> option C.
- Variable get_sign_spec : sign_theory copp ceqb get_sign.
-
- Variable cdiv:C -> C -> C*C.
- Variable cdiv_th : div_theory req cadd cmul phi cdiv.
-
-Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
-Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
-
-Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
-Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
+Instance NPEequiv_eq : Equivalence NPEequiv.
+Proof.
+ split; red; unfold NPEequiv; intros; [reflexivity|symmetry|etransitivity];
+  eauto.
+Qed.
+
+Instance NPEeval_ext : Proper (eq ==> NPEequiv ==> req) NPEeval.
+Proof.
+ intros l l' <- e e' He. now rewrite (He l).
+Qed.
+
+Notation Nnorm :=
+  (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
+Notation NPphi_dev :=
+  (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
+Notation NPphi_pow :=
+  (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
 
 (* add abstract semi-ring to help with some proofs *)
 Add Ring Rring : (ARth_SRth ARth).
 
-Local Hint Extern 2 (_ == _) => f_equiv.
-
 (* additional ring properties *)
 
-Lemma rsub_0_l : forall r, 0 - r == - r.
-intros; rewrite (ARsub_def ARth);ring.
+Lemma rsub_0_l r : 0 - r == - r.
+Proof.
+rewrite rsub_def; ring.
 Qed.
 
-Lemma rsub_0_r : forall r, r - 0 == r.
-intros; rewrite (ARsub_def ARth).
-rewrite (ARopp_zero Rsth Reqe ARth);  ring.
+Lemma rsub_0_r r : r - 0 == r.
+Proof.
+rewrite rsub_def, ropp_0; ring.
 Qed.
 
 (***************************************************************************
@@ -134,452 +190,525 @@ Qed.
 
   ***************************************************************************)
 
-Theorem rdiv_simpl: forall p q, ~ q == 0 ->  q * (p / q) == p.
+Theorem rdiv_simpl p q : ~ q == 0 ->  q * (p / q) == p.
 Proof.
-intros p q H.
+intros.
 rewrite rdiv_def.
-transitivity (/ q * q * p); [  ring | idtac ].
-rewrite rinv_l; auto.
+transitivity (/ q * q * p); [ ring | ].
+now rewrite rinv_l.
 Qed.
-Hint Resolve rdiv_simpl .
 
-Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv.
+Instance rdiv_ext: Proper (req ==> req ==> req) rdiv.
 Proof.
-intros p1 p2 Ep q1 q2 Eq.
-transitivity (p1 * / q1); auto.
-transitivity (p2 * / q2); auto.
+intros p1 p2 Ep q1 q2 Eq. now rewrite !rdiv_def, Ep, Eq.
 Qed.
-Hint Resolve SRdiv_ext.
 
-Lemma rmul_reg_l : forall p q1 q2,
+Lemma rmul_reg_l p q1 q2 :
   ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
 Proof.
-intros p q1 q2 H EQ.
-rewrite <- (@rdiv_simpl q1 p) by trivial.
-rewrite <- (@rdiv_simpl q2 p) by trivial.
-rewrite !rdiv_def, !(ARmul_assoc ARth).
-now rewrite EQ.
+intros H EQ.
+assert (H' : p * (q1 / p) == p * (q2 / p)).
+{ now rewrite !rdiv_def, !rmul_assoc, EQ. }
+now rewrite !rdiv_simpl in H'.
 Qed.
 
-Theorem field_is_integral_domain : forall r1 r2,
+Theorem field_is_integral_domain r1 r2 :
   ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
 Proof.
-intros r1 r2 H1 H2. contradict H2.
-transitivity (1 * r2); auto.
-transitivity (/ r1 * r1 * r2); auto.
-rewrite <- (ARmul_assoc ARth).
-rewrite H2.
-apply ARmul_0_r with (1 := Rsth) (2 := ARth).
+intros H1 H2. contradict H2.
+transitivity (/r1 * r1 * r2).
+- now rewrite rinv_l.
+- now rewrite <- rmul_assoc, H2.
 Qed.
 
-Theorem ropp_neq_0 : forall r,
+Theorem ropp_neq_0 r :
   ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
+Proof.
 intros.
 setoid_replace (- r) with (- (1) * r).
- apply field_is_integral_domain; trivial.
- rewrite <- (ARopp_mul_l ARth).
-   rewrite (ARmul_1_l ARth).
-   reflexivity.
+- apply field_is_integral_domain; trivial.
+- now rewrite <- ropp_mul_l, rmul_1_l.
 Qed.
 
-Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
-intros.
-rewrite (AFdiv_def AFth).
-rewrite (ARmul_comm ARth).
-apply (AFinv_l AFth).
-trivial.
+Theorem rdiv_r_r r : ~ r == 0 -> r / r == 1.
+Proof.
+intros. rewrite rdiv_def, rmul_comm. now apply rinv_l.
 Qed.
 
-Theorem rdiv1: forall r,  r == r / 1.
-intros r; transitivity (1 * (r / 1)); auto.
+Theorem rdiv1 r : r == r / 1.
+Proof.
+transitivity (1 * (r / 1)).
+- symmetry; apply rdiv_simpl. apply rI_neq_rO.
+- apply rmul_1_l.
 Qed.
 
-Theorem rdiv2:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
+Theorem rdiv2 a b c d :
+ ~ b == 0 ->
+ ~ d == 0 ->
+ a / b + c / d == (a * d + c * b) / (b * d).
 Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
+intros H H0.
+assert (~ b * d == 0) by now apply field_is_integral_domain.
+apply rmul_reg_l with (b * d); trivial.
 rewrite rdiv_simpl; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth).
-apply (Radd_ext Reqe).
-- transitivity (r2 * (r1 / r2) * r4); [  ring | auto ].
-- transitivity (r2 * (r4 * (r3 / r4))); auto.
-  transitivity (r2 * r3); auto.
+rewrite rdistr_r.
+apply radd_ext.
+- now rewrite <- rmul_assoc, (rmul_comm d), rmul_assoc, rdiv_simpl.
+- now rewrite (rmul_comm c), <- rmul_assoc, rdiv_simpl.
 Qed.
 
 
-Theorem rdiv2b:
- forall r1 r2 r3 r4 r5,
- ~ (r2*r5) == 0 ->
- ~ (r4*r5) == 0 ->
- r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
+Theorem rdiv2b a b c d e :
+ ~ (b*e) == 0 ->
+ ~ (d*e) == 0 ->
+ a / (b*e) + c / (d*e) == (a * d + c * b) / (b * (d * e)).
 Proof.
-intros r1 r2 r3 r4 r5 H H0.
-assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
-assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
-assert (HH4: ~ r2 * (r4 * r5) == 0)
+intros H H0.
+assert (~ b == 0) by (contradict H; rewrite H; ring).
+assert (~ e == 0) by (contradict H; rewrite H; ring).
+assert (~ d == 0) by (contradict H0; rewrite H0; ring).
+assert (~ b * (d * e) == 0)
    by (repeat apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
+apply rmul_reg_l with (b * (d * e)); trivial.
 rewrite rdiv_simpl; trivial.
-rewrite (ARdistr_r Rsth Reqe ARth).
-apply (Radd_ext Reqe).
- transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [  ring | auto ].
- transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [  ring | auto ].
-Qed.
-
-Theorem rdiv5: forall r1 r2,  - (r1 / r2) == - r1 / r2.
-Proof.
-intros r1 r2.
-transitivity (- (r1 * / r2)); auto.
-transitivity (- r1 * / r2); auto.
-Qed.
-Hint Resolve rdiv5 .
-
-Theorem rdiv3 r1 r2 r3 r4 :
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- r1 / r2 - r3 / r4 == (r1 * r4 -  r3 * r2) / (r2 * r4).
-Proof.
-intros H2 H4.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-transitivity (r1 / r2 + - (r3 / r4)); auto.
-transitivity (r1 / r2 + - r3 / r4); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)).
-apply rdiv2; auto.
-f_equiv.
-transitivity (r1 * r4 + - (r3 * r2)); auto.
-Qed.
-
-
-Theorem rdiv3b:
- forall r1 r2 r3 r4 r5,
- ~ (r2 * r5) == 0 ->
- ~ (r4 * r5) == 0 ->
- r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
-Proof.
-intros r1 r2 r3 r4 r5 H H0.
-transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
-transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
-transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
-apply rdiv2b; auto; try ring.
-apply (SRdiv_ext); auto.
-transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
-Qed.
-
-Theorem rdiv6:
- forall r1 r2,
- ~ r1 == 0 -> ~ r2 == 0 ->  / (r1 / r2) == r2 / r1.
-intros r1 r2 H H0.
-assert (~ r1 / r2 == 0) as Hk.
- intros H1; case H.
-   transitivity (r2 * (r1 / r2)); auto.
-   rewrite H1;  ring.
- apply rmul_reg_l with (r1 / r2); auto.
-   transitivity (/ (r1 / r2) * (r1 / r2)); auto.
-   transitivity 1; auto.
-   repeat rewrite rdiv_def.
-   transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac |  ring ].
-   repeat rewrite rinv_l; auto.
-Qed.
-Hint Resolve rdiv6 .
-
- Theorem rdiv4:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r4 == 0 ->
- (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
-Proof.
-intros r1 r2 r3 r4 H H0.
-assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
-apply rmul_reg_l with (r2 * r4); trivial.
-rewrite rdiv_simpl; trivial.
-transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [  ring | idtac ].
-repeat rewrite rdiv_simpl; trivial.
+rewrite rdistr_r.
+apply radd_ext.
+- transitivity ((b * e) * (a / (b * e)) * d);
+  [ ring | now rewrite rdiv_simpl ].
+- transitivity ((d * e) * (c / (d * e)) * b);
+  [ ring | now rewrite rdiv_simpl ].
 Qed.
 
- Theorem rdiv4b:
- forall r1 r2 r3 r4 r5 r6,
- ~ r2 * r5 == 0 ->
- ~ r4 * r6 == 0 ->
- ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4).
+Theorem rdiv5 a b : - (a / b) == - a / b.
 Proof.
-intros r1 r2 r3 r4 r5 r6 H H0.
-rewrite rdiv4; auto.
-transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))).
-apply SRdiv_ext; ring.
-assert (HH: ~ r5*r6 == 0).
-  apply field_is_integral_domain.
-    intros H1; case H; rewrite H1; ring.
-    intros H1; case H0; rewrite H1; ring.
-rewrite <- rdiv4 ; auto.
-  rewrite rdiv_r_r; auto.
+now rewrite !rdiv_def, ropp_mul_l.
+Qed.
 
-  apply field_is_integral_domain.
-    intros H1; case H; rewrite H1; ring.
-    intros H1; case H0; rewrite H1; ring.
+Theorem rdiv3b a b c d e :
+ ~ (b * e) == 0 ->
+ ~ (d * e) == 0 ->
+ a / (b*e) - c / (d*e) == (a * d - c * b) / (b * (d * e)).
+Proof.
+intros H H0.
+rewrite !rsub_def, rdiv5, ropp_mul_l.
+now apply rdiv2b.
 Qed.
 
+Theorem rdiv6 a b :
+ ~ a == 0 -> ~ b == 0 ->  / (a / b) == b / a.
+Proof.
+intros H H0.
+assert (Hk : ~ a / b == 0).
+{ contradict H.
+  transitivity (b * (a / b)).
+  - now rewrite rdiv_simpl.
+  - rewrite H. apply rmul_0_r. }
+apply rmul_reg_l with (a / b); trivial.
+rewrite (rmul_comm (a / b)), rinv_l; trivial.
+rewrite !rdiv_def.
+transitivity (/ a * a * (/ b * b)); [ | ring ].
+now rewrite !rinv_l, rmul_1_l.
+Qed.
+
+Theorem rdiv4 a b c d :
+ ~ b == 0 ->
+ ~ d == 0 ->
+ (a / b) * (c / d) == (a * c) / (b * d).
+Proof.
+intros H H0.
+assert (~ b * d == 0) by now apply field_is_integral_domain.
+apply rmul_reg_l with (b * d); trivial.
+rewrite rdiv_simpl; trivial.
+transitivity (b * (a / b) * (d * (c / d))); [ ring | ].
+rewrite !rdiv_simpl; trivial.
+Qed.
 
-Theorem rdiv7:
- forall r1 r2 r3 r4,
- ~ r2 == 0 ->
- ~ r3 == 0 ->
- ~ r4 == 0 ->
- (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
+Theorem rdiv4b a b c d e f :
+ ~ b * e == 0 ->
+ ~ d * f == 0 ->
+ ((a * f) / (b * e)) * ((c * e) / (d * f)) == (a * c) / (b * d).
+Proof.
+intros H H0.
+assert (~ b == 0) by (contradict H; rewrite H; ring).
+assert (~ e == 0) by (contradict H; rewrite H; ring).
+assert (~ d == 0) by (contradict H0; rewrite H0; ring).
+assert (~ f == 0) by (contradict H0; rewrite H0; ring).
+assert (~ b*d == 0) by now apply field_is_integral_domain.
+assert (~ e*f == 0) by now apply field_is_integral_domain.
+rewrite rdiv4; trivial.
+transitivity ((e * f) * (a * c) / ((e * f) * (b * d))).
+- apply rdiv_ext; ring.
+- rewrite <- rdiv4, rdiv_r_r; trivial.
+Qed.
+
+Theorem rdiv7 a b c d :
+ ~ b == 0 ->
+ ~ c == 0 ->
+ ~ d == 0 ->
+ (a / b) / (c / d) == (a * d) / (b * c).
 Proof.
 intros.
-rewrite (rdiv_def (r1 / r2)).
+rewrite (rdiv_def (a / b)).
 rewrite rdiv6; trivial.
 apply rdiv4; trivial.
 Qed.
 
-Theorem rdiv7b:
- forall r1 r2 r3 r4 r5 r6,
- ~ r2 * r6 == 0 ->
- ~ r3 * r5 == 0 ->
- ~ r4 * r6 == 0 ->
- ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3).
+Theorem rdiv7b a b c d e f :
+ ~ b * f == 0 ->
+ ~ c * e == 0 ->
+ ~ d * f == 0 ->
+ ((a * e) / (b * f)) / ((c * e) / (d * f)) == (a * d) / (b * c).
+Proof.
+intros Hbf Hce Hdf.
+assert (~ c==0) by (contradict Hce; rewrite Hce; ring).
+assert (~ e==0) by (contradict Hce; rewrite Hce; ring).
+assert (~ b==0) by (contradict Hbf; rewrite Hbf; ring).
+assert (~ f==0) by (contradict Hbf; rewrite Hbf; ring).
+assert (~ b*c==0) by now apply field_is_integral_domain.
+assert (~ e*f==0) by now apply field_is_integral_domain.
+rewrite rdiv7; trivial.
+transitivity ((e * f) * (a * d) / ((e * f) * (b * c))).
+- apply rdiv_ext; ring.
+- now rewrite <- rdiv4, rdiv_r_r.
+Qed.
+
+Theorem rinv_nz a : ~ a == 0 -> ~ /a == 0.
+Proof.
+intros H H0. apply rI_neq_rO.
+rewrite <- (rdiv_r_r H), rdiv_def, H0. apply rmul_0_r.
+Qed.
+
+Theorem rdiv8 a b : ~ b == 0 -> a == 0 ->  a / b == 0.
+Proof.
+intros H H0.
+now rewrite rdiv_def, H0, rmul_0_l.
+Qed.
+
+Theorem cross_product_eq a b c d :
+  ~ b == 0 -> ~ d == 0 -> a * d == c * b -> a / b == c / d.
 Proof.
 intros.
-rewrite rdiv7; auto.
-transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))).
-apply SRdiv_ext; ring.
-assert (HH: ~ r5*r6 == 0).
-  apply field_is_integral_domain.
-    intros H2; case H0; rewrite H2; ring.
-    intros H2; case H1; rewrite H2; ring.
-rewrite <- rdiv4 ; auto.
-rewrite rdiv_r_r; auto.
-  apply field_is_integral_domain.
-    intros H2; case H; rewrite H2; ring.
-    intros H2; case H0; rewrite H2; ring.
+transitivity (a / b * (d / d)).
+- now rewrite rdiv_r_r, rmul_1_r.
+- now rewrite rdiv4, H1, (rmul_comm b d), <- rdiv4, rdiv_r_r.
 Qed.
 
+(* Results about [pow_pos] and [pow_N] *)
 
-Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 ->  r1 / r2 == 0.
-intros r1 r2 H H0.
-transitivity (r1 * / r2); auto.
-transitivity (0 * / r2); auto.
+Instance pow_ext : Proper (req ==> eq ==> req) (pow_pos rmul).
+Proof.
+intros x y H p p' <-.
+induction p as [p IH| p IH|];simpl; trivial; now rewrite !IH, ?H.
 Qed.
 
+Instance pow_N_ext : Proper (req ==> eq ==> req) (pow_N rI rmul).
+Proof.
+intros x y H n n' <-. destruct n; simpl; trivial. now apply pow_ext.
+Qed.
 
-Theorem cross_product_eq : forall r1 r2 r3 r4,
-  ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
-intros.
-transitivity (r1 / r2 * (r4 / r4)).
- rewrite rdiv_r_r; trivial.
-   symmetry .
-   apply (ARmul_1_r Rsth ARth).
- rewrite rdiv4; trivial.
-   rewrite H1.
-   rewrite (ARmul_comm ARth r2 r4).
-   rewrite <- rdiv4; trivial.
-   rewrite rdiv_r_r by trivial.
-  apply (ARmul_1_r Rsth ARth).
+Lemma pow_pos_0 p : pow_pos rmul 0 p == 0.
+Proof.
+induction p;simpl;trivial; now rewrite !IHp.
 Qed.
 
+Lemma pow_pos_1 p : pow_pos rmul 1 p == 1.
+Proof.
+induction p;simpl;trivial; ring [IHp].
+Qed.
+
+Lemma pow_pos_cst c p : pow_pos rmul [c] p == [pow_pos cmul c p].
+Proof.
+induction p;simpl;trivial; now rewrite !CRmorph.(morph_mul), !IHp.
+Qed.
+
+Lemma pow_pos_mul_l x y p :
+ pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
+Proof.
+induction p;simpl;trivial; ring [IHp].
+Qed.
+
+Lemma pow_pos_add_r x p1 p2 :
+ pow_pos rmul x (p1+p2) == pow_pos rmul x p1 * pow_pos rmul x p2.
+Proof.
+ exact (Ring_theory.pow_pos_add Rsth rmul_ext rmul_assoc x p1 p2).
+Qed.
+
+Lemma pow_pos_mul_r x p1 p2 :
+  pow_pos rmul x (p1*p2) == pow_pos rmul (pow_pos rmul x p1) p2.
+Proof.
+induction p1;simpl;intros; rewrite ?pow_pos_mul_l, ?pow_pos_add_r;
+ simpl; trivial; ring [IHp1].
+Qed.
+
+Lemma pow_pos_nz x p : ~x==0 -> ~pow_pos rmul x p == 0.
+Proof.
+ intros Hx. induction p;simpl;trivial;
+  repeat (apply field_is_integral_domain; trivial).
+Qed.
+
+Lemma pow_pos_div a b p : ~ b == 0 ->
+ pow_pos rmul (a / b) p == pow_pos rmul a p / pow_pos rmul b p.
+Proof.
+ intros.
+ induction p; simpl; trivial.
+ - rewrite IHp.
+   assert (nz := pow_pos_nz p H).
+   rewrite !rdiv4; trivial.
+   apply field_is_integral_domain; trivial.
+ - rewrite IHp.
+   assert (nz := pow_pos_nz p H).
+   rewrite !rdiv4; trivial.
+Qed.
+
+(* === is a morphism *)
+
+Instance PEadd_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEadd C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEsub_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEsub C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEmul_ext : Proper (NPEequiv ==> NPEequiv ==> NPEequiv) (@PEmul C).
+Proof. intros ? ? E ? ? E' l. simpl. now rewrite E, E'. Qed.
+Instance PEopp_ext : Proper (NPEequiv ==> NPEequiv) (@PEopp C).
+Proof. intros ? ? E l. simpl. now rewrite E. Qed.
+Instance PEpow_ext : Proper (NPEequiv ==> eq ==> NPEequiv) (@PEpow C).
+Proof.
+ intros ? ? E ? ? <- l. simpl. rewrite !rpow_pow. apply pow_N_ext; trivial.
+Qed.
+
+Lemma PE_1_l (e : PExpr C) : (1 * e === e)%poly.
+Proof.
+ intros l. simpl. rewrite phi_1. apply rmul_1_l.
+Qed.
+
+Lemma PE_1_r (e : PExpr C) : (e * 1 === e)%poly.
+Proof.
+ intros l. simpl. rewrite phi_1. apply rmul_1_r.
+Qed.
+
+Lemma PEpow_0_r (e : PExpr C) : (e ^ 0 === 1)%poly.
+Proof.
+ intros l. simpl. now rewrite !rpow_pow.
+Qed.
+
+Lemma PEpow_1_r (e : PExpr C) : (e ^ 1 === e)%poly.
+Proof.
+ intros l. simpl. now rewrite !rpow_pow.
+Qed.
+
+Lemma PEpow_1_l n : (1 ^ n === 1)%poly.
+Proof.
+ intros l. simpl. rewrite rpow_pow. destruct n; simpl.
+ - now rewrite phi_1.
+ - now rewrite phi_1, pow_pos_1.
+Qed.
+
+Lemma PEpow_add_r (e : PExpr C) n n' :
+ (e ^ (n+n') === e ^ n * e ^ n')%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow.
+ destruct n; simpl.
+ - rewrite rmul_1_l. trivial.
+ - destruct n'; simpl.
+   + rewrite rmul_1_r. trivial.
+   + apply pow_pos_add_r.
+Qed.
+
+Lemma PEpow_mul_l (e e' : PExpr C) n :
+ ((e * e') ^ n === e ^ n * e' ^ n)%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow. destruct n; simpl; trivial.
+ - symmetry; apply rmul_1_l.
+ - apply pow_pos_mul_l.
+Qed.
+
+Lemma PEpow_mul_r (e : PExpr C) n n' :
+ (e ^ (n * n') === (e ^ n) ^ n')%poly.
+Proof.
+ intros l. simpl. rewrite !rpow_pow.
+ destruct n, n'; simpl; trivial.
+ - now rewrite pow_pos_1.
+ - apply pow_pos_mul_r.
+Qed.
+
+Lemma PEpow_nz l e n : ~ e @ l == 0 -> ~ (e^n) @ l == 0.
+Proof.
+ intros. simpl. rewrite rpow_pow. destruct n; simpl.
+ - apply rI_neq_rO.
+ - now apply pow_pos_nz.
+Qed.
+
+
 (***************************************************************************
 
                        Some equality test
 
   ***************************************************************************)
 
+Local Notation "a &&& b" := (if a then b else false)
+ (at level 40, left associativity).
+
 (* equality test *)
-Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool :=
- match e1, e2 with
-   PEc c1, PEc c2 => ceqb c1 c2
-  | PEX p1, PEX p2 => Pos.eqb p1 p2
-  | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false
-  | PEopp e3, PEopp e4 => PExpr_eq e3 e4
-  | PEpow e3 n3, PEpow e4 n4 => if N.eqb n3 n4 then PExpr_eq e3 e4 else false
+Fixpoint PExpr_eq (e e' : PExpr C) {struct e} : bool :=
+ match e, e' with
+  | PEc c, PEc c' => ceqb c c'
+  | PEX _ p, PEX _ p' => Pos.eqb p p'
+  | e1 + e2, e1' + e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | e1 - e2, e1' - e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | e1 * e2, e1' * e2' => PExpr_eq e1 e1' &&& PExpr_eq e2 e2'
+  | - e, - e' => PExpr_eq e e'
+  | e ^ n, e' ^ n' => N.eqb n n' &&& PExpr_eq e e'
   | _, _ => false
- end.
-
-Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph.
-intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
-Qed.
-
-Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph.
-intros x y H [|p];simpl;auto. apply pow_morph;trivial.
-Qed.
-
-Theorem PExpr_eq_semi_correct:
- forall l e1 e2, PExpr_eq e1 e2 = true ->  NPEeval l e1 == NPEeval l e2.
-intros l e1; elim e1.
-intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros c2; apply (morph_eq CRmorph).
-intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
-intros p2; case Pos.eqb_spec; intros; now subst.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
-intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
- (try (intros; discriminate)); auto.
-intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
-intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
- (try (intros; discriminate)); auto.
-intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))).
-intros e4 n4; case N.eqb_spec; try discriminate; intros EQ H; subst.
-repeat rewrite  pow_th.(rpow_pow_N). rewrite (rec _ H);auto.
-Qed.
-
-(* add *)
-Definition NPEadd e1 e2 :=
-  match e1, e2 with
-    PEc c1, PEc c2 => PEc (cadd c1 c2)
-  | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
-    (* Peut t'on factoriser ici ??? *)
-  | _, _ => PEadd e1 e2
-  end.
+ end%poly.
 
-Theorem NPEadd_correct:
- forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
+Lemma if_true (a b : bool) : a &&& b = true -> a = true /\ b = true.
 Proof.
-intros l e1 e2.
-destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl;
- try (ring [(morph0 CRmorph)]).
- apply (morph_add CRmorph).
+ destruct a, b; split; trivial.
 Qed.
 
-Definition NPEpow x n :=
-  match n with
-  | N0 => PEc cI
-  | Npos p =>
-    if Pos.eqb p xH then x else
-    match x with
-    | PEc c =>
-      if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p)
-    | _ => PEpow x n
-    end
-  end.
-
-Theorem NPEpow_correct : forall l e n,
-  NPEeval l (NPEpow e n) == NPEeval l (PEpow e n).
+Theorem PExpr_eq_semi_ok e e' :
+ PExpr_eq e e' = true ->  (e === e')%poly.
+Proof.
+revert e'; induction e; destruct e'; simpl; try discriminate.
+- intros H l. now apply (morph_eq CRmorph).
+- case Pos.eqb_spec; intros; now subst.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H; destruct (if_true _ _ H). now rewrite IHe1, IHe2.
+- intros H. now rewrite IHe.
+- intros H. destruct (if_true _ _ H).
+  apply N.eqb_eq in H0. now rewrite IHe, H0.
+Qed.
+
+Lemma PExpr_eq_spec e e' : BoolSpec (e === e')%poly True (PExpr_eq e e').
 Proof.
- destruct n;simpl.
- rewrite pow_th.(rpow_pow_N);simpl;auto.
- fold (p =? 1)%positive.
- case Pos.eqb_spec; intros H; (rewrite H || clear H).
- now rewrite  pow_th.(rpow_pow_N).
- destruct e;simpl;auto.
- repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl.
- symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)].
- symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)].
- induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
+ assert (H := PExpr_eq_semi_ok e e').
+ destruct PExpr_eq; constructor; intros; trivial. now apply H.
 Qed.
 
-(* mul *)
-Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
-  match x, y with
-    PEc c1, PEc c2 => PEc (cmul c1 c2)
-  | PEc c, _ =>
-      if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
-  |  _, PEc c =>
-      if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
-  | PEpow e1 n1, PEpow e2 n2 =>
-      if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
-  | _, _ => PEmul x y
-  end.
+(** Smart constructors for polynomial expression,
+    with reduction of constants *)
 
-Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
-induction p;simpl;auto;try ring [IHp].
-Qed.
+Definition NPEadd e1 e2 :=
+  match e1, e2 with
+  | PEc c1, PEc c2 => PEc (c1 + c2)
+  | PEc c, _ => if (c =? 0)%coef then e2 else e1 + e2
+  |  _, PEc c => if (c =? 0)%coef then e1 else e1 + e2
+    (* Peut t'on factoriser ici ??? *)
+  | _, _ => (e1 + e2)
+  end%poly.
+Infix "++" := NPEadd (at level 60, right associativity).
 
-Theorem NPEmul_correct : forall l e1 e2,
-  NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
-induction e1;destruct e2; simpl;try reflexivity;
- repeat apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl; try reflexivity;
- try ring [(morph0 CRmorph) (morph1 CRmorph)].
- apply (morph_mul CRmorph).
-case N.eqb_spec; intros H; try rewrite <- H; clear H.
-rewrite NPEpow_correct. simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite IHe1; destruct n;simpl;try ring.
-apply pow_pos_mul.
-simpl;auto.
+Theorem NPEadd_ok e1 e2 : (e1 ++ e2 === e1 + e2)%poly.
+Proof.
+intros l.
+destruct e1, e2; simpl; try reflexivity; try (case ceqb_spec);
+try intro H; try rewrite H; simpl;
+try apply eq_refl; try (ring [phi_0]).
+apply (morph_add CRmorph).
 Qed.
 
-(* sub *)
 Definition NPEsub e1 e2 :=
   match e1, e2 with
-    PEc c1, PEc c2 => PEc (csub c1 c2)
-  | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
-  |  _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
+  | PEc c1, PEc c2 => PEc (c1 - c2)
+  | PEc c, _ => if (c =? 0)%coef then - e2 else e1 - e2
+  |  _, PEc c => if (c =? 0)%coef then e1 else e1 - e2
      (* Peut-on factoriser ici *)
-  | _, _ => PEsub e1 e2
-  end.
+  | _, _ => e1 - e2
+  end%poly.
+Infix "--" := NPEsub (at level 50, left associativity).
 
-Theorem NPEsub_correct:
- forall l e1 e2,  NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
-intros l e1 e2.
-destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect;
- try (intro eq_c; rewrite eq_c); simpl;
- try rewrite (morph0 CRmorph); try reflexivity;
+Theorem NPEsub_ok e1 e2: (e1 -- e2 === e1 - e2)%poly.
+Proof.
+intros l.
+destruct e1, e2; simpl; try reflexivity; try case ceqb_spec;
+ try intro H; try rewrite H; simpl;
+ try rewrite phi_0; try reflexivity;
  try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
 apply (morph_sub CRmorph).
 Qed.
 
-(* opp *)
 Definition NPEopp e1 :=
-  match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
+  match e1 with PEc c1 => PEc (- c1) | _ => - e1 end%poly.
+
+Theorem NPEopp_ok e : (NPEopp e === -e)%poly.
+Proof.
+intros l. destruct e; simpl; trivial. apply (morph_opp CRmorph).
+Qed.
+
+Definition NPEpow x n :=
+  match n with
+  | N0 => 1
+  | Npos p =>
+    if (p =? 1)%positive then x else
+    match x with
+    | PEc c =>
+      if (c =? 1)%coef then 1
+      else if (c =? 0)%coef then 0
+      else PEc (pow_pos cmul c p)
+    | _ => x ^ n
+    end
+  end%poly.
+Infix "^^" := NPEpow (at level 35, right associativity).
 
-Theorem NPEopp_correct:
- forall l e1,  NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
-intros l e1; case e1; simpl; auto.
-intros; apply (morph_opp CRmorph).
+Theorem NPEpow_ok e n : (e ^^ n === e ^ n)%poly.
+Proof.
+ intros l. unfold NPEpow; destruct n.
+ - simpl; now rewrite rpow_pow.
+ - case Pos.eqb_spec; [intro; subst | intros _].
+   + simpl. now rewrite rpow_pow.
+   + destruct e;simpl;trivial.
+     repeat case ceqb_spec; intros; rewrite ?rpow_pow, ?H; simpl.
+     * now rewrite phi_1, pow_pos_1.
+     * now rewrite phi_0, pow_pos_0.
+     * now rewrite pow_pos_cst.
+Qed.
+
+Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
+  match x, y with
+  | PEc c1, PEc c2 => PEc (c1 * c2)
+  | PEc c, _ => if (c =? 1)%coef then y else if (c =? 0)%coef then 0 else x * y
+  | _, PEc c => if (c =? 1)%coef then x else if (c =? 0)%coef then 0 else x * y
+  | e1 ^ n1, e2 ^ n2 => if (n1 =? n2)%N then (NPEmul e1 e2)^^n1 else x * y
+  | _, _ => x * y
+  end%poly.
+Infix "**" := NPEmul (at level 40, left associativity).
+
+Theorem NPEmul_ok e1 e2 : (e1 ** e2 === e1 * e2)%poly.
+Proof.
+intros l.
+revert e2; induction e1;destruct e2; simpl;try reflexivity;
+ repeat (case ceqb_spec; intro H; try rewrite H; clear H);
+ simpl; try reflexivity; try ring [phi_0 phi_1].
+ apply (morph_mul CRmorph).
+case N.eqb_spec; [intros <- | reflexivity].
+rewrite NPEpow_ok. simpl.
+rewrite !rpow_pow. rewrite IHe1.
+destruct n; simpl; [ ring | apply pow_pos_mul_l ].
 Qed.
 
 (* simplification *)
-Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
+Fixpoint PEsimp (e : PExpr C) : PExpr C :=
  match e with
-   PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
-  | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
-  | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
-  | PEopp e1 => NPEopp (PExpr_simp e1)
-  | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
+  | e1 + e2 => (PEsimp e1) ++ (PEsimp e2)
+  | e1 * e2 => (PEsimp e1) ** (PEsimp e2)
+  | e1 - e2 => (PEsimp e1) -- (PEsimp e2)
+  | - e1 => NPEopp (PEsimp e1)
+  | e1 ^ n1 => (PEsimp e1) ^^ n1
   | _ => e
- end.
+ end%poly.
 
-Theorem PExpr_simp_correct:
- forall l e,  NPEeval l (PExpr_simp e) == NPEeval l e.
-intros l e; elim e; simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEadd_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEsub_correct.
-simpl; auto.
-intros e1 He1 e2 He2.
-transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
-apply NPEmul_correct.
-simpl; auto.
-intros e1 He1.
-transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
-apply NPEopp_correct.
-simpl; auto.
-intros e1 He1 n;simpl.
-rewrite NPEpow_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N).
-rewrite He1;auto.
+Theorem PEsimp_ok e : (PEsimp e === e)%poly.
+Proof.
+induction e; simpl.
+- reflexivity.
+- reflexivity.
+- intro l; trivial.
+- intro l; trivial.
+- rewrite NPEadd_ok. now f_equiv.
+- rewrite NPEsub_ok. now f_equiv.
+- rewrite NPEmul_ok. now f_equiv.
+- rewrite NPEopp_ok. now f_equiv.
+- rewrite NPEpow_ok. now f_equiv.
 Qed.
 
 
@@ -592,7 +721,9 @@ Qed.
 (* The input: syntax of a field expression *)
 
 Inductive FExpr : Type :=
-   FEc: C ->  FExpr
+ | FEO : FExpr
+ | FEI : FExpr
+ | FEc: C ->  FExpr
  | FEX: positive ->  FExpr
  | FEadd: FExpr -> FExpr ->  FExpr
  | FEsub: FExpr -> FExpr ->  FExpr
@@ -604,6 +735,8 @@ Inductive FExpr : Type :=
 
 Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
   match pe with
+  | FEO       => rO
+  | FEI       => rI
   | FEc c     => phi c
   | FEX x     => BinList.nth 0 x l
   | FEadd x y => FEeval l x + FEeval l y
@@ -633,44 +766,46 @@ Record linear : Type := mk_linear {
 Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
   match le with
   | nil => True
-  | e1 :: nil => ~ req (NPEeval l e1) rO
-  | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
+  | e1 :: nil => ~ req (e1 @ l) rO
+  | e1 :: l1 => ~ req (e1 @ l) rO /\ PCond l l1
   end.
 
-Theorem PCond_cons_inv_l :
-   forall l a l1, PCond l (a::l1) ->  ~ NPEeval l a == 0.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
+Theorem PCond_cons l a l1 :
+ PCond l (a :: l1) <-> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+destruct l1.
+- simpl. split; [split|destruct 1]; trivial.
+- reflexivity.
 Qed.
 
-Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) ->  PCond l l1.
-intros l a l1 H.
-destruct l1; simpl in H |- *; trivial.
-destruct H; trivial.
+Theorem PCond_cons_inv_l l a l1 : PCond l (a::l1) ->  ~ a @ l == 0.
+Proof.
+rewrite PCond_cons. now destruct 1.
 Qed.
 
-Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l1.
-intros l l1 l2; elim l1; simpl app.
- simpl; auto.
- destruct l0; simpl in *.
-  destruct l2; firstorder.
-  firstorder.
+Theorem PCond_cons_inv_r l a l1 : PCond l (a :: l1) ->  PCond l l1.
+Proof.
+rewrite PCond_cons. now destruct 1.
 Qed.
 
-Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) ->  PCond l l2.
-intros l l1 l2; elim l1; simpl app; auto.
-intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
+Theorem PCond_app l l1 l2 :
+ PCond l (l1 ++ l2) <-> PCond l l1 /\ PCond l l2.
+Proof.
+induction l1.
+- simpl. split; [split|destruct 1]; trivial.
+- simpl app. rewrite !PCond_cons, IHl1. symmetry; apply and_assoc.
 Qed.
 
+
 (* An unsatisfiable condition: issued when a division by zero is detected *)
-Definition absurd_PCond := cons (PEc cO) nil.
+Definition absurd_PCond := cons 0%poly nil.
 
 Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
+Proof.
 unfold absurd_PCond; simpl.
 red; intros.
 apply H.
-apply (morph0 CRmorph).
+apply phi_0.
 Qed.
 
 (***************************************************************************
@@ -679,167 +814,124 @@ Qed.
 
   ***************************************************************************)
 
-Fixpoint isIn (e1:PExpr C)  (p1:positive)
-                      (e2:PExpr C)  (p2:positive) {struct e2}: option (N * PExpr C) :=
+Definition default_isIn e1 p1 e2 p2 :=
+  if PExpr_eq e1 e2 then
+    match Z.pos_sub p1 p2 with
+     | Zpos p => Some (Npos p, 1%poly)
+     | Z0 => Some (N0, 1%poly)
+     | Zneg p => Some (N0, e2 ^^ Npos p)
+    end
+  else None.
+
+Fixpoint isIn e1 p1 e2 p2 {struct e2}: option (N * PExpr C) :=
   match e2 with
-  | PEmul e3 e4 =>
+  | e3 * e4 =>
        match isIn e1 p1 e3 p2 with
-       | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
+       | Some (N0, e5) => Some (N0, e5 ** (e4 ^^ Npos p2))
        | Some (Npos p, e5) =>
           match isIn e1 p e4 p2 with
-          | Some (n, e6) => Some (n, NPEmul e5 e6)
-          | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
+          | Some (n, e6) => Some (n, e5 ** e6)
+          | None => Some (Npos p, e5 ** (e4 ^^ Npos p2))
           end
        | None =>
          match isIn e1 p1 e4 p2 with
-         | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
+         | Some (n, e5) => Some (n, (e3 ^^ Npos p2) ** e5)
          | None => None
          end
        end
-  | PEpow e3 N0 => None
-  | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2)
-  | _ =>
-     if  PExpr_eq e1 e2 then
-         match Z.pos_sub p1 p2 with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None
-   end.
+  | e3 ^ N0 => None
+  | e3 ^ Npos p3 => isIn e1 p1 e3 (Pos.mul p3 p2)
+  | _ => default_isIn e1 p1 e2 p2
+   end%poly.
 
  Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
  Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
 
- Notation pow_pos_add :=
-   (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)).
-
  Lemma Z_pos_sub_gt p q : (p > q)%positive ->
   Z.pos_sub p q = Zpos (p - q).
  Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed.
 
  Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption.
 
- Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
-  match
-      (if  PExpr_eq e1 e2 then
-         match Z.sub (Zpos p1) (Zpos p2) with
-          | Zpos p => Some (Npos p, PEc cI)
-          | Z0 => Some (N0, PEc cI)
-          | Zneg p => Some (N0, NPEpow e2 (Npos p))
-          end
-     else None)
-   with
+ Lemma default_isIn_ok e1 e2 p1 p2 :
+  match default_isIn e1 p1 e2 p2 with
    | Some(n, e3) =>
-       NPEeval l (PEpow e2 (Npos p2)) ==
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-       (Zpos p1 > NtoZ n)%Z
-   |  _ => True
+       let n' := ZtoN (Zpos p1 - NtoZ n) in
+       (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly
+       /\ (Zpos p1 > NtoZ n)%Z
+   | _ => True
   end.
 Proof.
-  intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
-   case (PExpr_eq e1 e2); simpl; auto; intros H.
+  unfold default_isIn.
+  case PExpr_eq_spec; trivial. intros EQ.
   rewrite Z.pos_sub_spec.
-  case Pos.compare_spec;intros;simpl.
-  - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity.
-    subst. rewrite H by trivial. ring [ (morph1 CRmorph)].
-  - fold (p2 - p1 =? 1)%positive.
-    fold (NPEpow e2 (Npos (p2 - p1))).
-    rewrite NPEpow_correct;simpl.
-    repeat rewrite pow_th.(rpow_pow_N);simpl.
-    rewrite H;trivial. split. 2:reflexivity.
-    rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add.
-  - repeat rewrite pow_th.(rpow_pow_N);simpl.
-    rewrite H;trivial.
-    rewrite Z.pos_sub_gt by now apply Pos.sub_decr.
-    replace (p1 - (p1 - p2))%positive with p2;
-    [| rewrite Pos.sub_sub_distr, Pos.add_comm;
-       auto using Pos.add_sub, Pos.sub_decr ].
-    split.
-    simpl. ring [ (morph1 CRmorph)].
-    now apply Z.lt_gt, Pos.sub_decr.
-Qed.
-
-Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
-induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_add;simpl.
-ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
-Qed.
-
-
-Theorem isIn_correct: forall l e1 p1 e2 p2,
+  case Pos.compare_spec;intros H; split; try reflexivity.
+  - simpl. now rewrite PE_1_r, H, EQ.
+  - rewrite NPEpow_ok, EQ, <- PEpow_add_r. f_equiv.
+    simpl. f_equiv. now rewrite Pos.add_comm, Pos.sub_add.
+  - simpl. rewrite PE_1_r, EQ. f_equiv.
+    rewrite Z.pos_sub_gt by now apply Pos.sub_decr. simpl. f_equiv.
+    rewrite Pos.sub_sub_distr, Pos.add_comm; trivial.
+    rewrite Pos.add_sub; trivial.
+    apply Pos.sub_decr; trivial.
+  - simpl. now apply Z.lt_gt, Pos.sub_decr.
+Qed.
+
+Ltac npe_simpl := rewrite ?NPEmul_ok, ?NPEpow_ok, ?PEpow_mul_l.
+Ltac npe_ring := intro l; simpl; ring.
+
+Theorem isIn_ok e1 p1 e2 p2 :
   match isIn e1 p1 e2 p2 with
    | Some(n, e3) =>
-       NPEeval l (PEpow e2 (Npos p2)) ==
-       NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
-        (Zpos p1 > NtoZ n)%Z
+       let n' := ZtoN (Zpos p1 - NtoZ n) in
+       (e2 ^ N.pos p2 === e1 ^ n' * e3)%poly
+       /\ (Zpos p1 > NtoZ n)%Z
    |  _ => True
   end.
 Proof.
 Opaque NPEpow.
-intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
-  try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
-generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
-destruct n.
-  simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
-  repeat rewrite pow_th.(rpow_pow_N);simpl.
-  rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
-  generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
-  destruct n;simpl.
-    rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl.
-    intros (H1,H2) (H3,H4).
-    simpl_pos_sub. simpl in H3.
-    rewrite pow_pos_mul. rewrite H1;rewrite H3.
-    assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-        (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) ==
-        pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
-        NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
-   rewrite <- pow_pos_add.
-   rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4).
-   split. symmetry;apply ARth.(ARmul_assoc). reflexivity.
-   repeat rewrite pow_th.(rpow_pow_N);simpl.
-   intros (H1,H2) (H3,H4).
-   simpl_pos_sub. simpl in H1, H3.
-   assert (Zpos p1 > Zpos p6)%Z.
-     apply Zgt_trans with (Zpos p4). exact H4. exact H2.
-  simpl_pos_sub.
-  split. 2:exact H.
-  rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
-  assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
-                (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
-             pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
-                NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
-  rewrite <- pow_pos_add.
-  replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive.
- rewrite NPEmul_correct. simpl;ring.
-  assert
-     (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
- change  ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
- rewrite <- Z.add_assoc. rewrite (Z.add_assoc  (- Zpos p4)).
- simpl. rewrite Z.pos_sub_diag. simpl. reflexivity.
- unfold Z.sub, Z.opp in H0. simpl in H0.
-  simpl_pos_sub. inversion H0; trivial.
- simpl. repeat rewrite pow_th.(rpow_pow_N).
- intros H1 (H2,H3). simpl_pos_sub.
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- simpl in H2. rewrite pow_th.(rpow_pow_N);simpl.
- rewrite pow_pos_mul. split. ring [H2]. exact H3.
- generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
- destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl.
- intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
- rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
- repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul.
- intros (H1, H2);rewrite H1;split.
-   simpl_pos_sub. simpl in H1;ring [H1]. trivial.
- trivial.
- destruct n. trivial.
- generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
- destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
- repeat rewrite pow_th.(rpow_pow_N). simpl.
- intros (H1,H2);split;trivial.
- rewrite pow_pos_pow_pos;trivial.
- trivial.
+revert p1 p2.
+induction e2; intros p1 p2;
+ try refine (default_isIn_ok e1 _ p1 p2); simpl isIn.
+- specialize (IHe2_1 p1 p2).
+  destruct isIn as [([|p],e)|].
+  + split; [|reflexivity].
+    clear IHe2_2.
+    destruct IHe2_1 as (IH,_).
+    npe_simpl. rewrite IH. npe_ring.
+  + specialize (IHe2_2 p p2).
+    destruct isIn as [([|p'],e')|].
+    * destruct IHe2_1 as (IH1,GT1).
+      destruct IHe2_2 as (IH2,GT2).
+      split; [|simpl; apply Zgt_trans with (Z.pos p); trivial].
+      npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl.
+      replace (N.pos p1) with (N.pos p + N.pos (p1 - p))%N.
+      rewrite PEpow_add_r; npe_ring.
+      { simpl. f_equal. rewrite Pos.add_comm, Pos.sub_add. trivial.
+        now apply Pos.gt_lt. }
+    * destruct IHe2_1 as (IH1,GT1).
+      destruct IHe2_2 as (IH2,GT2).
+      assert (Z.pos p1 > Z.pos p')%Z by (now apply Zgt_trans with (Zpos p)).
+      split; [|simpl; trivial].
+      npe_simpl. rewrite IH1, IH2. simpl. simpl_pos_sub. simpl.
+      replace (N.pos (p1 - p')) with (N.pos (p1 - p) + N.pos (p - p'))%N.
+      rewrite PEpow_add_r; npe_ring.
+      { simpl. f_equal. rewrite Pos.add_sub_assoc, Pos.sub_add; trivial.
+        now apply Pos.gt_lt.
+        now apply Pos.gt_lt. }
+    * destruct IHe2_1 as (IH,GT). split; trivial.
+      npe_simpl. rewrite IH. npe_ring.
+  + specialize (IHe2_2 p1 p2).
+    destruct isIn as [(n,e)|]; trivial.
+    destruct IHe2_2 as (IH,GT). split; trivial.
+    set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d.
+    npe_simpl. rewrite IH. npe_ring.
+- destruct n; trivial.
+  specialize (IHe2 p1 (p * p2)%positive).
+  destruct isIn as [(n,e)|]; trivial.
+  destruct IHe2 as (IH,GT). split; trivial.
+  set (d := ZtoN (Z.pos p1 - NtoZ n)) in *; clearbody d.
+  now rewrite <- PEpow_mul_r.
 Qed.
 
 Record rsplit : Type := mk_rsplit {
@@ -852,121 +944,122 @@ Notation left := rsplit_left.
 Notation right := rsplit_right.
 Notation common := rsplit_common.
 
-Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :=
+Fixpoint split_aux e1 p e2 {struct e1}: rsplit :=
   match e1 with
-  | PEmul e3 e4 =>
+  | e3 * e4 =>
       let r1 := split_aux e3 p e2 in
       let r2 := split_aux e4 p (right r1) in
-          mk_rsplit (NPEmul (left r1) (left r2))
-                    (NPEmul (common r1) (common r2))
-                    (right r2)
-  | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
-  | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2
+      mk_rsplit (left r1 ** left r2)
+                (common r1 ** common r2)
+                (right r2)
+  | e3 ^ N0 => mk_rsplit 1 1 e2
+  | e3 ^ Npos p3 => split_aux e3 (Pos.mul p3 p) e2
   | _ =>
-       match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
+       match isIn e1 p e2 1 with
+       | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3
+       | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3
+       | None => mk_rsplit (e1 ^^ Npos p) 1 e2
        end
-  end.
+  end%poly.
 
-Lemma split_aux_correct_1 : forall l e1 p e2,
-  let res :=  match isIn e1 p e2 xH with
-       | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
-       | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
-       | None => mk_rsplit (NPEpow e1  (Npos p)) (PEc cI) e2
-       end in
-       NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
-   /\
-       NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
-Proof.
- intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
- destruct (isIn e1 p e2 1). destruct p0.
+Lemma split_aux_ok1 e1 p e2 :
+  (let res := match isIn e1 p e2 1 with
+       | Some (N0,e3) => mk_rsplit 1 (e1 ^^ Npos p) e3
+       | Some (Npos q, e3) => mk_rsplit (e1 ^^ Npos q) (e1 ^^ Npos (p - q)) e3
+       | None => mk_rsplit (e1 ^^ Npos p) 1 e2
+       end
+  in
+  e1 ^ Npos p === left res * common res
+  /\ e2 === right res * common res)%poly.
+Proof.
  Opaque NPEpow NPEmul.
-  destruct n;simpl;
-    (repeat rewrite NPEmul_correct;simpl;
-     repeat rewrite NPEpow_correct;simpl;
-     repeat rewrite pow_th.(rpow_pow_N);simpl).
-  intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
-  intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H].
-  apply Z.gt_lt in Hgt.
-  now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add.
-  simpl;intros. repeat rewrite NPEmul_correct;simpl.
-  rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
-Qed.
-
-Theorem split_aux_correct: forall l e1 p e2,
-  NPEeval l (PEpow e1 (Npos p)) ==
-       NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
-/\
-  NPEeval l  e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
-                                   (common (split_aux e1 p e2))).
-Proof.
-intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
-generalize (IHe1_1 k e2); clear IHe1_1.
-generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2.
-simpl. repeat (rewrite NPEmul_correct;simpl).
-repeat rewrite pow_th.(rpow_pow_N);simpl.
-intros (H1,H2) (H3,H4);split.
-rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
-rewrite H4;rewrite H2;ring.
-destruct n;simpl.
-split. repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite NPEmul_correct. simpl.
- induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
- rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
-generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
-repeat rewrite NPEmul_correct;simpl.
-repeat rewrite pow_th.(rpow_pow_N);simpl.
-rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
+ intros. unfold res;clear res; generalize (isIn_ok e1 p e2 xH).
+ destruct (isIn e1 p e2 1) as [([|p'],e')|]; simpl.
+ - intros (H1,H2); split; npe_simpl.
+   + now rewrite PE_1_l.
+   + rewrite PEpow_1_r in H1. rewrite H1. npe_ring.
+ - intros (H1,H2); split; npe_simpl.
+   + rewrite <- PEpow_add_r. f_equiv. simpl. f_equal.
+     rewrite Pos.add_comm, Pos.sub_add; trivial.
+     now apply Z.gt_lt in H2.
+   + rewrite PEpow_1_r in H1. rewrite H1. simpl_pos_sub. simpl. npe_ring.
+ - intros _; split; npe_simpl; now rewrite PE_1_r.
+Qed.
+
+Theorem split_aux_ok: forall e1 p e2,
+  (e1 ^ Npos p === left (split_aux e1 p e2) * common (split_aux e1 p e2)
+  /\ e2 === right (split_aux e1 p e2) * common (split_aux e1 p e2))%poly.
+Proof.
+induction e1;intros k e2; try refine (split_aux_ok1 _ k e2);simpl.
+destruct (IHe1_1 k e2) as (H1,H2).
+destruct (IHe1_2 k (right (split_aux e1_1 k e2))) as (H3,H4).
+clear IHe1_1 IHe1_2.
+- npe_simpl; split.
+  * rewrite H1, H3. npe_ring.
+  * rewrite H2 at 1. rewrite H4 at 1. npe_ring.
+- destruct n; simpl.
+  + rewrite PEpow_0_r, PEpow_1_l, !PE_1_r. now split.
+  + rewrite <- PEpow_mul_r. simpl. apply IHe1.
 Qed.
 
 Definition split e1 e2 := split_aux e1 xH e2.
 
-Theorem split_correct_l: forall l e1 e2,
-  NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
-                                   (common (split e1 e2))).
+Theorem split_ok_l e1 e2 :
+  (e1 === left (split e1 e2) * common (split e1 e2))%poly.
+Proof.
+destruct (split_aux_ok e1 xH e2) as (H,_). now rewrite <- H, PEpow_1_r.
+Qed.
+
+Theorem split_ok_r e1 e2 :
+  (e2 === right (split e1 e2) * common (split e1 e2))%poly.
 Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
-rewrite pow_th.(rpow_pow_N);simpl;auto.
+destruct (split_aux_ok e1 xH e2) as (_,H). trivial.
 Qed.
 
-Theorem split_correct_r: forall l e1 e2,
-  NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
-                                   (common (split e1 e2))).
+Lemma split_nz_l l e1 e2 :
+ ~ e1 @ l == 0 -> ~ left (split e1 e2) @ l == 0.
 Proof.
-intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
+ intros H. contradict H. rewrite (split_ok_l e1 e2); simpl.
+ now rewrite H, rmul_0_l.
+Qed.
+
+Lemma split_nz_r l e1 e2 :
+ ~ e2 @ l == 0 -> ~ right (split e1 e2) @ l == 0.
+Proof.
+ intros H. contradict H. rewrite (split_ok_r e1 e2); simpl.
+ now rewrite H, rmul_0_l.
 Qed.
 
 Fixpoint Fnorm (e : FExpr) : linear :=
   match e with
-  | FEc c => mk_linear (PEc c) (PEc cI) nil
-  | FEX x => mk_linear (PEX C x) (PEc cI) nil
+  | FEO => mk_linear 0 1 nil
+  | FEI => mk_linear 1 1 nil
+  | FEc c => mk_linear (PEc c) 1 nil
+  | FEX x => mk_linear (PEX C x) 1 nil
   | FEadd e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s := split (denum x) (denum y) in
       mk_linear
-        (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
-
+        ((num x ** right s) ++ (num y ** left s))
+        (left s ** (right s ** common s))
+        (condition x ++ condition y)%list
   | FEsub e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s := split (denum x) (denum y) in
       mk_linear
-        (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
-        (NPEmul (left s) (NPEmul (right s) (common s)))
-        (condition x ++ condition y)
+        ((num x ** right s) -- (num y ** left s))
+        (left s ** (right s ** common s))
+        (condition x ++ condition y)%list
   | FEmul e1 e2 =>
       let x := Fnorm e1 in
       let y := Fnorm e2 in
       let s1 := split (num x) (denum y) in
       let s2 := split (num y) (denum x) in
-      mk_linear (NPEmul (left s1) (left s2))
-        (NPEmul (right s2) (right s1))
-        (condition x ++ condition y)
+      mk_linear (left s1 ** left s2)
+        (right s2 ** right s1)
+        (condition x ++ condition y)%list
   | FEopp e1 =>
       let x := Fnorm e1 in
       mk_linear (NPEopp (num x)) (denum x) (condition x)
@@ -978,15 +1071,14 @@ Fixpoint Fnorm (e : FExpr) : linear :=
       let y := Fnorm e2 in
       let s1 := split (num x) (num y) in
       let s2 := split (denum x) (denum y) in
-      mk_linear (NPEmul (left s1) (right s2))
-        (NPEmul (left s2) (right s1))
-        (num y :: condition x ++ condition y)
+      mk_linear (left s1 ** right s2)
+        (left s2 ** right s1)
+        (num y :: condition x ++ condition y)%list
   | FEpow e1 n =>
       let x := Fnorm e1 in
-      mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
+      mk_linear ((num x)^^n) ((denum x)^^n) (condition x)
   end.
 
-
 (* Example *)
 (*
 Eval compute
@@ -996,93 +1088,31 @@ Eval compute
           (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
 *)
 
- Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
+Theorem Pcond_Fnorm l e :
+ PCond l (condition (Fnorm e)) ->  ~ (denum (Fnorm e))@l == 0.
 Proof.
- induction p;simpl.
-  intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
-  apply IHp.
-  rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  reflexivity.
-  rewrite H1. ring. rewrite Hp;ring.
-  intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p)  0 IHp).
-  reflexivity. rewrite Hp;ring. trivial.
-Qed.
-
-Theorem Pcond_Fnorm:
- forall l e,
- PCond l (condition (Fnorm e)) ->  ~ NPEeval l (denum (Fnorm e)) == 0.
-intros l e; elim e.
- simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
- simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-   intros HH; case Hrec1; auto.
-     apply PCond_app_inv_l with (1 := Hcond).
-   rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-   rewrite NPEmul_correct; simpl; rewrite HH; ring.
-   intros HH; case Hrec2; auto.
-     apply PCond_app_inv_r with (1 := Hcond).
-   rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-  intros HH; apply Hrec1.
-    apply PCond_app_inv_l with (1 := Hcond).
-    rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
-  intros HH; apply Hrec2.
-    apply PCond_app_inv_r with (1 := Hcond).
-    rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
- intros e1 Hrec1 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   auto.
- intros e1 Hrec1 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   apply PCond_cons_inv_l with (1:=Hcond).
- intros e1 Hrec1 e2 Hrec2 Hcond.
-   simpl condition in Hcond.
-   simpl denum.
-   rewrite NPEmul_correct.
-   simpl.
-   apply field_is_integral_domain.
-    intros HH; apply Hrec1.
-    specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
-    apply PCond_app_inv_l with (1 := Hcond1).
-    rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
-    intros HH; apply PCond_cons_inv_l with (1:=Hcond).
-    rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))).
-    rewrite NPEmul_correct; simpl; rewrite HH; ring.
- simpl;intros e1 Hrec1 n Hcond.
-  rewrite NPEpow_correct.
-  simpl;rewrite pow_th.(rpow_pow_N).
-  destruct n;simpl;intros.
-  apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
-Qed.
-Hint Resolve Pcond_Fnorm.
+induction e; simpl condition; rewrite ?PCond_cons, ?PCond_app;
+ simpl denum; intros (Hc1,Hc2) || intros Hc; rewrite ?NPEmul_ok.
+- simpl. rewrite phi_1; exact rI_neq_rO.
+- simpl. rewrite phi_1; exact rI_neq_rO.
+- simpl; intros. rewrite phi_1; exact rI_neq_rO.
+- simpl; intros. rewrite phi_1; exact rI_neq_rO.
+- rewrite <- split_ok_r. simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc1.
+  + apply IHe2, Hc2.
+- rewrite <- split_ok_r. simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc1.
+  + apply IHe2, Hc2.
+- simpl. apply field_is_integral_domain.
+  + apply split_nz_r, IHe1, Hc1.
+  + apply split_nz_r, IHe2, Hc2.
+- now apply IHe.
+- trivial.
+- destruct Hc2 as (Hc2,_). simpl. apply field_is_integral_domain.
+  + apply split_nz_l, IHe1, Hc2.
+  + apply split_nz_r, Hc1.
+- rewrite NPEpow_ok. apply PEpow_nz, IHe, Hc.
+Qed.
 
 
 (***************************************************************************
@@ -1091,154 +1121,106 @@ Hint Resolve Pcond_Fnorm.
 
   ***************************************************************************)
 
-Theorem Fnorm_FEeval_PEeval:
- forall l fe,
+Ltac uneval :=
+ repeat match goal with
+  | |- context [ ?x @ ?l * ?y @ ?l ] => change (x@l * y@l) with ((x*y)@l)
+  | |- context [ ?x @ ?l + ?y @ ?l ] => change (x@l + y@l) with ((x+y)@l)
+ end.
+
+Theorem Fnorm_FEeval_PEeval l fe:
  PCond l (condition (Fnorm fe)) ->
- FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
-Proof.
-intros l fe; elim fe; simpl.
-intros c H; rewrite CRmorph.(morph1); apply rdiv1.
-intros p H; rewrite CRmorph.(morph1); apply rdiv1.
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEadd_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv2b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-rewrite NPEsub_correct; simpl.
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2; rewrite U1; rewrite U2.
-apply rdiv3b; auto.
-  rewrite <- U1; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct; simpl.
-generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1)))
-   (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
-  rewrite U4; simpl.
-apply rdiv4b; auto.
-  rewrite <- U4; auto.
-  rewrite <- U2; auto.
-
-intros e1 He1 HH.
-rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
-
-intros e1 He1 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); apply rdiv6; auto.
-apply PCond_cons_inv_l with ( 1 := HH ).
-
-intros e1 He1 e2 He2 HH.
-assert (HH1: PCond l (condition (Fnorm e1))).
-apply PCond_app_inv_l with (condition (Fnorm e2)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-assert (HH2: PCond l (condition (Fnorm e2))).
-apply PCond_app_inv_r with (condition (Fnorm e1)).
-apply PCond_cons_inv_r with ( 1 := HH ).
-rewrite (He1 HH1); rewrite (He2 HH2).
-repeat rewrite NPEmul_correct;simpl.
-generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2)))
-   (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2)))
-   (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
-   (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
-repeat rewrite NPEmul_correct; simpl.
-intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
-  rewrite U4; simpl.
-apply rdiv7b; auto.
-  rewrite <- U3; auto.
-  rewrite <- U2; auto.
-apply PCond_cons_inv_l with ( 1 := HH ).
-  rewrite <- U4; auto.
-
-intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
-repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
-rewrite He1';clear He1'.
-destruct n;simpl. apply rdiv1.
-generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
-  (Pcond_Fnorm _ _ Hcond).
-intros r r0 Hdiff;induction p;simpl.
-repeat (rewrite <- rdiv4;trivial).
-rewrite IHp. reflexivity.
-apply pow_pos_not_0;trivial.
-apply pow_pos_not_0;trivial.
-intro Hp. apply (pow_pos_not_0 Hdiff  p).
-rewrite  (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p)  0).
- reflexivity. apply pow_pos_not_0;trivial. ring [Hp].
-rewrite <- rdiv4;trivial.
-rewrite IHp;reflexivity.
-apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
-reflexivity.
-Qed.
-
-Theorem Fnorm_crossproduct:
- forall l fe1 fe2,
+ FEeval l fe == (num (Fnorm fe)) @ l / (denum (Fnorm fe)) @ l.
+Proof.
+induction fe; simpl condition; rewrite ?PCond_cons, ?PCond_app; simpl;
+ intros (Hc1,Hc2) || intros Hc;
+ try (specialize (IHfe1 Hc1);apply Pcond_Fnorm in Hc1);
+ try (specialize (IHfe2 Hc2);apply Pcond_Fnorm in Hc2);
+ try set (F1 := Fnorm fe1) in *; try set (F2 := Fnorm fe2) in *.
+
+- now rewrite phi_1, phi_0, rdiv_def.
+- now rewrite phi_1; apply rdiv1.
+- rewrite phi_1; apply rdiv1.
+- rewrite phi_1; apply rdiv1.
+- rewrite NPEadd_ok, !NPEmul_ok. simpl.
+  rewrite <- rdiv2b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial.
+  now f_equiv.
+
+- rewrite NPEsub_ok, !NPEmul_ok. simpl.
+  rewrite <- rdiv3b; uneval; rewrite <- ?split_ok_l, <- ?split_ok_r; trivial.
+  now f_equiv.
+
+- rewrite !NPEmul_ok. simpl.
+  rewrite IHfe1, IHfe2.
+  rewrite (split_ok_l (num F1) (denum F2) l),
+          (split_ok_r (num F1) (denum F2) l),
+          (split_ok_l (num F2) (denum F1) l),
+          (split_ok_r (num F2) (denum F1) l) in *.
+  apply rdiv4b; trivial.
+
+- rewrite NPEopp_ok; simpl; rewrite (IHfe Hc); apply rdiv5.
+
+- rewrite (IHfe Hc2); apply rdiv6; trivial;
+   apply Pcond_Fnorm; trivial.
+
+- destruct Hc2 as (Hc2,Hc3).
+  rewrite !NPEmul_ok. simpl.
+  assert (U1 := split_ok_l (num F1) (num F2) l).
+  assert (U2 := split_ok_r (num F1) (num F2) l).
+  assert (U3 := split_ok_l (denum F1) (denum F2) l).
+  assert (U4 := split_ok_r (denum F1) (denum F2) l).
+  rewrite (IHfe1 Hc2), (IHfe2 Hc3), U1, U2, U3, U4.
+  simpl in U2, U3, U4. apply rdiv7b;
+   rewrite <- ?U2, <- ?U3, <- ?U4; try apply Pcond_Fnorm; trivial.
+
+- rewrite !NPEpow_ok. simpl. rewrite !rpow_pow, (IHfe Hc).
+  destruct n; simpl.
+  + apply rdiv1.
+  + apply pow_pos_div. apply Pcond_Fnorm; trivial.
+Qed.
+
+Theorem Fnorm_crossproduct l fe1 fe2 :
  let nfe1 := Fnorm fe1 in
  let nfe2 := Fnorm fe2 in
- NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
- NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
+ (num nfe1 * denum nfe2) @ l == (num nfe2 * denum nfe1) @ l ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
-intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval by
- apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval by
-  apply PCond_app_inv_r with (1 := Hcond).
-  apply cross_product_eq; trivial.
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_l with (1 := Hcond).
-   apply Pcond_Fnorm.
-     apply PCond_app_inv_r with (1 := Hcond).
+Proof.
+simpl. rewrite PCond_app. intros Hcrossprod (Hc1,Hc2).
+rewrite !Fnorm_FEeval_PEeval; trivial.
+apply cross_product_eq; trivial;
+ apply Pcond_Fnorm; trivial.
 Qed.
 
 (* Correctness lemmas of reflexive tactics *)
-Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow).
-Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
+Notation Ninterp_PElist :=
+  (interp_PElist rO rI radd rmul rsub ropp req phi Cp_phi rpow).
+Notation Nmk_monpol_list :=
+  (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
 
-Theorem Fnorm_correct:
+Theorem Fnorm_ok:
  forall n l lpe fe,
   Ninterp_PElist l lpe ->
   Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
   PCond l (condition (Fnorm fe)) ->  FEeval l fe == 0.
-intros n l lpe fe Hlpe H H1;
- apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
-apply rdiv8; auto.
-transitivity (NPEeval l (PEc cO)); auto.
-rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto.
-change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)).
-apply (Peq_ok Rsth Reqe CRmorph);auto.
-simpl. apply (morph0 CRmorph); auto.
+Proof.
+intros n l lpe fe Hlpe H H1.
+rewrite (Fnorm_FEeval_PEeval l fe H1).
+apply rdiv8. apply Pcond_Fnorm; trivial.
+transitivity (0@l); trivial.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe); trivial.
+change (0 @ l) with (Pphi 0 radd rmul phi l (Pc cO)).
+apply (Peq_ok Rsth Reqe CRmorph); trivial.
 Qed.
 
+Notation ring_rw_correct :=
+ (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec).
+
+Notation ring_rw_pow_correct :=
+ (ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec).
+
+Notation ring_correct :=
+ (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th).
+
 (* simplify a field expression into a fraction *)
 (* TODO: simplify when den is constant... *)
 Definition display_linear l num den :=
@@ -1247,71 +1229,54 @@ Definition display_linear l num den :=
 Definition display_pow_linear l num den :=
   NPphi_pow l num / NPphi_pow l den.
 
-Theorem Field_rw_correct :
- forall n lpe l,
+Theorem Field_rw_correct n lpe l :
    Ninterp_PElist l lpe ->
    forall lmp, Nmk_monpol_list lpe = lmp ->
    forall fe nfe, Fnorm fe = nfe ->
    PCond l (condition nfe) ->
-   FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+   FEeval l fe ==
+     display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
 Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_linear; apply SRdiv_ext;
-  eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
+  intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  rewrite (Fnorm_FEeval_PEeval _ _ H).
+  unfold display_linear; apply rdiv_ext;
+  eapply ring_rw_correct; eauto.
 Qed.
 
-Theorem Field_rw_pow_correct :
- forall n lpe l,
+Theorem Field_rw_pow_correct n lpe l :
    Ninterp_PElist l lpe ->
    forall lmp, Nmk_monpol_list lpe = lmp ->
    forall fe nfe, Fnorm fe = nfe ->
    PCond l (condition nfe) ->
-   FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+   FEeval l fe ==
+     display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
 Proof.
-  intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
-  apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
-  unfold display_pow_linear; apply SRdiv_ext;
-  eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
+  intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+  rewrite (Fnorm_FEeval_PEeval _ _ H).
+  unfold display_pow_linear; apply rdiv_ext;
+  eapply ring_rw_pow_correct;eauto.
 Qed.
 
-Theorem Field_correct :
- forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
+Theorem Field_correct n l lpe fe1 fe2 :
+ Ninterp_PElist l lpe ->
  forall lmp, Nmk_monpol_list lpe = lmp ->
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
- Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
-          (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true ->
+ Peq ceqb (Nnorm n lmp (num nfe1 * denum nfe2))
+          (Nnorm n lmp (num nfe2 * denum nfe1)) = true ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
+intros Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
 apply Fnorm_crossproduct; trivial.
-eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
+eapply ring_correct; eauto.
 Qed.
 
 (* simplify a field equation : generate the crossproduct and simplify
    polynomials *)
-Theorem Field_simplify_eq_old_correct :
- forall l fe1 fe2 nfe1 nfe2,
- Fnorm fe1 = nfe1 ->
- Fnorm fe2 = nfe2 ->
- NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
- NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) ->
- PCond l (condition nfe1 ++ condition nfe2) ->
- FEeval l fe1 == FEeval l fe2.
-Proof.
-intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond;  subst nfe1 nfe2.
-apply Fnorm_crossproduct; trivial.
-match goal with
- [ |- NPEeval l ?x == NPEeval l ?y] =>
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I Logic.eq_refl x Logic.eq_refl);
-    rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
-       O nil l I Logic.eq_refl y Logic.eq_refl)
- end.
-trivial.
-Qed.
+
+(** This allows rewriting modulo the simplification of PEeval on PMul *)
+Declare Equivalent Keys PEeval rmul.
 
 Theorem Field_simplify_eq_correct :
  forall n l lpe fe1 fe2,
@@ -1320,37 +1285,23 @@ Theorem Field_simplify_eq_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ NPphi_dev l (Nnorm n lmp (num nfe1 * right den)) ==
+ NPphi_dev l (Nnorm n lmp (num nfe2 * left den)) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond.
+apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial.
 simpl.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite NPEmul_correct.
-rewrite NPEmul_correct.
+rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3.
+rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3.
 simpl.
-repeat rewrite (ARmul_assoc ARth).
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-rewrite <-(
-  let x := (PEmul (num (Fnorm fe2))
-                     (rsplit_left
-                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-simpl in Hcrossprod.
-rewrite Hcrossprod.
-reflexivity.
+rewrite !rmul_assoc.
+apply rmul_ext; trivial.
+rewrite (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl),
+ (ring_rw_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl).
+rewrite Hlmp.
+apply Hcrossprod.
 Qed.
 
 Theorem Field_simplify_eq_pow_correct :
@@ -1360,37 +1311,55 @@ Theorem Field_simplify_eq_pow_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
- NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ NPphi_pow l (Nnorm n lmp (num nfe1 * right den)) ==
+ NPphi_pow l (Nnorm n lmp (num nfe2 * left den)) ->
  PCond l (condition nfe1 ++ condition nfe2) ->
  FEeval l fe1 == FEeval l fe2.
 Proof.
-intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
-  subst nfe1 nfe2 den lmp.
-apply Fnorm_crossproduct; trivial.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond.
+apply Fnorm_crossproduct; rewrite ?eq1, ?eq2; trivial.
 simpl.
-rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
-rewrite NPEmul_correct.
-rewrite NPEmul_correct.
+rewrite (split_ok_l (denum nfe1) (denum nfe2) l), eq3.
+rewrite (split_ok_r (denum nfe1) (denum nfe2) l), eq3.
 simpl.
-repeat rewrite (ARmul_assoc ARth).
-rewrite <-(
-  let x := PEmul (num (Fnorm fe1))
-                     (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
-ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-rewrite <-(
-  let x := (PEmul (num (Fnorm fe2))
-                     (rsplit_left
-                        (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
-    ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
-        Hlpe Logic.eq_refl
-        x Logic.eq_refl) in Hcrossprod.
-simpl in Hcrossprod.
-rewrite Hcrossprod.
-reflexivity.
+rewrite !rmul_assoc.
+apply rmul_ext; trivial.
+rewrite
+ (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe1 * right den) Logic.eq_refl),
+ (ring_rw_pow_correct n lpe l Hlpe Logic.eq_refl (num nfe2 * left den) Logic.eq_refl).
+rewrite Hlmp.
+apply Hcrossprod.
+Qed.
+
+Theorem Field_simplify_aux_ok l fe1 fe2 den :
+ FEeval l fe1 == FEeval l fe2 ->
+ split (denum (Fnorm fe1)) (denum (Fnorm fe2)) = den ->
+ PCond l (condition (Fnorm fe1) ++ condition (Fnorm fe2)) ->
+ (num (Fnorm fe1) * right den) @ l == (num (Fnorm fe2) * left den) @ l.
+Proof.
+ rewrite PCond_app; intros Hfe Hden (Hc1,Hc2); simpl.
+ assert (Hc1' := Pcond_Fnorm _ _ Hc1).
+ assert (Hc2' := Pcond_Fnorm _ _ Hc2).
+ set (N1 := num (Fnorm fe1)) in *. set (N2 := num (Fnorm fe2)) in *.
+ set (D1 := denum (Fnorm fe1)) in *. set (D2 := denum (Fnorm fe2)) in *.
+ assert (~ (common den) @ l == 0).
+ { intro H. apply Hc1'.
+   rewrite (split_ok_l D1 D2 l).
+   rewrite Hden. simpl. ring [H]. }
+ apply (@rmul_reg_l ((common den) @ l)); trivial.
+ rewrite !(rmul_comm ((common den) @ l)), <- !rmul_assoc.
+ change
+  (N1@l * (right den * common den) @ l ==
+   N2@l * (left den * common den) @ l).
+ rewrite <- Hden, <- split_ok_l, <- split_ok_r.
+ apply (@rmul_reg_l (/ D2@l)). { apply rinv_nz; trivial. }
+ rewrite (rmul_comm (/ D2 @ l)), <- !rmul_assoc.
+ rewrite <- rdiv_def, rdiv_r_r, rmul_1_r by trivial.
+ apply (@rmul_reg_l (/ (D1@l))). { apply rinv_nz; trivial. }
+ rewrite !(rmul_comm  (/ D1@l)), <- !rmul_assoc.
+ rewrite <- !rdiv_def, rdiv_r_r, rmul_1_r by trivial.
+ rewrite (rmul_comm (/ D2@l)), <- rdiv_def.
+ unfold N1,N2,D1,D2; rewrite <- !Fnorm_FEeval_PEeval; trivial.
 Qed.
 
 Theorem Field_simplify_eq_pow_in_correct :
@@ -1400,47 +1369,17 @@ Theorem Field_simplify_eq_pow_in_correct :
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ forall np1, Nnorm n lmp (num nfe1 * right den) = np1 ->
+ forall np2, Nnorm n lmp (num nfe2 * left den) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
  NPphi_pow l np1 ==
  NPphi_pow l np2.
 Proof.
  intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
- ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
- rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (AFth.(AFdiv_def)).
- repeat rewrite <- Fnorm_FEeval_PEeval ; trivial.
- apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+ rewrite !(Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial).
+ simpl. apply Field_simplify_aux_ok; trivial.
 Qed.
 
 Theorem Field_simplify_eq_in_correct :
@@ -1450,47 +1389,16 @@ forall n l lpe fe1 fe2,
  forall nfe1, Fnorm fe1 = nfe1 ->
  forall nfe2, Fnorm fe2 = nfe2 ->
  forall den, split (denum nfe1) (denum nfe2) = den ->
- forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
- forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ forall np1, Nnorm n lmp (num nfe1 * right den) = np1 ->
+ forall np2, Nnorm n lmp (num nfe2 * left den) = np2 ->
  FEeval l fe1 == FEeval l fe2 ->
-  PCond l (condition nfe1 ++ condition nfe2) ->
- NPphi_dev l np1 ==
- NPphi_dev l np2.
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_dev l np1 == NPphi_dev l np2.
 Proof.
  intros. subst nfe1 nfe2 lmp np1 np2.
- repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
- repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
- assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
- assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
- apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
- intro Heq;apply N1.
- rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
- rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
- repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
- repeat rewrite <- ARth.(ARmul_assoc).
- change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
- change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
-      (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
- repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
- rewrite <- split_correct_r.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
- ring [Heq]. rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
- intro Heq; apply AFth.(AF_1_neq_0).
- rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
- ring [Heq]. repeat rewrite (ARth.(ARmul_comm)  (/ NPEeval l (denum (Fnorm fe1)))).
- repeat rewrite <- (ARth.(ARmul_assoc)).
- repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
- rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
- rewrite  (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
- repeat rewrite <- (AFth.(AFdiv_def)).
- repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
- apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+ rewrite !(Pphi_dev_ok Rsth Reqe ARth CRmorph  get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial).
+ apply Field_simplify_aux_ok; trivial.
 Qed.
 
 
@@ -1499,7 +1407,7 @@ Section Fcons_impl.
 Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
 
 Hypothesis PCond_fcons_inv : forall l a l1,
-  PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
+  PCond l (Fcons a l1) ->  ~ a @ l == 0 /\ PCond l l1.
 
 Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
   match l with
@@ -1507,15 +1415,15 @@ Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
   | cons a l1 => Fcons a (Fapp l1 m)
   end.
 
- Lemma fcons_correct : forall l l1,
+Lemma fcons_ok : forall l l1,
   (forall lock, lock = PCond l -> lock (Fapp l1 nil)) -> PCond l l1.
- Proof.
- intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1.
- induction l1; simpl; intros.
-  trivial.
-  elim PCond_fcons_inv with (1 := H); intros.
-  destruct l1; trivial. split; trivial. apply IHl1; trivial.
- Qed.
+Proof.
+intros l l1 h1; assert (H := h1 (PCond l) (refl_equal _));clear h1.
+induction l1; simpl; intros.
+ trivial.
+ elim PCond_fcons_inv with (1 := H); intros.
+ destruct l1; trivial. split; trivial. apply IHl1; trivial.
+Qed.
 
 End Fcons_impl.
 
@@ -1531,21 +1439,15 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
  end.
 
 Theorem PFcons_fcons_inv:
- forall l a l1, PCond l (Fcons a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons; auto.
-simpl; auto.
-intros a0 l0.
-generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
-intros H H0 H1; split; auto.
-rewrite H; auto.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-generalize Hp; case l0; simpl; intuition.
+ forall l a l1, PCond l (Fcons a l1) ->  ~ a @ l == 0 /\ PCond l l1.
+Proof.
+induction l1 as [|e l1]; simpl Fcons.
+- simpl; now split.
+- case PExpr_eq_spec; intros H; rewrite !PCond_cons; intros (H1,H2);
+   repeat split; trivial.
+  + now rewrite H.
+  + now apply IHl1.
+  + now apply IHl1.
 Qed.
 
 (* equality of normal forms rather than syntactic equality *)
@@ -1558,23 +1460,16 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
  end.
 
 Theorem PFcons0_fcons_inv:
- forall l a l1, PCond l (Fcons0 a l1) ->  ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a l1; elim l1; simpl Fcons0; auto.
-simpl; auto.
-intros a0 l0.
-generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl.
-  case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)).
-intros H H0 H1; split; auto.
-rewrite H; auto.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-intros H H0 H1;
- assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
-split.
-generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
-apply H0.
-generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
-clear get_sign get_sign_spec.
-generalize Hp; case l0; simpl; intuition.
+ forall l a l1, PCond l (Fcons0 a l1) ->  ~ a @ l == 0 /\ PCond l l1.
+Proof.
+induction l1 as [|e l1]; simpl Fcons0.
+- simpl; now split.
+- generalize (ring_correct O l nil a e). lazy zeta; simpl Peq.
+  case Peq; intros H; rewrite !PCond_cons; intros (H1,H2);
+   repeat split; trivial.
+  + now rewrite H.
+  + now apply IHl1.
+  + now apply IHl1.
 Qed.
 
 (* split factorized denominators *)
@@ -1586,95 +1481,83 @@ Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  end.
 
 Theorem PFcons00_fcons_inv:
-  forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl.
-   apply field_is_integral_domain; trivial.
-   simpl;intros. rewrite pow_th.(rpow_pow_N).
-   destruct (H _ H0);split;auto.
-   destruct n;simpl. apply AFth.(AF_1_neq_0).
-   apply pow_pos_not_0;trivial.
+  forall l a l1, PCond l (Fcons00 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail).
+- intros p H p0 H0 l1 H1.
+  simpl in H1.
+  destruct (H _ H1) as (H2,H3).
+  destruct (H0 _ H3) as (H4,H5). split; trivial.
+  simpl.
+  apply field_is_integral_domain; trivial.
+- intros. destruct (H _ H0). split; trivial.
+  apply PEpow_nz; trivial.
 Qed.
 
 Definition Pcond_simpl_gen :=
-  fcons_correct _ PFcons00_fcons_inv.
+  fcons_ok _ PFcons00_fcons_inv.
 
 
 (* Specific case when the equality test of coefs is complete w.r.t. the
    field equality: non-zero coefs can be eliminated, and opposite can
    be simplified (if -1 <> 0) *)
 
-Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
+Hypothesis ceqb_complete : forall c1 c2, [c1] == [c2] -> ceqb c1 c2 = true.
 
-Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
-  (phi c1 == phi c2 -> P x) ->
-  (~ phi c1 == phi c2 -> P y) ->
-  P (if ceqb c1 c2 then x else y).
+Lemma ceqb_spec' c1 c2 : Bool.reflect ([c1] == [c2]) (ceqb c1 c2).
 Proof.
-intros.
-generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
-generalize (@ceqb_complete c1 c2).
-case (c1 ?=! c2); auto; intros.
-apply X0.
-red; intro.
-absurd (false = true); auto;  discriminate.
+assert (H := morph_eq CRmorph c1 c2).
+assert (H' := @ceqb_complete c1 c2).
+destruct (ceqb c1 c2); constructor.
+- now apply H.
+- intro E. specialize (H' E). discriminate.
 Qed.
 
 Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
  match e with
-   PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
+ | PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
  | PEpow e _ => Fcons1 e l
- | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
- | PEc c => if ceqb c cO then absurd_PCond else l
+ | PEopp e => if (-(1) =? 0)%coef then absurd_PCond else Fcons1 e l
+ | PEc c => if (c =? 0)%coef then absurd_PCond else l
  | _ => Fcons0 e l
  end.
 
 Theorem PFcons1_fcons_inv:
-  forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
-intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
- simpl; intros c l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H0).
-  split; trivial.
-    rewrite <- (morph0 CRmorph); trivial.
- intros p H p0 H0 l1 H1.
-   simpl in H1.
-   case (H _ H1); intros H2 H3.
-   case (H0 _ H3); intros H4 H5; split; auto.
-   simpl.
-   apply field_is_integral_domain; trivial.
- simpl; intros p H l1.
-   apply ceqb_rect_complete; intros.
-  elim (@absurd_PCond_bottom l H1).
-  destruct (H _ H1).
+  forall l a l1, PCond l (Fcons1 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; trivial; fail).
+- simpl; intros c l1.
+  case ceqb_spec'; intros H H0.
+  + elim (@absurd_PCond_bottom l H0).
+  + split; trivial. rewrite <- phi_0; trivial.
+- intros p H p0 H0 l1 H1. simpl in H1.
+  destruct (H _ H1) as (H2,H3).
+  destruct (H0 _ H3) as (H4,H5).
+  split; trivial. simpl. apply field_is_integral_domain; trivial.
+- simpl; intros p H l1.
+  case ceqb_spec'; intros H0 H1.
+  + elim (@absurd_PCond_bottom l H1).
+  + destruct (H _ H1).
     split; trivial.
     apply ropp_neq_0; trivial.
-    rewrite (morph_opp CRmorph) in H0.
-    rewrite (morph1 CRmorph) in H0.
-    rewrite (morph0 CRmorph) in H0.
-    trivial.
- intros;simpl. destruct (H _ H0);split;trivial.
- rewrite pow_th.(rpow_pow_N). destruct n;simpl.
- apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
+    rewrite (morph_opp CRmorph), phi_0, phi_1 in H0. trivial.
+- intros. destruct (H _ H0);split;trivial. apply PEpow_nz; trivial.
 Qed.
 
-Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
+Definition Fcons2 e l := Fcons1 (PEsimp e) l.
 
 Theorem PFcons2_fcons_inv:
- forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+ forall l a l1, PCond l (Fcons2 a l1) -> ~ a @ l == 0 /\ PCond l l1.
+Proof.
 unfold Fcons2; intros l a l1 H; split;
- case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
+ case (PFcons1_fcons_inv l (PEsimp a) l1); trivial.
 intros H1 H2 H3; case H1.
-transitivity (NPEeval l a); trivial.
-apply PExpr_simp_correct.
+transitivity (a@l); trivial.
+apply PEsimp_ok.
 Qed.
 
 Definition Pcond_simpl_complete :=
-  fcons_correct _ PFcons2_fcons_inv.
+  fcons_ok _ PFcons2_fcons_inv.
 
 End Fcons_simpl.
 
@@ -1742,22 +1625,22 @@ Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
 
 Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
 
-Lemma add_inj_r : forall p x y,
+Lemma add_inj_r p x y :
    gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
-intros p x y.
+Proof.
 elim p using Pos.peano_ind; simpl; intros.
  apply S_inj; trivial.
  apply H.
    apply S_inj.
-   repeat rewrite (ARadd_assoc ARth).
+   rewrite !(ARadd_assoc ARth).
    rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); trivial.
 Qed.
 
-Lemma gen_phiPOS_inj : forall x y,
+Lemma gen_phiPOS_inj x y :
   gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
   x = y.
-intros x y.
-repeat rewrite <- (same_gen Rsth Reqe ARth).
+Proof.
+rewrite <- !(same_gen Rsth Reqe ARth).
 case (Pos.compare_spec x y).
  intros.
    trivial.
@@ -1777,9 +1660,10 @@ case (Pos.compare_spec x y).
 Qed.
 
 
-Lemma gen_phiN_inj : forall x y,
+Lemma gen_phiN_inj x y :
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
   x = y.
+Proof.
 destruct x; destruct y; simpl; intros; trivial.
  elim gen_phiPOS_not_0 with p.
    symmetry .
@@ -1789,7 +1673,7 @@ destruct x; destruct y; simpl; intros; trivial.
  rewrite gen_phiPOS_inj with (1 := H); trivial.
 Qed.
 
-Lemma gen_phiN_complete : forall x y,
+Lemma gen_phiN_complete x y :
   gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
   N.eqb x y = true.
 Proof.
@@ -1808,31 +1692,22 @@ Section Field.
  Let AFth := F2AF Rsth Reqe Fth.
  Let ARth := Rth_ARth Rsth Reqe Rth.
 
-Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
+Lemma ring_S_inj x y : 1+x==1+y -> x==y.
+Proof.
 intros.
-transitivity (x + (1 + - (1))).
- rewrite (Ropp_def Rth).
-   symmetry .
-   apply (ARadd_0_r Rsth ARth).
- transitivity (y + (1 + - (1))).
-  repeat rewrite <- (ARplus_assoc ARth).
-    repeat rewrite (ARadd_assoc ARth).
-    apply (Radd_ext Reqe).
-   repeat rewrite <- (ARadd_comm ARth 1).
-     trivial.
-   reflexivity.
-  rewrite (Ropp_def Rth).
-    apply (ARadd_0_r Rsth ARth).
+rewrite <- (ARadd_0_l ARth x), <- (ARadd_0_l ARth y).
+rewrite <- (Ropp_def Rth 1), (ARadd_comm ARth 1).
+rewrite <- !(ARadd_assoc ARth). now apply (Radd_ext Reqe).
 Qed.
 
-
- Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
 
 Let gen_phiPOS_inject :=
    gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
 
-Lemma gen_phiPOS_discr_sgn : forall x y,
+Lemma gen_phiPOS_discr_sgn x y :
   ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
+Proof.
 red; intros.
 apply gen_phiPOS_not_0 with (y + x)%positive.
 rewrite (ARgen_phiPOS_add Rsth Reqe ARth).
@@ -1845,9 +1720,10 @@ transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
  apply (Ropp_def Rth).
 Qed.
 
-Lemma gen_phiZ_inj : forall x y,
+Lemma gen_phiZ_inj x y :
   gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
   x = y.
+Proof.
 destruct x; destruct y; simpl; intros.
  trivial.
  elim gen_phiPOS_not_0 with p.
@@ -1878,9 +1754,10 @@ destruct x; destruct y; simpl; intros.
    reflexivity.
 Qed.
 
-Lemma gen_phiZ_complete : forall x y,
+Lemma gen_phiZ_complete x y :
   gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
   Zeq_bool x y = true.
+Proof.
 intros.
  replace y with x.
  unfold Zeq_bool.
@@ -1891,3 +1768,6 @@ Qed.
 End Field.
 
 End Complete.
+
+Arguments FEO [C].
+Arguments FEI [C].
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index e106d5b5..b92b847b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import ZArith_base.
-Require Import Zpow_def.
+Require Import Zbool.
 Require Import BinInt.
 Require Import BinNat.
 Require Import Setoid.
@@ -16,6 +15,7 @@ Require Import Ring_polynom.
 Import List.
 
 Set Implicit Arguments.
+(* Set Universe Polymorphism. *)
 
 Import RingSyntax.
 
@@ -815,7 +815,7 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
                   fun f => f arth ext_r morph lemma1 lemma2
                 | _ => fail 4 "ring: bad sign specification"
                 end
-             | _ => fail 3 "ring: bad coefficiant division specification"
+             | _ => fail 3 "ring: bad coefficient division specification"
              end
           | _ => fail 2 "ring: bad power specification"
           end
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index cfd00521..a10eeecc 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -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/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v
index 95d7deee..2dc3197d 100644
--- a/plugins/setoid_ring/Ncring.v
+++ b/plugins/setoid_ring/Ncring.v
@@ -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/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index 516a993e..c40e0ffb 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -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        *)
@@ -192,6 +192,7 @@ Lemma gen_phiZ_opp : forall x, [- x] == - [x].
  Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
  Proof. intros;subst;reflexivity. Qed.
 
+Declare Equivalent Keys bracket gen_phiZ.
 (*proof that [.] satisfies morphism specifications*)
 Global Instance gen_phiZ_morph :
 (@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*)
diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v
index eefc9428..5845b629 100644
--- a/plugins/setoid_ring/Ncring_polynom.v
+++ b/plugins/setoid_ring/Ncring_polynom.v
@@ -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        *)
@@ -103,7 +103,7 @@ Variable P:Pol.
 
 (* Xi^n * P + Q
 les variables de tete de Q ne sont pas forcement < i 
-mais Q est normalisé : variables de tete decroissantes *)
+mais Q est normalisé : variables de tete decroissantes *)
 
 Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:=
   match Q with
@@ -216,8 +216,8 @@ Definition Psub(P P':Pol):= P ++ (--P').
   intros l P i n Q;unfold mkPX.
   destruct P;try (simpl;reflexivity).
   assert (Hh := ring_morphism_eq  c 0). 
-simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
-intros.
+  simpl; case_eq (Ceqb c 0);simpl;try reflexivity.
+  intros.
   rewrite Hh. rewrite ring_morphism0.
   rsimpl. apply Ceqb_eq. trivial.
   destruct (Pos.compare_spec i p).
@@ -416,10 +416,13 @@ Qed.
  Variable pow_th : power_theory Cp_phi rpow.
 
  (** evaluation of polynomial expressions towards R *)
+
  Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R :=
    match pe with
+   | PEO => 0
+   | PEI => 1
    | PEc c => [c]
-   | PEX j => nth 0 j l
+   | PEX _ j => nth 0 j l
    | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
    | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2)
    | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2)
@@ -500,8 +503,10 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
 
   Fixpoint norm_aux (pe:PExpr C) : Pol :=
    match pe with
+   | PEO => Pc cO
+   | PEI => Pc cI
    | PEc c => Pc c
-   | PEX j => mk_X j
+   | PEX _ j => mk_X j
    | PEadd pe1 (PEopp pe2) =>
      Psub (norm_aux pe1) (norm_aux pe2)
    | PEadd pe1 pe2 => Padd (norm_aux  pe1) (norm_aux pe2)
@@ -520,28 +525,30 @@ Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) :=
   Proof.
    intros.
    induction pe.
-Esimpl3. Esimpl3. simpl.
- rewrite IHpe1;rewrite IHpe2.
- destruct pe2; Esimpl3. 
-unfold Psub.
-destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
-simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
-destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity.
-Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
- Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3.
-simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
-simpl. rewrite IHpe; Esimpl3. 
-simpl.
-   rewrite Ppow_N_ok; (intros;try reflexivity). 
-   rewrite rpow_pow_N.  Esimpl3.
-   induction n;simpl. Esimpl3. induction p; simpl.
-  try rewrite IHp;try rewrite IHpe;
- repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;reflexivity.
-rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe;
- repeat rewrite Pms_ok;
-      repeat rewrite Pmul_ok;reflexivity. trivial.
-exact pow_th.
+   - now simpl; rewrite <- ring_morphism0.
+   - now simpl; rewrite <- ring_morphism1.
+   - Esimpl3. 
+   - Esimpl3. 
+   - simpl.
+     rewrite IHpe1;rewrite IHpe2.
+     destruct pe2; Esimpl3. 
+     unfold Psub.
+     destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity.
+   - simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2.
+     now destruct pe1; 
+       [destruct pe2; rewrite Padd_ok; rewrite Popp_ok; Esimpl3 | Esimpl3..]. 
+   - simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity.
+   - now simpl; rewrite IHpe; Esimpl3. 
+   - simpl.
+     rewrite Ppow_N_ok; (intros;try reflexivity). 
+     rewrite rpow_pow_N; [| now apply pow_th]. 
+     induction n;simpl; [now Esimpl3|]. 
+     induction p; simpl; trivial.
+     + try rewrite IHp;try rewrite IHpe;
+         repeat rewrite Pms_ok; repeat rewrite Pmul_ok;reflexivity.
+     + rewrite Pmul_ok. 
+       try rewrite IHp;try rewrite IHpe; repeat rewrite Pms_ok;
+         repeat rewrite Pmul_ok;reflexivity. 
   Qed.
 
  Lemma norm_subst_spec :
diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v
index 4fb02909..31c9e54d 100644
--- a/plugins/setoid_ring/Ncring_tac.v
+++ b/plugins/setoid_ring/Ncring_tac.v
@@ -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        *)
@@ -76,11 +76,11 @@ Instance  reify_mul (R:Type)
  : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10.
 
 Instance  reify_mul_ext (R:Type) `{Ring R}
-  lvar z e2 t2 
+  lvar (z:Z) e2 t2 
  `{Ring (T:=R)}
  {_:reify e2 lvar t2}
  : reify (PEmul (PEc z) e2) lvar
-      (@multiplication Z _ _  z t2)|9.
+      (@multiplication Z _ _ z t2)|9.
 
 Instance  reify_sub (R:Type)
  e1 lvar t1 e2 t2 op
@@ -127,7 +127,6 @@ Definition list_reifyl (R:Type) lexpr lvar lterm
 
 Unset Implicit Arguments.
 
-
 Ltac lterm_goal g :=
   match g with
   | ?t1 == ?t2 => constr:(t1::t2::nil)
@@ -138,6 +137,7 @@ Ltac lterm_goal g :=
 Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
  intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. 
 
+
 Ltac reify_goal lvar lexpr lterm:=
   (*idtac lvar; idtac lexpr; idtac lterm;*)
   match lexpr with
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index 98150d35..b2417db6 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -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/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index b64023ea..9508b8e7 100644
--- a/plugins/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -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/plugins/setoid_ring/Ring_equiv.v b/plugins/setoid_ring/Ring_equiv.v
deleted file mode 100644
index 945f6c68..00000000
--- a/plugins/setoid_ring/Ring_equiv.v
+++ /dev/null
@@ -1,74 +0,0 @@
-Require Import Setoid_ring_theory.
-Require Import LegacyRing_theory.
-Require Import Ring_theory.
-
-Set Implicit Arguments.
-
-Section Old2New.
-
-Variable A : Type.
-
-Variable Aplus : A -> A -> A.
-Variable Amult : A -> A -> A.
-Variable Aone : A.
-Variable Azero : A.
-Variable Aopp : A -> A.
-Variable Aeq : A -> A -> bool.
-Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
-
-Let Aminus := fun x y => Aplus x (Aopp y).
-
-Lemma ring_equiv1 :
-  ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
-Proof.
-destruct R.
-split;  eauto.
-Qed.
-
-End Old2New.
-
-Section New2OldRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
- Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma ring_equiv2 :
-   Ring_Theory radd  rmul rI rO ropp reqb.
-Proof.
-elim Rth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
- Definition default_eqb : R -> R -> bool := fun x y => false.
- Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
-Proof.
-discriminate 1.
-Qed.
-
-End New2OldRing.
-
-Section New2OldSemiRing.
- Variable R : Type.
- Variable (rO rI : R) (radd rmul: R->R->R).
- Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
-
- Variable reqb : R -> R -> bool.
- Variable reqb_ok : forall x y, reqb x y = true -> x = y.
-
- Lemma sring_equiv2 :
-   Semi_Ring_Theory radd rmul rI rO reqb.
-Proof.
-elim SRth; intros; constructor;  eauto.
-intros.
-apply reqb_ok.
-destruct (reqb x y); trivial; intros.
-elim H.
-Qed.
-
-End New2OldSemiRing.
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 21d3099c..2d2756b1 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -1,17 +1,19 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
+
 Set Implicit Arguments.
-Require Import Setoid Morphisms BinList BinPos BinNat BinInt.
+Require Import Setoid Morphisms. 
+Require Import BinList BinPos BinNat BinInt.
 Require Export Ring_theory.
-
 Local Open Scope positive_scope.
 Import RingSyntax.
+(* Set Universe Polymorphism. *)
 
 Section MakeRingPol.
 
@@ -372,17 +374,6 @@ Section MakeRingPol.
 
  Infix "**" := Pmul.
 
- Fixpoint Psquare (P:Pol) : Pol :=
-   match P with
-   | Pc c => Pc (c *! c)
-   | Pinj j Q => Pinj j (Psquare Q)
-   | PX P i Q =>
-     let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
-     let Q2 := Psquare Q in
-     let P2 := Psquare P in
-     mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
-   end.
-
  (** Monomial **)
 
  (** A monomial is X1^k1...Xi^ki. Its representation
@@ -511,6 +502,29 @@ Section MakeRingPol.
  Reserved Notation "P @ l " (at level 10, no associativity).
  Notation "P @ l " := (Pphi l P).
 
+ Definition Pequiv (P Q : Pol) := forall l, P@l == Q@l.
+ Infix "===" := Pequiv (at level 70, no associativity).
+
+ Instance Pequiv_eq : Equivalence Pequiv.
+ Proof.
+  unfold Pequiv; split; red; intros; [reflexivity|now symmetry|now etransitivity].
+ Qed.
+
+ Instance Pphi_ext : Proper (eq ==> Pequiv ==> req) Pphi.
+ Proof.
+  now intros l l' <- P Q H.
+ Qed.
+
+ Instance Pinj_ext : Proper (eq ==> Pequiv ==> Pequiv) Pinj.
+ Proof.
+  intros i j <- P P' HP l. simpl. now rewrite HP.
+ Qed.
+
+ Instance PX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) PX.
+ Proof.
+  intros P P' HP p p' <- Q Q' HQ l. simpl. now rewrite HP, HQ.
+ Qed.
+
  (** Evaluation of a monomial towards R *)
 
  Fixpoint Mphi(l:list R) (M: Mon) : R :=
@@ -532,8 +546,9 @@ Section MakeRingPol.
  Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l).
  Proof. rewrite Pos.add_comm. apply jump_add. Qed.
 
- Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l.
+ Lemma Peq_ok P P' : (P ?== P') = true -> P === P'.
  Proof.
+  unfold Pequiv.
   revert P';induction P;destruct P';simpl; intros H l; try easy.
   - now apply (morph_eq CRmorph).
   - destruct (Pos.compare_spec p p0); [ subst | easy | easy ].
@@ -545,8 +560,7 @@ Section MakeRingPol.
     now rewrite IHP1, IHP2.
  Qed.
 
- Lemma Peq_spec P P' :
-   BoolSpec (forall l, P@l == P'@l) True (P ?== P').
+ Lemma Peq_spec P P' : BoolSpec (P === P') True (P ?== P').
  Proof.
   generalize (Peq_ok P P'). destruct (P ?== P'); auto.
  Qed.
@@ -567,6 +581,11 @@ Section MakeRingPol.
   now rewrite jump_add'.
  Qed.
 
+ Instance mkPinj_ext : Proper (eq ==> Pequiv ==> Pequiv) mkPinj.
+ Proof.
+  intros i j <- P Q H l. now rewrite !mkPinj_ok.
+ Qed.
+
  Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j.
  Proof.
   rewrite Pos.add_comm.
@@ -590,6 +609,11 @@ Section MakeRingPol.
     rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl.
  Qed.
 
+ Instance mkPX_ext : Proper (Pequiv ==> eq ==> Pequiv ==> Pequiv) mkPX.
+ Proof.
+  intros P P' HP i i' <- Q Q' HQ l. now rewrite !mkPX_ok, HP, HQ.
+ Qed.
+
  Hint Rewrite
   Pphi0
   Pphi1
@@ -656,7 +680,7 @@ Section MakeRingPol.
   - add_permut.
   - destruct p; simpl;
     rewrite ?jump_pred_double; add_permut.
-  - destr_pos_sub; intros ->;Esimpl.
+  - destr_pos_sub; intros ->; Esimpl.
     + rewrite IHP';rsimpl. add_permut.
     + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
     + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
@@ -689,47 +713,23 @@ Section MakeRingPol.
         rewrite IHP'2, pow_pos_add; rsimpl. add_permut.
  Qed.
 
- Lemma PsubX_ok P' P k l :
-  (forall P l, (P--P')@l == P@l - P'@l) ->
-  (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k.
+ Lemma Psub_opp P' P : P -- P' === P ++ (--P').
  Proof.
-  intros IHP'.
-  revert k l. induction P;simpl;intros.
-  - rewrite Popp_ok;rsimpl; add_permut.
-  - destruct p; simpl;
-    rewrite Popp_ok;rsimpl;
-    rewrite ?jump_pred_double; add_permut.
-  - destr_pos_sub; intros ->; Esimpl.
-    + rewrite IHP';rsimpl. add_permut.
-    + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut.
-    + rewrite IHP1, pow_pos_add;rsimpl. add_permut.
+  revert P; induction P'; simpl; intros.
+  - intro l; Esimpl.
+  - revert p; induction P; simpl; intros; try reflexivity.
+    + destr_pos_sub; intros ->; now apply mkPinj_ext.
+    + destruct p0; now apply PX_ext.
+  - destruct P; simpl; try reflexivity.
+    + destruct p0; now apply PX_ext.
+    + destr_pos_sub; intros ->; apply mkPX_ext; auto.
+      revert p1. induction P2; simpl; intros; try reflexivity.
+      destr_pos_sub; intros ->; now apply mkPX_ext.
  Qed.
 
  Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l.
  Proof.
-  revert P l; induction P';simpl;intros;Esimpl.
-  - revert p l; induction P;simpl;intros.
-    + Esimpl; add_permut.
-    + destr_pos_sub; intros ->;Esimpl.
-      * rewrite IHP';rsimpl.
-      * rewrite IHP';Esimpl. now rewrite jump_add'.
-      * rewrite IHP. now rewrite jump_add'.
-    + destruct p0;simpl.
-      * rewrite IHP2;simpl. rsimpl.
-      * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl.
-      * rewrite IHP'. rsimpl.
-  - destruct P;simpl.
-    + Esimpl; add_permut.
-    + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl.
-      * rsimpl. add_permut.
-      * rewrite jump_pred_double. rsimpl. add_permut.
-      * rsimpl. add_permut.
-    + destr_pos_sub; intros ->; Esimpl.
-      * rewrite IHP'1, IHP'2;rsimpl. add_permut.
-      * rewrite IHP'1, IHP'2;simpl;Esimpl.
-        rewrite pow_pos_add;rsimpl. add_permut.
-      * rewrite PsubX_ok by trivial;rsimpl.
-        rewrite IHP'2, pow_pos_add;rsimpl. add_permut.
+  rewrite Psub_opp, Padd_ok, Popp_ok. rsimpl.
  Qed.
 
  Lemma PmulI_ok P' :
@@ -764,15 +764,6 @@ Section MakeRingPol.
       add_permut; f_equiv; mul_permut.
  Qed.
 
- Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l.
- Proof.
-  revert l;induction P;simpl;intros;Esimpl.
-  - apply IHP.
-  - rewrite Padd_ok, Pmul_ok;Esimpl.
-    rewrite IHP1, IHP2.
-    mul_push ((hd l)^p). now mul_push (P2@l).
- Qed.
-
  Lemma mkZmon_ok M j l :
    (mkZmon j M) @@ l == (zmon j M) @@ l.
  Proof.
@@ -807,9 +798,9 @@ Section MakeRingPol.
      P@l == Q@l + [c] * R@l.
  Proof.
  revert l.
- induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl.
- - assert (H := div_th.(div_eucl_th) c0 c).
-   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
+ induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. 
+ - assert (H := div_th.(div_eucl_th) c0 c). 
+   destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. 
  - destr_factor. Esimpl.
  - destr_factor. Esimpl. add_permut.
  Qed.
@@ -818,11 +809,12 @@ Section MakeRingPol.
    let (c,M) := cM in
    let (Q,R) := MFactor P c M in
      P@l == Q@l + [c] * M@@l * R@l.
- Proof.
+ Proof. 
  destruct cM as (c,M). revert M l.
- induction P; destruct M; intros l; simpl; auto;
+ induction P; destruct M; intros l; simpl; auto; 
  try (case ceqb_spec; intro He);
-  try (case Pos.compare_spec; intros He); rewrite ?He;
+  try (case Pos.compare_spec; intros He);
+  rewrite ?He;
    destr_factor; simpl; Esimpl.
  - assert (H := div_th.(div_eucl_th) c0 c).
    destruct cdiv as (q,r). rewrite H; Esimpl. add_permut.
@@ -880,9 +872,9 @@ Section MakeRingPol.
  Lemma PSubstL1_ok n LM1 P1 l :
    MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
  Proof.
- revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros.
- - reflexivity.
- - rewrite <- IH by intuition. now apply PNSubst1_ok.
+ revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. 
+ - reflexivity. 
+ - rewrite <- IH by intuition; now apply PNSubst1_ok.
  Qed.
 
  Lemma PSubstL_ok n LM1 P1 P2 l :
@@ -907,6 +899,8 @@ Section MakeRingPol.
  (** Definition of polynomial expressions *)
 
  Inductive PExpr : Type :=
+  | PEO : PExpr
+  | PEI : PExpr            
   | PEc : C -> PExpr
   | PEX : positive -> PExpr
   | PEadd : PExpr -> PExpr -> PExpr
@@ -915,6 +909,7 @@ Section MakeRingPol.
   | PEopp : PExpr -> PExpr
   | PEpow : PExpr -> N -> PExpr.
 
+
  (** evaluation of polynomial expressions towards R *)
  Definition mk_X j := mkPinj_pred j mkX.
 
@@ -922,6 +917,8 @@ Section MakeRingPol.
 
  Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R :=
    match pe with
+   | PEO => rO
+   | PEI => rI
    | PEc c => phi c
    | PEX j => nth 0 j l
    | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2)
@@ -985,11 +982,13 @@ Section POWER.
   Variable n : nat.
   Variable lmp:list (C*Mon*Pol).
   Let subst_l P := PNSubstL P lmp n n.
-  Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+  Let Pmul_subst P1 P2 := subst_l (P1 ** P2).
   Let Ppow_subst := Ppow_N subst_l.
 
   Fixpoint norm_aux (pe:PExpr) : Pol :=
    match pe with
+   | PEO => Pc cO
+   | PEI => Pc cI
    | PEc c => Pc c
    | PEX j => mk_X j
    | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1)
@@ -1021,7 +1020,7 @@ Section POWER.
     end.
   Proof.
   simpl (norm_aux (PEadd _ _)).
-  destruct pe1; [ | | | | | reflexivity | ];
+  destruct pe1; [ | | | | | | | reflexivity | ];
    destruct pe2; simpl get_PEopp; reflexivity.
   Qed.
 
@@ -1034,22 +1033,26 @@ Section POWER.
   now destruct pe.
   Qed.
 
+  Arguments norm_aux !pe : simpl nomatch.
+
   Lemma norm_aux_spec l pe :
     PEeval l pe == (norm_aux pe)@l.
   Proof.
    intros.
-   induction pe.
+   induction pe; cbn.
+   - now rewrite (morph0 CRmorph). 
+   - now rewrite (morph1 CRmorph).
    - reflexivity.
    - apply mkX_ok.
-   - simpl PEeval. rewrite IHpe1, IHpe2.
+   - rewrite IHpe1, IHpe2.
      assert (H1 := norm_aux_PEopp pe1).
      assert (H2 := norm_aux_PEopp pe2).
      rewrite norm_aux_PEadd.
      do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut.
-   - simpl. rewrite IHpe1, IHpe2. Esimpl.
-   - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
-   - simpl. rewrite IHpe. Esimpl.
-   - simpl. rewrite Ppow_N_ok by reflexivity.
+   - rewrite IHpe1, IHpe2. Esimpl.
+   - rewrite IHpe1, IHpe2. now rewrite Pmul_ok.
+   - rewrite IHpe. Esimpl.
+   - rewrite Ppow_N_ok by reflexivity.
      rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl.
      induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok.
   Qed.
@@ -1483,3 +1486,6 @@ Qed.
  Qed.
 
 End MakeRingPol.
+
+Arguments PEO [C].
+Arguments PEI [C].
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index 7a7ffcfd..77863edc 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -196,12 +196,17 @@ Ltac get_MonPol lemma :=
 (********************************************************)
 
 (* Building the atom list of a ring expression *)
-Ltac FV Cst CstPow add mul sub opp pow t fv :=
+(* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+(* the tactic could be used to discriminate occurrences of an opaque *)
+(* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac FV Cst CstPow rO rI add mul sub opp pow t fv :=
  let rec TFV t fv :=
   let f :=
   match Cst t with
   | NotConstant =>
       match t with
+      | rO =>  fun _ => fv
+      | rI =>  fun _ => fv
       | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
       | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
       | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
@@ -219,32 +224,39 @@ Ltac FV Cst CstPow add mul sub opp pow t fv :=
  in TFV t fv.
 
  (* syntaxification of ring expressions *)
-Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
+ (* We do not assume that Cst recognizes the rO and rI terms as constants, as *)
+ (* the tactic could be used to discriminate occurrences of an opaque *)
+ (* constant phi, with (phi 0) not convertible to 0 for instance *)
+Ltac mkPolexpr C Cst CstPow rO rI radd rmul rsub ropp rpow t fv :=
  let rec mkP t :=
     let f :=
     match Cst t with
     | InitialRing.NotConstant =>
         match t with
+        | rO => 
+          fun _ => constr:(@PEO C)
+        | rI => 
+          fun _ => constr:(@PEI C)
         | (radd ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEadd e1 e2)
+          let e2 := mkP t2 in constr:(@PEadd C e1 e2)
         | (rmul ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEmul e1 e2)
+          let e2 := mkP t2 in constr:(@PEmul C e1 e2)
         | (rsub ?t1 ?t2) =>
           fun _ =>
           let e1 := mkP t1 in
-          let e2 := mkP t2 in constr:(PEsub e1 e2)
+          let e2 := mkP t2 in constr:(@PEsub C e1 e2)
         | (ropp ?t1) =>
           fun _ =>
-          let e1 := mkP t1 in constr:(PEopp e1)
+          let e1 := mkP t1 in constr:(@PEopp C e1)
         | (rpow ?t1 ?n) =>
           match CstPow n with
           | InitialRing.NotConstant =>
             fun _ => let p := Find_at t fv in constr:(PEX C p)
-          | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
+          | ?c => fun _ => let e1 := mkP t1 in constr:(@PEpow C e1 c)
           end
         | _ =>
           fun _ => let p := Find_at t fv in constr:(PEX C p)
@@ -260,58 +272,58 @@ Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post :=
   let RNG :=
     match type of lemma1 with
     | context
-       [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+       [@PEeval ?R ?r0 ?r1 ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
         (fun proj => proj
              cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2)
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2)
     | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
     end in
   F RNG.
 
 Ltac get_Carrier RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             R).
 
 Ltac get_Eq RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             req).
 
 Ltac get_Pre RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             pre).
 
 Ltac get_Post RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             post).
 
 Ltac get_NormLemma RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             lemma1).
 
 Ltac get_SimplifyLemma RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
             lemma2).
 
 Ltac get_RingFV RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-            FV cst_tac pow_tac add mul sub opp pow).
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            FV cst_tac pow_tac r0 r1 add mul sub opp pow).
 
 Ltac get_RingMeta RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-            mkPolexpr C cst_tac pow_tac add mul sub opp pow).
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+            mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow).
 
 Ltac get_RingHypTac RNG :=
   RNG ltac:(fun cst_tac pow_tac pre post
-             R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
-       let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in
+             R req r0 r1 add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+       let mkPol := mkPolexpr C cst_tac pow_tac r0 r1 add mul sub opp pow in
        fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
 
 (* ring tactics *)
@@ -338,8 +350,8 @@ Ltac Ring RNG lemma lH :=
     (apply (lemma vfv vlpe pe1 pe2)
       || fail "typing error while applying ring");
     [ ((let prh := proofHyp_tac lH in exact prh)
-        || idtac "can not automatically proof hypothesis :";
-           idtac " maybe a left member of a hypothesis is not a monomial")
+        || idtac "can not automatically prove hypothesis :";
+           [> idtac " maybe a left member of a hypothesis is not a monomial"..])
     | vm_compute;
       (exact (eq_refl true) || fail "not a valid ring equation")]).
 
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index af43b0ab..4f05f0d4 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -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        *)
@@ -28,6 +28,8 @@ Reserved Notation "x == y" (at level 70, no associativity).
 End RingSyntax.
 Import RingSyntax.
 
+(* Set Universe Polymorphism. *)
+
 Section Power.
  Variable R:Type.
  Variable rI : R.
@@ -252,6 +254,7 @@ Section ALMOST_RING.
 
  Section SEMI_RING.
  Variable SReqe : sring_eq_ext radd rmul req.
+
    Add Morphism radd : radd_ext1.  exact (SRadd_ext SReqe). Qed.
    Add Morphism rmul : rmul_ext1.  exact (SRmul_ext SReqe). Qed.
  Variable SRth : semi_ring_theory 0 1 radd rmul req.
@@ -503,7 +506,6 @@ Qed.
 
 End ALMOST_RING.
 
-
 Section AddRing.
 
 (* Variable R : Type.
@@ -528,7 +530,6 @@ Inductive ring_kind : Type :=
     (_ : ring_morph rO rI radd rmul rsub ropp req
                     cO cI cadd cmul csub copp ceqb phi).
 
-
 End AddRing.
 
 
diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v
index 58a4d7ea..605a23a9 100644
--- a/plugins/setoid_ring/Rings_Z.v
+++ b/plugins/setoid_ring/Rings_Z.v
@@ -1,6 +1,7 @@
 Require Export Cring.
 Require Export Integral_domain.
 Require Export Ncring_initial.
+Require Export Omega.
 
 Instance Zcri: (Cring (Rr:=Zr)).
 red. exact Z.mul_comm. Defined.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 1177688d..848e06a7 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -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        *)
@@ -48,8 +48,8 @@ Ltac Zpower_neg :=
 Add Ring Zr : Zth
   (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ],
    power_tac Zpower_theory [Zpow_tac],
-    (* The two following option are not needed, it is the default chose when the set of
-        coefficiant is usual ring Z *)
+    (* The following two options are not needed; they are the default choice
+       when the set of coefficient is the usual ring Z *)
     div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
    sign get_signZ_th).
 
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index d1a5c0ab..2f9e8509 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml4
@@ -1,30 +1,27 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Closure
 open Environ
 open Libnames
-open Tactics
+open Globnames
 open Glob_term
 open Tacticals
 open Tacexpr
-open Pcoq
-open Tactic
-open Constr
-open Proof_type
 open Coqlib
-open Tacmach
 open Mod_subst
 open Tacinterp
 open Libobject
@@ -32,14 +29,20 @@ open Printer
 open Declare
 open Decl_kinds
 open Entries
+open Misctypes
+
+DECLARE PLUGIN "newring_plugin"
 
 (****************************************************************************)
 (* controlled reduction *)
 
-let mark_arg i c = mkEvar(i,[|c|])
+(** ppedrot: something dubious here, we're obviously using evars the wrong
+    way. FIXME! *)
+
+let mark_arg i c = mkEvar(Evar.unsafe_of_int i,[|c|])
 let unmark_arg f c =
   match destEvar c with
-    | (i,[|c|]) -> f i c
+    | (i,[|c|]) -> f (Evar.repr i) c
     | _ -> assert false
 
 type protect_flag = Eval|Prot|Rec
@@ -48,10 +51,19 @@ let tag_arg tag_rec map subs i c =
   match map i with
       Eval -> mk_clos subs c
     | Prot -> mk_atom c
-    | Rec -> if i = -1 then mk_clos subs c else tag_rec c
+    | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c
+
+let global_head_of_constr c = 
+  let f, args = decompose_app c in
+    try global_of_constr f
+    with Not_found -> anomaly (str "global_head_of_constr")
+
+let global_of_constr_nofail c = 
+  try global_of_constr c
+  with Not_found -> VarRef (Id.of_string "dummy")
 
 let rec mk_clos_but f_map subs t =
-  match f_map t with
+  match f_map (global_of_constr_nofail t) with
     | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
     | None ->
         (match kind_of_term t with
@@ -62,9 +74,9 @@ let rec mk_clos_but f_map subs t =
 and mk_clos_app_but f_map subs f args n =
   if n >= Array.length args then mk_atom(mkApp(f, args))
   else
-    let fargs, args' = array_chop n args in
+    let fargs, args' = Array.chop n args in
     let f' = mkApp(f,fargs) in
-    match f_map f' with
+    match f_map (global_of_constr_nofail f') with
         Some map ->
           mk_clos_deep
             (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
@@ -72,24 +84,13 @@ and mk_clos_app_but f_map subs f args n =
             (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
       | None -> mk_clos_app_but f_map subs f args (n+1)
 
-
-let interp_map l c =
-  try
-    let (im,am) = List.assoc c l in
-    Some(fun i ->
-      if List.mem i im then Eval
-      else if List.mem i am then Prot
-      else if i = -1 then Eval
-      else Rec)
-  with Not_found -> None
-
 let interp_map l t =
-  try Some(list_assoc_f eq_constr t l) with Not_found -> None
+  try Some(List.assoc_f eq_gr t l) with Not_found -> None
 
-let protect_maps = ref Stringmap.empty
-let add_map s m = protect_maps := Stringmap.add s m !protect_maps
+let protect_maps = ref String.Map.empty
+let add_map s m = protect_maps := String.Map.add s m !protect_maps
 let lookup_map map =
-  try Stringmap.find map !protect_maps
+  try String.Map.find map !protect_maps
   with Not_found ->
     errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
 
@@ -101,112 +102,120 @@ let protect_tac map =
   Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
 
 let protect_tac_in map id =
-  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));;
+  Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
 
 
 TACTIC EXTEND protect_fv
   [ "protect_fv" string(map) "in" ident(id) ] ->
-    [ protect_tac_in map id ]
+    [ Proofview.V82.tactic (protect_tac_in map id) ]
 | [ "protect_fv" string(map) ] ->
-    [ protect_tac map ]
+    [ Proofview.V82.tactic (protect_tac map) ]
 END;;
 
 (****************************************************************************)
 
 let closed_term t l =
-  let l = List.map constr_of_global l in
+  let l = List.map Universes.constr_of_global l in
   let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
   if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
 ;;
 
 TACTIC EXTEND closed_term
   [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
-    [ closed_term t l ]
+    [ Proofview.V82.tactic (closed_term t l) ]
 END
 ;;
 
-TACTIC EXTEND echo
+(* TACTIC EXTEND echo
 | [ "echo" constr(t) ] ->
   [ Pp.msg (Termops.print_constr t);  Tacinterp.eval_tactic (TacId []) ]
-END;;
+END;;*)
 
 (*
 let closed_term_ast l =
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
-   Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
+  TacFun([Some(Id.of_string"t")],
+  TacAtom(Loc.ghost,TacExtend(Loc.ghost,"closed_term",
+  [Genarg.in_gen Constrarg.wit_constr (mkVar(Id.of_string"t"));
+   Genarg.in_gen (Genarg.wit_list Constrarg.wit_ref) l])))
 *)
 let closed_term_ast l =
-  let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
-  TacFun([Some(id_of_string"t")],
-  TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
-  [Genarg.in_gen Genarg.globwit_constr (GVar(dummy_loc,id_of_string"t"),None);
-   Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
+  let tacname = {
+    mltac_plugin = "newring_plugin";
+    mltac_tactic = "closed_term";
+  } in
+  let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
+  TacFun([Some(Id.of_string"t")],
+  TacML(Loc.ghost,tacname,
+  [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None);
+   Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l]))
 (*
-let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
+let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
 *)
 
 (****************************************************************************)
 
 let ic c =
   let env = Global.env() and sigma = Evd.empty in
-  Constrintern.interp_constr sigma env c
+  Constrintern.interp_open_constr env sigma c
+
+let ic_unsafe c = (*FIXME remove *)
+  let env = Global.env() and sigma = Evd.empty in
+    fst (Constrintern.interp_constr env sigma c)
 
 let ty c = Typing.type_of (Global.env()) Evd.empty c
 
-let decl_constant na c =
-  mkConst(declare_constant (id_of_string na) (DefinitionEntry
-    { const_entry_body = c;
-      const_entry_secctx = None;
-      const_entry_type = None;
-      const_entry_opaque = true },
-    IsProof Lemma))
+let decl_constant na ctx c =
+  let vars = Universes.universes_of_constr c in
+  let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
+  mkConst(declare_constant (Id.of_string na) 
+	    (DefinitionEntry (definition_entry ~opaque:true
+				~univs:(Univ.ContextSet.to_context ctx) c),
+	     IsProof Lemma))
 
 (* Calling a global tactic *)
 let ltac_call tac (args:glob_tactic_arg list) =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+  TacArg(Loc.ghost,TacCall(Loc.ghost, ArgArg(Loc.ghost, Lazy.force tac),args))
 
 (* Calling a locally bound tactic *)
 let ltac_lcall tac args =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+  TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
 
 let ltac_letin (x, e1) e2 =
-  TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2)
+  TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2)
 
 let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
   Tacinterp.eval_tactic
     (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
 
 let ltac_record flds =
-  TacFun([Some(id_of_string"proj")], ltac_lcall "proj" flds)
+  TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds)
 
 
-let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
+let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
 
-let dummy_goal env =
+let dummy_goal env sigma =
   let (gl,_,sigma) = 
-    Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in
-  {Evd.it = gl;
-   Evd.sigma = sigma}
+    Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in
+  {Evd.it = gl; Evd.sigma = sigma}
 
-let exec_tactic env n f args =
-  let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
+let constr_of v = match Value.to_constr v with
+  | Some c -> c
+  | None -> failwith "Ring.exec_tactic: anomaly"
+
+let exec_tactic env evd n f args =
+  let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
   let res = ref [||] in
   let get_res ist =
-    let l = List.map (fun id ->  List.assoc id ist.lfun) lid in
+    let l = List.map (fun id ->  Id.Map.find id ist.lfun) lid in
     res := Array.of_list l;
     TacId[] in
   let getter =
     Tacexp(TacFun(List.map(fun id -> Some id) lid,
-                  glob_tactic(tacticIn get_res))) in
-  let _ =
-    Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
-  !res
-
-let constr_of = function
-  | VConstr ([],c) -> c
-  | _ -> failwith "Ring.exec_tactic: anomaly"
+                  Tacintern.glob_tactic(tacticIn get_res))) in
+  let gl = dummy_goal env evd in
+  let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
+  let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
+    Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd
 
 let stdlib_modules =
   [["Coq";"Setoids";"Setoid"];
@@ -217,16 +226,23 @@ let stdlib_modules =
 
 let coq_constant c =
   lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+let coq_reference c =
+  lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)
 
 let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
-let coq_cons = coq_constant "cons"
-let coq_nil = coq_constant "nil"
-let coq_None = coq_constant "None"
-let coq_Some = coq_constant "Some"
+let coq_None = coq_reference "None"
+let coq_Some = coq_reference "Some"
 let coq_eq = coq_constant "eq"
 
+let coq_cons = coq_reference "cons"
+let coq_nil = coq_reference "nil"
+
 let lapp f args = mkApp(Lazy.force f,args)
 
+let plapp evd f args = 
+  let fc = Evarutil.e_new_global evd (Lazy.force f) in
+    mkApp(fc,args)
+
 let dest_rel0 t =
   match kind_of_term t with
   | App(f,args) when Array.length args >= 2 ->
@@ -255,17 +271,19 @@ let plugin_modules =
 
 let my_constant c =
   lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
+let my_reference c =
+  lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c)
 
 let new_ring_path =
-  make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
 let ltac s =
-  lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s))
 let znew_ring_path =
-  make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
 let zltac s =
-  lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile znew_ring_path) DirPath.empty (Label.make s))
 
-let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
+let mk_cst l s = lazy (Coqlib.gen_reference "newring" l s);;
 let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
 
 (* Ring theory *)
@@ -274,9 +292,9 @@ let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
 let coq_almost_ring_theory = my_constant "almost_ring_theory"
 
 (* setoid and morphism utilities *)
-let coq_eq_setoid = my_constant "Eqsth"
-let coq_eq_morph = my_constant "Eq_ext"
-let coq_eq_smorph = my_constant "Eq_s_ext"
+let coq_eq_setoid = my_reference "Eqsth"
+let coq_eq_morph = my_reference "Eq_ext"
+let coq_eq_smorph = my_reference "Eq_s_ext"
 
 (* ring -> almost_ring utilities *)
 let coq_ring_theory = my_constant "ring_theory"
@@ -303,16 +321,19 @@ let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
 let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
 
 (* hypothesis *)
-let coq_mkhypo = my_constant "mkhypo"
-let coq_hypo = my_constant "hypo"
+let coq_mkhypo = my_reference "mkhypo"
+let coq_hypo = my_reference "hypo"
 
 (* Equality: do not evaluate but make recursive call on both sides *)
 let map_with_eq arg_map c =
   let (req,_,_) = dest_rel c in
   interp_map
-    ((req,(function -1->Prot|_->Rec))::
+    ((global_head_of_constr req,(function -1->Prot|_->Rec))::
     List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
 
+let map_without_eq arg_map _ =
+  interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
 let _ = add_map "ring"
   (map_with_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
@@ -343,15 +364,12 @@ type ring_info =
       ring_pre_tac : glob_tactic_expr;
       ring_post_tac : glob_tactic_expr }
 
-module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
+module Cmap = Map.Make(Constr)
 
-let from_carrier = ref Cmap.empty
-let from_relation = ref Cmap.empty
-let from_name = ref Spmap.empty
+let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
+let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table"
 
 let ring_for_carrier r = Cmap.find r !from_carrier
-let ring_for_relation rel = Cmap.find rel !from_relation
-
 
 let find_ring_structure env sigma l =
   match l with
@@ -370,32 +388,9 @@ let find_ring_structure env sigma l =
             (str"cannot find a declared ring structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
     | [] -> assert false
-(*
-        let (req,_,_) = dest_rel cl in
-        (try ring_for_relation req
-        with Not_found ->
-          errorlabstrm "ring"
-            (str"cannot find a declared ring structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ =
-  Summary.declare_summary "tactic-new-ring-table"
-    { Summary.freeze_function =
-        (fun () -> !from_carrier,!from_relation,!from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          from_carrier := ct; from_relation := rt; from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          from_carrier := Cmap.empty; from_relation := Cmap.empty;
-          from_name := Spmap.empty) }
 
 let add_entry (sp,_kn) e =
-(*  let _ = ty e.ring_lemma1 in
-  let _ = ty e.ring_lemma2 in
-*)
   from_carrier := Cmap.add e.ring_carrier e !from_carrier;
-  from_relation := Cmap.add e.ring_req e !from_relation;
   from_name := Spmap.add sp e !from_name
 
 
@@ -408,10 +403,10 @@ let subst_th (subst,th) =
   let th' = subst_mps subst th.ring_th in
   let thm1' = subst_mps subst th.ring_lemma1 in
   let thm2' = subst_mps subst th.ring_lemma2 in
-  let tac'= subst_tactic subst th.ring_cst_tac in
-  let pow_tac'= subst_tactic subst th.ring_pow_tac in
-  let pretac'= subst_tactic subst th.ring_pre_tac in
-  let posttac'= subst_tactic subst th.ring_post_tac in
+  let tac'= Tacsubst.subst_tactic subst th.ring_cst_tac in
+  let pow_tac'= Tacsubst.subst_tactic subst th.ring_pow_tac in
+  let pretac'= Tacsubst.subst_tactic subst th.ring_pre_tac in
+  let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in
   if c' == th.ring_carrier &&
      eq' == th.ring_req &&
      eq_constr set' th.ring_setoid &&
@@ -443,20 +438,20 @@ let theory_to_obj : ring_info -> obj =
   let cache_th (name,th) = add_entry name th in
   declare_object
     {(default_object "tactic-new-ring-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
+      open_function = (fun i o -> if Int.equal i 1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
       classify_function = (fun x -> Substitute x)}
 
 
-let setoid_of_relation env a r =
-  let evm = Evd.empty in
+let setoid_of_relation env evd a r =
   try
-    lapp coq_mk_Setoid
-      [|a ; r ;
-	Rewrite.get_reflexive_proof env evm a r ;
-	Rewrite.get_symmetric_proof env evm a r ;
-	Rewrite.get_transitive_proof env evm a r |]
+    let evm = !evd in
+    let evm, refl = Rewrite.get_reflexive_proof env evm a r in
+    let evm, sym = Rewrite.get_symmetric_proof env evm a r in
+    let evm, trans = Rewrite.get_transitive_proof env evm a r in
+      evd := evm;
+      lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |]
   with Not_found ->
     error "cannot find setoid relation"
 
@@ -469,7 +464,7 @@ let op_smorph r add mul req m1 m2 =
 (* let default_ring_equality (r,add,mul,opp,req) = *)
 (*   let is_setoid = function *)
 (*       {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
-(*         eq_constr req rel (\* Qu: use conversion ? *\) *)
+(*         eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *)
 (*     | _ -> false in *)
 (*   match default_relation_for_carrier ~filter:is_setoid r with *)
 (*       Leibniz _ -> *)
@@ -484,7 +479,7 @@ let op_smorph r add mul req m1 m2 =
 (*         let is_endomorphism = function *)
 (*             { args=args } -> List.for_all *)
 (*                 (function (var,Relation rel) -> *)
-(*                   var=None && eq_constr req rel *)
+(*                   var=None && eq_constr_nounivs req rel *)
 (*                   | _ -> false) args in *)
 (*         let add_m = *)
 (*           try default_morphism ~filter:is_endomorphism add *)
@@ -519,17 +514,19 @@ let op_smorph r add mul req m1 m2 =
 (*             op_smorph r add mul req add_m.lem mul_m.lem) in *)
 (*         (setoid,op_morph) *)
 
-let ring_equality (r,add,mul,opp,req) =
+let ring_equality env evd (r,add,mul,opp,req) =
   match kind_of_term req with
-    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
-	let setoid = lapp coq_eq_setoid [|r|] in
+    | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+	let setoid = plapp evd coq_eq_setoid [|r|] in
 	let op_morph =
 	  match opp with
-              Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
-            | None -> lapp coq_eq_smorph [|r;add;mul|] in
+              Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
+            | None -> plapp evd coq_eq_smorph [|r;add;mul|] in
+	let setoid = Typing.solve_evars env evd setoid in
+	let op_morph = Typing.solve_evars env evd op_morph in
 	  (setoid,op_morph)
     | _ ->
-	let setoid = setoid_of_relation (Global.env ()) r req in
+	let setoid = setoid_of_relation (Global.env ()) evd r req in
 	let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in
 	let add_m, add_m_lem =
 	  try Rewrite.default_morphism signature add
@@ -549,7 +546,7 @@ let ring_equality (r,add,mul,opp,req) =
 		let op_morph =
 		  op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
 		  Flags.if_verbose
-		    msgnl
+		    msg_info
 		    (str"Using setoid \""++pr_constr req++str"\""++spc()++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\","++spc()++ str"\""++pr_constr mul_m_lem++
@@ -558,7 +555,7 @@ let ring_equality (r,add,mul,opp,req) =
 		  op_morph)
             | None ->
 		(Flags.if_verbose
-		    msgnl
+		    msg_info
 		    (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
 			str"and morphisms \""++pr_constr add_m_lem ++
 			str"\""++spc()++str"and \""++
@@ -566,22 +563,22 @@ let ring_equality (r,add,mul,opp,req) =
 		 op_smorph r add mul req add_m_lem mul_m_lem) in
           (setoid,op_morph)
 
-let build_setoid_params r add mul opp req eqth =
+let build_setoid_params env evd r add mul opp req eqth =
   match eqth with
       Some th -> th
-    | None -> ring_equality (r,add,mul,opp,req)
+    | None -> ring_equality env evd (r,add,mul,opp,req)
 
 let dest_ring env sigma th_spec =
   let th_typ = Retyping.get_type_of env sigma th_spec in
   match kind_of_term th_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when eq_constr f (Lazy.force coq_almost_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) ->
           (None,r,zero,one,add,mul,Some sub,Some opp,req)
     | App(f,[|r;zero;one;add;mul;req|])
-        when eq_constr f (Lazy.force coq_semi_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) ->
         (Some true,r,zero,one,add,mul,None,None,req)
     | App(f,[|r;zero;one;add;mul;sub;opp;req|])
-        when eq_constr f (Lazy.force coq_ring_theory) ->
+        when eq_constr_nounivs f (Lazy.force coq_ring_theory) ->
         (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
     | _ -> error "bad ring structure"
 
@@ -591,18 +588,18 @@ let dest_morph env sigma m_spec =
   match kind_of_term m_typ with
       App(f,[|r;zero;one;add;mul;sub;opp;req;
               c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
-        when eq_constr f (Lazy.force coq_ring_morph) ->
+        when eq_constr_nounivs f (Lazy.force coq_ring_morph) ->
           (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
     | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
-        when eq_constr f (Lazy.force coq_semi_morph) ->
+        when eq_constr_nounivs f (Lazy.force coq_semi_morph) ->
         (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
     | _ -> error "bad morphism structure"
 
 
-type coeff_spec =
-    Computational of constr (* equality test *)
+type 'constr coeff_spec =
+    Computational of 'constr (* equality test *)
   | Abstract (* coeffs = Z *)
-  | Morphism of constr (* general morphism *)
+  | Morphism of 'constr (* general morphism *)
 
 
 let reflect_coeff rkind =
@@ -618,101 +615,89 @@ type cst_tac_spec =
 
 let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
   match cst_tac with
-      Some (CstTac t) -> Tacinterp.glob_tactic t
+      Some (CstTac t) -> Tacintern.glob_tactic t
     | Some (Closed lc) ->
         closed_term_ast (List.map Smartlocate.global_with_alias lc)
     | None ->
-        (match rk, opp, kind with
-            Abstract, None, _ ->
-              let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
-              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
-          | Abstract, Some opp, Some _ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
-              TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Abstract, Some opp, None ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
-          | Computational _,_,_ ->
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
-          | Morphism mth,_,_ ->
-              let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in
-              let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
-              TacArg
-                (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
-
-let make_hyp env c =
-  let t = Retyping.get_type_of env Evd.empty c in
-  lapp coq_mkhypo [|t;c|]
-
-let make_hyp_list env lH =
-  let carrier = Lazy.force coq_hypo in
-  List.fold_right
-    (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
-    (lapp coq_nil [|carrier|])
-
-let interp_power env pow =
-  let carrier = Lazy.force coq_hypo in
+        let t = ArgArg(Loc.ghost,Lazy.force ltac_inv_morph_nothing) in
+              TacArg(Loc.ghost,TacCall(Loc.ghost,t,[]))
+
+let make_hyp env evd c =
+  let t = Retyping.get_type_of env !evd c in
+   plapp evd coq_mkhypo [|t;c|]
+
+let make_hyp_list env evd lH =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
+  let l = 
+    List.fold_right
+      (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
+      (plapp evd coq_nil [|carrier|])
+  in 
+  let l' = Typing.solve_evars env evd l in
+    Evarutil.nf_evars_universes !evd l'
+
+let interp_power env evd pow =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match pow with
   | None ->
-      let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
-      (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+      let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in
+      (TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])), plapp evd coq_None [|carrier|])
   | Some (tac, spec) ->
       let tac =
         match tac with
-        | CstTac t -> Tacinterp.glob_tactic t
+        | CstTac t -> Tacintern.glob_tactic t
         | Closed lc ->
             closed_term_ast (List.map Smartlocate.global_with_alias lc) in
-      let spec = make_hyp env (ic spec) in
-      (tac, lapp coq_Some [|carrier; spec|])
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      (tac, plapp evd coq_Some [|carrier; spec|])
 
-let interp_sign env sign =
-  let carrier = Lazy.force coq_hypo in
+let interp_sign env evd sign =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match sign with
-  | None -> lapp coq_None [|carrier|]
+  | None -> plapp evd coq_None [|carrier|]
   | Some spec ->
-      let spec = make_hyp env (ic spec) in
-      lapp coq_Some [|carrier;spec|]
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      plapp evd coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
 
-let interp_div env div =
-  let carrier = Lazy.force coq_hypo in
+let interp_div env evd div =
+  let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in
   match div with
-  | None -> lapp coq_None [|carrier|]
+  | None -> plapp evd coq_None [|carrier|]
   | Some spec ->
-      let spec = make_hyp env (ic spec) in
-      lapp coq_Some [|carrier;spec|]
+      let spec = make_hyp env evd (ic_unsafe spec) in
+      plapp evd coq_Some [|carrier;spec|]
        (* Same remark on ill-typed terms ... *)
 
-let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
+let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
   check_required_library (cdir@["Ring_base"]);
   let env = Global.env() in
-  let sigma = Evd.empty in
   let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
-  let (pow_tac, pspec) = interp_power env power in
-  let sspec = interp_sign env sign in
-  let dspec = interp_div env div in
+  let evd = ref sigma in
+  let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
+  let (pow_tac, pspec) = interp_power env evd power in
+  let sspec = interp_sign env evd sign in
+  let dspec = interp_div env evd div in
   let rk = reflect_coeff morphth in
-  let params =
-    exec_tactic env 5 (zltac "ring_lemmas")
+  let params,ctx =
+    exec_tactic env !evd 5 (zltac "ring_lemmas")
       (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
+  let lemma1 = params.(3) in
+  let lemma2 = params.(4) in
 
-  let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
+  let lemma1 =
+    decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in
+  let lemma2 =
+    decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in
   let cst_tac =
     interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
   let pretac =
     match pre with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let posttac =
     match post with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let _ =
     Lib.add_leaf name
@@ -720,9 +705,9 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
         { ring_carrier = r;
           ring_req = req;
           ring_setoid = sth;
-          ring_ext = constr_of params.(1);
-          ring_morph = constr_of params.(2);
-          ring_th = constr_of params.(0);
+          ring_ext = params.(1);
+          ring_morph = params.(2);
+          ring_th = params.(0);
           ring_cst_tac = cst_tac;
 	  ring_pow_tac = pow_tac;
           ring_lemma1 = lemma1;
@@ -731,22 +716,28 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
           ring_post_tac = posttac }) in
   ()
 
-type ring_mod =
-    Ring_kind of coeff_spec
+type 'constr ring_mod =
+    Ring_kind of 'constr coeff_spec
   | Const_tac of cst_tac_spec
   | Pre_tac of raw_tactic_expr
   | Post_tac of raw_tactic_expr
-  | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
-  | Pow_spec of cst_tac_spec * Topconstr.constr_expr
+  | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr
+  | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
            (* Syntaxification tactic , correctness lemma *)
-  | Sign_spec of Topconstr.constr_expr
-  | Div_spec of Topconstr.constr_expr
+  | Sign_spec of Constrexpr.constr_expr
+  | Div_spec of Constrexpr.constr_expr
+
+
+let ic_coeff_spec = function
+  | Computational t -> Computational (ic_unsafe t)
+  | Morphism t -> Morphism (ic_unsafe t)
+  | Abstract -> Abstract
 
 
 VERNAC ARGUMENT EXTEND ring_mod
-  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
+  | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
   | [ "abstract" ] -> [ Ring_kind Abstract ]
-  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
+  | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
   | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
   | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
   | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
@@ -761,7 +752,7 @@ VERNAC ARGUMENT EXTEND ring_mod
 END
 
 let set_once s r v =
-  if !r = None then r := Some v else error (s^" cannot be set twice")
+  if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
 
 let process_ring_mods l =
   let kind = ref None in
@@ -773,21 +764,29 @@ let process_ring_mods l =
   let power = ref None in
   let div = ref None in
   List.iter(function
-      Ring_kind k -> set_once "ring kind" kind k
+      Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k)
     | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
     | Pre_tac t -> set_once "preprocess tactic" pre t
     | Post_tac t -> set_once "postprocess tactic" post t
-    | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)
+    | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
     | Pow_spec(t,spec) -> set_once "power" power (t,spec)
     | Sign_spec t -> set_once "sign" sign t
     | Div_spec t -> set_once "div" div t) l;
   let k = match !kind with Some k -> k | None -> Abstract in
   (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
 
-VERNAC COMMAND EXTEND AddSetoidRing
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
   | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
     [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
       add_theory id (ic t) set k cst (pre,post) power sign div]
+  | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
+    msg_notice (strbrk "The following ring structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      msg_notice (hov 2
+        (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+          str"with carrier "++ pr_constr fi.ring_carrier++spc()++
+          str"and equivalence relation "++ pr_constr fi.ring_req))
+    ) !from_name ]
 END
 
 (*****************************************************************************)
@@ -799,10 +798,11 @@ let make_args_list rl t =
   | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
   | _ -> rl
 
-let make_term_list carrier rl =
-  List.fold_right
-    (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
-    (lapp coq_nil [|carrier|])
+let make_term_list env evd carrier rl =
+  let l = List.fold_right
+    (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
+    (plapp evd coq_nil [|carrier|])
+  in Typing.solve_evars env evd l
 
 let ltac_ring_structure e =
   let req = carg e.ring_req in
@@ -819,19 +819,24 @@ let ltac_ring_structure e =
   [req;sth;ext;morph;th;cst_tac;pow_tac;
    lemma1;lemma2;pretac;posttac]
 
-let ring_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_ring_structure env sigma rl in
-  let rl = carg (make_term_list e.ring_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let ring = ltac_ring_structure e in
-  ltac_apply f (ring@[lH;rl]) gl
+let ring_lookup (f:glob_tactic_expr) lH rl t =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try (* find_ring_strucure can raise an exception *)
+      let evdref = ref sigma in
+      let rl = make_args_list rl t in
+      let e = find_ring_structure env sigma rl in
+      let rl = carg (make_term_list env evdref e.ring_carrier rl) in
+      let lH = carg (make_hyp_list env evdref lH) in
+      let ring = ltac_ring_structure e in
+      Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
+    with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
 TACTIC EXTEND ring_lookup
 | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
-    [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t]
+    [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
 END
 
 
@@ -839,10 +844,10 @@ END
 (***********************************************************************)
 
 let new_field_path =
-  make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"])
+  DirPath.make (List.map Id.of_string ["Field_tac";plugin_dir;"Coq"])
 
 let field_ltac s =
-  lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
+  lazy(make_kn (MPfile new_field_path) DirPath.empty (Label.make s))
 
 
 let _ = add_map "field"
@@ -851,9 +856,9 @@ let _ = add_map "field"
     coq_nil, (function -1->Eval|_ -> Prot);
     (* display_linear: evaluate polynomials and coef operations, protect
        field operations and make recursive call on the var map *)
-    my_constant "display_linear",
+    my_reference "display_linear",
       (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
-    my_constant "display_pow_linear",
+    my_reference "display_pow_linear",
      (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
    (* Pphi_dev: evaluate polynomial and coef operations, protect
        ring operations and make recursive call on the var map *)
@@ -865,16 +870,16 @@ let _ = add_map "field"
     pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
     (* FEeval: evaluate morphism, protect field
        operations and make recursive call on the var map *)
-    my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+    my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
 
 let _ = add_map "field_cond"
-  (map_with_eq
+  (map_without_eq
     [coq_cons,(function -1->Eval|2->Rec|_->Prot);
      coq_nil, (function -1->Eval|_ -> Prot);
     (* PCond: evaluate morphism and denum list, protect ring
        operations and make recursive call on the var map *)
-     my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
-(*                       (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
+     my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);;
+(*                       (function -1|9|11->Eval|10->Rec|_->Prot)]);;*)
 
 
 let _ = Redexpr.declare_reduction "simpl_field_expr"
@@ -882,29 +887,29 @@ let _ = Redexpr.declare_reduction "simpl_field_expr"
 
 
 
-let afield_theory = my_constant "almost_field_theory"
-let field_theory = my_constant "field_theory"
-let sfield_theory = my_constant "semi_field_theory"
-let af_ar = my_constant"AF_AR"
-let f_r = my_constant"F_R"
-let sf_sr = my_constant"SF_SR"
-let dest_field env sigma th_spec =
-  let th_typ = Retyping.get_type_of env sigma th_spec in
+let afield_theory = my_reference "almost_field_theory"
+let field_theory = my_reference "field_theory"
+let sfield_theory = my_reference "semi_field_theory"
+let af_ar = my_reference"AF_AR"
+let f_r = my_reference"F_R"
+let sf_sr = my_reference"SF_SR"
+let dest_field env evd th_spec =
+  let th_typ = Retyping.get_type_of env !evd th_spec in
   match kind_of_term th_typ with
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when eq_constr f (Lazy.force afield_theory) ->
-        let rth = lapp af_ar
+        when is_global (Lazy.force afield_theory) f ->
+        let rth = plapp evd af_ar
           [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
-        when eq_constr f (Lazy.force field_theory) ->
+        when is_global (Lazy.force field_theory) f ->
         let rth =
-          lapp f_r
+          plapp evd f_r
             [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
         (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
     | App(f,[|r;zero;one;add;mul;div;inv;req|])
-        when eq_constr f (Lazy.force sfield_theory) ->
-        let rth = lapp sf_sr
+        when is_global (Lazy.force sfield_theory) f ->
+        let rth = plapp evd sf_sr
           [|r;zero;one;add;mul;div;inv;req;th_spec|] in
         (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
     | _ -> error "bad field structure"
@@ -922,13 +927,10 @@ type field_info =
       field_pre_tac : glob_tactic_expr;
       field_post_tac : glob_tactic_expr }
 
-let field_from_carrier = ref Cmap.empty
-let field_from_relation = ref Cmap.empty
-let field_from_name = ref Spmap.empty
-
+let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
+let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
 
 let field_for_carrier r = Cmap.find r !field_from_carrier
-let field_for_relation rel = Cmap.find rel !field_from_relation
 
 let find_field_structure env sigma l =
   check_required_library (cdir@["Field_tac"]);
@@ -948,35 +950,9 @@ let find_field_structure env sigma l =
             (str"cannot find a declared field structure over"++
              spc()++str"\""++pr_constr ty++str"\""))
     | [] -> assert false
-(*        let (req,_,_) = dest_rel cl in
-        (try field_for_relation req
-        with Not_found ->
-          errorlabstrm "field"
-            (str"cannot find a declared field structure for equality"++
-             spc()++str"\""++pr_constr req++str"\"")) *)
-
-let _ =
-  Summary.declare_summary "tactic-new-field-table"
-    { Summary.freeze_function =
-        (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
-      Summary.unfreeze_function =
-        (fun (ct,rt,nt) ->
-          field_from_carrier := ct; field_from_relation := rt;
-          field_from_name := nt);
-      Summary.init_function =
-        (fun () ->
-          field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
-          field_from_name := Spmap.empty) }
 
 let add_field_entry (sp,_kn) e =
-(*
-  let _ = ty e.field_ok in
-  let _ = ty e.field_simpl_eq_ok in
-  let _ = ty e.field_simpl_ok in
-  let _ = ty e.field_cond in
-*)
   field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
-  field_from_relation := Cmap.add e.field_req e !field_from_relation;
   field_from_name := Spmap.add sp e !field_from_name
 
 let subst_th (subst,th) =
@@ -987,10 +963,10 @@ let subst_th (subst,th) =
   let thm3' = subst_mps subst th.field_simpl_ok in
   let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
   let thm5' = subst_mps subst th.field_cond in
-  let tac'= subst_tactic subst th.field_cst_tac in
-  let pow_tac' = subst_tactic subst th.field_pow_tac in
-  let pretac'= subst_tactic subst th.field_pre_tac in
-  let posttac'= subst_tactic subst th.field_post_tac in
+  let tac'= Tacsubst.subst_tactic subst th.field_cst_tac in
+  let pow_tac' = Tacsubst.subst_tactic subst th.field_pow_tac in
+  let pretac'= Tacsubst.subst_tactic subst th.field_pre_tac in
+  let posttac'= Tacsubst.subst_tactic subst th.field_post_tac in
   if c' == th.field_carrier &&
      eq' == th.field_req &&
      thm1' == th.field_ok &&
@@ -1019,17 +995,17 @@ let ftheory_to_obj : field_info -> obj =
   let cache_th (name,th) = add_field_entry name th in
   declare_object
     {(default_object "tactic-new-field-theory") with
-      open_function = (fun i o -> if i=1 then cache_th o);
+      open_function = (fun i o -> if Int.equal i 1 then cache_th o);
       cache_function = cache_th;
       subst_function = subst_th;
       classify_function = (fun x -> Substitute x) }
 
-let field_equality r inv req =
+let field_equality evd r inv req =
   match kind_of_term req with
-    | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
-        mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+    | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) ->
+        mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
     | _ ->
-	let _setoid = setoid_of_relation (Global.env ()) r req in
+	let _setoid = setoid_of_relation (Global.env ()) evd r req in
 	let signature = [Some (r,Some req)],Some(r,Some req) in
 	let inv_m, inv_m_lem =
 	  try Rewrite.default_morphism signature inv
@@ -1037,45 +1013,50 @@ let field_equality r inv req =
             error "field inverse should be declared as a morphism" in
 	  inv_m_lem
 
-let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv =
+let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv =
   check_required_library (cdir@["Field_tac"]);
   let env = Global.env() in
-  let sigma = Evd.empty in
+  let evd = ref sigma in
   let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
-    dest_field env sigma fth in
-  let (sth,ext) = build_setoid_params r add mul opp req eqth in
+    dest_field env evd fth in
+  let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in
   let eqth = Some(sth,ext) in
-  let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in
-  let (pow_tac, pspec) = interp_power env power in
-  let sspec = interp_sign env sign in
-  let dspec = interp_div env odiv in
-  let inv_m = field_equality r inv req in
+  let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in
+  let (pow_tac, pspec) = interp_power env evd power in
+  let sspec = interp_sign env evd sign in
+  let dspec = interp_div env evd odiv in
+  let inv_m = field_equality evd r inv req in
   let rk = reflect_coeff morphth in
-  let params =
-    exec_tactic env 9 (field_ltac"field_lemmas")
+  let params,ctx =
+    exec_tactic env !evd 9 (field_ltac"field_lemmas")
       (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
-  let lemma1 = constr_of params.(3) in
-  let lemma2 = constr_of params.(4) in
-  let lemma3 = constr_of params.(5) in
-  let lemma4 = constr_of params.(6) in
+  let lemma1 = params.(3) in
+  let lemma2 = params.(4) in
+  let lemma3 = params.(5) in
+  let lemma4 = params.(6) in
   let cond_lemma =
     match inj with
-      | Some thm -> mkApp(constr_of params.(8),[|thm|])
-      | None -> constr_of params.(7) in
-  let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
-  let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
-  let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
-  let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
-  let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
+      | Some thm -> mkApp(params.(8),[|thm|])
+      | None -> params.(7) in
+  let lemma1 = decl_constant (Id.to_string name^"_field_lemma1")
+    ctx lemma1 in
+  let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") 
+    ctx lemma2 in
+  let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") 
+    ctx lemma3 in
+  let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") 
+    ctx lemma4 in
+  let cond_lemma = decl_constant (Id.to_string name^"_lemma5") 
+    ctx cond_lemma in
   let cst_tac =
     interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
   let pretac =
     match pre with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let posttac =
     match post with
-        Some t -> Tacinterp.glob_tactic t
+        Some t -> Tacintern.glob_tactic t
       | _ -> TacId [] in
   let _ =
     Lib.add_leaf name
@@ -1092,9 +1073,9 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi
           field_pre_tac = pretac;
           field_post_tac = posttac }) in  ()
 
-type field_mod =
-    Ring_mod of ring_mod
-  | Inject of Topconstr.constr_expr
+type 'constr field_mod =
+    Ring_mod of 'constr ring_mod
+  | Inject of Constrexpr.constr_expr
 
 VERNAC ARGUMENT EXTEND field_mod
   | [ ring_mod(m) ] -> [ Ring_mod m ]
@@ -1112,23 +1093,31 @@ let process_field_mods l =
   let power = ref None in
   let div = ref None in
   List.iter(function
-      Ring_mod(Ring_kind k) -> set_once "field kind" kind k
+      Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k)
     | Ring_mod(Const_tac t) ->
         set_once "tactic recognizing constants" cst_tac t
     | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
     | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
-    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
+    | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext)
     | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
     | Ring_mod(Sign_spec t) -> set_once "sign" sign t
     | Ring_mod(Div_spec t) -> set_once "div" div t
-    | Inject i -> set_once "infinite property" inj (ic i)) l;
+    | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l;
   let k = match !kind with Some k -> k | None -> Abstract in
   (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
 
-VERNAC COMMAND EXTEND AddSetoidField
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
 | [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
   [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
     add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
+| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
+    msg_notice (strbrk "The following field structures have been declared:");
+    Spmap.iter (fun fn fi ->
+      msg_notice (hov 2
+        (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+          str"with carrier "++ pr_constr fi.field_carrier++spc()++
+          str"and equivalence relation "++ pr_constr fi.field_req))
+    ) !field_from_name ]
 END
 
 
@@ -1146,18 +1135,23 @@ let ltac_field_structure e =
   [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
    field_simpl_eq_in_ok;cond_ok;pretac;posttac]
 
-let field_lookup (f:glob_tactic_expr) lH rl t gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rl = make_args_list rl t in
-  let e = find_field_structure env sigma rl in
-  let rl = carg (make_term_list e.field_carrier rl) in
-  let lH = carg (make_hyp_list env lH) in
-  let field = ltac_field_structure e in
-  ltac_apply f (field@[lH;rl]) gl
+let field_lookup (f:glob_tactic_expr) lH rl t =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try
+      let evdref = ref sigma in
+      let rl = make_args_list rl t in
+      let e = find_field_structure env sigma rl in
+      let rl = carg (make_term_list env evdref e.field_carrier rl) in
+      let lH = carg (make_hyp_list env evdref lH) in
+      let field = ltac_field_structure e in
+      Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
+    with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
+  end
 
 
 TACTIC EXTEND field_lookup
 | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
-      [ let (t,l) = list_sep_last lt in field_lookup f lH l t ]
+      [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
 END
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
index 580df9b5..595ba55e 100644
--- a/plugins/setoid_ring/vo.itarget
+++ b/plugins/setoid_ring/vo.itarget
@@ -7,7 +7,6 @@ InitialRing.vo
 NArithRing.vo
 RealField.vo
 Ring_base.vo
-Ring_equiv.vo
 Ring_polynom.vo
 Ring_tac.vo
 Ring_theory.vo
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
deleted file mode 100644
index f4d8b769..00000000
--- a/plugins/subtac/eterm.ml
+++ /dev/null
@@ -1,259 +0,0 @@
-(**
-   - Get types of existentials ;
-   - Flatten dependency tree (prefix order) ;
-   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
-   - Apply term prefixed by quantification on "existentials".
-*)
-
-open Term
-open Sign
-open Names
-open Evd
-open List
-open Pp
-open Util
-open Subtac_utils
-open Proof_type
-
-let trace s =
-  if !Flags.debug then (msgnl s; msgerr s)
-  else ()
-
-let succfix (depth, fixrels) =
-  (succ depth, List.map succ fixrels)
-
-type oblinfo =
-  { ev_name: int * identifier;
-    ev_hyps: named_context;
-    ev_status: obligation_definition_status;
-    ev_chop: int option;
-    ev_src: hole_kind located;
-    ev_typ: types;
-    ev_tac: tactic option;
-    ev_deps: Intset.t }
-
-(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *)
-open Store.Field
-let evar_tactic = Store.field ()
-
-(** Substitute evar references in t using De Bruijn indices,
-  where n binders were passed through. *)
-
-let subst_evar_constr evs n idf t = 
-  let seen = ref Intset.empty in
-  let transparent = ref Idset.empty in
-  let evar_info id = List.assoc id evs in
-  let rec substrec (depth, fixrels) c = match kind_of_term c with
-    | Evar (k, args) ->
-	let { ev_name = (id, idstr) ;
-	      ev_hyps = hyps ; ev_chop = chop } =
-	  try evar_info k
-	  with Not_found ->
-	    anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
-	in
-        seen := Intset.add id !seen;
-	  (* Evar arguments are created in inverse order,
-	     and we must not apply to defined ones (i.e. LetIn's)
-	  *)
-	let args =
-	  let n = match chop with None -> 0 | Some c -> c in
-	  let (l, r) = list_chop n (List.rev (Array.to_list args)) in
-	    List.rev r
-	in
-	let args =
-	  let rec aux hyps args acc =
-	     match hyps, args with
-		 ((_, None, _) :: tlh), (c :: tla) ->
-		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
-	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
-		   aux tlh tla acc
-	       | [], [] -> acc
-	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
-	  in aux hyps args []
-	in
-	  if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then
-	    transparent := Idset.add idstr !transparent;
-	  mkApp (idf idstr, Array.of_list args)
-    | Fix _ ->
-	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
-    | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
-  in
-  let t' = substrec (0, []) t in
-    t', !seen, !transparent
-
-
-(** Substitute variable references in t using De Bruijn indices,
-  where n binders were passed through. *)
-let subst_vars acc n t =
-  let var_index id = Util.list_index id acc in
-  let rec substrec depth c = match kind_of_term c with
-    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
-    | _ -> map_constr_with_binders succ substrec depth c
-  in
-    substrec 0 t
-
-(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
-    to a product : forall H1 : t1, ..., forall Hn : tn, concl.
-    Changes evars and hypothesis references to variable references.
-*)
-let etype_of_evar evs hyps concl =
-  let rec aux acc n = function
-      (id, copt, t) :: tl ->
-	let t', s, trans = subst_evar_constr evs n mkVar t in
-	let t'' = subst_vars acc 0 t' in
-	let rest, s', trans' = aux (id :: acc) (succ n) tl in
-	let s' = Intset.union s s' in
-	let trans' = Idset.union trans trans' in
-	  (match copt with
-	      Some c -> 
-		let c', s'', trans'' = subst_evar_constr evs n mkVar c in
-		let c' = subst_vars acc 0 c' in
-		  mkNamedProd_or_LetIn (id, Some c', t'') rest,
-		Intset.union s'' s',
-		Idset.union trans'' trans'
-	    | None ->
-		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
-    | [] ->
-	let t', s, trans = subst_evar_constr evs n mkVar concl in
-	  subst_vars acc 0 t', s, trans
-  in aux [] 0 (rev hyps)
-
-
-open Tacticals
-
-let trunc_named_context n ctx =
-  let len = List.length ctx in
-    list_firstn (len - n) ctx
-
-let rec chop_product n t =
-  if n = 0 then Some t
-  else
-    match kind_of_term t with
-      | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
-      | _ -> None
-
-let evars_of_evar_info evi =
-  Intset.union (Evarutil.evars_of_term evi.evar_concl)
-    (Intset.union
-	(match evi.evar_body with
-	| Evar_empty -> Intset.empty
-	| Evar_defined b -> Evarutil.evars_of_term b)
-	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
-
-let evar_dependencies evm oev =
-  let one_step deps =
-    Intset.fold (fun ev s ->
-      let evi = Evd.find evm ev in
-      let deps' = evars_of_evar_info evi in
-	if Intset.mem oev deps' then
-	  raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev))
-	else Intset.union deps' s)
-      deps deps
-  in
-  let rec aux deps =
-    let deps' = one_step deps in
-      if Intset.equal deps deps' then deps
-      else aux deps'
-  in aux (Intset.singleton oev)
-      
-let move_after (id, ev, deps as obl) l = 
-  let rec aux restdeps = function
-    | (id', _, _) as obl' :: tl -> 
-	let restdeps' = Intset.remove id' restdeps in
-	  if Intset.is_empty restdeps' then
-	    obl' :: obl :: tl
-	  else obl' :: aux restdeps' tl
-    | [] -> [obl]
-  in aux (Intset.remove id deps) l
-    
-let sort_dependencies evl =
-  let rec aux l found list =
-    match l with
-    | (id, ev, deps) as obl :: tl ->
-	let found' = Intset.union found (Intset.singleton id) in
-	  if Intset.subset deps found' then
-	    aux tl found' (obl :: list)
-	  else aux (move_after obl tl) found list
-    | [] -> List.rev list
-  in aux evl Intset.empty []
-
-let map_evar_body f = function
-  | Evar_empty -> Evar_empty
-  | Evar_defined c -> Evar_defined (f c)
-
-open Environ
-      
-let map_evar_info f evi =
-  { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps));
-    evar_concl = f evi.evar_concl;
-    evar_body = map_evar_body f evi.evar_body }
-    
-let eterm_obligations env name isevars evm fs ?status t ty = 
-  (* 'Serialize' the evars *)
-  let nc = Environ.named_context env in
-  let nc_len = Sign.named_context_length nc in
-  let evl = List.rev (to_list evm) in
-  let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
-  let sevl = sort_dependencies evl in
-  let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
-  let evn =
-    let i = ref (-1) in
-      List.rev_map (fun (id, ev) -> incr i;
-		      (id, (!i, id_of_string
-			      (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))),
-		       ev)) evl
-  in
-  let evts =
-    (* Remove existential variables in types and build the corresponding products *)
-    fold_right
-      (fun (id, (n, nstr), ev) l ->
-	 let hyps = Evd.evar_filtered_context ev in
-	 let hyps = trunc_named_context nc_len hyps in
-	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
-	 let evtyp, hyps, chop =
-	   match chop_product fs evtyp with
-	   | Some t -> t, trunc_named_context fs hyps, fs
-	   | None -> evtyp, hyps, 0
-	 in
-	 let loc, k = evar_source id isevars in
-	 let status = match k with QuestionMark o -> Some o | _ -> status in
-	 let status, chop = match status with
-	   | Some (Define true as stat) ->
-	       if chop <> fs then Define false, None
-	       else stat, Some chop
-	   | Some s -> s, None
-	   | None -> Define true, None
-	 in
-	 let tac = match evar_tactic.get ev.evar_extra with
-	   | Some t ->
-	       if Dyn.tag t = "tactic" then
-		 Some (Tacinterp.interp 
-			  (Tacinterp.globTacticIn (Tacinterp.tactic_out t)))
-	       else None
-	   | None -> None
-	 in
-	 let info = { ev_name = (n, nstr);
-		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
-		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
-	 in (id, info) :: l)
-      evn []
-  in
-  let t', _, transparent = (* Substitute evar refs in the term by variables *)
-    subst_evar_constr evts 0 mkVar t 
-  in
-  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
-  let evars = 
-    List.map (fun (ev, info) ->
-      let { ev_name = (_, name); ev_status = status;
-	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
-      in
-      let status = match status with
-	| Define true when Idset.mem name transparent -> Define false
-	| _ -> status
-      in name, typ, src, status, deps, tac) evts
-  in
-  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
-  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
-    Array.of_list (List.rev evars), (evnames, evmap), t', ty
-
-let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
deleted file mode 100644
index 35744b71..00000000
--- a/plugins/subtac/eterm.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Environ
-open Tacmach
-open Term
-open Evd
-open Names
-open Util
-open Tacinterp
-
-val mkMetas : int -> constr list
-
-val evar_dependencies : evar_map -> int -> Intset.t
-val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list
-
-(* env, id, evars, number of function prototypes to try to clear from
-   evars contexts, object and type *)
-val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int ->
-  ?status:obligation_definition_status -> constr -> types -> 
-  (identifier * types * hole_kind located * obligation_definition_status * Intset.t * 
-      tactic option) array
-    (* Existential key, obl. name, type as product, location of the original evar, associated tactic,
-       status and dependencies as indexes into the array *)
-  * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types
-    (* Translations from existential identifiers to obligation identifiers 
-       and for terms with existentials to closed terms, given a 
-       translation from obligation identifiers to constrs, new term, new type *)
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
deleted file mode 100644
index c89d135f..00000000
--- a/plugins/subtac/g_subtac.ml4
+++ /dev/null
@@ -1,167 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*
-  Syntax for the subtac terms and types.
-  Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
-
-
-open Flags
-open Util
-open Names
-open Nameops
-open Vernacentries
-open Reduction
-open Term
-open Libnames
-open Topconstr
-
-(* We define new entries for programs, with the use of this module
- * Subtac. These entries are named Subtac.<foo>
- *)
-
-module Gram = Pcoq.Gram
-module Vernac = Pcoq.Vernac_
-module Tactic = Pcoq.Tactic
-
-module SubtacGram =
-struct
-  let gec s = Gram.entry_create ("Subtac."^s)
-		(* types *)
-  let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc"
-
-  let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac"
-end
-
-open Glob_term
-open SubtacGram
-open Util
-open Pcoq
-open Prim
-open Constr
-let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
-
-GEXTEND Gram
-  GLOBAL: subtac_gallina_loc typeclass_constraint subtac_withtac;
-
-  subtac_gallina_loc:
-    [ [ g = Vernac.gallina -> loc, g
-    | g = Vernac.gallina_ext -> loc, g ] ]
-    ;
-
-  subtac_withtac:
-    [ [ "with"; t = Tactic.tactic -> Some t
-      | -> None ] ]
-  ;
-
-  Constr.closed_binder:
-    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
-	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
-          [LocalRawAssum ([id], default_binder_kind, typ)]
-    ] ];
-
-  END
-
-
-type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type
-
-let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
-  (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
-  (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
-  Genarg.create_arg None "subtac_gallina_loc"
-
-type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
-
-let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
-  (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
-  (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
-  Genarg.create_arg None "subtac_withtac"
-
-VERNAC COMMAND EXTEND Subtac
-[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
-  END
-
-let try_catch_exn f e =
-  try f e
-  with exn when Errors.noncritical exn ->
-    errorlabstrm "Program" (Errors.print exn)
-
-let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e
-let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e
-let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e
-let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e
-let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e
-let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e
-
-VERNAC COMMAND EXTEND Subtac_Obligations
-| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, Some name, Some t) tac ]
-| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, Some name, None) tac ]
-| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, None, Some t) tac ]
-| [ "Obligation" integer(num) subtac_withtac(tac) ] -> 
-    [ subtac_obligation (num, None, None) tac ]
-| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] -> 
-    [ next_obligation (Some name) tac ]
-| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligation
-| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] ->
-    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] ->
-    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_Obligations
-| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] ->
-    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" "using" tactic(t) ] ->
-    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
-| [ "Solve" "Obligations" ] ->
-    [ try_solve_obligations None None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
-| [ "Solve" "All" "Obligations" "using" tactic(t) ] ->
-    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
-| [ "Solve" "All" "Obligations" ] ->
-    [ solve_all_obligations None ]
-      END
-
-VERNAC COMMAND EXTEND Subtac_Admit_Obligations
-| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
-| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
-    END
-
-VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
-    Subtac_obligations.set_default_tactic 
-      (Vernacexpr.use_section_locality ())
-      (Tacinterp.glob_tactic t) ]
-END
-
-open Pp
-
-VERNAC COMMAND EXTEND Subtac_Show_Solver
-| [ "Show" "Obligation" "Tactic" ] -> [
-    msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Show_Obligations
-| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ]
-| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ]
-END
-
-VERNAC COMMAND EXTEND Subtac_Show_Preterm
-| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ]
-| [ "Preterm" ] -> [ Subtac_obligations.show_term None ]
-END
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
deleted file mode 100644
index 89d9050c..00000000
--- a/plugins/subtac/subtac.ml
+++ /dev/null
@@ -1,226 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Compat
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Namegen
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-open Vernacexpr
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-let require_library dirpath =
-  let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
-    Library.require_library [qualid] None
-
-open Pp
-open Ppconstr
-open Decl_kinds
-open Tacinterp
-open Tacexpr
-
-let solve_tccs_in_type env id isevars evm c typ =
-  if not (Evd.is_empty evm) then
-    let stmt_id = Nameops.add_suffix id "_stmt" in
-    let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
-      match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with
-      | Subtac_obligations.Defined cst -> constant_value (Global.env()) 
-	  (match cst with ConstRef kn -> kn | _ -> assert false)
-      | _ ->
-	  errorlabstrm "start_proof"
-	    (str "The statement obligations could not be resolved automatically, " ++ spc () ++
-		str "write a statement definition first.")
-  else
-    let _ = Typeops.infer_type env c in c
-
-
-let start_proof_com env isevars sopt kind (bl,t) hook =
-  let id = match sopt with
-    | Some (loc,id) ->
-        (* We check existence here: it's a bit late at Qed time *)
-        if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-          user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
-        id
-    | None ->
-	next_global_ident_away (id_of_string "Unnamed_thm")
- 	  (Pfedit.get_all_proof_names ())
-  in
-  let evm, c, typ, imps =
-    Subtac_pretyping.subtac_process ~is_type:true env isevars id [] (Topconstr.prod_constr_expr t bl) None
-  in
-  let c = solve_tccs_in_type env id isevars evm c typ in
-    Lemmas.start_proof id kind c (fun loc gr ->
-      Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps];
-      hook loc gr)
-
-let start_proof_and_print env isevars idopt k t hook =
-  start_proof_com env isevars idopt k t hook;
-  Vernacentries.print_subgoals ()
-
-let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
-
-let assumption_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-
-let declare_assumptions env isevars idl is_coe k bl c nl =
-  if not (Pfedit.refining ()) then
-    let id = snd (List.hd idl) in
-    let evm, c, typ, imps =
-      Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None
-    in
-    let c = solve_tccs_in_type env id isevars evm c typ in
-      List.iter (Command.declare_assumption is_coe k c imps false nl) idl
-  else
-    errorlabstrm "Command.Assumption"
-	(str "Cannot declare an assumption while in proof editing mode.")
-
-let dump_constraint ty ((loc, n), _, _) =
-  match n with
-    | Name id -> Dumpglob.dump_definition (loc, id) false ty
-    | Anonymous -> ()
-
-let dump_variable lid = ()
-
-let vernac_assumption env isevars kind l nl =
-  let global = fst kind = Global in
-    List.iter (fun (is_coe,(idl,c)) ->
-      if Dumpglob.dump () then
-	List.iter (fun lid ->
-	  if global then Dumpglob.dump_definition lid (not global) "ax"
-	  else dump_variable lid) idl;
-      declare_assumptions env isevars idl is_coe kind [] c nl) l
-
-let check_fresh (loc,id) =
-  if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
-    user_err_loc (loc,"",pr_id id ++ str " already exists")
-
-let subtac (loc, command) =
-  check_required_library ["Coq";"Init";"Datatypes"];
-  check_required_library ["Coq";"Init";"Specif"];
-  let env = Global.env () in
-  let isevars = ref (create_evar_defs Evd.empty) in
-  try
-  match command with
-  | VernacDefinition (defkind, (_, id as lid), expr, hook) ->
-      check_fresh lid;
-      Dumpglob.dump_definition lid false "def";
-      (match expr with
-      | ProveBody (bl, t) ->
-	  start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
-	    (fun _ _ -> ())
-      | DefineBody (bl, _, c, tycon) ->
-	  ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
-  | VernacFixpoint l ->
-      List.iter (fun ((lid, _, _, _, _), _) ->
-	check_fresh lid;
-	Dumpglob.dump_definition lid false "fix") l;
-      let _ = trace (str "Building fixpoint") in
-	ignore(Subtac_command.build_recursive l)
-
-  | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) ->
-      if guard <> None then 
-        error "Do not support building theorems as a fixpoint.";
-      Dumpglob.dump_definition id false "prf";
-      if not(Pfedit.refining ()) then
-	if lettop then
-	  errorlabstrm "Subtac_command.StartProof"
-	    (str "Let declarations can only be used in proof editing mode");
-      if Lib.is_modtype () then
-	errorlabstrm "Subtac_command.StartProof"
-	  (str "Proof editing mode not supported in module types");
-      check_fresh id;
-      start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
-
-  | VernacAssumption (stre,nl,l) ->
-      vernac_assumption env isevars stre l nl
-
-  | VernacInstance (abst, glob, sup, is, props, pri) ->
-      dump_constraint "inst" is;
-      if abst then
-	error "Declare Instance not supported here.";
-      ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
-
-  | VernacCoFixpoint l ->
-      if Dumpglob.dump () then
-	List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l;
-      ignore(Subtac_command.build_corecursive l)
-
-  (*| VernacEndProof e ->
-    subtac_end_proof e*)
-
-  | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
-  with
-  | Typing_error e ->
-      msg_warning (str "Type error in Program tactic:");
-      let cmds =
-	(match e with
-	| NonFunctionalApp (loc, x, mux, e) ->
-	    str "non functional application of term " ++
-	      e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
-	| NonSigma (loc, t) ->
-	    str "Term is not of Sigma type: " ++ t
-	| NonConvertible (loc, x, y) ->
-	    str "Unconvertible terms:" ++ spc () ++
-	      x ++ spc () ++ str "and" ++ spc () ++ y
-	| IllSorted (loc, t) ->
-	    str "Term is ill-sorted:" ++ spc () ++ t
-	)
-      in msg_warning cmds
-
-  | Subtyping_error e ->
-      msg_warning (str "(Program tactic) Subtyping error:");
-      let cmds =
-	match e with
-	| UncoercibleInferType (loc, x, y) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
-	| UncoercibleInferTerm (loc, x, y, tx, ty) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
-	    ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
-	| UncoercibleRewrite (x, y) ->
-	    str "Uncoercible terms:" ++ spc ()
-	    ++ x ++ spc () ++ str "and" ++ spc () ++ y
-      in msg_warning cmds
-
-  | Cases.PatternMatchingError (env, exn) as e -> raise e
-
-  | Type_errors.TypeError (env, exn) as e -> raise e
-
-  | Pretype_errors.PretypeError (env, _, exn) as e -> raise e
-
-  | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
-     Loc.Exc_located (loc, e') as e) -> raise e
-
-  | reraise ->
-      (*       msg_warning (str "Uncaught exception: " ++ Errors.print e); *)
-      raise reraise
diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli
deleted file mode 100644
index b51150aa..00000000
--- a/plugins/subtac/subtac.mli
+++ /dev/null
@@ -1,2 +0,0 @@
-val require_library : string -> unit
-val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
deleted file mode 100644
index 9ff8ba50..00000000
--- a/plugins/subtac/subtac_cases.ml
+++ /dev/null
@@ -1,2023 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Cases
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Namegen
-open Declarations
-open Inductiveops
-open Environ
-open Sign
-open Reductionops
-open Typeops
-open Type_errors
-open Glob_term
-open Retyping
-open Pretype_errors
-open Evarutil
-open Evarconv
-open Subtac_utils
-
-(************************************************************************)
-(*            Pattern-matching compilation (Cases)                      *)
-(************************************************************************)
-
-(************************************************************************)
-(* Configuration, errors and warnings *)
-
-open Pp
-
-let mssg_may_need_inversion () =
-  str "Found a matching with no clauses on a term unknown to have an empty inductive type"
-
-(* Utils *)
-let make_anonymous_patvars =
-  list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous))
-
-(* Environment management *)
-let push_rels vars env = List.fold_right push_rel vars env
-
-(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
-   over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
-
-let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
-
-let rec regeneralize_index i k t = match kind_of_term t with
-  | Rel j when j = i+k -> mkRel (k+1)
-  | Rel j when j < i+k -> t
-  | Rel j when j > i+k -> t
-  | _ -> map_constr_with_binders succ (regeneralize_index i) k t
-
-type alias_constr =
-  | DepAlias
-  | NonDepAlias
-
-let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
-  { uj_val =
-      (match d with
-	| DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
-	| NonDepAlias ->
-	    if (not (dependent (mkRel 1) j.uj_type))
-	      or (* A leaf: *) isRel deppat
-	    then
-	      (* The body of pat is not needed to type j - see *)
-	      (* insert_aliases - and both deppat and nondeppat have the *)
-	      (* same type, then one can freely substitute one by the other *)
-	      subst1 nondeppat j.uj_val
-	    else
-	      (* The body of pat is not needed to type j but its value *)
-	      (* is dependent in the type of j; our choice is to *)
-	      (* enforce this dependency *)
-	      mkLetIn (na,deppat,t,j.uj_val));
-    uj_type = subst1 deppat j.uj_type }
-
-(**********************************************************************)
-(* Structures used in compiling pattern-matching *)
-
-type rhs =
-    { rhs_env    : env;
-      avoid_ids  : identifier list;
-      it         : glob_constr;
-    }
-
-type equation =
-    { patterns     : cases_pattern list;
-      rhs          : rhs;
-      alias_stack  : name list;
-      eqn_loc      : loc;
-      used         : bool ref }
-
-type matrix = equation list
-
-(* 1st argument of IsInd is the original ind before extracting the summary *)
-type tomatch_type =
-  | IsInd of types * inductive_type
-  | NotInd of constr option * types
-
-type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list)
-  | Alias of (constr * constr * alias_constr * constr)
-  | Abstract of rel_declaration
-
-type tomatch_stack = tomatch_status list
-
-(* The type [predicate_signature] types the terms to match and the rhs:
-
-   - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
-     if dep<>Anonymous, the term is dependent, let n=|names|, if
-     n<>0 then the type of the pushed term is necessarily an
-     inductive with n real arguments. Otherwise, it may be
-     non inductive, or inductive without real arguments, or inductive
-     originating from a subterm in which case real args are not dependent;
-     it accounts for n+1 binders if dep or n binders if not dep
-   - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
-   - [PrCcl] types the right-hand side
-   - Aliases [Alias] have no trace in [predicate_signature]
-*)
-
-type predicate_signature =
-  | PrLetIn of (name list * name) * predicate_signature
-  | PrProd of predicate_signature
-  | PrCcl of constr
-
-(* We keep a constr for aliases and a cases_pattern for error message *)
-
-type alias_builder =
-  | AliasLeaf
-  | AliasConstructor of constructor
-
-type pattern_history =
-  | Top
-  | MakeAlias of alias_builder * pattern_continuation
-
-and pattern_continuation =
-  | Continuation of int * cases_pattern list * pattern_history
-  | Result of cases_pattern list
-
-let start_history n = Continuation (n, [], Top)
-
-let feed_history arg = function
-  | Continuation (n, l, h) when n>=1 ->
-      Continuation (n-1, arg :: l, h)
-  | Continuation (n, _, _) ->
-      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
-  | Result _ ->
-      anomaly "Exhausted pattern history"
-
-(* This is for non exhaustive error message *)
-
-let rec glob_pattern_of_partial_history args2 = function
-  | Continuation (n, args1, h) ->
-      let args3 = make_anonymous_patvars (n - (List.length args2)) in
-      build_glob_pattern (List.rev_append args1 (args2@args3)) h
-  | Result pl -> pl
-
-and build_glob_pattern args = function
-  | Top -> args
-  | MakeAlias (AliasLeaf, rh) ->
-      assert (args = []);
-      glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
-  | MakeAlias (AliasConstructor pci, rh) ->
-      glob_pattern_of_partial_history
-	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
-
-let complete_history = glob_pattern_of_partial_history []
-
-(* This is to build glued pattern-matching history and alias bodies *)
-
-let rec simplify_history = function
-  | Continuation (0, l, Top) -> Result (List.rev l)
-  | Continuation (0, l, MakeAlias (f, rh)) ->
-      let pargs = List.rev l in
-      let pat = match f with
-	| AliasConstructor pci ->
-	    PatCstr (dummy_loc,pci,pargs,Anonymous)
-	| AliasLeaf ->
-	    assert (l = []);
-	    PatVar (dummy_loc, Anonymous) in
-      feed_history pat rh
-  | h -> h
-
-(* Builds a continuation expecting [n] arguments and building [ci] applied
-   to this [n] arguments *)
-
-let push_history_pattern n current cont =
-  Continuation (n, [], MakeAlias (current, cont))
-
-(* A pattern-matching problem has the following form:
-
-   env, isevars |- <pred> Cases tomatch of mat end
-
-  where tomatch is some sequence of "instructions" (t1  ... tn)
-
-  and mat is some matrix
-   (p11 ... p1n -> rhs1)
-   (    ...            )
-   (pm1 ... pmn -> rhsm)
-
-  Terms to match: there are 3 kinds of instructions
-
-  - "Pushed" terms to match are typed in [env]; these are usually just
-    Rel(n) except for the initial terms given by user and typed in [env]
-  - "Abstract" instructions means an abstraction has to be inserted in the
-    current branch to build (this means a pattern has been detected dependent
-    in another one and generalisation is necessary to ensure well-typing)
-  - "Alias" instructions means an alias has to be inserted (this alias
-    is usually removed at the end, except when its type is not the
-    same as the type of the matched term from which it comes -
-    typically because the inductive types are "real" parameters)
-
-  Right-hand-sides:
-
-  They consist of a raw term to type in an environment specific to the
-  clause they belong to: the names of declarations are those of the
-  variables present in the patterns. Therefore, they come with their
-  own [rhs_env] (actually it is the same as [env] except for the names
-  of variables).
-
-*)
-type pattern_matching_problem =
-    { env      : env;
-      isevars  : Evd.evar_map ref;
-      pred     : predicate_signature option;
-      tomatch  : tomatch_stack;
-      history  : pattern_continuation;
-      mat      : matrix;
-      caseloc  : loc;
-      casestyle: case_style;
-      typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment }
-
-(*--------------------------------------------------------------------------*
- * A few functions to infer the inductive type from the patterns instead of *
- * checking that the patterns correspond to the ind. type of the            *
- * destructurated object. Allows type inference of examples like            *
- *  match n with O => true | _ => false end                                 *
- *  match x in I with C => true | _ => false end                            *
- *--------------------------------------------------------------------------*)
-
-(* Computing the inductive type from the matrix of patterns *)
-
-(* We use the "in I" clause to coerce the terms to match and otherwise
-   use the constructor to know in which type is the matching problem
-
-   Note that insertion of coercions inside nested patterns is done
-   each time the matrix is expanded *)
-
-let rec find_row_ind = function
-    [] -> None
-  | PatVar _ :: l -> find_row_ind l
-  | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
-
-let inductive_template isevars env tmloc ind =
-  let arsign = get_full_arity_sign env ind in
-  let hole_source = match tmloc with
-    | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
-    | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
-   let (_,evarl,_) =
-    List.fold_right
-      (fun (na,b,ty) (subst,evarl,n) ->
-	match b with
-        | None ->
-	    let ty' = substl subst ty in
-	    let e = e_new_evar isevars env ~src:(hole_source n) ty' in
-	    (e::subst,e::evarl,n+1)
-	| Some b ->
-	    (b::subst,evarl,n+1))
-      arsign ([],[],1) in
-   applist (mkInd ind,List.rev evarl)
-
-
-(************************************************************************)
-(* Utils *)
-
-let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
-  e_new_evar isevars env ~src:src (new_Type ())
-
-let evd_comb2 f isevars x y =
-  let (evd',y) = f !isevars x y in
-  isevars := evd';
-  y
-
-let context_of_arsign l =
-  let (x, _) = List.fold_right
-    (fun c (x, n) ->
-      (lift_rel_context n c @ x, List.length c + n))
-    l ([], 0)
-  in x
-
-(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
-
-let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
-  let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
-  let subst, len =
-    List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
-      let signlen = List.length sign in
-	match kind_of_term tm with
-	  | Rel n when dependent tm c
-		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
-	      ((n, len) :: subst, len - signlen)
-	  | Rel n when signlen > 1 (* The term is of a dependent type,
-				      maybe some variable in its type appears in the tycon. *) ->
-	      (match tmtype with
-	      | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
-	      | IsInd (_, IndType(indf,realargs)) ->
-		  let subst =
-		    if dependent tm c && List.for_all isRel realargs
-		    then (n, 1) :: subst else subst
-		  in
-		    List.fold_left
-		      (fun (subst, len) arg ->
-			match kind_of_term arg with
-			| Rel n when dependent arg c ->
-			    ((n, len) :: subst, pred len)
-			| _ -> (subst, pred len))
-		      (subst, len) realargs)
-	  | _ -> (subst, len - signlen))
-      ([], nar) tomatchs arsign
-  in
-  let rec predicate lift c =
-    match kind_of_term c with
-      | Rel n when n > lift ->
-	  (try
-	      (* Make the predicate dependent on the matched variable *)
-	      let idx = List.assoc (n - lift) subst in
-		mkRel (idx + lift)
-	    with Not_found ->
-	      (* A variable that is not matched, lift over the arsign. *)
-	      mkRel (n + nar))
-      | _ ->
-	  map_constr_with_binders succ predicate lift c
-  in
-    try
-      (* The tycon may be ill-typed after abstraction. *)
-      let pred = predicate 0 c in
-      let env' = push_rel_context (context_of_arsign arsign) env in
-	ignore(Typing.sort_of env' evm pred); pred
-    with e when Errors.noncritical e -> lift nar c
-
-module Cases_F(Coercion : Coercion.S) : S = struct
-
-let inh_coerce_to_ind isevars env ty tyi =
-  let expected_typ = inductive_template isevars env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour
-        un inductif cela doit être égal *)
-  let _ = e_cumul env isevars expected_typ ty in ()
-
-let unify_tomatch_with_patterns isevars env loc typ pats =
-  match find_row_ind pats with
-    | None -> NotInd (None,typ)
-    | Some (_,(ind,_)) ->
-	inh_coerce_to_ind isevars env typ ind;
-	try IsInd (typ,find_rectype env ( !isevars) typ)
-	with Not_found -> NotInd (None,typ)
-
-let find_tomatch_tycon isevars env loc = function
-  (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
-  | None -> empty_tycon
-
-let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
-  let loc = Some (loc_of_glob_constr tomatch) in
-  let tycon = find_tomatch_tycon isevars env loc indopt in
-  let j = typing_fun tycon env tomatch in
-  let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !isevars j in
-  isevars := evd;
-  let typ = nf_evar ( !isevars) j.uj_type in
-  let t =
-    try IsInd (typ,find_rectype env ( !isevars) typ)
-    with Not_found ->
-      unify_tomatch_with_patterns isevars env loc typ pats in
-  (j.uj_val,t)
-
-let coerce_to_indtype typing_fun isevars env matx tomatchl =
-  let pats = List.map (fun r ->  r.patterns) matx in
-  let matx' = match matrix_transpose pats with
-    | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
-    | m -> m in
-  List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
-
-
-
-let adjust_tomatch_to_pattern pb ((current,typ),deps) =
-  (* Ideally, we could find a common inductive type to which both the
-     term to match and the patterns coerce *)
-  (* In practice, we coerce the term to match if it is not already an
-     inductive type and it is not dependent; moreover, we use only
-     the first pattern type and forget about the others *)
-  let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
-  let typ =
-    try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ)
-    with Not_found -> NotInd (None,typ) in
-  let tomatch = ((current,typ),deps) in
-  match typ with
-  | NotInd (None,typ) ->
-      let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
-      (match find_row_ind tm1 with
-	| None -> tomatch
-	| Some (_,(ind,_)) ->
-	    let indt = inductive_template pb.isevars pb.env None ind in
-	    let current =
-	      if deps = [] & isEvar typ then
-	      (* Don't insert coercions if dependent; only solve evars *)
-		let _ = e_cumul pb.env pb.isevars indt typ in
-		current
-	      else
-		(evd_comb2 (Coercion.inh_conv_coerce_to true dummy_loc pb.env)
-		  pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
-	    let sigma =  !(pb.isevars) in
-	    let typ = IsInd (indt,find_rectype pb.env sigma indt) in
-	    ((current,typ),deps))
-  | _ -> tomatch
-
-   (* extract some ind from [t], possibly coercing from constructors in [tm] *)
-let to_mutind env isevars tm c t =
-(*  match c with
-    | Some body -> *) NotInd (c,t)
-(*    | None -> unify_tomatch_with_patterns isevars env t tm*)
-
-let type_of_tomatch = function
-  | IsInd (t,_) -> t
-  | NotInd (_,t) -> t
-
-let mkDeclTomatch na = function
-  | IsInd (t,_) -> (na,None,t)
-  | NotInd (c,t) -> (na,c,t)
-
-let map_tomatch_type f = function
-  | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
-  | NotInd (c,t) -> NotInd (Option.map f c, f t)
-
-let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
-let lift_tomatch_type n = liftn_tomatch_type n 1
-
-(**********************************************************************)
-(* Utilities on patterns *)
-
-let current_pattern eqn =
-  match eqn.patterns with
-    | pat::_ -> pat
-    | [] -> anomaly "Empty list of patterns"
-
-let alias_of_pat = function
-  | PatVar (_,name) -> name
-  | PatCstr(_,_,_,name) -> name
-
-let remove_current_pattern eqn =
-  match eqn.patterns with
-    | pat::pats ->
-	{ eqn with
-	    patterns = pats;
-	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
-    | [] -> anomaly "Empty list of patterns"
-
-let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
-
-(**********************************************************************)
-(* Well-formedness tests *)
-(* Partial check on patterns *)
-
-exception NotAdjustable
-
-let rec adjust_local_defs loc = function
-  | (pat :: pats, (_,None,_) :: decls) ->
-      pat :: adjust_local_defs loc (pats,decls)
-  | (pats, (_,Some _,_) :: decls) ->
-      PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
-  | [], [] -> []
-  | _ -> raise NotAdjustable
-
-let check_and_adjust_constructor env ind cstrs = function
-  | PatVar _ as pat -> pat
-  | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
-      (* Check it is constructor of the right type *)
-      let ind' = inductive_of_constructor cstr in
-      if Names.eq_ind ind' ind then
-	(* Check the constructor has the right number of args *)
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	if List.length args = nb_args_constr then pat
-	else
-	  try
-	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
-	    in PatCstr (loc, cstr, args', alias)
-	  with NotAdjustable ->
-	    error_wrong_numarg_constructor_loc loc (Global.env())
-	      cstr nb_args_constr
-      else
-	(* Try to insert a coercion *)
-	try
-	  Coercion.inh_pattern_coerce_to loc pat ind' ind
-	with Not_found ->
-	  error_bad_constructor_loc loc cstr ind
-
-let check_all_variables typ mat =
-  List.iter
-    (fun eqn -> match current_pattern eqn with
-       | PatVar (_,id) -> ()
-       | PatCstr (loc,cstr_sp,_,_) ->
-	   error_bad_pattern_loc loc cstr_sp typ)
-    mat
-
-let check_unused_pattern env eqn =
-  if not !(eqn.used) then
-    raise_pattern_matching_error
-      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
-
-let set_used_pattern eqn = eqn.used := true
-
-let extract_rhs pb =
-  match pb.mat with
-    | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
-    | eqn::_ ->
-	set_used_pattern eqn;
-	eqn.rhs
-
-(**********************************************************************)
-(* Functions to deal with matrix factorization *)
-
-let occur_in_rhs na rhs =
-  match na with
-    | Anonymous -> false
-    | Name id -> occur_glob_constr id rhs.it
-
-let is_dep_patt eqn = function
-  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
-  | PatCstr _ -> true
-
-let dependencies_in_rhs nargs eqns =
-  if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
-  else
-  let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
-  let columns = matrix_transpose deps in
-  List.map (List.exists ((=) true)) columns
-
-let dependent_decl a = function
-  | (na,None,t) -> dependent a t
-  | (na,Some c,t) -> dependent a t || dependent a c
-
-(* Computing the matrix of dependencies *)
-
-(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
-   computes for declaration [k+1] in which of declarations in
-   [nextlist] (which corresponds to d(k+2)...dn) it depends;
-   declarations are expressed by index, e.g. in dependency list
-   [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
-
-let rec find_dependency_list k n = function
-  | [] -> []
-  | (used,tdeps,d)::rest ->
-      let deps = find_dependency_list k (n+1) rest in
-      if used && dependent_decl (mkRel n) d
-      then list_add_set (List.length rest + 1) (list_union deps tdeps)
-      else deps
-
-let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
-  let deps = find_dependency_list k 1 nextlist in
-  if is_dep_or_cstr_in_rhs || deps <> []
-  then (k-1,(true ,deps,d)::nextlist)
-  else (k-1,(false,[]  ,d)::nextlist)
-
-let find_dependencies_signature deps_in_rhs typs =
-  let k = List.length deps_in_rhs in
-  let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
-  List.map (fun (_,deps,_) -> deps) l
-
-(******)
-
-(* A Pushed term to match has just been substituted by some
-   constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
-   match
-
-   - all terms to match and to push (dependent on t by definition)
-     must have (Rel depth) substituted by t and Rel's>depth lifted by n
-   - all pushed terms to match (non dependent on t by definition) must
-     be lifted by n
-
-  We start with depth=1
-*)
-
-let regeneralize_index_tomatch n =
-  let rec genrec depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = regeneralize_index n depth c in
-      let tm = map_tomatch_type (regeneralize_index n depth) tm in
-      let l = List.map (regeneralize_rel n depth) l in
-      Pushed ((c,tm),l)::(genrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (regeneralize_index n depth) d)
-      ::(genrec (depth+1) rest) in
-  genrec 0
-
-let rec replace_term n c k t =
-  if isRel t && destRel t = n+k then lift k c
-  else map_constr_with_binders succ (replace_term n c) k t
-
-let replace_tomatch n c =
-  let rec replrec depth = function
-  | [] -> []
-  | Pushed ((b,tm),l)::rest ->
-      let b = replace_term n c depth b in
-      let tm = map_tomatch_type (replace_term n c depth) tm in
-      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l)::(replrec depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (replace_term n c depth) d)
-      ::(replrec (depth+1) rest) in
-  replrec 0
-
-let rec liftn_tomatch_stack n depth = function
-  | [] -> []
-  | Pushed ((c,tm),l)::rest ->
-      let c = liftn n depth c in
-      let tm = liftn_tomatch_type n depth tm in
-      let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
-  | Alias (c1,c2,d,t)::rest ->
-      Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
-      ::(liftn_tomatch_stack n depth rest)
-  | Abstract d::rest ->
-      Abstract (map_rel_declaration (liftn n depth) d)
-      ::(liftn_tomatch_stack n (depth+1) rest)
-
-
-let lift_tomatch_stack n = liftn_tomatch_stack n 1
-
-(* if [current] has type [I(p1...pn u1...um)] and we consider the case
-   of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
-   default variable [name] is expected to have which type?
-   Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
-
-(************************************************************************)
-(* Some heuristics to get names for variables pushed in pb environment *)
-(* Typical requirement:
-
-   [match y with (S (S x)) => x | x => x end] should be compiled into
-   [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
-
-   and [match y with (S (S n)) => n | n => n end] into
-   [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
-
-  i.e. user names should be preserved and created names should not
-  interfere with user names *)
-
-let merge_name get_name obj = function
-  | Anonymous -> get_name obj
-  | na -> na
-
-let merge_names get_name = List.map2 (merge_name get_name)
-
-let get_names env sign eqns =
-  let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
-  (* If any, we prefer names used in pats, from top to bottom *)
-  let names2 =
-    List.fold_right
-      (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
-      eqns names1 in
-  (* Otherwise, we take names from the parameters of the constructor but
-     avoiding conflicts with user ids *)
-  let allvars =
-    List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
-  let names4,_ =
-    List.fold_left2
-      (fun (l,avoid) d na ->
-	 let na =
-	   merge_name
-	     (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
-	     d na
-	 in
-         (na::l,(out_name na)::avoid))
-      ([],allvars) (List.rev sign) names2 in
-  names4
-
-(************************************************************************)
-(* Recovering names for variables pushed to the rhs' environment *)
-
-let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
-
-let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
-				(n, b, t)) sign
-
-let push_rels_eqn sign eqn =
-  let sign = all_name sign in
-    {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
-
-let push_rels_eqn_with_names sign eqn =
-  let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
-  let sign = recover_alias_names alias_of_pat pats sign in
-  push_rels_eqn sign eqn
-
-let build_aliases_context env sigma names allpats pats =
-  (* pats is the list of bodies to push as an alias *)
-  (* They all are defined in env and we turn them into a sign *)
-  (* cuts in sign need to be done in allpats *)
-  let rec insert env sign1 sign2 n newallpats oldallpats = function
-    | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
-        (* Anonymous leaves must be considered named and treated in the *)
-        (* next clause because they may occur in implicit arguments *)
-	insert env sign1 sign2
-	  n newallpats (List.map List.tl oldallpats) (pats,names)
-    | (deppat,nondeppat,d,t)::pats, na::names ->
-	let nondeppat = lift n nondeppat in
-	let deppat = lift n deppat in
-	let newallpats =
-	  List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
-	let oldallpats = List.map List.tl oldallpats in
-	let decl = (na,Some deppat,t) in
-	let a = (deppat,nondeppat,d,t) in
-	insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
-	  newallpats oldallpats (pats,names)
-    | [], [] -> newallpats, sign1, sign2, env
-    | _ -> anomaly "Inconsistent alias and name lists" in
-  let allpats = List.map (fun x -> [x]) allpats
-  in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
-
-let insert_aliases_eqn sign eqnnames alias_rest eqn =
-  let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
-    push_rels_eqn thissign { eqn with  alias_stack = alias_rest; }
-
-
-let insert_aliases env sigma alias eqns =
-  (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
-  (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
-  (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
-  let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
-  let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
-  (* names2 takes the meet of all needed aliases *)
-  let names2 =
-    List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
-  (* Only needed aliases are kept by build_aliases_context *)
-  let eqnsnames, sign1, sign2, env =
-    build_aliases_context env sigma [names2] eqnsnames [alias] in
-  let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
-  sign2, env, eqns
-
-(**********************************************************************)
-(* Functions to deal with elimination predicate *)
-
-exception Occur
-let noccur_between_without_evar n m term =
-  let rec occur_rec n c = match kind_of_term c with
-    | Rel p       -> if n<=p && p<n+m then raise Occur
-    | Evar (_,cl) -> ()
-    | _             -> iter_constr_with_binders succ occur_rec n c
-  in
-  try occur_rec n term; true with Occur -> false
-
-(* Inferring the predicate *)
-let prepare_unif_pb typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-
-  (* We may need to invert ci if its parameters occur in typ *)
-  let typ' =
-    if noccur_between_without_evar 1 n typ then lift (-n) typ
-    else (* TODO4-1 *)
-      error "Unable to infer return clause of this pattern-matching problem" in
-  let args = extended_rel_list (-n) cs.cs_args in
-  let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
-
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
-  (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
-
-
-(* Infering the predicate *)
-(*
-The problem to solve is the following:
-
-We match Gamma |- t : I(u01..u0q) against the following constructors:
-
-  Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
-   ...
-  Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
-
-Assume the types in the branches are the following
-
-  Gamma, x11...x1p1 |- branch1 : T1
-   ...
-  Gamma, xn1...xnpn |- branchn : Tn
-
-Assume the type of the global case expression is Gamma |- T
-
-The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
-the following n+1 equations:
-
-  Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1))  =  T1
-   ...
-  Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn))  =  Tn
-  Gamma             |- (phi u01..u0q t)               =  T
-
-Some hints:
-
-- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
-  should be inserted somewhere in Ti.
-
-- If T is undefined, an easy solution is to insert a "match z with (Ci
-  xi1..xipi) => ..." in front of each Ti
-
-- Otherwise, T1..Tn and T must be step by step unified, if some of them
-  diverge, then try to replace the diverging subterm by one of y1..yq or z.
-
-- The main problem is what to do when an existential variables is encountered
-
-let prepare_unif_pb typ cs =
-  let n = cs.cs_nargs in
-  let _,p = decompose_prod_n n typ in
-  let ci = build_dependent_constructor cs in
-  (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
-  (n, cs.cs_concl_realargs, ci, p)
-
-let eq_operator_lift k (n,n') = function
-  | OpRel p, OpRel p' when p > k & p' > k ->
-      if p < k+n or p' < k+n' then false else p - n = p' - n'
-  | op, op' -> op = op'
-
-let rec transpose_args n =
-  if n=0 then []
-  else
-    (Array.map (fun l -> List.hd l) lv)::
-    (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
-
-let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
-
-let reloc_operator (k,n) = function OpRel p when p > k ->
-let rec unify_clauses k pv =
-  let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in
-  let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
-  if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
-  then
-    let argvl = transpose_args (List.length args1) pv' in
-    let k' = shift_operator k op1 in
-    let argl = List.map (unify_clauses k') argvl in
-    gather_constr (reloc_operator (k,n1) op1) argl
-*)
-
-let abstract_conclusion typ cs =
-  let n = List.length (assums_of_rel_context cs.cs_args) in
-  let (sign,p) = decompose_prod_n n typ in
-  it_mkLambda p sign
-
-let infer_predicate loc env isevars typs cstrs indf =
-  (* Il faudra substituer les isevars a un certain moment *)
-  if Array.length cstrs = 0 then (* "TODO4-3" *)
-    error "Inference of annotation for empty inductive types not implemented"
-  else
-    (* Empiric normalization: p may depend in a irrelevant way on args of the*)
-    (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
-    let typs =
-      Array.map (local_strong whd_beta ( !isevars)) typs
-    in
-    let eqns = array_map2 prepare_unif_pb typs cstrs in
-    (* First strategy: no dependencies at all *)
-(*
-    let (mis,_) = dest_ind_family indf in
-    let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
-*)
-    let (sign,_) = get_arity env indf in
-    let mtyp =
-      if array_exists is_Type typs then
-	(* Heuristic to avoid comparison between non-variables algebric univs*)
-	new_Type ()
-      else
-	mkExistential env ~src:(loc, Evd.CasesType) isevars
-    in
-    if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
-    then
-      (* Non dependent case -> turn it into a (dummy) dependent one *)
-      let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-      (true,pred) (* true = dependent -- par défaut *)
-    else
-(*
-      let s = get_sort_of env ( isevars) typs.(0) in
-      let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
-      let caseinfo = make_default_case_info mis in
-      let brs = array_map2 abstract_conclusion typs cstrs in
-      let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
-      let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
-*)
-      (* "TODO4-2" *)
-      (* We skip parameters *)
-      let cis =
-	Array.map
-	  (fun cs ->
-	     applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
-	  cstrs in
-      let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
-      raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
-(*
-      (true,pred)
-*)
-
-(* Propagation of user-provided predicate through compilation steps *)
-
-let rec map_predicate f k = function
-  | PrCcl ccl -> PrCcl (f k ccl)
-  | PrProd pred ->
-      PrProd (map_predicate f (k+1) pred)
-  | PrLetIn ((names,dep as tm),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      PrLetIn (tm, map_predicate f (k+k') pred)
-
-let rec noccurn_predicate k = function
-  | PrCcl ccl -> noccurn k ccl
-  | PrProd pred -> noccurn_predicate (k+1) pred
-  | PrLetIn ((names,dep),pred) ->
-      let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
-      noccurn_predicate (k+k') pred
-
-let liftn_predicate n = map_predicate (liftn n)
-
-let lift_predicate n = liftn_predicate n 1
-
-let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
-
-let substnl_predicate sigma = map_predicate (substnl sigma)
-
-(* This is parallel bindings *)
-let subst_predicate (args,copt) pred =
-  let sigma = match copt with
-    | None -> List.rev args
-    | Some c -> c::(List.rev args) in
-  substnl_predicate sigma 0 pred
-
-let specialize_predicate_var (cur,typ) = function
-  | PrProd _ | PrCcl _ ->
-     anomaly "specialize_predicate_var: a pattern-variable must be pushed"
-  | PrLetIn (([],dep),pred) ->
-      subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
-  | PrLetIn ((_,dep),pred) ->
-      (match typ with
-        | IsInd (_,IndType (_,realargs)) ->
-           subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
-        | _ -> anomaly "specialize_predicate_var")
-
-let ungeneralize_predicate = function
-  | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
-  | PrProd pred -> pred
-
-(*****************************************************************************)
-(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
-(* and we want to abstract P over y:t(x) typed in the same context to get    *)
-(*                                                                           *)
-(*    pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y']                          *)
-(*                                                                           *)
-(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x'        *)
-(* then we have to replace x by x' in t(x) and y by y' in P                  *)
-(*****************************************************************************)
-let generalize_predicate ny d = function
-  | PrLetIn ((names,dep as tm),pred) ->
-      if dep=Anonymous then anomaly "Undetected dependency";
-      let p = List.length names + 1 in
-      let pred = lift_predicate 1 pred in
-      let pred = regeneralize_index_predicate (ny+p+1) pred in
-      PrLetIn (tm, PrProd pred)
-  | PrProd _ | PrCcl _ ->
-      anomaly "generalize_predicate: expects a non trivial pattern"
-
-let rec extract_predicate l = function
-  | pred, Alias (deppat,nondeppat,_,_)::tms ->
-      let tms' = match kind_of_term nondeppat with
-        | Rel i -> replace_tomatch i deppat tms
-        | _ -> (* initial terms are not dependent *) tms in
-      extract_predicate l (pred,tms')
-  | PrProd pred, Abstract d'::tms ->
-      let d' = map_rel_declaration (lift (List.length l)) d' in
-      substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
-  | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
-      let l = List.rev realargs@l in
-      extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
-  | PrCcl ccl, [] ->
-      substl l ccl
-  | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
-
-let abstract_predicate env sigma indf cur tms = function
-  | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
-  | PrLetIn ((names,dep),pred) ->
-      let sign = make_arity_signature env true indf in
-      (* n is the number of real args + 1 *)
-      let n = List.length sign in
-      let tms = lift_tomatch_stack n tms in
-      let tms =
-        match kind_of_term cur with
-          | Rel i -> regeneralize_index_tomatch (i+n) tms
-          | _ -> (* Initial case *) tms in
-      (* Depending on whether the predicate is dependent or not, and has real
-         args or not, we lift it to make room for [sign] *)
-      (* Even if not intrinsically dep, we move the predicate into a dep one *)
-      let sign,k =
-        if names = [] & n <> 1 then
-          (* Real args were not considered *)
-          (if dep<>Anonymous then
-            ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
-          else
-            (sign,n))
-        else
-          (* Real args are OK *)
-          (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
-           if dep<>Anonymous then 0 else 1) in
-      let pred = lift_predicate k pred in
-      let pred = extract_predicate [] (pred,tms) in
-      (true, it_mkLambda_or_LetIn_name env pred sign)
-
-let rec known_dependent = function
-  | None -> false
-  | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
-  | Some (PrCcl _) -> false
-  | Some (PrProd _) ->
-      anomaly "known_dependent: can only be used when patterns remain"
-
-(* [expand_arg] is used by [specialize_predicate]
-   it replaces gamma, x1...xn, x1...xk |- pred
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
-   by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
-
-let expand_arg n alreadydep (na,t) deps (k,pred) =
-  (* current can occur in pred even if the original problem is not dependent *)
-  let dep =
-    if alreadydep<>Anonymous then alreadydep
-    else if deps = [] && noccurn_predicate 1 pred then Anonymous
-    else Name (id_of_string "x") in
-  let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
-  (* There is no dependency in realargs for subpattern *)
-  (k-1, PrLetIn (([],dep), pred))
-
-
-(*****************************************************************************)
-(* pred = [X:=realargs;x:=c]P types the following problem:                   *)
-(*                                                                           *)
-(*  Gamma |- match Pushed(c:I(realargs)) rest with...end: pred               *)
-(*                                                                           *)
-(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi)      *)
-(* is considered. Assume each Ti is some Ii(argsi).                          *)
-(* We let e=Ci(x1,...,xn) and replace pred by                                *)
-(*                                                                           *)
-(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
-(*                                                                           *)
-(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
-(*                                                                           *)
-(*****************************************************************************)
-let specialize_predicate tomatchs deps cs = function
-  | (PrProd _ | PrCcl _) ->
-      anomaly "specialize_predicate: a matched pattern must be pushed"
-  | PrLetIn ((names,isdep),pred) ->
-      (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
-      let nrealargs = List.length names in
-      let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
-      (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
-      let n = cs.cs_nargs in
-      let pred' = liftn_predicate n (k+1) pred in
-      let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
-      let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
-      (* The substituends argsi, copti are all defined in gamma, x1...xn *)
-      (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
-      let pred'' = subst_predicate (argsi, copti) pred' in
-      (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
-      let pred''' = liftn_predicate n (n+1) pred'' in
-      (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
-      snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
-
-let find_predicate loc env isevars p typs cstrs current
-  (IndType (indf,realargs)) tms =
-  let (dep,pred) =
-    match p with
-      | Some p -> abstract_predicate env ( !isevars) indf current tms p
-      | None -> infer_predicate loc env isevars typs cstrs indf in
-  let typ = whd_beta ( !isevars) (applist (pred, realargs)) in
-  if dep then
-    (pred, whd_beta ( !isevars) (applist (typ, [current])),
-     new_Type ())
-  else
-    (pred, typ, new_Type ())
-
-(************************************************************************)
-(* Sorting equations by constructor *)
-
-type inversion_problem =
-  (* the discriminating arg in some Ind and its order in Ind *)
-  | Incompatible of int * (int * int)
-  | Constraints of (int * constr) list
-
-let solve_constraints constr_info indt =
-  (* TODO *)
-  Constraints []
-
-let rec irrefutable env = function
-  | PatVar (_,name) -> true
-  | PatCstr (_,cstr,args,_) ->
-      let ind = inductive_of_constructor cstr in
-      let (_,mip) = Inductive.lookup_mind_specif env ind in
-      let one_constr = Array.length mip.mind_user_lc = 1 in
-      one_constr & List.for_all (irrefutable env) args
-
-let first_clause_irrefutable env = function
-  | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
-  | _ -> false
-
-let group_equations pb ind current cstrs mat =
-  let mat =
-    if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
-  let brs = Array.create (Array.length cstrs) [] in
-  let only_default = ref true in
-  let _ =
-    List.fold_right (* To be sure it's from bottom to top *)
-      (fun eqn () ->
-	 let rest = remove_current_pattern eqn in
-	 let pat = current_pattern eqn in
-	 match check_and_adjust_constructor pb.env ind cstrs pat with
-	   | PatVar (_,name) ->
-	       (* This is a default clause that we expand *)
-	       for i=1 to Array.length cstrs do
-		 let n = cstrs.(i-1).cs_nargs in
-		 let args = make_anonymous_patvars n in
-		 brs.(i-1) <- (args, rest) :: brs.(i-1)
-	       done
-	   | PatCstr (loc,((_,i)),args,_) ->
-	       (* This is a regular clause *)
-	       only_default := false;
-	       brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
-  (brs,!only_default)
-
-(************************************************************************)
-(* Here starts the pattern-matching compilation algorithm *)
-
-(* Abstracting over dependent subterms to match *)
-let rec generalize_problem pb = function
-  | [] -> pb
-  | i::l ->
-      let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
-      let pb' = generalize_problem pb l in
-      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
-      let tomatch = regeneralize_index_tomatch (i+1) tomatch in
-      { pb with
-	  tomatch = Abstract d :: tomatch;
-          pred = Option.map (generalize_predicate i d) pb'.pred }
-
-(* No more patterns: typing the right-hand side of equations *)
-let build_leaf pb =
-  let rhs = extract_rhs pb in
-  let tycon = match pb.pred with
-    | None -> anomaly "Predicate not found"
-    | Some (PrCcl typ) -> mk_tycon typ
-    | Some _ -> anomaly "not all parameters of pred have been consumed" in
-    pb.typing_function tycon rhs.rhs_env rhs.it
-
-(* Building the sub-problem when all patterns are variables *)
-let shift_problem (current,t) pb =
-  {pb with
-     tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
-     pred = Option.map (specialize_predicate_var (current,t)) pb.pred;
-     history = push_history_pattern 0 AliasLeaf pb.history;
-     mat = List.map remove_current_pattern pb.mat }
-
-(* Building the sub-pattern-matching problem for a given branch *)
-let build_branch current deps pb eqns const_info =
-  (* We remember that we descend through a constructor *)
-  let alias_type =
-    if Array.length const_info.cs_concl_realargs = 0
-      & not (known_dependent pb.pred) & deps = []
-    then
-      NonDepAlias
-    else
-      DepAlias
-  in
-  let history =
-    push_history_pattern const_info.cs_nargs
-      (AliasConstructor const_info.cs_cstr)
-      pb.history in
-
-  (* We find matching clauses *)
-  let cs_args = (*assums_of_rel_context*) const_info.cs_args in
-  let names = get_names pb.env cs_args eqns in
-  let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
-  if submat = [] then
-    raise_pattern_matching_error
-      (dummy_loc, pb.env, NonExhaustive (complete_history history));
-  let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
-  let _,typs',_ =
-    List.fold_right
-      (fun (na,c,t as d) (env,typs,tms) ->
-	 let tm1 = List.map List.hd tms in
-	 let tms = List.map List.tl tms in
- 	 (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
-      typs (pb.env,[],List.map fst eqns) in
-
-  let dep_sign =
-    find_dependencies_signature
-      (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
-
-  (* The dependent term to subst in the types of the remaining UnPushed
-     terms is relative to the current context enriched by topushs *)
-  let ci = build_dependent_constructor const_info in
-
-  (* We replace [(mkRel 1)] by its expansion [ci] *)
-  (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
-  (* This is done in two steps : first from "Gamma |- tms" *)
-  (* into  "Gamma; typs; curalias |- tms" *)
-  let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
-
-  let currents =
-    list_map2_i
-      (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
-      1 typs' (List.rev dep_sign) in
-
-  let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
-  let ind =
-    appvect (
-      applist (mkInd (inductive_of_constructor const_info.cs_cstr),
-      List.map (lift const_info.cs_nargs) const_info.cs_params),
-      const_info.cs_concl_realargs) in
-
-  let cur_alias = lift (List.length sign) current in
-  let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
-  let env' = push_rels sign pb.env in
-  let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
-    sign,
-  { pb with
-      env = env';
-      tomatch = List.rev_append currents tomatch;
-      pred = pred';
-      history = history;
-      mat = List.map (push_rels_eqn_with_names sign) submat }
-
-(**********************************************************************
- INVARIANT:
-
-  pb = { env, subst, tomatch, mat, ...}
-  tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
-
-  "Pushed" terms and types are relative to env
-  "Abstract" types are relative to env enriched by the previous terms to match
-
-*)
-
-(**********************************************************************)
-(* Main compiling descent *)
-let rec compile pb =
-  match pb.tomatch with
-    | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
-    | (Alias x)::rest -> compile_alias pb x rest
-    | (Abstract d)::rest -> compile_generalization pb d rest
-    | [] -> build_leaf pb
-
-and match_current pb tomatch =
-  let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
-  match typ with
-    | NotInd (_,typ) ->
-	check_all_variables typ pb.mat;
-	compile (shift_problem ct pb)
-    | IsInd (_,(IndType(indf,realargs) as indt)) ->
-	let mind,_ = dest_ind_family indf in
-	let cstrs = get_constructors pb.env indf in
-	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
-	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
-	  compile (shift_problem ct pb)
-	else
-          let _constraints = Array.map (solve_constraints indt) cstrs in
-
-	  (* We generalize over terms depending on current term to match *)
-	  let pb = generalize_problem pb deps in
-
-	  (* We compile branches *)
-	  let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
-
-	  (* We build the (elementary) case analysis *)
-	  let brvals = Array.map (fun (v,_) -> v) brs in
-	  let brtyps = Array.map (fun (_,t) -> t) brs in
-	  let (pred,typ,s) =
-	    find_predicate pb.caseloc pb.env pb.isevars
-	      pb.pred brtyps cstrs current indt pb.tomatch in
-	  let ci = make_case_info pb.env mind pb.casestyle in
-	  let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
-	  let inst = List.map mkRel deps in
-	  { uj_val = applist (case, inst);
-	    uj_type = substl inst typ }
-
-and compile_branch current deps pb eqn cstr =
-  let sign, pb = build_branch current deps pb eqn cstr in
-  let j = compile pb in
-  (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
-
-and compile_generalization pb d rest =
-  let pb =
-    { pb with
-       env = push_rel d pb.env;
-       tomatch = rest;
-       pred = Option.map ungeneralize_predicate pb.pred;
-       mat = List.map (push_rels_eqn [d]) pb.mat } in
-  let j = compile pb in
-  { uj_val = mkLambda_or_LetIn d j.uj_val;
-    uj_type = mkProd_or_LetIn d j.uj_type }
-
-and compile_alias pb (deppat,nondeppat,d,t) rest =
-  let history = simplify_history pb.history in
-  let sign, newenv, mat =
-    insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
-  let n = List.length sign in
-
-  (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
-  (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
-  let tomatch = lift_tomatch_stack n rest in
-  let tomatch = match kind_of_term nondeppat with
-    | Rel i ->
-	if n = 1 then regeneralize_index_tomatch (i+n) tomatch
-	else replace_tomatch i deppat tomatch
-    | _ -> (* initial terms are not dependent *) tomatch in
-
-  let pb =
-    {pb with
-       env = newenv;
-       tomatch = tomatch;
-       pred = Option.map (lift_predicate n) pb.pred;
-       history = history;
-       mat = mat } in
-  let j = compile pb in
-  List.fold_left mkSpecialLetInJudge j sign
-
-(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
-substituer après par les initiaux *)
-
-(**************************************************************************)
-(* Preparation of the pattern-matching problem                            *)
-
-(* builds the matrix of equations testing that each eqn has n patterns
- * and linearizing the _ patterns.
- * Syntactic correctness has already been done in astterm *)
-let matx_of_eqns env eqns =
-  let build_eqn (loc,ids,lpat,rhs) =
-    let rhs =
-      { rhs_env = env;
-	avoid_ids = ids@(ids_of_named_context (named_context env));
-	it = rhs;
-      } in
-    { patterns = lpat;
-      alias_stack = [];
-      eqn_loc = loc;
-      used = ref false;
-      rhs = rhs }
-  in List.map build_eqn eqns
-
-(************************************************************************)
-(* preparing the elimination predicate if any                          *)
-
-let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
-  let cook (n, l, env, signs) = function
-    | c,IsInd (_,IndType(indf,realargs)) ->
-	let indf' = lift_inductive_family n indf in
-	let sign = make_arity_signature env dep indf' in
-	let p = List.length realargs in
-	if dep then
-	  (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
-	else
-	  (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
-    | c,NotInd _ ->
-	(n, l, env, []::signs) in
-  let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
-  let names = List.rev (List.map (List.map pi1) signs) in
-  let allargs =
-    List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in
-  let rec build_skeleton env c =
-    (* Don't put into normal form, it has effects on the synthesis of evars *)
- (* let c = whd_betadeltaiota env ( isevars) c in *)
-    (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
-    if isEvar c or List.exists (eq_constr c) allargs then
-      e_new_evar isevars env  ~src:(loc, Evd.CasesType)
-        (Retyping.get_type_of env ( !isevars) c)
-    else
-      map_constr_with_full_binders push_rel build_skeleton env c
-  in
-    names, build_skeleton env (lift n c)
-
-(* Here, [pred] is assumed to be in the context built from all *)
-(* realargs and terms to match *)
-let build_initial_predicate isdep allnames pred =
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let rec buildrec n pred = function
-    | [] -> PrCcl pred
-    | names::lnames ->
-        let names' = if isdep then List.tl names else names in
-        let n' = n + List.length names' in
-        let pred, p, user_p =
-          if isdep then
-            if dependent (mkRel (nar-n')) pred then pred, 1, 1
-            else liftn (-1) (nar-n') pred, 0, 1
-          else pred, 0, 0 in
-        let na =
-          if p=1 then
-            let na = List.hd names in
-            if na = Anonymous then
-              (* peut arriver en raison des evars *)
-              Name (id_of_string "x") (*Hum*)
-            else na
-          else Anonymous in
-        PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
-  in buildrec 0 pred allnames
-
-let extract_arity_signature env0 tomatchl tmsign =
-  let get_one_sign n tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) ->
-	  (match t with
-	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) ->
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-          let indf' = lift_inductive_family n indf in
-	  let (ind,params) = dest_ind_family indf' in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf') in
-	  (na,None,build_dependent_inductive env0 indf')
-	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
-  let rec buildrec n = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign n tm x in
-	l :: buildrec (n + List.length l) (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec 0 (tomatchl,tmsign))
-
-let extract_arity_signatures env0 tomatchl tmsign =
-  let get_one_sign tm (na,t) =
-    match tm with
-      | NotInd (bo,typ) ->
-	  (match t with
-	    | None -> [na,bo,typ]
-	    | Some (loc,_,_,_) ->
- 	    user_err_loc (loc,"",
-	    str "Unexpected type annotation for a term of non inductive type"))
-      | IsInd (_,IndType(indf,realargs)) ->
-	  let (ind,params) = dest_ind_family indf in
-	  let nrealargs = List.length realargs in
-	  let realnal =
-	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
-		    user_err_loc (loc,"",str "Wrong inductive type");
-		  if List.length params <> nparams
-		    or nrealargs <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
-		  List.rev realnal
-	      | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
-	  let arsign = fst (get_arity env0 indf) in
-	    (na,None,build_dependent_inductive env0 indf)
-	    ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign
-              with e when Errors.noncritical e -> assert false) in
-  let rec buildrec = function
-    | [],[] -> []
-    | (_,tm)::ltm, x::tmsign ->
-	let l = get_one_sign tm x in
-	  l :: buildrec (ltm,tmsign)
-    | _ -> assert false
-  in List.rev (buildrec (tomatchl,tmsign))
-
-let inh_conv_coerce_to_tycon loc env isevars j tycon =
-  match tycon with
-    | Some p ->
-	let (evd',j) = Coercion.inh_conv_coerce_to true loc env !isevars j p in
-          isevars := evd';
-          j
-    | None -> j
-
-let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
-
-let string_of_name name =
-  match name with
-    | Anonymous -> "anonymous"
-    | Name n -> string_of_id n
-
-let id_of_name n = id_of_string (string_of_name n)
-
-let make_prime_id name =
-  let str = string_of_name name in
-    id_of_string str, id_of_string (str ^ "'")
-
-let prime avoid name =
-  let previd, id = make_prime_id name in
-    previd, next_ident_away id avoid
-
-let make_prime avoid prevname =
-  let previd, id = prime !avoid prevname in
-    avoid := id :: !avoid;
-    previd, id
-
-let eq_id avoid id =
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away hid avoid in
-    hid'
-
-let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y =
-  mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |])
-
-let hole = GHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
-
-let constr_of_pat env isevars arsign pat avoid =
-  let rec typ env (ty, realargs) pat avoid =
-    match pat with
-    | PatVar (l,name) ->
-	let name, avoid = match name with
-	    Name n -> name, avoid
-	  | Anonymous ->
-	      let previd, id = prime avoid (Name (id_of_string "wildcard")) in
-		Name id, id :: avoid
-	in
-	  PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid
-    | PatCstr (l,((_, i) as cstr),args,alias) ->
-	let cind = inductive_of_constructor cstr in
-	let IndType (indf, _) = 
-	  try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty)
-	  with Not_found -> error_case_not_inductive env 
-	    {uj_val = ty; uj_type = Typing.type_of env !isevars ty}
-	in
-	let ind, params = dest_ind_family indf in
-	if ind <> cind then error_bad_constructor_loc l cstr ind;
-	let cstrs = get_constructors env indf in
-	let ci = cstrs.(i-1) in
-	let nb_args_constr = ci.cs_nargs in
-	assert(nb_args_constr = List.length args);
-	let patargs, args, sign, env, n, m, avoid =
-	  List.fold_right2
-	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
-	       let pat', sign', arg', typ', argtypargs, n', avoid =
-		 typ env (substl args (liftn (List.length sign) (succ (List.length args)) t), []) ua avoid
-	       in
-	       let args' = arg' :: List.map (lift n') args in
-	       let env' = push_rels sign' env in
-		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid))
-	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid)
-	in
-	let args = List.rev args in
-	let patargs = List.rev patargs in
-	let pat' = PatCstr (l, cstr, patargs, alias) in
-	let cstr = mkConstruct ci.cs_cstr in
-	let app = applistc cstr (List.map (lift (List.length sign)) params) in
-	let app = applistc app args in
-	let apptype = Retyping.get_type_of env ( !isevars) app in
-	let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in
-	  match alias with
-	      Anonymous ->
-		pat', sign, app, apptype, realargs, n, avoid
-	    | Name id ->
-		let sign = (alias, None, lift m ty) :: sign in
-		let avoid = id :: avoid in
-		let sign, i, avoid =
-		  try
-		    let env = push_rels sign env in
-		    isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars;
-		    let eq_t = mk_eq (lift (succ m) ty)
-		      (mkRel 1) (* alias *)
-		      (lift 1 app) (* aliased term *)
-		    in
-		    let neq = eq_id avoid id in
-		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
-		  with Reduction.NotConvertible -> sign, 1, avoid
-		in
-		  (* Mark the equality as a hole *)
-		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
-  in
-  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
-    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
-
-
-(* shadows functional version *)
-let eq_id avoid id =
-  let hid = id_of_string ("Heq_" ^ string_of_id id) in
-  let hid' = next_ident_away hid !avoid in
-    avoid := hid' :: !avoid;
-    hid'
-
-let rels_of_patsign =
-  List.map (fun ((na, b, t) as x) ->
-    match b with
-      | Some t' when kind_of_term t' = Rel 0 -> (na, None, t)
-      | _ -> x)
-
-let vars_of_ctx ctx =
-  let _, y =
-    List.fold_right (fun (na, b, t)  (prev, vars) ->
-      match b with
-	| Some t' when kind_of_term t' = Rel 0 ->
-	    prev,
-	    (GApp (dummy_loc,
-		(GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars
-	| _ ->
-	    match na with
-		Anonymous -> raise (Invalid_argument "vars_of_ctx")
-	      | Name n -> n, GVar (dummy_loc, n) :: vars)
-      ctx (id_of_string "vars_of_ctx_error", [])
-  in List.rev y
-
-let rec is_included x y =
-  match x, y with
-    | PatVar _, _ -> true
-    | _, PatVar _ -> true
-    | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias')  ->
-	if i = i' then List.for_all2 is_included args args'
-	else false
-
-(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its
-   full signature. However prevpatterns are in the original one signature per pattern form.
- *)
-let build_ineqs prevpatterns pats liftsign =
-  let _tomatchs = List.length pats in
-  let diffs =
-    List.fold_left
-      (fun c eqnpats ->
-	  let acc = List.fold_left2
-	    (* ppat is the pattern we are discriminating against, curpat is the current one. *)
-	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
-	      (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
-	      match acc with
-		  None -> None
-		| Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *)
-		    if is_included curpat ppat then
-		      (* Length of previous pattern's signature *)
-		      let lens = List.length ppat_sign in
-		      (* Accumulated length of previous pattern's signatures *)
-		      let len' = lens + len in
-		      let acc =
-			((* Jump over previous prevpat signs *)
-			  lift_rel_context len ppat_sign @ sign,
-			  len',
-			  succ n, (* nth pattern *)
-			  mkApp (delayed_force eq_ind,
-				[| lift (len' + liftsign) curpat_ty;
-				   liftn (len + liftsign) (succ lens) ppat_c ;
-				   lift len' curpat_c |]) ::
-			    List.map (lift lens (* Jump over this prevpat signature *)) c)
-		      in Some acc
-		    else None)
-	   (Some ([], 0, 0, [])) eqnpats pats
-	 in match acc with
-	     None -> c
-	   | Some (sign, len, _, c') ->
-	       let conj = it_mkProd_or_LetIn (mk_not (mk_conj c'))
-		 (lift_rel_context liftsign sign)
-	       in
-		 conj :: c)
-      [] prevpatterns
-  in match diffs with [] -> None
-    | _ -> Some (mk_conj diffs)
-
-let subst_rel_context k ctx subst =
-  let (_, ctx') =
-    List.fold_right
-      (fun (n, b, t) (k, acc) ->
-	 (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc))
-      ctx (k, [])
-  in ctx'
-
-let lift_rel_contextn n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-  liftrec (rel_context_length sign + k) sign
-
-let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
-  let i = ref 0 in
-  let (x, y, z) =
-    List.fold_left
-      (fun (branches, eqns, prevpatterns) eqn ->
-	 let _, newpatterns, pats =
-	   List.fold_left2
-	     (fun (idents, newpatterns, pats) pat arsign ->
-		let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in
-		  (idents, pat' :: newpatterns, cpat :: pats))
-	      ([], [], []) eqn.patterns sign
-	 in
-	 let newpatterns = List.rev newpatterns and opats = List.rev pats in
-	 let rhs_rels, pats, signlen =
-	   List.fold_left
-	     (fun (renv, pats, n) (sign,c, (s, args), p) ->
-	       (* Recombine signatures and terms of all of the row's patterns *)
-	       let sign' = lift_rel_context n sign in
-	       let len = List.length sign' in
-		 (sign' @ renv,
-		 (* lift to get outside of previous pattern's signatures. *)
-		 (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats,
-		 len + n))
-	     ([], [], 0) opats in
-	 let pats, _ = List.fold_left
-	   (* lift to get outside of past patterns to get terms in the combined environment. *)
-	   (fun (pats, n) (sign, c, (s, args), p) ->
-	     let len = List.length sign in
-	       ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n))
-	   ([], 0) pats
-	 in
-	 let ineqs = build_ineqs prevpatterns pats signlen in
-	 let rhs_rels' = rels_of_patsign rhs_rels in
-	 let _signenv = push_rel_context rhs_rels' env in
-	 let arity =
-	   let args, nargs =
-	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
-	       (args @ c :: allargs, List.length args + succ n))
-	       pats ([], 0)
-	   in
-	   let args = List.rev args in
-	     substl args (liftn signlen (succ nargs) arity)
-	 in
-	 let rhs_rels', tycon =
-	   let neqs_rels, arity =
-	     match ineqs with
-	     | None -> [], arity
-	     | Some ineqs ->
-		 [Anonymous, None, ineqs], lift 1 arity
-	   in
-	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
-	     eqs_rels @ neqs_rels @ rhs_rels', arity
-	 in
-	 let rhs_env = push_rels rhs_rels' env in
-	 let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in
-	 let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
-	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
-	 let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in
-	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
-	 let branch =
-	   let bref = GVar (dummy_loc, branch_name) in
-	     match vars_of_ctx rhs_rels with
-		 [] -> bref
-	       | l -> GApp (dummy_loc, bref, l)
-	 in
-	 let branch = match ineqs with
-	     Some _ -> GApp (dummy_loc, branch, [ hole ])
-	   | None -> branch
-	 in
-	 incr i;
-	 let rhs = { eqn.rhs with it = branch } in
-	   (branch_decl :: branches,
-	   { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
-	   opats :: prevpatterns))
-      ([], [], []) eqns
-  in x, y
-
-(* Builds the predicate. If the predicate is dependent, its context is
- * made of 1+nrealargs assumptions for each matched term in an inductive
- * type and 1 assumption for each term not _syntactically_ in an
- * inductive type.
-
- * Each matched terms are independently considered dependent or not.
-
- * A type constraint but no annotation case: it is assumed non dependent.
- *)
-
-let lift_ctx n ctx =
-  let ctx', _ =
-    List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
-  in ctx'
-
-(* Turn matched terms into variables. *)
-let abstract_tomatch env tomatchs tycon =
-  let prev, ctx, names, tycon =
-    List.fold_left
-      (fun (prev, ctx, names, tycon) (c, t) ->
-	 let lenctx =  List.length ctx in
-	 match kind_of_term c with
-	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon
-	   | _ ->
-	       let tycon = Option.map
-		 (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
-	       let name = next_ident_away (id_of_string "filtered_var") names in
-		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
-	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
-	       name :: names, tycon)
-      ([], [], [], tycon) tomatchs
-  in List.rev prev, ctx, tycon
-
-let is_dependent_ind = function
-    IsInd (_, IndType (indf, args)) when List.length args > 0 -> true
-  | _ -> false
-
-let build_dependent_signature env evars avoid tomatchs arsign =
-  let avoid = ref avoid in
-  let arsign = List.rev arsign in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
-  let eqs, neqs, refls, slift, arsign' =
-    List.fold_left2
-      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign ->
-	 (* The accumulator:
-	    previous eqs,
-	    number of previous eqs,
-	    lift to get outside eqs and in the introduced variables ('as' and 'in'),
-	    new arity signatures
-	 *)
-	 match ty with
-	     IsInd (ty, IndType (indf, args)) when List.length args > 0 ->
-	       (* Build the arity signature following the names in matched terms as much as possible *)
-	       let argsign = List.tl arsign in (* arguments in inverse application order *)
-	       let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
-	       let argsign = List.rev argsign in (* arguments in application order *)
-	       let env', nargeqs, argeqs, refl_args, slift, argsign' =
-		 List.fold_left2
-		   (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
-		      let argt = Retyping.get_type_of env evars arg in
-		      let eq, refl_arg =
-			if Reductionops.is_conv env evars argt t then
-			  (mk_eq (lift (nargeqs + slift) argt)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) arg),
-			   mk_eq_refl argt arg)
-			else
-			  (mk_JMeq (lift (nargeqs + slift) t)
-			     (mkRel (nargeqs + slift))
-			     (lift (nargeqs + nar) argt)
-			     (lift (nargeqs + nar) arg),
-			   mk_JMeq_refl argt arg)
-		      in
-		      let previd, id =
-			let name =
-			  match kind_of_term arg with
-			      Rel n -> pi1 (lookup_rel n env)
-			    | _ -> name
-			in
-			  make_prime avoid name
-		      in
-			(env, succ nargeqs,
-			 (Name (eq_id avoid previd), None, eq) :: argeqs,
-			 refl_arg :: refl_args,
-			 pred slift,
-			 (Name id, b, t) :: argsign'))
-		   (env, neqs, [], [], slift, []) args argsign
-	       in
-	       let eq = mk_JMeq
-		 (lift (nargeqs + slift) appt)
-		 (mkRel (nargeqs + slift))
-		 (lift (nargeqs + nar) ty)
-		 (lift (nargeqs + nar) tm)
-	       in
-	       let refl_eq = mk_JMeq_refl ty tm in
-	       let previd, id = make_prime avoid appn in
-		 (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
-		 succ nargeqs,
-		 refl_eq :: refl_args,
-		 pred slift,
-		 (((Name id, appb, appt) :: argsign') :: arsigns))
-
-	   | _ ->
-	       (* Non dependent inductive or not inductive, just use a regular equality *)
-	       let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
-	       let previd, id = make_prime avoid name in
-	       let arsign' = (Name id, b, typ) in
-	       let tomatch_ty = type_of_tomatch ty in
-	       let eq =
-		 mk_eq (lift nar tomatch_ty)
-		   (mkRel slift) (lift nar tm)
-	       in
-		 ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
-		  (mk_eq_refl tomatch_ty tm) :: refl_args,
-		  pred slift, (arsign' :: []) :: arsigns))
-      ([], 0, [], nar, []) tomatchs arsign
-  in
-  let arsign'' = List.rev arsign' in
-    assert(slift = 0); (* we must have folded over all elements of the arity signature *)
-    arsign'', allnames, nar, eqs, neqs, refls
-
-(**************************************************************************)
-(* Main entry of the matching compilation                                 *)
-
-let liftn_rel_context n k sign =
-  let rec liftrec k = function
-    | (na,c,t)::sign ->
-	(na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
-    | [] -> []
-  in
-    liftrec (k + rel_context_length sign) sign
-
-let nf_evars_env sigma (env : env) : env =
-  let nf t = nf_evar sigma t in
-  let env0 : env = reset_context env in
-  let f e (na, b, t) e' : env =
-    Environ.push_named (na, Option.map nf b, nf t) e'
-  in
-  let env' = Environ.fold_named_context f ~init:env0 env in
-    Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e')
-     ~init:env' env
-
-
-let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
-  (* We extract the signature of the arity *)
-  let arsign = extract_arity_signature env tomatchs sign in
-  let newenv = List.fold_right push_rels arsign env in
-  let allnames = List.rev (List.map (List.map pi1) arsign) in
-    match rtntyp with
-      | Some rtntyp ->
-	  let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in
-	  let predccl = (j_nf_evar !isevars predcclj).uj_val in
-	    Some (build_initial_predicate true allnames predccl)
-      | None ->
-	  match valcon_of_tycon tycon with
-	    | Some ty ->
-		let pred =
-		  prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty
-		in Some (build_initial_predicate true allnames pred)
-	    | None -> None
-
-let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
-
-  let typing_fun tycon env = typing_fun tycon env isevars in
-
-  (* We build the matrix of patterns and right-hand side *)
-  let matx = matx_of_eqns env eqns in
-
-  (* We build the vector of terms to match consistently with the *)
-  (* constructors found in patterns *)
-  let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
-  let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
-    if predopt = None then
-      let tycon = valcon_of_tycon tycon in
-      let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in
-      let env = push_rel_context tomatchs_lets env in
-      let len = List.length eqns in
-      let sign, allnames, signlen, eqs, neqs, args =
-	(* The arity signature *)
-	let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in
-	  (* Build the dependent arity signature, the equalities which makes
-	     the first part of the predicate and their instantiations. *)
-	let avoid = [] in
-	  build_dependent_signature env ( !isevars) avoid tomatchs arsign
-
-      in
-      let tycon, arity =
-	match tycon' with
-	| None -> let ev = mkExistential env isevars in ev, ev
-	| Some t ->
-	    Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars)
-	      tomatchs sign t
-      in
-      let neqs, arity =
-	let ctx = context_of_arsign eqs in
-	let neqs = List.length ctx in
-	  neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
-      in
-      let lets, matx =
-	(* Type the rhs under the assumption of equations *)
-	constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity
-      in
-      let matx = List.rev matx in
-      let _ = assert(len = List.length lets) in
-      let env = push_rels lets env in
-      let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
-      let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
-      let args = List.rev_map (lift len) args in
-      let pred = liftn len (succ signlen) arity in
-      let pred = build_initial_predicate true allnames pred in
-
-      (* We push the initial terms to match and push their alias to rhs' envs *)
-      (* names of aliases will be recovered from patterns (hence Anonymous here) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = Some pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } in
-
-      let j = compile pb in
-	(* We check for unused patterns *)
-	List.iter (check_unused_pattern env) matx;
-	let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
-	let j =
-	  { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
-	    uj_type = nf_evar !isevars tycon; }
-	in j
-    else
-      (* We build the elimination predicate if any and check its consistency *)
-      (* with the type of arguments to match *)
-      let tmsign = List.map snd tomatchl in
-      let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in
-
-      (* We push the initial terms to match and push their alias to rhs' envs *)
-      (* names of aliases will be recovered from patterns (hence Anonymous here) *)
-      let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-      let pb =
-	{ env      = env;
-	  isevars  = isevars;
-	  pred     = pred;
-	  tomatch  = initial_pushed;
-	  history  = start_history (List.length initial_pushed);
-	  mat      = matx;
-	  caseloc  = loc;
-	  casestyle= style;
-	  typing_function = typing_fun } in
-
-      let j = compile pb in
-	(* We check for unused patterns *)
-	List.iter (check_unused_pattern env) matx;
-	inh_conv_coerce_to_tycon loc env isevars j tycon
-
-end
-
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
deleted file mode 100644
index b0054d82..00000000
--- a/plugins/subtac/subtac_classes.ml
+++ /dev/null
@@ -1,190 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pretyping
-open Evd
-open Environ
-open Term
-open Glob_term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-open Subtac_command
-open Typeclasses
-open Typeclasses_errors
-open Decl_kinds
-open Entries
-open Util
-
-module SPretyping = Subtac_pretyping.Pretyping
-
-let interp_constr_evars_gen evdref env ?(impls=Constrintern.empty_internalization_env) kind c =
-  SPretyping.understand_tcc_evars evdref env kind
-    (intern_gen (kind=IsType) ~impls !evdref env c)
-
-let interp_casted_constr_evars evdref env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
-
-let interp_context_evars evdref env params =
-  let impls_env, bl = Constrintern.interp_context_gen
-    (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
-    (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl
-
-let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c =
-  let c = intern_gen true ~impls !evdref env c in
-  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
-    SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps
-
-let type_ctx_instance evars env ctx inst subst =
-  let rec aux (subst, instctx) l = function
-    (na, b, t) :: ctx ->
-      let t' = substl subst t in
-      let c', l =
-	match b with
-	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
-	| Some b -> substl subst b, l
-      in
-       evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
-       let d = na, Some c', t' in
-	aux (c' :: subst, d :: instctx) l ctx
-    | [] -> subst
-  in aux (subst, []) inst (List.rev ctx)
-
-let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
-  let env = Global.env() in
-  let evars = ref Evd.empty in
-  let tclass, _ =
-    match bk with
-    | Implicit ->
-	Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
-	  ~allow_partial:false (fun avoid (clname, (id, _, t)) ->
-	    match clname with
-	    | Some (cl, b) ->
-		let t =
-		  if b then
-		    let _k = class_info cl in
-		      CHole (Util.dummy_loc, Some Evd.InternalHole)
-		  else CHole (Util.dummy_loc, None)
-		in t, avoid
-	    | None -> failwith ("new instance: under-applied typeclass"))
-	  cl
-      | Explicit -> cl, Idset.empty
-  in
-  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
-  let k, cty, ctx', ctx, len, imps, subst =
-    let (env', ctx), imps = interp_context_evars evars env ctx in
-    let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
-    let len = List.length ctx in
-    let imps = imps @ Impargs.lift_implicits len imps' in
-    let ctx', c = decompose_prod_assum c' in
-    let ctx'' = ctx' @ ctx in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
-    let _, args = 
-      List.fold_right (fun (na, b, t) (args, args') ->
-	match b with
-	| None -> (List.tl args, List.hd args :: args')
-	| Some b -> (args, substl args' b :: args'))
-	(snd cl.cl_context) (args, [])
-    in
-      cl, c', ctx', ctx, len, imps, args
-  in
-  let id =
-    match snd instid with
-    | Name id ->
-	let sp = Lib.make_path id in
-	  if Nametab.exists_cci sp then
-	    errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
-	  id
-    | Anonymous ->
-	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
-	  Namegen.next_global_ident_away i (Termops.ids_of_context env)
-  in
-  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;  
-  let ctx = Evarutil.nf_rel_context_evar !evars ctx 
-  and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in
-  let env' = push_rel_context ctx env in
-  let sigma =  !evars in
-  let subst = List.map (Evarutil.nf_evar sigma) subst in
-  let props =
-    match props with
-    | Some (CRecord (loc, _, fs)) ->
-	if List.length fs > List.length k.cl_props then
-	  Classes.mismatched_props env' (List.map snd fs) k.cl_props;
-	Inl fs
-    | Some p -> Inr p
-    | None -> Inl []
-  in
-  let subst =
-    match props with
-    | Inr term ->
-	let c = interp_casted_constr_evars evars env' term cty in
-	  Inr c
-    | Inl props ->
-	let get_id =
-	  function
-	    | Ident id' -> id'
-	    | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
-	in
-	let props, rest =
-	  List.fold_left
-	    (fun (props, rest) (id,b,_) ->
-	      if b = None then
-		try
-		  let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
-		  let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
-		  let (loc, mid) = get_id loc_mid in
-		    List.iter 
-		      (fun (n, _, x) -> 
-			 if n = Name mid then
-			   Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
-		      k.cl_projs;
-		    c :: props, rest'
-		with Not_found ->
-		  (CHole (Util.dummy_loc, None) :: props), rest
-	      else props, rest)
-	    ([], props) k.cl_props
-	in
-	  if rest <> [] then
-	    unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
-	  else
-	    Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
-  in	  
-  evars := Evarutil.nf_evar_map !evars;
-  evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
-  evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars;
-  let term, termtype =
-    match subst with
-    | Inl subst ->
-	let subst = List.fold_left2
-	  (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-	  [] subst (k.cl_props @ snd k.cl_context)
-	in
-	let app, ty_constr = instance_constructor k subst in
-	let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
-	  term, termtype
-    | Inr def ->
-	let termtype = it_mkProd_or_LetIn cty ctx in
-	let term = Termops.it_mkLambda_or_LetIn def ctx in
-	  term, termtype
-  in
-  let termtype = Evarutil.nf_evar !evars termtype in
-  let term = Evarutil.nf_evar !evars term in
-  evars := undefined_evars !evars;
-  Evarutil.check_evars env Evd.empty !evars termtype;
-  let hook vis gr =
-    let cst = match gr with ConstRef kn -> kn | _ -> assert false in
-      Impargs.declare_manual_implicits false gr ~enriching:false [imps];
-      Typeclasses.declare_instance pri (not global) (ConstRef cst)
-  in
-  let evm = Subtac_utils.evars_of_term !evars Evd.empty term in
-  let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in
-    id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,Instance) ~hook obls
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
deleted file mode 100644
index bd3fe484..00000000
--- a/plugins/subtac/subtac_classes.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Names
-open Decl_kinds
-open Term
-open Sign
-open Evd
-open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Util
-open Typeclasses
-open Implicit_quantifiers
-open Classes
-(*i*)
-
-val type_ctx_instance :     Evd.evar_map ref ->
-  Environ.env ->
-    ('a * Term.constr option * Term.constr) list ->
-    Topconstr.constr_expr list ->
-    Term.constr list ->
-    Term.constr list
-
-val new_instance :
-  ?global:bool ->
-  local_binder list ->
-  typeclass_constraint ->
-  constr_expr option ->
-  ?generalize:bool ->
-  int option ->
-  identifier * Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
deleted file mode 100644
index 4fe29ac8..00000000
--- a/plugins/subtac/subtac_coercion.ml
+++ /dev/null
@@ -1,510 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-open Util
-open Names
-open Term
-open Reductionops
-open Environ
-open Typeops
-open Pretype_errors
-open Classops
-open Recordops
-open Evarutil
-open Evarconv
-open Retyping
-open Evd
-
-open Global
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-open Pp
-
-let app_opt env evars f t =
-  whd_betaiota !evars (app_opt f t)
-
-let pair_of_array a = (a.(0), a.(1))
-let make_name s = Name (id_of_string s)
-
-let rec disc_subset x =
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Ind i ->
-	let len = Array.length l in
-	let sig_ = delayed_force sig_ in
-	  if len = 2 && i = Term.destInd sig_.typ
-	  then
-	    let (a, b) = pair_of_array l in
-	      Some (a, b)
-	  else None
-      | _ -> None)
-  | _ -> None
-
-and disc_exist env x =
-  match kind_of_term x with
-  | App (c, l) ->
-      (match kind_of_term c with
-      Construct c ->
-	if c = Term.destConstruct (delayed_force sig_).intro
-	then Some (l.(0), l.(1), l.(2), l.(3))
-	else None
-      | _ -> None)
-  | _ -> None
-
-module Coercion = struct
-
-  exception NoSubtacCoercion
-
-  let disc_proj_exist env x =
-    match kind_of_term x with
-      | App (c, l) ->
-	  (if Term.eq_constr c (delayed_force sig_).proj1
-	     && Array.length l = 3
-	   then disc_exist env l.(2)
-	   else None)
-      | _ -> None
-
-
-  let sort_rel s1 s2 =
-    match s1, s2 with
-	Prop Pos, Prop Pos -> Prop Pos
-      | Prop Pos, Prop Null -> Prop Null
-      | Prop Null, Prop Null -> Prop Null
-      | Prop Null, Prop Pos -> Prop Pos
-      | Type _, Prop Pos -> Prop Pos
-      | Type _, Prop Null -> Prop Null
-      | _, Type _ -> s2
-
-  let hnf env isevars c = whd_betadeltaiota env isevars c
-  let hnf_nodelta env evars c = whd_betaiota evars c
-
-  let lift_args n sign =
-    let rec liftrec k = function
-      | t::sign -> liftn n k t :: (liftrec (k-1) sign)
-      | [] -> []
-    in
-      liftrec (List.length sign) sign
-
-  let rec mu env isevars t =
-    let rec aux v =
-      let v = hnf env !isevars v in
-      match disc_subset v with
-	  Some (u, p) ->
-	    let f, ct = aux u in
-	    let p = hnf env !isevars p in
-	      (Some (fun x ->
-		     app_opt env isevars 
-		     f (mkApp ((delayed_force sig_).proj1,
-			       [| u; p; x |]))),
-	       ct)
-	| None -> (None, v)
-    in aux t
-
-  and coerce loc env isevars (x : Term.constr) (y : Term.constr)
-      : (Term.constr -> Term.constr) option
-      =
-    let rec coerce_unify env x y =
-      let x = hnf env !isevars x and y = hnf env !isevars y in
-	try
-	  isevars := the_conv_x_leq env x y !isevars;
-	  None
-	with Reduction.NotConvertible -> coerce' env x y
-    and coerce' env x y : (Term.constr -> Term.constr) option =
-      let subco () = subset_coerce env isevars x y in
-      let dest_prod c =
-	match Reductionops.splay_prod_n env ( !isevars) 1 c with
-	| [(na,b,t)], c -> (na,t), c
-	| _ -> raise NoSubtacCoercion
-      in
-      let rec coerce_application typ typ' c c' l l' =
-	let len = Array.length l in
-	let rec aux tele typ typ' i co =
-	  if i < len then
-	    let hdx = l.(i) and hdy = l'.(i) in
-	      try isevars := the_conv_x_leq env hdx hdy !isevars;
-		let (n, eqT), restT = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod typ' in
-		aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
-	      with Reduction.NotConvertible ->
-		let (n, eqT), restT = dest_prod typ in
-		let (n', eqT'), restT' = dest_prod typ' in
-		let _ =
-		  try isevars := the_conv_x_leq env eqT eqT' !isevars
-		  with Reduction.NotConvertible -> raise NoSubtacCoercion
-		in
-		(* Disallow equalities on arities *)
-		if Reduction.is_arity env eqT then raise NoSubtacCoercion;
-		let restargs = lift_args 1
-		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
-		in
-		let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
-		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
-		let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in
-		let evar = make_existential loc env isevars eq in
-		let eq_app x = mkApp (delayed_force eq_rect,
-				      [| eqT; hdx; pred; x; hdy; evar|]) in
-		  aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
-	  else Some co
-	in
-	  if isEvar c || isEvar c' then
-	    (* Second-order unification needed. *)
-	    raise NoSubtacCoercion;
-	  aux [] typ typ' 0 (fun x -> x)
-      in
-	match (kind_of_term x, kind_of_term y) with
-	  | Sort s, Sort s' ->
-	      (match s, s' with
-		   Prop x, Prop y when x = y -> None
-		 | Prop _, Type _ -> None
-		 | Type x, Type y when x = y -> None (* false *)
-		 | _ -> subco ())
-	  | Prod (name, a, b), Prod (name', a', b') ->
-	      let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
-	      let env' = push_rel (name', None, a') env in
-	      let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
-		(* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
-	      let coec1 = app_opt env' isevars c1 (mkRel 1) in
-		(* env, x : a' |- c1[x] : lift 1 a *)
-	      let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
-		(* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
-		(match c1, c2 with
-		| None, None -> None
-		| _, _ ->
-		    Some
-		      (fun f ->
-			mkLambda (name', a',
-				 app_opt env' isevars c2
-				   (mkApp (Term.lift 1 f, [| coec1 |])))))
-
-	  | App (c, l), App (c', l') ->
-	      (match kind_of_term c, kind_of_term c' with
-		   Ind i, Ind i' -> (* Inductive types *)
-		     let len = Array.length l in
-		     let existS = delayed_force existS in
-		     let prod = delayed_force prod in
-		       (* Sigma types *)
-		       if len = Array.length l' && len = 2 && i = i'
-			 && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
-		       then
-			 if i = Term.destInd existS.typ
-			 then
-			   begin
-			     let (a, pb), (a', pb') =
-			       pair_of_array l, pair_of_array l'
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let rec remove_head a c =
-			       match kind_of_term c with
-				 | Lambda (n, t, t') -> c, t'
-				     (*| Prod (n, t, t') -> t'*)
-				 | Evar (k, args) ->
-				     let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in
-				       isevars := evs;
-				       let (n, dom, rng) = destLambda t in
-				       let (domk, args) = destEvar dom in
-					 isevars := define domk a !isevars;
-					 t, rng
-				 | _ -> raise NoSubtacCoercion
-			     in
-			     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
-			     let env' = push_rel (make_name "x", None, a) env in
-			     let c2 = coerce_unify env' b b' in
-			       match c1, c2 with
-				   None, None ->
-				     None
-				 | _, _ ->
-				     Some
-				       (fun x ->
-					  let x, y =
-					    app_opt env' isevars c1 (mkApp (existS.proj1,
-							       [| a; pb; x |])),
-					    app_opt env' isevars c2 (mkApp (existS.proj2,
-							       [| a; pb; x |]))
-					  in
-					    mkApp (existS.intro, [| a'; pb'; x ; y |]))
-			   end
-			 else
-			   begin
-			     let (a, b), (a', b') =
-			       pair_of_array l, pair_of_array l'
-			     in
-			     let c1 = coerce_unify env a a' in
-			     let c2 = coerce_unify env b b' in
-			       match c1, c2 with
-				   None, None -> None
-				 | _, _ ->
-				     Some
-				       (fun x ->
-					  let x, y =
-					    app_opt env isevars c1 (mkApp (prod.proj1,
-							       [| a; b; x |])),
-					    app_opt env isevars c2 (mkApp (prod.proj2,
-							       [| a; b; x |]))
-					  in
-					    mkApp (prod.intro, [| a'; b'; x ; y |]))
-			   end
-		       else
-			 if i = i' && len = Array.length l' then
-			   let evm =  !isevars in
-			     (try subco ()
-			       with NoSubtacCoercion ->
-				 let typ = Typing.type_of env evm c in
-				 let typ' = Typing.type_of env evm c' in
-				   (* 			     if not (is_arity env evm typ) then *)
-				   coerce_application typ typ' c c' l l')
-			       (* 			     else subco () *)
-			 else
-			   subco ()
-		 | x, y when x = y ->
-		     if Array.length l = Array.length l' then
-		       let evm =  !isevars in
-		       let lam_type = Typing.type_of env evm c in
-		       let lam_type' = Typing.type_of env evm c' in
-(* 			 if not (is_arity env evm lam_type) then ( *)
-			 coerce_application lam_type lam_type' c c' l l'
-(* 			 ) else subco () *)
-		     else subco ()
-		 | _ -> subco ())
-	  | _, _ ->  subco ()
-
-    and subset_coerce env isevars x y =
-      match disc_subset x with
-	  Some (u, p) ->
-	    let c = coerce_unify env u y in
-	    let f x =
-	      app_opt env isevars c (mkApp ((delayed_force sig_).proj1,
-				[| u; p; x |]))
-	    in Some f
-	| None ->
-	    match disc_subset y with
-		Some (u, p) ->
-		  let c = coerce_unify env x u in
-		    Some
-		      (fun x ->
-			 let cx = app_opt env isevars c x in
-			 let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
-			 in
-			   (mkApp
-			      ((delayed_force sig_).intro,
-			       [| u; p; cx; evar |])))
-	      | None ->
-		  raise NoSubtacCoercion
-		    (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
-		  None*)
-    in coerce_unify env x y
-
-  let coerce_itf loc env isevars v t c1 =
-    let evars = ref isevars in
-    let coercion = coerce loc env evars t c1 in
-    let t = Option.map (app_opt env evars coercion) v in
-      !evars, t
-
-  (* Taken from pretyping/coercion.ml *)
-
-  (* Typing operations dealing with coercions *)
-
-  (* Here, funj is a coercion therefore already typed in global context *)
-  let apply_coercion_args env argl funj =
-    let rec apply_rec acc typ = function
-      | [] -> { uj_val = applist (j_val funj,argl);
-		uj_type = typ }
-      | h::restl ->
-	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
-  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) ->
-		(* Typage garanti par l'appel à app_coercion*)
-		apply_rec (h::acc) (subst1 h c2) restl
-	    | _ -> anomaly "apply_coercion_args"
-    in
-      apply_rec [] funj.uj_type argl
-
-  (* appliquer le chemin de coercions de patterns p *)
-  exception NoCoercion
-
-  let apply_pattern_coercion loc pat p =
-    List.fold_left
-      (fun pat (co,n) ->
-	 let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
-	   Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
-      pat p
-
-  (* raise Not_found if no coercion found *)
-  let inh_pattern_coerce_to loc pat ind1 ind2 =
-    let p = lookup_pattern_path_between (ind1,ind2) in
-      apply_pattern_coercion loc pat p
-
-  (* appliquer le chemin de coercions p à hj *)
-
-  let apply_coercion env sigma p hj typ_cl =
-    try
-      fst (List.fold_left
-             (fun (ja,typ_cl) i ->
-		let fv,isid = coercion_value i in
-		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
-		let jres = apply_coercion_args env argl fv in
-		  (if isid then
-		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else
-		     jres),
-		jres.uj_type)
-             (hj,typ_cl) p)
-    with e when Errors.noncritical e -> anomaly "apply_coercion"
-
-  let inh_app_fun _ env isevars j =
-    let isevars = ref isevars in
-    let t = hnf env !isevars j.uj_type in
-      match kind_of_term t with
-	| Prod (_,_,_) -> (!isevars,j)
-	| Evar ev when not (is_defined_evar !isevars ev) ->
-	    let (isevars',t) = define_evar_as_product !isevars ev in
-	      (isevars',{ uj_val = j.uj_val; uj_type = t })
-	| _ ->
-       	    (try
-      	       let t,p =
-		 lookup_path_to_fun_from env !isevars j.uj_type in
-		 (!isevars,apply_coercion env !isevars p j t)
-	     with Not_found ->
-	       try
-		 let coercef, t = mu env isevars t in
-		 let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in
-		   (!isevars, res)
-	       with NoSubtacCoercion | NoCoercion ->
-		 (!isevars,j))
-
-  let inh_tosort_force loc env isevars j =
-    try
-      let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
-      let j1 = apply_coercion env ( isevars) p j t in
-	(isevars, type_judgment env (j_nf_evar ( isevars) j1))
-    with Not_found ->
-      error_not_a_type_loc loc env ( isevars) j
-
-  let inh_coerce_to_sort loc env isevars j =
-    let typ = hnf env isevars j.uj_type in
-      match kind_of_term typ with
-	| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
-	| Evar ev when not (is_defined_evar isevars ev) ->
-	    let (isevars',s) = define_evar_as_sort isevars ev in
-	      (isevars',{ utj_val = j.uj_val; utj_type = s })
-	| _ ->
-	    inh_tosort_force loc env isevars j
-
-  let inh_coerce_to_base loc env isevars j =
-    let isevars = ref isevars in
-    let typ = hnf env !isevars j.uj_type in
-    let ct, typ' = mu env isevars typ in
-    let res =
-      { uj_val = app_opt env isevars ct j.uj_val;
-	uj_type = typ' }
-    in !isevars, res
-
-  let inh_coerce_to_prod loc env isevars t =
-    let isevars = ref isevars in
-    let typ = hnf env !isevars (snd t) in
-    let _, typ' = mu env isevars typ in
-      !isevars, (fst t, typ')
-
-  let inh_coerce_to_fail env evd rigidonly v t c1 =
-    if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
-    then
-      raise NoCoercion
-    else
-    let v', t' =
-      try
-	let t2,t1,p = lookup_path_between env evd (t,c1) in
-	  match v with
-	      Some v ->
-		let j = apply_coercion env evd p
-		  {uj_val = v; uj_type = t} t2 in
-		  Some j.uj_val, j.uj_type
-	    | None -> None, t
-      with Not_found -> raise NoCoercion
-    in
-      try (the_conv_x_leq env t' c1 evd, v')
-      with Reduction.NotConvertible -> raise NoCoercion
-
-
-  let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
-    try (the_conv_x_leq env t c1 evd, v)
-    with Reduction.NotConvertible ->
-    try inh_coerce_to_fail env evd rigidonly v t c1
-    with NoCoercion ->
-    match
-      kind_of_term (whd_betadeltaiota env evd t),
-      kind_of_term (whd_betadeltaiota env evd c1)
-    with
-    | Prod (name,t1,t2), Prod (_,u1,u2) ->
-        (* Conversion did not work, we may succeed with a coercion. *)
-        (* We eta-expand (hence possibly modifying the original term!) *)
-	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
-	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
-	let name = match name with
-	  | Anonymous -> Name (id_of_string "x")
-	  | _ -> name in
-	let env1 = push_rel (name,None,u1) env in
-	let (evd', v1) =
-	  inh_conv_coerce_to_fail loc env1 evd rigidonly
-            (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
-        let v1 = Option.get v1 in
-	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
-        let t2 = Termops.subst_term v1 t2 in
-	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
-	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
-    | _ -> raise NoCoercion
-
-  (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-  let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
-    match n with
-    | None ->
-      let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } 
-      and t = hnf_nodelta env evd t in
-      let (evd', val') =
-	try
-	  inh_conv_coerce_to_fail loc env evd rigidonly
-	  (Some cj.uj_val) cj.uj_type t
-	with NoCoercion ->
-	(try
-	   coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
-	 with NoSubtacCoercion ->
-	   error_actual_type_loc loc env evd cj t)
-      in
-      let val' = match val' with Some v -> v | None -> assert(false) in
-	(evd',{ uj_val = val'; uj_type = t })
-    | Some (init, cur) ->
-      (evd, cj)
-
-  let inh_conv_coerce_to _ = inh_conv_coerce_to_gen false
-  let inh_conv_coerce_rigid_to _ = inh_conv_coerce_to_gen true
-
-  let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) =
-    let nabsinit, nabs =
-      match abs with
-	  None -> 0, 0
-	| Some (init, cur) -> init, cur
-    in
-      try
-	let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in
-	(* The final range free variables must have been replaced by evars, we accept only that evars
-	   in rng are applied to free vars. *)
-	if noccur_with_meta 1 (succ nabs) rng then (
-	  let env', t, t' =
-	    let env' = push_rel_context rels env in
-	      env', rng, lift nabs t'
-	  in
-	    try
-	      fst (try inh_conv_coerce_to_fail loc env' isevars false None t t'
-		   with NoCoercion ->
-		     coerce_itf loc env' isevars None t t')
-	    with NoSubtacCoercion ->
-	      error_cannot_coerce env' isevars (t, t'))
-	else isevars
-      with e when Errors.noncritical e -> isevars
-end
diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli
deleted file mode 100644
index 5678c10e..00000000
--- a/plugins/subtac/subtac_coercion.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-open Term
-val disc_subset : types -> (types * types) option
-
-module Coercion : Coercion.S
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
deleted file mode 100644
index 537a8301..00000000
--- a/plugins/subtac/subtac_command.ml
+++ /dev/null
@@ -1,544 +0,0 @@
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Libobject
-open Pattern
-open Matching
-open Pp
-open Glob_term
-open Sign
-open Tacred
-open Util
-open Names
-open Nameops
-open Libnames
-open Nametab
-open Pfedit
-open Proof_type
-open Refiner
-open Tacmach
-open Tactic_debug
-open Topconstr
-open Term
-open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
-open Genarg
-open Decl_kinds
-open Mod_subst
-open Printer
-open Inductiveops
-open Syntax_def
-open Environ
-open Tactics
-open Tacticals
-open Tacinterp
-open Vernacexpr
-open Notation
-open Evd
-open Evarutil
-
-module SPretyping = Subtac_pretyping.Pretyping
-open Subtac_utils
-open Pretyping
-open Subtac_obligations
-
-(*********************************************************************)
-(* Functions to parse and interpret constructions *)
-
-let evar_nf isevars c =
-  Evarutil.nf_evar !isevars c
-
-let interp_gen kind isevars env
-               ?(impls=Constrintern.empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[]))
-               c =
-  let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in
-  let c' = SPretyping.understand_tcc_evars isevars env kind c' in
-    evar_nf isevars c'
-
-let interp_constr isevars env c =
-  interp_gen (OfType None) isevars env c
-
-let interp_type_evars isevars env ?(impls=Constrintern.empty_internalization_env) c =
-  interp_gen IsType isevars env ~impls c
-
-let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c
-
-let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) c typ =
-  interp_gen (OfType (Some typ)) isevars env ~impls c
-
-let interp_open_constr isevars env c =
-    msgnl (str "Pretyping " ++ my_print_constr_expr c);
-  let c = Constrintern.intern_constr ( !isevars) env c in
-  let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in
-    evar_nf isevars c'
-
-let interp_constr_judgment isevars env c =
-  let j =
-    SPretyping.understand_judgment_tcc isevars env
-      (Constrintern.intern_constr ( !isevars) env c)
-  in
-    { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
-
-let locate_if_isevar loc na = function
-  | GHole _ ->
-      (try match na with
-	| Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id)
-	| Anonymous -> raise Not_found
-      with Not_found -> GHole (loc, Evd.BinderType na))
-  | x -> x
-
-let interp_binder sigma env na t =
-  let t = Constrintern.intern_gen true ( !sigma) env t in
-    SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_glob_constr t) na t)
-
-let interp_context_evars evdref env params =
-  let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_env params in
-  let (env, par, _, impls) =
-    List.fold_left
-      (fun (env,params,n,impls) (na, k, b, t) ->
-	match b with
-	    None ->
-	      let t' = locate_if_isevar (loc_of_glob_constr t) na t in
-	      let t = SPretyping.understand_tcc_evars evdref env IsType t' in
-	      let d = (na,None,t) in
-	      let impls =
-		if k = Implicit then
-		  let na = match na with Name n -> Some n | Anonymous -> None in
-		    (ExplByPos (n, na), (true, true, true)) :: impls
-		else impls
-	      in
-		(push_rel d env, d::params, succ n, impls)
-	  | Some b ->
-	      let c = SPretyping.understand_judgment_tcc evdref env b in
-	      let d = (na, Some c.uj_val, c.uj_type) in
-		(push_rel d env,d::params, succ n, impls))
-      (env,[],1,[]) (List.rev bl)
-  in (env, par), impls
-
-(* try to find non recursive definitions *)
-
-let list_chop_hd i l = match list_chop i l with
-  | (l1,x::l2) -> (l1,x,l2)
-  | (x :: [], l2) -> ([], x, [])
-  | _ -> assert(false)
-
-let collect_non_rec env =
-  let rec searchrec lnonrec lnamerec ldefrec larrec nrec =
-    try
-      let i =
-        list_try_find_i
-          (fun i f ->
-             if List.for_all (fun (_, def) -> not (Termops.occur_var env f def)) ldefrec
-             then i else failwith "try_find_i")
-          0 lnamerec
-      in
-      let (lf1,f,lf2) = list_chop_hd i lnamerec in
-      let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
-      let (lar1,ar,lar2) = list_chop_hd i larrec in
-      let newlnv =
-	try
-	  match list_chop i nrec with
-            | (lnv1,_::lnv2) -> (lnv1@lnv2)
-	    | _ -> [] (* nrec=[] for cofixpoints *)
-        with Failure "list_chop" -> []
-      in
-      searchrec ((f,def,ar)::lnonrec)
-	(lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
-    with Failure "try_find_i" ->
-      (List.rev lnonrec,
-       (Array.of_list lnamerec, Array.of_list ldefrec,
-        Array.of_list larrec, Array.of_list nrec))
-  in
-  searchrec []
-
-let list_of_local_binders l =
-  let rec aux acc = function
-      Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
-    | Topconstr.LocalRawAssum (nl, k, c) :: tl ->
-	aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
-    | [] -> List.rev acc
-  in aux [] l
-
-let lift_binders k n l =
-  let rec aux n = function
-    | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
-    | [] -> []
-  in aux n l
-
-let rec gen_rels = function
-    0 -> []
-  | n -> mkRel n :: gen_rels (pred n)
-
-let split_args n rel = match list_chop ((List.length rel) - n) rel with
-    (l1, x :: l2) -> l1, x, l2
-  | _ -> assert(false)
-
-open Coqlib
-
-let sigT = Lazy.lazy_from_fun build_sigma_type
-let sigT_info = lazy
-  { ci_ind       = destInd (Lazy.force sigT).typ;
-    ci_npar      = 2;
-    ci_cstr_ndecls = [|2|];
-    ci_pp_info   =  { ind_nargs = 0; style = LetStyle }
-  }
-
-let rec telescope = function
-  | [] -> assert false
-  | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
-  | (n, None, t) :: tl ->
-      let ty, tys, (k, constr) =
-	List.fold_left
-	  (fun (ty, tys, (k, constr)) (n, b, t) ->
-	    let pred = mkLambda (n, t, ty) in
-	    let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in
-	    let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in
-	      (sigty, pred :: tys, (succ k, intro)))
-	  (t, [], (2, mkRel 1)) tl
-      in
-      let (last, subst) = List.fold_right2
-	(fun pred (n, b, t) (prev, subst) ->
-	  let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in
-	  let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in
-	    (lift 1 proj2, (n, Some proj1, t) :: subst))
-	(List.rev tys) tl (mkRel 1, [])
-      in ty, ((n, Some last, t) :: subst), constr
-
-  | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in
-      ty, ((n, Some b, t) :: subst), lift 1 term
-
-let nf_evar_context isevars ctx =
-  List.map (fun (n, b, t) ->
-    (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx
-
-let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
-  Coqlib.check_required_library ["Coq";"Program";"Wf"];
-  let sigma = Evd.empty in
-  let isevars = ref (Evd.create_evar_defs sigma) in
-  let env = Global.env() in
-  let _pr c = my_print_constr env c in
-  let _prr = Printer.pr_rel_context env in
-  let _prn = Printer.pr_named_context env in
-  let _pr_rel env = Printer.pr_rel_context env in
-  let (env', binders_rel), impls = interp_context_evars isevars env bl in
-  let len = List.length binders_rel in
-  let top_env = push_rel_context binders_rel env in
-  let top_arity = interp_type_evars isevars top_env arityc in
-  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
-  let argtyp, letbinders, make = telescope binders_rel in
-  let argname = id_of_string "recarg" in
-  let arg = (Name argname, None, argtyp) in
-  let binders = letbinders @ [arg] in
-  let binders_env = push_rel_context binders_rel env in
-  let rel = interp_constr isevars env r in
-  let relty = type_of env !isevars rel in
-  let relargty =
-    let error () =
-      user_err_loc (constr_loc r,
-		   "Subtac_command.build_wellfounded",
-		   my_print_constr env rel ++ str " is not an homogeneous binary relation.")
-    in
-      try
-	let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
-	  match ctx, kind_of_term ar with
-	  | [(_, None, t); (_, None, u)], Sort (Prop Null)
-	      when Reductionops.is_conv env !isevars t u -> t
-	  | _, _ -> error ()
-      with e when Errors.noncritical e -> error ()
-  in
-  let measure = interp_casted_constr isevars binders_env measure relargty in
-  let wf_rel, wf_rel_fun, measure_fn =
-    let measure_body, measure =
-      it_mkLambda_or_LetIn measure letbinders,
-      it_mkLambda_or_LetIn measure binders
-    in
-    let comb = constr_of_global (delayed_force measure_on_R_ref) in
-    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
-    let wf_rel_fun x y =
-      mkApp (rel, [| subst1 x measure_body;
- 		     subst1 y measure_body |])
-    in wf_rel, wf_rel_fun, measure
-  in
-  let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
-  let argid' = id_of_string (string_of_id argname ^ "'") in
-  let wfarg len = (Name argid', None,
-  		  mkSubset (Name argid') argtyp
-		    (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
-  in
-  let intern_bl = wfarg 1 :: [arg] in
-  let _intern_env = push_rel_context intern_bl env in
-  let proj = (delayed_force sig_).Coqlib.proj1 in
-  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
-  let projection = (* in wfarg :: arg :: before *)
-    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
-  in
-  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
-  let intern_arity = substl [projection] top_arity_let in
-  (* substitute the projection of wfarg for something,
-     now intern_arity is in wfarg :: arg *)
-  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
-  let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
-  let curry_fun =
-    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
-    let arg = mkApp ((delayed_force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
-    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
-    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
-    let lam = (Name (id_of_string "recproof"), None, rcurry) in
-    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
-    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
-      (Name recname, Some body, ty)
-  in
-  let fun_bl = intern_fun_binder :: [arg] in
-  let lift_lets = Termops.lift_rel_context 1 letbinders in
-  let intern_body =
-    let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
-    let (r, l, impls, scopes) =
-      Constrintern.compute_internalization_data env
-	Constrintern.Recursive full_arity impls 
-    in
-    let newimpls = Idmap.singleton recname
-      (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))],
-       scopes @ [None]) in
-      interp_casted_constr isevars ~impls:newimpls
-	(push_rel_context ctx env) body (lift 1 top_arity)
-  in
-  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
-  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
-  let def =
-    mkApp (constr_of_global (delayed_force fix_sub_ref),
-	  [| argtyp ; wf_rel ;
-	     make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
-	     prop ; intern_body_lam |])
-  in
-  let _ = isevars := Evarutil.nf_evar_map !isevars in
-  let binders_rel = nf_evar_context !isevars binders_rel in
-  let binders = nf_evar_context !isevars binders in
-  let top_arity = Evarutil.nf_evar !isevars top_arity in
-  let hook, recname, typ = 
-    if List.length binders_rel > 1 then
-      let name = add_suffix recname "_func" in
-      let hook l gr = 
-	let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in
-	let ty = it_mkProd_or_LetIn top_arity binders_rel in
-	let ce =
-          { const_entry_body = Evarutil.nf_evar !isevars body;
-            const_entry_secctx = None;
-	    const_entry_type = Some ty;
-	    const_entry_opaque = false }
-	in 
-	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
-	let gr = ConstRef c in
-	  if Impargs.is_implicit_args () || impls <> [] then
-	    Impargs.declare_manual_implicits false gr [impls]
-      in
-      let typ = it_mkProd_or_LetIn top_arity binders in
-	hook, name, typ
-    else 
-      let typ = it_mkProd_or_LetIn top_arity binders_rel in
-      let hook l gr = 
-	if Impargs.is_implicit_args () || impls <> [] then
-	  Impargs.declare_manual_implicits false gr [impls]
-      in hook, recname, typ
-  in
-  let fullcoqc = Evarutil.nf_evar !isevars def in
-  let fullctyp = Evarutil.nf_evar !isevars typ in
-  let evm = evars_of_term !isevars Evd.empty fullctyp in
-  let evm = evars_of_term !isevars evm fullcoqc in
-  let evm = non_instanciated_map env isevars evm in
-  let evars, _, evars_def, evars_typ = 
-    Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp 
-  in
-    Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook
-
-let interp_fix_context evdref env fix =
-  interp_context_evars evdref env fix.Command.fix_binders
-
-let interp_fix_ccl evdref (env,_) fix =
-  interp_type_evars evdref env fix.Command.fix_type
-
-let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
-  let env = push_rel_context ctx env_rec in
-  let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in
-  Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body
-
-let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
-
-let prepare_recursive_declaration fixnames fixtypes fixdefs =
-  let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
-  let names = List.map (fun id -> Name id) fixnames in
-  (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
-
-let rel_index n ctx =
-  list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
-
-let rec unfold f b =
-  match f b with
-    | Some (x, b') -> x :: unfold f b'
-    | None -> []
-
-
-let find_annot loc id ctx = 
-  try rel_index id ctx
-  with Not_found -> 
-  user_err_loc(loc,"",
-	       str "No parameter named " ++ Nameops.pr_id id ++ str".")
-
-let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
-  match n with
-  | Some (loc, id) -> [find_annot loc id fixctx]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      let len = List.length fixctx in
-	unfold (function x when x = len -> None
-	  | n -> Some (n, succ n)) 0
-
-let push_named_context = List.fold_right push_named
-
-let check_evars env initial_sigma evd c =
-  let sigma =  evd in
-  let c = nf_evar sigma c in
-  let rec proc_rec c =
-    match kind_of_term c with
-      | Evar (evk,args) ->
-          assert (Evd.mem sigma evk);
-	  if not (Evd.mem initial_sigma evk) then
-            let (loc,k) = evar_source evk evd in
-	      (match k with
-	      | QuestionMark _
-	      | ImplicitArg (_, _, false) -> ()
-	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find sigma evk) in
-		    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
-      | _ -> iter_constr proc_rec c
-  in proc_rec c
-
-let out_def = function
-  | Some def -> def
-  | None -> error "Program Fixpoint needs defined bodies."
-
-let interp_recursive fixkind l =
-  let env = Global.env() in
-  let fixl, ntnl = List.split l in
-  let kind = fixkind <> IsCoFixpoint in
-  let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
-
-  (* Interp arities allowing for unresolved types *)
-  let evdref = ref Evd.empty in
-  let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
-  let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
-  let fixtypes = List.map2 build_fix_type fixctxs fixccls in
-  let rec_sign =
-    List.fold_left2 (fun env' id t ->
-      let sort = Retyping.get_type_of env !evdref t in
-      let fixprot =
-	try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|])
-	with e when Errors.noncritical e -> t
-      in
-	(id,None,fixprot) :: env')
-      [] fixnames fixtypes
-  in
-  let env_rec = push_named_context rec_sign env in
-
-  (* Get interpretation metadatas *)
-  let impls = Constrintern.compute_internalization_env env
-    Constrintern.Recursive fixnames fixtypes fiximps
-  in
-  let notations = List.flatten ntnl in
-
-  (* Interp bodies with rollback because temp use of notations/implicit *)
-  let fixdefs =
-    States.with_state_protection (fun () ->
-      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-      list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
-      () in
-
-  let fixdefs = List.map out_def fixdefs in
-
-  (* Instantiate evars and check all are resolved *)
-  let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in
-  let evd = Typeclasses.resolve_typeclasses
-    ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd
-  in
-  let evd = Evarutil.nf_evar_map evd in
-  let fixdefs = List.map (nf_evar evd) fixdefs in
-  let fixtypes = List.map (nf_evar evd) fixtypes in
-  let rec_sign = nf_named_context_evar evd rec_sign in
-
-  let recdefs = List.length rec_sign in
-  List.iter (check_evars env_rec Evd.empty evd) fixdefs;
-  List.iter (check_evars env Evd.empty evd) fixtypes;
-  Command.check_mutuality env kind (List.combine fixnames fixdefs);
-
-  (* Russell-specific code *)
-
-  (* Get the interesting evars, those that were not instanciated *)
-  let isevars = Evd.undefined_evars evd in
-  let evm =  isevars in
-  (* Solve remaining evars *)
-  let rec collect_evars id def typ imps =
-      (* Generalize by the recursive prototypes  *)
-    let def =
-      Termops.it_mkNamedLambda_or_LetIn def rec_sign
-    and typ =
-      Termops.it_mkNamedProd_or_LetIn typ rec_sign
-    in
-    let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
-    let evm' = Subtac_utils.evars_of_term evm evm' typ in
-    let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
-      (id, def, typ, imps, evars)
-  in
-  let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
-    (match fixkind with
-      | IsFixpoint wfl ->
-	  let possible_indexes =
-	    list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
-	  let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
-	    Array.of_list fixtypes,
-	    Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
-	  in
-	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
-	    list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
-      | IsCoFixpoint -> ());
-    Subtac_obligations.add_mutual_definitions defs notations fixkind
-
-let out_n = function
-    Some n -> n
-  | None -> raise Not_found
-
-let build_recursive l =
-  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
-    match g, l with
-	[(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, n, bl, typ, out_def def) r
-		    (match n with Some n -> mkIdentC (snd n) | None ->
-		      errorlabstrm "Subtac_command.build_recursive"
-			(str "Recursive argument required for well-founded fixpoints"))
-		    ntn)
-
-      | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
-	  ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r)
-		    m ntn)
-
-      | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
-	  let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) ->
-	    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n;
-	      Command.fix_body = def; Command.fix_type = typ},ntn)) l
-	  in interp_recursive (IsFixpoint g) fixl
-      | _, _ ->
-	  errorlabstrm "Subtac_command.build_recursive"
-	    (str "Well-founded fixpoints not allowed in mutually recursive blocks")
-
-let build_corecursive l =
-  let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
-    ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None;
-      Command.fix_body = def; Command.fix_type = typ},ntn))
-    l in
-  interp_recursive IsCoFixpoint fixl
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
deleted file mode 100644
index 72549a01..00000000
--- a/plugins/subtac/subtac_command.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-open Pretyping
-open Evd
-open Environ
-open Term
-open Topconstr
-open Names
-open Libnames
-open Pp
-open Vernacexpr
-open Constrintern
-
-val interp_gen :
-  typing_constraint ->
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  ?allow_patvar:bool ->
-  ?ltacvars:ltac_sign ->
-  constr_expr -> constr
-val interp_constr :
-  evar_map ref ->
-  env -> constr_expr -> constr
-val interp_type_evars :
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  constr_expr -> constr
-val interp_casted_constr_evars :
-  evar_map ref ->
-  env ->
-  ?impls:internalization_env ->
-  constr_expr -> types -> constr
-val interp_open_constr :
-  evar_map ref -> env -> constr_expr -> constr
-val interp_constr_judgment :
-  evar_map ref ->
-  env ->
-  constr_expr -> unsafe_judgment
-val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
-
-val interp_binder :     Evd.evar_map ref ->
-    Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
-
-
-val telescope :
-  (Names.name * Term.types option * Term.types) list ->
-  Term.types * (Names.name * Term.types option * Term.types) list *
-    Term.constr
-
-val build_wellfounded :
-           Names.identifier * 'a * Topconstr.local_binder list *
-           Topconstr.constr_expr * Topconstr.constr_expr ->
-           Topconstr.constr_expr ->
-           Topconstr.constr_expr -> 'b -> Subtac_obligations.progress
-
-val build_recursive :
-  (fixpoint_expr * decl_notation list) list -> unit
-
-val build_corecursive :
-  (cofixpoint_expr * decl_notation list) list -> unit
diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml
deleted file mode 100644
index 067da150..00000000
--- a/plugins/subtac/subtac_errors.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Util
-open Pp
-open Printer
-
-type term_pp = Pp.std_ppcmds
-
-type subtyping_error =
-  | UncoercibleInferType of loc * term_pp * term_pp
-  | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-
-type typing_error =
-  | NonFunctionalApp of loc * term_pp * term_pp * term_pp
-  | NonConvertible of loc * term_pp * term_pp
-  | NonSigma of loc * term_pp
-  | IllSorted of loc * term_pp
-
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-
-exception Debug_msg of string
-
-let typing_error e = raise (Typing_error e)
-let subtyping_error e = raise (Subtyping_error e)
diff --git a/plugins/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli
deleted file mode 100644
index 8d75b9c0..00000000
--- a/plugins/subtac/subtac_errors.mli
+++ /dev/null
@@ -1,15 +0,0 @@
-type term_pp = Pp.std_ppcmds
-type subtyping_error =
-    UncoercibleInferType of Util.loc * term_pp * term_pp
-  | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp
-  | UncoercibleRewrite of term_pp * term_pp
-type typing_error =
-    NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp
-  | NonConvertible of Util.loc * term_pp * term_pp
-  | NonSigma of Util.loc * term_pp
-  | IllSorted of Util.loc * term_pp
-exception Subtyping_error of subtyping_error
-exception Typing_error of typing_error
-exception Debug_msg of string
-val typing_error : typing_error -> 'a
-val subtyping_error : subtyping_error -> 'a
diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
deleted file mode 100644
index 7a4916fa..00000000
--- a/plugins/subtac/subtac_obligations.ml
+++ /dev/null
@@ -1,699 +0,0 @@
-open Printf
-open Pp
-open Subtac_utils
-open Command
-open Environ
-
-open Term
-open Names
-open Libnames
-open Summary
-open Libobject
-open Entries
-open Decl_kinds
-open Util
-open Evd
-open Declare
-open Proof_type
-open Compat
-
-let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
-let pperror cmd = Util.errorlabstrm "Program" cmd
-let error s = pperror (str s)
-
-let reduce c =
-  Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c
-
-exception NoObligations of identifier option
-
-let explain_no_obligations = function
-    Some ident -> str "No obligations for program " ++ str (string_of_id ident)
-  | None -> str "No obligations remaining"
-
-type obligation_info = (Names.identifier * Term.types * hole_kind located *
-			  obligation_definition_status * Intset.t * tactic option) array
-
-type obligation =
-  { obl_name : identifier;
-    obl_type : types;
-    obl_location : hole_kind located;
-    obl_body : constr option;
-    obl_status : obligation_definition_status;
-    obl_deps : Intset.t;
-    obl_tac : tactic option;
-  }
-
-type obligations = (obligation array * int)
-
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
-  | IsCoFixpoint
-
-type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
-
-type program_info = {
-  prg_name: identifier;
-  prg_body: constr;
-  prg_type: constr;
-  prg_obligations: obligations;
-  prg_deps : identifier list;
-  prg_fixkind : fixpoint_kind option ;
-  prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list;
-  prg_notations : notations ;
-  prg_kind : definition_kind;
-  prg_reduce : constr -> constr;
-  prg_hook : Tacexpr.declaration_hook;
-}
-
-let assumption_message id =
-  Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-
-let (set_default_tactic, get_default_tactic, print_default_tactic) = 
-  Tactic_option.declare_tactic_option "Program tactic"
-
-(* true = All transparent, false = Opaque if possible *)
-let proofs_transparency = ref true
-
-let set_proofs_transparency = (:=) proofs_transparency
-let get_proofs_transparency () = !proofs_transparency
-
-open Goptions
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "transparency of Program obligations";
-      optkey   = ["Transparent";"Obligations"];
-      optread  = get_proofs_transparency;
-      optwrite = set_proofs_transparency; }
-
-(* true = hide obligations *)
-let hide_obligations = ref false
-
-let set_hide_obligations = (:=) hide_obligations
-let get_hide_obligations () = !hide_obligations
-
-open Goptions
-
-let _ =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "Hidding of Program obligations";
-      optkey   = ["Hide";"Obligations"];
-      optread  = get_hide_obligations;
-      optwrite = set_hide_obligations; }
-
-let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
-
-let get_obligation_body expand obl =
-  let c = Option.get obl.obl_body in
-    if expand && obl.obl_status = Expand then
-      match kind_of_term c with
-      | Const c -> constant_value (Global.env ()) c
-      | _ -> c
-    else c
-
-let obl_substitution expand obls deps =
-  Intset.fold
-    (fun x acc ->
-       let xobl = obls.(x) in
-       let oblb =
-	 try get_obligation_body expand xobl
-	 with e when Errors.noncritical e -> assert(false)
-       in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
-    deps []
-
-let subst_deps expand obls deps t =
-  let subst = obl_substitution expand obls deps in
-    Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t
-
-let rec prod_app t n =
-  match kind_of_term (strip_outer_cast t) with
-    | Prod (_,_,b) -> subst1 n b
-    | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
-    | _ ->
-	errorlabstrm "prod_app"
-	  (str"Needed a product, but didn't find one" ++ fnl ())
-
-
-(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
-let prod_applist t nL = List.fold_left prod_app t nL
-
-let replace_appvars subst =
-  let rec aux c = 
-    let f, l = decompose_app c in
-      if isVar f then
-	try
-	  let c' = List.map (map_constr aux) l in
-	  let (t, b) = List.assoc (destVar f) subst in
-	    mkApp (delayed_force hide_obligation, 
-		   [| prod_applist t c'; applistc b c' |])
-	with Not_found -> map_constr aux c
-      else map_constr aux c
-  in map_constr aux
-       
-let subst_prog expand obls ints prg =
-  let subst = obl_substitution expand obls ints in
-    if get_hide_obligations () then
-      (replace_appvars subst prg.prg_body,
-       replace_appvars subst (Termops.refresh_universes prg.prg_type))
-    else 
-      let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
-	(Term.replace_vars subst' prg.prg_body,
-	 Term.replace_vars subst' (Termops.refresh_universes prg.prg_type))
-
-let subst_deps_obl obls obl =
-  let t' = subst_deps true obls obl.obl_deps obl.obl_type in
-    { obl with obl_type = t' }
-
-module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
-
-let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
-
-let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
-
-let map_cardinal m =
-  let i = ref 0 in
-    ProgMap.iter (fun _ _ -> incr i) m;
-    !i
-
-exception Found of program_info
-
-let map_first m =
-  try
-    ProgMap.iter (fun _ v -> raise (Found v)) m;
-    assert(false)
-  with Found x -> x
-
-let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
-
-let freeze () = !from_prg
-let unfreeze v = from_prg := v
-let init () = from_prg := ProgMap.empty
-
-(** Beware: if this code is dynamically loaded via dynlink after the start
-    of Coq, then this [init] function will not be run by [Lib.init ()].
-    Luckily, here we can launch [init] at load-time. *)
-
-let _ = init ()
-
-let _ =
-  Summary.declare_summary "program-tcc-table"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-
-let progmap_union = ProgMap.fold ProgMap.add
-
-let close sec =
-  if not (ProgMap.is_empty !from_prg) then
-    let keys = map_keys !from_prg in
-      errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
-			      prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
-			      (str (if List.length keys = 1 then " has " else "have ") ++
-			       str "unsolved obligations"))
-
-let input : program_info ProgMap.t -> obj =
-  declare_object
-    { (default_object "Program state") with
-      cache_function = (fun (na, pi) -> from_prg := pi);
-      load_function = (fun _ (_, pi) -> from_prg := pi);
-      discharge_function = (fun _ -> close "section"; None);
-      classify_function = (fun _ -> close "module"; Dispose) }
-    
-open Evd
-
-let progmap_remove prg =
-  Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
-  
-let progmap_add n prg =
-  Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
-
-let progmap_replace prg' = 
-  Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
-
-let rec intset_to = function
-    -1 -> Intset.empty
-  | n -> Intset.add n (intset_to (pred n))
-
-let subst_body expand prg =
-  let obls, _ = prg.prg_obligations in
-  let ints = intset_to (pred (Array.length obls)) in
-    subst_prog expand obls ints prg
-
-let declare_definition prg =
-  let body, typ = subst_body true prg in
-  let (local, kind) = prg.prg_kind in
-  let ce =
-    { const_entry_body = body;
-      const_entry_secctx = None;
-      const_entry_type = Some typ;
-      const_entry_opaque = false }
-  in
-    (Command.get_declare_definition_hook ()) ce;
-    match local with
-    | Local when Lib.sections_are_opened () ->
-        let c =
-          SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
-        let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in
-          print_message (Subtac_utils.definition_message prg.prg_name);
-          if Pfedit.refining () then
-            Flags.if_verbose msg_warning
-	      (str"Local definition " ++ Nameops.pr_id prg.prg_name ++
-		  str" is not visible from current goals");
-	  progmap_remove prg; 
-          VarRef prg.prg_name
-    | (Global|Local) ->
-	let c =
-	  Declare.declare_constant
-	    prg.prg_name (DefinitionEntry ce,IsDefinition (snd prg.prg_kind))
-	in
-	let gr = ConstRef c in
-	  if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
-	    Impargs.declare_manual_implicits false gr [prg.prg_implicits];
-	  print_message (Subtac_utils.definition_message prg.prg_name);
-	  progmap_remove prg; 
-	  prg.prg_hook local gr;
-	  gr
-
-open Pp
-open Ppconstr
-
-let rec lam_index n t acc =
-  match kind_of_term t with
-    | Lambda (na, _, b) ->
-	if na = Name n then acc
-	else lam_index n b (succ acc)
-    | _ -> raise Not_found
-
-let compute_possible_guardness_evidences (n,_) fixbody fixtype =
-  match n with
-  | Some (loc, n) -> [lam_index n fixbody 0]
-  | None ->
-      (* If recursive argument was not given by user, we try all args.
-	 An earlier approach was to look only for inductive arguments,
-	 but doing it properly involves delta-reduction, and it finally
-         doesn't seem to worth the effort (except for huge mutual
-	 fixpoints ?) *)
-      let m = Term.nb_prod fixtype in
-      let ctx = fst (decompose_prod_n_assum m fixtype) in
-	list_map_i (fun i _ -> i) 0 ctx
-
-let declare_mutual_definition l =
-  let len = List.length l in
-  let first = List.hd l in
-  let fixdefs, fixtypes, fiximps =
-    list_split3
-      (List.map (fun x -> 
-	let subs, typ = (subst_body true x) in
-	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
-	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
-	  x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
-  in
-(*   let fixdefs = List.map reduce_fix fixdefs in *)
-  let fixkind = Option.get first.prg_fixkind in
-  let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
-  let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
-  let (local,kind) = first.prg_kind in
-  let fixnames = first.prg_deps in
-  let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
-  let indexes, fixdecls =
-    match fixkind with
-      | IsFixpoint wfl ->
-	  let possible_indexes =
-	    list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in
-	  let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
-	    Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
-      | IsCoFixpoint ->
-	  None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l
-  in
-  (* Declare the recursive definitions *)
-  let kns = list_map4 (declare_fix kind) fixnames fixdecls fixtypes fiximps in
-    (* Declare notations *)
-    List.iter Metasyntax.add_notation_interpretation first.prg_notations;
-    Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
-    let gr = List.hd kns in
-    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
-      first.prg_hook local gr;
-      List.iter progmap_remove l; kn
-      
-let declare_obligation prg obl body =
-  let body = prg.prg_reduce body in
-  let ty = prg.prg_reduce obl.obl_type in
-  match obl.obl_status with
-  | Expand -> { obl with obl_body = Some body }
-  | Define opaque ->
-      let opaque = if get_proofs_transparency () then false else opaque in
-      let ce = 
-	{ const_entry_body = body;
-          const_entry_secctx = None;
-	  const_entry_type = Some ty;
-	  const_entry_opaque = opaque }
-      in
-      let constant = Declare.declare_constant obl.obl_name
-	(DefinitionEntry ce,IsProof Property)
-      in
-	if not opaque then
-	  Auto.add_hints false [string_of_id prg.prg_name]
-	    (Auto.HintsUnfoldEntry [EvalConstRef constant]);
-	print_message (Subtac_utils.definition_message obl.obl_name);
-	{ obl with obl_body = Some (mkConst constant) }
-
-let init_prog_info n b t deps fixkind notations obls impls kind reduce hook =
-  let obls', b = 
-    match b with
-    | None ->
-	assert(obls = [||]);
-	let n = Nameops.add_suffix n "_obligation" in
-	  [| { obl_name = n; obl_body = None;
-	       obl_location = dummy_loc, InternalHole; obl_type = t;
-	       obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |],
-	mkVar n
-    | Some b ->
-	Array.mapi
-	  (fun i (n, t, l, o, d, tac) ->
-            { obl_name = n ; obl_body = None; 
-	      obl_location = l; obl_type = reduce t; obl_status = o;
-	      obl_deps = d; obl_tac = tac })
-	  obls, b
-  in
-    { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls');
-      prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
-      prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; }
-
-let get_prog name =
-  let prg_infos = !from_prg in
-    match name with
-	Some n ->
-	  (try ProgMap.find n prg_infos
-	   with Not_found -> raise (NoObligations (Some n)))
-      | None ->
-	  (let n = map_cardinal prg_infos in
-	     match n with
-		 0 -> raise (NoObligations None)
-	       | 1 -> map_first prg_infos
-	       | _ -> error "More than one program with unsolved obligations")
-
-let get_prog_err n =
-  try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
-
-let obligations_solved prg = (snd prg.prg_obligations) = 0
-
-let all_programs () =
-  ProgMap.fold (fun k p l -> p :: l) !from_prg []
-
-type progress =
-    | Remain of int
-    | Dependent
-    | Defined of global_reference
-
-let obligations_message rem =
-  if rem > 0 then
-    if rem = 1 then
-      Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
-    else
-      Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
-  else
-    Flags.if_verbose msgnl (str "No more obligations remaining")
-
-let update_obls prg obls rem =
-  let prg' = { prg with prg_obligations = (obls, rem) } in
-    progmap_replace prg';
-    obligations_message rem;
-    if rem > 0 then Remain rem
-    else (
-      match prg'.prg_deps with
-      | [] ->
-	  let kn = declare_definition prg' in
-	    progmap_remove prg';
-	    Defined kn
-      | l ->
-	  let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
-	    if List.for_all (fun x -> obligations_solved x) progs then
-	      let kn = declare_mutual_definition progs in
-		Defined (ConstRef kn)
-	    else Dependent)
-
-let is_defined obls x = obls.(x).obl_body <> None
-
-let deps_remaining obls deps =
-  Intset.fold
-    (fun x acc ->
-      if is_defined obls x then acc
-      else x :: acc)
-    deps []
-
-let dependencies obls n =
-  let res = ref Intset.empty in
-    Array.iteri
-      (fun i obl ->
-	if i <> n && Intset.mem n obl.obl_deps then
-	  res := Intset.add i !res)
-      obls;
-    !res
-
-let kind_of_opacity o =
-  match o with
-  | Define false | Expand -> Subtac_utils.goal_kind
-  | _ -> Subtac_utils.goal_proof_kind
-
-let not_transp_msg =
-  str "Obligation should be transparent but was declared opaque." ++ spc () ++
-    str"Use 'Defined' instead."
-
-let warn_not_transp () = ppwarn not_transp_msg
-let error_not_transp () = pperror not_transp_msg
-
-let rec solve_obligation prg num tac =
-  let user_num = succ num in
-  let obls, rem = prg.prg_obligations in
-  let obl = obls.(num) in
-    if obl.obl_body <> None then
-      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")
-    else
-      match deps_remaining obls obl.obl_deps with
-      | [] ->
-	  let obl = subst_deps_obl obls obl in
-	    Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
-	      (fun strength gr ->
-		let cst = match gr with ConstRef cst -> cst | _ -> assert false in
-		let obl =
-		  let transparent = evaluable_constant cst (Global.env ()) in
-		  let body =
-		    match obl.obl_status with
-		    | Expand ->
-			if not transparent then error_not_transp ()
-			else constant_value (Global.env ()) cst
-		    | Define opaque ->
-			if not opaque && not transparent then error_not_transp ()
-			else Libnames.constr_of_global gr
-		  in
-		    if transparent then
-		      Auto.add_hints true [string_of_id prg.prg_name]
-			(Auto.HintsUnfoldEntry [EvalConstRef cst]);
-		    { obl with obl_body = Some body }
-		in
-		let obls = Array.copy obls in
-		let _ = obls.(num) <- obl in
-		let res = try update_obls prg obls (pred rem)
-		  with e when Errors.noncritical e ->
-                    pperror (Errors.print (Cerrors.process_vernac_interp_error e))
-		in
-		  match res with
-		  | Remain n when n > 0 ->
-		      let deps = dependencies obls num in
-			if deps <> Intset.empty then
-			  ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps)
-		  | _ -> ());
-	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
-		      Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
-	    Pfedit.by (snd (get_default_tactic ()));
-	    Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
-	    Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
-      | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
-		       ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
-
-and subtac_obligation (user_num, name, typ) tac =
-  let num = pred user_num in
-  let prg = get_prog_err name in
-  let obls, rem = prg.prg_obligations in
-    if num < Array.length obls then
-      let obl = obls.(num) in
-	match obl.obl_body with
-	    None -> solve_obligation prg num tac
-	  | Some r -> error "Obligation already solved"
-    else error (sprintf "Unknown obligation number %i" (succ num))
-
-
-and solve_obligation_by_tac prg obls i tac =
-  let obl = obls.(i) in
-    match obl.obl_body with
-    | Some _ -> false
-    | None ->
-	try
-	  if deps_remaining obls obl.obl_deps = [] then
-	    let obl = subst_deps_obl obls obl in
-	    let tac =
-	      match tac with
-	      | Some t -> t
-	      | None ->
-		  match obl.obl_tac with
-		  | Some t -> t
-		  | None -> snd (get_default_tactic ())
-	    in
-	    let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
-	      obls.(i) <- declare_obligation prg obl t;
-	      true
-	  else false
-	with
-	| Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
-	| Loc.Exc_located(_, Refiner.FailError (_, s))
-	| Refiner.FailError (_, s) ->
-	    user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
-	| Util.Anomaly _ as e -> raise e
-	| e when Errors.noncritical e -> false
-
-and solve_prg_obligations prg ?oblset tac =
-  let obls, rem = prg.prg_obligations in
-  let rem = ref rem in
-  let obls' = Array.copy obls in
-  let set = ref Intset.empty in
-  let p = match oblset with
-    | None -> (fun _ -> true)
-    | Some s -> set := s;
-      (fun i -> Intset.mem i !set)
-  in
-  let _ =
-    Array.iteri (fun i x ->
-      if p i && solve_obligation_by_tac prg obls' i tac then
-	let deps = dependencies obls i in
-	  (set := Intset.union !set deps;
-	   decr rem))
-      obls'
-  in
-    update_obls prg obls' !rem
-
-and solve_obligations n tac =
-  let prg = get_prog_err n in
-    solve_prg_obligations prg tac
-
-and solve_all_obligations tac =
-  ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
-
-and try_solve_obligation n prg tac =
-  let prg = get_prog prg in
-  let obls, rem = prg.prg_obligations in
-  let obls' = Array.copy obls in
-    if solve_obligation_by_tac prg obls' n tac then
-      ignore(update_obls prg obls' (pred rem));
-
-and try_solve_obligations n tac =
-  try ignore (solve_obligations n tac) with NoObligations _ -> ()
-
-and auto_solve_obligations n ?oblset tac : progress =
-  Flags.if_verbose msgnl (str "Solving obligations automatically...");
-  try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
-
-open Pp
-let show_obligations_of_prg ?(msg=true) prg =
-  let n = prg.prg_name in
-  let obls, rem = prg.prg_obligations in
-  let showed = ref 5 in
-    if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
-    Array.iteri (fun i x ->
-		   match x.obl_body with
-		   | None ->
-		       if !showed > 0 then (
-			 decr showed;
-			 msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
-				   str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
-				   hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())))
-		   | Some _ -> ())
-      obls
-
-let show_obligations ?(msg=true) n =
-  let progs = match n with
-    | None -> all_programs ()
-    | Some n ->
-	try [ProgMap.find n !from_prg]
-	with Not_found -> raise (NoObligations (Some n))
-  in List.iter (show_obligations_of_prg ~msg) progs
-
-let show_term n =
-  let prg = get_prog_err n in
-  let n = prg.prg_name in
-    msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++
-	      my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
-	    ++ my_print_constr (Global.env ()) prg.prg_body)
-
-let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic
-    ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls =
-  Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
-  let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in
-  let obls,_ = prg.prg_obligations in
-  if Array.length obls = 0 then (
-    Flags.if_verbose ppnl (str ".");
-    let cst = declare_definition prg in
-      Defined cst)
-  else (
-    let len = Array.length obls in
-    let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
-      progmap_add n prg;
-      let res = auto_solve_obligations (Some n) tactic in
-	match res with
-	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
-	| _ -> res)
-
-let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce)
-    ?(hook=fun _ _ -> ()) notations fixkind =
-  let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
-    List.iter
-    (fun  (n, b, t, imps, obls) ->
-     let prg = init_prog_info n (Some b) t deps (Some fixkind) 
-       notations obls imps kind reduce hook 
-     in progmap_add n prg) l;
-    let _defined =
-      List.fold_left (fun finished x ->
-	if finished then finished
-	else
-	  let res = auto_solve_obligations (Some x) tactic in
-	    match res with
-	    | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true
-	    | _ -> false)
-	false deps
-    in ()
-
-let admit_obligations n =
-  let prg = get_prog_err n in
-  let obls, rem = prg.prg_obligations in
-  let obls = Array.copy obls in
-    Array.iteri 
-      (fun i x ->
-	match x.obl_body with
-	| None ->
-            let x = subst_deps_obl obls x in
-	    let kn = Declare.declare_constant x.obl_name 
-              (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural)
-	    in
-	      assumption_message x.obl_name;
-	      obls.(i) <- { x with obl_body = Some (mkConst kn) }
-	| Some _ -> ())
-      obls;
-    ignore(update_obls prg obls 0)
-
-exception Found of int
-
-let array_find f arr =
-  try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
-    raise Not_found
-  with Found i -> i
-
-let next_obligation n tac =
-  let prg = get_prog_err n in
-  let obls, rem = prg.prg_obligations in
-  let i =
-    try array_find (fun x ->  x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
-    with Not_found -> anomaly "Could not find a solvable obligation."
-  in solve_obligation prg i tac
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
deleted file mode 100644
index c1d665aa..00000000
--- a/plugins/subtac/subtac_obligations.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-open Names
-open Util
-open Libnames
-open Evd
-open Proof_type
-open Vernacexpr
-
-type obligation_info =
-  (identifier * Term.types * hole_kind located *
-      obligation_definition_status * Intset.t * tactic option) array
-    (* ident, type, location, (opaque or transparent, expand or define),
-       dependencies, tactic to solve it *)
-
-type progress = (* Resolution status of a program *)
-  | Remain of int  (* n obligations remaining *)
-  | Dependent (* Dependent on other definitions *)
-  | Defined of global_reference (* Defined as id *)
-      
-val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit
-val get_default_tactic : unit -> locality_flag * Proof_type.tactic
-val print_default_tactic : unit -> Pp.std_ppcmds
-
-val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
-val get_proofs_transparency : unit -> bool
-
-val add_definition : Names.identifier -> ?term:Term.constr -> Term.types -> 
-  ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?tactic:Proof_type.tactic ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
-
-type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
-
-type fixpoint_kind =
-  | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
-  | IsCoFixpoint
-
-val add_mutual_definitions :
-  (Names.identifier * Term.constr * Term.types *
-      (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
-  ?tactic:Proof_type.tactic ->
-  ?kind:Decl_kinds.definition_kind ->
-  ?reduce:(Term.constr -> Term.constr) ->
-  ?hook:Tacexpr.declaration_hook ->
-  notations ->
-  fixpoint_kind -> unit
-
-val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option ->
-  Tacexpr.raw_tactic_expr option -> unit
-
-val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit
-
-val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress
-(* Number of remaining obligations to be solved for this program *)
-
-val solve_all_obligations : Proof_type.tactic option -> unit
-
-val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit
-
-val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit
-
-val show_obligations : ?msg:bool -> Names.identifier option -> unit
-
-val show_term : Names.identifier option -> unit
-
-val admit_obligations : Names.identifier option -> unit
-
-exception NoObligations of Names.identifier option
-
-val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds
-
diff --git a/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib
deleted file mode 100644
index a4b9d67e..00000000
--- a/plugins/subtac/subtac_plugin.mllib
+++ /dev/null
@@ -1,13 +0,0 @@
-Subtac_utils
-Eterm
-Subtac_errors
-Subtac_coercion
-Subtac_obligations
-Subtac_cases
-Subtac_pretyping_F
-Subtac_pretyping
-Subtac_command
-Subtac_classes
-Subtac
-G_subtac
-Subtac_plugin_mod
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
deleted file mode 100644
index 68636574..00000000
--- a/plugins/subtac/subtac_pretyping.ml
+++ /dev/null
@@ -1,138 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Global
-open Pp
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Termops
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-
-open Subtac_coercion
-open Subtac_utils
-open Coqlib
-open Printer
-open Subtac_errors
-open Eterm
-
-module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion)
-
-open Pretyping
-
-let _ = Pretyping.allow_anonymous_refs := true
-
-type recursion_info = {
-  arg_name: name;
-  arg_type: types; (* A *)
-  args_after : rel_context;
-  wf_relation: constr; (* R : A -> A -> Prop *)
-  wf_proof: constr; (* : well_founded R *)
-  f_type: types; (* f: A -> Set *)
-  f_fulltype: types; (* Type with argument and wf proof product first *)
-}
-
-let my_print_rec_info env t =
-  str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
-  str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
-  str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
-  str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
-  str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
-  str "Full type: " ++ my_print_constr env t.f_fulltype
-(*   trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *)
-(* 	   str " and tycon "++ my_print_tycon env tycon ++ *)
-(* 	   str " in environment: " ++ my_print_env env); *)
-
-let interp env isevars c tycon =
-  let j = pretype true tycon env isevars ([],[]) c in
-  let _ = isevars := Evarutil.nf_evar_map !isevars in
-  let evd = consider_remaining_unif_problems env !isevars in
-(*   let unevd = undefined_evars evd in *)
-  let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in
-  let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in
-  let evm =  unevd' in
-    isevars := unevd';
-    nf_evar evm j.uj_val, nf_evar evm j.uj_type
-
-let find_with_index x l =
-  let rec aux i = function
-      (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl
-    | [] -> raise Not_found
-  in aux 0 l
-
-open Vernacexpr
-
-let coqintern_constr evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
-  Constrintern.intern_constr evd env
-let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = 
-  Constrintern.intern_type evd env
-
-let env_with_binders env isevars l =
-  let rec aux ((env, rels) as acc) = function
-      Topconstr.LocalRawDef ((loc, name), def) :: tl ->
-	let rawdef = coqintern_constr !isevars env def in
-	let coqdef, deftyp = interp env isevars rawdef empty_tycon in
-	let reldecl = (name, Some coqdef, deftyp) in
-	  aux  (push_rel reldecl env, reldecl :: rels) tl
-    | Topconstr.LocalRawAssum (bl, k, typ) :: tl ->
-	let rawtyp = coqintern_type !isevars env typ in
-	let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
-	let acc =
-	  List.fold_left (fun (env, rels) (loc, name) ->
-			    let reldecl = (name, None, coqtyp) in
-			      (push_rel reldecl env,
-			       reldecl :: rels))
-	    (env, rels) bl
-	in aux acc tl
-    | [] -> acc
-  in aux (env, []) l
-
-let subtac_process ?(is_type=false) env isevars id bl c tycon =
-  let c = Topconstr.abstract_constr_expr c bl in
-  let tycon, imps =
-    match tycon with
-	None -> empty_tycon, None
-      | Some t ->
-	  let t = Topconstr.prod_constr_expr t bl in
-	  let t = coqintern_type !isevars env t in
-	  let imps = Implicit_quantifiers.implicits_of_glob_constr t in
-	  let coqt, ttyp = interp env isevars t empty_tycon in
-	    mk_tycon coqt, Some imps
-  in
-  let c = coqintern_constr !isevars env c in
-  let imps = match imps with 
-    | Some i -> i
-    | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type c
-  in
-  let coqc, ctyp = interp env isevars c tycon in
-  let evm = non_instanciated_map env isevars !isevars in
-  let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
-    evm, coqc, ty, imps
-
-open Subtac_obligations
-
-let subtac_proof kind hook env isevars id bl c tycon =
-  let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in
-  let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in
-  let evm' = Subtac_utils.evars_of_term evm evm' coqt in
-  let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
-    add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
deleted file mode 100644
index fa767790..00000000
--- a/plugins/subtac/subtac_pretyping.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-open Term
-open Environ
-open Names
-open Sign
-open Evd
-open Global
-open Topconstr
-open Implicit_quantifiers
-open Impargs
-
-module Pretyping : Pretyping.S
-
-val interp :
-    Environ.env ->
-    Evd.evar_map ref ->
-    Glob_term.glob_constr ->
-    Evarutil.type_constraint -> Term.constr * Term.constr
-
-val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
-
-val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list ->
-  constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
deleted file mode 100644
index 3fc35c81..00000000
--- a/plugins/subtac/subtac_pretyping_F.ml
+++ /dev/null
@@ -1,662 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Pp
-open Compat
-open Util
-open Names
-open Sign
-open Evd
-open Term
-open Reductionops
-open Environ
-open Type_errors
-open Typeops
-open Libnames
-open Nameops
-open Classops
-open List
-open Recordops
-open Evarutil
-open Pretype_errors
-open Glob_term
-open Evarconv
-open Pattern
-open Pretyping
-
-(************************************************************************)
-(* This concerns Cases *)
-open Declarations
-open Inductive
-open Inductiveops
-
-module SubtacPretyping_F (Coercion : Coercion.S) = struct
-
-  module Cases = Subtac_cases.Cases_F(Coercion)
-
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  let allow_anonymous_refs = ref true
-
-  let evd_comb0 f evdref =
-    let (evd',x) = f !evdref in
-      evdref := evd';
-      x
-
-  let evd_comb1 f evdref x =
-    let (evd',y) = f !evdref x in
-      evdref := evd';
-      y
-
-  let evd_comb2 f evdref x y =
-    let (evd',z) = f !evdref x y in
-      evdref := evd';
-      z
-
-  let evd_comb3 f evdref x y z =
-    let (evd',t) = f !evdref x y z in
-      evdref := evd';
-      t
-
-  let mt_evd = Evd.empty
-
-  (* Utilisé pour inférer le prédicat des Cases *)
-  (* Semble exagérement fort *)
-  (* Faudra préférer une unification entre les types de toutes les clauses *)
-  (* et autoriser des ? à rester dans le résultat de l'unification *)
-
-  let evar_type_fixpoint loc env evdref lna lar vdefj =
-    let lt = Array.length vdefj in
-      if Array.length lar = lt then
-	for i = 0 to lt-1 do
-          if not (e_cumul env evdref (vdefj.(i)).uj_type
-		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env !evdref
-              i lna vdefj lar
-	done
-
-  let check_branches_message loc env evdref ind c (explft,lft) =
-    for i = 0 to Array.length explft - 1 do
-      if not (e_cumul env evdref lft.(i) explft.(i)) then
-	let sigma =  !evdref in
-	  error_ill_formed_branch_loc loc env sigma c (ind,i) lft.(i) explft.(i)
-    done
-
-  (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
-    | None -> j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
-
-  let push_rels vars env = List.fold_right push_rel vars env
-
-  (*
-    let evar_type_case evdref env ct pt lft p c =
-    let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c
-    in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty)
-  *)
-
-  let strip_meta id = (* For Grammar v7 compatibility *)
-    let s = string_of_id id in
-      if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
-      else id
-
-  let invert_ltac_bound_name env id0 id =
-    try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env)))
-    with Not_found ->
-      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
-	str " depends on pattern variable name " ++ pr_id id ++
-	str " which is not bound in current context")
-
-  let pretype_id loc env sigma (lvar,unbndltacvars) id =
-    let id = strip_meta id in (* May happen in tactics defined by Grammar *)
-      try
-	let (n,_,typ) = Termops.lookup_rel_id id (rel_context env) in
-	  { uj_val  = mkRel n; uj_type = lift n typ }
-      with Not_found ->
-	try
-	  let (ids,c) = List.assoc id lvar in
-	  let subst = List.map (invert_ltac_bound_name env id) ids in
-	  let c = substl subst c in
-	  { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
-	with Not_found ->
-	  try
-	    let (_,_,typ) = lookup_named id env in
-	      { uj_val  = mkVar id; uj_type = typ }
-	  with Not_found ->
-	    try (* To build a nicer ltac error message *)
-	      match List.assoc id unbndltacvars with
-		| None -> user_err_loc (loc,"",
-					str "variable " ++ pr_id id ++ str " should be bound to a term")
-		| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-	    with Not_found ->
-	      error_var_not_found_loc loc id
-
-  (* make a dependent predicate from an undependent one *)
-
-  let make_dep_of_undep env (IndType (indf,realargs)) pj =
-    let n = List.length realargs in
-    let rec decomp n p =
-      if n=0 then p else
-	match kind_of_term p with
-	  | Lambda (_,_,c) -> decomp (n-1) c
-	  | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
-    in
-    let sign,s = decompose_prod_n n pj.uj_type in
-    let ind = build_dependent_inductive env indf in
-    let s' = mkProd (Anonymous, ind, s) in
-    let ccl = lift 1 (decomp n pj.uj_val) in
-    let ccl' = mkLambda (Anonymous, ind, ccl) in
-      {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign}
-
-  (*************************************************************************)
-  (* Main pretyping function                                               *)
-
-  let pretype_ref evdref env ref =
-    let c = constr_of_global ref in
-      make_judge c (Retyping.get_type_of env Evd.empty c)
-
-  let pretype_sort evdref = function
-    | GProp c -> judge_of_prop_contents c
-    | GType _ -> evd_comb0 judge_of_new_Type evdref
-
-  let split_tycon_lam loc env evd tycon =
-    let rec real_split evd c =
-      let t = whd_betadeltaiota env evd c in
-	match kind_of_term t with
-	| Prod (na,dom,rng) -> evd, (na, dom, rng)
-	| Evar ev when not (Evd.is_defined_evar evd ev) ->
-	    let (evd',prod) = define_evar_as_product evd ev in
-	    let (_,dom,rng) = destProd prod in
-	      evd',(Anonymous, dom, rng)
-	| _ -> error_not_product_loc loc env evd c
-    in
-      match tycon with
-      | None -> evd,(Anonymous,None,None)
-      | Some (abs, c) ->
-	  (match abs with
-	   | None ->
-	       let evd', (n, dom, rng) = real_split evd c in
-		 evd', (n, mk_tycon dom, mk_tycon rng)
-	   | Some (init, cur) ->
-	       evd, (Anonymous, None, Some (Some (init, succ cur), c)))
-	    
-	    
-  (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [( evdref)] and *)
-  (* the type constraint tycon *)
-  let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar c =
-(*     let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *)
-(* 			       str " with tycon " ++ Evarutil.pr_tycon env tycon)  *)
-(*     with _ -> () *)
-(*     in *)
-    let pretype = pretype resolve_tc in
-    let pretype_type = pretype_type resolve_tc in
-    let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
-    match c with
-    | GRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_ref evdref env ref)
-	  tycon
-
-    | GVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_id loc env !evdref lvar id)
-	  tycon
-
-    | GEvar (loc, ev, instopt) ->
-	(* Ne faudrait-il pas s'assurer que hyps est bien un
-	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_context (Evd.find !evdref ev) in
-	let args = match instopt with
-          | None -> instance_from_named_context hyps
-          | Some inst -> failwith "Evar subtitutions not implemented" in
-	let c = mkEvar (ev, args) in
-	let j = (Retyping.get_judgment_of env !evdref c) in
-	  inh_conv_coerce_to_tycon loc env evdref j tycon
-
-    | GPatVar (loc,(someta,n)) ->
-	anomaly "Found a pattern variable in a glob_constr to type"
-
-    | GHole (loc,k) ->
-	let ty =
-          match tycon with
-            | Some (None, ty) -> ty
-            | None | Some _ ->
-		e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in
-	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
-
-    | GRec (loc,fixkind,names,bl,lar,vdef) ->
-	let rec type_bl env ctxt = function
-            [] -> ctxt
-          | (na,k,None,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let dcl = (na,None,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-          | (na,k,Some bd,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in
-              let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
-	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
-	let larj =
-          array_map2
-            (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
-            ctxtv lar in
-	let lara = Array.map (fun a -> a.utj_val) larj in
-	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
-	let nbfix = Array.length lar in
-	let names = Array.map (fun id -> Name id) names in
-	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
-	let newenv =
-	  let marked_ftys =
-	    Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
-			 mkApp (delayed_force Subtac_utils.fix_proto, [| sort; ty |]))
-	      ftys
-	  in
-	    push_rec_types (names,marked_ftys,[||]) env
-	in
-	let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in
-	let vdefj =
-	  array_map2_i
-	    (fun i ctxt def ->
-	      let fty =
-		let ty = ftys.(i) in
-		  if i = fixi then (
-		    Option.iter (fun tycon ->
-		      evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon)
-		      tycon;
-		    nf_evar !evdref ty)
-		  else ty
-	      in
-              (* we lift nbfix times the type in tycon, because of
-	       * the nbfix variables pushed to newenv *)
-              let (ctxt,ty) =
-		decompose_prod_n_assum (rel_context_length ctxt)
-                  (lift nbfix fty) in
-              let nenv = push_rel_context ctxt newenv in
-              let j = pretype (mk_tycon ty) nenv evdref lvar def in
-		{ uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
-		  uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
-            ctxtv vdef in
-	evar_type_fixpoint loc env evdref names ftys vdefj;
-	let ftys = Array.map (nf_evar !evdref) ftys in
-	let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
-	let fixj = match fixkind with
-	  | GFix (vn,i) ->
-	      (* First, let's find the guard indexes. *)
-	      (* If recursive argument was not given by user, we try all args.
-	         An earlier approach was to look only for inductive arguments,
-		 but doing it properly involves delta-reduction, and it finally
-                 doesn't seem worth the effort (except for huge mutual
-		 fixpoints ?) *)
-	      let possible_indexes = Array.to_list (Array.mapi
-		(fun i (n,_) -> match n with
-		   | Some n -> [n]
-		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
-		vn)
-	      in
-	      let fixdecls = (names,ftys,fdefs) in
-	      let indexes = search_guard loc env possible_indexes fixdecls in
-	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
-	  | GCoFix i ->
-	      let cofix = (i,(names,ftys,fdefs)) in
-	      (try check_cofix env cofix
-               with e when Errors.noncritical e -> Loc.raise loc e);
-	      make_judge (mkCoFix cofix) ftys.(i) in
-	inh_conv_coerce_to_tycon loc env evdref fixj tycon
-
-    | GSort (loc,s) ->
-	let s' = pretype_sort evdref s in
-	inh_conv_coerce_to_tycon loc env evdref s' tycon
-
-    | GApp (loc,f,args) ->
-	let length = List.length args in
-	let ftycon =
-	  let ty =
-	    if length > 0 then
-	      match tycon with
-	      | None -> None
-	      | Some (None, ty) -> mk_abstr_tycon length ty
-	      | Some (Some (init, cur), ty) ->
-		  Some (Some (length + init, length + cur), ty)
- 	    else tycon
-	  in
-	    match ty with
-	    | Some (_, t) ->
-	      if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty
-	      else None
-	    | _ -> None
-	in
-	let fj = pretype ftycon env evdref lvar f in
- 	let floc = loc_of_glob_constr f in
-	let rec apply_rec env n resj tycon = function
-	  | [] -> resj
-	  | c::rest ->
-	      let argloc = loc_of_glob_constr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
-              let resty = whd_betadeltaiota env !evdref resj.uj_type in
-      		match kind_of_term resty with
-		  | Prod (na,c1,c2) ->
-		      Option.iter (fun ty -> evdref :=
-			Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
-		      let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
-		      evdref := evd;
-		      let hj = pretype (mk_tycon c1) env evdref lvar c in
-		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-			apply_rec env (n+1)
-			{ uj_val = value;
-			  uj_type = typ }
-			  (Option.map (fun (abs, c) -> abs, c) tycon) rest
-
-		  | _ ->
-		      let hj = pretype empty_tycon env evdref lvar c in
-			error_cant_apply_not_functional_loc
-			  (join_loc floc argloc) env !evdref
-	      		  resj [hj]
-	in
-	let resj = apply_rec env 1 fj ftycon args in
-	let resj =
-	  match kind_of_term (whd_evar !evdref resj.uj_val) with
-	  | App (f,args) when isInd f or isConst f ->
-	      let sigma =  !evdref in
-	      let c = mkApp (f,Array.map (whd_evar sigma) args) in
-	      let t = Retyping.get_type_of env sigma c in
-	      make_judge c t
-	  | _ -> resj in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLambda(loc,name,k,c1,c2)      ->
-	let tycon' = evd_comb1
-	  (fun evd tycon ->
-	    match tycon with
-	    | None -> evd, tycon
-	    | Some ty ->
-		let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
-		  evd, Some ty')
-	  evdref tycon
-	in
-	let (name',dom,rng) = evd_comb1 (split_tycon_lam loc env) evdref tycon' in
-	let dom_valcon = valcon_of_tycon dom in
-	let j = pretype_type dom_valcon env evdref lvar c1 in
-	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) evdref lvar c2 in
-	let resj = judge_of_abstraction env name j j' in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GProd(loc,name,k,c1,c2)        ->
-	let j = pretype_type empty_valcon env evdref lvar c1 in
-	let var = (name,j.utj_val) in
-	let env' = Termops.push_rel_assum var env in
-	let j' = pretype_type empty_valcon env' evdref lvar c2 in
-	let resj =
-	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Loc.raise loc e in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLetIn(loc,name,c1,c2)      ->
-	let j = pretype empty_tycon env evdref lvar c1 in
-	let t = Termops.refresh_universes j.uj_type in
-	let var = (name,Some j.uj_val,t) in
-        let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
-	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
-	    uj_type = subst1 j.uj_val j'.uj_type }
-
-    | GLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj
-	in
-	let cstrs = get_constructors env indf in
-	if Array.length cstrs <> 1 then
-          user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
-	let cs = cstrs.(0) in
-	  if List.length nal <> cs.cs_nargs then
-            user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
-	let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
-          (List.rev nal) cs.cs_args in
-	let env_f = push_rels fsign env in
-	  (* Make dependencies from arity signature impossible *)
-	let arsgn =
-	  let arsgn,_ = get_arity env indf in
-	    if not !allow_anonymous_refs then
-	      List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	    else arsgn
-	in
-	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	    let nar = List.length arsgn in
-	      (match po with
-		 | Some p ->
-		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p evdref lvar p in
-		     let ccl = nf_evar !evdref pj.utj_val in
-		     let psign = make_arity_signature env true indf in (* with names *)
-		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst =
-		       (Array.to_list cs.cs_concl_realargs)
-		       @[build_dependent_constructor cs] in
-		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env !evdref lp inst in
-		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|]) in
-		       { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
-
-		 | None ->
-		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar !evdref fj.uj_type in
-		     let ccl =
-		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl
-		       else
-			 error_cant_find_case_type_loc loc env !evdref
-			   cj.uj_val in
-		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
-		     let v =
-		       let mis,_ = dest_ind_family indf in
-		       let ci = make_case_info env mis LetStyle in
-			 mkCase (ci, p, cj.uj_val,[|f|] )
-		     in
-		       { uj_val = v; uj_type = ccl })
-
-    | GIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj in
-	let cstrs = get_constructors env indf in
-	  if Array.length cstrs <> 2 then
-            user_err_loc (loc,"",
-			  str "If is only for inductive types with two constructors.");
-
-	  let arsgn =
-	    let arsgn,_ = get_arity env indf in
-	      if not !allow_anonymous_refs then
-		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	      else arsgn
-	  in
-	  let nar = List.length arsgn in
-	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	  let pred,p = match po with
-	    | Some p ->
-		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p evdref lvar p in
-		let ccl = nf_evar !evdref pj.utj_val in
-		let pred = it_mkLambda_or_LetIn ccl psign in
-		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-		let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred;
-								     uj_type = typ} tycon
-		in
-		  jtyp.uj_val, jtyp.uj_type
-	    | None ->
-		let p = match tycon with
-		  | Some (None, ty) -> ty
-		  | None | Some _ ->
-                      e_new_evar evdref env ~src:(loc,InternalHole) (Termops.new_Type ())
-		in
-		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar !evdref pred in
-	  let p = nf_evar !evdref p in
-	  let f cs b =
-	    let n = rel_context_length cs.cs_args in
-	    let pi = lift n pred in
-	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn =
-	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
-	      else
-		List.map
-		  (fun (n, b, t) ->
-		     match n with
-                         Name _ -> (n, b, t)
-                       | Anonymous -> (Name (id_of_string "H"), b, t))
-		cs.cs_args
-	    in
-	    let env_c = push_rels csgn env in
-	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
-	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
-	  let b1 = f cstrs.(0) b1 in
-	  let b2 = f cstrs.(1) b2 in
-	  let v =
-	    let mis,_ = dest_ind_family indf in
-	    let ci = make_case_info env mis IfStyle in
-	      mkCase (ci, pred, cj.uj_val, [|b1;b2|])
-	  in
-	    { uj_val = v; uj_type = p }
-
-    | GCases (loc,sty,po,tml,eqns) ->
-	Cases.compile_cases loc sty
-	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
-	  tycon env (* loc *) (po,tml,eqns)
-
-    | GCast (loc,c,k) ->
-	let cj =
-	  match k with
-	      CastCoerce ->
-		let cj = pretype empty_tycon env evdref lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
-	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env evdref lvar t in
-		let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
-		let v = mkCast (cj.uj_val, k, tj.utj_val) in
-		  { uj_val = v; uj_type = tj.utj_val }
-	in
-	  inh_conv_coerce_to_tycon loc env evdref cj tycon
-
-  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-  and pretype_type resolve_tc valcon env evdref lvar = function
-    | GHole loc ->
-	(match valcon with
-	   | Some v ->
-               let s =
-		 let sigma =  !evdref in
-		 let t = Retyping.get_type_of env sigma v in
-		   match kind_of_term (whd_betadeltaiota env sigma t) with
-                     | Sort s -> s
-                     | Evar ev when is_Type (existential_type sigma ev) ->
-			 evd_comb1 (define_evar_as_sort) evdref ev
-                     | _ -> anomaly "Found a type constraint which is not a type"
-               in
-		 { utj_val = v;
-		   utj_type = s }
-	   | None ->
-	       let s = Termops.new_Type_sort () in
-		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
-		   utj_type = s})
-    | c ->
-	let j = pretype resolve_tc empty_tycon env evdref lvar c in
-	let loc = loc_of_glob_constr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
-	  match valcon with
-	    | None -> tj
-	    | Some v ->
-		if e_cumul env evdref v tj.utj_val then tj
-		else
-		  error_unexpected_type_loc
-                    (loc_of_glob_constr c) env !evdref tj.utj_val v
-
-  let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
-    let c' = match kind with
-      | OfType exptyp ->
-	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	  (pretype resolve_classes tycon env evdref lvar c).uj_val
-      | IsType ->
-	  (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val 
-    in
-      if resolve_classes then
-	(try 
-	   evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations
-	     ~split:true ~fail:true env !evdref;
-	   evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
-	     ~split:true ~fail:false env !evdref
-	 with e when Errors.noncritical e ->
-           if fail_evar then raise e else ());
-      evdref := consider_remaining_unif_problems env !evdref;
-      let c = if expand_evar then nf_evar !evdref c' else c' in
-      if fail_evar then check_evars env Evd.empty !evdref c;
-      c
-
-  (* TODO: comment faire remonter l'information si le typage a resolu des
-     variables du sigma original. il faudrait que la fonction de typage
-     retourne aussi le nouveau sigma...
-  *)
-
-  let understand_judgment sigma env c =
-    let evdref = ref (create_evar_defs sigma) in
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-    let evd = consider_remaining_unif_problems env !evdref in
-    let j = j_nf_evar evd j in
-    check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-    j
-
-  let understand_judgment_tcc evdref env c =
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-    j_nf_evar !evdref j
-
-  (* Raw calls to the unsafe inference machine: boolean says if we must
-     fail on unresolved evars; the unsafe_judgment list allows us to
-     extend env with some bindings *)
-
-  let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
-    let evdref = ref (Evd.create_evar_defs sigma) in
-    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
-    !evdref, c
-
-  (** Entry points of the high-level type synthesis algorithm *)
-
-  let understand_gen kind sigma env c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
-
-  let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
-
-  let understand_type sigma env c =
-    snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
-
-  let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
-    ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
-
-  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
-    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
-
-  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
-    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
-end
-
-module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
deleted file mode 100644
index e32bb9e0..00000000
--- a/plugins/subtac/subtac_utils.ml
+++ /dev/null
@@ -1,476 +0,0 @@
-(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
-
-open Evd
-open Libnames
-open Coqlib
-open Term
-open Names
-open Util
-
-let ($) f x = f x
-
-(****************************************************************************)
-(* Library linking *)
-
-let contrib_name = "Program"
-
-let subtac_dir = [contrib_name]
-let fixsub_module = subtac_dir @ ["Wf"]
-let utils_module = subtac_dir @ ["Utils"]
-let tactics_module = subtac_dir @ ["Tactics"]
-let init_constant dir s () = gen_constant contrib_name dir s
-let init_reference dir s () = gen_reference contrib_name dir s
-
-let safe_init_constant md name () =
-  check_required_library ("Coq"::md);
-  init_constant md name ()
-
-let ex_pi1 = init_constant utils_module "ex_pi1"
-let ex_pi2 = init_constant utils_module "ex_pi2"
-
-let make_ref l s = init_reference l s
-let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
-let acc_ref = make_ref  ["Init";"Wf"] "Acc"
-let acc_inv_ref = make_ref  ["Init";"Wf"] "Acc_inv"
-let fix_sub_ref = make_ref fixsub_module "Fix_sub"
-let measure_on_R_ref = make_ref fixsub_module "MR"
-let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
-let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
-
-let make_ref s = Qualid (dummy_loc, qualid_of_string s)
-let lt_ref = make_ref "Init.Peano.lt"
-let sig_ref = make_ref "Init.Specif.sig"
-let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
-let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
-
-let build_sig () =
-  { proj1 = init_constant ["Init"; "Specif"] "proj1_sig" ();
-    proj2 = init_constant ["Init"; "Specif"] "proj2_sig" ();
-    elim = init_constant ["Init"; "Specif"] "sig_rec" ();
-    intro = init_constant ["Init"; "Specif"] "exist" ();
-    typ = init_constant ["Init"; "Specif"] "sig" () }
-
-let sig_ = build_sig
-
-let fix_proto = safe_init_constant tactics_module "fix_proto"
-
-let hide_obligation = safe_init_constant tactics_module "obligation"
-
-let eq_ind = init_constant ["Init"; "Logic"] "eq"
-let eq_rec = init_constant ["Init"; "Logic"] "eq_rec"
-let eq_rect = init_constant ["Init"; "Logic"] "eq_rect"
-let eq_refl = init_constant ["Init"; "Logic"] "refl_equal"
-let eq_ind_ref = init_reference ["Init"; "Logic"] "eq"
-let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal"
-
-let not_ref = init_constant ["Init"; "Logic"] "not"
-
-let and_typ = Coqlib.build_coq_and
-
-let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep"
-let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec"
-let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep"
-let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro"
-
-let jmeq_ind =
-  safe_init_constant ["Logic";"JMeq"] "JMeq"
-
-let jmeq_rec =
-  init_constant ["Logic";"JMeq"] "JMeq_rec"
-
-let jmeq_refl =
-  init_constant ["Logic";"JMeq"] "JMeq_refl"
-
-let ex_ind = init_constant ["Init"; "Logic"] "ex"
-let ex_intro = init_reference ["Init"; "Logic"] "ex_intro"
-
-let proj1 = init_constant ["Init"; "Logic"] "proj1"
-let proj2 = init_constant ["Init"; "Logic"] "proj2"
-
-let existS = build_sigma_type
-
-let prod = build_prod
-
-
-(* orders *)
-let well_founded = init_constant ["Init"; "Wf"] "well_founded"
-let fix = init_constant ["Init"; "Wf"] "Fix"
-let acc = init_constant ["Init"; "Wf"] "Acc"
-let acc_inv = init_constant ["Init"; "Wf"] "Acc_inv"
-
-let extconstr = Constrextern.extern_constr true (Global.env ())
-let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
-
-open Pp
-
-let my_print_constr = Termops.print_constr_env
-let my_print_constr_expr = Ppconstr.pr_constr_expr
-let my_print_rel_context env ctx = Printer.pr_rel_context env ctx
-let my_print_context = Termops.print_rel_context
-let my_print_named_context = Termops.print_named_context
-let my_print_env = Termops.print_env
-let my_print_glob_constr = Printer.pr_glob_constr_env
-let my_print_evardefs = Evd.pr_evar_map None
-
-let my_print_tycon_type = Evarutil.pr_tycon_type
-
-let debug_level = 2
-
-let debug_on = true
-
-let debug n s =
-  if debug_on then
-    if !Flags.debug && n >= debug_level then
-      msgnl s
-    else ()
-  else ()
-
-let debug_msg n s =
-  if debug_on then
-    if !Flags.debug  && n >= debug_level then s
-    else mt ()
-  else mt ()
-
-let trace s =
-  if debug_on then
-    if !Flags.debug  && debug_level > 0 then msgnl s
-    else ()
-  else ()
-
-let rec pp_list f = function
-    [] -> mt()
-  | x :: y -> f x ++ spc () ++ pp_list f y
-
-let wf_relations = Hashtbl.create 10
-
-let std_relations () =
-  let add k v = Hashtbl.add wf_relations k v in
-    add (init_constant ["Init"; "Peano"] "lt" ())
-      (init_constant ["Arith"; "Wf_nat"] "lt_wf")
-
-let std_relations = Lazy.lazy_from_fun std_relations
-
-type binders = Topconstr.local_binder list
-
-let app_opt c e =
-  match c with
-      Some constr -> constr e
-    | None -> e
-
-let print_args env args =
-  Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
-
-let make_existential loc ?(opaque = Define true) env isevars c =
-  Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c
-
-let no_goals_or_obligations = function
-  | GoalEvar | QuestionMark _ -> false
-  | _ -> true
-
-let make_existential_expr loc env c =
-  let key = Evarutil.new_untyped_evar () in
-  let evar = Topconstr.CEvar (loc, key, None) in
-    debug 2 (str "Constructed evar " ++ int key);
-    evar
-
-let string_of_hole_kind = function
-  | ImplicitArg _ -> "ImplicitArg"
-  | BinderType _ -> "BinderType"
-  | QuestionMark _ -> "QuestionMark"
-  | CasesType -> "CasesType"
-  | InternalHole -> "InternalHole"
-  | TomatchTypeParameter _ -> "TomatchTypeParameter"
-  | GoalEvar -> "GoalEvar"
-  | ImpossibleCase -> "ImpossibleCase"
-  | MatchingVar _ -> "MatchingVar"
-
-let evars_of_term evc init c =
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n)
-    | Evar (n, _) -> assert(false)
-    | _ -> fold_constr evrec acc c
-  in
-    evrec init c
-
-let non_instanciated_map env evd evm =
-  List.fold_left
-    (fun evm (key, evi) ->
-       let (loc,k) = evar_source key !evd in
-	 debug 2 (str "evar " ++ int key ++ str " has kind " ++
-		    str (string_of_hole_kind k));
-	 match k with
-	 | QuestionMark _ -> Evd.add evm key evi
-	 | ImplicitArg (_,_,false) -> Evd.add evm key evi
-	 | _ ->
-	     debug 2 (str " and is an implicit");
-	     Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
-    Evd.empty (Evarutil.non_instantiated evm)
-
-let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
-let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
-
-let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
-let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
-
-let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
-let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
-
-open Tactics
-open Tacticals
-
-let filter_map f l =
-  let rec aux acc = function
-      hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
-		     | None -> aux acc tl)
-    | [] -> List.rev acc
-  in aux [] l
-
-let build_dependent_sum l =
-  let rec aux names conttac conttype = function
-      (n, t) :: ((_ :: _) as tl) ->
-	let hyptype = substl names t in
-	  trace (spc () ++ str ("treating evar " ^ string_of_id n));
-	  (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
-	   with e when Errors.noncritical e -> ());
-	let tac = assert_tac (Name n) hyptype in
-	let conttac =
-	  (fun cont ->
-	     conttac
-	     (tclTHENS tac
-		([intros;
-		  (tclTHENSEQ
-		     [constructor_tac false (Some 1) 1
-			(Glob_term.ImplicitBindings [mkVar n]);
-		      cont]);
-		 ])))
-	in
-	let conttype =
-	  (fun typ ->
-	     let tex = mkLambda (Name n, t, typ) in
-	       conttype
-		 (mkApp (ex_ind (), [| t; tex |])))
-	in
-	  aux (mkVar n :: names) conttac conttype tl
-    | (n, t) :: [] ->
-	(conttac intros, conttype t)
-    | [] -> raise (Invalid_argument "build_dependent_sum")
-  in aux [] identity identity (List.rev l)
-
-open Proof_type
-open Tacexpr
-
-let mkProj1 a b c =
-  mkApp (delayed_force proj1, [| a; b; c |])
-
-let mkProj2 a b c =
-  mkApp (delayed_force proj2, [| a; b; c |])
-
-let mk_ex_pi1 a b c =
-  mkApp (delayed_force ex_pi1, [| a; b; c |])
-
-let mk_ex_pi2 a b c =
-  mkApp (delayed_force ex_pi2, [| a; b; c |])
-
-let mkSubset name typ prop =
-  mkApp ((delayed_force sig_).typ,
-	 [| typ; mkLambda (name, typ, prop) |])
-
-let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (delayed_force jmeq_refl, [| typ; x |])
-
-let unsafe_fold_right f = function
-    hd :: tl -> List.fold_right f tl hd
-  | [] -> raise (Invalid_argument "unsafe_fold_right")
-
-let mk_conj l =
-  let conj_typ = delayed_force and_typ in
-    unsafe_fold_right
-      (fun c conj ->
-	 mkApp (conj_typ, [| c ; conj |]))
-      l
-
-let mk_not c =
-  let notc = delayed_force not_ref in
-    mkApp (notc, [| c |])
-
-let and_tac l hook =
-  let andc = Coqlib.build_coq_and () in
-  let rec aux ((accid, goal, tac, extract) as acc) = function
-    | [] -> (* Singleton *) acc
-
-    | (id, x, elgoal, eltac) :: tl ->
-	let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
-	let proj = fun c -> mkProj2 goal elgoal c in
-	let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
-	  aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac',
-	       (id, x, elgoal, proj) :: extract) tl
-
-  in
-  let and_proof_id, and_goal, and_tac, and_extract =
-    match l with
-      | [] -> raise (Invalid_argument "and_tac: empty list of goals")
-      | (hdid, x, hdg, hdt) :: tl ->
-	  aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
-  in
-  let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
-    Lemmas.start_proof and_proofid goal_kind and_goal
-      (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
-    trace (str "Started and proof");
-    Pfedit.by and_tac;
-    trace (str "Applied and tac")
-
-
-let destruct_ex ext ex =
-  let rec aux c acc =
-    match kind_of_term c with
-	App (f, args) ->
-	  (match kind_of_term f with
-	       Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 ->
-		 let (dom, rng) =
-		   try (args.(0), args.(1))
-		   with e when Errors.noncritical e -> assert(false)
-		 in
-		 let pi1 = (mk_ex_pi1 dom rng acc) in
-		 let rng_body =
-		   match kind_of_term rng with
-		       Lambda (_, _, t) -> subst1 pi1 t
-		     | t -> rng
-		 in
-		   pi1 :: aux rng_body (mk_ex_pi2 dom rng acc)
-	     | _ -> [acc])
-      | _ -> [acc]
-  in aux ex ext
-
-open Glob_term
-
-let id_of_name = function
-    Name n -> n
-  | Anonymous -> raise (Invalid_argument "id_of_name")
-
-let definition_message id =
-  Nameops.pr_id id ++ str " is defined"
-
-let recursive_message v =
-  match Array.length v with
-    | 0 -> error "no recursive definition"
-    | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
-    | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++
-		    spc () ++ str "are recursively defined")
-
-let print_message m =
-  Flags.if_verbose ppnl m
-
-(* Solve an obligation using tactics, return the corresponding proof term *)
-let solve_by_tac evi t =
-  let id = id_of_string "H" in
-  try
-    Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
-    (fun _ _ -> ());
-    Pfedit.by (tclCOMPLETE t);
-    let _,(const,_,_,_) = Pfedit.cook_proof ignore in
-      Pfedit.delete_current_proof (); 
-      Inductiveops.control_only_guard (Global.env ())
-	const.Entries.const_entry_body;
-      const.Entries.const_entry_body
-  with reraise ->
-    Pfedit.delete_current_proof();
-    raise reraise
-
-(* let apply_tac t goal = t goal *)
-
-(* let solve_by_tac evi t = *)
-(*   let ev = 1 in *)
-(*   let evm = Evd.add Evd.empty ev evi in *)
-(*   let goal = {it = evi; sigma = evm } in *)
-(*   let (res, valid) = apply_tac t goal in *)
-(*     if res.it = [] then *)
-(*       let prooftree = valid [] in *)
-(*       let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *)
-(* 	if obls = [] then proofterm *)
-(* 	else raise Exit *)
-(*     else raise Exit *)
-
-let rec string_of_list sep f = function
-    [] -> ""
-  | x :: [] -> f x
-  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
-
-let string_of_intset d =
-  string_of_list "," string_of_int (Intset.elements d)
-
-(**********************************************************)
-(* Pretty-printing *)
-open Printer
-open Ppconstr
-open Nameops
-open Evd
-
-let pr_meta_map evd =
-  let ml = meta_list evd in
-  let pr_name = function
-      Name id -> str"[" ++ pr_id id ++ str"]"
-    | _ -> mt() in
-  let pr_meta_binding = function
-    | (mv,Cltyp (na,b)) ->
-      	hov 0
-	  (pr_meta mv ++ pr_name na ++ str " : " ++
-           Termops.print_constr b.rebus ++ fnl ())
-    | (mv,Clval(na,b,_)) ->
-      	hov 0
-	  (pr_meta mv ++ pr_name na ++ str " := " ++
-             Termops.print_constr (fst b).rebus ++ fnl ())
-  in
-  prlist pr_meta_binding ml
-
-let pr_idl idl = prlist_with_sep pr_spc pr_id idl
-
-let pr_evar_info evi =
-  let phyps =
-    (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *)
-    Printer.pr_named_context (Global.env()) (evar_context evi)
-  in
-  let pty = Termops.print_constr evi.evar_concl in
-  let pb =
-    match evi.evar_body with
-      | Evar_empty -> mt ()
-      | Evar_defined c -> spc() ++ str"=> "  ++ Termops.print_constr c
-  in
-  hov 2 (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]")
-
-let pr_evar_map sigma =
-  h 0
-    (prlist_with_sep pr_fnl
-      (fun (ev,evi) ->
-        h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
-      (to_list sigma))
-
-let pr_constraints pbs =
-  h 0
-    (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
-      Termops.print_constr t1 ++ spc() ++
-      str (match pbty with
-	| Reduction.CONV -> "=="
-	| Reduction.CUMUL -> "<=") ++
-      spc() ++ Termops.print_constr t2) pbs)
-
-let pr_evar_map evd =
-  let pp_evm =
-    let evars =  evd in
-    if evars = empty then mt() else
-      str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
-  let pp_met =
-    if meta_list evd = [] then mt() else
-      str"METAS:"++brk(0,1)++pr_meta_map evd in
-  v 0 (pp_evm ++ pp_met)
-
-let contrib_tactics_path =
-  make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"])
-
-let tactics_tac s =
-  lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s))
-
-let tactics_call tac args =
-  TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
deleted file mode 100644
index 112b1795..00000000
--- a/plugins/subtac/subtac_utils.mli
+++ /dev/null
@@ -1,131 +0,0 @@
-open Term
-open Libnames
-open Coqlib
-open Environ
-open Pp
-open Evd
-open Decl_kinds
-open Topconstr
-open Glob_term
-open Util
-open Evarutil
-open Names
-open Sign
-
-val ($) : ('a -> 'b) -> 'a -> 'b
-val contrib_name : string
-val subtac_dir : string list
-val fixsub_module : string list
-val init_constant : string list -> string -> constr delayed
-val init_reference : string list -> string -> global_reference delayed
-val well_founded_ref : global_reference delayed
-val acc_ref : global_reference delayed
-val acc_inv_ref : global_reference delayed
-val fix_sub_ref : global_reference delayed
-val measure_on_R_ref : global_reference delayed
-val fix_measure_sub_ref : global_reference delayed
-val refl_ref : global_reference delayed
-val lt_ref : reference
-val sig_ref : reference
-val proj1_sig_ref : reference
-val proj2_sig_ref : reference
-val build_sig : unit -> coq_sigma_data
-val sig_ : coq_sigma_data delayed
-
-val fix_proto : constr delayed
-
-val hide_obligation : constr delayed
-
-val eq_ind : constr delayed
-val eq_rec : constr delayed
-val eq_rect : constr delayed
-val eq_refl : constr delayed
-
-val not_ref : constr delayed
-val and_typ : constr delayed
-
-val eqdep_ind : constr delayed
-val eqdep_rec : constr delayed
-
-val jmeq_ind : constr delayed
-val jmeq_rec : constr delayed
-val jmeq_refl : constr delayed
-
-val existS : coq_sigma_data delayed
-val prod : coq_sigma_data delayed
-
-val well_founded : constr delayed
-val fix : constr delayed
-val acc : constr delayed
-val acc_inv : constr delayed
-val extconstr : constr -> constr_expr
-val extsort : sorts -> constr_expr
-
-val my_print_constr : env -> constr -> std_ppcmds
-val my_print_constr_expr : constr_expr -> std_ppcmds
-val my_print_evardefs : evar_map -> std_ppcmds
-val my_print_context : env -> std_ppcmds
-val my_print_rel_context : env -> rel_context -> std_ppcmds
-val my_print_named_context : env -> std_ppcmds
-val my_print_env : env -> std_ppcmds
-val my_print_glob_constr : env -> glob_constr -> std_ppcmds
-val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
-
-
-val debug : int -> std_ppcmds -> unit
-val debug_msg : int -> std_ppcmds -> std_ppcmds
-val trace : std_ppcmds -> unit
-val wf_relations : (constr, constr delayed) Hashtbl.t
-
-type binders = local_binder list
-val app_opt : ('a -> 'a) option -> 'a -> 'a
-val print_args : env -> constr array -> std_ppcmds
-val make_existential : loc -> ?opaque:obligation_definition_status ->
-  env -> evar_map ref -> types -> constr
-val no_goals_or_obligations : Typeclasses.evar_filter
-val make_existential_expr : loc -> 'a -> 'b -> constr_expr
-val string_of_hole_kind : hole_kind -> string
-val evars_of_term : evar_map -> evar_map -> constr -> evar_map
-val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map
-val global_kind : logical_kind
-val goal_kind : locality * goal_object_kind
-val global_proof_kind : logical_kind
-val goal_proof_kind : locality * goal_object_kind
-val global_fix_kind : logical_kind
-val goal_fix_kind : locality * goal_object_kind
-
-val mkSubset : name -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mkProj1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_ex_pi1 : constr -> constr -> constr -> constr
-val mk_eq : types -> constr -> constr -> types
-val mk_eq_refl : types -> constr -> constr
-val mk_JMeq : types -> constr-> types -> constr -> types
-val mk_JMeq_refl : types -> constr -> constr
-val mk_conj : types list -> types
-val mk_not : types -> types
-
-val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
-val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->
-  ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
-
-val destruct_ex : constr -> constr -> constr list
-
-val id_of_name : name -> identifier
-
-val definition_message : identifier -> std_ppcmds
-val recursive_message : constant array -> std_ppcmds
-
-val print_message : std_ppcmds -> unit
-
-val solve_by_tac : evar_info -> Tacmach.tactic -> constr
-
-val string_of_list : string -> ('a -> string) -> 'a list -> string
-val string_of_intset : Intset.t -> string
-
-val pr_evar_map : evar_map -> Pp.std_ppcmds
-
-val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
-
-val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds
diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v
deleted file mode 100644
index e3dbd127..00000000
--- a/plugins/subtac/test/ListDep.v
+++ /dev/null
@@ -1,49 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import List.
-Require Import Coq.Program.Program.
-
-Set Implicit Arguments.
-
-Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
-
-Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
-Proof.
-  intros.
-  inversion H.
-  split.
-  intros.
-  apply H0.
-  auto with datatypes.
-  auto with arith.
-Qed.
-
-Section Map_DependentRecursor.
-  Variable U V : Set.
-  Variable l : list U.
-  Variable f : { x : U | In x l } -> V.
-
-  Obligations Tactic := unfold sub_list in * ;
-    program_simpl ; intuition.
-
-  Program Fixpoint map_rec ( l' : list U | sub_list l' l )
-    { measure length l' } : { r : list V | length r = length l' } :=
-    match l' with
-      | nil => nil
-      | cons x tl => let tl' := map_rec tl in
-	f x :: tl'
-    end.
-
-  Next Obligation.
-    destruct_call map_rec.
-    simpl in *.
-    subst l'.
-    simpl ; auto with arith.
-  Qed.
-
-  Program Definition map : list V := map_rec l.
-
-End Map_DependentRecursor.
-
-Extraction map.
-Extraction map_rec.
-
diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v
deleted file mode 100644
index 2cea0841..00000000
--- a/plugins/subtac/test/ListsTest.v
+++ /dev/null
@@ -1,99 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import Coq.Program.Program.
-Require Import List.
-
-Set Implicit Arguments.
-
-Section Accessors.
-  Variable A : Set.
-
-  Program Definition myhd : forall (l : list A | length l <> 0), A :=
-    fun l =>
-      match l with
-        | nil => !
-        | hd :: tl => hd
-      end.
-
-  Program Definition mytail (l : list A | length l <> 0) : list A :=
-    match l with
-      | nil => !
-      | hd :: tl => tl
-    end.
-End Accessors.
-
-Program Definition test_hd : nat := myhd (cons 1 nil).
-
-(*Eval compute in test_hd*)
-(*Program Definition test_tail : list A := mytail nil.*)
-
-Section app.
-  Variable A : Set.
-
-  Program Fixpoint app (l : list A) (l' : list A) { struct l } :
-    { r : list A | length r = length l + length l' } :=
-    match l with
-      | nil => l'
-      | hd :: tl => hd :: (tl ++ l')
-    end
-    where "x ++ y" := (app x y).
-
-  Next Obligation.
-    intros.
-    destruct_call app ; program_simpl.
-  Defined.
-
-  Program Lemma app_id_l : forall l : list A, l = nil ++ l.
-  Proof.
-    simpl ; auto.
-  Qed.
-
-  Program Lemma app_id_r : forall l : list A, l = l ++ nil.
-  Proof.
-    induction l ; simpl in * ; auto.
-    rewrite <- IHl ; auto.
-  Qed.
-
-End app.
-
-Extraction app.
-
-Section Nth.
-
-  Variable A : Set.
-
-  Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A :=
-    match n, l with
-      | 0, hd :: _ => hd
-      | S n', _ :: tl => nth tl n'
-      | _, nil => !
-    end.
-
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith.
-  Defined.
-
-  Next Obligation.
-  Proof.
-    inversion H.
-  Qed.
-
-  Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A :=
-    match l, n with
-      | hd :: _, 0 => hd
-      | _ :: tl, S n' => nth' tl n'
-      | nil, _ => !
-    end.
-  Next Obligation.
-  Proof.
-    simpl in *. auto with arith.
-  Defined.
-
-  Next Obligation.
-  Proof.
-    intros.
-    inversion H.
-  Defined.
-
-End Nth.
-
diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v
deleted file mode 100644
index 01e2d75f..00000000
--- a/plugins/subtac/test/Mutind.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Require Import List.
-
-Program Fixpoint f a : { x : nat | x > 0 } :=
-  match a with
-  | 0 => 1
-  | S a' => g a a'
-  end
-with g a b : { x : nat | x > 0 } :=
-  match b with
-  | 0 => 1
-  | S b' => f b'
-  end.
-
-Check f.
-Check g.
-
-
-
-
-
diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v
deleted file mode 100644
index 7e0755d5..00000000
--- a/plugins/subtac/test/Test1.v
+++ /dev/null
@@ -1,16 +0,0 @@
-Program Definition test (a b : nat) : { x : nat | x = a + b } :=
-  ((a + b) : { x : nat | x = a + b }).
-Proof.
-intros.
-reflexivity.
-Qed.
-
-Print test.
-
-Require Import List.
-
-Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
-  match l with
-    nil => 1
-    | a :: l => a
-  end.
diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v
deleted file mode 100644
index 97c3d941..00000000
--- a/plugins/subtac/test/euclid.v
+++ /dev/null
@@ -1,24 +0,0 @@
-Require Import Coq.Program.Program.
-Require Import Coq.Arith.Compare_dec.
-Notation "( x & y )" := (existS _ x y) : core_scope.
-
-Require Import Omega.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a}  :
-  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
-  (S q' & r)
-  else (O & a).
-
-Next Obligation.
-  assert(b * S q' = b * q' + b) by auto with arith ; omega.
-Defined.
-
-Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
-
-Eval lazy beta zeta delta iota in test_euclid.
-
-Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
-  (a & S a).
-
-Check testsig.
diff --git a/plugins/subtac/test/id.v b/plugins/subtac/test/id.v
deleted file mode 100644
index 9ae11088..00000000
--- a/plugins/subtac/test/id.v
+++ /dev/null
@@ -1,46 +0,0 @@
-Require Coq.Arith.Arith.
-
-Require Import Coq.subtac.Utils.
-Program Fixpoint id (n : nat) : { x : nat | x = n } :=
-  match n with
-  | O => O
-  | S p => S (id p)
-  end.
-intros ; auto.
-
-pose (subset_simpl (id p)).
-simpl in e.
-unfold p0.
-rewrite e.
-auto.
-Defined.
-
-Check id.
-Print id.
-Extraction id.
-
-Axiom le_gt_dec : forall n m, { n <= m } + { n > m }.
-Require Import Omega.
-
-Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } :=
-  if le_gt_dec n 0 then 0
-  else S (id_if (pred n)).
-intros.
-auto with arith.
-intros.
-pose (subset_simpl (id_if (pred n))).
-simpl in e.
-rewrite e.
-induction n ; auto with arith.
-Defined.
-
-Print id_if_instance.
-Extraction id_if_instance.
-
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-
-Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} :=
-  (a & a).
-intros.
-auto.
-Qed.
diff --git a/plugins/subtac/test/measure.v b/plugins/subtac/test/measure.v
deleted file mode 100644
index 4f938f4f..00000000
--- a/plugins/subtac/test/measure.v
+++ /dev/null
@@ -1,20 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.Program.Program.
-
-Fixpoint size (a : nat) : nat :=
-  match a with
-  0 => 1
-  | S n => S (size n)
-  end.
-
-Program Fixpoint test_measure (a : nat) {measure size a}  : nat :=
-  match a with
-  | S (S n) => S (test_measure n)
-  | 0 | S 0 => a
-  end.
-
-Check test_measure.
-Print test_measure.
\ No newline at end of file
diff --git a/plugins/subtac/test/rec.v b/plugins/subtac/test/rec.v
deleted file mode 100644
index aaefd8cc..00000000
--- a/plugins/subtac/test/rec.v
+++ /dev/null
@@ -1,65 +0,0 @@
-Require Import Coq.Arith.Arith.
-Require Import Lt.
-Require Import Omega.
-
-Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
-(*Proof.
-  intros.
-  elim (le_lt_dec y x) ; intros ; auto with arith.
-Defined.
-*)
-Require Import Coq.subtac.FixSub.
-Require Import Wf_nat.
-
-Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
-auto with arith.
-Qed.
-
-Program Fixpoint id_struct (a : nat) : nat :=
-  match a with
-  0 => 0
-  | S n => S (id_struct n)
-  end.
-
-Check struct_rec.
-
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-
-Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
-  if (lt_ge_dec O a)
-  then S (wfrec (pred a))
-  else O.
-intros.
-apply preda_lt_a ; auto.
-
-Defined.
-
-Extraction wfrec.
-Extraction Inline proj1_sig.
-Extract Inductive bool => "bool" [ "true" "false" ].
-Extract Inductive sumbool => "bool" [ "true" "false" ].
-Extract Inlined Constant lt_ge_dec => "<".
-
-Extraction wfrec.
-Extraction Inline lt_ge_dec le_lt_dec.
-Extraction wfrec.
-
-
-Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
-  match a with
-   S n => S (structrec n)
-   | 0 => 0
-   end.
-intros.
-unfold n0.
-omega.
-Defined.
-
-Print structrec.
-Extraction structrec.
-Extraction structrec.
-
-Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
-Print structrec_fun.
diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v
deleted file mode 100644
index 90ae8bae..00000000
--- a/plugins/subtac/test/take.v
+++ /dev/null
@@ -1,34 +0,0 @@
-(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
-Require Import JMeq.
-Require Import List.
-Require Import Program.
-
-Set Implicit Arguments.
-Obligations Tactic := idtac.
-
-Print cons.
-
-Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } :=
-  match n with
-  | 0 => nil
-  | S p =>
-    match l with
-    | cons hd tl => let rest := take tl p in cons hd rest
-    | nil => !
-    end
-  end.
-
-Require Import Omega.
-Solve All Obligations.
-Next Obligation.
-  destruct_call take ; program_simpl.
-Defined.
-
-Next Obligation.
-  intros.
-  inversion H.
-Defined.
-
-
-
-
diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v
deleted file mode 100644
index 5ccc154a..00000000
--- a/plugins/subtac/test/wf.v
+++ /dev/null
@@ -1,48 +0,0 @@
-Notation "( x & y )" := (@existS _ _ x y) : core_scope.
-Unset Printing All.
-Require Import Coq.Arith.Compare_dec.
-
-Require Import Coq.subtac.Utils.
-
-Ltac one_simpl_hyp :=
- match goal with
- | [H : (`exist _ _ _) = _ |- _] => simpl in H
- | [H : _ = (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) < _ |- _] => simpl in H
- | [H : _ < (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) <= _ |- _] => simpl in H
- | [H : _ <= (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) > _ |- _] => simpl in H
- | [H : _ > (`exist _ _ _) |- _] => simpl in H
- | [H : (`exist _ _ _) >= _ |- _] => simpl in H
- | [H : _ >= (`exist _ _ _) |- _] => simpl in H
- end.
-
-Ltac one_simpl_subtac :=
-  destruct_exists ;
-  repeat one_simpl_hyp ; simpl.
-
-Ltac simpl_subtac :=  do 3 one_simpl_subtac ; simpl.
-
-Require Import Omega.
-Require Import Wf_nat.
-
-Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt}  :
-  { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
-  if le_lt_dec b a then let (q', r) := euclid (a - b) b in
-  (S q' & r)
-  else (O & a).
-destruct b ; simpl_subtac.
-omega.
-simpl_subtac.
-assert(x0 * S q' = x0 + x0 * q').
-rewrite <- mult_n_Sm.
-omega.
-rewrite H2 ; omega.
-simpl_subtac.
-split ; auto with arith.
-omega.
-apply lt_wf.
-Defined.
-
-Check euclid_evars_proof.
\ No newline at end of file
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index bd2285bb..67c9dd0a 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -7,20 +7,18 @@
 (***********************************************************************)
 
 open Pp
+open Errors
 open Util
 open Names
-open Pcoq
 open Glob_term
-open Topconstr
-open Libnames
+open Globnames
 open Coqlib
-open Bigint
 
 exception Non_closed_ascii
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id)
-let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
 let ascii_module = ["Coq";"Strings";"Ascii"]
 
@@ -37,17 +35,17 @@ open Lazy
 
 let interp_ascii dloc p =
   let rec aux n p =
-     if n = 0 then [] else
+     if Int.equal n 0 then [] else
      let mp = p mod 2 in
-     GRef (dloc,if mp = 0 then glob_false else glob_true)
+     GRef (dloc,(if Int.equal mp 0 then glob_false else glob_true),None)
      :: (aux (n-1) (p/2)) in
-  GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p)
+  GApp (dloc,GRef(dloc,force glob_Ascii,None), aux 8 p)
 
 let interp_ascii_string dloc s =
   let p =
-    if String.length s = 1 then int_of_char s.[0]
+    if Int.equal (String.length s) 1 then int_of_char s.[0]
     else
-      if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+      if Int.equal (String.length s) 3 && is_digit s.[0] && is_digit s.[1] && is_digit s.[2]
       then int_of_string s
       else
 	user_err_loc (dloc,"interp_ascii_string",
@@ -56,13 +54,13 @@ let interp_ascii_string dloc s =
 
 let uninterp_ascii r =
   let rec uninterp_bool_list n = function
-    | [] when n = 0 -> 0
-    | GRef (_,k)::l when k = glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
-    | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l)
+    | [] when Int.equal n 0 -> 0
+    | GRef (_,k,_)::l when Globnames.eq_gr k glob_true  -> 1+2*(uninterp_bool_list (n-1)  l)
+    | GRef (_,k,_)::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l)
     | _ -> raise Non_closed_ascii in
   try
-    let rec aux = function
-    | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+    let aux = function
+    | GApp (_,GRef (_,k,_),l) when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l
     | _ -> raise Non_closed_ascii in
     Some (aux r)
   with
@@ -78,4 +76,4 @@ let _ =
   Notation.declare_string_interpreter "char_scope"
     (ascii_path,ascii_module)
     interp_ascii_string
-    ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
+    ([GRef (Loc.ghost,static_glob_Ascii,None)], uninterp_ascii_string, true)
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 2899f17f..0f280aad 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.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        *)
@@ -9,19 +9,11 @@
 (* This file defines the printer for natural numbers in [nat] *)
 
 (*i*)
-open Pcoq
-open Pp
-open Util
-open Names
-open Coqlib
 open Glob_term
-open Libnames
 open Bigint
 open Coqlib
-open Notation
 open Pp
-open Util
-open Names
+open Errors
 (*i*)
 
 (**********************************************************************)
@@ -33,13 +25,13 @@ let threshold = of_int 5000
 let nat_of_int dloc n =
   if is_pos_or_zero n then begin
       if less_than threshold n then
-	Flags.if_warn msg_warning
+	msg_warning
 	  (strbrk "Stack overflow or segmentation fault happens when " ++
 	   strbrk "working with large numbers in nat (observed threshold " ++
 	   strbrk "may vary from 5000 to 70000 depending on your system " ++
 	   strbrk "limits and on the command executed).");
-      let ref_O = GRef (dloc, glob_O) in
-      let ref_S = GRef (dloc, glob_S) in
+      let ref_O = GRef (dloc, glob_O, None) in
+      let ref_S = GRef (dloc, glob_S, None) in
       let rec mk_nat acc n =
 	if n <> zero then
 	  mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n)
@@ -58,8 +50,8 @@ let nat_of_int dloc n =
 exception Non_closed_number
 
 let rec int_of_nat = function
-  | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a)
-  | GRef (_,z) when z = glob_O -> zero
+  | GApp (_,GRef (_,s,_),[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a)
+  | GRef (_,z,_) when Globnames.eq_gr z glob_O -> zero
   | _ -> raise Non_closed_number
 
 let uninterp_nat p =
@@ -73,6 +65,6 @@ let uninterp_nat p =
 
 let _ =
   Notation.declare_numeral_interpreter "nat_scope"
-    (nat_path,["Coq";"Init";"Datatypes"])
+    (nat_path,datatypes_module_name)
     nat_of_int
-    ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true)
+    ([GRef (Loc.ghost,glob_S,None); GRef (Loc.ghost,glob_O,None)], uninterp_nat, true)
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index 5d43b353..b990c0d2 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.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        *)
@@ -9,18 +9,19 @@
 (* digit-based syntax for int31, bigN bigZ and bigQ *)
 
 open Bigint
-open Libnames
+open Names
+open Globnames
 open Glob_term
 
 (*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
 
-let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l))
-let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
-let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id)
-let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id
+let make_mind mp id = Names.MutInd.make2 mp (Label.make id)
+let make_mind_mpfile dir id = make_mind (MPfile (make_dir dir)) id
 let make_mind_mpdot dir modname id =
-  let mp = Names.MPdot (Names.MPfile (make_dir dir), Names.mk_label modname)
+  let mp = MPdot (MPfile (make_dir dir), Label.make modname)
   in make_mind mp id
 
 
@@ -82,9 +83,9 @@ exception Non_closed
 (* parses a *non-negative* integer (from bigint.ml) into an int31
    wraps modulo 2^31 *)
 let int31_of_pos_bigint dloc n =
-  let ref_construct = GRef (dloc, int31_construct) in
-  let ref_0 = GRef (dloc, int31_0) in
-  let ref_1 = GRef (dloc, int31_1) in
+  let ref_construct = GRef (dloc, int31_construct, None) in
+  let ref_0 = GRef (dloc, int31_0, None) in
+  let ref_1 = GRef (dloc, int31_1, None) in
   let rec args counter n =
     if counter <= 0 then
       []
@@ -95,7 +96,7 @@ let int31_of_pos_bigint dloc n =
   GApp (dloc, ref_construct, List.rev (args 31 n))
 
 let error_negative dloc =
-  Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+  Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
 
 let interp_int31 dloc n =
   if is_pos_or_zero n then
@@ -109,12 +110,12 @@ let bigint_of_int31 =
   let rec args_parsing args cur =
     match args with
       | [] -> cur
-      | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
-      | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
+      | (GRef (_,b,_))::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur)
+      | (GRef (_,b,_))::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur))
       | _ -> raise Non_closed
   in
   function
-  | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero
+  | GApp (_, GRef (_, c, _), args) when eq_gr c int31_construct -> args_parsing args zero
   | _ -> raise Non_closed
 
 let uninterp_int31 i =
@@ -127,7 +128,7 @@ let uninterp_int31 i =
 let _ = Notation.declare_numeral_interpreter int31_scope
   (int31_path, int31_module)
   interp_int31
-  ([GRef (Util.dummy_loc, int31_construct)],
+  ([GRef (Loc.ghost, int31_construct, None)],
    uninterp_int31,
    true)
 
@@ -158,16 +159,16 @@ let height bi =
 
 (* n must be a non-negative integer (from bigint.ml) *)
 let word_of_pos_bigint dloc hght n =
-  let ref_W0 = GRef (dloc, zn2z_W0) in
-  let ref_WW = GRef (dloc, zn2z_WW) in
+  let ref_W0 = GRef (dloc, zn2z_W0, None) in
+  let ref_WW = GRef (dloc, zn2z_WW, None) in
   let rec decomp hgt n =
     if hgt <= 0 then
       int31_of_pos_bigint dloc n
     else if equal n zero then
-      GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)])
+      GApp (dloc, ref_W0, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)])
     else
       let (h,l) = split_at hgt n in
-      GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole);
+      GApp (dloc, ref_WW, [GHole (dloc, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None);
 			   decomp (hgt-1) h;
 			   decomp (hgt-1) l])
   in
@@ -175,7 +176,7 @@ let word_of_pos_bigint dloc hght n =
 
 let bigN_of_pos_bigint dloc n =
   let h = height n in
-  let ref_constructor = GRef (dloc, bigN_constructor h) in
+  let ref_constructor = GRef (dloc, bigN_constructor h, None) in
   let word = word_of_pos_bigint dloc h n in
   let args =
     if h < n_inlined then [word]
@@ -184,7 +185,7 @@ let bigN_of_pos_bigint dloc n =
   GApp (dloc, ref_constructor, args)
 
 let bigN_error_negative dloc =
-  Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+  Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
 
 let interp_bigN dloc n =
   if is_pos_or_zero n then
@@ -198,14 +199,14 @@ let interp_bigN dloc n =
 let bigint_of_word =
   let rec get_height rc =
     match rc with
-    | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+    | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW ->
       1+max (get_height lft) (get_height rght)
     | _ -> 0
   in
   let rec transform hght rc =
     match rc with
-    | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero
-    | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW->
+    | GApp (_,GRef(_,c,_),_) when eq_gr c zn2z_W0-> zero
+    | GApp (_,GRef(_,c,_), [_;lft;rght]) when eq_gr c zn2z_WW->
       let new_hght = hght-1 in
       add (mult (rank new_hght)
              (transform new_hght lft))
@@ -235,7 +236,7 @@ let uninterp_bigN rc =
 let bigN_list_of_constructors =
   let rec build i =
     if i < n_inlined+1 then
-      GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1))
+      GRef (Loc.ghost, bigN_constructor i,None)::(build (i+1))
     else
       []
   in
@@ -252,8 +253,8 @@ let _ = Notation.declare_numeral_interpreter bigN_scope
 
 (*** Parsing for bigZ in digital notation ***)
 let interp_bigZ dloc n =
-  let ref_pos = GRef (dloc, bigZ_pos) in
-  let ref_neg = GRef (dloc, bigZ_neg) in
+  let ref_pos = GRef (dloc, bigZ_pos, None) in
+  let ref_neg = GRef (dloc, bigZ_neg, None) in
   if is_pos_or_zero n then
     GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
   else
@@ -261,8 +262,8 @@ let interp_bigZ dloc n =
 
 (* pretty printing functions for bigZ *)
 let bigint_of_bigZ = function
-  | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg
-  | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_neg ->
+  | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_pos -> bigint_of_bigN one_arg
+  | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigZ_neg ->
       let opp_val = bigint_of_bigN one_arg in
       if equal opp_val zero then
 	raise Non_closed
@@ -281,19 +282,19 @@ let uninterp_bigZ rc =
 let _ = Notation.declare_numeral_interpreter bigZ_scope
   (bigZ_path, bigZ_module)
   interp_bigZ
-  ([GRef (Util.dummy_loc, bigZ_pos);
-    GRef (Util.dummy_loc, bigZ_neg)],
+  ([GRef (Loc.ghost, bigZ_pos, None);
+    GRef (Loc.ghost, bigZ_neg, None)],
    uninterp_bigZ,
    true)
 
 (*** Parsing for bigQ in digital notation ***)
 let interp_bigQ dloc n =
-  let ref_z = GRef (dloc, bigQ_z) in
+  let ref_z = GRef (dloc, bigQ_z, None) in
   GApp (dloc, ref_z, [interp_bigZ dloc n])
 
 let uninterp_bigQ rc =
   try match rc with
-    | GApp (_, GRef(_,c), [one_arg]) when c = bigQ_z ->
+    | GApp (_, GRef(_,c,_), [one_arg]) when eq_gr c bigQ_z ->
 	Some (bigint_of_bigZ one_arg)
     | _ -> None (* we don't pretty-print yet fractions *)
   with Non_closed -> None
@@ -302,5 +303,5 @@ let uninterp_bigQ rc =
 let _ = Notation.declare_numeral_interpreter bigQ_scope
   (bigQ_path, bigQ_module)
   interp_bigQ
-  ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
+  ([GRef (Loc.ghost, bigQ_z, None)], uninterp_bigQ,
    true)
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 79a4d8e6..2c195755 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.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 Names
-open Pcoq
-open Topconstr
-open Libnames
+open Globnames
 
 exception Non_closed_number
 
@@ -19,18 +16,17 @@ exception Non_closed_number
 (* Parsing R via scopes                                               *)
 (**********************************************************************)
 
-open Libnames
 open Glob_term
 open Bigint
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
 let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
-let make_path dir id = Libnames.make_path dir (id_of_string id)
+let make_path dir id = Libnames.make_path dir (Id.of_string id)
 
 let r_path = make_path rdefinitions "R"
 
 (* TODO: temporary hack *)
-let make_path dir id = Libnames.encode_con dir (id_of_string id)
+let make_path dir id = Globnames.encode_con dir (Id.of_string id)
 
 let r_kn = make_path rdefinitions "R"
 let glob_R = ConstRef r_kn
@@ -46,24 +42,24 @@ let four = mult_2 two
 
 (* Unary representation of strictly positive numbers *)
 let rec small_r dloc n =
-  if equal one n then GRef (dloc, glob_R1)
-  else GApp(dloc,GRef (dloc,glob_Rplus),
-            [GRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+  if equal one n then GRef (dloc, glob_R1, None)
+  else GApp(dloc,GRef (dloc,glob_Rplus, None),
+            [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)])
 
 let r_of_posint dloc n =
-  let r1 = GRef (dloc, glob_R1) in
+  let r1 = GRef (dloc, glob_R1, None) in
   let r2 = small_r dloc two in
   let rec r_of_pos n =
     if less_than n four then small_r dloc n
     else
       let (q,r) = div2_with_rest n in
-      let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
-      if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in
-  if n <> zero then r_of_pos n else GRef(dloc,glob_R0)
+      let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in
+      if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in
+  if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None)
 
 let r_of_int dloc z =
   if is_strictly_neg z then
-    GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+    GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)])
   else
     r_of_posint dloc z
 
@@ -75,35 +71,35 @@ let bignat_of_r =
 (* for numbers > 1 *)
 let rec bignat_of_pos = function
   (* 1+1 *)
-  | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)])
-      when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
+  | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)])
+      when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two
   (* 1+(1+1) *)
-  | GApp (_,GRef (_,p1), [GRef (_,o1);
-      GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])])
-      when p1 = glob_Rplus & p2 = glob_Rplus &
-           o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
+  | GApp (_,GRef (_,p1,_), [GRef (_,o1,_);
+      GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])])
+      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus &&
+           Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three
   (* (1+1)*b *)
-  | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult ->
-      if bignat_of_pos a <> two then raise Non_closed_number;
+  | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult ->
+      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
       mult_2 (bignat_of_pos b)
   (* 1+(1+1)*b *)
-  | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])])
-      when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1  ->
-      if bignat_of_pos a <> two then raise Non_closed_number;
+  | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])])
+      when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1  ->
+      if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number;
         add_1 (mult_2 (bignat_of_pos b))
   | _ -> raise Non_closed_number
 in
 let bignat_of_r = function
-  | GRef (_,a) when a = glob_R0 -> zero
-  | GRef (_,a) when a = glob_R1 -> one
+  | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero
+  | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one
   | r -> bignat_of_pos r
 in
 bignat_of_r
 
 let bigint_of_r = function
-  | GApp (_,GRef (_,o), [a]) when o = glob_Ropp ->
+  | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp ->
       let n = bignat_of_r a in
-      if n = zero then raise Non_closed_number;
+      if Bigint.equal n zero then raise Non_closed_number;
       neg n
   | a -> bignat_of_r a
 
@@ -113,11 +109,12 @@ let uninterp_r p =
   with Non_closed_number ->
     None
 
+let mkGRef gr = GRef (Loc.ghost,gr,None)
+
 let _ = Notation.declare_numeral_interpreter "R_scope"
   (r_path,["Coq";"Reals";"Rdefinitions"])
   r_of_int
-  ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0);
-    GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult);
-    GRef(dummy_loc,glob_R1)],
+  (List.map mkGRef 
+    [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1],
     uninterp_r,
     false)
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index d670f602..2e696f39 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,12 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-open Pp
-open Util
-open Names
-open Pcoq
-open Libnames
-open Topconstr
+open Globnames
 open Ascii_syntax
 open Glob_term
 open Coqlib
@@ -37,8 +32,8 @@ open Lazy
 let interp_string dloc s =
   let le = String.length s in
   let rec aux n =
-     if n = le then GRef (dloc, force glob_EmptyString) else
-     GApp (dloc,GRef (dloc, force glob_String),
+     if n = le then GRef (dloc, force glob_EmptyString, None) else
+     GApp (dloc,GRef (dloc, force glob_String, None),
        [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
   in aux 0
 
@@ -46,11 +41,11 @@ let uninterp_string r =
   try
     let b = Buffer.create 16 in
     let rec aux = function
-    | GApp (_,GRef (_,k),[a;s]) when k = force glob_String ->
+    | GApp (_,GRef (_,k,_),[a;s]) when eq_gr k (force glob_String) ->
 	(match uninterp_ascii a with
 	  | Some c -> Buffer.add_char b (Char.chr c); aux s
 	  | _ -> raise Non_closed_string)
-    | GRef (_,z) when z = force glob_EmptyString ->
+    | GRef (_,z,_) when eq_gr z (force glob_EmptyString) ->
 	Some (Buffer.contents b)
     | _ ->
 	raise Non_closed_string
@@ -62,6 +57,6 @@ let _ =
   Notation.declare_string_interpreter "string_scope"
     (string_path,["Coq";"Strings";"String"])
     interp_string
-    ([GRef (dummy_loc,static_glob_String);
-      GRef (dummy_loc,static_glob_EmptyString)],
+    ([GRef (Loc.ghost,static_glob_String,None);
+      GRef (Loc.ghost,static_glob_EmptyString,None)],
      uninterp_string, true)
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 4025893d..e3721362 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -1,17 +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 Pcoq
 open Pp
+open Errors
 open Util
 open Names
-open Topconstr
-open Libnames
 open Bigint
 
 exception Non_closed_number
@@ -20,20 +18,20 @@ exception Non_closed_number
 (* Parsing positive via scopes                                        *)
 (**********************************************************************)
 
-open Libnames
+open Globnames
 open Glob_term
 
 let binnums = ["Coq";"Numbers";"BinNums"]
 
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id)
 
 let positive_path = make_path binnums "positive"
 
 (* TODO: temporary hack *)
-let make_kn dir id = Libnames.encode_mind dir id
+let make_kn dir id = Globnames.encode_mind dir id
 
-let positive_kn = make_kn (make_dir binnums) (id_of_string "positive")
+let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive")
 let glob_positive = IndRef (positive_kn,0)
 let path_of_xI = ((positive_kn,0),1)
 let path_of_xO = ((positive_kn,0),2)
@@ -43,13 +41,13 @@ let glob_xO = ConstructRef path_of_xO
 let glob_xH = ConstructRef path_of_xH
 
 let pos_of_bignat dloc x =
-  let ref_xI = GRef (dloc, glob_xI) in
-  let ref_xH = GRef (dloc, glob_xH) in
-  let ref_xO = GRef (dloc, glob_xO) in
+  let ref_xI = GRef (dloc, glob_xI, None) in
+  let ref_xH = GRef (dloc, glob_xH, None) in
+  let ref_xO = GRef (dloc, glob_xO, None) in
   let rec pos_of x =
     match div2_with_rest x with
       | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
-      | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q])
+      | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q])
       | (q,true) -> ref_xH
   in
   pos_of x
@@ -67,9 +65,9 @@ let interp_positive dloc n =
 (**********************************************************************)
 
 let rec bignat_of_pos = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
-  | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
-  | GRef (_, a) when a = glob_xH -> Bigint.one
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a)
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a))
+  | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one
   | _ -> raise Non_closed_number
 
 let uninterp_positive p =
@@ -85,9 +83,9 @@ let uninterp_positive p =
 let _ = Notation.declare_numeral_interpreter "positive_scope"
   (positive_path,binnums)
   interp_positive
-  ([GRef (dummy_loc, glob_xI);
-    GRef (dummy_loc, glob_xO);
-    GRef (dummy_loc, glob_xH)],
+  ([GRef (Loc.ghost, glob_xI, None);
+    GRef (Loc.ghost, glob_xO, None);
+    GRef (Loc.ghost, glob_xH, None)],
    uninterp_positive,
    true)
 
@@ -95,7 +93,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope"
 (* Parsing N via scopes                                               *)
 (**********************************************************************)
 
-let n_kn = make_kn (make_dir binnums) (id_of_string "N")
+let n_kn = make_kn (make_dir binnums) (Id.of_string "N")
 let glob_n = IndRef (n_kn,0)
 let path_of_N0 = ((n_kn,0),1)
 let path_of_Npos = ((n_kn,0),2)
@@ -105,10 +103,10 @@ let glob_Npos = ConstructRef path_of_Npos
 let n_path = make_path binnums "N"
 
 let n_of_binnat dloc pos_or_neg n =
-  if n <> zero then
-    GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+  if not (Bigint.equal n zero) then
+    GApp(dloc, GRef (dloc,glob_Npos,None), [pos_of_bignat dloc n])
   else
-    GRef (dloc, glob_N0)
+    GRef (dloc, glob_N0, None)
 
 let error_negative dloc =
   user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
@@ -122,8 +120,8 @@ let n_of_int dloc n =
 (**********************************************************************)
 
 let bignat_of_n = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
-  | GRef (_, a) when a = glob_N0 -> Bigint.zero
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a
+  | GRef (_, a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_n p =
@@ -136,8 +134,8 @@ let uninterp_n p =
 let _ = Notation.declare_numeral_interpreter "N_scope"
   (n_path,binnums)
   n_of_int
-  ([GRef (dummy_loc, glob_N0);
-    GRef (dummy_loc, glob_Npos)],
+  ([GRef (Loc.ghost, glob_N0, None);
+    GRef (Loc.ghost, glob_Npos, None)],
   uninterp_n,
   true)
 
@@ -146,7 +144,7 @@ let _ = Notation.declare_numeral_interpreter "N_scope"
 (**********************************************************************)
 
 let z_path = make_path binnums "Z"
-let z_kn = make_kn (make_dir binnums) (id_of_string "Z")
+let z_kn = make_kn (make_dir binnums) (Id.of_string "Z")
 let glob_z = IndRef (z_kn,0)
 let path_of_ZERO = ((z_kn,0),1)
 let path_of_POS = ((z_kn,0),2)
@@ -156,21 +154,21 @@ let glob_POS = ConstructRef path_of_POS
 let glob_NEG = ConstructRef path_of_NEG
 
 let z_of_int dloc n =
-  if n <> zero then
+  if not (Bigint.equal n zero) then
     let sgn, n =
       if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
-    GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n])
+    GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n])
   else
-    GRef (dloc, glob_ZERO)
+    GRef (dloc, glob_ZERO, None)
 
 (**********************************************************************)
 (* Printing Z via scopes                                              *)
 (**********************************************************************)
 
 let bigint_of_z = function
-  | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
-  | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
-  | GRef (_, a) when a = glob_ZERO -> Bigint.zero
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a
+  | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a)
+  | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero
   | _ -> raise Non_closed_number
 
 let uninterp_z p =
@@ -184,8 +182,8 @@ let uninterp_z p =
 let _ = Notation.declare_numeral_interpreter "Z_scope"
   (z_path,binnums)
   z_of_int
-  ([GRef (dummy_loc, glob_ZERO);
-    GRef (dummy_loc, glob_POS);
-    GRef (dummy_loc, glob_NEG)],
+  ([GRef (Loc.ghost, glob_ZERO, None);
+    GRef (Loc.ghost, glob_POS, None);
+    GRef (Loc.ghost, glob_NEG, None)],
   uninterp_z,
   true)
diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT
deleted file mode 100644
index c8d231fd..00000000
--- a/plugins/xml/COPYRIGHT
+++ /dev/null
@@ -1,25 +0,0 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This Coq module has been developed by Claudio Sacerdoti Coen
-<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI.
-
-Project HELM (for Hypertextual Electronic Library of Mathematics) is a
-project developed at the Department of Computer Science, University of Bologna;
-http://helm.cs.unibo.it
-
-Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces)
-is a UE IST project that generalizes and extends the HELM project;
-http://mowgli.cs.unibo.it
-
-The author is interested in any possible usage of the module.
-So, if you plan to use the module, please send him an e-mail.
-
-The licensing policy applied to the module is the same as for the whole Coq
-distribution.
diff --git a/plugins/xml/README b/plugins/xml/README
index a45dd31a..e3bcdaf0 100644
--- a/plugins/xml/README
+++ b/plugins/xml/README
@@ -1,254 +1,15 @@
-(******************************************************************************)
-(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>     *)
-(*                          Project Helm   (http://helm.cs.unibo.it)          *)
-(*                          Project MoWGLI (http://mowgli.cs.unibo.it)        *)
-(*                                                                            *)
-(*                     Coq Exportation to XML                                 *)
-(*                                                                            *)
-(******************************************************************************)
-
-This module provides commands to export a piece of Coq library in XML format.
-Only the information relevant to proof-checking and proof-rendering is exported,
-i.e. only the CIC proof objects (lambda-terms).
-
-This document is tructured in the following way:
- 1. User documentation
-   1.1. New vernacular commands available
-   1.2. New coqc/coqtop flags and suggested usage
-   1.3. How to exploit the XML files
- 2. Technical informations
-   2.1. Inner-types
-   2.2. CIC with Explicit Named Substitutions
-   2.3. The CIC with Explicit Named Substitutions XML DTD
-
-================================================================================
-                            USER DOCUMENTATION
-================================================================================
-
-=======================================
-1.1. New vernacular commands available:
-=======================================
-
-The new commands are:
-
- Print XML qualid.                 It prints in XML (to standard output) the
-                                   object whose qualified name is qualid and
-                                   its inner-types (see Sect. 2.1).
-                                   The inner-types are always printed
-                                   in their own XML file. If the object is a
-                                   constant, its type and body are also printed
-                                   as two distinct XML files.
-                                   The object printed is always the most
-                                   discharged form of the object (see
-                                   the Section command of the Coq manual).
-
- Print XML File "filename" qualid. Similar to "Print XML qualid". The generated
-                                   files are stored on the hard-disk using the
-                                   base file name "filename".
-
- Show XML Proof.                   It prints in XML the current proof in
-                                   progress. Its inner-types are also printed.
-
- Show XML File "filename" Proof.   Similar to "Show XML Proof". The generated
-                                   files are stored on the hard-disk using
-                                   the base file name "filename".
-
- The verbosity of the previous commands is raised if the configuration
- parameter verbose of xmlcommand.ml is set to true at compile time.
-
-==============================================
-1.2. New coqc/coqtop flags and suggested usage
-==============================================
-
- The following flag has been added to coqc and coqtop:
-
-  -xml     export XML files either to the hierarchy rooted in
-           the directory $COQ_XML_LIBRARY_ROOT (if the environment
-           variable is set) or to stdout (if unset)
-
- If the flag is set, every definition or declaration is immediately
- exported to XML. The XML files describe the user-provided non-discharged
- form of the definition or declaration. 
-
-
- The coq_makefile utility has also been modified to easily allow XML
- exportation:
-
-   make COQ_XML=-xml   (or, equivalently, setting the environment
-                        variable COQ_XML)
-
-
- The suggested usage of the module is the following:
-
-   1. add to your own contribution a valid Make file and use coq_makefile
-      to generate the Makefile from the Make file.
-      *WARNING:* Since logical names are used to structure the XML hierarchy,
-      always add to the Make file at least one "-R" option to map physical
-      file names to logical module paths. See the Coq manual for further
-      informations on the -R flag.
-   2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy
-      must be physically rooted.
-   3. compile your contribution with "make COQ_XML=-xml"
-
-
-=================================
-1.3. How to exploit the XML files
-=================================
-
- Once the information is exported to XML, it becomes possible to implement
- services that are completely Coq-independent. Projects HELM and MoWGLI
- already provide rendering, searching and data mining functionalities.
-
- In particular, the standard library and contributions of Coq can be
- browsed and searched on the HELM web site:
-
-                  http://helm.cs.unibo.it/library.html
-
-
- If you want to publish your own contribution so that it is included in the
- HELM library, use the MoWGLI prototype upload form:
-
-                  http://mowgli.cs.unibo.it
-
-
-================================================================================
-                            TECHNICAL INFORMATIONS
-================================================================================
-
-==========================
-2.1. Inner-types
-==========================
-
-In order to do proof-rendering (for example in natural language),
-some redundant typing information is required, i.e. the type of
-at least some of the subterms of the bodies and types. So, each
-new command described in section 1.1 print not only
-the object, but also another XML file in which you can find
-the type of all the subterms of the terms of the printed object
-which respect the following conditions:
-
- 1. It's sort is Prop or CProp (the "sort"-like definition used in
-    CoRN to type computationally relevant predicative propositions).
- 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL,
-    VAR, MUTCONSTR or CONST.
- 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA,
-    i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is
-    printed.
-
-The rationale for the 3rd condition is that the type of the inner LAMBDAs
-could be easily computed starting from the type of the outer LAMBDA; moreover,
-the types of the inner LAMBDAs requires a lot of disk/memory space: removing
-the 3rd condition leads to XML file that are two times as big as the ones
-exported appling the 3rd condition.
-
-==========================================
-2.2. CIC with Explicit Named Substitutions
-==========================================
-
-The exported files are and XML encoding of the lambda-terms used by the
-Coq system. The implementative details of the Coq system are hidden as much
-as possible, so that the XML DTD is a straightforward encoding of the  
-Calculus of (Co)Inductive Constructions.
-
-Nevertheless, there is a feature of the Coq system that can not be
-hidden in a completely satisfactory way: discharging. In Coq it is possible
-to open a section, declare variables and use them in the rest of the section
-as if they were axiom declarations. Once the section is closed, every definition
-and theorem in the section is discharged by abstracting it over the section
-variables. Variable declarations as well as section declarations are entirely
-dropped. Since we are interested in an XML encoding of definitions and
-theorems as close as possible to those directly provided the user, we
-do not want to export discharged forms. Exporting non-discharged theorem
-and definitions together with theorems that rely on the discharged forms
-obliges the tools that work on the XML encoding to implement discharging to
-achieve logical consistency. Moreover, the rendering of the files can be
-misleading, since hyperlinks can be shown between occurrences of the discharge
-form of a definition and the non-discharged definition, that are different
-objects.
-
-To overcome the previous limitations, Claudio Sacerdoti Coen developed in his
-PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions
-with Explicit Named Substitutions, that is a slight extension of CIC where
-discharging is not necessary. The DTD of the exported XML files describes
-constants, inductive types and variables of the Calculus of (Co)Inductive
-Constructions with Explicit Named Substitions. The conversion to the new
-calculus is performed during the exportation phase.
-
-The following example shows a very small Coq development together with its
-version in CIC with Explicit Named Substitutions.
-
-# CIC version: #
-Section S.
- Variable A : Prop.
-
- Definition impl := A -> A.
-
- Theorem t : impl.           (* uses the undischarged form of impl *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t' : (impl False).   (* uses the discharged form of impl *) 
- Proof.
-  exact (t False).           (* uses the discharged form of t *)
- Qed.
-
-# Corresponding CIC with Explicit Named Substitutions version: #
-Section S.
- Variable A : Prop.
-
- Definition impl(A) := A -> A.   (* theorems and definitions are
-                                    explicitly abstracted over the
-                                    variables. The name is sufficient
-                                    to completely describe the abstraction *)
-
- Theorem t(A) : impl.            (* impl where A is not instantiated *)
-  Proof.
-   exact (fun (a:A) => a).
-  Qed.
-
-End S.
-
-Theorem t'() : impl{False/A}.    (* impl where A is instantiated with False
-                                    Notice that t' does not depend on A     *) 
- Proof.
-  exact t{False/A}.              (* t where A is instantiated with False *)
- Qed.
-
-Further details on the typing and reduction rules of the calculus can be
-found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency
-of the calculus is also proved.
-
-======================================================
-2.3. The CIC with Explicit Named Substitutions XML DTD
-======================================================
-
-A copy of the DTD can be found in the file "cic.dtd".
-
-<ConstantType>     is the root element of the files that correspond to
-                   constant types.
-<ConstantBody>     is the root element of the files that correspond to
-                   constant bodies. It is used only for closed definitions and
-                   theorems (i.e. when no metavariable occurs in the body
-                   or type of the constant)
-<CurrentProof>     is the root element of the file that correspond to
-                   the body of a constant that depends on metavariables
-                   (e.g. unfinished proofs)
-<Variable>         is the root element of the files that correspond to variables
-<InductiveTypes>   is the root element of the files that correspond to blocks
-                   of mutually defined inductive definitions
-
-The elements
- <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>,
- <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX>
-are used to encode the constructors of CIC. The sort or type attribute of the
-element, if present, is respectively the sort or the type of the term, that
-is a sort because of the typing rules of CIC.
-
-The element <instantiate> correspond to the application of an explicit named
-substitution to its first argument, that is a reference to a definition
-or declaration in the environment.
-
-All the other elements are just syntactic sugar.
+The xml export plugin for Coq has been discontinued for lack of users:
+it was most certainly broken while imposing a non-negligible cost on
+Coq development. Its purpose was to give export Coq's kernel objects
+in xml form for treatment by external tools.
+
+If you are looking for such a tool, you may want to look at commit
+7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9 responsible for the deletion
+of this plugin (for instance, git checkout
+7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9^ including the "^", will lead
+you to the last commit before the xml plugin was deleted).
+
+Bear in mind, however, that the plugin was not working properly at the
+time. You may want instead to write to the original author of the
+plugin, Claudio Sacerdoti-Coen at sacerdot@cs.unibo.it. He has a
+stable version of the plugin for an old version of Coq.
diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml
deleted file mode 100644
index 653c2b7b..00000000
--- a/plugins/xml/acic.ml
+++ /dev/null
@@ -1,108 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-open Names
-open Term
-
-(* Maps fron \em{unshared} [constr] to ['a]. *)
-module CicHash =
- Hashtbl.Make
-  (struct
-    type t = Term.constr
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-type id = string  (* the type of the (annotated) node identifiers *)
-type uri = string
-
-type 'constr context_entry =
-   Decl of 'constr             (* Declaration *)
- | Def  of 'constr * 'constr   (* Definition; the second argument (the type) *)
-                               (* is not present in the DTD, but is needed   *)
-                               (* to use Coq functions during exportation.   *)
-
-type 'constr hypothesis = identifier * 'constr context_entry
-type context = constr hypothesis list
-
-type conjecture = existential_key * context * constr
-type metasenv = conjecture list
-
-(* list of couples section path -- variables defined in that section *)
-type params = (string * uri list) list
-
-type obj =
-   Constant of string *                            (* id,           *)
-    constr option * constr *                       (*  value, type, *)
-    params                                         (*  parameters   *)
- | Variable of
-    string * constr option * constr *              (* name, body, type *)
-    params                                         (*  parameters   *)
- | CurrentProof of
-    string * metasenv *                            (*  name, conjectures, *)
-    constr * constr                                (*  value, type        *)
- | InductiveDefinition of
-    inductiveType list *                           (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and inductiveType =
- identifier * bool * constr *                 (* typename, inductive, arity *)
-  constructor list                            (*  constructors              *)
-and constructor =
- identifier * constr                          (* id, type *)
-
-type aconstr =
-  | ARel       of id * int * id * identifier
-  | AVar       of id * uri
-  | AEvar      of id * existential_key * aconstr list
-  | ASort      of id * sorts
-  | ACast      of id * aconstr * aconstr
-  | AProds     of (id * name * aconstr) list * aconstr
-  | ALambdas   of (id * name * aconstr) list * aconstr
-  | ALetIns    of (id * name * aconstr) list * aconstr
-  | AApp       of id * aconstr list
-  | AConst     of id * explicit_named_substitution * uri
-  | AInd       of id * explicit_named_substitution * uri * int
-  | AConstruct of id * explicit_named_substitution * uri * int * int
-  | ACase      of id * uri * int * aconstr * aconstr * aconstr list
-  | AFix       of id * int * ainductivefun list
-  | ACoFix     of id * int * acoinductivefun list
-and ainductivefun =
- id * identifier * int * aconstr * aconstr
-and acoinductivefun =
- id * identifier * aconstr * aconstr
-and explicit_named_substitution = id option * (uri * aconstr) list
-
-type acontext = (id * aconstr hypothesis) list
-type aconjecture = id * existential_key * acontext * aconstr
-type ametasenv = aconjecture list
-
-type aobj =
-   AConstant of id * string *                      (* id,           *)
-    aconstr option * aconstr *                     (*  value, type, *)
-    params                                         (*  parameters   *)
- | AVariable of id *
-    string * aconstr option * aconstr *            (* name, body, type *)
-    params                                         (*  parameters   *)
- | ACurrentProof of id *
-    string * ametasenv *                           (*  name, conjectures, *)
-    aconstr * aconstr                              (*  value, type        *)
- | AInductiveDefinition of id *
-    anninductiveType list *                        (* inductive types ,      *)
-    params * int                                   (*  parameters,n ind. pars*)
-and anninductiveType =
- id * identifier * bool * aconstr *           (* typename, inductive, arity *)
-  annconstructor list                         (*  constructors              *)
-and annconstructor =
- identifier * aconstr                         (* id, type *)
diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
deleted file mode 100644
index 97f7e2bd..00000000
--- a/plugins/xml/acic2Xml.ml4
+++ /dev/null
@@ -1,363 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC codice cut & paste da cicPp e xmlcommand *)
-
-exception ImpossiblePossible;;
-exception NotImplemented;;
-let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";;
-let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";;
-
-let rec find_last_id =
- function
-    [] -> Util.anomaly "find_last_id: empty list"
-  | [id,_,_] -> id
-  | _::tl -> find_last_id tl
-;;
-
-let export_existential = string_of_int
-
-let print_term ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module N = Names in
-  let module X = Xml in
-    function
-       A.ARel (id,n,idref,b) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "REL"
-          ["value",(string_of_int n) ; "binder",(N.string_of_id b) ;
-           "id",id ; "idref",idref; "sort",sort]
-     | A.AVar (id,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
-     | A.AEvar (id,n,l) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "META"
-	   ["no",(export_existential n) ; "id",id ; "sort",sort]
-          (List.fold_left
-            (fun i t ->
-              [< i ; X.xml_nempty "substitution" [] (aux t) >]
-            ) [< >] (List.rev l))
-     | A.ASort (id,s) ->
-        let string_of_sort =
-         match Term.family_of_sort s with
-            Term.InProp -> "Prop"
-          | Term.InSet  -> "Set"
-          | Term.InType -> "Type"
-        in
-         X.xml_empty "SORT" ["value",string_of_sort ; "id",id]
-     | A.AProds (prods,t) ->
-        let last_id = find_last_id prods in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "PROD" ["type",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] prods ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ACast (id,v,t) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "CAST" ["id",id ; "sort",sort]
-          [< X.xml_nempty "term" [] (aux v) ;
-             X.xml_nempty "type" [] (aux t)
-          >]
-     | A.ALambdas (lambdas,t) ->
-        let last_id = find_last_id lambdas in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LAMBDA" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("type",sort)::
-                  match binder with
-                     Names.Anonymous -> []
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "decl" attrs (aux s) ; i >]
-              ) [< >] lambdas ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.ALetIns (letins,t) ->
-        let last_id = find_last_id letins in
-        let sort = Hashtbl.find ids_to_inner_sorts last_id in
-         X.xml_nempty "LETIN" ["sort",sort]
-          [< List.fold_left
-              (fun i (id,binder,s) ->
-                let sort =
-                 Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
-                in
-                 let attrs =
-                  ("id",id)::("sort",sort)::
-                  match binder with
-                     Names.Anonymous -> assert false
-                   | Names.Name b -> ["binder",Names.string_of_id b]
-                 in
-                  [< X.xml_nempty "def" attrs (aux s) ; i >]
-              ) [< >] letins ;
-             X.xml_nempty "target" [] (aux t)
-          >]
-     | A.AApp (id,li) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "APPLY" ["id",id ; "sort",sort]
-          [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li)
-          >]
-     | A.AConst (id,subst,uri) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs = ["uri", uri ; "id",id ; "sort",sort] in
-         aux_subst (X.xml_empty "CONST" attrs) subst
-     | A.AInd (id,subst,uri,i) ->
-        let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in
-         aux_subst (X.xml_empty "MUTIND" attrs) subst
-     | A.AConstruct (id,subst,uri,i,j) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-        let attrs =
-         ["uri", uri ;
-          "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
-          "id",id ; "sort",sort]
-        in
-         aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst
-     | A.ACase (id,uri,typeno,ty,te,patterns) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "MUTCASE"
-          ["uriType", uri ;
-           "noType", (string_of_int typeno) ;
-           "id", id ; "sort",sort]
-          [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
-             X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
-             List.fold_left
-              (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >])
-              [<>] patterns
-          >]
-     | A.AFix (id, no, funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "FIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ai,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "FixFunction"
-                    ["id",id ; "name", (Names.string_of_id fi) ;
-                     "recIndex", (string_of_int ai)]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
-     | A.ACoFix (id,no,funs) ->
-        let sort = Hashtbl.find ids_to_inner_sorts id in
-         X.xml_nempty "COFIX"
-          ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
-          [< List.fold_left
-              (fun i (id,fi,ti,bi) ->
-                [< i ;
-                   X.xml_nempty "CofixFunction"
-                    ["id",id ; "name", Names.string_of_id fi]
-                    [< X.xml_nempty "type" [] [< aux ti >] ;
-                       X.xml_nempty "body" [] [< aux bi >]
-                    >]
-                >]
-              ) [<>] funs
-          >]
- and aux_subst target (id,subst) =
-  if subst = [] then
-   target
-  else
-   Xml.xml_nempty "instantiate"
-    (match id with None -> [] | Some id -> ["id",id])
-    [< target ;
-       List.fold_left
-        (fun i (uri,arg) ->
-          [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >]
-        ) [<>] subst
-    >]
- in
-  aux
-;;
-
-let param_attribute_of_params params =
- List.fold_right
-  (fun (path,l) i ->
-    List.fold_right
-     (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i'
-     ) l "" ^ match i with "" -> "" | i' -> " " ^ i'
-  ) params ""
-;;
-
-let print_object uri ids_to_inner_sorts =
- let rec aux =
-  let module A = Acic in
-  let module X = Xml in
-    function
-       A.ACurrentProof (id,n,conjectures,bo,ty) ->
-        let xml_for_current_proof_body =
-(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
-(*CSC: I think so. Not implemented yet.                                       *)
-         X.xml_nempty "CurrentProof" ["of",uri ; "id", id]
-          [< List.fold_left
-              (fun i (cid,n,canonical_context,t) ->
-                [< i ;
-                   X.xml_nempty "Conjecture"
-                    ["id", cid ; "no",export_existential n]
-                    [< List.fold_left
-                        (fun i (hid,t) ->
-                          [< (match t with
-                                n,A.Decl t ->
-                                 X.xml_nempty "Decl"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                              | n,A.Def (t,_) ->
-                                 X.xml_nempty "Def"
-                                  ["id",hid;"name",Names.string_of_id n]
-                                  (print_term ids_to_inner_sorts t)
-                             ) ;
-                             i
-                          >]
-                        ) [< >] canonical_context ;
-                       X.xml_nempty "Goal" []
-                        (print_term ids_to_inner_sorts t)
-                    >]
-                >])
-              [<>] (List.rev conjectures) ;
-             X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
-        in
-        let xml_for_current_proof_type =
-         X.xml_nempty "ConstantType" ["name",n ; "id", id]
-          (print_term ids_to_inner_sorts ty)
-        in
-        let xmlbo =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n");
-            xml_for_current_proof_body
-         >] in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata
-             ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n");
-            xml_for_current_proof_type
-         >]
-        in
-         xmlty, Some xmlbo
-     | A.AConstant (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-        let xmlbo =
-         match bo with
-            None -> None
-          | Some bo ->
-             Some
-              [< X.xml_cdata
-                  "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-                 X.xml_cdata
-                  ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
-                 X.xml_nempty "ConstantBody"
-                  ["for",uri ; "params",params' ; "id", id]
-                  [< print_term ids_to_inner_sorts bo >]
-              >]
-        in
-        let xmlty =
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n");
-             X.xml_nempty "ConstantType"
-              ["name",n ; "params",params' ; "id", id]
-              [< print_term ids_to_inner_sorts ty >]
-         >]
-        in
-         xmlty, xmlbo
-     | A.AVariable (id,n,bo,ty,params) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ;
-            X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id]
-             [< (match bo with
-                    None -> [<>]
-                  | Some bo ->
-                     X.xml_nempty "body" []
-                      (print_term ids_to_inner_sorts bo)
-                ) ;
-                X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
-             >]
-         >], None
-     | A.AInductiveDefinition (id,tys,params,nparams) ->
-        let params' = param_attribute_of_params params in
-         [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-            X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
-             dtdname ^ "\">\n") ;
-            X.xml_nempty "InductiveDefinition"
-             ["noParams",string_of_int nparams ;
-              "id",id ;
-              "params",params']
-             [< (List.fold_left
-                  (fun i (id,typename,finite,arity,cons) ->
-                    [< i ;
-                       X.xml_nempty "InductiveType"
-                        ["id",id ; "name",Names.string_of_id typename ;
-                         "inductive",(string_of_bool finite)
-                        ]
-                        [< X.xml_nempty "arity" []
-                            (print_term ids_to_inner_sorts arity) ;
-                           (List.fold_left
-                            (fun i (name,lc) ->
-                              [< i ;
-                                 X.xml_nempty "Constructor"
-                                  ["name",Names.string_of_id name]
-                                  (print_term ids_to_inner_sorts lc)
-                              >]) [<>] cons
-                           )
-                        >]
-                    >]
-                  ) [< >] tys
-                )
-             >]
-         >], None
- in
-  aux
-;;
-
-let print_inner_types curi ids_to_inner_sorts ids_to_inner_types =
- let module C2A = Cic2acic in
- let module X = Xml in
-  [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-     X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n");
-      X.xml_nempty "InnerTypes" ["of",curi]
-       (Hashtbl.fold
-         (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
-           [< x ;
-              X.xml_nempty "TYPE" ["of",id]
-               [< X.xml_nempty "synthesized" []
-                   (print_term ids_to_inner_sorts synty) ;
-                  match expty with
-                     None -> [<>]
-                   | Some expty' ->
-                      X.xml_nempty "expected" []
-                       (print_term ids_to_inner_sorts expty')
-               >]
-           >]
-         ) ids_to_inner_types [<>]
-       )
-  >]
-;;
diff --git a/plugins/xml/cic.dtd b/plugins/xml/cic.dtd
deleted file mode 100644
index c8035cab..00000000
--- a/plugins/xml/cic.dtd
+++ /dev/null
@@ -1,259 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM is distributed in the hope that it will be useful,           -->
-<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of    -->
-<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     -->
-<!-- GNU General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-<!-- DTD FOR CIC OBJECTS: -->
-
-<!-- CIC term declaration -->
-
-<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST|
-                  LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'>
-
-<!-- CIC sorts -->
-
-<!ENTITY % sort '(Prop|Set|Type|CProp)'>
-
-<!-- CIC sequents -->
-
-<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
-
-<!-- CIC objects: -->
-
-<!ELEMENT ConstantType %term;>
-<!ATTLIST ConstantType
-          name       CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT ConstantBody %term;>
-<!ATTLIST ConstantBody
-          for        CDATA      #REQUIRED
-          params     CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT CurrentProof (Conjecture*,body)>
-<!ATTLIST CurrentProof
-          of         CDATA      #REQUIRED
-          id         ID         #REQUIRED>
-
-<!ELEMENT InductiveDefinition (InductiveType+)>
-<!ATTLIST InductiveDefinition
-          noParams NMTOKEN #REQUIRED
-          params   CDATA   #REQUIRED
-          id       ID      #REQUIRED>
-
-<!ELEMENT Variable (body?,type)>
-<!ATTLIST Variable
-          name   CDATA #REQUIRED
-          params CDATA #REQUIRED
-          id     ID    #REQUIRED>
-
-<!ELEMENT Sequent %sequent;>
-<!ATTLIST Sequent
-          no  NMTOKEN #REQUIRED
-          id  ID      #REQUIRED>
-
-<!-- Elements used in CIC objects, which are not terms: -->
-
-<!ELEMENT InductiveType (arity,Constructor*)>
-<!ATTLIST InductiveType
-          name      CDATA        #REQUIRED
-          inductive (true|false) #REQUIRED
-          id        ID           #REQUIRED>
-
-<!ELEMENT Conjecture %sequent;>
-<!ATTLIST Conjecture
-          no NMTOKEN #REQUIRED
-          id ID      #REQUIRED>
-
-<!ELEMENT Constructor %term;>
-<!ATTLIST Constructor
-          name CDATA #REQUIRED>
-
-<!ELEMENT Decl %term;>
-<!ATTLIST Decl
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Def %term;>
-<!ATTLIST Def
-          name CDATA #IMPLIED
-          id   ID    #REQUIRED>
-
-<!ELEMENT Hidden EMPTY>
-<!ATTLIST Hidden
-          id ID #REQUIRED>
-
-<!ELEMENT Goal %term;>
-
-<!-- CIC terms: -->
-
-<!ELEMENT LAMBDA (decl*,target)>
-<!ATTLIST LAMBDA
-          sort %sort; #REQUIRED>
-
-<!ELEMENT LETIN (def*,target)>
-<!ATTLIST LETIN
-          sort %sort; #REQUIRED>
-
-<!ELEMENT PROD (decl*,target)>
-<!ATTLIST PROD
-          type %sort; #REQUIRED>
-
-<!ELEMENT CAST (term,type)>
-<!ATTLIST CAST
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT REL EMPTY>
-<!ATTLIST REL
-          value  NMTOKEN #REQUIRED
-          binder CDATA   #REQUIRED
-          id     ID      #REQUIRED
-          idref  IDREF   #REQUIRED
-          sort   %sort;  #REQUIRED>
-
-<!ELEMENT SORT EMPTY>
-<!ATTLIST SORT
-          value CDATA #REQUIRED
-          id    ID    #REQUIRED>
-
-<!ELEMENT APPLY (%term;)+>
-<!ATTLIST APPLY
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT VAR EMPTY>
-<!ATTLIST VAR
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!-- The substitutions are ordered by increasing DeBrujin  -->
-<!-- index. An empty substitution means that that index is -->
-<!-- not accessible.                                       -->
-<!ELEMENT META (substitution*)>
-<!ATTLIST META
-          no              NMTOKEN #REQUIRED
-          id              ID      #REQUIRED
-          sort            %sort;  #REQUIRED>
-
-<!ELEMENT IMPLICIT EMPTY>
-<!ATTLIST IMPLICIT
-          id ID #REQUIRED>
-
-<!ELEMENT CONST EMPTY>
-<!ATTLIST CONST
-          uri  CDATA  #REQUIRED
-          id   ID     #REQUIRED
-          sort %sort; #REQUIRED>
-
-<!ELEMENT MUTIND EMPTY>
-<!ATTLIST MUTIND
-          uri    CDATA   #REQUIRED
-          noType NMTOKEN #REQUIRED
-          id     ID      #REQUIRED>
-
-<!ELEMENT MUTCONSTRUCT EMPTY>
-<!ATTLIST MUTCONSTRUCT
-          uri      CDATA   #REQUIRED
-          noType   NMTOKEN #REQUIRED
-          noConstr NMTOKEN #REQUIRED
-          id       ID      #REQUIRED
-          sort     %sort;  #REQUIRED>
-
-<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)>
-<!ATTLIST MUTCASE
-          uriType CDATA   #REQUIRED
-          noType  NMTOKEN #REQUIRED
-          id      ID      #REQUIRED
-          sort    %sort;  #REQUIRED>
-
-<!ELEMENT FIX (FixFunction+)>
-<!ATTLIST FIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!ELEMENT COFIX (CofixFunction+)>
-<!ATTLIST COFIX
-          noFun NMTOKEN #REQUIRED
-          id    ID      #REQUIRED
-          sort  %sort;  #REQUIRED>
-
-<!-- Elements used in CIC terms: -->
-
-<!ELEMENT FixFunction (type,body)>
-<!ATTLIST FixFunction
-          name     CDATA   #REQUIRED
-          id       ID      #REQUIRED
-          recIndex NMTOKEN #REQUIRED>
-
-<!ELEMENT CofixFunction (type,body)>
-<!ATTLIST CofixFunction
-          id       ID      #REQUIRED
-          name     CDATA   #REQUIRED>
-
-<!ELEMENT substitution ((%term;)?)>
-
-<!-- Explicit named substitutions: -->
-
-<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)>
-<!ATTLIST instantiate
-          id ID #IMPLIED>
-
-<!-- Sintactic sugar for CIC terms and for CIC objects: -->
-
-<!ELEMENT arg %term;>
-<!ATTLIST arg
-          relUri CDATA #REQUIRED>
-
-<!ELEMENT decl %term;>
-<!ATTLIST decl
-          id     ID     #REQUIRED
-          type   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-          
-<!ELEMENT def %term;>
-<!ATTLIST def
-          id     ID     #REQUIRED
-          sort   %sort; #REQUIRED
-          binder CDATA  #IMPLIED>
-
-<!ELEMENT target %term;>
-
-<!ELEMENT term %term;>
-
-<!ELEMENT type  %term;>
-
-<!ELEMENT arity %term;>
-
-<!ELEMENT patternsType  %term;>
-
-<!ELEMENT inductiveTerm  %term;>
-
-<!ELEMENT pattern  %term;>
-
-<!ELEMENT body  %term;>
diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml
deleted file mode 100644
index 981503a6..00000000
--- a/plugins/xml/cic2Xml.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-let print_xml_term ch env sigma cic =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let seed = ref 0 in
-  let acic =
-   Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids
-    ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
-    env [] sigma (Unshare.unshare cic) None in
-  let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
-  Xml.pp_ch xml ch
-;;
-
-Tacinterp.declare_xml_printer print_xml_term
-;;
diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
deleted file mode 100644
index 165bf83d..00000000
--- a/plugins/xml/cic2acic.ml
+++ /dev/null
@@ -1,942 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Utility Functions *)
-
-exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
-let get_module_path_of_full_path path =
- let dirpath = fst (Libnames.repr_path path) in
- let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
-  match
-   List.filter
-    (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
-  with
-     [] ->
-       Pp.msg_warn ("Modules not supported: reference to "^
-         Libnames.string_of_path path^" will be wrong");
-       dirpath
-   | [modul] -> modul
-   | _ ->
-       raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
-;;
-
-(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *)
-(*CSC: not exist two modules whose dir_paths are one a prefix of the other *)
-let remove_module_dirpath_from_dirpath ~basedir dir =
- let module Ln = Libnames in
-  if Ln.is_dirpath_prefix_of basedir dir then
-   let ids = Names.repr_dirpath dir in
-   let rec remove_firsts n l =
-    match n,l with
-       (0,l) -> l
-     | (n,he::tl) -> remove_firsts (n-1) tl
-     | _ -> assert false
-   in
-    let ids' =
-     List.rev
-      (remove_firsts
-        (List.length (Names.repr_dirpath basedir))
-        (List.rev ids))
-    in
-     ids'
-  else Names.repr_dirpath dir
-;;
-
-
-let get_uri_of_var v pvars =
- let module D = Decls in
- let module N = Names in
-  let rec search_in_open_sections =
-   function
-      [] -> Util.error ("Variable "^v^" not found")
-    | he::tl as modules ->
-       let dirpath = N.make_dirpath modules in
-        if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then
-         modules
-        else
-         search_in_open_sections tl
-  in
-   let path =
-    if List.mem v pvars then
-      []
-    else
-      search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
-   in
-    "cic:" ^
-     List.fold_left
-      (fun i x -> "/" ^ N.string_of_id x ^ i) "" path
-;;
-
-type tag =
-   Constant of Names.constant
- | Inductive of Names.mutual_inductive
- | Variable of Names.kernel_name
-;;
-
-type etag =
-   TConstant
- | TInductive
- | TVariable
-;;
-
-let etag_of_tag =
- function
-    Constant _ -> TConstant
-  | Inductive _ -> TInductive
-  | Variable _ -> TVariable
-
-let ext_of_tag =
- function
-    TConstant -> "con"
-  | TInductive -> "ind"
-  | TVariable -> "var"
-;;
-
-exception FunctorsXMLExportationNotImplementedYet;;
-
-let subtract l1 l2 =
- let l1' = List.rev (Names.repr_dirpath l1) in
- let l2' = List.rev (Names.repr_dirpath l2) in
-  let rec aux =
-   function
-      he::tl when tl = l2' -> [he]
-    | he::tl -> he::(aux tl)
-    | [] -> assert (l2' = []) ; []
-  in
-   Names.make_dirpath (List.rev (aux l1'))
-;;
-
-let token_list_of_path dir id tag =
- let module N = Names in
-  let token_list_of_dirpath dirpath =
-   List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
-  token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)]
-
-let token_list_of_kernel_name tag =
- let module N = Names in
- let module LN = Libnames in
- let id,dir = match tag with
-   | Variable kn ->
-       N.id_of_label (N.label kn), Lib.cwd ()
-   | Constant con ->
-       N.id_of_label (N.con_label con),
-       Lib.remove_section_part (LN.ConstRef con)
-   | Inductive kn ->
-       N.id_of_label (N.mind_label kn),
-       Lib.remove_section_part (LN.IndRef (kn,0))
- in
- token_list_of_path dir id (etag_of_tag tag)
-;;
-
-let uri_of_kernel_name tag =
-  let tokens = token_list_of_kernel_name tag in
-   "cic:/" ^ String.concat "/" tokens
-
-let uri_of_declaration id tag =
- let module LN = Libnames in
- let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in
- let tokens = token_list_of_path dir id tag in
-  "cic:/" ^ String.concat "/" tokens
-
-(* Special functions for handling of CCorn's CProp "sort" *)
-
-type sort =
-   Coq_sort of Term.sorts_family
- | CProp
-;;
-
-let prerr_endline _ = ();;
-
-let family_of_term ty =
- match Term.kind_of_term ty with
-    Term.Sort s -> Coq_sort (Term.family_of_sort s)
-  | Term.Const _ -> CProp  (* I could check that the constant is CProp *)
-  | _ -> Util.anomaly "family_of_term"
-;;
-
-module CPropRetyping =
- struct
-  module T = Term
-
-  let outsort env sigma t =
-   family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t)
-
-  let rec subst_type env sigma typ = function
-  | [] -> typ
-  | h::rest ->
-      match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with
-        | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
-        | _ -> Util.anomaly "Non-functional construction"
-
-
-  let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar =
-    match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
-      | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b
-      | T.Sort s -> Coq_sort (T.family_of_sort s)
-      | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
-  in concl_of_arity env ft
-
-let typeur sigma metamap =
-  let rec type_of env cstr=
-    match Term.kind_of_term cstr with
-    | T.Meta n ->
-          (try T.strip_outer_cast (List.assoc n metamap)
-           with Not_found -> Util.anomaly "type_of: this is not a well-typed term")
-    | T.Rel n ->
-        let (_,_,ty) = Environ.lookup_rel n env in
-        T.lift n ty
-    | T.Var id ->
-        (try
-          let (_,_,ty) = Environ.lookup_named id env in
-          ty
-        with Not_found ->
-          Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
-    | T.Const c ->
-        let cb = Environ.lookup_constant c env in
-        Typeops.type_of_constant_type env (cb.Declarations.const_type)
-    | T.Evar ev -> Evd.existential_type sigma ev
-    | T.Ind ind -> Inductiveops.type_of_inductive env ind
-    | T.Construct cstr -> Inductiveops.type_of_constructor env cstr
-    | T.Case (_,p,c,lf) ->
-        let Inductiveops.IndType(_,realargs) =
-          try Inductiveops.find_rectype env sigma (type_of env c)
-          with Not_found -> Util.anomaly "type_of: Bad recursive type" in
-        let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in
-        (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with
-          | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c]))
-          | _ -> t)
-    | T.Lambda (name,c1,c2) ->
-          T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2)
-    | T.LetIn (name,b,c1,c2) ->
-         T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2)
-    | T.Fix ((_,i),(_,tys,_)) -> tys.(i)
-    | T.CoFix (i,(_,tys,_)) -> tys.(i)
-    | T.App(f,args)->
-        T.strip_outer_cast
-          (subst_type env sigma (type_of env f) (Array.to_list args))
-    | T.Cast (c,_, t) -> t
-    | T.Sort _ | T.Prod _ ->
-       match sort_of env cstr with
-          Coq_sort T.InProp -> T.mkProp
-        | Coq_sort T.InSet -> T.mkSet
-        | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
-        | CProp -> T.mkConst DoubleTypeInference.cprop
-
-  and sort_of env t =
-    match Term.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) ->
-       (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with
-          | _, (Coq_sort T.InProp as s) -> s
-          | Coq_sort T.InProp, (Coq_sort T.InSet as s)
-          | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s
-          | Coq_sort T.InType, (Coq_sort T.InSet as s)
-          | CProp, (Coq_sort T.InSet as s) when
-              Environ.engagement env = Some Declarations.ImpredicativeSet -> s
-          | Coq_sort T.InType, Coq_sort T.InSet
-          | CProp, Coq_sort T.InSet -> Coq_sort T.InType
-          | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*)
-          | _, (CProp as s) -> s)
-    | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-
-  and sort_family_of env t =
-    match T.kind_of_term t with
-    | T.Cast (c,_, s) when T.isSort s -> family_of_term s
-    | T.Sort (T.Prop c) -> Coq_sort T.InType
-    | T.Sort (T.Type u) -> Coq_sort T.InType
-    | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2
-    | T.App(f,args) ->
-       sort_of_atomic_type env sigma (type_of env f) args
-    | T.Lambda _ | T.Fix _ | T.Construct _ ->
-        Util.anomaly "sort_of: Not a type (1)"
-    | _ -> outsort env sigma (type_of env t)
-
-  in type_of, sort_of, sort_family_of
-
-  let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
-  let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
-
- end
-;;
-
-let get_sort_family_of env evar_map ty =
- CPropRetyping.get_sort_family_of env evar_map ty
-;;
-
-let type_as_sort env evar_map ty =
-(* CCorn code *)
- family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty)
-;;
-
-let is_a_Prop =
- function
-    "Prop"
-  | "CProp" -> true
-  | _ -> false
-;;
-
-(* Main Functions *)
-
-type anntypes =
- {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option}
-;;
-
-let gen_id seed =
- let res = "i" ^ string_of_int !seed in
-  incr seed ;
-  res
-;;
-
-let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids =
- fun father t ->
-  let res = gen_id seed in
-   Hashtbl.add ids_to_father_ids res father ;
-   Hashtbl.add ids_to_terms res t ;
-   Acic.CicHash.add constr_to_ids t res ;
-   res
-;;
-
-let source_id_of_id id = "#source#" ^ id;;
-
-let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
- ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
- ?(fake_dependent_products=false) env idrefs evar_map t expectedty
-=
- let module D = DoubleTypeInference in
- let module E = Environ in
- let module N = Names in
- let module A = Acic in
- let module T = Term in
-  let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in
-   (* CSC: do you have any reasonable substitute for 503? *)
-   let terms_to_types = Acic.CicHash.create 503 in
-    D.double_type_of env evar_map t expectedty terms_to_types ;
-    let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env
-     idrefs ?(subst=None,[]) tt
-    =
-     let fresh_id'' = fresh_id' father tt in
-     let aux' = aux computeinnertypes (Some fresh_id'') [] in
-      let string_of_sort_family =
-       function
-          Coq_sort T.InProp -> "Prop"
-        | Coq_sort T.InSet  -> "Set"
-        | Coq_sort T.InType -> "Type"
-        | CProp -> "CProp"
-      in
-      let string_of_sort t =
-       string_of_sort_family
-        (type_as_sort env evar_map t)
-      in
-       let ainnertypes,innertype,innersort,expected_available =
-        let {D.synthesized = synthesized; D.expected = expected} =
-         if computeinnertypes then
-try
-          Acic.CicHash.find terms_to_types tt
-with e when e <> Sys.Break ->
-(*CSC: Warning: it really happens, for example in Ring_theory!!! *)
-Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
-         else
-          (* We are already in an inner-type and Coscoy's double *)
-          (* type inference algorithm has not been applied.      *)
-          (* We need to refresh the universes because we are doing *)
-          (* type inference on an already inferred type.           *)
-          {D.synthesized =
-            Reductionops.nf_beta evar_map
-             (CPropRetyping.get_type_of env evar_map
-              (Termops.refresh_universes tt)) ;
-           D.expected = None}
-        in
-(* Debugging only:
-print_endline "TERMINE:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ;
-print_endline "TIPO:" ; flush stdout ;
-Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ;
-print_endline "ENVIRONMENT:" ; flush stdout ;
-Pp.ppnl (Printer.pr_context_of env) ; flush stdout ;
-print_endline "FINE_ENVIRONMENT" ; flush stdout ;
-*)
-         let innersort =
-          let synthesized_innersort =
-           get_sort_family_of env evar_map synthesized
-          in
-           match expected with
-              None -> synthesized_innersort
-            | Some ty ->
-              let expected_innersort =
-               get_sort_family_of env evar_map ty
-              in
-               match expected_innersort, synthesized_innersort with
-                  CProp, _
-                | _, CProp -> CProp
-                | _, _ -> expected_innersort
-         in
-(* Debugging only:
-print_endline "PASSATO" ; flush stdout ;
-*)
-          let ainnertypes,expected_available =
-           if computeinnertypes then
-            let annexpected,expected_available =
-               match expected with
-                  None -> None,false
-                | Some expectedty' ->
-                   Some (aux false (Some fresh_id'') [] env idrefs expectedty'),
-                    true
-            in
-             Some
-              {annsynthesized =
-                aux false (Some fresh_id'') [] env idrefs synthesized ;
-               annexpected = annexpected
-              }, expected_available
-           else
-            None,false
-          in
-           ainnertypes,synthesized, string_of_sort_family innersort,
-            expected_available
-       in
-        let add_inner_type id =
-         match ainnertypes with
-            None -> ()
-          | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes
-        in
-
-         (* explicit_substitute_and_eta_expand_if_required h t t'         *)
-         (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit   *)
-         (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = [])  *)
-         (* check if [h] is a term that requires an explicit named        *)
-         (* substitution and, in that case, uses the first arguments of   *)
-         (* [t] as the actual arguments of the substitution. If there     *)
-         (* are not enough parameters in the list [t], then eta-expansion *)
-         (* is performed.                                                 *)
-         let
-          explicit_substitute_and_eta_expand_if_required h t t'
-           compute_result_if_eta_expansion_not_required
-         =
-          let subst,residual_args,uninst_vars =
-           let variables,basedir =
-             try
-               let g = Libnames.global_of_constr h in
-               let sp =
-                match g with
-                   Libnames.ConstructRef ((induri,_),_)
-                 | Libnames.IndRef (induri,_) ->
-                    Nametab.path_of_global (Libnames.IndRef (induri,0))
-                 | Libnames.VarRef id ->
-                    (* Invariant: variables are never cooked in Coq *)
-                    raise Not_found
-                 | _ -> Nametab.path_of_global g
-               in
-               Dischargedhypsmap.get_discharged_hyps sp,
-               get_module_path_of_full_path sp
-             with Not_found ->
-                (* no explicit substitution *)
-                [], Libnames.dirpath_of_string "dummy"
-           in
-           (* returns a triple whose first element is  *)
-           (* an explicit named substitution of "type" *)
-           (* (variable * argument) list, whose        *)
-           (* second element is the list of residual   *)
-           (* arguments and whose third argument is    *)
-           (* the list of uninstantiated variables     *)
-           let rec get_explicit_subst variables arguments =
-            match variables,arguments with
-               [],_ -> [],arguments,[]
-             | _,[] -> [],[],variables
-             | he1::tl1,he2::tl2 ->
-                let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in
-                let (he1_sp, he1_id) = Libnames.repr_path he1 in
-                let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in
-                let he1'' =
-                 String.concat "/"
-                  (List.map Names.string_of_id (List.rev he1')) ^ "/"
-                 ^ (Names.string_of_id he1_id) ^ ".var"
-                in
-                 (he1'',he2)::subst, extra_args, uninst
-           in
-            get_explicit_subst variables t'
-          in
-           let uninst_vars_length = List.length uninst_vars in
-            if uninst_vars_length > 0 then
-             (* Not enough arguments provided. We must eta-expand! *)
-             let un_args,_ =
-              T.decompose_prod_n uninst_vars_length
-               (CPropRetyping.get_type_of env evar_map tt)
-             in
-              let eta_expanded =
-               let arguments =
-                List.map (T.lift uninst_vars_length) t @
-                 Termops.rel_list 0 uninst_vars_length
-               in
-                Unshare.unshare
-                 (T.lamn uninst_vars_length un_args
-                  (T.applistc h arguments))
-              in
-               D.double_type_of env evar_map eta_expanded
-                None terms_to_types ;
-               Hashtbl.remove ids_to_inner_types fresh_id'' ;
-               aux' env idrefs eta_expanded
-            else
-             compute_result_if_eta_expansion_not_required subst residual_args
-         in
-
-          (* Now that we have all the auxiliary functions we  *)
-          (* can finally proceed with the main case analysis. *)
-          match T.kind_of_term tt with
-             T.Rel n ->
-              let id =
-               match List.nth (E.rel_context env) (n - 1) with
-                  (N.Name id,_,_)   -> id
-                | (N.Anonymous,_,_) -> Nameops.make_ident "_" None
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.ARel (fresh_id'', n, List.nth idrefs (n-1), id)
-           | T.Var id ->
-	      let pvars = Termops.ids_of_named_context (E.named_context env) in
-	      let pvars = List.map N.string_of_id pvars in
-              let path = get_uri_of_var (N.string_of_id id) pvars in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               if is_a_Prop innersort  && expected_available then
-                add_inner_type fresh_id'' ;
-               A.AVar
-                (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var")
-           | T.Evar (n,l) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              A.AEvar
-               (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l))
-           | T.Meta _ -> Util.anomaly "Meta met during exporting to XML"
-           | T.Sort s -> A.ASort (fresh_id'', s)
-           | T.Cast (v,_, t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t)
-           | T.Prod (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  if not fake_dependent_products && T.noccurn 1 t then
-                   N.Anonymous
-                  else
-                   N.Name
-                    (Namegen.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id''
-                (string_of_sort innertype) ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let new_passed_prods =
-                let father_is_prod =
-                 match father with
-                    None -> false
-                  | Some father' ->
-                     match
-                      Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                     with
-                        T.Prod _ -> true
-                      | _ -> false
-                in
-                 (fresh_id'', n', aux' env idrefs s)::
-                  (if father_is_prod then
-                    passed_lambdas_or_prods_or_letins
-                   else [])
-               in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Prod _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_prods
-                       new_env new_idrefs t
-                   | _ ->
-                     A.AProds (new_passed_prods, aux' new_env new_idrefs t))
-           | T.Lambda (n,s,t) ->
-              let n' =
-               match n with
-                  N.Anonymous -> N.Anonymous
-                | _ ->
-                  N.Name (Namegen.next_name_away n (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcetype = CPropRetyping.get_type_of env evar_map s in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort sourcetype) ;
-               let father_is_lambda =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.Lambda _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort &&
-                   ((not father_is_lambda) || expected_available)
-                then add_inner_type fresh_id'' ;
-                let new_passed_lambdas =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_lambda then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', None, s) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term t with
-                     T.Lambda _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_lambdas
-                       new_env new_idrefs t
-                   | _ ->
-                     let t' = aux' new_env new_idrefs t in
-                      (* eta-expansion for explicit named substitutions *)
-                      (* can create nested Lambdas. Here we perform the *)
-                      (* flattening.                                    *)
-                      match t' with
-                         A.ALambdas (lambdas, t'') ->
-                          A.ALambdas (lambdas@new_passed_lambdas, t'')
-                       | _ ->
-                         A.ALambdas (new_passed_lambdas, t')
-                 )
-           | T.LetIn (n,s,t,d) ->
-              let id =
-               match n with
-                   N.Anonymous -> N.id_of_string "_X"
-                 | N.Name id -> id
-              in
-              let n' =
-               N.Name (Namegen.next_ident_away id (Termops.ids_of_context env))
-              in
-               Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-               let sourcesort =
-                get_sort_family_of env evar_map
-                 (CPropRetyping.get_type_of env evar_map s)
-               in
-                Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
-                 (string_of_sort_family sourcesort) ;
-               let father_is_letin =
-                match father with
-                   None -> false
-                 | Some father' ->
-                    match
-                     Term.kind_of_term (Hashtbl.find ids_to_terms father')
-                    with
-                       T.LetIn _ -> true
-                     | _ -> false
-               in
-                if is_a_Prop innersort then
-                 add_inner_type fresh_id'' ;
-                let new_passed_letins =
-                 (fresh_id'',n', aux' env idrefs s)::
-                  (if father_is_letin then
-                    passed_lambdas_or_prods_or_letins
-                   else []) in
-                let new_env = E.push_rel (n', Some s, t) env in
-                let new_idrefs = fresh_id''::idrefs in
-                 (match Term.kind_of_term d with
-                     T.LetIn _ ->
-                      aux computeinnertypes (Some fresh_id'') new_passed_letins
-                       new_env new_idrefs d
-                   | _ -> A.ALetIns
-                           (new_passed_letins, aux' new_env new_idrefs d))
-           | T.App (h,t) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let
-               compute_result_if_eta_expansion_not_required subst residual_args
-              =
-               let residual_args_not_empty = residual_args <> [] in
-               let h' =
-                if residual_args_not_empty then
-                 aux' env idrefs ~subst:(None,subst) h
-                else
-                 aux' env idrefs ~subst:(Some fresh_id'',subst) h
-               in
-                (* maybe all the arguments were used for the explicit *)
-                (* named substitution                                 *)
-                if residual_args_not_empty then
-                 A.AApp (fresh_id'', h'::residual_args)
-                else
-                 h'
-              in
-               let t' =
-                Array.fold_right (fun x i -> (aux' env idrefs x)::i) t []
-               in
-                explicit_substitute_and_eta_expand_if_required h
-                 (Array.to_list t) t'
-                 compute_result_if_eta_expansion_not_required
-           | T.Const kn ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn)))
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Ind (kn,i) ->
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Construct ((kn,i),j) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort  && expected_available then
-               add_inner_type fresh_id'' ;
-              let compute_result_if_eta_expansion_not_required _ _ =
-               A.AConstruct
-                (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j)
-              in
-               let (_,subst') = subst in
-                explicit_substitute_and_eta_expand_if_required tt []
-                 (List.map snd subst')
-                 compute_result_if_eta_expansion_not_required
-           | T.Case ({T.ci_ind=(kn,i)},ty,term,a) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then
-               add_inner_type fresh_id'' ;
-              let a' =
-               Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
-              in
-               A.ACase
-                (fresh_id'', (uri_of_kernel_name (Inductive kn)), i,
-                  aux' env idrefs ty, aux' env idrefs term, a')
-           | T.Fix ((ai,i),(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Namegen.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.AFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi,ai) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi', ai,
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                   (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f'
-                  ) []
-                 )
-           | T.CoFix (i,(f,t,b)) ->
-              Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
-              if is_a_Prop innersort then add_inner_type fresh_id'' ;
-              let fresh_idrefs =
-               Array.init (Array.length t) (function _ -> gen_id seed) in
-              let new_idrefs =
-               (List.rev (Array.to_list fresh_idrefs)) @ idrefs
-              in
-               let f' =
-                let ids = ref (Termops.ids_of_context env) in
-                 Array.map
-                  (function
-                      N.Anonymous -> Util.error "Anonymous fix function met"
-                    | N.Name id as n ->
-                       let res = N.Name (Namegen.next_name_away n !ids) in
-                        ids := id::!ids ;
-                        res
-                 ) f
-               in
-                A.ACoFix (fresh_id'', i,
-                 Array.fold_right
-                  (fun (id,fi,ti,bi) i ->
-                    let fi' =
-                     match fi with
-                        N.Name fi -> fi
-                      | N.Anonymous -> Util.error "Anonymous fix function met"
-                    in
-                     (id, fi',
-                      aux' env idrefs ti,
-                      aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
-                  (Array.mapi
-                    (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f'
-                  ) []
-                 )
-    in
-     aux computeinnertypes None [] env idrefs t
-;;
-
-(* Obsolete [HH 1/2009]
-let acic_of_cic_context metasenv context t =
- let ids_to_terms = Hashtbl.create 503 in
- let constr_to_ids = Acic.CicHash.create 503 in
- let ids_to_father_ids = Hashtbl.create 503 in
- let ids_to_inner_sorts = Hashtbl.create 503 in
- let ids_to_inner_types = Hashtbl.create 503 in
- let seed = ref 0 in
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types metasenv context t,
-   ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
-;;
-*)
-
-let acic_object_of_cic_object sigma obj =
- let module A = Acic in
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-  let ids_to_conjectures = Hashtbl.create 11 in
-  let ids_to_hypotheses = Hashtbl.create 127 in
-  let hypotheses_seed = ref 0 in
-  let conjectures_seed = ref 0 in
-  let seed = ref 0 in
-  let acic_term_of_cic_term_context' =
-   acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
-    ids_to_inner_sorts ids_to_inner_types in
-(*CSC: is this the right env to use? Hhmmm. There is a problem: in    *)
-(*CSC: Global.env () the object we are exporting is already defined,  *)
-(*CSC: either in the environment or in the named context (in the case *)
-(*CSC: of variables. Is this a problem?                               *)
-  let env = Global.env () in
-  let acic_term_of_cic_term' ?fake_dependent_products =
-   acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in
-(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *)
-(*CSC: a modified version of the already existent fresh_id function    *)
-  let fresh_id () =
-   let res = "i" ^ string_of_int !seed in
-    incr seed ;
-    res
-  in
-   let aobj =
-    match obj with
-      A.Constant (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           None -> None
-         | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty))
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AConstant (fresh_id (),id,abo,aty,params)
-    | A.Variable (id,bo,ty,params) ->
-       let abo =
-        match bo with
-           Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
-         | None -> None
-       in
-       let aty = acic_term_of_cic_term' ty None in
-        A.AVariable (fresh_id (),id,abo,aty,params)
-    | A.CurrentProof (id,conjectures,bo,ty) ->
-       let aconjectures =
-        List.map
-         (function (i,canonical_context,term) as conjecture ->
-           let cid = "c" ^ string_of_int !conjectures_seed in
-            Hashtbl.add ids_to_conjectures cid conjecture ;
-            incr conjectures_seed ;
-            let canonical_env,idrefs',acanonical_context =
-             let rec aux env idrefs =
-              function
-                 [] -> env,idrefs,[]
-               | ((n,decl_or_def) as hyp)::tl ->
-                  let hid = "h" ^ string_of_int !hypotheses_seed in
-                  let new_idrefs = hid::idrefs in
-                   Hashtbl.add ids_to_hypotheses hid hyp ;
-                   incr hypotheses_seed ;
-                   match decl_or_def with
-                       A.Decl t ->
-                        let final_env,final_idrefs,atl =
-                         aux (Environ.push_rel (Names.Name n,None,t) env)
-                          new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                          final_env,final_idrefs,(hid,(n,A.Decl at))::atl
-                     | A.Def (t,ty) ->
-                        let final_env,final_idrefs,atl =
-                         aux
-                          (Environ.push_rel (Names.Name n,Some t,ty) env)
-                           new_idrefs tl
-                        in
-                         let at =
-                          acic_term_of_cic_term_context' env idrefs sigma t None
-                         in
-                         let dummy_never_used =
-                          let s = "dummy_never_used" in
-                           A.ARel (s,99,s,Names.id_of_string s)
-                         in
-                          final_env,final_idrefs,
-                           (hid,(n,A.Def (at,dummy_never_used)))::atl
-             in
-              aux env [] canonical_context
-            in
-             let aterm =
-              acic_term_of_cic_term_context' canonical_env idrefs' sigma term
-               None
-             in
-              (cid,i,List.rev acanonical_context,aterm)
-         ) conjectures in
-       let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in
-       let aty = acic_term_of_cic_term_context' env [] sigma ty None in
-        A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty)
-    | A.InductiveDefinition (tys,params,paramsno) ->
-       let env' =
-        List.fold_right
-         (fun (name,_,arity,_) env ->
-           Environ.push_rel (Names.Name name, None, arity) env
-         ) (List.rev tys) env in
-       let idrefs = List.map (function _ -> gen_id seed) tys in
-       let atys =
-        List.map2
-         (fun id (name,inductive,ty,cons) ->
-           let acons =
-            List.map
-             (function (name,ty) ->
-               (name,
-                 acic_term_of_cic_term_context' ~fake_dependent_products:true
-                  env' idrefs Evd.empty ty None)
-             ) cons
-           in
-            let aty =
-             acic_term_of_cic_term' ~fake_dependent_products:true ty None
-            in
-             (id,name,inductive,aty,acons)
-         ) (List.rev idrefs) tys
-       in
-       A.AInductiveDefinition (fresh_id (),atys,params,paramsno)
-   in
-    aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts,
-     ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses
-;;
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
deleted file mode 100644
index c22c16f0..00000000
--- a/plugins/xml/doubleTypeInference.ml
+++ /dev/null
@@ -1,273 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *)
-type types = {synthesized : Term.types ; expected : Term.types option};;
-
-let prerr_endline _ = ();;
-
-let cprop =
- let module N = Names in
-  N.make_con
-   (N.MPfile
-     (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
-   (N.make_dirpath [])
-   (N.mk_label "CProp")
-;;
-
-let whd_betadeltaiotacprop env _evar_map ty =
- let module R = Glob_term in
- let module C = Closure in
- let module CR = C.RedFlags in
- (*** CProp is made Opaque ***)
- let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in
- C.whd_val (C.create_clos_infos flags env) (C.inject ty)
-;;
-
-
-(* Code similar to the code in the Typing module, but:   *)
-(*  - the term is already assumed to be well typed       *)
-(*  - some checks have been removed                      *)
-(*  - both the synthesized and expected types of every   *)
-(*    node are computed (Coscoy's double type inference) *)
-
-let assumption_of_judgment env sigma j =
-  Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment env sigma j =
-  Typeops.type_judgment env (Evarutil.j_nf_evar sigma j)
-;;
-
-let type_judgment_cprop env sigma j =
-  match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with
-    | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s }
-    | _ -> None  (* None means the CProp constant *)
-;;
-
-let double_type_of env sigma cstr expectedty subterms_to_types =
- (*CSC: the code is inefficient because judgments are created just to be   *)
- (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *)
- (*CSC: functions used do checks that we do not need                       *)
- let rec execute env sigma cstr expectedty =
-  let module T = Term in
-  let module E = Environ in
-   (* the type part is the synthesized type *)
-   let judgement =
-    match T.kind_of_term cstr with
-       T.Meta n ->
-        Util.error
-         "DoubleTypeInference.double_type_of: found a non-instanciated goal"
-
-     | T.Evar ((n,l) as ev) ->
-        let ty = Unshare.unshare (Evd.existential_type sigma ev) in
-        let jty = execute env sigma ty None in
-        let jty = assumption_of_judgment env sigma jty in
-        let evar_context =
-	  E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
-         let rec iter actual_args evar_context =
-          match actual_args,evar_context with
-             [],[] -> ()
-           | he1::tl1,(n,_,ty)::tl2 ->
-              (* for side-effects *)
-              let _ = execute env sigma he1 (Some ty) in
-              let tl2' =
-               List.map
-                (function (m,bo,ty) ->
-                  (* Warning: the substitution should be performed also on bo *)
-                  (* This is not done since bo is not used later yet          *)
-                  (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty))
-                ) tl2
-              in
-               iter tl1 tl2'
-           | _,_ -> assert false
-         in
-          (* for side effects only *)
-          iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
-          E.make_judge cstr jty
-
-     | T.Rel n ->
-        Typeops.judge_of_relative env n
-
-     | T.Var id ->
-        Typeops.judge_of_variable env id
-
-     | T.Const c ->
-        E.make_judge cstr (Typeops.type_of_constant env c)
-
-     | T.Ind ind ->
-        E.make_judge cstr (Inductiveops.type_of_inductive env ind)
-
-     | T.Construct cstruct ->
-        E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
-
-     | T.Case (ci,p,c,lf) ->
-        let expectedtype =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in
-        let cj = execute env sigma c (Some expectedtype) in
-        let pj = execute env sigma p None in
-        let (expectedtypes,_,_) =
-         let indspec = Inductive.find_rectype env cj.Environ.uj_type in
-          Inductive.type_case_branches env indspec pj cj.Environ.uj_val
-        in
-        let lfj =
-         execute_array env sigma lf
-          (Array.map (function x -> Some x) expectedtypes) in
-        let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
-         j
-
-     | T.Fix ((vn,i as vni),recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let fix = (vni,recdef') in
-        E.make_judge (T.mkFix fix) tys.(i)
-
-     | T.CoFix (i,recdef) ->
-        let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
-        let cofix = (i,recdef') in
-        E.make_judge (T.mkCoFix cofix) tys.(i)
-
-     | T.Sort (T.Prop c) ->
-        Typeops.judge_of_prop_contents c
-
-     | T.Sort (T.Type u) ->
-(*CSC: In case of need, I refresh the universe. But exportation of the   *)
-(*CSC: right universe level information is destroyed. It must be changed *)
-(*CSC: again once Judicael will introduce his non-bugged algebraic       *)
-(*CSC: universes.                                                        *)
-(try
-        Typeops.judge_of_type u
- with e when e <> Sys.Break ->
- (* Successor of a non universe-variable universe anomaly *)
- (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
-  Typeops.judge_of_type (Termops.new_univ ())
-)
-
-     | T.App (f,args) ->
-        let expected_head =
-         Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in
-        let j = execute env sigma f (Some expected_head) in
-        let expected_args =
-         let rec aux typ =
-          function
-             [] -> []
-           | hj::restjl ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with
-                 T.Prod (_,c1,c2) ->
-                  (Some (Reductionops.nf_beta sigma c1)) ::
-                   (aux (T.subst1 hj c2) restjl)
-               | _ -> assert false
-         in
-          Array.of_list (aux j.Environ.uj_type (Array.to_list args))
-        in
-        let jl = execute_array env sigma args expected_args in
-        let (j,_) = Typeops.judge_of_apply env j jl in
-         j
-
-     | T.Lambda (name,c1,c2) ->
-        let j = execute env sigma c1 None in
-        let var = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,var.E.utj_val) env in
-        let expectedc2type =
-         match expectedty with
-            None -> None
-          | Some ety ->
-              match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with
-                 T.Prod (_,_,expected_target_type) ->
-                  Some (Reductionops.nf_beta sigma expected_target_type)
-               | _ -> assert false
-        in
-        let j' = execute env1 sigma c2 expectedc2type in
-         Typeops.judge_of_abstraction env1 name var j'
-
-     | T.Prod (name,c1,c2) ->
-        let j = execute env sigma c1 None in
-        let varj = type_judgment env sigma j in
-        let env1 = E.push_rel (name,None,varj.E.utj_val) env in
-        let j' = execute env1 sigma c2 None in
-        (match type_judgment_cprop env1 sigma j' with
-            Some varj' -> Typeops.judge_of_product env name varj varj'
-          | None ->
-             (* CProp found *)
-             { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val);
-               Environ.uj_type = T.mkConst cprop })
-
-     | T.LetIn (name,c1,c2,c3) ->
-(*CSC: What are the right expected types for the source and *)
-(*CSC: target of a LetIn? None used.                        *)
-        let j1 = execute env sigma c1 None in
-        let j2 = execute env sigma c2 None in
-        let j2 = type_judgment env sigma j2 in
-        let env1 =
-         E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env
-        in
-         let j3 = execute env1 sigma c3 None in
-          Typeops.judge_of_letin env name j1 j2 j3
-
-     | T.Cast (c,k,t) ->
-        let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in
-        let tj = execute env sigma t None in
-	let tj = type_judgment env sigma tj in
-        let j, _ = Typeops.judge_of_cast env cj k tj in
-	 j
-    in
-     let synthesized = E.j_type judgement in
-     let synthesized' = Reductionops.nf_beta sigma synthesized in
-      let types,res =
-       match expectedty with
-          None ->
-           (* No expected type *)
-           {synthesized = synthesized' ; expected = None}, synthesized
-        | Some ty when Term.eq_constr synthesized' ty ->
-           (* The expected type is synthactically equal to the    *)
-           (* synthesized type. Let's forget it.                  *)
-           (* Note: since eq_constr is up to casts, it is better  *)
-           (* to keep the expected type, since it can bears casts *)
-           (* that change the innersort to CProp                  *)
-           {synthesized = ty ; expected = None}, ty
-        | Some expectedty' ->
-           {synthesized = synthesized' ; expected = Some expectedty'},
-           expectedty'
-      in
-(*CSC: debugging stuff to be removed *)
-if Acic.CicHash.mem subterms_to_types cstr then
- (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ;
-       Acic.CicHash.add subterms_to_types cstr types ;
-       E.make_judge cstr res
-
-
- and execute_recdef env sigma (names,lar,vdef) =
-   let length = Array.length lar in
-   let larj =
-    execute_array env sigma lar (Array.make length None) in
-   let lara = Array.map (assumption_of_judgment env sigma) larj in
-   let env1 = Environ.push_rec_types (names,lara,vdef) env in
-   let expectedtypes =
-    Array.map (function i -> Some (Term.lift length i)) lar
-   in
-   let vdefj = execute_array env1 sigma vdef expectedtypes in
-   let vdefv = Array.map Environ.j_val vdefj in
-   (names,lara,vdefv)
-
- and execute_array env sigma v expectedtypes =
-   let jl =
-    execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes)
-   in
-    Array.of_list jl
-
- and execute_list env sigma =
-  List.map2 (execute env sigma)
-
-in
- ignore (execute env sigma cstr expectedty)
-;;
diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
deleted file mode 100644
index 5c00bdc6..00000000
--- a/plugins/xml/doubleTypeInference.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-type types = { synthesized : Term.types; expected : Term.types option; }
-
-val cprop : Names.constant
-
-val whd_betadeltaiotacprop :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
-
-val double_type_of :
-  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option ->
-   types Acic.CicHash.t -> unit
diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
deleted file mode 100644
index 76364541..00000000
--- a/plugins/xml/dumptree.ml4
+++ /dev/null
@@ -1,136 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** This module provides the "Dump Tree" command that allows dumping the
-    current state of the proof stree in XML format *)
-
-(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-open Tacexpr;;
-open Decl_mode;;
-open Printer;;
-open Pp;;
-open Environ;;
-open Format;;
-open Proof_type;;
-open Evd;;
-open Termops;;
-open Ppconstr;;
-open Names;;
-
-exception Different
-
-let xmlstream s =
-  (* In XML we want to print the whole stream so we can force the evaluation *)
-  Stream.of_list (List.map xmlescape (Stream.npeek max_int s))
-;;
-
-let thin_sign osign sign =
-  Sign.fold_named_context
-    (fun (id,c,ty as d) sign ->
-       try
-        if Sign.lookup_named id osign = (id,c,ty) then sign
-         else raise Different
-       with Not_found | Different -> Environ.push_named_context_val d sign)
-    sign ~init:Environ.empty_named_context_val
-;;
-
-let pr_tactic_xml = function
-  | TacArg (_,Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
-  | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
-;;
-
-let pr_proof_instr_xml instr =
-  Ppdecl_proof.pr_proof_instr (Global.env()) instr
-;;
-
-let pr_rule_xml pr = function
-  | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>"
-  | Nested(cmpd, subtree) ->
-      hov 2 (str "<cmpdrule>" ++ fnl () ++
-        begin match cmpd with
-          Tactic (texp, _) -> pr_tactic_xml texp
-        end ++ fnl ()
-        ++ pr subtree
-      ) ++ fnl () ++ str "</cmpdrule>"
-  | Daimon -> str "<daimon/>"
-  | Decl_proof _ -> str "<proof/>"
-;;
-
-let pr_var_decl_xml env (id,c,typ) =
-  let ptyp = print_constr_env env typ in
-  match c with
-  | None ->
-      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
-  | Some c ->
-      (* Force evaluation *)
-      let pb = print_constr_env env c in
-      (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
-         xmlstream pb ++ str "\"/>")
-;;
-
-let pr_rel_decl_xml env (na,c,typ) =
-  let pbody = match c with
-    | None -> mt ()
-    | Some c ->
-	(* Force evaluation *)
-	let pb = print_constr_env env c in
-	  (str" body=\"" ++ xmlstream pb ++ str "\"") in
-  let ptyp = print_constr_env env typ in
-  let pid =
-    match na with
-    | Anonymous -> mt ()
-    | Name id -> str " id=\"" ++ pr_id id ++ str "\""
-  in
-  (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>")
-;;
-
-let pr_context_xml env =
-  let sign_env =
-    fold_named_context
-      (fun env d pp -> pp ++ pr_var_decl_xml env d)
-      env ~init:(mt ())
-  in
-  let db_env =
-    fold_rel_context
-      (fun env d pp -> pp ++ pr_rel_decl_xml env d)
-      env ~init:(mt ())
-  in
-  (sign_env ++ db_env)
-;;
-
-let pr_subgoal_metas_xml metas env=
-  let pr_one (meta, typ) =
-    fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++
-      str "\"/>"
-  in
-  List.fold_left (++) (mt ()) (List.map pr_one metas)
-;;
-
-let pr_goal_xml sigma g =
-  let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in
-  if Decl_mode.try_get_info sigma g = None then
-    (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
-    xmlstream (pr_goal_concl_style_env env (Goal.V82.concl sigma g)) ++
-    str "\"/>" ++
-    (pr_context_xml env)) ++
-    fnl () ++ str "</goal>")
-  else
-    (hov 2 (str "<goal type=\"declarative\">" ++
-    (pr_context_xml env)) ++
-    fnl () ++ str "</goal>")
-;;
-
-let print_proof_xml () =
-  Util.anomaly "Dump Tree command not supported in this version."
-
-
-VERNAC COMMAND EXTEND DumpTree
-  [ "Dump" "Tree" ] -> [ print_proof_xml () ]
-END
diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
deleted file mode 100644
index 2d16190b..00000000
--- a/plugins/xml/proof2aproof.ml
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Note: we can not use the Set module here because we _need_ physical *)
-(* equality and there exists no comparison function compatible with    *)
-(* physical equality.                                                  *)
-
-module S =
- struct
-  let empty = []
-  let mem = List.memq
-  let add x l = x::l
- end
-;;
-
-(* evar reduction that preserves some terms *)
-let nf_evar sigma ~preserve =
- let module T = Term in
-  let rec aux t =
-   if preserve t then t else
-    match T.kind_of_term t with
-     | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
-     | T.Construct _ -> t
-     | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
-     | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
-     | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
-     | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
-     | T.App (c,l) ->
-        let c' = aux c in
-        let l' = Array.map aux l in
-         (match T.kind_of_term c' with
-             T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-           | T.Cast (he,_,_) ->
-              (match T.kind_of_term he with
-                  T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
-                | _ -> T.mkApp (c', l')
-              )
-           | _ -> T.mkApp (c', l'))
-     | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
-	aux (Evd.existential_value sigma (e,l))
-     | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
-     | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
-     | T.Fix (ln,(lna,tl,bl)) ->
-         T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-     | T.CoFix(ln,(lna,tl,bl)) ->
-         T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
-   in
-    aux
-;;
-
-module ProofTreeHash =
- Hashtbl.Make
-  (struct
-    type t = Proof_type.proof_tree
-    let equal = (==)
-    let hash = Hashtbl.hash
-   end)
-;;
-
-
-let extract_open_proof sigma pf =
-  (* Deactivated and candidate for removal. (Apr. 2010) *)
-   ()
-
-let extract_open_pftreestate pts =
-  (* Deactivated and candidate for removal. (Apr. 2010) *)
-   ()
diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
deleted file mode 100644
index 2f5eb6ac..00000000
--- a/plugins/xml/proofTree2Xml.ml4
+++ /dev/null
@@ -1,205 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
-
-let idref_of_id id = "v" ^ id;;
-
-(* Transform a constr to an Xml.token Stream.t *)
-(* env is a named context                      *)
-(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *)
-let constr_to_xml obj sigma env =
-  let ids_to_terms = Hashtbl.create 503 in
-  let constr_to_ids = Acic.CicHash.create 503 in
-  let ids_to_father_ids = Hashtbl.create 503 in
-  let ids_to_inner_sorts = Hashtbl.create 503 in
-  let ids_to_inner_types = Hashtbl.create 503 in
-
-  (* named_context holds section variables and local variables *)
-  let named_context = Environ.named_context env  in
-  (* real_named_context holds only the section variables *)
-  let real_named_context = Environ.named_context (Global.env ()) in
-  (* named_context' holds only the local variables *)
-  let named_context' =
-   List.filter (function n -> not (List.mem n real_named_context)) named_context
-  in
-  let idrefs =
-   List.map
-    (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in
-  let rel_context = Sign.push_named_to_rel_context named_context' [] in
-  let rel_env =
-   Environ.push_rel_context rel_context
-    (Environ.reset_with_named_context
-	(Environ.val_of_named_context real_named_context) env) in
-  let obj' =
-   Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
-  let seed = ref 0 in
-   try
-    let annobj =
-     Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids
-      ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env
-      idrefs sigma (Unshare.unshare obj') None
-    in
-     Acic2Xml.print_term ids_to_inner_sorts annobj
-   with e ->
-    Util.anomaly
-     ("Problem during the conversion of constr into XML: " ^
-      Printexc.to_string e)
-(* CSC: debugging stuff
-Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ;
-Pp.ppnl (Pp.str "ENVIRONMENT:") ;
-Pp.ppnl (Printer.pr_context_of rel_env) ;
-Pp.ppnl (Pp.str "TERM:") ;
-Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ;
-Pp.ppnl (Pp.str "RAW-TERM:") ;
-Pp.ppnl (Printer.pr_lconstr obj') ;
-Xml.xml_empty "MISSING TERM" [] (*; raise e*)
-*)
-;;
-
-let first_word s =
-   try let i = String.index s ' ' in
-       String.sub s 0 i
-   with _ -> s
-;;
-
-let string_of_prim_rule x = match x with
-  | Proof_type.Intro _-> "Intro"
-  | Proof_type.Cut _ -> "Cut"
-  | Proof_type.FixRule _ -> "FixRule"
-  | Proof_type.Cofix _ -> "Cofix"
-  | Proof_type.Refine _ -> "Refine"
-  | Proof_type.Convert_concl _ -> "Convert_concl"
-  | Proof_type.Convert_hyp _->"Convert_hyp"
-  | Proof_type.Thin _ -> "Thin"
-  | Proof_type.ThinBody _-> "ThinBody"
-  | Proof_type.Move (_,_,_) -> "Move"
-  | Proof_type.Order _ -> "Order"
-  | Proof_type.Rename (_,_) -> "Rename"
-  | Proof_type.Change_evars -> "Change_evars"
-
-let
- print_proof_tree curi sigma pf proof_tree_to_constr
-  proof_tree_to_flattened_proof_tree constr_to_ids
-=
- let module PT = Proof_type in
- let module L = Logic in
- let module X = Xml in
- let module T = Tacexpr in
-  let ids_of_node node =
-   let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in
-(*
-let constr =
- try
-    Proof2aproof.ProofTreeHash.find proof_tree_to_constr node
- with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated
-no lambda-term: ") (Refiner.print_script true (Evd.empty)
-(Global.named_context ()) node)) ; assert false (* Closed bug, should not
-happen any more *)
-in
-*)
-   try
-    Some (Acic.CicHash.find constr_to_ids constr)
-   with _ ->
-Pp.ppnl (Pp.(++) (Pp.str
-"The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
-(Printer.pr_lconstr constr)) ;
-    None
-  in
-  let rec aux node old_hyps =
-   let of_attribute =
-    match ids_of_node node with
-       None -> []
-     | Some id -> ["of",id]
-   in
-    match node with
-       {PT.ref=Some(PT.Prim tactic_expr,nodes)} ->
-         let tac = string_of_prim_rule tactic_expr in
-         let of_attribute = ("name",tac)::of_attribute in
-          if nodes = [] then
-           X.xml_empty "Prim" of_attribute
-          else
-           X.xml_nempty "Prim" of_attribute
-            (List.fold_left
-              (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
-
-     | {PT.goal=goal;
-        PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
-         (* [hidden_proof] is the proof of the tactic;                     *)
-         (* [nodes] are the proof of the subgoals generated by the tactic; *)
-         (* [flat_proof] if the proof-tree obtained substituting [nodes]   *)
-         (*  for the holes in [hidden_proof]                               *)
-        let flat_proof =
-         Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
-        in begin
-        match tactic_expr with
-        | T.TacArg (_,T.Tacexp _) ->
-            (* We don't need to keep the level of abstraction introduced at *)
-            (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
-            aux flat_proof old_hyps
-        | _ ->
-         (****** la tactique employee *)
-	 let prtac = Pptactic.pr_tactic (Global.env()) in
-         let tac = Pp.string_of_ppcmds (prtac tactic_expr) in
-         let tacname= first_word tac in
-         let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
-
-         (****** le but *)
-
-	 let concl = Goal.V82.concl sigma goal in
-	 let hyps = Goal.V82.hyps sigma goal in
-
-         let env = Global.env_of_context hyps in
-	   
-
-         let xgoal =
-          X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
-
-         let rec build_hyps =
-          function
-           | [] -> xgoal
-           | (id,c,tid)::hyps1 ->
-              let id' = Names.string_of_id id in
-               [< build_hyps hyps1;
-                  (X.xml_nempty "Hypothesis"
-                    ["id",idref_of_id id' ; "name",id']
-                    (constr_to_xml tid sigma env))
-               >] in
-         let old_names = List.map (fun (id,c,tid)->id) old_hyps in
-	 let nhyps = Environ.named_context_of_val hyps in
-         let new_hyps =
-          List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in
-
-         X.xml_nempty "Tactic" of_attribute
-          [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
-        end
-
-     | {PT.ref=Some(PT.Daimon,_)} ->
-         X.xml_empty "Hidden_open_goal" of_attribute
-
-     | {PT.ref=None;PT.goal=goal} ->
-         X.xml_empty "Open_goal" of_attribute
-     | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof"
-  in
-   [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
-      X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
-      X.xml_nempty "ProofTree" ["of",curi] (aux pf [])
-   >]
-;;
-
-
-(* Hook registration *)
-(* CSC: debranched since it is bugged
-Xmlcommand.set_print_proof_tree print_proof_tree;;
-*)
diff --git a/plugins/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd
deleted file mode 100644
index 953fe009..00000000
--- a/plugins/xml/theoryobject.dtd
+++ /dev/null
@@ -1,62 +0,0 @@
-<?xml encoding="ISO-8859-1"?>
-
-<!-- Copyright (C) 2000-2004, HELM Team                                -->
-<!--                                                                   -->
-<!-- This file is part of HELM, an Hypertextual, Electronic            -->
-<!-- Library of Mathematics, developed at the Computer Science         -->
-<!-- Department, University of Bologna, Italy.                         -->
-<!--                                                                   -->
-<!-- HELM is free software; you can redistribute it and/or             -->
-<!-- modify it under the terms of the GNU General Public License       -->
-<!-- as published by the Free Software Foundation; either version 2    -->
-<!-- of the License, or (at your option) any later version.            -->
-<!--                                                                   -->
-<!-- HELM is distributed in the hope that it will be useful,           -->
-<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of    -->
-<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     -->
-<!-- GNU General Public License for more details.                      -->
-<!--                                                                   -->
-<!-- You should have received a copy of the GNU General Public License -->
-<!-- along with HELM; if not, write to the Free Software               -->
-<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston,            -->
-<!-- MA  02111-1307, USA.                                              -->
-<!--                                                                   -->
-<!-- For details, see the HELM World-Wide-Web page,                    -->
-<!-- http://cs.unibo.it/helm/.                                         -->
-
-
-
-<!-- Notice: the markup described in this DTD is meant to be embedded -->
-<!-- in foreign markup (e.g. XHTML)                                   -->
-
-<!ENTITY % theorystructure
-  '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'>
-
-<!ELEMENT ht:SECTION (%theorystructure;)>
-<!ATTLIST ht:SECTION
-          uri CDATA #REQUIRED>
-
-<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)>
-
-<!-- Theory Items -->
-
-<!ELEMENT ht:AXIOM (Axiom)>
-<!ATTLIST ht:AXIOM
-          uri CDATA #REQUIRED
-          as (Axiom|Declaration) #REQUIRED>
-
-<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)>
-<!ATTLIST ht:DEFINITION
-          uri CDATA #REQUIRED
-          as (Definition|InteractiveDefinition|Inductive|CoInductive
-             |Record) #REQUIRED>
-
-<!ELEMENT ht:THEOREM (type)>
-<!ATTLIST ht:THEOREM
-          uri CDATA #REQUIRED
-          as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED>
-
-<!ELEMENT ht:VARIABLE (Variable)>
-<!ATTLIST ht:VARIABLE
-          uri CDATA #REQUIRED
-          as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED>
diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
deleted file mode 100644
index c854427d..00000000
--- a/plugins/xml/unshare.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-let unshare ?(already_unshared = function _ -> false) t =
- let obj = Obj.repr t in
-  let rec aux obj =
-   if already_unshared (Obj.obj obj) then
-    obj
-   else
-    (if Obj.is_int obj then
-      obj
-     else if Obj.is_block obj then
-      begin
-       let tag = Obj.tag obj in
-        if tag < Obj.no_scan_tag then
-         begin
-          let size = Obj.size obj in
-           let new_obj = Obj.new_block 0 size in
-            Obj.set_tag new_obj tag ;
-            for i = 0 to size - 1 do
-             Obj.set_field new_obj i (aux (Obj.field obj i))
-            done ;
-            new_obj
-         end
-        else if tag = Obj.string_tag then
-         obj
-        else
-         raise CanNotUnshare
-      end
-     else
-      raise CanNotUnshare
-    )
-  in
-   Obj.obj (aux obj)
-;;
diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
deleted file mode 100644
index cace2de6..00000000
--- a/plugins/xml/unshare.mli
+++ /dev/null
@@ -1,21 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-exception CanNotUnshare;;
-
-(* [unshare t] gives back a copy of t where all sharing has been removed   *)
-(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
-(* use physical equality can now be used to associate information to evey  *)
-(* node of the term.                                                       *)
-val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a
diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
deleted file mode 100644
index 8a4eb39a..00000000
--- a/plugins/xml/xml.ml4
+++ /dev/null
@@ -1,78 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* the type token for XML cdata, empty elements and not-empty elements *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token = Str of string
-           | Empty of string * (string * string) list
-	   | NEmpty of string * (string * string) list * token Stream.t
-;;
-
-(* currified versions of the constructors make the code more readable *)
-let xml_empty name attrs = [< 'Empty(name,attrs) >]
-let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
-let xml_cdata str = [< 'Str str >]
-
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-let pp_ch strm channel =
- let rec pp_r m =
-  parser
-    [< 'Str a ; s >] ->
-      print_spaces m ;
-      fprint_string (a ^ "\n") ;
-      pp_r m s
-  | [< 'Empty(n,l) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string "/>\n" ;
-      pp_r m s
-  | [< 'NEmpty(n,l,c) ; s >] ->
-      print_spaces m ;
-      fprint_string ("<" ^ n) ;
-      List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
-      fprint_string ">\n" ;
-      pp_r (m+1) c ;
-      print_spaces m ;
-      fprint_string ("</" ^ n ^ ">\n") ;
-      pp_r m s
-  | [< >] -> ()
- and print_spaces m =
-  for i = 1 to m do fprint_string "  " done
- and fprint_string str =
-  output_string channel str
- in
-  pp_r 0 strm
-;;
-
-
-let pp strm fn =
-  match fn with
-     Some filename ->
-      let filename = filename ^ ".xml" in
-      let ch = open_out filename in
-       pp_ch strm ch;
-       close_out ch ;
-       print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n");
-       flush stdout
-   | None ->
-       pp_ch strm stdout
-;;
-
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
deleted file mode 100644
index 0b6d5198..00000000
--- a/plugins/xml/xml.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* Tokens for XML cdata, empty elements and not-empty elements           *)
-(* Usage:                                                                *)
-(*  Str cdata                                                            *)
-(*  Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen]   *)
-(*  NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
-(*          content                                                      *)
-type token =
-  | Str of string
-  | Empty of string * (string * string) list
-  | NEmpty of string * (string * string) list * token Stream.t
-
-(* currified versions of the token constructors make the code more readable *)
-val xml_empty : string -> (string * string) list -> token Stream.t
-val xml_nempty :
-  string -> (string * string) list -> token Stream.t -> token Stream.t
-val xml_cdata : string -> token Stream.t
-
-val pp_ch : token Stream.t -> out_channel -> unit
-
-(* The pretty printer for streams of token                                  *)
-(* Usage:                                                                   *)
-(*  pp tokens None     pretty prints the output on stdout                   *)
-(*  pp tokens (Some filename) pretty prints the output on the file filename *)
-val pp : token Stream.t -> string option -> unit
diff --git a/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib
deleted file mode 100644
index 90797e8d..00000000
--- a/plugins/xml/xml_plugin.mllib
+++ /dev/null
@@ -1,13 +0,0 @@
-Unshare
-Xml
-Acic
-DoubleTypeInference
-Cic2acic
-Acic2Xml
-Proof2aproof
-Xmlcommand
-ProofTree2Xml
-Xmlentries
-Cic2Xml
-Dumptree
-Xml_plugin_mod
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
deleted file mode 100644
index 59ade01e..00000000
--- a/plugins/xml/xmlcommand.ml
+++ /dev/null
@@ -1,691 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* CONFIGURATION PARAMETERS *)
-
-let verbose = ref false;;
-
-(* HOOKS *)
-let print_proof_tree, set_print_proof_tree =
- let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in
-  (fun () -> !print_proof_tree),
-   (fun f ->
-     print_proof_tree :=
-     fun
-      curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree
-      constr_to_ids
-     ->
-      Some
-       (f curi sigma0 pf proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids))
-;;
-
-(* UTILITY FUNCTIONS *)
-
-let print_if_verbose s = if !verbose then print_string s;;
-
-(* Next exception is used only inside print_coq_object and tag_of_string_tag *)
-exception Uninteresting;;
-
-(* NOT USED anymore, we back to the V6 point of view with global parameters
-
-(* Internally, for Coq V7, params of inductive types are associated     *)
-(* not to the whole block of mutual inductive (as it was in V6) but to  *)
-(* each member of the block; but externally, all params are required    *)
-(* to be the same; the following function checks that the parameters    *)
-(* of each inductive of a same block are all the same, then returns     *)
-(* this number; it fails otherwise                                      *)
-let extract_nparams pack =
- let module D = Declarations in
- let module U = Util in
- let module S = Sign in
-
-  let {D.mind_nparams=nparams0} = pack.(0) in
-  let arity0 = pack.(0).D.mind_user_arity in
-  let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in
-  for i = 1 to Array.length pack - 1 do
-    let {D.mind_nparams=nparamsi} = pack.(i) in
-    let arityi = pack.(i).D.mind_user_arity in
-    let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in
-    if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block"
-  done;
-  nparams0
-
-*)
-
-(* could_have_namesakes sp = true iff o is an object that could be cooked and *)
-(* than that could exists in cooked form with the same name in a super        *)
-(* section of the actual section                                              *)
-let could_have_namesakes o sp =      (* namesake = omonimo in italian *)
- let module DK = Decl_kinds in
- let module D = Declare in
-  let tag = Libobject.object_tag o in
-   print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
-   match tag with
-      "CONSTANT"        -> true   (* constants/parameters are non global *)
-    | "INDUCTIVE"       -> true   (* mutual inductive types are never local   *)
-    | "VARIABLE"        -> false  (* variables are local, so no namesakes     *)
-    | _                 -> false  (* uninteresting thing that won't be printed*)
-;;
-
-(* filter_params pvars hyps *)
-(* filters out from pvars (which is a list of lists) all the variables *)
-(* that does not belong to hyps (which is a simple list)               *)
-(* It returns a list of couples relative section path -- list of       *)
-(* variable names.                                                     *)
-let filter_params pvars hyps =
- let rec aux ids =
-  function
-     [] -> []
-   | (id,he)::tl ->
-      let ids' = id::ids in
-      let ids'' =
-       "cic:/" ^
-        String.concat "/" (List.rev (List.map Names.string_of_id ids')) in
-      let he' =
-       ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in
-      let tl' = aux ids' tl in
-       match he' with
-          _,[] -> tl'
-        | _,_  -> he'::tl'
- in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
-   aux (Names.repr_dirpath modulepath) (List.rev pvars)
-;;
-
-type variables_type =
-   Definition of string * Term.constr * Term.types
- | Assumption of string * Term.constr
-;;
-
-(* The computation is very inefficient, but we can't do anything *)
-(* better unless this function is reimplemented in the Declare   *)
-(* module.                                                       *)
-let search_variables () =
- let module N = Names in
-  let cwd = Lib.cwd () in
-  let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
-  let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
-   let rec aux =
-    function
-       [] -> []
-     | he::tl as modules ->
-        let one_section_variables =
-         let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in
-          let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in
-           [he,t]
-        in
-         one_section_variables @ aux tl
-   in
-    aux
-     (Cic2acic.remove_module_dirpath_from_dirpath
-       ~basedir:modulepath cwd)
-;;
-
-(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *)
-
-let rec join_dirs cwd =
- function
-    []  -> cwd
-  | he::tail ->
-      (try
-        Unix.mkdir cwd 0o775
-       with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *)
-      ) ;
-     let newcwd = cwd ^ "/" ^ he in
-      join_dirs newcwd tail
-;;
-
-let filename_of_path xml_library_root tag =
- let module N = Names in
-  match xml_library_root with
-     None -> None  (* stdout *)
-   | Some xml_library_root' ->
-      let tokens = Cic2acic.token_list_of_kernel_name tag in
-       Some (join_dirs xml_library_root' tokens)
-;;
-
-let body_filename_of_filename =
- function
-    Some f -> Some (f ^ ".body")
-  | None   -> None
-;;
-
-let types_filename_of_filename =
- function
-    Some f -> Some (f ^ ".types")
-  | None   -> None
-;;
-
-let prooftree_filename_of_filename =
- function
-    Some f -> Some (f ^ ".proof_tree")
-  | None   -> None
-;;
-
-let theory_filename xml_library_root =
- let module N = Names in
-  match xml_library_root with
-    None -> None  (* stdout *)
-  | Some xml_library_root' ->
-     let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in
-     (* theory from A/B/C/F.v goes into A/B/C/F.theory *)
-     let alltoks = List.rev toks in
-       Some (join_dirs xml_library_root' alltoks ^ ".theory")
-
-let print_object uri obj sigma proof_tree_infos filename =
- (* function to pretty print and compress an XML file *)
-(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *)
- let pp xml filename =
-  Xml.pp xml filename ;
-  match filename with
-     None -> ()
-   | Some fn ->
-      let fn' =
-       let rec escape s n =
-        try
-         let p = String.index_from s n '\'' in
-          String.sub s n (p - n) ^ "\\'" ^ escape s (p+1)
-        with Not_found -> String.sub s n (String.length s - n)
-       in
-        escape fn 0
-      in
-       ignore (Unix.system ("gzip " ^ fn' ^ ".xml"))
- in
-  let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) =
-   Cic2acic.acic_object_of_cic_object sigma obj in
-  let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in
-  let xmltypes =
-   Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in
-  pp xml filename ;
-  begin
-   match xml' with
-      None -> ()
-    | Some xml' -> pp xml' (body_filename_of_filename filename)
-  end ;
-  pp xmltypes (types_filename_of_filename filename) ;
-  match proof_tree_infos with
-     None -> ()
-   | Some (sigma0,proof_tree,proof_tree_to_constr,
-           proof_tree_to_flattened_proof_tree) ->
-      let xmlprooftree =
-       print_proof_tree ()
-        uri sigma0 proof_tree proof_tree_to_constr
-        proof_tree_to_flattened_proof_tree constr_to_ids
-      in
-       match xmlprooftree with
-          None -> ()
-        | Some xmlprooftree ->
-           pp xmlprooftree (prooftree_filename_of_filename filename)
-;;
-
-let string_list_of_named_context_list =
- List.map
-  (function (n,_,_) -> Names.string_of_id n)
-;;
-
-(* Function to collect the variables that occur in a term. *)
-(* Used only for variables (since for constants and mutual *)
-(* inductive types this information is already available.  *)
-let find_hyps t =
- let module T = Term in
-  let rec aux l t =
-   match T.kind_of_term t with
-      T.Var id when not (List.mem id l) ->
-       let (_,bo,ty) = Global.lookup_named id in
-        let boids =
-         match bo with
-            Some bo' -> aux l bo'
-          | None -> l
-        in
-         id::(aux boids ty)
-    | T.Var _
-    | T.Rel _
-    | T.Meta _
-    | T.Evar _
-    | T.Sort _ -> l
-    | T.Cast (te,_, ty) -> aux (aux l te) ty
-    | T.Prod (_,s,t) -> aux (aux l s) t
-    | T.Lambda (_,s,t) -> aux (aux l s) t
-    | T.LetIn (_,s,_,t) -> aux (aux l s) t
-    | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl
-    | T.Const con ->
-       let hyps = (Global.lookup_constant con).Declarations.const_hyps in
-        map_and_filter l hyps @ l
-    | T.Ind ind
-    | T.Construct (ind,_) ->
-       let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in
-        map_and_filter l hyps @ l
-    | T.Case (_,t1,t2,b) ->
-       Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b
-    | T.Fix (_,(_,tys,bodies))
-    | T.CoFix (_,(_,tys,bodies)) ->
-       let r = Array.fold_left (fun i x -> aux i x) l tys in
-        Array.fold_left (fun i x -> aux i x) r bodies
-  and map_and_filter l =
-   function
-      [] -> []
-    | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl)
-    | _::tl -> map_and_filter l tl
-  in
-   aux [] t
-;;
-
-(* Functions to construct an object *)
-
-let mk_variable_obj id body typ =
- let hyps,unsharedbody =
-  match body with
-     None -> [],None
-   | Some bo -> find_hyps bo, Some (Unshare.unshare bo)
- in
-  let hyps' = find_hyps typ @ hyps in
-  let hyps'' = List.map Names.string_of_id hyps' in
-  let variables = search_variables () in
-  let params = filter_params variables hyps'' in
-   Acic.Variable
-    (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params)
-;;
-
-(* Unsharing is not performed on the body, that must be already unshared. *)
-(* The evar map and the type, instead, are unshared by this function.     *)
-let mk_current_proof_obj is_a_variable id bo ty evar_map env =
- let unshared_ty = Unshare.unshare ty in
- let metasenv =
-  List.map
-   (function
-     (n, {Evd.evar_concl = evar_concl ;
-          Evd.evar_hyps = evar_hyps}
-      ) ->
-       (* We map the named context to a rel context and every Var to a Rel *)
-       let final_var_ids,context =
-        let rec aux var_ids =
-         function
-            [] -> var_ids,[]
-          | (n,None,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let t' = Term.subst_vars var_ids t in
-               final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl'
-          | (n,Some b,t)::tl ->
-              let final_var_ids,tl' = aux (n::var_ids) tl in
-              let b' = Term.subst_vars var_ids b in
-               (* t will not be exported to XML. Thus no unsharing performed *)
-               final_var_ids,(n, Acic.Def  (Unshare.unshare b',t))::tl'
-        in
-         aux [] (List.rev (Environ.named_context_of_val evar_hyps))
-       in
-        (* We map the named context to a rel context and every Var to a Rel *)
-        (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl))
-   ) (Evarutil.non_instantiated evar_map)
- in
-  let id' = Names.string_of_id id in
-   if metasenv = [] then
-    let ids =
-     Names.Idset.union
-      (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in
-    let hyps0 = Environ.keep_hyps env ids in
-    let hyps = string_list_of_named_context_list hyps0 in
-    (* Variables are the identifiers of the variables in scope *)
-    let variables = search_variables () in
-    let params = filter_params variables hyps in
-     if is_a_variable then
-      Acic.Variable (id',Some bo,unshared_ty,params)
-     else
-      Acic.Constant (id',Some bo,unshared_ty,params)
-   else
-    Acic.CurrentProof (id',metasenv,bo,unshared_ty)
-;;
-
-let mk_constant_obj id bo ty variables hyps =
- let hyps = string_list_of_named_context_list hyps in
- let ty = Unshare.unshare ty in
- let params = filter_params variables hyps in
-  match bo with
-     None ->
-      Acic.Constant (Names.string_of_id id,None,ty,params)
-   | Some c ->
-      Acic.Constant
-       (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)),
-         ty,params)
-;;
-
-let mk_inductive_obj sp mib packs variables nparams hyps finite =
- let module D = Declarations in
-  let hyps = string_list_of_named_context_list hyps in
-  let params = filter_params variables hyps in
-(*  let nparams = extract_nparams packs in *)
-   let tys =
-    let tyno = ref (Array.length packs) in
-    Array.fold_right
-     (fun p i ->
-       decr tyno ;
-       let {D.mind_consnames=consnames ;
-            D.mind_typename=typename } = p
-       in
-        let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
-        let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
-        let cons =
-         (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
-          (Array.mapi
-           (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
-          []
-         )
-        in
-         (typename,finite,Unshare.unshare arity,cons)::i
-     ) packs []
-   in
-    Acic.InductiveDefinition (tys,params,nparams)
-;;
-
-(* The current channel for .theory files *)
-let theory_buffer = Buffer.create 4000;;
-
-let theory_output_string ?(do_not_quote = false) s =
-  (* prepare for coqdoc post-processing *)
-  let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
-  print_if_verbose s;
-   Buffer.add_string theory_buffer s
-;;
-
-let kind_of_global_goal = function
-  | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition"
-  | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k
-  | Decl_kinds.Local, _ -> assert false
-
-let kind_of_inductive isrecord kn =
- "DEFINITION",
- if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
- then begin 
-   match isrecord with 
-   | Declare.KernelSilent -> "Record"
-   | _ -> "Inductive"
- end
- else "CoInductive"
-;;
-
-let kind_of_variable id =
-  let module DK = Decl_kinds in
-  match Decls.variable_kind id with
-    | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
-    | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
-    | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
-    | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition"
-    | DK.IsProof _ -> "VARIABLE","LocalFact"
-    | _ -> Util.anomaly "Unsupported variable kind"
-;;
-
-let kind_of_constant kn =
-  let module DK = Decl_kinds in
-  match Decls.constant_kind kn with
-    | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
-    | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
-    | DK.IsAssumption DK.Conjectural ->
-        Pp.msg_warn "Conjecture not supported in dtd (used Declaration instead)";
-        "AXIOM","Declaration"
-    | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
-    | DK.IsDefinition DK.Example ->
-        Pp.msg_warn "Example not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Coercion ->
-        Pp.msg_warn "Coercion not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.SubClass ->
-        Pp.msg_warn "SubClass not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CanonicalStructure ->
-        Pp.msg_warn "CanonicalStructure not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Fixpoint ->
-        Pp.msg_warn "Fixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.CoFixpoint ->
-        Pp.msg_warn "CoFixpoint not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Scheme ->
-        Pp.msg_warn "Scheme not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.StructureComponent ->
-        Pp.msg_warn "StructureComponent not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.IdentityCoercion ->
-        Pp.msg_warn "IdentityCoercion not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Instance ->
-        Pp.msg_warn "Instance not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsDefinition DK.Method ->
-        Pp.msg_warn "Method not supported in dtd (used Definition instead)";
-        "DEFINITION","Definition"
-    | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) ->
-        "THEOREM",DK.string_of_theorem_kind thm
-    | DK.IsProof _ ->
-        Pp.msg_warn "Unsupported theorem kind (used Theorem instead)";
-        "THEOREM",DK.string_of_theorem_kind DK.Theorem
-;;
-
-let kind_of_global r =
-  let module Ln = Libnames in
-  let module DK = Decl_kinds in
-  match r with
-  | Ln.IndRef kn | Ln.ConstructRef (kn,_) ->
-      let isrecord =
-	try let _ = Recordops.lookup_projections kn in Declare.KernelSilent
-        with Not_found -> Declare.KernelVerbose in
-      kind_of_inductive isrecord (fst kn)
-  | Ln.VarRef id -> kind_of_variable id
-  | Ln.ConstRef kn -> kind_of_constant kn
-;;
-
-let print_object_kind uri (xmltag,variation) =
-  let s =
-    Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation
-  in
-  theory_output_string s
-;;
-
-(* print id dest                                                          *)
-(*  where sp   is the qualified identifier (section path) of a            *)
-(*             definition/theorem, variable or inductive definition       *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose identifier is id on dest     *)
-(* Note: it is printed only (and directly) the most cooked available      *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-let print internal glob_ref kind xml_library_root =
- let module D = Declarations in
- let module De = Declare in
- let module G = Global in
- let module N = Names in
- let module Nt = Nametab in
- let module T = Term in
- let module X = Xml in
- let module Ln = Libnames in
-  (* Variables are the identifiers of the variables in scope *)
-  let variables = search_variables () in
-  let tag,obj =
-   match glob_ref with
-      Ln.VarRef id ->
-       (* this kn is fake since it is not provided by Coq *)
-       let kn =
-        let (mod_path,dir_path) = Lib.current_prefix () in
-        N.make_kn mod_path dir_path (N.label_of_id id)
-       in
-       let (_,body,typ) = G.lookup_named id in
-        Cic2acic.Variable kn,mk_variable_obj id body typ
-    | Ln.ConstRef kn ->
-       let id = N.id_of_label (N.con_label kn) in
-       let cb = G.lookup_constant kn in
-       let val0 = D.body_of_constant cb in
-       let typ = cb.D.const_type in
-       let hyps = cb.D.const_hyps in
-       let typ = Typeops.type_of_constant_type (Global.env()) typ in
-        Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
-    | Ln.IndRef (kn,_) ->
-       let mib = G.lookup_mind kn in
-       let {D.mind_nparams=nparams;
-	    D.mind_packets=packs ;
-            D.mind_hyps=hyps;
-            D.mind_finite=finite} = mib in
-          Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
-    | Ln.ConstructRef _ ->
-       Util.error ("a single constructor cannot be printed in XML")
-  in
-  let fn = filename_of_path xml_library_root tag in
-  let uri = Cic2acic.uri_of_kernel_name tag in
-  (match internal with
-    | Declare.KernelSilent -> ()
-    | _ -> print_object_kind uri kind);
-   print_object uri obj Evd.empty None fn
-;;
-
-let print_ref qid fn =
-  let ref = Nametab.global qid in
-  print Declare.UserVerbose ref (kind_of_global ref) fn
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-let show_pftreestate internal fn (kind,pftst) id =
- if true then
-   Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version."
-
-let show fn =
- let pftst = Pfedit.get_pftreestate () in
- let (id,kind,_,_) = Pfedit.current_proof_statement () in
-  show_pftreestate false fn (kind,pftst) id
-;;
-
-
-(* Let's register the callbacks *)
-let xml_library_root =
-  try
-   Some (Sys.getenv "COQ_XML_LIBRARY_ROOT")
-  with Not_found -> None
-;;
-
-let proof_to_export = ref None (* holds the proof-tree to export *)
-;;
-
-let _ =
-  Pfedit.set_xml_cook_proof
-   (function pftreestate -> proof_to_export := Some pftreestate)
-;;
-
-let _ =
-  Declare.set_xml_declare_variable
-   (function (sp,kn) ->
-     let id = Libnames.basename sp in
-     print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
-     proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_constant
-   (function (internal,kn) ->
-     match !proof_to_export with
-        None ->
-          print internal (Libnames.ConstRef kn) (kind_of_constant kn)
-	    xml_library_root
-      | Some pftreestate ->
-         (* It is a proof. Let's export it starting from the proof-tree *)
-         (* I saved in the Pfedit.set_xml_cook_proof callback.          *)
-        let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
-         show_pftreestate internal fn pftreestate
-	  (Names.id_of_label (Names.con_label kn)) ;
-         proof_to_export := None)
-;;
-
-let _ =
-  Declare.set_xml_declare_inductive
-   (function (isrecord,(sp,kn)) ->
-      print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0))
-        (kind_of_inductive isrecord (Names.mind_of_kn kn))
-        xml_library_root)
-;;
-
-let _ =
-  Vernac.set_xml_start_library
-   (function () ->
-     Buffer.reset theory_buffer;
-     theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n";
-     theory_output_string ("<!DOCTYPE html [\n" ^
-      "<!ENTITY % xhtml-lat1.ent    SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^
-      "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^
-      "<!ENTITY % xhtml-symbol.ent  SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^
-      "%xhtml-lat1.ent;\n" ^
-      "%xhtml-special.ent;\n" ^
-      "%xhtml-symbol.ent;\n" ^
-      "]>\n\n");
-     theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n";
-     theory_output_string "<head></head>\n<body>\n")
-;;
-
-let _ =
-  Vernac.set_xml_end_library
-   (function () ->
-      theory_output_string "</body>\n</html>\n";
-      let ofn = theory_filename xml_library_root in
-       begin
-        match ofn with
-           None ->
-             Buffer.output_buffer stdout theory_buffer ;
-         | Some fn ->
-             let ch = open_out (fn ^ ".v") in
-             Buffer.output_buffer ch theory_buffer ;
-             close_out ch;
-             (* dummy glob file *)
-             let ch = open_out (fn ^ ".glob") in
-             close_out ch
-       end ;
-       Option.iter
-	(fun fn ->
-	  let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in
-	  let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
-          let command cmd =
-           if Sys.command cmd <> 0 then
-            Util.anomaly ("Error executing \"" ^ cmd ^ "\"")
-          in
-           command (coqdoc^options^" -o "^fn^".xml "^fn^".v");
-           command ("rm "^fn^".v "^fn^".glob");
-           print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n"))
-       ofn)
-;;
-
-let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
-
-let uri_of_dirpath dir =
-  "/" ^ String.concat "/"
-    (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
-;;
-
-let _ =
-  Lib.set_xml_open_section
-    (fun _ ->
-      let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in
-      theory_output_string ("<ht:SECTION uri=\""^s^"\">"))
-;;
-
-let _ =
-  Lib.set_xml_close_section
-    (fun _ -> theory_output_string "</ht:SECTION>")
-;;
-
-let _ =
-  Library.set_xml_require
-    (fun d -> theory_output_string
-      (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
-       (uri_of_dirpath d) (Names.string_of_dirpath d)))
-;;
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
deleted file mode 100644
index ec50d623..00000000
--- a/plugins/xml/xmlcommand.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(* print_global qid fn                                                    *)
-(*  where qid  is a long name denoting a definition/theorem or            *)
-(*             an inductive definition                                    *)
-(*  and   dest is either None (for stdout) or (Some filename)             *)
-(* pretty prints via Xml.pp the object whose name is ref on dest          *)
-(* Note: it is printed only (and directly) the most discharged available  *)
-(*       form of the definition (all the parameters are                   *)
-(*       lambda-abstracted, but the object can still refer to variables)  *)
-val print_ref : Libnames.reference -> string option -> unit
-
-(* show dest                                                  *)
-(*  where dest is either None (for stdout) or (Some filename) *)
-(* pretty prints via Xml.pp the proof in progress on dest     *)
-val show : string option -> unit
-
-(* set_print_proof_tree f                                      *)
-(*  sets a callback function f to export the proof_tree to XML *)
-val set_print_proof_tree :
-    (string ->
-     Evd.evar_map ->
-     Proof_type.proof_tree ->
-     Term.constr Proof2aproof.ProofTreeHash.t ->
-     Proof_type.proof_tree Proof2aproof.ProofTreeHash.t ->
-     string Acic.CicHash.t -> Xml.token Stream.t) ->
-    unit
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
deleted file mode 100644
index d65a1bd3..00000000
--- a/plugins/xml/xmlentries.ml4
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
-(*   \VV/  **************************************************************)
-(*    //   *   The HELM Project         /   The EU MoWGLI Project       *)
-(*         *   University of Bologna                                    *)
-(************************************************************************)
-(*          This file is distributed under the terms of the             *)
-(*           GNU Lesser General Public License Version 2.1              *)
-(*                                                                      *)
-(*                 Copyright (C) 2000-2004, HELM Team.                  *)
-(*                       http://helm.cs.unibo.it                        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Util;;
-open Vernacinterp;;
-
-open Extend;;
-open Genarg;;
-open Pp;;
-open Pcoq;;
-
-(* File name *)
-
-VERNAC ARGUMENT EXTEND filename
-| [ "File" string(fn) ] -> [ Some fn ]
-| [ ] -> [ None ]
-END
-
-(* Print XML and Show XML *)
-
-VERNAC COMMAND EXTEND Xml
-| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ]
-
-| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ]
-END
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml
index 78290e03..3cfc0dc8 100644
--- a/pretyping/arguments_renaming.ml
+++ b/pretyping/arguments_renaming.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,32 +8,20 @@
 
 (*i*)
 open Names
-open Libnames
-open Decl_kinds
+open Globnames
 open Term
-open Sign
-open Evd
 open Environ
-open Nametab
-open Mod_subst
 open Util
-open Pp
 open Libobject
-open Nameops
 (*i*)
 
-let empty_name_table = (Refmap.empty : name list list Refmap.t)
-let name_table = ref empty_name_table
-
-let _ =
-  Summary.declare_summary "rename-arguments"
-    { Summary.freeze_function = (fun () -> !name_table);
-      Summary.unfreeze_function = (fun r -> name_table := r);
-      Summary.init_function = (fun () -> name_table := empty_name_table) }
+let name_table =
+  Summary.ref (Refmap.empty : Name.t list list Refmap.t)
+    ~name:"rename-arguments"
 
 type req =
   | ReqLocal
-  | ReqGlobal of global_reference * name list list
+  | ReqGlobal of global_reference * Name.t list list
 
 let load_rename_args _ (_, (_, (r, names))) =
   name_table := Refmap.add r names !name_table
@@ -53,12 +41,12 @@ let section_segment_of_reference = function
   | ConstRef con -> Lib.section_segment_of_constant con
   | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
       Lib.section_segment_of_mutual_inductive kn
-  | _ -> []
+  | _ -> [], Univ.LMap.empty, Univ.UContext.empty
 
 let discharge_rename_args = function
   | _, (ReqGlobal (c, names), _ as req) ->
      (try 
-       let vars = section_segment_of_reference c in
+       let vars,_,_ = section_segment_of_reference c in
        let c' = pop_global_reference c in
        let var_names = List.map (fun (id, _,_,_) -> Name id) vars in
        let names' = List.map (fun l -> var_names @ l) names in
@@ -99,22 +87,24 @@ let rename_type ty ref =
   with Not_found -> ty
 
 let rename_type_of_constant env c =
-  let ty = Typeops.type_of_constant env c in
-  rename_type ty (ConstRef c)
+  let ty = Typeops.type_of_constant_in env c in
+  rename_type ty (ConstRef (fst c))
 
 let rename_type_of_inductive env ind =
   let ty = Inductiveops.type_of_inductive env ind in
-  rename_type ty (IndRef ind)
+  rename_type ty (IndRef (fst ind))
 
 let rename_type_of_constructor env cstruct =
   let ty = Inductiveops.type_of_constructor env cstruct in
-  rename_type ty (ConstructRef cstruct)
+  rename_type ty (ConstructRef (fst cstruct))
 
 let rename_typing env c =
-  let j = Typeops.typing env c in
-  match kind_of_term c with
-  | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) }
-  | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) }
-  | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) }
-  | _ -> j
+  let j = Typeops.infer env c in
+  let j' =
+    match kind_of_term c with
+    | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) }
+    | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) }
+    | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) }
+    | _ -> j
+  in j'
 
diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli
index 74c4cdc3..290bfc59 100644
--- a/pretyping/arguments_renaming.mli
+++ b/pretyping/arguments_renaming.mli
@@ -1,22 +1,22 @@
 (************************************************************************)
 (*  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 Libnames
+open Globnames
 open Environ
 open Term
 
-val rename_arguments : bool -> global_reference -> name list list -> unit
+val rename_arguments : bool -> global_reference -> Name.t list list -> unit
 
 (** [Not_found] is raised is no names are defined for [r] *)
-val arguments_names : global_reference -> name list list
+val arguments_names : global_reference -> Name.t list list
 
-val rename_type_of_constant : env -> constant -> types
-val rename_type_of_inductive : env -> inductive -> types
-val rename_type_of_constructor : env -> constructor -> types
+val rename_type_of_constant : env -> pconstant -> types
+val rename_type_of_inductive : env -> pinductive -> types
+val rename_type_of_constructor : env -> pconstructor -> types
 val rename_typing : env -> constr -> unsafe_judgment
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 57857351..fdb19d37 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1,29 +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 Compat
+open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Term
+open Vars
+open Context
 open Termops
 open Namegen
 open Declarations
 open Inductiveops
 open Environ
-open Sign
 open Reductionops
-open Typeops
 open Type_errors
 open Glob_term
+open Glob_ops
 open Retyping
 open Pretype_errors
 open Evarutil
+open Evarsolve
 open Evarconv
 open Evd
 
@@ -34,56 +37,39 @@ type pattern_matching_error =
   | BadConstructor of constructor * inductive
   | WrongNumargConstructor of constructor * int
   | WrongNumargInductive of inductive * int
-  | WrongPredicateArity of constr * constr * constr
-  | NeedsInversion of constr * constr
   | UnusedClause of cases_pattern list
   | NonExhaustive of cases_pattern list
   | CannotInferPredicate of (constr * types) array
 
-exception PatternMatchingError of env * pattern_matching_error
+exception PatternMatchingError of env * evar_map * pattern_matching_error
 
-let raise_pattern_matching_error (loc,ctx,te) =
-  Loc.raise loc (PatternMatchingError(ctx,te))
+let raise_pattern_matching_error (loc,env,sigma,te) =
+  Loc.raise loc (PatternMatchingError(env,sigma,te))
 
-let error_bad_pattern_loc loc cstr ind =
-  raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind))
+let error_bad_pattern_loc loc env sigma cstr ind =
+  raise_pattern_matching_error
+    (loc, env, sigma, BadPattern (cstr,ind))
 
-let error_bad_constructor_loc loc cstr ind =
-  raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
+let error_bad_constructor_loc loc env cstr ind =
+  raise_pattern_matching_error
+    (loc, env, Evd.empty, BadConstructor (cstr,ind))
 
 let error_wrong_numarg_constructor_loc loc env c n =
-  raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n))
+  raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargConstructor(c,n))
 
 let error_wrong_numarg_inductive_loc loc env c n =
-  raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n))
-
-let error_wrong_predicate_arity_loc loc env c n1 n2 =
-  raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
-
-let error_needs_inversion env x t =
-  raise (PatternMatchingError (env, NeedsInversion (x,t)))
-
-module type S = sig
-  val compile_cases :
-    loc -> case_style ->
-    (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
-    type_constraint ->
-    env -> glob_constr option * tomatch_tuples * cases_clauses ->
-    unsafe_judgment
-end
+  raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n))
 
 let rec list_try_compile f = function
   | [a] -> f a
-  | [] -> anomaly "try_find_f"
+  | [] -> anomaly (str "try_find_f")
   | h::t ->
       try f h
-      with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _
-	| Loc.Exc_located
-	    (_, (UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _)) ->
+      with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ ->
 	    list_try_compile f t
 
 let force_name =
-  let nx = Name (id_of_string "x") in function Anonymous -> nx | na -> na
+  let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na
 
 (************************************************************************)
 (*            Pattern-matching compilation (Cases)                      *)
@@ -99,18 +85,15 @@ let msg_may_need_inversion () =
 
 (* Utils *)
 let make_anonymous_patvars n =
-  list_make n (PatVar (dummy_loc,Anonymous))
-
-(* Environment management *)
-let push_rels vars env = List.fold_right push_rel vars env
+  List.make n (PatVar (Loc.ghost,Anonymous))
 
 (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
    over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
 
-let relocate_rel n1 n2 k j = if j = n1+k then n2+k else j
+let relocate_rel n1 n2 k j = if Int.equal j (n1 + k) then n2+k else j
 
 let rec relocate_index n1 n2 k t = match kind_of_term t with
-  | Rel j when j = n1+k -> mkRel (n2+k)
+  | Rel j when Int.equal j (n1 + k) -> mkRel (n2+k)
   | Rel j when j < n1+k -> t
   | Rel j when j > n1+k -> t
   | _ -> map_constr_with_binders succ (relocate_index n1 n2) k t
@@ -120,27 +103,33 @@ let rec relocate_index n1 n2 k t = match kind_of_term t with
 
 type 'a rhs =
     { rhs_env    : env;
-      rhs_vars   : identifier list;
-      avoid_ids  : identifier list;
+      rhs_vars   : Id.t list;
+      avoid_ids  : Id.t list;
       it         : 'a option}
 
 type 'a equation =
     { patterns     : cases_pattern list;
       rhs          : 'a rhs;
-      alias_stack  : name list;
-      eqn_loc      : loc;
+      alias_stack  : Name.t list;
+      eqn_loc      : Loc.t;
       used         : bool ref }
 
 type 'a matrix = 'a equation list
 
 (* 1st argument of IsInd is the original ind before extracting the summary *)
 type tomatch_type =
-  | IsInd of types * inductive_type * name list
+  | IsInd of types * inductive_type * Name.t list
   | NotInd of constr option * types
 
+(* spiwack: The first argument of [Pushed] is [true] for initial
+   Pushed and [false] otherwise. Used to decide whether the term being
+   matched on must be aliased in the variable case (only initial
+   Pushed need to be aliased). The first argument of [Alias] is [true]
+   if the alias was introduced by an initial pushed and [false]
+   otherwise.*)
 type tomatch_status =
-  | Pushed of ((constr * tomatch_type) * int list * name)
-  | Alias of (name * constr * (constr * types))
+  | Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
+  | Alias of (bool*(Name.t * constr * (constr * types)))
   | NonDepAlias
   | Abstract of int * rel_declaration
 
@@ -162,9 +151,9 @@ let feed_history arg = function
   | Continuation (n, l, h) when n>=1 ->
       Continuation (n-1, arg :: l, h)
   | Continuation (n, _, _) ->
-      anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
+      anomaly (str "Bad number of expected remaining patterns: " ++ int n)
   | Result _ ->
-      anomaly "Exhausted pattern history"
+      anomaly (Pp.str "Exhausted pattern history")
 
 (* This is for non exhaustive error message *)
 
@@ -178,22 +167,22 @@ and build_glob_pattern args = function
   | Top -> args
   | MakeConstructor (pci, rh) ->
       glob_pattern_of_partial_history
-	[PatCstr (dummy_loc, pci, args, Anonymous)] rh
+	[PatCstr (Loc.ghost, pci, args, Anonymous)] rh
 
 let complete_history = glob_pattern_of_partial_history []
 
 (* This is to build glued pattern-matching history and alias bodies *)
 
-let rec pop_history_pattern = function
+let pop_history_pattern = function
   | Continuation (0, l, Top) ->
       Result (List.rev l)
   | Continuation (0, l, MakeConstructor (pci, rh)) ->
-      feed_history (PatCstr (dummy_loc,pci,List.rev l,Anonymous)) rh
+      feed_history (PatCstr (Loc.ghost,pci,List.rev l,Anonymous)) rh
   | _ ->
-      anomaly "Constructor not yet filled with its arguments"
+      anomaly (Pp.str "Constructor not yet filled with its arguments")
 
 let pop_history h =
-  feed_history (PatVar (dummy_loc, Anonymous)) h
+  feed_history (PatVar (Loc.ghost, Anonymous)) h
 
 (* Builds a continuation expecting [n] arguments and building [ci] applied
    to this [n] arguments *)
@@ -251,7 +240,7 @@ type 'a pattern_matching_problem =
       tomatch   : tomatch_stack;
       history   : pattern_continuation;
       mat       : 'a matrix;
-      caseloc   : loc;
+      caseloc   : Loc.t;
       casestyle : case_style;
       typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment }
 
@@ -277,60 +266,67 @@ let rec find_row_ind = function
   | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
 
 let inductive_template evdref env tmloc ind =
-  let arsign = get_full_arity_sign env ind in
+  let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in
+  let arsign = inductive_alldecls_env env indu in
   let hole_source = match tmloc with
-    | Some loc -> fun i -> (loc, TomatchTypeParameter (ind,i))
-    | None -> fun _ -> (dummy_loc, InternalHole) in
+    | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i))
+    | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in
    let (_,evarl,_) =
     List.fold_right
       (fun (na,b,ty) (subst,evarl,n) ->
 	match b with
         | None ->
 	    let ty' = substl subst ty in
-	    let e = e_new_evar evdref env ~src:(hole_source n) ty' in
+	    let e = e_new_evar env evdref ~src:(hole_source n) ty' in
 	    (e::subst,e::evarl,n+1)
 	| Some b ->
 	    (substl subst b::subst,evarl,n+1))
       arsign ([],[],1) in
-   applist (mkInd ind,List.rev evarl)
+   applist (mkIndU indu,List.rev evarl)
 
 let try_find_ind env sigma typ realnames =
   let (IndType(_,realargs) as ind) = find_rectype env sigma typ in
   let names =
     match realnames with
       | Some names -> names
-      | None -> list_make (List.length realargs) Anonymous in
+      | None -> List.make (List.length realargs) Anonymous in
   IsInd (typ,ind,names)
 
-let inh_coerce_to_ind evdref env ty tyi =
-  let expected_typ = inductive_template evdref env None tyi in
-     (* devrait être indifférent d'exiger leq ou pas puisque pour
-        un inductif cela doit être égal *)
-  let _ = e_cumul env evdref expected_typ ty in ()
+let inh_coerce_to_ind evdref env loc ty tyi =
+  let sigma = !evdref in
+  let expected_typ = inductive_template evdref env loc tyi in
+  (* Try to refine the type with inductive information coming from the
+     constructor and renounce if not able to give more information *)
+  (* devrait être indifférent d'exiger leq ou pas puisque pour
+     un inductif cela doit être égal *)
+  if not (e_cumul env evdref expected_typ ty) then evdref := sigma
 
 let binding_vars_of_inductive = function
   | NotInd _ -> []
   | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs
 
 let extract_inductive_data env sigma (_,b,t) =
-  if b<>None then (NotInd (None,t),[]) else
-  let tmtyp =
-    try try_find_ind env sigma t None
-    with Not_found -> NotInd (None,t) in
-  let tmtypvars = binding_vars_of_inductive tmtyp in
-  (tmtyp,tmtypvars)
+  match b with
+  | None ->
+    let tmtyp =
+      try try_find_ind env sigma t None
+      with Not_found -> NotInd (None,t) in
+    let tmtypvars = binding_vars_of_inductive tmtyp in
+    (tmtyp,tmtypvars)
+  | Some _ ->
+    (NotInd (None, t), [])
 
 let unify_tomatch_with_patterns evdref env loc typ pats realnames =
   match find_row_ind pats with
     | None -> NotInd (None,typ)
     | Some (_,(ind,_)) ->
-	inh_coerce_to_ind evdref env typ ind;
+	inh_coerce_to_ind evdref env loc typ ind;
 	try try_find_ind env !evdref typ realnames
 	with Not_found -> NotInd (None,typ)
 
 let find_tomatch_tycon evdref env loc = function
   (* Try if some 'in I ...' is present and can be used as a constraint *)
-  | Some (_,ind,_,realnal) ->
+  | Some (_,ind,realnal) ->
       mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal)
   | None ->
       empty_tycon,None
@@ -339,6 +335,8 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) =
   let loc = Some (loc_of_glob_constr tomatch) in
   let tycon,realnames = find_tomatch_tycon evdref env loc indopt in
   let j = typing_fun tycon env evdref tomatch in
+  let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in
+  evdref := evd;
   let typ = nf_evar !evdref j.uj_type in
   let t =
     try try_find_ind env !evdref typ realnames
@@ -356,17 +354,14 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl =
 (************************************************************************)
 (* Utils *)
 
-let mkExistential env ?(src=(dummy_loc,InternalHole)) evdref =
-  e_new_evar evdref env ~src:src (new_Type ())
+let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref =
+  let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e
 
 let evd_comb2 f evdref x y =
   let (evd',y) = f !evdref x y in
   evdref := evd';
   y
 
-
-module Cases_F(Coercion : Coercion.S) : S = struct
-
 let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
   (* Ideally, we could find a common inductive type to which both the
      term to match and the patterns coerce *)
@@ -386,13 +381,13 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) =
 	| Some (_,(ind,_)) ->
 	    let indt = inductive_template pb.evdref pb.env None ind in
 	    let current =
-	      if deps = [] & isEvar typ then
+	      if List.is_empty deps && isEvar typ then
 	      (* Don't insert coercions if dependent; only solve evars *)
 		let _ = e_cumul pb.env pb.evdref indt typ in
 		current
 	      else
-		(evd_comb2 (Coercion.inh_conv_coerce_to true dummy_loc pb.env)
-		  pb.evdref (make_judge current typ) (mk_tycon_type indt)).uj_val in
+		(evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env)
+		  pb.evdref (make_judge current typ) indt).uj_val in
 	    let sigma =  !(pb.evdref) in
 	    (current,try_find_ind pb.env sigma indt names))
   | _ -> (current,tmtyp)
@@ -401,10 +396,6 @@ let type_of_tomatch = function
   | IsInd (t,_,_) -> t
   | NotInd (_,t) -> t
 
-let mkDeclTomatch na = function
-  | IsInd (t,_,_) -> (na,None,t)
-  | NotInd (c,t) -> (na,c,t)
-
 let map_tomatch_type f = function
   | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names)
   | NotInd (c,t) -> NotInd (Option.map f c, f t)
@@ -418,7 +409,7 @@ let lift_tomatch_type n = liftn_tomatch_type n 1
 let current_pattern eqn =
   match eqn.patterns with
     | pat::_ -> pat
-    | [] -> anomaly "Empty list of patterns"
+    | [] -> anomaly (Pp.str "Empty list of patterns")
 
 let alias_of_pat = function
   | PatVar (_,name) -> name
@@ -430,7 +421,7 @@ let remove_current_pattern eqn =
 	{ eqn with
 	    patterns = pats;
 	    alias_stack = alias_of_pat pat :: eqn.alias_stack }
-    | [] -> anomaly "Empty list of patterns"
+    | [] -> anomaly (Pp.str "Empty list of patterns")
 
 let push_current_pattern (cur,ty) eqn =
   match eqn.patterns with
@@ -439,7 +430,19 @@ let push_current_pattern (cur,ty) eqn =
 	{ eqn with
             rhs = { eqn.rhs with rhs_env = rhs_env };
 	    patterns = pats }
-    | [] -> anomaly "Empty list of patterns"
+    | [] -> anomaly (Pp.str "Empty list of patterns")
+
+(* spiwack: like [push_current_pattern] but does not introduce an
+   alias in rhs_env. Aliasing binders are only useful for variables at
+   the root of a pattern matching problem (initial push), so we
+   distinguish the cases. *)
+let push_noalias_current_pattern eqn =
+  match eqn.patterns with
+  | _::pats ->
+      { eqn with patterns = pats }
+  | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns")
+
+
 
 let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
 
@@ -466,33 +469,32 @@ let check_and_adjust_constructor env ind cstrs = function
 	(* Check the constructor has the right number of args *)
 	let ci = cstrs.(i-1) in
 	let nb_args_constr = ci.cs_nargs in
-	if List.length args = nb_args_constr then pat
+	if Int.equal (List.length args) nb_args_constr then pat
 	else
 	  try
 	    let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
 	    in PatCstr (loc, cstr, args', alias)
 	  with NotAdjustable ->
-	    error_wrong_numarg_constructor_loc loc (Global.env())
-	      cstr nb_args_constr
+	    error_wrong_numarg_constructor_loc loc env cstr nb_args_constr
       else
 	(* Try to insert a coercion *)
 	try
-	  Coercion.inh_pattern_coerce_to loc pat ind' ind
+	  Coercion.inh_pattern_coerce_to loc env pat ind' ind
 	with Not_found ->
-	  error_bad_constructor_loc loc cstr ind
+	  error_bad_constructor_loc loc env cstr ind
 
-let check_all_variables typ mat =
+let check_all_variables env sigma typ mat =
   List.iter
     (fun eqn -> match current_pattern eqn with
        | PatVar (_,id) -> ()
        | PatCstr (loc,cstr_sp,_,_) ->
-	   error_bad_pattern_loc loc cstr_sp typ)
+	   error_bad_pattern_loc loc env sigma cstr_sp typ)
     mat
 
 let check_unused_pattern env eqn =
   if not !(eqn.used) then
     raise_pattern_matching_error
-      (eqn.eqn_loc, env, UnusedClause eqn.patterns)
+      (eqn.eqn_loc, env, Evd.empty, UnusedClause eqn.patterns)
 
 let set_used_pattern eqn = eqn.used := true
 
@@ -509,20 +511,21 @@ let extract_rhs pb =
 let occur_in_rhs na rhs =
   match na with
     | Anonymous -> false
-    | Name id -> List.mem id rhs.rhs_vars
+    | Name id -> Id.List.mem id rhs.rhs_vars
 
 let is_dep_patt_in eqn = function
-  | PatVar (_,name) -> occur_in_rhs name eqn.rhs
+  | PatVar (_,name) -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs
   | PatCstr _ -> true
 
 let mk_dep_patt_row (pats,_,eqn) =
   List.map (is_dep_patt_in eqn) pats
 
 let dependencies_in_pure_rhs nargs eqns =
-  if eqns = [] then list_make nargs false (* Only "_" patts *) else
+  if List.is_empty eqns then
+    List.make nargs (not (Flags.is_program_mode ()))  (* Only "_" patts *) else
   let deps_rows = List.map mk_dep_patt_row eqns in
   let deps_columns = matrix_transpose deps_rows in
-  List.map (List.exists ((=) true)) deps_columns
+  List.map (List.exists (fun x -> x)) deps_columns
 
 let dependent_decl a = function
   | (na,None,t) -> dependent a t
@@ -530,12 +533,12 @@ let dependent_decl a = function
 
 let rec dep_in_tomatch n = function
   | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l
-  | Abstract (_,d) :: l -> dependent_decl (mkRel n) d or dep_in_tomatch (n+1) l
+  | Abstract (_,d) :: l -> dependent_decl (mkRel n) d || dep_in_tomatch (n+1) l
   | [] -> false
 
 let dependencies_in_rhs nargs current tms eqns =
   match kind_of_term current with
-  | Rel n when dep_in_tomatch n tms -> list_make nargs true
+  | Rel n when dep_in_tomatch n tms -> List.make nargs true
   | _ -> dependencies_in_pure_rhs nargs eqns
 
 (* Computing the matrix of dependencies *)
@@ -555,12 +558,14 @@ let rec find_dependency_list tmblock = function
   | (used,tdeps,d)::rest ->
       let deps = find_dependency_list tmblock rest in
       if used && List.exists (fun x -> dependent_decl x d) tmblock
-      then list_add_set (List.length rest + 1) (list_union deps tdeps)
+      then
+        List.add_set Int.equal
+          (List.length rest + 1) (List.union Int.equal deps tdeps)
       else deps
 
 let find_dependencies is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist =
   let deps = find_dependency_list (tm::tmtypleaves) nextlist in
-  if is_dep_or_cstr_in_rhs || deps <> []
+  if is_dep_or_cstr_in_rhs || not (List.is_empty deps)
   then ((true ,deps,d)::nextlist)
   else ((false,[]  ,d)::nextlist)
 
@@ -583,14 +588,14 @@ let relocate_index_tomatch n1 n2 =
   let rec genrec depth = function
   | [] ->
       []
-  | Pushed ((c,tm),l,na) :: rest ->
+  | Pushed (b,((c,tm),l,na)) :: rest ->
       let c = relocate_index n1 n2 depth c in
       let tm = map_tomatch_type (relocate_index n1 n2 depth) tm in
       let l = List.map (relocate_rel n1 n2 depth) l in
-      Pushed ((c,tm),l,na) :: genrec depth rest
-  | Alias (na,c,d) :: rest ->
+      Pushed (b,((c,tm),l,na)) :: genrec depth rest
+  | Alias (initial,(na,c,d)) :: rest ->
       (* [c] is out of relocation scope *)
-      Alias (na,c,map_pair (relocate_index n1 n2 depth) d) :: genrec depth rest
+      Alias (initial,(na,c,map_pair (relocate_index n1 n2 depth) d)) :: genrec depth rest
   | NonDepAlias :: rest ->
       NonDepAlias :: genrec depth rest
   | Abstract (i,d) :: rest ->
@@ -602,24 +607,29 @@ let relocate_index_tomatch n1 n2 =
 (* [replace_tomatch n c tomatch] replaces [Rel n] by [c] in [tomatch] *)
 
 let rec replace_term n c k t =
-  if isRel t && destRel t = n+k then lift k c
+  if isRel t && Int.equal (destRel t) (n + k) then lift k c
   else map_constr_with_binders succ (replace_term n c) k t
 
-let length_of_tomatch_type_sign na = function
-  | NotInd _ -> if na<>Anonymous then 1 else 0
-  | IsInd (_,_,names) -> List.length names + if na<>Anonymous then 1 else 0
+let length_of_tomatch_type_sign na t =
+  let l = match na with
+  | Anonymous -> 0
+  | Name _ -> 1
+  in
+  match t with
+  | NotInd _ -> l
+  | IsInd (_, _, names) -> List.length names + l
 
 let replace_tomatch n c =
   let rec replrec depth = function
   | [] -> []
-  | Pushed ((b,tm),l,na) :: rest ->
+  | Pushed (initial,((b,tm),l,na)) :: rest ->
       let b = replace_term n c depth b in
       let tm = map_tomatch_type (replace_term n c depth) tm in
-      List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
-      Pushed ((b,tm),l,na) :: replrec depth rest
-  | Alias (na,b,d) :: rest ->
+      List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch")) l;
+      Pushed (initial,((b,tm),l,na)) :: replrec depth rest
+  | Alias (initial,(na,b,d)) :: rest ->
       (* [b] is out of replacement scope *)
-      Alias (na,b,map_pair (replace_term n c depth) d) :: replrec depth rest
+      Alias (initial,(na,b,map_pair (replace_term n c depth) d)) :: replrec depth rest
   | NonDepAlias  :: rest ->
       NonDepAlias :: replrec depth rest
   | Abstract (i,d) :: rest ->
@@ -636,13 +646,13 @@ let replace_tomatch n c =
 
 let rec liftn_tomatch_stack n depth = function
   | [] -> []
-  | Pushed ((c,tm),l,na)::rest ->
+  | Pushed (initial,((c,tm),l,na))::rest ->
       let c = liftn n depth c in
       let tm = liftn_tomatch_type n depth tm in
       let l = List.map (fun i -> if i<depth then i else i+n) l in
-      Pushed ((c,tm),l,na)::(liftn_tomatch_stack n depth rest)
-  | Alias (na,c,d)::rest ->
-      Alias (na,liftn n depth c,map_pair (liftn n depth) d)
+      Pushed (initial,((c,tm),l,na))::(liftn_tomatch_stack n depth rest)
+  | Alias (initial,(na,c,d))::rest ->
+      Alias (initial,(na,liftn n depth c,map_pair (liftn n depth) d))
       ::(liftn_tomatch_stack n depth rest)
   | NonDepAlias  :: rest ->
       NonDepAlias :: liftn_tomatch_stack n depth rest
@@ -684,7 +694,7 @@ let merge_name get_name obj = function
 let merge_names get_name = List.map2 (merge_name get_name)
 
 let get_names env sign eqns =
-  let names1 = list_make (List.length sign) Anonymous in
+  let names1 = List.make (List.length sign) Anonymous in
   (* If any, we prefer names used in pats, from top to bottom *)
   let names2,aliasname =
     List.fold_right
@@ -695,7 +705,7 @@ let get_names env sign eqns =
   (* Otherwise, we take names from the parameters of the constructor but
      avoiding conflicts with user ids *)
   let allvars =
-    List.fold_left (fun l (_,_,eqn) -> list_union l eqn.rhs.avoid_ids)
+    List.fold_left (fun l (_,_,eqn) -> List.union Id.equal l eqn.rhs.avoid_ids)
       [] eqns in
   let names3,_ =
     List.fold_left2
@@ -723,10 +733,11 @@ let recover_initial_subpattern_names = List.map2 set_declaration_name
 let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
 
 let push_rels_eqn sign eqn =
-  {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env} }
+  {eqn with
+     rhs = {eqn.rhs with rhs_env = push_rel_context sign eqn.rhs.rhs_env} }
 
 let push_rels_eqn_with_names sign eqn =
-  let subpats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+  let subpats = List.rev (List.firstn (List.length sign) eqn.patterns) in
   let subpatnames = List.map alias_of_pat subpats in
   let sign = recover_initial_subpattern_names subpatnames sign in
   push_rels_eqn sign eqn
@@ -795,7 +806,7 @@ Some hints:
 
 let rec map_predicate f k ccl = function
   | [] -> f k ccl
-  | Pushed ((_,tm),_,na) :: rest ->
+  | Pushed (_,((_,tm),_,na)) :: rest ->
       let k' = length_of_tomatch_type_sign na tm in
       map_predicate f (k+k') ccl rest
   | (Alias _ | NonDepAlias) :: rest ->
@@ -821,10 +832,14 @@ let subst_predicate (args,copt) ccl tms =
   substnl_predicate sigma 0 ccl tms
 
 let specialize_predicate_var (cur,typ,dep) tms ccl =
-  let c = if dep<>Anonymous then Some cur else None in
+  let c = match dep with
+  | Anonymous -> None
+  | Name _ -> Some cur
+  in
   let l =
     match typ with
-    | IsInd (_,IndType(_,realargs),names) -> if names<>[] then realargs else []
+    | IsInd (_, IndType (_, _), []) -> []
+    | IsInd (_, IndType (_, realargs), names) -> realargs
     | NotInd _ -> [] in
   subst_predicate (l,c) ccl tms
 
@@ -838,7 +853,9 @@ let specialize_predicate_var (cur,typ,dep) tms ccl =
 (* then we have to replace x by x' in t(x) and y by y' in P                  *)
 (*****************************************************************************)
 let generalize_predicate (names,na) ny d tms ccl =
-  if na=Anonymous then anomaly "Undetected dependency";
+  let () = match na with
+  | Anonymous -> anomaly (Pp.str "Undetected dependency")
+  | _ -> () in
   let p = List.length names + 1 in
   let ccl = lift_predicate 1 ccl tms in
   regeneralize_index_predicate (ny+p+1) ccl tms
@@ -862,16 +879,23 @@ let rec extract_predicate ccl = function
       extract_predicate ccl tms
   | Abstract (i,d)::tms ->
       mkProd_wo_LetIn d (extract_predicate ccl tms)
-  | Pushed ((cur,NotInd _),_,na)::tms ->
-      let tms = if na<>Anonymous then lift_tomatch_stack 1 tms else tms in
-      let pred = extract_predicate ccl tms in
-      if na<>Anonymous then subst1 cur pred else pred
-  | Pushed ((cur,IsInd (_,IndType(_,realargs),_)),_,na)::tms ->
+  | Pushed (_,((cur,NotInd _),_,na))::tms ->
+      begin match na with
+      | Anonymous -> extract_predicate ccl tms
+      | Name _ ->
+        let tms = lift_tomatch_stack 1 tms in
+        let pred = extract_predicate ccl tms in
+        subst1 cur pred
+      end
+  | Pushed (_,((cur,IsInd (_,IndType(_,realargs),_)),_,na))::tms ->
       let realargs = List.rev realargs in
-      let k = if na<>Anonymous then 1 else 0 in
+      let k, nrealargs = match na with
+      | Anonymous -> 0, realargs
+      | Name _ -> 1, (cur :: realargs)
+      in
       let tms = lift_tomatch_stack (List.length realargs + k) tms in
       let pred = extract_predicate ccl tms in
-      substl (if na<>Anonymous then cur::realargs else realargs) pred
+      substl nrealargs pred
   | [] ->
       ccl
 
@@ -890,7 +914,10 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl =
   (* Pred is already dependent in the current term to match (if      *)
   (* (na<>Anonymous) and its realargs; we just need to adjust it to  *)
   (* full sign if dep in cur is not taken into account               *)
-  let ccl = if na <> Anonymous then ccl else lift_predicate 1 ccl tms in
+  let ccl = match na with
+  | Anonymous -> lift_predicate 1 ccl tms
+  | Name _ -> ccl
+  in
   let pred = extract_predicate ccl tms in
   (* Build the predicate properly speaking *)
   let sign = List.map2 set_declaration_name (na::names) sign in
@@ -906,28 +933,40 @@ let expand_arg tms (p,ccl) ((_,t),_,na) =
   let k = length_of_tomatch_type_sign na t in
   (p+k,liftn_predicate (k-1) (p+1) ccl tms)
 
+
+let use_unit_judge evd =
+  let j, ctx = coq_unit_judge () in
+  let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in
+    evd', j
+
+let add_assert_false_case pb tomatch =
+  let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in
+  let aliasnames =
+    List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch
+  in
+  [ { patterns = pats;
+      rhs = { rhs_env = pb.env;
+	      rhs_vars = [];
+	      avoid_ids = [];
+	      it = None };
+      alias_stack = Anonymous::aliasnames;
+      eqn_loc = Loc.ghost;
+      used = ref false } ]
+
 let adjust_impossible_cases pb pred tomatch submat =
-  if submat = [] then
-    match kind_of_term (whd_evar !(pb.evdref) pred) with
-    | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) = ImpossibleCase ->
-	let default = (coq_unit_judge ()).uj_type in
-	pb.evdref := Evd.define evk default !(pb.evdref);
-      (* we add an "assert false" case *)
-      let pats = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) tomatch in
-      let aliasnames =
-	map_succeed (function Alias _ | NonDepAlias -> Anonymous | _ -> failwith"") tomatch
-      in
-      [ { patterns = pats;
-          rhs = { rhs_env = pb.env;
-	          rhs_vars = [];
-		  avoid_ids = [];
-		  it = None };
-	  alias_stack = Anonymous::aliasnames;
-	  eqn_loc = dummy_loc;
-	  used = ref false } ]
+  match submat with
+  | [] ->
+    begin match kind_of_term pred with
+    | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase ->
+        if not (Evd.is_defined !(pb.evdref) evk) then begin
+	  let evd, default = use_unit_judge !(pb.evdref) in
+	  pb.evdref := Evd.define evk default.uj_type evd
+        end;
+        add_assert_false_case pb tomatch
     | _ ->
 	submat
-  else
+    end
+  | _ ->
     submat
 
 (*****************************************************************************)
@@ -957,7 +996,8 @@ let adjust_impossible_cases pb pred tomatch submat =
 let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
   (* Assume some gamma st: gamma |- PI [X,x:I(X)]. PI tms. ccl *)
   let nrealargs = List.length names in
-  let k = nrealargs + (if depna<>Anonymous then 1 else 0) in
+  let l = match depna with Anonymous -> 0 | Name _ -> 1 in
+  let k = nrealargs + l in
   (* We adjust pred st: gamma, x1..xn |- PI [X,x:I(X)]. PI tms. ccl' *)
   (* so that x can later be instantiated by Ci(x1..xn) *)
   (* and X by the realargs for Ci *)
@@ -965,12 +1005,14 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl =
   let ccl' = liftn_predicate n (k+1) ccl tms in
   (* We prepare the substitution of X and x:I(X) *)
   let realargsi =
-    if nrealargs <> 0 then
+    if not (Int.equal nrealargs 0) then
       adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs)
     else
       [] in
-  let copti =
-    if depna<>Anonymous then Some (build_dependent_constructor cs) else None in
+  let copti = match depna with
+  | Anonymous -> None
+  | Name _ -> Some (build_dependent_constructor cs)
+  in
   (* The substituends realargsi, copti are all defined in gamma, x1...xn *)
   (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *)
   (* Note: applying the substitution in tms is not important (is it sure?) *)
@@ -992,7 +1034,10 @@ let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb =
   let ((_,oldtyp),deps,na) = tomatch in
   match typ, oldtyp with
   | IsInd (_,_,names), NotInd _ ->
-      let k = if na <> Anonymous then 2 else 1 in
+      let k = match na with
+      | Anonymous -> 1
+      | Name _ -> 2
+      in
       let n = List.length names in
       { pb with pred = liftn_predicate n k pb.pred pb.tomatch },
       (ct,List.map (fun i -> if i >= k then i+n else i) deps,na)
@@ -1004,7 +1049,7 @@ let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb =
 
 let rec ungeneralize n ng body =
   match kind_of_term body with
-  | Lambda (_,_,c) when ng = 0 ->
+  | Lambda (_,_,c) when Int.equal ng 0 ->
       subst1 (mkRel n) c
   | Lambda (na,t,c) ->
       (* We traverse an inner generalization *)
@@ -1019,7 +1064,7 @@ let rec ungeneralize n ng body =
         let sign2,p = decompose_prod_n_assum ng p in
         let p = prod_applist p [mkRel (n+List.length sign+ng)] in
         it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in
-      mkCase (ci,p,c,array_map2 (fun q c ->
+      mkCase (ci,p,c,Array.map2 (fun q c ->
         let sign,b = decompose_lam_n_assum q c in
         it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign)
         ci.ci_cstr_ndecls brs)
@@ -1032,15 +1077,44 @@ let rec ungeneralize n ng body =
 let ungeneralize_branch n k (sign,body) cs =
   (sign,ungeneralize (n+cs.cs_nargs) k body)
 
+let rec is_dependent_generalization ng body =
+  match kind_of_term body with
+  | Lambda (_,_,c) when Int.equal ng 0 ->
+      dependent (mkRel 1) c
+  | Lambda (na,t,c) ->
+      (* We traverse an inner generalization *)
+      is_dependent_generalization (ng-1) c
+  | LetIn (na,b,t,c) ->
+      (* We traverse an alias *)
+      is_dependent_generalization ng c
+  | Case (ci,p,c,brs) ->
+      (* We traverse a split *)
+      Array.exists2 (fun q c ->
+        let _,b = decompose_lam_n_assum q c in is_dependent_generalization ng b)
+        ci.ci_cstr_ndecls brs
+  | App (g,args) ->
+      (* We traverse an inner generalization *)
+      assert (isCase g);
+      is_dependent_generalization (ng+Array.length args) g
+  | _ -> assert false
+
+let is_dependent_branch k (_,br) =
+  is_dependent_generalization k br
+
 let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
   let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with
   | [], _ -> brs,tomatch,pred,[]
   | n::deps, Abstract (i,d) :: tomatch ->
       let d = map_rel_declaration (nf_evar evd) d in
-      if List.exists (fun c -> dependent_decl (lift k c) d) tocheck || pi2 d <> None then
+      let is_d = match d with (_, None, _) -> false | _ -> true in
+      if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck
+                 && Array.exists (is_dependent_branch k) brs then
         (* Dependency in the current term to match and its dependencies is real *)
         let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in
-        let inst = if pi2 d = None then mkRel n::inst else inst in
+        let inst = match d with
+        | (_, None, _) -> mkRel n :: inst
+        | _ -> inst
+        in
         brs, Abstract (i,d) :: tomatch, pred, inst
       else
         (* Finally, no dependency remains, so, we can replace the generalized *)
@@ -1049,7 +1123,7 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs =
         let pred = lift_predicate (-1) pred tomatch in
         let tomatch = relocate_index_tomatch 1 (n+1) tomatch in
         let tomatch = lift_tomatch_stack (-1) tomatch in
-        let brs = array_map2 (ungeneralize_branch n k) brs cs in
+        let brs = Array.map2 (ungeneralize_branch n k) brs cs in
         aux k brs tomatch pred tocheck deps
   | _ -> assert false
   in aux 0 brs tomatch pred tocheck deps
@@ -1062,8 +1136,8 @@ let rec irrefutable env = function
   | PatCstr (_,cstr,args,_) ->
       let ind = inductive_of_constructor cstr in
       let (_,mip) = Inductive.lookup_mind_specif env ind in
-      let one_constr = Array.length mip.mind_user_lc = 1 in
-      one_constr & List.for_all (irrefutable env) args
+      let one_constr = Int.equal (Array.length mip.mind_user_lc) 1 in
+      one_constr && List.for_all (irrefutable env) args
 
 let first_clause_irrefutable env = function
   | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
@@ -1072,8 +1146,8 @@ let first_clause_irrefutable env = function
 let group_equations pb ind current cstrs mat =
   let mat =
     if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
-  let brs = Array.create (Array.length cstrs) [] in
-  let only_default = ref true in
+  let brs = Array.make (Array.length cstrs) [] in
+  let only_default = ref None in
   let _ =
     List.fold_right (* To be sure it's from bottom to top *)
       (fun eqn () ->
@@ -1085,12 +1159,13 @@ let group_equations pb ind current cstrs mat =
 	       for i=1 to Array.length cstrs do
 		 let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in
 		 brs.(i-1) <- (args, name, rest) :: brs.(i-1)
-	       done
+	       done;
+	       if !only_default == None then only_default := Some true
 	   | PatCstr (loc,((_,i)),args,name) ->
 	       (* This is a regular clause *)
-	       only_default := false;
+	       only_default := Some false;
 	       brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in
-  (brs,!only_default)
+  (brs,Option.default false !only_default)
 
 (************************************************************************)
 (* Here starts the pattern-matching compilation algorithm *)
@@ -1101,14 +1176,17 @@ let rec generalize_problem names pb = function
   | i::l ->
       let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
       let pb',deps = generalize_problem names pb l in
-      if na = Anonymous & b <> None then pb',deps else
-      let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
-      let tomatch = lift_tomatch_stack 1 pb'.tomatch in
-      let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
-      { pb' with
-	  tomatch = Abstract (i,d) :: tomatch;
-          pred = generalize_predicate names i d pb'.tomatch pb'.pred  },
-      i::deps
+      begin match (na, b) with
+      | Anonymous, Some _ -> pb', deps
+      | _ ->
+        let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *)
+        let tomatch = lift_tomatch_stack 1 pb'.tomatch in
+        let tomatch = relocate_index_tomatch (i+1) 1 tomatch in
+        { pb' with
+            tomatch = Abstract (i,d) :: tomatch;
+            pred = generalize_predicate names i d pb'.tomatch pb'.pred  },
+        i::deps
+      end
 
 (* No more patterns: typing the right-hand side of equations *)
 let build_leaf pb =
@@ -1117,10 +1195,12 @@ let build_leaf pb =
   j_nf_evar !(pb.evdref) j
 
 (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *)
-let build_branch current realargs deps (realnames,curname) pb arsign eqns const_info =
+(* spiwack: the [initial] argument keeps track whether the branch is a
+   toplevel branch ([true]) or a deep one ([false]). *)
+let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info =
   (* We remember that we descend through constructor C *)
   let history =
-    push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in
+    push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in
 
   (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *)
   (* build the name x1..xn from the names present in the equations *)
@@ -1137,9 +1217,9 @@ let build_branch current realargs deps (realnames,curname) pb arsign eqns const_
   (* We adjust the terms to match in the context they will be once the *)
   (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *)
   let typs' =
-    list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
+    List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in
 
-  let extenv = push_rels typs pb.env in
+  let extenv = push_rel_context typs pb.env in
 
   let typs' =
     List.map (fun (c,d) ->
@@ -1176,10 +1256,11 @@ let build_branch current realargs deps (realnames,curname) pb arsign eqns const_
   let typs' =
     List.map2
       (fun (tm,(tmtyp,_),(na,_,_)) deps ->
-	let na = match curname with
-	| Name _ -> (if na <> Anonymous then na else curname)
-	| Anonymous ->
-	    if deps = [] && pred_is_not_dep then Anonymous else force_name na in
+	let na = match curname, na with
+	| Name _, Anonymous -> curname
+	| Name _, Name _ -> na
+	| Anonymous, _ ->
+	    if List.is_empty deps && pred_is_not_dep then Anonymous else force_name na in
 	((tm,tmtyp),deps,na))
       typs' (List.rev dep_sign) in
 
@@ -1187,26 +1268,29 @@ let build_branch current realargs deps (realnames,curname) pb arsign eqns const_
   let pred =
     specialize_predicate typs' (realnames,curname) arsign const_info tomatch pb.pred in
 
-  let currents = List.map (fun x -> Pushed x) typs' in
+  let currents = List.map (fun x -> Pushed (false,x)) typs' in
 
-  let alias =
-    if aliasname = Anonymous then
+  let alias = match aliasname with
+  | Anonymous ->
       NonDepAlias
-    else
+  | Name _ ->
       let cur_alias = lift const_info.cs_nargs current in
       let ind =
         appvect (
-          applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+          applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr),
                    List.map (lift const_info.cs_nargs) const_info.cs_params),
           const_info.cs_concl_realargs) in
-      Alias (aliasname,cur_alias,(ci,ind)) in
+      Alias (initial,(aliasname,cur_alias,(ci,ind))) in
 
   let tomatch = List.rev_append (alias :: currents) tomatch in
 
   let submat = adjust_impossible_cases pb pred tomatch submat in
-  if submat = [] then
+  let () = match submat with
+  | [] ->
     raise_pattern_matching_error
-      (dummy_loc, pb.env, NonExhaustive (complete_history history));
+      (Loc.ghost, pb.env, Evd.empty, NonExhaustive (complete_history history))
+  | _ -> ()
+  in
 
   typs,
   { pb with
@@ -1227,38 +1311,48 @@ let build_branch current realargs deps (realnames,curname) pb arsign eqns const_
 
 *)
 
+let mk_case pb (ci,pred,c,brs) =
+  let mib = lookup_mind (fst ci.ci_ind) pb.env in
+    match mib.mind_record with
+    | Some (Some (_, cs, pbs)) ->
+      Reduction.beta_appvect brs.(0) 
+	(Array.map (fun p -> mkProj (Projection.make p true, c)) cs)
+    | _ -> mkCase (ci,pred,c,brs)
+
 (**********************************************************************)
 (* Main compiling descent *)
 let rec compile pb =
   match pb.tomatch with
     | Pushed cur :: rest -> match_current { pb with tomatch = rest } cur
-    | Alias x :: rest -> compile_alias pb x rest
+    | Alias (initial,x) :: rest -> compile_alias initial pb x rest
     | NonDepAlias :: rest -> compile_non_dep_alias pb rest
     | Abstract (i,d) :: rest -> compile_generalization pb i d rest
     | [] -> build_leaf pb
 
 (* Case splitting *)
-and match_current pb tomatch =
+and match_current pb (initial,tomatch) =
   let tm = adjust_tomatch_to_pattern pb tomatch in
   let pb,tomatch = adjust_predicate_from_tomatch tomatch tm pb in
   let ((current,typ),deps,dep) = tomatch in
   match typ with
     | NotInd (_,typ) ->
-	check_all_variables typ pb.mat;
-	shift_problem tomatch pb
+	check_all_variables pb.env !(pb.evdref) typ pb.mat;
+	compile_all_variables initial tomatch pb
     | IsInd (_,(IndType(indf,realargs) as indt),names) ->
 	let mind,_ = dest_ind_family indf in
+        let mind = Tacred.check_privacy pb.env mind in
 	let cstrs = get_constructors pb.env indf in
 	let arsign, _ = get_arity pb.env indf in
-	let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
-	if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt  then
-	  shift_problem tomatch pb
+	let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in
+        let no_cstr = Int.equal (Array.length cstrs) 0 in
+	if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then
+	  compile_all_variables initial tomatch pb
 	else
 	  (* We generalize over terms depending on current term to match *)
 	  let pb,deps = generalize_problem (names,dep) pb deps in
 
 	  (* We compile branches *)
-	  let brvals = array_map2 (compile_branch current realargs (names,dep) deps pb arsign) eqns cstrs in
+	  let brvals = Array.map2 (compile_branch initial current realargs (names,dep) deps pb arsign) eqns cstrs in
 	  (* We build the (elementary) case analysis *)
           let depstocheck = current::binding_vars_of_inductive typ in
           let brvals,tomatch,pred,inst =
@@ -1269,14 +1363,16 @@ and match_current pb tomatch =
 	  let (pred,typ) =
 	    find_predicate pb.caseloc pb.env pb.evdref
 	      pred current indt (names,dep) tomatch in
-	  let ci = make_case_info pb.env mind pb.casestyle in
+	  let ci = make_case_info pb.env (fst mind) pb.casestyle in
 	  let pred = nf_betaiota !(pb.evdref) pred in
-	  let case = mkCase (ci,pred,current,brvals) in
+	  let case = mk_case pb (ci,pred,current,brvals) in
 	  Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred;
 	  { uj_val = applist (case, inst);
 	    uj_type = prod_applist typ inst }
 
-(* Building the sub-problem when all patterns are variables *)
+
+(* Building the sub-problem when all patterns are variables. Case
+   where [current] is an intially pushed term. *)
 and shift_problem ((current,t),_,na) pb =
   let ty = type_of_tomatch t in
   let tomatch = lift_tomatch_stack 1 pb.tomatch in
@@ -1292,9 +1388,27 @@ and shift_problem ((current,t),_,na) pb =
   { uj_val = subst1 current j.uj_val;
     uj_type = subst1 current j.uj_type }
 
+(* Building the sub-problem when all patterns are variables,
+   non-initial case. Variables which appear as subterms of constructor
+   are already introduced in the context, we avoid creating aliases to
+   themselves by treating this case specially. *)
+and pop_problem ((current,t),_,na) pb =
+  let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in
+  let pb =
+    { pb with
+       pred = pred;
+       history = pop_history pb.history;
+       mat = List.map push_noalias_current_pattern pb.mat } in
+  compile pb
+
+(* Building the sub-problem when all patterns are variables. *)
+and compile_all_variables initial cur pb =
+  if initial then shift_problem cur pb
+  else pop_problem cur pb
+
 (* Building the sub-problem when all patterns are variables *)
-and compile_branch current realargs names deps pb arsign eqns cstr =
-  let sign, pb = build_branch current realargs deps names pb arsign eqns cstr in
+and compile_branch initial current realargs names deps pb arsign eqns cstr =
+  let sign, pb = build_branch initial current realargs deps names pb arsign eqns cstr in
   sign, (compile pb).uj_val
 
 (* Abstract over a declaration before continuing splitting *)
@@ -1308,7 +1422,10 @@ and compile_generalization pb i d rest =
   { uj_val = mkLambda_or_LetIn d j.uj_val;
     uj_type = mkProd_wo_LetIn d j.uj_type }
 
-and compile_alias pb (na,orig,(expanded,expanded_typ)) rest =
+(* spiwack: the [initial] argument keeps track whether the alias has
+   been introduced by a toplevel branch ([true]) or a deep one
+   ([false]). *)
+and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest =
   let f c t =
     let alias = (na,Some c,t) in
     let pb =
@@ -1325,18 +1442,35 @@ and compile_alias pb (na,orig,(expanded,expanded_typ)) rest =
         else
           mkLetIn (na,c,t,j.uj_val);
       uj_type = subst1 c j.uj_type } in
-  if isRel orig or isVar orig then
+  (* spiwack: when an alias appears on a deep branch, its non-expanded
+     form is automatically a variable of the same name. We avoid
+     introducing such superfluous aliases so that refines are elegant. *)
+  let just_pop () =
+    let pb =
+      { pb with
+        tomatch = rest;
+        history = pop_history_pattern pb.history;
+        mat = List.map drop_alias_eqn pb.mat } in
+    compile pb
+  in
+  let sigma = !(pb.evdref) in
+  if not (Flags.is_program_mode ()) && (isRel orig || isVar orig) then
     (* Try to compile first using non expanded alias *)
-    try f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+    try
+      if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+      else just_pop ()
     with e when precatchable_exception e ->
     (* Try then to compile using expanded alias *)
+    pb.evdref := sigma;
     f expanded expanded_typ
   else
     (* Try to compile first using expanded alias *)
     try f expanded expanded_typ
     with e when precatchable_exception e ->
     (* Try then to compile using non expanded alias *)
-    f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+    pb.evdref := sigma;
+    if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig)
+    else just_pop ()
 
 
 (* Remember that a non-trivial pattern has been consumed *)
@@ -1357,7 +1491,7 @@ substituer après par les initiaux *)
 (* builds the matrix of equations testing that each eqn has n patterns
  * and linearizing the _ patterns.
  * Syntactic correctness has already been done in astterm *)
-let matx_of_eqns env tomatchl eqns =
+let matx_of_eqns env eqns =
   let build_eqn (loc,ids,lpat,rhs) =
     let initial_lpat,initial_rhs = lpat,rhs in
     let initial_rhs = rhs in
@@ -1412,27 +1546,30 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t =
      - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u]
        and both are adjusted to [extenv] while [p] is the index of [id] in
        [extenv] (after expansion of the aliases) *)
-  let subst0 = map_succeed (fun (x,u) ->
+  let map (x, u) =
     (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *)
     (* \--env-/          (= x:ty)         *)
     (* \--------------extenv------------/ *)
-    let (p,_,_) = lookup_rel_id x (rel_context extenv) in
+    let (p, _, _) = lookup_rel_id x (rel_context extenv) in
     let rec traverse_local_defs p =
       match pi2 (lookup_rel p extenv) with
       | Some c -> assert (isRel c); traverse_local_defs (p + destRel c)
       | None -> p in
     let p = traverse_local_defs p in
-    let u = lift (n'-n) u in
-    (p,u,expand_vars_in_term extenv u)) subst in
-  let t0 = lift (n'-n) t in
-  (subst0,t0)
+    let u = lift (n' - n) u in
+    try Some (p, u, expand_vars_in_term extenv u)
+      (* pedrot: does this really happen to raise [Failure _]? *)
+    with Failure _ -> None in
+  let subst0 = List.map_filter map subst in
+  let t0 = lift (n' - n) t in
+  (subst0, t0)
 
 let push_binder d (k,env,subst) =
   (k+1,push_rel d env,List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst)
 
 let rec list_assoc_in_triple x = function
     [] -> raise Not_found
-  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l
+  | (a, b, _)::l -> if Int.equal a x then b else list_assoc_in_triple x l
 
 (* Let vijk and ti be a set of dependent terms and T a type, all
  * defined in some environment env. The vijk and ti are supposed to be
@@ -1449,9 +1586,11 @@ let rec list_assoc_in_triple x = function
  * similarly for each ti.
 *)
 
-let abstract_tycon loc env evdref subst _tycon extenv t =
-  let sigma = !evdref in
-  let t = nf_betaiota sigma t in (* it helps in some cases to remove K-redex *)
+let abstract_tycon loc env evdref subst tycon extenv t =
+  let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*)
+  let src = match kind_of_term t with
+    | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk)
+    | _ -> (loc,Evar_kinds.CasesType true) in
   let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv subst t in
   (* We traverse the type T of the original problem Xi looking for subterms
      that match the non-constructor part of the constraints (this part
@@ -1460,42 +1599,49 @@ let abstract_tycon loc env evdref subst _tycon extenv t =
      convertible subterms of the substitution *)
   let rec aux (k,env,subst as x) t =
     let t = whd_evar !evdref t in match kind_of_term t with
-    | Rel n when pi2 (lookup_rel n env) <> None ->
-        map_constr_with_full_binders push_binder aux x t
+    | Rel n when pi2 (lookup_rel n env) != None -> t
     | Evar ev ->
-        let ty = get_type_of env sigma t in
+        let ty = get_type_of env !evdref t in
+	let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in
         let inst =
-	  list_map_i
+	  List.map_i
 	    (fun i _ ->
               try list_assoc_in_triple i subst0 with Not_found -> mkRel i)
               1 (rel_context env) in
-        let ev = e_new_evar evdref env ~src:(loc, CasesType) ty in
-        evdref := add_conv_pb (Reduction.CONV,env,substl inst ev,t) !evdref;
-        ev
+        let ev' = e_new_evar env evdref ~src ty in
+        begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with
+        | Success evd -> evdref := evd
+        | UnifFailure _ -> assert false
+        end;
+        ev'
     | _ ->
-    let good = List.filter (fun (_,u,_) -> is_conv_leq env sigma t u) subst in
-    if good <> [] then
-      let u = pi3 (List.hd good) in (* u is in extenv *)
+    let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref t u) subst in
+    match good with
+    | [] ->
+      map_constr_with_full_binders push_binder aux x t
+    | (_, _, u) :: _ -> (* u is in extenv *)
       let vl = List.map pi1 good in
-      let ty = lift (-k) (aux x (get_type_of env !evdref t)) in
+      let ty = 
+	let ty = get_type_of env !evdref t in
+	  Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty
+      in
+      let ty = lift (-k) (aux x ty) in
       let depvl = free_rels ty in
       let inst =
-	list_map_i
-	  (fun i _ -> if List.mem i vl then u else mkRel i) 1
+	List.map_i
+	  (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1
 	  (rel_context extenv) in
       let rel_filter =
 	List.map (fun a -> not (isRel a) || dependent a u
-                           || Intset.mem (destRel a) depvl) inst in
+                           || Int.Set.mem (destRel a) depvl) inst in
       let named_filter =
 	List.map (fun (id,_,_) -> dependent (mkVar id) u)
 	  (named_context extenv) in
-      let filter = rel_filter@named_filter in
+      let filter = Filter.make (rel_filter @ named_filter) in
       let candidates = u :: List.map mkRel vl in
-      let ev =
-	e_new_evar evdref extenv ~src:(loc, CasesType) ~filter ~candidates ty in
+      let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in
       lift k ev
-    else
-      map_constr_with_full_binders push_binder aux x t in
+  in
   aux (0,extenv,subst0) t0
 
 let build_tycon loc env tycon_env subst tycon extenv evdref t =
@@ -1505,10 +1651,9 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t =
            we are in an impossible branch *)
 	let n = rel_context_length (rel_context env) in
 	let n' = rel_context_length (rel_context tycon_env) in
-        let tt = new_Type () in
-	let impossible_case_type =
-	  e_new_evar evdref env ~src:(loc,ImpossibleCase) tt in
-	(lift (n'-n) impossible_case_type, tt)
+	let impossible_case_type, u =
+	  e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in
+	(lift (n'-n) impossible_case_type, mkSort u)
     | Some t ->
         let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in
         let evd,tt = Typing.e_type_of extenv !evdref t in
@@ -1529,33 +1674,33 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t =
 let build_inversion_problem loc env sigma tms t =
   let make_patvar t (subst,avoid) =
     let id = next_name_away (named_hd env t Anonymous) avoid in
-    PatVar (dummy_loc,Name id), ((id,t)::subst, id::avoid) in
+    PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in
   let rec reveal_pattern t (subst,avoid as acc) =
     match kind_of_term (whd_betadeltaiota env sigma t) with
-    | Construct cstr -> PatCstr (dummy_loc,cstr,[],Anonymous), acc
+    | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc
     | App (f,v) when isConstruct f ->
-	let cstr = destConstruct f in
-	let n = constructor_nrealargs env cstr in
-	let l = list_lastn n (Array.to_list v) in
-	let l,acc = list_fold_map' reveal_pattern l acc in
-	PatCstr (dummy_loc,cstr,l,Anonymous), acc
+	let cstr,u = destConstruct f in
+	let n = constructor_nrealargs_env env cstr in
+	let l = List.lastn n (Array.to_list v) in
+	let l,acc = List.fold_map' reveal_pattern l acc in
+	PatCstr (Loc.ghost,cstr,l,Anonymous), acc
     | _ -> make_patvar t acc in
   let rec aux n env acc_sign tms acc =
     match tms with
     | [] -> [], acc_sign, acc
     | (t, IsInd (_,IndType(indf,realargs),_)) :: tms ->
-	let patl,acc = list_fold_map' reveal_pattern realargs acc in
+	let patl,acc = List.fold_map' reveal_pattern realargs acc in
 	let pat,acc = make_patvar t acc in
 	let indf' = lift_inductive_family n indf in
 	let sign = make_arity_signature env true indf' in
 	let sign = recover_alias_names alias_of_pat (pat :: List.rev patl) sign in
 	let p = List.length realargs in
-	let env' = push_rels sign env in
+	let env' = push_rel_context sign env in
 	let patl',acc_sign,acc = aux (n+p+1) env' (sign@acc_sign) tms acc in
 	patl@pat::patl',acc_sign,acc
     | (t, NotInd (bo,typ)) :: tms ->
       let pat,acc = make_patvar t acc in
-      let d = (alias_of_pat pat,None,t) in
+      let d = (alias_of_pat pat,None,typ) in
       let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in
       pat::patl,acc_sign,acc in
   let avoid0 = ids_of_context env in
@@ -1572,19 +1717,19 @@ let build_inversion_problem loc env sigma tms t =
   let n = List.length sign in
 
   let decls =
-    list_map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
+    List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in
 
-  let pb_env = push_rels sign env in
+  let pb_env = push_rel_context sign env in
   let decls =
     List.map (fun (c,d) -> (c,extract_inductive_data pb_env sigma d,d)) decls in
 
   let decls = List.rev decls in
-  let dep_sign = find_dependencies_signature (list_make n true) decls in
+  let dep_sign = find_dependencies_signature (List.make n true) decls in
 
   let sub_tms =
     List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) ->
-      let na = if deps = [] then Anonymous else force_name na in
-      Pushed ((tm,tmtyp),deps,na))
+      let na = if List.is_empty deps then Anonymous else force_name na in
+      Pushed (true,((tm,tmtyp),deps,na)))
       dep_sign decls in
   let subst = List.map (fun (na,t) -> (na,lift n t)) subst in
   (* [eqn1] is the first clause of the auxiliary pattern-matching that
@@ -1595,7 +1740,7 @@ let build_inversion_problem loc env sigma tms t =
   let eqn1 =
     { patterns = patl;
       alias_stack = [];
-      eqn_loc = dummy_loc;
+      eqn_loc = Loc.ghost;
       used = ref false;
       rhs = { rhs_env = pb_env;
               (* we assume all vars are used; in practice we discard dependent
@@ -1608,9 +1753,9 @@ let build_inversion_problem loc env sigma tms t =
      type constraints are incompatible with the constraints on the
      inductive types of the multiple terms matched in Xi *)
   let eqn2 =
-    { patterns = List.map (fun _ -> PatVar (dummy_loc,Anonymous)) patl;
+    { patterns = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) patl;
       alias_stack = [];
-      eqn_loc = dummy_loc;
+      eqn_loc = Loc.ghost;
       used = ref false;
       rhs = { rhs_env = pb_env;
               rhs_vars = [];
@@ -1618,11 +1763,18 @@ let build_inversion_problem loc env sigma tms t =
 	      it = None } } in
   (* [pb] is the auxiliary pattern-matching serving as skeleton for the
       return type of the original problem Xi *)
+  (* let sigma, s = Evd.new_sort_variable sigma in *)
+(*FIXME TRY *)
+  (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *)
+  let s' = Retyping.get_sort_of env sigma t in
+  let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in
+  let sigma = Evd.set_leq_sort env sigma s' s in
   let evdref = ref sigma in
+  (* let ty = evd_comb1 (refresh_universes false) evdref ty in *)
   let pb =
     { env       = pb_env;
       evdref    = evdref;
-      pred      = new_Type();
+      pred      = (*ty *) mkSort s;
       tomatch   = sub_tms;
       history   = start_history n;
       mat       = [eqn1;eqn2];
@@ -1643,30 +1795,30 @@ let build_initial_predicate arsign pred =
     | _ -> assert false
   in buildrec 0 pred [] (List.rev arsign)
 
-let extract_arity_signature env0 tomatchl tmsign =
+let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
+  let lift = if dolift then lift else fun n t -> t in
   let get_one_sign n tm (na,t) =
     match tm with
       | NotInd (bo,typ) ->
 	  (match t with
 	    | None -> [na,Option.map (lift n) bo,lift n typ]
-	    | Some (loc,_,_,_) ->
+	    | Some (loc,_,_) ->
  	    user_err_loc (loc,"",
 	    str"Unexpected type annotation for a term of non inductive type."))
       | IsInd (term,IndType(indf,realargs),_) ->
-          let indf' = lift_inductive_family n indf in
-	  let (ind,_) = dest_ind_family indf' in
-	  let nparams_ctxt,nrealargs_ctxt = inductive_nargs env0 ind in
+          let indf' = if dolift then lift_inductive_family n indf else indf in
+	  let ((ind,u),_) = dest_ind_family indf' in
+	  let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in
 	  let arsign = fst (get_arity env0 indf') in
 	  let realnal =
 	    match t with
-	      | Some (loc,ind',nparams,realnal) ->
-		  if ind <> ind' then
+	      | Some (loc,ind',realnal) ->
+		  if not (eq_ind ind ind') then
 		    user_err_loc (loc,"",str "Wrong inductive type.");
-		  if nparams_ctxt <> nparams
-		    or nrealargs_ctxt <> List.length realnal then
-		      anomaly "Ill-formed 'in' clause in cases";
+		  if not (Int.equal nrealargs_ctxt (List.length realnal)) then
+		      anomaly (Pp.str "Ill-formed 'in' clause in cases");
 		  List.rev realnal
-	      | None -> list_make nrealargs_ctxt Anonymous in
+	      | None -> List.make nrealargs_ctxt Anonymous in
 	  (na,None,build_dependent_inductive env0 indf')
 	  ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
   let rec buildrec n = function
@@ -1694,7 +1846,7 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c =
       let signlen = List.length sign in
 	match kind_of_term tm with
 	  | Rel n when dependent tm c
-		&& signlen = 1 (* The term to match is not of a dependent type itself *) ->
+		&& Int.equal signlen 1 (* The term to match is not of a dependent type itself *) ->
 	      ((n, len) :: subst, len - signlen)
 	  | Rel n when signlen > 1 (* The term is of a dependent type,
 				      maybe some variable in its type appears in the tycon. *) ->
@@ -1720,7 +1872,7 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c =
       | Rel n when n > lift ->
 	  (try
 	      (* Make the predicate dependent on the matched variable *)
-	      let idx = List.assoc (n - lift) subst in
+	      let idx = Int.List.assoc (n - lift) subst in
 		mkRel (idx + lift)
 	    with Not_found ->
 	      (* A variable that is not matched, lift over the arsign. *)
@@ -1741,11 +1893,11 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c =
  * tycon to make the predicate if it is not closed.
  *)
 
-let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred =
+let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred =
   let preds =
     match pred, tycon with
     (* No type annotation *)
-    | None, Some (None, t) when not (noccur_with_meta 0 max_int t) ->
+    | None, Some t when not (noccur_with_meta 0 max_int t) ->
 	(* If the tycon is not closed w.r.t real variables, we try *)
         (* two different strategies *)
 	(* First strategy: we abstract the tycon wrt to the dependencies *)
@@ -1758,8 +1910,12 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred =
 	(* No dependent type constraint, or no constraints at all: *)
 	(* we use two strategies *)
         let sigma,t = match tycon with
-	| Some (None, t) -> sigma,t
-	| _ -> new_type_evar sigma env ~src:(loc, CasesType) in
+	| Some t -> sigma,t
+	| None -> 
+	  let sigma, (t, _) = 
+	    new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in
+	    sigma, t
+	in
         (* First strategy: we build an "inversion" predicate *)
 	let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in
 	(* Second strategy: we directly use the evar as a non dependent pred *)
@@ -1768,16 +1924,17 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred =
     (* Some type annotation *)
     | Some rtntyp, _ ->
       (* We extract the signature of the arity *)
-      let envar = List.fold_right push_rels arsign env in
-      let sigma, newt = new_sort_variable sigma in
+      let envar = List.fold_right push_rel_context arsign env in
+      let sigma, newt = new_sort_variable univ_flexible_alg sigma in
       let evdref = ref sigma in
       let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in
-      let sigma = Option.cata (fun tycon ->
-          let na = Name (id_of_string "x") in
-          let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in
-          let predinst = extract_predicate predcclj.uj_val tms in
-          Coercion.inh_conv_coerces_to loc env !evdref predinst tycon)
-        !evdref tycon in
+      let sigma = !evdref in
+      (* let sigma = Option.cata (fun tycon -> *)
+      (*     let na = Name (Id.of_string "x") in *)
+      (*     let tms = List.map (fun tm -> Pushed(tm,[],na)) tomatchs in *)
+      (*     let predinst = extract_predicate predcclj.uj_val tms in *)
+      (*     Coercion.inh_conv_coerce_to loc env !evdref predinst tycon) *)
+      (*   !evdref tycon in *)
       let predccl = (j_nf_evar sigma predcclj).uj_val in
       [sigma, predccl]
   in
@@ -1787,23 +1944,537 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred =
       sigma,nal,pred)
     preds
 
+(** Program cases *)
+
+open Program
+
+let ($) f x = f x
+
+let string_of_name name =
+  match name with
+    | Anonymous -> "anonymous"
+    | Name n -> Id.to_string n
+
+let make_prime_id name =
+  let str = string_of_name name in
+    Id.of_string str, Id.of_string (str ^ "'")
+
+let prime avoid name =
+  let previd, id = make_prime_id name in
+    previd, next_ident_away id avoid
+
+let make_prime avoid prevname =
+  let previd, id = prime !avoid prevname in
+    avoid := id :: !avoid;
+    previd, id
+
+let eq_id avoid id =
+  let hid = Id.of_string ("Heq_" ^ Id.to_string id) in
+  let hid' = next_ident_away hid avoid in
+    hid'
+
+let mk_eq evdref typ x y = papp evdref coq_eq_ind [| typ; x ; y |]
+let mk_eq_refl evdref typ x = papp evdref coq_eq_refl [| typ; x |]
+let mk_JMeq evdref typ x typ' y =
+  papp evdref coq_JMeq_ind [| typ; x ; typ'; y |]
+let mk_JMeq_refl evdref typ x = 
+  papp evdref coq_JMeq_refl [| typ; x |]
+
+let hole = GHole (Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define true), Misctypes.IntroAnonymous, None)
+
+let constr_of_pat env evdref arsign pat avoid =
+  let rec typ env (ty, realargs) pat avoid =
+    match pat with
+    | PatVar (l,name) ->
+	let name, avoid = match name with
+	    Name n -> name, avoid
+	  | Anonymous ->
+	      let previd, id = prime avoid (Name (Id.of_string "wildcard")) in
+		Name id, id :: avoid
+	in
+	  (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, 
+	   (List.map (fun x -> mkRel 1) realargs), 1, avoid)
+    | PatCstr (l,((_, i) as cstr),args,alias) ->
+	let cind = inductive_of_constructor cstr in
+	let IndType (indf, _) = 
+	  try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty)
+	  with Not_found -> error_case_not_inductive env 
+	    {uj_val = ty; uj_type = Typing.type_of env !evdref ty}
+	in
+	let (ind,u), params = dest_ind_family indf in
+	if not (eq_ind ind cind) then error_bad_constructor_loc l env cstr ind;
+	let cstrs = get_constructors env indf in
+	let ci = cstrs.(i-1) in
+	let nb_args_constr = ci.cs_nargs in
+	assert (Int.equal nb_args_constr (List.length args));
+	let patargs, args, sign, env, n, m, avoid =
+	  List.fold_right2
+	    (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid)  ->
+	       let pat', sign', arg', typ', argtypargs, n', avoid =
+		 let liftt = liftn (List.length sign) (succ (List.length args)) t in
+		   typ env (substl args liftt, []) ua avoid
+	       in
+	       let args' = arg' :: List.map (lift n') args in
+	       let env' = push_rel_context sign' env in
+		 (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid))
+	    ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid)
+	in
+	let args = List.rev args in
+	let patargs = List.rev patargs in
+	let pat' = PatCstr (l, cstr, patargs, alias) in
+	let cstr = mkConstructU ci.cs_cstr in
+	let app = applistc cstr (List.map (lift (List.length sign)) params) in
+	let app = applistc app args in
+	let apptype = Retyping.get_type_of env ( !evdref) app in
+	let IndType (indf, realargs) = find_rectype env ( !evdref) apptype in
+	  match alias with
+	      Anonymous ->
+		pat', sign, app, apptype, realargs, n, avoid
+	    | Name id ->
+		let sign = (alias, None, lift m ty) :: sign in
+		let avoid = id :: avoid in
+		let sign, i, avoid =
+		  try
+		    let env = push_rel_context sign env in
+		    evdref := the_conv_x_leq (push_rel_context sign env)
+		      (lift (succ m) ty) (lift 1 apptype) !evdref;
+		    let eq_t = mk_eq evdref (lift (succ m) ty)
+		      (mkRel 1) (* alias *)
+		      (lift 1 app) (* aliased term *)
+		    in
+		    let neq = eq_id avoid id in
+		      (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+		  with Reduction.NotConvertible -> sign, 1, avoid
+		in
+		  (* Mark the equality as a hole *)
+		  pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
+  in
+  let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
+    pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+
+
+(* shadows functional version *)
+let eq_id avoid id =
+  let hid = Id.of_string ("Heq_" ^ Id.to_string id) in
+  let hid' = next_ident_away hid !avoid in
+    avoid := hid' :: !avoid;
+    hid'
+
+let is_topvar t =
+match kind_of_term t with
+| Rel 0 -> true
+| _ -> false
+
+let rels_of_patsign l =
+  List.map (fun ((na, b, t) as x) ->
+    match b with
+      | Some t' when is_topvar t' -> (na, None, t)
+      | _ -> x) l
+
+let vars_of_ctx ctx =
+  let _, y =
+    List.fold_right (fun (na, b, t)  (prev, vars) ->
+      match b with
+	| Some t' when is_topvar t' ->
+	    prev,
+	    (GApp (Loc.ghost,
+		(GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), 
+		   [hole; GVar (Loc.ghost, prev)])) :: vars
+	| _ ->
+	    match na with
+		Anonymous -> invalid_arg "vars_of_ctx"
+	      | Name n -> n, GVar (Loc.ghost, n) :: vars)
+      ctx (Id.of_string "vars_of_ctx_error", [])
+  in List.rev y
+
+let rec is_included x y =
+  match x, y with
+    | PatVar _, _ -> true
+    | _, PatVar _ -> true
+    | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias')  ->
+	if Int.equal i i' then List.for_all2 is_included args args'
+	else false
+
+(* liftsign is the current pattern's complete signature length. 
+   Hence pats is already typed in its
+   full signature. However prevpatterns are in the original one signature per pattern form.
+ *)
+let build_ineqs evdref prevpatterns pats liftsign =
+  let _tomatchs = List.length pats in
+  let diffs =
+    List.fold_left
+      (fun c eqnpats ->
+	  let acc = List.fold_left2
+	    (* ppat is the pattern we are discriminating against, curpat is the current one. *)
+	    (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
+	      (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
+	      match acc with
+		  None -> None
+		| Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *)
+		    if is_included curpat ppat then
+		      (* Length of previous pattern's signature *)
+		      let lens = List.length ppat_sign in
+		      (* Accumulated length of previous pattern's signatures *)
+		      let len' = lens + len in
+		      let acc =
+			((* Jump over previous prevpat signs *)
+			  lift_rel_context len ppat_sign @ sign,
+			  len',
+			  succ n, (* nth pattern *)
+			 (papp evdref coq_eq_ind
+			    [| lift (len' + liftsign) curpat_ty;
+			       liftn (len + liftsign) (succ lens) ppat_c ;
+			       lift len' curpat_c |]) ::
+			   List.map (lift lens (* Jump over this prevpat signature *)) c)
+		      in Some acc
+		    else None)
+	   (Some ([], 0, 0, [])) eqnpats pats
+	 in match acc with
+	     None -> c
+	   | Some (sign, len, _, c') ->
+	       let conj = it_mkProd_or_LetIn (mk_coq_not (mk_coq_and c'))
+		 (lift_rel_context liftsign sign)
+	       in
+		 conj :: c)
+      [] prevpatterns
+  in match diffs with [] -> None
+    | _ -> Some (mk_coq_and diffs)
+
+let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
+  let i = ref 0 in
+  let (x, y, z) =
+    List.fold_left
+      (fun (branches, eqns, prevpatterns) eqn ->
+	 let _, newpatterns, pats =
+	   List.fold_left2
+	     (fun (idents, newpatterns, pats) pat arsign ->
+		let pat', cpat, idents = constr_of_pat env evdref arsign pat idents in
+		  (idents, pat' :: newpatterns, cpat :: pats))
+	      ([], [], []) eqn.patterns sign
+	 in
+	 let newpatterns = List.rev newpatterns and opats = List.rev pats in
+	 let rhs_rels, pats, signlen =
+	   List.fold_left
+	     (fun (renv, pats, n) (sign,c, (s, args), p) ->
+	       (* Recombine signatures and terms of all of the row's patterns *)
+	       let sign' = lift_rel_context n sign in
+	       let len = List.length sign' in
+		 (sign' @ renv,
+		 (* lift to get outside of previous pattern's signatures. *)
+		 (sign', liftn n (succ len) c, 
+		  (s, List.map (liftn n (succ len)) args), p) :: pats,
+		 len + n))
+	     ([], [], 0) opats in
+	 let pats, _ = List.fold_left
+	   (* lift to get outside of past patterns to get terms in the combined environment. *)
+	   (fun (pats, n) (sign, c, (s, args), p) ->
+	     let len = List.length sign in
+	       ((rels_of_patsign sign, lift n c,
+		 (s, List.map (lift n) args), p) :: pats, len + n))
+	   ([], 0) pats
+	 in
+	 let ineqs = build_ineqs evdref prevpatterns pats signlen in
+	 let rhs_rels' = rels_of_patsign rhs_rels in
+	 let _signenv = push_rel_context rhs_rels' env in
+	 let arity =
+	   let args, nargs =
+	     List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
+	       (args @ c :: allargs, List.length args + succ n))
+	       pats ([], 0)
+	   in
+	   let args = List.rev args in
+	     substl args (liftn signlen (succ nargs) arity)
+	 in
+	 let rhs_rels', tycon =
+	   let neqs_rels, arity =
+	     match ineqs with
+	     | None -> [], arity
+	     | Some ineqs ->
+		 [Anonymous, None, ineqs], lift 1 arity
+	   in
+	   let eqs_rels, arity = decompose_prod_n_assum neqs arity in
+	     eqs_rels @ neqs_rels @ rhs_rels', arity
+	 in
+	 let rhs_env = push_rel_context rhs_rels' env in
+	 let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in
+	 let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
+	 and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
+	 let _btype = evd_comb1 (Typing.e_type_of env) evdref bbody in
+	 let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in
+	 let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in
+	 let branch =
+	   let bref = GVar (Loc.ghost, branch_name) in
+	     match vars_of_ctx rhs_rels with
+		 [] -> bref
+	       | l -> GApp (Loc.ghost, bref, l)
+	 in
+	 let branch = match ineqs with
+	     Some _ -> GApp (Loc.ghost, branch, [ hole ])
+	   | None -> branch
+	 in
+	 incr i;
+	 let rhs = { eqn.rhs with it = Some branch } in
+	   (branch_decl :: branches,
+	   { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
+	   opats :: prevpatterns))
+      ([], [], []) eqns
+  in x, y
+
+(* Builds the predicate. If the predicate is dependent, its context is
+ * made of 1+nrealargs assumptions for each matched term in an inductive
+ * type and 1 assumption for each term not _syntactically_ in an
+ * inductive type.
+
+ * Each matched terms are independently considered dependent or not.
+
+ * A type constraint but no annotation case: it is assumed non dependent.
+ *)
+
+let lift_ctx n ctx =
+  let ctx', _ =
+    List.fold_right (fun (c, t) (ctx, n') -> 
+		       (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') 
+      ctx ([], 0)
+  in ctx'
+
+(* Turn matched terms into variables. *)
+let abstract_tomatch env tomatchs tycon =
+  let prev, ctx, names, tycon =
+    List.fold_left
+      (fun (prev, ctx, names, tycon) (c, t) ->
+	 let lenctx =  List.length ctx in
+	 match kind_of_term c with
+	     Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon
+	   | _ ->
+	       let tycon = Option.map
+		 (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in
+	       let name = next_ident_away (Id.of_string "filtered_var") names in
+		 (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev,
+	       (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx,
+	       name :: names, tycon)
+      ([], [], [], tycon) tomatchs
+  in List.rev prev, ctx, tycon
+
+let build_dependent_signature env evdref avoid tomatchs arsign =
+  let avoid = ref avoid in
+  let arsign = List.rev arsign in
+  let allnames = List.rev_map (List.map pi1) arsign in
+  let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+  let eqs, neqs, refls, slift, arsign' =
+    List.fold_left2
+      (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign ->
+	 (* The accumulator:
+	    previous eqs,
+	    number of previous eqs,
+	    lift to get outside eqs and in the introduced variables ('as' and 'in'),
+	    new arity signatures
+	 *)
+	 match ty with
+	 | IsInd (ty, IndType (indf, args), _) when List.length args > 0 ->
+	     (* Build the arity signature following the names in matched terms 
+		as much as possible *)
+	     let argsign = List.tl arsign in (* arguments in inverse application order *)
+	     let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
+	     let argsign = List.rev argsign in (* arguments in application order *)
+	     let env', nargeqs, argeqs, refl_args, slift, argsign' =
+	       List.fold_left2
+		 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
+		    let argt = Retyping.get_type_of env !evdref arg in
+		    let eq, refl_arg =
+		      if Reductionops.is_conv env !evdref argt t then
+			(mk_eq evdref (lift (nargeqs + slift) argt)
+			   (mkRel (nargeqs + slift))
+			   (lift (nargeqs + nar) arg),
+			 mk_eq_refl evdref argt arg)
+		      else
+			(mk_JMeq evdref (lift (nargeqs + slift) t)
+			   (mkRel (nargeqs + slift))
+			   (lift (nargeqs + nar) argt)
+			   (lift (nargeqs + nar) arg),
+			 mk_JMeq_refl evdref argt arg)
+		    in
+		    let previd, id =
+		      let name =
+			match kind_of_term arg with
+			Rel n -> pi1 (lookup_rel n env)
+			| _ -> name
+		      in
+			make_prime avoid name
+		    in
+		      (env, succ nargeqs,
+		       (Name (eq_id avoid previd), None, eq) :: argeqs,
+		       refl_arg :: refl_args,
+		       pred slift,
+		       (Name id, b, t) :: argsign'))
+		 (env, neqs, [], [], slift, []) args argsign
+	     in
+	     let eq = mk_JMeq evdref
+	       (lift (nargeqs + slift) appt)
+	       (mkRel (nargeqs + slift))
+	       (lift (nargeqs + nar) ty)
+	       (lift (nargeqs + nar) tm)
+	     in
+	     let refl_eq = mk_JMeq_refl evdref ty tm in
+	     let previd, id = make_prime avoid appn in
+	       (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+		succ nargeqs,
+		refl_eq :: refl_args,
+		pred slift,
+		(((Name id, appb, appt) :: argsign') :: arsigns))
+
+	 | _ -> (* Non dependent inductive or not inductive, just use a regular equality *)
+	     let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
+	     let previd, id = make_prime avoid name in
+	     let arsign' = (Name id, b, typ) in
+	     let tomatch_ty = type_of_tomatch ty in
+	     let eq =
+	       mk_eq evdref (lift nar tomatch_ty)
+		 (mkRel slift) (lift nar tm)
+	     in
+	       ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
+		(mk_eq_refl evdref tomatch_ty tm) :: refl_args,
+		pred slift, (arsign' :: []) :: arsigns))
+      ([], 0, [], nar, []) tomatchs arsign
+  in
+  let arsign'' = List.rev arsign' in
+    assert(Int.equal slift 0); (* we must have folded over all elements of the arity signature *)
+    arsign'', allnames, nar, eqs, neqs, refls
+
+let context_of_arsign l =
+  let (x, _) = List.fold_right
+    (fun c (x, n) ->
+       (lift_rel_context n c @ x, List.length c + n))
+    l ([], 0)
+  in x
+
+let compile_program_cases loc style (typing_function, evdref) tycon env
+    (predopt, tomatchl, eqns) =
+  let typing_fun tycon env = function
+    | Some t ->	typing_function tycon env evdref t
+    | None -> Evarutil.evd_comb0 use_unit_judge evdref in
+
+  (* We build the matrix of patterns and right-hand side *)
+  let matx = matx_of_eqns env eqns in
+
+  (* We build the vector of terms to match consistently with the *)
+  (* constructors found in patterns *)
+  let tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in
+  let tycon = valcon_of_tycon tycon in
+  let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in
+  let env = push_rel_context tomatchs_lets env in
+  let len = List.length eqns in
+  let sign, allnames, signlen, eqs, neqs, args =
+    (* The arity signature *)
+    let arsign = extract_arity_signature ~dolift:false env tomatchs tomatchl in
+      (* Build the dependent arity signature, the equalities which makes
+	 the first part of the predicate and their instantiations. *)
+    let avoid = [] in
+      build_dependent_signature env evdref avoid tomatchs arsign
+
+  in
+  let tycon, arity =
+    match tycon' with
+    | None -> let ev = mkExistential env evdref in ev, ev
+    | Some t ->
+	let pred = 
+	  try
+	    let pred = prepare_predicate_from_arsign_tycon loc tomatchs sign t in
+	      (* The tycon may be ill-typed after abstraction. *)
+	    let env' = push_rel_context (context_of_arsign sign) env in
+	      ignore(Typing.sort_of env' evdref pred); pred
+	  with e when Errors.noncritical e ->
+	    let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in
+	      lift nar t
+	in Option.get tycon, pred
+  in
+  let neqs, arity =
+    let ctx = context_of_arsign eqs in
+    let neqs = List.length ctx in
+      neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
+  in
+  let lets, matx =
+    (* Type the rhs under the assumption of equations *)
+    constrs_of_pats typing_fun env evdref matx tomatchs sign neqs arity
+  in
+  let matx = List.rev matx in
+  let _ = assert (Int.equal len (List.length lets)) in
+  let env = push_rel_context lets env in
+  let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
+  let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
+  let args = List.rev_map (lift len) args in
+  let pred = liftn len (succ signlen) arity in
+  let nal, pred = build_initial_predicate sign pred in
+
+  (* We push the initial terms to match and push their alias to rhs' envs *)
+  (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+
+  let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in
+  let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in
+    
+  let typs =
+    List.map (fun (c,d) -> (c,extract_inductive_data env !evdref d,d)) typs in
+    
+  let dep_sign =
+    find_dependencies_signature
+      (List.make (List.length typs) true)
+      typs in
+    
+  let typs' =
+    List.map3
+      (fun (tm,tmt) deps na ->
+         let deps = if not (isRel tm) then [] else deps in
+           ((tm,tmt),deps,na))
+      tomatchs dep_sign nal in
+    
+  let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in
+    
+  let typing_function tycon env evdref = function
+    | Some t ->	typing_function tycon env evdref t
+    | None -> evd_comb0 use_unit_judge evdref in
+
+  let pb =
+    { env      = env;
+      evdref   = evdref;
+      pred     = pred;
+      tomatch  = initial_pushed;
+      history  = start_history (List.length initial_pushed);
+      mat      = matx;
+      caseloc  = loc;
+      casestyle= style;
+      typing_function = typing_function } in
+
+  let j = compile pb in
+    (* We check for unused patterns *)
+    List.iter (check_unused_pattern env) matx;
+    let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
+    let j =
+      { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
+	uj_type = nf_evar !evdref tycon; }
+    in j
+
 (**************************************************************************)
 (* Main entry of the matching compilation                                 *)
 
 let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
-
+  if predopt == None && Flags.is_program_mode () then
+    compile_program_cases loc style (typing_fun, evdref) 
+      tycon env (predopt, tomatchl, eqns)
+  else
+      
   (* We build the matrix of patterns and right-hand side *)
-  let matx = matx_of_eqns env tomatchl eqns in
+  let matx = matx_of_eqns env eqns in
 
   (* We build the vector of terms to match consistently with the *)
   (* constructors found in patterns *)
   let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in
 
+
+
   (* If an elimination predicate is provided, we check it is compatible
      with the type of arguments to match; if none is provided, we
      build alternative possible predicates *)
   let arsign = extract_arity_signature env tomatchs tomatchl in
-  let preds = prepare_predicate loc typing_fun !evdref env tomatchs arsign tycon predopt in
+  let preds = prepare_predicate loc typing_fun env !evdref tomatchs arsign tycon predopt in
 
   let compile_for_one_predicate (sigma,nal,pred) =
     (* We push the initial terms to match and push their alias to rhs' envs *)
@@ -1818,22 +2489,22 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
 
     let dep_sign =
       find_dependencies_signature
-        (list_make (List.length typs) true)
+        (List.make (List.length typs) true)
         typs in
 
     let typs' =
-      list_map3
+      List.map3
         (fun (tm,tmt) deps na ->
           let deps = if not (isRel tm) then [] else deps in
           ((tm,tmt),deps,na))
         tomatchs dep_sign nal in
 
-    let initial_pushed = List.map (fun x -> Pushed x) typs' in
+    let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in
 
     (* A typing function that provides with a canonical term for absurd cases*)
     let typing_fun tycon env evdref = function
     | Some t ->	typing_fun tycon env evdref t
-    | None -> coq_unit_judge () in
+    | None -> evd_comb0 use_unit_judge evdref in
 
     let myevdref = ref sigma in
 
@@ -1862,4 +2533,3 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e
   (* We coerce to the tycon (if an elim predicate was provided) *)
   inh_conv_coerce_to_tycon loc env evdref j tycon
 
-end
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 826d68a4..c599766a 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -1,14 +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 Util
 open Names
 open Term
+open Context
 open Evd
 open Environ
 open Inductiveops
@@ -23,37 +23,101 @@ type pattern_matching_error =
   | BadConstructor of constructor * inductive
   | WrongNumargConstructor of constructor * int
   | WrongNumargInductive of inductive * int
-  | WrongPredicateArity of constr * constr * constr
-  | NeedsInversion of constr * constr
   | UnusedClause of cases_pattern list
   | NonExhaustive of cases_pattern list
   | CannotInferPredicate of (constr * types) array
 
-exception PatternMatchingError of env * pattern_matching_error
+exception PatternMatchingError of env * evar_map * pattern_matching_error
 
-val raise_pattern_matching_error : (loc * env * pattern_matching_error) -> 'a
+val error_wrong_numarg_constructor_loc : Loc.t -> env -> constructor -> int -> 'a
 
-val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a
+val error_wrong_numarg_inductive_loc : Loc.t -> env -> inductive -> int -> 'a
 
-val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a
+(** {6 Compilation primitive. } *)
 
-val error_bad_constructor_loc : loc -> constructor -> inductive -> 'a
+val compile_cases :
+  Loc.t -> case_style ->
+  (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
+  type_constraint ->
+  env -> glob_constr option * tomatch_tuples * cases_clauses ->
+  unsafe_judgment
 
-val error_bad_pattern_loc : loc -> constructor -> constr -> 'a
+val constr_of_pat : 
+           Environ.env ->
+           Evd.evar_map ref ->
+           rel_declaration list ->
+           Glob_term.cases_pattern ->
+           Names.Id.t list ->
+           Glob_term.cases_pattern *
+           (rel_declaration list * Term.constr *
+            (Term.types * Term.constr list) * Glob_term.cases_pattern) *
+           Names.Id.t list
 
-val error_wrong_predicate_arity_loc : loc -> env -> constr -> constr -> constr -> 'a
+type 'a rhs =
+    { rhs_env    : env;
+      rhs_vars   : Id.t list;
+      avoid_ids  : Id.t list;
+      it         : 'a option}
 
-val error_needs_inversion : env -> constr -> types -> 'a
+type 'a equation =
+    { patterns     : cases_pattern list;
+      rhs          : 'a rhs;
+      alias_stack  : Name.t list;
+      eqn_loc      : Loc.t;
+      used         : bool ref }
 
-(** {6 Compilation primitive. } *)
+type 'a matrix = 'a equation list
+
+(* 1st argument of IsInd is the original ind before extracting the summary *)
+type tomatch_type =
+  | IsInd of types * inductive_type * Name.t list
+  | NotInd of constr option * types
+
+(* spiwack: The first argument of [Pushed] is [true] for initial
+   Pushed and [false] otherwise. Used to decide whether the term being
+   matched on must be aliased in the variable case (only initial
+   Pushed need to be aliased). The first argument of [Alias] is [true]
+   if the alias was introduced by an initial pushed and [false]
+   otherwise.*)
+type tomatch_status =
+  | Pushed of (bool*((constr * tomatch_type) * int list * Name.t))
+  | Alias of (bool * (Name.t * constr * (constr * types)))
+  | NonDepAlias
+  | Abstract of int * rel_declaration
+
+type tomatch_stack = tomatch_status list
+
+(* We keep a constr for aliases and a cases_pattern for error message *)
+
+type pattern_history =
+  | Top
+  | MakeConstructor of constructor * pattern_continuation
+
+and pattern_continuation =
+  | Continuation of int * cases_pattern list * pattern_history
+  | Result of cases_pattern list
+
+type 'a pattern_matching_problem =
+    { env       : env;
+      evdref    : evar_map ref;
+      pred      : constr;
+      tomatch   : tomatch_stack;
+      history   : pattern_continuation;
+      mat       : 'a matrix;
+      caseloc   : Loc.t;
+      casestyle : case_style;
+      typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment }
+
+
+val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment
 
-module type S = sig
-  val compile_cases :
-    loc -> case_style ->
-    (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref ->
-    type_constraint ->
-    env -> glob_constr option * tomatch_tuples * cases_clauses ->
-    unsafe_judgment
-end
+val prepare_predicate :            Loc.t ->
+           (Evarutil.type_constraint ->
+            Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) ->
+           Environ.env ->
+           Evd.evar_map ->
+           (Term.types * tomatch_type) list ->
+           Context.rel_context list ->
+           Constr.constr option ->
+           'a option -> (Evd.evar_map * Names.name list * Term.constr) list
 
-module Cases_F(C : Coercion.S) : S
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 08ec25be..21bbede0 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -1,19 +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 Util
-open Pp
-open Term
 open Names
-open Environ
-open Univ
-open Evd
-open Conv_oracle
+open Term
+open Vars
 open Closure
 open Esubst
 
@@ -46,10 +42,10 @@ type cbv_value =
   | VAL of int * constr
   | STACK of int * cbv_value * cbv_stack
   | CBN of constr * cbv_value subs
-  | LAM of int * (name * constr) list * constr * cbv_value subs
+  | LAM of int * (Name.t * constr) list * constr * cbv_value subs
   | FIXP of fixpoint * cbv_value subs * cbv_value array
   | COFIXP of cofixpoint * cbv_value subs * cbv_value array
-  | CONSTR of constructor * cbv_value array
+  | CONSTR of constructor puniverses * cbv_value array
 
 (* type of terms with a hole. This hole can appear only under App or Case.
  *   TOP means the term is considered without context
@@ -63,6 +59,8 @@ type cbv_value =
  *      the subs S, pat is information on the patterns of the Case
  *      (Weak reduction: we propagate the sub only when the selected branch
  *      is determined)
+ *   PROJ(p,pb,stk) means the term is in a primitive projection p, itself in stk.
+ *      pb is the associated projection body
  *
  * Important remark: the APPs should be collapsed:
  *    (APP (l,(APP ...))) forbidden
@@ -71,6 +69,7 @@ and cbv_stack =
   | TOP
   | APP of cbv_value array * cbv_stack
   | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
+  | PROJ of projection * Declarations.projection_body * cbv_stack
 
 (* les vars pourraient etre des constr,
    cela permet de retarder les lift: utile ?? *)
@@ -90,7 +89,7 @@ let rec shift_value n = function
   | CONSTR (c,args) ->
       CONSTR (c, Array.map (shift_value n) args)
 let shift_value n v =
-  if n = 0 then v else shift_value n v
+  if Int.equal n 0 then v else shift_value n v
 
 (* Contracts a fixpoint: given a fixpoint and a bindings,
  * returns the corresponding fixpoint body, and the bindings in which
@@ -111,11 +110,11 @@ let contract_cofixp env (i,(_,_,bds as bodies)) =
 let make_constr_ref n = function
   | RelKey p -> mkRel (n+p)
   | VarKey id -> mkVar id
-  | ConstKey cst -> mkConst cst
+  | ConstKey cst -> mkConstU cst
 
 (* Adds an application list. Collapse APPs! *)
 let stack_app appl stack =
-  if Array.length appl = 0 then stack else
+  if Int.equal (Array.length appl) 0 then stack else
     match stack with
     | APP(args,stk) -> APP(Array.append appl args,stk)
     | _             -> APP(appl, stack)
@@ -125,6 +124,7 @@ let rec stack_concat stk1 stk2 =
       TOP -> stk2
     | APP(v,stk1') -> APP(v,stack_concat stk1' stk2)
     | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2)
+    | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2)
 
 (* merge stacks when there is no shifts in between *)
 let mkSTACK = function
@@ -140,7 +140,7 @@ open RedFlags
 let red_set_ref flags = function
   | RelKey _ -> red_set flags fDELTA
   | VarKey id -> red_set flags (fVAR id)
-  | ConstKey sp -> red_set flags (fCONST sp)
+  | ConstKey (sp,_) -> red_set flags (fCONST sp)
 
 (* Transfer application lists from a value to the stack
  * useful because fixpoints may be totally applied in several times.
@@ -178,9 +178,9 @@ let cofixp_reducible flgs _ stk =
 
 (* The main recursive functions
  *
- * Go under applications and cases (pushed in the stack), expand head
- * constants or substitued de Bruijn, and try to make appear a
- * constructor, a lambda or a fixp in the head. If not, it is a value
+ * Go under applications and cases/projections (pushed in the stack), 
+ * expand head constants or substitued de Bruijn, and try to a make a
+ * constructor, a lambda or a fixp appear in the head. If not, it is a value
  * and is completely computed here. The head redexes are NOT reduced:
  * the function returns the pair of a cbv_value and its stack.  *
  * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last
@@ -197,7 +197,17 @@ let rec norm_head info env t stack =
       norm_head info env head (stack_app nargs stack)
   | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack))
   | Cast (ct,_,_) -> norm_head info env ct stack
-
+  
+  | Proj (p, c) -> 
+    let p' =
+      if red_set (info_flags info) (fCONST (Projection.constant p)) 
+      	&& red_set (info_flags info) fBETA 
+      then Projection.unfold p
+      else p
+    in 
+    let pinfo = Environ.lookup_projection p (info_env info) in
+      norm_head info env c (PROJ (p', pinfo, stack))
+	
   (* constants, axioms
    * the first pattern is CRUCIAL, n=0 happens very often:
    * when reducing closed terms, n is always 0 *)
@@ -222,10 +232,10 @@ let rec norm_head info env t stack =
 	let env' = subs_cons ([|cbv_stack_term info TOP env b|],env) in
         norm_head info env' c stack
       else
-	(CBN(t,env), stack) (* Considérer une coupure commutative ? *)
+	(CBN(t,env), stack) (* Should we consider a commutative cut ? *)
 
   | Evar ev ->
-      (match evar_value info ev with
+      (match evar_value info.i_cache ev with
           Some c -> norm_head info env c stack
         | None -> (VAL(0, t), stack))
 
@@ -255,19 +265,21 @@ and norm_head_ref k info env stack normt =
  * we build a value.
  *)
 and cbv_stack_term info stack env t =
-  match norm_head info env t stack with
-    (* a lambda meets an application -> BETA *)
-    | (LAM (nlams,ctxt,b,env), APP (args, stk))
+  cbv_stack_value info env (norm_head info env t stack)
+
+and cbv_stack_value info env = function
+  (* a lambda meets an application -> BETA *)
+  | (LAM (nlams,ctxt,b,env), APP (args, stk))
       when red_set (info_flags info) fBETA ->
-        let nargs = Array.length args in
-        if nargs == nlams then
+    let nargs = Array.length args in
+      if nargs == nlams then
           cbv_stack_term info stk (subs_cons(args,env)) b
         else if nlams < nargs then
           let env' = subs_cons(Array.sub args 0 nlams, env) in
           let eargs = Array.sub args nlams (nargs-nlams) in
           cbv_stack_term info (APP(eargs,stk)) env' b
         else
-          let ctxt' = list_skipn nargs ctxt in
+          let ctxt' = List.skipn nargs ctxt in
           LAM(nlams-nargs,ctxt', b, subs_cons(args,env))
 
     (* a Fix applied enough -> IOTA *)
@@ -283,22 +295,28 @@ and cbv_stack_term info stack env t =
         cbv_stack_term info stk envf redfix
 
     (* constructor in a Case -> IOTA *)
-    | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk)))
+    | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk)))
             when red_set (info_flags info) fIOTA ->
 	let cargs =
           Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in
         cbv_stack_term info (stack_app cargs stk) env br.(n-1)
 
     (* constructor of arity 0 in a Case -> IOTA *)
-    | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk))
+    | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk))
             when red_set (info_flags info) fIOTA ->
                     cbv_stack_term info stk env br.(n-1)
 
+    (* constructor in a Projection -> IOTA *)
+    | (CONSTR(((sp,n),u),[||]), APP(args,PROJ(p,pi,stk)))
+        when red_set (info_flags info) fIOTA && Projection.unfolded p ->
+      let arg = args.(pi.Declarations.proj_npars + pi.Declarations.proj_arg) in
+	cbv_stack_value info env (arg, stk)
+
     (* may be reduced later by application *)
     | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl)
     | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl)
     | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl)
-
+      
     (* definitely a value *)
     | (head,stk) -> mkSTACK(head, stk)
 
@@ -316,6 +334,8 @@ let rec apply_stack info t = function
         (mkCase (ci, cbv_norm_term info env ty, t,
 		    Array.map (cbv_norm_term info env) br))
         st
+  | PROJ (p, pinfo, st) ->
+       apply_stack info (mkProj (p, t)) st
 
 (* performs the reduction on a constr, and returns a constr *)
 and cbv_norm_term info env t =
@@ -333,7 +353,7 @@ and cbv_norm_value info = function (* reduction under binders *)
       map_constr_with_binders subs_lift (cbv_norm_term info) env t
   | LAM (n,ctxt,b,env) ->
       let nctxt =
-        list_map_i (fun i (x,ty) ->
+        List.map_i (fun i (x,ty) ->
           (x,cbv_norm_term info (subs_liftn i env) ty)) 0 ctxt in
       compose_lam (List.rev nctxt) (cbv_norm_term info (subs_liftn n env) b)
   | FIXP ((lij,(names,lty,bds)),env,args) ->
@@ -352,7 +372,7 @@ and cbv_norm_value info = function (* reduction under binders *)
 				(subs_liftn (Array.length lty) env)) bds)),
          Array.map (cbv_norm_value info) args)
   | CONSTR (c,args) ->
-      mkApp(mkConstruct c, Array.map (cbv_norm_value info) args)
+      mkApp(mkConstructU c, Array.map (cbv_norm_value info) args)
 
 (* with profiling *)
 let cbv_norm infos constr =
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index eb0abe97..bde85383 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.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        *)
@@ -27,15 +27,16 @@ type cbv_value =
   | VAL of int * constr
   | STACK of int * cbv_value * cbv_stack
   | CBN of constr * cbv_value subs
-  | LAM of int * (name * constr) list * constr * cbv_value subs
+  | LAM of int * (Name.t * constr) list * constr * cbv_value subs
   | FIXP of fixpoint * cbv_value subs * cbv_value array
   | COFIXP of cofixpoint * cbv_value subs * cbv_value array
-  | CONSTR of constructor * cbv_value array
+  | CONSTR of constructor puniverses * cbv_value array
 
 and cbv_stack =
   | TOP
   | APP of cbv_value array * cbv_stack
   | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack
+  | PROJ of projection * Declarations.projection_body * cbv_stack
 
 val shift_value : int -> cbv_value -> cbv_value
 
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 59f3c740..559f5fe6 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -1,24 +1,23 @@
 (************************************************************************)
 (*  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 Pp
 open Flags
 open Names
 open Libnames
+open Globnames
 open Nametab
 open Environ
 open Libobject
-open Library
 open Term
 open Termops
-open Glob_term
-open Decl_kinds
 open Mod_subst
 
 (* usage qque peu general: utilise aussi dans record *)
@@ -32,6 +31,7 @@ type cl_typ =
   | CL_SECVAR of variable
   | CL_CONST of constant
   | CL_IND of inductive
+  | CL_PROJ of constant
 
 type cl_info_typ = {
   cl_param : int
@@ -39,21 +39,42 @@ type cl_info_typ = {
 
 type coe_typ = global_reference
 
+module CoeTypMap = Refmap_env
+
 type coe_info_typ = {
   coe_value : constr;
   coe_type : types;
-  coe_strength : locality;
+  coe_local : bool;
+  coe_context : Univ.universe_context_set;
   coe_is_identity : bool;
+  coe_is_projection : bool;
   coe_param : int }
 
 let coe_info_typ_equal c1 c2 =
   eq_constr c1.coe_value c2.coe_value &&
     eq_constr c1.coe_type c2.coe_type &&
-    c1.coe_strength = c2.coe_strength &&
-    c1.coe_is_identity = c2.coe_is_identity &&
-    c1.coe_param = c2.coe_param
+    c1.coe_local == c2.coe_local &&
+    c1.coe_is_identity == c2.coe_is_identity &&
+    c1.coe_is_projection == c2.coe_is_projection &&
+    Int.equal c1.coe_param c2.coe_param
+
+let cl_typ_ord t1 t2 = match t1, t2 with
+  | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2
+  | CL_CONST c1, CL_CONST c2 -> con_user_ord c1 c2
+  | CL_PROJ c1, CL_PROJ c2 -> con_user_ord c1 c2
+  | CL_IND i1, CL_IND i2 -> ind_user_ord i1 i2
+  | _ -> Pervasives.compare t1 t2 (** OK *)
+
+module ClTyp = struct
+  type t = cl_typ
+  let compare = cl_typ_ord
+end
+
+module ClTypMap = Map.Make(ClTyp)
 
-type cl_index = int
+module IntMap = Map.Make(Int)
+
+let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0
 
 type coe_index = coe_info_typ
 
@@ -61,31 +82,60 @@ type inheritance_path = coe_index list
 
 (* table des classes, des coercions et graphe d'heritage *)
 
-module Bijint = struct
-  type ('a,'b) t = { v : ('a * 'b) array; s : int; inv : ('a,int) Gmap.t }
-  let empty = { v = [||]; s = 0; inv = Gmap.empty }
-  let mem y b = Gmap.mem y b.inv
-  let map x b = if 0 <= x & x < b.s then b.v.(x) else raise Not_found
-  let revmap y b = let n = Gmap.find y b.inv in (n, snd (b.v.(n)))
+module Bijint :
+sig
+  module Index :
+  sig
+    type t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val print : t -> std_ppcmds
+  end
+  type 'a t
+  val empty : 'a t
+  val mem : cl_typ -> 'a t -> bool
+  val map : Index.t -> 'a t -> cl_typ * 'a
+  val revmap : cl_typ -> 'a t -> Index.t * 'a
+  val add : cl_typ -> 'a -> 'a t -> 'a t
+  val dom : 'a t -> cl_typ list
+end
+=
+struct
+
+  module Index = struct include Int let print = Pp.int end
+
+  type 'a t = { v : (cl_typ * 'a) IntMap.t; s : int; inv : int ClTypMap.t }
+  let empty = { v = IntMap.empty; s = 0; inv = ClTypMap.empty }
+  let mem y b = ClTypMap.mem y b.inv
+  let map x b = IntMap.find x b.v
+  let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (IntMap.find n b.v))
   let add x y b =
-    let v =
-      if b.s = Array.length b.v then
-	(let v = Array.make (b.s + 8) (x,y) in Array.blit b.v 0 v 0 b.s; v)
-      else b.v in
-    v.(b.s) <- (x,y); { v = v; s = b.s+1; inv = Gmap.add x b.s b.inv }
-  let dom b = Gmap.dom b.inv
+    { v = IntMap.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv }
+  let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv [])
 end
 
+type cl_index = Bijint.Index.t
+
 let class_tab =
-  ref (Bijint.empty : (cl_typ, cl_info_typ) Bijint.t)
+  ref (Bijint.empty : cl_info_typ Bijint.t)
 
 let coercion_tab =
-  ref (Gmap.empty : (coe_typ, coe_info_typ) Gmap.t)
+  ref (CoeTypMap.empty : coe_info_typ CoeTypMap.t)
+
+module ClPairOrd =
+struct
+  type t = cl_index * cl_index
+  let compare (i1, j1) (i2, j2) =
+    let c = Bijint.Index.compare i1 i2 in
+    if Int.equal c 0 then Bijint.Index.compare j1 j2 else c
+end
+
+module ClPairMap = Map.Make(ClPairOrd)
 
 let inheritance_graph =
-  ref (Gmap.empty : (cl_index * cl_index, inheritance_path) Gmap.t)
+  ref (ClPairMap.empty : inheritance_path ClPairMap.t)
 
-let freeze () = (!class_tab, !coercion_tab, !inheritance_graph)
+let freeze _ = (!class_tab, !coercion_tab, !inheritance_graph)
 
 let unfreeze (fcl,fco,fig) =
   class_tab:=fcl;
@@ -99,17 +149,17 @@ let add_new_class cl s =
     class_tab := Bijint.add cl s !class_tab
 
 let add_new_coercion coe s =
-  coercion_tab := Gmap.add coe s !coercion_tab
+  coercion_tab := CoeTypMap.add coe s !coercion_tab
 
 let add_new_path x y =
-  inheritance_graph := Gmap.add x y !inheritance_graph
+  inheritance_graph := ClPairMap.add x y !inheritance_graph
 
 let init () =
   class_tab:= Bijint.empty;
   add_new_class CL_FUN  { cl_param = 0 };
   add_new_class CL_SORT { cl_param = 0 };
-  coercion_tab:= Gmap.empty;
-  inheritance_graph:= Gmap.empty
+  coercion_tab:= CoeTypMap.empty;
+  inheritance_graph:= ClPairMap.empty
 
 let _ =
   Summary.declare_summary "inh_graph"
@@ -135,20 +185,22 @@ let cl_sort_index = fst(class_info CL_SORT)
 
 (* coercion_info : coe_typ -> coe_info_typ *)
 
-let coercion_info coe = Gmap.find coe !coercion_tab
+let coercion_info coe = CoeTypMap.find coe !coercion_tab
 
-let coercion_exists coe = Gmap.mem coe !coercion_tab
+let coercion_exists coe = CoeTypMap.mem coe !coercion_tab
 
-(* find_class_type : evar_map -> constr -> cl_typ * constr list *)
+(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *)
 
 let find_class_type sigma t =
   let t', args = Reductionops.whd_betaiotazeta_stack sigma t in
   match kind_of_term t' with
-    | Var id -> CL_SECVAR id, args
-    | Const sp -> CL_CONST sp, args
-    | Ind ind_sp -> CL_IND ind_sp, args
-    | Prod (_,_,_) -> CL_FUN, []
-    | Sort _ -> CL_SORT, []
+    | Var id -> CL_SECVAR id, Univ.Instance.empty, args
+    | Const (sp,u) -> CL_CONST sp, u, args
+    | Proj (p, c) when not (Projection.unfolded p) ->
+      CL_PROJ (Projection.constant p), Univ.Instance.empty, c :: args
+    | Ind (ind_sp,u) -> CL_IND ind_sp, u, args
+    | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, []
+    | Sort _ -> CL_SORT, Univ.Instance.empty, []
     |  _ -> raise Not_found
 
 
@@ -156,55 +208,57 @@ let subst_cl_typ subst ct = match ct with
     CL_SORT
   | CL_FUN
   | CL_SECVAR _ -> ct
-  | CL_CONST kn ->
-      let kn',t = subst_con subst kn in
-	if kn' == kn then ct else
-         fst (find_class_type Evd.empty t)
-  | CL_IND (kn,i) ->
-      let kn' = subst_ind subst kn in
-	if kn' == kn then ct else
-	  CL_IND (kn',i)
+  | CL_PROJ c ->
+    let c',t = subst_con_kn subst c in
+      if c' == c then ct else CL_PROJ c'
+  | CL_CONST c ->
+      let c',t = subst_con_kn subst c in
+	if c' == c then ct else
+         pi1 (find_class_type Evd.empty t)
+  | CL_IND i ->
+      let i' = subst_ind subst i in
+	if i' == i then ct else CL_IND i'
 
 (*CSC: here we should change the datatype for coercions: it should be possible
        to declare any term as a coercion *)
-let subst_coe_typ subst t = fst (subst_global subst t)
+let subst_coe_typ subst t = subst_global_reference subst t
 
 (* class_of : Term.constr -> int *)
 
 let class_of env sigma t =
-  let (t, n1, i, args) =
+  let (t, n1, i, u, args) =
     try
-      let (cl,args) = find_class_type sigma t in
+      let (cl, u, args) = find_class_type sigma t in
       let (i, { cl_param = n1 } ) = class_info cl in
-      (t, n1, i, args)
+      (t, n1, i, u, args)
     with Not_found ->
       let t = Tacred.hnf_constr env sigma t in
-      let (cl, args) = find_class_type sigma t in
+      let (cl, u, args) = find_class_type sigma t in
       let (i, { cl_param = n1 } ) = class_info cl in
-      (t, n1, i, args)
+      (t, n1, i, u, args)
   in
-  if List.length args = n1 then t, i else raise Not_found
+  if Int.equal (List.length args) n1 then t, i else raise Not_found
 
 let inductive_class_of ind = fst (class_info (CL_IND ind))
 
-let class_args_of env sigma c = snd (find_class_type sigma c)
+let class_args_of env sigma c = pi3 (find_class_type sigma c)
 
 let string_of_class = function
   | CL_FUN -> "Funclass"
   | CL_SORT -> "Sortclass"
-  | CL_CONST sp ->
-      string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp))
+  | CL_CONST sp | CL_PROJ sp ->
+      string_of_qualid (shortest_qualid_of_global Id.Set.empty (ConstRef sp))
   | CL_IND sp ->
-      string_of_qualid (shortest_qualid_of_global Idset.empty (IndRef sp))
+      string_of_qualid (shortest_qualid_of_global Id.Set.empty (IndRef sp))
   | CL_SECVAR sp ->
-      string_of_qualid (shortest_qualid_of_global Idset.empty (VarRef sp))
+      string_of_qualid (shortest_qualid_of_global Id.Set.empty (VarRef sp))
 
 let pr_class x = str (string_of_class x)
 
 (* lookup paths *)
 
 let lookup_path_between_class (s,t) =
-  Gmap.find (s,t) !inheritance_graph
+  ClPairMap.find (s,t) !inheritance_graph
 
 let lookup_path_to_fun_from_class s =
   lookup_path_between_class (s,cl_fun_index)
@@ -216,16 +270,16 @@ let lookup_path_to_sort_from_class s =
 
 let apply_on_class_of env sigma t cont =
   try
-    let (cl,args) = find_class_type sigma t in
+    let (cl,u,args) = find_class_type sigma t in
     let (i, { cl_param = n1 } ) = class_info cl in
-    if List.length args <> n1 then raise Not_found;
+    if not (Int.equal (List.length args) n1) then raise Not_found;
     t, cont i
   with Not_found ->
     (* Is it worth to be more incremental on the delta steps? *)
     let t = Tacred.hnf_constr env sigma t in
-    let (cl, args) = find_class_type sigma t in
+    let (cl, u, args) = find_class_type sigma t in
     let (i, { cl_param = n1 } ) = class_info cl in
-    if List.length args <> n1 then raise Not_found;
+    if not (Int.equal (List.length args) n1) then raise Not_found;
     t, cont i
 
 let lookup_path_between env sigma (s,t) =
@@ -241,31 +295,35 @@ let lookup_path_to_fun_from env sigma s =
 let lookup_path_to_sort_from env sigma s =
   apply_on_class_of env sigma s lookup_path_to_sort_from_class
 
-let get_coercion_constructor coe =
+let get_coercion_constructor env coe =
   let c, _ =
-    Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value
+    Reductionops.whd_betadeltaiota_stack env Evd.empty coe.coe_value
   in
   match kind_of_term c with
-  | Construct cstr ->
-      (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1)
+  | Construct (cstr,u) ->
+      (cstr, Inductiveops.constructor_nrealargs cstr -1)
   | _ ->
       raise Not_found
 
-let lookup_pattern_path_between (s,t) =
+let lookup_pattern_path_between env (s,t) =
   let i = inductive_class_of s in
   let j = inductive_class_of t in
-  List.map get_coercion_constructor (Gmap.find (i,j) !inheritance_graph)
+  List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph)
 
 (* coercion_value : coe_index -> unsafe_judgment * bool *)
 
-let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } =
-  (make_judge c t, b)
+let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; 
+		     coe_is_identity = b; coe_is_projection = b' } =
+  let subst, ctx = Universes.fresh_universe_context_set_instance ctx in
+  let c' = Vars.subst_univs_level_constr subst c 
+  and t' = Vars.subst_univs_level_constr subst t in
+    (make_judge c' t', b, b'), ctx
 
 (* pretty-print functions are now in Pretty *)
 (* rajouter une coercion dans le graphe *)
 
 let path_printer = ref (fun _ -> str "<a class path>"
-                        : (int * int) * inheritance_path -> std_ppcmds)
+                        : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> std_ppcmds)
 
 let install_path_printer f = path_printer := f
 
@@ -273,27 +331,33 @@ let print_path x = !path_printer x
 
 let message_ambig l =
   (str"Ambiguous paths:" ++ spc () ++
-   prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l)
+   prlist_with_sep fnl (fun ijp -> print_path ijp) l)
 
 (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit
                          coercion,source,target *)
 
-let different_class_params i j =
-  (snd (class_info_from_index i)).cl_param > 0
-
+let different_class_params i =
+  let ci = class_info_from_index i in
+    if (snd ci).cl_param > 0 then true
+    else 
+      match fst ci with
+      | CL_IND i -> Global.is_polymorphic (IndRef i)
+      | CL_CONST c -> Global.is_polymorphic (ConstRef c)
+      | _ -> false
+	
 let add_coercion_in_graph (ic,source,target) =
   let old_inheritance_graph = !inheritance_graph in
   let ambig_paths =
     (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
   let try_add_new_path (i,j as ij) p =
     try
-      if i=j then begin
-	if different_class_params i j then begin
+      if Bijint.Index.equal i j then begin
+	if different_class_params i then begin
 	  let _ = lookup_path_between_class ij in
           ambig_paths := (ij,p)::!ambig_paths
 	end
       end else begin
-        let _ = lookup_path_between_class (i,j) in
+        let _ = lookup_path_between_class ij in
         ambig_paths := (ij,p)::!ambig_paths
       end;
       false
@@ -306,35 +370,50 @@ let add_coercion_in_graph (ic,source,target) =
     let _ = try_add_new_path ij p in ()
   in
   if try_add_new_path (source,target) [ic] then begin
-    Gmap.iter
+    ClPairMap.iter
       (fun (s,t) p ->
-         if s<>t then begin
-	   if t = source then begin
+         if not (Bijint.Index.equal s t) then begin
+	   if Bijint.Index.equal t source then begin
              try_add_new_path1 (s,target) (p@[ic]);
-             Gmap.iter
+             ClPairMap.iter
 	       (fun (u,v) q ->
-                  if u<>v & u = target &&  not (list_equal coe_info_typ_equal p q) then
+                  if not (Bijint.Index.equal u v) && Bijint.Index.equal u target &&  not (List.equal coe_info_typ_equal p q) then
 		    try_add_new_path1 (s,v) (p@[ic]@q))
                old_inheritance_graph
            end;
-           if s = target then try_add_new_path1 (source,t) (ic::p)
+           if Bijint.Index.equal s target then try_add_new_path1 (source,t) (ic::p)
 	 end)
       old_inheritance_graph
   end;
-  if (!ambig_paths <> []) && is_verbose () then
-    ppnl (message_ambig !ambig_paths)
-
-type coercion = coe_typ * locality * bool * cl_typ * cl_typ * int
+  let is_ambig = match !ambig_paths with [] -> false | _ -> true in
+  if is_ambig && is_verbose () then
+    msg_warning (message_ambig !ambig_paths)
+
+type coercion = {
+  coercion_type   : coe_typ;
+  coercion_local  : bool;
+  coercion_is_id  : bool;
+  coercion_is_proj  : bool;
+  coercion_source : cl_typ;
+  coercion_target : cl_typ;
+  coercion_params : int;
+}
 
-(* Calcul de l'arité d'une classe *)
+(* Computation of the class arity *)
 
 let reference_arity_length ref =
-  let t = Global.type_of_global ref in
+  let t = Universes.unsafe_type_of_global ref in
   List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t))
 
+let projection_arity_length p =
+  let len = reference_arity_length (ConstRef p) in
+  let pb = Environ.lookup_projection (Projection.make p false) (Global.env ()) in 
+    len - pb.Declarations.proj_npars
+
 let class_params = function
   | CL_FUN | CL_SORT -> 0
   | CL_CONST sp -> reference_arity_length (ConstRef sp)
+  | CL_PROJ sp -> projection_arity_length sp
   | CL_SECVAR sp -> reference_arity_length (VarRef sp)
   | CL_IND sp  -> reference_arity_length (IndRef sp)
 
@@ -355,18 +434,22 @@ let _ =
       optread  = (fun () -> !automatically_import_coercions);
       optwrite = (:=) automatically_import_coercions }
 
-let cache_coercion (_,(coe,stre,isid,cls,clt,ps)) =
-  add_class cls;
-  add_class clt;
-  let is,_ = class_info cls in
-  let it,_ = class_info clt in
+let cache_coercion (_, c) =
+  let () = add_class c.coercion_source in
+  let () = add_class c.coercion_target in
+  let is, _ = class_info c.coercion_source in
+  let it, _ = class_info c.coercion_target in
+  let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in
+  let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in
   let xf =
-    { coe_value = constr_of_global coe;
-      coe_type = Global.type_of_global coe;
-      coe_strength = stre;
-      coe_is_identity = isid;
-      coe_param = ps } in
-  add_new_coercion coe xf;
+    { coe_value = value;
+      coe_type = typ;
+      coe_context = ctx;
+      coe_local = c.coercion_local;
+      coe_is_identity = c.coercion_is_id;
+      coe_is_projection = c.coercion_is_proj;
+      coe_param = c.coercion_params } in
+  let () = add_new_coercion c.coercion_type xf in
   add_coercion_in_graph (xf,is,it)
 
 let load_coercion _ o =
@@ -376,40 +459,45 @@ let load_coercion _ o =
     cache_coercion o
 
 let open_coercion i o =
-  if i = 1 && not
+  if Int.equal i 1 && not
     (!automatically_import_coercions || Flags.version_less_or_equal Flags.V8_2)
   then
     cache_coercion o
 
-let subst_coercion (subst,(coe,stre,isid,cls,clt,ps as obj)) =
-  let coe' = subst_coe_typ subst coe in
-  let cls' = subst_cl_typ subst cls in
-  let clt' = subst_cl_typ subst clt in
-    if coe' == coe && cls' == cls & clt' == clt then obj else
-      (coe',stre,isid,cls',clt',ps)
+let subst_coercion (subst, c) =
+  let coe = subst_coe_typ subst c.coercion_type in
+  let cls = subst_cl_typ subst c.coercion_source in
+  let clt = subst_cl_typ subst c.coercion_target in
+  if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c
+  else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt }
 
 let discharge_cl = function
   | CL_CONST kn -> CL_CONST (Lib.discharge_con kn)
   | CL_IND ind -> CL_IND (Lib.discharge_inductive ind)
+  | CL_PROJ p -> CL_PROJ (Lib.discharge_con p)
   | cl -> cl
 
-let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
-  if stre = Local then None else
-    let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in
-    Some (Lib.discharge_global coe,
-          stre,
-	  isid,
-          discharge_cl cls,
-	  discharge_cl clt,
-          n + ps)
-
-let classify_coercion (coe,stre,isid,cls,clt,ps as obj) =
-  if stre = Local then Dispose else Substitute obj
-
-type coercion_obj =
-  coe_typ * Decl_kinds.locality * bool * cl_typ * cl_typ * int
-
-let inCoercion : coercion_obj -> obj =
+let discharge_coercion (_, c) =
+  if c.coercion_local then None
+  else
+    let n =
+      try
+        let ins = Lib.section_instance c.coercion_type in
+        Array.length (snd ins)
+      with Not_found -> 0
+    in
+    let nc = { c with
+      coercion_type = Lib.discharge_global c.coercion_type;
+      coercion_source = discharge_cl c.coercion_source;
+      coercion_target = discharge_cl c.coercion_target;
+      coercion_params = n + c.coercion_params;
+    } in
+    Some nc
+
+let classify_coercion obj =
+  if obj.coercion_local then Dispose else Substitute obj
+
+let inCoercion : coercion -> obj =
   declare_object {(default_object "COERCION") with
     open_function = open_coercion;
     load_function = load_coercion;
@@ -418,31 +506,49 @@ let inCoercion : coercion_obj -> obj =
     classify_function = classify_coercion;
     discharge_function = discharge_coercion }
 
-let declare_coercion coef stre ~isid ~src:cls ~target:clt ~params:ps =
-  Lib.add_anonymous_leaf (inCoercion (coef,stre,isid,cls,clt,ps))
+let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps =
+  let isproj = 
+    match coef with
+    | ConstRef c -> Environ.is_projection c (Global.env ())
+    | _ -> false
+  in
+  let c = {
+    coercion_type = coef;
+    coercion_local = local;
+    coercion_is_id = isid;
+    coercion_is_proj = isproj;
+    coercion_source = cls;
+    coercion_target = clt;
+    coercion_params = ps;
+  } in
+  Lib.add_anonymous_leaf (inCoercion c)
 
 (* For printing purpose *)
 let get_coercion_value v = v.coe_value
 
-let pr_cl_index n = int n
+let pr_cl_index = Bijint.Index.print
 
 let classes () = Bijint.dom !class_tab
-let coercions () = Gmap.rng !coercion_tab
-let inheritance_graph () = Gmap.to_list !inheritance_graph
+let coercions () =
+  List.rev (CoeTypMap.fold (fun _ y acc -> y::acc) !coercion_tab [])
+
+let inheritance_graph () =
+  ClPairMap.bindings !inheritance_graph
 
 let coercion_of_reference r =
   let ref = Nametab.global r in
   if not (coercion_exists ref) then
     errorlabstrm "try_add_coercion"
-      (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion.");
+      (Nametab.pr_global_env Id.Set.empty ref ++ str" is not a coercion.");
   ref
 
 module CoercionPrinting =
   struct
     type t = coe_typ
+    let compare = RefOrdered.compare
     let encode = coercion_of_reference
     let subst = subst_coe_typ
-    let printer x = pr_global_env Idset.empty x
+    let printer x = pr_global_env Id.Set.empty x
     let key = ["Printing";"Coercion"]
     let title = "Explicitly printed coercions: "
     let member_message x b =
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index 0136b90c..c421b450 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -1,17 +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 Names
-open Decl_kinds
 open Term
 open Evd
 open Environ
-open Nametab
 open Mod_subst
 
 (** {6 This is the type of class kinds } *)
@@ -21,6 +19,10 @@ type cl_typ =
   | CL_SECVAR of variable
   | CL_CONST of constant
   | CL_IND of inductive
+  | CL_PROJ of constant
+
+(** Equality over [cl_typ] *)
+val cl_typ_eq : cl_typ -> cl_typ -> bool
 
 val subst_cl_typ : substitution -> cl_typ -> cl_typ
 
@@ -29,7 +31,7 @@ type cl_info_typ = {
   cl_param : int }
 
 (** This is the type of coercion kinds *)
-type coe_typ = Libnames.global_reference
+type coe_typ = Globnames.global_reference
 
 (** This is the type of infos for declared coercions *)
 type coe_info_typ
@@ -44,13 +46,17 @@ type coe_index
 type inheritance_path = coe_index list
 
 (** {6 Access to classes infos } *)
-val class_info : cl_typ -> (cl_index * cl_info_typ)
+
 val class_exists : cl_typ -> bool
+
+val class_info : cl_typ -> (cl_index * cl_info_typ)
+(** @raise Not_found if this type is not a class *)
+
 val class_info_from_index : cl_index -> cl_typ * cl_info_typ
 
-(** [find_class_type env sigma c] returns the head reference of [c] and its
-   arguments *)
-val find_class_type : evar_map -> types -> cl_typ * constr list
+(** [find_class_type env sigma c] returns the head reference of [c],
+    its universe instance and its arguments *)
+val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list
 
 (** raises [Not_found] if not convertible to a class *)
 val class_of : env -> evar_map -> types -> types * cl_index
@@ -62,16 +68,18 @@ val class_args_of : env -> evar_map -> types -> constr list
 
 (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *)
 val declare_coercion :
-  coe_typ -> locality -> isid:bool ->
+  coe_typ -> ?local:bool -> isid:bool ->
       src:cl_typ -> target:cl_typ -> params:int -> unit
 
 (** {6 Access to coercions infos } *)
 val coercion_exists : coe_typ -> bool
 
-val coercion_value : coe_index -> (unsafe_judgment * bool)
+val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set
 
 (** {6 Lookup functions for coercion paths } *)
+
 val lookup_path_between_class : cl_index * cl_index -> inheritance_path
+(** @raise Not_found when no such path exists *)
 
 val lookup_path_between : env -> evar_map -> types * types ->
       types * types * inheritance_path
@@ -80,7 +88,7 @@ val lookup_path_to_fun_from : env -> evar_map -> types ->
 val lookup_path_to_sort_from : env -> evar_map -> types ->
       types * inheritance_path
 val lookup_pattern_path_between :
-  inductive * inductive -> (constructor * int) list
+  env -> inductive * inductive -> (constructor * int) list
 
 (**/**)
 (* Crade *)
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 917856a2..8ebb8cd2 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.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        *)
@@ -9,279 +9,513 @@
 (* Created by Hugo Herbelin for Coq V7 by isolating the coercion
    mechanism out of the type inference algorithm in file trad.ml from
    Coq V6.3, Nov 1999; The coercion mechanism was implemented in
-   trad.ml by Amokrane Saïbi, May 1996 *)
+   trad.ml by Amokrane Saïbi, May 1996 *)
 (* Addition of products and sorts in canonical structures by Pierre
    Corbineau, Feb 2008 *)
 (* Turned into an abstract compilation unit by Matthieu Sozeau, March 2006 *)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
 open Reductionops
 open Environ
 open Typeops
 open Pretype_errors
 open Classops
-open Recordops
 open Evarutil
 open Evarconv
-open Retyping
 open Evd
 open Termops
+open Globnames
 
-module type S = sig
-  (*s Coercions. *)
-
-  (* [inh_app_fun env evd j] coerces [j] to a function; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type a product; it returns [j] if no coercion is applicable *)
-  val inh_app_fun :
-    bool -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
-
-  (* [inh_coerce_to_sort env evd j] coerces [j] to a type; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type a sort; it fails if no coercion is applicable *)
-  val inh_coerce_to_sort : loc ->
-    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
-
-  (* [inh_coerce_to_base env evd j] coerces [j] to its base type; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type its base type (the notion depends on the coercion system) *)
-  val inh_coerce_to_base : loc ->
-    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
-
-  (* [inh_coerce_to_prod env evars t] coerces [t] to a product type *)
-  val inh_coerce_to_prod : loc ->
-    env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type
-
-  (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type
-     [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
-     [j.uj_type] are convertible; it fails if no coercion is applicable *)
-  val inh_conv_coerce_to : bool -> loc ->
-    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
-
-  val inh_conv_coerce_rigid_to : bool -> loc ->
-    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
-
-  (* [inh_conv_coerces_to loc env evd t t'] checks if an object of type [t]
-     is coercible to an object of type [t'] adding evar constraints if needed;
-     it fails if no coercion exists *)
-  val inh_conv_coerces_to : loc ->
-    env -> evar_map -> types -> type_constraint_type -> evar_map
-
-  (* [inh_pattern_coerce_to loc env evd pat ind1 ind2] coerces the Cases
-     pattern [pat] typed in [ind1] into a pattern typed in [ind2];
-     raises [Not_found] if no coercion found *)
-  val inh_pattern_coerce_to :
-    loc  -> Glob_term.cases_pattern -> inductive -> inductive -> Glob_term.cases_pattern
-end
-
-module Default = struct
-  (* Typing operations dealing with coercions *)
-  exception NoCoercion
-
-  (* Here, funj is a coercion therefore already typed in global context *)
-  let apply_coercion_args env argl funj =
-    let rec apply_rec acc typ = function
-      | [] -> { uj_val = applist (j_val funj,argl);
-		uj_type = typ }
-      | h::restl ->
-	  (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
-  	  match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
-	    | Prod (_,c1,c2) ->
-		(* Typage garanti par l'appel à app_coercion*)
-		apply_rec (h::acc) (subst1 h c2) restl
-	    | _ -> anomaly "apply_coercion_args"
+let use_typeclasses_for_conversion = ref true
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      optdepr  = false;
+      optname  = "use typeclass resolution during conversion";
+      optkey   = ["Typeclass"; "Resolution"; "For"; "Conversion"];
+      optread  = (fun () -> !use_typeclasses_for_conversion);
+      optwrite = (fun b -> use_typeclasses_for_conversion := b) }
+
+
+(* Typing operations dealing with coercions *)
+exception NoCoercion
+exception NoCoercionNoUnifier of evar_map * unification_error
+
+(* Here, funj is a coercion therefore already typed in global context *)
+let apply_coercion_args env evd check isproj argl funj =
+  let evdref = ref evd in
+  let rec apply_rec acc typ = function
+    | [] ->
+      if isproj then
+	let cst = fst (destConst (j_val funj)) in
+	let p = Projection.make cst false in
+	let pb = lookup_projection p env in
+	let args = List.skipn pb.Declarations.proj_npars argl in
+	let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in
+	  { uj_val = applist (mkProj (p, hd), tl);
+	    uj_type = typ }
+      else
+	{ uj_val = applist (j_val funj,argl);
+	  uj_type = typ }
+    | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *)
+      match kind_of_term (whd_betadeltaiota env evd typ) with
+      | Prod (_,c1,c2) ->
+        if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then
+	  raise NoCoercion;
+        apply_rec (h::acc) (subst1 h c2) restl
+      | _ -> anomaly (Pp.str "apply_coercion_args")
+  in
+  let res = apply_rec [] funj.uj_type argl in
+    !evdref, res
+
+(* appliquer le chemin de coercions de patterns p *)
+let apply_pattern_coercion loc pat p =
+  List.fold_left
+    (fun pat (co,n) ->
+       let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
+	 Glob_term.PatCstr (loc, co, List.init (n+1) f, Anonymous))
+    pat p
+
+(* raise Not_found if no coercion found *)
+let inh_pattern_coerce_to loc env pat ind1 ind2 =
+  let p = lookup_pattern_path_between env (ind1,ind2) in
+    apply_pattern_coercion loc pat p
+
+(* Program coercions *)
+
+open Program
+
+let make_existential loc ?(opaque = Evar_kinds.Define true) env evdref c =
+  Evarutil.e_new_evar env evdref ~src:(loc, Evar_kinds.QuestionMark opaque) c
+
+let app_opt env evdref f t =
+  whd_betaiota !evdref (app_opt f t)
+
+let pair_of_array a = (a.(0), a.(1))
+
+let disc_subset x =
+  match kind_of_term x with
+  | App (c, l) ->
+      (match kind_of_term c with
+       Ind (i,_) ->
+	 let len = Array.length l in
+	 let sigty = delayed_force sig_typ in
+	   if Int.equal len 2 && eq_ind i (Globnames.destIndRef sigty)
+	   then
+	     let (a, b) = pair_of_array l in
+	       Some (a, b)
+	   else None
+       | _ -> None)
+  | _ -> None
+
+exception NoSubtacCoercion
+  
+let hnf env evd c = whd_betadeltaiota env evd c
+let hnf_nodelta env evd c = whd_betaiota evd c
+
+let lift_args n sign =
+  let rec liftrec k = function
+    | t::sign -> liftn n k t :: (liftrec (k-1) sign)
+    | [] -> []
+  in
+    liftrec (List.length sign) sign
+
+let mu env evdref t =
+  let rec aux v =
+    let v' = hnf env !evdref v in
+      match disc_subset v' with
+      Some (u, p) ->
+	let f, ct = aux u in
+	let p = hnf_nodelta env !evdref p in
+	  (Some (fun x ->
+		   app_opt env evdref 
+		     f (papp evdref sig_proj1 [| u; p; x |])),
+	   ct)
+      | None -> (None, v)
+  in aux t
+
+and coerce loc env evdref (x : Term.constr) (y : Term.constr)
+    : (Term.constr -> Term.constr) option
+    =
+  let rec coerce_unify env x y =
+    let x = hnf env !evdref x and y = hnf env !evdref y in
+      try
+	evdref := the_conv_x_leq env x y !evdref;
+	None
+      with UnableToUnify _ -> coerce' env x y
+  and coerce' env x y : (Term.constr -> Term.constr) option =
+    let subco () = subset_coerce env evdref x y in
+    let dest_prod c =
+      match Reductionops.splay_prod_n env ( !evdref) 1 c with
+      | [(na,b,t)], c -> (na,t), c
+      | _ -> raise NoSubtacCoercion
     in
-      apply_rec [] funj.uj_type argl
-
-  (* appliquer le chemin de coercions de patterns p *)
-  let apply_pattern_coercion loc pat p =
-    List.fold_left
-      (fun pat (co,n) ->
-	 let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
-	   Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
-      pat p
-
-  (* raise Not_found if no coercion found *)
-  let inh_pattern_coerce_to loc pat ind1 ind2 =
-    let p = lookup_pattern_path_between (ind1,ind2) in
-      apply_pattern_coercion loc pat p
-
-  let saturate_evd env evd =
-    Typeclasses.resolve_typeclasses
-      ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd
-
-  (* appliquer le chemin de coercions p à hj *)
-  let apply_coercion env sigma p hj typ_cl =
-    try
-      fst (List.fold_left
-             (fun (ja,typ_cl) i ->
-		let fv,isid = coercion_value i in
-		let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
-		let jres = apply_coercion_args env argl fv in
-		  (if isid then
-		     { uj_val = ja.uj_val; uj_type = jres.uj_type }
-		   else
-		     jres),
-		jres.uj_type)
-             (hj,typ_cl) p)
-    with e when Errors.noncritical e -> anomaly "apply_coercion"
-
-  let inh_app_fun env evd j =
-    let t = whd_betadeltaiota env evd j.uj_type in
-      match kind_of_term t with
-	| Prod (_,_,_) -> (evd,j)
-	| Evar ev ->
-	    let (evd',t) = define_evar_as_product evd ev in
-	      (evd',{ uj_val = j.uj_val; uj_type = t })
-	| _ ->
-      	    let t,p =
-	      lookup_path_to_fun_from env evd j.uj_type in
-	      (evd,apply_coercion env evd p j t)
-
-  let inh_app_fun resolve_tc env evd j =
-    try inh_app_fun env evd j
-    with
-    | Not_found when not resolve_tc -> (evd, j)
-    | Not_found ->
-      try inh_app_fun env (saturate_evd env evd) j
-      with Not_found -> (evd, j)
-
-  let inh_tosort_force loc env evd j =
-    try
-      let t,p = lookup_path_to_sort_from env evd j.uj_type in
-      let j1 = apply_coercion env evd p j t in
-      let j2 = on_judgment_type (whd_evar evd) j1 in
-        (evd,type_judgment env j2)
-    with Not_found ->
-      error_not_a_type_loc loc env evd j
-
-  let inh_coerce_to_sort loc env evd j =
-    let typ = whd_betadeltaiota env evd j.uj_type in
-      match kind_of_term typ with
-	| Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
-	| Evar ev when not (is_defined_evar evd ev) ->
-	    let (evd',s) = define_evar_as_sort evd ev in
-	      (evd',{ utj_val = j.uj_val; utj_type = s })
-	| _ ->
-	    inh_tosort_force loc env evd j
-
-  let inh_coerce_to_base loc env evd j = (evd, j)
-  let inh_coerce_to_prod loc env evd t = (evd, t)
-
-  let inh_coerce_to_fail env evd rigidonly v t c1 =
-    if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
-    then
-      raise NoCoercion
-    else
-    let v', t' =
+    let coerce_application typ typ' c c' l l' =
+      let len = Array.length l in
+      let rec aux tele typ typ' i co =
+	if i < len then
+	  let hdx = l.(i) and hdy = l'.(i) in
+	    try evdref := the_conv_x_leq env hdx hdy !evdref;
+	      let (n, eqT), restT = dest_prod typ in
+	      let (n', eqT'), restT' = dest_prod typ' in
+		aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
+	    with UnableToUnify _ ->
+	      let (n, eqT), restT = dest_prod typ in
+	      let (n', eqT'), restT' = dest_prod typ' in
+	      let _ =
+		try evdref := the_conv_x_leq env eqT eqT' !evdref
+		with UnableToUnify _ -> raise NoSubtacCoercion
+	      in
+		(* Disallow equalities on arities *)
+		if Reduction.is_arity env eqT then raise NoSubtacCoercion;
+		let restargs = lift_args 1
+		  (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
+		in
+		let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
+		let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
+		let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in
+		let evar = make_existential loc env evdref eq in
+		let eq_app x = papp evdref coq_eq_rect
+		  [| eqT; hdx; pred; x; hdy; evar|] 
+		in
+		  aux (hdy :: tele) (subst1 hdx restT) 
+		    (subst1 hdy restT') (succ i)  (fun x -> eq_app (co x))
+	else Some (fun x -> 
+	  let term = co x in
+	    Typing.solve_evars env evdref term)
+      in
+	if isEvar c || isEvar c' then
+	  (* Second-order unification needed. *)
+	  raise NoSubtacCoercion;
+	aux [] typ typ' 0 (fun x -> x)
+    in
+      match (kind_of_term x, kind_of_term y) with
+      | Sort s, Sort s' ->
+        (match s, s' with
+	| Prop x, Prop y when x == y -> None
+	| Prop _, Type _ -> None
+	| Type x, Type y when Univ.Universe.equal x y -> None (* false *)
+	| _ -> subco ())
+      | Prod (name, a, b), Prod (name', a', b') ->
+	  let name' = 
+	    Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env))
+	  in
+	  let env' = push_rel (name', None, a') env in
+	  let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
+	    (* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
+	  let coec1 = app_opt env' evdref c1 (mkRel 1) in
+	    (* env, x : a' |- c1[x] : lift 1 a *)
+	  let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
+	    (* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
+	    (match c1, c2 with
+	     | None, None -> None
+	     | _, _ ->
+		 Some
+		   (fun f ->
+		      mkLambda (name', a',
+				app_opt env' evdref c2
+				  (mkApp (lift 1 f, [| coec1 |])))))
+
+      | App (c, l), App (c', l') ->
+	  (match kind_of_term c, kind_of_term c' with
+	   Ind (i, u), Ind (i', u') -> (* Inductive types *)
+	     let len = Array.length l in
+	     let sigT = delayed_force sigT_typ in
+	     let prod = delayed_force prod_typ in
+	       (* Sigma types *)
+	       if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i'
+		 && (eq_ind i (destIndRef sigT) || eq_ind i (destIndRef prod))
+	       then
+		 if eq_ind i (destIndRef sigT)
+		 then
+		   begin
+		     let (a, pb), (a', pb') =
+		       pair_of_array l, pair_of_array l'
+		     in
+		     let c1 = coerce_unify env a a' in
+		     let remove_head a c =
+		       match kind_of_term c with
+		       | Lambda (n, t, t') -> c, t'
+			   (*| Prod (n, t, t') -> t'*)
+		       | Evar (k, args) ->
+			   let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in
+			     evdref := evs;
+			     let (n, dom, rng) = destLambda t in
+			     let dom = whd_evar !evdref dom in
+			       if isEvar dom then
+				 let (domk, args) = destEvar dom in
+				   evdref := define domk a !evdref;
+			       else ();
+			       t, rng
+		       | _ -> raise NoSubtacCoercion
+		     in
+		     let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
+		     let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in
+		     let c2 = coerce_unify env' b b' in
+		       match c1, c2 with
+		       | None, None -> None
+		       | _, _ ->
+			   Some
+			     (fun x ->
+				let x, y =
+				  app_opt env' evdref c1 (papp evdref sigT_proj1
+							    [| a; pb; x |]),
+				  app_opt env' evdref c2 (papp evdref sigT_proj2
+							  [| a; pb; x |])
+				in
+				  papp evdref sigT_intro [| a'; pb'; x ; y |])
+		   end
+		 else
+		   begin
+		     let (a, b), (a', b') =
+		       pair_of_array l, pair_of_array l'
+		     in
+		     let c1 = coerce_unify env a a' in
+		     let c2 = coerce_unify env b b' in
+		       match c1, c2 with
+		       None, None -> None
+		       | _, _ ->
+			   Some
+			     (fun x ->
+				let x, y =
+				  app_opt env evdref c1 (papp evdref prod_proj1
+							   [| a; b; x |]),
+				  app_opt env evdref c2 (papp evdref prod_proj2
+							   [| a; b; x |])
+				in
+				  papp evdref prod_intro [| a'; b'; x ; y |])
+		   end
+	       else
+		 if eq_ind i i' && Int.equal len (Array.length l') then
+		   let evm = !evdref in
+		     (try subco ()
+		      with NoSubtacCoercion ->
+			let typ = Typing.type_of env evm c in
+			let typ' = Typing.type_of env evm c' in
+			  (* 			     if not (is_arity env evm typ) then *)
+			  coerce_application typ typ' c c' l l')
+		       (* 			     else subco () *)
+		 else
+		   subco ()
+	   | x, y when Constr.equal c c' ->
+	       if Int.equal (Array.length l) (Array.length l') then
+		 let evm =  !evdref in
+		 let lam_type = Typing.type_of env evm c in
+		 let lam_type' = Typing.type_of env evm c' in
+		   (* 			 if not (is_arity env evm lam_type) then ( *)
+		   coerce_application lam_type lam_type' c c' l l'
+		     (* 			 ) else subco () *)
+	       else subco ()
+	   | _ -> subco ())
+      | _, _ ->  subco ()
+
+  and subset_coerce env evdref x y =
+    match disc_subset x with
+    Some (u, p) ->
+      let c = coerce_unify env u y in
+      let f x =
+	app_opt env evdref c (papp evdref sig_proj1 [| u; p; x |])
+      in Some f
+    | None ->
+	match disc_subset y with
+	Some (u, p) ->
+	  let c = coerce_unify env x u in
+	    Some
+	      (fun x ->
+		 let cx = app_opt env evdref c x in
+		 let evar = make_existential loc env evdref (mkApp (p, [| cx |]))
+		 in
+		   (papp evdref sig_intro [| u; p; cx; evar |]))
+	| None ->
+	    raise NoSubtacCoercion
+  in coerce_unify env x y
+
+let coerce_itf loc env evd v t c1 =
+  let evdref = ref evd in
+  let coercion = coerce loc env evdref t c1 in
+  let t = Option.map (app_opt env evdref coercion) v in
+    !evdref, t
+
+let saturate_evd env evd =
+  Typeclasses.resolve_typeclasses
+    ~filter:Typeclasses.no_goals ~split:false ~fail:false env evd
+
+(* appliquer le chemin de coercions p à hj *)
+let apply_coercion env sigma p hj typ_cl =
+  try
+    let j,t,evd = 
+      List.fold_left
+        (fun (ja,typ_cl,sigma) i ->
+	  let ((fv,isid,isproj),ctx) = coercion_value i in
+	  let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
+	  let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
+	  let sigma, jres = 
+	    apply_coercion_args env sigma true isproj argl fv 
+	  in
+	    (if isid then
+	      { uj_val = ja.uj_val; uj_type = jres.uj_type }
+	     else
+	      jres),
+	    jres.uj_type,sigma)
+      (hj,typ_cl,sigma) p
+    in evd, j
+  with NoCoercion as e -> raise e
+  | e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion")
+
+let inh_app_fun env evd j =
+  let t = whd_betadeltaiota env evd j.uj_type in
+    match kind_of_term t with
+    | Prod (_,_,_) -> (evd,j)
+    | Evar ev ->
+	let (evd',t) = define_evar_as_product evd ev in
+	  (evd',{ uj_val = j.uj_val; uj_type = t })
+    | _ ->
+      	try let t,p =
+	  lookup_path_to_fun_from env evd j.uj_type in
+	    apply_coercion env evd p j t
+	with Not_found | NoCoercion when Flags.is_program_mode () ->
+	  try
+	    let evdref = ref evd in
+	    let coercef, t = mu env evdref t in
+	    let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in
+	      (!evdref, res)
+	  with NoSubtacCoercion | NoCoercion ->
+	    (evd,j)
+
+let inh_app_fun resolve_tc env evd j =
+  try inh_app_fun env evd j
+  with
+  | Not_found when not resolve_tc 
+    || not !use_typeclasses_for_conversion -> (evd, j)
+  | Not_found ->
+    try inh_app_fun env (saturate_evd env evd) j
+    with Not_found -> (evd, j)
+
+let inh_tosort_force loc env evd j =
+  try
+    let t,p = lookup_path_to_sort_from env evd j.uj_type in
+    let evd,j1 = apply_coercion env evd p j t in
+    let j2 = on_judgment_type (whd_evar evd) j1 in
+      (evd,type_judgment env j2)
+  with Not_found | NoCoercion ->
+    error_not_a_type_loc loc env evd j
+
+let inh_coerce_to_sort loc env evd j =
+  let typ = whd_betadeltaiota env evd j.uj_type in
+    match kind_of_term typ with
+    | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s })
+    | Evar ev when not (is_defined evd (fst ev)) ->
+	let (evd',s) = define_evar_as_sort env evd ev in
+	  (evd',{ utj_val = j.uj_val; utj_type = s })
+    | _ ->
+	inh_tosort_force loc env evd j
+
+let inh_coerce_to_base loc env evd j =
+  if Flags.is_program_mode () then
+    let evdref = ref evd in
+    let ct, typ' = mu env evdref j.uj_type in
+    let res =
+      { uj_val = app_opt env evdref ct j.uj_val;
+	uj_type = typ' }
+    in !evdref, res
+  else (evd, j)
+
+let inh_coerce_to_prod loc env evd t =
+  if Flags.is_program_mode () then
+    let evdref = ref evd in
+    let _, typ' = mu env evdref t in
+      !evdref, typ'
+  else (evd, t)
+
+let inh_coerce_to_fail env evd rigidonly v t c1 =
+  if rigidonly && not (Heads.is_rigid env c1 && Heads.is_rigid env t)
+  then
+    raise NoCoercion
+  else
+    let evd, v', t' =
       try
 	let t2,t1,p = lookup_path_between env evd (t,c1) in
 	  match v with
-	      Some v ->
-		let j =
-		  apply_coercion env evd p
-		    {uj_val = v; uj_type = t} t2 in
-		  Some j.uj_val, j.uj_type
-	    | None -> None, t
+	  | Some v ->
+	    let evd,j =
+	      apply_coercion env evd p
+		{uj_val = v; uj_type = t} t2 in
+	      evd, Some j.uj_val, j.uj_type
+	  | None -> evd, None, t
       with Not_found -> raise NoCoercion
     in
       try (the_conv_x_leq env t' c1 evd, v')
-      with Reduction.NotConvertible -> raise NoCoercion
+      with UnableToUnify _ -> raise NoCoercion
 
-  let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
-    try (the_conv_x_leq env t c1 evd, v)
-    with Reduction.NotConvertible ->
+let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
+  try (the_conv_x_leq env t c1 evd, v)
+  with UnableToUnify (best_failed_evd,e) ->
     try inh_coerce_to_fail env evd rigidonly v t c1
     with NoCoercion ->
-    match
+      match
       kind_of_term (whd_betadeltaiota env evd t),
       kind_of_term (whd_betadeltaiota env evd c1)
-    with
-    | Prod (name,t1,t2), Prod (_,u1,u2) ->
-        (* Conversion did not work, we may succeed with a coercion. *)
-        (* We eta-expand (hence possibly modifying the original term!) *)
-	(* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
-	(* has type forall (x:u1), u2 (with v' recursively obtained) *)
-        (* Note: we retype the term because sort-polymorphism may have *)
-        (* weaken its type *)
-	let name = match name with
-	  | Anonymous -> Name (id_of_string "x")
-	  | _ -> name in
-	let env1 = push_rel (name,None,u1) env in
-	let (evd', v1) =
-	  inh_conv_coerce_to_fail loc env1 evd rigidonly
-            (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
-        let v1 = Option.get v1 in
-	let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
-	let t2 = match v2 with
-	  | None -> subst_term v1 t2
-	  | Some v2 -> Retyping.get_type_of env1 evd' v2 in
-	let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
-	(evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
-    | _ -> raise NoCoercion
-
-  (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-  let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj (n, t) =
-    match n with
-	None ->
-	  let (evd', val') =
-	    try
-	      inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
-	    with
-            | NoCoercion when not resolve_tc -> error_actual_type_loc loc env evd cj t
-            | NoCoercion ->
-	      let evd = saturate_evd env evd in
-		try
-		  inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
-		with NoCoercion ->
-		  error_actual_type_loc loc env evd cj t
-	  in
-	  let val' = match val' with Some v -> v | None -> assert(false) in
-	    (evd',{ uj_val = val'; uj_type = t })
-      | Some (init, cur) -> (evd, cj)
+      with
+      | Prod (name,t1,t2), Prod (_,u1,u2) ->
+          (* Conversion did not work, we may succeed with a coercion. *)
+          (* We eta-expand (hence possibly modifying the original term!) *)
+	  (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
+	  (* has type forall (x:u1), u2 (with v' recursively obtained) *)
+          (* Note: we retype the term because sort-polymorphism may have *)
+          (* weaken its type *)
+	  let name = match name with
+	    | Anonymous -> Name Namegen.default_dependent_ident
+	    | _ -> name in
+	  let env1 = push_rel (name,None,u1) env in
+	  let (evd', v1) =
+	    inh_conv_coerce_to_fail loc env1 evd rigidonly
+              (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
+          let v1 = Option.get v1 in
+	  let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
+	  let t2 = match v2 with
+	    | None -> subst_term v1 t2
+	    | Some v2 -> Retyping.get_type_of env1 evd' v2 in
+	  let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
+	    (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
+      | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e))
 
-  let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false
-  let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true
+(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
+let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t =
+  let (evd', val') =
+    try
+      inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t
+    with NoCoercionNoUnifier (best_failed_evd,e) ->
+      try
+	if Flags.is_program_mode () then
+	  coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
+	else raise NoSubtacCoercion
+      with
+      | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion ->
+	  error_actual_type_loc loc env best_failed_evd cj t e
+      | NoSubtacCoercion ->
+	let evd' = saturate_evd env evd in
+      	  try
+	    if evd' == evd then 
+	      error_actual_type_loc loc env best_failed_evd cj t e
+	    else 
+      	      inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t
+	  with NoCoercionNoUnifier (best_failed_evd,e) ->
+	    error_actual_type_loc loc env best_failed_evd cj t e
+  in
+  let val' = match val' with Some v -> v | None -> assert(false) in
+    (evd',{ uj_val = val'; uj_type = t })
 
+let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false
+let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true
 
-    let inh_conv_coerces_to loc env (evd : evar_map) t (abs, t') =
-      if abs = None then
-	try
-	  fst (inh_conv_coerce_to_fail loc env evd true None t t')
-	with NoCoercion ->
-	  evd (* Maybe not enough information to unify *)
-      else
-        evd
-      (* Still problematic, as it changes unification
-      let nabsinit, nabs =
-	match abs with
-	    None -> 0, 0
-	  | Some (init, cur) -> init, cur
-      in
-	try
-	  let (rels, rng) =
-	    (* a little more effort to get products is needed *)
-	    try decompose_prod_n nabs t
-	    with _ ->
-	      if !Flags.debug then
-		msg_warning (str "decompose_prod_n failed");
-	      raise (Invalid_argument "Coercion.inh_conv_coerces_to")
-	  in
-	    (* The final range free variables must have been replaced by evars, we accept only that evars
-	       in rng are applied to free vars. *)
-	    if noccur_with_meta 0 (succ nabsinit) rng then (
-	      let env', t, t' =
-		let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
-		  env', rng, lift nabs t'
-	      in
-		try
-		  pi1 (inh_conv_coerce_to_fail loc env' evd None t t')
-		with NoCoercion ->
-		  evd) (* Maybe not enough information to unify *)
-	      (*let sigma =  evd in
-		error_cannot_coerce env' sigma (t, t'))*)
-	    else evd
-	with Invalid_argument _ -> evd	  *)
-end
+let inh_conv_coerces_to loc env evd t t' =
+  try
+    fst (inh_conv_coerce_to_fail loc env evd true None t t')
+  with NoCoercion ->
+    evd (* Maybe not enough information to unify *)
+      
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index f06f58f4..f511f977 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -1,69 +1,62 @@
 (************************************************************************)
 (*  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 Util
 open Evd
 open Names
 open Term
-open Sign
 open Environ
-open Evarutil
 open Glob_term
 
-module type S = sig
-  (** {6 Coercions. } *)
-
-  (** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type a product; it returns [j] if no coercion is applicable.
-     resolve_tc=false disables resolving type classes (as the last
-     resort before failing) *)
-  val inh_app_fun :
-    bool -> env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
-
-  (** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type a sort; it fails if no coercion is applicable *)
-  val inh_coerce_to_sort : loc ->
-    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
-
-  (** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
-     inserts a coercion into [j], if needed, in such a way it gets as
-     type its base type (the notion depends on the coercion system) *)
-  val inh_coerce_to_base : loc ->
-    env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
-
-  (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
-  val inh_coerce_to_prod : loc ->
-    env -> evar_map -> type_constraint_type -> evar_map * type_constraint_type
-
-  (** [inh_conv_coerce_to resolve_tc loc env isevars j t] coerces [j] to an object of type
-     [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
-     [j.uj_type] are convertible; it fails if no coercion is applicable.
-     resolve_tc=false disables resolving type classes (as the last
-     resort before failing) *)
-  val inh_conv_coerce_to : bool -> loc ->
-    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
-
-  val inh_conv_coerce_rigid_to : bool -> loc ->
-    env -> evar_map -> unsafe_judgment -> type_constraint_type -> evar_map * unsafe_judgment
-
-  (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
-     is coercible to an object of type [t'] adding evar constraints if needed;
-     it fails if no coercion exists *)
-  val inh_conv_coerces_to : loc ->
-    env -> evar_map -> types -> type_constraint_type -> evar_map
-
-  (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
-     pattern [pat] typed in [ind1] into a pattern typed in [ind2];
-     raises [Not_found] if no coercion found *)
-  val inh_pattern_coerce_to :
-    loc  -> cases_pattern -> inductive -> inductive -> cases_pattern
-end
-
-module Default : S
+(** {6 Coercions. } *)
+
+(** [inh_app_fun resolve_tc env isevars j] coerces [j] to a function; i.e. it
+    inserts a coercion into [j], if needed, in such a way it gets as
+    type a product; it returns [j] if no coercion is applicable.
+    resolve_tc=false disables resolving type classes (as the last
+    resort before failing) *)
+val inh_app_fun : bool ->
+  env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
+
+(** [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+    inserts a coercion into [j], if needed, in such a way it gets as
+    type a sort; it fails if no coercion is applicable *)
+val inh_coerce_to_sort : Loc.t ->
+  env -> evar_map -> unsafe_judgment -> evar_map * unsafe_type_judgment
+
+(** [inh_coerce_to_base env isevars j] coerces [j] to its base type; i.e. it
+    inserts a coercion into [j], if needed, in such a way it gets as
+    type its base type (the notion depends on the coercion system) *)
+val inh_coerce_to_base : Loc.t ->
+  env -> evar_map -> unsafe_judgment -> evar_map * unsafe_judgment
+
+(** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *)
+val inh_coerce_to_prod : Loc.t ->
+  env -> evar_map -> types -> evar_map * types
+
+(** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an 
+    object of type [t]; i.e. it inserts a coercion into [j], if needed, in such
+    a way [t] and [j.uj_type] are convertible; it fails if no coercion is
+    applicable. resolve_tc=false disables resolving type classes (as the last
+    resort before failing) *)
+val inh_conv_coerce_to : bool -> Loc.t ->
+  env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment
+
+val inh_conv_coerce_rigid_to : bool -> Loc.t ->
+  env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment
+
+(** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+    is coercible to an object of type [t'] adding evar constraints if needed;
+    it fails if no coercion exists *)
+val inh_conv_coerces_to : Loc.t ->
+  env -> evar_map -> types -> types -> evar_map
+
+(** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+    pattern [pat] typed in [ind1] into a pattern typed in [ind2];
+    raises [Not_found] if no coercion found *)
+val inh_pattern_coerce_to :
+  Loc.t -> env -> cases_pattern -> inductive -> inductive -> cases_pattern
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
new file mode 100644
index 00000000..a6e2bc19
--- /dev/null
+++ b/pretyping/constr_matching.ml
@@ -0,0 +1,494 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i*)
+open Pp
+open Errors
+open Util
+open Names
+open Globnames
+open Nameops
+open Termops
+open Reductionops
+open Term
+open Vars
+open Context
+open Pattern
+open Patternops
+open Misctypes
+(*i*)
+
+(* Given a term with second-order variables in it,
+   represented by Meta's, and possibly applied using [SOAPP] to
+   terms, this function will perform second-order, binding-preserving,
+   matching, in the case where the pattern is a pattern in the sense
+   of Dale Miller.
+
+   ALGORITHM:
+
+   Given a pattern, we decompose it, flattening Cast's and apply's,
+   recursing on all operators, and pushing the name of the binder each
+   time we descend a binder.
+
+   When we reach a first-order variable, we ask that the corresponding
+   term's free-rels all be higher than the depth of the current stack.
+
+   When we reach a second-order application, we ask that the
+   intersection of the free-rels of the term and the current stack be
+   contained in the arguments of the application, and in that case, we
+   construct a LAMBDA with the names on the stack.
+
+ *)
+
+type bound_ident_map = Id.t Id.Map.t
+
+exception PatternMatchingFailure
+
+let warn_bound_meta name =
+  msg_warning (str "Collision between bound variable " ++ pr_id name ++
+    str " and a metavariable of same name.")
+
+let warn_bound_bound name =
+  msg_warning (str "Collision between bound variables of name " ++ pr_id name)
+
+let warn_bound_again name =
+  msg_warning (str "Collision between bound variable " ++ pr_id name ++
+    str " and another bound variable of same name.")
+
+let constrain n (ids, m as x) (names, terms as subst) =
+  try
+    let (ids', m') = Id.Map.find n terms in
+    if List.equal Id.equal ids ids' && eq_constr m m' then subst
+    else raise PatternMatchingFailure
+  with Not_found ->
+    let () = if Id.Map.mem n names then warn_bound_meta n in
+    (names, Id.Map.add n x terms)
+
+let add_binders na1 na2 (names, terms as subst) = match na1, na2 with
+| Name id1, Name id2 ->
+  if Id.Map.mem id1 names then
+    let () = warn_bound_bound id1 in
+    (names, terms)
+  else
+    let names = Id.Map.add id1 id2 names in
+    let () = if Id.Map.mem id1 terms then warn_bound_again id1 in
+    (names, terms)
+| _ -> subst
+
+let rec build_lambda vars stk m = match vars with
+| [] ->
+  let len = List.length stk in
+  lift (-1 * len) m
+| n :: vars ->
+  (* change [ x1 ... xn y z1 ... zm |- t ] into
+     [ x1 ... xn z1 ... zm |- lam y. t ] *)
+  let len = List.length stk in
+  let init i =
+    if i < pred n then mkRel (i + 2)
+    else if Int.equal i (pred n) then mkRel 1
+    else mkRel (i + 1)
+  in
+  let m = substl (List.init len init) m in
+  let pre, suf = List.chop (pred n) stk in
+  match suf with
+  | [] -> assert false
+  | (_, na, t) :: suf ->
+    let map i = if i > n then pred i else i in
+    let vars = List.map map vars in
+    (** Check that the abstraction is legal *)
+    let frels = free_rels t in
+    let brels = List.fold_right Int.Set.add vars Int.Set.empty in
+    let () = if not (Int.Set.subset frels brels) then raise PatternMatchingFailure in
+    (** Create the abstraction *)
+    let m = mkLambda (na, t, m) in
+    build_lambda vars (pre @ suf) m
+
+let rec extract_bound_aux k accu frels stk = match stk with
+| [] -> accu
+| (na1, na2, _) :: stk ->
+  if Int.Set.mem k frels then
+    begin match na1 with
+    | Name id ->
+      let () = assert (match na2 with Anonymous -> false | Name _ -> true) in
+      let () = if Id.Set.mem id accu then raise PatternMatchingFailure in
+      extract_bound_aux (k + 1) (Id.Set.add id accu) frels stk
+    | Anonymous -> raise PatternMatchingFailure
+    end
+  else extract_bound_aux (k + 1) accu frels stk
+
+let extract_bound_vars frels stk =
+  extract_bound_aux 1 Id.Set.empty frels stk
+
+let dummy_constr = mkProp
+
+let make_renaming ids = function
+| (Name id, Name _, _) ->
+  begin
+    try mkRel (List.index Id.equal id ids)
+    with Not_found -> dummy_constr
+  end
+| _ -> dummy_constr
+
+let merge_binding allow_bound_rels stk n cT subst =
+  let c = match stk with
+  | [] -> (* Optimization *)
+    ([], cT)
+  | _ ->
+    let frels = free_rels cT in
+    if allow_bound_rels then
+      let vars = extract_bound_vars frels stk in
+      let ordered_vars = Id.Set.elements vars in
+      let rename binding = make_renaming ordered_vars binding in
+      let renaming = List.map rename stk in
+      (ordered_vars, substl renaming cT)
+    else
+      let depth = List.length stk in
+      let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in
+      if depth < min_elt then
+        ([], lift (- depth) cT)
+      else raise PatternMatchingFailure
+  in
+  constrain n c subst
+      
+let matches_core env sigma convert allow_partial_app allow_bound_rels pat c =
+  let convref ref c = 
+    match ref, kind_of_term c with
+    | VarRef id, Var id' -> Names.id_eq id id'
+    | ConstRef c, Const (c',_) -> Names.eq_constant c c'
+    | IndRef i, Ind (i', _) -> Names.eq_ind i i'
+    | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c'
+    | _, _ -> 
+      (if convert then 
+	  let sigma,c' = Evd.fresh_global env sigma ref in
+	    is_conv env sigma c' c
+       else false)
+  in
+  let rec sorec stk env subst p t =
+    let cT = strip_outer_cast t in
+    match p,kind_of_term cT with
+      | PSoApp (n,args),m ->
+        let fold (ans, seen) = function
+        | PRel n ->
+          let () = if Int.Set.mem n seen then error "Non linear second-order pattern" in
+          (n :: ans, Int.Set.add n seen)
+        | _ -> error "Only bound indices allowed in second order pattern matching."
+        in
+        let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in
+        let frels = free_rels cT in
+        if Int.Set.subset frels relset then
+          constrain n ([], build_lambda relargs stk cT) subst
+        else
+          raise PatternMatchingFailure
+
+      | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst
+
+      | PMeta None, m -> subst
+
+      | PRef (VarRef v1), Var v2 when Id.equal v1 v2 -> subst
+
+      | PVar v1, Var v2 when Id.equal v1 v2 -> subst
+
+      | PRef ref, _ when convref ref cT -> subst
+
+      | PRel n1, Rel n2 when Int.equal n1 n2 -> subst
+
+      | PSort GProp, Sort (Prop Null) -> subst
+
+      | PSort GSet, Sort (Prop Pos) -> subst
+
+      | PSort (GType _), Sort (Type _) -> subst
+
+      | PApp (p, [||]), _ -> sorec stk env subst p t
+
+      | PApp (PApp (h, a1), a2), _ ->
+          sorec stk env subst (PApp(h,Array.append a1 a2)) t
+
+      | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app ->
+         (let diff = Array.length args2 - Array.length args1 in
+          if diff >= 0 then
+            let args21, args22 = Array.chop diff args2 in
+	    let c = mkApp(c2,args21) in
+            let subst =
+              match meta with
+              | None -> subst
+              | Some n -> merge_binding allow_bound_rels stk n c subst in
+            Array.fold_left2 (sorec stk env) subst args1 args22
+          else (* Might be a projection on the right *)
+	    match kind_of_term c2 with
+	    | Proj (pr, c) when not (Projection.unfolded pr) ->
+	      (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in
+		     sorec stk env subst p term
+	       with Retyping.RetypeError _ -> raise PatternMatchingFailure)
+	    | _ -> raise PatternMatchingFailure)
+	   
+      | PApp (c1,arg1), App (c2,arg2) ->
+	(match c1, kind_of_term c2 with
+	| PRef (ConstRef r), Proj (pr,c) when not (eq_constant r (Projection.constant pr))
+	    || Projection.unfolded pr ->
+	  raise PatternMatchingFailure
+	| PProj (pr1,c1), Proj (pr,c) ->
+	  if Projection.equal pr1 pr then 
+	    try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c) arg1 arg2
+	    with Invalid_argument _ -> raise PatternMatchingFailure
+	  else raise PatternMatchingFailure
+	| _, Proj (pr,c) when not (Projection.unfolded pr) ->
+	  (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in
+		 sorec stk env subst p term
+	   with Retyping.RetypeError _ -> raise PatternMatchingFailure)	    
+	| _, _ ->
+          try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c2) arg1 arg2
+          with Invalid_argument _ -> raise PatternMatchingFailure)
+	  
+      | PApp (PRef (ConstRef c1), _), Proj (pr, c2) 
+	when Projection.unfolded pr || not (eq_constant c1 (Projection.constant pr)) -> 
+	raise PatternMatchingFailure
+	
+      | PApp (c, args), Proj (pr, c2) ->
+	(try let term = Retyping.expand_projection env sigma pr c2 [] in
+	       sorec stk env subst p term
+	 with Retyping.RetypeError _ -> raise PatternMatchingFailure)
+
+      | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 ->
+          sorec stk env subst c1 c2
+
+      | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
+	  sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env)
+            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+
+      | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
+	  sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env)
+            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+
+      | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
+	  sorec ((na1,na2,t2)::stk) (Environ.push_rel (na2,Some c2,t2) env)
+            (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2
+
+      | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
+	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
+	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
+	  let n = rel_context_length ctx in
+          let n' = rel_context_length ctx' in
+	  if noccur_between 1 n b2 && noccur_between 1 n' b2' then
+	    let s =
+	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in
+	    let s' =
+	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in
+	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
+	    sorec s' (Environ.push_rel_context ctx' env)
+	      (sorec s (Environ.push_rel_context ctx env) (sorec stk env subst a1 a2) b1 b2) b1' b2'
+          else
+            raise PatternMatchingFailure
+
+      | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) ->
+	  let n2 = Array.length br2 in
+          let () = match ci1.cip_ind with
+          | None -> ()
+          | Some ind1 ->
+            (** ppedrot: Something spooky going here. The comparison used to be
+                the generic one, so I may have broken something. *)
+            if not (eq_ind ind1 ci2.ci_ind) then raise PatternMatchingFailure
+          in
+          let () =
+            if not ci1.cip_extensible && not (Int.equal (List.length br1) n2)
+            then raise PatternMatchingFailure
+          in
+	  let chk_branch subst (j,n,c) =
+	    (* (ind,j+1) is normally known to be a correct constructor
+	       and br2 a correct match over the same inductive *)
+	    assert (j < n2);
+	    sorec stk env subst c br2.(j)
+	  in
+	  let chk_head = sorec stk env (sorec stk env subst a1 a2) p1 p2 in
+	  List.fold_left chk_branch chk_head br1
+
+      |	PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst
+      |	PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst
+      | _ -> raise PatternMatchingFailure
+
+  in
+  sorec [] env (Id.Map.empty, Id.Map.empty) pat c
+
+let matches_core_closed env sigma convert allow_partial_app pat c =
+  let names, subst = matches_core env sigma convert allow_partial_app false pat c in
+  (names, Id.Map.map snd subst)
+
+let extended_matches env sigma = matches_core env sigma false true true
+
+let matches env sigma pat c = snd (matches_core_closed env sigma false true pat c)
+
+let special_meta = (-1)
+
+type matching_result =
+    { m_sub : bound_ident_map * patvar_map;
+      m_ctx : constr; }
+
+let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=c; } , (IStream.thunk n) )
+
+let isPMeta = function PMeta _ -> true | _ -> false
+
+let matches_head env sigma pat c =
+  let head =
+    match pat, kind_of_term c with
+    | PApp (c1,arg1), App (c2,arg2) ->
+        if isPMeta c1 then c else
+        let n1 = Array.length arg1 in
+        if n1 < Array.length arg2 then mkApp (c2,Array.sub arg2 0 n1) else c
+    | c1, App (c2,arg2) when not (isPMeta c1) -> c2
+    | _ -> c in
+  matches env sigma pat head
+
+(* Tells if it is an authorized occurrence and if the instance is closed *)
+let authorized_occ env sigma partial_app closed pat c mk_ctx next =
+  try
+    let subst = matches_core_closed env sigma false partial_app pat c in
+    if closed && Id.Map.exists (fun _ c -> not (closed0 c)) (snd subst)
+    then next ()
+    else mkresult subst (mk_ctx (mkMeta special_meta)) next
+  with PatternMatchingFailure -> next ()
+
+(* Tries to match a subterm of [c] with [pat] *)
+let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
+  let rec aux env c mk_ctx next =
+  match kind_of_term c with
+  | Cast (c1,k,c2) ->
+      let next_mk_ctx lc = mk_ctx (mkCast (List.hd lc, k,c2)) in
+      let next () = try_aux [env] [c1] next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Lambda (x,c1,c2) ->
+      let next_mk_ctx lc = mk_ctx (mkLambda (x,List.hd lc,List.nth lc 1)) in
+      let next () = 
+	let env' = Environ.push_rel (x,None,c1) env in
+	  try_aux [env;env'] [c1; c2] next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Prod (x,c1,c2) ->
+      let next_mk_ctx lc = mk_ctx (mkProd (x,List.hd lc,List.nth lc 1)) in
+      let next () = 
+	let env' = Environ.push_rel (x,None,c1) env in
+	  try_aux [env;env'] [c1;c2] next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | LetIn (x,c1,t,c2) ->
+      let next_mk_ctx = function
+      | [c1;c2] -> mkLetIn (x,c1,t,c2)
+      | _ -> assert false
+      in
+      let next () = 
+	let env' = Environ.push_rel (x,Some c1,t) env in
+	  try_aux [env;env'] [c1;c2] next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | App (c1,lc) ->
+      let next () =
+        let topdown = true in
+        if partial_app then
+          if topdown then
+            let lc1 = Array.sub lc 0 (Array.length lc - 1) in
+            let app = mkApp (c1,lc1) in
+            let mk_ctx = function
+              | [app';c] -> mk_ctx (mkApp (app',[|c|]))
+              | _ -> assert false in
+            try_aux [env] [app;Array.last lc] mk_ctx next
+          else
+            let rec aux2 app args next =
+              match args with
+              | [] ->
+                  let mk_ctx le =
+                    mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
+                  try_aux [env] (c1::Array.to_list lc) mk_ctx next
+              | arg :: args ->
+                  let app = mkApp (app,[|arg|]) in
+                  let next () = aux2 app args next in
+                  let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in
+                  aux env app mk_ctx next in
+            aux2 c1 (Array.to_list lc) next
+        else
+          let mk_ctx le =
+            mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
+          try_aux [env] (c1::Array.to_list lc) mk_ctx next
+      in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Case (ci,hd,c1,lc) ->
+      let next_mk_ctx = function
+      | [] -> assert false
+      | c1 :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
+      in
+      let next () = try_aux [env] (c1 :: Array.to_list lc) next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Fix (indx,(names,types,bodies)) ->
+    let nb_fix = Array.length types in
+    let next_mk_ctx le =
+      let (ntypes,nbodies) = CList.chop nb_fix le in
+      mk_ctx (mkFix (indx,(names, Array.of_list ntypes, Array.of_list nbodies))) in
+    let next () =
+      try_aux
+	[env] ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in
+    authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | CoFix (i,(names,types,bodies)) ->
+    let nb_fix = Array.length types in
+    let next_mk_ctx le =
+      let (ntypes,nbodies) = CList.chop nb_fix le in
+      mk_ctx (mkCoFix (i,(names, Array.of_list ntypes, Array.of_list nbodies))) in
+    let next () =
+      try_aux [env] ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in
+    authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Proj (p,c') ->
+    let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in
+    let next () = 
+      if partial_app then
+	try 
+	  let term = Retyping.expand_projection env sigma p c' [] in
+	    aux env term mk_ctx next
+	with Retyping.RetypeError _ -> raise PatternMatchingFailure
+      else
+	try_aux [env] [c'] next_mk_ctx next in
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+  | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ ->
+      authorized_occ env sigma partial_app closed pat c mk_ctx next
+
+  (* Tries [sub_match] for all terms in the list *)
+  and try_aux lenv lc mk_ctx next =
+    let rec try_sub_match_rec lacc lenv lc = 
+      match lenv, lc with
+      | _, [] -> next ()
+      | env :: tlenv, c::tl ->
+          let mk_ctx ce = mk_ctx (List.rev_append lacc (ce::tl)) in
+          let next () = 
+	    let env' = match tlenv with [] -> lenv | _ -> tlenv in
+	      try_sub_match_rec (c::lacc) env' tl 
+	  in
+            aux env c mk_ctx next 
+      | _ -> assert false in
+    try_sub_match_rec [] lenv lc in
+  let lempty () = IStream.Nil in
+  let result () = aux env c (fun x -> x) lempty in
+  IStream.thunk result
+
+let match_subterm env sigma pat c = sub_match env sigma pat c
+
+let match_appsubterm env sigma pat c = 
+  sub_match ~partial_app:true env sigma pat c
+
+let match_subterm_gen env sigma app pat c = 
+  sub_match ~partial_app:app env sigma pat c
+
+let is_matching env sigma pat c =
+  try let _ = matches env sigma pat c in true
+  with PatternMatchingFailure -> false
+
+let is_matching_head env sigma pat c =
+  try let _ = matches_head env sigma pat c in true
+  with PatternMatchingFailure -> false
+
+let is_matching_appsubterm ?(closed=true) env sigma pat c =
+  let results = sub_match ~partial_app:true ~closed env sigma pat c in
+  not (IStream.is_empty results)
+
+let matches_conv env sigma c p =
+  snd (matches_core_closed env sigma true false c p)
+
+let is_matching_conv env sigma pat n =
+  try let _ = matches_conv env sigma pat n in true
+  with PatternMatchingFailure -> false
diff --git a/pretyping/matching.mli b/pretyping/constr_matching.mli
index 1a47b714..67854a89 100644
--- a/pretyping/matching.mli
+++ b/pretyping/constr_matching.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        *)
@@ -12,7 +12,6 @@ open Names
 open Term
 open Environ
 open Pattern
-open Termops
 
 (** [PatternMatchingFailure] is the exception raised when pattern
   matching fails *)
@@ -25,56 +24,60 @@ val special_meta : metavariable
 (** [bound_ident_map] represents the result of matching binding
    identifiers of the pattern with the binding identifiers of the term
    matched *)
-type bound_ident_map = (identifier * identifier) list
+type bound_ident_map = Id.t Id.Map.t
 
 (** [matches pat c] matches [c] against [pat] and returns the resulting
    assignment of metavariables; it raises [PatternMatchingFailure] if
    not matchable; bindings are given in increasing order based on the
    numbers given in the pattern *)
-val matches : constr_pattern -> constr -> patvar_map
+val matches : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
+
+(** [matches_head pat c] does the same as [matches pat c] but accepts
+    [pat] to match an applicative prefix of [c] *)
+val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
 
 (** [extended_matches pat c] also returns the names of bound variables
    in [c] that matches the bound variables in [pat]; if several bound
    variables or metavariables have the same name, the metavariable,
    or else the rightmost bound variable, takes precedence *)
 val extended_matches :
-  constr_pattern -> constr -> bound_ident_map * extended_patvar_map
+  env -> Evd.evar_map -> constr_pattern -> constr -> bound_ident_map * extended_patvar_map
 
 (** [is_matching pat c] just tells if [c] matches against [pat] *)
-val is_matching : constr_pattern -> constr -> bool
+val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool
+
+(** [is_matching_head pat c] just tells if [c] or an applicative
+    prefix of it matches against [pat] *)
+val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool
 
 (** [matches_conv env sigma] matches up to conversion in environment
    [(env,sigma)] when constants in pattern are concerned; it raises
    [PatternMatchingFailure] if not matchable; bindings are given in
    increasing order based on the numbers given in the pattern *)
-val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
+val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
 
 (** The type of subterm matching results: a substitution + a context
-   (whose hole is denoted with [special_meta]) + a continuation that
-   either returns the next matching subterm or raise PatternMatchingFailure *)
-type subterm_matching_result =
-    (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result)
+   (whose hole is denoted here with [special_meta]) *)
+type matching_result =
+    { m_sub : bound_ident_map * patvar_map;
+      m_ctx : constr }
 
 (** [match_subterm n pat c] returns the substitution and the context
-   corresponding to the first **closed** subterm of [c] matching [pat], and
-   a continuation that looks for the next matching subterm.
-   It raises PatternMatchingFailure if no subterm matches the pattern *)
-val match_subterm : constr_pattern -> constr -> subterm_matching_result
+   corresponding to each **closed** subterm of [c] matching [pat]. *)
+val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
 
 (** [match_appsubterm pat c] returns the substitution and the context
-   corresponding to the first **closed** subterm of [c] matching [pat],
-   considering application contexts as well. It also returns a
-   continuation that looks for the next matching subterm.
-   It raises PatternMatchingFailure if no subterm matches the pattern *)
-val match_appsubterm : constr_pattern -> constr -> subterm_matching_result
+   corresponding to each **closed** subterm of [c] matching [pat],
+   considering application contexts as well. *)
+val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
 
 (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : bool (** true = with app context *) ->
-   constr_pattern -> constr -> subterm_matching_result
+val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) ->
+   constr_pattern -> constr -> matching_result IStream.t
 
 (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches
    against [pat] taking partial subterms into consideration *)
-val is_matching_appsubterm : ?closed:bool -> constr_pattern -> constr -> bool
+val is_matching_appsubterm : ?closed:bool -> env -> Evd.evar_map -> constr_pattern -> constr -> bool
 
 (** [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
    up to conversion for constants in patterns *)
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 9e808dd4..046ee0da 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -1,38 +1,51 @@
 (************************************************************************)
 (*  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 Univ
 open Names
 open Term
-open Declarations
-open Inductive
+open Vars
+open Context
 open Inductiveops
 open Environ
-open Sign
 open Glob_term
-open Nameops
+open Glob_ops
 open Termops
 open Namegen
 open Libnames
+open Globnames
 open Nametab
-open Evd
 open Mod_subst
+open Misctypes
+open Decl_kinds
 
-let dl = dummy_loc
+let dl = Loc.ghost
+
+(** Should we keep details of universes during detyping ? *)
+let print_universes = Flags.univ_print
+
+(** If true, prints local context of evars, whatever print_arguments *)
+let print_evar_arguments = ref false
+
+let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env
+let add_name_opt na b t (nenv, env) = 
+  match t with
+  | None -> Termops.add_name na nenv, env
+  | Some t -> add_name na b t (nenv, env)
 
 (****************************************************************************)
 (* Tools for printing of Cases                                              *)
 
 let encode_inductive r =
   let indsp = global_inductive r in
-  let constr_lengths = mis_constr_nargs indsp in
+  let constr_lengths = constructors_nrealargs indsp in
   (indsp,constr_lengths)
 
 (* Parameterization of the translation from constr to ast      *)
@@ -40,9 +53,9 @@ let encode_inductive r =
 (* Tables for Cases printing under a "if" form, a "let" form,  *)
 
 let has_two_constructors lc =
-  Array.length lc = 2 (* & lc.(0) = 0 & lc.(1) = 0 *)
+  Int.equal (Array.length lc) 2 (* & lc.(0) = 0 & lc.(1) = 0 *)
 
-let isomorphic_to_tuple lc = (Array.length lc = 1)
+let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1
 
 let encode_bool r =
   let (x,lc) = encode_inductive r in
@@ -67,12 +80,10 @@ module PrintingInductiveMake =
   end) ->
   struct
     type t = inductive
+    let compare = ind_ord
     let encode = Test.encode
-    let subst subst (kn, ints as obj) =
-      let kn' = subst_ind subst kn in
-	if kn' == kn then obj else
-	  kn', ints
-    let printer ind = pr_global_env Idset.empty (IndRef ind)
+    let subst subst obj = subst_ind subst obj
+    let printer ind = pr_global_env Id.Set.empty (IndRef ind)
     let key = ["Printing";Test.field]
     let title = Test.title
     let member_message x = Test.member_message (printer x)
@@ -83,7 +94,7 @@ module PrintingCasesIf =
   PrintingInductiveMake (struct
     let encode = encode_bool
     let field = "If"
-    let title = "Types leading to pretty-printing of Cases using a `if' form: "
+    let title = "Types leading to pretty-printing of Cases using a `if' form:"
     let member_message s b =
       str "Cases on elements of " ++ s ++
       str
@@ -144,6 +155,17 @@ let _ = declare_bool_option
 	    optread  = reverse_matching;
 	    optwrite = (:=) reverse_matching_value }
 
+let print_primproj_params_value = ref true
+let print_primproj_params () = !print_primproj_params_value
+
+let _ = declare_bool_option
+	  { optsync  = true;
+            optdepr  = false;
+	    optname  = "printing of primitive projection parameters";
+	    optkey   = ["Printing";"Primitive";"Projection";"Parameters"];
+	    optread  = print_primproj_params;
+	    optwrite = (:=) print_primproj_params_value }
+
 (* Auxiliary function for MutCase printing *)
 (* [computable] tries to tell if the predicate typing the result is inferable*)
 
@@ -153,19 +175,19 @@ let computable p k =
        works for normal eta-expanded term. For non eta-expanded or
        non-normal terms, it may affirm the pred is synthetisable
        because of an undetected ultimate dependent variable in the second
-       clause, or else, it may affirms the pred non synthetisable
+       clause, or else, it may affirm the pred non synthetisable
        because of a non normal term in the fourth clause.
        A solution could be to store, in the MutCase, the eta-expanded
        normal form of pred to decide if it depends on its variables
 
-       Lorsque le prédicat est dépendant de manière certaine, on
-       ne déclare pas le prédicat synthétisable (même si la
-       variable dépendante ne l'est pas effectivement) parce que
-       sinon on perd la réciprocité de la synthèse (qui, lui,
-       engendrera un prédicat non dépendant) *)
+       Lorsque le prédicat est dépendant de manière certaine, on
+       ne déclare pas le prédicat synthétisable (même si la
+       variable dépendante ne l'est pas effectivement) parce que
+       sinon on perd la réciprocité de la synthèse (qui, lui,
+       engendrera un prédicat non dépendant) *)
 
   let sign,ccl = decompose_lam_assum p in
-  (rel_context_length sign = k+1)
+  Int.equal (rel_context_length sign) (k + 1)
   &&
   noccur_between 1 (k+1) ccl
 
@@ -173,11 +195,11 @@ let lookup_name_as_displayed env t s =
   let rec lookup avoid n c = match kind_of_term c with
     | Prod (name,_,c') ->
 	(match compute_displayed_name_in RenamingForGoal avoid name c' with
-           | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c'
+           | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c'
 	   | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c'))
     | LetIn (name,_,_,c') ->
 	(match compute_displayed_name_in RenamingForGoal avoid name c' with
-           | (Name id,avoid') -> if id=s then Some n else lookup avoid' (n+1) c'
+           | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c'
 	   | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c'))
     | Cast (c,_,_) -> lookup avoid n c
     | _ -> None
@@ -189,9 +211,9 @@ let lookup_index_as_renamed env t n =
 	  (match compute_displayed_name_in RenamingForGoal [] name c' with
                (Name _,_) -> lookup n (d+1) c'
              | (Anonymous,_) ->
-		 if n=0 then
+		 if Int.equal n 0 then
 		   Some (d-1)
-		 else if n=1 then
+		 else if Int.equal n 1 then
 		   Some d
 		 else
 		   lookup (n-1) (d+1) c')
@@ -199,55 +221,63 @@ let lookup_index_as_renamed env t n =
 	  (match compute_displayed_name_in RenamingForGoal [] name c' with
              | (Name _,_) -> lookup n (d+1) c'
              | (Anonymous,_) ->
-		 if n=0 then
+		 if Int.equal n 0 then
 		   Some (d-1)
-		 else if n=1 then
+		 else if Int.equal n 1 then
 		   Some d
 		 else
 		   lookup (n-1) (d+1) c'
 	  )
     | Cast (c,_,_) -> lookup n d c
-    | _ -> if n=0 then Some (d-1) else None
+    | _ -> if Int.equal n 0 then Some (d-1) else None
   in lookup n 1 t
 
 (**********************************************************************)
 (* Fragile algorithm to reverse pattern-matching compilation          *)
 
-let update_name na ((_,e),c) =
+let update_name na ((_,(e,_)),c) =
   match na with
-  | Name _ when force_wildcard () & noccurn (list_index na e) c ->
+  | Name _ when force_wildcard () && noccurn (List.index Name.equal na e) c ->
       Anonymous
   | _ ->
       na
 
-let rec decomp_branch n nal b (avoid,env as e) c =
-  let flag = if b then RenamingForGoal else RenamingForCasesPattern in
-  if n=0 then (List.rev nal,(e,c))
-  else
-    let na,c,f =
-      match kind_of_term (strip_outer_cast c) with
-	| Lambda (na,_,c) -> na,c,compute_displayed_let_name_in
-	| LetIn (na,_,_,c) -> na,c,compute_displayed_name_in
-	| _ ->
-	    Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])),
-	    compute_displayed_name_in in
+let rec decomp_branch tags nal b (avoid,env as e) c =
+  let flag = if b then RenamingForGoal else RenamingForCasesPattern (fst env,c) in
+  match tags with
+  | [] -> (List.rev nal,(e,c))
+  | b::tags ->
+      let na,c,f,body,t =
+        match kind_of_term (strip_outer_cast c), b with
+	| Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t
+	| LetIn (na,b,t,c),true ->
+            na,c,compute_displayed_name_in,Some b,Some t
+	| _, false ->
+	  Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])),
+	    compute_displayed_name_in,None,None
+	| _, true ->
+	  Anonymous,lift 1 c,compute_displayed_name_in,None,None
+    in
     let na',avoid' = f flag avoid na c in
-    decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c
+    decomp_branch tags (na'::nal) b
+      (avoid', add_name_opt na' body t env) c
 
 let rec build_tree na isgoal e ci cl =
   let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in
-  let cnl = ci.ci_cstr_ndecls in
+  let cnl = ci.ci_pp_info.cstr_tags in
+  let cna = ci.ci_cstr_nargs in
   List.flatten
-    (list_tabulate (fun i -> contract_branch isgoal e (cnl.(i),mkpat i,cl.(i)))
-       (Array.length cl))
+    (List.init (Array.length cl)
+      (fun i -> contract_branch isgoal e (cnl.(i),cna.(i),mkpat i,cl.(i))))
 
 and align_tree nal isgoal (e,c as rhs) = match nal with
   | [] -> [[],rhs]
   | na::nal ->
     match kind_of_term c with
-    | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e))
-	& (* don't contract if p dependent *)
-	computable p (ci.ci_pp_info.ind_nargs) ->
+    | Case (ci,p,c,cl) when
+        eq_constr c (mkRel (List.index Name.equal na (fst (snd e))))
+	&& (* don't contract if p dependent *)
+	computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) ->
 	let clauses = build_tree na isgoal e ci cl in
 	List.flatten
           (List.map (fun (pat,rhs) ->
@@ -259,8 +289,8 @@ and align_tree nal isgoal (e,c as rhs) = match nal with
 	let mat = align_tree nal isgoal rhs in
 	List.map (fun (hd,rest) -> pat::hd,rest) mat
 
-and contract_branch isgoal e (cn,mkpat,b) =
-  let nal,rhs = decomp_branch cn [] isgoal e b in
+and contract_branch isgoal e (cdn,can,mkpat,b) =
+  let nal,rhs = decomp_branch cdn [] isgoal e b in
   let mat = align_tree nal isgoal rhs in
   List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat
 
@@ -268,48 +298,53 @@ and contract_branch isgoal e (cn,mkpat,b) =
 (* Transform internal representation of pattern-matching into list of *)
 (* clauses                                                            *)
 
-let is_nondep_branch c n =
+let is_nondep_branch c l =
   try
-    let sign,ccl = decompose_lam_n_assum n c in
+    (* FIXME: do better using tags from l *)
+    let sign,ccl = decompose_lam_n_assum (List.length l) c in
     noccur_between 1 (rel_context_length sign) ccl
   with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *)
     false
 
-let extract_nondep_branches test c b n =
-  let rec strip n r = if n=0 then r else
-    match r with
-      | GLambda (_,_,_,_,t) -> strip (n-1) t
-      | GLetIn (_,_,_,t) -> strip (n-1) t
-      | _ -> assert false in
-  if test c n then Some (strip n b) else None
-
-let it_destRLambda_or_LetIn_names n c =
-  let rec aux n nal c =
-    if n=0 then (List.rev nal,c) else match c with
-      | GLambda (_,na,_,_,c) -> aux (n-1) (na::nal) c
-      | GLetIn (_,na,_,c) -> aux (n-1) (na::nal) c
-      | _ ->
+let extract_nondep_branches test c b l =
+  let rec strip l r =
+    match r,l with
+      | r, [] -> r
+      | GLambda (_,_,_,_,t), false::l -> strip l t
+      | GLetIn (_,_,_,t), true::l -> strip l t
+      (* FIXME: do we need adjustment? *)
+      | _,_ -> assert false in
+  if test c l then Some (strip l b) else None
+
+let it_destRLambda_or_LetIn_names l c =
+  let rec aux l nal c =
+    match c, l with
+      | _, [] -> (List.rev nal,c)
+      | GLambda (_,na,_,_,c), false::l -> aux l (na::nal) c
+      | GLetIn (_,na,_,c), true::l -> aux l (na::nal) c
+      | _, true::l -> (* let-expansion *) aux l (Anonymous :: nal) c
+      | _, false::l ->
           (* eta-expansion *)
-	  let rec next l =
-	    let x = next_ident_away (id_of_string "x") l in
+	  let next l =
+	    let x = next_ident_away default_dependent_ident l in
 	    (* Not efficient but unusual and no function to get free glob_vars *)
 (* 	    if occur_glob_constr x c then next (x::l) else x in *)
 	    x
 	  in
 	  let x = next (free_glob_vars c) in
 	  let a = GVar (dl,x) in
-	  aux (n-1) (Name x :: nal)
+	  aux l (Name x :: nal)
             (match c with
               | GApp (loc,p,l) -> GApp (loc,p,l@[a])
               | _ -> (GApp (dl,c,[a])))
-  in aux n [] c
+  in aux l [] c
 
 let detype_case computable detype detype_eqns testdep avoid data p c bl =
-  let (indsp,st,nparams,consnargsl,k) = data in
+  let (indsp,st,constagsl,k) = data in
   let synth_type = synthetize_type () in
   let tomatch = detype c in
   let alias, aliastyp, pred=
-    if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0
+    if (not !Flags.raw_print) && synth_type && computable && not (Int.equal (Array.length bl) 0)
     then
       Anonymous, None, None
     else
@@ -321,8 +356,8 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
               | GLambda (_,x,_,t,c) -> x, c
 	      | _ -> Anonymous, typ in
 	    let aliastyp =
-	      if List.for_all ((=) Anonymous) nl then None
-	      else Some (dl,indsp,nparams,nl) in
+	      if List.for_all (Name.equal Anonymous) nl then None
+	      else Some (dl,indsp,nl) in
             n, aliastyp, Some typ
   in
   let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
@@ -330,7 +365,7 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
     try
       if !Flags.raw_print then
         RegularStyle
-      else if st = LetPatternStyle then
+      else if st == LetPatternStyle then
 	st
       else if PrintingLet.active indsp then
 	LetStyle
@@ -340,117 +375,194 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl =
 	st
     with Not_found -> st
   in
-  match tag with
-  | LetStyle when aliastyp = None ->
+  match tag, aliastyp with
+  | LetStyle, None ->
       let bl' = Array.map detype bl in
-      let (nal,d) = it_destRLambda_or_LetIn_names consnargsl.(0) bl'.(0) in
+      let (nal,d) = it_destRLambda_or_LetIn_names constagsl.(0) bl'.(0) in
       GLetTuple (dl,nal,(alias,pred),tomatch,d)
-  | IfStyle when aliastyp = None ->
+  | IfStyle, None ->
       let bl' = Array.map detype bl in
       let nondepbrs =
-	array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
-      if array_for_all ((<>) None) nondepbrs then
+	Array.map3 (extract_nondep_branches testdep) bl bl' constagsl in
+      if Array.for_all ((!=) None) nondepbrs then
 	GIf (dl,tomatch,(alias,pred),
              Option.get nondepbrs.(0),Option.get nondepbrs.(1))
       else
-	let eqnl = detype_eqns constructs consnargsl bl in
+	let eqnl = detype_eqns constructs constagsl bl in
 	GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
   | _ ->
-      let eqnl = detype_eqns constructs consnargsl bl in
+      let eqnl = detype_eqns constructs constagsl bl in
       GCases (dl,tag,pred,[tomatch,(alias,aliastyp)],eqnl)
 
-let detype_sort = function
-  | Prop c -> GProp c
-  | Type u -> GType (Some u)
+let detype_sort sigma = function
+  | Prop Null -> GProp
+  | Prop Pos -> GSet
+  | Type u ->
+    GType
+      (if !print_universes
+       then [Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)]
+       else [])
 
 type binder_kind = BProd | BLambda | BLetIn
 
 (**********************************************************************)
 (* Main detyping function                                             *)
 
-let detype_anonymous = ref (fun loc n -> anomaly "detype: index to an anonymous variable")
+let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable"))
 let set_detype_anonymous f = detype_anonymous := f
 
-let rec detype (isgoal:bool) avoid env t =
+let detype_level sigma l =
+  GType (Some (Pp.string_of_ppcmds (Evd.pr_evd_level sigma l)))
+
+let detype_instance sigma l = 
+  if Univ.Instance.is_empty l then None
+  else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l)))
+
+let rec detype flags avoid env sigma t =
   match kind_of_term (collapse_appl t) with
     | Rel n ->
-      (try match lookup_name_of_rel n env with
+      (try match lookup_name_of_rel n (fst env) with
 	 | Name id   -> GVar (dl, id)
 	 | Anonymous -> !detype_anonymous dl n
        with Not_found ->
 	 let s = "_UNBOUND_REL_"^(string_of_int n)
-	 in GVar (dl, id_of_string s))
+	 in GVar (dl, Id.of_string s))
     | Meta n ->
 	(* Meta in constr are not user-parsable and are mapped to Evar *)
-	GEvar (dl, n, None)
+        (* using numbers to be unparsable *)
+	GEvar (dl, Id.of_string ("M" ^ string_of_int n), [])
     | Var id ->
-	(try
-	  let _ = Global.lookup_named id in GRef (dl, VarRef id)
-	 with e when Errors.noncritical e ->
-	  GVar (dl, id))
-    | Sort s -> GSort (dl,detype_sort s)
+	(try let _ = Global.lookup_named id in GRef (dl, VarRef id, None)
+	 with Not_found -> GVar (dl, id))
+    | Sort s -> GSort (dl,detype_sort sigma s)
     | Cast (c1,REVERTcast,c2) when not !Flags.raw_print ->
-        detype isgoal avoid env c1
+        detype flags avoid env sigma c1
     | Cast (c1,k,c2) ->
-	GCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2))
-    | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c
-    | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c
-    | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c
+        let d1 = detype flags avoid env sigma c1 in
+	let d2 = detype flags avoid env sigma c2 in
+    let cast = match k with
+    | VMcast -> CastVM d2
+    | NATIVEcast -> CastNative d2
+    | _ -> CastConv d2
+    in
+	GCast(dl,d1,cast)
+    | Prod (na,ty,c) -> detype_binder flags BProd avoid env sigma na None ty c
+    | Lambda (na,ty,c) -> detype_binder flags BLambda avoid env sigma na None ty c
+    | LetIn (na,b,ty,c) -> detype_binder flags BLetIn avoid env sigma na (Some b) ty c
     | App (f,args) ->
-	GApp (dl,detype isgoal avoid env f,
-              array_map_to_list (detype isgoal avoid env) args)
-    | Const sp -> GRef (dl, ConstRef sp)
-    | Evar (ev,cl) ->
-        GEvar (dl, ev,
-               Some (List.map (detype isgoal avoid env) (Array.to_list cl)))
-    | Ind ind_sp ->
-	GRef (dl, IndRef ind_sp)
-    | Construct cstr_sp ->
-	GRef (dl, ConstructRef cstr_sp)
+      let mkapp f' args' = 
+ 	match f' with
+ 	| GApp (dl',f',args'') -> 
+ 	  GApp (dl,f',args''@args')
+ 	| _ -> GApp (dl,f',args')
+      in
+	mkapp (detype flags avoid env sigma f)
+	  (Array.map_to_list (detype flags avoid env sigma) args)
+    | Const (sp,u) -> GRef (dl, ConstRef sp, detype_instance sigma u)
+    | Proj (p,c) ->
+      let noparams () = 
+	let pb = Environ.lookup_projection p (snd env) in
+	let pars = pb.Declarations.proj_npars in
+	let hole = GHole(Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in
+	let args = List.make pars hole in
+ 	  GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), 
+		(args @ [detype flags avoid env sigma c]))
+      in
+      if fst flags || !Flags.in_debugger || !Flags.in_toplevel then
+	try noparams ()
+	with _ ->
+	    (* lax mode, used by debug printers only *) 
+	  GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), 
+		[detype flags avoid env sigma c])
+      else 
+	if Projection.unfolded p then
+	  (** Print the compatibility match version *)
+	  let c' = 
+	    try 
+	      let pb = Environ.lookup_projection p (snd env) in
+	      let body = pb.Declarations.proj_body in
+	      let ty = Retyping.get_type_of (snd env) sigma c in
+	      let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in
+	      let body' = strip_lam_assum body in
+	      let body' = subst_instance_constr u body' in
+		substl (c :: List.rev args) body'
+	    with Retyping.RetypeError _ | Not_found -> 
+	      anomaly (str"Cannot detype an unfolded primitive projection.")
+	  in detype flags avoid env sigma c'
+	else
+	  if print_primproj_params () then
+	    try
+	      let c = Retyping.expand_projection (snd env) sigma p c [] in
+		detype flags avoid env sigma c
+	    with Retyping.RetypeError _ -> noparams ()
+	  else noparams ()
+
+    | Evar (evk,cl) ->
+        let bound_to_itself id c =
+	  try let n = List.index Name.equal (Name id) (fst env) in 
+	      isRelN n c 
+	  with Not_found -> isVarId id c in
+      let id,l =
+        try
+          let id = Evd.evar_ident evk sigma in
+          let l = Evd.evar_instance_array bound_to_itself (Evd.find sigma evk) cl in
+          let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> (Id.Set.union fvs (collect_vars c), Int.Set.union rels (free_rels c))) (Id.Set.empty,Int.Set.empty) l in
+          let l = Evd.evar_instance_array (fun id c -> not !print_evar_arguments && (bound_to_itself id c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in
+          id,l
+        with Not_found ->
+          Id.of_string ("X" ^ string_of_int (Evar.repr evk)), 
+          (Array.map_to_list (fun c -> (Id.of_string "A",c)) cl)
+      in
+        GEvar (dl,id,
+               List.map (on_snd (detype flags avoid env sigma)) l)
+    | Ind (ind_sp,u) ->
+	GRef (dl, IndRef ind_sp, detype_instance sigma u)
+    | Construct (cstr_sp,u) ->
+	GRef (dl, ConstructRef cstr_sp, detype_instance sigma u)
     | Case (ci,p,c,bl) ->
-	let comp = computable p (ci.ci_pp_info.ind_nargs) in
-	detype_case comp (detype isgoal avoid env)
-	  (detype_eqns isgoal avoid env ci comp)
+	let comp = computable p (List.length (ci.ci_pp_info.ind_tags)) in
+	detype_case comp (detype flags avoid env sigma)
+	  (detype_eqns flags avoid env sigma ci comp)
 	  is_nondep_branch avoid
-	  (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar,
-	   ci.ci_cstr_ndecls,ci.ci_pp_info.ind_nargs)
+	  (ci.ci_ind,ci.ci_pp_info.style,
+	   ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags)
 	  (Some p) c bl
-    | Fix (nvn,recdef) -> detype_fix isgoal avoid env nvn recdef
-    | CoFix (n,recdef) -> detype_cofix isgoal avoid env n recdef
+    | Fix (nvn,recdef) -> detype_fix flags avoid env sigma nvn recdef
+    | CoFix (n,recdef) -> detype_cofix flags avoid env sigma n recdef
 
-and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) =
+and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) =
   let def_avoid, def_env, lfi =
-    Array.fold_left
-      (fun (avoid, env, l) na ->
+    Array.fold_left2
+      (fun (avoid, env, l) na ty ->
 	 let id = next_name_away na avoid in
-	 (id::avoid, add_name (Name id) env, id::l))
-      (avoid, env, []) names in
+	 (id::avoid, add_name (Name id) None ty env, id::l))
+      (avoid, env, []) names tys in
   let n = Array.length tys in
-  let v = array_map3
-    (fun c t i -> share_names isgoal (i+1) [] def_avoid def_env c (lift n t))
+  let v = Array.map3
+    (fun c t i -> share_names flags (i+1) [] def_avoid def_env sigma c (lift n t))
     bodies tys vn in
   GRec(dl,GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
 
-and detype_cofix isgoal avoid env n (names,tys,bodies) =
+and detype_cofix flags avoid env sigma n (names,tys,bodies) =
   let def_avoid, def_env, lfi =
-    Array.fold_left
-      (fun (avoid, env, l) na ->
+    Array.fold_left2
+      (fun (avoid, env, l) na ty ->
 	 let id = next_name_away na avoid in
-	 (id::avoid, add_name (Name id) env, id::l))
-      (avoid, env, []) names in
+	 (id::avoid, add_name (Name id) None ty env, id::l))
+      (avoid, env, []) names tys in
   let ntys = Array.length tys in
-  let v = array_map2
-    (fun c t -> share_names isgoal 0 [] def_avoid def_env c (lift ntys t))
+  let v = Array.map2
+    (fun c t -> share_names flags 0 [] def_avoid def_env sigma c (lift ntys t))
     bodies tys in
   GRec(dl,GCoFix n,Array.of_list (List.rev lfi),
        Array.map (fun (bl,_,_) -> bl) v,
        Array.map (fun (_,_,ty) -> ty) v,
        Array.map (fun (_,bd,_) -> bd) v)
 
-and share_names isgoal n l avoid env c t =
+and share_names flags n l avoid env sigma c t =
   match kind_of_term c, kind_of_term t with
     (* factorize even when not necessary to have better presentation *)
     | Lambda (na,t,c), Prod (na',t',c') ->
@@ -458,93 +570,98 @@ and share_names isgoal n l avoid env c t =
             Name _, _ -> na
           | _, Name _ -> na'
           | _ -> na in
-        let t = detype isgoal avoid env t in
+        let t' = detype flags avoid env sigma t in
 	let id = next_name_away na avoid in
-        let avoid = id::avoid and env = add_name (Name id) env in
-        share_names isgoal (n-1) ((Name id,Explicit,None,t)::l) avoid env c c'
+        let avoid = id::avoid and env = add_name (Name id) None t env in
+        share_names flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c'
     (* May occur for fix built interactively *)
     | LetIn (na,b,t',c), _ when n > 0 ->
-        let t' = detype isgoal avoid env t' in
-        let b = detype isgoal avoid env b in
+        let t'' = detype flags avoid env sigma t' in
+        let b' = detype flags avoid env sigma b in
 	let id = next_name_away na avoid in
-        let avoid = id::avoid and env = add_name (Name id) env in
-        share_names isgoal n ((Name id,Explicit,Some b,t')::l) avoid env c (lift 1 t)
+        let avoid = id::avoid and env = add_name (Name id) (Some b) t' env in
+        share_names flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t)
     (* Only if built with the f/n notation or w/o let-expansion in types *)
     | _, LetIn (_,b,_,t) when n > 0 ->
-	share_names isgoal n l avoid env c (subst1 b t)
+	share_names flags n l avoid env sigma c (subst1 b t)
     (* If it is an open proof: we cheat and eta-expand *)
     | _, Prod (na',t',c') when n > 0 ->
-        let t' = detype isgoal avoid env t' in
+        let t'' = detype flags avoid env sigma t' in
 	let id = next_name_away na' avoid in
-        let avoid = id::avoid and env = add_name (Name id) env in
+        let avoid = id::avoid and env = add_name (Name id) None t' env in
         let appc = mkApp (lift 1 c,[|mkRel 1|]) in
-        share_names isgoal (n-1) ((Name id,Explicit,None,t')::l) avoid env appc c'
+        share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c'
     (* If built with the f/n notation: we renounce to share names *)
     | _ ->
-        if n>0 then msg_warn "Detyping.detype: cannot factorize fix enough";
-        let c = detype isgoal avoid env c in
-        let t = detype isgoal avoid env t in
+        if n>0 then msg_warning (strbrk "Detyping.detype: cannot factorize fix enough");
+        let c = detype flags avoid env sigma c in
+        let t = detype flags avoid env sigma t in
         (List.rev l,c,t)
 
-and detype_eqns isgoal avoid env ci computable constructs consnargsl bl =
+and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl =
   try
-    if !Flags.raw_print or not (reverse_matching ()) then raise Exit;
-    let mat = build_tree Anonymous isgoal (avoid,env) ci bl in
-    List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c))
+    if !Flags.raw_print || not (reverse_matching ()) then raise Exit;
+    let mat = build_tree Anonymous (snd flags) (avoid,env) ci bl in
+    List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c))
       mat
   with e when Errors.noncritical e ->
     Array.to_list
-      (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl)
+      (Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl)
 
-and detype_eqn isgoal avoid env constr construct_nargs branch =
-  let make_pat x avoid env b ids =
-    if force_wildcard () & noccurn 1 b then
-      PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids
+and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch =
+  let make_pat x avoid env b body ty ids =
+    if force_wildcard () && noccurn 1 b then
+      PatVar (dl,Anonymous),avoid,(add_name Anonymous body ty env),ids
     else
-      let id = next_name_away_in_cases_pattern x avoid in
-      PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids
+      let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in
+      let na,avoid' = compute_displayed_name_in flag avoid x b in
+      PatVar (dl,na),avoid',(add_name na body ty env),add_vname ids na
   in
-  let rec buildrec ids patlist avoid env n b =
-    if n=0 then
-      (dl, ids,
-       [PatCstr(dl, constr, List.rev patlist,Anonymous)],
-       detype isgoal avoid env b)
-    else
-      match kind_of_term b with
-	| Lambda (x,_,b) ->
-	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
-            buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
-
-	| LetIn (x,_,_,b) ->
-	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
-            buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
-
-	| Cast (c,_,_) ->    (* Oui, il y a parfois des cast *)
-	    buildrec ids patlist avoid env n c
-
-	| _ -> (* eta-expansion : n'arrivera plus lorsque tous les
-                  termes seront construits à partir de la syntaxe Cases *)
+  let rec buildrec ids patlist avoid env l b =
+    match kind_of_term b, l with
+      | _, [] ->
+        (dl, Id.Set.elements ids,
+         [PatCstr(dl, constr, List.rev patlist,Anonymous)],
+         detype flags avoid env sigma b)
+      | Lambda (x,t,b), false::l ->
+	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in
+            buildrec new_ids (pat::patlist) new_avoid new_env l b
+
+      | LetIn (x,b,t,b'), true::l ->
+	    let pat,new_avoid,new_env,new_ids = make_pat x avoid env b' (Some b) t ids in
+            buildrec new_ids (pat::patlist) new_avoid new_env l b'
+
+      | Cast (c,_,_), l ->    (* Oui, il y a parfois des cast *)
+	    buildrec ids patlist avoid env l c
+
+      | _, true::l ->
+	    let pat = PatVar (dl,Anonymous) in
+            buildrec ids (pat::patlist) avoid env l b
+
+      | _, false::l ->
+            (* eta-expansion : n'arrivera plus lorsque tous les
+               termes seront construits à partir de la syntaxe Cases *)
             (* nommage de la nouvelle variable *)
 	    let new_b = applist (lift 1 b, [mkRel 1]) in
             let pat,new_avoid,new_env,new_ids =
-	      make_pat Anonymous avoid env new_b ids in
-	    buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b
+	      make_pat Anonymous avoid env new_b None mkProp ids in
+	    buildrec new_ids (pat::patlist) new_avoid new_env l new_b
 
   in
-  buildrec [] [] avoid env construct_nargs branch
-
-and detype_binder isgoal bk avoid env na ty c =
-  let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (env,c) in
-  let na',avoid' =
-    if bk = BLetIn then compute_displayed_let_name_in flag avoid na c
-    else compute_displayed_name_in flag avoid na c in
-  let r =  detype isgoal avoid' (add_name na' env) c in
+  buildrec Id.Set.empty [] avoid env construct_nargs branch
+
+and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c =
+  let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in
+  let na',avoid' = match bk with
+  | BLetIn -> compute_displayed_let_name_in flag avoid na c
+  | _ -> compute_displayed_name_in flag avoid na c in
+  let r =  detype flags avoid' (add_name na' body ty env) sigma c in
   match bk with
-  | BProd -> GProd (dl, na',Explicit,detype false avoid env ty, r)
-  | BLambda -> GLambda (dl, na',Explicit,detype false avoid env ty, r)
-  | BLetIn -> GLetIn (dl, na',detype false avoid env ty, r)
+  | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
+  | BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r)
+  | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r)
 
-let rec detype_rel_context where avoid env sign =
+let detype_rel_context ?(lax=false) where avoid env sigma sign =
   let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in
   let rec aux avoid env = function
   | [] -> []
@@ -553,17 +670,80 @@ let rec detype_rel_context where avoid env sign =
 	match where with
 	| None -> na,avoid
 	| Some c ->
-	    if b<>None then
+	    if b != None then
 	      compute_displayed_let_name_in
-                (RenamingElsewhereFor (env,c)) avoid na c
+                (RenamingElsewhereFor (fst env,c)) avoid na c
 	    else
 	      compute_displayed_name_in
-                (RenamingElsewhereFor (env,c)) avoid na c in
-      let b = Option.map (detype false avoid env) b in
-      let t = detype false avoid env t in
-      (na',Explicit,b,t) :: aux avoid' (add_name na' env) rest
+                (RenamingElsewhereFor (fst env,c)) avoid na c in
+      let b' = Option.map (detype (lax,false) avoid env sigma) b in
+      let t' = detype (lax,false) avoid env sigma t in
+      (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest
   in aux avoid env (List.rev sign)
 
+let detype_names isgoal avoid nenv env sigma t = 
+  detype (false,isgoal) avoid (nenv,env) sigma t
+let detype ?(lax=false) isgoal avoid env sigma t =
+  detype (lax,isgoal) avoid (names_of_rel_context env, env) sigma t
+
+let detype_closed_glob ?lax isgoal avoid env sigma t =
+  let convert_id cl id =
+    try Id.Map.find id cl.idents
+    with Not_found -> id
+  in
+  let convert_name cl = function
+    | Name id -> Name (convert_id cl id)
+    | Anonymous -> Anonymous
+  in
+  let rec detype_closed_glob cl = function
+    | GVar (loc,id) ->
+        (* if [id] is bound to a name. *)
+        begin try
+          GVar(loc,Id.Map.find id cl.idents)
+        (* if [id] is bound to a typed term *)
+        with Not_found -> try
+          (* assumes [detype] does not raise [Not_found] exceptions *)
+          let (b,c) = Id.Map.find id cl.typed in
+          (* spiwack: I'm not sure it is the right thing to do,
+             but I'm computing the detyping environment like
+             [Printer.pr_constr_under_binders_env] does. *)
+          let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) b in
+          let env = Termops.push_rels_assum assums env in
+          detype ?lax isgoal avoid env sigma c
+        (* if [id] is bound to a [closed_glob_constr]. *)
+        with Not_found -> try
+          let {closure;term} = Id.Map.find id cl.untyped in
+          detype_closed_glob closure term
+        (* Otherwise [id] stands for itself *)
+        with Not_found ->
+         GVar(loc,id)
+        end
+    | GLambda (loc,id,k,t,c) ->
+        let id = convert_name cl id in
+        GLambda(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c)
+    | GProd (loc,id,k,t,c) ->
+        let id = convert_name cl id in
+        GProd(loc,id,k,detype_closed_glob cl t, detype_closed_glob cl c)
+    | GLetIn (loc,id,b,e) ->
+        let id = convert_name cl id in
+        GLetIn(loc,id,detype_closed_glob cl b, detype_closed_glob cl e)
+    | GLetTuple (loc,ids,(n,r),b,e) ->
+        let ids = List.map (convert_name cl) ids in
+        let n = convert_name cl n in
+        GLetTuple (loc,ids,(n,r),detype_closed_glob cl b, detype_closed_glob cl e)
+    | GCases (loc,sty,po,tml,eqns) ->
+        let (tml,eqns) =
+          Glob_ops.map_pattern_binders (fun na -> convert_name cl na) tml eqns
+        in
+        let (tml,eqns) =
+          Glob_ops.map_pattern (fun c -> detype_closed_glob cl c) tml eqns
+        in
+        GCases(loc,sty,po,tml,eqns)
+    | c ->
+        Glob_ops.map_glob_constr (detype_closed_glob cl) c
+  in
+  detype_closed_glob t.closure t.term
+
 (**********************************************************************)
 (* Module substitution: relies on detyping                            *)
 
@@ -571,17 +751,19 @@ let rec subst_cases_pattern subst pat =
   match pat with
   | PatVar _ -> pat
   | PatCstr (loc,((kn,i),j),cpl,n) ->
-      let kn' = subst_ind subst kn
-      and cpl' = list_smartmap (subst_cases_pattern subst) cpl in
+      let kn' = subst_mind subst kn
+      and cpl' = List.smartmap (subst_cases_pattern subst) cpl in
 	if kn' == kn && cpl' == cpl then pat else
 	  PatCstr (loc,((kn',i),j),cpl',n)
 
+let (f_subst_genarg, subst_genarg_hook) = Hook.make ()
+
 let rec subst_glob_constr subst raw =
   match raw with
-  | GRef (loc,ref) ->
+  | GRef (loc,ref,u) ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then raw else
-         detype false [] [] t
+         detype false [] (Global.env()) Evd.empty t
 
   | GVar _ -> raw
   | GEvar _ -> raw
@@ -589,7 +771,7 @@ let rec subst_glob_constr subst raw =
 
   | GApp (loc,r,rl) ->
       let r' = subst_glob_constr subst r
-      and rl' = list_smartmap (subst_glob_constr subst) rl in
+      and rl' = List.smartmap (subst_glob_constr subst) rl in
 	if r' == r && rl' == rl then raw else
 	  GApp(loc,r',rl')
 
@@ -610,18 +792,18 @@ let rec subst_glob_constr subst raw =
 
   | GCases (loc,sty,rtno,rl,branches) ->
       let rtno' = Option.smartmap (subst_glob_constr subst) rtno
-      and rl' = list_smartmap (fun (a,x as y) ->
+      and rl' = List.smartmap (fun (a,x as y) ->
         let a' = subst_glob_constr subst a in
         let (n,topt) = x in
         let topt' = Option.smartmap
-          (fun (loc,(sp,i),x,y as t) ->
-            let sp' = subst_ind subst sp in
-            if sp == sp' then t else (loc,(sp',i),x,y)) topt in
+          (fun (loc,(sp,i),y as t) ->
+            let sp' = subst_mind subst sp in
+            if sp == sp' then t else (loc,(sp',i),y)) topt in
         if a == a' && topt == topt' then y else (a',(n,topt'))) rl
-      and branches' = list_smartmap
+      and branches' = List.smartmap
 			(fun (loc,idl,cpl,r as branch) ->
 			   let cpl' =
-			     list_smartmap (subst_cases_pattern subst) cpl
+			     List.smartmap (subst_cases_pattern subst) cpl
 			   and r' = subst_glob_constr subst r in
 			     if cpl' == cpl && r' == r then branch else
 			       (loc,idl,cpl',r'))
@@ -642,52 +824,51 @@ let rec subst_glob_constr subst raw =
       and b1' = subst_glob_constr subst b1
       and b2' = subst_glob_constr subst b2
       and c' = subst_glob_constr subst c in
-	if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
+	if c' == c && po' == po && b1' == b1 && b2' == b2 then raw else
           GIf (loc,c',(na,po'),b1',b2')
 
   | GRec (loc,fix,ida,bl,ra1,ra2) ->
-      let ra1' = array_smartmap (subst_glob_constr subst) ra1
-      and ra2' = array_smartmap (subst_glob_constr subst) ra2 in
-      let bl' = array_smartmap
-        (list_smartmap (fun (na,k,obd,ty as dcl) ->
+      let ra1' = Array.smartmap (subst_glob_constr subst) ra1
+      and ra2' = Array.smartmap (subst_glob_constr subst) ra2 in
+      let bl' = Array.smartmap
+        (List.smartmap (fun (na,k,obd,ty as dcl) ->
           let ty' = subst_glob_constr subst ty in
           let obd' = Option.smartmap (subst_glob_constr subst) obd in
-          if ty'==ty & obd'==obd then dcl else (na,k,obd',ty')))
+          if ty'==ty && obd'==obd then dcl else (na,k,obd',ty')))
         bl in
 	if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
 	  GRec (loc,fix,ida,bl',ra1',ra2')
 
   | GSort _ -> raw
 
-  | GHole (loc,ImplicitArg (ref,i,b)) ->
-      let ref',_ = subst_global subst ref in
-	if ref' == ref then raw else
-	  GHole (loc,InternalHole)
-  | GHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole |
-      TomatchTypeParameter _ | GoalEvar | ImpossibleCase | MatchingVar _)) ->
-      raw
+  | GHole (loc, knd, naming, solve) ->
+    let nknd = match knd with
+    | Evar_kinds.ImplicitArg (ref, i, b) ->
+      let nref, _ = subst_global subst ref in
+      if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b)
+    | _ -> knd
+    in
+    let nsolve = Option.smartmap (Hook.get f_subst_genarg subst) solve in
+    if nsolve == solve && nknd == knd then raw
+    else GHole (loc, nknd, naming, nsolve)
 
   | GCast (loc,r1,k) ->
-      (match k with
-	   CastConv (k,r2) ->
-	     let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in
-	       if r1' == r1 && r2' == r2 then raw else
-		 GCast (loc,r1', CastConv (k,r2'))
-	 | CastCoerce ->
-	     let r1' = subst_glob_constr subst r1 in
-	       if r1' == r1 then raw else GCast (loc,r1',k))
+      let r1' = subst_glob_constr subst r1 in
+      let k' = Miscops.smartmap_cast_type (subst_glob_constr subst) k in
+      if r1' == r1 && k' == k then raw else GCast (loc,r1',k')
 
 (* Utilities to transform kernel cases to simple pattern-matching problem *)
 
 let simple_cases_matrix_of_branches ind brs =
   List.map (fun (i,n,b) ->
       let nal,c = it_destRLambda_or_LetIn_names n b in
-      let mkPatVar na = PatVar (dummy_loc,na) in
-      let p = PatCstr (dummy_loc,(ind,i+1),List.map mkPatVar nal,Anonymous) in
-      let ids = map_succeed Nameops.out_name nal in
-      (dummy_loc,ids,[p],c))
+      let mkPatVar na = PatVar (Loc.ghost,na) in
+      let p = PatCstr (Loc.ghost,(ind,i+1),List.map mkPatVar nal,Anonymous) in
+      let map name = try Some (Nameops.out_name name) with Failure _ -> None in
+      let ids = List.map_filter map nal in
+      (Loc.ghost,ids,[p],c))
     brs
 
-let return_type_of_predicate ind nparams nrealargs_ctxt pred =
-  let nal,p = it_destRLambda_or_LetIn_names (nrealargs_ctxt+1) pred in
-  (List.hd nal, Some (dummy_loc, ind, nparams, List.tl nal)), Some p
+let return_type_of_predicate ind nrealargs_tags pred =
+  let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in
+  (List.hd nal, Some (Loc.ghost, ind, List.tl nal)), Some p
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index bbd94cfe..eb158686 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -1,19 +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 Util
 open Names
 open Term
-open Sign
+open Context
 open Environ
 open Glob_term
 open Termops
 open Mod_subst
+open Misctypes
+open Evd
+
+(** Should we keep details of universes during detyping ? *)
+val print_universes : bool ref
+
+(** If true, prints full local context of evars *)
+val print_evar_arguments : bool ref
 
 val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern
 
@@ -24,36 +31,43 @@ val subst_glob_constr : substitution -> glob_constr -> glob_constr
    [isgoal] tells if naming must avoid global-level synonyms as intro does 
    [ctx] gives the names of the free variables *)
 
-val detype : bool -> identifier list -> names_context -> constr -> glob_constr
+val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> constr -> glob_constr
+
+val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr
 
 val detype_case :
-  bool -> ('a -> glob_constr) ->
-  (constructor array -> int array -> 'a array ->
-    (loc * identifier list * cases_pattern list * glob_constr) list) ->
-  ('a -> int -> bool) ->
-  identifier list -> inductive * case_style * int * int array * int ->
-    'a option -> 'a -> 'a array -> glob_constr
+  bool -> (constr -> glob_constr) ->
+  (constructor array -> bool list array -> constr array ->
+    (Loc.t * Id.t list * cases_pattern list * glob_constr) list) ->
+  (constr -> bool list -> bool) ->
+  Id.t list -> inductive * case_style * bool list array * bool list ->
+    constr option -> constr -> constr array -> glob_constr
 
-val detype_sort : sorts -> glob_sort
+val detype_sort : evar_map -> sorts -> glob_sort
 
-val detype_rel_context : constr option -> identifier list -> names_context ->
-  rel_context -> glob_decl list
+val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> 
+  evar_map -> rel_context -> glob_decl list
+
+val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr
 
 (** look for the index of a named var or a nondep var as it is renamed *)
-val lookup_name_as_displayed  : env -> constr -> identifier -> int option
+val lookup_name_as_displayed  : env -> constr -> Id.t -> int option
 val lookup_index_as_renamed : env -> constr -> int -> int option
 
-val set_detype_anonymous : (loc -> int -> glob_constr) -> unit
+val set_detype_anonymous : (Loc.t -> int -> glob_constr) -> unit
 val force_wildcard : unit -> bool
 val synthetize_type : unit -> bool
 
 (** Utilities to transform kernel cases to simple pattern-matching problem *)
 
-val it_destRLambda_or_LetIn_names : int -> glob_constr -> name list * glob_constr
+val it_destRLambda_or_LetIn_names : bool list -> glob_constr -> Name.t list * glob_constr
 val simple_cases_matrix_of_branches :
-  inductive -> (int * int * glob_constr) list -> cases_clauses
+  inductive -> (int * bool list * glob_constr) list -> cases_clauses
 val return_type_of_predicate :
-  inductive -> int -> int -> glob_constr -> predicate_pattern * glob_constr option
+  inductive -> bool list -> glob_constr -> predicate_pattern * glob_constr option
+
+val subst_genarg_hook :
+  (substitution -> Genarg.glob_generic_argument -> Genarg.glob_generic_argument) Hook.t
 
 module PrintingInductiveMake :
   functor (Test : sig
@@ -64,6 +78,7 @@ module PrintingInductiveMake :
   end) ->
     sig
       type t = Names.inductive
+      val compare : t -> t -> int
       val encode : Libnames.reference -> Names.inductive
       val subst : substitution -> t -> t
       val printer : t -> Pp.std_ppcmds
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 8b421ea3..a95af253 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.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 Names
 open Term
+open Vars
 open Closure
 open Reduction
 open Reductionops
@@ -17,41 +18,40 @@ open Termops
 open Environ
 open Recordops
 open Evarutil
-open Libnames
+open Evarsolve
+open Globnames
 open Evd
+open Pretype_errors
+
+type unify_fun = transparent_state ->
+  env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
 
 let debug_unification = ref (false)
 let _ = Goptions.declare_bool_option {
   Goptions.optsync = true; Goptions.optdepr = false;
   Goptions.optname =
-    "Print states sended to Evarconv unification";
+    "Print states sent to Evarconv unification";
   Goptions.optkey = ["Debug";"Unification"];
   Goptions.optread = (fun () -> !debug_unification);
   Goptions.optwrite = (fun a -> debug_unification:=a);
 }
 
-
-type flex_kind_of_term =
-  | Rigid of constr
-  | PseudoRigid of constr (* approximated as rigid but not necessarily so *)
-  | MaybeFlexible of constr (* approx'ed as reducible but not necessarily so *)
-  | Flexible of existential
-
-let flex_kind_of_term c l =
+let unfold_projection env evd ts p c =
+  let cst = Projection.constant p in
+    if is_transparent_constant ts cst then
+      let c' = Some (mkProj (Projection.make cst true, c)) in
+	match ReductionBehaviour.get (Globnames.ConstRef cst) with
+	| None -> c'
+	| Some (recargs, nargs, flags) ->
+	  if (List.mem `ReductionNeverUnfold flags) then None
+	  else c'
+    else None
+      
+let eval_flexible_term ts env evd c =
   match kind_of_term c with
-    | Rel _ | Const _ | Var _ -> MaybeFlexible c
-    | Lambda _ when l<>[] -> MaybeFlexible c
-    | LetIn _  -> MaybeFlexible c
-    | Evar ev -> Flexible ev
-    | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid c
-    | Meta _ | Case _ | Fix _ -> PseudoRigid c
-    | Cast _ | App _ -> assert false
-
-let eval_flexible_term ts env c =
-  match kind_of_term c with
-  | Const c -> 
+  | Const (c,u as cu) ->
       if is_transparent_constant ts c
-      then constant_opt_value env c
+      then constant_opt_value_in env cu
       else None
   | Rel n ->
       (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v
@@ -59,81 +59,126 @@ let eval_flexible_term ts env c =
   | Var id ->
       (try
 	 if is_transparent_variable ts id then
-	   let (_,v,_) = lookup_named id env in v 
-	 else None 
+	   let (_,v,_) = lookup_named id env in v
+	 else None
        with Not_found -> None)
   | LetIn (_,b,_,c) -> Some (subst1 b c)
   | Lambda _ -> Some c
+  | Proj (p, c) -> 
+    if Projection.unfolded p then assert false
+    else unfold_projection env evd ts p c
   | _ -> assert false
 
-let evar_apprec ts env evd stack c =
-  let sigma =  evd in
-  let rec aux s =
-    let (t,stack) = whd_betaiota_deltazeta_for_iota_state ts env sigma s in
-    match kind_of_term t with
-      | Evar (evk,_ as ev) when Evd.is_defined sigma evk ->
-	  aux (Evd.existential_value sigma ev, stack)
-      | _ -> (t, list_of_stack stack)
-  in aux (c, append_stack_list stack empty_stack)
+type flex_kind_of_term =
+  | Rigid
+  | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *)
+  | Flexible of existential
+
+let flex_kind_of_term ts env evd c sk =
+  match kind_of_term c with
+    | LetIn _ | Rel _ | Const _ | Var _ | Proj _ ->
+      Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c)
+    | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c
+    | Evar ev -> Flexible ev
+    | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid
+    | Meta _ -> Rigid
+    | Fix _ -> Rigid (* happens when the fixpoint is partially applied *)
+    | Cast _ | App _ | Case _ -> assert false
 
 let apprec_nohdbeta ts env evd c =
-  match kind_of_term (fst (Reductionops.whd_stack evd c)) with
-    | (Case _ | Fix _) -> applist (evar_apprec ts env evd [] c)
-    | _ -> c
+  let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in
+  if Stack.not_purely_applicative sk
+  then Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state
+		   ts env evd Cst_stack.empty appr))
+  else c
 
 let position_problem l2r = function
   | CONV -> None
   | CUMUL -> Some l2r
 
-(* [check_conv_record (t1,l1) (t2,l2)] tries to decompose the problem
-   (t1 l1) = (t2 l2) into a problem
-
-     l1 = params1@c1::extra_args1
-     l2 = us2@extra_args2
-     (t1 params1 c1) = (proji params (c xs))
-     (t2 us2) = (cstr us)
+let occur_rigidly ev evd t = 
+  let (l, app) = decompose_app_vect t in 
+  let rec aux t = 
+    match kind_of_term (whd_evar evd t) with
+    | App (f, c) -> if aux f then Array.exists aux c else false
+    | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true
+    | Proj (p, c) -> not (aux c)
+    | Evar (ev',_) -> if Evar.equal ev ev' then raise Occur else false
+    | Cast (p, _, _) -> aux p
+    | Lambda _ | LetIn _ -> false
+    | Const _ -> false
+    | Prod (_, b, t) -> ignore(aux b || aux t); true
+    | Rel _ | Var _ -> false
+    | Case _ -> false
+  in Array.exists (fun t -> try ignore(aux t); false with Occur -> true) app
+
+(* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose 
+   the problem (t1 stack1) = (t2 stack2) into a problem
+
+     stack1 = params1@[c1]@extra_args1
+     stack2 = us2@extra_args2
+     t1 params1 c1 = proji params (c xs)
+     t2 us2 = head us
      extra_args1 = extra_args2
 
    by finding a record R and an object c := [xs:bs](Build_R params v1..vn)
-   with vi = (cstr us), for which we know that the i-th projection proji
+   with vi = (head us), for which we know that the i-th projection proji
    satisfies
 
-      (proji params (c xs)) = (cstr us)
+      proji params (c xs) = head us
 
    Rem: such objects, usable for conversion, are defined in the objdef
    table; practically, it amounts to "canonically" equip t2 into a
    object c in structure R (since, if c1 were not an evar, the
    projection would have been reduced) *)
 
-let check_conv_record (t1,l1) (t2,l2) =
-  try
-    let proji = global_of_constr t1 in
-    let canon_s,l2_effective =
-      try
-	match kind_of_term t2 with
-	    Prod (_,a,b) -> (* assert (l2=[]); *)
-      	      if dependent (mkRel 1) b then raise Not_found
-	      else lookup_canonical_conversion (proji, Prod_cs),[a;pop b]
-	  | Sort s ->
-	      lookup_canonical_conversion
-		(proji, Sort_cs (family_of_sort s)),[]
-	  | _ ->
-	      let c2 = global_of_constr t2 in
-		lookup_canonical_conversion (proji, Const_cs c2),l2
-      with Not_found ->
-	lookup_canonical_conversion (proji,Default_cs),[]
-    in
-    let { o_DEF = c; o_INJ=n; o_TABS = bs;
-          o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in
-    let params1, c1, extra_args1 =
-      match list_chop nparams l1 with
-	| params1, c1::extra_args1 -> params1, c1, extra_args1
-	| _ -> raise Not_found in
-    let us2,extra_args2 = list_chop (List.length us) l2_effective in
-    c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1,
-    (n,applist(t2,l2))
-  with Failure _ | Not_found ->
-    raise Not_found
+let check_conv_record env sigma (t1,sk1) (t2,sk2) =
+  let (proji, u), arg = Universes.global_app_of_constr t1 in
+  let canon_s,sk2_effective =
+    try
+      match kind_of_term t2 with
+	Prod (_,a,b) -> (* assert (l2=[]); *)
+      	  if dependent (mkRel 1) b then raise Not_found
+	  else lookup_canonical_conversion (proji, Prod_cs),
+	    (Stack.append_app [|a;pop b|] Stack.empty)
+      | Sort s ->
+	lookup_canonical_conversion
+	  (proji, Sort_cs (family_of_sort s)),[]
+      | _ ->
+	let c2 = global_of_constr t2 in
+	  lookup_canonical_conversion (proji, Const_cs c2),sk2
+    with Not_found ->
+      let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in 
+	(c,cs),[]
+  in
+  let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs;
+        o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in
+  let params1, c1, extra_args1 =
+    match arg with
+    | Some c -> (* A primitive projection applied to c *)
+      let ty = Retyping.get_type_of ~lax:true env sigma c in
+      let (i,u), ind_args = 
+	try Inductiveops.find_mrectype env sigma ty 
+	with _ -> raise Not_found
+      in Stack.append_app_list ind_args Stack.empty, c, sk1
+    | None ->
+      match Stack.strip_n_app nparams sk1 with
+      | Some (params1, c1, extra_args1) -> params1, c1, extra_args1
+      | _ -> raise Not_found in
+  let us2,extra_args2 =
+    let l_us = List.length us in
+      if Int.equal l_us 0 then Stack.empty,sk2_effective
+      else match (Stack.strip_n_app (l_us-1) sk2_effective) with
+      | None -> raise Not_found
+      | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in
+  let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in
+  let c' = subst_univs_level_constr subst c in
+  let t' = subst_univs_level_constr subst t' in
+  let bs' = List.map (subst_univs_level_constr subst) bs in
+  let h, _ = decompose_app_vect t' in
+    ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1),
+    (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1,
+    (n,Stack.zip(t2,sk2))
 
 (* Precondition: one of the terms of the pb is an uninstantiated evar,
  * possibly applied to arguments. *)
@@ -142,40 +187,135 @@ let rec ise_try evd = function
     [] -> assert false
   | [f] -> f evd
   | f1::l ->
-      let (evd',b) = f1 evd in
-      if b then (evd',b) else ise_try evd l
+      match f1 evd with
+      | Success _ as x -> x
+      | UnifFailure _ -> ise_try evd l
 
 let ise_and evd l =
   let rec ise_and i = function
       [] -> assert false
     | [f] -> f i
     | f1::l ->
-        let (i',b) = f1 i in
-        if b then  ise_and i' l else (evd,false) in
+        match f1 i with
+	| Success i' -> ise_and i' l
+	| UnifFailure _ as x -> x in
   ise_and evd l
 
-let ise_list2 evd f l1 l2 =
-  let rec ise_list2 i l1 l2 =
-    match l1,l2 with
-        [], [] -> (i, true)
-      | [x], [y] -> f i x y
-      | x::l1, y::l2 ->
-          let (i',b) = f i x y in
-          if b then ise_list2 i' l1 l2 else (evd,false)
-      | _ -> (evd, false) in
-  ise_list2 evd l1 l2
+(* This function requires to get the outermost arguments first.  It is
+   a fold_right for backward compatibility.
+
+   It tries to unify the suffix of 2 lists element by element and if
+   it reaches the end of a list, it returns the remaining elements in
+   the other list if there are some.
+*)
+let ise_exact ise x1 x2 =
+  match ise x1 x2 with
+  | None, out -> out
+  | _, (UnifFailure _ as out) -> out
+  | Some _, Success i -> UnifFailure (i,NotSameArgSize)
 
 let ise_array2 evd f v1 v2 =
   let rec allrec i = function
-    | -1 -> (i,true)
+    | -1 -> Success i
     | n ->
-        let (i',b) = f i v1.(n) v2.(n) in
-        if b then allrec i' (n-1) else (evd,false)
-  in
+        match f i v1.(n) v2.(n) with
+	| Success i' -> allrec i' (n-1)
+	| UnifFailure _ as x -> x in
   let lv1 = Array.length v1 in
-  if lv1 = Array.length v2 then allrec evd (pred lv1)
-  else (evd,false)
-
+  if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1)
+  else UnifFailure (evd,NotSameArgSize)
+
+(* Applicative node of stack are read from the outermost to the innermost
+   but are unified the other way. *)
+let rec ise_app_stack2 env f evd sk1 sk2 =
+  match sk1,sk2 with
+  | Stack.App node1 :: q1, Stack.App node2 :: q2 ->
+     let (t1,l1) = Stack.decomp_node_last node1 q1 in
+     let (t2,l2) = Stack.decomp_node_last node2 q2 in
+     begin match ise_app_stack2 env f evd l1 l2 with
+	   |(_,UnifFailure _) as x -> x
+	   |x,Success i' -> x,f env i' CONV t1 t2
+     end
+  | _, _ -> (sk1,sk2), Success evd
+
+(* This function tries to unify 2 stacks element by element. It works
+   from the end to the beginning. If it unifies a non empty suffix of
+   stacks but not the entire stacks, the first part of the answer is
+   Some(the remaining prefixes to tackle)) *)
+let ise_stack2 no_app env evd f sk1 sk2 =
+  let rec ise_stack2 deep i sk1 sk2 =
+    let fail x = if deep then Some (List.rev sk1, List.rev sk2), Success i
+      else None, x in
+    match sk1, sk2 with
+    | [], [] -> None, Success i
+    | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 ->
+      (match f env i CONV t1 t2 with
+      | Success i' ->
+	(match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with
+	| Success i'' -> ise_stack2 true i'' q1 q2
+        | UnifFailure _ as x -> fail x)
+      | UnifFailure _ as x -> fail x)
+    | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 ->
+       if eq_constant (Projection.constant p1) (Projection.constant p2)
+       then ise_stack2 true i q1 q2
+       else fail (UnifFailure (i, NotSameHead))
+    | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1,
+      Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 ->
+      if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then
+        match ise_and i [
+	  (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2);
+	  (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2);
+	  (fun i -> ise_exact (ise_stack2 false i) a1 a2)] with
+        | Success i' -> ise_stack2 true i' q1 q2
+        | UnifFailure _ as x -> fail x
+      else fail (UnifFailure (i,NotSameHead))
+    | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _
+    | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false
+    | Stack.App _ :: _, Stack.App _ :: _ ->
+       if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else
+	 begin match ise_app_stack2 env f i sk1 sk2 with
+	       |_,(UnifFailure _ as x) -> fail x
+	       |(l1, l2), Success i' -> ise_stack2 true i' l1 l2
+	 end
+    |_, _ -> fail (UnifFailure (i,(* Maybe improve: *) NotSameHead))
+  in ise_stack2 false evd (List.rev sk1) (List.rev sk2)
+
+(* Make sure that the matching suffix is the all stack *)
+let exact_ise_stack2 env evd f sk1 sk2 =
+  let rec ise_stack2 i sk1 sk2 =
+    match sk1, sk2 with
+    | [], [] -> Success i
+    | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 ->
+      ise_and i [
+      (fun i -> ise_stack2 i q1 q2);
+      (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2);
+      (fun i -> f env i CONV t1 t2)]
+    | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1,
+      Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 ->
+      if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then
+	ise_and i [
+	  (fun i -> ise_stack2 i q1 q2);
+	  (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2);
+	  (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2);
+	  (fun i -> ise_stack2 i a1 a2)]
+      else UnifFailure (i,NotSameHead)
+    | Stack.Proj (n1,a1,p1,_)::q1, Stack.Proj (n2,a2,p2,_)::q2 ->
+       if eq_constant (Projection.constant p1) (Projection.constant p2)
+       then ise_stack2 i q1 q2
+       else (UnifFailure (i, NotSameHead))
+    | Stack.Update _ :: _, _ | Stack.Shift _ :: _, _
+    | _, Stack.Update _ :: _ | _, Stack.Shift _ :: _ -> assert false
+    | Stack.App _ :: _, Stack.App _ :: _ ->
+	 begin match ise_app_stack2 env f i sk1 sk2 with
+	       |_,(UnifFailure _ as x) -> x
+	       |(l1, l2), Success i' -> ise_stack2 i' l1 l2
+	 end
+    |_, _ -> UnifFailure (i,(* Maybe improve: *) NotSameHead)
+  in
+  if Reductionops.Stack.compare_shape sk1 sk2 then
+    ise_stack2 evd (List.rev sk1) (List.rev sk2)
+  else UnifFailure (evd, (* Dummy *) NotSameHead)
+    
 let rec evar_conv_x ts env evd pbty term1 term2 =
   let term1 = whd_head_evar evd term1 in
   let term2 = whd_head_evar evd term2 in
@@ -183,426 +323,578 @@ let rec evar_conv_x ts env evd pbty term1 term2 =
      could have found, we do it only if the terms are free of evar.
      Note: incomplete heuristic... *)
   let ground_test =
-    if is_ground_term evd term1 && is_ground_term evd term2 then
-      if is_trans_fconv pbty ts env evd term1 term2 then
-        Some true
-      else if is_ground_env evd env then Some false
-      else None
-    else None in
+    if is_ground_term evd term1 && is_ground_term evd term2 then (
+      let evd, b = 
+	try infer_conv ~pb:pbty ~ts:(fst ts) env evd term1 term2 
+	with Univ.UniverseInconsistency _ -> evd, false
+      in
+	if b then Some (evd, true)
+	else if is_ground_env evd env then Some (evd, false)
+	else None)
+    else None
+  in
   match ground_test with
-      Some b -> (evd,b)
+    | Some (evd, true) -> Success evd
+    | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2))
     | None ->
 	(* Until pattern-unification is used consistently, use nohdbeta to not
 	   destroy beta-redexes that can be used for 1st-order unification *)
-        let term1 = apprec_nohdbeta ts env evd term1 in
-        let term2 = apprec_nohdbeta ts env evd term2 in
-        if is_undefined_evar evd term1 then
-          solve_simple_eqn (evar_conv_x ts) env evd
-	    (position_problem true pbty,destEvar term1,term2)
-        else if is_undefined_evar evd term2 then
-          solve_simple_eqn (evar_conv_x ts) env evd
-	    (position_problem false pbty,destEvar term2,term1)
-        else
+        let term1 = apprec_nohdbeta (fst ts) env evd term1 in
+        let term2 = apprec_nohdbeta (fst ts) env evd term2 in
+	let default () = 
           evar_eqappr_x ts env evd pbty
-            (decompose_app term1) (decompose_app term2)
-
-and evar_eqappr_x ?(rhs_is_already_stuck = false)
-  ts env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
-
-  let eta env evd onleft term l term' l' =
-    assert (l = []);
-    let (na,c,body) = destLambda term in
-    let c = nf_evar evd c in
+            (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty)
+            (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty)
+	in
+          begin match kind_of_term term1, kind_of_term term2 with
+          | Evar ev, _ when Evd.is_undefined evd (fst ev) ->
+            (match solve_simple_eqn (evar_conv_x ts) env evd
+              (position_problem true pbty,ev,term2) with
+	      | UnifFailure (_,OccurCheck _) -> 
+		(* Eta-expansion might apply *) default ()
+	      | x -> x)
+          | _, Evar ev when Evd.is_undefined evd (fst ev) ->
+            (match solve_simple_eqn (evar_conv_x ts) env evd
+              (position_problem false pbty,ev,term1) with
+	      | UnifFailure (_, OccurCheck _) ->
+		(* Eta-expansion might apply *) default () 
+	      | x -> x)
+          | _ -> default ()
+        end
+
+and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
+    ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) =
+  let default_fail i = (* costly *)
+    UnifFailure (i,ConversionFailed (env, Stack.zip appr1, Stack.zip appr2)) in
+  let quick_fail i = (* not costly, loses info *)
+    UnifFailure (i, NotSameHead)
+  in
+  let miller_pfenning on_left fallback ev lF tM evd =
+    match is_unification_pattern_evar env evd ev lF tM with
+      | None -> fallback ()
+      | Some l1' -> (* Miller-Pfenning's patterns unification *)
+	let t2 = nf_evar evd tM in
+	let t2 = solve_pattern_eqn env l1' t2 in
+	  solve_simple_eqn (evar_conv_x ts) env evd
+	    (position_problem on_left pbty,ev,t2) 
+  in
+  let consume_stack on_left (termF,skF) (termO,skO) evd =
+    let switch f a b = if on_left then f a b else f b a in
+    let not_only_app = Stack.not_purely_applicative skO in
+    match switch (ise_stack2 not_only_app env evd (evar_conv_x ts)) skF skO with
+      |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) ->
+	switch (evar_conv_x ts env i' pbty) (Stack.zip(termF,l)) (Stack.zip(termO,r))
+      |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) ->
+	switch (evar_conv_x ts env i' pbty) (Stack.zip(termF,l)) (Stack.zip(termO,r))
+      |None, Success i' -> switch (evar_conv_x ts env i' pbty) termF termO
+      |_, (UnifFailure _ as x) -> x
+      |Some _, _ -> UnifFailure (evd,NotSameArgSize) in
+  let eta env evd onleft sk term sk' term' =
+    assert (match sk with [] -> true | _ -> false);
+    let (na,c1,c'1) = destLambda term in
+    let c = nf_evar evd c1 in
     let env' = push_rel (na,None,c) env in
-    let appr1 = evar_apprec ts env' evd [] body in
-    let appr2 = (lift 1 term', List.map (lift 1) l' @ [mkRel 1]) in
-    if onleft then evar_eqappr_x ts env' evd CONV appr1 appr2
-    else evar_eqappr_x ts env' evd CONV appr2 appr1
+    let out1 = whd_betaiota_deltazeta_for_iota_state
+      (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in
+    let out2 = whd_nored_state evd
+      (Stack.zip (term', sk' @ [Stack.Shift 1]), Stack.append_app [|mkRel 1|] Stack.empty), 
+      Cst_stack.empty in
+    if onleft then evar_eqappr_x ts env' evd CONV out1 out2
+    else evar_eqappr_x ts env' evd CONV out2 out1
   in
-
+  let rigids env evd sk term sk' term' =
+    let b,univs = Universes.eq_constr_universes term term' in
+      if b then
+       ise_and evd [(fun i ->
+         let cstrs = Universes.to_constraints (Evd.universes i) univs in
+           try Success (Evd.add_constraints i cstrs)
+           with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p));
+                  (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')]
+      else UnifFailure (evd,NotSameHead)
+  in
+  let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM =
+    let switch f a b = if on_left then f a b else f b a in
+    let not_only_app = Stack.not_purely_applicative skM in
+    let f1 i =
+      match Stack.list_of_app_stack skF with
+      | None -> default_fail evd
+      | Some lF -> 
+        let tM = Stack.zip apprM in
+	  miller_pfenning on_left
+	    (fun () -> if not_only_app then (* Postpone the use of an heuristic *)
+	      switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (Stack.zip apprF) tM
+	    else quick_fail i)
+	  ev lF tM i
+    and consume (termF,skF as apprF) (termM,skM as apprM) i = 
+      if not (Stack.is_empty skF && Stack.is_empty skM) then
+        consume_stack on_left apprF apprM i
+      else quick_fail i
+    and delta i =
+      switch (evar_eqappr_x ts env i pbty) (apprF,cstsF)
+	(whd_betaiota_deltazeta_for_iota_state (fst ts) env i cstsM (vM,skM))
+    in    
+    let default i = ise_try i [f1; consume apprF apprM; delta]
+    in
+      match kind_of_term termM with
+      | Proj (p, c) when not (Stack.is_empty skF) ->
+	(* Might be ?X args = p.c args', and we have to eta-expand the 
+	   primitive projection if |args| >= |args'|+1. *)
+	let nargsF = Stack.args_size skF and nargsM = Stack.args_size skM in
+	  begin
+	    (* ?X argsF' ~= (p.c ..) argsM' -> ?X ~= (p.c ..), no need to expand *)
+	    if nargsF <= nargsM then default evd
+	    else 
+	      let f =
+		try 
+		  let termM' = Retyping.expand_projection env evd p c [] in
+		  let apprM', cstsM' = 
+		    whd_betaiota_deltazeta_for_iota_state (fst ts) env evd cstsM (termM',skM)
+		  in
+		  let delta' i = 
+		    switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM') 
+		  in
+		    fun i -> ise_try i [f1; consume apprF apprM'; delta']
+		with Retyping.RetypeError _ ->
+		(* Happens thanks to w_unify building ill-typed terms *) 
+		  default
+	      in f evd
+	  end
+      | _ -> default evd
+  in
+  let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) =
+    let switch f a b = if on_left then f a b else f b a in
+    let eta evd =
+             match kind_of_term termR with
+	     | Lambda _ -> eta env evd false skR termR skF termF
+	     | Construct u -> eta_constructor ts env evd skR u skF termF
+	     | _ -> UnifFailure (evd,NotSameHead)
+    in
+    match Stack.list_of_app_stack skF with
+    | None ->
+        ise_try evd [consume_stack on_left apprF apprR; eta]
+    | Some lF ->
+        let tR = Stack.zip apprR in
+	  miller_pfenning on_left
+	    (fun () ->
+	      ise_try evd 
+	        [eta;(* Postpone the use of an heuristic *)
+		 (fun i -> 
+		   if not (occur_rigidly (fst ev) i tR) then
+                     let i,tF =
+                       if isRel tR || isVar tR then
+                         (* Optimization so as to generate candidates *)
+                         let i,ev = evar_absorb_arguments env i ev lF in
+                         i,mkEvar ev
+                       else
+                         i,Stack.zip apprF in
+		     switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i))
+	               tF tR
+		   else
+                     UnifFailure (evd,OccurCheck (fst ev,tR)))])
+	    ev lF tR evd
+  in
+  let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in
   (* Evar must be undefined since we have flushed evars *)
   let () = if !debug_unification then
 	     let open Pp in
-	     let pr_state (tm,l) =
-	       h 0 (Termops.print_constr tm ++ str "|" ++ cut ()
-		    ++ prlist_with_sep pr_semicolon
-				       (fun x -> hov 1 (Termops.print_constr x)) l) in
-	     pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) ++ fnl ()) in
-  match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with
+	     pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) 
+		 ++ fnl ()) in
+  match (flex_kind_of_term (fst ts) env evd term1 sk1, 
+	 flex_kind_of_term (fst ts) env evd term2 sk2) with
     | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
 	let f1 i =
-	  if List.length l1 > List.length l2 then
-            let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-            ise_and i
-              [(fun i -> solve_simple_eqn (evar_conv_x ts) env i
-	        (position_problem false pbty,ev2,applist(term1,deb1)));
-              (fun i -> ise_list2 i
-                  (fun i -> evar_conv_x ts env i CONV) rest1 l2)]
-	  else
-	    let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
-            ise_and i
-              [(fun i -> solve_simple_eqn (evar_conv_x ts) env i
-	          (position_problem true pbty,ev1,applist(term2,deb2)));
-              (fun i -> ise_list2 i
-                  (fun i -> evar_conv_x ts env i CONV) l1 rest2)]
+	  match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
+	  |None, Success i' -> 
+	    (* Evar can be defined in i' *)
+	    let ev1' = whd_evar i' (mkEvar ev1) in
+	      if isEvar ev1' then
+		solve_simple_eqn (evar_conv_x ts) env i'
+		  (position_problem true pbty,destEvar ev1',term2)
+	      else 
+		evar_eqappr_x ts env evd pbty 
+		  ((ev1', sk1), csts1) ((term2, sk2), csts2)
+	  |Some (r,[]), Success i' -> 
+	    let ev2' = whd_evar i' (mkEvar ev2) in
+	      if isEvar ev2' then
+		solve_simple_eqn (evar_conv_x ts) env i'
+		  (position_problem false pbty,destEvar ev2',Stack.zip(term1,r))
+	      else 
+		evar_eqappr_x ts env evd pbty 
+		  ((ev2', sk1), csts1) ((term2, sk2), csts2)
+
+	  |Some ([],r), Success i' -> 
+	    let ev1' = whd_evar i' (mkEvar ev1) in
+	      if isEvar ev1' then
+		solve_simple_eqn (evar_conv_x ts) env i'
+	          (position_problem true pbty,destEvar ev1',Stack.zip(term2,r))
+	      else evar_eqappr_x ts env evd pbty 
+		((ev1', sk1), csts1) ((term2, sk2), csts2)
+	  |_, (UnifFailure _ as x) -> x
+	  |Some _, _ -> UnifFailure (i,NotSameArgSize)
 	and f2 i =
-          if sp1 = sp2 then
-            ise_and i
-            [(fun i -> ise_list2 i
-                  (fun i -> evar_conv_x ts env i CONV) l1 l2);
-             (fun i -> solve_refl (evar_conv_x ts) env i sp1 al1 al2,
-                  true)]
-          else (i,false)
+          if Evar.equal sp1 sp2 then
+	    match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with
+	    |None, Success i' ->
+              Success (solve_refl (fun env i pbty a1 a2 ->
+                is_success (evar_conv_x ts env i pbty a1 a2))
+                env i' (position_problem true pbty) sp1 al1 al2)
+	    |_, (UnifFailure _ as x) -> x
+            |Some _, _ -> UnifFailure (i,NotSameArgSize)
+          else UnifFailure (i,NotSameHead)
 	in
 	ise_try evd [f1; f2]
 
-    | Flexible ev1, MaybeFlexible flex2 ->
-	let f1 i =
-          match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with
-          | Some l1' ->
-	    (* Miller-Pfenning's patterns unification *)
-	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t2 = nf_evar evd (applist appr2) in
-	    let t2 = solve_pattern_eqn env l1' t2 in
-	    solve_simple_eqn (evar_conv_x ts) env evd
-	      (position_problem true pbty,ev1,t2)
-          | None -> (i,false)
-        and f2 i =
-	  if
-            List.length l1 <= List.length l2
-	  then
-	    (* Try first-order unification *)
-	    (* (heuristic that gives acceptable results in practice) *)
-	    let (deb2,rest2) =
-              list_chop (List.length l2-List.length l1) l2 in
-            ise_and i
-              (* First compare extra args for better failure message *)
-              [(fun i -> ise_list2 i
-                  (fun i -> evar_conv_x ts env i CONV) l1 rest2);
-               (fun i -> evar_conv_x ts env i pbty term1 (applist(term2,deb2)))]
-          else (i,false)
-	and f3 i =
-	  match eval_flexible_term ts env flex2 with
-	    | Some v2 ->
-		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
-	    | None -> (i,false)
-	in
-	ise_try evd [f1; f2; f3]
+    | Flexible ev1, MaybeFlexible v2 ->
+      flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2
 
-    | MaybeFlexible flex1, Flexible ev2 ->
-	let f1 i =
-	  match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with
-          | Some l1' ->
-	    (* Miller-Pfenning's patterns unification *)
-	    (* Preserve generality (except that CCI has no eta-conversion) *)
-	    let t1 = nf_evar evd (applist appr1) in
-	    let t1 = solve_pattern_eqn env l2 t1 in
-	    solve_simple_eqn (evar_conv_x ts) env evd
-	      (position_problem false pbty,ev2,t1)
-          | None -> (i,false)
-        and f2 i =
-          if
-       	    List.length l2 <= List.length l1
-	  then
-	    (* Try first-order unification *)
-	    (* (heuristic that gives acceptable results in practice) *)
-            let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
-            ise_and i
-            (* First compare extra args for better failure message *)
-              [(fun i -> ise_list2 i
-                  (fun i -> evar_conv_x ts env i CONV) rest1 l2);
-               (fun i -> evar_conv_x ts env i pbty (applist(term1,deb1)) term2)]
-          else (i,false)
-	and f3 i =
-	  match eval_flexible_term ts env flex1 with
-	    | Some v1 ->
-		evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
-	    | None -> (i,false)
-	in
-	ise_try evd [f1; f2; f3]
+    | MaybeFlexible v1, Flexible ev2 -> 
+      flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1
 
-    | MaybeFlexible flex1, MaybeFlexible flex2 -> begin
-        match kind_of_term flex1, kind_of_term flex2 with
-        | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
+    | MaybeFlexible v1, MaybeFlexible v2 -> begin
+        match kind_of_term term1, kind_of_term term2 with
+        | LetIn (na,b1,t1,c'1), LetIn (_,b2,t2,c'2) ->
         let f1 i =
           ise_and i
-	    [(fun i -> evar_conv_x ts env i CONV b1 b2);
+	    [(fun i -> evar_conv_x ts env i CONV t1 t2);
+	     (fun i -> evar_conv_x ts env i CONV b1 b2);
 	     (fun i ->
 	       let b = nf_evar i b1 in
 	       let t = nf_evar i t1 in
 	       evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2);
-	     (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)]
+	     (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
 	and f2 i =
-          let appr1 = evar_apprec ts env i l1 (subst1 b1 c'1)
-          and appr2 = evar_apprec ts env i l2 (subst1 b2 c'2)
-	  in evar_eqappr_x ts env i pbty appr1 appr2
+          let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1)
+          and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2)
+	  in evar_eqappr_x ts env i pbty out1 out2
 	in
 	ise_try evd [f1; f2]
 
+	| Proj (p, c), Proj (p', c') 
+	  when Constant.equal (Projection.constant p) (Projection.constant p') ->
+	  let f1 i = 
+	    ise_and i 
+	    [(fun i -> evar_conv_x ts env i CONV c c');
+	     (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
+	  and f2 i =
+            let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1)
+            and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2)
+	    in evar_eqappr_x ts env i pbty out1 out2
+	  in
+	    ise_try evd [f1; f2]
+	      
+	(* Catch the p.c ~= p c' cases *)
+	| Proj (p,c), Const (p',u) when eq_constant (Projection.constant p) p' ->
+	  let res = 
+	    try Some (destApp (Retyping.expand_projection env evd p c []))
+	    with Retyping.RetypeError _ -> None
+	  in
+	    (match res with 
+	    | Some (f1,args1) -> 
+	      evar_eqappr_x ts env evd pbty ((f1,Stack.append_app args1 sk1),csts1) 
+		(appr2,csts2)
+	    | None -> UnifFailure (evd,NotSameHead))
+	      
+	| Const (p,u), Proj (p',c') when eq_constant p (Projection.constant p') ->
+	  let res = 
+	    try Some (destApp (Retyping.expand_projection env evd p' c' []))
+	    with Retyping.RetypeError _ -> None
+	  in 
+	    (match res with
+	    | Some (f2,args2) ->
+	      evar_eqappr_x ts env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2)
+	    | None -> UnifFailure (evd,NotSameHead))
+	      
 	| _, _ ->
-	let f1 i =
-	  if eq_constr flex1 flex2 then
-	    ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2
-	  else
-	     (i,false)
+	let f1 i = 
+	  (* Gather the universe constraints that would make term1 and term2 equal.
+	     If these only involve unifications of flexible universes to other universes,
+	     allow this identification (first-order unification of universes). Otherwise
+	     fallback to unfolding.
+	  *)
+	  let b,univs = Universes.eq_constr_universes term1 term2 in
+	    if b then
+	      ise_and i [(fun i -> 
+		try Success (Evd.add_universe_constraints i univs)
+		with UniversesDiffer -> UnifFailure (i,NotSameHead)
+		| Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p));
+			 (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
+	    else UnifFailure (i,NotSameHead)
 	and f2 i =
-	  (try conv_record ts env i
-             (try check_conv_record appr1 appr2
-	      with Not_found -> check_conv_record appr2 appr1)
-           with Not_found -> (i,false))
+	  (try 
+	     if not (snd ts) then raise Not_found
+	     else conv_record ts env i
+               (try check_conv_record env i appr1 appr2
+		with Not_found -> check_conv_record env i appr2 appr1)
+           with Not_found -> UnifFailure (i,NoCanonicalStructure))
 	and f3 i =
           (* heuristic: unfold second argument first, exception made
              if the first argument is a beta-redex (expand a constant
              only if necessary) or the second argument is potentially
              usable as a canonical projection or canonical value *)
           let rec is_unnamed (hd, args) = match kind_of_term hd with
-            | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> false
-            | (Case _|Fix _|CoFix _|Meta _|Rel _)-> true
-            | Evar _ -> false (* immediate solution without Canon Struct *)
-            | Lambda _ -> assert(args = []); true
-            | LetIn (_,b,_,c) -> 
-                is_unnamed (evar_apprec ts env i args (subst1 b c))
-            | App _| Cast _ -> assert false in
+            | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) ->
+	      Stack.not_purely_applicative args
+            | (CoFix _|Meta _|Rel _)-> true
+            | Evar _ -> Stack.not_purely_applicative args
+	    (* false (* immediate solution without Canon Struct *)*)
+            | Lambda _ -> assert (match args with [] -> true | _ -> false); true
+            | LetIn (_,b,_,c) -> is_unnamed
+	     (fst (whd_betaiota_deltazeta_for_iota_state
+		      (fst ts) env i Cst_stack.empty (subst1 b c, args)))
+	    | Fix _ -> true (* Partially applied fix can be the result of a whd call *)
+	    | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args
+            | Case _ | App _| Cast _ -> assert false in
           let rhs_is_stuck_and_unnamed () =
-            match eval_flexible_term ts env flex2 with
-            | None -> false
-            | Some v2 -> is_unnamed (evar_apprec ts env i l2 v2) in
+	    let applicative_stack = fst (Stack.strip_app sk2) in
+	    is_unnamed
+	      (fst (whd_betaiota_deltazeta_for_iota_state
+		      (fst ts) env i Cst_stack.empty (v2, applicative_stack))) in
           let rhs_is_already_stuck =
             rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in
-	  if isLambda flex1 || rhs_is_already_stuck then
-	    match eval_flexible_term ts env flex1 with
-	    | Some v1 ->
-		evar_eqappr_x ~rhs_is_already_stuck 
-                  ts env i pbty (evar_apprec ts env i l1 v1) appr2
-	    | None ->
-		match eval_flexible_term ts env flex2 with
-		| Some v2 ->
-		    evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
-		| None -> (i,false)
+
+	  if (isLambda term1 || rhs_is_already_stuck)
+	    && (not (Stack.not_purely_applicative sk1)) then
+	    evar_eqappr_x ~rhs_is_already_stuck ts env i pbty
+	      (whd_betaiota_deltazeta_for_iota_state
+		 (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1))
+	      (appr2,csts2)
 	  else
-	    match eval_flexible_term ts env flex2 with
-	    | Some v2 ->
-		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
-	    | None ->
-		match eval_flexible_term ts env flex1 with
-		| Some v1 ->
-		    evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
-		| None -> (i,false)
+	    evar_eqappr_x ts env i pbty (appr1,csts1)
+	      (whd_betaiota_deltazeta_for_iota_state
+		 (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2))
 	in
 	ise_try evd [f1; f2; f3]
-      end
+    end
 
-    | Rigid c1, Rigid c2 when isLambda c1 & isLambda c2 ->
-        let (na,c1,c'1) = destLambda c1 in
-        let (_,c2,c'2) = destLambda c2 in
-        assert (l1=[] & l2=[]);
+    | Rigid, Rigid when isLambda term1 && isLambda term2 ->
+        let (na,c1,c'1) = destLambda term1 in
+        let (_,c2,c'2) = destLambda term2 in
+        assert app_empty;
         ise_and evd
           [(fun i -> evar_conv_x ts env i CONV c1 c2);
            (fun i ->
 	     let c = nf_evar i c1 in
 	     evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)]
 
-    | Flexible ev1, (Rigid _ | PseudoRigid _) ->
-	(match is_unification_pattern_evar env evd ev1 l1 (applist appr2) with
-        | Some l1 ->
-	  (* Miller-Pfenning's pattern unification *)
-	  (* Preserve generality thanks to eta-conversion) *)
-	  let t2 = nf_evar evd (applist appr2) in
-	  let t2 = solve_pattern_eqn env l1 t2 in
-	  solve_simple_eqn (evar_conv_x ts) env evd
-	    (position_problem true pbty,ev1,t2)
-        | None ->
-          if isLambda term2 then
-            eta env evd false term2 l2 term1 l1
-          else
-	  (* Postpone the use of an heuristic *)
-	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
-	  true)
-
-    | (Rigid _ | PseudoRigid _), Flexible ev2 ->
-	(match is_unification_pattern_evar env evd ev2 l2 (applist appr1) with
-        | Some l2 ->
-	  (* Miller-Pfenning's pattern unification *)
-	  (* Preserve generality thanks to eta-conversion) *)
-	  let t1 = nf_evar evd (applist appr1) in
-	  let t1 = solve_pattern_eqn env l2 t1 in
-	  solve_simple_eqn (evar_conv_x ts) env evd
-	    (position_problem false pbty,ev2,t1)
-        | None ->
-          if isLambda term1 then
-            eta env evd true term1 l1 term2 l2
-          else
-	  (* Postpone the use of an heuristic *)
-	  add_conv_pb (pbty,env,applist appr1,applist appr2) evd,
-	  true)
-
-    | MaybeFlexible flex1, (Rigid _ | PseudoRigid _) ->
+    | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
+    | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1
+
+    | MaybeFlexible v1, Rigid ->
 	let f3 i =
-	  (try conv_record ts env i (check_conv_record appr1 appr2)
-           with Not_found -> (i,false))
+	  (try 
+	     if not (snd ts) then raise Not_found
+	     else conv_record ts env i (check_conv_record env i appr1 appr2)
+           with Not_found -> UnifFailure (i,NoCanonicalStructure))
 	and f4 i =
-	  match eval_flexible_term ts env flex1 with
-	    | Some v1 ->
-		evar_eqappr_x ts env i pbty (evar_apprec ts env i l1 v1) appr2
-	    | None ->
-                if isLambda term2 then
-                  eta env i false term2 l2 term1 l1
-                else
-                  (i,false)
+	  evar_eqappr_x ts env i pbty
+	    (whd_betaiota_deltazeta_for_iota_state
+	       (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1))
+	    (appr2,csts2)
 	in
-	ise_try evd [f3; f4]
+	  ise_try evd [f3; f4]
 
-    | (Rigid _ | PseudoRigid _), MaybeFlexible flex2 ->
+    | Rigid, MaybeFlexible v2 ->
 	let f3 i =
-	  (try conv_record ts env i (check_conv_record appr2 appr1)
-           with Not_found -> (i,false))
+	  (try
+	     if not (snd ts) then raise Not_found
+	     else conv_record ts env i (check_conv_record env i appr2 appr1)
+           with Not_found -> UnifFailure (i,NoCanonicalStructure))
 	and f4 i =
-	  match eval_flexible_term ts env flex2 with
-	    | Some v2 ->
-		evar_eqappr_x ts env i pbty appr1 (evar_apprec ts env i l2 v2)
-	    | None ->
-                if isLambda term1 then
-                  eta env i true term1 l1 term2 l2
-                else
-                  (i,false)
+	  evar_eqappr_x ts env i pbty (appr1,csts1)
+	    (whd_betaiota_deltazeta_for_iota_state
+	       (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2))
 	in
-	ise_try evd [f3; f4]
+	  ise_try evd [f3; f4]
 
     (* Eta-expansion *)
-    | Rigid c1, _ when isLambda c1 ->
-        eta env evd true term1 l1 term2 l2
-
-    | _, Rigid c2 when isLambda c2 ->
-        eta env evd false term2 l2 term1 l1
-
-    | Rigid c1, Rigid c2 -> begin
-        match kind_of_term c1, kind_of_term c2 with
-
-	| Sort s1, Sort s2 when l1=[] & l2=[] ->
-	    (try 
-	       let evd' = 
-		 if pbty = CONV 
-		 then Evd.set_eq_sort evd s1 s2 
-		 else Evd.set_leq_sort evd s1 s2 
-	       in (evd', true)
-	     with Univ.UniverseInconsistency _ -> (evd, false)
-	     | e when Errors.noncritical e -> (evd, false))
-
-	| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] ->
+    | Rigid, _ when isLambda term1 ->
+        eta env evd true sk1 term1 sk2 term2
+
+    | _, Rigid when isLambda term2 ->
+        eta env evd false sk2 term2 sk1 term1
+
+    | Rigid, Rigid -> begin
+        match kind_of_term term1, kind_of_term term2 with
+
+	| Sort s1, Sort s2 when app_empty ->
+	    (try
+	       let evd' =
+		 if pbty == CONV
+		 then Evd.set_eq_sort env evd s1 s2
+		 else Evd.set_leq_sort env evd s1 s2
+	       in Success evd'
+	     with Univ.UniverseInconsistency p ->
+               UnifFailure (evd,UnifUnivInconsistency p)
+	     | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead))
+
+	| Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty ->
             ise_and evd
               [(fun i -> evar_conv_x ts env i CONV c1 c2);
                (fun i ->
  	         let c = nf_evar i c1 in
 	         evar_conv_x ts (push_rel (n,None,c) env) i pbty c'1 c'2)]
 
-	| Ind sp1, Ind sp2 ->
-	    if eq_ind sp1 sp2 then
-              ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2
-            else (evd, false)
-
-	| Construct sp1, Construct sp2 ->
-	    if eq_constructor sp1 sp2 then
-              ise_list2 evd (fun i -> evar_conv_x ts env i CONV) l1 l2
-            else (evd, false)
+	| Rel x1, Rel x2 ->
+	    if Int.equal x1 x2 then
+              exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2
+            else UnifFailure (evd,NotSameHead)
+
+	| Var var1, Var var2 ->
+	    if Id.equal var1 var2 then
+              exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2
+            else UnifFailure (evd,NotSameHead)
+
+	| Const _, Const _
+	| Ind _, Ind _ 
+	| Construct _, Construct _ ->
+	  rigids env evd sk1 term1 sk2 term2
+
+	| Construct u, _ ->
+	  eta_constructor ts env evd sk1 u sk2 term2
+	    
+	| _, Construct u ->
+	  eta_constructor ts env evd sk2 u sk1 term1
+
+	| Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *)
+	  if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then
+            ise_and evd [
+	      (fun i -> ise_array2 i (fun i' -> evar_conv_x ts env i' CONV) tys1 tys2);
+	      (fun i -> ise_array2 i (fun i' -> evar_conv_x ts (push_rec_types recdef1 env) i' CONV) bds1 bds2);
+	      (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
+	  else UnifFailure (evd, NotSameHead)
 
 	| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
-            if i1=i2  then
+            if Int.equal i1 i2  then
               ise_and evd
                 [(fun i -> ise_array2 i
                     (fun i -> evar_conv_x ts env i CONV) tys1 tys2);
                  (fun i -> ise_array2 i
 		     (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV)
 		     bds1 bds2);
-                 (fun i -> ise_list2 i
-                     (fun i -> evar_conv_x ts env i CONV) l1 l2)]
-            else (evd,false)
-
-	| (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _), _ -> (evd,false)
-	| _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _) -> (evd,false)
-
-	| (App _ | Meta _ | Cast _ | Case _ | Fix _), _ -> assert false
-	| (LetIn _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false
+                 (fun i -> exact_ise_stack2 env i
+                     (evar_conv_x ts) sk1 sk2)]
+            else UnifFailure (evd,NotSameHead)
+
+	| (Meta _, _) | (_, Meta _) ->
+	  begin match ise_stack2 true env evd (evar_conv_x ts) sk1 sk2 with
+	  |_, (UnifFailure _ as x) -> x
+	  |None, Success i' -> evar_conv_x ts env i' CONV term1 term2
+	  |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip (term1,sk1')) (Stack.zip (term2,sk2'))
+	  end
+
+	| (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _), _ ->
+	  UnifFailure (evd,NotSameHead)
+	| _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) ->
+	  UnifFailure (evd,NotSameHead)
+
+	| (App _ | Cast _ | Case _ | Proj _), _ -> assert false
+	| (LetIn _| Evar _), _ -> assert false
 	| (Lambda _), _ -> assert false
 
       end
 
-    | PseudoRigid c1, PseudoRigid c2 -> begin
-        match kind_of_term c1, kind_of_term c2 with
+and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) =
+  (* Tries to unify the states
 
-	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
-            ise_and evd
-              [(fun i -> evar_conv_x ts env i CONV p1 p2);
-               (fun i -> evar_conv_x ts env i CONV c1 c2);
-	       (fun i -> ise_array2 i
-                   (fun i -> evar_conv_x ts env i CONV) cl1 cl2);
-               (fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) l1 l2)]
-
-	| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
-            if li1=li2 then
-              ise_and evd
-                [(fun i -> ise_array2 i
-                    (fun i -> evar_conv_x ts env i CONV) tys1 tys2);
-                 (fun i -> ise_array2 i
-		     (fun i -> evar_conv_x ts (push_rec_types recdef1 env) i CONV)
-		     bds1 bds2);
-	         (fun i -> ise_list2 i
-                     (fun i -> evar_conv_x ts env i CONV) l1 l2)]
-	    else (evd,false)
+        (proji params1 c1 | sk1)   =   (proji params2 (c (?xs:bs)) | sk2)
 
-	| (Meta _ | Case _ | Fix _ | CoFix _),
-	  (Meta _ | Case _ | Fix _ | CoFix _) -> (evd,false)
+     and the terms
 
-	| (App _ | Ind _ | Construct _ | Sort _ | Prod _), _ -> assert false
-	| _, (App _ | Ind _ | Construct _ | Sort _ | Prod _) -> assert false
+        h us  =  h2 us2
 
-	| (LetIn _ | Cast _), _ -> assert false
-	| _, (LetIn _ | Cast _) -> assert false
+     where
 
-	| (Lambda _ | Rel _ | Var _ | Const _ | Evar _), _ -> assert false
-	| _, (Lambda _ | Rel _ | Var _ | Const _ | Evar _) -> assert false
-      end
+     c = the constant for the canonical structure (i.e. some term of the form
+         fun (xs:bs) => Build_R params v1 .. vi-1 (h us) vi+1 .. vn)
+     bs = the types of the parameters of the canonical structure
+     c1 = the main argument of the canonical projection
+     sk1, sk2 = the surrounding stacks of the conversion problem
+     params1, params2 = the params of the projection (empty if a primitive proj)
 
-    | PseudoRigid _, Rigid _ ->  (evd,false)
+     knowing that
 
-    | Rigid _, PseudoRigid _ ->  (evd,false)
+       (proji params1 c1 | sk1)   =   (h2 us2 | sk2)
 
-and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
-  let (evd',ks,_) =
-    List.fold_left
-      (fun (i,ks,m) b ->
-	 if m=n then (i,t2::ks, m-1) else
-	 let dloc = (dummy_loc,InternalHole) in
-         let (i',ev) = new_evar i env ~src:dloc (substl ks b) in
-	 (i', ev :: ks, m - 1))
-      (evd,[],List.length bs - 1) bs
-  in
-  ise_and evd'
-    [(fun i ->
-       ise_list2 i
-         (fun i x1 x -> evar_conv_x trs env i CONV x1 (substl ks x))
-         params1 params);
-    (fun i ->
-      ise_list2 i
-        (fun i u1 u -> evar_conv_x trs env i CONV u1 (substl ks u))
-        us2 us);
-    (fun i -> evar_conv_x trs env i CONV c1 (applist (c,(List.rev ks))));
-    (fun i -> ise_list2 i (fun i -> evar_conv_x trs env i CONV) ts ts1)]
+     had to be initially resolved
+  *)
+  let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in
+  if Reductionops.Stack.compare_shape sk1 sk2 then
+    let (evd',ks,_,test) =
+      List.fold_left
+	(fun (i,ks,m,test) b ->
+	  if match n with Some n -> Int.equal m n | None -> false then
+	    let ty = Retyping.get_type_of env i t2 in
+	    let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in
+	      (i,t2::ks, m-1, test)
+	  else
+	    let dloc = (Loc.ghost,Evar_kinds.InternalHole) in
+            let (i',ev) = new_evar env i ~src:dloc (substl ks b) in
+	    (i', ev :: ks, m - 1,test))
+	(evd,[],List.length bs,fun i -> Success i) bs
+    in
+    let app = mkApp (c, Array.rev_of_list ks) in
+    ise_and evd'
+      [(fun i ->
+	exact_ise_stack2 env i
+          (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (substl ks x))
+          params1 params);
+       (fun i ->
+	 exact_ise_stack2 env i
+           (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (substl ks u))
+           us2 us);
+       (fun i -> evar_conv_x trs env i CONV c1 app);
+       (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2);
+       test;
+       (fun i -> evar_conv_x trs env i CONV h2
+	 (fst (decompose_app_vect (substl ks h))))]
+  else UnifFailure(evd,(*dummy*)NotSameHead)
+
+and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 =
+  let mib = lookup_mind (fst ind) env in
+    match mib.Declarations.mind_record with
+    | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> 
+      let pars = mib.Declarations.mind_nparams in
+	(try 
+	   let l1' = Stack.tail pars sk1 in
+	   let l2' = 
+	     let term = Stack.zip (term2,sk2) in 
+	       List.map (fun p -> mkProj (Projection.make p false, term)) (Array.to_list projs)
+	   in
+	     exact_ise_stack2 env evd (evar_conv_x (fst ts, false)) l1' 
+	       (Stack.append_app_list l2' Stack.empty)
+	 with 
+	 | Invalid_argument _ ->
+	   (* Stack.tail: partially applied constructor *)
+	   UnifFailure(evd,NotSameHead))
+    | _ -> UnifFailure (evd,NotSameHead)
+
+let evar_conv_x ts = evar_conv_x (ts, true)
+
+(* Profiling *)
+let evar_conv_x =
+  if Flags.profile then
+    let evar_conv_xkey = Profile.declare_profile "evar_conv_x" in
+      Profile.profile6 evar_conv_xkey evar_conv_x
+  else evar_conv_x
+
+let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x ()
+
+let evar_conv_x ts = Hook.get evar_conv_hook_get ts
+
+let set_evar_conv f = Hook.set evar_conv_hook_set f
 
-(* getting rid of the optional argument rhs_is_already_stuck *)
-let evar_eqappr_x ts env evd pbty appr1 appr2 =
-  evar_eqappr_x ts env evd pbty appr1 appr2
 
 (* We assume here |l1| <= |l2| *)
 
 let first_order_unification ts env evd (ev1,l1) (term2,l2) =
-  let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+  let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in
   ise_and evd
     (* First compare extra args for better failure message *)
-    [(fun i -> ise_list2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1);
+    [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1);
     (fun i ->
       (* Then instantiate evar unless already done by unifying args *)
-      let t2 = applist(term2,deb2) in
-      if is_defined_evar i ev1 then
+      let t2 = mkApp(term2,deb2) in
+      if is_defined i (fst ev1) then
 	evar_conv_x ts env i CONV t2 (mkEvar ev1)
       else
 	solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))]
@@ -610,46 +902,50 @@ let first_order_unification ts env evd (ev1,l1) (term2,l2) =
 let choose_less_dependent_instance evk evd term args =
   let evi = Evd.find_undefined evd evk in
   let subst = make_pure_subst evi args in
-  let subst' = List.filter (fun (id,c) -> eq_constr c term) subst in
-  if subst' = [] then evd, false else
-  Evd.define evk (mkVar (fst (List.hd subst'))) evd, true
+  let subst' = List.filter (fun (id,c) -> Term.eq_constr c term) subst in
+  match subst' with
+  | [] -> None
+  | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd)
 
-let apply_on_subterm evdref f c t =
-  let rec applyrec (k,c as kc) t =
+let apply_on_subterm env evdref f c t =
+  let rec applyrec (env,(k,c) as acc) t =
     (* By using eq_constr, we make an approximation, for instance, we *)
     (* could also be interested in finding a term u convertible to t *)
     (* such that c occurs in u *)
-    if eq_constr c t then f k
+    if e_eq_constr_univs evdref c t then f k
     else
       match kind_of_term t with
       | Evar (evk,args) when Evd.is_undefined !evdref evk ->
           let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in
-          let g (_,b,_) a = if b = None then applyrec kc a else a in
+          let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in
           mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args)))
       | _ ->
-        map_constr_with_binders_left_to_right (fun d (k,c) -> (k+1,lift 1 c))
-	  applyrec kc t
+        map_constr_with_binders_left_to_right
+	  (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c)))
+	  applyrec acc t
   in
-  applyrec (0,c) t
+  applyrec (env,(0,c)) t
 
 let filter_possible_projections c ty ctxt args =
-  let fv1 = free_rels c in
-  let fv2 = collect_vars c in
+  (* Since args in the types will be replaced by holes, we count the
+     fv of args to have a well-typed filter; don't know how necessary
+     it is however to have a well-typed filter here *)
+  let fv1 = free_rels (mkApp (c,args)) (* Hack: locally untyped *) in
+  let fv2 = collect_vars (mkApp (c,args)) in
+  let len = Array.length args in
   let tyvars = collect_vars ty in
-  List.map2 (fun (id,b,_) a ->
-    b <> None ||
+  List.map_i (fun i (id,b,_) ->
+    let () = assert (i < len) in
+    let a = Array.unsafe_get args i in
+    (match b with None -> false | Some c -> not (isRel c || isVar c)) ||
     a == c ||
     (* Here we make an approximation, for instance, we could also be *)
     (* interested in finding a term u convertible to c such that a occurs *)
     (* in u *)
-    isRel a && Intset.mem (destRel a) fv1 ||
-    isVar a && Idset.mem (destVar a) fv2 ||
-    Idset.mem id tyvars)
-    ctxt args
-
-let initial_evar_data evi =
-  let ids = List.map pi1 (evar_context evi) in
-  (evar_filter evi, List.map mkVar ids)
+    isRel a && Int.Set.mem (destRel a) fv1 ||
+    isVar a && Id.Set.mem (destVar a) fv2 ||
+    Id.Set.mem id tyvars)
+    0 ctxt
 
 let solve_evars = ref (fun _ -> failwith "solve_evars not installed")
 let set_solve_evars f = solve_evars := f
@@ -671,48 +967,49 @@ let set_solve_evars f = solve_evars := f
  * proposition from Dan Grayson]
  *)
 
+exception TypingFailed of evar_map
+
 let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
   try
-  let args = Array.to_list args in
   let evi = Evd.find_undefined evd evk in
-  let env_evar = evar_env evi in
+  let env_evar = evar_filtered_env evi in
   let sign = named_context_val env_evar in
   let ctxt = evar_filtered_context evi in
-  let filter = evar_filter evi in
   let instance = List.map mkVar (List.map pi1 ctxt) in
 
   let rec make_subst = function
   | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
-      if occs<>None then
+      begin match occs with
+      | Some _ ->
         error "Cannot force abstraction on identity instance."
-      else
+      | None ->
         make_subst (ctxt',l,occsl)
+      end
   | (id,_,t)::ctxt', c::l, occs::occsl ->
       let evs = ref [] in
       let ty = Retyping.get_type_of env_rhs evd c in
       let filter' = filter_possible_projections c ty ctxt args in
-      let filter = List.map2 (&&) filter filter' in
-      (id,t,c,ty,evs,filter,occs) :: make_subst (ctxt',l,occsl)
-  | [], [], [] -> []
-  | _ -> anomaly "Signature, instance and occurrences list do not match" in
+      (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl)
+  | _, _, [] -> []
+  | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list") in
 
   let rec set_holes evdref rhs = function
   | (id,_,c,cty,evsref,filter,occs)::subst ->
       let set_var k =
         match occs with
-        | Some (false,[]) -> mkVar id
+        | Some Locus.AllOccurrences -> mkVar id
         | Some _ -> error "Selection of specific occurrences not supported"
         | None ->
         let evty = set_holes evdref cty subst in
-        let instance = snd (list_filter2 (fun b c -> b) (filter,instance)) in
+        let instance = Filter.filter_list filter instance in
         let evd,ev = new_evar_instance sign !evdref evty ~filter instance in
         evdref := evd;
         evsref := (fst (destEvar ev),evty)::!evsref;
         ev in
-      set_holes evdref (apply_on_subterm evdref set_var c rhs) subst
+      set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst
   | [] -> rhs in
 
-  let subst = make_subst (ctxt,args,argoccs) in
+  let subst = make_subst (ctxt,Array.to_list args,argoccs) in
 
   let evdref = ref evd in
   let rhs = set_holes evdref rhs subst in
@@ -720,10 +1017,11 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
 
   (* We instantiate the evars of which the value is forced by typing *)
   let evd,rhs =
-    try !solve_evars env_evar evd rhs
+    let evdref = ref evd in
+    try let c = !solve_evars env_evar evdref rhs in !evdref,c
     with e when Pretype_errors.precatchable_exception e ->
       (* Could not revert all subterms *)
-      raise Exit in
+      raise (TypingFailed !evdref) in
 
   let rec abstract_free_holes evd = function
   | (id,idty,c,_,evsref,_,_)::l ->
@@ -735,10 +1033,12 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
               (* and we use typing to propagate this instantiation *)
               (* This is an arbitrary choice *)
               let evd = Evd.define evk (mkVar id) evd in
-              let evd,b = evar_conv_x ts env_evar evd CUMUL idty evty in
-              if not b then error "Cannot find an instance";
-              let evd,b = reconsider_conv_pbs (evar_conv_x ts) evd in
-              if not b then error "Cannot find an instance";
+              match evar_conv_x ts env_evar evd CUMUL idty evty with
+              | UnifFailure _ -> error "Cannot find an instance"
+              | Success evd ->
+              match reconsider_conv_pbs (evar_conv_x ts) evd with
+              | UnifFailure _ -> error "Cannot find an instance"
+              | Success evd ->
               evd
             else
               evd
@@ -749,63 +1049,78 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
       in
       force_instantiation evd !evsref
   | [] ->
-      Evd.define evk rhs evd in
-
+    let evd = 
+      try Evarsolve.check_evar_instance evd evk rhs 
+	    (evar_conv_x full_transparent_state)
+      with IllTypedInstance _ -> raise (TypingFailed evd)
+    in
+      Evd.define evk rhs evd 
+  in
   abstract_free_holes evd subst, true
-  with Exit -> evd, false
+  with TypingFailed evd -> evd, false
 
 let second_order_matching_with_args ts env evd ev l t =
 (*
   let evd,ev = evar_absorb_arguments env evd ev l in
-  let argoccs = array_map_to_list (fun _ -> None) (snd ev) in
-  second_order_matching ts env evd ev argoccs t
+  let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in
+  let evd, b = second_order_matching ts env evd ev argoccs t in
+  if b then Success evd
+  else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
+  if b then Success evd else
 *)
-  (evd,false)
+  UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t))
 
 let apply_conversion_problem_heuristic ts env evd pbty t1 t2 =
   let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in
   let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in
-  let (term1,l1 as appr1) = decompose_app t1 in
-  let (term2,l2 as appr2) = decompose_app t2 in
+  let (term1,l1 as appr1) = try destApp t1 with DestKO -> (t1, [||]) in
+  let (term2,l2 as appr2) = try destApp t2 with DestKO -> (t2, [||]) in
+  let app_empty = Array.is_empty l1 && Array.is_empty l2 in
   match kind_of_term term1, kind_of_term term2 with
-  | Evar (evk1,args1), (Rel _|Var _) when l1 = [] & l2 = []
-      & List.for_all (fun a -> eq_constr a term2 or isEvar a)
-        (remove_instance_local_defs evd evk1 (Array.to_list args1)) ->
+  | Evar (evk1,args1), (Rel _|Var _) when app_empty
+      && List.for_all (fun a -> Term.eq_constr a term2 || isEvar a)
+        (remove_instance_local_defs evd evk1 args1) ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
-    choose_less_dependent_instance evk1 evd term2 args1
-  | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = []
-      & List.for_all (fun a -> eq_constr a term1 or isEvar a)
-        (remove_instance_local_defs evd evk2 (Array.to_list args2)) ->
+      (match choose_less_dependent_instance evk1 evd term2 args1 with
+      | Some evd -> Success evd
+      | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+  | (Rel _|Var _), Evar (evk2,args2) when app_empty
+      && List.for_all (fun a -> Term.eq_constr a term1 || isEvar a)
+        (remove_instance_local_defs evd evk2 args2) ->
       (* The typical kind of constraint coming from pattern-matching return
          type inference *)
-    choose_less_dependent_instance evk2 evd term1 args2
-  | Evar (evk1,args1), Evar (evk2,args2) when evk1 = evk2 ->
-      let f env evd pbty x y = (evd,is_trans_fconv pbty ts env evd x y) in
-      solve_refl ~can_drop:true f env evd evk1 args1 args2, true
+      (match choose_less_dependent_instance evk2 evd term1 args2 with
+      | Some evd -> Success evd
+      | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)))
+  | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 ->
+      let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in
+      Success (solve_refl ~can_drop:true f env evd
+                 (position_problem true pbty) evk1 args1 args2)
   | Evar ev1, Evar ev2 ->
-      solve_evar_evar ~force:true
-        (evar_define (evar_conv_x ts)) (evar_conv_x ts) env evd ev1 ev2, true
-  | Evar ev1,_ when List.length l1 <= List.length l2 ->
+      Success (solve_evar_evar ~force:true
+        (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd
+        (position_problem true pbty) ev1 ev2)
+  | Evar ev1,_ when Array.length l1 <= Array.length l2 ->
       (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *)
       (* and otherwise second-order matching *)
       ise_try evd
         [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2);
          (fun evd ->
-           second_order_matching_with_args ts env evd ev1 l1 (applist appr2))]
-  | _,Evar ev2 when List.length l2 <= List.length l1 ->
+           second_order_matching_with_args ts env evd ev1 l1 t2)]
+  | _,Evar ev2 when Array.length l2 <= Array.length l1 ->
       (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *)
       (* and otherwise second-order matching *)
       ise_try evd
         [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1);
          (fun evd ->
-           second_order_matching_with_args ts env evd ev2 l2 (applist appr1))]
+           second_order_matching_with_args ts env evd ev2 l2 t1)]
   | Evar ev1,_ ->
       (* Try second-order pattern-matching *)
-      second_order_matching_with_args ts env evd ev1 l1 (applist appr2)
+      second_order_matching_with_args ts env evd ev1 l1 t2
   | _,Evar ev2 ->
       (* Try second-order pattern-matching *)
-      second_order_matching_with_args ts env evd ev2 l2 (applist appr1)
+      second_order_matching_with_args ts env evd ev2 l2 t1
   | _ ->
       (* Some head evar have been instantiated, or unknown kind of problem *)
       evar_conv_x ts env evd pbty t1 t2
@@ -828,9 +1143,9 @@ let max_undefined_with_candidates evd =
         | Some l -> (evk,ev_info,l)::evars) evd [] in
   match l with
   | [] -> None
-  | a::l -> Some (list_last (a::l))
+  | a::l -> Some (List.last (a::l))
 
-let rec solve_unconstrained_evars_with_canditates evd =
+let rec solve_unconstrained_evars_with_candidates ts evd =
   (* max_undefined is supposed to return the most recent, hence
      possibly most dependent evar *)
   match max_undefined_with_candidates evd with
@@ -840,70 +1155,87 @@ let rec solve_unconstrained_evars_with_canditates evd =
       | [] -> error "Unsolvable existential variables."
       | a::l ->
           try
-            let conv_algo = evar_conv_x full_transparent_state in
+            let conv_algo = evar_conv_x ts in
             let evd = check_evar_instance evd evk a conv_algo in
             let evd = Evd.define evk a evd in
-            let evd,b = reconsider_conv_pbs conv_algo evd in
-            if b then solve_unconstrained_evars_with_canditates evd
-            else aux l
-          with e when Pretype_errors.precatchable_exception e ->
-            aux l in
+            match reconsider_conv_pbs conv_algo evd with
+            | Success evd -> solve_unconstrained_evars_with_candidates ts evd
+            | UnifFailure _ -> aux l
+          with
+          | IllTypedInstance _ -> aux l
+          | e when Pretype_errors.precatchable_exception e -> aux l in
       (* List.rev is there to favor most dependent solutions *)
       (* and favor progress when used with the refine tactics *)
       let evd = aux (List.rev l) in
-      solve_unconstrained_evars_with_canditates evd
+      solve_unconstrained_evars_with_candidates ts evd
 
-let solve_unconstrained_impossible_cases evd =
+let solve_unconstrained_impossible_cases env evd =
   Evd.fold_undefined (fun evk ev_info evd' ->
     match ev_info.evar_source with
-    | _,ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd'
+    | _,Evar_kinds.ImpossibleCase -> 
+      let j, ctx = coq_unit_judge () in
+      let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in
+      let ty = j_type j in
+      let conv_algo = evar_conv_x full_transparent_state in
+      let evd' = check_evar_instance evd' evk ty conv_algo in
+	Evd.define evk ty evd' 
     | _ -> evd') evd evd
 
-
-let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd =
-  let evd = solve_unconstrained_evars_with_canditates evd in
+let consider_remaining_unif_problems env
+    ?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd =
+  let evd = solve_unconstrained_evars_with_candidates ts evd in
   let rec aux evd pbs progress stuck =
     match pbs with
     | (pbty,env,t1,t2 as pb) :: pbs ->
-      let evd', b = apply_conversion_problem_heuristic ts env evd pbty t1 t2 in
-	if b then 
-	  let (evd', rest) = extract_all_conv_pbs evd' in
-	    if rest = [] then aux evd' pbs true stuck
-	    else (* Unification got actually stuck, postpone *)
+        (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with
+	| Success evd' ->
+	    let (evd', rest) = extract_all_conv_pbs evd' in
+            begin match rest with
+            | [] -> aux evd' pbs true stuck
+            | _ -> (* Unification got actually stuck, postpone *)
 	      aux evd pbs progress (pb :: stuck)
-	else Pretype_errors.error_cannot_unify env evd (t1, t2)
+            end
+        | UnifFailure (evd,reason) ->
+	    Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
+              env evd ~reason (t1, t2))
     | _ -> 
 	if progress then aux evd stuck false []
 	else 
 	  match stuck with
 	  | [] -> (* We're finished *) evd
-	  | (pbty,env,t1,t2) :: _ ->
+	  | (pbty,env,t1,t2 as pb) :: _ ->
 	      (* There remains stuck problems *)
-	      Pretype_errors.error_cannot_unify env evd (t1, t2)
+	      Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb)
+                env evd (t1, t2)
   in
   let (evd,pbs) = extract_all_conv_pbs evd in
   let heuristic_solved_evd = aux evd pbs false [] in
   check_problems_are_solved env heuristic_solved_evd;
-  solve_unconstrained_impossible_cases heuristic_solved_evd
+  solve_unconstrained_impossible_cases env heuristic_solved_evd
 
 (* Main entry points *)
 
-let the_conv_x ?(ts=full_transparent_state) env t1 t2 evd =
+exception UnableToUnify of evar_map * unification_error
+
+let default_transparent_state env = full_transparent_state
+(* Conv_oracle.get_transp_state (Environ.oracle env) *)
+
+let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd =
   match evar_conv_x ts env evd CONV  t1 t2 with
-      (evd',true) -> evd'
-    | _ -> raise Reduction.NotConvertible
+  | Success evd' -> evd'
+  | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e))
 
-let the_conv_x_leq ?(ts=full_transparent_state) env t1 t2 evd =
+let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd =
   match evar_conv_x ts env evd CUMUL t1 t2 with
-      (evd', true) -> evd'
-    | _ -> raise Reduction.NotConvertible
+  | Success evd' -> evd'
+  | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e))
 
-let e_conv ?(ts=full_transparent_state) env evdref t1 t2 =
+let e_conv env ?(ts=default_transparent_state env) evdref t1 t2 =
   match evar_conv_x ts env !evdref CONV t1 t2 with
-      (evd',true) -> evdref := evd'; true
-    | _ -> false
+  | Success evd' -> evdref := evd'; true
+  | _ -> false
 
-let e_cumul ?(ts=full_transparent_state) env evdref t1 t2 =
+let e_cumul env ?(ts=default_transparent_state env) evdref t1 t2 =
   match evar_conv_x ts env !evdref CUMUL t1 t2 with
-      (evd',true) -> evdref := evd'; true
-    | _ -> false
+  | Success evd' -> evdref := evd'; true
+  | _ -> false
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 3a352d13..8bc30a71 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.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,40 +8,72 @@
 
 open Names
 open Term
-open Sign
 open Environ
-open Termops
 open Reductionops
 open Evd
+open Locus
 
-(** returns exception Reduction.NotConvertible if not unifiable *)
-val the_conv_x     : ?ts:transparent_state -> env -> constr -> constr -> evar_map -> evar_map
-val the_conv_x_leq : ?ts:transparent_state -> env -> constr -> constr -> evar_map -> evar_map
+(** {4 Unification for type inference. } *)
+
+exception UnableToUnify of evar_map * Pretype_errors.unification_error
+
+(** {6 Main unification algorithm for type inference. } *)
+
+(** returns exception NotUnifiable with best known evar_map if not unifiable *)
+val the_conv_x     : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map
+val the_conv_x_leq : env -> ?ts:transparent_state -> constr -> constr -> evar_map -> evar_map
 
 (** The same function resolving evars by side-effect and
    catching the exception *)
-val e_conv  : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool
-val e_cumul : ?ts:transparent_state -> env -> evar_map ref -> constr -> constr -> bool
+val e_conv  : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool
+val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool
 
-(**/**)
-(* For debugging *)
-val evar_conv_x : transparent_state ->
-  env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool
-val evar_eqappr_x : transparent_state ->
-  env -> evar_map ->
-    conv_pb -> constr * constr list -> constr * constr list ->
-      evar_map * bool
-(**/**)
+(** {6 Unification heuristics. } *)
+
+(** Try heuristics to solve pending unification problems and to solve
+    evars with candidates *)
+
+val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map
+
+(** Check all pending unification problems are solved and raise an
+    error otherwise *)
+
+val check_problems_are_solved : env -> evar_map -> unit
 
-val consider_remaining_unif_problems : ?ts:transparent_state -> env -> evar_map -> evar_map
+(** Check if a canonical structure is applicable *)
 
-val check_conv_record : constr * types list -> constr * types list ->
-  constr * constr list * (constr list * constr list) *
-    (constr list * types list) *
-    (constr list * types list) * constr *
-    (int * constr)
+val check_conv_record : env -> evar_map -> 
+  constr * types Stack.t -> constr * types Stack.t ->
+  Univ.universe_context_set * (constr * constr) 
+  * constr * constr list * (constr Stack.t * constr Stack.t) *
+    (constr Stack.t * types Stack.t) *
+    (constr Stack.t * types Stack.t) * constr *
+    (int option * constr)
 
-val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit
+(** Try to solve problems of the form ?x[args] = c by second-order
+    matching, using typing to select occurrences *)
 
-val second_order_matching : transparent_state -> env -> evar_map -> 
+val second_order_matching : transparent_state -> env -> evar_map ->
   existential -> occurrences option list -> constr -> evar_map * bool
+
+(** Declare function to enforce evars resolution by using typing constraints *)
+
+val set_solve_evars : (env -> evar_map ref -> constr -> constr) -> unit
+
+type unify_fun = transparent_state ->
+  env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result
+
+(** Override default [evar_conv_x] algorithm. *)
+val set_evar_conv : unify_fun -> unit
+
+(** The default unification algorithm with evars and universes. *)
+val evar_conv_x : unify_fun
+
+(**/**)
+(* For debugging *)
+val evar_eqappr_x : ?rhs_is_already_stuck:bool -> transparent_state * bool ->
+  env -> evar_map ->
+    conv_pb -> state * Cst_stack.t -> state * Cst_stack.t ->
+      Evarsolve.unification_result
+(**/**)
+
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
new file mode 100644
index 00000000..5aa72c90
--- /dev/null
+++ b/pretyping/evarsolve.ml
@@ -0,0 +1,1548 @@
+(************************************************************************)
+(*  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 Util
+open Errors
+open Names
+open Term
+open Vars
+open Context
+open Environ
+open Termops
+open Evd
+open Namegen
+open Retyping
+open Reductionops
+open Evarutil
+open Pretype_errors
+
+let normalize_evar evd ev =
+  match kind_of_term (whd_evar evd (mkEvar ev)) with
+  | Evar (evk,args) -> (evk,args)
+  | _ -> assert false
+
+let get_polymorphic_positions f = 
+  let open Declarations in
+  match kind_of_term f with
+  | Ind (ind, u) | Construct ((ind, _), u) -> 
+    let mib,oib = Global.lookup_inductive ind in
+      (match oib.mind_arity with
+      | RegularArity _ -> assert false
+      | TemplateArity templ -> templ.template_param_levels)
+  | Const (cst, u) ->
+    let cb = Global.lookup_constant cst in
+      (match cb.const_type with
+      | RegularArity _ -> assert false
+      | TemplateArity (_, templ) -> 
+        templ.template_param_levels)
+  | _ -> assert false
+
+(**
+   forall A (l : list A) -> typeof A = Type i <= Datatypes.j -> i not refreshed
+   hd ?A (l : list t) -> A = t
+
+*)
+let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t =
+  let evdref = ref evd in
+  let modified = ref false in
+  let rec refresh dir t = 
+    match kind_of_term t with
+    | Sort (Type u as s) when
+      (match Univ.universe_level u with
+      | None -> true 
+      | Some l -> not onlyalg && Option.is_empty (Evd.is_sort_variable evd s)) ->
+    let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in
+    let s' = evd_comb0 (new_sort_variable status) evdref in
+    let evd = 
+      if dir then set_leq_sort env !evdref s' s
+      else set_leq_sort env !evdref s s'
+    in
+      modified := true; evdref := evd; mkSort s'
+    | Prod (na,u,v) -> 
+    mkProd (na,u,refresh dir v)
+    | _ -> t
+  (** Refresh the types of evars under template polymorphic references *)
+  and refresh_term_evars onevars t =
+    match kind_of_term t with
+    | App (f, args) when is_template_polymorphic env f ->
+      let pos = get_polymorphic_positions f in
+	refresh_polymorphic_positions args pos
+    | Evar (ev, a) when onevars ->
+      let evi = Evd.find !evdref ev in
+      let ty' = refresh true evi.evar_concl in
+	if !modified then 
+	  evdref := Evd.add !evdref ev {evi with evar_concl = ty'}
+	else ()
+    | _ -> iter_constr (refresh_term_evars onevars) t
+  and refresh_polymorphic_positions args pos =
+    let rec aux i = function
+      | Some l :: ls -> 
+        if i < Array.length args then 
+	  ignore(refresh_term_evars true args.(i));
+        aux (succ i) ls
+      | None :: ls -> 
+        if i < Array.length args then 
+          ignore(refresh_term_evars false args.(i));
+	aux (succ i) ls
+      | [] -> ()
+    in aux 0 pos
+  in
+  let t' = 
+    if isArity t then
+      (match pbty with
+      | None -> t
+      | Some dir -> refresh dir t)
+    else (refresh_term_evars false t; t)
+  in
+    if !modified then !evdref, t' else !evdref, t
+
+let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c =
+  let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in
+    refresh_universes (Some false) env sigma ty
+
+(************************)
+(* Unification results  *)
+(************************)
+
+type unification_result =
+  | Success of evar_map
+  | UnifFailure of evar_map * unification_error
+
+let is_success = function Success _ -> true | UnifFailure _ -> false
+
+let test_success conv_algo env evd c c' rhs =
+  is_success (conv_algo env evd c c' rhs)
+
+let add_conv_oriented_pb (pbty,env,t1,t2) evd =
+  match pbty with
+  | Some true -> add_conv_pb (Reduction.CUMUL,env,t1,t2) evd
+  | Some false -> add_conv_pb (Reduction.CUMUL,env,t2,t1) evd
+  | None -> add_conv_pb (Reduction.CONV,env,t1,t2) evd
+
+(*------------------------------------*
+ * Restricting existing evars         *
+ *------------------------------------*)
+
+type 'a update =
+| UpdateWith of 'a
+| NoUpdate
+
+let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign
+
+let restrict_evar_key evd evk filter candidates =
+  match filter, candidates with
+  | None, NoUpdate -> evd, evk
+  | _ ->
+    let evi = Evd.find_undefined evd evk in
+    let oldfilter = evar_filter evi in
+    begin match filter, candidates with
+    | Some filter, NoUpdate when Filter.equal oldfilter filter ->
+      evd, evk
+    | _ ->
+      let filter = match filter with
+      | None -> evar_filter evi
+      | Some filter -> filter in
+      let candidates = match candidates with
+      | NoUpdate -> evi.evar_candidates
+      | UpdateWith c -> Some c in
+      restrict_evar evd evk filter candidates
+    end
+
+(* Restrict an applied evar and returns its restriction in the same context *)
+let restrict_applied_evar evd (evk,argsv) filter candidates =
+  let evd,newevk = restrict_evar_key evd evk filter candidates in
+  let newargsv = match filter with
+  | None -> (* optim *) argsv
+  | Some filter ->
+      let evi = Evd.find evd evk in
+      let subfilter = Filter.compose (evar_filter evi) filter in
+      Filter.filter_array subfilter argsv in
+  evd,(newevk,newargsv)
+
+(* Restrict an evar in the current evar_map *)
+let restrict_evar evd evk filter candidates =
+  fst (restrict_evar_key evd evk filter candidates)
+
+(* Restrict an evar in the current evar_map *)
+let restrict_instance evd evk filter argsv =
+  match filter with None -> argsv | Some filter ->
+  let evi = Evd.find evd evk in
+  Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv
+
+let noccur_evar env evd evk c =
+  let rec occur_rec k c = match kind_of_term c with
+  | Evar (evk',args' as ev') ->
+      (match safe_evar_value evd ev' with
+       | Some c -> occur_rec k c
+       | None ->
+           if Evar.equal evk evk' then raise Occur
+           else Array.iter (occur_rec k) args')
+  | Rel i when i > k ->
+      (match pi2 (Environ.lookup_rel (i-k) env) with
+       | None -> ()
+       | Some b -> occur_rec k (lift i b))
+  | _ -> iter_constr_with_binders succ occur_rec k c
+  in
+  try occur_rec 0 c; true with Occur -> false
+
+(***************************************)
+(* Managing chains of local definitons *)
+(***************************************)
+
+(* Expand rels and vars that are bound to other rels or vars so that
+   dependencies in variables are canonically associated to the most ancient
+   variable in its family of aliased variables *)
+
+let compute_var_aliases sign =
+  List.fold_right (fun (id,b,c) aliases ->
+    match b with
+    | Some t ->
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_id =
+              try Id.Map.find id' aliases with Not_found -> [] in
+            Id.Map.add id (aliases_of_id@[t]) aliases
+        | _ ->
+            Id.Map.add id [t] aliases)
+    | None -> aliases)
+    sign Id.Map.empty
+
+let compute_rel_aliases var_aliases rels =
+  snd (List.fold_right (fun (_,b,t) (n,aliases) ->
+    (n-1,
+     match b with
+     | Some t ->
+         (match kind_of_term t with
+         | Var id' ->
+             let aliases_of_n =
+               try Id.Map.find id' var_aliases with Not_found -> [] in
+             Int.Map.add n (aliases_of_n@[t]) aliases
+         | Rel p ->
+             let aliases_of_n =
+               try Int.Map.find (p+n) aliases with Not_found -> [] in
+             Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases
+         | _ ->
+             Int.Map.add n [lift n t] aliases)
+     | None -> aliases))
+         rels (List.length rels,Int.Map.empty))
+
+let make_alias_map env =
+  (* We compute the chain of aliases for each var and rel *)
+  let var_aliases = compute_var_aliases (named_context env) in
+  let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in
+  (var_aliases,rel_aliases)
+
+let lift_aliases n (var_aliases,rel_aliases as aliases) =
+  if Int.equal n 0 then aliases else
+  (var_aliases,
+   Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (lift n) l))
+     rel_aliases Int.Map.empty)
+
+let get_alias_chain_of aliases x = match kind_of_term x with
+  | Rel n -> (try Int.Map.find n (snd aliases) with Not_found -> [])
+  | Var id -> (try Id.Map.find id (fst aliases) with Not_found -> [])
+  | _ -> []
+
+let normalize_alias_opt aliases x =
+  match get_alias_chain_of aliases x with
+  | []  -> None
+  | a::_ when isRel a || isVar a -> Some a
+  | [_] -> None
+  | _::a::_ -> Some a
+
+let normalize_alias aliases x =
+  match normalize_alias_opt aliases x with
+  | Some a -> a
+  | None -> x
+
+let normalize_alias_var var_aliases id =
+  destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id))
+
+let extend_alias (_,b,_) (var_aliases,rel_aliases) =
+  let rel_aliases =
+    Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l))
+      rel_aliases Int.Map.empty in
+  let rel_aliases =
+    match b with
+    | Some t ->
+        (match kind_of_term t with
+        | Var id' ->
+            let aliases_of_binder =
+              try Id.Map.find id' var_aliases with Not_found -> [] in
+            Int.Map.add 1 (aliases_of_binder@[t]) rel_aliases
+        | Rel p ->
+            let aliases_of_binder =
+              try Int.Map.find (p+1) rel_aliases with Not_found -> [] in
+            Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
+        | _ ->
+            Int.Map.add 1 [lift 1 t] rel_aliases)
+    | None -> rel_aliases in
+  (var_aliases, rel_aliases)
+
+let expand_alias_once aliases x =
+  match get_alias_chain_of aliases x with
+  | []  -> None
+  | l -> Some (List.last l)
+
+let expansions_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> [x]
+  | a::_ as l when isRel a || isVar a -> x :: List.rev l
+  | _::l -> x :: List.rev l
+
+let expansion_of_var aliases x =
+  match get_alias_chain_of aliases x with
+  | [] -> x
+  | a::_ -> a
+
+let rec expand_vars_in_term_using aliases t = match kind_of_term t with
+  | Rel _ | Var _ ->
+      normalize_alias aliases t
+  | _ ->
+      map_constr_with_full_binders
+        extend_alias expand_vars_in_term_using aliases t
+
+let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
+
+let free_vars_and_rels_up_alias_expansion aliases c =
+  let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in
+  let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in
+  let is_in_cache depth = function
+    | Rel n -> Int.Set.mem (n-depth) !cache_rel
+    | Var s -> Id.Set.mem s !cache_var
+    | _ -> false in
+  let put_in_cache depth = function
+    | Rel n -> cache_rel := Int.Set.add (n-depth) !cache_rel
+    | Var s -> cache_var := Id.Set.add s !cache_var
+    | _ -> () in
+  let rec frec (aliases,depth) c =
+    match kind_of_term c with
+    | Rel _ | Var _ as ck ->
+      if is_in_cache depth ck then () else begin
+      put_in_cache depth ck;
+      let c = expansion_of_var aliases c in
+        match kind_of_term c with
+        | Var id -> acc2 := Id.Set.add id !acc2
+        | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1
+        | _ -> frec (aliases,depth) c end
+    | Const _ | Ind _ | Construct _ ->
+        acc2 := Id.Set.union (vars_of_global (Global.env()) c) !acc2
+    | _ ->
+        iter_constr_with_full_binders
+          (fun d (aliases,depth) -> (extend_alias d aliases,depth+1))
+          frec (aliases,depth) c
+  in
+  frec (aliases,0) c;
+  (!acc1,!acc2)
+
+(********************************)
+(* Managing pattern-unification *)
+(********************************)
+
+let rec expand_and_check_vars aliases = function
+  | [] -> []
+  | a::l when isRel a || isVar a ->
+      let a = expansion_of_var aliases a in
+      if isRel a || isVar a then a :: expand_and_check_vars aliases l
+      else raise Exit
+  | _ ->
+      raise Exit
+
+module Constrhash = Hashtbl.Make
+  (struct type t = constr
+          let equal = Term.eq_constr
+          let hash = hash_constr
+   end)
+
+let constr_list_distinct l =
+  let visited = Constrhash.create 23 in
+  let rec loop = function
+    | h::t ->
+        if Constrhash.mem visited h then false
+        else (Constrhash.add visited h h; loop t)
+    | [] -> true
+  in loop l
+
+let get_actual_deps aliases l t =
+  if occur_meta_or_existential t then
+    (* Probably no restrictions on allowed vars in presence of evars *)
+    l
+  else
+    (* Probably strong restrictions coming from t being evar-closed *)
+    let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
+    List.filter (fun c ->
+      match kind_of_term c with
+      | Var id -> Id.Set.mem id fv_ids
+      | Rel n -> Int.Set.mem n fv_rels
+      | _ -> assert false) l
+
+let remove_instance_local_defs evd evk args =
+  let evi = Evd.find evd evk in
+  let len = Array.length args in
+  let rec aux sign i = match sign with
+  | [] ->
+    let () = assert (i = len) in []
+  | (_, None, _) :: sign ->
+    let () = assert (i < len) in
+    (Array.unsafe_get args i) :: aux sign (succ i)
+  | (_, Some _, _) :: sign ->
+    aux sign (succ i)
+  in
+  aux (evar_filtered_context evi) 0
+
+(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
+
+let find_unification_pattern_args env l t =
+  if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then
+    let aliases = make_alias_map env in
+    match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
+    | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_meta env nb m l t =
+  (* Variables from context and rels > nb are implicitly all there *)
+  (* so we need to be a rel <= nb *)
+  if List.for_all (fun x -> isRel x && destRel x <= nb) l then
+    match find_unification_pattern_args env l t with
+    | Some _ as x when not (dependent (mkMeta m) t) -> x
+    | _ -> None
+  else
+    None
+
+let is_unification_pattern_evar env evd (evk,args) l t =
+  if List.for_all (fun x -> isRel x || isVar x) l 
+    && noccur_evar env evd evk t
+  then
+    let args = remove_instance_local_defs evd evk args in
+    let n = List.length args in
+      match find_unification_pattern_args env (args @ l) t with
+      | Some l -> Some (List.skipn n l)
+      | _ -> None
+  else None
+
+let is_unification_pattern_pure_evar env evd (evk,args) t =
+  let is_ev = is_unification_pattern_evar env evd (evk,args) [] t in
+  match is_ev with
+  | None -> false
+  | Some _ -> true
+
+let is_unification_pattern (env,nb) evd f l t =
+  match kind_of_term f with
+  | Meta m -> is_unification_pattern_meta env nb m l t
+  | Evar ev -> is_unification_pattern_evar env evd ev l t
+  | _ -> None
+
+(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
+   (pattern unification). It is assumed that l is made of rel's that
+   are distinct and not bound to aliases. *)
+(* It is also assumed that c does not contain metas because metas
+   *implicitly* depend on Vars but lambda abstraction will not reflect this
+   dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
+   return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
+let solve_pattern_eqn env l c =
+  let c' = List.fold_right (fun a c ->
+    let c' = subst_term (lift 1 a) (lift 1 c) in
+    match kind_of_term a with
+      (* Rem: if [a] links to a let-in, do as if it were an assumption *)
+      | Rel n ->
+          let d = map_rel_declaration (lift n) (lookup_rel n env) in
+          mkLambda_or_LetIn d c'
+      | Var id ->
+          let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
+      | _ -> assert false)
+    l c in
+  (* Warning: we may miss some opportunity to eta-reduce more since c'
+     is not in normal form *)
+  whd_eta c'
+
+(*****************************************)
+(* Refining/solving unification problems *)
+(*****************************************)
+
+(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
+ * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
+ * If a variable and an alias of it are bound to the same instance, we skip
+ * the alias (we just use eq_constr -- instead of conv --, since anyway,
+ * only instances that are variables -- or evars -- are later considered;
+ * morever, we can bet that similar instances came at some time from
+ * the very same substitution. The removal of aliased duplicates is
+ * useful to ensure the uniqueness of a projection.
+*)
+
+let make_projectable_subst aliases sigma evi args =
+  let sign = evar_filtered_context evi in
+  let evar_aliases = compute_var_aliases sign in
+  let (_,full_subst,cstr_subst) =
+    List.fold_right
+      (fun (id,b,c) (args,all,cstrs) ->
+        match b,args with
+        | None, a::rest ->
+            let a = whd_evar sigma a in
+            let cstrs =
+              let a',args = decompose_app_vect a in
+              match kind_of_term a' with
+              | Construct cstr ->
+                  let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in
+                  Constrmap.add (fst cstr) ((args,id)::l) cstrs
+              | _ -> cstrs in
+            (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
+        | Some c, a::rest ->
+            let a = whd_evar sigma a in
+            (match kind_of_term c with
+            | Var id' ->
+                let idc = normalize_alias_var evar_aliases id' in
+                let sub = try Id.Map.find idc all with Not_found -> [] in
+                if List.exists (fun (c,_,_) -> Term.eq_constr a c) sub then
+                  (rest,all,cstrs)
+                else
+                  (rest,
+                   Id.Map.add idc ((a,normalize_alias_opt aliases a,id)::sub) all,
+                   cstrs)
+            | _ ->
+                (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs))
+        | _ -> anomaly (Pp.str "Instance does not match its signature"))
+      sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in
+  (full_subst,cstr_subst)
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet
+ * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq.
+ * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)]
+ * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds.
+ *)
+
+let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env =
+  let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
+  let t_in_env = whd_evar evd t_in_env in
+  let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in
+  let ctxt = named_context_of_val sign in
+  let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in
+  let evar_in_sign = mkEvar (fst (destEvar evar_in_env), inst_in_sign) in
+  (evd,whd_evar evd evar_in_sign)
+
+(* We have x1..xq |- ?e1 : Ï„ and had to solve something like
+ * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some
+ * ?e2[v1..vn], hence flexible. We had to go through k binders and now
+ * virtually have x1..xq, y1'..yk' | ?e1' : Ï„' and the equation
+ * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
+ * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends Σ with the declaration
+ * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension
+ * of the context of e1 so that e1 can be instantiated by
+ * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']),
+ * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation
+ * ?e1'[u1..uq y1..yk] = c can be registered
+ *
+ * Note that, because invert_definition does not check types, we need to
+ * guess the types of y1'..yn' by inverting the types of y1..yn along the
+ * substitution u1..uq.
+ *)
+
+let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
+  let evi1 = Evd.find_undefined evd evk1 in
+  let env1,rel_sign = env_rel_context_chop k env in
+  let sign1 = evar_hyps evi1 in
+  let filter1 = evar_filter evi1 in
+  let src = subterm_source evk1 evi1.evar_source in
+  let ids1 = List.map pi1 (named_context_of_val sign1) in
+  let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in
+  let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
+    List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
+      let id = next_name_away na avoid in
+      let evd,t_in_sign =
+        let s = Retyping.get_sort_of env evd t_in_env in
+        let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in
+        define_evar_from_virtual_equation define_fun env evd src t_in_env
+          ty_t_in_sign sign filter inst_in_env in
+      let evd,b_in_sign = match b with
+      | None -> evd,None
+      | Some b ->
+          let evd,b = define_evar_from_virtual_equation define_fun env evd src b
+            t_in_sign sign filter inst_in_env in
+          evd,Some b in
+      (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter,
+       (mkRel 1)::(List.map (lift 1) inst_in_env),
+       (mkRel 1)::(List.map (lift 1) inst_in_sign),
+       push_rel d env,evd,id::avoid))
+      rel_sign
+      (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1)
+  in
+  let evd,ev2ty_in_sign =
+    let s = Retyping.get_sort_of env evd ty_in_env in
+    let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in
+    define_evar_from_virtual_equation define_fun env evd src ty_in_env
+      ty_t_in_sign sign2 filter2 inst2_in_env in
+  let evd,ev2_in_sign =
+    new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
+  let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
+  (evd, ev2_in_sign, ev2_in_env)
+
+let restrict_upon_filter evd evk p args =
+  let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in
+  let len = Array.length args in
+  Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i))
+
+(***************)
+(* Unification *)
+
+(* Inverting constructors in instances (common when inferring type of match) *)
+
+let find_projectable_constructor env evd cstr k args cstr_subst =
+  try
+    let l = Constrmap.find cstr cstr_subst in
+    let args = Array.map (lift (-k)) args in
+    let l =
+      List.filter (fun (args',id) ->
+        (* is_conv is maybe too strong (and source of useless computation) *)
+        (* (at least expansion of aliases is needed) *)
+        Array.for_all2 (is_conv env evd) args args') l in
+    List.map snd l
+  with Not_found ->
+    []
+
+(* [find_projectable_vars env sigma y subst] finds all vars of [subst]
+ * that project on [y]. It is able to find solutions to the following
+ * two kinds of problems:
+ *
+ * - ?n[...;x:=y;...] = y
+ * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable
+ *
+ * (see test-suite/success/Fixpoint.v for an example of application of
+ * the second kind of problem).
+ *
+ * The seek for [y] is up to variable aliasing.  In case of solutions that
+ * differ only up to aliasing, the binding that requires the less
+ * steps of alias reduction is kept. At the end, only one solution up
+ * to aliasing is kept.
+ *
+ * [find_projectable_vars] also unifies against evars that themselves mention
+ * [y] and recursively.
+ *
+ * In short, the following situations give the following solutions:
+ *
+ * problem                        evar ctxt   soluce remark
+ * z1; z2:=z1 |- ?ev[z1;z2] = z1  y1:A; y2:=y1  y1  \ thanks to defs kept in
+ * z1; z2:=z1 |- ?ev[z1;z2] = z2  y1:A; y2:=y1  y2  / subst and preferring =
+ * z1; z2:=z1 |- ?ev[z1]    = z2  y1:A          y1  thanks to expand_var
+ * z1; z2:=z1 |- ?ev[z2]    = z1  y1:A          y1  thanks to expand_var
+ * z3         |- ?ev[z3;z3] = z3  y1:A; y2:=y1  y2  see make_projectable_subst
+ *
+ * Remark: [find_projectable_vars] assumes that identical instances of
+ * variables in the same set of aliased variables are already removed (see
+ * [make_projectable_subst])
+ *)
+
+type evar_projection =
+| ProjectVar
+| ProjectEvar of existential * evar_info * Id.t * evar_projection
+
+exception NotUnique
+exception NotUniqueInType of (Id.t * evar_projection) list
+
+let rec assoc_up_to_alias sigma aliases y yc = function
+  | [] -> raise Not_found
+  | (c,cc,id)::l ->
+      let c' = whd_evar sigma c in
+      if Term.eq_constr y c' then id
+      else
+        match l with
+        | _ :: _ -> assoc_up_to_alias sigma aliases y yc l
+        | [] ->
+          (* Last chance, we reason up to alias conversion *)
+          match (if c == c' then cc else normalize_alias_opt aliases c') with
+          | Some cc when Term.eq_constr yc cc -> id
+          | _ -> if Term.eq_constr yc c then id else raise Not_found
+
+let rec find_projectable_vars with_evars aliases sigma y subst =
+  let yc = normalize_alias aliases y in
+  let is_projectable idc idcl subst' =
+    (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *)
+    try
+      let id = assoc_up_to_alias sigma aliases y yc idcl in
+      (id,ProjectVar)::subst'
+    with Not_found ->
+    (* Then test if [idc] is (indirectly) bound in [subst] to some evar *)
+    (* projectable on [y] *)
+      if with_evars then
+        let idcl' = List.filter (fun (c,_,id) -> isEvar c) idcl in
+        match idcl' with
+        | [c,_,id] ->
+          begin
+            let (evk,argsv as t) = destEvar c in
+            let evi = Evd.find sigma evk in
+            let subst,_ = make_projectable_subst aliases sigma evi argsv in
+            let l = find_projectable_vars with_evars aliases sigma y subst in
+            match l with
+            | [id',p] -> (id,ProjectEvar (t,evi,id',p))::subst'
+            | _ -> subst'
+          end
+        | [] -> subst'
+        | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance")
+      else
+        subst' in
+  Id.Map.fold is_projectable subst []
+
+(* [filter_solution] checks if one and only one possible projection exists
+ * among a set of solutions to a projection problem *)
+
+let filter_solution = function
+  | [] -> raise Not_found
+  | (id,p)::_::_ -> raise NotUnique
+  | [id,p] -> (mkVar id, p)
+
+let project_with_effects aliases sigma effects t subst =
+  let c, p =
+    filter_solution (find_projectable_vars false aliases sigma t subst) in
+  effects := p :: !effects;
+  c
+
+let rec find_solution_type evarenv = function
+  | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
+  | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
+  | (id,ProjectEvar _)::l -> find_solution_type evarenv l
+  | [] -> assert false
+
+(* In case the solution to a projection problem requires the instantiation of
+ * subsidiary evars, [do_projection_effects] performs them; it
+ * also try to instantiate the type of those subsidiary evars if their
+ * type is an evar too.
+ *
+ * Note: typing creates new evar problems, which induces a recursive dependency
+ * with [define]. To avoid a too large set of recursive functions, we
+ * pass [define] to [do_projection_effects] as a parameter.
+ *)
+
+let rec do_projection_effects define_fun env ty evd = function
+  | ProjectVar -> evd
+  | ProjectEvar ((evk,argsv),evi,id,p) ->
+      let evd = Evd.define evk (mkVar id) evd in
+      (* TODO: simplify constraints involving evk *)
+      let evd = do_projection_effects define_fun env ty evd p in
+      let ty = whd_betadeltaiota env evd (Lazy.force ty) in
+      if not (isSort ty) then
+        (* Don't try to instantiate if a sort because if evar_concl is an
+           evar it may commit to a univ level which is not the right
+           one (however, regarding coercions, because t is obtained by
+           unif, we know that no coercion can be inserted) *)
+        let subst = make_pure_subst evi argsv in
+        let ty' = replace_vars subst evi.evar_concl in
+        let ty' = whd_evar evd ty' in
+        if isEvar ty' then define_fun env evd (Some false) (destEvar ty') ty else evd
+      else
+        evd
+
+(* Assuming Σ; Γ, y1..yk |- c, [invert_arg_from_subst Γ k Σ [x1:=u1..xn:=un] c]
+ * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid.
+ * The strategy is to imitate the structure of c and then to invert
+ * the variables of c (i.e. rels or vars of Γ) using the algorithm
+ * implemented by project_with_effects/find_projectable_vars.
+ * It returns either a unique solution or says whether 0 or more than
+ * 1 solutions is found.
+ *
+ * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
+ * Postcondition: if φ(x1..xn) is returned then
+ *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
+ *
+ * The effects correspond to evars instantiated while trying to project.
+ *
+ * [invert_arg_from_subst] is used on instances of evars. Since the
+ * evars are flexible, these instances are potentially erasable. This
+ * is why we don't investigate whether evars in the instances of evars
+ * are unifiable, to the contrary of [invert_definition].
+ *)
+
+type projectibility_kind =
+  | NoUniqueProjection
+  | UniqueProjection of constr * evar_projection list
+
+type projectibility_status =
+  | CannotInvert
+  | Invertible of projectibility_kind
+
+let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
+  let effects = ref [] in
+  let rec aux k t =
+    let t = whd_evar evd t in
+    match kind_of_term t with
+    | Rel i when i>k0+k -> aux' k (mkRel (i-k))
+    | Var id -> aux' k t
+    | _ -> map_constr_with_binders succ aux k t
+  and aux' k t =
+    try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders
+    with Not_found ->
+      match expand_alias_once aliases t with
+      | None -> raise Not_found
+      | Some c -> aux k c in
+  try
+    let c = aux 0 c_in_env_extended_with_k_binders in
+    Invertible (UniqueProjection (c,!effects))
+  with
+    | Not_found -> CannotInvert
+    | NotUnique -> Invertible NoUniqueProjection
+
+let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
+  let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in
+  match res with
+  | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c)
+      ->
+      CannotInvert
+  | _ ->
+      res
+
+exception NotEnoughInformationToInvert
+
+let extract_unique_projection = function
+| Invertible (UniqueProjection (c,_)) -> c
+| _ ->
+    (* For instance, there are evars with non-invertible arguments and *)
+    (* we cannot arbitrarily restrict these evars before knowing if there *)
+    (* will really be used; it can also be due to some argument *)
+    (* (typically a rel) that is not inversible and that cannot be *)
+    (* inverted either because it is needed for typing the conclusion *)
+    (* of the evar to project *)
+  raise NotEnoughInformationToInvert
+
+let extract_candidates sols =
+  try
+    UpdateWith
+      (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols)
+  with Exit ->
+    NoUpdate
+
+let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
+  let evi = Evd.find_undefined evd evk in
+  let subst,_ = make_projectable_subst aliases evd evi argsv in
+  let invert arg =
+    let p = invert_arg fullenv evd aliases k evk subst arg in
+    extract_unique_projection p
+  in
+  Array.map invert args'
+
+(* Redefines an evar with a smaller context (i.e. it may depend on less
+ * variables) such that c becomes closed.
+ * Example: in "fun (x:?1) (y:list ?2[x]) => x = y :> ?3[x,y] /\ x = nil bool"
+ * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
+ * ?1 <-- list ?2     pb: ?2 may depend on x, but not ?1.
+ * What we do is that ?2 is defined by a new evar ?4 whose context will be
+ * a prefix of ?2's env, included in ?1's env.
+ *
+ * If "hyps |- ?e : T" and "filter" selects a subset hyps' of hyps then
+ * [do_restrict_hyps evd ?e filter] sets ?e:=?e'[hyps'] and returns ?e'
+ * such that "hyps' |- ?e : T"
+ *)
+
+let set_of_evctx l =
+  List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l
+
+let filter_effective_candidates evi filter candidates =
+  match filter with
+  | None -> candidates
+  | Some filter ->
+      let ids = set_of_evctx (Filter.filter_list filter (evar_context evi)) in
+      List.filter (fun a -> Id.Set.subset (collect_vars a) ids) candidates
+
+let filter_candidates evd evk filter candidates_update =
+  let evi = Evd.find_undefined evd evk in
+  let candidates = match candidates_update with
+  | NoUpdate -> evi.evar_candidates
+  | UpdateWith c -> Some c
+  in
+  match candidates with
+  | None -> NoUpdate
+  | Some l ->
+      let l' = filter_effective_candidates evi filter l in
+      if List.length l = List.length l' && candidates_update = NoUpdate then
+        NoUpdate
+      else
+        UpdateWith l'
+
+let closure_of_filter evd evk = function
+  | None -> None
+  | Some filter ->
+  let evi = Evd.find_undefined evd evk in
+  let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in
+  let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in
+  let newfilter = Filter.map_along test filter (evar_context evi) in
+  if Filter.equal newfilter (evar_filter evi) then None else Some newfilter
+
+let restrict_hyps evd evk filter candidates =
+    (* What to do with dependencies?
+       Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y.
+       - If y is in a non-erasable position in C(x,y) (i.e. it is not below an
+         occurrence of x in the hnf of C), then z should be removed too.
+       - If y is in a non-erasable position in T(x,y,z) then the problem is
+         unsolvable.
+       Computing whether y is erasable or not may be costly and the
+       interest for this early detection in practice is not obvious. We let
+       it for future work. In any case, thanks to the use of filters, the whole
+       (unrestricted) context remains consistent. *)
+    let candidates = filter_candidates evd evk (Some filter) candidates in
+    let typablefilter = closure_of_filter evd evk (Some filter) in
+    (typablefilter,candidates)
+
+exception EvarSolvedWhileRestricting of evar_map * constr
+
+let do_restrict_hyps evd (evk,args as ev) filter candidates =
+  let filter,candidates = match filter with
+  | None -> None,candidates
+  | Some filter -> restrict_hyps evd evk filter candidates in
+  match candidates,filter with
+  | UpdateWith [], _ -> error "Not solvable."
+  | UpdateWith [nc],_ ->
+      let evd = Evd.define evk nc evd in
+      raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev)))
+  | NoUpdate, None -> evd,ev
+  | _ -> restrict_applied_evar evd ev filter candidates
+
+(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *)
+(* ?e is assumed to have no candidates *)
+
+let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs =
+  let rhs = expand_vars_in_term env rhs in
+  let filter =
+    restrict_upon_filter evd evk
+      (* Keep only variables that occur in rhs *)
+      (* This is not safe: is the variable is a local def, its body *)
+      (* may contain references to variables that are removed, leading to *)
+      (* an ill-formed context. We would actually need a notion of filter *)
+      (* that says that the body is hidden. Note that expand_vars_in_term *)
+      (* expands only rels and vars aliases, not rels or vars bound to an *)
+      (* arbitrary complex term *)
+      (fun a -> not (isRel a || isVar a)
+                || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols)
+      argsv in
+  let filter = closure_of_filter evd evk filter in
+  let candidates = extract_candidates sols in
+  match candidates with
+  | NoUpdate ->
+    (* We made an approximation by not expanding a local definition *)
+    let evd,ev = restrict_applied_evar evd ev filter NoUpdate in
+    let pb = (pbty,env,mkEvar ev,rhs) in
+    add_conv_oriented_pb pb evd
+  | UpdateWith c ->
+    restrict_evar evd evk filter (UpdateWith c)
+
+(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic
+ * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
+ * - if there are at most one φj for each vj s.t. vj = φj(u1..un),
+ *   we first restrict ?e2 to the subset v_k1..v_kq of the vj that are
+ *   inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)]
+ *   (this is a case of pattern-unification)
+ * - symmetrically if there are at most one ψj for each uj s.t.
+ *   uj = ψj(v1..vp),
+ * - otherwise, each position i s.t. ui does not occur in v1..vp has to
+ *   be restricted and similarly for the vi, and we leave the equation
+ *   as an open equation (performed by [postpone_evar])
+ *
+ * Warning: the notion of unique φj is relative to some given class
+ * of unification problems
+ *
+ * Note: argument f is the function used to instantiate evars.
+ *)
+
+let are_canonical_instances args1 args2 env =
+  let n1 = Array.length args1 in
+  let n2 = Array.length args2 in
+  let rec aux n = function
+    | (id,_,c)::sign
+        when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
+        aux (n+1) sign
+    | [] ->
+        let rec aux2 n =
+          Int.equal n n1 ||
+          (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
+        in aux2 n
+    | _ -> false in
+  Int.equal n1 n2 && aux 0 (named_context env)
+
+let filter_compatible_candidates conv_algo env evd evi args rhs c =
+  let c' = instantiate_evar_array evi c args in
+  match conv_algo env evd Reduction.CONV rhs c' with
+  | Success evd -> Some (c,evd)
+  | UnifFailure _ -> None
+
+(* [restrict_candidates ... filter ev1 ev2] restricts the candidates
+   of ev1, removing those not compatible with the filter, as well as
+   those not convertible to some candidate of ev2 *)
+
+exception DoesNotPreserveCandidateRestriction
+
+let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) =
+  let evi1 = Evd.find evd evk1 in
+  let evi2 = Evd.find evd evk2 in
+  match evi1.evar_candidates, evi2.evar_candidates with
+  | _, None -> filter_candidates evd evk1 filter1 NoUpdate
+  | None, Some _ -> raise DoesNotPreserveCandidateRestriction
+  | Some l1, Some l2 ->
+      let l1 = filter_effective_candidates evi1 filter1 l1 in
+      let l1' = List.filter (fun c1 ->
+        let c1' = instantiate_evar_array evi1 c1 argsv1 in
+        let filter c2 =
+          let compatibility = filter_compatible_candidates conv_algo env evd evi2 argsv2 c1' c2 in
+          match compatibility with
+          | None -> false
+          | Some _ -> true
+        in
+        let filtered = List.filter filter l2 in
+        match filtered with [] -> false | _ -> true) l1 in
+      if Int.equal (List.length l1) (List.length l1') then NoUpdate
+      else UpdateWith l1'
+
+exception CannotProject of evar_map * existential
+
+(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U.
+   Can ?n be instantiated by a term u depending essentially on xi such that the
+   FV(u[x1:=t1..xn:=tn]) are in the set U?
+   - If ti is a variable, it has to be in U.
+   - If ti is a constructor, its parameters cannot be erased even if u
+     matches on it, so we have to discard ti if the parameters
+     contain variables not in U.
+   - If ti is rigid, we have to discard it if it contains variables in U.
+
+  Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...]
+  then, occurrences of ?m in the ti can be seen, like variables, as occurrences
+  of subterms to eventually discard so as to be allowed to keep ti.
+*)
+
+let rec is_constrainable_in top k (ev,(fv_rels,fv_ids) as g) t =
+  let f,args = decompose_app_vect t in
+  match kind_of_term f with
+  | Construct ((ind,_),u) ->
+    let n = Inductiveops.inductive_nparams ind in
+    if n > Array.length args then true (* We don't try to be more clever *)
+    else
+      let params = fst (Array.chop n args) in
+      Array.for_all (is_constrainable_in false k g) params
+  | Ind _ -> Array.for_all (is_constrainable_in false k g) args
+  | Prod (_,t1,t2) -> is_constrainable_in false k g t1 && is_constrainable_in false k g t2
+  | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*)
+  | Var id -> Id.Set.mem id fv_ids
+  | Rel n -> n <= k || Int.Set.mem n fv_rels
+  | Sort _ -> true
+  | _ -> (* We don't try to be more clever *) true
+
+let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t =
+  let t = expansion_of_var aliases t in
+  match kind_of_term t with
+  | Var id -> Id.Set.mem id fv_ids
+  | Rel n -> n <= k || Int.Set.mem n fv_rels
+  | _ -> is_constrainable_in true k (ev,fvs) t
+
+let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)=
+  let filter1 =
+    restrict_upon_filter evd evk1 (noccur_evar env evd evk2) argsv1
+  in
+  let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
+  let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in
+  let filter2 =
+    restrict_upon_filter evd evk2 (noccur_evar env evd evk1) argsv2
+  in
+  let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in
+  let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in
+  evd,ev1,ev2
+
+exception EvarSolvedOnTheFly of evar_map * constr
+
+(* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on
+   the common domain of definition *)
+let project_evar_on_evar g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) =
+  (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *)
+  let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in
+  let filter1 = restrict_upon_filter evd evk1
+    (has_constrainable_free_vars evd aliases k2 evk2 fvs2)
+    argsv1 in
+  let candidates1 =
+    try restrict_candidates g env evd filter1 ev1 ev2
+    with DoesNotPreserveCandidateRestriction ->
+      let evd,ev1' = do_restrict_hyps evd ev1 filter1 NoUpdate in
+      raise (CannotProject (evd,ev1')) in
+  let evd,(evk1',args1 as ev1') =
+    try do_restrict_hyps evd ev1 filter1 candidates1
+    with EvarSolvedWhileRestricting (evd,ev1) ->
+      raise (EvarSolvedOnTheFly (evd,ev1)) in
+  (* Only try pruning on variable substitutions, postpone otherwise. *)
+  (* Rules out non-linear instances. *)
+  if Option.is_empty pbty && is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then
+    try
+      evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1)
+    with NotEnoughInformationToInvert ->
+      raise (CannotProject (evd,ev1'))
+  else
+    raise (CannotProject (evd,ev1'))
+
+exception IllTypedInstance of env * types * types
+
+let check_evar_instance evd evk1 body conv_algo =
+  let evi = Evd.find evd evk1 in
+  let evenv = evar_env evi in
+  (* FIXME: The body might be ill-typed when this is called from w_merge *)
+  (* This happens in practice, cf MathClasses build failure on 2013-3-15 *)
+  let ty =
+    try Retyping.get_type_of ~lax:true evenv evd body
+    with Retyping.RetypeError _ -> error "Ill-typed evar instance"
+  in
+  match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with
+  | Success evd -> evd
+  | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl))
+
+let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) =
+  try
+    let evd,body = project_evar_on_evar g env evd aliases 0 pbty ev1 ev2 in
+    let evd' = Evd.define evk2 body evd in
+      check_evar_instance evd' evk2 body g
+  with EvarSolvedOnTheFly (evd,c) ->
+    f env evd pbty ev2 c
+
+let opp_problem = function None -> None | Some b -> Some (not b)
+
+let preferred_orientation evd evk1 evk2 =
+  let _,src1 = (Evd.find_undefined evd evk1).evar_source in
+  let _,src2 = (Evd.find_undefined evd evk2).evar_source in
+  (* This is a heuristic useful for program to work *)
+  match src1,src2 with
+  | Evar_kinds.QuestionMark _, _ -> true
+  | _,Evar_kinds.QuestionMark _ -> false
+  | _ -> true
+
+let solve_evar_evar_aux f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) =
+  let aliases = make_alias_map env in
+  if preferred_orientation evd evk1 evk2 then
+    try solve_evar_evar_l2r f g env evd aliases (opp_problem pbty) ev2 ev1
+    with CannotProject (evd,ev2) ->
+    try solve_evar_evar_l2r f g env evd aliases pbty ev1 ev2
+    with CannotProject (evd,ev1) ->
+    add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd
+  else
+    try solve_evar_evar_l2r f g env evd aliases pbty ev1 ev2
+    with CannotProject (evd,ev1) ->
+    try solve_evar_evar_l2r f g env evd aliases (opp_problem pbty) ev2 ev1
+    with CannotProject (evd,ev2) ->
+    add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd
+
+let solve_evar_evar ?(force=false) f g env evd pbty ev1 ev2 =
+  let (evd,(evk1,args1 as ev1),(evk2,args2 as ev2)),pbty =
+    (* If an evar occurs in the instance of the other evar and the
+       use of an heuristic is forced, we restrict *)
+    if force then ensure_evar_independent g env evd ev1 ev2, None
+    else (evd,ev1,ev2),pbty in
+  let evi = Evd.find evd evk1 in
+  let evd =
+    try 
+      (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j.
+	 The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *)
+      let evienv = Evd.evar_env evi in
+      let ctx1, i = Reduction.dest_arity evienv evi.evar_concl in
+      let evi2 = Evd.find evd evk2 in
+      let evi2env = Evd.evar_env evi2 in
+      let ctx2, j = Reduction.dest_arity evi2env evi2.evar_concl in
+      let ui, uj = univ_of_sort i, univ_of_sort j in
+	if i == j || Evd.check_eq evd ui uj
+	then (* Shortcut, i = j *) 
+	  evd
+	else if Evd.check_leq evd ui uj then
+          let t2 = it_mkProd_or_LetIn (mkSort i) ctx2 in
+          downcast evk2 t2 evd
+	else if Evd.check_leq evd uj ui then
+          let t1 = it_mkProd_or_LetIn (mkSort j) ctx1 in
+          downcast evk1 t1 evd
+	else
+	  let evd, k = Evd.new_sort_variable univ_flexible_alg evd in
+          let t1 = it_mkProd_or_LetIn (mkSort k) ctx1 in
+          let t2 = it_mkProd_or_LetIn (mkSort k) ctx2 in
+	  let evd = Evd.set_leq_sort env (Evd.set_leq_sort env evd k i) k j in
+          downcast evk2 t2 (downcast evk1 t1 evd)
+    with Reduction.NotArity -> 
+      evd in
+  solve_evar_evar_aux f g env evd pbty ev1 ev2
+
+type conv_fun =
+  env ->  evar_map -> conv_pb -> constr -> constr -> unification_result
+
+type conv_fun_bool =
+  env ->  evar_map -> conv_pb -> constr -> constr -> bool
+
+(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint
+ * definitions. We try to unify the ti with the ui pairwise. The pairs
+ * that don't unify are discarded (i.e. ?e is redefined so that it does not
+ * depend on these args). *)
+
+let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 =
+  let evdref = ref evd in
+  if Array.equal (e_eq_constr_univs evdref) argsv1 argsv2 then !evdref else
+  (* Filter and restrict if needed *)
+  let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in
+  let untypedfilter =
+    restrict_upon_filter evd evk
+      (fun (a1,a2) -> conv_algo env evd Reduction.CONV a1 a2) args in
+  let candidates = filter_candidates evd evk untypedfilter NoUpdate in
+  let filter = closure_of_filter evd evk untypedfilter in
+  let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in
+  if Evar.equal (fst ev1) evk && can_drop then (* No refinement *) evd else
+    (* either progress, or not allowed to drop, e.g. to preserve possibly *)
+    (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *)
+    (* if e can depend on x until ?y is not resolved, or, conversely, we *)
+    (* don't know if ?y has to be unified with ?y, until e is resolved *)
+  let argsv2 = restrict_instance evd evk filter argsv2 in
+  let ev2 = (fst ev1,argsv2) in
+  (* Leave a unification problem *)
+  add_conv_oriented_pb (pbty,env,mkEvar ev1,mkEvar ev2) evd
+
+(* If the evar can be instantiated by a finite set of candidates known
+   in advance, we check which of them apply *)
+
+exception NoCandidates
+exception IncompatibleCandidates
+
+let solve_candidates conv_algo env evd (evk,argsv) rhs =
+  let evi = Evd.find evd evk in
+  match evi.evar_candidates with
+  | None -> raise NoCandidates
+  | Some l ->
+      let l' =
+        List.map_filter
+          (filter_compatible_candidates conv_algo env evd evi argsv rhs) l in
+      match l' with
+      | [] -> raise IncompatibleCandidates
+      | [c,evd] ->
+          (* solve_candidates might have been called recursively in the mean *)
+          (* time and the evar been solved by the filtering process *)
+          if Evd.is_undefined evd evk then Evd.define evk c evd else evd
+      | l when List.length l < List.length l' ->
+          let candidates = List.map fst l in
+          restrict_evar evd evk None (UpdateWith candidates)
+      | l -> evd
+
+(* We try to instantiate the evar assuming the body won't depend
+ * on arguments that are not Rels or Vars, or appearing several times
+ * (i.e. we tackle a generalization of Miller-Pfenning patterns unification)
+ *
+ * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem
+ * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
+ *    where only Rel's and Var's are relevant in subst
+ * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is
+ *    not in the scope of ?ev. For instance, the problem
+ *    "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because
+ *    ?1 would be instantiated by y which is not in the scope of ?1.
+ * 4) We try to "project" the term if the process of imitation fails
+ *    and that only one projection is possible
+ *
+ * Note: we don't assume rhs in normal form, it may fail while it would
+ * have succeeded after some reductions.
+ *
+ * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] c]
+ * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
+ * Postcondition: if φ(x1..xn) is returned then
+ *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
+ *)
+
+exception NotInvertibleUsingOurAlgorithm of constr
+exception NotEnoughInformationToProgress of (Id.t * evar_projection) list
+exception NotEnoughInformationEvarEvar of constr
+exception OccurCheckIn of evar_map * constr
+exception MetaOccurInBodyInternal
+
+let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs =
+  let aliases = make_alias_map env in
+  let evdref = ref evd in
+  let progress = ref false in
+  let evi = Evd.find evd evk in
+  let subst,cstr_subst = make_projectable_subst aliases evd evi argsv in
+
+  (* Projection *)
+  let project_variable t =
+    (* Evar/Var problem: unifiable iff variable projectable from ev subst *)
+    try
+      let sols = find_projectable_vars true aliases !evdref t subst in
+      let c, p = match sols with
+        | [] -> raise Not_found
+        | [id,p] -> (mkVar id, p)
+        | (id,p)::_::_ ->
+            if choose then (mkVar id, p) else raise (NotUniqueInType sols)
+      in
+      let ty = lazy (Retyping.get_type_of env !evdref t) in
+      let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in
+      evdref := evd;
+      c
+    with
+      | Not_found -> raise (NotInvertibleUsingOurAlgorithm t)
+      | NotUniqueInType sols ->
+          if not !progress then
+            raise (NotEnoughInformationToProgress sols);
+          (* No unique projection but still restrict to where it is possible *)
+          (* materializing is necessary, but is restricting useful? *)
+          let ty = find_solution_type (evar_filtered_env evi) sols in
+          let ty' = instantiate_evar_array evi ty argsv in
+          let (evd,evar,(evk',argsv' as ev')) =
+            materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in
+          let ts = expansions_of_var aliases t in
+          let test c = isEvar c || List.mem_f Constr.equal c ts in
+          let filter = restrict_upon_filter evd evk test argsv' in
+          let filter = closure_of_filter evd evk' filter in
+          let candidates = extract_candidates sols in
+          let evd = match candidates with
+          | NoUpdate ->
+            let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in
+            Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd
+          | UpdateWith _ ->
+            restrict_evar evd evk' filter candidates
+          in
+          evdref := evd;
+          evar in
+
+  let rec imitate (env',k as envk) t =
+    let t = whd_evar !evdref t in
+    match kind_of_term t with
+    | Rel i when i>k ->
+        (match pi2 (Environ.lookup_rel (i-k) env') with
+        | None -> project_variable (mkRel (i-k))
+        | Some b ->
+          try project_variable (mkRel (i-k))
+          with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
+    | Var id ->
+        (match pi2 (Environ.lookup_named id env') with
+        | None -> project_variable t
+        | Some b ->
+          try project_variable t
+          with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
+    | LetIn (na,b,u,c) ->
+        imitate envk (subst1 b c)
+    | Evar (evk',args' as ev') ->
+        if Evar.equal evk evk' then raise (OccurCheckIn (evd,rhs));
+        (* Evar/Evar problem (but left evar is virtual) *)
+        let aliases = lift_aliases k aliases in
+        (try
+          let ev = (evk,Array.map (lift k) argsv) in
+          let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k None ev' ev in
+          evdref := evd;
+          body
+        with
+        | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t
+        | CannotProject (evd,ev') ->
+          if not !progress then
+            raise (NotEnoughInformationEvarEvar t);
+          (* Make the virtual left evar real *)
+          let ty = get_type_of env' evd t in
+          let (evd,evar'',ev'') =
+             materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in
+          (* materialize_evar may instantiate ev' by another evar; adjust it *)
+          let (evk',args' as ev') = normalize_evar evd ev' in
+          let evd =
+             (* Try to project (a restriction of) the left evar ... *)
+            try
+              let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 None ev'' ev' in
+              let evd = Evd.define evk' body evd in
+		check_evar_instance evd evk' body conv_algo
+            with
+            | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *)
+            | CannotProject (evd,ev'') ->
+              (* ... or postpone the problem *)
+              add_conv_oriented_pb (None,env',mkEvar ev'',mkEvar ev') evd in
+          evdref := evd;
+          evar'')
+    | _ ->
+        progress := true;
+        match
+          let c,args = decompose_app_vect t in
+          match kind_of_term c with
+          | Construct (cstr,u) when noccur_between 1 k t ->
+            (* This is common case when inferring the return clause of match *)
+            (* (currently rudimentary: we do not treat the case of multiple *)
+            (*  possible inversions; we do not treat overlap with a possible *)
+            (*  alternative inversion of the subterms of the constructor, etc)*)
+            (match find_projectable_constructor env evd cstr k args cstr_subst with
+             | _::_ as l -> Some (List.map mkVar l)
+             | _ -> None)
+          | _ -> None
+        with
+        | Some l ->
+            let ty = get_type_of env' !evdref t in
+            let candidates =
+              try
+                let t =
+                  map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+                    imitate envk t in
+                t::l
+              with e when Errors.noncritical e -> l in
+            (match candidates with
+            | [x] -> x
+            | _ ->
+              let (evd,evar'',ev'') =
+                materialize_evar (evar_define conv_algo ~choose) env' !evdref k ev ty in
+              evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates);
+              evar'')
+        | None ->
+          (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
+            map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
+              imitate envk t in
+
+  let _fast rhs = 
+    let filter_ctxt = evar_filtered_context evi in
+    let names = ref Idset.empty in
+    let rec is_id_subst ctxt s =
+       match ctxt, s with
+         | ((id, _, _) :: ctxt'), (c :: s') ->
+           names := Idset.add id !names;
+           isVarId id c && is_id_subst ctxt' s'
+         | [], [] -> true
+         | _ -> false in
+    is_id_subst filter_ctxt (Array.to_list argsv) &&
+    closed0 rhs &&
+    Idset.subset (collect_vars rhs) !names in
+  let rhs = whd_beta evd rhs (* heuristic *) in
+  let fast rhs = 
+    let filter_ctxt = evar_filtered_context evi in
+    let names = ref Idset.empty in
+    let rec is_id_subst ctxt s =
+      match ctxt, s with
+      | ((id, _, _) :: ctxt'), (c :: s') ->
+        names := Idset.add id !names;
+        isVarId id c && is_id_subst ctxt' s'
+      | [], [] -> true
+      | _ -> false 
+    in
+      is_id_subst filter_ctxt (Array.to_list argsv) &&
+      closed0 rhs &&
+      Idset.subset (collect_vars rhs) !names 
+  in
+  let body =
+    if fast rhs then nf_evar evd rhs
+    else imitate (env,0) rhs
+ in (!evdref,body)
+
+(* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
+ * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
+ * [define] tries to find an instance lhs such that
+ * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in
+ * context "hyps" and not referring to itself.
+ *)
+
+and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs =
+  match kind_of_term rhs with
+  | Evar (evk2,argsv2 as ev2) ->
+      if Evar.equal evk evk2 then
+        solve_refl ~can_drop:choose
+          (test_success conv_algo) env evd pbty evk argsv argsv2
+      else
+        solve_evar_evar ~force:choose
+          (evar_define conv_algo) conv_algo env evd pbty ev ev2
+  | _ ->
+  try solve_candidates conv_algo env evd ev rhs
+  with NoCandidates ->
+  try
+    let (evd',body) = invert_definition conv_algo choose env evd pbty ev rhs in
+    if occur_meta body then raise MetaOccurInBodyInternal;
+    (* invert_definition may have instantiate some evars of rhs with evk *)
+    (* so we recheck acyclicity *)
+    if occur_evar evk body then raise (OccurCheckIn (evd',body));
+    (* needed only if an inferred type *)
+    let evd', body = refresh_universes pbty env evd' body in
+(* Cannot strictly type instantiations since the unification algorithm
+ * does not unify applications from left to right.
+ * e.g problem f x == g y yields x==y and f==g (in that order)
+ * Another problem is that type variables are evars of type Type
+   let _ =
+      try
+        let env = evar_filtered_env evi in
+        let ty = evi.evar_concl in
+        Typing.check env evd' body ty
+      with e ->
+        msg_info
+          (str "Ill-typed evar instantiation: " ++ fnl() ++
+           pr_evar_map evd' ++ fnl() ++
+           str "----> " ++ int ev ++ str " := " ++
+           print_constr body);
+        raise e in*)
+    let evd' = check_evar_instance evd' evk body conv_algo in
+    Evd.define evk body evd'
+  with
+    | NotEnoughInformationToProgress sols ->
+        postpone_non_unique_projection env evd pbty ev sols rhs
+    | NotEnoughInformationEvarEvar t ->
+        add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd
+    | NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e ->
+        raise e
+    | OccurCheckIn (evd,rhs) ->
+        (* last chance: rhs actually reduces to ev *)
+        let c = whd_betadeltaiota env evd rhs in
+        match kind_of_term c with
+        | Evar (evk',argsv2) when Evar.equal evk evk' ->
+	    solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c')
+              env evd pbty evk argsv argsv2
+        | _ ->
+	    raise (OccurCheckIn (evd,rhs))
+
+(* This code (i.e. solve_pb, etc.) takes a unification
+ * problem, and tries to solve it. If it solves it, then it removes
+ * all the conversion problems, and re-runs conversion on each one, in
+ * the hopes that the new solution will aid in solving them.
+ *
+ * The kinds of problems it knows how to solve are those in which
+ * the usable arguments of an existential var are all themselves
+ * universal variables.
+ * The solution to this problem is to do renaming for the Var's,
+ * to make them match up with the Var's which are found in the
+ * hyps of the existential, to do a "pop" for each Rel which is
+ * not an argument of the existential, and a subst1 for each which
+ * is, again, with the corresponding variable. This is done by
+ * define
+ *
+ * Thus, we take the arguments of the existential which we are about
+ * to assign, and zip them with the identifiers in the hypotheses.
+ * Then, we process all the Var's in the arguments, and sort the
+ * Rel's into ascending order.  Then, we just march up, doing
+ * subst1's and pop's.
+ *
+ * NOTE: We can do this more efficiently for the relative arguments,
+ * by building a long substituend by hand, but this is a pain in the
+ * ass.
+ *)
+
+let status_changed lev (pbty,_,t1,t2) =
+  (try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) ||
+  (try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false)
+
+let reconsider_conv_pbs conv_algo evd =
+  let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
+  List.fold_left
+    (fun p (pbty,env,t1,t2 as x) ->
+       match p with
+       | Success evd ->
+           (match conv_algo env evd pbty t1 t2 with
+           | Success _ as x -> x
+           | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e)))
+       | UnifFailure _ as x -> x)
+    (Success evd)
+    pbs
+
+(* Tries to solve problem t1 = t2.
+ * Precondition: t1 is an uninstantiated evar
+ * Returns an optional list of evars that were instantiated, or None
+ * if the problem couldn't be solved. *)
+
+(* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
+let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) =
+  try
+    let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
+    let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in
+      reconsider_conv_pbs conv_algo evd
+  with
+    | NotInvertibleUsingOurAlgorithm t ->
+        UnifFailure (evd,NotClean (ev1,env,t))
+    | OccurCheckIn (evd,rhs) ->
+        UnifFailure (evd,OccurCheck (evk1,rhs))
+    | MetaOccurInBodyInternal ->
+        UnifFailure (evd,MetaOccurInBody evk1)
+    | IllTypedInstance (env,t,u) ->
+        UnifFailure (evd,InstanceNotSameType (evk1,env,t,u))
+    | IncompatibleCandidates ->
+        UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2))
+
diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli
new file mode 100644
index 00000000..21d97609
--- /dev/null
+++ b/pretyping/evarsolve.mli
@@ -0,0 +1,74 @@
+(************************************************************************)
+(*  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 Term
+open Evd
+open Environ
+
+type unification_result =
+  | Success of evar_map
+  | UnifFailure of evar_map * Pretype_errors.unification_error
+
+val is_success : unification_result -> bool
+
+(** Replace the vars and rels that are aliases to other vars and rels by 
+   their representative that is most ancient in the context *)
+val expand_vars_in_term : env -> constr -> constr
+
+(** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]),
+   possibly solving related unification problems, possibly leaving open
+   some problems that cannot be solved in a unique way (except if choose is
+   true); fails if the instance is not valid for the given [ev] *)
+
+type conv_fun =
+  env ->  evar_map -> conv_pb -> constr -> constr -> unification_result
+
+type conv_fun_bool =
+  env ->  evar_map -> conv_pb -> constr -> constr -> bool
+
+val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> 
+  bool option -> existential -> constr -> evar_map
+
+val refresh_universes : ?inferred:bool -> ?onlyalg:bool (* Only algebraic universes *) ->
+  bool option (* direction: true for levels lower than the existing levels *) ->
+  env -> evar_map -> types -> evar_map * types
+
+val solve_refl : ?can_drop:bool -> conv_fun_bool -> env ->  evar_map ->
+  bool option -> existential_key -> constr array -> constr array -> evar_map
+
+val solve_evar_evar : ?force:bool ->
+  (env -> evar_map -> bool option -> existential -> constr -> evar_map) ->
+  conv_fun ->
+  env ->  evar_map -> bool option -> existential -> existential -> evar_map
+
+val solve_simple_eqn : conv_fun -> ?choose:bool -> env ->  evar_map ->
+  bool option * existential * constr -> unification_result
+
+val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result
+
+val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
+  constr -> constr list option
+
+val is_unification_pattern : env * int -> evar_map -> constr -> constr list ->
+  constr -> constr list option
+
+val solve_pattern_eqn : env -> constr list -> constr -> constr
+
+val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool
+
+exception IllTypedInstance of env * types * types
+
+(* May raise IllTypedInstance if types are not convertible *)
+val check_evar_instance :
+  evar_map -> existential_key -> constr -> conv_fun -> evar_map
+
+val remove_instance_local_defs :
+  evar_map -> existential_key -> constr array -> constr list
+
+val get_type_of_refresh : 
+  ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 05b7e443..d286b98e 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -1,25 +1,48 @@
 (************************************************************************)
 (*  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 Pp
 open Names
-open Univ
 open Term
+open Vars
+open Context
 open Termops
 open Namegen
-open Sign
 open Pre_env
 open Environ
 open Evd
 open Reductionops
 open Pretype_errors
-open Retyping
+
+(** Combinators *)
+
+let evd_comb0 f evdref =
+  let (evd',x) = f !evdref in
+    evdref := evd';
+    x
+
+let evd_comb1 f evdref x =
+  let (evd',y) = f !evdref x in
+    evdref := evd';
+    y
+
+let evd_comb2 f evdref x y =
+  let (evd',z) = f !evdref x y in
+    evdref := evd';
+    z
+
+let e_new_global evdref x = 
+  evd_comb1 (Evd.fresh_global (Global.env())) evdref x
+
+let new_global evd x = 
+  Evd.fresh_global (Global.env()) evd x
 
 (****************************************************)
 (* Expanding/testing/exposing existential variables *)
@@ -37,48 +60,80 @@ let rec flush_and_check_evars sigma c =
        | Some c -> flush_and_check_evars sigma c)
   | _ -> map_constr (flush_and_check_evars sigma) c
 
-let nf_evar = Pretype_errors.nf_evar
-let j_nf_evar = Pretype_errors.j_nf_evar
-let jl_nf_evar = Pretype_errors.jl_nf_evar
-let jv_nf_evar = Pretype_errors.jv_nf_evar
-let tj_nf_evar = Pretype_errors.tj_nf_evar
+(* let nf_evar_key = Profile.declare_profile "nf_evar"  *)
+(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *)
+let nf_evar = Reductionops.nf_evar
+let j_nf_evar sigma j =
+  { uj_val = nf_evar sigma j.uj_val;
+    uj_type = nf_evar sigma j.uj_type }
+let j_nf_betaiotaevar sigma j =
+  { uj_val = nf_evar sigma j.uj_val;
+    uj_type = Reductionops.nf_betaiota sigma j.uj_type }
+let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
+let jv_nf_betaiotaevar sigma jl =
+  Array.map (j_nf_betaiotaevar sigma) jl
+let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
+let tj_nf_evar sigma {utj_val=v;utj_type=t} =
+  {utj_val=nf_evar sigma v;utj_type=t}
+
+let env_nf_evar sigma env =
+  process_rel_context
+    (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
+
+let env_nf_betaiotaevar sigma env =
+  process_rel_context
+    (fun d e ->
+      push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
+
+let nf_evars_universes evm =
+  Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) 
+    (Evd.universe_subst evm)
+    
+let nf_evars_and_universes evm =
+  let evm = Evd.nf_constraints evm in
+    evm, nf_evars_universes evm
+
+let e_nf_evars_and_universes evdref =
+  evdref := Evd.nf_constraints !evdref;
+  nf_evars_universes !evdref, Evd.universe_subst !evdref
+
+let nf_evar_map_universes evm =
+  let evm = Evd.nf_constraints evm in
+  let subst = Evd.universe_subst evm in
+    if Univ.LMap.is_empty subst then evm, nf_evar evm
+    else
+      let f = nf_evars_universes evm in
+	Evd.raw_map (fun _ -> map_evar_info f) evm, f
 
 let nf_named_context_evar sigma ctx =
-  Sign.map_named_context (Reductionops.nf_evar sigma) ctx
+  Context.map_named_context (nf_evar sigma) ctx
 
 let nf_rel_context_evar sigma ctx =
-  Sign.map_rel_context (Reductionops.nf_evar sigma) ctx
+  Context.map_rel_context (nf_evar sigma) ctx
 
 let nf_env_evar sigma env =
   let nc' = nf_named_context_evar sigma (Environ.named_context env) in
   let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in
     push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
 
-let nf_evar_info evc info =
-  { info with
-    evar_concl = Reductionops.nf_evar evc info.evar_concl;
-    evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps;
-    evar_body = match info.evar_body with
-      | Evar_empty -> Evar_empty
-      | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) }
-let nf_evars evm =
-  Evd.fold
-    (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
-    evm Evd.empty
-
-let nf_evars_undefined evm =
-  Evd.fold_undefined
-    (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
-    evm (defined_evars evm)
-
-let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd
-let nf_evar_map_undefined evd = Evd.evars_reset_evd (nf_evars_undefined evd) evd
+let nf_evar_info evc info = map_evar_info (nf_evar evc) info
+
+let nf_evar_map evm =
+  Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm
+
+let nf_evar_map_undefined evm =
+  Evd.raw_map_undefined (fun _ evi -> nf_evar_info evm evi) evm
 
 (*-------------------*)
 (* Auxiliary functions for the conversion algorithms modulo evars
  *)
 
-let has_undefined_evars_or_sorts evd t =
+(* A probably faster though more approximative variant of
+   [has_undefined (nf_evar c)]: instances are not substituted and
+   maybe an evar occurs in an instance and it would disappear by
+   instantiation *)
+
+let has_undefined_evars evd t =
   let rec has_ev t =
     match kind_of_term t with
     | Evar (ev,args) ->
@@ -87,13 +142,12 @@ let has_undefined_evars_or_sorts evd t =
             has_ev c; Array.iter has_ev args
         | Evar_empty ->
 	    raise NotInstantiatedEvar)
-    | Sort s when is_sort_variable evd s -> raise Not_found
     | _ -> iter_constr has_ev t in
   try let _ = has_ev t in false
   with (Not_found | NotInstantiatedEvar) -> true
 
 let is_ground_term evd t =
-  not (has_undefined_evars_or_sorts evd t)
+  not (has_undefined_evars evd t)
 
 let is_ground_env evd env =
   let is_ground_decl = function
@@ -101,9 +155,16 @@ let is_ground_env evd env =
     | _ -> true in
   List.for_all is_ground_decl (rel_context env) &&
   List.for_all is_ground_decl (named_context env)
+
 (* Memoization is safe since evar_map and environ are applicative
    structures *)
-let is_ground_env = memo1_2 is_ground_env
+let memo f =
+  let m = ref None in
+  fun x y -> match !m with
+  | Some (x', y', r) when x == x' && y == y' -> r
+  | _ -> let r = f x y in m := Some (x, y, r); r
+
+let is_ground_env = memo is_ground_env
 
 (* Return the head evar if any *)
 
@@ -125,35 +186,27 @@ let head_evar =
 let whd_head_evar_stack sigma c =
   let rec whrec (c, l as s) =
     match kind_of_term c with
-      | Evar (evk,args as ev) when Evd.is_defined sigma evk
-	  -> whrec (existential_value sigma ev, l)
+      | Evar (evk,args as ev) ->
+        let v =
+          try Some (existential_value sigma ev)
+          with NotInstantiatedEvar | Not_found  -> None in
+        begin match v with
+        | None -> s
+        | Some c -> whrec (c, l)
+        end
       | Cast (c,_,_) -> whrec (c, l)
-      | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
+      | App (f,args) -> whrec (f, args :: l)
       | _ -> s
   in
   whrec (c, [])
 
-let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
-
-let noccur_evar env evd evk c =
-  let rec occur_rec k c = match kind_of_term c with
-  | Evar (evk',args' as ev') ->
-      (match safe_evar_value evd ev' with
-       | Some c -> occur_rec k c
-       | None ->
-           if evk = evk' then raise Occur else Array.iter (occur_rec k) args')
-  | Rel i when i > k ->
-      (match pi2 (Environ.lookup_rel (i-k) env) with
-       | None -> ()
-       | Some b -> occur_rec k (lift i b))
-  | _ -> iter_constr_with_binders succ occur_rec k c
-  in
-  try occur_rec 0 c; true with Occur -> false
-
-let normalize_evar evd ev =
-  match kind_of_term (whd_evar evd (mkEvar ev)) with
-  | Evar (evk,args) -> (evk,args)
-  | _ -> assert false
+let whd_head_evar sigma c =
+  let (f, args) = whd_head_evar_stack sigma c in
+  (** optim: don't reallocate if empty/singleton *)
+  match args with
+  | [] -> f
+  | [arg] -> mkApp (f, arg)
+  | _ -> mkApp (f, Array.concat args)
 
 (**********************)
 (* Creating new metas *)
@@ -161,94 +214,28 @@ let normalize_evar evd ev =
 
 (* Generator of metavariables *)
 let new_meta =
-  let meta_ctr = ref 0 in
-  Summary.declare_summary "meta counter"
-    { Summary.freeze_function = (fun () -> !meta_ctr);
-      Summary.unfreeze_function = (fun n -> meta_ctr := n);
-      Summary.init_function = (fun () -> meta_ctr := 0) };
+  let meta_ctr = Summary.ref 0 ~name:"meta counter" in
   fun () -> incr meta_ctr; !meta_ctr
 
 let mk_new_meta () = mkMeta(new_meta())
 
-let collect_evars emap c =
-  let rec collrec acc c =
-    match kind_of_term c with
-      | Evar (evk,_) ->
-	  if Evd.is_undefined emap evk then evk::acc
-	  else (* No recursion on the evar instantiation *) acc
-      | _         ->
-	  fold_constr collrec acc c in
-  list_uniquize (collrec [] c)
-
-let push_dependent_evars sigma emap =
-  Evd.fold_undefined (fun ev {evar_concl = ccl} (sigma',emap') ->
-    List.fold_left
-      (fun (sigma',emap') ev ->
-	(Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev))
-      (sigma',emap') (collect_evars emap' ccl))
-    emap (sigma,emap)
-
-let push_duplicated_evars sigma emap c =
-  let rec collrec (one,(sigma,emap) as acc) c =
-    match kind_of_term c with
-    | Evar (evk,_) when not (Evd.mem sigma evk) ->
-	if List.mem evk one then
-	  let sigma' = Evd.add sigma evk (Evd.find emap evk) in
-	  let emap' = Evd.remove emap evk in
-	  (one,(sigma',emap'))
-	else
-	  (evk::one,(sigma,emap))
-    | _ ->
-	fold_constr collrec acc c
-  in
-  snd (collrec ([],(sigma,emap)) c)
-
-(* replaces a mapping of existentials into a mapping of metas.
-   Problem if an evar appears in the type of another one (pops anomaly) *)
-let evars_to_metas sigma (emap, c) =
-  let emap = nf_evar_map_undefined emap in
-  let sigma',emap' = push_dependent_evars sigma emap in
-  let sigma',emap' = push_duplicated_evars sigma' emap' c in
-  (* if an evar has been instantiated in [emap] (as part of typing [c])
-     then it is instantiated in [sigma]. *)
-  let repair_evars sigma emap =
-    fold_undefined begin fun ev _ sigma' ->
-      try
-	let info = find emap ev in
-	match evar_body info with
-	| Evar_empty -> sigma'
-	| Evar_defined body -> define ev body sigma'
-      with Not_found -> sigma'
-    end sigma sigma
-  in
-  let sigma' = repair_evars sigma' emap in
-  let change_exist evar =
-    let ty = nf_betaiota emap (existential_type emap evar) in
-    let n = new_meta() in
-    mkCast (mkMeta n, DEFAULTcast, ty) in
-  let rec replace c =
-    match kind_of_term c with
-      | Evar (evk,_ as ev) when Evd.mem emap' evk -> change_exist ev
-      | _ -> map_constr replace c in
-  (sigma', replace c)
-
 (* The list of non-instantiated existential declarations (order is important) *)
 
 let non_instantiated sigma =
-  let listev = Evd.undefined_list sigma in
-  List.map (fun (ev,evi) -> (ev,nf_evar_info sigma evi)) listev
+  let listev = Evd.undefined_map sigma in
+  Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev
 
 (************************)
 (* Manipulating filters *)
 (************************)
 
-let apply_subfilter filter subfilter =
-  fst (List.fold_right (fun oldb (l,filter) ->
-    if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
-         filter ([], List.rev subfilter))
-
-let extract_subfilter initial_filter refined_filter =
-  snd (list_filter2 (fun b1 b2 -> b1) (initial_filter,refined_filter))
+let make_pure_subst evi args =
+  snd (List.fold_right
+    (fun (id,b,c) (args,l) ->
+      match args with
+        | a::rest -> (rest, (id,a)::l)
+        | _ -> anomaly (Pp.str "Instance does not match its signature"))
+    (evar_filtered_context evi) (Array.rev_to_list args,[]))
 
 (**********************)
 (* Creating new evars *)
@@ -256,12 +243,8 @@ let extract_subfilter initial_filter refined_filter =
 
 (* Generator of existential names *)
 let new_untyped_evar =
-  let evar_ctr = ref 0 in
-  Summary.declare_summary "evar counter"
-    { Summary.freeze_function = (fun () -> !evar_ctr);
-      Summary.unfreeze_function = (fun n -> evar_ctr := n);
-      Summary.init_function = (fun () -> evar_ctr := 0) };
-  fun () -> incr evar_ctr; existential_of_int !evar_ctr
+  let evar_ctr = Summary.ref 0 ~name:"evar counter" in
+  fun () -> incr evar_ctr; Evar.unsafe_of_int !evar_ctr
 
 (*------------------------------------*
  * functional operations on evar sets *
@@ -296,109 +279,145 @@ let new_untyped_evar =
  *   we have the property that u and phi(t) are convertible in env.
  *)
 
+let subst2 subst vsubst c =
+  substl subst (replace_vars vsubst c)
+
 let push_rel_context_to_named_context env typ =
   (* compute the instances relative to the named context and rel_context *)
   let ids = List.map pi1 (named_context env) in
   let inst_vars = List.map mkVar ids in
   let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
+  let replace_var_named_declaration id0 id (id',b,t) =
+    let id' = if Id.equal id0 id' then id else id' in
+    let vsubst = [id0 , mkVar id] in
+    let b = match b with
+    | None -> None
+    | Some c -> Some (replace_vars vsubst c)
+    in
+    id', b, replace_vars vsubst t
+  in
+  let replace_var_named_context id0 id  env =
+    let nc = Environ.named_context env in
+    let nc' = List.map (replace_var_named_declaration id0 id) nc in
+    Environ.reset_with_named_context (val_of_named_context nc') env
+  in
+  let extract_if_neq id = function
+    | Anonymous -> None
+    | Name id' when id_ord id id' = 0 -> None
+    | Name id' -> Some id'
+  in
   (* move the rel context to a named context and extend the named instance *)
   (* with vars of the rel context *)
   (* We do keep the instances corresponding to local definition (see above) *)
-  let (subst, _, env) =
-    Sign.fold_rel_context
-      (fun (na,c,t) (subst, avoid, env) ->
-	let id = next_name_away na avoid in
-	let d = (id,Option.map (substl subst) c,substl subst t) in
-	(mkVar id :: subst, id::avoid, push_named d env))
-      (rel_context env) ~init:([], ids, env) in
-  (named_context_val env, substl subst typ, inst_rels@inst_vars, subst)
+  let (subst, vsubst, _, env) =
+    Context.fold_rel_context
+      (fun (na,c,t) (subst, vsubst, avoid, env) ->
+        let id =
+          (* ppedrot: we want to infer nicer names for the refine tactic, but
+             keeping at the same time backward compatibility in other code
+             using this function. For now, we only attempt to preserve the
+             old behaviour of Program, but ultimately, one should do something
+             about this whole name generation problem. *)
+          if Flags.is_program_mode () then next_name_away na avoid
+          else next_ident_away (id_of_name_using_hdchar env t na) avoid
+        in
+        match extract_if_neq id na with
+        | Some id0 when not (is_section_variable id0) ->
+            (* spiwack: if [id<>id0], rather than introducing a new
+               binding named [id], we will keep [id0] (the name given
+               by the user) and rename [id0] into [id] in the named
+               context. Unless [id] is a section variable. *)
+            let subst = List.map (replace_vars [id0,mkVar id]) subst in
+            let vsubst = (id0,mkVar id)::vsubst in
+            let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in
+            let env = replace_var_named_context id0  id env in
+            (mkVar id0 :: subst, vsubst, id::avoid, push_named d env)
+        | _ ->
+            (* spiwack: if [id0] is a section variable renaming it is
+               incorrect. We revert to a less robust behaviour where
+               the new binder has name [id]. Which amounts to the same
+               behaviour than when [id=id0]. *)
+	    let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in
+	    (mkVar id :: subst, vsubst, id::avoid, push_named d env)
+      )
+      (rel_context env) ~init:([], [], ids, env) in
+  (named_context_val env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
 
 (*------------------------------------*
  * Entry points to define new evars   *
  *------------------------------------*)
 
-let default_source = (dummy_loc,InternalHole)
+let default_source = (Loc.ghost,Evar_kinds.InternalHole)
 
-let new_pure_evar evd sign ?(src=default_source) ?filter ?candidates typ =
+let restrict_evar evd evk filter candidates =
+  let evk' = new_untyped_evar () in
+  let evd = Evd.restrict evk evk' filter ?candidates evd in
+  Evd.declare_future_goal evk' evd, evk'
+
+let new_pure_evar_full evd evi =
+  let evk = new_untyped_evar () in
+  let evd = Evd.add evd evk evi in
+  let evd = Evd.declare_future_goal evk evd in
+  (evd, evk)
+
+let new_pure_evar sign evd ?(src=default_source) ?filter ?candidates ?store ?naming ?(principal=false) typ =
+  let default_naming =
+    if principal then
+        (* waiting for a more principled approach
+           (unnamed evars, private names?) *)
+        Misctypes.IntroFresh (Names.Id.of_string "tmp_goal")
+      else
+        Misctypes.IntroAnonymous
+  in
+  let naming = Option.default default_naming naming in
   let newevk = new_untyped_evar() in
-  let evd = evar_declare sign newevk typ ~src ?filter ?candidates evd in
+  let evd = evar_declare sign newevk typ ~src ?filter ?candidates ?store ~naming evd in
+  let evd =
+    if principal then Evd.declare_principal_goal newevk evd
+    else Evd.declare_future_goal newevk evd
+  in
   (evd,newevk)
 
-let new_evar_instance sign evd typ ?src ?filter ?candidates instance =
+let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance =
   assert (not !Flags.debug ||
-            list_distinct (ids_of_named_context (named_context_of_val sign)));
-  let evd,newevk = new_pure_evar evd sign ?src ?filter ?candidates typ in
+            List.distinct (ids_of_named_context (named_context_of_val sign)));
+  let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in
   (evd,mkEvar (newevk,Array.of_list instance))
 
 (* [new_evar] declares a new existential in an env env with type typ *)
 (* Converting the env into the sign of the evar to define *)
-
-let new_evar evd env ?src ?filter ?candidates typ =
-  let sign,typ',instance,subst = push_rel_context_to_named_context env typ in
-  let candidates = Option.map (List.map (substl subst)) candidates in
+let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
+  let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in
+  let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in
   let instance =
     match filter with
     | None -> instance
-    | Some filter -> list_filter_with filter instance in
-  new_evar_instance sign evd typ' ?src ?filter ?candidates instance
+    | Some filter -> Filter.filter_list filter instance in
+  new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
 
-let new_type_evar ?src ?filter evd env =
-  let evd', s = new_sort_variable evd in
-  new_evar evd' env ?src ?filter (mkSort s)
+let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
+  let evd', s = new_sort_variable rigid evd in
+  let evd', e = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in
+    evd', (e, s)
 
-  (* The same using side-effect *)
-let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty =
-  let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in
-  evdref := evd';
-  ev
+let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
+  let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in
+    evdref := evd';
+    c
 
-(*------------------------------------*
- * Restricting existing evars         *
- *------------------------------------*)
+let new_Type ?(rigid=Evd.univ_flexible) env evd = 
+  let evd', s = new_sort_variable rigid evd in
+    evd', mkSort s
 
-let restrict_evar_key evd evk filter candidates =
-  if filter = None && candidates = None then
-    evd,evk
-  else
-    let evi = Evd.find_undefined evd evk in
-    let oldfilter = evar_filter evi in
-    if filter = Some oldfilter && candidates = None then
-      evd,evk
-    else
-    let filter =
-      match filter with
-      | None -> evar_filter evi
-      | Some filter -> filter in
-    let candidates =
-      match candidates with None -> evi.evar_candidates | _ -> candidates in
-    let ccl = evi.evar_concl in
-    let sign = evar_hyps evi in
-    let src = evi.evar_source in
-    let evd,newevk = new_pure_evar evd sign ccl ~src ~filter ?candidates in
-    let ctxt = snd (list_filter2 (fun b c -> b) (filter,evar_context evi)) in
-    let id_inst = Array.of_list (List.map (fun (id,_,_) -> mkVar id) ctxt) in
-    Evd.define evk (mkEvar(newevk,id_inst)) evd,newevk
-
-(* Restrict an applied evar and returns its restriction in the same context *)
-let restrict_applied_evar evd (evk,argsv) filter candidates =
-  let evd,newevk = restrict_evar_key evd evk filter candidates in
-  let newargsv = match filter with
-  | None -> (* optim *) argsv
-  | Some filter ->
-      let evi = Evd.find evd evk in
-      let subfilter = extract_subfilter (evar_filter evi) filter in
-      array_filter_with subfilter argsv in
-  evd,(newevk,newargsv)
-
-(* Restrict an evar in the current evar_map *)
-let restrict_evar evd evk filter candidates =
-  fst (restrict_evar_key evd evk filter candidates)
+let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
+  let evd', s = new_sort_variable rigid !evdref in
+    evdref := evd'; mkSort s
 
-(* Restrict an evar in the current evar_map *)
-let restrict_instance evd evk filter argsv =
-  match filter with None -> argsv | Some filter ->
-  let evi = Evd.find evd evk in
-  array_filter_with (extract_subfilter (evar_filter evi) filter) argsv
+  (* The same using side-effect *)
+let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
+  let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
+  evdref := evd';
+  ev
 
 (* This assumes an evar with identity instance and generalizes it over only
    the De Bruijn part of the context *)
@@ -410,176 +429,26 @@ let generalize_evar_over_rels sigma (ev,args) =
       if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
      (evi.evar_concl,[]) (Array.to_list args) sign
 
-(***************************************)
-(* Managing chains of local definitons *)
-(***************************************)
-
-(* Expand rels and vars that are bound to other rels or vars so that
-   dependencies in variables are canonically associated to the most ancient
-   variable in its family of aliased variables *)
-
-let compute_var_aliases sign =
-  List.fold_right (fun (id,b,c) aliases ->
-    match b with
-    | Some t ->
-        (match kind_of_term t with
-        | Var id' ->
-            let aliases_of_id =
-              try Idmap.find id' aliases with Not_found -> [] in
-            Idmap.add id (aliases_of_id@[t]) aliases
-	| _ ->
-            Idmap.add id [t] aliases)
-    | None -> aliases)
-    sign Idmap.empty
-
-let compute_rel_aliases var_aliases rels =
-  snd (List.fold_right (fun (_,b,t) (n,aliases) ->
-    (n-1,
-     match b with
-     | Some t ->
-         (match kind_of_term t with
-         | Var id' ->
-             let aliases_of_n =
-               try Idmap.find id' var_aliases with Not_found -> [] in
-             Intmap.add n (aliases_of_n@[t]) aliases
-         | Rel p ->
-             let aliases_of_n =
-               try Intmap.find (p+n) aliases with Not_found -> [] in
-             Intmap.add n (aliases_of_n@[mkRel (p+n)]) aliases
-         | _ ->
-             Intmap.add n [lift n t] aliases)
-     | None -> aliases))
-         rels (List.length rels,Intmap.empty))
-
-let make_alias_map env =
-  (* We compute the chain of aliases for each var and rel *)
-  let var_aliases = compute_var_aliases (named_context env) in
-  let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in
-  (var_aliases,rel_aliases)
-
-let lift_aliases n (var_aliases,rel_aliases as aliases) =
-  if n = 0 then aliases else
-  (var_aliases,
-   Intmap.fold (fun p l -> Intmap.add (p+n) (List.map (lift n) l))
-     rel_aliases Intmap.empty)
-
-let get_alias_chain_of aliases x = match kind_of_term x with
-  | Rel n -> (try Intmap.find n (snd aliases) with Not_found -> [])
-  | Var id -> (try Idmap.find id (fst aliases) with Not_found -> [])
-  | _ -> []
-
-let normalize_alias_opt aliases x =
-  match get_alias_chain_of aliases x with
-  | []  -> None
-  | a::_ when isRel a or isVar a -> Some a
-  | [_] -> None
-  | _::a::_ -> Some a
-
-let normalize_alias aliases x =
-  match normalize_alias_opt aliases x with
-  | Some a -> a
-  | None -> x
-
-let normalize_alias_var var_aliases id =
-  destVar (normalize_alias (var_aliases,Intmap.empty) (mkVar id))
-
-let extend_alias (_,b,_) (var_aliases,rel_aliases) =
-  let rel_aliases =
-    Intmap.fold (fun n l -> Intmap.add (n+1) (List.map (lift 1) l))
-      rel_aliases Intmap.empty in
-  let rel_aliases =
-    match b with
-    | Some t ->
-        (match kind_of_term t with
-        | Var id' ->
-            let aliases_of_binder =
-              try Idmap.find id' var_aliases with Not_found -> [] in
-	    Intmap.add 1 (aliases_of_binder@[t]) rel_aliases
-        | Rel p ->
-            let aliases_of_binder =
-              try Intmap.find (p+1) rel_aliases with Not_found -> [] in
-	    Intmap.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases
-        | _ ->
-            Intmap.add 1 [lift 1 t] rel_aliases)
-    | None -> rel_aliases in
-  (var_aliases, rel_aliases)
-
-let expand_alias_once aliases x =
-  match get_alias_chain_of aliases x with
-  | []  -> None
-  | l -> Some (list_last l)
-
-let rec expansions_of_var aliases x =
-  match get_alias_chain_of aliases x with
-  | [] -> [x]
-  | a::_ as l when isRel a || isVar a -> x :: List.rev l
-  | _::l -> x :: List.rev l
-
-let expansion_of_var aliases x =
-  match get_alias_chain_of aliases x with
-  | [] -> x
-  | a::_ -> a
-
-let rec expand_vars_in_term_using aliases t = match kind_of_term t with
-  | Rel _ | Var _ ->
-      normalize_alias aliases t
-  | _ ->
-      map_constr_with_full_binders
-	extend_alias expand_vars_in_term_using aliases t
-
-let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env)
-
-let free_vars_and_rels_up_alias_expansion aliases c =
-  let acc1 = ref Intset.empty and acc2 = ref Idset.empty in
-  let cache_rel = ref Intset.empty and cache_var = ref Idset.empty in
-  let is_in_cache depth = function
-    | Rel n -> Intset.mem (n-depth) !cache_rel
-    | Var s -> Idset.mem s !cache_var
-    | _ -> false in
-  let put_in_cache depth = function
-    | Rel n -> cache_rel := Intset.add (n-depth) !cache_rel
-    | Var s -> cache_var := Idset.add s !cache_var
-    | _ -> () in
-  let rec frec (aliases,depth) c =
-    match kind_of_term c with
-    | Rel _ | Var _ as ck ->
-      if is_in_cache depth ck then () else begin
-      put_in_cache depth ck;
-      let c = expansion_of_var aliases c in
-        match kind_of_term c with
-        | Var id -> acc2 := Idset.add id !acc2
-        | Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1
-        | _ -> frec (aliases,depth) c end
-    | Const _ | Ind _ | Construct _ ->
-        acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2
-    | _ ->
-        iter_constr_with_full_binders
-          (fun d (aliases,depth) -> (extend_alias d aliases,depth+1))
-          frec (aliases,depth) c
-  in
-  frec (aliases,0) c;
-  (!acc1,!acc2)
-
 (************************************)
 (* Removing a dependency in an evar *)
 (************************************)
 
 type clear_dependency_error =
-| OccurHypInSimpleClause of identifier option
+| OccurHypInSimpleClause of Id.t option
 | EvarTypingBreak of existential
 
-exception ClearDependencyError of identifier * clear_dependency_error
-
-open Store.Field
+exception ClearDependencyError of Id.t * clear_dependency_error
 
 let cleared = Store.field ()
 
-let rec check_and_clear_in_constr evdref err ids c =
+exception Depends of Id.t
+
+let rec check_and_clear_in_constr env evdref err ids c =
   (* returns a new constr where all the evars have been 'cleaned'
      (ie the hypotheses ids have been removed from the contexts of
      evars) *)
   let check id' =
-    if List.mem id' ids then
+    if Id.Set.mem id' ids then
       raise (ClearDependencyError (id',err))
   in
     match kind_of_term c with
@@ -587,14 +456,14 @@ let rec check_and_clear_in_constr evdref err ids c =
 	  check id'; c
 
       | ( Const _ | Ind _ | Construct _ ) ->
-          let vars = Environ.vars_of_global (Global.env()) c in
-            List.iter check vars; c
+          let vars = Environ.vars_of_global env c in
+            Id.Set.iter check vars; c
 
       | Evar (evk,l as ev) ->
 	  if Evd.is_defined !evdref evk then
 	    (* If evk is already defined we replace it by its definition *)
 	    let nc = whd_evar !evdref c in
-	      (check_and_clear_in_constr evdref err ids nc)
+	      (check_and_clear_in_constr env evdref err ids nc)
 	  else
 	    (* We check for dependencies to elements of ids in the
 	       evar_info corresponding to e and in the instance of
@@ -603,1217 +472,93 @@ let rec check_and_clear_in_constr evdref err ids c =
 	       removed *)
 	    let evi = Evd.find_undefined !evdref evk in
 	    let ctxt = Evd.evar_filtered_context evi in
-	    let (nhyps,nargs,rids) =
-	      List.fold_right2
-		(fun (rid,ob,c as h) a (hy,ar,ri) ->
-		  (* Check if some id to clear occurs in the instance
-		     a of rid in ev and remember the dependency *)
-		  match
-		    List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a))
-		  with
-		  | id :: _ -> (hy,ar,(rid,id)::ri)
-		  | _ ->
-		  (* Check if some rid to clear in the context of ev
-		     has dependencies in another hyp of the context of ev
-		     and transitively remember the dependency *)
-		  match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with
-		  | (_,id') :: _ -> (hy,ar,(rid,id')::ri)
-		  | _ ->
-		  (* No dependency at all, we can keep this ev's context hyp *)
-		      (h::hy,a::ar,ri))
-		ctxt (Array.to_list l) ([],[],[]) in
+	    let (rids,filter) =
+              List.fold_right2
+                (fun (rid, ob,c as h) a (ri,filter) ->
+                  try
+                  (* Check if some id to clear occurs in the instance
+                     a of rid in ev and remember the dependency *)
+                    let check id = if Id.Set.mem id ids then raise (Depends id) in
+                    let () = Id.Set.iter check (collect_vars a) in
+                  (* Check if some rid to clear in the context of ev
+                     has dependencies in another hyp of the context of ev
+                     and transitively remember the dependency *)
+                    let check id _ =
+                      if occur_var_in_decl (Global.env ()) id h
+                      then raise (Depends id)
+                    in
+                    let () = Id.Map.iter check ri in
+                  (* No dependency at all, we can keep this ev's context hyp *)
+                    (ri, true::filter)
+                  with Depends id -> (Id.Map.add rid id ri, false::filter))
+		ctxt (Array.to_list l) (Id.Map.empty,[]) in
 	    (* Check if some rid to clear in the context of ev has dependencies
 	       in the type of ev and adjust the source of the dependency *)
-	    let nconcl =
-	      try check_and_clear_in_constr evdref (EvarTypingBreak ev)
-		    (List.map fst rids) (evar_concl evi)
+	    let _nconcl =
+	      try
+                let nids = Id.Map.domain rids in
+                check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids (evar_concl evi)
 	      with ClearDependencyError (rid,err) ->
-		raise (ClearDependencyError (List.assoc rid rids,err)) in
+		raise (ClearDependencyError (Id.Map.find rid rids,err)) in
 
-            if rids = [] then c else begin
-	      let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
-	      let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
-	      evdref := Evd.define evk ev' !evdref;
-	      let (evk',_) = destEvar ev' in
+            if Id.Map.is_empty rids then c
+            else
+              let origfilter = Evd.evar_filter evi in
+              let filter = Evd.Filter.apply_subfilter origfilter filter in
+              let evd,_ = restrict_evar !evdref evk filter None in
+              evdref := evd;
 	    (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
 	      let evi = Evd.find !evdref evk in
 	      let extra = evi.evar_extra in
-	      let extra' = cleared.set true extra in
+	      let extra' = Store.set extra cleared true in
 	      let evi' = { evi with evar_extra = extra' } in
 	      evdref := Evd.add !evdref evk evi' ;
 	    (* spiwack: /hacking session *)
-	      mkEvar(evk', Array.of_list nargs)
-            end
+              whd_evar !evdref c
 
-      | _ -> map_constr (check_and_clear_in_constr evdref err ids) c
+      | _ -> map_constr (check_and_clear_in_constr env evdref err ids) c
 
-let clear_hyps_in_evi evdref hyps concl ids =
+let clear_hyps_in_evi_main env evdref hyps terms ids =
   (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
      hypothesis does not depend on a element of ids, and erases ids in
      the contexts of the evars occuring in evi *)
-  let nconcl =
-    check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in
+  let terms =
+    List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in
   let nhyps =
-    let check_context (id,ob,c) =
+    let check_context ((id,ob,c) as decl) =
       let err = OccurHypInSimpleClause (Some id) in
-      (id, Option.map (check_and_clear_in_constr evdref err ids) ob,
-	check_and_clear_in_constr evdref err ids c)
+      let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in
+      let c' = check_and_clear_in_constr env evdref err ids c in
+      if ob == ob' && c == c' then decl else (id, ob', c')
     in
-    let check_value vk =
-      match !vk with
-	| VKnone -> vk
-	| VKvalue (v,d) ->
-	    if (List.for_all (fun e -> not (Idset.mem e d)) ids) then
-	      (* v does depend on any of ids, it's ok *)
-	      vk
-	    else
-	      (* v depends on one of the cleared hyps: we forget the computed value *)
-	      ref VKnone
+    let check_value vk = match force_lazy_val vk with
+    | None -> vk
+    | Some (_, d) ->
+      if (Id.Set.for_all (fun e -> not (Id.Set.mem e d)) ids) then
+        (* v does depend on any of ids, it's ok *)
+        vk
+      else
+        (* v depends on one of the cleared hyps:
+            we forget the computed value *)
+        dummy_lazy_val ()
     in
       remove_hyps ids check_context check_value hyps
   in
-  (nhyps,nconcl)
-
-(********************************)
-(* Managing pattern-unification *)
-(********************************)
-
-let rec expand_and_check_vars aliases = function
-  | [] -> []
-  | a::l when isRel a or isVar a ->
-      let a = expansion_of_var aliases a in
-      if isRel a or isVar a then a :: expand_and_check_vars aliases l
-      else raise Exit
-  | _ ->
-      raise Exit
-
-module Constrhash = Hashtbl.Make
-  (struct type t = constr
-	  let equal = eq_constr
-	  let hash = hash_constr
-   end)
-
-let rec constr_list_distinct l =
-  let visited = Constrhash.create 23 in
-  let rec loop = function
-    | h::t ->
-	if Constrhash.mem visited h then false
-	else (Constrhash.add visited h h; loop t)
-    | [] -> true
-  in loop l
-
-let get_actual_deps aliases l t =
-  if occur_meta_or_existential t then
-    (* Probably no restrictions on allowed vars in presence of evars *)
-    l
-  else
-    (* Probably strong restrictions coming from t being evar-closed *)
-    let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
-    List.filter (fun c ->
-      match kind_of_term c with
-      | Var id -> Idset.mem id fv_ids
-      | Rel n -> Intset.mem n fv_rels
-      | _ -> assert false) l
-
-let remove_instance_local_defs evd evk args =
-  let evi = Evd.find evd evk in
-  let rec aux = function
-  | (_,Some _,_)::sign, a::args -> aux (sign,args)
-  | (_,None,_)::sign, a::args -> a::aux (sign,args)
-  | [], [] -> []
-  | _ -> assert false in
-  aux (evar_filtered_context evi, args)
-
-(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
-
-let find_unification_pattern_args env l t =
-  if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then
-    let aliases = make_alias_map env in
-    match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
-    | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
-    | _ -> None
-  else
-    None
-
-let is_unification_pattern_meta env nb m l t =
-  (* Variables from context and rels > nb are implicitly all there *)
-  (* so we need to be a rel <= nb *)
-  if List.for_all (fun x -> isRel x && destRel x <= nb) l then
-    match find_unification_pattern_args env l t with
-    | Some _ as x when not (dependent (mkMeta m) t) -> x
-    | _ -> None
-  else
-    None
-
-let is_unification_pattern_evar env evd (evk,args) l t =
-  if List.for_all (fun x -> isRel x || isVar x) l & noccur_evar env evd evk t
-  then
-    let args = remove_instance_local_defs evd evk (Array.to_list args) in
-    let n = List.length args in
-    match find_unification_pattern_args env (args @ l) t with
-    | Some l -> Some (list_skipn n l)
-    | _ -> None
-  else
-    None
-
-let is_unification_pattern_pure_evar env evd (evk,args) t =
-  is_unification_pattern_evar env evd (evk,args) [] t <> None
-
-let is_unification_pattern (env,nb) evd f l t =
-  match kind_of_term f with
-  | Meta m -> is_unification_pattern_meta env nb m l t
-  | Evar ev -> is_unification_pattern_evar env evd ev l t
-  | _ -> None
-
-(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
-   (pattern unification). It is assumed that l is made of rel's that
-   are distinct and not bound to aliases. *)
-(* It is also assumed that c does not contain metas because metas
-   *implicitly* depend on Vars but lambda abstraction will not reflect this
-   dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
-   return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
-let solve_pattern_eqn env l c =
-  let c' = List.fold_right (fun a c ->
-    let c' = subst_term (lift 1 a) (lift 1 c) in
-    match kind_of_term a with
-      (* Rem: if [a] links to a let-in, do as if it were an assumption *)
-      | Rel n ->
-          let d = map_rel_declaration (lift n) (lookup_rel n env) in
-          mkLambda_or_LetIn d c'
-      | Var id ->
-          let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
-      | _ -> assert false)
-    l c in
-  (* Warning: we may miss some opportunity to eta-reduce more since c'
-     is not in normal form *)
-  whd_eta c'
-
-(*****************************************)
-(* Refining/solving unification problems *)
-(*****************************************)
-
-(* Knowing that [Gamma |- ev : T] and that [ev] is applied to [args],
- * [make_projectable_subst ev args] builds the substitution [Gamma:=args].
- * If a variable and an alias of it are bound to the same instance, we skip
- * the alias (we just use eq_constr -- instead of conv --, since anyway,
- * only instances that are variables -- or evars -- are later considered;
- * morever, we can bet that similar instances came at some time from
- * the very same substitution. The removal of aliased duplicates is
- * useful to ensure the uniqueness of a projection.
-*)
-
-let make_projectable_subst aliases sigma evi args =
-  let sign = evar_filtered_context evi in
-  let evar_aliases = compute_var_aliases sign in
-  let (_,full_subst,cstr_subst) =
-    List.fold_right
-      (fun (id,b,c) (args,all,cstrs) ->
-        match b,args with
-	| None, a::rest ->
-	    let a = whd_evar sigma a in
-	    let cstrs =
-	      let a',args = decompose_app_vect a in
-	      match kind_of_term a' with
-	      | Construct cstr ->
-		  let l = try Constrmap.find cstr cstrs with Not_found -> [] in
-		  Constrmap.add cstr ((args,id)::l) cstrs
-	      | _ -> cstrs in
-	    (rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs)
-	| Some c, a::rest ->
-	    let a = whd_evar sigma a in
-	    (match kind_of_term c with
-	    | Var id' ->
-		let idc = normalize_alias_var evar_aliases id' in
-		let sub = try Idmap.find idc all with Not_found -> [] in
-		if List.exists (fun (c,_,_) -> eq_constr a c) sub then
-		  (rest,all,cstrs)
-		else
-		  (rest,
-		   Idmap.add idc ((a,normalize_alias_opt aliases a,id)::sub) all,
-		   cstrs)
-	    | _ ->
-		(rest,Idmap.add id [a,normalize_alias_opt aliases a,id] all,cstrs))
-	| _ -> anomaly "Instance does not match its signature")
-      sign (array_rev_to_list args,Idmap.empty,Constrmap.empty) in
-  (full_subst,cstr_subst)
-
-let make_pure_subst evi args =
-  snd (List.fold_right
-    (fun (id,b,c) (args,l) ->
-      match args with
-	| a::rest -> (rest, (id,a)::l)
-	| _ -> anomaly "Instance does not match its signature")
-    (evar_filtered_context evi) (array_rev_to_list args,[]))
+  (nhyps,terms)
 
-(*------------------------------------*
- * operations on the evar constraints *
- *------------------------------------*)
-
-(* We have a unification problem Σ; Γ |- ?e[u1..uq] = t : s where ?e is not yet
- * declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq.
- * [define_evar_from_virtual_equation ... Γ Σ t (x1:T1..xq:Tq) .. (u1..uq) (x1..xq)]
- * declares x1:T1..xq:Tq |- ?e : s such that ?e[u1..uq] = t holds.
- *)
-
-let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env =
-  let ty_t_in_env = Retyping.get_type_of env evd t_in_env in
-  let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in
-  let t_in_env = whd_evar evd t_in_env in
-  let evd = define_fun env evd (destEvar evar_in_env) t_in_env in
-  let ids = List.map pi1 (named_context_of_val sign) in
-  let inst_in_sign = List.map mkVar (list_filter_with filter ids) in
-  let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in
-  (evd,whd_evar evd evar_in_sign)
-
-(* We have x1..xq |- ?e1 : Ï„ and had to solve something like
- * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some
- * ?e2[v1..vn], hence flexible. We had to go through k binders and now
- * virtually have x1..xq, y1'..yk' | ?e1' : Ï„' and the equation
- * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c.
- * [materialize_evar Γ evd k (?e1[u1..uq]) τ'] extends Σ with the declaration
- * of ?e1' and returns both its instance ?e1'[x1..xq y1..yk] in an extension
- * of the context of e1 so that e1 can be instantiated by
- * (...\y1' ... \yk' ... ?e1'[x1..xq y1'..yk']),
- * and the instance ?e1'[u1..uq y1..yk] so that the remaining equation
- * ?e1'[u1..uq y1..yk] = c can be registered
- *
- * Note that, because invert_definition does not check types, we need to
- * guess the types of y1'..yn' by inverting the types of y1..yn along the
- * substitution u1..uq.
- *)
-
-let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
-  let evi1 = Evd.find_undefined evd evk1 in
-  let env1,rel_sign = env_rel_context_chop k env in
-  let sign1 = evar_hyps evi1 in
-  let filter1 = evar_filter evi1 in
-  let ids1 = List.map pi1 (named_context_of_val sign1) in
-  let inst_in_sign = List.map mkVar (list_filter_with filter1 ids1) in
-  let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
-    List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
-      let id = next_name_away na avoid in
-      let evd,t_in_sign =
-        define_evar_from_virtual_equation define_fun env evd t_in_env
-          sign filter inst_in_env in
-      let evd,b_in_sign = match b with
-      | None -> evd,None
-      | Some b ->
-          let evd,b = define_evar_from_virtual_equation define_fun env evd b
-            sign filter inst_in_env in
-          evd,Some b in
-      (push_named_context_val (id,b_in_sign,t_in_sign) sign,true::filter,
-       (mkRel 1)::(List.map (lift 1) inst_in_env),
-       (mkRel 1)::(List.map (lift 1) inst_in_sign),
-       push_rel d env,evd,id::avoid))
-      rel_sign
-      (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1)
-  in
-  let evd,ev2ty_in_sign =
-    define_evar_from_virtual_equation define_fun env evd ty_in_env
-      sign2 filter2 inst2_in_env in
-  let evd,ev2_in_sign =
-    new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in
-  let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
-  (evd, ev2_in_sign, ev2_in_env)
-
-let restrict_upon_filter evd evk p args =
-  let newfilter = List.map p args in
-  if List.for_all (fun id -> id) newfilter then
-    None
-  else
-    let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in
-    Some (apply_subfilter oldfullfilter newfilter)
-
-(* Inverting constructors in instances (common when inferring type of match) *)
-
-let find_projectable_constructor env evd cstr k args cstr_subst =
-  try
-    let l = Constrmap.find cstr cstr_subst in
-    let args = Array.map (lift (-k)) args in
-    let l =
-      List.filter (fun (args',id) ->
-	(* is_conv is maybe too strong (and source of useless computation) *)
-	(* (at least expansion of aliases is needed) *)
-	array_for_all2 (is_conv env evd) args args') l in
-    List.map snd l
-  with Not_found ->
-    []
-
-(* [find_projectable_vars env sigma y subst] finds all vars of [subst]
- * that project on [y]. It is able to find solutions to the following
- * two kinds of problems:
- *
- * - ?n[...;x:=y;...] = y
- * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable
- *
- * (see test-suite/success/Fixpoint.v for an example of application of
- * the second kind of problem).
- *
- * The seek for [y] is up to variable aliasing.  In case of solutions that
- * differ only up to aliasing, the binding that requires the less
- * steps of alias reduction is kept. At the end, only one solution up
- * to aliasing is kept.
- *
- * [find_projectable_vars] also unifies against evars that themselves mention
- * [y] and recursively.
- *
- * In short, the following situations give the following solutions:
- *
- * problem                        evar ctxt   soluce remark
- * z1; z2:=z1 |- ?ev[z1;z2] = z1  y1:A; y2:=y1  y1  \ thanks to defs kept in
- * z1; z2:=z1 |- ?ev[z1;z2] = z2  y1:A; y2:=y1  y2  / subst and preferring =
- * z1; z2:=z1 |- ?ev[z1]    = z2  y1:A          y1  thanks to expand_var
- * z1; z2:=z1 |- ?ev[z2]    = z1  y1:A          y1  thanks to expand_var
- * z3         |- ?ev[z3;z3] = z3  y1:A; y2:=y1  y2  see make_projectable_subst
- *
- * Remark: [find_projectable_vars] assumes that identical instances of
- * variables in the same set of aliased variables are already removed (see
- * [make_projectable_subst])
- *)
-
-type evar_projection =
-| ProjectVar
-| ProjectEvar of existential * evar_info * identifier * evar_projection
-
-exception NotUnique
-exception NotUniqueInType of (identifier * evar_projection) list
-
-let rec assoc_up_to_alias sigma aliases y yc = function
-  | [] -> raise Not_found
-  | (c,cc,id)::l ->
-      let c' = whd_evar sigma c in
-      if eq_constr y c' then id
-      else
-	if l <> [] then assoc_up_to_alias sigma aliases y yc l
-	else
-	  (* Last chance, we reason up to alias conversion *)
-	  match (if c == c' then cc else normalize_alias_opt aliases c') with
-	  | Some cc when eq_constr yc cc -> id
-	  | _ -> if eq_constr yc c then id else raise Not_found
-
-let rec find_projectable_vars with_evars aliases sigma y subst =
-  let yc = normalize_alias aliases y in
-  let is_projectable idc idcl subst' =
-    (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *)
-    try
-      let id = assoc_up_to_alias sigma aliases y yc idcl in
-      (id,ProjectVar)::subst'
-    with Not_found ->
-    (* Then test if [idc] is (indirectly) bound in [subst] to some evar *)
-    (* projectable on [y] *)
-      if with_evars then
-	let idcl' = List.filter (fun (c,_,id) -> isEvar c) idcl in
-	match idcl' with
-	| [c,_,id] ->
-	  begin
-	    let (evk,argsv as t) = destEvar c in
-	    let evi = Evd.find sigma evk in
-	    let subst,_ = make_projectable_subst aliases sigma evi argsv in
-	    let l = find_projectable_vars with_evars aliases sigma y subst in
-	    match l with
-	    | [id',p] -> (id,ProjectEvar (t,evi,id',p))::subst'
-	    | _ -> subst'
-	  end
-	| [] -> subst'
-	| _ -> anomaly "More than one non var in aliases class of evar instance"
-      else
-	subst' in
-  Idmap.fold is_projectable subst []
-
-(* [filter_solution] checks if one and only one possible projection exists
- * among a set of solutions to a projection problem *)
-
-let filter_solution = function
-  | [] -> raise Not_found
-  | (id,p)::_::_ -> raise NotUnique
-  | [id,p] -> (mkVar id, p)
-
-let project_with_effects aliases sigma effects t subst =
-  let c, p =
-    filter_solution (find_projectable_vars false aliases sigma t subst) in
-  effects := p :: !effects;
-  c
-
-let rec find_solution_type evarenv = function
-  | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv)
-  | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv)
-  | (id,ProjectEvar _)::l -> find_solution_type evarenv l
-  | [] -> assert false
-
-(* In case the solution to a projection problem requires the instantiation of
- * subsidiary evars, [do_projection_effects] performs them; it
- * also try to instantiate the type of those subsidiary evars if their
- * type is an evar too.
- *
- * Note: typing creates new evar problems, which induces a recursive dependency
- * with [define]. To avoid a too large set of recursive functions, we
- * pass [define] to [do_projection_effects] as a parameter.
- *)
-
-let rec do_projection_effects define_fun env ty evd = function
-  | ProjectVar -> evd
-  | ProjectEvar ((evk,argsv),evi,id,p) ->
-      let evd = Evd.define evk (mkVar id) evd in
-      (* TODO: simplify constraints involving evk *)
-      let evd = do_projection_effects define_fun env ty evd p in
-      let ty = whd_betadeltaiota env evd (Lazy.force ty) in
-      if not (isSort ty) then
-	(* Don't try to instantiate if a sort because if evar_concl is an
-           evar it may commit to a univ level which is not the right
-           one (however, regarding coercions, because t is obtained by
-           unif, we know that no coercion can be inserted) *)
-	let subst = make_pure_subst evi argsv in
-	let ty' = replace_vars subst evi.evar_concl in
-	let ty' = whd_evar evd ty' in
-	if isEvar ty' then define_fun env evd (destEvar ty') ty else evd
-      else
-	evd
-
-(* Assuming Σ; Γ, y1..yk |- c, [invert_arg_from_subst Γ k Σ [x1:=u1..xn:=un] c]
- * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid.
- * The strategy is to imitate the structure of c and then to invert
- * the variables of c (i.e. rels or vars of Γ) using the algorithm
- * implemented by project_with_effects/find_projectable_vars.
- * It returns either a unique solution or says whether 0 or more than
- * 1 solutions is found.
- *
- * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
- * Postcondition: if φ(x1..xn) is returned then
- *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
- *
- * The effects correspond to evars instantiated while trying to project.
- *
- * [invert_arg_from_subst] is used on instances of evars. Since the
- * evars are flexible, these instances are potentially erasable. This
- * is why we don't investigate whether evars in the instances of evars
- * are unifiable, to the contrary of [invert_definition].
- *)
-
-type projectibility_kind =
-  | NoUniqueProjection
-  | UniqueProjection of constr * evar_projection list
-
-type projectibility_status =
-  | CannotInvert
-  | Invertible of projectibility_kind
-
-let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
-  let effects = ref [] in
-  let rec aux k t =
-    let t = whd_evar evd t in
-    match kind_of_term t with
-    | Rel i when i>k0+k -> aux' k (mkRel (i-k))
-    | Var id -> aux' k t
-    | _ -> map_constr_with_binders succ aux k t
-  and aux' k t =
-    try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders
-    with Not_found ->
-      match expand_alias_once aliases t with
-      | None -> raise Not_found
-      | Some c -> aux k c in
-  try
-    let c = aux 0 c_in_env_extended_with_k_binders in
-    Invertible (UniqueProjection (c,!effects))
-  with
-    | Not_found -> CannotInvert
-    | NotUnique -> Invertible NoUniqueProjection
-
-let invert_arg fullenv evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
-  let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in
-  match res with
-  | Invertible (UniqueProjection (c,_)) when not (noccur_evar fullenv evd evk c)
-      ->
-      CannotInvert
-  | _ ->
-      res
-
-let effective_projections =
-  map_succeed (function Invertible c -> c | _ -> failwith"")
-
-let instance_of_projection f env t evd projs =
-  let ty = lazy (nf_evar evd (Retyping.get_type_of env evd t)) in
-  match projs with
-  | NoUniqueProjection -> raise NotUnique
-  | UniqueProjection (c,effects) ->
-      (List.fold_left (do_projection_effects f env ty) evd effects, c)
-
-exception NotEnoughInformationToInvert
-
-let extract_unique_projections projs =
-  List.map (function
-    | Invertible (UniqueProjection (c,_)) -> c
-    | _ ->
-        (* For instance, there are evars with non-invertible arguments and *)
-        (* we cannot arbitrarily restrict these evars before knowing if there *)
-        (* will really be used; it can also be due to some argument *)
-        (* (typically a rel) that is not inversible and that cannot be *)
-        (* inverted either because it is needed for typing the conclusion *)
-        (* of the evar to project *)
-      raise NotEnoughInformationToInvert) projs
-
-let extract_candidates sols =
-  try
-    Some
-      (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols)
-  with Exit ->
-    None
-
-let filter_of_projection = function Invertible _ -> true | _ -> false
-
-let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' =
-  let evi = Evd.find_undefined evd evk in
-  let subst,_ = make_projectable_subst aliases evd evi argsv in
-  let projs =
-    array_map_to_list (invert_arg fullenv evd aliases k evk subst) args' in
-  Array.of_list (extract_unique_projections projs)
-
-(* Redefines an evar with a smaller context (i.e. it may depend on less
- * variables) such that c becomes closed.
- * Example: in "fun (x:?1) (y:list ?2[x]) => x = y :> ?3[x,y] /\ x = nil bool"
- * ?3 <-- ?1          no pb: env of ?3 is larger than ?1's
- * ?1 <-- list ?2     pb: ?2 may depend on x, but not ?1.
- * What we do is that ?2 is defined by a new evar ?4 whose context will be
- * a prefix of ?2's env, included in ?1's env.
- *
- * If "hyps |- ?e : T" and "filter" selects a subset hyps' of hyps then
- * [do_restrict_hyps evd ?e filter] sets ?e:=?e'[hyps'] and returns ?e'
- * such that "hyps' |- ?e : T"
- *)
-
-let filter_effective_candidates evi filter candidates =
-  match filter with
-  | None -> candidates
-  | Some filter ->
-      let ids = List.map pi1 (list_filter_with filter (evar_context evi)) in
-      List.filter (fun a -> list_subset (Idset.elements (collect_vars a)) ids)
-        candidates
-
-let filter_candidates evd evk filter candidates_update =
-  let evi = Evd.find_undefined evd evk in
-  let candidates = match candidates_update with
-  | None -> evi.evar_candidates
-  | Some _ -> candidates_update
-  in
-  match candidates with
-  | None -> None
-  | Some l ->
-      let l' = filter_effective_candidates evi filter l in
-      if List.length l = List.length l' && candidates_update = None then
-        None
-      else
-        Some l'
-
-let closure_of_filter evd evk filter =
-  let evi = Evd.find_undefined evd evk in
-  let vars = collect_vars (nf_evar evd (evar_concl evi)) in
-  let test (id,c,_) b = b || Idset.mem id vars || c <> None in
-  let newfilter = List.map2 test (evar_context evi) filter in
-  if newfilter = evar_filter evi then None else Some newfilter
-
-let restrict_hyps evd evk filter candidates =
-    (* What to do with dependencies?
-       Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y.
-       - If y is in a non-erasable position in C(x,y) (i.e. it is not below an
-         occurrence of x in the hnf of C), then z should be removed too.
-       - If y is in a non-erasable position in T(x,y,z) then the problem is
-         unsolvable.
-       Computing whether y is erasable or not may be costly and the
-       interest for this early detection in practice is not obvious. We let
-       it for future work. In any case, thanks to the use of filters, the whole
-       (unrestricted) context remains consistent. *)
-    let candidates = filter_candidates evd evk (Some filter) candidates in
-    let typablefilter = closure_of_filter evd evk filter in
-    (typablefilter,candidates)
-
-exception EvarSolvedWhileRestricting of evar_map * constr
-
-let do_restrict_hyps evd (evk,args as ev) filter candidates =
-  let filter,candidates = match filter with
-  | None -> None,candidates
-  | Some filter -> restrict_hyps evd evk filter candidates in
-  match candidates,filter with
-  | Some [], _ -> error "Not solvable."
-  | Some [nc],_ ->
-      let evd = Evd.define evk nc evd in
-      raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev)))
-  | None, None -> evd,ev
-  | _ -> restrict_applied_evar evd ev filter candidates
-
-(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *)
-(* ?e is assumed to have no candidates *)
-
-let postpone_non_unique_projection env evd (evk,argsv as ev) sols rhs =
-  let rhs = expand_vars_in_term env rhs in
-  let filter =
-    restrict_upon_filter evd evk
-      (* Keep only variables that occur in rhs *)
-      (* This is not safe: is the variable is a local def, its body *)
-      (* may contain references to variables that are removed, leading to *)
-      (* a ill-formed context. We would actually need a notion of filter *)
-      (* that says that the body is hidden. Note that expand_vars_in_term *)
-      (* expands only rels and vars aliases, not rels or vars bound to an *)
-      (* arbitrary complex term *)
-      (fun a -> not (isRel a || isVar a)
-                || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols)
-      (Array.to_list argsv) in
-  let filter = match filter with
-  | None -> None
-  | Some filter -> closure_of_filter evd evk filter in
-  let candidates = extract_candidates sols in
-  if candidates <> None then
-    restrict_evar evd evk filter candidates
-  else
-    (* We made an approximation by not expanding a local definition *)
-    let evd,ev = restrict_applied_evar evd ev filter None in
-    let pb = (Reduction.CONV,env,mkEvar ev,rhs) in
-    Evd.add_conv_pb pb evd
-
-(* [postpone_evar_evar] postpones an equation of the form ?e1[?1] = ?e2[?2] *)
-
-let postpone_evar_evar f env evd filter1 ev1 filter2 ev2 =
-  (* Leave an equation between (restrictions of) ev1 andv ev2 *)
-  try
-    let evd,ev1' = do_restrict_hyps evd ev1 filter1 None in
-    try
-      let evd,ev2' = do_restrict_hyps evd ev2 filter2 None in
-      add_conv_pb (Reduction.CONV,env,mkEvar ev1',mkEvar ev2') evd
-    with EvarSolvedWhileRestricting (evd,ev2) ->
-      (* ev2 solved on the fly *)
-      f env evd ev1' ev2
-  with EvarSolvedWhileRestricting (evd,ev1) ->
-    (* ev1 solved on the fly *)
-    f env evd ev2 ev1
-
-(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic
- * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
- * - if there are at most one φj for each vj s.t. vj = φj(u1..un),
- *   we first restrict ?e2 to the subset v_k1..v_kq of the vj that are
- *   inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)]
- *   (this is a case of pattern-unification)
- * - symmetrically if there are at most one ψj for each uj s.t.
- *   uj = ψj(v1..vp),
- * - otherwise, each position i s.t. ui does not occur in v1..vp has to
- *   be restricted and similarly for the vi, and we leave the equation
- *   as an open equation (performed by [postpone_evar])
- *
- * Warning: the notion of unique φj is relative to some given class
- * of unification problems
- *
- * Note: argument f is the function used to instantiate evars.
- *)
-
-let are_canonical_instances args1 args2 env =
-  let n1 = Array.length args1 in
-  let n2 = Array.length args2 in
-  let rec aux n = function
-    | (id,_,c)::sign
-	when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
-	aux (n+1) sign
-    | [] ->
-	let rec aux2 n =
-	  n = n1 ||
-	  (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
-	in aux2 n
-    | _ -> false in
-  n1 = n2 & aux 0 (named_context env)
-
-let filter_compatible_candidates conv_algo env evd evi args rhs c =
-  let c' = instantiate_evar (evar_filtered_context evi) c args in
-  let evd, b = conv_algo env evd Reduction.CONV rhs c' in
-  if b then Some (c,evd) else None
-
-exception DoesNotPreserveCandidateRestriction
-
-let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) =
-  let evi1 = Evd.find evd evk1 in
-  let evi2 = Evd.find evd evk2 in
-  let cand1 = filter_candidates evd evk1 filter1 None in
-  let cand2 = evi2.evar_candidates in
-  match cand1, cand2 with
-  | _, None -> cand1
-  | None, Some _ -> raise DoesNotPreserveCandidateRestriction
-  | Some l1, Some l2 ->
-      let args1 = Array.to_list argsv1 in
-      let args2 = Array.to_list argsv2 in
-      let l1' = List.filter (fun c1 ->
-        let c1' = instantiate_evar (evar_filtered_context evi1) c1 args1 in
-        List.filter (fun c2 ->
-          (filter_compatible_candidates conv_algo env evd evi2 args2 c1' c2
-           <> None)) l2 <> []) l1 in
-      if List.length l1 = List.length l1' then None else Some l1'
-
-exception CannotProject of bool list option
-
-(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U.
-   Can ?n be instantiated by a term u depending essentially on xi such that the
-   FV(u[x1:=t1..xn:=tn]) are in the set U?
-   - If ti is a variable, it has to be in U.
-   - If ti is a constructor, its parameters cannot be erased even if u
-     matches on it, so we have to discard ti if the parameters
-     contain variables not in U.
-   - If ti is rigid, we have to discard it if it contains variables in U.
-
-  Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...]
-  then, occurrences of ?m in the ti can be seen, like variables, as occurrences
-  of subterms to eventually discard so as to be allowed to keep ti.
-*)
-
-let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t =
-  let f,args = decompose_app_vect t in
-  match kind_of_term f with
-  | Construct (ind,_) ->
-      let nparams =
-        (fst (Global.lookup_inductive ind)).Declarations.mind_nparams
-      in
-      if nparams > Array.length args
-      then true (* We don't try to be more clever *)
-      else
-        let params,_ = array_chop nparams args in
-        array_for_all (is_constrainable_in k g) params
-  | Ind _ -> array_for_all (is_constrainable_in k g) args
-  | Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2
-  | Evar (ev',_) -> ev' <> ev (*If ev' needed, one may also try to restrict it*)
-  | Var id -> Idset.mem id fv_ids
-  | Rel n -> n <= k || Intset.mem n fv_rels
-  | Sort _ -> true
-  | _ -> (* We don't try to be more clever *) true
-
-let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t =
-  let t = expansion_of_var aliases t in
-  match kind_of_term t with
-  | Var id -> Idset.mem id fv_ids
-  | Rel n -> n <= k || Intset.mem n fv_rels
-  | _ -> is_constrainable_in k (ev,fvs) t
-
-let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)=
-  let filter1 =
-    restrict_upon_filter evd evk1 (noccur_evar env evd evk2)
-      (Array.to_list argsv1)
-  in
-  let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
-  let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in
-  let filter2 =
-    restrict_upon_filter evd evk2 (noccur_evar env evd evk1)
-      (Array.to_list argsv2)
-  in
-  let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in
-  let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in
-  evd,ev1,ev2
-
-exception EvarSolvedOnTheFly of evar_map * constr
-
-let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) =
-  (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *)
-  let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in
-  let filter1 = restrict_upon_filter evd evk1
-    (has_constrainable_free_vars evd aliases k2 evk2 fvs2)
-    (Array.to_list argsv1) in
-  (* Only try pruning on variable substitutions, postpone otherwise. *)
-  (* Rules out non-linear instances. *)
-  if is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then
-    try
-      let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
-      let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in
-      evd,mkEvar (evk1',invert_invertible_arg env evd aliases k2 ev2 args1)
-    with
-    | EvarSolvedWhileRestricting (evd,ev1) ->
-        raise (EvarSolvedOnTheFly (evd,ev1))
-    | DoesNotPreserveCandidateRestriction | NotEnoughInformationToInvert ->
-        raise (CannotProject filter1)
-  else
-    raise (CannotProject filter1)
-
-let solve_evar_evar_l2r f g env evd aliases ev1 (evk2,_ as ev2) =
-  try
-    let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in
-    Evd.define evk2 body evd
-  with EvarSolvedOnTheFly (evd,c) ->
-    f env evd ev2 c
-
-let solve_evar_evar ?(force=false) f g env evd (evk1,args1 as ev1) (evk2,args2 as ev2) =
-  if are_canonical_instances args1 args2 env then
-    (* If instances are canonical, we solve the problem in linear time *)
-    let sign = evar_filtered_context (Evd.find evd evk2) in
-    let id_inst = list_map_to_array (fun (id,_,_) -> mkVar id) sign in
-    Evd.define evk2 (mkEvar(evk1,id_inst)) evd
-  else
-    let evd,ev1,ev2 =
-      (* If an evar occurs in the instance of the other evar and the
-         use of an heuristic is forced, we restrict *)
-      if force then ensure_evar_independent g env evd ev1 ev2 else (evd,ev1,ev2) in
-    let aliases = make_alias_map env in
-    try solve_evar_evar_l2r f g env evd aliases ev1 ev2
-    with CannotProject filter1 ->
-    try solve_evar_evar_l2r f g env evd aliases ev2 ev1
-    with CannotProject filter2 ->
-    postpone_evar_evar f env evd filter1 ev1 filter2 ev2
-
-type conv_fun =
-  env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool
-
-let check_evar_instance evd evk1 body conv_algo =
-  let evi = Evd.find evd evk1 in
-  let evenv = evar_unfiltered_env evi in
-  (* FIXME: The body might be ill-typed when this is called from w_merge *)
-  let ty =
-    try Retyping.get_type_of evenv evd body
-    with e when Errors.noncritical e -> error "Ill-typed evar instance"
-  in
-  let evd,b = conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl in
-  if b then evd else
-    user_err_loc (fst (evar_source evk1 evd),"",
-		  str "Unable to find a well-typed instantiation")
-
-(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint
- * definitions. We try to unify the ti with the ui pairwise. The pairs
- * that don't unify are discarded (i.e. ?e is redefined so that it does not
- * depend on these args). *)
-
-let solve_refl ?(can_drop=false) conv_algo env evd evk argsv1 argsv2 =
-  if array_equal eq_constr argsv1 argsv2 then evd else
-  (* Filter and restrict if needed *)
-  let untypedfilter =
-    restrict_upon_filter evd evk
-      (fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
-      (List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
-  let candidates = filter_candidates evd evk untypedfilter None in
-  let filter = match untypedfilter with
-    | None -> None
-    | Some filter -> closure_of_filter evd evk filter in
-  let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in
-  if fst ev1 = evk & can_drop then (* No refinement *) evd else
-    (* either progress, or not allowed to drop, e.g. to preserve possibly *)
-    (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *)
-    (* if e can depend on x until ?y is not resolved, or, conversely, we *)
-    (* don't know if ?y has to be unified with ?y, until e is resolved *)
-  let argsv2 = restrict_instance evd evk filter argsv2 in
-  let ev2 = (fst ev1,argsv2) in
-  (* Leave a unification problem *)
-  Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev1,mkEvar ev2) evd
-
-(* If the evar can be instantiated by a finite set of candidates known
-   in advance, we check which of them apply *)
-
-exception NoCandidates
-
-let solve_candidates conv_algo env evd (evk,argsv as ev) rhs =
-  let evi = Evd.find evd evk in
-  let args = Array.to_list argsv in
-  match evi.evar_candidates with
-  | None -> raise NoCandidates
-  | Some l ->
-      let l' =
-        list_map_filter
-          (filter_compatible_candidates conv_algo env evd evi args rhs) l in
-      match l' with
-      | [] -> error_cannot_unify env evd (mkEvar ev, rhs)
-      | [c,evd] ->
-          (* solve_candidates might have been called recursively in the mean *)
-          (* time and the evar been solved by the filtering process *)
-          if Evd.is_undefined evd evk then Evd.define evk c evd else evd
-      | l when List.length l < List.length l' ->
-          let candidates = List.map fst l in
-          restrict_evar evd evk None (Some candidates)
-      | l -> evd
-
-(* We try to instantiate the evar assuming the body won't depend
- * on arguments that are not Rels or Vars, or appearing several times
- * (i.e. we tackle a generalization of Miller-Pfenning patterns unification)
- *
- * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem
- * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs"
- *    where only Rel's and Var's are relevant in subst
- * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is
- *    not in the scope of ?ev. For instance, the problem
- *    "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because
- *    ?1 would be instantiated by y which is not in the scope of ?1.
- * 4) We try to "project" the term if the process of imitation fails
- *    and that only one projection is possible
- *
- * Note: we don't assume rhs in normal form, it may fail while it would
- * have succeeded after some reductions.
- *
- * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] c]
- * Precondition:  Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un
- * Postcondition: if φ(x1..xn) is returned then
- *                Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn)
- *)
-
-exception NotInvertibleUsingOurAlgorithm of constr
-exception NotEnoughInformationToProgress of (identifier * evar_projection) list
-exception NotEnoughInformationEvarEvar of constr
-exception OccurCheckIn of evar_map * constr
-
-let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs =
-  let aliases = make_alias_map env in
-  let evdref = ref evd in
-  let progress = ref false in
-  let evi = Evd.find evd evk in
-  let subst,cstr_subst = make_projectable_subst aliases evd evi argsv in
-
-  (* Projection *)
-  let project_variable t =
-    (* Evar/Var problem: unifiable iff variable projectable from ev subst *)
-    try
-      let sols = find_projectable_vars true aliases !evdref t subst in
-      let c, p = match sols with
-	| [] -> raise Not_found
-	| [id,p] -> (mkVar id, p)
-	| (id,p)::_::_ ->
-	    if choose then (mkVar id, p) else raise (NotUniqueInType sols)
-      in
-      let ty = lazy (Retyping.get_type_of env !evdref t) in
-      let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in
-      evdref := evd;
-      c
-    with
-      | Not_found -> raise (NotInvertibleUsingOurAlgorithm t)
-      | NotUniqueInType sols ->
-	  if not !progress then
-            raise (NotEnoughInformationToProgress sols);
-	  (* No unique projection but still restrict to where it is possible *)
-          (* materializing is necessary, but is restricting useful? *)
-          let ty = find_solution_type (evar_env evi) sols in
-          let sign = evar_filtered_context evi in
-          let ty' = instantiate_evar sign ty (Array.to_list argsv) in
-	  let (evd,evar,(evk',argsv' as ev')) =
-            materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in
-	  let ts = expansions_of_var aliases t in
-	  let test c = isEvar c or List.mem c ts in
-	  let filter = array_map_to_list test argsv' in
-          let filter = apply_subfilter (evar_filter (Evd.find_undefined evd evk)) filter in
-
-          let filter = closure_of_filter evd evk' filter in
-          let candidates = extract_candidates sols in
-          let evd =
-            if candidates <> None then restrict_evar evd evk' filter candidates
-            else
-              let evd,ev'' = restrict_applied_evar evd ev' filter None in
-              Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd in
-          evdref := evd;
-	  evar in
-
-  let rec imitate (env',k as envk) t =
-    let t = whd_evar !evdref t in
-    match kind_of_term t with
-    | Rel i when i>k ->
-        (match pi2 (Environ.lookup_rel (i-k) env') with
-        | None -> project_variable (mkRel (i-k))
-        | Some b ->
-          try project_variable (mkRel (i-k))
-          with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
-    | Var id ->
-        (match pi2 (Environ.lookup_named id env') with
-        | None -> project_variable t
-        | Some b ->
-          try project_variable t
-          with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
-    | Evar (evk',args' as ev') ->
-        if evk = evk' then raise (OccurCheckIn (evd,rhs));
-	(* Evar/Evar problem (but left evar is virtual) *)
-        let aliases = lift_aliases k aliases in
-        (try
-          let ev = (evk,Array.map (lift k) argsv) in
-          let evd,body = project_evar_on_evar conv_algo env' !evdref aliases k ev'  ev in
-	  evdref := evd;
-          body
-        with
-        | EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t
-        | CannotProject filter' ->
-          if not !progress then
-            raise (NotEnoughInformationEvarEvar t);
-	  (* Make the virtual left evar real *)
-	  let ty = get_type_of env' !evdref t in
-	  let (evd,evar'',ev'') =
-             materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
-          (* materialize_evar may instantiate ev' by another evar; adjust it *)
-          let (evk',args' as ev') = normalize_evar evd ev' in
-	  let evd =
-	     (* Try to project (a restriction of) the left evar ... *)
-	    try
-              let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in
-              Evd.define evk' body evd
-	    with
-            | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *)
-            | CannotProject filter'' ->
-	      (* ... or postpone the problem *)
-	      postpone_evar_evar (evar_define conv_algo) env' evd filter'' ev'' filter' ev' in
-	  evdref := evd;
-	  evar'')
-    | _ ->
-        progress := true;
-	match
-	  let c,args = decompose_app_vect t in
-	  match kind_of_term c with
-	  | Construct cstr when noccur_between 1 k t ->
-	    (* This is common case when inferring the return clause of match *)
-	    (* (currently rudimentary: we do not treat the case of multiple *)
-            (*  possible inversions; we do not treat overlap with a possible *)
-            (*  alternative inversion of the subterms of the constructor, etc)*)
-	    (match find_projectable_constructor env evd cstr k args cstr_subst with
-	     | _::_ as l -> Some (List.map mkVar l)
-	     | _ -> None)
-	  | _ -> None
-	with
-	| Some l ->
-            let ty = get_type_of env' !evdref t in
-            let candidates =
-              try
-                let t =
-                  map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
-	            imitate envk t in
-                t::l
-              with e when Errors.noncritical e -> l in
-            (match candidates with
-            | [x] -> x
-            | _ ->
-	      let (evd,evar'',ev'') =
-                materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
-              evdref := restrict_evar evd (fst ev'') None (Some candidates);
-              evar'')
-	| None ->
-	  (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
-	    map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
-	      imitate envk t in
-
-  let rhs = whd_beta evd rhs (* heuristic *) in
-  let body = imitate (env,0) rhs in
-  (!evdref,body)
-
-(* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is
- * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said,
- * [define] tries to find an instance lhs such that
- * "lhs [hyps:=args]" unifies to rhs. The term "lhs" must be closed in
- * context "hyps" and not referring to itself.
- *)
-
-and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs =
-  match kind_of_term rhs with
-  | Evar (evk2,argsv2 as ev2) ->
-      if evk = evk2 then
-        solve_refl ~can_drop:choose conv_algo env evd evk argsv argsv2
-      else
-        solve_evar_evar ~force:choose
-          (evar_define conv_algo) conv_algo env evd ev ev2
-  | _ ->
-  try solve_candidates conv_algo env evd ev rhs
-  with NoCandidates ->
-  try
-    let (evd',body) = invert_definition conv_algo choose env evd ev rhs in
-    if occur_meta body then error "Meta cannot occur in evar body.";
-    (* invert_definition may have instantiate some evars of rhs with evk *)
-    (* so we recheck acyclicity *)
-    if occur_evar evk body then raise (OccurCheckIn (evd',body));
-    (* needed only if an inferred type *)
-    let body = refresh_universes body in
-(* Cannot strictly type instantiations since the unification algorithm
- * does not unify applications from left to right.
- * e.g problem f x == g y yields x==y and f==g (in that order)
- * Another problem is that type variables are evars of type Type
-   let _ =
-      try
-        let env = evar_env evi in
-        let ty = evi.evar_concl in
-        Typing.check env evd' body ty
-      with e ->
-        pperrnl
-          (str "Ill-typed evar instantiation: " ++ fnl() ++
-           pr_evar_map evd' ++ fnl() ++
-           str "----> " ++ int ev ++ str " := " ++
-           print_constr body);
-        raise e in*)
-    let evd' = Evd.define evk body evd' in
-    check_evar_instance evd' evk body conv_algo
-  with
-    | NotEnoughInformationToProgress sols ->
-	postpone_non_unique_projection env evd ev sols rhs
-    | NotEnoughInformationEvarEvar t ->
-        add_conv_pb (Reduction.CONV,env,mkEvar ev,t) evd
-    | NotInvertibleUsingOurAlgorithm t ->
-	error_not_clean env evd evk t (evar_source evk evd)
-    | OccurCheckIn (evd,rhs) ->
-	(* last chance: rhs actually reduces to ev *)
-	let c = whd_betadeltaiota env evd rhs in
-	match kind_of_term c with
-	| Evar (evk',argsv2) when evk = evk' ->
-	    solve_refl
-	      (fun env sigma pb c c' -> (evd,is_fconv pb env sigma c c'))
-	      env evd evk argsv argsv2
-	| _ ->
-	    error_occur_check env evd evk rhs
-
-(* This code (i.e. solve_pb, etc.) takes a unification
- * problem, and tries to solve it. If it solves it, then it removes
- * all the conversion problems, and re-runs conversion on each one, in
- * the hopes that the new solution will aid in solving them.
- *
- * The kinds of problems it knows how to solve are those in which
- * the usable arguments of an existential var are all themselves
- * universal variables.
- * The solution to this problem is to do renaming for the Var's,
- * to make them match up with the Var's which are found in the
- * hyps of the existential, to do a "pop" for each Rel which is
- * not an argument of the existential, and a subst1 for each which
- * is, again, with the corresponding variable. This is done by
- * define
- *
- * Thus, we take the arguments of the existential which we are about
- * to assign, and zip them with the identifiers in the hypotheses.
- * Then, we process all the Var's in the arguments, and sort the
- * Rel's into ascending order.  Then, we just march up, doing
- * subst1's and pop's.
- *
- * NOTE: We can do this more efficiently for the relative arguments,
- * by building a long substituend by hand, but this is a pain in the
- * ass.
- *)
+let clear_hyps_in_evi env evdref hyps concl ids =
+  match clear_hyps_in_evi_main env evdref hyps [concl] ids with
+  | (nhyps,[nconcl]) -> (nhyps,nconcl)
+  | _ -> assert false
 
-let status_changed lev (pbty,_,t1,t2) =
-  (try ExistentialSet.mem (head_evar t1) lev with NoHeadEvar -> false) or
-  (try ExistentialSet.mem (head_evar t2) lev with NoHeadEvar -> false)
-
-let reconsider_conv_pbs conv_algo evd =
-  let (evd,pbs) = extract_changed_conv_pbs evd status_changed in
-  List.fold_left
-    (fun (evd,b as p) (pbty,env,t1,t2) ->
-      if b then conv_algo env evd pbty t1 t2 else p) (evd,true)
-    pbs
-
-(* Tries to solve problem t1 = t2.
- * Precondition: t1 is an uninstantiated evar
- * Returns an optional list of evars that were instantiated, or None
- * if the problem couldn't be solved. *)
-
-(* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
-let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) =
-  try
-    let t2 = whd_betaiota evd t2 in (* includes whd_evar *)
-    let evd =
-      match pbty with
-      | Some true when isEvar t2 ->
-          add_conv_pb (Reduction.CUMUL,env,mkEvar ev1,t2) evd
-      | Some false when isEvar t2 ->
-          add_conv_pb (Reduction.CUMUL,env,t2,mkEvar ev1) evd
-      | _ ->
-          evar_define conv_algo ~choose env evd ev1 t2 in
-    reconsider_conv_pbs conv_algo evd
-  with e when precatchable_exception e ->
-    (evd,false)
-
-(** The following functions return the set of evars immediately
-    contained in the object, including defined evars *)
-
-let evars_of_term c =
-  let rec evrec acc c =
-    match kind_of_term c with
-    | Evar (n, l) -> Intset.add n (Array.fold_left evrec acc l)
-    | _ -> fold_constr evrec acc c
-  in
-  evrec Intset.empty c
+let clear_hyps2_in_evi env evdref hyps t concl ids =
+  match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with
+  | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl)
+  | _ -> assert false
 
 (* spiwack: a few functions to gather evars on which goals depend. *)
 let queue_set q is_dependent set =
-  Intset.iter (fun a -> Queue.push (is_dependent,a) q) set
+  Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set
 let queue_term q is_dependent c =
   queue_set q is_dependent (evars_of_term c)
 
@@ -1830,7 +575,7 @@ let process_dependent_evar q acc evm is_dependent e =
   end (Environ.named_context_of_val evi.evar_hyps);
   match evi.evar_body with
   | Evar_empty ->
-      if is_dependent then Intmap.add e None acc else acc
+      if is_dependent then Evar.Map.add e None acc else acc
   | Evar_defined b ->
       let subevars = evars_of_term b in
       (* evars appearing in the definition of an evar [e] are marked
@@ -1838,14 +583,14 @@ let process_dependent_evar q acc evm is_dependent e =
          non-dependent goal, then, unless they are reach from another
          path, these evars are just other non-dependent goals. *)
       queue_set q is_dependent subevars;
-      if is_dependent then Intmap.add e (Some subevars) acc else acc
+      if is_dependent then Evar.Map.add e (Some subevars) acc else acc
 
 let gather_dependent_evars q evm =
-  let acc = ref Intmap.empty in
+  let acc = ref Evar.Map.empty in
   while not (Queue.is_empty q) do
     let (is_dependent,e) = Queue.pop q in
     (* checks if [e] has already been added to [!acc] *)
-    begin if not (Intmap.mem e !acc) then
+    begin if not (Evar.Map.mem e !acc) then
         acc := process_dependent_evar q !acc evm is_dependent e  
     end
   done;
@@ -1858,21 +603,6 @@ let gather_dependent_evars evm l =
 
 (* /spiwack *)
 
-let evars_of_named_context nc =
-  List.fold_right (fun (_, b, t) s ->
-    Option.fold_left (fun s t ->
-      Intset.union s (evars_of_term t))
-      (Intset.union s (evars_of_term t)) b)
-    nc Intset.empty
-
-let evars_of_evar_info evi =
-  Intset.union (evars_of_term evi.evar_concl)
-    (Intset.union
-	(match evi.evar_body with
-	| Evar_empty -> Intset.empty
-	| Evar_defined b -> evars_of_term b)
-	(evars_of_named_context (named_context_of_val evi.evar_hyps)))
-
 (** The following functions return the set of undefined evars
     contained in the object, the defined evars being traversed.
     This is roughly a combination of the previous functions and
@@ -1884,25 +614,25 @@ let undefined_evars_of_term evd t =
       | Evar (n, l) ->
 	let acc = Array.fold_left evrec acc l in
 	(try match (Evd.find evd n).evar_body with
-	  | Evar_empty -> Intset.add n acc
+	  | Evar_empty -> Evar.Set.add n acc
 	  | Evar_defined c -> evrec acc c
-	 with Not_found -> anomaly "undefined_evars_of_term: evar not found")
+	 with Not_found -> anomaly ~label:"undefined_evars_of_term" (Pp.str "evar not found"))
       | _ -> fold_constr evrec acc c
   in
-  evrec Intset.empty t
+  evrec Evar.Set.empty t
 
 let undefined_evars_of_named_context evd nc =
   List.fold_right (fun (_, b, t) s ->
     Option.fold_left (fun s t ->
-      Intset.union s (undefined_evars_of_term evd t))
-      (Intset.union s (undefined_evars_of_term evd t)) b)
-    nc Intset.empty
+      Evar.Set.union s (undefined_evars_of_term evd t))
+      (Evar.Set.union s (undefined_evars_of_term evd t)) b)
+    nc Evar.Set.empty
 
 let undefined_evars_of_evar_info evd evi =
-  Intset.union (undefined_evars_of_term evd evi.evar_concl)
-    (Intset.union
+  Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
+    (Evar.Set.union
        (match evi.evar_body with
-	 | Evar_empty -> Intset.empty
+	 | Evar_empty -> Evar.Set.empty
 	 | Evar_defined b -> undefined_evars_of_term evd b)
        (undefined_evars_of_named_context evd
 	  (named_context_of_val evi.evar_hyps)))
@@ -1919,21 +649,29 @@ let check_evars env initial_sigma sigma c =
 	  if not (Evd.mem initial_sigma evk) then
             let (loc,k) = evar_source evk sigma in
 	      match k with
-	      | ImplicitArg (gr, (i, id), false) -> ()
-	      | _ ->
-		  let evi = nf_evar_info sigma (Evd.find_undefined sigma evk) in
-		    error_unsolvable_implicit loc env sigma evi k None)
+	      | Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+	      | _ -> error_unsolvable_implicit loc env sigma evk None)
       | _ -> iter_constr proc_rec c
   in proc_rec c
 
-open Glob_term
+(* spiwack: this is a more complete version of
+   {!Termops.occur_evar}. The latter does not look recursively into an
+   [evar_map]. If unification only need to check superficially, tactics
+   do not have this luxury, and need the more complete version. *)
+let occur_evar_upto sigma n c =
+  let rec occur_rec c = match kind_of_term c with
+    | Evar (sp,_) when Evar.equal sp n -> raise Occur
+    | Evar e -> Option.iter occur_rec (existential_opt_value sigma e)
+    | _ -> iter_constr occur_rec c
+  in
+  try occur_rec c; false with Occur -> true
+
 
 (****************************************)
 (* Operations on value/type constraints *)
 (****************************************)
 
-type type_constraint_type = (int * int) option * constr
-type type_constraint = type_constraint_type option
+type type_constraint = types option
 
 type val_constraint = constr option
 
@@ -1954,14 +692,8 @@ type val_constraint = constr option
 (* The empty type constraint *)
 let empty_tycon = None
 
-let mk_tycon_type c = (None, c)
-let mk_abstr_tycon_type n c = (Some (n, n), c) (* First component is initial abstraction, second
-						  is current abstraction *)
-
 (* Builds a type constraint *)
-let mk_tycon ty = Some (mk_tycon_type ty)
-
-let mk_abstr_tycon n ty = Some (mk_abstr_tycon_type n ty)
+let mk_tycon ty = Some ty
 
 (* Constrains the value of a type *)
 let empty_valcon = None
@@ -1969,24 +701,34 @@ let empty_valcon = None
 (* Builds a value constraint *)
 let mk_valcon c = Some c
 
-
-let idx = id_of_string "x"
+let idx = Namegen.default_dependent_ident
 
 (* Refining an evar to a product *)
 
 let define_pure_evar_as_product evd evk =
   let evi = Evd.find_undefined evd evk in
-  let evenv = evar_unfiltered_env evi in
+  let evenv = evar_env evi in
   let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in
-  let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in
+  let concl = whd_evar evd evi.evar_concl in
+  let s = destSort concl in
+  let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
   let evd2,rng =
     let newenv = push_named (id, None, dom) evenv in
     let src = evar_source evk evd1 in
-    let filter = true::evar_filter evi in
-    new_type_evar evd1 newenv ~src ~filter in
+    let filter = Filter.extend 1 (evar_filter evi) in
+      if is_prop_sort s then
+       (* Impredicative product, conclusion must fall in [Prop]. *)
+        new_evar newenv evd1 concl ~src ~filter
+      else
+	let evd3, (rng, srng) =
+	  new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in
+	let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
+	let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in
+	  evd3, rng
+  in
   let prod = mkProd (Name id, dom, subst_var id rng) in
   let evd3 = Evd.define evk prod evd2 in
-  evd3,prod
+    evd3,prod
 
 (* Refine an applied evar to a product and returns its instantiation *)
 
@@ -1995,7 +737,7 @@ let define_evar_as_product evd (evk,args) =
   (* Quick way to compute the instantiation of evk with args *)
   let na,dom,rng = destProd prod in
   let evdom = mkEvar (fst (destEvar dom), args) in
-  let evrngargs = array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
   let evrng =  mkEvar (fst (destEvar rng), evrngargs) in
   evd,mkProd (na, evdom, evrng)
 
@@ -2010,19 +752,19 @@ let define_evar_as_product evd (evk,args) =
 
 let define_pure_evar_as_lambda env evd evk =
   let evi = Evd.find_undefined evd evk in
-  let evenv = evar_unfiltered_env evi in
+  let evenv = evar_env evi in
   let typ = whd_betadeltaiota env evd (evar_concl evi) in
   let evd1,(na,dom,rng) = match kind_of_term typ with
   | Prod (na,dom,rng) -> (evd,(na,dom,rng))
   | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ
-  | _ -> error_not_product_loc dummy_loc env evd typ in
+  | _ -> error_not_product_loc Loc.ghost env evd typ in
   let avoid = ids_of_named_context (evar_context evi) in
   let id =
     next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in
   let newenv = push_named (id, None, dom) evenv in
-  let filter = true::evar_filter evi in
+  let filter = Filter.extend 1 (evar_filter evi) in
   let src = evar_source evk evd1 in
-  let evd2,body = new_evar evd1 newenv ~src (subst1 (mkVar id) rng) ~filter in
+  let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
   let lam = mkLambda (Name id, dom, subst_var id body) in
   Evd.define evk lam evd2, lam
 
@@ -2030,7 +772,7 @@ let define_evar_as_lambda env evd (evk,args) =
   let evd,lam = define_pure_evar_as_lambda env evd evk in
   (* Quick way to compute the instantiation of evk with args *)
   let na,dom,body = destLambda lam in
-  let evbodyargs = array_cons (mkRel 1) (Array.map (lift 1) args) in
+  let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in
   let evbody = mkEvar (fst (destEvar body), evbodyargs) in
   evd,mkLambda (na, dom, evbody)
 
@@ -2041,30 +783,29 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function
       let evd,lam = define_pure_evar_as_lambda env evd evk in
       let _,_,body = destLambda lam in
       let evk = fst (destEvar body) in
-      evar_absorb_arguments env evd (evk, array_cons a args) l
+      evar_absorb_arguments env evd (evk, Array.cons a args) l
 
 (* Refining an evar to a sort *)
 
-let define_evar_as_sort evd (ev,args) =
-  let evd, s = new_sort_variable evd in
-    Evd.define ev (mkSort s) evd, s
+let define_evar_as_sort env evd (ev,args) =
+  let evd, u = new_univ_variable univ_rigid evd in
+  let evi = Evd.find_undefined evd ev in 
+  let s = Type u in
+  let evd' = Evd.define ev (mkSort s) evd in
+    Evd.set_leq_sort env evd' (Type (Univ.super u)) (destSort evi.evar_concl), s
 
 (* We don't try to guess in which sort the type should be defined, since
    any type has type Type. May cause some trouble, but not so far... *)
 
 let judge_of_new_Type evd =
-  let evd', s = new_univ_variable evd in
-    evd', Typeops.judge_of_type s
+  let evd', s = new_univ_variable univ_rigid evd in
+    evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
 
 (* Propagation of constraints through application and abstraction:
    Given a type constraint on a functional term, returns the type
    constraint on its domain and codomain. If the input constraint is
    an evar instantiate it with the product of 2 new evars. *)
 
-let unlift_tycon init cur c =
-  if cur = 1 then None, c
-  else Some (init, pred cur), c
-
 let split_tycon loc env evd tycon =
   let rec real_split evd c =
     let t = whd_betadeltaiota env evd c in
@@ -2081,35 +822,19 @@ let split_tycon loc env evd tycon =
   in
     match tycon with
       | None -> evd,(Anonymous,None,None)
-      | Some (abs, c) ->
-	  (match abs with
-	       None ->
-		 let evd', (n, dom, rng) = real_split evd c in
-		   evd', (n, mk_tycon dom, mk_tycon rng)
-	     | Some (init, cur) ->
-		 evd, (Anonymous, None, Some (unlift_tycon init cur c)))
-
-let valcon_of_tycon x =
-  match x with
-    | Some (None, t) -> Some t
-    | _ -> None
-
-let lift_abstr_tycon_type n (abs, t) =
-  match abs with
-      None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction")
-    | Some (init, abs) ->
-	let abs' = abs + n in
-	  if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type")
-	  else (Some (init, abs'), t)
-
-let lift_tycon_type n (abs, t) = (abs, lift n t)
-let lift_tycon n = Option.map (lift_tycon_type n)
-
-let pr_tycon_type env (abs, t) =
-  match abs with
-      None -> Termops.print_constr_env env t
-    | Some (init, cur) -> str "Abstract (" ++ int init ++ str ","  ++ int cur ++ str ") " ++ Termops.print_constr_env env t
+      | Some c ->
+	  let evd', (n, dom, rng) = real_split evd c in
+	    evd', (n, mk_tycon dom, mk_tycon rng)
+
+let valcon_of_tycon x = x
+let lift_tycon n = Option.map (lift n)
 
 let pr_tycon env = function
     None -> str "None"
-  | Some t -> pr_tycon_type env t
+  | Some t -> Termops.print_constr_env env t
+
+let subterm_source evk (loc,k) =
+  let evk = match k with
+    | Evar_kinds.SubEvar (evk) -> evk
+    | _ -> evk in
+  (loc,Evar_kinds.SubEvar evk)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 9269f138..f89266a6 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -1,19 +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 Util
 open Names
-open Glob_term
 open Term
-open Sign
+open Context
 open Evd
 open Environ
-open Reductionops
 
 (** {5 This modules provides useful functions for unification modulo evars } *)
 
@@ -23,23 +20,49 @@ open Reductionops
 val new_meta : unit -> metavariable
 val mk_new_meta : unit -> constr
 
-(** [new_untyped_evar] is a generator of unique evar keys *)
-val new_untyped_evar : unit -> existential_key
-
 (** {6 Creating a fresh evar given their type and context} *)
 val new_evar :
-  evar_map -> env -> ?src:loc * hole_kind -> ?filter:bool list ->
-  ?candidates:constr list -> types -> evar_map * constr
+  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  ?candidates:constr list -> ?store:Store.t ->
+  ?naming:Misctypes.intro_pattern_naming_expr ->
+  ?principal:bool -> types -> evar_map * constr
+
+val new_pure_evar :
+  named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  ?candidates:constr list -> ?store:Store.t ->
+  ?naming:Misctypes.intro_pattern_naming_expr ->
+  ?principal:bool -> types -> evar_map * evar
+
+val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar
 
 (** the same with side-effects *)
 val e_new_evar :
-  evar_map ref -> env -> ?src:loc * hole_kind -> ?filter:bool list ->
-  ?candidates:constr list -> types -> constr
+  env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  ?candidates:constr list -> ?store:Store.t ->
+  ?naming:Misctypes.intro_pattern_naming_expr ->
+  ?principal:bool -> types -> constr
 
 (** Create a new Type existential variable, as we keep track of 
     them during type-checking and unification. *)
 val new_type_evar :
-  ?src:loc * hole_kind -> ?filter:bool list -> evar_map -> env -> evar_map * constr
+  env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid ->
+  evar_map * (constr * sorts)
+
+val e_new_type_evar : env -> evar_map ref ->
+  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t ->
+  ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts
+
+val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr
+val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr
+
+val restrict_evar : evar_map -> existential_key -> Filter.t ->
+  constr list option -> evar_map * existential_key
+
+(** Polymorphic constants *)
+
+val new_global : evar_map -> Globnames.global_reference -> evar_map * constr
+val e_new_global : evar_map ref -> Globnames.global_reference -> constr
 
 (** Create a fresh evar in a context different from its definition context:
    [new_evar_instance sign evd ty inst] creates a new evar of context
@@ -48,30 +71,17 @@ val new_type_evar :
    of [inst] are typed in the occurrence context and their type (seen
    as a telescope) is [sign] *)
 val new_evar_instance :
- named_context_val -> evar_map -> types -> ?src:loc * hole_kind -> ?filter:bool list -> ?candidates:constr list -> constr list -> evar_map * constr
-
-val make_pure_subst : evar_info -> constr array -> (identifier * constr) list
+ named_context_val -> evar_map -> types -> 
+  ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> 
+  ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr ->
+  ?principal:bool ->
+  constr list -> evar_map * constr
 
-(** {6 Instantiate evars} *)
-
-type conv_fun =
-  env ->  evar_map -> conv_pb -> constr -> constr -> evar_map * bool
-
-(** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]),
-   possibly solving related unification problems, possibly leaving open
-   some problems that cannot be solved in a unique way (except if choose is
-   true); fails if the instance is not valid for the given [ev] *)
-val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> 
-  existential -> constr -> evar_map
+val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list
 
 (** {6 Evars/Metas switching...} *)
 
-(** [evars_to_metas] generates new metavariables for each non dependent
-   existential and performs the replacement in the given constr; it also
-   returns the evar_map extended with dependent evars *)
-val evars_to_metas : evar_map -> open_constr -> (evar_map * constr)
-
-val non_instantiated : evar_map -> (evar * evar_info) list
+val non_instantiated : evar_map -> evar_info Evar.Map.t
 
 (** {6 Unification utils} *)
 
@@ -82,46 +92,26 @@ val head_evar : constr -> existential_key (** may raise NoHeadEvar *)
 (* Expand head evar if any *)
 val whd_head_evar :  evar_map -> constr -> constr
 
+(* An over-approximation of [has_undefined (nf_evars evd c)] *)
+val has_undefined_evars : evar_map -> constr -> bool
+
 val is_ground_term :  evar_map -> constr -> bool
 val is_ground_env  :  evar_map -> env -> bool
-val solve_refl : ?can_drop:bool -> conv_fun -> env ->  evar_map ->
-  existential_key -> constr array -> constr array -> evar_map
-val solve_evar_evar : ?force:bool ->
-  (env -> evar_map -> existential -> constr -> evar_map) -> conv_fun ->
-  env ->  evar_map -> existential -> existential -> evar_map
-
-val solve_simple_eqn : conv_fun -> ?choose:bool -> env ->  evar_map ->
-  bool option * existential * constr -> evar_map * bool
-val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool
-
 (** [check_evars env initial_sigma extended_sigma c] fails if some
    new unresolved evar remains in [c] *)
 val check_evars : env -> evar_map -> evar_map -> constr -> unit
 
 val define_evar_as_product : evar_map -> existential -> evar_map * types
 val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types
-val define_evar_as_sort : evar_map -> existential -> evar_map * sorts
-
-val is_unification_pattern_evar : env -> evar_map -> existential -> constr list ->
-  constr -> constr list option
-
-val is_unification_pattern : env * int -> evar_map -> constr -> constr list ->
-  constr -> constr list option
+val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts
 
+(** Instantiate an evar by as many lambda's as needed so that its arguments
+    are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into
+    [?y[vars1:=args1,vars:=args]] with
+    [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *)
 val evar_absorb_arguments : env -> evar_map -> existential -> constr list ->
   evar_map * existential
 
-val solve_pattern_eqn : env -> constr list -> constr -> constr
-
-(** The following functions return the set of evars immediately
-    contained in the object, including defined evars *)
-
-
-val evars_of_term : constr -> Intset.t
-
-val evars_of_named_context : named_context -> Intset.t
-val evars_of_evar_info : evar_info -> Intset.t
-
 (** [gather_dependent_evars evm seeds] classifies the evars in [evm]
     as dependent_evars and goals (these may overlap). A goal is an
     evar in [seeds] or an evar appearing in the (partial) definition
@@ -131,43 +121,39 @@ val evars_of_evar_info : evar_info -> Intset.t
     associating to each dependent evar [None] if it has no (partial)
     definition or [Some s] if [s] is the list of evars appearing in
     its (partial) definition. *)
-val gather_dependent_evars : evar_map -> evar list -> (Intset.t option) Intmap.t
+val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t
 
 (** The following functions return the set of undefined evars
     contained in the object, the defined evars being traversed.
     This is roughly a combination of the previous functions and
     [nf_evar]. *)
 
-val undefined_evars_of_term : evar_map -> constr -> Intset.t
-val undefined_evars_of_named_context : evar_map -> named_context -> Intset.t
-val undefined_evars_of_evar_info : evar_map -> evar_info -> Intset.t
+val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t
+val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t
+val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t
+
+(** [occur_evar_upto sigma k c] returns [true] if [k] appears in
+    [c]. It looks up recursively in [sigma] for the value of existential
+    variables. *)
+val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool
 
 (** {6 Value/Type constraints} *)
 
 val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment
 
-type type_constraint_type = (int * int) option * constr
-type type_constraint = type_constraint_type option
-
+type type_constraint = types option
 type val_constraint = constr option
 
 val empty_tycon : type_constraint
-val mk_tycon_type : constr -> type_constraint_type
-val mk_abstr_tycon_type : int -> constr -> type_constraint_type
 val mk_tycon : constr -> type_constraint
-val mk_abstr_tycon : int -> constr -> type_constraint
 val empty_valcon : val_constraint
 val mk_valcon : constr -> val_constraint
 
 val split_tycon :
-  loc -> env ->  evar_map -> type_constraint ->
-    evar_map * (name * type_constraint * type_constraint)
+  Loc.t -> env ->  evar_map -> type_constraint ->
+    evar_map * (Name.t * type_constraint * type_constraint)
 
 val valcon_of_tycon : type_constraint -> val_constraint
-
-val lift_abstr_tycon_type : int -> type_constraint_type -> type_constraint_type
-
-val lift_tycon_type : int -> type_constraint_type -> type_constraint_type
 val lift_tycon : int -> type_constraint -> type_constraint
 
 (***********************************************************)
@@ -192,17 +178,29 @@ val nf_evar_info : evar_map -> evar_info -> evar_info
 val nf_evar_map : evar_map -> evar_map
 val nf_evar_map_undefined : evar_map -> evar_map
 
+val env_nf_evar : evar_map -> env -> env
+val env_nf_betaiotaevar : evar_map -> env -> env
+
+val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment
+val jv_nf_betaiotaevar :
+  evar_map -> unsafe_judgment array -> unsafe_judgment array
+(** Presenting terms without solved evars *)
+
+val nf_evars_universes : evar_map -> constr -> constr
+
+val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr)
+val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst
+
+(** Normalize the evar map w.r.t. universes, after simplification of constraints.
+    Return the substitution function for constrs as well. *)
+val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr)
+
 (** Replacing all evars, possibly raising [Uninstantiated_evar] *)
 exception Uninstantiated_evar of existential_key
 val flush_and_check_evars :  evar_map -> constr -> constr
 
-(** Replace the vars and rels that are aliases to other vars and rels by 
-   their representative that is most ancient in the context *)
-val expand_vars_in_term : env -> constr -> constr
-
 (** {6 debug pretty-printer:} *)
 
-val pr_tycon_type : env -> type_constraint_type -> Pp.std_ppcmds
 val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
 
 
@@ -210,24 +208,31 @@ val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
 raise OccurHypInSimpleClause if the removal breaks dependencies *)
 
 type clear_dependency_error =
-| OccurHypInSimpleClause of identifier option
+| OccurHypInSimpleClause of Id.t option
 | EvarTypingBreak of existential
 
-exception ClearDependencyError of identifier * clear_dependency_error
+exception ClearDependencyError of Id.t * clear_dependency_error
 
 (* spiwack: marks an evar that has been "defined" by clear.
     used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
-val cleared : bool Store.Field.t
+val cleared : bool Store.field
 
-val clear_hyps_in_evi : evar_map ref -> named_context_val -> types ->
-  identifier list -> named_context_val * types
+val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types ->
+  Id.Set.t -> named_context_val * types
+
+val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types ->
+  Id.Set.t -> named_context_val * types * types
 
 val push_rel_context_to_named_context : Environ.env -> types ->
-  named_context_val * types * constr list * constr list
+  named_context_val * types * constr list * constr list * (identifier*constr) list
 
 val generalize_evar_over_rels : evar_map -> existential -> types * constr list
 
-val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun ->
-  evar_map
+(** Evar combinators *)
+
+val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a
+val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a
+val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a
 
-val remove_instance_local_defs : evar_map -> existential_key -> constr list -> constr list
+val subterm_source : existential_key -> Evar_kinds.t Loc.located ->
+  Evar_kinds.t Loc.located
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 72dc27e6..ee72d314 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -1,43 +1,134 @@
 (************************************************************************)
 (*  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
 open Nameops
 open Term
+open Vars
 open Termops
-open Sign
 open Environ
-open Libnames
-open Mod_subst
+open Globnames
+
+(** Generic filters *)
+module Filter :
+sig
+  type t
+  val equal : t -> t -> bool
+  val identity : t
+  val filter_list : t -> 'a list -> 'a list
+  val filter_array : t -> 'a array -> 'a array
+  val extend : int -> t -> t
+  val compose : t -> t -> t
+  val apply_subfilter : t -> bool list -> t
+  val restrict_upon : t -> int -> (int -> bool) -> t option
+  val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
+  val make : bool list -> t
+  val repr :  t -> bool list option
+end =
+struct
+  type t = bool list option
+  (** We guarantee through the interface that if a filter is [Some _] then it
+      contains at least one [false] somewhere. *)
+
+  let identity = None
+
+  let rec equal l1 l2 = match l1, l2 with
+  | [], [] -> true
+  | h1 :: l1, h2 :: l2 ->
+    (if h1 then h2 else not h2) && equal l1 l2
+  | _ -> false
+
+  let equal l1 l2 = match l1, l2 with
+  | None, None -> true
+  | Some _, None | None, Some _ -> false
+  | Some l1, Some l2 -> equal l1 l2
+
+  let rec is_identity = function
+  | [] -> true
+  | true :: l -> is_identity l
+  | false :: _ -> false
+
+  let normalize f = if is_identity f then None else Some f
+
+  let filter_list f l = match f with
+  | None -> l
+  | Some f -> CList.filter_with f l
+
+  let filter_array f v = match f with
+  | None -> v
+  | Some f -> CArray.filter_with f v
+
+  let rec extend n l =
+    if n = 0 then l
+    else extend (pred n) (true :: l)
+
+  let extend n = function
+  | None -> None
+  | Some f -> Some (extend n f)
+
+  let compose f1 f2 = match f1 with
+  | None -> f2
+  | Some f1 ->
+    match f2 with
+    | None -> None
+    | Some f2 -> normalize (CList.filter_with f1 f2)
+
+  let apply_subfilter_array filter subfilter =
+    (** In both cases we statically know that the argument will contain at
+        least one [false] *)
+    match filter with
+    | None -> Some (Array.to_list subfilter)
+    | Some f ->
+    let len = Array.length subfilter in
+    let fold b (i, ans) =
+      if b then
+        let () = assert (0 <= i) in
+        (pred i, Array.unsafe_get subfilter i :: ans)
+      else
+        (i, false :: ans)
+    in
+    Some (snd (List.fold_right fold f (pred len, [])))
+
+  let apply_subfilter filter subfilter =
+    apply_subfilter_array filter (Array.of_list subfilter)
+
+  let restrict_upon f len p =
+    let newfilter = Array.init len p in
+    if Array.for_all (fun id -> id) newfilter then None
+    else
+      Some (apply_subfilter_array f newfilter)
 
-(* The kinds of existential variable *)
+  let map_along f flt l =
+    let ans = match flt with
+    | None -> List.map (fun x -> f true x) l
+    | Some flt -> List.map2 f flt l
+    in
+    normalize ans
 
-type obligation_definition_status = Define of bool | Expand
+  let make l = normalize l
+
+  let repr f = f
+
+end
 
-type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option) * bool
-  | BinderType of name
-  | QuestionMark of obligation_definition_status
-  | CasesType
-  | InternalHole
-  | TomatchTypeParameter of inductive * int
-  | GoalEvar
-  | ImpossibleCase
-  | MatchingVar of bool * identifier
+(* The kinds of existential variables are now defined in [Evar_kinds] *)
 
 (* The type of mappings for existential variables *)
 
-type evar = existential_key
+module Dummy = struct end
+module Store = Store.Make(Dummy)
 
-let string_of_existential evk = "?" ^ string_of_int evk
-let existential_of_int evk = evk
+type evar = Term.existential_key
+
+let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk)
 
 type evar_body =
   | Evar_empty
@@ -47,8 +138,8 @@ type evar_info = {
   evar_concl : constr;
   evar_hyps : named_context_val;
   evar_body : evar_body;
-  evar_filter : bool list;
-  evar_source : hole_kind located;
+  evar_filter : Filter.t;
+  evar_source : Evar_kinds.t Loc.located;
   evar_candidates : constr list option; (* if not None, list of allowed instances *)
   evar_extra : Store.t }
 
@@ -56,194 +147,311 @@ let make_evar hyps ccl = {
   evar_concl = ccl;
   evar_hyps = hyps;
   evar_body = Evar_empty;
-  evar_filter = List.map (fun _ -> true) (named_context_of_val hyps);
-  evar_source = (dummy_loc,InternalHole);
+  evar_filter = Filter.identity;
+  evar_source = (Loc.ghost,Evar_kinds.InternalHole);
   evar_candidates = None;
   evar_extra = Store.empty
 }
 
+let instance_mismatch () =
+  anomaly (Pp.str "Signature and its instance do not match")
+
 let evar_concl evi = evi.evar_concl
-let evar_hyps evi = evi.evar_hyps
-let evar_context evi = named_context_of_val evi.evar_hyps
-let evar_body evi = evi.evar_body
+
 let evar_filter evi = evi.evar_filter
+
+let evar_body evi = evi.evar_body
+
+let evar_context evi = named_context_of_val evi.evar_hyps
+
 let evar_filtered_context evi =
-  snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi))
-let evar_filtered_hyps evi =
-  List.fold_right push_named_context_val (evar_filtered_context evi)
-    empty_named_context_val
-let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps
-let evar_env evi =
-  List.fold_right push_named (evar_filtered_context evi)
-    (reset_context (Global.env()))
-
-let eq_evar_info ei1 ei2 =
-  ei1 == ei2 ||
-    eq_constr ei1.evar_concl ei2.evar_concl &&
-    eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) &&
-    ei1.evar_body = ei2.evar_body
-
-(* spiwack: Revised hierarchy :
-   - ExistentialMap ( Maps of existential_keys )
-   - EvarInfoMap ( .t = evar_info ExistentialMap.t * evar_info ExistentialMap )
-   - EvarMap ( .t = EvarInfoMap.t * sort_constraints )
-   - evar_map (exported)
-*)
+  Filter.filter_list (evar_filter evi) (evar_context evi)
 
-module ExistentialMap = Intmap
-module ExistentialSet = Intset
+let evar_hyps evi = evi.evar_hyps
+
+let evar_filtered_hyps evi = match Filter.repr (evar_filter evi) with
+| None -> evar_hyps evi
+| Some filter ->
+  let rec make_hyps filter ctxt = match filter, ctxt with
+  | [], [] -> empty_named_context_val
+  | false :: filter, _ :: ctxt -> make_hyps filter ctxt
+  | true :: filter, decl :: ctxt ->
+    let hyps = make_hyps filter ctxt in
+    push_named_context_val decl hyps
+  | _ -> instance_mismatch ()
+  in
+  make_hyps filter (evar_context evi)
+
+let evar_env evi = Global.env_of_context evi.evar_hyps
+
+let evar_filtered_env evi = match Filter.repr (evar_filter evi) with
+| None -> evar_env evi
+| Some filter ->
+  let rec make_env filter ctxt = match filter, ctxt with
+  | [], [] -> reset_context (Global.env ())
+  | false :: filter, _ :: ctxt -> make_env filter ctxt
+  | true :: filter, decl :: ctxt ->
+    let env = make_env filter ctxt in
+    push_named decl env
+  | _ -> instance_mismatch ()
+  in
+  make_env filter (evar_context evi)
+
+let map_evar_body f = function
+  | Evar_empty -> Evar_empty
+  | Evar_defined d -> Evar_defined (f d)
+
+let map_evar_info f evi =
+  {evi with
+    evar_body = map_evar_body f evi.evar_body;
+    evar_hyps = map_named_val f evi.evar_hyps;
+    evar_concl = f evi.evar_concl;
+    evar_candidates = Option.map (List.map f) evi.evar_candidates }
+
+let evar_ident_info evi =
+  match evi.evar_source with
+  | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id
+  | _,Evar_kinds.VarInstance id -> id
+  | _,Evar_kinds.GoalEvar -> Id.of_string "Goal"
+  | _ ->
+      let env = reset_with_named_context evi.evar_hyps (Global.env()) in
+      Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous
 
 (* This exception is raised by *.existential_value *)
 exception NotInstantiatedEvar
 
 (* Note: let-in contributes to the instance *)
-let make_evar_instance sign args =
-  let rec instrec = function
-    | (id,_,_) :: sign, c::args when isVarId id c -> instrec (sign,args)
-    | (id,_,_) :: sign, c::args -> (id,c) :: instrec (sign,args)
-    | [],[] -> []
-    | [],_ | _,[] -> anomaly "Signature and its instance do not match"
-  in
-    instrec (sign,args)
-
-let instantiate_evar sign c args =
-  let inst = make_evar_instance sign args in
-  if inst = [] then c else replace_vars inst c
-
-module EvarInfoMap = struct
-  type t = evar_info ExistentialMap.t * evar_info ExistentialMap.t
-
-  let empty = ExistentialMap.empty, ExistentialMap.empty
-
-  let is_empty (d,u) = ExistentialMap.is_empty d && ExistentialMap.is_empty u
-
-  let has_undefined (_,u) = not (ExistentialMap.is_empty u)
-
-  let to_list (def,undef) =
-    (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *)
-    let l = ref [] in
-    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) def;
-    ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) undef;
-    !l
-
-  let undefined_list (def,undef) =
-    (* Order is important: needs ocaml >= 3.08.4 from which "fold" is a
-       "fold_left" *)
-    ExistentialMap.fold (fun evk evi l -> (evk,evi)::l) undef []
-
-  let undefined_evars (def,undef) = (ExistentialMap.empty,undef)
-  let defined_evars (def,undef) = (def,ExistentialMap.empty)
-
-  let find (def,undef) k =
-    try ExistentialMap.find k def
-    with Not_found -> ExistentialMap.find k undef
-  let find_undefined (def,undef) k = ExistentialMap.find k undef
-  let remove (def,undef) k =
-    (ExistentialMap.remove k def,ExistentialMap.remove k undef)
-  let mem (def,undef) k =
-    ExistentialMap.mem k def || ExistentialMap.mem k undef
-  let fold (def,undef) f a =
-    ExistentialMap.fold f def (ExistentialMap.fold f undef a)
-  let fold_undefined (def,undef) f a =
-    ExistentialMap.fold f undef a
-  let exists_undefined (def,undef) f =
-    ExistentialMap.fold (fun k v b -> b || f k v) undef false
-
-  let add (def,undef) evk newinfo =
-    if newinfo.evar_body = Evar_empty then
-      (def,ExistentialMap.add evk newinfo undef)
-    else
-      (ExistentialMap.add evk newinfo def,undef)
-
-  let add_undefined (def,undef) evk newinfo =
-    assert (newinfo.evar_body = Evar_empty);
-    (def,ExistentialMap.add evk newinfo undef)
-
-  let map f (def,undef) = (ExistentialMap.map f def, ExistentialMap.map f undef)
-
-  let define (def,undef) evk body =
-    let oldinfo =
-      try ExistentialMap.find evk undef
-      with Not_found -> 
-	try ExistentialMap.find evk def
-	with Not_found -> 
-	  anomaly "Evd.define: cannot define undeclared evar" in
-    let newinfo =
-      { oldinfo with
-	  evar_body = Evar_defined body } in
-      match oldinfo.evar_body with
-	| Evar_empty ->
-	    (ExistentialMap.add evk newinfo def,ExistentialMap.remove evk undef)
-	| _ ->
-	    anomaly "Evd.define: cannot define an evar twice"
-
-  let is_evar = mem
-
-  let is_defined (def,undef) evk = ExistentialMap.mem evk def
-  let is_undefined (def,undef) evk = ExistentialMap.mem evk undef
-
-  (*******************************************************************)
-  (* Formerly Instantiate module *)
-
-  (* Existentials. *)
-
-  let existential_type sigma (n,args) =
-    let info =
-      try find sigma n
-      with Not_found ->
-	anomaly ("Evar "^(string_of_existential n)^" was not declared") in
-    let hyps = evar_filtered_context info in
-      instantiate_evar hyps info.evar_concl (Array.to_list args)
-
-  let existential_value sigma (n,args) =
-    let info = find sigma n in
-    let hyps = evar_filtered_context info in
-      match evar_body info with
-	| Evar_defined c ->
-	    instantiate_evar hyps c (Array.to_list args)
-	| Evar_empty ->
-	    raise NotInstantiatedEvar
-
-  let existential_opt_value sigma ev =
-    try Some (existential_value sigma ev)
-    with NotInstantiatedEvar -> None
 
+let evar_instance_array test_id info args =
+  let len = Array.length args in
+  let rec instrec filter ctxt i = match filter, ctxt with
+  | [], [] ->
+    if Int.equal i len then []
+    else instance_mismatch ()
+  | false :: filter, _ :: ctxt ->
+    instrec filter ctxt i
+  | true :: filter, (id, _, _) :: ctxt ->
+    if i < len then
+      let c = Array.unsafe_get args i in
+      if test_id id c then instrec filter ctxt (succ i)
+      else (id, c) :: instrec filter ctxt (succ i)
+    else instance_mismatch ()
+  | _ -> instance_mismatch ()
+  in
+  match Filter.repr (evar_filter info) with
+  | None ->
+    let map i (id, _, _) =
+      if (i < len) then
+        let c = Array.unsafe_get args i in
+        if test_id id c then None else Some (id,c)
+      else instance_mismatch ()
+    in
+    List.map_filter_i map (evar_context info)
+  | Some filter ->
+    instrec filter (evar_context info) 0
+
+let make_evar_instance_array info args =
+  evar_instance_array isVarId info args
+
+let instantiate_evar_array info c args =
+  let inst = make_evar_instance_array info args in
+  match inst with
+  | [] -> c
+  | _ -> replace_vars inst c
+
+module StringOrd = struct type t = string let compare = String.compare end
+module UNameMap = struct
+    
+  include Map.Make(StringOrd)
+    
+  let union s t = 
+    if s == t then s
+    else
+      merge (fun k l r -> 
+	match l, r with
+	| Some _, _ -> l
+	| _, _ -> r) s t
 end
 
-module EvarMap = struct
-  type t = EvarInfoMap.t * (Univ.UniverseLSet.t * Univ.universes)
-  let empty = EvarInfoMap.empty, (Univ.UniverseLSet.empty, Univ.initial_universes)
-  let is_empty (sigma,_) = EvarInfoMap.is_empty sigma
-  let has_undefined (sigma,_) = EvarInfoMap.has_undefined sigma
-  let add (sigma,sm) k v = (EvarInfoMap.add sigma k v, sm)
-  let add_undefined (sigma,sm) k v = (EvarInfoMap.add_undefined sigma k v, sm)
-  let find (sigma,_) = EvarInfoMap.find sigma
-  let find_undefined (sigma,_) = EvarInfoMap.find_undefined sigma
-  let remove (sigma,sm) k = (EvarInfoMap.remove sigma k, sm)
-  let mem (sigma,_) = EvarInfoMap.mem sigma
-  let to_list (sigma,_) = EvarInfoMap.to_list sigma
-  let undefined_list (sigma,_) = EvarInfoMap.undefined_list sigma
-  let undefined_evars (sigma,sm) = (EvarInfoMap.undefined_evars sigma, sm)
-  let defined_evars (sigma,sm) = (EvarInfoMap.defined_evars sigma, sm)
-  let fold (sigma,_) = EvarInfoMap.fold sigma
-  let fold_undefined (sigma,_) = EvarInfoMap.fold_undefined sigma
-  let define (sigma,sm) k v = (EvarInfoMap.define sigma k v, sm)
-  let is_evar (sigma,_) = EvarInfoMap.is_evar sigma
-  let is_defined (sigma,_) = EvarInfoMap.is_defined sigma
-  let is_undefined (sigma,_) = EvarInfoMap.is_undefined sigma
-  let existential_value (sigma,_) = EvarInfoMap.existential_value sigma
-  let existential_type (sigma,_) = EvarInfoMap.existential_type sigma
-  let existential_opt_value (sigma,_) = EvarInfoMap.existential_opt_value sigma
-  let progress_evar_map (sigma1,sm1 as x) (sigma2,sm2 as y) = not (x == y) &&
-    (EvarInfoMap.exists_undefined sigma1
-      (fun k v -> assert (v.evar_body = Evar_empty);
-        EvarInfoMap.is_defined sigma2 k))
-
-  let merge e e' = fold e' (fun n v sigma -> add sigma n v) e
-  let add_constraints (sigma, (us, sm)) cstrs =
-    (sigma, (us, Univ.merge_constraints cstrs sm))
-end
+(* 2nd part used to check consistency on the fly. *)
+type evar_universe_context = 
+ { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t;
+   uctx_local : Univ.universe_context_set; (** The local context of variables *)
+    uctx_univ_variables : Universes.universe_opt_subst;
+      (** The local universes that are unification variables *)
+    uctx_univ_algebraic : Univ.universe_set; 
+    (** The subset of unification variables that
+	can be instantiated with algebraic universes as they appear in types 
+	and universe instances only. *)
+    uctx_universes : Univ.universes; (** The current graph extended with the local constraints *)
+    uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *)
+  }
+  
+let empty_evar_universe_context = 
+  { uctx_names = UNameMap.empty, Univ.LMap.empty;
+    uctx_local = Univ.ContextSet.empty;
+    uctx_univ_variables = Univ.LMap.empty;
+    uctx_univ_algebraic = Univ.LSet.empty;
+    uctx_universes = Univ.initial_universes;
+    uctx_initial_universes = Univ.initial_universes }
+
+let evar_universe_context_from e = 
+  let u = universes e in
+    {empty_evar_universe_context with 
+      uctx_universes = u; uctx_initial_universes = u}
+
+let is_empty_evar_universe_context ctx =
+  Univ.ContextSet.is_empty ctx.uctx_local && 
+    Univ.LMap.is_empty ctx.uctx_univ_variables
+
+let union_evar_universe_context ctx ctx' =
+  if ctx == ctx' then ctx
+  else if is_empty_evar_universe_context ctx' then ctx
+  else
+    let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in
+    let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in
+    let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in
+      { uctx_names = (names, names_rev);
+	uctx_local = local;
+	uctx_univ_variables = 
+	  Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables;
+	uctx_univ_algebraic = 
+	  Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic;
+	uctx_initial_universes = ctx.uctx_initial_universes;
+	uctx_universes = 
+	  if local == ctx.uctx_local then ctx.uctx_universes
+	  else
+	    let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in
+	      Univ.merge_constraints cstrsr ctx.uctx_universes }
+
+(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *)
+(* let union_evar_universe_context =  *)
+(*   Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *)
+
+type 'a in_evar_universe_context = 'a * evar_universe_context
+
+let evar_universe_context_set ctx = ctx.uctx_local
+let evar_universe_context_constraints ctx = snd ctx.uctx_local
+let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local
+let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx }
+let evar_universe_context_subst ctx = ctx.uctx_univ_variables
+
+let instantiate_variable l b v =
+  (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *)
+  (* if Univ.univ_depends (Univ.Universe.make l) b then  *)
+  (*   error ("Occur-check in universe variable instantiation") *)
+  (* else *) v := Univ.LMap.add l (Some b) !v
+
+exception UniversesDiffer
+
+let process_universe_constraints univs vars alg cstrs =
+  let vars = ref vars in
+  let normalize = Universes.normalize_universe_opt_subst vars in
+  let rec unify_universes fo l d r local =
+    let l = normalize l and r = normalize r in
+      if Univ.Universe.equal l r then local
+      else 
+	let varinfo x = 
+	  match Univ.Universe.level x with
+	  | None -> Inl x
+	  | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg)
+	in
+	  if d == Universes.ULe then
+	    if Univ.check_leq univs l r then
+	      (** Keep Prop/Set <= var around if var might be instantiated by prop or set
+		  later. *)
+	      if Univ.Universe.is_level l then 
+		match Univ.Universe.level r with
+		| Some r ->
+		  Univ.Constraint.add (Option.get (Univ.Universe.level l),Univ.Le,r) local
+		| _ -> local
+	      else local
+	    else
+	      match Univ.Universe.level r with
+	      | None -> error ("Algebraic universe on the right")
+	      | Some rl ->
+		if Univ.Level.is_small rl then
+		  let levels = Univ.Universe.levels l in
+		    Univ.LSet.fold (fun l local ->
+		      if Univ.Level.is_small l || Univ.LMap.mem l !vars then
+			Univ.enforce_eq (Univ.Universe.make l) r local
+		      else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None)))
+		      levels local
+		else
+		  Univ.enforce_leq l r local
+	  else if d == Universes.ULub then
+	    match varinfo l, varinfo r with
+	    | (Inr (l, true, _), Inr (r, _, _)) 
+	    | (Inr (r, _, _), Inr (l, true, _)) -> 
+	      instantiate_variable l (Univ.Universe.make r) vars; 
+	      Univ.enforce_eq_level l r local
+	    | Inr (_, _, _), Inr (_, _, _) ->
+	      unify_universes true l Universes.UEq r local
+	    | _, _ -> assert false
+	  else (* d = Universes.UEq *)
+	    match varinfo l, varinfo r with
+	    | Inr (l', lloc, _), Inr (r', rloc, _) ->
+	      let () = 
+		if lloc then
+		  instantiate_variable l' r vars
+		else if rloc then 
+		  instantiate_variable r' l vars
+		else if not (Univ.check_eq univs l r) then
+		  (* Two rigid/global levels, none of them being local,
+		     one of them being Prop/Set, disallow *)
+		  if Univ.Level.is_small l' || Univ.Level.is_small r' then
+		    raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
+		  else
+		    if fo then 
+		      raise UniversesDiffer
+	      in
+	        Univ.enforce_eq_level l' r' local
+           | _, _ (* One of the two is algebraic or global *) -> 
+	     if Univ.check_eq univs l r then local
+	     else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None))
+  in
+  let local = 
+    Universes.Constraints.fold (fun (l,d,r) local -> unify_universes false l d r local)
+      cstrs Univ.Constraint.empty
+  in
+    !vars, local
+
+let add_constraints_context ctx cstrs =
+  let univs, local = ctx.uctx_local in
+  let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> 
+    let l = Univ.Universe.make l and r = Univ.Universe.make r in
+    let cstr' = 
+      if d == Univ.Lt then (Univ.Universe.super l, Universes.ULe, r)
+      else (l, (if d == Univ.Le then Universes.ULe else Universes.UEq), r)
+    in Universes.Constraints.add cstr' acc)
+    cstrs Universes.Constraints.empty
+  in
+  let vars, local' =
+    process_universe_constraints ctx.uctx_universes
+      ctx.uctx_univ_variables ctx.uctx_univ_algebraic
+      cstrs'
+  in
+    { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+      uctx_univ_variables = vars;
+      uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes }
+
+(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *)
+(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *)
+
+let add_universe_constraints_context ctx cstrs =
+  let univs, local = ctx.uctx_local in
+  let vars, local' = 
+    process_universe_constraints ctx.uctx_universes 
+      ctx.uctx_univ_variables ctx.uctx_univ_algebraic 
+      cstrs 
+  in
+    { ctx with uctx_local = (univs, Univ.Constraint.union local local');
+      uctx_univ_variables = vars;
+      uctx_universes = Univ.merge_constraints local' ctx.uctx_universes }
 
+(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *)
+(* let add_universe_constraints_context =  *)
+(*   Profile.profile2 addunivconstrkey add_universe_constraints_context;; *)
 (*******************************************************************)
 (* Metamaps *)
 
@@ -253,16 +461,16 @@ end
 
 type 'a freelisted = {
   rebus : 'a;
-  freemetas : Intset.t }
+  freemetas : Int.Set.t }
 
 (* Collects all metavars appearing in a constr *)
 let metavars_of c =
   let rec collrec acc c =
     match kind_of_term c with
-      | Meta mv -> Intset.add mv acc
+      | Meta mv -> Int.Set.add mv acc
       | _         -> fold_constr collrec acc c
   in
-  collrec Intset.empty c
+  collrec Int.Set.empty c
 
 let mk_freelisted c =
   { rebus = c; freemetas = metavars_of c }
@@ -278,6 +486,8 @@ let map_fl f cfl = { cfl with rebus=f cfl.rebus }
 
 type instance_constraint = IsSuperType | IsSubType | Conv
 
+let eq_instance_constraint c1 c2 = c1 == c2
+
 (* Status of the unification of the type of an instance against the type of
      the meta it instantiates:
    - CoerceToType means that the unification of types has not been done
@@ -301,8 +511,8 @@ type instance_status = instance_constraint * instance_typing_status
 (* Clausal environments *)
 
 type clbinding =
-  | Cltyp of name * constr freelisted
-  | Clval of name * (constr freelisted * instance_status) * constr freelisted
+  | Cltyp of Name.t * constr freelisted
+  | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
 
 let map_clb f = function
   | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
@@ -315,11 +525,9 @@ let clb_name = function
 
 (***********************)
 
-module Metaset = Intset
+module Metaset = Int.Set
 
-let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false
-
-module Metamap = Intmap
+module Metamap = Int.Map
 
 let metamap_to_list m =
   Metamap.fold (fun n v l -> (n,v)::l) m []
@@ -329,136 +537,322 @@ let metamap_to_list m =
 
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * Environ.env * constr * constr
-type evar_map =
-    { evars : EvarMap.t;
-      conv_pbs : evar_constraint list;
-      last_mods : ExistentialSet.t;
-      metas : clbinding Metamap.t }
 
-(*** Lifting primitive from EvarMap. ***)
+module EvMap = Evar.Map
+
+type evar_map = {
+  (** Existential variables *)
+  defn_evars : evar_info EvMap.t;
+  undf_evars : evar_info EvMap.t;
+  evar_names : Id.t EvMap.t * existential_key Idmap.t;
+  (** Universes *)
+  universes  : evar_universe_context;
+  (** Conversion problems *)
+  conv_pbs   : evar_constraint list;
+  last_mods  : Evar.Set.t;
+  (** Metas *)
+  metas      : clbinding Metamap.t;
+  (** Interactive proofs *)
+  effects    : Declareops.side_effects;
+  future_goals : Evar.t list; (** list of newly created evars, to be
+                                  eventually turned into goals if not solved.*)
+  principal_future_goal : Evar.t option; (** if [Some e], [e] must be
+                                             contained
+                                             [future_goals]. The evar
+                                             [e] will inherit
+                                             properties (now: the
+                                             name) of the evar which
+                                             will be instantiated with
+                                             a term containing [e]. *)
+}
+
+(*** Lifting primitive from Evar.Map. ***)
 
 (* HH: The progress tactical now uses this function. *)
 let progress_evar_map d1 d2 =
-  EvarMap.progress_evar_map d1.evars d2.evars
-
-(* spiwack: tentative. It might very well not be the semantics we want
-     for merging evar_map *)
-let merge d1 d2 = {
-  evars = EvarMap.merge d1.evars d2.evars ;
-  conv_pbs = List.rev_append d1.conv_pbs d2.conv_pbs ;
-  last_mods = ExistentialSet.union d1.last_mods d2.last_mods ;
-  metas = Metamap.fold (fun k m r -> Metamap.add k m r) d2.metas d1.metas
-}
-let add d e i = { d with evars=EvarMap.add d.evars e i }
-let remove d e = { d with evars=EvarMap.remove d.evars e }
-let find d e = EvarMap.find d.evars e
-let find_undefined d e = EvarMap.find_undefined d.evars e
-let mem d e = EvarMap.mem d.evars e
+  let is_new k v =
+    assert (v.evar_body == Evar_empty);
+    EvMap.mem k d2.defn_evars
+  in
+  not (d1 == d2) && EvMap.exists is_new d1.undf_evars
+
+let add_name_newly_undefined naming evk evi (evtoid,idtoev) =
+  let id = match naming with
+  | Misctypes.IntroAnonymous ->
+      let id = evar_ident_info evi in
+      Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev)
+  | Misctypes.IntroIdentifier id ->
+      let id' =
+        Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
+      if not (Names.Id.equal id id') then
+        user_err_loc
+          (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
+      id'
+  | Misctypes.IntroFresh id ->
+      Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
+  (EvMap.add evk id evtoid, Idmap.add id evk idtoev)
+
+let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) =
+  if EvMap.mem evk evtoid then
+    evar_names
+  else
+    add_name_newly_undefined naming evk evi evar_names
+
+let remove_name_defined evk (evtoid,idtoev) =
+  let id = EvMap.find evk evtoid in
+  (EvMap.remove evk evtoid, Idmap.remove id idtoev)
+
+let remove_name_possibly_already_defined evk evar_names =
+  try remove_name_defined evk evar_names
+  with Not_found -> evar_names
+
+let rename evk id evd =
+  let (evtoid,idtoev) = evd.evar_names in
+  let id' = EvMap.find evk evtoid in
+  if Idmap.mem id idtoev then anomaly (str "Evar name already in use");
+  { evd with evar_names =
+      (EvMap.add evk id evtoid (* overwrite old name *),
+       Idmap.add id evk (Idmap.remove id' idtoev)) }
+
+let reassign_name_defined evk evk' (evtoid,idtoev) =
+  let id = EvMap.find evk evtoid in
+  (EvMap.add evk' id (EvMap.remove evk evtoid),
+   Idmap.add id evk' (Idmap.remove id idtoev))
+
+let add d e i = match i.evar_body with
+| Evar_empty ->
+  let evar_names = add_name_undefined Misctypes.IntroAnonymous e i d.evar_names in
+  { d with undf_evars = EvMap.add e i d.undf_evars; evar_names }
+| Evar_defined _ ->
+  let evar_names = remove_name_possibly_already_defined e d.evar_names in
+  { d with defn_evars = EvMap.add e i d.defn_evars; evar_names }
+
+let remove d e =
+  let undf_evars = EvMap.remove e d.undf_evars in
+  let defn_evars = EvMap.remove e d.defn_evars in
+  { d with undf_evars; defn_evars; }
+
+let find d e =
+  try EvMap.find e d.undf_evars
+  with Not_found -> EvMap.find e d.defn_evars
+
+let find_undefined d e = EvMap.find e d.undf_evars
+
+let mem d e = EvMap.mem e d.undf_evars || EvMap.mem e d.defn_evars
+
 (* spiwack: this function loses information from the original evar_map
    it might be an idea not to export it. *)
-let to_list d = EvarMap.to_list d.evars
-let undefined_list d = EvarMap.undefined_list d.evars
-let undefined_evars d = { d with evars=EvarMap.undefined_evars d.evars }
-let defined_evars d = { d with evars=EvarMap.defined_evars d.evars }
+let to_list d =
+  (* Workaround for change in Map.fold behavior in ocaml 3.08.4 *)
+  let l = ref [] in
+  EvMap.iter (fun evk x -> l := (evk,x)::!l) d.defn_evars;
+  EvMap.iter (fun evk x -> l := (evk,x)::!l) d.undf_evars;
+  !l
+
+let undefined_map d = d.undf_evars
+
+let drop_all_defined d = { d with defn_evars = EvMap.empty }
+
 (* spiwack: not clear what folding over an evar_map, for now we shall
     simply fold over the inner evar_map. *)
-let fold f d a = EvarMap.fold d.evars f a
-let fold_undefined f d a = EvarMap.fold_undefined d.evars f a
-let is_evar d e = EvarMap.is_evar d.evars e
-let is_defined d e = EvarMap.is_defined d.evars e
-let is_undefined d e = EvarMap.is_undefined d.evars e
+let fold f d a =
+  EvMap.fold f d.defn_evars (EvMap.fold f d.undf_evars a)
+
+let fold_undefined f d a = EvMap.fold f d.undf_evars a
+
+let raw_map f d =
+  let f evk info =
+    let ans = f evk info in
+    let () = match info.evar_body, ans.evar_body with
+    | Evar_defined _, Evar_empty
+    | Evar_empty, Evar_defined _ ->
+      anomaly (str "Unrespectful mapping function.")
+    | _ -> ()
+    in
+    ans
+  in
+  let defn_evars = EvMap.smartmapi f d.defn_evars in
+  let undf_evars = EvMap.smartmapi f d.undf_evars in
+  { d with defn_evars; undf_evars; }
+
+let raw_map_undefined f d =
+  let f evk info =
+    let ans = f evk info in
+    let () = match ans.evar_body with
+    | Evar_defined _ ->
+      anomaly (str "Unrespectful mapping function.")
+    | _ -> ()
+    in
+    ans
+  in
+  { d with undf_evars = EvMap.smartmapi f d.undf_evars; }
+
+let is_evar = mem
+
+let is_defined d e = EvMap.mem e d.defn_evars
+
+let is_undefined d e = EvMap.mem e d.undf_evars
+
+let existential_value d (n, args) =
+  let info = find d n in
+  match evar_body info with
+  | Evar_defined c ->
+    instantiate_evar_array info c args
+  | Evar_empty ->
+    raise NotInstantiatedEvar
+
+let existential_opt_value d ev =
+  try Some (existential_value d ev)
+  with NotInstantiatedEvar -> None
 
-let existential_value d e = EvarMap.existential_value d.evars e
-let existential_type d e = EvarMap.existential_type d.evars e
-let existential_opt_value d e = EvarMap.existential_opt_value d.evars e
+let existential_type d (n, args) =
+  let info =
+    try find d n
+    with Not_found ->
+      anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in
+  instantiate_evar_array info info.evar_concl args
 
-let add_constraints d e = {d with evars= EvarMap.add_constraints d.evars e}
+let add_constraints d c =
+  { d with universes = add_constraints_context d.universes c }
+
+let add_universe_constraints d c = 
+  { d with universes = add_universe_constraints_context d.universes c }
 
 (*** /Lifting... ***)
 
 (* evar_map are considered empty disregarding histories *)
 let is_empty d =
-  EvarMap.is_empty d.evars &&
-  d.conv_pbs = [] &&
+  EvMap.is_empty d.defn_evars &&
+  EvMap.is_empty d.undf_evars &&
+  List.is_empty d.conv_pbs &&
   Metamap.is_empty d.metas
 
-let subst_named_context_val s = map_named_val (subst_mps s)
-
-let subst_evar_info s evi =
-  let subst_evb = function Evar_empty -> Evar_empty
-    | Evar_defined c -> Evar_defined (subst_mps s c) in
-  { evi with
-      evar_concl = subst_mps s evi.evar_concl;
-      evar_hyps = subst_named_context_val s evi.evar_hyps;
-      evar_body = subst_evb evi.evar_body }
-
-let subst_evar_defs_light sub evd =
-  assert (Univ.is_initial_universes (snd (snd evd.evars)));
-  assert (evd.conv_pbs = []);
+let cmap f evd = 
   { evd with
-      metas = Metamap.map (map_clb (subst_mps sub)) evd.metas;
-      evars = EvarInfoMap.map (subst_evar_info sub)  (fst evd.evars), (snd evd.evars)
+      metas = Metamap.map (map_clb f) evd.metas;
+      defn_evars = EvMap.map (map_evar_info f) evd.defn_evars;
+      undf_evars = EvMap.map (map_evar_info f) evd.defn_evars
   }
 
-let subst_evar_map = subst_evar_defs_light
-
 (* spiwack: deprecated *)
 let create_evar_defs sigma = { sigma with
-  conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty }
+  conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty }
 (* spiwack: tentatively deprecated *)
 let create_goal_evar_defs sigma = { sigma with
-   (* conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } *)
+   (* conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } *)
   metas=Metamap.empty } 
-let empty =  {
-  evars=EvarMap.empty;
-  conv_pbs=[];
-  last_mods = ExistentialSet.empty;
-  metas=Metamap.empty
+
+let empty = {
+  defn_evars = EvMap.empty;
+  undf_evars = EvMap.empty;
+  universes  = empty_evar_universe_context;
+  conv_pbs   = [];
+  last_mods  = Evar.Set.empty;
+  metas      = Metamap.empty;
+  effects    = Declareops.no_seff;
+  evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *)
+  future_goals = [];
+  principal_future_goal = None;
 }
 
-let has_undefined evd =
-  EvarMap.has_undefined evd.evars
+let from_env ?ctx e = 
+  match ctx with
+  | None -> { empty with universes = evar_universe_context_from e }
+  | Some ctx -> { empty with universes = ctx }
+
+let has_undefined evd = not (EvMap.is_empty evd.undf_evars)
+
+let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d =
+  let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in
+  let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in
+  let universes = 
+    if not with_univs then evd.universes
+    else union_evar_universe_context evd.universes d.universes
+  in
+  { evd with
+    metas = d.metas;
+    last_mods; conv_pbs; universes }
+
+let merge_universe_context evd uctx' =
+  { evd with universes = union_evar_universe_context evd.universes uctx' }
+
+let set_universe_context evd uctx' =
+  { evd with universes = uctx' }
 
-let evars_reset_evd ?(with_conv_pbs=false) evd d = 
-  {d with evars = evd.evars; 
-     conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs }
 let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs}
-let evar_source evk d = (EvarMap.find d.evars evk).evar_source
+
+let evar_source evk d = (find d evk).evar_source
+
+let evar_ident evk evd =
+  try EvMap.find evk (fst evd.evar_names)
+  with Not_found ->
+    (* Unnamed (non-dependent) evar *)
+    add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk))
+
+let evar_key id evd =
+  Idmap.find id (snd evd.evar_names)
+
+let define_aux def undef evk body =
+  let oldinfo =
+    try EvMap.find evk undef
+    with Not_found ->
+      if EvMap.mem evk def then
+        anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice")
+      else
+        anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar")
+  in
+  let () = assert (oldinfo.evar_body == Evar_empty) in
+  let newinfo = { oldinfo with evar_body = Evar_defined body } in
+  EvMap.add evk newinfo def, EvMap.remove evk undef
 
 (* define the existential of section path sp as the constr body *)
 let define evk body evd =
-  { evd with
-    evars = EvarMap.define evd.evars evk body;
-    last_mods =
-        match evd.conv_pbs with
-	| [] ->  evd.last_mods
-        | _ -> ExistentialSet.add evk evd.last_mods }
-
-let evar_declare hyps evk ty ?(src=(dummy_loc,InternalHole)) ?filter ?candidates evd =
-  let filter =
-    if filter = None then
-      List.map (fun _ -> true) (named_context_of_val hyps)
-    else
-      (let filter = Option.get filter in
-      assert (List.length filter = List.length (named_context_of_val hyps));
-      filter)
+  let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
+  let last_mods = match evd.conv_pbs with
+  | [] ->  evd.last_mods
+  | _ -> Evar.Set.add evk evd.last_mods
   in
-  { evd with
-    evars = EvarMap.add_undefined evd.evars evk
-      {evar_hyps = hyps;
-       evar_concl = ty;
-       evar_body = Evar_empty;
-       evar_filter = filter;
-       evar_source = src;
-       evar_candidates = candidates;
-       evar_extra = Store.empty } }
-
-let is_defined_evar evd (evk,_) = EvarMap.is_defined evd.evars evk
-
-(* Does k corresponds to an (un)defined existential ? *)
-let is_undefined_evar evd c = match kind_of_term c with
-  | Evar ev -> not (is_defined_evar evd ev)
-  | _ -> false
+  let evar_names = remove_name_defined evk evd.evar_names in
+  { evd with defn_evars; undf_evars; last_mods; evar_names }
+
+let evar_declare hyps evk ty ?(src=(Loc.ghost,Evar_kinds.InternalHole)) 
+    ?(filter=Filter.identity) ?candidates ?(store=Store.empty)
+    ?(naming=Misctypes.IntroAnonymous) evd =
+  let () = match Filter.repr filter with
+  | None -> ()
+  | Some filter ->
+    assert (Int.equal (List.length filter) (List.length (named_context_of_val hyps)))
+  in
+  let evar_info = {
+    evar_hyps = hyps;
+    evar_concl = ty;
+    evar_body = Evar_empty;
+    evar_filter = filter;
+    evar_source = src;
+    evar_candidates = candidates;
+    evar_extra = store; }
+  in
+  let evar_names = add_name_newly_undefined naming evk evar_info evd.evar_names in
+  { evd with undf_evars = EvMap.add evk evar_info evd.undf_evars; evar_names }
+
+let restrict evk evk' filter ?candidates evd =
+  let evar_info = EvMap.find evk evd.undf_evars in
+  let evar_info' =
+    { evar_info with evar_filter = filter;
+      evar_candidates = candidates;
+      evar_extra = Store.empty } in
+  let evar_names = reassign_name_defined evk evk' evd.evar_names in
+  let ctxt = Filter.filter_list filter (evar_context evar_info) in
+  let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in
+  let body = mkEvar(evk',id_inst) in
+  let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
+  { evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
+    defn_evars; evar_names }
+
+let downcast evk ccl evd =
+  let evar_info = EvMap.find evk evd.undf_evars in
+  let evar_info' = { evar_info with evar_concl = ccl } in
+  { evd with undf_evars = EvMap.add evk evar_info' evd.undf_evars }
 
 (* extracts conversion problems that satisfy predicate p *)
 (* Note: conv_pbs not satisying p are stored back in reverse order *)
@@ -473,129 +867,495 @@ let extract_conv_pbs evd p =
       ([],[])
       evd.conv_pbs
   in
-  {evd with conv_pbs = pbs1; last_mods = ExistentialSet.empty},
+  {evd with conv_pbs = pbs1; last_mods = Evar.Set.empty},
   pbs
 
 let extract_changed_conv_pbs evd p =
-  extract_conv_pbs evd (p evd.last_mods)
+  extract_conv_pbs evd (fun pb -> p evd.last_mods pb)
 
 let extract_all_conv_pbs evd =
   extract_conv_pbs evd (fun _ -> true)
 
-(* spiwack: should it be replaced by Evd.merge? *)
-let evar_merge evd evars =
-  { evd with evars = EvarMap.merge evd.evars evars.evars }
+let loc_of_conv_pb evd (pbty,env,t1,t2) =
+  match kind_of_term (fst (decompose_app t1)) with
+  | Evar (evk1,_) -> fst (evar_source evk1 evd)
+  | _ ->
+  match kind_of_term (fst (decompose_app t2)) with
+  | Evar (evk2,_) -> fst (evar_source evk2 evd)
+  | _ -> Loc.ghost
+
+(** The following functions return the set of evars immediately
+    contained in the object *)
 
-let evar_list evd c =
+(* excluding defined evars *)
+
+let evar_list c =
   let rec evrec acc c =
     match kind_of_term c with
-    | Evar (evk, _ as ev) when mem evd evk -> ev :: acc
+    | Evar (evk, _ as ev) -> ev :: acc
     | _ -> fold_constr evrec acc c in
   evrec [] c
 
-let collect_evars c =
-  let rec collrec acc c =
+let evars_of_term c =
+  let rec evrec acc c =
     match kind_of_term c with
-      | Evar (evk,_) -> ExistentialSet.add evk acc
-      | _       -> fold_constr collrec acc c
+    | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l)
+    | _ -> fold_constr evrec acc c
   in
-  collrec ExistentialSet.empty c
+  evrec Evar.Set.empty c
+
+let evars_of_named_context nc =
+  List.fold_right (fun (_, b, t) s ->
+    Option.fold_left (fun s t ->
+      Evar.Set.union s (evars_of_term t))
+      (Evar.Set.union s (evars_of_term t)) b)
+    nc Evar.Set.empty
+
+let evars_of_filtered_evar_info evi =
+  Evar.Set.union (evars_of_term evi.evar_concl)
+    (Evar.Set.union
+	(match evi.evar_body with
+	| Evar_empty -> Evar.Set.empty
+	| Evar_defined b -> evars_of_term b)
+	(evars_of_named_context (evar_filtered_context evi)))
+
+(**********************************************************)
+(* Side effects *)
+
+let emit_side_effects eff evd =
+  { evd with effects = Declareops.union_side_effects eff evd.effects; }
+
+let drop_side_effects evd =
+  { evd with effects = Declareops.no_seff; }
+
+let eval_side_effects evd = evd.effects
+
+(* Future goals *)
+let declare_future_goal evk evd =
+  { evd with future_goals = evk::evd.future_goals }
+
+let declare_principal_goal evk evd =
+  match evd.principal_future_goal with
+  | None -> { evd with
+    future_goals = evk::evd.future_goals;
+    principal_future_goal=Some evk; }
+  | Some _ -> Errors.error "Only one main subgoal per instantiation."
+
+let future_goals evd = evd.future_goals
+
+let principal_future_goal evd = evd.principal_future_goal
+
+let reset_future_goals evd =
+  { evd with future_goals = [] ; principal_future_goal=None }
+
+let restore_future_goals evd gls pgl =
+  { evd with future_goals = gls ; principal_future_goal = pgl }
 
 (**********************************************************)
 (* Sort variables *)
 
-let new_univ_variable ({ evars = (sigma,(us,sm)) } as d) =
-  let u = Termops.new_univ_level () in
-  let us' = Univ.UniverseLSet.add u us in
-    ({d with evars = (sigma, (us', sm))}, Univ.make_universe u)
-  
-let new_sort_variable d =
-  let (d', u) = new_univ_variable d in
+type rigid = 
+  | UnivRigid
+  | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
+
+let univ_rigid = UnivRigid
+let univ_flexible = UnivFlexible false
+let univ_flexible_alg = UnivFlexible true
+
+let evar_universe_context d = d.universes
+
+let universe_context_set d = d.universes.uctx_local
+
+let universe_context evd =
+  Univ.ContextSet.to_context evd.universes.uctx_local
+
+let universe_subst evd =
+  evd.universes.uctx_univ_variables
+
+let merge_uctx rigid uctx ctx' =
+  let open Univ in
+  let uctx = 
+    match rigid with
+    | UnivRigid -> uctx
+    | UnivFlexible b ->
+      let levels = ContextSet.levels ctx' in
+      let fold u accu =
+        if LMap.mem u accu then accu
+        else LMap.add u None accu
+      in
+      let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in
+	if b then
+	  { uctx with uctx_univ_variables = uvars';
+	  uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels }
+	else { uctx with uctx_univ_variables = uvars' }
+  in
+  let uctx_local = ContextSet.append ctx' uctx.uctx_local in
+  let uctx_universes = merge_constraints (ContextSet.constraints ctx') uctx.uctx_universes in
+  { uctx with uctx_local; uctx_universes }
+
+let merge_context_set rigid evd ctx' = 
+  {evd with universes = merge_uctx rigid evd.universes ctx'}
+
+let merge_uctx_subst uctx s =
+  { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s }
+      
+let merge_universe_subst evd subst = 
+  {evd with universes = merge_uctx_subst evd.universes subst }
+
+let with_context_set rigid d (a, ctx) = 
+  (merge_context_set rigid d ctx, a)
+
+let add_uctx_names s l (names, names_rev) =
+    (UNameMap.add s l names, Univ.LMap.add l s names_rev)
+
+let uctx_new_univ_variable rigid name
+  ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) =
+  let u = Universes.new_univ_level (Global.current_dirpath ()) in
+  let ctx' = Univ.ContextSet.add_universe u ctx in
+  let uctx' = 
+    match rigid with
+    | UnivRigid -> uctx
+    | UnivFlexible b -> 
+      let uvars' = Univ.LMap.add u None uvars in
+	if b then {uctx with uctx_univ_variables = uvars';
+	  uctx_univ_algebraic = Univ.LSet.add u avars}
+	else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in
+  let names = 
+    match name with
+    | Some n -> add_uctx_names n u uctx.uctx_names
+    | None -> uctx.uctx_names
+  in
+    {uctx' with uctx_names = names; uctx_local = ctx';
+      uctx_universes = Univ.add_universe u uctx.uctx_universes}, u
+
+let new_univ_level_variable ?name rigid evd =
+  let uctx', u = uctx_new_univ_variable rigid name evd.universes in
+    ({evd with universes = uctx'}, u)
+
+let new_univ_variable ?name rigid evd =
+  let uctx', u = uctx_new_univ_variable rigid name evd.universes in
+    ({evd with universes = uctx'}, Univ.Universe.make u)
+
+let new_sort_variable ?name rigid d =
+  let (d', u) = new_univ_variable rigid ?name d in
     (d', Type u)
 
-let is_sort_variable {evars=(_,(us,_))} s = match s with Type u -> true | _ -> false 
-let whd_sort_variable {evars=(_,sm)} t = t
+let make_flexible_variable evd b u =
+  let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in
+  let uvars' = Univ.LMap.add u None uvars in
+  let avars' = 
+    if b then
+      let uu = Univ.Universe.make u in
+      let substu_not_alg u' v =
+	Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
+      in
+	if not (Univ.LMap.exists substu_not_alg uvars)
+	then Univ.LSet.add u avars else avars 
+    else avars 
+  in
+    {evd with universes = {ctx with uctx_univ_variables = uvars'; 
+      uctx_univ_algebraic = avars'}}
+
+(****************************************)
+(* Operations on constants              *)
+(****************************************)
+
+let fresh_sort_in_family ?(rigid=univ_flexible) env evd s = 
+  with_context_set rigid evd (Universes.fresh_sort_in_family env s)
+
+let fresh_constant_instance env evd c =
+  with_context_set univ_flexible evd (Universes.fresh_constant_instance env c)
 
-let univ_of_sort = function
-  | Type u -> u
-  | Prop Pos -> Univ.type0_univ
-  | Prop Null -> Univ.type0m_univ
+let fresh_inductive_instance env evd i =
+  with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i)
+
+let fresh_constructor_instance env evd c =
+  with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c)
+
+let fresh_global ?(rigid=univ_flexible) ?names env evd gr =
+  with_context_set rigid evd (Universes.fresh_global_instance ?names env gr)
+
+let whd_sort_variable evd t = t
+
+let is_sort_variable evd s = 
+  match s with 
+  | Type u -> 
+    (match Univ.universe_level u with
+    | Some l as x -> 
+      let uctx = evd.universes in
+	if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then x
+	else None
+    | None -> None)
+  | _ -> None
+
+let is_flexible_level evd l = 
+  let uctx = evd.universes in
+    Univ.LMap.mem l uctx.uctx_univ_variables
 
 let is_eq_sort s1 s2 =
-  if s1 = s2 then None
-  else 
-    let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in
-      if u1 = u2 then None
+  if Sorts.equal s1 s2 then None
+  else
+    let u1 = univ_of_sort s1
+    and u2 = univ_of_sort s2 in
+      if Univ.Universe.equal u1 u2 then None
       else Some (u1, u2)
 
-let is_univ_var_or_set u =   
-  Univ.is_univ_variable u || u = Univ.type0_univ
-
-let set_leq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 =
+let normalize_universe evd =
+  let vars = ref evd.universes.uctx_univ_variables in
+  let normalize = Universes.normalize_universe_opt_subst vars in
+    normalize
+
+let normalize_universe_instance evd l =
+  let vars = ref evd.universes.uctx_univ_variables in
+  let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in
+    Univ.Instance.subst_fn normalize l
+
+let normalize_sort evars s =
+  match s with
+  | Prop _ -> s
+  | Type u -> 
+    let u' = normalize_universe evars u in
+    if u' == u then s else Type u'
+
+(* FIXME inefficient *)
+let set_eq_sort env d s1 s2 =
+  let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in
   match is_eq_sort s1 s2 with
   | None -> d
   | Some (u1, u2) ->
-      match s1, s2 with
-      | Prop c, Prop c' -> 
-	  if c = Null && c' = Pos then d
-	  else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2)))
-     | Type u, Prop c -> 
-	  if c = Pos then 
-	    add_constraints d (Univ.enforce_geq Univ.type0_univ u Univ.empty_constraint)
-	  else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))
-      | _, Type u ->
-	  if is_univ_var_or_set u then
-	    add_constraints d (Univ.enforce_geq u2 u1 Univ.empty_constraint)
-	  else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2))
-
-let is_univ_level_var us u =
-  match Univ.universe_level u with
-  | Some u -> Univ.UniverseLSet.mem u us
-  | None -> false
-
-let set_eq_sort ({evars = (sigma, (us, sm))} as d) s1 s2 =
+    if not (type_in_type env) then
+      add_universe_constraints d
+        (Universes.Constraints.singleton (u1,Universes.UEq,u2))
+    else
+      d
+
+let has_lub evd u1 u2 =
+  (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *)
+  (* (\* let dref, norm = memo_normalize_universe d in *\) *)
+  (* let u1 = normalize u1 and u2 = normalize u2 in *)
+    if Univ.Universe.equal u1 u2 then evd
+    else add_universe_constraints evd
+      (Universes.Constraints.singleton (u1,Universes.ULub,u2))
+
+let set_eq_level d u1 u2 =
+  add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty)
+
+let set_leq_level d u1 u2 =
+  add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty)
+
+let set_eq_instances ?(flex=false) d u1 u2 =
+  add_universe_constraints d
+    (Universes.enforce_eq_instances_univs flex u1 u2 Universes.Constraints.empty)
+
+let set_leq_sort env evd s1 s2 =
+  let s1 = normalize_sort evd s1 
+  and s2 = normalize_sort evd s2 in
   match is_eq_sort s1 s2 with
-  | None -> d
+  | None -> evd
   | Some (u1, u2) ->
-      match s1, s2 with
-      | Prop c, Type u when is_univ_level_var us u ->
-	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
-      | Type u, Prop c when is_univ_level_var us u ->
-	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
-      | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) ->
-	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
-      | Prop c, Type u when is_univ_var_or_set u &&
-	  Univ.check_eq sm u1 u2 -> d
-      | Type u, Prop c when is_univ_var_or_set u && Univ.check_eq sm u1 u2 -> d
-      | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v ->
-	  add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint)
-      | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2))
+    (* if Univ.is_type0_univ u2 then *)
+    (*   if Univ.is_small_univ u1 then evd *)
+    (*   else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
+    (* else if Univ.is_type0m_univ u2 then  *)
+    (*   raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *)
+    (* else  *)
+      if not (type_in_type env) then
+      add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2))
+      else evd
 	    
+let check_eq evd s s' =
+  Univ.check_eq evd.universes.uctx_universes s s'
+
+let check_leq evd s s' =
+  Univ.check_leq evd.universes.uctx_universes s s'
+
+let subst_univs_context_with_def def usubst (ctx, cst) =
+  (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst)
+
+let normalize_evar_universe_context_variables uctx =
+  let normalized_variables, undef, def, subst = 
+    Universes.normalize_univ_variables uctx.uctx_univ_variables 
+  in
+  let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in
+  let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in
+    subst, { uctx with uctx_local = ctx_local';
+      uctx_univ_variables = normalized_variables;
+      uctx_universes = univs }
+
+(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *)
+(* let normalize_evar_universe_context_variables = *)
+(*   Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *)
+    
+let abstract_undefined_variables uctx =
+  let vars' = 
+    Univ.LMap.fold (fun u v acc ->
+      if v == None then Univ.LSet.remove u acc
+      else acc)
+    uctx.uctx_univ_variables uctx.uctx_univ_algebraic
+  in { uctx with uctx_local = Univ.ContextSet.empty;
+      uctx_univ_algebraic = vars' }
+
+
+let refresh_undefined_univ_variables uctx =
+  let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in
+  let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) 
+    uctx.uctx_univ_algebraic Univ.LSet.empty 
+  in
+  let vars = 
+    Univ.LMap.fold
+      (fun u v acc ->
+	Univ.LMap.add (Univ.subst_univs_level_level subst u) 
+          (Option.map (Univ.subst_univs_level_universe subst) v) acc)
+      uctx.uctx_univ_variables Univ.LMap.empty
+  in 
+  let uctx' = {uctx_names = uctx.uctx_names;
+	       uctx_local = ctx'; 
+	       uctx_univ_variables = vars; uctx_univ_algebraic = alg;
+	       uctx_universes = Univ.initial_universes;
+	       uctx_initial_universes = uctx.uctx_initial_universes } in
+    uctx', subst
+
+let refresh_undefined_universes evd =
+  let uctx', subst = refresh_undefined_univ_variables evd.universes in
+  let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in
+    evd', subst
+
+let normalize_evar_universe_context uctx = 
+  let rec fixpoint uctx = 
+    let ((vars',algs'), us') = 
+      Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables
+        uctx.uctx_univ_algebraic
+    in
+      if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then 
+        uctx
+      else
+	let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in
+	let uctx' = 
+	  { uctx_names = uctx.uctx_names;
+	    uctx_local = us'; 
+	    uctx_univ_variables = vars'; 
+	    uctx_univ_algebraic = algs';
+	    uctx_universes = universes;
+	    uctx_initial_universes = uctx.uctx_initial_universes }
+	in fixpoint uctx'
+  in fixpoint uctx
+
+let nf_univ_variables evd = 
+  let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
+  let evd' = {evd with universes = uctx'} in
+    evd', subst
+
+let nf_constraints evd =
+  let subst, uctx' = normalize_evar_universe_context_variables evd.universes in
+  let uctx' = normalize_evar_universe_context uctx' in
+    {evd with universes = uctx'}
+
+let nf_constraints = 
+  if Flags.profile then
+    let nfconstrkey = Profile.declare_profile "nf_constraints" in
+      Profile.profile1 nfconstrkey nf_constraints
+  else nf_constraints
+
+let universe_of_name evd s = 
+  UNameMap.find s (fst evd.universes.uctx_names)
+
+let add_universe_name evd s l =
+  let names' = add_uctx_names s l evd.universes.uctx_names in
+    {evd with universes = {evd.universes with uctx_names = names'}}
+
+let universes evd = evd.universes.uctx_universes
+
+(* Conversion w.r.t. an evar map and its local universes. *)
+
+let conversion_gen env evd pb t u =
+  match pb with 
+  | Reduction.CONV -> 
+    Reduction.trans_conv_universes 
+      full_transparent_state ~evars:(existential_opt_value evd) env 
+      evd.universes.uctx_universes t u
+  | Reduction.CUMUL -> Reduction.trans_conv_leq_universes
+     full_transparent_state ~evars:(existential_opt_value evd) env 
+    evd.universes.uctx_universes t u
+
+(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *)
+(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *)
+
+let conversion env d pb t u =
+  conversion_gen env d pb t u; d
+
+let test_conversion env d pb t u =
+  try conversion_gen env d pb t u; true
+  with _ -> false
+
+let eq_constr_univs evd t u =
+  let b, c = Universes.eq_constr_univs_infer evd.universes.uctx_universes t u in
+    if b then 
+      try let evd' = add_universe_constraints evd c in evd', b
+      with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false
+    else evd, b
+
+let e_eq_constr_univs evdref t u =
+  let evd, b = eq_constr_univs !evdref t u in
+    evdref := evd; b
+
+let eq_constr_univs_test evd t u =
+  snd (eq_constr_univs evd t u)
+
+let eq_named_context_val d ctx1 ctx2 = 
+  ctx1 == ctx2 ||
+    let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in
+    let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+      Id.equal i1 i2 && Option.equal (eq_constr_univs_test d) c1 c2 
+      && (eq_constr_univs_test d) t1 t2
+    in List.equal eq_named_declaration c1 c2
+
+let eq_evar_body d b1 b2 = match b1, b2 with
+| Evar_empty, Evar_empty -> true
+| Evar_defined t1, Evar_defined t2 -> eq_constr_univs_test d t1 t2
+| _ -> false
+
+let eq_evar_info d ei1 ei2 =
+  ei1 == ei2 ||
+    eq_constr_univs_test d ei1.evar_concl ei2.evar_concl &&
+    eq_named_context_val d (ei1.evar_hyps) (ei2.evar_hyps) &&
+    eq_evar_body d ei1.evar_body ei2.evar_body
+    (** ppedrot: [eq_constr] may be a bit too permissive here *)
+
+
 (**********************************************************)
 (* Accessing metas *)
 
-let meta_list evd = metamap_to_list evd.metas
+(** We use this function to overcome OCaml compiler limitations and to prevent
+    the use of costly in-place modifications. *)
+let set_metas evd metas = {
+  defn_evars = evd.defn_evars;
+  undf_evars = evd.undf_evars;
+  universes  = evd.universes;
+  conv_pbs = evd.conv_pbs;
+  last_mods = evd.last_mods;
+  metas;
+  effects = evd.effects;
+  evar_names = evd.evar_names;
+  future_goals = evd.future_goals;
+  principal_future_goal = evd.principal_future_goal;
+}
 
-let find_meta evd mv = Metamap.find mv evd.metas
+let meta_list evd = metamap_to_list evd.metas
 
 let undefined_metas evd =
-  List.sort Pervasives.compare (map_succeed (function
-    | (n,Clval(_,_,typ)) -> failwith ""
-    | (n,Cltyp (_,typ))  -> n)
-    (meta_list evd))
-
-let metas_of evd =
-  List.map (function
-    | (n,Clval(_,_,typ)) -> (n,typ.rebus)
-    | (n,Cltyp (_,typ))  -> (n,typ.rebus))
-    (meta_list evd)
+  let filter = function
+    | (n,Clval(_,_,typ)) -> None
+    | (n,Cltyp (_,typ))  -> Some n
+  in
+  let m = List.map_filter filter (meta_list evd) in
+  List.sort Int.compare m
 
 let map_metas_fvalue f evd =
-  { evd with metas =
-      Metamap.map
-        (function
-          | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
-          | x -> x) evd.metas }
+  let map = function
+  | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ)
+  | x -> x
+  in
+  set_metas evd (Metamap.smartmap map evd.metas)
 
 let meta_opt_fvalue evd mv =
   match Metamap.find mv evd.metas with
@@ -614,7 +1374,7 @@ let try_meta_fvalue evd mv =
 
 let meta_fvalue evd mv =
   try try_meta_fvalue evd mv
-  with Not_found -> anomaly "meta_fvalue: meta has no value"
+  with Not_found -> anomaly ~label:"meta_fvalue" (Pp.str "meta has no value")
 
 let meta_value evd mv =
   (fst (try_meta_fvalue evd mv)).rebus
@@ -627,39 +1387,55 @@ let meta_ftype evd mv =
 let meta_type evd mv = (meta_ftype evd mv).rebus
 
 let meta_declare mv v ?(name=Anonymous) evd =
-  { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas }
+  let metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas in
+  set_metas evd metas
 
-let meta_assign mv (v,pb) evd =
-  match Metamap.find mv evd.metas with
-  | Cltyp(na,ty) ->
-      { evd with
-        metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }
-  | _ -> anomaly "meta_assign: already defined"
+let meta_assign mv (v, pb) evd =
+  let modify _ = function
+  | Cltyp (na, ty) -> Clval (na, (mk_freelisted v, pb), ty)
+  | _ -> anomaly ~label:"meta_assign" (Pp.str "already defined")
+  in
+  let metas = Metamap.modify mv modify evd.metas in
+  set_metas evd metas
 
-let meta_reassign mv (v,pb) evd =
-  match Metamap.find mv evd.metas with
-  | Clval(na,_,ty) ->
-      { evd with
-        metas = Metamap.add mv (Clval(na,(mk_freelisted v,pb),ty)) evd.metas }
-  | _ -> anomaly "meta_reassign: not yet defined"
+let meta_reassign mv (v, pb) evd =
+  let modify _ = function
+  | Clval(na, _, ty) -> Clval (na, (mk_freelisted v, pb), ty)
+  | _ -> anomaly ~label:"meta_reassign" (Pp.str "not yet defined")
+  in
+  let metas = Metamap.modify mv modify evd.metas in
+  set_metas evd metas
 
 (* If the meta is defined then forget its name *)
 let meta_name evd mv =
   try fst (clb_name (Metamap.find mv evd.metas)) with Not_found -> Anonymous
 
+let explain_no_such_bound_variable evd id =
+  let mvl =
+    List.rev (Metamap.fold (fun n clb l ->
+      let na = fst (clb_name clb) in
+      if na != Anonymous then out_name na :: l else l)
+    evd.metas []) in
+  errorlabstrm "Evd.meta_with_name"
+    (str"No such bound variable " ++ pr_id id ++
+     (if mvl == [] then str " (no bound variables at all in the expression)."
+      else
+        (str" (possible name" ++
+         str (if List.length mvl == 1 then " is: " else "s are: ") ++
+         pr_enum pr_id mvl ++ str").")))
+
 let meta_with_name evd id =
   let na = Name id in
   let (mvl,mvnodef) =
     Metamap.fold
       (fun n clb (l1,l2 as l) ->
         let (na',def) = clb_name clb in
-        if na = na' then if def then (n::l1,l2) else (n::l1,n::l2)
+        if Name.equal na na' then if def then (n::l1,l2) else (n::l1,n::l2)
         else l)
       evd.metas ([],[]) in
   match mvnodef, mvl with
     | _,[]  ->
-	errorlabstrm "Evd.meta_with_name"
-          (str"No such bound variable " ++ pr_id id ++ str".")
+      explain_no_such_bound_variable evd id
     | ([n],_|_,[n]) ->
 	n
     | _  ->
@@ -667,36 +1443,55 @@ let meta_with_name evd id =
           (str "Binder name \"" ++ pr_id id ++
            strbrk "\" occurs more than once in clause.")
 
+let clear_metas evd = {evd with metas = Metamap.empty}
 
 let meta_merge evd1 evd2 =
-  {evd2 with
-    metas = List.fold_left (fun m (n,v) -> Metamap.add n v m)
-      evd2.metas (metamap_to_list evd1.metas) }
+  let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in
+  let universes = union_evar_universe_context evd2.universes evd1.universes in
+  {evd2 with universes; metas; }
 
 type metabinding = metavariable * constr * instance_status
 
 let retract_coercible_metas evd =
-  let mc,ml =
-    Metamap.fold (fun n v (mc,ml) ->
-      match v with
-	| Clval (na,(b,(Conv,CoerceToType as s)),typ) ->
-	    (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml
-	| v ->
-	    mc, Metamap.add n v ml)
-      evd.metas ([],Metamap.empty) in
-  mc, { evd with metas = ml }
-
-let rec list_assoc_in_triple x = function
-    [] -> raise Not_found
-  | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l
-
-let subst_defined_metas bl c =
+  let mc = ref [] in
+  let map n v = match v with
+  | Clval (na, (b, (Conv, CoerceToType as s)), typ) ->
+    let () = mc := (n, b.rebus, s) :: !mc in
+    Cltyp (na, typ)
+  | v -> v
+  in
+  let metas = Metamap.smartmapi map evd.metas in
+  !mc, set_metas evd metas
+
+let subst_defined_metas_evars (bl,el) c =
   let rec substrec c = match kind_of_term c with
-    | Meta i -> substrec (list_assoc_snd_in_triple i bl)
+    | Meta i ->
+      let select (j,_,_) = Int.equal i j in
+      substrec (pi2 (List.find select bl))
+    | Evar (evk,args) ->
+      let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in
+      (try substrec (pi3 (List.find select el))
+       with Not_found -> map_constr substrec c)
     | _ -> map_constr substrec c
   in try Some (substrec c) with Not_found -> None
 
+let evar_source_of_meta mv evd =
+  match meta_name evd mv with
+  | Anonymous -> (Loc.ghost,Evar_kinds.GoalEvar)
+  | Name id -> (Loc.ghost,Evar_kinds.VarInstance id)
+
+let dependent_evar_ident ev evd =
+  let evi = find evd ev in
+  match evi.evar_source with
+  | (_,Evar_kinds.VarInstance id) -> id
+  | _ -> anomaly (str "Not an evar resulting of a dependent binding")
+
 (*******************************************************************)
+
+type pending = (* before: *) evar_map * (* after: *) evar_map
+
+type pending_constr = pending * constr
+
 type open_constr = evar_map * constr
 
 (*******************************************************************)
@@ -704,10 +1499,57 @@ type open_constr = evar_map * constr
   type ['a] *)
 type 'a sigma = {
   it : 'a ;
-  sigma : evar_map}
+  sigma : evar_map
+}
 
 let sig_it x = x.it
 let sig_sig x = x.sigma
+let on_sig s f = 
+  let sigma', v = f s.sigma in
+    { s with sigma = sigma' }, v
+
+(*******************************************************************)
+(* The state monad with state an evar map. *)
+
+module MonadR =
+  Monad.Make (struct
+
+    type +'a t = evar_map -> evar_map * 'a
+
+    let return a = fun s -> (s,a)
+
+    let (>>=) x f = fun s ->
+      let (s',a) = x s in
+      f a s'
+
+    let (>>) x y = fun s ->
+      let (s',()) = x s in
+      y s'
+
+    let map f x = fun s ->
+      on_snd f (x s)
+
+  end)
+
+module Monad =
+  Monad.Make (struct
+
+    type +'a t = evar_map -> 'a * evar_map
+
+    let return a = fun s -> (a,s)
+
+    let (>>=) x f = fun s ->
+      let (a,s') = x s in
+      f a s'
+
+    let (>>) x y = fun s ->
+      let ((),s') = x s in
+      y s'
+
+    let map f x = fun s ->
+      on_fst f (x s)
+
+  end)
 
 (**********************************************************)
 (* Failure explanation *)
@@ -717,6 +1559,8 @@ type unsolvability_explanation = SeveralInstancesFound of int
 (**********************************************************)
 (* Pretty-printing *)
 
+let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma)
+
 let pr_instance_status (sc,typ) =
   begin match sc with
   | IsSubType -> str " [or a subtype of it]"
@@ -753,27 +1597,35 @@ let pr_decl ((id,b,_),ok) =
   | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
       print_constr c ++ str (if ok then ")" else "}")
 
-let pr_evar_source = function
-  | QuestionMark _ -> str "underscore"
-  | CasesType -> str "pattern-matching return predicate"
-  | BinderType (Name id) -> str "type of " ++ Nameops.pr_id id
-  | BinderType Anonymous -> str "type of anonymous binder"
-  | ImplicitArg (c,(n,ido),b) ->
+let rec pr_evar_source = function
+  | Evar_kinds.QuestionMark _ -> str "underscore"
+  | Evar_kinds.CasesType false -> str "pattern-matching return predicate"
+  | Evar_kinds.CasesType true ->
+      str "subterm of pattern-matching return predicate"
+  | Evar_kinds.BinderType (Name id) -> str "type of " ++ Nameops.pr_id id
+  | Evar_kinds.BinderType Anonymous -> str "type of anonymous binder"
+  | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
       let id = Option.get ido in
       str "parameter " ++ pr_id id ++ spc () ++ str "of" ++
-      spc () ++ print_constr (constr_of_global c)
-  | InternalHole -> str "internal placeholder"
-  | TomatchTypeParameter (ind,n) ->
-      nth n ++ str " argument of type " ++ print_constr (mkInd ind)
-  | GoalEvar -> str "goal evar"
-  | ImpossibleCase -> str "type of impossible pattern-matching clause"
-  | MatchingVar _ -> str "matching variable"
+      spc () ++ print_constr (printable_constr_of_global c)
+  | Evar_kinds.InternalHole -> str "internal placeholder"
+  | Evar_kinds.TomatchTypeParameter (ind,n) ->
+      pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind)
+  | Evar_kinds.GoalEvar -> str "goal evar"
+  | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause"
+  | Evar_kinds.MatchingVar _ -> str "matching variable"
+  | Evar_kinds.VarInstance id -> str "instance of " ++ pr_id id
+  | Evar_kinds.SubEvar evk ->
+      str "subterm of " ++ str (string_of_existential evk)
 
 let pr_evar_info evi =
   let phyps =
     try
-      let decls = List.combine (evar_context evi) (evar_filter evi) in
-      prlist_with_sep pr_spc pr_decl (List.rev decls)
+      let decls = match Filter.repr (evar_filter evi) with
+      | None -> List.map (fun c -> (c, true)) (evar_context evi)
+      | Some filter -> List.combine (evar_context evi) filter
+      in
+      prlist_with_sep spc pr_decl (List.rev decls)
     with Invalid_argument _ -> str "Ill-formed filtered context" in
   let pty = print_constr evi.evar_concl in
   let pb =
@@ -794,95 +1646,151 @@ let pr_evar_info evi =
     (str"["  ++ phyps ++ spc () ++ str"|- "  ++ pty ++ pb ++ str"]" ++
        candidates ++ spc() ++ src)
 
-let compute_evar_dependency_graph (sigma:evar_map) =
+let compute_evar_dependency_graph (sigma : evar_map) =
   (* Compute the map binding ev to the evars whose body depends on ev *)
-  fold (fun evk evi acc ->
-    let deps =
-      match evar_body evi with
-      | Evar_empty -> ExistentialSet.empty
-      | Evar_defined c -> collect_evars c in
-    ExistentialSet.fold (fun evk' acc ->
-      let tab = try ExistentialMap.find evk' acc with Not_found -> [] in
-      ExistentialMap.add evk' ((evk,evi)::tab) acc) deps acc)
-    sigma ExistentialMap.empty
+  let fold evk evi acc =
+    let fold_ev evk' acc =
+      let tab =
+        try EvMap.find evk' acc
+        with Not_found -> Evar.Set.empty
+      in
+      EvMap.add evk' (Evar.Set.add evk tab) acc
+    in
+    match evar_body evi with
+    | Evar_empty -> assert false
+    | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc
+  in
+  EvMap.fold fold sigma.defn_evars EvMap.empty
 
 let evar_dependency_closure n sigma =
+  (** Create the DAG of depth [n] representing the recursive dependencies of
+      undefined evars. *)
   let graph = compute_evar_dependency_graph sigma in
-  let order a b = fst a < fst b in
-  let rec aux n l =
-    if n=0 then l
-    else
-      let l' =
-        list_map_append (fun (evk,_) ->
-          try ExistentialMap.find evk graph with Not_found -> []) l in
-      aux (n-1) (list_uniquize (Sort.list order (l@l'))) in
-  aux n (undefined_list sigma)
-
-let pr_evar_map_t depth sigma =
-  let (evars,(uvs,univs)) = sigma.evars in
-  let pr_evar_list l =
-    h 0 (prlist_with_sep pr_fnl
-	   (fun (ev,evi) ->
-	     h 0 (str(string_of_existential ev) ++
-                    str"==" ++ pr_evar_info evi)) l) in
-  let evs =
-    if EvarInfoMap.is_empty evars then mt ()
+  let rec aux n curr accu =
+    if Int.equal n 0 then Evar.Set.union curr accu
     else
-      match depth with
-      | None ->
-          (* Print all evars *)
-          str"EVARS:"++brk(0,1)++pr_evar_list (to_list sigma)++fnl()
-      | Some n ->
-          (* Print all evars *)
-          str"UNDEFINED EVARS"++
-          (if n=0 then mt() else str" (+level "++int n++str" closure):")++
-          brk(0,1)++
-          pr_evar_list (evar_dependency_closure n sigma)++fnl()
-  and svs =
-    if Univ.UniverseLSet.is_empty uvs then mt ()
-    else str"UNIVERSE VARIABLES:"++brk(0,1)++
-      h 0 (prlist_with_sep pr_fnl 
-	     (fun u -> Univ.pr_uni_level u) (Univ.UniverseLSet.elements uvs))++fnl()
-  and cs =
-    if Univ.is_initial_universes univs then mt ()
-    else str"UNIVERSES:"++brk(0,1)++
-      h 0 (Univ.pr_universes univs)++fnl()
-  in evs ++ svs ++ cs
+      let fold evk accu =
+        try
+          let deps = EvMap.find evk graph in
+          Evar.Set.union deps accu
+        with Not_found -> accu
+      in
+      (** Consider only the newly added evars *)
+      let ncurr = Evar.Set.fold fold curr Evar.Set.empty in
+      (** Merge the others *)
+      let accu = Evar.Set.union curr accu in
+      aux (n - 1) ncurr accu
+  in
+  let undef = EvMap.domain (undefined_map sigma) in
+  aux n undef Evar.Set.empty
+
+let evar_dependency_closure n sigma =
+  let deps = evar_dependency_closure n sigma in
+  let map = EvMap.bind (fun ev -> find sigma ev) deps in
+  EvMap.bindings map
+
+let has_no_evar sigma =
+  EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars
+
+let pr_uctx_level uctx = 
+  let map, map_rev = uctx.uctx_names in 
+    fun l ->
+      try str(Univ.LMap.find l map_rev)
+      with Not_found -> 
+	Universes.pr_with_global_universes l
+
+let pr_evd_level evd = pr_uctx_level evd.universes
+
+let pr_evar_universe_context ctx =
+  let prl = pr_uctx_level ctx in
+  if is_empty_evar_universe_context ctx then mt ()
+  else
+    (str"UNIVERSES:"++brk(0,1)++ 
+       h 0 (Univ.pr_universe_context_set prl ctx.uctx_local) ++ fnl () ++
+     str"ALGEBRAIC UNIVERSES:"++brk(0,1)++
+     h 0 (Univ.LSet.pr prl ctx.uctx_univ_algebraic) ++ fnl() ++
+     str"UNDEFINED UNIVERSES:"++brk(0,1)++
+       h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables) ++ fnl())
 
 let print_env_short env =
-  let pr_body n = function None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
+  let pr_body n = function
+  | None -> pr_name n
+  | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
   let pr_named_decl (n, b, _) = pr_body (Name n) b in
   let pr_rel_decl (n, b, _) = pr_body n b in
   let nc = List.rev (named_context env) in
   let rc = List.rev (rel_context env) in
-    str "[" ++ prlist_with_sep pr_spc pr_named_decl nc ++ str "]" ++ spc () ++
-    str "[" ++ prlist_with_sep pr_spc pr_rel_decl rc ++ str "]"
-
-let pr_constraints pbs =
-  h 0
-    (prlist_with_sep pr_fnl 
-       (fun (pbty,env,t1,t2) ->
-	  print_env_short env ++ spc () ++ str "|-" ++ spc () ++
-	    print_constr t1 ++ spc() ++
-	    str (match pbty with
-		 | Reduction.CONV -> "=="
-		 | Reduction.CUMUL -> "<=") ++
-	    spc() ++ print_constr t2) pbs)
-
-let pr_evar_map_constraints evd =
-  if evd.conv_pbs = [] then mt() 
-  else pr_constraints evd.conv_pbs++fnl()
-
-let pr_evar_map allevars evd =
-  let pp_evm =
-    if EvarMap.is_empty evd.evars then mt() else
-      pr_evar_map_t allevars evd++fnl() in
-  let cstrs = if evd.conv_pbs = [] then mt() else
-    str"CONSTRAINTS:"++brk(0,1)++pr_constraints evd.conv_pbs++fnl() in
-  let pp_met =
-    if Metamap.is_empty evd.metas then mt() else
-      str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
-  v 0 (pp_evm ++ cstrs ++ pp_met)
+    str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++
+    str "[" ++ pr_sequence pr_rel_decl rc ++ str "]"
+
+let pr_evar_constraints pbs =
+  let pr_evconstr (pbty, env, t1, t2) =
+    print_env_short env ++ spc () ++ str "|-" ++ spc () ++
+      print_constr_env env t1 ++ spc () ++
+      str (match pbty with
+            | Reduction.CONV -> "=="
+            | Reduction.CUMUL -> "<=") ++
+      spc () ++ print_constr_env env t2
+  in
+  prlist_with_sep fnl pr_evconstr pbs
+
+let pr_evar_map_gen with_univs pr_evars sigma =
+  let { universes = uvs } = sigma in
+  let evs = if has_no_evar sigma then mt () else pr_evars sigma ++ fnl ()
+  and svs = if with_univs then pr_evar_universe_context uvs else mt ()
+  and cstrs =
+    if List.is_empty sigma.conv_pbs then mt ()
+    else
+    str "CONSTRAINTS:" ++ brk (0, 1) ++
+      pr_evar_constraints sigma.conv_pbs ++ fnl ()
+  and metas =
+    if Metamap.is_empty sigma.metas then mt ()
+    else
+      str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas
+  in
+  evs ++ svs ++ cstrs ++ metas
+
+let pr_evar_list sigma l =
+  let pr (ev, evi) =
+    h 0 (str (string_of_existential ev) ++
+      str "==" ++ pr_evar_info evi ++
+      (if evi.evar_body == Evar_empty
+       then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}"
+       else mt ()))
+  in
+  h 0 (prlist_with_sep fnl pr l)
+
+let pr_evar_by_depth depth sigma = match depth with
+| None ->
+  (* Print all evars *)
+  str"EVARS:"++brk(0,1)++pr_evar_list sigma (to_list sigma)++fnl()
+| Some n ->
+  (* Print all evars *)
+  str"UNDEFINED EVARS:"++
+  (if Int.equal n 0 then mt() else str" (+level "++int n++str" closure):")++
+  brk(0,1)++
+  pr_evar_list sigma (evar_dependency_closure n sigma)++fnl()
+
+let pr_evar_by_filter filter sigma =
+  let defined = Evar.Map.filter filter sigma.defn_evars in
+  let undefined = Evar.Map.filter filter sigma.undf_evars in
+  let prdef =
+    if Evar.Map.is_empty defined then mt ()
+    else str "DEFINED EVARS:" ++ brk (0, 1) ++
+      pr_evar_list sigma (Evar.Map.bindings defined)
+  in
+  let prundef =
+    if Evar.Map.is_empty undefined then mt ()
+    else str "UNDEFINED EVARS:" ++ brk (0, 1) ++
+      pr_evar_list sigma (Evar.Map.bindings undefined)
+  in
+  prdef ++ prundef
+
+let pr_evar_map ?(with_univs=true) depth sigma =
+  pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_depth depth sigma) sigma
+
+let pr_evar_map_filter ?(with_univs=true) filter sigma =
+  pr_evar_map_gen with_univs (fun sigma -> pr_evar_by_filter filter sigma) sigma
 
 let pr_metaset metas =
-  str "[" ++ prlist_with_sep spc pr_meta (Metaset.elements metas) ++ str "]"
+  str "[" ++ pr_sequence pr_meta (Metaset.elements metas) ++ str "]"
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index d5bf2f68..53f8b0db 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -1,126 +1,108 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
 open Term
-open Sign
+open Context
 open Environ
-open Libnames
 open Mod_subst
-open Termops
 
-(********************************************************************
-   Meta map *)
-
-module Metamap : Map.S with type key = metavariable
-
-module Metaset : Set.S with type elt = metavariable
+(** {5 Existential variables and unification states}
 
-val meta_exists : (metavariable -> bool) -> Metaset.t -> bool
+    A unification state (of type [evar_map]) is primarily a finite mapping
+    from existential variables to records containing the type of the evar
+    ([evar_concl]), the context under which it was introduced ([evar_hyps])
+    and its definition ([evar_body]). [evar_extra] is used to add any other
+    kind of information.
 
-type 'a freelisted = {
-  rebus : 'a;
-  freemetas : Metaset.t }
+    It also contains conversion constraints, debugging information and
+    information about meta variables. *)
 
-val metavars_of : constr -> Metaset.t
-val mk_freelisted : constr -> constr freelisted
-val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
+(** {6 Evars} *)
 
-(** Status of an instance found by unification wrt to the meta it solves:
-  - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
-  - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
-  - a term that can be eta-expanded n times while still being a solution
-    (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
-*)
-
-type instance_constraint = IsSuperType | IsSubType | Conv
+type evar = existential_key
+(** Existential variables. TODO: Should be made opaque one day. *)
 
-(** Status of the unification of the type of an instance against the type of
-     the meta it instantiates:
-   - CoerceToType means that the unification of types has not been done
-     and that a coercion can still be inserted: the meta should not be
-     substituted freely (this happens for instance given via the
-     "with" binding clause).
-   - TypeProcessed means that the information obtainable from the
-     unification of types has been extracted.
-   - TypeNotProcessed means that the unification of types has not been
-     done but it is known that no coercion may be inserted: the meta
-     can be substituted freely.
-*)
+val string_of_existential : evar -> string
 
-type instance_typing_status =
-    CoerceToType | TypeNotProcessed | TypeProcessed
+(** {6 Evar filters} *)
 
-(** Status of an instance together with the status of its type unification *)
+module Filter :
+sig
+  type t
+  (** Evar filters, seen as bitmasks. *)
 
-type instance_status = instance_constraint * instance_typing_status
+  val equal : t -> t -> bool
+  (** Equality over filters *)
 
-(** Clausal environments *)
+  val identity : t
+  (** The identity filter. *)
 
-type clbinding =
-  | Cltyp of name * constr freelisted
-  | Clval of name * (constr freelisted * instance_status) * constr freelisted
+  val filter_list : t -> 'a list -> 'a list
+  (** Filter a list. Sizes must coincide. *)
 
-val map_clb : (constr -> constr) -> clbinding -> clbinding
+  val filter_array : t -> 'a array -> 'a array
+  (** Filter an array. Sizes must coincide. *)
 
+  val extend : int -> t -> t
+  (** [extend n f] extends [f] on the left with [n]-th times [true]. *)
 
-(********************************************************************
-  ** Kinds of existential variables ***)
+  val compose : t -> t -> t
+  (** Horizontal composition : [compose f1 f2] only keeps parts of [f2] where
+      [f1] is set. In particular, [f1] and [f2] must have the same length. *)
 
-(** Should the obligation be defined (opaque or transparent (default)) or
-   defined transparent and expanded in the term? *)
+  val apply_subfilter : t -> bool list -> t
+  (** [apply_subfilter f1 f2] applies filter [f2] where [f1] is [true]. In
+      particular, the length of [f2] is the number of times [f1] is [true] *)
 
-type obligation_definition_status = Define of bool | Expand
+  val restrict_upon : t -> int -> (int -> bool) -> t option
+  (** Ad-hoc primitive. *)
 
-(** Evars *)
-type hole_kind =
-  | ImplicitArg of global_reference * (int * identifier option) * bool (** Force inference *)
-  | BinderType of name
-  | QuestionMark of obligation_definition_status
-  | CasesType
-  | InternalHole
-  | TomatchTypeParameter of inductive * int
-  | GoalEvar
-  | ImpossibleCase
-  | MatchingVar of bool * identifier
+  val map_along : (bool -> 'a -> bool) -> t -> 'a list -> t
+  (** Apply the function on the filter and the list. Sizes must coincide. *)
 
-(********************************************************************
-  ** Existential variables and unification states ***)
+  val make : bool list -> t
+  (** Create out of a list *)
 
-(** A unification state (of type [evar_map]) is primarily a finite mapping
-    from existential variables to records containing the type of the evar
-   ([evar_concl]), the context under which it was introduced ([evar_hyps])
-   and its definition ([evar_body]). [evar_extra] is used to add any other
-   kind of information.
-   It also contains conversion constraints, debugging information and
-   information about meta variables. *)
+  val repr :  t -> bool list option
+  (** Observe as a bool list. *)
 
-(** Information about existential variables. *)
-type evar = existential_key
+end
 
-val string_of_existential : evar -> string
-val existential_of_int : int -> evar
+(** {6 Evar infos} *)
 
 type evar_body =
   | Evar_empty
   | Evar_defined of constr
 
+
+module Store : Store.S
+(** Datatype used to store additional information in evar maps. *)
+
 type evar_info = {
   evar_concl : constr;
+  (** Type of the evar. *)
   evar_hyps : named_context_val;
+  (** Context of the evar. *)
   evar_body : evar_body;
-  evar_filter : bool list;
-  evar_source : hole_kind located;
+  (** Optional content of the evar. *)
+  evar_filter : Filter.t;
+  (** Boolean mask over {!evar_hyps}. Should have the same length.
+      TODO: document me more. *)
+  evar_source : Evar_kinds.t located;
+  (** Information about the evar. *)
   evar_candidates : constr list option;
-  evar_extra : Store.t }
-
-val eq_evar_info : evar_info -> evar_info -> bool
+  (** TODO: document this *)
+  evar_extra : Store.t
+  (** Extra store, used for clever hacks. *)
+}
 
 val make_evar : named_context_val -> types -> evar_info
 val evar_concl : evar_info -> constr
@@ -129,171 +111,498 @@ val evar_filtered_context : evar_info -> named_context
 val evar_hyps : evar_info -> named_context_val
 val evar_filtered_hyps : evar_info -> named_context_val
 val evar_body : evar_info -> evar_body
-val evar_filter : evar_info -> bool list
-val evar_unfiltered_env :  evar_info -> env
+val evar_filter : evar_info -> Filter.t
 val evar_env :  evar_info -> env
+val evar_filtered_env :  evar_info -> env
 
-(*** Unification state ***)
-type evar_map
+val map_evar_body : (constr -> constr) -> evar_body -> evar_body
+val map_evar_info : (constr -> constr) -> evar_info -> evar_info
+
+(** {6 Unification state} **)
+
+type evar_universe_context
+(** The universe context associated to an evar map *)
 
-(** Unification state and existential variables *)
+type evar_map
+(** Type of unification state. Essentially a bunch of state-passing data needed
+    to handle incremental term construction. *)
 
+val progress_evar_map : evar_map -> evar_map -> bool
 (** Assuming that the second map extends the first one, this says if
    some existing evar has been refined *)
-val progress_evar_map : evar_map -> evar_map -> bool
 
 val empty : evar_map
+(** The empty evar map. *)
+
+val from_env : ?ctx:evar_universe_context -> env -> evar_map
+(** The empty evar map with given universe context, taking its initial 
+    universes from env. *)
+
 val is_empty : evar_map -> bool
+(** Whether an evarmap is empty. *)
+
+val has_undefined : evar_map -> bool
 (** [has_undefined sigma] is [true] if and only if
     there are uninstantiated evars in [sigma]. *)
-val has_undefined : evar_map -> bool
 
+val add : evar_map -> evar -> evar_info -> evar_map
 (** [add sigma ev info] adds [ev] with evar info [info] in sigma.
     Precondition: ev must not preexist in [sigma]. *)
-val add : evar_map -> evar -> evar_info -> evar_map
 
 val find : evar_map -> evar -> evar_info
+(** Recover the data associated to an evar. *)
+
 val find_undefined : evar_map -> evar -> evar_info
+(** Same as {!find} but restricted to undefined evars. For efficiency
+    reasons. *)
+
 val remove : evar_map -> evar -> evar_map
+(** Remove an evar from an evar map. Use with caution. *)
+
 val mem : evar_map -> evar -> bool
-val undefined_list : evar_map -> (evar * evar_info) list
-val to_list : evar_map -> (evar * evar_info) list
+(** Whether an evar is present in an evarmap. *)
+
 val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
+(** Apply a function to all evars and their associated info in an evarmap. *)
+
 val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
-val merge : evar_map -> evar_map -> evar_map
+(** Same as {!fold}, but restricted to undefined evars. For efficiency
+    reasons. *)
+
+val raw_map : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
+(** Apply the given function to all evars in the map. Beware: this function
+    expects the argument function to preserve the kind of [evar_body], i.e. it
+    must send [Evar_empty] to [Evar_empty] and [Evar_defined c] to some
+    [Evar_defined c']. *)
+
+val raw_map_undefined : (evar -> evar_info -> evar_info) -> evar_map -> evar_map
+(** Same as {!raw_map}, but restricted to undefined evars. For efficiency
+    reasons. *)
+
 val define : evar -> constr -> evar_map -> evar_map
+(** Set the body of an evar to the given constr. It is expected that:
+    {ul
+      {- The evar is already present in the evarmap.}
+      {- The evar is not defined in the evarmap yet.}
+      {- All the evars present in the constr should be present in the evar map.}
+    } *)
+
+val cmap : (constr -> constr) -> evar_map -> evar_map
+(** Map the function on all terms in the evar map. *)
 
 val is_evar : evar_map -> evar -> bool
+(** Alias for {!mem}. *)
 
 val is_defined : evar_map -> evar -> bool
+(** Whether an evar is defined in an evarmap. *)
+
 val is_undefined : evar_map -> evar -> bool
+(** Whether an evar is not defined in an evarmap. *)
 
 val add_constraints : evar_map -> Univ.constraints -> evar_map
+(** Add universe constraints in an evar map. *)
 
-(** {6 ... } *)
-(** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
-    no body and [Not_found] if it does not exist in [sigma] *)
+val undefined_map : evar_map -> evar_info Evar.Map.t
+(** Access the undefined evar mapping directly. *)
+
+val eq_evar_info : evar_map -> evar_info -> evar_info -> bool
+(** Compare the evar_info's up to the universe constraints of the evar map. *)
+
+val drop_all_defined : evar_map -> evar_map
+
+(** {6 Instantiating partial terms} *)
 
 exception NotInstantiatedEvar
+
 val existential_value : evar_map -> existential -> constr
+(** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+    no body and [Not_found] if it does not exist in [sigma] *)
+
 val existential_type : evar_map -> existential -> types
+
 val existential_opt_value : evar_map -> existential -> constr option
+(** Same as {!existential_value} but returns an option instead of raising an
+    exception. *)
 
-val instantiate_evar : named_context -> constr -> constr list -> constr
+val evar_instance_array : (Id.t -> 'a -> bool) -> evar_info ->
+  'a array -> (Id.t * 'a) list
 
-(** Assume empty universe constraints in [evar_map] and [conv_pbs] *)
-val subst_evar_defs_light : substitution -> evar_map -> evar_map
+val instantiate_evar_array : evar_info -> constr -> constr array -> constr
 
+val evars_reset_evd  : ?with_conv_pbs:bool -> ?with_univs:bool -> 
+  evar_map ->  evar_map -> evar_map
 (** spiwack: this function seems to somewhat break the abstraction. *)
-val evars_reset_evd  : ?with_conv_pbs:bool -> evar_map ->  evar_map -> evar_map
 
+(** {6 Misc} *)
 
-(* spiwack: [is_undefined_evar] should be considered a candidate
-                   for moving to evarutils *)
-val is_undefined_evar :  evar_map -> constr -> bool
-val undefined_evars : evar_map -> evar_map
-val defined_evars : evar_map -> evar_map
-(* [fold_undefined f m] iterates ("folds") function [f] over the undefined
-    evars (that is, whose value is [Evar_empty]) of map [m].
-    It optimizes the call of {!Evd.fold} to [f] and [undefined_evars m] *)
-val fold_undefined : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
 val evar_declare :
-  named_context_val -> evar -> types -> ?src:loc * hole_kind ->
-      ?filter:bool list -> ?candidates:constr list -> evar_map -> evar_map
-val evar_source : existential_key -> evar_map -> hole_kind located
+  named_context_val -> evar -> types -> ?src:Loc.t * Evar_kinds.t ->
+      ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t ->
+      ?naming:Misctypes.intro_pattern_naming_expr -> evar_map -> evar_map
+(** Convenience function. Just a wrapper around {!add}. *)
+
+val restrict : evar -> evar -> Filter.t -> ?candidates:constr list ->
+  evar_map -> evar_map
+(** Restrict an undefined evar into a new evar by filtering context and
+    possibly limiting the instances to a set of candidates *)
+
+val downcast : evar -> types -> evar_map -> evar_map
+(** Change the type of an undefined evar to a new type assumed to be a
+    subtype of its current type; subtyping must be ensured by caller *)
+
+val evar_source : existential_key -> evar_map -> Evar_kinds.t located
+(** Convenience function. Wrapper around {!find} to recover the source of an
+    evar in a given evar map. *)
+
+val evar_ident : existential_key -> evar_map -> Id.t
+
+val rename : existential_key -> Id.t -> evar_map -> evar_map
+
+val evar_key : Id.t -> evar_map -> existential_key
+
+val evar_source_of_meta : metavariable -> evar_map -> Evar_kinds.t located
+
+val dependent_evar_ident : existential_key -> evar_map -> Id.t
+
+(** {5 Side-effects} *)
+
+val emit_side_effects : Declareops.side_effects -> evar_map -> evar_map
+(** Push a side-effect into the evar map. *)
+
+val eval_side_effects : evar_map -> Declareops.side_effects
+(** Return the effects contained in the evar map. *)
+
+val drop_side_effects : evar_map -> evar_map
+(** This should not be used. For hacking purposes. *)
 
-(* spiwack: this function seems to somewhat break the abstraction. 
-   [evar_merge evd ev1] extends the evars of [evd] with [evd1] *)
-val evar_merge : evar_map -> evar_map -> evar_map
+(** {5 Future goals} *)
+
+val declare_future_goal : Evar.t -> evar_map -> evar_map
+(** Adds an existential variable to the list of future goals. For
+    internal uses only. *)
+
+val declare_principal_goal : Evar.t -> evar_map -> evar_map
+(** Adds an existential variable to the list of future goals and make
+    it principal. Only one existential variable can be made principal, an
+    error is raised otherwise. For internal uses only. *)
+
+val future_goals : evar_map -> Evar.t list
+(** Retrieves the list of future goals. Used by the [refine] primitive
+    of the tactic engine. *)
+
+val principal_future_goal : evar_map -> Evar.t option
+(** Retrieves the name of the principal existential variable if there
+    is one. Used by the [refine] primitive of the tactic engine. *)
+
+val reset_future_goals : evar_map -> evar_map
+(** Clears the list of future goals (as well as the principal future
+    goal). Used by the [refine] primitive of the tactic engine. *)
+
+val restore_future_goals : evar_map -> Evar.t list -> Evar.t option -> evar_map
+(** Sets the future goals (including the principal future goal) to a
+    previous value. Intended to be used after a local list of future
+    goals has been consumed. Used by the [refine] primitive of the
+    tactic engine. *)
+
+(** {5 Sort variables}
+
+    Evar maps also keep track of the universe constraints defined at a given
+    point. This section defines the relevant manipulation functions. *)
+
+val whd_sort_variable : evar_map -> constr -> constr
+
+exception UniversesDiffer
+
+val add_universe_constraints : evar_map -> Universes.universe_constraints -> evar_map
+(** Add the given universe unification constraints to the evar map.
+    @raises UniversesDiffer in case a first-order unification fails.
+    @raises UniverseInconsistency
+*)
+(** {5 Enriching with evar maps} *)
+
+type 'a sigma = {
+  it : 'a ;
+  (** The base object. *)
+  sigma : evar_map
+  (** The added unification state. *)
+}
+(** The type constructor ['a sigma] adds an evar map to an object of type
+    ['a]. *)
+
+val sig_it  : 'a sigma -> 'a
+val sig_sig : 'a sigma -> evar_map
+val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b
+
+(** {5 The state monad with state an evar map} *)
+
+module MonadR : Monad.S with type +'a t = evar_map -> evar_map * 'a
+module Monad  : Monad.S with type +'a t = evar_map -> 'a * evar_map
+
+
+(** {5 Meta machinery}
+
+    These functions are almost deprecated. They were used before the
+    introduction of the full-fledged evar calculus. In an ideal world, they
+    should be removed. Alas, some parts of the code still use them. Do not use
+    in newly-written code. *)
+
+module Metaset : Set.S with type elt = metavariable
+module Metamap : Map.ExtS with type key = metavariable and module Set := Metaset
+
+type 'a freelisted = {
+  rebus : 'a;
+  freemetas : Metaset.t }
+
+val metavars_of : constr -> Metaset.t
+val mk_freelisted : constr -> constr freelisted
+val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
+
+(** Status of an instance found by unification wrt to the meta it solves:
+  - a supertype of the meta (e.g. the solution to ?X <= T is a supertype of ?X)
+  - a subtype of the meta (e.g. the solution to T <= ?X is a supertype of ?X)
+  - a term that can be eta-expanded n times while still being a solution
+    (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice)
+*)
+
+type instance_constraint = IsSuperType | IsSubType | Conv
+
+val eq_instance_constraint :
+  instance_constraint -> instance_constraint -> bool
+
+(** Status of the unification of the type of an instance against the type of
+     the meta it instantiates:
+   - CoerceToType means that the unification of types has not been done
+     and that a coercion can still be inserted: the meta should not be
+     substituted freely (this happens for instance given via the
+     "with" binding clause).
+   - TypeProcessed means that the information obtainable from the
+     unification of types has been extracted.
+   - TypeNotProcessed means that the unification of types has not been
+     done but it is known that no coercion may be inserted: the meta
+     can be substituted freely.
+*)
+
+type instance_typing_status =
+    CoerceToType | TypeNotProcessed | TypeProcessed
+
+(** Status of an instance together with the status of its type unification *)
+
+type instance_status = instance_constraint * instance_typing_status
+
+(** Clausal environments *)
+
+type clbinding =
+  | Cltyp of Name.t * constr freelisted
+  | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted
 
 (** Unification constraints *)
 type conv_pb = Reduction.conv_pb
 type evar_constraint = conv_pb * env * constr * constr
 val add_conv_pb :  evar_constraint -> evar_map -> evar_map
 
-module ExistentialMap : Map.S with type key = existential_key
-module ExistentialSet : Set.S with type elt = existential_key
 val extract_changed_conv_pbs : evar_map ->
-      (ExistentialSet.t -> evar_constraint -> bool) ->
+      (Evar.Set.t -> evar_constraint -> bool) ->
       evar_map * evar_constraint list
 val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list
+val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t
+
+(** The following functions return the set of evars immediately
+    contained in the object; need the term to be evar-normal otherwise
+    defined evars are returned too. *)
+
+val evar_list : constr -> existential list
+  (** excluding evars in instances of evars and collected with
+     redundancies from right to left (used by tactic "instantiate") *)
 
-val evar_list : evar_map -> constr -> existential list
-val collect_evars : constr -> ExistentialSet.t
+val evars_of_term : constr -> Evar.Set.t
+  (** including evars in instances of evars *)
+
+val evars_of_named_context : named_context -> Evar.Set.t
+
+val evars_of_filtered_evar_info : evar_info -> Evar.Set.t
 
 (** Metas *)
-val find_meta : evar_map -> metavariable -> clbinding
 val meta_list : evar_map -> (metavariable * clbinding) list
 val meta_defined : evar_map -> metavariable -> bool
 
+val meta_value     : evar_map -> metavariable -> constr
 (** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
    meta has no value *)
-val meta_value     : evar_map -> metavariable -> constr
+
 val meta_fvalue    : evar_map -> metavariable -> constr freelisted * instance_status
 val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option
 val meta_type      : evar_map -> metavariable -> types
 val meta_ftype     : evar_map -> metavariable -> types freelisted
-val meta_name      : evar_map -> metavariable -> name
-val meta_with_name : evar_map -> identifier -> metavariable
+val meta_name      : evar_map -> metavariable -> Name.t
+val meta_with_name : evar_map -> Id.t -> metavariable
 val meta_declare   :
-  metavariable -> types -> ?name:name -> evar_map -> evar_map
+  metavariable -> types -> ?name:Name.t -> evar_map -> evar_map
 val meta_assign    : metavariable -> constr * instance_status -> evar_map -> evar_map
 val meta_reassign  : metavariable -> constr * instance_status -> evar_map -> evar_map
 
+val clear_metas : evar_map -> evar_map
+
 (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
 val meta_merge : evar_map -> evar_map -> evar_map
 
 val undefined_metas : evar_map -> metavariable list
-val metas_of : evar_map -> meta_type_map
 val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map
 
 type metabinding = metavariable * constr * instance_status
 
 val retract_coercible_metas : evar_map -> metabinding list * evar_map
-val subst_defined_metas : metabinding list -> constr -> constr option
+val subst_defined_metas_evars : metabinding list * ('a * existential * constr) list -> constr -> constr option
+
+(** {5 FIXME: Nothing to do here} *)
 
 (*********************************************************
-   Sort variables *)
+   Sort/universe variables *)
+
+(** Rigid or flexible universe variables *)
+
+type rigid = 
+  | UnivRigid
+  | UnivFlexible of bool (** Is substitution by an algebraic ok? *)
+
+val univ_rigid : rigid
+val univ_flexible : rigid
+val univ_flexible_alg : rigid
+
+type 'a in_evar_universe_context = 'a * evar_universe_context
+
+val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set
+val evar_universe_context_constraints : evar_universe_context -> Univ.constraints
+val evar_context_universe_context : evar_universe_context -> Univ.universe_context
+val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context
+val empty_evar_universe_context : evar_universe_context
+val union_evar_universe_context : evar_universe_context -> evar_universe_context ->
+  evar_universe_context
+val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst
+
+(** Raises Not_found if not a name for a universe in this map. *)
+val universe_of_name : evar_map -> string -> Univ.universe_level
+val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map
+
+val universes : evar_map -> Univ.universes
+
+val add_constraints_context : evar_universe_context -> 
+  Univ.constraints -> evar_universe_context
+
+
+val normalize_evar_universe_context_variables : evar_universe_context -> 
+  Univ.universe_subst in_evar_universe_context
+
+val normalize_evar_universe_context : evar_universe_context -> 
+  evar_universe_context
+
+val new_univ_level_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level
+val new_univ_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe
+val new_sort_variable : ?name:string -> rigid -> evar_map -> evar_map * sorts
+val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
+val is_sort_variable : evar_map -> sorts -> Univ.universe_level option 
+(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is 
+    not a local sort variable declared in [evm] *)
+val is_flexible_level : evar_map -> Univ.Level.t -> bool
 
-val new_univ_variable : evar_map -> evar_map * Univ.universe
-val new_sort_variable : evar_map -> evar_map * sorts
-val is_sort_variable : evar_map -> sorts -> bool
 val whd_sort_variable : evar_map -> constr -> constr
-val set_leq_sort : evar_map -> sorts -> sorts -> evar_map
-val set_eq_sort : evar_map -> sorts -> sorts -> evar_map
+(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *)
+val normalize_universe : evar_map -> Univ.universe -> Univ.universe
+val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance
 
-(********************************************************************
-   constr with holes *)
-type open_constr = evar_map * constr
+val set_leq_sort : env -> evar_map -> sorts -> sorts -> evar_map
+val set_eq_sort : env -> evar_map -> sorts -> sorts -> evar_map
+val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map
+val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
+val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map
+val set_eq_instances : ?flex:bool -> 
+  evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map
+
+val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool
+val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool
+
+val evar_universe_context : evar_map -> evar_universe_context
+val universe_context_set : evar_map -> Univ.universe_context_set
+val universe_context : evar_map -> Univ.universe_context
+val universe_subst : evar_map -> Universes.universe_opt_subst
+val universes : evar_map -> Univ.universes
+
+
+val merge_universe_context : evar_map -> evar_universe_context -> evar_map
+val set_universe_context : evar_map -> evar_universe_context -> evar_map
+
+val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map
+val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map
+
+val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a
+
+val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst
+val abstract_undefined_variables : evar_universe_context -> evar_universe_context
+
+val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst
+
+val nf_constraints : evar_map -> evar_map
+
+(** Polymorphic universes *)
+
+val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts
+val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant
+val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive
+val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor
+
+val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> 
+  Globnames.global_reference -> evar_map * constr
 
 (********************************************************************
-   The type constructor ['a sigma] adds an evar map to an object of
-  type ['a] *)
-type 'a sigma = {
-  it : 'a ;
-  sigma : evar_map}
+  Conversion w.r.t. an evar map: might generate universe unifications 
+  that are kept in the evarmap.
+  Raises [NotConvertible]. *)
 
-val sig_it  : 'a sigma -> 'a
-val sig_sig : 'a sigma -> evar_map
+val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map
 
-(*********************************************************
-   Failure explanation *)
+val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool
+(** This one forgets about the assignemts of universes. *)
+
+val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool
+(** Syntactic equality up to universes, recording the associated constraints *)
+
+val e_eq_constr_univs : evar_map ref -> constr -> constr -> bool
+(** Syntactic equality up to universes. *)
+
+val eq_constr_univs_test : evar_map -> constr -> constr -> bool
+(** Syntactic equality up to universes, throwing away the (consistent) constraints
+    in case of success. *)
+
+(********************************************************************)
+(* constr with holes and pending resolution of classes, conversion  *)
+(* problems, candidates, etc.                                       *)
+
+type pending = (* before: *) evar_map * (* after: *) evar_map
+
+type pending_constr = pending * constr
+
+type open_constr = evar_map * constr (* Special case when before is empty *)
+
+(** Partially constructed constrs. *)
 
 type unsolvability_explanation = SeveralInstancesFound of int
+(** Failure explanation. *)
 
-(********************************************************************
-   debug pretty-printer: *)
+val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
+
+(** {5 Debug pretty-printers} *)
 
 val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_map_constraints : evar_map -> Pp.std_ppcmds
-val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds
+val pr_evar_constraints : evar_constraint list -> Pp.std_ppcmds
+val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds
+val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) ->
+  evar_map -> Pp.std_ppcmds
 val pr_metaset : Metaset.t -> Pp.std_ppcmds
+val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds
+val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
 
+(** {5 Deprecated functions} *)
 
-(*** /!\Deprecated /!\ **
-   create an [evar_map] with empty meta map: *)
 val create_evar_defs      : evar_map -> evar_map
+(** Create an [evar_map] with empty meta map: *)
+
 val create_goal_evar_defs : evar_map -> evar_map
-val is_defined_evar :  evar_map -> existential -> bool
-val subst_evar_map : substitution -> evar_map -> evar_map
-(*** /Deprecaded ***)
diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml
new file mode 100644
index 00000000..7f7f4d76
--- /dev/null
+++ b/pretyping/find_subterm.ml
@@ -0,0 +1,179 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Errors
+open Names
+open Locus
+open Context
+open Term
+open Nameops
+open Termops
+open Pretype_errors
+
+(** Processing occurrences *)
+
+type occurrence_error =
+  | InvalidOccurrence of int list
+  | IncorrectInValueOccurrence of Id.t
+
+let explain_invalid_occurrence l =
+  let l = List.sort_uniquize Int.compare l in
+  str ("Invalid occurrence " ^ String.plural (List.length l) "number" ^": ")
+  ++ prlist_with_sep spc int l ++ str "."
+
+let explain_incorrect_in_value_occurrence id =
+  pr_id id ++ str " has no value."
+
+let explain_occurrence_error = function
+  | InvalidOccurrence l -> explain_invalid_occurrence l
+  | IncorrectInValueOccurrence id -> explain_incorrect_in_value_occurrence id
+
+let error_occurrences_error e =
+  errorlabstrm "" (explain_occurrence_error e)
+
+let error_invalid_occurrence occ =
+  error_occurrences_error (InvalidOccurrence occ)
+
+let check_used_occurrences nbocc (nowhere_except_in,locs) =
+  let rest = List.filter (fun o -> o >= nbocc) locs in
+  match rest with
+  | [] -> ()
+  | _ -> error_occurrences_error (InvalidOccurrence rest)
+
+let proceed_with_occurrences f occs x =
+  match occs with
+  | NoOccurrences -> x
+  | occs ->
+    let plocs = Locusops.convert_occs occs in
+    assert (List.for_all (fun x -> x >= 0) (snd plocs));
+    let (nbocc,x) = f 1 x in
+    check_used_occurrences nbocc plocs;
+    x
+
+(** Applying a function over a named_declaration with an hypothesis
+    location request *)
+
+let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
+  let f = f (Some (id,hyploc)) in
+  match bodyopt,hyploc with
+  | None, InHypValueOnly ->
+      error_occurrences_error (IncorrectInValueOccurrence id)
+  | None, _ | Some _, InHypTypeOnly ->
+      let acc,typ = f acc typ in acc,(id,bodyopt,typ)
+  | Some body, InHypValueOnly ->
+      let acc,body = f acc body in acc,(id,Some body,typ)
+  | Some body, InHyp ->
+      let acc,body = f acc body in
+      let acc,typ = f acc typ in
+      acc,(id,Some body,typ)
+
+(** Finding a subterm up to some testing function *)
+
+exception SubtermUnificationError of subterm_unification_error
+
+exception NotUnifiable of (constr * constr * unification_error) option
+
+type 'a testing_function = {
+  match_fun : 'a -> constr -> 'a;
+  merge_fun : 'a -> 'a -> 'a;
+  mutable testing_state : 'a;
+  mutable last_found : position_reporting option
+}
+
+(* Find subterms using a testing function, but only at a list of
+   locations or excluding a list of locations; in the occurrences list
+   (b,l), b=true means no occurrence except the ones in l and b=false,
+   means all occurrences except the ones in l *)
+
+let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t =
+  let (nowhere_except_in,locs) = Locusops.convert_occs occs in
+  let maxocc = List.fold_right max locs 0 in
+  let pos = ref occ in
+  let nested = ref false in
+  let add_subst t subst =
+    try
+      test.testing_state <- test.merge_fun subst test.testing_state;
+      test.last_found <- Some ((cl,!pos),t)
+    with NotUnifiable e when not like_first ->
+      let lastpos = Option.get test.last_found in
+     raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in
+  let rec substrec k t =
+    if nowhere_except_in && !pos > maxocc then t else
+    if not (Vars.closed0 t) then subst_below k t else
+    try
+      let subst = test.match_fun test.testing_state t in
+      if Locusops.is_selected !pos occs then
+        (if !nested then begin
+          (* in case it is nested but not later detected as unconvertible,
+             as when matching "id _" in "id (id 0)" *)
+          let lastpos = Option.get test.last_found in
+          raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,None))
+         end;
+         add_subst t subst; incr pos;
+         (* Check nested matching subterms *)
+         if occs != Locus.AllOccurrences && occs != Locus.NoOccurrences then
+           begin nested := true; ignore (subst_below k t); nested := false end;
+         (* Do the effective substitution *)
+         Vars.lift k (bywhat ()))
+      else
+        (incr pos; subst_below k t)
+    with NotUnifiable _ ->
+      subst_below k t
+  and subst_below k t =
+    map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t
+  in
+  let t' = substrec 0 t in
+  (!pos, t')
+
+let replace_term_occ_modulo occs test bywhat t =
+  let occs',like_first =
+    match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in
+  proceed_with_occurrences
+    (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t
+
+let replace_term_occ_decl_modulo occs test bywhat d =
+  let (plocs,hyploc),like_first =
+    match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
+  proceed_with_occurrences
+    (map_named_declaration_with_hyploc
+       (replace_term_occ_gen_modulo plocs like_first test bywhat)
+       hyploc)
+    plocs d
+
+(** Finding an exact subterm *)
+
+let make_eq_univs_test env evd c =
+  { match_fun = (fun evd c' ->
+    let b, cst = Universes.eq_constr_universes_proj env c c' in
+      if b then
+	try Evd.add_universe_constraints evd cst
+	with Evd.UniversesDiffer -> raise (NotUnifiable None)
+      else raise (NotUnifiable None));
+  merge_fun = (fun evd _ -> evd);
+  testing_state = evd;
+  last_found = None
+} 
+
+let subst_closed_term_occ env evd occs c t =
+  let test = make_eq_univs_test env evd c in
+  let bywhat () = mkRel 1 in
+  let t' = replace_term_occ_modulo occs test bywhat t in
+    t', test.testing_state
+
+let subst_closed_term_occ_decl env evd occs c d =
+  let test = make_eq_univs_test env evd c in
+  let (plocs,hyploc),like_first =
+    match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in
+  let bywhat () = mkRel 1 in
+  proceed_with_occurrences
+    (map_named_declaration_with_hyploc
+       (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None)
+       hyploc) plocs d,
+  test.testing_state
diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli
new file mode 100644
index 00000000..82330b84
--- /dev/null
+++ b/pretyping/find_subterm.mli
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  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 Names
+open Locus
+open Context
+open Term
+open Evd
+open Pretype_errors
+open Environ
+
+(** Finding subterms, possibly up to some unification function,
+    possibly at some given occurrences *)
+
+exception NotUnifiable of (constr * constr * unification_error) option
+
+exception SubtermUnificationError of subterm_unification_error
+
+(** A testing function is typically a unification function returning a
+    substitution or failing with a NotUnifiable error, together with a
+    function to merge substitutions and an initial substitution;
+    last_found is used for error messages and it has to be initialized
+    with None. *)
+
+type 'a testing_function = {
+  match_fun : 'a -> constr -> 'a;
+  merge_fun : 'a -> 'a -> 'a;
+  mutable testing_state : 'a;
+  mutable last_found : position_reporting option
+}
+
+(** This is the basic testing function, looking for exact matches of a
+    closed term *)
+val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function
+
+(** [replace_term_occ_modulo occl test mk c] looks in [c] for subterm
+    modulo a testing function [test] and replaces successfully
+    matching subterms at the indicated occurrences [occl] with [mk
+    ()]; it turns a NotUnifiable exception raised by the testing
+    function into a SubtermUnificationError. *)
+val replace_term_occ_modulo : occurrences or_like_first ->
+  'a testing_function -> (unit -> constr) -> constr -> constr
+
+(** [replace_term_occ_decl_modulo] is similar to
+    [replace_term_occ_modulo] but for a named_declaration. *)
+val replace_term_occ_decl_modulo :
+  (occurrences * hyp_location_flag) or_like_first ->
+  'a testing_function -> (unit -> constr) ->
+  named_declaration -> named_declaration
+
+(** [subst_closed_term_occ occl c d] replaces occurrences of
+    closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC),
+    unifying universes which results in a set of constraints. *)
+val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first ->
+  constr -> constr -> constr * evar_map
+
+(** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of 
+    closed [c] at positions [occl] by [Rel 1] in [decl]. *)
+val subst_closed_term_occ_decl : env -> evar_map ->
+  (occurrences * hyp_location_flag) or_like_first ->
+  constr -> named_declaration -> named_declaration * evar_map
+
+(** Miscellaneous *)
+val error_invalid_occurrence : int list -> 'a
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
new file mode 100644
index 00000000..454d64f0
--- /dev/null
+++ b/pretyping/glob_ops.ml
@@ -0,0 +1,434 @@
+(************************************************************************)
+(*  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 Util
+open Names
+open Globnames
+open Misctypes
+open Glob_term
+
+(* Untyped intermediate terms, after ASTs and before constr. *)
+
+let cases_pattern_loc = function
+    PatVar(loc,_) -> loc
+  | PatCstr(loc,_,_,_) -> loc
+
+let cases_predicate_names tml =
+  List.flatten (List.map (function
+    | (tm,(na,None)) -> [na]
+    | (tm,(na,Some (_,_,nal))) -> na::nal) tml)
+
+let mkGApp loc p t =
+  match p with
+  | GApp (loc,f,l) -> GApp (loc,f,l@[t])
+  | _ -> GApp (loc,p,[t])
+
+let map_glob_decl_left_to_right f (na,k,obd,ty) =
+  let comp1 = Option.map f obd in
+  let comp2 = f ty in
+  (na,k,comp1,comp2)
+
+let binding_kind_eq bk1 bk2 = match bk1, bk2 with
+| Decl_kinds.Explicit, Decl_kinds.Explicit -> true
+| Decl_kinds.Implicit, Decl_kinds.Implicit -> true
+| _ -> false
+
+let case_style_eq s1 s2 = match s1, s2 with
+| LetStyle, LetStyle -> true
+| IfStyle, IfStyle -> true
+| LetPatternStyle, LetPatternStyle -> true
+| MatchStyle, MatchStyle -> true
+| RegularStyle, RegularStyle -> true
+| _ -> false
+
+let rec cases_pattern_eq p1 p2 = match p1, p2 with
+| PatVar (_, na1), PatVar (_, na2) -> Name.equal na1 na2
+| PatCstr (_, c1, pl1, na1), PatCstr (_, c2, pl2, na2) ->
+  eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
+  Name.equal na1 na2
+| _ -> false
+
+let cast_type_eq eq t1 t2 = match t1, t2 with
+| CastConv t1, CastConv t2 -> eq t1 t2
+| CastVM t1, CastVM t2 -> eq t1 t2
+| CastCoerce, CastCoerce -> true
+| CastNative t1, CastNative t2 -> eq t1 t2
+| _ -> false
+
+let rec glob_constr_eq c1 c2 = match c1, c2 with
+| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2
+| GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2
+| GEvar (_, id1, arg1), GEvar (_, id2, arg2) ->
+  Id.equal id1 id2 &&
+  List.equal instance_eq arg1 arg2
+| GPatVar (_, (b1, pat1)), GPatVar (_, (b2, pat2)) ->
+  (b1 : bool) == b2 && Id.equal pat1 pat2
+| GApp (_, f1, arg1), GApp (_, f2, arg2) ->
+  glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2
+| GLambda (_, na1, bk1, t1, c1), GLambda (_, na2, bk2, t2, c2) ->
+  Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
+  glob_constr_eq t1 t2 && glob_constr_eq c1 c2
+| GProd (_, na1, bk1, t1, c1), GProd (_, na2, bk2, t2, c2) ->
+  Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
+  glob_constr_eq t1 t2 && glob_constr_eq c1 c2
+| GLetIn (_, na1, t1, c1), GLetIn (_, na2, t2, c2) ->
+  Name.equal na1 na2 && glob_constr_eq t1 t2 && glob_constr_eq c1 c2
+| GCases (_, st1, c1, tp1, cl1), GCases (_, st2, c2, tp2, cl2) ->
+  case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 &&
+  List.equal tomatch_tuple_eq tp1 tp2 &&
+  List.equal cases_clause_eq cl1 cl2
+| GLetTuple (_, na1, (n1, p1), c1, t1), GLetTuple (_, na2, (n2, p2), c2, t2) ->
+  List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
+  Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
+  glob_constr_eq t1 t2
+| GIf (_, m1, (pat1, p1), c1, t1), GIf (_, m2, (pat2, p2), c2, t2) ->
+  glob_constr_eq m1 m2 && Name.equal pat1 pat2 &&
+  Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
+  glob_constr_eq t1 t2
+| GRec (_, kn1, id1, decl1, c1, t1), GRec (_, kn2, id2, decl2, c2, t2) ->
+  fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 &&
+  Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 &&
+  Array.equal glob_constr_eq c1 c2 &&
+  Array.equal glob_constr_eq t1 t2
+| GSort (_, s1), GSort (_, s2) -> Miscops.glob_sort_eq s1 s2
+| GHole (_, kn1, nam1, gn1), GHole (_, kn2, nam2, gn2) ->
+  Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
+  Miscops.intro_pattern_naming_eq nam1 nam2
+| GCast (_, c1, t1), GCast (_, c2, t2) ->
+  glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2
+| _ -> false
+
+and tomatch_tuple_eq (c1, p1) (c2, p2) =
+  let eqp (_, i1, na1) (_, i2, na2) =
+    eq_ind i1 i2 && List.equal Name.equal na1 na2
+  in
+  let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in
+  glob_constr_eq c1 c2 && eq_pred p1 p2
+
+and cases_clause_eq (_, id1, p1, c1) (_, id2, p2, c2) =
+  List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 &&
+  glob_constr_eq c1 c2
+
+and glob_decl_eq (na1, bk1, c1, t1) (na2, bk2, c2, t2) =
+  Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
+  Option.equal glob_constr_eq c1 c2 &&
+  glob_constr_eq t1 t2
+
+and fix_kind_eq k1 k2 = match k1, k2 with
+| GFix (a1, i1), GFix (a2, i2) ->
+  let eq (i1, o1) (i2, o2) =
+    Option.equal Int.equal i1 i2 && fix_recursion_order_eq o1 o2
+  in
+  Int.equal i1 i2 && Array.equal eq a1 a1
+| GCoFix i1, GCoFix i2 -> Int.equal i1 i2
+| _ -> false
+
+and fix_recursion_order_eq o1 o2 = match o1, o2 with
+| GStructRec, GStructRec -> true
+| GWfRec c1, GWfRec c2 -> glob_constr_eq c1 c2
+| GMeasureRec (c1, o1), GMeasureRec (c2, o2) ->
+  glob_constr_eq c1 c2 && Option.equal glob_constr_eq o1 o2
+| _ -> false
+
+and instance_eq (x1,c1) (x2,c2) =
+  Id.equal x1 x2 && glob_constr_eq c1 c2
+
+let map_glob_constr_left_to_right f = function
+  | GApp (loc,g,args) ->
+      let comp1 = f g in
+      let comp2 = Util.List.map_left f args in
+      GApp (loc,comp1,comp2)
+  | GLambda (loc,na,bk,ty,c) ->
+      let comp1 = f ty in
+      let comp2 = f c in
+      GLambda (loc,na,bk,comp1,comp2)
+  | GProd (loc,na,bk,ty,c) ->
+      let comp1 = f ty in
+      let comp2 = f c in
+      GProd (loc,na,bk,comp1,comp2)
+  | GLetIn (loc,na,b,c) ->
+      let comp1 = f b in
+      let comp2 = f c in
+      GLetIn (loc,na,comp1,comp2)
+  | GCases (loc,sty,rtntypopt,tml,pl) ->
+      let comp1 = Option.map f rtntypopt in
+      let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in
+      let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in
+      GCases (loc,sty,comp1,comp2,comp3)
+  | GLetTuple (loc,nal,(na,po),b,c) ->
+      let comp1 = Option.map f po in
+      let comp2 = f b in
+      let comp3 = f c in
+      GLetTuple (loc,nal,(na,comp1),comp2,comp3)
+  | GIf (loc,c,(na,po),b1,b2) ->
+      let comp1 = Option.map f po in
+      let comp2 = f b1 in
+      let comp3 = f b2 in
+      GIf (loc,f c,(na,comp1),comp2,comp3)
+  | GRec (loc,fk,idl,bl,tyl,bv) ->
+      let comp1 = Array.map (Util.List.map_left (map_glob_decl_left_to_right f)) bl in
+      let comp2 = Array.map f tyl in
+      let comp3 = Array.map f bv in
+      GRec (loc,fk,idl,comp1,comp2,comp3)
+  | GCast (loc,c,k) ->
+      let comp1 = f c in
+      let comp2 = Miscops.map_cast_type f k in
+      GCast (loc,comp1,comp2)
+  | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x
+
+let map_glob_constr = map_glob_constr_left_to_right
+
+let fold_glob_constr f acc =
+  let rec fold acc = function
+  | GVar _ -> acc
+  | GApp (_,c,args) -> List.fold_left fold (fold acc c) args
+  | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) ->
+      fold (fold acc b) c
+  | GCases (_,_,rtntypopt,tml,pl) ->
+      List.fold_left fold_pattern
+	(List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml))
+	pl
+    | GLetTuple (_,_,rtntyp,b,c) ->
+	fold (fold (fold_return_type acc rtntyp) b) c
+    | GIf (_,c,rtntyp,b1,b2) ->
+	fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2
+    | GRec (_,_,_,bl,tyl,bv) ->
+	let acc = Array.fold_left
+	  (List.fold_left (fun acc (na,k,bbd,bty) ->
+	    fold (Option.fold_left fold acc bbd) bty)) acc bl in
+	Array.fold_left fold (Array.fold_left fold acc tyl) bv
+    | GCast (_,c,k) ->
+        let r = match k with
+        | CastConv t | CastVM t | CastNative t -> fold acc t | CastCoerce -> acc
+        in
+        fold r c
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
+
+  and fold_pattern acc (_,idl,p,c) = fold acc c
+
+  and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt
+
+  in fold acc
+
+let iter_glob_constr f = fold_glob_constr (fun () -> f) ()
+
+let same_id na id = match na with
+| Anonymous -> false
+| Name id' -> Id.equal id id'
+
+let occur_glob_constr id =
+  let rec occur = function
+    | GVar (loc,id') -> Id.equal id id'
+    | GApp (loc,f,args) -> (occur f) || (List.exists occur args)
+    | GLambda (loc,na,bk,ty,c) ->
+      (occur ty) || (not (same_id na id) && (occur c))
+    | GProd (loc,na,bk,ty,c) ->
+      (occur ty) || (not (same_id na id) && (occur c))
+    | GLetIn (loc,na,b,c) ->
+      (occur b) || (not (same_id na id) && (occur c))
+    | GCases (loc,sty,rtntypopt,tml,pl) ->
+	(occur_option rtntypopt)
+        || (List.exists (fun (tm,_) -> occur tm) tml)
+	|| (List.exists occur_pattern pl)
+    | GLetTuple (loc,nal,rtntyp,b,c) ->
+	occur_return_type rtntyp id
+        || (occur b) || (not (List.mem_f Name.equal (Name id) nal) && (occur c))
+    | GIf (loc,c,rtntyp,b1,b2) ->
+	occur_return_type rtntyp id || (occur c) || (occur b1) || (occur b2)
+    | GRec (loc,fk,idl,bl,tyl,bv) ->
+        not (Array.for_all4 (fun fid bl ty bd ->
+          let rec occur_fix = function
+              [] -> not (occur ty) && (Id.equal fid id || not(occur bd))
+            | (na,k,bbd,bty)::bl ->
+                not (occur bty) &&
+                (match bbd with
+                    Some bd -> not (occur bd)
+                  | _ -> true) &&
+                (match na with Name id' -> Id.equal id id' | _ -> not (occur_fix bl)) in
+          occur_fix bl)
+          idl bl tyl bv)
+    | GCast (loc,c,k) -> (occur c) || (match k with CastConv t
+      | CastVM t | CastNative t -> occur t | CastCoerce -> false)
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> false
+
+  and occur_pattern (loc,idl,p,c) = not (Id.List.mem id idl) && (occur c)
+
+  and occur_option = function None -> false | Some p -> occur p
+
+  and occur_return_type (na,tyopt) id = not (same_id na id) && occur_option tyopt
+
+  in occur
+
+
+let add_name_to_ids set na =
+  match na with
+    | Anonymous -> set
+    | Name id -> Id.Set.add id set
+
+let free_glob_vars  =
+  let rec vars bounded vs = function
+    | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs
+    | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
+    | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) ->
+	let vs' = vars bounded vs ty in
+	let bounded' = add_name_to_ids bounded na in
+       vars bounded' vs' c
+    | GCases (loc,sty,rtntypopt,tml,pl) ->
+	let vs1 = vars_option bounded vs rtntypopt in
+	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in
+	List.fold_left (vars_pattern bounded) vs2 pl
+    | GLetTuple (loc,nal,rtntyp,b,c) ->
+	let vs1 = vars_return_type bounded vs rtntyp in
+	let vs2 = vars bounded vs1 b in
+	let bounded' = List.fold_left add_name_to_ids bounded nal in
+	vars bounded' vs2 c
+    | GIf (loc,c,rtntyp,b1,b2) ->
+	let vs1 = vars_return_type bounded vs rtntyp in
+	let vs2 = vars bounded vs1 c in
+	let vs3 = vars bounded vs2 b1 in
+	vars bounded vs3 b2
+    | GRec (loc,fk,idl,bl,tyl,bv) ->
+	let bounded' = Array.fold_right Id.Set.add idl bounded in
+	let vars_fix i vs fid =
+	  let vs1,bounded1 =
+	    List.fold_left
+	      (fun (vs,bounded) (na,k,bbd,bty) ->
+		 let vs' = vars_option bounded vs bbd in
+		 let vs'' = vars bounded vs' bty in
+		 let bounded' = add_name_to_ids bounded na in
+		 (vs'',bounded')
+	      )
+	      (vs,bounded')
+	      bl.(i)
+	  in
+	  let vs2 = vars bounded1 vs1 tyl.(i) in
+	  vars bounded1 vs2 bv.(i)
+	in
+	Array.fold_left_i vars_fix vs idl
+    | GCast (loc,c,k) -> let v = vars bounded vs c in
+	(match k with CastConv t | CastVM t | CastNative t -> vars bounded v t | _ -> v)
+    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs
+
+  and vars_pattern bounded vs (loc,idl,p,c) =
+    let bounded' = List.fold_right Id.Set.add idl bounded  in
+    vars bounded' vs c
+
+  and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p
+
+  and vars_return_type bounded vs (na,tyopt) =
+    let bounded' = add_name_to_ids bounded na in
+    vars_option bounded' vs tyopt
+  in
+  fun rt ->
+    let vs = vars Id.Set.empty Id.Set.empty rt in
+    Id.Set.elements vs
+
+(** Mapping of names in binders *)
+
+(* spiwack: I used a smartmap-style kind of mapping here, because the
+   operation will be the identity almost all of the time (with any
+   term outside of Ltac to begin with). But to be honest, there would
+   probably be no significant penalty in doing reallocation as
+   pattern-matching expressions are usually rather small. *)
+
+let map_inpattern_binders f ((loc,id,nal) as x) =
+  let r = CList.smartmap f nal in
+  if r == nal then x
+  else loc,id,r
+
+let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple =
+  let r = Option.smartmap (fun p -> map_inpattern_binders f p) inp in
+  if r == inp then x
+  else c,(f na, r)
+
+let rec map_case_pattern_binders f = function
+  | PatVar (loc,na) as x ->
+      let r = f na in
+      if r == na then x
+      else PatVar (loc,r)
+  | PatCstr (loc,c,ps,na) as x ->
+      let rna = f na in
+      let rps =
+        CList.smartmap (fun p -> map_case_pattern_binders f p) ps
+      in
+      if rna == na && rps == ps then x
+      else PatCstr(loc,c,rps,rna)
+
+let map_cases_branch_binders f ((loc,il,cll,rhs) as x) : cases_clause =
+  (* spiwack: not sure if I must do something with the list of idents.
+     It is intended to be a superset of the free variable of the
+     right-hand side, if I understand correctly. But I'm not sure when
+     or how they are used. *)
+  let r = List.smartmap (fun cl -> map_case_pattern_binders f cl) cll in
+  if r == cll then x
+  else loc,il,r,rhs
+
+let map_pattern_binders f tomatch branches =
+  CList.smartmap (fun tm -> map_tomatch_binders f tm) tomatch,
+  CList.smartmap (fun br -> map_cases_branch_binders f br) branches
+
+(** /mapping of names in binders *)
+
+let map_tomatch f (c,pp) : tomatch_tuple = f c , pp
+
+let map_cases_branch f (loc,il,cll,rhs) : cases_clause =
+  loc , il , cll , f rhs
+
+let map_pattern f tomatch branches =
+  List.map (fun tm -> map_tomatch f tm) tomatch,
+  List.map (fun br -> map_cases_branch f br) branches
+
+let loc_of_glob_constr = function
+  | GRef (loc,_,_) -> loc
+  | GVar (loc,_) -> loc
+  | GEvar (loc,_,_) -> loc
+  | GPatVar (loc,_) -> loc
+  | GApp (loc,_,_) -> loc
+  | GLambda (loc,_,_,_,_) -> loc
+  | GProd (loc,_,_,_,_) -> loc
+  | GLetIn (loc,_,_,_) -> loc
+  | GCases (loc,_,_,_,_) -> loc
+  | GLetTuple (loc,_,_,_,_) -> loc
+  | GIf (loc,_,_,_,_) -> loc
+  | GRec (loc,_,_,_,_,_) -> loc
+  | GSort (loc,_) -> loc
+  | GHole (loc,_,_,_) -> loc
+  | GCast (loc,_,_) -> loc
+
+(**********************************************************************)
+(* Conversion from glob_constr to cases pattern, if possible            *)
+
+let rec cases_pattern_of_glob_constr na = function
+  | GVar (loc,id) ->
+    begin match na with
+    | Name _ ->
+      (* Unable to manage the presence of both an alias and a variable *)
+      raise Not_found
+    | Anonymous -> PatVar (loc,Name id)
+    end
+  | GHole (loc,_,_,_) -> PatVar (loc,na)
+  | GRef (loc,ConstructRef cstr,_) ->
+      PatCstr (loc,cstr,[],na)
+  | GApp (loc,GRef (_,ConstructRef cstr,_),l) ->
+      PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na)
+  | _ -> raise Not_found
+
+(* Turn a closed cases pattern into a glob_constr *)
+let rec glob_constr_of_closed_cases_pattern_aux = function
+  | PatCstr (loc,cstr,[],Anonymous) ->
+      GRef (loc,ConstructRef cstr,None)
+  | PatCstr (loc,cstr,l,Anonymous) ->
+      let ref = GRef (loc,ConstructRef cstr,None) in
+      GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l)
+  | _ -> raise Not_found
+
+let glob_constr_of_closed_cases_pattern = function
+  | PatCstr (loc,cstr,l,na) ->
+      na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
+  | _ ->
+      raise Not_found
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
new file mode 100644
index 00000000..67f3cb41
--- /dev/null
+++ b/pretyping/glob_ops.mli
@@ -0,0 +1,61 @@
+(************************************************************************)
+(*  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 Names
+open Glob_term
+
+(** Equalities *)
+
+val cases_pattern_eq : cases_pattern -> cases_pattern -> bool
+
+val glob_constr_eq : glob_constr -> glob_constr -> bool
+
+(** Operations on [glob_constr] *)
+
+val cases_pattern_loc : cases_pattern -> Loc.t
+
+val cases_predicate_names : tomatch_tuples -> Name.t list
+
+(** Apply one argument to a glob_constr *)
+val mkGApp : Loc.t -> glob_constr -> glob_constr -> glob_constr
+
+val map_glob_constr :
+  (glob_constr -> glob_constr) -> glob_constr -> glob_constr
+
+(** Ensure traversal from left to right *)
+val map_glob_constr_left_to_right :
+  (glob_constr -> glob_constr) -> glob_constr -> glob_constr
+
+val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
+val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
+val occur_glob_constr : Id.t -> glob_constr -> bool
+val free_glob_vars : glob_constr -> Id.t list
+val loc_of_glob_constr : glob_constr -> Loc.t
+
+(** [map_pattern_binders f m c] applies [f] to all the binding names
+    in a pattern-matching expression ({!Glob_term.GCases}) represented
+    here by its relevant components [m] and [c]. It is used to
+    interpret Ltac-bound names both in pretyping and printing of
+    terms. *)
+val map_pattern_binders : (name -> name) ->
+  tomatch_tuples -> cases_clauses -> (tomatch_tuples*cases_clauses)
+
+(** [map_pattern f m c] applies [f] to the return predicate and the
+    right-hand side of a pattern-matching expression
+    ({!Glob_term.GCases}) represented here by its relevant components
+    [m] and [c]. *)
+val map_pattern : (glob_constr -> glob_constr) ->
+  tomatch_tuples -> cases_clauses -> (tomatch_tuples*cases_clauses)
+
+(** Conversion from glob_constr to cases pattern, if possible
+
+    Take the current alias as parameter,
+    @raise Not_found if translation is impossible *)
+val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern
+
+val glob_constr_of_closed_cases_pattern : cases_pattern -> Name.t * glob_constr
diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml
deleted file mode 100644
index b7023db0..00000000
--- a/pretyping/glob_term.ml
+++ /dev/null
@@ -1,418 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Util
-open Names
-open Sign
-open Term
-open Libnames
-open Nametab
-open Evd
-(*i*)
-
-(* Untyped intermediate terms, after ASTs and before constr. *)
-
-(* locs here refers to the ident's location, not whole pat *)
-(* the last argument of PatCstr is a possible alias ident for the pattern *)
-type cases_pattern =
-  | PatVar of loc * name
-  | PatCstr of loc * constructor * cases_pattern list * name
-
-let cases_pattern_loc = function
-    PatVar(loc,_) -> loc
-  | PatCstr(loc,_,_,_) -> loc
-
-type patvar = identifier
-
-type glob_sort = GProp of Term.contents | GType of Univ.universe option
-
-type binding_kind = Lib.binding_kind = Explicit | Implicit
-
-type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
-
-type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
-
-type 'a bindings =
-  | ImplicitBindings of 'a list
-  | ExplicitBindings of 'a explicit_bindings
-  | NoBindings
-
-type 'a with_bindings = 'a * 'a bindings
-
-type 'a cast_type =
-  | CastConv of cast_kind * 'a
-  | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *)
-
-type glob_constr =
-  | GRef of (loc * global_reference)
-  | GVar of (loc * identifier)
-  | GEvar of loc * existential_key * glob_constr list option
-  | GPatVar of loc * (bool * patvar) (* Used for patterns only *)
-  | GApp of loc * glob_constr * glob_constr list
-  | GLambda of loc * name * binding_kind * glob_constr * glob_constr
-  | GProd of loc * name * binding_kind * glob_constr * glob_constr
-  | GLetIn of loc * name * glob_constr * glob_constr
-  | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses
-  | GLetTuple of loc * name list * (name * glob_constr option) *
-      glob_constr * glob_constr
-  | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr
-  | GRec of loc * fix_kind * identifier array * glob_decl list array *
-      glob_constr array * glob_constr array
-  | GSort of loc * glob_sort
-  | GHole of (loc * hole_kind)
-  | GCast of loc * glob_constr * glob_constr cast_type
-
-and glob_decl = name * binding_kind * glob_constr option * glob_constr
-
-and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option
-
-and fix_kind =
-  | GFix of ((int option * fix_recursion_order) array * int)
-  | GCoFix of int
-
-and predicate_pattern =
-    name * (loc * inductive * int * name list) option
-
-and tomatch_tuple = (glob_constr * predicate_pattern)
-
-and tomatch_tuples = tomatch_tuple list
-
-and cases_clause = (loc * identifier list * cases_pattern list * glob_constr)
-
-and cases_clauses = cases_clause list
-
-let cases_predicate_names tml =
-  List.flatten (List.map (function
-    | (tm,(na,None)) -> [na]
-    | (tm,(na,Some (_,_,_,nal))) -> na::nal) tml)
-
-let mkGApp loc p t =
-  match p with
-  | GApp (loc,f,l) -> GApp (loc,f,l@[t])
-  | _ -> GApp (loc,p,[t])
-
-let map_glob_decl_left_to_right f (na,k,obd,ty) = 
-  let comp1 = Option.map f obd in
-  let comp2 = f ty in
-  (na,k,comp1,comp2)
-
-let map_glob_constr_left_to_right f = function
-  | GApp (loc,g,args) -> 
-      let comp1 = f g in 
-      let comp2 = Util.list_map_left f args in 
-      GApp (loc,comp1,comp2)
-  | GLambda (loc,na,bk,ty,c) -> 
-      let comp1 = f ty in 
-      let comp2 = f c in 
-      GLambda (loc,na,bk,comp1,comp2)
-  | GProd (loc,na,bk,ty,c) -> 
-      let comp1 = f ty in 
-      let comp2 = f c in 
-      GProd (loc,na,bk,comp1,comp2)
-  | GLetIn (loc,na,b,c) -> 
-      let comp1 = f b in 
-      let comp2 = f c in 
-      GLetIn (loc,na,comp1,comp2)
-  | GCases (loc,sty,rtntypopt,tml,pl) ->
-      let comp1 = Option.map f rtntypopt in 
-      let comp2 = Util.list_map_left (fun (tm,x) -> (f tm,x)) tml in
-      let comp3 = Util.list_map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in
-      GCases (loc,sty,comp1,comp2,comp3)
-  | GLetTuple (loc,nal,(na,po),b,c) ->
-      let comp1 = Option.map f po in
-      let comp2 = f b in
-      let comp3 = f c in 
-      GLetTuple (loc,nal,(na,comp1),comp2,comp3)
-  | GIf (loc,c,(na,po),b1,b2) ->
-      let comp1 = Option.map f po in
-      let comp2 = f b1 in
-      let comp3 = f b2 in
-      GIf (loc,f c,(na,comp1),comp2,comp3)
-  | GRec (loc,fk,idl,bl,tyl,bv) ->
-      let comp1 = Array.map (Util.list_map_left (map_glob_decl_left_to_right f)) bl in
-      let comp2 = Array.map f tyl in
-      let comp3 = Array.map f bv in
-      GRec (loc,fk,idl,comp1,comp2,comp3)
-  | GCast (loc,c,k) -> 
-      let comp1 = f c in
-      let comp2 = match k with CastConv (k,t) -> CastConv (k, f t) | x -> x in
-      GCast (loc,comp1,comp2)
-  | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) as x -> x
-
-let map_glob_constr = map_glob_constr_left_to_right
-
-(*
-let name_app f e = function
-  | Name id -> let (id, e) = f id e in (Name id, e)
-  | Anonymous -> Anonymous, e
-
-let fold_ident g idl e =
-  let (idl,e) =
-    Array.fold_right
-      (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e)
-  in (Array.of_list idl,e)
-
-let map_glob_constr_with_binders_loc loc g f e = function
-  | GVar (_,id) -> GVar (loc,id)
-  | GApp (_,a,args) -> GApp (loc,f e a, List.map (f e) args)
-  | GLambda (_,na,ty,c) ->
-      let na,e = name_app g e na in GLambda (loc,na,f e ty,f e c)
-  | GProd (_,na,ty,c) ->
-      let na,e = name_app g e na in GProd (loc,na,f e ty,f e c)
-  | GLetIn (_,na,b,c) ->
-      let na,e = name_app g e na in GLetIn (loc,na,f e b,f e c)
-  | GCases (_,tyopt,tml,pl) ->
-      (* We don't modify pattern variable since we don't traverse patterns *)
-      let g' id e = snd (g id e) in
-      let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in
-      GCases
-	(loc,Option.map (f e) tyopt,List.map (f e) tml, List.map h pl)
-  | GRec (_,fk,idl,tyl,bv) ->
-      let idl',e' = fold_ident g idl e in
-      GRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
-  | GCast (_,c,t) -> GCast (loc,f e c,f e t)
-  | GSort (_,x) -> GSort (loc,x)
-  | GHole (_,x)  -> GHole (loc,x)
-  | GRef (_,x) -> GRef (loc,x)
-  | GEvar (_,x,l) -> GEvar (loc,x,l)
-  | GPatVar (_,x) -> GPatVar (loc,x)
-*)
-
-let fold_glob_constr f acc =
-  let rec fold acc = function
-  | GVar _ -> acc
-  | GApp (_,c,args) -> List.fold_left fold (fold acc c) args
-  | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) ->
-      fold (fold acc b) c
-  | GCases (_,_,rtntypopt,tml,pl) ->
-      List.fold_left fold_pattern
-	(List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml))
-	pl
-    | GLetTuple (_,_,rtntyp,b,c) ->
-	fold (fold (fold_return_type acc rtntyp) b) c
-    | GIf (_,c,rtntyp,b1,b2) ->
-	fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2
-    | GRec (_,_,_,bl,tyl,bv) ->
-	let acc = Array.fold_left
-	  (List.fold_left (fun acc (na,k,bbd,bty) ->
-	    fold (Option.fold_left fold acc bbd) bty)) acc bl in
-	Array.fold_left fold (Array.fold_left fold acc tyl) bv
-    | GCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c
-    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc
-
-  and fold_pattern acc (_,idl,p,c) = fold acc c
-
-  and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt
-
-  in fold acc
-
-let iter_glob_constr f = fold_glob_constr (fun () -> f) ()
-
-let occur_glob_constr id =
-  let rec occur = function
-    | GVar (loc,id') -> id = id'
-    | GApp (loc,f,args) -> (occur f) or (List.exists occur args)
-    | GLambda (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
-    | GProd (loc,na,bk,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
-    | GLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
-    | GCases (loc,sty,rtntypopt,tml,pl) ->
-	(occur_option rtntypopt)
-        or (List.exists (fun (tm,_) -> occur tm) tml)
-	or (List.exists occur_pattern pl)
-    | GLetTuple (loc,nal,rtntyp,b,c) ->
-	occur_return_type rtntyp id
-        or (occur b) or (not (List.mem (Name id) nal) & (occur c))
-    | GIf (loc,c,rtntyp,b1,b2) ->
-	occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2)
-    | GRec (loc,fk,idl,bl,tyl,bv) ->
-        not (array_for_all4 (fun fid bl ty bd ->
-          let rec occur_fix = function
-              [] -> not (occur ty) && (fid=id or not(occur bd))
-            | (na,k,bbd,bty)::bl ->
-                not (occur bty) &&
-                (match bbd with
-                    Some bd -> not (occur bd)
-                  | _ -> true) &&
-                (na=Name id or not(occur_fix bl)) in
-          occur_fix bl)
-          idl bl tyl bv)
-    | GCast (loc,c,k) -> (occur c) or (match k with CastConv (_, t) -> occur t | CastCoerce -> false)
-    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> false
-
-  and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
-
-  and occur_option = function None -> false | Some p -> occur p
-
-  and occur_return_type (na,tyopt) id = na <> Name id & occur_option tyopt
-
-  in occur
-
-
-let add_name_to_ids set na =
-  match na with
-    | Anonymous -> set
-    | Name id -> Idset.add id set
-
-let free_glob_vars  =
-  let rec vars bounded vs = function
-    | GVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs
-    | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args)
-    | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) ->
-	let vs' = vars bounded vs ty in
-	let bounded' = add_name_to_ids bounded na in
-       vars bounded' vs' c
-    | GCases (loc,sty,rtntypopt,tml,pl) ->
-	let vs1 = vars_option bounded vs rtntypopt in
-	let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in
-	List.fold_left (vars_pattern bounded) vs2 pl
-    | GLetTuple (loc,nal,rtntyp,b,c) ->
-	let vs1 = vars_return_type bounded vs rtntyp in
-	let vs2 = vars bounded vs1 b in
-	let bounded' = List.fold_left add_name_to_ids bounded nal in
-	vars bounded' vs2 c
-    | GIf (loc,c,rtntyp,b1,b2) ->
-	let vs1 = vars_return_type bounded vs rtntyp in
-	let vs2 = vars bounded vs1 c in
-	let vs3 = vars bounded vs2 b1 in
-	vars bounded vs3 b2
-    | GRec (loc,fk,idl,bl,tyl,bv) ->
-	let bounded' = Array.fold_right Idset.add idl bounded in
-	let vars_fix i vs fid =
-	  let vs1,bounded1 =
-	    List.fold_left
-	      (fun (vs,bounded) (na,k,bbd,bty) ->
-		 let vs' = vars_option bounded vs bbd in
-		 let vs'' = vars bounded vs' bty in
-		 let bounded' = add_name_to_ids bounded na in
-		 (vs'',bounded')
-	      )
-	      (vs,bounded')
-	      bl.(i)
-	  in
-	  let vs2 = vars bounded1 vs1 tyl.(i) in
-	  vars bounded1 vs2 bv.(i)
-	in
-	array_fold_left_i vars_fix vs idl
-    | GCast (loc,c,k) -> let v = vars bounded vs c in
-	(match k with CastConv (_,t) -> vars bounded v t | _ -> v)
-    | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> vs
-
-  and vars_pattern bounded vs (loc,idl,p,c) =
-    let bounded' = List.fold_right Idset.add idl bounded  in
-    vars bounded' vs c
-
-  and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p
-
-  and vars_return_type bounded vs (na,tyopt) =
-    let bounded' = add_name_to_ids bounded na in
-    vars_option bounded' vs tyopt
-  in
-  fun rt ->
-    let vs = vars Idset.empty Idset.empty rt in
-    Idset.elements vs
-
-
-let loc_of_glob_constr = function
-  | GRef (loc,_) -> loc
-  | GVar (loc,_) -> loc
-  | GEvar (loc,_,_) -> loc
-  | GPatVar (loc,_) -> loc
-  | GApp (loc,_,_) -> loc
-  | GLambda (loc,_,_,_,_) -> loc
-  | GProd (loc,_,_,_,_) -> loc
-  | GLetIn (loc,_,_,_) -> loc
-  | GCases (loc,_,_,_,_) -> loc
-  | GLetTuple (loc,_,_,_,_) -> loc
-  | GIf (loc,_,_,_,_) -> loc
-  | GRec (loc,_,_,_,_,_) -> loc
-  | GSort (loc,_) -> loc
-  | GHole (loc,_) -> loc
-  | GCast (loc,_,_) -> loc
-
-(**********************************************************************)
-(* Conversion from glob_constr to cases pattern, if possible            *)
-
-let rec cases_pattern_of_glob_constr na = function
-  | GVar (loc,id) when na<>Anonymous ->
-      (* Unable to manage the presence of both an alias and a variable *)
-      raise Not_found
-  | GVar (loc,id) -> PatVar (loc,Name id)
-  | GHole (loc,_) -> PatVar (loc,na)
-  | GRef (loc,ConstructRef cstr) ->
-      PatCstr (loc,cstr,[],na)
-  | GApp (loc,GRef (_,ConstructRef (ind,_ as cstr)),args) ->
-      let mib,_ = Global.lookup_inductive ind in
-      let nparams = mib.Declarations.mind_nparams in
-      if nparams > List.length args then
-        user_err_loc (loc,"",Pp.str "Invalid notation for pattern.");
-      let params,args = list_chop nparams args in
-      List.iter (function GHole _ -> ()
-	| _ -> user_err_loc (loc,"",Pp.str"Invalid notation for pattern."))
-        params;
-      let args = List.map (cases_pattern_of_glob_constr Anonymous) args in
-      PatCstr (loc,cstr,args,na)
-  | _ -> raise Not_found
-
-(* Turn a closed cases pattern into a glob_constr *)
-let rec glob_constr_of_closed_cases_pattern_aux = function
-  | PatCstr (loc,cstr,[],Anonymous) ->
-      GRef (loc,ConstructRef cstr)
-  | PatCstr (loc,cstr,l,Anonymous) ->
-      let ref = GRef (loc,ConstructRef cstr) in
-      GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l)
-  | _ -> raise Not_found
-
-let glob_constr_of_closed_cases_pattern = function
-  | PatCstr (loc,cstr,l,na) ->
-      na,glob_constr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
-  | _ ->
-      raise Not_found
-
-(**********************************************************************)
-(* Reduction expressions                                              *)
-
-type 'a glob_red_flag = {
-  rBeta : bool;
-  rIota : bool;
-  rZeta : bool;
-  rDelta : bool; (* true = delta all but rConst; false = delta only on rConst*)
-  rConst : 'a list
-}
-
-let all_flags =
-  {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
-
-type 'a or_var = ArgArg of 'a | ArgVar of identifier located
-
-type occurrences_expr = bool * int or_var list
-
-let all_occurrences_expr_but l = (false,l)
-let no_occurrences_expr_but l = (true,l)
-let all_occurrences_expr = (false,[])
-let no_occurrences_expr = (true,[])
-
-type 'a with_occurrences = occurrences_expr * 'a
-
-type ('a,'b,'c) red_expr_gen =
-  | Red of bool
-  | Hnf
-  | Simpl of 'c with_occurrences option
-  | Cbv of 'b glob_red_flag
-  | Lazy of 'b glob_red_flag
-  | Unfold of 'b with_occurrences list
-  | Fold of 'a list
-  | Pattern of 'a with_occurrences list
-  | ExtraRedExpr of string
-  | CbvVm
-
-type ('a,'b,'c) may_eval =
-  | ConstrTerm of 'a
-  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
-  | ConstrContext of (loc * identifier) * 'a
-  | ConstrTypeOf of 'a
diff --git a/pretyping/glob_term.mli b/pretyping/glob_term.mli
deleted file mode 100644
index 09dd9203..00000000
--- a/pretyping/glob_term.mli
+++ /dev/null
@@ -1,167 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(**Untyped intermediate terms, after constr_expr and before constr
-
-   Resolution of names, insertion of implicit arguments placeholder,
-   and notations are done, but coercions, inference of implicit
-   arguments and pattern-matching compilation are not. *)
-
-open Util
-open Names
-open Sign
-open Term
-open Libnames
-open Nametab
-
-(**  The kind of patterns that occurs in "match ... with ... end"
-
-     locs here refers to the ident's location, not whole pat *)
-type cases_pattern =
-  | PatVar of loc * name
-  | PatCstr of loc * constructor * cases_pattern list * name 
-      (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *)
-
-val cases_pattern_loc : cases_pattern -> loc
-
-type patvar = identifier
-
-type glob_sort = GProp of Term.contents | GType of Univ.universe option
-
-type binding_kind = Lib.binding_kind = Explicit | Implicit
-
-type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
-
-type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list
-
-type 'a bindings =
-  | ImplicitBindings of 'a list
-  | ExplicitBindings of 'a explicit_bindings
-  | NoBindings
-
-type 'a with_bindings = 'a * 'a bindings
-
-type 'a cast_type =
-  | CastConv of cast_kind * 'a
-  | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *)
-
-type glob_constr =
-  | GRef of (loc * global_reference)
-  | GVar of (loc * identifier)
-  | GEvar of loc * existential_key * glob_constr list option
-  | GPatVar of loc * (bool * patvar) (** Used for patterns only *)
-  | GApp of loc * glob_constr * glob_constr list
-  | GLambda of loc * name * binding_kind *  glob_constr * glob_constr
-  | GProd of loc * name * binding_kind * glob_constr * glob_constr
-  | GLetIn of loc * name * glob_constr * glob_constr
-  | GCases of loc * case_style * glob_constr option * tomatch_tuples * cases_clauses
-      (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in 
-	  [MatchStyle]) *)
-
-  | GLetTuple of loc * name list * (name * glob_constr option) *
-      glob_constr * glob_constr
-  | GIf of loc * glob_constr * (name * glob_constr option) * glob_constr * glob_constr
-  | GRec of loc * fix_kind * identifier array * glob_decl list array *
-      glob_constr array * glob_constr array
-  | GSort of loc * glob_sort
-  | GHole of (loc * Evd.hole_kind)
-  | GCast of loc * glob_constr * glob_constr cast_type
-
-and glob_decl = name * binding_kind * glob_constr option * glob_constr
-
-and fix_recursion_order = GStructRec | GWfRec of glob_constr | GMeasureRec of glob_constr * glob_constr option
-
-and fix_kind =
-  | GFix of ((int option * fix_recursion_order) array * int)
-  | GCoFix of int
-
-and predicate_pattern =
-    name * (loc * inductive * int * name list) option
-      (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)], [k]
-	  is the number of parameter of [I]. *)
-
-and tomatch_tuple = (glob_constr * predicate_pattern)
-
-and tomatch_tuples = tomatch_tuple list
-
-and cases_clause = (loc * identifier list * cases_pattern list * glob_constr)
-(** [(p,il,cl,t)] = "|'cl' as 'il' => 't'" *)
-
-and cases_clauses = cases_clause list
-
-val cases_predicate_names : tomatch_tuples -> name list
-
-(* Apply one argument to a glob_constr *)
-val mkGApp : loc -> glob_constr -> glob_constr -> glob_constr
-
-val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr
-
-(* Ensure traversal from left to right *)
-val map_glob_constr_left_to_right :
-  (glob_constr -> glob_constr) -> glob_constr -> glob_constr
-
-(*
-val map_glob_constr_with_binders_loc : loc ->
-  (identifier -> 'a -> identifier * 'a) ->
-  ('a -> glob_constr -> glob_constr) -> 'a -> glob_constr -> glob_constr
-*)
-
-val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
-val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
-val occur_glob_constr : identifier -> glob_constr -> bool
-val free_glob_vars : glob_constr -> identifier list
-val loc_of_glob_constr : glob_constr -> loc
-
-(** Conversion from glob_constr to cases pattern, if possible
-    
-    Take the current alias as parameter, 
-    @raise Not_found if translation is impossible *)
-val cases_pattern_of_glob_constr : name -> glob_constr -> cases_pattern
-
-val glob_constr_of_closed_cases_pattern : cases_pattern -> name * glob_constr
-
-(** {6 Reduction expressions} *)
-
-type 'a glob_red_flag = {
-  rBeta : bool;
-  rIota : bool;
-  rZeta : bool;
-  rDelta : bool; (** true = delta all but rConst; false = delta only on rConst*)
-  rConst : 'a list
-}
-
-val all_flags : 'a glob_red_flag
-
-type 'a or_var = ArgArg of 'a | ArgVar of identifier located
-
-type occurrences_expr = bool * int or_var list
-
-val all_occurrences_expr_but : int or_var list -> occurrences_expr
-val no_occurrences_expr_but : int or_var list -> occurrences_expr
-val all_occurrences_expr : occurrences_expr
-val no_occurrences_expr : occurrences_expr
-
-type 'a with_occurrences = occurrences_expr * 'a
-
-type ('a,'b,'c) red_expr_gen =
-  | Red of bool
-  | Hnf
-  | Simpl of 'c with_occurrences option
-  | Cbv of 'b glob_red_flag
-  | Lazy of 'b glob_red_flag
-  | Unfold of 'b with_occurrences list
-  | Fold of 'a list
-  | Pattern of 'a with_occurrences list
-  | ExtraRedExpr of string
-  | CbvVm
-
-type ('a,'b,'c) may_eval =
-  | ConstrTerm of 'a
-  | ConstrEval of ('a,'b,'c) red_expr_gen * 'a
-  | ConstrContext of (loc * identifier) * 'a
-  | ConstrTypeOf of 'a
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index c7cdb302..54d47fbe 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.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        *)
@@ -11,66 +11,75 @@
 (* This file builds various inductive schemes *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Libnames
+open Globnames
 open Nameops
 open Term
+open Vars
+open Context
 open Namegen
 open Declarations
-open Entries
+open Declareops
 open Inductive
 open Inductiveops
 open Environ
 open Reductionops
-open Typeops
-open Type_errors
-open Safe_typing
 open Nametab
-open Sign
 
 type dep_flag = bool
 
 (* Errors related to recursors building *)
 type recursion_scheme_error =
-  | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive
+  | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
   | NotMutualInScheme of inductive * inductive
 
 exception RecursionSchemeError of recursion_scheme_error
 
 let make_prod_dep dep env = if dep then mkProd_name env else mkProd
-let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
+let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c)
 
 (*******************************************)
 (* Building curryfied elimination          *)
 (*******************************************)
 
+let is_private mib =
+  match mib.mind_private with
+  | Some true -> true
+  | _ -> false
+
+let check_privacy_block mib =
+  if is_private mib then
+    errorlabstrm ""(str"case analysis on a private inductive type")
+      
 (**********************************************************************)
 (* Building case analysis schemes *)
 (* Christine Paulin, 1996 *)
 
-let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
-  let lnamespar = List.map
-    (fun (n, c, t) -> (n, c, Termops.refresh_universes t))
-    mib.mind_params_ctxt
+let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
+  let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in
+  let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in
+  let constrs = get_constructors env indf in
+  let projs = get_projections env indf in
+
+  let () = if Option.is_empty projs then check_privacy_block mib in
+  let () = 
+    if not (Sorts.List.mem kind (elim_sorts specif)) then
+      raise
+	(RecursionSchemeError
+	   (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind)))
   in
+  let ndepar = mip.mind_nrealdecls + 1 in
 
-  if not (List.mem kind (elim_sorts specif)) then
-    raise
-      (RecursionSchemeError
-	 (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind)));
-
-  let ndepar = mip.mind_nrealargs_ctxt + 1 in
-
-  (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
-  (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
+  (* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
+  (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
   let env' = push_rel_context lnamespar env in
 
-  let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in
-  let constrs = get_constructors env indf in
 
   let rec add_branch env k =
-    if k = Array.length mip.mind_consnames then
+    if Int.equal k (Array.length mip.mind_consnames) then
       let nbprod = k+1 in
 
       let indf' = lift_inductive_family nbprod indf in
@@ -78,7 +87,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
       let depind = build_dependent_inductive env indf' in
       let deparsign = (Anonymous,None,depind)::arsign in
 
-      let ci = make_case_info env ind RegularStyle in
+      let ci = make_case_info env (fst pind) RegularStyle in
       let pbody =
         appvect
           (mkRel (ndepar + nbprod),
@@ -90,21 +99,34 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind =
 	   (Anonymous,depind,pbody))
           arsign
       in
-      it_mkLambda_or_LetIn_name env'
-       	(mkCase (ci, lift ndepar p,
-		     mkRel 1,
-		     Termops.rel_vect ndepar k))
-       	deparsign
+      let obj = 
+	match projs with
+	| None -> mkCase (ci, lift ndepar p,  mkRel 1,
+			  Termops.rel_vect ndepar k)
+	| Some ps -> 
+	  let term = 
+	    mkApp (mkRel 2, 
+		   Array.map 
+		   (fun p -> mkProj (Projection.make p true, mkRel 1)) ps) in
+	    if dep then
+	      let ty = mkApp (mkRel 3, [| mkRel 1 |]) in 
+		mkCast (term, DEFAULTcast, ty)
+	    else term
+      in
+	it_mkLambda_or_LetIn_name env' obj deparsign
     else
       let cs = lift_constructor (k+1) constrs.(k) in
       let t = build_branch_type env dep (mkRel (k+1)) cs in
       mkLambda_string "f" t
 	(add_branch (push_rel (Anonymous, None, t) env) (k+1))
   in
-  let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in
-  it_mkLambda_or_LetIn_name env
+  let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+  let typP = make_arity env' dep indf s in
+  let c = 
+    it_mkLambda_or_LetIn_name env
     (mkLambda_string "P" typP
-       (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
+     (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar
+  in sigma, c
 
 (* check if the type depends recursively on one of the inductive scheme *)
 
@@ -137,7 +159,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 	    let d = (n,Some b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c)
      	| Ind (_,_) ->
-	    let realargs = list_skipn nparams largs in
+	    let realargs = List.skipn nparams largs in
 	    let base = applist (lift i pk,realargs) in
             if depK then
 	      Reduction.beta_appvect
@@ -158,7 +180,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
                   (match dest_recarg ra with
 	            | Mrec (_,j) when is_rec -> (depPvect.(j),rest)
 	            | Imbr _  ->
-		        Flags.if_warn msg_warning (str "Ignoring recursive call");
+		        msg_warning (strbrk "Ignoring recursive call");
 		        (None,rest)
                     | _ -> (None, rest))
 	  in
@@ -172,7 +194,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
 		 let nP = lift (i+1+decP) p in
                  let env' = push_rel (n,None,t) env in
 		 let t_0 = process_pos env' dep' nP (lift 1 t) in
-		 make_prod_dep (dep or dep') env
+		 make_prod_dep (dep || dep') env
                    (n,t,
 		    mkArrow t_0
 		      (process_constr
@@ -186,9 +208,9 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
       | _ -> assert false
     else
       if dep then
-	let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in
+	let realargs = List.rev_map (fun k -> mkRel (i-k)) li in
         let params = List.map (lift i) vargs in
-        let co = applist (mkConstruct cs.cs_cstr,params@realargs) in
+        let co = applist (mkConstructU cs.cs_cstr,params@realargs) in
 	Reduction.beta_appvect c [|co|]
       else c
   in
@@ -212,14 +234,14 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	    let d = (n,Some b,t) in
 	    mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
      	| Ind _ ->
-            let realargs = list_skipn nparrec largs
+            let realargs = List.skipn nparrec largs
             and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in
             applist(lift i fk,realargs@[arg])
      	| _ -> assert false
     in
     prec env 0 []
   in
-  (* ici, cstrprods est la liste des produits du constructeur instantié *)
+  (* ici, cstrprods est la liste des produits du constructeur instantié *)
   let rec process_constr env i f = function
     | (n,None,t as d)::cprest, recarg::rest ->
         let optionpos =
@@ -248,7 +270,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
 	   process_constr (push_rel d env) (i+1) (lift 1 f)
 	     (cprest,rest))
     | [],[] -> f
-    | _,[] | [],_ -> anomaly "process_constr"
+    | _,[] | [],_ -> anomaly (Pp.str "process_constr")
 
   in
   process_constr env 0 f (List.rev cstr.cs_args, recargs)
@@ -264,21 +286,21 @@ let context_chop k ctx =
     | (_, []) -> failwith "context_chop"
   in chop_aux [] (k,ctx)
 
-
 (* Main function *)
-let mis_make_indrec env sigma listdepkind mib =
+let mis_make_indrec env sigma listdepkind mib u =
   let nparams = mib.mind_nparams in
-  let nparrec = mib. mind_nparams_rec in
+  let nparrec = mib.mind_nparams_rec in
+  let evdref = ref sigma in
   let lnonparrec,lnamesparrec =
-    context_chop (nparams-nparrec) mib.mind_params_ctxt in
+    context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in
   let nrec = List.length listdepkind in
   let depPvec =
-    Array.create mib.mind_ntypes (None : (bool * constr) option) in
+    Array.make mib.mind_ntypes (None : (bool * constr) option) in
   let _ =
     let rec
 	assign k = function
 	  | [] -> ()
-          | (indi,mibi,mipi,dep,_)::rest ->
+          | ((indi,u),mibi,mipi,dep,_)::rest ->
               (Array.set depPvec (snd indi) (Some(dep,mkRel k));
                assign (k-1) rest)
     in
@@ -287,12 +309,12 @@ let mis_make_indrec env sigma listdepkind mib =
     Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
   (* recarg information for non recursive parameters *)
   let rec recargparn l n =
-    if n = 0 then l else recargparn (mk_norec::l) (n-1) in
+    if Int.equal n 0 then l else recargparn (mk_norec::l) (n-1) in
   let recargpar = recargparn [] (nparams-nparrec) in
   let make_one_rec p =
     let makefix nbconstruct =
       let rec mrec i ln ltyp ldef = function
-	| (indi,mibi,mipi,dep,_)::rest ->
+	| ((indi,u),mibi,mipi,dep,_)::rest ->
 	    let tyi = snd indi in
 	    let nctyi =
               Array.length mipi.mind_consnames in (* nb constructeurs du type*)
@@ -300,7 +322,7 @@ let mis_make_indrec env sigma listdepkind mib =
             (* arity in the context of the fixpoint, i.e.
                P1..P_nrec f1..f_nbconstruct *)
 	    let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in
-	    let indf = make_ind_family(indi,args) in
+	    let indf = make_ind_family((indi,u),args) in
 
 	    let arsign,_ = get_arity env indf in
 	    let depind = build_dependent_inductive env indf in
@@ -315,7 +337,7 @@ let mis_make_indrec env sigma listdepkind mib =
                P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
 	    let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in
 	    let args'' = Termops.extended_rel_list ndepar lnonparrec in
-            let indf' = make_ind_family(indi,args'@args'') in
+            let indf' = make_ind_family((indi,u),args'@args'') in
 
 	    let branches =
 	      let constrs = get_constructors env indf' in
@@ -324,8 +346,8 @@ let mis_make_indrec env sigma listdepkind mib =
 		(fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec))
 		fi
 	      in
-		array_map3
-		  (make_rec_branch_arg env sigma
+		Array.map3
+		  (make_rec_branch_arg env !evdref
 		      (nparrec,depPvec,larsign))
                   vecfi constrs (dest_subterms recargsvec.(tyi))
 	    in
@@ -359,10 +381,27 @@ let mis_make_indrec env sigma listdepkind mib =
 		      (Anonymous,depind',concl))
 		  arsign'
 	      in
-		it_mkLambda_or_LetIn_name env
-		  (mkCase (ci, pred,
-		          mkRel 1,
-			  branches))
+	      let obj = 
+		let projs = get_projections env indf in
+		  match projs with
+		  | None -> (mkCase (ci, pred,
+				     mkRel 1,
+				     branches))
+		  | Some ps -> 
+		    let branch = branches.(0) in
+		    let ctx, br = decompose_lam_assum branch in
+		    let n, subst = 
+		      List.fold_right (fun (na,b,t) (i, subst) ->
+			if b == None then 
+			  let t = mkProj (Projection.make ps.(i) true, mkRel 1) in
+			    (i + 1, t :: subst)
+			else (i, mkRel 0 :: subst))
+			ctx (0, [])
+		    in
+		    let term = substl subst br in
+		      term
+	      in
+		it_mkLambda_or_LetIn_name env obj
 		  (Termops.lift_rel_context nrec deparsign)
 	    in
 
@@ -383,26 +422,26 @@ let mis_make_indrec env sigma listdepkind mib =
 	    let fixn = Array.of_list (List.rev ln) in
             let fixtyi = Array.of_list (List.rev ltyp) in
             let fixdef = Array.of_list (List.rev ldef) in
-            let names = Array.create nrec (Name(id_of_string "F")) in
+            let names = Array.make nrec (Name(Id.of_string "F")) in
 	      mkFix ((fixn,p),(names,fixtyi,fixdef))
       in
 	mrec 0 [] [] []
     in
     let rec make_branch env i = function
-      | (indi,mibi,mipi,dep,_)::rest ->
+      | ((indi,u),mibi,mipi,dep,_)::rest ->
           let tyi = snd indi in
 	  let nconstr = Array.length mipi.mind_consnames in
 	  let rec onerec env j =
-	    if j = nconstr then
+	    if Int.equal j nconstr then
 	      make_branch env (i+j) rest
 	    else
 	      let recarg = (dest_subterms recargsvec.(tyi)).(j) in
 	      let recarg = recargpar@recarg in
 	      let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in
-	      let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
+	      let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in
 	      let p_0 =
 		type_rec_branch
-                  true dep env sigma (vargs,depPvec,i+j) tyi cs recarg
+                  true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg
 	      in
 		mkLambda_string "f" p_0
 		  (onerec (push_rel (Anonymous,None,p_0) env) (j+1))
@@ -411,9 +450,13 @@ let mis_make_indrec env sigma listdepkind mib =
 	  makefix i listdepkind
     in
     let rec put_arity env i = function
-      | (indi,_,_,dep,kinds)::rest ->
-	  let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in
-	  let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in
+      | ((indi,u),_,_,dep,kinds)::rest ->
+	  let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in
+	  let s = 
+	    Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) 
+	      evdref kinds 
+	  in
+	  let typP = make_arity env dep indf s in
 	    mkLambda_string "P" typP
 	      (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
       | [] ->
@@ -421,33 +464,38 @@ let mis_make_indrec env sigma listdepkind mib =
     in
 
     (* Body on make_one_rec *)
-    let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
+    let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in
 
       if (mis_is_recursive_subset
-	(List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
+	(List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind)
 	mipi.mind_recargs)
       then
 	let env' = push_rel_context lnamesparrec env in
 	  it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
 	    lnamesparrec
       else
-	mis_make_case_com dep env sigma indi (mibi,mipi) kind
+	let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in
+	  evdref := evd'; c
   in
     (* Body of mis_make_indrec *)
-    list_tabulate make_one_rec nrec
+    !evdref, List.init nrec make_one_rec
 
 (**********************************************************************)
 (* This builds elimination predicate for Case tactic *)
 
-let build_case_analysis_scheme env sigma ity dep kind =
-  let (mib,mip) = lookup_mind_specif env ity in
-  mis_make_case_com dep env sigma ity (mib,mip) kind
+let build_case_analysis_scheme env sigma pity dep kind =
+  let (mib,mip) = lookup_mind_specif env (fst pity) in
+  mis_make_case_com dep env sigma pity (mib,mip) kind
 
-let build_case_analysis_scheme_default env sigma ity kind =
-  let (mib,mip) = lookup_mind_specif env ity in
-  let dep = inductive_sort_family mip <> InProp in
-  mis_make_case_com dep env sigma ity (mib,mip) kind
+let is_in_prop mip =
+  match inductive_sort_family mip with
+  | InProp -> true
+  | _ -> false
 
+let build_case_analysis_scheme_default env sigma pity kind =
+  let (mib,mip) = lookup_mind_specif env (fst pity) in
+  let dep = not (is_in_prop mip) in
+  mis_make_case_com dep env sigma pity (mib,mip) kind
 
 (**********************************************************************)
 (* [modify_sort_scheme s rec] replaces the sort of the scheme
@@ -456,87 +504,78 @@ let build_case_analysis_scheme_default env sigma ity kind =
 let change_sort_arity sort =
   let rec drec a = match kind_of_term a with
     | Cast (c,_,_) -> drec c
-    | Prod (n,t,c) -> mkProd (n, t, drec c)
-    | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c)
-    | Sort _ -> mkSort sort
+    | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c')
+    | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c')
+    | Sort s -> s, mkSort sort
     | _ -> assert false
   in
     drec
 
-(* [npar] is the number of expected arguments (then excluding letin's) *)
-let modify_sort_scheme sort =
-  let rec drec npar elim =
-    match kind_of_term elim with
-      | Lambda (n,t,c) ->
-	  if npar = 0 then
-	    mkLambda (n, change_sort_arity sort t, c)
-	  else
-	    mkLambda (n, t, drec (npar-1) c)
-      | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c)
-      | _ -> anomaly "modify_sort_scheme: wrong elimination type"
-  in
-  drec
-
 (* Change the sort in the type of an inductive definition, builds the
    corresponding eta-expanded term *)
-let weaken_sort_scheme sort npars term =
+let weaken_sort_scheme env evd set sort npars term ty =
+  let evdref = ref evd in
   let rec drec np elim =
     match kind_of_term elim with
       | Prod (n,t,c) ->
-	  if np = 0 then
-            let t' = change_sort_arity sort t in
-            mkProd (n, t', c),
-            mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1)))
+	  if Int.equal np 0 then
+            let osort, t' = change_sort_arity sort t in
+	      evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) env !evdref sort osort;
+              mkProd (n, t', c),
+              mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1)))
 	  else
             let c',term' = drec (np-1) c in
 	    mkProd (n, t, c'), mkLambda (n, t, term')
       | LetIn (n,b,t,c) -> let c',term' = drec np c in
            mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term')
-      | _ -> anomaly "weaken_sort_scheme: wrong elimination type"
+      | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type")
   in
-  drec npars
+  let ty, term = drec npars ty in
+    !evdref, ty, term
 
 (**********************************************************************)
 (* Interface to build complex Scheme *)
 (* Check inductive types only occurs once
 (otherwise we obtain a meaning less scheme) *)
 
-let check_arities listdepkind =
+let check_arities env listdepkind =
   let _ = List.fold_left
-    (fun ln ((_,ni as mind),mibi,mipi,dep,kind) ->
+    (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) ->
        let kelim = elim_sorts (mibi,mipi) in
-       if not (List.exists ((=) kind) kelim) then raise
+       if not (Sorts.List.mem kind kelim) then raise
 	 (RecursionSchemeError
-	   (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind)))
-       else if List.mem ni ln then raise
+	  (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family env
+					      kind),(mind,u))))
+       else if Int.List.mem ni ln then raise
 	 (RecursionSchemeError (NotMutualInScheme (mind,mind)))
        else ni::ln)
 	    [] listdepkind
   in true
 
 let build_mutual_induction_scheme env sigma = function
-  | (mind,dep,s)::lrecspec ->
-      let (mib,mip) = Global.lookup_inductive mind in
+  | ((mind,u),dep,s)::lrecspec ->
+      let (mib,mip) = lookup_mind_specif env mind in
       let (sp,tyi) = mind in
       let listdepkind =
-	(mind,mib,mip,dep,s)::
+	((mind,u),mib,mip,dep,s)::
     	(List.map
-	   (function (mind',dep',s') ->
+	   (function ((mind',u'),dep',s') ->
 	      let (sp',_) = mind' in
-	      if sp=sp' then
+	      if eq_mind sp sp' then
                 let (mibi',mipi') = lookup_mind_specif env mind' in
-		(mind',mibi',mipi',dep',s')
+		((mind',u'),mibi',mipi',dep',s')
 	      else
 		raise (RecursionSchemeError (NotMutualInScheme (mind,mind'))))
 	   lrecspec)
       in
-      let _ = check_arities listdepkind in
-      mis_make_indrec env sigma listdepkind mib
-  | _ -> anomaly "build_induction_scheme expects a non empty list of inductive types"
+      let _ = check_arities env listdepkind in
+      mis_make_indrec env sigma listdepkind mib u
+  | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types")
 
-let build_induction_scheme env sigma ind dep kind =
-  let (mib,mip) = lookup_mind_specif env ind in
-  List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
+let build_induction_scheme env sigma pind dep kind =
+  let (mib,mip) = lookup_mind_specif env (fst pind) in
+  let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in
+    sigma, List.hd l
 
 (*s Eliminations. *)
 
@@ -559,17 +598,17 @@ let lookup_eliminator ind_sp s =
   (* Try first to get an eliminator defined in the same section as the *)
   (* inductive type *)
   try
-    let cst =Global.constant_of_delta_kn (make_kn mp dp (label_of_id id)) in
+    let cst =Global.constant_of_delta_kn (make_kn mp dp (Label.of_id id)) in
     let _ = Global.lookup_constant cst in
-      mkConst cst
+      ConstRef cst
   with Not_found ->
   (* Then try to get a user-defined eliminator in some other places *)
   (* using short name (e.g. for "eq_rec") *)
-  try constr_of_global (Nametab.locate (qualid_of_ident id))
+  try Nametab.locate (qualid_of_ident id)
   with Not_found ->
     errorlabstrm "default_elim"
       (strbrk "Cannot find the elimination combinator " ++
        pr_id id ++ strbrk ", the elimination of the inductive definition " ++
-       pr_global_env Idset.empty (IndRef ind_sp) ++
+       pr_global_env Id.Set.empty (IndRef ind_sp) ++
        strbrk " on sort " ++ Termops.pr_sort_family s ++
        strbrk " is probably not allowed.")
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 19c70dc0..f616c967 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.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,15 +8,13 @@
 
 open Names
 open Term
-open Declarations
-open Inductiveops
 open Environ
 open Evd
 
 (** Errors related to recursors building *)
 
 type recursion_scheme_error =
-  | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive
+  | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive
   | NotMutualInScheme of inductive * inductive
 
 exception RecursionSchemeError of recursion_scheme_error
@@ -27,42 +25,39 @@ type dep_flag = bool
 
 (** Build a case analysis elimination scheme in some sort family *)
 
-val build_case_analysis_scheme : env -> evar_map -> inductive ->
-      dep_flag -> sorts_family -> constr
+val build_case_analysis_scheme : env -> evar_map -> pinductive ->
+      dep_flag -> sorts_family -> evar_map * constr
 
 (** Build a dependent case elimination predicate unless type is in Prop *)
 
-val build_case_analysis_scheme_default : env -> evar_map -> inductive ->
-      sorts_family -> constr
+val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
+      sorts_family -> evar_map * constr
 
 (** Builds a recursive induction scheme (Peano-induction style) in the same
    sort family as the inductive family; it is dependent if not in Prop *)
 
-val build_induction_scheme : env -> evar_map -> inductive ->
-      dep_flag -> sorts_family -> constr
+val build_induction_scheme : env -> evar_map -> pinductive ->
+      dep_flag -> sorts_family -> evar_map * constr
 
 (** Builds mutual (recursive) induction schemes *)
 
 val build_mutual_induction_scheme :
-  env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list
+  env -> evar_map -> (pinductive * dep_flag * sorts_family) list -> evar_map * constr list
 
 (** Scheme combinators *)
 
-(** [modify_sort_scheme s n c] modifies the quantification sort of
-   scheme c whose predicate is abstracted at position [n] of [c] *)
+(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t]
+   whose conclusion is quantified on [Type i] at position [n] of [t] a
+   scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i],
+  otherwise just less or equal to [i]. *)
 
-val modify_sort_scheme : sorts -> int -> constr -> constr
-
-(** [weaken_sort_scheme s n c t] derives by subtyping from [c:t]
-   whose conclusion is quantified on [Type] at position [n] of [t] a
-   scheme quantified on sort [s] *)
-
-val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types
+val weaken_sort_scheme : env -> evar_map -> bool -> sorts -> int -> constr -> types -> 
+  evar_map * types * constr
 
 (** Recursor names utilities *)
 
-val lookup_eliminator : inductive -> sorts_family -> constr
+val lookup_eliminator : inductive -> sorts_family -> Globnames.global_reference
 val elimination_suffix : sorts_family -> string
-val make_elimination_ident : identifier -> sorts_family -> identifier
+val make_elimination_ident : Id.t -> sorts_family -> Id.t
 
 val case_suffix : string
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 5bfc57bf..654f914b 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -1,47 +1,52 @@
 (************************************************************************)
 (*  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 Term
+open Vars
+open Context
 open Termops
-open Namegen
-open Sign
 open Declarations
+open Declareops
 open Environ
 open Reductionops
+open Inductive
 
 (* The following three functions are similar to the ones defined in
    Inductive, but they expect an env *)
 
-let type_of_inductive env ind =
- let specif = Inductive.lookup_mind_specif env ind in
-  Inductive.type_of_inductive env specif
+let type_of_inductive env (ind,u) =
+ let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in
+ Typeops.check_hyps_inclusion env (mkInd ind) mib.mind_hyps;
+ Inductive.type_of_inductive env (specif,u)
 
 (* Return type as quoted by the user *)
-let type_of_constructor env cstr =
- let specif =
-  Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
- Inductive.type_of_constructor cstr specif
+let type_of_constructor env (cstr,u) =
+ let (mib,_ as specif) =
+   Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+ Typeops.check_hyps_inclusion env (mkConstruct cstr) mib.mind_hyps;
+ Inductive.type_of_constructor (cstr,u) specif
 
 (* Return constructor types in user form *)
-let type_of_constructors env ind =
+let type_of_constructors env (ind,u as indu) =
  let specif = Inductive.lookup_mind_specif env ind in
-  Inductive.type_of_constructors ind specif
+  Inductive.type_of_constructors indu specif
 
 (* Return constructor types in normal form *)
-let arities_of_constructors env ind =
+let arities_of_constructors env (ind,u as indu) =
  let specif = Inductive.lookup_mind_specif env ind in
-  Inductive.arities_of_constructors ind specif
+  Inductive.arities_of_constructors indu specif
 
 (* [inductive_family] = [inductive_instance] applied to global parameters *)
-type inductive_family = inductive * constr list
+type inductive_family = pinductive * constr list
 
 let make_ind_family (mis, params) = (mis,params)
 let dest_ind_family (mis,params) = (mis,params)
@@ -68,88 +73,224 @@ let lift_inductive_type n = liftn_inductive_type n 1
 let substnl_ind_type l n = map_inductive_type (substnl l n)
 
 let mkAppliedInd (IndType ((ind,params), realargs)) =
-  applist (mkInd ind,params@realargs)
+  applist (mkIndU ind,params@realargs)
 
 (* Does not consider imbricated or mutually recursive types *)
 let mis_is_recursive_subset listind rarg =
-  let rec one_is_rec rvec =
+  let one_is_rec rvec =
     List.exists
       (fun ra ->
         match dest_recarg ra with
-	  | Mrec (_,i) -> List.mem i listind
+	  | Mrec (_,i) -> Int.List.mem i listind
           | _ -> false) rvec
   in
-  array_exists one_is_rec (dest_subterms rarg)
+  Array.exists one_is_rec (dest_subterms rarg)
 
 let mis_is_recursive (ind,mib,mip) =
-  mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1))
+  mis_is_recursive_subset (List.interval 0 (mib.mind_ntypes - 1))
     mip.mind_recargs
 
-let mis_nf_constructor_type (ind,mib,mip) j =
+let mis_nf_constructor_type ((ind,u),mib,mip) j =
   let specif = mip.mind_nf_lc
   and ntypes = mib.mind_ntypes
   and nconstr = Array.length mip.mind_consnames in
-  let make_Ik k = mkInd ((fst ind),ntypes-k-1) in
+  let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in
   if j > nconstr then error "Not enough constructors in the type.";
-  substl (list_tabulate make_Ik ntypes) specif.(j-1)
+    substl (List.init ntypes make_Ik) (subst_instance_constr u specif.(j-1))
+
+(* Number of constructors *)
+
+let nconstructors ind =
+  let (_,mip) = Global.lookup_inductive ind in
+  Array.length mip.mind_consnames
+
+let nconstructors_env env ind =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  Array.length mip.mind_consnames
+
+(* Arity of constructors excluding parameters, excluding local defs *)
+
+let constructors_nrealargs ind =
+  let (_,mip) = Global.lookup_inductive ind in
+  mip.mind_consnrealargs
+
+let constructors_nrealargs_env env ind =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_consnrealargs
+
+(* Arity of constructors excluding parameters, including local defs *)
+
+let constructors_nrealdecls ind =
+  let (_,mip) = Global.lookup_inductive ind in
+  mip.mind_consnrealdecls
+
+let constructors_nrealdecls_env env ind =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_consnrealdecls
 
-(* Arity of constructors excluding parameters and local defs *)
+(* Arity of constructors including parameters, excluding local defs *)
 
-let mis_constr_nargs indsp =
+let constructor_nallargs (indsp,j) =
   let (mib,mip) = Global.lookup_inductive indsp in
-  let recargs = dest_subterms mip.mind_recargs in
-  Array.map List.length recargs
+  mip.mind_consnrealargs.(j-1) + mib.mind_nparams
 
-let mis_constr_nargs_env env (kn,i) =
+let constructor_nallargs_env env ((kn,i),j) =
   let mib = Environ.lookup_mind kn env in
   let mip = mib.mind_packets.(i) in
-  let recargs = dest_subterms mip.mind_recargs in
-  Array.map List.length recargs
+  mip.mind_consnrealargs.(j-1) + mib.mind_nparams
 
-let mis_constructor_nargs_env env ((kn,i),j) =
+(* Arity of constructors including params, including local defs *)
+
+let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *)
+  let (mib,mip) = Global.lookup_inductive indsp in
+  mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+
+let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *)
   let mib = Environ.lookup_mind kn env in
   let mip = mib.mind_packets.(i) in
-  recarg_length mip.mind_recargs j + mib.mind_nparams
+  mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt)
+
+(* Arity of constructors excluding params, excluding local defs *)
 
-let constructor_nrealargs env (ind,j) =
+let constructor_nrealargs (ind,j) =
+  let (_,mip) = Global.lookup_inductive ind in
+  mip.mind_consnrealargs.(j-1)
+
+let constructor_nrealargs_env env (ind,j) =
   let (_,mip) = Inductive.lookup_mind_specif env ind in
-  recarg_length mip.mind_recargs j
+  mip.mind_consnrealargs.(j-1)
 
-let constructor_nrealhyps env (ind,j) =
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+(* Arity of constructors excluding params, including local defs *)
+
+let constructor_nrealdecls (ind,j) = (* TOCHANGE en decls *)
+  let (_,mip) = Global.lookup_inductive ind in
   mip.mind_consnrealdecls.(j-1)
 
-let get_full_arity_sign env ind =
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  mip.mind_arity_ctxt
+let constructor_nrealdecls_env env (ind,j) = (* TOCHANGE en decls *)
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_consnrealdecls.(j-1)
 
-let nconstructors ind =
-  let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
-  Array.length mip.mind_consnames
+(* Length of arity, excluding params, excluding local defs *)
+
+let inductive_nrealargs ind =
+  let (_,mip) = Global.lookup_inductive ind in
+  mip.mind_nrealargs
+
+let inductive_nrealargs_env env ind =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_nrealargs
+
+(* Length of arity, excluding params, including local defs *)
+
+let inductive_nrealdecls ind =
+  let (_,mip) = Global.lookup_inductive ind in
+  mip.mind_nrealdecls
+
+let inductive_nrealdecls_env env ind =
+  let (_,mip) = Inductive.lookup_mind_specif env ind in
+  mip.mind_nrealdecls
+
+(* Full length of arity (w/o local defs) *)
+
+let inductive_nallargs ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  mib.mind_nparams + mip.mind_nrealargs
+
+let inductive_nallargs_env env ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mib.mind_nparams + mip.mind_nrealargs
 
 (* Length of arity (w/o local defs) *)
 
-let inductive_nargs env ind =
+let inductive_nparams ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  mib.mind_nparams
+
+let inductive_nparams_env env ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  mib.mind_nparams
+
+(* Length of arity (with local defs) *)
+
+let inductive_nparamdecls ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  rel_context_length mib.mind_params_ctxt
+
+let inductive_nparamdecls_env env ind =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  rel_context_length mib.mind_params_ctxt
+
+(* Full length of arity (with local defs) *)
+
+let inductive_nalldecls ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+
+let inductive_nalldecls_env env ind =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt)
+  rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls
+
+(* Others *)
+
+let inductive_paramdecls (ind,u) =
+  let (mib,mip) = Global.lookup_inductive ind in
+    Inductive.inductive_paramdecls (mib,u)
+
+let inductive_paramdecls_env env (ind,u) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+    Inductive.inductive_paramdecls (mib,u)
+
+let inductive_alldecls (ind,u) =
+  let (mib,mip) = Global.lookup_inductive ind in
+    Vars.subst_instance_context u mip.mind_arity_ctxt
+
+let inductive_alldecls_env env (ind,u) =
+  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+    Vars.subst_instance_context u mip.mind_arity_ctxt
+
+let constructor_has_local_defs (indsp,j) =
+  let (mib,mip) = Global.lookup_inductive indsp in
+  let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in
+  let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in
+  not (Int.equal l1 l2)
+
+let inductive_has_local_defs ind =
+  let (mib,mip) = Global.lookup_inductive ind in
+  let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in
+  let l2 = mib.mind_nparams + mip.mind_nrealargs in
+  not (Int.equal l1 l2)
 
 let allowed_sorts env (kn,i as ind) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   mip.mind_kelim
 
+let projection_nparams_env env p = 
+  let pb = lookup_projection p env in
+    pb.proj_npars
+
+let projection_nparams p = projection_nparams_env (Global.env ()) p
+
 (* Annotation for cases *)
 let make_case_info env ind style =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
-  let print_info = { ind_nargs = mip.mind_nrealargs_ctxt; style = style } in
+  let ind_tags =
+    rel_context_tags (List.firstn mip.mind_nrealargs mip.mind_arity_ctxt) in
+  let cstr_tags =
+    Array.map2 (fun c n ->
+      let d,_ = decompose_prod_assum c in
+      rel_context_tags (List.firstn n d))
+      mip.mind_nf_lc mip.mind_consnrealdecls in
+  let print_info = { ind_tags; cstr_tags; style } in
   { ci_ind     = ind;
     ci_npar    = mib.mind_nparams;
     ci_cstr_ndecls = mip.mind_consnrealdecls;
+    ci_cstr_nargs = mip.mind_consnrealargs;
     ci_pp_info = print_info }
 
 (*s Useful functions *)
 
 type constructor_summary = {
-  cs_cstr : constructor;
+  cs_cstr : pconstructor;
   cs_params : constr list;
   cs_nargs : int;
   cs_args : rel_context;
@@ -170,33 +311,39 @@ let instantiate_params t args sign =
     | ((_,None,_)::ctxt,a::args) ->
 	(match kind_of_term t with
 	   | Prod(_,_,t) -> inst (a::s) t (ctxt,args)
-	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
+	   | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
     | ((_,(Some b),_)::ctxt,args) ->
 	(match kind_of_term t with
 	   | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
-	   | _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
+	   | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch"))
     | _, [] -> substl s t
-    | _ -> anomaly"instantiate_params: type, ctxt and args mismatch"
+    | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")
   in inst [] t (List.rev sign,args)
 
-let get_constructor (ind,mib,mip,params) j =
+let get_constructor ((ind,u as indu),mib,mip,params) j =
   assert (j <= Array.length mip.mind_consnames);
-  let typi = mis_nf_constructor_type (ind,mib,mip) j in
+  let typi = mis_nf_constructor_type (indu,mib,mip) j in
   let typi = instantiate_params typi params mib.mind_params_ctxt in
   let (args,ccl) = decompose_prod_assum typi in
   let (_,allargs) = decompose_app ccl in
-  let vargs = list_skipn (List.length params) allargs in
-  { cs_cstr = ith_constructor_of_inductive ind j;
+  let vargs = List.skipn (List.length params) allargs in
+  { cs_cstr = (ith_constructor_of_inductive ind j,u);
     cs_params = params;
     cs_nargs = rel_context_length args;
     cs_args = args;
     cs_concl_realargs = Array.of_list vargs }
 
 let get_constructors env (ind,params) =
-  let (mib,mip) = Inductive.lookup_mind_specif env ind in
+  let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in
   Array.init (Array.length mip.mind_consnames)
     (fun j -> get_constructor (ind,mib,mip,params) (j+1))
 
+let get_projections env (ind,params) =
+  let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in
+    match mib.mind_record with
+    | Some (Some (id, projs, pbs)) -> Some projs
+    | _ -> None
+
 (* substitution in a signature *)
 
 let substnl_rel_context subst n sign =
@@ -207,15 +354,15 @@ let substnl_rel_context subst n sign =
 
 let substl_rel_context subst = substnl_rel_context subst 0
 
-let rec instantiate_context sign args =
+let instantiate_context sign args =
   let rec aux subst = function
   | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args)
   | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args)
   | [], [] -> subst
-  | _ -> anomaly "Signature/instance mismatch in inductive family"
+  | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family")
   in aux [] (List.rev sign,args)
 
-let get_arity env (ind,params) =
+let get_arity env ((ind,u),params) =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
   let parsign =
     (* Dynamically detect if called with an instance of recursively
@@ -223,19 +370,21 @@ let get_arity env (ind,params) =
        parameters *)
     let parsign = mib.mind_params_ctxt in
     let nnonrecparams = mib.mind_nparams - mib.mind_nparams_rec in
-    if List.length params = rel_context_nhyps parsign - nnonrecparams then
-      snd (list_chop nnonrecparams mib.mind_params_ctxt)
+    if Int.equal (List.length params) (rel_context_nhyps parsign - nnonrecparams) then
+      snd (List.chop nnonrecparams mib.mind_params_ctxt)
     else
       parsign in
+  let parsign = Vars.subst_instance_context u parsign in
   let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in
-  let arsign,_ = list_chop arproperlength mip.mind_arity_ctxt in
+  let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in
   let subst = instantiate_context parsign params in
+  let arsign = Vars.subst_instance_context u arsign in
   (substl_rel_context subst arsign, Inductive.inductive_sort_family mip)
 
 (* Functions to build standard types related to inductive *)
 let build_dependent_constructor cs =
   applist
-    (mkConstruct cs.cs_cstr,
+    (mkConstructU cs.cs_cstr,
      (List.map (lift cs.cs_nargs) cs.cs_params)
       @(extended_rel_list 0 cs.cs_args))
 
@@ -243,7 +392,7 @@ let build_dependent_inductive env ((ind, params) as indf) =
   let arsign,_ = get_arity env indf in
   let nrealargs = List.length arsign in
   applist
-    (mkInd ind,
+    (mkIndU ind,
      (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
 
 (* builds the arity of an elimination predicate in sort [s] *)
@@ -252,7 +401,7 @@ let make_arity_signature env dep indf =
   let (arsign,_) = get_arity env indf in
   if dep then
     (* We need names everywhere *)
-    name_context env
+    Namegen.name_context env
       ((Anonymous,None,build_dependent_inductive env indf)::arsign)
       (* Costly: would be better to name once for all at definition time *)
   else
@@ -265,7 +414,7 @@ let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s)
 let build_branch_type env dep p cs =
   let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in
   if dep then
-    it_mkProd_or_LetIn_name env
+    Namegen.it_mkProd_or_LetIn_name env
       (applist (base,[build_dependent_constructor cs]))
       cs.cs_args
   else
@@ -288,18 +437,18 @@ let find_mrectype env sigma c =
 let find_rectype env sigma c =
   let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
   match kind_of_term t with
-    | Ind ind ->
+    | Ind (ind,u as indu) ->
         let (mib,mip) = Inductive.lookup_mind_specif env ind in
         if mib.mind_nparams > List.length l then raise Not_found;
-        let (par,rargs) = list_chop mib.mind_nparams l in
-        IndType((ind, par),rargs)
+        let (par,rargs) = List.chop mib.mind_nparams l in
+        IndType((indu, par),rargs)
     | _ -> raise Not_found
 
 let find_inductive env sigma c =
   let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
   match kind_of_term t with
     | Ind ind
-        when (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite ->
         (ind, l)
     | _ -> raise Not_found
 
@@ -307,7 +456,7 @@ let find_coinductive env sigma c =
   let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in
   match kind_of_term t with
     | Ind ind
-        when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite ->
+        when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite ->
         (ind, l)
     | _ -> raise Not_found
 
@@ -322,7 +471,7 @@ let is_predicate_explicitly_dep env pred arsign =
     match kind_of_term pv', arsign with
       | Lambda (na,t,b), (_,None,_)::arsign ->
 	  srec (push_rel_assum (na,t) env) b arsign
-      | Lambda (na,_,_), _ ->
+      | Lambda (na,_,t), _ ->
 
        (* The following code has an impact on the introduction names
 	  given by the tactics "case" and "inversion": when the
@@ -341,13 +490,15 @@ let is_predicate_explicitly_dep env pred arsign =
 	  dependency status (of course, Anonymous implies non
 	  dependent, but not conversely).
 
-          At the end, this is only to preserve the compatibility: a
-          check whether the predicate is actually dependent or not
-          would indeed be more natural! *)
+          From Coq > 8.2, using or not the the effective dependency of
+          the predicate is parametrable! *)
 
-	  na <> Anonymous
+          begin match na with
+          | Anonymous -> false
+          | Name _ -> true
+          end
 
-      | _ -> anomaly "Non eta-expanded dep-expanded \"match\" predicate"
+      | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate")
   in
   srec env pred arsign
 
@@ -357,7 +508,7 @@ let is_elim_predicate_explicitly_dependent env pred indf =
 
 let set_names env n brty =
   let (ctxt,cl) = decompose_prod_n_assum n brty in
-  it_mkProd_or_LetIn_name env cl ctxt
+  Namegen.it_mkProd_or_LetIn_name env cl ctxt
 
 let set_pattern_names env ind brv =
   let (mib,mip) = Inductive.lookup_mind_specif env ind in
@@ -367,19 +518,19 @@ let set_pattern_names env ind brv =
         rel_context_length ((prod_assum c)) -
         mib.mind_nparams)
       mip.mind_nf_lc in
-  array_map2 (set_names env) arities brv
+  Array.map2 (set_names env) arities brv
 
 let type_case_branches_with_names env indspec p c =
   let (ind,args) = indspec in
-  let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in
+  let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in
   let nparams = mib.mind_nparams in
-  let (params,realargs) = list_chop nparams args in
+  let (params,realargs) = List.chop nparams args in
   let lbrty = Inductive.build_branches_type ind specif params p in
   (* Build case type *)
   let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in
   (* Adjust names *)
   if is_elim_predicate_explicitly_dependent env p (ind,params) then
-    (set_pattern_names env ind lbrty, conclty)
+    (set_pattern_names env (fst ind) lbrty, conclty)
   else (lbrty, conclty)
 
 (* Type of Case predicates *)
@@ -393,40 +544,44 @@ let arity_of_case_predicate env (ind,params) dep k =
 (* Inferring the sort of parameters of a polymorphic inductive type
    knowing the sort of the conclusion *)
 
+
 (* Compute the inductive argument types: replace the sorts
    that appear in the type of the inductive by the sort of the
    conclusion, and the other ones by fresh universes. *)
-let rec instantiate_universes env scl is = function
+let rec instantiate_universes env evdref scl is = function
   | (_,Some _,_ as d)::sign, exp ->
-      d :: instantiate_universes env scl is (sign, exp)
+      d :: instantiate_universes env evdref scl is (sign, exp)
   | d::sign, None::exp ->
-      d :: instantiate_universes env scl is (sign, exp)
-  | (na,None,ty)::sign, Some u::exp ->
+      d :: instantiate_universes env evdref scl is (sign, exp)
+  | (na,None,ty)::sign, Some l::exp ->
       let ctx,_ = Reduction.dest_arity env ty in
+      let u = Univ.Universe.make l in
       let s =
 	(* Does the sort of parameter [u] appear in (or equal)
            the sort of inductive [is] ? *)
-        if univ_depends u is then
+        if univ_level_mem l is then
           scl (* constrained sort: replace by scl *)
         else
-          (* unconstriained sort: replace by fresh universe *)
-          new_Type_sort() in
-      (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp)
+          (* unconstrained sort: replace by fresh universe *)
+          let evm, s = Evd.new_sort_variable Evd.univ_flexible !evdref in
+	  let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in
+	    evdref := evm; s
+      in
+      (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp)
   | sign, [] -> sign (* Uniform parameters are exhausted *)
   | [], _ -> assert false
 
-(* Does not deal with universes, but only with Set/Type distinction *)
-let type_of_inductive_knowing_conclusion env mip conclty =
+let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty =
   match mip.mind_arity with
-  | Monomorphic s ->
-      s.mind_user_arity
-  | Polymorphic ar ->
-      let _,scl = Reduction.dest_arity env conclty in
-      let ctx = List.rev mip.mind_arity_ctxt in
-      let ctx =
-        instantiate_universes
-          env scl ar.poly_level (ctx,ar.poly_param_levels) in
-      mkArity (List.rev ctx,scl)
+  | RegularArity s -> sigma, subst_instance_constr u s.mind_user_arity
+  | TemplateArity ar ->
+    let _,scl = Reduction.dest_arity env conclty in
+    let ctx = List.rev mip.mind_arity_ctxt in
+    let evdref = ref sigma in
+    let ctx =
+      instantiate_universes
+        env evdref scl ar.template_level (ctx,ar.template_param_levels) in
+      !evdref, mkArity (List.rev ctx,scl)
 
 (***********************************************)
 (* Guard condition *)
@@ -447,7 +602,3 @@ let control_only_guard env c =
     iter_constr_with_full_binders push_rel iter env c
   in
   iter env c
-
-let subst_inductive subst (kn,i as ind) =
-  let kn' = Mod_subst.subst_ind subst kn in
-  if kn == kn' then ind else (kn',i)
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 133d7013..af1783b7 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.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,27 +8,27 @@
 
 open Names
 open Term
+open Context
 open Declarations
 open Environ
 open Evd
-open Sign
 
 (** The following three functions are similar to the ones defined in
    Inductive, but they expect an env *)
 
-val type_of_inductive    : env -> inductive -> types
+val type_of_inductive    : env -> pinductive -> types
 
 (** Return type as quoted by the user *)
-val type_of_constructor  : env -> constructor -> types
-val type_of_constructors : env -> inductive -> types array
+val type_of_constructor  : env -> pconstructor -> types
+val type_of_constructors : env -> pinductive -> types array
 
 (** Return constructor types in normal form *)
-val arities_of_constructors : env -> inductive -> types array
+val arities_of_constructors : env -> pinductive -> types array
 
 (** An inductive type with its parameters *)
 type inductive_family
-val make_ind_family : inductive * constr list -> inductive_family
-val dest_ind_family : inductive_family -> inductive * constr list
+val make_ind_family : inductive puniverses * constr list -> inductive_family
+val dest_ind_family : inductive_family -> inductive puniverses * constr list
 val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family
 val liftn_inductive_family : int -> int -> inductive_family -> inductive_family
 val lift_inductive_family  : int -> inductive_family -> inductive_family
@@ -49,31 +49,86 @@ val mis_is_recursive_subset : int list -> wf_paths -> bool
 val mis_is_recursive :
   inductive * mutual_inductive_body * one_inductive_body -> bool
 val mis_nf_constructor_type :
-  inductive * mutual_inductive_body * one_inductive_body -> int -> constr
+  pinductive * mutual_inductive_body * one_inductive_body -> int -> constr
 
-(** Extract information from an inductive name *)
-
-(** Arity of constructors excluding parameters and local defs *)
-val mis_constr_nargs : inductive -> int array
-val mis_constr_nargs_env : env -> inductive -> int array
+(** {6 Extract information from an inductive name} *)
 
+(** @return number of constructors *)
 val nconstructors : inductive -> int
+val nconstructors_env : env -> inductive -> int
+
+(** @return arity of constructors excluding parameters, excluding local defs *)
+val constructors_nrealargs : inductive -> int array
+val constructors_nrealargs_env : env -> inductive -> int array
+
+(** @return arity of constructors excluding parameters, including local defs *)
+val constructors_nrealdecls : inductive -> int array
+val constructors_nrealdecls_env : env -> inductive -> int array
+
+(** @return the arity, excluding params, excluding local defs *)
+val inductive_nrealargs : inductive -> int
+val inductive_nrealargs_env : env -> inductive -> int
+
+(** @return the arity, excluding params, including local defs *)
+val inductive_nrealdecls : inductive -> int
+val inductive_nrealdecls_env : env -> inductive -> int
+
+(** @return the arity, including params, excluding local defs *)
+val inductive_nallargs : inductive -> int
+val inductive_nallargs_env : env -> inductive -> int
+
+(** @return the arity, including params, including local defs *)
+val inductive_nalldecls : inductive -> int
+val inductive_nalldecls_env : env -> inductive -> int
+
+(** @return nb of params without local defs *)
+val inductive_nparams : inductive -> int
+val inductive_nparams_env : env -> inductive -> int
+
+(** @return nb of params with local defs *)
+val inductive_nparamdecls : inductive -> int
+val inductive_nparamdecls_env : env -> inductive -> int
 
-(** Return the lengths of parameters signature and real arguments signature *)
-val inductive_nargs : env -> inductive -> int * int
+(** @return params context *)
+val inductive_paramdecls : pinductive -> rel_context
+val inductive_paramdecls_env : env -> pinductive -> rel_context
 
-val mis_constructor_nargs_env : env -> constructor -> int
-val constructor_nrealargs : env -> constructor -> int
-val constructor_nrealhyps : env -> constructor -> int
+(** @return full arity context, hence with letin *)
+val inductive_alldecls : pinductive -> rel_context
+val inductive_alldecls_env : env -> pinductive -> rel_context
 
-val get_full_arity_sign : env -> inductive -> rel_context
+(** {7 Extract information from a constructor name} *)
+
+(** @return param + args without letin *)
+val constructor_nallargs : constructor -> int
+val constructor_nallargs_env : env -> constructor -> int
+
+(** @return param + args with letin *)
+val constructor_nalldecls : constructor -> int
+val constructor_nalldecls_env : env -> constructor -> int
+
+(** @return args without letin *)
+val constructor_nrealargs : constructor -> int
+val constructor_nrealargs_env : env -> constructor -> int
+
+(** @return args with letin *)
+val constructor_nrealdecls : constructor -> int
+val constructor_nrealdecls_env : env -> constructor -> int
+
+(** Is there local defs in params or args ? *)
+val constructor_has_local_defs : constructor -> bool
+val inductive_has_local_defs : inductive -> bool
 
 val allowed_sorts : env -> inductive -> sorts_family list
 
+(** Primitive projections *)
+val projection_nparams : projection -> int
+val projection_nparams_env : env -> projection -> int
+
 (** Extract information from an inductive family *)
 
 type constructor_summary = {
-  cs_cstr : constructor;    (* internal name of the constructor *)
+  cs_cstr : pconstructor;    (* internal name of the constructor plus universes *)
   cs_params : constr list;  (* parameters of the constructor in current ctx *)
   cs_nargs : int;           (* length of arguments signature (letin included) *)
   cs_args : rel_context;    (* signature of the arguments (letin included) *)
@@ -81,22 +136,24 @@ type constructor_summary = {
 }
 val lift_constructor : int -> constructor_summary -> constructor_summary
 val get_constructor :
-  inductive * mutual_inductive_body * one_inductive_body * constr list ->
+  pinductive * mutual_inductive_body * one_inductive_body * constr list ->
   int -> constructor_summary
 val get_arity        : env -> inductive_family -> rel_context * sorts_family
 val get_constructors : env -> inductive_family -> constructor_summary array
+val get_projections  : env -> inductive_family -> constant array option
+
 val build_dependent_constructor : constructor_summary -> constr
 val build_dependent_inductive   : env -> inductive_family -> constr
 val make_arity_signature : env -> bool -> inductive_family -> rel_context
 val make_arity : env -> bool -> inductive_family -> sorts -> types
 val build_branch_type : env -> bool -> constr -> constructor_summary -> types
 
-(** Raise [Not_found] if not given an valid inductive type *)
-val extract_mrectype : constr -> inductive * constr list
-val find_mrectype    : env -> evar_map -> types -> inductive * constr list
+(** Raise [Not_found] if not given a valid inductive type *)
+val extract_mrectype : constr -> pinductive * constr list
+val find_mrectype    : env -> evar_map -> types -> pinductive * constr list
 val find_rectype     : env -> evar_map -> types -> inductive_type
-val find_inductive   : env -> evar_map -> types -> inductive * constr list
-val find_coinductive : env -> evar_map -> types -> inductive * constr list
+val find_inductive   : env -> evar_map -> types -> pinductive * constr list
+val find_coinductive : env -> evar_map -> types -> pinductive * constr list
 
 (********************)
 
@@ -105,8 +162,7 @@ val arity_of_case_predicate :
   env -> inductive_family -> bool -> sorts -> types
 
 val type_case_branches_with_names :
-  env -> inductive * constr list -> constr -> constr ->
-    types array * types
+  env -> pinductive * constr list -> constr -> constr -> types array * types
 
 (** Annotation for cases *)
 val make_case_info : env -> inductive -> case_style -> case_info
@@ -118,9 +174,7 @@ i*)
 (********************)
 
 val type_of_inductive_knowing_conclusion :
-  env -> one_inductive_body -> types -> types
+  env -> evar_map -> Inductive.mind_specif puniverses -> types -> evar_map * types
 
 (********************)
 val control_only_guard : env -> types -> unit
-
-val subst_inductive : Mod_subst.substitution -> inductive -> inductive
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
new file mode 100644
index 00000000..4a5e11f0
--- /dev/null
+++ b/pretyping/locusops.ml
@@ -0,0 +1,125 @@
+(************************************************************************)
+(*  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 Locus
+
+(** Utilities on occurrences *)
+
+let occurrences_map f = function
+  | OnlyOccurrences l ->
+    let l' = f l in
+    if l' = [] then NoOccurrences else OnlyOccurrences l'
+  | AllOccurrencesBut l ->
+    let l' = f l in
+    if l' = [] then AllOccurrences else AllOccurrencesBut l'
+  | (NoOccurrences|AllOccurrences) as o -> o
+
+let convert_occs = function
+  | AllOccurrences -> (false,[])
+  | AllOccurrencesBut l -> (false,l)
+  | NoOccurrences -> (true,[])
+  | OnlyOccurrences l -> (true,l)
+
+let is_selected occ = function
+  | AllOccurrences -> true
+  | AllOccurrencesBut l -> not (Int.List.mem occ l)
+  | OnlyOccurrences l -> Int.List.mem occ l
+  | NoOccurrences -> false
+
+(** Usual clauses *)
+
+let allHypsAndConcl = { onhyps=None; concl_occs=AllOccurrences }
+let allHyps = { onhyps=None; concl_occs=NoOccurrences }
+let onConcl = { onhyps=Some[]; concl_occs=AllOccurrences }
+let nowhere = { onhyps=Some[]; concl_occs=NoOccurrences }
+let onHyp h =
+  { onhyps=Some[(AllOccurrences,h),InHyp]; concl_occs=NoOccurrences }
+
+let is_nowhere = function
+| { onhyps=Some[]; concl_occs=NoOccurrences } -> true
+| _ -> false
+
+(** Clause conversion functions, parametrized by a hyp enumeration function *)
+
+(** From [clause] to [simple_clause] *)
+
+let simple_clause_of enum_hyps cl =
+  let error_occurrences () =
+    Errors.error "This tactic does not support occurrences selection" in
+  let error_body_selection () =
+    Errors.error "This tactic does not support body selection" in
+  let hyps =
+    match cl.onhyps with
+    | None ->
+	List.map Option.make (enum_hyps ())
+    | Some l ->
+	List.map (fun ((occs,id),w) ->
+	  if occs <> AllOccurrences then error_occurrences ();
+	  if w = InHypValueOnly then error_body_selection ();
+	  Some id) l in
+  if cl.concl_occs = NoOccurrences then hyps
+  else
+    if cl.concl_occs <> AllOccurrences then error_occurrences ()
+    else None :: hyps
+
+(** From [clause] to [concrete_clause] *)
+
+let concrete_clause_of enum_hyps cl =
+  let hyps =
+    match cl.onhyps with
+    | None ->
+	let f id = OnHyp (id,AllOccurrences,InHyp) in
+	List.map f (enum_hyps ())
+    | Some l ->
+	List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in
+  if cl.concl_occs = NoOccurrences then hyps
+  else
+    OnConcl cl.concl_occs :: hyps
+
+(** Miscellaneous functions *)
+
+let out_arg = function
+  | Misctypes.ArgVar _ -> Errors.anomaly (Pp.str "Unevaluated or_var variable")
+  | Misctypes.ArgArg x -> x
+
+let occurrences_of_hyp id cls =
+  let rec hyp_occ = function
+      [] -> NoOccurrences, InHyp
+    | ((occs,id'),hl)::_ when Names.Id.equal id id' ->
+        occurrences_map (List.map out_arg) occs, hl
+    | _::l -> hyp_occ l in
+  match cls.onhyps with
+      None -> AllOccurrences,InHyp
+    | Some l -> hyp_occ l
+
+let occurrences_of_goal cls =
+  occurrences_map (List.map out_arg) cls.concl_occs
+
+let in_every_hyp cls = Option.is_empty cls.onhyps
+
+let clause_with_generic_occurrences cls =
+  let hyps = match cls.onhyps with
+  | None -> true
+  | Some hyps ->
+     List.for_all
+       (function ((AllOccurrences,_),_) -> true | _ -> false) hyps in
+  let concl = match cls.concl_occs with
+  | AllOccurrences | NoOccurrences -> true
+  | _ -> false in
+  hyps && concl
+
+let clause_with_generic_context_selection cls =
+  let hyps = match cls.onhyps with
+  | None -> true
+  | Some hyps ->
+     List.for_all
+       (function ((AllOccurrences,_),InHyp) -> true | _ -> false) hyps in
+  let concl = match cls.concl_occs with
+  | AllOccurrences | NoOccurrences -> true
+  | _ -> false in
+  hyps && concl
diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli
new file mode 100644
index 00000000..79dc3734
--- /dev/null
+++ b/pretyping/locusops.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  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 Names
+open Locus
+
+(** Utilities on occurrences *)
+
+val occurrences_map :
+  ('a list -> 'b list) -> 'a occurrences_gen -> 'b occurrences_gen
+
+(** From occurrences to a list of positions (or complement of positions) *)
+val convert_occs : occurrences -> bool * int list
+
+val is_selected : int -> occurrences -> bool
+
+(** Usual clauses *)
+
+val allHypsAndConcl : 'a clause_expr
+val allHyps : 'a clause_expr
+val onConcl : 'a clause_expr
+val nowhere : 'a clause_expr
+val onHyp : 'a -> 'a clause_expr
+
+(** Tests *)
+
+val is_nowhere : 'a clause_expr -> bool
+
+(** Clause conversion functions, parametrized by a hyp enumeration function *)
+
+val simple_clause_of : (unit -> Id.t list) -> clause -> simple_clause
+val concrete_clause_of : (unit -> Id.t list) -> clause -> concrete_clause
+
+(** Miscellaneous functions *)
+
+val occurrences_of_hyp : Id.t -> clause -> (occurrences * hyp_location_flag)
+val occurrences_of_goal : clause -> occurrences
+val in_every_hyp : clause -> bool
+
+val clause_with_generic_occurrences : 'a clause_expr -> bool
+val clause_with_generic_context_selection : 'a clause_expr -> bool
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
deleted file mode 100644
index b86f3e45..00000000
--- a/pretyping/matching.ml
+++ /dev/null
@@ -1,357 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Pp
-open Util
-open Names
-open Libnames
-open Nameops
-open Termops
-open Reductionops
-open Term
-open Glob_term
-open Sign
-open Environ
-open Pattern
-(*i*)
-
-(* Given a term with second-order variables in it,
-   represented by Meta's, and possibly applied using [SOAPP] to
-   terms, this function will perform second-order, binding-preserving,
-   matching, in the case where the pattern is a pattern in the sense
-   of Dale Miller.
-
-   ALGORITHM:
-
-   Given a pattern, we decompose it, flattening Cast's and apply's,
-   recursing on all operators, and pushing the name of the binder each
-   time we descend a binder.
-
-   When we reach a first-order variable, we ask that the corresponding
-   term's free-rels all be higher than the depth of the current stack.
-
-   When we reach a second-order application, we ask that the
-   intersection of the free-rels of the term and the current stack be
-   contained in the arguments of the application, and in that case, we
-   construct a LAMBDA with the names on the stack.
-
- *)
-
-type bound_ident_map = (identifier * identifier) list
-
-exception PatternMatchingFailure
-
-let constrain (n,(ids,m as x)) (names,terms as subst) =
-  try
-    let (ids',m') = List.assoc n terms in
-    if ids = ids' && eq_constr m m' then subst
-    else raise PatternMatchingFailure
-  with
-      Not_found ->
-        if List.mem_assoc n names then
-          Flags.if_warn Pp.msg_warning
-              (str "Collision between bound variable " ++ pr_id n ++
-               str " and a metavariable of same name.");
-        (names,(n,x)::terms)
-
-let add_binders na1 na2 (names,terms as subst) =
-  match na1, na2 with
-  | Name id1, Name id2 ->
-      if List.mem_assoc id1 names then
-        (Flags.if_warn Pp.msg_warning
-          (str "Collision between bound variables of name " ++ pr_id id1);
-         (names,terms))
-      else
-        (if List.mem_assoc id1 terms then
-            Flags.if_warn Pp.msg_warning
-              (str "Collision between bound variable " ++ pr_id id1 ++
-               str " and another bound variable of same name.");
-         ((id1,id2)::names,terms));
-  | _ -> subst
-
-let build_lambda toabstract stk (m : constr) =
-  let rec buildrec m p_0 p_1 = match p_0,p_1 with
-    | (_, []) -> m
-    | (n, (_,na,t)::tl) ->
-	if List.mem n toabstract then
-          buildrec (mkLambda (na,t,m)) (n+1) tl
-        else
-	  buildrec (lift (-1) m) (n+1) tl
-  in
-  buildrec m 1 stk
-
-let rec list_insert f a = function
-  | [] -> [a]
-  | b::l when f a b -> a::b::l
-  | b::l when a = b -> raise PatternMatchingFailure
-  | b::l -> b :: list_insert f a l
-
-let extract_bound_vars =
-  let rec aux k = function
-  | ([],_) -> []
-  | (n::l,(na1,na2,_)::stk) when k = n ->
-      begin match na1,na2 with
-      | Name id1,Name _ -> list_insert (<) id1 (aux (k+1) (l,stk))
-      | Name _,Anonymous -> anomaly "Unnamed bound variable"
-      | Anonymous,_ -> raise PatternMatchingFailure
-      end
-  | (l,_::stk) -> aux (k+1) (l,stk)
-  | (_,[]) -> assert false
-  in aux 1
-
-let dummy_constr = mkProp
-
-let rec make_renaming ids = function
-  | (Name id,Name _,_)::stk ->
-      let renaming = make_renaming ids stk in
-      (try mkRel (list_index id ids) :: renaming
-       with Not_found -> dummy_constr :: renaming)
-  | (_,_,_)::stk ->
-      dummy_constr :: make_renaming ids stk
-  | [] ->
-      []
-
-let merge_binding allow_bound_rels stk n cT subst =
-  let depth = List.length stk in
-  let c =
-    if depth = 0 then
-      (* Optimization *)
-      ([],cT)
-    else
-      let frels = Intset.elements (free_rels cT) in
-      let frels = List.filter (fun i -> i <= depth) frels in
-      if allow_bound_rels then
-	let frels = Sort.list (<) frels in
-	let canonically_ordered_vars = extract_bound_vars (frels,stk) in
-	let renaming = make_renaming canonically_ordered_vars stk in
-	(canonically_ordered_vars, substl renaming cT)
-      else if frels = [] then
-	([],lift (-depth) cT)
-      else
-	raise PatternMatchingFailure in
-  constrain (n,c) subst
-
-let matches_core convert allow_partial_app allow_bound_rels pat c =
-  let conv = match convert with
-    | None -> eq_constr
-    | Some (env,sigma) -> is_conv env sigma in
-  let rec sorec stk subst p t =
-    let cT = strip_outer_cast t in
-    match p,kind_of_term cT with
-      | PSoApp (n,args),m ->
-	  let relargs =
-	    List.map
-	      (function
-		 | PRel n -> n
-		 | _ -> error "Only bound indices allowed in second order pattern matching.")
-	      args in
-	  let frels = Intset.elements (free_rels cT) in
-	  if list_subset frels relargs then
-	    constrain (n,([],build_lambda relargs stk cT)) subst
-	  else
-	    raise PatternMatchingFailure
-
-      | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst
-
-      | PMeta None, m -> subst
-
-      | PRef (VarRef v1), Var v2 when v1 = v2 -> subst
-
-      | PVar v1, Var v2 when v1 = v2 -> subst
-
-      | PRef ref, _ when conv (constr_of_global ref) cT -> subst
-
-      | PRel n1, Rel n2 when n1 = n2 -> subst
-
-      | PSort (GProp c1), Sort (Prop c2) when c1 = c2 -> subst
-
-      | PSort (GType _), Sort (Type _) -> subst
-
-      | PApp (p, [||]), _ -> sorec stk subst p t
-
-      | PApp (PApp (h, a1), a2), _ ->
-          sorec stk subst (PApp(h,Array.append a1 a2)) t
-
-      | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app ->
-          let p = Array.length args2 - Array.length args1 in
-          if p>=0 then
-            let args21, args22 = array_chop p args2 in
-	    let c = mkApp(c2,args21) in
-            let subst =
-              match meta with
-              | None -> subst
-              | Some n -> merge_binding allow_bound_rels stk n c subst in
-            array_fold_left2 (sorec stk) subst args1 args22
-          else raise PatternMatchingFailure
-
-      | PApp (c1,arg1), App (c2,arg2) ->
-        (try array_fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2
-         with Invalid_argument _ -> raise PatternMatchingFailure)
-
-      | PProd (na1,c1,d1), Prod(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::stk)
-            (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
-
-      | PLambda (na1,c1,d1), Lambda(na2,c2,d2) ->
-	  sorec ((na1,na2,c2)::stk)
-            (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
-
-      | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) ->
-	  sorec ((na1,na2,t2)::stk)
-            (add_binders na1 na2 (sorec stk subst c1 c2)) d1 d2
-
-      | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) ->
-	  let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in
-	  let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in
-	  let n = rel_context_length ctx in
-          let n' = rel_context_length ctx' in
-	  if noccur_between 1 n b2 & noccur_between 1 n' b2' then
-	    let s =
-	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in
-	    let s' =
-	      List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in
-	    let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in
-  	    sorec s' (sorec s (sorec stk subst a1 a2) b1 b2) b1' b2'
-          else
-            raise PatternMatchingFailure
-
-      | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) ->
-	  let n2 = Array.length br2 in
-	  if (ci1.cip_ind <> None && ci1.cip_ind <> Some ci2.ci_ind) ||
-	     (not ci1.cip_extensible && List.length br1 <> n2)
-	  then raise PatternMatchingFailure;
-	  let chk_branch subst (j,n,c) =
-	    (* (ind,j+1) is normally known to be a correct constructor
-	       and br2 a correct match over the same inductive *)
-	    assert (j < n2);
-	    sorec stk subst c br2.(j)
-	  in
-	  let chk_head = sorec stk (sorec stk subst a1 a2) p1 p2 in
-	  List.fold_left chk_branch chk_head br1
-
-      |	PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst
-      |	PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst
-      | _ -> raise PatternMatchingFailure
-
-  in
-  let names,terms = sorec [] ([],[]) pat c in
-  (names,Sort.list (fun (a,_) (b,_) -> a<b) terms)
-
-let matches_core_closed convert allow_partial_app pat c =
-  let names,subst = matches_core convert allow_partial_app false pat c in
-  (names, List.map (fun (a,(_,b)) -> (a,b)) subst)
-
-let extended_matches = matches_core None true true
-
-let matches c p = snd (matches_core_closed None true c p)
-
-let special_meta = (-1)
-
-(* Tells if it is an authorized occurrence and if the instance is closed *)
-let authorized_occ partial_app closed pat c mk_ctx next =
-  try
-    let sigma = matches_core_closed None partial_app pat c in
-    if closed && not (List.for_all (fun (_,c) -> closed0 c) (snd sigma))
-    then next ()
-    else sigma, mk_ctx (mkMeta special_meta), next
-  with
-    PatternMatchingFailure -> next ()
-
-(* Tries to match a subterm of [c] with [pat] *)
-let sub_match ?(partial_app=false) ?(closed=true) pat c =
-  let rec aux c mk_ctx next =
-  match kind_of_term c with
-  | Cast (c1,k,c2) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx lc = mk_ctx (mkCast (List.hd lc, k,c2)) in
-        try_aux [c1] mk_ctx next)
-  | Lambda (x,c1,c2) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx lc = mk_ctx (mkLambda (x,List.hd lc,List.nth lc 1)) in
-        try_aux [c1;c2] mk_ctx next)
-  | Prod (x,c1,c2) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx lc = mk_ctx (mkProd (x,List.hd lc,List.nth lc 1)) in
-        try_aux [c1;c2] mk_ctx next)
-  | LetIn (x,c1,t,c2) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx = function [c1;c2] -> mkLetIn (x,c1,t,c2) | _ -> assert false
-        in try_aux [c1;c2] mk_ctx next)
-  | App (c1,lc) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let topdown = true in
-	if partial_app then
-          if topdown then
-            let lc1 = Array.sub lc 0 (Array.length lc - 1) in
-            let app = mkApp (c1,lc1) in
-            let mk_ctx = function
-              | [app';c] -> mk_ctx (mkApp (app',[|c|]))
-              | _ -> assert false in
-	    try_aux [app;array_last lc] mk_ctx next
-          else
-            let rec aux2 app args next =
-              match args with
-              | [] ->
-                  let mk_ctx le =
-                    mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
-	          try_aux (c1::Array.to_list lc) mk_ctx next
-	      | arg :: args ->
-                  let app = mkApp (app,[|arg|]) in
-                  let next () = aux2 app args next in
-                  let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in
-                  aux app mk_ctx next in
-            aux2 c1 (Array.to_list lc) next
-        else
-          let mk_ctx le =
-            mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
-	  try_aux (c1::Array.to_list lc) mk_ctx next)
-  | Case (ci,hd,c1,lc) ->
-      authorized_occ partial_app closed pat c mk_ctx (fun () ->
-        let mk_ctx le =
-          mk_ctx (mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) in
-        try_aux (c1::Array.to_list lc) mk_ctx next)
-  | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _
-  | Rel _|Meta _|Var _|Sort _ ->
-      authorized_occ partial_app closed pat c mk_ctx next
-
-  (* Tries [sub_match] for all terms in the list *)
-  and try_aux lc mk_ctx next =
-    let rec try_sub_match_rec lacc = function
-      | [] -> next ()
-      | c::tl ->
-          let mk_ctx ce = mk_ctx (List.rev_append lacc (ce::tl)) in
-          let next () = try_sub_match_rec (c::lacc) tl in
-          aux c mk_ctx next in
-    try_sub_match_rec [] lc in
-  aux c (fun x -> x) (fun () -> raise PatternMatchingFailure)
-
-type subterm_matching_result =
-    (bound_ident_map * patvar_map) * constr * (unit -> subterm_matching_result)
-
-let match_subterm pat c = sub_match pat c
-
-let match_appsubterm pat c = sub_match ~partial_app:true pat c
-
-let match_subterm_gen app pat c = sub_match ~partial_app:app pat c
-
-let is_matching pat c =
-  try let _ = matches pat c in true
-  with PatternMatchingFailure -> false
-
-let is_matching_appsubterm ?(closed=true) pat c =
-  try let _ = sub_match ~partial_app:true ~closed pat c in true
-  with PatternMatchingFailure -> false
-
-let matches_conv env sigma c p =
-  snd (matches_core_closed (Some (env,sigma)) false c p)
-
-let is_matching_conv env sigma pat n =
-  try let _ = matches_conv env sigma pat n in true
-  with PatternMatchingFailure -> false
-
diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
new file mode 100644
index 00000000..a2c97d2c
--- /dev/null
+++ b/pretyping/miscops.ml
@@ -0,0 +1,60 @@
+(************************************************************************)
+(*  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 Util
+open Misctypes
+open Genredexpr
+
+(** Mapping [cast_type] *)
+
+let map_cast_type f = function
+  | CastConv a -> CastConv (f a)
+  | CastVM a -> CastVM (f a)
+  | CastCoerce -> CastCoerce
+  | CastNative a -> CastNative (f a)
+
+let smartmap_cast_type f c =
+  match c with
+    | CastConv a -> let a' = f a in if a' == a then c else CastConv a'
+    | CastVM a -> let a' = f a in if a' == a then c else CastVM a'
+    | CastCoerce -> CastCoerce
+    | CastNative a -> let a' = f a in if a' == a then c else CastNative a'
+
+(** Equalities on [glob_sort] *)
+
+let glob_sort_eq g1 g2 = match g1, g2 with
+| GProp, GProp -> true
+| GSet, GSet -> true
+| GType l1, GType l2 -> List.for_all2 CString.equal l1 l2
+| _ -> false
+
+let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
+| IntroAnonymous, IntroAnonymous -> true
+| IntroIdentifier id1, IntroIdentifier id2 -> Names.Id.equal id1 id2
+| IntroFresh id1, IntroFresh id2 -> Names.Id.equal id1 id2
+| _ -> false
+
+(** Mapping [red_expr_gen] *)
+
+let map_flags f flags =
+  { flags with rConst = List.map f flags.rConst }
+
+let map_occs f (occ,e) = (occ,f e)
+
+let map_red_expr_gen f g h = function
+  | Fold l -> Fold (List.map f l)
+  | Pattern occs_l -> Pattern (List.map (map_occs f) occs_l)
+  | Simpl (flags,occs_o) ->
+     Simpl (map_flags g flags, Option.map (map_occs (map_union g h)) occs_o)
+  | Unfold occs_l -> Unfold (List.map (map_occs g) occs_l)
+  | Cbv flags -> Cbv (map_flags g flags)
+  | Lazy flags -> Lazy (map_flags g flags)
+  | CbvVm occs_o -> CbvVm (Option.map (map_occs (map_union g h)) occs_o)
+  | CbvNative occs_o -> CbvNative (Option.map (map_occs (map_union g h)) occs_o)
+  | Cbn flags -> Cbn (map_flags g flags)
+  | ExtraRedExpr _ | Red _ | Hnf as x -> x
diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli
new file mode 100644
index 00000000..453648d4
--- /dev/null
+++ b/pretyping/miscops.mli
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*  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 Misctypes
+open Genredexpr
+
+(** Mapping [cast_type] *)
+
+val map_cast_type : ('a -> 'b) -> 'a cast_type -> 'b cast_type
+val smartmap_cast_type : ('a -> 'a) -> 'a cast_type -> 'a cast_type
+
+(** Equalities on [glob_sort] *)
+
+val glob_sort_eq : glob_sort -> glob_sort -> bool
+
+(** Equalities on [intro_pattern_naming] *)
+
+val intro_pattern_naming_eq :
+  intro_pattern_naming_expr -> intro_pattern_naming_expr -> bool
+
+(** Mapping [red_expr_gen] *)
+
+val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) ->
+  ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
index 76b9bd8a..5aca11ae 100644
--- a/pretyping/namegen.ml
+++ b/pretyping/namegen.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        *)
@@ -15,25 +15,42 @@
 open Util
 open Names
 open Term
+open Vars
 open Nametab
 open Nameops
 open Libnames
+open Globnames
 open Environ
 open Termops
 
 (**********************************************************************)
+(* Conventional names *)
+
+let default_prop_string = "H"
+let default_prop_ident = Id.of_string default_prop_string
+
+let default_small_string = "H"
+let default_small_ident = Id.of_string default_small_string
+
+let default_type_string = "X"
+let default_type_ident = Id.of_string default_type_string
+
+let default_non_dependent_string = "H"
+let default_non_dependent_ident = Id.of_string default_non_dependent_string
+
+let default_dependent_ident = Id.of_string "x"
+
+(**********************************************************************)
 (* Globality of identifiers *)
 
-let rec is_imported_modpath mp =
-  let current_mp,_ = Lib.current_prefix() in
-    match mp with
-      | MPfile dp ->
-	  let rec find_prefix = function
-	    |MPfile dp1 -> not (dp1=dp)
-	    |MPdot(mp,_) -> find_prefix mp
-	    |MPbound(_) -> false
-	  in find_prefix current_mp
-      | p -> false
+let is_imported_modpath = function
+  | MPfile dp ->
+    let rec find_prefix = function
+      |MPfile dp1 -> not (DirPath.equal dp1 dp)
+      |MPdot(mp,_) -> find_prefix mp
+      |MPbound(_) -> false
+    in find_prefix (Lib.current_mp ())
+  | _ -> false
 
 let is_imported_ref = function
   | VarRef _ -> false
@@ -61,8 +78,22 @@ let is_constructor id =
 (**********************************************************************)
 (* Generating "intuitive" names from its type *)
 
+let head_name c = (* Find the head constant of a constr if any *)
+  let rec hdrec c =
+    match kind_of_term c with
+    | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c)
+    | Cast (c,_,_) | App (c,_) -> hdrec c
+    | Proj (kn,_) -> Some (Label.to_id (con_label (Projection.constant kn)))
+    | Const _ | Ind _ | Construct _ | Var _ ->
+	Some (basename_of_global (global_of_constr c))
+    | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
+	Some (match lna.(i) with Name id -> id | _ -> assert false)
+    | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) -> None
+  in
+  hdrec c
+
 let lowercase_first_char id = (* First character of a constr *)
-  lowercase_first_char_utf8 (string_of_id id)
+  Unicode.lowercase_first_char (Id.to_string id)
 
 let sort_hdchar = function
   | Prop(_) -> "P"
@@ -71,14 +102,12 @@ let sort_hdchar = function
 let hdchar env c =
   let rec hdrec k c =
     match kind_of_term c with
-    | Prod (_,_,c)    -> hdrec (k+1) c
-    | Lambda (_,_,c)  -> hdrec (k+1) c
-    | LetIn (_,_,_,c) -> hdrec (k+1) c
-    | Cast (c,_,_)    -> hdrec k c
-    | App (f,l)       -> hdrec k f
-    | Const kn -> lowercase_first_char (id_of_label (con_label kn))
-    | Ind x -> lowercase_first_char (basename_of_global (IndRef x))
-    | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x))
+    | Prod (_,_,c) | Lambda (_,_,c) | LetIn (_,_,_,c) -> hdrec (k+1) c
+    | Cast (c,_,_) | App (c,_) -> hdrec k c
+    | Proj (kn,_) -> lowercase_first_char (Label.to_id (con_label (Projection.constant kn)))
+    | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn))
+    | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x))
+    | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x))
     | Var id  -> lowercase_first_char id
     | Sort s -> sort_hdchar s
     | Rel n ->
@@ -88,22 +117,20 @@ let hdchar env c =
 	     | (Name id,_,_)   -> lowercase_first_char id
 	     | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
 	   with Not_found -> "y")
-    | Fix ((_,i),(lna,_,_)) ->
-	let id = match lna.(i) with Name id -> id | _ -> assert false in
-	lowercase_first_char id
-    | CoFix (i,(lna,_,_)) ->
+    | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
 	let id = match lna.(i) with Name id -> id | _ -> assert false in
 	lowercase_first_char id
-    | Meta _|Evar _|Case (_, _, _, _) -> "y"
+    | Evar _ (* We could do better... *)
+    | Meta _ | Case (_, _, _, _) -> "y"
   in
   hdrec 0 c
 
 let id_of_name_using_hdchar env a = function
-  | Anonymous -> id_of_string (hdchar env a)
+  | Anonymous -> Id.of_string (hdchar env a)
   | Name id   -> id
 
 let named_hd env a = function
-  | Anonymous -> Name (id_of_string (hdchar env a))
+  | Anonymous -> Name (Id.of_string (hdchar env a))
   | x         -> x
 
 let mkProd_name   env (n,a,b) = mkProd (named_hd env a n, a, b)
@@ -138,8 +165,6 @@ let it_mkLambda_or_LetIn_name env b hyps =
 (**********************************************************************)
 (* Fresh names *)
 
-let default_x = id_of_string "x"
-
 (* Looks for next "good" name by lifting subscript *)
 
 let next_ident_away_from id bad =
@@ -151,17 +176,46 @@ let next_ident_away_from id bad =
 
 let restart_subscript id =
   if not (has_subscript id) then id else
-    (* Ce serait sans doute mieux avec quelque chose inspiré de
-     *** make_ident id (Some 0) *** mais ça brise la compatibilité... *)
+    (* It would probably be better with something in the spirit of
+     *** make_ident id (Some 0) *** but compatibility would be lost... *)
     forget_subscript id
 
+let rec to_avoid id = function
+| [] -> false
+| id' :: avoid -> Id.equal id id' || to_avoid id avoid
+
+let occur_rel p env id =
+  try
+    let name = lookup_name_of_rel p env in
+    begin match name with
+    | Name id' -> Id.equal id' id
+    | Anonymous -> false
+    end
+  with Not_found -> false (* Unbound indice : may happen in debug *)
+
+let visibly_occur_id id (nenv,c) =
+  let rec occur n c = match kind_of_term c with
+    | Const _ | Ind _ | Construct _ | Var _
+      when
+        let short = shortest_qualid_of_global Id.Set.empty (global_of_constr c) in
+        qualid_eq short (qualid_of_ident id) ->
+      raise Occur
+    | Rel p when p>n && occur_rel (p-n) nenv id -> raise Occur
+    | _ -> iter_constr_with_binders succ occur n c
+  in
+  try occur 1 c; false
+  with Occur -> true
+    | Not_found -> false (* Happens when a global is not in the env *)
+
 (* Now, there are different renaming strategies... *)
 
 (* 1- Looks for a fresh name for printing in cases pattern *)
 
-let next_name_away_in_cases_pattern na avoid =
-  let id = match na with Name id -> id | Anonymous -> default_x in
-  next_ident_away_from id (fun id -> List.mem id avoid or is_constructor id)
+let next_name_away_in_cases_pattern env_t na avoid =
+  let id = match na with Name id -> id | Anonymous -> default_dependent_ident in
+  let bad id = to_avoid id avoid || is_constructor id
+                                 || visibly_occur_id id env_t in
+  next_ident_away_from id bad
 
 (* 2- Looks for a fresh name for introduction in goal *)
 
@@ -173,12 +227,14 @@ let next_name_away_in_cases_pattern na avoid =
      name is taken by finding a free subscript starting from 0 *)
 
 let next_ident_away_in_goal id avoid =
-  let id = if List.mem id avoid then restart_subscript id else id in
-  let bad id = List.mem id avoid || (is_global id & not (is_section_variable id)) in
+  let id = if to_avoid id avoid then restart_subscript id else id in
+  let bad id = to_avoid id avoid || (is_global id && not (is_section_variable id)) in
   next_ident_away_from id bad
 
 let next_name_away_in_goal na avoid =
-  let id = match na with Name id -> id | Anonymous -> id_of_string "H" in
+  let id = match na with
+    | Name id -> id
+    | Anonymous -> default_non_dependent_ident in
   next_ident_away_in_goal id avoid
 
 (* 3- Looks for next fresh name outside a list that is moreover valid
@@ -189,20 +245,20 @@ let next_name_away_in_goal na avoid =
    beyond the current subscript *)
 
 let next_global_ident_away id avoid =
-  let id = if List.mem id avoid then restart_subscript id else id in
-  let bad id = List.mem id avoid || is_global id in
+  let id = if to_avoid id avoid then restart_subscript id else id in
+  let bad id = to_avoid id avoid || is_global id in
   next_ident_away_from id bad
 
 (* 4- Looks for next fresh name outside a list; if name already used,
    looks for same name with lower available subscript *)
 
 let next_ident_away id avoid =
-  if List.mem id avoid then
-    next_ident_away_from (restart_subscript id) (fun id -> List.mem id avoid)
+  if to_avoid id avoid then
+    next_ident_away_from (restart_subscript id) (fun id -> to_avoid id avoid)
   else id
 
 let next_name_away_with_default default na avoid =
-  let id = match na with Name id -> id | Anonymous -> id_of_string default in
+  let id = match na with Name id -> id | Anonymous -> Id.of_string default in
   next_ident_away id avoid
 
 let reserved_type_name = ref (fun t -> Anonymous)
@@ -213,10 +269,10 @@ let next_name_away_with_default_using_types default na avoid t =
     | Name id -> id
     | Anonymous -> match !reserved_type_name t with
 	| Name id -> id
-	| Anonymous -> id_of_string default in
+	| Anonymous -> Id.of_string default in
   next_ident_away id avoid
 
-let next_name_away = next_name_away_with_default "H"
+let next_name_away = next_name_away_with_default default_non_dependent_string
 
 let make_all_name_different env =
   let avoid = ref (ids_of_named_context (named_context env)) in
@@ -232,24 +288,8 @@ let make_all_name_different env =
    looks for name of same base with lower available subscript beyond current
    subscript *)
 
-let occur_rel p env id =
-  try lookup_name_of_rel p env = Name id
-  with Not_found -> false (* Unbound indice : may happen in debug *)
-
-let visibly_occur_id id (nenv,c) =
-  let rec occur n c = match kind_of_term c with
-    | Const _ | Ind _ | Construct _ | Var _
-	  when shortest_qualid_of_global Idset.empty (global_of_constr c)
-	    = qualid_of_ident id -> raise Occur
-    | Rel p when p>n & occur_rel (p-n) nenv id -> raise Occur
-    | _ -> iter_constr_with_binders succ occur n c
-  in
-  try occur 1 c; false
-  with Occur -> true
-    | Not_found -> false (* Happens when a global is not in the env *)
-
 let next_ident_away_for_default_printing env_t id avoid =
-  let bad id = List.mem id avoid or visibly_occur_id id env_t in
+  let bad id = to_avoid id avoid || visibly_occur_id id env_t in
   next_ident_away_from id bad
 
 let next_name_away_for_default_printing env_t na avoid =
@@ -259,7 +299,7 @@ let next_name_away_for_default_printing env_t na avoid =
       (* In principle, an anonymous name is not dependent and will not be *)
       (* taken into account by the function compute_displayed_name_in; *)
       (* just in case, invent a valid name *)
-      id_of_string "H" in
+      default_non_dependent_ident in
   next_ident_away_for_default_printing env_t id avoid
 
 (**********************************************************************)
@@ -281,29 +321,31 @@ let next_name_away_for_default_printing env_t na avoid =
 *)
 
 type renaming_flags =
-  | RenamingForCasesPattern
+  | RenamingForCasesPattern of (Name.t list * constr)
   | RenamingForGoal
-  | RenamingElsewhereFor of (name list * constr)
+  | RenamingElsewhereFor of (Name.t list * constr)
 
 let next_name_for_display flags =
   match flags with
-  | RenamingForCasesPattern -> next_name_away_in_cases_pattern
+  | RenamingForCasesPattern env_t -> next_name_away_in_cases_pattern env_t
   | RenamingForGoal -> next_name_away_in_goal
   | RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t
 
 (* Remark: Anonymous var may be dependent in Evar's contexts *)
 let compute_displayed_name_in flags avoid na c =
-  if na = Anonymous & noccurn 1 c then
+  match na with
+  | Anonymous when noccurn 1 c ->
     (Anonymous,avoid)
-  else
+  | _ ->
     let fresh_id = next_name_for_display flags na avoid in
     let idopt = if noccurn 1 c then Anonymous else Name fresh_id in
     (idopt, fresh_id::avoid)
 
 let compute_and_force_displayed_name_in flags avoid na c =
-  if na = Anonymous & noccurn 1 c then
+  match na with
+  | Anonymous when noccurn 1 c ->
     (Anonymous,avoid)
-  else
+  | _ ->
     let fresh_id = next_name_for_display flags na avoid in
     (Name fresh_id, fresh_id::avoid)
 
@@ -311,7 +353,7 @@ let compute_displayed_let_name_in flags avoid na c =
   let fresh_id = next_name_for_display flags na avoid in
   (Name fresh_id, fresh_id::avoid)
 
-let rec rename_bound_vars_as_displayed avoid env c =
+let rename_bound_vars_as_displayed avoid env c =
   let rec rename avoid env c =
     match kind_of_term c with
     | Prod (na,c1,c2)  ->
@@ -328,3 +370,25 @@ let rec rename_bound_vars_as_displayed avoid env c =
     | _ -> c
   in
   rename avoid env c
+
+(**********************************************************************)
+(* "H"-based naming strategy introduced June 2014 for hypotheses in
+   Prop produced by case/elim/destruct/induction, in place of the
+   strategy that was using the first letter of the type, leading to
+   inelegant "n:~A", "e:t=u", etc. when eliminating sumbool or similar
+   types *)
+
+let h_based_elimination_names = ref false
+
+let use_h_based_elimination_names () =
+  !h_based_elimination_names && Flags.version_strictly_greater Flags.V8_4
+
+open Goptions
+
+let _ = declare_bool_option
+	  { optsync  = true;
+            optdepr  = false;
+	    optname  = "use of \"H\"-based proposition names in elimination tactics";
+	    optkey   = ["Standard";"Proposition";"Elimination";"Names"];
+	    optread  = (fun () -> !h_based_elimination_names);
+	    optwrite = (:=) h_based_elimination_names }
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
index db078026..f66bc6d8 100644
--- a/pretyping/namegen.mli
+++ b/pretyping/namegen.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,23 +8,34 @@
 
 open Names
 open Term
+open Context
 open Environ
 
 (*********************************************************************
+   Conventional default names *)
+
+val default_prop_ident : Id.t          (* "H" *)
+val default_small_ident : Id.t         (* "H" *)
+val default_type_ident : Id.t          (* "X" *)
+val default_non_dependent_ident : Id.t (* "H" *)
+val default_dependent_ident : Id.t     (* "x" *)
+
+(*********************************************************************
    Generating "intuitive" names from their type *)
 
-val lowercase_first_char : identifier -> string
+val lowercase_first_char : Id.t -> string
 val sort_hdchar : sorts -> string
 val hdchar : env -> types -> string
-val id_of_name_using_hdchar : env -> types -> name -> identifier
-val named_hd : env -> types -> name -> name
+val id_of_name_using_hdchar : env -> types -> Name.t -> Id.t
+val named_hd : env -> types -> Name.t -> Name.t
+val head_name : types -> Id.t option
 
-val mkProd_name : env -> name * types * types -> types
-val mkLambda_name : env -> name * types * constr -> constr
+val mkProd_name : env -> Name.t * types * types -> types
+val mkLambda_name : env -> Name.t * types * constr -> constr
 
 (** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
-val prod_name : env -> name * types * types -> types
-val lambda_name : env -> name * types * constr -> constr
+val prod_name : env -> Name.t * types * types -> types
+val lambda_name : env -> Name.t * types * constr -> constr
 
 val prod_create : env -> types * types -> constr
 val lambda_create : env -> types * constr -> constr
@@ -40,45 +51,52 @@ val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr
    Fresh names *)
 
 (** Avoid clashing with a name satisfying some predicate *)
-val next_ident_away_from : identifier -> (identifier -> bool) -> identifier
+val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t
 
 (** Avoid clashing with a name of the given list *)
-val next_ident_away : identifier -> identifier list -> identifier
+val next_ident_away : Id.t -> Id.t list -> Id.t
 
 (** Avoid clashing with a name already used in current module *)
-val next_ident_away_in_goal : identifier -> identifier list -> identifier
+val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t
 
 (** Avoid clashing with a name already used in current module 
    but tolerate overwriting section variables, as in goals *)
-val next_global_ident_away : identifier -> identifier list -> identifier
+val next_global_ident_away : Id.t -> Id.t list -> Id.t
 
 (** Avoid clashing with a constructor name already used in current module *)
-val next_name_away_in_cases_pattern : name -> identifier list -> identifier
+val next_name_away_in_cases_pattern : (Termops.names_context * constr) -> Name.t -> Id.t list -> Id.t
 
-val next_name_away  : name -> identifier list -> identifier (** default is "H" *)
-val next_name_away_with_default : string -> name -> identifier list ->
-  identifier
+(** Default is [default_non_dependent_ident] *)
+val next_name_away  : Name.t -> Id.t list -> Id.t
 
-val next_name_away_with_default_using_types : string -> name ->
-  identifier list -> types -> identifier
+val next_name_away_with_default : string -> Name.t -> Id.t list ->
+  Id.t
 
-val set_reserved_typed_name : (types -> name) -> unit
+val next_name_away_with_default_using_types : string -> Name.t ->
+  Id.t list -> types -> Id.t
+
+val set_reserved_typed_name : (types -> Name.t) -> unit
 
 (*********************************************************************
    Making name distinct for displaying *)
 
 type renaming_flags =
-  | RenamingForCasesPattern (** avoid only global constructors *)
+  | RenamingForCasesPattern of (Name.t list * constr) (** avoid only global constructors *)
   | RenamingForGoal (** avoid all globals (as in intro) *)
-  | RenamingElsewhereFor of (name list * constr)
+  | RenamingElsewhereFor of (Name.t list * constr)
 
 val make_all_name_different : env -> env
 
 val compute_displayed_name_in :
-  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+  renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
 val compute_and_force_displayed_name_in :
-  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+  renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
 val compute_displayed_let_name_in :
-  renaming_flags -> identifier list -> name -> constr -> name * identifier list
+  renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
 val rename_bound_vars_as_displayed :
-  identifier list -> name list -> types -> types
+  Id.t list -> Name.t list -> types -> types
+
+(**********************************************************************)
+(* Naming strategy for arguments in Prop when eliminating inductive types *)
+
+val use_h_based_elimination_names : unit -> bool
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
new file mode 100644
index 00000000..bd427ecd
--- /dev/null
+++ b/pretyping/nativenorm.ml
@@ -0,0 +1,404 @@
+(************************************************************************)
+(*  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 Pp
+open Errors
+open Term
+open Vars
+open Environ
+open Reduction
+open Univ
+open Declarations
+open Names
+open Inductive
+open Util
+open Nativecode
+open Nativevalues
+open Nativelambda
+
+(** This module implements normalization by evaluation to OCaml code *)
+
+let evars_of_evar_map evd =
+  { evars_val = Evd.existential_opt_value evd;
+    evars_typ = Evd.existential_type evd;
+    evars_metas = Evd.meta_type evd }
+
+exception Find_at of int
+
+let invert_tag cst tag reloc_tbl =
+  try
+    for j = 0 to Array.length reloc_tbl - 1 do
+      let tagj,arity = reloc_tbl.(j) in
+      if Int.equal tag tagj && (cst && Int.equal arity 0 || not(cst || Int.equal arity 0)) then
+	raise (Find_at j)
+      else ()
+    done;raise Not_found
+  with Find_at j -> (j+1)
+
+let decompose_prod env t =
+  let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
+  match name with
+  | Anonymous -> (Name (id_of_string "x"),dom,codom)
+  | _ -> res
+
+let app_type env c =
+  let t = whd_betadeltaiota env c in
+  try destApp t with DestKO -> (t,[||])
+
+ 
+let find_rectype_a env c =
+  let (t, l) = app_type env c in
+  match kind_of_term t with
+  | Ind ind -> (ind, l)
+  | _ -> raise Not_found
+
+(* Instantiate inductives and parameters in constructor type *)
+
+let type_constructor mind mib typ params = 
+  let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in
+  let ctyp = substl s typ in
+  let nparams = Array.length params in
+  if Int.equal nparams 0 then ctyp
+  else
+    let _,ctyp = decompose_prod_n nparams ctyp in   
+    substl (List.rev (Array.to_list params)) ctyp
+
+let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs =
+  let mib,mip = lookup_mind_specif env ind in
+  let nparams = mib.mind_nparams in
+  let params = Array.sub allargs 0 nparams in
+  try
+    if const then
+      let ctyp = type_constructor mind mib (mip.mind_nf_lc.(0)) params in
+      retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag, ctyp
+    else
+      raise Not_found
+  with Not_found ->
+  let i = invert_tag const tag mip.mind_reloc_tbl in
+  let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
+  (mkApp(mkConstructU((ind,i),u), params), ctyp)
+ 
+
+let construct_of_constr const env tag typ =
+  let t, l = app_type env typ in
+  match kind_of_term t with
+  | Ind (ind,u) -> 
+      construct_of_constr_notnative const env tag ind u l
+  | _ -> assert false
+
+let construct_of_constr_const env tag typ = 
+  fst (construct_of_constr true env tag typ)
+
+let construct_of_constr_block = construct_of_constr false
+
+let build_branches_type env (mind,_ as _ind) mib mip params dep p =
+  let rtbl = mip.mind_reloc_tbl in
+  (* [build_one_branch i cty] construit le type de la ieme branche (commence
+     a 0) et les lambda correspondant aux realargs *)
+  let build_one_branch i cty =
+    let typi = type_constructor mind mib cty params in
+    let decl,indapp = Reductionops.splay_prod env Evd.empty typi in
+    let decl_with_letin,_ = decompose_prod_assum typi in
+    let ind,cargs = find_rectype_a env indapp in
+    let nparams = Array.length params in
+    let carity = snd (rtbl.(i)) in
+    let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
+    let codom =
+      let ndecl = List.length decl in
+      let papp = mkApp(lift ndecl p,crealargs) in
+      if dep then
+	let cstr = ith_constructor_of_inductive (fst ind) (i+1) in
+        let relargs = Array.init carity (fun i -> mkRel (carity-i)) in
+	let params = Array.map (lift ndecl) params in
+	let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in
+	mkApp(papp,[|dep_cstr|])
+      else papp
+    in 
+    decl, decl_with_letin, codom
+  in Array.mapi build_one_branch mip.mind_nf_lc
+
+let build_case_type dep p realargs c = 
+  if dep then mkApp(mkApp(p, realargs), [|c|])
+  else mkApp(p, realargs)
+
+(* TODO move this function *)
+let type_of_rel env n = 
+  let (_,_,ty) = lookup_rel n env in
+  lift n ty
+
+let type_of_prop = mkSort type1_sort
+
+let type_of_sort s = 
+  match s with
+  | Prop _ -> type_of_prop
+  | Type u -> mkType (Univ.super u)
+
+let type_of_var env id = 
+  try let (_,_,ty) = lookup_named id env in ty
+  with Not_found ->
+    anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
+
+let sort_of_product env domsort rangsort =
+  match (domsort, rangsort) with
+    (* Product rule (s,Prop,Prop) *)
+    | (_,       Prop Null)  -> rangsort
+    (* Product rule (Prop/Set,Set,Set) *)
+    | (Prop _,  Prop Pos) -> rangsort
+    (* Product rule (Type,Set,?) *)
+    | (Type u1, Prop Pos) ->
+        begin match engagement env with
+        | Some ImpredicativeSet ->
+          (* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
+          rangsort
+        | _ ->
+          (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
+          Type (sup u1 type0_univ)
+        end
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Pos,  Type u2)  -> Type (sup type0_univ u2)
+    (* Product rule (Prop,Type_i,Type_i) *)
+    | (Prop Null, Type _)  -> rangsort
+    (* Product rule (Type_i,Type_i,Type_i) *)
+    | (Type u1, Type u2) -> Type (sup u1 u2)
+
+(* normalisation of values *)
+
+let branch_of_switch lvl ans bs = 
+  let tbl = ans.asw_reloc in
+  let branch i = 
+    let tag,arity = tbl.(i) in
+    let ci = 
+      if Int.equal arity 0 then mk_const tag
+      else mk_block tag (mk_rels_accu lvl arity) in
+    bs ci in
+  Array.init (Array.length tbl) branch
+
+let rec nf_val env v typ =
+  match kind_of_value v with
+  | Vaccu accu -> nf_accu env accu
+  | Vfun f -> 
+      let lvl = nb_rel env in
+      let name,dom,codom = 
+	try decompose_prod env typ
+	with DestKO ->
+          Errors.anomaly
+            (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
+      in
+      let env = push_rel (name,None,dom) env in
+      let body = nf_val env (f (mk_rel_accu lvl)) codom in
+      mkLambda(name,dom,body)
+  | Vconst n -> construct_of_constr_const env n typ
+  | Vblock b ->
+      let capp,ctyp = construct_of_constr_block env (block_tag b) typ in
+      let args = nf_bargs env b ctyp in
+      mkApp(capp,args)
+
+and nf_type env v =
+  match kind_of_value v with
+  | Vaccu accu -> nf_accu env accu
+  | _ -> assert false
+
+and nf_type_sort env v =
+  match kind_of_value v with
+  | Vaccu accu -> 
+      let t,s = nf_accu_type env accu in
+      let s = try destSort s with DestKO -> assert false in
+      t, s
+  | _ -> assert false
+
+and nf_accu env accu =
+  let atom = atom_of_accu accu in
+  if Int.equal (accu_nargs accu) 0 then nf_atom env atom
+  else
+    let a,typ = nf_atom_type env atom in
+    let _, args = nf_args env accu typ in
+    mkApp(a,Array.of_list args)
+
+and nf_accu_type env accu =
+  let atom = atom_of_accu accu in
+  if Int.equal (accu_nargs accu) 0 then nf_atom_type env atom
+  else
+    let a,typ = nf_atom_type env atom in
+    let t, args = nf_args env accu typ in
+    mkApp(a,Array.of_list args), t
+
+and nf_args env accu t =
+  let aux arg (t,l) = 
+    let _,dom,codom =
+      try decompose_prod env t with
+	DestKO ->
+	Errors.anomaly
+	  (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
+    in
+    let c = nf_val env arg dom in
+    (subst1 c codom, c::l)
+  in
+  let t,l = List.fold_right aux (args_of_accu accu) (t,[]) in
+  t, List.rev l
+
+and nf_bargs env b t =
+  let t = ref t in
+  let len = block_size b in
+  Array.init len
+    (fun i ->
+      let _,dom,codom =
+	try decompose_prod env !t with
+	  DestKO ->
+	  Errors.anomaly
+	    (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
+      in
+      let c = nf_val env (block_field b i) dom in
+      t := subst1 c codom; c)
+
+and nf_atom env atom =
+  match atom with
+  | Arel i -> mkRel (nb_rel env - i)
+  | Aconstant cst -> mkConstU cst
+  | Aind ind -> mkIndU ind
+  | Asort s -> mkSort s
+  | Avar id -> mkVar id
+  | Aprod(n,dom,codom) ->
+      let dom = nf_type env dom in
+      let vn = mk_rel_accu (nb_rel env) in
+      let env = push_rel (n,None,dom) env in
+      let codom = nf_type env (codom vn) in
+      mkProd(n,dom,codom)
+  | Ameta (mv,_) -> mkMeta mv
+  | Aevar (ev,_) -> mkEvar ev
+  | Aproj(p,c) ->
+      let c = nf_accu env c in
+	mkProj(Projection.make p false,c)
+  | _ -> fst (nf_atom_type env atom)
+
+and nf_atom_type env atom =
+  match atom with
+  | Arel i ->
+      let n = (nb_rel env - i) in
+      mkRel n, type_of_rel env n
+  | Aconstant cst ->
+      mkConstU cst, Typeops.type_of_constant_in env cst
+  | Aind ind ->
+      mkIndU ind, Inductiveops.type_of_inductive env ind
+  | Asort s ->
+      mkSort s, type_of_sort s
+  | Avar id ->
+      mkVar id, type_of_var env id
+  | Acase(ans,accu,p,bs) ->
+      let a,ta = nf_accu_type env accu in
+      let ((mind,_),u as ind),allargs = find_rectype_a env ta in
+      let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in
+      let nparams = mib.mind_nparams in
+      let params,realargs = Array.chop nparams allargs in
+      let pT = 
+	hnf_prod_applist env 
+	  (Inductiveops.type_of_inductive env ind) (Array.to_list params) in
+      let pT = whd_betadeltaiota env pT in
+      let dep, p = nf_predicate env ind mip params p pT in
+      (* Calcul du type des branches *)
+      let btypes = build_branches_type env (fst ind) mib mip params dep p in
+      (* calcul des branches *)
+      let bsw = branch_of_switch (nb_rel env) ans bs in
+      let mkbranch i v =
+       let decl,decl_with_letin,codom = btypes.(i) in
+       let b = nf_val (Termops.push_rels_assum decl env) v codom in
+        Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin
+      in 
+      let branchs = Array.mapi mkbranch bsw in
+      let tcase = build_case_type dep p realargs a in
+      let ci = ans.asw_ci in
+      mkCase(ci, p, a, branchs), tcase 
+  | Afix(tt,ft,rp,s) ->
+      let tt = Array.map (fun t -> nf_type env t) tt in
+      let name = Array.map (fun _ -> (Name (id_of_string "Ffix"))) tt in
+      let lvl = nb_rel env in
+      let nbfix = Array.length ft in
+      let fargs = mk_rels_accu lvl (Array.length ft) in
+      (* Third argument of the tuple is ignored by push_rec_types *)
+      let env = push_rec_types (name,tt,[||]) env in
+      (* We lift here because the types of arguments (in tt) will be evaluated
+         in an environment where the fixpoints have been pushed *)
+      let norm_body i v = nf_val env (napply v fargs) (lift nbfix tt.(i)) in
+      let ft = Array.mapi norm_body ft in
+      mkFix((rp,s),(name,tt,ft)), tt.(s)
+  | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) ->
+      let tt = Array.map (nf_type env) tt in
+      let name = Array.map (fun _ -> (Name (id_of_string "Fcofix"))) tt in
+      let lvl = nb_rel env in
+      let fargs = mk_rels_accu lvl (Array.length ft) in
+      let env = push_rec_types (name,tt,[||]) env in
+      let ft = Array.mapi (fun i v -> nf_val env (napply v fargs) tt.(i)) ft in
+      mkCoFix(s,(name,tt,ft)), tt.(s)
+  | Aprod(n,dom,codom) ->
+      let dom,s1 = nf_type_sort env dom in
+      let vn = mk_rel_accu (nb_rel env) in
+      let env = push_rel (n,None,dom) env in
+      let codom,s2 = nf_type_sort env (codom vn) in
+      mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2)
+  | Aevar(ev,ty) ->
+     let ty = nf_type env ty in
+     mkEvar ev, ty
+  | Ameta(mv,ty) ->
+     let ty = nf_type env ty in
+     mkMeta mv, ty
+  | Aproj(p,c) ->
+      let c,tc = nf_accu_type env c in
+      let cj = make_judge c tc in
+      let uj = Typeops.judge_of_projection env (Projection.make p true) cj in
+      uj.uj_val, uj.uj_type
+
+
+and  nf_predicate env ind mip params v pT =
+  match kind_of_value v, kind_of_term pT with
+  | Vfun f, Prod _ ->
+      let k = nb_rel env in
+      let vb = f (mk_rel_accu k) in
+      let name,dom,codom =
+	try decompose_prod env pT with
+	  DestKO ->
+	  Errors.anomaly
+	    (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
+      in
+      let dep,body = 
+	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
+      dep, mkLambda(name,dom,body)
+  | Vfun f, _ -> 
+      let k = nb_rel env in
+      let vb = f (mk_rel_accu k) in
+      let name = Name (id_of_string "c") in
+      let n = mip.mind_nrealargs in
+      let rargs = Array.init n (fun i -> mkRel (n-i)) in
+      let params = if Int.equal n 0 then params else Array.map (lift n) params in
+      let dom = mkApp(mkIndU ind,Array.append params rargs) in
+      let body = nf_type (push_rel (name,None,dom) env) vb in
+      true, mkLambda(name,dom,body)
+  | _, _ -> false, nf_type env v
+
+let native_norm env sigma c ty =  
+  if !Flags.no_native_compiler then
+    error "Native_compute reduction has been disabled"
+  else
+  let penv = Environ.pre_env env in 
+  (*
+  Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1);
+  Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2);
+  *)
+  let ml_filename, prefix = Nativelib.get_ml_filename () in
+  let code, upd = mk_norm_code penv sigma prefix c in
+  match Nativelib.compile ml_filename code with
+    | true, fn ->
+        if !Flags.debug then Pp.msg_debug (Pp.str "Running norm ...");
+        let t0 = Sys.time () in
+        Nativelib.call_linker ~fatal:true prefix fn (Some upd);
+        let t1 = Sys.time () in
+        let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in
+        if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+        let res = nf_val env !Nativelib.rt1 ty in
+        let t2 = Sys.time () in
+        let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in
+        if !Flags.debug then Pp.msg_debug (Pp.str time_info);
+        res
+    | _ -> anomaly (Pp.str "Compilation failure") 
diff --git a/plugins/subtac/subtac_cases.mli b/pretyping/nativenorm.mli
index 5ef42b13..c854e8c9 100644
--- a/plugins/subtac/subtac_cases.mli
+++ b/pretyping/nativenorm.mli
@@ -1,21 +1,17 @@
 (************************************************************************)
 (*  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 Term
-open Evd
 open Environ
-open Inductiveops
-open Glob_term
-open Evarutil
-(*i*)
+open Evd
+open Nativelambda
+
+(** This module implements normalization by evaluation to OCaml code *)
+
+val evars_of_evar_map : evar_map -> evars
 
-(*s Compilation of pattern-matching, subtac style. *)
-module Cases_F(C : Coercion.S) : Cases.S
+val native_norm : env -> evars -> constr -> types -> constr
diff --git a/pretyping/pattern.ml b/pretyping/patternops.ml
index 553615c2..c49bec9a 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/patternops.ml
@@ -1,67 +1,97 @@
 (************************************************************************)
 (*  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 Libnames
+open Globnames
 open Nameops
 open Term
+open Vars
 open Glob_term
-open Environ
-open Nametab
+open Glob_ops
 open Pp
 open Mod_subst
+open Misctypes
+open Decl_kinds
+open Pattern
+open Evd
+open Environ
 
-(* Metavariables *)
+let case_info_pattern_eq i1 i2 =
+  i1.cip_style == i2.cip_style &&
+  Option.equal eq_ind i1.cip_ind i2.cip_ind &&
+  Option.equal (List.equal (==)) i1.cip_ind_tags i2.cip_ind_tags &&
+  i1.cip_extensible == i2.cip_extensible
 
-type constr_under_binders = identifier list * constr
+let rec constr_pattern_eq p1 p2 = match p1, p2 with
+| PRef r1, PRef r2 -> eq_gr r1 r2
+| PVar v1, PVar v2 -> Id.equal v1 v2
+| PEvar (ev1, ctx1), PEvar (ev2, ctx2) ->
+  Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2
+| PRel i1, PRel i2 ->
+  Int.equal i1 i2
+| PApp (t1, arg1), PApp (t2, arg2) ->
+  constr_pattern_eq t1 t2 && Array.equal constr_pattern_eq arg1 arg2
+| PSoApp (id1, arg1), PSoApp (id2, arg2) ->
+  Id.equal id1 id2 && List.equal constr_pattern_eq arg1 arg2
+| PLambda (v1, t1, b1), PLambda (v2, t2, b2) ->
+  Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
+| PProd (v1, t1, b1), PProd (v2, t2, b2) ->
+  Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
+| PLetIn (v1, t1, b1), PLetIn (v2, t2, b2) ->
+  Name.equal v1 v2 && constr_pattern_eq t1 t2 && constr_pattern_eq b1 b2
+| PSort s1, PSort s2 -> Miscops.glob_sort_eq s1 s2
+| PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2
+| PIf (t1, l1, r1), PIf (t2, l2, r2) ->
+  constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2
+| PCase (info1, p1, r1, l1), PCase (info2, p2, r2, l2) ->
+  case_info_pattern_eq info1 info2 &&
+  constr_pattern_eq p1 p2 &&
+  constr_pattern_eq r1 r2 &&
+  List.equal pattern_eq l1 l2
+| PFix f1, PFix f2 ->
+  fixpoint_eq f1 f2
+| PCoFix f1, PCoFix f2 ->
+  cofixpoint_eq f1 f2
+| _ -> false
+(** FIXME: fixpoint and cofixpoint should be relativized to pattern *)
 
-type patvar_map = (patvar * constr) list
-type extended_patvar_map = (patvar * constr_under_binders) list
+and pattern_eq (i1, j1, p1) (i2, j2, p2) =
+  Int.equal i1 i2 && List.equal (==) j1 j2 && constr_pattern_eq p1 p2
 
-(* Patterns *)
+and fixpoint_eq ((arg1, i1), r1) ((arg2, i2), r2) =
+  Int.equal i1 i2 &&
+  Array.equal Int.equal arg1 arg2 &&
+  rec_declaration_eq r1 r2
 
-type case_info_pattern =
-    { cip_style : case_style;
-      cip_ind : inductive option;
-      cip_ind_args : (int * int) option; (** number of params and args *)
-      cip_extensible : bool (** does this match end with _ => _ ? *) }
+and cofixpoint_eq (i1, r1) (i2, r2) =
+  Int.equal i1 i2 &&
+  rec_declaration_eq r1 r2
 
-type constr_pattern =
-  | PRef of global_reference
-  | PVar of identifier
-  | PEvar of existential_key * constr_pattern array
-  | PRel of int
-  | PApp of constr_pattern * constr_pattern array
-  | PSoApp of patvar * constr_pattern list
-  | PLambda of name * constr_pattern * constr_pattern
-  | PProd of name * constr_pattern * constr_pattern
-  | PLetIn of name * constr_pattern * constr_pattern
-  | PSort of glob_sort
-  | PMeta of patvar option
-  | PIf of constr_pattern * constr_pattern * constr_pattern
-  | PCase of case_info_pattern * constr_pattern * constr_pattern *
-      (int * int * constr_pattern) list (** constructor index, nb of args *)
-  | PFix of fixpoint
-  | PCoFix of cofixpoint
+and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) =
+  Array.equal Name.equal n1 n2 &&
+  Array.equal Term.eq_constr c1 c2 &&
+  Array.equal Term.eq_constr r1 r2
 
 let rec occur_meta_pattern = function
   | PApp (f,args) ->
-      (occur_meta_pattern f) or (array_exists occur_meta_pattern args)
-  | PLambda (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
-  | PProd (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
-  | PLetIn (na,t,c)  -> (occur_meta_pattern t) or (occur_meta_pattern c)
+      (occur_meta_pattern f) || (Array.exists occur_meta_pattern args)
+  | PProj (_,arg) -> occur_meta_pattern arg
+  | PLambda (na,t,c)  -> (occur_meta_pattern t) || (occur_meta_pattern c)
+  | PProd (na,t,c)  -> (occur_meta_pattern t) || (occur_meta_pattern c)
+  | PLetIn (na,t,c)  -> (occur_meta_pattern t) || (occur_meta_pattern c)
   | PIf (c,c1,c2)  ->
-      (occur_meta_pattern c) or
-      (occur_meta_pattern c1) or (occur_meta_pattern c2)
+      (occur_meta_pattern c) ||
+      (occur_meta_pattern c1) || (occur_meta_pattern c2)
   | PCase(_,p,c,br) ->
-      (occur_meta_pattern p) or
-      (occur_meta_pattern c) or
+      (occur_meta_pattern p) ||
+      (occur_meta_pattern c) ||
       (List.exists (fun (_,_,p) -> occur_meta_pattern p) br)
   | PMeta _ | PSoApp _ -> true
   | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false
@@ -77,72 +107,77 @@ let rec head_pattern_bound t =
     | PCase (_,p,c,br) -> head_pattern_bound c
     | PRef r         -> r
     | PVar id        -> VarRef id
+    | PProj (p,c)    -> ConstRef (Projection.constant p)
     | PEvar _ | PRel _ | PMeta _ | PSoApp _  | PSort _ | PFix _
 	-> raise BoundPattern
     (* Perhaps they were arguments, but we don't beta-reduce *)
     | PLambda _ -> raise BoundPattern
-    | PCoFix _ -> anomaly "head_pattern_bound: not a type"
+    | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type")
 
 let head_of_constr_reference c = match kind_of_term c with
-  | Const sp -> ConstRef sp
-  | Construct sp -> ConstructRef sp
-  | Ind sp -> IndRef sp
+  | Const (sp,_) -> ConstRef sp
+  | Construct (sp,_) -> ConstructRef sp
+  | Ind (sp,_) -> IndRef sp
   | Var id -> VarRef id
-  | _ -> anomaly "Not a rigid reference"
-
-open Evd
+  | _ -> anomaly (Pp.str "Not a rigid reference")
 
-let pattern_of_constr sigma t =
+let pattern_of_constr env sigma t =
   let ctx = ref [] in
-  let rec pattern_of_constr t =
+  let rec pattern_of_constr env t =
   match kind_of_term t with
     | Rel n  -> PRel n
-    | Meta n -> PMeta (Some (id_of_string ("META" ^ string_of_int n)))
+    | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n)))
     | Var id -> PVar id
-    | Sort (Prop c) -> PSort (GProp c)
-    | Sort (Type _) -> PSort (GType None)
-    | Cast (c,_,_)      -> pattern_of_constr c
-    | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
-    | Prod (na,c,b)   -> PProd (na,pattern_of_constr c,pattern_of_constr b)
-    | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b)
+    | Sort (Prop Null) -> PSort GProp
+    | Sort (Prop Pos) -> PSort GSet
+    | Sort (Type _) -> PSort (GType [])
+    | Cast (c,_,_)      -> pattern_of_constr env c
+    | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,
+				  pattern_of_constr (push_rel (na,Some c,t) env) b)
+    | Prod (na,c,b)   -> PProd (na,pattern_of_constr env c,
+				pattern_of_constr (push_rel (na, None, c) env) b)
+    | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c,
+				  pattern_of_constr (push_rel (na, None, c) env) b)
     | App (f,a) ->
-        (match 
+        (match
           match kind_of_term f with
             Evar (evk,args as ev) ->
               (match snd (Evd.evar_source evk sigma) with
-                  MatchingVar (true,id) ->
-                    ctx := (id,None,existential_type sigma ev)::!ctx;
+                  Evar_kinds.MatchingVar (true,id) ->
+                    ctx := (id,None,Evarutil.nf_evar sigma (existential_type sigma ev))::!ctx;
                     Some id
                 | _ -> None)
             | _ -> None
           with
-            | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a))
-            | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a))
-    | Const sp         -> PRef (ConstRef (constant_of_kn(canonical_con sp)))
-    | Ind sp        -> PRef (canonical_gr (IndRef sp))
-    | Construct sp -> PRef (canonical_gr (ConstructRef sp))
+            | Some n -> PSoApp (n,Array.to_list (Array.map (pattern_of_constr env) a))
+            | None -> PApp (pattern_of_constr env f,Array.map (pattern_of_constr env) a))
+    | Const (sp,u)  -> PRef (ConstRef (constant_of_kn(canonical_con sp)))
+    | Ind (sp,u)    -> PRef (canonical_gr (IndRef sp))
+    | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp))
+    | Proj (p, c) -> 
+      pattern_of_constr env (Retyping.expand_projection env sigma p c [])
     | Evar (evk,ctxt as ev) ->
         (match snd (Evd.evar_source evk sigma) with
-          | MatchingVar (b,id) ->
-              ctx := (id,None,existential_type sigma ev)::!ctx;
+          | Evar_kinds.MatchingVar (b,id) ->
+              ctx := (id,None,Evarutil.nf_evar sigma (existential_type sigma ev))::!ctx;
               assert (not b); PMeta (Some id)
-          | GoalEvar -> PEvar (evk,Array.map pattern_of_constr ctxt)
+          | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt)
           | _ -> PMeta None)
     | Case (ci,p,a,br) ->
         let cip =
 	  { cip_style = ci.ci_pp_info.style;
 	    cip_ind = Some ci.ci_ind;
-	    cip_ind_args = Some (ci.ci_npar, ci.ci_pp_info.ind_nargs);
+	    cip_ind_tags = Some ci.ci_pp_info.ind_tags;
 	    cip_extensible = false }
 	in
 	let branch_of_constr i c =
-	  (i, ci.ci_cstr_ndecls.(i), pattern_of_constr c)
+	  (i, ci.ci_pp_info.cstr_tags.(i), pattern_of_constr env c)
 	in
-	PCase (cip, pattern_of_constr p, pattern_of_constr a,
+	PCase (cip, pattern_of_constr env p, pattern_of_constr env a,
 	       Array.to_list (Array.mapi branch_of_constr br))
     | Fix f -> PFix f
     | CoFix f -> PCoFix f in
-  let p = pattern_of_constr t in
+  let p = pattern_of_constr env t in
   (* side-effect *)
   (* Warning: the order of dependencies in ctx is not ensured *)
   (!ctx,p)
@@ -158,32 +193,39 @@ let map_pattern_with_binders g f l = function
   | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2)
   | PCase (ci,po,p,pl) ->
     PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl)
+  | PProj (p,pc) -> PProj (p, f l pc)
   (* Non recursive *)
   | (PVar _ | PEvar _ | PRel _ | PRef _  | PSort _  | PMeta _
   (* Bound to terms *)
   | PFix _ | PCoFix _ as x) -> x
 
 let error_instantiate_pattern id l =
-  let is = if List.length l = 1 then "is" else "are" in
+  let is = match l with
+  | [_] -> "is" 
+  | _ -> "are"
+  in
   errorlabstrm "" (str "Cannot substitute the term bound to " ++ pr_id id
     ++ strbrk " in pattern because the term refers to " ++ pr_enum pr_id l
     ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.")
 
-let instantiate_pattern sigma lvar c =
+let instantiate_pattern env sigma lvar c =
   let rec aux vars = function
   | PVar id as x ->
       (try
-	let ctx,c = List.assoc id lvar in
+	let ctx,c = Id.Map.find id lvar in
 	try
 	  let inst =
-	    List.map (fun id -> mkRel (list_index (Name id) vars)) ctx in
+	    List.map
+              (fun id -> mkRel (List.index Name.equal (Name id) vars))
+              ctx
+          in
 	  let c = substl inst c in
-	  snd (pattern_of_constr sigma c)
-	with Not_found (* list_index failed *) ->
+	  snd (pattern_of_constr env sigma c)
+	with Not_found (* List.index failed *) ->
 	  let vars =
-	    list_map_filter (function Name id -> Some id | _ -> None) vars in
-	  error_instantiate_pattern id (list_subtract ctx vars)
-       with Not_found (* List.assoc failed *) ->
+	    List.map_filter (function Name id -> Some id | _ -> None) vars in
+	  error_instantiate_pattern id (List.subtract Id.equal ctx vars)
+       with Not_found (* Map.find failed *) ->
 	 x)
   | (PFix _ | PCoFix _) -> error ("Non instantiable pattern.")
   | c ->
@@ -203,17 +245,23 @@ let rec subst_pattern subst pat =
   | PRef ref ->
       let ref',t = subst_global subst ref in
 	if ref' == ref then pat else
-	 snd (pattern_of_constr Evd.empty t)
+	 snd (pattern_of_constr (Global.env()) Evd.empty t)
   | PVar _
   | PEvar _
   | PRel _ -> pat
+  | PProj (p,c) -> 
+      let p' = Projection.map (fun p -> 
+	destConstRef (fst (subst_global subst (ConstRef p)))) p in
+      let c' = subst_pattern subst c in
+	if p' == p && c' == c then pat else
+	  PProj(p',c')
   | PApp (f,args) ->
       let f' = subst_pattern subst f in
-      let args' = array_smartmap (subst_pattern subst) args in
+      let args' = Array.smartmap (subst_pattern subst) args in
 	if f' == f && args' == args then pat else
 	  PApp (f',args')
   | PSoApp (i,args) ->
-      let args' = list_smartmap (subst_pattern subst) args in
+      let args' = List.smartmap (subst_pattern subst) args in
 	if args' == args then pat else
 	  PSoApp (i,args')
   | PLambda (name,c1,c2) ->
@@ -241,7 +289,7 @@ let rec subst_pattern subst pat =
 	  PIf (c',c1',c2')
   | PCase (cip,typ,c,branches) ->
       let ind = cip.cip_ind in
-      let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in
+      let ind' = Option.smartmap (subst_ind subst) ind in
       let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in
       let typ' = subst_pattern subst typ in
       let c' = subst_pattern subst c in
@@ -249,7 +297,7 @@ let rec subst_pattern subst pat =
 	let c' = subst_pattern subst c in
 	if c' == c then br else (i,n,c')
       in
-      let branches' = list_smartmap subst_branch branches in
+      let branches' = List.smartmap subst_branch branches in
       if cip' == cip && typ' == typ && c' == c && branches' == branches
       then pat
       else PCase(cip', typ', c', branches')
@@ -271,13 +319,13 @@ let err loc pp = user_err_loc (loc,"pattern_of_glob_constr", pp)
 
 let rec pat_of_raw metas vars = function
   | GVar (_,id) ->
-      (try PRel (list_index (Name id) vars)
+      (try PRel (List.index Name.equal (Name id) vars)
        with Not_found -> PVar id)
   | GPatVar (_,(false,n)) ->
       metas := n::!metas; PMeta (Some n)
-  | GRef (_,gr) ->
+  | GRef (_,gr,_) ->
       PRef (canonical_gr gr)
-  (* Hack pour ne pas réécrire une interprétation complète des patterns*)
+  (* Hack to avoid rewriting a complete interpretation of patterns *)
   | GApp (_, GPatVar (_,(true,n)), cl) ->
       metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
   | GApp (_,c,cl) ->
@@ -300,43 +348,45 @@ let rec pat_of_raw metas vars = function
   | GHole _ ->
       PMeta None
   | GCast (_,c,_) ->
-      Flags.if_warn
-        Pp.msg_warning (str "Cast not taken into account in constr pattern");
+      Pp.msg_warning (strbrk "Cast not taken into account in constr pattern");
       pat_of_raw metas vars c
   | GIf (_,c,(_,None),b1,b2) ->
       PIf (pat_of_raw metas vars c,
            pat_of_raw metas vars b1,pat_of_raw metas vars b2)
   | GLetTuple (loc,nal,(_,None),b,c) ->
-      let mkGLambda c na = GLambda (loc,na,Explicit,GHole (loc,Evd.InternalHole),c) in
+      let mkGLambda c na =
+	GLambda (loc,na,Explicit,GHole (loc,Evar_kinds.InternalHole, IntroAnonymous, None),c) in
       let c = List.fold_left mkGLambda c nal in
       let cip =
 	{ cip_style = LetStyle;
 	  cip_ind = None;
-	  cip_ind_args = None;
+	  cip_ind_tags = None;
 	  cip_extensible = false }
       in
+      let tags = List.map (fun _ -> false) nal (* Approximation which can be without let-ins... *) in
       PCase (cip, PMeta None, pat_of_raw metas vars b,
-             [0,1,pat_of_raw metas vars c])
+             [0,tags,pat_of_raw metas vars c])
   | GCases (loc,sty,p,[c,(na,indnames)],brs) ->
       let get_ind = function
 	| (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
 	| _ -> None
       in
-      let ind_nargs,ind = match indnames with
-	| Some (_,ind,n,nal) -> Some (n,List.length nal), Some ind
+      let ind_tags,ind = match indnames with
+	| Some (_,ind,nal) -> Some (List.length nal), Some ind
 	| None -> None, get_ind brs
       in
       let ext,brs = pats_of_glob_branches loc metas vars ind brs
       in
       let pred = match p,indnames with
-	| Some p, Some (_,_,_,nal) ->
-	  rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas vars p))
+	| Some p, Some (_,_,nal) ->
+          let nvars = na :: List.rev nal @ vars in
+          rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p))
 	| _ -> PMeta None
       in
       let info =
 	{ cip_style = sty;
 	  cip_ind = ind;
-	  cip_ind_args = ind_nargs;
+	  cip_ind_tags = None;
 	  cip_extensible = ext }
       in
       (* Nota : when we have a non-trivial predicate,
@@ -355,21 +405,25 @@ and pats_of_glob_branches loc metas vars ind brs =
     | [] -> false, []
     | [(_,_,[PatVar(_,Anonymous)],GHole _)] -> true, [] (* ends with _ => _ *)
     | (_,_,[PatCstr(_,(indsp,j),lv,_)],br) :: brs ->
-      if ind <> None && ind <> Some indsp then
-        err loc (Pp.str "All constructors must be in the same inductive type.");
-      if Intset.mem (j-1) indexes then
+      let () = match ind with
+      | Some sp when eq_ind sp indsp -> ()
+      | _ ->
+        err loc (Pp.str "All constructors must be in the same inductive type.")
+      in
+      if Int.Set.mem (j-1) indexes then
 	err loc
           (str "No unique branch for " ++ int j ++ str"-th constructor.");
       let lna = List.map get_arg lv in
       let vars' = List.rev lna @ vars in
       let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in
-      let ext,pats = get_pat (Intset.add (j-1) indexes) brs in
-      ext, ((j-1, List.length lv, pat) :: pats)
+      let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in
+      let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in
+      ext, ((j-1, tags, pat) :: pats)
     | (loc,_,_,_) :: _ -> err loc (Pp.str "Non supported pattern.")
   in
-  get_pat Intset.empty brs
+  get_pat Int.Set.empty brs
 
 let pattern_of_glob_constr c =
   let metas = ref [] in
-  let p = pat_of_raw metas [] c in	
+  let p = pat_of_raw metas [] c in
   (!metas,p)
diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli
new file mode 100644
index 00000000..cf02421c
--- /dev/null
+++ b/pretyping/patternops.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  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 Context
+open Term
+open Globnames
+open Glob_term
+open Mod_subst
+open Misctypes
+open Pattern
+
+(** {5 Functions on patterns} *)
+
+val constr_pattern_eq : constr_pattern -> constr_pattern -> bool
+
+val occur_meta_pattern : constr_pattern -> bool
+
+val subst_pattern : substitution -> constr_pattern -> constr_pattern
+
+exception BoundPattern
+
+(** [head_pattern_bound t] extracts the head variable/constant of the
+   type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
+   if [t] is an abstraction *)
+
+val head_pattern_bound : constr_pattern -> global_reference
+
+(** [head_of_constr_reference c] assumes [r] denotes a reference and
+   returns its label; raises an anomaly otherwise *)
+
+val head_of_constr_reference : Term.constr -> global_reference
+
+(** [pattern_of_constr c] translates a term [c] with metavariables into
+   a pattern; currently, no destructor (Cases, Fix, Cofix) and no
+   existential variable are allowed in [c] *)
+
+val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> named_context * constr_pattern
+
+(** [pattern_of_glob_constr l c] translates a term [c] with metavariables into
+   a pattern; variables bound in [l] are replaced by the pattern to which they
+    are bound *)
+
+val pattern_of_glob_constr : glob_constr ->
+      patvar list * constr_pattern
+
+val instantiate_pattern : Environ.env ->
+  Evd.evar_map -> extended_patvar_map ->
+  constr_pattern -> constr_pattern
+
+val lift_pattern : int -> constr_pattern -> constr_pattern
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 52122974..030b4a11 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -1,100 +1,68 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Sign
 open Term
-open Termops
-open Namegen
 open Environ
 open Type_errors
-open Glob_term
-open Inductiveops
+
+type unification_error =
+  | OccurCheck of existential_key * constr
+  | NotClean of existential * env * constr
+  | NotSameArgSize
+  | NotSameHead
+  | NoCanonicalStructure
+  | ConversionFailed of env * constr * constr
+  | MetaOccurInBody of existential_key
+  | InstanceNotSameType of existential_key * env * types * types
+  | UnifUnivInconsistency of Univ.univ_inconsistency
+  | CannotSolveConstraint of Evd.evar_constraint * unification_error
+
+type position = (Id.t * Locus.hyp_location_flag) option
+
+type position_reporting = (position * int) * constr
+
+type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option
 
 type pretype_error =
   (* Old Case *)
   | CantFindCaseType of constr
-  (* Unification *)
-  | OccurCheck of existential_key * constr
-  | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind *
-      Evd.unsolvability_explanation option
-  | CannotUnify of constr * constr
+  (* Type inference unification *)
+  | ActualTypeNotCoercible of unsafe_judgment * types * unification_error
+  (* Tactic unification *)
+  | UnifOccurCheck of existential_key * constr
+  | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option
+  | CannotUnify of constr * constr * unification_error option
   | CannotUnifyLocal of constr * constr * constr
   | CannotUnifyBindingType of constr * constr
   | CannotGeneralize of constr
-  | NoOccurrenceFound of constr * identifier option
-  | CannotFindWellTypedAbstraction of constr * constr list
-  | AbstractionOverMeta of name * name
-  | NonLinearUnification of name * constr
+  | NoOccurrenceFound of constr * Id.t option
+  | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option
+  | WrongAbstractionType of Name.t * constr * types * types
+  | AbstractionOverMeta of Name.t * Name.t
+  | NonLinearUnification of Name.t * constr
   (* Pretyping *)
-  | VarNotFound of identifier
+  | VarNotFound of Id.t
   | UnexpectedType of constr * constr
   | NotProduct of constr
   | TypingError of type_error
+  | CannotUnifyOccurrences of subterm_unification_error
+  | UnsatisfiableConstraints of
+    (existential_key * Evar_kinds.t) option * Evar.Set.t option
 
 exception PretypeError of env * Evd.evar_map * pretype_error
 
 let precatchable_exception = function
-  | Util.UserError _ | TypeError _ | PretypeError _
-  | Loc.Exc_located(_,(Util.UserError _ | TypeError _ |
-    Nametab.GlobalizationError _ | PretypeError _)) -> true
+  | Errors.UserError _ | TypeError _ | PretypeError _
+  | Nametab.GlobalizationError _ -> true
   | _ -> false
 
-let nf_evar = Reductionops.nf_evar
-let j_nf_evar sigma j =
-  { uj_val = nf_evar sigma j.uj_val;
-    uj_type = nf_evar sigma j.uj_type }
-let j_nf_betaiotaevar sigma j =
-  { uj_val = nf_evar sigma j.uj_val;
-    uj_type = Reductionops.nf_betaiota sigma j.uj_type }
-let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl
-let jv_nf_betaiotaevar sigma jl =
-  Array.map (j_nf_betaiotaevar sigma) jl
-let jv_nf_evar sigma = Array.map (j_nf_evar sigma)
-let tj_nf_evar sigma {utj_val=v;utj_type=t} =
-  {utj_val=nf_evar sigma v;utj_type=t}
-
-let env_nf_evar sigma env =
-  process_rel_context
-    (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env
-
-let env_nf_betaiotaevar sigma env =
-  process_rel_context
-    (fun d e ->
-      push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env
-
-(* This simplifies the typing context of Cases clauses *)
-(* hope it does not disturb other typing contexts *)
-let contract env lc =
-  let l = ref [] in
-  let contract_context (na,c,t) env =
-    match c with
-      | Some c' when isRel c' ->
-	  l := (substl !l c') :: !l;
-	  env
-      | _ ->
-	  let t' = substl !l t in
-	  let c' = Option.map (substl !l) c in
-	  let na' = named_hd env t' na in
-	  l := (mkRel 1) :: List.map (lift 1) !l;
-	  push_rel (na',c',t') env in
-  let env = process_rel_context contract_context env in
-  (env, List.map (substl !l) lc)
-
-let contract2 env a b = match contract env [a;b] with
-  | env, [a;b] -> env,a,b | _ -> assert false
-
-let contract3 env a b c = match contract env [a;b;c] with
-  | env, [a;b;c] -> env,a,b,c | _ -> assert false
-
 let raise_pretype_error (loc,env,sigma,te) =
   Loc.raise loc (PretypeError(env,sigma,te))
 
@@ -102,10 +70,10 @@ let raise_located_type_error (loc,env,sigma,te) =
   Loc.raise loc (PretypeError(env,sigma,TypingError te))
 
 
-let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty =
-  let env, c, actty, expty = contract3 env c actty expty in
+let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty reason =
   let j = {uj_val=c;uj_type=actty} in
-  raise_located_type_error (loc, env, sigma, ActualType (j, expty))
+  raise_pretype_error
+    (loc, env, sigma, ActualTypeNotCoercible (j, expty, reason))
 
 let error_cant_apply_not_functional_loc loc env sigma rator randl =
   raise_located_type_error
@@ -137,26 +105,29 @@ let error_not_a_type_loc loc env sigma j =
     a precise location. *)
 
 let error_occur_check env sigma ev c =
-  raise (PretypeError (env, sigma, OccurCheck (ev,c)))
-
-let error_not_clean env sigma ev c (loc,k) =
-  Loc.raise loc (PretypeError (env, sigma, NotClean (ev,c,k)))
+  raise (PretypeError (env, sigma, UnifOccurCheck (ev,c)))
 
-let error_unsolvable_implicit loc env sigma evi e explain =
+let error_unsolvable_implicit loc env sigma evk explain =
   Loc.raise loc
-    (PretypeError (env, sigma, UnsolvableImplicit (evi, e, explain)))
+    (PretypeError (env, sigma, UnsolvableImplicit (evk, explain)))
+
+let error_cannot_unify_loc loc env sigma ?reason (m,n) =
+  Loc.raise loc (PretypeError (env, sigma,CannotUnify (m,n,reason)))
 
-let error_cannot_unify env sigma (m,n) =
-  raise (PretypeError (env, sigma,CannotUnify (m,n)))
+let error_cannot_unify env sigma ?reason (m,n) =
+  raise (PretypeError (env, sigma,CannotUnify (m,n,reason)))
 
 let error_cannot_unify_local env sigma (m,n,sn) =
   raise (PretypeError (env, sigma,CannotUnifyLocal (m,n,sn)))
 
 let error_cannot_coerce env sigma (m,n) =
-  raise (PretypeError (env, sigma,CannotUnify (m,n)))
+  raise (PretypeError (env, sigma,CannotUnify (m,n,None)))
 
-let error_cannot_find_well_typed_abstraction env sigma p l =
-  raise (PretypeError (env, sigma,CannotFindWellTypedAbstraction (p,l)))
+let error_cannot_find_well_typed_abstraction env sigma p l e =
+  raise (PretypeError (env, sigma,CannotFindWellTypedAbstraction (p,l,e)))
+
+let error_wrong_abstraction_type env sigma na a p l =
+  raise (PretypeError (env, sigma,WrongAbstractionType (na,a,p,l)))
 
 let error_abstraction_over_meta env sigma hdmeta metaarg =
   let m = Evd.meta_name sigma hdmeta and n = Evd.meta_name sigma metaarg in
@@ -174,7 +145,6 @@ let error_cant_find_case_type_loc loc env sigma expr =
 (*s Pretyping errors *)
 
 let error_unexpected_type_loc loc env sigma actty expty =
-  let env, actty, expty = contract2 env actty expty in
   raise_pretype_error (loc, env, sigma, UnexpectedType (actty, expty))
 
 let error_not_product_loc loc env sigma c =
@@ -184,3 +154,20 @@ let error_not_product_loc loc env sigma c =
 
 let error_var_not_found_loc loc s =
   raise_pretype_error (loc, empty_env, Evd.empty, VarNotFound s)
+
+(*s Typeclass errors *)
+
+let unsatisfiable_constraints env evd ev comp =
+  match ev with
+  | None ->
+    let err = UnsatisfiableConstraints (None, comp) in
+    raise (PretypeError (env,evd,err))
+  | Some ev ->
+    let loc, kind = Evd.evar_source ev evd in
+    let err = UnsatisfiableConstraints (Some (ev, kind), comp) in
+    Loc.raise loc (PretypeError (env,evd,err))
+
+let unsatisfiable_exception exn =
+  match exn with
+  | PretypeError (_, _, UnsatisfiableConstraints _) -> true
+  | _ -> false
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index 75962d11..8fcfb59b 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -1,91 +1,97 @@
 (************************************************************************)
 (*  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 Names
 open Term
-open Sign
 open Environ
-open Glob_term
-open Inductiveops
+open Type_errors
 
 (** {6 The type of errors raised by the pretyper } *)
 
+type unification_error =
+  | OccurCheck of existential_key * constr
+  | NotClean of existential * env * constr
+  | NotSameArgSize
+  | NotSameHead
+  | NoCanonicalStructure
+  | ConversionFailed of env * constr * constr
+  | MetaOccurInBody of existential_key
+  | InstanceNotSameType of existential_key * env * types * types
+  | UnifUnivInconsistency of Univ.univ_inconsistency
+  | CannotSolveConstraint of Evd.evar_constraint * unification_error
+
+type position = (Id.t * Locus.hyp_location_flag) option
+
+type position_reporting = (position * int) * constr
+
+type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option
+
 type pretype_error =
   (** Old Case *)
   | CantFindCaseType of constr
-  (** Unification *)
-  | OccurCheck of existential_key * constr
-  | NotClean of existential_key * constr * Evd.hole_kind
-  | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind *
-      Evd.unsolvability_explanation option
-  | CannotUnify of constr * constr
+  (** Type inference unification *)
+  | ActualTypeNotCoercible of unsafe_judgment * types * unification_error
+  (** Tactic Unification *)
+  | UnifOccurCheck of existential_key * constr
+  | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option
+  | CannotUnify of constr * constr * unification_error option
   | CannotUnifyLocal of constr * constr * constr
   | CannotUnifyBindingType of constr * constr
   | CannotGeneralize of constr
-  | NoOccurrenceFound of constr * identifier option
-  | CannotFindWellTypedAbstraction of constr * constr list
-  | AbstractionOverMeta of name * name
-  | NonLinearUnification of name * constr
+  | NoOccurrenceFound of constr * Id.t option
+  | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option
+  | WrongAbstractionType of Name.t * constr * types * types
+  | AbstractionOverMeta of Name.t * Name.t
+  | NonLinearUnification of Name.t * constr
   (** Pretyping *)
-  | VarNotFound of identifier
+  | VarNotFound of Id.t
   | UnexpectedType of constr * constr
   | NotProduct of constr
-  | TypingError of Type_errors.type_error
+  | TypingError of type_error
+  | CannotUnifyOccurrences of subterm_unification_error
+  | UnsatisfiableConstraints of
+    (existential_key * Evar_kinds.t) option * Evar.Set.t option
+    (** unresolvable evar, connex component *)
 
 exception PretypeError of env * Evd.evar_map * pretype_error
 
 val precatchable_exception : exn -> bool
 
-(** Presenting terms without solved evars *)
-val nf_evar : Evd.evar_map -> constr -> constr
-val j_nf_evar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar : Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar : Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar : Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment
-
-val env_nf_evar : Evd.evar_map -> env -> env
-val env_nf_betaiotaevar : Evd.evar_map -> env -> env
-
-val j_nf_betaiotaevar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment
-val jv_nf_betaiotaevar :
-  Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array
-
 (** Raising errors *)
 val error_actual_type_loc :
-  loc -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b
+  Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr ->
+      unification_error -> 'b
 
 val error_cant_apply_not_functional_loc :
-  loc -> env -> Evd.evar_map ->
+  Loc.t -> env -> Evd.evar_map ->
       unsafe_judgment -> unsafe_judgment list -> 'b
 
 val error_cant_apply_bad_type_loc :
-  loc -> env -> Evd.evar_map -> int * constr * constr ->
+  Loc.t -> env -> Evd.evar_map -> int * constr * constr ->
       unsafe_judgment -> unsafe_judgment list -> 'b
 
 val error_case_not_inductive_loc :
-  loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b
+  Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b
 
 val error_ill_formed_branch_loc :
-  loc -> env -> Evd.evar_map ->
-      constr -> constructor -> constr -> constr -> 'b
+  Loc.t -> env -> Evd.evar_map ->
+      constr -> pconstructor -> constr -> constr -> 'b
 
 val error_number_branches_loc :
-  loc -> env -> Evd.evar_map ->
+  Loc.t -> env -> Evd.evar_map ->
       unsafe_judgment -> int -> 'b
 
 val error_ill_typed_rec_body_loc :
-  loc -> env -> Evd.evar_map ->
-      int -> name array -> unsafe_judgment array -> types array -> 'b
+  Loc.t -> env -> Evd.evar_map ->
+      int -> Name.t array -> unsafe_judgment array -> types array -> 'b
 
 val error_not_a_type_loc :
-  loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b
+  Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b
 
 val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
 
@@ -93,19 +99,23 @@ val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
 
 val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b
 
-val error_not_clean :
-  env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
-
 val error_unsolvable_implicit :
-  loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind ->
+  Loc.t -> env -> Evd.evar_map -> existential_key ->
       Evd.unsolvability_explanation option -> 'b
 
-val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b
+val error_cannot_unify_loc : Loc.t -> env -> Evd.evar_map ->
+  ?reason:unification_error -> constr * constr -> 'b
+
+val error_cannot_unify : env -> Evd.evar_map -> ?reason:unification_error ->
+  constr * constr -> 'b
 
 val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b
 
 val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map ->
-      constr -> constr list -> 'b
+      constr -> constr list -> (env * type_error) option -> 'b
+
+val error_wrong_abstraction_type :  env -> Evd.evar_map ->
+      Name.t -> constr -> types -> types -> 'b
 
 val error_abstraction_over_meta : env -> Evd.evar_map ->
   metavariable -> metavariable -> 'b
@@ -116,16 +126,24 @@ val error_non_linear_unification : env -> Evd.evar_map ->
 (** {6 Ml Case errors } *)
 
 val error_cant_find_case_type_loc :
-  loc -> env -> Evd.evar_map -> constr -> 'b
+  Loc.t -> env -> Evd.evar_map -> constr -> 'b
 
 (** {6 Pretyping errors } *)
 
 val error_unexpected_type_loc :
-  loc -> env -> Evd.evar_map -> constr -> constr -> 'b
+  Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b
 
 val error_not_product_loc :
-  loc -> env -> Evd.evar_map -> constr -> 'b
+  Loc.t -> env -> Evd.evar_map -> constr -> 'b
 
 (** {6 Error in conversion from AST to glob_constr } *)
 
-val error_var_not_found_loc : loc -> identifier -> 'b
+val error_var_not_found_loc : Loc.t -> Id.t -> 'b
+
+(** {6 Typeclass errors } *)
+
+val unsatisfiable_constraints : env -> Evd.evar_map -> Evd.evar option ->
+  Evar.Set.t option -> 'a
+
+val unsatisfiable_exception : exn -> bool
+
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 08e8df05..040792ef 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.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        *)
@@ -21,39 +21,44 @@
 (* Secondary maintenance: collective *)
 
 
-open Compat
 open Pp
+open Errors
 open Util
 open Names
-open Sign
 open Evd
 open Term
+open Vars
+open Context
 open Termops
 open Reductionops
 open Environ
 open Type_errors
 open Typeops
-open Libnames
+open Globnames
 open Nameops
-open Classops
-open List
-open Recordops
 open Evarutil
 open Pretype_errors
 open Glob_term
+open Glob_ops
 open Evarconv
 open Pattern
-
-type typing_constraint = OfType of types option | IsType
-type var_map = (identifier * constr_under_binders) list
-type unbound_ltac_var_map = (identifier * identifier option) list
-type ltac_var_map = var_map * unbound_ltac_var_map
+open Misctypes
+
+type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
+type var_map = constr_under_binders Id.Map.t
+type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
+type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+type ltac_var_map = {
+  ltac_constrs : var_map;
+  ltac_uconstrs : uconstr_var_map;
+  ltac_idents: Id.t Id.Map.t;
+  ltac_genargs : unbound_ltac_var_map;
+}
 type glob_constr_ltac_closure = ltac_var_map * glob_constr
 type pure_open_constr = evar_map * constr
 
 (************************************************************************)
 (* This concerns Cases *)
-open Declarations
 open Inductive
 open Inductiveops
 
@@ -66,12 +71,15 @@ exception Found of int array
 let search_guard loc env possible_indexes fixdefs =
   (* Standard situation with only one possibility for each fix. *)
   (* We treat it separately in order to get proper error msg. *)
-  if List.for_all (fun l->1=List.length l) possible_indexes then
+  let is_singleton = function [_] -> true | _ -> false in
+  if List.for_all is_singleton possible_indexes then
     let indexes = Array.of_list (List.map List.hd possible_indexes) in
     let fix = ((indexes, 0),fixdefs) in
     (try check_fix env fix
-     with e when Errors.noncritical e ->
-       if loc = dummy_loc then raise e else Loc.raise loc e);
+     with reraise ->
+       let (e, info) = Errors.push reraise in
+       let info = Loc.add_loc info loc in
+       iraise (e, info));
     indexes
   else
     (* we now search recursively amoungst all combinations *)
@@ -82,9 +90,8 @@ let search_guard loc env possible_indexes fixdefs =
 	    let fix = ((indexes, 0),fixdefs) in
 	    try check_fix env fix; raise (Found indexes)
 	    with TypeError _ -> ())
-	 (list_combinations possible_indexes);
+	 (List.combinations possible_indexes);
        let errmsg = "Cannot guess decreasing argument of fix." in
-       if loc = dummy_loc then error errmsg else
 	 user_err_loc (loc,"search_guard", Pp.str errmsg)
      with Found indexes -> indexes)
 
@@ -93,704 +100,947 @@ let ((constr_in : constr -> Dyn.t),
      (constr_out : Dyn.t -> constr)) = Dyn.create "constr"
 
 (** Miscellaneous interpretation functions *)
-
-let interp_sort = function
-  | GProp c -> Prop c
-  | GType _ -> new_Type_sort ()
+let interp_universe_level_name evd s =
+  let names, _ = Universes.global_universe_names () in
+  try
+    let id = try Id.of_string s with _ -> raise Not_found in
+      evd, Idmap.find id names
+  with Not_found ->
+    try let level = Evd.universe_of_name evd s in
+	  evd, level
+    with Not_found -> 
+      new_univ_level_variable ~name:s univ_rigid evd
+
+let interp_universe evd = function
+  | [] -> let evd, l = new_univ_level_variable univ_rigid evd in
+	    evd, Univ.Universe.make l
+  | l ->
+    List.fold_left (fun (evd, u) l -> 
+      let evd', l = interp_universe_level_name evd l in
+	(evd', Univ.sup u (Univ.Universe.make l)))
+    (evd, Univ.Universe.type0m) l
+
+let interp_universe_level evd = function
+  | None -> new_univ_level_variable univ_rigid evd
+  | Some s -> interp_universe_level_name evd s
+
+let interp_sort evd = function
+  | GProp -> evd, Prop Null
+  | GSet -> evd, Prop Pos
+  | GType n -> 
+    let evd, u = interp_universe evd n in
+      evd, Type u
 
 let interp_elimination_sort = function
-  | GProp Null -> InProp
-  | GProp Pos  -> InSet
+  | GProp -> InProp
+  | GSet  -> InSet
   | GType _ -> InType
 
-let resolve_evars env evdref fail_evar resolve_classes =
-  if resolve_classes then
-    evdref := (Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals
-		 ~split:true ~fail:fail_evar env !evdref);
+type inference_flags = {
+  use_typeclasses : bool;
+  use_unif_heuristics : bool;
+  use_hook : (env -> evar_map -> evar -> constr) option;
+  fail_evar : bool;
+  expand_evars : bool
+}
+
+let pending_holes (sigma, sigma') =
+  let fold evk _ accu =
+    if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu
+  in
+  Evd.fold_undefined fold sigma' Evar.Set.empty
+
+let apply_typeclasses env evdref pending fail_evar =
+  let filter_pending evk = Evar.Set.mem evk pending in
+  evdref := Typeclasses.resolve_typeclasses
+     ~filter:(if Flags.is_program_mode () 
+	      then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && filter_pending evk)
+              else (fun evk evi -> Typeclasses.no_goals evk evi && filter_pending evk))
+     ~split:true ~fail:fail_evar env !evdref;
+  if Flags.is_program_mode () then (* Try optionally solving the obligations *)
+    evdref := Typeclasses.resolve_typeclasses
+      ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && filter_pending evk) ~split:true ~fail:false env !evdref
+
+let apply_inference_hook hook evdref pending =
+  evdref := Evar.Set.fold (fun evk sigma ->
+    if Evd.is_undefined sigma evk (* in particular not defined by side-effect *)
+    then
+      try
+        let c = hook sigma evk in
+        Evd.define evk c sigma
+      with Exit ->
+        sigma
+    else
+      sigma) pending !evdref
+
+let apply_heuristics env evdref fail_evar =
   (* Resolve eagerly, potentially making wrong choices *)
-  evdref := (try consider_remaining_unif_problems
-	       ~ts:(Typeclasses.classes_transparent_state ()) env !evdref
-	     with e when Errors.noncritical e ->
-               if fail_evar then raise e else !evdref)
-
-let solve_remaining_evars fail_evar use_classes hook env initial_sigma (evd,c) =
-  let evdref = ref evd in
-  resolve_evars env evdref fail_evar use_classes;
-  let rec proc_rec c =
-    let c = Reductionops.whd_evar !evdref c in
-    match kind_of_term c with
-    | Evar (evk,args as ev) when not (Evd.mem initial_sigma evk) ->
-        let sigma = !evdref in
-	(try
-	   let c = hook env sigma ev in
-	   evdref := Evd.define evk c !evdref;
-	   c
-	 with Exit ->
-           if fail_evar then
-	     let evi = Evd.find_undefined sigma evk in
-             let (loc,src) = evar_source evk !evdref in
-	     Pretype_errors.error_unsolvable_implicit loc env sigma evi src None
-           else
-             c)
-    | _ -> map_constr proc_rec c in
-  let c = proc_rec c in
-  (* Side-effect *)
-  !evdref,c
-
-module type S =
-sig
-
-  module Cases : Cases.S
-
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  val allow_anonymous_refs : bool ref
-
-  (* Generic call to the interpreter from glob_constr to open_constr, leaving
-     unresolved holes as evars and returning the typing contexts of
-     these evars. Work as [understand_gen] for the rest. *)
-
-  val understand_tcc : ?resolve_classes:bool ->
-    evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr
-
-  val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
-    evar_map ref -> env -> typing_constraint -> glob_constr -> constr
-
-  (* More general entry point with evars from ltac *)
-
-  (* Generic call to the interpreter from glob_constr to constr, failing
-     unresolved holes in the glob_constr cannot be instantiated.
-
-     In [understand_ltac expand_evars sigma env ltac_env constraint c],
-
-     resolve_classes : launch typeclass resolution after typechecking.
-     expand_evars : expand inferred evars by their value if any
-     sigma : initial set of existential variables (typically dependent subgoals)
-     ltac_env : partial substitution of variables (used for the tactic language)
-     constraint : tell if interpreted as a possibly constrained term or a type
-  *)
-
-  val understand_ltac : ?resolve_classes:bool ->
-    bool -> evar_map -> env -> ltac_var_map ->
-    typing_constraint -> glob_constr -> pure_open_constr
-
-  (* Standard call to get a constr from a glob_constr, resolving implicit args *)
-
-  val understand : evar_map -> env -> ?expected_type:Term.types ->
-    glob_constr -> constr
-
-  (* Idem but the glob_constr is intended to be a type *)
-
-  val understand_type : evar_map -> env -> glob_constr -> constr
-
-  (* A generalization of the two previous case *)
-
-  val understand_gen : typing_constraint -> evar_map -> env ->
-    glob_constr -> constr
-
-  (* Idem but returns the judgment of the understood term *)
-
-  val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment
-
-  (* Idem but do not fail on unresolved evars *)
-
-  val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment
-
-  (*i*)
-  (* Internal of Pretyping...
-   * Unused outside, but useful for debugging
-   *)
-  val pretype :
-    bool -> type_constraint -> env -> evar_map ref ->
-    ltac_var_map -> glob_constr -> unsafe_judgment
-
-  val pretype_type :
-    bool -> val_constraint -> env -> evar_map ref ->
-    ltac_var_map -> glob_constr -> unsafe_type_judgment
-
-  val pretype_gen :
-    bool -> bool -> bool -> evar_map ref -> env ->
-    ltac_var_map -> typing_constraint -> glob_constr -> constr
-
-    (*i*)
-end
-
-module Pretyping_F (Coercion : Coercion.S) = struct
-
-  module Cases = Cases.Cases_F(Coercion)
-
-  (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  let allow_anonymous_refs = ref false
-
-  let evd_comb0 f evdref =
-    let (evd',x) = f !evdref in
-      evdref := evd';
-      x
-
-  let evd_comb1 f evdref x =
-    let (evd',y) = f !evdref x in
-      evdref := evd';
-      y
-
-  let evd_comb2 f evdref x y =
-    let (evd',z) = f !evdref x y in
-      evdref := evd';
-      z
-
-  let evd_comb3 f evdref x y z =
-    let (evd',t) = f !evdref x y z in
-      evdref := evd';
-      t
-
-  let mt_evd = Evd.empty
-
-  (* Utilisé pour inférer le prédicat des Cases *)
-  (* Semble exagérement fort *)
-  (* Faudra préférer une unification entre les types de toutes les clauses *)
-  (* et autoriser des ? à rester dans le résultat de l'unification *)
-
-  let evar_type_fixpoint loc env evdref lna lar vdefj =
-    let lt = Array.length vdefj in
-      if Array.length lar = lt then
-	for i = 0 to lt-1 do
-          if not (e_cumul env evdref (vdefj.(i)).uj_type
-		    (lift lt lar.(i))) then
-            error_ill_typed_rec_body_loc loc env !evdref
-              i lna vdefj lar
-	done
-
-  (* coerce to tycon if any *)
-  let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
-    | None -> j
-    | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
-
-  let push_rels vars env = List.fold_right push_rel vars env
-
-  (* used to enforce a name in Lambda when the type constraints itself
-     is named, hence possibly dependent *)
-
-  let orelse_name name name' = match name with
-    | Anonymous -> name'
-    | _ -> name
-
-  let invert_ltac_bound_name env id0 id =
-    try mkRel (pi1 (lookup_rel_id id (rel_context env)))
-    with Not_found ->
-      errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
-	str " depends on pattern variable name " ++ pr_id id ++
-	str " which is not bound in current context.")
-
-  let protected_get_type_of env sigma c =
-    try Retyping.get_type_of env sigma c
-    with Anomaly _ ->
-      errorlabstrm "" (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.")
-
-  let pretype_id loc env sigma (lvar,unbndltacvars) id =
-    (* Look for the binder of [id] *)
-    try
-      let (n,_,typ) = lookup_rel_id id (rel_context env) in
+  try evdref := consider_remaining_unif_problems
+	~ts:(Typeclasses.classes_transparent_state ()) env !evdref
+  with e when Errors.noncritical e ->
+    let e = Errors.push e in if fail_evar then iraise e
+
+let check_typeclasses_instances_are_solved env current_sigma pending =
+  (* Naive way, call resolution again with failure flag *)
+  apply_typeclasses env (ref current_sigma) pending true
+
+let check_extra_evars_are_solved env current_sigma pending =
+  Evar.Set.iter
+    (fun evk ->
+      if not (Evd.is_defined current_sigma evk) then
+        let (loc,k) = evar_source evk current_sigma in
+	match k with
+	| Evar_kinds.ImplicitArg (gr, (i, id), false) -> ()
+	| _ ->
+	    error_unsolvable_implicit loc env current_sigma evk None) pending
+
+let check_evars_are_solved env current_sigma pending =
+  check_typeclasses_instances_are_solved env current_sigma pending;
+  check_problems_are_solved env current_sigma;
+  check_extra_evars_are_solved env current_sigma pending
+
+(* Try typeclasses, hooks, unification heuristics ... *)
+
+let solve_remaining_evars flags env current_sigma pending =
+  let pending = pending_holes pending in
+  let evdref = ref current_sigma in
+  if flags.use_typeclasses then apply_typeclasses env evdref pending false;
+  if Option.has_some flags.use_hook then
+    apply_inference_hook (Option.get flags.use_hook env) evdref pending;
+  if flags.use_unif_heuristics then apply_heuristics env evdref false;
+  if flags.fail_evar then check_evars_are_solved env !evdref pending;
+  !evdref
+
+let check_evars_are_solved env current_sigma pending =
+  let pending = pending_holes pending in
+  check_evars_are_solved env current_sigma pending
+
+let process_inference_flags flags env initial_sigma (sigma,c) =
+  let sigma = solve_remaining_evars flags env sigma (initial_sigma, sigma) in
+  let c = if flags.expand_evars then nf_evar sigma c else c in
+  sigma,c
+
+(* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+let allow_anonymous_refs = ref false
+
+(* Utilisé pour inférer le prédicat des Cases *)
+(* Semble exagérement fort *)
+(* Faudra préférer une unification entre les types de toutes les clauses *)
+(* et autoriser des ? à rester dans le résultat de l'unification *)
+
+let evar_type_fixpoint loc env evdref lna lar vdefj =
+  let lt = Array.length vdefj in
+    if Int.equal (Array.length lar) lt then
+      for i = 0 to lt-1 do
+        if not (e_cumul env evdref (vdefj.(i)).uj_type
+		  (lift lt lar.(i))) then
+          error_ill_typed_rec_body_loc loc env !evdref
+            i lna vdefj lar
+      done
+
+(* coerce to tycon if any *)
+let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function
+  | None -> j
+  | Some t ->
+      evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env) evdref j t
+
+let check_instance loc subst = function
+  | [] -> ()
+  | (id,_) :: _ ->
+      if List.mem_assoc id subst then
+        user_err_loc (loc,"",pr_id id ++ str "appears more than once.")
+      else
+        user_err_loc (loc,"",str "No such variable in the signature of the existential variable: " ++ pr_id id ++ str ".")
+
+(* used to enforce a name in Lambda when the type constraints itself
+   is named, hence possibly dependent *)
+
+let orelse_name name name' = match name with
+  | Anonymous -> name'
+  | _ -> name
+
+let ltac_interp_name { ltac_idents ; ltac_genargs } = function
+  | Anonymous -> Anonymous
+  | Name id as n ->
+      try Name (Id.Map.find id ltac_idents)
+      with Not_found ->
+        if Id.Map.mem id ltac_genargs then
+          errorlabstrm "" (str"Ltac variable"++spc()++ pr_id id ++
+                           spc()++str"is not bound to an identifier."++spc()++
+                           str"It cannot be used in a binder.")
+        else n
+
+let invert_ltac_bound_name lvar env id0 id =
+  let id = Id.Map.find id lvar.ltac_idents in
+  try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+  with Not_found ->
+    errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
+		       str " depends on pattern variable name " ++ pr_id id ++
+		       str " which is not bound in current context.")
+
+let protected_get_type_of env sigma c =
+  try Retyping.get_type_of ~lax:true env sigma c
+  with Retyping.RetypeError _ ->
+    errorlabstrm ""
+      (str "Cannot reinterpret " ++ quote (print_constr c) ++
+       str " in the current environment.")
+
+let pretype_id pretype loc env evdref lvar id =
+  let sigma = !evdref in
+  (* Look for the binder of [id] *)
+  try
+    let id =
+      try Id.Map.find id lvar.ltac_idents
+      with Not_found -> id
+    in
+    let (n,_,typ) = lookup_rel_id id (rel_context env) in
       { uj_val  = mkRel n; uj_type = lift n typ }
-    with Not_found ->
+  with Not_found ->
     (* Check if [id] is an ltac variable *)
     try
-      let (ids,c) = List.assoc id lvar in
-      let subst = List.map (invert_ltac_bound_name env id) ids in
+      let (ids,c) = Id.Map.find id lvar.ltac_constrs in
+      let subst = List.map (invert_ltac_bound_name lvar env id) ids in
       let c = substl subst c in
-      { uj_val = c; uj_type = protected_get_type_of env sigma c }
+	{ uj_val = c; uj_type = protected_get_type_of env sigma c }
+    with Not_found -> try
+       let {closure;term} = Id.Map.find id lvar.ltac_uconstrs in
+       let lvar = {
+         ltac_constrs = closure.typed;
+         ltac_uconstrs = closure.untyped;
+         ltac_idents = closure.idents;
+         ltac_genargs = Id.Map.empty; }
+       in
+       (* spiwack: I'm catching [Not_found] potentially too eagerly
+          here, as the call to the main pretyping function is caught
+          inside the try but I want to avoid refactoring this function
+          too much for now. *)
+       pretype env evdref lvar term
     with Not_found ->
-    (* if [id] an ltac variable not bound to a term *)
-    (* build a nice error message *)
-    try
-      match List.assoc id unbndltacvars with
-      | None -> user_err_loc (loc,"",
-	  str "Variable " ++ pr_id id ++ str " should be bound to a term.")
-      | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
-    with Not_found ->
-    (* Check if [id] is a section or goal variable *)
-    try
-      let (_,_,typ) = lookup_named id env in
-      { uj_val  = mkVar id; uj_type = typ }
-    with Not_found ->
-    (* [id] not found, standard error message *)
-      error_var_not_found_loc loc id
-
-  let evar_kind_of_term sigma c =
-    kind_of_term (whd_evar sigma c)
-
-  (*************************************************************************)
-  (* Main pretyping function                                               *)
-
-  let pretype_ref evdref env ref =
-    let c = constr_of_global ref in
-      make_judge c (Retyping.get_type_of env Evd.empty c)
-  let pretype_ref loc evdref env = function
-    | VarRef id ->
-        (* Section variable *)
-        (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty
-         with Not_found ->
-           (* This may happen if env is a goal env and section variables have
-              been cleared - section variables should be different from goal
-              variables *)
-           Pretype_errors.error_var_not_found_loc loc id)
-    | ref ->
-        let c = constr_of_global ref in
-        make_judge c (Retyping.get_type_of env Evd.empty c)
-
-  let pretype_sort evdref = function
-    | GProp c -> judge_of_prop_contents c
-    | GType _ -> evd_comb0 judge_of_new_Type evdref
-
-  exception Found of fixpoint
-
-  let new_type_evar evdref env loc =
-    evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,InternalHole)) evdref
-
-  (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
-  (* in environment [env], with existential variables [evdref] and *)
-  (* the type constraint tycon *)
-  let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t =
-    let pretype = pretype resolve_tc in
-    let pretype_type = pretype_type resolve_tc in
-    let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
-    match t with
-    | GRef (loc,ref) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_ref loc evdref env ref)
-	  tycon
-
-    | GVar (loc, id) ->
-	inh_conv_coerce_to_tycon loc env evdref
-	  (pretype_id loc env !evdref lvar id)
-	  tycon
-
-    | GEvar (loc, evk, instopt) ->
-	(* Ne faudrait-il pas s'assurer que hyps est bien un
-	   sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
-	let hyps = evar_filtered_context (Evd.find !evdref evk) in
-	let args = match instopt with
-          | None -> instance_from_named_context hyps
-          | Some inst -> failwith "Evar subtitutions not implemented" in
-	let c = mkEvar (evk, args) in
-	let j = (Retyping.get_judgment_of env !evdref c) in
-	  inh_conv_coerce_to_tycon loc env evdref j tycon
-
-    | GPatVar (loc,(someta,n)) ->
-	let ty =
-          match tycon with
-            | Some (None, ty) -> ty
-            | None | Some _ -> new_type_evar evdref env loc in
-        let k = MatchingVar (someta,n) in
-	{ uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
-
-    | GHole (loc,k) ->
-	let ty =
-          match tycon with
-            | Some (None, ty) -> ty
-            | None | Some _ ->
-		new_type_evar evdref env loc in
-	  { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
-
-    | GRec (loc,fixkind,names,bl,lar,vdef) ->
-	let rec type_bl env ctxt = function
-            [] -> ctxt
-          | (na,bk,None,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let dcl = (na,None,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
-          | (na,bk,Some bd,ty)::bl ->
-              let ty' = pretype_type empty_valcon env evdref lvar ty in
-              let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in
-              let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
-		type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
-	let ctxtv = Array.map (type_bl env empty_rel_context) bl in
-	let larj =
-          array_map2
-            (fun e ar ->
-               pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
-            ctxtv lar in
-	let lara = Array.map (fun a -> a.utj_val) larj in
-	let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
-	let nbfix = Array.length lar in
-	let names = Array.map (fun id -> Name id) names in
-	  (* Note: bodies are not used by push_rec_types, so [||] is safe *)
-	let newenv = push_rec_types (names,ftys,[||]) env in
-	let vdefj =
-	  array_map2_i
-	    (fun i ctxt def ->
-               (* we lift nbfix times the type in tycon, because of
-		* the nbfix variables pushed to newenv *)
-               let (ctxt,ty) =
-		 decompose_prod_n_assum (rel_context_length ctxt)
-                   (lift nbfix ftys.(i)) in
-               let nenv = push_rel_context ctxt newenv in
-               let j = pretype (mk_tycon ty) nenv evdref lvar def in
-		 { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
-		   uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
-            ctxtv vdef in
-	evar_type_fixpoint loc env evdref names ftys vdefj;
-	let ftys = Array.map (nf_evar !evdref) ftys in
-	let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
- 	let fixj = match fixkind with
-	  | GFix (vn,i) ->
+        (* Check if [id] is a ltac variable not bound to a term *)
+	(* and build a nice error message *)
+      if Id.Map.mem id lvar.ltac_genargs then
+	user_err_loc (loc,"",
+          str "Variable " ++ pr_id id ++ str " should be bound to a term.");
+      (* Check if [id] is a section or goal variable *)
+      try
+	let (_,_,typ) = lookup_named id env in
+	(* let _ =  *)
+	(*   try  *)
+   	(*     let ctx = Decls.variable_context id in *)
+	(*       evdref := Evd.merge_context_set univ_rigid !evdref ctx; *)
+	(*   with Not_found -> () *)
+	(* in *)
+	  { uj_val  = mkVar id; uj_type = typ }
+      with Not_found ->
+	  (* [id] not found, standard error message *)
+	  error_var_not_found_loc loc id
+
+let evar_kind_of_term sigma c =
+  kind_of_term (whd_evar sigma c)
+
+(*************************************************************************)
+(* Main pretyping function                                               *)
+
+let interp_universe_level_name evd = function
+  | GProp -> evd, Univ.Level.prop
+  | GSet -> evd, Univ.Level.set
+  | GType s -> interp_universe_level evd s
+
+let pretype_global loc rigid env evd gr us = 
+  let evd, instance = 
+    match us with
+    | None -> evd, None
+    | Some l -> 
+      let _, ctx = Universes.unsafe_constr_of_global gr in
+      let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in
+      let len = Array.length arr in
+	if len != List.length l then
+	  user_err_loc (loc, "pretype", 
+			str "Universe instance should have length " ++ int len)
+	else
+	  let evd, l' = List.fold_left (fun (evd, univs) l -> 
+	    let evd, l = interp_universe_level_name evd l in
+	      (evd, l :: univs)) (evd, []) l
+      in 
+	evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l')))
+  in
+    Evd.fresh_global ~rigid ?names:instance env evd gr
+
+let pretype_ref loc evdref env ref us =
+  match ref with
+  | VarRef id ->
+      (* Section variable *)
+      (try let (_,_,ty) = lookup_named id env in
+	     make_judge (mkVar id) ty
+       with Not_found ->
+         (* This may happen if env is a goal env and section variables have
+            been cleared - section variables should be different from goal
+            variables *)
+         Pretype_errors.error_var_not_found_loc loc id)
+  | ref ->
+    let evd, c = pretype_global loc univ_flexible env !evdref ref us in
+    let () = evdref := evd in
+    let ty = Typing.type_of env evd c in
+      make_judge c ty
+
+let judge_of_Type evd s =
+  let evd, s = interp_universe evd s in
+  let judge = 
+    { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }
+  in
+    evd, judge
+
+let pretype_sort evdref = function
+  | GProp -> judge_of_prop
+  | GSet -> judge_of_set
+  | GType s -> evd_comb1 judge_of_Type evdref s
+
+let new_type_evar env evdref loc =
+  let e, s = 
+    evd_comb0 (fun evd -> Evarutil.new_type_evar env evd univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref
+  in e
+
+let get_projection env cst =
+  let cb = lookup_constant cst env in
+    match cb.Declarations.const_proj with
+    | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> 
+      (cst,mind,n,m,ty)
+    | None -> raise Not_found
+
+let (f_genarg_interp, genarg_interp_hook) = Hook.make ()
+
+(* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
+(* in environment [env], with existential variables [evdref] and *)
+(* the type constraint tycon *)
+
+let is_GHole = function
+  | GHole _ -> true
+  | _ -> false
+
+let evars = ref Id.Map.empty
+
+let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t =
+  let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in
+  let pretype_type = pretype_type resolve_tc in
+  let pretype = pretype resolve_tc in
+  match t with
+  | GRef (loc,ref,u) ->
+      inh_conv_coerce_to_tycon loc env evdref
+	(pretype_ref loc evdref env ref u)
+	tycon
+
+  | GVar (loc, id) ->
+    inh_conv_coerce_to_tycon loc env evdref
+      (pretype_id (fun e r l t -> pretype tycon e r l t) loc env evdref lvar id)
+      tycon
+
+  | GEvar (loc, id, inst) ->
+      (* Ne faudrait-il pas s'assurer que hyps est bien un
+	 sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
+      let evk =
+        try Evd.evar_key id !evdref
+        with Not_found ->
+          user_err_loc (loc,"",str "Unknown existential variable.") in
+      let hyps = evar_filtered_context (Evd.find !evdref evk) in
+      let args = pretype_instance resolve_tc env evdref lvar loc hyps evk inst in
+      let c = mkEvar (evk, args) in
+      let j = (Retyping.get_judgment_of env !evdref c) in
+	inh_conv_coerce_to_tycon loc env evdref j tycon
+
+  | GPatVar (loc,(someta,n)) ->
+    let ty =
+      match tycon with
+      | Some ty -> ty
+      | None -> new_type_evar env evdref loc in
+    let k = Evar_kinds.MatchingVar (someta,n) in
+      { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty }
+
+  | GHole (loc, k, naming, None) ->
+      let ty =
+        match tycon with
+        | Some ty -> ty
+        | None ->
+          new_type_evar env evdref loc in
+        { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty }
+
+  | GHole (loc, k, _naming, Some arg) ->
+      let ty =
+        match tycon with
+        | Some ty -> ty
+        | None ->
+          new_type_evar env evdref loc in
+      let ist = lvar.ltac_genargs in
+      let (c, sigma) = Hook.get f_genarg_interp ty env !evdref ist arg in
+      let () = evdref := sigma in
+      { uj_val = c; uj_type = ty }
+
+  | GRec (loc,fixkind,names,bl,lar,vdef) ->
+    let rec type_bl env ctxt = function
+    [] -> ctxt
+      | (na,bk,None,ty)::bl ->
+        let ty' = pretype_type empty_valcon env evdref lvar ty in
+        let dcl = (na,None,ty'.utj_val) in
+	  type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
+      | (na,bk,Some bd,ty)::bl ->
+        let ty' = pretype_type empty_valcon env evdref lvar ty in
+        let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in
+        let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
+	  type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
+    let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+    let larj =
+      Array.map2
+        (fun e ar ->
+          pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
+        ctxtv lar in
+    let lara = Array.map (fun a -> a.utj_val) larj in
+    let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
+    let nbfix = Array.length lar in
+    let names = Array.map (fun id -> Name id) names in
+    let _ = 
+      match tycon with
+      | Some t -> 
+ 	let fixi = match fixkind with
+	  | GFix (vn,i) -> i
+	  | GCoFix i -> i
+	in e_conv env evdref ftys.(fixi) t
+      | None -> true
+    in
+      (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+    let newenv = push_rec_types (names,ftys,[||]) env in
+    let vdefj =
+      Array.map2_i
+	(fun i ctxt def ->
+             (* we lift nbfix times the type in tycon, because of
+	      * the nbfix variables pushed to newenv *)
+          let (ctxt,ty) =
+	    decompose_prod_n_assum (rel_context_length ctxt)
+              (lift nbfix ftys.(i)) in
+          let nenv = push_rel_context ctxt newenv in
+          let j = pretype (mk_tycon ty) nenv evdref lvar def in
+	    { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+	      uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+        ctxtv vdef in
+      evar_type_fixpoint loc env evdref names ftys vdefj;
+      let ftys = Array.map (nf_evar !evdref) ftys in
+      let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
+      let fixj = match fixkind with
+	| GFix (vn,i) ->
 	      (* First, let's find the guard indexes. *)
 	      (* If recursive argument was not given by user, we try all args.
 	         An earlier approach was to look only for inductive arguments,
 		 but doing it properly involves delta-reduction, and it finally
                  doesn't seem worth the effort (except for huge mutual
 		 fixpoints ?) *)
-	      let possible_indexes = Array.to_list (Array.mapi
-		(fun i (n,_) -> match n with
-		   | Some n -> [n]
-		   | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
-		vn)
-	      in
-	      let fixdecls = (names,ftys,fdefs) in
-	      let indexes = search_guard loc env possible_indexes fixdecls in
-	      make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
-	  | GCoFix i ->
-	      let cofix = (i,(names,ftys,fdefs)) in
-	      (try check_cofix env cofix
-               with e when Errors.noncritical e -> Loc.raise loc e);
-	      make_judge (mkCoFix cofix) ftys.(i) in
+	  let possible_indexes =
+	    Array.to_list (Array.mapi
+			     (fun i (n,_) -> match n with
+			     | Some n -> [n]
+			     | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i))
+			     vn)
+	  in
+	  let fixdecls = (names,ftys,fdefs) in
+	  let indexes = search_guard loc env possible_indexes fixdecls in
+	    make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i)
+	| GCoFix i ->
+	  let cofix = (i,(names,ftys,fdefs)) in
+	    (try check_cofix env cofix
+             with reraise ->
+               let (e, info) = Errors.push reraise in
+               let info = Loc.add_loc info loc in
+               iraise (e, info));
+	    make_judge (mkCoFix cofix) ftys.(i)
+      in
 	inh_conv_coerce_to_tycon loc env evdref fixj tycon
 
-    | GSort (loc,s) ->
-	let j = pretype_sort evdref s in
-	  inh_conv_coerce_to_tycon loc env evdref j tycon
-
-    | GApp (loc,f,args) ->
-	let fj = pretype empty_tycon env evdref lvar f in
- 	let floc = loc_of_glob_constr f in
-	let rec apply_rec env n resj = function
-	  | [] -> resj
-	  | c::rest ->
-	      let argloc = loc_of_glob_constr c in
-	      let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
-              let resty = whd_betadeltaiota env !evdref resj.uj_type in
-      		match kind_of_term resty with
-		  | Prod (na,c1,c2) ->
-		      let hj = pretype (mk_tycon c1) env evdref lvar c in
-		      let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
-			apply_rec env (n+1)
-			  { uj_val = value;
-			    uj_type = typ }
-			  rest
-		  | _ ->
-		      let hj = pretype empty_tycon env evdref lvar c in
-			error_cant_apply_not_functional_loc
-			  (join_loc floc argloc) env !evdref
-	      		  resj [hj]
-	in
-	let resj = apply_rec env 1 fj args in
-	let resj =
-	  match evar_kind_of_term !evdref resj.uj_val with
-	  | App (f,args) ->
-              let f = whd_evar !evdref f in
-              begin match kind_of_term f with
-              | Ind _ | Const _
-		  when isInd f or has_polymorphic_type (destConst f)
-		    ->
-	          let sigma =  !evdref in
-		  let c = mkApp (f,Array.map (whd_evar sigma) args) in
-	          let t = Retyping.get_type_of env sigma c in
-		  make_judge c (* use this for keeping evars: resj.uj_val *) t
-              | _ -> resj end
-	  | _ -> resj in
-	inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLambda(loc,name,bk,c1,c2)      ->
-	let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon in
-	let dom_valcon = valcon_of_tycon dom in
-	let j = pretype_type dom_valcon env evdref lvar c1 in
-	let var = (name,None,j.utj_val) in
-	let j' = pretype rng (push_rel var env) evdref lvar c2 in
-	  judge_of_abstraction env (orelse_name name name') j j'
-
-    | GProd(loc,name,bk,c1,c2)        ->
-	let j = pretype_type empty_valcon env evdref lvar c1 in
-	let j' =
-	  if name = Anonymous then
-	    let j = pretype_type empty_valcon env evdref lvar c2 in
-	      { j with utj_val = lift 1 j.utj_val }
-	  else
-	    let var = (name,j.utj_val) in
-	    let env' = push_rel_assum var env in
-	      pretype_type empty_valcon env' evdref lvar c2
-	in
-	let resj =
-	  try judge_of_product env name j j'
-	  with TypeError _ as e -> Loc.raise loc e in
-	  inh_conv_coerce_to_tycon loc env evdref resj tycon
-
-    | GLetIn(loc,name,c1,c2)      ->
-	let j =
-	  match c1 with
-	  | GCast (loc, c, CastConv (DEFAULTcast, t)) ->
-	      let tj = pretype_type empty_valcon env evdref lvar t in
-		pretype (mk_tycon tj.utj_val) env evdref lvar c
-	  | _ -> pretype empty_tycon env evdref lvar c1
-	in
-	let t = refresh_universes j.uj_type in
-	let var = (name,Some j.uj_val,t) in
-        let tycon = lift_tycon 1 tycon in
-	let j' = pretype tycon (push_rel var env) evdref lvar c2 in
-	  { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
-	    uj_type = subst1 j.uj_val j'.uj_type }
-
-    | GLetTuple (loc,nal,(na,po),c,d) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj
-	in
-	let cstrs = get_constructors env indf in
-	  if Array.length cstrs <> 1 then
-            user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor.");
-	  let cs = cstrs.(0) in
-	    if List.length nal <> cs.cs_nargs then
-              user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables.");
-	    let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
-              (List.rev nal) cs.cs_args in
-	    let env_f = push_rels fsign env in
-	      (* Make dependencies from arity signature impossible *)
-	    let arsgn =
-	      let arsgn,_ = get_arity env indf in
-		if not !allow_anonymous_refs then
-		  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-		else arsgn
+  | GSort (loc,s) ->
+    let j = pretype_sort evdref s in
+      inh_conv_coerce_to_tycon loc env evdref j tycon
+
+  | GApp (loc,f,args) ->
+    let fj = pretype empty_tycon env evdref lvar f in
+    let floc = loc_of_glob_constr f in
+    let length = List.length args in
+    let candargs =
+	(* Bidirectional typechecking hint: 
+	   parameters of a constructor are completely determined
+	   by a typing constraint *)
+      if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then
+	match tycon with
+	| None -> []
+	| Some ty ->
+	  let ((ind, i), u) = destConstruct fj.uj_val in
+	  let npars = inductive_nparams ind in
+	    if Int.equal npars 0 then []
+	    else
+	      try
+	  	let IndType (indf, args) = find_rectype env !evdref ty in
+	  	let ((ind',u'),pars) = dest_ind_family indf in
+	  	  if eq_ind ind ind' then pars
+	  	  else (* Let the usual code throw an error *) []
+	      with Not_found -> []
+      else []
+    in
+    let app_f = 
+      match kind_of_term fj.uj_val with
+      | Const (p, u) when Environ.is_projection p env ->
+	let p = Projection.make p false in
+	let pb = Environ.lookup_projection p env in
+	let npars = pb.Declarations.proj_npars in
+	  fun n -> 
+	    if n == npars + 1 then fun _ v -> mkProj (p, v)
+	    else fun f v -> applist (f, [v])
+      | _ -> fun _ f v -> applist (f, [v])
+    in
+    let rec apply_rec env n resj candargs = function
+      | [] -> resj
+      | c::rest ->
+	let argloc = loc_of_glob_constr c in
+	let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in
+        let resty = whd_betadeltaiota env !evdref resj.uj_type in
+      	  match kind_of_term resty with
+	  | Prod (na,c1,c2) ->
+	    let tycon = Some c1 in
+	    let hj = pretype tycon env evdref lvar c in
+	    let candargs, ujval =
+	      match candargs with
+	      | [] -> [], j_val hj
+	      | arg :: args -> 
+		if e_conv env evdref (j_val hj) arg then
+		  args, nf_evar !evdref (j_val hj)
+		else [], j_val hj
 	    in
-	    let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	    let nar = List.length arsgn in
-	      (match po with
-		 | Some p ->
-		     let env_p = push_rels psign env in
-		     let pj = pretype_type empty_valcon env_p evdref lvar p in
-		     let ccl = nf_evar !evdref pj.utj_val in
-		     let psign = make_arity_signature env true indf in (* with names *)
-		     let p = it_mkLambda_or_LetIn ccl psign in
-		     let inst =
-		       (Array.to_list cs.cs_concl_realargs)
-		       @[build_dependent_constructor cs] in
-		     let lp = lift cs.cs_nargs p in
-		     let fty = hnf_lam_applist env !evdref lp inst in
-		     let fj = pretype (mk_tycon fty) env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let v =
-		       let ind,_ = dest_ind_family indf in
-		       let ci = make_case_info env ind LetStyle in
-		       Typing.check_allowed_sort env !evdref ind cj.uj_val p;
-		       mkCase (ci, p, cj.uj_val,[|f|]) in
-		     { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
-
-		 | None ->
-		     let tycon = lift_tycon cs.cs_nargs tycon in
-		     let fj = pretype tycon env_f evdref lvar d in
-		     let f = it_mkLambda_or_LetIn fj.uj_val fsign in
-		     let ccl = nf_evar !evdref fj.uj_type in
-		     let ccl =
-		       if noccur_between 1 cs.cs_nargs ccl then
-			 lift (- cs.cs_nargs) ccl
-		       else
-			 error_cant_find_case_type_loc loc env !evdref
-			   cj.uj_val in
-		     let ccl = refresh_universes ccl in
-		     let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
-		     let v =
-		       let ind,_ = dest_ind_family indf in
-		       let ci = make_case_info env ind LetStyle in
-		       Typing.check_allowed_sort env !evdref ind cj.uj_val p;
-		       mkCase (ci, p, cj.uj_val,[|f|])
-		     in { uj_val = v; uj_type = ccl })
-
-    | GIf (loc,c,(na,po),b1,b2) ->
-	let cj = pretype empty_tycon env evdref lvar c in
-	let (IndType (indf,realargs)) =
-	  try find_rectype env !evdref cj.uj_type
-	  with Not_found ->
-	    let cloc = loc_of_glob_constr c in
-	      error_case_not_inductive_loc cloc env !evdref cj in
-	let cstrs = get_constructors env indf in
-	  if Array.length cstrs <> 2 then
-            user_err_loc (loc,"",
-			  str "If is only for inductive types with two constructors.");
-
-	  let arsgn =
-	    let arsgn,_ = get_arity env indf in
-	      if not !allow_anonymous_refs then
-		(* Make dependencies from arity signature impossible *)
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
-	      else arsgn
-	  in
-	  let nar = List.length arsgn in
-	  let psign = (na,None,build_dependent_inductive env indf)::arsgn in
-	  let pred,p = match po with
-	    | Some p ->
-		let env_p = push_rels psign env in
-		let pj = pretype_type empty_valcon env_p evdref lvar p in
-		let ccl = nf_evar !evdref pj.utj_val in
-		let pred = it_mkLambda_or_LetIn ccl psign in
-		let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
-	        pred, typ
-	    | None ->
-		let p = match tycon with
-		  | Some (None, ty) -> ty
-		  | None | Some _ -> new_type_evar evdref env loc
-		in
-		  it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
-	  let pred = nf_evar !evdref pred in
-	  let p = nf_evar !evdref p in
-	  let f cs b =
-	    let n = rel_context_length cs.cs_args in
-	    let pi = lift n pred in (* liftn n 2 pred ? *)
-	    let pi = beta_applist (pi, [build_dependent_constructor cs]) in
-	    let csgn =
-	      if not !allow_anonymous_refs then
-		List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
-	      else
-		List.map
-		  (fun (n, b, t) ->
-		     match n with
-                         Name _ -> (n, b, t)
-                       | Anonymous -> (Name (id_of_string "H"), b, t))
-		cs.cs_args
+	    let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in
+	    let j = { uj_val = value; uj_type = typ } in
+	      apply_rec env (n+1) j candargs rest
+		
+	  | _ ->
+	    let hj = pretype empty_tycon env evdref lvar c in
+	      error_cant_apply_not_functional_loc
+		(Loc.merge floc argloc) env !evdref
+	      	resj [hj]
+    in
+    let resj = apply_rec env 1 fj candargs args in
+    let resj =
+      match evar_kind_of_term !evdref resj.uj_val with
+      | App (f,args) ->
+        let f = whd_evar !evdref f in
+          if isInd f && is_template_polymorphic env f then
+	    (* Special case for inductive type applications that must be 
+	       refreshed right away. *)
+	    let sigma = !evdref in
+	    let c = mkApp (f,Array.map (whd_evar sigma) args) in
+	    let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env) evdref c in
+	    let t = Retyping.get_type_of env !evdref c in
+	      make_judge c (* use this for keeping evars: resj.uj_val *) t
+	  else resj
+      | _ -> resj 
+    in
+      inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+  | GLambda(loc,name,bk,c1,c2)      ->
+    let tycon' = evd_comb1
+      (fun evd tycon ->
+	match tycon with
+	| None -> evd, tycon
+	| Some ty ->
+	  let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
+	    evd, Some ty')
+      evdref tycon
+    in
+    let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+    let dom_valcon = valcon_of_tycon dom in
+    let j = pretype_type dom_valcon env evdref lvar c1 in
+    (* The name specified by ltac is used also to create bindings. So
+       the substitution must also be applied on variables before they are
+       looked up in the rel context. *)
+    let name = ltac_interp_name lvar name in
+    let var = (name,None,j.utj_val) in
+    let j' = pretype rng (push_rel var env) evdref lvar c2 in
+    let resj = judge_of_abstraction env (orelse_name name name') j j' in
+      inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+  | GProd(loc,name,bk,c1,c2)        ->
+    let j = pretype_type empty_valcon env evdref lvar c1 in
+    (* The name specified by ltac is used also to create bindings. So
+       the substitution must also be applied on variables before they are
+       looked up in the rel context. *)
+    let name = ltac_interp_name lvar name in
+    let j' = match name with
+      | Anonymous ->
+        let j = pretype_type empty_valcon env evdref lvar c2 in
+          { j with utj_val = lift 1 j.utj_val }
+      | Name _ ->
+        let var = (name,j.utj_val) in
+        let env' = push_rel_assum var env in
+          pretype_type empty_valcon env' evdref lvar c2
+    in
+    let resj =
+      try
+        judge_of_product env name j j'
+      with TypeError _ as e ->
+        let (e, info) = Errors.push e in
+        let info = Loc.add_loc info loc in
+        iraise (e, info) in
+      inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+  | GLetIn(loc,name,c1,c2)      ->
+    let j =
+      match c1 with
+      | GCast (loc, c, CastConv t) ->
+	let tj = pretype_type empty_valcon env evdref lvar t in
+	  pretype (mk_tycon tj.utj_val) env evdref lvar c
+      | _ -> pretype empty_tycon env evdref lvar c1
+    in
+    let t = j.uj_type in
+    (* The name specified by ltac is used also to create bindings. So
+       the substitution must also be applied on variables before they are
+       looked up in the rel context. *)
+    let name = ltac_interp_name lvar name in
+    let var = (name,Some j.uj_val,t) in
+    let tycon = lift_tycon 1 tycon in
+    let j' = pretype tycon (push_rel var env) evdref lvar c2 in
+      { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
+	uj_type = subst1 j.uj_val j'.uj_type }
+
+  | GLetTuple (loc,nal,(na,po),c,d) ->
+    let cj = pretype empty_tycon env evdref lvar c in
+    let (IndType (indf,realargs)) =
+      try find_rectype env !evdref cj.uj_type
+      with Not_found ->
+	let cloc = loc_of_glob_constr c in
+	  error_case_not_inductive_loc cloc env !evdref cj
+    in
+    let cstrs = get_constructors env indf in
+    if not (Int.equal (Array.length cstrs) 1) then
+      user_err_loc (loc,"",str "Destructing let is only for inductive types" ++
+	str " with one constructor.");
+    let cs = cstrs.(0) in
+    if not (Int.equal (List.length nal) cs.cs_nargs) then
+      user_err_loc (loc,"", str "Destructing let on this type expects " ++ 
+	int cs.cs_nargs ++ str " variables.");
+    let nal = List.map (fun na -> ltac_interp_name lvar na) nal in
+    let na = ltac_interp_name lvar na in
+    let fsign, record = 
+      match get_projections env indf with
+      | None -> List.map2 (fun na (_,c,t) -> (na,c,t))
+	(List.rev nal) cs.cs_args, false
+      | Some ps ->
+	let rec aux n k names l =
+	  match names, l with
+	  | na :: names, ((_, None, t) :: l) -> 
+	    let proj = Projection.make ps.(cs.cs_nargs - k) true in
+	      (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t)
+	    :: aux (n+1) (k + 1) names l
+	  | na :: names, ((_, c, t) :: l) -> 
+	    (na, c, t) :: aux (n+1) k names l
+	  | [], [] -> []
+	  | _ -> assert false
+	in aux 1 1 (List.rev nal) cs.cs_args, true
+    in
+    let obj ind p v f =
+      if not record then 
+	let f = it_mkLambda_or_LetIn f fsign in
+	let ci = make_case_info env (fst ind) LetStyle in
+	  mkCase (ci, p, cj.uj_val,[|f|]) 
+      else it_mkLambda_or_LetIn f fsign
+    in
+    let env_f = push_rel_context fsign env in
+      (* Make dependencies from arity signature impossible *)
+    let arsgn =
+      let arsgn,_ = get_arity env indf in
+	if not !allow_anonymous_refs then
+	  List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	else arsgn
+    in
+      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let nar = List.length arsgn in
+	  (match po with
+	  | Some p ->
+	    let env_p = push_rel_context psign env in
+	    let pj = pretype_type empty_valcon env_p evdref lvar p in
+	    let ccl = nf_evar !evdref pj.utj_val in
+	    let psign = make_arity_signature env true indf in (* with names *)
+	    let p = it_mkLambda_or_LetIn ccl psign in
+	    let inst =
+	      (Array.to_list cs.cs_concl_realargs)
+	      @[build_dependent_constructor cs] in
+	    let lp = lift cs.cs_nargs p in
+	    let fty = hnf_lam_applist env !evdref lp inst in
+	    let fj = pretype (mk_tycon fty) env_f evdref lvar d in
+	    let v =
+	      let ind,_ = dest_ind_family indf in
+		Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+		obj ind p cj.uj_val fj.uj_val
 	    in
-	    let env_c = push_rels csgn env in
-	    let bj = pretype (mk_tycon pi) env_c evdref lvar b in
-	      it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
-	  let b1 = f cstrs.(0) b1 in
-	  let b2 = f cstrs.(1) b2 in
-	  let v =
-	    let ind,_ = dest_ind_family indf in
-	    let ci = make_case_info env ind IfStyle in
-	    let pred = nf_evar !evdref pred in
-	    Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
-	    mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+	      { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+	  | None ->
+	    let tycon = lift_tycon cs.cs_nargs tycon in
+	    let fj = pretype tycon env_f evdref lvar d in
+	    let ccl = nf_evar !evdref fj.uj_type in
+	    let ccl =
+	      if noccur_between 1 cs.cs_nargs ccl then
+		lift (- cs.cs_nargs) ccl
+	      else
+		error_cant_find_case_type_loc loc env !evdref
+		  cj.uj_val in
+		 (* let ccl = refresh_universes ccl in *)
+	    let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
+	    let v =
+	      let ind,_ = dest_ind_family indf in
+		Typing.check_allowed_sort env !evdref ind cj.uj_val p;
+		obj ind p cj.uj_val fj.uj_val
+	    in { uj_val = v; uj_type = ccl })
+
+  | GIf (loc,c,(na,po),b1,b2) ->
+    let cj = pretype empty_tycon env evdref lvar c in
+    let (IndType (indf,realargs)) =
+      try find_rectype env !evdref cj.uj_type
+      with Not_found ->
+	let cloc = loc_of_glob_constr c in
+	  error_case_not_inductive_loc cloc env !evdref cj in
+    let cstrs = get_constructors env indf in
+      if not (Int.equal (Array.length cstrs) 2) then
+        user_err_loc (loc,"",
+		      str "If is only for inductive types with two constructors.");
+
+      let arsgn =
+	let arsgn,_ = get_arity env indf in
+	  if not !allow_anonymous_refs then
+	      (* Make dependencies from arity signature impossible *)
+	    List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+	  else arsgn
+      in
+      let nar = List.length arsgn in
+      let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+      let pred,p = match po with
+	| Some p ->
+	  let env_p = push_rel_context psign env in
+	  let pj = pretype_type empty_valcon env_p evdref lvar p in
+	  let ccl = nf_evar !evdref pj.utj_val in
+	  let pred = it_mkLambda_or_LetIn ccl psign in
+	  let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
+	    pred, typ
+	| None ->
+	  let p = match tycon with
+	    | Some ty -> ty
+	    | None -> new_type_evar env evdref loc
 	  in
-	    { uj_val = v; uj_type = p }
-
-    | GCases (loc,sty,po,tml,eqns) ->
-	Cases.compile_cases loc sty
-	  ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
-	  tycon env (* loc *) (po,tml,eqns)
-
-    | GCast (loc,c,k) ->
-	let cj =
-	  match k with
-	      CastCoerce ->
-		let cj = pretype empty_tycon env evdref lvar c in
-		  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
-	    | CastConv (k,t) ->
-		let tj = pretype_type empty_valcon env evdref lvar t in
- 		let cj = pretype empty_tycon env evdref lvar c in
-		let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
-		let cj = match k with
-		  | VMcast ->
-                      if not (occur_existential cty || occur_existential tval) then
-		      begin 
-			try 
-			  ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
-			with Reduction.NotConvertible -> 
-			  error_actual_type_loc loc env !evdref cj tval 
-		      end
-                      else user_err_loc (loc,"",str "Cannot check cast with vm: unresolved arguments remain.")
-		  | _ -> inh_conv_coerce_to_tycon loc env evdref cj (mk_tycon tval)
-		in
-		let v = mkCast (cj.uj_val, k, tval) in
-		  { uj_val = v; uj_type = tval }
-	in inh_conv_coerce_to_tycon loc env evdref cj tycon
-
-  (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
-  and pretype_type resolve_tc valcon env evdref lvar = function
-    | GHole loc ->
-	(match valcon with
-	   | Some v ->
-               let s =
-		 let sigma =  !evdref in
-		 let t = Retyping.get_type_of env sigma v in
-		   match kind_of_term (whd_betadeltaiota env sigma t) with
-                     | Sort s -> s
-                     | Evar ev when is_Type (existential_type sigma ev) ->
-			 evd_comb1 (define_evar_as_sort) evdref ev
-                     | _ -> anomaly "Found a type constraint which is not a type"
-               in
-		 { utj_val = v;
-		   utj_type = s }
-	   | None ->
-	       let s = evd_comb0 new_sort_variable evdref in
-		 { utj_val = e_new_evar evdref env ~src:loc (mkSort s);
-		   utj_type = s})
-    | c ->
-	let j = pretype resolve_tc empty_tycon env evdref lvar c in
-	let loc = loc_of_glob_constr c in
-	let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
-	  match valcon with
-	    | None -> tj
-	    | Some v ->
-		if e_cumul env evdref v tj.utj_val then tj
-		else
-		  error_unexpected_type_loc
-                    (loc_of_glob_constr c) env !evdref tj.utj_val v
-
-  let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
-    let c' = match kind with
-      | OfType exptyp ->
-	  let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
-	  (pretype resolve_classes tycon env evdref lvar c).uj_val
-      | IsType ->
-	  (pretype_type resolve_classes empty_valcon env evdref lvar c).utj_val 
+	    it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+      let pred = nf_evar !evdref pred in
+      let p = nf_evar !evdref p in
+      let f cs b =
+	let n = rel_context_length cs.cs_args in
+	let pi = lift n pred in (* liftn n 2 pred ? *)
+	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+	let csgn =
+	  if not !allow_anonymous_refs then
+	    List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+	  else
+	    List.map
+	      (fun (n, b, t) ->
+		match n with
+                  Name _ -> (n, b, t)
+                | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t))
+	      cs.cs_args
+	in
+	let env_c = push_rel_context csgn env in
+	let bj = pretype (mk_tycon pi) env_c evdref lvar b in
+	  it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
+      let b1 = f cstrs.(0) b1 in
+      let b2 = f cstrs.(1) b2 in
+      let v =
+	let ind,_ = dest_ind_family indf in
+	let ci = make_case_info env (fst ind) IfStyle in
+	let pred = nf_evar !evdref pred in
+	  Typing.check_allowed_sort env !evdref ind cj.uj_val pred;
+	  mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+      in
+      let cj = { uj_val = v; uj_type = p } in
+      inh_conv_coerce_to_tycon loc env evdref cj tycon
+
+  | GCases (loc,sty,po,tml,eqns) ->
+    let (tml,eqns) =
+      Glob_ops.map_pattern_binders (fun na -> ltac_interp_name lvar na) tml eqns
     in
-      resolve_evars env evdref fail_evar resolve_classes;
-      let c = if expand_evar then nf_evar !evdref c' else c' in
-	if fail_evar then check_evars env Evd.empty !evdref c;
-	c
-
-  (* TODO: comment faire remonter l'information si le typage a resolu des
-     variables du sigma original. il faudrait que la fonction de typage
-     retourne aussi le nouveau sigma...
-  *)
-
-  let understand_judgment sigma env c =
-    let evdref = ref sigma in
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-      resolve_evars env evdref true true;
-      let j = j_nf_evar !evdref j in
-	check_evars env sigma !evdref (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
-	j
-
-  let understand_judgment_tcc evdref env c =
-    let j = pretype true empty_tycon env evdref ([],[]) c in
-      resolve_evars env evdref false true;
-      j_nf_evar !evdref j
-
-  (* Raw calls to the unsafe inference machine: boolean says if we must
-     fail on unresolved evars; the unsafe_judgment list allows us to
-     extend env with some bindings *)
-
-  let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
-    let evdref = ref sigma in
-    let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
-    !evdref, c
-
-  (** Entry points of the high-level type synthesis algorithm *)
-
-  let understand_gen kind sigma env c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
-
-  let understand sigma env ?expected_type:exptyp c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
-
-  let understand_type sigma env c =
-    snd (ise_pretype_gen true true true sigma env ([],[]) IsType c)
-
-  let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
-    ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
-
-  let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
-    ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
-
-  let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
-    pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
-end
-
-module Default : S = Pretyping_F(Coercion.Default)
+    Cases.compile_cases loc sty
+      ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref)
+      tycon env (* loc *) (po,tml,eqns)
+
+  | GCast (loc,c,k) ->
+    let cj =
+      match k with
+      | CastCoerce ->
+	let cj = pretype empty_tycon env evdref lvar c in
+	  evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
+      | CastConv t | CastVM t | CastNative t ->
+	let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in
+	let tj = pretype_type empty_valcon env evdref lvar t in
+	let tval = nf_evar !evdref tj.utj_val in
+	let cj = match k with
+	  | VMcast ->
+ 	    let cj = pretype empty_tycon env evdref lvar c in
+	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+	      if not (occur_existential cty || occur_existential tval) then
+		begin 
+		  try 
+		    ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj
+		  with Reduction.NotConvertible -> 
+		    error_actual_type_loc loc env !evdref cj tval 
+                      (ConversionFailed (env,cty,tval))
+		end
+	      else user_err_loc (loc,"",str "Cannot check cast with vm: " ++
+		str "unresolved arguments remain.")
+	  | NATIVEcast ->
+ 	    let cj = pretype empty_tycon env evdref lvar c in
+	    let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in
+            let evars = Nativenorm.evars_of_evar_map !evdref in
+            begin
+              try
+                ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj
+              with Reduction.NotConvertible -> 
+                error_actual_type_loc loc env !evdref cj tval 
+                  (ConversionFailed (env,cty,tval))
+            end
+	  | _ -> 
+ 	    pretype (mk_tycon tval) env evdref lvar c
+	in
+	let v = mkCast (cj.uj_val, k, tval) in
+	  { uj_val = v; uj_type = tval }
+    in inh_conv_coerce_to_tycon loc env evdref cj tycon
+
+and pretype_instance resolve_tc env evdref lvar loc hyps evk update =
+  let f (id,_,t) (subst,update) =
+    let t = replace_vars subst t in
+    let c, update =
+      try
+        let c = List.assoc id update in
+        let c = pretype resolve_tc (mk_tycon t) env evdref lvar c in
+        c.uj_val, List.remove_assoc id update
+      with Not_found ->
+      try
+        let (n,_,t') = lookup_rel_id id (rel_context env) in
+        if is_conv env !evdref t t' then mkRel n, update else raise Not_found
+      with Not_found ->
+      try
+        let (_,_,t') = lookup_named id env in
+        if is_conv env !evdref t t' then mkVar id, update else raise Not_found
+      with Not_found ->
+        user_err_loc (loc,"",str "Cannot interpret " ++
+          pr_existential_key !evdref evk ++
+          str " in current context: no binding for " ++ pr_id id ++ str ".") in
+    ((id,c)::subst, update) in
+  let subst,inst = List.fold_right f hyps ([],update) in
+  check_instance loc subst inst;
+  Array.map_of_list snd subst
+
+(* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
+and pretype_type resolve_tc valcon env evdref lvar = function
+  | GHole (loc, knd, naming, None) ->
+      (match valcon with
+       | Some v ->
+           let s =
+	     let sigma =  !evdref in
+	     let t = Retyping.get_type_of env sigma v in
+	       match kind_of_term (whd_betadeltaiota env sigma t) with
+               | Sort s -> s
+               | Evar ev when is_Type (existential_type sigma ev) ->
+		   evd_comb1 (define_evar_as_sort env) evdref ev
+               | _ -> anomaly (Pp.str "Found a type constraint which is not a type")
+           in
+	     { utj_val = v;
+	       utj_type = s }
+       | None ->
+	   let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in
+	     { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s);
+	       utj_type = s})
+  | c ->
+      let j = pretype resolve_tc empty_tycon env evdref lvar c in
+      let loc = loc_of_glob_constr c in
+      let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
+	match valcon with
+	| None -> tj
+	| Some v ->
+	    if e_cumul env evdref v tj.utj_val then tj
+	    else
+	      error_unexpected_type_loc
+                (loc_of_glob_constr c) env !evdref tj.utj_val v
+
+let ise_pretype_gen flags env sigma lvar kind c =
+  let evdref = ref sigma in
+  let c' = match kind with
+    | WithoutTypeConstraint ->
+        (pretype flags.use_typeclasses empty_tycon env evdref lvar c).uj_val
+    | OfType exptyp ->
+	(pretype flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val
+    | IsType ->
+	(pretype_type flags.use_typeclasses empty_valcon env evdref lvar c).utj_val 
+  in
+  process_inference_flags flags env sigma (!evdref,c')
+
+let default_inference_flags fail = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = None;
+  fail_evar = fail;
+  expand_evars = true }
+
+let no_classes_no_fail_inference_flags = {
+  use_typeclasses = false;
+  use_unif_heuristics = true;
+  use_hook = None;
+  fail_evar = false;
+  expand_evars = true }
+
+let all_and_fail_flags = default_inference_flags true
+let all_no_fail_flags = default_inference_flags false
+
+let empty_lvar : ltac_var_map = {
+  ltac_constrs = Id.Map.empty;
+  ltac_uconstrs = Id.Map.empty;
+  ltac_idents = Id.Map.empty;
+  ltac_genargs = Id.Map.empty;
+}
+
+let on_judgment f j =
+  let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in
+  let (c,_,t) = destCast (f c) in
+  {uj_val = c; uj_type = t}
+
+let understand_judgment env sigma c =
+  let evdref = ref sigma in
+  let j = pretype true empty_tycon env evdref empty_lvar c in
+  let j = on_judgment (fun c ->
+    let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in 
+      evdref := evd; c) j
+  in j, Evd.evar_universe_context !evdref
+
+let understand_judgment_tcc env evdref c =
+  let j = pretype true empty_tycon env evdref empty_lvar c in
+  on_judgment (fun c ->
+    let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in
+    evdref := evd; c) j
+
+let ise_pretype_gen_ctx flags env sigma lvar kind c =
+  let evd, c = ise_pretype_gen flags env sigma lvar kind c in
+  let evd, f = Evarutil.nf_evars_and_universes evd in
+    f c, Evd.evar_universe_context evd
+
+(** Entry points of the high-level type synthesis algorithm *)
+
+let understand
+    ?(flags=all_and_fail_flags)
+    ?(expected_type=WithoutTypeConstraint)
+    env sigma c =
+  ise_pretype_gen_ctx flags env sigma empty_lvar expected_type c
+
+let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c =
+  ise_pretype_gen flags env sigma empty_lvar expected_type c
+
+let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=WithoutTypeConstraint) c =
+  let sigma, c = ise_pretype_gen flags env !evdref empty_lvar expected_type c in
+  evdref := sigma;
+  c
+
+let understand_ltac flags env sigma lvar kind c =
+  ise_pretype_gen flags env sigma lvar kind c
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index a785b432..7d1e0c9b 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.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        *)
@@ -13,113 +13,137 @@
    implicit arguments. *)
 
 open Names
-open Sign
 open Term
 open Environ
 open Evd
 open Glob_term
 open Evarutil
+open Misctypes
 
 (** An auxiliary function for searching for fixpoint guard indexes *)
 
 val search_guard :
-    Util.loc -> env -> int list list -> rec_declaration -> int array
+  Loc.t -> env -> int list list -> rec_declaration -> int array
 
-type typing_constraint = OfType of types option | IsType
+type typing_constraint = OfType of types | IsType | WithoutTypeConstraint
+
+type var_map = Pattern.constr_under_binders Id.Map.t
+type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t
+type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t
+
+type ltac_var_map = {
+  ltac_constrs : var_map;
+  (** Ltac variables bound to constrs *)
+  ltac_uconstrs : uconstr_var_map;
+  (** Ltac variables bound to untyped constrs *)
+  ltac_idents: Id.t Id.Map.t;
+  (** Ltac variables bound to identifiers *)
+  ltac_genargs : unbound_ltac_var_map;
+  (** Ltac variables bound to other kinds of arguments *)
+}
+
+val empty_lvar : ltac_var_map
 
-type var_map = (identifier * Pattern.constr_under_binders) list
-type unbound_ltac_var_map = (identifier * identifier option) list
-type ltac_var_map = var_map * unbound_ltac_var_map
 type glob_constr_ltac_closure = ltac_var_map * glob_constr
 type pure_open_constr = evar_map * constr
 
-module type S =
-sig
+type inference_flags = {
+  use_typeclasses : bool;
+  use_unif_heuristics : bool;
+  use_hook : (env -> evar_map -> evar -> constr) option;
+  fail_evar : bool;
+  expand_evars : bool
+}
 
-  module Cases : Cases.S
+val default_inference_flags : bool -> inference_flags
 
-  (** Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
-  val allow_anonymous_refs : bool ref
+val no_classes_no_fail_inference_flags : inference_flags
 
-  (** Generic call to the interpreter from glob_constr to open_constr, leaving
-     unresolved holes as evars and returning the typing contexts of
-     these evars. Work as [understand_gen] for the rest. *)
+val all_no_fail_flags : inference_flags
 
-  val understand_tcc : ?resolve_classes:bool ->
-    evar_map -> env -> ?expected_type:types -> glob_constr -> open_constr
+val all_and_fail_flags : inference_flags
 
-  val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool ->
-    evar_map ref -> env -> typing_constraint -> glob_constr -> constr
+(** Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+val allow_anonymous_refs : bool ref
+  
+(** Generic call to the interpreter from glob_constr to open_constr, leaving
+    unresolved holes as evars and returning the typing contexts of
+    these evars. Work as [understand_gen] for the rest. *)
 
-  (** More general entry point with evars from ltac *)
+val understand_tcc : ?flags:inference_flags -> env -> evar_map ->
+  ?expected_type:typing_constraint -> glob_constr -> open_constr
 
-  (** Generic call to the interpreter from glob_constr to constr, failing
-     unresolved holes in the glob_constr cannot be instantiated.
+val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref ->
+  ?expected_type:typing_constraint -> glob_constr -> constr
 
-     In [understand_ltac expand_evars sigma env ltac_env constraint c],
+(** More general entry point with evars from ltac *)
 
-     resolve_classes : launch typeclass resolution after typechecking.
-     expand_evars : expand inferred evars by their value if any
-     sigma : initial set of existential variables (typically dependent subgoals)
-     ltac_env : partial substitution of variables (used for the tactic language)
-     constraint : tell if interpreted as a possibly constrained term or a type
-  *)
+(** Generic call to the interpreter from glob_constr to constr
 
-  val understand_ltac : ?resolve_classes:bool ->
-    bool -> evar_map -> env -> ltac_var_map ->
-    typing_constraint -> glob_constr -> pure_open_constr
+    In [understand_ltac flags sigma env ltac_env constraint c],
 
-  (** Standard call to get a constr from a glob_constr, resolving implicit args *)
+    flags: tell how to manage evars
+    sigma: initial set of existential variables (typically current goals)
+    ltac_env: partial substitution of variables (used for the tactic language)
+    constraint: tell if interpreted as a possibly constrained term or a type
+*)
 
-  val understand : evar_map -> env -> ?expected_type:Term.types ->
-    glob_constr -> constr
+val understand_ltac : inference_flags ->
+  env -> evar_map -> ltac_var_map ->
+  typing_constraint -> glob_constr -> pure_open_constr
 
-  (** Idem but the glob_constr is intended to be a type *)
+(** Standard call to get a constr from a glob_constr, resolving implicit args *)
 
-  val understand_type : evar_map -> env -> glob_constr -> constr
+val understand : ?flags:inference_flags -> ?expected_type:typing_constraint ->
+  env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context
 
-  (** A generalization of the two previous case *)
+(** Idem but returns the judgment of the understood term *)
 
-  val understand_gen : typing_constraint -> evar_map -> env ->
-    glob_constr -> constr
+val understand_judgment : env -> evar_map -> 
+  glob_constr -> unsafe_judgment Evd.in_evar_universe_context
 
-  (** Idem but returns the judgment of the understood term *)
+(** Idem but do not fail on unresolved evars *)
+val understand_judgment_tcc : env -> evar_map ref ->
+  glob_constr -> unsafe_judgment
 
-  val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment
+(** Trying to solve remaining evars and remaining conversion problems
+    with type classes, heuristics, and possibly an external solver *)
+(* For simplicity, it is assumed that current map has no other evars
+   with candidate and no other conversion problems that the one in
+   [pending], however, it can contain more evars than the pending ones. *)
 
-  (** Idem but do not fail on unresolved evars *)
-  val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment
+val solve_remaining_evars : inference_flags ->
+  env -> (* initial map *) evar_map -> (* map to solve *) pending -> evar_map
 
-  (**/**)
-  (** Internal of Pretyping... *)
-  val pretype :
-    bool -> type_constraint -> env -> evar_map ref ->
-    ltac_var_map -> glob_constr -> unsafe_judgment
+(** Checking evars are all solved and reporting an appropriate error message *)
 
-  val pretype_type :
-    bool -> val_constraint -> env -> evar_map ref ->
-    ltac_var_map -> glob_constr -> unsafe_type_judgment
+val check_evars_are_solved :
+  env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit
 
-  val pretype_gen :
-    bool -> bool -> bool -> evar_map ref -> env ->
-    ltac_var_map -> typing_constraint -> glob_constr -> constr
+(**/**)
+(** Internal of Pretyping... *)
+val pretype :
+  bool -> type_constraint -> env -> evar_map ref ->
+  ltac_var_map -> glob_constr -> unsafe_judgment
 
-  (**/**)
+val pretype_type :
+  bool -> val_constraint -> env -> evar_map ref ->
+  ltac_var_map -> glob_constr -> unsafe_type_judgment
 
-end
+val ise_pretype_gen :
+  inference_flags -> env -> evar_map ->
+  ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr
 
-module Pretyping_F (C : Coercion.S) : S
-module Default : S
+(**/**)
 
 (** To embed constr in glob_constr *)
 
 val constr_in : constr -> Dyn.t
 val constr_out : Dyn.t -> constr
 
-val interp_sort : glob_sort -> sorts
+val interp_sort : evar_map -> glob_sort -> evar_map * sorts
 val interp_elimination_sort : glob_sort -> sorts_family
 
-(** Last chance for solving evars, possibly using external solver *)
-val solve_remaining_evars : bool -> bool ->
-  (env -> evar_map -> existential -> constr) ->
-  env -> evar_map -> pure_open_constr -> pure_open_constr
+val genarg_interp_hook :
+  (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t ->
+    Genarg.glob_generic_argument -> constr * evar_map) Hook.t
diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib
index 9eec9414..25d17c7c 100644
--- a/pretyping/pretyping.mllib
+++ b/pretyping/pretyping.mllib
@@ -1,29 +1,34 @@
+Locusops
 Termops
+Namegen
 Evd
 Reductionops
 Vnorm
-Namegen
 Inductiveops
+Arguments_renaming
+Nativenorm
 Retyping
 Cbv
 Pretype_errors
+Find_subterm
 Evarutil
-Term_dnet
+Evarsolve
 Recordops
 Evarconv
-Arguments_renaming
 Typing
-Glob_term
-Pattern
-Matching
+Miscops
+Glob_ops
+Redops
+Patternops
+Constr_matching
 Tacred
 Typeclasses_errors
 Typeclasses
 Classops
+Program
 Coercion
-Unification
 Detyping
 Indrec
 Cases
 Pretyping
-
+Unification
diff --git a/pretyping/program.ml b/pretyping/program.ml
new file mode 100644
index 00000000..cac8a6a3
--- /dev/null
+++ b/pretyping/program.ml
@@ -0,0 +1,69 @@
+(************************************************************************)
+(*  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 Pp
+open Errors
+open Util
+open Names
+open Term
+
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+
+let find_reference locstr dir s =
+  let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in
+  try Nametab.global_of_path sp
+  with Not_found ->
+    anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp)
+
+let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s
+let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s)
+
+let init_constant dir s () = coq_constant "Program" dir s
+let init_reference dir s () = coq_reference "Program" dir s
+
+let papp evdref r args = 
+  let gr = delayed_force r in
+    mkApp (Evarutil.e_new_global evdref gr, args)
+
+let sig_typ = init_reference ["Init"; "Specif"] "sig"
+let sig_intro = init_reference ["Init"; "Specif"] "exist"
+let sig_proj1 = init_reference ["Init"; "Specif"] "proj1_sig"
+
+let sigT_typ = init_reference ["Init"; "Specif"] "sigT"
+let sigT_intro = init_reference ["Init"; "Specif"] "existT"
+let sigT_proj1 = init_reference ["Init"; "Specif"] "projT1"
+let sigT_proj2 = init_reference ["Init"; "Specif"] "projT2"
+
+let prod_typ = init_reference ["Init"; "Datatypes"] "prod"
+let prod_intro = init_reference ["Init"; "Datatypes"] "pair"
+let prod_proj1 = init_reference ["Init"; "Datatypes"] "fst"
+let prod_proj2 = init_reference ["Init"; "Datatypes"] "snd"
+
+let coq_eq_ind = init_reference ["Init"; "Logic"] "eq"
+let coq_eq_refl = init_reference ["Init"; "Logic"] "eq_refl"
+let coq_eq_refl_ref = init_reference ["Init"; "Logic"] "eq_refl"
+let coq_eq_rect = init_reference ["Init"; "Logic"] "eq_rect"
+
+let coq_JMeq_ind = init_reference ["Logic";"JMeq"] "JMeq"
+let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl"
+
+let coq_not = init_constant ["Init";"Logic"] "not"
+let coq_and = init_constant ["Init";"Logic"] "and"
+
+let mk_coq_not x = mkApp (delayed_force coq_not, [| x |])
+
+let unsafe_fold_right f = function
+    hd :: tl -> List.fold_right f tl hd
+  | [] -> invalid_arg "unsafe_fold_right"
+
+let mk_coq_and l =
+  let and_typ = delayed_force coq_and in
+    unsafe_fold_right
+      (fun c conj ->
+	 mkApp (and_typ, [| c ; conj |]))
+      l
diff --git a/pretyping/program.mli b/pretyping/program.mli
new file mode 100644
index 00000000..3844f375
--- /dev/null
+++ b/pretyping/program.mli
@@ -0,0 +1,39 @@
+(************************************************************************)
+(*  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 Term
+open Globnames
+
+(** A bunch of Coq constants used by Progam *)
+
+val sig_typ : unit -> global_reference
+val sig_intro : unit -> global_reference
+val sig_proj1 : unit -> global_reference
+val sigT_typ : unit -> global_reference
+val sigT_intro : unit -> global_reference
+val sigT_proj1 : unit -> global_reference
+val sigT_proj2 : unit -> global_reference
+
+val prod_typ : unit -> global_reference
+val prod_intro : unit -> global_reference
+val prod_proj1 : unit -> global_reference
+val prod_proj2 : unit -> global_reference
+
+val coq_eq_ind : unit -> global_reference
+val coq_eq_refl : unit -> global_reference
+val coq_eq_refl_ref : unit -> global_reference
+val coq_eq_rect : unit -> global_reference
+
+val coq_JMeq_ind : unit -> global_reference
+val coq_JMeq_refl : unit -> global_reference
+
+val mk_coq_and : constr list -> constr
+val mk_coq_not : constr -> constr
+
+(** Polymorphic application of delayed references *)
+val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index f9cd3501..6dc0d1f3 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -1,27 +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        *)
 (************************************************************************)
 
-(* Created by Amokrane Saïbi, Dec 1998 *)
+(* Created by Amokrane Saïbi, Dec 1998 *)
 (* Addition of products and sorts in canonical structures by Pierre
    Corbineau, Feb 2008 *)
 
 (* This file registers properties of records: projections and
    canonical structures *)
 
+open Errors
 open Util
 open Pp
 open Names
-open Libnames
+open Globnames
 open Nametab
 open Term
-open Typeops
 open Libobject
-open Library
 open Mod_subst
 open Reductionops
 
@@ -29,25 +28,27 @@ open Reductionops
    constructor (the name of which defaults to Build_S) *)
 
 (* Table des structures: le nom de la structure (un [inductive]) donne
-   le nom du constructeur, le nombre de paramètres et pour chaque
-   argument réel du constructeur, le nom de la projection
-   correspondante, si valide, et un booléen disant si c'est une vraie
-   projection ou bien une fonction constante (associée à un LetIn) *)
+   le nom du constructeur, le nombre de paramètres et pour chaque
+   argument réel du constructeur, le nom de la projection
+   correspondante, si valide, et un booléen disant si c'est une vraie
+   projection ou bien une fonction constante (associée à un LetIn) *)
 
 type struc_typ = {
   s_CONST : constructor;
   s_EXPECTEDPARAM : int;
-  s_PROJKIND : (name * bool) list;
+  s_PROJKIND : (Name.t * bool) list;
   s_PROJ : constant option list }
 
-let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
-let projection_table = ref Cmap.empty
+let structure_table =
+  Summary.ref (Indmap.empty : struc_typ Indmap.t) ~name:"record-structs"
+let projection_table =
+  Summary.ref Cmap.empty ~name:"record-projs"
 
 (* TODO: could be unify struc_typ and struc_tuple ? in particular,
    is the inductive always (fst constructor) ? It seems so... *)
 
 type struc_tuple =
-    inductive * constructor * (name * bool) list * constant option list
+    inductive * constructor * (Name.t * bool) list * constant option list
 
 let load_structure i (_,(ind,id,kl,projs)) =
   let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
@@ -62,12 +63,12 @@ let cache_structure o =
   load_structure 1 o
 
 let subst_structure (subst,((kn,i),id,kl,projs as obj)) = 
-  let kn' = subst_ind subst kn in
+  let kn' = subst_mind subst kn in
   let projs' =
    (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *)
    (* the first component of subst_con.                                   *)
-   list_smartmap
-     (Option.smartmap (fun kn -> fst (subst_con subst kn)))
+   List.smartmap
+     (Option.smartmap (fun kn -> fst (subst_con_kn subst kn)))
     projs
   in
   let id' = fst (subst_constructor subst id) in
@@ -104,56 +105,6 @@ let find_projection = function
   | ConstRef cst -> Cmap.find cst !projection_table
   | _ -> raise Not_found
 
-(* Management of a field store : each field + argument of the inferred
- * records are stored in a discrimination tree *)
-
-let subst_id s (gr,ev,evm) =
-  (fst(subst_global s gr),ev,Evd.subst_evar_map s evm)
-
-module MethodsDnet : Term_dnet.S
-  with type ident = global_reference * Evd.evar * Evd.evar_map
-  = Term_dnet.Make
-  (struct
-     type t = global_reference * Evd.evar * Evd.evar_map
-     let compare = Pervasives.compare
-     let subst = subst_id
-     let constr_of (_,ev,evm) = Evd.evar_concl (Evd.find evm ev)
-   end)
-  (struct
-     let reduce c = Reductionops.head_unfold_under_prod
-       Names.full_transparent_state (Global.env()) Evd.empty c
-     let direction = true
-   end)
-
-let meth_dnet = ref MethodsDnet.empty
-
-open Summary
-
-let _ =
-  declare_summary "record-methods-state"
-    { freeze_function = (fun () -> !meth_dnet);
-      unfreeze_function = (fun m -> meth_dnet := m);
-      init_function = (fun () -> meth_dnet := MethodsDnet.empty) }
-
-open Libobject
-
-let load_method (_,(ty,id)) =
-  meth_dnet := MethodsDnet.add ty id !meth_dnet
-
-let in_method : constr * MethodsDnet.ident -> obj =
-  declare_object
-    { (default_object "RECMETHODS") with
-	load_function = (fun _ -> load_method);
-	cache_function = load_method;
-	subst_function = (fun (s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id);
-	classify_function = (fun x -> Substitute x)
-    }
-
-let methods_matching c = MethodsDnet.search_pattern !meth_dnet c
-
-let declare_method cons ev sign =
-  Lib.add_anonymous_leaf (in_method ((Evd.evar_concl (Evd.find sign ev)),(cons,ev,sign)))
-
 (************************************************************************)
 (*s A canonical structure declares "canonical" conversion hints between *)
 (*  the effective components of a structure and the projections of the  *)
@@ -163,16 +114,18 @@ let declare_method cons ev sign =
 
   c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n)
 
-  If ti has the form (ci ui1...uir) where ci is a global reference and
-if the corresponding projection Li of the structure R is defined, one
-declare a "conversion" between ci and Li
+  If ti has the form (ci ui1...uir) where ci is a global reference (or
+  a sort, or a product or a reference to a parameter) and if the 
+  corresponding projection Li of the structure R is defined, one
+  declares a "conversion" between ci and Li.
 
     x1:B1..xk:Bk |- (Li a1..am (c x1..xk)) =_conv (ci ui1...uir)
 
-that maps the pair (Li,ci) to the following data
+  that maps the pair (Li,ci) to the following data
 
     o_DEF = c
     o_TABS = B1...Bk
+    o_INJ = Some n        (when ci is a reference to the parameter xi)
     o_PARAMS = a1...am
     o_NARAMS = m
     o_TCOMP = ui1...uir
@@ -181,7 +134,8 @@ that maps the pair (Li,ci) to the following data
 
 type obj_typ = {
   o_DEF : constr;
-  o_INJ : int;      (* position of trivial argument (negative= none) *)
+  o_CTX : Univ.ContextSet.t;
+  o_INJ : int option;      (* position of trivial argument if any *)
   o_TABS : constr list;    (* ordered *)
   o_TPARAMS : constr list; (* ordered *)
   o_NPARAMS : int;
@@ -193,42 +147,60 @@ type cs_pattern =
   | Sort_cs of sorts_family
   | Default_cs
 
-let object_table = ref (Refmap.empty : (cs_pattern * obj_typ) list Refmap.t)
+let eq_cs_pattern p1 p2 = match p1, p2 with
+| Const_cs gr1, Const_cs gr2 -> eq_gr gr1 gr2
+| Prod_cs, Prod_cs -> true
+| Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2
+| Default_cs, Default_cs -> true
+| _ -> false
+
+let rec assoc_pat a = function
+  | ((pat, t), e) :: xs -> if eq_cs_pattern pat a then (t, e) else assoc_pat a xs
+  | [] -> raise Not_found
+
+
+let object_table =
+  Summary.ref (Refmap.empty : ((cs_pattern * constr) * obj_typ) list Refmap.t)
+    ~name:"record-canonical-structs"
 
 let canonical_projections () =
-  Refmap.fold (fun x -> List.fold_right (fun (y,c) acc -> ((x,y),c)::acc))
+  Refmap.fold (fun x -> List.fold_right (fun ((y,_),c) acc -> ((x,y),c)::acc))
     !object_table []
 
 let keep_true_projections projs kinds =
-  map_succeed (function (p,(_,true)) -> p | _ -> failwith "")
-    (List.combine projs kinds)
+  let filter (p, (_, b)) = if b then Some p else None in
+  List.map_filter filter (List.combine projs kinds)
 
 let cs_pattern_of_constr t =
   match kind_of_term t with
       App (f,vargs) ->
 	begin
-	  try  Const_cs (global_of_constr f) , -1, Array.to_list vargs
+	  try Const_cs (global_of_constr f) , None, Array.to_list vargs
           with e when Errors.noncritical e -> raise Not_found
 	end
-    | Rel n -> Default_cs, pred n, []
-    | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, -1, [a; Termops.pop b]
-    | Sort s -> Sort_cs (family_of_sort s), -1, []
+    | Rel n -> Default_cs, Some n, []
+    | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, None, [a; Termops.pop b]
+    | Sort s -> Sort_cs (family_of_sort s), None, []
     | _ ->
 	begin
-	  try  Const_cs (global_of_constr t) , -1, []
+	  try Const_cs (global_of_constr t) , None, []
           with e when Errors.noncritical e -> raise Not_found
 	end
 
 (* Intended to always succeed *)
 let compute_canonical_projections (con,ind) =
-  let v = mkConst con in
-  let c = Environ.constant_value (Global.env()) con in
-  let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in
-  let lt = List.rev (List.map snd lt) in
+  let env = Global.env () in
+  let ctx = Environ.constant_context env con in
+  let u = Univ.UContext.instance ctx in
+  let v = (mkConstU (con,u)) in
+  let ctx = Univ.ContextSet.of_context ctx in
+  let c = Environ.constant_value_in env (con,u) in
+  let lt,t = Reductionops.splay_lam env Evd.empty c in
+  let lt = List.rev_map snd lt in
   let args = snd (decompose_app t) in
   let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } =
     lookup_structure ind in
-  let params, projs = list_chop p args in
+  let params, projs = List.chop p args in
   let lpj = keep_true_projections lpj kl in
   let lps = List.combine lpj projs in
   let comp =
@@ -239,48 +211,48 @@ let compute_canonical_projections (con,ind) =
 	       begin
 		 try
 		   let patt, n , args = cs_pattern_of_constr t in
-		     ((ConstRef proji_sp, patt, n, args) :: l)
+		     ((ConstRef proji_sp, patt, t, n, args) :: l)
 		 with Not_found ->
                    if Flags.is_verbose () then
-                     (let con_pp = Nametab.pr_global_env Idset.empty (ConstRef con)
-                      and proji_sp_pp = Nametab.pr_global_env Idset.empty (ConstRef proji_sp) in
-		      msg_warning (str "No global reference exists for projection value"
-                                   ++ Termops.print_constr t ++ str " in instance "  
-                                   ++ con_pp ++ str " of " ++ proji_sp_pp ++ str ", ignoring it."));
+                     (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con)
+                      and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in
+		      msg_warning (strbrk "No global reference exists for projection value"
+                                   ++ Termops.print_constr t ++ strbrk " in instance "  
+                                   ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it."));
 		   l
 	       end
 	   | _ -> l)
       [] lps in
-  List.map (fun (refi,c,inj,argj) ->
-    (refi,c),
-    {o_DEF=v; o_INJ=inj; o_TABS=lt;
+  List.map (fun (refi,c,t,inj,argj) ->
+    (refi,(c,t)),
+    {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt;
      o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj})
     comp
 
 let pr_cs_pattern = function
-    Const_cs c -> Nametab.pr_global_env Idset.empty c
+    Const_cs c -> Nametab.pr_global_env Id.Set.empty c
   | Prod_cs -> str "_ -> _"
   | Default_cs -> str "_"
   | Sort_cs s -> Termops.pr_sort_family s
 
 let open_canonical_structure i (_,o) =
-  if i=1 then
+  if Int.equal i 1 then
     let lo = compute_canonical_projections o in
-    List.iter (fun ((proj,cs_pat),s) ->
+    List.iter (fun ((proj,(cs_pat,_ as pat)),s) ->
       let l = try Refmap.find proj !object_table with Not_found -> [] in
-      let ocs = try Some (List.assoc cs_pat l)
+      let ocs = try Some (assoc_pat cs_pat l)
       with Not_found -> None
       in match ocs with
-        | None -> object_table := Refmap.add proj ((cs_pat,s)::l) !object_table;
-        | Some cs ->
+        | None -> object_table := Refmap.add proj ((pat,s)::l) !object_table;
+        | Some (c, cs) ->
             if Flags.is_verbose () then
               let old_can_s = (Termops.print_constr cs.o_DEF)
               and new_can_s = (Termops.print_constr s.o_DEF) in
-              let prj = (Nametab.pr_global_env Idset.empty proj)
+              let prj = (Nametab.pr_global_env Id.Set.empty proj)
               and hd_val = (pr_cs_pattern cs_pat) in
-              msg_warning (str "Ignoring canonical projection to " ++ hd_val
-                             ++ str " by " ++ prj ++ str " in "
-                             ++ new_can_s ++ str ": redundant with " ++ old_can_s)) lo
+              msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val
+                             ++ strbrk " by " ++ prj ++ strbrk " in "
+                             ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)) lo
 
 let cache_canonical_structure o =
   open_canonical_structure 1 o
@@ -288,9 +260,9 @@ let cache_canonical_structure o =
 let subst_canonical_structure (subst,(cst,ind as obj)) =
   (* invariant: cst is an evaluable reference. Thus we can take *)
   (* the first component of subst_con.                                   *)
-  let cst' = fst (subst_con subst cst) in
-  let ind' = Inductiveops.subst_inductive subst ind in
-  if cst' == cst & ind' == ind then obj else (cst',ind')
+  let cst' = subst_constant subst cst in
+  let ind' = subst_ind subst ind in
+  if cst' == cst && ind' == ind then obj else (cst',ind')
 
 let discharge_canonical_structure (_,(cst,ind)) =
   Some (Lib.discharge_con cst,Lib.discharge_inductive ind)
@@ -314,7 +286,9 @@ let error_not_structure ref =
 let check_and_decompose_canonical_structure ref =
   let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in
   let env = Global.env () in
-  let vc = match Environ.constant_opt_value env sp with
+  let ctx = Environ.constant_context env sp in
+  let u = Univ.UContext.instance ctx in
+  let vc = match Environ.constant_opt_value_in env (sp, u) with
     | Some vc -> vc
     | None -> error_not_structure ref in
   let body = snd (splay_lam (Global.env()) Evd.empty vc) in
@@ -322,7 +296,7 @@ let check_and_decompose_canonical_structure ref =
     | App (f,args) -> f,args
     | _ -> error_not_structure ref in
   let indsp = match kind_of_term f with
-    | Construct (indsp,1) -> indsp
+    | Construct ((indsp,1),u) -> indsp
     | _ -> error_not_structure ref in
   let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
   let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in
@@ -334,32 +308,17 @@ let declare_canonical_structure ref =
   add_canonical_structure (check_and_decompose_canonical_structure ref)
 
 let lookup_canonical_conversion (proj,pat) =
-  List.assoc pat (Refmap.find proj !object_table)
+  assoc_pat pat (Refmap.find proj !object_table)
 
 let is_open_canonical_projection env sigma (c,args) =
   try
-    let n = find_projection_nparams (global_of_constr c) in
+    let ref = global_of_constr c in
+    let n = find_projection_nparams ref in
+    (** Check if there is some canonical projection attached to this structure *)
+    let _ = Refmap.find ref !object_table in
     try
-      let arg = whd_betadeltaiota env sigma (List.nth args n) in
+      let arg = whd_betadeltaiota env sigma (Stack.nth args n) in
       let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in
-      not (isConstruct hd) 
+      not (isConstruct hd)
     with Failure _ -> false
   with Not_found -> false
-
-let freeze () =
-  !structure_table, !projection_table, !object_table
-
-let unfreeze (s,p,o) =
-  structure_table := s; projection_table := p; object_table := o
-
-let init () =
-  structure_table := Indmap.empty; projection_table := Cmap.empty;
-  object_table := Refmap.empty
-
-let _ = init()
-
-let _ =
-  Summary.declare_summary "objdefs"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index 442e51db..37d5b4c2 100644
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -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 Names
-open Nametab
 open Term
-open Libnames
-open Libobject
-open Library
+open Globnames
 
 (** Operations concerning records and canonical structures *)
 
@@ -22,11 +19,11 @@ open Library
 type struc_typ = {
   s_CONST : constructor;
   s_EXPECTEDPARAM : int;
-  s_PROJKIND : (name * bool) list;
+  s_PROJKIND : (Name.t * bool) list;
   s_PROJ : constant option list }
 
 type struc_tuple =
-    inductive * constructor * (name * bool) list * constant option list
+    inductive * constructor * (Name.t * bool) list * constant option list
 
 val declare_structure : struc_tuple -> unit
 
@@ -46,20 +43,12 @@ val find_projection_nparams : global_reference -> int
 (** raise [Not_found] if not a projection *)
 val find_projection : global_reference -> struc_typ
 
-(** we keep an index (dnet) of record's arguments + fields
-   (=methods). Here is how to declare them: *)
-val declare_method :
-  global_reference -> Evd.evar -> Evd.evar_map -> unit
-  (** and here is how to search for methods matched by a given term: *)
-val methods_matching : constr ->
-  ((global_reference*Evd.evar*Evd.evar_map) *
-     (constr*existential_key)*Termops.subst) list
-
 (** {6 Canonical structures } *)
 (** A canonical structure declares "canonical" conversion hints between 
     the effective components of a structure and the projections of the  
     structure *)
 
+(** A cs_pattern characterizes the form of a component of canonical structure *)
 type cs_pattern =
     Const_cs of global_reference
   | Prod_cs
@@ -68,18 +57,21 @@ type cs_pattern =
 
 type obj_typ = {
   o_DEF : constr;
-  o_INJ : int;      (** position of trivial argument *)
+  o_CTX : Univ.ContextSet.t;
+  o_INJ : int option;      (** position of trivial argument *)
   o_TABS : constr list;    (** ordered *)
   o_TPARAMS : constr list; (** ordered *)
   o_NPARAMS : int;
   o_TCOMPS : constr list } (** ordered *)
 
-val cs_pattern_of_constr : constr -> cs_pattern * int * constr list
+(** Return the form of the component of a canonical structure *)
+val cs_pattern_of_constr : constr -> cs_pattern * int option * constr list
+
 val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds
 
-val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ
+val lookup_canonical_conversion : (global_reference * cs_pattern) -> constr * obj_typ
 val declare_canonical_structure : global_reference -> unit
 val is_open_canonical_projection :
-  Environ.env -> Evd.evar_map -> (constr * constr list) -> bool
+  Environ.env -> Evd.evar_map -> (constr * constr Reductionops.Stack.t) -> bool
 val canonical_projections : unit ->
   ((global_reference * cs_pattern) * obj_typ) list
diff --git a/pretyping/redops.ml b/pretyping/redops.ml
new file mode 100644
index 00000000..92782737
--- /dev/null
+++ b/pretyping/redops.ml
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  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 Genredexpr
+
+let union_consts l1 l2 = Util.List.union Pervasives.(=) l1 l2 (* FIXME *)
+
+let make_red_flag l =
+  let rec add_flag red = function
+    | [] -> red
+    | FBeta :: lf -> add_flag { red with rBeta = true } lf
+    | FIota :: lf -> add_flag { red with rIota = true } lf
+    | FZeta :: lf -> add_flag { red with rZeta = true } lf
+    | FConst l :: lf ->
+	if red.rDelta then
+	  Errors.error
+	    "Cannot set both constants to unfold and constants not to unfold";
+        add_flag { red with rConst = union_consts red.rConst l } lf
+    | FDeltaBut l :: lf ->
+	if red.rConst <> [] && not red.rDelta then
+	  Errors.error
+	    "Cannot set both constants to unfold and constants not to unfold";
+        add_flag
+          { red with rConst = union_consts red.rConst l; rDelta = true }
+          lf
+  in
+  add_flag
+    {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []}
+    l
+
+
+let all_flags =
+  {rBeta = true; rIota = true; rZeta = true; rDelta = true; rConst = []}
diff --git a/states/MakeInitial.v b/pretyping/redops.mli
index d334a4db..89c68ff3 100644
--- a/states/MakeInitial.v
+++ b/pretyping/redops.mli
@@ -1,9 +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        *)
 (************************************************************************)
-Require Export Prelude.
-Require Export Logic_Type.
+
+open Genredexpr
+
+val make_red_flag : 'a red_atom list -> 'a glob_red_flag
+
+val all_flags : 'a glob_red_flag
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 7c348d97..a23963ab 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1,107 +1,572 @@
 (************************************************************************)
 (*  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
 open Term
+open Vars
+open Context
 open Termops
 open Univ
 open Evd
-open Declarations
 open Environ
-open Closure
-open Esubst
-open Reduction
 
 exception Elimconst
 
+(** This module implements a call by name reduction used by (at
+    least) evarconv unification and cbn tactic.
 
-(**********************************************************************)
-(* The type of (machine) stacks (= lambda-bar-calculus' contexts)     *)
-
-type 'a stack_member =
-  | Zapp of 'a list
-  | Zcase of case_info * 'a * 'a array
-  | Zfix of 'a * 'a stack
-  | Zshift of int
-  | Zupdate of 'a
-
-and 'a stack = 'a stack_member list
-
-let empty_stack = []
-let append_stack_list l s =
-  match (l,s) with
-  | ([],s) -> s
-  | (l1, Zapp l :: s) -> Zapp (l1@l) :: s
-  | (l1, s) -> Zapp l1 :: s
-let append_stack v s = append_stack_list (Array.to_list v) s
-
-let rec stack_args_size = function
-  | Zapp l::s -> List.length l + stack_args_size s
-  | Zshift(_)::s -> stack_args_size s
-  | Zupdate(_)::s -> stack_args_size s
-  | _ -> 0
-
-(* When used as an argument stack (only Zapp can appear) *)
-let rec decomp_stack = function
-  | Zapp[v]::s -> Some (v, s)
-  | Zapp(v::l)::s -> Some (v, (Zapp l :: s))
-  | Zapp [] :: s -> decomp_stack s
-  | _ -> None
-let array_of_stack s =
-  let rec stackrec = function
-  | [] -> []
-  | Zapp args :: s -> args :: (stackrec s)
-  | _ -> assert false
-  in Array.of_list (List.concat (stackrec s))
-let rec list_of_stack = function
-  | [] -> []
-  | Zapp args :: s -> args @ (list_of_stack s)
-  | _ -> assert false
-let rec app_stack = function
-  | f, [] -> f
-  | f, (Zapp [] :: s) -> app_stack (f, s)
-  | f, (Zapp args :: s) ->
-      app_stack (applist (f, args), s)
-  | _ -> assert false
-let rec stack_assign s p c = match s with
-  | Zapp args :: s ->
-      let q = List.length args in
-      if p >= q then
-	Zapp args :: stack_assign s (p-q) c
-      else
-        (match list_chop p args with
-            (bef, _::aft) -> Zapp (bef@c::aft) :: s
-          | _ -> assert false)
-  | _ -> s
-let rec stack_tail p s =
-  if p = 0 then s else
-    match s with
-      | Zapp args :: s ->
-	  let q = List.length args in
-	  if p >= q then stack_tail (p-q) s
-	  else Zapp (list_skipn p args) :: s
-      | _ -> failwith "stack_tail"
-let rec stack_nth s p = match s with
-  | Zapp args :: s ->
-      let q = List.length args in
-      if p >= q then stack_nth s (p-q)
-      else List.nth args p
-  | _ -> raise Not_found
-
-(**************************************************************)
-(* The type of (machine) states (= lambda-bar-calculus' cuts) *)
-type state = constr * constr stack
+    It has an ability to "refold" constants by storing constants and
+    their parameters in its stack.
+*)
+
+(** Machinery to custom the behavior of the reduction *)
+module ReductionBehaviour = struct
+  open Globnames
+  open Libobject
+
+  type t = {
+    b_nargs: int;
+    b_recargs: int list;
+    b_dont_expose_case: bool;
+  }
+
+  let table =
+    Summary.ref (Refmap.empty : t Refmap.t) ~name:"reductionbehaviour"
+
+  type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ]
+  type req =
+    | ReqLocal
+    | ReqGlobal of global_reference * (int list * int * flag list)
+
+  let load _ (_,(_,(r, b))) =
+    table := Refmap.add r b !table
+
+  let cache o = load 1 o
+
+  let classify = function
+    | ReqLocal, _ -> Dispose
+    | ReqGlobal _, _ as o -> Substitute o
+
+  let subst (subst, (_, (r,o as orig))) =
+    ReqLocal,
+    let r' = fst (subst_global subst r) in if r==r' then orig else (r',o)
+
+  let discharge = function
+    | _,(ReqGlobal (ConstRef c, req), (_, b)) ->
+       let c' = pop_con c in
+       let vars, _subst, _ctx = Lib.section_segment_of_constant c in
+       let extra = List.length vars in
+       let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in
+       let recargs' = List.map ((+) extra) b.b_recargs in
+       let b' = { b with b_nargs = nargs'; b_recargs = recargs' } in
+       Some (ReqGlobal (ConstRef c', req), (ConstRef c', b'))
+    | _ -> None
+
+  let rebuild = function
+    | req, (ConstRef c, _ as x) -> req, x
+    | _ -> assert false
+
+  let inRedBehaviour = declare_object {
+			(default_object "REDUCTIONBEHAVIOUR") with
+			load_function = load;
+			cache_function = cache;
+			classify_function = classify;
+			subst_function = subst;
+			discharge_function = discharge;
+			rebuild_function = rebuild;
+		      }
+
+  let set local r (recargs, nargs, flags as req) =
+    let nargs = if List.mem `ReductionNeverUnfold flags then max_int else nargs in
+    let behaviour = {
+      b_nargs = nargs; b_recargs = recargs;
+      b_dont_expose_case = List.mem `ReductionDontExposeCase flags } in
+    let req = if local then ReqLocal else ReqGlobal (r, req) in
+    Lib.add_anonymous_leaf (inRedBehaviour (req, (r, behaviour)))
+  ;;
+
+  let get r =
+    try
+      let b = Refmap.find r !table in
+      let flags =
+	if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold]
+	else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in
+      Some (b.b_recargs, (if Int.equal b.b_nargs max_int then -1 else b.b_nargs), flags)
+    with Not_found -> None
+
+  let print ref =
+    let open Pp in
+    let pr_global = Nametab.pr_global_env Id.Set.empty in
+    match get ref with
+    | None -> mt ()
+    | Some (recargs, nargs, flags) ->
+       let never = List.mem `ReductionNeverUnfold flags in
+       let nomatch = List.mem `ReductionDontExposeCase flags in
+       let pp_nomatch = spc() ++ if nomatch then
+				   str "but avoid exposing match constructs" else str"" in
+       let pp_recargs = spc() ++ str "when the " ++
+			  pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++
+			  str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++
+			  str " to a constructor" in
+       let pp_nargs =
+	 spc() ++ str "when applied to " ++ int nargs ++
+	   str (String.plural nargs " argument") in
+       hov 2 (str "The reduction tactics " ++
+		 match recargs, nargs, never with
+		 | _,_, true -> str "never unfold " ++ pr_global ref
+		 | [], 0, _ -> str "always unfold " ++ pr_global ref
+		 | _::_, n, _ when n < 0 ->
+		    str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
+		 | _::_, n, _ when n > List.fold_left max 0 recargs ->
+		    str "unfold " ++ pr_global ref ++ pp_recargs ++
+		      str " and" ++ pp_nargs ++ pp_nomatch
+		 | _::_, _, _ ->
+		    str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
+		 | [], n, _ when n > 0 ->
+		    str "unfold " ++ pr_global ref ++ pp_nargs ++ pp_nomatch
+		 | _ -> str "unfold " ++ pr_global ref ++ pp_nomatch )
+end
+
+(** Machinery about stack of unfolded constants *)
+module Cst_stack = struct
+(** constant * params * args
+
+- constant applied to params = term in head applied to args
+- there is at most one arguments with an empty list of args, it must be the first.
+- in args, the int represents the indice of the first arg to consider *)
+  type t = (constr * constr list * (int * constr array) list)  list
+
+  let empty = []
+  let is_empty = CList.is_empty
+
+  let sanity x y =
+    assert(Term.eq_constr x y)
+
+  let drop_useless = function
+    | _ :: ((_,_,[])::_ as q) -> q
+    | l -> l
+
+  let add_param h cst_l =
+    let append2cst = function
+      | (c,params,[]) -> (c, h::params, [])
+      | (c,params,((i,t)::q)) when i = pred (Array.length t) ->
+	 let () = sanity h t.(i) in (c, params, q)
+      | (c,params,(i,t)::q) ->
+	let () = sanity h t.(i) in (c, params, (succ i,t)::q)
+    in
+      drop_useless (List.map append2cst cst_l)
+
+  let add_args cl =
+    List.map (fun (a,b,args) -> (a,b,(0,cl)::args))
+
+  let add_cst cst = function
+    | (_,_,[]) :: q as l -> l
+    | l -> (cst,[],[])::l
+
+  let best_cst = function
+    | (cst,params,[])::_ -> Some(cst,params)
+    | _ -> None
+
+  let reference t = match best_cst t with
+    | Some (c, _) when Term.isConst c -> Some (fst (Term.destConst c))
+    | _ -> None
+
+  (** [best_replace d cst_l c] makes the best replacement for [d]
+      by [cst_l] in [c] *)
+  let best_replace d cst_l c =
+    let reconstruct_head = List.fold_left
+      (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in
+    List.fold_right
+      (fun (cst,params,args) t -> Termops.replace_term
+	(reconstruct_head d args)
+	(applist (cst, List.rev params))
+	t) cst_l c
+
+  let pr l =
+    let open Pp in
+    let p_c = Termops.print_constr in
+    prlist_with_sep pr_semicolon
+      (fun (c,params,args) ->
+	hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++
+		 pr_sequence (fun (i,el) -> prvect_with_sep spc p_c (Array.sub el i (Array.length el - i))) args ++
+		 str ")")) l
+end
+
+
+(** The type of (machine) stacks (= lambda-bar-calculus' contexts) *)
+module Stack :
+sig
+  type 'a app_node
+  val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds
+
+  type cst_member =
+    | Cst_const of pconstant
+    | Cst_proj of projection
+
+  type 'a member =
+  | App of 'a app_node
+  | Case of case_info * 'a * 'a array * Cst_stack.t
+  | Proj of int * int * projection * Cst_stack.t
+  | Fix of fixpoint * 'a t * Cst_stack.t
+  | Cst of cst_member * int * int list * 'a t * Cst_stack.t
+  | Shift of int
+  | Update of 'a
+  and 'a t = 'a member list
+  val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val append_app : 'a array -> 'a t -> 'a t
+  val decomp : 'a t -> ('a * 'a t) option
+  val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t)
+  val equal : ('a * int -> 'a * int -> bool) -> (fixpoint * int -> fixpoint * int -> bool)
+    -> 'a t -> 'a t -> (int * int) option
+  val compare_shape : 'a t -> 'a t -> bool
+  val map : (constr -> constr) -> constr t -> constr t
+  val fold2 : ('a -> constr -> constr -> 'a) -> 'a ->
+    constr t -> constr t -> 'a * int * int
+  val append_app_list : 'a list -> 'a t -> 'a t
+  val strip_app : 'a t -> 'a t * 'a t
+  val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option
+  val not_purely_applicative : 'a t -> bool
+  val will_expose_iota : 'a t -> bool
+  val list_of_app_stack : constr t -> constr list option
+  val assign : 'a t -> int -> 'a -> 'a t
+  val args_size : 'a t -> int
+  val tail : int -> 'a t -> 'a t
+  val nth : 'a t -> int -> 'a
+  val best_state : constr * constr t -> Cst_stack.t -> constr * constr t
+  val zip : ?refold:bool -> constr * constr t -> constr
+end =
+struct
+  type 'a app_node = int * 'a array * int
+  (* first releavnt position, arguments, last relevant position *)
+
+  (*
+     Invariant that this module must ensure :
+     (behare of direct access to app_node by the rest of Reductionops)
+     - in app_node (i,_,j) i <= j
+     - There is no array realocation (outside of debug printing)
+   *)
+
+  let pr_app_node pr (i,a,j) =
+    let open Pp in surround (
+		     prvect_with_sep pr_comma pr (Array.sub a i (j - i + 1))
+		     )
+
+
+  type cst_member =
+    | Cst_const of pconstant
+    | Cst_proj of projection
+
+  type 'a member =
+  | App of 'a app_node
+  | Case of Term.case_info * 'a * 'a array * Cst_stack.t
+  | Proj of int * int * projection * Cst_stack.t
+  | Fix of fixpoint * 'a t * Cst_stack.t
+  | Cst of cst_member * int * int list * 'a t * Cst_stack.t
+  | Shift of int
+  | Update of 'a
+  and 'a t = 'a member list
+
+  let rec pr_member pr_c member =
+    let open Pp in
+    let pr_c x = hov 1 (pr_c x) in
+    match member with
+    | App app -> str "ZApp" ++ pr_app_node pr_c app
+    | Case (_,_,br,cst) ->
+       str "ZCase(" ++
+	 prvect_with_sep (pr_bar) pr_c br
+       ++ str ")"
+    | Proj (n,m,p,cst) ->
+      str "ZProj(" ++ int n ++ pr_comma () ++ int m ++
+	pr_comma () ++ pr_con (Projection.constant p) ++ str ")"
+    | Fix (f,args,cst) ->
+       str "ZFix(" ++ Termops.pr_fix Termops.print_constr f
+       ++ pr_comma () ++ pr pr_c args ++ str ")"
+    | Cst (mem,curr,remains,params,cst_l) ->
+      str "ZCst(" ++ pr_cst_member pr_c mem ++ pr_comma () ++ int curr
+      ++ pr_comma () ++
+	prlist_with_sep pr_semicolon int remains ++
+	pr_comma () ++ pr pr_c params ++ str ")"
+    | Shift i -> str "ZShift(" ++ int i ++ str ")"
+    | Update t -> str "ZUpdate(" ++ pr_c t ++ str ")"
+  and pr pr_c l =
+    let open Pp in
+    prlist_with_sep pr_semicolon (fun x -> hov 1 (pr_member pr_c x)) l
+
+  and pr_cst_member pr_c c =
+    let open Pp in
+      match c with
+      | Cst_const (c, u) ->
+	if Univ.Instance.is_empty u then Constant.print c
+	else str"(" ++ Constant.print c ++ str ", " ++ 
+	  Univ.Instance.pr Univ.Level.pr u ++ str")"
+      | Cst_proj p ->
+	str".(" ++ Constant.print (Projection.constant p) ++ str")"
+
+  let empty = []
+  let is_empty = CList.is_empty
+
+  let append_app v s =
+    let le = Array.length v in
+    if Int.equal le 0 then s else App (0,v,pred le) :: s
+
+  let decomp_node (i,l,j) sk =
+    if i < j then (l.(i), App (succ i,l,j) :: sk)
+    else (l.(i), sk)
+
+  let decomp = function
+    | App node::s -> Some (decomp_node node s)
+    | _ -> None
+
+  let decomp_node_last (i,l,j) sk =
+    if i < j then (l.(j), App (i,l,pred j) :: sk)
+    else (l.(j), sk)
+
+  let equal f f_fix sk1 sk2 =
+    let equal_cst_member x lft1 y lft2 =
+      match x, y with
+      | Cst_const (c1,u1), Cst_const (c2, u2) ->
+	Constant.equal c1 c2 && Univ.Instance.equal u1 u2
+      | Cst_proj p1, Cst_proj p2 ->
+	Constant.equal (Projection.constant p1) (Projection.constant p2)
+      | _, _ -> false
+    in
+    let rec equal_rec sk1 lft1 sk2 lft2  =
+      match sk1,sk2 with
+      | [],[] -> Some (lft1,lft2)
+      | (Update _ :: _, _ | _, Update _ :: _) -> assert false
+      | Shift k :: s1, _ -> equal_rec  s1  (lft1+k)  sk2 lft2
+      | _, Shift k :: s2 -> equal_rec sk1 lft1 s2 (lft2+k)
+      | App a1 :: s1, App a2 :: s2 ->
+	let t1,s1' = decomp_node_last a1 s1 in
+	let t2,s2' = decomp_node_last a2 s2 in
+	if f (t1,lft1) (t2,lft2) then equal_rec s1' lft1 s2' lft2 else None
+      | Case (_,t1,a1,_) :: s1, Case (_,t2,a2,_) :: s2 ->
+	if f (t1,lft1) (t2,lft2) && CArray.equal (fun x y -> f (x,lft1) (y,lft2)) a1 a2
+	then equal_rec s1 lft1 s2 lft2
+	else None
+      | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) ->
+	if Int.equal n1 n2 && Int.equal m1 m2
+	  && Constant.equal (Projection.constant p) (Projection.constant p2)
+	then equal_rec s1 lft1 s2 lft2
+	else None
+      | Fix (f1,s1,_) :: s1', Fix (f2,s2,_) :: s2' ->
+	if f_fix (f1,lft1) (f2,lft2) then
+	  match equal_rec (List.rev s1) lft1 (List.rev s2) lft2 with
+	  | None -> None
+	  | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2'
+	else None
+      | Cst (c1,curr1,remains1,params1,_)::s1', Cst (c2,curr2,remains2,params2,_)::s2' ->
+	if equal_cst_member c1 lft1 c2 lft2 then
+	  match equal_rec (List.rev params1) lft1 (List.rev params2) lft2 with
+	  | Some (lft1',lft2') -> equal_rec s1' lft1' s2' lft2'
+	  | None -> None
+	else None
+      | ((App _|Case _|Proj _|Fix _|Cst _)::_|[]), _ -> None
+    in equal_rec (List.rev sk1) 0 (List.rev sk2) 0
+
+  let compare_shape stk1 stk2 =
+    let rec compare_rec bal stk1 stk2 =
+      match (stk1,stk2) with
+	([],[]) -> Int.equal bal 0
+      | ((Update _|Shift _)::s1, _) -> compare_rec bal s1 stk2
+      | (_, (Update _|Shift _)::s2) -> compare_rec bal stk1 s2
+      | (App (i,_,j)::s1, _) -> compare_rec (bal + j + 1 - i) s1 stk2
+      | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2
+      | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) ->
+        Int.equal bal 0 (* && c1.ci_ind  = c2.ci_ind *) && compare_rec 0 s1 s2
+      | (Proj (n1,m1,p,_)::s1, Proj(n2,m2,p2,_)::s2) ->
+	Int.equal bal 0 && compare_rec 0 s1 s2
+      | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) ->
+        Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2
+      | (Cst (_,_,_,p1,_)::s1, Cst (_,_,_,p2,_)::s2) ->
+	Int.equal bal 0 && compare_rec 0 p1 p2 && compare_rec 0 s1 s2
+      | (_,_) -> false in
+    compare_rec 0 stk1 stk2
+
+  let fold2 f o sk1 sk2 =
+    let rec aux o lft1 sk1 lft2 sk2 =
+      let fold_array =
+	Array.fold_left2 (fun a x y -> f a (Vars.lift lft1 x) (Vars.lift lft2 y))
+      in
+      match sk1,sk2 with
+      | [], [] -> o,lft1,lft2
+      | Shift n :: q1, _ -> aux o (lft1+n) q1 lft2 sk2
+      | _, Shift n :: q2 -> aux o lft1 sk1 (lft2+n) q2
+      | App n1 :: q1, App n2 :: q2 ->
+	 let t1,l1 = decomp_node_last n1 q1 in
+	 let t2,l2 = decomp_node_last n2 q2 in
+	 aux (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2))
+	     lft1 l1 lft2 l2
+      | Case (_,t1,a1,_) :: q1, Case (_,t2,a2,_) :: q2 ->
+	aux (fold_array
+	       (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2))
+	       a1 a2) lft1 q1 lft2 q2
+      | Proj (n1,m1,p1,_) :: q1, Proj (n2,m2,p2,_) :: q2 ->
+	aux o lft1 q1 lft2 q2
+      | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 ->
+	let (o',lft1',lft2') = aux (fold_array (fold_array o b1 b2) a1 a2)
+	  lft1 (List.rev s1) lft2 (List.rev s2) in
+	aux o' lft1' q1 lft2' q2
+      | Cst (cst1,_,_,params1,_) :: q1, Cst (cst2,_,_,params2,_) :: q2 ->
+	let (o',lft1',lft2') =
+	  aux o lft1 (List.rev params1) lft2 (List.rev params2)
+	in aux o' lft1' q1 lft2' q2
+      | (((Update _|App _|Case _|Proj _|Fix _| Cst _) :: _|[]), _) ->
+	raise (Invalid_argument "Reductionops.Stack.fold2")
+    in aux o 0 (List.rev sk1) 0 (List.rev sk2)
+
+  let rec map f x = List.map (function
+			       | Update _ -> assert false
+			       | (Proj (_,_,_,_) | Shift _) as e -> e
+			       | App (i,a,j) ->
+				  let le = j - i + 1 in
+				  App (0,Array.map f (Array.sub a i le), le-1)
+			       | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt)
+			       | Fix ((r,(na,ty,bo)),arg,alt) ->
+				  Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt)
+			       | Cst (cst,curr,remains,params,alt) ->
+				 Cst (cst,curr,remains,map f params,alt)
+  ) x
+
+  let append_app_list l s =
+    let a = Array.of_list l in
+    append_app a s
+
+  let rec args_size = function
+    | App (i,_,j)::s -> j + 1 - i + args_size s
+    | Shift(_)::s -> args_size s
+    | Update(_)::s -> args_size s
+    | (Case _|Fix _|Proj _|Cst _)::_ | [] -> 0
+
+  let strip_app s =
+    let rec aux out = function
+      | ( App _ | Shift _ as e) :: s -> aux (e :: out) s
+      | s -> List.rev out,s
+    in aux [] s
+  let strip_n_app n s =
+    let rec aux n out = function
+      | Shift k as e :: s -> aux n (e :: out) s
+      | App (i,a,j) as e :: s ->
+	 let nb = j  - i + 1 in
+	 if n >= nb then
+	   aux (n - nb) (e::out) s
+	 else
+	   let p = i+n in
+	   Some (CList.rev
+	      (if Int.equal n 0 then out else App (i,a,p-1) :: out),
+	    a.(p),
+	    if j > p then App(succ p,a,j)::s else s)
+      | s -> None
+    in aux n [] s
+
+  let not_purely_applicative args =
+    List.exists (function (Fix _ | Case _ | Proj _ | Cst _) -> true | _ -> false) args
+  let will_expose_iota args =
+    List.exists
+      (function (Fix (_,_,l) | Case (_,_,_,l) |
+		 Proj (_,_,_,l) | Cst (_,_,_,_,l)) when Cst_stack.is_empty l -> true | _ -> false)
+      args
+
+  let list_of_app_stack s =
+    let rec aux = function
+      | App (i,a,j) :: s ->
+	 let (k,(args',s')) = aux s in
+	 let a' = Array.map (Vars.lift k) (Array.sub a i (j - i + 1)) in
+	 k,(Array.fold_right (fun x y -> x::y) a' args', s')
+      | Shift n :: s ->
+	 let (k,(args',s')) = aux s in (k+n,(args', s'))
+      | s -> (0,([],s)) in
+    let (lft,(out,s')) = aux s in
+    let init = match s' with [] when Int.equal lft 0 -> true | _ -> false in
+    Option.init init out
+
+  let assign s p c =
+    match strip_n_app p s with
+    | Some (pre,_,sk) -> pre @ (App (0,[|c|],0)::sk)
+    | None -> assert false
+
+  let tail n0 s0 =
+    let rec aux lft n s =
+      let out s = if Int.equal lft 0 then s else Shift lft :: s in
+      if Int.equal n 0 then out s else
+	match s with
+      | App (i,a,j) :: s ->
+	 let nb = j  - i + 1 in
+	 if n >= nb then
+	   aux lft (n - nb) s
+	 else
+	   let p = i+n in
+	   if j >= p then App(p,a,j)::s else s
+	| Shift k :: s' -> aux (lft+k) n s'
+	| _ -> raise (Invalid_argument "Reductionops.Stack.tail")
+    in aux 0 n0 s0
+
+  let nth s p =
+    match strip_n_app p s with
+    | Some (_,el,_) -> el
+    | None -> raise Not_found
+
+  (** This function breaks the abstraction of Cst_stack ! *)
+  let best_state (_,sk as s) l =
+    let rec aux sk def = function
+      |(cst, params, []) -> (cst, append_app_list (List.rev params) sk)
+      |(cst, params, (i,t)::q) -> match decomp sk with
+	| Some (el,sk') when Constr.equal el t.(i) ->
+	  if i = pred (Array.length t)
+	  then aux sk' def (cst, params, q)
+	  else aux sk' def (cst, params, (succ i,t)::q)
+	| _ -> def
+    in List.fold_left (aux sk) s l
+
+  let constr_of_cst_member f sk =
+    match f with
+    | Cst_const (c, u) -> mkConstU (c,u), sk
+    | Cst_proj p -> 
+      match decomp sk with
+      | Some (hd, sk) -> mkProj (p, hd), sk
+      | None -> assert false
+
+  let rec zip ?(refold=false) = function
+    | f, [] -> f
+    | f, (App (i,a,j) :: s) ->
+       let a' = if Int.equal i 0 && Int.equal j (Array.length a - 1)
+		then a
+		else Array.sub a i (j - i + 1) in
+       zip ~refold (mkApp (f, a'), s)
+    | f, (Case (ci,rt,br,cst_l)::s) when refold ->
+      zip ~refold (best_state (mkCase (ci,rt,f,br), s) cst_l)
+    | f, (Case (ci,rt,br,_)::s) -> zip ~refold (mkCase (ci,rt,f,br), s)
+    | f, (Fix (fix,st,cst_l)::s) when refold ->
+      zip ~refold (best_state (mkFix fix, st @ (append_app [|f|] s)) cst_l)
+  | f, (Fix (fix,st,_)::s) -> zip ~refold
+    (mkFix fix, st @ (append_app [|f|] s))
+  | f, (Cst (cst,_,_,params,cst_l)::s) when refold ->
+    zip ~refold (best_state (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l)
+  | f, (Cst (cst,_,_,params,_)::s) ->
+    zip ~refold (constr_of_cst_member cst (params @ (append_app [|f|] s)))
+  | f, (Shift n::s) -> zip ~refold (lift n f, s)
+  | f, (Proj (n,m,p,cst_l)::s) when refold ->
+    zip ~refold (best_state (mkProj (p,f),s) cst_l)
+  | f, (Proj (n,m,p,_)::s) -> zip ~refold (mkProj (p,f),s)
+  | _, (Update _::_) -> assert false
+end
+
+(** The type of (machine) states (= lambda-bar-calculus' cuts) *)
+type state = constr * constr Stack.t
 
 type  contextual_reduction_function = env ->  evar_map -> constr -> constr
 type  reduction_function =  contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
+type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
 
 type  contextual_stack_reduction_function =
     env ->  evar_map -> constr -> constr * constr list
@@ -114,6 +579,10 @@ type  contextual_state_reduction_function =
 type  state_reduction_function =  contextual_state_reduction_function
 type local_state_reduction_function = evar_map -> state -> state
 
+let pr_state (tm,sk) =
+  let open Pp in
+  h 0 (Termops.print_constr tm ++ str "|" ++ cut () ++ Stack.pr Termops.print_constr sk)
+
 (*************************************)
 (*** Reduction Functions Operators ***)
 (*************************************)
@@ -122,26 +591,10 @@ let safe_evar_value sigma ev =
   try Some (Evd.existential_value sigma ev)
   with NotInstantiatedEvar | Not_found -> None
 
-let rec whd_app_state sigma (x, stack as s) =
-  match kind_of_term x with
-    | App (f,cl) -> whd_app_state sigma (f, append_stack cl stack)
-    | Cast (c,_,_)  -> whd_app_state sigma (c, stack)
-    | Evar ev ->
-        (match safe_evar_value sigma ev with
-            Some c -> whd_app_state sigma (c,stack)
-          | _ -> s)
-    | _             -> s
-
 let safe_meta_value sigma ev =
   try Some (Evd.meta_value sigma ev)
   with Not_found -> None
 
-let appterm_of_stack (f,s) = (f,list_of_stack s)
-
-let whd_stack sigma x =
-  appterm_of_stack (whd_app_state sigma (x, empty_stack))
-let whd_castapp_stack = whd_stack
-
 let strong whdfun env sigma t =
   let rec strongrec env t =
     map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in
@@ -161,70 +614,39 @@ let rec strong_prodspine redfun sigma c =
 (*** Reduction using bindingss ***)
 (*************************************)
 
-(* This signature is very similar to Closure.RedFlagsSig except there
-   is eta but no per-constant unfolding *)
-
-module type RedFlagsSig = sig
-  type flags
-  type flag
-  val fbeta : flag
-  val fdelta : flag
-  val feta : flag
-  val fiota : flag
-  val fzeta : flag
-  val mkflags : flag list -> flags
-  val red_beta : flags -> bool
-  val red_delta : flags -> bool
-  val red_eta : flags -> bool
-  val red_iota : flags -> bool
-  val red_zeta : flags -> bool
-end
-
-(* Compact Implementation *)
-module RedFlags = (struct
-  type flag = int
-  type flags = int
-  let fbeta = 1
-  let fdelta = 2
-  let feta = 8
-  let fiota = 16
-  let fzeta = 32
-  let mkflags = List.fold_left (lor) 0
-  let red_beta f = f land fbeta <> 0
-  let red_delta f = f land fdelta <> 0
-  let red_eta f = f land feta <> 0
-  let red_iota f = f land fiota <> 0
-  let red_zeta f = f land fzeta <> 0
-end : RedFlagsSig)
-
-open RedFlags
-
 (* Local *)
-let beta = mkflags [fbeta]
-let eta = mkflags [feta]
-let zeta = mkflags [fzeta]
-let betaiota = mkflags [fiota; fbeta]
-let betaiotazeta = mkflags [fiota; fbeta;fzeta]
+let nored = Closure.RedFlags.no_red
+let beta = Closure.beta
+let eta = Closure.RedFlags.mkflags [Closure.RedFlags.fETA]
+let zeta = Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]
+let betaiota = Closure.betaiota
+let betaiotazeta = Closure.betaiotazeta
 
 (* Contextual *)
-let delta = mkflags [fdelta]
-let betadelta = mkflags [fbeta;fdelta;fzeta]
-let betadeltaeta = mkflags [fbeta;fdelta;fzeta;feta]
-let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fiota]
-let betadeltaiota_nolet = mkflags [fbeta;fdelta;fiota]
-let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fiota;feta]
-let betaetalet = mkflags [fbeta;feta;fzeta]
-let betalet = mkflags [fbeta;fzeta]
+let delta = Closure.RedFlags.mkflags [Closure.RedFlags.fDELTA]
+let betalet = Closure.RedFlags.mkflags [Closure.RedFlags.fBETA;Closure.RedFlags.fZETA]
+let betaetalet = Closure.RedFlags.red_add betalet Closure.RedFlags.fETA
+let betadelta = Closure.RedFlags.red_add betalet Closure.RedFlags.fDELTA
+let betadeltaeta = Closure.RedFlags.red_add betadelta Closure.RedFlags.fETA
+let betadeltaiota = Closure.RedFlags.red_add betadelta Closure.RedFlags.fIOTA
+let betadeltaiota_nolet = Closure.betadeltaiotanolet
+let betadeltaiotaeta = Closure.RedFlags.red_add betadeltaiota Closure.RedFlags.fETA
 
 (* Beta Reduction tools *)
 
-let rec stacklam recfun env t stack =
-  match (decomp_stack stack,kind_of_term t) with
-    | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl
-    | _ -> recfun (substl env t, stack)
+let apply_subst recfun env cst_l t stack =
+  let rec aux env cst_l t stack =
+    match (Stack.decomp stack,kind_of_term t) with
+    | Some (h,stacktl), Lambda (_,_,c) ->
+      aux (h::env) (Cst_stack.add_param h cst_l) c stacktl
+    | _ -> recfun cst_l (substl env t, stack)
+  in aux env cst_l t stack
+
+let stacklam recfun env t stack =
+  apply_subst (fun _ -> recfun) env Cst_stack.empty t stack
 
 let beta_applist (c,l) =
-  stacklam app_stack [] c (append_stack_list l empty_stack)
+  stacklam Stack.zip [] c (Stack.append_app_list l Stack.empty)
 
 (* Iota reduction tools *)
 
@@ -239,16 +661,64 @@ let reducible_mind_case c = match kind_of_term c with
   | Construct _ | CoFix _ -> true
   | _  -> false
 
-let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
+(** @return c if there is a constant c whose body is bd
+    @return bd else.
+
+    It has only a meaning because internal representation of "Fixpoint f x
+    := t" is Definition f := fix f x => t
+
+    Even more fragile that we could hope because do Module M. Fixpoint
+    f x := t. End M. Definition f := u. and say goodbye to any hope
+    of refolding M.f this way ...
+*)
+let magicaly_constant_of_fixbody env reference bd = function
+  | Name.Anonymous -> bd
+  | Name.Name id ->
+    try
+      let (cst_mod,cst_sect,_) = Constant.repr3 reference in
+      let cst = Constant.make3 cst_mod cst_sect (Label.of_id id) in
+      let (cst, u), ctx = Universes.fresh_constant_instance env cst in
+      match constant_opt_value_in env (cst,u) with
+      | None -> bd
+      | Some t ->
+        let b, csts = Universes.eq_constr_universes t bd in
+    	let subst = Universes.Constraints.fold (fun (l,d,r) acc ->
+    	  Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc)
+    	  csts Univ.LMap.empty
+    	in
+    	let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in
+          if b then mkConstU (cst,inst) else bd
+    with
+    | Not_found -> bd
+
+let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies)) =
   let nbodies = Array.length bodies in
-  let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in
-  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+  let make_Fi j =
+    let ind = nbodies-j-1 in
+    if Int.equal bodynum ind then mkCoFix (ind,typedbodies)
+    else
+      let bd = mkCoFix (ind,typedbodies) in
+      match env with
+      | None -> bd
+      | Some e ->
+        match reference with
+        | None -> bd
+        | Some r -> magicaly_constant_of_fixbody e r bd names.(ind) in
+  let closure = List.init nbodies make_Fi in
+  substl closure bodies.(bodynum)
+
+(** Similar to the "fix" case below *)
+let reduce_and_refold_cofix recfun env cst_l cofix sk =
+  let raw_answer = contract_cofix ~env ?reference:(Cst_stack.reference cst_l) cofix in
+  apply_subst
+    (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkCoFix cofix) cst_l t,sk'))
+    [] Cst_stack.empty raw_answer sk
 
 let reduce_mind_case mia =
   match kind_of_term mia.mconstr with
-    | Construct (ind_sp,i) ->
+    | Construct ((ind_sp,i),u) ->
 (*	let ncargs = (fst mia.mci).(i-1) in*)
-	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
+	let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in
         applist (mia.mlf.(i-1),real_cargs)
     | CoFix cofix ->
 	let cofix_def = contract_cofix cofix in
@@ -258,164 +728,370 @@ let reduce_mind_case mia =
 (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce
    Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *)
 
-let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) =
-  let nbodies = Array.length recindices in
-  let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in
-  substl (list_tabulate make_Fi nbodies) bodies.(bodynum)
+let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) =
+    let nbodies = Array.length recindices in
+    let make_Fi j =
+      let ind = nbodies-j-1 in
+      if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies)
+      else
+	let bd = mkFix ((recindices,ind),typedbodies) in
+	match env with
+	| None -> bd
+	| Some e ->
+          match reference with
+          | None -> bd
+          | Some r -> magicaly_constant_of_fixbody e r bd names.(ind) in
+    let closure = List.init nbodies make_Fi in
+    substl closure bodies.(bodynum)
+
+(** First we substitute the Rel bodynum by the fixpoint and then we try to
+    replace the fixpoint by the best constant from [cst_l]
+    Other rels are directly substituted by constants "magically found from the
+    context" in contract_fix *)
+let reduce_and_refold_fix recfun env cst_l fix sk =
+  let raw_answer = contract_fix ~env ?reference:(Cst_stack.reference cst_l) fix in
+  apply_subst
+    (fun x (t,sk') -> recfun x (Cst_stack.best_replace (mkFix fix) cst_l t,sk'))
+    [] Cst_stack.empty raw_answer sk
 
 let fix_recarg ((recindices,bodynum),_) stack =
-  assert (0 <= bodynum & bodynum < Array.length recindices);
+  assert (0 <= bodynum && bodynum < Array.length recindices);
   let recargnum = Array.get recindices bodynum in
   try
-    Some (recargnum, stack_nth stack recargnum)
+    Some (recargnum, Stack.nth stack recargnum)
   with Not_found ->
     None
 
-type fix_reduction_result = NotReducible | Reduced of state
+(** Generic reduction function with environment
 
-let reduce_fix whdfun sigma fix stack =
-  match fix_recarg fix stack with
-    | None -> NotReducible
-    | Some (recargnum,recarg) ->
-        let (recarg'hd,_ as recarg') = whdfun sigma (recarg, empty_stack) in
-        let stack' = stack_assign stack recargnum (app_stack recarg') in
-	(match kind_of_term recarg'hd with
-           | Construct _ -> Reduced (contract_fix fix, stack')
-	   | _ -> NotReducible)
+    Here is where unfolded constant are stored in order to be
+    eventualy refolded.
 
-(* Generic reduction function *)
+    If tactic_mode is true, it uses ReductionBehaviour, prefers
+    refold constant instead of value and tries to infer constants
+    fix and cofix came from.
 
-(* Y avait un commentaire pour whd_betadeltaiota :
-
-   NB : Cette fonction alloue peu c'est l'appel
-     ``let (c,cargs) = whfun (recarg, empty_stack)''
-                              -------------------
-   qui coute cher *)
+    It substitutes fix and cofix by the constant they come from in
+    contract_* in any case .
+*)
 
-let rec whd_state_gen flags ts env sigma =
-  let rec whrec (x, stack as s) =
+let debug_RAKAM = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Print states of the Reductionops abstract machine";
+  Goptions.optkey = ["Debug";"RAKAM"];
+  Goptions.optread = (fun () -> !debug_RAKAM);
+  Goptions.optwrite = (fun a -> debug_RAKAM:=a);
+}
+
+let equal_stacks (x, l) (y, l') =
+  let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in
+  let eq_fix (a,b) (c,d) = f_equal (Constr.mkFix a, b) (Constr.mkFix c, d) in
+    match Stack.equal f_equal eq_fix l l' with
+    | None -> false
+    | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) 
+
+let rec whd_state_gen ?csts tactic_mode flags env sigma =
+  let rec whrec cst_l (x, stack as s) =
+    let () = if !debug_RAKAM then
+	let open Pp in
+	pp (h 0 (str "<<" ++ Termops.print_constr x ++
+		   str "|" ++ cut () ++ Cst_stack.pr cst_l ++
+		   str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++
+		   str ">>") ++ fnl ())
+    in
+    let fold () =
+      let () = if !debug_RAKAM then
+	  let open Pp in pp (str "<><><><><>" ++ fnl ()) in
+      if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else (s,cst_l)
+    in
     match kind_of_term x with
-      | Rel n when red_delta flags ->
-	  (match lookup_rel n env with
-	     | (_,Some body,_) -> whrec (lift n body, stack)
-	     | _ -> s)
-      | Var id when red_delta flags ->
-	  (match lookup_named id env with
-	     | (_,Some body,_) -> whrec (body, stack)
-	     | _ -> s)
-      | Evar ev ->
-	  (match safe_evar_value sigma ev with
-	     | Some body -> whrec (body, stack)
-	     | None -> s)
-      | Meta ev ->
-	  (match safe_meta_value sigma ev with
-	     | Some body -> whrec (body, stack)
-	     | None -> s)
-      | Const const when is_transparent_constant ts const ->
-	  (match constant_opt_value env const with
-	     | Some  body -> whrec (body, stack)
-	     | None -> s)
-      | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
-      | Cast (c,_,_) -> whrec (c, stack)
-      | App (f,cl)  -> whrec (f, append_stack cl stack)
-      | Lambda (na,t,c) ->
-          (match decomp_stack stack with
-             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
-             | None when red_eta flags ->
-		 let env' = push_rel (na,None,t) env in
-		 let whrec' = whd_state_gen flags ts env' sigma in
-                 (match kind_of_term (app_stack (whrec' (c, empty_stack))) with
-                    | App (f,cl) ->
-			let napp = Array.length cl in
-			if napp > 0 then
-			  let x', l' = whrec' (array_last cl, empty_stack) in
-                          match kind_of_term x', decomp_stack l' with
-                            | Rel 1, None ->
-				let lc = Array.sub cl 0 (napp-1) in
-				let u = if napp=1 then f else appvect (f,lc) in
-				if noccurn 1 u then (pop u,empty_stack) else s
-                            | _ -> s
-			else s
-		    | _ -> s)
-	     | _ -> s)
-
-      | Case (ci,p,d,lf) when red_iota flags ->
-          let (c,cargs) = whrec (d, empty_stack) in
-          if reducible_mind_case c then
-            whrec (reduce_mind_case
-                     {mP=p; mconstr=c; mcargs=list_of_stack cargs;
-		      mci=ci; mlf=lf}, stack)
-          else
-	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
-
-      | Fix fix when red_iota flags ->
-	  (match reduce_fix (fun _ -> whrec) sigma fix stack with
-             | Reduced s' -> whrec s'
-	     | NotReducible -> s)
-
-      | x -> s
+    | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA ->
+      (match lookup_rel n env with
+      | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack)
+      | _ -> fold ())
+    | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) ->
+      (match lookup_named id env with
+      | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack)
+      | _ -> fold ())
+    | Evar ev ->
+      (match safe_evar_value sigma ev with
+      | Some body -> whrec cst_l (body, stack)
+      | None -> fold ())
+    | Meta ev ->
+      (match safe_meta_value sigma ev with
+      | Some body -> whrec cst_l (body, stack)
+      | None -> fold ())
+    | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) ->
+       (match constant_opt_value_in env const with
+	| None -> fold ()
+	| Some body ->
+	   if not tactic_mode
+	   then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
+	   else (* Looks for ReductionBehaviour *)
+	     match ReductionBehaviour.get (Globnames.ConstRef c) with
+	     | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack)
+	     | Some (recargs, nargs, flags) ->
+		if (List.mem `ReductionNeverUnfold flags
+		    || (nargs > 0 && Stack.args_size stack < nargs))
+		then fold ()
+		else (* maybe unfolds *)
+		  if List.mem `ReductionDontExposeCase flags then
+		    let app_sk,sk = Stack.strip_app stack in
+		    let (tm',sk'),cst_l' =
+		      whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk)
+		    in
+		      if equal_stacks (x, app_sk) (tm', sk') || Stack.will_expose_iota sk'
+		      then fold ()
+		      else whrec cst_l' (tm', sk' @ sk)
+		  else match recargs with
+		  |[] -> (* if nargs has been specified *)
+			 (* CAUTION : the constant is NEVER refold
+                            (even when it hides a (co)fix) *)
+		    whrec cst_l (body, stack)
+		  |curr::remains -> match Stack.strip_n_app curr stack with
+		    | None -> fold ()
+		    | Some (bef,arg,s') ->
+		      whrec Cst_stack.empty 
+			(arg,Stack.Cst(Stack.Cst_const const,curr,remains,bef,cst_l)::s')
+       )
+    | Proj (p, c) when Closure.RedFlags.red_projection flags p ->
+      (let pb = lookup_projection p env in
+       let kn = Projection.constant p in
+       let npars = pb.Declarations.proj_npars 
+       and arg = pb.Declarations.proj_arg in
+	 if not tactic_mode then 
+	   let stack' = (c, Stack.Proj (npars, arg, p, Cst_stack.empty (*cst_l*)) :: stack) in
+	     whrec Cst_stack.empty stack'
+	 else match ReductionBehaviour.get (Globnames.ConstRef kn) with
+	 | None ->
+	   let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in
+	   let stack'', csts = whrec Cst_stack.empty stack' in
+	     if equal_stacks stack' stack'' then fold ()
+	     else stack'', csts
+	 | Some (recargs, nargs, flags) ->
+	   if (List.mem `ReductionNeverUnfold flags
+	       || (nargs > 0 && Stack.args_size stack < (nargs - (npars + 1))))
+	   then fold ()
+	   else
+	     let recargs = List.map_filter (fun x -> 
+	       let idx = x - npars in 
+		 if idx < 0 then None else Some idx) recargs
+	     in
+	       match recargs with
+	       |[] -> (* if nargs has been specified *)
+		(* CAUTION : the constant is NEVER refold
+                   (even when it hides a (co)fix) *)
+		 let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in
+		   whrec Cst_stack.empty(* cst_l *) stack'
+	       | curr::remains -> 
+		 if curr == 0 then (* Try to reduce the record argument *)
+		   whrec Cst_stack.empty 
+		     (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack)
+		 else
+		   match Stack.strip_n_app curr stack with
+		   | None -> fold ()
+		   | Some (bef,arg,s') ->
+		     whrec Cst_stack.empty 
+		       (arg,Stack.Cst(Stack.Cst_proj p,curr,remains,
+				      Stack.append_app [|c|] bef,cst_l)::s'))
+
+    | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
+      apply_subst whrec [b] cst_l c stack
+    | Cast (c,_,_) -> whrec cst_l (c, stack)
+    | App (f,cl)  ->
+      whrec
+	(Cst_stack.add_args cl cst_l)
+	(f, Stack.append_app cl stack)
+    | Lambda (na,t,c) ->
+      (match Stack.decomp stack with
+      | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
+	apply_subst whrec [] cst_l x stack
+      | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
+	let env' = push_rel (na,None,t) env in
+	let whrec' = whd_state_gen tactic_mode flags env' sigma in
+        (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with
+        | App (f,cl) ->
+	  let napp = Array.length cl in
+	  if napp > 0 then
+	    let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in
+            match kind_of_term x', l' with
+            | Rel 1, [] ->
+	      let lc = Array.sub cl 0 (napp-1) in
+	      let u = if Int.equal napp 1 then f else appvect (f,lc) in
+	      if noccurn 1 u then (pop u,Stack.empty),Cst_stack.empty else fold ()
+            | _ -> fold ()
+	  else fold ()
+	| _ -> fold ())
+      | _ -> fold ())
+
+    | Case (ci,p,d,lf) ->
+      whrec Cst_stack.empty (d, Stack.Case (ci,p,lf,cst_l) :: stack)
+
+    | Fix ((ri,n),_ as f) ->
+      (match Stack.strip_n_app ri.(n) stack with
+      |None -> fold ()
+      |Some (bef,arg,s') ->
+	whrec Cst_stack.empty (arg, Stack.Fix(f,bef,cst_l)::s'))
+
+    | Construct ((ind,c),u) ->
+      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+	match Stack.strip_app stack with
+	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	  whrec Cst_stack.empty (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
+	|args, (Stack.Proj (n,m,p,_)::s') ->
+	  whrec Cst_stack.empty (Stack.nth args (n+m), s')
+	|args, (Stack.Fix (f,s',cst_l)::s'') ->
+	  let x' = Stack.zip(x,args) in
+	  let out_sk = s' @ (Stack.append_app [|x'|] s'') in
+	  reduce_and_refold_fix whrec env cst_l f out_sk
+	|args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') ->
+	  let x' = Stack.zip(x,args) in
+	  begin match remains with
+	  | [] -> 
+	    (match const with
+	    | Stack.Cst_const const ->
+	      (match constant_opt_value_in env const with
+	      | None -> fold ()
+	      | Some body ->
+		whrec (Cst_stack.add_cst (mkConstU const) cst_l)
+		  (body, s' @ (Stack.append_app [|x'|] s'')))
+	    | Stack.Cst_proj p ->
+	      let pb = lookup_projection p env in
+	      let npars = pb.Declarations.proj_npars in
+	      let narg = pb.Declarations.proj_arg in
+	      let stack = s' @ (Stack.append_app [|x'|] s'') in
+		match Stack.strip_n_app 0 stack with
+		| None -> assert false
+		| Some (_,arg,s'') ->
+		  whrec Cst_stack.empty (arg, Stack.Proj (npars,narg,p,cst_l) :: s''))
+	  | next :: remains' -> match Stack.strip_n_app (next-curr-1) s'' with
+	    | None -> fold ()
+	    | Some (bef,arg,s''') ->
+	      whrec Cst_stack.empty
+		(arg,
+		 Stack.Cst (const,next,remains',s' @ (Stack.append_app [|x'|] bef),cst_l) :: s''')
+	  end
+	|_, (Stack.App _|Stack.Update _|Stack.Shift _)::_ -> assert false
+	|_, [] -> fold ()
+      else fold ()
+
+    | CoFix cofix ->
+      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+	match Stack.strip_app stack with
+	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	  reduce_and_refold_cofix whrec env cst_l cofix stack
+	|_ -> fold ()
+      else fold ()
+
+    | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold ()
+    | Sort _ | Ind _ | Prod _ -> fold ()
   in
-  whrec
+  whrec (Option.default Cst_stack.empty csts)
 
+(** reduction machine without global env and refold machinery *)
 let local_whd_state_gen flags sigma =
   let rec whrec (x, stack as s) =
     match kind_of_term x with
-      | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
-      | Cast (c,_,_) -> whrec (c, stack)
-      | App (f,cl)  -> whrec (f, append_stack cl stack)
-      | Lambda (_,_,c) ->
-          (match decomp_stack stack with
-             | Some (a,m) when red_beta flags -> stacklam whrec [a] c m
-             | None when red_eta flags ->
-                 (match kind_of_term (app_stack (whrec (c, empty_stack))) with
-                    | App (f,cl) ->
-			let napp = Array.length cl in
-			if napp > 0 then
-			  let x', l' = whrec (array_last cl, empty_stack) in
-                          match kind_of_term x', decomp_stack l' with
-                            | Rel 1, None ->
-				let lc = Array.sub cl 0 (napp-1) in
-				let u = if napp=1 then f else appvect (f,lc) in
-				if noccurn 1 u then (pop u,empty_stack) else s
-                            | _ -> s
-			else s
-		    | _ -> s)
-	     | _ -> s)
-
-      | Case (ci,p,d,lf) when red_iota flags ->
-          let (c,cargs) = whrec (d, empty_stack) in
-          if reducible_mind_case c then
-            whrec (reduce_mind_case
-                     {mP=p; mconstr=c; mcargs=list_of_stack cargs;
-		      mci=ci; mlf=lf}, stack)
-          else
-	    (mkCase (ci, p, app_stack (c,cargs), lf), stack)
-
-      | Fix fix when red_iota flags ->
-	  (match reduce_fix (fun _ ->whrec) sigma fix stack with
-             | Reduced s' -> whrec s'
-	     | NotReducible -> s)
-
-      | Evar ev ->
-          (match safe_evar_value sigma ev with
-              Some c -> whrec (c,stack)
-            | None -> s)
-
-      | Meta ev ->
-          (match safe_meta_value sigma ev with
-              Some c -> whrec (c,stack)
-            | None -> s)
-
-      | x -> s
+    | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA ->
+      stacklam whrec [b] c stack
+    | Cast (c,_,_) -> whrec (c, stack)
+    | App (f,cl)  -> whrec (f, Stack.append_app cl stack)
+    | Lambda (_,_,c) ->
+      (match Stack.decomp stack with
+      | Some (a,m) when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA ->
+	stacklam whrec [a] c m
+      | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA ->
+        (match kind_of_term (Stack.zip (whrec (c, Stack.empty))) with
+        | App (f,cl) ->
+	  let napp = Array.length cl in
+	  if napp > 0 then
+	    let x', l' = whrec (Array.last cl, Stack.empty) in
+            match kind_of_term x', l' with
+            | Rel 1, [] ->
+	      let lc = Array.sub cl 0 (napp-1) in
+	      let u = if Int.equal napp 1 then f else appvect (f,lc) in
+	      if noccurn 1 u then (pop u,Stack.empty) else s
+            | _ -> s
+	  else s
+	| _ -> s)
+      | _ -> s)
+
+    | Proj (p,c) when Closure.RedFlags.red_projection flags p ->
+      (let pb = lookup_projection p (Global.env ()) in
+	 whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+			       p, Cst_stack.empty)
+           :: stack))
+
+    | Case (ci,p,d,lf) ->
+      whrec (d, Stack.Case (ci,p,lf,Cst_stack.empty) :: stack)
+
+    | Fix ((ri,n),_ as f) ->
+      (match Stack.strip_n_app ri.(n) stack with
+      |None -> s
+      |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef,Cst_stack.empty)::s'))
+
+    | Evar ev ->
+      (match safe_evar_value sigma ev with
+        Some c -> whrec (c,stack)
+      | None -> s)
+
+    | Meta ev ->
+      (match safe_meta_value sigma ev with
+        Some c -> whrec (c,stack)
+      | None -> s)
+
+    | Construct ((ind,c),u) ->
+      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+	match Stack.strip_app stack with
+	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	  whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s')
+	|args, (Stack.Proj (n,m,p,_) :: s') ->
+	  whrec (Stack.nth args (n+m), s')
+	|args, (Stack.Fix (f,s',cst)::s'') ->
+	  let x' = Stack.zip(x,args) in
+	  whrec (contract_fix f, s' @ (Stack.append_app [|x'|] s''))
+	|_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false
+	|_, [] -> s
+      else s
+
+    | CoFix cofix ->
+      if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then
+	match Stack.strip_app stack with
+	|args, (Stack.Case(ci, _, lf,_)::s') ->
+	  whrec (contract_cofix cofix, stack)
+	|_ -> s
+      else s
+
+    | x -> s
   in
   whrec
 
+let raw_whd_state_gen flags env =
+  let f sigma s = fst (whd_state_gen false flags env sigma s) in
+  f
 
-let stack_red_of_state_red f sigma x =
-  appterm_of_stack (f sigma (x, empty_stack))
+let stack_red_of_state_red f =
+  let f sigma x = decompose_app (Stack.zip (f sigma (x, Stack.empty))) in
+  f
+
+(* Drops the Cst_stack *)
+let iterate_whd_gen refold flags env sigma s =
+  let rec aux t =
+  let (hd,sk),_ = whd_state_gen refold flags env sigma (t,Stack.empty) in
+  let whd_sk = Stack.map aux sk in
+  Stack.zip ~refold (hd,whd_sk)
+  in aux s
 
 let red_of_state_red f sigma x =
-  app_stack (f sigma (x,empty_stack))
+  Stack.zip (f sigma (x,Stack.empty))
+
+(* 0. No Reduction Functions *)
+
+let whd_nored_state = local_whd_state_gen nored
+let whd_nored_stack = stack_red_of_state_red whd_nored_state
+let whd_nored = red_of_state_red whd_nored_state
 
 (* 1. Beta Reduction Functions *)
 
@@ -434,19 +1110,18 @@ let whd_betalet = red_of_state_red whd_betalet_state
 
 (* 2. Delta Reduction Functions *)
 
-let whd_delta_state e = whd_state_gen delta full_transparent_state e
+let whd_delta_state e = raw_whd_state_gen delta e
 let whd_delta_stack env = stack_red_of_state_red (whd_delta_state env)
 let whd_delta env = red_of_state_red  (whd_delta_state env)
 
-let whd_betadelta_state e = whd_state_gen betadelta full_transparent_state e
+let whd_betadelta_state e = raw_whd_state_gen betadelta e
 let whd_betadelta_stack env =
   stack_red_of_state_red (whd_betadelta_state env)
 let whd_betadelta env =
   red_of_state_red (whd_betadelta_state env)
 
 
-let whd_betadeltaeta_state e =
-  whd_state_gen betadeltaeta full_transparent_state e
+let whd_betadeltaeta_state e = raw_whd_state_gen betadeltaeta e
 let whd_betadeltaeta_stack env =
   stack_red_of_state_red (whd_betadeltaeta_state env)
 let whd_betadeltaeta env =
@@ -462,29 +1137,19 @@ let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta
 let whd_betaiotazeta_stack = stack_red_of_state_red whd_betaiotazeta_state
 let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state
 
-let whd_betadeltaiota_state env =
-  whd_state_gen betadeltaiota full_transparent_state env
+let whd_betadeltaiota_state env = raw_whd_state_gen betadeltaiota env
 let whd_betadeltaiota_stack env =
   stack_red_of_state_red (whd_betadeltaiota_state env)
 let whd_betadeltaiota env =
   red_of_state_red (whd_betadeltaiota_state env)
 
-let whd_betadeltaiota_state_using ts env =
-  whd_state_gen betadeltaiota ts env
-let whd_betadeltaiota_stack_using ts env =
-  stack_red_of_state_red (whd_betadeltaiota_state_using ts env)
-let whd_betadeltaiota_using ts env =
-  red_of_state_red (whd_betadeltaiota_state_using ts env)
-
-let whd_betadeltaiotaeta_state env =
-  whd_state_gen betadeltaiotaeta full_transparent_state env
+let whd_betadeltaiotaeta_state env = raw_whd_state_gen betadeltaiotaeta env
 let whd_betadeltaiotaeta_stack env =
   stack_red_of_state_red (whd_betadeltaiotaeta_state env)
 let whd_betadeltaiotaeta env =
   red_of_state_red (whd_betadeltaiotaeta_state env)
 
-let whd_betadeltaiota_nolet_state env =
-  whd_state_gen betadeltaiota_nolet full_transparent_state env
+let whd_betadeltaiota_nolet_state env = raw_whd_state_gen betadeltaiota_nolet env
 let whd_betadeltaiota_nolet_stack env =
   stack_red_of_state_red (whd_betadeltaiota_nolet_state env)
 let whd_betadeltaiota_nolet env =
@@ -492,11 +1157,11 @@ let whd_betadeltaiota_nolet env =
 
 (* 4. Eta reduction Functions *)
 
-let whd_eta c = app_stack (local_whd_state_gen eta Evd.empty (c,empty_stack))
+let whd_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty))
 
 (* 5. Zeta Reduction Functions *)
 
-let whd_zeta c = app_stack (local_whd_state_gen zeta Evd.empty (c,empty_stack))
+let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty))
 
 (****************************************************************************)
 (*                   Reduction Functions                                    *)
@@ -506,10 +1171,23 @@ let whd_zeta c = app_stack (local_whd_state_gen zeta Evd.empty (c,empty_stack))
 let rec whd_evar sigma c =
   match kind_of_term c with
     | Evar ev ->
-        (match safe_evar_value sigma ev with
+        let (evk, args) = ev in
+        let args = Array.map (fun c -> whd_evar sigma c) args in
+        (match safe_evar_value sigma (evk, args) with
             Some c -> whd_evar sigma c
           | None -> c)
-    | Sort s -> whd_sort_variable sigma c
+    | Sort (Type u) -> 
+      let u' = Evd.normalize_universe sigma u in
+	if u' == u then c else mkSort (Sorts.sort_of_univ u')
+    | Const (c', u) when not (Univ.Instance.is_empty u) -> 
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkConstU (c', u')
+    | Ind (i, u) when not (Univ.Instance.is_empty u) -> 
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkIndU (i, u')
+    | Construct (co, u) when not (Univ.Instance.is_empty u) ->
+      let u' = Evd.normalize_universe_instance sigma u in
+	if u' == u then c else mkConstructU (co, u')
     | _ -> c
 
 let nf_evar =
@@ -520,66 +1198,19 @@ let nf_evar =
    a [nf_evar] here *)
 let clos_norm_flags flgs env sigma t =
   try
-    norm_val
-      (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
-      (inject t)
-  with Anomaly _ -> error "Tried to normalized ill-typed term" 
-
-let nf_beta = clos_norm_flags Closure.beta empty_env
-let nf_betaiota = clos_norm_flags Closure.betaiota empty_env
+    let evars ev = safe_evar_value sigma ev in
+    Closure.norm_val
+      (Closure.create_clos_infos ~evars flgs env)
+      (Closure.inject t)
+  with e when is_anomaly e -> error "Tried to normalize ill-typed term"
+
+let nf_beta = clos_norm_flags Closure.beta (Global.env ())
+let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ())
+let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ())
 let nf_betadeltaiota env sigma =
   clos_norm_flags Closure.betadeltaiota env sigma
 
 
-(* Attention reduire un beta-redexe avec un argument qui n'est pas
-   une variable, peut changer enormement le temps de conversion lors
-   du type checking :
-     (fun x => x + x) M
-*)
-let rec whd_betaiota_preserving_vm_cast env sigma t =
-   let rec stacklam_var subst t stack =
-     match (decomp_stack stack,kind_of_term t) with
-     | Some (h,stacktl), Lambda (_,_,c) ->
-         begin match kind_of_term h with
-         | Rel i when not (evaluable_rel i env) ->
-             stacklam_var (h::subst) c stacktl
-         | Var id when  not (evaluable_named id env)->
-             stacklam_var (h::subst) c stacktl
-         | _ -> whrec (substl subst t, stack)
-         end
-     | _ -> whrec (substl subst t, stack)
-   and whrec (x, stack as s) =
-     match kind_of_term x with
-       | Evar ev ->
-           (match safe_evar_value sigma ev with
-              | Some body -> whrec (body, stack)
-              | None -> s)
-       | Cast (c,VMcast,t) ->
-           let c = app_stack (whrec (c,empty_stack)) in
-           let t = app_stack (whrec (t,empty_stack)) in
-           (mkCast(c,VMcast,t),stack)
-       | Cast (c,DEFAULTcast,_) ->
-           whrec (c, stack)
-       | App (f,cl)  -> whrec (f, append_stack cl stack)
-       | Lambda (na,t,c) ->
-           (match decomp_stack stack with
-            | Some (a,m) -> stacklam_var [a] c m
-            | _ -> s)
-       | Case (ci,p,d,lf) ->
-           let (c,cargs) = whrec (d, empty_stack) in
-           if reducible_mind_case c then
-             whrec (reduce_mind_case
-                      {mP=p; mconstr=c; mcargs=list_of_stack cargs;
-                       mci=ci; mlf=lf}, stack)
-           else
-             (mkCase (ci, p, app_stack (c,cargs), lf), stack)
-       | x -> s
-   in
-   app_stack (whrec (t,empty_stack))
-
-let nf_betaiota_preserving_vm_cast =
-  strong whd_betaiota_preserving_vm_cast
-
 (********************************************************************)
 (*                         Conversion                               *)
 (********************************************************************)
@@ -591,40 +1222,88 @@ let fakey = Profile.declare_profile "fhnf_apply";;
 let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
 *)
 
-let is_transparent k =
-  Conv_oracle.get_strategy k <> Conv_oracle.Opaque
+let is_transparent e k =
+  match Conv_oracle.get_strategy (Environ.oracle e) k with
+  | Conv_oracle.Opaque -> false
+  | _ -> true
 
 (* Conversion utility functions *)
 
 type conversion_test = constraints -> constraints
 
-let pb_is_equal pb = pb = CONV
+let pb_is_equal pb = pb == Reduction.CONV
 
 let pb_equal = function
-  | CUMUL -> CONV
-  | CONV -> CONV
-
-let sort_cmp = sort_cmp
+  | Reduction.CUMUL -> Reduction.CONV
+  | Reduction.CONV -> Reduction.CONV
 
-let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y =
-  try let _ =
-    f ~evars:(safe_evar_value sigma) env x y in true
-  with NotConvertible -> false
-    | Anomaly _ -> error "Conversion test raised an anomaly"
-
-let is_conv env sigma = test_conversion Reduction.conv env sigma
-let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
-let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
+let sort_cmp cv_pb s1 s2 u = 
+  Reduction.check_sort_cmp_universes cv_pb s1 s2 u
 
 let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y =
-  try let _ = f ~evars:(safe_evar_value sigma) reds env x y in true
-  with NotConvertible -> false
-    | Anomaly _ -> error "Conversion test raised an anomaly"
-
-let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma
-let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma
-let is_trans_fconv = function | CONV -> is_trans_conv | CUMUL -> is_trans_conv_leq
-
+  try
+    let evars ev = safe_evar_value sigma ev in
+    let _ = f ~evars reds env (Evd.universes sigma) x y in
+    true
+  with Reduction.NotConvertible -> false
+    | e when is_anomaly e -> error "Conversion test raised an anomaly"
+
+let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma
+let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma
+let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq
+
+let is_conv = is_trans_conv full_transparent_state
+let is_conv_leq = is_trans_conv_leq full_transparent_state
+let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq
+
+let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = 
+  let f = match pb with
+    | Reduction.CONV -> Reduction.trans_conv_universes
+    | Reduction.CUMUL -> Reduction.trans_conv_leq_universes 
+  in
+    try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true
+    with Reduction.NotConvertible -> false
+    | Univ.UniverseInconsistency _ -> false
+    | e when is_anomaly e -> error "Conversion test raised an anomaly"
+
+let sigma_compare_sorts env pb s0 s1 sigma =
+  match pb with
+  | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1
+  | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1
+    
+let sigma_compare_instances flex i0 i1 sigma =
+  try Evd.set_eq_instances ~flex sigma i0 i1
+  with Evd.UniversesDiffer -> raise Reduction.NotConvertible
+
+let sigma_univ_state = 
+  { Reduction.compare = sigma_compare_sorts;
+    Reduction.compare_instances = sigma_compare_instances }
+
+let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = 
+  try 
+    let b, sigma = 
+      let b, cstrs = 
+	if pb == Reduction.CUMUL then 
+	  Universes.leq_constr_univs_infer (Evd.universes sigma) x y 
+	else
+	  Universes.eq_constr_univs_infer (Evd.universes sigma) x y 
+      in
+	if b then 
+	  try true, Evd.add_universe_constraints sigma cstrs
+	  with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma
+	else false, sigma
+    in
+      if b then sigma, true
+      else
+	let sigma' = 
+	  Reduction.generic_conv pb false (safe_evar_value sigma) ts 
+	    env (sigma, sigma_univ_state) x y in
+	  sigma', true
+  with
+  | Reduction.NotConvertible -> sigma, false
+  | Univ.UniverseInconsistency _ -> sigma, false
+  | e when is_anomaly e -> error "Conversion test raised an anomaly"
+    
 (********************************************************************)
 (*             Special-Purpose Reduction                            *)
 (********************************************************************)
@@ -633,33 +1312,36 @@ let whd_meta sigma c = match kind_of_term c with
   | Meta p -> (try meta_value sigma p with Not_found -> c)
   | _ -> c
 
+let default_plain_instance_ident = Id.of_string "H"
+
 (* Try to replace all metas. Does not replace metas in the metas' values
  * Differs from (strong whd_meta). *)
 let plain_instance s c =
   let rec irec n u = match kind_of_term u with
-    | Meta p -> (try lift n (List.assoc p s) with Not_found -> u)
+    | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u)
     | App (f,l) when isCast f ->
         let (f,_,t) = destCast f in
-        let l' = Array.map (irec n) l in
+        let l' = CArray.Fun1.smartmap irec n l in
         (match kind_of_term f with
         | Meta p ->
 	    (* Don't flatten application nodes: this is used to extract a
                proof-term from a proof-tree and we want to keep the structure
                of the proof-tree *)
-	    (try let g = List.assoc p s in
+	    (try let g = Metamap.find p s in
 	    match kind_of_term g with
             | App _ ->
-                let h = id_of_string "H" in
-                mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
+                let l' = CArray.Fun1.smartmap lift 1 l' in
+                mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l'))
             | _ -> mkApp (g,l')
 	    with Not_found -> mkApp (f,l'))
         | _ -> mkApp (irec n f,l'))
     | Cast (m,_,_) when isMeta m ->
-	(try lift n (List.assoc (destMeta m) s) with Not_found -> u)
+	(try lift n (Metamap.find (destMeta m) s) with Not_found -> u)
     | _ ->
 	map_constr_with_binders succ irec n u
   in
-  if s = [] then c else irec 0 c
+  if Metamap.is_empty s then c
+  else irec 0 c
 
 (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota]
    has (unfortunately) different subtle side effects:
@@ -708,7 +1390,7 @@ let instance sigma s c =
 let hnf_prod_app env sigma t n =
   match kind_of_term (whd_betadeltaiota env sigma 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_appvect env sigma t nl =
   Array.fold_left (hnf_prod_app env sigma) t nl
@@ -719,7 +1401,7 @@ let hnf_prod_applist env sigma t nl =
 let hnf_lam_app env sigma t n =
   match kind_of_term (whd_betadeltaiota env sigma t) with
     | Lambda (_,_,b) -> subst1 n b
-    | _ -> anomaly "hnf_lam_app: Need an abstraction"
+    | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction")
 
 let hnf_lam_appvect env sigma t nl =
   Array.fold_left (hnf_lam_app env sigma) t nl
@@ -760,7 +1442,10 @@ let splay_prod_assum env sigma =
 	prodec_rec (push_rel (x, Some b, t) env)
 	  (add_rel_decl (x, Some b, t) l) c
     | Cast (c,_,_)    -> prodec_rec env l c
-    | _               -> l,t
+    | _               -> 
+      let t' = whd_betadeltaiota env sigma t in
+	if Term.eq_constr t t' then l,t
+	else prodec_rec env l t'
   in
   prodec_rec env empty_rel_context
 
@@ -773,7 +1458,7 @@ let splay_arity env sigma c =
 let sort_of_arity env sigma c = snd (splay_arity env sigma c)
 
 let splay_prod_n env sigma n =
-  let rec decrec env m ln c = if m = 0 then (ln,c) else
+  let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Prod (n,a,c0) ->
 	  decrec (push_rel (n,None,a) env)
@@ -783,7 +1468,7 @@ let splay_prod_n env sigma n =
   decrec env n empty_rel_context
 
 let splay_lam_n env sigma n =
-  let rec decrec env m ln c = if m = 0 then (ln,c) else
+  let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else
     match kind_of_term (whd_betadeltaiota env sigma c) with
       | Lambda (n,a,c0) ->
 	  decrec (push_rel (n,None,a) env)
@@ -792,87 +1477,34 @@ let splay_lam_n env sigma n =
   in
   decrec env n empty_rel_context
 
-exception NotASort
-
-let decomp_sort env sigma t =
+let is_sort env sigma t =
   match kind_of_term (whd_betadeltaiota env sigma t) with
-  | Sort s -> s
-  | _ -> raise NotASort
-
-let is_sort env sigma arity =
-  try let _ = decomp_sort env sigma arity in true
-  with NotASort -> false
+  | Sort s -> true
+  | _ -> false
 
 (* reduction to head-normal-form allowing delta/zeta only in argument
    of case/fix (heuristic used by evar_conv) *)
 
-let whd_betaiota_deltazeta_for_iota_state ts env sigma s =
-  let rec whrec s =
-    let (t, stack as s) = whd_betaiota_state sigma s in
-    match kind_of_term t with
-    | Case (ci,p,d,lf) ->
-        let (cr,crargs) = whd_betadeltaiota_stack_using ts env sigma d in
-        let rslt = mkCase (ci, p, applist (cr,crargs), lf) in
-        if reducible_mind_case cr then
-	  whrec (rslt, stack)
-        else
-	  s
-    | Fix fix ->
-	  (match
-              reduce_fix (whd_betadeltaiota_state_using ts env) sigma fix stack
-           with
-             | Reduced s -> whrec s
-	     | NotReducible -> s)
-    | _ -> s
-  in whrec s
-
-(* A reduction function like whd_betaiota but which keeps casts
- * and does not reduce redexes containing existential variables.
- * Used in Correctness.
- * Added by JCF, 29/1/98. *)
-
-let whd_programs_stack env sigma =
-  let rec whrec (x, stack as s) =
-    match kind_of_term x with
-      | App (f,cl) ->
-	  let n = Array.length cl - 1 in
-	  let c = cl.(n) in
-	  if occur_existential c then
-	    s
-	  else
-	    whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack)
-      | LetIn (_,b,_,c) ->
-	  if occur_existential b then
-	    s
-	  else
-	    stacklam whrec [b] c stack
-      | Lambda (_,_,c) ->
-          (match decomp_stack stack with
-             | None -> s
-             | Some (a,m) -> stacklam whrec [a] c m)
-      | Case (ci,p,d,lf) ->
-	  if occur_existential d then
-	    s
-	  else
-            let (c,cargs) = whrec (d, empty_stack) in
-            if reducible_mind_case c then
-	      whrec (reduce_mind_case
-		       {mP=p; mconstr=c; mcargs=list_of_stack cargs;
-			mci=ci; mlf=lf}, stack)
-	    else
-	      (mkCase (ci, p, app_stack(c,cargs), lf), stack)
-      | Fix fix ->
-	  (match reduce_fix (fun _ ->whrec) sigma  fix stack with
-             | Reduced s' -> whrec s'
-	     | NotReducible -> s)
-      | _ -> s
-  in
-  whrec
-
-let whd_programs env sigma x =
-  app_stack (whd_programs_stack env sigma (x, empty_stack))
-
-exception IsType
+let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s =
+  let rec whrec csts s =
+    let (t, stack as s),csts' = whd_state_gen ~csts false betaiota env sigma s in
+    match Stack.strip_app stack with
+      |args, (Stack.Case _ :: _ as stack') ->
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
+	  (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+	if reducible_mind_case t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
+      |args, (Stack.Fix _ :: _ as stack') ->
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
+	  (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+	if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts'
+      |args, (Stack.Proj (n,m,p,_) :: stack'') ->
+	let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false
+	  (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in
+	if isConstruct t_o then
+	  whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'')
+	else s,csts'
+      |_, ((Stack.App _| Stack.Shift _|Stack.Update _|Stack.Cst _) :: _|[]) -> s,csts'
+  in whrec csts s
 
 let find_conclusion env sigma =
   let rec decrec env c =
@@ -896,74 +1528,86 @@ let meta_value evd mv =
   let rec valrec mv =
     match meta_opt_fvalue evd mv with
     | Some (b,_) ->
-      instance evd
-        (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
-        b.rebus
+      let metas = Metamap.bind valrec b.freemetas in
+      instance evd metas b.rebus
     | None -> mkMeta mv
   in
   valrec mv
 
 let meta_instance sigma b =
-  let c_sigma =
-    List.map
-      (fun mv -> (mv,meta_value sigma mv)) (Metaset.elements b.freemetas)
-  in
-  if c_sigma = [] then b.rebus else instance sigma c_sigma b.rebus
+  let fm = b.freemetas in
+  if Metaset.is_empty fm then b.rebus
+  else
+    let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in
+    instance sigma c_sigma b.rebus
 
 let nf_meta sigma c = meta_instance sigma (mk_freelisted c)
 
 (* Instantiate metas that create beta/iota redexes *)
 
 let meta_reducible_instance evd b =
-  let fm = Metaset.elements b.freemetas in
-  let metas = List.fold_left (fun l mv ->
-    match (try meta_opt_fvalue evd mv with Not_found -> None) with
-    | Some (g,(_,s)) -> (mv,(g.rebus,s))::l
-    | None -> l) [] fm in
+  let fm = b.freemetas in
+  let fold mv accu =
+    let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in
+    match fvalue with
+    | None -> accu
+    | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu
+  in
+  let metas = Metaset.fold fold fm Metamap.empty in
   let rec irec u =
     let u = whd_betaiota Evd.empty u in
     match kind_of_term u with
-    | Case (ci,p,c,bl) when isMeta c or isCast c & isMeta (pi1 (destCast c)) ->
-	let m =
-          try destMeta c
-          with e when Errors.noncritical e -> destMeta (pi1 (destCast c))
-        in
+    | Case (ci,p,c,bl) when isMeta (strip_outer_cast c) ->
+	let m = destMeta (strip_outer_cast c) in
 	(match
 	  try
-	    let g,s = List.assoc m metas in
-	    if isConstruct g or s <> CoerceToType then Some g else None
+	    let g, s = Metamap.find m metas in
+            let is_coerce = match s with CoerceToType -> true | _ -> false in
+	    if isConstruct g || not is_coerce then Some g else None
 	  with Not_found -> None
 	  with
 	    | Some g -> irec (mkCase (ci,p,g,bl))
 	    | None -> mkCase (ci,irec p,c,Array.map irec bl))
-    | App (f,l) when isMeta f or isCast f & isMeta (pi1 (destCast f)) ->
-        let m =
-          try destMeta f
-          with e when Errors.noncritical e -> destMeta (pi1 (destCast f))
-        in
+    | App (f,l) when isMeta (strip_outer_cast f) ->
+	let m = destMeta (strip_outer_cast f) in
 	(match
 	  try
-	    let g,s = List.assoc m metas in
-	    if isLambda g or s <> CoerceToType then Some g else None
+	    let g, s = Metamap.find m metas in
+            let is_coerce = match s with CoerceToType -> true | _ -> false in
+	    if isLambda g || not is_coerce then Some g else None
 	  with Not_found -> None
 	 with
 	   | Some g -> irec (mkApp (g,l))
 	   | None -> mkApp (f,Array.map irec l))
     | Meta m ->
-	(try let g,s = List.assoc m metas in if s<>CoerceToType then irec g else u
+	(try let g, s = Metamap.find m metas in
+          let is_coerce = match s with CoerceToType -> true | _ -> false in
+          if not is_coerce then irec g else u
 	 with Not_found -> u)
+    | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) ->
+	let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in
+	  (match
+	  try
+	    let g, s = Metamap.find m metas in
+            let is_coerce = match s with CoerceToType -> true | _ -> false in
+	    if isConstruct g || not is_coerce then Some g else None
+	  with Not_found -> None
+	  with
+	    | Some g -> irec (mkProj (p,g))
+	    | None -> mkProj (p,c))
     | _ -> map_constr irec u
   in
-  if fm = [] then (* nf_betaiota? *) b.rebus else irec b.rebus
+  if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus
+  else irec b.rebus
 
 
 let head_unfold_under_prod ts env _ c =
-  let unfold cst =
+  let unfold (cst,u as cstu) =
     if Cpred.mem cst (snd ts) then
-      match constant_opt_value env cst with
+      match constant_opt_value_in env cstu with
 	| Some c -> c
-	| None -> mkConst cst
-    else mkConst cst in
+	| None -> mkConstU cstu
+    else mkConstU cstu in
   let rec aux c =
     match kind_of_term c with
       | Prod (n,t,c) -> mkProd (n,aux t, aux c)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index f508ea6c..7c61d4e1 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.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,50 +8,109 @@
 
 open Names
 open Term
+open Context
 open Univ
 open Evd
 open Environ
-open Closure
 
 (** Reduction Functions. *)
 
 exception Elimconst
 
-(***********************************************************************
-  s A [stack] is a context of arguments, arguments are pushed by
-   [append_stack] one array at a time but popped with [decomp_stack]
-   one by one *)
-
-type 'a stack_member =
-  | Zapp of 'a list
-  | Zcase of case_info * 'a * 'a array
-  | Zfix of 'a * 'a stack
-  | Zshift of int
-  | Zupdate of 'a
-
-and 'a stack = 'a stack_member list
-
-val empty_stack : 'a stack
-val append_stack : 'a array -> 'a stack -> 'a stack
-val append_stack_list : 'a list -> 'a stack -> 'a stack
-
-val decomp_stack : 'a stack -> ('a * 'a stack) option
-val list_of_stack : 'a stack -> 'a list
-val array_of_stack : 'a stack -> 'a array
-val stack_assign : 'a stack -> int -> 'a -> 'a stack
-val stack_args_size : 'a stack -> int
-val app_stack : constr * constr stack -> constr
-val stack_tail : int -> 'a stack -> 'a stack
-val stack_nth : 'a stack -> int -> 'a
+(** Machinery to customize the behavior of the reduction *)
+module ReductionBehaviour : sig
+  type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ]
+
+(** [set is_local ref (recargs, nargs, flags)] *)
+  val set :
+    bool -> Globnames.global_reference -> (int list * int * flag list) -> unit
+  val get :
+    Globnames.global_reference -> (int list * int * flag list) option
+  val print : Globnames.global_reference -> Pp.std_ppcmds
+end
+
+(** {6 Machinery about a stack of unfolded constant }
+
+    cst applied to params must convertible to term of the state applied to args
+*)
+module Cst_stack : sig
+  type t
+  val empty : t
+  val add_param : constr -> t -> t
+  val add_args : constr array -> t -> t
+  val add_cst : constr -> t -> t
+  val best_cst : t -> (constr * constr list) option
+  val best_replace : constr -> t -> constr -> constr
+  val reference : t -> Constant.t option
+  val pr : t -> Pp.std_ppcmds
+end
+
+
+module Stack : sig
+  type 'a app_node
+
+  val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds
+
+  type cst_member =
+    | Cst_const of pconstant
+    | Cst_proj of projection
+
+  type 'a member =
+  | App of 'a app_node
+  | Case of case_info * 'a * 'a array * Cst_stack.t
+  | Proj of int * int * projection * Cst_stack.t
+  | Fix of fixpoint * 'a t * Cst_stack.t
+  | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *)
+    * 'a t * Cst_stack.t
+  | Shift of int
+  | Update of 'a
+  and 'a t = 'a member list
+
+  val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds
+
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val append_app : 'a array -> 'a t -> 'a t
+  val decomp : 'a t -> ('a * 'a t) option
+
+  val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t)
+
+  val compare_shape : 'a t -> 'a t -> bool
+  (** [fold2 f x sk1 sk2] folds [f] on any pair of term in [(sk1,sk2)].
+      @return the result and the lifts to apply on the terms *)
+  val fold2 : ('a -> Term.constr -> Term.constr -> 'a) -> 'a ->
+    Term.constr t -> Term.constr t -> 'a * int * int
+  val map : (Term.constr -> Term.constr) -> Term.constr t -> Term.constr t
+  val append_app_list : 'a list -> 'a t -> 'a t
+
+  (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not
+      start by App or Shift *)
+  val strip_app : 'a t -> 'a t * 'a t
+  (** @return (the nth first elements, the (n+1)th element, the remaining stack)  *)
+  val strip_n_app : int -> 'a t -> ('a t * 'a * 'a t) option
+
+  val not_purely_applicative : 'a t -> bool
+  val list_of_app_stack : constr t -> constr list option
+
+  val assign : 'a t -> int -> 'a -> 'a t
+  val args_size : 'a t -> int
+  val tail : int -> 'a t -> 'a t
+  val nth : 'a t -> int -> 'a
+
+  val best_state : constr * constr t -> Cst_stack.t -> constr * constr t
+  val zip : ?refold:bool -> constr * constr t -> constr
+end
 
 (************************************************************************)
 
-type state = constr * constr stack
+type state = constr * constr Stack.t
 
 type contextual_reduction_function = env -> evar_map -> constr -> constr
 type reduction_function = contextual_reduction_function
 type local_reduction_function = evar_map -> constr -> constr
 
+type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
+
 type contextual_stack_reduction_function =
     env -> evar_map -> constr -> constr * constr list
 type stack_reduction_function = contextual_stack_reduction_function
@@ -63,11 +122,7 @@ type contextual_state_reduction_function =
 type state_reduction_function = contextual_state_reduction_function
 type local_state_reduction_function = evar_map -> state -> state
 
-(** Removes cast and put into applicative form *)
-val whd_stack : local_stack_reduction_function
-
-(** For compatibility: alias for whd\_stack *)
-val whd_castapp_stack : local_stack_reduction_function
+val pr_state : state -> Pp.std_ppcmds
 
 (** {6 Reduction Function Operators } *)
 
@@ -78,7 +133,13 @@ val strong_prodspine : local_reduction_function -> local_reduction_function
 val stack_reduction_of_reduction :
   'a reduction_function -> 'a state_reduction_function
 i*)
-val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a
+val stacklam : (state -> 'a) -> constr list -> constr -> constr Stack.t -> 'a
+
+val whd_state_gen : ?csts:Cst_stack.t -> bool -> Closure.RedFlags.reds ->
+  Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t
+
+val iterate_whd_gen : bool -> Closure.RedFlags.reds ->
+  Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
 
 (** {6 Generic Optimized Reduction Function using Closures } *)
 
@@ -87,13 +148,14 @@ val clos_norm_flags : Closure.RedFlags.reds -> reduction_function
 (** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *)
 val nf_beta : local_reduction_function
 val nf_betaiota : local_reduction_function
+val nf_betaiotazeta : local_reduction_function
 val nf_betadeltaiota : reduction_function
 val nf_evar : evar_map -> constr -> constr
 
-val nf_betaiota_preserving_vm_cast : reduction_function
-
 (** Lazy strategy, weak head reduction *)
+
 val whd_evar :  evar_map -> constr -> constr
+val whd_nored : local_reduction_function
 val whd_beta : local_reduction_function
 val whd_betaiota : local_reduction_function
 val whd_betaiotazeta : local_reduction_function
@@ -102,6 +164,8 @@ val whd_betadeltaiota_nolet :  contextual_reduction_function
 val whd_betaetalet : local_reduction_function
 val whd_betalet : local_reduction_function
 
+(** Removes cast and put into applicative form *)
+val whd_nored_stack : local_stack_reduction_function
 val whd_beta_stack : local_stack_reduction_function
 val whd_betaiota_stack : local_stack_reduction_function
 val whd_betaiotazeta_stack : local_stack_reduction_function
@@ -110,6 +174,7 @@ val whd_betadeltaiota_nolet_stack : contextual_stack_reduction_function
 val whd_betaetalet_stack : local_stack_reduction_function
 val whd_betalet_stack : local_stack_reduction_function
 
+val whd_nored_state : local_state_reduction_function
 val whd_beta_state : local_state_reduction_function
 val whd_betaiota_state : local_state_reduction_function
 val whd_betaiotazeta_state : local_state_reduction_function
@@ -149,15 +214,14 @@ val hnf_lam_app      : env ->  evar_map -> constr -> constr -> constr
 val hnf_lam_appvect  : env ->  evar_map -> constr -> constr array -> constr
 val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
 
-val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
-val splay_lam : env ->  evar_map -> constr -> (name * constr) list * constr
-val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
+val splay_prod : env ->  evar_map -> constr -> (Name.t * constr) list * constr
+val splay_lam : env ->  evar_map -> constr -> (Name.t * constr) list * constr
+val splay_arity : env ->  evar_map -> constr -> (Name.t * constr) list * sorts
 val sort_of_arity : env -> evar_map -> constr -> sorts
 val splay_prod_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_lam_n : env ->  evar_map -> int -> constr -> rel_context * constr
 val splay_prod_assum :
   env ->  evar_map -> constr -> rel_context * constr
-val decomp_sort : env -> evar_map -> types -> sorts
 val is_sort : env -> evar_map -> types -> bool
 
 type 'a miota_args = {
@@ -172,20 +236,13 @@ val reduce_mind_case : constr miota_args -> constr
 
 val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term
 val is_arity : env ->  evar_map -> constr -> bool
+val is_sort : env -> evar_map -> types -> bool
 
-val whd_programs :  reduction_function
-
-(** [reduce_fix redfun fix stk] contracts [fix stk] if it is actually
-   reducible; the structural argument is reduced by [redfun] *)
-
-type fix_reduction_result = NotReducible | Reduced of state
-
-val fix_recarg : fixpoint -> constr stack -> (int * constr) option
-val reduce_fix : local_state_reduction_function -> evar_map -> fixpoint
-   -> constr stack -> fix_reduction_result
+val contract_fix : ?env:Environ.env -> ?reference:Constant.t -> fixpoint -> constr
+val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option
 
 (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *)
-val is_transparent : 'a tableKey -> bool
+val is_transparent : Environ.env -> constant tableKey -> bool
 
 (** {6 Conversion Functions (uses closures, lazy strategy) } *)
 
@@ -194,7 +251,7 @@ type conversion_test = constraints -> constraints
 val pb_is_equal : conv_pb -> bool
 val pb_equal : conv_pb -> conv_pb
 
-val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test
+val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit
 
 val is_conv : env ->  evar_map -> constr -> constr -> bool
 val is_conv_leq : env ->  evar_map -> constr -> constr -> bool
@@ -204,17 +261,29 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr ->
 val is_trans_conv_leq : transparent_state -> env ->  evar_map -> constr -> constr -> bool
 val is_trans_fconv : conv_pb -> transparent_state -> env ->  evar_map -> constr -> constr -> bool
 
+(** [check_conv] Checks universe constraints only.
+    pb defaults to CUMUL and ts to a full transparent state.
+ *)
+val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env ->  evar_map -> constr -> constr -> bool
+
+(** [infer_fconv] Adds necessary universe constraints to the evar map.
+    pb defaults to CUMUL and ts to a full transparent state.
+ *)
+val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env ->  evar_map -> constr -> constr -> 
+  evar_map * bool
+
 (** {6 Special-Purpose Reduction Functions } *)
 
 val whd_meta : evar_map -> constr -> constr
-val plain_instance : (metavariable * constr) list -> constr -> constr
-val instance :evar_map -> (metavariable * constr) list -> constr -> constr
+val plain_instance : constr Metamap.t -> constr -> constr
+val instance : evar_map -> constr Metamap.t -> constr -> constr
 val head_unfold_under_prod : transparent_state -> reduction_function
 
 (** {6 Heuristic for Conversion with Evar } *)
 
 val whd_betaiota_deltazeta_for_iota_state :
-  transparent_state -> state_reduction_function
+  transparent_state -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state ->
+  state * Cst_stack.t
 
 (** {6 Meta-related reduction functions } *)
 val meta_instance : evar_map -> constr freelisted -> constr
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 1e1960f5..cd52ba44 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -1,26 +1,54 @@
 (************************************************************************)
 (*  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 Term
+open Vars
 open Inductive
 open Inductiveops
 open Names
 open Reductionops
 open Environ
-open Typeops
-open Declarations
 open Termops
+open Arguments_renaming
+
+type retype_error =
+  | NotASort
+  | NotAnArity
+  | NotAType
+  | BadVariable of Id.t
+  | BadMeta of int
+  | BadRecursiveType
+  | NonFunctionalConstruction
+
+let print_retype_error = function
+  | NotASort -> str "Not a sort"
+  | NotAnArity -> str "Not an arity"
+  | NotAType -> str "Not a type (1)"
+  | BadVariable id -> str "variable " ++ Id.print id ++ str " unbound"
+  | BadMeta n -> str "unknown meta " ++ int n
+  | BadRecursiveType -> str "Bad recursive type"
+  | NonFunctionalConstruction -> str "Non-functional construction"
+
+exception RetypeError of retype_error
+
+let retype_error re = raise (RetypeError re)
+
+let anomaly_on_error f x =
+ try f x
+ with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e)
 
 let get_type_from_constraints env sigma t =
   if isEvar (fst (decompose_app t)) then
     match
-      list_map_filter (fun (pbty,env,t1,t2) ->
+      List.map_filter (fun (pbty,env,t1,t2) ->
         if is_fconv Reduction.CONV env sigma t t1 then Some t2
         else if is_fconv Reduction.CONV env sigma t t2 then Some t1
         else None)
@@ -29,46 +57,48 @@ let get_type_from_constraints env sigma t =
     | t::l -> t
     | _ -> raise Not_found
   else raise Not_found
- 
+
 let rec subst_type env sigma typ = function
   | [] -> typ
   | h::rest ->
       match kind_of_term (whd_betadeltaiota env sigma typ) with
         | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest
-        | _ -> anomaly "Non-functional construction"
+        | _ -> retype_error NonFunctionalConstruction
 
-(* Si ft est le type d'un terme f, lequel est appliqué à args, *)
-(* [sort_of_atomic_ty] calcule ft[args] qui doit être une sorte *)
-(* On suit une méthode paresseuse, en espèrant que ft est une arité *)
-(* et sinon on substitue *)
+(* If ft is the type of f which itself is applied to args, *)
+(* [sort_of_atomic_type] computes ft[args] which has to be a sort *)
 
 let sort_of_atomic_type env sigma ft args =
-  let rec concl_of_arity env ar args =
+  let rec concl_of_arity env n ar args =
     match kind_of_term (whd_betadeltaiota env sigma ar), args with
-    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some h,t) env) b l
+    | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l
     | Sort s, [] -> s
-    | _ -> anomaly "Not a sort"
-  in concl_of_arity env ft (Array.to_list args)
+    | _ -> retype_error NotASort
+  in concl_of_arity env 0 ft (Array.to_list args)
 
 let type_of_var env id =
   try let (_,_,ty) = lookup_named id env in ty
-  with Not_found ->
-    anomaly ("type_of: variable "^(string_of_id id)^" unbound")
+  with Not_found -> retype_error (BadVariable id)
+
+let decomp_sort env sigma t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+  | Sort s -> s
+  | _ -> retype_error NotASort
 
 let retype ?(polyprop=true) sigma =
   let rec type_of env cstr=
     match kind_of_term cstr with
     | Meta n ->
       (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus
-       with Not_found -> anomaly ("type_of: unknown meta " ^ string_of_int n))
+       with Not_found -> retype_error (BadMeta n))
     | Rel n ->
         let (_,_,ty) = lookup_rel n env in
         lift n ty
     | Var id -> type_of_var env id
-    | Const cst -> Typeops.type_of_constant env cst
+    | Const cst -> rename_type_of_constant env cst
     | Evar ev -> Evd.existential_type sigma ev
-    | Ind ind -> type_of_inductive env ind
-    | Construct cstr -> type_of_constructor env cstr
+    | Ind ind -> rename_type_of_inductive env ind
+    | Construct cstr -> rename_type_of_constructor env cstr
     | Case (_,p,c,lf) ->
         let Inductiveops.IndType(_,realargs) =
           let t = type_of env c in
@@ -77,7 +107,8 @@ let retype ?(polyprop=true) sigma =
           try
             let t = get_type_from_constraints env sigma t in
             Inductiveops.find_rectype env sigma t
-          with Not_found -> anomaly "type_of: Bad recursive type" in
+          with Not_found -> retype_error BadRecursiveType
+        in
         let t = whd_beta sigma (applist (p, realargs)) in
         (match kind_of_term (whd_betadeltaiota env sigma (type_of env t)) with
           | Prod _ -> whd_beta sigma (applist (t, [c]))
@@ -88,12 +119,20 @@ let retype ?(polyprop=true) sigma =
          subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
     | Fix ((_,i),(_,tys,_)) -> tys.(i)
     | CoFix (i,(_,tys,_)) -> tys.(i)
-    | App(f,args) when isGlobalRef f ->
+    | App(f,args) when is_template_polymorphic env f ->
 	let t = type_of_global_reference_knowing_parameters env f args in
         strip_outer_cast (subst_type env sigma t (Array.to_list args))
     | App(f,args) ->
         strip_outer_cast
           (subst_type env sigma (type_of env f) (Array.to_list args))
+    | Proj (p,c) -> 
+       let Inductiveops.IndType(pars,realargs) =
+	 let ty = type_of env c in
+           try Inductiveops.find_rectype env sigma ty
+           with Not_found -> retype_error BadRecursiveType
+       in
+       let (_,u), pars = dest_ind_family pars in
+	 substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u))
     | Cast (c,_, t) -> t
     | Sort _ | Prod _ -> mkSort (sort_of env cstr)
 
@@ -106,20 +145,16 @@ let retype ?(polyprop=true) sigma =
         (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with
 	  | _, (Prop Null as s) -> s
           | Prop _, (Prop Pos as s) -> s
-          | Type _, (Prop Pos as s) when
-              Environ.engagement env = Some ImpredicativeSet -> s
-	  | (Type _, _) | (_, Type _) -> new_Type_sort ()
-(*
+          | Type _, (Prop Pos as s) when is_impredicative_set env -> s
           | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ)
 	  | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2)
 	  | Prop Null, (Type _ as s) -> s
-	  | Type u1, Type u2 -> Type (Univ.sup u1 u2)*))
-    | App(f,args) when isGlobalRef f ->
-	let t = type_of_global_reference_knowing_parameters env f args in
+	  | Type u1, Type u2 -> Type (Univ.sup u1 u2))
+    | App(f,args) when is_template_polymorphic env f ->
+      let t = type_of_global_reference_knowing_parameters env f args in
         sort_of_atomic_type env sigma t args
     | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
-    | Lambda _ | Fix _ | Construct _ ->
-        anomaly "sort_of: Not a type (1)"
+    | Lambda _ | Fix _ | Construct _ -> retype_error NotAType
     | _ -> decomp_sort env sigma (type_of env t)
 
   and sort_family_of env t =
@@ -129,29 +164,29 @@ let retype ?(polyprop=true) sigma =
     | Sort (Type u) -> InType
     | Prod (name,t,c2) ->
 	let s2 = sort_family_of (push_rel (name,None,t) env) c2 in
-	if Environ.engagement env <> Some ImpredicativeSet &&
-	   s2 = InSet & sort_family_of env t = InType then InType else s2
-    | App(f,args) when isGlobalRef f ->
+	if not (is_impredicative_set env) &&
+	   s2 == InSet && sort_family_of env t == InType then InType else s2
+    | App(f,args) when is_template_polymorphic env f ->
 	let t = type_of_global_reference_knowing_parameters env f args in
         family_of_sort (sort_of_atomic_type env sigma t args)
     | App(f,args) ->
 	family_of_sort (sort_of_atomic_type env sigma (type_of env f) args)
-    | Lambda _ | Fix _ | Construct _ ->
-        anomaly "sort_of: Not a type (1)"
-    | _ -> family_of_sort (decomp_sort env sigma (type_of env t))
+    | Lambda _ | Fix _ | Construct _ -> retype_error NotAType
+    | _ -> 
+      family_of_sort (decomp_sort env sigma (type_of env t))
 
   and type_of_global_reference_knowing_parameters env c args =
-    let argtyps = Array.map (fun c -> nf_evar sigma (type_of env c)) args in
+    let argtyps =
+      Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in
     match kind_of_term c with
     | Ind ind ->
-      let (_,mip) = lookup_mind_specif env ind in
+      let mip = lookup_mind_specif env (fst ind) in
 	(try Inductive.type_of_inductive_knowing_parameters
-	       ~polyprop env mip argtyps
-	 with Reduction.NotArity -> anomaly "type_of: Not an arity")
+	       ~polyprop env (mip,snd ind) argtyps
+	 with Reduction.NotArity -> retype_error NotAnArity)
     | Const cst ->
-      let t = constant_type env cst in
-	(try Typeops.type_of_constant_knowing_parameters env t argtyps
-	 with Reduction.NotArity -> anomaly "type_of: Not an arity")
+	(try Typeops.type_of_constant_knowing_parameters_in env cst argtyps
+	 with Reduction.NotArity -> retype_error NotAnArity)
     | Var id -> type_of_var env id
     | Construct cstr -> type_of_constructor env cstr
     | _ -> assert false
@@ -160,36 +195,59 @@ let retype ?(polyprop=true) sigma =
      type_of_global_reference_knowing_parameters
 
 let get_sort_of ?(polyprop=true) env sigma t =
-  let _,f,_,_ = retype ~polyprop sigma in f env t
+  let _,f,_,_ = retype ~polyprop sigma in anomaly_on_error (f env) t
 let get_sort_family_of ?(polyprop=true) env sigma c =
-  let _,_,f,_ = retype ~polyprop sigma in f env c
+  let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c
 let type_of_global_reference_knowing_parameters env sigma c args =
-  let _,_,_,f = retype sigma in f env c args
+  let _,_,_,f = retype sigma in anomaly_on_error (f env c) args
 
 let type_of_global_reference_knowing_conclusion env sigma c conclty =
   let conclty = nf_evar sigma conclty in
   match kind_of_term c with
-    | Ind ind ->
-        let (_,mip) = Inductive.lookup_mind_specif env ind in
-        type_of_inductive_knowing_conclusion env mip conclty
+    | Ind (ind,u) ->
+        let spec = Inductive.lookup_mind_specif env ind in
+          type_of_inductive_knowing_conclusion env sigma (spec,u) conclty
     | Const cst ->
-        let t = constant_type env cst in
+        let t = constant_type_in env cst in
         (* TODO *)
-        Typeops.type_of_constant_knowing_parameters env t [||]
-    | Var id -> type_of_var env id
-    | Construct cstr -> type_of_constructor env cstr
+          sigma, Typeops.type_of_constant_type_knowing_parameters env t [||]
+    | Var id -> sigma, type_of_var env id
+    | Construct cstr -> sigma, type_of_constructor env cstr
     | _ -> assert false
 
-(* We are outside the kernel: we take fresh universes *)
-(* to avoid tactics and co to refresh universes themselves *)
-let get_type_of ?(polyprop=true) ?(refresh=true) env sigma c =
-  let f,_,_,_ = retype ~polyprop sigma in
-  let t = f env c in
-    if refresh then refresh_universes t else t
+(* Profiling *)
+(* let get_type_of polyprop lax env sigma c = *)
+(*   let f,_,_,_ = retype ~polyprop sigma in *)
+(*     if lax then f env c else anomaly_on_error (f env) c  *)
+
+(* let get_type_of_key = Profile.declare_profile "get_type_of" *)
+(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *)
 
-(* Makes an assumption from a constr *)
-let get_assumption_of env evc c = c
+(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *)
+(*   get_type_of polyprop lax env sigma c *)
+
+let get_type_of ?(polyprop=true) ?(lax=false) env sigma c =
+  let f,_,_,_ = retype ~polyprop sigma in
+    if lax then f env c else anomaly_on_error (f env) c
 
 (* Makes an unsafe judgment from a constr *)
 let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c }
 
+(* Returns sorts of a context *)
+let sorts_of_context env evc ctxt =
+  let rec aux = function
+  | [] -> env,[]
+  | (_,_,t as d)::ctxt ->
+      let env,sorts = aux ctxt in
+      let s = get_sort_of env evc t in
+      (push_rel d env,s::sorts) in
+  snd (aux ctxt)
+
+let expand_projection env sigma pr c args =
+  let ty = get_type_of ~lax:true env sigma c in
+  let (i,u), ind_args = 
+    try Inductiveops.find_mrectype env sigma ty 
+    with Not_found -> retype_error BadRecursiveType
+  in
+    mkApp (mkConstU (Projection.constant pr,u), 
+	   Array.of_list (ind_args @ (c :: args)))
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 4ef54c13..89ba46db 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -1,14 +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 Names
 open Term
 open Evd
+open Context
 open Environ
 
 (** This family of functions assumes its constr argument is known to be
@@ -20,8 +20,14 @@ open Environ
 (** The "polyprop" optional argument is used by the extraction to
     disable "Prop-polymorphism", cf comment in [inductive.ml] *)
 
+(** The "lax" optional argument provides a relaxed version of
+    [get_type_of] that won't raise any anomaly but RetypeError instead *)
+
+type retype_error
+exception RetypeError of retype_error
+
 val get_type_of :
-  ?polyprop:bool -> ?refresh:bool -> env -> evar_map -> constr -> types
+  ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types
 
 val get_sort_of :
   ?polyprop:bool -> env -> evar_map -> types -> sorts
@@ -29,9 +35,6 @@ val get_sort_of :
 val get_sort_family_of :
   ?polyprop:bool -> env -> evar_map -> types -> sorts_family
 
-(** Makes an assumption from a constr *)
-val get_assumption_of : env -> evar_map -> constr -> types
-
 (** Makes an unsafe judgment from a constr *)
 val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
 
@@ -39,4 +42,8 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr ->
   constr array -> types
 
 val type_of_global_reference_knowing_conclusion :
-  env -> evar_map -> constr -> types -> types
+  env -> evar_map -> constr -> types -> evar_map * types
+
+val sorts_of_context : env -> evar_map -> rel_context -> sorts list
+
+val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index b18314f7..b4e0459c 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -1,34 +1,34 @@
 (************************************************************************)
 (*  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
-open Nameops
 open Term
+open Vars
 open Libnames
+open Globnames
 open Termops
+open Find_subterm
 open Namegen
-open Declarations
-open Inductive
-open Libobject
 open Environ
 open Closure
 open Reductionops
 open Cbv
-open Glob_term
-open Pattern
-open Matching
+open Patternops
+open Locus
+open Pretype_errors
 
 (* Errors *)
 
 type reduction_tactic_error =
-    InvalidAbstraction of env * constr * (env * Type_errors.type_error)
+    InvalidAbstraction of env * Evd.evar_map * constr * (env * Type_errors.type_error)
 
 exception ReductionTacticError of reduction_tactic_error
 
@@ -39,27 +39,28 @@ exception Redelimination
 
 let error_not_evaluable r =
   errorlabstrm "error_not_evaluable"
-    (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Idset.empty r ++
+    (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Id.Set.empty r ++
      spc () ++ str "to an evaluable reference.")
 
 let is_evaluable_const env cst =
-  is_transparent (ConstKey cst) && evaluable_constant cst env
+  is_transparent env (ConstKey cst) && 
+    (evaluable_constant cst env || is_projection cst env)
 
 let is_evaluable_var env id =
-  is_transparent (VarKey id) && evaluable_named id env
+  is_transparent env (VarKey id) && evaluable_named id env
 
 let is_evaluable env = function
   | EvalConstRef cst -> is_evaluable_const env cst
   | EvalVarRef id -> is_evaluable_var env id
 
-let value_of_evaluable_ref env = function
-  | EvalConstRef con -> constant_value env con
+let value_of_evaluable_ref env evref u =
+  match evref with
+  | EvalConstRef con -> 
+    (try constant_value_in env (con,u)
+    with NotEvaluableConst IsProj -> 
+      raise (Invalid_argument "value_of_evaluable_ref"))
   | EvalVarRef id -> Option.get (pi2 (lookup_named id env))
 
-let constr_of_evaluable_ref = function
-  | EvalConstRef con -> mkConst con
-  | EvalVarRef id -> mkVar id
-
 let evaluable_of_global_reference env = function
   | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst
   | VarRef id when is_evaluable_var env id -> EvalVarRef id
@@ -71,31 +72,55 @@ let global_of_evaluable_reference = function
 
 type evaluable_reference =
   | EvalConst of constant
-  | EvalVar of identifier
+  | EvalVar of Id.t
   | EvalRel of int
   | EvalEvar of existential
 
-let mkEvalRef = function
-  | EvalConst cst -> mkConst cst
+let evaluable_reference_eq r1 r2 = match r1, r2 with
+| EvalConst c1, EvalConst c2 -> eq_constant c1 c2
+| EvalVar id1, EvalVar id2 -> Id.equal id1 id2
+| EvalRel i1, EvalRel i2 -> Int.equal i1 i2
+| EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) ->
+  Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2
+| _ -> false
+
+let mkEvalRef ref u =
+  match ref with
+  | EvalConst cst -> mkConstU (cst,u)
   | EvalVar id -> mkVar id
   | EvalRel n -> mkRel n
   | EvalEvar ev -> mkEvar ev
 
 let isEvalRef env c = match kind_of_term c with
-  | Const sp -> is_evaluable env (EvalConstRef sp)
+  | Const (sp,_) -> is_evaluable env (EvalConstRef sp)
   | Var id -> is_evaluable env (EvalVarRef id)
   | Rel _ | Evar _ -> true
   | _ -> false
 
-let destEvalRef c = match kind_of_term c with
-  | Const cst ->  EvalConst cst
-  | Var id  -> EvalVar id
-  | Rel n -> EvalRel n
-  | Evar ev -> EvalEvar ev
-  | _ -> anomaly "Not an unfoldable reference"
+let destEvalRefU c = match kind_of_term c with
+  | Const (cst,u) ->  EvalConst cst, u
+  | Var id  -> (EvalVar id, Univ.Instance.empty)
+  | Rel n -> (EvalRel n, Univ.Instance.empty)
+  | Evar ev -> (EvalEvar ev, Univ.Instance.empty)
+  | _ -> anomaly (Pp.str "Not an unfoldable reference")
+
+let unsafe_reference_opt_value env sigma eval = 
+  match eval with
+  | EvalConst cst ->
+    (match (lookup_constant cst env).Declarations.const_body with 
+    | Declarations.Def c -> Some (Mod_subst.force_constr c)
+    | _ -> None)
+  | EvalVar id ->
+      let (_,v,_) = lookup_named id env in
+      v
+  | EvalRel n ->
+      let (_,v,_) = lookup_rel n env in
+      Option.map (lift n) v
+  | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
-let reference_opt_value sigma env = function
-  | EvalConst cst -> constant_opt_value env cst
+let reference_opt_value env sigma eval u = 
+  match eval with
+  | EvalConst cst -> constant_opt_value_in env (cst,u)
   | EvalVar id ->
       let (_,v,_) = lookup_named id env in
       v
@@ -105,8 +130,8 @@ let reference_opt_value sigma env = function
   | EvalEvar ev -> Evd.existential_opt_value sigma ev
 
 exception NotEvaluable
-let reference_value sigma env c =
-  match reference_opt_value sigma env c with
+let reference_value env sigma c u =
+  match reference_opt_value env sigma c u with
     | None -> raise NotEvaluable
     | Some d -> d
 
@@ -121,28 +146,14 @@ type constant_evaluation =
       ((int*evaluable_reference) option array *
        (int * (int * constr) list * int))
   | EliminationCases of int
+  | EliminationProj of int
   | NotAnElimination
 
 (* We use a cache registered as a global table *)
 
-let eval_table = ref Cmap_env.empty
-
-type frozen = (int * constant_evaluation) Cmap_env.t
-
-let init () =
-  eval_table := Cmap_env.empty
+type frozen = constant_evaluation Cmap.t
 
-let freeze () =
-  !eval_table
-
-let unfreeze ct =
-  eval_table := ct
-
-let _ =
-  Summary.declare_summary "evaluation"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+let eval_table = Summary.ref (Cmap.empty : frozen) ~name:"evaluation"
 
 (* [compute_consteval] determines whether c is an "elimination constant"
 
@@ -177,8 +188,8 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
       (function d -> match kind_of_term d with
          | Rel k ->
              if
-	       array_for_all (noccurn k) tys
-	       && array_for_all (noccurn (k+nbfix)) bds
+	       Array.for_all (noccurn k) tys
+	       && Array.for_all (noccurn (k+nbfix)) bds
 	     then
 	       (k, List.nth labs (k-1))
 	     else
@@ -187,12 +198,14 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
 	     raise Elimconst) args
   in
   let reversible_rels = List.map fst li in
-  if not (list_distinct reversible_rels) then
+  if not (List.distinct_f Int.compare reversible_rels) then
     raise Elimconst;
-  list_iter_i (fun i t_i ->
-    if not (List.mem_assoc (i+1) li) then
-      let fvs = List.map ((+) (i+1)) (Intset.elements (free_rels t_i)) in
-      if list_intersect fvs reversible_rels <> [] then raise Elimconst)
+  List.iteri (fun i t_i ->
+    if not (Int.List.mem_assoc (i+1) li) then
+      let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels t_i)) in
+      match List.intersect Int.equal fvs reversible_rels with
+      | [] -> ()
+      | _ -> raise Elimconst)
     labs;
   let k = lv.(i) in
   if k < nargs then
@@ -210,57 +223,64 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
 let invert_name labs l na0 env sigma ref = function
   | Name id ->
       let minfxargs = List.length l in
-      if na0 <> Name id then
+      begin match na0 with
+      | Name id' when Id.equal id' id ->
+        Some (minfxargs,ref)
+      | _ ->
 	let refi = match ref with
 	  | EvalRel _ | EvalEvar _ -> None
 	  | EvalVar id' -> Some (EvalVar id)
 	  | EvalConst kn ->
-	      Some (EvalConst (con_with_label kn (label_of_id id))) in
+	      Some (EvalConst (con_with_label kn (Label.of_id id))) in
 	match refi with
 	  | None -> None
 	  | Some ref ->
-	      try match reference_opt_value sigma env ref with
+	      try match unsafe_reference_opt_value env sigma ref with
 		| None -> None
 		| Some c ->
 		    let labs',ccl = decompose_lam c in
 		    let _, l' = whd_betalet_stack sigma ccl in
 		    let labs' = List.map snd labs' in
-		    if labs' = labs & l = l' then Some (minfxargs,ref)
+		    (** ppedrot: there used to be generic equality on terms here *)
+		    if List.equal eq_constr labs' labs &&
+                       List.equal eq_constr l l' then Some (minfxargs,ref)
                     else None
 	      with Not_found (* Undefined ref *) -> None
-      else Some (minfxargs,ref)
+      end
   | Anonymous -> None (* Actually, should not occur *)
 
 (* [compute_consteval_direct] expand all constant in a whole, but
    [compute_consteval_mutual_fix] only one by one, until finding the
    last one before the Fix if the latter is mutually defined *)
 
-let compute_consteval_direct sigma env ref =
-  let rec srec env n labs c =
+let compute_consteval_direct env sigma ref =
+  let rec srec env n labs onlyproj c =
     let c',l = whd_betadelta_stack env sigma c in
     match kind_of_term c' with
-      | Lambda (id,t,g) when l=[] ->
-	  srec (push_rel (id,None,t) env) (n+1) (t::labs) g
-      | Fix fix ->
+      | Lambda (id,t,g) when List.is_empty l && not onlyproj ->
+	  srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g
+      | Fix fix when not onlyproj ->
 	  (try check_fix_reversibility labs l fix
 	  with Elimconst -> NotAnElimination)
-      | Case (_,_,d,_) when isRel d -> EliminationCases n
+      | Case (_,_,d,_) when isRel d && not onlyproj -> EliminationCases n
+      | Case (_,_,d,_) -> srec env n labs true d
+      | Proj (p, d) when isRel d -> EliminationProj n
       | _ -> NotAnElimination
   in
-  match reference_opt_value sigma env ref with
+  match unsafe_reference_opt_value env sigma ref with
     | None -> NotAnElimination
-    | Some c -> srec env 0 [] c
+    | Some c -> srec env 0 [] false c
 
-let compute_consteval_mutual_fix sigma env ref =
+let compute_consteval_mutual_fix env sigma ref =
   let rec srec env minarg labs ref c =
     let c',l = whd_betalet_stack sigma c in
     let nargs = List.length l in
     match kind_of_term c' with
-      | Lambda (na,t,g) when l=[] ->
+      | Lambda (na,t,g) when List.is_empty l ->
 	  srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
       | Fix ((lv,i),(names,_,_)) ->
 	  (* Last known constant wrapping Fix is ref = [labs](Fix l) *)
-	  (match compute_consteval_direct sigma env ref with
+	  (match compute_consteval_direct env sigma ref with
 	     | NotAnElimination -> (*Above const was eliminable but this not!*)
 		 NotAnElimination
 	     | EliminationFix (minarg',minfxargs,infos) ->
@@ -272,32 +292,32 @@ let compute_consteval_mutual_fix sigma env ref =
 	     | _ -> assert false)
       | _ when isEvalRef env c' ->
 	  (* Forget all \'s and args and do as if we had started with c' *)
-	  let ref = destEvalRef c' in
-	  (match reference_opt_value sigma env ref with
-	    | None -> anomaly "Should have been trapped by compute_direct"
+	  let ref,_ = destEvalRefU c' in
+	  (match unsafe_reference_opt_value env sigma ref with
+	    | None -> anomaly (Pp.str "Should have been trapped by compute_direct")
 	    | Some c -> srec env (minarg-nargs) [] ref c)
       | _ -> (* Should not occur *) NotAnElimination
   in
-  match reference_opt_value sigma env ref with
+  match unsafe_reference_opt_value env sigma ref with
     | None -> (* Should not occur *) NotAnElimination
     | Some c -> srec env 0 [] ref c
 
-let compute_consteval sigma env ref =
-  match compute_consteval_direct sigma env ref with
-    | EliminationFix (_,_,(nbfix,_,_)) when nbfix <> 1 ->
-	compute_consteval_mutual_fix sigma env ref
+let compute_consteval env sigma ref =
+  match compute_consteval_direct env sigma ref with
+    | EliminationFix (_,_,(nbfix,_,_)) when not (Int.equal nbfix 1) ->
+	compute_consteval_mutual_fix env sigma ref
     | elim -> elim
 
-let reference_eval sigma env = function
+let reference_eval env sigma = function
   | EvalConst cst as ref ->
       (try
-	 Cmap_env.find cst !eval_table
+	 Cmap.find cst !eval_table
        with Not_found -> begin
-	 let v = compute_consteval sigma env ref in
-	 eval_table := Cmap_env.add cst v !eval_table;
+	 let v = compute_consteval env sigma ref in
+	 eval_table := Cmap.add cst v !eval_table;
 	 v
        end)
-  | ref -> compute_consteval sigma env ref
+  | ref -> compute_consteval env sigma ref
 
 (* If f is bound to EliminationFix (n',infos), then n' is the minimal
    number of args for starting the reduction and infos is
@@ -320,16 +340,16 @@ let reference_eval sigma env = function
    The type Tij' is Tij[yi(j-1)..y1 <- ai(j-1)..a1]
 *)
 
-let x = Name (id_of_string "x")
+let x = Name default_dependent_ident
 
-let make_elim_fun (names,(nbfix,lv,n)) largs =
-  let lu = list_firstn n (list_of_stack largs) in
+let make_elim_fun (names,(nbfix,lv,n)) u largs =
+  let lu = List.firstn n largs in
   let p = List.length lv in
   let lyi = List.map fst lv in
   let la =
-    list_map_i (fun q aq ->
+    List.map_i (fun q aq ->
       (* k from the comment is q+1 *)
-      try mkRel (p+1-(list_index (n-q) lyi))
+      try mkRel (p+1-(List.index Int.equal (n-q) lyi))
       with Not_found -> aq)
       0 (List.map (lift p) lu)
   in
@@ -337,10 +357,10 @@ let make_elim_fun (names,(nbfix,lv,n)) largs =
     match names.(i) with
       | None -> None
       | Some (minargs,ref) ->
-          let body = applistc (mkEvalRef ref) la in
+          let body = applistc (mkEvalRef ref u) la in
           let g =
-            list_fold_left_i (fun q (* j = n+1-q *) c (ij,tij) ->
-              let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in
+            List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) ->
+              let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in
               let tij' = substl (List.rev subst) tij in
 	      mkLambda (x,tij',c)) 1 body (List.rev lv)
           in Some (minargs,g)
@@ -349,37 +369,32 @@ let make_elim_fun (names,(nbfix,lv,n)) largs =
    do so that the reduction uses this extra information *)
 
 let dummy = mkProp
-let vfx = id_of_string"_expanded_fix_"
-let vfun = id_of_string"_eliminator_function_"
+let vfx = Id.of_string "_expanded_fix_"
+let vfun = Id.of_string "_eliminator_function_"
+let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)]
 
 (* Mark every occurrence of substituted vars (associated to a function)
    as a problem variable: an evar that can be instantiated either by
    vfx (expanded fixpoint) or vfun (named function). *)
-let substl_with_function subst constr =
-  let cnt = ref 0 in
-  let evd = ref Evd.empty in
-  let minargs = ref Intmap.empty in
+let substl_with_function subst sigma constr =
+  let evd = ref sigma in
+  let minargs = ref Evar.Map.empty in
   let v = Array.of_list subst in
-  let rec subst_total k c =
-    match kind_of_term c with
-        Rel i when k<i ->
-          if i <= k + Array.length v then
-            match v.(i-k-1) with
-              | (fx,Some(min,ref)) ->
-                  decr cnt;
-                  evd := Evd.add !evd !cnt
-                    (Evd.make_evar
-                      (val_of_named_context
-                        [(vfx,None,dummy);(vfun,None,dummy)])
-                      dummy);
-                  minargs := Intmap.add !cnt min !minargs;
-                  lift k (mkEvar(!cnt,[|fx;ref|]))
-              | (fx,None) -> lift k fx
-          else mkRel (i - Array.length v)
-      | _ ->
-          map_constr_with_binders succ subst_total k c in
+  let rec subst_total k c = match kind_of_term c with
+  | Rel i when k < i ->
+    if i <= k + Array.length v then
+      match v.(i-k-1) with
+      | (fx, Some (min, ref)) ->
+        let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in
+        evd := sigma;
+        minargs := Evar.Map.add evk min !minargs;
+        lift k (mkEvar (evk, [|fx;ref|]))
+      | (fx, None) -> lift k fx
+    else mkRel (i - Array.length v)
+  | _ ->
+    map_constr_with_binders succ subst_total k c in
   let c = subst_total 0 constr in
-  (c,!evd,!minargs)
+  (c, !evd, !minargs)
 
 exception Partial
 
@@ -392,15 +407,16 @@ let solve_arity_problem env sigma fxminargs c =
     let c' = whd_betaiotazeta sigma c in
     let (h,rcargs) = decompose_app c' in
     match kind_of_term h with
-        Evar(i,_) when Intmap.mem i fxminargs && not (Evd.is_defined !evm i) ->
-          let minargs = Intmap.find i fxminargs in
+        Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) ->
+          let minargs = Evar.Map.find i fxminargs in
           if List.length rcargs < minargs then
             if strict then set_fix i
             else raise Partial;
           List.iter (check strict) rcargs
       | (Var _|Const _) when isEvalRef env h ->
-          (match reference_opt_value sigma env (destEvalRef h) with
-              Some h' ->
+          (let ev, u = destEvalRefU h in
+	     match reference_opt_value env sigma ev u with
+             | Some h' ->
                 let bak = !evm in
                 (try List.iter (check false) rcargs
                 with Partial ->
@@ -411,42 +427,52 @@ let solve_arity_problem env sigma fxminargs c =
   check true c;
   !evm
 
-let substl_checking_arity env subst c =
+let substl_checking_arity env subst sigma c =
   (* we initialize the problem: *)
-  let body,sigma,minargs = substl_with_function subst c in
+  let body,sigma,minargs = substl_with_function subst sigma c in
   (* we collect arity constraints *)
   let sigma' = solve_arity_problem env sigma minargs body in
   (* we propagate the constraints: solved problems are substituted;
      the other ones are replaced by the function symbol *)
   let rec nf_fix c =
     match kind_of_term c with
-        Evar(i,[|fx;f|] as ev) when Intmap.mem i minargs ->
+        Evar(i,[|fx;f|] as ev) when Evar.Map.mem i minargs ->
           (match Evd.existential_opt_value sigma' ev with
               Some c' -> c'
             | None -> f)
       | _ -> map_constr nf_fix c in
   nf_fix body
 
+type fix_reduction_result = NotReducible | Reduced of (constr*constr list)
 
+let reduce_fix whdfun sigma fix stack =
+  match fix_recarg fix (Stack.append_app_list stack Stack.empty) with
+    | None -> NotReducible
+    | Some (recargnum,recarg) ->
+        let (recarg'hd,_ as recarg') = whdfun sigma recarg in
+        let stack' = List.assign stack recargnum (applist recarg') in
+	(match kind_of_term recarg'hd with
+           | Construct _ -> Reduced (contract_fix fix, stack')
+	   | _ -> NotReducible)
 
 let contract_fix_use_function env sigma f
   ((recindices,bodynum),(_names,_types,bodies as typedbodies)) =
   let nbodies = Array.length recindices in
   let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in
-  let lbodies = list_tabulate make_Fi nbodies in
-  substl_checking_arity env (List.rev lbodies) (nf_beta sigma bodies.(bodynum))
+  let lbodies = List.init nbodies make_Fi in
+  substl_checking_arity env (List.rev lbodies) sigma (nf_beta sigma bodies.(bodynum))
 
 let reduce_fix_use_function env sigma f whfun fix stack =
-  match fix_recarg fix stack with
+  match fix_recarg fix (Stack.append_app_list stack Stack.empty) with
     | None -> NotReducible
     | Some (recargnum,recarg) ->
         let (recarg'hd,_ as recarg') =
 	  if isRel recarg then
 	    (* The recarg cannot be a local def, no worry about the right env *)
-	    (recarg, empty_stack)
+	    (recarg, [])
 	  else
-	    whfun (recarg, empty_stack) in
-        let stack' = stack_assign stack recargnum (app_stack recarg') in
+	    whfun recarg in
+        let stack' = List.assign stack recargnum (applist recarg') in
 	(match kind_of_term recarg'hd with
            | Construct _ ->
 	       Reduced (contract_fix_use_function env sigma f fix,stack')
@@ -456,21 +482,21 @@ let contract_cofix_use_function env sigma f
   (bodynum,(_names,_,bodies as typedbodies)) =
   let nbodies = Array.length bodies in
   let make_Fi j = (mkCoFix(j,typedbodies), f j) in
-  let subbodies = list_tabulate make_Fi nbodies in
+  let subbodies = List.init nbodies make_Fi in
   substl_checking_arity env (List.rev subbodies)
-    (nf_beta sigma bodies.(bodynum))
+    sigma (nf_beta sigma bodies.(bodynum))
 
 let reduce_mind_case_use_function func env sigma mia =
   match kind_of_term mia.mconstr with
-    | Construct(ind_sp,i) ->
-	let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
+    | Construct ((ind_sp,i),u) ->
+	let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in
 	applist (mia.mlf.(i-1), real_cargs)
     | CoFix (bodynum,(names,_,_) as cofix) ->
 	let build_cofix_name =
 	  if isConst func then
             let minargs = List.length mia.mcargs in
 	    fun i ->
-	      if i = bodynum then Some (minargs,func)
+	      if Int.equal i bodynum then Some (minargs,func)
 	      else match names.(i) with
 		| Anonymous -> None
 		| Name id ->
@@ -478,12 +504,13 @@ let reduce_mind_case_use_function func env sigma mia =
 		       mutual inductive, try to reuse the global name if
 		       the block was indeed initially built as a global
 		       definition *)
-		    let kn = con_with_label (destConst func) (label_of_id id)
+		    let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id))
+		      (destConst func)
 		    in
-		    try match constant_opt_value env kn with
+		    try match constant_opt_value_in env kn with
 		      | None -> None
                           (* TODO: check kn is correct *)
-		      | Some _ -> Some (minargs,mkConst kn)
+		      | Some _ -> Some (minargs,mkConstU kn)
 		    with Not_found -> None
 	  else
 	    fun _ -> None in
@@ -492,226 +519,277 @@ let reduce_mind_case_use_function func env sigma mia =
 	mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf)
     | _ -> assert false
 
-let special_red_case env sigma whfun (ci, p, c, lf)  =
+
+let match_eval_ref env constr = 
+  match kind_of_term constr with
+  | Const (sp, u) when is_evaluable env (EvalConstRef sp) ->
+      Some (EvalConst sp, u)
+  | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty)
+  | Rel i -> Some (EvalRel i, Univ.Instance.empty)
+  | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty)
+  | _ -> None
+
+let match_eval_ref_value env sigma constr = 
+  match kind_of_term constr with
+  | Const (sp, u) when is_evaluable env (EvalConstRef sp) ->
+    Some (constant_value_in env (sp, u))
+  | Var id when is_evaluable env (EvalVarRef id) -> 
+    let (_,v,_) = lookup_named id env in v
+  | Rel n -> let (_,v,_) = lookup_rel n env in
+	       Option.map (lift n) v
+  | Evar ev -> Evd.existential_opt_value sigma ev
+  | _ -> None
+
+let special_red_case env sigma whfun (ci, p, c, lf) =
   let rec redrec s =
     let (constr, cargs) = whfun s in
-    if isEvalRef env constr then
-      let ref = destEvalRef constr in
-      match reference_opt_value sigma env ref with
-        | None -> raise Redelimination
-        | Some gvalue ->
-	    if reducible_mind_case gvalue then
-	      reduce_mind_case_use_function constr env sigma
-	        {mP=p; mconstr=gvalue; mcargs=list_of_stack cargs;
-                mci=ci; mlf=lf}
-	    else
-	      redrec (gvalue, cargs)
-    else
+    match match_eval_ref env constr with
+    | Some (ref, u) ->
+      (match reference_opt_value env sigma ref u with
+      | None -> raise Redelimination
+      | Some gvalue ->
+        if reducible_mind_case gvalue then
+	  reduce_mind_case_use_function constr env sigma
+	  {mP=p; mconstr=gvalue; mcargs=cargs;
+           mci=ci; mlf=lf}
+	else
+	  redrec (applist(gvalue, cargs)))
+    | None ->
       if reducible_mind_case constr then
         reduce_mind_case
-	  {mP=p; mconstr=constr; mcargs=list_of_stack cargs;
+	  {mP=p; mconstr=constr; mcargs=cargs;
 	  mci=ci; mlf=lf}
       else
 	raise Redelimination
   in
-  redrec (c, empty_stack)
-
-(* data structure to hold the map kn -> rec_args for simpl *)
-
-type behaviour = {
-  b_nargs: int;
-  b_recargs: int list;
-  b_dont_expose_case: bool;
-}
-
-let behaviour_table = ref (Refmap.empty : behaviour Refmap.t)
-
-let _ =
-  Summary.declare_summary "simplbehaviour"
-    { Summary.freeze_function = (fun () -> !behaviour_table);
-      Summary.unfreeze_function = (fun x -> behaviour_table := x);
-      Summary.init_function = (fun () -> behaviour_table := Refmap.empty) }
-
-type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ]
-type req =
-  | ReqLocal
-  | ReqGlobal of global_reference * (int list * int * simpl_flag list)
-
-let load_simpl_behaviour _ (_,(_,(r, b))) =
-  behaviour_table := Refmap.add r b !behaviour_table
-
-let cache_simpl_behaviour o = load_simpl_behaviour 1 o
-
-let classify_simpl_behaviour = function
-  | ReqLocal, _ -> Dispose
-  | ReqGlobal _, _ as o -> Substitute o
-
-let subst_simpl_behaviour (subst, (_, (r,o as orig))) =
-  ReqLocal,
-  let r' = fst (subst_global subst r) in if r==r' then orig else (r',o)
-
-let discharge_simpl_behaviour = function
-  | _,(ReqGlobal (ConstRef c, req), (_, b)) ->
-     let c' = pop_con c in
-     let vars = Lib.section_segment_of_constant c in
-     let extra = List.length vars in
-     let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in
-     let recargs' = List.map ((+) extra) b.b_recargs in
-     let b' = { b with b_nargs = nargs'; b_recargs = recargs' } in
-     Some (ReqGlobal (ConstRef c', req), (ConstRef c', b'))
-  | _ -> None
+  redrec c
 
-let rebuild_simpl_behaviour = function
-  | req, (ConstRef c, _ as x) -> req, x
-  | _ -> assert false
-
-let inSimplBehaviour = declare_object { (default_object "SIMPLBEHAVIOUR") with
-  load_function = load_simpl_behaviour;
-  cache_function = cache_simpl_behaviour;
-  classify_function = classify_simpl_behaviour;
-  subst_function = subst_simpl_behaviour;
-  discharge_function = discharge_simpl_behaviour;
-  rebuild_function = rebuild_simpl_behaviour;
-}
-
-let set_simpl_behaviour local r (recargs, nargs, flags as req) =
-  let nargs = if List.mem `SimplNeverUnfold flags then max_int else nargs in
-  let behaviour = {
-    b_nargs = nargs; b_recargs = recargs;
-    b_dont_expose_case = List.mem `SimplDontExposeCase flags } in
-  let req = if local then ReqLocal else ReqGlobal (r, req) in
-  Lib.add_anonymous_leaf (inSimplBehaviour (req, (r, behaviour)))
-;;
-
-let get_simpl_behaviour r =
-  try
-    let b = Refmap.find r !behaviour_table in
-    let flags =
-      if b.b_nargs = max_int then [`SimplNeverUnfold]
-      else if b.b_dont_expose_case then [`SimplDontExposeCase] else [] in
-    Some (b.b_recargs, (if b.b_nargs = max_int then -1 else b.b_nargs), flags)
-  with Not_found -> None
+let recargs = function
+  | EvalVar _ | EvalRel _ | EvalEvar _ -> None
+  | EvalConst c -> ReductionBehaviour.get (ConstRef c)
 
-let get_behaviour = function
-  | EvalVar _ | EvalRel _ | EvalEvar _ -> raise Not_found
-  | EvalConst c -> Refmap.find (ConstRef c) !behaviour_table
+let reduce_projection env sigma pb (recarg'hd,stack') stack =
+  (match kind_of_term recarg'hd with
+  | Construct _ -> 
+    let proj_narg = 
+      pb.Declarations.proj_npars + pb.Declarations.proj_arg
+    in Reduced (List.nth stack' proj_narg, stack)
+  | _ -> NotReducible)
+
+let reduce_proj env sigma whfun whfun' c =
+  let rec redrec s =
+    match kind_of_term s with
+    | Proj (proj, c) -> 
+      let c' = try redrec c with Redelimination -> c in
+      let constr, cargs = whfun c' in
+	(match kind_of_term constr with
+	| Construct _ -> 
+	  let proj_narg = 
+	    let pb = lookup_projection proj env in
+	      pb.Declarations.proj_npars + pb.Declarations.proj_arg
+	  in List.nth cargs proj_narg
+	| _ -> raise Redelimination)
+    | Case (n,p,c,brs) -> 
+      let c' = redrec c in
+      let p = (n,p,c',brs) in
+	(try special_red_case env sigma whfun' p
+	 with Redelimination -> mkCase p)
+    | _ -> raise Redelimination
+  in redrec c
 
-let recargs r =
-  try let b = get_behaviour r in Some (b.b_recargs, b.b_nargs)
-  with Not_found -> None
 
-let dont_expose_case r =
-  try (get_behaviour r).b_dont_expose_case with Not_found -> false
+let dont_expose_case = function
+  | EvalVar _ | EvalRel _ | EvalEvar _ -> false
+  | EvalConst c ->
+     Option.cata (fun (_,_,z) -> List.mem `ReductionDontExposeCase z)
+		 false (ReductionBehaviour.get (ConstRef c))
+
+let whd_nothing_for_iota env sigma s =
+  let rec whrec (x, stack as s) =
+    match kind_of_term x with
+      | Rel n ->
+	  (match lookup_rel n env with
+	     | (_,Some body,_) -> whrec (lift n body, stack)
+	     | _ -> s)
+      | Var id ->
+	  (match lookup_named id env with
+	     | (_,Some body,_) -> whrec (body, stack)
+	     | _ -> s)
+      | Evar ev ->
+	(try whrec (Evd.existential_value sigma ev, stack)
+	with Evd.NotInstantiatedEvar | Not_found -> s)
+      | Meta ev ->
+	(try whrec (Evd.meta_value sigma ev, stack)
+	with Not_found -> s)
+      | Const const when is_transparent_constant full_transparent_state (fst const) ->
+	  (match constant_opt_value_in env const with
+	     | Some  body -> whrec (body, stack)
+	     | None -> s)
+      | LetIn (_,b,_,c) -> stacklam whrec [b] c stack
+      | Cast (c,_,_) -> whrec (c, stack)
+      | App (f,cl)  -> whrec (f, Stack.append_app cl stack)
+      | Lambda (na,t,c) ->
+          (match Stack.decomp stack with
+             | Some (a,m) -> stacklam whrec [a] c m
+	     | _ -> s)
+
+      | x -> s
+  in
+  decompose_app (Stack.zip (whrec (s,Stack.empty)))
 
 (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind
    constants by keeping the name of the constants in the recursive calls;
    it fails if no redex is around *)
 
-let rec red_elim_const env sigma ref largs =
-  let nargs = stack_args_size largs in
-  let largs, unfold_anyway, unfold_nonelim =
+let rec red_elim_const env sigma ref u largs =
+  let nargs = List.length largs in
+  let largs, unfold_anyway, unfold_nonelim, nocase =
     match recargs ref with
-    | None -> largs, false, false
-    | Some (_,n) when nargs < n -> raise Redelimination
-    | Some (x::l,_) when nargs <= List.fold_left max x l -> raise Redelimination
-    | Some (l,n) ->
-        List.fold_left (fun stack i ->
-          let arg = stack_nth stack i in
-          let rarg = whd_construct_state env sigma (arg, empty_stack) in
-          match kind_of_term (fst rarg) with
-          | Construct _ -> stack_assign stack i (app_stack rarg)
-          | _ -> raise Redelimination)
-        largs l, n >= 0 && l =  [] && nargs >= n, 
-                 n >= 0 && l <> [] && nargs >= n in
-  try match reference_eval sigma env ref with
+    | None -> largs, false, false, false
+    | Some (_,n,f) when nargs < n || List.mem `ReductionNeverUnfold f -> raise Redelimination
+    | Some (x::l,_,_) when nargs <= List.fold_left max x l -> raise Redelimination
+    | Some (l,n,f) ->
+        let is_empty = match l with [] -> true | _ -> false in
+	  reduce_params env sigma largs l, 
+	  n >= 0 && is_empty && nargs >= n,
+          n >= 0 && not is_empty && nargs >= n,
+	  List.mem `ReductionDontExposeCase f
+  in
+  try match reference_eval env sigma ref with
     | EliminationCases n when nargs >= n ->
-	let c = reference_value sigma env ref in
-	let c', lrest = whd_betadelta_state env sigma (c,largs) in
-	let whfun = whd_simpl_state env sigma in
-        (special_red_case env sigma whfun (destCase c'), lrest)
+	let c = reference_value env sigma ref u in
+	let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in
+	let whfun = whd_simpl_stack env sigma in
+        (special_red_case env sigma whfun (destCase c'), lrest), nocase
+    | EliminationProj n when nargs >= n ->
+	let c = reference_value env sigma ref u in
+	let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in
+	let whfun = whd_construct_stack env sigma in
+	let whfun' = whd_simpl_stack env sigma in
+	  (reduce_proj env sigma whfun whfun' c', lrest), nocase
     | EliminationFix (min,minfxargs,infos) when nargs >= min ->
-	let c = reference_value sigma env ref in
-	let d, lrest = whd_betadelta_state env sigma (c,largs) in
-	let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in
-	let whfun = whd_construct_state env sigma in
+	let c = reference_value env sigma ref u in
+	let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in
+	let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in
+	let whfun = whd_construct_stack env sigma in
 	(match reduce_fix_use_function env sigma f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
-           | Reduced (c,rest) -> (nf_beta sigma c, rest))
+           | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase)
     | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min ->
-	let rec descend ref args =
-	  let c = reference_value sigma env ref in
-	  if ref = refgoal then
+	let rec descend (ref,u) args =
+	  let c = reference_value env sigma ref u in
+	  if evaluable_reference_eq ref refgoal then
 	    (c,args)
 	  else
-	    let c', lrest = whd_betalet_state sigma (c,args) in
-	    descend (destEvalRef c') lrest in
-	let (_, midargs as s) = descend ref largs in
-	let d, lrest = whd_betadelta_state env sigma s in
-	let f = make_elim_fun refinfos midargs in
-	let whfun = whd_construct_state env sigma in
+	    let c', lrest = whd_betalet_stack sigma (applist(c,args)) in
+	    descend (destEvalRefU c') lrest in
+	let (_, midargs as s) = descend (ref,u) largs in
+	let d, lrest = whd_nothing_for_iota env sigma (applist s) in
+	let f = make_elim_fun refinfos u midargs in
+	let whfun = whd_construct_stack env sigma in
 	(match reduce_fix_use_function env sigma f whfun (destFix d) lrest with
 	   | NotReducible -> raise Redelimination
-	   | Reduced (c,rest) -> (nf_beta sigma c, rest))
-    | NotAnElimination when unfold_nonelim -> 
-         let c = reference_value sigma env ref in
-         whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack
+	   | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase)
+    | NotAnElimination when unfold_nonelim ->
+         let c = reference_value env sigma ref u in
+           (whd_betaiotazeta sigma (applist (c, largs)), []), nocase
     | _ -> raise Redelimination
     with Redelimination when unfold_anyway ->
-       let c = reference_value sigma env ref in
-       whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack
+       let c = reference_value env sigma ref u in
+	 (whd_betaiotazeta sigma (applist (c, largs)), []), nocase
+
+and reduce_params env sigma stack l =
+  let len = List.length stack in
+    List.fold_left (fun stack i ->
+      if len <= i then raise Redelimination
+      else
+	let arg = List.nth stack i in
+	let rarg = whd_construct_stack env sigma arg in
+	  match kind_of_term (fst rarg) with
+	  | Construct _ -> List.assign stack i (applist rarg)
+	  | _ -> raise Redelimination)
+      stack l
+    
 
 (* reduce to whd normal form or to an applied constant that does not hide
    a reducible iota/fix/cofix redex (the "simpl" tactic) *)
 
-and whd_simpl_state env sigma s =
-  let rec redrec (x, stack as s) =
+and whd_simpl_stack env sigma =
+  let rec redrec s =
+    let (x, stack as s') = decompose_app s in
     match kind_of_term x with
       | Lambda (na,t,c) ->
-          (match decomp_stack stack with
-             | None -> s
-             | Some (a,rest) -> stacklam redrec [a] c rest)
-      | LetIn (n,b,t,c) -> stacklam redrec [b] c stack
-      | App (f,cl) -> redrec (f, append_stack cl stack)
-      | Cast (c,_,_) -> redrec (c, stack)
+          (match stack with
+             | [] -> s'
+             | a :: rest -> redrec (beta_applist (x,stack)))
+      | LetIn (n,b,t,c) -> redrec (applist (substl [b] c, stack))
+      | App (f,cl) -> redrec (applist(f, (Array.to_list cl)@stack))
+      | Cast (c,_,_) -> redrec (applist(c, stack))
       | Case (ci,p,c,lf) ->
           (try
-	    redrec (special_red_case env sigma redrec (ci,p,c,lf), stack)
+	    redrec (applist(special_red_case env sigma redrec (ci,p,c,lf), stack))
 	  with
-	      Redelimination -> s)
+	      Redelimination -> s')
       | Fix fix ->
-	  (try match reduce_fix (whd_construct_state env) sigma fix stack with
-            | Reduced s' -> redrec s'
-	    | NotReducible -> s
-	  with Redelimination -> s)
-      | _ when isEvalRef env x ->
-	  let ref = destEvalRef x in
+	  (try match reduce_fix (whd_construct_stack env) sigma fix stack with
+            | Reduced s' -> redrec (applist s')
+	    | NotReducible -> s'
+	  with Redelimination -> s')
+
+      | Proj (p, c) ->
+        (try 
+	   let unf = Projection.unfolded p in
+	     if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then
+	       let pb = lookup_projection p env in
+ 		 (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with
+ 		 | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> 
+                   (* simpl never *) s'
+		 | false, Some (l, n, f) when not (List.is_empty l) ->
+		   let l' = List.map_filter (fun i -> 
+		     let idx = (i - (pb.Declarations.proj_npars + 1)) in
+		       if idx < 0 then None else Some idx) l in
+		   let stack = reduce_params env sigma stack l' in
+		     (match reduce_projection env sigma pb 
+		       (whd_construct_stack env sigma c) stack 
+		      with
+		      | Reduced s' -> redrec (applist s')
+		      | NotReducible -> s')
+ 		 | _ ->
+		   match reduce_projection env sigma pb (whd_construct_stack env sigma c) stack with
+		   | Reduced s' -> redrec (applist s')
+		   | NotReducible -> s')
+	   else s'
+	 with Redelimination -> s')
+	  
+      | _ -> 
+        match match_eval_ref env x with
+	| Some (ref, u) ->
           (try
-            let hd, _ as s' = redrec (red_elim_const env sigma ref stack) in
-            let rec is_case x = match kind_of_term x with
-              | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x
-              | App (hd, _) -> is_case hd
-              | Case _ -> true
-              | _ -> false in
-            if dont_expose_case ref && is_case hd then raise Redelimination
-            else s'
-           with Redelimination ->
-	     s)
-      | _ -> s
+	     let sapp, nocase = red_elim_const env sigma ref u stack in
+             let hd, _ as s'' = redrec (applist(sapp)) in
+             let rec is_case x = match kind_of_term x with
+               | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x
+               | App (hd, _) -> is_case hd
+               | Case _ -> true
+               | _ -> false in
+               if nocase && is_case hd then raise Redelimination
+               else s''
+           with Redelimination -> s')
+	| None -> s'
   in
-  redrec s
+  redrec
 
 (* reduce until finding an applied constructor or fail *)
 
-and whd_construct_state env sigma s =
-  let (constr, cargs as s') = whd_simpl_state env sigma s in
+and whd_construct_stack env sigma s =
+  let (constr, cargs as s') = whd_simpl_stack env sigma s in
   if reducible_mind_case constr then s'
-  else if isEvalRef env constr then
-    let ref = destEvalRef constr in
-    match reference_opt_value sigma env ref with
-      | None -> raise Redelimination
-      | Some gvalue -> whd_construct_state env sigma (gvalue, cargs)
-  else
-    raise Redelimination
+  else match match_eval_ref env constr with
+  | Some (ref, u) ->
+    (match reference_opt_value env sigma ref u with
+    | None -> raise Redelimination
+    | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs)))
+  | _ -> raise Redelimination
 
 (************************************************************************)
 (*            Special Purpose Reduction Strategies                     *)
@@ -724,35 +802,47 @@ and whd_construct_state env sigma s =
 let try_red_product env sigma c =
   let simpfun = clos_norm_flags betaiotazeta env sigma in
   let rec redrec env x =
+    let x = whd_betaiota sigma x in
     match kind_of_term x with
       | App (f,l) ->
           (match kind_of_term f with
              | Fix fix ->
-                 let stack = append_stack l empty_stack in
+                 let stack = Stack.append_app l Stack.empty in
                  (match fix_recarg fix stack with
                     | None -> raise Redelimination
                     | Some (recargnum,recarg) ->
                         let recarg' = redrec env recarg in
-                        let stack' = stack_assign stack recargnum recarg' in
-                        simpfun (app_stack (f,stack')))
+                        let stack' = Stack.assign stack recargnum recarg' in
+                        simpfun (Stack.zip (f,stack')))
              | _ -> simpfun (appvect (redrec env f, l)))
       | Cast (c,_,_) -> redrec env c
       | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
       | LetIn (x,a,b,t) -> redrec env (subst1 a t)
       | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
-      | _ when isEvalRef env x ->
+      | Proj (p, c) -> 
+	let c' = 
+	  match kind_of_term c with
+	  | Construct _ -> c
+	  | _ -> redrec env c
+	in
+	let pb = lookup_projection p env in
+          (match reduce_projection env sigma pb (whd_betaiotazeta_stack sigma c') [] with
+	  | Reduced s -> simpfun (applist s)
+	  | NotReducible -> raise Redelimination)
+      | _ -> 
+        (match match_eval_ref env x with
+        | Some (ref, u) ->
           (* TO DO: re-fold fixpoints after expansion *)
           (* to get true one-step reductions *)
-          let ref = destEvalRef x in
-	  (match reference_opt_value sigma env ref with
+	  (match reference_opt_value env sigma ref u with
 	     | None -> raise Redelimination
 	     | Some c -> c)
-      | _ -> raise Redelimination
+	| _ -> raise Redelimination)
   in redrec env c
 
 let red_product env sigma c =
   try try_red_product env sigma c
-  with Redelimination -> error "Not reducible."
+  with Redelimination -> error "No head constant to reduce."
 
 (*
 (* This old version of hnf uses betadeltaiota instead of itself (resp
@@ -798,7 +888,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
           (try
 	    redrec (red_elim_const env sigma ref stack)
            with Redelimination ->
-             match reference_opt_value sigma env ref with
+             match reference_opt_value env sigma ref with
 	       | Some c ->
 		   (match kind_of_term (strip_lam c) with
                      | CoFix _ | Fix _ -> s
@@ -808,96 +898,160 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
   in app_stack (redrec (c, empty_stack))
 *)
 
+let whd_simpl_stack = 
+  if Flags.profile then 
+    let key = Profile.declare_profile "whd_simpl_stack" in
+      Profile.profile3 key whd_simpl_stack
+  else whd_simpl_stack
+
 (* Same as [whd_simpl] but also reduces constants that do not hide a
    reducible fix, but does this reduction of constants only until it
    immediately hides a non reducible fix or a cofix *)
 
 let whd_simpl_orelse_delta_but_fix env sigma c =
   let rec redrec s =
-    let (constr, stack as s') = whd_simpl_state env sigma s in
-    if isEvalRef env constr then
-      match reference_opt_value sigma env (destEvalRef constr) with
-	| Some c ->
-	    (match kind_of_term (strip_lam c) with
-              | CoFix _ | Fix _ -> s'
-	      | _ -> redrec (c, stack))
-	| None -> s'
-    else s'
-  in app_stack (redrec (c, empty_stack))
+    let (constr, stack as s') = whd_simpl_stack env sigma s in
+    match match_eval_ref_value env sigma constr with
+    | Some c ->
+      (match kind_of_term (strip_lam c) with
+      | CoFix _ | Fix _ -> s'
+      | Proj (p,t) when
+	  (match kind_of_term constr with
+	  | Const (c', _) -> eq_constant (Projection.constant p) c'
+	  | _ -> false) ->
+	let pb = Environ.lookup_projection p env in
+	  if List.length stack <= pb.Declarations.proj_npars then
+	    (** Do not show the eta-expanded form *)
+	    s'
+	  else redrec (applist (c, stack))
+      | _ -> redrec (applist(c, stack)))
+    | None -> s'
+  in
+  let simpfun = clos_norm_flags betaiota env sigma in
+  simpfun (applist (redrec c))
 
 let hnf_constr = whd_simpl_orelse_delta_but_fix
 
 (* The "simpl" reduction tactic *)
 
 let whd_simpl env sigma c =
-  app_stack (whd_simpl_state env sigma (c, empty_stack))
+  applist (whd_simpl_stack env sigma c)
 
 let simpl env sigma c = strong whd_simpl env sigma c
 
 (* Reduction at specific subterms *)
 
-let matches_head c t =
+let matches_head env sigma c t =
   match kind_of_term t with
-    | App (f,_) -> matches c f
-    | _ -> raise PatternMatchingFailure
+    | App (f,_) -> Constr_matching.matches env sigma c f
+    | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p))
+    | _ -> raise Constr_matching.PatternMatchingFailure
+
+let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false
 
-let contextually byhead ((nowhere_except_in,locs),c) f env sigma t =
+(** FIXME: Specific function to handle projections: it ignores what happens on the
+    parameters. This is a temporary fix while rewrite etc... are not up to equivalence
+    of the projection and its eta expanded form.
+*)
+let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = 
+  match kind_of_term c with
+  | Proj (p, r) -> (* Treat specially for partial applications *)
+    let t = Retyping.expand_projection env sigma p r [] in
+    let hdf, al = destApp t in
+    let a = al.(Array.length al - 1) in
+    let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in
+    let app' = f acc app in
+    let a' = f acc a in
+      (match kind_of_term app' with
+      | App (hdf', al') when hdf' == hdf ->
+        (* Still the same projection, we ignore the change in parameters *)
+	mkProj (p, a')
+      | _ -> mkApp (app', [| a' |]))
+  | _ -> map_constr_with_binders_left_to_right g f acc c
+
+let e_contextually byhead (occs,c) f env sigma t =
+  let (nowhere_except_in,locs) = Locusops.convert_occs occs in
   let maxocc = List.fold_right max locs 0 in
   let pos = ref 1 in
-  let rec traverse (env,c as envc) t =
-    if nowhere_except_in & (!pos > maxocc) then t
+  let evd = ref sigma in
+  let rec traverse nested (env,c as envc) t =
+    if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t
     else
     try
-      let subst = if byhead then matches_head c t else matches c t in
+      let subst =
+        if byhead then matches_head env sigma c t 
+	else Constr_matching.matches env sigma c t in
       let ok =
-	if nowhere_except_in then List.mem !pos locs
-	else not (List.mem !pos locs) in
+	if nowhere_except_in then Int.List.mem !pos locs
+	else not (Int.List.mem !pos locs) in
       incr pos;
-      if ok then
-	f subst env sigma t
-      else if byhead then
-	(* find other occurrences of c in t; TODO: ensure left-to-right *)
-        let (f,l) = destApp t in
-	mkApp (f, array_map_left (traverse envc) l)
+      if ok then begin
+        if Option.has_some nested then
+          errorlabstrm "" (str "The subterm at occurrence " ++ int (Option.get nested) ++ str " overlaps with the subterm at occurrence " ++ int (!pos-1) ++ str ".");
+        (* Skip inner occurrences for stable counting of occurrences *)
+        if locs != [] then
+          ignore (traverse_below (Some (!pos-1)) envc t);
+	let evm, t = f subst env !evd t in
+	(evd := evm; t)
+      end
       else
-	t
-    with PatternMatchingFailure ->
-      map_constr_with_binders_left_to_right
-	(fun d (env,c) -> (push_rel d env,lift_pattern 1 c))
-        traverse envc t
+	traverse_below nested envc t
+    with Constr_matching.PatternMatchingFailure ->
+      traverse_below nested envc t
+  and traverse_below nested envc t =
+    (* when byhead, find other occurrences without matching again partial
+       application with same head *)
+    match kind_of_term t with
+    | App (f,l) when byhead -> mkApp (f, Array.map_left (traverse nested envc) l)
+    | Proj (p,c) when byhead -> mkProj (p,traverse nested envc c)
+    | _ ->
+        change_map_constr_with_binders_left_to_right
+          (fun d (env,c) -> (push_rel d env,lift_pattern 1 c))
+          (traverse nested) envc sigma t
   in
-  let t' = traverse (env,c) t in
+  let t' = traverse None (env,c) t in
   if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
-  t'
+  !evd, t'
+
+let contextually byhead occs f env sigma t =
+  let f' subst env sigma t = sigma, f subst env sigma t in
+    snd (e_contextually byhead occs f' env sigma t)
 
 (* linear bindings (following pretty-printer) of the value of name in c.
  * n is the number of the next occurence of name.
  * ol is the occurence list to find. *)
 
-let substlin env evalref n (nowhere_except_in,locs) c =
+let match_constr_evaluable_ref sigma c evref = 
+  match kind_of_term c, evref with
+  | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u
+  | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty
+  | _, _ -> None
+
+let substlin env sigma evalref n (nowhere_except_in,locs) c =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref n in
   assert (List.for_all (fun x -> x >= 0) locs);
-  let value = value_of_evaluable_ref env evalref in
-  let term = constr_of_evaluable_ref evalref in
+  let value u = value_of_evaluable_ref env evalref u in
   let rec substrec () c =
-    if nowhere_except_in & !pos > maxocc then c
-    else if eq_constr c term then
-      let ok =
-	if nowhere_except_in then List.mem !pos locs
-	else not (List.mem !pos locs) in
-      incr pos;
-      if ok then value else c
-    else
-      map_constr_with_binders_left_to_right
-	(fun _ () -> ())
-        substrec () c
+    if nowhere_except_in && !pos > maxocc then c
+    else 
+      match match_constr_evaluable_ref sigma c evalref with
+      | Some u ->
+        let ok =
+	  if nowhere_except_in then Int.List.mem !pos locs
+	  else not (Int.List.mem !pos locs) in
+	  incr pos;
+	  if ok then value u else c
+      | None -> 
+        map_constr_with_binders_left_to_right
+	  (fun _ () -> ())
+          substrec () c
   in
   let t' = substrec () c in
   (!pos, t')
 
 let string_of_evaluable_ref env = function
-  | EvalVarRef id -> string_of_id id
+  | EvalVarRef id -> Id.to_string id
   | EvalConstRef kn ->
       string_of_qualid
         (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn))
@@ -908,19 +1062,31 @@ let unfold env sigma name =
   else
     error (string_of_evaluable_ref env name^" is opaque.")
 
+let is_projection env = function
+  | EvalVarRef _ -> false
+  | EvalConstRef c -> Environ.is_projection c env
+
 (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)]
  * Unfolds the constant name in a term c following a list of occurrences occl.
  * at the occurrences of occ_list. If occ_list is empty, unfold all occurences.
  * Performs a betaiota reduction after unfolding. *)
-let unfoldoccs env sigma ((nowhere_except_in,locs as plocs),name) c =
-  if locs = [] then if nowhere_except_in then c else unfold env sigma name c
-  else
-    let (nbocc,uc) = substlin env name 1 plocs c in
-    if nbocc = 1 then
+let unfoldoccs env sigma (occs,name) c =
+  let unfo nowhere_except_in locs =
+    let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in
+    if Int.equal nbocc 1 then
       error ((string_of_evaluable_ref env name)^" does not occur.");
     let rest = List.filter (fun o -> o >= nbocc) locs in
-    if rest <> [] then error_invalid_occurrence rest;
-    nf_betaiota sigma uc
+    let () = match rest with
+    | [] -> ()
+    | _ -> error_invalid_occurrence rest
+    in
+    nf_betaiotazeta sigma uc
+  in
+  match occs with
+    | NoOccurrences -> c
+    | AllOccurrences -> unfold env sigma name c
+    | OnlyOccurrences l -> unfo true l
+    | AllOccurrencesBut l -> unfo false l
 
 (* Unfold reduction tactic: *)
 let unfoldn loccname env sigma c =
@@ -962,25 +1128,39 @@ let compute = cbv_betadeltaiota
 (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only
  * the specified occurrences. *)
 
-let abstract_scheme env sigma (locc,a) c =
+let abstract_scheme env (locc,a) (c, sigma) =
   let ta = Retyping.get_type_of env sigma a in
   let na = named_hd env ta Anonymous in
   if occur_meta ta then error "Cannot find a type for the generalisation.";
   if occur_meta a then
-    mkLambda (na,ta,c)
+    mkLambda (na,ta,c), sigma
   else
-    mkLambda (na,ta,subst_closed_term_occ locc a c)
+    let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in
+      mkLambda (na,ta,c'), sigma'
 
 let pattern_occs loccs_trm env sigma c =
-  let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in
+  let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in
   try
     let _ = Typing.type_of env sigma abstr_trm in
-    applist(abstr_trm, List.map snd loccs_trm)
+      sigma, applist(abstr_trm, List.map snd loccs_trm)
   with Type_errors.TypeError (env',t) ->
-    raise (ReductionTacticError (InvalidAbstraction (env,abstr_trm,(env',t))))
+    raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
 
 (* Used in several tactics. *)
 
+let check_privacy env ind =
+  let spec = Inductive.lookup_mind_specif env (fst ind) in
+  if Inductive.is_private spec then
+    errorlabstrm "" (str "case analysis on a private type.")
+  else ind
+
+let check_not_primitive_record env ind =
+  let spec = Inductive.lookup_mind_specif env (fst ind) in
+    if Inductive.is_primitive_record spec then
+      errorlabstrm "" (str "case analysis on a primitive record type: " ++
+		       str "use projections or let instead.")
+    else ind
+
 (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name
    return name, B and t' *)
 
@@ -988,7 +1168,7 @@ let reduce_to_ind_gen allow_product env sigma t =
   let rec elimrec env t l =
     let t = hnf_constr env sigma t in
     match kind_of_term (fst (decompose_app t)) with
-      | Ind ind-> (ind, it_mkProd_or_LetIn t l)
+      | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l)
       | Prod (n,ty,t') ->
 	  if allow_product then
 	    elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l)
@@ -999,7 +1179,7 @@ let reduce_to_ind_gen allow_product env sigma t =
 	     was partially the case between V5.10 and V8.1 *)
 	  let t' = whd_betadeltaiota env sigma t in
 	  match kind_of_term (fst (decompose_app t')) with
-	    | Ind ind-> (ind, it_mkProd_or_LetIn t' l)
+	    | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l)
 	    | _ -> errorlabstrm "" (str"Not an inductive product.")
   in
   elimrec env t []
@@ -1007,7 +1187,7 @@ let reduce_to_ind_gen allow_product env sigma t =
 let reduce_to_quantified_ind x = reduce_to_ind_gen true x
 let reduce_to_atomic_ind x = reduce_to_ind_gen false x
 
-let rec find_hnf_rectype env sigma t =
+let find_hnf_rectype env sigma t =
   let ind,t = reduce_to_atomic_ind env sigma t in
   ind, snd (decompose_app t)
 
@@ -1020,69 +1200,66 @@ let one_step_reduce env sigma c =
   let rec redrec (x, stack) =
     match kind_of_term x with
       | Lambda (n,t,c)  ->
-          (match decomp_stack stack with
-             | None      -> raise NotStepReducible
-             | Some (a,rest) -> (subst1 a c, rest))
-      | App (f,cl) -> redrec (f, append_stack cl stack)
+          (match stack with
+             | []        -> raise NotStepReducible
+             | a :: rest -> (subst1 a c, rest))
+      | App (f,cl) -> redrec (f, (Array.to_list cl)@stack)
       | LetIn (_,f,_,cl) -> (subst1 f cl,stack)
       | Cast (c,_,_) -> redrec (c,stack)
       | Case (ci,p,c,lf) ->
           (try
-	     (special_red_case env sigma (whd_simpl_state env sigma)
+	     (special_red_case env sigma (whd_simpl_stack env sigma)
 	       (ci,p,c,lf), stack)
            with Redelimination -> raise NotStepReducible)
       | Fix fix ->
-	  (match reduce_fix (whd_construct_state env) sigma fix stack with
+	  (match reduce_fix (whd_construct_stack env) sigma fix stack with
              | Reduced s' -> s'
 	     | NotReducible -> raise NotStepReducible)
       | _ when isEvalRef env x ->
-	  let ref = destEvalRef x in
+	  let ref,u = destEvalRefU x in
           (try
-             red_elim_const env sigma ref stack
+             fst (red_elim_const env sigma ref u stack)
            with Redelimination ->
-	     match reference_opt_value sigma env ref with
-	       | Some d -> d, stack
+	     match reference_opt_value env sigma ref u with
+	       | Some d -> (d, stack)
 	       | None -> raise NotStepReducible)
 
       | _ -> raise NotStepReducible
   in
-  app_stack (redrec (c, empty_stack))
+  applist (redrec (c,[]))
 
-let isIndRef = function IndRef _ -> true | _ -> false
+let error_cannot_recognize ref =
+  errorlabstrm ""
+    (str "Cannot recognize a statement based on " ++
+     Nametab.pr_global_env Id.Set.empty ref ++ str".")
 
 let reduce_to_ref_gen allow_product env sigma ref t =
   if isIndRef ref then
-    let (mind,t) = reduce_to_ind_gen allow_product env sigma t in
-    if IndRef mind <> ref then
-      errorlabstrm "" (str "Cannot recognize a statement based on " ++
-        Nametab.pr_global_env Idset.empty ref ++ str".")
-    else
-      t
+    let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in
+    begin match ref with
+    | IndRef mind' when eq_ind mind mind' -> t
+    | _ -> error_cannot_recognize ref
+    end
   else
   (* lazily reduces to match the head of [t] with the expected [ref] *)
   let rec elimrec env t l =
-    let c, _ = Reductionops.whd_stack sigma t in
+    let c, _ = decompose_appvect (Reductionops.whd_nored sigma t) in
     match kind_of_term c with
       | Prod (n,ty,t') ->
-	  if allow_product then
+          if allow_product then
 	    elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l)
-	  else
-	     errorlabstrm ""
-	       (str "Cannot recognize an atomic statement based on " ++
-	        Nametab.pr_global_env Idset.empty ref ++ str".")
+          else
+            error_cannot_recognize ref
       | _ ->
 	  try
-	    if global_of_constr c = ref
+	    if eq_gr (global_of_constr c) ref
 	    then it_mkProd_or_LetIn t l
 	    else raise Not_found
 	  with Not_found ->
           try
 	    let t' = nf_betaiota sigma (one_step_reduce env sigma t) in
             elimrec env t' l
-          with NotStepReducible ->
-	    errorlabstrm ""
-	      (str "Cannot recognize a statement based on " ++
-	       Nametab.pr_global_env Idset.empty ref ++ str".")
+          with NotStepReducible -> error_cannot_recognize ref
   in
   elimrec env t []
 
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index aec9da95..03c4cb41 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.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        *)
@@ -11,14 +11,13 @@ open Term
 open Environ
 open Evd
 open Reductionops
-open Closure
-open Glob_term
-open Termops
 open Pattern
-open Libnames
+open Globnames
+open Locus
+open Univ
 
 type reduction_tactic_error =
-    InvalidAbstraction of env * constr * (env * Type_errors.type_error)
+    InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error)
 
 exception ReductionTacticError of reduction_tactic_error
 
@@ -28,13 +27,13 @@ exception ReductionTacticError of reduction_tactic_error
 
 val is_evaluable : Environ.env -> evaluable_global_reference -> bool
 
-val error_not_evaluable : Libnames.global_reference -> 'a
+val error_not_evaluable : Globnames.global_reference -> 'a
 
 val evaluable_of_global_reference :
-  Environ.env -> Libnames.global_reference -> evaluable_global_reference
+  Environ.env -> Globnames.global_reference -> evaluable_global_reference
 
 val global_of_evaluable_reference :
-  evaluable_global_reference -> Libnames.global_reference
+  evaluable_global_reference -> Globnames.global_reference
 
 exception Redelimination
 
@@ -44,14 +43,6 @@ val red_product : reduction_function
 (** Red (raise Redelimination if nothing reducible) *)
 val try_red_product : reduction_function
 
-(** Tune the behaviour of simpl for the given constant name *)
-type simpl_flag = [ `SimplDontExposeCase | `SimplNeverUnfold ]
-
-val set_simpl_behaviour :
-  bool -> global_reference -> (int list * int * simpl_flag list) -> unit
-val get_simpl_behaviour :
-  global_reference -> (int list * int * simpl_flag list) option
-
 (** Simpl *)
 val simpl : reduction_function
 
@@ -70,7 +61,8 @@ val unfoldn :
 val fold_commands : constr list ->  reduction_function
 
 (** Pattern *)
-val pattern_occs : (occurrences * constr) list ->  reduction_function
+val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> 
+   evar_map * constr
 
 (** Rem: Lazy strategies are defined in Reduction *)
 
@@ -84,12 +76,12 @@ val cbv_norm_flags : Closure.RedFlags.reds ->  reduction_function
 (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)]
    with [I] an inductive definition;
    returns [I] and [t'] or fails with a user error *)
-val reduce_to_atomic_ind : env ->  evar_map -> types -> inductive * types
+val reduce_to_atomic_ind : env ->  evar_map -> types -> pinductive * types
 
 (** [reduce_to_quantified_ind env sigma t] puts [t] in the form
    [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition;
    returns [I] and [t'] or fails with a user error *)
-val reduce_to_quantified_ind : env ->  evar_map -> types -> inductive * types
+val reduce_to_quantified_ind : env ->  evar_map -> types -> pinductive * types
 
 (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form
    [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *)
@@ -100,7 +92,18 @@ val reduce_to_atomic_ref :
   env ->  evar_map -> global_reference -> types -> types
 
 val find_hnf_rectype : 
-  env ->  evar_map -> types -> inductive * constr list
+  env ->  evar_map -> types -> pinductive * constr list
 
 val contextually : bool -> occurrences * constr_pattern ->
   (patvar_map -> reduction_function) -> reduction_function
+
+val e_contextually : bool -> occurrences * constr_pattern ->
+  (patvar_map -> e_reduction_function) -> e_reduction_function
+
+(** Returns the same inductive if it is allowed for pattern-matching
+    raises an error otherwise. **)
+val check_privacy : env -> inductive puniverses -> inductive puniverses
+
+(** Returns the same inductive if it is not a primitive record
+    raises an error otherwise. **)
+val check_not_primitive_record : env -> inductive puniverses -> inductive puniverses
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 02661a93..5862a852 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -1,27 +1,28 @@
 (************************************************************************)
 (*  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
 open Nameops
 open Term
-open Sign
+open Vars
+open Context
 open Environ
-open Libnames
-open Nametab
+open Locus
 
 (* Sorts and sort family *)
 
 let print_sort = function
   | Prop Pos -> (str "Set")
   | Prop Null -> (str "Prop")
-  | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")")
+  | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")")
 
 let pr_sort_family = function
   | InSet -> (str "Set")
@@ -34,6 +35,19 @@ let pr_name = function
 
 let pr_con sp = str(string_of_con sp)
 
+let pr_fix pr_constr ((t,i),(lna,tl,bl)) =
+  let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
+  hov 1
+      (str"fix " ++ int i ++ spc() ++  str"{" ++
+         v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
+           pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
+	   cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
+         str"}")
+
+let pr_puniverses p u = 
+  if Univ.Instance.is_empty u then p 
+  else p ++ str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
+
 let rec pr_constr c = match kind_of_term c with
   | Rel n -> str "#"++int n
   | Meta n -> str "Meta(" ++ int n ++ str ")"
@@ -59,25 +73,19 @@ let rec pr_constr c = match kind_of_term c with
       (str"(" ++ pr_constr c ++ spc() ++
        prlist_with_sep spc pr_constr (Array.to_list l) ++ str")")
   | Evar (e,l) -> hov 1
-      (str"Evar#" ++ int e ++ str"{" ++
+      (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++
        prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
-  | Const c -> str"Cst(" ++ pr_con c ++ str")"
-  | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")"
-  | Construct ((sp,i),j) ->
-      str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
+  | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")"
+  | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")"
+  | Construct (((sp,i),j),u) ->
+      str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")"
+  | Proj (p,c) -> str"Proj(" ++ pr_con (Projection.constant p) ++ str"," ++ bool (Projection.unfolded p) ++ pr_constr c ++ str")"
   | Case (ci,p,c,bl) -> v 0
       (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
              pr_constr c ++ str"of") ++ cut() ++
        prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++
       cut() ++ str"end")
-  | Fix ((t,i),(lna,tl,bl)) ->
-      let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
-      hov 1
-        (str"fix " ++ int i ++ spc() ++  str"{" ++
-         v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
-           pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
-           cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
-         str"}")
+  | Fix f -> pr_fix pr_constr f
   | CoFix(i,(lna,tl,bl)) ->
       let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
       hov 1
@@ -142,43 +150,6 @@ let print_env env =
   in
     (sign_env ++ db_env)
 
-(*let current_module = ref empty_dirpath
-
-let set_module m = current_module := m*)
-
-let new_univ_level =
-  let univ_gen = ref 0 in
-  (fun sp ->
-    incr univ_gen;
-    Univ.make_universe_level (Lib.library_dp(),!univ_gen))
-
-let new_univ () = Univ.make_universe (new_univ_level ())
-let new_Type () = mkType (new_univ ())
-let new_Type_sort () = Type (new_univ ())
-
-(* This refreshes universes in types; works only for inferred types (i.e. for
-   types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
-   head normal form) *)
-let refresh_universes_gen strict t =
-  let modified = ref false in
-  let rec refresh t = match kind_of_term t with
-    | Sort (Type u) when strict or u <> Univ.type0m_univ ->
-	modified := true; new_Type ()
-    | Prod (na,u,v) -> mkProd (na,u,refresh v)
-    | _ -> t in
-  let t' = refresh t in
-  if !modified then t' else t
-
-let refresh_universes = refresh_universes_gen false
-let refresh_universes_strict = refresh_universes_gen true
-
-let new_sort_in_family = function
-  | InProp -> prop_sort
-  | InSet -> set_sort
-  | InType -> Type (new_univ ())
-
-
-
 (* [Rel (n+m);...;Rel(n+1)] *)
 let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i))
 
@@ -208,22 +179,23 @@ let push_rels_assum assums =
 
 let push_named_rec_types (lna,typarray,_) env =
   let ctxt =
-    array_map2_i
+    Array.map2_i
       (fun i na t ->
 	 match na with
 	   | Name id -> (id, None, lift i t)
-	   | Anonymous -> anomaly "Fix declarations must be named")
+	   | Anonymous -> anomaly (Pp.str "Fix declarations must be named"))
       lna typarray in
   Array.fold_left
     (fun e assum -> push_named assum e) env ctxt
 
-let rec lookup_rel_id id sign =
-  let rec lookrec = function
-    | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l)
-    | (n, (Name id',b,t)::l)  -> if id' = id then (n,b,t) else lookrec (n+1,l)
-    | (_, [])                 -> raise Not_found
+let lookup_rel_id id sign =
+  let rec lookrec n = function
+    | []                     -> raise Not_found
+    | (Anonymous, _, _) :: l -> lookrec (n + 1) l
+    | (Name id', b, t) :: l  ->
+      if Names.Id.equal id' id then (n, b, t) else lookrec (n + 1) l
   in
-  lookrec (1,sign)
+  lookrec 1 sign
 
 (* Constructs either [forall x:t, c] or [let x:=b:t in c] *)
 let mkProd_or_LetIn (na,body,t) c =
@@ -250,6 +222,13 @@ let it_mkNamedProd_or_LetIn init = it_named_context_quantifier mkNamedProd_or_Le
 let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_LetIn ~init
 let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init
 
+let it_mkLambda_or_LetIn_from_no_LetIn c decls =
+  let rec aux k decls c = match decls with
+  | [] -> c
+  | (na,Some b,t)::decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c))
+  | (na,None,t)::decls -> mkLambda (na,t,aux (k-1) decls c)
+  in aux (List.length decls) (List.rev decls) c
+
 (* *)
 
 (* strips head casts and flattens head applications *)
@@ -258,7 +237,7 @@ let rec strip_head_cast c = match kind_of_term c with
       let rec collapse_rec f cl2 = match kind_of_term f with
 	| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
 	| Cast (c,_,_) -> collapse_rec c cl2
-	| _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
+	| _ -> if Int.equal (Array.length cl2) 0 then f else mkApp (f,cl2)
       in
       collapse_rec f cl
   | Cast (c,_,_) -> strip_head_cast c
@@ -267,15 +246,15 @@ let rec strip_head_cast c = match kind_of_term c with
 let rec drop_extra_implicit_args c = match kind_of_term c with
   (* Removed trailing extra implicit arguments, what improves compatibility
      for constants with recently added maximal implicit arguments *)
-  | App (f,args) when isEvar (array_last args) ->
+  | App (f,args) when isEvar (Array.last args) ->
       drop_extra_implicit_args
-	(mkApp (f,fst (array_chop (Array.length args - 1) args)))
+	(mkApp (f,fst (Array.chop (Array.length args - 1) args)))
   | _ -> c
 
 (* Get the last arg of an application *)
 let last_arg c = match kind_of_term c with
-  | App (f,cl) -> array_last cl
-  | _ -> anomaly "last_arg"
+  | App (f,cl) -> Array.last cl
+  | _ -> anomaly (Pp.str "last_arg")
 
 (* Get the last arg of an application *)
 let decompose_app_vect c =
@@ -285,22 +264,22 @@ let decompose_app_vect c =
 
 let adjust_app_list_size f1 l1 f2 l2 =
   let len1 = List.length l1 and len2 = List.length l2 in
-  if len1 = len2 then (f1,l1,f2,l2)
+  if Int.equal len1 len2 then (f1,l1,f2,l2)
   else if len1 < len2 then
-   let extras,restl2 = list_chop (len2-len1) l2 in
+   let extras,restl2 = List.chop (len2-len1) l2 in
     (f1, l1, applist (f2,extras), restl2)
   else
-    let extras,restl1 = list_chop (len1-len2) l1 in
+    let extras,restl1 = List.chop (len1-len2) l1 in
     (applist (f1,extras), restl1, f2, l2)
 
 let adjust_app_array_size f1 l1 f2 l2 =
   let len1 = Array.length l1 and len2 = Array.length l2 in
-  if len1 = len2 then (f1,l1,f2,l2)
+  if Int.equal len1 len2 then (f1,l1,f2,l2)
   else if len1 < len2 then
-    let extras,restl2 = array_chop (len2-len1) l2 in
+    let extras,restl2 = Array.chop (len2-len1) l2 in
     (f1, l1, appvect (f2,extras), restl2)
   else
-    let extras,restl1 = array_chop (len1-len2) l1 in
+    let extras,restl1 = Array.chop (len1-len2) l1 in
     (appvect (f1,extras), restl1, f2, l2)
 
 (* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
@@ -317,6 +296,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with
   | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
   | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
   | App (c,al) -> mkApp (f l c, Array.map (f l) al)
+  | Proj (p,c) -> mkProj (p, f l c)
   | Evar (e,al) -> mkEvar (e, Array.map (f l) al)
   | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl)
   | Fix (ln,(lna,tl,bl)) ->
@@ -337,45 +317,81 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with
    (co-)fixpoint) *)
 
 let fold_rec_types g (lna,typarray,_) e =
-  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 -> g assum e) e ctxt
 
+let map_left2 f a g b =
+  let l = Array.length a in
+  if Int.equal l 0 then [||], [||] else begin
+    let r = Array.make l (f a.(0)) in
+    let s = Array.make l (g b.(0)) in
+    for i = 1 to l - 1 do
+      r.(i) <- f a.(i);
+      s.(i) <- g b.(i)
+    done;
+    r, s
+  end
 
 let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
   | (Rel _ | Meta _ | Var _   | Sort _ | Const _ | Ind _
     | Construct _) -> c
-  | Cast (c,k,t) -> let c' = f l c in mkCast (c',k,f l t)
-  | Prod (na,t,c) ->
+  | Cast (b,k,t) -> 
+    let b' = f l b in 
+    let t' = f l t in
+      if b' == b && t' == t then c
+      else mkCast (b',k,t')
+  | Prod (na,t,b) ->
       let t' = f l t in
-      mkProd (na, t', f (g (na,None,t) l) c)
-  | Lambda (na,t,c) ->
+      let b' = f (g (na,None,t) l) b in
+	if t' == t && b' == b then c
+	else mkProd (na, t', b')
+  | Lambda (na,t,b) ->
       let t' = f l t in
-      mkLambda (na, t', f (g (na,None,t) l) c)
-  | LetIn (na,b,t,c) ->
-      let b' = f l b in
+      let b' = f (g (na,None,t) l) b in
+	if t' == t && b' == b then c
+	else mkLambda (na, t', b')
+  | LetIn (na,bo,t,b) ->
+      let bo' = f l bo in
       let t' = f l t in
-      let c' = f (g (na,Some b,t) l) c in
-      mkLetIn (na, b', t', c')
+      let b' = f (g (na,Some bo,t) l) b in
+	if bo' == bo && t' == t && b' == b then c
+	else mkLetIn (na, bo', t', b')	    
   | App (c,[||]) -> assert false
-  | App (c,al) ->
+  | App (t,al) ->
       (*Special treatment to be able to recognize partially applied subterms*)
       let a = al.(Array.length al - 1) in
-      let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in
-      mkApp (hd, [| f l a |])
-  | Evar (e,al) -> mkEvar (e, array_map_left (f l) al)
-  | Case (ci,p,c,bl) ->
+      let app = (mkApp (t, Array.sub al 0 (Array.length al - 1))) in
+      let app' = f l app in
+      let a' = f l a in
+	if app' == app && a' == a then c
+	else mkApp (app', [| a' |])
+  | Proj (p,b) ->
+    let b' = f l b in
+      if b' == b then c
+      else mkProj (p, b')
+  | Evar (e,al) -> 
+    let al' = Array.map_left (f l) al in
+      if Array.for_all2 (==) al' al then c
+      else mkEvar (e, al')
+  | Case (ci,p,b,bl) ->
       (* In v8 concrete syntax, predicate is after the term to match! *)
-      let c' = f l c in
+      let b' = f l b in
       let p' = f l p in
-      mkCase (ci, p', c', array_map_left (f l) bl)
+      let bl' = Array.map_left (f l) bl in
+	if b' == b && p' == p && bl' == bl then c
+	else mkCase (ci, p', b', bl')
   | Fix (ln,(lna,tl,bl as fx)) ->
       let l' = fold_rec_types g fx l in
-      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
-      mkFix (ln,(lna,tl',bl'))
+      let (tl', bl') = map_left2 (f l) tl (f l') bl in
+	if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
+	then c
+	else mkFix (ln,(lna,tl',bl'))
   | CoFix(ln,(lna,tl,bl as fx)) ->
       let l' = fold_rec_types g fx l in
-      let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in
-      mkCoFix (ln,(lna,tl',bl'))
+      let (tl', bl') = map_left2 (f l) tl (f l') bl in
+	if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
+	then c
+	else mkCoFix (ln,(lna,tl',bl'))
 
 (* strong *)
 let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
@@ -401,30 +417,33 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
   | App (c,al) ->
       let c' = f l c in
       let al' = Array.map (f l) al in
-      if c==c' && array_for_all2 (==) al al' then cstr else mkApp (c', al')
+      if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al')
+  | Proj (p,c) -> 
+      let c' = f l c in
+	if c' == c then cstr else mkProj (p, c')
   | Evar (e,al) ->
       let al' = Array.map (f l) al in
-      if array_for_all2 (==) al al' then cstr else mkEvar (e, al')
+      if Array.for_all2 (==) al al' then cstr else mkEvar (e, al')
   | Case (ci,p,c,bl) ->
       let p' = f l p in
       let c' = f l c in
       let bl' = Array.map (f l) bl in
-      if p==p' && c==c' && array_for_all2 (==) bl bl' then cstr else
+      if p==p' && c==c' && Array.for_all2 (==) bl bl' then cstr else
         mkCase (ci, p', c', bl')
   | Fix (ln,(lna,tl,bl)) ->
       let tl' = Array.map (f l) tl in
       let l' =
-        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+        Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
       let bl' = Array.map (f l') bl in
-      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
       then cstr
       else mkFix (ln,(lna,tl',bl'))
   | CoFix(ln,(lna,tl,bl)) ->
       let tl' = Array.map (f l) tl in
       let l' =
-        array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+        Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
       let bl' = Array.map (f l') bl in
-      if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+      if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl'
       then cstr
       else mkCoFix (ln,(lna,tl',bl'))
 
@@ -443,15 +462,16 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with
   | Lambda (_,t,c) -> f (g n) (f n acc t) c
   | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c
   | App (c,l) -> Array.fold_left (f n) (f n acc c) l
+  | Proj (p,c) -> f n acc c
   | Evar (_,l) -> Array.fold_left (f n) acc l
   | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl
   | Fix (_,(lna,tl,bl)) ->
       let n' = iterate g (Array.length tl) n in
-      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      let fd = Array.map2 (fun t b -> (t,b)) tl bl in
       Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
   | CoFix (_,(lna,tl,bl)) ->
       let n' = iterate g (Array.length tl) n in
-      let fd = array_map2 (fun t b -> (t,b)) tl bl in
+      let fd = Array.map2 (fun t b -> (t,b)) tl bl in
       Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd
 
 (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate
@@ -467,14 +487,15 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with
   | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
   | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
   | App (c,args) -> f l c; Array.iter (f l) args
+  | Proj (p,c) -> f l c
   | Evar (_,args) -> Array.iter (f l) args
   | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl
   | Fix (_,(lna,tl,bl)) ->
-      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
       Array.iter (f l) tl;
       Array.iter (f l') bl
   | CoFix (_,(lna,tl,bl)) ->
-      let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
+      let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in
       Array.iter (f l) tl;
       Array.iter (f l') bl
 
@@ -503,23 +524,16 @@ let occur_meta_or_existential c =
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
-let occur_const s c =
-  let rec occur_rec c = match kind_of_term c with
-    | Const sp when sp=s -> raise Occur
-    | _ -> iter_constr occur_rec c
-  in
-  try occur_rec c; false with Occur -> true
-
 let occur_evar n c =
   let rec occur_rec c = match kind_of_term c with
-    | Evar (sp,_) when sp=n -> raise Occur
+    | Evar (sp,_) when Evar.equal sp n -> raise Occur
     | _ -> iter_constr occur_rec c
   in
   try occur_rec c; false with Occur -> true
 
 let occur_in_global env id constr =
   let vars = vars_of_global env constr in
-  if List.mem id vars then raise Occur
+  if Id.Set.mem id vars then raise Occur
 
 let occur_var env id c =
   let rec occur_rec c =
@@ -540,10 +554,10 @@ let occur_var_in_decl env hyp (_,c,typ) =
 
 let free_rels m =
   let rec frec depth acc c = match kind_of_term c with
-    | Rel n       -> if n >= depth then Intset.add (n-depth+1) acc else acc
+    | Rel n       -> if n >= depth then Int.Set.add (n-depth+1) acc else acc
     | _ -> fold_constr_with_binders succ frec depth acc c
   in
-  frec 1 Intset.empty m
+  frec 1 Int.Set.empty m
 
 (* collects all metavar occurences, in left-to-right order, preserving
  * repetitions and all. *)
@@ -551,7 +565,7 @@ let free_rels m =
 let collect_metas c =
   let rec collrec acc c =
     match kind_of_term c with
-      | Meta mv -> list_add_set mv acc
+      | Meta mv -> List.add_set Int.equal mv acc
       | _       -> fold_constr collrec acc c
   in
   List.rev (collrec [] c)
@@ -560,32 +574,41 @@ let collect_metas c =
    all section variables; for the latter, use global_vars_set *)
 let collect_vars c =
   let rec aux vars c = match kind_of_term c with
-  | Var id -> Idset.add id vars
+  | Var id -> Id.Set.add id vars
   | _ -> fold_constr aux vars c in
-  aux Idset.empty c
+  aux Id.Set.empty c
 
 (* Tests whether [m] is a subterm of [t]:
    [m] is appropriately lifted through abstractions of [t] *)
 
-let dependent_main noevar m t =
+let dependent_main noevar univs m t =
+  let eqc x y = if univs then fst (Universes.eq_constr_universes x y) else eq_constr_nounivs x y in
   let rec deprec m t =
-    if eq_constr m t then
+    if eqc m t then
       raise Occur
     else
       match kind_of_term m, kind_of_term t with
 	| App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt ->
 	    deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm)));
-	    Array.iter (deprec m)
+	    CArray.Fun1.iter deprec m
 	      (Array.sub lt
 		(Array.length lm) ((Array.length lt) - (Array.length lm)))
-	| _, Cast (c,_,_) when noevar & isMeta c -> ()
+	| _, Cast (c,_,_) when noevar && isMeta c -> ()
 	| _, Evar _ when noevar -> ()
-	| _ -> iter_constr_with_binders (lift 1) deprec m t
+	| _ -> iter_constr_with_binders (fun c -> lift 1 c) deprec m t
   in
   try deprec m t; false with Occur -> true
 
-let dependent = dependent_main false
-let dependent_no_evar = dependent_main true
+let dependent = dependent_main false false
+let dependent_no_evar = dependent_main true false
+
+let dependent_univs = dependent_main false true
+let dependent_univs_no_evar = dependent_main true true
+
+let dependent_in_decl a (_,c,t) =
+  match c with
+    | None -> dependent a t
+    | Some body -> dependent a body || dependent a t
 
 let count_occurrences m t =
   let n = ref 0 in
@@ -621,7 +644,7 @@ type meta_value_map = (metavariable * constr) list
 
 let rec subst_meta bl c =
   match kind_of_term c with
-    | Meta i -> (try List.assoc i bl with Not_found -> c)
+    | Meta i -> (try Int.List.assoc i bl with Not_found -> c)
     | _ -> map_constr (subst_meta bl) c
 
 (* First utilities for avoiding telescope computation for subst_term *)
@@ -686,184 +709,42 @@ let replace_term_gen eq_fun c by_c in_t =
 
 let replace_term = replace_term_gen eq_constr
 
-(* Substitute only at a list of locations or excluding a list of
-   locations; in the occurrences list (b,l), b=true means no
-   occurrence except the ones in l and b=false, means all occurrences
-   except the ones in l *)
-
-type hyp_location_flag = (* To distinguish body and type of local defs *)
-  | InHyp
-  | InHypTypeOnly
-  | InHypValueOnly
-
-type occurrences = bool * int list
-let all_occurrences = (false,[])
-let no_occurrences_in_set = (true,[])
-
-let error_invalid_occurrence l =
-  let l = list_uniquize (List.sort Pervasives.compare l) in
-  errorlabstrm ""
-    (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++
-     prlist_with_sep spc int l ++ str ".")
-
-let pr_position (cl,pos) =
-  let clpos = match cl with
-    | None -> str " of the goal"
-    | Some (id,InHyp) -> str " of hypothesis " ++ pr_id id
-    | Some (id,InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id
-    | Some (id,InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in
-  int pos ++ clpos
-
-let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) (nowhere_except_in,locs) =
-  let s = if nested then "Found nested occurrences of the pattern"
-    else "Found incompatible occurrences of the pattern" in
-  errorlabstrm ""
-    (str s ++ str ":" ++
-     spc () ++ str "Matched term " ++ quote (print_constr t2) ++
-     strbrk " at position " ++ pr_position (cl2,pos2) ++ 
-     strbrk " is not compatible with matched term " ++
-     quote (print_constr t1) ++ strbrk " at position " ++ 
-     pr_position (cl1,pos1) ++ str ".")
-
-let is_selected pos (nowhere_except_in,locs) =
-  nowhere_except_in && List.mem pos locs ||
-  not nowhere_except_in && not (List.mem pos locs)
-
-exception NotUnifiable
-
-type 'a testing_function = {
-  match_fun : constr -> 'a;
-  merge_fun : 'a -> 'a -> 'a;
-  mutable testing_state : 'a;
-  mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option
-}
-
-let subst_closed_term_occ_gen_modulo (nowhere_except_in,locs as plocs) test cl occ t =
-  let maxocc = List.fold_right max locs 0 in
-  let pos = ref occ in
-  let nested = ref false in
-  let add_subst t subst =
-    try
-      test.testing_state <- test.merge_fun subst test.testing_state;
-      test.last_found <- Some (cl,!pos,t)
-    with NotUnifiable ->
-      let lastpos = Option.get test.last_found in
-      error_cannot_unify_occurrences !nested (cl,!pos,t) lastpos plocs in
-  let rec substrec k t =
-    if nowhere_except_in & !pos > maxocc then t else
-    try
-      let subst = test.match_fun t in
-      if is_selected !pos plocs then
-        (add_subst t subst; incr pos;
-         (* Check nested matching subterms *)
-         nested := true; ignore (subst_below k t); nested := false;
-         (* Do the effective substitution *)
-         mkRel k)
-      else
-        (incr pos; subst_below k t)
-    with NotUnifiable ->
-      subst_below k t
-  and subst_below k t =
-    map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t
-  in
-  let t' = substrec 1 t in
-  (!pos, t')
-
-let is_nowhere (nowhere_except_in,locs) = nowhere_except_in && locs = [] 
-
-let check_used_occurrences nbocc (nowhere_except_in,locs) =
-  let rest = List.filter (fun o -> o >= nbocc) locs in
-  if rest <> [] then error_invalid_occurrence rest
-
-let proceed_with_occurrences f plocs x =
-  if is_nowhere plocs then (* optimization *) x else
-  begin
-    assert (List.for_all (fun x -> x >= 0) (snd plocs));
-    let (nbocc,x) = f 1 x in
-    check_used_occurrences nbocc plocs;
-    x
-  end
-
-let make_eq_test c = {
-  match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable);
-  merge_fun = (fun () () -> ());
-  testing_state = ();
-  last_found = None
-} 
-
-let subst_closed_term_occ_gen plocs pos c t =
-  subst_closed_term_occ_gen_modulo plocs (make_eq_test c) None pos t
-
-let subst_closed_term_occ plocs c t =
-  proceed_with_occurrences (fun occ -> subst_closed_term_occ_gen plocs occ c)
-    plocs t
-
-let subst_closed_term_occ_modulo plocs test cl t =
-  proceed_with_occurrences
-    (subst_closed_term_occ_gen_modulo plocs test cl) plocs t
-
-let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) =
-  let f = f (Some (id,hyploc)) in
-  match bodyopt,hyploc with
-  | None, InHypValueOnly ->
-      errorlabstrm "" (pr_id id ++ str " has no value.")
-  | None, _ | Some _, InHypTypeOnly ->
-      let acc,typ = f acc typ in acc,(id,bodyopt,typ)
-  | Some body, InHypValueOnly ->
-      let acc,body = f acc body in acc,(id,Some body,typ)
-  | Some body, InHyp ->
-      let acc,body = f acc body in
-      let acc,typ = f acc typ in
-      acc,(id,Some body,typ)
-
-let subst_closed_term_occ_decl (plocs,hyploc) c d =
-  proceed_with_occurrences
-    (map_named_declaration_with_hyploc
-       (fun _ occ -> subst_closed_term_occ_gen plocs occ c) hyploc) plocs d
-
-let subst_closed_term_occ_decl_modulo (plocs,hyploc) test d =
-  proceed_with_occurrences
-    (map_named_declaration_with_hyploc
-       (subst_closed_term_occ_gen_modulo plocs test)
-       hyploc)
-    plocs d
-
 let vars_of_env env =
   let s =
-    Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s)
-      (named_context env) ~init:Idset.empty in
-  Sign.fold_rel_context
-    (fun (na,_,_) s -> match na with Name id -> Idset.add id s | _ -> s)
+    Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s)
+      (named_context env) ~init:Id.Set.empty in
+  Context.fold_rel_context
+    (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s)
     (rel_context env) ~init:s
 
 let add_vname vars = function
-    Name id -> Idset.add id vars
+    Name id -> Id.Set.add id vars
   | _ -> vars
 
 (*************************)
 (*   Names environments  *)
 (*************************)
-type names_context = name list
+type names_context = Name.t list
 let add_name n nl = n::nl
 let lookup_name_of_rel p names =
   try List.nth names (p-1)
   with Invalid_argument _ | Failure _ -> raise Not_found
-let rec lookup_rel_of_name id names =
+let lookup_rel_of_name id names =
   let rec lookrec n = function
     | Anonymous :: l  -> lookrec (n+1) l
-    | (Name id') :: l -> if id' = id then n else lookrec (n+1) l
+    | (Name id') :: l -> if Id.equal id' id then n else lookrec (n+1) l
     | []            -> raise Not_found
   in
   lookrec 1 names
 let empty_names_context = []
 
 let ids_of_rel_context sign =
-  Sign.fold_rel_context
+  Context.fold_rel_context
     (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
     sign ~init:[]
 
 let ids_of_named_context sign =
-  Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
+  Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
 
 let ids_of_context env =
   (ids_of_rel_context (rel_context env))
@@ -882,15 +763,16 @@ let isGlobalRef c =
   | Const _ | Ind _ | Construct _ | Var _ -> true
   | _ -> false
 
-let has_polymorphic_type c =
-  match (Global.lookup_constant c).Declarations.const_type with
-  | Declarations.PolymorphicArity _ -> true
+let is_template_polymorphic env f =
+  match kind_of_term f with
+  | Ind ind -> Environ.template_polymorphic_pind ind env
+  | Const c -> Environ.template_polymorphic_pconstant c env
   | _ -> false
 
 let base_sort_cmp pb s0 s1 =
   match (s0,s1) with
-    | (Prop c1, Prop c2) -> c1 = Null or c2 = Pos  (* Prop <= Set *)
-    | (Prop c1, Type u)  -> pb = Reduction.CUMUL
+    | (Prop c1, Prop c2) -> c1 == Null || c2 == Pos  (* Prop <= Set *)
+    | (Prop c1, Type u)  -> pb == Reduction.CUMUL
     | (Type u1, Type u2) -> true
     | _ -> false
 
@@ -899,45 +781,48 @@ let compare_constr_univ f cv_pb t1 t2 =
   match kind_of_term t1, kind_of_term t2 with
       Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2
     | Prod (_,t1,c1), Prod (_,t2,c2) ->
-	f Reduction.CONV t1 t2 & f cv_pb c1 c2
-    | _ -> compare_constr (f Reduction.CONV) t1 t2
+	f Reduction.CONV t1 t2 && f cv_pb c1 c2
+    | _ -> compare_constr (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2
 
 let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2
 
-let eq_constr = constr_cmp Reduction.CONV
+let eq_constr t1 t2 = constr_cmp Reduction.CONV t1 t2
 
 (* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn)
    App(c,[||]) -> ([],c) *)
 let split_app c = match kind_of_term c with
     App(c,l) ->
       let len = Array.length l in
-      if len=0 then ([],c) else
+      if Int.equal len 0 then ([],c) else
 	let last = Array.get l (len-1) in
 	let prev = Array.sub l 0 (len-1) in
 	c::(Array.to_list prev), last
   | _ -> assert false
 
-let hdtl l = List.hd l, List.tl l
-
-type subst = (rel_context*constr) Intmap.t
+type subst = (rel_context*constr) Evar.Map.t
 
 exception CannotFilter
 
 let filtering env cv_pb c1 c2 =
-  let evm = ref Intmap.empty in
+  let evm = ref Evar.Map.empty in
   let define cv_pb e1 ev c1 =
-    try let (e2,c2) = Intmap.find ev !evm in
+    try let (e2,c2) = Evar.Map.find ev !evm in
     let shift = List.length e1 - List.length e2 in
     if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter
     with Not_found ->
-      evm := Intmap.add ev (e1,c1) !evm
+      evm := Evar.Map.add ev (e1,c1) !evm
   in
   let rec aux env cv_pb c1 c2 =
     match kind_of_term c1, kind_of_term c2 with
       | App _, App _ ->
-	  let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in
-	  aux env cv_pb l1 l2; if p1=[] & p2=[] then () else
-	      aux env cv_pb (applist (hdtl p1)) (applist (hdtl p2))
+        let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in
+        let () = aux env cv_pb l1 l2 in
+        begin match p1, p2 with
+        | [], [] -> ()
+        | (h1 :: p1), (h2 :: p2) ->
+          aux env cv_pb (applistc h1 p1) (applistc h2 p2)
+        | _ -> assert false
+        end
       | Prod (n,t1,c1), Prod (_,t2,c2) ->
 	  aux env cv_pb t1 t2;
 	  aux ((n,None,t1)::env) cv_pb c1 c2
@@ -963,12 +848,12 @@ let align_prod_letin c a : rel_context * constr =
   let (lc,_,_) = decompose_prod_letin c in
   let (la,l,a) = decompose_prod_letin a in
   if not (la >= lc) then invalid_arg "align_prod_letin";
-  let (l1,l2) = Util.list_chop lc l in
+  let (l1,l2) = Util.List.chop lc l in
   l2,it_mkProd_or_LetIn a l1
 
-(* On reduit une serie d'eta-redex de tete ou rien du tout  *)
+(* We reduce a series of head eta-redex or nothing at all   *)
 (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *)
-(* Remplace 2 versions précédentes buggées                  *)
+(* Remplace 2 earlier buggish versions                      *)
 
 let rec eta_reduce_head c =
   match kind_of_term c with
@@ -976,12 +861,12 @@ let rec eta_reduce_head c =
 	(match kind_of_term (eta_reduce_head c') with
            | App (f,cl) ->
                let lastn = (Array.length cl) - 1 in
-               if lastn < 1 then anomaly "application without arguments"
+               if lastn < 0 then anomaly (Pp.str "application without arguments")
                else
                  (match kind_of_term cl.(lastn) with
                     | Rel 1 ->
 			let c' =
-                          if lastn = 1 then f
+                          if Int.equal lastn 0 then f
 			  else mkApp (f, Array.sub cl 0 lastn)
 			in
 			if noccurn 1 c'
@@ -992,24 +877,15 @@ let rec eta_reduce_head c =
     | _ -> c
 
 
-(* alpha-eta conversion : ignore print names and casts *)
-let eta_eq_constr =
-  let rec aux t1 t2 =
-    let t1 = eta_reduce_head (strip_head_cast t1)
-    and t2 = eta_reduce_head (strip_head_cast t2) in
-    t1=t2 or compare_constr aux t1 t2
-  in aux
-
-
 (* iterator on rel context *)
 let process_rel_context f env =
   let sign = named_context_val env in
   let rels = rel_context env in
   let env0 = reset_with_named_context sign env in
-  Sign.fold_rel_context f rels ~init:env0
+  Context.fold_rel_context f rels ~init:env0
 
 let assums_of_rel_context sign =
-  Sign.fold_rel_context
+  Context.fold_rel_context
     (fun (na,c,t) l ->
       match c with
           Some _ -> l
@@ -1054,37 +930,49 @@ let adjust_subst_to_rel_context sign l =
     | (_,Some c,_)::sign', args' ->
 	aux (substl (List.rev subst) c :: subst) sign' args'
     | [], [] -> List.rev subst
-    | _ -> anomaly "Instance and signature do not match"
+    | _ -> anomaly (Pp.str "Instance and signature do not match")
   in aux [] (List.rev sign) l
 
-let fold_named_context_both_sides f l ~init = list_fold_right_and_left f l init
+let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init
 
 let rec mem_named_context id = function
-  | (id',_,_) :: _ when id=id' -> true
+  | (id',_,_) :: _ when Id.equal id id' -> true
   | _ :: sign -> mem_named_context id sign
   | [] -> false
 
+let compact_named_context_reverse sign =
+  let compact l (i1,c1,t1) =
+    match l with
+    | [] -> [[i1],c1,t1]
+    | (l2,c2,t2)::q ->
+       if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
+       then (i1::l2,c2,t2)::q
+       else ([i1],c1,t1)::l
+  in Context.fold_named_context_reverse compact ~init:[] sign
+
+let compact_named_context sign = List.rev (compact_named_context_reverse sign)
+
 let clear_named_body id env =
-  let rec aux _ = function
-  | (id',Some c,t) when id = id' -> push_named (id,None,t)
+  let aux _ = function
+  | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t)
   | d -> push_named d in
   fold_named_context aux env ~init:(reset_context env)
 
-let global_vars env ids = Idset.elements (global_vars_set env ids)
+let global_vars env ids = Id.Set.elements (global_vars_set env ids)
 
 let global_vars_set_of_decl env = function
   | (_,None,t) -> global_vars_set env t
   | (_,Some c,t) ->
-      Idset.union (global_vars_set env t)
+      Id.Set.union (global_vars_set env t)
         (global_vars_set env c)
 
 let dependency_closure env sign hyps =
-  if Idset.is_empty hyps then [] else
+  if Id.Set.is_empty hyps then [] else
     let (_,lh) =
-      Sign.fold_named_context_reverse
+      Context.fold_named_context_reverse
         (fun (hs,hl) (x,_,_ as d) ->
-          if Idset.mem x hs then
-            (Idset.union (global_vars_set_of_decl env d) (Idset.remove x hs),
+          if Id.Set.mem x hs then
+            (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs),
             x::hl)
           else (hs,hl))
         ~init:(hyps,[])
@@ -1104,13 +992,13 @@ let context_chop k ctx =
     | (0, l2) -> (List.rev acc, l2)
     | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
     | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
-    | (_, []) -> anomaly "context_chop"
+    | (_, []) -> anomaly (Pp.str "context_chop")
   in chop_aux [] (k,ctx)
 
 (* Do not skip let-in's *)
 let env_rel_context_chop k env =
   let rels = rel_context env in
-  let ctx1,ctx2 = list_chop k rels in
+  let ctx1,ctx2 = List.chop k rels in
   push_rel_context ctx2 (reset_with_named_context (named_context_val env) env),
   ctx1
 
@@ -1122,13 +1010,15 @@ let impossible_default_case = ref None
 let set_impossible_default_clause c = impossible_default_case := Some c
 
 let coq_unit_judge =
-  let na1 = Name (id_of_string "A") in
-  let na2 = Name (id_of_string "H") in
+  let na1 = Name (Id.of_string "A") in
+  let na2 = Name (Id.of_string "H") in
   fun () ->
     match !impossible_default_case with
-    | Some (id,type_of_id) ->
-	make_judge id type_of_id
+    | Some fn -> 
+        let (id,type_of_id), ctx = fn () in
+	  make_judge id type_of_id, ctx
     | None ->
 	(* In case the constants id/ID are not defined *)
 	make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1)))
-                 (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2)))
+                 (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), 
+       Univ.ContextSet.empty
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index 81b23d7e..9f3efd72 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -1,30 +1,22 @@
 (************************************************************************)
 (*  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 Util
 open Pp
 open Names
 open Term
-open Sign
+open Context
 open Environ
-
-(** Universes *)
-val new_univ_level : unit -> Univ.universe_level
-val new_univ : unit -> Univ.universe
-val new_sort_in_family : sorts_family -> sorts
-val new_Type : unit -> types
-val new_Type_sort : unit -> sorts
-val refresh_universes : types -> types
-val refresh_universes_strict : types -> types
+open Locus
 
 (** printers *)
 val print_sort : sorts -> std_ppcmds
 val pr_sort_family : sorts_family -> std_ppcmds
+val pr_fix : (constr -> std_ppcmds) -> fixpoint -> std_ppcmds
 
 (** debug printer: do not use to display terms to the casual user... *)
 val set_print_constr : (env -> constr -> std_ppcmds) -> unit
@@ -36,12 +28,19 @@ val print_rel_context : env -> std_ppcmds
 val print_env : env -> std_ppcmds
 
 (** about contexts *)
-val push_rel_assum : name * types -> env -> env
-val push_rels_assum : (name * types) list -> env -> env
-val push_named_rec_types : name array * types array * 'a -> env -> env
-val lookup_rel_id : identifier -> rel_context -> int * constr option * types
-
-(** builds argument lists matching a block of binders or a context *)
+val push_rel_assum : Name.t * types -> env -> env
+val push_rels_assum : (Name.t * types) list -> env -> env
+val push_named_rec_types : Name.t array * types array * 'a -> env -> env
+
+val lookup_rel_id : Id.t -> rel_context -> int * constr option * types
+(** Associates the contents of an identifier in a [rel_context]. Raise
+    [Not_found] if there is no such identifier. *)
+
+(** Functions that build argument lists matching a block of binders or a context.
+    [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|]
+    [extended_rel_vect n ctx] extends the [ctx] context of length [m]
+    with [n] elements.
+*)
 val rel_vect : int -> int -> constr array
 val rel_list : int -> int -> constr list
 val extended_rel_list : int -> rel_context -> constr list
@@ -50,8 +49,8 @@ val extended_rel_vect : int -> rel_context -> constr array
 (** iterators/destructors on terms *)
 val mkProd_or_LetIn : rel_declaration -> types -> types
 val mkProd_wo_LetIn : rel_declaration -> types -> types
-val it_mkProd : types -> (name * types) list -> types
-val it_mkLambda : constr -> (name * types) list -> constr
+val it_mkProd : types -> (Name.t * types) list -> types
+val it_mkLambda : constr -> (Name.t * types) list -> constr
 val it_mkProd_or_LetIn : types -> rel_context -> types
 val it_mkProd_wo_LetIn : types -> rel_context -> types
 val it_mkLambda_or_LetIn : constr -> rel_context -> constr
@@ -59,13 +58,14 @@ val it_mkNamedProd_or_LetIn : types -> named_context -> types
 val it_mkNamedProd_wo_LetIn : types -> named_context -> types
 val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr
 
-val it_named_context_quantifier :
-  (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
+(* Ad hoc version reinserting letin, assuming the body is defined in
+   the context where the letins are expanded *)
+val it_mkLambda_or_LetIn_from_no_LetIn : constr -> rel_context -> constr
 
 (** {6 Generic iterators on constr} *)
 
 val map_constr_with_named_binders :
-  (name -> 'a -> 'a) ->
+  (Name.t -> 'a -> 'a) ->
   ('a -> constr -> constr) -> 'a -> constr -> constr
 val map_constr_with_binders_left_to_right :
   (rel_declaration -> 'a -> 'a) ->
@@ -99,18 +99,22 @@ exception Occur
 val occur_meta : types -> bool
 val occur_existential : types -> bool
 val occur_meta_or_existential : types -> bool
-val occur_const : constant -> types -> bool
 val occur_evar : existential_key -> types -> bool
-val occur_var : env -> identifier -> types -> bool
+val occur_var : env -> Id.t -> types -> bool
 val occur_var_in_decl :
   env ->
-  identifier -> 'a * types option * types -> bool
-val free_rels : constr -> Intset.t
+  Id.t -> 'a * types option * types -> bool
+val free_rels : constr -> Int.Set.t
+
+(** [dependent m t] tests whether [m] is a subterm of [t] *)
 val dependent : constr -> constr -> bool
 val dependent_no_evar : constr -> constr -> bool
+val dependent_univs : constr -> constr -> bool
+val dependent_univs_no_evar : constr -> constr -> bool
+val dependent_in_decl : constr -> named_declaration -> bool
 val count_occurrences : constr -> constr -> int
 val collect_metas : constr -> int list
-val collect_vars : constr -> Idset.t (** for visible vars only *)
+val collect_vars : constr -> Id.Set.t (** for visible vars only *)
 val occur_term : constr -> constr -> bool (** Synonymous
  of dependent 
    Substitution of metavariables *)
@@ -144,68 +148,14 @@ val subst_term : constr -> constr -> constr
 (** [replace_term d e c] replaces [d] by [e] in [c] *)
 val replace_term : constr -> constr -> constr -> constr
 
-(** In occurrences sets, false = everywhere except and true = nowhere except *)
-type occurrences = bool * int list
-val all_occurrences : occurrences
-val no_occurrences_in_set : occurrences
-
-(** [subst_closed_term_occ_gen occl n c d] replaces occurrences of closed [c] at
-   positions [occl], counting from [n], by [Rel 1] in [d] *)
-val subst_closed_term_occ_gen :
-  occurrences -> int -> constr -> types -> int * types
-
-(** [subst_closed_term_occ_modulo] looks for subterm modulo a
-    testing function returning a substitution of type ['a] (or failing
-    with NotUnifiable); a function for merging substitution (possibly
-    failing with NotUnifiable) and an initial substitution are
-    required too *)
-
-type hyp_location_flag = (** To distinguish body and type of local defs *)
-  | InHyp
-  | InHypTypeOnly
-  | InHypValueOnly
-
-type 'a testing_function = {
-  match_fun : constr -> 'a;
-  merge_fun : 'a -> 'a -> 'a;
-  mutable testing_state : 'a;
-  mutable last_found : ((identifier * hyp_location_flag) option * int * constr) option
-}
-
-val make_eq_test : constr -> unit testing_function
-
-exception NotUnifiable
-
-val subst_closed_term_occ_modulo :
-  occurrences -> 'a testing_function -> (identifier * hyp_location_flag) option
-  -> constr -> types
-
-(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at
-   positions [occl] by [Rel 1] in [d] (see also Note OCC) *)
-val subst_closed_term_occ : occurrences -> constr -> constr -> constr
-
-(** [subst_closed_term_occ_decl occl c decl] replaces occurrences of closed [c]
-   at positions [occl] by [Rel 1] in [decl] *)
-
-val subst_closed_term_occ_decl :
-  occurrences * hyp_location_flag -> constr -> named_declaration ->
-      named_declaration
-
-val subst_closed_term_occ_decl_modulo :
-  occurrences * hyp_location_flag -> 'a testing_function ->
-  named_declaration -> named_declaration
-
-val error_invalid_occurrence : int list -> 'a
-
 (** Alternative term equalities *)
 val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool
 val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) ->
   Reduction.conv_pb -> constr -> constr -> bool
 val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool
-val eq_constr : constr -> constr -> bool
+val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*)
 
 val eta_reduce_head : constr -> constr
-val eta_eq_constr : constr -> constr -> bool
 
 exception CannotFilter
 
@@ -215,7 +165,7 @@ exception CannotFilter
    (context,term), or raises [CannotFilter].
    Warning: Outer-kernel sort subtyping are taken into account: c1 has
    to be smaller than c2 wrt. sorts. *)
-type subst = (rel_context*constr) Intmap.t
+type subst = (rel_context*constr) Evar.Map.t
 val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst
 
 val decompose_prod_letin : constr -> int * rel_context * constr
@@ -233,26 +183,26 @@ val adjust_app_array_size : constr -> constr array -> constr -> constr array ->
   (constr * constr array * constr * constr array)
 
 (** name contexts *)
-type names_context = name list
-val add_name : name -> names_context -> names_context
-val lookup_name_of_rel : int -> names_context -> name
-val lookup_rel_of_name : identifier -> names_context -> int
+type names_context = Name.t list
+val add_name : Name.t -> names_context -> names_context
+val lookup_name_of_rel : int -> names_context -> Name.t
+val lookup_rel_of_name : Id.t -> names_context -> int
 val empty_names_context : names_context
-val ids_of_rel_context : rel_context -> identifier list
-val ids_of_named_context : named_context -> identifier list
-val ids_of_context : env -> identifier list
+val ids_of_rel_context : rel_context -> Id.t list
+val ids_of_named_context : named_context -> Id.t list
+val ids_of_context : env -> Id.t list
 val names_of_rel_context : env -> names_context
 
 val context_chop : int -> rel_context -> rel_context * rel_context
 val env_rel_context_chop : int -> env -> env * rel_context
 
 (** Set of local names *)
-val vars_of_env: env -> Idset.t
-val add_vname : Idset.t -> name -> Idset.t
+val vars_of_env: env -> Id.Set.t
+val add_vname : Id.Set.t -> Name.t -> Id.Set.t
 
 (** other signature iterators *)
 val process_rel_context : (rel_declaration -> env -> env) -> env -> env
-val assums_of_rel_context : rel_context -> (name * constr) list
+val assums_of_rel_context : rel_context -> (Name.t * constr) list
 val lift_rel_context : int -> rel_context -> rel_context
 val substl_rel_context : constr list -> rel_context -> rel_context
 val smash_rel_context : rel_context -> rel_context (** expand lets in context *)
@@ -264,23 +214,25 @@ val map_rel_context_with_binders :
 val fold_named_context_both_sides :
   ('a -> named_declaration -> named_declaration list -> 'a) ->
     named_context -> init:'a -> 'a
-val mem_named_context : identifier -> named_context -> bool
+val mem_named_context : Id.t -> named_context -> bool
+val compact_named_context : named_context -> named_list_context
+val compact_named_context_reverse : named_context -> named_list_context
 
-val clear_named_body : identifier -> env -> env
+val clear_named_body : Id.t -> env -> env
 
-val global_vars : env -> constr -> identifier list
-val global_vars_set_of_decl : env -> named_declaration -> Idset.t
+val global_vars : env -> constr -> Id.t list
+val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t
 
 (** Gives an ordered list of hypotheses, closed by dependencies,
    containing a given set *)
-val dependency_closure : env -> named_context -> Idset.t -> identifier list
+val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list
 
 (** Test if an identifier is the basename of a global reference *)
-val is_section_variable : identifier -> bool
+val is_section_variable : Id.t -> bool
 
 val isGlobalRef : constr -> bool
 
-val has_polymorphic_type : constant -> bool
+val is_template_polymorphic : env -> constr -> bool
 
 (** Combinators on judgments *)
 
@@ -289,5 +241,5 @@ val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment
 val on_judgment_type  : (types -> types) -> unsafe_judgment -> unsafe_judgment
 
 (** {6 Functions to deal with impossible cases } *)
-val set_impossible_default_clause : constr * types -> unit
-val coq_unit_judge : unit -> unsafe_judgment
+val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit
+val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 2b5b7fe2..817d6878 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.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,45 +8,50 @@
 
 (*i*)
 open Names
-open Libnames
+open Globnames
 open Decl_kinds
 open Term
-open Sign
+open Vars
+open Context
 open Evd
 open Environ
-open Nametab
-open Mod_subst
 open Util
 open Typeclasses_errors
 open Libobject
 (*i*)
 
+let typeclasses_unique_solutions = ref false
+let set_typeclasses_unique_solutions d = (:=) typeclasses_unique_solutions d
+let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions
 
-let add_instance_hint_ref = ref (fun id local pri -> assert false)
-let register_add_instance_hint =
-  (:=) add_instance_hint_ref
-let add_instance_hint id = !add_instance_hint_ref id
+open Goptions
 
-let remove_instance_hint_ref = ref (fun id -> assert false)
-let register_remove_instance_hint =
-  (:=) remove_instance_hint_ref
-let remove_instance_hint id = !remove_instance_hint_ref id
+let set_typeclasses_unique_solutions =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "check that typeclasses proof search returns unique solutions";
+      optkey   = ["Typeclasses";"Unique";"Solutions"];
+      optread  = get_typeclasses_unique_solutions;
+      optwrite = set_typeclasses_unique_solutions; }
 
-let set_typeclass_transparency_ref = ref (fun id local c -> assert false)
-let register_set_typeclass_transparency =
-  (:=) set_typeclass_transparency_ref
-let set_typeclass_transparency gr local c = !set_typeclass_transparency_ref gr local c
+let (add_instance_hint, add_instance_hint_hook) = Hook.make ()
+let add_instance_hint id = Hook.get add_instance_hint id
 
-let classes_transparent_state_ref = ref (fun () -> assert false)
-let register_classes_transparent_state = (:=) classes_transparent_state_ref
-let classes_transparent_state () = !classes_transparent_state_ref ()
+let (remove_instance_hint, remove_instance_hint_hook) = Hook.make ()
+let remove_instance_hint id = Hook.get remove_instance_hint id
 
-let solve_instanciation_problem = ref (fun _ _ _ -> assert false)
+let (set_typeclass_transparency, set_typeclass_transparency_hook) = Hook.make ()
+let set_typeclass_transparency gr local c = Hook.get set_typeclass_transparency gr local c
 
-let resolve_one_typeclass env evm t =
-  !solve_instanciation_problem env evm t
+let (classes_transparent_state, classes_transparent_state_hook) = Hook.make ()
+let classes_transparent_state () = Hook.get classes_transparent_state ()
+
+let solve_instantiation_problem = ref (fun _ _ _ _ -> assert false)
+
+let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t =
+  !solve_instantiation_problem env evm t unique
 
-type rels = constr list
 type direction = Forward | Backward
 
 (* This module defines type-classes *)
@@ -61,12 +66,14 @@ type typeclass = {
   cl_props : rel_context;
 
   (* The method implementaions as projections. *)
-  cl_projs : (name * (direction * int option) option * constant option) list;
-}
+  cl_projs : (Name.t * (direction * int option) option * constant option) list;
+  
+  cl_strict : bool;
 
-module Gmap = Fmap.Make(RefOrdered)
+  cl_unique : bool;
+}
 
-type typeclasses = typeclass Gmap.t
+type typeclasses = typeclass Refmap.t
 
 type instance = {
   is_class: global_reference;
@@ -75,14 +82,17 @@ type instance = {
      -1 for discard, 0 for none, mutable to avoid redeclarations
      when multiple rebuild_object happen. *)
   is_global: int;
+  is_poly: bool;
   is_impl: global_reference;
 }
 
-type instances = (instance Gmap.t) Gmap.t
+type instances = (instance Refmap.t) Refmap.t
 
 let instance_impl is = is.is_impl
 
-let new_instance cl pri glob impl =
+let instance_priority is = is.is_pri
+
+let new_instance cl pri glob poly impl =
   let global =
     if glob then Lib.sections_depth ()
     else -1
@@ -90,38 +100,45 @@ let new_instance cl pri glob impl =
     { is_class = cl.cl_impl;
       is_pri = pri ;
       is_global = global ;
+      is_poly = poly;
       is_impl = impl }
 
 (*
  * states management
  *)
 
-let classes : typeclasses ref = ref Gmap.empty
-
-let instances : instances ref = ref Gmap.empty
-
-let freeze () = !classes, !instances
-
-let unfreeze (cl,is) =
-  classes:=cl;
-  instances:=is
+let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes"
+let instances : instances ref = Summary.ref Refmap.empty ~name:"instances"
 
-let init () =
-  classes:= Gmap.empty;
-  instances:= Gmap.empty
+open Declarations
 
-let _ =
-  Summary.declare_summary "classes_and_instances"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
+let typeclass_univ_instance (cl,u') =
+  let subst = 
+    let u = 
+      match cl.cl_impl with
+      | ConstRef c -> 
+        let cb = Global.lookup_constant c in
+	  if cb.const_polymorphic then Univ.UContext.instance cb.const_universes
+	  else Univ.Instance.empty
+      | IndRef c ->
+         let mib,oib = Global.lookup_inductive c in
+	  if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes
+	  else Univ.Instance.empty
+      | _ -> Univ.Instance.empty
+    in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) 
+      Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u')
+  in
+  let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in
+    { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context);
+      cl_props = subst_ctx cl.cl_props}, u'
 
 let class_info c =
-  try Gmap.find c !classes
-  with Not_found -> not_a_class (Global.env()) (constr_of_global c)
+  try Refmap.find c !classes
+  with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c)
 
 let global_class_of_constr env c =
-  try class_info (global_of_constr c)
+  try let gr, u = Universes.global_of_constr c in
+	class_info gr, u
   with Not_found -> not_a_class env c
 
 let dest_class_app env c =
@@ -129,19 +146,26 @@ let dest_class_app env c =
     global_class_of_constr env cl, args
 
 let dest_class_arity env c =
-  let rels, c = Term.decompose_prod_assum c in
+  let rels, c = decompose_prod_assum c in
     rels, dest_class_app env c
 
 let class_of_constr c =
   try Some (dest_class_arity (Global.env ()) c)
   with e when Errors.noncritical e -> None
 
-let rec is_class_type evd c =
-  match kind_of_term c with
-  | Prod (_, _, t) -> is_class_type evd t
-  | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c)
-  | _ -> class_of_constr c <> None
+let is_class_constr c = 
+  try let gr, u = Universes.global_of_constr c in
+	Refmap.mem gr !classes
+  with Not_found -> false
 
+let rec is_class_type evd c =
+  let c, args = decompose_app c in
+    match kind_of_term c with
+    | Prod (_, _, t) -> is_class_type evd t
+    | Evar (e, _) when Evd.is_defined evd e ->
+      is_class_type evd (Evarutil.whd_head_evar evd c)
+    | _ -> is_class_constr c
+      
 let is_class_evar evd evi =
   is_class_type evd evi.Evd.evar_concl
 
@@ -150,25 +174,28 @@ let is_class_evar evd evi =
  *)
 
 let load_class (_, cl) =
-  classes := Gmap.add cl.cl_impl cl !classes
+  classes := Refmap.add cl.cl_impl cl !classes
 
 let cache_class = load_class
 
 let subst_class (subst,cl) =
-  let do_subst_con c = fst (Mod_subst.subst_con subst c)
+  let do_subst_con c = Mod_subst.subst_constant subst c
   and do_subst c = Mod_subst.subst_mps subst c
   and do_subst_gr gr = fst (subst_global subst gr) in
-  let do_subst_ctx ctx = list_smartmap
+  let do_subst_ctx ctx = List.smartmap
     (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t))
     ctx in
   let do_subst_context (grs,ctx) =
-    list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
+    List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs,
     do_subst_ctx ctx in
-  let do_subst_projs projs = list_smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in
+  let do_subst_projs projs = List.smartmap (fun (x, y, z) -> 
+    (x, y, Option.smartmap do_subst_con z)) projs in
   { cl_impl = do_subst_gr cl.cl_impl;
     cl_context = do_subst_context cl.cl_context;
     cl_props = do_subst_ctx cl.cl_props;
-    cl_projs = do_subst_projs cl.cl_projs; }
+    cl_projs = do_subst_projs cl.cl_projs;
+    cl_strict = cl.cl_strict;
+    cl_unique = cl.cl_unique }
 
 let discharge_class (_,cl) =
   let repl = Lib.replacement_context () in
@@ -196,22 +223,26 @@ let discharge_class (_,cl) =
       let newgrs = List.map (fun (_, _, t) -> 
 	match class_of_constr t with
 	| None -> None
-	| Some (_, (tc, _)) -> Some (tc.cl_impl, true))
+	| Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true))
 	ctx' 
       in
-	list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+	List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
 	  @ newgrs
     in grs', discharge_rel_context subst 1 ctx @ ctx' in
   let cl_impl' = Lib.discharge_global cl.cl_impl in
   if cl_impl' == cl.cl_impl then cl else
-    let ctx = abs_context cl in
+    let ctx, usubst, uctx = abs_context cl in
     let ctx, subst = rel_of_variable_context ctx in
     let context = discharge_context ctx subst cl.cl_context in
     let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in
-    { cl_impl = cl_impl';
-      cl_context = context;
-      cl_props = props;
-      cl_projs = list_smartmap (fun (x, y, z) -> x, y, Option.smartmap Lib.discharge_con z) cl.cl_projs }
+    let discharge_proj (x, y, z) = x, y, Option.smartmap Lib.discharge_con z in
+      { cl_impl = cl_impl';
+	cl_context = context;
+	cl_props = props;
+	cl_projs = List.smartmap discharge_proj cl.cl_projs;
+	cl_strict = cl.cl_strict;
+	cl_unique = cl.cl_unique
+      }
 
 let rebuild_class cl = 
   try 
@@ -239,25 +270,35 @@ let check_instance env sigma c =
   try 
     let (evd, c) = resolve_one_typeclass env sigma
       (Retyping.get_type_of env sigma c) in
-      Evd.is_empty (Evd.undefined_evars evd)
+      not (Evd.has_undefined evd)
   with e when Errors.noncritical e -> false
 
 let build_subclasses ~check env sigma glob pri =
-  let rec aux pri c =
-    let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in
+  let _id = Nametab.basename_of_global glob in
+  let _next_id = 
+    let i = ref (-1) in 
+      (fun () -> incr i;
+        Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i))
+  in
+  let ty, ctx = Global.type_of_global_in_context env glob in
+  let sigma = Evd.merge_context_set Evd.univ_rigid sigma (Univ.ContextSet.of_context ctx) in
+  let rec aux pri c ty path =
+    let ty = Evarutil.nf_evar sigma ty in
       match class_of_constr ty with
       | None -> []
-      | Some (rels, (tc, args)) ->
-	let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in
+      | Some (rels, ((tc,u), args)) ->
+	let instapp = 
+	  Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) 
+	in
 	let projargs = Array.of_list (args @ [instapp]) in
-	let projs = list_map_filter 
+	let projs = List.map_filter 
 	  (fun (n, b, proj) ->
 	   match b with 
 	   | None -> None
 	   | Some (Backward, _) -> None
 	   | Some (Forward, pri') ->
 	     let proj = Option.get proj in
-	     let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in
+	     let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in
 	       if check && check_instance env sigma body then None
 	       else 
 		 let pri = 
@@ -269,10 +310,16 @@ let build_subclasses ~check env sigma glob pri =
 		   Some (ConstRef proj, pri, body)) tc.cl_projs 
 	in
 	let declare_proj hints (cref, pri, body) =
-	  let rest = aux pri body in
-	    hints @ (pri, body) :: rest
+	  let path' = cref :: path in
+	  let ty = Retyping.get_type_of env sigma body in
+	  let rest = aux pri body ty path' in
+	    hints @ (path', pri, body) :: rest
 	in List.fold_left declare_proj [] projs 
-  in aux pri (constr_of_global glob)
+  in
+  let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in
+    (*FIXME subclasses should now get substituted for each particular instance of
+      the polymorphic superclass *)
+    aux pri term ty [glob]
 
 (*
  * instances persistent object
@@ -284,17 +331,17 @@ type instance_action =
 
 let load_instance inst = 
   let insts = 
-    try Gmap.find inst.is_class !instances 
-    with Not_found -> Gmap.empty in
-  let insts = Gmap.add inst.is_impl inst insts in
-  instances := Gmap.add inst.is_class insts !instances
+    try Refmap.find inst.is_class !instances
+    with Not_found -> Refmap.empty in
+  let insts = Refmap.add inst.is_impl inst insts in
+  instances := Refmap.add inst.is_class insts !instances
 
 let remove_instance inst =
   let insts = 
-    try Gmap.find inst.is_class !instances 
+    try Refmap.find inst.is_class !instances
     with Not_found -> assert false in
-  let insts = Gmap.remove inst.is_impl insts in
-  instances := Gmap.add inst.is_class insts !instances
+  let insts = Refmap.remove inst.is_impl insts in
+  instances := Refmap.add inst.is_class insts !instances
 
 let cache_instance (_, (action, i)) =
   match action with 
@@ -315,27 +362,28 @@ let discharge_instance (_, (action, inst)) =
       is_impl = Lib.discharge_global inst.is_impl })
     
 
-let is_local i = i.is_global = -1
+let is_local i = Int.equal i.is_global (-1)
 
 let add_instance check inst =
-  add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri;
-  List.iter (fun (pri, c) -> add_instance_hint c (is_local inst) pri) 
+  let poly = Global.is_polymorphic inst.is_impl in
+  add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) 
+    inst.is_pri poly;
+  List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path
+    (is_local inst) pri poly)
     (build_subclasses ~check:(check && not (isVarRef inst.is_impl))
        (Global.env ()) Evd.empty inst.is_impl inst.is_pri)
 
 let rebuild_instance (action, inst) =
-  if action = AddInstance then add_instance true inst;
+  let () = match action with
+  | AddInstance -> add_instance true inst
+  | _ -> ()
+  in
   (action, inst)
 
 let classify_instance (action, inst) =
   if is_local inst then Dispose
   else Substitute (action, inst)
 
-let load_instance (_, (action, inst) as ai) =
-  cache_instance ai;
-  if action = AddInstance then
-    add_instance_hint (constr_of_global inst.is_impl) (is_local inst) inst.is_pri
-
 let instance_input : instance_action * instance -> obj =
   declare_object
     { (default_object "type classes instances state") with
@@ -356,11 +404,10 @@ let remove_instance i =
   remove_instance_hint i.is_impl
 
 let declare_instance pri local glob =
-  let c = constr_of_global glob in
-  let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in
+  let ty = Global.type_of_global_unsafe glob in
     match class_of_constr ty with
-    | Some (rels, (tc, args) as _cl) ->
-      add_instance (new_instance tc pri (not local) glob)
+    | Some (rels, ((tc,_), args) as _cl) ->
+      add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob)
 (*       let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *)
 (*       let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *)
 (* 	Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *)
@@ -373,71 +420,57 @@ let add_class cl =
   List.iter (fun (n, inst, body) ->
 	     match inst with
 	     | Some (Backward, pri) ->
-	       declare_instance pri false (ConstRef (Option.get body))
+	       (match body with
+	       | None -> Errors.error "Non-definable projection can not be declared as a subinstance"
+	       | Some b -> declare_instance pri false (ConstRef b))
 	     | _ -> ())
   cl.cl_projs
 
 
 open Declarations
-
-let add_constant_class cst =
-  let ty = Typeops.type_of_constant (Global.env ()) cst in
-  let ctx, arity = decompose_prod_assum ty in
-  let tc = 
-    { cl_impl = ConstRef cst;
-      cl_context = (List.map (const None) ctx, ctx);
-      cl_props = [(Anonymous, None, arity)];
-      cl_projs = []
-    }
-  in add_class tc;
-    set_typeclass_transparency (EvalConstRef cst) false false
-      
-let add_inductive_class ind =
-  let mind, oneind = Global.lookup_inductive ind in
-  let k =
-    let ctx = oneind.mind_arity_ctxt in
-    let ty = Inductive.type_of_inductive_knowing_parameters
-      (push_rel_context ctx (Global.env ()))
-	  oneind (Termops.extended_rel_vect 0 ctx)
-    in
-      { cl_impl = IndRef ind;
-	cl_context = List.map (const None) ctx, ctx;
-	cl_props = [Anonymous, None, ty];
-	cl_projs = [] }
-  in add_class k
       
 (*
  * interface functions
  *)
 
-let instance_constructor cl args =
-  let lenpars = List.length (List.filter (fun (na, b, t) -> b = None) (snd cl.cl_context)) in
-  let pars = fst (list_chop lenpars args) in
+let instance_constructor (cl,u) args =
+  let filter (_, b, _) = match b with
+  | None -> true
+  | Some _ -> false
+  in
+  let lenpars = List.length (List.filter filter (snd cl.cl_context)) in
+  let pars = fst (List.chop lenpars args) in
     match cl.cl_impl with
-      | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args),
-	  applistc (mkInd ind) pars
+      | IndRef ind -> 
+        let ind = ind, u in
+          (Some (applistc (mkConstructUi (ind, 1)) args),
+	   applistc (mkIndU ind) pars)
       | ConstRef cst -> 
-	let term = if args = [] then None else Some (list_last args) in
-	  term, applistc (mkConst cst) pars
+        let cst = cst, u in
+	let term = match args with
+	  | [] -> None
+	  | _ -> Some (List.last args)
+	in
+	  (term, applistc (mkConstU cst) pars)
       | _ -> assert false
 
-let typeclasses () = Gmap.fold (fun _ l c -> l :: c) !classes []
+let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes []
 
-let cmap_elements c = Gmap.fold (fun k v acc -> v :: acc) c []
+let cmap_elements c = Refmap.fold (fun k v acc -> v :: acc) c []
 
 let instances_of c =
-  try cmap_elements (Gmap.find c.cl_impl !instances) with Not_found -> []
+  try cmap_elements (Refmap.find c.cl_impl !instances) with Not_found -> []
 
 let all_instances () = 
-  Gmap.fold (fun k v acc -> 
-    Gmap.fold (fun k v acc -> v :: acc) v acc)
+  Refmap.fold (fun k v acc ->
+    Refmap.fold (fun k v acc -> v :: acc) v acc)
     !instances []
 
 let instances r = 
   let cl = class_info r in instances_of cl    
-      
+
 let is_class gr = 
-  Gmap.fold (fun k v acc -> acc || v.cl_impl = gr) !classes false
+  Refmap.exists (fun _ v -> eq_gr v.cl_impl gr) !classes
 
 let is_instance = function
   | ConstRef c ->
@@ -452,6 +485,14 @@ let is_instance = function
       is_class (IndRef ind)
   | _ -> false
 
+let is_implicit_arg = function
+| Evar_kinds.GoalEvar -> false
+| _ -> true
+  (* match k with *)
+  (*     ImplicitArg (ref, (n, id), b) -> true *)
+  (*   | InternalHole -> true *)
+  (*   | _ -> false *)
+
 
 (* To embed a boolean for resolvability status.
    This is essentially a hack to mark which evars correspond to
@@ -463,42 +504,61 @@ let is_instance = function
  *)
 
 let resolvable = Store.field ()
-open Store.Field
+
+let set_resolvable s b =
+  Store.set s resolvable b
 
 let is_resolvable evi =
-  assert (evi.evar_body = Evar_empty);
-  Option.default true (resolvable.get evi.evar_extra)
+  assert (match evi.evar_body with Evar_empty -> true | _ -> false);
+  Option.default true (Store.get evi.evar_extra resolvable)
 
 let mark_resolvability_undef b evi =
-  let t = resolvable.set b evi.evar_extra in
+  let t = Store.set evi.evar_extra resolvable b in
   { evi with evar_extra = t }
 
 let mark_resolvability b evi =
-  assert (evi.evar_body = Evar_empty);
+  assert (match evi.evar_body with Evar_empty -> true | _ -> false);
   mark_resolvability_undef b evi
 
 let mark_unresolvable evi = mark_resolvability false evi
 let mark_resolvable evi = mark_resolvability true evi
 
-let mark_resolvability b sigma =
-  Evd.fold_undefined (fun ev evi evs ->
-    Evd.add evs ev (mark_resolvability_undef b evi))
-    sigma (Evd.defined_evars sigma)
+open Evar_kinds
+type evar_filter = existential_key -> Evar_kinds.t -> bool
 
-let mark_unresolvables sigma = mark_resolvability false sigma
+let all_evars _ _ = true
+let all_goals _ = function VarInstance _ | GoalEvar -> true | _ -> false
+let no_goals ev evi = not (all_goals ev evi)
+let no_goals_or_obligations _ = function
+  | VarInstance _ | GoalEvar | QuestionMark _ -> false
+  | _ -> true
 
-let has_typeclasses evd =
-  Evd.fold_undefined (fun ev evi has -> has ||
-    (is_resolvable evi && is_class_evar evd evi))
-    evd false
+let mark_resolvability filter b sigma =
+  let map ev evi =
+    if filter ev (snd evi.evar_source) then mark_resolvability_undef b evi
+    else evi
+  in
+  Evd.raw_map_undefined map sigma
+
+let mark_unresolvables ?(filter=all_evars) sigma = mark_resolvability filter false sigma
+let mark_resolvables ?(filter=all_evars) sigma = mark_resolvability filter true sigma
+
+let has_typeclasses filter evd =
+  let check ev evi =
+    filter ev (snd evi.evar_source) && is_resolvable evi && is_class_evar evd evi
+  in
+  Evar.Map.exists check (Evd.undefined_map evd)
 
-let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false)
+let solve_instantiations_problem = ref (fun _ _ _ _ _ _ -> assert false)
 
-type evar_filter = hole_kind -> bool
+let solve_problem env evd filter unique split fail =
+  !solve_instantiations_problem env evd filter unique split fail
 
-let no_goals = function GoalEvar -> false | _ -> true
-let all_evars _ = true
+(** Profiling resolution of typeclasses *)
+(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *)
+(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *)
 
-let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd =
-  if not (has_typeclasses evd) then evd
-  else !solve_instanciations_problem env evd filter split fail
+let resolve_typeclasses ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
+    ?(split=true) ?(fail=true) env evd =
+  if not (has_typeclasses filter evd) then evd
+  else solve_problem env evd filter unique split fail
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 91069b70..1a0b6696 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -1,22 +1,17 @@
 (************************************************************************)
 (*  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 Libnames
-open Decl_kinds
+open Globnames
 open Term
-open Sign
+open Context
 open Evd
 open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Util
 
 type direction = Forward | Backward
 
@@ -38,7 +33,14 @@ type typeclass = {
       Some may be undefinable due to sorting restrictions or simply undefined if 
       no name is provided. The [int option option] indicates subclasses whose hint has
       the given priority. *)
-  cl_projs : (name * (direction * int option) option * constant option) list;
+  cl_projs : (Name.t * (direction * int option) option * constant option) list;
+
+  (** Whether we use matching or full unification during resolution *)
+  cl_strict : bool; 
+
+  (** Whether we can assume that instances are unique, which allows 
+      no backtracking and sharing of resolution. *)
+  cl_unique : bool; 
 }
 
 type instance
@@ -49,64 +51,79 @@ val all_instances : unit -> instance list
 
 val add_class : typeclass -> unit
 
-val add_constant_class : constant -> unit
-
-val add_inductive_class : inductive -> unit
-
-val new_instance : typeclass -> int option -> bool -> global_reference -> instance
+val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> 
+  global_reference -> instance
 val add_instance : instance -> unit
 val remove_instance : instance -> unit
 
 val class_info : global_reference -> typeclass (** raises a UserError if not a class *)
 
 
-(** These raise a UserError if not a class. *)
-val dest_class_app : env -> constr -> typeclass * constr list
+(** These raise a UserError if not a class.
+    Caution: the typeclass structures is not instantiated w.r.t. the universe instance.
+    This is done separately by typeclass_univ_instance. *)
+val dest_class_app : env -> constr -> typeclass puniverses * constr list
+
+(** Get the instantiated typeclass structure for a given universe instance. *)
+val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses
 
 (** Just return None if not a class *)
-val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option
+val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option
   
 val instance_impl : instance -> global_reference
 
+val instance_priority : instance -> int option
+
 val is_class : global_reference -> bool
 val is_instance : global_reference -> bool
 
+val is_implicit_arg : Evar_kinds.t -> bool
+
 (** Returns the term and type for the given instance of the parameters and fields
    of the type class. *)
 
-val instance_constructor : typeclass -> constr list -> constr option * types
+val instance_constructor : typeclass puniverses -> constr list -> 
+  constr option * types
+
+(** Filter which evars to consider for resolution. *)
+type evar_filter = existential_key -> Evar_kinds.t -> bool
+val all_evars : evar_filter
+val all_goals : evar_filter
+val no_goals : evar_filter
+val no_goals_or_obligations : evar_filter
 
 (** Resolvability.
-    Only undefined evars could be marked or checked for resolvability. *)
+    Only undefined evars can be marked or checked for resolvability. *)
 
+val set_resolvable : Evd.Store.t -> bool -> Evd.Store.t
 val is_resolvable : evar_info -> bool
 val mark_unresolvable : evar_info -> evar_info
+val mark_unresolvables : ?filter:evar_filter -> evar_map -> evar_map
+val mark_resolvables   : ?filter:evar_filter -> evar_map -> evar_map
 val mark_resolvable : evar_info -> evar_info
-val mark_unresolvables : evar_map -> evar_map
 val is_class_evar : evar_map -> evar_info -> bool
+val is_class_type : evar_map -> types -> bool
 
-(** Filter which evars to consider for resolution. *)
-type evar_filter = hole_kind -> bool
-val no_goals : evar_filter
-val all_evars : evar_filter
-
-val resolve_typeclasses : ?filter:evar_filter -> ?split:bool -> ?fail:bool ->
-  env -> evar_map -> evar_map
-val resolve_one_typeclass : env -> evar_map -> types -> open_constr
+val resolve_typeclasses : ?filter:evar_filter -> ?unique:bool -> 
+  ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map
+val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> types -> open_constr
 
-val register_set_typeclass_transparency : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) -> unit
+val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t
 val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit
 
-val register_classes_transparent_state : (unit -> transparent_state) -> unit
+val classes_transparent_state_hook : (unit -> transparent_state) Hook.t
 val classes_transparent_state : unit -> transparent_state
 
-val register_add_instance_hint : (constr -> bool (* local? *) -> int option -> unit) -> unit
-val register_remove_instance_hint : (global_reference -> unit) -> unit
-val add_instance_hint : constr -> bool -> int option -> unit
+val add_instance_hint_hook : 
+  (global_reference_or_constr -> global_reference list ->
+   bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t
+val remove_instance_hint_hook : (global_reference -> unit) Hook.t
+val add_instance_hint : global_reference_or_constr -> global_reference list -> 
+  bool -> int option -> Decl_kinds.polymorphic -> unit
 val remove_instance_hint : global_reference -> unit
 
-val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref
-val solve_instanciation_problem : (env -> evar_map -> types -> open_constr) ref
+val solve_instantiations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) ref
+val solve_instantiation_problem : (env -> evar_map -> types -> bool -> open_constr) ref
 
 val declare_instance : int option -> bool -> global_reference -> unit
 
@@ -116,4 +133,4 @@ val declare_instance : int option -> bool -> global_reference -> unit
     subinstances and add only the missing ones. *)
 
 val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) ->
-  (int option * constr) list
+  (global_reference list * int option * constr) list
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index da5dc909..4f88dd86 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.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,26 +8,19 @@
 
 (*i*)
 open Names
-open Decl_kinds
 open Term
-open Sign
+open Context
 open Evd
 open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Compat
-open Util
-open Libnames
+open Constrexpr
+open Globnames
 (*i*)
 
 type contexts = Parameters | Properties
 
 type typeclass_error =
     | NotAClass of constr
-    | UnboundMethod of global_reference * identifier located (* Class name, method *)
-    | NoInstance of identifier located * constr list
-    | UnsatisfiableConstraints of evar_map * (existential_key * hole_kind) option
+    | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *)
     | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
@@ -38,21 +31,4 @@ let not_a_class env c = typeclass_error env (NotAClass c)
 
 let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id))
 
-let no_instance env id args = typeclass_error env (NoInstance (id, args))
-
-let unsatisfiable_constraints env evd ev =
-  match ev with
-  | None ->
-      raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
-  | Some ev ->
-      let loc, kind = Evd.evar_source ev evd in
-	raise (Loc.Exc_located (loc, TypeClassError
-	  (env, UnsatisfiableConstraints (evd, Some (ev, kind)))))
-
 let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m))
-
-let rec unsatisfiable_exception exn =
-  match exn with
-  | TypeClassError (_, UnsatisfiableConstraints _) -> true
-  | Loc.Exc_located(_, e) -> unsatisfiable_exception e
-  | _ -> false
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 6e0fc6ad..dd808771 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -1,42 +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 Loc
 open Names
-open Decl_kinds
 open Term
-open Sign
+open Context
 open Evd
 open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Util
-open Libnames
+open Constrexpr
+open Globnames
 
 type contexts = Parameters | Properties
 
 type typeclass_error =
   | NotAClass of constr
-  | UnboundMethod of global_reference * identifier located (** Class name, method *)
-  | NoInstance of identifier located * constr list
-  | UnsatisfiableConstraints of evar_map * (existential_key * hole_kind) option
+  | UnboundMethod of global_reference * Id.t located (** Class name, method *)
   | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *)
 
 exception TypeClassError of env * typeclass_error
 
 val not_a_class : env -> constr -> 'a
 
-val unbound_method : env -> global_reference -> identifier located -> 'a
-
-val no_instance : env -> identifier located -> constr list -> 'a
-
-val unsatisfiable_constraints : env -> evar_map -> evar option -> 'a
+val unbound_method : env -> global_reference -> Id.t located -> 'a
 
 val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a
 
-val unsatisfiable_exception : exn -> bool
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 9fbfc197..c6209cc3 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -1,44 +1,44 @@
 (************************************************************************)
 (*  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
 open Term
+open Vars
 open Environ
 open Reductionops
 open Type_errors
-open Pretype_errors
 open Inductive
 open Inductiveops
 open Typeops
-open Evd
 open Arguments_renaming
 
 let meta_type evd mv =
   let ty =
     try Evd.meta_ftype evd mv
-    with Not_found -> anomaly ("unknown meta ?"^Nameops.string_of_meta mv) in
+    with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv)) in
   meta_instance evd ty
 
 let constant_type_knowing_parameters env cst jl =
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  type_of_constant_knowing_parameters env (constant_type env cst) paramstyp
+  let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in
+  type_of_constant_knowing_parameters_in env cst paramstyp
 
-let inductive_type_knowing_parameters env ind jl =
-  let (mib,mip) = lookup_mind_specif env ind in
-  let paramstyp = Array.map (fun j -> j.uj_type) jl in
-  Inductive.type_of_inductive_knowing_parameters env mip paramstyp
+let inductive_type_knowing_parameters env (ind,u) jl =
+  let mspec = lookup_mind_specif env ind in
+  let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in
+  Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp
 
 let e_type_judgment env evdref j =
   match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with
     | Sort s -> {utj_val = j.uj_val; utj_type = s }
     | Evar ev ->
-        let (evd,s) = Evarutil.define_evar_as_sort !evdref ev in
+        let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in
         evdref := evd; { utj_val = j.uj_val; utj_type = s }
     | _ -> error_not_type env j
 
@@ -69,17 +69,17 @@ let e_judge_of_apply env evdref funj argjv =
   in
   apply_rec 1 funj.uj_type (Array.to_list argjv)
 
-let e_check_branch_types env evdref ind cj (lfj,explft) =
-  if Array.length lfj <> Array.length explft then
+let e_check_branch_types env evdref (ind,u) cj (lfj,explft) =
+  if not (Int.equal (Array.length lfj) (Array.length explft)) then
     error_number_branches env cj (Array.length explft);
   for i = 0 to Array.length explft - 1 do
     if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then
-      error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
+      error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i)
   done
 
-let rec max_sort l =
-  if List.mem InType l then InType else
-  if List.mem InSet l then InSet else InProp
+let max_sort l =
+  if Sorts.List.mem InType l then InType else
+  if Sorts.List.mem InSet l then InSet else InProp
 
 let e_is_correct_arity env evdref c pj ind specif params =
   let arsign = make_arity_signature env true (make_ind_family (ind,params)) in
@@ -92,10 +92,11 @@ let e_is_correct_arity env evdref c pj ind specif params =
         if not (Evarconv.e_cumul env evdref a1 a1') then error ();
         srec (push_rel (na1,None,a1) env) t ar'
     | Sort s, [] ->
-        if not (List.mem (family_of_sort s) allowed_sorts) then error ()
+        if not (Sorts.List.mem (Sorts.family s) allowed_sorts)
+        then error ()
     | Evar (ev,_), [] ->
-        let s = Termops.new_sort_in_family (max_sort allowed_sorts) in
-        evdref := Evd.define ev (mkSort s) !evdref
+        let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in
+        evdref := Evd.define ev (mkSort s) evd
     | _, (_,Some _,_ as d)::ar' ->
         srec (push_rel d env) (lift 1 pt') ar'
     | _ ->
@@ -104,13 +105,13 @@ let e_is_correct_arity env evdref c pj ind specif params =
   srec env pj.uj_type (List.rev arsign)
 
 let e_type_case_branches env evdref (ind,largs) pj c =
-  let specif = lookup_mind_specif env ind in
+  let specif = lookup_mind_specif env (fst ind) in
   let nparams = inductive_params specif in
-  let (params,realargs) = list_chop nparams largs in
+  let (params,realargs) = List.chop nparams largs in
   let p = pj.uj_val in
   let univ = e_is_correct_arity env evdref c pj ind specif params in
   let lc = build_branches_type ind specif params p in
-  let n = (snd specif).Declarations.mind_nrealargs_ctxt in
+  let n = (snd specif).Declarations.mind_nrealargs in
   let ty =
     whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in
   (lc, ty, univ)
@@ -125,12 +126,13 @@ let e_judge_of_case env evdref ci pj cj lfj =
   { uj_val  = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj);
     uj_type = rslty }
 
+(* FIXME: might depend on the level of actual parameters!*)
 let check_allowed_sort env sigma ind c p =
   let pj = Retyping.get_judgment_of env sigma p in
   let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in
-  let specif = Global.lookup_inductive ind in
+  let specif = Global.lookup_inductive (fst ind) in
   let sorts = elim_sorts specif in
-  if not (List.exists ((=) ksort) sorts) then
+  if not (List.exists ((==) ksort) sorts) then
     let s = inductive_sort_family (snd specif) in
     error_elim_arity env ind sorts c pj
       (Some(ksort,s,error_elim_explain ksort s))
@@ -195,22 +197,26 @@ let rec execute env evdref cstr =
 	judge_of_prop_contents c
 
     | Sort (Type u) ->
-	judge_of_type u
+        judge_of_type u
+
+    | Proj (p, c) -> 
+        let cj = execute env evdref c in
+	  judge_of_projection env p (Evarutil.j_nf_evar !evdref cj)
 
     | App (f,args) ->
         let jl = execute_array env evdref args in
 	let j =
 	  match kind_of_term f with
-	    | Ind ind ->
+	    | Ind ind when Environ.template_polymorphic_pind ind env ->
 		(* Sort-polymorphism of inductive types *)
 		make_judge f
 		  (inductive_type_knowing_parameters env ind
-		    (jv_nf_evar !evdref jl))
-	    | Const cst ->
+		    (Evarutil.jv_nf_evar !evdref jl))
+	    | Const cst when Environ.template_polymorphic_pconstant cst env ->
 		(* Sort-polymorphism of inductive types *)
 		make_judge f
 		  (constant_type_knowing_parameters env cst
-		    (jv_nf_evar !evdref jl))
+		    (Evarutil.jv_nf_evar !evdref jl))
 	    | _ ->
 		execute env evdref f
 	in
@@ -235,7 +241,7 @@ let rec execute env evdref cstr =
         let j1 = execute env evdref c1 in
         let j2 = execute env evdref c2 in
         let j2 = e_type_judgment env evdref j2 in
-        let _ =  judge_of_cast env j1 DEFAULTcast j2 in
+        let _ =  e_judge_of_cast env evdref j1 DEFAULTcast j2 in
         let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
         let j3 = execute env1 evdref c3 in
         judge_of_letin env name j1 j2 j3
@@ -257,40 +263,37 @@ and execute_recdef env evdref (names,lar,vdef) =
 
 and execute_array env evdref = Array.map (execute env evdref)
 
-let check env evd c t =
-  let evdref = ref evd in
+let check env evdref c t =
   let j = execute env evdref c in
   if not (Evarconv.e_cumul env evdref j.uj_type t) then
-    error_actual_type env j (nf_evar evd t)
+    error_actual_type env j (nf_evar !evdref t)
 
 (* Type of a constr *)
 
 let type_of env evd c =
   let j = execute env (ref evd) c in
-  (* We are outside the kernel: we take fresh universes *)
-  (* to avoid tactics and co to refresh universes themselves *)
-  Termops.refresh_universes j.uj_type
+    j.uj_type
 
 (* Sort of a type *)
 
-let sort_of env evd c =
-  let evdref = ref evd in
+let sort_of env evdref c =
   let j = execute env evdref c in
   let a = e_type_judgment env evdref j in
   a.utj_type
 
 (* Try to solve the existential variables by typing *)
 
-let e_type_of env evd c =
+let e_type_of ?(refresh=false) env evd c =
   let evdref = ref evd in
   let j = execute env evdref c in
   (* side-effect on evdref *)
-  !evdref, Termops.refresh_universes j.uj_type
+    if refresh then
+      Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type
+    else !evdref, j.uj_type
 
-let solve_evars env evd c =
-  let evdref = ref evd in
+let solve_evars env evdref c =
   let c = (execute env evdref c).uj_val in
   (* side-effect on evdref *)
-  !evdref, nf_evar !evdref c
+  nf_evar !evdref c
 
 let _ = Evarconv.set_solve_evars solve_evars
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 5aa0a2d4..c933106d 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.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        *)
@@ -12,27 +12,28 @@ open Environ
 open Evd
 
 (** This module provides the typing machine with existential variables
-   (but without universes). *)
+    and universes. *)
 
 (** Typecheck a term and return its type *)
 val type_of : env -> evar_map -> constr -> types
 
-(** Typecheck a term and return its type + updated evars *)
-val e_type_of : env -> evar_map -> constr -> evar_map * types
+(** Typecheck a term and return its type + updated evars, optionally refreshing
+    universes *)
+val e_type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types
 
 (** Typecheck a type and return its sort *)
-val sort_of : env -> evar_map -> types -> sorts
+val sort_of : env -> evar_map ref -> types -> sorts
 
 (** Typecheck a term has a given type (assuming the type is OK) *)
-val check   : env -> evar_map -> constr -> types -> unit
+val check   : env -> evar_map ref -> constr -> types -> unit
 
 (** Returns the instantiated type of a metavariable *)
 val meta_type : evar_map -> metavariable -> types
 
 (** Solve existential variables using typing *)
-val solve_evars : env -> evar_map -> constr -> evar_map * constr
+val solve_evars : env -> evar_map ref -> constr -> constr
 
 (** Raise an error message if incorrect elimination for this inductive *)
 (** (first constr is term to match, second is return predicate) *)
-val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr ->
+val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr ->
   unit
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index d6b1e2e4..203b1ec8 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -1,29 +1,51 @@
 (************************************************************************)
 (*  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 Pp
 open Util
 open Names
-open Nameops
 open Term
+open Vars
 open Termops
 open Namegen
-open Sign
 open Environ
 open Evd
 open Reduction
 open Reductionops
-open Glob_term
 open Evarutil
+open Evarsolve
 open Pretype_errors
 open Retyping
-open Coercion.Default
+open Coercion
 open Recordops
+open Locus
+open Locusops
+open Find_subterm
+
+let keyed_unification = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname = "Unification is keyed";
+  Goptions.optkey = ["Keyed";"Unification"];
+  Goptions.optread = (fun () -> !keyed_unification);
+  Goptions.optwrite = (fun a -> keyed_unification:=a);
+}
+
+let debug_unification = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Print states sent to tactic unification";
+  Goptions.optkey = ["Debug";"Tactic";"Unification"];
+  Goptions.optread = (fun () -> !debug_unification);
+  Goptions.optwrite = (fun a -> debug_unification:=a);
+}
 
 let occur_meta_or_undefined_evar evd c =
   let rec occrec c = match kind_of_term c with
@@ -33,7 +55,6 @@ let occur_meta_or_undefined_evar evd c =
         | Evar_defined c ->
             occrec c; Array.iter occrec args
         | Evar_empty -> raise Occur)
-    | Sort s when is_sort_variable evd s -> raise Occur
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur | Not_found -> true
 
@@ -42,48 +63,60 @@ let occur_meta_evd sigma mv c =
     (* Note: evars are not instantiated by terms with metas *)
     let c = whd_evar sigma (whd_meta sigma c) in
     match kind_of_term c with
-    | Meta mv' when mv = mv' -> raise Occur
+    | Meta mv' when Int.equal mv mv' -> raise Occur
     | _ -> iter_constr occrec c
   in try occrec c; false with Occur -> true
 
 (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
    gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
 
-let abstract_scheme env c l lname_typ =
+let abstract_scheme env evd c l lname_typ =
   List.fold_left2
-    (fun t (locc,a) (na,_,ta) ->
+    (fun (t,evd) (locc,a) (na,_,ta) ->
        let na = match kind_of_term a with Var id -> Name id | _ -> na in
 (* [occur_meta ta] test removed for support of eelim/ecase but consequences
    are unclear...
        if occur_meta ta then error "cannot find a type for the generalisation"
-       else *) if occur_meta a then mkLambda_name env (na,ta,t)
-       else mkLambda_name env (na,ta,subst_closed_term_occ locc a t))
-    c
+       else *) 
+       if occur_meta a then mkLambda_name env (na,ta,t), evd
+       else
+	 let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in
+	   mkLambda_name env (na,ta,t'), evd')
+    (c,evd)
     (List.rev l)
     lname_typ
 
+(* Precondition: resulting abstraction is expected to be of type [typ] *)
+
 let abstract_list_all env evd typ c l =
   let ctxt,_ = splay_prod_n env evd (List.length l) typ in
-  let l_with_all_occs = List.map (function a -> (all_occurrences,a)) l in
-  let p = abstract_scheme env c l_with_all_occs ctxt in
-  try
-    if is_conv_leq env evd (Typing.type_of env evd p) typ then p
-    else error "abstract_list_all"
-  with UserError _ | Type_errors.TypeError _ ->
-    error_cannot_find_well_typed_abstraction env evd p l
+  let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in
+  let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in
+  let evd,typp =
+    try Typing.e_type_of env evd p
+    with
+    | UserError _ ->
+        error_cannot_find_well_typed_abstraction env evd p l None
+    | Type_errors.TypeError (env',x) ->
+        error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in
+  evd,(p,typp)
 
 let set_occurrences_of_last_arg args =
-  Some all_occurrences :: List.tl (array_map_to_list (fun _ -> None) args)
+  Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
 
 let abstract_list_all_with_dependencies env evd typ c l =
-  let evd,ev = new_evar evd env typ in
+  let evd,ev = new_evar env evd typ in
   let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in
-  let argoccs = set_occurrences_of_last_arg (snd ev') in
+  let n = List.length l in
+  let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
   let evd,b =
     Evarconv.second_order_matching empty_transparent_state
       env evd ev' argoccs c in
-  if b then nf_evar evd (existential_value evd (destEvar ev))
-  else error "Cannot find a well-typed abstraction."
+  if b then
+    let p = nf_evar evd (existential_value evd (destEvar ev)) in
+      evd, p
+  else error_cannot_find_well_typed_abstraction env evd 
+    (nf_evar evd c) l None
 
 (**)
 
@@ -103,15 +136,15 @@ let extract_instance_status = function
   | CUMUL -> add_type_status (IsSubType, IsSuperType)
   | CONV -> add_type_status (Conv, Conv)
 
-let rec assoc_pair x = function
-    [] -> raise Not_found
-  | (a,b,_)::l -> if compare a x = 0 then b else assoc_pair x l
-
 let rec subst_meta_instances bl c =
   match kind_of_term c with
-    | Meta i -> (try assoc_pair i bl with Not_found -> c)
+    | Meta i ->
+      let select (j,_,_) = Int.equal i j in
+      (try pi2 (List.find select bl) with Not_found -> c)
     | _ -> map_constr (subst_meta_instances bl) c
 
+(** [env] should be the context in which the metas live *)
+
 let pose_all_metas_as_evars env evd t =
   let evdref = ref evd in
   let rec aux t = match kind_of_term t with
@@ -120,8 +153,9 @@ let pose_all_metas_as_evars env evd t =
        | Some ({rebus=c},_) -> c
        | None ->
         let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in
-        let ty = if mvs = Evd.Metaset.empty then ty else aux ty in
-        let ev = Evarutil.e_new_evar evdref env ~src:(dummy_loc,GoalEvar) ty in
+        let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in
+        let src = Evd.evar_source_of_meta mv !evdref in
+        let ev = Evarutil.e_new_evar env evdref ~src ty in
         evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref;
         ev)
   | _ ->
@@ -133,14 +167,18 @@ let pose_all_metas_as_evars env evd t =
 let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) =
   match kind_of_term f with
     | Meta k ->
-	let sigma,c = pose_all_metas_as_evars env sigma c in
+	(* We enforce that the Meta does not depend on the [nb]
+	   extra assumptions added by unification to the context *)
+        let env' = pop_rel_context nb env in
+	let sigma,c = pose_all_metas_as_evars env' sigma c in
 	let c = solve_pattern_eqn env l c in
 	let pb = (Conv,TypeNotProcessed) in
 	  if noccur_between 1 nb c then
             sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst
 	  else error_cannot_unify_local env sigma (applist (f, l),c,c)
     | Evar ev ->
-	let sigma,c = pose_all_metas_as_evars env sigma c in
+        let env' = pop_rel_context nb env in
+	let sigma,c = pose_all_metas_as_evars env' sigma c in
 	sigma,metasubst,(env,ev,solve_pattern_eqn env l c)::evarsubst
     | _ -> assert false
 
@@ -166,18 +204,23 @@ let unify_r2l x = x
 let sort_eqns = unify_r2l
 *)
 
-(* Option introduced and activated in Coq 8.3 *)
-let global_evars_pattern_unification_flag = ref true
+let global_pattern_unification_flag = ref true
+
+(* Compatibility option introduced and activated in Coq 8.3 whose
+   syntax is now deprecated. *)
 
 open Goptions
 let _ =
   declare_bool_option
     { optsync  = true;
-      optdepr  = false;
+      optdepr  = true;
       optname  = "pattern-unification for existential variables in tactics";
       optkey   = ["Tactic";"Evars";"Pattern";"Unification"];
-      optread  = (fun () -> !global_evars_pattern_unification_flag);
-      optwrite = (:=) global_evars_pattern_unification_flag }
+      optread  = (fun () -> !global_pattern_unification_flag);
+      optwrite = (:=) global_pattern_unification_flag }
+
+(* Compatibility option superseding the previous one, introduced and
+   activated in Coq 8.4 *)
 
 let _ =
   declare_bool_option
@@ -185,10 +228,10 @@ let _ =
       optdepr  = false;
       optname  = "pattern-unification for existential variables in tactics";
       optkey   = ["Tactic";"Pattern";"Unification"];
-      optread  = (fun () -> !global_evars_pattern_unification_flag);
-      optwrite = (:=) global_evars_pattern_unification_flag }
+      optread  = (fun () -> !global_pattern_unification_flag);
+      optwrite = (:=) global_pattern_unification_flag }
 
-type unify_flags = {
+type core_unify_flags = {
   modulo_conv_on_closed_terms : Names.transparent_state option;
     (* What this flag controls was activated with all constants transparent, *)
     (* even for auto, since Coq V5.10 *)
@@ -197,37 +240,33 @@ type unify_flags = {
     (* This refinement of the conversion on closed terms is activable *)
     (* (and activated for apply, rewrite but not auto since Feb 2008 for 8.2) *)
 
+  use_evars_eagerly_in_conv_on_closed_terms : bool;
+
   modulo_delta : Names.transparent_state;
     (* This controls which constants are unfoldable; this is on for apply *)
     (* (but not simple apply) since Feb 2008 for 8.2 *)
 
   modulo_delta_types : Names.transparent_state;
 
-  modulo_delta_in_merge : Names.transparent_state option;
-    (* This controls whether unfoldability is different when trying to unify *)
-    (* several instances of the same metavariable *)
-    (* Typical situation is when we give a pattern to be matched *)
-    (* syntactically against a subterm but we want the metas of the *)
-    (* pattern to be modulo convertibility *)
-
   check_applied_meta_types : bool;
     (* This controls whether meta's applied to arguments have their *)
     (* type unified with the type of their instance *)
 
-  resolve_evars : bool;
-    (* This says if type classes instances resolution must be used to infer *)
-    (* the remaining evars *)
-
   use_pattern_unification : bool;
-    (* This says if type classes instances resolution must be used to infer *)
-    (* the remaining evars *)
+    (* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *)
+    (* This says if pattern unification is tried; can be overwritten with *)
+    (* option "Set Tactic Pattern Unification" *)
 
   use_meta_bound_pattern_unification : bool;
-    (* This solves pattern "?n x1 ... xn = t" when the xi are distinct rels *)
-    (* This allows for instance to unify "forall x:A, B(x)" with "A' -> B'" *)
+    (* This is implied by use_pattern_unification (though deactivated *)
+    (* by unsetting Tactic Pattern Unification); has no particular *)
+    (* reasons to be set differently than use_pattern_unification *)
+    (* except for compatibility of "auto". *)
     (* This was on for all tactics, including auto, since Sep 2006 for 8.1 *)
+    (* This allowed for instance to unify "forall x:?A, ?B x" with "A' -> B'" *)
+    (* when ?B is a Meta. *)
 
-  frozen_evars : ExistentialSet.t;
+  frozen_evars : Evar.Set.t;
     (* Evars of this set are considered axioms and never instantiated *)
     (* Useful e.g. for autorewrite *)
 
@@ -240,43 +279,86 @@ type unify_flags = {
 
   modulo_eta : bool;
     (* Support eta in the reduction *)
+}
+
+type unify_flags = {
+  core_unify_flags : core_unify_flags;
+    (* Governs unification of problems of the form "t(?x) = u(?x)" in apply *)
+
+  merge_unify_flags : core_unify_flags;
+    (* These are the flags to be used when trying to unify *)
+    (* several instances of the same metavariable *)
+    (* Typical situation is when we give a pattern to be matched *)
+    (* syntactically against a subterm but we want the metas of the *)
+    (* pattern to be modulo convertibility *)
+
+  subterm_unify_flags : core_unify_flags;
+    (* Governs unification of problems of the form "?X a1..an = u" in apply, *)
+    (* hence in rewrite and elim *)
 
-  allow_K_in_toplevel_higher_order_unification : bool
-    (* This is used only in second/higher order unification when looking for *)
-    (* subterms (rewrite and elim) *)
+  allow_K_in_toplevel_higher_order_unification : bool;
+    (* Tells in second-order abstraction over subterms which have not *)
+    (* been found in term are allowed (used for rewrite, elim, or *)
+    (* apply with a lemma whose type has the form "?X a1 ... an") *)
+
+  resolve_evars : bool
+    (* This says if type classes instances resolution must be used to infer *)
+    (* the remaining evars *)
 }
 
 (* Default flag for unifying a type against a type (e.g. apply) *)
 (* We set all conversion flags (no flag should be modified anymore) *)
-let default_unify_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
+let default_core_unify_flags () =
+  let ts = Names.full_transparent_state in {
+  modulo_conv_on_closed_terms = Some ts;
   use_metas_eagerly_in_conv_on_closed_terms = true;
-  modulo_delta = full_transparent_state;
-  modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = ts;
+  modulo_delta_types = ts;
   check_applied_meta_types = true;
-  resolve_evars = false;
   use_pattern_unification = true;
   use_meta_bound_pattern_unification = true;
-  frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.empty;
   restrict_conv_on_strict_subterms = false;
   modulo_betaiota = true;
   modulo_eta = true;
-  allow_K_in_toplevel_higher_order_unification = false
-      (* in fact useless when not used in w_unify_to_subterm_list *)
+ }
+
+(* Default flag for first-order or second-order unification of a type *)
+(* against another type (e.g. apply)                                  *)
+(* We set all conversion flags (no flag should be modified anymore)   *)
+let default_unify_flags () =
+  let flags = default_core_unify_flags () in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = { flags with modulo_delta = var_full_transparent_state };
+  allow_K_in_toplevel_higher_order_unification = false; (* Why not? *)
+  resolve_evars = false
+}
+
+let set_no_delta_core_flags flags = { flags with
+  modulo_conv_on_closed_terms = None;
+  modulo_delta = empty_transparent_state;
+  check_applied_meta_types = false;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = true;
+  modulo_betaiota = false
 }
 
-let set_merge_flags flags =
-  match flags.modulo_delta_in_merge with
-  | None -> flags
-  | Some ts ->
-    { flags with modulo_delta = ts; modulo_conv_on_closed_terms = Some ts }
+let set_no_delta_flags flags = {
+  core_unify_flags = set_no_delta_core_flags flags.core_unify_flags;
+  merge_unify_flags = set_no_delta_core_flags flags.merge_unify_flags;
+  subterm_unify_flags = set_no_delta_core_flags flags.subterm_unify_flags;
+  allow_K_in_toplevel_higher_order_unification =
+      flags.allow_K_in_toplevel_higher_order_unification;
+  resolve_evars = flags.resolve_evars
+}
 
 (* Default flag for the "simple apply" version of unification of a *)
 (* type against a type (e.g. apply) *)
-(* We set only the flags available at the time the new "apply" extends *)
+(* We set only the flags available at the time the new "apply" extended *)
 (* out of "simple apply" *)
-let default_no_delta_unify_flags = { default_unify_flags with
+let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with
   modulo_delta = empty_transparent_state;
   check_applied_meta_types = false;
   use_pattern_unification = false;
@@ -284,56 +366,133 @@ let default_no_delta_unify_flags = { default_unify_flags with
   modulo_betaiota = false;
 }
 
+let default_no_delta_unify_flags () =
+  let flags = default_no_delta_core_unify_flags () in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = flags;
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = false
+}
+
 (* Default flags for looking for subterms in elimination tactics *)
 (* Not used in practice at the current date, to the exception of *)
 (* allow_K) because only closed terms are involved in *)
 (* induction/destruct/case/elim and w_unify_to_subterm_list does not *)
 (* call w_unify for induction/destruct/case/elim  (13/6/2011) *)
-let elim_flags = { default_unify_flags with
-  restrict_conv_on_strict_subterms = false; (* ? *)
+let elim_core_flags sigma = { (default_core_unify_flags ()) with
   modulo_betaiota = false;
-  allow_K_in_toplevel_higher_order_unification = true
+  frozen_evars =
+    fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
+      sigma Evar.Set.empty;
 }
 
-let elim_no_delta_flags = { elim_flags with
+let elim_flags_evars sigma =
+  let flags = elim_core_flags sigma in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = { flags with modulo_delta = empty_transparent_state };
+  allow_K_in_toplevel_higher_order_unification = true;
+  resolve_evars = false
+}
+
+let elim_flags () = elim_flags_evars Evd.empty
+
+let elim_no_delta_core_flags () = { (elim_core_flags Evd.empty) with
   modulo_delta = empty_transparent_state;
   check_applied_meta_types = false;
   use_pattern_unification = false;
+  modulo_betaiota = false;
 }
 
-let set_no_head_reduction flags =
-  { flags with restrict_conv_on_strict_subterms = true }
+let elim_no_delta_flags () =
+  let flags = elim_no_delta_core_flags () in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = flags;
+  allow_K_in_toplevel_higher_order_unification = true;
+  resolve_evars = false
+}
+
+(* On types, we don't restrict unification, but possibly for delta *)
+let set_flags_for_type flags = { flags with
+  modulo_delta = flags.modulo_delta_types;
+  modulo_conv_on_closed_terms = Some flags.modulo_delta_types;
+  use_pattern_unification = true;
+  modulo_betaiota = true;
+  modulo_eta = true;
+}
 
 let use_evars_pattern_unification flags =
-  !global_evars_pattern_unification_flag && flags.use_pattern_unification
+  !global_pattern_unification_flag && flags.use_pattern_unification
   && Flags.version_strictly_greater Flags.V8_2
 
 let use_metas_pattern_unification flags nb l =
-  !global_evars_pattern_unification_flag && flags.use_pattern_unification
+  !global_pattern_unification_flag && flags.use_pattern_unification
   || (Flags.version_less_or_equal Flags.V8_3 || 
       flags.use_meta_bound_pattern_unification) &&
-     array_for_all (fun c -> isRel c && destRel c <= nb) l
-
-let expand_key env = function
-  | Some (ConstKey cst) -> constant_opt_value env cst
-  | Some (VarKey id) -> (try named_body id env with Not_found -> None)
-  | Some (RelKey _) -> None
+     Array.for_all (fun c -> isRel c && destRel c <= nb) l
+
+type key = 
+  | IsKey of Closure.table_key
+  | IsProj of projection * constr
+
+let expand_table_key env = function
+  | ConstKey cst -> constant_opt_value_in env cst
+  | VarKey id -> (try named_body id env with Not_found -> None)
+  | RelKey _ -> None
+
+let unfold_projection env p stk =
+  (match try Some (lookup_projection p env) with Not_found -> None with
+  | Some pb -> 
+    let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, 
+			p, Cst_stack.empty) in
+      s :: stk
+  | None -> assert false)
+
+let expand_key ts env sigma = function
+  | Some (IsKey k) -> expand_table_key env k
+  | Some (IsProj (p, c)) -> 
+    let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma 
+				Cst_stack.empty (c, unfold_projection env p [])))
+    in if Term.eq_constr (mkProj (p, c)) red then None else Some red
   | None -> None
 
-let subterm_restriction is_subterm flags =
-  not is_subterm && flags.restrict_conv_on_strict_subterms
+  
+type unirec_flags = {
+  at_top: bool;
+  with_types: bool;
+  with_cs : bool;
+}
+
+let subterm_restriction opt flags =
+  not opt.at_top && flags.restrict_conv_on_strict_subterms
 
-let key_of b flags f =
+let key_of env b flags f =
   if subterm_restriction b flags then None else
   match kind_of_term f with
-  | Const cst when is_transparent (ConstKey cst) &&
-        Cpred.mem cst (snd flags.modulo_delta) ->
-      Some (ConstKey cst)
-  | Var id when is_transparent (VarKey id) &&
-        Idpred.mem id (fst flags.modulo_delta) ->
-      Some (VarKey id)
+  | Const (cst, u) when is_transparent env (ConstKey cst) &&
+      (Cpred.mem cst (snd flags.modulo_delta)
+       || Environ.is_projection cst env) ->
+      Some (IsKey (ConstKey (cst, u)))
+  | Var id when is_transparent env (VarKey id) && 
+      Id.Pred.mem id (fst flags.modulo_delta) ->
+    Some (IsKey (VarKey id))
+  | Proj (p, c) when Projection.unfolded p
+      || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) ->
+    Some (IsProj (p, c))
   | _ -> None
+  
 
+let translate_key = function
+  | ConstKey (cst,u) -> ConstKey cst
+  | VarKey id -> VarKey id
+  | RelKey n -> RelKey n
+
+let translate_key = function
+  | IsKey k -> translate_key k    
+  | IsProj (c, _) -> ConstKey (Projection.constant c)
+  
 let oracle_order env cf1 cf2 =
   match cf1 with
   | None ->
@@ -343,57 +502,151 @@ let oracle_order env cf1 cf2 =
   | Some k1 ->
       match cf2 with
       | None -> Some true
-      | Some k2 -> Some (Conv_oracle.oracle_order false k1 k2)
+      | Some k2 ->
+	match k1, k2 with
+	| IsProj (p, _), IsKey (ConstKey (p',_)) 
+	  when eq_constant (Projection.constant p) p' -> 
+	  Some (not (Projection.unfolded p))
+	| IsKey (ConstKey (p,_)), IsProj (p', _) 
+	  when eq_constant p (Projection.constant p') -> 
+	  Some (Projection.unfolded p')
+	| _ ->
+          Some (Conv_oracle.oracle_order (fun x -> x)
+		  (Environ.oracle env) false (translate_key k1) (translate_key k2))
+
+let is_rigid_head flags t =
+  match kind_of_term t with
+  | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta))
+  | Ind (i,u) -> true
+  | Construct _ -> true
+  | Fix _ | CoFix _ -> true
+  | _ -> false
 
+let force_eqs c = 
+  Universes.Constraints.fold
+    (fun ((l,d,r) as c) acc -> 
+      let c' = if d == Universes.ULub then (l,Universes.UEq,r) else c in
+	Universes.Constraints.add c' acc) 
+    c Universes.Constraints.empty
+
+let constr_cmp pb sigma flags t u =
+  let b, cstrs = 
+    if pb == Reduction.CONV then Universes.eq_constr_universes t u
+    else Universes.leq_constr_universes t u
+  in 
+    if b then 
+      try Evd.add_universe_constraints sigma cstrs, b
+      with Univ.UniverseInconsistency _ -> sigma, false
+      | Evd.UniversesDiffer -> 
+	if is_rigid_head flags t then 
+	  try Evd.add_universe_constraints sigma (force_eqs cstrs), b
+	  with Univ.UniverseInconsistency _ -> sigma, false
+	else sigma, false
+    else sigma, b
+    
 let do_reduce ts (env, nb) sigma c =
-  let (t, stack') = whd_betaiota_deltazeta_for_iota_state ts env sigma (c, empty_stack) in
-  let l = list_of_stack stack' in
-    applist (t, l)
+  Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty)))
 
 let use_full_betaiota flags =
   flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3
 
 let isAllowedEvar flags c = match kind_of_term c with
-  | Evar (evk,_) -> not (ExistentialSet.mem evk flags.frozen_evars)
+  | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars)
   | _ -> false
 
-let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN =
-  match subst_defined_metas metasubst tyM with
-  | None -> ()
+let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN =
+  match subst_defined_metas_evars (metasubst,[]) tyM with
+  | None -> sigma
   | Some m ->
-  match subst_defined_metas metasubst tyN with
-  | None -> ()
+  match subst_defined_metas_evars (metasubst,[]) tyN with
+  | None -> sigma
   | Some n ->
-      if not (is_trans_fconv CONV full_transparent_state env sigma m n)
-         && is_ground_term sigma m && is_ground_term sigma n
-      then
-	error_cannot_unify env sigma (m,n)
+    if is_ground_term sigma m && is_ground_term sigma n then
+      let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in
+	if b then sigma
+	else error_cannot_unify env sigma (m,n)
+    else sigma
+
+
+let rec is_neutral env ts t =
+  let (f, l) = decompose_appvect t in
+    match kind_of_term f with
+    | Const (c, u) ->
+      not (Environ.evaluable_constant c env) ||
+      not (is_transparent env (ConstKey c)) ||
+      not (Cpred.mem c (snd ts))
+    | Var id -> 
+      not (Environ.evaluable_named id env) ||
+      not (is_transparent env (VarKey id)) ||
+      not (Id.Pred.mem id (fst ts))
+    | Rel n -> true
+    | Evar _ | Meta _ -> true
+    | Case (_, p, c, cl) -> is_neutral env ts c
+    | Proj (p, c) -> is_neutral env ts c
+    | _ -> false
+
+let is_eta_constructor_app env ts f l1 term =
+  match kind_of_term f with
+  | Construct (((_, i as ind), j), u) when i == 0 && j == 1 ->
+    let mib = lookup_mind (fst ind) env in
+      (match mib.Declarations.mind_record with
+      | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite &&
+          Array.length projs == Array.length l1 - mib.Declarations.mind_nparams ->
+	(** Check that the other term is neutral *)
+	is_neutral env ts term
+      | _ -> false)
+  | _ -> false
 
-let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n =
-  let rec unirec_rec (curenv,nb as curenvnb) pb b wt ((sigma,metasubst,evarsubst) as substn) curm curn =
+let eta_constructor_app env f l1 term =
+  match kind_of_term f with
+  | Construct (((_, i as ind), j), u) ->
+    let mib = lookup_mind (fst ind) env in
+      (match mib.Declarations.mind_record with
+      | Some (Some (_, projs, _)) ->
+        let npars = mib.Declarations.mind_nparams in
+	let pars, l1' = Array.chop npars l1 in
+	let arg = Array.append pars [|term|] in
+	let l2 = Array.map (fun p -> mkApp (mkConstU (p,u), arg)) projs in
+	  l1', l2
+      | _ -> assert false)
+  | _ -> assert false
+
+let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n =
+  let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn) curm curn =
     let cM = Evarutil.whd_head_evar sigma curm
     and cN = Evarutil.whd_head_evar sigma curn in
+    let () = 
+      if !debug_unification then
+	msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN)
+    in 
       match (kind_of_term cM,kind_of_term cN) with
 	| Meta k1, Meta k2 ->
-            if k1 = k2 then substn else
+            if Int.equal k1 k2 then substn else
 	    let stM,stN = extract_instance_status pb in
-            if wt && flags.check_applied_meta_types then
-              (let tyM = Typing.meta_type sigma k1 in
-               let tyN = Typing.meta_type sigma k2 in
-               check_compatibility curenv substn tyM tyN);
+            let sigma = 
+	      if opt.with_types && flags.check_applied_meta_types then
+		let tyM = Typing.meta_type sigma k1 in
+		let tyN = Typing.meta_type sigma k2 in
+		let l, r = if k2 < k1 then tyN, tyM else tyM, tyN in
+		  check_compatibility curenv CUMUL flags substn l r
+	      else sigma
+	    in
 	    if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst
 	    else sigma,(k2,cM,stM)::metasubst,evarsubst
 	| Meta k, _
             when not (dependent cM cN) (* helps early trying alternatives *) ->
-            if wt && flags.check_applied_meta_types then
-              (try
-                 let tyM = Typing.meta_type sigma k in
-                 let tyN = get_type_of curenv sigma cN in
-                 check_compatibility curenv substn tyM tyN
-               with Anomaly _ (* Hack *) ->
-                 (* Renounce, maybe metas/evars prevents typing *) ());
+            let sigma = 
+	      if opt.with_types && flags.check_applied_meta_types then
+		(try
+                   let tyM = Typing.meta_type sigma k in
+                   let tyN = get_type_of curenv ~lax:true sigma cN in
+                     check_compatibility curenv CUMUL flags substn tyN tyM
+		 with RetypeError _ ->
+                   (* Renounce, maybe metas/evars prevents typing *) sigma)
+	      else sigma
+	    in
 	    (* Here we check that [cN] does not contain any local variables *)
-	    if nb = 0 then
+	    if Int.equal nb 0 then
               sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst
             else if noccur_between 1 nb cN then
               (sigma,
@@ -402,15 +655,18 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
 	    else error_cannot_unify_local curenv sigma (m,n,cN)
 	| _, Meta k
             when not (dependent cN cM) (* helps early trying alternatives *) ->
-            if wt && flags.check_applied_meta_types then
+          let sigma = 
+	    if opt.with_types && flags.check_applied_meta_types then
               (try
-                 let tyM = get_type_of curenv sigma cM in
+                 let tyM = get_type_of curenv ~lax:true sigma cM in
                  let tyN = Typing.meta_type sigma k in
-                 check_compatibility curenv substn tyM tyN
-               with Anomaly _ (* Hack *) ->
-                 (* Renounce, maybe metas/evars prevents typing *) ());
+                   check_compatibility curenv CUMUL flags substn tyM tyN
+               with RetypeError _ ->
+                 (* Renounce, maybe metas/evars prevents typing *) sigma)
+	    else sigma
+	  in
 	    (* Here we check that [cM] does not contain any local variables *)
-	    if nb = 0 then
+	    if Int.equal nb 0 then
               (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst)
 	    else if noccur_between 1 nb cM
 	    then
@@ -418,125 +674,205 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
               evarsubst)
 	    else error_cannot_unify_local curenv sigma (m,n,cM)
 	| Evar (evk,_ as ev), _
-            when not (ExistentialSet.mem evk flags.frozen_evars) ->
+            when not (Evar.Set.mem evk flags.frozen_evars) 
+	      && not (occur_evar evk cN) ->
 	    let cmvars = free_rels cM and cnvars = free_rels cN in
-	      if Intset.subset cnvars cmvars then
+	      if Int.Set.subset cnvars cmvars then
 		sigma,metasubst,((curenv,ev,cN)::evarsubst)
 	      else error_cannot_unify_local curenv sigma (m,n,cN)
 	| _, Evar (evk,_ as ev)
-            when not (ExistentialSet.mem evk flags.frozen_evars) ->
+            when not (Evar.Set.mem evk flags.frozen_evars)
+	      && not (occur_evar evk cM) ->
 	    let cmvars = free_rels cM and cnvars = free_rels cN in
-	      if Intset.subset cmvars cnvars then
+	      if Int.Set.subset cmvars cnvars then
 		sigma,metasubst,((curenv,ev,cM)::evarsubst)
 	      else error_cannot_unify_local curenv sigma (m,n,cN)
 	| Sort s1, Sort s2 ->
 	    (try 
 	       let sigma' = 
-		 if cv_pb = CUMUL 
-		 then Evd.set_leq_sort sigma s1 s2 
-		 else Evd.set_eq_sort sigma s1 s2 
+		 if pb == CUMUL
+		 then Evd.set_leq_sort curenv sigma s1 s2 
+		 else Evd.set_eq_sort curenv sigma s1 s2
 	       in (sigma', metasubst, evarsubst)
 	     with e when Errors.noncritical e ->
                error_cannot_unify curenv sigma (m,n))
 
 	| Lambda (na,t1,c1), Lambda (_,t2,c2) ->
-	    unirec_rec (push (na,t1) curenvnb) CONV true wt
-	      (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2
+	    unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true}
+	      (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2
 	| Prod (na,t1,c1), Prod (_,t2,c2) ->
-	    unirec_rec (push (na,t1) curenvnb) pb true false
-	      (unirec_rec curenvnb CONV true false substn t1 t2) c1 c2
-	| LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b wt substn (subst1 a c) cN
-	| _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b wt substn cM (subst1 a c)
+	    unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true}
+	      (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2
+	| LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN
+	| _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c)
+
+	(** Fast path for projections. *)
+	| Proj (p1,c1), Proj (p2,c2) when eq_constant
+	    (Projection.constant p1) (Projection.constant p2) ->
+	  (try unify_same_proj curenvnb cv_pb {opt with at_top = true}
+	       substn c1 c2
+	   with ex when precatchable_exception ex ->
+	     unify_not_same_head curenvnb pb opt substn cM cN)
 
         (* eta-expansion *)
 	| Lambda (na,t1,c1), _ when flags.modulo_eta ->
-	    unirec_rec (push (na,t1) curenvnb) CONV true wt substn
+	    unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn
 	      c1 (mkApp (lift 1 cN,[|mkRel 1|]))
 	| _, Lambda (na,t2,c2) when flags.modulo_eta ->
-	    unirec_rec (push (na,t2) curenvnb) CONV true wt substn
+	    unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn
 	      (mkApp (lift 1 cM,[|mkRel 1|])) c2
 
+	(* For records *)
+	| App (f1, l1), _ when flags.modulo_eta && 
+	    (* This ensures cN is an evar, meta or irreducible constant/variable
+	       and not a constructor. *)
+	    is_eta_constructor_app curenv flags.modulo_delta f1 l1 cN ->
+	  (try 
+	     let l1', l2' = eta_constructor_app curenv f1 l1 cN in
+	     let opt' = {opt with at_top = true; with_cs = false} in
+	       Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2'
+	   with ex when precatchable_exception ex ->
+	     match kind_of_term cN with
+	     | App(f2,l2) when
+		 (isMeta f2 && use_metas_pattern_unification flags nb l2
+		  || use_evars_pattern_unification flags && isAllowedEvar flags f2) ->
+	       unify_app_pattern false curenvnb pb opt substn cM f1 l1 cN f2 l2
+	     | _ -> raise ex)
+
+	| _, App (f2, l2) when flags.modulo_eta && 
+	    is_eta_constructor_app curenv flags.modulo_delta f2 l2 cM ->
+	  (try 
+	     let l2', l1' = eta_constructor_app curenv f2 l2 cM in
+	     let opt' = {opt with at_top = true; with_cs = false} in
+	       Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2'
+	   with ex when precatchable_exception ex ->
+	     match kind_of_term cM with
+	     | App(f1,l1) when 
+		 (isMeta f1 && use_metas_pattern_unification flags nb l1
+		  || use_evars_pattern_unification flags && isAllowedEvar flags f1) ->
+	       unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2
+	     | _ -> raise ex)
+
 	| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
             (try 
-	       array_fold_left2 (unirec_rec curenvnb CONV true wt)
-		 (unirec_rec curenvnb CONV true false
-		    (unirec_rec curenvnb CONV true false substn p1 p2) c1 c2)
+	     let opt' = {opt with at_top = true; with_types = false} in
+	       Array.fold_left2 (unirec_rec curenvnb CONV {opt with at_top = true})
+	       (unirec_rec curenvnb CONV opt'
+		(unirec_rec curenvnb CONV opt' substn p1 p2) c1 c2)
                  cl1 cl2
 	     with ex when precatchable_exception ex ->
-	       reduce curenvnb pb b wt substn cM cN)
+	       reduce curenvnb pb opt substn cM cN)
 
 	| App (f1,l1), _ when 
 	    (isMeta f1 && use_metas_pattern_unification flags nb l1
             || use_evars_pattern_unification flags && isAllowedEvar flags f1) ->
-            (match
-                is_unification_pattern curenvnb sigma f1 (Array.to_list l1) cN
-             with
-             | None ->
-                 (match kind_of_term cN with
-                 | App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
-                 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN)
-             | Some l ->
-                 solve_pattern_eqn_array curenvnb f1 l cN substn)
+	  unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN cN [||]
 
 	| _, App (f2,l2) when
 	    (isMeta f2 && use_metas_pattern_unification flags nb l2
             || use_evars_pattern_unification flags && isAllowedEvar flags f2) ->
-            (match
-                is_unification_pattern curenvnb sigma f2 (Array.to_list l2) cM
-             with
-             | None ->
-                 (match kind_of_term cM with
-                 | App (f1,l1) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
-                 | _ -> unify_not_same_head curenvnb pb b wt substn cM cN)
-             | Some l ->
-	         solve_pattern_eqn_array curenvnb f2 l cM substn)
+	  unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2
 
 	| App (f1,l1), App (f2,l2) ->
-            unify_app curenvnb pb b substn cM f1 l1 cN f2 l2
+	  unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
+	    
+	| App (f1,l1), Proj(p2,c2) ->
+	  unify_app curenvnb pb opt substn cM f1 l1 cN cN [||]
 
-	| _ ->
-            unify_not_same_head curenvnb pb b wt substn cM cN
+	| Proj (p1,c1), App(f2,l2) ->
+	  unify_app curenvnb pb opt substn cM cM [||] cN f2 l2
 
-  and unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 =
+	| _ ->
+          unify_not_same_head curenvnb pb opt substn cM cN
+
+  and unify_app_pattern dir curenvnb pb opt substn cM f1 l1 cN f2 l2 =
+    let f, l, t = if dir then f1, l1, cN else f2, l2, cM in
+      match is_unification_pattern curenvnb sigma f (Array.to_list l) t with
+      | None ->
+	(match kind_of_term t with
+	| App (f',l') -> 
+	  if dir then unify_app curenvnb pb opt substn cM f1 l1 t f' l'
+	  else unify_app curenvnb pb opt substn t f' l' cN f2 l2
+	| Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2
+	| _ -> unify_not_same_head curenvnb pb opt substn cM cN)
+      | Some l ->
+	solve_pattern_eqn_array curenvnb f l t substn
+
+  and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn) cM f1 l1 cN f2 l2 =
     try
+      let needs_expansion p c' = 
+	match kind_of_term c' with
+	| Meta _ -> true
+	| Evar _ -> true
+	| Const (c, u) -> Constant.equal c (Projection.constant p)
+	| _ -> false
+      in
+      let expand_proj c c' l = 
+      	match kind_of_term c with
+      	| Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' ->
+      	  (try destApp (Retyping.expand_projection curenv sigma p t (Array.to_list l))
+      	   with RetypeError _ -> (** Unification can be called on ill-typed terms, due
+      				     to FO and eta in particular, fail gracefully in that case *)
+      	     (c, l))
+      	| _ -> (c, l)
+      in
+      let f1, l1 = expand_proj f1 f2 l1 in
+      let f2, l2 = expand_proj f2 f1 l2 in
+      let opta = {opt with at_top = true; with_types = false} in
+      let optf = {opt with at_top = true; with_types = true} in
       let (f1,l1,f2,l2) = adjust_app_array_size f1 l1 f2 l2 in
-      array_fold_left2 (unirec_rec curenvnb CONV true false)
-	(unirec_rec curenvnb CONV true true substn f1 f2) l1 l2
-    with ex when precatchable_exception ex ->
-    try reduce curenvnb pb b false substn cM cN
+	if Array.length l1 == 0 then error_cannot_unify (fst curenvnb) sigma (cM,cN)
+	else
+	  Array.fold_left2 (unirec_rec curenvnb CONV opta)
+	    (unirec_rec curenvnb CONV optf substn f1 f2) l1 l2
     with ex when precatchable_exception ex ->
-    try expand curenvnb pb b false substn cM f1 l1 cN f2 l2
+    try reduce curenvnb pb {opt with with_types = false} substn cM cN
     with ex when precatchable_exception ex ->
-    canonical_projections curenvnb pb b cM cN substn
-
-  and unify_not_same_head curenvnb pb b wt substn cM cN =
-    try canonical_projections curenvnb pb b cM cN substn
+    try canonical_projections curenvnb pb opt cM cN substn
     with ex when precatchable_exception ex ->
-    if constr_cmp cv_pb cM cN then substn else
-    try reduce curenvnb pb b wt substn cM cN
+    expand curenvnb pb {opt with with_types = false} substn cM f1 l1 cN f2 l2
+
+  and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 =
+    let substn = unirec_rec curenvnb CONV opt substn c1 c2 in
+      try (* Force unification of the types to fill in parameters *)
+	let ty1 = get_type_of curenv ~lax:true sigma c1 in
+	let ty2 = get_type_of curenv ~lax:true sigma c2 in
+	  unify_0_with_initial_metas substn true curenv cv_pb
+	    { flags with modulo_conv_on_closed_terms = Some full_transparent_state;
+	      modulo_delta = full_transparent_state;
+	      modulo_eta = true;
+	      modulo_betaiota = true }
+	    ty1 ty2
+      with RetypeError _ -> substn
+
+  and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn) cM cN =
+    try canonical_projections curenvnb pb opt cM cN substn
     with ex when precatchable_exception ex ->
-    let (f1,l1) =
-      match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
-    let (f2,l2) =
-      match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
-    expand curenvnb pb b wt substn cM f1 l1 cN f2 l2
-
-  and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN =
-    if use_full_betaiota flags && not (subterm_restriction b flags) then
+    let sigma', b = constr_cmp cv_pb sigma flags cM cN in
+      if b then (sigma', metas, evars)
+      else
+	try reduce curenvnb pb opt substn cM cN
+	with ex when precatchable_exception ex ->
+	let (f1,l1) =
+	  match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in
+	let (f2,l2) =
+	  match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in
+	  expand curenvnb pb opt substn cM f1 l1 cN f2 l2
+
+  and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN =
+    if use_full_betaiota flags && not (subterm_restriction opt flags) then
       let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in
-	if not (eq_constr cM cM') then
-	  unirec_rec curenvnb pb b wt substn cM' cN
+	if not (Term.eq_constr cM cM') then
+	  unirec_rec curenvnb pb opt substn cM' cN
 	else
 	  let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in
-	    if not (eq_constr cN cN') then
-	      unirec_rec curenvnb pb b wt substn cM cN'
+	    if not (Term.eq_constr cN cN') then
+	      unirec_rec curenvnb pb opt substn cM cN'
 	    else error_cannot_unify (fst curenvnb) sigma (cM,cN)
-    else
-      error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    else error_cannot_unify (fst curenvnb) sigma (cM,cN)
 	    
-  and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 =
-
-    if
+  and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 =
+    let res =
       (* Try full conversion on meta-free terms. *)
       (* Back to 1995 (later on called trivial_unify in 2002), the
 	 heuristic was to apply conversion on meta-free (but not
@@ -549,117 +885,144 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag
 	 (it is used by apply and rewrite); it might now be redundant
 	 with the support for delta-expansion (which is used
 	 essentially for apply)... *)
-      not (subterm_restriction b flags) &&
+      if subterm_restriction opt flags then None else 
       match flags.modulo_conv_on_closed_terms with
-      | None -> false
+      | None -> None
       | Some convflags ->
-      let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in
-      match subst_defined_metas subst cM with
-      | None -> (* some undefined Metas in cM *) false
+      let subst = ((if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms), (if flags.use_evars_eagerly_in_conv_on_closed_terms then evarsubst else es)) in
+      match subst_defined_metas_evars subst cM with
+      | None -> (* some undefined Metas in cM *) None
       | Some m1 ->
-      match subst_defined_metas subst cN with
-      | None -> (* some undefined Metas in cN *) false
+      match subst_defined_metas_evars subst cN with
+      | None -> (* some undefined Metas in cN *) None
       | Some n1 ->
           (* No subterm restriction there, too much incompatibilities *)
-	  if is_trans_fconv pb convflags env sigma m1 n1
-	  then true else
-	    if is_ground_term sigma m1 && is_ground_term sigma n1 then
-	      error_cannot_unify curenv sigma (cM,cN)
-	    else false
-    then
-      substn
-    else
-      let cf1 = key_of b flags f1 and cf2 = key_of b flags f2 in
+	  let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in
+	    if b then Some (sigma, metasubst, evarsubst)
+	    else 
+	      if is_ground_term sigma m1 && is_ground_term sigma n1 then
+		error_cannot_unify curenv sigma (cM,cN)
+	      else None
+    in
+      match res with
+      | Some substn -> substn
+      | None ->
+      let cf1 = key_of curenv opt flags f1 and cf2 = key_of curenv opt flags f2 in
 	match oracle_order curenv cf1 cf2 with
 	| None -> error_cannot_unify curenv sigma (cM,cN)
 	| Some true ->
-	    (match expand_key curenv cf1 with
+	    (match expand_key flags.modulo_delta curenv sigma cf1 with
 	    | Some c ->
-		unirec_rec curenvnb pb b wt substn
+		unirec_rec curenvnb pb opt substn
                   (whd_betaiotazeta sigma (mkApp(c,l1))) cN
 	    | None ->
-		(match expand_key curenv cf2 with
+		(match expand_key flags.modulo_delta curenv sigma cf2 with
 		| Some c ->
-		    unirec_rec curenvnb pb b wt substn cM
+		    unirec_rec curenvnb pb opt substn cM
                       (whd_betaiotazeta sigma (mkApp(c,l2)))
 		| None ->
 		    error_cannot_unify curenv sigma (cM,cN)))
 	| Some false ->
-	    (match expand_key curenv cf2 with
+	    (match expand_key flags.modulo_delta curenv sigma cf2 with
 	    | Some c ->
-		unirec_rec curenvnb pb b wt substn cM
+		unirec_rec curenvnb pb opt substn cM
                   (whd_betaiotazeta sigma (mkApp(c,l2)))
 	    | None ->
-		(match expand_key curenv cf1 with
+		(match expand_key flags.modulo_delta curenv sigma cf1 with
 		| Some c ->
-		    unirec_rec curenvnb pb b wt substn
+		    unirec_rec curenvnb pb opt substn
                       (whd_betaiotazeta sigma (mkApp(c,l1))) cN
 		| None ->
 		    error_cannot_unify curenv sigma (cM,cN)))
 
-  and canonical_projections curenvnb pb b cM cN (sigma,_,_ as substn) =
+  and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) =
     let f1 () =
       if isApp cM then
-	let f1l1 = decompose_app cM in
-	  if is_open_canonical_projection env sigma f1l1 then
-	    let f2l2 = decompose_app cN in
-	      solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 substn
+	let f1l1 = whd_nored_state sigma (cM,Stack.empty) in
+	  if is_open_canonical_projection curenv sigma f1l1 then
+	    let f2l2 = whd_nored_state sigma (cN,Stack.empty) in
+	      solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn
 	  else error_cannot_unify (fst curenvnb) sigma (cM,cN)
       else error_cannot_unify (fst curenvnb) sigma (cM,cN)
     in
-      if flags.modulo_conv_on_closed_terms = None ||
-         subterm_restriction b flags then
+      if not opt.with_cs ||
+        begin match flags.modulo_conv_on_closed_terms with
+        | None -> true
+        | Some _ -> subterm_restriction opt flags
+        end then
 	error_cannot_unify (fst curenvnb) sigma (cM,cN)
       else
 	try f1 () with e when precatchable_exception e ->
 	  if isApp cN then
-	    let f2l2 = decompose_app cN in
-	      if is_open_canonical_projection env sigma f2l2 then
-		let f1l1 = decompose_app cM in
-		  solve_canonical_projection curenvnb pb b cN f2l2 cM f1l1 substn
+	    let f2l2 = whd_nored_state sigma (cN, Stack.empty) in
+	      if is_open_canonical_projection curenv sigma f2l2 then
+		let f1l1 = whd_nored_state sigma (cM, Stack.empty) in
+		  solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn
 	      else error_cannot_unify (fst curenvnb) sigma (cM,cN)
 	  else error_cannot_unify (fst curenvnb) sigma (cM,cN)
 
-  and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) =
-    let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
-      try Evarconv.check_conv_record f1l1 f2l2
+  and solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 (sigma,ms,es) =
+    let (ctx,t,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) =
+      try Evarconv.check_conv_record (fst curenvnb) sigma f1l1 f2l2
       with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN)
     in
-    let (evd,ks,_) =
-      List.fold_left
-	(fun (evd,ks,m) b ->
-	  if m=n then (evd,t2::ks, m-1) else
-            let mv = new_meta () in
-	    let evd' = meta_declare mv (substl ks b) evd in
+    if Reductionops.Stack.compare_shape ts ts1 then
+      let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in
+      let (evd,ks,_) =
+	List.fold_left
+	  (fun (evd,ks,m) b ->
+	    if match n with Some n -> Int.equal m n | None -> false then
+                (evd,t2::ks, m-1)
+            else
+              let mv = new_meta () in
+	      let evd' = meta_declare mv (substl ks b) evd in
 	      (evd', mkMeta mv :: ks, m - 1))
-	(sigma,[],List.length bs - 1) bs
-    in
-    let unilist2 f substn l l' =
-      try List.fold_left2 f substn l l'
-      with Invalid_argument "List.fold_left2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN)
-    in
-    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u))
-      (evd,ms,es) us2 us in
-    let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b false s u1 (substl ks u))
-      substn params1 params in
-    let substn = unilist2 (unirec_rec curenvnb pb b false) substn ts ts1 in
-      unirec_rec curenvnb pb b false substn c1 (applist (c,(List.rev ks)))
-
+	  (sigma,[],List.length bs) bs
+      in
+      try
+      let opt' = {opt with with_types = false} in
+      let (substn,_,_) = Reductionops.Stack.fold2
+			   (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
+			   (evd,ms,es) us2 us in
+      let (substn,_,_) = Reductionops.Stack.fold2
+			   (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u))
+			   substn params1 params in
+      let (substn,_,_) = Reductionops.Stack.fold2 (unirec_rec curenvnb pb opt') substn ts ts1 in
+      let app = mkApp (c, Array.rev_of_list ks) in
+      (* let substn = unirec_rec curenvnb pb b false substn t cN in *)
+	unirec_rec curenvnb pb opt' substn c1 app
+      with Invalid_argument "Reductionops.Stack.fold2" ->
+	error_cannot_unify (fst curenvnb) sigma (cM,cN)
+    else error_cannot_unify (fst curenvnb) sigma (cM,cN)
   in
-  let evd = sigma in
-    if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n
-        || subterm_restriction conv_at_top flags then false
-      else if (match flags.modulo_conv_on_closed_terms with
-      | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n
-      | _ -> constr_cmp cv_pb m n) then true
-      else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
-            | Some (cv_id, cv_k), (dl_id, dl_k) ->
-                Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k
-            | None,(dl_id, dl_k) ->
-                Idpred.is_empty dl_id && Cpred.is_empty dl_k)
-      then error_cannot_unify env sigma (m, n) else false)
-    then subst
-    else unirec_rec (env,0) cv_pb conv_at_top false subst m n
+    
+  if !debug_unification then msg_debug (str "Starting unification");
+  let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in
+  try
+  let res = 
+    if occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n
+      || subterm_restriction opt flags then None
+    else 
+      let sigma, b = match flags.modulo_conv_on_closed_terms with
+	| Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n
+	| _ -> constr_cmp cv_pb sigma flags m n in
+	if b then Some sigma
+	else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with
+        | Some (cv_id, cv_k), (dl_id, dl_k) ->
+          Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k
+        | None,(dl_id, dl_k) ->
+          Id.Pred.is_empty dl_id && Cpred.is_empty dl_k)
+	then error_cannot_unify env sigma (m, n) else None
+  in 
+    let a = match res with 
+    | Some sigma -> sigma, ms, es
+    | None -> unirec_rec (env,0) cv_pb opt subst m n in
+    if !debug_unification then msg_debug (str "Leaving unification with success");
+    a
+  with e ->
+    if !debug_unification then msg_debug (str "Leaving unification with failure");
+    raise e
+
 
 let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env
 
@@ -704,14 +1067,14 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
   | ((IsSubType | Conv as oppst1),
      (IsSubType | Conv)) ->
     let res = unify_0 env sigma CUMUL flags c2 c1 in
-      if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
-      else if st2=IsSubType then (left, st1, res)
+      if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res)
+      else if eq_instance_constraint st2 IsSubType then (left, st1, res)
       else (right, st2, res)
   | ((IsSuperType | Conv as oppst1),
      (IsSuperType | Conv)) ->
     let res = unify_0 env sigma CUMUL flags c1 c2 in
-      if oppst1=st2 then (* arbitrary choice *) (left, st1, res)
-      else if st2=IsSuperType then (left, st1, res)
+      if eq_instance_constraint oppst1 st2 then (* arbitrary choice *) (left, st1, res)
+      else if eq_instance_constraint st2 IsSuperType then (left, st1, res)
       else (right, st2, res)
   | (IsSuperType,IsSubType) ->
     (try (left, IsSubType, unify_0 env sigma CUMUL flags c2 c1)
@@ -773,13 +1136,13 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
 
 let applyHead env evd n c  =
   let rec apprec n c cty evd =
-    if n = 0 then
+    if Int.equal n 0 then
       (evd, c)
     else
       match kind_of_term (whd_betadeltaiota env evd cty) with
       | Prod (_,c1,c2) ->
         let (evd',evar) =
-	  Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in
+	  Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in
 	  apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
       | _ -> error "Apply_Head_Then"
   in
@@ -787,21 +1150,20 @@ let applyHead env evd n c  =
     
 let is_mimick_head ts f =
   match kind_of_term f with
-  | Const c -> not (Closure.is_transparent_constant ts c)
+  | Const (c,u) -> not (Closure.is_transparent_constant ts c)
   | Var id -> not (Closure.is_transparent_variable ts id)
   | (Rel _|Construct _|Ind _) -> true
   | _ -> false
 
 let try_to_coerce env evd c cty tycon =
   let j = make_judge c cty in
-  let (evd',j') = inh_conv_coerce_rigid_to true dummy_loc env evd j tycon in
+  let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in
   let evd' = Evarconv.consider_remaining_unif_problems env evd' in
   let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
     (evd',j'.uj_val)
 
 let w_coerce_to_type env evd c cty mvty =
-  let evd,mvty = pose_all_metas_as_evars env evd mvty in
-  let tycon = mk_tycon_type mvty in
+  let evd,tycon = pose_all_metas_as_evars env evd mvty in
     try try_to_coerce env evd c cty tycon
     with e when precatchable_exception e ->
     (* inh_conv_coerce_rigid_to should have reasoned modulo reduction
@@ -816,8 +1178,8 @@ let w_coerce env evd mv c =
   w_coerce_to_type env evd c cty mvty
 
 let unify_to_type env sigma flags c status u =
-  let c = refresh_universes c in
-  let t = get_type_of env sigma c in
+  let sigma, c = refresh_universes (Some false) env sigma c in
+  let t = get_type_of env sigma (nf_meta sigma c) in
   let t = nf_betaiota sigma (nf_meta sigma t) in
     unify_0 env sigma CUMUL flags t u
 
@@ -825,9 +1187,7 @@ let unify_type env sigma flags mv status c =
   let mvty = Typing.meta_type sigma mv in
   let mvty = nf_meta sigma mvty in
     unify_to_type env sigma 
-      {flags with modulo_delta = flags.modulo_delta_types;
-	 modulo_conv_on_closed_terms = Some flags.modulo_delta_types;
-	 modulo_betaiota = true}
+      (set_flags_for_type flags)
       c status mvty
 
 (* Move metas that may need coercion at the end of the list of instances *)
@@ -835,17 +1195,20 @@ let unify_type env sigma flags mv status c =
 let order_metas metas =
   let rec order latemetas = function
   | [] -> List.rev latemetas
-  | (_,_,(status,to_type) as meta)::metas ->
-      if to_type = CoerceToType then order (meta::latemetas) metas
-      else meta :: order latemetas metas
+  | (_,_,(_,CoerceToType) as meta)::metas ->
+    order (meta::latemetas) metas
+  | (_,_,(_,_) as meta)::metas ->
+    meta :: order latemetas metas
   in order [] metas
 
 (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *)
 
 let solve_simple_evar_eqn ts env evd ev rhs =
-  let evd,b = solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) in
-  if not b then error_cannot_unify env evd (mkEvar ev,rhs);
-  Evarconv.consider_remaining_unif_problems env evd
+  match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with
+  | UnifFailure (evd,reason) ->
+      error_cannot_unify env evd ~reason (mkEvar ev,rhs);
+  | Success evd ->
+      Evarconv.consider_remaining_unif_problems env evd
 
 (* [w_merge env sigma b metas evars] merges common instances in metas
    or in evars, possibly generating new unification problems; if [b]
@@ -860,7 +1223,7 @@ let w_merge env with_types flags (evd,metas,evars) =
 	if Evd.is_defined evd evk then
 	  let v = Evd.existential_value evd ev in
 	  let (evd,metas',evars'') =
-	    unify_0 curenv evd CONV (set_merge_flags flags) rhs v in
+	    unify_0 curenv evd CONV flags rhs v in
 	  w_merge_rec evd (metas'@metas) (evars''@evars') eqns
     	else begin
 	  (* This can make rhs' ill-typed if metas are *)
@@ -872,16 +1235,22 @@ let w_merge env with_types flags (evd,metas,evars) =
 	      if is_mimick_head flags.modulo_delta f then
 		let evd' =
 		  mimick_undefined_evar evd flags f (Array.length cl) evk in
-		w_merge_rec evd' metas evars eqns
+		(* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *)
+		  w_merge_rec evd' metas evars eqns
 	      else
-		let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
-		w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'')
-		  metas evars' eqns
-
+		let evd' = 
+		  let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
+		    try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs''
+		    with Retyping.RetypeError _ ->
+		      error_cannot_unify curenv evd' (mkEvar ev,rhs'')
+		in w_merge_rec evd' metas evars' eqns
           | _ ->
 	      let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in
-		w_merge_rec (solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'')
-		  metas evars' eqns
+	      let evd' = 
+		try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs''
+		with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'')
+	      in
+		w_merge_rec evd' metas evars' eqns
 	end
     | [] ->
 
@@ -889,13 +1258,15 @@ let w_merge env with_types flags (evd,metas,evars) =
     match metas with
     | (mv,c,(status,to_type))::metas ->
         let ((evd,c),(metas'',evars'')),eqns =
-	  if with_types & to_type <> TypeProcessed then
-	    if to_type = CoerceToType then
+	  if with_types && to_type != TypeProcessed then
+	    begin match to_type with
+	    | CoerceToType ->
               (* Some coercion may have to be inserted *)
 	      (w_coerce env evd mv c,([],[])),eqns
-	    else
+	    | _ ->
               (* No coercion needed: delay the unification of types *)
 	      ((evd,c),([],[])),(mv,status,c)::eqns
+	    end
 	  else
 	    ((evd,c),([],[])),eqns 
 	in
@@ -938,19 +1309,30 @@ let w_merge env with_types flags (evd,metas,evars) =
     let sp_env = Global.env_of_context ev.evar_hyps in
     let (evd', c) = applyHead sp_env evd nargs hdc in
     let (evd'',mc,ec) =
-      unify_0 sp_env evd' CUMUL (set_merge_flags flags)
+      unify_0 sp_env evd' CUMUL flags
         (get_type_of sp_env evd' c) ev.evar_concl in
     let evd''' = w_merge_rec evd'' mc ec [] in
     if evd' == evd'''
     then Evd.define sp c evd'''
     else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in
 
-  (* merge constraints *)
-  w_merge_rec evd (order_metas metas) evars []
+  let check_types evd = 
+    let metas = Evd.meta_list evd in
+    let eqns = List.fold_left (fun acc (mv, b) ->
+      match b with
+      | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, t.rebus) :: acc
+      | _ -> acc) [] metas
+    in w_merge_rec evd [] [] eqns
+  in
+  let res =  (* merge constraints *)
+    w_merge_rec evd (order_metas metas) (List.rev evars) []
+  in
+    if with_types then check_types res
+    else res
 
-let w_unify_meta_types env ?(flags=default_unify_flags) evd =
+let w_unify_meta_types env ?(flags=default_unify_flags ()) evd =
   let metas,evd = retract_coercible_metas evd in
-  w_merge env true flags (evd,metas,[])
+  w_merge env true flags.merge_unify_flags (evd,metas,[])
 
 (* [w_unify env evd M N]
    performs a unification of M and N, generating a bunch of
@@ -962,49 +1344,49 @@ let w_unify_meta_types env ?(flags=default_unify_flags) evd =
    [clenv_typed_unify M N clenv] expects in addition that expected
    types of metavars are unifiable with the types of their instances    *)
 
+let head_app sigma m =
+  fst (whd_nored_state sigma (m, Stack.empty))
+
 let check_types env flags (sigma,_,_ as subst) m n =
-  if isEvar_or_Meta (fst (whd_stack sigma m)) then
+  if isEvar_or_Meta (head_app sigma m) then
     unify_0_with_initial_metas subst true env CUMUL
       flags
       (get_type_of env sigma n)
       (get_type_of env sigma m)
-  else if isEvar_or_Meta (fst (whd_stack sigma n)) then
+  else if isEvar_or_Meta (head_app sigma n) then
     unify_0_with_initial_metas subst true env CUMUL
       flags
       (get_type_of env sigma m)
       (get_type_of env sigma n)
   else subst
 
-let try_resolve_typeclasses env evd flags m n =
-  if flags.resolve_evars then
-    try Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false
-	  ~fail:true env evd
-    with e when Typeclasses_errors.unsatisfiable_exception e ->
-      error_cannot_unify env evd (m, n)
+let try_resolve_typeclasses env evd flag m n =
+  if flag then
+    Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false
+      ~fail:true env evd
   else evd
 
 let w_unify_core_0 env evd with_types cv_pb flags m n =
   let (mc1,evd') = retract_coercible_metas evd in
-  let (sigma,ms,es) = check_types env flags (evd,mc1,[]) m n in
+  let (sigma,ms,es) = check_types env (set_flags_for_type flags.core_unify_flags) (evd',mc1,[]) m n in
   let subst2 =
-     unify_0_with_initial_metas (evd',ms,es) false env cv_pb flags m n
+     unify_0_with_initial_metas (sigma,ms,es) false env cv_pb
+       flags.core_unify_flags m n
   in
-  let evd = w_merge env with_types flags subst2 in
-  try_resolve_typeclasses env evd flags m n
+  let evd = w_merge env with_types flags.merge_unify_flags subst2 in
+  try_resolve_typeclasses env evd flags.resolve_evars m n
 
-let w_unify_0 env evd = w_unify_core_0 env evd false
 let w_typed_unify env evd = w_unify_core_0 env evd true
 
-let w_typed_unify_list env evd flags f1 l1 f2 l2 =
-  let flags' = { flags with resolve_evars = false } in
-  let f1,l1,f2,l2 = adjust_app_list_size f1 l1 f2 l2 in
+let w_typed_unify_array env evd flags f1 l1 f2 l2 =
+  let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in
   let (mc1,evd') = retract_coercible_metas evd in
-  let subst =
-    List.fold_left2 (fun subst m n ->
-      unify_0_with_initial_metas subst true env CONV flags' m n) (evd',[],[])
-      (f1::l1) (f2::l2) in
-  let evd = w_merge env true flags subst in
-  try_resolve_typeclasses env evd flags (applist(f1,l1)) (applist(f2,l2))
+  let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags  m n in
+  let subst = fold_subst (evd', [], []) f1 f2 in
+  let subst = Array.fold_left2 fold_subst subst l1 l2 in
+  let evd = w_merge env true flags.merge_unify_flags subst in
+  try_resolve_typeclasses env evd flags.resolve_evars
+    (mkApp(f1,l1)) (mkApp(f2,l2))
 
 (* takes a substitution s, an open term op and a closed term cl
    try to find a subterm of cl which matches op, if op is just a Meta
@@ -1013,21 +1395,242 @@ let w_typed_unify_list env evd flags f1 l1 f2 l2 =
 let iter_fail f a =
   let n = Array.length a in
   let rec ffail i =
-    if i = n then error "iter_fail"
+    if Int.equal i n then error "iter_fail"
     else
       try f a.(i)
       with ex when precatchable_exception ex -> ffail (i+1)
   in ffail 0
 
+(* make_abstraction: a variant of w_unify_to_subterm which works on
+   contexts, with evars, and possibly with occurrences *)
+
+let indirectly_dependent c d decls =
+  not (isVar c) &&
+    (* This test is not needed if the original term is a variable, but
+       it is needed otherwise, as e.g. when abstracting over "2" in
+       "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious
+       way to see that the second hypothesis depends indirectly over 2 *)
+    List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls
+
+let indirect_dependency d decls =
+  pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls))
+
+let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
+  let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
+  let sigma, subst = nf_univ_variables sigma in
+  sigma, subst_univs_constr subst (nf_evar sigma c)
+
+let default_matching_core_flags sigma =
+  let ts = Names.full_transparent_state in {
+  modulo_conv_on_closed_terms = Some empty_transparent_state;
+  use_metas_eagerly_in_conv_on_closed_terms = false;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = ts;
+  check_applied_meta_types = true;
+  use_pattern_unification = false;
+  use_meta_bound_pattern_unification = false;
+  frozen_evars =
+    fold_undefined (fun evk _ evars -> Evar.Set.add evk evars)
+      sigma Evar.Set.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = false;
+}
+
+let default_matching_merge_flags sigma =
+  let ts = Names.full_transparent_state in
+  let flags = default_matching_core_flags sigma in {
+  flags with
+    modulo_conv_on_closed_terms = Some ts;
+    modulo_delta = ts;
+    modulo_betaiota = true;
+    modulo_eta = true;
+    use_pattern_unification = true;
+}
+
+let default_matching_flags (sigma,_) =
+  let flags = default_matching_core_flags sigma in {
+  core_unify_flags = flags;
+  merge_unify_flags = default_matching_merge_flags sigma;
+  subterm_unify_flags = flags; (* does not matter *)
+  resolve_evars = false;
+  allow_K_in_toplevel_higher_order_unification = false;
+}
+
+(* This supports search of occurrences of term from a pattern *)
+(* from_prefix is useful e.g. for subterms in an inductive type: we can say *)
+(* "destruct t" and it finds "t u" *)
+
+exception PatternNotFound
+
+let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) =
+  let flags =
+    if from_prefix_of_ind then
+      let flags = default_matching_flags pending in
+      { flags with core_unify_flags = { flags.core_unify_flags with
+        modulo_conv_on_closed_terms = Some Names.full_transparent_state;
+        restrict_conv_on_strict_subterms = true } }
+    else default_matching_flags pending in
+  let n = List.length (snd (decompose_app c)) in
+  let matching_fun _ t =
+    try
+      let t',l2 =
+        if from_prefix_of_ind then
+          (* We check for fully applied subterms of the form "u u1 .. un" *)
+          (* of inductive type knowing only a prefix "u u1 .. ui" *)
+          let t,l = decompose_app t in
+          let l1,l2 =
+            try List.chop n l with Failure _ -> raise (NotUnifiable None) in
+          if not (List.for_all closed0 l2) then raise (NotUnifiable None)
+          else
+            applist (t,l1), l2
+        else t, [] in
+      let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in
+      let ty = Retyping.get_type_of env sigma t in
+      if not (is_correct_type ty) then raise (NotUnifiable None);
+      Some(sigma, t, l2)
+    with
+    | PretypeError (_,_,CannotUnify (c1,c2,Some e)) ->
+        raise (NotUnifiable (Some (c1,c2,e)))
+    (** MS: This is pretty bad, it catches Not_found for example *)
+    | e when Errors.noncritical e -> raise (NotUnifiable None) in
+  let merge_fun c1 c2 =
+    match c1, c2 with
+    | Some (evd,c1,_) as x, Some (_,c2,_) ->
+      if is_conv env sigma c1 c2 then x else raise (NotUnifiable None)
+    | Some _, None -> c1
+    | None, Some _ -> c2
+    | None, None -> None in
+  { match_fun = matching_fun; merge_fun = merge_fun;
+    testing_state = None; last_found = None },
+  (fun test -> match test.testing_state with
+  | None -> None
+  | Some (sigma,_,l) ->
+     let c = applist (nf_evar sigma (local_strong whd_meta sigma c),l) in
+     let univs, subst = nf_univ_variables sigma in
+     Some (sigma,subst_univs_constr subst c))
+
+let make_eq_test env evd c =
+  let out cstr =
+    match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, c)
+  in
+  (make_eq_univs_test env evd c, out)
+
+let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
+  let id =
+    let t = match ty with Some t -> t | None -> get_type_of env sigma c in
+    let x = id_of_name_using_hdchar (Global.env()) t name in
+    let ids = ids_of_named_context (named_context env) in
+    if name == Anonymous then next_ident_away_in_goal x ids else
+    if mem_named_context x (named_context env) then
+      error ("The variable "^(Id.to_string x)^" is already declared.")
+    else
+      x
+  in
+  let likefirst = clause_with_generic_occurrences occs in
+  let mkvarid () = mkVar id in
+  let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) =
+    match occurrences_of_hyp hyp occs with
+    | NoOccurrences, InHyp ->
+        if indirectly_dependent c d depdecls then
+          (* Told explicitly not to abstract over [d], but it is dependent *)
+          let id' = indirect_dependency d depdecls in
+          errorlabstrm "" (str "Cannot abstract over " ++ Nameops.pr_id id'
+            ++ str " without also abstracting or erasing " ++ Nameops.pr_id hyp
+            ++ str ".")
+        else
+          (push_named_context_val d sign,depdecls)
+    | AllOccurrences, InHyp as occ ->
+        let occ = if likefirst then LikeFirst else AtOccs occ in
+        let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in
+        if Context.eq_named_declaration d newdecl
+           && not (indirectly_dependent c d depdecls)
+        then
+          if check_occs && not (in_every_hyp occs)
+          then raise (PretypeError (env,sigma,NoOccurrenceFound (c,Some hyp)))
+          else (push_named_context_val d sign, depdecls)
+        else
+          (push_named_context_val newdecl sign, newdecl :: depdecls)
+    | occ ->
+        (* There are specific occurrences, hence not like first *)
+        let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in
+        (push_named_context_val newdecl sign, newdecl :: depdecls) in
+  try
+    let sign,depdecls =
+      fold_named_context compute_dependency env
+        ~init:(empty_named_context_val,[]) in
+    let ccl = match occurrences_of_goal occs with
+      | NoOccurrences -> concl
+      | occ ->
+          let occ = if likefirst then LikeFirst else AtOccs occ in
+          replace_term_occ_modulo occ test mkvarid concl
+    in
+    let lastlhyp =
+      if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in
+    (id,sign,depdecls,lastlhyp,ccl,out test)
+  with
+    SubtermUnificationError e ->
+      raise (PretypeError (env,sigma,CannotUnifyOccurrences e))
+
+(** [make_abstraction] is the main entry point to abstract over a term
+    or pattern at some occurrences; it returns:
+    - the id used for the abstraction
+    - the type of the abstraction
+    - the declarations from the context which depend on the term or pattern
+    - the most recent hyp before which there is no dependency in the term of pattern
+    - the abstracted conclusion
+    - an evar universe context effect to apply on the goal
+    - the term or pattern to abstract fully instantiated
+*)
+
+type prefix_of_inductive_support_flag = bool
+
+type abstraction_request =
+| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool
+| AbstractExact of Name.t * constr * types option * clause * bool
+
+type abstraction_result =
+  Names.Id.t * named_context_val *
+    Context.named_declaration list * Names.Id.t option *
+    types * (Evd.evar_map * constr) option
+
+let make_abstraction env evd ccl abs =
+  match abs with
+  | AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
+      make_abstraction_core name
+        (make_pattern_test from_prefix check env evd c)
+        env evd (snd c) None occs check_occs ccl
+  | AbstractExact (name,c,ty,occs,check_occs) ->
+      make_abstraction_core name
+        (make_eq_test env evd c)
+        env evd c ty occs check_occs ccl
+
+let keyed_unify env evd kop = 
+  if not !keyed_unification then fun cl -> true
+  else 
+    match kop with 
+    | None -> fun _ -> true
+    | Some kop ->
+      fun cl ->
+	let kc = Keys.constr_key cl in
+	  match kc with
+	  | None -> false
+	  | Some kc -> Keys.equiv_keys kop kc
+
 (* Tries to find an instance of term [cl] in term [op].
    Unifies [cl] to every subterm of [op] until it finds a match.
    Fails if no match is found *)
-let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) =
+let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) =
+  let bestexn = ref None in
+  let kop = Keys.constr_key op in
   let rec matchrec cl =
     let cl = strip_outer_cast cl in
     (try
-       if closed0 cl && not (isEvar cl)
-       then w_typed_unify env evd CONV flags op cl,cl
+       if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then
+	 (try w_typed_unify env evd CONV flags op cl,cl
+	  with ex when Pretype_errors.unsatisfiable_exception ex ->
+	    bestexn := Some ex; error "Unsat")
        else error "Bound 1"
      with ex when precatchable_exception ex ->
        (match kind_of_term cl with
@@ -1051,6 +1654,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) =
 	       with ex when precatchable_exception ex ->
 		 matchrec c2)
 
+	  | Proj (p,c) -> matchrec c
+
 	  | Fix(_,(_,types,terms)) ->
 	       (try
 		 iter_fail matchrec types
@@ -1077,15 +1682,17 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) =
   in
   try matchrec cl
   with ex when precatchable_exception ex ->
-    raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
+    match !bestexn with
+    | None -> raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
+    | Some e -> raise e
 
 (* Tries to find all instances of term [cl] in term [op].
    Unifies [cl] to every subterm of [op] and return all the matches.
    Fails if no match is found *)
-let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) =
+let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) =
   let return a b =
     let (evd,c as a) = a () in
-      if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b
+      if List.exists (fun (evd',c') -> Term.eq_constr c c') b then b else a :: b
   in
   let fail str _ = error str in
   let bind f g a =
@@ -1099,7 +1706,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) =
   let bind_iter f a =
     let n = Array.length a in
     let rec ffail i =
-      if i = n then fun a -> a
+      if Int.equal i n then fun a -> a
       else bind (f a.(i)) (ffail (i+1))
     in ffail 0
   in
@@ -1120,6 +1727,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) =
             | Case(_,_,c,lf) -> (* does not search in the predicate *)
 		bind (matchrec c) (bind_iter matchrec lf)
 
+	    | Proj (p,c) -> matchrec c
+
 	    | LetIn(_,c1,_,c2) ->
 		bind (matchrec c1) (matchrec c2)
 
@@ -1138,10 +1747,10 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) =
             | _ -> fail "Match_subterm"))
   in
   let res = matchrec cl [] in
-  if res = [] then
+  match res with
+  | [] ->
     raise (PretypeError (env,evd,NoOccurrenceFound (op, None)))
-  else
-    res
+  | _ -> res
 
 let w_unify_to_subterm_list env evd flags hdmeta oplist t =
   List.fold_right
@@ -1150,47 +1759,64 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t =
       if isMeta op then
 	if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l)
 	else error_abstraction_over_meta env evd hdmeta (destMeta op)
-      else if occur_meta_or_existential op then
+      else
+        let allow_K = flags.allow_K_in_toplevel_higher_order_unification in
+        let flags =
+          if occur_meta_or_existential op || !keyed_unification then
+            flags
+          else
+            (* up to Nov 2014, unification was bypassed on evar/meta-free terms;
+               now it is called in a minimalistic way, at least to possibly
+               unify pre-existing non frozen evars of the goal or of the
+               pattern *)
+            set_no_delta_flags flags in
         let (evd',cl) =
           try
 	    (* This is up to delta for subterms w/o metas ... *)
 	    w_unify_to_subterm env evd ~flags (strip_outer_cast op,t)
-	  with PretypeError (env,_,NoOccurrenceFound _) when
-              flags.allow_K_in_toplevel_higher_order_unification -> (evd,op)
+	  with PretypeError (env,_,NoOccurrenceFound _) when allow_K -> (evd,op)
         in
-	  if not flags.allow_K_in_toplevel_higher_order_unification &&
+	  if not allow_K &&
             (* ensure we found a different instance *)
-	    List.exists (fun op -> eq_constr op cl) l
+	    List.exists (fun op -> Term.eq_constr op cl) l
 	  then error_non_linear_unification env evd hdmeta cl
-	  else (evd',cl::l)
-      else if flags.allow_K_in_toplevel_higher_order_unification or dependent op t
-      then
-	(evd,op::l)
-      else
-	(* This is not up to delta ... *)
-	raise (PretypeError (env,evd,NoOccurrenceFound (op, None))))
+	  else (evd',cl::l))
     oplist
     (evd,[])
 
 let secondOrderAbstraction env evd flags typ (p, oplist) =
   (* Remove delta when looking for a subterm *)
-  let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in
+  let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in
   let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in
   let typp = Typing.meta_type evd' p in
-  let pred = abstract_list_all env evd' typp typ cllist in
-  w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[])
+  let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in
+  let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in
+  if not b then
+    error_wrong_abstraction_type env evd'
+      (Evd.meta_name evd p) pred typp predtyp;
+  w_merge env false flags.merge_unify_flags
+    (evd',[p,pred,(Conv,TypeProcessed)],[])
+
+  (* let evd',metas,evars =  *)
+  (*   try unify_0 env evd' CUMUL flags predtyp typp  *)
+  (*   with NotConvertible -> *)
+  (*     error_wrong_abstraction_type env evd *)
+  (*       (Evd.meta_name evd p) pred typp predtyp *)
+  (* in *)
+  (*   w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *)
 
 let secondOrderDependentAbstraction env evd flags typ (p, oplist) =
   let typp = Typing.meta_type evd p in
-  let pred = abstract_list_all_with_dependencies env evd typp typ oplist in
-  w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[])
+  let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in
+  w_merge env false flags.merge_unify_flags
+    (evd,[p,pred,(Conv,TypeProcessed)],[])
 
 let secondOrderAbstractionAlgo dep =
   if dep then secondOrderDependentAbstraction else secondOrderAbstraction
 
 let w_unify2 env evd flags dep cv_pb ty1 ty2 =
-  let c1, oplist1 = whd_stack evd ty1 in
-  let c2, oplist2 = whd_stack evd ty2 in
+  let c1, oplist1 = whd_nored_stack evd ty1 in
+  let c2, oplist2 = whd_nored_stack evd ty2 in
   match kind_of_term c1, kind_of_term c2 with
     | Meta p1, _ ->
         (* Find the predicate *)
@@ -1220,15 +1846,17 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 =
    Before, second-order was used if the type of Meta(1) and [x:A]t was
    convertible and first-order otherwise. But if failed if e.g. the type of
    Meta(1) had meta-variables in it. *)
-let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 =
-  let hd1,l1 = whd_stack evd ty1 in
-  let hd2,l2 = whd_stack evd ty2 in
-    match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
+let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
+  let hd1,l1 = decompose_appvect (whd_nored evd ty1) in
+  let hd2,l2 = decompose_appvect (whd_nored evd ty2) in
+  let is_empty1 = Array.is_empty l1 in
+  let is_empty2 = Array.is_empty l2 in
+    match kind_of_term hd1, not is_empty1, kind_of_term hd2, not is_empty2 with
       (* Pattern case *)
       | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
-	  when List.length l1 = List.length l2 ->
+	  when Int.equal (Array.length l1) (Array.length l2) ->
 	  (try
-	      w_typed_unify_list env evd flags hd1 l1 hd2 l2
+	      w_typed_unify_array env evd flags hd1 l1 hd2 l2
 	    with ex when precatchable_exception ex ->
 	      try
 		w_unify2 env evd flags false cv_pb ty1 ty2
@@ -1241,7 +1869,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 =
 	    with PretypeError (env,_,NoOccurrenceFound _) as e -> raise e
 	      | ex when precatchable_exception ex ->
 		  try
-		    w_typed_unify_list env evd flags hd1 l1 hd2 l2
+		    w_typed_unify_array env evd flags hd1 l1 hd2 l2
 		  with ex' when precatchable_exception ex' ->
                     (* Last chance, use pattern-matching with typed
                        dependencies (done late for compatibility) *)
@@ -1252,3 +1880,17 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 =
 
       (* General case: try first order *)
       | _ -> w_typed_unify env evd cv_pb flags ty1 ty2
+
+(* Profiling *)
+
+let w_unify env evd cv_pb flags ty1 ty2 =
+  w_unify env evd cv_pb ~flags:flags ty1 ty2
+
+let w_unify = 
+  if Flags.profile then
+    let wunifkey = Profile.declare_profile "w_unify" in
+      Profile.profile6 wunifkey w_unify
+  else w_unify
+
+let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
+  w_unify env evd cv_pb flags ty1 ty2
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 75bddc1f..119b1a75 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.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        *)
@@ -10,34 +10,43 @@ open Term
 open Environ
 open Evd
 
-type unify_flags = {
+type core_unify_flags = {
   modulo_conv_on_closed_terms : Names.transparent_state option;
   use_metas_eagerly_in_conv_on_closed_terms : bool;
+  use_evars_eagerly_in_conv_on_closed_terms : bool;
   modulo_delta : Names.transparent_state;
   modulo_delta_types : Names.transparent_state;
-  modulo_delta_in_merge : Names.transparent_state option;
   check_applied_meta_types : bool;
-  resolve_evars : bool;
   use_pattern_unification : bool;
   use_meta_bound_pattern_unification : bool;
-  frozen_evars : ExistentialSet.t;
+  frozen_evars : Evar.Set.t;
   restrict_conv_on_strict_subterms : bool;
   modulo_betaiota : bool;
   modulo_eta : bool;
-  allow_K_in_toplevel_higher_order_unification : bool
 }
 
-val default_unify_flags : unify_flags
-val default_no_delta_unify_flags : unify_flags
+type unify_flags = {
+  core_unify_flags : core_unify_flags;
+  merge_unify_flags : core_unify_flags;
+  subterm_unify_flags : core_unify_flags;
+  allow_K_in_toplevel_higher_order_unification : bool;
+  resolve_evars : bool
+}
+
+val default_core_unify_flags : unit -> core_unify_flags
+val default_no_delta_core_unify_flags : unit -> core_unify_flags
+
+val default_unify_flags : unit -> unify_flags
+val default_no_delta_unify_flags : unit -> unify_flags
 
-val elim_flags : unify_flags
-val elim_no_delta_flags : unify_flags
+val elim_flags : unit -> unify_flags
+val elim_no_delta_flags : unit -> unify_flags
 
 (** The "unique" unification fonction *)
 val w_unify :
   env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map
 
-(** [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
+(** [w_unify_to_subterm env m (c,t)] performs unification of [c] with a
    subterm of [t]. Constraints are added to [m] and the matched
    subterm of [t] is also returned. *)
 val w_unify_to_subterm :
@@ -53,25 +62,59 @@ val w_unify_meta_types : env -> ?flags:unify_flags -> evar_map -> evar_map
 val w_coerce_to_type : env -> evar_map -> constr -> types -> types ->
   evar_map * constr
 
+(* Looking for subterms in contexts at some occurrences, possibly with pattern*)
+
+exception PatternNotFound
+
+type prefix_of_inductive_support_flag = bool
+
+type abstraction_request =
+| AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Names.Name.t * pending_constr * Locus.clause * bool
+| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
+
+val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
+  env -> Evd.evar_map -> pending_constr -> Evd.evar_map * constr
+
+type abstraction_result =
+  Names.Id.t * named_context_val *
+    Context.named_declaration list * Names.Id.t option *
+    types * (Evd.evar_map * constr) option
+
+val make_abstraction : env -> Evd.evar_map -> constr ->
+  abstraction_request -> abstraction_result
+
+val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
+
 (*i This should be in another module i*)
 
-(** [abstract_list_all env evd t c l]                       
-   abstracts the terms in l over c to get a term of type t 
+(** [abstract_list_all env evd t c l]
+   abstracts the terms in l over c to get a term of type t
    (exported for inv.ml) *)
 val abstract_list_all :
-  env -> evar_map -> constr -> constr -> constr list -> constr
-
+  env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types)
 
 (* For tracing *)
 
-val w_merge : env -> bool -> unify_flags -> evar_map *
+val w_merge : env -> bool -> core_unify_flags -> evar_map *
   (metavariable * constr * (instance_constraint * instance_typing_status)) list *
   (env * types pexistential * types) list -> evar_map
 
 val unify_0 :            Environ.env ->
            Evd.evar_map ->
            Evd.conv_pb ->
-           unify_flags ->
+           core_unify_flags ->
+           Term.types ->
+           Term.types ->
+           Evd.evar_map * Evd.metabinding list *
+           (Environ.env * Term.types Term.pexistential * Term.constr) list
+
+val unify_0_with_initial_metas : 
+           Evd.evar_map * Evd.metabinding list *
+           (Environ.env * Term.types Term.pexistential * Term.constr) list ->
+           bool ->
+           Environ.env ->
+           Evd.conv_pb ->
+           core_unify_flags ->
            Term.types ->
            Term.types ->
            Evd.evar_map * Evd.metabinding list *
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 047971d5..19613c4e 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -1,14 +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 Util
 open Names
 open Declarations
 open Term
+open Vars
 open Environ
 open Inductive
 open Reduction
@@ -22,8 +24,9 @@ let crazy_type =  mkSet
 
 let decompose_prod env t =
   let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in
-  if name = Anonymous then (Name (id_of_string "x"),dom,codom)
-  else res
+  match name with
+  | Anonymous -> (Name (Id.of_string "x"), dom, codom)
+  | Name _ -> res
 
 exception Find_at of int
 
@@ -34,7 +37,8 @@ let invert_tag cst tag reloc_tbl =
   try
     for j = 0 to Array.length reloc_tbl - 1 do
       let tagj,arity = reloc_tbl.(j) in
-      if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then
+      let no_arity = Int.equal arity 0 in
+      if Int.equal tag tagj && (cst && no_arity || not (cst || no_arity)) then
 	raise (Find_at j)
       else ()
     done;raise Not_found
@@ -44,30 +48,31 @@ let invert_tag cst tag reloc_tbl =
 let find_rectype_a env c =
   let (t, l) =
     let t = whd_betadeltaiota env c in
-    try destApp t with e when Errors.noncritical e -> (t,[||]) in
+    try destApp t with DestKO -> (t,[||]) in
   match kind_of_term t with
   | Ind ind -> (ind, l)
   | _ -> raise Not_found
 
 (* Instantiate inductives and parameters in constructor type *)
 
-let type_constructor mind mib typ params =
-  let s = ind_subst mind mib in
+let type_constructor mind mib u typ params =
+  let s = ind_subst mind mib u in
   let ctyp = substl s typ in
+  let ctyp = subst_instance_constr u ctyp in
   let nparams = Array.length params in
-  if nparams = 0 then ctyp
+  if Int.equal nparams 0 then ctyp
   else
     let _,ctyp = decompose_prod_n nparams ctyp in
-    substl (List.rev (Array.to_list params)) ctyp
+    substl (Array.rev_to_list params) ctyp
 
 
 
 let construct_of_constr const env tag typ =
-  let (mind,_ as ind), allargs = find_rectype_a env typ in
+  let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in
   (* spiwack : here be a branch for specific decompilation handled by retroknowledge *)
   try
     if const then
-      ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (Ind ind) tag),
+      ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkIndU indu) tag),
        typ) (*spiwack: this may need to be changed in case there are parameters in the
 	               type which may cause a constant value to have an arity.
 	               (type_constructor seems to be all about parameters actually)
@@ -80,8 +85,8 @@ let construct_of_constr const env tag typ =
     let nparams = mib.mind_nparams in
     let i = invert_tag const tag mip.mind_reloc_tbl in
     let params = Array.sub allargs 0 nparams in
-    let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in
-      (mkApp(mkConstruct(ind,i), params), ctyp)
+    let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in
+      (mkApp(mkConstructUi(indu,i), params), ctyp)
 
 let construct_of_constr_const env tag typ =
   fst (construct_of_constr true env tag typ)
@@ -91,7 +96,8 @@ let construct_of_constr_block = construct_of_constr false
 let constr_type_of_idkey env idkey =
   match idkey with
   | ConstKey cst ->
-      mkConst cst, Typeops.type_of_constant env cst
+    let const_type = Typeops.type_of_constant_in env cst in
+      mkConstU cst, const_type
   | VarKey id ->
       let (_,_,ty) = lookup_named id env in
       mkVar id, ty
@@ -100,30 +106,33 @@ let constr_type_of_idkey env idkey =
       let (_,_,ty) = lookup_rel n env in
       mkRel n, lift n ty
 
-let type_of_ind env ind =
-  type_of_inductive env (Inductive.lookup_mind_specif env ind)
+let type_of_ind env (ind, u) =
+  type_of_inductive env (Inductive.lookup_mind_specif env ind, u)
 
-let build_branches_type env (mind,_ as _ind) mib mip params dep p =
+let build_branches_type env (mind,_ as _ind) mib mip u params dep p =
   let rtbl = mip.mind_reloc_tbl in
   (* [build_one_branch i cty] construit le type de la ieme branche (commence
      a 0) et les lambda correspondant aux realargs *)
   let build_one_branch i cty =
-    let typi = type_constructor mind mib cty params in
-    let decl,indapp = decompose_prod_assum typi in
-    let ind,cargs = find_rectype_a env indapp in
+    let typi = type_constructor mind mib u cty params in
+    let decl,indapp = Reductionops.splay_prod env Evd.empty typi in
+    let decl_with_letin,_ = decompose_prod_assum typi in
+    let ((ind,u),cargs) = find_rectype_a env indapp in
     let nparams = Array.length params in
     let carity = snd (rtbl.(i)) in
     let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
     let codom =
-      let papp = mkApp(lift (List.length decl) p,crealargs) in
+      let ndecl = List.length decl in
+      let papp = mkApp(lift ndecl p,crealargs) in
       if dep then
 	let cstr = ith_constructor_of_inductive ind (i+1) in
         let relargs = Array.init carity (fun i -> mkRel (carity-i)) in
-	let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in
+	let params = Array.map (lift ndecl) params in
+	let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in
 	mkApp(papp,[|dep_cstr|])
       else papp
     in
-    decl, codom
+    decl, decl_with_letin, codom
   in Array.mapi build_one_branch mip.mind_nf_lc
 
 let build_case_type dep p realargs c =
@@ -141,7 +150,7 @@ and nf_whd env whd typ =
   | Vsort s -> mkSort s
   | Vprod p ->
       let dom = nf_vtype env (dom p) in
-      let name = Name (id_of_string "x") in
+      let name = Name (Id.of_string "x") in
       let vc = body_of_vfun (nb_rel env) (codom p) in
       let codom = nf_vtype (push_rel (name,None,dom) env) vc  in
       mkProd(name,dom,codom)
@@ -166,7 +175,7 @@ and nf_whd env whd typ =
   | Vatom_stk(Aiddef(idkey,v), stk) ->
       nf_whd env (whd_stack v stk) typ
   | Vatom_stk(Aind ind, stk) ->
-      nf_stk env (mkInd ind) (type_of_ind env ind) stk
+      nf_stk env (mkIndU ind) (type_of_ind env ind) stk
 
 and nf_stk env c t stk  =
   match stk with
@@ -176,28 +185,25 @@ and nf_stk env c t stk  =
       nf_stk env (mkApp(c,args)) t stk
   | Zfix (f,vargs) :: stk ->
       let fa, typ = nf_fix_app env f vargs in
-      let _,_,codom =
-        try decompose_prod env typ
-        with e when Errors.noncritical e -> exit 120
-      in
+      let _,_,codom = decompose_prod env typ in
       nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk
   | Zswitch sw :: stk ->
-      let (mind,_ as ind),allargs = find_rectype_a env t in
+      let ((mind,_ as ind), u), allargs = find_rectype_a env t in
       let (mib,mip) = Inductive.lookup_mind_specif env ind in
       let nparams = mib.mind_nparams in
-      let params,realargs = Util.array_chop nparams allargs in
+      let params,realargs = Util.Array.chop nparams allargs in
       let pT =
-	hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in
+	hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in
       let pT = whd_betadeltaiota env pT in
-      let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in
+      let dep, p = nf_predicate env (ind,u) mip params (type_of_switch sw) pT in
       (* Calcul du type des branches *)
-      let btypes = build_branches_type env ind mib mip params dep p in
+      let btypes = build_branches_type env ind mib mip u params dep p in
       (* calcul des branches *)
       let bsw = branch_of_switch (nb_rel env) sw in
       let mkbranch i (n,v) =
-	let decl,codom = btypes.(i) in
-	let b = nf_val (push_rel_context decl env) v codom in
-	it_mkLambda_or_LetIn b decl
+	let decl,decl_with_letin,codom = btypes.(i) in
+	let b = nf_val (Termops.push_rels_assum decl env) v codom in
+        Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin
       in
       let branchs = Array.mapi mkbranch bsw in
       let tcase = build_case_type dep p realargs c in
@@ -209,21 +215,18 @@ and nf_predicate env ind mip params v pT =
   | Vfun f, Prod _ ->
       let k = nb_rel env in
       let vb = body_of_vfun k f in
-      let name,dom,codom =
-        try decompose_prod env pT
-        with e when Errors.noncritical e -> exit 121
-      in
+      let name,dom,codom = decompose_prod env pT in
       let dep,body =
 	nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in
       dep, mkLambda(name,dom,body)
   | Vfun f, _ ->
       let k = nb_rel env in
       let vb = body_of_vfun k f in
-      let name = Name (id_of_string "c") in
+      let name = Name (Id.of_string "c") in
       let n = mip.mind_nrealargs in
       let rargs = Array.init n (fun i -> mkRel (n-i)) in
-      let params = if n=0 then params else Array.map (lift n) params in
-      let dom = mkApp(mkInd ind,Array.append params rargs) in
+      let params = if Int.equal n 0 then params else Array.map (lift n) params in
+      let dom = mkApp(mkIndU ind,Array.append params rargs) in
       let body = nf_vtype (push_rel (name,None,dom) env) vb in
       true, mkLambda(name,dom,body)
   | _, _ -> false, nf_val env v crazy_type
@@ -234,10 +237,7 @@ and nf_args env vargs t =
   let args =
     Array.init len
       (fun i ->
-	let _,dom,codom =
-          try decompose_prod env !t
-          with e when Errors.noncritical e -> exit 123
-        in
+	let _,dom,codom = decompose_prod env !t in
 	let c = nf_val env (arg vargs i) dom in
 	t := subst1 c codom; c) in
   !t,args
@@ -248,10 +248,7 @@ and nf_bargs env b t =
   let args =
     Array.init len
       (fun i ->
-	let _,dom,codom =
-          try decompose_prod env !t
-          with e when Errors.noncritical e -> exit 124
-        in
+	let _,dom,codom = decompose_prod env !t in
 	let c = nf_val env (bfield b i) dom in
 	t := subst1 c codom; c) in
   args
@@ -261,8 +258,10 @@ and nf_fun env f typ =
   let vb = body_of_vfun k f in
   let name,dom,codom =
     try decompose_prod env typ
-    with e when Errors.noncritical e ->
-      raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ))
+    with DestKO ->
+      (* 27/2/13: Turned this into an anomaly *)
+      Errors.anomaly
+        (Pp.strbrk "Returned a functional value in a type not recognized as a product type.")
   in
   let body = nf_val (push_rel (name,None,dom) env) vb codom in
   mkLambda(name,dom,body)
@@ -274,9 +273,13 @@ and nf_fix env f =
   let vb, vt = reduce_fix k f in
   let ndef = Array.length vt in
   let ft = Array.map (fun v -> nf_val env v crazy_type) vt in
-  let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in
+  let name = Array.init ndef (fun _ -> (Name (Id.of_string "Ffix"))) in
+  (* Third argument of the tuple is ignored by push_rec_types *)
   let env = push_rec_types (name,ft,ft) env in
-  let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in
+  (* We lift here because the types of arguments (in tt) will be evaluated
+     in an environment where the fixpoints have been pushed *)
+  let norm_vb v t = nf_fun env v (lift ndef t) in
+  let fb = Util.Array.map2 norm_vb vb ft in
   mkFix ((rec_args,init),(name,ft,fb))
 
 and nf_fix_app env f vargs =
@@ -292,9 +295,9 @@ and nf_cofix env cf =
   let vb,vt = reduce_cofix k cf in
   let ndef = Array.length vt in
   let cft = Array.map (fun v -> nf_val env v crazy_type) vt in
-  let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in
+  let name = Array.init ndef (fun _ -> (Name (Id.of_string "Fcofix"))) in
   let env = push_rec_types (name,cft,cft) env in
-  let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in
+  let cfb = Util.Array.map2 (fun v t -> nf_val env v t) vb cft in
   mkCoFix (init,(name,cft,cfb))
 
 let cbv_vm env c t  =
diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli
index a0cf2372..7dabbc6c 100644
--- a/pretyping/vnorm.mli
+++ b/pretyping/vnorm.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        *)
 (************************************************************************)
 
-open Names
 open Term
 open Environ
-open Reduction
 
 (** {6 Reduction functions } *)
 val cbv_vm : env -> constr -> types -> constr
diff --git a/printing/genprint.ml b/printing/genprint.ml
new file mode 100644
index 00000000..ade69ef8
--- /dev/null
+++ b/printing/genprint.ml
@@ -0,0 +1,45 @@
+(************************************************************************)
+(*  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 Pp
+open Genarg
+
+type ('raw, 'glb, 'top) printer = {
+  raw : 'raw -> std_ppcmds;
+  glb : 'glb -> std_ppcmds;
+  top : 'top -> std_ppcmds;
+}
+
+module PrintObj =
+struct
+  type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer
+  let name = "printer"
+  let default wit = match unquote (rawwit wit) with
+  | ExtraArgType name ->
+    let printer = {
+      raw = (fun _ -> str "<genarg:" ++ str name ++ str ">");
+      glb = (fun _ -> str "<genarg:" ++ str name ++ str ">");
+      top = (fun _ -> str "<genarg:" ++ str name ++ str ">");
+    } in
+    Some printer
+  | _ -> assert false
+end
+
+module Print = Register (PrintObj)
+
+let register_print0 wit raw glb top =
+  let printer = { raw; glb; top; } in
+  Print.register0 wit printer
+
+let raw_print wit v = (Print.obj wit).raw v
+let glb_print wit v = (Print.obj wit).glb v
+let top_print wit v = (Print.obj wit).top v
+
+let generic_raw_print v = unpack { unpacker = fun w v -> raw_print w (raw v); } v
+let generic_glb_print v = unpack { unpacker = fun w v -> glb_print w (glb v); } v
+let generic_top_print v = unpack { unpacker = fun w v -> top_print w (top v); } v
diff --git a/printing/genprint.mli b/printing/genprint.mli
new file mode 100644
index 00000000..5b91d6d2
--- /dev/null
+++ b/printing/genprint.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Entry point for generic printers *)
+
+open Pp
+open Genarg
+
+val raw_print : ('raw, 'glb, 'top) genarg_type -> 'raw -> std_ppcmds
+(** Printer for raw level generic arguments. *)
+
+val glb_print : ('raw, 'glb, 'top) genarg_type -> 'glb -> std_ppcmds
+(** Printer for glob level generic arguments. *)
+
+val top_print : ('raw, 'glb, 'top) genarg_type -> 'top -> std_ppcmds
+(** Printer for top level generic arguments. *)
+
+val generic_raw_print : rlevel generic_argument -> std_ppcmds
+val generic_glb_print : glevel generic_argument -> std_ppcmds
+val generic_top_print : tlevel generic_argument -> std_ppcmds
+
+val register_print0 : ('raw, 'glb, 'top) genarg_type ->
+  ('raw -> std_ppcmds) -> ('glb -> std_ppcmds) -> ('top -> std_ppcmds) -> unit
diff --git a/printing/miscprint.ml b/printing/miscprint.ml
new file mode 100644
index 00000000..d09af6d2
--- /dev/null
+++ b/printing/miscprint.ml
@@ -0,0 +1,49 @@
+(************************************************************************)
+(*  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 Misctypes
+open Pp
+
+(** Printing of [intro_pattern] *)
+
+let rec pr_intro_pattern prc (_,pat) = match pat with
+  | IntroForthcoming true -> str "*"
+  | IntroForthcoming false -> str "**"
+  | IntroNaming p -> pr_intro_pattern_naming p
+  | IntroAction p -> pr_intro_pattern_action prc p
+
+and pr_intro_pattern_naming = function
+  | IntroIdentifier id -> Nameops.pr_id id
+  | IntroFresh id -> str "?" ++ Nameops.pr_id id
+  | IntroAnonymous -> str "?"
+
+and pr_intro_pattern_action prc = function
+  | IntroWildcard -> str "_"
+  | IntroOrAndPattern pll -> pr_or_and_intro_pattern prc pll
+  | IntroInjection pl ->
+      str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++
+      str "]"
+  | IntroApplyOn (c,pat) -> pr_intro_pattern prc pat ++ str "/" ++ prc c
+  | IntroRewrite true -> str "->"
+  | IntroRewrite false -> str "<-"
+
+and pr_or_and_intro_pattern prc = function
+  | [pl] ->
+      str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")"
+  | pll ->
+      str "[" ++
+      hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll)
+      ++ str "]"
+
+(** Printing of [move_location] *)
+
+let pr_move_location pr_id = function
+  | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id
+  | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id
+  | MoveFirst -> str " at top"
+  | MoveLast -> str " at bottom"
diff --git a/lib/gmapl.ml b/printing/miscprint.mli
index 987ff9af..1d915ef8 100644
--- a/lib/gmapl.ml
+++ b/printing/miscprint.mli
@@ -1,33 +1,24 @@
 (************************************************************************)
 (*  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 Util
+open Misctypes
 
-type ('a,'b) t = ('a,'b list) Gmap.t
+(** Printing of [intro_pattern] *)
 
-let empty = Gmap.empty
-let mem = Gmap.mem
-let iter = Gmap.iter
-let map = Gmap.map
-let fold = Gmap.fold
+val pr_intro_pattern :
+  ('a -> Pp.std_ppcmds) -> 'a intro_pattern_expr Loc.located -> Pp.std_ppcmds
 
-let add x y m =
-  try
-    let l = Gmap.find x m in
-    Gmap.add x (y::list_except y l) m
-  with Not_found ->
-    Gmap.add x [y] m
+val pr_or_and_intro_pattern :
+  ('a -> Pp.std_ppcmds) -> 'a or_and_intro_pattern_expr -> Pp.std_ppcmds
 
-let find x m =
-  try Gmap.find x m with Not_found -> []
-
-let remove x y m =
-  let l = Gmap.find x m in
-  Gmap.add x (if List.mem y l then list_subtract l [y] else l) m
+val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.std_ppcmds
 
+(** Printing of [move_location] *)
 
+val pr_move_location :
+  ('a -> Pp.std_ppcmds) -> 'a move_location -> Pp.std_ppcmds
diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml
new file mode 100644
index 00000000..4f26b824
--- /dev/null
+++ b/printing/ppannotation.ml
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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 Ppextend
+open Constrexpr
+open Vernacexpr
+open Tacexpr
+
+type t =
+  | AKeyword
+  | AUnparsing            of unparsing
+  | AConstrExpr           of constr_expr
+  | AVernac               of vernac_expr
+  | AGlobTacticExpr       of glob_tactic_expr
+  | AGlobAtomicTacticExpr of glob_atomic_tactic_expr
+  | ARawTacticExpr        of raw_tactic_expr
+  | ARawAtomicTacticExpr  of raw_atomic_tactic_expr
+  | ATacticExpr           of tactic_expr
+  | AAtomicTacticExpr     of atomic_tactic_expr
+
+let tag_of_annotation = function
+  | AKeyword                -> "keyword"
+  | AUnparsing _            -> "unparsing"
+  | AConstrExpr _           -> "constr_expr"
+  | AVernac _               -> "vernac_expr"
+  | AGlobTacticExpr _       -> "glob_tactic_expr"
+  | AGlobAtomicTacticExpr _ -> "glob_atomic_tactic_expr"
+  | ARawTacticExpr _        -> "raw_tactic_expr"
+  | ARawAtomicTacticExpr _  -> "raw_atomic_tactic_expr"
+  | ATacticExpr _           -> "tactic_expr"
+  | AAtomicTacticExpr _     -> "atomic_tactic_expr"
+
+let attributes_of_annotation a =
+  []
+
+let tag = Pp.Tag.create "ppannotation"
diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli
new file mode 100644
index 00000000..bc345c34
--- /dev/null
+++ b/printing/ppannotation.mli
@@ -0,0 +1,33 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module defines the annotations that are attached to
+    semi-structured pretty-printing of Coq syntactic objects. *)
+
+open Ppextend
+open Constrexpr
+open Vernacexpr
+open Tacexpr
+
+type t =
+  | AKeyword
+  | AUnparsing            of unparsing
+  | AConstrExpr           of constr_expr
+  | AVernac               of vernac_expr
+  | AGlobTacticExpr       of glob_tactic_expr
+  | AGlobAtomicTacticExpr of glob_atomic_tactic_expr
+  | ARawTacticExpr        of raw_tactic_expr
+  | ARawAtomicTacticExpr  of raw_atomic_tactic_expr
+  | ATacticExpr           of tactic_expr
+  | AAtomicTacticExpr     of atomic_tactic_expr
+
+val tag_of_annotation : t -> string
+
+val attributes_of_annotation : t -> (string * string) list
+
+val tag : t Pp.Tag.key
diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
new file mode 100644
index 00000000..d9d8af66
--- /dev/null
+++ b/printing/ppconstr.ml
@@ -0,0 +1,812 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i*)
+open Errors
+open Util
+open Pp
+open Names
+open Nameops
+open Libnames
+open Pputils
+open Ppextend
+open Constrexpr
+open Constrexpr_ops
+open Decl_kinds
+open Misctypes
+(*i*)
+
+module Make (Taggers : sig
+  val tag_keyword     : std_ppcmds -> std_ppcmds
+  val tag_evar     : std_ppcmds -> std_ppcmds
+  val tag_type     : std_ppcmds -> std_ppcmds
+  val tag_path     : std_ppcmds -> std_ppcmds
+  val tag_ref     : std_ppcmds -> std_ppcmds
+  val tag_var     : std_ppcmds -> std_ppcmds
+  val tag_constr_expr : constr_expr -> std_ppcmds -> std_ppcmds
+  val tag_unparsing   : unparsing -> std_ppcmds -> std_ppcmds
+end) = struct
+
+  open Taggers
+
+  let keyword s = tag_keyword (str s)
+  let sep_v = fun _ -> str"," ++ spc()
+  let pr_tight_coma () = str "," ++ cut ()
+
+  let latom = 0
+  let lprod = 200
+  let llambda = 200
+  let lif = 200
+  let lletin = 200
+  let lletpattern = 200
+  let lfix = 200
+  let lcast = 100
+  let larg = 9
+  let lapp = 10
+  let lposint = 0
+  let lnegint = 35 (* must be consistent with Notation "- x" *)
+  let ltop = (200,E)
+  let lproj = 1
+  let ldelim = 1
+  let lsimpleconstr = (8,E)
+  let lsimplepatt = (1,E)
+
+  let prec_less child (parent,assoc) =
+    if parent < 0 && Int.equal child lprod then true
+    else
+      let parent = abs parent in
+      match assoc with
+        | E -> (<=) child parent
+        | L -> (<) child parent
+        | Prec n -> child<=n
+        | Any -> true
+
+  let prec_of_prim_token = function
+    | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint
+    | String _ -> latom
+
+  open Notation
+
+  let print_hunks n pr pr_binders (terms, termlists, binders) unps =
+    let env = ref terms and envlist = ref termlists and bll = ref binders in
+    let pop r = let a = List.hd !r in r := List.tl !r; a in
+    let return unp pp1 pp2 = (tag_unparsing unp pp1) ++ pp2 in
+    (* Warning:
+       The following function enforces a very precise order of
+       evaluation of sub-components.
+       Do not modify it unless you know what you are doing! *)
+    let rec aux = function
+      | [] ->
+        mt ()
+      | UnpMetaVar (_, prec) as unp :: l ->
+        let c = pop env in
+        let pp2 = aux l in
+        let pp1 = pr (n, prec) c in
+        return unp pp1 pp2
+      | UnpListMetaVar (_, prec, sl) as unp :: l ->
+        let cl = pop envlist in
+        let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in
+        let pp2 = aux l in
+        return unp pp1 pp2
+      | UnpBinderListMetaVar (_, isopen, sl) as unp :: l ->
+        let cl = pop bll in
+        let pp2 = aux l in
+        let pp1 = pr_binders (fun () -> aux sl) isopen cl in
+        return unp pp1 pp2
+      | UnpTerminal s as unp :: l ->
+        let pp2 = aux l in
+        let pp1 = str s in
+        return unp pp1 pp2
+      | UnpBox (b,sub) as unp :: l ->
+        let pp1 = ppcmd_of_box b (aux sub) in
+        let pp2 = aux l in
+        return unp pp1 pp2
+      | UnpCut cut as unp :: l ->
+        let pp2 = aux l in
+        let pp1 = ppcmd_of_cut cut in
+        return unp pp1 pp2
+    in
+    aux unps
+
+  let pr_notation pr pr_binders s env =
+    let unpl, level = find_notation_printing_rule s in
+    print_hunks level pr pr_binders env unpl, level
+
+  let pr_delimiters key strm =
+    strm ++ str ("%"^key)
+
+  let pr_generalization bk ak c =
+    let hd, tl =
+      match bk with
+        | Implicit -> "{", "}"
+        | Explicit -> "(", ")"
+    in (* TODO: syntax Abstraction Kind *)
+    str "`" ++ str hd ++ c ++ str tl
+
+  let pr_com_at n =
+    if Flags.do_beautify() && not (Int.equal n 0) then comment n
+    else mt()
+
+  let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp)
+
+  let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c)
+
+  let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
+
+  let pr_univ l =
+    match l with
+      | [x] -> str x
+      | l -> str"max(" ++ prlist_with_sep (fun () -> str",") str l ++ str")"
+
+  let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}"
+
+  let pr_glob_sort = function
+    | GProp -> tag_type (str "Prop")
+    | GSet -> tag_type (str "Set")
+    | GType [] -> tag_type (str "Type")
+    | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u)
+
+  let pr_qualid sp =
+    let (sl, id) = repr_qualid sp in
+    let id = tag_ref (str (Id.to_string id)) in
+    let sl = match List.rev (DirPath.repr sl) with
+    | [] -> mt ()
+    | sl ->
+      let pr dir = tag_path (str (Id.to_string dir)) ++ str "." in
+      prlist pr sl
+    in
+    sl ++ id
+
+  let pr_id = pr_id
+  let pr_name = pr_name
+  let pr_qualid = pr_qualid
+  let pr_patvar = pr_id
+
+  let pr_glob_sort_instance = function
+    | GProp ->
+      tag_type (str "Prop")
+    | GSet ->
+      tag_type (str "Set")
+    | GType u ->
+      (match u with
+        | Some u -> str u
+        | None -> tag_type (str "Type"))
+
+  let pr_universe_instance l =
+    pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l
+
+  let pr_reference = function
+  | Qualid (_, qid) -> pr_qualid qid
+  | Ident (_, id) -> tag_var (str (Id.to_string id))
+
+  let pr_cref ref us =
+    pr_reference ref ++ pr_universe_instance us
+
+  let pr_expl_args pr (a,expl) =
+    match expl with
+      | None -> pr (lapp,L) a
+      | Some (_,ExplByPos (n,_id)) ->
+        anomaly (Pp.str "Explicitation by position not implemented")
+      | Some (_,ExplByName id) ->
+        str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")"
+
+  let pr_opt_type pr = function
+    | CHole (_,_,Misctypes.IntroAnonymous,_) -> mt ()
+    | t -> cut () ++ str ":" ++ pr t
+
+  let pr_opt_type_spc pr = function
+    | CHole (_,_,Misctypes.IntroAnonymous,_) -> mt ()
+    | t ->  str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t
+
+  let pr_lident (loc,id) =
+    if not (Loc.is_ghost loc) then
+      let (b,_) = Loc.unloc loc in
+      pr_located pr_id (Loc.make_loc (b,b + String.length (Id.to_string id)), id)
+    else
+      pr_id id
+
+  let pr_lname = function
+    | (loc,Name id) -> pr_lident (loc,id)
+    | lna -> pr_located pr_name lna
+
+  let pr_or_var pr = function
+    | ArgArg x -> pr x
+    | ArgVar (loc,s) -> pr_lident (loc,s)
+
+  let pr_prim_token = function
+    | Numeral n -> str (Bigint.to_string n)
+    | String s -> qs s
+
+  let pr_evar pr id l =
+    hov 0 (
+      tag_evar (str "?" ++ pr_id id) ++
+        (match l with
+          | [] -> mt()
+          | l ->
+            let f (id,c) = pr_id id ++ str ":=" ++ pr ltop c in
+            str"@{" ++ hov 0 (prlist_with_sep pr_semicolon f (List.rev l)) ++ str"}"))
+
+  let las = lapp
+  let lpator = 100
+  let lpatrec = 0
+
+  let rec pr_patt sep inh p =
+    let (strm,prec) = match p with
+      | CPatRecord (_, l) ->
+        let pp (c, p) =
+          pr_reference c ++ spc() ++ str ":=" ++ pr_patt spc (lpatrec, Any) p
+        in
+        str "{| " ++ prlist_with_sep pr_semicolon pp l ++ str " |}", lpatrec
+
+      | CPatAlias (_, p, id) ->
+        pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las
+
+      | CPatCstr (_,c, [], []) ->
+        pr_reference c, latom
+
+      | CPatCstr (_, c, [], args) ->
+        pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
+
+      | CPatCstr (_, c, args, []) ->
+        str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp
+
+      | CPatCstr (_, c, expl_args, extra_args) ->
+        surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args)
+        ++ prlist (pr_patt spc (lapp,L)) extra_args, lapp
+
+      | CPatAtom (_, None) ->
+        str "_", latom
+
+      | CPatAtom (_,Some r) ->
+        pr_reference r, latom
+
+      | CPatOr (_,pl) ->
+        hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
+
+      | CPatNotation (_,"( _ )",([p],[]),[]) ->
+        pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
+
+      | CPatNotation (_,s,(l,ll),args) ->
+        let strm_not, l_not = pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[]) in
+        (if List.is_empty args||prec_less l_not (lapp,L) then strm_not else surround strm_not)
+        ++ prlist (pr_patt spc (lapp,L)) args, if not (List.is_empty args) then lapp else l_not
+
+      | CPatPrim (_,p) ->
+        pr_prim_token p, latom
+
+      | CPatDelimiters (_,k,p) ->
+        pr_delimiters k (pr_patt mt lsimplepatt p), 1
+    in
+    let loc = cases_pattern_expr_loc p in
+    pr_with_comments loc
+      (sep() ++ if prec_less prec inh then strm else surround strm)
+
+  let pr_patt = pr_patt mt
+
+  let pr_eqn pr (loc,pl,rhs) =
+    let pl = List.map snd pl in
+    spc() ++ hov 4
+      (pr_with_comments loc
+         (str "| " ++
+            hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl
+                   ++ str " =>") ++
+            pr_sep_com spc (pr ltop) rhs))
+
+  let begin_of_binder = function
+  LocalRawDef((loc,_),_) -> fst (Loc.unloc loc)
+    | LocalRawAssum((loc,_)::_,_,_) -> fst (Loc.unloc loc)
+    | _ -> assert false
+
+  let begin_of_binders = function
+    | b::_ -> begin_of_binder b
+    | _ -> 0
+
+  let surround_impl k p =
+    match k with
+      | Explicit -> str"(" ++ p ++ str")"
+      | Implicit -> str"{" ++ p ++ str"}"
+
+  let surround_implicit k p =
+    match k with
+      | Explicit -> p
+      | Implicit -> (str"{" ++ p ++ str"}")
+
+  let pr_binder many pr (nal,k,t) =
+    match k with
+      | Generalized (b, b', t') ->
+        assert (match b with Implicit -> true | _ -> false);
+        begin match nal with
+          |[loc,Anonymous] ->
+            hov 1 (str"`" ++ (surround_impl b'
+                                ((if t' then str "!" else mt ()) ++ pr t)))
+          |[loc,Name id] ->
+            hov 1 (str "`" ++ (surround_impl b'
+                                 (pr_lident (loc,id) ++ str " : " ++
+                                    (if t' then str "!" else mt()) ++ pr t)))
+          |_ -> anomaly (Pp.str "List of generalized binders have alwais one element.")
+        end
+      | Default b ->
+        match t with
+          | CHole (_,_,Misctypes.IntroAnonymous,_) ->
+            let s = prlist_with_sep spc pr_lname nal in
+            hov 1 (surround_implicit b s)
+          | _ ->
+            let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in
+            hov 1 (if many then surround_impl b s else surround_implicit b s)
+
+  let pr_binder_among_many pr_c = function
+    | LocalRawAssum (nal,k,t) ->
+      pr_binder true pr_c (nal,k,t)
+    | LocalRawDef (na,c) ->
+      let c,topt = match c with
+        | CCast(_,c, (CastConv t|CastVM t|CastNative t)) -> c, t
+        | _ -> c, CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
+      surround (pr_lname na ++ pr_opt_type pr_c topt ++
+                  str":=" ++ cut() ++ pr_c c)
+
+  let pr_undelimited_binders sep pr_c =
+    prlist_with_sep sep (pr_binder_among_many pr_c)
+
+  let pr_delimited_binders kw sep pr_c bl =
+    let n = begin_of_binders bl in
+    match bl with
+      | [LocalRawAssum (nal,k,t)] ->
+        pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t)
+      | LocalRawAssum _ :: _ as bdl ->
+        pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl
+      | _ -> assert false
+
+  let pr_binders_gen pr_c sep is_open =
+    if is_open then pr_delimited_binders mt sep pr_c
+    else pr_undelimited_binders sep pr_c
+
+  let rec extract_prod_binders = function
+  (*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_prod_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+    | CProdN (loc,[],c) ->
+      extract_prod_binders c
+    | CProdN (loc,(nal,bk,t)::bl,c) ->
+      let bl,c = extract_prod_binders (CProdN(loc,bl,c)) in
+      LocalRawAssum (nal,bk,t) :: bl, c
+    | c -> [], c
+
+  let rec extract_lam_binders = function
+  (*  | CLetIn (loc,na,b,c) as x ->
+      let bl,c = extract_lam_binders c in
+      if bl = [] then [], x else LocalRawDef (na,b) :: bl, c*)
+    | CLambdaN (loc,[],c) ->
+      extract_lam_binders c
+    | CLambdaN (loc,(nal,bk,t)::bl,c) ->
+      let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in
+      LocalRawAssum (nal,bk,t) :: bl, c
+    | c -> [], c
+
+  let split_lambda = function
+    | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c)
+    | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c))
+    | CLambdaN (loc,(na::nal,bk,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,bk,t)::bl,c))
+    | _ -> anomaly (Pp.str "ill-formed fixpoint body")
+
+  let rename na na' t c =
+    match (na,na') with
+      | (_,Name id), (_,Name id') ->
+        (na',t,Topconstr.replace_vars_constr_expr (Id.Map.singleton id id') c)
+      | (_,Name id), (_,Anonymous) -> (na,t,c)
+      | _ -> (na',t,c)
+
+  let split_product na' = function
+    | CProdN (loc,[[na],bk,t],c) -> rename na na' t c
+    | CProdN (loc,([na],bk,t)::bl,c) -> rename na na' t (CProdN(loc,bl,c))
+    | CProdN (loc,(na::nal,bk,t)::bl,c) ->
+      rename na na' t (CProdN(loc,(nal,bk,t)::bl,c))
+    | _ -> anomaly (Pp.str "ill-formed fixpoint body")
+
+  let rec split_fix n typ def =
+    if Int.equal n 0 then ([],typ,def)
+    else
+      let (na,_,def) = split_lambda def in
+      let (na,t,typ) = split_product na typ in
+      let (bl,typ,def) = split_fix (n-1) typ def in
+      (LocalRawAssum ([na],default_binder_kind,t)::bl,typ,def)
+
+  let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
+    let pr_body =
+      if dangling_with_for then pr_dangling else pr in
+    pr_id id ++ str" " ++
+      hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++
+      pr_opt_type_spc pr t ++ str " :=" ++
+      pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
+
+  let pr_guard_annot pr_aux bl (n,ro) =
+    match n with
+      | None -> mt ()
+      | Some (loc, id) ->
+        match (ro : Constrexpr.recursion_order_expr) with
+          | CStructRec ->
+            let names_of_binder = function
+              | LocalRawAssum (nal,_,_) -> nal
+              | LocalRawDef (_,_) -> []
+            in let ids = List.flatten (List.map names_of_binder bl) in
+               if List.length ids > 1 then
+                 spc() ++ str "{" ++ keyword "struct" ++ spc () ++ pr_id id ++ str"}"
+               else mt()
+          | CWfRec c ->
+            spc() ++ str "{" ++ keyword "wf" ++ spc () ++ pr_aux c ++ spc() ++ pr_id id ++ str"}"
+          | CMeasureRec (m,r) ->
+            spc() ++ str "{" ++ keyword "measure" ++ spc () ++ pr_aux m ++ spc() ++ pr_id id++
+              (match r with None -> mt() | Some r -> str" on " ++ pr_aux r) ++ str"}"
+
+  let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) =
+    let annot = pr_guard_annot (pr lsimpleconstr) bl ro in
+    pr_recursive_decl pr prd dangling_with_for id bl annot t c
+
+  let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =
+    pr_recursive_decl pr prd dangling_with_for id bl (mt()) t c
+
+  let pr_recursive pr_decl id = function
+    | [] -> anomaly (Pp.str "(co)fixpoint with no definition")
+    | [d1] -> pr_decl false d1
+    | dl ->
+      prlist_with_sep (fun () -> fnl() ++ keyword "with" ++ spc ())
+        (pr_decl true) dl ++
+        fnl() ++ keyword "for" ++ spc () ++ pr_id id
+
+  let pr_asin pr (na,indnalopt) =
+    (match na with (* Decision of printing "_" or not moved to constrextern.ml *)
+      | Some na -> spc () ++ keyword "as" ++ spc () ++  pr_lname na
+      | None -> mt ()) ++
+      (match indnalopt with
+        | None -> mt ()
+        | Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt lsimplepatt t)
+
+  let pr_case_item pr (tm,asin) =
+    hov 0 (pr (lcast,E) tm ++ pr_asin pr asin)
+
+  let pr_case_type pr po =
+    match po with
+      | None | Some (CHole (_,_,Misctypes.IntroAnonymous,_)) -> mt()
+      | Some p ->
+        spc() ++ hov 2 (keyword "return" ++ pr_sep_com spc (pr lsimpleconstr) p)
+
+  let pr_simple_return_type pr na po =
+    (match na with
+      | Some (_,Name id) ->
+        spc () ++ keyword "as" ++ spc () ++ pr_id id
+      | _ -> mt ()) ++
+      pr_case_type pr po
+
+  let pr_proj pr pr_app a f l =
+    hov 0 (pr (lproj,E) a ++ cut() ++ str ".(" ++ pr_app pr f l ++ str ")")
+
+  let pr_appexpl pr (f,us) l =
+    hov 2 (
+      str "@" ++ pr_reference f ++
+        pr_universe_instance us ++
+        prlist (pr_sep_com spc (pr (lapp,L))) l)
+
+  let pr_app pr a l =
+    hov 2 (
+      pr (lapp,L) a  ++
+        prlist (fun a -> spc () ++ pr_expl_args pr a) l)
+
+  let pr_forall () = keyword "forall" ++ spc ()
+
+  let pr_fun () = keyword "fun" ++ spc ()
+
+  let pr_fun_sep = spc () ++ str "=>"
+
+  let pr_dangling_with_for sep pr inherited a =
+    match a with
+      | (CFix (_,_,[_])|CCoFix(_,_,[_])) ->
+        pr sep (latom,E) a
+      | _ ->
+        pr sep inherited a
+
+  let pr pr sep inherited a =
+    let return (cmds, prec) = (tag_constr_expr a cmds, prec) in
+    let (strm, prec) = match a with
+      | CRef (r, us) ->
+        return (pr_cref r us, latom)
+      | CFix (_,id,fix) ->
+        return (
+          hov 0 (keyword "fix" ++ spc () ++
+                   pr_recursive
+                   (pr_fixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) fix),
+          lfix
+        )
+      | CCoFix (_,id,cofix) ->
+        return (
+          hov 0 (keyword "cofix" ++ spc () ++
+                   pr_recursive
+                   (pr_cofixdecl (pr mt) (pr_dangling_with_for mt pr)) (snd id) cofix),
+          lfix
+        )
+      | CProdN _ ->
+        let (bl,a) = extract_prod_binders a in
+        return (
+          hov 0 (
+            hov 2 (pr_delimited_binders pr_forall spc
+                     (pr mt ltop) bl) ++
+              str "," ++ pr spc ltop a),
+          lprod
+        )
+      | CLambdaN _ ->
+        let (bl,a) = extract_lam_binders a in
+        return (
+          hov 0 (
+            hov 2 (pr_delimited_binders pr_fun spc
+                     (pr mt ltop) bl) ++
+              pr_fun_sep ++ pr spc ltop a),
+          llambda
+        )
+      | CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
+          when Id.equal x x' ->
+        return (
+          hv 0 (
+            hov 2 (keyword "let" ++ spc () ++ pr mt ltop fx
+                   ++ spc ()
+                   ++ keyword "in") ++
+              pr spc ltop b),
+          lletin
+        )
+      | CLetIn (_,x,a,b) ->
+        return (
+          hv 0 (
+            hov 2 (keyword "let" ++ spc () ++ pr_lname x ++ str " :="
+                   ++ pr spc ltop a ++ spc ()
+                   ++ keyword "in") ++
+              pr spc ltop b),
+          lletin
+        )
+      | CAppExpl (_,(Some i,f,us),l) ->
+        let l1,l2 = List.chop i l in
+        let c,l1 = List.sep_last l1 in
+        let p = pr_proj (pr mt) pr_appexpl c (f,us) l1 in
+        if not (List.is_empty l2) then
+          return (p ++ prlist (pr spc (lapp,L)) l2, lapp)
+        else
+          return (p, lproj)
+      | CAppExpl (_,(None,Ident (_,var),us),[t])
+      | CApp (_,(_,CRef(Ident(_,var),us)),[t,None])
+          when Id.equal var Notation_ops.ldots_var ->
+        return (
+          hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."),
+          larg
+        )
+      | CAppExpl (_,(None,f,us),l) ->
+        return (pr_appexpl (pr mt) (f,us) l, lapp)
+      | CApp (_,(Some i,f),l) ->
+        let l1,l2 = List.chop i l in
+        let c,l1 = List.sep_last l1 in
+        assert (Option.is_empty (snd c));
+        let p = pr_proj (pr mt) pr_app (fst c) f l1 in
+        if not (List.is_empty l2) then
+          return (
+            p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2,
+            lapp
+          )
+        else
+          return (p, lproj)
+      | CApp (_,(None,a),l) ->
+        return (pr_app (pr mt) a l, lapp)
+      | CRecord (_,w,l) ->
+        let beg =
+          match w with
+            | None ->
+              spc ()
+            | Some t ->
+              spc () ++ pr spc ltop t ++ spc ()
+              ++ keyword "with" ++ spc ()
+        in
+        return (
+          hv 0 (str"{|" ++ beg ++
+                  prlist_with_sep pr_semicolon
+                  (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l
+                ++ str" |}"),
+          latom
+        )
+      | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) ->
+        return (
+          hv 0 (
+            keyword "let" ++ spc () ++ str"'" ++
+              hov 0 (pr_patt ltop p ++
+                       pr_asin (pr_dangling_with_for mt pr) asin ++
+                       str " :=" ++ pr spc ltop c ++
+                       pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++
+                       spc () ++ keyword "in" ++ pr spc ltop b)),
+          lletpattern
+        )
+      | CCases(_,_,rtntypopt,c,eqns) ->
+        return (
+          v 0
+            (hv 0 (keyword "match" ++ brk (1,2) ++
+                     hov 0 (
+                       prlist_with_sep sep_v
+                         (pr_case_item (pr_dangling_with_for mt pr)) c
+                       ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt) ++
+                     spc () ++ keyword "with") ++
+               prlist (pr_eqn (pr mt)) eqns ++ spc()
+             ++ keyword "end"),
+          latom
+        )
+      | CLetTuple (_,nal,(na,po),c,b) ->
+        return (
+          hv 0 (
+            keyword "let" ++ spc () ++
+              hov 0 (str "(" ++
+                       prlist_with_sep sep_v pr_lname nal ++
+                       str ")" ++
+                       pr_simple_return_type (pr mt) na po ++ str " :=" ++
+                       pr spc ltop c ++ spc ()
+                     ++ keyword "in") ++
+              pr spc ltop b),
+          lletin
+        )
+      | CIf (_,c,(na,po),b1,b2) ->
+      (* On force les parenthèses autour d'un "if" sous-terme (même si le
+         parsing est lui plus tolérant) *)
+        return (
+          hv 0 (
+            hov 1 (keyword "if" ++ spc () ++ pr mt ltop c
+                   ++ pr_simple_return_type (pr mt) na po) ++
+              spc () ++
+              hov 0 (keyword "then"
+                     ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++
+              hov 0 (keyword "else" ++ pr (fun () -> brk (1,1)) ltop b2)),
+        lif
+        )
+
+      | CHole (_,_,Misctypes.IntroIdentifier id,_) ->
+        return (str "?[" ++ pr_id id ++ str "]", latom)
+      | CHole (_,_,Misctypes.IntroFresh id,_) ->
+        return (str "?[?" ++ pr_id id ++ str "]", latom)
+      | CHole (_,_,_,_) ->
+        return (str "_", latom)
+      | CEvar (_,n,l) ->
+        return (pr_evar (pr mt) n l, latom)
+      | CPatVar (_,p) ->
+        return (str "?" ++ pr_patvar p, latom)
+      | CSort (_,s) ->
+        return (pr_glob_sort s, latom)
+      | CCast (_,a,b) ->
+        return (
+          hv 0 (pr mt (lcast,L) a ++ cut () ++
+                  match b with
+                    | CastConv b -> str ":" ++ pr mt (-lcast,E) b
+                    | CastVM b -> str "<:" ++ pr mt (-lcast,E) b
+                    | CastNative b -> str "<<:" ++ pr mt (-lcast,E) b
+                    | CastCoerce -> str ":>"),
+          lcast
+        )
+      | CNotation (_,"( _ )",([t],[],[])) ->
+        return (pr (fun()->str"(") (max_int,L) t ++ str")", latom)
+      | CNotation (_,s,env) ->
+        pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env
+      | CGeneralization (_,bk,ak,c) ->
+        return (pr_generalization bk ak (pr mt ltop c), latom)
+      | CPrim (_,p) ->
+        return (pr_prim_token p, prec_of_prim_token p)
+      | CDelimiters (_,sc,a) ->
+        return (pr_delimiters sc (pr mt (ldelim,E) a), ldelim)
+    in
+    let loc = constr_loc a in
+    pr_with_comments loc
+      (sep() ++ if prec_less prec inherited then strm else surround strm)
+
+  type term_pr = {
+    pr_constr_expr   : constr_expr -> std_ppcmds;
+    pr_lconstr_expr  : constr_expr -> std_ppcmds;
+    pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
+    pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+  }
+
+  type precedence =  Ppextend.precedence * Ppextend.parenRelation
+  let modular_constr_pr = pr
+  let rec fix rf x = rf (fix rf) x
+  let pr = fix modular_constr_pr mt
+
+  let transf env c =
+    if !Flags.beautify_file then
+      let r = Constrintern.for_grammar (Constrintern.intern_constr env) c in
+      Constrextern.extern_glob_constr (Termops.vars_of_env env) r
+    else c
+
+  let pr prec c = pr prec (transf (Global.env()) c)
+
+  let pr_simpleconstr = function
+    | CAppExpl (_,(None,f,us),[]) -> str "@" ++ pr_cref f us
+    | c -> pr lsimpleconstr c
+
+  let default_term_pr = {
+    pr_constr_expr   = pr_simpleconstr;
+    pr_lconstr_expr  = pr ltop;
+    pr_constr_pattern_expr  = pr_simpleconstr;
+    pr_lconstr_pattern_expr = pr ltop
+  }
+
+  let term_pr = ref default_term_pr
+
+  let set_term_pr = (:=) term_pr
+
+  let pr_constr_expr c   = !term_pr.pr_constr_expr   c
+  let pr_lconstr_expr c  = !term_pr.pr_lconstr_expr  c
+  let pr_constr_pattern_expr c  = !term_pr.pr_constr_pattern_expr  c
+  let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c
+
+  let pr_cases_pattern_expr = pr_patt ltop
+
+  let pr_binders = pr_undelimited_binders spc (pr ltop)
+
+end
+
+module Tag =
+struct
+  let keyword =
+    let style = Terminal.make ~bold:true () in
+    Ppstyle.make ~style ["constr"; "keyword"]
+
+  let evar =
+    let style = Terminal.make ~fg_color:`LIGHT_BLUE () in
+    Ppstyle.make ~style ["constr"; "evar"]
+
+  let univ =
+    let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in
+    Ppstyle.make ~style ["constr"; "type"]
+
+  let notation =
+    let style = Terminal.make ~fg_color:`WHITE () in
+    Ppstyle.make ~style ["constr"; "notation"]
+
+  let variable =
+    Ppstyle.make ["constr"; "variable"]
+
+  let reference =
+    let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
+    Ppstyle.make ~style ["constr"; "reference"]
+
+  let path =
+    let style = Terminal.make ~fg_color:`LIGHT_MAGENTA () in
+    Ppstyle.make ~style ["constr"; "path"]
+
+end
+
+let do_not_tag _ x = x
+
+(** Instantiating Make with tagging functions that only add style
+    information. *)
+include Make (struct
+    let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
+    let tag_keyword     = tag Tag.keyword
+    let tag_evar        = tag Tag.evar
+    let tag_type        = tag Tag.univ
+    let tag_unparsing   = function
+    | UnpTerminal s -> tag Tag.notation
+    | _ -> do_not_tag ()
+    let tag_constr_expr = do_not_tag
+    let tag_path = tag Tag.path
+    let tag_ref = tag Tag.reference
+    let tag_var = tag Tag.variable
+end)
+
+module Richpp = struct
+
+  include Make (struct
+    open Ppannotation
+    let tag_keyword       = Pp.tag (Pp.Tag.inj AKeyword tag)
+    let tag_type          = Pp.tag (Pp.Tag.inj AKeyword tag)
+    let tag_evar          = do_not_tag ()
+    let tag_unparsing unp = Pp.tag (Pp.Tag.inj (AUnparsing unp) tag)
+    let tag_constr_expr e = Pp.tag (Pp.Tag.inj (AConstrExpr e) tag)
+    let tag_path = do_not_tag ()
+    let tag_ref = do_not_tag ()
+    let tag_var = do_not_tag ()
+  end)
+
+end
+
diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli
new file mode 100644
index 00000000..6e8d3b04
--- /dev/null
+++ b/printing/ppconstr.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module implements pretty-printers for constr_expr syntactic
+    objects and their subcomponents. *)
+
+(** The default pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as raw strings. *)
+include Ppconstrsig.Pp
+
+(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as annotated strings. The annotations can be
+    retrieved using {!RichPp.rich_pp}. Their definitions are
+    located in {!Ppannotation.t}. *)
+
+module Richpp : Ppconstrsig.Pp
diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli
new file mode 100644
index 00000000..15413d51
--- /dev/null
+++ b/printing/ppconstrsig.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  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 Loc
+open Pp
+open Libnames
+open Constrexpr
+open Names
+open Misctypes
+open Locus
+open Genredexpr
+
+module type Pp = sig
+
+  val extract_lam_binders :
+    constr_expr -> local_binder list * constr_expr
+  val extract_prod_binders :
+    constr_expr -> local_binder list * constr_expr
+  val split_fix :
+    int -> constr_expr -> constr_expr ->
+    local_binder list *  constr_expr * constr_expr
+
+  val prec_less : int -> int * Ppextend.parenRelation -> bool
+
+  val pr_tight_coma : unit -> std_ppcmds
+
+  val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+
+  val pr_lident : Id.t located -> std_ppcmds
+  val pr_lname : Name.t located -> std_ppcmds
+
+  val pr_with_comments : Loc.t -> std_ppcmds -> std_ppcmds
+  val pr_com_at : int -> std_ppcmds
+  val pr_sep_com :
+    (unit -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    constr_expr -> std_ppcmds
+
+  val pr_id : Id.t -> std_ppcmds
+  val pr_name : Name.t -> std_ppcmds
+  val pr_qualid : qualid -> std_ppcmds
+  val pr_patvar : patvar -> std_ppcmds
+
+  val pr_glob_sort : glob_sort -> std_ppcmds
+  val pr_guard_annot : (constr_expr -> std_ppcmds) ->
+    local_binder list ->
+    ('a * Names.Id.t) option * recursion_order_expr ->
+    std_ppcmds
+
+  val pr_binders : local_binder list -> std_ppcmds
+  val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds
+  val pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+  val pr_constr_expr : constr_expr -> std_ppcmds
+  val pr_lconstr_expr : constr_expr -> std_ppcmds
+  val pr_cases_pattern_expr : cases_pattern_expr -> std_ppcmds
+
+  type term_pr = {
+    pr_constr_expr   : constr_expr -> std_ppcmds;
+    pr_lconstr_expr  : constr_expr -> std_ppcmds;
+    pr_constr_pattern_expr  : constr_pattern_expr -> std_ppcmds;
+    pr_lconstr_pattern_expr : constr_pattern_expr -> std_ppcmds
+  }
+
+  val set_term_pr : term_pr -> unit
+  val default_term_pr : term_pr
+
+(** The modular constr printer.
+    [modular_constr_pr pr s p t] prints the head of the term [t] and calls
+    [pr] on its subterms.
+    [s] is typically {!Pp.mt} and [p] is [lsimpleconstr] for "constr" printers
+    and [ltop] for "lconstr" printers (spiwack: we might need more
+    specification here).
+    We can make a new modular constr printer by overriding certain branches,
+    for instance if we want to build a printer which prints "Prop" as "Omega"
+    instead we can proceed as follows:
+    let my_modular_constr_pr pr s p = function
+    | CSort (_,GProp Null) -> str "Omega"
+    | t -> modular_constr_pr pr s p t
+    Which has the same type. We can turn a modular printer into a printer by
+    taking its fixpoint. *)
+
+  type precedence
+  val lsimpleconstr : precedence
+  val ltop : precedence
+  val modular_constr_pr :
+    ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) ->
+    (unit->std_ppcmds) -> precedence  -> constr_expr -> std_ppcmds
+
+end
+
diff --git a/printing/ppstyle.ml b/printing/ppstyle.ml
new file mode 100644
index 00000000..fb334c70
--- /dev/null
+++ b/printing/ppstyle.ml
@@ -0,0 +1,149 @@
+(************************************************************************)
+(*  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 Util
+
+type t = string
+(** We use the concatenated string, with dots separating each string. We
+    forbid the use of dots in the strings. *)
+
+let tags : Terminal.style option String.Map.t ref = ref String.Map.empty
+
+let make ?style tag =
+  let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in
+  let () = List.iter check tag in
+  let name = String.concat "." tag in
+  let () = assert (not (String.Map.mem name !tags)) in
+  let () = tags := String.Map.add name style !tags in
+  name
+
+let repr t = String.split '.' t
+
+let get_style tag =
+  try String.Map.find tag !tags with Not_found -> assert false
+
+let set_style tag st =
+  try tags := String.Map.update tag st !tags with Not_found -> assert false
+
+let clear_styles () =
+  tags := String.Map.map (fun _ -> None) !tags
+
+let dump () = String.Map.bindings !tags
+
+let parse_config s =
+  let styles = Terminal.parse s in
+  let set accu (name, st) =
+    try String.Map.update name (Some st) accu with Not_found -> accu
+  in
+  tags := List.fold_left set !tags styles
+
+let tag = Pp.Tag.create "ppstyle"
+
+(** Default tag is to reset everything *)
+let default = Terminal.({
+  fg_color = Some `DEFAULT;
+  bg_color = Some `DEFAULT;
+  bold = Some false;
+  italic = Some false;
+  underline = Some false;
+  negative = Some false;
+})
+
+let empty = Terminal.make ()
+
+let make_style_stack style_tags =
+  (** Not thread-safe. We should put a lock somewhere if we print from
+      different threads. Do we? *)
+  let style_stack = ref [] in
+  let peek () = match !style_stack with
+  | [] -> default (** Anomalous case, but for robustness *)
+  | st :: _ -> st
+  in
+  let push tag =
+    let style =
+      try
+        begin match String.Map.find tag style_tags with
+        | None -> empty
+        | Some st -> st
+        end
+      with Not_found -> empty
+    in
+    (** Use the merging of the latest tag and the one being currently pushed.
+    This may be useful if for instance the latest tag changes the background and
+    the current one the foreground, so that the two effects are additioned. *)
+    let style = Terminal.merge (peek ()) style in
+    let () = style_stack := style :: !style_stack in
+    Terminal.eval style
+  in
+  let pop _ = match !style_stack with
+  | [] ->
+    (** Something went wrong, we fallback *)
+    Terminal.eval default
+  | _ :: rem ->
+    let () = style_stack := rem in
+    Terminal.eval (peek ())
+  in
+  let clear () = style_stack := [] in
+  push, pop, clear
+
+let error_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in
+  make ~style ["message"; "error"]
+
+let warning_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in
+  make ~style ["message"; "warning"]
+
+let debug_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in
+  make ~style ["message"; "debug"]
+
+let pp_tag t = match Pp.Tag.prj t tag with
+| None -> ""
+| Some key -> key
+
+let init_color_output () =
+  let push_tag, pop_tag, clear_tag = make_style_stack !tags in
+  let tag_handler = {
+    Format.mark_open_tag = push_tag;
+    Format.mark_close_tag = pop_tag;
+    Format.print_open_tag = ignore;
+    Format.print_close_tag = ignore;
+  } in
+  let open Pp_control in
+  let () = Format.pp_set_mark_tags !std_ft true in
+  let () = Format.pp_set_mark_tags !err_ft true in
+  let () = Format.pp_set_formatter_tag_functions !std_ft tag_handler in
+  let () = Format.pp_set_formatter_tag_functions !err_ft tag_handler in
+  let pptag = tag in
+  let open Pp in
+  let msg ?header ft strm =
+    let strm = match header with
+    | None -> hov 0 strm
+    | Some (h, t) ->
+      let tag = Pp.Tag.inj t pptag in
+      let h = Pp.tag tag (str h ++ str ":") in
+      hov 0 (h ++ spc () ++ strm)
+    in
+    pp_with ~pp_tag ft strm;
+    Format.pp_print_newline ft ();
+    Format.pp_print_flush ft ();
+    (** In case something went wrong, we reset the stack *)
+    clear_tag ();
+  in
+  let logger level strm = match level with
+  | Debug _ -> msg ~header:("Debug", debug_tag) !std_ft strm
+  | Info -> msg !std_ft strm
+  | Notice -> msg !std_ft strm
+  | Warning ->
+    let header = ("Warning", warning_tag) in
+    Flags.if_warn (fun () -> msg ~header !err_ft strm) ()
+  | Error -> msg ~header:("Error", error_tag) !err_ft strm
+  in
+  let () = set_logger logger in
+  ()
diff --git a/printing/ppstyle.mli b/printing/ppstyle.mli
new file mode 100644
index 00000000..f5d6184c
--- /dev/null
+++ b/printing/ppstyle.mli
@@ -0,0 +1,70 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Highlighting of printers. Used for pretty-printing terms that should be
+    displayed on a color-capable terminal. *)
+
+(** {5 Style tags} *)
+
+type t
+(** Style tags *)
+
+val make : ?style:Terminal.style -> string list -> t
+(** Create a new tag with the given name. Each name must be unique. The optional
+    style is taken as the default one. *)
+
+val repr : t -> string list
+(** Gives back the original name of the style tag where each string has been
+    concatenated and separated with a dot. *)
+
+val tag : t Pp.Tag.key
+(** An annotation for styles *)
+
+(** {5 Manipulating global styles} *)
+
+val get_style : t -> Terminal.style option
+(** Get the style associated to a tag. *)
+
+val set_style : t -> Terminal.style option -> unit
+(** Set a style associated to a tag. *)
+
+val clear_styles : unit -> unit
+(** Clear all styles. *)
+
+val parse_config : string -> unit
+(** Add all styles from the given string as parsed by {!Terminal.parse}.
+    Unregistered tags are ignored. *)
+
+val dump : unit -> (t * Terminal.style option) list
+(** Recover the list of known tags together with their current style. *)
+
+(** {5 Setting color output} *)
+
+val init_color_output : unit -> unit
+(** Once called, all tags defined here will use their current style when
+    printed. To this end, this function redefines the loggers used when sending
+    messages to the user. The program will in particular use the formatters
+    {!Pp_control.std_ft} and {!Pp_control.err_ft} to display those messages,
+    with additional syle information provided by this module. Be careful this is
+    not compatible with the Emacs mode! *)
+
+val pp_tag : Pp.tag_handler
+(** Returns the name of a style tag that is understandable by the formatters
+    that have been inititialized through {!init_color_output}. To be used with
+    {!Pp.pp_with}. *)
+
+(** {5 Tags} *)
+
+val error_tag : t
+(** Tag used by the {!Pp.msg_error} function. *)
+
+val warning_tag : t
+(** Tag used by the {!Pp.msg_warning} function. *)
+
+val debug_tag : t
+(** Tag used by the {!Pp.msg_debug} function. *)
diff --git a/printing/pptactic.ml b/printing/pptactic.ml
new file mode 100644
index 00000000..f8264e5a
--- /dev/null
+++ b/printing/pptactic.ml
@@ -0,0 +1,1499 @@
+(************************************************************************)
+(*  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 Pp
+open Names
+open Namegen
+open Errors
+open Util
+open Constrexpr
+open Tacexpr
+open Genarg
+open Constrarg
+open Libnames
+open Ppextend
+open Misctypes
+open Locus
+open Decl_kinds
+open Genredexpr
+open Ppconstr
+open Printer
+
+let pr_global x = Nametab.pr_global_env Id.Set.empty x
+
+type grammar_terminals = string option list
+
+type pp_tactic = {
+  pptac_args : argument_type list;
+  pptac_prods : int * grammar_terminals;
+}
+
+(* ML Extensions *)
+let prtac_tab = Hashtbl.create 17
+
+(* Tactic notations *)
+let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty
+
+let declare_ml_tactic_pprule key pt =
+  Hashtbl.add prtac_tab (key, pt.pptac_args) pt.pptac_prods
+
+let declare_notation_tactic_pprule kn pt =
+  prnotation_tab := KNmap.add kn pt !prnotation_tab
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (Term.constr -> std_ppcmds) ->
+    (Term.constr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+let genarg_pprule = ref String.Map.empty
+
+let declare_extra_genarg_pprule wit f g h =
+  let s = match unquote (topwit wit) with
+    | ExtraArgType s -> s
+    | _ -> error
+      "Can declare a pretty-printing rule only for extra argument types."
+  in
+  let f prc prlc prtac x = f prc prlc prtac (out_gen (rawwit wit) x) in
+  let g prc prlc prtac x = g prc prlc prtac (out_gen (glbwit wit) x) in
+  let h prc prlc prtac x = h prc prlc prtac (out_gen (topwit wit) x) in
+  genarg_pprule := String.Map.add s (f,g,h) !genarg_pprule
+
+module Make
+  (Ppconstr : Ppconstrsig.Pp)
+  (Taggers : sig
+      val tag_keyword
+        : std_ppcmds -> std_ppcmds
+      val tag_primitive
+        : std_ppcmds -> std_ppcmds
+      val tag_string
+        : std_ppcmds -> std_ppcmds
+      val tag_glob_tactic_expr
+        : glob_tactic_expr -> std_ppcmds -> std_ppcmds
+      val tag_glob_atomic_tactic_expr
+        : glob_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
+      val tag_raw_tactic_expr
+        : raw_tactic_expr -> std_ppcmds -> std_ppcmds
+      val tag_raw_atomic_tactic_expr
+        : raw_atomic_tactic_expr -> std_ppcmds -> std_ppcmds
+      val tag_tactic_expr
+        : tactic_expr -> std_ppcmds -> std_ppcmds
+      val tag_atomic_tactic_expr
+        : atomic_tactic_expr -> std_ppcmds -> std_ppcmds
+  end)
+= struct
+
+  open Taggers
+
+  let keyword x = tag_keyword (str x)
+  let primitive x = tag_primitive (str x)
+
+  let pr_with_occurrences pr (occs,c) =
+    match occs with
+      | AllOccurrences ->
+        pr c
+      | NoOccurrences ->
+        failwith "pr_with_occurrences: no occurrences"
+      | OnlyOccurrences nl ->
+        hov 1 (pr c ++ spc () ++ keyword "at" ++ spc () ++
+                 hov 0 (prlist_with_sep spc (pr_or_var int) nl))
+      | AllOccurrencesBut nl ->
+        hov 1 (pr c ++ spc () ++ keyword "at" ++ str" - " ++
+                 hov 0 (prlist_with_sep spc (pr_or_var int) nl))
+
+  exception ComplexRedFlag
+
+  let pr_short_red_flag pr r =
+    if not r.rBeta ||  not r.rIota ||  not r.rZeta then raise ComplexRedFlag
+    else if List.is_empty r.rConst then
+      if r.rDelta then mt () else raise ComplexRedFlag
+    else (if r.rDelta then str "-" else mt ()) ++
+	   hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]")
+
+  let pr_red_flag pr r =
+    try pr_short_red_flag pr r
+    with complexRedFlags ->
+      (if r.rBeta then pr_arg str "beta" else mt ()) ++
+	(if r.rIota then pr_arg str "iota" else mt ()) ++
+	(if r.rZeta then pr_arg str "zeta" else mt ()) ++
+	(if List.is_empty r.rConst then
+	   if r.rDelta then pr_arg str "delta"
+	   else mt ()
+	 else
+	   pr_arg str "delta " ++ (if r.rDelta then str "-" else mt ()) ++
+	     hov 0 (str "[" ++ prlist_with_sep spc pr r.rConst ++ str "]"))
+
+  let pr_union pr1 pr2 = function
+    | Inl a -> pr1 a
+    | Inr b -> pr2 b
+
+  let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) = function
+    | Red false -> keyword "red"
+    | Hnf -> keyword "hnf"
+    | Simpl (f,o) -> keyword "simpl" ++ (pr_short_red_flag pr_ref f)
+		     ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
+    | Cbv f ->
+      if f.rBeta && f.rIota && f.rZeta && f.rDelta && List.is_empty f.rConst then
+        keyword "compute"
+      else
+        hov 1 (keyword "cbv" ++ pr_red_flag pr_ref f)
+    | Lazy f ->
+      hov 1 (keyword "lazy" ++ pr_red_flag pr_ref f)
+    | Cbn f ->
+      hov 1 (keyword "cbn" ++ pr_red_flag pr_ref f)
+    | Unfold l ->
+      hov 1 (keyword "unfold" ++ spc() ++
+               prlist_with_sep pr_comma (pr_with_occurrences pr_ref) l)
+    | Fold l -> hov 1 (keyword "fold" ++ prlist (pr_arg pr_constr) l)
+    | Pattern l ->
+      hov 1 (keyword "pattern" ++
+               pr_arg (prlist_with_sep pr_comma (pr_with_occurrences pr_constr)) l)
+
+    | Red true ->
+      error "Shouldn't be accessible from user."
+    | ExtraRedExpr s ->
+      str s
+    | CbvVm o ->
+      keyword "vm_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
+    | CbvNative o ->
+      keyword "native_compute" ++ pr_opt (pr_with_occurrences (pr_union pr_ref pr_pattern)) o
+
+  let pr_may_eval test prc prlc pr2 pr3 = function
+    | ConstrEval (r,c) ->
+      hov 0
+        (keyword "eval" ++ brk (1,1) ++
+           pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++
+           keyword "in" ++ spc() ++ prc c)
+    | ConstrContext ((_,id),c) ->
+      hov 0
+        (keyword "context" ++ spc () ++ pr_id id ++ spc () ++
+           str "[" ++ prlc c ++ str "]")
+    | ConstrTypeOf c ->
+      hov 1 (keyword "type of" ++ spc() ++ prc c)
+    | ConstrTerm c when test c ->
+      h 0 (str "(" ++ prc c ++ str ")")
+    | ConstrTerm c ->
+      prc c
+
+  let pr_may_eval a =
+    pr_may_eval (fun _ -> false) a
+
+  let pr_arg pr x = spc () ++ pr x
+
+  let pr_or_var pr = function
+    | ArgArg x -> pr x
+    | ArgVar (_,s) -> pr_id s
+
+  let pr_and_short_name pr (c,_) = pr c
+
+  let pr_or_by_notation f = function
+    | AN v -> f v
+    | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
+
+  let pr_located pr (loc,x) = pr x
+
+  let pr_evaluable_reference = function
+    | EvalVarRef id -> pr_id id
+    | EvalConstRef sp -> pr_global (Globnames.ConstRef sp)
+
+  let pr_quantified_hypothesis = function
+    | AnonHyp n -> int n
+    | NamedHyp id -> pr_id id
+
+  let pr_binding prc = function
+    | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c)
+    | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+
+  let pr_bindings prc prlc = function
+    | ImplicitBindings l ->
+      brk (1,1) ++ keyword "with" ++ brk (1,1) ++
+        hv 0 (prlist_with_sep spc prc l)
+    | ExplicitBindings l ->
+      brk (1,1) ++ keyword "with" ++ brk (1,1) ++
+        hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l)
+    | NoBindings -> mt ()
+
+  let pr_bindings_no_with prc prlc = function
+    | ImplicitBindings l ->
+      brk (0,1) ++
+        prlist_with_sep spc prc l
+    | ExplicitBindings l ->
+      brk (0,1) ++
+        prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
+    | NoBindings -> mt ()
+
+  let pr_clear_flag clear_flag pp x =
+    (match clear_flag with Some false -> str "!" | Some true -> str ">" | None -> mt())
+    ++ pp x
+
+  let pr_with_bindings prc prlc (c,bl) =
+    prc c ++ pr_bindings prc prlc bl
+
+  let pr_with_bindings_arg prc prlc (clear_flag,c) =
+    pr_clear_flag clear_flag (pr_with_bindings prc prlc) c
+
+  let pr_with_constr prc = function
+    | None -> mt ()
+    | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c)
+
+  let pr_message_token prid = function
+    | MsgString s -> tag_string (qs s)
+    | MsgInt n -> int n
+    | MsgIdent id -> prid id
+
+  let pr_fresh_ids =
+    prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s)
+
+  let with_evars ev s = if ev then "e" ^ s else s
+
+
+  let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) =
+    match Genarg.genarg_tag x with
+      | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x)
+      | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x)
+      | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x)
+      | GenArgType -> pr_raw_generic prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x)
+      | ConstrArgType -> prc (out_gen (rawwit wit_constr) x)
+      | ConstrMayEvalArgType ->
+        pr_may_eval prc prlc (pr_or_by_notation prref) prpat
+          (out_gen (rawwit wit_constr_may_eval) x)
+      | QuantHypArgType -> pr_quantified_hypothesis (out_gen (rawwit wit_quant_hyp) x)
+      | RedExprArgType ->
+        pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat)
+          (out_gen (rawwit wit_red_expr) x)
+      | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x))
+      | ConstrWithBindingsArgType ->
+        pr_with_bindings prc prlc (out_gen (rawwit wit_constr_with_bindings) x)
+      | BindingsArgType ->
+        pr_bindings_no_with prc prlc (out_gen (rawwit wit_bindings) x)
+      | ListArgType _ ->
+        let list_unpacker wit l =
+          let map x = pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) in
+          pr_sequence map (raw l)
+        in
+        hov 0 (list_unpack { list_unpacker } x)
+      | OptArgType _ ->
+        let opt_unpacker wit o = match raw o with
+          | None -> mt ()
+          | Some x -> pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x)
+        in
+        hov 0 (opt_unpack { opt_unpacker } x)
+      | PairArgType _ ->
+        let pair_unpacker wit1 wit2 o =
+          let p, q = raw o in
+          let p = in_gen (rawwit wit1) p in
+          let q = in_gen (rawwit wit2) q in
+          pr_sequence (pr_raw_generic prc prlc prtac prpat prref) [p; q]
+        in
+        hov 0 (pair_unpack { pair_unpacker } x)
+      | ExtraArgType s ->
+        try pi1 (String.Map.find s !genarg_pprule) prc prlc prtac x
+        with Not_found -> Genprint.generic_raw_print x
+
+
+  let rec pr_glb_generic prc prlc prtac prpat x =
+    match Genarg.genarg_tag x with
+      | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x)
+      | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x)
+      | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x)
+      | GenArgType -> pr_glb_generic prc prlc prtac prpat (out_gen (glbwit wit_genarg) x)
+      | ConstrArgType -> prc (out_gen (glbwit wit_constr) x)
+      | ConstrMayEvalArgType ->
+        pr_may_eval prc prlc
+          (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat
+          (out_gen (glbwit wit_constr_may_eval) x)
+      | QuantHypArgType ->
+        pr_quantified_hypothesis (out_gen (glbwit wit_quant_hyp) x)
+      | RedExprArgType ->
+        pr_red_expr
+          (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat)
+          (out_gen (glbwit wit_red_expr) x)
+      | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x))
+      | ConstrWithBindingsArgType ->
+        pr_with_bindings prc prlc (out_gen (glbwit wit_constr_with_bindings) x)
+      | BindingsArgType ->
+        pr_bindings_no_with prc prlc (out_gen (glbwit wit_bindings) x)
+      | ListArgType _ ->
+        let list_unpacker wit l =
+          let map x = pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) in
+          pr_sequence map (glb l)
+        in
+        hov 0 (list_unpack { list_unpacker } x)
+      | OptArgType _ ->
+        let opt_unpacker wit o = match glb o with
+          | None -> mt ()
+          | Some x -> pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x)
+        in
+        hov 0 (opt_unpack { opt_unpacker } x)
+      | PairArgType _ ->
+        let pair_unpacker wit1 wit2 o =
+          let p, q = glb o in
+          let p = in_gen (glbwit wit1) p in
+          let q = in_gen (glbwit wit2) q in
+          pr_sequence (pr_glb_generic prc prlc prtac prpat) [p; q]
+        in
+        hov 0 (pair_unpack { pair_unpacker } x)
+      | ExtraArgType s ->
+        try pi2 (String.Map.find s !genarg_pprule) prc prlc prtac x
+        with Not_found -> Genprint.generic_glb_print x
+
+  let rec pr_top_generic prc prlc prtac prpat x =
+    match Genarg.genarg_tag x with
+      | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x)
+      | IdentArgType -> pr_id (out_gen (topwit wit_ident) x)
+      | VarArgType -> pr_id (out_gen (topwit wit_var) x)
+      | GenArgType -> pr_top_generic prc prlc prtac prpat (out_gen (topwit wit_genarg) x)
+      | ConstrArgType -> prc (out_gen (topwit wit_constr) x)
+      | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x)
+      | QuantHypArgType -> pr_quantified_hypothesis (out_gen (topwit wit_quant_hyp) x)
+      | RedExprArgType ->
+        pr_red_expr (prc,prlc,pr_evaluable_reference,prpat)
+          (out_gen (topwit wit_red_expr) x)
+      | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x))
+      | ConstrWithBindingsArgType ->
+        let (c,b) = (out_gen (topwit wit_constr_with_bindings) x).Evd.it in
+        pr_with_bindings prc prlc (c,b)
+      | BindingsArgType ->
+        pr_bindings_no_with prc prlc (out_gen (topwit wit_bindings) x).Evd.it
+      | ListArgType _ ->
+        let list_unpacker wit l =
+          let map x = pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) in
+          pr_sequence map (top l)
+        in
+        hov 0 (list_unpack { list_unpacker } x)
+      | OptArgType _ ->
+        let opt_unpacker wit o = match top o with
+          | None -> mt ()
+          | Some x -> pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x)
+        in
+        hov 0 (opt_unpack { opt_unpacker } x)
+      | PairArgType _ ->
+        let pair_unpacker wit1 wit2 o =
+          let p, q = top o in
+          let p = in_gen (topwit wit1) p in
+          let q = in_gen (topwit wit2) q in
+          pr_sequence (pr_top_generic prc prlc prtac prpat) [p; q]
+        in
+        hov 0 (pair_unpack { pair_unpacker } x)
+      | ExtraArgType s ->
+        try pi3 (String.Map.find s !genarg_pprule) prc prlc prtac x
+        with Not_found -> Genprint.generic_top_print x
+
+  let rec tacarg_using_rule_token pr_gen = function
+    | Some s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al)
+    | None :: l, a :: al ->
+      let r = tacarg_using_rule_token pr_gen (l,al) in
+      pr_gen a :: r
+    | [], [] -> []
+    | _ -> failwith "Inconsistent arguments of extended tactic"
+
+  let pr_tacarg_using_rule pr_gen l =
+    let l = match l with
+    | (Some s :: l, al) ->
+      (** First terminal token should be considered as the name of the tactic,
+          so we tag it differently than the other terminal tokens. *)
+      primitive s :: (tacarg_using_rule_token pr_gen (l, al))
+    | _ -> tacarg_using_rule_token pr_gen l
+    in
+    pr_sequence (fun x -> x) l
+
+  let pr_extend_gen pr_gen lev s l =
+    try
+      let tags = List.map genarg_tag l in
+      let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in
+      let p = pr_tacarg_using_rule pr_gen (pl,l) in
+      if lev' > lev then surround p else p
+    with Not_found ->
+      let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic in
+      let args = match l with
+        | [] -> mt ()
+        | _ -> spc() ++ pr_sequence pr_gen l
+      in
+      str "<" ++ name ++ str ">" ++ args
+
+  let pr_alias_gen pr_gen lev key l =
+    try
+      let pp = KNmap.find key !prnotation_tab in
+      let (lev', pl) = pp.pptac_prods in
+      let p = pr_tacarg_using_rule pr_gen (pl, l) in
+      if lev' > lev then surround p else p
+    with Not_found ->
+      KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)"
+
+  let pr_raw_extend prc prlc prtac prpat =
+    pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
+  let pr_glob_extend prc prlc prtac prpat =
+    pr_extend_gen (pr_glb_generic prc prlc prtac prpat)
+  let pr_extend prc prlc prtac prpat =
+    pr_extend_gen (pr_top_generic prc prlc prtac prpat)
+
+  let pr_raw_alias prc prlc prtac prpat =
+    pr_alias_gen (pr_raw_generic prc prlc prtac prpat pr_reference)
+  let pr_glob_alias prc prlc prtac prpat =
+    pr_alias_gen (pr_glb_generic prc prlc prtac prpat)
+  let pr_alias prc prlc prtac prpat =
+    pr_alias_gen (pr_top_generic prc prlc prtac prpat)
+
+  (**********************************************************************)
+  (* The tactic printer                                                 *)
+
+  let strip_prod_binders_expr n ty =
+    let rec strip_ty acc n ty =
+      match ty with
+          Constrexpr.CProdN(_,bll,a) ->
+            let nb =
+              List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in
+            let bll = List.map (fun (x, _, y) -> x, y) bll in
+            if nb >= n then (List.rev (bll@acc)), a
+            else strip_ty (bll@acc) (n-nb) a
+        | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let pr_ltac_or_var pr = function
+    | ArgArg x -> pr x
+    | ArgVar (loc,id) -> pr_with_comments loc (pr_id id)
+
+  let pr_ltac_constant kn =
+    if !Flags.in_debugger then pr_kn kn
+    else try
+           pr_qualid (Nametab.shortest_qualid_of_tactic kn)
+      with Not_found -> (* local tactic not accessible anymore *)
+        str "<" ++ pr_kn kn ++ str ">"
+
+  let pr_evaluable_reference_env env = function
+    | EvalVarRef id -> pr_id id
+    | EvalConstRef sp ->
+      Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp)
+
+  let pr_esubst prc l =
+    let pr_qhyp = function
+    (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")"
+      | (_,NamedHyp id,c) ->
+        str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")"
+    in
+    prlist_with_sep spc pr_qhyp l
+
+  let pr_bindings_gen for_ex prc prlc = function
+    | ImplicitBindings l ->
+      spc () ++
+        hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
+                 prlist_with_sep spc prc l)
+    | ExplicitBindings l ->
+      spc () ++
+        hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++
+                 pr_esubst prlc l)
+    | NoBindings -> mt ()
+
+  let pr_bindings prc prlc = pr_bindings_gen false prc prlc
+
+  let pr_with_bindings prc prlc (c,bl) =
+    hov 1 (prc c ++ pr_bindings prc prlc bl)
+
+  let pr_as_disjunctive_ipat prc ipatl =
+    keyword "as" ++ spc () ++
+      pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl
+
+  let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat
+
+  let pr_with_induction_names prc = function
+    | None, None -> mt ()
+    | Some eqpat, None -> spc () ++ hov 1 (pr_eqn_ipat eqpat)
+    | None, Some ipat -> spc () ++ hov 1 (pr_as_disjunctive_ipat prc ipat)
+    | Some eqpat, Some ipat ->
+      spc () ++
+        hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat)
+
+  let pr_as_intro_pattern prc ipat =
+    spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat)
+
+  let pr_with_inversion_names prc = function
+    | None -> mt ()
+    | Some ipat -> pr_as_disjunctive_ipat prc ipat
+
+  let pr_as_ipat prc = function
+    | None -> mt ()
+    | Some ipat -> pr_as_intro_pattern prc ipat
+
+  let pr_as_name = function
+    | Anonymous -> mt ()
+    | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id)
+
+  let pr_pose_as_style prc na c =
+    spc() ++ prc c ++ pr_as_name na
+
+  let pr_pose prc prlc na c = match na with
+    | Anonymous -> spc() ++ prc c
+    | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c)
+
+  let pr_assertion prc prdc _prlc ipat c = match ipat with
+    (* Use this "optimisation" or use only the general case ?
+       | IntroIdentifier id ->
+       spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c)
+    *)
+    | ipat ->
+      spc() ++ prc c ++ pr_as_ipat prdc ipat
+
+  let pr_assumption prc prdc prlc ipat c = match ipat with
+    (* Use this "optimisation" or use only the general case ?*)
+    (* it seems that this "optimisation" is somehow more natural *)
+    | Some (_,IntroNaming (IntroIdentifier id)) ->
+      spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c)
+    | ipat ->
+      spc() ++ prc c ++ pr_as_ipat prdc ipat
+
+  let pr_by_tactic prt = function
+    | TacId [] -> mt ()
+    | tac -> spc() ++ keyword "by" ++ spc () ++ prt tac
+
+  let pr_hyp_location pr_id = function
+    | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs
+    | occs, InHypTypeOnly ->
+      spc () ++ pr_with_occurrences (fun id ->
+        str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")"
+      ) occs
+    | occs, InHypValueOnly ->
+      spc () ++ pr_with_occurrences (fun id ->
+        str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")"
+      ) occs
+
+  let pr_in pp = spc () ++ hov 0 (keyword "in" ++ pp)
+
+  let pr_simple_hyp_clause pr_id = function
+    | [] -> mt ()
+    | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l)
+
+  let pr_in_hyp_as prc pr_id = function
+    | None -> mt ()
+    | Some (clear,id,ipat) ->
+      pr_in (spc () ++ pr_clear_flag clear pr_id id) ++ pr_as_ipat prc ipat
+
+  let pr_clauses default_is_concl pr_id = function
+    | { onhyps=Some []; concl_occs=occs }
+        when (match default_is_concl with Some true -> true | _ -> false) ->
+      pr_with_occurrences mt (occs,())
+    | { onhyps=None; concl_occs=AllOccurrences }
+        when (match default_is_concl with Some false -> true | _ -> false) -> mt ()
+    | { onhyps=None; concl_occs=NoOccurrences } ->
+      pr_in (str " * |-")
+    | { onhyps=None; concl_occs=occs } ->
+      pr_in (pr_with_occurrences (fun () -> str " *") (occs,()))
+    | { onhyps=Some l; concl_occs=occs } ->
+      let pr_occs = match occs with
+        | NoOccurrences -> mt ()
+        | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,())
+      in
+      pr_in
+        (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ pr_occs)
+
+  let pr_orient b = if b then mt () else str "<- "
+
+  let pr_multi = function
+    | Precisely 1 -> mt ()
+    | Precisely n -> int n ++ str "!"
+    | UpTo n -> int n ++ str "?"
+    | RepeatStar -> str "?"
+    | RepeatPlus -> str "!"
+
+  let pr_induction_arg prc prlc = function
+    | ElimOnConstr c -> pr_with_bindings prc prlc c
+    | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id)
+    | ElimOnAnonHyp n -> int n
+
+  let pr_induction_kind = function
+    | SimpleInversion -> primitive "simple inversion"
+    | FullInversion -> primitive "inversion"
+    | FullInversionClear -> primitive "inversion_clear"
+
+  let pr_lazy = function
+    | General -> keyword "multi"
+    | Select -> keyword "lazy"
+    | Once -> mt ()
+
+  let pr_match_pattern pr_pat = function
+    | Term a -> pr_pat a
+    | Subterm (b,None,a) ->
+    (** ppedrot: we don't make difference between [appcontext] and [context]
+        anymore, and the interpretation is governed by a flag instead. *)
+      keyword "context" ++ str" [" ++ pr_pat a ++ str "]"
+    | Subterm (b,Some id,a) ->
+      keyword "context" ++ spc () ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]"
+
+  let pr_match_hyps pr_pat = function
+    | Hyp (nal,mp) ->
+      pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp
+    | Def (nal,mv,mp) ->
+      pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv
+      ++ str ":" ++ pr_match_pattern pr_pat mp
+
+  let pr_match_rule m pr pr_pat = function
+    | Pat ([],mp,t) when m ->
+      pr_match_pattern pr_pat mp ++
+        spc () ++ str "=>" ++ brk (1,4) ++ pr t
+    (*
+      | Pat (rl,mp,t) ->
+      hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++
+      (if rl <> [] then spc () else mt ()) ++
+      hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+      str "=>" ++ brk (1,4) ++ pr t))
+    *)
+    | Pat (rl,mp,t) ->
+      hov 0 (
+        hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++
+          (if not (List.is_empty rl) then spc () else mt ()) ++
+          hov 0 (
+            str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++
+              str "=>" ++ brk (1,4) ++ pr t))
+    | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t
+
+  let pr_funvar = function
+    | None -> spc () ++ str "_"
+    | Some id -> spc () ++ pr_id id
+
+  let pr_let_clause k pr (id,(bl,t)) =
+    hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++
+             str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t)))
+
+  let pr_let_clauses recflag pr = function
+    | hd::tl ->
+      hv 0
+        (pr_let_clause (if recflag then "let rec" else "let") pr hd ++
+           prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl)
+    | [] -> anomaly (Pp.str "LetIn must declare at least one binding")
+
+  let pr_seq_body pr tl =
+    hv 0 (str "[ " ++
+            prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+            str " ]")
+
+  let pr_dispatch pr tl =
+    hv 0 (str "[>" ++
+            prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++
+            str " ]")
+
+  let pr_opt_tactic pr = function
+    | TacId [] -> mt ()
+    | t -> pr t
+
+  let pr_tac_extend_gen pr tf tm tl =
+    prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++
+      pr_opt_tactic pr tm ++ str ".." ++
+      prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl
+
+  let pr_then_gen pr tf tm tl =
+    hv 0 (str "[ " ++
+            pr_tac_extend_gen pr tf tm tl ++
+            str " ]")
+
+  let pr_tac_extend pr tf tm tl =
+    hv 0 (str "[>" ++
+            pr_tac_extend_gen pr tf tm tl ++
+            str " ]")
+
+  let pr_hintbases = function
+    | None -> spc () ++ keyword "with" ++ str" *"
+    | Some [] -> mt ()
+    | Some l ->
+      spc () ++ hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l)
+
+  let pr_auto_using prc = function
+    | [] -> mt ()
+    | l -> spc () ++
+      hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
+
+  let string_of_debug = function
+    | Off -> ""
+    | Debug -> "debug "
+    | Info -> "info_"
+
+  let pr_then () = str ";"
+
+  let ltop = (5,E)
+  let lseq = 4
+  let ltactical = 3
+  let lorelse = 2
+  let llet = 5
+  let lfun = 5
+  let lcomplete = 1
+  let labstract = 3
+  let lmatch = 1
+  let latom = 0
+  let lcall = 1
+  let leval = 1
+  let ltatom = 1
+  let linfo = 5
+
+  let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq
+
+  (** A printer for tactics that polymorphically works on the three
+      "raw", "glob" and "typed" levels *)
+
+  type 'a printer = {
+    pr_tactic    : tolerability -> 'tacexpr -> std_ppcmds;
+    pr_constr    : 'trm -> std_ppcmds;
+    pr_uconstr   : 'utrm -> std_ppcmds;
+    pr_lconstr   : 'trm -> std_ppcmds;
+    pr_dconstr   : 'dtrm -> std_ppcmds;
+    pr_pattern   : 'pat -> std_ppcmds;
+    pr_lpattern  : 'pat -> std_ppcmds;
+    pr_constant  : 'cst -> std_ppcmds;
+    pr_reference : 'ref -> std_ppcmds;
+    pr_name      : 'nam -> std_ppcmds;
+    pr_generic   : 'lev generic_argument -> std_ppcmds;
+    pr_extend    : int -> ml_tactic_name -> 'lev generic_argument list -> std_ppcmds;
+    pr_alias     : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds;
+  }
+
+  constraint 'a = <
+      term      :'trm;
+      utrm      :'utrm;
+      dterm     :'dtrm;
+      pattern   :'pat;
+      constant  :'cst;
+      reference :'ref;
+      name      :'nam;
+      tacexpr   :'tacexpr;
+      level     :'lev
+    >
+
+    let make_pr_tac pr strip_prod_binders tag_atom tag =
+
+        (* some shortcuts *)
+        let _pr_bindings = pr_bindings pr.pr_constr pr.pr_lconstr in
+        let pr_ex_bindings = pr_bindings_gen true pr.pr_constr pr.pr_lconstr in
+        let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in
+        let pr_with_bindings_arg_full = pr_with_bindings_arg in
+        let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in
+        let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in
+
+        let pr_constrarg c = spc () ++ pr.pr_constr c in
+        let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in
+        let pr_intarg n = spc () ++ int n in
+
+        (* Some printing combinators *)
+        let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in
+
+        let extract_binders = function
+          | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body)
+          | body -> ([],body) in
+
+        let pr_binder_fix (nal,t) =
+          (*  match t with
+              | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal
+              | _ ->*)
+          let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in
+          spc() ++ hov 1 (str"(" ++ s ++ str")") in
+
+        let pr_fix_tac (id,n,c) =
+          let rec set_nth_name avoid n = function
+          (nal,ty)::bll ->
+            if n <= List.length nal then
+              match List.chop (n-1) nal with
+                  _, (_,Name id) :: _ -> id, (nal,ty)::bll
+                | bef, (loc,Anonymous) :: aft ->
+                  let id = next_ident_away (Id.of_string"y") avoid in
+                  id, ((bef@(loc,Name id)::aft, ty)::bll)
+                | _ -> assert false
+            else
+              let (id,bll') = set_nth_name avoid (n-List.length nal) bll in
+              (id,(nal,ty)::bll')
+            | [] -> assert false in
+          let (bll,ty) = strip_prod_binders n c in
+          let names =
+            List.fold_left
+              (fun ln (nal,_) -> List.fold_left
+                (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+                ln nal)
+              [] bll in
+          let idarg,bll = set_nth_name names n bll in
+          let annot = match names with
+            | [_] ->
+              mt ()
+            | _ ->
+              spc() ++ str"{"
+              ++ keyword "struct" ++ spc ()
+              ++ pr_id idarg ++ str"}"
+          in
+          hov 1 (str"(" ++ pr_id id ++
+                   prlist pr_binder_fix bll ++ annot ++ str" :" ++
+                   pr_lconstrarg ty ++ str")") in
+        (*  spc() ++
+            hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ pr_constrarg
+            c)
+        *)
+        let pr_cofix_tac (id,c) =
+          hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in
+
+        (* Printing tactics as arguments *)
+        let rec pr_atom0 a = tag_atom a (match a with
+          | TacIntroPattern [] -> primitive "intros"
+          | TacIntroMove (None,MoveLast) -> primitive "intro"
+          | TacTrivial (d,[],Some []) -> str (string_of_debug d) ++ primitive "trivial"
+          | TacAuto (d,None,[],Some []) -> str (string_of_debug d) ++ primitive "auto"
+          | TacClear (true,[]) -> primitive "clear"
+          | t -> str "(" ++ pr_atom1 t ++ str ")"
+        )
+
+        (* Main tactic printer *)
+        and pr_atom1 a = tag_atom a (match a with
+          (* Basic tactics *)
+          | TacIntroPattern [] as t ->
+            pr_atom0 t
+          | TacIntroPattern (_::_ as p) ->
+            hov 1 (primitive "intros" ++ spc () ++
+                     prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)
+          | TacIntroMove (None,MoveLast) as t ->
+            pr_atom0 t
+          | TacIntroMove (Some id,MoveLast) ->
+            primitive "intro" ++ spc () ++ pr_id id
+          | TacIntroMove (ido,hto) ->
+            hov 1 (primitive "intro" ++ pr_opt pr_id ido ++
+                     Miscprint.pr_move_location pr.pr_name hto)
+          | TacExact c ->
+            hov 1 (primitive "exact" ++ pr_constrarg c)
+          | TacApply (a,ev,cb,inhyp) ->
+            hov 1 (
+              (if a then mt() else primitive "simple ") ++
+                primitive (with_evars ev "apply") ++ spc () ++
+                prlist_with_sep pr_comma pr_with_bindings_arg cb ++
+                pr_in_hyp_as pr.pr_dconstr pr.pr_name inhyp
+            )
+          | TacElim (ev,cb,cbo) ->
+            hov 1 (
+              primitive (with_evars ev "elim")
+              ++ pr_arg pr_with_bindings_arg cb
+              ++ pr_opt pr_eliminator cbo)
+          | TacCase (ev,cb) ->
+            hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb)
+          | TacFix (ido,n) -> hov 1 (primitive "fix" ++ pr_opt pr_id ido ++ pr_intarg n)
+          | TacMutualFix (id,n,l) ->
+            hov 1 (
+              primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc()
+              ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l)
+          | TacCofix ido ->
+            hov 1 (primitive "cofix" ++ pr_opt pr_id ido)
+          | TacMutualCofix (id,l) ->
+            hov 1 (
+              primitive "cofix" ++ spc () ++ pr_id id ++ spc()
+              ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
+            )
+          | TacAssert (b,Some tac,ipat,c) ->
+            hov 1 (
+              primitive (if b then "assert" else "enough") ++
+                pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
+                pr_by_tactic (pr.pr_tactic ltop) tac
+            )
+          | TacAssert (_,None,ipat,c) ->
+            hov 1 (
+              primitive "pose proof"
+              ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c
+            )
+          | TacGeneralize l ->
+            hov 1 (
+              primitive "generalize" ++ spc ()
+              ++ prlist_with_sep pr_comma (fun (cl,na) ->
+                pr_with_occurrences pr.pr_constr cl ++ pr_as_name na)
+                l
+            )
+          | TacGeneralizeDep c ->
+            hov 1 (
+              primitive "generalize" ++ spc () ++ str "dependent"
+              ++ pr_constrarg c
+            )
+          | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
+            hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
+          | TacLetTac (na,c,cl,b,e) ->
+            hov 1 (
+              (if b then primitive "set" else primitive "remember") ++
+                (if b then pr_pose pr.pr_constr pr.pr_lconstr na c
+                 else pr_pose_as_style pr.pr_constr na c) ++
+                pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
+                pr_clauses (Some b) pr.pr_name cl)
+          (*  | TacInstantiate (n,c,ConclLocation ()) ->
+              hov 1 (str "instantiate" ++ spc() ++
+              hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+              pr_lconstrarg c ++ str ")" ))
+              | TacInstantiate (n,c,HypLocation (id,hloc)) ->
+              hov 1 (str "instantiate" ++ spc() ++
+              hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++
+              pr_lconstrarg c ++ str ")" )
+              ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None)))
+          *)
+
+          (* Derived basic tactics *)
+          | TacInductionDestruct (isrec,ev,(l,el)) ->
+            hov 1 (
+              primitive (with_evars ev (if isrec then "induction" else "destruct"))
+              ++ spc ()
+              ++ prlist_with_sep pr_comma (fun ((clear_flag,h),ids,cl) ->
+                pr_clear_flag clear_flag (pr_induction_arg pr.pr_dconstr pr.pr_dconstr) h ++
+                  pr_with_induction_names pr.pr_dconstr ids ++
+                  pr_opt_no_spc (pr_clauses None pr.pr_name) cl) l ++
+                pr_opt pr_eliminator el
+            )
+          | TacDoubleInduction (h1,h2) ->
+            hov 1 (
+              primitive "double induction"
+              ++ pr_arg pr_quantified_hypothesis h1
+              ++ pr_arg pr_quantified_hypothesis h2
+            )
+
+          (* Automation tactics *)
+          | TacTrivial (_,[],Some []) as x ->
+            pr_atom0 x
+          | TacTrivial (d,lems,db) ->
+            hov 0 (
+              str (string_of_debug d) ++ primitive "trivial"
+              ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db
+            )
+          | TacAuto (_,None,[],Some []) as x ->
+            pr_atom0 x
+          | TacAuto (d,n,lems,db) ->
+            hov 0 (
+              str (string_of_debug d) ++ primitive "auto"
+              ++ pr_opt (pr_or_var int) n
+              ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db
+            )
+
+          (* Context management *)
+          | TacClear (true,[]) as t ->
+            pr_atom0 t
+          | TacClear (keep,l) ->
+            hov 1 (
+              primitive "clear" ++ spc ()
+              ++ (if keep then str "- " else mt ())
+              ++ prlist_with_sep spc pr.pr_name l
+            )
+          | TacClearBody l ->
+            hov 1 (
+              primitive "clearbody" ++ spc ()
+              ++ prlist_with_sep spc pr.pr_name l
+            )
+          | TacMove (id1,id2) ->
+            hov 1 (
+              primitive "move"
+              ++ brk (1,1) ++ pr.pr_name id1
+              ++ Miscprint.pr_move_location pr.pr_name id2
+            )
+          | TacRename l ->
+            hov 1 (
+              primitive "rename" ++ brk (1,1)
+              ++ prlist_with_sep
+                (fun () -> str "," ++ brk (1,1))
+                (fun (i1,i2) ->
+                  pr.pr_name i1 ++ spc () ++ str "into" ++ spc () ++ pr.pr_name i2)
+                l
+            )
+
+          (* Constructors *)
+          | TacSplit (ev,l) ->
+            hov 1 (
+              primitive (with_evars ev "exists")
+              ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l
+            )
+
+          (* Conversion *)
+          | TacReduce (r,h) ->
+            hov 1 (
+              pr_red_expr r
+              ++ pr_clauses (Some true) pr.pr_name h
+            )
+          | TacChange (op,c,h) ->
+            hov 1 (
+              primitive "change" ++ brk (1,1)
+              ++ (
+                match op with
+                    None ->
+                      mt ()
+                  | Some p ->
+                    pr.pr_pattern p ++ spc ()
+                    ++ keyword "with" ++ spc ()
+              ) ++ pr.pr_dconstr c ++ pr_clauses (Some true) pr.pr_name h
+            )
+
+          (* Equivalence relations *)
+          | TacSymmetry cls ->
+            primitive "symmetry" ++ pr_clauses (Some true) pr.pr_name cls
+
+          (* Equality and inversion *)
+          | TacRewrite (ev,l,cl,by) ->
+            hov 1 (
+              primitive (with_evars ev "rewrite") ++ spc ()
+              ++ prlist_with_sep
+                (fun () -> str ","++spc())
+                (fun (b,m,c) ->
+                  pr_orient b ++ pr_multi m ++
+                    pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c)
+                l
+              ++ pr_clauses (Some true) pr.pr_name cl
+              ++ (
+                match by with
+                  | Some by -> pr_by_tactic (pr.pr_tactic ltop) by
+                  | None -> mt()
+              )
+            )
+          | TacInversion (DepInversion (k,c,ids),hyp) ->
+            hov 1 (
+              primitive "dependent " ++ pr_induction_kind k ++ spc ()
+              ++ pr_quantified_hypothesis hyp
+              ++ pr_with_inversion_names pr.pr_dconstr ids
+              ++ pr_with_constr pr.pr_constr c
+            )
+          | TacInversion (NonDepInversion (k,cl,ids),hyp) ->
+            hov 1 (
+              pr_induction_kind k ++ spc ()
+              ++ pr_quantified_hypothesis hyp
+              ++ pr_with_inversion_names pr.pr_dconstr ids
+              ++ pr_simple_hyp_clause pr.pr_name cl
+            )
+          | TacInversion (InversionUsing (c,cl),hyp) ->
+            hov 1 (
+              primitive "inversion" ++ spc()
+              ++ pr_quantified_hypothesis hyp ++ spc ()
+              ++ keyword "using" ++ spc () ++ pr.pr_constr c
+              ++ pr_simple_hyp_clause pr.pr_name cl
+            )
+        )
+        in
+
+        let rec pr_tac inherited tac =
+          let return (doc, l) = (tag tac doc, l) in
+          let (strm, prec) = return (match tac with
+            | TacAbstract (t,None) ->
+              keyword "abstract " ++ pr_tac (labstract,L) t, labstract
+            | TacAbstract (t,Some s) ->
+              hov 0 (
+                keyword "abstract"
+                ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc ()
+                ++ keyword "using" ++ spc () ++ pr_id s),
+              labstract
+            | TacLetIn (recflag,llc,u) ->
+              let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in
+              v 0
+                (hv 0 (
+                  pr_let_clauses recflag (pr_tac ltop) llc
+                  ++ spc () ++ keyword "in"
+                 ) ++ fnl () ++ pr_tac (llet,E) u),
+              llet
+            | TacMatch (lz,t,lrul) ->
+              hov 0 (
+                pr_lazy lz ++ keyword "match" ++ spc ()
+                ++ pr_tac ltop t ++ spc () ++ keyword "with"
+                ++ prlist (fun r ->
+                  fnl () ++ str "| "
+                  ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r
+                ) lrul
+                ++ fnl() ++ keyword "end"),
+              lmatch
+            | TacMatchGoal (lz,lr,lrul) ->
+              hov 0 (
+                pr_lazy lz
+                ++ keyword (if lr then "match reverse goal with" else "match goal with")
+                ++ prlist (fun r ->
+                  fnl () ++ str "| "
+                  ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r
+                ) lrul ++ fnl() ++ keyword "end"),
+              lmatch
+            | TacFun (lvar,body) ->
+              hov 2 (
+                keyword "fun"
+                ++ prlist pr_funvar lvar ++ str " =>" ++ spc ()
+                ++ pr_tac (lfun,E) body),
+              lfun
+            | TacThens (t,tl) ->
+              hov 1 (
+                pr_tac (lseq,E) t ++ pr_then () ++ spc ()
+                ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl),
+              lseq
+            | TacThen (t1,t2) ->
+              hov 1 (
+                pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
+                ++ pr_tac (lseq,L) t2),
+              lseq
+            | TacDispatch tl ->
+              pr_dispatch (pr_tac ltop) tl, lseq
+            | TacExtendTac (tf,t,tr) ->
+              pr_tac_extend (pr_tac ltop) tf t tr , lseq
+            | TacThens3parts (t1,tf,t2,tl) ->
+              hov 1 (
+                pr_tac (lseq,E) t1 ++ pr_then () ++ spc ()
+                ++ pr_then_gen (pr_tac ltop) tf t2 tl),
+              lseq
+            | TacTry t ->
+              hov 1 (
+                keyword "try" ++ spc () ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacDo (n,t) ->
+              hov 1 (
+                str "do" ++ spc ()
+                ++ pr_or_var int n ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacTimeout (n,t) ->
+              hov 1 (
+                keyword "timeout "
+                ++ pr_or_var int n ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacTime (s,t) ->
+              hov 1 (
+                keyword "time"
+                ++ pr_opt str s ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacRepeat t ->
+              hov 1 (
+                keyword "repeat" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacProgress t ->
+              hov 1 (
+                keyword "progress" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacShowHyps t ->
+              hov 1 (
+                keyword "infoH" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacInfo t ->
+              hov 1 (
+                keyword "info" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              linfo
+            | TacOr (t1,t2) ->
+              hov 1 (
+                pr_tac (lorelse,L) t1 ++ spc ()
+                ++ str "+" ++ brk (1,1)
+                ++ pr_tac (lorelse,E) t2),
+              lorelse
+            | TacOnce t ->
+              hov 1 (
+                keyword "once" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacExactlyOnce t ->
+              hov 1 (
+                keyword "exactly_once" ++ spc ()
+                ++ pr_tac (ltactical,E) t),
+              ltactical
+            | TacIfThenCatch (t,tt,te) ->
+                hov 1 (
+                 str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++
+                 str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++
+                 str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)),
+                ltactical
+            | TacOrelse (t1,t2) ->
+              hov 1 (
+                pr_tac (lorelse,L) t1 ++ spc ()
+                ++ str "||" ++ brk (1,1)
+                ++ pr_tac (lorelse,E) t2),
+              lorelse
+            | TacFail (g,n,l) ->
+              let arg =
+                match n with
+                  | ArgArg 0 -> mt ()
+                  | _ -> pr_arg (pr_or_var int) n
+              in
+              let name =
+                match g with
+                | TacGlobal -> keyword "gfail"
+                | TacLocal -> keyword "fail"
+              in
+              hov 1 (
+                name ++ arg
+                ++ prlist (pr_arg (pr_message_token pr.pr_name)) l),
+              latom
+            | TacFirst tl ->
+              keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+            | TacSolve tl ->
+              keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
+            | TacComplete t ->
+              pr_tac (lcomplete,E) t, lcomplete
+            | TacId l ->
+              keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom
+            | TacAtom (loc,t) ->
+              pr_with_comments loc (hov 1 (pr_atom1 t)), ltatom
+            | TacArg(_,Tacexp e) ->
+              pr.pr_tactic (latom,E) e, latom
+            | TacArg(_,ConstrMayEval (ConstrTerm c)) ->
+              keyword "constr:" ++ pr.pr_constr c, latom
+            | TacArg(_,ConstrMayEval c) ->
+              pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval
+            | TacArg(_,TacFreshId l) ->
+              primitive "fresh" ++ pr_fresh_ids l, latom
+            | TacArg(_,TacGeneric arg) ->
+              pr.pr_generic arg, latom
+            | TacArg(_,TacCall(loc,f,[])) ->
+              pr.pr_reference f, latom
+            | TacArg(_,TacCall(loc,f,l)) ->
+              pr_with_comments loc (hov 1 (
+                pr.pr_reference f ++ spc ()
+                ++ prlist_with_sep spc pr_tacarg l)),
+              lcall
+            | TacArg (_,a) ->
+              pr_tacarg a, latom
+            | TacML (loc,s,l) ->
+              pr_with_comments loc (pr.pr_extend 1 s l), lcall
+            | TacAlias (loc,kn,l) ->
+              pr_with_comments loc (pr.pr_alias (level_of inherited) kn (List.map snd l)), latom
+          )
+          in
+          if prec_less prec inherited then strm
+          else str"(" ++ strm ++ str")"
+
+        and pr_tacarg = function
+          | TacDynamic (loc,t) ->
+            pr_with_comments loc (
+              str "<" ++ keyword "dynamic" ++ str (" [" ^ (Dyn.tag t)^"]>")
+            )
+          | MetaIdArg (loc,true,s) ->
+            pr_with_comments loc (str ("$" ^ s))
+          | MetaIdArg (loc,false,s) ->
+            pr_with_comments loc (keyword "constr:" ++ str(" $" ^ s))
+          | Reference r ->
+            pr.pr_reference r
+          | ConstrMayEval c ->
+            pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c
+          | UConstr c ->
+            keyword "uconstr:" ++ pr.pr_uconstr c
+          | TacFreshId l ->
+            keyword "fresh" ++ pr_fresh_ids l
+          | TacPretype c ->
+            keyword "type_term" ++ pr.pr_constr c
+          | TacNumgoals ->
+            keyword "numgoals"
+          | (TacCall _|Tacexp _ | TacGeneric _) as a ->
+            keyword "ltac:" ++ pr_tac (latom,E) (TacArg (Loc.ghost,a))
+
+        in pr_tac
+
+  let strip_prod_binders_glob_constr n (ty,_) =
+    let rec strip_ty acc n ty =
+      if Int.equal n 0 then (List.rev acc, (ty,None)) else
+        match ty with
+            Glob_term.GProd(loc,na,Explicit,a,b) ->
+              strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b
+          | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let raw_printers =
+    (strip_prod_binders_expr)
+
+  let rec pr_raw_tactic_level n (t:raw_tactic_expr) =
+    let pr = {
+      pr_tactic = pr_raw_tactic_level;
+      pr_constr = pr_constr_expr;
+      pr_uconstr = pr_constr_expr;
+      pr_dconstr = pr_constr_expr;
+      pr_lconstr = pr_lconstr_expr;
+      pr_pattern = pr_constr_pattern_expr;
+      pr_lpattern = pr_lconstr_pattern_expr;
+      pr_constant = pr_or_by_notation pr_reference;
+      pr_reference = pr_reference;
+      pr_name = pr_lident;
+      pr_generic = Genprint.generic_raw_print;
+      pr_extend = pr_raw_extend pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
+      pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr;
+    } in
+    make_pr_tac
+      pr raw_printers
+      tag_raw_atomic_tactic_expr tag_raw_tactic_expr
+      n t
+
+  let pr_raw_tactic = pr_raw_tactic_level ltop
+
+  let pr_and_constr_expr pr (c,_) = pr c
+
+  let pr_pat_and_constr_expr pr ((c,_),_) = pr c
+
+  let rec pr_glob_tactic_level env n t =
+    let glob_printers =
+      (strip_prod_binders_glob_constr)
+    in
+    let rec prtac n (t:glob_tactic_expr) =
+      let pr = {
+        pr_tactic = prtac;
+        pr_constr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_uconstr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env);
+        pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env);
+        pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env);
+        pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env));
+        pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant);
+        pr_name = pr_lident;
+        pr_generic = Genprint.generic_glb_print;
+        pr_extend = pr_glob_extend
+          (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+          prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
+        pr_alias = pr_glob_alias
+          (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env))
+          prtac (pr_pat_and_constr_expr (pr_glob_constr_env env));
+      } in
+      make_pr_tac
+        pr glob_printers
+        tag_glob_atomic_tactic_expr tag_glob_tactic_expr
+        n t
+    in
+    prtac n t
+
+  let pr_glob_tactic env = pr_glob_tactic_level env ltop
+
+  let strip_prod_binders_constr n ty =
+    let rec strip_ty acc n ty =
+      if n=0 then (List.rev acc, ty) else
+        match Term.kind_of_term ty with
+            Term.Prod(na,a,b) ->
+              strip_ty (([Loc.ghost,na],a)::acc) (n-1) b
+          | _ -> error "Cannot translate fix tactic: not enough products" in
+    strip_ty [] n ty
+
+  let pr_tactic_level env n t =
+    let typed_printers =
+      (strip_prod_binders_constr)
+    in
+    let prtac n (t:tactic_expr) =
+      let pr = {
+        pr_tactic = pr_glob_tactic_level env;
+        pr_constr = pr_constr_env env Evd.empty;
+        pr_uconstr = pr_closed_glob_env env Evd.empty;
+        pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env);
+        pr_lconstr = pr_lconstr_env env Evd.empty;
+        pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env);
+        pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env);
+        pr_constant = pr_and_short_name (pr_evaluable_reference_env env);
+        pr_reference = pr_located pr_ltac_constant;
+        pr_name = pr_id;
+        pr_generic = Genprint.generic_top_print;
+        pr_extend = pr_extend
+          (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty)
+          (pr_glob_tactic_level env) pr_constr_pattern;
+        pr_alias = pr_alias
+          (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty)
+          (pr_glob_tactic_level env) pr_constr_pattern;
+      }
+      in
+      make_pr_tac
+        pr typed_printers
+        tag_atomic_tactic_expr tag_tactic_expr
+        n t
+    in
+    prtac n t
+
+  let pr_tactic env = pr_tactic_level env ltop
+
+end
+
+module Tag =
+struct
+  let keyword =
+    let style = Terminal.make ~bold:true () in
+    Ppstyle.make ~style ["tactic"; "keyword"]
+
+  let primitive =
+    let style = Terminal.make ~fg_color:`LIGHT_GREEN () in
+    Ppstyle.make ~style ["tactic"; "primitive"]
+
+  let string =
+    let style = Terminal.make ~fg_color:`LIGHT_RED () in
+    Ppstyle.make ~style ["tactic"; "string"]
+
+end
+
+include Make (Ppconstr) (struct
+    let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
+    let do_not_tag _ x = x
+    let tag_keyword                 = tag Tag.keyword
+    let tag_primitive               = tag Tag.primitive
+    let tag_string                  = tag Tag.string
+    let tag_glob_tactic_expr        = do_not_tag
+    let tag_glob_atomic_tactic_expr = do_not_tag
+    let tag_raw_tactic_expr         = do_not_tag
+    let tag_raw_atomic_tactic_expr  = do_not_tag
+    let tag_tactic_expr             = do_not_tag
+    let tag_atomic_tactic_expr      = do_not_tag
+end)
+
+(** Registering *)
+
+let () =
+  let pr_bool b = if b then str "true" else str "false" in
+  let pr_unit _ = str "()" in
+  let pr_string s = str "\"" ++ str s ++ str "\"" in
+  Genprint.register_print0 Constrarg.wit_ref
+    pr_reference (pr_or_var (pr_located pr_global)) pr_global;
+  Genprint.register_print0
+    Constrarg.wit_intro_pattern
+    (Miscprint.pr_intro_pattern pr_constr_expr)
+    (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c))
+    (Miscprint.pr_intro_pattern (fun c -> pr_constr (snd (c (Global.env()) Evd.empty))));
+  Genprint.register_print0
+    Constrarg.wit_clause_dft_concl
+    (pr_clauses (Some true) pr_lident)
+    (pr_clauses (Some true) pr_lident)
+    (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id)))
+  ;
+  Genprint.register_print0 Constrarg.wit_sort
+    pr_glob_sort pr_glob_sort (pr_sort Evd.empty);
+  Genprint.register_print0
+    Constrarg.wit_uconstr
+    Ppconstr.pr_constr_expr
+    (fun (c,_) -> Printer.pr_glob_constr c)
+    Printer.pr_closed_glob
+  ;
+  Genprint.register_print0 Stdarg.wit_int int int int;
+  Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool;
+  Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit;
+  Genprint.register_print0 Stdarg.wit_pre_ident str str str;
+  Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string
+
+let () =
+  let printer _ _ prtac = prtac (0, E) in
+  declare_extra_genarg_pprule wit_tactic printer printer printer
+
+let _ = Hook.set Tactic_debug.tactic_printer
+  (fun x -> pr_glob_tactic (Global.env()) x)
+
+let _ = Hook.set Tactic_debug.match_pattern_printer
+  (fun env sigma hyp -> pr_match_pattern (pr_constr_pattern_env env sigma) hyp)
+
+let _ = Hook.set Tactic_debug.match_rule_printer
+  (fun rl ->
+    pr_match_rule false (pr_glob_tactic (Global.env()))
+      (fun (_,p) -> pr_constr_pattern p) rl)
+
+module Richpp = struct
+
+  include Make (Ppconstr.Richpp) (struct
+    open Ppannotation
+    let do_not_tag _ x = x
+    let tag e s = Pp.tag (Pp.Tag.inj e tag) s
+    let tag_keyword                   = tag AKeyword
+    let tag_primitive                 = tag AKeyword
+    let tag_string                    = do_not_tag ()
+    let tag_glob_tactic_expr        e = tag (AGlobTacticExpr e)
+    let tag_glob_atomic_tactic_expr a = tag (AGlobAtomicTacticExpr a)
+    let tag_raw_tactic_expr         e = tag (ARawTacticExpr e)
+    let tag_raw_atomic_tactic_expr  a = tag (ARawAtomicTacticExpr a)
+    let tag_tactic_expr             e = tag (ATacticExpr e)
+    let tag_atomic_tactic_expr      a = tag (AAtomicTacticExpr a)
+  end)
+
+end
diff --git a/printing/pptactic.mli b/printing/pptactic.mli
new file mode 100644
index 00000000..284237f0
--- /dev/null
+++ b/printing/pptactic.mli
@@ -0,0 +1,65 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module implements pretty-printers for tactic_expr syntactic
+    objects and their subcomponents. *)
+
+open Pp
+open Genarg
+open Names
+open Constrexpr
+open Tacexpr
+open Ppextend
+open Environ
+open Pattern
+open Misctypes
+
+type 'a raw_extra_genarg_printer =
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a glob_extra_genarg_printer =
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+type 'a extra_genarg_printer =
+    (Term.constr -> std_ppcmds) ->
+    (Term.constr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    'a -> std_ppcmds
+
+val declare_extra_genarg_pprule :
+  ('a, 'b, 'c) genarg_type ->
+  'a raw_extra_genarg_printer ->
+  'b glob_extra_genarg_printer ->
+  'c extra_genarg_printer -> unit
+
+type grammar_terminals = string option list
+
+type pp_tactic = {
+  pptac_args : argument_type list;
+  pptac_prods : int * grammar_terminals;
+}
+
+val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic -> unit
+val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
+
+(** The default pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as raw strings. *)
+include Pptacticsig.Pp
+
+(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as annotated strings. The annotations can be
+    retrieved using {!RichPp.rich_pp}. Their definitions are
+    located in {!Ppannotation.t}. *)
+module Richpp : Pptacticsig.Pp
+
diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli
new file mode 100644
index 00000000..98b5757d
--- /dev/null
+++ b/printing/pptacticsig.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  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 Pp
+open Genarg
+open Names
+open Constrexpr
+open Tacexpr
+open Ppextend
+open Environ
+open Pattern
+open Misctypes
+
+module type Pp = sig
+
+  val pr_with_occurrences :
+    ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds
+  val pr_red_expr :
+    ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
+    ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds
+  val pr_may_eval :
+    ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
+    ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds
+
+  val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds
+  val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds
+  val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds
+
+  val pr_clauses :  bool option ->
+    ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds
+  val pr_raw_generic :
+    (constr_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) ->
+    (Libnames.reference -> std_ppcmds) -> rlevel generic_argument ->
+    std_ppcmds
+
+  val pr_glb_generic :
+    (glob_constr_and_expr -> Pp.std_ppcmds) ->
+    (glob_constr_and_expr -> Pp.std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (glob_constr_pattern_and_expr -> std_ppcmds) ->
+    glevel generic_argument -> std_ppcmds
+
+  val pr_top_generic :
+    (Term.constr -> std_ppcmds) ->
+    (Term.constr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (Pattern.constr_pattern -> std_ppcmds) ->
+    tlevel generic_argument ->
+    std_ppcmds
+
+  val pr_raw_extend:
+    (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) ->
+    (tolerability -> raw_tactic_expr -> std_ppcmds) ->
+    (constr_expr -> std_ppcmds) -> int ->
+    ml_tactic_name -> raw_generic_argument list -> std_ppcmds
+
+  val pr_glob_extend:
+    (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (glob_constr_pattern_and_expr -> std_ppcmds) -> int ->
+    ml_tactic_name -> glob_generic_argument list -> std_ppcmds
+
+  val pr_extend :
+    (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) ->
+    (tolerability -> glob_tactic_expr -> std_ppcmds) ->
+    (constr_pattern -> std_ppcmds) -> int ->
+    ml_tactic_name -> typed_generic_argument list -> std_ppcmds
+
+  val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds
+
+  val pr_raw_tactic : raw_tactic_expr -> std_ppcmds
+
+  val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds
+
+  val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds
+
+  val pr_tactic : env -> tactic_expr -> std_ppcmds
+
+  val pr_hintbases : string list option -> std_ppcmds
+
+  val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds
+
+  val pr_bindings :
+    ('constr -> std_ppcmds) ->
+    ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds
+
+end
diff --git a/printing/pputils.ml b/printing/pputils.ml
new file mode 100644
index 00000000..ee1a39ef
--- /dev/null
+++ b/printing/pputils.ml
@@ -0,0 +1,15 @@
+(************************************************************************)
+(*  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 Pp
+
+let pr_located pr (loc, x) =
+  if Flags.do_beautify () && loc <> Loc.ghost then
+    let (b, e) = Loc.unloc loc in
+    Pp.comment b ++ pr x ++ Pp.comment e
+  else pr x
diff --git a/plugins/ring/Setoid_ring.v b/printing/pputils.mli
index 4b484483..72877483 100644
--- a/plugins/ring/Setoid_ring.v
+++ b/printing/pputils.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        *)
 (************************************************************************)
 
-Require Export Setoid_ring_theory.
-Require Export Quote.
-Require Export Setoid_ring_normalize.
-Declare ML Module "ring_plugin".
+open Pp
+
+val pr_located : ('a -> std_ppcmds) -> 'a Loc.located -> std_ppcmds
+(** Prints an object surrounded by its commented location *)
+
diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml
new file mode 100644
index 00000000..e9e335ec
--- /dev/null
+++ b/printing/ppvernac.ml
@@ -0,0 +1,1296 @@
+(************************************************************************)
+(*  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 Pp
+open Names
+
+open Errors
+open Util
+open Extend
+open Vernacexpr
+open Pputils
+open Libnames
+open Constrexpr
+open Constrexpr_ops
+open Decl_kinds
+
+module Make
+  (Ppconstr : Ppconstrsig.Pp)
+  (Pptactic : Pptacticsig.Pp)
+  (Taggers  : sig
+    val tag_keyword : std_ppcmds -> std_ppcmds
+    val tag_vernac  : vernac_expr -> std_ppcmds -> std_ppcmds
+  end)
+= struct
+
+  open Taggers
+  open Ppconstr
+  open Pptactic
+
+  let keyword s = tag_keyword (str s)
+
+  let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr
+
+  let pr_lident (loc,id) =
+    if Loc.is_ghost loc then
+      let (b,_) = Loc.unloc loc in
+      pr_located pr_id (Loc.make_loc (b,b + String.length(Id.to_string id)),id)
+    else
+      pr_id id
+
+  let string_of_fqid fqid =
+    String.concat "." (List.map Id.to_string fqid)
+
+  let pr_fqid fqid = str (string_of_fqid fqid)
+
+  let pr_lfqid (loc,fqid) =
+    if Loc.is_ghost loc then
+      let (b,_) = Loc.unloc loc in
+      pr_located pr_fqid (Loc.make_loc (b,b + String.length(string_of_fqid fqid)),fqid)
+    else
+      pr_fqid fqid
+
+  let pr_lname = function
+    | (loc,Name id) -> pr_lident (loc,id)
+    | lna -> pr_located pr_name lna
+
+  let pr_smart_global = pr_or_by_notation pr_reference
+
+  let pr_ltac_ref = Libnames.pr_reference
+
+  let pr_module = Libnames.pr_reference
+
+  let pr_import_module = Libnames.pr_reference
+
+  let sep_end = function
+    | VernacBullet _
+    | VernacSubproof None
+    | VernacEndSubproof -> str""
+    | _ -> str"."
+
+  let pr_gen t =
+    pr_raw_generic
+      pr_constr_expr
+      pr_lconstr_expr
+      pr_raw_tactic_level
+      pr_constr_expr
+      pr_reference t
+
+  let sep = fun _ -> spc()
+  let sep_v2 = fun _ -> str"," ++ spc()
+
+  let pr_ne_sep sep pr = function
+  [] -> mt()
+    | l -> sep() ++ pr l
+
+  let pr_set_entry_type = function
+    | ETName -> str"ident"
+    | ETReference -> str"global"
+    | ETPattern -> str"pattern"
+    | ETConstr _ -> str"constr"
+    | ETOther (_,e) -> str e
+    | ETBigint -> str "bigint"
+    | ETBinder true -> str "binder"
+    | ETBinder false -> str "closed binder"
+    | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type"
+
+  let strip_meta id =
+    let s = Id.to_string id in
+    if s.[0] == '$' then Id.of_string (String.sub s 1 (String.length s - 1))
+    else id
+
+  let pr_production_item = function
+    | TacNonTerm (loc,nt,Some (p,sep)) ->
+      let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in
+      str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")"
+    | TacNonTerm (loc,nt,None) -> str nt
+    | TacTerm s -> qs s
+
+  let pr_comment pr_c = function
+    | CommentConstr c -> pr_c c
+    | CommentString s -> qs s
+    | CommentInt n -> int n
+
+  let pr_in_out_modules = function
+    | SearchInside l -> spc() ++ keyword "inside" ++ spc() ++ prlist_with_sep sep pr_module l
+    | SearchOutside [] -> mt()
+    | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l
+
+  let pr_search_about (b,c) =
+    (if b then str "-" else mt()) ++
+      match c with
+        | SearchSubPattern p -> pr_constr_pattern_expr p
+        | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc
+
+  let pr_search a gopt b pr_p =
+    pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
+    ++
+      match a with
+      | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b
+      | SearchAbout sl ->
+	 keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b
+
+  let pr_locality local = if local then keyword "Local" else keyword "Global"
+
+  let pr_explanation (e,b,f) =
+    let a = match e with
+      | ExplByPos (n,_) -> anomaly (Pp.str "No more supported")
+      | ExplByName id -> pr_id id in
+    let a = if f then str"!" ++ a else a in
+    if b then str "[" ++ a ++ str "]" else a
+
+  let pr_option_ref_value = function
+    | QualidRefValue id -> pr_reference id
+    | StringRefValue s -> qs s
+
+  let pr_printoption table b =
+    prlist_with_sep spc str table ++
+      pr_opt (prlist_with_sep sep pr_option_ref_value) b
+
+  let pr_set_option a b =
+    let pr_opt_value = function
+      | IntValue None -> assert false
+    (* This should not happen because of the grammar *)
+      | IntValue (Some n) -> spc() ++ int n
+      | StringValue s -> spc() ++ str s
+      | BoolValue b -> mt()
+    in pr_printoption a None ++ pr_opt_value b
+
+  let pr_topcmd _ = str"(* <Warning> : No printer for toplevel commands *)"
+
+  let pr_opt_hintbases l = match l with
+    | [] -> mt()
+    | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z
+
+  let pr_reference_or_constr pr_c = function
+    | HintsReference r -> pr_reference r
+    | HintsConstr c -> pr_c c
+
+  let pr_hints db h pr_c pr_pat =
+    let opth = pr_opt_hintbases db  in
+    let pph =
+      match h with
+        | HintsResolve l ->
+          keyword "Resolve " ++ prlist_with_sep sep
+            (fun (pri, _, c) -> pr_reference_or_constr pr_c c ++
+              match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ())
+            l
+        | HintsImmediate l ->
+          keyword "Immediate" ++ spc() ++
+            prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l
+        | HintsUnfold l ->
+          keyword "Unfold" ++ spc () ++ prlist_with_sep sep pr_reference l
+        | HintsTransparency (l, b) ->
+          keyword (if b then "Transparent" else "Opaque")
+          ++ spc ()
+          ++ prlist_with_sep sep pr_reference l
+        | HintsMode (m, l) ->
+          keyword "Mode"
+          ++ spc ()
+          ++ pr_reference m ++ spc() ++ prlist_with_sep spc
+            (fun b -> if b then str"+" else str"-") l
+        | HintsConstructors c ->
+          keyword "Constructors"
+          ++ spc() ++ prlist_with_sep spc pr_reference c
+        | HintsExtern (n,c,tac) ->
+          let pat = match c with None -> mt () | Some pat -> pr_pat pat in
+          keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
+            spc() ++ pr_raw_tactic tac
+    in
+    hov 2 (keyword "Hint "++ pph ++ opth)
+
+  let pr_with_declaration pr_c = function
+    | CWith_Definition (id,c) ->
+      let p = pr_c c in
+      keyword "Definition" ++ spc() ++ pr_lfqid id ++ str" := " ++ p
+    | CWith_Module (id,qid) ->
+      keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++
+        pr_located pr_qualid qid
+
+  let rec pr_module_ast leading_space pr_c = function
+    | CMident qid ->
+      if leading_space then
+        spc () ++ pr_located pr_qualid qid
+      else
+        pr_located pr_qualid qid
+    | CMwith (_,mty,decl) ->
+      let m = pr_module_ast leading_space pr_c mty in
+      let p = pr_with_declaration pr_c decl in
+      m ++ spc() ++ keyword "with" ++ spc() ++ p
+    | CMapply (_,me1,(CMident _ as me2)) ->
+      pr_module_ast leading_space pr_c me1 ++ spc() ++ pr_module_ast false pr_c me2
+    | CMapply (_,me1,me2) ->
+      pr_module_ast leading_space pr_c me1 ++ spc() ++
+        hov 1 (str"(" ++ pr_module_ast false pr_c me2 ++ str")")
+
+  let pr_inline = function
+    | DefaultInline -> mt ()
+    | NoInline -> str "[no inline]"
+    | InlineAt i -> str "[inline at level " ++ int i ++ str "]"
+
+  let pr_module_ast_inl leading_space pr_c (mast,inl) =
+    pr_module_ast leading_space pr_c mast ++ pr_inline inl
+
+  let pr_of_module_type prc = function
+    | Enforce mty -> str ":" ++ pr_module_ast_inl true prc mty
+    | Check mtys ->
+      prlist_strict (fun m -> str "<:" ++ pr_module_ast_inl true prc m) mtys
+
+  let pr_require_token = function
+    | Some true ->
+      keyword "Export" ++ spc ()
+    | Some false ->
+      keyword "Import" ++ spc ()
+    | None -> mt()
+
+  let pr_module_vardecls pr_c (export,idl,(mty,inl)) =
+    let m = pr_module_ast true pr_c mty in
+    spc() ++
+      hov 1 (str"(" ++ pr_require_token export ++
+               prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")")
+
+  let pr_module_binders l pr_c =
+    prlist_strict (pr_module_vardecls pr_c) l
+
+  let pr_type_option pr_c = function
+    | CHole (loc, k, Misctypes.IntroAnonymous, _) -> mt()
+    | _ as c -> brk(0,2) ++ str" :" ++ pr_c c
+
+  let pr_decl_notation prc ((loc,ntn),c,scopt) =
+    fnl () ++ keyword "where " ++ qs ntn ++ str " := " ++ prc c ++
+      pr_opt (fun sc -> str ": " ++ str sc) scopt
+
+  let pr_binders_arg =
+    pr_ne_sep spc pr_binders
+
+  let pr_and_type_binders_arg bl =
+    pr_binders_arg bl
+
+  let pr_onescheme (idop,schem) =
+    match schem with
+      | InductionScheme (dep,ind,s) ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc ()
+        ) ++
+          hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for")
+                 ++ spc() ++ pr_smart_global ind) ++ spc() ++
+          hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s)
+      | CaseScheme (dep,ind,s) ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc ()
+        ) ++
+          hov 0 ((if dep then keyword "Elimination for" else keyword "Case for")
+                 ++ spc() ++ pr_smart_global ind) ++ spc() ++
+          hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s)
+      | EqualityScheme ind ->
+        (match idop with
+          | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+          | None -> spc()
+        ) ++
+          hov 0 (keyword "Equality for")
+        ++ spc() ++ pr_smart_global ind
+
+  let begin_of_inductive = function
+    | [] -> 0
+    | (_,((loc,_),_))::_ -> fst (Loc.unloc loc)
+
+  let pr_class_rawexpr = function
+    | FunClass -> keyword "Funclass"
+    | SortClass -> keyword "Sortclass"
+    | RefClass qid -> pr_smart_global qid
+
+  let pr_assumption_token many (l,a) =
+    let l = match l with Some x -> x | None -> Decl_kinds.Global in
+    match l, a with
+      | (Discharge,Logical) ->
+        keyword (if many then "Hypotheses" else "Hypothesis")
+      | (Discharge,Definitional) ->
+        keyword (if many then "Variables" else "Variable")
+      | (Global,Logical) ->
+        keyword (if many then "Axioms" else "Axiom")
+      | (Global,Definitional) ->
+        keyword (if many then "Parameters" else "Parameter")
+      | (Local, Logical) ->
+        keyword (if many then "Local Axioms" else "Local Axiom")
+      | (Local,Definitional) ->
+        keyword (if many then "Local Parameters" else "Local Parameter")
+      | (Global,Conjectural) -> str"Conjecture"
+      | ((Discharge | Local),Conjectural) ->
+        anomaly (Pp.str "Don't know how to beautify a local conjecture")
+
+  let pr_params pr_c (xl,(c,t)) =
+    hov 2 (prlist_with_sep sep pr_lident xl ++ spc() ++
+             (if c then str":>" else str":" ++
+                 spc() ++ pr_c t))
+
+  let rec factorize = function
+    | [] -> []
+    | (c,(idl,t))::l ->
+      match factorize l with
+        | (xl,((c', t') as r))::l'
+            when (c : bool) == c' && Pervasives.(=) t t' ->
+          (** FIXME: we need equality on constr_expr *)
+          (idl@xl,r)::l'
+        | l' -> (idl,(c,t))::l'
+
+  let pr_ne_params_list pr_c l =
+    match factorize l with
+      | [p] -> pr_params pr_c p
+      | l ->
+        prlist_with_sep spc
+          (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l
+(*
+  prlist_with_sep pr_semicolon (pr_params pr_c)
+*)
+
+  let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k)
+
+  let pr_syntax_modifier = function
+    | SetItemLevel (l,NextLevel) ->
+      prlist_with_sep sep_v2 str l ++
+        spc() ++ keyword "at next level"
+    | SetItemLevel (l,NumLevel n) ->
+      prlist_with_sep sep_v2 str l ++
+        spc() ++ keyword "at level" ++ spc() ++ int n
+    | SetLevel n -> keyword "at level" ++ spc() ++ int n
+    | SetAssoc LeftA -> keyword "left associativity"
+    | SetAssoc RightA -> keyword "right associativity"
+    | SetAssoc NonA -> keyword "no associativity"
+    | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ
+    | SetOnlyParsing Flags.Current -> keyword "only parsing"
+    | SetOnlyParsing v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"")
+    | SetFormat("text",s) -> keyword "format " ++ pr_located qs s
+    | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_located qs s
+
+  let pr_syntax_modifiers = function
+    | [] -> mt()
+    | l -> spc() ++
+      hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")")
+
+  let print_level n =
+    if not (Int.equal n 0) then
+      spc () ++ tag_keyword (str "(at level " ++ int n ++ str ")")
+    else
+      mt ()
+
+  let pr_grammar_tactic_rule n (_,pil,t) =
+    hov 2 (keyword "Tactic Notation" ++ print_level n ++ spc() ++
+             hov 0 (prlist_with_sep sep pr_production_item pil ++
+                      spc() ++ str":=" ++ spc() ++ pr_raw_tactic t))
+
+  let pr_statement head (id,(bl,c,guard)) =
+    assert (not (Option.is_empty id));
+    hov 2
+      (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++
+         (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++
+         pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++
+         str":" ++ pr_spc_lconstr c)
+
+  let pr_priority = function
+    | None -> mt ()
+    | Some i -> spc () ++ str "|" ++ spc () ++ int i
+
+(**************************************)
+(* Pretty printer for vernac commands *)
+(**************************************)
+  let make_pr_vernac pr_constr pr_lconstr =
+    let pr_constrarg c = spc () ++ pr_constr c in
+    let pr_lconstrarg c = spc () ++ pr_lconstr c in
+    let pr_intarg n = spc () ++ int n in
+    let pr_oc = function
+    None -> str" :"
+      | Some true -> str" :>"
+      | Some false -> str" :>>"
+    in
+    let pr_record_field ((x, pri), ntn) =
+      let prx = match x with
+        | (oc,AssumExpr (id,t)) ->
+          hov 1 (pr_lname id ++
+                   pr_oc oc ++ spc() ++
+                   pr_lconstr_expr t)
+        | (oc,DefExpr(id,b,opt)) -> (match opt with
+            | Some t ->
+              hov 1 (pr_lname id ++
+                       pr_oc oc ++ spc() ++
+                       pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b)
+            | None ->
+              hov 1 (pr_lname id ++ str" :=" ++ spc() ++
+                       pr_lconstr b)) in
+      let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in
+      prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn
+    in
+    let pr_record_decl b c fs =
+      pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++
+        hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}")
+    in
+
+    let pr_printable = function
+      | PrintFullContext ->
+        keyword "Print All"
+      | PrintSectionContext s ->
+        keyword "Print Section" ++ spc() ++ Libnames.pr_reference s
+      | PrintGrammar ent ->
+        keyword "Print Grammar" ++ spc() ++ str ent
+      | PrintLoadPath dir ->
+        keyword "Print LoadPath" ++ pr_opt pr_dirpath dir
+      | PrintModules ->
+        keyword "Print Modules"
+      | PrintMLLoadPath ->
+        keyword "Print ML Path"
+      | PrintMLModules ->
+        keyword "Print ML Modules"
+      | PrintDebugGC ->
+        keyword "Print ML GC"
+      | PrintGraph ->
+        keyword "Print Graph"
+      | PrintClasses ->
+        keyword "Print Classes"
+      | PrintTypeClasses ->
+        keyword "Print TypeClasses"
+      | PrintInstances qid ->
+        keyword "Print Instances" ++ spc () ++ pr_smart_global qid
+      | PrintLtac qid ->
+        keyword "Print Ltac" ++ spc() ++ pr_ltac_ref qid
+      | PrintCoercions ->
+        keyword "Print Coercions"
+      | PrintCoercionPaths (s,t) ->
+        keyword "Print Coercion Paths" ++ spc()
+        ++ pr_class_rawexpr s ++ spc()
+        ++ pr_class_rawexpr t
+      | PrintCanonicalConversions ->
+        keyword "Print Canonical Structures"
+      | PrintTables ->
+        keyword "Print Tables"
+      | PrintHintGoal ->
+        keyword "Print Hint"
+      | PrintHint qid ->
+        keyword "Print Hint" ++ spc () ++ pr_smart_global qid
+      | PrintHintDb ->
+        keyword "Print Hint *"
+      | PrintHintDbName s ->
+        keyword "Print HintDb" ++ spc () ++ str s
+      | PrintRewriteHintDbName s ->
+        keyword "Print Rewrite HintDb" ++ spc() ++ str s
+      | PrintUniverses (b, fopt) ->
+        let cmd =
+          if b then "Print Sorted Universes"
+          else "Print Universes"
+        in
+        keyword cmd ++ pr_opt str fopt
+      | PrintName qid ->
+        keyword "Print" ++ spc()  ++ pr_smart_global qid
+      | PrintModuleType qid ->
+        keyword "Print Module Type" ++ spc() ++ pr_reference qid
+      | PrintModule qid ->
+        keyword "Print Module" ++ spc() ++ pr_reference qid
+      | PrintInspect n ->
+        keyword "Inspect" ++ spc() ++ int n
+      | PrintScopes ->
+        keyword "Print Scopes"
+      | PrintScope s ->
+        keyword "Print Scope" ++ spc() ++ str s
+      | PrintVisibility s ->
+        keyword "Print Visibility" ++ pr_opt str s
+      | PrintAbout (qid,gopt) ->
+         pr_opt (fun g -> int g ++ str ":"++ spc()) gopt
+	 ++ keyword "About" ++ spc()  ++ pr_smart_global qid
+      | PrintImplicit qid ->
+        keyword "Print Implicit" ++ spc()  ++ pr_smart_global qid
+      (* spiwack: command printing all the axioms and section variables used in a
+         term *)
+      | PrintAssumptions (b, t, qid) ->
+        let cmd = match b, t with
+          | true, true -> "Print All Dependencies"
+          | true, false -> "Print Opaque Dependencies"
+          | false, true -> "Print Transparent Dependencies"
+          | false, false -> "Print Assumptions"
+        in
+        keyword cmd ++ spc() ++ pr_smart_global qid
+      | PrintNamespace dp ->
+        keyword "Print Namespace" ++ pr_dirpath dp
+      | PrintStrategy None ->
+        keyword "Print Strategies"
+      | PrintStrategy (Some qid) ->
+        keyword "Print Strategy" ++ pr_smart_global qid
+    in
+
+    let pr_using e = str (Proof_using.to_string e) in
+
+    let rec pr_vernac v =
+      let return = Taggers.tag_vernac v in
+      match v with
+        | VernacPolymorphic (poly, v) ->
+          let s = if poly then keyword "Polymorphic" else keyword "Monomorphic" in
+          return (s ++ pr_vernac v)
+        | VernacProgram v ->
+          return (keyword "Program" ++ spc() ++ pr_vernac v)
+        | VernacLocal (local, v) ->
+          return (pr_locality local ++ spc() ++ pr_vernac v)
+
+        (* Stm *)
+        | VernacStm JoinDocument ->
+          return (keyword "Stm JoinDocument")
+        | VernacStm PrintDag ->
+          return (keyword "Stm PrintDag")
+        | VernacStm Finish ->
+          return (keyword "Stm Finish")
+        | VernacStm Wait ->
+          return (keyword "Stm Wait")
+        | VernacStm (Observe id) ->
+          return (keyword "Stm Observe " ++ str(Stateid.to_string id))
+        | VernacStm (Command v) ->
+          return (keyword "Stm Command " ++ pr_vernac v)
+        | VernacStm (PGLast v) ->
+          return (keyword "Stm PGLast " ++ pr_vernac v)
+
+        (* Proof management *)
+        | VernacAbortAll ->
+          return (keyword "Abort All")
+        | VernacRestart ->
+          return (keyword "Restart")
+        | VernacUnfocus ->
+          return (keyword "Unfocus")
+        | VernacUnfocused ->
+          return (keyword "Unfocused")
+        | VernacGoal c ->
+          return (keyword "Goal" ++ pr_lconstrarg c)
+        | VernacAbort id ->
+          return (keyword "Abort" ++ pr_opt pr_lident id)
+        | VernacUndo i ->
+          return (
+            if Int.equal i 1 then keyword "Undo" else keyword "Undo" ++ pr_intarg i
+          )
+        | VernacUndoTo i ->
+          return (keyword "Undo" ++ spc() ++ keyword "To" ++ pr_intarg i)
+        | VernacBacktrack (i,j,k) ->
+          return (keyword "Backtrack" ++  spc() ++ prlist_with_sep sep int [i;j;k])
+        | VernacFocus i ->
+          return (keyword "Focus" ++ pr_opt int i)
+        | VernacShow s ->
+          let pr_goal_reference = function
+            | OpenSubgoals -> mt ()
+            | NthGoal n -> spc () ++ int n
+            | GoalId n -> spc () ++ str n in
+          let pr_showable = function
+            | ShowGoal n -> keyword "Show" ++ pr_goal_reference n
+            | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n
+            | ShowProof -> keyword "Show Proof"
+            | ShowNode -> keyword "Show Node"
+            | ShowScript -> keyword "Show Script"
+            | ShowExistentials -> keyword "Show Existentials"
+            | ShowUniverses -> keyword "Show Universes"
+            | ShowTree -> keyword "Show Tree"
+            | ShowProofNames -> keyword "Show Conjectures"
+            | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro")
+            | ShowMatch id -> keyword "Show Match " ++ pr_lident id
+            | ShowThesis -> keyword "Show Thesis"
+          in
+          return (pr_showable s)
+        | VernacCheckGuard ->
+          return (keyword "Guarded")
+
+      (* Resetting *)
+        | VernacResetName id ->
+          return (keyword "Reset" ++ spc() ++ pr_lident id)
+        | VernacResetInitial ->
+          return (keyword "Reset Initial")
+        | VernacBack i ->
+          return (
+            if Int.equal i 1 then keyword "Back" else keyword "Back" ++ pr_intarg i
+          )
+        | VernacBackTo i ->
+          return (keyword "BackTo" ++ pr_intarg i)
+
+      (* State management *)
+        | VernacWriteState s ->
+          return (keyword "Write State" ++ spc () ++ qs s)
+        | VernacRestoreState s ->
+          return  (keyword "Restore State" ++ spc() ++ qs s)
+
+      (* Control *)
+        | VernacLoad (f,s) ->
+          return (
+            keyword "Load"
+            ++ if f then
+                (spc() ++ keyword "Verbose" ++ spc())
+              else
+                spc() ++ qs s
+          )
+        | VernacTime v ->
+          return (keyword "Time" ++ spc() ++ pr_vernac_list v)
+        | VernacTimeout(n,v) ->
+          return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac v)
+        | VernacFail v ->
+          return (keyword "Fail" ++ spc() ++ pr_vernac v)
+        | VernacError _ ->
+          return (keyword "No-parsing-rule for VernacError")
+
+      (* Syntax *)
+        | VernacTacticNotation (n,r,e) ->
+          return (pr_grammar_tactic_rule n ("",r,e))
+        | VernacOpenCloseScope (_,(opening,sc)) ->
+          return (
+            keyword (if opening then "Open " else "Close ") ++
+              keyword "Scope" ++ spc() ++ str sc
+          )
+        | VernacDelimiters (sc,key) ->
+          return (
+            keyword "Delimit Scope" ++ spc () ++ str sc ++
+              spc() ++ keyword "with" ++ spc () ++ str key
+          )
+        | VernacBindScope (sc,cll) ->
+          return (
+            keyword "Bind Scope" ++ spc () ++ str sc ++
+              spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_smart_global cll
+          )
+        | VernacArgumentsScope (q,scl) ->
+          let pr_opt_scope = function
+            | None -> str"_"
+            | Some sc -> str sc
+          in
+          return (
+            keyword "Arguments Scope"
+            ++ spc() ++ pr_smart_global q
+            ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]"
+          )
+        | VernacInfix (_,((_,s),mv),q,sn) -> (* A Verifier *)
+          return (
+            hov 0 (hov 0 (keyword "Infix "
+                          ++ qs s ++ str " :=" ++ pr_constrarg q) ++
+                     pr_syntax_modifiers mv ++
+                     (match sn with
+                       | None -> mt()
+                       | Some sc -> spc() ++ str":" ++ spc() ++ str sc))
+          )
+        | VernacNotation (_,c,((_,s),l),opt) ->
+          let ps =
+            let n = String.length s in
+            if n > 2 && s.[0] == '\'' && s.[n-1] == '\''
+            then
+              let s' = String.sub s 1 (n-2) in
+              if String.contains s' '\'' then qs s else str s'
+            else qs s
+          in
+          return (
+            hov 2 (keyword "Notation" ++ spc() ++ ps ++
+                     str " :=" ++ pr_constrarg c ++ pr_syntax_modifiers l ++
+                     (match opt with
+                       | None -> mt()
+                       | Some sc -> str" :" ++ spc() ++ str sc))
+          )
+        | VernacSyntaxExtension (_,(s,l)) ->
+          return (
+            keyword "Reserved Notation" ++ spc() ++ pr_located qs s ++
+              pr_syntax_modifiers l
+          )
+        | VernacNotationAddFormat(s,k,v) ->
+          return (
+            keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v
+          )
+
+        (* Gallina *)
+        | VernacDefinition (d,id,b) -> (* A verifier... *)
+          let pr_def_token (l,dk) =
+            let l = match l with Some x -> x | None -> Decl_kinds.Global in
+            keyword (Kindops.string_of_definition_kind (l,false,dk))
+          in
+          let pr_reduce = function
+            | None -> mt()
+            | Some r ->
+              keyword "Eval" ++ spc() ++
+                pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) r ++
+                keyword " in" ++ spc()
+          in
+          let pr_def_body = function
+            | DefineBody (bl,red,body,d) ->
+              let ty = match d with
+                | None -> mt()
+                | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty
+              in
+              (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body))
+            | ProveBody (bl,t) ->
+              (pr_binders_arg bl, str" :" ++ pr_spc_lconstr t, None) in
+          let (binds,typ,c) = pr_def_body b in
+          return (
+            hov 2 (
+              pr_def_token d ++ spc()
+              ++ pr_lident id ++ binds ++ typ
+              ++ (match c with
+                | None -> mt()
+                | Some cc -> str" :=" ++ spc() ++ cc))
+          )
+
+        | VernacStartTheoremProof (ki,l,_) ->
+          return (
+            hov 1 (pr_statement (pr_thm_token ki) (List.hd l) ++
+                     prlist (pr_statement (spc () ++ keyword "with")) (List.tl l))
+          )
+
+        | VernacEndProof Admitted ->
+          return (keyword "Admitted")
+
+        | VernacEndProof (Proved (opac,o)) -> return (
+          match o with
+            | None -> if opac then keyword "Qed" else keyword "Defined"
+            | Some (id,th) -> (match th with
+                | None -> (if opac then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id
+                | Some tok -> keyword "Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)
+        )
+        | VernacExactProof c ->
+          return (hov 2 (keyword "Proof" ++ pr_lconstrarg c))
+        | VernacAssumption (stre,_,l) ->
+          let n = List.length (List.flatten (List.map fst (List.map snd l))) in
+          return (
+            hov 2
+              (pr_assumption_token (n > 1) stre ++ spc() ++
+                 pr_ne_params_list pr_lconstr_expr l)
+          )
+        | VernacInductive (p,f,l) ->
+          let pr_constructor (coe,(id,c)) =
+            hov 2 (pr_lident id ++ str" " ++
+                     (if coe then str":>" else str":") ++
+                     pr_spc_lconstr c)
+          in
+          let pr_constructor_list b l = match l with
+            | Constructors [] -> mt()
+            | Constructors l ->
+              let fst_sep = match l with [_] -> "   " | _ -> " | " in
+              pr_com_at (begin_of_inductive l) ++
+                fnl() ++ str fst_sep ++
+                prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l
+            | RecordDecl (c,fs) ->
+              pr_record_decl b c fs
+          in
+          let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) =
+            hov 0 (
+              str key ++ spc() ++
+                (if coe then str"> " else str"") ++ pr_lident id ++
+                pr_and_type_binders_arg indpar ++ spc() ++
+                Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++
+                str" :=") ++ pr_constructor_list k lc ++
+              prlist (pr_decl_notation pr_constr) ntn
+          in
+          let key =
+            let (_,_,_,k,_),_ = List.hd l in
+            match k with Record -> "Record" | Structure -> "Structure"
+              | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive"
+              | Class _ -> "Class" | Variant -> "Variant"
+          in
+          return (
+            hov 1 (pr_oneind key (List.hd l)) ++
+              (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
+          )
+
+        | VernacFixpoint (local, recs) ->
+          let local = match local with
+            | Some Discharge -> "Let "
+            | Some Local -> "Local "
+            | None | Some Global -> ""
+          in
+          let pr_onerec = function
+            | ((loc,id),ro,bl,type_,def),ntn ->
+              let annot = pr_guard_annot pr_lconstr_expr bl ro in
+              pr_id id ++ pr_binders_arg bl ++ annot
+              ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
+              ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
+                prlist (pr_decl_notation pr_constr) ntn
+          in
+          return (
+            hov 0 (str local ++ keyword "Fixpoint" ++ spc () ++
+                     prlist_with_sep (fun _ -> fnl () ++ keyword "with" ++ spc ()) pr_onerec recs)
+          )
+
+        | VernacCoFixpoint (local, corecs) ->
+          let local = match local with
+            | Some Discharge -> keyword "Let" ++ spc ()
+            | Some Local -> keyword "Local" ++ spc ()
+            | None | Some Global -> str ""
+          in
+          let pr_onecorec (((loc,id),bl,c,def),ntn) =
+            pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++
+              spc() ++ pr_lconstr_expr c ++
+              pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
+              prlist (pr_decl_notation pr_constr) ntn
+          in
+          return (
+            hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++
+                     prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onecorec corecs)
+          )
+        | VernacScheme l ->
+          return (
+            hov 2 (keyword "Scheme" ++ spc() ++
+                     prlist_with_sep (fun _ -> fnl() ++ keyword "with" ++ spc ()) pr_onescheme l)
+          )
+        | VernacCombinedScheme (id, l) ->
+          return (
+            hov 2 (keyword "Combined Scheme" ++ spc() ++
+                     pr_lident id ++ spc() ++ keyword "from" ++ spc() ++
+                     prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l)
+          )
+        | VernacUniverse v ->
+          return (
+            hov 2 (keyword "Universe" ++ spc () ++
+                     prlist_with_sep (fun _ -> str",") pr_lident v)
+          )
+        | VernacConstraint v ->
+          let pr_uconstraint (l, d, r) =
+            pr_lident l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_lident r
+          in
+          return (
+            hov 2 (keyword "Constraint" ++ spc () ++
+                     prlist_with_sep (fun _ -> str",") pr_uconstraint v)
+          )
+
+        (* Gallina extensions *)
+        | VernacBeginSection id ->
+          return (hov 2 (keyword "Section" ++ spc () ++ pr_lident id))
+        | VernacEndSegment id ->
+          return (hov 2 (keyword "End" ++ spc() ++ pr_lident id))
+        | VernacNameSectionHypSet (id,set) ->
+          return (hov 2 (keyword "Package" ++ spc() ++ pr_lident id ++ spc()++
+          str ":="++spc()++pr_using set))
+        | VernacRequire (exp, l) ->
+          return (
+            hov 2
+              (keyword "Require" ++ spc() ++ pr_require_token exp ++
+                 prlist_with_sep sep pr_module l)
+          )
+        | VernacImport (f,l) ->
+          return (
+            (if f then keyword "Export" else keyword "Import") ++ spc() ++
+              prlist_with_sep sep pr_import_module l
+          )
+        | VernacCanonical q ->
+          return (
+            keyword "Canonical Structure" ++ spc() ++ pr_smart_global q
+          )
+        | VernacCoercion (_,id,c1,c2) ->
+          return (
+            hov 1 (
+              keyword "Coercion" ++ spc() ++
+                pr_smart_global id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++
+                spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2)
+          )
+        | VernacIdentityCoercion (_,id,c1,c2) ->
+          return (
+            hov 1 (
+              keyword "Identity Coercion" ++ spc() ++ pr_lident id ++
+                spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
+                spc() ++ pr_class_rawexpr c2)
+          )
+
+        | VernacInstance (abst, sup, (instid, bk, cl), props, pri) ->
+          return (
+            hov 1 (
+              (if abst then keyword "Declare" ++ spc () else mt ()) ++
+                keyword "Instance" ++
+                (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () |
+                    Anonymous -> mt ()) ++
+                pr_and_type_binders_arg sup ++
+                str":" ++ spc () ++
+                pr_constr cl ++ pr_priority pri ++
+                (match props with
+                  | Some (_,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p
+                  | None -> mt()))
+          )
+
+        | VernacContext l ->
+          return (
+            hov 1 (
+              keyword "Context" ++ spc () ++ pr_and_type_binders_arg l)
+          )
+
+        | VernacDeclareInstances (ids, pri) ->
+          return (
+            hov 1 (keyword "Existing" ++ spc () ++
+                     keyword(String.plural (List.length ids) "Instance") ++
+                     spc () ++ prlist_with_sep spc pr_reference ids ++ pr_priority pri)
+          )
+
+        | VernacDeclareClass id ->
+          return (
+            hov 1 (keyword "Existing" ++ spc () ++ keyword "Class" ++ spc () ++ pr_reference id)
+          )
+
+        (* Modules and Module Types *)
+        | VernacDefineModule (export,m,bl,tys,bd) ->
+          let b = pr_module_binders bl pr_lconstr in
+          return (
+            hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++
+                     pr_lident m ++ b ++
+                     pr_of_module_type pr_lconstr tys ++
+                     (if List.is_empty bd then mt () else str ":= ") ++
+                     prlist_with_sep (fun () -> str " <+ ")
+                     (pr_module_ast_inl true pr_lconstr) bd)
+          )
+        | VernacDeclareModule (export,id,bl,m1) ->
+          let b = pr_module_binders bl pr_lconstr in
+          return (
+            hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++
+                     pr_lident id ++ b ++
+                     pr_module_ast_inl true pr_lconstr m1)
+          )
+        | VernacDeclareModuleType (id,bl,tyl,m) ->
+          let b = pr_module_binders bl pr_lconstr in
+          let pr_mt = pr_module_ast_inl true pr_lconstr in
+          return (
+            hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++
+                     prlist_strict (fun m -> str " <: " ++ pr_mt m) tyl ++
+                     (if List.is_empty m then mt () else str ":= ") ++
+                     prlist_with_sep (fun () -> str " <+ ") pr_mt m)
+          )
+        | VernacInclude (mexprs) ->
+          let pr_m = pr_module_ast_inl false pr_lconstr in
+          return (
+            hov 2 (keyword "Include" ++ spc() ++
+                     prlist_with_sep (fun () -> str " <+ ") pr_m mexprs)
+          )
+        (* Solving *)
+      | VernacSolve (i,info,tac,deftac) ->
+        let pr_goal_selector = function
+          | SelectNth i -> int i ++ str":"
+          | SelectId id -> pr_id id ++ str":"
+          | SelectAll -> str"all" ++ str":"
+          | SelectAllParallel -> str"par"
+        in
+        let pr_info =
+          match info with
+            | None -> mt ()
+            | Some i -> str"Info"++spc()++int i++spc()
+        in
+        return (
+          (if i = Proof_global.get_default_goal_selector () then mt() else pr_goal_selector i) ++
+          pr_info ++
+          pr_raw_tactic tac
+          ++ (if deftac then str ".." else mt ())
+        )
+        | VernacSolveExistential (i,c) ->
+          return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c)
+
+        (* Auxiliary file and library management *)
+        | VernacAddLoadPath (fl,s,d) ->
+          return (
+            hov 2
+              (keyword "Add" ++
+                 (if fl then spc () ++ keyword "Rec" ++ spc () else spc()) ++
+                 keyword "LoadPath" ++ spc() ++ qs s ++
+                 (match d with
+                   | None -> mt()
+                   | Some dir -> spc() ++ keyword "as" ++ spc() ++ pr_dirpath dir))
+          )
+        | VernacRemoveLoadPath s ->
+          return (keyword "Remove LoadPath" ++ qs s)
+        | VernacAddMLPath (fl,s) ->
+          return (
+            keyword "Add"
+            ++ (if fl then spc () ++ keyword "Rec" ++ spc () else spc())
+            ++ keyword "ML Path"
+            ++ qs s
+          )
+        | VernacDeclareMLModule (l) ->
+          return (
+            hov 2 (keyword "Declare ML Module" ++ spc() ++ prlist_with_sep sep qs l)
+          )
+        | VernacChdir s ->
+          return (keyword "Cd" ++ pr_opt qs s)
+
+        (* Commands *)
+        | VernacDeclareTacticDefinition (rc,l) ->
+          let pr_tac_body (id, redef, body) =
+            let idl, body =
+              match body with
+                | Tacexpr.TacFun (idl,b) -> idl,b
+                | _ -> [], body in
+            pr_ltac_ref id ++
+              prlist (function None -> str " _"
+                | Some id -> spc () ++ pr_id id) idl
+            ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++
+              pr_raw_tactic body
+          in
+          return (
+            hov 1
+              (keyword "Ltac" ++ spc () ++
+                 prlist_with_sep (fun () ->
+                   fnl() ++ keyword "with" ++ spc ()) pr_tac_body l)
+          )
+        | VernacCreateHintDb (dbname,b) ->
+          return (
+            hov 1 (keyword "Create HintDb" ++ spc () ++
+                     str dbname ++ (if b then str" discriminated" else mt ()))
+          )
+        | VernacRemoveHints (dbnames, ids) ->
+          return (
+            hov 1 (keyword "Remove Hints" ++ spc () ++
+                     prlist_with_sep spc (fun r -> pr_id (coerce_reference_to_id r)) ids ++
+                     pr_opt_hintbases dbnames)
+          )
+        | VernacHints (_, dbnames,h) ->
+          return (pr_hints dbnames h pr_constr pr_constr_pattern_expr)
+        | VernacSyntacticDefinition (id,(ids,c),_,onlyparsing) ->
+          return (
+            hov 2
+              (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++
+                 prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++
+                 pr_syntax_modifiers
+                 (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v]))
+          )
+        | VernacDeclareImplicits (q,[]) ->
+          return (
+            hov 2 (keyword "Implicit Arguments" ++ spc() ++ pr_smart_global q)
+          )
+        | VernacDeclareImplicits (q,impls) ->
+          return (
+            hov 1 (keyword "Implicit Arguments" ++ spc () ++
+                     spc() ++ pr_smart_global q ++ spc() ++
+                     prlist_with_sep spc (fun imps ->
+                       str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]")
+                     impls)
+          )
+        | VernacArguments (q, impl, nargs, mods) ->
+          return (
+            hov 2 (
+              keyword "Arguments" ++ spc() ++
+                pr_smart_global q ++
+                let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in
+                let pr_if b x = if b then x else str "" in
+                let pr_br imp max x = match imp, max with
+                  | true, false -> str "[" ++ x ++ str "]"
+                  | true, true -> str "{" ++ x ++ str "}"
+                  | _ -> x in
+                let rec aux n l =
+                  match n, l with
+                    | 0, l -> spc () ++ str"/" ++ aux ~-1 l
+                    | _, [] -> mt()
+                    | n, (id,k,s,imp,max) :: tl ->
+                      spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++
+                        aux (n-1) tl in
+                prlist_with_sep (fun () -> str", ") (aux nargs) impl ++
+                  if not (List.is_empty mods) then str" : " else str"" ++
+                    prlist_with_sep (fun () -> str", " ++ spc()) (function
+                      | `ReductionDontExposeCase -> keyword "simpl nomatch"
+                      | `ReductionNeverUnfold -> keyword "simpl never"
+                      | `DefaultImplicits -> keyword "default implicits"
+                      | `Rename -> keyword "rename"
+                      | `Assert -> keyword "assert"
+                      | `ExtraScopes -> keyword "extra scopes"
+                      | `ClearImplicits -> keyword "clear implicits"
+                      | `ClearScopes -> keyword "clear scopes")
+                    mods)
+          )
+        | VernacReserve bl ->
+          let n = List.length (List.flatten (List.map fst bl)) in
+          return (
+            hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " "))
+                   ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl))
+          )
+        | VernacGeneralizable g ->
+          return (
+            hov 1 (tag_keyword (
+              str"Generalizable Variable" ++
+                match g with
+                  | None -> str "s none"
+                  | Some [] -> str "s all"
+                  | Some idl ->
+                    str (if List.length idl > 1 then "s " else " ") ++
+                      prlist_with_sep spc pr_lident idl)
+            ))
+        | VernacSetOpacity(k,l) when Conv_oracle.is_transparent k ->
+          return (
+            hov 1 (keyword "Transparent" ++
+                     spc() ++ prlist_with_sep sep pr_smart_global l)
+          )
+        | VernacSetOpacity(Conv_oracle.Opaque,l) ->
+          return (
+            hov 1 (keyword "Opaque" ++
+                     spc() ++ prlist_with_sep sep pr_smart_global l)
+          )
+        | VernacSetOpacity _ ->
+          return (
+            Errors.anomaly (keyword "VernacSetOpacity used to set something else")
+          )
+        | VernacSetStrategy l ->
+          let pr_lev = function
+            | Conv_oracle.Opaque -> keyword "opaque"
+            | Conv_oracle.Expand -> keyword "expand"
+            | l when Conv_oracle.is_transparent l -> keyword "transparent"
+            | Conv_oracle.Level n -> int n
+          in
+          let pr_line (l,q) =
+            hov 2 (pr_lev l ++ spc() ++
+                     str"[" ++ prlist_with_sep sep pr_smart_global q ++ str"]")
+          in
+          return (
+            hov 1 (keyword "Strategy" ++ spc() ++
+                     hv 0 (prlist_with_sep sep pr_line l))
+          )
+        | VernacUnsetOption (na) ->
+          return (
+            hov 1 (keyword "Unset" ++ spc() ++ pr_printoption na None)
+          )
+        | VernacSetOption (na,v) ->
+          return (
+            hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v)
+          )
+        | VernacAddOption (na,l) ->
+          return (
+            hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l))
+          )
+        | VernacRemoveOption (na,l) ->
+          return (
+            hov 2 (keyword "Remove" ++ spc() ++ pr_printoption na (Some l))
+          )
+        | VernacMemOption (na,l) ->
+          return (
+            hov 2 (keyword "Test" ++ spc() ++ pr_printoption na (Some l))
+          )
+        | VernacPrintOption na ->
+          return (
+            hov 2 (keyword "Test" ++ spc() ++ pr_printoption na None)
+          )
+        | VernacCheckMayEval (r,io,c) ->
+          let pr_mayeval r c = match r with
+            | Some r0 ->
+              hov 2 (keyword "Eval" ++ spc() ++
+                       pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r0 ++
+                       spc() ++ keyword "in" ++ spc () ++ pr_lconstr c)
+            | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c)
+          in
+          let pr_i = match io with None -> mt () | Some i -> int i ++ str ": " in
+          return (pr_i ++ pr_mayeval r c)
+        | VernacGlobalCheck c ->
+          return (hov 2 (keyword "Type" ++ pr_constrarg c))
+        | VernacDeclareReduction (s,r) ->
+          return (
+            keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++
+              pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) r
+          )
+        | VernacPrint p ->
+          return (pr_printable p)
+        | VernacSearch (sea,g,sea_r) ->
+          return (pr_search sea g sea_r pr_constr_pattern_expr)
+        | VernacLocate loc ->
+          let pr_locate =function
+            | LocateAny qid -> pr_smart_global qid
+            | LocateTerm qid -> keyword "Term" ++ spc() ++ pr_smart_global qid
+            | LocateFile f -> keyword "File" ++ spc() ++ qs f
+            | LocateLibrary qid -> keyword "Library" ++ spc () ++ pr_module qid
+            | LocateModule qid -> keyword "Module" ++ spc () ++ pr_module qid
+            | LocateTactic qid -> keyword "Ltac" ++ spc () ++ pr_ltac_ref qid
+          in
+          return (keyword "Locate" ++ spc() ++ pr_locate loc)
+        | VernacRegister (id, RegisterInline) ->
+          return (
+            hov 2
+              (keyword "Register Inline" ++ spc() ++ pr_lident id)
+          )
+        | VernacComments l ->
+          return (
+            hov 2
+              (keyword "Comments" ++ spc()
+               ++ prlist_with_sep sep (pr_comment pr_constr) l)
+          )
+        | VernacNop ->
+          mt()
+
+        (* Toplevel control *)
+        | VernacToplevelControl exn ->
+          return (pr_topcmd exn)
+
+        (* For extension *)
+        | VernacExtend (s,c) ->
+          return (pr_extend s c)
+        | VernacProof (None, None) ->
+          return (keyword "Proof")
+        | VernacProof (None, Some e) ->
+          return (keyword "Proof " ++ spc () ++
+              keyword "using" ++ spc() ++ pr_using e)
+        | VernacProof (Some te, None) ->
+          return (keyword "Proof with" ++ spc() ++ pr_raw_tactic te)
+        | VernacProof (Some te, Some e) ->
+          return (
+            keyword "Proof" ++ spc () ++
+              keyword "using" ++ spc() ++ pr_using e ++ spc() ++
+              keyword "with" ++ spc() ++pr_raw_tactic te
+          )
+        | VernacProofMode s ->
+          return (keyword "Proof Mode" ++ str s)
+        | VernacBullet b ->
+          return (begin match b with
+            | Dash n -> str (String.make n '-')
+            | Star n -> str (String.make n '*')
+            | Plus n -> str (String.make n '+')
+          end ++ spc())
+        | VernacSubproof None ->
+          return (str "{")
+        | VernacSubproof (Some i) ->
+          return (keyword "BeginSubproof" ++ spc () ++ int i)
+        | VernacEndSubproof ->
+          return (str "}")
+
+    and pr_vernac_list l =
+      hov 2 (str"[" ++ spc() ++
+               prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l
+             ++ spc() ++ str"]")
+
+    and pr_extend s cl =
+      let pr_arg a =
+        try pr_gen a
+        with Failure _ -> str ("<error in "^fst s^">") in
+      try
+        let rl = Egramml.get_extend_vernac_rule s in
+        let start,rl,cl =
+          match rl with
+            | Egramml.GramTerminal s :: rl -> str s, rl, cl
+            | Egramml.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl
+            | [] -> anomaly (Pp.str "Empty entry") in
+        let (pp,_) =
+          List.fold_left
+            (fun (strm,args) pi ->
+              let pp,args = match pi with
+                | Egramml.GramNonTerminal _ -> (pr_arg (List.hd args), List.tl args)
+                | Egramml.GramTerminal s -> (str s, args) in
+              (strm ++ spc() ++ pp), args)
+            (start,cl) rl in
+        hov 1 pp
+      with Not_found ->
+        hov 1 (str ("TODO("^fst s) ++ prlist_with_sep sep pr_arg cl ++ str ")")
+
+    in pr_vernac
+
+  let pr_vernac_body v = make_pr_vernac pr_constr_expr pr_lconstr_expr v
+
+  let pr_vernac v = make_pr_vernac pr_constr_expr pr_lconstr_expr v ++ sep_end v
+
+  let pr_vernac x =
+    try pr_vernac x
+    with e -> Errors.print e
+
+end
+
+include Make (Ppconstr) (Pptactic) (struct
+  let do_not_tag _ x = x
+  let tag_keyword = do_not_tag ()
+  let tag_vernac  = do_not_tag
+end)
+
+module Richpp = struct
+
+  include Make
+    (Ppconstr.Richpp)
+    (Pptactic.Richpp)
+    (struct
+      open Ppannotation
+      let tag_keyword s = Pp.tag (Pp.Tag.inj AKeyword tag) s
+      let tag_vernac v s = Pp.tag (Pp.Tag.inj (AVernac v) tag) s
+     end)
+
+end
diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli
new file mode 100644
index 00000000..f38848cd
--- /dev/null
+++ b/printing/ppvernac.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module implements pretty-printers for vernac_expr syntactic
+    objects and their subcomponents. *)
+
+(** The default pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as raw strings. *)
+include Ppvernacsig.Pp
+
+(** The rich pretty-printers produce {!Pp.std_ppcmds} that are
+    interpreted as annotated strings. The annotations can be
+    retrieved using {!RichPp.rich_pp}. Their definitions are
+    located in {!Ppannotation.t}. *)
+module Richpp : Ppvernacsig.Pp
diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli
new file mode 100644
index 00000000..cfcd4974
--- /dev/null
+++ b/printing/ppvernacsig.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type Pp = sig
+
+  (** Prints a vernac expression *)
+  val pr_vernac_body : Vernacexpr.vernac_expr -> Pp.std_ppcmds
+
+  (** Prints a vernac expression and closes it with a dot. *)
+  val pr_vernac : Vernacexpr.vernac_expr -> Pp.std_ppcmds
+
+end
diff --git a/parsing/prettyp.ml b/printing/prettyp.ml
index 3b3fb2c3..223377c2 100644
--- a/parsing/prettyp.ml
+++ b/printing/prettyp.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        *)
@@ -11,25 +11,22 @@
  *)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Term
 open Termops
 open Declarations
-open Inductive
-open Inductiveops
-open Sign
-open Reduction
 open Environ
-open Declare
 open Impargs
 open Libobject
-open Printer
-open Printmod
 open Libnames
-open Nametab
+open Globnames
 open Recordops
+open Misctypes
+open Printer
+open Printmod
 
 type object_pr = {
   print_inductive           : mutual_inductive -> std_ppcmds;
@@ -38,11 +35,11 @@ type object_pr = {
   print_syntactic_def       : kernel_name -> std_ppcmds;
   print_module              : bool -> Names.module_path -> std_ppcmds;
   print_modtype             : module_path -> std_ppcmds;
-  print_named_decl          : identifier * constr option * types -> std_ppcmds;
+  print_named_decl          : Id.t * constr option * types -> std_ppcmds;
   print_library_entry       : bool -> (object_name * Lib.node) -> std_ppcmds option;
   print_context             : bool -> int option -> Lib.library_segment -> std_ppcmds;
-  print_typed_value_in_env  : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds;
-  print_eval                : Reductionops.reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds;
+  print_typed_value_in_env  : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
+  print_eval                : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds;
 }
 
 let gallina_print_module  = print_module
@@ -53,15 +50,15 @@ let gallina_print_modtype = print_modtype
 
 let print_closed_sections = ref false
 
-let pr_infos_list l = v 0 (prlist_with_sep cut (fun x -> x) l) ++ fnl()
+let pr_infos_list l = v 0 (prlist_with_sep cut (fun x -> x) l)
 
-let with_line_skip l = if l = [] then mt() else fnl() ++ pr_infos_list l
+let with_line_skip l = if List.is_empty l then mt() else fnl() ++ fnl () ++ pr_infos_list l
 
 let blankline = mt() (* add a blank sentence in the list of infos *)
 
 let add_colon prefix = if ismt prefix then mt () else prefix ++ str ": "
 
-let int_or_no n = if n=0 then str "no" else int n
+let int_or_no n = if Int.equal n 0 then str "no" else int n
 
 (*******************)
 (** Basic printing *)
@@ -69,33 +66,34 @@ let int_or_no n = if n=0 then str "no" else int n
 let print_basename sp = pr_global (ConstRef sp)
 
 let print_ref reduce ref =
-  let typ = Global.type_of_global ref in
+  let typ = Global.type_of_global_unsafe ref in
   let typ =
     if reduce then
       let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ
       in it_mkProd_or_LetIn ccl ctx
     else typ in
-  hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ)
+  let univs = Global.universes_of_global ref in
+  hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ ++ 
+  	   Printer.pr_universe_ctx univs)
 
 (********************************)
 (** Printing implicit arguments *)
 
-let conjugate_verb_to_be = function [_] -> "is" | _ -> "are"
-
 let pr_impl_name imp = pr_id (name_of_implicit imp)
 
 let print_impargs_by_name max = function
   | []  -> []
   | impls ->
-     [hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++
+     let n = List.length impls in
+     [hov 0 (str (String.plural n "Argument") ++ spc() ++
       prlist_with_sep pr_comma pr_impl_name impls ++ spc() ++
-      str (conjugate_verb_to_be impls) ++ str" implicit" ++
+      str (String.conjugate_verb_to_be n) ++ str" implicit" ++
       (if max then strbrk " and maximally inserted" else mt()))]
 
 let print_one_impargs_list l =
   let imps = List.filter is_status_implicit l in
   let maximps = List.filter Impargs.maximal_insertion_of imps in
-  let nonmaximps = list_subtract imps maximps in
+  let nonmaximps = List.subtract Pervasives.(=) imps maximps in (* FIXME *)
   print_impargs_by_name false nonmaximps @
   print_impargs_by_name true maximps
 
@@ -110,32 +108,32 @@ let print_impargs_list prefix l =
        [v 2 (prlist_with_sep cut (fun x -> x)
 	 [(if ismt prefix then str "When" else prefix ++ str ", when") ++
 	   str " applied to " ++
-	   (if n1 = n2 then int_or_no n2 else
-	    if n1 = 0 then str "less than " ++ int n2
+	   (if Int.equal n1 n2 then int_or_no n2 else
+	    if Int.equal n1 0 then str "less than " ++ int n2
 	    else int n1 ++ str " to " ++ int_or_no n2) ++
-	    str (plural n2 " argument") ++ str ":";
+	    str (String.plural n2 " argument") ++ str ":";
           v 0 (prlist_with_sep cut (fun x -> x)
 	    (if List.exists is_status_implicit imps
 	    then print_one_impargs_list imps
 	    else [str "No implicit arguments"]))])]) l)
 
 let print_renames_list prefix l =
-  if l = [] then [] else
+  if List.is_empty l then [] else
   [add_colon prefix ++ str "Arguments are renamed to " ++
     hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map pr_name l))]
 
 let need_expansion impl ref =
-  let typ = Global.type_of_global ref in
-  let ctx = (prod_assum typ) in
-  let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in
-  impl <> [] & List.length impl >= nprods &
-    let _,lastimpl = list_chop nprods impl in
-      List.filter is_status_implicit lastimpl <> []
+  let typ = Global.type_of_global_unsafe ref in
+  let ctx = prod_assum typ in
+  let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in
+  not (List.is_empty impl) && List.length impl >= nprods &&
+    let _,lastimpl = List.chop nprods impl in
+      List.exists is_status_implicit lastimpl
 
 let print_impargs ref =
   let ref = Smartlocate.smart_global ref in
   let impl = implicits_of_global ref in
-  let has_impl = impl <> [] in
+  let has_impl = not (List.is_empty impl) in
   (* Need to reduce since implicits are computed with products flattened *)
   pr_infos_list
     ([ print_ref (need_expansion (select_impargs_size 0 impl) ref) ref;
@@ -149,52 +147,13 @@ let print_impargs ref =
 let print_argument_scopes prefix = function
   | [Some sc] ->
       [add_colon prefix ++ str"Argument scope is [" ++ str sc ++ str"]"]
-  | l when not (List.for_all ((=) None) l) ->
+  | l when not (List.for_all Option.is_empty l) ->
      [add_colon prefix ++ hov 2 (str"Argument scopes are" ++ spc() ++
       str "[" ++
-      prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++
+      pr_sequence (function Some sc -> str sc | None -> str "_") l ++
       str "]")]
   | _  -> []
 
-(*****************************)
-(** Printing simpl behaviour *)
-
-let print_simpl_behaviour ref =
-  match Tacred.get_simpl_behaviour ref with
-  | None -> []
-  | Some (recargs, nargs, flags) ->
-     let never = List.mem `SimplNeverUnfold flags in
-     let nomatch = List.mem `SimplDontExposeCase flags in
-     let pp_nomatch = spc() ++ if nomatch then
-       str "avoiding to expose match constructs" else str"" in
-     let pp_recargs = spc() ++ str "when the " ++
-       let rec aux = function
-         | [] -> mt()
-         | [x] -> str (ordinal (x+1))
-         | [x;y] -> str (ordinal (x+1)) ++ str " and " ++ str (ordinal (y+1))
-         | x::tl -> str (ordinal (x+1)) ++ str ", " ++ aux tl in
-       aux recargs ++ str (plural (List.length recargs) " argument") ++
-       str (plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++
-       str " to a constructor" in
-     let pp_nargs =
-       spc() ++ str "when applied to " ++ int nargs ++
-       str (plural nargs " argument") in
-     [hov 2 (str "The simpl tactic " ++
-     match recargs, nargs, never with
-     | _,_, true -> str "never unfolds " ++ pr_global ref
-     | [], 0, _ -> str "always unfolds " ++ pr_global ref
-     | _::_, n, _ when n < 0 ->
-        str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
-     | _::_, n, _ when n > List.fold_left max 0 recargs ->
-        str "unfolds " ++ pr_global ref ++ pp_recargs ++
-        str " and" ++ pp_nargs ++ pp_nomatch
-     | _::_, _, _ ->
-        str "unfolds " ++ pr_global ref ++ pp_recargs ++ pp_nomatch
-     | [], n, _ when n > 0 ->
-        str "unfolds " ++ pr_global ref ++ pp_nargs ++ pp_nomatch
-     | _ -> str "unfolds " ++ pr_global ref ++ pp_nomatch )]
-;;
-
 (*********************)
 (** Printing Opacity *)
 
@@ -203,15 +162,17 @@ type opacity =
   | TransparentMaybeOpacified of Conv_oracle.level
 
 let opacity env = function
-  | VarRef v when pi2 (Environ.lookup_named v env) <> None ->
-      Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v)))
+  | VarRef v when not (Option.is_empty (pi2 (Environ.lookup_named v env))) ->
+      Some(TransparentMaybeOpacified
+        (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v)))
   | ConstRef cst ->
       let cb = Environ.lookup_constant cst env in
       (match cb.const_body with
 	| Undef _ -> None
 	| OpaqueDef _ -> Some FullyOpaque
 	| Def _ -> Some
-          (TransparentMaybeOpacified (Conv_oracle.get_strategy(ConstKey cst))))
+          (TransparentMaybeOpacified
+            (Conv_oracle.get_strategy (Environ.oracle env) (ConstKey cst))))
   | _ -> None
 
 let print_opacity ref =
@@ -223,7 +184,7 @@ let print_opacity ref =
           | FullyOpaque -> "opaque"
           | TransparentMaybeOpacified Conv_oracle.Opaque ->
               "basically transparent but considered opaque for reduction"
-          | TransparentMaybeOpacified lev when lev = Conv_oracle.transparent ->
+          | TransparentMaybeOpacified lev when Conv_oracle.is_transparent lev ->
               "transparent"
           | TransparentMaybeOpacified (Conv_oracle.Level n) ->
               "transparent (with expansion weight "^string_of_int n^")"
@@ -233,7 +194,29 @@ let print_opacity ref =
 (*******************)
 (* *)
 
+let print_polymorphism ref =
+  let poly = Global.is_polymorphic ref in
+  let template_poly = Global.is_template_polymorphic ref in
+    pr_global ref ++ str " is " ++ str 
+      (if poly then "universe polymorphic"
+       else if template_poly then
+	 "template universe polymorphic"
+       else "not universe polymorphic")
+
+let print_primitive_record mipv = function
+  | Some (Some (_, ps,_)) ->
+    [pr_id mipv.(0).mind_typename ++ str" is primitive and has eta conversion."]
+  | _ -> []
+    
+let print_primitive ref =
+  match ref with 
+  | IndRef ind -> 
+    let mib,_ = Global.lookup_inductive ind in
+      print_primitive_record mib.mind_packets mib.mind_record
+  | _ -> []
+    
 let print_name_infos ref =
+  let poly = print_polymorphism ref in
   let impls = implicits_of_global ref in
   let scopes = Notation.find_arguments_scope ref in
   let renames =
@@ -245,6 +228,7 @@ let print_name_infos ref =
        print_ref true ref; blankline]
     else
       [] in
+  poly :: print_primitive ref @
   type_info_for_implicit @
   print_renames_list (mt()) renames @
   print_impargs_list (mt()) impls @
@@ -268,20 +252,19 @@ let print_args_data_of_inductive_ids get test pr sp mipv =
 
 let print_inductive_implicit_args =
   print_args_data_of_inductive_ids
-    implicits_of_global (fun l -> positions_of_implicits l <> [])
+    implicits_of_global (fun l -> not (List.is_empty (positions_of_implicits l)))
     print_impargs_list
 
 let print_inductive_renames =
   print_args_data_of_inductive_ids
     (fun r ->
-      try List.hd (Arguments_renaming.arguments_names r)
-      with e when Errors.noncritical e -> [])
-    ((<>) Anonymous)
+      try List.hd (Arguments_renaming.arguments_names r) with Not_found -> [])
+    ((!=) Anonymous)
     print_renames_list
 
 let print_inductive_argument_scopes =
   print_args_data_of_inductive_ids
-    Notation.find_arguments_scope ((<>) None) print_argument_scopes
+    Notation.find_arguments_scope (Option.has_some) print_argument_scopes
 
 (*********************)
 (* "Locate" commands *)
@@ -290,19 +273,19 @@ type logical_name =
   | Term of global_reference
   | Dir of global_dir_reference
   | Syntactic of kernel_name
-  | ModuleType of qualid * module_path
+  | ModuleType of module_path
+  | Tactic of Nametab.ltac_constant
   | Undefined of qualid
 
 let locate_any_name ref =
-  let module N = Nametab in
   let (loc,qid) = qualid_of_reference ref in
-  try Term (N.locate qid)
+  try Term (Nametab.locate qid)
   with Not_found ->
-  try Syntactic (N.locate_syndef qid)
+  try Syntactic (Nametab.locate_syndef qid)
   with Not_found ->
-  try Dir (N.locate_dir qid)
+  try Dir (Nametab.locate_dir qid)
   with Not_found ->
-  try ModuleType (qid, N.locate_modtype qid)
+  try ModuleType (Nametab.locate_modtype qid)
   with Not_found -> Undefined qid
 
 let pr_located_qualid = function
@@ -324,42 +307,108 @@ let pr_located_qualid = function
 	| DirClosedSection dir -> "Closed Section", dir
       in
       str s ++ spc () ++ pr_dirpath dir
-  | ModuleType (qid,_) ->
-      str "Module Type" ++ spc () ++ pr_path (Nametab.full_name_modtype qid)
+  | ModuleType mp ->
+      str "Module Type" ++ spc () ++ pr_path (Nametab.path_of_modtype mp)
+  | Tactic kn ->
+      str "Ltac" ++ spc () ++ pr_path (Nametab.path_of_tactic kn)
   | Undefined qid ->
       pr_qualid qid ++ spc () ++ str "not a defined object."
 
-let print_located_qualid ref =
-  let (loc,qid) = qualid_of_reference ref in
-  let module N = Nametab in
+let canonize_ref = function
+  | ConstRef c ->
+    let kn = Constant.canonical c in
+    if KerName.equal (Constant.user c) kn then None
+    else Some (ConstRef (Constant.make1 kn))
+  | IndRef (ind,i) ->
+    let kn = MutInd.canonical ind in
+    if KerName.equal (MutInd.user ind) kn then None
+    else Some (IndRef (MutInd.make1 kn, i))
+  | ConstructRef ((ind,i),j) ->
+    let kn = MutInd.canonical ind in
+    if KerName.equal (MutInd.user ind) kn then None
+    else Some (ConstructRef ((MutInd.make1 kn, i),j))
+  | VarRef _ -> None
+
+let display_alias = function
+  | Term r ->
+    begin match canonize_ref r with
+    | None -> mt ()
+    | Some r' ->
+      let q' = Nametab.shortest_qualid_of_global Id.Set.empty r' in
+      spc () ++ str "(alias of " ++ pr_qualid q' ++ str ")"
+    end
+  | _ -> mt ()
+
+let locate_term qid =
   let expand = function
     | TrueGlobal ref ->
-	Term ref, N.shortest_qualid_of_global Idset.empty ref
+        Term ref, Nametab.shortest_qualid_of_global Id.Set.empty ref
     | SynDef kn ->
-	Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in
-  match List.map expand (N.locate_extended_all qid) with
+        Syntactic kn, Nametab.shortest_qualid_of_syndef Id.Set.empty kn
+  in
+  List.map expand (Nametab.locate_extended_all qid)
+
+let locate_tactic qid =
+  let all = Nametab.locate_extended_all_tactic qid in
+  List.map (fun kn -> (Tactic kn, Nametab.shortest_qualid_of_tactic kn)) all
+
+let locate_module qid =
+  let all = Nametab.locate_extended_all_dir qid in
+  let map dir = match dir with
+  | DirModule (_, (mp, _)) -> Some (Dir dir, Nametab.shortest_qualid_of_module mp)
+  | DirOpenModule _ -> Some (Dir dir, qid)
+  | _ -> None
+  in
+  List.map_filter map all
+
+let locate_modtype qid =
+  let all = Nametab.locate_extended_all_modtype qid in
+  let map mp = ModuleType mp, Nametab.shortest_qualid_of_modtype mp in
+  let modtypes = List.map map all in
+  (** Don't forget the opened module types: they are not part of the same name tab. *)
+  let all = Nametab.locate_extended_all_dir qid in
+  let map dir = match dir with
+  | DirOpenModtype _ -> Some (Dir dir, qid)
+  | _ -> None
+  in
+  modtypes @ List.map_filter map all
+
+let print_located_qualid name flags ref =
+  let (loc,qid) = qualid_of_reference ref in
+  let located = [] in
+  let located = if List.mem `LTAC flags then locate_tactic qid @ located else located in
+  let located = if List.mem `MODTYPE flags then locate_modtype qid @ located else located in
+  let located = if List.mem `MODULE flags then locate_module qid @ located else located in
+  let located = if List.mem `TERM flags then locate_term qid @ located else located in
+  match located with
     | [] ->
 	let (dir,id) = repr_qualid qid in
-	if dir = empty_dirpath then
-	  str "No object of basename " ++ pr_id id
+	if DirPath.is_empty dir then
+	  str ("No " ^ name ^ " of basename") ++ spc () ++ pr_id id
 	else
-	  str "No object of suffix " ++ pr_qualid qid
+	  str ("No " ^ name ^ " of suffix") ++ spc () ++ pr_qualid qid
     | l ->
 	prlist_with_sep fnl
 	(fun (o,oqid) ->
 	  hov 2 (pr_located_qualid o ++
-	  (if oqid <> qid then
-	    spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")"
-	  else
-	    mt ()))) l
+	  (if not (qualid_eq oqid qid) then
+	    spc() ++ str "(shorter name to refer to it in current context is "
+            ++ pr_qualid oqid ++ str")"
+	   else mt ()) ++
+          display_alias o)) l
+
+let print_located_term ref = print_located_qualid "term" [`TERM] ref
+let print_located_tactic ref = print_located_qualid "tactic" [`LTAC] ref
+let print_located_module ref = print_located_qualid "module" [`MODULE; `MODTYPE] ref
+let print_located_qualid ref = print_located_qualid "object" [`TERM; `LTAC; `MODULE; `MODTYPE] ref
 
 (******************************************)
 (**** Printing declarations and judgments *)
 (****  Gallina layer                  *****)
 
-let gallina_print_typed_value_in_env env (trm,typ) =
-  (pr_lconstr_env env trm ++ fnl () ++
-     str "     : " ++ pr_ltype_env env typ ++ fnl ())
+let gallina_print_typed_value_in_env env sigma (trm,typ) =
+  (pr_lconstr_env env sigma trm ++ fnl () ++
+     str "     : " ++ pr_ltype_env env sigma typ)
 
 (* To be improved; the type should be used to provide the types in the
    abstractions. This should be done recursively inside pr_lconstr, so that
@@ -379,7 +428,7 @@ let print_named_assum name typ =
   str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]"
 
 let gallina_print_named_decl (id,c,typ) =
-  let s = string_of_id id in
+  let s = Id.to_string id in
   match c with
     | Some body -> print_named_def s body typ
     | None -> print_named_assum s typ
@@ -394,9 +443,10 @@ let gallina_print_inductive sp =
   let env = Global.env() in
   let mib = Environ.lookup_mind sp env in
   let mipv = mib.mind_packets in
-  pr_mutual_inductive_body env sp mib ++ fnl () ++
+  pr_mutual_inductive_body env sp mib ++
   with_line_skip
-    (print_inductive_renames sp mipv @
+    (print_primitive_record mipv mib.mind_record @
+     print_inductive_renames sp mipv @
      print_inductive_implicit_args sp mipv @
      print_inductive_argument_scopes sp mipv)
 
@@ -408,45 +458,51 @@ let gallina_print_section_variable id =
   with_line_skip (print_name_infos (VarRef id))
 
 let print_body = function
-  | Some lc  -> pr_lconstr (Declarations.force lc)
+  | Some c  -> pr_lconstr c
   | None -> (str"<no body>")
 
 let print_typed_body (val_0,typ) =
   (print_body val_0 ++ fnl () ++ str "     : " ++ pr_ltype typ)
 
-let ungeneralized_type_of_constant_type = function
-  | PolymorphicArity (ctx,a) -> mkArity (ctx, Type a.poly_level)
-  | NonPolymorphicType t -> t
+let ungeneralized_type_of_constant_type t = 
+  Typeops.type_of_constant_type (Global.env ()) t
 
 let print_constant with_values sep sp =
   let cb = Global.lookup_constant sp in
-  let val_0 = body_of_constant cb in
-  let typ = ungeneralized_type_of_constant_type cb.const_type in
-  hov 0 (
+  let val_0 = Global.body_of_constant_body cb in
+  let typ = Declareops.type_of_constant cb in
+  let typ = ungeneralized_type_of_constant_type typ in
+  let univs = Univ.instantiate_univ_context 
+    (Global.universes_of_constant_body cb)
+  in
+  hov 0 (pr_polymorphic cb.const_polymorphic ++
     match val_0 with
     | None ->
 	str"*** [ " ++
 	print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++
-	str" ]"
+	str" ]" ++
+	Printer.pr_universe_ctx univs
     | _ ->
 	print_basename sp ++ str sep ++ cut () ++
-	(if with_values then print_typed_body (val_0,typ) else pr_ltype typ))
-  ++ fnl ()
+	(if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++
+        Printer.pr_universe_ctx univs)
 
 let gallina_print_constant_with_infos sp =
   print_constant true " = " sp ++
   with_line_skip (print_name_infos (ConstRef sp))
 
 let gallina_print_syntactic_def kn =
-  let qid = Nametab.shortest_qualid_of_syndef Idset.empty kn
+  let qid = Nametab.shortest_qualid_of_syndef Id.Set.empty kn
   and (vars,a) = Syntax_def.search_syntactic_definition kn in
-  let c = Topconstr.glob_constr_of_aconstr dummy_loc a in
+  let c = Notation_ops.glob_constr_of_notation_constr Loc.ghost a in
   hov 2
     (hov 4
        (str "Notation " ++ pr_qualid qid ++
-        prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++ 
+        prlist (fun id -> spc () ++ pr_id id) (List.map fst vars) ++
         spc () ++ str ":=") ++
-     spc () ++ Constrextern.without_symbols pr_glob_constr c) ++ fnl ()
+     spc () ++
+     Constrextern.without_specific_symbols
+       [Notation.SynDefRule kn] pr_glob_constr c)
 
 let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) =
   let sep = if with_values then " = " else " : "
@@ -491,7 +547,7 @@ let gallina_print_library_entry with_values ent =
 
 let gallina_print_context with_values =
   let rec prec n = function
-    | h::rest when n = None or Option.get n > 0 ->
+    | h::rest when Option.is_empty n || Option.get n > 0 ->
 	(match gallina_print_library_entry with_values h with
 	  | None -> prec n rest
 	  | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ())
@@ -499,9 +555,9 @@ let gallina_print_context with_values =
   in
   prec
 
-let gallina_print_eval red_fun env evmap _ {uj_val=trm;uj_type=typ} =
-  let ntrm = red_fun env evmap trm in
-  (str "     = " ++ gallina_print_typed_value_in_env env (ntrm,typ))
+let gallina_print_eval red_fun env sigma _ {uj_val=trm;uj_type=typ} =
+  let ntrm = red_fun env sigma trm in
+  (str "     = " ++ gallina_print_typed_value_in_env env sigma (ntrm,typ))
 
 (******************************************)
 (**** Printing abstraction layer          *)
@@ -539,24 +595,21 @@ let print_eval x = !object_pr.print_eval x
 (**** Printing declarations and judgments *)
 (****  Abstract layer                 *****)
 
-let print_typed_value x = print_typed_value_in_env (Global.env ()) x
+let print_typed_value x = print_typed_value_in_env (Global.env ()) Evd.empty x
 
-let print_judgment env {uj_val=trm;uj_type=typ} =
-  print_typed_value_in_env env (trm, typ)
+let print_judgment env sigma {uj_val=trm;uj_type=typ} =
+  print_typed_value_in_env env sigma (trm, typ)
 
-let print_safe_judgment env j =
+let print_safe_judgment env sigma j =
   let trm = Safe_typing.j_val j in
   let typ = Safe_typing.j_type j in
-  print_typed_value_in_env env (trm, typ)
+  print_typed_value_in_env env sigma (trm, typ)
 
 (*********************)
 (* *)
 
-let print_full_context () =
-  print_context true None (Lib.contents_after None)
-
-let print_full_context_typ () =
-  print_context false None (Lib.contents_after None)
+let print_full_context () = print_context true None (Lib.contents ())
+let print_full_context_typ () = print_context false None (Lib.contents ())
 
 let print_full_pure_context () =
   let rec prec = function
@@ -574,11 +627,11 @@ let print_full_pure_context () =
 	      | OpaqueDef lc ->
 		str "Theorem " ++ print_basename con ++ cut () ++
 		str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++
-		str "Proof " ++ pr_lconstr (Declarations.force_opaque lc)
+		str "Proof " ++ pr_lconstr (Opaqueproof.force_proof (Global.opaque_tables ()) lc)
 	      | Def c ->
 		str "Definition " ++ print_basename con ++ cut () ++
 		str "  : " ++ pr_ltype typ ++ cut () ++ str " := " ++
-		pr_lconstr (Declarations.force c))
+		pr_lconstr (Mod_subst.force_constr c))
           ++ str "." ++ fnl () ++ fnl ()
       | "INDUCTIVE" ->
 	  let mind = Global.mind_of_delta_kn kn in
@@ -598,7 +651,7 @@ let print_full_pure_context () =
       prec rest ++ pp
   | _::rest -> prec rest
   | _ -> mt () in
-  prec (Lib.contents_after None)
+  prec (Lib.contents ())
 
 (* For printing an inductive definition with
    its constructors and elimination,
@@ -614,14 +667,14 @@ let read_sec_context r =
       user_err_loc (loc,"read_sec_context", str "Unknown section.") in
   let rec get_cxt in_cxt = function
     | (_,Lib.OpenedSection ((dir',_),_) as hd)::rest ->
-        if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
+        if DirPath.equal dir dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest
     | (_,Lib.ClosedSection _)::rest ->
         error "Cannot print the contents of a closed section."
 	(* LEM: Actually, we could if we wanted to. *)
     | [] -> []
     | hd::rest -> get_cxt (hd::in_cxt) rest
   in
-  let cxt = (Lib.contents_after None) in
+  let cxt = Lib.contents () in
   List.rev (get_cxt [] cxt)
 
 let print_sec_context sec =
@@ -638,11 +691,12 @@ let print_any_name = function
   | Syntactic kn -> print_syntactic_def kn
   | Dir (DirModule(dirpath,(mp,_))) -> print_module (printable_body dirpath) mp
   | Dir _ -> mt ()
-  | ModuleType (_,kn) -> print_modtype kn
+  | ModuleType mp -> print_modtype mp
+  | Tactic kn -> mt () (** TODO *)
   | Undefined qid ->
   try  (* Var locale de but, pas var de section... donc pas d'implicits *)
     let dir,str = repr_qualid qid in
-    if (repr_dirpath dir) <> [] then raise Not_found;
+    if not (DirPath.is_empty dir) then raise Not_found;
     let (_,c,typ) = Global.lookup_named str in
     (print_named_decl (str,c,typ))
   with Not_found ->
@@ -650,26 +704,26 @@ let print_any_name = function
       "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.")
 
 let print_name = function
-  | Genarg.ByNotation (loc,ntn,sc) ->
+  | ByNotation (loc,ntn,sc) ->
       print_any_name
         (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
                ntn sc))
-  | Genarg.AN ref ->
+  | AN ref ->
       print_any_name (locate_any_name ref)
 
 let print_opaque_name qid =
   let env = Global.env () in
-  match global qid with
+  match Nametab.global qid with
     | ConstRef cst ->
 	let cb = Global.lookup_constant cst in
-        if constant_has_body cb then
+        if Declareops.constant_has_body cb then
 	  print_constant_with_infos cst
         else
 	  error "Not a defined constant."
     | IndRef (sp,_) ->
         print_inductive sp
-    | ConstructRef cstr ->
-	let ty = Inductiveops.type_of_constructor env cstr in
+    | ConstructRef cstr as gr ->
+	let ty = Universes.unsafe_type_of_global gr in
 	print_typed_value (mkConstruct cstr, ty)
     | VarRef id ->
         let (_,c,ty) = lookup_named id env in
@@ -678,34 +732,35 @@ let print_opaque_name qid =
 let print_about_any loc k =
   match k with
   | Term ref ->
+    let rb = Reductionops.ReductionBehaviour.print ref in
     Dumpglob.add_glob loc ref;
       pr_infos_list
        (print_ref false ref :: blankline ::
 	print_name_infos ref @
-	print_simpl_behaviour ref @
+	(if Pp.ismt rb then [] else [rb]) @
 	print_opacity ref @
 	[hov 0 (str "Expands to: " ++ pr_located_qualid k)])
   | Syntactic kn ->
     let () = match Syntax_def.search_syntactic_definition kn with
-    | [],Topconstr.ARef ref -> Dumpglob.add_glob loc ref
+    | [],Notation_term.NRef ref -> Dumpglob.add_glob loc ref
     | _ -> () in
       v 0 (
-      print_syntactic_def kn ++
-      hov 0 (str "Expands to: " ++ pr_located_qualid k)) ++ fnl()
-  | Dir _ | ModuleType _ | Undefined _ ->
-      hov 0 (pr_located_qualid k) ++ fnl()
+      print_syntactic_def kn ++ fnl () ++
+      hov 0 (str "Expands to: " ++ pr_located_qualid k))
+  | Dir _ | ModuleType _ | Tactic _ | Undefined _ ->
+      hov 0 (pr_located_qualid k)
 
 let print_about = function
-  | Genarg.ByNotation (loc,ntn,sc) ->
+  | ByNotation (loc,ntn,sc) ->
       print_about_any loc
         (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true)
                ntn sc))
-  | Genarg.AN ref ->
+  | AN ref ->
       print_about_any (loc_of_reference ref) (locate_any_name ref)
 
 (* for debug *)
 let inspect depth =
-  print_context false (Some depth) (Lib.contents_after None)
+  print_context false (Some depth) (Lib.contents ())
 
 
 (*************************************************************************)
@@ -728,18 +783,18 @@ let print_path ((i,j),p) =
 let _ = Classops.install_path_printer print_path
 
 let print_graph () =
-  prlist_with_sep pr_fnl print_path (inheritance_graph())
+  prlist_with_sep fnl print_path (inheritance_graph())
 
 let print_classes () =
-  prlist_with_sep pr_spc pr_class (classes())
+  pr_sequence pr_class (classes())
 
 let print_coercions () =
-  prlist_with_sep pr_spc print_coercion_value (coercions())
+  pr_sequence print_coercion_value (coercions())
 
 let index_of_class cl =
   try
     fst (class_info cl)
-  with e when Errors.noncritical e ->
+  with Not_found ->
     errorlabstrm "index_of_class"
       (pr_class cl ++ spc() ++ str "not a defined class.")
 
@@ -749,7 +804,7 @@ let print_path_between cls clt =
   let p =
     try
       lookup_path_between_class (i,j)
-    with e when Errors.noncritical e ->
+    with Not_found ->
       errorlabstrm "index_cl_of_id"
         (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt
 	 ++ str ".")
@@ -757,7 +812,7 @@ let print_path_between cls clt =
   print_path ((i,j),p)
 
 let print_canonical_projections () =
-  prlist_with_sep pr_fnl
+  prlist_with_sep fnl
     (fun ((r1,r2),o) -> pr_cs_pattern r2 ++
     str " <- " ++
     pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )")
@@ -771,7 +826,7 @@ let print_canonical_projections () =
 open Typeclasses
 
 let pr_typeclass env t =
-  print_ref false t.cl_impl ++ fnl ()
+  print_ref false t.cl_impl
 
 let print_typeclasses () =
   let env = Global.env () in
@@ -780,7 +835,11 @@ let print_typeclasses () =
 let pr_instance env i =
   (*   gallina_print_constant_with_infos i.is_impl *)
   (* lighter *)
-  print_ref false (instance_impl i) ++ fnl ()
+  print_ref false (instance_impl i) ++
+  begin match instance_priority i with
+  | None -> mt ()
+  | Some i -> spc () ++ str "|" ++ spc () ++ int i
+  end
 
 let print_all_instances () =
   let env = Global.env () in
@@ -791,4 +850,3 @@ let print_instances r =
   let env = Global.env () in
   let inst = instances r in
     prlist_with_sep fnl (pr_instance env) inst
-
diff --git a/parsing/prettyp.mli b/printing/prettyp.mli
index 4cf3e489..6216d4d5 100644
--- a/parsing/prettyp.mli
+++ b/printing/prettyp.mli
@@ -1,25 +1,23 @@
 (************************************************************************)
 (*  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 Names
-open Sign
 open Term
 open Environ
 open Reductionops
 open Libnames
-open Nametab
-open Genarg
+open Globnames
+open Misctypes
 
 (** A Pretty-Printer for the Calculus of Inductive Constructions. *)
 
-val assumptions_for_print : name list -> Termops.names_context
+val assumptions_for_print : Name.t list -> Termops.names_context
 
 val print_closed_sections : bool ref
 val print_context : bool -> int option -> Lib.library_segment -> std_ppcmds
@@ -29,10 +27,11 @@ val print_full_context_typ : unit -> std_ppcmds
 val print_full_pure_context : unit -> std_ppcmds
 val print_sec_context : reference -> std_ppcmds
 val print_sec_context_typ : reference -> std_ppcmds
-val print_judgment : env -> unsafe_judgment -> std_ppcmds
-val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds
+val print_judgment : env -> Evd.evar_map -> unsafe_judgment -> std_ppcmds
+val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> std_ppcmds
 val print_eval :
-  reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds
+  reduction_function -> env -> Evd.evar_map ->
+    Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds
 
 val print_name : reference or_by_notation -> std_ppcmds
 val print_opaque_name : reference -> std_ppcmds
@@ -54,7 +53,11 @@ val print_all_instances : unit -> std_ppcmds
 val inspect : int -> std_ppcmds
 
 (** Locate *)
+
 val print_located_qualid : reference -> std_ppcmds
+val print_located_term : reference -> std_ppcmds
+val print_located_tactic : reference -> std_ppcmds
+val print_located_module : reference -> std_ppcmds
 
 type object_pr = {
   print_inductive           : mutual_inductive -> std_ppcmds;
@@ -63,11 +66,11 @@ type object_pr = {
   print_syntactic_def       : kernel_name -> std_ppcmds;
   print_module              : bool -> Names.module_path -> std_ppcmds;
   print_modtype             : module_path -> std_ppcmds;
-  print_named_decl          : identifier * constr option * types -> std_ppcmds;
+  print_named_decl          : Id.t * constr option * types -> std_ppcmds;
   print_library_entry       : bool -> (object_name * Lib.node) -> std_ppcmds option;
   print_context             : bool -> int option -> Lib.library_segment -> std_ppcmds;
-  print_typed_value_in_env  : Environ.env -> Term.constr * Term.types -> Pp.std_ppcmds;
-  print_eval                : reduction_function -> env -> Evd.evar_map -> Topconstr.constr_expr -> unsafe_judgment -> std_ppcmds
+  print_typed_value_in_env  : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds;
+  print_eval                : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> unsafe_judgment -> std_ppcmds
 }
 
 val set_object_pr : object_pr -> unit
diff --git a/parsing/printer.ml b/printing/printer.ml
index 1b887e6e..3403fb9c 100644
--- a/parsing/printer.ml
+++ b/printing/printer.ml
@@ -1,38 +1,38 @@
 (************************************************************************)
 (*  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
-open Nameops
 open Term
-open Sign
+open Vars
 open Environ
-open Global
-open Declare
-open Libnames
+open Globnames
 open Nametab
 open Evd
 open Proof_type
 open Refiner
 open Pfedit
-open Ppconstr
 open Constrextern
-open Tacexpr
+open Ppconstr
 open Declarations
 
-open Store.Field
-
 let emacs_str s =
   if !Flags.print_emacs then s else ""
 let delayed_emacs_cmd s =
   if !Flags.print_emacs then s () else str ""
 
+let get_current_context () =
+  try Pfedit.get_current_goal_context ()
+  with e when Logic.catchable_exception e ->
+    (Evd.empty, Global.env())
+
 (**********************************************************************)
 (** Terms                                                             *)
 
@@ -44,53 +44,71 @@ let delayed_emacs_cmd s =
    and only names of goal/section variables and rel names that do
    _not_ occur in the scope of the binder to be printed are avoided. *)
 
-let pr_constr_core goal_concl_style env t =
-  pr_constr_expr (extern_constr goal_concl_style env t)
-let pr_lconstr_core goal_concl_style env t =
-  pr_lconstr_expr (extern_constr goal_concl_style env t)
+let pr_constr_core goal_concl_style env sigma t =
+  pr_constr_expr (extern_constr goal_concl_style env sigma t)
+let pr_lconstr_core goal_concl_style env sigma t =
+  pr_lconstr_expr (extern_constr goal_concl_style env sigma t)
 
 let pr_lconstr_env env = pr_lconstr_core false env
 let pr_constr_env env = pr_constr_core false env
+let _ = Hook.set Proofview.Refine.pr_constr pr_constr_env
 
-let pr_open_lconstr_env env (_,c) = pr_lconstr_env env c
-let pr_open_constr_env env (_,c) = pr_constr_env env c
+let pr_lconstr_goal_style_env env = pr_lconstr_core true env
+let pr_constr_goal_style_env env = pr_constr_core true env
+
+let pr_open_lconstr_env env sigma (_,c) = pr_lconstr_env env sigma c
+let pr_open_constr_env env sigma (_,c) = pr_constr_env env sigma c
 
   (* NB do not remove the eta-redexes! Global.env() has side-effects... *)
-let pr_lconstr t = pr_lconstr_env (Global.env()) t
-let pr_constr t = pr_constr_env (Global.env()) t
+let pr_lconstr t =
+  let (sigma, env) = get_current_context () in
+  pr_lconstr_env env sigma t
+let pr_constr t =
+  let (sigma, env) = get_current_context () in
+  pr_constr_env env sigma t
 
 let pr_open_lconstr (_,c) = pr_lconstr c
 let pr_open_constr (_,c) = pr_constr c
 
-let pr_constr_under_binders_env_gen pr env (ids,c) =
+let pr_constr_under_binders_env_gen pr env sigma (ids,c) =
   (* Warning: clashes can occur with variables of same name in env but *)
   (* we also need to preserve the actual names of the patterns *)
   (* So what to do? *)
   let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in
-  pr (Termops.push_rels_assum assums env) c
+  pr (Termops.push_rels_assum assums env) sigma c
 
 let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_constr_env
 let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_lconstr_env
 
-let pr_constr_under_binders c = pr_constr_under_binders_env (Global.env()) c
-let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c
+let pr_constr_under_binders c =
+  let (sigma, env) = get_current_context () in
+  pr_constr_under_binders_env env sigma c
+let pr_lconstr_under_binders c =
+  let (sigma, env) = get_current_context () in
+  pr_lconstr_under_binders_env env sigma c
 
-let pr_type_core goal_concl_style env t =
-  pr_constr_expr (extern_type goal_concl_style env t)
-let pr_ltype_core goal_concl_style env t =
-  pr_lconstr_expr (extern_type goal_concl_style env t)
+let pr_type_core goal_concl_style env sigma t =
+  pr_constr_expr (extern_type goal_concl_style env sigma t)
+let pr_ltype_core goal_concl_style env sigma t =
+  pr_lconstr_expr (extern_type goal_concl_style env sigma t)
 
 let pr_goal_concl_style_env env = pr_ltype_core true env
 let pr_ltype_env env = pr_ltype_core false env
 let pr_type_env env = pr_type_core false env
 
-let pr_ltype t = pr_ltype_env (Global.env()) t
-let pr_type t = pr_type_env (Global.env()) t
+let pr_ltype t =
+    let (sigma, env) = get_current_context () in
+    pr_ltype_env env sigma t
+let pr_type t =
+    let (sigma, env) = get_current_context () in
+    pr_type_env env sigma t
 
-let pr_ljudge_env env j =
-  (pr_lconstr_env env j.uj_val, pr_lconstr_env env j.uj_type)
+let pr_ljudge_env env sigma j =
+  (pr_lconstr_env env sigma j.uj_val, pr_lconstr_env env sigma j.uj_type)
 
-let pr_ljudge j = pr_ljudge_env (Global.env()) j
+let pr_ljudge j =
+  let (sigma, env) = get_current_context () in
+  pr_ljudge_env env sigma j
 
 let pr_lglob_constr_env env c =
   pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c)
@@ -98,27 +116,39 @@ let pr_glob_constr_env env c =
   pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c)
 
 let pr_lglob_constr c =
-  pr_lconstr_expr (extern_glob_constr Idset.empty c)
+  let (sigma, env) = get_current_context () in
+  pr_lglob_constr_env env c
 let pr_glob_constr c =
-  pr_constr_expr (extern_glob_constr Idset.empty c)
+  let (sigma, env) = get_current_context () in
+  pr_glob_constr_env env c
 
-let pr_cases_pattern t =
-  pr_cases_pattern_expr (extern_cases_pattern Idset.empty t)
+let pr_closed_glob_env env sigma c =
+  pr_constr_expr (extern_closed_glob false env sigma c)
+let pr_closed_glob c =
+  let (sigma, env) = get_current_context () in
+  pr_closed_glob_env env sigma c
 
-let pr_lconstr_pattern_env env c =
-  pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c)
-let pr_constr_pattern_env env c =
-  pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) c)
+let pr_lconstr_pattern_env env sigma c =
+  pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c)
+let pr_constr_pattern_env env sigma c =
+  pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c)
+
+let pr_cases_pattern t =
+  pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t)
 
 let pr_lconstr_pattern t =
-  pr_lconstr_pattern_expr (extern_constr_pattern Termops.empty_names_context t)
+  let (sigma, env) = get_current_context () in
+  pr_lconstr_pattern_env env sigma t
 let pr_constr_pattern t =
-  pr_constr_pattern_expr (extern_constr_pattern Termops.empty_names_context t)
+  let (sigma, env) = get_current_context () in
+  pr_constr_pattern_env env sigma t
 
-let pr_sort s = pr_glob_sort (extern_sort s)
+let pr_sort sigma s = pr_glob_sort (extern_sort sigma s)
 
-let _ = Termops.set_print_constr pr_lconstr_env
+let _ = Termops.set_print_constr 
+  (fun env t -> pr_lconstr_expr (extern_constr ~lax:true false env Evd.empty t))
 
+let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)"
 
 (** Term printers resilient to [Nametab] errors *)
 
@@ -130,31 +160,30 @@ let _ = Termops.set_print_constr pr_lconstr_env
     (needs an environment for this). *)
 
 let id_of_global env = function
-  | ConstRef kn -> id_of_label (con_label kn)
-  | IndRef (kn,0) -> id_of_label (mind_label kn)
+  | ConstRef kn -> Label.to_id (Constant.label kn)
+  | IndRef (kn,0) -> Label.to_id (MutInd.label kn)
   | IndRef (kn,i) ->
     (Environ.lookup_mind kn env).mind_packets.(i).mind_typename
   | ConstructRef ((kn,i),j) ->
     (Environ.lookup_mind kn env).mind_packets.(i).mind_consnames.(j-1)
   | VarRef v -> v
 
-let cons_dirpath id dp = make_dirpath (id :: repr_dirpath dp)
-
 let rec dirpath_of_mp = function
   | MPfile sl -> sl
-  | MPbound uid -> make_dirpath [id_of_mbid uid]
-  | MPdot (mp,l) -> cons_dirpath (id_of_label l) (dirpath_of_mp mp)
+  | MPbound uid -> DirPath.make [MBId.to_id uid]
+  | MPdot (mp,l) ->
+    Libnames.add_dirpath_suffix (dirpath_of_mp mp) (Label.to_id l)
 
 let dirpath_of_global = function
-  | ConstRef kn -> dirpath_of_mp (con_modpath kn)
+  | ConstRef kn -> dirpath_of_mp (Constant.modpath kn)
   | IndRef (kn,_) | ConstructRef ((kn,_),_) ->
-    dirpath_of_mp (mind_modpath kn)
-  | VarRef _ -> empty_dirpath
+    dirpath_of_mp (MutInd.modpath kn)
+  | VarRef _ -> DirPath.empty
 
 let qualid_of_global env r =
   Libnames.make_qualid (dirpath_of_global r) (id_of_global env r)
 
-let safe_gen f env c =
+let safe_gen f env sigma c =
   let orig_extern_ref = Constrextern.get_extern_reference () in
   let extern_ref loc vars r =
     try orig_extern_ref loc vars r
@@ -163,7 +192,7 @@ let safe_gen f env c =
   in
   Constrextern.set_extern_reference extern_ref;
   try
-    let p = f env c in
+    let p = f env sigma c in
     Constrextern.set_extern_reference orig_extern_ref;
     p
   with e when Errors.noncritical e ->
@@ -172,26 +201,48 @@ let safe_gen f env c =
 
 let safe_pr_lconstr_env = safe_gen pr_lconstr_env
 let safe_pr_constr_env = safe_gen pr_constr_env
-let safe_pr_lconstr t = safe_pr_lconstr_env (Global.env()) t
-let safe_pr_constr t = safe_pr_constr_env (Global.env()) t
-
+let safe_pr_lconstr t =
+  let (sigma, env) = get_current_context () in
+  safe_pr_lconstr_env env sigma t
+
+let safe_pr_constr t =
+  let (sigma, env) = get_current_context () in
+  safe_pr_constr_env env sigma t
+
+let pr_universe_ctx c =
+  if !Detyping.print_universes && not (Univ.UContext.is_empty c) then
+    fnl()++pr_in_comment (fun c -> v 0 
+      (Univ.pr_universe_context Universes.pr_with_global_universes c)) c
+  else
+    mt()
 
 (**********************************************************************)
 (* Global references *)
 
 let pr_global_env = pr_global_env
-let pr_global = pr_global_env Idset.empty
+let pr_global = pr_global_env Id.Set.empty
+
+let pr_puniverses f env (c,u) =
+  f env c ++ 
+  (if !Constrextern.print_universes then
+    str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
+   else mt ())
 
 let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst)
-let pr_existential env ev = pr_lconstr_env env (mkEvar ev)
-let pr_inductive env ind = pr_lconstr_env env (mkInd ind)
-let pr_constructor env cstr = pr_lconstr_env env (mkConstruct cstr)
+let pr_existential_key = Evd.pr_existential_key
+let pr_existential env sigma ev = pr_lconstr_env env sigma (mkEvar ev)
+let pr_inductive env ind = pr_lconstr_env env Evd.empty (mkInd ind)
+let pr_constructor env cstr = pr_lconstr_env env Evd.empty (mkConstruct cstr)
+
+let pr_pconstant = pr_puniverses pr_constant
+let pr_pinductive = pr_puniverses pr_inductive
+let pr_pconstructor = pr_puniverses pr_constructor
 
 let pr_evaluable_reference ref =
   pr_global (Tacred.global_of_evaluable_reference ref)
 
 (*let pr_glob_constr t =
-  pr_lconstr (Constrextern.extern_glob_constr Idset.empty t)*)
+  pr_lconstr (Constrextern.extern_glob_constr Id.Set.empty t)*)
 
 (*open Pattern
 
@@ -200,27 +251,33 @@ let pr_pattern t = pr_pattern_env (Global.env()) empty_names_context t*)
 (**********************************************************************)
 (* Contexts and declarations                                          *)
 
-let pr_var_decl env (id,c,typ) =
+let pr_var_decl_skel pr_id env sigma (id,c,typ) =
   let pbody = match c with
     | None ->  (mt ())
     | Some c ->
 	(* Force evaluation *)
-	let pb = pr_lconstr_core true env c in
+	let pb = pr_lconstr_env env sigma c in
 	let pb = if isCast c then surround pb else pb in
 	(str" := " ++ pb ++ cut () ) in
-  let pt = pr_ltype_core true env typ in
+  let pt = pr_ltype_env env sigma typ in
   let ptyp = (str" : " ++ pt) in
   (pr_id id ++ hov 0 (pbody ++ ptyp))
 
-let pr_rel_decl env (na,c,typ) =
+let pr_var_decl env sigma (id,c,typ) =
+  pr_var_decl_skel pr_id env sigma (id,c,typ)
+
+let pr_var_list_decl env sigma (l,c,typ) =
+  hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ))
+
+let pr_rel_decl env sigma (na,c,typ) =
   let pbody = match c with
     | None -> mt ()
     | Some c ->
 	(* Force evaluation *)
-	let pb = pr_lconstr_core true env c in
+	let pb = pr_lconstr_env env sigma c in
 	let pb = if isCast c then surround pb else pb in
 	(str":=" ++ spc () ++ pb ++ spc ()) in
-  let ptyp = pr_ltype_core true env typ in
+  let ptyp = pr_ltype_env env sigma typ in
   match na with
   | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
   | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
@@ -231,66 +288,67 @@ let pr_rel_decl env (na,c,typ) =
  * It's printed out from outermost to innermost, so it's readable. *)
 
 (* Prints a signature, all declarations on the same line if possible *)
-let pr_named_context_of env =
-  let make_decl_list env d pps = pr_var_decl env d :: pps in
+let pr_named_context_of env sigma =
+  let make_decl_list env d pps = pr_var_decl env sigma d :: pps in
   let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in
   hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl)
 
-let pr_named_context env ne_context =
-  hv 0 (Sign.fold_named_context
-	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d)
+let pr_named_context env sigma ne_context =
+  hv 0 (Context.fold_named_context
+	  (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d)
           ne_context ~init:(mt ()))
 
-let pr_rel_context env rel_context =
-  pr_binders (extern_rel_context None env rel_context)
+let pr_rel_context env sigma rel_context =
+  pr_binders (extern_rel_context None env sigma rel_context)
 
-let pr_rel_context_of env =
-  pr_rel_context env (rel_context env)
+let pr_rel_context_of env sigma =
+  pr_rel_context env sigma (rel_context env)
 
 (* Prints an env (variables and de Bruijn). Separator: newline *)
-let pr_context_unlimited env =
+let pr_context_unlimited env sigma =
   let sign_env =
-    fold_named_context
-      (fun env d pps ->
-         let pidt =  pr_var_decl env d in (pps ++ fnl () ++ pidt))
-      env ~init:(mt ())
+    Context.fold_named_list_context
+      (fun d pps ->
+         let pidt =  pr_var_list_decl env sigma d in
+         (pps ++ fnl () ++ pidt))
+      (Termops.compact_named_context (named_context env)) ~init:(mt ())
   in
   let db_env =
     fold_rel_context
       (fun env d pps ->
-         let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
+         let pnat = pr_rel_decl env sigma d in (pps ++ fnl () ++ pnat))
       env ~init:(mt ())
   in
   (sign_env ++ db_env)
 
-let pr_ne_context_of header env =
-  if Environ.rel_context env = empty_rel_context &
-    Environ.named_context env = empty_named_context  then (mt ())
-  else let penv = pr_context_unlimited env in (header ++ penv ++ fnl ())
+let pr_ne_context_of header env sigma =
+  if List.is_empty (Environ.rel_context env) &&
+    List.is_empty (Environ.named_context env)  then (mt ())
+  else let penv = pr_context_unlimited env sigma in (header ++ penv ++ fnl ())
 
-let pr_context_limit n env =
+let pr_context_limit n env sigma =
   let named_context = Environ.named_context env in
   let lgsign = List.length named_context in
   if n >= lgsign then
-    pr_context_unlimited env
+    pr_context_unlimited env sigma
   else
     let k = lgsign-n in
     let _,sign_env =
-      fold_named_context
-        (fun env d (i,pps) ->
+      Context.fold_named_list_context
+        (fun d (i,pps) ->
            if i < k then
 	     (i+1, (pps ++str "."))
 	   else
-             let pidt = pr_var_decl env d in
+             let pidt = pr_var_list_decl env sigma d in
 	     (i+1, (pps ++ fnl () ++
 		      str (emacs_str "") ++
 		      pidt)))
-        env ~init:(0,(mt ()))
+        (Termops.compact_named_context (Environ.named_context env)) ~init:(0,(mt ()))
     in
     let db_env =
       fold_rel_context
         (fun env d pps ->
-           let pnat = pr_rel_decl env d in
+           let pnat = pr_rel_decl env sigma d in
 	   (pps ++ fnl () ++
 	      str (emacs_str "") ++
 	      pnat))
@@ -298,9 +356,9 @@ let pr_context_limit n env =
     in
     (sign_env ++ db_env)
 
-let pr_context_of env = match Flags.print_hyps_limit () with
-  | None -> hv 0 (pr_context_unlimited env)
-  | Some n -> hv 0 (pr_context_limit n env)
+let pr_context_of env sigma = match Flags.print_hyps_limit () with
+  | None -> hv 0 (pr_context_unlimited env sigma)
+  | Some n -> hv 0 (pr_context_limit n env sigma)
 
 (* display goal parts (Proof mode) *)
 
@@ -308,12 +366,12 @@ let pr_predicate pr_elt (b, elts) =
   let pr_elts = prlist_with_sep spc pr_elt elts in
     if b then
       str"all" ++
-	(if elts = [] then mt () else str" except: " ++ pr_elts)
+	(if List.is_empty elts then mt () else str" except: " ++ pr_elts)
     else
-      if elts = [] then str"none" else pr_elts
+      if List.is_empty elts then str"none" else pr_elts
 
 let pr_cpred p = pr_predicate (pr_constant (Global.env())) (Cpred.elements p)
-let pr_idpred p = pr_predicate Nameops.pr_id (Idpred.elements p)
+let pr_idpred p = pr_predicate Nameops.pr_id (Id.Pred.elements p)
 
 let pr_transparent_state (ids, csts) =
   hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++
@@ -322,89 +380,103 @@ let pr_transparent_state (ids, csts) =
 (* display complete goal *)
 let default_pr_goal gs =
   let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in
-  let env = Goal.V82.unfiltered_env sigma g in
+  let env = Goal.V82.env sigma g in
   let preamb,thesis,penv,pc =
     mt (), mt (),
-    pr_context_of env,
-    pr_goal_concl_style_env env (Goal.V82.concl sigma g)
+    pr_context_of env sigma,
+    pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
   in
     preamb ++
     str"  " ++ hv 0 (penv ++ fnl () ++
 		       str (emacs_str "")  ++
 		       str "============================" ++ fnl ()  ++
-		       thesis ++ str " " ++  pc) ++ fnl ()
+		       thesis ++ str " " ++  pc)
 
 (* display a goal tag *)
 let pr_goal_tag g =
   let s = " (ID " ^ Goal.uid g ^ ")" in
   str (emacs_str s)
 
+let display_name = false
+
+(* display a goal name *)
+let pr_goal_name sigma g =
+  if display_name then str " " ++ Pp.surround (pr_id (Evd.evar_ident g sigma))
+  else mt ()
+
 (* display the conclusion of a goal *)
 let pr_concl n sigma g =
   let (g,sigma) = Goal.V82.nf_evar sigma g in
   let env = Goal.V82.env sigma g in
-  let pc = pr_goal_concl_style_env env (Goal.V82.concl sigma g) in
+  let pc = pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g) in
     str (emacs_str "")  ++
-      str "subgoal " ++ int n ++ pr_goal_tag g ++
+      str "subgoal " ++ int n ++ pr_goal_tag g ++ pr_goal_name sigma g ++
       str " is:" ++ cut () ++ str" "  ++ pc
 
 (* display evar type: a context and a type *)
-let pr_evgl_sign gl =
-  let ps = pr_named_context_of (evar_unfiltered_env gl) in
-  let _,l = list_filter2 (fun b c -> not b) (evar_filter gl,evar_context gl) in
-  let ids = List.rev (List.map pi1 l) in
+let pr_evgl_sign sigma evi =
+  let env = evar_env evi in
+  let ps = pr_named_context_of env sigma in
+  let _, l = match Filter.repr (evar_filter evi) with
+  | None -> [], []
+  | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi)
+  in
+  let ids = List.rev_map pi1 l in
   let warn =
-    if ids = [] then mt () else
+    if List.is_empty ids then mt () else
       (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)")
   in
-  let pc = pr_lconstr gl.evar_concl in
+  let pc = pr_lconstr_env env sigma evi.evar_concl in
   hov 0 (str"[" ++ ps ++ spc () ++ str"|- "  ++ pc ++ str"]" ++ spc () ++ warn)
 
 (* Print an existential variable *)
 
-let pr_evar (ev, evd) =
-  let pegl = pr_evgl_sign evd in
-  (hov 0 (str (string_of_existential ev)  ++ str " : " ++ pegl))
+let pr_evar sigma (evk, evi) =
+  let pegl = pr_evgl_sign sigma evi in
+  hov 0 (pr_existential_key sigma evk ++ str " : " ++ pegl)
 
 (* Print an enumerated list of existential variables *)
-let rec pr_evars_int i = function
-  | [] -> (mt ())
-  | (ev,evd)::rest ->
-      let pegl = pr_evgl_sign evd in
-      let pei = pr_evars_int (i+1) rest in
-      (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++
-              str (string_of_existential ev)  ++ str " : " ++ pegl)) ++
-      fnl () ++ pei
+let rec pr_evars_int_hd head sigma i = function
+  | [] -> mt ()
+  | (evk,evi)::rest ->
+      (hov 0 (head i ++ pr_evar sigma (evk,evi))) ++
+      (match rest with [] -> mt () | _ -> fnl () ++ pr_evars_int_hd head sigma (i+1) rest)
+
+let pr_evars_int sigma i evs = pr_evars_int_hd (fun i -> str "Existential " ++ int i ++ str " =" ++ spc ()) sigma i (Evar.Map.bindings evs)
+
+let pr_evars sigma evs = pr_evars_int_hd (fun i -> mt ()) sigma 1 (Evar.Map.bindings evs)
 
 let default_pr_subgoal n sigma =
   let rec prrec p = function
     | [] -> error "No such goal."
     | g::rest ->
-       	if p = 1 then
-          let pg = default_pr_goal { sigma=sigma ; it=g } in
-          v 0 (str "subgoal " ++ int n ++ pr_goal_tag g
+	if Int.equal p 1 then
+          let pg = default_pr_goal { sigma=sigma ; it=g; } in
+          v 0 (str "subgoal " ++ int n ++ pr_goal_tag g ++ pr_goal_name sigma g 
 	       ++ str " is:" ++ cut () ++ pg)
-       	else
+	else
 	  prrec (p-1) rest
   in
   prrec n
 
+let pr_internal_existential_key ev = str (string_of_existential ev)
+
 let emacs_print_dependent_evars sigma seeds =
   let evars () =
     let evars = Evarutil.gather_dependent_evars sigma seeds in
     let evars =
-      Intmap.fold begin fun e i s ->
-	let e' = str (string_of_existential e) in
+      Evar.Map.fold begin fun e i s ->
+	let e' = pr_internal_existential_key e in
 	match i with
 	| None -> s ++ str" " ++ e' ++ str " open,"
 	| Some i ->
 	  s ++ str " " ++ e' ++ str " using " ++
-	    Intset.fold begin fun d s ->
-	      str (string_of_existential d) ++ str " " ++ s
+	    Evar.Set.fold begin fun d s ->
+	      pr_internal_existential_key d ++ str " " ++ s
 	    end i (str ",")
       end evars (str "")
     in
-    cut () ++ 
+    fnl () ++
     str "(dependent evars:" ++ evars ++ str ")" ++ fnl ()
   in
   delayed_emacs_cmd evars
@@ -415,14 +487,40 @@ let emacs_print_dependent_evars sigma seeds =
    and printed in its entirety. *)
 (* courtieu: in emacs mode, even less cases where the first goal is printed
    in its entirety *)
-let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals =
+let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals =
+  (** Printing functions for the extra informations. *)
   let rec print_stack a = function
     | [] -> Pp.int a
     | b::l -> Pp.int a ++ str"-" ++ print_stack b l
   in
-  let print_unfocused a l =
-    str"unfocused: " ++ print_stack a l
+  let print_unfocused l =
+    match l with
+    | [] -> None
+    | a::l -> Some (str"unfocused: " ++ print_stack a l)
+  in
+  let print_shelf l =
+    match l with
+    | [] -> None
+    | _ -> Some (str"shelved: " ++ Pp.int (List.length l))
+  in
+  let rec print_comma_separated_list a l =
+    match l with
+    | [] -> a
+    | b::l -> print_comma_separated_list (a++str", "++b) l
   in
+  let print_extra_list l =
+    match l with
+    | [] -> Pp.mt ()
+    | a::l -> Pp.spc () ++ str"(" ++ print_comma_separated_list a l ++ str")"
+  in
+  let extra = Option.List.flatten [ print_unfocused stack ; print_shelf shelf ] in
+  let print_extra = print_extra_list extra in
+  let focused_if_needed =
+    let needed = not (CList.is_empty extra) && pr_first in
+    if needed then str" focused "
+    else str" " (* non-breakable space *)
+  in
+  (** Main function *)
   let rec pr_rec n = function
     | [] -> (mt ())
     | g::rest ->
@@ -432,56 +530,45 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals =
   in
   let print_multiple_goals g l =
     if pr_first then
-      default_pr_goal { it = g ; sigma = sigma } ++
+      default_pr_goal { it = g ; sigma = sigma; } ++ fnl () ++
       pr_rec 2 l
     else 
       pr_rec 1 (g::l)
   in
-  match goals,stack with
-  | [],_ ->
+  match goals with
+  | [] ->
       begin
 	match close_cmd with
 	  Some cmd ->
 	    (str "Subproof completed, now type " ++ str cmd ++
-	       str "." ++ fnl ())
+	       str ".")
 	| None ->
 	    let exl = Evarutil.non_instantiated sigma in
-	    if exl = [] then
-	      (str"No more subgoals." ++ fnl ()
+	    if Evar.Map.is_empty exl then
+	      (str"No more subgoals."
 	       ++ emacs_print_dependent_evars sigma seeds)
 	    else
-	      let pei = pr_evars_int 1 exl in
+	      let pei = pr_evars_int sigma 1 exl in
 	      (str "No more subgoals but non-instantiated existential " ++
 		 str "variables:" ++ fnl () ++ (hov 0 pei)
 	       ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++
                  str "You can use Grab Existential Variables.")
       end
-  | [g],[] when not !Flags.print_emacs ->
-      let pg = default_pr_goal { it = g ; sigma = sigma } in
-      v 0 (
-	str "1 subgoal" ++ pr_goal_tag g ++ cut () ++ pg
-	++ emacs_print_dependent_evars sigma seeds
-      )
-  | [g],a::l when not !Flags.print_emacs ->
-      let pg = default_pr_goal { it = g ; sigma = sigma } in
-      v 0 (
-	str "1 focused subgoal (" ++ print_unfocused a l ++ str")" ++ pr_goal_tag g ++ cut () ++ pg
-	++ emacs_print_dependent_evars sigma seeds
-      )
-  | g1::rest,[] ->
-      let goals = print_multiple_goals g1 rest in
+  | [g] when not !Flags.print_emacs ->
+      let pg = default_pr_goal { it = g ; sigma = sigma; } in
       v 0 (
-	int(List.length rest+1) ++ str" subgoals" ++
-          str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut ()
-	++ goals ++ fnl ()
+	str "1" ++ focused_if_needed ++ str"subgoal" ++ print_extra
+        ++ pr_goal_tag g ++ pr_goal_name sigma g ++ cut () ++ pg
 	++ emacs_print_dependent_evars sigma seeds
       )
-  | g1::rest,a::l ->
+  | g1::rest ->
       let goals = print_multiple_goals g1 rest in
       v 0 (
-	int(List.length rest+1) ++ str" focused subgoals (" ++
-          print_unfocused a l ++ str")" ++ cut () ++
-          str (emacs_str ", subgoal 1") ++ pr_goal_tag g1 ++ cut ()
+	int(List.length rest+1) ++ focused_if_needed ++ str"subgoals" ++
+          print_extra ++
+          str ((if display_name then (fun x -> x) else emacs_str) ", subgoal 1")
+        ++ pr_goal_tag g1
+        ++ pr_goal_name sigma g1 ++ cut ()
 	++ goals
 	++ emacs_print_dependent_evars sigma seeds
       )
@@ -491,7 +578,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds stack goals =
 
 
 type printer_pr = {
- pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds;
+ pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds;
  pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds;
  pr_goal                : goal sigma -> std_ppcmds;
 }
@@ -513,27 +600,34 @@ let pr_goal     x = !printer_pr.pr_goal     x
 (* End abstraction layer                                              *)
 (**********************************************************************)
 
-let pr_open_subgoals () =
+let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () =
   (* spiwack: it shouldn't be the job of the printer to look up stuff
      in the [evar_map], I did stuff that way because it was more
      straightforward, but seriously, [Proof.proof] should return
      [evar_info]-s instead. *)
-  let p = Proof_global.give_me_the_proof () in
-  let (goals , stack , sigma ) = Proof.proof p in
+  let p = proof in
+  let (goals , stack , shelf, given_up, sigma ) = Proof.proof p in
   let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in
   let seeds = Proof.V82.top_evars p in
   begin match goals with
   | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in
-          begin match bgoals with
-	  | [] -> pr_subgoals None sigma seeds stack goals
-	  | _ ->
-	    (* emacs mode: xml-like flag for detecting information message *)
-	    str (emacs_str "<infomsg>") ++
-	    str"This subproof is complete, but there are still unfocused goals."
-	    ++ str (emacs_str "</infomsg>")
-	    ++ fnl () ++ fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] bgoals
+          begin match bgoals,shelf,given_up with
+	  | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals
+          | [] , [] , _ ->
+	     msg_info (str "No more goals, however there are goals you gave up. You need to go back and solve them.");
+	     fnl ()
+            ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up
+          | [] , _ , _ ->
+	    msg_info (str "All the remaining goals are on the shelf.");
+	    fnl ()
+            ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf
+	  | _ , _, _ ->
+	    msg_info (str "This subproof is complete, but there are still unfocused goals." ++
+			(match Proof_global.Bullet.suggest p
+			 with None  -> str"" | Some s -> fnl () ++ str s));
+	    fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds shelf [] bgoals
 	  end
-  | _ -> pr_subgoals None sigma seeds stack goals
+  | _ -> pr_subgoals None sigma seeds shelf stack goals
   end
 
 let pr_nth_open_subgoal n =
@@ -544,20 +638,17 @@ let pr_nth_open_subgoal n =
 let pr_goal_by_id id =
   let p = Proof_global.give_me_the_proof () in
   let g = Goal.get_by_uid id in
-  let pr gs = 
+  let pr gs =
     v 0 (str ("goal / evar " ^ id ^ " is:") ++ cut ()
 	 ++ pr_goal gs)
   in
   try
-    Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma})
+    Proof.in_proof p (fun sigma -> pr {it=g;sigma=sigma;})
   with Not_found -> error "Invalid goal identifier."
 
 (* Elementary tactics *)
 
 let pr_prim_rule = function
-  | Intro id ->
-      str"intro " ++ pr_id id
-
   | Cut (b,replace,id,t) ->
      if b then
        (* TODO: express "replace" *)
@@ -571,7 +662,7 @@ let pr_prim_rule = function
       (str"fix " ++ pr_id f ++ str"/" ++ int n)
 
   | FixRule (f,n,others,j) ->
-      if j<>0 then msg_warn "Unsupported printing of \"fix\"";
+      if not (Int.equal j 0) then msg_warning (strbrk "Unsupported printing of \"fix\"");
       let rec print_mut = function
 	| (f,n,ar)::oth ->
            pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth
@@ -583,7 +674,7 @@ let pr_prim_rule = function
       (str"cofix " ++ pr_id f)
 
   | Cofix (f,others,j) ->
-      if j<>0 then msg_warn "Unsupported printing of \"fix\"";
+      if not (Int.equal j 0) then msg_warning (strbrk "Unsupported printing of \"fix\"");
       let rec print_mut = function
 	| (f,ar)::oth ->
 	  (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth)
@@ -593,38 +684,11 @@ let pr_prim_rule = function
       str(if Termops.occur_meta c then "refine " else "exact ") ++
       Constrextern.with_meta_as_hole pr_constr c
 
-  | Convert_concl (c,_) ->
-      (str"change "  ++ pr_constr c)
-
-  | Convert_hyp (id,None,t) ->
-      (str"change "  ++ pr_constr t  ++ spc ()  ++ str"in "  ++ pr_id id)
-
-  | Convert_hyp (id,Some c,t) ->
-      (str"change "  ++ pr_constr c  ++ spc ()  ++ str"in "
-       ++ pr_id id ++ str" (type of "  ++ pr_id id ++ str ")")
-
   | Thin ids ->
-      (str"clear "  ++ prlist_with_sep pr_spc pr_id ids)
-
-  | ThinBody ids ->
-      (str"clearbody "  ++ prlist_with_sep pr_spc pr_id ids)
-
-  | Move (withdep,id1,id2) ->
-      (str (if withdep then "dependent " else "") ++
-	 str"move "  ++ pr_id id1 ++ pr_move_location pr_id id2)
-
-  | Order ord ->
-      (str"order "  ++ prlist_with_sep pr_spc pr_id ord)
-
-  | Rename (id1,id2) ->
-      (str "rename " ++ pr_id id1 ++ str " into " ++ pr_id id2)
-
-  | Change_evars ->
-      (* This is internal tactic and cannot be replayed at user-level.
-         Function pr_rule_dot below is used when we want to hide
-         Change_evars *)
-      str "Evar change"
+      (str"clear "  ++ pr_sequence pr_id ids)
 
+  | Move (id1,id2) ->
+      (str"move "  ++ pr_id id1 ++ Miscprint.pr_move_location pr_id id2)
 
 (* Backwards compatibility *)
 
@@ -638,153 +702,59 @@ open Assumptions
 
 let pr_assumptionset env s =
   if ContextObjectMap.is_empty s then
-    str "Closed under the global context" ++ fnl()
+    str "Closed under the global context"
   else
     let safe_pr_constant env kn =
       try pr_constant env kn
       with Not_found ->
 	let mp,_,lab = repr_con kn in
-	str (string_of_mp mp ^ "." ^ string_of_label lab)
+	str (string_of_mp mp ^ "." ^ Label.to_string lab)
     in
     let safe_pr_ltype typ =
-      try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt ()
+      try str " : " ++ pr_ltype typ
+      with e when Errors.noncritical e -> mt ()
     in
-    let (vars,axioms,opaque) =
-      ContextObjectMap.fold (fun t typ r ->
-	let (v,a,o) = r in
-	match t with
-	| Variable id -> (  Some (
-	                      Option.default (fnl ()) v
-			   ++ str (string_of_id id)
-			   ++ str " : "
-	                   ++ pr_ltype typ
-	                   ++ fnl ()
-			    )
-	                 ,
-	                   a, o)
-	| Axiom kn    -> ( v ,
-			     Some (
-			      Option.default (fnl ()) a
-			   ++ safe_pr_constant env kn
-	                   ++ safe_pr_ltype typ
-	                   ++ fnl ()
-			     )
-			 , o
-			 )
-	| Opaque kn    -> ( v , a ,
-			     Some (
-			      Option.default (fnl ()) o
-			   ++ safe_pr_constant env kn
-	                   ++ safe_pr_ltype typ
-	                   ++ fnl ()
-			     )
-			 )
-      )
-	s (None,None,None)
+    let fold t typ accu =
+      let (v, a, o, tr) = accu in
+      match t with
+      | Variable id ->
+        let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in
+        (var :: v, a, o, tr)
+      | Axiom kn ->
+        let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in
+        (v, ax :: a, o, tr)
+      | Opaque kn ->
+        let opq = safe_pr_constant env kn ++ safe_pr_ltype typ in
+        (v, a, opq :: o, tr)
+      | Transparent kn ->
+        let tran = safe_pr_constant env kn ++ safe_pr_ltype typ in
+        (v, a, o, tran :: tr)
     in
-    let (vars,axioms,opaque) =
-      ( Option.map (fun p -> str "Section Variables:" ++ p) vars ,
-	Option.map (fun p -> str "Axioms:" ++ p) axioms ,
-	Option.map (fun p -> str "Opaque constants:" ++ p) opaque
-      )
+    let (vars, axioms, opaque, trans) = 
+      ContextObjectMap.fold fold s ([], [], [], [])
     in
-    (Option.default (mt ()) vars) ++ (Option.default (mt ()) axioms)
-      ++ (Option.default (mt ()) opaque)
-
-let cmap_to_list m = Cmap.fold (fun k v acc -> v :: acc) m []
-
-open Typeclasses
-
-let pr_instance i = 
-  pr_global (instance_impl i)
-    
-let pr_instance_gmap insts =
-  prlist_with_sep fnl (fun (gr, insts) ->
-    prlist_with_sep fnl pr_instance (cmap_to_list insts))
-    (Gmap.to_list insts)
-
-(** Inductive declarations *)
-
-open Termops
-open Reduction
-open Inductive
-open Inductiveops
-
-let print_params env params =
-  if params = [] then mt () else pr_rel_context env params ++ brk(1,2)
+    let opt_list title = function
+    | [] -> None
+    | l ->
+      let section =
+        title ++ fnl () ++
+        v 0 (prlist_with_sep fnl (fun s -> s) l) in
+      Some section
+    in
+    let assums = [
+      opt_list (str "Transparent constants:") trans;
+      opt_list (str "Section Variables:") vars;
+      opt_list (str "Axioms:") axioms;
+      opt_list (str "Opaque constants:") opaque;
+    ] in
+    prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums)
+
+let xor a b = 
+  (a && not b) || (not a && b)
+
+let pr_polymorphic b = 
+  let print = xor (Flags.is_universe_polymorphism ()) b in
+  if print then
+    if b then str"Polymorphic " else str"Monomorphic "
+  else mt ()
 
-let print_constructors envpar names types =
-  let pc =
-    prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
-      (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c)
-      (Array.to_list (array_map2 (fun n t -> (n,t)) names types))
-  in
-  hv 0 (str "  " ++ pc)
-
-let build_ind_type env mip =
-  match mip.mind_arity with
-    | Monomorphic ar -> ar.mind_user_arity
-    | Polymorphic ar ->
-      it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt
-
-let print_one_inductive env mib ((_,i) as ind) =
-  let mip = mib.mind_packets.(i) in
-  let params = mib.mind_params_ctxt in
-  let args = extended_rel_list 0 params in
-  let arity = hnf_prod_applist env (build_ind_type env mip) args in
-  let cstrtypes = Inductive.type_of_constructors ind (mib,mip) in
-  let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
-  let envpar = push_rel_context params env in
-  hov 0 (
-    pr_id mip.mind_typename ++ brk(1,4) ++ print_params env params ++
-    str ": " ++ pr_lconstr_env envpar arity ++ str " :=") ++
-  brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes
-
-let print_mutual_inductive env mind mib =
-  let inds = list_tabulate (fun x -> (mind,x)) (Array.length mib.mind_packets)
-  in
-  hov 0 (
-    str (if mib.mind_finite then "Inductive " else "CoInductive ") ++
-    prlist_with_sep (fun () -> fnl () ++ str"  with ")
-      (print_one_inductive env mib) inds)
-
-let get_fields =
-  let rec prodec_rec l subst c =
-    match kind_of_term c with
-    | Prod (na,t,c) ->
-	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
-	prodec_rec ((id,true,substl subst t)::l) (mkVar id::subst) c
-    | LetIn (na,b,_,c) ->
-	let id = match na with Name id -> id | Anonymous -> id_of_string "_" in
-	prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c
-    | _               -> List.rev l
-  in
-  prodec_rec [] []
-
-let print_record env mind mib =
-  let mip = mib.mind_packets.(0) in
-  let params = mib.mind_params_ctxt in
-  let args = extended_rel_list 0 params in
-  let arity = hnf_prod_applist env (build_ind_type env mip) args in
-  let cstrtypes = Inductive.type_of_constructors (mind,0) (mib,mip) in
-  let cstrtype = hnf_prod_applist env cstrtypes.(0) args in
-  let fields = get_fields cstrtype in
-  let envpar = push_rel_context params env in
-  hov 0 (
-    hov 0 (
-      str "Record " ++ pr_id mip.mind_typename ++ brk(1,4) ++
-      print_params env params ++
-      str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++
-      str ":= " ++ pr_id mip.mind_consnames.(0)) ++
-    brk(1,2) ++
-    hv 2 (str "{ " ++
-      prlist_with_sep (fun () -> str ";" ++ brk(2,0))
-        (fun (id,b,c) ->
-	  pr_id id ++ str (if b then " : " else " := ") ++
-	  pr_lconstr_env envpar c) fields) ++ str" }")
-
-let pr_mutual_inductive_body env mind mib =
-  if mib.mind_record & not !Flags.raw_print then
-    print_record env mind mib
-  else
-    print_mutual_inductive env mind mib
diff --git a/parsing/printer.mli b/printing/printer.mli
index c0ef1932..6b9c7081 100644
--- a/parsing/printer.mli
+++ b/printing/printer.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,60 +8,61 @@
 
 open Pp
 open Names
-open Libnames
+open Globnames
 open Term
-open Sign
+open Context
 open Environ
-open Glob_term
 open Pattern
-open Nametab
-open Termops
 open Evd
 open Proof_type
 open Glob_term
-open Tacexpr
 
 (** These are the entry points for printing terms, context, tac, ... *)
 
 (** Terms *)
 
-val pr_lconstr_env         : env -> constr -> std_ppcmds
+val pr_lconstr_env         : env -> evar_map -> constr -> std_ppcmds
 val pr_lconstr             : constr -> std_ppcmds
+val pr_lconstr_goal_style_env : env -> evar_map -> constr -> std_ppcmds
 
-val pr_constr_env          : env -> constr -> std_ppcmds
+val pr_constr_env          : env -> evar_map -> constr -> std_ppcmds
 val pr_constr              : constr -> std_ppcmds
+val pr_constr_goal_style_env : env -> evar_map -> constr -> std_ppcmds
 
 (** Same, but resilient to [Nametab] errors. Prints fully-qualified
     names when [shortest_qualid_of_global] has failed. Prints "??"
     in case of remaining issues (such as reference not in env). *)
 
-val safe_pr_lconstr_env         : env -> constr -> std_ppcmds
+val safe_pr_lconstr_env         : env -> evar_map -> constr -> std_ppcmds
 val safe_pr_lconstr             : constr -> std_ppcmds
 
-val safe_pr_constr_env          : env -> constr -> std_ppcmds
+val safe_pr_constr_env          : env -> evar_map -> constr -> std_ppcmds
 val safe_pr_constr              : constr -> std_ppcmds
 
 
-val pr_open_constr_env     : env -> open_constr -> std_ppcmds
+val pr_open_constr_env     : env -> evar_map -> open_constr -> std_ppcmds
 val pr_open_constr         : open_constr -> std_ppcmds
 
-val pr_open_lconstr_env    : env -> open_constr -> std_ppcmds
+val pr_open_lconstr_env    : env -> evar_map -> open_constr -> std_ppcmds
 val pr_open_lconstr        : open_constr -> std_ppcmds
 
-val pr_constr_under_binders_env  : env -> constr_under_binders -> std_ppcmds
+val pr_constr_under_binders_env  : env -> evar_map -> constr_under_binders -> std_ppcmds
 val pr_constr_under_binders      : constr_under_binders -> std_ppcmds
 
-val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds
+val pr_lconstr_under_binders_env : env -> evar_map -> constr_under_binders -> std_ppcmds
 val pr_lconstr_under_binders     : constr_under_binders -> std_ppcmds
 
-val pr_goal_concl_style_env : env -> types -> std_ppcmds
-val pr_ltype_env           : env -> types -> std_ppcmds
+val pr_goal_concl_style_env : env -> evar_map -> types -> std_ppcmds
+val pr_ltype_env           : env -> evar_map -> types -> std_ppcmds
 val pr_ltype               : types -> std_ppcmds
 
-val pr_type_env            : env -> types -> std_ppcmds
+val pr_type_env            : env -> evar_map -> types -> std_ppcmds
 val pr_type                : types -> std_ppcmds
 
-val pr_ljudge_env          : env -> unsafe_judgment -> std_ppcmds * std_ppcmds
+val pr_closed_glob_env     : env -> evar_map -> closed_glob_constr -> std_ppcmds
+val pr_closed_glob         : closed_glob_constr -> std_ppcmds
+
+val pr_ljudge_env          : env -> evar_map -> unsafe_judgment -> std_ppcmds * std_ppcmds
 val pr_ljudge              : unsafe_judgment -> std_ppcmds * std_ppcmds
 
 val pr_lglob_constr_env      : env -> glob_constr -> std_ppcmds
@@ -70,62 +71,76 @@ val pr_lglob_constr          : glob_constr -> std_ppcmds
 val pr_glob_constr_env       : env -> glob_constr -> std_ppcmds
 val pr_glob_constr           : glob_constr -> std_ppcmds
 
-val pr_lconstr_pattern_env : env -> constr_pattern -> std_ppcmds
+val pr_lconstr_pattern_env : env -> evar_map -> constr_pattern -> std_ppcmds
 val pr_lconstr_pattern     : constr_pattern -> std_ppcmds
 
-val pr_constr_pattern_env  : env -> constr_pattern -> std_ppcmds
+val pr_constr_pattern_env  : env -> evar_map -> constr_pattern -> std_ppcmds
 val pr_constr_pattern      : constr_pattern -> std_ppcmds
 
 val pr_cases_pattern       : cases_pattern -> std_ppcmds
 
-val pr_sort                : sorts -> std_ppcmds
+val pr_sort                : evar_map -> sorts -> std_ppcmds
+
+(** Universe constraints *)
+
+val pr_polymorphic         : bool -> std_ppcmds
+val pr_universe_ctx        : Univ.universe_context -> std_ppcmds
 
 (** Printing global references using names as short as possible *)
 
-val pr_global_env          : Idset.t -> global_reference -> std_ppcmds
+val pr_global_env          : Id.Set.t -> global_reference -> std_ppcmds
 val pr_global              : global_reference -> std_ppcmds
 
 val pr_constant            : env -> constant -> std_ppcmds
-val pr_existential         : env -> existential -> std_ppcmds
+val pr_existential_key     : evar_map -> existential_key -> std_ppcmds
+val pr_existential         : env -> evar_map -> existential -> std_ppcmds
 val pr_constructor         : env -> constructor -> std_ppcmds
 val pr_inductive           : env -> inductive -> std_ppcmds
 val pr_evaluable_reference : evaluable_global_reference -> std_ppcmds
 
+val pr_pconstant           : env -> pconstant -> std_ppcmds
+val pr_pinductive          : env -> pinductive -> std_ppcmds
+val pr_pconstructor        : env -> pconstructor -> std_ppcmds
+
+
 (** Contexts *)
 
-val pr_ne_context_of       : std_ppcmds -> env -> std_ppcmds
+val pr_context_unlimited   : env -> evar_map -> std_ppcmds
+val pr_ne_context_of       : std_ppcmds -> env -> evar_map -> std_ppcmds
 
-val pr_var_decl            : env -> named_declaration -> std_ppcmds
-val pr_rel_decl            : env -> rel_declaration -> std_ppcmds
+val pr_var_decl            : env -> evar_map -> named_declaration -> std_ppcmds
+val pr_var_list_decl       : env -> evar_map -> named_list_declaration -> std_ppcmds
+val pr_rel_decl            : env -> evar_map -> rel_declaration -> std_ppcmds
 
-val pr_named_context       : env -> named_context -> std_ppcmds
-val pr_named_context_of    : env -> std_ppcmds
-val pr_rel_context         : env -> rel_context -> std_ppcmds
-val pr_rel_context_of      : env -> std_ppcmds
-val pr_context_of          : env -> std_ppcmds
+val pr_named_context       : env -> evar_map -> named_context -> std_ppcmds
+val pr_named_context_of    : env -> evar_map -> std_ppcmds
+val pr_rel_context         : env -> evar_map -> rel_context -> std_ppcmds
+val pr_rel_context_of      : env -> evar_map -> std_ppcmds
+val pr_context_of          : env -> evar_map -> std_ppcmds
 
 (** Predicates *)
 
 val pr_predicate           : ('a -> std_ppcmds) -> (bool * 'a list) -> std_ppcmds
 val pr_cpred               : Cpred.t -> std_ppcmds
-val pr_idpred              : Idpred.t -> std_ppcmds
+val pr_idpred              : Id.Pred.t -> std_ppcmds
 val pr_transparent_state   : transparent_state -> std_ppcmds
 
 (** Proofs *)
 
 val pr_goal                : goal sigma -> std_ppcmds
-val pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds
+val pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds
 val pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds
 val pr_concl               : int -> evar_map -> goal -> std_ppcmds
 
-val pr_open_subgoals       : unit -> std_ppcmds
+val pr_open_subgoals       : ?proof:Proof.proof -> unit -> std_ppcmds
 val pr_nth_open_subgoal    : int -> std_ppcmds
-val pr_evar                : (evar * evar_info) -> std_ppcmds
-val pr_evars_int           : int -> (evar * evar_info) list -> std_ppcmds
+val pr_evar                : evar_map -> (evar * evar_info) -> std_ppcmds
+val pr_evars_int           : evar_map -> int -> evar_info Evar.Map.t -> std_ppcmds
+val pr_evars               : evar_map -> evar_info Evar.Map.t -> std_ppcmds
 
 val pr_prim_rule           : prim_rule -> std_ppcmds
 
-(** Emacs/proof general support 
+(** Emacs/proof general support
    (emacs_str s) outputs
     - s if emacs mode,
     - nothing otherwise.
@@ -151,7 +166,7 @@ val pr_assumptionset :
 val pr_goal_by_id : string -> std_ppcmds
 
 type printer_pr = {
- pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> int list -> goal list -> std_ppcmds;
+ pr_subgoals            : ?pr_first:bool -> string option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds;
  pr_subgoal             : int -> evar_map -> goal list -> std_ppcmds;
  pr_goal                : goal sigma -> std_ppcmds;
 };;
@@ -160,10 +175,3 @@ val set_printer_pr : printer_pr -> unit
 
 val default_printer_pr : printer_pr
 
-val pr_instance_gmap : (global_reference, Typeclasses.instance Names.Cmap.t) Gmap.t ->
-  Pp.std_ppcmds
-
-(** Inductive declarations *)
-
-val pr_mutual_inductive_body :
-  env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
diff --git a/printing/printing.mllib b/printing/printing.mllib
new file mode 100644
index 00000000..7b4c71a8
--- /dev/null
+++ b/printing/printing.mllib
@@ -0,0 +1,14 @@
+Genprint
+Pputils
+Ppstyle
+Ppannotation
+Ppconstr
+Ppconstrsig
+Printer
+Pptactic
+Pptacticsig
+Printmod
+Prettyp
+Ppvernac
+Ppvernacsig
+Richprinter
diff --git a/printing/printmod.ml b/printing/printmod.ml
new file mode 100644
index 00000000..295d8aaa
--- /dev/null
+++ b/printing/printmod.ml
@@ -0,0 +1,438 @@
+(************************************************************************)
+(*  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 Util
+open Term
+open Pp
+open Names
+open Environ
+open Declarations
+open Nameops
+open Globnames
+open Libnames
+open Goptions
+
+(** Note: there is currently two modes for printing modules.
+    - The "short" one, that just prints the names of the fields.
+    - The "rich" one, that also tries to print the types of the fields.
+    The short version used to be the default behavior, but now we print
+    types by default. The following option allows changing this.
+    Technically, the environments in this file are either None in
+    the "short" mode or (Some env) in the "rich" one.
+*)
+
+let short = ref false
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "short module printing";
+      optkey   = ["Short";"Module";"Printing"];
+      optread  = (fun () -> !short) ;
+      optwrite = ((:=) short) }
+
+(** Each time we have to print a non-globally visible structure,
+    we place its elements in a fake fresh namespace. *)
+
+let mk_fake_top =
+  let r = ref 0 in
+  fun () -> incr r; Id.of_string ("FAKETOP"^(string_of_int !r))
+
+module Make (Taggers : sig
+  val tag_definition : std_ppcmds -> std_ppcmds
+  val tag_keyword : std_ppcmds -> std_ppcmds
+end) =
+struct
+
+let def s = Taggers.tag_definition (str s)
+let keyword s = Taggers.tag_keyword (str s)
+
+let get_new_id locals id =
+  let rec get_id l id =
+    let dir = DirPath.make [id] in
+      if not (Nametab.exists_module dir) then
+	id
+      else
+	get_id (id::l) (Namegen.next_ident_away id l)
+  in
+    get_id (List.map snd locals) id
+
+(** Inductive declarations *)
+
+open Termops
+open Reduction
+
+let print_params env sigma params =
+  if List.is_empty params then mt ()
+  else Printer.pr_rel_context env sigma params ++ brk(1,2)
+
+let print_constructors envpar names types =
+  let pc =
+    prlist_with_sep (fun () -> brk(1,0) ++ str "| ")
+      (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar Evd.empty c)
+      (Array.to_list (Array.map2 (fun n t -> (n,t)) names types))
+  in
+  hv 0 (str "  " ++ pc)
+
+let build_ind_type env mip =
+  Inductive.type_of_inductive env mip
+
+let print_one_inductive env mib ((_,i) as ind) =
+  let u = if mib.mind_polymorphic then 
+      Univ.UContext.instance mib.mind_universes 
+    else Univ.Instance.empty in
+  let mip = mib.mind_packets.(i) in
+  let params = Inductive.inductive_paramdecls (mib,u) in
+  let args = extended_rel_list 0 params in
+  let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
+  let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in
+  let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in
+  let envpar = push_rel_context params env in
+  hov 0 (
+    pr_id mip.mind_typename ++ brk(1,4) ++ print_params env Evd.empty params ++
+    str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ str " :=") ++
+  brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes
+
+let print_mutual_inductive env mind mib =
+  let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x))
+  in
+  let keyword =
+    let open Decl_kinds in
+    match mib.mind_finite with
+    | Finite -> "Inductive"
+    | BiFinite -> "Variant"
+    | CoFinite -> "CoInductive"
+  in
+  hov 0 (Printer.pr_polymorphic mib.mind_polymorphic ++
+    def keyword ++ spc () ++
+    prlist_with_sep (fun () -> fnl () ++ str"  with ")
+      (print_one_inductive env mib) inds ++
+      Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes))
+
+let get_fields =
+  let rec prodec_rec l subst c =
+    match kind_of_term c with
+    | Prod (na,t,c) ->
+        let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in
+        prodec_rec ((id,true,Vars.substl subst t)::l) (mkVar id::subst) c
+    | LetIn (na,b,_,c) ->
+        let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in
+        prodec_rec ((id,false,Vars.substl subst b)::l) (mkVar id::subst) c
+    | _               -> List.rev l
+  in
+  prodec_rec [] []
+
+let print_record env mind mib =
+  let u = 
+    if mib.mind_polymorphic then 
+      Univ.UContext.instance mib.mind_universes 
+    else Univ.Instance.empty 
+  in
+  let mip = mib.mind_packets.(0) in
+  let params = Inductive.inductive_paramdecls (mib,u) in
+  let args = extended_rel_list 0 params in
+  let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in
+  let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in
+  let cstrtype = hnf_prod_applist env cstrtypes.(0) args in
+  let fields = get_fields cstrtype in
+  let envpar = push_rel_context params env in
+  let keyword =
+    let open Decl_kinds in
+    match mib.mind_finite with
+    | BiFinite -> "Record"
+    | Finite -> "Inductive"
+    | CoFinite -> "CoInductive"
+  in
+  hov 0 (
+    hov 0 (
+      Printer.pr_polymorphic mib.mind_polymorphic ++
+      def keyword ++ spc () ++ pr_id mip.mind_typename ++ brk(1,4) ++
+      print_params env Evd.empty params ++
+      str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ brk(1,2) ++
+      str ":= " ++ pr_id mip.mind_consnames.(0)) ++
+    brk(1,2) ++
+    hv 2 (str "{ " ++
+      prlist_with_sep (fun () -> str ";" ++ brk(2,0))
+        (fun (id,b,c) ->
+          pr_id id ++ str (if b then " : " else " := ") ++
+          Printer.pr_lconstr_env envpar Evd.empty c) fields) ++ str" }" ++
+      Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes))
+
+let pr_mutual_inductive_body env mind mib =
+  if mib.mind_record <> None && not !Flags.raw_print then
+    print_record env mind mib
+  else
+    print_mutual_inductive env mind mib
+
+(** Modpaths *)
+
+let rec print_local_modpath locals = function
+  | MPbound mbid -> pr_id (Util.List.assoc_f MBId.equal mbid locals)
+  | MPdot(mp,l) ->
+      print_local_modpath locals mp ++ str "." ++ pr_lab l
+  | MPfile _ -> raise Not_found
+
+let print_modpath locals mp =
+  try (* must be with let because streams are lazy! *)
+    let qid = Nametab.shortest_qualid_of_module mp in
+      pr_qualid qid
+  with
+    | Not_found -> print_local_modpath locals mp
+
+let print_kn locals kn =
+  try
+    let qid = Nametab.shortest_qualid_of_modtype kn in
+      pr_qualid qid
+  with
+      Not_found ->
+	try
+	  print_local_modpath locals kn
+	with
+	    Not_found -> print_modpath locals kn
+
+let nametab_register_dir mp =
+  let id = mk_fake_top () in
+  let dir = DirPath.make [id] in
+  Nametab.push_dir (Nametab.Until 1) dir (DirModule (dir,(mp,DirPath.empty)))
+
+(** Nota: the [global_reference] we register in the nametab below
+    might differ from internal ones, since we cannot recreate here
+    the canonical part of constant and inductive names, but only
+    the user names. This works nonetheless since we search now
+    [Nametab.the_globrevtab] modulo user name. *)
+
+let nametab_register_body mp dir (l,body) =
+  let push id ref =
+    Nametab.push (Nametab.Until (1+List.length (DirPath.repr dir)))
+      (make_path dir id) ref
+  in
+  match body with
+    | SFBmodule _ -> () (* TODO *)
+    | SFBmodtype _ -> () (* TODO *)
+    | SFBconst _ ->
+      push (Label.to_id l) (ConstRef (Constant.make2 mp l))
+    | SFBmind mib ->
+      let mind = MutInd.make2 mp l in
+      Array.iteri
+	(fun i mip ->
+	  push mip.mind_typename (IndRef (mind,i));
+	  Array.iteri (fun j id -> push id (ConstructRef ((mind,i),j+1)))
+	    mip.mind_consnames)
+	mib.mind_packets
+
+let nametab_register_module_body mp struc =
+  (* If [mp] is a globally visible module, we simply import it *)
+  try Declaremods.really_import_module mp
+  with Not_found ->
+    (* Otherwise we try to emulate an import by playing with nametab *)
+    nametab_register_dir mp;
+    List.iter (nametab_register_body mp DirPath.empty) struc
+
+let get_typ_expr_alg mtb = match mtb.mod_type_alg with
+  | Some (NoFunctor me) -> me
+  | _ -> raise Not_found
+
+let nametab_register_modparam mbid mtb =
+  match mtb.mod_type with
+  | MoreFunctor _ -> () (* functorial param : nothing to register *)
+  | NoFunctor struc ->
+    (* We first try to use the algebraic type expression if any,
+       via a Declaremods function that converts back to module entries *)
+    try
+      Declaremods.process_module_binding mbid (get_typ_expr_alg mtb)
+    with e when Errors.noncritical e ->
+      (* Otherwise, we try to play with the nametab ourselves *)
+      let mp = MPbound mbid in
+      let dir = DirPath.make [MBId.to_id mbid] in
+      nametab_register_dir mp;
+      List.iter (nametab_register_body mp dir) struc
+
+let print_body is_impl env mp (l,body) =
+  let name = str (Label.to_string l) in
+  hov 2 (match body with
+    | SFBmodule _ -> keyword "Module" ++ spc () ++ name
+    | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name
+    | SFBconst cb ->
+      (match cb.const_body with
+	| Def _ -> def "Definition" ++ spc ()
+	| OpaqueDef _ when is_impl -> def "Theorem" ++ spc ()
+	| _ -> def "Parameter" ++ spc ()) ++ name ++
+      (match env with
+	  | None -> mt ()
+	  | Some env ->
+	    str " :" ++ spc () ++
+	    hov 0 (Printer.pr_ltype_env env Evd.empty (* No evars in modules *)
+		     (Typeops.type_of_constant_type env cb.const_type)) ++
+	    (match cb.const_body with
+	      | Def l when is_impl ->
+		spc () ++
+		hov 2 (str ":= " ++
+		       Printer.pr_lconstr_env env Evd.empty (Mod_subst.force_constr l))
+	      | _ -> mt ()) ++ str "." ++
+	    Printer.pr_universe_ctx cb.const_universes)
+    | SFBmind mib ->
+      try
+	let env = Option.get env in
+	pr_mutual_inductive_body env (MutInd.make2 mp l) mib
+      with e when Errors.noncritical e ->
+        let keyword =
+          let open Decl_kinds in
+          match mib.mind_finite with
+          | Finite -> def "Inductive"
+          | BiFinite -> def "Variant"
+          | CoFinite -> def "CoInductive"
+        in
+	keyword ++ spc () ++ name)
+
+let print_struct is_impl env mp struc =
+  prlist_with_sep spc (print_body is_impl env mp) struc
+
+let print_structure is_type env mp locals struc =
+  let env' = Option.map
+    (Modops.add_structure mp struc Mod_subst.empty_delta_resolver) env in
+  nametab_register_module_body mp struc;
+  let kwd = if is_type then "Sig" else "Struct" in
+  hv 2 (keyword kwd ++ spc () ++ print_struct false env' mp struc ++
+	brk (1,-2) ++ keyword "End")
+
+let rec flatten_app mexpr l = match mexpr with
+  | MEapply (mexpr, arg) -> flatten_app mexpr (arg::l)
+  | MEident mp -> mp::l
+  | MEwith _ -> assert false
+
+let rec print_typ_expr env mp locals mty =
+  match mty with
+  | MEident kn -> print_kn locals kn
+  | MEapply _ ->
+      let lapp = flatten_app mty [] in
+      let fapp = List.hd lapp in
+      let mapp = List.tl lapp in
+      hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++
+		 prlist_with_sep spc (print_modpath locals) mapp ++ str")")
+  | MEwith(me,WithDef(idl,c))->
+      let env' = None in (* TODO: build a proper environment if env <> None *)
+      let s = String.concat "." (List.map Id.to_string idl) in
+      hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc()
+             ++ def "Definition"++ spc() ++ str s ++ spc() ++  str ":="++ spc())
+  | MEwith(me,WithMod(idl,mp))->
+      let s = String.concat "." (List.map Id.to_string idl) in
+      hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++
+             keyword "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc())
+
+let print_mod_expr env mp locals = function
+  | MEident mp -> print_modpath locals mp
+  | MEapply _ as me ->
+      let lapp = flatten_app me [] in
+      hov 3
+        (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")")
+  | MEwith _ -> assert false (* No 'with' syntax for modules *)
+
+let rec print_functor fty fatom is_type env mp locals = function
+  |NoFunctor me -> fatom is_type env mp locals me
+  |MoreFunctor (mbid,mtb1,me2) ->
+      nametab_register_modparam mbid mtb1;
+      let mp1 = MPbound mbid in
+      let pr_mtb1 = fty env mp1 locals mtb1 in
+      let env' = Option.map (Modops.add_module_type mp1 mtb1) env in
+      let locals' = (mbid, get_new_id locals (MBId.to_id mbid))::locals in
+      let kwd = if is_type then "Funsig" else "Functor" in
+      hov 2
+        (keyword kwd ++ spc () ++
+	 str "(" ++ pr_id (MBId.to_id mbid) ++ str ":" ++ pr_mtb1 ++ str ")" ++
+	 spc() ++ print_functor fty fatom is_type env' mp locals' me2)
+
+let rec print_expression x =
+  print_functor
+    print_modtype
+    (function true -> print_typ_expr | false -> print_mod_expr) x
+
+and print_signature x =
+  print_functor print_modtype print_structure x
+
+and print_modtype env mp locals mtb = match mtb.mod_type_alg with
+  | Some me -> print_expression true env mp locals me
+  | None -> print_signature true env mp locals mtb.mod_type
+
+let rec printable_body dir =
+  let dir = pop_dirpath dir in
+    DirPath.is_empty dir ||
+    try
+      match Nametab.locate_dir (qualid_of_dirpath dir) with
+	  DirOpenModtype _ -> false
+	| DirModule _ | DirOpenModule _ -> printable_body dir
+	| _ -> true
+    with
+	Not_found -> true
+
+(** Since we might play with nametab above, we should reset to prior
+    state after the printing *)
+
+let print_expression' is_type env mp me =
+  States.with_state_protection
+    (fun e -> eval_ppcmds (print_expression is_type env mp [] e)) me
+
+let print_signature' is_type env mp me =
+  States.with_state_protection
+    (fun e -> eval_ppcmds (print_signature is_type env mp [] e)) me
+
+let unsafe_print_module env mp with_body mb =
+  let name = print_modpath [] mp in
+  let pr_equals = spc () ++ str ":= " in
+  let body = match with_body, mb.mod_expr with
+    | false, _
+    | true, Abstract -> mt()
+    | _, Algebraic me -> pr_equals ++ print_expression' false env mp me
+    | _, Struct sign -> pr_equals ++ print_signature' false env mp sign
+    | _, FullStruct -> pr_equals ++ print_signature' false env mp mb.mod_type
+  in
+  let modtype = match mb.mod_expr, mb.mod_type_alg with
+    | FullStruct, _ -> mt ()
+    | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true env mp ty
+    | _, _ -> brk (1,1) ++ str": " ++ print_signature' true env mp mb.mod_type
+  in
+  hv 0 (keyword "Module" ++ spc () ++ name ++ modtype ++ body)
+
+exception ShortPrinting
+
+let print_module with_body mp =
+  let me = Global.lookup_module mp in
+  try
+    if !short then raise ShortPrinting;
+    unsafe_print_module (Some (Global.env ())) mp with_body me ++ fnl ()
+  with e when Errors.noncritical e ->
+    unsafe_print_module None mp with_body me ++ fnl ()
+
+let print_modtype kn =
+  let mtb = Global.lookup_modtype kn in
+  let name = print_kn [] kn in
+  hv 1
+    (keyword "Module Type" ++ spc () ++ name ++ str " =" ++ spc () ++
+     (try
+	if !short then raise ShortPrinting;
+	print_signature' true (Some (Global.env ())) kn mtb.mod_type
+      with e when Errors.noncritical e ->
+	print_signature' true None kn mtb.mod_type))
+
+end
+
+module Tag =
+struct
+  let definition =
+    let style = Terminal.make ~bold:true ~fg_color:`LIGHT_RED () in
+    Ppstyle.make ~style ["module"; "definition"]
+  let keyword =
+    let style = Terminal.make ~bold:true () in
+    Ppstyle.make ~style ["module"; "keyword"]
+end
+
+include Make(struct
+  let tag t s = Pp.tag (Pp.Tag.inj t Ppstyle.tag) s
+  let tag_definition s = tag Tag.definition s
+  let tag_keyword s = tag Tag.keyword s
+end)
diff --git a/parsing/printmod.mli b/printing/printmod.mli
index f60d19b3..bea47534 100644
--- a/parsing/printmod.mli
+++ b/printing/printmod.mli
@@ -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 Names
 
 (** false iff the module is an element of an open module type *)
-val printable_body : dir_path -> bool
+val printable_body : DirPath.t -> bool
 
-val print_module : bool -> module_path -> std_ppcmds
-
-val print_modtype : module_path -> std_ppcmds
+include Printmodsig.Pp
diff --git a/plugins/field/LegacyField.v b/printing/printmodsig.mli
index a5a85790..5d0d4ab0 100644
--- a/plugins/field/LegacyField.v
+++ b/printing/printmodsig.mli
@@ -1,14 +1,17 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Export LegacyField_Compl.
-Require Export LegacyField_Theory.
-Require Export LegacyField_Tactic.
-Declare ML Module "field_plugin".
+open Pp
+open Names
 
-(* Command declarations are moved to the ML side *)
+module type Pp =
+sig
+  val pr_mutual_inductive_body : Environ.env -> mutual_inductive -> Declarations.mutual_inductive_body -> std_ppcmds
+  val print_module : bool -> module_path -> std_ppcmds
+  val print_modtype : module_path -> std_ppcmds
+end
diff --git a/printing/richprinter.ml b/printing/richprinter.ml
new file mode 100644
index 00000000..d71dc82d
--- /dev/null
+++ b/printing/richprinter.ml
@@ -0,0 +1,26 @@
+open Richpp
+
+module RichppConstr = Ppconstr.Richpp
+module RichppVernac = Ppvernac.Richpp
+module RichppTactic = Pptactic.Richpp
+
+type rich_pp =
+    string
+    * Ppannotation.t Richpp.located Xml_datatype.gxml
+    * Xml_datatype.xml
+
+let get_annotations obj = Pp.Tag.prj obj Ppannotation.tag
+
+let make_richpp pr ast =
+  let raw_pp, rich_pp =
+    rich_pp get_annotations (pr ast)
+  in
+  let xml = Ppannotation.(
+    xml_of_rich_pp tag_of_annotation attributes_of_annotation rich_pp
+  )
+  in
+  (raw_pp, rich_pp, xml)
+
+let richpp_vernac = make_richpp RichppVernac.pr_vernac
+let richpp_constr = make_richpp RichppConstr.pr_constr_expr
+let richpp_tactic env = make_richpp (RichppTactic.pr_tactic env)
diff --git a/printing/richprinter.mli b/printing/richprinter.mli
new file mode 100644
index 00000000..c67d52c0
--- /dev/null
+++ b/printing/richprinter.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This module provides an entry point to "rich" pretty-printers that
+    produce pretty-printing as done by {!Printer} but with additional
+    annotations represented as a semi-structured document.
+
+    To understand what are these annotations and how they are represented
+    as standard XML attributes, please refer to {!Ppannotation}.
+
+    In addition to these annotations, each node of the semi-structured
+    document contains a [startpos] and an [endpos] attribute that
+    relate this node to the raw pretty-printing.
+    Please refer to {!Richpp} for more details. *)
+
+(** A rich pretty-print is composed of: *)
+type rich_pp =
+    (** - a raw pretty-print ; *)
+    string
+
+    (** - a generalized semi-structured document whose attributes are
+        annotations ; *)
+    * Ppannotation.t Richpp.located Xml_datatype.gxml
+
+    (** - an XML document, representing annotations as usual textual
+        XML attributes. *)
+    * Xml_datatype.xml
+
+(** [richpp_vernac phrase] produces a rich pretty-printing of [phrase]. *)
+val richpp_vernac : Vernacexpr.vernac_expr -> rich_pp
+
+(** [richpp_constr constr] produces a rich pretty-printing of [constr]. *)
+val richpp_constr : Constrexpr.constr_expr -> rich_pp
+
+(** [richpp_tactic constr] produces a rich pretty-printing of [tactic]. *)
+val richpp_tactic : Environ.env -> Tacexpr.tactic_expr -> rich_pp
diff --git a/proofs/clenv.ml b/proofs/clenv.ml
index 8c66269e..2c9c695b 100644
--- a/proofs/clenv.ml
+++ b/proofs/clenv.ml
@@ -1,31 +1,29 @@
 (************************************************************************)
 (*  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
 open Nameops
 open Term
+open Vars
 open Termops
 open Namegen
-open Sign
 open Environ
 open Evd
 open Reduction
 open Reductionops
-open Glob_term
-open Pattern
 open Tacred
 open Pretype_errors
 open Evarutil
 open Unification
-open Mod_subst
-open Coercion.Default
+open Misctypes
 
 (* Abbreviations *)
 
@@ -44,10 +42,10 @@ type clausenv = {
 let cl_env ce = ce.env
 let cl_sigma ce =  ce.evd
 
-let subst_clenv sub clenv =
-  { templval = map_fl (subst_mps sub) clenv.templval;
-    templtyp = map_fl (subst_mps sub) clenv.templtyp;
-    evd = subst_evar_defs_light sub clenv.evd;
+let map_clenv sub clenv =
+  { templval = map_fl sub clenv.templval;
+    templtyp = map_fl sub clenv.templtyp;
+    evd = cmap sub clenv.evd;
     env = clenv.env }
 
 let clenv_nf_meta clenv c = nf_meta clenv.evd c
@@ -56,6 +54,15 @@ let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv
 let clenv_value clenv = meta_instance clenv.evd clenv.templval
 let clenv_type clenv = meta_instance clenv.evd clenv.templtyp
 
+let refresh_undefined_univs clenv =
+  match kind_of_term clenv.templval.rebus with
+  | Var _ -> clenv, Univ.empty_level_subst
+  | App (f, args) when isVar f -> clenv, Univ.empty_level_subst
+  | _ ->  
+    let evd', subst = Evd.refresh_undefined_universes clenv.evd in
+    let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in
+      { clenv with evd = evd'; templval = map_freelisted clenv.templval;
+	templtyp = map_freelisted clenv.templtyp }, subst
 
 let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t
 
@@ -84,6 +91,16 @@ let clenv_push_prod cl =
 (* Instantiate the first [bound] products of [t] with metas (all products if
    [bound] is [None]; unfold local defs *)
 
+(** [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
+   [lmetas] is a list of metas to be applied to a proof of [t] so that
+   it produces the unification pattern [ccl]; [sigma'] is [sigma]
+   extended with [lmetas]; if [n] is defined, it limits the size of
+   the list even if [ccl] is still a product; otherwise, it stops when
+   [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x]
+   and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and
+   [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1]
+   and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *)
+
 let clenv_environments evd bound t =
   let rec clrec (e,metas) n t =
     match n, kind_of_term t with
@@ -101,41 +118,13 @@ let clenv_environments evd bound t =
   in
   clrec (evd,[]) bound t
 
-(* Instantiate the first [bound] products of [t] with evars (all products if
-   [bound] is [None]; unfold local defs *)
-
-let clenv_environments_evars env evd bound t =
-  let rec clrec (e,ts) n t =
-    match n, kind_of_term t with
-      | (Some 0, _) -> (e, List.rev ts, t)
-      | (n, Cast (t,_,_)) -> clrec (e,ts) n t
-      | (n, Prod (na,t1,t2)) ->
-          let e',constr = Evarutil.new_evar e env t1 in
-	  let dep = dependent (mkRel 1) t2 in
-	  clrec (e', constr::ts) (Option.map ((+) (-1)) n)
-	    (if dep then (subst1 constr t2) else t2)
-      | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t)
-      | (n, _) -> (e, List.rev ts, t)
-  in
-  clrec (evd,[]) bound t
-
-let clenv_conv_leq env sigma t c bound =
-  let ty = Retyping.get_type_of env sigma c in
-  let evd = Evd.create_goal_evar_defs sigma in
-  let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in
-  let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in
-  let evars = Evarconv.consider_remaining_unif_problems env evars in
-  let args = List.map (whd_evar evars) args in
-  check_evars env sigma evars (applist (c,args));
-  args
-
-let mk_clenv_from_env environ sigma n (c,cty) =
+let mk_clenv_from_env env sigma n (c,cty) =
   let evd = create_goal_evar_defs sigma in
   let (evd,args,concl) = clenv_environments evd n cty in
-  { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
+  { templval = mk_freelisted (applist (c,args));
     templtyp = mk_freelisted concl;
     evd = evd;
-    env = environ }
+    env = env }
 
 let mk_clenv_from_n gls n (c,cty) =
   mk_clenv_from_env (pf_env gls) gls.sigma n (c, cty)
@@ -152,13 +141,13 @@ let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t)
 
 let mentions clenv mv0 =
   let rec menrec mv1 =
-    mv0 = mv1 ||
+    Int.equal mv0 mv1 ||
     let mlist =
       try match meta_opt_fvalue clenv.evd mv1 with
       | Some (b,_) -> b.freemetas
       | None -> Metaset.empty
       with Not_found -> Metaset.empty in
-    meta_exists menrec mlist
+    Metaset.exists menrec mlist
   in menrec
 
 let error_incompatible_inst clenv mv  =
@@ -169,16 +158,16 @@ let error_incompatible_inst clenv mv  =
           (str "An incompatible instantiation has already been found for " ++
            pr_id id)
     | _ ->
-        anomaly "clenv_assign: non dependent metavar already assigned"
+        anomaly ~label:"clenv_assign" (Pp.str "non dependent metavar already assigned")
 
 (* TODO: replace by clenv_unify (mkMeta mv) rhs ? *)
 let clenv_assign mv rhs clenv =
   let rhs_fls = mk_freelisted rhs in
-  if meta_exists (mentions clenv mv) rhs_fls.freemetas then
+  if Metaset.exists (mentions clenv mv) rhs_fls.freemetas then
     error "clenv_assign: circularity in unification";
   try
     if meta_defined clenv.evd mv then
-      if not (eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then
+      if not (Term.eq_constr (fst (meta_fvalue clenv.evd mv)).rebus rhs) then
         error_incompatible_inst clenv mv
       else
 	clenv
@@ -265,22 +254,49 @@ let clenv_dependent ce = clenv_dependent_gen false ce
 
 (******************************************************************)
 
-let clenv_unify ?(flags=default_unify_flags) cv_pb t1 t2 clenv =
+let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv =
   { clenv with
       evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 }
 
-let clenv_unify_meta_types ?(flags=default_unify_flags) clenv =
+let clenv_unify_meta_types ?(flags=default_unify_flags ()) clenv =
   { clenv with evd = w_unify_meta_types ~flags:flags clenv.env clenv.evd }
 
-let clenv_unique_resolver ?(flags=default_unify_flags) clenv gl =
+let clenv_unique_resolver ?(flags=default_unify_flags ()) clenv gl =
   let concl = Goal.V82.concl clenv.evd (sig_it gl) in
-  if isMeta (fst (whd_stack clenv.evd clenv.templtyp.rebus)) then
+  if isMeta (fst (decompose_appvect (whd_nored clenv.evd clenv.templtyp.rebus))) then
     clenv_unify CUMUL ~flags (clenv_type clenv) concl
       (clenv_unify_meta_types ~flags clenv)
   else
     clenv_unify CUMUL ~flags
       (meta_reducible_instance clenv.evd clenv.templtyp) concl clenv
 
+let adjust_meta_source evd mv = function
+  | loc,Evar_kinds.VarInstance id ->
+    let rec match_name c l =
+      match kind_of_term c, l with
+      | Lambda (Name id,_,c), a::l when Constr.equal a (mkMeta mv) -> Some id
+      | Lambda (_,_,c), a::l -> match_name c l
+      | _ -> None in
+    (* This is very ad hoc code so that an evar inherits the name of the binder
+       in situations like "ex_intro (fun x => P) ?ev p" *)
+    let f = function (mv',(Cltyp (_,t) | Clval (_,_,t))) ->
+      if Metaset.mem mv t.freemetas then
+        let f,l = decompose_app t.rebus in
+        match kind_of_term f with
+        | Meta mv'' ->
+          (match meta_opt_fvalue evd mv'' with
+          | Some (c,_) -> match_name c.rebus l
+          | None -> None)
+        | Evar ev ->
+          (match existential_opt_value evd ev with
+          | Some c -> match_name c l
+          | None -> None)
+        | _ -> None
+      else None in
+    let id = try List.find_map f (Evd.meta_list evd) with Not_found -> id in
+    loc,Evar_kinds.VarInstance id
+  | src -> src
+
 (* [clenv_pose_metas_as_evars clenv dep_mvs]
  * For each dependent evar in the clause-env which does not have a value,
  * pose a value for it by constructing a fresh evar.  We do this in
@@ -317,14 +333,13 @@ let clenv_pose_metas_as_evars clenv dep_mvs =
       (* This assumes no cycle in the dependencies - is it correct ? *)
       if occur_meta ty then fold clenv (mvs@[mv])
       else
-	let (evd,evar) =
-	  new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in
+        let src = evar_source_of_meta mv clenv.evd in
+        let src = adjust_meta_source clenv.evd mv src in
+	let (evd,evar) = new_evar (cl_env clenv) clenv.evd ~src ty in
 	let clenv = clenv_assign mv evar {clenv with evd=evd} in
 	fold clenv mvs in
   fold clenv dep_mvs
 
-let evar_clenv_unique_resolver = clenv_unique_resolver
-
 (******************************************************************)
 
 let connect_clenv gls clenv =
@@ -333,6 +348,9 @@ let connect_clenv gls clenv =
     evd = evd ;
     env = Goal.V82.env evd (sig_it gls) }
 
+(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *)
+(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *)
+
 (* [clenv_fchain mv clenv clenv']
  *
  * Resolves the value of "mv" (which must be undefined) in clenv to be
@@ -357,11 +375,11 @@ let connect_clenv gls clenv =
    In particular, it assumes that [env'] and [sigma'] extend [env] and [sigma].
 *)
 
-let fchain_flags =
-  { default_unify_flags with
+let fchain_flags () =
+  { (default_unify_flags ()) with
     allow_K_in_toplevel_higher_order_unification = true }
 
-let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv =
+let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv =
   (* Add the metavars of [nextclenv] to [clenv], with their name-environment *)
   let clenv' =
     { templval = clenv.templval;
@@ -370,7 +388,7 @@ let clenv_fchain ?(flags=fchain_flags) mv clenv nextclenv =
       env = nextclenv.env } in
   (* unify the type of the template of [nextclenv] with the type of [mv] *)
   let clenv'' =
-    clenv_unify ~flags:flags CUMUL
+    clenv_unify ~flags CUMUL
       (clenv_term clenv' nextclenv.templtyp)
       (clenv_meta_type clenv' mv)
       clenv' in
@@ -397,8 +415,13 @@ let clenv_independent clenv =
   let deps = Metaset.union (dependent_in_type_of_metas clenv mvs) ctyp_mvs in
   List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
 
+let qhyp_eq h1 h2 = match h1, h2 with
+| NamedHyp n1, NamedHyp n2 -> Id.equal n1 n2
+| AnonHyp i1, AnonHyp i2 -> Int.equal i1 i2
+| _ -> false
+
 let check_bindings bl =
-  match list_duplicates (List.map pi2 bl) with
+  match List.duplicates qhyp_eq (List.map pi2 bl) with
     | NamedHyp s :: _ ->
 	errorlabstrm ""
 	  (str "The variable " ++ pr_id s ++
@@ -423,11 +446,11 @@ let error_already_defined b =
           (str "Binder name \"" ++ pr_id id ++
            str"\" already defined with incompatible value.")
     | AnonHyp n ->
-        anomalylabstrm ""
+        anomaly
           (str "Position " ++ int n ++ str" already defined.")
 
 let clenv_unify_binding_type clenv c t u =
-  if isMeta (fst (whd_stack clenv.evd u)) then
+  if isMeta (fst (decompose_appvect (whd_nored clenv.evd u))) then
     (* Not enough information to know if some subtyping is needed *)
     CoerceToType, clenv, c
   else
@@ -436,7 +459,8 @@ let clenv_unify_binding_type clenv c t u =
       let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in
       TypeProcessed, { clenv with evd = evd }, c
     with 
-      | PretypeError (_,_,NotClean _) as e -> raise e
+      | PretypeError (_,_,ActualTypeNotCoercible (_,_,NotClean _)) as e ->
+	  raise e
       | e when precatchable_exception e ->
 	  TypeNotProcessed, clenv, c
 
@@ -447,7 +471,7 @@ let clenv_assign_binding clenv k c =
   { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd }
 
 let clenv_match_args bl clenv =
-  if bl = [] then
+  if List.is_empty bl then
     clenv
   else
     let mvs = clenv_independent clenv in
@@ -456,7 +480,7 @@ let clenv_match_args bl clenv =
       (fun clenv (loc,b,c) ->
 	let k = meta_of_binder clenv loc mvs b in
         if meta_defined clenv.evd k then
-          if eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv
+          if Term.eq_constr (fst (meta_fvalue clenv.evd k)).rebus c then clenv
           else error_already_defined b
         else
 	  clenv_assign_binding clenv k c)
@@ -466,7 +490,7 @@ exception NoSuchBinding
 
 let clenv_constrain_last_binding c clenv =
   let all_mvs = collect_metas clenv.templval.rebus in
-  let k = try list_last all_mvs with Failure _ -> raise NoSuchBinding in
+  let k = try List.last all_mvs with Failure _ -> raise NoSuchBinding in
   clenv_assign_binding clenv k c
 
 let error_not_right_number_missing_arguments n =
@@ -475,17 +499,17 @@ let error_not_right_number_missing_arguments n =
       int n ++ str ").")
 
 let clenv_constrain_dep_args hyps_only bl clenv =
-  if bl = [] then
+  if List.is_empty bl then
     clenv
   else
     let occlist = clenv_dependent_gen hyps_only clenv in
-    if List.length occlist = List.length bl then
+    if Int.equal (List.length occlist) (List.length bl) then
       List.fold_left2 clenv_assign_binding clenv occlist bl
     else
       if hyps_only then
 	(* Tolerance for compatibility <= 8.3 *)
 	let occlist' = clenv_dependent_gen hyps_only ~iter:false clenv in
-	if List.length occlist' = List.length bl then
+	if Int.equal (List.length occlist') (List.length bl) then
 	  List.fold_left2 clenv_assign_binding clenv occlist' bl
 	else
 	  error_not_right_number_missing_arguments (List.length occlist)
@@ -508,9 +532,12 @@ let make_clenv_binding_gen hyps_only n env sigma (c,t) = function
 
 let make_clenv_binding_env_apply env sigma n =
   make_clenv_binding_gen true n env sigma
+
+let make_clenv_binding_env env sigma =
+  make_clenv_binding_gen false None env sigma
 	
-let make_clenv_binding_apply gls n = make_clenv_binding_gen true n (pf_env gls) gls.sigma
-let make_clenv_binding gls = make_clenv_binding_gen false None (pf_env gls) gls.sigma
+let make_clenv_binding_apply env sigma n = make_clenv_binding_gen true n env sigma
+let make_clenv_binding env sigma = make_clenv_binding_gen false None env sigma
 
 (****************************************************************)
 (* Pretty-print *)
@@ -520,3 +547,131 @@ let pr_clenv clenv =
     (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
      str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
      pr_evar_map (Some 2) clenv.evd)
+
+(****************************************************************)
+(** Evar version of mk_clenv *)
+
+type hole = {
+  hole_evar : constr;
+  hole_type : types;
+  hole_deps  : bool;
+  hole_name : Name.t;
+}
+
+type clause = {
+  cl_holes : hole list;
+  cl_concl : types;
+}
+
+let make_evar_clause env sigma ?len t =
+  let bound = match len with
+  | None -> -1
+  | Some n -> assert (0 <= n); n
+  in
+  (** FIXME: do the renaming online *)
+  let t = rename_bound_vars_as_displayed [] [] t in
+  let rec clrec (sigma, holes) n t =
+    if n = 0 then (sigma, holes, t)
+    else match kind_of_term t with
+    | Cast (t, _, _) -> clrec (sigma, holes) n t
+    | Prod (na, t1, t2) ->
+      let store = Typeclasses.set_resolvable Evd.Store.empty false in
+      let sigma, ev = new_evar ~store env sigma t1 in
+      let dep = dependent (mkRel 1) t2 in
+      let hole = {
+        hole_evar = ev;
+        hole_type = t1;
+        hole_deps = dep;
+        (* We fix it later *)
+        hole_name = na;
+      } in
+      let t2 = if dep then subst1 ev t2 else t2 in
+      clrec (sigma, hole :: holes) (pred n) t2
+    | LetIn (na, b, _, t) -> clrec (sigma, holes) n (subst1 b t)
+    | _ -> (sigma, holes, t)
+  in
+  let (sigma, holes, t) = clrec (sigma, []) bound t in
+  let holes = List.rev holes in
+  let clause = { cl_concl = t; cl_holes = holes } in
+  (sigma, clause)
+
+let explain_no_such_bound_variable holes id =
+  let fold h accu = match h.hole_name with
+  | Anonymous -> accu
+  | Name id -> id :: accu
+  in
+  let mvl = List.fold_right fold holes [] in
+  let expl = match mvl with
+  | [] -> str " (no bound variables at all in the expression)."
+  | [id] -> str "(possible name is: " ++ pr_id id ++ str ")."
+  | _ -> str "(possible names are: " ++ pr_enum pr_id mvl ++ str ")."
+  in
+  errorlabstrm "" (str "No such bound variable " ++ pr_id id ++ expl)
+
+let evar_with_name holes id =
+  let map h = match h.hole_name with
+  | Anonymous -> None
+  | Name id' -> if Id.equal id id' then Some h else None
+  in
+  let hole = List.map_filter map holes in
+  match hole with
+  | [] -> explain_no_such_bound_variable holes id
+  | [h] -> h.hole_evar
+  | _ ->
+    errorlabstrm ""
+      (str "Binder name \"" ++ pr_id id ++
+        str "\" occurs more than once in clause.")
+
+let evar_of_binder holes = function
+| NamedHyp s -> evar_with_name holes s
+| AnonHyp n ->
+  try
+    let h = List.nth holes (pred n) in
+    h.hole_evar
+  with e when Errors.noncritical e ->
+    errorlabstrm "" (str "No such binder.")
+
+let define_with_type sigma env ev c =
+  let t = Retyping.get_type_of env sigma ev in
+  let ty = Retyping.get_type_of env sigma c in
+  let j = Environ.make_judge c ty in
+  let (sigma, j) = Coercion.inh_conv_coerce_to true (Loc.ghost) env sigma j t in
+  let (ev, _) = destEvar ev in
+  let sigma = Evd.define ev j.Environ.uj_val sigma in
+  sigma
+
+let solve_evar_clause env sigma hyp_only clause = function
+| NoBindings -> sigma
+| ImplicitBindings largs ->
+  let fold holes h =
+    if h.hole_deps then
+      (** Some subsequent term uses the hole *)
+      let (ev, _) = destEvar h.hole_evar in
+      let is_dep hole = occur_evar ev hole.hole_type in
+      let in_hyp = List.exists is_dep holes in
+      let in_ccl = occur_evar ev clause.cl_concl in
+      let dep = if hyp_only then in_hyp && not in_ccl else in_hyp || in_ccl in
+      let h = { h with hole_deps = dep } in
+      h :: holes
+    else
+      (** The hole does not occur anywhere *)
+      h :: holes
+  in
+  let holes = List.fold_left fold [] (List.rev clause.cl_holes) in
+  let map h = if h.hole_deps then Some h.hole_evar else None in
+  let evs = List.map_filter map holes in
+  let len = List.length evs in
+  if Int.equal len (List.length largs) then
+    let fold sigma ev arg = define_with_type sigma env ev arg in
+    let sigma = List.fold_left2 fold sigma evs largs in
+    sigma
+  else
+    error_not_right_number_missing_arguments len
+| ExplicitBindings lbind ->
+  let () = check_bindings lbind in
+  let fold sigma (_, binder, c) =
+    let ev = evar_of_binder clause.cl_holes binder in
+    define_with_type sigma env ev c
+  in
+  let sigma = List.fold_left fold sigma lbind in
+  sigma
diff --git a/proofs/clenv.mli b/proofs/clenv.mli
index f7817611..9b671bcf 100644
--- a/proofs/clenv.mli
+++ b/proofs/clenv.mli
@@ -1,21 +1,18 @@
 (************************************************************************)
 (*  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 Util
 open Names
 open Term
-open Sign
 open Environ
 open Evd
-open Evarutil
 open Mod_subst
-open Glob_term
 open Unification
+open Misctypes
 
 (** {6 The Type of Constructions clausale environments.} *)
 
@@ -27,10 +24,8 @@ type clausenv = {
 				    out *)
   templtyp : constr freelisted (** its type *)}
 
-(** Substitution is not applied on templenv (because [subst_clenv] is
-   applied only on hints which typing env is overwritten by the
-   goal env) *)
-val subst_clenv : substitution -> clausenv -> clausenv
+
+val map_clenv : (constr -> constr) -> clausenv -> clausenv
 
 (** subject of clenv (instantiated) *)
 val clenv_value     : clausenv -> constr
@@ -50,6 +45,9 @@ val mk_clenv_from_n :
 val mk_clenv_type_of : Goal.goal sigma -> constr -> clausenv
 val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> clausenv
 
+(** Refresh the universes in a clenv *)
+val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst
+
 (** {6 linking of clenvs } *)
 
 val connect_clenv : Goal.goal sigma -> clausenv -> clausenv
@@ -66,11 +64,6 @@ val clenv_unify :
 val clenv_unique_resolver :
   ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv
 
-(** same as above ([allow_K=false]) but replaces remaining metas
-   with fresh evars if [evars_flag] is [true] *)
-val evar_clenv_unique_resolver :
-  ?flags:unify_flags -> clausenv -> Goal.goal sigma -> clausenv
-
 val clenv_dependent : clausenv -> metavariable list
 
 val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv
@@ -89,9 +82,6 @@ val clenv_missing : clausenv -> metavariable list
 exception NoSuchBinding
 val clenv_constrain_last_binding : constr -> clausenv -> clausenv
 
-(** defines metas corresponding to the name of the bindings *)
-val clenv_match_args : arg_bindings -> clausenv -> clausenv
-
 val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv
 
 (** start with a clenv to refine with a given term with bindings *)
@@ -104,31 +94,14 @@ val make_clenv_binding_env_apply :
    clausenv
 
 val make_clenv_binding_apply :
-  Goal.goal sigma -> int option -> constr * constr -> constr bindings ->
+  env -> evar_map -> int option -> constr * constr -> constr bindings ->
    clausenv
+
+val make_clenv_binding_env :
+  env -> evar_map -> constr * constr -> constr bindings -> clausenv
+
 val make_clenv_binding :
-  Goal.goal sigma -> constr * constr -> constr bindings -> clausenv
-
-(** [clenv_environments sigma n t] returns [sigma',lmeta,ccl] where
-   [lmetas] is a list of metas to be applied to a proof of [t] so that
-   it produces the unification pattern [ccl]; [sigma'] is [sigma]
-   extended with [lmetas]; if [n] is defined, it limits the size of
-   the list even if [ccl] is still a product; otherwise, it stops when
-   [ccl] is not a product; example: if [t] is [forall x y, x=y -> y=x]
-   and [n] is [None], then [lmetas] is [Meta n1;Meta n2;Meta n3] and
-   [ccl] is [Meta n1=Meta n2]; if [n] is [Some 1], [lmetas] is [Meta n1]
-   and [ccl] is [forall y, Meta n1=y -> y=Meta n1] *)
-val clenv_environments :
- evar_map -> int option -> types -> evar_map * constr list * types
-
-(** [clenv_environments_evars env sigma n t] does the same but returns
-   a list of Evar's defined in [env] and extends [sigma] accordingly *)
-val clenv_environments_evars :
- env -> evar_map -> int option -> types -> evar_map * constr list * types
-
-(** [clenv_conv_leq env sigma t c n] looks for c1...cn s.t. [t <= c c1...cn] *)
-val clenv_conv_leq :
- env -> evar_map -> types -> constr -> int -> constr list
+  env -> evar_map -> constr * constr -> constr bindings -> clausenv
 
 (** if the clause is a product, add an extra meta for this product *)
 exception NotExtensibleClause
@@ -137,3 +110,58 @@ val clenv_push_prod : clausenv -> clausenv
 (** {6 Pretty-print (debug only) } *)
 val pr_clenv : clausenv -> Pp.std_ppcmds
 
+(** {6 Evar-based clauses} *)
+
+(** The following code is an adaptation of the [make_clenv_*] functions above,
+    except that it uses evars instead of metas, and naturally fits in the new
+    refinement monad. It should eventually replace all uses of the
+    aforementioned functions.
+
+    A clause is constructed as follows: assume a type [t := forall (x1 : A1) ...
+    (xn : An), T], we instantiate all the [xi] with a fresh evar [ei] and
+    return [T(xi := ei)] together with the [ei] enriched with a bit of
+    additional data. This is the simple part done by [make_evar_clause].
+
+    The problem lies in the fact we want to solve such holes with some
+    [constr bindings]. This entails some subtleties, because the provided terms
+    may only be well-typed up to a coercion, which we can only infer if we have
+    enough typing information. The meta machinery could insert coercions through
+    tricky instantiation delays. The only solution we have now is to delay the
+    tentative resolution of clauses by providing the [solve_evar_clause]
+    function, to be called at a smart enough time.
+*)
+
+type hole = {
+  hole_evar : constr;
+  (** The hole itself. Guaranteed to be an evar. *)
+  hole_type : types;
+  (** Type of the hole in the current environment. *)
+  hole_deps  : bool;
+  (** Whether the remainder of the clause was dependent in the hole. Note that
+      because let binders are substituted, it does not mean that it actually
+      appears somewhere in the returned clause. *)
+  hole_name : Name.t;
+  (** Name of the hole coming from its binder. *)
+}
+
+type clause = {
+  cl_holes : hole list;
+  cl_concl : types;
+}
+
+val make_evar_clause : env -> evar_map -> ?len:int -> types ->
+  (evar_map * clause)
+(** An evar version of {!make_clenv_binding}. Given a type [t],
+    [evar_environments env sigma ~len t bl] tries to eliminate at most [len]
+    products of the type [t] by filling it with evars. It returns the resulting
+    type together with the list of holes generated. Assumes that [t] is
+    well-typed in the environment. *)
+
+val solve_evar_clause : env -> evar_map -> bool -> clause -> constr bindings ->
+  evar_map
+(** [solve_evar_clause env sigma hyps cl bl] tries to solve the holes contained
+    in [cl] according to the [bl] argument. Assumes that [bl] are well-typed in
+    the environment. The boolean [hyps] is a compatibility flag that allows to
+    consider arguments to be dependent only when they appear in hypotheses and
+    not in the conclusion. This boolean is only used when [bl] is of the form
+    [ImplicitBindings _]. *)
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index b54e2323..18883df2 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -1,30 +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        *)
 (************************************************************************)
 
-open Pp
 open Util
 open Names
-open Nameops
 open Term
 open Termops
-open Sign
-open Environ
 open Evd
-open Evarutil
-open Proof_type
 open Refiner
 open Logic
 open Reduction
-open Reductionops
 open Tacmach
-open Glob_term
-open Pattern
-open Tacexpr
 open Clenv
 
 
@@ -39,6 +29,7 @@ let clenv_cast_meta clenv =
     match kind_of_term u with
       | App _ | Case _ -> crec_hd u
       | Cast (c,_,_) when isMeta c -> u
+      | Proj (p, c) -> mkProj (p, crec_hd c)
       | _  -> map_constr crec u
 
   and crec_hd u =
@@ -53,6 +44,7 @@ let clenv_cast_meta clenv =
       | App(f,args) -> mkApp (crec_hd f, Array.map crec args)
       | Case(ci,p,c,br) ->
 	  mkCase (ci, crec_hd p, crec_hd c, Array.map crec br)
+      | Proj (p, c) -> mkProj (p, crec_hd c)
       | _ -> u
   in
   crec
@@ -62,67 +54,78 @@ let clenv_value_cast_meta clenv =
 
 let clenv_pose_dependent_evars with_evars clenv =
   let dep_mvs = clenv_dependent clenv in
-  if dep_mvs <> [] & not with_evars then
+  if not (List.is_empty dep_mvs) && not with_evars then
     raise
       (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs)));
   clenv_pose_metas_as_evars clenv dep_mvs
 
-let clenv_refine with_evars ?(with_classes=true) clenv gls =
+let clenv_refine with_evars ?(with_classes=true) clenv =
+  (** ppedrot: a Goal.enter here breaks things, because the tactic below may
+      solve goals by side effects, while the compatibility layer keeps those
+      useless goals. That deserves a FIXME. *)
+  Proofview.V82.tactic begin fun gl ->
   let clenv = clenv_pose_dependent_evars with_evars clenv in
   let evd' =
     if with_classes then
-      Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
+      let evd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
         ~fail:(not with_evars) clenv.env clenv.evd
+      in Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd'
     else clenv.evd
   in
   let clenv = { clenv with evd = evd' } in
   tclTHEN
-    (tclEVARS evd')
-    (refine (clenv_cast_meta clenv (clenv_value clenv)))
-    gls
+    (tclEVARS (Evd.clear_metas evd'))
+    (refine_no_check (clenv_cast_meta clenv (clenv_value clenv))) gl
+  end
 
 open Unification
 
 let dft = default_unify_flags
 
-let res_pf clenv ?(with_evars=false) ?(flags=dft) gls =
-  clenv_refine with_evars (clenv_unique_resolver ~flags clenv gls) gls
-
-let elim_res_pf_THEN_i clenv tac gls =
-  let clenv' = (clenv_unique_resolver ~flags:elim_flags clenv gls) in
-  tclTHENLASTn (clenv_refine false clenv') (tac clenv') gls
-
-let e_res_pf clenv = res_pf clenv ~with_evars:true ~flags:dft
-
+let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv =
+  Proofview.Goal.enter begin fun gl ->
+    let clenv gl = clenv_unique_resolver ~flags clenv gl in
+    clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl))
+  end
 
 (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en
    particulier ne semblent pas vérifier que des instances différentes
    d'une même Meta sont compatibles. D'ailleurs le "fst" jette les metas
    provenant de w_Unify. (Utilisé seulement dans prolog.ml) *)
 
-let fail_quick_unif_flags = {
+let fail_quick_core_unif_flags = {
   modulo_conv_on_closed_terms = Some full_transparent_state;
   use_metas_eagerly_in_conv_on_closed_terms = false;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
   modulo_delta = empty_transparent_state;
   modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
   check_applied_meta_types = false;
-  resolve_evars = false;
   use_pattern_unification = false;
   use_meta_bound_pattern_unification = true; (* ? *)
-  frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.empty;
   restrict_conv_on_strict_subterms = false; (* ? *)
   modulo_betaiota = false;
   modulo_eta = true;
-  allow_K_in_toplevel_higher_order_unification = false
 }
 
-(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
-let unifyTerms ?(flags=fail_quick_unif_flags) m n gls =
-  let env = pf_env gls in
-  let evd = create_goal_evar_defs (project gls) in
-  let evd' = w_unify env evd CONV ~flags m n in
-  tclIDTAC {it = gls.it; sigma =  evd'}
+let fail_quick_unif_flags = {
+  core_unify_flags = fail_quick_core_unif_flags;
+  merge_unify_flags = fail_quick_core_unif_flags;
+  subterm_unify_flags = fail_quick_core_unif_flags;
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = false
+}
 
-let unify ?(flags=fail_quick_unif_flags) m gls =
-  let n = pf_concl gls in unifyTerms ~flags m n gls
+(* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *)
+let unify ?(flags=fail_quick_unif_flags) m =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Tacmach.New.pf_env gl in
+    let n = Tacmach.New.pf_nf_concl gl in
+    let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in
+    try
+      let evd' = w_unify env evd CONV ~flags m n in
+	Proofview.Unsafe.tclEVARSADVANCE evd'
+    with e when Errors.noncritical e ->
+      (** This is Tacticals.tclFAIL *)
+      Proofview.tclZERO (FailError (0, lazy (Errors.print e)))
+  end
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 4ed18d2e..da40427c 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -1,29 +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 Util
-open Names
 open Term
-open Sign
-open Evd
 open Clenv
 open Proof_type
 open Tacexpr
 open Unification
 
 (** Tactics *)
-val unify : ?flags:unify_flags -> constr -> tactic
-val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> tactic
-val res_pf : clausenv -> ?with_evars:evars_flag -> ?flags:unify_flags -> tactic
-val elim_res_pf_THEN_i : clausenv -> (clausenv -> tactic array) -> tactic
+val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic
+val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> unit Proofview.tactic
+val res_pf : ?with_evars:evars_flag -> ?with_classes:bool -> ?flags:unify_flags -> clausenv -> unit Proofview.tactic
 
 val clenv_pose_dependent_evars : evars_flag -> clausenv -> clausenv
 val clenv_value_cast_meta : clausenv -> constr
-
-(** Compatibility, use res_pf ?with_evars:true instead *)
-val e_res_pf : clausenv -> tactic
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index 6548a1dd..c8cb1d1c 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -1,61 +1,71 @@
 (************************************************************************)
 (*  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 Term
 open Evd
 open Evarutil
-open Sign
-open Refiner
+open Evarsolve
 
 (******************************************)
 (* Instantiation of existential variables *)
 (******************************************)
 
 let depends_on_evar evk _ (pbty,_,t1,t2) =
-  try head_evar t1 = evk
+  try Evar.equal (head_evar t1) evk
   with NoHeadEvar ->
-  try head_evar t2 = evk
+  try Evar.equal (head_evar t2) evk
   with NoHeadEvar -> false
 
-let define_and_solve_constraints evk c evd =
-  try
-    let evd = define evk c evd in
-    let (evd,pbs) = extract_changed_conv_pbs evd (depends_on_evar evk) in
-    fst (List.fold_left
-      (fun (evd,b as p) (pbty,env,t1,t2) ->
-	if b then Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 else p) (evd,true)
-      pbs)
-  with e when Pretype_errors.precatchable_exception e ->
-    error "Instance does not satisfy constraints."
+let define_and_solve_constraints evk c env evd =
+  if Termops.occur_evar evk c then
+    Pretype_errors.error_occur_check env evd evk c;
+  let evd = define evk c evd in
+  let (evd,pbs) = extract_changed_conv_pbs evd (depends_on_evar evk) in
+  match
+    List.fold_left
+      (fun p (pbty,env,t1,t2) -> match p with
+	| Success evd -> Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2
+	| UnifFailure _ as x -> x) (Success evd)
+      pbs
+  with
+    | Success evd -> evd
+    | UnifFailure _ -> error "Instance does not satisfy the constraints."
 
 let w_refine (evk,evi) (ltac_var,rawc) sigma =
   if Evd.is_defined sigma evk then
     error "Instantiate called on already-defined evar";
-  let env = Evd.evar_env evi in
+  let env = Evd.evar_filtered_env evi in
   let sigma',typed_c =
-    try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var
-	  (Pretyping.OfType (Some evi.evar_concl)) rawc
+    let flags = {
+      Pretyping.use_typeclasses = true;
+      Pretyping.use_unif_heuristics = true;
+      Pretyping.use_hook = None;
+      Pretyping.fail_evar = false;
+      Pretyping.expand_evars = true } in
+    try Pretyping.understand_ltac flags
+      env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc
     with e when Errors.noncritical e ->
-      let loc = Glob_term.loc_of_glob_constr rawc in
+      let loc = Glob_ops.loc_of_glob_constr rawc in
       user_err_loc
         (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^
 			string_of_existential evk))
   in
-  define_and_solve_constraints evk typed_c (evars_reset_evd sigma' sigma)
+  define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma)
 
 (* vernac command Existential *)
 
 (* Main component of vernac command Existential *)
 let instantiate_pf_com evk com sigma =
   let evi = Evd.find sigma evk in
-  let env = Evd.evar_env evi in
-  let rawc = Constrintern.intern_constr sigma env com in
-  let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in
+  let env = Evd.evar_filtered_env evi in
+  let rawc = Constrintern.intern_constr env com in
+  let ltac_vars = Pretyping.empty_lvar in
+  let sigma' = w_refine (evk, evi) (ltac_vars, rawc) sigma in
   sigma'
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index 9fb9c09b..673dad55 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -1,18 +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 Environ
 open Evd
-open Refiner
 open Pretyping
-open Glob_term
 
 (** Refinement of existential variables. *)
 
@@ -20,6 +15,6 @@ val w_refine : evar * evar_info ->
   glob_constr_ltac_closure -> evar_map -> evar_map
 
 val instantiate_pf_com :
-  Evd.evar -> Topconstr.constr_expr -> Evd.evar_map -> Evd.evar_map
+  Evd.evar -> Constrexpr.constr_expr -> Evd.evar_map -> Evd.evar_map
 
 (** the instantiate tactic was moved to [tactics/evar_tactics.ml] *)
diff --git a/proofs/goal.ml b/proofs/goal.ml
index 20527c62..e3570242 100644
--- a/proofs/goal.ml
+++ b/proofs/goal.ml
@@ -1,545 +1,105 @@
 (************************************************************************)
 (*  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 Util
 open Pp
 open Term
+open Vars
+open Context
 
 (* This module implements the abstract interface to goals *)
-(* A general invariant of the module, is that a goal whose associated 
+(* A general invariant of the module, is that a goal whose associated
    evar is defined in the current evar_map, should not be accessed. *)
 
 (* type of the goals *)
-type goal = {
-  content : Evd.evar;      (* Corresponding evar. Allows to retrieve
-			      logical information once put together
-			      with an evar_map. *)
-  tags : string list       (* Heriditary? tags to be displayed *)
-}
-(* spiwack: I don't deal with the tags, yet. It is a worthy discussion
-   whether we do want some tags displayed besides the goal or not. *)
+type goal = Evd.evar
 
+let pr_goal e = str "GOAL:" ++ Pp.int (Evar.repr e)
 
-let pr_goal {content = e} = str "GOAL:" ++ Pp.int e
+let uid e = string_of_int (Evar.repr e)
+let get_by_uid u = Evar.unsafe_of_int (int_of_string u)
 
-(* access primitive *)
-(* invariant : [e] must exist in [em] *)
-let content evars { content = e } = Evd.find evars e
-
-
-(* Builds a new (empty) goal with evar [e] *)
-let build e =
-  { content = e ;
-    tags = []
-  }
-
-
-let uid {content = e} = string_of_int e
-let get_by_uid u =
-  (* this necessarily forget about tags.
-     when tags are to be implemented, they
-     should be done another way.
-     We could use the store in evar_extra,
-     for instance. *)
-  build (int_of_string u)
-
-(* Builds a new goal with content evar [e] and 
-   inheriting from goal [gl]*)
-let descendent gl e =
-  { gl with content = e}
-
-(* [advance sigma g] returns [Some g'] if [g'] is undefined and 
-    is the current avatar of [g] (for instance [g] was changed by [clear]
-    into [g']). It returns [None] if [g] has been (partially) solved. *)
-open Store.Field
-let rec advance sigma g =
-  let evi = Evd.find sigma g.content in
-  if Option.default false (Evarutil.cleared.get evi.Evd.evar_extra) then
-    let v = 
-      match evi.Evd.evar_body with 
-      | Evd.Evar_defined c -> c
-      | _ -> Util.anomaly "Some goal is marked as 'cleared' but is uninstantiated"
-    in
-    let (e,_) = Term.destEvar v in
-    let g' = { g with content = e } in
-    advance sigma g'
-  else
-    match evi.Evd.evar_body with
-    | Evd.Evar_defined _ -> None
-    | _ -> Some g
-
-(*** Goal tactics ***)
-
-
-(* Goal tactics are [subgoal sensitive]-s *)
-type subgoals = { subgoals: goal list }
-
-(* type of the base elements of the goal API.*)
-(* it has an extra evar_info with respect to what would be expected,
-   it is supposed to be the evar_info of the goal in the evar_map.
-   The idea is that it is computed by the [run] function as an 
-   optimisation, since it will generaly not change during the 
-   evaluation. *)
-type 'a sensitive = 
-    Environ.env -> Evd.evar_map ref -> goal -> Evd.evar_info -> 'a
-
-(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *)
-(* the evar_info corresponding to the goal is computed at once
-   as an optimisation (it shouldn't change during the evaluation). *)
-let eval t env defs gl =
-  let info = content defs gl in
-  let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
-  let rdefs = ref defs in
-  let r = t env rdefs gl info in
-  ( r , !rdefs )
-
-(* monadic bind on sensitive expressions *)
-let bind e f env rdefs goal info =
-  f (e env rdefs goal info) env rdefs goal info
-
-(* monadic return on sensitive expressions *)
-let return v _ _ _ _ = v
-
-(* interpretation of "open" constr *)
-(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. 
-    In an ideal world, this could/should be the other way round.
-    As of now, though, it seems at least quite useful to build tactics. *)
-let interp_constr cexpr env rdefs _ _ =
-  let (defs,c) = Constrintern.interp_open_constr !rdefs env cexpr in
-  rdefs := defs ;
-  c
-
-(* Type of constr with holes used by refine. *)
-(* The list of evars doesn't necessarily contain all the evars in the constr, 
-    only those the constr has introduced. *)
-(* The variables in [myevars] are supposed to be stored
-   in decreasing order. Breaking this invariant might cause
-   many things to go wrong. *)
-type refinable = {
-  me: constr;
-  my_evars: Evd.evar list
-}
-
-module Refinable = struct
-  type t = refinable
-
-  type handle = Evd.evar list ref
-
-  let make t env rdefs gl info = 
-    let r = ref [] in
-    let me = t r env rdefs gl info in
-    { me = me;
-       my_evars = !r }
-  let make_with t env rdefs gl info =
-    let r = ref [] in
-    let (me,side) = t r env rdefs gl info in
-    { me = me ; my_evars = !r } , side
-
-  let mkEvar handle env typ _ rdefs _ _ =
-    let ev = Evarutil.e_new_evar rdefs env typ in
-    let (e,_) = Term.destEvar ev in
-    handle := e::!handle;
-    ev
-      
-  (* [with_type c typ] constrains term [c] to have type [typ].  *)
-  let with_type t typ env rdefs _ _ = 
-    (* spiwack: this function assumes that no evars can be created during
-        this sort of coercion.
-        If it is not the case it could produce bugs. We would need to add a handle
-        and add the new evars to it. *)
-    let my_type = Retyping.get_type_of env !rdefs t in
-    let j = Environ.make_judge t my_type in
-    let tycon = Evarutil.mk_tycon_type typ in
-    let (new_defs,j') = 
-      Coercion.Default.inh_conv_coerce_to true (Util.dummy_loc) env !rdefs j tycon 
-    in
-    rdefs := new_defs;
-    j'.Environ.uj_val 
-
-  (* spiwack: it is not very fine grain since it solves all typeclasses holes, 
-      not only those containing the current goal, or a given term. But it
-      seems to fit our needs so far. *)
-  let resolve_typeclasses ?filter ?split ?(fail=false) () env rdefs _ _ =
-    rdefs:=Typeclasses.resolve_typeclasses ?filter ?split ~fail env !rdefs;
-    ()
-
-
-
-  (* a pessimistic (i.e : there won't be many positive answers) filter
-     over evar_maps, acting only on undefined evars *)
-  let evar_map_filter_undefined f evm =
-    Evd.fold_undefined
-      (fun ev evi r -> if f ev evi then Evd.add r ev evi else r)
-      evm
-      Evd.empty
-
-  (* Union, sorted in decreasing order, of two lists of evars in decreasing order. *)
-  let rec fusion l1 l2 = match l1 , l2 with
-    | [] , _ -> l2
-    | _ , [] -> l1
-    | a::l1 , b::_ when a>b -> a::(fusion l1 l2)
-    | a::l1 , b::l2 when a=b -> a::(fusion l1 l2)
-    | _ , b::l2 -> b::(fusion l1 l2)
-
-  let update_handle handle init_defs post_defs =
-    (* [delta_evars] holds the evars that have been introduced by this
-       refinement (but not immediatly solved) *)
-    (* spiwack: this is the hackish part, don't know how to do any better though. *)
-    let delta_evars = evar_map_filter_undefined
-      (fun ev _ -> not (Evd.mem init_defs ev))
-      post_defs
-    in
-    (* [delta_evars] in the shape of a list of [evar]-s*)
-    let delta_list = List.map fst (Evd.to_list delta_evars) in
-    (* The variables in [myevars] are supposed to be stored
-       in decreasing order. Breaking this invariant might cause
-       many things to go wrong. *)
-    handle := fusion delta_list !handle;
-    delta_evars
-
-  (* [constr_of_raw] is a pretyping function. The [check_type] argument
-      asks whether the term should have the same type as the conclusion.
-      [resolve_classes] is a flag on pretyping functions which, if set to true,
-      calls the typeclass resolver.
-      The principal argument is a [glob_constr] which is then pretyped in the
-      context of a term, the remaining evars are registered to the handle.
-      It is the main component of the toplevel refine tactic.*)
-  (* spiwack: it is not entirely satisfactory to have this function here. Plus it is
-      a bit hackish. However it does not seem possible to move it out until
-      pretyping is defined as some proof procedure. *)
-  let constr_of_raw handle check_type resolve_classes rawc env rdefs gl info =
-    (* We need to keep trace of what [rdefs] was originally*)
-    let init_defs = !rdefs in
-    (* if [check_type] is true, then creates a type constraint for the 
-       proof-to-be *)
-    let tycon = Pretyping.OfType (Option.init check_type (Evd.evar_concl info)) in
-    (* call to [understand_tcc_evars] returns a constr with undefined evars
-       these evars will be our new goals *)
-    let open_constr = 
-      Pretyping.Default.understand_tcc_evars ~resolve_classes rdefs env tycon rawc
-    in
-      ignore(update_handle handle init_defs !rdefs);
-      open_constr 
-  
-  let constr_of_open_constr handle check_type (evars, c) env rdefs gl info =
-    let delta = update_handle handle !rdefs evars in
-      rdefs := Evd.fold (fun ev evi evd -> Evd.add evd ev evi) delta !rdefs;
-      if check_type then with_type c (Evd.evar_concl (content !rdefs gl)) env rdefs gl info
-      else c
- 
-end
-
-(* [refine t] takes a refinable term and use it as a partial proof for current
-    goal. *)
-let refine step env rdefs gl info =
-  (* subgoals to return *)
-  (* The evars in [my_evars] are stored in reverse order.
-     It is expectingly better however to display the goal
-     in increasing order. *)
-  rdefs := Evarconv.consider_remaining_unif_problems env !rdefs ;
-  let subgoals = List.map (descendent gl) (List.rev step.my_evars) in
-  (* creates the new [evar_map] by defining the evar of the current goal
-     as being [refine_step]. *)
-  let new_defs = Evd.define gl.content (step.me) !rdefs in
-  rdefs := new_defs;   
-  (* Filtering the [subgoals] for uninstanciated (=unsolved) goals. *)
-  let subgoals = 
-    Option.List.flatten (List.map (advance !rdefs) subgoals) 
-  in
-  { subgoals = subgoals }
-
-
-(*** Cleaning  goals ***)
-
-let clear ids env rdefs gl info =
-  let hyps = Evd.evar_hyps info in
-  let concl = Evd.evar_concl info in
-  let (hyps,concl) = Evarutil.clear_hyps_in_evi rdefs hyps concl ids in
-  let cleared_env = Environ.reset_with_named_context hyps env in
-  let cleared_concl = Evarutil.e_new_evar rdefs cleared_env concl in
-  let (cleared_evar,_) = Term.destEvar cleared_concl in
-  let cleared_goal = descendent gl cleared_evar in
-  rdefs := Evd.define gl.content cleared_concl !rdefs;
-  { subgoals = [cleared_goal] }
-
-let wrap_apply_to_hyp_and_dependent_on sign id f g =
-  try Environ.apply_to_hyp_and_dependent_on sign id f g 
-  with Environ.Hyp_not_found -> 
-    Util.error "No such assumption" 
-
-let check_typability env sigma c =
-  let _ = Typing.type_of env sigma c in () 
-
-let recheck_typability (what,id) env sigma t =
-  try check_typability env sigma t
-  with e when Errors.noncritical e ->
-    let s = match what with
-      | None -> "the conclusion"
-      | Some id -> "hypothesis "^(Names.string_of_id id) in
-    Util.error
-      ("The correctness of "^s^" relies on the body of "^(Names.string_of_id id))
-
-let remove_hyp_body env sigma id =
-  let sign =
-    wrap_apply_to_hyp_and_dependent_on (Environ.named_context_val env) id
-      (fun (_,c,t) _ ->
-	match c with
-	| None -> Util.error ((Names.string_of_id id)^" is not a local definition")
-	| Some c ->(id,None,t))
-      (fun (id',c,t as d) sign ->
-	(
-	  begin 
-	    let env = Environ.reset_with_named_context sign env in
-	    match c with
-	    | None ->  recheck_typability (Some id',id) env sigma t
-	    | Some b ->
-		let b' = mkCast (b,DEFAULTcast, t) in
-		recheck_typability (Some id',id) env sigma b'
-	  end;d))
-  in
-  Environ.reset_with_named_context sign env 
-
-
-let clear_body idents env rdefs gl info =
-  let info = content !rdefs gl in
-  let full_env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
-  let aux env id = 
-     let env' = remove_hyp_body env !rdefs id in
-       recheck_typability (None,id) env' !rdefs (Evd.evar_concl info);
-       env'
-  in
-  let new_env = 
-    List.fold_left aux full_env idents
-  in
-  let concl = Evd.evar_concl info in
-  let (defs',new_constr) = Evarutil.new_evar !rdefs new_env concl in
-  let (new_evar,_) = destEvar new_constr in
-  let new_goal = descendent gl new_evar in
-  rdefs := Evd.define gl.content new_constr defs';
-  { subgoals = [new_goal] }
-
-
-(*** Sensitive primitives ***)
-
-(* [concl] is the conclusion of the current goal *)
-let concl _ _ _ info =
-  Evd.evar_concl info
-
-(* [hyps] is the [named_context_val] representing the hypotheses
-   of the current goal *)
-let hyps _ _ _ info =
-  Evd.evar_hyps info
-
-(* [env] is the current [Environ.env] containing both the 
-   environment in which the proof is ran, and the goal hypotheses *)
-let env env _ _ _ = env
-
-(* [defs] is the [Evd.evar_map] at the current evaluation point *)
-let defs _ rdefs _ _ =
-  !rdefs
-
-(* Cf mli for more detailed comment.
-    [null], [plus], [here] and [here_list] use internal exception [UndefinedHere]
-    to communicate whether or not the value is defined in the particular context. *)
-exception UndefinedHere
-(* no handler: this should never be allowed to reach toplevel *)
-let null _ _ _ _ = raise UndefinedHere
-
-let plus s1 s2 env rdefs goal info =
-  try s1 env rdefs goal info
-  with UndefinedHere -> s2 env rdefs goal info
-
-(* Equality of two goals *)
-let equal { content = e1 } { content = e2 } = e1 = e2
-
-let here goal value _ _ goal' _ =
-  if equal goal goal' then
-    value
-  else 
-    raise UndefinedHere
-
-(* arnaud: voir à la passer dans Util ? *)
-let rec list_mem_with eq x = function
-  | y::_ when eq x y -> true
-  | _::l -> list_mem_with eq x l
-  | [] -> false
-
-let here_list goals value _ _ goal' _ =
-  if list_mem_with equal goal' goals then
-    value
-  else
-    raise UndefinedHere
-
-
-(*** Conversion in goals ***)
-
-let convert_hyp check (id,b,bt as d) env rdefs gl info =
-  let sigma = !rdefs in
-  (* This function substitutes the new type and body definitions
-     in the appropriate variable when used with {!Environ.apply_hyps}. *)
-  let replace_function =
-    (fun _ (_,c,ct) _ ->
-       if check && not (Reductionops.is_conv env sigma bt ct) then
-	 Util.error ("Incorrect change of the type of "^(Names.string_of_id id));
-       if check && not (Option.Misc.compare (Reductionops.is_conv env sigma) b c) then
-	 Util.error ("Incorrect change of the body of "^(Names.string_of_id id));
-       d)
-  in
-  (* Modified named context. *)
-  let new_hyps = 
-    Environ.apply_to_hyp (hyps env rdefs gl info) id replace_function
-  in  
-  let new_env = Environ.reset_with_named_context new_hyps env in
-  let new_constr = 
-    Evarutil.e_new_evar rdefs new_env (concl env rdefs gl info)
-  in
-  let (new_evar,_) = Term.destEvar new_constr in
-  let new_goal = descendent gl new_evar in
-  rdefs := Evd.define gl.content new_constr !rdefs;
-  { subgoals = [new_goal] }
-  
-let convert_concl check cl' env rdefs gl info =
-  let sigma = !rdefs in
-  let cl = concl env rdefs gl info in
-  check_typability env sigma cl';
-  if (not check) || Reductionops.is_conv_leq env sigma cl' cl then
-    let new_constr = 
-      Evarutil.e_new_evar rdefs env cl' 
-    in
-    let (new_evar,_) = Term.destEvar new_constr in
-    let new_goal = descendent gl new_evar in
-    rdefs := Evd.define gl.content new_constr !rdefs;
-    { subgoals = [new_goal] }
-  else
-    Util.error "convert-concl rule passed non-converting term"
-
-
-(*** Bureaucracy in hypotheses ***)  
-
-(* Renames a hypothesis. *)
-let rename_hyp_sign id1 id2 sign =
-  Environ.apply_to_hyp_and_dependent_on sign id1
-    (fun (_,b,t) _ -> (id2,b,t))
-    (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d)
-let rename_hyp id1 id2 env rdefs gl info = 
-  let hyps = hyps env rdefs gl info in
-  if id1 <> id2 &&
-    List.mem id2 (Termops.ids_of_named_context (Environ.named_context_of_val hyps)) then
-       Util.error ((Names.string_of_id id2)^" is already used.");
-  let new_hyps = rename_hyp_sign id1 id2 hyps in
-  let new_env = Environ.reset_with_named_context new_hyps env in
-  let new_concl = Term.replace_vars [id1,mkVar id2] (concl env rdefs gl info) in
-  let new_subproof = Evarutil.e_new_evar rdefs new_env new_concl in
-  let new_subproof = Term.replace_vars [id2,mkVar id1] new_subproof in
-  let (new_evar,_) = Term.destEvar new_subproof in
-  let new_goal = descendent gl new_evar in
-  rdefs := Evd.define gl.content new_subproof !rdefs;
-  { subgoals = [new_goal] }
-
-(*** Additional functions ***)
-
-(* emulates List.map for functions of type 
-   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
-   new evar_map to next definition. *)
-(*This sort of construction actually works with any monad (here the State monade
-   in Haskell). There is a generic construction in Haskell called mapM.
-*)
-let rec list_map f l s = 
-  match l with
-  | [] -> ([],s)
-  | a::l -> let (a,s) = f s a in
-               let (l,s) = list_map f l s in
-	       (a::l,s)
-
-
-(* Layer to implement v8.2 tactic engine ontop of the new architecture. 
+(* Layer to implement v8.2 tactic engine ontop of the new architecture.
    Types are different from what they used to be due to a change of the
    internal types. *)
 module V82 = struct
 
   (* Old style env primitive *)
-  let env evars gl = 
-    let evi = content evars gl in
-    Evd.evar_env evi
-
-  (* For printing *)
-  let unfiltered_env evars gl = 
-    let evi = content evars gl in
-    Evd.evar_unfiltered_env evi
+  let env evars gl =
+    let evi = Evd.find evars gl in
+    Evd.evar_filtered_env evi
 
   (* Old style hyps primitive *)
   let hyps evars gl =
-    let evi = content evars gl in
+    let evi = Evd.find evars gl in
     Evd.evar_filtered_hyps evi
 
+  (* same as [hyps], but ensures that existential variables are
+     normalised. *)
+  let nf_hyps evars gl =
+    let hyps = Environ.named_context_of_val (hyps evars gl) in
+    Environ.val_of_named_context (Evarutil.nf_named_context_evar evars hyps)
+
   (* Access to ".evar_concl" *)
   let concl evars gl =
-    let evi = content evars gl in
+    let evi = Evd.find evars gl in
     evi.Evd.evar_concl
 
   (* Access to ".evar_extra" *)
   let extra evars gl =
-    let evi = content evars gl in
+    let evi = Evd.find evars gl in
     evi.Evd.evar_extra
 
-  (* Old style filtered_context primitive *)
-  let filtered_context evars gl =
-    let evi = content evars gl in
-    Evd.evar_filtered_context evi
-
   (* Old style mk_goal primitive *)
   let mk_goal evars hyps concl extra =
-    let evk = Evarutil.new_untyped_evar () in
-    let evi = { Evd.evar_hyps = hyps; 
-		     Evd.evar_concl = concl; 
-		     Evd.evar_filter = List.map (fun _ -> true) 
-	                                                        (Environ.named_context_of_val hyps);
-		     Evd.evar_body = Evd.Evar_empty; 
-		     Evd.evar_source = (Util.dummy_loc,Evd.GoalEvar);
-		     Evd.evar_candidates = None;
-		     Evd.evar_extra = extra }
+    (* A goal created that way will not be used by refine and will not
+       be shelved. It must not appear as a future_goal, so the future
+       goals are restored to their initial value after the evar is
+       created. *)
+    let prev_future_goals = Evd.future_goals evars in
+    let prev_principal_goal = Evd.principal_future_goal evars in
+    let evi = { Evd.evar_hyps = hyps;
+		Evd.evar_concl = concl;
+		Evd.evar_filter = Evd.Filter.identity;
+		Evd.evar_body = Evd.Evar_empty;
+		Evd.evar_source = (Loc.ghost,Evar_kinds.GoalEvar);
+		Evd.evar_candidates = None;
+		Evd.evar_extra = extra }
     in
     let evi = Typeclasses.mark_unresolvable evi in
-    let evars = Evd.add evars evk evi in
-    let ids = List.map Util.pi1 (Environ.named_context_of_val hyps) in
-    let inst = Array.of_list (List.map mkVar ids) in
+    let (evars, evk) = Evarutil.new_pure_evar_full evars evi in
+    let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in
+    let ctxt = Environ.named_context_of_val hyps in
+    let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in
     let ev = Term.mkEvar (evk,inst) in
-    (build evk, ev, evars)
-
-  (* Equality function on goals *)
-  let equal evars gl1 gl2 =
-    let evi1 = content evars gl1 in
-    let evi2 = content evars gl2 in
-    Evd.eq_evar_info evi1 evi2
-
-  (* Creates a dummy [goal sigma] for use in auto *)
-  let dummy_goal =
-    (* This goal seems to be marshalled somewhere. Therefore it cannot be 
-       marked unresolvable for typeclasses, as non-empty Store.t-s happen
-       to have functional content. *)
-    let evi = Evd.make_evar Environ.empty_named_context_val Term.mkProp in
-    let evk = Evarutil.new_untyped_evar () in
-    let sigma = Evd.add Evd.empty evk evi in
-    { Evd.it = build evk ; Evd.sigma = sigma }
-
-  (* Makes a goal out of an evar *)
-  let build = build
+    (evk, ev, evars)
 
   (* Instantiates a goal with an open term *)
-  let partial_solution sigma { content=evk } c =
+  let partial_solution sigma evk c =
+    (* Check that the goal itself does not appear in the refined term *)
+    let _ =
+      if not (Evarutil.occur_evar_upto sigma evk c) then ()
+      else Pretype_errors.error_occur_check Environ.empty_env sigma evk c
+    in
     Evd.define evk c sigma
-   
+
+  (* Instantiates a goal with an open term, using name of goal for evk' *)
+  let partial_solution_to sigma evk evk' c =
+    let id = Evd.evar_ident evk sigma in
+    Evd.rename evk' id (partial_solution sigma evk c)
+
   (* Parts of the progress tactical *)
   let same_goal evars1 gl1 evars2 gl2 =
-    let evi1 = content evars1 gl1 in
-    let evi2 = content evars2 gl2 in
+    let evi1 = Evd.find evars1 gl1 in
+    let evi2 = Evd.find evars2 gl2 in
     Term.eq_constr evi1.Evd.evar_concl evi2.Evd.evar_concl &&
     Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps
-      
+
   let weak_progress glss gls =
     match glss.Evd.it with
     | [ g ] -> not (same_goal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it)
@@ -548,41 +108,40 @@ module V82 = struct
   let progress glss gls =
     weak_progress glss gls
     (* spiwack: progress normally goes like this:
-    (Evd.progress_evar_map gls.Evd.sigma glss.Evd.sigma) || (weak_progress glss gls) 
+    (Evd.progress_evar_map gls.Evd.sigma glss.Evd.sigma) || (weak_progress glss gls)
        This is immensly slow in the current implementation. Maybe we could
        reimplement progress_evar_map with restricted folds like "fold_undefined",
        with a good implementation of them.
     *)
-      
-  (* Used for congruence closure and change *)
+
+  (* Used for congruence closure  *)
   let new_goal_with sigma gl extra_hyps =
-    let evi = content sigma gl in
+    let evi = Evd.find sigma gl in
     let hyps = evi.Evd.evar_hyps in
     let new_hyps =
       List.fold_right Environ.push_named_context_val extra_hyps hyps in
-    let extra_filter = List.map (fun _ -> true) extra_hyps in
-    let new_filter = extra_filter @ evi.Evd.evar_filter in
+    let filter = evi.Evd.evar_filter in
+    let new_filter = Evd.Filter.extend (List.length extra_hyps) filter in
     let new_evi =
       { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in
     let new_evi = Typeclasses.mark_unresolvable new_evi in
-    let evk = Evarutil.new_untyped_evar () in
-    let new_sigma = Evd.add Evd.empty evk new_evi in
-    { Evd.it = build evk ; sigma = new_sigma }
+    let (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in
+    { Evd.it = evk ; sigma = new_sigma; }
 
   (* Used by the compatibility layer and typeclasses *)
   let nf_evar sigma gl =
-    let evi = content sigma gl in
+    let evi = Evd.find sigma gl in
     let evi = Evarutil.nf_evar_info sigma evi in
-    let sigma = Evd.add sigma gl.content evi in
-    (gl,sigma)
+    let sigma = Evd.add sigma gl evi in
+    (gl, sigma)
 
   (* Goal represented as a type, doesn't take into account section variables *)
-  let abstract_type sigma gl = 
+  let abstract_type sigma gl =
     let (gl,sigma) = nf_evar sigma gl in
     let env = env sigma gl in
     let genv = Global.env () in
-    let is_proof_var decl = 
-      try ignore (Environ.lookup_named (Util.pi1 decl) genv); false 
+    let is_proof_var decl =
+      try ignore (Environ.lookup_named (Util.pi1 decl) genv); false
       with Not_found -> true in
     Environ.fold_named_context_reverse (fun t decl ->
 					  if is_proof_var decl then
diff --git a/proofs/goal.mli b/proofs/goal.mli
index b7b20272..a00a95a2 100644
--- a/proofs/goal.mli
+++ b/proofs/goal.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,12 +8,7 @@
 
 (* This module implements the abstract interface to goals *)
 
-type goal
-
-(* spiwack: this primitive is not extremely brilliant. It may be a good
-    idea to define goals and proof views in the same file to avoid this
-    sort of communication pipes. But I find it heavy. *)
-val build : Evd.evar -> goal 
+type goal = Evar.t
 
 (* Gives a unique identifier to each goal. The identifier is
    guaranteed to contain no space. *)
@@ -25,155 +20,6 @@ val get_by_uid : string -> goal
 (* Debugging help *)
 val pr_goal : goal -> Pp.std_ppcmds
 
-(* [advance sigma g] returns [Some g'] if [g'] is undefined and 
-    is the current avatar of [g] (for instance [g] was changed by [clear]
-    into [g']). It returns [None] if [g] has been (partially) solved. *)
-open Store.Field
-val advance : Evd.evar_map -> goal -> goal option
-
-
-(*** Goal tactics ***)
-
-
-(* Goal tactics are [subgoal sensitive]-s *)
-type subgoals = private { subgoals: goal list }
-
-(* Goal sensitive values *)
-type +'a sensitive
-
-(* evaluates a goal sensitive value in a given goal (knowing the current evar_map). *)
-val eval : 'a sensitive -> Environ.env -> Evd.evar_map -> goal -> 'a * Evd.evar_map
-
-(* monadic bind on sensitive expressions *)
-val bind : 'a sensitive -> ('a -> 'b sensitive) -> 'b sensitive
-
-(* monadic return on sensitive expressions *)
-val return : 'a -> 'a sensitive
-
-
-(* interpretation of "open" constr *)
-(* spiwack: it is a wrapper around [Constrintern.interp_open_constr]. 
-    In an ideal world, this could/should be the other way round.
-    As of now, though, it seems at least quite useful to build tactics. *)
-val interp_constr : Topconstr.constr_expr -> Term.constr sensitive
-
-(* Type of constr with holes used by refine. *)
-type refinable
-
-module Refinable : sig
-  type t = refinable 
-  type handle
-
-  val make : (handle -> Term.constr sensitive) -> refinable sensitive
-  val make_with : (handle -> (Term.constr*'a) sensitive) -> (refinable*'a) sensitive
-
-  val mkEvar : handle -> Environ.env -> Term.types -> Term.constr sensitive
-
-  (* [with_type c typ] constrains term [c] to have type [typ].  *)
-  val with_type : Term.constr -> Term.types -> Term.constr sensitive
-
-  val resolve_typeclasses : ?filter:(Evd.hole_kind -> bool) -> ?split:bool -> ?fail:bool -> unit -> unit sensitive
-
-
-  (* [constr_of_raw h check_type resolve_classes] is a pretyping function.
-      The [check_type] argument asks whether the term should have the same
-      type as the conclusion. [resolve_classes] is a flag on pretyping functions
-      which, if set to true, calls the typeclass resolver.
-      The principal argument is a [glob_constr] which is then pretyped in the
-      context of a term, the remaining evars are registered to the handle.
-      It is the main component of the toplevel refine tactic.*)
-  val constr_of_raw : 
-    handle -> bool -> bool -> Glob_term.glob_constr -> Term.constr sensitive
-
-  (* [constr_of_open_constr h check_type] transforms an open constr into a 
-     goal-sensitive constr, adding the undefined variables to the set of subgoals.
-     If [check_type] is true, the term is coerced to the conclusion of the goal.
-     It allows to do refinement with already-built terms with holes.
-  *)
-  val constr_of_open_constr : handle -> bool -> Evd.open_constr -> Term.constr sensitive
-
-end
-
-(* [refine t] takes a refinable term and use it as a partial proof for current
-    goal. *)
-val refine : refinable -> subgoals sensitive
-
-
-(*** Cleaning  goals ***)
-
-(* Implements the [clear] tactic *)
-val clear : Names.identifier list -> subgoals sensitive
-
-(* Implements the [clearbody] tactic *)
-val clear_body : Names.identifier list -> subgoals sensitive
-
-
-(*** Conversion in goals ***)
-
-(* Changes an hypothesis of the goal with a convertible type and body.
-   Checks convertibility if the boolean argument is true. *)
-val convert_hyp : bool -> Term.named_declaration -> subgoals sensitive
-
-(* Changes the conclusion of the goal with a convertible type and body.
-   Checks convertibility if the boolean argument is true. *)
-val convert_concl : bool -> Term.constr -> subgoals sensitive
-
-(*** Bureaucracy in hypotheses ***)
-
-(* Renames a hypothesis. *)
-val rename_hyp : Names.identifier -> Names.identifier -> subgoals sensitive
-
-(*** Sensitive primitives ***)
-
-(* [concl] is the conclusion of the current goal *)
-val concl : Term.constr sensitive
-
-(* [hyps] is the [named_context_val] representing the hypotheses
-   of the current goal *)
-val hyps : Environ.named_context_val sensitive
-
-(* [env] is the current [Environ.env] containing both the 
-   environment in which the proof is ran, and the goal hypotheses *)
-val env : Environ.env sensitive
-
-(* [defs] is the [Evd.evar_map] at the current evaluation point *)
-val defs : Evd.evar_map sensitive
-
-(* These four functions serve as foundation for the goal sensitive part
-    of the tactic monad (see Proofview).
-    [here] is a special sort of [return]: [here g a] is the value [a], but
-    does not have any value (it raises an exception) if evaluated in
-    any other goal than [g].
-    [here_list] is the same, except with a list of goals rather than a single one.
-    [plus a b] is the same as [a] if [a] is defined in the current goal, otherwise
-    it is [b]. Effectively it's defined in the goals where [a] and [b] are defined.
-    [null] is defined in no goal. (it is a neutral element for [plus]). *)
-(* spiwack: these primitives are a bit hackish, but I couldn't find another way
-    to pass information between goals, like for an intro tactic which gives to
-    each goal the name of the variable it introduce.
-    In pratice, in my experience, the primitives given in Proofview (in terms of
-    [here] and [plus]) are sufficient to define any tactics, hence these might
-    be another example of communication primitives between Goal and Proofview.
-    Still, I can't see a way to prevent using the Proofview primitive to read
-    a goal sensitive value out of its valid context. *)
-val null : 'a sensitive
-
-val plus : 'a sensitive -> 'a sensitive -> 'a sensitive 
-
-val here : goal -> 'a -> 'a sensitive 
-
-val here_list : goal list -> 'a -> 'a sensitive 
-
-(*** Additional functions ***)
-
-(* emulates List.map for functions of type 
-   [Evd.evar_map -> 'a -> 'b * Evd.evar_map] on lists of type 'a, by propagating
-   new evar_map to next definition *)
-val list_map : (Evd.evar_map -> 'a -> 'b * Evd.evar_map) -> 
-                        'a list -> 
-                        Evd.evar_map -> 
-                        'b list *Evd.evar_map
-
 (* Layer to implement v8.2 tactic engine ontop of the new architecture. 
    Types are different from what they used to be due to a change of the
    internal types. *)
@@ -182,20 +28,18 @@ module V82 : sig
   (* Old style env primitive *)
   val env : Evd.evar_map -> goal -> Environ.env
 
-  (* For printing *)
-  val unfiltered_env : Evd.evar_map -> goal -> Environ.env
-
   (* Old style hyps primitive *)
   val hyps : Evd.evar_map -> goal -> Environ.named_context_val
 
+  (* same as [hyps], but ensures that existential variables are
+     normalised. *)
+  val nf_hyps : Evd.evar_map -> goal -> Environ.named_context_val
+
   (* Access to ".evar_concl" *)
   val concl : Evd.evar_map -> goal -> Term.constr
 
   (* Access to ".evar_extra" *)
-  val extra : Evd.evar_map -> goal -> Store.t
-
-  (* Old style filtered_context primitive *)
-  val filtered_context : Evd.evar_map -> goal -> Sign.named_context
+  val extra : Evd.evar_map -> goal -> Evd.Store.t
 
   (* Old style mk_goal primitive, returns a new goal with corresponding 
        hypotheses and conclusion, together with a term which is precisely
@@ -203,25 +47,16 @@ module V82 : sig
   val mk_goal : Evd.evar_map -> 
                          Environ.named_context_val ->
                          Term.constr ->
-                         Store.t ->
+                         Evd.Store.t ->
                          goal * Term.constr * Evd.evar_map
 
-  (* Equality function on goals *)
-  val equal : Evd.evar_map -> goal -> goal -> bool
-
-  (* Creates a dummy [goal sigma] for use in auto *)
-  val dummy_goal : goal Evd.sigma
-
-  (* Makes a goal out of an evar *)
-  (* spiwack: used by [Proofview.init], not entirely clean probably, but it is
-      the only way I could think of to preserve compatibility with previous Coq
-      stuff. *)
-  val build : Evd.evar -> goal 
-
-
   (* Instantiates a goal with an open term *)
   val partial_solution : Evd.evar_map -> goal -> Term.constr -> Evd.evar_map
-   
+
+  (* Instantiates a goal with an open term, reusing name of goal for
+     second goal *)
+  val partial_solution_to : Evd.evar_map -> goal -> goal -> Term.constr -> Evd.evar_map
+
   (* Principal part of the weak-progress tactical *)
   val weak_progress : goal list Evd.sigma -> goal Evd.sigma -> bool
    
@@ -232,7 +67,7 @@ module V82 : sig
   val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool
 
  (* Used for congruence closure *)
-  val new_goal_with : Evd.evar_map -> goal -> Sign.named_context -> goal Evd.sigma
+  val new_goal_with : Evd.evar_map -> goal -> Context.named_context -> goal Evd.sigma
 
   (* Used by the compatibility layer and typeclasses *)
   val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map
diff --git a/proofs/logic.ml b/proofs/logic.ml
index 52ca0e00..53f8093e 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -1,37 +1,34 @@
 (************************************************************************)
 (*  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 Names
 open Nameops
-open Evd
 open Term
+open Vars
+open Context
 open Termops
-open Sign
 open Environ
 open Reductionops
-open Inductive
 open Inductiveops
 open Typing
 open Proof_type
-open Typeops
 open Type_errors
 open Retyping
-open Evarutil
-open Tacexpr
+open Misctypes
 
 type refiner_error =
 
   (* Errors raised by the refiner *)
   | BadType of constr * constr * constr
-  | UnresolvedBindings of name list
+  | UnresolvedBindings of Name.t list
   | CannotApply of constr * constr
   | NotWellTyped of constr
   | NonLinearProof of constr
@@ -39,31 +36,39 @@ type refiner_error =
 
   (* Errors raised by the tactics *)
   | IntroNeedsProduct
-  | DoesNotOccurIn of constr * identifier
+  | DoesNotOccurIn of constr * Id.t
+  | NoSuchHyp of Id.t
 
 exception RefinerError of refiner_error
 
 open Pretype_errors
 
-let rec catchable_exception = function
-  | Loc.Exc_located(_,e) -> catchable_exception e
-  | LtacLocated(_,e) -> catchable_exception e
-  | Util.UserError _ | TypeError _ | PretypeError (_,_,TypingError _)
+(** FIXME: this is quite brittle. Why not accept any PretypeError? *)
+let is_typing_error = function
+| UnexpectedType (_, _) | NotProduct _
+| VarNotFound _ | TypingError _ -> true
+| _ -> false
+
+let is_unification_error = function
+| CannotUnify _ | CannotUnifyLocal _| CannotGeneralize _
+| NoOccurrenceFound _ | CannotUnifyBindingType _
+| ActualTypeNotCoercible _ | UnifOccurCheck _
+| CannotFindWellTypedAbstraction _ | WrongAbstractionType _
+| UnsolvableImplicit _| AbstractionOverMeta _
+| UnsatisfiableConstraints _ -> true
+| _ -> false
+
+let catchable_exception = function
+  | Errors.UserError _ | TypeError _
   | RefinerError _ | Indrec.RecursionSchemeError _
-  | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _)
+  | Nametab.GlobalizationError _
   (* reduction errors *)
-  | Tacred.ReductionTacticError _ 
-  (* unification errors *)
-  | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
-		   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
-		   |CannotFindWellTypedAbstraction _|OccurCheck _
-		   |UnsolvableImplicit _|AbstractionOverMeta _)) -> true
-  | Typeclasses_errors.TypeClassError
-      (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
+  | Tacred.ReductionTacticError _ -> true
+  (* unification and typing errors *)
+  | PretypeError(_,_, e) -> is_unification_error e || is_typing_error e 
   | _ -> false
 
-let error_no_such_hypothesis id =
-  error ("No such hypothesis: " ^ string_of_id id ^ ".")
+let error_no_such_hypothesis id = raise (RefinerError (NoSuchHyp id))
 
 (* Tells if the refiner should check that the submitted rules do not
    produce invalid subgoals *)
@@ -75,13 +80,13 @@ let with_check = Flags.with_option check
 let apply_to_hyp sign id f =
   try apply_to_hyp sign id f
   with Hyp_not_found ->
-    if !check then error "No such assumption."
+    if !check then error_no_such_hypothesis id
     else sign
 
 let apply_to_hyp_and_dependent_on sign id f g =
   try apply_to_hyp_and_dependent_on sign id f g
   with Hyp_not_found ->
-    if !check then error "No such assumption."
+    if !check then error_no_such_hypothesis id
     else sign
 
 let check_typability env sigma c =
@@ -96,41 +101,17 @@ let check_typability env sigma c =
    (instead of iterating on the list of identifier to be removed, which
    forces the user to give them in order). *)
 
-let clear_hyps sigma ids sign cl =
+let clear_hyps env sigma ids sign cl =
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
-  let (hyps,concl) = Evarutil.clear_hyps_in_evi evdref sign cl ids in
-  (hyps,concl, !evdref)
+  let (hyps,cl) = Evarutil.clear_hyps_in_evi env evdref sign cl ids in
+  (hyps, cl, !evdref)
 
-(* The ClearBody tactic *)
+let clear_hyps2 env sigma ids sign t cl =
+  let evdref = ref (Evd.create_goal_evar_defs sigma) in
+  let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in
+  (hyps, t, cl, !evdref)
 
-let recheck_typability (what,id) env sigma t =
-  try check_typability env sigma t
-  with e when Errors.noncritical e ->
-    let s = match what with
-      | None -> "the conclusion"
-      | Some id -> "hypothesis "^(string_of_id id) in
-    error
-      ("The correctness of "^s^" relies on the body of "^(string_of_id id))
-
-let remove_hyp_body env sigma id =
-  let sign =
-    apply_to_hyp_and_dependent_on (named_context_val env) id
-      (fun (_,c,t) _ ->
-	match c with
-	| None -> error ((string_of_id id)^" is not a local definition.")
-	| Some c ->(id,None,t))
-      (fun (id',c,t as d) sign ->
-	(if !check then
-	  begin
-	    let env = reset_with_named_context sign env in
-	    match c with
-	    | None ->  recheck_typability (Some id',id) env sigma t
-	    | Some b ->
-		let b' = mkCast (b,DEFAULTcast, t) in
-		recheck_typability (Some id',id) env sigma b'
-	  end;d))
-  in
-  reset_with_named_context sign env
+(* The ClearBody tactic *)
 
 (* Reordering of the context *)
 
@@ -139,36 +120,36 @@ let remove_hyp_body env sigma id =
 (* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *)
 (* reculees par rapport aux autres (faire le contraire!) *)
 
-let mt_q = (Idmap.empty,[])
+let mt_q = (Id.Map.empty,[])
 let push_val y = function
     (_,[] as q) -> q
-  | (m, (x,l)::q) -> (m, (x,Idset.add y l)::q)
+  | (m, (x,l)::q) -> (m, (x,Id.Set.add y l)::q)
 let push_item x v (m,l) =
-  (Idmap.add x v m, (x,Idset.empty)::l)
-let mem_q x (m,_) = Idmap.mem x m
-let rec find_q x (m,q) =
-  let v = Idmap.find x m in
-  let m' = Idmap.remove x m in
+  (Id.Map.add x v m, (x,Id.Set.empty)::l)
+let mem_q x (m,_) = Id.Map.mem x m
+let find_q x (m,q) =
+  let v = Id.Map.find x m in
+  let m' = Id.Map.remove x m in
   let rec find accs acc = function
       [] -> raise Not_found
     | [(x',l)] ->
-        if x=x' then ((v,Idset.union accs l),(m',List.rev acc))
+        if Id.equal x x' then ((v,Id.Set.union accs l),(m',List.rev acc))
         else raise Not_found
     | (x',l as i)::((x'',l'')::q as itl) ->
-        if x=x' then
-          ((v,Idset.union accs l),
-           (m',List.rev acc@(x'',Idset.add x (Idset.union l l''))::q))
-        else find (Idset.union l accs) (i::acc) itl in
-  find Idset.empty [] q
+        if Id.equal x x' then
+          ((v,Id.Set.union accs l),
+           (m',List.rev acc@(x'',Id.Set.add x (Id.Set.union l l''))::q))
+        else find (Id.Set.union l accs) (i::acc) itl in
+  find Id.Set.empty [] q
 
 let occur_vars_in_decl env hyps d =
-  if Idset.is_empty hyps then false else
+  if Id.Set.is_empty hyps then false else
     let ohyps = global_vars_set_of_decl env d in
-    Idset.exists (fun h -> Idset.mem h ohyps) hyps
+    Id.Set.exists (fun h -> Id.Set.mem h ohyps) hyps
 
 let reorder_context env sign ord =
-  let ords = List.fold_right Idset.add ord Idset.empty in
-  if List.length ord <> Idset.cardinal ords then
+  let ords = List.fold_right Id.Set.add ord Id.Set.empty in
+  if not (Int.equal (List.length ord) (Id.Set.cardinal ords)) then
     error "Order list has duplicates";
   let rec step ord expected ctxt_head moved_hyps ctxt_tail =
     match ord with
@@ -179,16 +160,16 @@ let reorder_context env sign ord =
             errorlabstrm "reorder_context"
               (str "Cannot move declaration " ++ pr_id top ++ spc() ++
               str "before " ++
-              prlist_with_sep pr_spc pr_id
-                (Idset.elements (Idset.inter h
+              pr_sequence pr_id
+                (Id.Set.elements (Id.Set.inter h
                   (global_vars_set_of_decl env d))));
           step ord' expected ctxt_head mh (d::ctxt_tail)
       | _ ->
           (match ctxt_head with
             | [] -> error_no_such_hypothesis (List.hd ord)
             | (x,_,_ as d) :: ctxt ->
-                if Idset.mem x expected then
-                  step ord (Idset.remove x expected)
+                if Id.Set.mem x expected then
+                  step ord (Id.Set.remove x expected)
                     ctxt (push_item x d moved_hyps) ctxt_tail
                 else
                   step ord expected
@@ -204,8 +185,8 @@ let reorder_val_context env sign ord =
 let check_decl_position env sign (x,_,_ as d) =
   let needed = global_vars_set_of_decl env d in
   let deps = dependency_closure env (named_context_of_val sign) needed in
-  if List.mem x deps then
-    error ("Cannot create self-referring hypothesis "^string_of_id x);
+  if Id.List.mem x deps then
+    error ("Cannot create self-referring hypothesis "^Id.to_string x);
   x::deps
 
 (* Auxiliary functions for primitive MOVE tactic
@@ -216,11 +197,18 @@ let check_decl_position env sign (x,_,_ as d) =
  * on the right side [right] if [toleft=false].
  * If [with_dep] then dependent hypotheses are moved accordingly. *)
 
+let move_location_eq m1 m2 = match m1, m2 with
+| MoveAfter id1, MoveAfter id2 -> Id.equal id1 id2
+| MoveBefore id1, MoveBefore id2 -> Id.equal id1 id2
+| MoveLast, MoveLast -> true
+| MoveFirst, MoveFirst -> true
+| _ -> false
+
 let rec get_hyp_after h = function
   | [] -> error_no_such_hypothesis h
   | (hyp,_,_) :: right ->
-      if hyp = h then
-	match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd false
+      if Id.equal hyp h then
+	match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst
       else
        get_hyp_after h right
 
@@ -228,11 +216,14 @@ let split_sign hfrom hto l =
   let rec splitrec left toleft = function
     | [] -> error_no_such_hypothesis hfrom
     | (hyp,c,typ) as d :: right ->
-      	if hyp = hfrom then
-	  (left,right,d, toleft or hto = MoveToEnd true)
+      	if Id.equal hyp hfrom then
+	  (left,right,d, toleft || move_location_eq hto MoveLast)
       	else
-	  splitrec (d::left)
-	    (toleft or hto = MoveAfter hyp or hto = MoveBefore hyp)
+          let is_toleft = match hto with
+          | MoveAfter h' | MoveBefore h' -> Id.equal hyp h'
+          | _ -> false
+          in
+	  splitrec (d::left) (toleft || is_toleft)
 	    right
   in
     splitrec [] false l
@@ -242,7 +233,7 @@ let hyp_of_move_location = function
   | MoveBefore id -> id
   | _ -> assert false
 
-let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
+let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto =
   let env = Global.env() in
   let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) =
     if toleft
@@ -251,25 +242,25 @@ let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto =
   in
   let rec moverec first middle = function
     | [] ->
-	if match hto with MoveToEnd _ -> false | _ -> true then
+	if match hto with MoveFirst | MoveLast -> false | _ -> true then
 	  error_no_such_hypothesis (hyp_of_move_location hto);
 	List.rev first @ List.rev middle
-    | (hyp,_,_) :: _ as right when hto = MoveBefore hyp ->
+    | (hyp,_,_) :: _ as right when move_location_eq hto (MoveBefore hyp) ->
 	List.rev first @ List.rev middle @ right
     | (hyp,_,_) as d :: right ->
 	let (first',middle') =
       	  if List.exists (test_dep d) middle then
-	    if with_dep & hto <> MoveAfter hyp then
+	    if not (move_location_eq hto (MoveAfter hyp)) then
 	      (first, d::middle)
             else
 	      errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++
-	        pr_move_location pr_id hto ++
+	        Miscprint.pr_move_location pr_id hto ++
 	        str (if toleft then ": it occurs in " else ": it depends on ")
 	        ++ pr_id hyp ++ str ".")
           else
 	    (d::first, middle)
 	in
-      	if hto = MoveAfter hyp then
+      	if move_location_eq hto (MoveAfter hyp) then
 	  List.rev first' @ List.rev middle' @ right
       	else
 	  moverec first' middle' right
@@ -291,6 +282,9 @@ let rename_hyp id1 id2 sign =
     (fun (_,b,t) _ -> (id2,b,t))
     (fun d _ -> map_named_declaration (replace_vars [id1,mkVar id2]) d)
 
+(**********************************************************************)
+
+
 (************************************************************************)
 (************************************************************************)
 (* Implementation of the logical rules *)
@@ -308,21 +302,34 @@ let collect_meta_variables c =
     | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc
     | Cast(c,_,_) -> collrec deep acc c
     | (App _| Case _) -> fold_constr (collrec deep) acc c
+    | Proj (_, c) -> collrec deep acc c
     | _ -> fold_constr (collrec true) acc c
   in
   List.rev (collrec false [] c)
 
 let check_meta_variables c =
-  if not (list_distinct (collect_meta_variables c)) then
+  if not (List.distinct_f Int.compare (collect_meta_variables c)) then
     raise (RefinerError (NonLinearProof c))
 
 let check_conv_leq_goal env sigma arg ty conclty =
-  if !check & not (is_conv_leq env sigma ty conclty) then
-    raise (RefinerError (BadType (arg,ty,conclty)))
+  if !check then
+    let evm, b = Reductionops.infer_conv env sigma ty conclty in
+      if b then evm 
+      else raise (RefinerError (BadType (arg,ty,conclty)))
+  else sigma
+
+exception Stop of constr list
+let meta_free_prefix a =
+  try
+    let _ = Array.fold_left (fun acc a -> 
+      if occur_meta a then raise (Stop acc)
+      else a :: acc) [] a
+    in a
+  with Stop acc -> Array.rev_of_list acc
 
 let goal_type_of env sigma c =
   if !check then type_of env sigma c
-  else Retyping.get_type_of ~refresh:true env sigma c
+  else Retyping.get_type_of env sigma c
 
 let rec mk_refgoals sigma goal goalacc conclty trm =
   let env = Goal.V82.env sigma goal in
@@ -330,62 +337,77 @@ let rec mk_refgoals sigma goal goalacc conclty trm =
   let mk_goal hyps concl =
     Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal)
   in
-  match kind_of_term trm with
-    | Meta _ ->
+    if (not !check) && not (occur_meta trm) then
+      let t'ty = Retyping.get_type_of env sigma trm in
+      let sigma = check_conv_leq_goal env sigma trm t'ty conclty in
+        (goalacc,t'ty,sigma,trm)
+    else
+      match kind_of_term trm with
+      | Meta _ ->
 	let conclty = nf_betaiota sigma conclty in
 	  if !check && occur_meta conclty then
 	    raise (RefinerError (MetaInType conclty));
 	  let (gl,ev,sigma) = mk_goal hyps conclty in
 	  gl::goalacc, conclty, sigma, ev
 
-    | Cast (t,k, ty) ->
+      | Cast (t,k, ty) ->
 	check_typability env sigma ty;
-	check_conv_leq_goal env sigma trm ty conclty;
+        let sigma = check_conv_leq_goal env sigma trm ty conclty in
 	let res = mk_refgoals sigma goal goalacc ty t in
-	(** we keep the casts (in particular VMcast) except
+	(** we keep the casts (in particular VMcast and NATIVEcast) except
 	    when they are annotating metas *)
 	if isMeta t then begin
-	  assert (k <> VMcast);
+	  assert (k != VMcast && k != NATIVEcast);
 	  res
 	end else
-	  let (gls,cty,sigma,trm) = res in
-	  (gls,cty,sigma,mkCast(trm,k,ty))
+	  let (gls,cty,sigma,ans) = res in
+          let ans = if ans == t then trm else mkCast(ans,k,ty) in
+	  (gls,cty,sigma,ans)
 
-    | App (f,l) ->
+      | App (f,l) ->
 	let (acc',hdty,sigma,applicand) =
-	  match kind_of_term f with
-	    | Ind _ | Const _
-		when (isInd f or has_polymorphic_type (destConst f)) ->
-		(* Sort-polymorphism of definition and inductive types *)
-		goalacc,
-                type_of_global_reference_knowing_conclusion env sigma f conclty,
-		sigma, f
-	    | _ ->
-		mk_hdgoals sigma goal goalacc f
+	  if is_template_polymorphic env f then
+	    let sigma, ty = 
+	      (* Template sort-polymorphism of definition and inductive types *)
+	      type_of_global_reference_knowing_conclusion env sigma f conclty
+	    in
+	      goalacc, ty, sigma, f
+	  else
+	    mk_hdgoals sigma goal goalacc f
 	in
-	let (acc'',conclty',sigma, args) =
-	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
-	check_conv_leq_goal env sigma trm conclty' conclty;
-        (acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args))
-
-    | Case (ci,p,c,lf) ->
+	let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in
+        let sigma = check_conv_leq_goal env sigma trm conclty' conclty in
+        let ans = if applicand == f && args == l then trm else Term.mkApp (applicand, args) in
+        (acc'',conclty',sigma, ans)
+
+      | Proj (p,c) ->
+	let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in
+	let c = mkProj (p, c') in
+	let ty = get_type_of env sigma c in
+	  (acc',ty,sigma,c)
+
+      | Case (ci,p,c,lf) ->
 	let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in
-	check_conv_leq_goal env sigma trm conclty' conclty;
+	let sigma = check_conv_leq_goal env sigma trm conclty' conclty in
 	let (acc'',sigma, rbranches) =
-	  array_fold_left2
+	  Array.fold_left2
             (fun (lacc,sigma,bacc) ty fi ->
 	       let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc))
             (acc',sigma,[]) lbrty lf
 	in
-	(acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches)))
+        let lf' = Array.rev_of_list rbranches in
+        let ans =
+          if p' == p && c' == c && Array.equal (==) lf' lf then trm
+          else Term.mkCase (ci,p',c',lf')
+        in
+	(acc'',conclty',sigma, ans)
 
-    | _ ->
+      | _ ->
 	if occur_meta trm then
-	  anomaly "refiner called with a meta in non app/case subterm";
-
-      	let t'ty = goal_type_of env sigma trm in
-	check_conv_leq_goal env sigma trm t'ty conclty;
-        (goalacc,t'ty,sigma, trm)
+	  anomaly (Pp.str "refiner called with a meta in non app/case subterm");
+	let t'ty = goal_type_of env sigma trm in
+	let sigma = check_conv_leq_goal env sigma trm t'ty conclty in
+          (goalacc,t'ty,sigma, trm)
 
 (* Same as mkREFGOALS but without knowing the type of the term. Therefore,
  * Metas should be casted. *)
@@ -407,44 +429,57 @@ and mk_hdgoals sigma goal goalacc trm =
 
     | App (f,l) ->
 	let (acc',hdty,sigma,applicand) =
-	  if isInd f or isConst f
-	     & not (array_exists occur_meta l) (* we could be finer *)
+	  if is_template_polymorphic env f
 	  then
-	   (goalacc,type_of_global_reference_knowing_parameters env sigma f l,sigma,f)
+	    let l' = meta_free_prefix l in	      
+	   (goalacc,type_of_global_reference_knowing_parameters env sigma f l',sigma,f)
 	  else mk_hdgoals sigma goal goalacc f
 	in
-	let (acc'',conclty',sigma, args) =
-	  mk_arggoals sigma goal acc' hdty (Array.to_list l) in
-	(acc'',conclty',sigma, Term.mkApp (applicand, Array.of_list args))
+	let ((acc'',conclty',sigma), args) = mk_arggoals sigma goal acc' hdty l in
+        let ans = if applicand == f && args == l then trm else Term.mkApp (applicand, args) in
+	(acc'',conclty',sigma, ans)
 
     | Case (ci,p,c,lf) ->
 	let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in
 	let (acc'',sigma,rbranches) =
-	  array_fold_left2
+	  Array.fold_left2
             (fun (lacc,sigma,bacc) ty fi ->
 	       let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc))
             (acc',sigma,[]) lbrty lf
 	in
-	(acc'',conclty',sigma, Term.mkCase (ci,p',c',Array.of_list (List.rev rbranches)))
+	let lf' = Array.rev_of_list rbranches in
+	let ans =
+          if p' == p && c' == c && Array.equal (==) lf' lf then trm
+          else Term.mkCase (ci,p',c',lf')
+	in
+	(acc'',conclty',sigma, ans)
+
+    | Proj (p,c) ->
+         let (acc',cty,sigma,c') = mk_hdgoals sigma goal goalacc c in
+	 let c = mkProj (p, c') in
+         let ty = get_type_of env sigma c in
+	   (acc',ty,sigma,c)
 
     | _ ->
 	if !check && occur_meta trm then
-	  anomaly "refine called with a dependent meta";
+	  anomaly (Pp.str "refine called with a dependent meta");
 	goalacc, goal_type_of env sigma trm, sigma, trm
 
-and mk_arggoals sigma goal goalacc funty = function
-  | [] -> goalacc,funty,sigma, []
-  | harg::tlargs as allargs ->
-      let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in
-      match kind_of_term t with
-	| Prod (_,c1,b) ->
-	    let (acc',hargty,sigma,arg') = mk_refgoals sigma goal goalacc c1 harg in
-	    let (acc'',fty, sigma', args) =
-	      mk_arggoals sigma goal acc' (subst1 harg b) tlargs in
-	    (acc'',fty,sigma',arg'::args)
-	| LetIn (_,c1,_,b) ->
-	    mk_arggoals sigma goal goalacc (subst1 c1 b) allargs
-	| _ -> raise (RefinerError (CannotApply (t,harg)))
+and mk_arggoals sigma goal goalacc funty allargs =
+  let foldmap (goalacc, funty, sigma) harg =
+    let t = whd_betadeltaiota (Goal.V82.env sigma goal) sigma funty in
+    let rec collapse t = match kind_of_term t with
+    | LetIn (_, c1, _, b) -> collapse (subst1 c1 b)
+    | _ -> t
+    in
+    let t = collapse t in
+    match kind_of_term t with
+    | Prod (_, c1, b) ->
+      let (acc, hargty, sigma, arg) = mk_refgoals sigma goal goalacc c1 harg in
+      (acc, subst1 harg b, sigma), arg
+    | _ -> raise (RefinerError (CannotApply (t, harg)))
+  in
+  Array.smartfoldmap foldmap (goalacc, funty, sigma) allargs
 
 and mk_casegoals sigma goal goalacc p c =
   let env = Goal.V82.env sigma goal in
@@ -452,24 +487,23 @@ and mk_casegoals sigma goal goalacc p c =
   let (acc'',pt,sigma,p') = mk_hdgoals sigma goal acc' p in
   let indspec =
     try Tacred.find_hnf_rectype env sigma ct
-    with Not_found -> anomaly "mk_casegoals" in
-  let (lbrty,conclty) =
-    type_case_branches_with_names env indspec p c in
+    with Not_found -> anomaly (Pp.str "mk_casegoals") in
+  let (lbrty,conclty) = type_case_branches_with_names env indspec p c in
   (acc'',lbrty,conclty,sigma,p',c')
 
 
-let convert_hyp sign sigma (id,b,bt as d) =
+let convert_hyp check sign sigma (id,b,bt as d) =
   let env = Global.env() in
   let reorder = ref [] in
   let sign' =
     apply_to_hyp sign id
       (fun _ (_,c,ct) _ ->
         let env = Global.env_of_context sign in
-        if !check && not (is_conv env sigma bt ct) then
-	  error ("Incorrect change of the type of "^(string_of_id id)^".");
-        if !check && not (Option.Misc.compare (is_conv env sigma) b c) then
-	  error ("Incorrect change of the body of "^(string_of_id id)^".");
-       if !check then reorder := check_decl_position env sign d;
+        if check && not (is_conv env sigma bt ct) then
+	  error ("Incorrect change of the type of "^(Id.to_string id)^".");
+        if check && not (Option.equal (is_conv env sigma) b c) then
+	  error ("Incorrect change of the body of "^(Id.to_string id)^".");
+       if check then reorder := check_decl_position env sign d;
        d) in
   reorder_val_context env sign' !reorder
 
@@ -488,50 +522,31 @@ let prim_refiner r sigma goal =
   in
   match r with
     (* Logical rules *)
-    | Intro id ->
-    	if !check && mem_named_context id (named_context_of_val sign) then
-	  error ("Variable " ^ string_of_id id ^ " is already declared.");
-        (match kind_of_term (strip_outer_cast cl) with
-	   | Prod (_,c1,b) ->
-	       let (sg,ev,sigma) = mk_goal (push_named_context_val (id,None,c1) sign)
-			  (subst1 (mkVar id) b) in
-               let sigma = 
-		 Goal.V82.partial_solution sigma goal (mkNamedLambda id c1 ev) in
-	       ([sg], sigma)
-	   | LetIn (_,c1,t1,b) ->
-	       let (sg,ev,sigma) =
-		 mk_goal (push_named_context_val (id,Some c1,t1) sign)
-		   (subst1 (mkVar id) b) in
-	       let sigma = 
-		 Goal.V82.partial_solution sigma goal (mkNamedLetIn id c1 t1 ev) in
-	       ([sg], sigma)
-	   | _ ->
-	       raise (RefinerError IntroNeedsProduct))
-
     | Cut (b,replace,id,t) ->
+(*        if !check && not (Retyping.get_sort_of env sigma t) then*)
         let (sg1,ev1,sigma) = mk_goal sign (nf_betaiota sigma t) in
-	let sign,cl,sigma =
+	let sign,t,cl,sigma =
 	  if replace then
 	    let nexthyp = get_hyp_after id (named_context_of_val sign) in
-	    let sign,cl,sigma = clear_hyps sigma [id] sign cl in
-	    move_hyp true false ([],(id,None,t),named_context_of_val sign)
+	    let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in
+	    move_hyp false ([],(id,None,t),named_context_of_val sign)
 	      nexthyp,
-	      cl,sigma
+	      t,cl,sigma
 	  else
             (if !check && mem_named_context id (named_context_of_val sign) then
-	      error ("Variable " ^ string_of_id id ^ " is already declared.");
-	     push_named_context_val (id,None,t) sign,cl,sigma) in
+	      error ("Variable " ^ Id.to_string id ^ " is already declared.");
+	     push_named_context_val (id,None,t) sign,t,cl,sigma) in
         let (sg2,ev2,sigma) = 
 	  Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in
-	let oterm = Term.mkApp (Term.mkNamedLambda id t ev2 , [| ev1 |]) in
-	let sigma = Goal.V82.partial_solution sigma goal oterm in
+	let oterm = Term.mkApp (mkNamedLambda id t ev2 , [| ev1 |]) in
+	let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in
         if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma)
 
     | FixRule (f,n,rest,j) ->
      	let rec check_ind env k cl =
           match kind_of_term (strip_outer_cast cl) with
             | Prod (na,c1,b) ->
-            	if k = 1 then
+            	if Int.equal k 1 then
 		  try
 		    fst (find_inductive env sigma c1)
 		  with Not_found ->
@@ -540,31 +555,30 @@ let prim_refiner r sigma goal =
 		  check_ind (push_rel (na,None,c1) env) (k-1) b
             | _ -> error "Not enough products."
 	in
-	let (sp,_) = check_ind env n cl in
-	let firsts,lasts = list_chop j rest in
+	let ((sp,_),u) = check_ind env n cl in
+	let firsts,lasts = List.chop j rest in
 	let all = firsts@(f,n,cl)::lasts in
      	let rec mk_sign sign = function
 	  | (f,n,ar)::oth ->
-	      let (sp',_)  = check_ind env n ar in
-	      if not (sp=sp') then
+	      let ((sp',_),u')  = check_ind env n ar in
+	      if not (eq_mind sp sp') then
 		error ("Fixpoints should be on the same " ^
 		       "mutual inductive declaration.");
 	      if !check && mem_named_context f (named_context_of_val sign) then
 		error
-		  ("Name "^string_of_id f^" already used in the environment");
+		  ("Name "^Id.to_string f^" already used in the environment");
 	      mk_sign (push_named_context_val (f,None,ar) sign) oth
 	  | [] ->
-	      Goal.list_map (fun sigma (_,_,c) ->
-				                   let (gl,ev,sig')=
-				                     Goal.V82.mk_goal sigma sign c
-						             (Goal.V82.extra sigma goal)
-						   in ((gl,ev),sig'))
-		                              all sigma
+	      Evd.Monad.List.map (fun (_,_,c) sigma ->
+                let gl,ev,sig' =
+                  Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
+                (gl,ev),sig')
+              all sigma
 	in
 	let (gls_evs,sigma) =  mk_sign sign all in
 	let (gls,evs) = List.split gls_evs in
 	let ids = List.map pi1 all in
-	let evs = List.map (Term.subst_vars (List.rev ids)) evs in
+	let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
 	let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in
 	let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
 	let typarray = Array.of_list (List.map pi3 all) in
@@ -585,7 +599,7 @@ let prim_refiner r sigma goal =
 		  error ("All methods must construct elements " ^
 			  "in coinductive types.")
 	in
-	let firsts,lasts = list_chop j others in
+	let firsts,lasts = List.chop j others in
 	let all = firsts@(f,cl)::lasts in
      	List.iter (fun (_,c) -> check_is_coind env c) all;
         let rec mk_sign sign = function
@@ -596,18 +610,17 @@ let prim_refiner r sigma goal =
               with
               |	Not_found ->
                   mk_sign (push_named_context_val (f,None,ar) sign) oth)
-	  | [] -> Goal.list_map (fun sigma(_,c) ->
-				                       let (gl,ev,sigma) =
-				                         Goal.V82.mk_goal sigma sign c
-							   (Goal.V82.extra sigma goal)
-						       in
-				                       ((gl,ev),sigma))
-	                                             all sigma                                      
+	  | [] -> 
+              Evd.Monad.List.map (fun (_,c) sigma ->
+                let gl,ev,sigma =
+                  Goal.V82.mk_goal sigma sign c (Goal.V82.extra sigma goal) in
+                (gl,ev),sigma)
+              all sigma
      	in
 	let (gls_evs,sigma) =  mk_sign sign all in
 	let (gls,evs) = List.split gls_evs in
 	let (ids,types) = List.split all in
-	let evs = List.map (Term.subst_vars (List.rev ids)) evs in
+	let evs = List.map (Vars.subst_vars (List.rev ids)) evs in
 	let funnames = Array.of_list (List.map (fun i -> Name i) ids) in
 	let typarray = Array.of_list types in
 	let bodies = Array.of_list evs in
@@ -622,87 +635,21 @@ let prim_refiner r sigma goal =
 	let sigma = Goal.V82.partial_solution sigma goal oterm in
 	  (sgl, sigma)
 
-    (* Conversion rules *)
-    | Convert_concl (cl',k) ->
-	check_typability env sigma cl';
-	if (not !check) || is_conv_leq env sigma cl' cl then
-          let (sg,ev,sigma) = mk_goal sign cl' in
-	  let ev = if k<>DEFAULTcast then mkCast(ev,k,cl) else ev in
-	  let sigma = Goal.V82.partial_solution sigma goal ev in
-          ([sg], sigma)
-	else
-	  error "convert-concl rule passed non-converting term"
-
-    | Convert_hyp (id,copt,ty) ->
-	let (gl,ev,sigma) = mk_goal (convert_hyp sign sigma (id,copt,ty)) cl in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
-	([gl], sigma)
-
     (* And now the structural rules *)
     | Thin ids ->
-	let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in
+        let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in
+	let (hyps,concl,nsigma) = clear_hyps env sigma ids sign cl in
 	let (gl,ev,sigma) =
 	  Goal.V82.mk_goal nsigma hyps concl (Goal.V82.extra nsigma goal)
 	in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
+	let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
 	  ([gl], sigma)
 
-    | ThinBody ids ->
-	let clear_aux env id =
-          let env' = remove_hyp_body env sigma id in
-            if !check then recheck_typability (None,id) env' sigma cl;
-            env'
-	in
-	let sign' = named_context_val (List.fold_left clear_aux env ids) in
-     	let (sg,ev,sigma) = mk_goal sign' cl in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
-     	  ([sg], sigma)
-
-    | Move (withdep, hfrom, hto) ->
+    | Move (hfrom, hto) ->
   	let (left,right,declfrom,toleft) =
 	  split_sign hfrom hto (named_context_of_val sign) in
   	let hyps' =
-	  move_hyp withdep toleft (left,declfrom,right) hto in
+	  move_hyp toleft (left,declfrom,right) hto in
 	let (gl,ev,sigma) = mk_goal hyps' cl in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
+	let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
   	  ([gl], sigma)
-
-    | Order ord ->
-        let hyps' = reorder_val_context env sign ord in
-	let (gl,ev,sigma) = mk_goal hyps' cl in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
-        ([gl], sigma)
-
-    | Rename (id1,id2) ->
-        if !check & id1 <> id2 &&
-	  List.mem id2 (ids_of_named_context (named_context_of_val sign)) then
-          error ((string_of_id id2)^" is already used.");
-        let sign' = rename_hyp id1 id2 sign in
-        let cl' = replace_vars [id1,mkVar id2] cl in
-	let (gl,ev,sigma) = mk_goal sign' cl' in
-	let ev = Term.replace_vars [(id2,mkVar id1)] ev in
-	let sigma = Goal.V82.partial_solution sigma goal ev in
-          ([gl], sigma)
-
-    | Change_evars ->
-	(* Normalises evars in goals. Used by instantiate. *)
-        let (goal,sigma) = Goal.V82.nf_evar sigma goal in
-	([goal],sigma)
-
-(************************************************************************)
-(************************************************************************)
-(* Extracting a proof term from the proof tree *)
-
-(* Util *)
-
-type variable_proof_status = ProofVar | SectionVar of identifier
-
-type proof_variable = name * variable_proof_status
-
-let proof_variable_index x =
-  let rec aux n = function
-    | (Name id,ProofVar)::l when x = id -> n
-    | _::l ->  aux (n+1) l
-    | [] -> raise Not_found
-  in
-  aux 1
diff --git a/proofs/logic.mli b/proofs/logic.mli
index 1044b59e..d034b73c 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.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,9 +8,7 @@
 
 open Names
 open Term
-open Sign
 open Evd
-open Environ
 open Proof_type
 
 (** This suppresses check done in [prim_refiner] for the tactic given in
@@ -32,10 +30,6 @@ val with_check    : tactic -> tactic
 
 val prim_refiner : prim_rule -> evar_map -> goal -> goal list * evar_map
 
-type proof_variable
-
-
-val proof_variable_index : identifier -> proof_variable list -> int
 
 (** {6 Refiner errors. } *)
 
@@ -43,7 +37,7 @@ type refiner_error =
 
   (*i Errors raised by the refiner i*)
   | BadType of constr * constr * constr
-  | UnresolvedBindings of name list
+  | UnresolvedBindings of Name.t list
   | CannotApply of constr * constr
   | NotWellTyped of constr
   | NonLinearProof of constr
@@ -51,8 +45,12 @@ type refiner_error =
 
   (*i Errors raised by the tactics i*)
   | IntroNeedsProduct
-  | DoesNotOccurIn of constr * identifier
+  | DoesNotOccurIn of constr * Id.t
+  | NoSuchHyp of Id.t
 
 exception RefinerError of refiner_error
 
 val catchable_exception : exn -> bool
+
+val convert_hyp : bool -> Environ.named_context_val -> evar_map ->
+  Context.named_declaration -> Environ.named_context_val
diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml
new file mode 100644
index 00000000..d509670e
--- /dev/null
+++ b/proofs/logic_monad.ml
@@ -0,0 +1,326 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This file defines the low-level monadic operations used by the
+    tactic monad. The monad is divided into two layers: a non-logical
+    layer which consists in operations which will not (or cannot) be
+    backtracked in case of failure (input/output or persistent state)
+    and a logical layer which handles backtracking, proof
+    manipulation, and any other effect which needs to backtrack. *)
+
+
+(** {6 Exceptions} *)
+
+
+(** To help distinguish between exceptions raised by the IO monad from
+    the one used natively by Coq, the former are wrapped in
+    [Exception].  It is only used internally so that [catch] blocks of
+    the IO monad would only catch exceptions raised by the [raise]
+    function of the IO monad, and not for instance, by system
+    interrupts. Also used in [Proofview] to avoid capturing exception
+    from the IO monad ([Proofview] catches errors in its compatibility
+    layer, and when lifting goal-level expressions). *)
+exception Exception of exn
+(** This exception is used to signal abortion in [timeout] functions. *)
+exception Timeout
+(** This exception is used by the tactics to signal failure by lack of
+    successes, rather than some other exceptions (like system
+    interrupts). *)
+exception TacticFailure of exn
+
+let _ = Errors.register_handler begin function
+  | Timeout -> Errors.errorlabstrm "Some timeout function" (Pp.str"Timeout!")
+  | Exception e -> Errors.print e
+  | TacticFailure e -> Errors.print e
+  | _ -> Pervasives.raise Errors.Unhandled
+end
+
+(** {6 Non-logical layer} *)
+
+(** The non-logical monad is a simple [unit -> 'a] (i/o) monad. The
+    operations are simple wrappers around corresponding usual
+    operations and require little documentation. *)
+module NonLogical =
+struct
+
+  (* The functions in this module follow the pattern that they are
+     defined with the form [(); fun ()->...]. This is an optimisation
+     which signals to the compiler that the function is usually partially
+     applied up to the [();]. Without this annotation, partial
+     applications can be significantly slower.
+
+     Documentation of this behaviour can be found at:
+     https://ocaml.janestreet.com/?q=node/30 *)
+
+  include Monad.Make(struct
+    type 'a t = unit -> 'a
+
+    let return a = (); fun () -> a
+    let (>>=) a k = (); fun () -> k (a ()) ()
+    let (>>) a k = (); fun () -> a (); k ()
+    let map f a = (); fun () -> f (a ())
+  end)
+
+  type 'a ref = 'a Pervasives.ref
+
+  let ignore a = (); fun () -> ignore (a ())
+
+  let ref a = (); fun () -> Pervasives.ref a
+
+  (** [Pervasives.(:=)] *)
+  let (:=) r a = (); fun () -> r := a
+
+  (** [Pervasives.(!)] *)
+  let (!) = fun r -> (); fun () -> ! r
+
+  (** [Pervasives.raise]. Except that exceptions are wrapped with
+      {!Exception}. *)
+  let raise ?info = fun e -> (); fun () -> Exninfo.raise ?info (Exception e)
+
+  (** [try ... with ...] but restricted to {!Exception}. *)
+  let catch = fun s h -> ();
+    fun () -> try s ()
+      with Exception e as src ->
+        let (src, info) = Errors.push src in
+        h (e, info) ()
+
+  let read_line = fun () -> try Pervasives.read_line () with e ->
+    let (e, info) = Errors.push e in raise ~info e ()
+
+  let print_char = fun c -> (); fun () -> print_char c
+
+  (** {!Pp.pp}. The buffer is also flushed. *)
+  let print = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e ->
+    let (e, info) = Errors.push e in raise ~info e ()
+
+  let timeout = fun n t -> (); fun () ->
+    Control.timeout n t (Exception Timeout)
+
+  let make f = (); fun () ->
+    try f ()
+    with e when Errors.noncritical e ->
+      let (e, info) = Errors.push e in
+      Util.iraise (Exception e, info)
+
+  let run = fun x ->
+    try x () with Exception e as src ->
+      let (src, info) = Errors.push src in
+      Util.iraise (e, info)
+end
+
+(** {6 Logical layer} *)
+
+(** The logical monad is a backtracking monad on top of which is
+    layered a state monad (which is used to implement all of read/write,
+    read only, and write only effects). The state monad being layered on
+    top of the backtracking monad makes it so that the state is
+    backtracked on failure.
+
+    Backtracking differs from regular exception in that, writing (+)
+    for exception catching and (>>=) for bind, we require the
+    following extra distributivity laws:
+
+    x+(y+z) = (x+y)+z
+
+    zero+x = x
+
+    x+zero = x
+
+    (x+y)>>=k = (x>>=k)+(y>>=k) *)
+
+(** A view type for the logical monad, which is a form of list, hence
+    we can decompose it with as a list. *)
+type ('a, 'b) list_view =
+  | Nil of Exninfo.iexn
+  | Cons of 'a * 'b
+
+module type Param = sig
+
+  (** Read only *)
+  type e
+
+  (** Write only *)
+  type w
+
+  (** [w] must be a monoid *)
+  val wunit : w
+  val wprod : w -> w -> w
+
+  (** Read-write *)
+  type s
+
+  (** Update-only. Essentially a writer on [u->u]. *)
+  type u
+
+  (** [u] must be pointed. *)
+  val uunit : u
+
+end
+
+
+module Logical (P:Param) =
+struct
+
+  (** All three of environment, writer and state are coded as a single
+      state-passing-style monad.*)
+  type state = {
+    rstate : P.e;
+    ustate : P.u;
+    wstate : P.w;
+    sstate : P.s;
+  }
+
+  (** Double-continuation backtracking monads are reasonable folklore
+      for "search" implementations (including the Tac interactive
+      prover's tactics). Yet it's quite hard to wrap your head around
+      these.  I recommand reading a few times the "Backtracking,
+      Interleaving, and Terminating Monad Transformers" paper by
+      O. Kiselyov, C. Shan, D. Friedman, and A. Sabry.  The peculiar
+      shape of the monadic type is reminiscent of that of the
+      continuation monad transformer.
+
+      The paper also contains the rational for the [split] abstraction.
+
+      An explanation of how to derive such a monad from mathematical
+      principles can be found in "Kan Extensions for Program
+      Optimisation" by Ralf Hinze.
+
+      A somewhat concrete view is that the type ['a iolist] is, in fact
+      the impredicative encoding of the following stream type:
+
+      [type 'a _iolist' = Nil of exn | Cons of 'a*'a iolist'
+      and 'a iolist = 'a _iolist NonLogical.t]
+
+      Using impredicative encoding avoids intermediate allocation and
+      is, empirically, very efficient in Ocaml. It also has the
+      practical benefit that the monadic operation are independent of
+      the underlying monad, which simplifies the code and side-steps
+      the limited inlining of Ocaml.
+
+      In that vision, [bind] is simply [concat_map] (though the cps
+      version is significantly simpler), [plus] is concatenation, and
+      [split] is pattern-matching. *)
+  type rich_exn = Exninfo.iexn
+
+  type 'a iolist =
+      { iolist : 'r. (rich_exn -> 'r NonLogical.t) ->
+                     ('a -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) ->
+                     'r NonLogical.t }
+
+  include Monad.Make(struct
+    type 'a t = state -> ('a * state) iolist
+
+    let return x : 'a t = (); fun s ->
+      { iolist = fun nil cons -> cons (x, s) nil }
+
+    let (>>=) (m : 'a t) (f : 'a -> 'b t) : 'b t = (); fun s ->
+      let m = m s in
+      { iolist = fun nil cons ->
+        m.iolist nil (fun (x, s) next -> (f x s).iolist next cons) }
+
+    let (>>) (m : unit t) (f : 'a t) : 'a t = (); fun s ->
+      let m = m s in
+      { iolist = fun nil cons ->
+        m.iolist nil (fun ((), s) next -> (f s).iolist next cons) }
+
+    let map (f : 'a -> 'b) (m : 'a t) : 'b t = (); fun s ->
+      let m = m s in
+      { iolist = fun nil cons -> m.iolist nil (fun (x, s) next -> cons (f x, s) next) }
+
+  end)
+
+  let zero e : 'a t = (); fun s ->
+    { iolist = fun nil cons -> nil e }
+
+  let plus m1 m2 : 'a t = (); fun s ->
+    let m1 = m1 s in
+    { iolist = fun nil cons -> m1.iolist (fun e -> (m2 e s).iolist nil cons) cons }
+
+  let ignore (m : 'a t) : unit t = (); fun s ->
+    let m = m s in
+    { iolist = fun nil cons -> m.iolist nil (fun (_, s) next -> cons ((), s) next) }
+
+  let lift (m : 'a NonLogical.t) : 'a t = (); fun s ->
+    { iolist = fun nil cons -> NonLogical.(m >>= fun x -> cons (x, s) nil) }
+
+  (** State related *)
+
+  let get : P.s t = (); fun s ->
+    { iolist = fun nil cons -> cons (s.sstate, s) nil }
+
+  let set (sstate : P.s) : unit t = (); fun s ->
+    { iolist = fun nil cons -> cons ((), { s with sstate }) nil }
+
+  let modify (f : P.s -> P.s) : unit t = (); fun s ->
+    { iolist = fun nil cons -> cons ((), { s with sstate = f s.sstate }) nil }
+
+  let current : P.e t = (); fun s ->
+    { iolist = fun nil cons -> cons (s.rstate, s) nil }
+
+  let local (type a) (e:P.e) (m:a t) : a t = (); fun s ->
+    let m = m { s with rstate = e } in
+    { iolist = fun nil cons ->
+      m.iolist nil (fun (x,s') next -> cons (x,{s' with rstate=s.rstate}) next) }
+
+  let put (w : P.w) : unit t = (); fun s ->
+    { iolist = fun nil cons -> cons ((), { s with wstate = P.wprod s.wstate w }) nil }
+
+  let update (f : P.u -> P.u) : unit t = (); fun s ->
+    { iolist = fun nil cons -> cons ((), { s with ustate = f s.ustate }) nil }
+
+  (** List observation *)
+
+  let once (m : 'a t) : 'a t = (); fun s ->
+    let m = m s in
+    { iolist = fun nil cons -> m.iolist nil (fun x _ -> cons x nil) }
+
+  let break (f : rich_exn -> rich_exn option) (m : 'a t) : 'a t = (); fun s ->
+    let m = m s in
+    { iolist = fun nil cons ->
+      m.iolist nil (fun x next -> cons x (fun e -> match f e with None -> next e | Some e -> nil e))
+    }
+
+  (** For [reflect] and [split] see the "Backtracking, Interleaving,
+      and Terminating Monad Transformers" paper.  *)
+  type 'a reified = ('a, rich_exn -> 'a reified) list_view NonLogical.t
+
+  let rec reflect (m : 'a reified) : 'a iolist =
+    { iolist = fun nil cons ->
+      let next = function
+      | Nil e -> nil e
+      | Cons (x, l) -> cons x (fun e -> (reflect (l e)).iolist nil cons)
+      in
+      NonLogical.(m >>= next)
+    }
+
+  let split (m : 'a t) : ('a, rich_exn -> 'a t) list_view t = (); fun s ->
+    let m = m s in
+    let rnil e = NonLogical.return (Nil e) in
+    let rcons p l = NonLogical.return (Cons (p, l)) in
+    { iolist = fun nil cons ->
+      let open NonLogical in
+      m.iolist rnil rcons >>= begin function
+      | Nil e -> cons (Nil e, s) nil
+      | Cons ((x, s), l) ->
+        let l e = (); fun _ -> reflect (l e) in
+        cons (Cons (x, l), s) nil
+      end }
+
+  let run m r s =
+    let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in
+    let m = m s in
+    let rnil e = NonLogical.return (Nil e) in
+    let rcons (x, s) l =
+      let p = (x, s.sstate, s.wstate, s.ustate) in
+      NonLogical.return (Cons (p, l))
+    in
+    m.iolist rnil rcons
+
+  let repr x = x
+
+ end
diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli
new file mode 100644
index 00000000..ab729aff
--- /dev/null
+++ b/proofs/logic_monad.mli
@@ -0,0 +1,157 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This file defines the low-level monadic operations used by the
+    tactic monad. The monad is divided into two layers: a non-logical
+    layer which consists in operations which will not (or cannot) be
+    backtracked in case of failure (input/output or persistent state)
+    and a logical layer which handles backtracking, proof
+    manipulation, and any other effect which needs to backtrack. *)
+
+
+(** {6 Exceptions} *)
+
+
+(** To help distinguish between exceptions raised by the IO monad from
+    the one used natively by Coq, the former are wrapped in
+    [Exception].  It is only used internally so that [catch] blocks of
+    the IO monad would only catch exceptions raised by the [raise]
+    function of the IO monad, and not for instance, by system
+    interrupts. Also used in [Proofview] to avoid capturing exception
+    from the IO monad ([Proofview] catches errors in its compatibility
+    layer, and when lifting goal-level expressions). *)
+exception Exception of exn
+(** This exception is used to signal abortion in [timeout] functions. *)
+exception Timeout
+(** This exception is used by the tactics to signal failure by lack of
+    successes, rather than some other exceptions (like system
+    interrupts). *)
+exception TacticFailure of exn
+
+
+(** {6 Non-logical layer} *)
+
+(** The non-logical monad is a simple [unit -> 'a] (i/o) monad. The
+    operations are simple wrappers around corresponding usual
+    operations and require little documentation. *)
+module NonLogical : sig
+
+  include Monad.S
+
+  val ignore : 'a t -> unit t
+
+  type 'a ref
+
+  val ref : 'a -> 'a ref t
+  (** [Pervasives.(:=)] *)
+  val (:=) : 'a ref -> 'a -> unit t
+  (** [Pervasives.(!)] *)
+  val (!) : 'a ref -> 'a t
+
+  val read_line : string t
+  val print_char : char -> unit t
+  (** {!Pp.pp}. The buffer is also flushed. *)
+  val print : Pp.std_ppcmds -> unit t
+
+  (** [Pervasives.raise]. Except that exceptions are wrapped with
+      {!Exception}. *)
+  val raise : ?info:Exninfo.info -> exn -> 'a t
+  (** [try ... with ...] but restricted to {!Exception}. *)
+  val catch : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
+  val timeout : int -> 'a t -> 'a t
+
+  (** Construct a monadified side-effect. Exceptions raised by the argument are
+      wrapped with {!Exception}. *)
+  val make : (unit -> 'a) -> 'a t
+
+  (** [run] performs effects. *)
+  val run : 'a t -> 'a
+
+end
+
+
+(** {6 Logical layer} *)
+
+(** The logical monad is a backtracking monad on top of which is
+    layered a state monad (which is used to implement all of read/write,
+    read only, and write only effects). The state monad being layered on
+    top of the backtracking monad makes it so that the state is
+    backtracked on failure.
+
+    Backtracking differs from regular exception in that, writing (+)
+    for exception catching and (>>=) for bind, we require the
+    following extra distributivity laws:
+
+    x+(y+z) = (x+y)+z
+
+    zero+x = x
+
+    x+zero = x
+
+    (x+y)>>=k = (x>>=k)+(y>>=k) *)
+
+(** A view type for the logical monad, which is a form of list, hence
+    we can decompose it with as a list. *)
+type ('a, 'b) list_view =
+| Nil of Exninfo.iexn
+| Cons of 'a * 'b
+
+(** The monad is parametrised in the types of state, environment and
+    writer. *)
+module type Param = sig
+
+  (** Read only *)
+  type e
+
+  (** Write only *)
+  type w
+
+  (** [w] must be a monoid *)
+  val wunit : w
+  val wprod : w -> w -> w
+
+  (** Read-write *)
+  type s
+
+  (** Update-only. Essentially a writer on [u->u]. *)
+  type u
+
+  (** [u] must be pointed. *)
+  val uunit : u
+
+end
+
+module Logical (P:Param) : sig
+
+  include Monad.S
+
+  val ignore : 'a t -> unit t
+
+  val set : P.s -> unit t
+  val get : P.s t
+  val modify : (P.s -> P.s) -> unit t
+  val put : P.w -> unit t
+  val current : P.e t
+  val local : P.e -> 'a t -> 'a t
+  val update : (P.u -> P.u) -> unit t
+
+  val zero : Exninfo.iexn -> 'a t
+  val plus : 'a t -> (Exninfo.iexn -> 'a t) -> 'a t
+  val split : 'a t -> (('a,(Exninfo.iexn->'a t)) list_view) t
+  val once : 'a t -> 'a t
+  val break : (Exninfo.iexn -> Exninfo.iexn option) -> 'a t -> 'a t
+
+  val lift : 'a NonLogical.t -> 'a t
+
+  type 'a reified
+
+  val repr : 'a reified -> ('a, Exninfo.iexn -> 'a reified) list_view NonLogical.t
+
+  val run : 'a t -> P.e -> P.s -> ('a * P.s * P.w * P.u) reified
+
+end
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 77e7b324..fdc93bcb 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.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        *)
@@ -9,19 +9,9 @@
 open Pp
 open Util
 open Names
-open Nameops
-open Sign
-open Term
-open Declarations
 open Entries
 open Environ
 open Evd
-open Typing
-open Refiner
-open Tacexpr
-open Proof_type
-open Lib
-open Safe_typing
 
 let refining = Proof_global.there_are_pending_proofs
 let check_no_pending_proofs = Proof_global.check_no_pending_proof
@@ -35,58 +25,28 @@ let delete_proof = Proof_global.discard
 let delete_current_proof = Proof_global.discard_current
 let delete_all_proofs = Proof_global.discard_all
 
-let undo n =
-  let p = Proof_global.give_me_the_proof () in
-  let d = Proof.V82.depth p in
-  if n >= d then raise Proof.EmptyUndoStack;
-  for i = 1 to n do
-    Proof.undo p
-  done
-
-let current_proof_depth () =
-  try
-    let p = Proof_global.give_me_the_proof () in
-    Proof.V82.depth p
-  with Proof_global.NoCurrentProof -> -1
-
-(* [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d
-   is the depth of the focus stack). *)
-let undo_todepth n =
-  try
-    undo ((current_proof_depth ()) - n )
-  with Proof_global.NoCurrentProof  when n=0 -> ()
-
-let set_undo _ = ()
-let get_undo _ = None
-
-
-let start_proof id str hyps c ?init_tac ?compute_guard hook = 
+let start_proof (id : Id.t) str sigma hyps c ?init_tac terminator =
   let goals = [ (Global.env_of_context hyps , c) ] in
-  Proof_global.start_proof id str goals ?compute_guard hook;
-  let tac = match init_tac with
-   | Some tac -> Proofview.V82.tactic tac
-   | None -> Proofview.tclUNIT ()
-  in
-  try Proof_global.run_tactic tac
-  with reraise -> Proof_global.discard_current (); raise reraise
-
-let restart_proof () = undo_todepth 1
-
-let cook_proof hook =
-  let prf = Proof_global.give_me_the_proof () in
-  hook prf;
-  match Proof_global.close_proof () with
-  | (i,([e],cg,str,h)) -> (i,(e,cg,str,h))
-  | _ -> Util.anomaly "Pfedit.cook_proof: more than one proof term."
-
-let xml_cook_proof = ref (fun _ -> ())
-let set_xml_cook_proof f = xml_cook_proof := f
-
+  Proof_global.start_proof sigma id str goals terminator;
+  let env = Global.env () in
+  ignore (Proof_global.with_current_proof (fun _ p ->
+    match init_tac with
+    | None -> p,(true,[])
+    | Some tac -> Proof.run_tactic env tac p))
+
+let cook_this_proof p =
+  match p with
+  | { Proof_global.id;entries=[constr];persistence;universes } ->
+      (id,(constr,universes,persistence))
+  | _ -> Errors.anomaly ~label:"Pfedit.cook_proof" (Pp.str "more than one proof term.")
+
+let cook_proof () =
+  cook_this_proof (fst
+    (Proof_global.close_proof ~keep_body_ucst_sepatate:false (fun x -> x)))
 let get_pftreestate () =
   Proof_global.give_me_the_proof ()
 
 let set_end_tac tac =
-  let tac = Proofview.V82.tactic tac in
   Proof_global.set_endline_tactic tac
 
 let set_used_variables l =
@@ -96,25 +56,25 @@ let get_used_variables () =
 
 exception NoSuchGoal
 let _ = Errors.register_handler begin function
-  | NoSuchGoal -> Util.error "No such goal."
+  | NoSuchGoal -> Errors.error "No such goal."
   | _ -> raise Errors.Unhandled
 end
 let get_nth_V82_goal i =
   let p = Proof_global.give_me_the_proof () in
-  let { it=goals ; sigma = sigma } = Proof.V82.subgoals p in
+  let { it=goals ; sigma = sigma; } = Proof.V82.subgoals p in
   try
-    { it=(List.nth goals (i-1)) ; sigma=sigma }
+          { it=(List.nth goals (i-1)) ; sigma=sigma; }
   with Failure _ -> raise NoSuchGoal
     
 let get_goal_context_gen i =
   try
-    let { it=goal ; sigma=sigma } =  get_nth_V82_goal i in
-    (sigma, Refiner.pf_env { it=goal ; sigma=sigma })
-  with Proof_global.NoCurrentProof -> Util.error "No focused proof."
+let { it=goal ; sigma=sigma; } =  get_nth_V82_goal i in
+(sigma, Refiner.pf_env { it=goal ; sigma=sigma; })
+  with Proof_global.NoCurrentProof -> Errors.error "No focused proof."
 
 let get_goal_context i =
   try get_goal_context_gen i
-  with NoSuchGoal -> Util.error "No such goal."
+  with NoSuchGoal -> Errors.error "No such goal."
 
 let get_current_goal_context () =
   try get_goal_context_gen 1
@@ -125,29 +85,44 @@ let get_current_goal_context () =
 
 let current_proof_statement () =
   match Proof_global.V82.get_current_initial_conclusions () with
-    | (id,([concl],strength,hook)) -> id,strength,concl,hook
-    | _ -> Util.anomaly "Pfedit.current_proof_statement: more than one statement"
+    | (id,([concl],strength)) -> id,strength,concl
+    | _ -> Errors.anomaly ~label:"Pfedit.current_proof_statement" (Pp.str "more than one statement")
 
-let solve_nth ?(with_end_tac=false) gi tac = 
+let solve ?with_end_tac gi info_lvl tac pr =
   try 
-    let tac = Proofview.V82.tactic tac in
-    let tac = if with_end_tac then 
-                Proof_global.with_end_tac tac
-              else
-		tac
+    let tac = match with_end_tac with
+      | None -> tac
+      | Some etac -> Proofview.tclTHEN tac etac in
+    let tac = match info_lvl with
+      | None -> tac
+      | Some _ -> Proofview.Trace.record_info_trace tac
     in
-    Proof_global.run_tactic (Proofview.tclFOCUS gi gi tac) 
-  with 
-    | Proof_global.NoCurrentProof  -> Util.error "No focused proof"
-    | Proofview.IndexOutOfRange | Failure "list_chop" -> 
-	let msg = str "No such goal: " ++ int gi ++ str "." in
-	Util.errorlabstrm "" msg
+    let tac = match gi with
+      | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac
+      | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac
+      | Vernacexpr.SelectAll -> tac
+      | Vernacexpr.SelectAllParallel ->
+          Errors.anomaly(str"SelectAllParallel not handled by Stm")
+    in
+    let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in
+    let () =
+      match info_lvl with
+      | None -> ()
+      | Some i -> Pp.ppnl (hov 0 (Proofview.Trace.pr_info ~lvl:i info))
+    in
+    (p,status)
+  with
+    | Proof_global.NoCurrentProof  -> Errors.error "No focused proof"
+    | CList.IndexOutOfRange ->
+        match gi with
+	| Vernacexpr.SelectNth i -> let msg = str "No such goal: " ++ int i ++ str "." in
+	                            Errors.errorlabstrm "" msg
+        | _ -> assert false
 
-let by = solve_nth 1
+let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac)
 
 let instantiate_nth_evar_com n com = 
-  let pf = Proof_global.give_me_the_proof () in
-  Proof.V82.instantiate_evar n com pf
+  Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.instantiate_evar n com p)
 
 
 (**********************************************************************)
@@ -157,21 +132,29 @@ open Decl_kinds
 
 let next = let n = ref 0 in fun () -> incr n; !n
 
-let build_constant_by_tactic id sign typ tac =
-  start_proof id (Global,Proof Theorem) sign typ (fun _ _ -> ());
+let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac =
+  let evd = Evd.from_env ~ctx Environ.empty_env in
+  start_proof id goal_kind evd sign typ (fun _ -> ());
   try
-    by tac;
-    let _,(const,_,_,_) = cook_proof (fun _ -> ()) in
+    let status = by tac in
+    let _,(const,univs,_) = cook_proof () in
     delete_current_proof ();
-    const
+    const, status, univs
   with reraise ->
+    let reraise = Errors.push reraise in
     delete_current_proof ();
-    raise reraise
+    iraise reraise
 
-let build_by_tactic env typ tac =
-  let id = id_of_string ("temporary_proof"^string_of_int (next())) in
+let build_by_tactic env ctx ?(poly=false) typ tac =
+  let id = Id.of_string ("temporary_proof"^string_of_int (next())) in
   let sign = val_of_named_context (named_context env) in
-  (build_constant_by_tactic id sign typ tac).const_entry_body
+  let gk = Global, poly, Proof Theorem in
+  let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in
+  let ce = Term_typing.handle_entry_side_effects env ce in
+  let (cb, ctx), se = Future.force ce.const_entry_body in
+  assert(Declareops.side_effects_is_empty se);
+  assert(Univ.ContextSet.is_empty ctx);
+  cb, status, univs
 
 (**********************************************************************)
 (* Support for resolution of evars in tactic interpretation, including
@@ -181,13 +164,19 @@ let implicit_tactic = ref None
 
 let declare_implicit_tactic tac = implicit_tactic := Some tac
 
-let solve_by_implicit_tactic env sigma (evk,args) =
+let clear_implicit_tactic () = implicit_tactic := None
+
+let solve_by_implicit_tactic env sigma evk =
   let evi = Evd.find_undefined sigma evk in
   match (!implicit_tactic, snd (evar_source evk sigma)) with
-  | Some tac, (ImplicitArg _ | QuestionMark _)
+  | Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _)
       when
-	Sign.named_context_equal (Environ.named_context_of_val evi.evar_hyps)
+	Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps)
 	(Environ.named_context env) ->
-      (try build_by_tactic env evi.evar_concl (tclCOMPLETE tac)
+      let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in
+      (try
+        let (ans, _, _) = 
+	  build_by_tactic env (Evd.evar_universe_context sigma) evi.evar_concl tac in
+        ans
        with e when Logic.catchable_exception e -> raise Exit)
   | _ -> raise Exit
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index ec083e41..edbc18a3 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -1,20 +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 Util
-open Pp
+open Loc
 open Names
 open Term
-open Sign
 open Environ
 open Decl_kinds
-open Tacmach
-open Tacexpr
 
 (** Several proofs can be opened simultaneously but at most one is
    focused at some time. The following functions work by side-effect
@@ -38,7 +34,7 @@ val check_no_pending_proofs : unit -> unit
 (** [delete_proof name] deletes proof of name [name] or fails if no proof
     has this name *)
 
-val delete_proof : identifier located -> unit
+val delete_proof : Id.t located -> unit
 
 (** [delete_current_proof ()] deletes current focused proof or fails if
     no proof is focused *)
@@ -50,21 +46,6 @@ val delete_current_proof : unit -> unit
 val delete_all_proofs : unit -> unit
 
 (** {6 ... } *)
-(** [undo n] undoes the effect of the last [n] tactics applied to the
-    current proof; it fails if no proof is focused or if the ``undo''
-    stack is exhausted *)
-
-val undo : int -> unit
-
-(** [undo_todepth n] resets the proof to its nth step (does [undo (d-n)] where d
-   is the depth of the undo stack). *)
-val undo_todepth : int -> unit 
-
-(** Returns the depth of the current focused proof stack, this is used
-   to put informations in coq prompt (in emacs mode). *)
-val current_proof_depth: unit -> int
-
-(** {6 ... } *)
 (** [start_proof s str env t hook tac] starts a proof of name [s] and
     conclusion [t]; [hook] is optionally a function to be applied at
     proof end (e.g. to declare the built constructions as a coercion
@@ -75,14 +56,9 @@ val current_proof_depth: unit -> int
 type lemma_possible_guards = Proof_global.lemma_possible_guards
 
 val start_proof :
-  identifier -> goal_kind -> named_context_val -> constr ->
-  ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> 
-  declaration_hook -> unit
-
-(** [restart_proof ()] restarts the current focused proof from the beginning
-   or fails if no proof is focused *)
-
-val restart_proof : unit -> unit
+  Id.t -> goal_kind -> Evd.evar_map -> named_context_val -> constr ->
+  ?init_tac:unit Proofview.tactic ->
+  Proof_global.proof_terminator -> unit
 
 (** {6 ... } *)
 (** [cook_proof opacity] turns the current proof (assumed completed) into
@@ -90,17 +66,18 @@ val restart_proof : unit -> unit
     it fails if there is no current proof of if it is not completed;
     it also tells if the guardness condition has to be inferred. *)
 
-val cook_proof : (Proof.proof -> unit) ->
-  identifier *
-    (Entries.definition_entry * lemma_possible_guards * goal_kind *
-     declaration_hook)
+val cook_this_proof :
+    Proof_global.proof_object ->
+  (Id.t *
+    (Entries.definition_entry * Proof_global.proof_universes * goal_kind))
 
-(** To export completed proofs to xml *)
-val set_xml_cook_proof : (goal_kind * Proof.proof -> unit) -> unit
+val cook_proof : unit ->
+  (Id.t *
+    (Entries.definition_entry * Proof_global.proof_universes * goal_kind))
 
 (** {6 ... } *)
-(** [get_Proof.proof ()] returns the current focused pending proof or
-   raises [UserError "no focused proof"] *)
+(** [get_pftreestate ()] returns the current focused pending proof.
+   @raise NoCurrentProof if there is no pending proof. *)
 
 val get_pftreestate : unit -> Proof.proof
 
@@ -117,61 +94,76 @@ val get_current_goal_context : unit -> Evd.evar_map * env
 (** [current_proof_statement] *)
 
 val current_proof_statement :
-  unit -> identifier * goal_kind * types * declaration_hook
+  unit -> Id.t * goal_kind * types
 
 (** {6 ... } *)
 (** [get_current_proof_name ()] return the name of the current focused
     proof or failed if no proof is focused *)
 
-val get_current_proof_name : unit -> identifier
+val get_current_proof_name : unit -> Id.t
 
 (** [get_all_proof_names ()] returns the list of all pending proof names.
     The first name is the current proof, the other names may come in
     any order. *)
 
-val get_all_proof_names : unit -> identifier list
+val get_all_proof_names : unit -> Id.t list
 
 (** {6 ... } *)
 (** [set_end_tac tac] applies tactic [tac] to all subgoal generate
-    by [solve_nth] *)
+    by [solve] *)
 
-val set_end_tac : tactic -> unit
+val set_end_tac : Tacexpr.raw_tactic_expr -> unit
 
 (** {6 ... } *)
 (** [set_used_variables l] declares that section variables [l] will be
     used in the proof *)
-val set_used_variables : identifier list -> unit
-val get_used_variables : unit -> Sign.section_context option
+val set_used_variables : Id.t list -> Context.section_context
+val get_used_variables : unit -> Context.section_context option
 
 (** {6 ... } *)
-(** [solve_nth n tac] applies tactic [tac] to the [n]th subgoal of the
-   current focused proof or raises a UserError if no proof is focused or
-   if there is no [n]th subgoal *)
+(** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th
+    subgoal of the current focused proof or raises a [UserError] if no
+    proof is focused or if there is no [n]th subgoal. [solve SelectAll
+    tac] applies [tac] to all subgoals. *)
 
-val solve_nth : ?with_end_tac:bool -> int -> tactic -> unit
+val solve : ?with_end_tac:unit Proofview.tactic ->
+      Vernacexpr.goal_selector -> int option -> unit Proofview.tactic ->
+      Proof.proof -> Proof.proof*bool
 
 (** [by tac] applies tactic [tac] to the 1st subgoal of the current
-   focused proof or raises a UserError if there is no focused proof or
-   if there is no more subgoals *)
+    focused proof or raises a UserError if there is no focused proof or
+    if there is no more subgoals.
+    Returns [false] if an unsafe tactic has been used. *)
 
-val by : tactic -> unit
+val by : unit Proofview.tactic -> bool
 
 (** [instantiate_nth_evar_com n c] instantiate the [n]th undefined
    existential variable of the current focused proof by [c] or raises a
    UserError if no proof is focused or if there is no such [n]th
    existential variable *)
 
-val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit
+val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit
 
-(** [build_by_tactic typ tac] returns a term of type [typ] by calling [tac] *)
+(** [build_by_tactic typ tac] returns a term of type [typ] by calling
+    [tac]. The return boolean, if [false] indicates the use of an unsafe
+    tactic. *)
 
-val build_constant_by_tactic : identifier -> named_context_val -> types -> tactic ->
-  Entries.definition_entry
-val build_by_tactic : env -> types -> tactic -> constr
+val build_constant_by_tactic :
+  Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind ->
+  types -> unit Proofview.tactic -> 
+  Entries.definition_entry * bool * Evd.evar_universe_context
+
+val build_by_tactic : env -> Evd.evar_universe_context -> ?poly:polymorphic -> 
+  types -> unit Proofview.tactic -> 
+  constr * bool * Evd.evar_universe_context
 
 (** Declare the default tactic to fill implicit arguments *)
 
-val declare_implicit_tactic : tactic -> unit
+val declare_implicit_tactic : unit Proofview.tactic -> unit
+
+(** To remove the default tactic *)
+val clear_implicit_tactic : unit -> unit
 
 (* Raise Exit if cannot solve *)
-val solve_by_implicit_tactic : env -> Evd.evar_map -> existential -> constr
+(* FIXME: interface: it may incur some new universes etc... *)
+val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr
diff --git a/proofs/proof.ml b/proofs/proof.ml
index bd185b99..828f9fa7 100644
--- a/proofs/proof.ml
+++ b/proofs/proof.ml
@@ -1,16 +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        *)
 (************************************************************************)
 
 (* Module defining the last essential tiles of interactive proofs.
-   The features of the Proof module are undoing and focusing.
-   A proof is a mutable object, it contains a proofview, and some information
-   to be able to undo actions, and to unfocus the current view. All three
-   of these being meant to evolve.
+   A proof deals with the focusing commands (including the braces and bullets),
+   the shelf (see the [shelve] tactic) and given up goal (see the [give_up]
+   tactic). A proof is made of the following:
    - Proofview: a proof is primarily the data of the current view.
      That which is shown to the user (as a remainder, a proofview
      is mainly the logical state of the proof, together with the
@@ -23,24 +22,27 @@
      the focus kind is actually stored inside the condition). To unfocus, one
      needs to know the focus kind, and the condition (for instance "no condition" or
      the proof under focused must be complete) must be met.
-   - Undo: since proofviews and focus stacks are immutable objects, 
-     it could suffice to hold the previous states, to allow to return to the past.
-     However, we also allow other modules to do actions that can be undone.
-     Therefore the undo stack stores action to be ran to undo.
+   - Shelf: A list of goals which have been put aside during the proof. They can be
+     retrieved with the [Unshelve] command, or solved by side effects
+   - Given up goals: as long as there is a given up goal, the proof is not completed.
+     Given up goals cannot be retrieved, the user must go back where the tactic
+     [give_up] was run and solve the goal there.
 *)
 
-open Term
+open Util
 
 type _focus_kind = int
 type 'a focus_kind = _focus_kind
 type focus_info = Obj.t
+type reason = NotThisWay | AlreadyNoFocus
 type unfocusable =
-  | Cannot of exn
+  | Cannot of reason
   | Loose
   | Strict
-type _focus_condition = 
-    (_focus_kind -> Proofview.proofview -> unfocusable) *
-    (_focus_kind -> bool)
+type _focus_condition =
+  | CondNo       of bool * _focus_kind
+  | CondDone     of bool * _focus_kind
+  | CondEndStack of        _focus_kind (* loose_end is false here *)
 type 'a focus_condition = _focus_condition
 
 let next_kind = ref 0
@@ -49,107 +51,71 @@ let new_focus_kind () =
   incr next_kind;
   r
 
-(* Auxiliary function to define conditions. *)
-let check kind1 kind2 = kind1=kind2
-
 (* To be authorized to unfocus one must meet the condition prescribed by
     the action which focused.*)
 (* spiwack: we could consider having a list of authorized focus_kind instead
     of just one, if anyone needs it *)
-(* [no_cond] only checks that the unfocusing command uses the right
-    [focus_kind]. *)
-
-module Cond = struct
-  (* first attempt at an algebra of condition *)
-  (* semantics:
-     - [Cannot] means that the condition is not met
-     - [Strict] that the condition is met
-     - [Loose] that the condition is not quite met
-       but authorises to unfocus provided a condition
-       of a previous focus on the stack is (strictly)
-       met. [Loose] focuses are those, like bullets,
-       which do not have a closing command and
-       are hence closed by unfocusing actions unrelated
-       to their focus_kind.
-  *)
-  let bool e b =
-    if b then fun _ _ -> Strict
-    else fun _ _ -> Cannot e
-  let loose c k p = match c k p with
-    | Cannot _ -> Loose
-    | c -> c
-  let cloose l c =
-    if l then loose c
-    else c
-  let (&&&) c1 c2 k p=
-    match c1 k p , c2 k p with
-    | Cannot e , _ 
-    | _ , Cannot e -> Cannot e
-    | Strict, Strict -> Strict
-    | _ , _ -> Loose
-  let kind e k0 k p = bool e (k0=k) k p 
-  let pdone e k p = bool e (Proofview.finished p) k p
-end
-
 
-(* Unfocus command.
-   Fails if the proof is not focused. *)
 exception CannotUnfocusThisWay
+
+(* Cannot focus on non-existing subgoals *)
+exception NoSuchGoals of int * int
+
+
+exception FullyUnfocused
+
 let _ = Errors.register_handler begin function
   | CannotUnfocusThisWay ->
-    Util.error "This proof is focused, but cannot be unfocused this way"
+    Errors.error "This proof is focused, but cannot be unfocused this way"
+  | NoSuchGoals (i,j) when Int.equal i j ->
+      Errors.errorlabstrm "Focus" Pp.(str"No such goal (" ++ int i ++ str").")
+  | NoSuchGoals (i,j) ->
+      Errors.errorlabstrm "Focus" Pp.(
+        str"Not every goal in range ["++ int i ++ str","++int j++str"] exist."
+      )
+  | FullyUnfocused -> Errors.error "The proof is not focused"
   | _ -> raise Errors.Unhandled
 end
 
-open Cond
-let no_cond_gen e ~loose_end k0 =
-  cloose loose_end (kind e k0)
-let no_cond_gen e ?(loose_end=false) k = no_cond_gen e ~loose_end k , check k
-let no_cond ?loose_end = no_cond_gen CannotUnfocusThisWay ?loose_end
-(* [done_cond] checks that the unfocusing command uses the right [focus_kind]
-    and that the focused proofview is complete. *)
-let done_cond_gen e ~loose_end k0 =
-  (cloose loose_end (kind e k0)) &&& pdone e
-let done_cond_gen e ?(loose_end=false) k = done_cond_gen e ~loose_end k , check k
-let done_cond ?loose_end = done_cond_gen CannotUnfocusThisWay ?loose_end
-
+let check_cond_kind c k =
+  let kind_of_cond = function
+    | CondNo (_,k) | CondDone(_,k) | CondEndStack k -> k in
+  Int.equal (kind_of_cond c) k
+
+let test_cond c k1 pw =
+  match c with
+  | CondNo(_,     k) when Int.equal k k1 -> Strict
+  | CondNo(true,  _)             -> Loose
+  | CondNo(false, _)             -> Cannot NotThisWay
+  | CondDone(_,     k) when Int.equal k k1 && Proofview.finished pw -> Strict
+  | CondDone(true,  _)                                      -> Loose
+  | CondDone(false, _)                                      -> Cannot NotThisWay
+  | CondEndStack k when Int.equal k k1 -> Strict
+  | CondEndStack _             -> Cannot AlreadyNoFocus
+
+let no_cond ?(loose_end=false) k = CondNo (loose_end, k)
+let done_cond ?(loose_end=false) k = CondDone (loose_end,k)
 
 (* Subpart of the type of proofs. It contains the parts of the proof which
    are under control of the undo mechanism *)
-type proof_state = {
+type proof = {
   (* Current focused proofview *)
   proofview: Proofview.proofview;
+  (* Entry for the proofview *)
+  entry : Proofview.entry;
   (* History of the focusings, provides information on how
      to unfocus the proof and the extra information stored while focusing.
      The list is empty when the proof is fully unfocused. *)
   focus_stack: (_focus_condition*focus_info*Proofview.focus_context) list;
-  (* Extra information which can be freely used to create new behaviours. *)
-  intel: Store.t
+  (* List of goals that have been shelved. *)
+  shelf : Goal.goal list;
+  (* List of goals that have been given up *)
+  given_up : Goal.goal list;
 }
 
-type proof_info = {
-  mutable endline_tactic : unit Proofview.tactic ;
-  mutable section_vars : Sign.section_context option;
-  initial_conclusions : Term.types list
-}
-
-type undo_action = 
-  | State of proof_state
-  | Effect of (unit -> unit)
-
-type proof = { (* current proof_state *)
-               mutable state : proof_state;
-               (* The undo stack *)
-               mutable undo_stack : undo_action list;
-	       (* secondary undo stacks used for transactions *)
-	       mutable transactions : undo_action list list;
-	       info : proof_info
-             }
-
-
 (*** General proof functions ***)
 
-let proof { state = p } =
+let proof p =
   let (goals,sigma) = Proofview.proofview p.proofview in
   (* spiwack: beware, the bottom of the stack is used by [Proof]
      internally, and should not be exposed. *)
@@ -161,322 +127,261 @@ let proof { state = p } =
   let stack =
     map_minus_one (fun (_,_,c) -> Proofview.focus_context c) p.focus_stack
   in
-  (goals,stack,sigma)
+  let shelf = p.shelf in
+  let given_up = p.given_up in
+  (goals,stack,shelf,given_up,sigma)
+
+type 'a pre_goals = {
+    fg_goals : 'a list;
+  (** List of the focussed goals *)
+  bg_goals : ('a list * 'a list) list;
+  (** Zipper representing the unfocussed background goals *)
+  shelved_goals : 'a list;
+  (** List of the goals on the shelf. *)
+  given_up_goals : 'a list;
+  (** List of the goals that have been given up *)
+}
+
+let map_structured_proof pfts process_goal: 'a pre_goals =
+  let (goals, zipper, shelf, given_up, sigma) = proof pfts in
+  let fg = List.map (process_goal sigma) goals in
+  let map_zip (lg, rg) =
+    let lg = List.map (process_goal sigma) lg in
+    let rg = List.map (process_goal sigma) rg in
+    (lg, rg)
+  in
+  let bg = List.map map_zip zipper in
+  let shelf = List.map (process_goal sigma) shelf in
+  let given_up = List.map (process_goal sigma) given_up in
+    { fg_goals = fg;
+      bg_goals = bg;
+      shelved_goals = shelf;
+      given_up_goals = given_up; }
 
 let rec unroll_focus pv = function
   | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk
   | [] -> pv
-
 (* spiwack: a proof is considered completed even if its still focused, if the focus
    doesn't hide any goal.
    Unfocusing is handled in {!return}. *)
 let is_done p =
-  Proofview.finished p.state.proofview && 
-  Proofview.finished (unroll_focus p.state.proofview p.state.focus_stack)
+  Proofview.finished p.proofview &&
+  Proofview.finished (unroll_focus p.proofview p.focus_stack)
 
 (* spiwack: for compatibility with <= 8.2 proof engine *)
 let has_unresolved_evar p =
-  Proofview.V82.has_unresolved_evar p.state.proofview
+  Proofview.V82.has_unresolved_evar p.proofview
 
 (* Returns the list of partial proofs to initial goals *)
-let partial_proof p =
-  List.map fst (Proofview.return p.state.proofview)
-
-
+let partial_proof p = Proofview.partial_proof p.entry p.proofview
 
 (*** The following functions implement the basic internal mechanisms
      of proofs, they are not meant to be exported in the .mli ***)
 
 (* An auxiliary function to push a {!focus_context} on the focus stack. *)
 let push_focus cond inf context pr =
-  pr.state <- { pr.state with focus_stack = (cond,inf,context)::pr.state.focus_stack }
+  { pr with focus_stack = (cond,inf,context)::pr.focus_stack }
 
-exception FullyUnfocused
-let _ = Errors.register_handler begin function
-  | FullyUnfocused -> Util.error "The proof is not focused"
-  | _ -> raise Errors.Unhandled
-end
 (* An auxiliary function to read the kind of the next focusing step *)
 let cond_of_focus pr =
-  match pr.state.focus_stack with
+  match pr.focus_stack with
   | (cond,_,_)::_ -> cond
   | _ -> raise FullyUnfocused
 
 (* An auxiliary function to pop and read the last {!Proofview.focus_context} 
    on the focus stack. *)
 let pop_focus pr =
-  match pr.state.focus_stack with
-  | focus::other_focuses -> 
-      pr.state <- { pr.state with focus_stack = other_focuses }; focus
-  | _ -> 
+  match pr.focus_stack with
+  | focus::other_focuses ->
+      { pr with focus_stack = other_focuses }, focus
+  | _ ->
       raise FullyUnfocused
 
-(* Auxiliary function to push a [proof_state] onto the undo stack. *)
-let push_undo save pr =
-  match pr.transactions with
-  | [] -> pr.undo_stack <- save::pr.undo_stack
-  | stack::trans' -> pr.transactions <- (save::stack)::trans'
-
-(* Auxiliary function to pop and read a [save_state] from the undo stack. *)
-exception EmptyUndoStack
-let _ = Errors.register_handler begin function
-  | EmptyUndoStack -> Util.error "Cannot undo: no more undo information"
-  | _ -> raise Errors.Unhandled
-end
-let pop_undo pr =
-  match pr.transactions , pr.undo_stack with
-  | [] , state::stack -> pr.undo_stack <- stack; state
-  | (state::stack)::trans', _ -> pr.transactions <- stack::trans'; state
-  | _ -> raise EmptyUndoStack
-
-
 (* This function focuses the proof [pr] between indices [i] and [j] *)
 let _focus cond inf i j pr =
-  let (focused,context) = Proofview.focus i j pr.state.proofview in
-  push_focus cond inf context pr;
-  pr.state <- { pr.state with proofview = focused }
+  let focused, context = Proofview.focus i j pr.proofview in
+  let pr = push_focus cond inf context pr in
+  { pr with proofview = focused }
 
 (* This function unfocuses the proof [pr], it raises [FullyUnfocused],
    if the proof is already fully unfocused.
    This function does not care about the condition of the current focus. *)
 let _unfocus pr =
-  let (_,_,fc) = pop_focus pr in
-  pr.state <- { pr.state with proofview = Proofview.unfocus fc pr.state.proofview }
-
-
-let set_used_variables l p =
-  p.info.section_vars <- Some l
-
-let get_used_variables p = p.info.section_vars
-
-(*** Endline tactic ***)
-
-(* spiwack this is an information about the UI, it might be a good idea to move
-   it to the Proof_global module *)
-
-(* Sets the tactic to be used when a tactic line is closed with [...] *)
-let set_endline_tactic tac p =
- p.info.endline_tactic <- tac
-
-let with_end_tac pr tac =
-  Proofview.tclTHEN tac pr.info.endline_tactic
-
-(*** The following functions define the safety mechanism of the
-     proof system, they may be unsafe if not used carefully. There is
-     currently no reason to export them in the .mli ***)
-
-(* This functions saves the current state into a [proof_state]. *)
-let save_state { state = ps } = State ps
-
-(* This function stores the current proof state in the undo stack. *)
-let save pr =
-  push_undo (save_state pr) pr
-
-(* This function restores a state, presumably from the top of the undo stack. *)
-let restore_state save pr =
-  match save with
-  | State save -> pr.state <- save
-  | Effect undo -> undo ()
-
-(* Interpretes the Undo command. *)
-let undo pr =
-  (* On a single line, since the effects commute *)
-  restore_state (pop_undo pr) pr
-
-(* Adds an undo effect to the undo stack. Use it with care, errors here might result
-    in inconsistent states. *)
-let add_undo effect pr =
-  push_undo (Effect effect) pr
-
-
-
-(*** Transactions ***)
-
-let init_transaction pr =
-  pr.transactions <- []::pr.transactions
-
-let commit_stack pr stack =
-  let push s = push_undo s pr in
-  List.iter push (List.rev stack)
-
-(* Invariant: [commit] should be called only when a transaction
-   is open. It closes the current transaction. *)
-let commit pr =
-  match pr.transactions with
-  | stack::trans' ->
-    pr.transactions <- trans';
-    commit_stack pr stack
-  | [] -> assert false
-
-(* Invariant: [rollback] should be called only when a transaction
-   is open. It closes the current transaction. *)
-let rec rollback pr =
-  try
-    undo pr;
-    rollback pr
-  with EmptyUndoStack ->
-    match pr.transactions with
-    | []::trans' -> pr.transactions <- trans'
-    | _ -> assert false
-
-
-let transaction pr t =
-  init_transaction pr;
-  try t (); commit pr
-  with reraise -> rollback pr; raise reraise
-
+  let pr, (_,_,fc) = pop_focus pr in
+   { pr with proofview = Proofview.unfocus fc pr.proofview }
 
 (* Focus command (focuses on the [i]th subgoal) *)
 (* spiwack: there could also, easily be a focus-on-a-range tactic, is there 
    a need for it? *)
 let focus cond inf i pr =
-  save pr;
-  _focus cond (Obj.repr inf) i i pr
+  try _focus cond (Obj.repr inf) i i pr
+  with CList.IndexOutOfRange -> raise (NoSuchGoals (i,i))
 
 let rec unfocus kind pr () =
-  let starting_point = save_state pr in
   let cond = cond_of_focus pr in
-  match fst cond kind pr.state.proofview with
-  | Cannot e -> raise e
-  | Strict -> 
-    (_unfocus pr;
-     push_undo starting_point pr)
+  match test_cond cond kind pr.proofview with
+  | Cannot NotThisWay -> raise CannotUnfocusThisWay
+  | Cannot AlreadyNoFocus -> raise FullyUnfocused
+  | Strict ->
+     let pr = _unfocus pr in
+     pr
   | Loose ->
     begin try
-	    _unfocus pr;
-	    push_undo starting_point pr;
+            let pr = _unfocus pr in
 	    unfocus kind pr ()
       with FullyUnfocused -> raise CannotUnfocusThisWay
     end
 
-let unfocus kind pr =
-  transaction pr (unfocus kind pr)
-
 exception NoSuchFocus
 (* no handler: should not be allowed to reach toplevel. *)
 let rec get_in_focus_stack kind stack =
   match stack with
-  | ((_,check),inf,_)::stack ->
-      if check kind then inf
+  | (cond,inf,_)::stack ->
+      if check_cond_kind cond kind then inf
       else get_in_focus_stack kind stack
   | [] -> raise NoSuchFocus
 let get_at_focus kind pr =
-  Obj.magic (get_in_focus_stack kind pr.state.focus_stack)
+  Obj.magic (get_in_focus_stack kind pr.focus_stack)
 
 let is_last_focus kind pr =
-  let ((_,check),_,_) = List.hd pr.state.focus_stack in
-  check kind
+  let (cond,_,_) = List.hd pr.focus_stack in
+  check_cond_kind cond kind
 
 let no_focused_goal p =
-  Proofview.finished p.state.proofview
+  Proofview.finished p.proofview
+
+let rec maximal_unfocus k p =
+  if no_focused_goal p then
+    try maximal_unfocus k (unfocus k p ())
+    with FullyUnfocused | CannotUnfocusThisWay -> p
+  else p
 
 (*** Proof Creation/Termination ***)
 
 (* [end_of_stack] is unfocused by return to close every loose focus. *)
 let end_of_stack_kind = new_focus_kind ()
-let end_of_stack = done_cond_gen FullyUnfocused end_of_stack_kind
+let end_of_stack = CondEndStack end_of_stack_kind
 
 let unfocused = is_last_focus end_of_stack_kind
 
-let start goals =
-  let pr =
-    { state = { proofview = Proofview.init goals ;
-	        focus_stack = [] ;
-	        intel = Store.empty} ;
-      undo_stack = [] ;
-      transactions = [] ;
-      info = { endline_tactic = Proofview.tclUNIT ();
-               initial_conclusions = List.map snd goals;
-               section_vars = None }
-    }
-  in
-  _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr;
-  pr
+let start sigma goals =
+  let entry, proofview = Proofview.init sigma goals in
+  let pr = {
+    proofview;
+    entry;
+    focus_stack = [] ;
+    shelf = [] ;
+    given_up = [] } in
+  _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr
+let dependent_start goals =
+  let entry, proofview = Proofview.dependent_init goals in
+  let pr = {
+    proofview;
+    entry;
+    focus_stack = [] ;
+    shelf = [] ;
+    given_up = [] } in
+  let number_of_goals = List.length (Proofview.initial_goals pr.entry) in
+  _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr
 
 exception UnfinishedProof
+exception HasShelvedGoals
+exception HasGivenUpGoals
 exception HasUnresolvedEvar
 let _ = Errors.register_handler begin function
-  | UnfinishedProof -> Util.error "Some goals have not been solved."
-  | HasUnresolvedEvar -> Util.error "Some existential variables are uninstantiated."
+  | UnfinishedProof -> Errors.error "Some goals have not been solved."
+  | HasShelvedGoals -> Errors.error "Some goals have been left on the shelf."
+  | HasGivenUpGoals -> Errors.error "Some goals have been given up."
+  | HasUnresolvedEvar -> Errors.error "Some existential variables are uninstantiated."
   | _ -> raise Errors.Unhandled
 end
+
 let return p =
   if not (is_done p) then
     raise UnfinishedProof
-  else if has_unresolved_evar p then 
+  else if not (CList.is_empty (p.shelf)) then
+    raise HasShelvedGoals
+  else if not (CList.is_empty (p.given_up)) then
+    raise HasGivenUpGoals
+  else if has_unresolved_evar p then
     (* spiwack: for compatibility with <= 8.3 proof engine *)
     raise HasUnresolvedEvar
   else
-    unfocus end_of_stack_kind p;
-    Proofview.return p.state.proofview
-
-(*** Function manipulation proof extra informations ***)
+    let p = unfocus end_of_stack_kind p () in
+    Proofview.return p.proofview
 
-let get_proof_info pr =
-  pr.state.intel
+let initial_goals p = Proofview.initial_goals p.entry
 
-let set_proof_info info pr =
-  save pr;
-  pr.state <- { pr.state with intel=info }
+let compact p =
+  let entry, proofview = Proofview.compact p.entry p.proofview in
+  { p with proofview; entry }
 
+(*** Function manipulation proof extra informations ***)
 
 (*** Tactics ***)
 
 let run_tactic env tac pr =
-  let starting_point = save_state pr in
-  let sp = pr.state.proofview in
-  try
-    let tacticced_proofview = Proofview.apply env tac sp in
-    pr.state <- { pr.state with proofview = tacticced_proofview };
-    push_undo starting_point pr
-  with reraise ->
-    restore_state starting_point pr;
-    raise reraise
+  let sp = pr.proofview in
+  let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) =
+    Proofview.apply env tac sp
+  in
+  let sigma = Proofview.return tacticced_proofview in
+  (* Already solved goals are not to be counted as shelved. Nor are
+     they to be marked as unresolvable. *)
+  let undef l = List.filter (fun g -> Evd.is_undefined sigma g) l in
+  let retrieved = undef (List.rev (Evd.future_goals sigma)) in
+  let shelf = (undef pr.shelf)@retrieved@(undef to_shelve) in
+  let proofview =
+    List.fold_left
+      Proofview.Unsafe.mark_as_goal
+      tacticced_proofview
+      retrieved
+  in
+  let given_up = pr.given_up@give_up in
+  let proofview = Proofview.Unsafe.reset_future_goals proofview in
+  { pr with proofview ; shelf ; given_up },(status,info_trace)
 
 (*** Commands ***)
 
-let in_proof p k =
-  Proofview.in_proofview p.state.proofview k
+let in_proof p k = k (Proofview.return p.proofview)
 
+(* Remove all the goals from the shelf and adds them at the end of the
+   focused goals. *)
+let unshelve p =
+  { p with proofview = Proofview.unshelve (p.shelf) (p.proofview) ; shelf = [] }
 
 (*** Compatibility layer with <=v8.2 ***)
 module V82 = struct
   let subgoals p =
-    Proofview.V82.goals p.state.proofview
+    Proofview.V82.goals p.proofview
 
   let background_subgoals p =
-    Proofview.V82.goals (unroll_focus p.state.proofview p.state.focus_stack)
-
-  let get_initial_conclusions p = 
-    p.info.initial_conclusions
-
-  let depth p = List.length p.undo_stack
+    Proofview.V82.goals (unroll_focus p.proofview p.focus_stack)
 
-  let top_goal p = 
-    let { Evd.it=gls ; sigma=sigma } = 
-	Proofview.V82.top_goals p.state.proofview
+  let top_goal p =
+    let { Evd.it=gls ; sigma=sigma; } =
+	Proofview.V82.top_goals p.entry p.proofview
     in
-    { Evd.it=List.hd gls ; sigma=sigma }
+    { Evd.it=List.hd gls ; sigma=sigma; }
 
   let top_evars p =
-    Proofview.V82.top_evars p.state.proofview
+    Proofview.V82.top_evars p.entry
 
   let grab_evars p =
     if not (is_done p) then
       raise UnfinishedProof
     else
-      save p;
-      p.state <- { p.state with proofview = Proofview.V82.grab p.state.proofview }
-    
-
-    let instantiate_evar n com pr =
-      let starting_point = save_state pr in
-      let sp = pr.state.proofview in
-      try
-	let new_proofview = Proofview.V82.instantiate_evar n com sp in
-	pr.state <- { pr.state with proofview = new_proofview };
-	push_undo starting_point pr
-      with reraise ->
-	restore_state starting_point pr;
-	raise reraise
+      { p with proofview = Proofview.V82.grab p.proofview }
+
+
+  let instantiate_evar n com pr =
+    let sp = pr.proofview in
+    let proofview = Proofview.V82.instantiate_evar n com sp in
+    let shelf =
+      List.filter begin fun g ->
+        Evd.is_undefined (Proofview.return proofview) g
+      end pr.shelf
+    in
+    { pr with proofview ; shelf }
+
 end
diff --git a/proofs/proof.mli b/proofs/proof.mli
index d6873790..4ae64ae6 100644
--- a/proofs/proof.mli
+++ b/proofs/proof.mli
@@ -1,16 +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        *)
 (************************************************************************)
 
 (* Module defining the last essential tiles of interactive proofs.
-   The features of the Proof module are undoing and focusing.
-   A proof is a mutable object, it contains a proofview, and some information
-   to be able to undo actions, and to unfocus the current view. All three
-   of these being meant to evolve.
+   A proof deals with the focusing commands (including the braces and bullets),
+   the shelf (see the [shelve] tactic) and given up goal (see the [give_up]
+   tactic). A proof is made of the following:
    - Proofview: a proof is primarily the data of the current view.
      That which is shown to the user (as a remainder, a proofview
      is mainly the logical state of the proof, together with the
@@ -23,14 +22,13 @@
      the focus kind is actually stored inside the condition). To unfocus, one
      needs to know the focus kind, and the condition (for instance "no condition" or
      the proof under focused must be complete) must be met.
-   - Undo: since proofviews and focus stacks are immutable objects, 
-     it could suffice to hold the previous states, to allow to return to the past.
-     However, we also allow other modules to do actions that can be undone.
-     Therefore the undo stack stores action to be ran to undo.
+   - Shelf: A list of goals which have been put aside during the proof. They can be
+     retrieved with the [Unshelve] command, or solved by side effects
+   - Given up goals: as long as there is a given up goal, the proof is not completed.
+     Given up goals cannot be retrieved, the user must go back where the tactic
+     [give_up] was run and solve the goal there.
 *)
 
-open Term
-
 (* Type of a proof. *)
 type proof
 
@@ -40,13 +38,37 @@ type proof
    functions to ide-s. This would be better than spawning a new nearly
    identical function everytime. Hence the generic name. *)
 (* In this version: returns the focused goals, a representation of the
-   focus stack (the number of goals at each level) and the underlying
+   focus stack (the goals at each level), a representation of the
+   shelf (the list of goals on the shelf), a representation of the
+   given up goals (the list of the given up goals) and the underlying
    evar_map *)
-val proof : proof -> Goal.goal list * (Goal.goal list * Goal.goal list) list * Evd.evar_map
+val proof : proof ->
+  Goal.goal list
+  * (Goal.goal list * Goal.goal list) list
+  * Goal.goal list
+  * Goal.goal list
+  * Evd.evar_map
+
+(* Generic records structured like the return type of proof *)
+type 'a pre_goals = {
+  fg_goals : 'a list;
+  (** List of the focussed goals *)
+  bg_goals : ('a list * 'a list) list;
+  (** Zipper representing the unfocussed background goals *)
+  shelved_goals : 'a list;
+  (** List of the goals on the shelf. *)
+  given_up_goals : 'a list;
+  (** List of the goals that have been given up *)
+}
+
+val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals)
+
 
 (*** General proof functions ***)
 
-val start : (Environ.env * Term.types) list -> proof
+val start : Evd.evar_map -> (Environ.env * Term.types) list -> proof
+val dependent_start : Proofview.telescope -> proof
+val initial_goals : proof -> (Term.constr * Term.types) list
 
 (* Returns [true] if the considered proof is completed, that is if no goal remain
     to be considered (this does not require that all evars have been solved). *)
@@ -55,25 +77,18 @@ val is_done : proof -> bool
 (* Returns the list of partial proofs to initial goals. *)
 val partial_proof : proof -> Term.constr list
 
+val compact : proof -> proof
+
 (* Returns the proofs (with their type) of the initial goals.
     Raises [UnfinishedProof] is some goals remain to be considered.
+    Raises [HasShelvedGoals] if some goals are left on the shelf.
+    Raises [HasGivenUpGoals] if some goals have been given up.
     Raises [HasUnresolvedEvar] if some evars have been left undefined. *)
 exception UnfinishedProof
+exception HasShelvedGoals
+exception HasGivenUpGoals
 exception HasUnresolvedEvar
-val return : proof -> (Term.constr * Term.types) list
-
-(* Interpretes the Undo command. Raises [EmptyUndoStack] if 
-    the undo stack is empty. *)
-exception EmptyUndoStack
-val undo : proof -> unit
-
-(* Adds an undo effect to the undo stack. Use it with care, errors here might result
-    in inconsistent states.
-   An undo effect is meant to undo an effect on a proof (a canonical example
-   of which is {!Proofglobal.set_proof_mode} which changes the current parser for
-   tactics). Make sure it will work even if the effects have been only partially
-   applied at the time of failure. *)
-val add_undo : (unit -> unit) -> proof -> unit
+val return : proof -> Evd.evar_map
 
 (*** Focusing actions ***)
 
@@ -113,15 +128,23 @@ val done_cond : ?loose_end:bool -> 'a focus_kind -> 'a focus_condition
 (* focus command (focuses on the [i]th subgoal) *)
 (* spiwack: there could also, easily be a focus-on-a-range tactic, is there 
    a need for it? *)
-val focus : 'a focus_condition -> 'a -> int -> proof -> unit
+val focus : 'a focus_condition -> 'a -> int -> proof -> proof
 
 exception FullyUnfocused
 exception CannotUnfocusThisWay
+
+(* This is raised when trying to focus on non-existing subgoals. It is
+   handled by an error message but one may need to catched it and
+   settle a better error message in some case (suggesting a better
+   bullet for example), see proof_global.ml function Bullet.pop and
+   Bullet.push. *)
+exception NoSuchGoals of int * int
+
 (* Unfocusing command.
    Raises [FullyUnfocused] if the proof is not focused.
    Raises [CannotUnfocusThisWay] if the proof the unfocusing condition
      is not met. *)
-val unfocus : 'a focus_kind -> proof -> unit
+val unfocus : 'a focus_kind -> proof -> unit -> proof
 
 (* [unfocused p] returns [true] when [p] is fully unfocused. *)
 val unfocused : proof -> bool
@@ -138,43 +161,23 @@ val is_last_focus : 'a focus_kind -> proof -> bool
 (* returns [true] if there is no goal under focus. *)
 val no_focused_goal : proof -> bool
 
-(*** Function manipulation proof extra informations ***)
-
-val get_proof_info : proof -> Store.t
-
-(* Sets the section variables assumed by the proof *)
-val set_used_variables : Sign.section_context -> proof -> unit
-val get_used_variables : proof -> Sign.section_context option
-
-(*** Endline tactic ***)
-
-(* Sets the tactic to be used when a tactic line is closed with [...] *)
-val set_endline_tactic : unit Proofview.tactic -> proof -> unit
-
-val with_end_tac : proof -> unit Proofview.tactic -> unit Proofview.tactic
-
 (*** Tactics ***)
 
-val run_tactic : Environ.env -> unit Proofview.tactic -> proof -> unit
-
-
-(*** Transactions ***)
-
-(* A transaction chains several commands into a single one. For instance,
-   a focusing command and a tactic. Transactions are such that if
-   any of the atomic action fails, the whole transaction fails.
-
-   During a transaction, the visible undo stack is constituted only
-   of the actions performed done during the transaction.
-
-   [transaction p f] can be called on an [f] using, itself, [transaction p].*)
-val transaction : proof -> (unit -> unit) -> unit
+(* the returned boolean signal whether an unsafe tactic has been
+   used. In which case it is [false]. *)
+val run_tactic : Environ.env ->
+  unit Proofview.tactic -> proof -> proof*(bool*Proofview_monad.Info.tree)
 
+val maximal_unfocus : 'a focus_kind -> proof -> proof
 
 (*** Commands ***)
 
 val in_proof : proof -> (Evd.evar_map -> 'a) -> 'a
 
+(* Remove all the goals from the shelf and adds them at the end of the
+   focused goals. *)
+val unshelve : proof -> proof
+
 (*** Compatibility layer with <=v8.2 ***)
 module V82 : sig
   val subgoals : proof -> Goal.goal list Evd.sigma
@@ -182,19 +185,15 @@ module V82 : sig
   (* All the subgoals of the proof, including those which are not focused. *)
   val background_subgoals : proof -> Goal.goal list Evd.sigma
 
-  val get_initial_conclusions : proof -> Term.types list 
-
-  val depth : proof -> int 
-
   val top_goal : proof -> Goal.goal Evd.sigma
-  
+
   (* returns the existential variable used to start the proof *)
   val top_evars : proof -> Evd.evar list
 
   (* Turns the unresolved evars into goals.
      Raises [UnfinishedProof] if there are still unsolved goals. *)
-  val grab_evars : proof -> unit
+  val grab_evars : proof -> proof
 
   (* Implements the Existential command *)
-  val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit
+  val instantiate_evar : int -> Constrexpr.constr_expr -> proof -> proof
 end
diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml
index a58fab0c..f55ab700 100644
--- a/proofs/proof_global.ml
+++ b/proofs/proof_global.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        *)
@@ -14,6 +14,7 @@
 (*                                                                     *)
 (***********************************************************************)
 
+open Util
 open Pp
 open Names
 
@@ -32,15 +33,17 @@ let proof_modes = Hashtbl.create 6
 let find_proof_mode n =
   try Hashtbl.find proof_modes n
   with Not_found ->
-    Util.error (Format.sprintf "No proof mode named \"%s\"." n)
+    Errors.error (Format.sprintf "No proof mode named \"%s\"." n)
+
+let register_proof_mode ({name = n} as m) =
+  Hashtbl.add proof_modes n (Ephemeron.create m)
 
-let register_proof_mode ({ name = n } as m) = Hashtbl.add proof_modes n m
 (* initial mode: standard mode *)
 let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) }
 let _ = register_proof_mode standard
 
 (* Default proof mode, to be set at the beginning of proofs. *)
-let default_proof_mode = ref standard
+let default_proof_mode = ref (find_proof_mode "No")
 
 let _ =
   Goptions.declare_string_option {Goptions.
@@ -48,48 +51,63 @@ let _ =
     optdepr = false;
     optname = "default proof mode" ;
     optkey = ["Default";"Proof";"Mode"] ;
-    optread = begin fun () -> 
-                               let { name = name } = !default_proof_mode in name 
-                     end;
-    optwrite = begin fun n -> 
-                                default_proof_mode := find_proof_mode n
-                      end
+    optread = begin fun () ->
+      (Ephemeron.default !default_proof_mode standard).name
+    end;
+    optwrite = begin fun n ->
+      default_proof_mode := find_proof_mode n
+    end
   }
 
 (*** Proof Global Environment ***)
 
-(* local shorthand *)
-type nproof = identifier*Proof.proof
-
 (* Extra info on proofs. *)
 type lemma_possible_guards = int list list
-type proof_info = { 
-  strength : Decl_kinds.goal_kind ;
-  compute_guard :  lemma_possible_guards; 
-  hook :Tacexpr.declaration_hook ;
-  mode : proof_mode
+type proof_universes = Evd.evar_universe_context
+
+type proof_object = {
+  id : Names.Id.t;
+  entries : Entries.definition_entry list;
+  persistence : Decl_kinds.goal_kind;
+  universes: proof_universes;
+  (* constraints : Univ.constraints; *)
+}
+
+type proof_ending =
+  | Admitted
+  | Proved of Vernacexpr.opacity_flag *
+             (Vernacexpr.lident * Decl_kinds.theorem_kind option) option *
+              proof_object
+type proof_terminator = proof_ending -> unit
+type closed_proof = proof_object * proof_terminator
+
+type pstate = {
+  pid : Id.t;
+  terminator : proof_terminator Ephemeron.key;
+  endline_tactic : Tacexpr.raw_tactic_expr option;
+  section_vars : Context.section_context option;
+  proof : Proof.proof;
+  strength : Decl_kinds.goal_kind;
+  mode : proof_mode Ephemeron.key;
 }
 
-(* Invariant: the domain of proof_info is current_proof.*)
-(* The head of [!current_proof] is the actual current proof, the other ones are
+(* The head of [!pstates] is the actual current proof, the other ones are
    to be resumed when the current proof is closed or aborted. *)
-let current_proof = ref ([]:nproof list)
-let proof_info = ref (Idmap.empty : proof_info Idmap.t)
+let pstates = ref ([] : pstate list)
 
 (* Current proof_mode, for bookkeeping *)
 let current_proof_mode = ref !default_proof_mode
 
 (* combinators for proof modes *)
-let update_proof_mode () = 
-  match !current_proof with
-  | (id,_)::_ ->  
-      let { mode = m } = Idmap.find id !proof_info in
-      !current_proof_mode.reset ();
+let update_proof_mode () =
+  match !pstates with
+  | { mode = m } :: _ ->
+      Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
       current_proof_mode := m;
-      !current_proof_mode.set ()
-  | _ -> 
-      !current_proof_mode.reset (); 
-      current_proof_mode := standard
+      Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ())
+  | _ ->
+      Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ());
+      current_proof_mode := find_proof_mode "No"
 
 (* combinators for the current_proof lists *)
 let push a l = l := a::!l;
@@ -97,213 +115,271 @@ let push a l = l := a::!l;
 
 exception NoSuchProof
 let _ = Errors.register_handler begin function
-  | NoSuchProof -> Util.error "No such proof."
+  | NoSuchProof -> Errors.error "No such proof."
   | _ -> raise Errors.Unhandled
 end
-let rec extract id l = 
-  let rec aux = function
-    | ((id',_) as np)::l when id_ord id id' = 0 -> (np,l)
-    | np::l -> let (np', l) = aux l in (np' , np::l)
-    | [] -> raise NoSuchProof
-  in
-  let (np,l') = aux !l in
-  l := l';
-  update_proof_mode ();
-  np
 
 exception NoCurrentProof
 let _ = Errors.register_handler begin function
-  | NoCurrentProof -> Util.error "No focused proof (No proof-editing in progress)."
+  | NoCurrentProof -> Errors.error "No focused proof (No proof-editing in progress)."
   | _ -> raise Errors.Unhandled
 end
-let extract_top l =
-  match !l with
-  | np::l' -> l := l' ; update_proof_mode (); np
-  | [] -> raise NoCurrentProof	
-let find_top l =
-  match !l with
+
+(*** Proof Global manipulation ***)
+
+let get_all_proof_names () =
+  List.map (function { pid = id } -> id) !pstates
+
+let cur_pstate () =
+  match !pstates with
   | np::_ -> np
   | [] -> raise NoCurrentProof
 
-let rotate_top l1 l2 =
-  let np = extract_top l1 in
-  push np l2
+let give_me_the_proof () = (cur_pstate ()).proof
+let get_current_proof_name () = (cur_pstate ()).pid
 
-let rotate_find id l1 l2 =
-  let np = extract id l1 in
-  push np l2
-  
+let interp_tac = ref (fun _ -> assert false)
+let set_interp_tac f = interp_tac := f
 
-(* combinators for the proof_info map *)
-let add id info m =
-  m := Idmap.add id info !m
-let remove id m =
-  m := Idmap.remove id !m
-
-(*** Proof Global manipulation ***)
+let with_current_proof f =
+  match !pstates with
+  | [] -> raise NoCurrentProof
+  | p :: rest ->
+      let et =
+        match p.endline_tactic with
+        | None -> Proofview.tclUNIT ()
+        | Some tac -> !interp_tac tac in
+      let (newpr,ret) = f et p.proof in
+      let p = { p with proof = newpr } in
+      pstates := p :: rest;
+      ret
+let simple_with_current_proof f = with_current_proof (fun t p -> f t p , ())
 
-let get_all_proof_names () =
-    List.map fst !current_proof
+let compact_the_proof () = simple_with_current_proof (fun _ -> Proof.compact)
 
-let give_me_the_proof () = 
-  snd (find_top current_proof)
 
-let get_current_proof_name () =
-  fst (find_top current_proof)
+(* Sets the tactic to be used when a tactic line is closed with [...] *)
+let set_endline_tactic tac =
+  match !pstates with
+  | [] -> raise NoCurrentProof
+  | p :: rest -> pstates := { p with endline_tactic = Some tac } :: rest
 
 (* spiwack: it might be considered to move error messages away.
     Or else to remove special exceptions from Proof_global.
     Arguments for the former: there is no reason Proof_global is only
-    accessed directly through vernacular commands. Error message should be 
+    accessed directly through vernacular commands. Error message should be
    pushed to external layers, and so we should be able to have a finer
    control on error message on complex actions. *)
 let msg_proofs () =
   match get_all_proof_names () with
     | [] -> (spc () ++ str"(No proof-editing in progress).")
     | l ->  (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++
-               (Util.prlist_with_sep Util.pr_spc Nameops.pr_id l)++ str ".")
+               (pr_sequence Nameops.pr_id l) ++ str".")
 
-let there_is_a_proof () = !current_proof <> []
+let there_is_a_proof () = not (List.is_empty !pstates)
 let there_are_pending_proofs () = there_is_a_proof ()
 let check_no_pending_proof () =
   if not (there_are_pending_proofs ()) then
     ()
   else begin
-    Util.error (Pp.string_of_ppcmds
+    Errors.error (Pp.string_of_ppcmds
       (str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
        str"Use \"Abort All\" first or complete proof(s)."))
   end
 
 let discard_gen id =
-  ignore (extract id current_proof);
-  remove id proof_info
-
-let discard (loc,id) = 
-  try
-    discard_gen id
-  with NoSuchProof ->
-    Util.user_err_loc
+  pstates := List.filter (fun { pid = id' } -> not (Id.equal id id')) !pstates
+
+let discard (loc,id) =
+  let n = List.length !pstates in
+  discard_gen id;
+  if Int.equal (List.length !pstates) n then
+    Errors.user_err_loc
       (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
 
 let discard_current () =
-  let (id,_) = extract_top current_proof in
-  remove id proof_info
- 
-let discard_all () =
-  current_proof := [];
-  proof_info := Idmap.empty
+  if List.is_empty !pstates then raise NoCurrentProof else pstates := List.tl !pstates
+
+let discard_all () = pstates := []
 
 (* [set_proof_mode] sets the proof mode to be used after it's called. It is
     typically called by the Proof Mode command. *)
-(* Core component.
-    No undo handling.
-    Applies to proof [id], and proof mode [m]. *)
-let set_proof_mode m id = 
-  let info = Idmap.find id !proof_info in
-  let info = { info with mode = m } in
-  proof_info := Idmap.add id info !proof_info;
+let set_proof_mode m id =
+  pstates :=
+    List.map (function { pid = id' } as p ->
+      if Id.equal id' id then { p with mode = m } else p) !pstates;
   update_proof_mode ()
-(* Complete function.
-    Handles undo.
-    Applies to current proof, and proof mode name [mn]. *)
-let set_proof_mode mn =
-  let m = find_proof_mode mn in
-  let id = get_current_proof_name () in
-  let pr = give_me_the_proof () in
-  Proof.add_undo begin let curr = !current_proof_mode in fun () ->
-    set_proof_mode curr id ; update_proof_mode ()
-  end pr ;
-  set_proof_mode m id
-
-exception AlreadyExists
-let _ = Errors.register_handler begin function
-  | AlreadyExists -> Util.error "Already editing something of that name."
-  | _ -> raise Errors.Unhandled
-end
-(* [start_proof s str env t hook tac] starts a proof of name [s] and
-    conclusion [t]; [hook] is optionally a function to be applied at
-    proof end (e.g. to declare the built constructions as a coercion
-    or a setoid morphism); init_tac is possibly a tactic to
-    systematically apply at initialization time (e.g. to start the
-    proof of mutually dependent theorems).
-    It raises exception [ProofInProgress] if there is a proof being
-    currently edited. *)
-let start_proof  id str goals ?(compute_guard=[]) hook =
-  begin
-    List.iter begin fun (id_ex,_) ->
-      if Names.id_ord id id_ex = 0 then raise AlreadyExists
-    end !current_proof
-  end;
-  let p = Proof.start goals in
-  add id { strength=str ; 
-	        compute_guard=compute_guard ; 
-		hook=hook ;
-	        mode = ! default_proof_mode } proof_info ;
-  push (id,p) current_proof
-
-(* arnaud: à enlever *)
-let run_tactic tac = 
-  let p = give_me_the_proof () in
-  let env = Global.env () in
-  Proof.run_tactic env tac p
 
-(* Sets the tactic to be used when a tactic line is closed with [...] *)
-let set_endline_tactic tac =
-  let p = give_me_the_proof () in
-  Proof.set_endline_tactic tac p
+let set_proof_mode mn =
+  set_proof_mode (find_proof_mode mn) (get_current_proof_name ())
+
+let activate_proof_mode mode =
+  Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ())
+let disactivate_proof_mode mode =
+  Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ())
+
+(** [start_proof sigma id str goals terminator] starts a proof of name
+    [id] with goals [goals] (a list of pairs of environment and
+    conclusion); [str] describes what kind of theorem/definition this
+    is (spiwack: for potential printing, I believe is used only by
+    closing commands and the xml plugin); [terminator] is used at the
+    end of the proof to close the proof. The proof is started in the
+    evar map [sigma] (which can typically contain universe
+    constraints). *)
+let start_proof sigma id str goals terminator =
+  let initial_state = {
+    pid = id;
+    terminator = Ephemeron.create terminator;
+    proof = Proof.start sigma goals;
+    endline_tactic = None;
+    section_vars = None;
+    strength = str;
+    mode = find_proof_mode "No" } in
+  push initial_state pstates
+
+let start_dependent_proof id str goals terminator =
+  let initial_state = {
+    pid = id;
+    terminator = Ephemeron.create terminator;
+    proof = Proof.dependent_start goals;
+    endline_tactic = None;
+    section_vars = None;
+    strength = str;
+    mode = find_proof_mode "No" } in
+  push initial_state pstates
+
+let get_used_variables () = (cur_pstate ()).section_vars
 
 let set_used_variables l =
-  let p = give_me_the_proof () in
   let env = Global.env () in
-  let ids = List.fold_right Idset.add l Idset.empty in
+  let ids = List.fold_right Id.Set.add l Id.Set.empty in
   let ctx = Environ.keep_hyps env ids in
-  Proof.set_used_variables ctx p
-
-let get_used_variables () =
-  Proof.get_used_variables (give_me_the_proof ())
-
-let with_end_tac tac =
-  let p = give_me_the_proof () in
-  Proof.with_end_tac p tac
-
-let close_proof () =
-  (* spiwack: for now close_proof doesn't actually discard the proof, it is done
-      by [Command.save]. *)
-  try 
-    let id = get_current_proof_name () in
-    let p = give_me_the_proof () in
-    let proofs_and_types = Proof.return p in
-    let section_vars = Proof.get_used_variables p in
-    let entries = List.map
-      (fun (c,t) -> { Entries.const_entry_body = c;
-                      const_entry_secctx = section_vars;
-                      const_entry_type = Some t;
-		      const_entry_opaque = true })
-      proofs_and_types
-    in
-    let { compute_guard=cg ; strength=str ; hook=hook } =
-      Idmap.find id !proof_info
-    in
-    (id, (entries,cg,str,hook))
-  with 
-    |  Proof.UnfinishedProof ->
-	 Util.error "Attempt to save an incomplete proof"
-    | Proof.HasUnresolvedEvar ->
-	Util.error "Attempt to save a proof with existential variables still non-instantiated"
-
+  match !pstates with
+  | [] -> raise NoCurrentProof
+  | p :: rest ->
+      if not (Option.is_empty p.section_vars) then
+        Errors.error "Used section variables can be declared only once";
+      pstates := { p with section_vars = Some ctx} :: rest;
+      ctx
+
+let get_open_goals () =
+  let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in
+  List.length gl +
+    List.fold_left (+) 0
+    (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) +
+    List.length shelf
+
+let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl =
+  let { pid; section_vars; strength; proof; terminator } = cur_pstate () in
+  let poly = pi2 strength (* Polymorphic *) in
+  let initial_goals = Proof.initial_goals proof in
+  let fpl, univs = Future.split2 fpl in
+  let universes = 
+    if poly || now then Future.force univs 
+    else Proof.in_proof proof (fun x -> Evd.evar_universe_context x) 
+  in
+  (* Because of dependent subgoals at the begining of proofs, we could
+     have existential variables in the initial types of goals, we need to
+     normalise them for the kernel. *)
+  let subst_evar k =
+    Proof.in_proof proof (fun m -> Evd.existential_opt_value m k) in
+  let nf = Universes.nf_evars_and_universes_opt_subst subst_evar
+    (Evd.evar_universe_context_subst universes) in
+  let make_body =
+    if poly || now then
+      let make_body t (c, eff) =
+        let open Universes in
+	let body = c and typ = nf t in
+        let used_univs_body = Universes.universes_of_constr body in
+	let used_univs_typ = Universes.universes_of_constr typ in
+	let ctx = Evd.evar_universe_context_set universes in
+        if keep_body_ucst_sepatate then
+          (* For vi2vo compilation proofs are computed now but we need to
+           * completent the univ constraints of the typ with the ones of
+           * the body.  So we keep the two sets distinct. *)
+          let ctx_body = restrict_universe_context ctx used_univs_body in
+          let ctx_typ = restrict_universe_context ctx used_univs_typ in
+          let univs_typ = Univ.ContextSet.to_context ctx_typ in
+          (univs_typ, typ), ((body, ctx_body), eff)
+        else
+          (* Since the proof is computed now, we can simply have 1 set of
+           * constraints in which we merge the ones for the body and the ones
+           * for the typ *)
+          let used_univs = Univ.LSet.union used_univs_body used_univs_typ in
+          let ctx = restrict_universe_context ctx used_univs in
+          let univs = Univ.ContextSet.to_context ctx in
+          (univs, typ), ((body, Univ.ContextSet.empty), eff)
+      in 
+	fun t p ->
+	  Future.split2 (Future.chain ~pure:true p (make_body t))
+    else
+      fun t p ->
+        let initunivs = Evd.evar_context_universe_context universes in
+	  Future.from_val (initunivs, nf t), 
+	  Future.chain ~pure:true p (fun (pt,eff) ->
+	    (pt, Evd.evar_universe_context_set (Future.force univs)), eff)
+  in
+  let entries =
+    Future.map2 (fun p (_, t) ->
+      let univstyp, body = make_body t p in
+      let univs, typ = Future.force univstyp in
+	{ Entries.
+	  const_entry_body = body;
+	  const_entry_secctx = section_vars;
+	  const_entry_feedback = feedback_id;
+	  const_entry_type  = Some typ;
+	  const_entry_inline_code = false;
+	  const_entry_opaque = true;
+	  const_entry_universes = univs;
+	  const_entry_polymorphic = poly})
+      fpl initial_goals in
+  { id = pid; entries = entries; persistence = strength; universes = universes },
+  fun pr_ending -> Ephemeron.get terminator pr_ending
+
+type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context
+
+let return_proof () =
+  let { proof; strength = (_,poly,_) } = cur_pstate () in
+  let initial_goals = Proof.initial_goals proof in
+  let evd =
+    let error s = raise (Errors.UserError("last tactic before Qed",s)) in
+    try Proof.return proof with
+    | Proof.UnfinishedProof ->
+        error(str"Attempt to save an incomplete proof")
+    | Proof.HasShelvedGoals ->
+        error(str"Attempt to save a proof with shelved goals")
+    | Proof.HasGivenUpGoals ->
+        error(str"Attempt to save a proof with given up goals")
+    | Proof.HasUnresolvedEvar->
+        error(str"Attempt to save a proof with existential " ++
+              str"variables still non-instantiated") in
+  let eff = Evd.eval_side_effects evd in
+  let evd =
+    if poly || !Flags.compilation_mode = Flags.BuildVo
+    then Evd.nf_constraints evd
+    else evd in
+  (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate
+      side-effects... This may explain why one need to uniquize side-effects
+      thereafter... *)
+  let proofs = 
+    List.map (fun (c, _) -> (Evarutil.nf_evars_universes evd c, eff)) initial_goals in
+    proofs, Evd.evar_universe_context evd
+
+let close_future_proof ~feedback_id proof =
+  close_proof ~keep_body_ucst_sepatate:true ~feedback_id ~now:false proof
+let close_proof ~keep_body_ucst_sepatate fix_exn =
+  close_proof ~keep_body_ucst_sepatate ~now:true
+    (Future.from_val ~fix_exn (return_proof ()))
+
+(** Gets the current terminator without checking that the proof has
+    been completed. Useful for the likes of [Admitted]. *)
+let get_terminator () = Ephemeron.get ( cur_pstate() ).terminator
+let set_terminator hook =
+  match !pstates with
+  | [] -> raise NoCurrentProof
+  | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps
 
-(**********************************************************)
-(*                                                                                                  *)
-(*                              Utility functions                                          *)
-(*                                                                                                  *)
-(**********************************************************)
 
-let maximal_unfocus k p =
-  begin try while Proof.no_focused_goal p do
-    Proof.unfocus k p
-  done
-  with Proof.FullyUnfocused | Proof.CannotUnfocusThisWay -> ()
-  end
 
 
 (**********************************************************)
@@ -314,14 +390,25 @@ let maximal_unfocus k p =
 
 module Bullet = struct
 
-  open Store.Field
+  type t = Vernacexpr.bullet
+
+  let bullet_eq b1 b2 = match b1, b2 with
+  | Vernacexpr.Dash n1, Vernacexpr.Dash n2 -> n1 = n2
+  | Vernacexpr.Star n1, Vernacexpr.Star n2 -> n1 = n2
+  | Vernacexpr.Plus n1, Vernacexpr.Plus n2 -> n1 = n2
+  | _ -> false
 
+  let pr_bullet b =
+    match b with
+    | Vernacexpr.Dash n -> str (String.make n '-')
+    | Vernacexpr.Star n -> str (String.make n '*')
+    | Vernacexpr.Plus n -> str (String.make n '+')
 
-  type t = Vernacexpr.bullet
 
   type behavior = {
     name : string;
-    put : Proof.proof -> t -> unit
+    put : Proof.proof -> t -> Proof.proof;
+    suggest: Proof.proof -> string option
   }
 
   let behaviors = Hashtbl.create 4
@@ -330,11 +417,55 @@ module Bullet = struct
   (*** initial modes ***)
   let none = {
     name = "None";
-    put = fun _ _ -> ()
+    put = (fun x _ -> x);
+    suggest = (fun _ -> None)
   }
   let _ = register_behavior none
 
   module Strict = struct
+    type suggestion =
+    | Suggest of t (* this bullet is mandatory here *)
+    | Unfinished of t (* no mandatory bullet here, but this bullet is unfinished *)
+    | NoBulletInUse (* No mandatory bullet (or brace) here, no bullet pending,
+		       some focused goals exists. *)
+    | NeedClosingBrace (* Some unfocussed goal exists "{" needed to focus them *)
+    | ProofFinished (* No more goal anywhere *)
+
+    (* give a message only if more informative than the standard coq message *)
+    let suggest_on_solved_goal sugg =
+      match sugg with
+      | NeedClosingBrace -> Some "Try unfocusing with \"}\"."
+      | NoBulletInUse -> None
+      | ProofFinished -> None
+      | Suggest b -> Some ("Focus next goal with bullet "
+			   ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
+			   ^".")
+      | Unfinished b -> Some ("The current bullet "
+			      ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
+			      ^ " is unfinished.")
+
+    (* give always a message. *)
+    let suggest_on_error sugg =
+      match sugg with
+      | NeedClosingBrace -> "Try unfocusing with \"}\"."
+      | NoBulletInUse -> assert false (* This should never raise an error. *)
+      | ProofFinished -> "No more subgoals."
+      | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
+		      ^ " is mandatory here.")
+      | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b))
+			 ^ " is not finished.")
+
+    exception FailedBullet of t * suggestion
+
+    let _ =
+      Errors.register_handler
+	(function
+	| FailedBullet (b,sugg) ->
+	  let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in
+	  Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg))
+	| _ -> raise Errors.Unhandled)
+
+
     (* spiwack: we need only one focus kind as we keep a stack of (distinct!) bullets *)
     let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind)
     let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind
@@ -350,42 +481,88 @@ module Bullet = struct
 
     let has_bullet bul pr =
       let rec has_bullet = function
-	| b'::_ when bul=b' -> true
+	| b'::_ when bullet_eq bul b' -> true
 	| _::l -> has_bullet l
 	| [] -> false
       in
       has_bullet (get_bullets pr)
 
-    (* precondition: the stack is not empty *)
+    (* pop a bullet from proof [pr]. There should be at least one
+       bullet in use. If pop impossible (pending proofs on this level
+       of bullet or higher) then raise [Proof.CannotUnfocusThisWay]. *)
     let pop pr =
       match get_bullets pr with
-      | b::_ ->
-	Proof.unfocus bullet_kind pr;
-	(*returns*) b
+      | b::_ -> Proof.unfocus bullet_kind pr () , b
       | _ -> assert false
 
-    let push b pr =
+    let push (b:t) pr =
       Proof.focus bullet_cond (b::get_bullets pr) 1 pr
 
+    (* Used only in the next function.
+       TODO: use a recursive function instead? *)
+    exception SuggestFound of t
+
+    let suggest_bullet (prf:Proof.proof): suggestion =
+      if Proof.is_done prf then ProofFinished
+      else if not (Proof.no_focused_goal prf)
+      then (* No suggestion if a bullet is not mandatory, look for an unfinished bullet *)
+	match get_bullets prf with
+	| b::_ -> Unfinished b
+	| _ -> NoBulletInUse
+      else (* There is no goal under focus but some are unfocussed,
+	      let us look at the bullet needed. If no  *)
+	let pcobaye = ref prf in
+	try
+	  while true do
+	    let pcobaye', b = pop !pcobaye in
+	   (* pop went well, this means that there are no more goals
+	    *under this* bullet b, see if a new b can be pushed. *)
+	    (try let _ = push b pcobaye' in (* push didn't fail so a new b can be pushed. *)
+		 raise (SuggestFound b)
+	     with SuggestFound _ as e -> raise e
+	     | _ -> ()); (* b could not be pushed, so we must look for a outer bullet *)
+	    pcobaye := pcobaye'
+	  done;
+	  assert false
+	with SuggestFound b -> Suggest b
+	| _ -> NeedClosingBrace (* No push was possible, but there are still
+				   subgoals somewhere: there must be a "}" to use. *)
+
+
+    let rec pop_until (prf:Proof.proof) bul: Proof.proof =
+      let prf', b = pop prf in
+      if bullet_eq bul b then prf'
+      else pop_until prf' bul
+
     let put p bul =
-      if has_bullet bul p then
-	Proof.transaction p begin fun () ->
-	  while bul <> pop p do () done;
+      try
+	if not (has_bullet bul p) then
+	  (* bullet is not in use, so pushing it is always ok unless
+	     no goal under focus. *)
 	  push bul p
-	end
-      else 
-	push bul p
+	else
+	  match suggest_bullet p with
+	  | Suggest suggested_bullet when bullet_eq bul suggested_bullet
+	      -> (* suggested_bullet is mandatory and you gave the right one *)
+	    let p' = pop_until p bul in
+	    push bul p'
+	(* the bullet you gave is in use but not the right one *)
+	  | sugg -> raise (FailedBullet (bul,sugg))
+      with Proof.NoSuchGoals _ -> (* push went bad *)
+	raise (FailedBullet (bul,suggest_bullet p))
 
     let strict = {
       name = "Strict Subproofs";
-      put = put
+      put = put;
+      suggest = (fun prf -> suggest_on_solved_goal (suggest_bullet prf))
+
     }
     let _ = register_behavior strict
   end
 
   (* Current bullet behavior, controled by the option *)
   let current_behavior = ref Strict.strict
-    
+
   let _ =
     Goptions.declare_string_option {Goptions.
       optsync = true;
@@ -402,16 +579,77 @@ module Bullet = struct
 
   let put p b =
     (!current_behavior).put p b
+
+  let suggest p =
+    (!current_behavior).suggest p
 end
 
 
+let _ =
+  let hook n =
+    let prf = give_me_the_proof () in
+    (Bullet.suggest prf) in
+  Proofview.set_nosuchgoals_hook hook
+
+
+(**********************************************************)
+(*                                                        *)
+(*                     Default goal selector              *)
+(*                                                        *)
+(**********************************************************)
+
+
+(* Default goal selector: selector chosen when a tactic is applied
+   without an explicit selector. *)
+let default_goal_selector = ref (Vernacexpr.SelectNth 1)
+let get_default_goal_selector () = !default_goal_selector
+
+let print_goal_selector = function
+  | Vernacexpr.SelectAll -> "all"
+  | Vernacexpr.SelectNth i -> string_of_int i
+  | Vernacexpr.SelectId id -> Id.to_string id
+  | Vernacexpr.SelectAllParallel -> "par"
+
+let parse_goal_selector = function
+  | "all" -> Vernacexpr.SelectAll
+  | i ->
+      let err_msg = "A selector must be \"all\" or a natural number." in
+      begin try
+              let i = int_of_string i in
+              if i < 0 then Errors.error err_msg;
+              Vernacexpr.SelectNth i
+        with Failure _ -> Errors.error err_msg
+      end
+
+let _ =
+  Goptions.declare_string_option {Goptions.
+                                  optsync = true ;
+                                  optdepr = false;
+                                  optname = "default goal selector" ;
+                                  optkey = ["Default";"Goal";"Selector"] ;
+                                  optread = begin fun () -> print_goal_selector !default_goal_selector end;
+                                  optwrite = begin fun n ->
+                                    default_goal_selector := parse_goal_selector n
+                                  end
+                                 }
+
+
 module V82 = struct
   let get_current_initial_conclusions () =
-    let p = give_me_the_proof () in
-    let id = get_current_proof_name () in
-    let { strength=str ; hook=hook } = 
-      Idmap.find id !proof_info
-    in
-    (id,(Proof.V82.get_initial_conclusions p, str, hook))
+  let { pid; strength; proof } = cur_pstate () in
+  let initial = Proof.initial_goals proof in
+  let goals = List.map (fun (o, c) -> c) initial in
+    pid, (goals, strength)
 end
 
+type state = pstate list
+        
+let freeze ~marshallable =
+  match marshallable with
+  | `Yes ->
+      Errors.anomaly (Pp.str"full marshalling of proof state not supported")
+  | `Shallow -> !pstates
+  | `No -> !pstates
+let unfreeze s = pstates := s; update_proof_mode ()
+let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof
+
diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli
index 08ae7519..2700e901 100644
--- a/proofs/proof_global.mli
+++ b/proofs/proof_global.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        *)
@@ -28,14 +28,13 @@ type proof_mode = {
     It corresponds to Coq default setting are they are set when coqtop starts. *)
 val register_proof_mode : proof_mode -> unit
 
-val there_is_a_proof : unit -> bool
 val there_are_pending_proofs : unit -> bool
 val check_no_pending_proof : unit -> unit
 
-val get_current_proof_name : unit -> Names.identifier
-val get_all_proof_names : unit -> Names.identifier list
+val get_current_proof_name : unit -> Names.Id.t
+val get_all_proof_names : unit -> Names.Id.t list
 
-val discard : Names.identifier Util.located -> unit
+val discard : Names.Id.t Loc.located -> unit
 val discard_current : unit -> unit
 val discard_all : unit -> unit
 
@@ -45,53 +44,102 @@ val set_proof_mode : string -> unit
 
 exception NoCurrentProof
 val give_me_the_proof : unit -> Proof.proof
+(** @raise NoCurrentProof when outside proof mode. *)
 
+val compact_the_proof : unit -> unit
 
-(** [start_proof s str goals ~init_tac ~compute_guard hook] starts 
-    a proof of name [s] and
-    conclusion [t]; [hook] is optionally a function to be applied at
-    proof end (e.g. to declare the built constructions as a coercion
-    or a setoid morphism). *)
+(** When a proof is closed, it is reified into a [proof_object], where
+    [id] is the name of the proof, [entries] the list of the proof terms
+    (in a form suitable for definitions). Together with the [terminator]
+    function which takes a [proof_object] together with a [proof_end]
+    (i.e. an proof ending command) and registers the appropriate
+    values. *)
 type lemma_possible_guards = int list list
-val start_proof : Names.identifier -> 
-                          Decl_kinds.goal_kind ->
-                          (Environ.env * Term.types) list  ->
-                          ?compute_guard:lemma_possible_guards -> 
-                          Tacexpr.declaration_hook -> 
-                          unit
-
-val close_proof : unit -> 
-                           Names.identifier * 
-                          (Entries.definition_entry list * 
-			    lemma_possible_guards * 
-			    Decl_kinds.goal_kind * 
-			    Tacexpr.declaration_hook)
+type proof_universes = Evd.evar_universe_context
+type proof_object = {
+  id : Names.Id.t;
+  entries : Entries.definition_entry list;
+  persistence : Decl_kinds.goal_kind;
+  universes: proof_universes;
+  (* constraints : Univ.constraints; *)
+  (** guards : lemma_possible_guards; *)
+}
+
+type proof_ending =
+  | Admitted
+  | Proved of Vernacexpr.opacity_flag *
+             (Vernacexpr.lident * Decl_kinds.theorem_kind option) option *
+              proof_object
+type proof_terminator = proof_ending -> unit
+type closed_proof = proof_object * proof_terminator
+
+(** [start_proof id str goals terminator] starts a proof of name [id]
+    with goals [goals] (a list of pairs of environment and
+    conclusion); [str] describes what kind of theorem/definition this
+    is (spiwack: for potential printing, I believe is used only by
+    closing commands and the xml plugin); [terminator] is used at the
+    end of the proof to close the proof. *)
+val start_proof :
+  Evd.evar_map -> Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list  ->
+    proof_terminator -> unit
+
+(** Like [start_proof] except that there may be dependencies between
+    initial goals. *)
+val start_dependent_proof :
+  Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope  ->
+    proof_terminator -> unit
+
+(* Takes a function to add to the exceptions data relative to the
+   state in which the proof was built *)
+val close_proof : keep_body_ucst_sepatate:bool -> Future.fix_exn -> closed_proof
+
+(* Intermediate step necessary to delegate the future.
+ * Both access the current proof state. The formes is supposed to be
+ * chained with a computation that completed the proof *)
+
+type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context
+
+val return_proof : unit -> closed_proof_output
+val close_future_proof : feedback_id:Stateid.t ->
+  closed_proof_output Future.computation -> closed_proof
+
+(** Gets the current terminator without checking that the proof has
+    been completed. Useful for the likes of [Admitted]. *)
+val get_terminator : unit -> proof_terminator
+val set_terminator : proof_terminator -> unit
 
 exception NoSuchProof
 
-(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is 
-   no current proof. *)
-val run_tactic : unit Proofview.tactic -> unit
+val get_open_goals : unit -> int
 
-(** Sets the tactic to be used when a tactic line is closed with [...] *)
-val set_endline_tactic : unit Proofview.tactic -> unit
+(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is
+    no current proof.
+    The return boolean is set to [false] if an unsafe tactic has been used. *)
+val with_current_proof :
+  (unit Proofview.tactic -> Proof.proof -> Proof.proof*'a) -> 'a
+val simple_with_current_proof :
+  (unit Proofview.tactic -> Proof.proof -> Proof.proof) -> unit
 
-(** Sets the section variables assumed by the proof *)
-val set_used_variables : Names.identifier list -> unit
-val get_used_variables : unit -> Sign.section_context option
+(** Sets the tactic to be used when a tactic line is closed with [...] *)
+val set_endline_tactic : Tacexpr.raw_tactic_expr -> unit
+val set_interp_tac :
+  (Tacexpr.raw_tactic_expr -> unit Proofview.tactic)
+    -> unit
 
-(** Appends the endline tactic of the current proof to a tactic. *)
-val with_end_tac : unit Proofview.tactic -> unit Proofview.tactic
+(** Sets the section variables assumed by the proof, returns its closure
+ * (w.r.t. type dependencies *)
+val set_used_variables : Names.Id.t list -> Context.section_context
+val get_used_variables : unit -> Context.section_context option
 
 (**********************************************************)
-(*                                                                                                  *)
-(*                              Utility functions                                          *)
-(*                                                                                                  *)
+(*                                                        *)
+(*                            Proof modes                 *)
+(*                                                        *)
 (**********************************************************)
 
-(** [maximal_unfocus k p] unfocuses [p] until [p] has at least a
-    focused goal or that the last focus isn't of kind [k]. *)
-val maximal_unfocus : 'a Proof.focus_kind -> Proof.proof -> unit
+
+val activate_proof_mode : string -> unit
+val disactivate_proof_mode : string -> unit
 
 (**********************************************************)
 (*                                                        *)
@@ -103,11 +151,13 @@ module Bullet : sig
   type t = Vernacexpr.bullet
 
   (** A [behavior] is the data of a put function which
-      is called when a bullet prefixes a tactic, together
-      with a name to identify it. *)
+      is called when a bullet prefixes a tactic, a suggest function
+      suggesting the right bullet to use on a given proof, together
+      with a name to identify the behavior. *)
   type behavior = {
     name : string;
-    put : Proof.proof -> t -> unit
+    put : Proof.proof -> t -> Proof.proof;
+    suggest: Proof.proof -> string option
   }
 
   (** A registered behavior can then be accessed in Coq
@@ -123,9 +173,25 @@ module Bullet : sig
 
   (** Handles focusing/defocusing with bullets:
        *)
-  val put : Proof.proof -> t -> unit
+  val put : Proof.proof -> t -> Proof.proof
+  val suggest : Proof.proof -> string option
 end
 
+
+(**********************************************************)
+(*                                                        *)
+(*                     Default goal selector              *)
+(*                                                        *)
+(**********************************************************)
+
+val get_default_goal_selector : unit -> Vernacexpr.goal_selector
+
 module V82 : sig
-  val get_current_initial_conclusions : unit -> Names.identifier *(Term.types list * Decl_kinds.goal_kind * Tacexpr.declaration_hook)
+  val get_current_initial_conclusions : unit -> Names.Id.t *(Term.types list *
+  Decl_kinds.goal_kind)
 end
+
+type state
+val freeze : marshallable:[`Yes | `No | `Shallow] -> state
+val unfreeze : state -> unit
+val proof_of_state : state -> Proof.proof
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
index c56f8a24..26bb78df 100644
--- a/proofs/proof_type.ml
+++ b/proofs/proof_type.ml
@@ -1,104 +1,53 @@
 (************************************************************************)
 (*  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 Environ
 open Evd
 open Names
-open Libnames
 open Term
-open Util
+open Context
 open Tacexpr
-(* open Decl_expr *)
 open Glob_term
-open Genarg
 open Nametab
-open Pattern
+open Misctypes
 (*i*)
 
 (* This module defines the structure of proof tree and the tactic type. So, it
    is used by Proof_tree and Refiner *)
 
+(** Types of goals, tactics, rules ... *)
+
 type goal = Goal.goal
 
 type tactic = goal sigma -> goal list sigma 
 
 type prim_rule =
-  | Intro of identifier
-  | Cut of bool * bool * identifier * types
-  | FixRule of identifier * int * (identifier * int * constr) list * int
-  | Cofix of identifier * (identifier * constr) list * int
+  | Cut of bool * bool * Id.t * types
+  | FixRule of Id.t * int * (Id.t * int * constr) list * int
+  | Cofix of Id.t * (Id.t * constr) list * int
   | Refine of constr
-  | Convert_concl of types * cast_kind
-  | Convert_hyp of named_declaration
-  | Thin of identifier list
-  | ThinBody of identifier list
-  | Move of bool * identifier * identifier move_location
-  | Order of identifier list
-  | Rename of identifier * identifier
-  | Change_evars
-
-type proof_tree = {
-  goal : goal;
-  ref : (rule * proof_tree list) option }
-
-and rule =
-  | Prim of prim_rule
-  | Nested of compound_rule * proof_tree
-  | Decl_proof of bool
-  | Daimon
+  | Thin of Id.t list
+  | Move of Id.t * Id.t move_location
 
-and compound_rule=
-  | Tactic of tactic_expr * bool
+(** Nowadays, the only rules we'll consider are the primitive rules *)
 
-and tactic_expr =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_tactic_expr
+type rule = prim_rule
 
-and atomic_tactic_expr =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_atomic_tactic_expr
-
-and tactic_arg =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_tactic_arg
+(** Ltac traces *)
 
 type ltac_call_kind =
-  | LtacNotationCall of string
+  | LtacMLCall of glob_tactic_expr
+  | LtacNotationCall of KerName.t
   | LtacNameCall of ltac_constant
-  | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
-  | LtacVarCall of identifier * glob_tactic_expr
-  | LtacConstrInterp of glob_constr *
-      (extended_patvar_map * (identifier * identifier option) list)
-
-type ltac_trace = (int * loc * ltac_call_kind) list
+  | LtacAtomCall of glob_atomic_tactic_expr
+  | LtacVarCall of Id.t * glob_tactic_expr
+  | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
 
-exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn
+type ltac_trace = (Loc.t * ltac_call_kind) list
 
-let abstract_tactic_box = ref (ref None)
+let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make ()
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index 6fa8087e..e709be5b 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -1,44 +1,34 @@
 (************************************************************************)
 (*  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 Environ
 open Evd
 open Names
-open Libnames
 open Term
-open Util
+open Context
 open Tacexpr
 open Glob_term
-open Genarg
 open Nametab
-open Pattern
+open Misctypes
 
 (** This module defines the structure of proof tree and the tactic type. So, it
    is used by [Proof_tree] and [Refiner] *)
 
-type goal = Goal.goal
-
-type tactic = goal sigma -> goal list sigma
-
 type prim_rule =
-  | Intro of identifier
-  | Cut of bool * bool * identifier * types
-  | FixRule of identifier * int * (identifier * int * constr) list * int
-  | Cofix of identifier * (identifier * constr) list * int
+  | Cut of bool * bool * Id.t * types
+  | FixRule of Id.t * int * (Id.t * int * constr) list * int
+  | Cofix of Id.t * (Id.t * constr) list * int
   | Refine of constr
-  | Convert_concl of types * cast_kind
-  | Convert_hyp of named_declaration
-  | Thin of identifier list
-  | ThinBody of identifier list
-  | Move of bool * identifier * identifier move_location
-  | Order of identifier list
-  | Rename of identifier * identifier
-  | Change_evars
+  | Thin of Id.t list
+  | Move of Id.t * Id.t move_location
+
+(** Nowadays, the only rules we'll consider are the primitive rules *)
+
+type rule = prim_rule
 
 (** The type [goal sigma] is the type of subgoal. It has the following form
 {v   it    = \{ evar_concl = [the conclusion of the subgoal]
@@ -65,70 +55,22 @@ type prim_rule =
                                               in the type of evar] \} \} \} v}
 *)
 
-(** {6 ... } *)
-(** Proof trees.
-  [ref] = [None] if the goal has still to be proved,
-  and [Some (r,l)] if the rule [r] was applied to the goal
-  and gave [l] as subproofs to be completed.
-  if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof
-  that the goal can be proven if the goals in [l] are solved. *)
-type proof_tree = {
-  goal : goal;
-  ref : (rule * proof_tree list) option }
-
-and rule =
-  | Prim of prim_rule
-  | Nested of compound_rule * proof_tree
-  | Decl_proof of bool
-  | Daimon
-
-and compound_rule=
-  (** the boolean of Tactic tells if the default tactic is used *)
-  | Tactic of tactic_expr * bool
+type goal = Goal.goal
 
-and tactic_expr =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_tactic_expr
+type tactic = goal sigma -> goal list sigma
 
-and atomic_tactic_expr =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_atomic_tactic_expr
+(** Ltac traces *)
 
-and tactic_arg =
-  (constr,
-   constr_pattern,
-   evaluable_global_reference,
-   inductive,
-   ltac_constant,
-   identifier,
-   glob_tactic_expr,
-   tlevel)
-     Tacexpr.gen_tactic_arg
+(** TODO: Move those definitions somewhere sensible *)
 
 type ltac_call_kind =
-  | LtacNotationCall of string
+  | LtacMLCall of glob_tactic_expr
+  | LtacNotationCall of KerName.t
   | LtacNameCall of ltac_constant
-  | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref
-  | LtacVarCall of identifier * glob_tactic_expr
-  | LtacConstrInterp of glob_constr *
-      (extended_patvar_map * (identifier * identifier option) list)
-
-type ltac_trace = (int * loc * ltac_call_kind) list
+  | LtacAtomCall of glob_atomic_tactic_expr
+  | LtacVarCall of Id.t * glob_tactic_expr
+  | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map
 
-exception LtacLocated of (int * ltac_call_kind * ltac_trace * loc) * exn
+type ltac_trace = (Loc.t * ltac_call_kind) list
 
-val abstract_tactic_box : atomic_tactic_expr option ref ref
+val ltac_trace_info : ltac_trace Exninfo.t
diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml
new file mode 100644
index 00000000..f66e9657
--- /dev/null
+++ b/proofs/proof_using.ml
@@ -0,0 +1,166 @@
+(************************************************************************)
+(*  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 Names
+open Environ
+open Util
+open Vernacexpr
+
+let to_string = function
+  | SsAll -> "All"
+  | SsType -> "Type"
+  | SsExpr(SsSet l)-> String.concat " " (List.map Id.to_string (List.map snd l))
+  | SsExpr e ->
+      let rec aux = function
+        | SsSet [] -> "( )"
+        | SsSet [_,x] -> Id.to_string x
+        | SsSet l ->
+          "(" ^ String.concat " " (List.map Id.to_string (List.map snd l)) ^ ")"
+        | SsCompl e -> "-" ^ aux e^""
+        | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")"
+        | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")"
+      in aux e
+
+let known_names = Summary.ref [] ~name:"proofusing-nameset"
+
+let in_nameset =
+  let open Libobject in
+  declare_object { (default_object "proofusing-nameset") with
+    cache_function = (fun (_,x) -> known_names := x :: !known_names);
+    classify_function = (fun _ -> Dispose);
+    discharge_function = (fun _ -> None)
+  }
+
+let rec process_expr env e ty =
+  match e with
+  | SsAll ->
+      List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty
+  | SsExpr e ->
+      let rec aux = function
+        | SsSet l -> set_of_list env (List.map snd l)
+        | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2)
+        | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2)
+        | SsCompl e -> Id.Set.diff (full_set env) (aux e)
+      in
+        aux e
+  | SsType ->
+      List.fold_left (fun acc ty ->
+        Id.Set.union (global_vars_set env ty) acc)
+      Id.Set.empty ty
+and set_of_list env = function
+  | [x] when CList.mem_assoc_f Id.equal x !known_names ->
+      process_expr env (CList.assoc_f Id.equal x !known_names) []
+  | l -> List.fold_right Id.Set.add l Id.Set.empty
+and full_set env = set_of_list env (List.map pi1 (named_context env))
+
+let process_expr env e ty =
+  let s = Id.Set.union (process_expr env SsType ty) (process_expr env e []) in
+  Id.Set.elements s
+
+let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr))
+
+let minimize_hyps env ids =
+  let rec aux ids =
+    let ids' =
+      Id.Set.fold (fun id alive ->
+        let impl_by_id =
+          Id.Set.remove id (really_needed env (Id.Set.singleton id)) in
+        if Id.Set.is_empty impl_by_id then alive
+        else Id.Set.diff alive impl_by_id)
+      ids ids in
+    if Id.Set.equal ids ids' then ids else aux ids'
+  in
+    aux ids
+
+let minimize_unused_hyps env ids =
+  let all_ids = List.map pi1 (named_context env) in
+  let deps_of =
+    let cache =
+      List.map (fun id -> id,really_needed env (Id.Set.singleton id)) all_ids in
+    fun id -> List.assoc id cache in
+  let inv_dep_of =
+    let cache_sum cache id stuff =
+      try Id.Map.add id (Id.Set.add stuff (Id.Map.find id cache)) cache
+      with Not_found -> Id.Map.add id (Id.Set.singleton stuff) cache in
+    let cache =
+      List.fold_left (fun cache id ->
+        Id.Set.fold (fun d cache -> cache_sum cache d id)
+          (Id.Set.remove id (deps_of id)) cache)
+        Id.Map.empty all_ids in
+    fun id -> try Id.Map.find id cache with Not_found -> Id.Set.empty in
+  let rec aux s =
+    let s' =
+      Id.Set.fold (fun id s ->
+        if Id.Set.subset (inv_dep_of id) s then Id.Set.diff s (inv_dep_of id)
+        else s)
+      s s in
+    if Id.Set.equal s s' then s else aux s' in
+  aux ids
+
+let suggest_Proof_using kn env vars ids_typ context_ids =
+  let module S = Id.Set in
+  let open Pp in
+  let used = S.union vars ids_typ in
+  let needed = minimize_hyps env used in
+  let all_needed = really_needed env needed in
+  let all = List.fold_right S.add context_ids S.empty in
+  let unneeded = minimize_unused_hyps env (S.diff all needed) in
+  let pr_set s =
+    let wrap ppcmds =
+      if S.cardinal s > 1 || S.equal s (S.singleton (Id.of_string "All"))
+      then str "(" ++ ppcmds ++ str ")"
+      else ppcmds in
+    wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in
+  if !Flags.debug then begin
+    prerr_endline (string_of_ppcmds (str "All " ++ pr_set all));
+    prerr_endline (string_of_ppcmds (str "Type" ++ pr_set ids_typ));
+    prerr_endline (string_of_ppcmds (str "needed " ++ pr_set needed));
+    prerr_endline (string_of_ppcmds (str "unneeded " ++ pr_set unneeded));
+  end;
+  msg_info (
+    str"The proof of "++
+    Names.Constant.print kn ++ spc() ++ str "should start with:"++spc()++
+    str"Proof using " ++
+    if S.is_empty needed then str "."
+    else if S.subset needed ids_typ then str "Type."
+    else if S.equal all all_needed then str "All."
+    else 
+      let s1 = string_of_ppcmds (str "-" ++ pr_set unneeded ++ str".") in
+      let s2 = string_of_ppcmds (pr_set needed ++ str".") in
+      if String.length s1 < String.length s2 then str s1 else str s2)
+
+let value = ref false
+
+let _ =
+  Goptions.declare_bool_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "suggest Proof using";
+      Goptions.optkey   = ["Suggest";"Proof";"Using"];
+      Goptions.optread  = (fun () -> !value);
+      Goptions.optwrite = (fun b ->
+        value := b;
+        if b then Term_typing.set_suggest_proof_using suggest_Proof_using
+        else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> ())
+      ) }
+
+let value = ref "_unset_"
+
+let _ =
+  Goptions.declare_string_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "default value for Proof using";
+      Goptions.optkey   = ["Default";"Proof";"Using"];
+      Goptions.optread  = (fun () -> !value);
+      Goptions.optwrite = (fun b -> value := b;) }
+
+
+let get_default_proof_using () =
+  if !value = "_unset_" then None
+  else Some !value
diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli
new file mode 100644
index 00000000..fb3497f1
--- /dev/null
+++ b/proofs/proof_using.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+
+(* [minimize_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true]
+ * and [keep_hyps e s1] is equal to [keep_hyps e s2].  Inefficient. *)
+val minimize_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t
+
+(* [minimize_unused_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true]
+ * and s.t. calling [clear s1] would do the same as [clear s2].  Inefficient. *)
+val minimize_unused_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t
+
+val process_expr :
+  Environ.env -> Vernacexpr.section_subset_descr -> Constr.types list ->
+    Names.Id.t list
+
+val name_set : Names.Id.t -> Vernacexpr.section_subset_descr -> unit
+
+val to_string : Vernacexpr.section_subset_descr -> string
+
+val get_default_proof_using : unit -> string option
diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib
index 66001e77..32bf5576 100644
--- a/proofs/proofs.mllib
+++ b/proofs/proofs.mllib
@@ -1,12 +1,16 @@
+Miscprint
 Goal
 Evar_refiner
+Proof_using
+Proof_type
+Proof_errors
+Logic_monad
+Proofview_monad
+Logic
 Proofview
 Proof
 Proof_global
-Tacexpr
-Proof_type
 Redexpr
-Logic
 Refiner
 Tacmach
 Pfedit
diff --git a/proofs/proofview.ml b/proofs/proofview.ml
index 17be1f7d..a25683bf 100644
--- a/proofs/proofview.ml
+++ b/proofs/proofview.ml
@@ -1,525 +1,1175 @@
 (************************************************************************)
 (*  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
-
-(* The proofview datastructure is a pure datastructure underlying the notion
-   of proof (namely, a proof is a proofview which can evolve and has safety
-   mechanisms attached).
-   The general idea of the structure is that it is composed of a chemical
-   solution: an unstructured bag of stuff which has some relations with 
-   one another, which represents the various subnodes of the proof, together
-   with a comb: a datastructure that gives order to some of these nodes, 
-   namely the open goals. 
-   The natural candidate for the solution is an {!Evd.evar_map}, that is
-   a calculus of evars. The comb is then a list of goals (evars wrapped 
-   with some extra information, like possible name anotations).
-   There is also need of a list of the evars which initialised the proofview
-   to be able to return information about the proofview. *)
-
-(* Type of proofviews. *)
-type proofview = {
-     initial : (Term.constr * Term.types) list;
-     solution : Evd.evar_map;
-     comb : Goal.goal list
-     }
 
+(** This files defines the basic mechanism of proofs: the [proofview]
+    type is the state which tactics manipulate (a global state for
+    existential variables, together with the list of goals), and the type
+    ['a tactic] is the (abstract) type of tactics modifying the proof
+    state and returning a value of type ['a]. *)
+
+open Pp
+open Util
+open Proofview_monad
+
+(** Main state of tactics *)
+type proofview = Proofview_monad.proofview
+
+type entry = (Term.constr * Term.types) list
+
+(** Returns a stylised view of a proofview for use by, for instance,
+    ide-s. *)
+(* spiwack: the type of [proofview] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: returns the list of focused goals together with
+   the [evar_map] context. *)
 let proofview p =
   p.comb , p.solution
 
-(* Initialises a proofview, the argument is a list of environement, 
-   conclusion types, and optional names, creating that many initial goals. *)
-let init = 
+let compact el { comb; solution } =
+  let nf = Evarutil.nf_evar solution in
+  let size = Evd.fold (fun _ _ i -> i+1) solution 0 in
+  let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in
+  let pruned_solution = Evd.drop_all_defined solution in
+  let apply_subst_einfo _ ei =
+    Evd.({ ei with
+       evar_concl =  nf ei.evar_concl;
+       evar_hyps = Environ.map_named_val nf ei.evar_hyps;
+       evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in
+  let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in
+  let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in
+  msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size));
+  new_el, { comb; solution = new_solution }
+
+
+(** {6 Starting and querying a proof view} *)
+
+type telescope =
+  | TNil of Evd.evar_map
+  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
+
+let dependent_init =
+  (* Goals are created with a store which marks them as unresolvable
+     for type classes. *)
+  let store = Typeclasses.set_resolvable Evd.Store.empty false in
+  (* Goals don't have a source location. *)
+  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+  (* Main routine *)
   let rec aux = function
-  | [] ->  { initial = [] ; 
-	     solution = Evd.empty ;
-	     comb = []
-	   }
-  | (env,typ)::l -> let { initial = ret ; solution = sol ; comb = comb } =
-                           aux l
-                         in
-                         let ( new_defs , econstr ) = 
-			   Evarutil.new_evar sol env typ
-			 in
-			 let (e,_) = Term.destEvar econstr in
-			 let gl = Goal.build e in
-			 { initial = (econstr,typ)::ret;
-			   solution = new_defs ;
-			   comb = gl::comb }
+  | TNil sigma -> [], { solution = sigma; comb = []; }
+  | TCons (env, sigma, typ, t) ->
+    let (sigma, econstr ) = Evarutil.new_evar env sigma ~src ~store typ in
+    let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in
+    let (gl, _) = Term.destEvar econstr in
+    let entry = (econstr, typ) :: ret in
+    entry, { solution = sol; comb = gl :: comb; }
+  in
+  fun t ->
+    let entry, v = aux t in
+    (* The created goal are not to be shelved. *)
+    let solution = Evd.reset_future_goals v.solution in
+    entry, { v with solution }
+
+let init =
+  let rec aux sigma = function
+    | [] -> TNil sigma
+    | (env,g)::l -> TCons (env,sigma,g,(fun sigma _ -> aux sigma l))
   in
-  fun l -> let v = aux l in
-    (* Marks all the goal unresolvable for typeclasses. *)
-    { v with solution = Typeclasses.mark_unresolvables v.solution }
+  fun sigma l -> dependent_init (aux sigma l)
+
+let initial_goals initial = initial
 
-(* Returns whether this proofview is finished or not. That is,
-   if it has empty subgoals in the comb. There could still be unsolved
-   subgoaled, but they would then be out of the view, focused out. *)
 let finished = function
   | {comb = []} -> true
   | _  -> false
 
-(* Returns the current value of the proofview partial proofs. *)
-let return { initial=init; solution=defs }  =
-  List.map (fun (c,t) -> (Evarutil.nf_evar defs c , t)) init
-
-(* spiwack: this function should probably go in the Util section,
-    but I'd rather have Util (or a separate module for lists)
-    raise proper exceptions before *)
-(* [IndexOutOfRange] occurs in case of malformed indices
-   with respect to list lengths. *)
-exception IndexOutOfRange
-(* no handler: should not be allowed to reach toplevel *)
-
-(* [list_goto i l] returns a pair of lists [c,t] where
-   [c] has length [i] and is the reversed of the [i] first
-   elements of [l], and [t] is the rest of the list.
-   The idea is to navigate through the list, [c] is then
-   seen as the context of the current position. 
-   Raises [IndexOutOfRange] if [i > length l]*)
-let list_goto = 
-  let rec aux acc index = function
-    | l when index = 0-> (acc,l)
-    | [] -> raise IndexOutOfRange
-    | a::q -> aux (a::acc) (index-1) q
-  in
-  fun i l ->
-    if i < 0 then
-      raise IndexOutOfRange
-    else
-      aux [] i l
-
-(* Type of the object which allow to unfocus a view.*)
-(* First component is a reverse list of what comes before
-   and second component is what goes after (in the expected
-   order) *)
-type focus_context = Goal.goal list * Goal.goal list
+let return { solution=defs } = defs
+
+let return_constr { solution = defs } c = Evarutil.nf_evar defs c
+
+let partial_proof entry pv = CList.map (return_constr pv) (CList.map fst entry)
 
+
+(** {6 Focusing commands} *)
+
+(** A [focus_context] represents the part of the proof view which has
+    been removed by a focusing action, it can be used to unfocus later
+    on. *)
+(* First component is a reverse list of the goals which come before
+   and second component is the list of the goals which go after (in
+   the expected order). *)
+type focus_context = Evar.t list * Evar.t list
+
+
+(** Returns a stylised view of a focus_context for use by, for
+    instance, ide-s. *)
+(* spiwack: the type of [focus_context] will change as we push more
+   refined functions to ide-s. This would be better than spawning a
+   new nearly identical function everytime. Hence the generic name. *)
+(* In this version: the goals in the context, as a "zipper" (the first
+   list is in reversed order). *)
 let focus_context f = f
 
-(* This (internal) function extracts a sublist between two indices, and
-   returns this sublist together with its context:
-   if it returns [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
-   original list.
-   The focused list has lenght [j-i-1] and contains the goals from
-   number [i] to number [j] (both included) the first goal of the list
-   being numbered [1].
-   [focus_sublist i j l] raises [IndexOutOfRange] if
-   [i > length l], or [j > length l] or [ j < i ].  *)
+(** This (internal) function extracts a sublist between two indices,
+    and returns this sublist together with its context: if it returns
+    [(a,(b,c))] then [a] is the sublist and (rev b)@a@c is the
+    original list.  The focused list has lenght [j-i-1] and contains
+    the goals from number [i] to number [j] (both included) the first
+    goal of the list being numbered [1].  [focus_sublist i j l] raises
+    [IndexOutOfRange] if [i > length l], or [j > length l] or [j <
+    i]. *)
 let focus_sublist i j l =
-  let (left,sub_right) = list_goto (i-1) l in
+  let (left,sub_right) = CList.goto (i-1) l in
   let (sub, right) = 
-    try 
-      Util.list_chop (j-i+1) sub_right 
-    with Failure "list_chop" -> 
-      Util.errorlabstrm "nth_unproven" (Pp.str"No such unproven subgoal")
+    try CList.chop (j-i+1) sub_right
+    with Failure _ -> raise CList.IndexOutOfRange
   in
   (sub, (left,right))
 
-(* Inverse operation to the previous one. *)
+(** Inverse operation to the previous one. *)
 let unfocus_sublist (left,right) s =
-  List.rev_append left (s@right)
+  CList.rev_append left (s@right)
 
 
-(* [focus i j] focuses a proofview on the goals from index [i] to index [j] 
-   (inclusive). (i.e. goals number [i] to [j] become the only goals of the
-   returned proofview). The first goal has index 1.
-   It returns the focus proof, and a context for the focus trace. *)
+(** [focus i j] focuses a proofview on the goals from index [i] to
+    index [j] (inclusive, goals are indexed from [1]). I.e. goals
+    number [i] to [j] become the only focused goals of the returned
+    proofview.  It returns the focused proofview, and a context for
+    the focus stack. *)
 let focus i j sp =
   let (new_comb, context) = focus_sublist i j sp.comb in
   ( { sp with comb = new_comb } , context )
 
-(* Unfocuses a proofview with respect to a context. *)
-let undefined defs l =
-  Option.List.flatten (List.map (Goal.advance defs) l)
+
+(** [advance sigma g] returns [Some g'] if [g'] is undefined and is
+    the current avatar of [g] (for instance [g] was changed by [clear]
+    into [g']). It returns [None] if [g] has been (partially)
+    solved. *)
+(* spiwack: [advance] is probably performance critical, and the good
+   behaviour of its definition may depend sensitively to the actual
+   definition of [Evd.find]. Currently, [Evd.find] starts looking for
+   a value in the heap of undefined variable, which is small. Hence in
+   the most common case, where [advance] is applied to an unsolved
+   goal ([advance] is used to figure if a side effect has modified the
+   goal) it terminates quickly. *)
+let rec advance sigma g =
+  let open Evd in
+  let evi = Evd.find sigma g in
+  match evi.evar_body with
+  | Evar_empty -> Some g
+  | Evar_defined v ->
+      if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then
+        let (e,_) = Term.destEvar v in
+        advance sigma e
+      else
+        None
+
+(** [undefined defs l] is the list of goals in [l] which are still
+    unsolved (after advancing cleared goals). *)
+let undefined defs l = CList.map_filter (advance defs) l
+
+(** Unfocuses a proofview with respect to a context. *)
 let unfocus c sp =
   { sp with comb = undefined sp.solution (unfocus_sublist c sp.comb) }
 
 
-(* The tactic monad:
-   - Tactics are objects which apply a transformation to all
-     the subgoals of the current view at the same time. By opposed
-     to the old vision of applying it to a single goal. It mostly 
-     allows to consider tactic like [reorder] to reorder the goals
-     in the current view (which might be useful for the tactic designer)
-     (* spiwack: the ordering of goals, though, is perhaps a bit
-        brittle. It would be much more interesting to find a more
-        robust way to adress goals, I have no idea at this time 
-        though*) 
-     or global automation tactic for dependent subgoals (instantiating
-     an evar has influences on the other goals of the proof in progress,
-     not being able to take that into account causes the current eauto
-     tactic to fail on some instances where it could succeed).
-   - Tactics are a monad ['a tactic], in a sense a tactic can be 
-     seens as a function (without argument) which returns a value
-     of type 'a and modifies the environement (in our case: the view).
-     Tactics of course have arguments, but these are given at the 
-     meta-level as OCaml functions.
-     Most tactics, in the sense we are used to, return [ () ], that is
-     no really interesting values. But some might pass information 
-     around; the [(>>--)] and [(>>==)] bind-like construction are the
-     main ingredients of this information passing. 
-     (* spiwack: I don't know how much all this relates to F. Kirchner and 
-        C. Muñoz. I wasn't able to understand how they used the monad
-        structure in there developpement.
-     *)
-     The tactics seen in Coq's Ltac are (for now at least) only 
-     [unit tactic], the return values are kept for the OCaml toolkit.
-     The operation or the monad are [Proofview.tclUNIT] (which is the 
-     "return" of the tactic monad) [Proofview.tclBIND] (which is
-     the "bind", also noted [(>=)]) and [Proofview.tclTHEN] (which is a
-     specialized bind on unit-returning tactics).
+(** {6 The tactic monad} *)
+
+(** - Tactics are objects which apply a transformation to all the
+    subgoals of the current view at the same time. By opposition to
+    the old vision of applying it to a single goal. It allows tactics
+    such as [shelve_unifiable], tactics to reorder the focused goals,
+    or global automation tactic for dependent subgoals (instantiating
+    an evar has influences on the other goals of the proof in
+    progress, not being able to take that into account causes the
+    current eauto tactic to fail on some instances where it could
+    succeed).  Another benefit is that it is possible to write tactics
+    that can be executed even if there are no focused goals.
+    - Tactics form a monad ['a tactic], in a sense a tactic can be
+    seens as a function (without argument) which returns a value of
+    type 'a and modifies the environement (in our case: the view).
+    Tactics of course have arguments, but these are given at the
+    meta-level as OCaml functions.  Most tactics in the sense we are
+    used to return [()], that is no really interesting values. But
+    some might pass information around.  The tactics seen in Coq's
+    Ltac are (for now at least) only [unit tactic], the return values
+    are kept for the OCaml toolkit.  The operation or the monad are
+    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
+    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
+    (which is a specialized bind on unit-returning tactics).
+    - Tactics have support for full-backtracking. Tactics can be seen
+    having multiple success: if after returning the first success a
+    failure is encountered, the tactic can backtrack and use a second
+    success if available. The state is backtracked to its previous
+    value, except the non-logical state defined in the {!NonLogical}
+    module below.
 *)
+(* spiwack: as far as I'm aware this doesn't really relate to
+   F. Kirchner and C. Muñoz. *)
 
-(* type of tactics *)
-(* spiwack: double-continuation backtracking monads are reasonable
-    folklore for "search" implementations (including Tac interactive prover's
-    tactics). Yet it's quite hard to wrap your head around these.
-    I recommand reading a few times the "Backtracking, Interleaving, and Terminating
-    Monad Transformers" paper by O. Kiselyov, C. Chen, D. Fridman.  
-    The peculiar shape of the monadic type is reminiscent of that of the continuation
-    monad transformer.
-    A good way to get a feel of what's happening is to look at what happens when
-    executing [apply (tclUNIT ())]. 
-    The disjunction function is unlike that of the LogicT paper, because we want and 
-    need to backtrack over state as well as values. Therefore we cannot be
-    polymorphic over the inner monad. *)
-type proof_step = { goals : Goal.goal list ; defs : Evd.evar_map }
-type +'a result = { proof_step : proof_step ;
-		                content : 'a }
-
-(* nb=non-backtracking *)
-type +'a nb_tactic  = proof_step -> 'a result
-
-(* double-continutation backtracking *)
-(* "sk" stands for "success continuation", "fk" for "failure continuation" *)
-type 'r fk = exn -> 'r
-type (-'a,'r) sk = 'a -> 'r fk -> 'r
-type +'a tactic0 = { go : 'r. ('a, 'r nb_tactic) sk -> 'r nb_tactic fk -> 'r nb_tactic }
-
-(* We obtain a tactic by parametrizing with an environment *)
-(* spiwack: alternatively the environment could be part of the "nb_tactic" state
-    monad. As long as we do not intend to change the environment during a tactic,
-    it's probably better here. *)
-type +'a tactic = Environ.env -> 'a tactic0
-
-(* unit of [nb_tactic] *)
-let nb_tac_unit a step = { proof_step = step ; content = a }
-
-(* Applies a tactic to the current proofview. *)
-let apply env t sp  = 
-  let start = { goals = sp.comb ; defs = sp.solution } in
-  let res = (t env).go (fun a _ step -> nb_tac_unit a step) (fun e _ -> raise e) start in
-  let next = res.proof_step in
-  {sp with
-     solution = next.defs ;
-     comb = next.goals
-  }
+module Proof = Logical
 
-(*** tacticals ***)
+(** type of tactics:
 
+   tactics can
+   - access the environment,
+   - report unsafe status, shelved goals and given up goals
+   - access and change the current [proofview]
+   - backtrack on previous changes of the proofview *)
+type +'a tactic = 'a Proof.t
 
-(* Unit of the tactic monad *)
-let tclUNIT a _ = { go = fun sk fk step -> sk a fk step }
+(** Applies a tactic to the current proofview. *)
+let apply env t sp =
+  let open Logic_monad in
+  let ans = Proof.repr (Proof.run t false (sp,env)) in
+  let ans = Logic_monad.NonLogical.run ans in
+  match ans with
+  | Nil (e, info) -> iraise (TacticFailure e, info)
+  | Cons ((r, (state, _), status, info), _) ->
+    r, state, status, Trace.to_tree info
 
-(* Bind operation of the tactic monad *)
-let tclBIND t k env = { go = fun sk fk step ->
-  (t env).go (fun a fk -> (k a env).go sk fk) fk step
-}
 
-(* Interpretes the ";" (semicolon) of Ltac.
-   As a monadic operation, it's a specialized "bind"
-   on unit-returning tactic (meaning "there is no value to bind") *)
-let tclTHEN t1 t2 env = { go = fun sk fk step ->
-  (t1 env).go (fun () fk -> (t2 env).go sk fk) fk step
-}
 
-(* [tclIGNORE t] has the same operational content as [t],
-   but drops the value at the end. *)
-let tclIGNORE tac env = { go = fun sk fk step ->
-  (tac env).go (fun _ fk -> sk () fk) fk step
-}
+(** {7 Monadic primitives} *)
 
-(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t1 fails. 
-    No interleaving for the moment. *)
-(* spiwack: compared to the LogicT paper, we backtrack at the same state
-    where [t1] has been called, not the state where [t1] failed. *)
-let tclOR t1 t2 env = { go = fun sk fk step ->
-  (t1 env).go sk (fun _ _ -> (t2 env).go sk fk step) step
-}
+(** Unit of the tactic monad. *)
+let tclUNIT = Proof.return
 
-(* [tclZERO e] always fails with error message [e]*)
-let tclZERO e env = { go = fun _ fk step -> fk e step }
+(** Bind operation of the tactic monad. *)
+let tclBIND = Proof.(>>=)
 
+(** Interpretes the ";" (semicolon) of Ltac. As a monadic operation,
+    it's a specialized "bind". *)
+let tclTHEN = Proof.(>>)
+
+(** [tclIGNORE t] has the same operational content as [t], but drops
+    the returned value. *)
+let tclIGNORE = Proof.ignore
+
+module Monad = Proof
 
-(* Focusing operation on proof_steps. *)
-let focus_proof_step i j ps =
-  let (new_subgoals, context) = focus_sublist i j ps.goals in
-  ( { ps with goals = new_subgoals } , context )
 
-(* Unfocusing operation of proof_steps. *)
-let unfocus_proof_step c ps =
-  { ps with 
-     goals = undefined ps.defs (unfocus_sublist c ps.goals) 
-  }
 
-(* Focuses a tactic at a range of subgoals, found by their indices. *)
-(* arnaud: bug if 0 goals ! *)
-let tclFOCUS i j t env = { go = fun sk fk step ->
-  let (focused,context) = focus_proof_step i j step in
-  (t env).go (fun a fk step -> sk a fk (unfocus_proof_step context step)) fk focused
-}
-
-(* Dispatch tacticals are used to apply a different tactic to each goal under
-    consideration. They come in two flavours:
-    [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic].
-    [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns
-    and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g]
-    corresponds to that of the tactic which created [g].
-    It is to be noted that the return value of [tclDISPATCHS ts] makes only
-    sense in the goals immediatly built by it, and would cause an anomaly
-    is used otherwise. *)
-exception SizeMismatch
+(** {7 Failure and backtracking} *)
+
+
+(** [tclZERO e] fails with exception [e]. It has no success. *)
+let tclZERO ?info e =
+  let info = match info with
+  | None -> Exninfo.null
+  | Some info -> info
+  in
+  Proof.zero (e, info)
+
+(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
+    the successes of [t1] have been depleted and it failed with [e],
+    then it behaves as [t2 e]. In other words, [tclOR] inserts a
+    backtracking point. *)
+let tclOR = Proof.plus
+
+(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
+    success or [t2 e] if [t1] fails with [e]. It is analogous to
+    [try/with] handler of exception in that it is not a backtracking
+    point. *)
+let tclORELSE t1 t2 =
+  let open Logic_monad in
+  let open Proof in
+  split t1 >>= function
+    | Nil e -> t2 e
+    | Cons (a,t1') -> plus (return a) t1'
+
+(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
+    succeeds at least once then it behaves as [tclBIND a s] otherwise,
+    if [a] fails with [e], then it behaves as [f e]. *)
+let tclIFCATCH a s f =
+  let open Logic_monad in
+  let open Proof in
+  split a >>= function
+    | Nil e -> f e
+    | Cons (x,a') -> plus (s x) (fun e -> (a' e) >>= fun x' -> (s x'))
+
+(** [tclONCE t] behave like [t] except it has at most one success:
+    [tclONCE t] stops after the first success of [t]. If [t] fails
+    with [e], [tclONCE t] also fails with [e]. *)
+let tclONCE = Proof.once
+
+exception MoreThanOneSuccess
 let _ = Errors.register_handler begin function
-  | SizeMismatch -> Util.error "Incorrect number of goals."
+  | MoreThanOneSuccess -> Errors.error "This tactic has more than one success."
   | _ -> raise Errors.Unhandled
 end
-(* spiwack: we use an parametrised function to generate the dispatch tacticals.
-    [tclDISPATCHGEN] takes a [null] argument to generate the return value
-    if there are no goal under focus, and a [join] argument to explain how
-    the return value at two given lists of subgoals are combined when
-    both lists are being concatenated.
-    [join] and [null] need be some sort of comutative monoid. *)
-let rec tclDISPATCHGEN null join tacs env = { go = fun sk fk step ->
-  match tacs,step.goals with
-  | [] , [] -> (tclUNIT null env).go sk fk step
-  | t::tacs , first::goals -> 
-      (tclDISPATCHGEN null join tacs env).go
-	begin fun x fk step -> 
-	  match Goal.advance step.defs first with
-	  | None -> sk x fk step
-	  | Some first ->
-	    (t env).go 
-	      begin fun y fk step' -> 
-		sk (join x y) fk { step' with 
-			                   goals = step'.goals@step.goals
-				         }
-	      end 
-	      fk 
-	      { step with goals = [first] }
-	end
-	fk
-	{ step with goals = goals }
-  | _ -> raise SizeMismatch
-}
-
-(* takes a tactic which can raise exception and makes it pure by *failing* 
-    on with these exceptions. Does not catch anomalies. *)
-let purify t = 
-  let t' env =
-    { go = fun sk fk step ->
-      try (t env).go (fun x -> sk (Util.Inl x)) fk step
-      with Util.Anomaly _ as e -> raise e
-	| e when Errors.noncritical e -> sk (Util.Inr e) fk step
-    }
-  in
-  tclBIND t' begin function
-    | Util.Inl x -> tclUNIT x
-    | Util.Inr e -> tclZERO e
-  end
-let tclDISPATCHGEN null join tacs = purify (tclDISPATCHGEN null join tacs)
 
-let unitK () () = ()
-let tclDISPATCH = tclDISPATCHGEN () unitK
+(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
+    success. Otherwise it fails. The tactic [t] is run until its first
+    success, then a failure with exception [e] is simulated. It [t]
+    yields another success, then [tclEXACTLY_ONCE e t] fails with
+    [MoreThanOneSuccess] (it is a user error). Otherwise,
+    [tclEXACTLY_ONCE e t] succeeds with the first success of
+    [t]. Notice that the choice of [e] is relevant, as the presence of
+    further successes may depend on [e] (see {!tclOR}). *)
+let tclEXACTLY_ONCE e t =
+  let open Logic_monad in
+  let open Proof in
+  split t >>= function
+    | Nil (e, info) -> tclZERO ~info e
+    | Cons (x,k) ->
+        Proof.split (k (e, Exninfo.null)) >>= function
+          | Nil _ -> tclUNIT x
+          | _ -> tclZERO MoreThanOneSuccess
 
-let extend_to_list =
-  let rec copy n x l =
-    if n < 0 then raise SizeMismatch
-    else if n = 0 then l
-    else copy (n-1) x (x::l)
+
+(** [tclCASE t] wraps the {!Proofview_monad.Logical.split} primitive. *)
+type 'a case =
+| Fail of iexn
+| Next of 'a * (iexn -> 'a tactic)
+let tclCASE t =
+  let open Logic_monad in
+  let map = function
+  | Nil e -> Fail e
+  | Cons (x, t) -> Next (x, t)
   in
-  fun startxs rx endxs l ->
-    let ns = List.length startxs in
-    let ne = List.length endxs in
-    let n = List.length l in
-    startxs@(copy (n-ne-ns) rx endxs)
-let tclEXTEND tacs1 rtac tacs2 env = { go = fun sk fk step -> 
-  let tacs = extend_to_list tacs1 rtac tacs2 step.goals in
-  (tclDISPATCH tacs env).go sk fk step
-}
-
-(* [tclGOALBIND] and [tclGOALBINDU] are sorts of bind which take a
-    [Goal.sensitive] as a first argument, the tactic then acts on each goal separately.
-    Allows backtracking between goals. *)
-let list_of_sensitive s k env step =
-  Goal.list_map begin fun defs g ->
-    let (a,defs) = Goal.eval s env defs g in
-    (k a) , defs
-  end step.goals step.defs
-(* In form of a tactic *)
-let list_of_sensitive s k env = { go = fun sk fk step ->
-  let (tacs,defs) = list_of_sensitive s k env step in
-  sk tacs fk { step with defs = defs } 
-}
-
-(* This is a helper function for the dispatching tactics (like [tclGOALBIND] and
-    [tclDISPATCHS]). It takes an ['a sensitive] value, and returns a tactic
-    whose return value is, again, ['a sensitive] but only has value in the
-    (unmodified) goals under focus. *)
-let here_s b env = { go = fun sk fk step ->
-  sk (Goal.bind (Goal.here_list step.goals b) (fun b -> b)) fk step
-}
-
-let rec tclGOALBIND s k = 
-  (* spiwack: the first line ensures that the value returned by the tactic [k] will
-      not "escape its scope". *)
-  let k a = tclBIND (k a) here_s in
-  purify begin 
-    tclBIND (list_of_sensitive s k) begin fun tacs ->
-      tclDISPATCHGEN Goal.null Goal.plus tacs
-    end 
-  end
+  Proof.map map (Proof.split t)
+
+let tclBREAK = Proof.break
+
+
+
+(** {7 Focusing tactics} *)
+
+exception NoSuchGoals of int
+
+(* This hook returns a string to be appended to the usual message.
+   Primarily used to add a suggestion about the right bullet to use to
+   focus the next goal, if applicable. *)
+let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None))
+let set_nosuchgoals_hook f = nosuchgoals_hook := f
+
+
+
+(* This uses the hook above *)
+let _ = Errors.register_handler begin function
+  | NoSuchGoals n ->
+    let suffix:string option = (!nosuchgoals_hook) n in
+    Errors.errorlabstrm ""
+      (str "No such " ++ str (String.plural n "goal") ++ str "."
+       ++ pr_opt str suffix)
+  | _ -> raise Errors.Unhandled
+end
+
+(** [tclFOCUS_gen nosuchgoal i j t] applies [t] in a context where
+    only the goals numbered [i] to [j] are focused (the rest of the goals
+    is restored at the end of the tactic). If the range [i]-[j] is not
+    valid, then it [tclFOCUS_gen nosuchgoal i j t] is [nosuchgoal]. *)
+let tclFOCUS_gen nosuchgoal i j t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  try
+    let (focused,context) = focus i j initial in
+    Pv.set focused >>
+    t >>= fun result ->
+    Pv.modify (fun next -> unfocus context next) >>
+    return result
+  with CList.IndexOutOfRange -> nosuchgoal
+
+let tclFOCUS i j t = tclFOCUS_gen (tclZERO (NoSuchGoals (j+1-i))) i j t
+let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t
 
-(* spiwack: this should probably be moved closer to the [tclDISPATCH] tactical. *)
-let tclDISPATCHS tacs = 
-  let tacs = 
-    List.map begin fun tac -> 
-      tclBIND tac here_s
-    end tacs 
+(** Like {!tclFOCUS} but selects a single goal by name. *)
+let tclFOCUSID id t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let rec aux n = function
+    | [] -> tclZERO (NoSuchGoals 1)
+    | g::l ->
+        if Names.Id.equal (Evd.evar_ident g initial.solution) id then
+          let (focused,context) = focus n n initial in
+          Pv.set focused >>
+          t >>= fun result ->
+          Pv.modify (fun next -> unfocus context next) >>
+          return result
+        else
+          aux (n+1) l in
+  aux 1 initial.comb
+
+
+
+(** {7 Dispatching on goals} *)
+
+exception SizeMismatch of int*int
+let _ = Errors.register_handler begin function
+  | SizeMismatch (i,_) ->
+      let open Pp in
+      let errmsg =
+        str"Incorrect number of goals" ++ spc() ++
+        str"(expected "++int i++str(String.plural i " tactic") ++ str")."
+      in
+      Errors.errorlabstrm "" errmsg
+  | _ -> raise Errors.Unhandled
+end
+
+(** A variant of [Monad.List.iter] where we iter over the focused list
+    of goals. The argument tactic is executed in a focus comprising
+    only of the current goal, a goal which has been solved by side
+    effect is skipped. The generated subgoals are concatenated in
+    order.  *)
+let iter_goal i =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Proof.List.fold_left begin fun (subgoals as cur) goal ->
+    Solution.get >>= fun step ->
+    match advance step goal with
+    | None -> return cur
+    | Some goal ->
+        Comb.set [goal] >>
+        i goal >>
+        Proof.map (fun comb -> comb :: subgoals) Comb.get
+  end [] initial >>= fun subgoals ->
+  Solution.get >>= fun evd ->
+  Comb.set CList.(undefined evd (flatten (rev subgoals)))
+
+(** A variant of [Monad.List.fold_left2] where the first list is the
+    list of focused goals. The argument tactic is executed in a focus
+    comprising only of the current goal, a goal which has been solved
+    by side effect is skipped. The generated subgoals are concatenated
+    in order. *)
+let fold_left2_goal i s l =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let err =
+    return () >>= fun () -> (* Delay the computation of list lengths. *)
+    tclZERO (SizeMismatch (CList.length initial.comb,CList.length l))
+  in 
+  Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a ->
+    Solution.get >>= fun step ->
+    match advance step goal with
+    | None -> return cur
+    | Some goal ->
+        Comb.set [goal] >>
+        i goal a r >>= fun r ->
+        Proof.map (fun comb -> (r, comb :: subgoals)) Comb.get
+  end (s,[]) initial.comb l >>= fun (r,subgoals) ->
+  Solution.get >>= fun evd ->
+  Comb.set CList.(undefined evd (flatten (rev subgoals))) >>
+  return r
+
+(** Dispatch tacticals are used to apply a different tactic to each
+    goal under focus. They come in two flavours: [tclDISPATCH] takes a
+    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
+    takes a list of ['a tactic] and returns an ['a list tactic].
+
+    They both work by applying each of the tactic in a focus
+    restricted to the corresponding goal (starting with the first
+    goal). In the case of [tclDISPATCHL], the tactic returns a list of
+    the same size as the argument list (of tactics), each element
+    being the result of the tactic executed in the corresponding goal.
+
+    When the length of the tactic list is not the number of goal,
+    raises [SizeMismatch (g,t)] where [g] is the number of available
+    goals, and [t] the number of tactics passed.
+
+    [tclDISPATCHGEN join tacs] generalises both functions as the
+    successive results of [tacs] are stored in reverse order in a
+    list, and [join] is used to convert the result into the expected
+    form. *)
+let tclDISPATCHGEN0 join tacs =
+  match tacs with
+  | [] ->
+      begin 
+        let open Proof in
+        Comb.get >>= function
+        | [] -> tclUNIT (join [])
+        | comb -> tclZERO (SizeMismatch (CList.length comb,0))
+      end
+  | [tac] ->
+      begin
+        let open Proof in
+        Pv.get >>= function
+        | { comb=[goal] ; solution } ->
+            begin match advance solution goal with
+            | None -> tclUNIT (join [])
+            | Some _ -> Proof.map (fun res -> join [res]) tac
+            end
+        | {comb} -> tclZERO (SizeMismatch(CList.length comb,1))
+      end
+  | _ ->
+      let iter _ t cur = Proof.map (fun y -> y :: cur) t in
+      let ans = fold_left2_goal iter [] tacs in
+      Proof.map join ans
+
+let tclDISPATCHGEN join tacs =
+  let branch t = InfoL.tag (Info.DBranch) t in
+  let tacs = CList.map branch tacs in
+  InfoL.tag (Info.Dispatch) (tclDISPATCHGEN0 join tacs)
+
+let tclDISPATCH tacs = tclDISPATCHGEN Pervasives.ignore tacs
+
+let tclDISPATCHL tacs = tclDISPATCHGEN CList.rev tacs
+
+
+(** [extend_to_list startxs rx endxs l] builds a list
+    [startxs@[rx,...,rx]@endxs] of the same length as [l]. Raises
+    [SizeMismatch] if [startxs@endxs] is already longer than [l]. *)
+let extend_to_list startxs rx endxs l =
+  (* spiwack: I use [l] essentially as a natural number *)
+  let rec duplicate acc = function
+    | [] -> acc
+    | _::rest -> duplicate (rx::acc) rest
   in
-  purify begin 
-    tclDISPATCHGEN Goal.null Goal.plus tacs
+  let rec tail to_match rest =
+    match rest, to_match with
+    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
+    | _::rest , _::to_match -> tail to_match rest
+    | _ , [] -> duplicate endxs rest
+  in
+  let rec copy pref rest =
+    match rest,pref with
+    | [] , _::_ -> raise (SizeMismatch(0,0)) (* placeholder *)
+    | _::rest, a::pref -> a::(copy pref rest)
+    | _ , [] -> tail endxs rest
+  in
+  copy startxs l
+
+(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
+    tactic is "repeated" enough time such that every goal has a tactic
+    assigned to it ([b] is the list of tactics applied to the first
+    goals, [e] to the last goals, and [r] is applied to every goal in
+    between). *)
+let tclEXTEND tacs1 rtac tacs2 =
+  let open Proof in
+  Comb.get >>= fun comb ->
+  try
+    let tacs = extend_to_list tacs1 rtac tacs2 comb in
+    tclDISPATCH tacs
+  with SizeMismatch _ ->
+    tclZERO (SizeMismatch(
+      CList.length comb,
+      (CList.length tacs1)+(CList.length tacs2)))
+(* spiwack: failure occurs only when the number of goals is too
+   small. Hence we can assume that [rtac] is replicated 0 times for
+   any error message. *)
+
+(** [tclEXTEND [] tac []]. *)
+let tclINDEPENDENT tac =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  match initial.comb with
+  | [] -> tclUNIT ()
+  | [_] -> tac
+  | _ ->
+      let tac = InfoL.tag (Info.DBranch) tac in
+      InfoL.tag (Info.Dispatch) (iter_goal (fun _ -> tac))
+
+
+
+(** {7 Goal manipulation} *)
+
+(** Shelves all the goals under focus. *)
+let shelve =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Comb.set [] >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >>
+  Shelf.put initial
+
+
+(** [contained_in_info e evi] checks whether the evar [e] appears in
+    the hypotheses, the conclusion or the body of the evar_info
+    [evi]. Note: since we want to use it on goals, the body is actually
+    supposed to be empty. *)
+let contained_in_info sigma e evi =
+  Evar.Set.mem e (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi))
+
+(** [depends_on sigma src tgt] checks whether the goal [src] appears
+    as an existential variable in the definition of the goal [tgt] in
+    [sigma]. *)
+let depends_on sigma src tgt =
+  let evi = Evd.find sigma tgt in
+  contained_in_info sigma src evi
+
+(** [unifiable sigma g l] checks whether [g] appears in another
+    subgoal of [l]. The list [l] may contain [g], but it does not
+    affect the result. *)
+let unifiable sigma g l =
+  CList.exists (fun tgt -> not (Evar.equal g tgt) && depends_on sigma g tgt) l
+
+(** [partition_unifiable sigma l] partitions [l] into a pair [(u,n)]
+    where [u] is composed of the unifiable goals, i.e. the goals on
+    whose definition other goals of [l] depend, and [n] are the
+    non-unifiable goals. *)
+let partition_unifiable sigma l =
+  CList.partition (fun g -> unifiable sigma g l) l
+
+(** Shelves the unifiable goals under focus, i.e. the goals which
+    appear in other goals under focus (the unfocused goals are not
+    considered). *)
+let shelve_unifiable =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let (u,n) = partition_unifiable initial.solution initial.comb in
+  Comb.set n >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >>
+  Shelf.put u
+
+(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some
+    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
+let guard_no_unifiable =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  let (u,n) = partition_unifiable initial.solution initial.comb in
+  match u with
+  | [] -> tclUNIT ()
+  | gls ->
+      let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in
+      let l = CList.map (fun id -> Names.Name id) l in
+      tclZERO (Logic.RefinerError (Logic.UnresolvedBindings l))
+
+(** [unshelve l p] adds all the goals in [l] at the end of the focused
+    goals of p *)
+let unshelve l p =
+  (* advance the goals in case of clear *)
+  let l = undefined p.solution l in
+  { p with comb = p.comb@l }
+
+
+(** [goodmod p m] computes the representative of [p] modulo [m] in the
+    interval [[0,m-1]].*)
+let goodmod p m =
+  let p' = p mod m in
+  (* if [n] is negative [n mod l] is negative of absolute value less
+     than [l], so [(n mod l)+l] is the representative of [n] in the
+     interval [[0,l-1]].*)
+  if p' < 0 then p'+m else p'
+
+let cycle n =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle"++spc()++int n))) >>
+  Comb.modify begin fun initial ->
+    let l = CList.length initial in
+    let n' = goodmod n l in
+    let (front,rear) = CList.chop n' initial in
+    rear@front
   end
 
-let rec tclGOALBINDU s k = 
-  purify begin 
-    tclBIND (list_of_sensitive s k) begin fun tacs ->
-      tclDISPATCHGEN () unitK tacs
-    end
+let swap i j =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.(str"swap"++spc()++int i++spc()++int j))) >>
+  Comb.modify begin fun initial ->
+    let l = CList.length initial in
+    let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in
+    let i = goodmod i l and j = goodmod j l in
+    CList.map_i begin fun k x ->
+      match k with
+      | k when Int.equal k i -> CList.nth initial j
+      | k when Int.equal k j -> CList.nth initial i
+      | _ -> x
+    end 0 initial
   end
 
-(* spiwack: up to a few details, same errors are in the Logic module.
-    this should be maintained synchronized, probably. *)
-open Pretype_errors
-let rec catchable_exception = function
-  | Loc.Exc_located(_,e) -> catchable_exception e
-  | Util.UserError _
-  | Type_errors.TypeError _ | PretypeError (_,_,TypingError _)
-  | Indrec.RecursionSchemeError _
-  | Nametab.GlobalizationError _ | PretypeError (_,_,VarNotFound _)
-  (* unification errors *)
-  | PretypeError(_,_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
-		   |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
-		   |CannotFindWellTypedAbstraction _
-		   |UnsolvableImplicit _)) -> true
-  | Typeclasses_errors.TypeClassError 
-      (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
-  | _ -> false
-
-(* No backtracking can happen here, hence, as opposed to the dispatch tacticals,
-    everything is done in one step. *)
-let sensitive_on_step s env step =
-  let wrap g ((defs, partial_list) as partial_res) = 
-    match Goal.advance defs g with
-    | None ->partial_res
-    | Some g ->
-      let {Goal.subgoals = sg } , d' = Goal.eval s env defs g in
-      (d',sg::partial_list)
-  in
-  let ( new_defs , combed_subgoals ) = 
-    List.fold_right wrap step.goals (step.defs,[])
+let revgoals =
+  let open Proof in
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"revgoals")) >>
+  Comb.modify CList.rev
+
+let numgoals =
+  let open Proof in
+  Comb.get >>= fun comb ->
+  return (CList.length comb)
+
+
+
+(** {7 Access primitives} *)
+
+let tclEVARMAP = Solution.get
+
+let tclENV = Env.get
+
+
+
+(** {7 Put-like primitives} *)
+
+
+let emit_side_effects eff x =
+  { x with solution = Evd.emit_side_effects eff x.solution }
+
+let tclEFFECTS eff =
+  let open Proof in
+  return () >>= fun () -> (* The Global.env should be taken at exec time *)
+  Env.set (Global.env ()) >>
+  Pv.modify (fun initial -> emit_side_effects eff initial)
+
+let mark_as_unsafe = Status.put false
+
+(** Gives up on the goal under focus. Reports an unsafe status. Proofs
+    with given up goals cannot be closed. *)
+let give_up =
+  let open Proof in
+  Comb.get >>= fun initial ->
+  Comb.set [] >>
+  mark_as_unsafe >>
+  InfoL.leaf (Info.Tactic (fun () -> Pp.str"give_up")) >>
+  Giveup.put initial
+
+
+
+(** {7 Control primitives} *)
+
+(** Equality function on goals *)
+let goal_equal evars1 gl1 evars2 gl2 =
+  let evi1 = Evd.find evars1 gl1 in
+  let evi2 = Evd.find evars2 gl2 in
+  Evd.eq_evar_info evars2 evi1 evi2
+
+let tclPROGRESS t =
+  let open Proof in
+  Pv.get >>= fun initial ->
+  t >>= fun res ->
+  Pv.get >>= fun final ->
+  let test =
+    Evd.progress_evar_map initial.solution final.solution &&
+    not (Util.List.for_all2eq (fun i f -> goal_equal initial.solution i final.solution f) initial.comb final.comb)
   in
-  { defs = new_defs;
-     goals = List.flatten combed_subgoals }
-let tclSENSITIVE s =
-  purify begin
-    fun env -> { go = fun sk fk step -> sk () fk (sensitive_on_step s env step) }
-  end
+  if test then
+    tclUNIT res
+  else
+    tclZERO (Errors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
+
+exception Timeout
+let _ = Errors.register_handler begin function
+  | Timeout -> Errors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
+  | _ -> Pervasives.raise Errors.Unhandled
+end
+
+let tclTIMEOUT n t =
+  let open Proof in
+  (* spiwack: as one of the monad is a continuation passing monad, it
+     doesn't force the computation to be threaded inside the underlying
+     (IO) monad. Hence I force it myself by asking for the evaluation of
+     a dummy value first, lest [timeout] be called when everything has
+     already been computed. *)
+  let t = Proof.lift (Logic_monad.NonLogical.return ()) >> t in
+  Proof.get >>= fun initial ->
+  Proof.current >>= fun envvar ->
+  Proof.lift begin
+    Logic_monad.NonLogical.catch
+      begin
+        let open Logic_monad.NonLogical in
+        timeout n (Proof.repr (Proof.run t envvar initial)) >>= fun r ->
+        match r with
+        | Logic_monad.Nil e -> return (Util.Inr e)
+        | Logic_monad.Cons (r, _) -> return (Util.Inl r)
+      end
+      begin let open Logic_monad.NonLogical in function (e, info) ->
+        match e with
+        | Logic_monad.Timeout -> return (Util.Inr (Timeout, info))
+        | Logic_monad.TacticFailure e ->
+          return (Util.Inr (e, info))
+        | e -> Logic_monad.NonLogical.raise ~info e
+      end
+  end >>= function
+    | Util.Inl (res,s,m,i) ->
+        Proof.set s >>
+        Proof.put m >>
+        Proof.update (fun _ -> i) >>
+        return res
+    | Util.Inr (e, info) -> tclZERO ~info e
+
+let tclTIME s t =
+  let pr_time t1 t2 n msg =
+    let msg =
+      if n = 0 then
+        str msg
+      else
+        str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking")
+    in
+    msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++
+             System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in
+  let rec aux n t =
+    let open Proof in
+    tclUNIT () >>= fun () ->
+    let tstart = System.get_time() in
+    Proof.split t >>= let open Logic_monad in function
+    | Nil (e, info) ->
+      begin
+        let tend = System.get_time() in
+        pr_time tstart tend n "failure";
+        tclZERO ~info e
+      end
+    | Cons (x,k) ->
+        let tend = System.get_time() in
+        pr_time tstart tend n "success";
+        tclOR (tclUNIT x) (fun e -> aux (n+1) (k e))
+  in aux 0 t
+
 
 
-(*** Commands ***)
+(** {7 Unsafe primitives} *)
 
-let in_proofview p k =
-  k p.solution
+module Unsafe = struct
+
+  let tclEVARS evd =
+    Pv.modify (fun ps -> { ps with solution = evd })
+
+  let tclNEWGOALS gls =
+    Pv.modify begin fun step ->
+      let gls = undefined step.solution gls in
+      { step with comb = step.comb @ gls }
+    end
+
+  let tclGETGOALS = Comb.get
+
+  let tclSETGOALS = Comb.set
+
+  let tclEVARSADVANCE evd =
+    Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb })
+
+  let tclEVARUNIVCONTEXT ctx = 
+    Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx })
+
+  let reset_future_goals p =
+    { p with solution = Evd.reset_future_goals p.solution }
+
+  let mark_as_goal_evm evd content =
+    let info = Evd.find evd content in
+    let info =
+      { info with Evd.evar_source = match info.Evd.evar_source with
+      | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x
+      | loc,_ -> loc,Evar_kinds.GoalEvar }
+    in
+    let info = Typeclasses.mark_unresolvable info in
+    Evd.add evd content info
+
+  let mark_as_goal p gl =
+    { p with solution = mark_as_goal_evm p.solution gl }
+
+end
+
+
+
+(** {7 Notations} *)
 
 module Notations = struct
-  let (>-) = Goal.bind
-  let (>>-) = tclGOALBINDU
-  let (>>--) = tclGOALBIND
-  let (>=) = tclBIND
-  let (>>=) t k = t >= fun s -> s >>- k
-  let (>>==) t k = t >= fun s -> s >>-- k
+  let (>>=) = tclBIND
   let (<*>) = tclTHEN
-  let (<+>) = tclOR
+  let (<+>) t1 t2 = tclOR t1 (fun _ -> t2)
 end
 
-(*** Compatibility layer with <= 8.2 tactics ***)
-module V82 = struct
-  type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma
-
-  let tactic tac _ = { go = fun sk fk ps ->
-    (* spiwack: we ignore the dependencies between goals here, expectingly
-         preserving the semantics of <= 8.2 tactics *)
-    let tac evd gl = 
-      let glsigma  = tac { Evd.it = gl ; Evd.sigma = evd }  in
-      let sigma = glsigma.Evd.sigma in
-      let g = glsigma.Evd.it in
-      ( g , sigma )
+open Notations
+
+
+
+(** {6 Goal-dependent tactics} *)
+
+(* To avoid shadowing by the local [Goal] module *)
+module GoalV82 = Goal.V82
+
+let catchable_exception = function
+  | Logic_monad.Exception _ -> false
+  | e -> Errors.noncritical e
+
+
+module Goal = struct
+
+  type 'a t = {
+    env : Environ.env;
+    sigma : Evd.evar_map;
+    concl : Term.constr ;
+    self : Evar.t ; (* for compatibility with old-style definitions *)
+  }
+
+  let assume (gl : 'a t) = (gl :> [ `NF ] t)
+
+  let env { env=env } = env
+  let sigma { sigma=sigma } = sigma
+  let hyps { env=env } = Environ.named_context env
+  let concl { concl=concl } = concl
+  let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self
+
+  let raw_concl { concl=concl } = concl
+
+
+  let gmake_with info env sigma goal = 
+    { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ;
+      sigma = sigma ;
+      concl = Evd.evar_concl info ;
+      self = goal }
+
+  let nf_gmake env sigma goal =
+    let info = Evarutil.nf_evar_info sigma (Evd.find sigma goal) in
+    let sigma = Evd.add sigma goal info in
+    gmake_with info env sigma goal , sigma
+
+  let nf_enter f =
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try
+        let (gl, sigma) = nf_gmake env sigma goal in
+        tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) (f gl))
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let normalize { self } =
+    Env.get >>= fun env ->
+    tclEVARMAP >>= fun sigma ->
+    let (gl,sigma) = nf_gmake env sigma self in
+    tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl)
+
+  let gmake env sigma goal =
+    let info = Evd.find sigma goal in
+    gmake_with info env sigma goal
+
+  let enter f =
+    let f gl = InfoL.tag (Info.DBranch) (f gl) in
+    InfoL.tag (Info.Dispatch) begin
+    iter_goal begin fun goal ->
+      Env.get >>= fun env ->
+      tclEVARMAP >>= fun sigma ->
+      try f (gmake env sigma goal)
+      with e when catchable_exception e ->
+        let (e, info) = Errors.push e in
+        tclZERO ~info e
+    end
+    end
+
+  let goals =
+    Env.get >>= fun env ->
+    Pv.get >>= fun step ->
+    let sigma = step.solution in
+    let map goal =
+      match advance sigma goal with
+      | None -> None (** ppedrot: Is this check really necessary? *)
+      | Some goal ->
+        let gl =
+          tclEVARMAP >>= fun sigma ->
+          tclUNIT (gmake env sigma goal)
+        in
+        Some gl
     in
-    (* Old style tactics expect the goals normalized with respect to evars. *)
-    let (initgoals,initevd) = 
-      Goal.list_map Goal.V82.nf_evar ps.goals ps.defs
+    tclUNIT (CList.map_filter map step.comb)
+
+  (* compatibility *)
+  let goal { self=self } = self
+
+end
+
+
+
+(** {6 The refine tactic} *)
+
+module Refine =
+struct
+
+  let typecheck_evar ev env sigma =
+    let info = Evd.find sigma ev in
+    let evdref = ref sigma in
+    let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in
+    let _ = Typing.sort_of env evdref (Evd.evar_concl info) in
+    !evdref
+
+  let typecheck_proof c concl env sigma =
+    let evdref = ref sigma in
+    let () = Typing.check env evdref c concl in
+    !evdref
+
+  let (pr_constrv,pr_constr) =
+    Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") ()
+
+  let refine ?(unsafe = true) f = Goal.enter begin fun gl ->
+    let sigma = Goal.sigma gl in
+    let env = Goal.env gl in
+    let concl = Goal.concl gl in
+    (** Save the [future_goals] state to restore them after the
+        refinement. *)
+    let prev_future_goals = Evd.future_goals sigma in
+    let prev_principal_goal = Evd.principal_future_goal sigma in
+    (** Create the refinement term *)
+    let (sigma, c) = f (Evd.reset_future_goals sigma) in
+    let evs = Evd.future_goals sigma in
+    let evkmain = Evd.principal_future_goal sigma in
+    (** Check that the introduced evars are well-typed *)
+    let fold accu ev = typecheck_evar ev env accu in
+    let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in
+    (** Check that the refined term is typesafe *)
+    let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in
+    (** Check that the goal itself does not appear in the refined term *)
+    let _ =
+      if not (Evarutil.occur_evar_upto sigma gl.Goal.self c) then ()
+      else Pretype_errors.error_occur_check env sigma gl.Goal.self c
     in
-    let (goalss,evd) = Goal.list_map tac initgoals initevd in
-    let sgs = List.flatten goalss in
-    sk () fk { defs = evd ; goals = sgs }
-}
+    (** Proceed to the refinement *)
+    let sigma = match evkmain with
+      | None -> Evd.define gl.Goal.self c sigma
+      | Some evk ->
+          let id = Evd.evar_ident gl.Goal.self sigma in
+          Evd.rename evk id (Evd.define gl.Goal.self c sigma)
+    in
+    (** Restore the [future goals] state. *)
+    let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in
+    (** Select the goals *)
+    let comb = undefined sigma (CList.rev evs) in
+    let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in
+    let open Proof in
+    InfoL.leaf (Info.Tactic (fun () -> Pp.(str"refine"++spc()++ Hook.get pr_constrv env sigma c))) >>
+    Pv.set { solution = sigma; comb; }
+  end
+
+  (** Useful definitions *)
+
+  let with_type env evd c t =
+    let my_type = Retyping.get_type_of env evd c in
+    let j = Environ.make_judge c my_type in
+    let (evd,j') =
+      Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t
+    in
+    evd , j'.Environ.uj_val
+
+  let refine_casted ?unsafe f = Goal.enter begin fun gl ->
+    let concl = Goal.concl gl in
+    let env = Goal.env gl in
+    let f h = let (h, c) = f h in with_type env h c concl in
+    refine ?unsafe f
+  end
+end
+
+
+
+(** {6 Trace} *)
+
+module Trace = struct
+
+  let record_info_trace = InfoL.record_trace
 
+  let log m = InfoL.leaf (Info.Msg m)
+  let name_tactic m t = InfoL.tag (Info.Tactic m) t
+
+  let pr_info ?(lvl=0) info =
+    assert (lvl >= 0);
+    Info.(print (collapse lvl info))
+
+end
+
+
+
+(** {6 Non-logical state} *)
+
+module NonLogical = Logic_monad.NonLogical
+
+let tclLIFT = Proof.lift
+
+let tclCHECKINTERRUPT =
+   tclLIFT (NonLogical.make Control.check_for_interrupt)
+
+
+
+
+
+(*** Compatibility layer with <= 8.2 tactics ***)
+module V82 = struct
+  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
+
+  let tactic tac =
+    (* spiwack: we ignore the dependencies between goals here,
+       expectingly preserving the semantics of <= 8.2 tactics *)
+    (* spiwack: convenience notations, waiting for ocaml 3.12 *)
+    let open Proof in
+    Pv.get >>= fun ps ->
+    try
+      let tac gl evd = 
+        let glsigma  =
+          tac { Evd.it = gl ; sigma = evd; }  in
+        let sigma = glsigma.Evd.sigma in
+        let g = glsigma.Evd.it in
+        ( g, sigma )
+      in
+        (* Old style tactics expect the goals normalized with respect to evars. *)
+      let (initgoals,initevd) =
+        Evd.Monad.List.map (fun g s -> GoalV82.nf_evar s g) ps.comb ps.solution
+      in
+      let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in
+      let sgs = CList.flatten goalss in
+      let sgs = undefined evd sgs in
+      InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >>
+      Pv.set { solution = evd; comb = sgs; }
+    with e when catchable_exception e ->
+      let (e, info) = Errors.push e in
+      tclZERO ~info e
+
+
+  (* normalises the evars in the goals, and stores the result in
+     solution. *)
+  let nf_evar_goals =
+    Pv.modify begin fun ps ->
+    let map g s = GoalV82.nf_evar s g in
+    let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in
+    { solution = evd; comb = goals; }
+    end
+      
   let has_unresolved_evar pv =
     Evd.has_undefined pv.solution
 
   (* Main function in the implementation of Grab Existential Variables.*)
   let grab pv =
-    let goals =
-      List.map begin fun (e,_) ->
-	Goal.build e
-      end (Evd.undefined_list pv.solution)
-    in
+    let undef = Evd.undefined_map pv.solution in
+    let goals = CList.rev_map fst (Evar.Map.bindings undef) in
     { pv with comb = goals }
       
     
 
   (* Returns the open goals of the proofview together with the evar_map to 
      interprete them. *)
-  let goals { comb = comb ; solution = solution } = 
-    { Evd.it = comb ; sigma = solution}
+  let goals { comb = comb ; solution = solution; } =
+   { Evd.it = comb ; sigma = solution }
 
-  let top_goals { initial=initial ; solution=solution } = 
-    let goals = List.map (fun (t,_) -> Goal.V82.build (fst (Term.destEvar t))) initial in
-    { Evd.it = goals ; sigma=solution }
+  let top_goals initial { solution=solution; } =
+    let goals = CList.map (fun (t,_) -> fst (Term.destEvar t)) initial in
+    { Evd.it = goals ; sigma=solution; }
 
-  let top_evars { initial=initial } =
+  let top_evars initial =
     let evars_of_initial (c,_) =
-      Util.Intset.elements (Evarutil.evars_of_term c)
+      Evar.Set.elements (Evd.evars_of_term c)
     in
-    List.flatten (List.map evars_of_initial initial)
+    CList.flatten (CList.map evars_of_initial initial)
 
   let instantiate_evar n com pv =
-    let (evk,_) = 
+    let (evk,_) =
       let evl = Evarutil.non_instantiated pv.solution in
-     if (n <= 0) then
-	Util.error "incorrect existential variable index"
-      else if List.length evl < n then
-	  Util.error "not so many uninstantiated existential variables"
+      let evl = Evar.Map.bindings evl in
+      if (n <= 0) then
+	Errors.error "incorrect existential variable index"
+      else if CList.length evl < n then
+	  Errors.error "not so many uninstantiated existential variables"
       else
-	List.nth evl (n-1) 
+	CList.nth evl (n-1)
     in
     { pv with
 	solution = Evar_refiner.instantiate_pf_com evk com pv.solution }
 
-  let purify = purify
+  let of_tactic t gls =
+    try
+      let init = { solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in
+      let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in
+      { Evd.sigma = final.solution ; it = final.comb }
+    with Logic_monad.TacticFailure e as src ->
+      let (_, info) = Errors.push src in
+      iraise (e, info)
+
+  let put_status = Status.put
+
+  let catchable_exception = catchable_exception
+
+  let wrap_exceptions f =
+    try f ()
+    with e when catchable_exception e ->
+      let (e, info) = Errors.push e in tclZERO ~info e
+
 end
diff --git a/proofs/proofview.mli b/proofs/proofview.mli
index a87383c8..ec255f6a 100644
--- a/proofs/proofview.mli
+++ b/proofs/proofview.mli
@@ -1,32 +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        *)
 (************************************************************************)
 
-(* The proofview datastructure is a pure datastructure underlying the notion
-   of proof (namely, a proof is a proofview which can evolve and has safety
-   mechanisms attached).
-   The general idea of the structure is that it is composed of a chemical
-   solution: an unstructured bag of stuff which has some relations with 
-   one another, which represents the various subnodes of the proof, together
-   with a comb: a datastructure that gives order to some of these nodes, 
-   namely the open goals. 
-   The natural candidate for the solution is an {!Evd.evar_map}, that is
-   a calculus of evars. The comb is then a list of goals (evars wrapped 
-   with some extra information, like possible name anotations).
-   There is also need of a list of the evars which initialised the proofview
-   to be able to return information about the proofview. *)
+(** This files defines the basic mechanism of proofs: the [proofview]
+    type is the state which tactics manipulate (a global state for
+    existential variables, together with the list of goals), and the type
+    ['a tactic] is the (abstract) type of tactics modifying the proof
+    state and returning a value of type ['a]. *)
 
+open Util
 open Term
 
-type proofview 
+(** Main state of tactics *)
+type proofview
 
-
-(* Returns a stylised view of a proofview for use by, for instance,
-   ide-s. *)
+(** Returns a stylised view of a proofview for use by, for instance,
+    ide-s. *)
 (* spiwack: the type of [proofview] will change as we push more
    refined functions to ide-s. This would be better than spawning a
    new nearly identical function everytime. Hence the generic name. *)
@@ -34,183 +27,518 @@ type proofview
    the [evar_map] context. *)
 val proofview : proofview -> Goal.goal list * Evd.evar_map
 
-(* Initialises a proofview, the argument is a list of environement, 
-   conclusion types, creating that many initial goals. *)
-val init : (Environ.env * Term.types) list -> proofview
 
-(* Returns whether this proofview is finished or not.That is,
-   if it has empty subgoals in the comb. There could still be unsolved
-   subgoaled, but they would then be out of the view, focused out. *)
+(** {6 Starting and querying a proof view} *)
+
+(** Abstract representation of the initial goals of a proof. *)
+type entry
+
+(** Optimize memory consumption *)
+val compact : entry -> proofview -> entry * proofview
+
+(** Initialises a proofview, the main argument is a list of
+    environements (including a [named_context] which are used as
+    hypotheses) pair with conclusion types, creating accordingly many
+    initial goals. Because a proof does not necessarily starts in an
+    empty [evar_map] (indeed a proof can be triggered by an incomplete
+    pretyping), [init] takes an additional argument to represent the
+    initial [evar_map]. *)
+val init : Evd.evar_map -> (Environ.env * Term.types) list -> entry * proofview
+
+(** A [telescope] is a list of environment and conclusion like in
+    {!init}, except that each element may depend on the previous
+    goals. The telescope passes the goals in the form of a
+    [Term.constr] which represents the goal as an [evar]. The
+    [evar_map] is threaded in state passing style. *)
+type telescope =
+  | TNil of Evd.evar_map
+  | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope)
+
+(** Like {!init}, but goals are allowed to be dependent on one
+    another. Dependencies between goals is represented with the type
+    [telescope] instead of [list]. Note that the first [evar_map] of
+    the telescope plays the role of the [evar_map] argument in
+    [init]. *)
+val dependent_init  : telescope -> entry * proofview
+
+(** [finished pv] is [true] if and only if [pv] is complete. That is,
+    if it has an empty list of focused goals. There could still be
+    unsolved subgoaled, but they would then be out of focus. *)
 val finished : proofview -> bool
 
-(* Returns the current value of the proofview partial proofs. *)
-val return : proofview -> (constr*types) list
+(** Returns the current [evar] state. *)
+val return : proofview -> Evd.evar_map
+
+val partial_proof : entry -> proofview -> constr list
+val initial_goals : entry -> (constr * types) list
 
 
-(*** Focusing operations ***)
 
-(* [IndexOutOfRange] occurs in case of malformed indices
-   with respect to list lengths. *)
-exception IndexOutOfRange
+(** {6 Focusing commands} *)
 
-(* Type of the object which allow to unfocus a view.*)
+(** A [focus_context] represents the part of the proof view which has
+    been removed by a focusing action, it can be used to unfocus later
+    on. *)
 type focus_context
 
-(* Returns a stylised view of a focus_context for use by, for
-   instance, ide-s. *)
+(** Returns a stylised view of a focus_context for use by, for
+    instance, ide-s. *)
 (* spiwack: the type of [focus_context] will change as we push more
    refined functions to ide-s. This would be better than spawning a
    new nearly identical function everytime. Hence the generic name. *)
-(* In this version: returns the number of goals that are held *)
+(* In this version: the goals in the context, as a "zipper" (the first
+   list is in reversed order). *)
 val focus_context : focus_context -> Goal.goal list * Goal.goal list
 
-(* [focus i j] focuses a proofview on the goals from index [i] to index [j] 
-   (inclusive). (i.e. goals number [i] to [j] become the only goals of the
-   returned proofview).
-   It returns the focus proof, and a context for the focus trace. *)
+(** [focus i j] focuses a proofview on the goals from index [i] to
+    index [j] (inclusive, goals are indexed from [1]). I.e. goals
+    number [i] to [j] become the only focused goals of the returned
+    proofview.  It returns the focused proofview, and a context for
+    the focus stack. *)
 val focus : int -> int -> proofview -> proofview * focus_context
 
-(* Unfocuses a proofview with respect to a context. *)
+(** Unfocuses a proofview with respect to a context. *)
 val unfocus : focus_context -> proofview -> proofview
 
-(* The tactic monad:
-   - Tactics are objects which apply a transformation to all
-     the subgoals of the current view at the same time. By opposed
-     to the old vision of applying it to a single goal. It mostly 
-     allows to consider tactic like [reorder] to reorder the goals
-     in the current view (which might be useful for the tactic designer)
-     (* spiwack: the ordering of goals, though, is actually rather
-        brittle. It would be much more interesting to find a more
-        robust way to adress goals, I have no idea at this time 
-        though*) 
-     or global automation tactic for dependent subgoals (instantiating
-     an evar has influences on the other goals of the proof in progress,
-     not being able to take that into account causes the current eauto
-     tactic to fail on some instances where it could succeed).
-   - Tactics are a monad ['a tactic], in a sense a tactic can be 
-     seens as a function (without argument) which returns a value
-     of type 'a and modifies the environement (in our case: the view).
-     Tactics of course have arguments, but these are given at the 
-     meta-level as OCaml functions.
-     Most tactics in the sense we are used to return [ () ], that is
-     no really interesting values. But some might, to pass information 
-     around; for instance [Proofview.freeze] allows to store a certain
-     goal sensitive value "at the present time" (which means, considering the
-     structure of the dynamics of proofs, [Proofview.freeze s] will have,
-     for every current goal [gl], and for any of its descendent [g'] in 
-     the future the same value in [g'] that in [gl]). 
-     (* spiwack: I don't know how much all this relates to F. Kirchner and 
-        C. Muñoz. I wasn't able to understand how they used the monad
-        structure in there developpement.
-     *)
-     The tactics seen in Coq's Ltac are (for now at least) only 
-     [unit tactic], the return values are kept for the OCaml toolkit.
-     The operation or the monad are [Proofview.tclIDTAC] (which is the 
-     "return" of the tactic monad) [Proofview.tclBIND] (which is
-     the "bind") and [Proofview.tclTHEN] (which is a specialized
-     bind on unit-returning tactics).
+
+(** {6 The tactic monad} *)
+
+(** - Tactics are objects which apply a transformation to all the
+    subgoals of the current view at the same time. By opposition to
+    the old vision of applying it to a single goal. It allows tactics
+    such as [shelve_unifiable], tactics to reorder the focused goals,
+    or global automation tactic for dependent subgoals (instantiating
+    an evar has influences on the other goals of the proof in
+    progress, not being able to take that into account causes the
+    current eauto tactic to fail on some instances where it could
+    succeed).  Another benefit is that it is possible to write tactics
+    that can be executed even if there are no focused goals.
+    - Tactics form a monad ['a tactic], in a sense a tactic can be
+    seens as a function (without argument) which returns a value of
+    type 'a and modifies the environement (in our case: the view).
+    Tactics of course have arguments, but these are given at the
+    meta-level as OCaml functions.  Most tactics in the sense we are
+    used to return [()], that is no really interesting values. But
+    some might pass information around.  The tactics seen in Coq's
+    Ltac are (for now at least) only [unit tactic], the return values
+    are kept for the OCaml toolkit.  The operation or the monad are
+    [Proofview.tclUNIT] (which is the "return" of the tactic monad)
+    [Proofview.tclBIND] (which is the "bind") and [Proofview.tclTHEN]
+    (which is a specialized bind on unit-returning tactics).
+    - Tactics have support for full-backtracking. Tactics can be seen
+    having multiple success: if after returning the first success a
+    failure is encountered, the tactic can backtrack and use a second
+    success if available. The state is backtracked to its previous
+    value, except the non-logical state defined in the {!NonLogical}
+    module below.
 *)
 
 
+(** The abstract type of tactics *)
 type +'a tactic 
 
-(* Applies a tactic to the current proofview. *)
-val apply : Environ.env -> 'a tactic -> proofview -> proofview
-
-(*** tacticals ***)
-
-(* Unit of the tactic monad *)
+(** Applies a tactic to the current proofview. Returns a tuple
+    [a,pv,(b,sh,gu)] where [a] is the return value of the tactic, [pv]
+    is the updated proofview, [b] a boolean which is [true] if the
+    tactic has not done any action considered unsafe (such as
+    admitting a lemma), [sh] is the list of goals which have been
+    shelved by the tactic, and [gu] the list of goals on which the
+    tactic has given up. In case of multiple success the first one is
+    selected. If there is no success, fails with
+    {!Logic_monad.TacticFailure}*)
+val apply : Environ.env -> 'a tactic -> proofview -> 'a
+                                                   * proofview
+                                                   * (bool*Goal.goal list*Goal.goal list)
+                                                   * Proofview_monad.Info.tree
+
+(** {7 Monadic primitives} *)
+
+(** Unit of the tactic monad. *)
 val tclUNIT : 'a -> 'a tactic
-
-(* Bind operation of the tactic monad *)
+ 
+(** Bind operation of the tactic monad. *)
 val tclBIND : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
 
-(* Interprets the ";" (semicolon) of Ltac.
-   As a monadic operation, it's a specialized "bind"
-   on unit-returning tactic (meaning "there is no value to bind") *)
+(** Interprets the ";" (semicolon) of Ltac. As a monadic operation,
+    it's a specialized "bind". *)
 val tclTHEN : unit tactic -> 'a tactic -> 'a tactic
 
-(* [tclIGNORE t] has the same operational content as [t],
-   but drops the value at the end. *)
+(** [tclIGNORE t] has the same operational content as [t], but drops
+    the returned value. *)
 val tclIGNORE : 'a tactic -> unit tactic
 
-(* [tclOR t1 t2 = t1] if t1 succeeds and [tclOR t1 t2 = t2] if t2 fails. 
-    No interleaving at this point. *)
-val tclOR : 'a tactic -> 'a tactic -> 'a tactic
+(** Generic monadic combinators for tactics. *)
+module Monad : Monad.S with type +'a t = 'a tactic
+
+(** {7 Failure and backtracking} *)
+
+(** [tclZERO e] fails with exception [e]. It has no success. *)
+val tclZERO : ?info:Exninfo.info -> exn -> 'a tactic
+
+(** [tclOR t1 t2] behaves like [t1] as long as [t1] succeeds. Whenever
+    the successes of [t1] have been depleted and it failed with [e],
+    then it behaves as [t2 e]. In other words, [tclOR] inserts a
+    backtracking point. *)
+val tclOR : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
+
+(** [tclORELSE t1 t2] is equal to [t1] if [t1] has at least one
+    success or [t2 e] if [t1] fails with [e]. It is analogous to
+    [try/with] handler of exception in that it is not a backtracking
+    point. *)
+val tclORELSE : 'a tactic -> (iexn -> 'a tactic) -> 'a tactic
+
+(** [tclIFCATCH a s f] is a generalisation of {!tclORELSE}: if [a]
+    succeeds at least once then it behaves as [tclBIND a s] otherwise,
+    if [a] fails with [e], then it behaves as [f e]. *)
+val tclIFCATCH : 'a tactic -> ('a -> 'b tactic) -> (iexn -> 'b tactic) -> 'b tactic
+
+(** [tclONCE t] behave like [t] except it has at most one success:
+    [tclONCE t] stops after the first success of [t]. If [t] fails
+    with [e], [tclONCE t] also fails with [e]. *)
+val tclONCE : 'a tactic -> 'a tactic
+
+(** [tclEXACTLY_ONCE e t] succeeds as [t] if [t] has exactly one
+    success. Otherwise it fails. The tactic [t] is run until its first
+    success, then a failure with exception [e] is simulated. It [t]
+    yields another success, then [tclEXACTLY_ONCE e t] fails with
+    [MoreThanOneSuccess] (it is a user error). Otherwise,
+    [tclEXACTLY_ONCE e t] succeeds with the first success of
+    [t]. Notice that the choice of [e] is relevant, as the presence of
+    further successes may depend on [e] (see {!tclOR}). *)
+exception MoreThanOneSuccess
+val tclEXACTLY_ONCE : exn -> 'a tactic -> 'a tactic
+
+(** [tclCASE t] splits [t] into its first success and a
+    continuation. It is the most general primitive to control
+    backtracking. *)
+type 'a case =
+  | Fail of iexn
+  | Next of 'a * (iexn -> 'a tactic)
+val tclCASE : 'a tactic -> 'a case tactic
+
+(** [tclBREAK p t] is a generalization of [tclONCE t]. Instead of
+    stopping after the first success, it succeeds like [t] until a
+    failure with an exception [e] such that [p e = Some e'] is raised. At
+    which point it drops the remaining successes, failing with [e'].
+    [tclONCE t] is equivalent to [tclBREAK (fun e -> Some e) t]. *)
+val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
+
+
+(** {7 Focusing tactics} *)
+
+(** [tclFOCUS i j t] applies [t] after focusing on the goals number
+    [i] to [j] (see {!focus}). The rest of the goals is restored after
+    the tactic action. If the specified range doesn't correspond to
+    existing goals, fails with [NoSuchGoals] (a user error). this
+    exception is catched at toplevel with a default message + a hook
+    message that can be customized by [set_nosuchgoals_hook] below.
+    This hook is used to add a suggestion about bullets when
+    applicable. *)
+exception NoSuchGoals of int
+val set_nosuchgoals_hook: (int -> string option) -> unit
 
-(* [tclZERO] always fails *)
-val tclZERO : exn -> 'a tactic
-
-(* Focuses a tactic at a range of subgoals, found by their indices. *)
 val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
 
-(* Dispatch tacticals are used to apply a different tactic to each goal under
-    consideration. They come in two flavours:
-    [tclDISPATCH] takes a list of [unit tactic]-s and build a [unit tactic].
-    [tclDISPATCHS] takes a list of ['a sensitive tactic] and returns and returns
-    and ['a sensitive tactic] where the ['a sensitive] interpreted in a goal [g]
-    corresponds to that of the tactic which created [g].
-    It is to be noted that the return value of [tclDISPATCHS ts] makes only
-    sense in the goals immediatly built by it, and would cause an anomaly
-    is used otherwise. *)
+(** [tclFOCUSID x t] applies [t] on a (single) focused goal like
+    {!tclFOCUS}. The goal is found by its name rather than its
+    number.*)
+val tclFOCUSID : Names.Id.t -> 'a tactic -> 'a tactic
+
+(** [tclTRYFOCUS i j t] behaves like {!tclFOCUS}, except that if the
+    specified range doesn't correspond to existing goals, behaves like
+    [tclUNIT ()] instead of failing. *)
+val tclTRYFOCUS : int -> int -> unit tactic -> unit tactic
+
+
+(** {7 Dispatching on goals} *)
+
+(** Dispatch tacticals are used to apply a different tactic to each
+    goal under focus. They come in two flavours: [tclDISPATCH] takes a
+    list of [unit tactic]-s and build a [unit tactic]. [tclDISPATCHL]
+    takes a list of ['a tactic] and returns an ['a list tactic].
+
+    They both work by applying each of the tactic in a focus
+    restricted to the corresponding goal (starting with the first
+    goal). In the case of [tclDISPATCHL], the tactic returns a list of
+    the same size as the argument list (of tactics), each element
+    being the result of the tactic executed in the corresponding goal.
+
+    When the length of the tactic list is not the number of goal,
+    raises [SizeMismatch (g,t)] where [g] is the number of available
+    goals, and [t] the number of tactics passed. *)
+exception SizeMismatch of int*int
 val tclDISPATCH : unit tactic list -> unit tactic
-val tclDISPATCHS : 'a Goal.sensitive tactic list -> 'a Goal.sensitive tactic
+val tclDISPATCHL : 'a tactic list -> 'a list tactic
 
-(* [tclEXTEND b r e] is a variant to [tclDISPATCH], where the [r] tactic
-    is "repeated" enough time such that every goal has a tactic assigned to it
-    ([b] is the list of tactics applied to the first goals, [e] to the last goals, and [r]
-    is applied to every goal in between. *)
+(** [tclEXTEND b r e] is a variant of {!tclDISPATCH}, where the [r]
+    tactic is "repeated" enough time such that every goal has a tactic
+    assigned to it ([b] is the list of tactics applied to the first
+    goals, [e] to the last goals, and [r] is applied to every goal in
+    between). *)
 val tclEXTEND : unit tactic list -> unit tactic -> unit tactic list -> unit tactic
 
-(* A sort of bind which takes a [Goal.sensitive] as a first argument, 
-    the tactic then acts on each goal separately.
-    Allows backtracking between goals. *)
-val tclGOALBIND : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
-val tclGOALBINDU : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic
+(** [tclINDEPENDENT tac] runs [tac] on each goal successively, from
+    the first one to the last one. Backtracking in one goal is
+    independent of backtracking in another. It is equivalent to
+    [tclEXTEND [] tac []]. *)
+val tclINDEPENDENT : unit tactic -> unit tactic
+
+
+(** {7 Goal manipulation} *)
+
+(** Shelves all the goals under focus. The goals are placed on the
+    shelf for later use (or being solved by side-effects). *)
+val shelve : unit tactic
+
+(** Shelves the unifiable goals under focus, i.e. the goals which
+    appear in other goals under focus (the unfocused goals are not
+    considered). *)
+val shelve_unifiable : unit tactic
+
+(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some
+    goals are unifiable (see {!shelve_unifiable}) in the current focus. *)
+val guard_no_unifiable : unit tactic
+
+(** [unshelve l p] adds all the goals in [l] at the end of the focused
+    goals of p *)
+val unshelve : Goal.goal list -> proofview -> proofview
+
+(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
+    is negative, then it puts the [n] last goals first.*)
+val cycle : int -> unit tactic
+
+(** [swap i j] swaps the position of goals number [i] and [j]
+    (negative numbers can be used to address goals from the end. Goals
+    are indexed from [1]. For simplicity index [0] corresponds to goal
+    [1] as well, rather than raising an error. *)
+val swap : int -> int -> unit tactic
+
+(** [revgoals] reverses the list of focused goals. *)
+val revgoals : unit tactic
 
-(* [tclSENSITIVE] views goal-type tactics as a special kind of tactics.*)
-val tclSENSITIVE : Goal.subgoals Goal.sensitive -> unit tactic 
+(** [numgoals] returns the number of goals under focus. *)
+val numgoals : int tactic
 
 
-(*** Commands ***)
+(** {7 Access primitives} *)
 
-val in_proofview : proofview -> (Evd.evar_map -> 'a) -> 'a
+(** [tclEVARMAP] doesn't affect the proof, it returns the current
+    [evar_map]. *)
+val tclEVARMAP : Evd.evar_map tactic
 
+(** [tclENV] doesn't affect the proof, it returns the current
+    environment. It is not the environment of a particular goal,
+    rather the "global" environment of the proof. The goal-wise
+    environment is obtained via {!Proofview.Goal.env}. *)
+val tclENV : Environ.env tactic
 
 
+(** {7 Put-like primitives} *)
 
+(** [tclEFFECTS eff] add the effects [eff] to the current state. *)
+val tclEFFECTS : Declareops.side_effects -> unit tactic
+
+(** [mark_as_unsafe] declares the current tactic is unsafe. *)
+val mark_as_unsafe : unit tactic
+
+(** Gives up on the goal under focus. Reports an unsafe status. Proofs
+    with given up goals cannot be closed. *)
+val give_up : unit tactic
+
+
+(** {7 Control primitives} *)
+
+(** [tclPROGRESS t] checks the state of the proof after [t]. It it is
+    identical to the state before, then [tclePROGRESS t] fails, otherwise
+    it succeeds like [t]. *)
+val tclPROGRESS : 'a tactic -> 'a tactic
+
+(** Checks for interrupts *)
+val tclCHECKINTERRUPT : unit tactic
+
+exception Timeout
+(** [tclTIMEOUT n t] can have only one success.
+    In case of timeout if fails with [tclZERO Timeout]. *)
+val tclTIMEOUT : int -> 'a tactic -> 'a tactic
+
+(** [tclTIME s t] displays time for each atomic call to t, using s as an
+    identifying annotation if present *)
+val tclTIME : string option -> 'a tactic -> 'a tactic
+
+(** {7 Unsafe primitives} *)
+
+(** The primitives in the [Unsafe] module should be avoided as much as
+    possible, since they can make the proof state inconsistent. They are
+    nevertheless helpful, in particular when interfacing the pretyping and
+    the proof engine. *)
+module Unsafe : sig
+
+  (** [tclEVARS sigma] replaces the current [evar_map] by [sigma]. If
+      [sigma] has new unresolved [evar]-s they will not appear as
+      goal. If goals have been solved in [sigma] they will still
+      appear as unsolved goals. *)
+  val tclEVARS : Evd.evar_map -> unit tactic
+    
+  (** Like {!tclEVARS} but also checks whether goals have been solved. *)
+  val tclEVARSADVANCE : Evd.evar_map -> unit tactic
+
+  (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently
+      being proved, appending them to the list of focused goals. If a
+      goal is already solved, it is not added. *)
+  val tclNEWGOALS : Goal.goal list -> unit tactic
+
+  (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a
+      goal is already solved, it is not set. *)
+  val tclSETGOALS : Goal.goal list -> unit tactic
+
+  (** [tclGETGOALS] returns the list of goals under focus. *)
+  val tclGETGOALS : Goal.goal list tactic
+
+  (** Sets the evar universe context. *)
+  val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic
+
+  (** Clears the future goals store in the proof view. *)
+  val reset_future_goals : proofview -> proofview
+
+  (** Give an evar the status of a goal (changes its source location
+      and makes it unresolvable for type classes. *)
+  val mark_as_goal : proofview -> Evar.t -> proofview
+end
+
+(** {7 Notations} *)
 
-(* Notations for building tactics. *)
 module Notations : sig
-  (* Goal.bind *)
-  val (>-) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive) -> 'b Goal.sensitive
-  (* tclGOALBINDU *)
-  val (>>-) : 'a Goal.sensitive -> ('a -> unit tactic) -> unit tactic
-  (* tclGOALBIND *)
-  val (>>--) : 'a Goal.sensitive -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
-
-  (* tclBIND *)
-  val (>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
-
-  (* [(>>=)] (and its goal sensitive variant [(>>==)]) "binds" in one step the
-      tactic monad and the goal-sensitive monad.
-      It is strongly advised to use it everytieme an ['a Goal.sensitive tactic]
-      needs a bind, since it usually avoids to delay the interpretation of the
-      goal sensitive value to a location where it does not make sense anymore. *)
-  val (>>=) : 'a Goal.sensitive tactic -> ('a -> unit tactic) -> unit tactic
-  val (>>==) : 'a Goal.sensitive tactic -> ('a -> 'b Goal.sensitive tactic) -> 'b Goal.sensitive tactic
-
-  (* tclTHEN *)
+
+  (** {!tclBIND} *)
+  val (>>=) : 'a tactic -> ('a -> 'b tactic) -> 'b tactic
+  (** {!tclTHEN} *)
   val (<*>) : unit tactic -> 'a tactic -> 'a tactic
-  (* tclOR *)
+  (** {!tclOR}: [t1+t2] = [tclOR t1 (fun _ -> t2)]. *)
   val (<+>) : 'a tactic -> 'a tactic -> 'a tactic
+
 end
 
+
+(** {6 Goal-dependent tactics} *)
+
+module Goal : sig
+
+  (** The type of goals. The parameter type is a phantom argument indicating
+      whether the data contained in the goal has been normalized w.r.t. the
+      current sigma. If it is the case, it is flagged [ `NF ]. You may still
+      access the un-normalized data using {!assume} if you known you do not rely
+      on the assumption of being normalized, at your own risk. *)
+  type 'a t
+
+  (** Assume that you do not need the goal to be normalized. *)
+  val assume : 'a t -> [ `NF ] t
+
+  (** Normalises the argument goal. *)
+  val normalize : 'a t -> [ `NF ] t tactic
+
+  (** [concl], [hyps], [env] and [sigma] given a goal [gl] return
+      respectively the conclusion of [gl], the hypotheses of [gl], the
+      environment of [gl] (i.e. the global environment and the
+      hypotheses) and the current evar map. *)
+  val concl : [ `NF ] t -> Term.constr
+  val hyps : [ `NF ] t -> Context.named_context
+  val env : 'a t -> Environ.env
+  val sigma : 'a t -> Evd.evar_map
+  val extra : 'a t -> Evd.Store.t
+
+  (** Returns the goal's conclusion even if the goal is not
+      normalised. *)
+  val raw_concl : 'a t -> Term.constr
+
+  (** [nf_enter t] applies the goal-dependent tactic [t] in each goal
+      independently, in the manner of {!tclINDEPENDENT} except that
+      the current goal is also given as an argument to [t]. The goal
+      is normalised with respect to evars. *)
+  val nf_enter : ([ `NF ] t -> unit tactic) -> unit tactic
+
+  (** Like {!nf_enter}, but does not normalize the goal beforehand. *)
+  val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
+
+  (** Recover the list of current goals under focus, without evar-normalization *)
+  val goals : [ `LZ ] t tactic list tactic
+
+  (** Compatibility: avoid if possible *)
+  val goal : [ `NF ] t -> Evar.t
+
+end
+
+
+(** {6 The refine tactic} *)
+
+module Refine : sig
+
+  (** Printer used to print the constr which refine refines. *)
+  val pr_constr :
+    (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t
+
+  (** {7 Refinement primitives} *)
+
+  val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * Constr.t) -> unit tactic
+  (** In [refine ?unsafe t], [t] is a term with holes under some
+      [evar_map] context. The term [t] is used as a partial solution
+      for the current goal (refine is a goal-dependent tactic), the
+      new holes created by [t] become the new subgoals. Exception
+      raised during the interpretation of [t] are caught and result in
+      tactic failures. If [unsafe] is [true] (default) [t] is
+      type-checked beforehand. *)
+
+  (** {7 Helper functions} *)
+
+  val with_type : Environ.env -> Evd.evar_map ->
+    Term.constr -> Term.types -> Evd.evar_map * Term.constr
+  (** [with_type env sigma c t] ensures that [c] is of type [t]
+      inserting a coercion if needed. *)
+
+  val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*Constr.t) -> unit tactic
+  (** Like {!refine} except the refined term is coerced to the conclusion of the
+      current goal. *)
+
+end
+
+
+(** {6 Trace} *)
+
+module Trace : sig
+
+  (** [record_info_trace t] behaves like [t] except the [info] trace
+      is stored. *)
+  val record_info_trace : 'a tactic -> 'a tactic
+
+  val log : Proofview_monad.lazy_msg -> unit tactic
+  val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic
+
+  val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds
+
+end
+
+
+(** {6 Non-logical state} *)
+
+(** The [NonLogical] module allows the execution of effects (including
+    I/O) in tactics (non-logical side-effects are not discarded at
+    failures). *)
+module NonLogical : module type of Logic_monad.NonLogical
+
+(** [tclLIFT c] is a tactic which behaves exactly as [c]. *)
+val tclLIFT : 'a NonLogical.t -> 'a tactic
+
+
+(**/**)
+
 (*** Compatibility layer with <= 8.2 tactics ***)
 module V82 : sig
-  type tac = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma 
+  type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma
   val tactic : tac -> unit tactic
 
+  (* normalises the evars in the goals, and stores the result in
+     solution. *)
+  val nf_evar_goals : unit tactic
+
   val has_unresolved_evar : proofview -> bool
 
   (* Main function in the implementation of Grab Existential Variables.
@@ -220,17 +548,29 @@ module V82 : sig
 
   (* Returns the open goals of the proofview together with the evar_map to 
      interprete them. *)
-  val goals : proofview -> Goal.goal list Evd.sigma
+  val goals : proofview -> Evar.t list Evd.sigma
 
-  val top_goals : proofview -> Goal.goal list Evd.sigma
+  val top_goals : entry -> proofview -> Evar.t list Evd.sigma
   
   (* returns the existential variable used to start the proof *)
-  val top_evars : proofview -> Evd.evar list
+  val top_evars : entry -> Evd.evar list
     
   (* Implements the Existential command *)
-  val instantiate_evar : int -> Topconstr.constr_expr -> proofview -> proofview
+  val instantiate_evar : int -> Constrexpr.constr_expr -> proofview -> proofview
+
+  (* Caution: this function loses quite a bit of information. It
+     should be avoided as much as possible.  It should work as
+     expected for a tactic obtained from {!V82.tactic} though. *)
+  val of_tactic : 'a tactic -> tac
+
+  (* marks as unsafe if the argument is [false] *)
+  val put_status : bool -> unit tactic
+
+  (* exception for which it is deemed to be safe to transmute into
+     tactic failure. *)
+  val catchable_exception : exn -> bool
 
-  (* spiwack: [purify] might be useful while writing tactics manipulating exception 
-     explicitely or from the [V82] submodule (neither being advised, though *)
-  val purify : 'a tactic -> 'a tactic
+  (* transforms every Ocaml (catchable) exception into a failure in
+     the monad. *)
+  val wrap_exceptions : (unit -> 'a tactic) -> 'a tactic
 end
diff --git a/proofs/proofview_monad.ml b/proofs/proofview_monad.ml
new file mode 100644
index 00000000..6e68cd2e
--- /dev/null
+++ b/proofs/proofview_monad.ml
@@ -0,0 +1,270 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This file defines the datatypes used as internal states by the
+    tactic monad, and specialises the [Logic_monad] to these type. *)
+
+(** {6 Trees/forest for traces} *)
+
+module Trace = struct
+
+  (** The intent is that an ['a forest] is a list of messages of type
+      ['a]. But messages can stand for a list of more precise
+      messages, hence the structure is organised as a tree. *)
+  type 'a forest = 'a tree list
+  and  'a tree   = Seq of 'a * 'a forest
+
+  (** To build a trace incrementally, we use an intermediary data
+      structure on which we can define an S-expression like language
+      (like a simplified xml except the closing tags do not carry a
+      name). Note that nodes are built from right to left in ['a
+      incr], the result is mirrored when returning so that in the
+      exposed interface, the forest is read from left to right.
+
+      Concretely, we want to add a new tree to a forest: and we are
+      building it by adding new trees to the left of its left-most
+      subtrees which is built the same way. *)
+  type 'a incr = { head:'a forest ; opened: 'a tree list }
+
+  (** S-expression like language as ['a incr] transformers. It is the
+      responsibility of the library builder not to use [close] when no
+      tag is open. *)
+  let empty_incr = { head=[] ; opened=[] }
+  let opn a { head ; opened } = { head ; opened = Seq(a,[])::opened }
+  let close { head ; opened } =
+    match opened with
+    | [a] -> { head = a::head ; opened=[] }
+    | a::Seq(b,f)::opened -> { head ; opened=Seq(b,a::f)::opened }
+    | [] -> assert false
+  let leaf a s = close (opn a s)
+
+  (** Returning a forest. It is the responsibility of the library
+      builder to close all the tags. *)
+  (* spiwack: I may want to close the tags instead, to deal with
+     interruptions. *)
+  let rec mirror f = List.rev_map mirror_tree f
+  and mirror_tree (Seq(a,f)) = Seq(a,mirror f)
+
+  let to_tree = function
+    | { head ; opened=[] } -> mirror head
+    | { head ; opened=_::_} -> assert false
+
+end
+
+
+
+(** {6 State types} *)
+
+(** We typically label nodes of [Trace.tree] with messages to
+    print. But we don't want to compute the result. *)
+type lazy_msg = unit -> Pp.std_ppcmds
+let pr_lazy_msg msg = msg ()
+
+(** Info trace. *)
+module Info = struct
+
+  (** The type of the tags for [info]. *)
+  type tag =
+    | Msg of lazy_msg (** A simple message *)
+    | Tactic of lazy_msg (** A tactic call *)
+    | Dispatch  (** A call to [tclDISPATCH]/[tclEXTEND] *)
+    | DBranch  (** A special marker to delimit individual branch of a dispatch. *)
+
+  type state = tag Trace.incr
+  type tree = tag Trace.forest
+
+
+
+  let pr_in_comments m = Pp.(str"(* "++pr_lazy_msg m++str" *)")
+
+  let unbranch = function
+    | Trace.Seq (DBranch,brs) -> brs
+    | _ -> assert false
+
+
+  let is_empty_branch = let open Trace in function
+    | Seq(DBranch,[]) -> true
+    | _ -> false
+
+  (** Dispatch with empty branches are (supposed to be) equivalent to
+      [idtac] which need not appear, so they are removed from the
+      trace. *)
+  let dispatch brs =
+    let open Trace in
+    if CList.for_all is_empty_branch brs then None
+    else Some (Seq(Dispatch,brs))
+
+  let constr = let open Trace in function
+    | Dispatch -> dispatch
+    | t -> fun br -> Some (Seq(t,br))
+
+  let rec compress_tree = let open Trace in function
+    | Seq(t,f) -> constr t (compress f)
+  and compress f =
+    CList.map_filter compress_tree f
+
+  let rec is_empty = let open Trace in function
+    | Seq(Dispatch,brs) -> List.for_all is_empty brs
+    | Seq(DBranch,br) -> List.for_all is_empty br
+    | _ -> false
+
+  (** [with_sep] is [true] when [Tactic m] must be printed with a
+      trailing semi-colon. *)
+  let rec pr_tree with_sep = let open Trace in function
+    | Seq (Msg m,[]) -> pr_in_comments m
+    | Seq (Tactic m,_) ->
+        let tail = if with_sep then Pp.str";" else Pp.mt () in
+        Pp.(pr_lazy_msg m ++ tail)
+    | Seq (Dispatch,brs) ->
+        let tail = if with_sep then Pp.str";" else Pp.mt () in
+        Pp.(pr_dispatch brs++tail)
+    | Seq (Msg _,_::_) | Seq (DBranch,_) -> assert false
+  and pr_dispatch brs =
+    let open Pp in
+    let brs = List.map unbranch brs in
+    match brs with
+    | [br] -> pr_forest br
+    | _ ->
+        let sep () = spc()++str"|"++spc() in
+        let branches = prlist_with_sep sep pr_forest brs in
+        str"[>"++spc()++branches++spc()++str"]"
+  and pr_forest = function
+    | [] -> Pp.mt ()
+    | [tr] -> pr_tree false tr
+    | tr::l -> Pp.(pr_tree true tr ++ pr_forest l)
+
+  let print f =
+    pr_forest (compress f)
+
+  let rec collapse_tree n t =
+    let open Trace in
+    match n , t with
+    | 0 , t -> [t]
+    | _ , (Seq(Tactic _,[]) as t) -> [t]
+    | n , Seq(Tactic _,f) -> collapse (pred n) f
+    | n , Seq(Dispatch,brs) -> [Seq(Dispatch, (collapse n brs))]
+    | n , Seq(DBranch,br) -> [Seq(DBranch, (collapse n br))]
+    | _ , (Seq(Msg _,_) as t) -> [t]
+  and collapse n f =
+    CList.map_append (collapse_tree n) f
+end
+
+
+(** Type of proof views: current [evar_map] together with the list of
+    focused goals. *)
+type proofview = { solution : Evd.evar_map; comb : Goal.goal list }
+
+
+(** {6 Instantiation of the logic monad} *)
+
+(** Parameters of the logic monads *)
+module P = struct
+
+  type s = proofview * Environ.env
+
+  (** Recording info trace (true) or not. *)
+  type e = bool
+
+  (** Status (safe/unsafe) * shelved goals * given up *)
+  type w = bool * Evar.t list * Evar.t list
+
+  let wunit = true , [] , []
+  let wprod (b1,s1,g1) (b2,s2,g2) = b1 && b2 , s1@s2 , g1@g2
+
+  type u = Info.state
+
+  let uunit = Trace.empty_incr
+
+end
+
+module Logical = Logic_monad.Logical(P)
+
+
+(** {6 Lenses to access to components of the states} *)
+
+module type State = sig
+  type t
+  val get : t Logical.t
+  val set : t -> unit Logical.t
+  val modify : (t->t) -> unit Logical.t
+end
+
+module type Writer = sig
+  type t
+  val put : t -> unit Logical.t
+end
+
+module Pv : State with type t := proofview = struct
+  let get = Logical.(map fst get)
+  let set p = Logical.modify (fun (_,e) -> (p,e))
+  let modify f= Logical.modify (fun (p,e) -> (f p,e))
+end
+
+module Solution : State with type t := Evd.evar_map = struct
+  let get = Logical.map (fun {solution} -> solution) Pv.get
+  let set s = Pv.modify (fun pv -> { pv with solution = s })
+  let modify f = Pv.modify (fun pv -> { pv with solution = f pv.solution })
+end
+
+module Comb : State with type t = Evar.t list = struct
+    (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
+  type t = Evar.t list
+  let get = Logical.map (fun {comb} -> comb) Pv.get
+  let set c = Pv.modify (fun pv -> { pv with comb = c })
+  let modify f = Pv.modify (fun pv -> { pv with comb = f pv.comb })
+end
+
+module Env : State with type t := Environ.env = struct
+  let get = Logical.(map snd get)
+  let set e = Logical.modify (fun (p,_) -> (p,e))
+  let modify f = Logical.modify (fun (p,e) -> (p,f e))
+end
+
+module Status : Writer with type t := bool = struct
+  let put s = Logical.put (s,[],[])
+end
+
+module Shelf : Writer with type t = Evar.t list = struct
+    (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
+  type t = Evar.t list
+  let put sh = Logical.put (true,sh,[])
+end
+
+module Giveup : Writer with type t = Evar.t list = struct
+    (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *)
+  type t = Evar.t list
+  let put gs = Logical.put (true,[],gs)
+end
+
+(** Lens and utilies pertaining to the info trace *)
+module InfoL = struct
+  let recording = Logical.current
+  let if_recording t =
+    let open Logical in
+    recording >>= fun r ->
+    if r then t else return ()
+
+  let record_trace t = Logical.local true t
+
+  let raw_update = Logical.update
+  let update f = if_recording (raw_update f)
+  let opn a = update (Trace.opn a)
+  let close = update Trace.close
+  let leaf a = update (Trace.leaf a)
+
+  let tag a t =
+    let open Logical in
+    recording >>= fun r ->
+    if r then begin
+      raw_update (Trace.opn a) >>
+      t >>= fun a ->
+      raw_update Trace.close >>
+      return a
+    end else
+      t
+end
diff --git a/proofs/proofview_monad.mli b/proofs/proofview_monad.mli
new file mode 100644
index 00000000..d2a2e55f
--- /dev/null
+++ b/proofs/proofview_monad.mli
@@ -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        *)
+(************************************************************************)
+
+(** This file defines the datatypes used as internal states by the
+    tactic monad, and specialises the [Logic_monad] to these type. *)
+
+(** {6 Traces} *)
+
+module Trace : sig
+
+  (** The intent is that an ['a forest] is a list of messages of type
+      ['a]. But messages can stand for a list of more precise
+      messages, hence the structure is organised as a tree. *)
+  type 'a forest = 'a tree list
+  and  'a tree   = Seq of 'a * 'a forest
+
+  (** To build a trace incrementally, we use an intermediary data
+      structure on which we can define an S-expression like language
+      (like a simplified xml except the closing tags do not carry a
+      name). *)
+  type 'a incr
+  val to_tree : 'a incr -> 'a forest
+
+  (** [open a] opens a tag with name [a]. *)
+  val opn : 'a -> 'a incr -> 'a incr
+
+  (** [close] closes the last open tag. It is the responsibility of
+      the user to close all the tags. *)
+  val close : 'a incr -> 'a incr
+
+  (** [leaf] creates an empty tag with name [a]. *)
+  val leaf : 'a -> 'a incr -> 'a incr
+
+end
+
+(** {6 State types} *)
+
+(** We typically label nodes of [Trace.tree] with messages to
+    print. But we don't want to compute the result. *)
+type lazy_msg = unit -> Pp.std_ppcmds
+
+(** Info trace. *)
+module Info : sig
+
+  (** The type of the tags for [info]. *)
+  type tag =
+    | Msg of lazy_msg (** A simple message *)
+    | Tactic of lazy_msg (** A tactic call *)
+    | Dispatch  (** A call to [tclDISPATCH]/[tclEXTEND] *)
+    | DBranch  (** A special marker to delimit individual branch of a dispatch. *)
+
+  type state = tag Trace.incr
+  type tree = tag Trace.forest
+
+  val print : tree -> Pp.std_ppcmds
+
+  (** [collapse n t] flattens the first [n] levels of [Tactic] in an
+      info trace, effectively forgetting about the [n] top level of
+      names (if there are fewer, the last name is kept). *)
+  val collapse : int -> tree -> tree
+
+end
+
+(** Type of proof views: current [evar_map] together with the list of
+    focused goals. *)
+type proofview = { solution : Evd.evar_map; comb : Goal.goal list }
+
+(** {6 Instantiation of the logic monad} *)
+
+module P : sig
+  type s = proofview * Environ.env
+
+  (** Status (safe/unsafe) * shelved goals * given up *)
+  type w = bool * Evar.t list * Evar.t list
+
+  val wunit : w
+  val wprod : w -> w -> w
+
+  (** Recording info trace (true) or not. *)
+  type e = bool
+
+  type u = Info.state
+
+  val uunit : u
+end
+
+module Logical : module type of Logic_monad.Logical(P)
+
+
+(** {6 Lenses to access to components of the states} *)
+
+module type State = sig
+  type t
+  val get : t Logical.t
+  val set : t -> unit Logical.t
+  val modify : (t->t) -> unit Logical.t
+end
+
+module type Writer = sig
+  type t
+  val put : t -> unit Logical.t
+end
+
+(** Lens to the [proofview]. *)
+module Pv : State with type t := proofview
+
+(** Lens to the [evar_map] of the proofview. *)
+module Solution : State with type t := Evd.evar_map
+
+(** Lens to the list of focused goals. *)
+module Comb : State with type t = Evar.t list
+
+(** Lens to the global environment. *)
+module Env : State with type t := Environ.env
+
+(** Lens to the tactic status ([true] if safe, [false] if unsafe) *)
+module Status : Writer with type t := bool
+
+(** Lens to the list of goals which have been shelved during the
+    execution of the tactic. *)
+module Shelf : Writer with type t = Evar.t list
+
+(** Lens to the list of goals which were given up during the execution
+    of the tactic. *)
+module Giveup : Writer with type t = Evar.t list
+
+(** Lens and utilies pertaining to the info trace *)
+module InfoL : sig
+  (** [record_trace t] behaves like [t] and compute its [info] trace. *)
+  val record_trace : 'a Logical.t -> 'a Logical.t
+
+  val update : (Info.state -> Info.state) -> unit Logical.t
+  val opn : Info.tag -> unit Logical.t
+  val close : unit Logical.t
+  val leaf : Info.tag -> unit Logical.t
+
+  (** [tag a t] opens tag [a] runs [t] then closes the tag. *)
+  val tag : Info.tag -> 'a Logical.t -> 'a Logical.t
+end
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 3c2431a1..18588867 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -1,25 +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 Pp
+open Errors
 open Util
 open Names
 open Term
 open Declarations
-open Libnames
-open Glob_term
+open Globnames
+open Genredexpr
 open Pattern
 open Reductionops
 open Tacred
 open Closure
 open RedFlags
 open Libobject
-open Summary
+open Misctypes
 
 (* call by value normalisation function using the virtual machine *)
 let cbv_vm env sigma c =
@@ -28,13 +29,35 @@ let cbv_vm env sigma c =
     error "vm_compute does not support existential variables.";
   Vnorm.cbv_vm env c ctyp
 
+let cbv_native env sigma c =
+  let ctyp = Retyping.get_type_of env sigma c in
+  let evars = Nativenorm.evars_of_evar_map sigma in
+  Nativenorm.native_norm env evars c ctyp
+
+let whd_cbn flags env sigma t =
+  let (state,_) =
+    (whd_state_gen true flags env sigma (t,Reductionops.Stack.empty))
+  in Reductionops.Stack.zip ~refold:true state
+
+let strong_cbn flags =
+  strong (whd_cbn flags)
+
+let simplIsCbn = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Plug the simpl tactic to the new cbn mechanism";
+  Goptions.optkey = ["SimplIsCbn"];
+  Goptions.optread = (fun () -> !simplIsCbn);
+  Goptions.optwrite = (fun a -> simplIsCbn:=a);
+}
 
 let set_strategy_one ref l  =
   let k =
     match ref with
       | EvalConstRef sp -> ConstKey sp
       | EvalVarRef id -> VarKey id in
-  Conv_oracle.set_strategy k l;
+  Global.set_strategy k l;
   match k,l with
       ConstKey sp, Conv_oracle.Opaque ->
         Csymtable.set_opaque_const sp
@@ -44,7 +67,7 @@ let set_strategy_one ref l  =
 	  | OpaqueDef _ ->
             errorlabstrm "set_transparent_const"
               (str "Cannot make" ++ spc () ++
-		 Nametab.pr_global_env Idset.empty (ConstRef sp) ++
+		 Nametab.pr_global_env Id.Set.empty (ConstRef sp) ++
 		 spc () ++ str "transparent because it was declared opaque.");
 	  | _ -> Csymtable.set_transparent_const sp)
     | _ -> ()
@@ -56,9 +79,9 @@ let cache_strategy (_,str) =
 
 let subst_strategy (subs,(local,obj)) =
   local,
-  list_smartmap
+  List.smartmap
     (fun (k,ql as entry) ->
-      let ql' = list_smartmap (Mod_subst.subst_evaluable_reference subs) ql in
+      let ql' = List.smartmap (Mod_subst.subst_evaluable_reference subs) ql in
       if ql==ql' then entry else (k,ql'))
     obj
 
@@ -71,8 +94,8 @@ let map_strategy f l =
           match f q with
               Some q' -> q' :: ql
             | None -> ql) ql [] in
-      if ql'=[] then str else (lev,ql')::str) l [] in
-  if l'=[] then None else Some (false,l')
+      if List.is_empty ql' then str else (lev,ql')::str) l [] in
+  if List.is_empty l' then None else Some (false,l')
 
 let classify_strategy (local,_ as obj) =
   if local then Dispose else Substitute obj
@@ -103,12 +126,6 @@ let inStrategy : strategy_obj -> obj =
 let set_strategy local str =
   Lib.add_anonymous_leaf (inStrategy (local,str))
 
-let _ = declare_summary "Transparent constants and variables"
-    { freeze_function = Conv_oracle.freeze;
-      unfreeze_function = Conv_oracle.unfreeze;
-      init_function = Conv_oracle.init }
-
-
 (* Generic reduction: reduction functions used in reduction tactics *)
 
 type red_expr =
@@ -118,7 +135,7 @@ let make_flag_constant = function
   | EvalVarRef id -> fVAR id
   | EvalConstRef sp -> fCONST sp
 
-let make_flag f =
+let make_flag env f =
   let red = no_red in
   let red = if f.rBeta then red_add red fBETA else red in
   let red = if f.rIota then red_add red fIOTA else red in
@@ -126,7 +143,8 @@ let make_flag f =
   let red =
     if f.rDelta then (* All but rConst *)
         let red = red_add red fDELTA in
-        let red = red_add_transparent red (Conv_oracle.get_transp_state()) in
+        let red = red_add_transparent red 
+                    (Conv_oracle.get_transp_state (Environ.oracle env)) in
 	List.fold_right
 	  (fun v red -> red_sub red (make_flag_constant v))
 	  f.rConst red
@@ -141,81 +159,90 @@ let is_reference = function PRef _ | PVar _ -> true | _ -> false
 
 (* table of custom reductino fonctions, not synchronized,
    filled via ML calls to [declare_reduction] *)
-let reduction_tab = ref Stringmap.empty
+let reduction_tab = ref String.Map.empty
 
 (* table of custom reduction expressions, synchronized,
    filled by command Declare Reduction *)
-let red_expr_tab = ref Stringmap.empty
+let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction"
 
 let declare_reduction s f =
-  if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab
+  if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab
   then error ("There is already a reduction expression of name "^s)
-  else reduction_tab := Stringmap.add s f !reduction_tab
+  else reduction_tab := String.Map.add s f !reduction_tab
 
 let check_custom = function
   | ExtraRedExpr s ->
-      if not (Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab)
+      if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab)
       then error ("Reference to undefined reduction expression "^s)
   |_ -> ()
 
 let decl_red_expr s e =
-  if Stringmap.mem s !reduction_tab || Stringmap.mem s !red_expr_tab
+  if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab
   then error ("There is already a reduction expression of name "^s)
   else begin
     check_custom e;
-    red_expr_tab := Stringmap.add s e !red_expr_tab
+    red_expr_tab := String.Map.add s e !red_expr_tab
   end
 
 let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
   | ArgArg x -> x
 
-let out_with_occurrences ((b,l),c) =
-  ((b,List.map out_arg l), c)
+let out_with_occurrences (occs,c) =
+  (Locusops.occurrences_map (List.map out_arg) occs, c)
+
+let e_red f env evm c = evm, f env evm c
+
+let head_style = false (* Turn to true to have a semantics where simpl
+   only reduce at the head when an evaluable reference is given, e.g.
+   2+n would just reduce to S(1+n) instead of S(S(n)) *)
+
+let contextualize f g = function
+  | Some (occs,c) ->
+      let l = Locusops.occurrences_map (List.map out_arg) occs in
+      let b,c,h = match c with
+        | Inl r -> true,PRef (global_of_evaluable_reference r),f
+        | Inr c -> false,c,f in
+      e_red (contextually b (l,c) (fun _ -> h))
+  | None -> e_red g
 
-let rec reduction_of_red_expr = function
+let reduction_of_red_expr env =
+  let make_flag = make_flag env in
+  let rec reduction_of_red_expr = function
   | Red internal ->
-      if internal then (try_red_product,DEFAULTcast)
-      else (red_product,DEFAULTcast)
-  | Hnf -> (hnf_constr,DEFAULTcast)
-  | Simpl (Some (_,c as lp)) ->
-    (contextually (is_reference c) (out_with_occurrences lp)
-      (fun _ -> simpl),DEFAULTcast)
-  | Simpl None -> (simpl,DEFAULTcast)
-  | Cbv f -> (cbv_norm_flags (make_flag f),DEFAULTcast)
-  | Lazy f -> (clos_norm_flags (make_flag f),DEFAULTcast)
-  | Unfold ubinds -> (unfoldn (List.map out_with_occurrences ubinds),DEFAULTcast)
-  | Fold cl -> (fold_commands cl,DEFAULTcast)
+      if internal then (e_red try_red_product,DEFAULTcast)
+      else (e_red red_product,DEFAULTcast)
+  | Hnf -> (e_red hnf_constr,DEFAULTcast)
+  | Simpl (f,o) ->
+     let whd_am = if !simplIsCbn then whd_cbn (make_flag f) else whd_simpl in
+     let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in
+     let () =
+       if not (!simplIsCbn || List.is_empty f.rConst) then
+	 Pp.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in
+     (contextualize (if head_style then whd_am else am) am o,DEFAULTcast)
+  | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast)
+  | Cbn f ->
+     (e_red (strong_cbn (make_flag f)), DEFAULTcast)
+  | Lazy f -> (e_red (clos_norm_flags (make_flag f)),DEFAULTcast)
+  | Unfold ubinds -> (e_red (unfoldn (List.map out_with_occurrences ubinds)),DEFAULTcast)
+  | Fold cl -> (e_red (fold_commands cl),DEFAULTcast)
   | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast)
   | ExtraRedExpr s ->
-      (try (Stringmap.find s !reduction_tab,DEFAULTcast)
+      (try (e_red (String.Map.find s !reduction_tab),DEFAULTcast)
       with Not_found ->
-	(try reduction_of_red_expr (Stringmap.find s !red_expr_tab)
+	(try reduction_of_red_expr (String.Map.find s !red_expr_tab)
 	 with Not_found ->
 	   error("unknown user-defined reduction \""^s^"\"")))
-  | CbvVm -> (cbv_vm ,VMcast)
+  | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast)
+  | CbvNative o -> (contextualize cbv_native cbv_native o, VMcast)
+  in
+    reduction_of_red_expr
 
-
-let subst_flags subs flags =
-  { flags with rConst = List.map subs flags.rConst }
-
-let subst_occs subs (occ,e) = (occ,subs e)
-
-let subst_gen_red_expr subs_a subs_b subs_c = function
-  | Fold l -> Fold (List.map subs_a l)
-  | Pattern occs_l -> Pattern (List.map (subst_occs subs_a) occs_l)
-  | Simpl occs_o -> Simpl (Option.map (subst_occs subs_c) occs_o)
-  | Unfold occs_l -> Unfold (List.map (subst_occs subs_b) occs_l)
-  | Cbv flags -> Cbv (subst_flags subs_b flags)
-  | Lazy flags -> Lazy (subst_flags subs_b flags)
-  | e -> e
-
-let subst_red_expr subs e =
-  subst_gen_red_expr
+let subst_red_expr subs =
+  Miscops.map_red_expr_gen
     (Mod_subst.subst_mps subs)
     (Mod_subst.subst_evaluable_reference subs)
-    (Pattern.subst_pattern subs)
-    e
+    (Patternops.subst_pattern subs)
 
 let inReduction : bool * string * red_expr -> obj =
   declare_object
@@ -229,8 +256,3 @@ let inReduction : bool * string * red_expr -> obj =
 
 let declare_red_expr locality s expr =
     Lib.add_anonymous_leaf (inReduction (locality,s,expr))
-
-let _ = declare_summary "Declare Reduction"
-  { freeze_function = (fun () -> !red_expr_tab);
-    unfreeze_function = ((:=) red_expr_tab);
-    init_function = (fun () -> red_expr_tab := Stringmap.empty) }
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index 285f9cfd..b32cedf8 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.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,18 +8,18 @@
 
 open Names
 open Term
-open Closure
 open Pattern
-open Glob_term
+open Genredexpr
 open Reductionops
-open Termops
+open Locus
 
 type red_expr =
     (constr, evaluable_global_reference, constr_pattern) red_expr_gen
-
+ 
 val out_with_occurrences : 'a with_occurrences -> occurrences * 'a
 
-val reduction_of_red_expr : red_expr -> reduction_function * cast_kind
+val reduction_of_red_expr :
+  Environ.env -> red_expr -> e_reduction_function * cast_kind
 
 (** [true] if we should use the vm to verify the reduction *)
 
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index ca82e882..974fa212 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -1,22 +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 Compat
 open Pp
+open Errors
 open Util
-open Term
-open Termops
-open Sign
 open Evd
-open Sign
 open Environ
-open Reductionops
-open Type_errors
 open Proof_type
 open Logic
 
@@ -29,66 +23,41 @@ let project x = x.sigma
 let pf_env gls = Global.env_of_context (Goal.V82.hyps (project gls) (sig_it gls))
 let pf_hyps gls = named_context_of_val (Goal.V82.hyps (project gls) (sig_it gls))
 
-let abstract_operation syntax semantics =
-  semantics
+let refiner pr goal_sigma =
+  let (sgl,sigma') = prim_refiner pr goal_sigma.sigma goal_sigma.it in
+  { it = sgl; sigma = sigma'; }
 
-let abstract_tactic_expr ?(dflt=false) te tacfun gls =
-  abstract_operation (Tactic(te,dflt)) tacfun gls
-
-let abstract_tactic ?(dflt=false) te =
-  !abstract_tactic_box := Some te;
-  abstract_tactic_expr ~dflt (Tacexpr.TacAtom (dummy_loc,te))
-
-let abstract_extended_tactic ?(dflt=false) s args =
-  abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args))
-
-let refiner = function
-  | Prim pr ->
-      let prim_fun = prim_refiner pr in
-	(fun goal_sigma ->
-          let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in
-	  {it=sgl; sigma = sigma'})
-
-
-  | Nested (_,_) | Decl_proof _ ->
-      failwith "Refiner: should not occur"
-
-	(* Daimon is a canonical unfinished proof *)
-
-  | Daimon ->
-      fun gls ->
-	{it=[];sigma=gls.sigma}
-
-
-let norm_evar_tac gl = refiner (Prim Change_evars) gl
+(* Profiling refiner *)
+let refiner = 
+  if Flags.profile then
+    let refiner_key = Profile.declare_profile "refiner" in
+      Profile.profile2 refiner_key refiner
+  else refiner
 
 (*********************)
 (*   Tacticals       *)
 (*********************)
 
 
-let unpackage glsig = (ref (glsig.sigma)),glsig.it
+let unpackage glsig = (ref (glsig.sigma)), glsig.it
 
-let repackage r v = {it=v;sigma = !r}
+let repackage r v = {it = v; sigma = !r; }
 
 let apply_sig_tac r tac g =
-  check_for_interrupt (); (* Breakpoint *)
+  Control.check_for_interrupt (); (* Breakpoint *)
   let glsigma = tac (repackage r g) in
   r := glsigma.sigma;
   glsigma.it
 
 (* [goal_goal_list : goal sigma -> goal list sigma] *)
-let goal_goal_list gls = {it=[gls.it];sigma=gls.sigma}
-
-(* forces propagation of evar constraints *)
-let tclNORMEVAR = norm_evar_tac
+let goal_goal_list gls = {it=[gls.it]; sigma=gls.sigma; }
 
 (* identity tactic without any message *)
 let tclIDTAC gls = goal_goal_list gls
 
 (* the message printing identity tactic *)
 let tclIDTAC_MESSAGE s gls =
-  msg (hov 0 s); tclIDTAC gls
+  Pp.msg_info (hov 0 s); pp_flush (); tclIDTAC gls
 
 (* General failure tactic *)
 let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s)
@@ -102,8 +71,8 @@ let tclFAIL lvl s g = raise (FailError (lvl,lazy s))
 let tclFAIL_lazy lvl s g = raise (FailError (lvl,s))
 
 let start_tac gls =
-  let (sigr,g) = unpackage gls in
-  (sigr,[g])
+  let sigr, g = unpackage gls in
+  (sigr, [g])
 
 let finish_tac (sigr,gl) = repackage sigr gl
 
@@ -115,7 +84,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) =
   let ng = List.length gs in
   if ng<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
   let gll =
-      (list_map_i (fun i ->
+      (List.map_i (fun i ->
         apply_sig_tac sigr (if i<nf then tacfi.(i) else if i>=ng-nl then tacli.(nl-ng+i) else tac))
 	0 gs) in
     (sigr,List.flatten gll)
@@ -123,33 +92,14 @@ let thens3parts_tac tacfi tac tacli (sigr,gs) =
 (* Apply [taci.(i)] on the first n subgoals and [tac] on the others *)
 let thensf_tac taci tac = thens3parts_tac taci tac [||]
 
-(* Apply [taci.(i)] on the last n subgoals and [tac] on the others *)
-let thensl_tac tac taci = thens3parts_tac [||] tac taci
-
 (* Apply [tac i] on the ith subgoal (no subgoals number check) *)
 let thensi_tac tac (sigr,gs) =
   let gll =
-    list_map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs in
+    List.map_i (fun i -> apply_sig_tac sigr (tac i)) 1 gs in
   (sigr, List.flatten gll)
 
 let then_tac tac = thensf_tac [||] tac
 
-let non_existent_goal n =
-  errorlabstrm ("No such goal: "^(string_of_int n))
-    (str"Trying to apply a tactic to a non existent goal")
-
-(* Apply tac on the i-th goal (if i>0). If i<0, then start counting from
-   the last goal (i=-1). *)
-let theni_tac i tac ((_,gl) as subgoals) =
-  let nsg = List.length gl in
-  let k = if i < 0 then nsg + i + 1 else i in
-  if nsg < 1 then errorlabstrm "theni_tac" (str"No more subgoals.")
-  else if k >= 1 & k <= nsg then
-    thensf_tac
-      (Array.init k (fun i -> if i+1 = k then tac else tclIDTAC)) tclIDTAC
-      subgoals
-  else non_existent_goal k
-
 (* [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls]
    applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to
    the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m]
@@ -236,26 +186,55 @@ let tclNOTSAMEGOAL (tac : tactic) goal =
       (str"Tactic generated a subgoal identical to the original goal.")
   else rslt
 
-let catch_failerror e =
-  if catchable_exception e then check_for_interrupt ()
+(* Execute tac and show the names of hypothesis create by tac in
+   the "as" format. The resulting goals are printed *after* the
+   as-expression, which forces pg to some gymnastic. TODO: Have
+   something similar (better?) in the xml protocol. *)
+let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma)
+    :Proof_type.goal list Evd.sigma =
+  let oldhyps:Context.named_context = pf_hyps goal in
+  let rslt:Proof_type.goal list Evd.sigma = tac goal in
+  let { it = gls; sigma = sigma; } = rslt in
+  let hyps:Context.named_context list =
+    List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in
+  let newhyps =
+    List.map
+      (fun hypl -> List.subtract Context.eq_named_declaration hypl oldhyps)
+      hyps
+  in
+  let emacs_str s =
+    if !Flags.print_emacs then s else "" in
+  let s = 
+    let frst = ref true in
+    List.fold_left
+    (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ")
+      ^ (List.fold_left
+	   (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc)
+	   "" lh))
+    "" newhyps in
+  pp (str (emacs_str "<infoH>")
+      ++  (hov 0 (str s))
+      ++  (str (emacs_str "</infoH>")) ++ fnl());
+  rslt;;
+
+
+let catch_failerror (e, info) =
+  if catchable_exception e then Control.check_for_interrupt ()
   else match e with
-  | FailError (0,_) | Loc.Exc_located(_, FailError (0,_))
-  | Loc.Exc_located(_, LtacLocated (_,FailError (0,_)))  ->
-      check_for_interrupt ()
-  | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
-  | Loc.Exc_located(s,FailError (lvl,s')) ->
-      raise (Loc.Exc_located(s,FailError (lvl - 1, s')))
-  | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s')))  ->
-      raise
-       (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1,s'))))
-  | e -> raise e
+  | FailError (0,_) ->
+      Control.check_for_interrupt ()
+  | FailError (lvl,s) ->
+    iraise (FailError (lvl - 1, s), info)
+  | e -> iraise (e, info)
+  (** FIXME: do we need to add a [Errors.push] here? *)
 
 (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *)
 let tclORELSE0 t1 t2 g =
   try
     t1 g
   with (* Breakpoint *)
-    | e when Errors.noncritical e -> catch_failerror e; t2 g
+    | e when Errors.noncritical e ->
+      let e = Errors.push e in catch_failerror e; t2 g
 
 (* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress,
    then applies t2 *)
@@ -267,11 +246,12 @@ let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2
 let tclORELSE_THEN t1 t2then t2else gls =
   match
     try Some(tclPROGRESS t1 gls)
-    with e when Errors.noncritical e -> catch_failerror e; None
+    with e when Errors.noncritical e ->
+      let e = Errors.push e in catch_failerror e; None
   with
     | None -> t2else gls
     | Some sgl ->
-        let (sigr,gl) = unpackage sgl in
+        let sigr, gl = unpackage sgl in
         finish_tac (then_tac t2then  (sigr,gl))
 
 (* TRY f tries to apply f, and if it fails, leave the goal unchanged *)
@@ -292,13 +272,17 @@ let ite_gen tcal tac_if continue tac_else gl=
       success:=true;result in
   let tac_else0 e gl=
     if !success then
-      raise e
+      iraise e
     else
-      tac_else gl in
-    try
-      tcal tac_if0 continue gl
-    with (* Breakpoint *)
-      | e when Errors.noncritical e -> catch_failerror e; tac_else0 e gl
+      try
+        tac_else gl
+      with
+        e' when Errors.noncritical e' -> iraise e in
+  try
+    tcal tac_if0 continue gl
+  with (* Breakpoint *)
+  | e when Errors.noncritical e ->
+    let e = Errors.push e in catch_failerror e; tac_else0 e gl
 
 (* Try the first tactic and, if it succeeds, continue with
    the second one, and if it fails, use the third one *)
@@ -327,32 +311,11 @@ let tclDO n t =
   let rec dorec k =
     if k < 0 then errorlabstrm "Refiner.tclDO"
       (str"Wrong argument : Do needs a positive integer.");
-    if k = 0 then tclIDTAC
-    else if k = 1 then t else (tclTHEN t (dorec (k-1)))
+    if Int.equal k 0 then tclIDTAC
+    else if Int.equal k 1 then t else (tclTHEN t (dorec (k-1)))
   in
   dorec n
 
-(* Fails if a tactic hasn't finished after a certain amount of time *)
-
-exception TacTimeout
-
-let tclTIMEOUT n t g =
-  let timeout_handler _ = raise TacTimeout in
-  let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
-  ignore (Unix.alarm n);
-  let restore_timeout () =
-    ignore (Unix.alarm 0);
-    Sys.set_signal Sys.sigalrm psh
-  in
-  try
-    let res = t g in
-    restore_timeout ();
-    res
-  with
-    | TacTimeout | Loc.Exc_located(_,TacTimeout) ->
-      restore_timeout ();
-      errorlabstrm "Refiner.tclTIMEOUT" (str"Timeout!")
-    | reraise -> restore_timeout (); raise reraise
 
 (* Beware: call by need of CAML, g is needed *)
 let rec tclREPEAT t g =
@@ -362,81 +325,20 @@ let tclAT_LEAST_ONCE t = (tclTHEN t (tclREPEAT t))
 
 (* Repeat on the first subgoal (no failure if no more subgoal) *)
 let rec tclREPEAT_MAIN t g =
-  (tclORELSE (tclTHEN_i t (fun i -> if i = 1 then (tclREPEAT_MAIN t) else
+  (tclORELSE (tclTHEN_i t (fun i -> if Int.equal i 1 then (tclREPEAT_MAIN t) else
     tclIDTAC)) tclIDTAC) g
 
-(*s Tactics handling a list of goals. *)
-
-type tactic_list = (goal list sigma) -> (goal list sigma)
-
-(* Functions working on goal list for correct backtracking in Prolog *)
-
-let tclFIRSTLIST = tclFIRST
-let tclIDTAC_list gls = gls
-
-(* first_goal : goal list sigma -> goal sigma *)
-
-let first_goal gls =
-  let gl = gls.it and sig_0 = gls.sigma in
-  if gl = [] then error "first_goal";
-  { it = List.hd gl; sigma = sig_0 }
-
-(* goal_goal_list : goal sigma -> goal list sigma *)
-
-let goal_goal_list gls =
-  let gl = gls.it and sig_0 = gls.sigma in { it = [gl]; sigma = sig_0 }
-
-(* tactic -> tactic_list : Apply a tactic to the first goal in the list *)
-
-let apply_tac_list tac glls =
-  let (sigr,lg) = unpackage glls in
-  match lg with
-  | (g1::rest) ->
-      let gl = apply_sig_tac sigr tac g1 in
-      repackage sigr (gl@rest)
-  | _ -> error "apply_tac_list"
-
-let then_tactic_list tacl1 tacl2 glls =
-  let glls1 = tacl1 glls in
-  let glls2 = tacl2 glls1 in
-  glls2
-
-(* Transform a tactic_list into a tactic *)
-
-let tactic_list_tactic tac gls =
-    let glres = tac (goal_goal_list gls) in
-    glres
-
 (* Change evars *)
 let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma}
 
-(* Pretty-printers. *)
+let tclEVARUNIVCONTEXT ctx gls = tclIDTAC {gls with sigma= Evd.set_universe_context gls.sigma ctx}
 
-let pp_info = ref (fun _ _ _ -> assert false)
-let set_info_printer f = pp_info := f
+(* Push universe context *)
+let tclPUSHCONTEXT rigid ctx tac gl = 
+  tclTHEN (tclEVARS (Evd.merge_context_set rigid (project gl) ctx)) tac gl
 
-(* Check that holes in arguments have been resolved *)
+let tclPUSHEVARUNIVCONTEXT ctx gl = 
+  tclEVARS (Evd.merge_universe_context (project gl) ctx) gl
 
-let check_evars env sigma extsigma gl =
-  let origsigma = gl.sigma in
-  let rest =
-    Evd.fold_undefined (fun evk evi acc ->
-      if Evd.is_undefined extsigma evk & not (Evd.mem origsigma evk) then
-	evi::acc
-      else
-	acc)
-      sigma []
-  in
-  if rest <> [] then
-    let evi = List.hd rest in
-    let (loc,k) = evi.evar_source in
-    let evi = Evarutil.nf_evar_info sigma evi in
-    Pretype_errors.error_unsolvable_implicit loc env sigma evi k None
-
-let tclWITHHOLES accept_unresolved_holes tac sigma c gl =
-  if sigma == project gl then tac c gl
-  else
-    let res = tclTHEN (tclEVARS sigma) (tac c) gl in
-    if not accept_unresolved_holes then
-      check_evars (pf_env gl) (res).sigma sigma gl;
-    res
+let tclPUSHCONSTRAINTS cst gl = 
+  tclEVARS (Evd.add_constraints (project gl) cst) gl
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 5db43eaf..a81555ff 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -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 Term
-open Sign
+open Context
 open Evd
 open Proof_type
-open Tacexpr
-open Logic
 
 (** The refiner (handles primitive rules and high-level tactics). *)
 
@@ -26,31 +23,22 @@ val repackage : evar_map ref -> 'a -> 'a sigma
 val apply_sig_tac :
   evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list
 
-(** {6 Hiding the implementation of tactics. } *)
-
-(** [abstract_tactic tac] hides the (partial) proof produced by [tac] under
-   a single proof node. The boolean tells if the default tactic is used. *)
-(* spiwack: currently here for compatibility, abstract_operation 
-    is a second projection *)
-val abstract_operation : compound_rule -> tactic -> tactic
-val abstract_tactic : ?dflt:bool -> atomic_tactic_expr -> tactic -> tactic
-val abstract_tactic_expr : ?dflt:bool -> tactic_expr -> tactic -> tactic
-val abstract_extended_tactic :
-  ?dflt:bool -> string -> typed_generic_argument list -> tactic -> tactic
-
 val refiner : rule -> tactic
 
 (** {6 Tacticals. } *)
 
-(** [tclNORMEVAR] forces propagation of evar constraints *)
-val tclNORMEVAR       : tactic
-
 (** [tclIDTAC] is the identity tactic without message printing*)
 val tclIDTAC          : tactic
 val tclIDTAC_MESSAGE  : Pp.std_ppcmds -> tactic
 
 (** [tclEVARS sigma] changes the current evar map *)
 val tclEVARS : evar_map -> tactic
+val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> tactic
+
+val tclPUSHCONTEXT : Evd.rigid -> Univ.universe_context_set -> tactic -> tactic
+val tclPUSHEVARUNIVCONTEXT : Evd.evar_universe_context -> tactic
+
+val tclPUSHCONSTRAINTS : Univ.constraints -> tactic
 
 (** [tclTHEN tac1 tac2 gls] applies the tactic [tac1] to [gls] and applies
    [tac2] to every resulting subgoals *)
@@ -83,10 +71,6 @@ val tclTHENSV         : tactic -> tactic array -> tactic
 (** Same with a list of tactics *)
 val tclTHENS         : tactic -> tactic list -> tactic
 
-(** [tclTHENST] is renamed [tclTHENSFIRSTn]
-val tclTHENST        : tactic -> tactic array -> tactic -> tactic
-*)
-
 (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls]
    applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to
    the first [n] resulting subgoals, [t'1], ..., [t'm] to the last [m]
@@ -118,7 +102,7 @@ exception FailError of int * Pp.std_ppcmds Lazy.t
 
 (** Takes an exception and either raise it at the next
    level or do nothing. *)
-val catch_failerror  : exn -> unit
+val catch_failerror  : Exninfo.iexn -> unit
 
 val tclORELSE0       : tactic -> tactic -> tactic
 val tclORELSE        : tactic -> tactic -> tactic
@@ -133,9 +117,9 @@ val tclAT_LEAST_ONCE : tactic -> tactic
 val tclFAIL          : int -> Pp.std_ppcmds -> tactic
 val tclFAIL_lazy     : int -> Pp.std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
-val tclTIMEOUT       : int -> tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
+val tclSHOWHYPS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 
 (** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
@@ -150,21 +134,3 @@ val tclIFTHENSVELSE   : tactic -> tactic array -> tactic ->tactic
    Equivalent to [(tac1;try tac2)||tac2] *)
 
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
-
-(** {6 Tactics handling a list of goals. } *)
-
-type tactic_list = goal list sigma -> goal list sigma
-
-val tclFIRSTLIST       : tactic_list list -> tactic_list
-val tclIDTAC_list      : tactic_list
-val first_goal         : 'a list sigma -> 'a sigma
-val apply_tac_list     : tactic -> tactic_list
-val then_tactic_list   : tactic_list -> tactic_list -> tactic_list
-val tactic_list_tactic : tactic_list -> tactic
-val goal_goal_list     : 'a sigma -> 'a list sigma
-
-(** [tclWITHHOLES solve_holes tac (sigma,c)] applies [tac] to [c] which
-   may have unresolved holes; if [solve_holes] these holes must be
-   resolved after application of the tactic; [sigma] must be an
-   extension of the sigma of the goal *)
-val tclWITHHOLES : bool -> ('a -> tactic) -> evar_map -> 'a -> tactic
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
deleted file mode 100644
index 536c966c..00000000
--- a/proofs/tacexpr.ml
+++ /dev/null
@@ -1,345 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Topconstr
-open Libnames
-open Nametab
-open Glob_term
-open Util
-open Genarg
-open Pattern
-open Decl_kinds
-
-type 'a or_metaid = AI of 'a | MetaId of loc * string
-
-type direction_flag = bool (* true = Left-to-right    false = right-to-right *)
-type lazy_flag = bool      (* true = lazy             false = eager *)
-type evars_flag = bool     (* true = pose evars       false = fail on evars *)
-type rec_flag = bool       (* true = recursive        false = not recursive *)
-type advanced_flag = bool  (* true = advanced         false = basic *)
-type split_flag = bool     (* true = exists           false = split *)
-type hidden_flag = bool    (* true = internal use     false = user-level *)
-type letin_flag = bool     (* true = use local def    false = use Leibniz *)
-
-type debug = Debug | Info | Off (* for trivial / auto / eauto ... *)
-
-type glob_red_flag =
-  | FBeta
-  | FIota
-  | FZeta
-  | FConst of reference or_by_notation list
-  | FDeltaBut of reference or_by_notation list
-
-let make_red_flag =
-  let rec add_flag red = function
-    | [] -> red
-    | FBeta :: lf -> add_flag { red with rBeta = true } lf
-    | FIota :: lf -> add_flag { red with rIota = true } lf
-    | FZeta :: lf -> add_flag { red with rZeta = true } lf
-    | FConst l :: lf ->
-	if red.rDelta then
-	  error
-	    "Cannot set both constants to unfold and constants not to unfold";
-        add_flag { red with rConst = list_union red.rConst l } lf
-    | FDeltaBut l :: lf ->
-	if red.rConst <> [] & not red.rDelta then
-	  error
-	    "Cannot set both constants to unfold and constants not to unfold";
-        add_flag
-	  { red with rConst = list_union red.rConst l; rDelta = true }
-	  lf
-  in
-  add_flag
-    {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []}
-
-type 'a raw_hyp_location = 'a with_occurrences * Termops.hyp_location_flag
-
-type 'id move_location =
-  | MoveAfter of 'id
-  | MoveBefore of 'id
-  | MoveToEnd of bool
-
-let no_move = MoveToEnd true
-
-open Pp
-
-let pr_move_location pr_id = function
-  | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id
-  | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id
-  | MoveToEnd toleft -> str (if toleft then " at bottom" else " at top")
-
-type 'a induction_arg =
-  | ElimOnConstr of 'a
-  | ElimOnIdent of identifier located
-  | ElimOnAnonHyp of int
-
-type inversion_kind =
-  | SimpleInversion
-  | FullInversion
-  | FullInversionClear
-
-type ('c,'id) inversion_strength =
-  | NonDepInversion of
-      inversion_kind * 'id list * intro_pattern_expr located option
-  | DepInversion of
-      inversion_kind * 'c option * intro_pattern_expr located option
-  | InversionUsing of 'c * 'id list
-
-type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
-
-type 'id message_token =
-  | MsgString of string
-  | MsgInt of int
-  | MsgIdent of 'id
-
-(* onhyps:
-     [None] means *on every hypothesis*
-     [Some l] means on hypothesis belonging to l *)
-type 'id gclause =
-  { onhyps : 'id raw_hyp_location list option;
-    concl_occs : occurrences_expr }
-
-let nowhere = {onhyps=Some[]; concl_occs=no_occurrences_expr}
-
-type 'constr induction_clause =
-    'constr with_bindings induction_arg *
-    (intro_pattern_expr located option (* eqn:... *)
-    * intro_pattern_expr located option) (* as ... *)
-
-type ('constr,'id) induction_clause_list =
-    'constr induction_clause list
-    * 'constr with_bindings option (* using ... *)
-    * 'id gclause option (* in ... *)
-
-type multi =
-  | Precisely of int
-  | UpTo of int
-  | RepeatStar
-  | RepeatPlus
-
-(* Type of patterns *)
-type 'a match_pattern =
-  | Term of 'a
-  | Subterm of bool * identifier option * 'a
-
-(* Type of hypotheses for a Match Context rule *)
-type 'a match_context_hyps =
-  | Hyp of name located * 'a match_pattern
-  | Def of name located * 'a match_pattern * 'a match_pattern
-
-(* Type of a Match rule for Match Context and Match *)
-type ('a,'t) match_rule =
-  | Pat of 'a match_context_hyps list * 'a match_pattern * 't
-  | All of 't
-
-type ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr =
-  (* Basic tactics *)
-  | TacIntroPattern of intro_pattern_expr located list
-  | TacIntrosUntil of quantified_hypothesis
-  | TacIntroMove of identifier option * 'id move_location
-  | TacAssumption
-  | TacExact of 'constr
-  | TacExactNoCheck of 'constr
-  | TacVmCastNoCheck of 'constr
-  | TacApply of advanced_flag * evars_flag * 'constr with_bindings list *
-      ('id * intro_pattern_expr located option) option
-  | TacElim of evars_flag * 'constr with_bindings *
-      'constr with_bindings option
-  | TacElimType of 'constr
-  | TacCase of evars_flag * 'constr with_bindings
-  | TacCaseType of 'constr
-  | TacFix of identifier option * int
-  | TacMutualFix of hidden_flag * identifier * int * (identifier * int *
-      'constr) list
-  | TacCofix of identifier option
-  | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list
-  | TacCut of 'constr
-  | TacAssert of 'tac option * intro_pattern_expr located option * 'constr
-  | TacGeneralize of ('constr with_occurrences * name) list
-  | TacGeneralizeDep of 'constr
-  | TacLetTac of name * 'constr * 'id gclause * letin_flag *
-      intro_pattern_expr located option
-
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct of rec_flag * quantified_hypothesis
-  | TacInductionDestruct of rec_flag * evars_flag * ('constr,'id) induction_clause_list
-  | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis
-  | TacDecomposeAnd of 'constr
-  | TacDecomposeOr of 'constr
-  | TacDecompose of 'ind list * 'constr
-  | TacSpecialize of int option * 'constr with_bindings
-  | TacLApply of 'constr
-
-  (* Automation tactics *)
-  | TacTrivial of debug * 'constr list * string list option
-  | TacAuto of debug * int or_var option * 'constr list * string list option
-
-  (* Context management *)
-  | TacClear of bool * 'id list
-  | TacClearBody of 'id list
-  | TacMove of bool * 'id * 'id move_location
-  | TacRename of ('id *'id) list
-  | TacRevert of 'id list
-
-  (* Constructors *)
-  | TacLeft of evars_flag * 'constr bindings
-  | TacRight of evars_flag * 'constr bindings
-  | TacSplit of evars_flag * split_flag * 'constr bindings list
-  | TacAnyConstructor of evars_flag * 'tac option
-  | TacConstructor of evars_flag * int or_var * 'constr bindings
-
-  (* Conversion *)
-  | TacReduce of ('constr,'cst,'pat) red_expr_gen * 'id gclause
-  | TacChange of 'pat option * 'constr * 'id gclause
-
-  (* Equivalence relations *)
-  | TacReflexivity
-  | TacSymmetry of 'id gclause
-  | TacTransitivity of 'constr option
-
-  (* Equality and inversion *)
-  | TacRewrite of
-      evars_flag * (bool * multi * 'constr with_bindings) list * 'id gclause * 'tac option
-  | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis
-
-  (* For ML extensions *)
-  | TacExtend of loc * string * 'lev generic_argument list
-
-  (* For syntax extensions *)
-  | TacAlias of loc * string *
-      (identifier * 'lev generic_argument) list
-      * (dir_path * glob_tactic_expr)
-
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr =
-  | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_atomic_tactic_expr
-  | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr array
-  | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr *
-	('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
-  | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
-  | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacSolve of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr list
-  | TacTry of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacOrelse of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacDo of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacTimeout of int or_var * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacRepeat of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacProgress of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacAbstract of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * identifier option
-  | TacId of 'id message_token list
-  | TacFail of int or_var * 'id message_token list
-  | TacInfo of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacLetIn of rec_flag * (identifier located * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg) list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-  | TacMatch of lazy_flag * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list
-  | TacMatchGoal of lazy_flag * direction_flag * ('pat,('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr) match_rule list
-  | TacFun of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast
-  | TacArg of ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg located
-
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_fun_ast =
-  identifier option list * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_expr
-
-  (* These are the possible arguments of a tactic definition *)
-and ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg =
-  | TacDynamic     of loc * Dyn.t
-  | TacVoid
-  | MetaIdArg      of loc * bool * string
-  | ConstrMayEval  of ('constr,'cst,'pat) may_eval
-  | IntroPattern   of intro_pattern_expr located
-  | Reference      of 'ref
-  | Integer        of int
-  | TacCall        of loc *
-      'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list
-  | TacExternal of loc * string * string *
-      ('constr,'pat,'cst,'ind,'ref,'id,'tac,'lev) gen_tactic_arg list
-  | TacFreshId     of string or_var list
-  | Tacexp of 'tac
-
-(* Globalized tactics *)
-and glob_tactic_expr =
-    (glob_constr_and_expr,
-     glob_constr_and_expr * constr_pattern,
-     evaluable_global_reference and_short_name or_var,
-     inductive or_var,
-     ltac_constant located or_var,
-     identifier located,
-     glob_tactic_expr,
-     glevel) gen_tactic_expr
-
-type raw_tactic_expr =
-    (constr_expr,
-     constr_pattern_expr,
-     reference or_by_notation,
-     reference or_by_notation,
-     reference,
-     identifier located or_metaid,
-     raw_tactic_expr,
-     rlevel) gen_tactic_expr
-
-type raw_atomic_tactic_expr =
-    (constr_expr,                  (* constr *)
-     constr_pattern_expr,                 (* pattern *)
-     reference or_by_notation,     (* evaluable reference *)
-     reference or_by_notation,     (* inductive *)
-     reference,                    (* ltac reference *)
-     identifier located or_metaid, (* identifier *)
-     raw_tactic_expr,
-     rlevel) gen_atomic_tactic_expr
-
-type raw_tactic_arg =
-    (constr_expr,
-     constr_pattern_expr,
-     reference or_by_notation,
-     reference or_by_notation,
-     reference,
-     identifier located or_metaid,
-     raw_tactic_expr,
-     rlevel) gen_tactic_arg
-
-type raw_generic_argument = rlevel generic_argument
-
-type raw_red_expr =
-    (constr_expr, reference or_by_notation, constr_expr) red_expr_gen
-
-type glob_atomic_tactic_expr =
-    (glob_constr_and_expr,
-     glob_constr_and_expr * constr_pattern,
-     evaluable_global_reference and_short_name or_var,
-     inductive or_var,
-     ltac_constant located or_var,
-     identifier located,
-     glob_tactic_expr,
-     glevel) gen_atomic_tactic_expr
-
-type glob_tactic_arg =
-    (glob_constr_and_expr,
-     glob_constr_and_expr * constr_pattern,
-     evaluable_global_reference and_short_name or_var,
-     inductive or_var,
-     ltac_constant located or_var,
-     identifier located,
-     glob_tactic_expr,
-     glevel) gen_tactic_arg
-
-type glob_generic_argument = glevel generic_argument
-
-type glob_red_expr =
-    (glob_constr_and_expr, evaluable_global_reference or_var, constr_pattern)
-    red_expr_gen
-
-type typed_generic_argument = tlevel generic_argument
-
-type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type
-
-type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type
-
-type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type
-
-type declaration_hook = locality -> global_reference -> unit
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 8346e4c2..fa0d0362 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -1,17 +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 Pp
 open Util
-open Names
 open Namegen
-open Sign
-open Term
 open Termops
 open Environ
 open Reductionops
@@ -22,9 +18,8 @@ open Tacred
 open Proof_type
 open Logic
 open Refiner
-open Tacexpr
 
-let re_sig it gc = { it = it; sigma = gc }
+let re_sig it  gc = { it = it; sigma = gc; }
 
 (**************************************************************)
 (* Operations for handling terms under a local typing context *)
@@ -53,9 +48,9 @@ let pf_last_hyp gl = List.hd (pf_hyps gl)
 
 let pf_get_hyp gls id =
   try
-    Sign.lookup_named id (pf_hyps gls)
+    Context.lookup_named id (pf_hyps gls)
   with Not_found ->
-    error ("No such hypothesis: " ^ (string_of_id id))
+    raise (RefinerError (NoSuchHyp id))
 
 let pf_get_hyp_typ gls id =
   let (_,_,ty)= (pf_get_hyp gls id) in
@@ -74,18 +69,17 @@ let pf_get_new_ids ids gls =
 
 let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
 
-let pf_parse_const gls = compose (pf_global gls) id_of_string
-
 let pf_reduction_of_red_expr gls re c =
-  (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c
+  (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c
 
 let pf_apply f gls = f (pf_env gls) (project gls)
+let pf_eapply f gls x = 
+  on_sig gls (fun evm -> f (pf_env gls) evm x)
 let pf_reduce = pf_apply
+let pf_e_reduce = pf_apply
 
 let pf_whd_betadeltaiota         = pf_reduce whd_betadeltaiota
-let pf_whd_betadeltaiota_stack   = pf_reduce whd_betadeltaiota_stack
 let pf_hnf_constr                = pf_reduce hnf_constr
-let pf_red_product               = pf_reduce red_product
 let pf_nf                        = pf_reduce simpl
 let pf_nf_betaiota               = pf_reduce (fun _ -> nf_betaiota)
 let pf_compute                   = pf_reduce compute
@@ -93,38 +87,17 @@ let pf_unfoldn ubinds            = pf_reduce (unfoldn ubinds)
 let pf_type_of                   = pf_reduce type_of
 let pf_get_type_of               = pf_reduce Retyping.get_type_of
 
-let pf_conv_x                   = pf_reduce is_conv
-let pf_conv_x_leq               = pf_reduce is_conv_leq
-let pf_const_value              = pf_reduce (fun env _ -> constant_value env)
+let pf_conv_x gl                = pf_reduce test_conversion gl Reduction.CONV
+let pf_conv_x_leq gl            = pf_reduce test_conversion gl Reduction.CUMUL
+let pf_const_value              = pf_reduce (fun env _ -> constant_value_in env)
+
 let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind
 let pf_reduce_to_atomic_ind     = pf_reduce reduce_to_atomic_ind
 
 let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls)
 
-let pf_check_type gls c1 c2 =
-  ignore (pf_type_of gls (mkCast (c1, DEFAULTcast, c2)))
-
-let pf_is_matching              = pf_apply Matching.is_matching_conv
-let pf_matches                  = pf_apply Matching.matches_conv
-
-(************************************)
-(* Tactics handling a list of goals *)
-(************************************)
-
-type transformation_tactic = proof_tree -> goal list 
-
-type validation_list = proof_tree list -> proof_tree list
-
-type tactic_list = Refiner.tactic_list 
-
-let first_goal         = first_goal
-let goal_goal_list     = goal_goal_list
-let apply_tac_list     = apply_tac_list
-let then_tactic_list   = then_tactic_list
-let tactic_list_tactic = tactic_list_tactic
-let tclFIRSTLIST       = tclFIRSTLIST
-let tclIDTAC_list      = tclIDTAC_list
-
+let pf_is_matching              = pf_apply Constr_matching.is_matching_conv
+let pf_matches                  = pf_apply Constr_matching.matches_conv
 
 (********************************************)
 (* Definition of the most primitive tactics *)
@@ -132,69 +105,39 @@ let tclIDTAC_list      = tclIDTAC_list
 
 let refiner = refiner
 
-(* This does not check that the variable name is not here *)
-let introduction_no_check id =
-  refiner (Prim (Intro id))
-
 let internal_cut_no_check replace id t gl =
-  refiner (Prim (Cut (true,replace,id,t))) gl
+  refiner (Cut (true,replace,id,t)) gl
 
 let internal_cut_rev_no_check replace id t gl =
-  refiner (Prim (Cut (false,replace,id,t))) gl
+  refiner (Cut (false,replace,id,t)) gl
 
 let refine_no_check c gl =
-  refiner (Prim (Refine c)) gl
-
-let convert_concl_no_check c sty gl =
-  refiner (Prim (Convert_concl (c,sty))) gl
-
-let convert_hyp_no_check d gl =
-  refiner (Prim (Convert_hyp d)) gl
+  refiner (Refine c) gl
 
 (* This does not check dependencies *)
 let thin_no_check ids gl =
-  if ids = [] then tclIDTAC gl else refiner (Prim (Thin ids)) gl
-
-(* This does not check dependencies *)
-let thin_body_no_check ids gl =
-  if ids = [] then tclIDTAC gl else refiner (Prim (ThinBody ids)) gl
+  if List.is_empty ids then tclIDTAC gl else refiner (Thin ids) gl
 
-let move_hyp_no_check with_dep id1 id2 gl =
-  refiner (Prim (Move (with_dep,id1,id2))) gl
-
-let order_hyps idl gl =
-  refiner (Prim (Order idl)) gl
-
-let rec rename_hyp_no_check l gl = match l with
-  | [] -> tclIDTAC gl
-  | (id1,id2)::l ->
-      tclTHEN (refiner (Prim (Rename (id1,id2))))
-	(rename_hyp_no_check l) gl
+let move_hyp_no_check id1 id2 gl =
+  refiner (Move (id1,id2)) gl
 
 let mutual_fix f n others j gl =
-  with_check (refiner (Prim (FixRule (f,n,others,j)))) gl
+  with_check (refiner (FixRule (f,n,others,j))) gl
 
 let mutual_cofix f others j gl =
-  with_check (refiner (Prim (Cofix (f,others,j)))) gl
+  with_check (refiner (Cofix (f,others,j))) gl
 
 (* Versions with consistency checks *)
 
-let introduction id    = with_check (introduction_no_check id)
 let internal_cut b d t = with_check (internal_cut_no_check b d t)
 let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t)
 let refine c           = with_check (refine_no_check c)
-let convert_concl d sty = with_check (convert_concl_no_check d sty)
-let convert_hyp d      = with_check (convert_hyp_no_check d)
 let thin c             = with_check (thin_no_check c)
-let thin_body c        = with_check (thin_body_no_check c)
-let move_hyp b id id'  = with_check (move_hyp_no_check b id id')
-let rename_hyp l       = with_check (rename_hyp_no_check l)
+let move_hyp id id'  = with_check (move_hyp_no_check id id')
 
 (* Pretty-printers *)
 
 open Pp
-open Tacexpr
-open Glob_term
 
 let db_pr_goal sigma g =
   let env = Goal.V82.env sigma g in
@@ -209,5 +152,85 @@ let pr_gls gls =
 
 let pr_glls glls =
   hov 0 (pr_evar_map (Some 2) (sig_sig glls) ++ fnl () ++
-         prlist_with_sep pr_fnl (db_pr_goal (project glls)) (sig_it glls))
+         prlist_with_sep fnl (db_pr_goal (project glls)) (sig_it glls))
+
+(* Variants of [Tacmach] functions built with the new proof engine *)
+module New = struct
+
+  let pf_apply f gl =
+    f (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+
+  let of_old f gl =
+    f { Evd.it = Proofview.Goal.goal gl ; sigma = Proofview.Goal.sigma gl }
+
+  let pf_global id gl =
+    (** We only check for the existence of an [id] in [hyps] *)
+    let gl = Proofview.Goal.assume gl in
+    let hyps = Proofview.Goal.hyps gl in
+    Constrintern.construct_reference hyps id
+
+  let pf_env = Proofview.Goal.env
+  let pf_concl = Proofview.Goal.concl
+
+  let pf_type_of gl t =
+    pf_apply type_of gl t
+
+  let pf_conv_x gl t1 t2 = pf_apply is_conv gl t1 t2
+
+  let pf_ids_of_hyps gl =
+    (** We only get the identifiers in [hyps] *)
+    let gl = Proofview.Goal.assume gl in
+    let hyps = Proofview.Goal.hyps gl in
+    ids_of_named_context hyps
+
+  let pf_get_new_id id gl =
+    let ids = pf_ids_of_hyps gl in
+    next_ident_away id ids
+
+  let pf_get_hyp id gl =
+    let hyps = Proofview.Goal.hyps gl in
+    let sign =
+      try Context.lookup_named id hyps
+      with Not_found -> raise (RefinerError (NoSuchHyp id))
+    in
+    sign
+
+  let pf_get_hyp_typ id gl =
+    let (_,_,ty) = pf_get_hyp id gl in
+    ty
+
+  let pf_hyps_types gl =
+    let env = Proofview.Goal.env gl in
+    let sign = Environ.named_context env in
+    List.map (fun (id,_,x) -> (id, x)) sign
+
+  let pf_last_hyp gl =
+    let hyps = Proofview.Goal.hyps gl in
+    List.hd hyps
+
+  let pf_nf_concl (gl : [ `LZ ] Proofview.Goal.t) =
+    (** We normalize the conclusion just after *)
+    let gl = Proofview.Goal.assume gl in
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    nf_evar sigma concl
+
+  let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+
+  let pf_get_type_of gl t = pf_apply Retyping.get_type_of gl t
+
+  let pf_reduce_to_quantified_ind gl t =
+    pf_apply reduce_to_quantified_ind gl t
+
+  let pf_hnf_constr gl t = pf_apply hnf_constr gl t
+  let pf_hnf_type_of gl t =
+    pf_whd_betadeltaiota gl (pf_get_type_of gl t)
+
+  let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t
+
+  let pf_whd_betadeltaiota gl t = pf_apply whd_betadeltaiota gl t
+  let pf_compute gl t = pf_apply compute gl t
+
+  let pf_nf_evar gl t = nf_evar (Proofview.Goal.sigma gl) t
 
+end
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 39ecbd3b..f7fc6b54 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.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,16 +8,14 @@
 
 open Names
 open Term
-open Sign
+open Context
 open Environ
 open Evd
-open Reduction
 open Proof_type
-open Refiner
 open Redexpr
-open Tacexpr
-open Glob_term
 open Pattern
+open Locus
+open Misctypes
 
 (** Operations for handling terms under a local typing context. *)
 
@@ -32,49 +30,50 @@ val re_sig : 'a -> evar_map -> 'a sigma
 val unpackage : 'a sigma -> evar_map ref * 'a
 val repackage : evar_map ref -> 'a -> 'a sigma
 val apply_sig_tac :
-  evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) 
+  evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list)
 
 val pf_concl              : goal sigma -> types
 val pf_env                : goal sigma -> env
 val pf_hyps               : goal sigma -> named_context
-(*i val pf_untyped_hyps       : goal sigma -> (identifier * constr) list i*)
-val pf_hyps_types         : goal sigma -> (identifier * types) list
-val pf_nth_hyp_id         : goal sigma -> int -> identifier
+(*i val pf_untyped_hyps       : goal sigma -> (Id.t * constr) list i*)
+val pf_hyps_types         : goal sigma -> (Id.t * types) list
+val pf_nth_hyp_id         : goal sigma -> int -> Id.t
 val pf_last_hyp           : goal sigma -> named_declaration
-val pf_ids_of_hyps        : goal sigma -> identifier list
-val pf_global             : goal sigma -> identifier -> constr
-val pf_parse_const        : goal sigma -> string -> constr
+val pf_ids_of_hyps        : goal sigma -> Id.t list
+val pf_global             : goal sigma -> Id.t -> constr
 val pf_type_of            : goal sigma -> constr -> types
-val pf_check_type         : goal sigma -> constr -> types -> unit
 val pf_hnf_type_of        : goal sigma -> constr -> types
 
-val pf_get_hyp            : goal sigma -> identifier -> named_declaration
-val pf_get_hyp_typ        : goal sigma -> identifier -> types
+val pf_get_hyp            : goal sigma -> Id.t -> named_declaration
+val pf_get_hyp_typ        : goal sigma -> Id.t -> types
 
-val pf_get_new_id  : identifier      -> goal sigma -> identifier
-val pf_get_new_ids : identifier list -> goal sigma -> identifier list
+val pf_get_new_id  : Id.t      -> goal sigma -> Id.t
+val pf_get_new_ids : Id.t list -> goal sigma -> Id.t list
 
-val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr
+val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> evar_map * constr
 
 
 val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a
+val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> 
+  goal sigma -> 'a -> goal sigma * 'b
 val pf_reduce :
   (env -> evar_map -> constr -> constr) ->
-    goal sigma -> constr -> constr
+  goal sigma -> constr -> constr
+val pf_e_reduce :
+  (env -> evar_map -> constr -> evar_map * constr) ->
+  goal sigma -> constr -> evar_map * constr
 
 val pf_whd_betadeltaiota       : goal sigma -> constr -> constr
-val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list
 val pf_hnf_constr              : goal sigma -> constr -> constr
-val pf_red_product             : goal sigma -> constr -> constr
 val pf_nf                      : goal sigma -> constr -> constr
 val pf_nf_betaiota             : goal sigma -> constr -> constr
-val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types
-val pf_reduce_to_atomic_ind     : goal sigma -> types -> inductive * types
+val pf_reduce_to_quantified_ind : goal sigma -> types -> pinductive * types
+val pf_reduce_to_atomic_ind     : goal sigma -> types -> pinductive * types
 val pf_compute                 : goal sigma -> constr -> constr
-val pf_unfoldn    : (Termops.occurrences * evaluable_global_reference) list
-        -> goal sigma -> constr -> constr
+val pf_unfoldn    : (occurrences * evaluable_global_reference) list
+  -> goal sigma -> constr -> constr
 
-val pf_const_value : goal sigma -> constant -> constr
+val pf_const_value : goal sigma -> pconstant -> constr
 val pf_conv_x      : goal sigma -> constr -> constr -> bool
 val pf_conv_x_leq  : goal sigma -> constr -> constr -> bool
 
@@ -85,49 +84,56 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
 (** {6 The most primitive tactics. } *)
 
 val refiner                   : rule -> tactic
-val introduction_no_check     : identifier -> tactic
-val internal_cut_no_check     : bool -> identifier -> types -> tactic
-val internal_cut_rev_no_check : bool -> identifier -> types -> tactic
+val internal_cut_no_check     : bool -> Id.t -> types -> tactic
 val refine_no_check           : constr -> tactic
-val convert_concl_no_check    : types -> cast_kind -> tactic
-val convert_hyp_no_check      : named_declaration -> tactic
-val thin_no_check             : identifier list -> tactic
-val thin_body_no_check        : identifier list -> tactic
-val move_hyp_no_check         :
-  bool -> identifier -> identifier move_location -> tactic
-val rename_hyp_no_check       : (identifier*identifier) list -> tactic
-val order_hyps : identifier list -> tactic
+val thin_no_check             : Id.t list -> tactic
 val mutual_fix      :
-  identifier -> int -> (identifier * int * constr) list -> int -> tactic
-val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
+  Id.t -> int -> (Id.t * int * constr) list -> int -> tactic
+val mutual_cofix    : Id.t -> (Id.t * constr) list -> int -> tactic
 
 (** {6 The most primitive tactics with consistency and type checking } *)
 
-val introduction     : identifier -> tactic
-val internal_cut     : bool -> identifier -> types -> tactic
-val internal_cut_rev : bool -> identifier -> types -> tactic
+val internal_cut     : bool -> Id.t -> types -> tactic
+val internal_cut_rev : bool -> Id.t -> types -> tactic
 val refine           : constr -> tactic
-val convert_concl    : types -> cast_kind -> tactic
-val convert_hyp      : named_declaration -> tactic
-val thin             : identifier list -> tactic
-val thin_body        : identifier list -> tactic
-val move_hyp         : bool -> identifier -> identifier move_location -> tactic
-val rename_hyp       : (identifier*identifier) list -> tactic
+val thin             : Id.t list -> tactic
+val move_hyp         : Id.t -> Id.t move_location -> tactic
 
-(** {6 Tactics handling a list of goals. } *)
+(** {6 Pretty-printing functions (debug only). } *)
+val pr_gls    : goal sigma -> Pp.std_ppcmds
+val pr_glls   : goal list sigma -> Pp.std_ppcmds
 
-type validation_list = proof_tree list -> proof_tree list
+(* Variants of [Tacmach] functions built with the new proof engine *)
+module New : sig
+  val pf_apply : (env -> evar_map -> 'a) -> 'b Proofview.Goal.t -> 'a
+  val pf_global : identifier -> 'a Proofview.Goal.t -> constr
+  val of_old : (Proof_type.goal Evd.sigma -> 'a) -> [ `NF ] Proofview.Goal.t -> 'a
 
-type tactic_list = Refiner.tactic_list
+  val pf_env : 'a Proofview.Goal.t -> Environ.env
+  val pf_concl : [ `NF ] Proofview.Goal.t -> types
 
-val first_goal         : 'a list sigma -> 'a sigma
-val goal_goal_list     : 'a sigma -> 'a list sigma
-val apply_tac_list     : tactic -> tactic_list
-val then_tactic_list   : tactic_list -> tactic_list -> tactic_list
-val tactic_list_tactic : tactic_list -> tactic
-val tclFIRSTLIST       : tactic_list list -> tactic_list
-val tclIDTAC_list      : tactic_list
+  val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types
+  val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool
 
-(** {6 Pretty-printing functions (debug only). } *)
-val pr_gls    : goal sigma -> Pp.std_ppcmds
-val pr_glls   : goal list sigma -> Pp.std_ppcmds
+  val pf_get_new_id  : identifier -> [ `NF ] Proofview.Goal.t -> identifier
+  val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list
+  val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list
+
+  val pf_get_hyp : identifier -> [ `NF ] Proofview.Goal.t -> named_declaration
+  val pf_get_hyp_typ        : identifier -> [ `NF ] Proofview.Goal.t -> types
+  val pf_last_hyp           : [ `NF ] Proofview.Goal.t -> named_declaration
+
+  val pf_nf_concl : [ `LZ ] Proofview.Goal.t -> types
+  val pf_reduce_to_quantified_ind : 'a Proofview.Goal.t -> types -> pinductive * types
+
+  val pf_hnf_constr : 'a Proofview.Goal.t -> constr -> types
+  val pf_hnf_type_of : 'a Proofview.Goal.t -> constr -> types
+
+  val pf_whd_betadeltaiota : 'a Proofview.Goal.t -> constr -> constr
+  val pf_compute : 'a Proofview.Goal.t -> constr -> constr
+
+  val pf_matches : 'a Proofview.Goal.t -> constr_pattern -> constr -> patvar_map
+
+  val pf_nf_evar : 'a Proofview.Goal.t -> constr -> constr
+
+end
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index a7df80f6..3cc81daf 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -1,23 +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 Util
 open Names
-open Constrextern
 open Pp
 open Tacexpr
 open Termops
 
-let prtac = ref (fun _ -> assert false)
-let set_tactic_printer f = prtac := f
-let prmatchpatt = ref (fun _ _ -> assert false)
-let set_match_pattern_printer f = prmatchpatt := f
-let prmatchrl = ref (fun _ -> assert false)
-let set_match_rule_printer f = prmatchrl := f
+let (prtac, tactic_printer) = Hook.make ()
+let (prmatchpatt, match_pattern_printer) = Hook.make ()
+let (prmatchrl, match_rule_printer) = Hook.make ()
+
 
 (* This module intends to be a beginning of debugger for tactic expressions.
    Currently, it is quite simple and we can hope to have, in the future, a more
@@ -33,23 +31,29 @@ let explain_logic_error = ref (fun e -> mt())
 
 let explain_logic_error_no_anomaly = ref (fun e -> mt())
 
+let msg_tac_debug s = Proofview.NonLogical.print (s++fnl())
+
 (* Prints the goal *)
 
-let db_pr_goal g =
-  let env = Refiner.pf_env g in
+let db_pr_goal gl =
+  let env = Proofview.Goal.env gl in
+  let concl = Proofview.Goal.concl gl in
   let penv = print_named_context env in
-  let pc = print_constr_env env (Goal.V82.concl (Refiner.project g) (Refiner.sig_it g)) in
-  str"  " ++ hv 0 (penv ++ fnl () ++
+  let pc = print_constr_env env concl in
+    str"  " ++ hv 0 (penv ++ fnl () ++
                    str "============================" ++ fnl ()  ++
                    str" "  ++ pc) ++ fnl ()
 
-let db_pr_goal g =
-  msgnl (str "Goal:" ++ fnl () ++ db_pr_goal g)
+let db_pr_goal =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let pg = db_pr_goal gl in
+  Proofview.tclLIFT (msg_tac_debug (str "Goal:" ++ fnl () ++ pg))
+  end
 
 
 (* Prints the commands *)
 let help () =
-  msgnl (str "Commands: <Enter> = Continue" ++ fnl() ++
+  msg_tac_debug (str "Commands: <Enter> = Continue" ++ fnl() ++
          str "          h/? = Help" ++ fnl() ++
          str "          r <num> = Run <num> times" ++ fnl() ++
          str "          r <string> = Run up to next idtac <string>" ++ fnl() ++
@@ -57,168 +61,257 @@ let help () =
          str "          x = Exit")
 
 (* Prints the goal and the command to be executed *)
-let goal_com g tac =
-  begin
-    db_pr_goal g;
-    msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ())
-  end
-
-let skipped = ref 0
-let skip = ref 0
-let breakpoint = ref None
+let goal_com tac =
+  Proofview.tclTHEN
+    db_pr_goal
+    (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac)))
+
+(* [run (new_ref _)] gives us a ref shared among [NonLogical.t]
+   expressions. It avoids parametrizing everything over a
+   reference. *)
+let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
+let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0)
+let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None)
 
 let rec drop_spaces inst i =
-  if String.length inst > i && inst.[i] = ' ' then drop_spaces inst (i+1)
+  if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1)
   else i
 
 let possibly_unquote s =
-  if String.length s >= 2 & s.[0] = '"' & s.[String.length s - 1] = '"' then
+  if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then
     String.sub s 1 (String.length s - 2)
   else
     s
 
 (* (Re-)initialize debugger *)
-let db_initialize () =
-  skip:=0;skipped:=0;breakpoint:=None
+let db_initialize =
+  let open Proofview.NonLogical in
+  (skip:=0) >> (skipped:=0) >> (breakpoint:=None)
+
+let int_of_string s =
+  try Proofview.NonLogical.return (int_of_string s)
+  with e -> Proofview.NonLogical.raise e
+
+let string_get s i =
+  try Proofview.NonLogical.return (String.get s i)
+  with e -> Proofview.NonLogical.raise e
 
 (* Gives the number of steps or next breakpoint of a run command *)
 let run_com inst =
-  if (String.get inst 0)='r' then
+  let open Proofview.NonLogical in
+  string_get inst 0 >>= fun first_char ->
+  if first_char ='r' then
     let i = drop_spaces inst 1 in
     if String.length inst > i then
       let s = String.sub inst i (String.length inst - i) in
       if inst.[0] >= '0' && inst.[0] <= '9' then
-        let num = int_of_string s in
-        if num<0 then raise (Invalid_argument "run_com");
-        skip:=num;skipped:=0
+        int_of_string s >>= fun num ->
+        (if num<0 then invalid_arg "run_com" else return ()) >>
+        (skip:=num) >> (skipped:=0)
       else
         breakpoint:=Some (possibly_unquote s)
     else
-      raise (Invalid_argument "run_com")
+      invalid_arg "run_com"
   else
-    raise (Invalid_argument "run_com")
+    invalid_arg "run_com"
 
 (* Prints the run counter *)
 let run ini =
+  let open Proofview.NonLogical in
   if not ini then
-  begin
-    for i=1 to 2 do
-      print_char (Char.chr 8);print_char (Char.chr 13)
-    done;
-    msg (str "Executed expressions: " ++ int !skipped ++ fnl() ++ fnl())
-  end;
-  incr skipped
+    begin
+      Proofview.NonLogical.print (str"\b\r\b\r") >>
+      !skipped >>= fun skipped ->
+      msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl())
+    end >>
+    !skipped >>= fun x ->
+    skipped := x+1
+  else
+    return ()
 
 (* Prints the prompt *)
 let rec prompt level =
+  (* spiwack: avoid overriding by the open below *)
+  let runtrue = run true in
   begin
-    msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ");
-    flush stdout;
-    let exit () = skip:=0;skipped:=0;raise Sys.Break in
-    let inst = try read_line () with End_of_file -> exit () in
+    let open Proofview.NonLogical in
+    Proofview.NonLogical.print (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >>
+    let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in
+    Proofview.NonLogical.catch Proofview.NonLogical.read_line
+      begin function (e, info) -> match e with
+        | End_of_file -> exit
+        | e -> raise ~info e
+      end
+    >>= fun inst ->
     match inst with
-    | ""  -> DebugOn (level+1)
-    | "s" -> DebugOff
-    | "x" -> print_char (Char.chr 8); exit ()
+    | ""  -> return (DebugOn (level+1))
+    | "s" -> return (DebugOff)
+    | "x" -> Proofview.NonLogical.print_char '\b' >> exit
     | "h"| "?" ->
       begin
-        help ();
+        help () >>
         prompt level
       end
     | _ ->
-      (try run_com inst;run true;DebugOn (level+1)
-       with Failure _ | Invalid_argument _ -> prompt level)
+        Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1)))
+          begin function (e, info) -> match e with
+            | Failure _ | Invalid_argument _ -> prompt level
+            | e -> raise ~info e
+          end
   end
 
 (* Prints the state and waits for an instruction *)
-let debug_prompt lev g tac f =
+(* spiwack: the only reason why we need to take the continuation [f]
+   as an argument rather than returning the new level directly seems to
+   be that [f] is wrapped in with "explain_logic_error". I don't think
+   it serves any purpose in the current design, so we could just drop
+   that. *)
+let debug_prompt lev tac f =
+  (* spiwack: avoid overriding by the open below *)
+  let runfalse = run false in
+  let open Proofview.NonLogical in
+  let (>=) = Proofview.tclBIND in
   (* What to print and to do next *)
   let newlevel =
-    if !skip = 0 then
-      if !breakpoint = None then (goal_com g tac; prompt lev)
-      else (run false; DebugOn (lev+1))
-    else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in
+    Proofview.tclLIFT !skip >= fun initial_skip ->
+    if Int.equal initial_skip 0 then
+      Proofview.tclLIFT !breakpoint >= fun breakpoint ->
+      if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev))
+      else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1)))
+    else Proofview.tclLIFT begin
+      (!skip >>= fun s -> skip:=s-1) >>
+      runfalse >>
+      !skip >>= fun new_skip ->
+      (if Int.equal new_skip 0 then skipped:=0 else return ()) >>
+      return (DebugOn (lev+1))
+    end in
+  newlevel >= fun newlevel ->
   (* What to execute *)
-  try f newlevel
-  with reraise ->
-    skip:=0; skipped:=0;
-    if Logic.catchable_exception reraise then
-      ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error reraise);
-    raise reraise
+  Proofview.tclOR
+    (f newlevel)
+    begin fun (reraise, info) ->
+      Proofview.tclTHEN
+        (Proofview.tclLIFT begin
+          (skip:=0) >> (skipped:=0) >>
+            if Logic.catchable_exception reraise then
+              msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise)
+            else return ()
+        end)
+        (Proofview.tclZERO ~info reraise)
+    end
+
+let is_debug db =
+  let open Proofview.NonLogical in
+  !breakpoint >>= fun breakpoint ->
+  match db, breakpoint with
+  | DebugOff, _ -> return false
+  | _, Some _ -> return false
+  | _ ->
+      !skip >>= fun skip ->
+      return (Int.equal skip 0)
 
 (* Prints a constr *)
 let db_constr debug env c =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str "Evaluated term: " ++ print_constr_env env c)
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Evaluated term: " ++ print_constr_env env c)
+  else return ()
 
 (* Prints the pattern rule *)
 let db_pattern_rule debug num r =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
   begin
-    msgnl (str "Pattern rule " ++ int num ++ str ":");
-    msgnl (str "|" ++ spc () ++ !prmatchrl r)
+    msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++
+      str "|" ++ spc () ++ Hook.get prmatchrl r)
   end
+  else return ()
 
 (* Prints the hypothesis pattern identifier if it exists *)
 let hyp_bound = function
   | Anonymous -> " (unbound)"
-  | Name id -> " (bound to "^(Names.string_of_id id)^")"
+  | Name id -> " (bound to "^(Names.Id.to_string id)^")"
 
 (* Prints a matched hypothesis *)
 let db_matched_hyp debug env (id,_,c) ido =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str "Hypothesis " ++
-           str ((Names.string_of_id id)^(hyp_bound ido)^
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Hypothesis " ++
+           str ((Names.Id.to_string id)^(hyp_bound ido)^
                 " has been matched: ") ++ print_constr_env env c)
+  else return ()
 
 (* Prints the matched conclusion *)
 let db_matched_concl debug env c =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str "Conclusion has been matched: " ++ print_constr_env env c)
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env c)
+  else return ()
 
 (* Prints a success message when the goal has been matched *)
 let db_mc_pattern_success debug =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str "The goal has been successfully matched!" ++ fnl() ++
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++
            str "Let us execute the right-hand side part..." ++ fnl())
+  else return ()
 
 (* Prints a failure message for an hypothesis pattern *)
-let db_hyp_pattern_failure debug env (na,hyp) =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str ("The pattern hypothesis"^(hyp_bound na)^
+let db_hyp_pattern_failure debug env sigma (na,hyp) =
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str ("The pattern hypothesis"^(hyp_bound na)^
                 " cannot match: ") ++
-           !prmatchpatt env hyp)
+           Hook.get prmatchpatt env sigma hyp)
+  else return ()
 
 (* Prints a matching failure message for a rule *)
 let db_matching_failure debug =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
-    msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
+    msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++
            str "Let us try the next one...")
+  else return ()
 
 (* Prints an evaluation failure message for a rule *)
 let db_eval_failure debug s =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
     let s = str "message \"" ++ s ++ str "\"" in
-    msgnl
+    msg_tac_debug
       (str "This rule has failed due to \"Fail\" tactic (" ++
        s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...")
+  else return ()
 
 (* Prints a logic failure message for a rule *)
 let db_logic_failure debug err =
-  if debug <> DebugOff & !skip = 0 & !breakpoint = None then
+  let open Proofview.NonLogical in
+  is_debug debug >>= fun db ->
+  if db then
   begin
-    msgnl (!explain_logic_error err);
-    msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++
+    msg_tac_debug (Pervasives.(!) explain_logic_error err) >>
+    msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++
            str "Let us try the next one...")
   end
+  else return ()
 
 let is_breakpoint brkname s = match brkname, s with
-  | Some s, MsgString s'::_ -> s = s'
+  | Some s, MsgString s'::_ -> String.equal s s'
   | _ -> false
 
 let db_breakpoint debug s =
+  let open Proofview.NonLogical in
+  !breakpoint >>= fun opt_breakpoint ->
   match debug with
-  | DebugOn lev when s <> [] & is_breakpoint !breakpoint s ->
+  | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s ->
       breakpoint:=None
   | _ ->
-      ()
+      return ()
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index b4c05324..e4c0a23e 100644
--- a/proofs/tactic_debug.mli
+++ b/proofs/tactic_debug.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,22 +8,20 @@
 
 open Environ
 open Pattern
-open Evd
-open Proof_type
 open Names
 open Tacexpr
 open Term
+open Evd
 
 (** This module intends to be a beginning of debugger for tactic expressions.
    Currently, it is quite simple and we can hope to have, in the future, a more
    complete panel of commands dedicated to a proof assistant framework *)
 
-val set_tactic_printer : (glob_tactic_expr ->Pp.std_ppcmds) -> unit
-val set_match_pattern_printer :
-  (env -> constr_pattern match_pattern -> Pp.std_ppcmds) -> unit
-val set_match_rule_printer :
-  ((Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) ->
-    unit
+val tactic_printer : (glob_tactic_expr -> Pp.std_ppcmds) Hook.t
+val match_pattern_printer :
+  (env -> evar_map -> constr_pattern match_pattern -> Pp.std_ppcmds) Hook.t
+val match_rule_printer :
+  ((Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) Hook.t
 
 (** Debug information *)
 type debug_info =
@@ -32,37 +30,37 @@ type debug_info =
 
 (** Prints the state and waits *)
 val debug_prompt :
-  int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a
+  int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic
 
 (** Initializes debugger *)
-val db_initialize : unit -> unit
+val db_initialize : unit Proofview.NonLogical.t
 
 (** Prints a constr *)
-val db_constr : debug_info -> env -> constr -> unit
+val db_constr : debug_info -> env -> constr -> unit Proofview.NonLogical.t
 
 (** Prints the pattern rule *)
 val db_pattern_rule :
-  debug_info -> int -> (Genarg.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit
+  debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t
 
 (** Prints a matched hypothesis *)
 val db_matched_hyp :
-  debug_info -> env -> identifier * constr option * constr -> name -> unit
+  debug_info -> env -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t
 
 (** Prints the matched conclusion *)
-val db_matched_concl : debug_info -> env -> constr -> unit
+val db_matched_concl : debug_info -> env -> constr -> unit Proofview.NonLogical.t
 
 (** Prints a success message when the goal has been matched *)
-val db_mc_pattern_success : debug_info -> unit
+val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t
 
 (** Prints a failure message for an hypothesis pattern *)
 val db_hyp_pattern_failure :
-  debug_info -> env -> name * constr_pattern match_pattern -> unit
+  debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t
 
 (** Prints a matching failure message for a rule *)
-val db_matching_failure : debug_info -> unit
+val db_matching_failure : debug_info -> unit Proofview.NonLogical.t
 
 (** Prints an evaluation failure message for a rule *)
-val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit
+val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t
 
 (** An exception handler *)
 val explain_logic_error: (exn -> Pp.std_ppcmds) ref
@@ -74,8 +72,8 @@ val explain_logic_error: (exn -> Pp.std_ppcmds) ref
 val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref
 
 (** Prints a logic failure message for a rule *)
-val db_logic_failure : debug_info -> exn -> unit
+val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t
 
 (** Prints a logic failure message for a rule *)
 val db_breakpoint : debug_info ->
-  identifier Util.located message_token list -> unit
+  Id.t Loc.located message_token list -> unit Proofview.NonLogical.t
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
deleted file mode 100644
index eaecda5d..00000000
--- a/scripts/coqmktop.ml
+++ /dev/null
@@ -1,319 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* coqmktop is a script to link Coq, analogous to ocamlmktop.
-   The command line contains options specific to coqmktop, options for the
-   Ocaml linker and files to link (in addition to the default Coq files). *)
-
-open Unix
-
-(* In Win32 outside cygwin, Sys.command calls cmd.exe. When it executes
-   a command that may contains many double-quote, we should double-quote
-   the whole ! *)
-
-let safe_sys_command =
-  if Sys.os_type = "Win32" then
-    fun cmd -> Sys.command ("\""^cmd^"\"")
-  else Sys.command
-
-(* Objects to link *)
-
-(* 1. Core objects *)
-let ocamlobjs = ["str.cma";"unix.cma";"nums.cma"]
-let dynobjs = ["dynlink.cma"]
-let camlp4objs =
-  if Coq_config.camlp4 = "camlp5" then ["gramlib.cma"] else ["camlp4lib.cma"]
-let libobjs = ocamlobjs @ camlp4objs
-
-let spaces = Str.regexp "[ \t\n]+"
-let split_list l = Str.split spaces l
-
-let copts     = split_list Tolink.copts
-let core_objs = split_list Tolink.core_objs
-let core_libs = split_list Tolink.core_libs
-
-(* 3. Toplevel objects *)
-let camlp4topobjs =
-  if Coq_config.camlp4 = "camlp5" then
-    ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"]
-  else
-    [ "Camlp4Top.cmo";
-      "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo";
-      "Camlp4Parsers/Camlp4OCamlParser.cmo";
-      "Camlp4Parsers/Camlp4GrammarParser.cmo" ]
-let topobjs = camlp4topobjs
-
-let gramobjs = []
-let notopobjs = gramobjs
-
-(* 4. High-level tactics objects *)
-
-(* environment *)
-let opt        = ref false
-let full       = ref false
-let top        = ref false
-let echo       = ref false
-let no_start   = ref false
-
-let is_ocaml4 = Coq_config.caml_version.[0] <> '3'
-
-(* Since the .cma are given with their relative paths (e.g. "lib/clib.cma"),
-   we only need to include directories mentionned in the temp main ml file
-   below (for accessing the corresponding .cmi). *)
-
-let src_dirs =
-  [ []; ["lib"]; ["toplevel"]; ["kernel";"byterun"]; ]
-
-let includes () =
-  let coqlib = if !Flags.boot then "." else Envars.coqlib () in
-  let mkdir d = "\"" ^ List.fold_left Filename.concat coqlib d ^ "\"" in
-  (List.fold_right (fun d l -> "-I" :: mkdir d :: l) src_dirs [])
-  @ ["-I"; "\"" ^ Envars.camlp4lib () ^ "\""]
-  @ (if is_ocaml4 then ["-I"; "+compiler-libs"] else [])
-
-(* Transform bytecode object file names in native object file names *)
-let native_suffix f =
-  if Filename.check_suffix f ".cmo" then
-    (Filename.chop_suffix f ".cmo") ^ ".cmx"
-  else if Filename.check_suffix f ".cma" then
-    (Filename.chop_suffix f ".cma") ^ ".cmxa"
-  else
-    if Filename.check_suffix f ".a" then f
-    else
-      failwith ("File "^f^" has not extension .cmo, .cma or .a")
-
-(* Transforms a file name in the corresponding Caml module name. *)
-let rem_ext_regexpr = Str.regexp "\\(.*\\)\\.\\(cm..?\\|ml\\)"
-
-let module_of_file name =
-  let s = Str.replace_first rem_ext_regexpr "\\1" (Filename.basename name) in
-  String.capitalize s
-
-(* Build the list of files to link and the list of modules names *)
-let files_to_link userfiles =
-  let dyn_objs =
-    if not !opt || Coq_config.has_natdynlink then dynobjs else [] in
-  let toplevel_objs =
-    if !top then topobjs else if !opt then notopobjs else [] in
-  let objs = dyn_objs @ libobjs @ core_objs @ toplevel_objs in
-  let modules = List.map module_of_file (objs @ userfiles)
-  in
-  let libs = dyn_objs @ libobjs @ core_libs @ toplevel_objs in
-  let libstolink =
-    (if !opt then List.map native_suffix libs else libs) @ userfiles
-  in
-  (modules, libstolink)
-
-(* Gives the list of all the directories under [dir].
-   Uses [Unix] (it is hard to do without it). *)
-let all_subdirs dir =
-  let l = ref [dir] in
-  let add f = l := f :: !l in
-  let rec traverse dir =
-    let dirh =
-      try opendir dir with Unix_error _ -> invalid_arg "all_subdirs"
-    in
-    try
-      while true do
-	let f = readdir dirh in
-	if f <> "." && f <> ".." then
-	  let file = Filename.concat dir f in
-	  if (stat file).st_kind = S_DIR then begin
-	    add file;
-	    traverse file
-	  end
-      done
-    with End_of_file ->
-      closedir dirh
-  in
-  traverse dir; List.rev !l
-
-(* usage *)
-let usage () =
-  prerr_endline "Usage: coqmktop <options> <ocaml options> files\
-\nFlags are:\
-\n  -coqlib dir    Specify where the Coq object files are\
-\n  -camlbin dir   Specify where the OCaml binaries are\
-\n  -camlp4bin dir Specify where the Camlp4/5 binaries are\
-\n  -o exec-file   Specify the name of the resulting toplevel\
-\n  -boot          Run in boot mode\
-\n  -echo          Print calls to external commands\
-\n  -full          Link high level tactics\
-\n  -opt           Compile in native code\
-\n  -top           Build Coq on a OCaml toplevel (incompatible with -opt)\
-\n  -R dir         Add recursively dir to OCaml search path\
-\n";
-  exit 1
-
-(* parsing of the command line *)
-let parse_args () =
-  let rec parse (op,fl) = function
-    | [] -> List.rev op, List.rev fl
-    | "-coqlib" :: d :: rem ->
-	Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem
-    | "-coqlib" :: _        -> usage ()
-    | "-camlbin" :: d :: rem ->
-	Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem
-    | "-camlbin" :: _        -> usage ()
-    | "-camlp4bin" :: d :: rem ->
-	Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem
-    | "-camlp4bin" :: _        -> usage ()
-    | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem
-    | "-opt" :: rem -> opt := true ; parse (op,fl) rem
-    | "-full" :: rem -> full := true ; parse (op,fl) rem
-    | "-top" :: rem -> top := true ; parse (op,fl) rem
-    | "-v8" :: rem ->
-	Printf.eprintf "warning: option -v8 deprecated";
-	parse (op,fl) rem
-    | "-echo" :: rem -> echo := true ; parse (op,fl) rem
-    | ("-cclib"|"-ccopt"|"-I"|"-o"|"-w" as o) :: rem' ->
-	begin
-	  match rem' with
-	    | a :: rem -> parse (a::o::op,fl) rem
-	    | []       -> usage ()
-	end
-    | "-R" :: a :: rem ->
-        parse ((List.rev(List.flatten (List.map (fun d -> ["-I";d])
-					 (all_subdirs a))))@op,fl) rem
-    | "-R" :: [] -> usage ()
-    | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem ->
-        parse (o::op,fl) rem
-    | ("-h"|"--help") :: _ -> usage ()
-    | ("-no-start") :: rem -> no_start:=true; parse (op, fl) rem
-    | f :: rem ->
-	if Filename.check_suffix f ".ml"
-	  or Filename.check_suffix f ".cmx"
-	  or Filename.check_suffix f ".cmo"
-	  or Filename.check_suffix f ".cmxa"
-	  or Filename.check_suffix f ".cma"
-	  or Filename.check_suffix f ".c" then
-	    parse (op,f::fl) rem
-	else begin
-	  prerr_endline ("Don't know what to do with " ^ f);
-	  exit 1
-	end
-  in
-  parse ([Coq_config.osdeplibs],[]) (List.tl (Array.to_list Sys.argv))
-
-let clean file =
-  let rm f = if Sys.file_exists f then Sys.remove f in
-  let basename = Filename.chop_suffix file ".ml" in
-  if not !echo then begin
-    rm file;
-    rm (basename ^ ".o");
-    rm (basename ^ ".cmi");
-    rm (basename ^ ".cmo");
-    rm (basename ^ ".cmx")
-  end
-
-(* Creates another temporary file for Dynlink if needed *)
-let tmp_dynlink()=
-  let tmp = Filename.temp_file "coqdynlink" ".ml" in
-  let _ = Sys.command ("echo \"Dynlink.init();;\" > "^tmp) in
-  tmp
-
-(* Initializes the kind of loading in the main program *)
-let declare_loading_string () =
-  if not !top then
-    "Mltop.remove ();;"
-  else
-    "begin try\
-\n       (* Enable rectypes in the toplevel if it has the directive #rectypes *)\
-\n       begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\
-\n         | Toploop.Directive_none f -> f ()\
-\n         | _ -> ()\
-\n       end\
-\n     with\
-\n       | Not_found -> ()\
-\n     end;;\
-\n\
-\n     let ppf = Format.std_formatter;;\
-\n     Mltop.set_top\
-\n       {Mltop.load_obj=\
-\n         (fun f -> if not (Topdirs.load_file ppf f) then Util.error (\"Could not load plugin \"^f));\
-\n        Mltop.use_file=Topdirs.dir_use ppf;\
-\n        Mltop.add_dir=Topdirs.dir_directory;\
-\n        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\
-\n"
-
-(* create a temporary main file to link *)
-let create_tmp_main_file modules =
-  let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in
-  try
-    (* Add the pre-linked modules *)
-    output_string oc "List.iter Mltop.add_known_module [\"";
-    output_string oc (String.concat "\";\"" modules);
-    output_string oc "\"];;\n";
-    (* Initializes the kind of loading *)
-    output_string oc (declare_loading_string());
-    (* Start the toplevel loop *)
-    if not !no_start then
-    output_string oc "Coqtop.start();;\n";
-    close_out oc;
-    main_name
-  with reraise ->
-    clean main_name; raise reraise
-
-(* main part *)
-let main () =
-  let (options, userfiles) = parse_args () in
-  (* which ocaml command to invoke *)
-  let camlbin = Envars.camlbin () in
-  let prog =
-    if !opt then begin
-      (* native code *)
-      if !top then failwith "no custom toplevel in native code !";
-      let ocamloptexec = Filename.quote (Filename.concat camlbin "ocamlopt") in
-        ocamloptexec^" -linkall"
-    end else
-      (* bytecode (we shunt ocamlmktop script which fails on win32) *)
-      let ocamlmktoplib = if is_ocaml4
-	then " ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma"
-	else " toplevellib.cma" in
-      let ocamlcexec = Filename.quote (Filename.concat camlbin "ocamlc") in
-      let ocamlccustom = Printf.sprintf "%s %s -linkall "
-        ocamlcexec Coq_config.coqrunbyteflags in
-      (if !top then ocamlccustom^ocamlmktoplib else ocamlccustom)
-  in
-  (* files to link *)
-  let (modules, tolink) = files_to_link userfiles in
-  (*file for dynlink *)
-  let dynlink=
-    if not (!opt || !top) then
-      [tmp_dynlink()]
-    else
-      []
-  in
-  (* the list of the loaded modules *)
-  let main_file = create_tmp_main_file modules in
-  try
-    let args = options @ includes () @ copts @ tolink @ dynlink in
-    let args = args @ [ Filename.quote main_file ] in
-      (* add topstart.cmo explicitly because we shunted ocamlmktop wrapper *)
-    let args = if !top then args @ [ "topstart.cmo" ] else args in
-      (* Now, with the .cma, we MUST use the -linkall option *)
-    let command = String.concat " " (prog::"-rectypes"::args) in
-      if !echo then
-	begin
-	  print_endline command;
-	  print_endline
-	    ("(command length is " ^
-	       (string_of_int (String.length command)) ^ " characters)");
-	  flush Pervasives.stdout
-	end;
-      let retcode = safe_sys_command command in
-	clean main_file;
-	(* command gives the exit code in HSB, and signal in LSB !!! *)
-	if retcode > 255 then retcode lsr 8 else retcode
-  with reraise ->
-    clean main_file; raise reraise
-
-let retcode =
-  try Printexc.print main () with any -> 1
-
-let _ = exit retcode
diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml
new file mode 100644
index 00000000..672527d9
--- /dev/null
+++ b/stm/asyncTaskQueue.ml
@@ -0,0 +1,344 @@
+(************************************************************************)
+(*  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 Errors
+open Pp
+open Util
+
+let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
+
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+type 'a worker_status = [ `Fresh | `Old of 'a ]
+
+module type Task = sig
+
+  type task
+  type competence
+
+  (* Marshallable *)
+  type request
+  type response
+
+  val name : string ref (* UID of the task kind, for -toploop *)
+  val extra_env : unit -> string array
+
+  (* run by the master, on a thread *)
+  val request_of_task : competence worker_status -> task -> request option
+  val task_match : competence worker_status -> task -> bool
+  val use_response :
+    competence worker_status -> task -> response ->
+      [ `Stay of competence * task list | `End ]
+  val on_marshal_error : string -> task -> unit
+  val on_task_cancellation_or_expiration_or_slave_death : task option -> unit
+  val forward_feedback : Feedback.feedback -> unit
+ 
+  (* run by the worker *)
+  val perform : request -> response
+
+  (* debugging *)
+  val name_of_task : task -> string
+  val name_of_request : request -> string
+
+end
+
+type expiration = bool ref
+
+module Make(T : Task) = struct
+
+  exception Die
+  type response =
+    | Response of T.response
+    | RespFeedback of Feedback.feedback
+    | RespGetCounterNewUnivLevel
+  type request = Request of T.request
+
+  type more_data =
+    | MoreDataUnivLevel of Univ.universe_level list
+ 
+  let request_expiry_of_task (t, c) = T.request_of_task t, c
+  
+  let slave_respond (Request r) =
+    let res = T.perform r in
+    Response res
+
+  exception MarshalError of string
+  
+  let marshal_to_channel oc data =
+    Marshal.to_channel oc data [];
+    flush oc
+  
+  let marshal_err s = raise (MarshalError s)
+  
+  let marshal_request oc (req : request) =
+    try marshal_to_channel oc req
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("marshal_request: "^s)
+  
+  let unmarshal_request ic =
+    try (CThread.thread_friendly_input_value ic : request)
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("unmarshal_request: "^s)
+  
+  let marshal_response oc (res : response) =
+    try marshal_to_channel oc res
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("marshal_response: "^s)
+  
+  let unmarshal_response ic =
+    try (CThread.thread_friendly_input_value ic : response)
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("unmarshal_response: "^s)
+  
+  let marshal_more_data oc (res : more_data) =
+    try marshal_to_channel oc res
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("marshal_more_data: "^s)
+  
+  let unmarshal_more_data ic =
+    try (CThread.thread_friendly_input_value ic : more_data)
+    with Failure s | Invalid_argument s | Sys_error s ->
+      marshal_err ("unmarshal_more_data: "^s)
+
+  let report_status ?(id = !Flags.async_proofs_worker_id) s =
+    Pp.feedback ~state_id:Stateid.initial (Feedback.WorkerStatus(id, s))
+
+  module Worker = Spawn.Sync(struct end)
+
+  module Model = struct
+
+  type process = Worker.process
+  type extra = (T.task * expiration) TQueue.t
+
+  let spawn id =
+    let name = Printf.sprintf "%s:%d" !T.name id in
+    let proc, ic, oc =
+      let rec set_slave_opt = function
+        | [] -> !Flags.async_proofs_flags_for_workers @
+                ["-toploop"; !T.name^"top";
+                 "-worker-id"; name;
+                 "-async-proofs-worker-priority";
+                   Flags.string_of_priority !Flags.async_proofs_worker_priority]
+        | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl
+        | ("-async-proofs" |"-toploop" |"-vi2vo" |"-compile"
+          |"-load-vernac-source" |"-compile-verbose"
+          |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl ->
+          set_slave_opt tl
+        | x::tl -> x :: set_slave_opt tl in
+      let args =
+        Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in
+      let env = Array.append (T.extra_env ()) (Unix.environment ()) in
+    Worker.spawn ~env Sys.argv.(0) args in
+    name, proc, CThread.prepare_in_channel_for_thread_friendly_io ic, oc
+
+  let manager cpanel (id, proc, ic, oc) =
+    let { WorkerPool.extra = queue; exit; cancelled } = cpanel in
+    let exit () =  report_status ~id "Dead"; exit () in
+    let last_task = ref None in
+    let worker_age = ref `Fresh in
+    let got_token = ref false in
+    let giveback_exec_token () =
+      if !got_token then (CoqworkmgrApi.giveback 1; got_token := false) in
+    let stop_waiting = ref false in
+    let expiration_date = ref (ref false) in
+    let pick_task () =
+      prerr_endline "waiting for a task";
+      let pick age (t, c) = not !c && T.task_match age t in
+      let task, task_expiration =
+        TQueue.pop ~picky:(pick !worker_age) ~destroy:stop_waiting queue in
+      expiration_date := task_expiration;
+      last_task := Some task;
+      prerr_endline ("got task: "^T.name_of_task task);
+      task in
+    let add_tasks l =
+      List.iter (fun t -> TQueue.push queue (t,!expiration_date)) l in
+    let get_exec_token () =
+      ignore(CoqworkmgrApi.get 1);
+      got_token := true;
+      prerr_endline ("got execution token") in
+    let kill proc =
+      Worker.kill proc;
+      prerr_endline ("Worker exited: " ^
+        match Worker.wait proc with
+        | Unix.WEXITED 0x400 -> "exit code unavailable"
+        | Unix.WEXITED i -> Printf.sprintf "exit(%d)" i
+        | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno
+        | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in
+    let more_univs n =
+      CList.init 10 (fun _ ->
+        Universes.new_univ_level (Global.current_dirpath ())) in
+
+    let rec kill_if () =
+      if not (Worker.is_alive proc) then ()
+      else if cancelled () || !(!expiration_date) then
+        let () = stop_waiting := true in
+        let () = TQueue.signal_destruction queue in
+        Worker.kill proc
+      else
+        let () = Unix.sleep 1 in
+        kill_if ()
+    in
+    let _ = Thread.create kill_if () in
+
+    try while true do
+      report_status ~id "Idle";
+      let task = pick_task () in
+      match T.request_of_task !worker_age task with
+      | None -> prerr_endline ("Task expired: " ^ T.name_of_task task)
+      | Some req ->
+      try
+        get_exec_token ();
+        marshal_request oc (Request req);
+        let rec continue () =
+          match unmarshal_response ic with
+          | RespGetCounterNewUnivLevel ->
+              marshal_more_data oc (MoreDataUnivLevel (more_univs 10));
+              continue ()
+          | RespFeedback fbk -> T.forward_feedback fbk; continue ()
+          | Response resp ->
+              match T.use_response !worker_age task resp with
+              | `End -> raise Die
+              | `Stay(competence, new_tasks) ->
+                   last_task := None;
+                   giveback_exec_token ();
+                   worker_age := `Old competence;
+                   add_tasks new_tasks
+        in
+          continue ()
+      with
+      | (Sys_error _|Invalid_argument _|End_of_file|Die) as e ->
+          raise e (* we pass the exception to the external handler *)
+      | MarshalError s -> T.on_marshal_error s task; raise Die
+      | e ->
+          pr_err ("Uncaught exception in worker manager: "^
+            string_of_ppcmds (print e));
+          flush_all (); raise Die
+    done with
+    | (Die | TQueue.BeingDestroyed) ->
+        giveback_exec_token (); kill proc; exit ()
+    | Sys_error _ | Invalid_argument _ | End_of_file ->
+        giveback_exec_token ();
+        T.on_task_cancellation_or_expiration_or_slave_death !last_task;
+        kill proc;
+        exit ()
+  end
+
+  module Pool = WorkerPool.Make(Model)
+
+  type queue = {
+    active : Pool.pool;
+    queue : (T.task * expiration) TQueue.t;
+    cleaner : Thread.t;
+  }
+
+  let create size =
+    let cleaner queue =
+      while true do
+        try ignore(TQueue.pop ~picky:(fun (_,cancelled) -> !cancelled) queue)
+        with TQueue.BeingDestroyed -> Thread.exit ()
+      done in
+    let queue = TQueue.create () in
+    {
+      active = Pool.create queue ~size;
+      queue;
+      cleaner = Thread.create cleaner queue;
+    }
+  
+  let destroy { active; queue } =
+    Pool.destroy active;
+    TQueue.destroy queue
+
+  let enqueue_task { queue; active } (t, _ as item) =
+    prerr_endline ("Enqueue task "^T.name_of_task t);
+    TQueue.push queue item
+
+  let cancel_worker { active } n = Pool.cancel n active
+
+  let name_of_request (Request r) = T.name_of_request r
+
+  let set_order { queue } cmp =
+    TQueue.set_order queue (fun (t1,_) (t2,_) -> cmp t1 t2)
+
+  let join { queue; active } =
+    if not (Pool.is_empty active) then
+      TQueue.wait_until_n_are_waiting_and_queue_empty
+        (Pool.n_workers active + 1(*cleaner*))
+        queue
+
+  let cancel_all { queue; active } =
+    TQueue.clear queue;
+    Pool.cancel_all active
+
+  let slave_ic = ref None
+  let slave_oc = ref None
+
+  let init_stdout () =
+    let ic, oc = Spawned.get_channels () in
+    slave_oc := Some oc; slave_ic := Some ic
+
+  let bufferize f =
+    let l = ref [] in
+    fun () ->
+      match !l with
+      | [] -> let data = f () in l := List.tl data; List.hd data
+      | x::tl -> l := tl; x
+
+  let slave_handshake () =
+    Pool.worker_handshake (Option.get !slave_ic) (Option.get !slave_oc)
+
+  let main_loop () =
+    let slave_feeder oc fb =
+      Marshal.to_channel oc (RespFeedback fb) []; flush oc in
+    Pp.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x);
+    Pp.log_via_feedback ();
+    Universes.set_remote_new_univ_level (bufferize (fun () ->
+      marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel;
+      match unmarshal_more_data (Option.get !slave_ic) with
+      | MoreDataUnivLevel l -> l));
+    let working = ref false in
+    slave_handshake ();
+    while true do
+      try
+        working := false;
+        let request = unmarshal_request (Option.get !slave_ic) in
+        working := true;
+        report_status (name_of_request request);
+        let response = slave_respond request in
+        report_status "Idle";
+        marshal_response (Option.get !slave_oc) response;
+        Ephemeron.clear ()
+      with
+      | MarshalError s ->
+        pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2
+      | End_of_file ->
+        prerr_endline "connection lost"; flush_all (); exit 2
+      | e ->
+        pr_err ("Slave: critical exception: " ^ Pp.string_of_ppcmds (print e));
+        flush_all (); exit 1
+    done
+
+  let clear { queue; active } =
+    assert(Pool.is_empty active); (* We allow that only if no slaves *)
+    TQueue.clear queue
+  
+  let snapshot { queue; active } =
+    List.map fst
+     (TQueue.wait_until_n_are_waiting_then_snapshot
+       (Pool.n_workers active) queue)
+
+  let with_n_workers n f =
+    let q = create n in 
+    try let rc = f q in destroy q; rc
+    with e -> let e = Errors.push e in destroy q; iraise e
+
+  let n_workers { active } = Pool.n_workers active
+
+end
+
+module MakeQueue(T : Task) = struct include Make(T) end
+module MakeWorker(T : Task) = struct include Make(T) end
diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli
new file mode 100644
index 00000000..78f295d3
--- /dev/null
+++ b/stm/asyncTaskQueue.mli
@@ -0,0 +1,82 @@
+(************************************************************************)
+(*  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 'a worker_status = [ `Fresh | `Old of 'a ]
+
+module type Task = sig
+
+  type task
+  type competence
+
+  (* Marshallable *)
+  type request
+  type response
+
+  val name : string ref (* UID of the task kind, for -toploop *)
+  val extra_env : unit -> string array
+
+  (* run by the master, on a thread *)
+  val request_of_task : competence worker_status -> task -> request option
+  val task_match : competence worker_status -> task -> bool
+  val use_response :
+    competence worker_status -> task -> response ->
+      [ `Stay of competence * task list | `End ]
+  val on_marshal_error : string -> task -> unit
+  val on_task_cancellation_or_expiration_or_slave_death : task option -> unit
+  val forward_feedback : Feedback.feedback -> unit
+ 
+  (* run by the worker *)
+  val perform : request -> response
+
+  (* debugging *)
+  val name_of_task : task -> string
+  val name_of_request : request -> string
+
+end
+
+type expiration = bool ref
+
+module MakeQueue(T : Task) : sig
+
+  type queue
+
+  (* Number of workers, 0 = lazy local *)
+  val create : int -> queue
+  val destroy : queue -> unit
+
+  val n_workers : queue -> int
+
+  val enqueue_task : queue -> T.task * expiration -> unit
+
+  (* blocking function that waits for the task queue to be empty *)
+  val join : queue -> unit
+  val cancel_all : queue -> unit
+
+  val cancel_worker : queue -> WorkerPool.worker_id -> unit
+
+  val set_order : queue -> (T.task -> T.task -> int) -> unit
+
+  (* Take a snapshot (non destructive but waits until all workers are
+   * enqueued) *)
+  val snapshot : queue -> T.task list
+
+  (* Clears the queue, only if the worker prool is empty *)
+ val clear : queue -> unit
+ 
+  (* create a queue, run the function, destroy the queue.
+   * the user should call join *)
+  val with_n_workers : int -> (queue -> 'a) -> 'a
+
+end
+
+module MakeWorker(T : Task) : sig
+
+  val main_loop : unit -> unit
+  val init_stdout : unit -> unit
+  
+end
diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml
new file mode 100644
index 00000000..c34d447e
--- /dev/null
+++ b/stm/coqworkmgrApi.ml
@@ -0,0 +1,140 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+let debug = false
+
+type request =
+  | Hello of Flags.priority
+  | Get of int
+  | TryGet of int
+  | GiveBack of int
+  | Ping
+
+type response =
+  | Tokens of int
+  | Noluck
+  | Pong of int * int * int
+
+exception ParseError
+
+(* make it work with telnet: strip trailing \r  *)
+let strip_r s =
+  let len = String.length s in
+  if s.[len - 1] <> '\r' then s else String.sub s 0 (len - 1)
+
+let positive_int_of_string n =
+  try
+    let n = int_of_string n in
+    if n <= 0 then raise ParseError else n
+  with Invalid_argument _ | Failure _ -> raise ParseError
+
+let parse_request s =
+  if debug then Printf.eprintf "parsing '%s'\n" s;
+  match Str.split (Str.regexp " ") (strip_r s) with
+  | [ "HELLO"; "LOW" ] -> Hello Flags.Low
+  | [ "HELLO"; "HIGH" ] -> Hello Flags.High
+  | [ "GET"; n ] -> Get (positive_int_of_string n)
+  | [ "TRYGET"; n ] -> TryGet (positive_int_of_string n)
+  | [ "GIVEBACK"; n ] -> GiveBack (positive_int_of_string n)
+  | [ "PING" ] -> Ping
+  | _ -> raise ParseError
+
+let parse_response s =
+  if debug then Printf.eprintf "parsing '%s'\n" s;
+  match Str.split (Str.regexp " ") (strip_r s) with
+  | [ "TOKENS"; n ] -> Tokens (positive_int_of_string n)
+  | [ "NOLUCK" ] -> Noluck
+  | [ "PONG"; n; m; p ] ->
+      let n = try int_of_string n with _ -> raise ParseError in
+      let m = try int_of_string m with _ -> raise ParseError in
+      let p = try int_of_string p with _ -> raise ParseError in
+      Pong (n,m,p)
+  | _ -> raise ParseError
+       
+let print_request = function
+  | Hello Flags.Low -> "HELLO LOW\n"
+  | Hello Flags.High -> "HELLO HIGH\n"
+  | Get n -> Printf.sprintf "GET %d\n" n
+  | TryGet n -> Printf.sprintf "TRYGET %d\n" n
+  | GiveBack n -> Printf.sprintf "GIVEBACK %d\n" n
+  | Ping -> "PING\n"
+
+let print_response = function
+  | Tokens n -> Printf.sprintf "TOKENS %d\n" n
+  | Noluck -> "NOLUCK\n"
+  | Pong (n,m,p) -> Printf.sprintf "PONG %d %d %d\n" n m p
+
+let connect s =
+  try
+    match Str.split (Str.regexp ":") s with
+    | [ h; p ] ->
+        let open Unix in
+        let s = socket PF_INET SOCK_STREAM 0 in
+        connect s (ADDR_INET (inet_addr_of_string h,int_of_string p));
+        Some s
+    | _ -> None
+  with Unix.Unix_error _ -> None
+
+let manager = ref None
+
+let option_map f = function None -> None | Some x -> Some (f x)
+
+let init p =
+  try
+    let sock = Sys.getenv "COQWORKMGR_SOCK" in
+    manager := option_map (fun s -> 
+      let cout = Unix.out_channel_of_descr s in
+      set_binary_mode_out cout true;
+      let cin = Unix.in_channel_of_descr s in
+      set_binary_mode_in cin true;
+      output_string cout (print_request (Hello p)); flush cout;
+      cin, cout) (connect sock)
+  with Not_found | End_of_file -> ()
+
+let with_manager f g =
+  try
+    match !manager with
+    | None -> f ()
+    | Some (cin, cout) -> g cin cout
+  with
+  | ParseError | End_of_file -> manager := None; f ()
+
+let get n =
+  with_manager
+  (fun () ->
+    min n (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers))
+  (fun cin cout ->
+    output_string cout (print_request (Get n));
+    flush cout;
+    let l = input_line cin in
+    match parse_response l with
+    | Tokens m -> m
+    | _ -> raise (Failure "coqworkmgr protocol error"))
+
+let tryget n =
+  with_manager
+  (fun () ->
+    Some
+     (min n
+       (min !Flags.async_proofs_n_workers !Flags.async_proofs_n_tacworkers)))
+  (fun cin cout ->
+    output_string cout (print_request (TryGet n));
+    flush cout;
+    let l = input_line cin in
+    match parse_response l with
+    | Tokens m -> Some m
+    | Noluck -> None
+    | _ -> raise (Failure "coqworkmgr protocol error"))
+
+let giveback n =
+  with_manager
+  (fun () -> ())
+  (fun cin cout ->
+    output_string cout (print_request (GiveBack n));
+    flush cout)
+
diff --git a/stm/coqworkmgrApi.mli b/stm/coqworkmgrApi.mli
new file mode 100644
index 00000000..42dd39b9
--- /dev/null
+++ b/stm/coqworkmgrApi.mli
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* High level api for clients of the service (like coqtop) *)
+
+(* Connects to a work manager if any. If no worker manager, then
+   -async-proofs-j and -async-proofs-tac-j are used *)
+val init : Flags.priority -> unit
+
+(* blocking *)
+val get : int -> int
+
+(* not blocking *)
+val tryget : int -> int option
+val giveback : int -> unit
+
+(* Low level *)
+type request =
+  | Hello of Flags.priority
+  | Get of int
+  | TryGet of int
+  | GiveBack of int
+  | Ping
+
+type response =
+  | Tokens of int
+  | Noluck
+  | Pong of int * int * int (* cur, max, pid *)
+
+val connect : string -> Unix.file_descr option
+
+exception ParseError
+
+(* Intended to be used with input_line and output_string *)
+val parse_request  : string -> request
+val parse_response : string -> response
+
+val print_request  : request -> string
+val print_response : response -> string
diff --git a/stm/dag.ml b/stm/dag.ml
new file mode 100644
index 00000000..d0515d3f
--- /dev/null
+++ b/stm/dag.ml
@@ -0,0 +1,134 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type S = sig
+
+  module Cluster :
+  sig
+    type 'd t
+    val equal : 'd t -> 'd t -> bool
+    val compare : 'd t -> 'd t -> int
+    val to_string : 'd t -> string
+    val data : 'd t -> 'd
+  end
+
+  type node
+  module NodeSet : Set.S with type elt = node
+
+  type ('edge,'info,'cdata) t
+
+  val empty : ('e,'i,'d) t
+
+  val add_edge : ('e,'i,'d) t -> node -> 'e -> node -> ('e,'i,'d) t
+  val from_node : ('e,'i,'d) t -> node -> (node * 'e) list
+  val mem : ('e,'i,'d) t -> node -> bool
+  val del_edge : ('e,'i,'d) t -> node -> node -> ('e,'i,'d) t
+  val del_nodes : ('e,'i,'d) t -> NodeSet.t  -> ('e,'i,'d) t
+  val all_nodes : ('e,'i,'d) t -> NodeSet.t
+
+  val iter : ('e,'i,'d) t ->
+    (node -> 'd Cluster.t option -> 'i option ->
+      (node * 'e) list -> unit) -> unit
+
+  val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+  val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option
+  val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t
+
+  val get_info : ('e,'i,'d) t -> node -> 'i option
+  val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t
+  val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t
+
+end
+
+module Make(OT : Map.OrderedType) = struct
+
+module Cluster =
+struct
+  type 'd t = 'd * int
+  let equal (_,i1) (_,i2) = Int.equal i1 i2
+  let compare (_,i1) (_,i2) = Int.compare i1 i2
+  let to_string (_,i) = string_of_int i
+  let data (d,_) = d
+end
+
+type node = OT.t
+
+module NodeMap = CMap.Make(OT)
+module NodeSet = Set.Make(OT)
+
+type ('edge,'info,'data) t = {
+  graph : (node * 'edge) list NodeMap.t;
+  clusters : 'data Cluster.t NodeMap.t;
+  infos : 'info NodeMap.t;
+}
+
+let empty = {
+  graph = NodeMap.empty;
+  clusters = NodeMap.empty;
+  infos = NodeMap.empty;
+}
+
+let mem { graph } id = NodeMap.mem id graph
+
+let add_edge dag from trans dest = { dag with
+  graph =
+    try NodeMap.modify from (fun _ arcs -> (dest, trans) :: arcs) dag.graph
+    with Not_found -> NodeMap.add from [dest, trans] dag.graph }
+
+let from_node { graph } id = NodeMap.find id graph
+
+let del_edge dag id tgt = { dag with
+  graph =
+    try
+      let modify _ arcs =
+        let filter (d, _) = OT.compare d tgt <> 0 in
+        List.filter filter arcs
+      in
+      NodeMap.modify id modify dag.graph
+    with Not_found -> dag.graph }
+
+let del_nodes dag s = {
+  infos = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.infos;
+  clusters = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.clusters;
+  graph = NodeMap.filter (fun n l ->
+      let drop = NodeSet.mem n s in
+      if not drop then
+        assert(List.for_all (fun (n',_) -> not(NodeSet.mem n' s)) l);
+      not drop)
+    dag.graph }
+
+let clid = ref 1
+let create_cluster dag l data =
+  incr clid;
+  { dag with clusters =
+     List.fold_right (fun x clusters ->
+       NodeMap.add x (data, !clid) clusters) l dag.clusters }
+
+let cluster_of dag id =
+  try Some (NodeMap.find id dag.clusters)
+  with Not_found -> None
+
+let del_cluster dag c =
+  { dag with clusters =
+     NodeMap.filter (fun _ c' -> not (Cluster.equal c' c)) dag.clusters }
+
+let get_info dag id =
+  try Some (NodeMap.find id dag.infos)
+  with Not_found -> None
+
+let set_info dag id info = { dag with infos = NodeMap.add id info dag.infos }
+
+let clear_info dag id = { dag with infos = NodeMap.remove id dag.infos }
+
+let iter dag f =
+  NodeMap.iter (fun k v -> f k (cluster_of dag k) (get_info dag k) v) dag.graph
+
+let all_nodes dag = NodeMap.domain dag.graph
+
+end
+
diff --git a/stm/dag.mli b/stm/dag.mli
new file mode 100644
index 00000000..14ccdc9f
--- /dev/null
+++ b/stm/dag.mli
@@ -0,0 +1,52 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module type S = sig
+
+  (* A cluster is just a set of nodes.  This set holds some data.
+     Stm uses this to group nodes contribution to the same proofs and
+     that can be evaluated asynchronously *)
+  module Cluster :
+  sig
+    type 'd t
+    val equal : 'd t -> 'd t -> bool
+    val compare : 'd t -> 'd t -> int
+    val to_string : 'd t -> string
+    val data : 'd t -> 'd
+  end
+
+  type node
+  module NodeSet : Set.S with type elt = node
+
+  type ('edge,'info,'cdata) t
+  
+  val empty : ('e,'i,'d) t
+
+  val add_edge : ('e,'i,'d) t -> node -> 'e -> node -> ('e,'i,'d) t
+  val from_node : ('e,'i,'d) t -> node -> (node * 'e) list
+  val mem : ('e,'i,'d) t -> node -> bool
+  val del_edge : ('e,'i,'d) t -> node -> node -> ('e,'i,'d) t
+  val del_nodes : ('e,'i,'d) t -> NodeSet.t  -> ('e,'i,'d) t
+  val all_nodes : ('e,'i,'d) t -> NodeSet.t
+
+  val iter : ('e,'i,'d) t -> 
+    (node -> 'd Cluster.t option -> 'i option ->
+      (node * 'e) list -> unit) -> unit
+
+  val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t
+  val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option
+  val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t
+
+  val get_info : ('e,'i,'d) t -> node -> 'i option
+  val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t
+  val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t
+
+end
+
+module Make(OT : Map.OrderedType) : S with type node = OT.t
+
diff --git a/stm/lemmas.ml b/stm/lemmas.ml
new file mode 100644
index 00000000..f2e68779
--- /dev/null
+++ b/stm/lemmas.ml
@@ -0,0 +1,478 @@
+(************************************************************************)
+(*  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 by Hugo Herbelin from contents related to lemma proofs in
+   file command.ml, Aug 2009 *)
+
+open Errors
+open Util
+open Flags
+open Pp
+open Names
+open Term
+open Declarations
+open Declareops
+open Entries
+open Environ
+open Nameops
+open Globnames
+open Decls
+open Decl_kinds
+open Declare
+open Pretyping
+open Termops
+open Namegen
+open Reductionops
+open Constrexpr
+open Constrintern
+open Impargs
+
+type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a
+let mk_hook hook = hook
+let call_hook fix_exn hook l c =
+  try hook l c
+  with e when Errors.noncritical e ->
+    let e = Errors.push e in
+    iraise (fix_exn e)
+
+(* Support for mutually proved theorems *)
+
+let retrieve_first_recthm = function
+  | VarRef id ->
+      (pi2 (Global.lookup_named id),variable_opacity id)
+  | ConstRef cst ->
+      let cb = Global.lookup_constant cst in
+      (Global.body_of_constant_body cb, is_opaque cb)
+  | _ -> assert false
+
+let adjust_guardness_conditions const = function
+  | [] -> const (* Not a recursive statement *)
+  | possible_indexes ->
+  (* Try all combinations... not optimal *)
+     let env = Global.env() in
+     { const with const_entry_body =
+        Future.chain ~greedy:true ~pure:true const.const_entry_body
+        (fun ((body, ctx), eff) ->
+          match kind_of_term body with
+          | Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
+(*      let possible_indexes =
+	List.map2 (fun i c -> match i with Some i -> i | None ->
+	  List.interval 0 (List.length ((lam_assum c))))
+	  lemma_guard (Array.to_list fixdefs) in
+*)
+              let add c cb e =
+                let exists c e =
+                  try ignore(Environ.lookup_constant c e); true
+                  with Not_found -> false in 
+                if exists c e then e else Environ.add_constant c cb e in
+              let env = Declareops.fold_side_effects (fun env -> function
+                | SEsubproof (c, cb,_) -> add c cb env
+                | SEscheme (l,_) ->
+                    List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l)
+                env (Declareops.uniquize_side_effects eff) in
+              let indexes =
+	        search_guard Loc.ghost env
+                  possible_indexes fixdecls in
+		(mkFix ((indexes,0),fixdecls), ctx), eff
+          | _ -> (body, ctx), eff) }
+
+let find_mutually_recursive_statements thms =
+    let n = List.length thms in
+    let inds = List.map (fun (id,(t,impls,annot)) ->
+      let (hyps,ccl) = decompose_prod_assum t in
+      let x = (id,(t,impls)) in
+      match annot with
+      (* Explicit fixpoint decreasing argument is given *)
+      | Some (Some (_,id),CStructRec) ->
+          let i,b,typ = lookup_rel_id id hyps in
+          (match kind_of_term t with
+          | Ind ((kn,_ as ind), u) when
+              let mind = Global.lookup_mind kn in
+              mind.mind_finite == Decl_kinds.Finite && Option.is_empty b ->
+              [ind,x,i],[]
+          | _ ->
+              error "Decreasing argument is not an inductive assumption.")
+      (* Unsupported cases *)
+      | Some (_,(CWfRec _|CMeasureRec _)) ->
+          error "Only structural decreasing is supported for mutual statements."
+      (* Cofixpoint or fixpoint w/o explicit decreasing argument *)
+      | None | Some (None, CStructRec) ->
+      let whnf_hyp_hds = map_rel_context_in_env
+        (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c))
+        (Global.env()) hyps in
+      let ind_hyps =
+        List.flatten (List.map_i (fun i (_,b,t) ->
+          match kind_of_term t with
+          | Ind ((kn,_ as ind),u) when
+                let mind = Global.lookup_mind kn in
+                mind.mind_finite <> Decl_kinds.CoFinite && Option.is_empty b ->
+              [ind,x,i]
+          | _ ->
+              []) 0 (List.rev whnf_hyp_hds)) in
+      let ind_ccl =
+        let cclenv = push_rel_context hyps (Global.env()) in
+        let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in
+        match kind_of_term whnf_ccl with
+        | Ind ((kn,_ as ind),u) when
+              let mind = Global.lookup_mind kn in
+              Int.equal mind.mind_ntypes n && mind.mind_finite == Decl_kinds.CoFinite ->
+            [ind,x,0]
+        | _ ->
+            [] in
+      ind_hyps,ind_ccl) thms in
+    let inds_hyps,ind_ccls = List.split inds in
+    let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> eq_mind kn kn' in
+    (* Check if all conclusions are coinductive in the same type *)
+    (* (degenerated cartesian product since there is at most one coind ccl) *)
+    let same_indccl =
+      List.cartesians_filter (fun hyp oks ->
+	if List.for_all (of_same_mutind hyp) oks
+	then Some (hyp::oks) else None) [] ind_ccls in
+    let ordered_same_indccl =
+      List.filter (List.for_all_i (fun i ((kn,j),_,_) -> Int.equal i j) 0) same_indccl in
+    (* Check if some hypotheses are inductive in the same type *)
+    let common_same_indhyp =
+      List.cartesians_filter (fun hyp oks ->
+	if List.for_all (of_same_mutind hyp) oks
+	then Some (hyp::oks) else None) [] inds_hyps in
+    let ordered_inds,finite,guard =
+      match ordered_same_indccl, common_same_indhyp with
+      | indccl::rest, _ ->
+	  assert (List.is_empty rest);
+          (* One occ. of common coind ccls and no common inductive hyps *)
+	  if not (List.is_empty common_same_indhyp) then
+	    if_verbose msg_info (str "Assuming mutual coinductive statements.");
+	  flush_all ();
+          indccl, true, []
+      | [], _::_ ->
+          let () = match same_indccl with
+          | ind :: _ ->
+            if List.distinct_f ind_ord (List.map pi1 ind)
+            then
+              if_verbose msg_info
+                (strbrk
+                   ("Coinductive statements do not follow the order of "^
+                    "definition, assuming the proof to be by induction."));
+            flush_all ()
+          | _ -> ()
+          in
+          let possible_guards = List.map (List.map pi3) inds_hyps in
+	  (* assume the largest indices as possible *)
+	  List.last common_same_indhyp, false, possible_guards
+      | _, [] ->
+	  error
+            ("Cannot find common (mutual) inductive premises or coinductive" ^
+             " conclusions in the statements.")
+    in
+    (finite,guard,None), ordered_inds
+
+let look_for_possibly_mutual_statements = function
+  | [id,(t,impls,None)] ->
+      (* One non recursively proved theorem *)
+      None,[id,(t,impls)],None
+  | _::_ as thms ->
+    (* More than one statement and/or an explicit decreasing mark: *)
+    (* we look for a common inductive hyp or a common coinductive conclusion *)
+    let recguard,ordered_inds = find_mutually_recursive_statements thms in
+    let thms = List.map pi2 ordered_inds in
+    Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds)
+  | [] -> anomaly (Pp.str "Empty list of theorems.")
+
+(* Saving a goal *)
+
+let save id const cstrs do_guard (locality,poly,kind) hook =
+  let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in
+  try
+    let const = adjust_guardness_conditions const do_guard in
+    let k = Kindops.logical_kind_of_goal_kind kind in
+    let l,r = match locality with
+      | Discharge when Lib.sections_are_opened () ->
+          let c = SectionLocalDef const in
+          let _ = declare_variable id (Lib.cwd(), c, k) in
+          (Local, VarRef id)
+      | Local | Global | Discharge ->
+          let local = match locality with
+          | Local | Discharge -> true
+          | Global -> false
+          in
+          let kn = declare_constant id ~local (DefinitionEntry const, k) in
+          (locality, ConstRef kn) in
+    definition_message id;
+    call_hook (fun exn -> exn) hook l r
+  with e when Errors.noncritical e ->
+    let e = Errors.push e in
+    iraise (fix_exn e)
+
+let default_thm_id = Id.of_string "Unnamed_thm"
+
+let compute_proof_name locality = function
+  | Some (loc,id) ->
+      (* We check existence here: it's a bit late at Qed time *)
+      if Nametab.exists_cci (Lib.make_path id) || is_section_variable id ||
+	 locality == Global && Nametab.exists_cci (Lib.make_path_except_section id)
+      then
+        user_err_loc (loc,"",pr_id id ++ str " already exists.");
+      id
+  | None ->
+      next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) 
+
+let save_remaining_recthms (locality,p,kind) norm ctx body opaq i (id,(t_i,(_,imps))) =
+  let t_i = norm t_i in
+  match body with
+  | None ->
+      (match locality with
+      | Discharge ->
+          let impl = false in (* copy values from Vernacentries *)
+          let k = IsAssumption Conjectural in
+          let c = SectionLocalAssum ((t_i,ctx),p,impl) in
+	  let _ = declare_variable id (Lib.cwd(),c,k) in
+          (Discharge, VarRef id,imps)
+      | Local | Global ->
+          let k = IsAssumption Conjectural in
+          let local = match locality with
+          | Local -> true
+          | Global -> false
+          | Discharge -> assert false
+          in
+          let ctx = Univ.ContextSet.to_context ctx in
+          let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in
+          let kn = declare_constant id ~local decl in
+          (locality,ConstRef kn,imps))
+  | Some body ->
+      let body = norm body in
+      let k = Kindops.logical_kind_of_goal_kind kind in
+      let body_i = match kind_of_term body with
+        | Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
+        | CoFix (0,decls) -> mkCoFix (i,decls)
+        | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in
+      match locality with
+      | Discharge ->
+          let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p 
+	    ~univs:(Univ.ContextSet.to_context ctx) body_i in
+	  let c = SectionLocalDef const in
+	  let _ = declare_variable id (Lib.cwd(), c, k) in
+          (Discharge,VarRef id,imps)
+      | Local | Global ->
+        let ctx = Univ.ContextSet.to_context ctx in
+        let local = match locality with
+        | Local -> true
+        | Global -> false
+        | Discharge -> assert false
+        in
+        let const =
+	  Declare.definition_entry ~types:t_i ~poly:p ~univs:ctx ~opaque:opaq body_i
+	in
+        let kn = declare_constant id ~local (DefinitionEntry const, k) in
+        (locality,ConstRef kn,imps)
+
+let save_hook = ref ignore
+let set_save_hook f = save_hook := f
+
+let save_named proof =
+  let id,const,cstrs,do_guard,persistence,hook = proof in
+  save id const cstrs do_guard persistence hook
+
+let check_anonymity id save_ident =
+  if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then
+    error "This command can only be used for unnamed theorem."
+
+
+let save_anonymous proof save_ident =
+  let id,const,cstrs,do_guard,persistence,hook = proof in
+  check_anonymity id save_ident;
+  save save_ident const cstrs do_guard persistence hook
+
+let save_anonymous_with_strength proof kind save_ident =
+  let id,const,cstrs,do_guard,_,hook = proof in
+  check_anonymity id save_ident;
+  (* we consider that non opaque behaves as local for discharge *)
+  save save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook
+
+(* Admitted *)
+
+let admit hook () =
+  let (id,k,typ) = Pfedit.current_proof_statement () in
+  let ctx =
+    let evd = fst (Pfedit.get_current_goal_context ()) in
+      Evd.universe_context evd
+  in
+  let e = Pfedit.get_used_variables(), pi2 k, (typ, ctx), None in
+  let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in
+  let () = match k with
+  | Global, _, _ -> ()
+  | Local, _, _ | Discharge, _, _ ->
+    msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++
+      str "declared as an axiom.")
+  in
+  let () = assumption_message id in
+  call_hook (fun exn -> exn) hook Global (ConstRef kn)
+
+(* Starting a goal *)
+
+let start_hook = ref ignore
+let set_start_hook = (:=) start_hook
+
+
+let get_proof proof do_guard hook opacity =
+  let (id,(const,cstrs,persistence)) =
+    Pfedit.cook_this_proof proof
+  in
+  (** FIXME *)
+  id,{const with const_entry_opaque = opacity},cstrs,do_guard,persistence,hook
+
+let standard_proof_terminator compute_guard hook =
+  let open Proof_global in function
+  | Admitted ->
+      admit hook ();
+      Pp.feedback Feedback.AddedAxiom
+  | Proved (is_opaque,idopt,proof) ->
+      let proof = get_proof proof compute_guard hook is_opaque in
+      begin match idopt with
+      | None -> save_named proof
+      | Some ((_,id),None) -> save_anonymous proof id
+      | Some ((_,id),Some kind) -> 
+          save_anonymous_with_strength proof kind id
+      end
+
+let universe_proof_terminator compute_guard hook =
+  let open Proof_global in function
+  | Admitted ->
+      admit (hook None) ();
+      Pp.feedback Feedback.AddedAxiom
+  | Proved (is_opaque,idopt,proof) ->
+      let proof = get_proof proof compute_guard 
+	(hook (Some proof.Proof_global.universes)) is_opaque in
+      begin match idopt with
+      | None -> save_named proof
+      | Some ((_,id),None) -> save_anonymous proof id
+      | Some ((_,id),Some kind) -> 
+          save_anonymous_with_strength proof kind id
+      end
+
+let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
+  let terminator = standard_proof_terminator compute_guard hook in
+  let sign = 
+    match sign with
+    | Some sign -> sign
+    | None -> initialize_named_context_for_proof ()
+  in
+  !start_hook c;
+  Pfedit.start_proof id kind sigma sign c ?init_tac terminator
+
+let start_proof_univs id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook =
+  let terminator = universe_proof_terminator compute_guard hook in
+  let sign = 
+    match sign with
+    | Some sign -> sign
+    | None -> initialize_named_context_for_proof ()
+  in
+  !start_hook c;
+  Pfedit.start_proof id kind sigma sign c ?init_tac terminator
+
+let rec_tac_initializer finite guard thms snl =
+  if finite then
+    match List.map (fun (id,(t,_)) -> (id,t)) thms with
+    | (id,_)::l -> Tactics.mutual_cofix id l 0
+    | _ -> assert false
+  else
+    (* nl is dummy: it will be recomputed at Qed-time *)
+    let nl = match snl with 
+     | None -> List.map succ (List.map List.last guard)
+     | Some nl -> nl
+    in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with
+       | (id,n,_)::l -> Tactics.mutual_fix id n l 0
+       | _ -> assert false
+
+let start_proof_with_initialization kind ctx recguard thms snl hook =
+  let intro_tac (_, (_, (ids, _))) =
+    Tacticals.New.tclMAP (function
+    | Name id -> Tactics.intro_mustbe_force id
+    | Anonymous -> Tactics.intro) (List.rev ids) in
+  let init_tac,guard = match recguard with
+  | Some (finite,guard,init_tac) ->
+      let rec_tac = Proofview.V82.tactic (rec_tac_initializer finite guard thms snl) in
+      Some (match init_tac with
+        | None -> 
+            if Flags.is_auto_intros () then 
+              Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms)
+            else
+              rec_tac
+        | Some tacl ->
+            Tacticals.New.tclTHENS rec_tac
+            (if Flags.is_auto_intros () then
+              List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms
+            else
+              tacl)),guard
+  | None ->
+      let () = match thms with [_] -> () | _ -> assert false in
+      (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in
+  match thms with
+  | [] -> anomaly (Pp.str "No proof to start")
+  | (id,(t,(_,imps)))::other_thms ->
+      let hook ctx strength ref =
+        let ctx = match ctx with
+        | None -> Evd.empty_evar_universe_context
+        | Some ctx -> ctx
+        in
+        let other_thms_data =
+          if List.is_empty other_thms then [] else
+            (* there are several theorems defined mutually *)
+            let body,opaq = retrieve_first_recthm ref in
+            let subst = Evd.evar_universe_context_subst ctx in
+            let norm c = Universes.subst_opt_univs_constr subst c in
+	    let ctx = Evd.evar_universe_context_set ctx in
+	    let body = Option.map norm body in
+            List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in
+        let thms_data = (strength,ref,imps)::other_thms_data in
+        List.iter (fun (strength,ref,imps) ->
+	  maybe_declare_manual_implicits false ref imps;
+	  call_hook (fun exn -> exn) hook strength ref) thms_data in
+      start_proof_univs id kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard
+
+let start_proof_com kind thms hook =
+  let env0 = Global.env () in
+  let evdref = ref (Evd.from_env env0) in
+  let thms = List.map (fun (sopt,(bl,t,guard)) ->
+    let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in
+    let t', imps' = interp_type_evars_impls ~impls env evdref t in
+    check_evars_are_solved env !evdref (Evd.empty,!evdref);
+    let ids = List.map pi1 ctx in
+      (compute_proof_name (pi1 kind) sopt,
+      (nf_evar !evdref (it_mkProd_or_LetIn t' ctx),
+       (ids, imps @ lift_implicits (List.length ids) imps'),
+       guard)))
+    thms in
+  let recguard,thms,snl = look_for_possibly_mutual_statements thms in
+  let evd, nf = Evarutil.nf_evars_and_universes !evdref in
+  let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in
+  start_proof_with_initialization kind evd
+    recguard thms snl hook
+
+
+(* Saving a proof *)
+
+let save_proof ?proof = function
+  | Vernacexpr.Admitted ->
+      Proof_global.get_terminator() Proof_global.Admitted
+  | Vernacexpr.Proved (is_opaque,idopt) ->
+      let (proof_obj,terminator) =
+        match proof with
+        | None ->
+            Proof_global.close_proof ~keep_body_ucst_sepatate:false (fun x -> x)
+        | Some proof -> proof
+      in
+      (* if the proof is given explicitly, nothing has to be deleted *)
+      if Option.is_empty proof then Pfedit.delete_current_proof ();
+      terminator (Proof_global.Proved (is_opaque,idopt,proof_obj))
+
+(* Miscellaneous *)
+
+let get_current_context () =
+  try Pfedit.get_current_goal_context ()
+  with e when Logic.catchable_exception e ->
+    (Evd.empty, Global.env())
diff --git a/toplevel/lemmas.mli b/stm/lemmas.mli
index 1e68f846..d0669d7a 100644
--- a/toplevel/lemmas.mli
+++ b/stm/lemmas.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        *)
@@ -9,55 +9,54 @@
 open Names
 open Term
 open Decl_kinds
-open Topconstr
+open Constrexpr
 open Tacexpr
 open Vernacexpr
-open Proof_type
 open Pfedit
 
+type 'a declaration_hook
+
+val mk_hook :
+  (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook
+
+val call_hook :
+  Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a
+
 (** A hook start_proof calls on the type of the definition being started *)
 val set_start_hook : (types -> unit) -> unit
 
-val start_proof : identifier -> goal_kind -> types ->
-  ?init_tac:tactic -> ?compute_guard:lemma_possible_guards -> 
-    declaration_hook -> unit
+val start_proof : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types ->
+  ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> 
+   unit declaration_hook -> unit
+
+val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named_context_val -> types ->
+  ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> 
+  (Proof_global.proof_universes option -> unit declaration_hook) -> unit
 
 val start_proof_com : goal_kind ->
   (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list ->
-  declaration_hook -> unit
+  unit declaration_hook -> unit
 
 val start_proof_with_initialization : 
-  goal_kind -> (bool * lemma_possible_guards * tactic list option) option ->
-  (identifier * (types * (name list * Impargs.manual_explicitation list))) list
-  -> int list option -> declaration_hook -> unit
+  goal_kind -> Evd.evar_map -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option ->
+  (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list
+  -> int list option -> unit declaration_hook -> unit
 
-(** A hook the next three functions pass to cook_proof *)
-val set_save_hook : (Proof.proof -> unit) -> unit
+val standard_proof_terminator :
+  Proof_global.lemma_possible_guards -> unit declaration_hook ->
+    Proof_global.proof_terminator
 
 (** {6 ... } *)
-(** [save_named b] saves the current completed proof under the name it
-was started; boolean [b] tells if the theorem is declared opaque; it
-fails if the proof is not completed *)
-
-val save_named : bool -> unit
 
-(** [save_anonymous b name] behaves as [save_named] but declares the theorem
-under the name [name] and respects the strength of the declaration *)
-
-val save_anonymous : bool -> identifier -> unit
-
-(** [save_anonymous_with_strength s b name] behaves as [save_anonymous] but
-   declares the theorem under the name [name] and gives it the
-   strength [strength] *)
-
-val save_anonymous_with_strength : theorem_kind -> bool -> identifier -> unit
+(** A hook the next three functions pass to cook_proof *)
+val set_save_hook : (Proof.proof -> unit) -> unit
 
-(** [admit ()] aborts the current goal and save it as an assmumption *)
+val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit
 
-val admit : unit -> unit
 
 (** [get_current_context ()] returns the evar context and env of the
    current open proof if any, otherwise returns the empty evar context
    and the current global env *)
 
 val get_current_context : unit -> Evd.evar_map * Environ.env
+
diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml
new file mode 100644
index 00000000..0e40c345
--- /dev/null
+++ b/stm/proofworkertop.ml
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask)
+
+let () = Coqtop.toploop_init := (fun args ->
+        Flags.make_silent true;
+        W.init_stdout ();
+        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
+        args)
+
+let () = Coqtop.toploop_run := W.main_loop
+
diff --git a/stm/proofworkertop.mllib b/stm/proofworkertop.mllib
new file mode 100644
index 00000000..f9f6c22d
--- /dev/null
+++ b/stm/proofworkertop.mllib
@@ -0,0 +1 @@
+Proofworkertop
diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml
new file mode 100644
index 00000000..c8e6432b
--- /dev/null
+++ b/stm/queryworkertop.ml
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask)
+
+let () = Coqtop.toploop_init := (fun args ->
+        Flags.make_silent true;
+        W.init_stdout ();
+        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
+        args)
+
+let () = Coqtop.toploop_run := W.main_loop
+
diff --git a/stm/queryworkertop.mllib b/stm/queryworkertop.mllib
new file mode 100644
index 00000000..c2f73089
--- /dev/null
+++ b/stm/queryworkertop.mllib
@@ -0,0 +1 @@
+Queryworkertop
diff --git a/stm/spawned.ml b/stm/spawned.ml
new file mode 100644
index 00000000..18159288
--- /dev/null
+++ b/stm/spawned.ml
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  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 Spawn
+
+let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+type chandescr = AnonPipe | Socket of string * int
+
+let handshake cin cout =
+  try
+    match input_value cin with
+    | Hello(v, pid) when v = proto_version ->
+        prerr_endline (Printf.sprintf "Handshake with %d OK" pid);
+        output_value cout (Hello (proto_version,Unix.getpid ())); flush cout
+    | _ -> raise (Failure "handshake protocol")
+  with
+  | Failure s | Invalid_argument s | Sys_error s ->
+      pr_err ("Handshake failed: "  ^ s); raise (Failure "handshake")
+  | End_of_file ->
+      pr_err "Handshake failed: End_of_file"; raise (Failure "handshake")
+
+let open_bin_connection h p =
+  let open Unix in
+  let cin, cout = open_connection (ADDR_INET (inet_addr_of_string h,p)) in
+  set_binary_mode_in cin true;
+  set_binary_mode_out cout true;
+  let cin = CThread.prepare_in_channel_for_thread_friendly_io cin in
+  cin, cout
+
+let controller h p =
+  prerr_endline "starting controller thread";
+  let main () =
+    let ic, oc = open_bin_connection h p in
+    let rec loop () =
+      try
+        match CThread.thread_friendly_input_value ic with
+        | Hello _ -> prerr_endline "internal protocol error"; exit 1
+        | ReqDie -> prerr_endline "death sentence received"; exit 0
+        | ReqStats ->
+            output_value oc (RespStats (Gc.quick_stat ())); flush oc; loop ()
+      with
+      | e ->
+        prerr_endline ("control channel broken: " ^ Printexc.to_string e);
+        exit 1 in
+    loop () in
+  ignore(Thread.create main ())
+
+let main_channel = ref None
+let control_channel = ref None
+
+let channels = ref None
+
+let init_channels () =
+  if !channels <> None then Errors.anomaly(Pp.str "init_channels called twice");
+  let () = match !main_channel with
+  | None -> ()
+  | Some (Socket(mh,mp)) ->
+    channels := Some (open_bin_connection mh mp);
+  | Some AnonPipe ->
+    let stdin = Unix.in_channel_of_descr (Unix.dup Unix.stdin) in
+    let stdout = Unix.out_channel_of_descr (Unix.dup Unix.stdout) in
+    Unix.dup2 Unix.stderr Unix.stdout;
+    set_binary_mode_in stdin true;
+    set_binary_mode_out stdout true;
+    let stdin = CThread.prepare_in_channel_for_thread_friendly_io stdin in
+    channels := Some (stdin, stdout);
+  in
+  match !control_channel with
+  | None -> ()
+  | Some (Socket (ch, cp)) ->
+    controller ch cp
+  | Some AnonPipe ->
+    Errors.anomaly (Pp.str "control channel cannot be a pipe")
+
+let get_channels () =
+  match !channels with
+  | None -> Errors.anomaly(Pp.str "init_channels not called")
+  | Some(ic, oc) -> ic, oc
+
diff --git a/stm/spawned.mli b/stm/spawned.mli
new file mode 100644
index 00000000..d9e7baff
--- /dev/null
+++ b/stm/spawned.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* To link this file, threads are needed *)
+
+type chandescr = AnonPipe | Socket of string * int
+
+(* Argument parsing should set these *)
+val main_channel : chandescr option ref
+val control_channel : chandescr option ref
+
+(* Immediately after argument parsing one *must* call this *)
+val init_channels : unit -> unit
+
+(* Once initialized, these are the channels to talk with our master *)
+val get_channels : unit -> CThread.thread_ic * out_channel
+
diff --git a/stm/stm.ml b/stm/stm.ml
new file mode 100644
index 00000000..7b246854
--- /dev/null
+++ b/stm/stm.ml
@@ -0,0 +1,2407 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+let pr_err s = Printf.eprintf "%s] %s\n" (System.process_id ()) s; flush stderr
+
+let prerr_endline s = if !Flags.debug then begin pr_err s end else ()
+
+open Vernacexpr
+open Errors
+open Pp
+open Names
+open Util
+open Ppvernac
+open Vernac_classifier
+
+module Hooks = struct
+
+let process_error, process_error_hook = Hook.make ()
+let interp, interp_hook = Hook.make ()
+let with_fail, with_fail_hook = Hook.make ()
+
+let state_computed, state_computed_hook = Hook.make
+ ~default:(fun state_id ~in_cache ->
+    feedback ~state_id Feedback.Processed) ()
+
+let state_ready, state_ready_hook = Hook.make
+ ~default:(fun state_id -> ()) ()
+
+let forward_feedback, forward_feedback_hook = Hook.make
+ ~default:(function
+    | { Feedback.id = Feedback.Edit edit_id; route; contents } ->
+          feedback ~edit_id ~route contents
+    | { Feedback.id = Feedback.State state_id; route; contents } ->
+          feedback ~state_id ~route contents) ()
+
+let parse_error, parse_error_hook = Hook.make
+ ~default:(function
+    | Feedback.Edit edit_id -> fun loc msg ->
+        feedback ~edit_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))
+    | Feedback.State state_id -> fun loc msg ->
+        feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) ()
+
+let execution_error, execution_error_hook = Hook.make
+ ~default:(fun state_id loc msg ->
+    feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) ()
+
+let unreachable_state, unreachable_state_hook = Hook.make
+ ~default:(fun _ -> ()) ()
+
+include Hook
+
+(* enables:  Hooks.(call foo args) *)
+let call = get
+
+let call_process_error_once =
+  let processed : unit Exninfo.t = Exninfo.make () in
+  fun (_, info as ei) ->
+    match Exninfo.get info processed with
+    | Some _ -> ei
+    | None ->
+        let e, info = call process_error ei in
+        let info = Exninfo.add info processed () in
+        e, info
+
+end
+
+(* During interactive use we cache more states so that Undoing is fast *)
+let interactive () =
+  if !Flags.ide_slave || !Flags.print_emacs || not !Flags.batch_mode then `Yes
+  else `No
+
+let async_proofs_workers_extra_env = ref [||]
+
+type ast = { verbose : bool; loc : Loc.t; mutable expr : vernac_expr }
+let pr_ast { expr } = pr_vernac expr
+
+(* Wrapper for Vernacentries.interp to set the feedback id *)
+let vernac_interp ?proof id ?route { verbose; loc; expr } =
+  let rec internal_command = function
+    | VernacResetName _ | VernacResetInitial | VernacBack _
+    | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _
+    | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true
+    | VernacTime el -> List.for_all (fun (_,e) -> internal_command e) el
+    | _ -> false in
+  if internal_command expr then begin
+    prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr))
+  end else begin
+    set_id_for_feedback ?route (Feedback.State id);
+    Aux_file.record_in_aux_set_at loc;
+    prerr_endline ("interpreting " ^ string_of_ppcmds(pr_vernac expr));
+    try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr))
+    with e ->
+      let e = Errors.push e in
+      iraise Hooks.(call_process_error_once e)
+  end
+
+(* Wrapper for Vernac.parse_sentence to set the feedback id *)
+let vernac_parse ?newtip ?route eid s =
+  let feedback_id = 
+    if Option.is_empty newtip then Feedback.Edit eid
+    else Feedback.State (Option.get newtip) in
+  set_id_for_feedback ?route feedback_id;
+  let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+  Flags.with_option Flags.we_are_parsing (fun () ->
+    try
+      match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
+      | None -> raise (Invalid_argument "vernac_parse")
+      | Some ast -> ast
+    with e when Errors.noncritical e ->
+      let (e, info) = Errors.push e in
+      let loc = Option.default Loc.ghost (Loc.get_loc info) in
+      Hooks.(call parse_error feedback_id loc (iprint (e, info)));
+      iraise (e, info))
+  ()
+
+let pr_open_cur_subgoals () =
+  try Printer.pr_open_subgoals ()
+  with Proof_global.NoCurrentProof -> str""
+
+module Vcs_ = Vcs.Make(Stateid)
+type future_proof = Proof_global.closed_proof_output Future.computation
+type proof_mode = string
+type depth = int
+type cancel_switch = bool ref
+type branch_type =
+  [ `Master
+  | `Proof of proof_mode * depth
+  | `Edit of proof_mode * Stateid.t * Stateid.t ]
+type cmd_t = {
+  cast : ast;
+  cids : Id.t list;
+  cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] }
+type fork_t = ast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list
+type qed_t = {
+  qast : ast;
+  keep : vernac_qed_type;
+  mutable fproof : (future_proof * cancel_switch) option;
+  brname : Vcs_.Branch.t;
+  brinfo : branch_type Vcs_.branch_info
+}
+type seff_t = ast option
+type alias_t = Stateid.t
+type transaction =
+  | Cmd    of cmd_t
+  | Fork   of fork_t
+  | Qed    of qed_t
+  | Sideff of seff_t
+  | Alias  of alias_t
+  | Noop
+type step =
+  [ `Cmd    of cmd_t
+  | `Fork   of fork_t * Stateid.t option
+  | `Qed    of qed_t * Stateid.t
+  | `Sideff of [ `Ast of ast * Stateid.t | `Id of Stateid.t ]
+  | `Alias  of alias_t ]
+type visit = { step : step; next : Stateid.t }
+
+type state = {
+  system : States.state;
+  proof : Proof_global.state;
+  shallow : bool
+}
+type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info
+type backup = { mine : branch; others : branch list }
+type 'vcs state_info = { (* Make private *)
+  mutable n_reached : int;
+  mutable n_goals : int;
+  mutable state : state option;
+  mutable vcs_backup : 'vcs option * backup option;
+}
+let default_info () =
+  { n_reached = 0; n_goals = 0; state = None; vcs_backup = None,None }
+
+(* Functions that work on a Vcs with a specific branch type *)
+module Vcs_aux : sig
+
+  val proof_nesting : (branch_type, 't,'i) Vcs_.t -> int
+  val find_proof_at_depth :
+    (branch_type, 't, 'i) Vcs_.t -> int ->
+      Vcs_.Branch.t * branch_type Vcs_.branch_info
+  exception Expired
+  val visit : (branch_type, transaction,'i) Vcs_.t -> Vcs_.Dag.node -> visit
+
+end = struct (* {{{ *)
+
+  let proof_nesting vcs =
+    List.fold_left max 0
+      (List.map_filter
+        (function
+         | { Vcs_.kind = `Proof (_,n) } -> Some n
+         | { Vcs_.kind = `Edit _ } -> Some 1
+         | _ -> None)
+        (List.map (Vcs_.get_branch vcs) (Vcs_.branches vcs)))
+
+  let find_proof_at_depth vcs pl =
+    try List.find (function
+          | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl
+          | _, { Vcs_.kind = `Edit _ } -> anomaly(str"find_proof_at_depth")
+          | _ -> false)
+        (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs))
+    with Not_found -> failwith "find_proof_at_depth"
+
+  exception Expired
+  let visit vcs id =
+    if Stateid.equal id Stateid.initial then
+      anomaly(str"Visiting the initial state id")
+    else if Stateid.equal id Stateid.dummy then
+      anomaly(str"Visiting the dummy state id")
+    else
+    try
+      match Vcs_.Dag.from_node (Vcs_.dag vcs) id with
+      | [n, Cmd x] -> { step = `Cmd x; next = n }
+      | [n, Alias x] -> { step = `Alias x; next = n }
+      | [n, Fork x] -> { step = `Fork (x,None); next = n }
+      | [n, Fork x; p, Noop] -> { step = `Fork (x,Some p); next = n }
+      | [p, Noop; n, Fork x] -> { step = `Fork (x,Some p); next = n }
+      | [n, Qed x; p, Noop]
+      | [p, Noop; n, Qed x] -> { step = `Qed (x,p); next = n }
+      | [n, Sideff None; p, Noop]
+      | [p, Noop; n, Sideff None]-> { step = `Sideff (`Id p); next = n }
+      | [n, Sideff (Some x); p, Noop]
+      | [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n }
+      | [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n}
+      | _ -> anomaly (str ("Malformed VCS at node "^Stateid.to_string id))
+    with Not_found -> raise Expired
+
+end (* }}} *)
+
+(*************************** THE DOCUMENT *************************************)
+(******************************************************************************)
+
+(* Imperative wrap around VCS to obtain _the_ VCS that is the
+ * representation of the document Coq is currently processing *)
+module VCS : sig
+
+  exception Expired
+
+  module Branch : (module type of Vcs_.Branch with type t = Vcs_.Branch.t)
+  type id = Stateid.t
+  type 'branch_type branch_info = 'branch_type Vcs_.branch_info = {
+    kind : [> `Master] as 'branch_type;
+    root : id;
+    pos  : id;
+  }
+
+  type vcs = (branch_type, transaction, vcs state_info) Vcs_.t
+
+  val init : id -> unit
+
+  val current_branch : unit -> Branch.t
+  val checkout : Branch.t -> unit
+  val branches : unit -> Branch.t list
+  val get_branch : Branch.t -> branch_type branch_info
+  val get_branch_pos : Branch.t -> id
+  val new_node : ?id:Stateid.t -> unit -> id
+  val merge : id -> ours:transaction -> ?into:Branch.t -> Branch.t -> unit
+  val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit
+  val delete_branch : Branch.t -> unit
+  val commit : id -> transaction -> unit
+  val mk_branch_name : ast -> Branch.t
+  val edit_branch : Branch.t
+  val branch : ?root:id -> ?pos:id -> Branch.t -> branch_type -> unit
+  val reset_branch : Branch.t -> id -> unit
+  val reachable : id -> Vcs_.NodeSet.t
+  val cur_tip : unit -> id
+
+  val get_info : id -> vcs state_info
+  val reached : id -> bool -> unit
+  val goals : id -> int -> unit
+  val set_state : id -> state -> unit
+  val get_state : id -> state option
+
+  (* cuts from start -> stop, raising Expired if some nodes are not there *)
+  val slice : start:id -> stop:id -> vcs
+  val nodes_in_slice : start:id -> stop:id -> Stateid.t list
+  
+  val create_cluster : id list -> qed:id -> start:id -> unit
+  val cluster_of : id -> (id * id) option
+  val delete_cluster_of : id -> unit
+
+  val proof_nesting : unit -> int
+  val checkout_shallowest_proof_branch : unit -> unit
+  val propagate_sideff : ast option -> unit
+
+  val gc : unit -> unit
+
+  val visit : id -> visit
+
+  val print : ?now:bool -> unit -> unit
+
+  val backup : unit -> vcs
+  val restore : vcs -> unit
+
+end = struct (* {{{ *)
+
+  include Vcs_
+  exception Expired = Vcs_aux.Expired
+
+  module StateidSet = Set.Make(Stateid)
+  open Printf
+
+  let print_dag vcs () =
+    let fname =
+      "stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in
+    let string_of_transaction = function
+      | Cmd { cast = t } | Fork (t, _,_,_) ->
+          (try string_of_ppcmds (pr_ast t) with _ -> "ERR")
+      | Sideff (Some t) ->
+          sprintf "Sideff(%s)"
+            (try string_of_ppcmds (pr_ast t) with _ -> "ERR")
+      | Sideff None -> "EnvChange"
+      | Noop -> " "
+      | Alias id -> sprintf "Alias(%s)" (Stateid.to_string id)
+      | Qed { qast } -> string_of_ppcmds (pr_ast qast) in
+    let is_green id = 
+      match get_info vcs id with
+      | Some { state = Some _ } -> true
+      | _ -> false in
+    let is_red id =
+      match get_info vcs id with
+      | Some s -> Int.equal s.n_reached ~-1
+      | _ -> false in
+    let head = current_branch vcs in
+    let heads =
+      List.map (fun x -> x, (get_branch vcs x).pos) (branches vcs) in
+    let graph = dag vcs in
+    let quote s =
+      Str.global_replace (Str.regexp "\n") "<BR/>"
+       (Str.global_replace (Str.regexp "<") "&lt;"
+        (Str.global_replace (Str.regexp ">") "&gt;"
+         (Str.global_replace (Str.regexp "\"") "&quot;"
+          (Str.global_replace (Str.regexp "&") "&amp;"
+           (String.sub s 0 (min (String.length s) 20)))))) in
+    let fname_dot, fname_ps =
+      let f = "/tmp/" ^ Filename.basename fname in
+      f ^ ".dot", f ^ ".pdf" in
+    let node id = "s" ^ Stateid.to_string id in
+    let edge tr =
+      sprintf "<<FONT POINT-SIZE=\"12\" FACE=\"sans\">%s</FONT>>"
+        (quote (string_of_transaction tr)) in
+    let ids = ref StateidSet.empty in
+    let clus = Hashtbl.create 13 in
+    let node_info id =
+      match get_info vcs id with
+      | None -> ""
+      | Some info ->
+          sprintf "<<FONT POINT-SIZE=\"12\">%s</FONT>" (Stateid.to_string id) ^
+          sprintf " <FONT POINT-SIZE=\"11\">r:%d g:%d</FONT>>"
+            info.n_reached info.n_goals in
+    let color id =
+      if is_red id then "red" else if is_green id then "green" else "white" in
+    let nodefmt oc id =
+      fprintf oc "%s [label=%s,style=filled,fillcolor=%s];\n"
+        (node id) (node_info id) (color id) in
+    let add_to_clus_or_ids from cf =
+      match cf with
+      | None -> ids := StateidSet.add from !ids; false
+      | Some c -> Hashtbl.replace clus c
+         (try let n = Hashtbl.find clus c in from::n
+         with Not_found -> [from]); true in
+    let oc = open_out fname_dot in
+    output_string oc "digraph states {\nsplines=ortho\n";
+    Dag.iter graph (fun from cf _ l ->
+      let c1 = add_to_clus_or_ids from cf in
+      List.iter (fun (dest, trans) ->
+       let c2 = add_to_clus_or_ids dest (Dag.cluster_of graph dest) in
+       fprintf oc "%s -> %s [xlabel=%s,labelfloat=%b];\n"
+           (node from) (node dest) (edge trans) (c1 && c2)) l
+    );
+    StateidSet.iter (nodefmt oc) !ids;
+    Hashtbl.iter (fun c nodes ->
+       fprintf oc "subgraph cluster_%s {\n" (Dag.Cluster.to_string c);
+       List.iter (nodefmt oc) nodes;
+       fprintf oc "color=blue; }\n"
+    ) clus;
+    List.iteri (fun i (b,id) ->
+      let shape = if Branch.equal head b then "box3d" else "box" in
+      fprintf oc "b%d -> %s;\n" i (node id);
+      fprintf oc "b%d [shape=%s,label=\"%s\"];\n" i shape
+        (Branch.to_string b);
+    ) heads;
+    output_string oc "}\n";
+    close_out oc;
+    ignore(Sys.command
+      ("dot -Tpdf -Gcharset=latin1 " ^ fname_dot ^ " -o" ^ fname_ps))
+
+  type vcs = (branch_type, transaction, vcs state_info) t
+  let vcs : vcs ref = ref (empty Stateid.dummy)
+
+  let init id =
+    vcs := empty id;
+    vcs := set_info !vcs id (default_info ())
+
+  let current_branch () = current_branch !vcs
+
+  let checkout head = vcs := checkout !vcs head
+  let branches () = branches !vcs
+  let get_branch head = get_branch !vcs head
+  let get_branch_pos head = (get_branch head).pos
+  let new_node ?(id=Stateid.fresh ()) () =
+    assert(Vcs_.get_info !vcs id = None);
+    vcs := set_info !vcs id (default_info ());
+    id
+  let merge id ~ours ?into branch =
+    vcs := merge !vcs id ~ours ~theirs:Noop ?into branch
+  let delete_branch branch = vcs := delete_branch !vcs branch
+  let reset_branch branch id = vcs := reset_branch !vcs branch id
+  let commit id t = vcs := commit !vcs id t
+  let rewrite_merge id ~ours ~at branch =
+    vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch
+  let reachable id = reachable !vcs id
+  let mk_branch_name { expr = x } = Branch.make
+    (match x with
+    | VernacDefinition (_,(_,i),_) -> string_of_id i
+    | VernacStartTheoremProof (_,[Some (_,i),_],_) -> string_of_id i
+    | _ -> "branch")
+  let edit_branch = Branch.make "edit"
+  let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind
+  let get_info id =
+    match get_info !vcs id with
+    | Some x -> x
+    | None -> raise Vcs_aux.Expired
+  let set_state id s =
+    (get_info id).state <- Some s;
+    if Flags.async_proofs_is_master () then Hooks.(call state_ready id)
+  let get_state id = (get_info id).state
+  let reached id b =
+    let info = get_info id in
+    if b then info.n_reached <- info.n_reached + 1
+    else info.n_reached <- -1
+  let goals id n = (get_info id).n_goals <- n
+  let cur_tip () = get_branch_pos (current_branch ())
+
+  let proof_nesting () = Vcs_aux.proof_nesting !vcs
+
+  let checkout_shallowest_proof_branch () =
+    if List.mem edit_branch (Vcs_.branches !vcs) then begin
+      checkout edit_branch;
+      match get_branch edit_branch with
+      | { kind = `Edit (mode, _, _) } -> Proof_global.activate_proof_mode mode
+      | _ -> assert false
+    end else
+      let pl = proof_nesting () in
+      try
+        let branch, mode = match Vcs_aux.find_proof_at_depth !vcs pl with
+          | h, { Vcs_.kind = `Proof (m, _) } -> h, m | _ -> assert false in
+        checkout branch;
+        prerr_endline ("mode:" ^ mode);
+        Proof_global.activate_proof_mode mode
+      with Failure _ ->
+        checkout Branch.master;
+        Proof_global.disactivate_proof_mode "Classic"
+
+  (* copies the transaction on every open branch *)
+  let propagate_sideff t =
+    List.iter (fun b ->
+      checkout b;
+      let id = new_node () in
+      merge id ~ours:(Sideff t) ~into:b Branch.master)
+    (List.filter (fun b -> not (Branch.equal b Branch.master)) (branches ()))
+  
+  let visit id = Vcs_aux.visit !vcs id
+
+  let nodes_in_slice ~start ~stop =
+    let rec aux id =
+      if Stateid.equal id start then [] else
+      match visit id with
+      | { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n
+      | { next = n; step = `Alias x } -> (id,Alias x) :: aux n
+      | { next = n; step = `Sideff (`Ast (x,_)) } ->
+           (id,Sideff (Some x)) :: aux n
+      | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string start ^
+                         " to "^Stateid.to_string stop))
+    in aux stop
+
+  let slice ~start ~stop =
+    let l = nodes_in_slice ~start ~stop in
+    let copy_info v id =
+      Vcs_.set_info v id
+        { (get_info id) with state = None; vcs_backup = None,None } in
+    let copy_info_w_state v id =
+      Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in
+    let v = Vcs_.empty start in
+    let v = copy_info v start in
+    let v = List.fold_right (fun (id,tr) v ->
+      let v = Vcs_.commit v id tr in
+      let v = copy_info v id in
+      v) l v in
+    (* Stm should have reached the beginning of proof *)
+    assert (not (Option.is_empty (get_info start).state));
+    (* We put in the new dag the most recent state known to master *)
+    let rec fill id =
+      if (get_info id).state = None then fill (Vcs_aux.visit v id).next
+      else copy_info_w_state v id in
+    fill stop
+
+  let nodes_in_slice ~start ~stop =
+    List.rev (List.map fst (nodes_in_slice ~start ~stop))
+
+  let create_cluster l ~qed ~start = vcs := create_cluster !vcs l (qed,start)
+  let cluster_of id = Option.map Dag.Cluster.data (cluster_of !vcs id)
+  let delete_cluster_of id =
+    Option.iter (fun x -> vcs := delete_cluster !vcs x) (Vcs_.cluster_of !vcs id)
+
+  let gc () =
+    let old_vcs = !vcs in
+    let new_vcs, erased_nodes = gc old_vcs in
+    Vcs_.NodeSet.iter (fun id ->
+        match (Vcs_aux.visit old_vcs id).step with
+        | `Qed ({ fproof = Some (_, cancel_switch) }, _)
+        | `Cmd { cqueue = `TacQueue cancel_switch }
+        | `Cmd { cqueue = `QueryQueue cancel_switch } ->
+             cancel_switch := true
+        | _ -> ())
+      erased_nodes;
+    vcs := new_vcs
+
+  module NB : sig (* Non blocking Sys.command *)
+
+    val command : now:bool -> (unit -> unit) -> unit
+
+  end = struct
+    
+    let m = Mutex.create ()
+    let c = Condition.create ()
+    let job = ref None
+    let worker = ref None
+
+    let set_last_job j =
+      Mutex.lock m;
+      job := Some j;
+      Condition.signal c;
+      Mutex.unlock m
+
+    let get_last_job () =
+      Mutex.lock m;
+      while Option.is_empty !job do Condition.wait c m; done;
+      match !job with
+      | None -> assert false
+      | Some x -> job := None; Mutex.unlock m; x
+
+    let run_command () =
+      try while true do get_last_job () () done
+      with e -> () (* No failure *)
+
+    let command ~now job =
+      if now then job ()
+      else begin
+        set_last_job job;
+        if Option.is_empty !worker then
+          worker := Some (Thread.create run_command ())
+      end
+
+  end
+
+  let print ?(now=false) () =
+    if not !Flags.debug && not now then () else NB.command ~now (print_dag !vcs)
+
+  let backup () = !vcs
+  let restore v = vcs := v
+
+end (* }}} *)
+
+let state_of_id id =
+  try `Valid (VCS.get_info id).state
+  with VCS.Expired -> `Expired
+
+
+(****** A cache: fills in the nodes of the VCS document with their value ******)
+module State : sig
+  
+  (** The function is from unit, so it uses the current state to define
+      a new one.  I.e. one may been to install the right state before
+      defining a new one.
+      Warning: an optimization in installed_cached requires that state
+      modifying functions are always executed using this wrapper. *)
+  val define :
+    ?safe_id:Stateid.t ->
+    ?redefine:bool -> ?cache:Summary.marshallable ->
+    ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit
+
+  val install_cached : Stateid.t -> unit
+  val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool
+
+
+  val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn
+  (* to send states across worker/master *)
+  type frozen_state
+  val get_cached : Stateid.t -> frozen_state
+  val same_env : frozen_state -> frozen_state -> bool
+  type partial_state =
+    [ `Full of frozen_state | `Proof of Stateid.t * Proof_global.state ]
+  val proof_part_of_frozen : frozen_state -> Proof_global.state
+  val assign : Stateid.t -> partial_state -> unit
+
+end = struct (* {{{ *)
+
+  (* cur_id holds Stateid.dummy in case the last attempt to define a state
+   * failed, so the global state may contain garbage *)
+  let cur_id = ref Stateid.dummy
+
+  (* helpers *)
+  let freeze_global_state marshallable =
+    { system = States.freeze ~marshallable;
+      proof = Proof_global.freeze ~marshallable;
+      shallow = (marshallable = `Shallow) }
+  let unfreeze_global_state { system; proof } =
+    States.unfreeze system; Proof_global.unfreeze proof
+
+  (* hack to make futures functional *)
+  let in_t, out_t = Dyn.create "state4future"
+  let () = Future.set_freeze
+    (fun () -> in_t (freeze_global_state `No, !cur_id))
+    (fun t -> let s,i = out_t t in unfreeze_global_state s; cur_id := i)
+  
+  type frozen_state = state
+  type partial_state =
+    [ `Full of frozen_state | `Proof of Stateid.t * Proof_global.state ]
+  let proof_part_of_frozen { proof } = proof
+
+  let freeze marhallable id = VCS.set_state id (freeze_global_state marhallable)
+
+  let is_cached ?(cache=`No) id =
+    if Stateid.equal id !cur_id then
+      try match VCS.get_info id with
+        | { state = None } when cache = `Yes -> freeze `No id; true
+        | { state = None } when cache = `Shallow -> freeze `Shallow id; true
+        | _ -> true
+      with VCS.Expired -> false
+    else
+      try match VCS.get_info id with
+        | { state = Some _ } -> true
+        | _ -> false 
+      with VCS.Expired -> false
+
+  let install_cached id =
+    if Stateid.equal id !cur_id then () else (* optimization *)
+    let s =
+      match VCS.get_info id with
+      | { state = Some s } -> s
+      | _ -> anomaly (str "unfreezing a non existing state") in
+    unfreeze_global_state s; cur_id := id
+
+  let get_cached id =
+    try match VCS.get_info id with
+    | { state = Some s } -> s
+    | _ -> anomaly (str "not a cached state")
+    with VCS.Expired -> anomaly (str "not a cached state (expired)")
+
+  let assign id what =
+    if VCS.get_state id <> None then () else
+    try match what with
+    | `Full s -> VCS.set_state id s
+    | `Proof(ontop,p) ->
+         if is_cached ontop then (
+           VCS.set_state id { (get_cached ontop) with proof = p })
+    with VCS.Expired -> ()
+
+  let exn_on id ?valid (e, info) =
+    match Stateid.get info with
+    | Some _ -> (e, info)
+    | None ->
+        let loc = Option.default Loc.ghost (Loc.get_loc info) in
+        let (e, info) = Hooks.(call_process_error_once (e, info)) in
+        Hooks.(call execution_error id loc (iprint (e, info)));
+        (e, Stateid.add info ?valid id)
+
+  let same_env { system = s1 } { system = s2 } =
+    let s1 = States.summary_of_state s1 in
+    let e1 = Summary.project_summary s1 [Global.global_env_summary_name] in
+    let s2 = States.summary_of_state s2 in
+    let e2 = Summary.project_summary s2 [Global.global_env_summary_name] in
+    Summary.pointer_equal e1 e2
+
+  let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true)
+        f id
+  =
+    feedback ~state_id:id Feedback.(ProcessingIn !Flags.async_proofs_worker_id);
+    let str_id = Stateid.to_string id in
+    if is_cached id && not redefine then
+      anomaly (str"defining state "++str str_id++str" twice");
+    try
+      prerr_endline("defining "^str_id^" (cache="^
+        if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)");
+      f ();
+      if cache = `Yes then freeze `No id
+      else if cache = `Shallow then freeze `Shallow id;
+      prerr_endline ("setting cur id to "^str_id);
+      cur_id := id;
+      if feedback_processed then
+        Hooks.(call state_computed id ~in_cache:false);
+      VCS.reached id true;
+      if Proof_global.there_are_pending_proofs () then
+        VCS.goals id (Proof_global.get_open_goals ());
+    with e ->
+      let (e, info) = Errors.push e in
+      let good_id = !cur_id in
+      cur_id := Stateid.dummy;
+      VCS.reached id false;
+      Hooks.(call unreachable_state id);
+      match Stateid.get info, safe_id with
+      | None, None -> iraise (exn_on id ~valid:good_id (e, info))
+      | None, Some good_id -> iraise (exn_on id ~valid:good_id (e, info))
+      | Some _, None -> iraise (e, info)
+      | Some (_,at), Some id -> iraise (e, Stateid.add info ~valid:id at)
+
+end (* }}} *)
+
+
+(****************************** CRUFT *****************************************)
+(******************************************************************************)
+
+(* The backtrack module simulates the classic behavior of a linear document *)
+module Backtrack : sig
+
+  val record : unit -> unit
+  val backto : Stateid.t -> unit
+  val back_safe : unit -> unit
+
+  (* we could navigate the dag, but this ways easy *)
+  val branches_of : Stateid.t -> backup
+
+  (* To be installed during initialization *)
+  val undo_vernac_classifier : vernac_expr -> vernac_classification
+
+end = struct (* {{{ *)
+
+  let record () =
+    List.iter (fun current_branch ->
+      let mine = current_branch, VCS.get_branch current_branch in
+      let info = VCS.get_info (VCS.get_branch_pos current_branch) in
+      let others =
+        CList.map_filter (fun b ->
+          if Vcs_.Branch.equal b current_branch then None
+          else Some(b, VCS.get_branch b)) (VCS.branches ()) in
+      let backup = if fst info.vcs_backup <> None then fst info.vcs_backup
+        else Some (VCS.backup ()) in
+      let branches = if snd info.vcs_backup <> None then snd info.vcs_backup
+        else Some { mine; others } in
+      info.vcs_backup <- backup, branches)
+    [VCS.current_branch (); VCS.Branch.master]
+
+  let backto oid =
+    let info = VCS.get_info oid in
+    match info.vcs_backup with
+    | None, _ ->
+       anomaly(str"Backtrack.backto "++str(Stateid.to_string oid)++
+               str": a state with no vcs_backup")
+    | Some vcs, _ -> VCS.restore vcs
+
+  let branches_of id =
+    let info = VCS.get_info id in
+    match info.vcs_backup with
+    | _, None ->
+       anomaly(str"Backtrack.branches_of "++str(Stateid.to_string id)++
+               str": a state with no vcs_backup")
+    | _, Some x -> x
+
+  let rec fold_until f acc id =
+    let next acc =
+      if id = Stateid.initial then raise Not_found
+      else fold_until f acc (VCS.visit id).next in
+    let info = VCS.get_info id in
+    match info.vcs_backup with
+    | None, _ -> next acc
+    | Some vcs, _ ->
+        let ids =
+          if id = Stateid.initial || id = Stateid.dummy then [] else
+          match VCS.visit id with
+          | { step = `Fork ((_,_,_,l),_) } -> l
+          | { step = `Cmd { cids = l } } -> l
+          | _ -> [] in
+        match f acc (id, vcs, ids) with
+        | `Stop x -> x
+        | `Cont acc -> next acc
+ 
+  let back_safe () =
+    let id =
+      fold_until (fun n (id,_,_) ->
+        if n >= 0 && State.is_cached id then `Stop id else `Cont (succ n))
+        0 (VCS.get_branch_pos (VCS.current_branch ())) in
+    backto id
+
+  let undo_vernac_classifier v =
+    try
+      match v with
+      | VernacResetInitial ->
+          VtStm (VtBack Stateid.initial, true), VtNow
+      | VernacResetName (_,name) ->
+          msg_warning
+            (str"Reset not implemented for automatically generated constants");
+          let id = VCS.get_branch_pos (VCS.current_branch ()) in
+          (try
+            let oid =
+              fold_until (fun b (id,_,label) ->
+                if b then `Stop id else `Cont (List.mem name label))
+              false id in
+            VtStm (VtBack oid, true), VtNow
+          with Not_found ->
+            VtStm (VtBack id, true), VtNow)
+      | VernacBack n ->
+          let id = VCS.get_branch_pos (VCS.current_branch ()) in
+          let oid = fold_until (fun n (id,_,_) ->
+            if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in
+          VtStm (VtBack oid, true), VtNow
+      | VernacUndo n ->
+          let id = VCS.get_branch_pos (VCS.current_branch ()) in
+          let oid = fold_until (fun n (id,_,_) ->
+            if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in
+          if n = 1 && !Flags.coqtop_ui && not !Flags.batch_mode &&
+             not !Flags.print_emacs then
+           VtStm (VtBack oid, false), VtNow
+          else VtStm (VtBack oid, true), VtLater
+      | VernacUndoTo _
+      | VernacRestart as e ->
+          let m = match e with VernacUndoTo m -> m | _ -> 0 in
+          let id = VCS.get_branch_pos (VCS.current_branch ()) in
+          let vcs =
+            match (VCS.get_info id).vcs_backup with 
+            | None, _ -> anomaly(str"Backtrack: tip with no vcs_backup")
+            | Some vcs, _ -> vcs in
+          let cb, _ =
+            Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) in
+          let n = fold_until (fun n (_,vcs,_) ->
+            if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n)
+            0 id in
+          let oid = fold_until (fun n (id,_,_) ->
+            if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in
+          VtStm (VtBack oid, true), VtLater
+      | VernacAbortAll ->
+          let id = VCS.get_branch_pos (VCS.current_branch ()) in
+          let oid = fold_until (fun () (id,vcs,_) ->
+            match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ())
+            () id in
+          VtStm (VtBack oid, true), VtLater
+      | VernacBacktrack (id,_,_)
+      | VernacBackTo id ->
+          VtStm (VtBack (Stateid.of_int id), not !Flags.print_emacs), VtNow
+      | _ -> VtUnknown, VtNow
+    with
+    | Not_found ->
+       msg_warning(str"undo_vernac_classifier: going back to the initial state.");
+       VtStm (VtBack Stateid.initial, true), VtNow
+
+end (* }}} *)
+
+let hints = ref Aux_file.empty_aux_file
+let set_compilation_hints file =
+  hints := Aux_file.load_aux_file_for file
+let get_hint_ctx loc =
+  let s = Aux_file.get !hints loc "context_used" in
+  let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") s) in
+  let ids = List.map (fun id -> Loc.ghost, id) ids in
+  SsExpr (SsSet ids)
+
+let get_hint_bp_time proof_name =
+  try float_of_string (Aux_file.get !hints Loc.ghost proof_name)
+  with Not_found -> 1.0
+
+let record_pb_time proof_name loc time =
+  let proof_build_time = Printf.sprintf "%.3f" time in
+  Aux_file.record_in_aux_at loc "proof_build_time" proof_build_time;
+  if proof_name <> "" then begin
+    Aux_file.record_in_aux_at Loc.ghost proof_name proof_build_time;
+    hints := Aux_file.set !hints Loc.ghost proof_name proof_build_time
+  end
+ 
+exception RemoteException of std_ppcmds
+let _ = Errors.register_handler (function
+  | RemoteException ppcmd -> ppcmd
+  | _ -> raise Unhandled)
+
+(****************************** THE SCHEDULER *********************************)
+(******************************************************************************)
+
+module rec ProofTask : sig
+ 
+  type competence = Stateid.t list
+  type task_build_proof = {
+    t_exn_info : Stateid.t * Stateid.t;
+    t_start    : Stateid.t;
+    t_stop     : Stateid.t;
+    t_states   : competence;
+    t_assign   : Proof_global.closed_proof_output Future.assignement -> unit;
+    t_loc      : Loc.t;
+    t_uuid     : Future.UUID.t;
+    t_name     : string }
+
+  type task =
+    | BuildProof of task_build_proof
+    | States of Stateid.t list
+
+  type request =
+    | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * competence
+    | ReqStates of Stateid.t list
+
+  include AsyncTaskQueue.Task
+  with type task := task
+  and  type competence := competence
+  and  type request := request
+
+  val build_proof_here :
+    Stateid.t * Stateid.t -> Loc.t -> Stateid.t ->
+      Proof_global.closed_proof_output Future.computation
+   
+end = struct (* {{{ *)
+
+  let forward_feedback msg = Hooks.(call forward_feedback msg)
+
+  type competence = Stateid.t list
+  type task_build_proof = {
+    t_exn_info : Stateid.t * Stateid.t;
+    t_start    : Stateid.t;
+    t_stop     : Stateid.t;
+    t_states   : competence;
+    t_assign   : Proof_global.closed_proof_output Future.assignement -> unit;
+    t_loc      : Loc.t;
+    t_uuid     : Future.UUID.t;
+    t_name     : string }
+
+  type task =
+    | BuildProof of task_build_proof
+    | States of Stateid.t list
+
+  type request =
+    | ReqBuildProof of (Future.UUID.t,VCS.vcs) Stateid.request * competence
+    | ReqStates of Stateid.t list
+  
+  type error = {
+    e_error_at    : Stateid.t;
+    e_safe_id     : Stateid.t;
+    e_msg         : std_ppcmds;
+    e_safe_states : Stateid.t list }
+
+  type response =
+    | RespBuiltProof of Proof_global.closed_proof_output * float
+    | RespError of error
+    | RespStates of (Stateid.t * State.partial_state) list
+    | RespDone
+
+  let name = ref "proofworker"
+  let extra_env () = !async_proofs_workers_extra_env
+
+  let task_match age t =
+    match age, t with
+    | `Fresh, BuildProof _ -> true
+    | `Old my_states, States l ->
+        List.for_all (fun x -> CList.mem_f Stateid.equal x my_states) l
+    | _ -> false
+
+  let name_of_task = function
+    | BuildProof t -> "proof: " ^ t.t_name
+    | States l -> "states: " ^ String.concat "," (List.map Stateid.to_string l)
+  let name_of_request = function
+    | ReqBuildProof(r,_) -> "proof: " ^ r.Stateid.name
+    | ReqStates l -> "states: "^String.concat "," (List.map Stateid.to_string l)
+
+  let request_of_task age = function
+    | States l -> Some (ReqStates l)
+    | BuildProof { t_exn_info;t_start;t_stop;t_loc;t_uuid;t_name;t_states } ->
+        assert(age = `Fresh);
+        try Some (ReqBuildProof ({
+          Stateid.exn_info = t_exn_info;
+          stop = t_stop;
+          document = VCS.slice ~start:t_start ~stop:t_stop;
+          loc = t_loc;
+          uuid = t_uuid;
+          name = t_name }, t_states))
+        with VCS.Expired -> None
+
+  let use_response (s : competence AsyncTaskQueue.worker_status) t r =
+    match s, t, r with
+    | `Old c, States _, RespStates l ->
+        List.iter (fun (id,s) -> State.assign id s) l; `End
+    | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states },
+              RespBuiltProof (pl, time) ->
+        feedback (Feedback.InProgress ~-1);
+        t_assign (`Val pl);
+        record_pb_time t_name t_loc time;
+        if not !Flags.async_proofs_full then `End
+        else `Stay(t_states,[States t_states])
+    | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states },
+            RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } ->
+        feedback (Feedback.InProgress ~-1);
+        let info = Stateid.add ~valid Exninfo.null e_error_at in
+        let e = (RemoteException e_msg, info) in
+        t_assign (`Exn e);
+        `Stay(t_states,[States e_safe_states])
+    | _ -> assert false
+
+  let on_task_cancellation_or_expiration_or_slave_death = function
+    | None -> ()
+    | Some (States _) -> ()
+    | Some (BuildProof { t_start = start; t_assign }) ->
+        let s = "Worker dies or task expired" in
+        let info = Stateid.add ~valid:start Exninfo.null start in
+        let e = (RemoteException (strbrk s), info) in
+        t_assign (`Exn e);
+        Hooks.(call execution_error start Loc.ghost (strbrk s));
+        feedback (Feedback.InProgress ~-1)
+
+  let build_proof_here (id,valid) loc eop =
+    Future.create (State.exn_on id ~valid) (fun () ->
+      let wall_clock1 = Unix.gettimeofday () in
+      if !Flags.batch_mode then Reach.known_state ~cache:`No eop
+      else Reach.known_state ~cache:`Shallow eop;
+      let wall_clock2 = Unix.gettimeofday () in
+      Aux_file.record_in_aux_at loc "proof_build_time"
+        (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
+      Proof_global.return_proof ())
+
+  let perform_buildp { Stateid.exn_info; stop; document; loc } my_states =
+    try
+      VCS.restore document;
+      VCS.print ();
+      let proof, future_proof, time =
+        let wall_clock = Unix.gettimeofday () in
+        let fp = build_proof_here exn_info loc stop in
+        let proof = Future.force fp in
+        proof, fp, Unix.gettimeofday () -. wall_clock in
+      (* We typecheck the proof with the kernel (in the worker) to spot
+       * the few errors tactics don't catch, like the "fix" tactic building
+       * a bad fixpoint *)
+      let fix_exn = Future.fix_exn_of future_proof in
+      let checked_proof = Future.chain ~pure:false future_proof (fun p ->
+        let pobject, _ =
+          Proof_global.close_future_proof stop (Future.from_val ~fix_exn p) in
+        let terminator = (* The one sent by master is an InvalidKey *)
+          Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in
+        vernac_interp stop
+          ~proof:(pobject, terminator)
+          { verbose = false; loc;
+            expr = (VernacEndProof (Proved (true,None))) }) in
+      ignore(Future.join checked_proof);
+      RespBuiltProof(proof,time)
+    with
+    | e when Errors.noncritical e ->
+        let (e, info) = Errors.push e in
+        (* This can happen if the proof is broken.  The error has also been
+         * signalled as a feedback, hence we can silently recover *)
+        let e_error_at, e_safe_id = match Stateid.get info with
+          | Some (safe, err) -> err, safe
+          | None -> Stateid.dummy, Stateid.dummy in
+        let e_msg = iprint (e, info) in
+        prerr_endline "failed with the following exception:";
+        prerr_endline (string_of_ppcmds e_msg);
+        let e_safe_states = List.filter State.is_cached my_states in
+        RespError { e_error_at; e_safe_id; e_msg; e_safe_states }
+  
+  let perform_states query =
+    if query = [] then [] else
+    let initial = 
+      let rec aux id =
+        try match VCS.visit id with { next } -> aux next
+        with VCS.Expired -> id in
+      aux (List.hd query) in
+    let get_state seen id =
+      let prev =
+        try
+          let { next = prev; step } = VCS.visit id in
+          if State.is_cached prev && List.mem prev seen
+          then Some (prev, State.get_cached prev, step)
+          else None
+        with VCS.Expired -> None in
+      let this = 
+        if State.is_cached id then Some (State.get_cached id) else None in
+      match prev, this with
+      | _, None -> None
+      | Some (prev, o, `Cmd { cast = { expr = VernacSolve _ }}), Some n
+        when State.same_env o n -> (* A pure tactic *)
+          Some (id, `Proof (prev, State.proof_part_of_frozen n))
+      | Some _, Some s ->
+          msg_warning (str "Sending back a fat state");
+          Some (id, `Full s)
+      | _, Some s -> Some (id, `Full s) in
+    let rec aux seen = function
+      | [] -> []
+      | id :: rest ->
+          match get_state seen id with
+          | None -> aux seen rest
+          | Some stuff -> stuff :: aux (id :: seen) rest in
+    aux [initial] query
+
+  let perform = function
+    | ReqBuildProof (bp,states) -> perform_buildp bp states
+    | ReqStates sl -> RespStates (perform_states sl)
+
+  let on_marshal_error s = function
+    | States _ -> msg_error(strbrk("Marshalling error: "^s^". "^
+        "The system state could not be sent to the master process."))
+    | BuildProof { t_exn_info; t_stop; t_assign; t_loc } ->
+      msg_error(strbrk("Marshalling error: "^s^". "^
+        "The system state could not be sent to the worker process. "^
+        "Falling back to local, lazy, evaluation."));
+      t_assign(`Comp(build_proof_here t_exn_info t_loc t_stop));
+      feedback (Feedback.InProgress ~-1)
+
+end (* }}} *)
+
+(* Slave processes (if initialized, otherwise local lazy evaluation) *)
+and Slaves : sig
+
+  (* (eventually) remote calls *)
+  val build_proof : loc:Loc.t ->
+    exn_info:(Stateid.t * Stateid.t) -> start:Stateid.t -> stop:Stateid.t ->
+      name:string -> future_proof * cancel_switch
+
+  (* blocking function that waits for the task queue to be empty *)
+  val wait_all_done : unit -> unit
+  
+  (* initialize the whole machinery (optional) *)
+  val init : unit -> unit
+
+  type 'a tasks = ('a,VCS.vcs) Stateid.request list
+  val dump_snapshot : unit -> Future.UUID.t tasks
+  val check_task : string -> int tasks -> int -> bool
+  val info_tasks : 'a tasks -> (string * float * int) list
+  val finish_task :
+    string ->
+    Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs ->
+    int tasks -> int -> Library.seg_univ
+
+  val cancel_worker : WorkerPool.worker_id -> unit
+
+  val reset_task_queue : unit -> unit
+
+  val set_perspective : Stateid.t list -> unit
+
+end = struct (* {{{ *)
+
+  module TaskQueue = AsyncTaskQueue.MakeQueue(ProofTask)
+  
+  let queue = ref None
+
+  let init () =
+    if Flags.async_proofs_is_master () then
+      queue := Some (TaskQueue.create !Flags.async_proofs_n_workers)
+    else
+      queue := Some (TaskQueue.create 0)
+
+  let check_task_aux extra name l i =
+    let { Stateid.stop; document; loc; name = r_name } = List.nth l i in
+    msg_info(
+      str(Printf.sprintf "Checking task %d (%s%s) of %s" i r_name extra name));
+    VCS.restore document;
+    let start =
+      let rec aux cur =
+        try aux (VCS.visit cur).next
+        with VCS.Expired -> cur in
+      aux stop in
+    try
+      Reach.known_state ~cache:`No stop;
+      (* The original terminator, a hook, has not been saved in the .vio*)
+      Proof_global.set_terminator
+        (Lemmas.standard_proof_terminator []
+          (Lemmas.mk_hook (fun _ _ -> ())));
+      let proof =
+        Proof_global.close_proof ~keep_body_ucst_sepatate:true (fun x -> x) in
+      (* We jump at the beginning since the kernel handles side effects by also
+       * looking at the ones that happen to be present in the current env *)
+      Reach.known_state ~cache:`No start;
+      vernac_interp stop ~proof
+        { verbose = false; loc;
+          expr = (VernacEndProof (Proved (true,None))) };
+      Some proof
+    with e ->
+      let (e, info) = Errors.push e in
+      (try match Stateid.get info with
+      | None ->
+          pperrnl (
+            str"File " ++ str name ++ str ": proof of " ++ str r_name ++
+            spc () ++ iprint (e, info))
+      | Some (_, cur) ->
+          match VCS.visit cur with
+          | { step = `Cmd { cast = { loc } } }
+          | { step = `Fork (( { loc }, _, _, _), _) } 
+          | { step = `Qed ( { qast = { loc } }, _) } 
+          | { step = `Sideff (`Ast ( { loc }, _)) } ->
+              let start, stop = Loc.unloc loc in
+              pperrnl (
+                str"File " ++ str name ++ str ": proof of " ++ str r_name ++
+                str ": chars " ++ int start ++ str "-" ++ int stop ++
+                spc () ++ iprint (e, info))
+          | _ ->
+              pperrnl (
+                str"File " ++ str name ++ str ": proof of " ++ str r_name ++
+                spc () ++ iprint (e, info))
+    with e ->
+      msg_error (str"unable to print error message: " ++
+                    str (Printexc.to_string e))); None
+
+  let finish_task name (u,cst,_) d p l i =
+    let bucket = (List.nth l i).Stateid.uuid in
+    match check_task_aux (Printf.sprintf ", bucket %d" bucket) name l i with
+    | None -> exit 1
+    | Some (po,_) ->
+        let discharge c = List.fold_right Cooking.cook_constr d.(bucket) c in
+        let con =
+          Nametab.locate_constant
+            (Libnames.qualid_of_ident po.Proof_global.id) in
+        let c = Global.lookup_constant con in
+        let o = match c.Declarations.const_body with
+          | Declarations.OpaqueDef o -> o
+          | _ -> assert false in
+        let uc =
+          Option.get
+            (Opaqueproof.get_constraints (Global.opaque_tables ()) o) in
+        let pr =
+          Future.from_val (Option.get (Global.body_of_constant_body c)) in
+        let uc =
+          Future.chain
+            ~greedy:true ~pure:true uc Univ.hcons_universe_context_set in
+        let pr = Future.chain ~greedy:true ~pure:true pr discharge in
+        let pr = Future.chain ~greedy:true ~pure:true pr Constr.hcons in
+        Future.sink pr;
+        let extra = Future.join uc in
+        u.(bucket) <- uc;
+        p.(bucket) <- pr;
+        u, Univ.ContextSet.union cst extra, false
+  
+  let check_task name l i =
+    match check_task_aux "" name l i with
+    | Some _ -> true
+    | None -> false
+
+  let info_tasks l =
+    CList.map_i (fun i { Stateid.loc; name } ->
+      let time1 =
+        try float_of_string (Aux_file.get !hints loc "proof_build_time")
+        with Not_found -> 0.0 in
+      let time2 =
+        try float_of_string (Aux_file.get !hints loc "proof_check_time")
+        with Not_found -> 0.0 in
+      name, max (time1 +. time2) 0.0001,i) 0 l
+
+  let set_perspective idl =
+    let open Stateid in
+    let open ProofTask in
+    let overlap s1 s2 =
+      List.exists (fun x -> CList.mem_f Stateid.equal x s2) s1 in
+    let overlap_rel s1 s2 =
+      match overlap s1 idl, overlap s2 idl with
+      | true, true | false, false -> 0
+      | true, false -> -1
+      | false, true -> 1 in
+    TaskQueue.set_order (Option.get !queue) (fun task1 task2 ->
+     match task1, task2 with
+     | BuildProof { t_states = s1 },
+       BuildProof { t_states = s2 } -> overlap_rel s1 s2
+     | _ -> 0)
+
+  let build_proof ~loc ~exn_info ~start ~stop ~name:pname =
+    let id, valid as t_exn_info = exn_info in
+    let cancel_switch = ref false in
+    if TaskQueue.n_workers (Option.get !queue) = 0 then
+      if !Flags.compilation_mode = Flags.BuildVio then begin
+        let f,assign =
+          Future.create_delegate ~blocking:true (State.exn_on id ~valid) in
+        let t_uuid = Future.uuid f in
+        let task = ProofTask.(BuildProof {
+          t_exn_info; t_start = start; t_stop = stop;
+          t_assign = assign; t_loc = loc; t_uuid; t_name = pname;
+          t_states = VCS.nodes_in_slice ~start ~stop }) in
+        TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
+        f, cancel_switch
+      end else
+        ProofTask.build_proof_here t_exn_info loc stop, cancel_switch
+    else 
+      let f, t_assign = Future.create_delegate (State.exn_on id ~valid) in
+      let t_uuid = Future.uuid f in
+      feedback (Feedback.InProgress 1);
+      let task = ProofTask.(BuildProof {
+        t_exn_info; t_start = start; t_stop = stop; t_assign;
+        t_loc = loc; t_uuid; t_name = pname;
+        t_states = VCS.nodes_in_slice ~start ~stop }) in
+      TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch);
+      f, cancel_switch
+
+  let wait_all_done () = TaskQueue.join (Option.get !queue)
+
+  let cancel_worker n = TaskQueue.cancel_worker (Option.get !queue) n
+
+  (* For external users this name is nicer than request *)
+  type 'a tasks = ('a,VCS.vcs) Stateid.request list
+  let dump_snapshot () =
+    let tasks = TaskQueue.snapshot (Option.get !queue) in
+    let reqs =
+      CList.map_filter
+        ProofTask.(fun x ->
+             match request_of_task `Fresh x with
+             | Some (ReqBuildProof (r, _)) -> Some r
+             | _ -> None)
+        tasks in
+    prerr_endline (Printf.sprintf "dumping %d tasks\n" (List.length reqs));
+    reqs
+
+  let reset_task_queue () = TaskQueue.clear (Option.get !queue)
+
+end (* }}} *)
+
+and TacTask : sig
+
+  type output = Constr.constr * Evd.evar_universe_context
+  type task = {
+    t_state    : Stateid.t;
+    t_state_fb : Stateid.t;
+    t_assign   : output Future.assignement -> unit;
+    t_ast      : ast;
+    t_goal     : Goal.goal;
+    t_kill     : unit -> unit;
+    t_name     : string }  
+
+  include AsyncTaskQueue.Task with type task := task
+
+end = struct (* {{{ *)
+
+  type output = Constr.constr * Evd.evar_universe_context
+  
+  let forward_feedback msg = Hooks.(call forward_feedback msg)
+
+  type task = {
+    t_state    : Stateid.t;
+    t_state_fb : Stateid.t;
+    t_assign   : output Future.assignement -> unit;
+    t_ast      : ast;
+    t_goal     : Goal.goal;
+    t_kill     : unit -> unit;
+    t_name     : string }  
+
+  type request = {
+    r_state    : Stateid.t;
+    r_state_fb : Stateid.t;
+    r_document : VCS.vcs option;
+    r_ast      : ast;
+    r_goal     : Goal.goal;
+    r_name     : string }
+
+  type response =
+    | RespBuiltSubProof of output
+    | RespError of std_ppcmds
+
+  let name = ref "tacworker"
+  let extra_env () = [||]
+  type competence = unit
+  let task_match _ _ = true
+
+  (* run by the master, on a thread *)
+  let request_of_task age { t_state; t_state_fb; t_ast; t_goal; t_name } =
+    try Some {
+      r_state    = t_state;
+      r_state_fb = t_state_fb;
+      r_document =
+        if age <> `Fresh then None
+        else Some (VCS.slice ~start:t_state ~stop:t_state);
+      r_ast      = t_ast;
+      r_goal     = t_goal;
+      r_name     = t_name }
+    with VCS.Expired -> None
+          
+  let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp =
+    match resp with
+    | RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[])
+    | RespError msg ->
+        let info = Stateid.add ~valid:t_state Exninfo.null t_state_fb in
+        let e = (RemoteException msg, info) in
+        t_assign (`Exn e);
+        t_kill ();
+        `Stay ((),[])
+                    
+  let on_marshal_error err { t_name } =
+    pr_err ("Fatal marshal error: " ^ t_name );
+    flush_all (); exit 1
+
+  let on_task_cancellation_or_expiration_or_slave_death = function
+    | Some { t_kill } -> t_kill ()
+    | _ -> ()
+ 
+  let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } =
+    Option.iter VCS.restore vcs;
+    try
+      Reach.known_state ~cache:`No id;
+      let t, uc = Future.purify (fun () ->
+        vernac_interp r_state_fb r_ast;
+        let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in
+        match Evd.(evar_body (find sigma r_goal)) with
+        | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress")
+        | Evd.Evar_defined t ->
+            let t = Evarutil.nf_evar sigma t in
+            if Evarutil.is_ground_term sigma t then
+              t, Evd.evar_universe_context sigma
+            else Errors.errorlabstrm "Stm" (str"The solution is not ground"))
+        () in
+      RespBuiltSubProof (t,uc) 
+    with e when Errors.noncritical e -> RespError (Errors.print e)
+
+  let name_of_task { t_name } = t_name
+  let name_of_request { r_name } = r_name
+  
+end (* }}} *)
+
+and Partac : sig
+
+  val vernac_interp :
+    cancel_switch -> int -> Stateid.t -> Stateid.t -> ast -> unit
+
+end = struct (* {{{ *)
+    
+  module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask)
+
+  let vernac_interp cancel nworkers safe_id id { verbose; loc; expr = e } =
+    let e, etac, time, fail =
+      let rec find time fail = function
+        | VernacSolve(_,_,re,b) -> re, b, time, fail
+        | VernacTime [_,e] -> find true fail e
+        | VernacFail e -> find time true e
+        | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in
+    Hooks.call Hooks.with_fail fail (fun () ->
+    (if time then System.with_time false else (fun x -> x)) (fun () ->
+    ignore(TaskQueue.with_n_workers nworkers (fun queue ->
+    Proof_global.with_current_proof (fun _ p ->
+      let goals, _, _, _, _ = Proof.proof p in
+      let open TacTask in
+      let res = CList.map_i (fun i g ->
+        let f,assign= Future.create_delegate (State.exn_on id ~valid:safe_id) in
+        let t_ast =
+          { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in
+        let t_name = Goal.uid g in
+        TaskQueue.enqueue_task queue
+          ({ t_state = safe_id; t_state_fb = id;
+            t_assign = assign; t_ast; t_goal = g; t_name;
+            t_kill = (fun () -> TaskQueue.cancel_all queue) }, cancel);
+        Goal.uid g,f)
+        1 goals in
+      TaskQueue.join queue;
+      let assign_tac : unit Proofview.tactic =
+        Proofview.V82.tactic (fun gl ->
+          let open Tacmach in
+          let sigma, g = project gl, sig_it gl in
+          let gid = Goal.uid g in
+          let f =
+            try List.assoc gid res
+            with Not_found -> Errors.anomaly(str"Partac: wrong focus") in
+          if Future.is_over f then
+            let pt, uc = Future.join f in
+            prerr_endline (string_of_ppcmds(hov 0 (
+              str"g=" ++ str gid ++ spc () ++
+              str"t=" ++ (Printer.pr_constr pt) ++ spc () ++
+              str"uc=" ++ Evd.pr_evar_universe_context uc)));
+            let sigma = Goal.V82.partial_solution sigma g pt in
+            let sigma = Evd.merge_universe_context sigma uc in
+            re_sig [] sigma
+          else (* One has failed and cancelled the others, but not this one *)
+            re_sig [g] sigma) in
+      Proof.run_tactic (Global.env()) assign_tac p)))) ())
+  
+end (* }}} *)
+
+and QueryTask : sig
+
+  type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast }
+  include AsyncTaskQueue.Task with type task := task
+
+end = struct (* {{{ *)
+  
+  type task =
+    { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast }
+  
+  type request =
+    { r_where : Stateid.t ; r_for : Stateid.t ; r_what : ast; r_doc : VCS.vcs }
+  type response = unit
+
+  let name = ref "queryworker"
+  let extra_env _ = [||]
+  type competence = unit
+  let task_match _ _ = true
+
+  let request_of_task _ { t_where; t_what; t_for } =
+    try Some {
+      r_where = t_where;
+      r_for   = t_for;
+      r_doc   = VCS.slice ~start:t_where ~stop:t_where;
+      r_what  = t_what }
+    with VCS.Expired -> None
+  
+  let use_response _ _ _ = `End
+
+  let on_marshal_error _ _ =
+    pr_err ("Fatal marshal error in query");
+    flush_all (); exit 1
+
+  let on_task_cancellation_or_expiration_or_slave_death _ = ()
+  
+  let forward_feedback msg = Hooks.(call forward_feedback msg)
+
+  let perform { r_where; r_doc; r_what; r_for } =
+    VCS.restore r_doc;
+    VCS.print ();
+    Reach.known_state ~cache:`No r_where;
+    try
+      vernac_interp r_for { r_what with verbose = true };
+      feedback ~state_id:r_for Feedback.Processed     
+    with e when Errors.noncritical e ->
+      let msg = string_of_ppcmds (print e) in
+      feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg))
+    
+  let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what)
+  let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what)
+
+end (* }}} *)
+
+and Query : sig 
+
+  val init : unit -> unit
+  val vernac_interp : cancel_switch -> Stateid.t ->  Stateid.t -> ast -> unit
+
+end = struct (* {{{ *)
+
+  module TaskQueue = AsyncTaskQueue.MakeQueue(QueryTask)
+
+  let queue = ref None
+
+  let vernac_interp switch prev id q =
+    assert(TaskQueue.n_workers (Option.get !queue) > 0);
+    TaskQueue.enqueue_task (Option.get !queue)
+      QueryTask.({ QueryTask.t_where = prev; t_for = id; t_what = q }, switch)
+
+  let init () = queue := Some (TaskQueue.create
+    (if !Flags.async_proofs_full then 1 else 0))
+
+end (* }}} *)
+
+(* Runs all transactions needed to reach a state *)
+and Reach : sig
+
+  val known_state :
+    ?redefine_qed:bool -> cache:Summary.marshallable -> Stateid.t -> unit
+
+end = struct (* {{{ *)
+
+let pstate = ["meta counter"; "evar counter"; "program-tcc-table"]
+
+let async_policy () =
+  let open Flags in
+  if interactive () = `Yes then
+    (async_proofs_is_master () || !async_proofs_mode = Flags.APonLazy)
+  else
+    (!compilation_mode = Flags.BuildVio || !async_proofs_mode <> Flags.APoff)
+
+let delegate name =
+  let time = get_hint_bp_time name in
+  time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio
+
+let collect_proof keep cur hd brkind id =
+ prerr_endline ("Collecting proof ending at "^Stateid.to_string id);
+ let no_name = "" in
+ let name = function
+   | [] -> no_name
+   | id :: _ -> Id.to_string id in
+ let loc = (snd cur).loc in
+ let is_defined = function
+   | _, { expr = VernacEndProof (Proved (false,_)) } -> true
+   | _ -> false in
+ let proof_using_ast = function
+   | Some (_, ({ expr = VernacProof(_,Some _) } as v)) -> Some v
+   | _ -> None in
+ let has_proof_using x = proof_using_ast x <> None in
+ let proof_no_using = function
+   | Some (_, ({ expr = VernacProof(t,None) } as v)) -> t,v
+   | _ -> assert false in
+ let has_proof_no_using = function
+   | Some (_, { expr = VernacProof(_,None) }) -> true
+   | _ -> false in
+ let parent = function Some (p, _) -> p | None -> assert false in
+ let rec collect last accn id =
+    let view = VCS.visit id in
+    match view.step with
+    | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next
+    (* An Alias could jump everywhere... we hope we can ignore it*)
+    | `Alias _ -> `Sync (no_name,None,`Alias)
+    | `Fork((_,_,_,_::_::_), _) ->
+        `Sync (no_name,proof_using_ast last,`MutualProofs)
+    | `Fork((_,_,Doesn'tGuaranteeOpacity,_), _) ->
+        `Sync (no_name,proof_using_ast last,`Doesn'tGuaranteeOpacity)
+    | `Fork((_,hd',GuaranteesOpacity,ids), _) when has_proof_using last ->
+        assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch);
+        let name = name ids in
+        `ASync (parent last,proof_using_ast last,accn,name,delegate name)
+    | `Fork((_, hd', GuaranteesOpacity, ids), _) when
+       has_proof_no_using last && not (State.is_cached (parent last)) &&
+       !Flags.compilation_mode = Flags.BuildVio ->
+        assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch);
+        (try
+          let name, hint = name ids, get_hint_ctx loc  in
+          let t, v = proof_no_using last in
+          v.expr <- VernacProof(t, Some hint);
+          `ASync (parent last,proof_using_ast last,accn,name,delegate name)
+        with Not_found -> `Sync (no_name,None,`NoHint))
+    | `Fork((_, hd', GuaranteesOpacity, ids), _) ->
+        assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch);
+        let name = name ids in
+        `MaybeASync (parent last, None, accn, name, delegate name)
+    | `Sideff _ -> `Sync (no_name,None,`NestedProof)
+    | _ -> `Sync (no_name,None,`Unknown) in
+ let make_sync why = function
+   | `Sync(name,pua,_) -> `Sync (name,pua,why)
+   | `MaybeASync(_,pua,_,name,_) -> `Sync (name,pua,why)
+   | `ASync(_,pua,_,name,_) -> `Sync (name,pua,why) in
+ let check_policy rc = if async_policy () then rc else make_sync `Policy rc in
+ match cur, (VCS.visit id).step, brkind with
+ | (parent, { expr = VernacExactProof _ }), `Fork _, _ ->
+     `Sync (no_name,None,`Immediate)
+ | _, _, { VCS.kind = `Edit _ }  -> check_policy (collect (Some cur) [] id)
+ | _ ->
+     if is_defined cur then `Sync (no_name,None,`Transparent)
+     else if keep == VtDrop then `Sync (no_name,None,`Aborted)
+     else
+       let rc = collect (Some cur) [] id in
+       if keep == VtKeep &&
+          (not(State.is_cached id) || !Flags.async_proofs_full)
+       then check_policy rc
+       else make_sync `AlreadyEvaluated rc
+
+let string_of_reason = function
+  | `Transparent -> "Transparent"
+  | `AlreadyEvaluated -> "AlreadyEvaluated"
+  | `Policy -> "Policy"
+  | `NestedProof -> "NestedProof"
+  | `Immediate -> "Immediate"
+  | `Alias -> "Alias"
+  | `NoHint -> "NoHint"
+  | `Doesn'tGuaranteeOpacity -> "Doesn'tGuaranteeOpacity"
+  | `Aborted -> "Aborted"
+  | _ -> "Unknown Reason"
+
+let wall_clock_last_fork = ref 0.0
+
+let known_state ?(redefine_qed=false) ~cache id =
+
+  (* ugly functions to process nested lemmas, i.e. hard to reproduce
+   * side effects *)
+  let cherry_pick_non_pstate () =
+    Summary.freeze_summary ~marshallable:`No ~complement:true pstate,
+    Lib.freeze ~marshallable:`No in
+  let inject_non_pstate (s,l) = Summary.unfreeze_summary s; Lib.unfreeze l in
+
+  let rec pure_cherry_pick_non_pstate id = Future.purify (fun id ->
+    prerr_endline ("cherry-pick non pstate " ^ Stateid.to_string id);
+    reach id;
+    cherry_pick_non_pstate ()) id
+
+  (* traverses the dag backward from nodes being already calculated *)
+  and reach ?(redefine_qed=false) ?(cache=cache) id =
+    prerr_endline ("reaching: " ^ Stateid.to_string id);
+    if not redefine_qed && State.is_cached ~cache id then begin
+      State.install_cached id;
+      Hooks.(call state_computed id ~in_cache:true);
+      prerr_endline ("reached (cache)")
+    end else
+    let step, cache_step, feedback_processed =
+      let view = VCS.visit id in
+      match view.step with
+      | `Alias id -> (fun () ->
+            reach view.next; reach id
+          ), cache, true
+      | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () ->
+            reach ~cache:`Shallow view.next;
+            Partac.vernac_interp
+              cancel !Flags.async_proofs_n_tacworkers view.next id x
+          ), cache, true
+      | `Cmd { cast = x; cqueue = `QueryQueue cancel }
+        when Flags.async_proofs_is_master () -> (fun () ->
+            reach ~cache:`Shallow view.next;
+            Query.vernac_interp cancel view.next id x
+          ), cache, false
+      | `Cmd { cast = x } -> (fun () ->
+            reach view.next; vernac_interp id x
+          ), cache, true
+      | `Fork ((x,_,_,_), None) -> (fun () ->
+            reach view.next; vernac_interp id x;
+            wall_clock_last_fork := Unix.gettimeofday ()
+          ), `Yes, true
+      | `Fork ((x,_,_,_), Some prev) -> (fun () ->
+            reach ~cache:`Shallow prev;
+            reach view.next;
+            (try vernac_interp id x;
+            with e when Errors.noncritical e ->
+              let (e, info) = Errors.push e in
+              let info = Stateid.add info ~valid:prev id in
+              iraise (e, info));
+            wall_clock_last_fork := Unix.gettimeofday ()
+          ), `Yes, true
+      | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) ->
+          let rec aux = function
+          | `ASync (start, pua, nodes, name, delegate) -> (fun () ->
+                assert(keep == VtKeep);
+                let stop, exn_info, loc = eop, (id, eop), x.loc in
+                prerr_endline ("Asynchronous " ^ Stateid.to_string id);
+                VCS.create_cluster nodes ~qed:id ~start;
+                begin match brinfo, qed.fproof with
+                | { VCS.kind = `Edit _ }, None -> assert false
+                | { VCS.kind = `Edit _ }, Some (ofp, cancel) ->
+                    assert(redefine_qed = true);
+                    let fp, cancel =
+                      Slaves.build_proof ~loc ~exn_info ~start ~stop ~name in
+                    Future.replace ofp fp;
+                    qed.fproof <- Some (fp, cancel)
+                | { VCS.kind = `Proof _ }, Some _ -> assert false
+                | { VCS.kind = `Proof _ }, None ->
+                    reach ~cache:`Shallow start;
+                    let fp, cancel =
+                      if delegate then
+                        Slaves.build_proof ~loc ~exn_info ~start ~stop ~name
+                      else
+                        ProofTask.build_proof_here exn_info loc stop, ref false
+                    in
+                    qed.fproof <- Some (fp, cancel);
+                    let proof =
+                      Proof_global.close_future_proof ~feedback_id:id fp in
+                    if not delegate then ignore(Future.compute fp);
+                    reach view.next;
+                    vernac_interp id ~proof x;
+                    feedback ~state_id:id Feedback.Incomplete
+                | { VCS.kind = `Master }, _ -> assert false
+                end;
+                Proof_global.discard_all ()
+              ), (if redefine_qed then `No else `Yes), true
+          | `Sync (name, _, `Immediate) -> (fun () -> 
+                assert (Stateid.equal view.next eop);
+                reach eop; vernac_interp id x; Proof_global.discard_all ()
+              ), `Yes, true
+          | `Sync (name, pua, reason) -> (fun () ->
+                prerr_endline ("Synchronous " ^ Stateid.to_string id ^ " " ^
+                  string_of_reason reason);
+                reach eop;
+                let wall_clock = Unix.gettimeofday () in
+                record_pb_time name x.loc (wall_clock -. !wall_clock_last_fork);
+                let proof =
+                  if keep != VtKeep then None
+                  else Some(Proof_global.close_proof
+                              ~keep_body_ucst_sepatate:false
+                              (State.exn_on id ~valid:eop)) in
+                if proof = None then prerr_endline "NONE!!!!!";
+                reach view.next;
+                if keep == VtKeepAsAxiom then
+                  Option.iter (vernac_interp id) pua;
+                let wall_clock2 = Unix.gettimeofday () in
+                vernac_interp id ?proof x;
+                let wall_clock3 = Unix.gettimeofday () in
+                Aux_file.record_in_aux_at x.loc "proof_check_time"
+                  (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2));
+                Proof_global.discard_all ()
+              ), `Yes, true
+          | `MaybeASync (start, pua, nodes, name, delegate) -> (fun () ->
+                prerr_endline ("MaybeAsynchronous " ^ Stateid.to_string id);
+                reach ~cache:`Shallow start;
+                (* no sections *)
+                if List.is_empty (Environ.named_context (Global.env ()))
+                then pi1 (aux (`ASync (start, pua, nodes, name, delegate))) ()
+                else pi1 (aux (`Sync (name, pua, `Unknown))) ()
+              ), (if redefine_qed then `No else `Yes), true
+          in
+          aux (collect_proof keep (view.next, x) brname brinfo eop)
+      | `Sideff (`Ast (x,_)) -> (fun () ->
+            reach view.next; vernac_interp id x;
+          ), cache, true
+      | `Sideff (`Id origin) -> (fun () ->
+            reach view.next;
+            inject_non_pstate (pure_cherry_pick_non_pstate origin);
+          ), cache, true
+    in
+    let cache_step =
+      if !Flags.async_proofs_cache = Some Flags.Force then `Yes
+      else cache_step in
+    State.define
+      ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id;
+    prerr_endline ("reached: "^ Stateid.to_string id) in
+  reach ~redefine_qed id
+
+end (* }}} *)
+
+(********************************* STM API ************************************)
+(******************************************************************************)
+
+let init () =
+  VCS.init Stateid.initial;
+  set_undo_classifier Backtrack.undo_vernac_classifier;
+  State.define ~cache:`Yes (fun () -> ()) Stateid.initial;
+  Backtrack.record ();
+  Slaves.init ();
+  if Flags.async_proofs_is_master () then begin
+    prerr_endline "Initialising workers";
+    Query.init ();
+    let opts = match !Flags.async_proofs_private_flags with
+      | None -> []
+      | Some s -> Str.split_delim (Str.regexp ",") s in
+    begin try
+      let env_opt = Str.regexp "^extra-env=" in
+      let env = List.find (fun s -> Str.string_match env_opt s 0) opts in
+      async_proofs_workers_extra_env := Array.of_list
+        (Str.split_delim (Str.regexp ";") (Str.replace_first env_opt "" env))
+    with Not_found -> () end;
+  end
+
+let observe id =
+  let vcs = VCS.backup () in
+  try
+    Reach.known_state ~cache:(interactive ()) id;
+    VCS.print ()
+  with e ->
+    let e = Errors.push e in
+    VCS.print ();
+    VCS.restore vcs;
+    iraise e
+
+let finish ?(print_goals=false) () =
+  observe (VCS.get_branch_pos (VCS.current_branch ()));
+  if print_goals then msg_notice (pr_open_cur_subgoals ());
+  VCS.print ()
+
+let wait () =
+  Slaves.wait_all_done ();
+  VCS.print ()
+
+let join () =
+  finish ();
+  wait ();
+  prerr_endline "Joining the environment";
+  Global.join_safe_environment ();
+  VCS.print ();
+  VCS.print ()
+
+let dump_snapshot () = Slaves.dump_snapshot (), RemoteCounter.snapshot ()
+type document = VCS.vcs
+type tasks = int Slaves.tasks * RemoteCounter.remote_counters_status
+let check_task name (tasks,rcbackup) i =
+  RemoteCounter.restore rcbackup;
+  let vcs = VCS.backup () in
+  try
+    let rc = Future.purify (Slaves.check_task name tasks) i in
+    pperr_flush ();
+    VCS.restore vcs;
+    rc
+  with e when Errors.noncritical e -> VCS.restore vcs; false
+let info_tasks (tasks,_) = Slaves.info_tasks tasks
+let finish_tasks name u d p (t,rcbackup as tasks) =
+  RemoteCounter.restore rcbackup;
+  let finish_task u (_,_,i) =
+    let vcs = VCS.backup () in
+    let u = Future.purify (Slaves.finish_task name u d p t) i in
+    pperr_flush ();
+    VCS.restore vcs;
+    u in
+  try
+    let u, a, _ = List.fold_left finish_task u (info_tasks tasks) in
+    (u,a,true), p
+  with e ->
+    let e = Errors.push e in
+    pperrnl (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e);
+    exit 1
+
+let merge_proof_branch ?id qast keep brname =
+  let brinfo = VCS.get_branch brname in
+  let qed fproof = { qast; keep; brname; brinfo; fproof } in
+  match brinfo with
+  | { VCS.kind = `Proof _ } ->
+      VCS.checkout VCS.Branch.master;
+      let id = VCS.new_node ?id () in
+      VCS.merge id ~ours:(Qed (qed None)) brname;
+      VCS.delete_branch brname;
+      if keep <> VtDrop then VCS.propagate_sideff None;
+      `Ok
+  | { VCS.kind = `Edit (mode, qed_id, master_id) } ->
+      let ofp =
+        match VCS.visit qed_id with
+        | { step = `Qed ({ fproof }, _) } -> fproof
+        | _ -> assert false in
+      VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname;
+      VCS.delete_branch brname;
+      VCS.gc ();
+      Reach.known_state ~redefine_qed:true ~cache:`No qed_id;
+      VCS.checkout VCS.Branch.master;
+      `Unfocus qed_id
+  | { VCS.kind = `Master } ->
+       iraise (State.exn_on Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null))
+
+(* When tty is true, this code also does some of the job of the user interface:
+   jump back to a state that is valid *)
+let handle_failure (e, info) vcs tty =
+  if e = Errors.Drop then iraise (e, info) else
+  match Stateid.get info with
+  | None ->
+      VCS.restore vcs;
+      VCS.print ();
+      if tty && interactive () = `Yes then begin
+        (* Hopefully the 1 to last state is valid *)
+        Backtrack.back_safe (); 
+        VCS.checkout_shallowest_proof_branch ();
+      end;
+      VCS.print ();
+      anomaly(str"error with no safe_id attached:" ++ spc() ++
+        Errors.print_no_report e)
+  | Some (safe_id, id) ->
+      prerr_endline ("Failed at state " ^ Stateid.to_string id);
+      VCS.restore vcs;
+      if tty && interactive () = `Yes then begin
+        (* We stay on a valid state *)
+        Backtrack.backto safe_id;
+        VCS.checkout_shallowest_proof_branch ();
+        Reach.known_state ~cache:(interactive ()) safe_id;
+      end;
+      VCS.print ();
+      iraise (e, info)
+
+let snapshot_vio ldir long_f_dot_v =
+  finish ();
+  if List.length (VCS.branches ()) > 1 then
+    Errors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs");
+  Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_v
+    (Global.opaque_tables ())
+
+let reset_task_queue = Slaves.reset_task_queue
+
+(* Document building *)
+let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) =
+  let warn_if_pos a b =
+    if b then msg_warning(pr_ast a ++ str" should not be part of a script") in
+  let v, x = expr, { verbose = verbose; loc; expr } in
+  prerr_endline ("{{{ processing: "^ string_of_ppcmds (pr_ast x));
+  let vcs = VCS.backup () in
+  try
+    let head = VCS.current_branch () in
+    VCS.checkout head;
+    let rc = begin
+      prerr_endline ("  classified as: " ^ string_of_vernac_classification c);
+      match c with
+      (* PG stuff *)    
+      | VtStm(VtPG,false), VtNow -> vernac_interp Stateid.dummy x; `Ok
+      | VtStm(VtPG,_), _ -> anomaly(str "PG command in script or VtLater")
+      (* Joining various parts of the document *)
+      | VtStm (VtJoinDocument, b), VtNow -> warn_if_pos x b; join (); `Ok
+      | VtStm (VtFinish, b),       VtNow -> warn_if_pos x b; finish (); `Ok
+      | VtStm (VtWait, b),     VtNow -> warn_if_pos x b; finish (); wait (); `Ok
+      | VtStm (VtPrintDag, b), VtNow ->
+          warn_if_pos x b; VCS.print ~now:true (); `Ok
+      | VtStm (VtObserve id, b),   VtNow -> warn_if_pos x b; observe id; `Ok
+      | VtStm ((VtObserve _ | VtFinish | VtJoinDocument
+                |VtPrintDag |VtWait),_), VtLater ->
+          anomaly(str"classifier: join actions cannot be classified as VtLater")
+      
+      (* Back *)
+      | VtStm (VtBack oid, true), w ->
+          let id = VCS.new_node ~id:newtip () in
+          let { mine; others } = Backtrack.branches_of oid in
+          List.iter (fun branch ->
+            if not (List.mem_assoc branch (mine::others)) then
+              ignore(merge_proof_branch x VtDrop branch))
+            (VCS.branches ());
+          VCS.checkout_shallowest_proof_branch ();
+          let head = VCS.current_branch () in
+          List.iter (fun b ->
+            if not(VCS.Branch.equal b head) then begin
+              VCS.checkout b;
+              VCS.commit (VCS.new_node ()) (Alias oid);
+            end)
+            (VCS.branches ());
+          VCS.checkout_shallowest_proof_branch ();
+          VCS.commit id (Alias oid);
+          Backtrack.record (); if w == VtNow then finish (); `Ok
+      | VtStm (VtBack id, false), VtNow ->
+          prerr_endline ("undo to state " ^ Stateid.to_string id);
+          Backtrack.backto id;
+          VCS.checkout_shallowest_proof_branch ();
+          Reach.known_state ~cache:(interactive ()) id; `Ok
+      | VtStm (VtBack id, false), VtLater ->
+          anomaly(str"classifier: VtBack + VtLater must imply part_of_script")
+
+      (* Query *)
+      | VtQuery (false,(report_id,route)), VtNow when tty = true ->
+          finish ();
+          (try Future.purify (vernac_interp report_id ~route)
+                  { verbose = true; loc; expr }
+           with e when Errors.noncritical e ->
+             let e = Errors.push e in
+             iraise (State.exn_on report_id e)); `Ok
+      | VtQuery (false,(report_id,route)), VtNow ->
+          (try vernac_interp report_id ~route x
+           with e when Errors.noncritical e ->
+             let e = Errors.push e in
+             iraise (State.exn_on report_id e)); `Ok
+      | VtQuery (true,(report_id,_)), w ->
+          assert(Stateid.equal report_id Stateid.dummy);
+          let id = VCS.new_node ~id:newtip () in
+          let queue =
+            if !Flags.async_proofs_full then `QueryQueue (ref false)
+            else `MainQueue in
+          VCS.commit id (Cmd { cast = x; cids = []; cqueue = queue });
+          Backtrack.record (); if w == VtNow then finish (); `Ok
+      | VtQuery (false,_), VtLater ->
+          anomaly(str"classifier: VtQuery + VtLater must imply part_of_script")
+
+      (* Proof *)
+      | VtStartProof (mode, guarantee, names), w ->
+          let id = VCS.new_node ~id:newtip () in
+          let bname = VCS.mk_branch_name x in
+          VCS.checkout VCS.Branch.master;
+          if VCS.Branch.equal head VCS.Branch.master then begin
+            VCS.commit id (Fork (x, bname, guarantee, names));
+            VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1))
+          end else begin
+            VCS.branch bname (`Proof (mode, VCS.proof_nesting () + 1));
+            VCS.merge id ~ours:(Fork (x, bname, guarantee, names)) head
+          end;
+          Proof_global.activate_proof_mode mode;
+          Backtrack.record (); if w == VtNow then finish (); `Ok
+      | VtProofMode _, VtLater ->
+          anomaly(str"VtProofMode must be executed VtNow")
+      | VtProofMode mode, VtNow ->
+          let id = VCS.new_node ~id:newtip () in
+          VCS.checkout VCS.Branch.master;
+          VCS.commit id (Cmd {cast = x; cids=[]; cqueue = `MainQueue});
+          VCS.propagate_sideff (Some x);
+          List.iter
+            (fun bn -> match VCS.get_branch bn with
+            | { VCS.root; kind = `Master; pos } -> ()
+            | { VCS.root; kind = `Proof(_,d); pos } ->
+                VCS.delete_branch bn;
+                VCS.branch ~root ~pos bn (`Proof(mode,d))
+            | { VCS.root; kind = `Edit(_,f,q); pos } ->
+                VCS.delete_branch bn;
+                VCS.branch ~root ~pos bn (`Edit(mode,f,q)))
+            (VCS.branches ());
+          VCS.checkout_shallowest_proof_branch ();
+          Backtrack.record ();
+          finish ();
+          `Ok
+      | VtProofStep paral, w ->
+          let id = VCS.new_node ~id:newtip () in
+          let queue = if paral then `TacQueue (ref false) else `MainQueue in
+          VCS.commit id (Cmd {cast = x; cids = []; cqueue = queue });
+          Backtrack.record (); if w == VtNow then finish (); `Ok
+      | VtQed keep, w ->
+          let rc = merge_proof_branch ~id:newtip x keep head in
+          VCS.checkout_shallowest_proof_branch ();
+          Backtrack.record (); if w == VtNow then finish ();
+          rc
+          
+      (* Side effect on all branches *)
+      | VtUnknown, _ when expr = VernacToplevelControl Drop ->
+          vernac_interp (VCS.get_branch_pos head) x; `Ok
+
+      | VtSideff l, w ->
+          let id = VCS.new_node ~id:newtip () in
+          VCS.checkout VCS.Branch.master;
+          VCS.commit id (Cmd { cast = x; cids = l; cqueue = `MainQueue});
+          VCS.propagate_sideff (Some x);
+          VCS.checkout_shallowest_proof_branch ();
+          Backtrack.record (); if w == VtNow then finish (); `Ok
+
+      (* Unknown: we execute it, check for open goals and propagate sideeff *)
+      | VtUnknown, VtNow ->
+          let id = VCS.new_node ~id:newtip () in
+          let head_id = VCS.get_branch_pos head in
+          Reach.known_state ~cache:`Yes head_id; (* ensure it is ok *)
+          let step () =
+            VCS.checkout VCS.Branch.master;
+            let mid = VCS.get_branch_pos VCS.Branch.master in
+            Reach.known_state ~cache:(interactive ()) mid;
+            vernac_interp id x;
+            (* Vernac x may or may not start a proof *)
+            if VCS.Branch.equal head VCS.Branch.master &&
+               Proof_global.there_are_pending_proofs ()
+            then begin
+              let bname = VCS.mk_branch_name x in
+              VCS.commit id (Fork (x,bname,Doesn'tGuaranteeOpacity,[]));
+              VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1));
+              Proof_global.activate_proof_mode "Classic";
+            end else begin
+              VCS.commit id (Cmd { cast = x; cids = []; cqueue = `MainQueue});
+              VCS.propagate_sideff (Some x);
+              VCS.checkout_shallowest_proof_branch ();
+            end in
+          State.define ~safe_id:head_id ~cache:`Yes step id;
+          Backtrack.record (); `Ok
+
+      | VtUnknown, VtLater ->
+          anomaly(str"classifier: VtUnknown must imply VtNow")
+    end in
+    (* Proof General *)
+    begin match v with 
+      | VernacStm (PGLast _) ->
+        if not (VCS.Branch.equal head VCS.Branch.master) then
+          vernac_interp Stateid.dummy
+            { verbose = true; loc = Loc.ghost;
+              expr = VernacShow (ShowGoal OpenSubgoals) }
+      | _ -> ()
+    end;
+    prerr_endline "processed }}}";
+    VCS.print ();
+    rc
+  with e ->
+    let e = Errors.push e in
+    handle_failure e vcs tty
+
+let print_ast id =
+  try
+    match VCS.visit id with
+    | { step = `Cmd { cast = { loc; expr } } }
+    | { step = `Fork (({ loc; expr }, _, _, _), _) } 
+    | { step = `Qed ({ qast = { loc; expr } }, _) } ->
+        let xml = 
+          try Texmacspp.tmpp expr loc
+          with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e) in
+        xml;
+    | _ -> Xml_datatype.PCData "ERROR"
+  with _ -> Xml_datatype.PCData "ERROR"
+
+let stop_worker n = Slaves.cancel_worker n
+
+let add ~ontop ?newtip ?(check=ignore) verb eid s =
+  let cur_tip = VCS.cur_tip () in
+  if Stateid.equal ontop cur_tip then begin
+    let _, ast as loc_ast = vernac_parse ?newtip eid s in
+    check(loc_ast);
+    let clas = classify_vernac ast in
+    match process_transaction ?newtip ~tty:false verb clas loc_ast with
+    | `Ok -> VCS.cur_tip (), `NewTip
+    | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ())
+  end else begin
+    (* For now, arbitrary edits should be announced with edit_at *)
+    anomaly(str"Not yet implemented, the GUI should not try this")
+  end
+
+let set_perspective id_list = Slaves.set_perspective id_list
+
+type focus = {
+  start : Stateid.t;
+  stop : Stateid.t;
+  tip : Stateid.t
+}
+
+let query ~at ?(report_with=(Stateid.dummy,Feedback.default_route)) s =
+  Future.purify (fun s ->
+    if Stateid.equal at Stateid.dummy then finish ()
+    else Reach.known_state ~cache:`Yes at;
+    let newtip, route = report_with in
+    let _, ast as loc_ast = vernac_parse ~newtip ~route 0 s in
+    let clas = classify_vernac ast in
+    match clas with
+    | VtStm (w,_), _ ->
+       ignore(process_transaction
+         ~tty:false true (VtStm (w,false), VtNow) loc_ast)
+    | _ ->
+       ignore(process_transaction
+         ~tty:false true (VtQuery (false,report_with), VtNow) loc_ast))
+  s
+
+let edit_at id =
+  if Stateid.equal id Stateid.dummy then anomaly(str"edit_at dummy") else
+  let vcs = VCS.backup () in
+  let on_cur_branch id =
+    let rec aux cur =
+      if id = cur then true
+      else match VCS.visit cur with
+      | { step = `Fork _ } -> false
+      | { next } -> aux next in
+    aux (VCS.get_branch_pos (VCS.current_branch ())) in
+  let is_ancestor_of_cur_branch id =
+    Vcs_.NodeSet.mem id
+      (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in
+  let has_failed qed_id =
+    match VCS.visit qed_id with
+    | { step = `Qed ({ fproof = Some (fp,_) }, _) } -> Future.is_exn fp
+    | _ -> false in
+  let rec master_for_br root tip =
+      if Stateid.equal tip Stateid.initial then tip else
+      match VCS.visit tip with
+      | { next } when next = root -> root
+      | { step = `Fork _ } -> tip
+      | { step = `Sideff (`Ast(_,id)|`Id id) } -> id
+      | { next } -> master_for_br root next in
+  let reopen_branch start at_id mode qed_id tip =
+    let master_id, cancel_switch =
+      (* Hum, this should be the real start_id in the clusted and not next *)
+      match VCS.visit qed_id with
+      | { step = `Qed ({ fproof = Some (_,cs)},_) } -> start, cs
+      | _ -> anomaly (str "Cluster not ending with Qed") in
+    VCS.branch ~root:master_id ~pos:id
+      VCS.edit_branch (`Edit (mode, qed_id, master_id));
+    VCS.delete_cluster_of id;
+    cancel_switch := true;
+    Reach.known_state ~cache:(interactive ()) id;
+    VCS.checkout_shallowest_proof_branch ();
+    `Focus { stop = qed_id; start = master_id; tip } in
+  let backto id =
+    List.iter VCS.delete_branch (VCS.branches ());
+    let ancestors = VCS.reachable id in
+    let { mine = brname, brinfo; others } = Backtrack.branches_of id in
+    List.iter (fun (name,{ VCS.kind = k; root; pos }) ->
+      if not(VCS.Branch.equal name VCS.Branch.master) &&
+         Vcs_.NodeSet.mem root ancestors then
+        VCS.branch ~root ~pos name k)
+      others;
+    VCS.reset_branch VCS.Branch.master (master_for_br brinfo.VCS.root id);
+    VCS.branch ~root:brinfo.VCS.root ~pos:brinfo.VCS.pos brname brinfo.VCS.kind;
+    VCS.delete_cluster_of id;
+    VCS.gc ();
+    Reach.known_state ~cache:(interactive ()) id;
+    VCS.checkout_shallowest_proof_branch ();
+    `NewTip in
+  try
+    let rc =
+      let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in
+      let branch_info =
+        match snd (VCS.get_info id).vcs_backup with
+        | Some{ mine = _, { VCS.kind = (`Proof(m,_)|`Edit(m,_,_)) }} -> Some m
+        | _ -> None in
+      match focused, VCS.cluster_of id, branch_info with
+      | _, Some _, None -> assert false
+      | false, Some (qed_id,start), Some mode ->
+          let tip = VCS.cur_tip () in
+          if has_failed qed_id && not !Flags.async_proofs_never_reopen_branch
+          then reopen_branch start id mode qed_id tip
+          else backto id
+      | true, Some (qed_id,_), Some mode ->
+          if on_cur_branch id then begin
+            assert false
+          end else if is_ancestor_of_cur_branch id then begin
+            backto id
+          end else begin
+            anomaly(str"Cannot leave an `Edit branch open")
+          end
+      | true, None, _ ->
+          if on_cur_branch id then begin
+            VCS.reset_branch (VCS.current_branch ()) id;
+            Reach.known_state ~cache:(interactive ()) id;
+            VCS.checkout_shallowest_proof_branch ();
+            `NewTip
+          end else if is_ancestor_of_cur_branch id then begin
+            backto id
+          end else begin
+            anomaly(str"Cannot leave an `Edit branch open")
+          end
+      | false, None, _ -> backto id
+    in
+    VCS.print ();
+    rc
+  with e ->
+    let (e, info) = Errors.push e in
+    match Stateid.get info with
+    | None ->
+        VCS.print ();
+        anomaly (str ("edit_at "^Stateid.to_string id^": ") ++
+          Errors.print_no_report e)
+    | Some (_, id) ->
+        prerr_endline ("Failed at state " ^ Stateid.to_string id);
+        VCS.restore vcs;
+        VCS.print ();
+        iraise (e, info)
+
+(*********************** TTY API (PG, coqtop, coqc) ***************************)
+(******************************************************************************)
+
+let interp verb (_,e as lexpr) =
+  let clas = classify_vernac e in
+  let rc = process_transaction ~tty:true verb clas lexpr in
+  if rc <> `Ok then anomaly(str"tty loop can't be mixed with the STM protocol");
+  if interactive () = `Yes ||
+     (!Flags.async_proofs_mode = Flags.APoff &&
+      !Flags.compilation_mode = Flags.BuildVo) then
+    let vcs = VCS.backup () in
+    let print_goals =
+      verb && match clas with
+       | VtQuery _, _ -> false
+       | (VtProofStep _ | VtStm (VtBack _, _)), _ -> true
+       | _ -> not !Flags.coqtop_ui || !Flags.print_emacs in
+    try finish ~print_goals ()
+    with e ->
+      let e = Errors.push e in
+      handle_failure e vcs true
+
+let finish () = finish ()
+
+let get_current_state () = VCS.cur_tip ()
+
+let current_proof_depth () =
+  let head = VCS.current_branch () in
+  match VCS.get_branch head with
+  | { VCS.kind = `Master } -> 0
+  | { VCS.pos = cur; VCS.kind = (`Proof _ | `Edit _); VCS.root = root } ->
+      let rec distance root =
+        if Stateid.equal cur root then 0
+        else 1 + distance (VCS.visit cur).next in
+      distance cur
+
+let unmangle n =
+  let n = VCS.Branch.to_string n in
+  let idx = String.index n '_' + 1 in
+  Names.id_of_string (String.sub n idx (String.length n - idx))
+
+let proofname b = match VCS.get_branch b with
+  | { VCS.kind = (`Proof _| `Edit _) } -> Some b
+  | _ -> None
+
+let get_all_proof_names () =
+  List.map unmangle (List.map_filter proofname (VCS.branches ()))
+
+let get_current_proof_name () =
+  Option.map unmangle (proofname (VCS.current_branch ()))
+
+let get_script prf =
+  let branch, test =
+    match prf with
+    | None -> VCS.Branch.master, fun _ -> true
+    | Some name -> VCS.current_branch (),  List.mem name in
+  let rec find acc id =
+    if Stateid.equal id Stateid.initial ||
+       Stateid.equal id Stateid.dummy then acc else
+    let view = VCS.visit id in
+    match view.step with
+    | `Fork((_,_,_,ns), _) when test ns -> acc
+    | `Qed (qed, proof) -> find [qed.qast.expr, (VCS.get_info id).n_goals] proof
+    | `Sideff (`Ast (x,_)) ->
+         find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next
+    | `Sideff (`Id id)  -> find acc id
+    | `Cmd {cast = x} -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next 
+    | `Alias id -> find acc id
+    | `Fork _ -> find acc view.next
+    in
+  find [] (VCS.get_branch_pos branch)
+
+(* indentation code for Show Script, initially contributed
+   by D. de Rauglaudre *)
+
+let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) =
+  (* ng1 : number of goals remaining at the current level (before cmd)
+     ngl1 : stack of previous levels with their remaining goals
+     ng : number of goals after the execution of cmd
+     beginend : special indentation stack for { } *)
+  let ngprev = List.fold_left (+) ng1 ngl1 in
+  let new_ngl =
+    if ng > ngprev then
+      (* We've branched *)
+      (ng - ngprev + 1, ng1 - 1 :: ngl1)
+    else if ng < ngprev then
+      (* A subgoal have been solved. Let's compute the new current level
+	 by discarding all levels with 0 remaining goals. *)
+      let rec loop = function
+	| (0, ng2::ngl2) -> loop (ng2,ngl2)
+	| p -> p
+      in loop (ng1-1, ngl1)
+    else
+      (* Standard case, same goal number as before *)
+      (ng1, ngl1)
+  in
+  (* When a subgoal have been solved, separate this block by an empty line *)
+  let new_nl = (ng < ngprev)
+  in
+  (* Indentation depth *)
+  let ind = List.length ngl1
+  in
+  (* Some special handling of bullets and { }, to get a nicer display *)
+  let pred n = max 0 (n-1) in
+  let ind, nl, new_beginend = match cmd with
+    | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend
+    | VernacEndSubproof -> List.hd beginend, false, List.tl beginend
+    | VernacBullet _ -> pred ind, nl, beginend
+    | _ -> ind, nl, beginend
+  in
+  let pp =
+    (if nl then fnl () else mt ()) ++
+    (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))
+  in
+  (new_ngl, new_nl, new_beginend, pp :: ppl)
+
+let show_script ?proof () =
+  try
+    let prf =
+      try match proof with
+      | None -> Some (Pfedit.get_current_proof_name ())
+      | Some (p,_) -> Some (p.Proof_global.id)
+      with Proof_global.NoCurrentProof -> None
+    in
+    let cmds = get_script prf in
+    let _,_,_,indented_cmds =
+      List.fold_left indent_script_item ((1,[]),false,[],[]) cmds
+    in
+    let indented_cmds = List.rev (indented_cmds) in
+    msg_notice (v 0 (prlist_with_sep fnl (fun x -> x) indented_cmds))
+  with Vcs_aux.Expired -> ()
+
+(* Export hooks *)
+let state_computed_hook = Hooks.state_computed_hook
+let state_ready_hook = Hooks.state_ready_hook
+let parse_error_hook = Hooks.parse_error_hook
+let execution_error_hook = Hooks.execution_error_hook
+let forward_feedback_hook = Hooks.forward_feedback_hook
+let process_error_hook = Hooks.process_error_hook
+let interp_hook = Hooks.interp_hook
+let with_fail_hook = Hooks.with_fail_hook
+let unreachable_state_hook = Hooks.unreachable_state_hook
+
+(* vim:set foldmethod=marker: *)
diff --git a/stm/stm.mli b/stm/stm.mli
new file mode 100644
index 00000000..1d926e99
--- /dev/null
+++ b/stm/stm.mli
@@ -0,0 +1,132 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Vernacexpr
+open Names
+open Feedback
+
+(** state-transaction-machine interface *)
+
+(* [add ontop check vebose eid s] adds a new command [s] on the state [ontop]
+   having edit id [eid].  [check] is called on the AST.
+   The [ontop] parameter is just for asserting the GUI is on sync, but
+   will eventually call edit_at on the fly if needed.
+   The sentence [s] is parsed in the state [ontop].
+   If [newtip] is provided, then the returned state id is guaranteed to be
+   [newtip] *)
+val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(located_vernac_expr -> unit) ->
+  bool -> edit_id -> string ->
+    Stateid.t * [ `NewTip | `Unfocus of Stateid.t ]
+
+(* parses and executes a command at a given state, throws away its side effects
+   but for the printings.  Feedback is sent with report_with (defaults to dummy
+   state id)  *)
+val query :
+  at:Stateid.t -> ?report_with:(Stateid.t * Feedback.route_id) -> string -> unit
+
+(* [edit_at id] is issued to change the editing zone.  [`NewTip] is returned if
+   the requested id is the new document tip hence the document portion following
+   [id] is dropped by Coq.  [`Focus fo] is returned to say that [fo.tip] is the
+   new document tip, the document between [id] and [fo.stop] has been dropped.
+   The portion between [fo.stop] and [fo.tip] has been kept.  [fo.start] is
+   just to tell the gui where the editing zone starts, in case it wants to
+   graphically denote it.  All subsequent [add] happen on top of [id]. *)
+type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t }
+val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ]
+
+(* Evaluates the tip of the current branch *)
+val finish : unit -> unit
+
+val observe : Stateid.t -> unit
+
+val stop_worker : string -> unit
+
+(* Joins the entire document.  Implies finish, but also checks proofs *)
+val join : unit -> unit
+
+(* Saves on the dist a .vio corresponding to the current status:
+   - if the worker prool is empty, all tasks are saved
+   - if the worker proof is not empty, then it waits until all workers
+     are done with their current jobs and then dumps (or fails if one
+     of the completed tasks is a failuere) *)
+val snapshot_vio : DirPath.t -> string -> unit
+
+(* Empties the task queue, can be used only if the worker pool is empty (E.g.
+ * after having built a .vio in batch mode *)
+val reset_task_queue : unit -> unit
+
+(* A .vio contains tasks to be completed *)
+type tasks
+val check_task : string -> tasks -> int -> bool
+val info_tasks : tasks -> (string * float * int) list
+val finish_tasks : string ->
+  Library.seg_univ -> Library.seg_discharge -> Library.seg_proofs ->
+    tasks -> Library.seg_univ * Library.seg_proofs
+
+(* Id of the tip of the current branch *)
+val get_current_state : unit -> Stateid.t
+
+(* Misc *)
+val init : unit -> unit
+val print_ast : Stateid.t -> Xml_datatype.xml
+
+(* Filename *)
+val set_compilation_hints : string -> unit
+
+(* Reorders the task queue putting forward what is in the perspective *)
+val set_perspective : Stateid.t list -> unit
+
+(** workers **************************************************************** **)
+
+module ProofTask : AsyncTaskQueue.Task
+module TacTask   : AsyncTaskQueue.Task
+module QueryTask : AsyncTaskQueue.Task
+
+(** customization ********************************************************** **)
+
+(* From the master (or worker, but beware that to install the hook
+ * into a worker one has to build the worker toploop to do so and
+ * the alternative toploop for the worker can be selected by changing
+ * the name of the Task(s) above) *)
+
+val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t
+val parse_error_hook :
+  (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
+val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t
+val unreachable_state_hook : (Stateid.t -> unit) Hook.t
+(* ready means that master has it at hand *)
+val state_ready_hook : (Stateid.t -> unit) Hook.t
+
+(* Messages from the workers to the master *)
+val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t
+
+type state = {
+  system : States.state;
+  proof : Proof_global.state;
+  shallow : bool
+}
+val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ]
+
+(** read-eval-print loop compatible interface ****************************** **)
+
+(* Adds a new line to the document.  It replaces the core of Vernac.interp.
+   [finish] is called as the last bit of this function is the system
+   is running interactively (-emacs or coqtop). *)
+val interp : bool -> located_vernac_expr -> unit
+
+(* Queries for backward compatibility *)
+val current_proof_depth : unit -> int
+val get_all_proof_names : unit -> Id.t list
+val get_current_proof_name : unit -> Id.t option
+val show_script : ?proof:Proof_global.closed_proof -> unit -> unit
+
+(** Reverse dependency hooks *)
+val process_error_hook : Future.fix_exn Hook.t
+val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof ->
+  Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t
+val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t
diff --git a/stm/stm.mllib b/stm/stm.mllib
new file mode 100644
index 00000000..92b3a869
--- /dev/null
+++ b/stm/stm.mllib
@@ -0,0 +1,12 @@
+Spawned
+Dag
+Vcs
+TQueue
+WorkerPool
+Vernac_classifier
+Lemmas
+CoqworkmgrApi
+AsyncTaskQueue
+Texmacspp
+Stm
+Vio_checking
diff --git a/stm/tQueue.ml b/stm/tQueue.ml
new file mode 100644
index 00000000..8a62fe79
--- /dev/null
+++ b/stm/tQueue.ml
@@ -0,0 +1,133 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module PriorityQueue : sig
+  type 'a t
+  val create : unit -> 'a t
+  val set_rel : ('a -> 'a -> int) -> 'a t -> unit
+  val is_empty : 'a t -> bool
+  val exists : ('a -> bool) -> 'a t -> bool
+  val pop : ?picky:('a -> bool) -> 'a t -> 'a
+  val push : 'a t -> 'a -> unit
+  val clear : 'a t -> unit
+end = struct
+  type 'a item = int * 'a
+  type 'a rel = 'a item -> 'a item -> int
+  type 'a t = ('a item list * 'a rel) ref
+  let sort_timestamp (i,_) (j,_) = i - j
+  let age = ref 0
+  let create () = ref ([],sort_timestamp)
+  let is_empty t = fst !t = []
+  let exists p t = List.exists (fun (_,x) -> p x) (fst !t)
+  let pop ?(picky=(fun _ -> true)) ({ contents = (l, rel) } as t) =
+    let rec aux acc = function
+      | [] -> raise Queue.Empty
+      | (_,x) :: xs when picky x -> t := (List.rev acc @ xs, rel); x
+      | (_,x) as hd :: xs -> aux (hd :: acc) xs in
+    aux [] l
+  let push ({ contents = (xs, rel) } as t) x =
+    incr age;
+    (* re-roting the whole list is not the most efficient way... *)
+    t := (List.sort rel (xs @ [!age,x]), rel)
+  let clear ({ contents = (l, rel) } as t) = t := ([], rel)
+  let set_rel rel ({ contents = (xs, _) } as t) =
+    let rel (_,x) (_,y) = rel x y in
+    t := (List.sort rel xs, rel)
+end
+
+type 'a t = {
+  queue: 'a PriorityQueue.t;
+  lock : Mutex.t;
+  cond : Condition.t;
+  mutable nwaiting : int;
+  cond_waiting : Condition.t;
+  mutable release : bool;
+}
+
+exception BeingDestroyed
+
+let create () = {
+  queue = PriorityQueue.create ();
+  lock = Mutex.create ();
+  cond = Condition.create ();
+  nwaiting = 0;
+  cond_waiting = Condition.create ();
+  release = false;
+}
+
+let pop ?(picky=(fun _ -> true)) ?(destroy=ref false)
+  ({ queue = q; lock = m; cond = c; cond_waiting = cn } as tq)
+=
+  Mutex.lock m;
+  if tq.release then (Mutex.unlock m; raise BeingDestroyed);
+  while not (PriorityQueue.exists picky q || !destroy) do
+    tq.nwaiting <- tq.nwaiting + 1;
+    Condition.broadcast cn;
+    Condition.wait c m;
+    tq.nwaiting <- tq.nwaiting - 1;
+    if tq.release || !destroy then (Mutex.unlock m; raise BeingDestroyed)
+  done;
+  if !destroy then (Mutex.unlock m; raise BeingDestroyed);
+  let x = PriorityQueue.pop ~picky q in
+  Condition.signal c;
+  Condition.signal cn;
+  Mutex.unlock m;
+  x
+
+let signal_destruction { lock = m; cond = c } =
+  Mutex.lock m;
+  Condition.broadcast c;
+  Mutex.unlock m
+
+let push { queue = q; lock = m; cond = c; release } x =
+  if release then Errors.anomaly(Pp.str
+    "TQueue.push while being destroyed! Only 1 producer/destroyer allowed");
+  Mutex.lock m;
+  PriorityQueue.push q x;
+  Condition.broadcast c;
+  Mutex.unlock m
+
+let clear { queue = q; lock = m; cond = c } =
+  Mutex.lock m;
+  PriorityQueue.clear q;
+  Mutex.unlock m
+
+let is_empty { queue = q } = PriorityQueue.is_empty q
+
+let destroy tq =
+  tq.release <- true;
+  while tq.nwaiting > 0 do
+    Mutex.lock tq.lock;
+    Condition.broadcast tq.cond;
+    Mutex.unlock tq.lock;
+  done;
+  tq.release <- false
+
+let wait_until_n_are_waiting_and_queue_empty j tq =
+  Mutex.lock tq.lock;
+  while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do
+    Condition.wait tq.cond_waiting tq.lock
+  done;
+  Mutex.unlock tq.lock
+
+let wait_until_n_are_waiting_then_snapshot j tq =
+  let l = ref [] in
+  Mutex.lock tq.lock;
+  while not (PriorityQueue.is_empty tq.queue) do
+    l := PriorityQueue.pop tq.queue :: !l
+  done;
+  while tq.nwaiting < j do Condition.wait tq.cond_waiting tq.lock done;
+  List.iter (PriorityQueue.push tq.queue) (List.rev !l);
+  if !l <> [] then Condition.broadcast tq.cond;
+  Mutex.unlock tq.lock;
+  List.rev !l
+
+let set_order tq rel =
+  Mutex.lock tq.lock;
+  PriorityQueue.set_rel rel tq.queue;
+  Mutex.unlock tq.lock
diff --git a/stm/tQueue.mli b/stm/tQueue.mli
new file mode 100644
index 00000000..bc3922b3
--- /dev/null
+++ b/stm/tQueue.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* Thread safe queue with some extras *)
+
+type 'a t
+val create : unit -> 'a t
+val pop : ?picky:('a -> bool) -> ?destroy:bool ref -> 'a t -> 'a
+val push : 'a t -> 'a -> unit
+val set_order : 'a t -> ('a -> 'a -> int) -> unit
+val wait_until_n_are_waiting_and_queue_empty : int -> 'a t -> unit
+val signal_destruction : 'a t -> unit
+
+(* Non destructive *)
+val wait_until_n_are_waiting_then_snapshot : int -> 'a t -> 'a list
+
+val clear : 'a t -> unit
+val is_empty : 'a t -> bool
+
+exception BeingDestroyed
+(* Threads blocked in pop can get this exception if the queue is being
+ * destroyed *)
+val destroy : 'a t -> unit
diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml
new file mode 100644
index 00000000..c1a37fed
--- /dev/null
+++ b/stm/tacworkertop.ml
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+module W = AsyncTaskQueue.MakeWorker(Stm.TacTask)
+
+let () = Coqtop.toploop_init := (fun args ->
+        Flags.make_silent true;
+        W.init_stdout ();
+        CoqworkmgrApi.init !Flags.async_proofs_worker_priority;
+        args)
+
+let () = Coqtop.toploop_run := W.main_loop
+
diff --git a/stm/tacworkertop.mllib b/stm/tacworkertop.mllib
new file mode 100644
index 00000000..db38fde2
--- /dev/null
+++ b/stm/tacworkertop.mllib
@@ -0,0 +1 @@
+Tacworkertop
diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml
new file mode 100644
index 00000000..d71c169d
--- /dev/null
+++ b/stm/texmacspp.ml
@@ -0,0 +1,763 @@
+(************************************************************************)
+(*  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 Xml_datatype
+open Vernacexpr
+open Constrexpr
+open Names
+open Misctypes
+open Bigint
+open Decl_kinds
+open Extend
+open Libnames
+open Flags
+
+let unlock loc =
+  let start, stop = Loc.unloc loc in
+  (string_of_int start, string_of_int stop)
+
+let xmlNoop = (* almost noop  *)
+  PCData ""
+
+let xmlWithLoc loc ename attr xml =
+  let start, stop = unlock loc in
+  Element(ename, [ "begin", start; "end", stop ] @ attr, xml)
+
+let get_fst_attr_in_xml_list attr xml_list =
+  let attrs_list =
+    List.map (function
+      | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs)
+      | _ -> [])
+    xml_list in
+  match List.flatten attrs_list with
+  | [] -> (attr, "")
+  | l  -> (List.hd l)
+
+let backstep_loc xmllist =
+  let start_att = get_fst_attr_in_xml_list "begin" xmllist in
+  let stop_att =  get_fst_attr_in_xml_list "end" (List.rev xmllist) in
+  [start_att ; stop_att]
+
+let compare_begin_att xml1 xml2 =
+  let att1 = get_fst_attr_in_xml_list "begin" [xml1] in
+  let att2 = get_fst_attr_in_xml_list "begin" [xml2] in
+  match att1, att2 with
+  | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0
+  | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1
+  | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1
+  | _ -> 0
+
+let xmlBeginSection loc name = xmlWithLoc loc "beginsection" ["name", name] []
+
+let xmlEndSegment loc name = xmlWithLoc loc "endsegment" ["name", name] []
+
+let xmlThm typ name loc xml =
+  xmlWithLoc loc "theorem" ["type", typ; "name", name] xml
+
+let xmlDef typ name loc xml =
+  xmlWithLoc loc "definition" ["type", typ; "name", name] xml
+
+let xmlNotation attr name loc xml =
+  xmlWithLoc loc "notation" (("name", name) :: attr) xml
+
+let xmlReservedNotation attr name loc =
+  xmlWithLoc loc "reservednotation" (("name", name) :: attr) []
+
+let xmlCst name ?(attr=[]) loc =
+  xmlWithLoc loc "constant" (("name", name) :: attr) []
+
+let xmlOperator name ?(attr=[]) ?(pprules=[]) loc =
+  xmlWithLoc loc "operator"
+    (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) []
+
+let xmlApply loc ?(attr=[]) xml = xmlWithLoc loc "apply" attr xml
+
+let xmlToken loc ?(attr=[]) xml = xmlWithLoc loc "token" attr xml
+
+let xmlTyped xml = Element("typed", (backstep_loc xml), xml)
+
+let xmlReturn ?(attr=[]) xml = Element("return", attr, xml)
+
+let xmlCase xml = Element("case", [], xml)
+
+let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml)
+
+let xmlWith xml = Element("with", [], xml)
+
+let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml])
+
+let xmlInductive kind loc xml = xmlWithLoc loc "inductive" ["kind",kind] xml
+
+let xmlCoFixpoint xml = Element("cofixpoint", [], xml)
+
+let xmlFixpoint xml = Element("fixpoint", [], xml)
+
+let xmlCheck loc xml = xmlWithLoc loc "check" [] xml
+
+let xmlAssumption kind loc xml = xmlWithLoc loc "assumption" ["kind",kind] xml
+
+let xmlComment loc xml = xmlWithLoc loc "comment" [] xml
+
+let xmlCanonicalStructure attr loc = xmlWithLoc loc "canonicalstructure" attr []
+
+let xmlQed ?(attr=[]) loc = xmlWithLoc loc "qed" attr []
+
+let xmlPatvar id loc = xmlWithLoc loc "patvar" ["id", id] []
+
+let xmlReference ref =
+  let name = Libnames.string_of_reference ref in
+  let i, j = Loc.unloc (Libnames.loc_of_reference ref) in
+  let b, e = string_of_int i, string_of_int j in
+  Element("reference",["name", name; "begin", b; "end", e] ,[])
+
+let xmlRequire loc ?(attr=[]) xml = xmlWithLoc loc "require" attr xml
+let xmlImport loc ?(attr=[]) xml = xmlWithLoc loc "import" attr xml
+
+let xmlAddLoaPath loc ?(attr=[]) xml = xmlWithLoc loc "addloadpath" attr xml
+let xmlRemoveLoaPath loc ?(attr=[]) = xmlWithLoc loc "removeloadpath" attr
+let xmlAddMLPath loc ?(attr=[]) = xmlWithLoc loc "addmlpath" attr
+
+let xmlExtend loc xml = xmlWithLoc loc "extend" [] xml
+
+let xmlScope loc action ?(attr=[]) name xml =
+  xmlWithLoc loc "scope" (["name",name;"action",action] @ attr) xml
+
+let xmlProofMode loc name = xmlWithLoc loc "proofmode" ["name",name] []
+
+let xmlProof loc xml = xmlWithLoc loc "proof" [] xml
+
+let xmlRawTactic name rtac =
+  Element("rawtactic", ["name",name],
+    [PCData (Pp.string_of_ppcmds (Pptactic.pr_raw_tactic rtac))])
+
+let xmlSectionSubsetDescr name ssd =
+  Element("sectionsubsetdescr",["name",name],
+    [PCData (Proof_using.to_string ssd)])
+
+let xmlDeclareMLModule loc s =
+  xmlWithLoc loc "declarexmlmodule" []
+    (List.map (fun x -> Element("path",["value",x],[])) s)
+
+(* tactics *)
+let xmlLtac loc xml = xmlWithLoc loc "ltac" [] xml
+
+(* toplevel commands *)
+let xmlGallina loc xml = xmlWithLoc loc "gallina" [] xml
+
+let xmlTODO loc x =
+  xmlWithLoc loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+let string_of_name n =
+  match n with
+  | Anonymous -> "_"
+  | Name id -> Id.to_string id
+
+let string_of_glob_sort s =
+  match s with
+  | GProp -> "Prop"
+  | GSet -> "Set"
+  | GType _ -> "Type"
+
+let string_of_cast_sort c =
+  match c with
+  | CastConv _ -> "CastConv"
+  | CastVM _ -> "CastVM"
+  | CastNative _ -> "CastNative"
+  | CastCoerce -> "CastCoerce"
+
+let string_of_case_style s =
+  match s with
+  | LetStyle -> "Let"
+  | IfStyle -> "If"
+  | LetPatternStyle -> "LetPattern"
+  | MatchStyle -> "Match"
+  | RegularStyle -> "Regular"
+
+let attribute_of_syntax_modifier sm =
+match sm with
+  | SetItemLevel (sl, NumLevel n) ->
+      List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n]
+  | SetItemLevel (sl, NextLevel) ->
+      List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"]
+  | SetLevel i -> ["level", string_of_int i]
+  | SetAssoc a ->
+      begin match a with
+      | NonA -> ["",""]
+      | RightA -> ["associativity", "right"]
+      | LeftA -> ["associativity", "left"]
+      end
+  | SetEntryType (s, _) -> ["entrytype", s]
+  | SetOnlyParsing v -> ["compat", Flags.pr_version v]
+  | SetFormat (system, (loc, s)) ->
+      let start, stop = unlock loc in
+      ["format-"^system, s; "begin", start; "end", stop]
+
+let string_of_assumption_kind l a many =
+  match l, a, many with
+  | (Discharge, Logical,      true)  -> "Hypotheses"
+  | (Discharge, Logical,      false) -> "Hypothesis"
+  | (Discharge, Definitional, true)  -> "Variables"
+  | (Discharge, Definitional, false) -> "Variable"
+  | (Global,    Logical,      true)  -> "Axioms"
+  | (Global,    Logical,      false) -> "Axiom"
+  | (Global,    Definitional, true)  -> "Parameters"
+  | (Global,    Definitional, false) -> "Parameter"
+  | (Local,     Logical,      true)  -> "Local Axioms"
+  | (Local,     Logical,      false) -> "Local Axiom"
+  | (Local,     Definitional, true)  -> "Local Parameters"
+  | (Local,     Definitional, false) -> "Local Parameter"
+  | (Global,    Conjectural, _)      -> "Conjecture"
+  | ((Discharge | Local), Conjectural, _) -> assert false
+
+let rec pp_bindlist bl =
+  let tlist =
+    List.flatten
+        (List.map
+          (fun (loc_names, _, e) ->
+            let names =
+              (List.map
+                (fun (loc, name) ->
+                  xmlCst (string_of_name name) loc) loc_names) in
+            match e with
+              | CHole _ -> names
+              | _ -> names @ [pp_expr e])
+          bl) in
+  match tlist with
+    | [e] -> e
+    | l -> xmlTyped l
+and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *)
+  Element ("decl_notation", ["name", s], [pp_expr ce])
+and pp_local_binder lb = (* don't know what it is for now *)
+  match lb with
+  | LocalRawDef ((_, nam), ce) ->
+      let attrs = ["name", string_of_name nam] in
+      pp_expr ~attr:attrs ce
+  | LocalRawAssum (namll, _, ce) ->
+      let ppl =
+        List.map (fun (loc, nam) -> (xmlCst (string_of_name nam) loc)) namll in
+      xmlTyped (ppl @ [pp_expr ce])
+and pp_local_decl_expr lde = (* don't know what it is for now *)
+  match lde with
+  | AssumExpr (_, ce) -> pp_expr ce
+  | DefExpr (_, ce, _) -> pp_expr ce
+and pp_inductive_expr ((_, (l, id)), lbl, ceo, _, cl_or_rdexpr) =
+  (* inductive_expr *)
+  let b,e = Loc.unloc l in
+  let location = ["begin", string_of_int b; "end", string_of_int e] in
+  [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *)
+  begin match cl_or_rdexpr with
+  | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel
+  | RecordDecl (_, ldewwwl) ->
+      List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl
+  end @
+  begin match ceo with (* don't know what it is for now *)
+  | Some ce -> [pp_expr ce]
+  | None -> []
+  end @
+  (List.map pp_local_binder lbl)
+and pp_recursion_order_expr optid roe = (* don't know what it is for now *)
+  let attrs =
+    match optid with
+    | None -> []
+    | Some (loc, id) ->
+        let start, stop = unlock loc in
+        ["begin", start; "end", stop ; "name", Id.to_string id] in
+  let kind, expr =
+    match roe with
+    | CStructRec -> "struct", []
+    | CWfRec e -> "rec", [pp_expr e]
+    | CMeasureRec (e, None) -> "mesrec", [pp_expr e]
+    | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in
+  Element ("recursion_order", ["kind", kind] @ attrs, expr)
+and pp_fixpoint_expr ((loc, id), (optid, roe), lbl, ce, ceo) =
+  (* fixpoint_expr *)
+  let start, stop = unlock loc in
+  let id = Id.to_string id in
+  [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
+  (* fixpoint name *)
+  [pp_recursion_order_expr optid roe] @
+  (List.map pp_local_binder lbl) @
+  [pp_expr ce] @
+  begin match ceo with (* don't know what it is for now *)
+  | Some ce -> [pp_expr ce]
+  | None -> []
+  end
+and pp_cofixpoint_expr ((loc, id), lbl, ce, ceo) = (* cofixpoint_expr *)
+  (* Nota: it is like fixpoint_expr without (optid, roe)
+   * so could be merged if there is no more differences *)
+  let start, stop = unlock loc in
+  let id = Id.to_string id in
+  [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @
+  (* cofixpoint name *)
+  (List.map pp_local_binder lbl) @
+  [pp_expr ce] @
+  begin match ceo with (* don't know what it is for now *)
+  | Some ce -> [pp_expr ce]
+  | None -> []
+  end
+and pp_lident (loc, id) = xmlCst (Id.to_string id) loc
+and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce]
+and pp_cases_pattern_expr cpe =
+  match cpe with
+  | CPatAlias (loc, cpe, id) ->
+      xmlApply loc
+        (xmlOperator "alias" ~attr:["name", string_of_id id] loc ::
+          [pp_cases_pattern_expr cpe])
+  | CPatCstr (loc, ref, cpel1, cpel2) ->
+      xmlApply loc
+        (xmlOperator "reference"
+           ~attr:["name", Libnames.string_of_reference ref] loc ::
+         [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1));
+          Element ("args", [], (List.map pp_cases_pattern_expr cpel2))])
+  | CPatAtom (loc, optr) ->
+      let attrs = match optr with
+        | None -> []
+        | Some r -> ["name", Libnames.string_of_reference r] in
+      xmlApply loc (xmlOperator "atom" ~attr:attrs loc :: [])
+  | CPatOr (loc, cpel) ->
+      xmlApply loc (xmlOperator "or" loc :: List.map pp_cases_pattern_expr cpel)
+  | CPatNotation (loc, n, (subst_constr, subst_rec), cpel) ->
+      xmlApply loc
+        (xmlOperator "notation" loc ::
+          [xmlOperator n loc;
+           Element ("subst", [],
+             [Element ("subterms", [],
+                List.map pp_cases_pattern_expr subst_constr);
+              Element ("recsubterms", [],
+                List.map
+                  (fun (cpel) ->
+                     Element ("recsubterm", [],
+                       List.map pp_cases_pattern_expr cpel))
+                subst_rec)]);
+           Element ("args", [], (List.map pp_cases_pattern_expr cpel))])
+  | CPatPrim (loc, tok) -> pp_token loc tok
+  | CPatRecord (loc, rcl) ->
+      xmlApply loc
+        (xmlOperator "record" loc ::
+           List.map (fun (r, cpe) ->
+             Element ("field",
+               ["reference", Libnames.string_of_reference r],
+               [pp_cases_pattern_expr cpe]))
+           rcl)
+  | CPatDelimiters (loc, delim, cpe) ->
+      xmlApply loc
+        (xmlOperator "delimiter" ~attr:["name", delim] loc ::
+          [pp_cases_pattern_expr cpe])
+and pp_case_expr (e, (name, pat)) =
+  match name, pat with
+  | None, None -> xmlScrutinee [pp_expr e]
+  | Some (loc, name), None ->
+      let start, stop= unlock loc in
+      xmlScrutinee ~attr:["name", string_of_name name;
+                          "begin", start; "end", stop] [pp_expr e]
+  | Some (loc, name), Some p ->
+      let start, stop= unlock loc in
+      xmlScrutinee ~attr:["name", string_of_name name;
+                          "begin", start; "end", stop]
+        [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
+  | None, Some p ->
+      xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e]
+and pp_branch_expr_list bel =
+  xmlWith
+    (List.map
+      (fun (_, cpel, e) ->
+        let ppcepl =
+          List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in
+        let ppe = [pp_expr e] in
+        xmlCase (ppcepl @ ppe))
+     bel)
+and pp_token loc tok =
+  let tokstr =
+    match tok with
+    | String s -> PCData s
+    | Numeral n -> PCData (to_string n) in
+  xmlToken loc [tokstr]
+and pp_local_binder_list lbl =
+  let l = (List.map pp_local_binder lbl) in
+  Element ("recurse", (backstep_loc l), l)
+and pp_const_expr_list cel =
+  let l = List.map pp_expr cel in
+  Element ("recurse", (backstep_loc l), l)
+and pp_expr ?(attr=[]) e =
+  match e with
+  | CRef (r, _) ->
+      xmlCst ~attr
+        (Libnames.string_of_reference r) (Libnames.loc_of_reference r)
+  | CProdN (loc, bl, e) ->
+      xmlApply loc
+        (xmlOperator "forall" loc :: [pp_bindlist bl] @ [pp_expr e])
+  | CApp (loc, (_, hd), args) ->
+       xmlApply ~attr loc (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args)
+  | CAppExpl (loc, (_, r, _), args) ->
+       xmlApply ~attr loc
+         (xmlCst (Libnames.string_of_reference r)
+                 (Libnames.loc_of_reference r) :: List.map pp_expr args)
+  | CNotation (loc, notation,  ([],[],[])) ->
+       xmlOperator notation loc
+  | CNotation (loc, notation,  (args, cell, lbll)) ->
+      let fmts = Notation.find_notation_extra_printing_rules notation in
+      let oper = xmlOperator notation loc ~pprules:fmts in
+      let cels = List.map pp_const_expr_list cell in
+      let lbls = List.map pp_local_binder_list lbll in
+      let args = List.map pp_expr args in
+      xmlApply loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls)))
+  | CSort(loc, s) ->
+      xmlOperator (string_of_glob_sort s) loc
+  | CDelimiters (loc, scope, ce) ->
+      xmlApply loc (xmlOperator "delimiter" ~attr:["name", scope] loc ::
+        [pp_expr ce])
+  | CPrim (loc, tok) -> pp_token loc tok
+  | CGeneralization (loc, kind, _, e) ->
+      let kind= match kind with
+      | Explicit -> "explicit"
+      | Implicit -> "implicit" in
+      xmlApply loc
+        (xmlOperator "generalization" ~attr:["kind", kind] loc :: [pp_expr e])
+  | CCast (loc, e, tc) ->
+      begin match tc with
+      | CastConv t | CastVM t |CastNative t ->
+          xmlApply loc
+            (xmlOperator ":" loc ~attr:["kind", (string_of_cast_sort tc)] ::
+             [pp_expr e; pp_expr t])
+      | CastCoerce   ->
+          xmlApply loc
+            (xmlOperator ":" loc ~attr:["kind", "CastCoerce"] ::
+             [pp_expr e])
+      end
+  | CEvar (loc, ek, cel) ->
+      let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in
+      xmlApply loc
+        (xmlOperator "evar" loc ~attr:["id", string_of_id ek] ::
+          ppcel)
+  | CPatVar (loc, id) -> xmlPatvar (string_of_id id) loc
+  | CHole (loc, _, _, _) -> xmlCst ~attr  "_" loc
+  | CIf (loc, test, (_, ret), th, el) ->
+      let return = match ret with
+      | None -> []
+      | Some r -> [xmlReturn [pp_expr r]] in
+      xmlApply loc
+        (xmlOperator "if" loc ::
+          return @ [pp_expr th] @ [pp_expr el])
+  | CLetTuple (loc, names, (_, ret), value, body) ->
+      let return = match ret with
+      | None -> []
+      | Some r -> [xmlReturn [pp_expr r]] in
+      xmlApply loc
+        (xmlOperator "lettuple" loc ::
+          return @
+          (List.map (fun (loc, var) -> xmlCst (string_of_name var) loc) names) @
+          [pp_expr value; pp_expr body])
+  | CCases (loc, sty, ret, cel, bel) ->
+      let return = match ret with
+      | None -> []
+      | Some r -> [xmlReturn [pp_expr r]] in
+      xmlApply loc
+        (xmlOperator "match" loc  ~attr:["style", (string_of_case_style sty)] ::
+          (return @
+           [Element ("scrutinees", [], List.map pp_case_expr cel)] @
+           [pp_branch_expr_list bel]))
+  | CRecord (_, _, _) -> assert false
+  | CLetIn (loc, (varloc, var), value, body) ->
+      xmlApply loc
+        (xmlOperator "let" loc ::
+         [xmlCst (string_of_name var) varloc; pp_expr value; pp_expr body])
+  | CLambdaN (loc, bl, e) ->
+      xmlApply loc
+        (xmlOperator "lambda" loc :: [pp_bindlist bl] @ [pp_expr e])
+  | CCoFix (_, _, _) -> assert false
+  | CFix (loc, lid, fel) ->
+      xmlApply loc
+        (xmlOperator "fix" loc ::
+           List.flatten (List.map
+             (fun (a,b,cl,c,d) -> pp_fixpoint_expr (a,b,cl,c,Some d))
+             fel))
+
+let pp_comment (c) =
+  match c with
+  | CommentConstr e -> [pp_expr e]
+  | CommentString s -> [Element ("string", [], [PCData s])]
+  | CommentInt i -> [PCData (string_of_int i)]
+
+let rec tmpp v loc =
+  match v with
+  (* Control *)
+  | VernacLoad (verbose,f) ->
+      xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] []
+  | VernacTime l ->
+      xmlApply loc (Element("time",[],[]) ::
+                    List.map (fun(loc,e) ->tmpp e loc) l)
+  | VernacTimeout (s,e) ->
+      xmlApply loc (Element("timeout",["val",string_of_int s],[]) ::
+                    [tmpp e loc])
+  | VernacFail e -> xmlApply loc (Element("fail",[],[]) :: [tmpp e loc])
+  | VernacError _ -> xmlWithLoc loc "error" [] []
+
+  (* Syntax *)
+  | VernacTacticNotation _ as x ->
+      xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+  | VernacSyntaxExtension (_, ((_, name), sml)) ->
+      let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+      xmlReservedNotation attrs name loc
+
+  | VernacOpenCloseScope (_,(true,name)) -> xmlScope loc "open" name []
+  | VernacOpenCloseScope (_,(false,name)) -> xmlScope loc "close" name []
+  | VernacDelimiters (name,tag) ->
+      xmlScope loc "delimit" name ~attr:["delimiter",tag] []
+  | VernacBindScope (name,l) ->
+      xmlScope loc "bind" name
+        (List.map (function
+          | ByNotation(loc,name,None) -> xmlNotation [] name loc []
+          | ByNotation(loc,name,Some d) ->
+              xmlNotation ["delimiter",d] name loc []
+          | AN ref -> xmlReference ref) l)
+  | VernacInfix (_,((_,name),sml),ce,sn) ->
+      let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+      let sc_attr =
+        match sn with
+        | Some scope -> ["scope", scope]
+        | None -> [] in
+      xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
+  | VernacNotation (_, ce, (lstr, sml), sn) ->
+      let name = snd lstr in
+      let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in
+      let sc_attr =
+        match sn with
+        | Some scope -> ["scope", scope]
+        | None -> [] in
+      xmlNotation (sc_attr @ attrs) name loc [pp_expr ce]
+  | VernacNotationAddFormat _ as x -> xmlTODO loc x
+  | VernacUniverse _
+  | VernacConstraint _
+  | VernacPolymorphic (_, _) as x -> xmlTODO loc x
+  (* Gallina *)
+  | VernacDefinition (ldk, (_,id), de) ->
+      let l, dk =
+        match ldk with
+        | Some l, dk -> (l, dk)
+        | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *)
+      let e =
+        match de with
+        | ProveBody (_, ce) -> ce
+        | DefineBody (_, Some _, ce, None) -> ce
+        | DefineBody (_, None  , ce, None) -> ce
+        | DefineBody (_, Some _, ce, Some _) -> ce
+        | DefineBody (_, None  , ce, Some _) -> ce in
+      let str_dk = Kindops.string_of_definition_kind (l, false, dk) in
+      let str_id = Id.to_string id in
+      (xmlDef str_dk str_id loc [pp_expr e])
+  | VernacStartTheoremProof (tk, [ Some (_,id), ([], statement, None) ], b) ->
+      let str_tk = Kindops.string_of_theorem_kind tk in
+      let str_id = Id.to_string id in
+      (xmlThm str_tk str_id loc [pp_expr statement])
+  | VernacStartTheoremProof _ as x -> xmlTODO loc x
+  | VernacEndProof pe ->
+      begin
+        match pe with
+        | Admitted -> xmlQed loc
+        | Proved (_, Some ((_, id), Some tk)) ->
+            let nam = Id.to_string id in
+            let typ = Kindops.string_of_theorem_kind tk in
+            xmlQed ~attr:["name", nam; "type", typ] loc
+        | Proved (_, Some ((_, id), None)) ->
+            let nam = Id.to_string id in
+            xmlQed ~attr:["name", nam] loc
+        | Proved _ -> xmlQed loc
+      end
+  | VernacExactProof _ as x -> xmlTODO loc x
+  | VernacAssumption ((l, a), _, sbwcl) ->
+      let many =
+        List.length (List.flatten (List.map fst (List.map snd sbwcl))) > 1 in
+      let exprs =
+        List.flatten (List.map pp_simple_binder (List.map snd sbwcl)) in
+      let l = match l with Some x -> x | None -> Decl_kinds.Global in
+      let kind = string_of_assumption_kind l a many in
+      xmlAssumption kind loc exprs
+  | VernacInductive (_, _, iednll) ->
+      let kind =
+        let (_, _, _, k, _),_ = List.hd iednll in
+	  begin
+            match k with
+            | Record -> "Record"
+            | Structure -> "Structure"
+            | Inductive_kw -> "Inductive"
+            | CoInductive -> "CoInductive"
+            | Class _ -> "Class"
+            | Variant -> "Variant"
+          end in
+      let exprs =
+        List.flatten (* should probably not be flattened *)
+          (List.map
+            (fun (ie, dnl) -> (pp_inductive_expr ie) @
+                              (List.map pp_decl_notation dnl)) iednll) in
+      xmlInductive kind loc exprs
+  | VernacFixpoint (_, fednll) ->
+      let exprs =
+        List.flatten (* should probably not be flattened *)
+          (List.map
+            (fun (fe, dnl) -> (pp_fixpoint_expr fe) @
+                              (List.map pp_decl_notation dnl)) fednll) in
+      xmlFixpoint exprs
+  | VernacCoFixpoint (_, cfednll) ->
+      (* Nota: it is like VernacFixpoint without so could be merged *)
+      let exprs =
+        List.flatten (* should probably not be flattened *)
+          (List.map
+            (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @
+                              (List.map pp_decl_notation dnl)) cfednll) in
+      xmlCoFixpoint exprs
+  | VernacScheme _ as x -> xmlTODO loc x
+  | VernacCombinedScheme _ as x -> xmlTODO loc x
+
+  (* Gallina extensions *)
+  | VernacBeginSection (_, id) -> xmlBeginSection loc (Id.to_string id)
+  | VernacEndSegment (_, id) -> xmlEndSegment loc (Id.to_string id)
+  | VernacNameSectionHypSet _ as x -> xmlTODO loc x
+  | VernacRequire (None,l) ->
+      xmlRequire loc (List.map (fun ref ->
+        xmlReference ref) l)
+  | VernacRequire (Some true,l) ->
+      xmlRequire loc ~attr:["export","true"] (List.map (fun ref ->
+        xmlReference ref) l)
+  | VernacRequire (Some false,l) ->
+      xmlRequire loc ~attr:["import","true"] (List.map (fun ref ->
+        xmlReference ref) l)
+  | VernacImport (true,l) ->
+      xmlImport loc ~attr:["export","true"] (List.map (fun ref ->
+        xmlReference ref) l)
+  | VernacImport (false,l) ->
+      xmlImport loc (List.map (fun ref ->
+        xmlReference ref) l)
+  | VernacCanonical r ->
+      let attr =
+        match r with
+        | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q]
+        | AN (Ident (_, id)) -> ["id", Id.to_string id]
+        | ByNotation (_, s, _) -> ["notation", s] in
+      xmlCanonicalStructure attr loc
+  | VernacCoercion _ as x -> xmlTODO loc x
+  | VernacIdentityCoercion _ as x -> xmlTODO loc x
+
+  (* Type classes *)
+  | VernacInstance _ as x -> xmlTODO loc x
+
+  | VernacContext _ as x -> xmlTODO loc x
+
+  | VernacDeclareInstances _ as x -> xmlTODO loc x
+
+  | VernacDeclareClass _ as x -> xmlTODO loc x
+
+  (* Modules and Module Types *)
+  | VernacDeclareModule _ as x -> xmlTODO loc x
+  | VernacDefineModule _ as x -> xmlTODO loc x
+  | VernacDeclareModuleType _ as x -> xmlTODO loc x
+  | VernacInclude _ as x -> xmlTODO loc x
+
+  (* Solving *)
+
+  | (VernacSolve _ | VernacSolveExistential _) as x ->
+      xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+  (* Auxiliary file and library management *)
+  | VernacAddLoadPath (recf,name,None) ->
+      xmlAddLoaPath loc ~attr:["rec",string_of_bool recf;"path",name] []
+  | VernacAddLoadPath (recf,name,Some dp) ->
+      xmlAddLoaPath loc ~attr:["rec",string_of_bool recf;"path",name]
+        [PCData (Names.DirPath.to_string dp)]
+                 
+  | VernacRemoveLoadPath name -> xmlRemoveLoaPath loc ~attr:["path",name] []
+  | VernacAddMLPath (recf,name) ->
+      xmlAddMLPath loc ~attr:["rec",string_of_bool recf;"path",name] []
+  | VernacDeclareMLModule sl -> xmlDeclareMLModule loc sl
+  | VernacChdir _ as x -> xmlTODO loc x
+
+  (* State management *)
+  | VernacWriteState _ as x -> xmlTODO loc x
+  | VernacRestoreState _ as x -> xmlTODO loc x
+
+  (* Resetting *)
+  | VernacResetName _ as x -> xmlTODO loc x
+  | VernacResetInitial as x -> xmlTODO loc x
+  | VernacBack _ as x -> xmlTODO loc x
+  | VernacBackTo _ -> PCData "VernacBackTo"
+
+  (* Commands *)
+  | VernacDeclareTacticDefinition _ as x -> xmlTODO loc x
+  | VernacCreateHintDb _ as x -> xmlTODO loc x
+  | VernacRemoveHints _ as x -> xmlTODO loc x
+  | VernacHints _ as x -> xmlTODO loc x
+  | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) ->
+      let name = Id.to_string name in
+      let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in
+      xmlNotation attrs name loc [pp_expr ce]
+  | VernacDeclareImplicits _ as x -> xmlTODO loc x
+  | VernacArguments _ as x -> xmlTODO loc x
+  | VernacArgumentsScope _ as x -> xmlTODO loc x
+  | VernacReserve _ as x -> xmlTODO loc x
+  | VernacGeneralizable _ as x -> xmlTODO loc x
+  | VernacSetOpacity _ as x -> xmlTODO loc x
+  | VernacSetStrategy _ as x -> xmlTODO loc x
+  | VernacUnsetOption _ as x -> xmlTODO loc x
+  | VernacSetOption _ as x -> xmlTODO loc x
+  | VernacAddOption _ as x -> xmlTODO loc x
+  | VernacRemoveOption _ as x -> xmlTODO loc x
+  | VernacMemOption _ as x -> xmlTODO loc x
+  | VernacPrintOption _ as x -> xmlTODO loc x
+  | VernacCheckMayEval (_,_,e) -> xmlCheck loc [pp_expr e]
+  | VernacGlobalCheck _ as x -> xmlTODO loc x
+  | VernacDeclareReduction _ as x -> xmlTODO loc x
+  | VernacPrint _ as x -> xmlTODO loc x
+  | VernacSearch _ as x -> xmlTODO loc x
+  | VernacLocate _ as x -> xmlTODO loc x
+  | VernacRegister _ as x -> xmlTODO loc x
+  | VernacComments (cl) ->
+      xmlComment loc (List.flatten (List.map pp_comment cl))
+  | VernacNop as x -> xmlTODO loc x
+
+  (* Stm backdoor *)
+  | VernacStm _ as x -> xmlTODO loc x
+
+  (* Proof management *)
+  | VernacGoal _ as x -> xmlTODO loc x
+  | VernacAbort _ as x -> xmlTODO loc x
+  | VernacAbortAll -> PCData "VernacAbortAll"
+  | VernacRestart as x -> xmlTODO loc x
+  | VernacUndo _ as x -> xmlTODO loc x
+  | VernacUndoTo _ as x -> xmlTODO loc x
+  | VernacBacktrack _ as x -> xmlTODO loc x
+  | VernacFocus _ as x -> xmlTODO loc x
+  | VernacUnfocus as x -> xmlTODO loc x
+  | VernacUnfocused as x -> xmlTODO loc x
+  | VernacBullet _ as x -> xmlTODO loc x
+  | VernacSubproof _ as x -> xmlTODO loc x
+  | VernacEndSubproof as x -> xmlTODO loc x
+  | VernacShow _ as x -> xmlTODO loc x
+  | VernacCheckGuard as x -> xmlTODO loc x
+  | VernacProof (tac,using) ->
+      let tac = Option.map (xmlRawTactic "closingtactic") tac in
+      let using = Option.map (xmlSectionSubsetDescr "using") using in
+      xmlProof loc (Option.List.(cons tac (cons using [])))
+  | VernacProofMode name -> xmlProofMode loc name
+
+  (* Toplevel control *)
+  | VernacToplevelControl _ as x -> xmlTODO loc x
+
+  (* For extension *)
+  | VernacExtend _ as x ->
+      xmlExtend loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))]
+
+  (* Flags *)
+  | VernacProgram e -> xmlApply loc (Element("program",[],[]) :: [tmpp e loc])
+  | VernacLocal (b,e) ->
+      xmlApply loc (Element("local",["flag",string_of_bool b],[]) ::
+                    [tmpp e loc])
+
+let tmpp v loc =
+  match tmpp v loc with
+  | Element("ltac",_,_) as x -> x
+  | xml -> xmlGallina loc [xml]
diff --git a/tactics/refine.mli b/stm/texmacspp.mli
index 47c00983..58dec8fd 100644
--- a/tactics/refine.mli
+++ b/stm/texmacspp.mli
@@ -1,11 +1,12 @@
 (************************************************************************)
 (*  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 Tacmach
+open Xml_datatype
+open Vernacexpr
 
-val refine : Evd.open_constr -> tactic
+val tmpp : vernac_expr -> Loc.t -> xml
diff --git a/stm/vcs.ml b/stm/vcs.ml
new file mode 100644
index 00000000..dfcbc19a
--- /dev/null
+++ b/stm/vcs.ml
@@ -0,0 +1,193 @@
+(************************************************************************)
+(*  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 Pp
+open Errors
+
+module type S = sig
+
+  module Branch :
+  sig
+    type t
+    val make : string -> t
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+    val to_string : t -> string
+    val master : t
+  end
+
+  type id
+
+  (* Branches have [branch_info] attached to them. *)
+  type ('kind) branch_info = {
+    kind : [> `Master] as 'kind;
+    root : id;
+    pos  : id;
+  }
+
+  type ('kind,'diff,'info) t constraint 'kind = [> `Master ]
+
+  val empty : id -> ('kind,'diff,'info) t
+
+  val current_branch : ('k,'e,'i) t -> Branch.t
+  val branches : ('k,'e,'i) t -> Branch.t list
+
+  val get_branch : ('k,'e,'i) t -> Branch.t -> 'k branch_info
+  val reset_branch : ('k,'e,'i) t -> Branch.t -> id -> ('k,'e,'i) t
+  val branch :
+    ('kind,'e,'i) t -> ?root:id -> ?pos:id ->
+        Branch.t -> 'kind -> ('kind,'e,'i) t
+  val delete_branch : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t
+  val merge :
+    ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t ->
+            Branch.t -> ('k,'diff,'i) t
+  val commit : ('k,'diff,'i) t -> id -> 'diff -> ('k,'diff,'i) t
+  val rewrite_merge :
+    ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> at:id ->
+            Branch.t -> ('k,'diff,'i) t
+  val checkout : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t
+
+  val set_info : ('k,'e,'info) t -> id -> 'info -> ('k,'e,'info) t
+  val get_info : ('k,'e,'info) t -> id -> 'info option
+  
+  module NodeSet : Set.S with type elt = id
+
+  val gc : ('k,'e,'info) t -> ('k,'e,'info) t * NodeSet.t
+
+  val reachable : ('k,'e,'info) t -> id -> NodeSet.t
+
+  module Dag : Dag.S with type node = id
+  val dag : ('kind,'diff,'info) t -> ('diff,'info,id*id) Dag.t
+
+  val create_cluster : ('k,'e,'i) t -> id list -> (id * id) -> ('k,'e,'i) t
+  val cluster_of : ('k,'e,'i) t -> id -> (id * id) Dag.Cluster.t option
+  val delete_cluster : ('k,'e,'i) t -> (id * id) Dag.Cluster.t -> ('k,'e,'i) t 
+
+end
+
+module Make(OT : Map.OrderedType) = struct
+
+module Dag = Dag.Make(OT)
+
+type id = OT.t
+
+module NodeSet = Dag.NodeSet
+
+
+module Branch =
+struct
+  type t = string
+  let make =
+    let bid = ref 0 in
+    fun s -> incr bid; string_of_int !bid ^ "_" ^ s
+  let equal = CString.equal
+  let compare = CString.compare
+  let to_string s = s
+  let master = "master"
+end
+
+module BranchMap = Map.Make(Branch)
+
+type 'kind branch_info = {
+  kind : [> `Master] as 'kind;
+  root : id;
+  pos  : id;
+}
+
+type ('kind,'edge,'info) t = {
+  cur_branch   : Branch.t;
+  heads        : 'kind branch_info BranchMap.t;
+  dag          : ('edge,'info,id*id) Dag.t;
+}
+
+let empty root = {
+  cur_branch = Branch.master;
+  heads = BranchMap.singleton Branch.master { root = root; pos = root; kind = `Master };
+  dag = Dag.empty;
+}
+
+let add_node vcs id edges =
+  assert (not (CList.is_empty edges));
+  { vcs with dag =
+     List.fold_left (fun g (t,tgt) -> Dag.add_edge g id t tgt) vcs.dag edges }
+
+let get_branch vcs head =
+  try BranchMap.find head vcs.heads
+  with Not_found -> anomaly (str"head " ++ str head ++ str" not found")
+
+let reset_branch vcs head id =
+  let map name h =
+    if Branch.equal name head then { h with pos = id } else h
+  in
+  { vcs with heads = BranchMap.mapi map vcs.heads; }
+
+let current_branch vcs = vcs.cur_branch
+
+let branch
+  vcs ?(root=(get_branch vcs vcs.cur_branch).pos) ?(pos=root) name kind
+=
+  { vcs with
+      heads = BranchMap.add name { kind; root; pos } vcs.heads;
+      cur_branch = name }
+
+let delete_branch vcs name =
+  if Branch.equal Branch.master name then vcs else
+  let filter n _ = not (Branch.equal n name) in
+  { vcs with heads = BranchMap.filter filter vcs.heads }
+
+let merge vcs id ~ours:tr1 ~theirs:tr2 ?(into = vcs.cur_branch) name =
+  assert (not (Branch.equal name into));
+  let br_id = (get_branch vcs name).pos in
+  let cur_id = (get_branch vcs into).pos in
+  let vcs = add_node vcs id [tr1,cur_id; tr2,br_id] in
+  let vcs = reset_branch vcs into id in
+  vcs
+
+let del_edge id vcs tgt = { vcs with dag = Dag.del_edge vcs.dag id tgt }
+
+let rewrite_merge vcs id ~ours:tr1 ~theirs:tr2 ~at:cur_id name =
+  let br_id = (get_branch vcs name).pos in
+  let old_edges = List.map fst (Dag.from_node vcs.dag id) in
+  let vcs = List.fold_left (del_edge id) vcs old_edges in
+  let vcs = add_node vcs id [tr1,cur_id; tr2,br_id] in
+  vcs
+
+let commit vcs id tr =
+  let vcs = add_node vcs id [tr, (get_branch vcs vcs.cur_branch).pos] in
+  let vcs = reset_branch vcs vcs.cur_branch id in
+  vcs
+
+let checkout vcs name = { vcs with cur_branch = name }
+
+let set_info vcs id info = { vcs with dag = Dag.set_info vcs.dag id info }
+let get_info vcs id = Dag.get_info vcs.dag id
+
+let create_cluster vcs l i = { vcs with dag = Dag.create_cluster vcs.dag l i }
+let cluster_of vcs i = Dag.cluster_of vcs.dag i
+let delete_cluster vcs c = { vcs with dag = Dag.del_cluster vcs.dag c }
+
+let branches vcs = BranchMap.fold (fun x _ accu -> x :: accu) vcs.heads []
+let dag vcs = vcs.dag
+
+let rec closure s d n =
+  let l = try Dag.from_node d n with Not_found -> [] in
+  List.fold_left (fun s (n',_) ->
+    if Dag.NodeSet.mem n' s then s
+    else closure s d n')
+  (Dag.NodeSet.add n s) l
+
+let reachable vcs i = closure Dag.NodeSet.empty vcs.dag i
+
+let gc vcs =
+  let alive =
+    BranchMap.fold (fun b { pos } s -> closure s vcs.dag pos)
+      vcs.heads Dag.NodeSet.empty in
+  let dead = Dag.NodeSet.diff (Dag.all_nodes vcs.dag) alive in
+  { vcs with dag = Dag.del_nodes vcs.dag dead }, dead
+
+end
diff --git a/stm/vcs.mli b/stm/vcs.mli
new file mode 100644
index 00000000..fb79d02c
--- /dev/null
+++ b/stm/vcs.mli
@@ -0,0 +1,90 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(* This module builds a VCS like interface on top of Dag, used to build
+   a Dag instance by the State Transaction Machine.
+
+   This data structure does not hold system states:
+   - Edges are meant to hold a diff.
+     The delta between two states, or equivalent data like a vernac_expr whose
+     execution corresponds to the application of the diff.
+   - Nodes are empty, unless one adds explicit info.
+     The info could be a system state, obtaind by applying all the diffs
+     from the initial state, but is not necessarily there.
+   As a consequence, "checkout" just updates the current branch.
+
+   The type [id] is the type of commits (a node in the dag)
+   The type [Vcs.t] has 3 parameters:
+    ['info] data attached to a node (like a system state)
+    ['diff] data attached to an edge (the commit content, a "patch")
+    ['kind] extra data attached to a branch (like being the master branch)
+*)
+
+module type S = sig
+
+  module Branch :
+  sig
+    type t
+    val make : string -> t
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+    val to_string : t -> string
+    val master : t
+  end
+
+  type id
+  
+  type ('kind) branch_info = {
+    kind : [> `Master] as 'kind;
+    root : id;
+    pos  : id;
+  }
+  
+  type ('kind,'diff,'info) t constraint 'kind = [> `Master ]
+  
+  val empty : id -> ('kind,'diff,'info) t
+  
+  val current_branch : ('k,'e,'i) t -> Branch.t
+  val branches : ('k,'e,'i) t -> Branch.t list
+  
+  val get_branch : ('k,'e,'i) t -> Branch.t -> 'k branch_info
+  val reset_branch : ('k,'e,'i) t -> Branch.t -> id -> ('k,'e,'i) t
+  val branch :
+    ('kind,'e,'i) t -> ?root:id -> ?pos:id ->
+        Branch.t -> 'kind -> ('kind,'e,'i) t
+  val delete_branch : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t
+  val merge :
+    ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t ->
+            Branch.t -> ('k,'diff,'i) t
+  val commit : ('k,'diff,'i) t -> id -> 'diff -> ('k,'diff,'i) t
+  val rewrite_merge :
+    ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> at:id ->
+            Branch.t -> ('k,'diff,'i) t
+  val checkout : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t
+  
+  val set_info : ('k,'e,'info) t -> id -> 'info -> ('k,'e,'info) t
+  val get_info : ('k,'e,'info) t -> id -> 'info option
+
+  module NodeSet : Set.S with type elt = id
+  
+  (* Removes all unreachable nodes and returns them *)
+  val gc : ('k,'e,'info) t -> ('k,'e,'info) t * NodeSet.t
+
+  val reachable : ('k,'e,'info) t -> id -> NodeSet.t
+
+  (* read only dag *)
+  module Dag : Dag.S with type node = id
+  val dag : ('kind,'diff,'info) t -> ('diff,'info,id * id) Dag.t
+ 
+  val create_cluster : ('k,'e,'i) t -> id list -> (id * id) -> ('k,'e,'i) t
+  val cluster_of : ('k,'e,'i) t -> id -> (id * id) Dag.Cluster.t option
+  val delete_cluster : ('k,'e,'i) t -> (id * id) Dag.Cluster.t -> ('k,'e,'i) t 
+
+end
+
+module Make(OT : Map.OrderedType) : S with type id = OT.t
diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml
new file mode 100644
index 00000000..e9302bb7
--- /dev/null
+++ b/stm/vernac_classifier.ml
@@ -0,0 +1,227 @@
+(************************************************************************)
+(*  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 Vernacexpr
+open Errors
+open Pp
+
+let string_of_in_script b = if b then " (inside script)" else ""
+
+let string_of_vernac_type = function
+  | VtUnknown -> "Unknown"
+  | VtStartProof _ -> "StartProof"
+  | VtSideff _ -> "Sideff"
+  | VtQed VtKeep -> "Qed(keep)"
+  | VtQed VtKeepAsAxiom -> "Qed(admitted)"
+  | VtQed VtDrop -> "Qed(drop)"
+  | VtProofStep false -> "ProofStep"
+  | VtProofStep true -> "ProofStep (parallel)"
+  | VtProofMode s -> "ProofMode " ^ s
+  | VtQuery (b,(id,route)) ->
+      "Query " ^ string_of_in_script b ^ " report " ^ Stateid.to_string id ^
+      " route " ^ string_of_int route
+  | VtStm ((VtFinish|VtJoinDocument|VtObserve _|VtPrintDag|VtWait), b) ->
+      "Stm " ^ string_of_in_script b
+  | VtStm (VtPG, b) -> "Stm PG " ^ string_of_in_script b
+  | VtStm (VtBack _, b) -> "Stm Back " ^ string_of_in_script b
+
+let string_of_vernac_when = function
+  | VtLater -> "Later"
+  | VtNow -> "Now"
+
+let string_of_vernac_classification (t,w) =
+  string_of_vernac_type t ^ " " ^ string_of_vernac_when w
+
+let classifiers = ref []
+let declare_vernac_classifier
+  (s : Vernacexpr.extend_name)
+  (f : Genarg.raw_generic_argument list -> unit -> vernac_classification)
+=
+  classifiers := !classifiers @ [s,f]
+
+let elide_part_of_script_and_now (a, _) =
+  match a with
+  | VtQuery (_,id) -> VtQuery (false,id), VtNow
+  | VtStm (x, _) -> VtStm (x, false), VtNow
+  | x -> x, VtNow
+
+let make_polymorphic (a, b as x) =
+  match a with
+  | VtStartProof (x, _, ids) ->
+      VtStartProof (x, Doesn'tGuaranteeOpacity, ids), b
+  | _ -> x
+
+let undo_classifier = ref (fun _ -> assert false)
+let set_undo_classifier f = undo_classifier := f
+
+let rec classify_vernac e =
+  let rec static_classifier e = match e with
+    (* PG compatibility *)
+    | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"])
+    | VernacSetOption   ((["Silent"]|["Undo"]|["Printing";"Depth"]),_)
+      when !Flags.print_emacs -> VtStm(VtPG,false), VtNow
+    (* Stm *)
+    | VernacStm Finish -> VtStm (VtFinish, true), VtNow
+    | VernacStm Wait -> VtStm (VtWait, true), VtNow
+    | VernacStm JoinDocument -> VtStm (VtJoinDocument, true), VtNow
+    | VernacStm PrintDag -> VtStm (VtPrintDag, true), VtNow
+    | VernacStm (Observe id) -> VtStm (VtObserve id, true), VtNow
+    | VernacStm (Command x) -> elide_part_of_script_and_now (classify_vernac x)
+    | VernacStm (PGLast x) -> fst (classify_vernac x), VtNow
+    (* Nested vernac exprs *)
+    | VernacProgram e -> classify_vernac e
+    | VernacLocal (_,e) -> classify_vernac e
+    | VernacPolymorphic (b, e) -> 
+      if b || Flags.is_universe_polymorphism () (* Ok or not? *) then
+	make_polymorphic (classify_vernac e)
+      else classify_vernac e
+    | VernacTimeout (_,e) -> classify_vernac e
+    | VernacTime e -> classify_vernac_list e
+    | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *)
+        (match classify_vernac e with
+        | ( VtQuery _ | VtProofStep _ | VtSideff _
+          | VtStm _ | VtProofMode _ ), _ as x -> x
+        | VtQed _, _ -> VtProofStep false, VtNow
+        | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow)
+    (* Qed *)
+    | VernacAbort _ -> VtQed VtDrop, VtLater
+    | VernacEndProof Admitted -> VtQed VtKeepAsAxiom, VtLater
+    | VernacEndProof _ | VernacExactProof _ -> VtQed VtKeep, VtLater
+    (* Query *)
+    | VernacShow _ | VernacPrint _ | VernacSearch _ | VernacLocate _
+    | VernacCheckMayEval _ ->
+        VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater
+    (* ProofStep *)
+    | VernacSolve (SelectAllParallel,_,_,_) -> VtProofStep true, VtLater
+    | VernacProof _ 
+    | VernacBullet _ 
+    | VernacFocus _ | VernacUnfocus
+    | VernacSubproof _ | VernacEndSubproof
+    | VernacSolve _ 
+    | VernacCheckGuard
+    | VernacUnfocused
+    | VernacSolveExistential _ -> VtProofStep false, VtLater
+    (* Options changing parser *)
+    | VernacUnsetOption (["Default";"Proof";"Using"])
+    | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow
+    (* StartProof *)
+    | VernacDefinition (
+       (Some Decl_kinds.Discharge,Decl_kinds.Definition),(_,i),ProveBody _) ->
+        VtStartProof("Classic",Doesn'tGuaranteeOpacity,[i]), VtLater
+    | VernacDefinition (_,(_,i),ProveBody _) ->
+        VtStartProof("Classic",GuaranteesOpacity,[i]), VtLater
+    | VernacStartTheoremProof (_,l,_) ->
+        let ids = 
+          CList.map_filter (function (Some(_,i), _) -> Some i | _ -> None) l in
+        VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater
+    | VernacGoal _ -> VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater
+    | VernacFixpoint (_,l) ->
+        let ids, open_proof =
+          List.fold_left (fun (l,b) (((_,id),_,_,_,p),_) ->
+            id::l, b || p = None) ([],false) l in
+        if open_proof
+        then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater
+        else VtSideff ids, VtLater
+    | VernacCoFixpoint (_,l) ->
+        let ids, open_proof =
+          List.fold_left (fun (l,b) (((_,id),_,_,p),_) ->
+            id::l, b || p = None) ([],false) l in
+        if open_proof
+        then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater
+        else VtSideff ids, VtLater
+    (* Sideff: apply to all open branches. usually run on master only *)
+    | VernacAssumption (_,_,l) ->
+        let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map snd l) l) in
+        VtSideff ids, VtLater    
+    | VernacDefinition (_,(_,id),DefineBody _) -> VtSideff [id], VtLater
+    | VernacInductive (_,_,l) ->
+        let ids = List.map (fun (((_,(_,id)),_,_,_,cl),_) -> id :: match cl with
+        | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l
+        | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @
+           CList.map_filter (function
+            | ((_,AssumExpr((_,Names.Name n),_)),_),_ -> Some n
+            | _ -> None) l) l in
+        VtSideff (List.flatten ids), VtLater
+    | VernacScheme l ->
+        let ids = List.map snd (CList.map_filter (fun (x,_) -> x) l) in
+        VtSideff ids, VtLater
+    | VernacCombinedScheme ((_,id),_) -> VtSideff [id], VtLater
+    | VernacUniverse _ | VernacConstraint _
+    | VernacBeginSection _
+    | VernacCanonical _ | VernacCoercion _ | VernacIdentityCoercion _
+    | VernacAddLoadPath _ | VernacRemoveLoadPath _ | VernacAddMLPath _
+    | VernacChdir _ 
+    | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
+    | VernacDeclareImplicits _ | VernacArguments _ | VernacArgumentsScope _
+    | VernacReserve _
+    | VernacGeneralizable _
+    | VernacSetOpacity _ | VernacSetStrategy _
+    | VernacUnsetOption _ | VernacSetOption _
+    | VernacAddOption _ | VernacRemoveOption _
+    | VernacMemOption _ | VernacPrintOption _
+    | VernacGlobalCheck _
+    | VernacDeclareReduction _
+    | VernacDeclareClass _ | VernacDeclareInstances _
+    | VernacRegister _
+    | VernacDeclareTacticDefinition _
+    | VernacNameSectionHypSet _
+    | VernacComments _ -> VtSideff [], VtLater
+    (* Who knows *)
+    | VernacLoad _ -> VtSideff [], VtNow
+    (* (Local) Notations have to disappear *)
+    | VernacEndSegment _ -> VtSideff [], VtNow
+    (* Modules with parameters have to be executed: can import notations *)
+    | VernacDeclareModule (exp,(_,id),bl,_)
+    | VernacDefineModule (exp,(_,id),bl,_,_) ->
+        VtSideff [id], if bl = [] && exp = None then VtLater else VtNow
+    | VernacDeclareModuleType ((_,id),bl,_,_) ->
+        VtSideff [id], if bl = [] then VtLater else VtNow
+    (* These commands alter the parser *)
+    | VernacOpenCloseScope _ | VernacDelimiters _ | VernacBindScope _
+    | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _
+    | VernacSyntaxExtension _ 
+    | VernacSyntacticDefinition _
+    | VernacTacticNotation _
+    | VernacRequire _ | VernacImport _ | VernacInclude _
+    | VernacDeclareMLModule _
+    | VernacContext _ (* TASSI: unsure *)
+    | VernacProofMode _ 
+    (* These are ambiguous *)
+    | VernacInstance _ -> VtUnknown, VtNow
+    (* Stm will install a new classifier to handle these *)
+    | VernacBack _ | VernacAbortAll
+    | VernacUndoTo _ | VernacUndo _
+    | VernacResetName _ | VernacResetInitial
+    | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e
+    (* What are these? *)
+    | VernacNop
+    | VernacToplevelControl _
+    | VernacRestoreState _
+    | VernacWriteState _ -> VtUnknown, VtNow
+    | VernacError _ -> assert false
+    (* Plugins should classify their commands *)
+    | VernacExtend (s,l) ->
+        try List.assoc s !classifiers l ()
+        with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s))
+  and classify_vernac_list = function
+    (* spiwack: It would be better to define a monoid on classifiers.
+       So that the classifier of the list would be the composition of
+       the classifier of the individual commands. Currently: special
+       case for singleton lists.*)
+    | [_,c] -> static_classifier c
+    | l -> VtUnknown,VtNow
+  in
+  let res = static_classifier e in
+    if Flags.is_universe_polymorphism () then
+      make_polymorphic res
+    else res
+
+let classify_as_query =
+  VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater
+let classify_as_sideeff = VtSideff [], VtLater
+let classify_as_proofstep = VtProofStep false, VtLater
diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli
new file mode 100644
index 00000000..0680fe84
--- /dev/null
+++ b/stm/vernac_classifier.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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 Vernacexpr
+open Genarg
+
+val string_of_vernac_classification : vernac_classification -> string
+
+(** What does a vernacular do *)
+val classify_vernac : vernac_expr -> vernac_classification
+
+(** Install a vernacular classifier for VernacExtend *)
+val declare_vernac_classifier :
+  Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit
+
+(** Set by Stm *)
+val set_undo_classifier : (vernac_expr -> vernac_classification) -> unit
+
+(** Standard constant classifiers *)
+val classify_as_query : vernac_classification
+val classify_as_sideeff : vernac_classification
+val classify_as_proofstep : vernac_classification
+
diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml
new file mode 100644
index 00000000..84df3ecd
--- /dev/null
+++ b/stm/vio_checking.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 Util
+
+let check_vio (ts,f) =
+  Dumpglob.noglob ();
+  let long_f_dot_v, _, _, _, tasks, _ = Library.load_library_todo f in
+  Stm.set_compilation_hints long_f_dot_v;
+  List.fold_left (fun acc ids -> Stm.check_task f tasks ids && acc) true ts
+
+module Worker = Spawn.Sync(struct end)
+
+module IntOT = struct
+  type t = int
+  let compare = compare
+end
+
+module Pool = Map.Make(IntOT)
+
+let schedule_vio_checking j fs =
+  if j < 1 then Errors.error "The number of workers must be bigger than 0";
+  let jobs = ref [] in
+  List.iter (fun f ->
+    let f =
+      if Filename.check_suffix f ".vio" then Filename.chop_extension f
+      else f in
+    let long_f_dot_v, _,_,_, tasks, _ = Library.load_library_todo f in
+    Stm.set_compilation_hints long_f_dot_v;
+    let infos = Stm.info_tasks tasks in
+    let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in
+    if infos <> [] then jobs := (f, eta, infos) :: !jobs)
+  fs;
+  let cmp_job (_,t1,_) (_,t2,_) = compare t2 t1 in
+  jobs := List.sort cmp_job !jobs;
+  let eta = ref (List.fold_left (fun a j -> a +. pi2 j) 0.0 !jobs) in
+  let pool : Worker.process Pool.t ref = ref Pool.empty in
+  let rec filter_argv b = function
+    | [] -> []
+    | "-schedule-vio-checking" :: rest -> filter_argv true rest
+    | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest)
+    | _ :: rest when b -> filter_argv b rest
+    | s :: rest -> s :: filter_argv b rest in
+  let pack = function
+    | [] -> []
+    | ((f,_),_,_) :: _ as l ->
+        let rec aux last acc = function
+          | [] -> [last,acc]
+          | ((f',id),_,_) :: tl when last = f' -> aux last (id::acc) tl
+          | ((f',id),_,_) :: _ as l -> (last,acc) :: aux f' [] l in
+        aux f [] l in
+  let prog = Sys.argv.(0) in  
+  let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in
+  let make_job () =
+    let cur = ref 0.0 in
+    let what = ref [] in
+    let j_left = j - Pool.cardinal !pool in
+    let take_next_file () =
+      let f, t, tasks = List.hd !jobs in
+      jobs := List.tl !jobs;
+      cur := !cur +. t;
+      what := (List.map (fun (n,t,id) -> (f,id),n,t) tasks) @ !what in
+    if List.length !jobs >= j_left then take_next_file ()
+    else while !jobs <> [] &&
+         !cur < max 0.0 (min 60.0 (!eta /. float_of_int j_left)) do
+      let f, t, tasks = List.hd !jobs in
+      jobs := List.tl !jobs;
+      let n, tt, id = List.hd tasks in
+      if List.length tasks > 1 then
+        jobs := (f, t -. tt, List.tl tasks) :: !jobs;
+      cur := !cur +. tt;
+      what := ((f,id),n,tt) :: !what;
+    done;
+    if !what = [] then take_next_file ();
+    eta := !eta -. !cur;
+    let cmp_job (f1,_,_) (f2,_,_) = compare f1 f2 in
+    List.flatten
+      (List.map (fun (f, tl) ->
+        "-check-vio-tasks" :: 
+        String.concat "," (List.map string_of_int tl) :: [f])
+      (pack (List.sort cmp_job !what))) in
+  let rc = ref 0 in
+  while !jobs <> [] || Pool.cardinal !pool > 0 do
+    while Pool.cardinal !pool < j && !jobs <> [] do
+      let args = Array.of_list (stdargs @ make_job ()) in
+      let proc, _, _ = Worker.spawn prog args in
+      pool := Pool.add (Worker.unixpid proc) proc !pool;
+    done;
+    let pid, ret = Unix.wait () in
+    if ret <> Unix.WEXITED 0 then rc := 1;
+    pool := Pool.remove pid !pool;
+  done;
+  exit !rc
+
+let schedule_vio_compilation j fs =
+  if j < 1 then Errors.error "The number of workers must be bigger than 0";
+  let jobs = ref [] in
+  List.iter (fun f ->
+    let f =
+      if Filename.check_suffix f ".vio" then Filename.chop_extension f
+      else f in
+    let paths = Loadpath.get_paths () in
+    let _, long_f_dot_v =
+      System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in
+    let aux = Aux_file.load_aux_file_for long_f_dot_v in
+    let eta =
+      try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time")
+      with Not_found -> 0.0 in
+    jobs := (f, eta) :: !jobs)
+  fs;
+  let cmp_job (_,t1) (_,t2) = compare t2 t1 in
+  jobs := List.sort cmp_job !jobs;
+  let pool : Worker.process Pool.t ref = ref Pool.empty in
+  let rec filter_argv b = function
+    | [] -> []
+    | "-schedule-vio2vo" :: rest -> filter_argv true rest
+    | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest)
+    | _ :: rest when b -> filter_argv b rest
+    | s :: rest -> s :: filter_argv b rest in
+  let prog = Sys.argv.(0) in  
+  let stdargs = filter_argv false (List.tl (Array.to_list Sys.argv)) in
+  let make_job () =
+    let f, t = List.hd !jobs in
+    jobs := List.tl !jobs;
+    [ "-vio2vo"; f ] in
+  let rc = ref 0 in
+  while !jobs <> [] || Pool.cardinal !pool > 0 do
+    while Pool.cardinal !pool < j && !jobs <> [] do
+      let args = Array.of_list (stdargs @ make_job ()) in
+      let proc, _, _ = Worker.spawn prog args in
+      pool := Pool.add (Worker.unixpid proc) proc !pool;
+    done;
+    let pid, ret = Unix.wait () in
+    if ret <> Unix.WEXITED 0 then rc := 1;
+    pool := Pool.remove pid !pool;
+  done;
+  exit !rc
+
+  
diff --git a/theories/ZArith/ZOdiv_def.v b/stm/vio_checking.mli
index 8b823d9f..e2da5026 100644
--- a/theories/ZArith/ZOdiv_def.v
+++ b/stm/vio_checking.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        *)
 (************************************************************************)
 
-Require Import BinInt.
+(* [check_vio tasks file] checks the [tasks] stored in [file] *)
+val check_vio : int list * string -> bool
+val schedule_vio_checking : int -> string list -> unit
 
-Notation ZOdiv_eucl := Z.quotrem (only parsing).
-Notation ZOdiv := Z.quot (only parsing).
-Notation ZOmod := Z.rem (only parsing).
-
-Notation ZOdiv_eucl_correct := Z.quotrem_eq.
+val schedule_vio_compilation : int -> string list -> unit
diff --git a/stm/workerPool.ml b/stm/workerPool.ml
new file mode 100644
index 00000000..db3bb5ad
--- /dev/null
+++ b/stm/workerPool.ml
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  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 worker_id = string
+
+type 'a cpanel = {
+  exit : unit -> unit; (* called by manager to exit instead of Thread.exit *)
+  cancelled : unit -> bool; (* manager checks for a request of termination *)
+  extra : 'a;                        (* extra stuff to pass to the manager *)
+}
+
+module type PoolModel = sig
+  (* this shall come from a Spawn.* model *)
+  type process
+  val spawn : int -> worker_id * process * CThread.thread_ic * out_channel
+
+  (* this defines the main loop of the manager *)
+  type extra
+  val manager :
+    extra cpanel -> worker_id * process * CThread.thread_ic * out_channel -> unit
+end
+
+module Make(Model : PoolModel) = struct
+
+type worker = {
+  name : worker_id;
+  cancel : bool ref;
+  manager : Thread.t;
+  process : Model.process;
+}
+
+type pre_pool = {
+  workers : worker list ref;
+  count : int ref;
+  extra_arg : Model.extra;
+}
+
+type pool = { lock : Mutex.t; pool : pre_pool }
+
+let magic_no = 17
+
+let master_handshake worker_id ic oc =
+  try
+    Marshal.to_channel oc magic_no [];  flush oc;
+    let n = (CThread.thread_friendly_input_value ic : int) in
+    if n <> magic_no then begin
+      Printf.eprintf "Handshake with %s failed: protocol mismatch\n" worker_id;
+      exit 1;
+    end
+  with e when Errors.noncritical e ->
+    Printf.eprintf "Handshake with %s failed: %s\n"
+      worker_id (Printexc.to_string e);
+    exit 1
+
+let worker_handshake slave_ic slave_oc =
+  try
+    let v = (CThread.thread_friendly_input_value slave_ic : int) in
+    if v <> magic_no then begin
+      prerr_endline "Handshake failed: protocol mismatch\n";
+      exit 1;
+    end;
+    Marshal.to_channel slave_oc v []; flush slave_oc;
+  with e when Errors.noncritical e ->
+    prerr_endline ("Handshake failed: " ^ Printexc.to_string e);
+    exit 1
+
+let locking { lock; pool = p } f =
+  try
+    Mutex.lock lock;
+    let x = f p in
+    Mutex.unlock lock;
+    x
+  with e -> Mutex.unlock lock; raise e
+
+let rec create_worker extra pool id =
+  let cancel = ref false in
+  let name, process, ic, oc as worker = Model.spawn id in
+  master_handshake name ic oc;
+  let exit () = cancel := true; cleanup pool; Thread.exit () in
+  let cancelled () = !cancel in
+  let cpanel = { exit; cancelled; extra } in
+  let manager = Thread.create (Model.manager cpanel) worker in
+  { name; cancel; manager; process }
+  
+and cleanup x = locking x begin fun { workers; count; extra_arg } ->
+  workers := List.map (function
+    | { cancel } as w when !cancel = false -> w
+    | _ -> let n = !count in incr count; create_worker extra_arg x n)
+  !workers
+end
+
+let n_workers x = locking x begin fun { workers } ->
+   List.length !workers
+end
+
+let is_empty x = locking x begin fun { workers } -> !workers = [] end
+
+let create extra_arg ~size = let x = {
+    lock = Mutex.create ();
+    pool = {
+      extra_arg;
+      workers = ref [];
+      count = ref size;
+  }} in
+  locking x begin fun { workers } ->
+     workers := CList.init size (create_worker extra_arg x)
+  end;
+  x
+
+let cancel n x = locking x begin fun { workers } ->
+  List.iter (fun { name; cancel } -> if n = name then cancel := true) !workers
+end
+
+let cancel_all x = locking x begin fun { workers } ->
+  List.iter (fun { cancel } -> cancel := true) !workers
+end
+
+let destroy x = locking x begin fun { workers } ->
+  List.iter (fun { cancel } -> cancel := true) !workers;
+  workers := []
+end
+
+end
diff --git a/stm/workerPool.mli b/stm/workerPool.mli
new file mode 100644
index 00000000..f46303b5
--- /dev/null
+++ b/stm/workerPool.mli
@@ -0,0 +1,46 @@
+(************************************************************************)
+(*  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 worker_id = string
+
+type 'a cpanel = {
+  exit : unit -> unit; (* called by manager to exit instead of Thread.exit *)
+  cancelled : unit -> bool; (* manager checks for a request of termination *)
+  extra : 'a;                        (* extra stuff to pass to the manager *)
+}
+
+module type PoolModel = sig
+  (* this shall come from a Spawn.* model *)
+  type process
+  val spawn : int -> worker_id * process * CThread.thread_ic * out_channel
+
+  (* this defines the main loop of the manager *)
+  type extra
+  val manager :
+    extra cpanel -> worker_id * process * CThread.thread_ic * out_channel -> unit
+end
+
+module Make(Model : PoolModel) : sig
+
+  type pool
+  
+  val create : Model.extra -> size:int -> pool
+
+  val is_empty : pool -> bool
+  val n_workers : pool -> int
+
+  (* cancel signal *)
+  val cancel : worker_id -> pool -> unit
+  val cancel_all : pool -> unit
+  (* camcel signal + true removal, the pool is empty afterward *)
+  val destroy : pool -> unit
+
+  (* The worker should call this function *)
+  val worker_handshake : CThread.thread_ic -> out_channel -> unit
+
+end
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 3451957e..45052685 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -1,1011 +1,29 @@
 (************************************************************************)
 (*  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 Errors
 open Names
-open Nameops
-open Namegen
-open Term
+open Vars
 open Termops
-open Inductiveops
-open Sign
 open Environ
-open Inductive
-open Evd
-open Reduction
-open Typing
-open Pattern
-open Matching
 open Tacmach
-open Proof_type
-open Pfedit
-open Glob_term
-open Evar_refiner
-open Tacred
+open Genredexpr
 open Tactics
 open Tacticals
 open Clenv
-open Hiddentac
-open Libnames
-open Nametab
-open Smartlocate
-open Libobject
-open Library
-open Printer
-open Declarations
 open Tacexpr
-open Mod_subst
-
-(****************************************************************************)
-(*            The Type of Constructions Autotactic Hints                    *)
-(****************************************************************************)
-
-type 'a auto_tactic =
-  | Res_pf     of constr * 'a (* Hint Apply *)
-  | ERes_pf    of constr * 'a (* Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (* Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
-  | Extern     of glob_tactic_expr       (* Hint Extern *)
-
-type hints_path_atom = 
-  | PathHints of global_reference list
-  | PathAny
-
-type hints_path =
-  | PathAtom of hints_path_atom
-  | PathStar of hints_path
-  | PathSeq of hints_path * hints_path
-  | PathOr of hints_path * hints_path
-  | PathEmpty
-  | PathEpsilon
-
-type 'a gen_auto_tactic = {
-  pri  : int;            (* A number lower is higher priority *)
-  pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
-  name  : hints_path_atom; (* A potential name to refer to the hint *) 
-  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
-}
-
-type pri_auto_tactic = clausenv gen_auto_tactic
-
-type hint_entry = global_reference option * types gen_auto_tactic
-
-let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) =
-  let d = pri1 - pri2 in
-    if d == 0 then id2 - id1
-    else d
-
-let pri_order t1 t2 = pri_order_int t1 t2 <= 0
-
-let insert v l =
-  let rec insrec = function
-    | [] -> [v]
-    | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl)
-  in
-  insrec l
-
-(* Nov 98 -- Papageno *)
-(* Les Hints sont ré-organisés en plusieurs databases.
-
-  La table impérative "searchtable", de type "hint_db_table",
-   associe une database (hint_db) à chaque nom.
-
-  Une hint_db est une table d'association fonctionelle constr -> search_entry
-  Le constr correspond à la constante de tête de la conclusion.
-
-  Une search_entry est un triplet comprenant :
-     - la liste des tactiques qui n'ont pas de pattern associé
-     - la liste des tactiques qui ont un pattern
-     - un discrimination net borné (Btermdn.t) constitué de tous les
-       patterns de la seconde liste de tactiques *)
-
-type stored_data = int * pri_auto_tactic
-    (* First component is the index of insertion in the table, to keep most recent first semantics. *)
-
-let auto_tactic_ord code1 code2 =
-  match code1, code2 with
-  | Res_pf (c1, _), Res_pf (c2, _)
-  | ERes_pf (c1, _), ERes_pf (c2, _)
-  | Give_exact c1, Give_exact c2
-  | Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> constr_ord c1 c2
-  | Unfold_nth (EvalVarRef i1), Unfold_nth (EvalVarRef i2) -> Pervasives.compare i1 i2
-  | Unfold_nth (EvalConstRef c1), Unfold_nth (EvalConstRef c2) ->
-      kn_ord (canonical_con c1) (canonical_con c2)
-  | Extern t1, Extern t2 -> Pervasives.compare t1 t2
-  | _ -> Pervasives.compare code1 code2
-
-module Bounded_net = Btermdn.Make(struct
-				    type t = stored_data
-				    let compare = pri_order_int
-				  end)
-
-type search_entry = stored_data list * stored_data list * Bounded_net.t
-
-let empty_se = ([],[],Bounded_net.create ())
-
-let eq_pri_auto_tactic (_, x) (_, y) =
-  if x.pri = y.pri && x.pat = y.pat then
-    match x.code,y.code with
-      | Res_pf(cstr,_),Res_pf(cstr1,_) -> 
-	   eq_constr cstr cstr1
-      | ERes_pf(cstr,_),ERes_pf(cstr1,_) -> 
-	  eq_constr cstr cstr1
-      | Give_exact cstr,Give_exact cstr1  -> 
-	  eq_constr cstr cstr1
-      | Res_pf_THEN_trivial_fail(cstr,_)
-	  ,Res_pf_THEN_trivial_fail(cstr1,_) -> 
-	  eq_constr cstr cstr1
-      | _,_ -> false
-  else
-    false
-
-let add_tac pat t st (l,l',dn) =
-  match pat with
-  | None -> if not (List.exists (eq_pri_auto_tactic t) l) then (insert t l, l', dn) else (l, l', dn)
-  | Some pat -> 
-    if not (List.exists (eq_pri_auto_tactic t) l') 
-    then (l, insert t l', Bounded_net.add st dn (pat,t)) else (l, l', dn)
-
-let rebuild_dn st ((l,l',dn) : search_entry) =
-  (l, l', List.fold_left (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t)))
-    (Bounded_net.create ()) l')
-
-
-let lookup_tacs (hdc,c) st (l,l',dn) =
-  let l'  = List.map snd (Bounded_net.lookup st dn c) in
-  let sl' = List.stable_sort pri_order_int l' in
-    Sort.merge pri_order l sl'
-
-module Constr_map = Map.Make(RefOrdered)
-
-let is_transparent_gr (ids, csts) = function
-  | VarRef id -> Idpred.mem id ids
-  | ConstRef cst -> Cpred.mem cst csts
-  | IndRef _ | ConstructRef _ -> false
-
-let dummy_goal = Goal.V82.dummy_goal
-
-let translate_hint (go,p) =
-  let mk_clenv (c,t) =
-    let cl = mk_clenv_from dummy_goal (c,t) in {cl with env = empty_env }
-  in
-  let code = match p.code with
-    | Res_pf (c,t) -> Res_pf (c, mk_clenv (c,t))
-    | ERes_pf (c,t) -> ERes_pf (c, mk_clenv (c,t))
-    | Res_pf_THEN_trivial_fail (c,t) ->
-      Res_pf_THEN_trivial_fail (c, mk_clenv (c,t))
-    | Give_exact c -> Give_exact c
-    | Unfold_nth e -> Unfold_nth e
-    | Extern t -> Extern t
-  in
-  (go,{ p with code = code })
-
-let path_matches hp hints =
-  let rec aux hp hints k =
-    match hp, hints with
-    | PathAtom _, [] -> false
-    | PathAtom PathAny, (_ :: hints') -> k hints'
-    | PathAtom p, (h :: hints') -> 
-      if p = h then k hints' else false
-    | PathStar hp', hints -> 
-      k hints || aux hp' hints (fun hints' -> aux hp hints' k)
-    | PathSeq (hp, hp'), hints -> 
-      aux hp hints (fun hints' -> aux hp' hints' k)
-    | PathOr (hp, hp'), hints ->
-      aux hp hints k || aux hp' hints k
-    | PathEmpty, _ -> false
-    | PathEpsilon, hints -> k hints
-  in aux hp hints (fun hints' -> true)
-
-let rec matches_epsilon = function
-  | PathAtom _ -> false
-  | PathStar _ -> true
-  | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p'
-  | PathOr (p, p') -> matches_epsilon p || matches_epsilon p'
-  | PathEmpty -> false
-  | PathEpsilon -> true
-
-let rec is_empty = function
-  | PathAtom _ -> false
-  | PathStar _ -> false
-  | PathSeq (p, p') -> is_empty p || is_empty p'
-  | PathOr (p, p') -> matches_epsilon p && matches_epsilon p'
-  | PathEmpty -> true
-  | PathEpsilon -> false
-
-let rec path_derivate hp hint =
-  let rec derivate_atoms hints hints' =
-    match hints, hints' with
-    | gr :: grs, gr' :: grs' when gr = gr' -> derivate_atoms grs grs'
-    | [], [] -> PathEpsilon
-    | [], hints -> PathEmpty
-    | grs, [] -> PathAtom (PathHints grs)
-    | _, _ -> PathEmpty 
-  in
-    match hp with
-    | PathAtom PathAny -> PathEpsilon
-    | PathAtom (PathHints grs) -> 
-      (match grs, hint with
-       | h :: hints, PathAny -> PathEmpty
-       | hints, PathHints hints' -> derivate_atoms hints hints'
-       | _, _ -> assert false)
-    | PathStar p -> if path_matches p [hint] then hp else PathEpsilon
-    | PathSeq (hp, hp') ->
-      let hpder = path_derivate hp hint in
-	if matches_epsilon hp then 
-	  PathOr (PathSeq (hpder, hp'), path_derivate hp' hint)
-	else if is_empty hpder then PathEmpty 
-	else PathSeq (hpder, hp')
-    | PathOr (hp, hp') ->
-      PathOr (path_derivate hp hint, path_derivate hp' hint)
-    | PathEmpty -> PathEmpty
-    | PathEpsilon -> PathEmpty
-
-let rec normalize_path h =
-  match h with
-  | PathStar PathEpsilon -> PathEpsilon
-  | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty
-  | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p
-  | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p
-  | PathOr (p, q) -> 
-    let p', q' = normalize_path p, normalize_path q in
-      if p = p' && q = q' then h
-      else normalize_path (PathOr (p', q'))
-  | PathSeq (p, q) -> 
-    let p', q' = normalize_path p, normalize_path q in
-      if p = p' && q = q' then h
-      else normalize_path (PathSeq (p', q'))
-  | _ -> h
-
-let path_derivate hp hint = normalize_path (path_derivate hp hint)
-
-let rec pp_hints_path = function
-  | PathAtom (PathAny) -> str"."
-  | PathAtom (PathHints grs) -> prlist_with_sep pr_spc pr_global grs
-  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
-  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
-  | PathOr (p, p') -> 
-    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
-  | PathEmpty -> str"Ø"
-  | PathEpsilon -> str"ε"
-
-let subst_path_atom subst p =
-  match p with
-  | PathAny -> p
-  | PathHints grs ->
-    let gr' gr = fst (subst_global subst gr) in
-    let grs' = list_smartmap gr' grs in
-      if grs' == grs then p else PathHints grs'
-
-let rec subst_hints_path subst hp =
-  match hp with
-  | PathAtom p ->
-    let p' = subst_path_atom subst p in
-      if p' == p then hp else PathAtom p'
-  | PathStar p -> let p' = subst_hints_path subst p in
-      if p' == p then hp else PathStar p'
-  | PathSeq (p, q) ->
-    let p' = subst_hints_path subst p in
-    let q' = subst_hints_path subst q in
-      if p' == p && q' == q then hp else PathSeq (p', q')
-  | PathOr (p, q) ->
-    let p' = subst_hints_path subst p in
-    let q' = subst_hints_path subst q in
-      if p' == p && q' == q then hp else PathOr (p', q')
-  | _ -> hp
-
-module Hint_db = struct
-
-  type t = {
-    hintdb_state : Names.transparent_state;
-    hintdb_cut : hints_path;
-    hintdb_unfolds : Idset.t * Cset.t;
-    mutable hintdb_max_id : int;
-    use_dn : bool;
-    hintdb_map : search_entry Constr_map.t;
-    (* A list of unindexed entries starting with an unfoldable constant
-       or with no associated pattern. *)
-    hintdb_nopat : (global_reference option * stored_data) list
-  }
-
-  let next_hint_id t = 
-    let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h
-
-  let empty st use_dn = { hintdb_state = st;
-			  hintdb_cut = PathEmpty;
-			  hintdb_unfolds = (Idset.empty, Cset.empty);
-			  hintdb_max_id = 0;
-			  use_dn = use_dn;
-			  hintdb_map = Constr_map.empty;
-			  hintdb_nopat = [] }
-
-  let find key db =
-    try Constr_map.find key db.hintdb_map
-    with Not_found -> empty_se
- 
-  let map_none db =
-    List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
-    
-  let map_all k db =
-    let (l,l',_) = find k db in
-      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
-
-  let map_auto (k,c) db =
-    let st = if db.use_dn then Some db.hintdb_state else None in
-    let l' = lookup_tacs (k,c) st (find k db) in
-      List.map snd (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
-
-  let is_exact = function
-    | Give_exact _ -> true
-    | _ -> false
-
-  let is_unfold = function
-    | Unfold_nth _ -> true
-    | _ -> false
-
-  let addkv gr id v db =
-    let idv = id, v in
-    let k = match gr with
-      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr &&
-	  is_unfold v.code then None else Some gr
-      | None -> None
-    in
-    let dnst = if db.use_dn then Some db.hintdb_state else None in
-    let pat = if not db.use_dn && is_exact v.code then None else v.pat in
-      match k with
-      | None ->
-	  if not (List.exists (fun (_, (_, v')) -> v = v') db.hintdb_nopat) then
-	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
-	  else db
-      | Some gr ->
-	  let oval = find gr db in
-	    { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map }
-
-  let rebuild_db st' db =
-    let db' =
-      { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map;
-	hintdb_state = st'; hintdb_nopat = [] }
-    in
-      List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
-
-  let add_one kv db =
-    let (k,v) = translate_hint kv in
-    let st',db,rebuild =
-      match v.code with
-      | Unfold_nth egr ->
-	  let addunf (ids,csts) (ids',csts') =
-	    match egr with
-	    | EvalVarRef id -> (Idpred.add id ids, csts), (Idset.add id ids', csts')
-	    | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts')
-	  in 
-	  let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in
-	    state, { db with hintdb_unfolds = unfs }, true
-      | _ -> db.hintdb_state, db, false
-    in
-    let db = if db.use_dn && rebuild then rebuild_db st' db else db
-    in addkv k (next_hint_id db) v db
-
-  let add_list l db = List.fold_left (fun db k -> add_one k db) db l
-
-  let remove_sdl p sdl = list_smartfilter p sdl 
-  let remove_he st p (sl1, sl2, dn as he) =
-    let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in
-      if sl1' == sl1 && sl2' == sl2 then he
-      else rebuild_dn st (sl1', sl2', dn)
-
-  let remove_list grs db =
-    let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem gr grs) | _ -> true in
-    let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in
-    let hintnopat = list_smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
-      { db with hintdb_map = hintmap; hintdb_nopat = hintnopat }
-
-  let remove_one gr db = remove_list [gr] db
-
-  let iter f db =
-    f None (List.map (fun x -> snd (snd x)) db.hintdb_nopat);
-    Constr_map.iter (fun k (l,l',_) -> f (Some k) (List.map snd (l@l'))) db.hintdb_map
-
-  let transparent_state db = db.hintdb_state
-
-  let set_transparent_state db st =
-    if db.use_dn then rebuild_db st db
-    else { db with hintdb_state = st }
-
-  let add_cut path db =
-    { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) }
-
-  let cut db = db.hintdb_cut
-
-  let unfolds db = db.hintdb_unfolds
-
-  let use_dn db = db.use_dn
-
-end
-
-module Hintdbmap = Gmap
-
-type hint_db = Hint_db.t
-
-type frozen_hint_db_table = (string,hint_db) Hintdbmap.t
-
-type hint_db_table = (string,hint_db) Hintdbmap.t ref
-
-type hint_db_name = string
-
-let searchtable = (ref Hintdbmap.empty : hint_db_table)
-
-let searchtable_map name =
-  Hintdbmap.find name !searchtable
-let searchtable_add (name,db) =
-  searchtable := Hintdbmap.add name db !searchtable
-let current_db_names () =
-  Hintdbmap.dom !searchtable
-
-(**************************************************************************)
-(*                       Definition of the summary                        *)
-(**************************************************************************)
-
-let auto_init : (unit -> unit) ref = ref (fun () -> ())
-let add_auto_init f = 
-  let init = !auto_init in
-    auto_init := (fun () -> init (); f ())
-
-let init     () = searchtable := Hintdbmap.empty; !auto_init ()
-let freeze   () = !searchtable
-let unfreeze fs = searchtable := fs
-
-let _ = Summary.declare_summary "search"
-	  { Summary.freeze_function   = freeze;
-	    Summary.unfreeze_function = unfreeze;
-	    Summary.init_function     = init }
-
-
-(**************************************************************************)
-(*             Auxiliary functions to prepare AUTOHINT objects            *)
-(**************************************************************************)
-
-let rec nb_hyp c = match kind_of_term c with
-  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
-  | _ -> 0
-
-(* adding and removing tactics in the search table *)
-
-let try_head_pattern c =
-  try head_pattern_bound c
-  with BoundPattern -> error "Bound head variable."
-
-let name_of_constr c = try Some (global_of_constr c) with Not_found -> None
-
-let make_exact_entry sigma pri ?(name=PathAny) (c,cty) =
-  let cty = strip_outer_cast cty in
-    match kind_of_term cty with
-    | Prod _ -> failwith "make_exact_entry"
-    | _ ->
-	let pat = snd (Pattern.pattern_of_constr sigma cty) in
-	let hd =
-	  try head_pattern_bound pat
-	  with BoundPattern -> failwith "make_exact_entry"
-	in
-          (Some hd,
-	  { pri = (match pri with None -> 0 | Some p -> p);
-	    pat = Some pat;
-	    name = name;
-	    code = Give_exact c })
-
-let make_apply_entry env sigma (eapply,hnf,verbose) pri ?(name=PathAny) (c,cty) =
-  let cty = if hnf then hnf_constr env sigma cty else cty in
-    match kind_of_term cty with
-    | Prod _ ->
-        let ce = mk_clenv_from dummy_goal (c,cty) in
-	let c' = clenv_type (* ~reduce:false *) ce in
-	let pat = snd (Pattern.pattern_of_constr sigma c') in
-        let hd =
-	  try head_pattern_bound pat
-          with BoundPattern -> failwith "make_apply_entry" in
-        let nmiss = List.length (clenv_missing ce) in
-	if nmiss = 0 then
-	  (Some hd,
-          { pri = (match pri with None -> nb_hyp cty | Some p -> p);
-            pat = Some pat;
-	    name = name;
-            code = Res_pf(c,cty) })
-	else begin
-	  if not eapply then failwith "make_apply_entry";
-          if verbose then
-	    warn (str "the hint: eapply " ++ pr_lconstr c ++
-	    str " will only be used by eauto");
-          (Some hd,
-           { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
-             pat = Some pat;
-	     name = name;
-             code = ERes_pf(c,cty) })
-        end
-    | _ -> failwith "make_apply_entry"
-
-(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose
-   c is a constr
-   cty is the type of constr *)
-
-let make_resolves env sigma flags pri ?name c =
-  let cty = Retyping.get_type_of env sigma c in
-  let ents =
-    map_succeed
-      (fun f -> f (c,cty))
-      [make_exact_entry sigma pri ?name; make_apply_entry env sigma flags pri ?name]
-  in
-  if ents = [] then
-    errorlabstrm "Hint"
-      (pr_lconstr c ++ spc() ++
-        (if pi1 flags then str"cannot be used as a hint."
-	else str "can be used as a hint only for eauto."));
-  ents
-
-(* used to add an hypothesis to the local hint database *)
-let make_resolve_hyp env sigma (hname,_,htyp) =
-  try
-    [make_apply_entry env sigma (true, true, false) None 
-       ~name:(PathHints [VarRef hname])
-       (mkVar hname, htyp)]
-  with
-    | Failure _ -> []
-    | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
-
-(* REM : in most cases hintname = id *)
-let make_unfold eref =
-  let g = global_of_evaluable_reference eref in
-  (Some g,
-   { pri = 4;
-     pat = None;
-     name = PathHints [g];
-     code = Unfold_nth eref })
-
-let make_extern pri pat tacast =
-  let hdconstr = Option.map try_head_pattern pat in
-  (hdconstr,
-   { pri = pri;
-     pat = pat;
-     name = PathAny;
-     code = Extern tacast })
-
-let make_trivial env sigma ?(name=PathAny) c =
-  let t = hnf_constr env sigma (type_of env sigma c) in
-  let hd = head_of_constr_reference (fst (head_constr t)) in
-  let ce = mk_clenv_from dummy_goal (c,t) in
-  (Some hd, { pri=1;
-              pat = Some (snd (Pattern.pattern_of_constr sigma (clenv_type ce)));
-	      name = name;
-              code=Res_pf_THEN_trivial_fail(c,t) })
-  
-open Vernacexpr
-
-(**************************************************************************)
-(*               declaration of the AUTOHINT library object               *)
-(**************************************************************************)
-
-(* If the database does not exist, it is created *)
-(* TODO: should a warning be printed in this case ?? *)
-
-let get_db dbname =
-  try searchtable_map dbname
-  with Not_found -> Hint_db.empty empty_transparent_state false
-
-let add_hint dbname hintlist = 
-  let db = get_db dbname in
-  let db' = Hint_db.add_list hintlist db in
-    searchtable_add (dbname,db')
-
-let add_transparency dbname grs b =
-  let db = get_db dbname in
-  let st = Hint_db.transparent_state db in
-  let st' =
-    List.fold_left (fun (ids, csts) gr ->
-      match gr with
-      | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
-      | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts)
-      st grs
-  in searchtable_add (dbname, Hint_db.set_transparent_state db st')
-
-let remove_hint dbname grs =
-  let db = get_db dbname in
-  let db' = Hint_db.remove_list grs db in
-    searchtable_add (dbname, db')
-
-type hint_action =
-  | CreateDB of bool * transparent_state
-  | AddTransparency of evaluable_global_reference list * bool
-  | AddHints of hint_entry list
-  | RemoveHints of global_reference list
-  | AddCut of hints_path
-
-let add_cut dbname path =
-  let db = get_db dbname in
-  let db' = Hint_db.add_cut path db in
-    searchtable_add (dbname, db')
-
-type hint_obj = bool * string * hint_action  (* locality, name, action *)
-
-let cache_autohint (_,(local,name,hints)) =
-  match hints with
-  | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
-  | AddTransparency (grs, b) -> add_transparency name grs b
-  | AddHints hints -> add_hint name hints
-  | RemoveHints grs -> remove_hint name grs
-  | AddCut path -> add_cut name path
-
-let forward_subst_tactic =
-  ref (fun _ -> failwith "subst_tactic is not installed for auto")
-
-let set_extern_subst_tactic f = forward_subst_tactic := f
-
-let subst_autohint (subst,(local,name,hintlist as obj)) =
-  let subst_key gr =
-    let (lab'', elab') = subst_global subst gr in
-    let gr' =
-      (try head_of_constr_reference (fst (head_constr_bound elab'))
-       with Tactics.Bound -> lab'')
-    in if gr' == gr then gr else gr'
-  in
-  let subst_hint (k,data as hint) =
-    let k' = Option.smartmap subst_key k in
-    let pat' = Option.smartmap (subst_pattern subst) data.pat in
-    let code' = match data.code with
-      | Res_pf (c,t) ->
-          let c' = subst_mps subst c in
-          let t' = subst_mps subst t in
-          if c==c' && t'==t then data.code else Res_pf (c', t')
-      | ERes_pf (c,t) ->
-          let c' = subst_mps subst c in
-          let t' = subst_mps subst t in
-          if c==c' && t'==t then data.code else ERes_pf (c',t')
-      | Give_exact c ->
-          let c' = subst_mps subst c in
-          if c==c' then data.code else Give_exact c'
-      | Res_pf_THEN_trivial_fail (c,t) ->
-          let c' = subst_mps subst c in
-          let t' = subst_mps subst t in
-          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t')
-      | Unfold_nth ref ->
-          let ref' = subst_evaluable_reference subst ref in
-          if ref==ref' then data.code else Unfold_nth ref'
-      | Extern tac ->
-	  let tac' = !forward_subst_tactic subst tac in
-	  if tac==tac' then data.code else Extern tac'
-    in
-    let name' = subst_path_atom subst data.name in
-    let data' =
-      if data.pat==pat' && data.name == name' && data.code==code' then data
-      else { data with pat = pat'; name = name'; code = code' }
-    in
-    if k' == k && data' == data then hint else (k',data')
-  in
-    match hintlist with
-    | CreateDB _ -> obj
-    | AddTransparency (grs, b) ->
-	let grs' = list_smartmap (subst_evaluable_reference subst) grs in
-	  if grs==grs' then obj else (local, name, AddTransparency (grs', b))
-    | AddHints hintlist ->
-	let hintlist' = list_smartmap subst_hint hintlist in
-	  if hintlist' == hintlist then obj else
-	    (local,name,AddHints hintlist')
-    | RemoveHints grs ->
-	let grs' = list_smartmap (fun x -> fst (subst_global subst x)) grs in
-	  if grs==grs' then obj else (local, name, RemoveHints grs')
-    | AddCut path ->
-      let path' = subst_hints_path subst path in
-	if path' == path then obj else (local, name, AddCut path')
-
-let classify_autohint ((local,name,hintlist) as obj) =
-  if local or hintlist = (AddHints []) then Dispose else Substitute obj
-
-let inAutoHint : hint_obj -> obj =
-  declare_object {(default_object "AUTOHINT") with
-                    cache_function = cache_autohint;
-		    load_function = (fun _ -> cache_autohint);
-		    subst_function = subst_autohint;
-		    classify_function = classify_autohint; }
-
-let create_hint_db l n st b =
-  Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
-
-let remove_hints local dbnames grs =
-  let dbnames = if dbnames = [] then ["core"] else dbnames in
-    List.iter
-      (fun dbname ->
-	 Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs)))
-      dbnames
-
-(**************************************************************************)
-(*                     The "Hint" vernacular command                      *)
-(**************************************************************************)
-let add_resolves env sigma clist local dbnames =
-  List.iter
-    (fun dbname ->
-       Lib.add_anonymous_leaf
-	 (inAutoHint
-	    (local,dbname, AddHints
-     	      (List.flatten (List.map (fun (x, hnf, path, y) ->
-		make_resolves env sigma (true,hnf,Flags.is_verbose()) x ~name:path y) clist)))))
-    dbnames
-
-let add_unfolds l local dbnames =
-  List.iter
-    (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddHints (List.map make_unfold l))))
-    dbnames
-
-let add_cuts l local dbnames =
-  List.iter
-    (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddCut l)))
-    dbnames
-
-let add_transparency l b local dbnames =
-  List.iter
-    (fun dbname -> Lib.add_anonymous_leaf
-       (inAutoHint (local,dbname, AddTransparency (l, b))))
-    dbnames
-
-let add_extern pri pat tacast local dbname =
-  (* We check that all metas that appear in tacast have at least
-     one occurence in the left pattern pat *)
-  let tacmetas = [] in
-    match pat with
-    | Some (patmetas,pat) ->
-	(match (list_subtract tacmetas patmetas) with
-	| i::_ ->
-	    errorlabstrm "add_extern"
-	      (str "The meta-variable ?" ++ Ppconstr.pr_patvar i ++ str" is not bound.")
-	| []  ->
-	    Lib.add_anonymous_leaf
-	      (inAutoHint(local,dbname, AddHints [make_extern pri (Some pat) tacast])))
-    | None ->
-	Lib.add_anonymous_leaf
-	  (inAutoHint(local,dbname, AddHints [make_extern pri None tacast]))
-
-let add_externs pri pat tacast local dbnames =
-  List.iter (add_extern pri pat tacast local) dbnames
-
-let add_trivials env sigma l local dbnames =
-  List.iter
-    (fun dbname ->
-       Lib.add_anonymous_leaf (
-	 inAutoHint(local,dbname, 
-		    AddHints (List.map (fun (name, c) -> make_trivial env sigma ~name c) l))))
-    dbnames
-
-let forward_intern_tac =
-  ref (fun _ -> failwith "intern_tac is not installed for auto")
-
-let set_extern_intern_tac f = forward_intern_tac := f
-
-type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
-  | HintsImmediateEntry of (hints_path_atom * constr) list
-  | HintsCutEntry of hints_path
-  | HintsUnfoldEntry of evaluable_global_reference list
-  | HintsTransparencyEntry of evaluable_global_reference list * bool
-  | HintsExternEntry of
-      int * (patvar list * constr_pattern) option * glob_tactic_expr
-
-let h = id_of_string "H"
-
-exception Found of constr * types
-
-let prepare_hint env (sigma,c) =
-  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
-  (* We re-abstract over uninstantiated evars.
-     It is actually a bit stupid to generalize over evars since the first
-     thing make_resolves will do is to re-instantiate the products *)
-  let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in
-  let vars = ref (collect_vars c) in
-  let subst = ref [] in
-  let rec find_next_evar c = match kind_of_term c with
-    | Evar (evk,args as ev) ->
-      (* We skip the test whether args is the identity or not *)
-      let t = Evarutil.nf_evar sigma (existential_type sigma ev) in
-      let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in
-      if free_rels t <> Intset.empty then
-	error "Hints with holes dependent on a bound variable not supported.";
-      if occur_existential t then
-	(* Not clever enough to construct dependency graph of evars *)
-	error "Not clever enough to deal with evars dependent in other evars.";
-      raise (Found (c,t))
-    | _ -> iter_constr find_next_evar c in
-  let rec iter c =
-    try find_next_evar c; c
-    with Found (evar,t) ->
-      let id = next_ident_away_from h (fun id -> Idset.mem id !vars) in
-      vars := Idset.add id !vars;
-      subst := (evar,mkVar id)::!subst;
-      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
-  iter c
-
-let path_of_constr_expr c =
-  match c with
-  | Topconstr.CRef r ->
-    (try PathHints [global r] with e when Errors.noncritical e -> PathAny)
-  | _ -> PathAny
-      
-let interp_hints h =
-  let f c =
-    let evd,c = Constrintern.interp_open_constr Evd.empty (Global.env()) c in
-    let c = prepare_hint (Global.env()) (evd,c) in
-    Evarutil.check_evars (Global.env()) Evd.empty evd c;
-    c in
-  let fr r =
-    let gr = global_with_alias r in
-    let r' = evaluable_of_global_reference (Global.env()) gr in
-    Dumpglob.add_glob (loc_of_reference r) gr;
-    r' in
-  let fres (o, b, c) = (o, b, path_of_constr_expr c, f c) in
-  let fi c = path_of_constr_expr c, f c in
-  let fp = Constrintern.intern_constr_pattern Evd.empty (Global.env()) in
-  match h with
-  | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints)
-  | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints)
-  | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
-  | HintsTransparency (lhints, b) ->
-      HintsTransparencyEntry (List.map fr lhints, b)
-  | HintsConstructors lqid ->
-      let constr_hints_of_ind qid =
-        let ind = global_inductive_with_alias qid in
-	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
-        list_tabulate (fun i -> let c = (ind,i+1) in
-			 None, true, PathHints [ConstructRef c], mkConstruct c)
-	  (nconstructors ind) in
-	HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
-  | HintsExtern (pri, patcom, tacexp) ->
-      let pat =	Option.map fp patcom in
-      let tacexp = !forward_intern_tac (match pat with None -> [] | Some (l, _) -> l) tacexp in
-      HintsExternEntry (pri, pat, tacexp)
-
-let add_hints local dbnames0 h =
-  if List.mem "nocore" dbnames0 then
-    error "The hint database \"nocore\" is meant to stay empty.";
-  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
-  let env = Global.env() and sigma = Evd.empty in
-  match h with
-  | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
-  | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
-  | HintsCutEntry lhints -> add_cuts lhints local dbnames
-  | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
-  | HintsTransparencyEntry (lhints, b) ->
-      add_transparency lhints b local dbnames
-  | HintsExternEntry (pri, pat, tacexp) ->
-      add_externs pri pat tacexp local dbnames
-
-(**************************************************************************)
-(*                    Functions for printing the hints                    *)
-(**************************************************************************)
-
-let pr_autotactic =
-  function
-  | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
-  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
-  | Give_exact c -> (str"exact " ++ pr_constr c)
-  | Res_pf_THEN_trivial_fail (c,clenv) ->
-      (str"apply " ++ pr_constr c ++ str" ; trivial")
-  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
-  | Extern tac ->
-      let env =
-        try
-          let (_, env) = Pfedit.get_current_goal_context () in
-          env
-        with e when Errors.noncritical e -> Global.env ()
-      in
-      (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac)
-
-let pr_hint (id, v) =
-  (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())
-
-let pr_hint_list hintlist =
-  (str "  " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ())
-
-let pr_hints_db (name,db,hintlist) =
-  (str "In the database " ++ str name ++ str ":" ++
-     if hintlist = [] then (str " nothing" ++ fnl ())
-     else (fnl () ++ pr_hint_list hintlist))
-
-(* Print all hints associated to head c in any database *)
-let pr_hint_list_for_head c =
-  let dbs = Hintdbmap.to_list !searchtable in
-  let valid_dbs =
-    map_succeed
-      (fun (name,db) -> (name,db, List.map (fun v -> 0, v) (Hint_db.map_all c db)))
-      dbs
-  in
-  if valid_dbs = [] then
-    (str "No hint declared for :" ++ pr_global c)
-  else
-    hov 0
-      (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
-	 hov 0 (prlist pr_hints_db valid_dbs))
-
-let pr_hint_ref ref = pr_hint_list_for_head ref
-
-(* Print all hints associated to head id in any database *)
-let print_hint_ref ref =  ppnl(pr_hint_ref ref)
-
-let pr_hint_term cl =
-  try
-    let dbs = Hintdbmap.to_list !searchtable in
-    let valid_dbs =
-      let fn = try
-	  let (hdc,args) = head_constr_bound cl in
-	  let hd = head_of_constr_reference hdc in
-	    if occur_existential cl then
-	      Hint_db.map_all hd
-	    else Hint_db.map_auto (hd, applist (hdc,args))
-	with Bound -> Hint_db.map_none
-      in
-      let fn db = List.map (fun x -> 0, x) (fn db) in
-	map_succeed (fun (name, db) -> (name, db, fn db)) dbs
-    in
-      if valid_dbs = [] then
-	(str "No hint applicable for current goal")
-      else
-	(str "Applicable Hints :" ++ fnl () ++
-	    hov 0 (prlist pr_hints_db valid_dbs))
-  with Match_failure _ | Failure _ ->
-    (str "No hint applicable for current goal")
-
-let error_no_such_hint_database x =
-  error ("No such Hint database: "^x^".")
-
-let print_hint_term cl = ppnl (pr_hint_term cl)
-
-(* print all hints that apply to the concl of the current goal *)
-let print_applicable_hint () =
-  let pts = get_pftreestate () in
-  let glss = Proof.V82.subgoals pts in
-  match glss.Evd.it with
-  | [] -> Util.error "No focused goal."
-  | g::_ ->
-    let gl = { Evd.it = g; sigma = glss.Evd.sigma } in
-    print_hint_term (pf_concl gl)
-
-(* displays the whole hint database db *)
-let print_hint_db db =
-  let (ids, csts) = Hint_db.transparent_state db in
-  msgnl (hov 0
-	  ((if Hint_db.use_dn db then str"Discriminated database"
-	    else str"Non-discriminated database")));
-  msgnl (hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids));
-  msgnl (hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts));
-  msgnl (hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)));
-  Hint_db.iter
-    (fun head hintlist ->
-      match head with
-      | Some head ->
-	  msg (hov 0
-		  (str "For " ++ pr_global head ++ str " -> " ++
-		      pr_hint_list (List.map (fun x -> (0,x)) hintlist)))
-      | None ->
-	  msg (hov 0
-		  (str "For any goal -> " ++
-		      pr_hint_list (List.map (fun x -> (0, x)) hintlist))))
-    db
-
-let print_hint_db_by_name dbname =
-  try
-    let db = searchtable_map dbname in print_hint_db db
-  with Not_found ->
-    error_no_such_hint_database dbname
-
-(* displays all the hints of all databases *)
-let print_searchtable () =
-  Hintdbmap.iter
-    (fun name db ->
-       msg (str "In the database " ++ str name ++ str ":" ++ fnl ());
-       print_hint_db db)
-    !searchtable
+open Locus
+open Proofview.Notations
+open Hints
 
 (**************************************************************************)
 (*                           Automatic tactics                            *)
@@ -1015,79 +33,82 @@ let print_searchtable () =
 (*          tactics with a trace mechanism for automatic search           *)
 (**************************************************************************)
 
-let priority l = List.filter (fun (_, hint) -> hint.pri = 0) l
+let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l
 
 (* tell auto not to reuse already instantiated metas in unification (for
    compatibility, since otherwise, apply succeeds oftener) *)
 
 open Unification
 
-let auto_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = false;
-  modulo_delta = empty_transparent_state;
+let auto_core_unif_flags_of st1 st2 useeager = {
+  modulo_conv_on_closed_terms = Some st1;
+  use_metas_eagerly_in_conv_on_closed_terms = useeager;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = st2;
   modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
   check_applied_meta_types = false;
-  resolve_evars = true;
   use_pattern_unification = false;
   use_meta_bound_pattern_unification = true;
-  frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.empty;
   restrict_conv_on_strict_subterms = false; (* Compat *)
   modulo_betaiota = false;
   modulo_eta = true;
-  allow_K_in_toplevel_higher_order_unification = false
 }
 
-(* Try unification with the precompiled clause, then use registered Apply *)
+let auto_unif_flags_of st1 st2 useeager =
+  let flags = auto_core_unif_flags_of st1 st2 useeager in {
+  core_unify_flags = flags;
+  merge_unify_flags = flags;
+  subterm_unify_flags = { flags with modulo_delta = empty_transparent_state };
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = true
+}
 
-let h_clenv_refine ev c clenv =
-  Refiner.abstract_tactic (TacApply (true,ev,[c,NoBindings],None))
-    (Clenvtac.clenv_refine ev clenv)
+let auto_unif_flags =
+  auto_unif_flags_of full_transparent_state empty_transparent_state false
 
-let unify_resolve_nodelta (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver ~flags:auto_unif_flags clenv' gl in
-  h_clenv_refine false c clenv'' gl
+let auto_flags_of_state st =
+  auto_unif_flags_of full_transparent_state st false
 
-let unify_resolve flags (c,clenv) gl =
-  let clenv' = connect_clenv gl clenv in
-  let clenv'' = clenv_unique_resolver ~flags clenv' gl in
-  h_clenv_refine false c clenv'' gl
+(* Try unification with the precompiled clause, then use registered Apply *)
 
-let unify_resolve_gen = function
-  | None -> unify_resolve_nodelta
-  | Some flags -> unify_resolve flags
+let unify_resolve_nodelta poly (c,clenv) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in
+  let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags:auto_unif_flags clenv' gl) gl in
+  Clenvtac.clenv_refine false clenv''
+  end
+
+let unify_resolve poly flags (c,clenv) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in
+  let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv' gl) gl in
+  Clenvtac.clenv_refine false clenv''
+  end
+
+let unify_resolve_gen poly = function
+  | None -> unify_resolve_nodelta poly
+  | Some flags -> unify_resolve poly flags
+
+let exact poly (c,clenv) =
+  let ctx, c' = 
+    if poly then
+      let evd', subst = Evd.refresh_undefined_universes clenv.evd in
+      let ctx = Evd.evar_universe_context evd' in
+	ctx, subst_univs_level_constr subst c 
+    else 
+      let ctx = Evd.evar_universe_context clenv.evd in
+	ctx, c
+  in
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Evd.merge_universe_context (Proofview.Goal.sigma gl) ctx in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (exact_check c')
+  end
 
 (* Util *)
 
-let expand_constructor_hints env lems =
-  list_map_append (fun (sigma,lem) ->
-    match kind_of_term lem with
-    | Ind ind ->
-	list_tabulate (fun i -> mkConstruct (ind,i+1)) (nconstructors ind)
-    | _ ->
-	[prepare_hint env (sigma,lem)]) lems
-
-(* builds a hint database from a constr signature *)
-(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
-
-let add_hint_lemmas eapply lems hint_db gl =
-  let lems = expand_constructor_hints (pf_env gl) lems in
-  let hintlist' =
-    list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in
-  Hint_db.add_list hintlist' hint_db
-
-let make_local_hint_db ?ts eapply lems gl =
-  let sign = pf_hyps gl in
-  let ts = match ts with
-    | None -> Hint_db.transparent_state (searchtable_map "core") 
-    | Some ts -> ts
-  in
-  let hintlist = list_map_append (pf_apply make_resolve_hyp gl) sign in
-  add_hint_lemmas eapply lems
-    (Hint_db.add_list hintlist (Hint_db.empty ts false)) gl
-
 (* Serait-ce possible de compiler d'abord la tactique puis de faire la
    substitution sans passer par bdize dont l'objectif est de préparer un
    terme pour l'affichage ? (HH) *)
@@ -1100,19 +121,23 @@ si après Intros la conclusion matche le pattern.
 
 (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
 
-let forward_interp_tactic =
-  ref (fun _ -> failwith "interp_tactic is not installed for auto")
-
-let set_extern_interp f = forward_interp_tactic := f
+let (forward_interp_tactic, extern_interp) = Hook.make ()
 
-let conclPattern concl pat tac gl =
-  let constr_bindings =
+let conclPattern concl pat tac =
+  let constr_bindings env sigma =
     match pat with
-    | None -> []
+    | None -> Proofview.tclUNIT Id.Map.empty
     | Some pat ->
-	try matches pat concl
-	with PatternMatchingFailure -> error "conclPattern" in
-    !forward_interp_tactic constr_bindings tac gl
+	try
+	  Proofview.tclUNIT (Constr_matching.matches env sigma pat concl)
+	with Constr_matching.PatternMatchingFailure ->
+          Proofview.tclZERO (UserError ("conclPattern",str"conclPattern"))
+  in
+   Proofview.Goal.enter (fun gl ->
+     let env = Proofview.Goal.env gl in
+     let sigma = Proofview.Goal.sigma gl in
+       constr_bindings env sigma >>= fun constr_bindings ->
+     Hook.get forward_interp_tactic constr_bindings tac)
 
 (***********************************************************)
 (** A debugging / verbosity framework for trivial and auto *)
@@ -1147,8 +172,8 @@ let no_dbg () = (Off,0,ref [])
 
 let mk_trivial_dbg debug =
   let d =
-    if debug = Debug || !global_debug_trivial then Debug
-    else if debug = Info || !global_info_trivial then Info
+    if debug == Debug || !global_debug_trivial then Debug
+    else if debug == Info || !global_info_trivial then Info
     else Off
   in (d,0,ref [])
 
@@ -1157,8 +182,8 @@ let mk_trivial_dbg debug =
 
 let mk_auto_dbg debug =
   let d =
-    if debug = Debug || !global_debug_auto then Debug
-    else if debug = Info || !global_info_auto then Info
+    if debug == Debug || !global_debug_auto then Debug
+    else if debug == Info || !global_info_auto then Info
     else Off
   in (d,1,ref [])
 
@@ -1172,25 +197,27 @@ let tclLOG (dbg,depth,trace) pp tac =
     | Debug ->
        (* For "debug (trivial/auto)", we directly output messages *)
       let s = String.make depth '*' in
-      begin fun gl ->
+      Proofview.V82.tactic begin fun gl ->
 	try
-	  let out = tac gl in
+	  let out = Proofview.V82.of_tactic tac gl in
 	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)");
 	  out
 	with reraise ->
+          let reraise = Errors.push reraise in
 	  msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)");
-	  raise reraise
+	  iraise reraise
       end
     | Info ->
       (* For "info (trivial/auto)", we store a log trace *)
-      begin fun gl ->
+      Proofview.V82.tactic begin fun gl ->
 	try
-	  let out = tac gl in
+	  let out = Proofview.V82.of_tactic tac gl in
 	  trace := (depth, Some pp) :: !trace;
 	  out
 	with reraise ->
+          let reraise = Errors.push reraise in
 	  trace := (depth, None) :: !trace;
-	  raise reraise
+	  iraise reraise
       end
 
 (** For info, from the linear trace information, we reconstitute the part
@@ -1207,37 +234,39 @@ let rec cleanup_info_trace depth acc = function
 
 and erase_subtree depth = function
   | [] -> []
-  | (d,_) :: l -> if d = depth then l else erase_subtree depth l
+  | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l
 
 let pr_info_atom (d,pp) =
-  msg_debug (str (String.make d ' ') ++ pp () ++ str ".")
+  str (String.make d ' ') ++ pp () ++ str "."
 
 let pr_info_trace = function
   | (Info,_,{contents=(d,Some pp)::l}) ->
-      List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l)
-  | _ -> ()
+      prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)
+  | _ -> mt ()
 
 let pr_info_nop = function
-  | (Info,_,_) -> msg_debug (str "idtac.")
-  | _ -> ()
+  | (Info,_,_) -> str "idtac."
+  | _ -> mt ()
 
 let pr_dbg_header = function
-  | (Off,_,_) -> ()
-  | (Debug,0,_) -> msg_debug (str "(* debug trivial : *)")
-  | (Debug,_,_) -> msg_debug (str "(* debug auto : *)")
-  | (Info,0,_) -> msg_debug (str "(* info trivial : *)")
-  | (Info,_,_) -> msg_debug (str "(* info auto : *)")
+  | (Off,_,_) -> mt ()
+  | (Debug,0,_) -> str "(* debug trivial : *)"
+  | (Debug,_,_) -> str "(* debug auto : *)"
+  | (Info,0,_) -> str "(* info trivial : *)"
+  | (Info,_,_) -> str "(* info auto : *)"
 
 let tclTRY_dbg d tac =
-  tclORELSE0
-    (fun gl ->
-      pr_dbg_header d;
-      let out = tac gl in
-      pr_info_trace d;
-      out)
-    (fun gl ->
-      pr_info_nop d;
-      tclIDTAC gl)
+  let (level, _, _) = d in
+  let delay f = Proofview.tclUNIT () >>= fun () -> f () in
+  let tac = match level with
+  | Off -> tac
+  | Debug | Info -> delay (fun () -> msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); tac)
+  in
+  let after = match level with
+  | Info -> delay (fun () -> msg_debug (pr_info_nop d); Proofview.tclUNIT ())
+  | Off | Debug -> Proofview.tclUNIT ()
+  in
+  Tacticals.New.tclORELSE0 tac after
 
 (**************************************************************************)
 (*                           The Trivial tactic                           *)
@@ -1247,16 +276,21 @@ let tclTRY_dbg d tac =
 (* Papageno : cette fonction a été pas mal simplifiée depuis que la base
   de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
 
+let auto_unif_flags =
+  auto_unif_flags_of full_transparent_state empty_transparent_state false
+
 let flags_of_state st =
-  {auto_unif_flags with
-    modulo_conv_on_closed_terms = Some st; modulo_delta = st}
+  auto_unif_flags_of st st false
+
+let auto_flags_of_state st =
+  auto_unif_flags_of full_transparent_state st false
 
 let hintmap_of hdc concl =
   match hdc with
   | None -> Hint_db.map_none
   | Some hdc ->
-      if occur_existential concl then Hint_db.map_all hdc
-      else Hint_db.map_auto (hdc,concl)
+      if occur_existential concl then Hint_db.map_existential hdc concl
+      else Hint_db.map_auto hdc concl
 
 let exists_evaluable_reference env = function
   | EvalConstRef _ -> true
@@ -1265,41 +299,49 @@ let exists_evaluable_reference env = function
 let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro
 let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption
 
-let rec trivial_fail_db dbg mod_delta db_list local_db gl =
+let rec trivial_fail_db dbg mod_delta db_list local_db =
   let intro_tac =
-    tclTHEN (dbg_intro dbg)
-      (fun g'->
-	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
-	 in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g')
+    Tacticals.New.tclTHEN (dbg_intro dbg)
+      ( Proofview.Goal.enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          let nf c = Evarutil.nf_evar sigma c in
+          let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in
+          let hyp = Context.map_named_declaration nf decl in
+	  let hintl = make_resolve_hyp env sigma hyp
+	  in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db)
+      end)
   in
-  tclFIRST
-    ((dbg_assumption dbg)::intro_tac::
-     (List.map tclCOMPLETE
-       (trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl
+  Proofview.Goal.enter begin fun gl ->
+    let concl = Tacmach.New.pf_nf_concl gl in
+    Tacticals.New.tclFIRST
+      ((dbg_assumption dbg)::intro_tac::
+          (List.map Tacticals.New.tclCOMPLETE
+             (trivial_resolve dbg mod_delta db_list local_db concl)))
+  end
 
 and my_find_search_nodelta db_list local_db hdc concl =
   List.map (fun hint -> (None,hint))
-    (list_map_append (hintmap_of hdc concl) (local_db::db_list))
+    (List.map_append (hintmap_of hdc concl) (local_db::db_list))
 
 and my_find_search mod_delta =
   if mod_delta then my_find_search_delta
   else my_find_search_nodelta
 
 and my_find_search_delta db_list local_db hdc concl =
-  let flags = {auto_unif_flags with use_metas_eagerly_in_conv_on_closed_terms = true} in
   let f = hintmap_of hdc concl in
     if occur_existential concl then
-      list_map_append
+      List.map_append
 	(fun db ->
 	  if Hint_db.use_dn db then
 	    let flags = flags_of_state (Hint_db.transparent_state db) in
 	      List.map (fun x -> (Some flags,x)) (f db)
 	  else
-	    let flags = {flags with modulo_delta = Hint_db.transparent_state db} in
+	    let flags = auto_flags_of_state (Hint_db.transparent_state db) in
 	      List.map (fun x -> (Some flags,x)) (f db))
 	(local_db::db_list)
     else
-      list_map_append (fun db ->
+      List.map_append (fun db ->
 	if Hint_db.use_dn db then
 	  let flags = flags_of_state (Hint_db.transparent_state db) in
 	    List.map (fun x -> (Some flags, x)) (f db)
@@ -1309,39 +351,40 @@ and my_find_search_delta db_list local_db hdc concl =
 	    let l =
 	      match hdc with None -> Hint_db.map_none db
 	      | Some hdc ->
-		  if (Idpred.is_empty ids && Cpred.is_empty csts)
-		  then Hint_db.map_auto (hdc,concl) db
-		  else Hint_db.map_all hdc db
-	    in {flags with modulo_delta = st}, l
+		  if (Id.Pred.is_empty ids && Cpred.is_empty csts)
+		  then Hint_db.map_auto hdc concl db
+		  else Hint_db.map_existential hdc concl db
+	    in auto_flags_of_state st, l
 	  in List.map (fun x -> (Some flags,x)) l)
       	(local_db::db_list)
 
-and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) =
+and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) =
   let tactic = 
     match t with
-    | Res_pf (c,cl) -> unify_resolve_gen flags (c,cl)
-    | ERes_pf _ -> (fun gl -> error "eres_pf")
-    | Give_exact c  -> exact_check c
+    | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl)
+    | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf")
+    | Give_exact (c, cl)  -> exact poly (c, cl)
     | Res_pf_THEN_trivial_fail (c,cl) ->
-      tclTHEN
-        (unify_resolve_gen flags (c,cl))
+      Tacticals.New.tclTHEN
+        (unify_resolve_gen poly flags (c,cl))
 	(* With "(debug) trivial", we shouldn't end here, and
 	   with "debug auto" we don't display the details of inner trivial *)
-        (trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db)
+        (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db)
     | Unfold_nth c ->
-      (fun gl ->
+      Proofview.V82.tactic (fun gl ->
        if exists_evaluable_reference (pf_env gl) c then
-	 tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
+	 tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl
        else tclFAIL 0 (str"Unbound reference") gl)
-    | Extern tacast -> conclPattern concl p tacast
+    | Extern tacast -> 
+      conclPattern concl p tacast
   in
   tclLOG dbg (fun () -> pr_autotactic t) tactic
 
 and trivial_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
-	    Some (head_of_constr_reference hdconstr)
+      try let hdconstr = decompose_app_bound cl in
+	    Some hdconstr
       with Bound -> None
     in
       List.map (tac_of_hint dbg db_list local_db cl)
@@ -1352,36 +395,33 @@ and trivial_resolve dbg mod_delta db_list local_db cl =
 (** The use of the "core" database can be de-activated by passing
     "nocore" amongst the databases. *)
 
-let make_db_list dbnames =
-  let use_core = not (List.mem "nocore" dbnames) in
-  let dbnames = list_remove "nocore" dbnames in
-  let dbnames = if use_core then "core"::dbnames else dbnames in
-  let lookup db =
-    try searchtable_map db with Not_found -> error_no_such_hint_database db
-  in
-  List.map lookup dbnames
-
-let trivial ?(debug=Off) lems dbnames gl =
+let trivial ?(debug=Off) lems dbnames =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let db_list = make_db_list dbnames in
   let d = mk_trivial_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
-
-let full_trivial ?(debug=Off) lems gl =
-  let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_remove "v62" dbnames in
-  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+    (trivial_fail_db d false db_list hints)
+  end
+
+let full_trivial ?(debug=Off) lems =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let db_list = current_pure_db () in
   let d = mk_trivial_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
+    (trivial_fail_db d false db_list hints)
+  end
 
 let gen_trivial ?(debug=Off) lems = function
   | None -> full_trivial ~debug lems
   | Some l -> trivial ~debug lems l
 
-let h_trivial ?(debug=Off) lems l =
-  Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l))
-    (gen_trivial ~debug lems l)
+let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l
 
 (**************************************************************************)
 (*                       The classical Auto tactic                        *)
@@ -1390,88 +430,90 @@ let h_trivial ?(debug=Off) lems l =
 let possible_resolve dbg mod_delta db_list local_db cl =
   try
     let head =
-      try let hdconstr,_ = head_constr_bound cl in
-	    Some (head_of_constr_reference hdconstr)
+      try let hdconstr = decompose_app_bound cl in
+	    Some hdconstr
       with Bound -> None
     in
       List.map (tac_of_hint dbg db_list local_db cl)
 	(my_find_search mod_delta db_list local_db head cl)
   with Not_found -> []
 
-let dbg_case dbg id =
-  tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id))
-
-let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl =
-  try
-    let ccl = applist (head_constr typc) in
-    match Hipattern.match_with_conjunction ccl with
-    | Some (_,args) ->
-	tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl
-    | None ->
-	kont2 gl
-  with UserError _ -> kont2 gl
-
-let decomp_empty_term dbg (id,_,typc) gl =
-  if Hipattern.is_empty_type typc then
-    dbg_case dbg id gl
-  else
-    errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.")
-
-let extend_local_db gl decl db =
-  Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db
+let extend_local_db decl db gl =
+  Hint_db.add_list (make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) decl) db
 
 (* Introduce an hypothesis, then call the continuation tactic [kont]
    with the hint db extended with the so-obtained hypothesis *)
 
 let intro_register dbg kont db =
-  tclTHEN (dbg_intro dbg)
-    (onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl))
+  Tacticals.New.tclTHEN (dbg_intro dbg)
+    (Proofview.Goal.enter begin fun gl ->
+      let extend_local_db decl db = extend_local_db decl db gl in
+      Tacticals.New.onLastDecl (fun decl -> kont (extend_local_db decl db))
+    end)
 
 (* n is the max depth of search *)
 (* local_db contains the local Hypotheses *)
 
-exception Uplift of tactic list
-
 let search d n mod_delta db_list local_db =
   let rec search d n local_db =
-    if n=0 then (fun gl -> error "BOUND 2") else
-      tclORELSE0 (dbg_assumption d)
-	(tclORELSE0 (intro_register d (search d n) local_db)
-	   (fun gl ->
-	     let d' = incr_dbg d in
-	     tclFIRST
-	       (List.map
-		  (fun ntac -> tclTHEN ntac (search d' (n-1) local_db))
-		  (possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl))
+    (* spiwack: the test of [n] to 0 must be done independently in
+       each goal. Hence the [tclEXTEND] *)
+    Proofview.tclEXTEND [] begin
+      if Int.equal n 0 then Proofview.tclZERO (Errors.UserError ("",str"BOUND 2")) else
+        Tacticals.New.tclORELSE0 (dbg_assumption d)
+	  (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db)
+	     ( Proofview.Goal.enter begin fun gl ->
+               let concl = Tacmach.New.pf_nf_concl gl in
+	       let d' = incr_dbg d in
+	       Tacticals.New.tclFIRST
+	         (List.map
+		    (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db))
+		    (possible_resolve d mod_delta db_list local_db concl))
+             end))
+    end []
   in
   search d n local_db
 
 let default_search_depth = ref 5
 
-let delta_auto ?(debug=Off) mod_delta n lems dbnames gl =
+let delta_auto debug mod_delta n lems dbnames =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let db_list = make_db_list dbnames in
   let d = mk_auto_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
+    (search d n mod_delta db_list hints)
+  end
 
-let auto ?(debug=Off) n = delta_auto ~debug false n
+let delta_auto = 
+  if Flags.profile then
+    let key = Profile.declare_profile "delta_auto" in
+      Profile.profile5 key delta_auto
+  else delta_auto
 
-let new_auto ?(debug=Off) n = delta_auto ~debug true n
+let auto ?(debug=Off) n = delta_auto debug false n
+
+let new_auto ?(debug=Off) n = delta_auto debug true n
 
 let default_auto = auto !default_search_depth [] []
 
-let delta_full_auto ?(debug=Off) mod_delta n lems gl =
-  let dbnames = Hintdbmap.dom !searchtable in
-  let dbnames = list_remove "v62" dbnames in
-  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+let delta_full_auto ?(debug=Off) mod_delta n lems =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let db_list = current_pure_db () in
   let d = mk_auto_dbg debug in
+  let hints = make_local_hint_db env sigma false lems in
   tclTRY_dbg d
-    (search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
+    (search d n mod_delta db_list hints)
+  end
 
 let full_auto ?(debug=Off) n = delta_full_auto ~debug false n
 let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n
 
-let default_full_auto gl = full_auto !default_search_depth [] gl
+let default_full_auto = full_auto !default_search_depth []
 
 let gen_auto ?(debug=Off) n lems dbnames =
   let n = match n with None -> !default_search_depth | Some n -> n in
@@ -1479,8 +521,4 @@ let gen_auto ?(debug=Off) n lems dbnames =
   | None -> full_auto ~debug n lems
   | Some l -> auto ~debug n lems l
 
-let inj_or_var = Option.map (fun n -> ArgArg n)
-
-let h_auto ?(debug=Off) n lems l =
-  Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l))
-    (gen_auto ~debug n lems l)
+let h_auto ?(debug=Off) n lems l = gen_auto ~debug n lems l
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 5ac2de87..ea3f0ac0 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -1,268 +1,87 @@
 (************************************************************************)
 (*  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 Util
 open Names
 open Term
-open Sign
 open Proof_type
-open Tacmach
 open Clenv
 open Pattern
-open Environ
 open Evd
-open Libnames
-open Vernacexpr
-open Mod_subst
+open Decl_kinds
+open Hints
 
-(** Auto and related automation tactics *)
-
-type 'a auto_tactic =
-  | Res_pf     of constr * 'a    (** Hint Apply *)
-  | ERes_pf    of constr * 'a    (** Hint EApply *)
-  | Give_exact of constr
-  | Res_pf_THEN_trivial_fail of constr * 'a (** Hint Immediate *)
-  | Unfold_nth of evaluable_global_reference          (** Hint Unfold *)
-  | Extern     of Tacexpr.glob_tactic_expr   (** Hint Extern *)
-
-open Glob_term
-
-type hints_path_atom = 
-  | PathHints of global_reference list
-  | PathAny
-
-type 'a gen_auto_tactic = {
-  pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
-  pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
-  name  : hints_path_atom; (** A potential name to refer to the hint *) 
-  code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
-}
-
-type pri_auto_tactic = clausenv gen_auto_tactic
-
-type stored_data = int * clausenv gen_auto_tactic
-
-type search_entry
-
-(** The head may not be bound. *)
-
-type hint_entry = global_reference option * types gen_auto_tactic
-
-type hints_path =
-  | PathAtom of hints_path_atom
-  | PathStar of hints_path
-  | PathSeq of hints_path * hints_path
-  | PathOr of hints_path * hints_path
-  | PathEmpty
-  | PathEpsilon
-
-val normalize_path : hints_path -> hints_path
-val path_matches : hints_path -> hints_path_atom list -> bool
-val path_derivate : hints_path -> hints_path_atom -> hints_path
-val pp_hints_path : hints_path -> Pp.std_ppcmds
-
-module Hint_db :
-  sig
-    type t
-    val empty : transparent_state -> bool -> t
-    val find : global_reference -> t -> search_entry
-    val map_none : t -> pri_auto_tactic list
-    val map_all : global_reference -> t -> pri_auto_tactic list
-    val map_auto : global_reference * constr -> t -> pri_auto_tactic list
-    val add_one : hint_entry -> t -> t
-    val add_list : (hint_entry) list -> t -> t
-    val remove_one : global_reference -> t -> t
-    val remove_list : global_reference list -> t -> t
-    val iter : (global_reference option -> pri_auto_tactic list -> unit) -> t -> unit
-
-    val use_dn : t -> bool
-    val transparent_state : t -> transparent_state
-    val set_transparent_state : t -> transparent_state -> t
-
-    val add_cut : hints_path -> t -> t
-    val cut : t -> hints_path
-
-    val unfolds : t -> Idset.t * Cset.t
-  end
-
-type hint_db_name = string
-
-type hint_db = Hint_db.t
-
-type hints_entry =
-  | HintsResolveEntry of (int option * bool * hints_path_atom * constr) list
-  | HintsImmediateEntry of (hints_path_atom * constr) list
-  | HintsCutEntry of hints_path
-  | HintsUnfoldEntry of evaluable_global_reference list
-  | HintsTransparencyEntry of evaluable_global_reference list * bool
-  | HintsExternEntry of
-      int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
-
-val searchtable_map : hint_db_name -> hint_db
-
-val searchtable_add : (hint_db_name * hint_db) -> unit
-
-(** [create_hint_db local name st use_dn].
-   [st] is a transparency state for unification using this db
-   [use_dn] switches the use of the discrimination net for all hints
-   and patterns. *)
-
-val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
-
-val remove_hints : bool -> hint_db_name list -> global_reference list -> unit
-
-val current_db_names : unit -> hint_db_name list
-
-val interp_hints : hints_expr -> hints_entry
+val extern_interp :
+  (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t
 
-val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
-
-val prepare_hint : env -> open_constr -> constr
-
-val print_searchtable : unit -> unit
-
-val print_applicable_hint : unit -> unit
-
-val print_hint_ref : global_reference -> unit
-
-val print_hint_db_by_name : hint_db_name -> unit
-
-val print_hint_db : Hint_db.t -> unit
-
-(** [make_exact_entry pri (c, ctyp)].
-   [c] is the term given as an exact proof to solve the goal;
-   [ctyp] is the type of [c]. *)
-
-val make_exact_entry : evar_map -> int option -> ?name:hints_path_atom -> constr * constr -> hint_entry
-
-(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
-   [eapply] is true if this hint will be used only with EApply;
-   [hnf] should be true if we should expand the head of cty before searching for
-   products;
-   [c] is the term given as an exact proof to solve the goal;
-   [cty] is the type of [c]. *)
-
-val make_apply_entry :
-  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
-  constr * constr -> hint_entry
-
-(** A constr which is Hint'ed will be:
-   - (1) used as an Exact, if it does not start with a product
-   - (2) used as an Apply, if its HNF starts with a product, and
-         has no missing arguments.
-   - (3) used as an EApply, if its HNF starts with a product, and
-         has missing arguments. *)
-
-val make_resolves :
-  env -> evar_map -> bool * bool * bool -> int option -> ?name:hints_path_atom -> 
-  constr -> hint_entry list
-
-(** [make_resolve_hyp hname htyp].
-   used to add an hypothesis to the local hint database;
-   Never raises a user exception;
-   If the hyp cannot be used as a Hint, the empty list is returned. *)
-
-val make_resolve_hyp :
-  env -> evar_map -> named_declaration -> hint_entry list
-
-(** [make_extern pri pattern tactic_expr] *)
-
-val make_extern :
-  int -> constr_pattern option -> Tacexpr.glob_tactic_expr
-      -> hint_entry
-
-val set_extern_interp :
-  (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
-
-val set_extern_intern_tac :
-  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr)
-  -> unit
-
-val set_extern_subst_tactic :
-  (substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
-  -> unit
-
-(** Create a Hint database from the pairs (name, constr).
-   Useful to take the current goal hypotheses as hints;
-   Boolean tells if lemmas with evars are allowed *)
-
-val make_local_hint_db : ?ts:transparent_state -> bool -> open_constr list -> goal sigma -> hint_db
+(** Auto and related automation tactics *)
 
 val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list
 
 val default_search_depth : int ref
 
-val auto_unif_flags : Unification.unify_flags
+val auto_flags_of_state : transparent_state -> Unification.unify_flags
 
 (** Try unification with the precompiled clause, then use registered Apply *)
-val unify_resolve_nodelta : (constr * clausenv) -> tactic
+val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> unit Proofview.tactic
 
-val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic
+val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> unit Proofview.tactic
 
 (** [ConclPattern concl pat tacast]:
    if the term concl matches the pattern pat, (in sense of
    [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
    right values to build a tactic *)
 
-val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> tactic
+val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic
 
 (** The Auto tactic *)
 
 (** The use of the "core" database can be de-activated by passing
     "nocore" amongst the databases. *)
 
-val make_db_list : hint_db_name list -> hint_db list
-
 val auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> hint_db_name list -> tactic
+  int -> open_constr list -> hint_db_name list -> unit Proofview.tactic
 
 (** Auto with more delta. *)
 
 val new_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> hint_db_name list -> tactic
+  int -> open_constr list -> hint_db_name list -> unit Proofview.tactic
 
 (** auto with default search depth and with the hint database "core" *)
-val default_auto : tactic
+val default_auto : unit Proofview.tactic
 
 (** auto with all hint databases except the "v62" compatibility database *)
 val full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> tactic
+  int -> open_constr list -> unit Proofview.tactic
 
 (** auto with all hint databases except the "v62" compatibility database
    and doing delta *)
 val new_full_auto : ?debug:Tacexpr.debug ->
-  int -> open_constr list -> tactic
+  int -> open_constr list -> unit Proofview.tactic
 
 (** auto with default search depth and with all hint databases
    except the "v62" compatibility database *)
-val default_full_auto : tactic
+val default_full_auto : unit Proofview.tactic
 
 (** The generic form of auto (second arg [None] means all bases) *)
 val gen_auto : ?debug:Tacexpr.debug ->
-  int option -> open_constr list -> hint_db_name list option -> tactic
+  int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
 (** The hidden version of auto *)
 val h_auto   : ?debug:Tacexpr.debug ->
-  int option -> open_constr list -> hint_db_name list option -> tactic
+  int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic
 
 (** Trivial *)
 
 val trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list -> tactic
+  open_constr list -> hint_db_name list -> unit Proofview.tactic
 val gen_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> tactic
+  open_constr list -> hint_db_name list option -> unit Proofview.tactic
 val full_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> tactic
+  open_constr list -> unit Proofview.tactic
 val h_trivial : ?debug:Tacexpr.debug ->
-  open_constr list -> hint_db_name list option -> tactic
-
-val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
-
-(** Hook for changing the initialization of auto *)
-
-val add_auto_init : (unit -> unit) -> unit
+  open_constr list -> hint_db_name list option -> unit Proofview.tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 93441a93..ee8e1855 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -1,39 +1,37 @@
 (************************************************************************)
 (*  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 Equality
-open Hipattern
 open Names
 open Pp
-open Proof_type
 open Tacticals
-open Tacinterp
 open Tactics
 open Term
 open Termops
+open Errors
 open Util
-open Glob_term
-open Vernacinterp
 open Tacexpr
 open Mod_subst
+open Locus
 
 (* Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr }
+		  rew_tac: glob_tactic_expr option }
 
 let subst_hint subst hint =
   let cst' = subst_mps subst hint.rew_lemma in
   let typ' = subst_mps subst hint.rew_type in
   let pat' = subst_mps subst hint.rew_pat in
-  let t' = Tacinterp.subst_tactic subst hint.rew_tac in
+  let t' = Option.smartmap (Tacsubst.subst_tactic subst) hint.rew_tac in
     if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else
       { hint with
 	rew_lemma = cst'; rew_type = typ';
@@ -43,9 +41,7 @@ module HintIdent =
 struct
   type t = int * rew_rule
 
-  let compare (i,t) (i',t') =
-    Pervasives.compare i i'
-(*     Pervasives.compare t.rew_lemma t'.rew_lemma *)
+  let compare (i, t) (j, t') = i - j
 
   let subst s (i,t) = (i,subst_hint s t)
 
@@ -62,23 +58,15 @@ module HintDN = Term_dnet.Make(HintIdent)(HintOpt)
 
 (* Summary and Object declaration *)
 let rewtab =
-  ref (Stringmap.empty : HintDN.t Stringmap.t)
+  Summary.ref (String.Map.empty : HintDN.t String.Map.t) ~name:"autorewrite"
 
-let _ =
-  let init () = rewtab := Stringmap.empty in
-  let freeze () = !rewtab in
-  let unfreeze fs = rewtab := fs in
-  Summary.declare_summary "autorewrite"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
+let raw_find_base bas = String.Map.find bas !rewtab
 
 let find_base bas =
- try Stringmap.find bas !rewtab
- with
-  Not_found ->
-   errorlabstrm "AutoRewrite"
-     (str ("Rewriting base "^(bas)^" does not exist."))
+  try raw_find_base bas
+  with Not_found ->
+    errorlabstrm "AutoRewrite"
+      (str ("Rewriting base "^(bas)^" does not exist."))
 
 let find_rewrites bas =
   List.rev_map snd (HintDN.find_all (find_base bas))
@@ -86,45 +74,55 @@ let find_rewrites bas =
 let find_matches bas pat =
   let base = find_base bas in
   let res = HintDN.search_pattern base pat in
-    List.map (fun ((_,rew), esubst, subst) -> rew) res
+  List.map snd res
 
 let print_rewrite_hintdb bas =
-  ppnl (str "Database " ++ str bas ++ (Pp.cut ()) ++
-	   prlist_with_sep Pp.cut
+  (str "Database " ++ str bas ++ fnl () ++
+	   prlist_with_sep fnl
 	   (fun h ->
 	     str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++
 	       Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++
-	       str " then use tactic " ++
-	       Pptactic.pr_glob_tactic (Global.env()) h.rew_tac)
+	       Option.cata (fun tac -> str " then use tactic " ++
+	       Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac)
 	   (find_rewrites bas))
 
-type raw_rew_rule = loc * constr * bool * raw_tactic_expr
+type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option
 
 (* Applies all the rules of one base *)
 let one_base general_rewrite_maybe_in tac_main bas =
   let lrul = find_rewrites bas in
-  let lrul = List.map (fun h -> (h.rew_lemma,h.rew_l2r,Tacinterp.eval_tactic h.rew_tac)) lrul in
-    tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
-      tclTHEN tac
-        (tclREPEAT_MAIN
-	    (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main)))
-      tclIDTAC lrul))
+  let try_rewrite dir ctx c tc = Proofview.Goal.nf_enter (fun gl ->
+    let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in
+    let c' = Vars.subst_univs_level_constr subst c in
+    let sigma = Proofview.Goal.sigma gl in
+    let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in
+    Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+      (general_rewrite_maybe_in dir c' tc)
+  ) in
+  let lrul = List.map (fun h -> 
+  let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in
+    (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in
+    Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) ->
+      Tacticals.New.tclTHEN tac
+        (Tacticals.New.tclREPEAT_MAIN
+	    (Tacticals.New.tclTHENFIRST (try_rewrite dir ctx csr tc) tac_main)))
+      (Proofview.tclUNIT()) lrul))
 
 (* The AutoRewrite tactic *)
 let autorewrite ?(conds=Naive) tac_main lbas =
-  tclREPEAT_MAIN (tclPROGRESS
+  Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS
     (List.fold_left (fun tac bas ->
-       tclTHEN tac
+       Tacticals.New.tclTHEN tac
         (one_base (fun dir c tac ->
-	  let tac = tac, conds in
-	    general_rewrite dir all_occurrences true false ~tac c)
+	  let tac = (tac, conds) in
+	    general_rewrite dir AllOccurrences true false ~tac c)
 	  tac_main bas))
-      tclIDTAC lbas))
+      (Proofview.tclUNIT()) lbas))
 
-let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
-  fun gl ->
+let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas =
+ Proofview.Goal.nf_enter begin fun gl ->
  (* let's check at once if id exists (to raise the appropriate error) *)
- let _ = List.map (Tacmach.pf_get_hyp gl) idl in
+ let _ = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) idl in
  let general_rewrite_in id =
   let id = ref id in
   let to_be_cleared = ref false in
@@ -133,15 +131,15 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
      match Tacmach.pf_hyps gl with
         (last_hyp_id,_,_)::_ -> last_hyp_id
       | _ -> (* even the hypothesis id is missing *)
-             error ("No such hypothesis: " ^ (string_of_id !id) ^".")
+        raise (Logic.RefinerError (Logic.NoSuchHyp !id))
     in
-    let gl' = general_rewrite_in dir all_occurrences true ~tac:(tac, conds) false !id cstr false gl in
+    let gl' = Proofview.V82.of_tactic (general_rewrite_in dir AllOccurrences true ~tac:(tac, conds) false !id cstr false) gl in
     let gls = gl'.Evd.it in
     match gls with
        g::_ ->
         (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with
             (lastid,_,_)::_ ->
-              if last_hyp_id <> lastid then
+              if not (Id.equal last_hyp_id lastid) then
                begin
                 let gl'' =
                   if !to_be_cleared then
@@ -159,11 +157,13 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic =
           | _ -> assert false) (* there must be at least an hypothesis *)
      | _ -> assert false (* rewriting cannot complete a proof *)
  in
- tclMAP (fun id ->
-  tclREPEAT_MAIN (tclPROGRESS
+ let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in
+ Tacticals.New.tclMAP (fun id ->
+  Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS
     (List.fold_left (fun tac bas ->
-       tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas)))
-   idl gl
+       Tacticals.New.tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) (Proofview.tclUNIT()) lbas)))
+   idl
+ end
 
 let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id]
 
@@ -171,53 +171,48 @@ let gen_auto_multi_rewrite conds tac_main lbas cl =
   let try_do_hyps treat_id l =
     autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas
   in
-  if cl.concl_occs <> all_occurrences_expr &
-     cl.concl_occs <> no_occurrences_expr
+  if cl.concl_occs != AllOccurrences &&
+     cl.concl_occs != NoOccurrences
   then
-    error "The \"at\" syntax isn't available yet for the autorewrite tactic."
+    Proofview.tclZERO (UserError("" , str"The \"at\" syntax isn't available yet for the autorewrite tactic."))
   else
     let compose_tac t1 t2 =
       match cl.onhyps with
 	| Some [] -> t1
-	| _ ->      tclTHENFIRST t1 t2
+	| _ ->      Tacticals.New.tclTHENFIRST t1 t2
     in
     compose_tac
-	(if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC)
+	(if cl.concl_occs != NoOccurrences then autorewrite ~conds tac_main lbas else Proofview.tclUNIT ())
 	(match cl.onhyps with
 	   | Some l -> try_do_hyps (fun ((_,id),_) -> id) l
 	   | None ->
-	       fun gl ->
 		 (* try to rewrite in all hypothesis
 		    (except maybe the rewritten one) *)
-		 let ids =  Tacmach.pf_ids_of_hyps gl
-		 in try_do_hyps (fun id -> id)  ids gl)
+               Proofview.Goal.nf_enter begin fun gl ->
+                 let ids = Tacmach.New.pf_ids_of_hyps gl in
+		 try_do_hyps (fun id -> id)  ids
+               end)
 
-let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tclIDTAC
+let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT())
 
-let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl =
-  let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in
-  match onconcl,cl.Tacexpr.onhyps with
+let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl =
+  let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in
+  match onconcl,cl.Locus.onhyps with
     | false,Some [_] | true,Some [] | false,Some [] ->
 	(* autorewrite with .... in clause using tac n'est sur que
 	   si clause represente soit le but soit UNE hypothese
 	*)
-	gen_auto_multi_rewrite conds tac_main lbas cl gl
+	gen_auto_multi_rewrite conds tac_main lbas cl
     | _ ->
-	    Util.errorlabstrm "autorewrite"
-	      (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")
+        Proofview.tclZERO (UserError ("autorewrite",strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion."))
 
 (* Functions necessary to the library object declaration *)
 let cache_hintrewrite (_,(rbase,lrl)) =
-  let base =
-    try find_base rbase
-    with e when Errors.noncritical e -> HintDN.empty
-  in
-  let max =
-    try fst (Util.list_last (HintDN.find_all base))
-    with e when Errors.noncritical e -> 0
+  let base = try raw_find_base rbase with Not_found -> HintDN.empty in
+  let max = try fst (Util.List.last (HintDN.find_all base)) with Failure _ -> 0
   in
   let lrl = HintDN.map (fun (i,h) -> (i + max, h)) lrl in
-    rewtab:=Stringmap.add rbase (HintDN.union lrl base) !rewtab
+    rewtab:=String.Map.add rbase (HintDN.union lrl base) !rewtab
 
 
 let subst_hintrewrite (subst,(rbase,list as node)) =
@@ -250,12 +245,6 @@ type hypinfo = {
   hyp_right : constr;
 }
 
-let evd_convertible env evd x y =
-  try
-    ignore(Unification.w_unify ~flags:Unification.elim_flags env evd Reduction.CONV x y); true 
-  (* try ignore(Evarconv.the_conv_x env x y evd); true *)
-  with e when Errors.noncritical e -> false
-
 let decompose_applied_relation metas env sigma c ctype left2right =
   let find_rel ty =
     let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
@@ -296,7 +285,7 @@ let find_applied_relation metas loc env sigma c left2right =
     | Some c -> c
     | None ->
 	user_err_loc (loc, "decompose_applied_relation",
-		     str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++
+		     str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++
 		       spc () ++ str"of this term does not end with an applied relation.")
 
 (* To add rewriting rules to a base *)
@@ -304,12 +293,12 @@ let add_rew_rules base lrul =
   let counter = ref 0 in
   let lrul =
     List.fold_left
-      (fun dn (loc,c,b,t) ->
+      (fun dn (loc,(c,ctx),b,t) ->
 	let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in
 	let pat = if b then info.hyp_left else info.hyp_right in
 	let rul = { rew_lemma = c; rew_type = info.hyp_ty;
-		    rew_pat = pat; rew_l2r = b;
-		    rew_tac = Tacinterp.glob_tactic t}
+		    rew_pat = pat; rew_ctx = ctx; rew_l2r = b;
+		    rew_tac = Option.map Tacintern.glob_tactic t}
 	in incr counter;
 	  HintDN.add pat (!counter, rul) dn) HintDN.empty lrul
   in Lib.add_anonymous_leaf (inHintRewrite (base,lrul))
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index b0016449..9905b520 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.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,11 +8,10 @@
 
 open Term
 open Tacexpr
-open Tacmach
 open Equality
 
 (** Rewriting rules before tactic interpretation *)
-type raw_rew_rule = Util.loc * Term.constr * bool * Tacexpr.raw_tactic_expr
+type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option
 
 (** To add rewriting rules to a base *)
 val add_rew_rules : string -> raw_rew_rule list -> unit
@@ -21,25 +20,26 @@ val add_rew_rules : string -> raw_rew_rule list -> unit
    The optional conditions tell rewrite how to handle matching and side-condition solving.
    Default is Naive: first match in the clause, don't look at the side-conditions to
    tell if the rewrite succeeded. *)
-val autorewrite : ?conds:conditions -> tactic -> string list -> tactic
-val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic
+val autorewrite : ?conds:conditions -> unit Proofview.tactic -> string list -> unit Proofview.tactic
+val autorewrite_in : ?conds:conditions -> Names.Id.t -> unit Proofview.tactic -> string list -> unit Proofview.tactic
 
 (** Rewriting rules *)
 type rew_rule = { rew_lemma: constr;
 		  rew_type: types;
 		  rew_pat: constr;
+		  rew_ctx: Univ.universe_context_set;
 		  rew_l2r: bool;
-		  rew_tac: glob_tactic_expr }
+		  rew_tac: glob_tactic_expr option }
 
 val find_rewrites : string -> rew_rule list
 
 val find_matches : string -> constr -> rew_rule list
 
-val auto_multi_rewrite : ?conds:conditions -> string list -> Tacticals.clause -> tactic
+val auto_multi_rewrite : ?conds:conditions -> string list -> Locus.clause -> unit Proofview.tactic
 
-val auto_multi_rewrite_with : ?conds:conditions -> tactic -> string list -> Tacticals.clause -> tactic
+val auto_multi_rewrite_with : ?conds:conditions -> unit Proofview.tactic -> string list -> Locus.clause -> unit Proofview.tactic
 
-val print_rewrite_hintdb : string -> unit
+val print_rewrite_hintdb : string -> Pp.std_ppcmds
 
 open Clenv
 
@@ -56,6 +56,6 @@ type hypinfo = {
 }
 
 val find_applied_relation : bool ->
-  Util.loc ->
+  Loc.t ->
   Environ.env -> Evd.evar_map -> Term.constr -> bool -> hypinfo
 
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 182cac7d..1f5177c3 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -1,16 +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 Util
 open Term
 open Names
-open Termdn
 open Pattern
-open Libnames
+open Globnames
 
 (* Discrimination nets with bounded depth.
    See the module dn.ml for further explanations.
@@ -18,133 +18,159 @@ open Libnames
 
 let dnet_depth = ref 8
 
+type term_label =
+| GRLabel of global_reference
+| ProdLabel
+| LambdaLabel
+| SortLabel
+
+let compare_term_label t1 t2 = match t1, t2 with
+| GRLabel gr1, GRLabel gr2 -> RefOrdered.compare gr1 gr2
+| _ -> Pervasives.compare t1 t2 (** OK *)
+
+type 'res lookup_res = 'res Dn.lookup_res = Label of 'res | Nothing | Everything
+
+let decomp_pat =
+  let rec decrec acc = function
+    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
+    | PProj (p, c) -> (PRef (ConstRef (Projection.constant p)), c :: acc)
+    | c -> (c,acc)
+  in
+  decrec []
+
+let decomp =
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc)
+    | Cast (c1,_,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in
+    decrec []
+
+let constr_val_discr t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id -> Label(GRLabel (VarRef id),l)
+    | Const _ -> Everything
+    | _ -> Nothing
+
+let constr_pat_discr t =
+  if not (Patternops.occur_meta_pattern t) then
+    None
+  else
+    match decomp_pat t with
+    | PRef ((IndRef _) as ref), args
+    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
+    | _ -> None
+
+let constr_val_discr_st (idpred,cpred) t =
+  let c, l = decomp t in
+    match kind_of_term c with
+    | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
+    | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l)
+    | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l)
+    | Var id when not (Id.Pred.mem id idpred) -> Label(GRLabel (VarRef id),l)
+    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
+    | Lambda (n, d, c) -> 
+      if List.is_empty l then 
+	Label(LambdaLabel, [d; c] @ l)
+      else Everything
+    | Sort _ -> Label(SortLabel, [])
+    | Evar _ -> Everything
+    | _ -> Nothing
+
+let constr_pat_discr_st (idpred,cpred) t =
+  match decomp_pat t with
+  | PRef ((IndRef _) as ref), args
+  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
+  | PRef ((VarRef v) as ref), args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel ref,args)
+  | PVar v, args when not (Id.Pred.mem v idpred) ->
+      Some(GRLabel (VarRef v),args)
+  | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
+      Some (GRLabel ref, args)
+  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
+  | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c])
+  | PSort s, [] -> Some (SortLabel, [])
+  | _ -> None
+
+let bounded_constr_pat_discr_st st (t,depth) =
+  if Int.equal depth 0 then
+    None
+  else
+    match constr_pat_discr_st st t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+let bounded_constr_val_discr_st st (t,depth) =
+  if Int.equal depth 0 then
+    Nothing
+  else
+    match constr_val_discr_st st t with
+      | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l)
+      | Nothing -> Nothing
+      | Everything -> Everything
+
+let bounded_constr_pat_discr (t,depth) =
+  if Int.equal depth 0 then
+    None
+  else
+    match constr_pat_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+let bounded_constr_val_discr (t,depth) =
+  if Int.equal depth 0 then
+    Nothing
+  else
+    match constr_val_discr t with
+      | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l)
+      | Nothing -> Nothing
+      | Everything -> Everything
 
 module Make =
   functor (Z : Map.OrderedType) ->
 struct
-  module Term_dn = Termdn.Make(Z)
-
-  module X = struct
-    type t = constr_pattern*int
-    let compare = Pervasives.compare 
-  end
-
- module Y = struct 
-     type t = Term_dn.term_label
-     let compare x y = 
-       let make_name n =
-	 match n with
-	 | Term_dn.GRLabel(ConstRef con) -> 
-	     Term_dn.GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | Term_dn.GRLabel(IndRef (kn,i)) ->
-	     Term_dn.GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | Term_dn.GRLabel(ConstructRef ((kn,i),j ))->
-	     Term_dn.GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
+
+ module Y = struct
+    type t = term_label
+    let compare = compare_term_label
  end
- 
- module Dn = Dn.Make(X)(Y)(Z)
-  
+
+ module Dn = Dn.Make(Y)(Z)
+
  type t = Dn.t
 
   let create = Dn.create
 
-  let decomp = 
-    let rec decrec acc c = match kind_of_term c with
-      | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-      | Cast (c1,_,_) -> decrec acc c1
-      | _ -> (c,acc)
-    in 
-      decrec []
-
-  let constr_val_discr t =
-    let c, l = decomp t in
-      match kind_of_term c with
-      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-      | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-      | Const _ -> Dn.Everything
-      | _ -> Dn.Nothing
-	
-  let constr_val_discr_st (idpred,cpred) t =
-    let c, l = decomp t in
-      match kind_of_term c with
-      | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
-      | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-      | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-      | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-      | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
-      | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
-      | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
-      | Evar _ -> Dn.Everything
-      | _ -> Dn.Nothing
-
-  let bounded_constr_pat_discr_st st (t,depth) =
-    if depth = 0 then 
-      None 
-    else
-      match Term_dn.constr_pat_discr_st st t with
-	| None -> None
-	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-  let bounded_constr_val_discr_st st (t,depth) =
-    if depth = 0 then 
-      Dn.Nothing 
-    else
-      match constr_val_discr_st st t with
-	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-	| Dn.Nothing -> Dn.Nothing
-	| Dn.Everything -> Dn.Everything
-
-  let bounded_constr_pat_discr (t,depth) =
-    if depth = 0 then 
-      None 
-    else
-      match Term_dn.constr_pat_discr t with
-	| None -> None
-	| Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
-	    
-  let bounded_constr_val_discr (t,depth) =
-    if depth = 0 then 
-      Dn.Nothing 
-    else
-      match constr_val_discr t with
-	| Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l)
-	| Dn.Nothing -> Dn.Nothing
-	| Dn.Everything -> Dn.Everything
-	    
-	    
   let add = function
-    | None -> 
-	(fun dn (c,v) -> 
+    | None ->
+	(fun dn (c,v) ->
 	   Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-    | Some st -> 
-	(fun dn (c,v) -> 
+    | Some st ->
+	(fun dn (c,v) ->
 	   Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
-	  
+
   let rmv = function
-    | None -> 
-	(fun dn (c,v) -> 
+    | None ->
+	(fun dn (c,v) ->
 	   Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v))
-    | Some st -> 
-	(fun dn (c,v) -> 
+    | Some st ->
+	(fun dn (c,v) ->
 	 Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v))
-	  
+
   let lookup = function
-    | None -> 
+    | None ->
 	(fun dn t ->
-	   List.map 
-	     (fun ((c,_),v) -> (c,v)) 
-	     (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)))
-    | Some st -> 
+	     Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))
+    | Some st ->
 	(fun dn t ->
-	   List.map 
-	     (fun ((c,_),v) -> (c,v)) 
-	     (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)))
-	  
-  let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
-    
+	     Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))
+
+  let app f dn = Dn.app f dn
+
 end
-    
+
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index f9c2271a..6c396b4c 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.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        *)
@@ -11,6 +11,18 @@ open Pattern
 open Names
 
 (** Discrimination nets with bounded depth. *)
+
+(** This module registers actions (typically tactics) mapped to patterns *)
+
+(** Patterns are stocked linearly as the list of its node in prefix
+order in such a way patterns having the same prefix have this common
+prefix shared and the seek for the action associated to the patterns
+that a term matches are found in time proportional to the maximal
+number of nodes of the patterns matching the term. The [transparent_state]
+indicates which constants and variables can be considered as rigid.
+These dnets are able to cope with existential variables as well, which match
+[Everything]. *)
+
 module Make :
   functor (Z : Map.OrderedType) ->
 sig
@@ -21,9 +33,8 @@ sig
   val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t
   val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t
 
-  val lookup : transparent_state option -> t -> constr -> (constr_pattern * Z.t) list
-  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
+  val lookup : transparent_state option -> t -> constr -> Z.t list
+  val app : (Z.t -> unit) -> t -> unit
 end
-    
-val dnet_depth : int ref
 
+val dnet_depth : int ref
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
new file mode 100644
index 00000000..1c15fa40
--- /dev/null
+++ b/tactics/class_tactics.ml
@@ -0,0 +1,847 @@
+(************************************************************************)
+(*  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 Pp
+open Errors
+open Util
+open Names
+open Term
+open Termops
+open Reduction
+open Proof_type
+open Tacticals
+open Tacmach
+open Tactics
+open Patternops
+open Clenv
+open Typeclasses
+open Globnames
+open Evd
+open Locus
+open Misctypes
+open Proofview.Notations
+open Hints
+
+(** Hint database named "typeclass_instances", now created directly in Auto *)
+
+let typeclasses_debug = ref false
+let typeclasses_depth = ref None
+
+let typeclasses_modulo_eta = ref false
+let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d
+let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta
+
+let typeclasses_dependency_order = ref false
+let set_typeclasses_dependency_order d = (:=) typeclasses_dependency_order d
+let get_typeclasses_dependency_order () = !typeclasses_dependency_order
+
+open Goptions
+
+let set_typeclasses_modulo_eta =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "do typeclass search modulo eta conversion";
+      optkey   = ["Typeclasses";"Modulo";"Eta"];
+      optread  = get_typeclasses_modulo_eta;
+      optwrite = set_typeclasses_modulo_eta; }
+
+let set_typeclasses_dependency_order =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "during typeclass resolution, solve instances according to their dependency order";
+      optkey   = ["Typeclasses";"Dependency";"Order"];
+      optread  = get_typeclasses_dependency_order;
+      optwrite = set_typeclasses_dependency_order; }
+
+(** We transform the evars that are concerned by this resolution
+    (according to predicate p) into goals.
+    Invariant: function p only manipulates and returns undefined evars *)
+
+let top_sort evm undefs =
+  let l' = ref [] in
+  let tosee = ref undefs in
+  let rec visit ev evi = 
+    let evs = Evarutil.undefined_evars_of_evar_info evm evi in
+      Evar.Set.iter (fun ev -> 
+	if Evar.Map.mem ev !tosee then 
+	  visit ev (Evar.Map.find ev !tosee)) evs;
+      tosee := Evar.Map.remove ev !tosee;
+      l' := ev :: !l';
+  in
+    while not (Evar.Map.is_empty !tosee) do
+      let ev, evi = Evar.Map.min_binding !tosee in
+	visit ev evi
+    done;
+    List.rev !l'
+
+let evars_to_goals p evm =
+  let goals = ref Evar.Map.empty in
+  let map ev evi =
+    let evi, goal = p evm ev evi in
+    let () = if goal then goals := Evar.Map.add ev evi !goals in
+    evi
+  in
+  let evm = Evd.raw_map_undefined map evm in
+  if Evar.Map.is_empty !goals then None
+  else Some (!goals, evm)
+
+(** Typeclasses instance search tactic / eauto *)
+
+open Auto
+
+open Unification
+
+let auto_core_unif_flags st freeze = {
+  modulo_conv_on_closed_terms = Some st;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = st;
+  modulo_delta_types = st;
+  check_applied_meta_types = false;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = freeze;
+  restrict_conv_on_strict_subterms = false; (* ? *)
+  modulo_betaiota = true;
+  modulo_eta = !typeclasses_modulo_eta;
+}
+
+let auto_unif_flags freeze st = 
+  let fl = auto_core_unif_flags st freeze in
+  { core_unify_flags = fl;
+    merge_unify_flags = fl;
+    subterm_unify_flags = fl;
+    allow_K_in_toplevel_higher_order_unification = false;
+    resolve_evars = false
+}
+
+let rec eq_constr_mod_evars x y =
+  match kind_of_term x, kind_of_term y with
+  | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true
+  | _, _ -> compare_constr eq_constr_mod_evars x y
+
+let progress_evars t =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let check =
+      Proofview.Goal.nf_enter begin fun gl' ->
+        let newconcl = Proofview.Goal.concl gl' in
+        if eq_constr_mod_evars concl newconcl
+        then Tacticals.New.tclFAIL 0 (str"No progress made (modulo evars)")
+        else Proofview.tclUNIT ()
+      end
+    in t <*> check
+  end
+
+
+let e_give_exact flags poly (c,clenv) gl =
+  let c, gl =
+    if poly then
+      let clenv', subst = Clenv.refresh_undefined_univs clenv in
+      let clenv' = connect_clenv gl clenv' in
+      let c = Vars.subst_univs_level_constr subst c in
+	c, {gl with sigma = clenv'.evd}
+    else c, gl
+  in
+  let t1 = pf_type_of gl c in
+    tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
+
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+  Proofview.V82.of_tactic (Clenvtac.clenv_refine true ~with_classes:false clenv') gls
+
+let unify_resolve poly flags (c,clenv) gls =
+  let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+  Proofview.V82.of_tactic 
+    (Clenvtac.clenv_refine false ~with_classes:false clenv') gls
+
+let clenv_of_prods poly nprods (c, clenv) gls =
+  if poly || Int.equal nprods 0 then Some clenv
+  else
+    let ty = pf_type_of gls c in
+    let diff = nb_prod ty - nprods in
+      if Pervasives.(>=) diff 0 then
+        (* Was Some clenv... *)
+	Some (mk_clenv_from_n gls (Some diff) (c,ty))
+      else None
+
+let with_prods nprods poly (c, clenv) f gls =
+  match clenv_of_prods poly nprods (c, clenv) gls with
+  | None -> tclFAIL 0 (str"Not enough premisses") gls
+  | Some clenv' -> f (c, clenv') gls
+
+(** Hack to properly solve dependent evars that are typeclasses *)
+
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl =
+    Eauto.registered_e_assumption ::
+    (tclTHEN (Proofview.V82.of_tactic Tactics.intro)
+       (function g'->
+	  let d = pf_last_hyp g' in
+	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
+          (e_trivial_fail_db db_list
+	      (Hint_db.add_list hintl local_db) g'))) ::
+    (List.map (fun (x,_,_,_,_) -> x) 
+     (e_trivial_resolve db_list local_db (project goal) (pf_concl goal)))
+  in
+  tclFIRST (List.map tclCOMPLETE tacl) goal
+
+and e_my_find_search db_list local_db hdc complete sigma concl =
+  let prods, concl = decompose_prod_assum concl in
+  let nprods = List.length prods in
+  let freeze = 
+    try
+      let cl = Typeclasses.class_info (fst hdc) in
+	if cl.cl_strict then
+	  Evd.evars_of_term concl
+	else Evar.Set.empty
+    with _ -> Evar.Set.empty
+  in
+  let hintl =
+    List.map_append
+      (fun db ->
+	let tacs = 
+	  if Hint_db.use_dn db then (* Using dnet *)
+	    Hint_db.map_eauto hdc concl db
+	  else Hint_db.map_existential hdc concl db
+	in
+	let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in
+	  List.map (fun x -> (flags, x)) tacs)
+      (local_db::db_list)
+  in
+  let tac_of_hint =
+    fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) ->
+      let tac =
+	match t with
+	  | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags)
+	  | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags)
+	  | Give_exact c -> e_give_exact flags poly c
+	  | Res_pf_THEN_trivial_fail (term,cl) ->
+              tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags))
+	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])
+	  | Extern tacast ->
+	    Proofview.V82.of_tactic (conclPattern concl p tacast)
+      in
+      let tac = if complete then tclCOMPLETE tac else tac in
+	match t with
+	| Extern _ -> (tac,b,true, name, lazy (pr_autotactic t))
+	| _ ->
+(* 	  let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *)
+	    (tac,b,false, name, lazy (pr_autotactic t))
+  in List.map tac_of_hint hintl
+
+and e_trivial_resolve db_list local_db sigma concl =
+  try
+    e_my_find_search db_list local_db
+     (decompose_app_bound concl) true sigma concl
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db sigma concl =
+  try
+    e_my_find_search db_list local_db
+      (decompose_app_bound concl) false sigma concl
+  with Bound | Not_found -> []
+
+let catchable = function
+  | Refiner.FailError _ -> true
+  | e -> Logic.catchable_exception e
+
+let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
+
+let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l)
+
+type autoinfo = { hints : hint_db; is_evar: existential_key option;
+		  only_classes: bool; unique : bool;
+		  auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t;
+		  auto_path : global_reference option list;
+		  auto_cut : hints_path }
+type autogoal = goal * autoinfo
+type 'ans fk = unit -> 'ans
+type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
+type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
+
+type auto_result = autogoal list sigma
+
+type atac = auto_result tac
+
+(* Some utility types to avoid the need of -rectypes *)
+
+type 'a optionk =
+  | Nonek
+  | Somek of 'a * 'a optionk fk
+
+type ('a,'b) optionk2 =
+  | Nonek2
+  | Somek2 of 'a * 'b * ('a,'b) optionk2 fk
+
+let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
+  let cty = Evarutil.nf_evar sigma cty in
+  let rec iscl env ty =
+    let ctx, ar = decompose_prod_assum ty in
+      match kind_of_term (fst (decompose_app ar)) with
+      | Const (c,_) -> is_class (ConstRef c)
+      | Ind (i,_) -> is_class (IndRef i)
+      | _ ->
+	  let env' = Environ.push_rel_context ctx env in
+	  let ty' = whd_betadeltaiota env' ar in
+	       if not (Term.eq_constr ty' ar) then iscl env' ty'
+	       else false
+  in
+  let is_class = iscl env cty in
+  let keep = not only_classes || is_class in
+    if keep then
+      let c = mkVar id in
+      let name = PathHints [VarRef id] in
+      let hints =
+	if is_class then
+	  let hints = build_subclasses ~check:false env sigma (VarRef id) None in
+	    (List.map_append
+	       (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path)
+		  (true,false,Flags.is_verbose()) pri false
+		 (IsConstr (c,Univ.ContextSet.empty)))
+	       hints)
+	else []
+      in
+        (hints @ List.map_filter
+	 (fun f -> try Some (f (c, cty, Univ.ContextSet.empty)) 
+	   with Failure _ | UserError _ -> None)
+	 [make_exact_entry ~name env sigma pri false; 
+	  make_apply_entry ~name env sigma flags pri false])
+    else []
+
+let pf_filtered_hyps gls =
+  Goal.V82.hyps gls.Evd.sigma (sig_it gls)
+
+let make_hints g st only_classes sign =
+  let paths, hintlist =
+    List.fold_left
+    (fun (paths, hints) hyp ->
+      let consider =
+	try let (_, b, t) = Global.lookup_named (pi1 hyp) in
+	      (* Section variable, reindex only if the type changed *)
+	      not (Term.eq_constr t (pi3 hyp))
+	with Not_found -> true
+     in
+      if consider then 
+	let path, hint =
+	  PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp
+	in
+	  (PathOr (paths, path), hint @ hints)
+      else (paths, hints))
+    (PathEmpty, []) sign
+  in Hint_db.add_list hintlist (Hint_db.empty st true)
+
+let make_autogoal_hints =
+  let cache = ref (true, Environ.empty_named_context_val, 
+		   Hint_db.empty full_transparent_state true) 
+  in
+    fun only_classes ?(st=full_transparent_state) g ->
+      let sign = pf_filtered_hyps g in
+      let (onlyc, sign', cached_hints) = !cache in
+	if onlyc == only_classes && 
+	  (sign == sign' || Environ.eq_named_context_val sign sign') then
+	  cached_hints
+	else
+	  let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
+	    cache := (only_classes, sign, hints); hints
+
+let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
+  { skft = fun sk fk {it = gl,hints; sigma=s;} ->
+    let res = try Some (tac {it=gl; sigma=s;})
+              with e when catchable e -> None in
+      match res with
+      | Some gls -> sk (f gls hints) fk
+      | None -> fk () }
+
+let intro_tac : atac =
+  lift_tactic (Proofview.V82.of_tactic Tactics.intro)
+    (fun {it = gls; sigma = s} info ->
+      let gls' =
+	List.map (fun g' ->
+	  let env = Goal.V82.env s g' in
+	  let context = Environ.named_context_of_val (Goal.V82.hyps s g') in
+	  let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints)
+	    (true,false,false) info.only_classes None (List.hd context) in
+	  let ldb = Hint_db.add_list hint info.hints in
+	    (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls
+      in {it = gls'; sigma = s;})
+
+let normevars_tac : atac =
+  { skft = fun sk fk {it = (gl, info); sigma = s;} ->
+    let gl', sigma' = Goal.V82.nf_evar s gl in
+    let info' = { info with auto_last_tac = lazy (str"normevars") } in
+      sk {it = [gl', info']; sigma = sigma';} fk }
+
+let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
+  { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
+
+let is_Prop env sigma concl =
+  let ty = Retyping.get_type_of env sigma concl in
+  match kind_of_term ty with
+  | Sort (Prop Null) -> true
+  | _ -> false
+
+let is_unique env concl = 
+  try 
+    let (cl,u), args = dest_class_app env concl in
+      cl.cl_unique
+  with _ -> false
+
+let needs_backtrack env evd oev concl =
+  if Option.is_empty oev || is_Prop env evd concl then
+    occur_existential concl
+  else true
+
+let hints_tac hints =
+  { skft = fun sk fk {it = gl,info; sigma = s;} ->
+      let env = Goal.V82.env s gl in
+      let concl = Goal.V82.concl s gl in
+      let tacgl = {it = gl; sigma = s;} in
+      let poss = e_possible_resolve hints info.hints s concl in
+      let unique = is_unique env concl in
+      let rec aux i foundone = function
+      | (tac, _, b, name, pp) :: tl ->
+	let derivs = path_derivate info.auto_cut name in
+	let res =
+          try
+	    if path_matches derivs [] then None else Some (tac tacgl)
+	  with e when catchable e -> None
+	in
+	  (match res with
+	  | None -> aux i foundone tl
+	  | Some {it = gls; sigma = s';} ->
+	    if !typeclasses_debug then
+	      msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
+			 ++ str" on" ++ spc () ++ pr_ev s gl);
+	    let sgls =
+	      evars_to_goals
+		(fun evm ev evi ->
+		  if Typeclasses.is_resolvable evi && not (Evd.is_undefined s ev) &&
+		    (not info.only_classes || Typeclasses.is_class_evar evm evi)
+		  then Typeclasses.mark_unresolvable evi, true
+		  else evi, false) s'
+	    in
+	    let newgls, s' =
+	      let gls' = List.map (fun g -> (None, g)) gls in
+		match sgls with
+		| None -> gls', s'
+		| Some (evgls, s') ->
+		  if not !typeclasses_dependency_order then
+		    (gls' @ List.map (fun (ev,_) -> (Some ev, ev)) (Evar.Map.bindings evgls), s')
+		  else 
+ 		    (* Reorder with dependent subgoals. *)
+		    let evm = List.fold_left 
+		      (fun acc g -> Evar.Map.add g (Evd.find_undefined s' g) acc) evgls gls in
+		    let gls = top_sort s' evm in
+		      (List.map (fun ev -> Some ev, ev) gls, s')
+	    in
+	    let gls' = List.map_i
+	      (fun j (evar, g) ->
+		let info =
+		  { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
+		    is_evar = evar;
+		    hints =
+		      if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) 
+				     (Goal.V82.hyps s' gl))
+		      then make_autogoal_hints info.only_classes
+			~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s';}
+		      else info.hints;
+		    auto_cut = derivs }
+		in g, info) 1 newgls in
+	    let glsv = {it = gls'; sigma = s';} in
+	    let fk' =
+	      (fun () ->
+		let do_backtrack =
+		  if unique then occur_existential concl
+		  else if info.unique then true
+		  else if List.is_empty gls' then 
+		    needs_backtrack env s' info.is_evar concl
+		  else true
+		in
+		  if !typeclasses_debug then
+		    msg_debug 
+		      ((if do_backtrack then str"Backtracking after "
+			else str "Not backtracking after ")
+		       ++ Lazy.force pp);
+		  if do_backtrack then aux (succ i) true tl
+		  else fk ())
+	    in
+	      sk glsv fk')
+      | [] ->
+	if not foundone && !typeclasses_debug then
+	  msg_debug (pr_depth info.auto_depth ++ str": no match for " ++
+		       Printer.pr_constr_env (Goal.V82.env s gl) s concl ++
+		       spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities");
+	fk ()
+      in aux 1 false poss }
+
+let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
+  let rec aux s (acc : autogoal list list) fk = function
+    | (gl,info) :: gls ->
+	(match info.is_evar with
+	 | Some ev when Evd.is_defined s ev -> aux s acc fk gls
+	 | _ ->
+	     second.skft
+	       (fun {it=gls';sigma=s'} fk' -> 
+		 let fk'' =
+		   if not info.unique && List.is_empty gls' &&
+		     not (needs_backtrack (Goal.V82.env s gl) s
+			    info.is_evar (Goal.V82.concl s gl))
+		   then fk
+		   else fk'
+		 in
+		   aux s' (gls'::acc) fk'' gls)
+	       fk {it = (gl,info); sigma = s; })
+    | [] -> Somek2 (List.rev acc, s, fk)
+  in fun {it = gls; sigma = s; } fk ->
+    let rec aux' = function
+      | Nonek2 -> fk ()
+      | Somek2 (res, s', fk') ->
+	  let goals' = List.concat res in
+	    sk {it = goals'; sigma = s'; } (fun () -> aux' (fk' ()))
+    in aux' (aux s [] (fun () -> Nonek2) gls)
+
+let then_tac (first : atac) (second : atac) : atac =
+  { skft = fun sk fk -> first.skft (then_list second sk) fk }
+
+let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
+  t.skft (fun x _ -> Some x) (fun _ -> None) gl
+
+type run_list_res = auto_result optionk
+
+let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
+  (then_list t (fun x fk -> Somek (x, fk)))
+    gl
+    (fun _ -> Nonek)
+
+let fail_tac : atac =
+  { skft = fun sk fk _ -> fk () }
+
+let rec fix (t : 'a tac) : 'a tac =
+  then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
+
+let rec fix_limit limit (t : 'a tac) : 'a tac =
+  if Int.equal limit 0 then fail_tac
+  else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
+
+let make_autogoal ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) cut ev g =
+  let hints = make_autogoal_hints only_classes ~st g in
+    (g.it, { hints = hints ; is_evar = ev; unique = unique;
+	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none");
+	     auto_path = []; auto_cut = cut })
+
+
+let cut_of_hints h =
+  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
+
+let make_autogoals ?(only_classes=true) ?(unique=false) 
+    ?(st=full_transparent_state) hints gs evm' =
+  let cut = cut_of_hints hints in
+  { it = List.map_i (fun i g ->
+    let (gl, auto) = make_autogoal ~only_classes ~unique 
+      ~st cut (Some g) {it = g; sigma = evm'; } in
+      (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm'; }
+
+let get_result r =
+  match r with
+  | Nonek -> None
+  | Somek (gls, fk) -> Some (gls.sigma,fk)
+
+let run_on_evars ?(only_classes=true) ?(unique=false) ?(st=full_transparent_state) p evm hints tac =
+  match evars_to_goals p evm with
+  | None -> None (* This happens only because there's no evar having p *)
+  | Some (goals, evm') ->
+    let goals = 
+      if !typeclasses_dependency_order then
+	top_sort evm' goals
+      else List.map (fun (ev, _) -> ev) (Evar.Map.bindings goals)
+    in
+    let res = run_list_tac tac p goals 
+      (make_autogoals ~only_classes ~unique ~st hints goals evm') in
+      match get_result res with
+      | None -> raise Not_found
+      | Some (evm', fk) -> 
+	Some (evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm, fk)
+
+let eauto_tac hints =
+  then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
+
+let eauto_tac ?limit hints =
+  match limit with
+  | None -> fix (eauto_tac hints)
+  | Some limit -> fix_limit limit (eauto_tac hints)
+
+let eauto ?(only_classes=true) ?st ?limit hints g =
+  let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in
+    match run_tac (eauto_tac ?limit hints) gl with
+    | None -> raise Not_found
+    | Some {it = goals; sigma = s; } ->
+	{it = List.map fst goals; sigma = s;}
+
+let real_eauto ?limit unique st hints p evd =
+  let res =
+    run_on_evars ~st ~unique p evd hints (eauto_tac ?limit hints)
+  in
+    match res with
+    | None -> evd
+    | Some (evd', fk) -> 
+      if unique then
+	(match get_result (fk ()) with
+	| Some (evd'', fk') -> error "Typeclass resolution gives multiple solutions"
+	| None -> evd')
+      else evd'
+    
+let resolve_all_evars_once debug limit unique p evd =
+  let db = searchtable_map typeclasses_db in
+    real_eauto ?limit unique (Hint_db.transparent_state db) [db] p evd
+
+(** We compute dependencies via a union-find algorithm.
+    Beware of the imperative effects on the partition structure,
+    it should not be shared, but only used locally. *)
+
+module Intpart = Unionfind.Make(Evar.Set)(Evar.Map)
+
+let deps_of_constraints cstrs evm p =
+  List.iter (fun (_, _, x, y) ->
+    let evx = Evarutil.undefined_evars_of_term evm x in
+    let evy = Evarutil.undefined_evars_of_term evm y in
+    Intpart.union_set (Evar.Set.union evx evy) p)
+    cstrs
+
+let evar_dependencies evm p =
+  Evd.fold_undefined
+    (fun ev evi _ ->
+      let evars = Evar.Set.add ev (Evarutil.undefined_evars_of_evar_info evm evi)
+      in Intpart.union_set evars p)
+    evm ()
+
+let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique =
+  let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in
+  let (gl,t,sigma) =
+    Goal.V82.mk_goal sigma nc gl Store.empty in
+  let gls = { it = gl ; sigma = sigma; } in
+  let hints = searchtable_map typeclasses_db in
+  let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in
+  let evd = sig_sig gls' in
+  let t' = let (ev, inst) = destEvar t in
+    mkEvar (ev, Array.of_list subst)
+  in
+  let term = Evarutil.nf_evar evd t' in
+    evd, term
+
+let _ =
+  Typeclasses.solve_instantiation_problem := 
+    (fun x y z w -> resolve_one_typeclass x ~sigma:y z w)
+
+(** [split_evars] returns groups of undefined evars according to dependencies *)
+
+let split_evars evm =
+  let p = Intpart.create () in
+  evar_dependencies evm p;
+  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
+  Intpart.partition p
+
+let is_inference_forced p evd ev =
+  try
+    let evi = Evd.find_undefined evd ev in
+    if Typeclasses.is_resolvable evi && snd (p ev evi)
+    then
+      let (loc, k) = evar_source ev evd in
+      match k with
+	| Evar_kinds.ImplicitArg (_, _, b) -> b
+	| Evar_kinds.QuestionMark _ -> false
+	| _ -> true
+    else true
+  with Not_found -> assert false
+
+let is_mandatory p comp evd =
+  Evar.Set.exists (is_inference_forced p evd) comp
+
+(** In case of unsatisfiable constraints, build a nice error message *)
+
+let error_unresolvable env comp evd =
+  let evd = Evarutil.nf_evar_map_undefined evd in
+  let is_part ev = match comp with
+  | None -> true
+  | Some s -> Evar.Set.mem ev s
+  in
+  let fold ev evi (found, accu) =
+    let ev_class = class_of_constr evi.evar_concl in
+    if not (Option.is_empty ev_class) && is_part ev then
+      (* focus on one instance if only one was searched for *)
+      if not found then (true, Some ev)
+      else (found, None)
+    else (found, accu)
+   in
+  let (_, ev) = Evd.fold_undefined fold evd (true, None) in
+    Pretype_errors.unsatisfiable_constraints
+      (Evarutil.nf_env_evar evd env) evd ev comp
+
+(** Check if an evar is concerned by the current resolution attempt,
+    (and in particular is in the current component), and also update
+    its evar_info.
+    Invariant : this should only be applied to undefined evars,
+    and return undefined evar_info *)
+
+let select_and_update_evars p oevd in_comp evd ev evi =
+  assert (evi.evar_body == Evar_empty);
+  try
+    let oevi = Evd.find_undefined oevd ev in
+    if Typeclasses.is_resolvable oevi then
+      Typeclasses.mark_unresolvable evi,
+      (in_comp ev && p evd ev evi)
+    else evi, false
+  with Not_found ->
+    Typeclasses.mark_unresolvable evi, p evd ev evi
+
+(** Do we still have unresolved evars that should be resolved ? *)
+
+let has_undefined p oevd evd =
+  let check ev evi = snd (p oevd ev evi) in
+  Evar.Map.exists check (Evd.undefined_map evd)
+
+(** Revert the resolvability status of evars after resolution,
+    potentially unprotecting some evars that were set unresolvable
+    just for this call to resolution. *)
+
+let revert_resolvability oevd evd =
+  let map ev evi =
+    try
+      if not (Typeclasses.is_resolvable evi) then
+        let evi' = Evd.find_undefined oevd ev in
+        if Typeclasses.is_resolvable evi' then
+          Typeclasses.mark_resolvable evi
+        else evi
+      else evi
+    with Not_found -> evi
+  in
+  Evd.raw_map_undefined map evd
+
+(** If [do_split] is [true], we try to separate the problem in
+    several components and then solve them separately *)
+
+exception Unresolved
+
+let resolve_all_evars debug m unique env p oevd do_split fail =
+  let split = if do_split then split_evars oevd else [Evar.Set.empty] in
+  let in_comp comp ev = if do_split then Evar.Set.mem ev comp else true
+  in
+  let rec docomp evd = function
+    | [] -> revert_resolvability oevd evd
+    | comp :: comps ->
+      let p = select_and_update_evars p oevd (in_comp comp) in
+      try
+	 let evd' = resolve_all_evars_once debug m unique p evd in
+	 if has_undefined p oevd evd' then raise Unresolved;
+	 docomp evd' comps
+      with Unresolved | Not_found ->
+	if fail && (not do_split || is_mandatory (p evd) comp evd)
+	then (* Unable to satisfy the constraints. *)
+          let comp = if do_split then Some comp else None in
+	  error_unresolvable env comp evd
+	else (* Best effort: do nothing on this component *)
+	  docomp evd comps
+  in docomp oevd split
+
+let initial_select_evars filter =
+  fun evd ev evi ->
+    filter ev (snd evi.Evd.evar_source) &&
+    Typeclasses.is_class_evar evd evi
+
+let resolve_typeclass_evars debug m unique env evd filter split fail =
+  let evd =
+    try Evarconv.consider_remaining_unif_problems
+      ~ts:(Typeclasses.classes_transparent_state ()) env evd
+    with e when Errors.noncritical e -> evd
+  in
+    resolve_all_evars debug m unique env (initial_select_evars filter) evd split fail
+
+let solve_inst debug depth env evd filter unique split fail =
+  resolve_typeclass_evars debug depth unique env evd filter split fail
+
+let _ =
+  Typeclasses.solve_instantiations_problem :=
+    solve_inst false !typeclasses_depth
+
+let set_typeclasses_debug d = (:=) typeclasses_debug d;
+  Typeclasses.solve_instantiations_problem := solve_inst d !typeclasses_depth
+
+let get_typeclasses_debug () = !typeclasses_debug
+
+let set_typeclasses_depth d = (:=) typeclasses_depth d;
+  Typeclasses.solve_instantiations_problem := solve_inst !typeclasses_debug !typeclasses_depth
+
+let get_typeclasses_depth () = !typeclasses_depth
+
+open Goptions
+
+let set_typeclasses_debug =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "debug output for typeclasses proof search";
+      optkey   = ["Typeclasses";"Debug"];
+      optread  = get_typeclasses_debug;
+      optwrite = set_typeclasses_debug; }
+
+let set_typeclasses_depth =
+  declare_int_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "depth for typeclasses proof search";
+      optkey   = ["Typeclasses";"Depth"];
+      optread  = get_typeclasses_depth;
+      optwrite = set_typeclasses_depth; }
+
+let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl =
+  try
+    let dbs = List.map_filter
+      (fun db -> try Some (searchtable_map db)
+        with e when Errors.noncritical e -> None)
+      dbs
+    in
+    let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
+      eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl
+   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl
+
+(** Take the head of the arity of a constr.
+    Used in the partial application tactic. *)
+
+let rec head_of_constr t =
+  let t = strip_outer_cast(collapse_appl t) in
+    match kind_of_term t with
+    | Prod (_,_,c2)  -> head_of_constr c2
+    | LetIn (_,_,_,c2) -> head_of_constr c2
+    | App (f,args)  -> head_of_constr f
+    | _      -> t
+
+let head_of_constr h c =
+  let c = head_of_constr c in
+  letin_tac None (Name h) c None Locusops.allHyps
+
+let not_evar c = match kind_of_term c with
+| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar")
+| _ -> Proofview.tclUNIT ()
+
+let is_ground c gl =
+  if Evarutil.is_ground_term (project gl) c then tclIDTAC gl
+  else tclFAIL 0 (str"Not ground") gl
+
+let autoapply c i gl =
+  let flags = auto_unif_flags Evar.Set.empty 
+    (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in
+  let cty = pf_type_of gl c in
+  let ce = mk_clenv_from gl (c,cty) in
+  unify_e_resolve false flags (c,ce) gl
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
deleted file mode 100644
index 4a5f0e2c..00000000
--- a/tactics/class_tactics.ml4
+++ /dev/null
@@ -1,833 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Sign
-open Reduction
-open Proof_type
-open Declarations
-open Tacticals
-open Tacmach
-open Evar_refiner
-open Tactics
-open Pattern
-open Clenv
-open Auto
-open Glob_term
-open Hiddentac
-open Typeclasses
-open Typeclasses_errors
-open Classes
-open Topconstr
-open Pfedit
-open Command
-open Libnames
-open Evd
-open Compat
-
-let typeclasses_db = "typeclass_instances"
-let typeclasses_debug = ref false
-let typeclasses_depth = ref None
-
-let _ = 
-  Auto.add_auto_init 
-    (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true)
-
-exception Found of evar_map
-
-(** We transform the evars that are concerned by this resolution
-    (according to predicate p) into goals.
-    Invariant: function p only manipulates undefined evars *)
-
-let evars_to_goals p evm =
-  let goals, evm' =
-    Evd.fold_undefined
-      (fun ev evi (gls, evm') ->
-	let evi', goal = p evm ev evi in
-	let gls' = if goal then (ev,Goal.V82.build ev) :: gls else gls in
-	(gls', Evd.add evm' ev evi'))
-      evm ([], Evd.defined_evars evm)
-  in
-  if goals = [] then None else Some (List.rev goals, evm')
-
-(** Typeclasses instance search tactic / eauto *)
-
-open Auto
-
-let e_give_exact flags c gl = 
-  let t1 = (pf_type_of gl c) in
-    tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl
-
-open Unification
-
-let auto_unif_flags = {
-  modulo_conv_on_closed_terms = Some full_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = true;
-  modulo_delta = var_full_transparent_state;
-  modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = None;
-  check_applied_meta_types = false;
-  resolve_evars = false;
-  use_pattern_unification = true;
-  use_meta_bound_pattern_unification = true;
-  frozen_evars = ExistentialSet.empty;
-  restrict_conv_on_strict_subterms = false; (* ? *)
-  modulo_betaiota = true;
-  modulo_eta = true;
-  allow_K_in_toplevel_higher_order_unification = false
-}
-
-let rec eq_constr_mod_evars x y =
-  match kind_of_term x, kind_of_term y with
-  | Evar (e1, l1), Evar (e2, l2) when e1 <> e2 -> true
-  | _, _ -> compare_constr eq_constr_mod_evars x y
-
-let progress_evars t gl =
-  let concl = pf_concl gl in
-  let check gl' = 
-    let newconcl = pf_concl gl' in
-      if eq_constr_mod_evars concl newconcl 
-      then tclFAIL 0 (str"No progress made (modulo evars)") gl'
-      else tclIDTAC gl'
-  in tclTHEN t check gl
-
-TACTIC EXTEND progress_evars
-  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ]
-END
-
-let unify_e_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver ~flags clenv' gls in
-    Clenvtac.clenv_refine true ~with_classes:false clenv' gls
-
-let unify_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
-  let clenv' = clenv_unique_resolver ~flags clenv' gls in
-    Clenvtac.clenv_refine false ~with_classes:false clenv' gls
-
-let clenv_of_prods nprods (c, clenv) gls =
-  if nprods = 0 then Some clenv
-  else 
-    let ty = pf_type_of gls c in
-    let diff = nb_prod ty - nprods in
-      if diff >= 0 then
-	Some (mk_clenv_from_n gls (Some diff) (c,ty))
-      else None
-
-let with_prods nprods (c, clenv) f gls =
-  match clenv_of_prods nprods (c, clenv) gls with
-  | None -> tclFAIL 0 (str"Not enough premisses") gls
-  | Some clenv' -> f (c, clenv') gls
-
-(** Hack to properly solve dependent evars that are typeclasses *)
-
-let flags_of_state st =
-  {auto_unif_flags with
-    modulo_conv_on_closed_terms = Some st; modulo_delta = st; 
-     modulo_delta_types = st;
-     modulo_eta = false}
-
-let rec e_trivial_fail_db db_list local_db goal =
-  let tacl =
-    Eauto.registered_e_assumption ::
-    (tclTHEN Tactics.intro
-       (function g'->
-	  let d = pf_last_hyp g' in
-	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
-          (e_trivial_fail_db db_list
-	      (Hint_db.add_list hintl local_db) g'))) ::
-    (List.map (fun (x,_,_,_,_) -> x) (e_trivial_resolve db_list local_db (pf_concl goal)))
-  in 
-  tclFIRST (List.map tclCOMPLETE tacl) goal 
-
-and e_my_find_search db_list local_db hdc complete concl =
-  let hdc = head_of_constr_reference hdc in
-  let prods, concl = decompose_prod_assum concl in
-  let nprods = List.length prods in
-  let hintl =
-    list_map_append
-      (fun db ->
-	if Hint_db.use_dn db then
-	  let flags = flags_of_state (Hint_db.transparent_state db) in
-	    List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db)
-	else
-	  let flags = flags_of_state (Hint_db.transparent_state db) in
-	    List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db))
-      (local_db::db_list)
-  in
-  let tac_of_hint =
-    fun (flags, {pri = b; pat = p; code = t; name = name}) ->
-      let tac =
-	match t with
-	  | Res_pf (term,cl) -> with_prods nprods (term,cl) (unify_resolve flags)
-	  | ERes_pf (term,cl) -> with_prods nprods (term,cl) (unify_e_resolve flags)
-	  | Give_exact (c) -> e_give_exact flags c
-	  | Res_pf_THEN_trivial_fail (term,cl) ->
-              tclTHEN (with_prods nprods (term,cl) (unify_e_resolve flags))
-	        (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)
-	  | Unfold_nth c -> tclWEAK_PROGRESS (unfold_in_concl [all_occurrences,c])
-	  | Extern tacast -> 
-(* 	    tclTHEN *)
-(* 	      (fun gl -> Refiner.tclEVARS (mark_unresolvables (project gl)) gl) *)
-	      (conclPattern concl p tacast)
-      in
-      let tac = if complete then tclCOMPLETE tac else tac in
-	match t with
-	| Extern _ -> (tac,b,true, name, lazy (pr_autotactic t))
-	| _ -> 
-(* 	  let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *)
-	    (tac,b,false, name, lazy (pr_autotactic t))
-  in List.map tac_of_hint hintl
-
-and e_trivial_resolve db_list local_db gl =
-  try
-    e_my_find_search db_list local_db
-    (fst (head_constr_bound gl)) true gl
-  with Bound | Not_found -> []
-
-let e_possible_resolve db_list local_db gl =
-  try
-    e_my_find_search db_list local_db
-      (fst (head_constr_bound gl)) false gl
-  with Bound | Not_found -> []
-
-let rec catchable = function
-  | Refiner.FailError _ -> true
-  | Loc.Exc_located (_, e) -> catchable e
-  | e -> Logic.catchable_exception e
-
-let nb_empty_evars s =
-  Evd.fold_undefined (fun ev evi acc -> succ acc) s 0
-
-let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) (Evarutil.nf_evar evs (Goal.V82.concl evs ev))
-
-let pr_depth l = prlist_with_sep (fun () -> str ".") pr_int (List.rev l)
-
-type autoinfo = { hints : Auto.hint_db; is_evar: existential_key option;
-		  only_classes: bool; auto_depth: int list; auto_last_tac: std_ppcmds Lazy.t;
-		  auto_path : global_reference option list;
-		  auto_cut : hints_path }
-type autogoal = goal * autoinfo
-type 'ans fk = unit -> 'ans
-type ('a,'ans) sk = 'a -> 'ans fk -> 'ans
-type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans }
-
-type auto_result = autogoal list sigma
-
-type atac = auto_result tac
-
-let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) =
-  let cty = Evarutil.nf_evar sigma cty in
-  let rec iscl env ty = 
-    let ctx, ar = decompose_prod_assum ty in
-      match kind_of_term (fst (decompose_app ar)) with
-      | Const c -> is_class (ConstRef c)
-      | Ind i -> is_class (IndRef i)
-      | _ -> 
-	  let env' = Environ.push_rel_context ctx env in
-	  let ty' = whd_betadeltaiota env' ar in
-	       if not (eq_constr ty' ar) then iscl env' ty'
-	       else false
-  in
-  let is_class = iscl env cty in
-  let keep = not only_classes || is_class in
-    if keep then 
-      let c = mkVar id in
-      let name = PathHints [VarRef id] in
-      let hints =
-	if is_class then
-	  let hints = build_subclasses ~check:false env sigma (VarRef id) None in
-	    (list_map_append
-	       (fun (pri, c) -> make_resolves env sigma 
-		  (true,false,Flags.is_verbose()) pri c) 
-	       hints)
-	else []
-      in
-        (hints @ map_succeed 
-	 (fun f -> try f (c,cty) with UserError _ -> failwith "") 
-	 [make_exact_entry ~name sigma pri; make_apply_entry ~name env sigma flags pri])
-    else []
-
-let pf_filtered_hyps gls = 
-  Goal.V82.hyps gls.Evd.sigma (sig_it gls)
-
-let make_hints g st only_classes sign =
-  let paths, hintlist = 
-    List.fold_left 
-    (fun (paths, hints) hyp ->
-     if is_section_variable (pi1 hyp) then (paths, hints)
-     else
-       let path, hint = 		    
-	 PathEmpty, pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp
-       in
-	 (PathOr (paths, path), hint @ hints))
-    (PathEmpty, []) sign
-  in Hint_db.add_list hintlist (Hint_db.empty st true)
-
-let autogoal_hints_cache : (bool * Environ.named_context_val * hint_db) option ref = ref None
-let freeze () = !autogoal_hints_cache
-let unfreeze v = autogoal_hints_cache := v
-let init () = autogoal_hints_cache := None
-
-let _ = init ()
-
-let _ =
-  Summary.declare_summary "autogoal-hints-cache"
-    { Summary.freeze_function = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function = init }
-    
-let make_autogoal_hints = 
-  fun only_classes ?(st=full_transparent_state) g ->
-    let sign = pf_filtered_hyps g in
-      match freeze () with
-      | Some (onlyc, sign', hints) 
-	  when onlyc = only_classes && 
-	    Environ.eq_named_context_val sign sign' -> hints
-      | _ -> let hints = make_hints g st only_classes (Environ.named_context_of_val sign) in
-	  unfreeze (Some (only_classes, sign, hints)); hints
-	  
-let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : 'a tac =
-  { skft = fun sk fk {it = gl,hints; sigma=s} ->
-    let res = try Some (tac {it=gl; sigma=s}) with e when catchable e -> None in
-      match res with
-      | Some gls -> sk (f gls hints) fk
-      | None -> fk () }
-
-let intro_tac : atac =
-  lift_tactic Tactics.intro
-    (fun {it = gls; sigma = s} info ->
-      let gls' =
-	List.map (fun g' ->
-	  let env = Goal.V82.env s g' in
-	  let context = Environ.named_context_of_val (Goal.V82.hyps s g') in
-	  let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) 
-	    (true,false,false) info.only_classes None (List.hd context) in
-	  let ldb = Hint_db.add_list hint info.hints in
-	    (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls
-      in {it = gls'; sigma = s})
-
-let normevars_tac : atac = 
-  { skft = fun sk fk {it = (gl, info); sigma = s} ->
-    let gl', sigma' = Goal.V82.nf_evar s gl in
-    let info' = { info with auto_last_tac = lazy (str"normevars") } in
-      sk {it = [gl', info']; sigma = sigma'} fk }
-
-(* Ordering of states is lexicographic on the number of remaining goals. *)
-let compare (pri, _, _, res) (pri', _, _, res') =
-  let nbgoals s =
-    List.length (sig_it s) + nb_empty_evars (sig_sig s)
-  in
-  let pri = pri - pri' in
-    if pri <> 0 then pri
-    else nbgoals res - nbgoals res'
-
-let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
-  { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
-
-let hints_tac hints =
-  { skft = fun sk fk {it = gl,info; sigma = s} ->
-      let concl = Goal.V82.concl s gl in
-      let tacgl = {it = gl; sigma = s} in
-      let poss = e_possible_resolve hints info.hints concl in
-      let rec aux i foundone = function
-	| (tac, _, b, name, pp) :: tl ->
-	  let derivs = path_derivate info.auto_cut name in
-	  let res = 
-            try
-		if path_matches derivs [] then None else Some (tac tacgl)
-	    with e when catchable e -> None 
-	  in
-	    (match res with
-	       | None -> aux i foundone tl
-	       | Some {it = gls; sigma = s'} ->
-	    	   if !typeclasses_debug then
-		     msgnl (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp
-			    ++ str" on" ++ spc () ++ pr_ev s gl);
-		   let fk =
-		     (fun () -> if !typeclasses_debug then msgnl (str"backtracked after " ++ Lazy.force pp);
-			aux (succ i) true tl)
-		   in
-		   let sgls =
-		     evars_to_goals
-		       (fun evm ev evi ->
-			  if Typeclasses.is_resolvable evi &&
-			    (not info.only_classes || Typeclasses.is_class_evar evm evi)
-			  then Typeclasses.mark_unresolvable evi, true
-			  else evi, false) s'
-		   in
-		   let newgls, s' =
-		     let gls' = List.map (fun g -> (None, g)) gls in
-		       match sgls with
-		       | None -> gls', s'
-		       | Some (evgls, s') ->
-			 (* Reorder with dependent subgoals. *)
-			 (gls' @ List.map (fun (ev, x) -> Some ev, x) evgls, s')
-		   in
-		   let gls' = list_map_i
-		     (fun j (evar, g) ->
-			let info =
-			  { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp;
-			      is_evar = evar;
-			      hints =
-			      if b && not (Environ.eq_named_context_val (Goal.V82.hyps s' g) (Goal.V82.hyps s' gl))
-			      then make_autogoal_hints info.only_classes
-				~st:(Hint_db.transparent_state info.hints) {it = g; sigma = s'}
-			      else info.hints;
-			      auto_cut = derivs }
-			in g, info) 1 newgls in
-		   let glsv = {it = gls'; sigma = s'} in
-		     sk glsv fk)
-	| [] ->
-	  if not foundone && !typeclasses_debug then
-	    msgnl (pr_depth info.auto_depth ++ str": no match for " ++
-		     Printer.pr_constr_env (Goal.V82.env s gl) concl ++
-		     spc () ++ int (List.length poss) ++ str" possibilities");
-	  fk ()
-    in aux 1 false poss }
-
-let isProp env sigma concl = 
-  let ty = Retyping.get_type_of env sigma concl in
-    kind_of_term ty = Sort (Prop Null)
-
-let needs_backtrack only_classes env evd oev concl =
-  if oev = None || isProp env evd concl then
-    not (Intset.is_empty (Evarutil.evars_of_term concl))
-  else true
-
-let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk =
-  let rec aux s (acc : autogoal list list) fk = function
-    | (gl,info) :: gls ->
-	(match info.is_evar with 
-	 | Some ev when Evd.is_defined s ev -> aux s acc fk gls
-	 | _ -> 
-	     second.skft
-	       (fun {it=gls';sigma=s'} fk' ->
-		  let needs_backtrack = 
-		    if gls' = [] then
- 		      needs_backtrack info.only_classes
-		        (Goal.V82.env s gl) s' info.is_evar (Goal.V82.concl s gl)
-		    else true
-		  in
-		  let fk'' = 
-		    if not needs_backtrack then
-		      (if !typeclasses_debug then msgnl (str"no backtrack on " ++ pr_ev s gl ++ 
-							 str " after " ++ Lazy.force info.auto_last_tac); fk) 
-		    else fk' 
-		  in aux s' (gls'::acc) fk'' gls)
-	       fk {it = (gl,info); sigma = s})
-    | [] -> Some (List.rev acc, s, fk)
-  in fun {it = gls; sigma = s} fk ->
-    let rec aux' = function
-      | None -> fk ()
-      | Some (res, s', fk') ->
-	  let goals' = List.concat res in
-	    sk {it = goals'; sigma = s'} (fun () -> aux' (fk' ()))
-    in aux' (aux s [] (fun () -> None) gls)
-
-let then_tac (first : atac) (second : atac) : atac =
-  { skft = fun sk fk -> first.skft (then_list second sk) fk }
-
-let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
-  t.skft (fun x _ -> Some x) (fun _ -> None) gl
-
-type run_list_res = (auto_result * run_list_res fk) option
-
-let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
-  (then_list t (fun x fk -> Some (x, fk)))
-    gl
-    (fun _ -> None)
-
-let fail_tac : atac = 
-  { skft = fun sk fk _ -> fk () }
-
-let rec fix (t : 'a tac) : 'a tac =
-  then_tac t { skft = fun sk fk -> (fix t).skft sk fk }
-
-let rec fix_limit limit (t : 'a tac) : 'a tac =
-  if limit = 0 then fail_tac 
-  else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk }
-    
-let make_autogoal ?(only_classes=true) ?(st=full_transparent_state) cut ev g =
-  let hints = make_autogoal_hints only_classes ~st g in
-    (g.it, { hints = hints ; is_evar = ev; 
-	     only_classes = only_classes; auto_depth = []; auto_last_tac = lazy (str"none");
-	     auto_path = []; auto_cut = cut })
-      
-
-let cut_of_hints h =
-  List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h
-
-let make_autogoals ?(only_classes=true) ?(st=full_transparent_state) hints gs evm' =
-  let cut = cut_of_hints hints in
-  { it = list_map_i (fun i g -> 
-    let (gl, auto) = make_autogoal ~only_classes ~st cut (Some (fst g)) {it = snd g; sigma = evm'} in
-      (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' }
-
-let get_result r = 
-  match r with
-  | None -> None
-  | Some (gls, fk) -> Some (gls.sigma,fk)
-	
-let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm hints tac =
-  match evars_to_goals p evm with
-  | None -> None (* This happens only because there's no evar having p *)
-  | Some (goals, evm') ->
-      let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st hints goals evm') in
-	match get_result res with
-	| None -> raise Not_found
-	| Some (evm', fk) -> Some (evars_reset_evd ~with_conv_pbs:true evm' evm, fk)
-	    
-let eauto_tac hints = 
-  then_tac normevars_tac (or_tac (hints_tac hints) intro_tac)
-
-let eauto_tac ?limit hints = 
-  match limit with
-  | None -> fix (eauto_tac hints)
-  | Some limit -> fix_limit limit (eauto_tac hints)
-      
-let eauto ?(only_classes=true) ?st ?limit hints g =
-  let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g } in
-    match run_tac (eauto_tac ?limit hints) gl with
-    | None -> raise Not_found
-    | Some {it = goals; sigma = s} ->
-	{it = List.map fst goals; sigma = s}
-
-let real_eauto st ?limit hints p evd =
-  let rec aux evd fails =
-    let res, fails =
-      try run_on_evars ~st p evd hints (eauto_tac ?limit hints), fails
-      with Not_found ->
-	List.fold_right (fun fk (res, fails) ->
-	  match res with
-	  | Some r -> res, fk :: fails
-	  | None -> get_result (fk ()), fails)
-	  fails (None, [])
-    in
-      match res with
-      | None -> evd
-      | Some (evd', fk) -> aux evd' (fk :: fails)
-  in aux evd []
-
-let resolve_all_evars_once debug limit p evd =
-  let db = searchtable_map typeclasses_db in
-    real_eauto ?limit (Hint_db.transparent_state db) [db] p evd
-
-(** We compute dependencies via a union-find algorithm.
-    Beware of the imperative effects on the partition structure,
-    it should not be shared, but only used locally. *)
-
-module Intpart = Unionfind.Make(Intset)(Intmap)
-
-let deps_of_constraints cstrs evm p =
-  List.iter (fun (_, _, x, y) ->
-    let evx = Evarutil.undefined_evars_of_term evm x in
-    let evy = Evarutil.undefined_evars_of_term evm y in
-    Intpart.union_set (Intset.union evx evy) p)
-    cstrs
-
-let evar_dependencies evm p =
-  Evd.fold_undefined
-    (fun ev evi _ ->
-      let evars = Intset.add ev (Evarutil.undefined_evars_of_evar_info evm evi)
-      in Intpart.union_set evars p)
-    evm ()
-
-let resolve_one_typeclass env ?(sigma=Evd.empty) gl =
-  let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env gl in
-  let (gl,t,sigma) = 
-    Goal.V82.mk_goal sigma nc gl Store.empty in
-  let gls = { it = gl ; sigma = sigma } in
-  let hints = searchtable_map typeclasses_db in
-  let gls' = eauto ?limit:!typeclasses_depth ~st:(Hint_db.transparent_state hints) [hints] gls in
-  let evd = sig_sig gls' in
-  let t' = let (ev, inst) = destEvar t in
-    mkEvar (ev, Array.of_list subst)
-  in
-  let term = Evarutil.nf_evar evd t' in
-    evd, term
-
-let _ =
-  Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z)
-
-(** [split_evars] returns groups of undefined evars according to dependencies *)
-
-let split_evars evm =
-  let p = Intpart.create () in
-  evar_dependencies evm p;
-  deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p;
-  Intpart.partition p
-
-(** [evars_in_comp] filters an [evar_map], keeping only evars
-    that belongs to a certain component *)
-
-let evars_in_comp comp evm =
-  try
-    evars_reset_evd 
-      (Intset.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evm ev))
-	 comp Evd.empty) evm
-  with Not_found -> assert false
-
-let is_inference_forced p evd ev =
-  try
-    let evi = Evd.find_undefined evd ev in
-    if Typeclasses.is_resolvable evi && snd (p ev evi)
-    then
-      let (loc, k) = evar_source ev evd in
-      match k with
-	| ImplicitArg (_, _, b) -> b
-	| QuestionMark _ -> false
-	| _ -> true
-    else true
-  with Not_found -> assert false
-
-let is_mandatory p comp evd =
-  Intset.exists (is_inference_forced p evd) comp
-
-(** In case of unsatisfiable constraints, build a nice error message *)
-
-let error_unresolvable env comp do_split evd =
-  let evd = Evarutil.nf_evar_map_undefined evd in
-  let evm = if do_split then evars_in_comp comp evd else evd in
-  let _, ev = Evd.fold_undefined
-    (fun ev evi (b,acc) ->
-      (* focus on one instance if only one was searched for *)
-      if class_of_constr evi.evar_concl <> None then
-	if not b (* || do_split *) then
-	  true, Some ev
-	else b, None
-      else b, acc) evm (false, None)
-  in
-  Typeclasses_errors.unsatisfiable_constraints
-    (Evarutil.nf_env_evar evm env) evm ev
-
-(** Check if an evar is concerned by the current resolution attempt,
-    (and in particular is in the current component), and also update
-    its evar_info.
-    Invariant : this should only be applied to undefined evars,
-    and return undefined evar_info *)
-
-let select_and_update_evars p oevd in_comp evd ev evi =
-  assert (evi.evar_body = Evar_empty);
-  try
-    let oevi = Evd.find_undefined oevd ev in
-    if Typeclasses.is_resolvable oevi then
-      Typeclasses.mark_unresolvable evi,
-      (in_comp ev && p evd ev evi)
-    else evi, false
-  with Not_found ->
-    Typeclasses.mark_unresolvable evi, p evd ev evi
-
-(** Do we still have unresolved evars that should be resolved ? *)
-
-let has_undefined p oevd evd =
-  Evd.fold_undefined (fun ev evi has -> has ||
-    snd (p oevd ev evi))
-    evd false
-
-(** Revert the resolvability status of evars after resolution,
-    potentially unprotecting some evars that were set unresolvable
-    just for this call to resolution. *)
-
-let revert_resolvability oevd evd = 
-  Evd.fold_undefined
-    (fun ev evi evm ->
-     try 
-       if not (Typeclasses.is_resolvable evi) then
-	 let evi' = Evd.find_undefined oevd ev in
-	   if Typeclasses.is_resolvable evi' then
-	     Evd.add evm ev (Typeclasses.mark_resolvable evi)
-	   else evm
-       else evm
-     with Not_found -> evm)
-  evd evd
-
-(** If [do_split] is [true], we try to separate the problem in
-    several components and then solve them separately *)
-
-exception Unresolved
-
-let resolve_all_evars debug m env p oevd do_split fail =
-  let split = if do_split then split_evars oevd else [Intset.empty] in
-  let in_comp comp ev = if do_split then Intset.mem ev comp else true
-  in
-  let rec docomp evd = function
-    | [] -> revert_resolvability oevd evd
-    | comp :: comps ->
-      let p = select_and_update_evars p oevd (in_comp comp) in
-      try
-	 let evd' = resolve_all_evars_once debug m p evd in
-	 if has_undefined p oevd evd' then raise Unresolved;
-	 docomp evd' comps
-      with Unresolved | Not_found ->
-	if fail && (not do_split || is_mandatory (p evd) comp evd)
-	then (* Unable to satisfy the constraints. *)
-	  error_unresolvable env comp do_split evd
-	else (* Best effort: do nothing on this component *) 
-	  docomp evd comps
-  in docomp oevd split
-
-let initial_select_evars filter evd ev evi =
-  filter (snd evi.Evd.evar_source) &&
-  Typeclasses.is_class_evar evd evi
-
-let resolve_typeclass_evars debug m env evd filter split fail =
-  let evd = 
-    try Evarconv.consider_remaining_unif_problems
-      ~ts:(Typeclasses.classes_transparent_state ()) env evd
-    with e when Errors.noncritical e -> evd
-  in
-    resolve_all_evars debug m env (initial_select_evars filter) evd split fail
-
-let solve_inst debug depth env evd filter split fail =
-  resolve_typeclass_evars debug depth env evd filter split fail
-
-let _ =
-  Typeclasses.solve_instanciations_problem :=
-    solve_inst false !typeclasses_depth
-
-
-(** Options: depth, debug and transparency settings. *)
-
-open Goptions
-
-let set_typeclasses_debug d = (:=) typeclasses_debug d;
-  Typeclasses.solve_instanciations_problem := solve_inst d !typeclasses_depth
-    
-let get_typeclasses_debug () = !typeclasses_debug
-
-let set_typeclasses_debug =
-  declare_bool_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "debug output for typeclasses proof search";
-      optkey   = ["Typeclasses";"Debug"];
-      optread  = get_typeclasses_debug;
-      optwrite = set_typeclasses_debug; }
-
-
-let set_typeclasses_depth d = (:=) typeclasses_depth d;
-  Typeclasses.solve_instanciations_problem := solve_inst !typeclasses_debug !typeclasses_depth
-    
-let get_typeclasses_depth () = !typeclasses_depth
-
-let set_typeclasses_depth =
-  declare_int_option
-    { optsync  = true;
-      optdepr  = false;
-      optname  = "depth for typeclasses proof search";
-      optkey   = ["Typeclasses";"Depth"];
-      optread  = get_typeclasses_depth;
-      optwrite = set_typeclasses_depth; }
-
-let set_transparency cl b =
-  List.iter (fun r -> 
-    let gr = Smartlocate.global_with_alias r in
-    let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
-      Classes.set_typeclass_transparency ev false b) cl
-
-VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings
-| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
-    set_transparency cl true ]
-END
-
-VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings
-| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
-    set_transparency cl false ]
-END
-
-open Genarg
-open Extraargs
-
-let pr_debug _prc _prlc _prt b =
-  if b then Pp.str "debug" else Pp.mt()
-
-ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
-| [ "debug" ] -> [ true ]
-| [ ] -> [ false ]
-END
-
-let pr_depth _prc _prlc _prt = function
-    Some i -> Util.pr_int i
-  | None -> Pp.mt()
-
-ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth
-| [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ]
-END
-
-(* true = All transparent, false = Opaque if possible *)
-
-VERNAC COMMAND EXTEND Typeclasses_Settings
- | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
-     set_typeclasses_debug d;
-     set_typeclasses_depth depth
-   ]
-END
-
-let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) dbs gl =
-  try 
-    let dbs = list_map_filter
-      (fun db -> try Some (Auto.searchtable_map db)
-        with e when Errors.noncritical e -> None) dbs
-    in
-    let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in
-      eauto ?limit:!typeclasses_depth ~only_classes ~st dbs gl
-   with Not_found -> tclFAIL 0 (str" typeclasses eauto failed on: " ++ Printer.pr_goal gl) gl
- 
-TACTIC EXTEND typeclasses_eauto
-| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ typeclasses_eauto l ]
-| [ "typeclasses" "eauto" ] -> [ typeclasses_eauto ~only_classes:true [typeclasses_db] ]
-END
-
-let _ = Classes.refine_ref := Refine.refine
-
-(** Take the head of the arity of a constr.
-    Used in the partial application tactic. *)
-
-let rec head_of_constr t =
-  let t = strip_outer_cast(collapse_appl t) in
-    match kind_of_term t with
-    | Prod (_,_,c2)  -> head_of_constr c2
-    | LetIn (_,_,_,c2) -> head_of_constr c2
-    | App (f,args)  -> head_of_constr f
-    | _      -> t
-
-TACTIC EXTEND head_of_constr
-  [ "head_of_constr" ident(h) constr(c) ] -> [
-    let c = head_of_constr c in
-      letin_tac None (Name h) c None allHyps
-  ]
-END
-
-TACTIC EXTEND not_evar
-  [ "not_evar" constr(ty) ] -> [
-    match kind_of_term ty with
-    | Evar _ -> tclFAIL 0 (str"Evar")
-    | _ -> tclIDTAC ]
-END
-
-TACTIC EXTEND is_ground
-  [ "is_ground" constr(ty) ] -> [ fun gl ->
-    if Evarutil.is_ground_term (project gl) ty then tclIDTAC gl
-    else tclFAIL 0 (str"Not ground") gl ]
-END
-
-TACTIC EXTEND autoapply
-  [ "autoapply" constr(c) "using" preident(i) ] -> [ fun gl ->
-    let flags = flags_of_state (Auto.Hint_db.transparent_state (Auto.searchtable_map i)) in
-    let cty = pf_type_of gl c in
-    let ce = mk_clenv_from gl (c,cty) in
-      unify_e_resolve flags (c,ce) gl ]
-END
diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli
new file mode 100644
index 00000000..c6207ed6
--- /dev/null
+++ b/tactics/class_tactics.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  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 Names
+open Constr
+open Tacmach
+
+val catchable : exn -> bool
+
+val set_typeclasses_debug : bool -> unit
+val get_typeclasses_debug : unit -> bool
+
+val set_typeclasses_depth : int option -> unit
+val get_typeclasses_depth : unit -> int option
+
+val progress_evars : unit Proofview.tactic -> unit Proofview.tactic
+
+val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state ->
+  Hints.hint_db_name list -> tactic
+
+val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic
+
+val not_evar : constr -> unit Proofview.tactic
+
+val is_ground : constr -> tactic
+
+val autoapply : constr -> Hints.hint_db_name -> tactic
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 2a09f321..9ee14b80 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -1,90 +1,119 @@
 (************************************************************************)
 (*  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 Util
+open Errors
 open Term
-open Proof_type
 open Hipattern
 open Tacmach
 open Tacticals
 open Tactics
 open Coqlib
 open Reductionops
-open Glob_term
+open Misctypes
 
 (* Absurd *)
 
-let absurd c gls =
-  let env = pf_env gls and sigma = project gls in
-  let _,j = Coercion.Default.inh_coerce_to_sort dummy_loc env
-    (Evd.create_goal_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in
-  let c = j.Environ.utj_val in
-  (tclTHENS
-     (tclTHEN (elim_type (build_coq_False ())) (cut c))
-     ([(tclTHENS
-          (cut (applist(build_coq_not (),[c])))
-	  ([(tclTHEN intros
-	       ((fun gl ->
-		   let ida = pf_nth_hyp_id gl 1
-                   and idna = pf_nth_hyp_id gl 2 in
-                   exact_no_check (applist(mkVar idna,[mkVar ida])) gl)));
-            tclIDTAC]));
-       tclIDTAC])) gls
+let mk_absurd_proof t =
+  let id = Namegen.default_dependent_ident in
+  mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]),
+    mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|])))
+
+let absurd c =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let j = Retyping.get_judgment_of env sigma c in
+    let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in
+    let t = j.Environ.utj_val in
+    Tacticals.New.tclTHENLIST [
+      Proofview.Unsafe.tclEVARS sigma;
+      elim_type (build_coq_False ());
+      Simple.apply (mk_absurd_proof t)
+    ]
+  end
+
+let absurd c = absurd c
 
 (* Contradiction *)
 
-let filter_hyp f tac gl =
+(** [f] does not assume its argument to be [nf_evar]-ed. *)
+let filter_hyp f tac =
   let rec seek = function
-    | [] -> raise Not_found
-    | (id,_,t)::rest when f t -> tac id gl
+    | [] -> Proofview.tclZERO Not_found
+    | (id,_,t)::rest when f t -> tac id
     | _::rest -> seek rest in
-  seek (pf_hyps gl)
+  Proofview.Goal.enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+    seek hyps
+  end
 
-let contradiction_context gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let rec seek_neg l gl = match l with
-    | [] ->  error "No such contradiction"
-    | (id,_,typ)::rest ->
-	let typ = whd_betadeltaiota env sigma typ in
-	if is_empty_type typ then
-	  simplest_elim (mkVar id) gl
-	else match kind_of_term typ with
+let contradiction_context =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let rec seek_neg l = match l with
+      | [] ->  Proofview.tclZERO (UserError ("" , Pp.str"No such contradiction"))
+      | (id,_,typ)::rest ->
+          let typ = nf_evar sigma typ in
+	  let typ = whd_betadeltaiota env sigma typ in
+	  if is_empty_type typ then
+	    simplest_elim (mkVar id)
+	  else match kind_of_term typ with
 	  | Prod (na,t,u) when is_empty_type u ->
-	      (try
-		filter_hyp (fun typ -> pf_conv_x_leq gl typ t)
-		  (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
-		  gl
-	      with Not_found -> seek_neg rest gl)
-	  | _ -> seek_neg rest gl in
-  seek_neg (pf_hyps gl) gl
+	      (Proofview.tclORELSE
+                 (Proofview.Goal.enter begin fun gl ->
+                   let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in
+	           filter_hyp (fun typ -> is_conv_leq typ t)
+		     (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
+                 end)
+                 begin function (e, info) -> match e with
+	           | Not_found -> seek_neg rest
+                   | e -> Proofview.tclZERO ~info e
+                 end)
+	  | _ -> seek_neg rest
+    in
+    let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+    seek_neg hyps
+  end
 
 let is_negation_of env sigma typ t =
   match kind_of_term (whd_betadeltaiota env sigma t) with
-    | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t
+    | Prod (na,t,u) ->
+      let u = nf_evar sigma u in
+      is_empty_type u && is_conv_leq env sigma typ t
     | _ -> false
 
-let contradiction_term (c,lbind as cl) gl =
-  let env = pf_env gl in
-  let sigma = project gl in
-  let typ = pf_type_of gl c in
-  let _, ccl = splay_prod env sigma typ in
-  if is_empty_type ccl then
-    tclTHEN (elim false cl None) (tclTRY assumption) gl
-  else
-    try
-      if lbind = NoBindings then
-	filter_hyp (is_negation_of env sigma typ)
-	  (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl
-      else
-	raise Not_found
-    with Not_found -> error "Not a contradiction."
+let contradiction_term (c,lbind as cl) =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let typ = type_of c in
+    let _, ccl = splay_prod env sigma typ in
+    if is_empty_type ccl then
+      Tacticals.New.tclTHEN
+        (elim false None cl None)
+        (Tacticals.New.tclTRY assumption)
+    else
+      Proofview.tclORELSE
+        begin
+          if lbind = NoBindings then
+            filter_hyp (is_negation_of env sigma typ)
+              (fun id -> simplest_elim (mkApp (mkVar id,[|c|])))
+          else
+            Proofview.tclZERO Not_found
+        end
+        begin function (e, info) -> match e with
+          | Not_found -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Not a contradiction."))
+          | e -> Proofview.tclZERO ~info e
+        end
+  end
 
 let contradiction = function
-  | None -> tclTHEN intros contradiction_context
+  | None -> Tacticals.New.tclTHEN intros contradiction_context
   | Some c -> contradiction_term c
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index 79da83e0..25d07e25 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -1,16 +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 Proof_type
-open Glob_term
-open Genarg
+open Misctypes
 
-val absurd                      : constr -> tactic
-val contradiction               : constr with_bindings option -> tactic
+val absurd                      : constr -> unit Proofview.tactic
+val contradiction               : constr with_bindings option -> unit Proofview.tactic
diff --git a/tactics/coretactics.ml4 b/tactics/coretactics.ml4
new file mode 100644
index 00000000..5c039e72
--- /dev/null
+++ b/tactics/coretactics.ml4
@@ -0,0 +1,229 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Util
+open Names
+open Locus
+open Misctypes
+open Genredexpr
+
+open Proofview.Notations
+
+DECLARE PLUGIN "coretactics"
+
+TACTIC EXTEND reflexivity
+  [ "reflexivity" ] -> [ Tactics.intros_reflexivity ]
+END
+
+TACTIC EXTEND assumption
+  [ "assumption" ] -> [ Tactics.assumption ]
+END
+
+TACTIC EXTEND etransitivity
+  [ "etransitivity" ] -> [ Tactics.intros_transitivity None ]
+END
+
+TACTIC EXTEND cut
+  [ "cut" constr(c) ] -> [ Tactics.cut c ]
+END
+
+TACTIC EXTEND exact_no_check
+  [ "exact_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.exact_no_check c) ]
+END
+
+TACTIC EXTEND vm_cast_no_check
+  [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ]
+END
+
+TACTIC EXTEND casetype
+  [ "casetype" constr(c) ] -> [ Tactics.case_type c ]
+END
+
+TACTIC EXTEND elimtype
+  [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ]
+END
+
+TACTIC EXTEND lapply
+  [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ]
+END
+
+TACTIC EXTEND transitivity
+  [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ]
+END
+
+(** Left *)
+
+TACTIC EXTEND left
+  [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eleft
+  [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND left_with
+  [ "left" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.left_with_bindings false bl
+  ]
+END
+
+TACTIC EXTEND eleft_with
+  [ "eleft" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true) sigma bl
+  ]
+END
+
+(** Right *)
+
+TACTIC EXTEND right
+  [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ]
+END
+
+TACTIC EXTEND eright
+  [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ]
+END
+
+TACTIC EXTEND right_with
+  [ "right" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.right_with_bindings false bl
+  ]
+END
+
+TACTIC EXTEND eright_with
+  [ "eright" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true) sigma bl
+  ]
+END
+
+(** Constructor *)
+
+TACTIC EXTEND constructor
+  [ "constructor" ] -> [ Tactics.any_constructor false None ]
+| [ "constructor" int_or_var(i) ] -> [
+    let i = Tacinterp.interp_int_or_var ist i in
+    Tactics.constructor_tac false None i NoBindings
+  ]
+| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma; it = bl } = bl in
+    let i = Tacinterp.interp_int_or_var ist i in
+    let tac c = Tactics.constructor_tac false None i c in
+    Proofview.Unsafe.tclEVARS sigma <*> tac bl
+  ]
+END
+
+TACTIC EXTEND econstructor
+  [ "econstructor" ] -> [ Tactics.any_constructor true None ]
+| [ "econstructor" int_or_var(i) ] -> [
+    let i = Tacinterp.interp_int_or_var ist i in
+    Tactics.constructor_tac true None i NoBindings
+  ]
+| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma; it = bl } = bl in
+    let i = Tacinterp.interp_int_or_var ist i in
+    let tac c = Tactics.constructor_tac true None i c in
+    Tacticals.New.tclWITHHOLES true tac sigma bl
+  ]
+END
+
+(** Specialize *)
+
+TACTIC EXTEND specialize
+  [ "specialize" constr_with_bindings(c) ] -> [
+    let { Evd.sigma = sigma; it = c } = c in
+    let specialize c = Proofview.V82.tactic (Tactics.specialize c) in
+    Proofview.Unsafe.tclEVARS sigma <*> specialize c
+  ]
+END
+
+TACTIC EXTEND symmetry
+  [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ]
+END
+
+(** Split *)
+
+TACTIC EXTEND split
+  [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ]
+END
+
+TACTIC EXTEND esplit
+  [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ]
+END
+
+TACTIC EXTEND split_with
+  [ "split" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Proofview.Unsafe.tclEVARS sigma <*> Tactics.split_with_bindings false [bl]
+  ]
+END
+
+TACTIC EXTEND esplit_with
+  [ "esplit" "with" bindings(bl) ] -> [
+    let { Evd.sigma = sigma ; it = bl } = bl in
+    Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true) sigma [bl]
+  ]
+END
+
+(** Intro *)
+
+TACTIC EXTEND intros_until
+  [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ]
+END
+
+(** Revert *)
+
+TACTIC EXTEND revert
+  [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ]
+END
+
+(** Simple induction / destruct *)
+
+TACTIC EXTEND simple_induction
+  [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ]
+END
+
+TACTIC EXTEND simple_destruct
+  [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ]
+END
+
+(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
+
+open Tacexpr
+
+let initial_atomic () =
+  let dloc = Loc.ghost in
+  let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in
+  let iter (s, t) =
+    let body = TacAtom (dloc, t) in
+    Tacenv.register_ltac false false (Id.of_string s) body
+  in
+  let () = List.iter iter
+      [ "red", TacReduce(Red false,nocl);
+        "hnf", TacReduce(Hnf,nocl);
+        "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl);
+        "compute", TacReduce(Cbv Redops.all_flags,nocl);
+        "intro", TacIntroMove(None,MoveLast);
+        "intros", TacIntroPattern [];
+        "cofix", TacCofix None;
+        "trivial", TacTrivial (Off,[],None);
+        "auto", TacAuto(Off,None,[],None);
+      ]
+  in
+  let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in
+  List.iter iter
+      [ "idtac",TacId [];
+        "fail", TacFail(TacLocal,ArgArg 0,[]);
+        "fresh", TacArg(dloc,TacFreshId [])
+      ]
+
+let () = Mltop.declare_cache_obj initial_atomic "coretactics"
diff --git a/tactics/dn.ml b/tactics/dn.ml
index a0889ab8..3b1614d6 100644
--- a/tactics/dn.ml
+++ b/tactics/dn.ml
@@ -1,103 +1,101 @@
+open Util
 
+type 'res lookup_res = Label of 'res | Nothing | Everything
 
-
-
-
-module Make = 
-  functor (X : Set.OrderedType) ->
+module Make =
     functor (Y : Map.OrderedType) ->
       functor (Z : Map.OrderedType) ->
 struct
-  
+
   module Y_tries = struct
     type t = (Y.t * int) option
-    let compare x y = 
+    let compare x y =
       match x,y with
 	  None,None -> 0
-	| Some (l,n),Some (l',n') -> 
+	| Some (l,n),Some (l',n') ->
 	    let m = Y.compare l l' in
-	    if m = 0 then
-	      n-n' 
+	    if Int.equal m 0 then
+	      n-n'
 	    else m
 	| Some(l,n),None -> 1
 	| None, Some(l,n) -> -1
   end
-  module X_tries = struct
-    type t = X.t * Z.t
-    let compare (x1,x2) (y1,y2) = 
-      let m = (X.compare x1 y1) in
-      if m = 0 then (Z.compare x2 y2) else 
-	m
+  module ZSet = Set.Make(Z)
+  module X_tries =
+  struct
+    type t = ZSet.t
+    let nil = ZSet.empty
+    let is_nil = ZSet.is_empty
+    let add = ZSet.union
+    let sub = ZSet.diff
   end
 
-  module T = Tries.Make(X_tries)(Y_tries)
-    
-  type  decompose_fun = X.t -> (Y.t * X.t list) option
-    
-  type 'res lookup_res = Label of 'res | Nothing | Everything
-    
+  module Trie = Trie.Make(Y_tries)(X_tries)
+
+  type 'a decompose_fun = 'a -> (Y.t * 'a list) option
+
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
 
-  type  t = T.t
+  type  t = Trie.t
 
-  let create () = T.empty
+  let create () = Trie.empty
 
-(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in 
+(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in
 prefix ordering, [dna] is the function returning the main node of a pattern *)
 
   let path_of dna =
     let rec path_of_deferred = function
       | [] -> []
       | h::tl -> pathrec tl h
-	  
+
     and pathrec deferred t =
       match dna t with
-	| None -> 
+	| None ->
 	    None :: (path_of_deferred deferred)
 	| Some (lbl,[]) ->
 	    (Some (lbl,0))::(path_of_deferred deferred)
 	| Some (lbl,(h::def_subl as v)) ->
 	    (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
-    in 
+    in
       pathrec []
-	
+
   let tm_of tm lbl =
-    try [T.map tm lbl, true] with Not_found -> []
-      
+    try [Trie.next tm lbl, true] with Not_found -> []
+
   let rec skip_arg n tm =
-    if n = 0 then [tm,true]
+    if Int.equal n 0 then [tm, true]
     else
-      List.flatten 
-	(List.map 
-	   (fun a -> match a with
-	      | None -> skip_arg (pred n) (T.map tm a)
-	      | Some (lbl,m) -> 
-		  skip_arg (pred n + m) (T.map tm a)) 
-	   (T.dom tm))
-	
+      let labels = Trie.labels tm in
+      let map lbl = match lbl with
+      | None -> skip_arg (pred n) (Trie.next tm lbl)
+      | Some (_, m) ->
+        skip_arg (pred n + m) (Trie.next tm lbl)
+      in
+      List.flatten (List.map map labels)
+
   let lookup tm dna t =
     let rec lookrec t tm =
       match dna t with
 	| Nothing -> tm_of tm None
 	| Label(lbl,v) ->
 	    tm_of tm None@
-	      (List.fold_left 
-		 (fun l c -> 
+	      (List.fold_left
+		 (fun l c ->
 		List.flatten(List.map (fun (tm, b) ->
 					 if b then lookrec c tm
 					 else [tm,b]) l))
 		 (tm_of tm (Some(lbl,List.length v))) v)
 	| Everything -> skip_arg 1 tm
-    in 
-      List.flatten (List.map (fun (tm,b) -> T.xtract tm) (lookrec t tm))
-	
+    in
+    List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm))
+
   let add tm dna (pat,inf) =
-    let p = path_of dna pat in T.add tm (p,(pat,inf))
-				 
+    let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm
+
   let rmv tm dna (pat,inf) =
-  let p = path_of dna pat in T.rmv tm (p,(pat,inf))
-			       
-  let app f tm = T.app (fun (_,p) -> f p) tm
-    
+    let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm
+
+  let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm
+
 end
-  
+
diff --git a/tactics/dn.mli b/tactics/dn.mli
index 662ac19a..20407e9d 100644
--- a/tactics/dn.mli
+++ b/tactics/dn.mli
@@ -1,48 +1,39 @@
+type 'res lookup_res = Label of 'res | Nothing | Everything
 
 
-
-
-
-
-
-module Make : 
-  functor (X : Set.OrderedType) ->
+module Make :
     functor (Y : Map.OrderedType) ->
       functor (Z : Map.OrderedType) ->
 sig
 
-  type decompose_fun = X.t -> (Y.t * X.t list) option
-    
+  type 'a decompose_fun = 'a -> (Y.t * 'a list) option
+
   type t
 
   val create : unit -> t
-    
+
   (** [add t f (tree,inf)] adds a structured object [tree] together with
      the associated information [inf] to the table [t]; the function
      [f] is used to translated [tree] into its prefix decomposition: [f]
      must decompose any tree into a label characterizing its root node and
      the list of its subtree *)
-    
-  val add : t -> decompose_fun -> X.t * Z.t -> t
-    
-  val rmv : t -> decompose_fun -> X.t * Z.t -> t
-    
-  type 'res lookup_res = Label of 'res | Nothing | Everything
-      
+
+  val add : t -> 'a decompose_fun -> 'a * Z.t -> t
+
+  val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t
+
   type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res
-    
+
 
 (** [lookup t f tree] looks for trees (and their associated
    information) in table [t] such that the structured object [tree]
    matches against them; [f] is used to translated [tree] into its
    prefix decomposition: [f] must decompose any tree into a label
    characterizing its root node and the list of its subtree *)
-    
+
   val lookup : t -> 'term lookup_fun -> 'term
-    -> (X.t * Z.t) list
-    
-  val app : ((X.t * Z.t) -> unit) -> t -> unit
-    
-  val skip_arg : int -> t -> (t * bool) list
-    
+    -> Z.t list
+
+  val app : (Z.t -> unit) -> t -> unit
+
 end
diff --git a/lib/dnet.ml b/tactics/dnet.ml
index 7f9bd949..61a35866 100644
--- a/lib/dnet.ml
+++ b/tactics/dnet.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        *)
@@ -27,10 +27,9 @@ sig
   type meta
   type 'a structure
   module Idset : Set.S with type elt=ident
-  type 'a pattern =
-    | Term of 'a
+  type term_pattern =
+    | Term of term_pattern structure
     | Meta of meta
-  type term_pattern = ('a structure) pattern as 'a
   val empty : t
   val add : t -> term_pattern -> ident -> t
   val find_all : t -> Idset.t
@@ -51,18 +50,17 @@ struct
   type ident = Ident.t
   type meta = Meta.t
 
-  type 'a pattern =
-    | Term of 'a
-    | Meta of meta
-
   type 'a structure = 'a T.t
 
+  type term_pattern =
+    | Term of term_pattern structure
+    | Meta of meta
+
   module Idset = Set.Make(Ident)
   module Mmap = Map.Make(Meta)
   module Tmap = Map.Make(struct type t = unit structure
 				let compare = T.compare end)
 
-  type term_pattern = term_pattern structure pattern
   type idset = Idset.t
 
 
@@ -169,13 +167,13 @@ struct
   (* Sets with a neutral element for inter *)
   module OSet (S:Set.S) = struct
     type t = S.t option
-    let union s1 s2 = match s1,s2 with
+    let union s1 s2 : t = match s1,s2 with
       | (None, _ | _, None) -> None
       | Some a, Some b -> Some (S.union a b)
-    let inter s1 s2 = match s1,s2 with
+    let inter s1 s2 : t = match s1,s2 with
       | (None, a | a, None) -> a
       | Some a, Some b -> Some (S.inter a b)
-    let is_empty = function 
+    let is_empty : t -> bool = function 
       | None -> false
       | Some s -> S.is_empty s
     (* optimization hack: Not_found is catched in fold_pattern *)
diff --git a/lib/dnet.mli b/tactics/dnet.mli
index 826e120a..4bfa7263 100644
--- a/lib/dnet.mli
+++ b/tactics/dnet.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        *)
@@ -83,12 +83,10 @@ sig
 
   (** a pattern is a term where each node can be a unification
      variable *)
-  type 'a pattern =
-    | Term of 'a
+  type term_pattern =
+    | Term of term_pattern structure
     | Meta of meta
 
-  type term_pattern = 'a structure pattern as 'a
-
   val empty : t
 
   (** [add t w i] adds a new association (w,i) in t. *)
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index 144100c9..30c5e686 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -1,40 +1,42 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
+open Errors
 open Util
 open Names
 open Nameops
 open Term
 open Termops
-open Sign
-open Reduction
 open Proof_type
-open Declarations
 open Tacticals
 open Tacmach
-open Evar_refiner
 open Tactics
-open Pattern
+open Patternops
 open Clenv
 open Auto
-open Glob_term
-open Hiddentac
+open Genredexpr
 open Tacexpr
+open Misctypes
+open Locus
+open Locusops
+open Hints
 
-let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
+DECLARE PLUGIN "eauto"
+
+let eauto_unif_flags = auto_flags_of_state full_transparent_state
 
 let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in
-  if occur_existential t1 or occur_existential t2 then
-     tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl
-  else exact_check c gl
+  if occur_existential t1 || occur_existential t2 then
+     tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl
+  else Proofview.V82.of_tactic (exact_check c) gl
 
 let assumption id = e_give_exact (mkVar id)
 
@@ -42,11 +44,11 @@ let e_assumption gl =
   tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
 
 TACTIC EXTEND eassumption
-| [ "eassumption" ] -> [ e_assumption ]
+| [ "eassumption" ] -> [ Proofview.V82.tactic e_assumption ]
 END
 
 TACTIC EXTEND eexact
-| [ "eexact" constr(c) ] -> [ e_give_exact c ]
+| [ "eexact" constr(c) ] -> [ Proofview.V82.tactic (e_give_exact c) ]
 END
 
 let registered_e_assumption gl =
@@ -57,10 +59,29 @@ let registered_e_assumption gl =
 (*   PROLOG tactic                                                      *)
 (************************************************************************)
 
+(*s Tactics handling a list of goals. *)
+
+(* first_goal : goal list sigma -> goal sigma *)
+
+let first_goal gls =
+  let gl = gls.Evd.it and sig_0 = gls.Evd.sigma in
+  if List.is_empty gl then error "first_goal";
+  { Evd.it = List.hd gl; Evd.sigma = sig_0; }
+
+(* tactic -> tactic_list : Apply a tactic to the first goal in the list *)
+
+let apply_tac_list tac glls =
+  let (sigr,lg) = unpackage glls in
+  match lg with
+  | (g1::rest) ->
+      let gl = apply_sig_tac sigr tac g1 in
+      repackage sigr (gl@rest)
+  | _ -> error "apply_tac_list"
+
 let one_step l gl =
-  [Tactics.intro]
-  @ (List.map h_simplest_eapply (List.map mkVar (pf_ids_of_hyps gl)))
-  @ (List.map h_simplest_eapply l)
+  [Proofview.V82.of_tactic Tactics.intro]
+  @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl)))
+  @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l)
   @ (List.map assumption (pf_ids_of_hyps gl))
 
 let rec prolog l n gl =
@@ -68,11 +89,15 @@ let rec prolog l n gl =
   let prol = (prolog l (n-1)) in
   (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
 
+let out_term = function
+  | IsConstr (c, _) -> c
+  | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr)
+
 let prolog_tac l n gl =
-  let l = List.map (prepare_hint (pf_env gl)) l in
+  let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in
   let n =
     match n with
-      |  ArgArg n -> n
+      | ArgArg n -> n
       | _ -> error "Prolog called with a non closed argument."
   in
   try (prolog l n gl)
@@ -80,7 +105,7 @@ let prolog_tac l n gl =
     errorlabstrm "Prolog.prolog" (str "Prolog failed.")
 
 TACTIC EXTEND prolog
-| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ]
 END
 
 open Auto
@@ -90,17 +115,26 @@ open Unification
 (* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
 (***************************************************************************)
 
-let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
-
-let unify_e_resolve flags (c,clenv) gls =
-  let clenv' = connect_clenv gls clenv in
-  let _ = clenv_unique_resolver ~flags clenv' gls in
-  h_simplest_eapply c gls
-
+let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l)
+
+let unify_e_resolve poly flags (c,clenv) gls =
+  let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv 
+  else clenv, Univ.empty_level_subst in
+  let clenv' = connect_clenv gls clenv' in
+  let clenv' = clenv_unique_resolver ~flags clenv' gls in
+    tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd))
+      (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls
+
+let e_exact poly flags (c,clenv) =
+  let clenv', subst = 
+    if poly then Clenv.refresh_undefined_univs clenv 
+    else clenv, Univ.empty_level_subst
+  in e_give_exact (* ~flags *) (Vars.subst_univs_level_constr subst c)
+    
 let rec e_trivial_fail_db db_list local_db goal =
   let tacl =
     registered_e_assumption ::
-    (tclTHEN Tactics.intro
+    (tclTHEN (Proofview.V82.of_tactic Tactics.intro)
        (function g'->
 	  let d = pf_last_hyp g' in
 	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
@@ -108,43 +142,35 @@ let rec e_trivial_fail_db db_list local_db goal =
 	      (Hint_db.add_list hintl local_db) g'))) ::
     (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
   in
-  tclFIRST (List.map tclCOMPLETE tacl) goal
+    tclFIRST (List.map tclCOMPLETE tacl) goal
 
 and e_my_find_search db_list local_db hdc concl =
-  let hdc = head_of_constr_reference hdc in
   let hintl =
     if occur_existential concl then
-      list_map_append (fun db ->
-	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list)
+      List.map_append (fun db ->
+	let flags = auto_flags_of_state (Hint_db.transparent_state db) in
+	  List.map (fun x -> flags, x) (Hint_db.map_existential hdc concl db)
+   (* FIXME: should be (Hint_db.map_eauto hdc concl db) *)) (local_db::db_list)
     else
-      list_map_append (fun db ->
-	let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in
-	  List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
+      List.map_append (fun db ->
+	let flags = auto_flags_of_state (Hint_db.transparent_state db) in
+	  List.map (fun x -> flags, x) (Hint_db.map_auto hdc concl db)) (local_db::db_list)
   in
   let tac_of_hint =
-    fun (st, {pri=b; pat = p; code=t}) ->
+    fun (st, {pri = b; pat = p; code = t; poly = poly}) ->
       (b,
        let tac =
 	 match t with
-	   | Res_pf (term,cl) -> unify_resolve st (term,cl)
-	   | ERes_pf (term,cl) -> unify_e_resolve st (term,cl)
-	   | Give_exact (c) -> e_give_exact c
+	   | Res_pf (term,cl) -> Proofview.V82.of_tactic (unify_resolve poly st (term,cl))
+	   | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl)
+	   | Give_exact (c,cl) -> e_exact poly st (c,cl)
 	   | Res_pf_THEN_trivial_fail (term,cl) ->
-               tclTHEN (unify_e_resolve st (term,cl))
+               tclTHEN (unify_e_resolve poly st (term,cl))
 		 (e_trivial_fail_db db_list local_db)
-	   | Unfold_nth c -> h_reduce (Unfold [all_occurrences_expr,c]) onConcl
-	   | Extern tacast -> conclPattern concl p tacast
+	   | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl
+	   | Extern tacast -> Proofview.V82.of_tactic (conclPattern concl p tacast)
        in
        (tac,lazy (pr_autotactic t)))
-       (*i
-	 fun gls -> pPNL (pr_autotactic t); Format.print_flush ();
-                     try tac gls
-		     with e when Logic.catchable_exception(e) ->
-                            (Format.print_string "Fail\n";
-			     Format.print_flush ();
-			     raise e)
-       i*)
   in
   List.map tac_of_hint hintl
 
@@ -152,13 +178,13 @@ and e_trivial_resolve db_list local_db gl =
   try
     priority
       (e_my_find_search db_list local_db
-	 (fst (head_constr_bound gl)) gl)
+	 (decompose_app_bound gl) gl)
   with Bound | Not_found -> []
 
 let e_possible_resolve db_list local_db gl =
   try List.map snd
     (e_my_find_search db_list local_db
-	(fst (head_constr_bound gl)) gl)
+	(decompose_app_bound gl) gl)
   with Bound | Not_found -> []
 
 let find_first_goal gls =
@@ -171,8 +197,8 @@ type search_state = {
   depth : int; (*r depth of search before failing *)
   tacres : goal list sigma;
   last_tactic : std_ppcmds Lazy.t;
-  dblist : Auto.hint_db list;
-  localdb :  Auto.hint_db list;
+  dblist : hint_db list;
+  localdb :  hint_db list;
   prev : prev_search_state
 }
 
@@ -185,13 +211,9 @@ module SearchProblem = struct
 
   type state = search_state
 
-  let success s = (sig_it s.tacres) = []
+  let success s = List.is_empty (sig_it s.tacres)
 
-  let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl)
-
-  let pr_goals gls =
-    let evars = Evarutil.nf_evar_map (Refiner.project gls) in
-      prlist (pr_ev evars) (sig_it gls)
+(*   let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) *)
 
   let filter_tactics glls l =
 (*     let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *)
@@ -206,6 +228,7 @@ module SearchProblem = struct
 (* 	      msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *)
 	      (lgls,pptac) :: aux tacl
 	  with e when Errors.noncritical e ->
+            let e = Errors.push e in
             Refiner.catch_failerror e; aux tacl
     in aux l
 
@@ -214,13 +237,13 @@ module SearchProblem = struct
   let compare s s' =
     let d = s'.depth - s.depth in
     let nbgoals s = List.length (sig_it s.tacres) in
-    if d <> 0 then d else nbgoals s - nbgoals s'
+    if not (Int.equal d 0) then d else nbgoals s - nbgoals s'
 
   let branching s =
-    if s.depth = 0 then
+    if Int.equal s.depth 0 then
       []
     else
-      let ps = if s.prev = Unknown then Unknown else State s in
+      let ps = if s.prev == Unknown then Unknown else State s in
       let lg = s.tacres in
       let nbgl = List.length (sig_it lg) in
       assert (nbgl > 0);
@@ -249,7 +272,7 @@ module SearchProblem = struct
 	     { depth = s.depth; tacres = res;
 	       last_tactic = pp; dblist = s.dblist;
 	       localdb = ldb :: List.tl s.localdb; prev = ps })
-	  (filter_tactics s.tacres [Tactics.intro,lazy (str "intro")])
+	  (filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro,lazy (str "intro")])
       in
       let rec_tacs =
 	let l =
@@ -262,10 +285,18 @@ module SearchProblem = struct
 	       { depth = s.depth; tacres = res; last_tactic = pp; prev = ps;
 		 dblist = s.dblist; localdb = List.tl s.localdb }
 	     else
-	       { depth = pred s.depth; tacres = res;
-		 dblist = s.dblist; last_tactic = pp; prev = ps;
-		 localdb =
-		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
+	       let newlocal = 
+		 let hyps = pf_hyps g in
+		   List.map (fun gl ->
+		     let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in
+		     let hyps' = pf_hyps gls in
+		       if hyps' == hyps then List.hd s.localdb
+		       else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true [])
+		     (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls))
+	       in
+		 { depth = pred s.depth; tacres = res;
+		   dblist = s.dblist; last_tactic = pp; prev = ps;
+		   localdb = newlocal @ List.tl s.localdb })
 	  l
       in
       List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
@@ -301,8 +332,8 @@ let _ =
       Goptions.optwrite = (:=) global_info_eauto }
 
 let mk_eauto_dbg d =
-  if d = Debug || !global_debug_eauto then Debug
-  else if d = Info || !global_info_eauto then Info
+  if d == Debug || !global_debug_eauto then Debug
+  else if d == Info || !global_info_eauto then Info
   else Off
 
 let pr_info_nop = function
@@ -315,7 +346,7 @@ let pr_dbg_header = function
   | Info -> msg_debug (str "(* info eauto : *)")
 
 let pr_info dbg s =
-  if dbg <> Info then ()
+  if dbg != Info then ()
   else
     let rec loop s =
       match s.prev with
@@ -336,11 +367,11 @@ let make_initial_state dbg n gl dblist localdb =
     last_tactic = lazy (mt());
     dblist = dblist;
     localdb = [localdb];
-    prev = if dbg=Info then Init else Unknown;
+    prev = if dbg == Info then Init else Unknown;
   }
 
 let e_search_auto debug (in_depth,p) lems db_list gl =
-  let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
+  let local_db = make_local_hint_db (pf_env gl) (project gl) ~ts:full_transparent_state true lems in
   let d = mk_eauto_dbg debug in
   let tac = match in_depth,d with
     | (true,Debug) -> Search.debug_depth_first
@@ -357,7 +388,8 @@ let e_search_auto debug (in_depth,p) lems db_list gl =
     pr_info_nop d;
     error "eauto: search failed"
 
-open Evd
+(* let e_search_auto_key = Profile.declare_profile "e_search_auto" *)
+(* let e_search_auto = Profile.profile5 e_search_auto_key e_search_auto *)
 
 let eauto_with_bases ?(debug=Off) np lems db_list =
   tclTRY (e_search_auto debug np lems db_list)
@@ -368,8 +400,8 @@ let eauto ?(debug=Off) np lems dbnames =
 
 let full_eauto ?(debug=Off) n lems gl =
   let dbnames = current_db_names () in
-  let dbnames =  list_remove "v62" dbnames in
-  let db_list = List.map searchtable_map dbnames in
+  let dbnames =  String.Set.remove "v62" dbnames in
+  let db_list = List.map searchtable_map (String.Set.elements dbnames) in
   tclTRY (e_search_auto debug n lems db_list) gl
 
 let gen_eauto ?(debug=Off) np lems = function
@@ -422,7 +454,7 @@ END
 TACTIC EXTEND eauto
 | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND new_eauto
@@ -436,64 +468,70 @@ END
 TACTIC EXTEND debug_eauto
 | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto ~debug:Debug (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND info_eauto
 | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
     hintbases(db) ] ->
-    [ gen_eauto ~debug:Info (make_dimension n p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ]
 END
 
 TACTIC EXTEND dfs_eauto
 | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
       hintbases(db) ] ->
-    [ gen_eauto (true, make_depth p) lems db ]
+    [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ]
 END
 
 let cons a l = a :: l
 
-let autounfolds db occs =
+let autounfolds db occs cls gl =
   let unfolds = List.concat (List.map (fun dbname -> 
     let db = try searchtable_map dbname 
       with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
     in
     let (ids, csts) = Hint_db.unfolds db in
-      Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts
-	(Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db)
-  in unfold_option unfolds
+    let hyps = pf_ids_of_hyps gl in
+    let ids = Idset.filter (fun id -> List.mem id hyps) ids in
+      Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts
+	(Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db)
+  in unfold_option unfolds cls gl
 
 let autounfold db cls gl =
-  let cls = concrete_clause_of cls gl in
+  let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in
   let tac = autounfolds db in
   tclMAP (function
     | OnHyp (id,occs,where) -> tac occs (Some (id,where))
     | OnConcl occs -> tac occs None)
     cls gl
 
-open Extraargs
+let autounfold_tac db cls gl =
+  let dbs = match db with
+  | None -> String.Set.elements (current_db_names ())
+  | Some [] -> ["core"]
+  | Some l -> l
+  in
+  autounfold dbs  cls gl
 
 TACTIC EXTEND autounfold
-| [ "autounfold" hintbases(db) in_arg_hyp(id) ] ->
-    [ autounfold (match db with None -> Auto.current_db_names () | Some [] -> ["core"] | Some x -> x) 
-	(glob_in_arg_hyp_to_clause id) ]
+| [ "autounfold" hintbases(db) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ]
 END
 
 let unfold_head env (ids, csts) c = 
   let rec aux c = 
     match kind_of_term c with
-    | Var id when Idset.mem id ids ->
+    | Var id when Id.Set.mem id ids ->
 	(match Environ.named_body id env with
 	| Some b -> true, b
 	| None -> false, c)
-    | Const cst when Cset.mem cst csts ->
-	true, Environ.constant_value env cst
+    | Const (cst,u as c) when Cset.mem cst csts ->
+	true, Environ.constant_value_in env c
     | App (f, args) ->
 	(match aux f with
 	| true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args))
 	| false, _ -> 
 	    let done_, args' = 
-	      array_fold_left_i (fun i (done_, acc) arg -> 
+	      Array.fold_left_i (fun i (done_, acc) arg -> 
 		if done_ then done_, arg :: acc 
 		else match aux arg with
 		| true, arg' -> true, arg' :: acc
@@ -511,24 +549,30 @@ let unfold_head env (ids, csts) c =
 	in !done_, c'
   in aux c
 
-let autounfold_one db cl gl =
+let autounfold_one db cl =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let concl = Proofview.Goal.concl gl in
   let st =
     List.fold_left (fun (i,c) dbname -> 
       let db = try searchtable_map dbname 
 	with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
       in
       let (ids, csts) = Hint_db.unfolds db in
-	(Idset.union ids i, Cset.union csts c)) (Idset.empty, Cset.empty) db
+	(Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db
+  in
+  let did, c' = unfold_head env st 
+    (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) 
   in
-  let did, c' = unfold_head (pf_env gl) st (match cl with Some (id, _) -> pf_get_hyp_typ gl id | None -> pf_concl gl) in
     if did then
       match cl with
-      | Some hyp -> change_in_hyp None c' hyp gl
-      | None -> convert_concl_no_check c' DEFAULTcast gl
-    else tclFAIL 0 (str "Nothing to unfold") gl
+      | Some hyp -> change_in_hyp None (fun sigma -> sigma, c') hyp
+      | None -> convert_concl_no_check c' DEFAULTcast
+    else Tacticals.New.tclFAIL 0 (str "Nothing to unfold")
+  end
 
 (* 	  Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *)
-(* 	    (Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
+(* 	    (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *)
 (*       in unfold_option unfolds cl *)
 
 (*       let db = try searchtable_map dbname  *)
@@ -536,7 +580,7 @@ let autounfold_one db cl gl =
 (*       in *)
 (*       let (ids, csts) = Hint_db.unfolds db in *)
 (* 	Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *)
-(* 	  (Idset.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *)
+(* 	  (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *)
 (*       (tclFAIL 0 (mt())) db *)
       
 TACTIC EXTEND autounfold_one
@@ -548,16 +592,26 @@ TACTIC EXTEND autounfold_one
 
 TACTIC EXTEND autounfoldify
 | [ "autounfoldify" constr(x) ] -> [
+  Proofview.V82.tactic (
     let db = match kind_of_term x with
-      | Const c -> string_of_label (con_label c)
+      | Const (c,_) -> Label.to_string (con_label c)
       | _ -> assert false
-    in autounfold ["core";db] onConcl ]
+    in autounfold ["core";db] onConcl 
+  )]
 END
 
 TACTIC EXTEND unify
 | ["unify" constr(x) constr(y) ] -> [ unify x y ]
 | ["unify" constr(x) constr(y) "with" preident(base)  ] -> [
-    unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ]
+    let table = try Some (searchtable_map base) with Not_found -> None in
+    match table with
+    | None ->
+      let msg = str "Hint table " ++ str base ++ str " not found" in
+      Proofview.tclZERO (UserError ("", msg))
+    | Some t ->
+      let state = Hint_db.transparent_state t in
+      unify ~state x y
+  ]
 END
 
 
@@ -570,7 +624,7 @@ let pr_hints_path_atom prc _ _ a =
   match a with
   | PathAny -> str"."
   | PathHints grs ->
-    prlist_with_sep pr_spc Printer.pr_global grs
+    pr_sequence Printer.pr_global grs
 
 ARGUMENT EXTEND hints_path_atom
   TYPED AS hints_path_atom
@@ -610,9 +664,9 @@ ARGUMENT EXTEND opthints
 | [ ] -> [ None ]
 END
 
-VERNAC COMMAND EXTEND HintCut
+VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF
 | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [
   let entry = HintsCutEntry p in
-    Auto.add_hints (Vernacexpr.use_section_locality ()) 
+    Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
       (match dbnames with None -> ["core"] | Some l -> l) entry ]
 END
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index bfe52d9a..19e2f198 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.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,18 +8,19 @@
 
 open Term
 open Proof_type
-open Tacexpr
 open Auto
-open Topconstr
 open Evd
-open Environ
-open Explore
+open Hints
 
 val hintbases : hint_db_name list option Pcoq.Gram.entry
-val wit_hintbases : hint_db_name list option typed_abstract_argument_type
-val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
 
-val rawwit_auto_using : Genarg.open_constr_expr list raw_abstract_argument_type
+val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type
+
+val wit_auto_using :
+  (Tacexpr.open_constr_expr list,
+  Tacexpr.open_glob_constr list, Evd.open_constr list)
+    Genarg.genarg_type
+
 
 val e_assumption : tactic
 
@@ -33,6 +34,6 @@ val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
 val eauto_with_bases :
   ?debug:Tacexpr.debug ->
   bool * int ->
-  open_constr list -> Auto.hint_db list -> Proof_type.tactic
+  open_constr list -> hint_db list -> Proof_type.tactic
 
-val autounfold : hint_db_name list -> Tacticals.clause -> tactic
+val autounfold : hint_db_name list -> Locus.clause -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index ea5b4eed..b7d5b102 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -1,35 +1,28 @@
 (************************************************************************)
 (*  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 Names
 open Term
 open Termops
-open Environ
-open Libnames
-open Reduction
 open Inductiveops
-open Proof_type
-open Clenv
 open Hipattern
-open Tacmach
-open Tacticals
+open Tacmach.New
+open Tacticals.New
 open Tactics
-open Hiddentac
-open Genarg
-open Tacexpr
+open Misctypes
+open Proofview.Notations
 
 let introElimAssumsThen tac ba =
   let nassums =
     List.fold_left
       (fun acc b -> if b then acc+2 else acc+1)
-      0 ba.branchsign
+      0 ba.Tacticals.branchsign
   in
   let introElimAssums = tclDO nassums intro in
   (tclTHEN introElimAssums (elim_on_ba tac ba))
@@ -38,17 +31,17 @@ let introCaseAssumsThen tac ba =
   let case_thin_sign =
     List.flatten
       (List.map (function b -> if b then [false;true] else [false])
-	ba.branchsign)
+	ba.Tacticals.branchsign)
   in
   let n1 = List.length case_thin_sign in
-  let n2 = List.length ba.branchnames in
+  let n2 = List.length ba.Tacticals.branchnames in
   let (l1,l2),l3 =
-    if n1 < n2 then list_chop n1 ba.branchnames, []
+    if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, []
     else
-      (ba.branchnames, []),
-       if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
+      (ba.Tacticals.branchnames, []),
+       if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in
   let introCaseAssums =
-    tclTHEN (intros_pattern no_move l1) (intros_clearing l3) in
+    tclTHEN (intro_patterns l1) (intros_clearing l3) in
   (tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
 
 (* The following tactic Decompose repeatedly applies the
@@ -69,118 +62,120 @@ Another example :
    Qed.
 *)
 
-let elimHypThen tac id gl =
-  elimination_then tac ([],[]) (mkVar id) gl
+let elimHypThen tac id =
+  elimination_then tac (mkVar id)
 
 let rec general_decompose_on_hyp recognizer =
-  ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> tclIDTAC)
+  ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT())
 
 and general_decompose_aux recognizer id =
   elimHypThen
     (introElimAssumsThen
        (fun bas ->
-	  tclTHEN (clear [id])
+	  tclTHEN (Proofview.V82.tactic (clear [id]))
 	    (tclMAP (general_decompose_on_hyp recognizer)
-               (ids_of_named_context bas.assums))))
+               (ids_of_named_context bas.Tacticals.assums))))
     id
 
-(* Faudrait ajouter un COMPLETE pour que l'hypothèse créée ne reste
-   pas si aucune élimination n'est possible *)
+(* We should add a COMPLETE to be sure that the created hypothesis
+   doesn't stay if no elimination is possible *)
 
-(* Meilleures stratégies mais perte de compatibilité *)
-let tmphyp_name = id_of_string "_TmpHyp"
+(* Best strategies but loss of compatibility *)
+let tmphyp_name = Id.of_string "_TmpHyp"
 let up_to_delta = ref false (* true *)
 
-let general_decompose recognizer c gl =
-  let typc = pf_type_of gl c in
-  tclTHENSV (cut typc)
-    [| tclTHEN (intro_using tmphyp_name)
+let general_decompose recognizer c =
+  Proofview.Goal.enter begin fun gl ->
+  let type_of = pf_type_of gl in
+  let typc = type_of c in
+  tclTHENS (cut typc)
+    [ tclTHEN (intro_using tmphyp_name)
          (onLastHypId
 	    (ifOnHyp recognizer (general_decompose_aux recognizer)
-	      (fun id -> clear [id])));
-       exact_no_check c |] gl
+	      (fun id -> Proofview.V82.tactic (clear [id]))));
+       Proofview.V82.tactic (exact_no_check c) ]
+  end
 
-let head_in gls indl t =
+let head_in indl t gl =
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   try
     let ity,_ =
       if !up_to_delta
-      then find_mrectype (pf_env gls) (project gls) t
+      then find_mrectype env sigma t
       else extract_mrectype t
-    in List.mem ity indl
+    in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl
   with Not_found -> false
 
-let decompose_these c l gls =
-  let indl = (*List.map inductive_of*) l in
-  general_decompose (fun (_,t) -> head_in gls indl t) c gls
+let decompose_these c l =
+  Proofview.Goal.enter begin fun gl ->
+  let indl = List.map (fun x -> x, Univ.Instance.empty) l in
+  general_decompose (fun (_,t) -> head_in indl t gl) c
+  end
 
-let decompose_nonrec c gls =
-  general_decompose
-    (fun (_,t) -> is_non_recursive_type t)
-    c gls
-
-let decompose_and c gls =
+let decompose_and c =
   general_decompose
     (fun (_,t) -> is_record t)
-    c gls
+    c
 
-let decompose_or c gls =
+let decompose_or c =
   general_decompose
     (fun (_,t) -> is_disjunction t)
-    c gls
+    c
 
-let h_decompose l c =
-  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
+let h_decompose l c = decompose_these c l
 
-let h_decompose_or c =
-  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
+let h_decompose_or = decompose_or
 
-let h_decompose_and c =
-  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
+let h_decompose_and = decompose_and
 
 (* The tactic Double performs a double induction *)
 
-let simple_elimination c gls =
-  simple_elimination_then (fun _ -> tclIDTAC) c gls
+let simple_elimination c =
+  elimination_then (fun _ -> tclIDTAC) c
 
 let induction_trailer abs_i abs_j bargs =
   tclTHEN
     (tclDO (abs_j - abs_i) intro)
     (onLastHypId
-       (fun id gls ->
-	  let idty = pf_type_of gls (mkVar id) in
-	  let fvty = global_vars (pf_env gls) idty in
+       (fun id ->
+          Proofview.Goal.nf_enter begin fun gl ->
+	  let idty = pf_type_of gl (mkVar id) in
+	  let fvty = global_vars (pf_env gl) idty in
 	  let possible_bring_hyps =
-	    (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums
+	    (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums
           in
 	  let (hyps,_) =
             List.fold_left
-	      (fun (bring_ids,leave_ids) (cid,_,cidty as d) ->
+	      (fun (bring_ids,leave_ids) (cid,_,_ as d) ->
                  if not (List.mem cid leave_ids)
                  then (d::bring_ids,leave_ids)
                  else (bring_ids,cid::leave_ids))
 	      ([],fvty) possible_bring_hyps
 	  in
           let ids = List.rev (ids_of_named_context hyps) in
-	  (tclTHENSEQ
-            [bring_hyps hyps; tclTRY (clear ids);
+	  (tclTHENLIST
+            [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids));
 	     simple_elimination (mkVar id)])
-          gls))
-
-let double_ind h1 h2 gls =
-  let abs_i = depth_of_quantified_hypothesis true h1 gls in
-  let abs_j = depth_of_quantified_hypothesis true h2 gls in
-  let (abs_i,abs_j) =
-    if abs_i < abs_j then (abs_i,abs_j) else
-    if abs_i > abs_j then (abs_j,abs_i) else
-      error "Both hypotheses are the same." in
+          end
+          ))
+
+let double_ind h1 h2 =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in
+  let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in
+  let abs =
+    if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else
+    if abs_i > abs_j then  Proofview.tclUNIT (abs_j,abs_i) else
+      tclZEROMSG (Pp.str "Both hypotheses are the same.") in
+  abs >>= fun (abs_i,abs_j) ->
   (tclTHEN (tclDO abs_i intro)
      (onLastHypId
        	(fun id ->
            elimination_then
-             (introElimAssumsThen (induction_trailer abs_i abs_j))
-             ([],[]) (mkVar id)))) gls
+             (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id))))
+  end
 
-let h_double_induction h1 h2 =
-  Refiner.abstract_tactic (TacDoubleInduction (h1,h2)) (double_ind h1 h2)
+let h_double_induction = double_ind
 
 
diff --git a/tactics/elim.mli b/tactics/elim.mli
index 2c6b8d96..8e98646e 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.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,27 +8,16 @@
 
 open Names
 open Term
-open Proof_type
-open Tacmach
-open Genarg
 open Tacticals
+open Misctypes
 
 (** Eliminations tactics. *)
 
-val introElimAssumsThen :
-  (branch_assumptions -> tactic) -> branch_args -> tactic
-
 val introCaseAssumsThen :
-  (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) ->
-    branch_args -> tactic
-
-val general_decompose : (identifier * constr -> bool) -> constr -> tactic
-val decompose_nonrec  : constr -> tactic
-val decompose_and     : constr -> tactic
-val decompose_or      : constr -> tactic
-val h_decompose       : inductive list -> constr -> tactic
-val h_decompose_or    : constr -> tactic
-val h_decompose_and   : constr -> tactic
+  (Tacexpr.intro_patterns -> branch_assumptions -> unit Proofview.tactic) ->
+    branch_args -> unit Proofview.tactic
 
-val double_ind : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis -> tactic
-val h_double_induction : Glob_term.quantified_hypothesis -> Glob_term.quantified_hypothesis->tactic
+val h_decompose       : inductive list -> constr -> unit Proofview.tactic
+val h_decompose_or    : constr -> unit Proofview.tactic
+val h_decompose_and   : constr -> unit Proofview.tactic
+val h_double_induction : quantified_hypothesis -> quantified_hypothesis-> unit Proofview.tactic
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index df4c0ebc..749e0d2b 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.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        *)
@@ -17,19 +17,21 @@ open Term
 open Indrec
 open Declarations
 open Typeops
-open Termops
 open Ind_tables
 
 (* Induction/recursion schemes *)
 
 let optimize_non_type_induction_scheme kind dep sort ind =
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
   if check_scheme kind ind then
     (* in case the inductive has a type elimination, generates only one
        induction scheme, the other ones share the same code with the
        apropriate type *)
-    let cte = find_scheme kind ind in
-    let c = mkConst cte in
-    let t = type_of_constant (Global.env()) cte in
+    let cte, eff = find_scheme kind ind in
+    let sigma, cte = Evd.fresh_constant_instance env sigma cte in
+    let c = mkConstU cte in
+    let t = type_of_constant_in (Global.env()) cte in
     let (mib,mip) = Global.lookup_inductive ind in
     let npars =
       (* if a constructor of [ind] contains a recursive call, the scheme
@@ -39,28 +41,42 @@ let optimize_non_type_induction_scheme kind dep sort ind =
 	mib.mind_nparams_rec
       else
 	mib.mind_nparams in
-    snd (weaken_sort_scheme (new_sort_in_family sort) npars c t)
+    let sigma, sort = Evd.fresh_sort_in_family env sigma sort in
+    let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in
+    let sigma, nf = Evarutil.nf_evars_and_universes sigma in
+      (nf c', Evd.evar_universe_context sigma), eff
   else
-    build_induction_scheme (Global.env()) Evd.empty ind dep sort
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+    let ctx = Declareops.inductive_context mib in
+    let u = Univ.UContext.instance ctx in
+    let ctxset = Univ.ContextSet.of_context ctx in
+    let ectx = Evd.evar_universe_context_of ctxset in
+    let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in
+      (c, Evd.evar_universe_context sigma), Declareops.no_seff
 
 let build_induction_scheme_in_type dep sort ind =
-  build_induction_scheme (Global.env()) Evd.empty ind dep sort
-
+  let env = Global.env () in
+  let ctx = 
+    let mib,mip = Inductive.lookup_mind_specif env ind in
+      Declareops.inductive_context mib
+  in
+  let u = Univ.UContext.instance ctx in
+  let ctxset = Univ.ContextSet.of_context ctx in
+  let ectx = Evd.evar_universe_context_of ctxset in
+  let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in
+    c, Evd.evar_universe_context sigma
+ 
 let rect_scheme_kind_from_type =
   declare_individual_scheme_object "_rect_nodep"
-    (build_induction_scheme_in_type false InType)
+    (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff)
 
 let rect_scheme_kind_from_prop =
   declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop"
-    (build_induction_scheme_in_type false InType)
+    (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff)
 
 let rect_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_rect" ~aux:"_rect_from_type"
-    (build_induction_scheme_in_type true InType)
-
-let rect_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_rect_dep"
-    (build_induction_scheme_in_type true InType)
+    (fun x -> build_induction_scheme_in_type true InType x, Declareops.no_seff)
 
 let ind_scheme_kind_from_type =
   declare_individual_scheme_object "_ind_nodep"
@@ -74,14 +90,6 @@ let ind_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_ind" ~aux:"_ind_from_type"
   (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp)
 
-let ind_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_ind_dep"
-  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InProp)
-
-let rec_scheme_kind_from_type =
-  declare_individual_scheme_object "_rec_nodep"
-  (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet)
-
 let rec_scheme_kind_from_prop =
   declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop"
   (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet)
@@ -90,35 +98,35 @@ let rec_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_rec" ~aux:"_rec_from_type"
   (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet)
 
-let rec_dep_scheme_kind_from_prop =
-  declare_individual_scheme_object "_rec_dep"
-  (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_prop true InSet)
-
 (* Case analysis *)
 
 let build_case_analysis_scheme_in_type dep sort ind =
-  build_case_analysis_scheme (Global.env()) Evd.empty ind dep sort
+  let env = Global.env () in
+  let sigma = Evd.from_env env in
+  let sigma, indu = Evd.fresh_inductive_instance env sigma ind in
+  let sigma, c = build_case_analysis_scheme env sigma indu dep sort in 
+    c, Evd.evar_universe_context sigma
 
 let case_scheme_kind_from_type =
   declare_individual_scheme_object "_case_nodep"
-  (build_case_analysis_scheme_in_type false InType)
+  (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff)
 
 let case_scheme_kind_from_prop =
   declare_individual_scheme_object "_case" ~aux:"_case_from_prop"
-  (build_case_analysis_scheme_in_type false InType)
+  (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_type =
   declare_individual_scheme_object "_case" ~aux:"_case_from_type"
-  (build_case_analysis_scheme_in_type true InType)
+  (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_type_in_prop =
   declare_individual_scheme_object "_casep_dep"
-  (build_case_analysis_scheme_in_type true InProp)
+  (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_prop =
   declare_individual_scheme_object "_case_dep"
-  (build_case_analysis_scheme_in_type true InType)
+  (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff)
 
 let case_dep_scheme_kind_from_prop_in_prop =
   declare_individual_scheme_object "_casep"
-  (build_case_analysis_scheme_in_type true InProp)
+  (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff)
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index c747b843..0b843b8f 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.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/tactics/eqdecide.ml b/tactics/eqdecide.ml
new file mode 100644
index 00000000..c2cd9e47
--- /dev/null
+++ b/tactics/eqdecide.ml
@@ -0,0 +1,212 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Errors
+open Util
+open Names
+open Namegen
+open Term
+open Declarations
+open Tactics
+open Tacticals.New
+open Auto
+open Constr_matching
+open Hipattern
+open Tacmach.New
+open Coqlib
+
+(* This file containts the implementation of the tactics ``Decide
+   Equality'' and ``Compare''. They can be used to decide the
+   propositional equality of two objects that belongs to a small
+   inductive datatype --i.e., an inductive set such that all the
+   arguments of its constructors are non-functional sets.
+
+   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
+   follows:
+   1. Eliminate x and then y.
+   2. Try discrimination to solve those goals where x and y has
+      been introduced by different constructors.
+   3. If x and y have been introduced by the same constructor,
+      then analyse one by one the corresponding pairs of arguments.
+      If they are equal, rewrite one into the other. If they are
+      not, derive a contradiction from the injectiveness of the
+      constructor.
+   4. Once all the arguments have been rewritten, solve the remaining half
+      of the disjunction by reflexivity.
+
+   Eduardo Gimenez (30/3/98).
+*)
+
+let clear ids = Proofview.V82.tactic (clear ids)
+let clear_last = (onLastHyp (fun c -> (clear [destVar c])))
+
+let choose_eq eqonleft =
+  if eqonleft then
+    left_with_bindings false Misctypes.NoBindings
+  else
+    right_with_bindings false Misctypes.NoBindings
+let choose_noteq eqonleft =
+  if eqonleft then
+    right_with_bindings false Misctypes.NoBindings
+  else
+    left_with_bindings false Misctypes.NoBindings
+
+let mkBranches c1 c2 =
+  tclTHENLIST
+    [Proofview.V82.tactic (generalize [c2]);
+     Simple.elim c1;
+     intros;
+     onLastHyp Simple.case;
+     clear_last;
+     intros]
+
+let solveNoteqBranch side =
+  tclTHEN (choose_noteq side)
+    (tclTHEN introf
+      (onLastHypId (fun id -> Extratactics.discrHyp id)))
+
+(* Constructs the type {c1=c2}+{~c1=c2} *)
+
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+
+let mkDecideEqGoal eqonleft op rectype c1 c2 =
+  let equality    = mkApp(make_eq(), [|rectype; c1; c2|]) in
+  let disequality = mkApp(build_coq_not (), [|equality|]) in
+  if eqonleft then mkApp(op, [|equality; disequality |])
+  else mkApp(op, [|disequality; equality |])
+
+
+(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
+
+let idx = Id.of_string "x"
+let idy = Id.of_string "y"
+
+let mkGenDecideEqGoal rectype g =
+  let hypnames = pf_ids_of_hyps g in
+  let xname    = next_ident_away idx hypnames
+  and yname    = next_ident_away idy hypnames in
+  (mkNamedProd xname rectype
+     (mkNamedProd yname rectype
+        (mkDecideEqGoal true (build_coq_sumbool ())
+          rectype (mkVar xname) (mkVar yname))))
+
+let eqCase tac =
+  (tclTHEN intro
+  (tclTHEN (onLastHyp Equality.rewriteLR)
+  (tclTHEN clear_last
+  tac)))
+
+let diseqCase eqonleft =
+  let diseq  = Id.of_string "diseq" in
+  let absurd = Id.of_string "absurd" in
+  (tclTHEN (intro_using diseq)
+  (tclTHEN (choose_noteq eqonleft)
+  (tclTHEN  (Proofview.V82.tactic red_in_concl)
+  (tclTHEN  (intro_using absurd)
+  (tclTHEN  (Simple.apply (mkVar diseq))
+  (tclTHEN  (Extratactics.injHyp absurd)
+            (full_trivial [])))))))
+
+open Proofview.Notations
+
+(* spiwack: a small wrapper around [Hipattern]. *)
+
+let match_eqdec c =
+  try Proofview.tclUNIT (match_eqdec c)
+  with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure
+
+(* /spiwack *)
+
+let solveArg eqonleft op a1 a2 tac =
+  Proofview.Goal.enter begin fun gl ->
+  let rectype = pf_type_of gl a1 in
+  let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in
+  let subtacs =
+    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto]
+    else [diseqCase eqonleft;eqCase tac;default_auto] in
+  (tclTHENS (elim_type decide) subtacs)
+  end
+
+let solveEqBranch rectype =
+  Proofview.tclORELSE
+    begin
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) ->
+          let (mib,mip) = Global.lookup_inductive rectype in
+          let nparams   = mib.mind_nparams in
+          let getargs l = List.skipn nparams (snd (decompose_app l)) in
+          let rargs   = getargs rhs
+          and largs   = getargs lhs in
+          List.fold_right2
+            (solveArg eqonleft op) largs rargs
+            (tclTHEN (choose_eq eqonleft) intros_reflexivity)
+      end
+    end
+    begin function (e, info) -> match e with
+      | PatternMatchingFailure -> Proofview.tclZERO (UserError ("",Pp.str"Unexpected conclusion!"))
+      | e -> Proofview.tclZERO ~info e
+    end
+
+(* The tactic Decide Equality *)
+
+let hd_app c = match kind_of_term c with
+  | App (h,_) -> h
+  | _ -> c
+
+let decideGralEquality =
+  Proofview.tclORELSE
+    begin
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) ->
+        let headtyp = hd_app (pf_compute gl typ) in
+        begin match kind_of_term headtyp with
+        | Ind (mi,_) -> Proofview.tclUNIT mi
+        | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.")
+        end >>= fun rectype ->
+          (tclTHEN
+             (mkBranches c1 c2)
+             (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype)))
+      end
+    end
+    begin function (e, info) -> match e with
+      | PatternMatchingFailure ->
+          Proofview.tclZERO (UserError ("", Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}."))
+      | e -> Proofview.tclZERO ~info e
+    end
+
+let decideEqualityGoal = tclTHEN intros decideGralEquality
+
+let decideEquality rectype =
+  Proofview.Goal.enter begin fun gl ->
+  let decide = mkGenDecideEqGoal rectype gl in
+  (tclTHENS (cut decide) [default_auto;decideEqualityGoal])
+  end
+
+
+(* The tactic Compare *)
+
+let compare c1 c2 =
+  Proofview.Goal.enter begin fun gl ->
+  let rectype = pf_type_of gl c1 in
+  let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in
+  (tclTHENS (cut decide)
+            [(tclTHEN  intro
+             (tclTHEN (onLastHyp simplest_case) clear_last));
+             decideEquality rectype])
+  end
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
deleted file mode 100644
index 4a11d586..00000000
--- a/tactics/eqdecide.ml4
+++ /dev/null
@@ -1,188 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(************************************************************************)
-(*                              EqDecide                               *)
-(*   A tactic for deciding propositional equality on inductive types   *)
-(*                           by Eduardo Gimenez                        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Util
-open Names
-open Namegen
-open Term
-open Declarations
-open Tactics
-open Tacticals
-open Hiddentac
-open Equality
-open Auto
-open Pattern
-open Matching
-open Hipattern
-open Proof_type
-open Tacmach
-open Coqlib
-
-(* This file containts the implementation of the tactics ``Decide
-   Equality'' and ``Compare''. They can be used to decide the
-   propositional equality of two objects that belongs to a small
-   inductive datatype --i.e., an inductive set such that all the
-   arguments of its constructors are non-functional sets.
-
-   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
-   follows:
-   1. Eliminate x and then y.
-   2. Try discrimination to solve those goals where x and y has
-      been introduced by different constructors.
-   3. If x and y have been introduced by the same constructor,
-      then analyse one by one the corresponding pairs of arguments.
-      If they are equal, rewrite one into the other. If they are
-      not, derive a contradiction from the injectiveness of the
-      constructor.
-   4. Once all the arguments have been rewritten, solve the remaining half
-      of the disjunction by reflexivity.
-
-   Eduardo Gimenez (30/3/98).
-*)
-
-let clear_last = (onLastHyp (fun c -> (clear [destVar c])))
-
-let choose_eq eqonleft =
-  if eqonleft then h_simplest_left else h_simplest_right
-let choose_noteq eqonleft =
-  if eqonleft then h_simplest_right else h_simplest_left
-
-let mkBranches c1 c2 =
-  tclTHENSEQ
-    [generalize [c2];
-     h_simplest_elim c1;
-     intros;
-     onLastHyp h_simplest_case;
-     clear_last;
-     intros]
-
-let solveNoteqBranch side =
-  tclTHEN (choose_noteq side)
-    (tclTHEN introf
-      (onLastHypId (fun id -> Extratactics.h_discrHyp id)))
-
-let h_solveNoteqBranch side =
-  Refiner.abstract_extended_tactic "solveNoteqBranch" []
-    (solveNoteqBranch side)
-
-(* Constructs the type {c1=c2}+{~c1=c2} *)
-
-let mkDecideEqGoal eqonleft op rectype c1 c2 g =
-  let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
-  let disequality = mkApp(build_coq_not (), [|equality|]) in
-  if eqonleft then mkApp(op, [|equality; disequality |])
-  else mkApp(op, [|disequality; equality |])
-
-
-(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
-
-let mkGenDecideEqGoal rectype g =
-  let hypnames = pf_ids_of_hyps g in
-  let xname    = next_ident_away (id_of_string "x") hypnames
-  and yname    = next_ident_away (id_of_string "y") hypnames in
-  (mkNamedProd xname rectype
-     (mkNamedProd yname rectype
-        (mkDecideEqGoal true (build_coq_sumbool ())
-          rectype (mkVar xname) (mkVar yname) g)))
-
-let eqCase tac =
-  (tclTHEN intro
-  (tclTHEN (onLastHyp Equality.rewriteLR)
-  (tclTHEN clear_last
-  tac)))
-
-let diseqCase eqonleft =
-  let diseq  = id_of_string "diseq" in
-  let absurd = id_of_string "absurd" in
-  (tclTHEN (intro_using diseq)
-  (tclTHEN (choose_noteq eqonleft)
-  (tclTHEN  red_in_concl
-  (tclTHEN  (intro_using absurd)
-  (tclTHEN  (h_simplest_apply (mkVar diseq))
-  (tclTHEN  (Extratactics.h_injHyp absurd)
-            (full_trivial [])))))))
-
-let solveArg eqonleft op a1 a2 tac g =
-  let rectype = pf_type_of g a1 in
-  let decide  = mkDecideEqGoal eqonleft op rectype a1 a2 g in
-  let subtacs =
-    if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto]
-    else [diseqCase eqonleft;eqCase tac;default_auto] in
-  (tclTHENS (h_elim_type decide) subtacs) g
-
-let solveEqBranch rectype g =
-  try
-    let (eqonleft,op,lhs,rhs,_) = match_eqdec (pf_concl g) in
-    let (mib,mip) = Global.lookup_inductive rectype in
-    let nparams   = mib.mind_nparams in
-    let getargs l = list_skipn nparams (snd (decompose_app l)) in
-    let rargs   = getargs rhs
-    and largs   = getargs lhs in
-    List.fold_right2
-      (solveArg eqonleft op) largs rargs
-      (tclTHEN (choose_eq eqonleft) h_reflexivity) g
-  with PatternMatchingFailure -> error "Unexpected conclusion!"
-
-(* The tactic Decide Equality *)
-
-let hd_app c = match kind_of_term c with
-  | App (h,_) -> h
-  | _ -> c
-
-let decideGralEquality g =
-  try
-    let eqonleft,_,c1,c2,typ = match_eqdec (pf_concl g) in
-    let headtyp = hd_app (pf_compute g typ) in
-    let rectype =
-      match kind_of_term headtyp with
-        | Ind mi -> mi
-	| _ -> error"This decision procedure only works for inductive objects."
-    in
-    (tclTHEN
-      (mkBranches c1 c2)
-      (tclORELSE (h_solveNoteqBranch eqonleft) (solveEqBranch rectype)))
-    g
-  with PatternMatchingFailure ->
-    error "The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}."
-
-let decideEqualityGoal = tclTHEN intros decideGralEquality
-
-let decideEquality rectype g =
-  let decide  = mkGenDecideEqGoal rectype g in
-  (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g
-
-
-(* The tactic Compare *)
-
-let compare c1 c2 g =
-  let rectype = pf_type_of g c1 in
-  let decide  = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in
-  (tclTHENS (cut decide)
-            [(tclTHEN  intro
-             (tclTHEN (onLastHyp simplest_case)
-                       clear_last));
-             decideEquality (pf_type_of g c1)]) g
-
-
-(* User syntax *)
-
-TACTIC EXTEND decide_equality
-| [ "decide" "equality" ] -> [ decideEqualityGoal ]
-END
-
-TACTIC EXTEND compare
-| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
-END
diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli
new file mode 100644
index 00000000..864160f6
--- /dev/null
+++ b/tactics/eqdecide.mli
@@ -0,0 +1,17 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+val decideEqualityGoal : unit Proofview.tactic
+
+val compare : Constr.t -> Constr.t -> unit Proofview.tactic
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 5a8d537e..8643fe10 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.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        *)
@@ -44,9 +44,12 @@
    natural expectation of the user.
 *)
 
+open Errors
 open Util
 open Names
 open Term
+open Vars
+open Context
 open Declarations
 open Environ
 open Inductive
@@ -56,16 +59,18 @@ open Inductiveops
 open Ind_tables
 open Indrec
 
-let hid = id_of_string "H"
-let xid = id_of_string "X"
+let hid = Id.of_string "H"
+let xid = Id.of_string "X"
 let default_id_of_sort = function InProp | InSet -> hid | InType -> xid
 let fresh env id = next_global_ident_away id []
+let with_context_set ctx (b, ctx') = 
+  (b, Univ.ContextSet.union ctx ctx')
 
 let build_dependent_inductive ind (mib,mip) =
-  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
-    (mkInd ind,
-       extended_rel_list mip.mind_nrealargs_ctxt mib.mind_params_ctxt
+    (mkIndU ind,
+       extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt
        @ extended_rel_list 0 realargs)
 
 let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s
@@ -73,12 +78,13 @@ let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s
 let my_it_mkLambda_or_LetIn_name s c =
   it_mkLambda_or_LetIn_name (Global.env()) c s
 
-let get_coq_eq () =
+let get_coq_eq ctx =
   try
-    let eq = Libnames.destIndRef Coqlib.glob_eq in
-    let _ = Global.lookup_inductive eq in
+    let eq = Globnames.destIndRef Coqlib.glob_eq in
     (* Do not force the lazy if they are not defined *)
-    mkInd eq, Coqlib.build_coq_eq_refl ()
+    let eq, ctx = with_context_set ctx 
+      (Universes.fresh_inductive_instance (Global.env ()) eq) in
+      mkIndU eq, mkConstructUi (eq,1), ctx
   with Not_found ->
     error "eq not found."
 
@@ -91,27 +97,30 @@ let get_coq_eq () =
 (* in which case, a symmetry lemma is definable                       *)
 (**********************************************************************)
 
-let get_sym_eq_data env ind =
+let get_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) ||
+    not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments"; (* This can be relaxed... *)
-  let params,constrargs = list_chop mib.mind_nparams constrargs in
+  let params,constrargs = List.chop mib.mind_nparams constrargs in
   if mip.mind_nrealargs > mib.mind_nparams then
     error "Constructors arguments must repeat the parameters.";
-  let _,params2 = list_chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let _,params2 = List.chop (mib.mind_nparams-mip.mind_nrealargs) params in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
   let paramsctxt1,_ =
-    list_chop (mib.mind_nparams-mip.mind_nrealargs) mib.mind_params_ctxt in
-  if not (list_equal eq_constr params2 constrargs) then
+    List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in
+  if not (List.equal eq_constr params2 constrargs) then
     error "Constructors arguments must repeat the parameters.";
   (* nrealargs_ctxt and nrealargs are the same here *)
-  (specif,mip.mind_nrealargs,realsign,mib.mind_params_ctxt,paramsctxt1)
+  (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1)
 
 (**********************************************************************)
 (* Check if an inductive type [ind] has the form                      *)
@@ -123,19 +132,23 @@ let get_sym_eq_data env ind =
 (* such that symmetry is a priori definable                           *)
 (**********************************************************************)
 
-let get_non_sym_eq_data env ind =
+let get_non_sym_eq_data env (ind,u) =
   let (mib,mip as specif) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) ||
+    not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported";
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then
     error "Constructor must have no arguments";
-  let _,constrargs = list_chop mib.mind_nparams constrargs in
-  (specif,constrargs,realsign,mip.mind_nrealargs)
+  let _,constrargs = List.chop mib.mind_nparams constrargs in
+  let constrargs = List.map (Vars.subst_instance_constr u) constrargs in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
+  (specif,constrargs,realsign,paramsctxt,mip.mind_nrealargs)
 
 (**********************************************************************)
 (* Build the symmetry lemma associated to an inductive type           *)
@@ -152,30 +165,35 @@ let get_non_sym_eq_data env ind =
 (**********************************************************************)
 
 let build_sym_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkCase (ci,
      my_it_mkLambda_or_LetIn_name
        (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (mkInd ind,Array.concat
+       (mkApp (mkIndU indu,Array.concat
 	  [extended_rel_vect (3*nrealargs+2) paramsctxt1;
 	   rel_vect 1 nrealargs;
 	   rel_vect (2*nrealargs+2) nrealargs])),
      mkRel 1 (* varH *),
        [|cstr (nrealargs+1)|]))))
+  in c, Evd.evar_universe_context_of ctx
 
 let sym_scheme_kind =
   declare_individual_scheme_object "_sym_internal"
-  (fun ind -> build_sym_scheme (Global.env() (* side-effect! *)) ind)
+  (fun ind -> 
+    let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in
+      (c, ctx), Declareops.no_seff)
 
 (**********************************************************************)
 (* Build the involutivity of symmetry for an inductive type           *)
@@ -193,49 +211,59 @@ let sym_scheme_kind =
 (*                                                                    *)
 (**********************************************************************)
 
+let const_of_scheme kind env ind ctx = 
+  let sym_scheme, eff = (find_scheme kind ind) in
+  let sym, ctx = with_context_set ctx 
+    (Universes.fresh_constant_instance (Global.env()) sym_scheme) in
+    mkConstU sym, ctx, eff
+
 let build_sym_involutive_scheme env ind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let sym = mkConst (find_scheme sym_scheme_kind ind) in
-  let (eq,eqrefl) = get_coq_eq () in
-  let cstr n = mkApp (mkConstruct(ind,1),extended_rel_vect n paramsctxt) in
+    get_sym_eq_data env indu in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let applied_ind = build_dependent_inductive ind specif in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_C =
     mkApp
-      (mkInd ind, Array.append
+      (mkIndU indu, Array.append
          (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt)
          (rel_vect (nrealargs+1) nrealargs)) in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  (my_it_mkLambda_or_LetIn paramsctxt
-  (my_it_mkLambda_or_LetIn_name realsign_ind
-  (mkCase (ci,
-     my_it_mkLambda_or_LetIn_name
-       (lift_rel_context (nrealargs+1) realsign_ind)
-       (mkApp (eq,[|
-	 mkApp
-	   (mkInd ind, Array.concat
-	     [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	      rel_vect (2*nrealargs+2) nrealargs;
-	      rel_vect 1 nrealargs]);
-         mkApp (sym,Array.concat
-	   [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-            rel_vect 1 nrealargs;
-            rel_vect (2*nrealargs+2) nrealargs;
-            [|mkApp (sym,Array.concat
-	      [extended_rel_vect (3*nrealargs+2) paramsctxt1;
-	       rel_vect (2*nrealargs+2) nrealargs;
-	       rel_vect 1 nrealargs;
-	       [|mkRel 1|]])|]]);
-	 mkRel 1|])),
-     mkRel 1 (* varH *),
-       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+  let c = 
+    (my_it_mkLambda_or_LetIn paramsctxt
+     (my_it_mkLambda_or_LetIn_name realsign_ind
+      (mkCase (ci,
+	       my_it_mkLambda_or_LetIn_name
+	       (lift_rel_context (nrealargs+1) realsign_ind)
+	       (mkApp (eq,[|
+	       mkApp
+	       (mkIndU indu, Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect (2*nrealargs+2) nrealargs;
+		rel_vect 1 nrealargs]);
+               mkApp (sym,Array.concat
+	       [extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		rel_vect 1 nrealargs;
+		rel_vect (2*nrealargs+2) nrealargs;
+		[|mkApp (sym,Array.concat
+		[extended_rel_vect (3*nrealargs+2) paramsctxt1;
+		 rel_vect (2*nrealargs+2) nrealargs;
+		 rel_vect 1 nrealargs;
+		 [|mkRel 1|]])|]]);
+	       mkRel 1|])),
+	       mkRel 1 (* varH *),
+	       [|mkApp(eqrefl,[|applied_ind_C;cstr (nrealargs+1)|])|]))))
+  in (c, Evd.evar_universe_context_of ctx), eff
 
 let sym_involutive_scheme_kind =
   declare_individual_scheme_object "_sym_involutive"
-  (fun ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
+  (fun ind -> 
+    build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind)
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for conclusion associated  *)
@@ -298,26 +326,27 @@ let sym_involutive_scheme_kind =
 (**********************************************************************)
 
 let build_l2r_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
-  let sym = mkConst (find_scheme sym_scheme_kind ind) in
-  let sym_involutive = mkConst (find_scheme sym_involutive_scheme_kind ind) in
-  let (eq,eqrefl) = get_coq_eq () in
+    get_sym_eq_data env indu in
+  let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in
+  let sym_involutive, ctx, eff' = const_of_scheme sym_involutive_scheme_kind env ind ctx in
+  let eq,eqrefl,ctx = get_coq_eq ctx in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect nrealargs nrealargs]) in
   let applied_ind_G =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+3) paramsctxt1;
         rel_vect (nrealargs+3) nrealargs;
         rel_vect 0 nrealargs]) in
@@ -336,9 +365,11 @@ let build_l2r_rew_scheme dep env ind kind =
                      rel_vect (nrealargs+4) nrealargs;
                      rel_vect 1 nrealargs;
 		     [|mkRel 1|]]) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  let cieq = make_case_info (Global.env()) (destInd eq) RegularStyle in
+  let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign)
            (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in
@@ -363,6 +394,7 @@ let build_l2r_rew_scheme dep env ind kind =
       my_it_mkLambda_or_LetIn_name realsign_ind_G applied_PG,
       applied_sym_C 3,
       [|mkVar varHC|]) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varP
@@ -380,6 +412,7 @@ let build_l2r_rew_scheme dep env ind kind =
        [|main_body|])
    else
      main_body))))))
+  in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff
 
 (**********************************************************************)
 (* Build the left-to-right rewriting lemma for hypotheses associated  *)
@@ -408,23 +441,24 @@ let build_l2r_rew_scheme dep env ind kind =
 (**********************************************************************)
 
 let build_l2r_forward_rew_scheme dep env ind kind =
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
   let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 =
-    get_sym_eq_data env ind in
+    get_sym_eq_data env indu in
   let cstr n p =
-    mkApp (mkConstruct(ind,1),
+    mkApp (mkConstructUi(indu,1),
       Array.concat [extended_rel_vect n paramsctxt1;
                     rel_vect p nrealargs]) in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let applied_ind_P =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (4*nrealargs+2) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (nrealargs+1) nrealargs]) in
   let applied_ind_P' =
-    mkApp (mkInd ind, Array.concat
+    mkApp (mkIndU indu, Array.concat
        [extended_rel_vect (3*nrealargs+1) paramsctxt1;
         rel_vect 0 nrealargs;
         rel_vect (2*nrealargs+1) nrealargs]) in
@@ -433,7 +467,9 @@ let build_l2r_forward_rew_scheme dep env ind kind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
   let realsign_ind_P n aP =
     name_context env ((Name varH,None,aP)::realsign_P n) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     mkApp (mkVar varP,Array.append
@@ -447,6 +483,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
   let applied_PG =
     mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs)
            (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in
+  let c = 
   (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
   (my_it_mkLambda_or_LetIn_name realsign
   (mkNamedLambda varH applied_ind
@@ -463,6 +500,7 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 	  (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s)
       (mkNamedLambda varHC applied_PC'
 	(mkVar varHC))|])))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* Build the right-to-left rewriting lemma for hypotheses associated  *)
@@ -494,19 +532,22 @@ let build_l2r_forward_rew_scheme dep env ind kind =
 (* statement but no need for symmetry of the equality.                *)
 (**********************************************************************)
 
-let build_r2l_forward_rew_scheme dep env ind kind =
-  let ((mib,mip as specif),constrargs,realsign,nrealargs) =
-    get_non_sym_eq_data env ind in
+let build_r2l_forward_rew_scheme dep env ind kind = 
+  let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in
+  let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) =
+    get_non_sym_eq_data env indu in
   let cstr n =
-    mkApp (mkConstruct(ind,1),extended_rel_vect n mib.mind_params_ctxt) in
+    mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in
   let constrargs_cstr = constrargs@[cstr 0] in
   let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in
-  let varHC = fresh env (id_of_string "HC") in
-  let varP = fresh env (id_of_string "P") in
-  let applied_ind = build_dependent_inductive ind specif in
+  let varHC = fresh env (Id.of_string "HC") in
+  let varP = fresh env (Id.of_string "P") in
+  let applied_ind = build_dependent_inductive indu specif in
   let realsign_ind =
     name_context env ((Name varH,None,applied_ind)::realsign) in
-  let s = mkSort (new_sort_in_family kind) in
+  let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in
+  let ctx = Univ.ContextSet.union ctx ctx' in
+  let s = mkSort s in
   let ci = make_case_info (Global.env()) ind RegularStyle in
   let applied_PC =
     applist (mkVar varP,if dep then constrargs_cstr else constrargs) in
@@ -514,7 +555,8 @@ let build_r2l_forward_rew_scheme dep env ind kind =
     mkApp (mkVar varP,
            if dep then extended_rel_vect 0 realsign_ind
 	   else extended_rel_vect 1 realsign) in
-  (my_it_mkLambda_or_LetIn mib.mind_params_ctxt
+  let c = 
+  (my_it_mkLambda_or_LetIn paramsctxt
   (my_it_mkLambda_or_LetIn_name realsign_ind
   (mkNamedLambda varP
     (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1)
@@ -531,6 +573,7 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 	   lift (nrealargs+3) applied_PC,
 	   mkRel 1)|]),
     [|mkVar varHC|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 (**********************************************************************)
 (* This function "repairs" the non-dependent r2l forward rewriting    *)
@@ -548,11 +591,12 @@ let build_r2l_forward_rew_scheme dep env ind kind =
 (*                                                                    *)
 (**********************************************************************)
 
-let fix_r2l_forward_rew_scheme c =
+let fix_r2l_forward_rew_scheme (c, ctx') =
   let t = Retyping.get_type_of (Global.env()) Evd.empty c in
   let ctx,_ = decompose_prod_assum t in
   match ctx with
   | hp :: p :: ind :: indargs ->
+     let c' = 
       my_it_mkLambda_or_LetIn indargs
 	(mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p)
 	  (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp)
@@ -560,7 +604,8 @@ let fix_r2l_forward_rew_scheme c =
 	      (Reductionops.whd_beta Evd.empty
 		(applist (c,
 	          extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))
-  | _ -> anomaly "Ill-formed non-dependent left-to-right rewriting scheme"
+      in c', ctx'
+  | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme")
 
 (**********************************************************************)
 (* Build the right-to-left rewriting lemma for conclusion associated  *)
@@ -582,9 +627,16 @@ let fix_r2l_forward_rew_scheme c =
 (*          (H:I q1..qm a1..an),                                      *)
 (*          P b1..bn C -> P a1..an H                                  *)
 (**********************************************************************)
-
+ 
 let build_r2l_rew_scheme dep env ind k =
-  build_case_analysis_scheme env Evd.empty ind dep k
+  let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in
+  let sigma', c = build_case_analysis_scheme env sigma indu dep k in
+    c, Evd.evar_universe_context sigma'
+
+let build_l2r_rew_scheme = build_l2r_rew_scheme
+let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme
+let build_r2l_rew_scheme = build_r2l_rew_scheme
+let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme
 
 (**********************************************************************)
 (* Register the rewriting schemes                                     *)
@@ -608,7 +660,7 @@ let rew_l2r_dep_scheme_kind =
 (**********************************************************************)
 let rew_r2l_dep_scheme_kind =
   declare_individual_scheme_object "_rew_dep"
-  (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Dependent rewrite from right-to-left in hypotheses                 *)
@@ -618,7 +670,7 @@ let rew_r2l_dep_scheme_kind =
 (**********************************************************************)
 let rew_r2l_forward_dep_scheme_kind =
   declare_individual_scheme_object "_rew_fwd_dep"
-  (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Dependent rewrite from left-to-right in hypotheses                 *)
@@ -628,7 +680,7 @@ let rew_r2l_forward_dep_scheme_kind =
 (**********************************************************************)
 let rew_l2r_forward_dep_scheme_kind =
   declare_individual_scheme_object "_rew_fwd_r_dep"
-  (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType)
+  (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff)
 
 (**********************************************************************)
 (* Non-dependent rewrite from either left-to-right in conclusion or   *)
@@ -642,7 +694,7 @@ let rew_l2r_forward_dep_scheme_kind =
 let rew_l2r_scheme_kind =
   declare_individual_scheme_object "_rew_r"
   (fun ind -> fix_r2l_forward_rew_scheme
-      (build_r2l_forward_rew_scheme false (Global.env()) ind InType))
+     (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff)
 
 (**********************************************************************)
 (* Non-dependent rewrite from either right-to-left in conclusion or   *)
@@ -652,7 +704,7 @@ let rew_l2r_scheme_kind =
 (**********************************************************************)
 let rew_r2l_scheme_kind =
   declare_individual_scheme_object "_rew"
-  (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType)
+  (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff)
 
 (* End of rewriting schemes *)
 
@@ -671,35 +723,41 @@ let rew_r2l_scheme_kind =
 
 (* TODO: extend it to types with more than one index *)
 
-let build_congr env (eq,refl) ind =
+let build_congr env (eq,refl,ctx) ind =
+  let (ind,u as indu), ctx = with_context_set ctx 
+    (Universes.fresh_inductive_instance env ind) in
   let (mib,mip) = lookup_mind_specif env ind in
-  if Array.length mib.mind_packets <> 1 or Array.length mip.mind_nf_lc <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then
     error "Not an inductive type with a single constructor.";
-  if mip.mind_nrealargs <> 1 then
+  if not (Int.equal mip.mind_nrealargs 1) then
     error "Expect an inductive type with one predicate parameter.";
   let i = 1 in
-  let realsign,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in
-  if List.exists (fun (_,b,_) -> b <> None) realsign then
+  let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in
+  let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in
+  let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in
+  if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then
     error "Inductive equalities with local definitions in arity not supported.";
-  let env_with_arity = push_rel_context mip.mind_arity_ctxt env in
+  let env_with_arity = push_rel_context arityctxt env in
   let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in
   let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in
   let _,constrargs = decompose_app ccl in
-  if rel_context_length constrsign<>rel_context_length mib.mind_params_ctxt then
+  if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then
     error "Constructor must have no arguments";
   let b = List.nth constrargs (i + mib.mind_nparams - 1) in
-  let varB = fresh env (id_of_string "B") in
-  let varH = fresh env (id_of_string "H") in
-  let varf = fresh env (id_of_string "f") in
+  let varB = fresh env (Id.of_string "B") in
+  let varH = fresh env (Id.of_string "H") in
+  let varf = fresh env (Id.of_string "f") in
   let ci = make_case_info (Global.env()) ind RegularStyle in
-  my_it_mkLambda_or_LetIn mib.mind_params_ctxt
-     (mkNamedLambda varB (new_Type ())
+  let uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in
+  let c = 
+  my_it_mkLambda_or_LetIn paramsctxt
+     (mkNamedLambda varB (mkSort (Type uni))
      (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB))
      (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign)
      (mkNamedLambda varH
         (applist
-           (mkInd ind,
-	    extended_rel_list (mip.mind_nrealargs+2) mib.mind_params_ctxt @
+           (mkIndU indu,
+	    extended_rel_list (mip.mind_nrealargs+2) paramsctxt @
 	    extended_rel_list 0 realsign))
      (mkCase (ci,
        my_it_mkLambda_or_LetIn_name
@@ -707,20 +765,21 @@ let build_congr env (eq,refl) ind =
          (mkLambda
            (Anonymous,
             applist
-             (mkInd ind,
-	        extended_rel_list (2*mip.mind_nrealargs_ctxt+3)
-		  mib.mind_params_ctxt
+             (mkIndU indu,
+	        extended_rel_list (2*mip.mind_nrealdecls+3)
+		  paramsctxt
 	        @ extended_rel_list 0 realsign),
             mkApp (eq,
 	      [|mkVar varB;
-                mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+4) b|]);
+                mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]);
 		mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))),
        mkVar varH,
        [|mkApp (refl,
           [|mkVar varB;
 	    mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) b|])|])|]))))))
+  in c, Evd.evar_universe_context_of ctx
 
 let congr_scheme_kind = declare_individual_scheme_object "_congr"
   (fun ind ->
     (* May fail if equality is not defined *)
-    build_congr (Global.env()) (get_coq_eq ()) ind)
+    build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff)
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index 2f973e6d..6bb84808 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.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        *)
@@ -22,22 +22,26 @@ val rew_l2r_forward_dep_scheme_kind : individual scheme_kind
 val rew_r2l_dep_scheme_kind : individual scheme_kind
 val rew_r2l_scheme_kind : individual scheme_kind
 
-val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
-val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> constr
+val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context
+val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val build_r2l_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 val build_l2r_forward_rew_scheme :
-  bool -> env -> inductive -> sorts_family -> constr
+  bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context
 
 (** Builds a symmetry scheme for a symmetrical equality type *)
 
-val build_sym_scheme : env -> inductive -> constr
+val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context
 val sym_scheme_kind : individual scheme_kind
 
-val build_sym_involutive_scheme : env -> inductive -> constr
+val build_sym_involutive_scheme : env -> inductive -> 
+  constr Evd.in_evar_universe_context * Declareops.side_effects
 val sym_involutive_scheme_kind : individual scheme_kind
 
 (** Builds a congruence scheme for an equality type *)
 
 val congr_scheme_kind : individual scheme_kind
-val build_congr : env -> constr * constr -> inductive -> constr
+val build_congr : env -> constr * constr * Univ.universe_context_set -> inductive -> 
+  constr Evd.in_evar_universe_context
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 184f98ca..c130fa15 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -1,49 +1,47 @@
 (************************************************************************)
 (*  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
 open Nameops
-open Univ
 open Term
+open Vars
 open Termops
 open Namegen
 open Inductive
 open Inductiveops
 open Environ
 open Libnames
+open Globnames
 open Reductionops
-open Typeops
 open Typing
 open Retyping
-open Tacmach
-open Proof_type
+open Tacmach.New
 open Logic
-open Evar_refiner
-open Pattern
-open Matching
 open Hipattern
 open Tacexpr
-open Tacticals
+open Tacticals.New
 open Tactics
 open Tacred
-open Glob_term
 open Coqlib
-open Vernacexpr
 open Declarations
 open Indrec
-open Printer
 open Clenv
-open Clenvtac
 open Evd
 open Ind_tables
 open Eqschemes
+open Locus
+open Locusops
+open Misctypes
+open Proofview.Notations
+open Unification
 
 (* Options *)
 
@@ -62,8 +60,28 @@ let _ =
       optread  = (fun () -> !discriminate_introduction);
       optwrite = (:=) discriminate_introduction }
 
+let injection_pattern_l2r_order = ref true
+
+let use_injection_pattern_l2r_order () =
+  !injection_pattern_l2r_order
+  && Flags.version_strictly_greater Flags.V8_4
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "injection left-to-right pattern order";
+      optkey   = ["Injection";"L2R";"Pattern";"Order"];
+      optread  = (fun () -> !injection_pattern_l2r_order) ;
+      optwrite = (fun b -> injection_pattern_l2r_order := b) }
+
 (* Rewriting tactics *)
 
+let clear ids = Proofview.V82.tactic (clear ids)
+
+let tclNOTSAMEGOAL tac =
+  Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac))
+
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
 type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
 
@@ -82,35 +100,44 @@ type conditions =
    -- Eduardo (19/8/97)
 *)
 
+let rewrite_core_unif_flags = {
+  modulo_conv_on_closed_terms = None;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = empty_transparent_state;
+  check_applied_meta_types = true;
+  use_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
+  frozen_evars = Evar.Set.empty;
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = true;
+}
+
 let rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.modulo_delta_types = empty_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = true;
-  Unification.use_pattern_unification = true;
-  Unification.use_meta_bound_pattern_unification = true;
-  Unification.frozen_evars = ExistentialSet.empty;
-  Unification.restrict_conv_on_strict_subterms = false;
-  Unification.modulo_betaiota = false;
-  Unification.modulo_eta = true;
-  Unification.allow_K_in_toplevel_higher_order_unification = false
+  core_unify_flags = rewrite_core_unif_flags;
+  merge_unify_flags = rewrite_core_unif_flags;
+  subterm_unify_flags = rewrite_core_unif_flags;
+  allow_K_in_toplevel_higher_order_unification = false;
     (* allow_K does not matter in practice because calls w_typed_unify *)
+  resolve_evars = true
 }
 
 let freeze_initial_evars sigma flags clause =
   (* We take evars of the type: this may include old evars! For excluding *)
   (* all old evars, including the ones occurring in the rewriting lemma, *)
   (* we would have to take the clenv_value *)
-  let newevars = Evd.collect_evars (clenv_type clause) in
+  let newevars = Evd.evars_of_term (clenv_type clause) in
   let evars =
     fold_undefined (fun evk _ evars ->
-      if ExistentialSet.mem evk newevars then evars
-      else ExistentialSet.add evk evars)
-      sigma ExistentialSet.empty in
-  { flags with Unification.frozen_evars = evars }
+      if Evar.Set.mem evk newevars then evars
+      else Evar.Set.add evk evars)
+      sigma Evar.Set.empty in
+  {flags with
+    core_unify_flags = {flags.core_unify_flags with frozen_evars = evars};
+    merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars};
+    subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}}
 
 let make_flags frzevars sigma flags clause =
   if frzevars then freeze_initial_evars sigma flags clause else flags
@@ -118,89 +145,91 @@ let make_flags frzevars sigma flags clause =
 let side_tac tac sidetac =
   match sidetac with
   | None -> tac
-  | Some sidetac -> tclTHENSFIRSTn tac [|tclIDTAC|] sidetac
-
-let instantiate_lemma_all frzevars env sigma gl c ty l l2r concl =
-  let eqclause = Clenv.make_clenv_binding { gl with sigma = sigma } (c,ty) l in
-  let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
-  let rec split_last_two = function
-      | [c1;c2] -> [],(c1, c2)
-      | x::y::z ->
-	  let l,res = split_last_two (y::z) in x::l, res
-      | _ -> error "The term provided is not an applied relation." in
-  let others,(c1,c2) = split_last_two args in
+  | Some sidetac -> tclTHENSFIRSTn tac [|Proofview.tclUNIT ()|] sidetac
+
+let instantiate_lemma_all frzevars gl c ty l l2r concl =
+  let env = Proofview.Goal.env gl in
+  let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in
+  let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in
+  let arglen = Array.length args in
+  let () = if arglen < 2 then error "The term provided is not an applied relation." in
+  let c1 = args.(arglen - 2) in
+  let c2 = args.(arglen - 1) in
   let try_occ (evd', c') =
-    clenv_pose_dependent_evars true {eqclause with evd = evd'}
+    Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'}
   in
-  let flags = make_flags frzevars sigma rewrite_unif_flags eqclause in
+  let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_unif_flags eqclause in
   let occs =
-    Unification.w_unify_to_subterm_all ~flags env eqclause.evd
+    w_unify_to_subterm_all ~flags env eqclause.evd
       ((if l2r then c1 else c2),concl)
   in List.map try_occ occs
 
-let instantiate_lemma env sigma gl c ty l l2r concl =
-  let gl = { gl with sigma = sigma } in
+let instantiate_lemma gl c ty l l2r concl =
   let ct = pf_type_of gl c in
   let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
-  let eqclause = Clenv.make_clenv_binding gl (c,t) l in
+  let eqclause = pf_apply Clenv.make_clenv_binding gl (c,t) l in
    [eqclause]
 
-let rewrite_conv_closed_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = Some full_transparent_state;
+let rewrite_conv_closed_core_unif_flags = {
+  modulo_conv_on_closed_terms = Some full_transparent_state;
     (* We have this flag for historical reasons, it has e.g. the consequence *)
     (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *)
 
-  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_metas_eagerly_in_conv_on_closed_terms = true;
+  use_evars_eagerly_in_conv_on_closed_terms = false;
     (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *)
     (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *)
 
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.modulo_delta_types = full_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = false;
-  Unification.use_pattern_unification = true;
+  modulo_delta = empty_transparent_state;
+  modulo_delta_types = full_transparent_state;
+  check_applied_meta_types = true;
+  use_pattern_unification = true;
     (* To rewrite "?n x y" in "y+x=0" when ?n is *)
     (* a preexisting evar of the goal*)
 
-  Unification.use_meta_bound_pattern_unification = true;
+  use_meta_bound_pattern_unification = true;
 
-  Unification.frozen_evars = ExistentialSet.empty;
+  frozen_evars = Evar.Set.empty;
     (* This is set dynamically *)
 
-  Unification.restrict_conv_on_strict_subterms = false;
-  Unification.modulo_betaiota = false;
-  Unification.modulo_eta = true;
-  Unification.allow_K_in_toplevel_higher_order_unification = false
+  restrict_conv_on_strict_subterms = false;
+  modulo_betaiota = false;
+  modulo_eta = true;
 }
 
-let rewrite_elim with_evars frzevars c e gl =
-  let flags =
-    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
-  general_elim_clause_gen (elimination_clause_scheme with_evars ~flags) c e gl
+let rewrite_conv_closed_unif_flags = {
+  core_unify_flags = rewrite_conv_closed_core_unif_flags;
+  merge_unify_flags = rewrite_conv_closed_core_unif_flags;
+  subterm_unify_flags = rewrite_conv_closed_core_unif_flags;
+  allow_K_in_toplevel_higher_order_unification = false;
+  resolve_evars = false
+}
 
-let rewrite_elim_in with_evars frzevars id c e gl =
-  let flags =
-    make_flags frzevars (project gl) rewrite_conv_closed_unif_flags c in
-  general_elim_clause_gen
-    (elimination_in_clause_scheme with_evars ~flags id) c e gl
+let rewrite_elim with_evars frzevars cls c e =
+  Proofview.Goal.enter begin fun gl ->
+  let flags = make_flags frzevars (Proofview.Goal.sigma gl) rewrite_conv_closed_unif_flags c in
+  general_elim_clause with_evars flags cls c e
+  end
 
 (* Ad hoc asymmetric general_elim_clause *)
 let general_elim_clause with_evars frzevars cls rew elim =
-  try
-    (match cls with
-      | None ->
-	  (* was tclWEAK_PROGRESS which only fails for tactics generating one
-             subgoal and did not fail for useless conditional rewritings generating
-             an extra condition *)
-	  tclNOTSAMEGOAL (rewrite_elim with_evars frzevars rew elim)
-      | Some id -> rewrite_elim_in with_evars frzevars id rew elim)
-  with Pretype_errors.PretypeError (env,evd,
-				    Pretype_errors.NoOccurrenceFound (c', _)) ->
-    raise (Pretype_errors.PretypeError
-	      (env,evd,Pretype_errors.NoOccurrenceFound (c', cls)))
-
-let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
+  let open Pretype_errors in
+  Proofview.tclORELSE
+    begin match cls with
+    | None ->
+      (* was tclWEAK_PROGRESS which only fails for tactics generating one
+          subgoal and did not fail for useless conditional rewritings generating
+          an extra condition *)
+      tclNOTSAMEGOAL (rewrite_elim with_evars frzevars cls rew elim)
+    | Some _ -> rewrite_elim with_evars frzevars cls rew elim
+    end
+    begin function (e, info) -> match e with
+    | PretypeError (env, evd, NoOccurrenceFound (c', _)) ->
+      Proofview.tclZERO (PretypeError (env, evd, NoOccurrenceFound (c', cls)))
+    | e -> Proofview.tclZERO ~info e
+    end
+
+let general_elim_clause with_evars frzevars tac cls c t l l2r elim =
   let all, firstonly, tac =
     match tac with
     | None -> false, false, None
@@ -208,20 +237,26 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
     | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac)
     | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac)
   in
-  let cs =
-    (if not all then instantiate_lemma else instantiate_lemma_all frzevars)
-      (pf_env gl) sigma gl c t l l2r
-      (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id)
-  in
   let try_clause c =
     side_tac
       (tclTHEN
-         (Refiner.tclEVARS c.evd)
-         (general_elim_clause with_evars frzevars cls c elim)) tac
+         (Proofview.Unsafe.tclEVARS c.evd)
+         (general_elim_clause with_evars frzevars cls c elim))
+      tac
   in
-    if firstonly then
-      tclFIRST (List.map try_clause cs) gl
-    else tclMAP try_clause cs gl
+  Proofview.Goal.enter begin fun gl ->
+    let instantiate_lemma concl =
+      if not all then instantiate_lemma gl c t l l2r concl
+      else instantiate_lemma_all frzevars gl c t l l2r concl
+    in
+    let typ = match cls with
+    | None -> pf_nf_concl gl
+    | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl)
+    in
+    let cs = instantiate_lemma typ in
+    if firstonly then tclFIRST (List.map try_clause cs)
+    else tclMAP try_clause cs
+  end
 
 (* The next function decides in particular whether to try a regular
   rewrite or a generalized rewrite.
@@ -230,11 +265,7 @@ let general_elim_clause with_evars frzevars tac cls sigma c t l l2r elim gl =
   If occurrences are set, use general rewrite.
 *)
 
-let general_rewrite_clause = ref (fun _ -> assert false)
-let register_general_rewrite_clause = (:=) general_rewrite_clause
-
-let is_applied_rewrite_relation = ref (fun _ _ _ _ -> None)
-let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation
+let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hook.make ()
 
 (* Do we have a JMeq instance on twice the same domains ? *)
 
@@ -242,46 +273,51 @@ let jmeq_same_dom gl = function
   | None -> true (* already checked in Hipattern.find_eq_data_decompose *)
   | Some t ->
     let rels, t = decompose_prod_assum t in
-    let env = Environ.push_rel_context rels (pf_env gl) in
+    let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in
     match decompose_app t with
-      | _, [dom1; _; dom2;_] -> is_conv env (project gl) dom1 dom2
+      | _, [dom1; _; dom2;_] -> is_conv env (Proofview.Goal.sigma gl) dom1 dom2
       | _ -> false
 
 (* find_elim determines which elimination principle is necessary to
    eliminate lbeq on sort_of_gl. *)
 
 let find_elim hdcncl lft2rgt dep cls ot gl =
-  let inccl = not (Option.has_some cls) in
-  let hdcncl_is u = eq_constr hdcncl (constr_of_reference u) in
-  if (hdcncl_is (Coqlib.glob_eq) ||
-      hdcncl_is (Coqlib.glob_jmeq) && jmeq_same_dom gl ot)
-     && not dep
-     || Flags.version_less_or_equal Flags.V8_2
+  let inccl = Option.is_empty cls in
+  if (is_global Coqlib.glob_eq hdcncl ||
+      (is_global Coqlib.glob_jmeq hdcncl &&
+	 jmeq_same_dom gl ot)) && not dep
+    || Flags.version_less_or_equal Flags.V8_2
   then
-    match kind_of_term hdcncl with 
-      | Ind ind_sp -> 
+    let c = 
+      match kind_of_term hdcncl with 
+      | Ind (ind_sp,u) -> 
 	let pr1 = 
 	  lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) 
-	in 
-	if lft2rgt = Some (cls=None) 
-	then
-	  let c1 = destConst pr1 in 
+	in
+        begin match lft2rgt, cls with
+        | Some true, None
+        | Some false, Some _ ->
+	  let c1 = destConstRef pr1 in 
 	  let mp,dp,l = repr_con (constant_of_kn (canonical_con c1)) in 
-	  let l' = label_of_id (add_suffix (id_of_label l) "_r")  in 
+	  let l' = Label.of_id (add_suffix (Label.to_id l) "_r")  in 
 	  let c1' = Global.constant_of_delta_kn (make_kn mp dp l') in
 	  begin 
 	    try 
 	      let _ = Global.lookup_constant c1' in
-	      mkConst c1'
+		c1'
 	    with Not_found -> 
-	      let rwr_thm = string_of_label l' in 
+	      let rwr_thm = Label.to_string l' in 
 	      error ("Cannot find rewrite principle "^rwr_thm^".")
 	  end
-	else pr1 
+	| _ -> destConstRef pr1
+        end
       | _ -> 
 	  (* cannot occur since we checked that we are in presence of 
 	     Logic.eq or Jmeq just before *)
 	assert false
+    in
+      let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+	sigma, elim, Declareops.no_seff
   else
   let scheme_name = match dep, lft2rgt, inccl with
     (* Non dependent case *)
@@ -296,31 +332,39 @@ let find_elim hdcncl lft2rgt dep cls ot gl =
     | true, _, false -> rew_r2l_forward_dep_scheme_kind
   in
   match kind_of_term hdcncl with
-  | Ind ind -> mkConst (find_scheme scheme_name ind)
+  | Ind (ind,u) -> 
+      let c, eff = find_scheme scheme_name ind in 
+      (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *)
+      let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in
+	sigma, elim, eff
   | _ -> assert false
 
-let type_of_clause gl = function
-  | None -> pf_concl gl
-  | Some id -> pf_get_hyp_typ gl id
+let type_of_clause cls gl = match cls with
+  | None -> Proofview.Goal.concl gl
+  | Some id -> pf_get_hyp_typ id gl
 
-let leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c t l with_evars frzevars dep_proof_ok gl hdcncl =
+let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl =
+  Proofview.Goal.nf_enter begin fun gl ->
   let isatomic = isProd (whd_zeta hdcncl) in
   let dep_fun = if isatomic then dependent else dependent_no_evar in
-  let dep = dep_proof_ok && dep_fun c (type_of_clause gl cls) in
-  let elim = find_elim hdcncl lft2rgt dep cls (Some t) gl in
-  general_elim_clause with_evars frzevars tac cls sigma c t l
-    (match lft2rgt with None -> false | Some b -> b)
-    {elimindex = None; elimbody = (elim,NoBindings)} gl
+  let type_of_cls = type_of_clause cls gl in
+  let dep = dep_proof_ok && dep_fun c type_of_cls in
+  let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in
+    Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS effs <*>
+      general_elim_clause with_evars frzevars tac cls c t l
+      (match lft2rgt with None -> false | Some b -> b)
+      {elimindex = None; elimbody = (elim,NoBindings); elimrename = None}
+  end
 
 let adjust_rewriting_direction args lft2rgt =
-  if List.length args = 1 then begin
+  match args with
+  | [_] ->
     (* equality to a constant, like in eq_true *)
     (* more natural to see -> as the rewriting to the constant *)
     if not lft2rgt then
       error "Rewriting non-symmetric equality not allowed from right-to-left.";
     None
-  end
-  else
+  | _ ->
     (* other equality *)
     Some lft2rgt
 
@@ -329,34 +373,39 @@ let rewrite_side_tac tac sidetac = side_tac tac (Option.map fst sidetac)
 (* Main function for dispatching which kind of rewriting it is about *)
 
 let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac
-    ((c,l) : constr with_bindings) with_evars gl =
-  if occs <> all_occurrences then (
-    rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl)
+    ((c,l) : constr with_bindings) with_evars =
+  if occs != AllOccurrences then (
+    rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac)
   else
-    let env = pf_env gl in
-    let sigma = project gl in
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
     let ctype = get_type_of env sigma c in
     let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in
       match match_with_equality_type t with
       | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *)
 	  let lft2rgt = adjust_rewriting_direction args lft2rgt in
-          leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c (it_mkProd_or_LetIn t rels)
-	    l with_evars frzevars dep_proof_ok gl hdcncl
+          leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels)
+	    l with_evars frzevars dep_proof_ok hdcncl
       | None ->
-	  try
-	    rewrite_side_tac (!general_rewrite_clause cls
-				 lft2rgt occs (c,l) ~new_goals:[]) tac gl
-	  with e when Errors.noncritical e ->
-            (* Try to see if there's an equality hidden *)
-	    let env' = push_rel_context rels env in
-	    let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
-	      match match_with_equality_type t' with
-	      | Some (hdcncl,args) ->
+	  Proofview.tclORELSE
+            begin
+	      rewrite_side_tac (Hook.get forward_general_setoid_rewrite_clause cls
+				   lft2rgt occs (c,l) ~new_goals:[]) tac
+            end
+            begin function
+              | (e, info) ->
+	          let env' = push_rel_context rels env in
+	          let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *)
+	          match match_with_equality_type t' with
+	            | Some (hdcncl,args) ->
 		  let lft2rgt = adjust_rewriting_direction args lft2rgt in
-		    leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c
-		      (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok gl hdcncl
-	      | None -> raise e
-		  (* error "The provided term does not end with an equality or a declared rewrite relation." *)
+		  leibniz_rewrite_ebindings_clause cls lft2rgt tac c
+		    (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl
+	            | None -> Proofview.tclZERO ~info e
+            (* error "The provided term does not end with an equality or a declared rewrite relation." *)  
+            end
+    end
 
 let general_rewrite_ebindings =
   general_rewrite_ebindings_clause None
@@ -380,8 +429,8 @@ let general_rewrite_in l2r occs frzevars dep_proof_ok ?tac id c =
   general_rewrite_ebindings_clause (Some id) l2r occs
     frzevars dep_proof_ok ?tac (c,NoBindings)
 
-let general_multi_rewrite l2r with_evars ?tac c cl =
-  let occs_of = on_snd (List.fold_left
+let general_rewrite_clause l2r with_evars ?tac c cl =
+  let occs_of = occurrences_map (List.fold_left
     (fun acc ->
       function ArgArg x -> x :: acc | ArgVar _ -> acc)
     [])
@@ -391,108 +440,163 @@ let general_multi_rewrite l2r with_evars ?tac c cl =
 	(* If a precise list of locations is given, success is mandatory for
 	   each of these locations. *)
 	let rec do_hyps = function
-	  | [] -> tclIDTAC
+	  | [] -> Proofview.tclUNIT ()
 	  | ((occs,id),_) :: l ->
 	    tclTHENFIRST
 	      (general_rewrite_ebindings_in l2r (occs_of occs) false true ?tac id c with_evars)
 	      (do_hyps l)
 	in
-	if cl.concl_occs = no_occurrences_expr then do_hyps l else
+	if cl.concl_occs == NoOccurrences then do_hyps l else
 	  tclTHENFIRST
-	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
-	   (do_hyps l)
+	    (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
+            (do_hyps l)
     | None ->
 	(* Otherwise, if we are told to rewrite in all hypothesis via the
            syntax "* |-", we fail iff all the different rewrites fail *)
 	let rec do_hyps_atleastonce = function
-	  | [] -> (fun gl -> error "Nothing to rewrite.")
+	  | [] -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Nothing to rewrite."))
 	  | id :: l ->
 	    tclIFTHENTRYELSEMUST
-	     (general_rewrite_ebindings_in l2r all_occurrences false true ?tac id c with_evars)
+	     (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars)
 	     (do_hyps_atleastonce l)
 	in
-	let do_hyps gl =
+	let do_hyps =
 	  (* If the term to rewrite uses an hypothesis H, don't rewrite in H *)
-	  let ids =
+	  let ids gl =
 	    let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in
-	      Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl)
-	  in do_hyps_atleastonce ids gl
+            let ids_of_hyps = pf_ids_of_hyps gl in
+	    Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps
+	  in
+          Proofview.Goal.enter begin fun gl ->
+            do_hyps_atleastonce (ids gl)
+          end
 	in
-	if cl.concl_occs = no_occurrences_expr then do_hyps else
+	if cl.concl_occs == NoOccurrences then do_hyps else
 	  tclIFTHENTRYELSEMUST
 	   (general_rewrite_ebindings l2r (occs_of cl.concl_occs) false true ?tac c with_evars)
 	   do_hyps
 
+let apply_special_clear_request clear_flag f =
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    try
+      let sigma,(c,bl) = f env sigma in
+      apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
+    with
+      e when catchable_exception e -> tclIDTAC
+  end
+
 type delayed_open_constr_with_bindings =
     env -> evar_map -> evar_map * constr with_bindings
 
-let general_multi_multi_rewrite with_evars l cl tac =
-  let do1 l2r f gl =
-    let sigma,c = f (pf_env gl) (project gl) in
-    Refiner.tclWITHHOLES with_evars
-      (general_multi_rewrite l2r with_evars ?tac c) sigma cl gl in
+let general_multi_rewrite with_evars l cl tac =
+  let do1 l2r f =
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let sigma,c = f env sigma in
+      tclWITHHOLES with_evars
+        (general_rewrite_clause l2r with_evars ?tac c) sigma cl
+    end
+  in
   let rec doN l2r c = function
-    | Precisely n when n <= 0 -> tclIDTAC
+    | Precisely n when n <= 0 -> Proofview.tclUNIT ()
     | Precisely 1 -> do1 l2r c
     | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1)))
     | RepeatStar -> tclREPEAT_MAIN (do1 l2r c)
     | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar)
-    | UpTo n when n<=0 -> tclIDTAC
+    | UpTo n when n<=0 -> Proofview.tclUNIT ()
     | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1)))
   in
   let rec loop = function
-    | [] -> tclIDTAC
-    | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l)
+    | [] -> Proofview.tclUNIT ()
+    | (l2r,m,clear_flag,c)::l ->
+        tclTHENFIRST
+          (tclTHEN (doN l2r c m) (apply_special_clear_request clear_flag c)) (loop l)
   in loop l
 
-let rewriteLR = general_rewrite true all_occurrences true true
-let rewriteRL = general_rewrite false all_occurrences true true
+let rewriteLR = general_rewrite true AllOccurrences true true
+let rewriteRL = general_rewrite false AllOccurrences true true
 
 (* Replacing tactics *)
 
+let classes_dirpath =
+  DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
+
+let check_setoid cl = 
+  Option.fold_left
+    ( List.fold_left 
+	(fun b ((occ,_),_) -> 
+	  b||(Locusops.occurrences_map (fun x -> x) occ <> AllOccurrences)
+	)
+    )
+    ((Locusops.occurrences_map (fun x -> x) cl.concl_occs <> AllOccurrences) &&
+	(Locusops.occurrences_map (fun x -> x) cl.concl_occs <> NoOccurrences))
+    cl.onhyps
+
+let replace_core clause l2r eq =
+  if check_setoid clause
+  then init_setoid ();
+  tclTHENFIRST
+    (assert_as false None eq)
+    (onLastHypId (fun id ->
+      tclTHEN
+        (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause))
+	(clear [id])))
+
 (* eq,sym_eq : equality on Type and its symmetry theorem
-   c2 c1 : c1 is to be replaced by c2
+   c1 c2 : c1 is to be replaced by c2
    unsafe : If true, do not check that c1 and c2 are convertible
    tac : Used to prove the equality c1 = c2
    gl : goal *)
 
-let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl =
+let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
   let try_prove_eq =
     match try_prove_eq_opt with
-      | None -> tclIDTAC
+      | None -> Proofview.tclUNIT ()
       | Some tac ->  tclCOMPLETE tac
   in
-  let t1 = pf_apply get_type_of gl c1
-  and t2 = pf_apply get_type_of gl c2 in
-  if unsafe or (pf_conv_x gl t1 t2) then
+  Proofview.Goal.enter begin fun gl ->
+  let get_type_of = pf_apply get_type_of gl in
+  let t1 = get_type_of c1
+  and t2 = get_type_of c2 in
+  let evd = 
+    if unsafe then Some (Proofview.Goal.sigma gl)
+    else
+      try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Proofview.Goal.sigma gl))
+      with Evarconv.UnableToUnify _ -> None
+  in
+  match evd with
+  | None ->
+    tclFAIL 0 (str"Terms do not have convertible types.")
+  | Some evd ->
     let e = build_coq_eq () in
     let sym = build_coq_eq_sym () in
+    Tacticals.New.pf_constr_of_global sym (fun sym ->
+    Tacticals.New.pf_constr_of_global e (fun e ->
     let eq = applist (e, [t1;c1;c2]) in
-    tclTHENS (assert_as false None eq)
-      [onLastHypId (fun id ->
-	tclTHEN
-	  (tclTRY (general_multi_rewrite false false (mkVar id,NoBindings) clause))
-	  (clear [id]));
-       tclFIRST
-	 [assumption;
-	  tclTHEN (apply sym) assumption;
-	  try_prove_eq
-	 ]
-      ] gl
-  else
-    error "Terms do not have convertible types."
-
-
-let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl
-
-let replace_in id c2 c1 gl = multi_replace (onHyp id) c2 c1 false None gl
+    tclTHENLAST
+      (replace_core clause l2r eq)
+      (tclFIRST
+         [assumption;
+          tclTHEN (apply sym) assumption;
+          try_prove_eq
+         ])))
+  end
 
-let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl
+let replace c1 c2 =
+  replace_using_leibniz onConcl c2 c1 false false None
 
-let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl
+let replace_by c1 c2 tac =
+  replace_using_leibniz onConcl c2 c1 false false (Some tac)
 
-let replace_in_clause_maybe_by c2 c1 cl tac_opt gl =
-  multi_replace cl c2 c1 false tac_opt gl
+let replace_in_clause_maybe_by c1 c2 cl tac_opt =
+  replace_using_leibniz cl c2 c1 false false tac_opt
 
 (* End of Eduardo's code. The rest of this file could be improved
    using the functions match_with_equation, etc that I defined
@@ -541,41 +645,64 @@ let replace_in_clause_maybe_by c2 c1 cl tac_opt gl =
 exception DiscrFound of
   (constructor * int) list * constructor * constructor
 
+let injection_on_proofs = ref false
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "injection on prop arguments";
+      optkey   = ["Injection";"On";"Proofs"];
+      optread  = (fun () -> !injection_on_proofs) ;
+      optwrite = (fun b -> injection_on_proofs := b) }
+
+
 let find_positions env sigma t1 t2 =
+  let project env sorts posn t1 t2 =
+    let ty1 = get_type_of env sigma t1 in
+    let s = get_sort_family_of env sigma ty1 in
+    if Sorts.List.mem s sorts
+    then [(List.rev posn,t1,t2)] else []
+  in
   let rec findrec sorts posn t1 t2 =
     let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
     let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
     match (kind_of_term hd1, kind_of_term hd2) with
-
-      | Construct sp1, Construct sp2
-          when List.length args1 = mis_constructor_nargs_env env sp1
+      | Construct (sp1,_), Construct (sp2,_)
+          when Int.equal (List.length args1) (constructor_nallargs_env env sp1)
             ->
-	  let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in
+	  let sorts' =
+            Sorts.List.intersect sorts (allowed_sorts env (fst sp1))
+          in
           (* both sides are fully applied constructors, so either we descend,
              or we can discriminate here. *)
-	  if is_conv env sigma hd1 hd2 then
-	    let nrealargs = constructor_nrealargs env sp1 in
-	    let rargs1 = list_lastn nrealargs args1 in
-	    let rargs2 = list_lastn nrealargs args2 in
+	  if eq_constructor sp1 sp2 then
+	    let nrealargs = constructor_nrealargs_env env sp1 in
+	    let rargs1 = List.lastn nrealargs args1 in
+	    let rargs2 = List.lastn nrealargs args2 in
             List.flatten
-	      (list_map2_i (fun i -> findrec sorts ((sp1,i)::posn))
+	      (List.map2_i (fun i -> findrec sorts' ((sp1,i)::posn))
 		0 rargs1 rargs2)
-	  else if List.mem InType sorts then (* see build_discriminator *)
+	  else if Sorts.List.mem InType sorts'
+          then (* see build_discriminator *)
 	    raise (DiscrFound (List.rev posn,sp1,sp2))
-	  else []
-
+	  else 
+          (* if we cannot eliminate to Type, we cannot discriminate but we
+	     may still try to project *)
+	  project env sorts posn (applist (hd1,args1)) (applist (hd2,args2))
       | _ ->
 	  let t1_0 = applist (hd1,args1)
           and t2_0 = applist (hd2,args2) in
           if is_conv env sigma t1_0 t2_0 then
 	    []
           else
-	    let ty1_0 = get_type_of env sigma t1_0 in
-	    let s = get_sort_family_of env sigma ty1_0 in
-	    if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in
+	    project env sorts posn t1_0 t2_0
+  in
   try
-    (* Rem: to allow injection on proofs objects, just add InProp *)
-    Inr (findrec [InSet;InType] [] t1 t2)
+    let sorts = if !injection_on_proofs then [InSet;InType;InProp]
+		else [InSet;InType]
+    in
+    Inr (findrec sorts [] t1 t2)
   with DiscrFound (path,c1,c2) ->
     Inl (path,c1,c2)
 
@@ -638,7 +765,7 @@ let injectable env sigma t1 t2 =
 
  *)
 
-(* [descend_then sigma env head dirn]
+(* [descend_then env sigma head dirn]
 
    returns the number of products introduced, and the environment
    which is active, in the body of the case-branch given by [dirn],
@@ -653,12 +780,13 @@ let injectable env sigma t1 t2 =
    the continuation then constructs the case-split.
  *)
 
-let descend_then sigma env head dirn =
+let descend_then env sigma head dirn =
   let IndType (indf,_) =
     try find_rectype env sigma (get_type_of env sigma head)
     with Not_found ->
       error "Cannot project on an inductive type derived from a dependency." in
-   let ind,_ = dest_ind_family indf in
+  let indp,_ = (dest_ind_family indf) in
+  let ind, _ = check_privacy env indp in
   let (mib,mip) = lookup_mind_specif env ind in
   let cstr = get_constructors env indf in
   let dirn_nlams = cstr.(dirn-1).cs_nargs in
@@ -670,11 +798,11 @@ let descend_then sigma env head dirn =
       let p =
 	it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in
       let build_branch i =
-	let result = if i = dirn then dirnval else dfltval in
+	let result = if Int.equal i dirn then dirnval else dfltval in
 	it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in
       let brl =
         List.map build_branch
-          (interval 1 (Array.length mip.mind_consnames)) in
+          (List.interval 1 (Array.length mip.mind_consnames)) in
       let ci = make_case_info env ind RegularStyle in
       mkCase (ci, p, head, Array.of_list brl)))
 
@@ -695,7 +823,7 @@ let descend_then sigma env head dirn =
    constructs a case-split on [headval], with the [dirn]-th branch
    giving [True], and all the rest giving False. *)
 
-let construct_discriminator sigma env dirn c sort =
+let construct_discriminator env sigma dirn c sort =
   let IndType(indf,_) =
     try find_rectype env sigma (get_type_of env sigma c)
     with Not_found ->
@@ -707,26 +835,27 @@ let construct_discriminator sigma env dirn c sort =
       errorlabstrm "Equality.construct_discriminator"
 	(str "Cannot discriminate on inductive constructors with \
 		 dependent types.") in
-  let (ind,_) = dest_ind_family indf in
+  let (indp,_) = dest_ind_family indf in
+  let ind, _ = check_privacy env indp in
   let (mib,mip) = lookup_mind_specif env ind in
   let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in
   let deparsign = make_arity_signature env true indf in
   let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in
   let cstrs = get_constructors env indf in
   let build_branch i =
-    let endpt = if i = dirn then true_0 else false_0 in
+    let endpt = if Int.equal i dirn then true_0 else false_0 in
     it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in
   let brl =
-    List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in
+    List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in
   let ci = make_case_info env ind RegularStyle in
   mkCase (ci, p, c, Array.of_list brl)
 
-let rec build_discriminator sigma env dirn c sort = function
-  | [] -> construct_discriminator sigma env dirn c sort
+let rec build_discriminator env sigma dirn c sort = function
+  | [] -> construct_discriminator env sigma dirn c sort
   | ((sp,cnum),argnum)::l ->
-      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let subval = build_discriminator sigma cnum_env dirn newc sort l  in
+      let subval = build_discriminator cnum_env sigma dirn newc sort l  in
       kont subval (build_coq_False (),mkSort (Prop Null))
 
 (* Note: discrimination could be more clever: if some elimination is
@@ -740,13 +869,16 @@ let rec build_discriminator sigma env dirn c sort = function
    Goal ~ c _ 0 0 = c _ 0 1. intro. discriminate H.
 *)
 
-let gen_absurdity id gl =
-  if is_empty_type (pf_get_hyp_typ gl id)
+let gen_absurdity id =
+  Proofview.Goal.enter begin fun gl ->
+  let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in
+  let hyp_typ = pf_nf_evar gl hyp_typ in
+  if is_empty_type hyp_typ
   then
-    simplest_elim (mkVar id) gl
+    simplest_elim (mkVar id)
   else
-    errorlabstrm "Equality.gen_absurdity"
-      (str "Not the negation of an equality.")
+    Proofview.tclZERO (Errors.UserError ("Equality.gen_absurdity" , str "Not the negation of an equality."))
+  end
 
 (* Precondition: eq is leibniz equality
 
@@ -756,24 +888,25 @@ let gen_absurdity id gl =
 *)
 
 let ind_scheme_of_eq lbeq =
-  let (mib,mip) = Global.lookup_inductive (destInd lbeq.eq) in
+  let (mib,mip) = Global.lookup_inductive (destIndRef lbeq.eq) in
   let kind = inductive_sort_family mip in
   (* use ind rather than case by compatibility *)
   let kind =
-    if kind = InProp then Elimschemes.ind_scheme_kind_from_prop
+    if kind == InProp then Elimschemes.ind_scheme_kind_from_prop
     else Elimschemes.ind_scheme_kind_from_type in
-  mkConst (find_scheme kind (destInd lbeq.eq))
+  let c, eff = find_scheme kind (destIndRef lbeq.eq) in
+    ConstRef c, eff
 
 
-let discrimination_pf e (t,t1,t2) discriminator lbeq =
-  let i           = build_coq_I () in
-  let absurd_term = build_coq_False () in
-  let eq_elim     = ind_scheme_of_eq lbeq in
-  (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term)
+let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq =
+  let i            = build_coq_I () in
+  let absurd_term  = build_coq_False () in
+  let eq_elim, eff = ind_scheme_of_eq lbeq in
+  let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in
+    sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term),
+    eff
 
-exception NotDiscriminable
-
-let eq_baseid = id_of_string "e"
+let eq_baseid = Id.of_string "e"
 
 let apply_on_clause (f,t) clause =
   let sigma =  clause.evd in
@@ -788,44 +921,58 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort =
   let e = next_ident_away eq_baseid (ids_of_context env) in
   let e_env = push_named (e,None,t) env in
   let discriminator =
-    build_discriminator sigma e_env dirn (mkVar e) sort cpath in
-  let (pf, absurd_term) = discrimination_pf e (t,t1,t2) discriminator lbeq in
+    build_discriminator e_env sigma dirn (mkVar e) sort cpath in
+  let sigma,(pf, absurd_term), eff = 
+    discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in
   let pf_ty = mkArrow eqn absurd_term in
   let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in
-  let pf = clenv_value_cast_meta absurd_clause in
-  tclTHENS (cut_intro absurd_term)
-    [onLastHypId gen_absurdity; refine pf]
+  let pf = Clenvtac.clenv_value_cast_meta absurd_clause in
+  Proofview.Unsafe.tclEVARS sigma <*>
+  Proofview.tclEFFECTS eff <*>
+  tclTHENS (assert_after Anonymous absurd_term)
+    [onLastHypId gen_absurdity; (Proofview.V82.tactic (refine pf))]
 
-let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls =
+let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
-  let env = pf_env gls in
-  match find_positions env sigma t1 t2 with
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl gl in
+    match find_positions env sigma t1 t2 with
     | Inr _ ->
-	errorlabstrm "discr" (str"Not a discriminable equality.")
+	Proofview.tclZERO (Errors.UserError ("discr" , str"Not a discriminable equality."))
     | Inl (cpath, (_,dirn), _) ->
-	let sort = pf_apply get_type_of gls (pf_concl gls) in
-	discr_positions env sigma u eq_clause cpath dirn sort gls
-
-let onEquality with_evars tac (c,lbindc) gls =
-  let t = pf_type_of gls c in
-  let t' = try snd (pf_reduce_to_quantified_ind gls t) with UserError _ -> t in
-  let eq_clause = make_clenv_binding gls (c,t') lbindc in
-  let eq_clause' = clenv_pose_dependent_evars with_evars eq_clause in
+	let sort = pf_apply get_type_of gl concl in
+	discr_positions env sigma u eq_clause cpath dirn sort
+  end
+
+let onEquality with_evars tac (c,lbindc) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let type_of = pf_type_of gl in
+  let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in
+  let t = type_of c in
+  let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in
+  let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in
+  let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in
   let eqn = clenv_type eq_clause' in
-  let eq,eq_args = find_this_eq_data_decompose gls eqn in
+  let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in
   tclTHEN
-    (Refiner.tclEVARS eq_clause'.evd)
-    (tac (eq,eqn,eq_args) eq_clause') gls
-
-let onNegatedEquality with_evars tac gls =
-  let ccl = pf_concl gls in
-  match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with
-  | Prod (_,t,u) when is_empty_type u ->
-      tclTHEN introf
-        (onLastHypId (fun id ->
-          onEquality with_evars tac (mkVar id,NoBindings))) gls
-  | _ ->
-      errorlabstrm "" (str "Not a negated primitive equality.")
+    (Proofview.Unsafe.tclEVARS eq_clause'.evd)
+    (tac (eq,eqn,eq_args) eq_clause')
+  end
+
+let onNegatedEquality with_evars tac =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    match kind_of_term (hnf_constr env sigma ccl) with
+    | Prod (_,t,u) when is_empty_type u ->
+        tclTHEN introf
+          (onLastHypId (fun id ->
+            onEquality with_evars tac (mkVar id,NoBindings)))
+    | _ ->
+        Proofview.tclZERO (Errors.UserError ("" , str "Not a negated primitive equality."))
+  end
 
 let discrSimpleClause with_evars = function
   | None -> onNegatedEquality with_evars discrEq
@@ -842,25 +989,25 @@ let discrEverywhere with_evars =
     (if discr_do_intro () then
       (tclTHEN
 	(tclREPEAT introf)
-	(Tacticals.tryAllHyps
+	(tryAllHyps
           (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings)))))
      else (* <= 8.2 compat *)
-       Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars))
+       tryAllHypsAndConcl (discrSimpleClause with_evars))
 (*    (fun gls ->
        errorlabstrm "DiscrEverywhere" (str"No discriminable equalities."))
 *)
 let discr_tac with_evars = function
   | None -> discrEverywhere with_evars
-  | Some c -> onInductionArg (discr with_evars) c
+  | Some c -> onInductionArg (fun clear_flag -> discr with_evars) c
 
-let discrConcl gls  = discrClause false onConcl gls
-let discrHyp id gls = discrClause false (onHyp id) gls
+let discrConcl = discrClause false onConcl
+let discrHyp id = discrClause false (onHyp id)
 
 (* returns the sigma type (sigS, sigT) with the respective
     constructor depending on the sort *)
 (* J.F.: correction du bug #1167 en accord avec Hugo. *)
 
-let find_sigma_data s = build_sigma_type ()
+let find_sigma_data env s = build_sigma_type ()
 
 (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
    index bound in [rty]
@@ -874,16 +1021,18 @@ let find_sigma_data s = build_sigma_type ()
 
 let make_tuple env sigma (rterm,rty) lind =
   assert (dependent (mkRel lind) rty);
-  let {intro = exist_term; typ = sig_term} =
-    find_sigma_data (get_sort_of env sigma rty) in
-  let a = type_of env sigma (mkRel lind) in
+  let sigdata = find_sigma_data env (get_sort_of env sigma rty) in
+  let sigma, a = e_type_of ~refresh:true env sigma (mkRel lind) in
   let (na,_,_) = lookup_rel lind env in
   (* We move [lind] to [1] and lift other rels > [lind] by 1 *)
   let rty = lift (1-lind) (liftn lind (lind+1) rty) in
   (* Now [lind] is [mkRel 1] and we abstract on (na:a) *)
   let p = mkLambda (na, a, rty) in
-  (applist(exist_term,[a;p;(mkRel lind);rterm]),
-   applist(sig_term,[a;p]))
+  let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in
+  let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in
+    sigma,
+    (applist(exist_term,[a;p;(mkRel lind);rterm]),
+     applist(sig_term,[a;p]))
 
 (* check that the free-references of the type of [c] are contained in
    the free-references of the normal-form of that type. Strictly
@@ -896,7 +1045,7 @@ let minimal_free_rels env sigma (c,cty) =
   let cty_rels = free_rels cty in
   let cty' = simpl env sigma cty in
   let rels' = free_rels cty' in
-  if Intset.subset cty_rels rels' then
+  if Int.Set.subset cty_rels rels' then
     (cty,cty_rels)
   else
     (cty',rels')
@@ -906,10 +1055,10 @@ let minimal_free_rels env sigma (c,cty) =
 let minimal_free_rels_rec env sigma =
   let rec minimalrec_free_rels_rec prev_rels (c,cty) =
     let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in
-    let combined_rels = Intset.union prev_rels direct_rels in
+    let combined_rels = Int.Set.union prev_rels direct_rels in
     let folder rels i = snd (minimalrec_free_rels_rec rels (c, type_of env sigma (mkRel i)))
-    in (cty, List.fold_left folder combined_rels (Intset.elements (Intset.diff direct_rels prev_rels)))
-  in minimalrec_free_rels_rec Intset.empty
+    in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels)))
+  in minimalrec_free_rels_rec Int.Set.empty
 
 (* [sig_clausal_form siglen ty]
 
@@ -948,22 +1097,23 @@ let minimal_free_rels_rec env sigma =
  *)
 
 let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
-  let { intro = exist_term } = find_sigma_data sort_of_ty in
+  let sigdata = find_sigma_data env sort_of_ty in
   let evdref = ref (Evd.create_goal_evar_defs sigma) in
   let rec sigrec_clausal_form siglen p_i =
-    if siglen = 0 then
+    if Int.equal siglen 0 then
       (* is the default value typable with the expected type *)
       let dflt_typ = type_of env sigma dflt in
-      if Evarconv.e_cumul env evdref dflt_typ p_i then
-	(* the_conv_x had a side-effect on evdref *)
+      try
+	let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in
+	let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in
 	dflt
-      else
+      with Evarconv.UnableToUnify _ ->
 	error "Cannot solve a unification problem."
     else
       let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with
 	| (_sigS,[a;p]) -> (a,p)
- 	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
-      let ev = Evarutil.e_new_evar evdref env a in
+ 	| _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in
+      let ev = Evarutil.e_new_evar env evdref a in
       let rty = beta_applist(p_i_minus_1,[ev]) in
       let tuple_tail = sigrec_clausal_form (siglen-1) rty in
       match
@@ -973,13 +1123,14 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 	| Some w ->
             let w_type = type_of env sigma w in
             if Evarconv.e_cumul env evdref w_type a then
-              applist(exist_term,[w_type;p_i_minus_1;w;tuple_tail])
+	      let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in
+              applist(exist_term,[a;p_i_minus_1;w;tuple_tail])
             else
               error "Cannot solve a unification problem."
-	| None -> anomaly "Not enough components to build the dependent tuple"
+	| None -> anomaly (Pp.str "Not enough components to build the dependent tuple")
   in
   let scf = sigrec_clausal_form siglen ty in
-  Evarutil.nf_evar !evdref scf
+    !evdref, Evarutil.nf_evar !evdref scf
 
 (* The problem is to build a destructor (a generalization of the
    predecessor) which, when applied to a term made of constructors
@@ -1012,7 +1163,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 
    If [zty] has no dependencies, this is simple. Otherwise, assume
    [zty] has free (de Bruijn) variables in,...i1 then the role of
-   [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the
+   [make_iterated_tuple env sigma (term,typ) (z,zty)] is to build the
    tuple
 
    [existT [xn]Pn Rel(in) .. (existT [x2]P2 Rel(i2) (existT [x1]P1 Rel(i1) z))]
@@ -1042,30 +1193,29 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
 let make_iterated_tuple env sigma dflt (z,zty) =
   let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in
   let sort_of_zty = get_sort_of env sigma zty in
-  let sorted_rels = Sort.list (<) (Intset.elements rels) in
-  let (tuple,tuplety) =
-    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels
+  let sorted_rels = Int.Set.elements rels in
+  let sigma, (tuple,tuplety) =
+    List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels
   in
   assert (closed0 tuplety);
   let n = List.length sorted_rels in
-  let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
-  (tuple,tuplety,dfltval)
+  let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
+    sigma, (tuple,tuplety,dfltval)
 
-let rec build_injrec sigma env dflt c = function
+let rec build_injrec env sigma dflt c = function
   | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c)
   | ((sp,cnum),argnum)::l ->
     try
-      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
       let newc = mkRel(cnum_nlams-argnum) in
-      let (subval,tuplety,dfltval) = build_injrec sigma cnum_env dflt newc l in
-      (kont subval (dfltval,tuplety),
-      tuplety,dfltval)
+      let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in
+	sigma, (kont subval (dfltval,tuplety), tuplety,dfltval)
     with
 	UserError _ -> failwith "caught"
 
-let build_injector sigma env dflt c cpath =
-  let (injcode,resty,_) = build_injrec sigma env dflt c cpath in
-  (injcode,resty)
+let build_injector env sigma dflt c cpath =
+  let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in
+    sigma, (injcode,resty)
 
 (*
 let try_delta_expand env sigma t =
@@ -1080,6 +1230,52 @@ let try_delta_expand env sigma t =
   hd_rec whdt
 *)
 
+let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined")
+let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k)
+
+let eqdep_dec = qualid_of_string "Coq.Logic.Eqdep_dec"
+
+let inject_if_homogenous_dependent_pair ty =
+  Proofview.Goal.nf_enter begin fun gl ->
+  try
+    let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in
+    (* fetch the informations of the  pair *)
+    let ceq = Universes.constr_of_global Coqlib.glob_eq in
+    let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
+    let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in
+    (* check whether the equality deals with dep pairs or not *)
+    let eqTypeDest = fst (decompose_app t) in
+    if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit;
+    let hd1,ar1 = decompose_app_vect t1 and
+        hd2,ar2 = decompose_app_vect t2 in
+    if not (Globnames.is_global (existTconstr()) hd1) then raise Exit;
+    if not (Globnames.is_global (existTconstr()) hd2) then raise Exit;
+    let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in
+    (* check if the user has declared the dec principle *)
+    (* and compare the fst arguments of the dep pair *)
+    (* Note: should work even if not an inductive type, but the table only *)
+    (* knows inductive types *)
+    if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) &&
+      pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit;
+    Library.require_library [Loc.ghost,eqdep_dec] (Some false);
+    let new_eq_args = [|pf_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in
+    let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing"
+      ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
+    let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in
+    (* cut with the good equality and prove the requested goal *)
+    tclTHENLIST
+      [Proofview.tclEFFECTS eff;
+       intro;
+       onLastHyp (fun hyp ->
+        tclTHENS (cut (mkApp (ceq,new_eq_args)))
+          [clear [destVar hyp];
+           Proofview.V82.tactic (refine
+             (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))
+          ])]
+  with Exit ->
+    Proofview.tclUNIT ()
+  end
+
 (* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it
    expands then only when the whdnf has a constructor of an inductive type
    in hd position, otherwise delta expansion is not done *)
@@ -1091,141 +1287,114 @@ let simplify_args env sigma t =
     | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2])
     | _ -> t
 
-let inject_at_positions env sigma (eq,_,(t,t1,t2)) eq_clause posns tac =
+let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac =
   let e = next_ident_away eq_baseid (ids_of_context env) in
-  let e_env = push_named (e,None,t) env in
-  let injectors =
-    map_succeed
-      (fun (cpath,t1',t2') ->
-        (* arbitrarily take t1' as the injector default value *)
-	let (injbody,resty) = build_injector sigma e_env t1' (mkVar e) cpath in
-	let injfun = mkNamedLambda e t injbody in
-	let pf = applist(eq.congr,[t;resty;injfun;t1;t2]) in
-	let pf_typ = get_type_of env sigma pf in
-	let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in
-        let pf = clenv_value_cast_meta inj_clause in
-	let ty = simplify_args env sigma (clenv_type inj_clause) in
-	(pf,ty))
-      posns in
-  if injectors = [] then
-    errorlabstrm "Equality.inj" (str "Failed to decompose the equality.");
-  tclTHEN
-    (tclMAP
-      (fun (pf,ty) -> tclTHENS (cut ty) [tclIDTAC; refine pf])
-      injectors)
-    (tac (List.length injectors))
-
-exception Not_dep_pair
-
-let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined")
-let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k)
-
-let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause =
+  let e_env = push_named (e, None,t) env in
+  let evdref = ref sigma in
+  let filter (cpath, t1', t2') =
+    try
+      (* arbitrarily take t1' as the injector default value *)
+      let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in
+      let injfun = mkNamedLambda e t injbody in
+      let sigma,congr = Evd.fresh_global env sigma eq.congr in
+      let pf = applist(congr,[t;resty;injfun;t1;t2]) in
+      let sigma, pf_typ = Typing.e_type_of env sigma pf in
+      let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in
+      let pf = Clenvtac.clenv_value_cast_meta inj_clause in
+      let ty = simplify_args env sigma (clenv_type inj_clause) in
+	evdref := sigma;
+	Some (pf, ty)
+    with Failure _ -> None
+  in
+  let injectors = List.map_filter filter posns in
+  if List.is_empty injectors then
+    Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality."))
+  else
+    Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref)
+    (Proofview.tclBIND
+      (Proofview.Monad.List.map
+         (fun (pf,ty) -> tclTHENS (cut ty)
+           [inject_if_homogenous_dependent_pair ty;
+            Proofview.V82.tactic (refine pf)])
+         (if l2r then List.rev injectors else injectors))
+      (fun _ -> tac (List.length injectors)))
+
+let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause =
   let sigma = eq_clause.evd in
   let env = eq_clause.env in
   match find_positions env sigma t1 t2 with
-    | Inl _ ->
-	errorlabstrm "Inj"
-	  (str"Not a projectable equality but a discriminable one.")
-    | Inr [] ->
-	errorlabstrm "Equality.inj"
-	   (str"Nothing to do, it is an equality between convertible terms.")
-    | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 ->
-        errorlabstrm "Equality.inj" (str"Nothing to inject.")
-    | Inr posns ->
-(* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ?
-	let t1 = try_delta_expand env sigma t1 in
-	let t2 = try_delta_expand env sigma t2 in
-*)
-        try (
-(* fetch the informations of the  pair *)
-        let ceq = constr_of_global Coqlib.glob_eq in
-        let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
-        let eqTypeDest = fst (destApp t) in
-        let _,ar1 = destApp t1 and
-            _,ar2 = destApp t2 in
-        let ind = destInd ar1.(0) in
-        let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing"
-            ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
-(* check whether the equality deals with dep pairs or not *)
-(* if yes, check if the user has declared the dec principle *)
-(* and compare the fst arguments of the dep pair *)
-        let new_eq_args = [|type_of env sigma (ar1.(3));ar1.(3);ar2.(3)|] in
-        if ( (eqTypeDest = sigTconstr()) &&
-             (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind=true) &&
-             (is_conv env sigma (ar1.(2)) (ar2.(2)) = true))
-              then (
-(* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*)
-              let qidl = qualid_of_reference
-                (Ident (dummy_loc,id_of_string "Eqdep_dec")) in
-              Library.require_library [qidl] (Some false);
-(* cut with the good equality and prove the requested goal *)
-              tclTHENS (cut (mkApp (ceq,new_eq_args)) )
-               [tclIDTAC; tclTHEN (apply (
-                  mkApp(inj2,
-                        [|ar1.(0);mkConst (find_scheme (!eq_dec_scheme_kind_name()) ind);
-                          ar1.(1);ar1.(2);ar1.(3);ar2.(3)|])
-                  )) (Auto.trivial [] [])
-                ]
-(* not a dep eq or no decidable type found *)
-            ) else (raise Not_dep_pair)
-        ) with e when Errors.noncritical e ->
-	  inject_at_positions env sigma u eq_clause posns
-	    (fun _ -> intros_pattern no_move ipats)
-
-let inj ipats with_evars = onEquality with_evars (injEq ipats)
+  | Inl _ ->
+     Proofview.tclZERO (Errors.UserError ("Inj",strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal."))
+  | Inr [] ->
+     let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in
+     Proofview.tclZERO (Errors.UserError ("Equality.inj",strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)))
+  | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 ->
+     Proofview.tclZERO (Errors.UserError ("Equality.inj" , str"Nothing to inject."))
+  | Inr posns ->
+      inject_at_positions env sigma l2r u eq_clause posns
+	(tac (clenv_value eq_clause))
+
+let use_clear_hyp_by_default () = false
+
+let postInjEqTac clear_flag ipats c n =
+  match ipats with
+  | Some ipats ->
+      let clear_tac =
+        let dft =
+          use_injection_pattern_l2r_order () || use_clear_hyp_by_default () in
+        tclTRY (apply_clear_request clear_flag dft c) in
+      let intro_tac =
+        if use_injection_pattern_l2r_order ()
+        then intro_patterns_bound_to n MoveLast ipats
+        else intro_patterns_to MoveLast ipats in
+      tclTHEN clear_tac intro_tac
+  | None -> tclIDTAC
+
+let injEq clear_flag ipats =
+  let l2r =
+    if use_injection_pattern_l2r_order () && not (Option.is_empty ipats) then true else false
+  in
+  injEqThen (fun c i -> postInjEqTac clear_flag ipats c i) l2r
+
+let inj ipats with_evars clear_flag = onEquality with_evars (injEq clear_flag ipats)
 
 let injClause ipats with_evars = function
-  | None -> onNegatedEquality with_evars (injEq ipats)
+  | None -> onNegatedEquality with_evars (injEq None ipats)
   | Some c -> onInductionArg (inj ipats with_evars) c
 
-let injConcl gls  = injClause [] false None gls
-let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls
-
-let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls =
-  let sort = pf_apply get_type_of gls (pf_concl gls) in
-  let sigma =  clause.evd in
-  let env = pf_env gls in
-  match find_positions env sigma t1 t2 with
-    | Inl (cpath, (_,dirn), _) ->
-	discr_positions env sigma u clause cpath dirn sort gls
-    | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
-        ntac 0 gls
+let injConcl = injClause None false None
+let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id)))
+
+let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in
+    let sigma =  clause.evd in
+    let env = Proofview.Goal.env gl in
+      match find_positions env sigma t1 t2 with
+      | Inl (cpath, (_,dirn), _) ->
+	  discr_positions env sigma u clause cpath dirn sort
+      | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
+        ntac (clenv_value clause) 0
     | Inr posns ->
-	inject_at_positions env sigma u clause (List.rev posns) ntac gls
+	inject_at_positions env sigma true u clause posns
+          (ntac (clenv_value clause))
+  end
 
 let dEqThen with_evars ntac = function
-  | None -> onNegatedEquality with_evars (decompEqThen ntac)
-  | Some c -> onInductionArg (onEquality with_evars (decompEqThen ntac)) c
-
-let dEq with_evars = dEqThen with_evars (fun x -> tclIDTAC)
-
-let swap_equality_args = function
-  | MonomorphicLeibnizEq (e1,e2) -> [e2;e1]
-  | PolymorphicLeibnizEq (t,e1,e2) -> [t;e2;e1]
-  | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1]
-
-let swap_equands gls eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  applist(lbeq.eq,swap_equality_args eq_args)
-
-let swapEquandsInConcl gls =
-  let (lbeq,eq_args) = find_eq_data (pf_concl gls) in
-  let sym_equal = lbeq.sym in
-  refine
-    (applist(sym_equal,(swap_equality_args eq_args@[Evarutil.mk_new_meta()])))
-    gls
-
-(* Refine from [|- P e2] to [|- P e1] and [|- e1=e2:>t] (body is P (Rel 1)) *)
-
-let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
-  (* find substitution scheme *)
-  let eq_elim = find_elim lbeq.eq (Some false) false None None gls in
-  (* build substitution predicate *)
-  let p = lambda_create (pf_env gls) (t,body) in
-  (* apply substitution scheme *)
-  refine (applist(eq_elim,[t;e1;p;Evarutil.mk_new_meta();
-                           e2;Evarutil.mk_new_meta()])) gls
+  | None -> onNegatedEquality with_evars (decompEqThen (ntac None))
+  | Some c -> onInductionArg (fun clear_flag -> onEquality with_evars (decompEqThen (ntac clear_flag))) c
+
+let dEq with_evars =
+  dEqThen with_evars (fun clear_flag c x ->
+    (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c))
+
+let intro_decompe_eq tac data cl =
+  Proofview.Goal.enter begin fun gl ->
+    let cl = pf_apply make_clenv_binding gl cl NoBindings in
+    decompEqThen (fun _ -> tac) data cl
+  end
+
+let _ = declare_intro_decomp_eq intro_decompe_eq
 
 (* [subst_tuple_term dep_pair B]
 
@@ -1263,17 +1432,15 @@ let decomp_tuple_term env c t =
   let rec decomprec inner_code ex exty =
     let iterated_decomp =
     try
-      let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in
-      let car_code = applist (p1,[a;p;inner_code])
-      and cdr_code = applist (p2,[a;p;inner_code]) in
+      let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in
+      let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code])
+      and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in
       let cdrtyp = beta_applist (p,[car]) in
       List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp)
-    with PatternMatchingFailure ->
+    with Constr_matching.PatternMatchingFailure ->
       []
-    in
-    [((ex,exty),inner_code)]::iterated_decomp
-  in
-  decomprec (mkRel 1) c t
+    in [((ex,exty),inner_code)]::iterated_decomp
+  in decomprec (mkRel 1) c t
 
 let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
   let typ = get_type_of env sigma dep_pair1 in
@@ -1293,78 +1460,80 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b =
     List.fold_right
       (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in
   let pred_body = beta_applist(abst_B,proj_list) in
+  let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in
   let expected_goal = beta_applist (abst_B,List.map fst e2_list) in
   (* Simulate now the normalisation treatment made by Logic.mk_refgoals *)
   let expected_goal = nf_betaiota sigma expected_goal in
-  pred_body,expected_goal
+  (* Retype to get universes right *)
+  let sigma, expected_goal_ty = Typing.e_type_of env sigma expected_goal in
+  let sigma, _ = Typing.e_type_of env sigma body in
+    sigma,body,expected_goal
 
-(* Like "replace" but decompose dependent equalities *)
+(* Like "replace" but decompose dependent equalities                      *)
+(* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *)
+(* then it uses the predicate "\x.phi(proj1_sig x,proj2_sig x)", and so   *)
+(* on for further iterated sigma-tuples                                   *)
 
 exception NothingToRewrite
 
-let cutSubstInConcl_RL eqn gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
-  let body,expected_goal = pf_apply subst_tuple_term gls e2 e1 (pf_concl gls) in
-  if not (dependent (mkRel 1) body) then raise NothingToRewrite;
+let cutSubstInConcl l2r eqn =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in
+  let typ = pf_concl gl in
+  let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in
+  let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in
   tclTHENFIRST
-    (bareRevSubstInConcl lbeq body eq)
-    (convert_concl expected_goal DEFAULTcast) gls
+    (tclTHENLIST [
+       (Proofview.Unsafe.tclEVARS sigma);
+       (change_concl typ); (* Put in pattern form *)
+       (replace_core onConcl l2r eqn)
+    ])
+    (change_concl expected) (* Put in normalized form *)
+   end
+
+let cutSubstInHyp l2r eqn id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in
+  let typ = pf_get_hyp_typ id gl in
+  let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in
+  let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in
+  tclTHENFIRST
+    (tclTHENLIST [
+       (Proofview.Unsafe.tclEVARS sigma);
+       (change_in_hyp None (fun s -> s,typ) (id,InHypTypeOnly));
+       (replace_core (onHyp id) l2r eqn)
+    ])
+    (change_in_hyp None (fun s -> s,expected) (id,InHypTypeOnly))
+  end
 
-(* |- (P e1)
-     BY CutSubstInConcl_LR (eq T e1 e2)
-     |- (P e2)
-     |- (eq T e1 e2)
- *)
-let cutSubstInConcl_LR eqn gls =
-  (tclTHENS (cutSubstInConcl_RL (swap_equands gls eqn))
-     ([tclIDTAC;
-       swapEquandsInConcl])) gls
-
-let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL
-
-let cutSubstInHyp_LR eqn id gls =
-  let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in
-  let idtyp = pf_get_hyp_typ gls id in
-  let body,expected_goal = pf_apply subst_tuple_term gls e1 e2 idtyp in
-  if not (dependent (mkRel 1) body) then raise NothingToRewrite;
-  cut_replacing id expected_goal
-    (tclTHENFIRST
-      (bareRevSubstInConcl lbeq body eq)
-      (refine_no_check (mkVar id))) gls
-
-let cutSubstInHyp_RL eqn id gls =
-  (tclTHENS (cutSubstInHyp_LR (swap_equands gls eqn) id)
-     ([tclIDTAC;
-       swapEquandsInConcl])) gls
-
-let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL
-
-let try_rewrite tac gls =
-  try
-    tac gls
-  with
-    | PatternMatchingFailure ->
-	errorlabstrm "try_rewrite" (str "Not a primitive equality here.")
+let try_rewrite tac =
+  Proofview.tclORELSE tac begin function (e, info) -> match e with
+    | Constr_matching.PatternMatchingFailure ->
+	tclZEROMSG (str "Not a primitive equality here.")
     | e when catchable_exception e ->
-	errorlabstrm "try_rewrite"
+	tclZEROMSG
           (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.")
     | NothingToRewrite ->
-	errorlabstrm "try_rewrite"
+	tclZEROMSG
           (strbrk "Nothing to rewrite.")
+    | e -> Proofview.tclZERO ~info e
+  end
 
-let cutSubstClause l2r eqn cls gls =
+let cutSubstClause l2r eqn cls =
   match cls with
-    | None ->    cutSubstInConcl l2r eqn gls
-    | Some id -> cutSubstInHyp l2r eqn id gls
+    | None ->    cutSubstInConcl l2r eqn
+    | Some id -> cutSubstInHyp l2r eqn id
 
 let cutRewriteClause l2r eqn cls = try_rewrite (cutSubstClause l2r eqn cls)
 let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id)
 let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None
 
-let substClause l2r c cls gls =
-  let eq = pf_apply get_type_of gls c in
+let substClause l2r c cls =
+  Proofview.Goal.enter begin fun gl ->
+  let eq = pf_apply get_type_of gl c in
   tclTHENS (cutSubstClause l2r eq cls)
-    [tclIDTAC; exact_no_check c] gls
+    [Proofview.tclUNIT (); Proofview.V82.tactic (exact_no_check c)]
+  end
 
 let rewriteClause l2r c cls = try_rewrite (substClause l2r c cls)
 let rewriteInHyp l2r c id = rewriteClause l2r c (Some id)
@@ -1389,100 +1558,102 @@ user = raise user error specific to rewrite
 (**********************************************************************)
 (* Substitutions tactics (JCF) *)
 
-let unfold_body x gl =
-  let hyps = pf_hyps gl in
-  let xval =
-    match Sign.lookup_named x hyps with
-        (_,Some xval,_) -> xval
-      | _ -> errorlabstrm "unfold_body"
-          (pr_id x ++ str" is not a defined hypothesis.") in
-  let aft = afterHyp x gl in
+let unfold_body x =
+  Proofview.Goal.enter begin fun gl ->
+  (** We normalize the given hypothesis immediately. *)
+  let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+  let (_, xval, _) = Context.lookup_named x hyps in
+  let xval = match xval with
+  | None -> errorlabstrm "unfold_body"
+    (pr_id x ++ str" is not a defined hypothesis.")
+  | Some xval -> pf_nf_evar gl xval
+  in
+  afterHyp x begin fun aft ->
   let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in
   let xvar = mkVar x in
   let rfun _ _ c = replace_term xvar xval c in
-  tclTHENLIST
-    [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
-     reduct_in_concl (rfun,DEFAULTcast)] gl
-
-
+  let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in
+  let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in
+  tclTHENLIST [tclMAP reducth hl; reductc]
+  end
+  end
 
 let restrict_to_eq_and_identity eq = (* compatibility *)
-  if eq <> constr_of_global glob_eq && eq <> constr_of_global glob_identity then
-    raise PatternMatchingFailure
+  if not (is_global glob_eq eq) &&
+    not (is_global glob_identity eq) 
+  then raise Constr_matching.PatternMatchingFailure
 
-exception FoundHyp of (identifier * constr * bool)
+exception FoundHyp of (Id.t * constr * bool)
 
 (* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *)
 let is_eq_x gl x (id,_,c) =
   try
-    let (_,lhs,rhs) = snd (find_eq_data_decompose gl c) in
-    if (eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
-    if (eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
-  with PatternMatchingFailure ->
+    let c = pf_nf_evar gl c in
+    let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in
+    if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
+  with Constr_matching.PatternMatchingFailure ->
     ()
 
 (* Rewrite "hyp:x=rhs" or "hyp:rhs=x" (if dir=false) everywhere and
    erase hyp and x; proceed by generalizing all dep hyps *)
 
-let subst_one dep_proof_ok x (hyp,rhs,dir) gl =
+let subst_one dep_proof_ok x (hyp,rhs,dir) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let hyps = Proofview.Goal.hyps gl in
+  let concl = Proofview.Goal.concl gl in
   (* The set of hypotheses using x *)
-  let depdecls =
-    let test (id,_,c as dcl) =
-      if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
-      else failwith "caught" in
-    List.rev (map_succeed test (pf_hyps gl)) in
-  let dephyps = List.map (fun (id,_,_) -> id) depdecls in
+  let dephyps =
+    List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) ->
+      if not (Id.equal id hyp)
+         && List.exists (fun y -> occur_var_in_decl env y dcl) deps
+      then
+        ((if b = None then deps else id::deps), id::allhyps)
+      else
+        (deps,allhyps))
+      hyps
+      ([x],[]))) in
   (* Decides if x appears in conclusion *)
-  let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
-  (* The set of non-defined hypothesis: they must be abstracted,
-     rewritten and reintroduced *)
-  let abshyps =
-    map_succeed
-      (fun (id,v,_) -> if v=None then mkVar id else failwith "caught")
-      depdecls in
-  (* a tactic that either introduce an abstracted and rewritten hyp,
-     or introduce a definition where x was replaced *)
-  let introtac = function
-      (id,None,_) -> intro_using id
-    | (id,Some hval,htyp) ->
-        letin_tac None (Name id)
-	  (replace_term (mkVar x) rhs hval)
-	  (Some (replace_term (mkVar x) rhs htyp)) nowhere
-  in
-  let need_rewrite = dephyps <> [] || depconcl in
+  let depconcl = occur_var env x concl in
+  let need_rewrite = not (List.is_empty dephyps) || depconcl in
   tclTHENLIST
     ((if need_rewrite then
-      [generalize abshyps;
-       general_rewrite dir all_occurrences true dep_proof_ok (mkVar hyp);
-       thin dephyps;
-       tclMAP introtac depdecls]
+      [revert dephyps;
+       general_rewrite dir AllOccurrences true dep_proof_ok (mkVar hyp);
+       (tclMAP intro_using dephyps)]
       else
-       [tclIDTAC]) @
-     [tclTRY (clear [x;hyp])]) gl
+       [Proofview.tclUNIT ()]) @
+     [tclTRY (clear [x; hyp])])
+  end
 
 (* Look for an hypothesis hyp of the form "x=rhs" or "rhs=x", rewrite
    it everywhere, and erase hyp and x; proceed by generalizing all dep hyps *)
 
-let subst_one_var dep_proof_ok x gl =
-  let hyps = pf_hyps gl in
-  let (_,xval,_) = pf_get_hyp gl x in
-  (* If x has a body, simply replace x with body and clear x *)
-  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
-  (* x is a variable: *)
-  let varx = mkVar x in
-  (* Find a non-recursive definition for x *)
-  let (hyp,rhs,dir) =
-    try
-      let test hyp _ = is_eq_x gl varx hyp in
-      Sign.fold_named_context test ~init:() hyps;
-      errorlabstrm "Subst"
-        (str "Cannot find any non-recursive equality over " ++ pr_id x ++
-	 str".")
-    with FoundHyp res -> res in
-  subst_one dep_proof_ok x (hyp,rhs,dir) gl
+let subst_one_var dep_proof_ok x =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let (_,xval,_) = pf_get_hyp x gl in
+    (* If x has a body, simply replace x with body and clear x *)
+    if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else
+      (* x is a variable: *)
+      let varx = mkVar x in
+      (* Find a non-recursive definition for x *)
+      let res =
+        try
+          (** [is_eq_x] ensures nf_evar on its side *)
+          let hyps = Proofview.Goal.hyps gl in
+          let test hyp _ = is_eq_x gl varx hyp in
+          Context.fold_named_context test ~init:() hyps;
+          errorlabstrm "Subst"
+            (str "Cannot find any non-recursive equality over " ++ pr_id x ++
+	       str".")
+        with FoundHyp res -> res in
+      subst_one dep_proof_ok x res
+  end
 
 let subst_gen dep_proof_ok ids =
-  tclTHEN tclNORMEVAR (tclMAP (subst_one_var dep_proof_ok) ids)
+  tclTHEN Proofview.V82.nf_evar_goals (tclMAP (subst_one_var dep_proof_ok) ids)
 
 (* For every x, look for an hypothesis hyp of the form "x=rhs" or "rhs=x",
    rewrite it everywhere, and erase hyp and x; proceed by generalizing
@@ -1501,67 +1672,82 @@ let default_subst_tactic_flags () =
   else
     { only_leibniz = true; rewrite_dependent_proof = false }
 
-let subst_all ?(flags=default_subst_tactic_flags ()) gl =
+let subst_all ?(flags=default_subst_tactic_flags ()) () =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let find_eq_data_decompose = find_eq_data_decompose gl in
   let test (_,c) =
     try
-      let lbeq,(_,x,y) = find_eq_data_decompose gl c in
-      if flags.only_leibniz then restrict_to_eq_and_identity lbeq.eq;
+      let lbeq,u,(_,x,y) = find_eq_data_decompose c in
+      let eq = Universes.constr_of_global_univ (lbeq.eq,u) in
+      if flags.only_leibniz then restrict_to_eq_and_identity eq;
       (* J.F.: added to prevent failure on goal containing x=x as an hyp *)
-      if eq_constr x y then failwith "caught";
+      if Term.eq_constr x y then failwith "caught";
       match kind_of_term x with Var x -> x | _ ->
       match kind_of_term y with Var y -> y | _ -> failwith "caught"
-    with PatternMatchingFailure -> failwith "caught"
+    with Constr_matching.PatternMatchingFailure -> failwith "caught"
   in
-  let ids = map_succeed test (pf_hyps_types gl) in
-  let ids = list_uniquize ids in
-  subst_gen flags.rewrite_dependent_proof ids gl
+  let test p = try Some (test p) with Failure _ -> None in
+  let hyps = pf_hyps_types gl in
+  let ids = List.map_filter test hyps in
+  let ids = List.uniquize ids in
+  subst_gen flags.rewrite_dependent_proof ids
+  end
 
-(* Rewrite the first assumption for which the condition faildir does not fail
+(* Rewrite the first assumption for which a condition holds
    and gives the direction of the rewrite *)
 
 let cond_eq_term_left c t gl =
   try
-    let (_,x,_) = snd (find_eq_data_decompose gl t) in
+    let (_,x,_) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term_right c t gl =
   try
-    let (_,_,x) = snd (find_eq_data_decompose gl t) in
+    let (_,_,x) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then false else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
 let cond_eq_term c t gl =
   try
-    let (_,x,y) = snd (find_eq_data_decompose gl t) in
+    let (_,x,y) = pi3 (find_eq_data_decompose gl t) in
     if pf_conv_x gl c x then true
     else if pf_conv_x gl c y then false
     else failwith "not convertible"
-  with PatternMatchingFailure -> failwith "not an equality"
+  with Constr_matching.PatternMatchingFailure -> failwith "not an equality"
 
-let rewrite_multi_assumption_cond cond_eq_term cl gl =
-  let rec arec = function
+let rewrite_assumption_cond cond_eq_term cl =
+  let rec arec hyps gl = match hyps with
     | [] -> error "No such assumption."
     | (id,_,t) ::rest ->
 	begin
 	  try
-	    let dir = cond_eq_term t gl in
-	    general_multi_rewrite dir false (mkVar id,NoBindings) cl gl
-	  with | Failure _ | UserError _ -> arec rest
+            let dir = cond_eq_term t gl in
+	    general_rewrite_clause dir false (mkVar id,NoBindings) cl
+	  with | Failure _ | UserError _ -> arec rest gl
 	end
   in
-  arec (pf_hyps gl)
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps gl in
+    arec hyps gl
+  end
 
-let replace_multi_term dir_opt c  =
+(* Generalize "subst x" to substitution of subterm appearing as an
+   equation in the context, but not clearing the hypothesis *)
+
+let replace_term dir_opt c  =
   let cond_eq_fun =
     match dir_opt with
       | None -> cond_eq_term c
       | Some true -> cond_eq_term_left c
       | Some false -> cond_eq_term_right c
   in
-  rewrite_multi_assumption_cond cond_eq_fun
+  rewrite_assumption_cond cond_eq_fun
+
+(* Declare rewriting tactic for intro patterns "<-" and "->" *)
 
-let _ = Tactics.register_general_multi_rewrite
-  (fun b evars t cls -> general_multi_rewrite b evars t cls)
+let _ =
+  let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in
+  Hook.set Tactics.general_rewrite_clause gmr
 
-let _ = Tactics.register_subst_one (fun b -> subst_one b)
+let _ = Hook.set Tactics.subst_one subst_one
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 75a59e6d..90d8a224 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -1,29 +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        *)
 (************************************************************************)
 
 (*i*)
-open Util
 open Names
 open Term
-open Sign
 open Evd
 open Environ
-open Proof_type
 open Tacmach
-open Hipattern
-open Pattern
-open Tacticals
-open Tactics
 open Tacexpr
-open Termops
-open Glob_term
-open Genarg
 open Ind_tables
+open Locus
+open Misctypes
 (*i*)
 
 type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
@@ -38,101 +30,91 @@ type conditions =
 
 val general_rewrite_bindings :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 val general_rewrite :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic
 
 (* Equivalent to [general_rewrite l2r] *)
-val rewriteLR : ?tac:(tactic * conditions) -> constr -> tactic
-val rewriteRL : ?tac:(tactic * conditions) -> constr  -> tactic
+val rewriteLR : ?tac:(unit Proofview.tactic * conditions) -> constr -> unit Proofview.tactic
+val rewriteRL : ?tac:(unit Proofview.tactic * conditions) -> constr  -> unit Proofview.tactic
 
 (* Warning: old [general_rewrite_in] is now [general_rewrite_bindings_in] *)
 
-val register_general_rewrite_clause :
-  (identifier option -> orientation ->
-    occurrences -> constr with_bindings -> new_goals:constr list -> tactic) -> unit
-val register_is_applied_rewrite_relation : (env -> evar_map -> rel_context -> constr -> constr option) -> unit
+val general_setoid_rewrite_clause :
+  (Id.t option -> orientation -> occurrences -> constr with_bindings ->
+   new_goals:constr list -> unit Proofview.tactic) Hook.t
 
-val general_rewrite_ebindings_clause : identifier option ->
+val general_rewrite_ebindings_clause : Id.t option ->
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 
 val general_rewrite_bindings_in :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag ->
-  ?tac:(tactic * conditions) ->
-  identifier -> constr with_bindings -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) ->
+  Id.t -> constr with_bindings -> evars_flag -> unit Proofview.tactic
 val general_rewrite_in          :
   orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> 
-  ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic
+  ?tac:(unit Proofview.tactic * conditions) -> Id.t -> constr -> evars_flag -> unit Proofview.tactic
+
+val general_rewrite_clause :
+  orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic
 
 val general_multi_rewrite :
-  orientation -> evars_flag -> ?tac:(tactic * conditions) -> constr with_bindings -> clause -> tactic
-
-type delayed_open_constr_with_bindings =
-    env -> evar_map -> evar_map * constr with_bindings
-
-val general_multi_multi_rewrite :
-  evars_flag -> (bool * multi * delayed_open_constr_with_bindings) list ->
-    clause -> (tactic * conditions) option -> tactic
-
-val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic
-val replace    : constr -> constr -> tactic
-val replace_in : identifier -> constr -> constr -> tactic
-val replace_by : constr -> constr -> tactic -> tactic
-val replace_in_by : identifier -> constr -> constr -> tactic -> tactic
-
-val discr        : evars_flag -> constr with_bindings -> tactic
-val discrConcl   : tactic
-val discrClause  : evars_flag -> clause -> tactic
-val discrHyp     : identifier -> tactic
-val discrEverywhere : evars_flag -> tactic
+  evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list ->
+    clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic
+
+val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic
+val replace    : constr -> constr -> unit Proofview.tactic
+val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic
+
+val discr        : evars_flag -> constr with_bindings -> unit Proofview.tactic
+val discrConcl   : unit Proofview.tactic
+val discrHyp     : Id.t -> unit Proofview.tactic
+val discrEverywhere : evars_flag -> unit Proofview.tactic
 val discr_tac    : evars_flag ->
-  constr with_bindings induction_arg option -> tactic
-val inj          : intro_pattern_expr located list -> evars_flag ->
-  constr with_bindings -> tactic
-val injClause    : intro_pattern_expr located list -> evars_flag ->
-  constr with_bindings induction_arg option -> tactic
-val injHyp       : identifier -> tactic
-val injConcl     : tactic
+  constr with_bindings induction_arg option -> unit Proofview.tactic
+val inj          : intro_patterns option -> evars_flag ->
+  clear_flag -> constr with_bindings -> unit Proofview.tactic
+val injClause    : intro_patterns option -> evars_flag ->
+  constr with_bindings induction_arg option -> unit Proofview.tactic
+val injHyp       : clear_flag -> Id.t -> unit Proofview.tactic
+val injConcl     : unit Proofview.tactic
 
-val dEq : evars_flag -> constr with_bindings induction_arg option -> tactic
-val dEqThen : evars_flag -> (int -> tactic) -> constr with_bindings induction_arg option -> tactic
+val dEq : evars_flag -> constr with_bindings induction_arg option -> unit Proofview.tactic
+val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings induction_arg option -> unit Proofview.tactic
 
 val make_iterated_tuple :
-  env -> evar_map -> constr -> (constr * types) -> constr * constr * constr
+  env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr)
 
 (* The family cutRewriteIn expect an equality statement *)
-val cutRewriteInHyp : bool -> types -> identifier -> tactic
-val cutRewriteInConcl : bool -> constr -> tactic
+val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic
+val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic
 
 (* The family rewriteIn expect the proof of an equality *)
-val rewriteInHyp : bool -> constr -> identifier -> tactic
-val rewriteInConcl : bool -> constr -> tactic
-
-(* Expect the proof of an equality; fails with raw internal errors *)
-val substClause : bool -> constr -> identifier option -> tactic
+val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic
+val rewriteInConcl : bool -> constr -> unit Proofview.tactic
 
 val discriminable : env -> evar_map -> constr -> constr -> bool
 val injectable : env -> evar_map -> constr -> constr -> bool
 
 (* Subst *)
 
-val unfold_body : identifier -> tactic
+(* val unfold_body : Id.t -> tactic *)
 
 type subst_tactic_flags = {
   only_leibniz : bool;
   rewrite_dependent_proof : bool
 }
-val subst_gen : bool -> identifier list -> tactic
-val subst : identifier list -> tactic
-val subst_all : ?flags:subst_tactic_flags -> tactic
+val subst_gen : bool -> Id.t list -> unit Proofview.tactic
+val subst : Id.t list -> unit Proofview.tactic
+val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic
 
 (* Replace term *)
-(* [replace_multi_term dir_opt c cl]
+(* [replace_term dir_opt c cl]
    perfoms replacement of [c] by the first value found in context
    (according to [dir] if given to get the rewrite direction)  in the clause [cl]
 *)
-val replace_multi_term : bool option -> constr -> clause -> tactic
+val replace_term : bool option -> constr -> clause -> unit Proofview.tactic
 
 val set_eq_dec_scheme_kind : mutual scheme_kind -> unit
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index e9a041d7..2aafaf08 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -1,57 +1,79 @@
 (************************************************************************)
 (*  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 Term
 open Util
+open Errors
 open Evar_refiner
 open Tacmach
 open Tacexpr
 open Refiner
-open Proof_type
 open Evd
-open Sign
-open Termops
+open Locus
 
 (* The instantiate tactic *)
 
-let instantiate n (ist,rawc) ido gl =
+let instantiate_evar evk (ist,rawc) sigma =
+  let evi = Evd.find sigma evk in
+  let filtered = Evd.evar_filtered_env evi in
+  let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in
+  let lvar = {
+    Pretyping.ltac_constrs = constrvars;
+    ltac_uconstrs = Names.Id.Map.empty;
+    ltac_idents = Names.Id.Map.empty;
+    ltac_genargs = ist.Geninterp.lfun;
+  } in
+  let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in
+  tclEVARS sigma'
+
+let instantiate_tac n c ido =
+  Proofview.V82.tactic begin fun gl ->
   let sigma = gl.sigma in
   let evl =
     match ido with
-	ConclLocation () -> evar_list sigma (pf_concl gl)
+	ConclLocation () -> evar_list (pf_concl gl)
       | HypLocation (id,hloc) ->
 	  let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in
 	    match hloc with
 		InHyp ->
 		  (match decl with
-		      (_,None,typ) -> evar_list sigma typ
+		      (_,None,typ) -> evar_list typ
 		    | _ -> error
 			"Please be more specific: in type or value?")
 	      | InHypTypeOnly ->
-		  let (_, _, typ) = decl in evar_list sigma typ
+		  let (_, _, typ) = decl in evar_list typ
 	      | InHypValueOnly ->
 		  (match decl with
-		      (_,Some body,_) -> evar_list sigma body
+		      (_,Some body,_) -> evar_list body
 		    | _ -> error "Not a defined hypothesis.") in
-    if List.length evl < n then
-      error "Not enough uninstantiated existential variables.";
-    if n <= 0 then error "Incorrect existential variable index.";
-    let evk,_ = List.nth evl (n-1) in
-    let evi = Evd.find sigma evk in
-    let ltac_vars = Tacinterp.extract_ltac_constr_values ist (Evd.evar_env evi) in
-    let sigma' = w_refine (evk,evi) (ltac_vars,rawc) sigma in
-      tclTHEN
-        (tclEVARS sigma')
-        tclNORMEVAR
-        gl
+  if List.length evl < n then
+    error "Not enough uninstantiated existential variables.";
+  if n <= 0 then error "Incorrect existential variable index.";
+  let evk,_ = List.nth evl (n-1) in
+  instantiate_evar evk c sigma gl
+  end
+
+let instantiate_tac_by_name id c =
+  Proofview.V82.tactic begin fun gl ->
+  let sigma = gl.sigma in
+  let evk =
+    try Evd.evar_key id sigma
+    with Not_found -> error "Unknown existential variable." in
+  instantiate_evar evk c sigma gl
+  end
 
-let let_evar name typ gls =
-  let src = (dummy_loc,GoalEvar) in
-  let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) ~src typ in
-  Refiner.tclTHEN (Refiner.tclEVARS sigma')
-    (Tactics.letin_tac None name evar None nowhere) gls
+let let_evar name typ =
+  let src = (Loc.ghost,Evar_kinds.GoalEvar) in
+  Proofview.Goal.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let id = Namegen.id_of_name_using_hdchar env typ name in
+    let id = Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) in
+    let sigma',evar = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
+    Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS sigma'))
+      (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere)
+  end
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index f4e1ed80..42d00e1e 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.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        *)
@@ -9,9 +9,12 @@
 open Tacmach
 open Names
 open Tacexpr
-open Termops
+open Locus
 
-val instantiate : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
-  (identifier * hyp_location_flag, unit) location -> tactic
+val instantiate_tac : int -> Tacinterp.interp_sign * Glob_term.glob_constr ->
+  (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic
 
-val let_evar : name -> Term.types -> tactic
+val instantiate_tac_by_name : Id.t ->
+  Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic
+
+val let_evar : Name.t -> Term.types -> unit Proofview.tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index 88271fd6..47987e9e 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -1,20 +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        *)
 (************************************************************************)
 
-(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
-open Pcoq
 open Genarg
 open Names
 open Tacexpr
+open Taccoerce
 open Tacinterp
-open Termops
+open Misctypes
+open Locus
 
 (* Rewriting orientation *)
 
@@ -34,29 +35,35 @@ END
 let pr_orient = pr_orient () () ()
 
 
-let pr_int_list = Util.pr_sequence Pp.int
+let pr_int_list = Pp.pr_sequence Pp.int
 let pr_int_list_full _prc _prlc _prt l = pr_int_list l
 
-open Glob_term
-
 let pr_occurrences _prc _prlc _prt l =
   match l with
     | ArgArg x -> pr_int_list x
     | ArgVar (loc, id) -> Nameops.pr_id id
 
-let coerce_to_int = function
-  | VInteger n -> n
-  | v -> raise (CannotCoerceTo "an integer")
+let occurrences_of = function
+  | [] -> NoOccurrences
+  | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl)
+  | nl ->
+      if List.exists (fun n -> n < 0) nl then
+        Errors.error "Illegal negative occurrence number.";
+      OnlyOccurrences nl
+
+let coerce_to_int v = match Value.to_int v with
+  | None -> raise (CannotCoerceTo "an integer")
+  | Some n -> n
 
-let int_list_of_VList = function
-  | VList l -> List.map (fun n -> coerce_to_int n) l
-  | _ -> raise Not_found
+let int_list_of_VList v = match Value.to_list v with
+| Some l -> List.map (fun n -> coerce_to_int n) l
+| _ -> raise (CannotCoerceTo "an integer")
 
 let interp_occs ist gl l =
   match l with
     | ArgArg x -> x
     | ArgVar (_,id as locid) ->
-	(try int_list_of_VList (List.assoc id ist.lfun)
+	(try int_list_of_VList (Id.Map.find id ist.lfun)
 	  with Not_found | CannotCoerceTo _ -> [interp_int ist locid])
 let interp_occs ist gl l =
   Tacmach.project gl , interp_occs ist gl l
@@ -65,9 +72,6 @@ let glob_occs ist l = l
 
 let subst_occs evm l = l
 
-type occurrences_or_var = int list or_var
-type occurrences = int list
-
 ARGUMENT EXTEND occurrences
   PRINTED BY pr_int_list_full
 
@@ -93,9 +97,9 @@ let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
 
 let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t)
 
-let glob_glob = Tacinterp.intern_constr
+let glob_glob = Tacintern.intern_constr
 
-let subst_glob = Tacinterp.subst_glob_constr_and_expr
+let subst_glob = Tacsubst.subst_glob_constr_and_expr
 
 ARGUMENT EXTEND glob
     PRINTED BY pr_globc
@@ -109,14 +113,28 @@ ARGUMENT EXTEND glob
 
      GLOB_TYPED AS glob_constr_and_expr
      GLOB_PRINTED BY pr_gen
-  [ lconstr(c) ] -> [ c ]
+  [ constr(c) ] -> [ c ]
 END
 
+ARGUMENT EXTEND lglob
+    PRINTED BY pr_globc
+
+     INTERPRETED BY interp_glob
+     GLOBALIZED BY glob_glob
+     SUBSTITUTED BY subst_glob
+
+     RAW_TYPED AS constr_expr
+     RAW_PRINTED BY pr_gen
+
+     GLOB_TYPED AS glob_constr_and_expr
+     GLOB_PRINTED BY pr_gen
+  [ lconstr(c) ] -> [ c ]
+END
 
 type 'id gen_place= ('id * hyp_location_flag,unit) location
 
-type loc_place = identifier Util.located gen_place
-type place = identifier gen_place
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
 
 let pr_gen_place pr_id = function
     ConclLocation () -> Pp.mt ()
@@ -132,14 +150,14 @@ let pr_hloc = pr_loc_place () () ()
 
 let intern_place ist = function
     ConclLocation () -> ConclLocation ()
-  | HypLocation (id,hl) -> HypLocation (intern_hyp ist id,hl)
+  | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl)
 
-let interp_place ist gl = function
+let interp_place ist env sigma = function
     ConclLocation () -> ConclLocation ()
-  | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
+  | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl)
 
 let interp_place ist gl p =
-  Tacmach.project gl , interp_place ist gl p
+  Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p
 
 let subst_place subst pl = pl
 
@@ -157,11 +175,11 @@ ARGUMENT EXTEND hloc
   |  [ "in" "|-" "*" ] ->
     [ ConclLocation () ]
 | [ "in" ident(id) ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHyp) ]
+    [ HypLocation ((Loc.ghost,id),InHyp) ]
 | [ "in" "(" "Type" "of" ident(id) ")" ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ]
+    [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ]
 | [ "in" "(" "Value" "of" ident(id) ")" ] ->
-    [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ]
+    [ HypLocation ((Loc.ghost,id),InHypValueOnly) ]
 
  END
 
@@ -187,115 +205,16 @@ END
 
 let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c
 
-let pr_in_hyp  pr_id (lo,concl) :  Pp.std_ppcmds =
-  match lo,concl with
-    | Some [],true -> mt ()
-    | None,true -> str "in" ++ spc () ++ str "*"
-    | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-"
-    | Some l,_ ->
-	str "in" ++
-         spc () ++ Util.prlist_with_sep Util.pr_comma pr_id l ++
-	  match concl with
-	    | true -> spc () ++ str "|-" ++ spc () ++ str "*"
-	    | _ -> mt ()
-
-
-let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id)
-
-let pr_in_arg_hyp_typed  _ _  _  = pr_in_hyp Ppconstr.pr_id
-
-
-let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id
-
-let pr_var_list_typed _ _ _ =  pr_var_list_gen Ppconstr.pr_id
-
-let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id)
-
-
-ARGUMENT EXTEND comma_var_lne
-  PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list
-  RAW_PRINTED BY pr_var_list
-  GLOB_TYPED AS var list
-  GLOB_PRINTED BY pr_var_list
-| [ var(x) ] -> [ [x] ]
-| [ var(x) "," comma_var_lne(l) ] -> [x::l]
-END
-
-ARGUMENT EXTEND comma_var_l
-  PRINTED BY pr_var_list_typed
-  RAW_TYPED AS var list
-  RAW_PRINTED BY pr_var_list
-  GLOB_TYPED AS var list
-  GLOB_PRINTED BY pr_var_list
-| [  comma_var_lne(l) ] -> [l]
-| [] -> [ [] ]
-END
-
-let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-"
-
-ARGUMENT EXTEND inconcl
-  TYPED AS bool
-  PRINTED BY pr_in_concl
-| [ "|-" "*" ] -> [ true ]
-| [ "|-" ] -> [ false ]
-END
-
-
-
-ARGUMENT EXTEND in_arg_hyp
-  PRINTED BY pr_in_arg_hyp_typed
-  RAW_TYPED AS var list option * bool
-  RAW_PRINTED BY pr_in_arg_hyp
-  GLOB_TYPED AS var list option * bool
-  GLOB_PRINTED BY pr_in_arg_hyp
-| [ "in" "*" ] -> [(None,true)]
-| [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)]
-| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in
-					      Some l, onconcl
-					   ]
-| [ ] -> [ (Some [],true) ]
-END
-
-let pr_in_arg_hyp = pr_in_arg_hyp_typed () () ()
-
-let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause =
-  {Tacexpr.onhyps=
-   Option.map
-     (fun l ->
-	List.map
-	  (fun id -> ( (all_occurrences_expr,trad_id id),InHyp))
-	  l
-     )
-     hyps;
-   Tacexpr.concl_occs = if concl then all_occurrences_expr else no_occurrences_expr}
-
-
-let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd
-let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x)
-
-
-(* spiwack argument for the commands of the retroknowledge *)
-
-let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) =
-  Genarg.create_arg None "r_nat_field"
-let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) =
-  Genarg.create_arg None "r_n_field"
-let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) =
-  Genarg.create_arg None "r_int31_field"
-let (wit_r_field, globwit_r_field, rawwit_r_field) =
-  Genarg.create_arg None "r_field"
-
 (* spiwack: the print functions are incomplete, but I don't know what they are
 	used for *)
-let pr_r_nat_field _ _ _ natf =
+let pr_r_nat_field natf =
   str "nat " ++
   match natf with
     | Retroknowledge.NatType -> str "type"
     | Retroknowledge.NatPlus -> str "plus"
     | Retroknowledge.NatTimes -> str "times"
 
-let pr_r_n_field _ _ _ nf =
+let pr_r_n_field  nf =
   str "binary N " ++
   match nf with
     | Retroknowledge.NPositive -> str "positive"
@@ -307,7 +226,7 @@ let pr_r_n_field _ _ _ nf =
     | Retroknowledge.NPlus -> str "plus"
     | Retroknowledge.NTimes -> str "times"
 
-let pr_r_int31_field _ _ _ i31f =
+let pr_r_int31_field i31f =
   str "int31 " ++
   match i31f with
     | Retroknowledge.Int31Bits -> str "bits"
@@ -320,16 +239,15 @@ let pr_r_int31_field _ _ _ i31f =
     | Retroknowledge.Int31Times -> str "times"
     | _ -> assert false
 
-let pr_retroknowledge_field _ _ _ f =
+let pr_retroknowledge_field f =
   match f with
  (* | Retroknowledge.KEq -> str "equality"
   | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf
   | Retroknowledge.KN nf -> pr_r_n_field () () () nf *)
-  | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field () () () i31f) ++
+  | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++
                                            str "in " ++ str group
 
-ARGUMENT EXTEND retroknowledge_nat
-TYPED AS r_nat_field
+VERNAC ARGUMENT EXTEND retroknowledge_nat
 PRINTED BY pr_r_nat_field
 | [ "nat" "type" ] -> [ Retroknowledge.NatType ]
 | [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ]
@@ -337,8 +255,7 @@ PRINTED BY pr_r_nat_field
 END
 
 
-ARGUMENT EXTEND retroknowledge_binary_n
-TYPED AS r_n_field
+VERNAC ARGUMENT EXTEND retroknowledge_binary_n
 PRINTED BY pr_r_n_field
 | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ]
 | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ]
@@ -350,8 +267,7 @@ PRINTED BY pr_r_n_field
 | [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ]
 END
 
-ARGUMENT EXTEND retroknowledge_int31
-TYPED AS r_int31_field
+VERNAC ARGUMENT EXTEND retroknowledge_int31
 PRINTED BY pr_r_int31_field
 | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ]
 | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ]
@@ -369,15 +285,17 @@ PRINTED BY pr_r_int31_field
 | [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ]
 | [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ]
 | [ "int31" "div" ] -> [ Retroknowledge.Int31Div ]
+| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ]
 | [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ]
 | [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ]
 | [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ]
 | [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ]
-
+| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ]
+| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ]
+| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ]
 END
 
-ARGUMENT EXTEND retroknowledge_field
-TYPED AS r_field
+VERNAC ARGUMENT EXTEND retroknowledge_field
 PRINTED BY pr_retroknowledge_field
 (*| [ "equality" ] -> [ Retroknowledge.KEq ]
 | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ]
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 8a0ae066..ef084e9d 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -1,55 +1,54 @@
 (************************************************************************)
 (*  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 Tacexpr
-open Term
 open Names
-open Proof_type
-open Topconstr
-open Termops
+open Constrexpr
 open Glob_term
+open Misctypes
 
-val rawwit_orient : bool raw_abstract_argument_type
-val globwit_orient : bool glob_abstract_argument_type
-val wit_orient : bool typed_abstract_argument_type
+val wit_orient : bool Genarg.uniform_genarg_type
 val orient : bool Pcoq.Gram.entry
 val pr_orient : bool -> Pp.std_ppcmds
 
 val occurrences : (int list or_var) Pcoq.Gram.entry
-val rawwit_occurrences : (int list or_var) raw_abstract_argument_type
-val wit_occurrences : (int list) typed_abstract_argument_type
-val pr_occurrences : int list Glob_term.or_var -> Pp.std_ppcmds
+val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type
+val pr_occurrences : int list or_var -> Pp.std_ppcmds
+val occurrences_of : int list -> Locus.occurrences
+
+val wit_glob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
+
+val wit_lglob :
+  (constr_expr,
+  Tacexpr.glob_constr_and_expr,
+  Tacinterp.interp_sign * glob_constr) Genarg.genarg_type
 
-val rawwit_glob : constr_expr raw_abstract_argument_type
-val wit_glob : (Tacinterp.interp_sign * glob_constr) typed_abstract_argument_type
 val glob : constr_expr Pcoq.Gram.entry
+val lglob : constr_expr Pcoq.Gram.entry
 
-type 'id gen_place= ('id * hyp_location_flag,unit) location
+type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location
 
-type loc_place = identifier Util.located gen_place
-type place = identifier gen_place
+type loc_place = Id.t Loc.located gen_place
+type place = Id.t gen_place
 
-val rawwit_hloc : loc_place raw_abstract_argument_type
-val wit_hloc : place typed_abstract_argument_type
+val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type
 val hloc : loc_place Pcoq.Gram.entry
 val pr_hloc : loc_place -> Pp.std_ppcmds
 
-val in_arg_hyp:  (Names.identifier Util.located list option * bool)  Pcoq.Gram.entry
-val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type
-val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
-val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
-val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause
-val glob_in_arg_hyp_to_clause :  (Names.identifier list option * bool)  -> Tacticals.clause
-val pr_in_arg_hyp : (Names.identifier list option * bool) -> Pp.std_ppcmds
-
 val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry
-val rawwit_by_arg_tac :  raw_tactic_expr option raw_abstract_argument_type
-val wit_by_arg_tac : glob_tactic_expr option typed_abstract_argument_type
+val wit_by_arg_tac :
+  (raw_tactic_expr option,
+  glob_tactic_expr option,
+  glob_tactic_expr option) Genarg.genarg_type
+
 val pr_by_arg_tac : 
   (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) ->
   raw_tactic_expr option -> Pp.std_ppcmds
@@ -58,5 +57,4 @@ val pr_by_arg_tac :
 (** Spiwack: Primitive for retroknowledge registration *)
 
 val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry
-val rawwit_retroknowledge_field :  Retroknowledge.field raw_abstract_argument_type
-val wit_retroknowledge_field : Retroknowledge.field typed_abstract_argument_type
+val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index 6fd95f16..f3482c31 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -1,26 +1,29 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Pp
-open Pcoq
 open Genarg
 open Extraargs
 open Mod_subst
 open Names
 open Tacexpr
-open Glob_term
+open Glob_ops
 open Tactics
+open Errors
 open Util
 open Evd
 open Equality
-open Compat
+open Misctypes
+open Proofview.Notations
+
+DECLARE PLUGIN "extratactics"
 
 (**********************************************************************)
 (* admit, replace, discriminate, injection, simplify_eq               *)
@@ -30,76 +33,46 @@ TACTIC EXTEND admit
   [ "admit" ] -> [ admit_as_an_axiom ]
 END
 
-
-
-let classes_dirpath =
-  make_dirpath (List.map id_of_string ["Classes";"Coq"])
-
-let init_setoid () =
-  if Libnames.is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
-  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
-
-
-let occurrences_of occs = 
-  let loccs = match occs with 
-  | n::_ as nl when n < 0 -> (false,List.map (fun n -> ArgArg (abs n)) nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true, List.map (fun n -> (ArgArg n)) nl)
-  in 
-  init_setoid ();
-  {onhyps = Some []; concl_occs =loccs}
-
-let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac =
-  Refiner.tclWITHHOLES false
+let replace_in_clause_maybe_by (sigma,c1) c2 cl  tac =
+  Proofview.Unsafe.tclEVARS sigma <*>
     (replace_in_clause_maybe_by c1 c2 cl)
-    sigma1
     (Option.map Tacinterp.eval_tactic tac)
 
-let replace_multi_term dir_opt (sigma,c) in_hyp =
-  Refiner.tclWITHHOLES false
-    (replace_multi_term dir_opt c)
-    sigma
-    (glob_in_arg_hyp_to_clause in_hyp)
+let replace_term dir_opt (sigma,c) cl =
+  Proofview.Unsafe.tclEVARS sigma <*>
+    (replace_term dir_opt c) cl
 
 TACTIC EXTEND replace
-   ["replace" open_constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) tac ]
-END
-
-TACTIC EXTEND replace_at
-   ["replace" open_constr(c1) "with" constr(c2) "at" occurrences(occs) by_arg_tac(tac) ]
--> [ replace_in_clause_maybe_by c1 c2 (occurrences_of occs) tac ]
+   ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ]
+-> [ replace_in_clause_maybe_by c1 c2 cl tac ]
 END
 
-
 TACTIC EXTEND replace_term_left
-  [ "replace"  "->" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term (Some true) c in_hyp]
+  [ "replace"  "->" open_constr(c) clause(cl) ]
+  -> [ replace_term (Some true) c cl ]
 END
 
 TACTIC EXTEND replace_term_right
-  [ "replace"  "<-" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [replace_multi_term (Some false) c in_hyp]
+  [ "replace"  "<-" open_constr(c) clause(cl) ]
+  -> [ replace_term (Some false) c cl ]
 END
 
 TACTIC EXTEND replace_term
-  [ "replace" open_constr(c) in_arg_hyp(in_hyp) ]
-  -> [ replace_multi_term None c in_hyp ]
+  [ "replace" open_constr(c) clause(cl) ]
+  -> [ replace_term None c cl ]
 END
 
 let induction_arg_of_quantified_hyp = function
-  | AnonHyp n -> ElimOnAnonHyp n
-  | NamedHyp id -> ElimOnIdent (Util.dummy_loc,id)
+  | AnonHyp n -> None,ElimOnAnonHyp n
+  | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id)
 
 (* Versions *_main must come first!! so that "1" is interpreted as a
    ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a
    ElimOnIdent and not as "constr" *)
 
 let elimOnConstrWithHoles tac with_evars c =
-  Refiner.tclWITHHOLES with_evars (tac with_evars) 
-    c.sigma (Some (ElimOnConstr c.it))
+  Tacticals.New.tclWITHHOLES with_evars (tac with_evars) 
+    c.sigma (Some (None,ElimOnConstr c.it))
 
 TACTIC EXTEND simplify_eq_main
 | [ "simplify_eq" constr_with_bindings(c) ] ->
@@ -120,9 +93,11 @@ TACTIC EXTEND esimplify_eq
     [ dEq true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
+let discr_main c = elimOnConstrWithHoles discr_tac false c
+
 TACTIC EXTEND discriminate_main
 | [ "discriminate" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles discr_tac false c ]
+    [ discr_main c ]
 END
 TACTIC EXTEND discriminate
 | [ "discriminate" ] -> [ discr_tac false None ]
@@ -139,49 +114,55 @@ TACTIC EXTEND ediscriminate
     [ discr_tac true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_discrHyp id gl =
-  h_discriminate_main {it = Term.mkVar id,NoBindings; sigma = Refiner.project gl} gl
+open Proofview.Notations
+let discrHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;}
+
+let injection_main c =
+ elimOnConstrWithHoles (injClause None) false c
 
 TACTIC EXTEND injection_main
 | [ "injection" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles (injClause []) false c ]
+    [ injection_main c ]
 END
 TACTIC EXTEND injection
-| [ "injection" ] -> [ injClause [] false None ]
+| [ "injection" ] -> [ injClause None false None ]
 | [ "injection" quantified_hypothesis(h) ] ->
-    [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause None false (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND einjection_main
 | [ "einjection" constr_with_bindings(c) ] ->
-    [ elimOnConstrWithHoles (injClause []) true c ]
+    [ elimOnConstrWithHoles (injClause None) true c ]
 END
 TACTIC EXTEND einjection
-| [ "einjection" ] -> [ injClause [] true None ]
-| [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ]
+| [ "einjection" ] -> [ injClause None true None ]
+| [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND injection_as_main
 | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ elimOnConstrWithHoles (injClause ipat) false c ]
+    [ elimOnConstrWithHoles (injClause (Some ipat)) false c ]
 END
 TACTIC EXTEND injection_as
 | [ "injection" "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat false None ]
+    [ injClause (Some ipat) false None ]
 | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ]
 END
 TACTIC EXTEND einjection_as_main
 | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] ->
-    [ elimOnConstrWithHoles (injClause ipat) true c ]
+    [ elimOnConstrWithHoles (injClause (Some ipat)) true c ]
 END
 TACTIC EXTEND einjection_as
 | [ "einjection" "as" simple_intropattern_list(ipat)] ->
-    [ injClause ipat true None ]
+    [ injClause (Some ipat) true None ]
 | [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] ->
-    [ injClause ipat true (Some (induction_arg_of_quantified_hyp h)) ]
+    [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ]
 END
 
-let h_injHyp id gl =
-  h_injection_main { it = Term.mkVar id,NoBindings; sigma = Refiner.project gl } gl
+let injHyp id =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; }
 
 TACTIC EXTEND dependent_rewrite
 | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ]
@@ -189,6 +170,10 @@ TACTIC EXTEND dependent_rewrite
     -> [ rewriteInHyp b c id ]
 END
 
+(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to
+    "replace u with t" or "enough (t=u) as <-" and 
+    "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *)
+
 TACTIC EXTEND cut_rewrite
 | [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ]
 | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ]
@@ -196,6 +181,17 @@ TACTIC EXTEND cut_rewrite
 END
 
 (**********************************************************************)
+(* Decompose                                                          *)
+
+TACTIC EXTEND decompose_sum
+| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ]
+END
+
+TACTIC EXTEND decompose_record
+| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ]
+END
+
+(**********************************************************************)
 (* Contradiction                                                      *)
 
 open Contradiction
@@ -206,7 +202,7 @@ END
 
 let onSomeWithHoles tac = function
   | None -> tac None
-  | Some c -> Refiner.tclWITHHOLES false tac c.sigma (Some c.it)
+  | Some c -> Proofview.Unsafe.tclEVARS c.sigma <*> tac (Some c.it)
 
 TACTIC EXTEND contradiction
  [ "contradiction" constr_with_bindings_opt(c) ] ->
@@ -230,22 +226,19 @@ ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_stri
 END
 
 TACTIC EXTEND autorewrite
-| [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
-    [ auto_multi_rewrite  l (glob_in_arg_hyp_to_clause  cl) ]
-| [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite  l ( cl) ]
+| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
     [
-      let cl =  glob_in_arg_hyp_to_clause cl in
       auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl
-
     ]
 END
 
 TACTIC EXTEND autorewrite_star
-| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] ->
-    [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause  cl) ]
-| [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] ->
-    [ let cl =  glob_in_arg_hyp_to_clause cl in
-	auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] ->
+    [ auto_multi_rewrite ~conds:AllMatches l cl ]
+| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] ->
+  [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ]
 END
 
 (**********************************************************************)
@@ -253,15 +246,8 @@ END
 
 let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) =
   let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in
-  Refiner. tclWITHHOLES false
-    (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings)) sigma true
-
-let occurrences_of = function
-  | n::_ as nl when n < 0 -> (false,List.map abs nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true,nl)
+  Proofview.Unsafe.tclEVARS sigma <*>
+    general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true
 
 TACTIC EXTEND rewrite_star
 | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] ->
@@ -269,45 +255,62 @@ TACTIC EXTEND rewrite_star
 | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] ->
     [ rewrite_star (Some id) o (occurrences_of occ) c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] ->
-    [ rewrite_star (Some id) o Termops.all_occurrences c tac ]
+    [ rewrite_star (Some id) o Locus.AllOccurrences c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] ->
     [ rewrite_star None o (occurrences_of occ) c tac ]
 | [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] ->
-    [ rewrite_star None o Termops.all_occurrences c tac ]
+    [ rewrite_star None o Locus.AllOccurrences c tac ]
     END
 
 (**********************************************************************)
 (* Hint Rewrite                                                       *)
 
-let add_rewrite_hint name ort t lcsr =
+let add_rewrite_hint bases ort t lcsr =
   let env = Global.env() and sigma = Evd.empty in
-  let f c = Topconstr.constr_loc c, Constrintern.interp_constr sigma env c, ort, t in
-  add_rew_rules name (List.map f lcsr)
-
-VERNAC COMMAND EXTEND HintRewrite
-  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] ->
-  [ add_rewrite_hint b o (Tacexpr.TacId []) l ]
+  let poly = Flags.is_universe_polymorphism () in 
+  let f ce = 
+    let c, ctx = Constrintern.interp_constr env sigma ce in
+    let ctx =
+      if poly then 
+	Evd.evar_universe_context_set ctx
+      else 
+	let cstrs = Evd.evar_universe_context_constraints ctx in
+	  (Global.add_constraints cstrs; Univ.ContextSet.empty)
+    in
+      Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in
+  let eqs = List.map f lcsr in
+  let add_hints base = add_rew_rules base eqs in
+  List.iter add_hints bases
+
+let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater
+
+VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint
+  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o None l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
-    ":" preident(b) ] ->
-  [ add_rewrite_hint b o t l ]
+    ":" preident_list(bl) ] ->
+  [ add_rewrite_hint bl o (Some t) l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] ->
-  [ add_rewrite_hint "core" o (Tacexpr.TacId []) l ]
+  [ add_rewrite_hint ["core"] o None l ]
 | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] ->
-  [ add_rewrite_hint "core" o t l ]
+  [ add_rewrite_hint ["core"] o (Some t) l ]
 END
 
 (**********************************************************************)
 (* Hint Resolve                                                       *)
 
 open Term
+open Vars
 open Coqlib
 
-let project_hint pri l2r c =
+let project_hint pri l2r r =
+  let gr = Smartlocate.global_with_alias r in
   let env = Global.env() in
-  let c = Constrintern.interp_constr Evd.empty env c in
-  let t = Retyping.get_type_of env Evd.empty c in
+  let sigma = Evd.from_env env in
+  let sigma, c = Evd.fresh_global env sigma gr in
+  let t = Retyping.get_type_of env sigma c in
   let t =
-    Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in
+    Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in
   let sign,ccl = decompose_prod_assum t in
   let (a,b) = match snd (decompose_app ccl) with
     | [a;b] -> (a,b)
@@ -317,82 +320,91 @@ let project_hint pri l2r c =
   let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in
   let c = it_mkLambda_or_LetIn
     (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
-  (pri,true,Auto.PathAny,c)
+  let id =
+    Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
+  in
+  let ctx = Evd.universe_context_set sigma in
+  let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in
+    (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c))
 
 let add_hints_iff l2r lc n bl =
-  Auto.add_hints true bl
-    (Auto.HintsResolveEntry (List.map (project_hint n l2r) lc))
+  Hints.add_hints true bl
+    (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc))
 
-VERNAC COMMAND EXTEND HintResolveIffLR
-  [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n)
+VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n)
     ":" preident_list(bl) ] ->
   [ add_hints_iff true lc n bl ]
-| [ "Hint" "Resolve" "->" ne_constr_list(lc) natural_opt(n) ] ->
+| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] ->
   [ add_hints_iff true lc n ["core"] ]
 END
-VERNAC COMMAND EXTEND HintResolveIffRL
-  [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n)
+VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF
+  [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n)
     ":" preident_list(bl) ] ->
   [ add_hints_iff false lc n bl ]
-| [ "Hint" "Resolve" "<-" ne_constr_list(lc) natural_opt(n) ] ->
+| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] ->
   [ add_hints_iff false lc n ["core"] ]
 END
 
 (**********************************************************************)
 (* Refine                                                             *)
 
-open Refine
+let refine_tac {Glob_term.closure=closure;term=term} =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let flags = Pretyping.all_no_fail_flags in
+    let tycon = Pretyping.OfType concl in
+    let lvar = { Pretyping.empty_lvar with
+      Pretyping.ltac_constrs = closure.Glob_term.typed;
+      Pretyping.ltac_uconstrs = closure.Glob_term.untyped;
+      Pretyping.ltac_idents = closure.Glob_term.idents;
+    } in
+    let update evd = Pretyping.understand_ltac flags env evd lvar tycon term in
+    Tactics.New.refine ~unsafe:false update
+  end
 
 TACTIC EXTEND refine
-  [ "refine" casted_open_constr(c) ] -> [ refine c ]
+  [ "refine" uconstr(c) ] -> [  refine_tac c ]
 END
 
-let refine_tac = h_refine
-
 (**********************************************************************)
 (* Inversion lemmas (Leminv)                                          *)
 
 open Inv
 open Leminv
 
-VERNAC COMMAND EXTEND DeriveInversionClear
-  [ "Derive" "Inversion_clear" ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_clear_tac ]
-
-| [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_clear_tac ]
+let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater
 
+VERNAC COMMAND EXTEND DeriveInversionClear
 | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
 
-| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (Glob_term.GProp Term.Null) false inv_clear_tac ]
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ]
 END
 
 open Term
-open Glob_term
 
 VERNAC COMMAND EXTEND DeriveInversion
 | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s false inv_tac ]
 
-| [ "Derive" "Inversion" ident(na) "with" constr(c) ]
-  -> [ add_inversion_lemma_exn na c (GProp Null) false inv_tac ]
-
-| [ "Derive" "Inversion" ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal 1 na id Term.prop_sort false inv_tac ]
-
-| [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ]
-  -> [ inversion_lemma_from_goal n na id Term.prop_sort false inv_tac ]
+| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ]
+  -> [ add_inversion_lemma_exn na c GProp false inv_tac ]
 END
 
 VERNAC COMMAND EXTEND DeriveDependentInversion
 | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s true dinv_tac ]
-    END
+END
 
 VERNAC COMMAND EXTEND DeriveDependentInversionClear
 | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  => [ seff na ]
   -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
 END
 
@@ -401,14 +413,14 @@ END
 
 TACTIC EXTEND subst
 | [ "subst" ne_var_list(l) ] -> [ subst l ]
-| [ "subst" ] -> [ fun gl -> subst_all gl ]
+| [ "subst" ] -> [ subst_all () ]
 END
 
 let simple_subst_tactic_flags =
   { only_leibniz = true; rewrite_dependent_proof = false }
 
 TACTIC EXTEND simple_subst
-| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags ]
+| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ]
 END
 
 open Evar_tactics
@@ -416,29 +428,28 @@ open Evar_tactics
 (**********************************************************************)
 (* Evar creation                                                      *)
 
+(* TODO: add support for some test similar to g_constr.name_colon so that
+   expressions like "evar (list A)" do not raise a syntax error *)
 TACTIC EXTEND evar
   [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ]
 | [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ]
 END
 
-open Tacexpr
 open Tacticals
 
 TACTIC EXTEND instantiate
-  [ "instantiate" "(" integer(i) ":=" glob(c) ")" hloc(hl) ] ->
-    [instantiate i c hl  ]
-| [ "instantiate" ] -> [ tclNORMEVAR ]
+  [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] ->
+    [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ]
+| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ]
 END
 
-
 (**********************************************************************)
 (** Nijmegen "step" tactic for setoid rewriting                       *)
 
 open Tactics
-open Tactics
-open Libnames
 open Glob_term
-open Summary
 open Libobject
 open Lib
 
@@ -447,8 +458,8 @@ open Lib
      x R y -> x == z -> z R y    (in the left table)
 *)
 
-let transitivity_right_table = ref []
-let transitivity_left_table = ref []
+let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r"
+let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l"
 
 (* [step] tries to apply a rewriting lemma; then apply [tac] intended to
    complete to proof of the last hypothesis (assumed to state an equality) *)
@@ -456,12 +467,12 @@ let transitivity_left_table = ref []
 let step left x tac =
   let l =
     List.map (fun lem ->
-      tclTHENLAST
-      (apply_with_bindings (lem, ImplicitBindings [x]))
+      Tacticals.New.tclTHENLAST
+        (apply_with_bindings (lem, ImplicitBindings [x]))
         tac)
       !(if left then transitivity_left_table else transitivity_right_table)
   in
-  tclFIRST l
+  Tacticals.New.tclFIRST l
 
 (* Main function to push lemmas in persistent environment *)
 
@@ -476,59 +487,43 @@ let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref)
 let inTransitivity : bool * constr -> obj =
   declare_object {(default_object "TRANSITIVITY-STEPS") with
     cache_function = cache_transitivity_lemma;
-    open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
+    open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o);
     subst_function = subst_transitivity_lemma;
     classify_function = (fun o -> Substitute o) }
 
-(* Synchronisation with reset *)
-
-let freeze () = !transitivity_left_table, !transitivity_right_table
-
-let unfreeze (l,r) =
-  transitivity_left_table := l;
-  transitivity_right_table := r
-
-let init () =
-  transitivity_left_table := [];
-  transitivity_right_table := []
-
-let _ =
-  declare_summary "transitivity-steps"
-    { freeze_function = freeze;
-      unfreeze_function = unfreeze;
-      init_function = init }
-
 (* Main entry points *)
 
 let add_transitivity_lemma left lem =
- let lem' = Constrintern.interp_constr Evd.empty (Global.env ()) lem in
+ let lem',ctx (*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty lem in
   add_anonymous_leaf (inTransitivity (left,lem'))
 
 (* Vernacular syntax *)
 
 TACTIC EXTEND stepl
 | ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ]
-| ["stepl" constr(c) ] -> [ step true c tclIDTAC ]
+| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ]
 END
 
 TACTIC EXTEND stepr
 | ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ]
-| ["stepr" constr(c) ] -> [ step false c tclIDTAC ]
+| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ]
 END
 
-VERNAC COMMAND EXTEND AddStepl
+VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF
 | [ "Declare" "Left" "Step" constr(t) ] ->
     [ add_transitivity_lemma true t ]
 END
 
-VERNAC COMMAND EXTEND AddStepr
+VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF
 | [ "Declare" "Right" "Step" constr(t) ] ->
     [ add_transitivity_lemma false t ]
 END
 
-VERNAC COMMAND EXTEND ImplicitTactic
+VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF
 | [ "Declare" "Implicit" "Tactic" tactic(tac) ] ->
     [ Pfedit.declare_implicit_tactic (Tacinterp.interp tac) ]
+| [ "Clear" "Implicit" "Tactic" ] ->
+    [ Pfedit.clear_implicit_tactic () ]
 END
 
 
@@ -537,10 +532,10 @@ END
 (**********************************************************************)
 (*spiwack : Vernac commands for retroknowledge                        *)
 
-VERNAC COMMAND EXTEND RetroknowledgeRegister
+VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF
  | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] ->
-           [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in
-             let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in
+           [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in
+             let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in
              Global.register f tc tb ]
 END
 
@@ -567,7 +562,7 @@ END
     during dependent induction. For internal use. *)
 
 TACTIC EXTEND specialize_eqs
-[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ]
+[ "specialize_eqs" hyp(id) ] -> [ Proofview.V82.tactic (specialize_eqs id) ]
 END
 
 (**********************************************************************)
@@ -579,26 +574,36 @@ END
 (**********************************************************************)
 
 let subst_var_with_hole occ tid t = 
-  let occref = if occ > 0 then ref occ else Termops.error_invalid_occurrence [occ] in
+  let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in
   let locref = ref 0 in
   let rec substrec = function
     | GVar (_,id) as x -> 
-        if id = tid 
-        then (decr occref; if !occref = 0 then x
-                           else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true))))
+        if Id.equal id tid 
+        then
+	  (decr occref;
+	   if Int.equal !occref 0 then x
+           else
+	     (incr locref;
+	      GHole (Loc.make_loc (!locref,0),
+		     Evar_kinds.QuestionMark(Evar_kinds.Define true),
+                     Misctypes.IntroAnonymous, None)))
         else x
     | c -> map_glob_constr_left_to_right substrec c in
   let t' = substrec t
   in
-  if !occref > 0 then Termops.error_invalid_occurrence [occ] else t'
+  if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t'
 
 let subst_hole_with_term occ tc t =
   let locref = ref 0 in
   let occref = ref occ in
   let rec substrec = function
-    | GHole (_,Evd.QuestionMark(Evd.Define true)) -> 
-        decr occref; if !occref = 0 then tc
-                     else (incr locref; GHole (make_loc (!locref,0),Evd.QuestionMark(Evd.Define true)))
+    | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) ->
+        decr occref;
+        if Int.equal !occref 0 then tc
+        else
+	  (incr locref;
+	   GHole (Loc.make_loc (!locref,0),
+		  Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s))
     | c -> map_glob_constr_left_to_right substrec c
   in
   substrec t
@@ -606,31 +611,38 @@ let subst_hole_with_term occ tc t =
 open Tacmach
 
 let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
   | ArgArg x -> x
 
-let hResolve id c occ t gl = 
-  let sigma = project gl in 
-  let env = Termops.clear_named_body id (pf_env gl) in
+let hResolve id c occ t =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let env = Termops.clear_named_body id (Proofview.Goal.env gl) in
+  let concl = Proofview.Goal.concl gl in
   let env_ids = Termops.ids_of_context env in
-  let env_names = Termops.names_of_rel_context env in
-  let c_raw = Detyping.detype true env_ids env_names c in 
-  let t_raw = Detyping.detype true env_ids env_names t in 
+  let c_raw = Detyping.detype true env_ids env sigma c in
+  let t_raw = Detyping.detype true env_ids env sigma t in
   let rec resolve_hole t_hole =
     try 
-      Pretyping.Default.understand sigma env t_hole
-    with 
-    | Loc.Exc_located (loc,Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _)) ->
-        resolve_hole (subst_hole_with_term (fst (unloc loc)) c_raw t_hole)
+      Pretyping.understand env sigma t_hole
+    with
+      | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e ->
+          let (e, info) = Errors.push e in
+          let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in
+          resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole)
   in
-  let t_constr = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in
+  let sigma = Evd.merge_universe_context sigma ctx in
   let t_constr_type = Retyping.get_type_of env sigma t_constr in
-  change_in_concl None (mkLetIn (Anonymous,t_constr,t_constr_type,pf_concl gl)) gl
+  Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARS sigma)
+    (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))
+  end
 
-let hResolve_auto id c t gl =
+let hResolve_auto id c t =
   let rec resolve_auto n = 
     try
-      hResolve id c n t gl
+      hResolve id c n t
     with
     | UserError _ as e -> raise e
     | e when Errors.noncritical e -> resolve_auto (n+1)
@@ -646,18 +658,18 @@ END
    hget_evar
 *)
 
-open Evar_refiner
-open Sign
-
-let hget_evar n gl =
-  let sigma = project gl in
-  let evl = evar_list sigma (pf_concl gl) in
+let hget_evar n =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma = Proofview.Goal.sigma gl in
+  let concl = Proofview.Goal.concl gl in
+  let evl = evar_list concl in
   if List.length evl < n then
     error "Not enough uninstantiated existential variables.";
   if n <= 0 then error "Incorrect existential variable index.";
   let ev = List.nth evl (n-1) in
   let ev_type = existential_type sigma ev in
-  change_in_concl None (mkLetIn (Anonymous,mkEvar ev,ev_type,pf_concl gl)) gl
+  change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))
+  end
 
 TACTIC EXTEND hget_evar
 | [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ]
@@ -673,12 +685,15 @@ END
 (* Contributed by Julien Forest and Pierre Courtieu (july 2010)       *)
 (**********************************************************************)
 
-exception Found of tactic
+exception Found of unit Proofview.tactic
 
-let rewrite_except h g =
-  tclMAP (fun id -> if id = h then tclIDTAC else 
-      tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true true id (mkVar h) false))
-    (Tacmach.pf_ids_of_hyps g) g
+let rewrite_except h =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let hyps = Tacmach.New.pf_ids_of_hyps gl in
+  Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else 
+      Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false))
+    hyps
+  end
 
 
 let refl_equal = 
@@ -691,31 +706,39 @@ let refl_equal =
 (* This is simply an implementation of the case_eq tactic.  this code
   should be replaced by a call to the tactic but I don't know how to
   call it before it is defined. *)
-let  mkCaseEq a  : tactic =
-     (fun g ->
-       let type_of_a = Tacmach.pf_type_of g a in
-       tclTHENLIST
-         [Hiddentac.h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
-          (fun g2 ->
-	    change_in_concl None
-	     (Tacred.pattern_occs [((false,[1]), a)] (Tacmach.pf_env g2) Evd.empty (Tacmach.pf_concl g2))
-		  g2);
-	  simplest_case a] g);;
-
-
-let case_eq_intros_rewrite x g =
-  let n = nb_prod (Tacmach.pf_concl g) in
-  Pp.msgnl (Printer.pr_lconstr x); 
-  tclTHENLIST [
+let  mkCaseEq a  : unit Proofview.tactic =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g a) gl in
+       Tacticals.New.tclTHENLIST
+         [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]);
+          Proofview.Goal.nf_enter begin fun gl ->
+            let concl = Proofview.Goal.concl gl in
+            let env = Proofview.Goal.env gl in
+	    change_concl
+	      (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl))
+          end;
+	  simplest_case a]
+  end
+
+
+let case_eq_intros_rewrite x =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let n = nb_prod (Proofview.Goal.concl gl) in
+  (* Pp.msgnl (Printer.pr_lconstr x); *)
+  Tacticals.New.tclTHENLIST [
       mkCaseEq x;
-      (fun g -> 
-	let n' = nb_prod (Tacmach.pf_concl g) in
-	let h = fresh_id (Tacmach.pf_ids_of_hyps g) (id_of_string "heq") g in
-	tclTHENLIST [ (tclDO (n'-n-1) intro);
-		      Tacmach.introduction h;
-		      rewrite_except h] g
-      )
-    ] g
+    Proofview.Goal.nf_enter begin fun gl ->
+      let concl = Proofview.Goal.concl gl in
+      let hyps = Tacmach.New.pf_ids_of_hyps gl in
+      let n' = nb_prod concl in
+      let h = Tacmach.New.of_old (fun g -> fresh_id hyps (Id.of_string "heq") g) gl in
+      Tacticals.New.tclTHENLIST [
+                    Tacticals.New.tclDO (n'-n-1) intro;
+		    introduction h;
+		    rewrite_except h]
+    end
+  ]
+  end
 
 let rec find_a_destructable_match t =
   match kind_of_term t with
@@ -724,40 +747,52 @@ let rec find_a_destructable_match t =
 	  (* TODO check there is no rel n. *)
 	  raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>)))
 	else
-	  let _ = Pp.msgnl (Printer.pr_lconstr x)  in
+	  (* let _ = Pp.msgnl (Printer.pr_lconstr x)  in *)
 	  raise (Found (case_eq_intros_rewrite x))
     | _ -> iter_constr find_a_destructable_match t
 	
 
 let destauto t =
   try find_a_destructable_match t;
-    error "No destructable match found"
+    Proofview.tclZERO (UserError ("",  str"No destructable match found"))
   with Found tac -> tac
 
-let destauto_in id g = 
-  let ctype = Tacmach.pf_type_of g (mkVar id) in
-  Pp.msgnl (Printer.pr_lconstr (mkVar id)); 
-  Pp.msgnl (Printer.pr_lconstr (ctype)); 
-  destauto ctype g
+let destauto_in id = 
+  Proofview.Goal.nf_enter begin fun gl ->
+  let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g (mkVar id)) gl in
+(*  Pp.msgnl (Printer.pr_lconstr (mkVar id)); *)
+(*  Pp.msgnl (Printer.pr_lconstr (ctype)); *)
+  destauto ctype
+  end
 
 TACTIC EXTEND destauto
-| [ "destauto" ] -> [ (fun g -> destauto (Tacmach.pf_concl g) g) ]
+| [ "destauto" ] -> [ Proofview.Goal.nf_enter (fun gl -> destauto (Proofview.Goal.concl gl)) ]
 | [ "destauto" "in" hyp(id) ] -> [ destauto_in id ]
 END
 
 
 (* ********************************************************************* *)
 
+let eq_constr x y = 
+  Proofview.Goal.enter (fun gl ->
+    let evd = Proofview.Goal.sigma gl in
+      if Evd.eq_constr_univs_test evd x y then Proofview.tclUNIT () 
+      else Tacticals.New.tclFAIL 0 (str "Not equal"))
+
 TACTIC EXTEND constr_eq
-| [ "constr_eq" constr(x) constr(y) ] -> [
-    if eq_constr x y then tclIDTAC else tclFAIL 0 (str "Not equal") ]
+| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ]
+END
+
+TACTIC EXTEND constr_eq_nounivs
+| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [
+    if eq_constr_nounivs x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ]
 END
 
 TACTIC EXTEND is_evar
 | [ "is_evar" constr(x) ] ->
     [ match kind_of_term x with
-        | Evar _ -> tclIDTAC
-        | _ -> tclFAIL 0 (str "Not an evar")
+        | Evar _ -> Proofview.tclUNIT ()
+        | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar")
     ]
 END
 
@@ -776,28 +811,36 @@ let rec has_evar x =
       has_evar t1 || has_evar t2 || has_evar_array ts
     | Fix ((_, tr)) | CoFix ((_, tr)) ->
       has_evar_prec tr
+    | Proj (p, c) -> has_evar c
 and has_evar_array x =
-  array_exists has_evar x
+  Array.exists has_evar x
 and has_evar_prec (_, ts1, ts2) =
-  array_exists has_evar ts1 || array_exists has_evar ts2
+  Array.exists has_evar ts1 || Array.exists has_evar ts2
 
 TACTIC EXTEND has_evar
 | [ "has_evar" constr(x) ] ->
-    [ if has_evar x then tclIDTAC else tclFAIL 0 (str "No evars") ]
+    [ if has_evar x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") ]
 END
 
 TACTIC EXTEND is_hyp
 | [ "is_var" constr(x) ] ->
   [ match kind_of_term x with
-    | Var _ -> tclIDTAC
-    | _ -> tclFAIL 0 (str "Not a variable or hypothesis") ]
+    | Var _ ->  Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ]
 END
 
 TACTIC EXTEND is_fix
 | [ "is_fix" constr(x) ] ->
   [ match kind_of_term x with
-    | Fix _ -> Tacticals.tclIDTAC
-    | _ -> Tacticals.tclFAIL 0 (Pp.str "not a fix definition") ]
+    | Fix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ]
+END;;
+
+TACTIC EXTEND is_cofix
+| [ "is_cofix" constr(x) ] ->
+  [ match kind_of_term x with
+    | CoFix _ -> Proofview.tclUNIT ()
+    | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ]
 END;;
 
 (* Command to grab the evars left unresolved at the end of a proof. *)
@@ -805,8 +848,169 @@ END;;
    the semantics of the LCF-style tactics, hence with the classic tactic
    mode. *)
 VERNAC COMMAND EXTEND GrabEvars
-[ "Grab" "Existential" "Variables" ] ->
-  [ let p = Proof_global.give_me_the_proof () in
-    Proof.V82.grab_evars p;
-    Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ]
+[ "Grab" "Existential" "Variables" ]
+  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.V82.grab_evars p) ]
+END
+
+(* Shelves all the goals under focus. *)
+TACTIC EXTEND shelve
+| [ "shelve" ] ->
+    [ Proofview.shelve ]
+END
+
+(* Shelves the unifiable goals under focus, i.e. the goals which
+   appear in other goals under focus (the unfocused goals are not
+   considered). *)
+TACTIC EXTEND shelve_unifiable
+| [ "shelve_unifiable" ] ->
+    [ Proofview.shelve_unifiable ]
+END
+
+(* Command to add every unshelved variables to the focus *)
+VERNAC COMMAND EXTEND Unshelve
+[ "Unshelve" ]
+  => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ]
+  -> [ Proof_global.simple_with_current_proof (fun _ p  -> Proof.unshelve p) ]
+END
+
+(* Gives up on the goals under focus: the goals are considered solved,
+   but the proof cannot be closed until the user goes back and solve
+   these goals. *)
+TACTIC EXTEND give_up
+| [ "give_up" ] ->
+    [ Proofview.give_up ]
+END
+
+(* cycles [n] goals *)
+TACTIC EXTEND cycle
+| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ]
+END
+
+(* swaps goals number [i] and [j] *)
+TACTIC EXTEND swap
+| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ]
+END
+
+(* reverses the list of focused goals *)
+TACTIC EXTEND revgoals
+| [ "revgoals" ] -> [ Proofview.revgoals ]
+END
+
+
+type cmp =
+  | Eq
+  | Lt | Le
+  | Gt | Ge
+
+type 'i test =
+  | Test of cmp * 'i * 'i
+
+let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 None "cmp"
+let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type =
+  Genarg.make0 None "tactest"
+
+let pr_cmp = function
+  | Eq -> Pp.str"="
+  | Lt -> Pp.str"<"
+  | Le -> Pp.str"<="
+  | Gt -> Pp.str">"
+  | Ge -> Pp.str">="
+
+let pr_cmp' _prc _prlc _prt = pr_cmp
+
+let pr_test_gen f (Test(c,x,y)) =
+  Pp.(f x ++ pr_cmp c ++ f y)
+
+let pr_test = pr_test_gen (Pptactic.pr_or_var Pp.int)
+
+let pr_test' _prc _prlc _prt = pr_test
+
+let pr_itest = pr_test_gen Pp.int
+
+let pr_itest' _prc _prlc _prt = pr_itest
+
+
+
+ARGUMENT EXTEND comparison TYPED AS cmp PRINTED BY pr_cmp'
+| [ "="  ] -> [ Eq ]
+| [ "<"  ] -> [ Lt ]
+| [ "<=" ] -> [ Le ]
+| [ ">"  ] -> [ Gt ]
+| [ ">=" ] -> [ Ge ]
+    END
+
+let interp_test ist gls = function
+  | Test (c,x,y) ->
+      project gls ,
+      Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y)
+
+ARGUMENT EXTEND test
+  PRINTED BY pr_itest'
+  INTERPRETED BY interp_test
+  RAW_TYPED AS test
+  RAW_PRINTED BY pr_test'
+  GLOB_TYPED AS test
+  GLOB_PRINTED BY pr_test'
+| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ]
+END
+
+let interp_cmp = function
+  | Eq -> Int.equal
+  | Lt -> ((<):int->int->bool)
+  | Le -> ((<=):int->int->bool)
+  | Gt -> ((>):int->int->bool)
+  | Ge -> ((>=):int->int->bool)
+
+let run_test = function
+  | Test(c,x,y) -> interp_cmp c x y
+
+let guard tst =
+  if run_test tst then
+    Proofview.tclUNIT ()
+  else
+    let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in
+    Proofview.tclZERO (Errors.UserError("guard",msg))
+
+
+TACTIC EXTEND guard
+| [ "guard" test(tst) ] -> [ guard tst ]
+END
+
+let decompose l c =
+  Proofview.Goal.enter begin fun gl ->
+    let to_ind c =
+      if isInd c then Univ.out_punivs (destInd c)
+      else error "not an inductive type"
+    in
+    let l = List.map to_ind l in
+    Elim.h_decompose l c
+  end
+
+TACTIC EXTEND decompose
+| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ]
+END
+
+(** library/keys *)
+
+VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF
+| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ 
+  let it c = snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c) in 
+  let k1 = Keys.constr_key (it c) in
+  let k2 = Keys.constr_key (it c') in
+    match k1, k2 with
+    | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2
+    | _ -> () ]
+END
+
+VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY
+| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ]
+END
+
+
+VERNAC COMMAND EXTEND OptimizeProof
+| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Proof_global.compact_the_proof () ]
+| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] ->
+  [ Gc.compact () ]
 END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index 934d94fc..72c2679c 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -1,16 +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 Proof_type
+val discrHyp : Names.Id.t -> unit Proofview.tactic
+val injHyp : Names.Id.t -> unit Proofview.tactic
 
-val h_discrHyp : Names.identifier -> tactic
-val h_injHyp : Names.identifier -> tactic
+(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *)
 
-val refine_tac : Evd.open_constr -> tactic
-
-val onSomeWithHoles : ('a option -> tactic) -> 'a Evd.sigma option -> tactic
+val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic
diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml
new file mode 100644
index 00000000..fea0432a
--- /dev/null
+++ b/tactics/ftactic.ml
@@ -0,0 +1,86 @@
+(************************************************************************)
+(*  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 Proofview.Notations
+
+(** Focussing tactics *)
+
+type 'a focus =
+| Uniform of 'a
+| Depends of 'a list
+
+(** Type of tactics potentially goal-dependent. If it contains a [Depends],
+    then the length of the inner list is guaranteed to be the number of
+    currently focussed goals. Otherwise it means the tactic does not depends
+    on the current set of focussed goals. *)
+type 'a t = 'a focus Proofview.tactic
+
+let return (x : 'a) : 'a t = Proofview.tclUNIT (Uniform x)
+
+let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function
+| Uniform x -> f x
+| Depends l ->
+  let f arg = f arg >>= function
+  | Uniform x ->
+    (** We dispatch the uniform result on each goal under focus, as we know
+        that the [m] argument was actually dependent. *)
+    Proofview.Goal.goals >>= fun l ->
+    let ans = List.map (fun _ -> x) l in
+    Proofview.tclUNIT ans
+  | Depends l -> Proofview.tclUNIT l
+  in
+  Proofview.tclDISPATCHL (List.map f l) >>= fun l ->
+  Proofview.tclUNIT (Depends (List.concat l))
+
+let nf_enter f =
+  bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l))
+    (fun gl ->
+      gl >>= fun gl ->
+      Proofview.Goal.normalize gl >>= fun nfgl ->
+      Proofview.V82.wrap_exceptions (fun () -> f nfgl))
+
+let enter f =
+  bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l))
+    (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl))
+
+let with_env t =
+  t >>= function
+    | Uniform a ->
+        Proofview.tclENV >>= fun env -> Proofview.tclUNIT (Uniform (env,a))
+    | Depends l ->
+        Proofview.Goal.goals >>= fun gs ->
+        Proofview.Monad.(List.map (map Proofview.Goal.env) gs) >>= fun envs ->
+        Proofview.tclUNIT (Depends (List.combine envs l))
+
+let lift (type a) (t:a Proofview.tactic) : a t =
+  Proofview.tclBIND t (fun x -> Proofview.tclUNIT (Uniform x))
+
+(** If the tactic returns unit, we can focus on the goals if necessary. *)
+let run m k = m >>= function
+| Uniform v -> k v
+| Depends l ->
+  let tacs = List.map k l in
+  Proofview.tclDISPATCH tacs
+
+let (>>=) = bind
+
+let (<*>) = fun m n -> bind m (fun () -> n)
+
+module Self =
+struct
+  type 'a t = 'a focus Proofview.tactic
+  let return = return
+  let (>>=) = bind
+  let (>>) = (<*>)
+  let map f x = x >>= fun a -> return (f a)
+end
+
+module Ftac = Monad.Make(Self)
+module List = Ftac.List
+
+let debug_prompt = Tactic_debug.debug_prompt
diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli
new file mode 100644
index 00000000..48351567
--- /dev/null
+++ b/tactics/ftactic.mli
@@ -0,0 +1,67 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Potentially focussing tactics *)
+
+type +'a focus
+
+type +'a t = 'a focus Proofview.tactic
+(** The type of focussing tactics. A focussing tactic is like a normal tactic,
+    except that it is able to remember it have entered a goal. Whenever this is
+    the case, each subsequent effect of the tactic is dispatched on the
+    focussed goals. This is a monad. *)
+
+(** {5 Monadic interface} *)
+
+val return : 'a -> 'a t
+(** The unit of the monad. *)
+
+val bind : 'a t -> ('a -> 'b t) -> 'b t
+(** The bind of the monad. *)
+
+(** {5 Operations} *)
+
+val lift : 'a Proofview.tactic -> 'a t
+(** Transform a tactic into a focussing tactic. The resulting tactic is not
+    focussed. *)
+
+val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic
+(** Given a continuation producing a tactic, evaluates the focussing tactic. If
+    the tactic has not focussed, then the continuation is evaluated once.
+    Otherwise it is called in each of the currently focussed goals. *)
+
+(** {5 Focussing} *)
+
+val nf_enter : ([ `NF ] Proofview.Goal.t -> 'a t) -> 'a t
+(** Enter a goal. The resulting tactic is focussed. *)
+
+val enter : ([ `LZ ] Proofview.Goal.t -> 'a t) -> 'a t
+(** Enter a goal, without evar normalization. The resulting tactic is
+    focussed. *)
+
+val with_env : 'a t -> (Environ.env*'a) t
+(** [with_env t] returns, in addition to the return type of [t], an
+    environment, which is the global environment if [t] does not focus on
+    goals, or the local goal environment if [t] focuses on goals. *)
+
+(** {5 Notations} *)
+
+val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+(** Notation for {!bind}. *)
+
+val (<*>) : unit t -> 'a t -> 'a t
+(** Sequence. *)
+
+(** {5 List operations} *)
+
+module List : Monad.ListS with type 'a t := 'a t
+
+(** {5 Debug} *)
+
+val debug_prompt :
+  int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t
diff --git a/tactics/g_class.ml4 b/tactics/g_class.ml4
new file mode 100644
index 00000000..a55da35e
--- /dev/null
+++ b/tactics/g_class.ml4
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Misctypes
+open Class_tactics
+
+DECLARE PLUGIN "g_class"
+
+TACTIC EXTEND progress_evars
+  [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ]
+END
+
+(** Options: depth, debug and transparency settings. *)
+
+let set_transparency cl b =
+  List.iter (fun r ->
+    let gr = Smartlocate.global_with_alias r in
+    let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in
+      Classes.set_typeclass_transparency ev false b) cl
+
+VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [
+    set_transparency cl true ]
+END
+
+VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF
+| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [
+    set_transparency cl false ]
+END
+
+open Genarg
+
+let pr_debug _prc _prlc _prt b =
+  if b then Pp.str "debug" else Pp.mt()
+
+ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug
+| [ "debug" ] -> [ true ]
+| [ ] -> [ false ]
+END
+
+let pr_depth _prc _prlc _prt = function
+    Some i -> Pp.int i
+  | None -> Pp.mt()
+
+ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth
+| [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ]
+END
+
+(* true = All transparent, false = Opaque if possible *)
+
+VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF
+ | [ "Typeclasses" "eauto" ":=" debug(d) depth(depth) ] -> [
+     set_typeclasses_debug d;
+     set_typeclasses_depth depth
+   ]
+END
+
+TACTIC EXTEND typeclasses_eauto
+| [ "typeclasses" "eauto" "with" ne_preident_list(l) ] -> [ Proofview.V82.tactic (typeclasses_eauto l) ]
+| [ "typeclasses" "eauto" ] -> [ Proofview.V82.tactic (typeclasses_eauto ~only_classes:true [Hints.typeclasses_db]) ]
+END
+
+TACTIC EXTEND head_of_constr
+  [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ]
+END
+
+TACTIC EXTEND not_evar
+  [ "not_evar" constr(ty) ] -> [ not_evar ty ]
+END
+
+TACTIC EXTEND is_ground
+  [ "is_ground" constr(ty) ] -> [ Proofview.V82.tactic (is_ground ty) ]
+END
+
+TACTIC EXTEND autoapply
+  [ "autoapply" constr(c) "using" preident(i) ] -> [ Proofview.V82.tactic (autoapply c i) ]
+END
diff --git a/tactics/g_eqdecide.ml4 b/tactics/g_eqdecide.ml4
new file mode 100644
index 00000000..1bd8f075
--- /dev/null
+++ b/tactics/g_eqdecide.ml4
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Eqdecide
+
+DECLARE PLUGIN "g_eqdecide"
+
+TACTIC EXTEND decide_equality
+| [ "decide" "equality" ] -> [ decideEqualityGoal ]
+END
+
+TACTIC EXTEND compare
+| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+END
diff --git a/tactics/g_rewrite.ml4 b/tactics/g_rewrite.ml4
new file mode 100644
index 00000000..d60cc126
--- /dev/null
+++ b/tactics/g_rewrite.ml4
@@ -0,0 +1,263 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(* Syntax for rewriting with strategies *)
+
+open Names
+open Misctypes
+open Locus
+open Constrexpr
+open Glob_term
+open Geninterp
+open Extraargs
+open Tacmach
+open Tacticals
+open Rewrite
+
+DECLARE PLUGIN "g_rewrite"
+
+type constr_expr_with_bindings = constr_expr with_bindings
+type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings
+type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings
+
+let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
+let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
+let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
+let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
+let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l
+let subst_glob_constr_with_bindings s c =
+  Tacsubst.subst_glob_with_bindings s c
+
+ARGUMENT EXTEND glob_constr_with_bindings
+    PRINTED BY pr_glob_constr_with_bindings_sign
+
+    INTERPRETED BY interp_glob_constr_with_bindings
+    GLOBALIZED BY glob_glob_constr_with_bindings
+    SUBSTITUTED BY subst_glob_constr_with_bindings
+
+    RAW_TYPED AS constr_expr_with_bindings
+    RAW_PRINTED BY pr_constr_expr_with_bindings
+
+    GLOB_TYPED AS glob_constr_with_bindings
+    GLOB_PRINTED BY pr_glob_constr_with_bindings
+
+   [ constr_with_bindings(bl) ] -> [ bl ]
+END
+
+type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
+type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
+
+let interp_strategy ist gl s = 
+  let sigma = project gl in
+    sigma, strategy_of_ast s
+let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s
+let subst_strategy s str = str
+
+let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
+let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>"
+let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>"
+
+ARGUMENT EXTEND rewstrategy
+    PRINTED BY pr_strategy
+
+    INTERPRETED BY interp_strategy
+    GLOBALIZED BY glob_strategy
+    SUBSTITUTED BY subst_strategy
+
+    RAW_TYPED AS raw_strategy
+    RAW_PRINTED BY pr_raw_strategy
+
+    GLOB_TYPED AS glob_strategy
+    GLOB_PRINTED BY pr_glob_strategy
+
+    [ glob(c) ] -> [ StratConstr (c, true) ]
+  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
+  | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ]
+  | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ]
+  | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ]
+  | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ]
+  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ]
+  | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ]
+  | [ "id" ] -> [ StratId ]
+  | [ "fail" ] -> [ StratFail ]
+  | [ "refl" ] -> [ StratRefl ]
+  | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ]
+  | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ]
+  | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ]
+  | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ]
+  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ]
+  | [ "(" rewstrategy(h) ")" ] -> [ h ]
+  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ]
+  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
+  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
+  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
+  | [ "eval" red_expr(r) ] -> [ StratEval r ]
+  | [ "fold" constr(c) ] -> [ StratFold c ]
+END
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let db_strat db = StratUnary (Topdown, StratHints (false, db))
+let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db))
+
+let cl_rewrite_clause_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "cl_rewrite_clause_db" in
+      Profile.profile3 key cl_rewrite_clause_db
+  else cl_rewrite_clause_db
+
+TACTIC EXTEND rewrite_strat
+| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s (Some id)) ]
+| [ "rewrite_strat" rewstrategy(s) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_strat s None) ]
+| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db (Some id)) ]
+| [ "rewrite_db" preident(db) ] -> [ Proofview.V82.tactic (cl_rewrite_clause_db db None) ]
+END
+
+let clsubstitute o c =
+  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in
+    Tacticals.onAllHypsAndConcl
+      (fun cl ->
+        match cl with
+          | Some id when is_tac id -> tclIDTAC
+          | _ -> cl_rewrite_clause c o AllOccurrences cl)
+
+TACTIC EXTEND substitute
+| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ Proofview.V82.tactic (clsubstitute o c) ]
+END
+
+
+(* Compatibility with old Setoids *)
+
+TACTIC EXTEND setoid_rewrite
+   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
+   -> [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences None) ]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o AllOccurrences (Some id))]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) None)]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))]
+ | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
+      [ Proofview.V82.tactic (cl_rewrite_clause c o (occurrences_of occ) (Some id))]
+END
+
+VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
+
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None None ]
+  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) None ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation a aeq n None None (Some lemma3) ]
+END
+
+type binders_argtype = local_binder list
+
+let wit_binders =
+ (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type)
+
+let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders)
+
+open Pcoq
+
+GEXTEND Gram
+  GLOBAL: binders;
+    binders:
+    [ [ b = Pcoq.Constr.binders -> b ] ];
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
+        "reflexivity" "proved" "by" constr(lemma1)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None None ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF
+    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
+      "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
+  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+        "as" ident(n) ] ->
+      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF
+   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ]
+  | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+     [  add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ]
+  | [ "Add" "Morphism" constr(m) ":" ident(n) ]
+    (* This command may or may not open a goal *)
+    => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ]
+    -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ]
+  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ]
+  | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
+        "with" "signature" lconstr(s) "as" ident(n) ]
+    => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ]
+    -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ]
+END
+
+TACTIC EXTEND setoid_symmetry
+   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
+ | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
+END
+
+TACTIC EXTEND setoid_reflexivity
+[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
+END
+
+TACTIC EXTEND setoid_transitivity
+  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
+| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
+END
diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml
new file mode 100644
index 00000000..d44c4ac3
--- /dev/null
+++ b/tactics/geninterp.ml
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  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 Names
+open Genarg
+
+module TacStore = Store.Make(struct end)
+
+type interp_sign = {
+  lfun : tlevel generic_argument Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign ->
+    Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top
+
+module InterpObj =
+struct
+  type ('raw, 'glb, 'top) obj = ('glb, 'top) interp_fun
+  let name = "interp"
+  let default _ = None
+end
+
+module Interp = Register(InterpObj)
+
+let interp = Interp.obj
+let register_interp0 = Interp.register0
+
+let generic_interp ist gl v =
+  let unpacker wit v =
+    let (sigma, ans) = interp wit ist gl (glb v) in
+    (sigma, in_gen (topwit wit) ans)
+  in
+  unpack { unpacker; } v
diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli
new file mode 100644
index 00000000..3c653697
--- /dev/null
+++ b/tactics/geninterp.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Interpretation functions for generic arguments. *)
+
+open Names
+open Genarg
+
+module TacStore : Store.S
+
+type interp_sign = {
+  lfun : tlevel generic_argument Id.Map.t;
+  extra : TacStore.t }
+
+type ('glb, 'top) interp_fun = interp_sign ->
+    Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top
+
+val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun
+
+val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun
+
+val register_interp0 :
+  ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
deleted file mode 100644
index 8bfebc03..00000000
--- a/tactics/hiddentac.ml
+++ /dev/null
@@ -1,142 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Proof_type
-open Tacmach
-
-open Glob_term
-open Refiner
-open Genarg
-open Tacexpr
-open Tactics
-open Util
-
-(* Basic tactics *)
-let h_intro_move x y =
-  abstract_tactic (TacIntroMove (x, y)) (intro_move x y)
-let h_intro x        = h_intro_move (Some x) no_move
-let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
-let h_assumption     = abstract_tactic TacAssumption assumption
-let h_exact c        = abstract_tactic (TacExact c) (exact_check c)
-let h_exact_no_check c =
-  abstract_tactic (TacExactNoCheck c) (exact_no_check c)
-let h_vm_cast_no_check c =
-  abstract_tactic (TacVmCastNoCheck c) (vm_cast_no_check c)
-let h_apply simple ev cb =
-  abstract_tactic (TacApply (simple,ev,List.map snd cb,None))
-    (apply_with_bindings_gen simple ev cb)
-let h_apply_in simple ev cb (id,ipat as inhyp) =
-  abstract_tactic (TacApply (simple,ev,List.map snd cb,Some inhyp))
-    (apply_in simple ev id cb ipat)
-let h_elim ev cb cbo    =
-  abstract_tactic (TacElim (ev,cb,cbo))
-    (elim ev cb cbo)
-let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
-let h_case ev cb     = abstract_tactic (TacCase (ev,cb)) (general_case_analysis ev cb)
-let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
-let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
-let h_mutual_fix b id n l =
-  abstract_tactic
-    (TacMutualFix (b,id,n,l))
-    (mutual_fix id n l 0)
-
-let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
-let h_mutual_cofix b id l =
-  abstract_tactic
-    (TacMutualCofix (b,id,l))
-    (mutual_cofix id l 0)
-
-let h_cut c          = abstract_tactic (TacCut c) (cut c)
-let h_generalize_gen cl =
-  abstract_tactic (TacGeneralize cl)
-    (generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl))
-let h_generalize cl =
-  h_generalize_gen (List.map (fun c -> ((all_occurrences_expr,c),Names.Anonymous))
-    cl)
-let h_generalize_dep c =
-  abstract_tactic (TacGeneralizeDep c) (generalize_dep c)
-let h_let_tac b na c cl eqpat =
-  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
-  let with_eq = if b then None else Some (true,id) in
-  abstract_tactic (TacLetTac (na,c,cl,b,eqpat))
-    (letin_tac with_eq na c None cl)
-let h_let_pat_tac b na c cl eqpat =
-  let id = Option.default (dummy_loc,IntroAnonymous) eqpat in
-  let with_eq = if b then None else Some (true,id) in
-  abstract_tactic (TacLetTac (na,snd c,cl,b,eqpat))
-    (letin_pat_tac with_eq na c None cl)
-
-(* Derived basic tactics *)
-let h_simple_induction_destruct isrec h =
-  abstract_tactic (TacSimpleInductionDestruct (isrec,h))
-    (if isrec then (simple_induct h) else (simple_destruct h))
-let h_simple_induction = h_simple_induction_destruct true
-let h_simple_destruct = h_simple_induction_destruct false
-
-let out_indarg = function
-  | ElimOnConstr (_,c) -> ElimOnConstr c
-  | ElimOnIdent id -> ElimOnIdent id
-  | ElimOnAnonHyp n -> ElimOnAnonHyp n
-
-let h_induction_destruct isrec ev lcl =
-  let lcl' = on_pi1 (List.map (fun (a,b) ->(out_indarg a,b))) lcl in
-  abstract_tactic (TacInductionDestruct (isrec,ev,lcl'))
-    (induction_destruct isrec ev lcl)
-let h_new_induction ev c idl e cl =
-  h_induction_destruct true ev ([c,idl],e,cl)
-let h_new_destruct ev c idl e cl = h_induction_destruct false ev ([c,idl],e,cl)
-
-let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (specialize n d)
-let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
-
-(* Context management *)
-let h_clear b l = abstract_tactic (TacClear (b,l))
-  ((if b then keep else clear) l)
-let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l)
-let h_move dep id1 id2 =
-  abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2)
-let h_rename l =
-  abstract_tactic (TacRename l) (rename_hyp l)
-let h_revert l = abstract_tactic (TacRevert l) (revert l)
-
-(* Constructors *)
-let h_left ev l  = abstract_tactic (TacLeft (ev,l)) (left_with_bindings ev l)
-let h_right ev l = abstract_tactic (TacRight (ev,l)) (right_with_bindings ev l)
-let h_split ev l = abstract_tactic (TacSplit (ev,false,l)) (split_with_bindings ev l)
-(* Moved to tacinterp because of dependencies in Tacinterp.interp
-let h_any_constructor t =
-  abstract_tactic (TacAnyConstructor t) (any_constructor t)
-*)
-let h_constructor ev n l =
-  abstract_tactic (TacConstructor(ev,ArgArg n,l))(constructor_tac ev None n l)
-let h_one_constructor n =
-  abstract_tactic (TacConstructor(false,ArgArg n,NoBindings)) (one_constructor n NoBindings)
-let h_simplest_left   = h_left false NoBindings
-let h_simplest_right  = h_right false NoBindings
-
-(* Conversion *)
-let h_reduce r cl  =
-  abstract_tactic (TacReduce (r,cl)) (reduce r cl)
-let h_change op c cl =
-  abstract_tactic (TacChange (op,c,cl)) (change op c cl)
-
-(* Equivalence relations *)
-let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
-let h_symmetry c     = abstract_tactic (TacSymmetry c) (intros_symmetry c)
-let h_transitivity c =
-  abstract_tactic (TacTransitivity c)
-    (intros_transitivity c)
-
-let h_simplest_apply c = h_apply false false [dummy_loc,(c,NoBindings)]
-let h_simplest_eapply c = h_apply false true [dummy_loc,(c,NoBindings)]
-let h_simplest_elim c   = h_elim false (c,NoBindings) None
-let h_simplest_case   c = h_case false (c,NoBindings)
-
-let h_intro_patterns l = abstract_tactic (TacIntroPattern l) (intro_patterns l)
-
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
deleted file mode 100644
index ae4e1f53..00000000
--- a/tactics/hiddentac.mli
+++ /dev/null
@@ -1,124 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Util
-open Term
-open Proof_type
-open Tacmach
-open Genarg
-open Tacexpr
-open Glob_term
-open Evd
-open Clenv
-open Termops
-
-(** Tactics for the interpreter. They left a trace in the proof tree
-   when they are called. *)
-
-(** Basic tactics *)
-
-val h_intro_move      : identifier option -> identifier move_location -> tactic
-val h_intro           : identifier -> tactic
-val h_intros_until    : quantified_hypothesis -> tactic
-
-val h_assumption      : tactic
-val h_exact           : constr -> tactic
-val h_exact_no_check  : constr -> tactic
-val h_vm_cast_no_check  : constr -> tactic
-
-val h_apply           : advanced_flag -> evars_flag ->
-  constr with_bindings located list -> tactic
-val h_apply_in        : advanced_flag -> evars_flag ->
-  constr with_bindings located list ->
-  identifier * intro_pattern_expr located option -> tactic
-
-val h_elim            : evars_flag -> constr with_bindings ->
-                        constr with_bindings option -> tactic
-val h_elim_type       : constr -> tactic
-val h_case            : evars_flag -> constr with_bindings -> tactic
-val h_case_type       : constr -> tactic
-
-val h_mutual_fix      : hidden_flag -> identifier -> int ->
-                        (identifier * int * constr) list -> tactic
-val h_fix             : identifier option -> int -> tactic
-val h_mutual_cofix    : hidden_flag -> identifier ->
-                        (identifier * constr) list -> tactic
-val h_cofix           : identifier option -> tactic
-
-val h_cut             : constr -> tactic
-val h_generalize      : constr list -> tactic
-val h_generalize_gen  : (constr with_occurrences * name) list -> tactic
-val h_generalize_dep  : constr -> tactic
-val h_let_tac         : letin_flag -> name -> constr -> Tacticals.clause ->
-                        intro_pattern_expr located option -> tactic
-val h_let_pat_tac     : letin_flag -> name -> evar_map * constr ->
-                        Tacticals.clause -> intro_pattern_expr located option ->
-                        tactic
-
-(** Derived basic tactics *)
-
-val h_simple_induction   : quantified_hypothesis -> tactic
-val h_simple_destruct    : quantified_hypothesis -> tactic
-val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic
-val h_new_induction   : evars_flag ->
-  (evar_map * constr with_bindings) induction_arg ->
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  constr with_bindings option ->
-  Tacticals.clause option -> tactic
-val h_new_destruct    : evars_flag ->
-  (evar_map * constr with_bindings) induction_arg ->
-  intro_pattern_expr located option * intro_pattern_expr located option ->
-  constr with_bindings option ->
-  Tacticals.clause option -> tactic
-val h_induction_destruct : rec_flag -> evars_flag ->
-  ((evar_map * constr with_bindings) induction_arg *
-   (intro_pattern_expr located option * intro_pattern_expr located option)) list
-    * constr with_bindings option
-    * Tacticals.clause option -> tactic
-
-val h_specialize      : int option -> constr with_bindings -> tactic
-val h_lapply          : constr -> tactic
-
-(** Automation tactic : see Auto *)
-
-
-(** Context management *)
-val h_clear           : bool -> identifier list -> tactic
-val h_clear_body      : identifier list -> tactic
-val h_move            : bool -> identifier -> identifier move_location -> tactic
-val h_rename          : (identifier*identifier) list -> tactic
-val h_revert          : identifier list -> tactic
-
-(** Constructors *)
-val h_constructor     : evars_flag -> int -> constr bindings -> tactic
-val h_left            : evars_flag -> constr bindings -> tactic
-val h_right           : evars_flag -> constr bindings -> tactic
-val h_split           : evars_flag -> constr bindings list -> tactic
-
-val h_one_constructor : int -> tactic
-val h_simplest_left   : tactic
-val h_simplest_right  : tactic
-
-
-(** Conversion *)
-val h_reduce          : Redexpr.red_expr -> Tacticals.clause -> tactic
-val h_change          :
-  Pattern.constr_pattern option -> constr -> Tacticals.clause -> tactic
-
-(** Equivalence relations *)
-val h_reflexivity     : tactic
-val h_symmetry        : Tacticals.clause -> tactic
-val h_transitivity    : constr option -> tactic
-
-val h_simplest_apply  : constr -> tactic
-val h_simplest_eapply : constr -> tactic
-val h_simplest_elim   : constr -> tactic
-val h_simplest_case   : constr -> tactic
-
-val h_intro_patterns  : intro_pattern_expr located list -> tactic
diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib
index 7d12f9d0..ff2e1ff6 100644
--- a/tactics/hightactics.mllib
+++ b/tactics/hightactics.mllib
@@ -1,8 +1,11 @@
-Refine
 Extraargs
+Coretactics
 Extratactics
 Eauto
 Class_tactics
+G_class
 Rewrite
+G_rewrite
 Tauto
 Eqdecide
+G_eqdecide
diff --git a/tactics/hints.ml b/tactics/hints.ml
new file mode 100644
index 00000000..5621c365
--- /dev/null
+++ b/tactics/hints.ml
@@ -0,0 +1,1221 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Errors
+open Names
+open Vars
+open Term
+open Environ
+open Mod_subst
+open Globnames
+open Libobject
+open Namegen
+open Libnames
+open Smartlocate
+open Misctypes
+open Evd
+open Termops
+open Inductiveops
+open Typing
+open Tacexpr
+open Decl_kinds
+open Pattern
+open Patternops
+open Clenv
+open Pfedit
+open Tacred
+open Printer
+open Vernacexpr
+
+(****************************************)
+(* General functions                    *)
+(****************************************)
+
+exception Bound
+
+let head_constr_bound t =
+  let t = strip_outer_cast t in
+  let _,ccl = decompose_prod_assum t in
+  let hd,args = decompose_app ccl in
+  match kind_of_term hd with
+    | Const _ | Ind _ | Construct _ | Var _ -> hd
+    | Proj (p, _) -> mkConst (Projection.constant p)
+    | _ -> raise Bound
+
+let head_constr c =
+  try head_constr_bound c with Bound -> error "Bound head variable."
+
+let decompose_app_bound t =
+  let t = strip_outer_cast t in
+  let _,ccl = decompose_prod_assum t in
+  let hd,args = decompose_app_vect ccl in
+  match kind_of_term hd with
+    | Const (c,u) -> ConstRef c, args
+    | Ind (i,u) -> IndRef i, args
+    | Construct (c,u) -> ConstructRef c, args
+    | Var id -> VarRef id, args
+    | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args
+    | _ -> raise Bound
+
+(************************************************************************)
+(*           The Type of Constructions Autotactic Hints                 *)
+(************************************************************************)
+
+type 'a auto_tactic =
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
+  | Extern     of glob_tactic_expr       (* Hint Extern *)
+
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+type hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
+type 'a gen_auto_tactic = {
+  pri  : int;            (* A number lower is higher priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
+  pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (* A potential name to refer to the hint *) 
+  code : 'a auto_tactic     (* the tactic to apply when the concl matches pat *)
+}
+
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
+
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) gen_auto_tactic
+
+let eq_hints_path_atom p1 p2 = match p1, p2 with
+| PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2
+| PathAny, PathAny -> true
+| (PathHints _ | PathAny), _ -> false
+
+let eq_auto_tactic t1 t2 = match t1, t2 with
+| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2
+| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2
+| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2
+| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2
+| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2
+| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *)
+| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _
+  | Unfold_nth _ | Extern _), _ -> false
+
+let eq_gen_auto_tactic t1 t2 =
+  Int.equal t1.pri t2.pri &&
+  Option.equal constr_pattern_eq t1.pat t2.pat &&
+  eq_hints_path_atom t1.name t2.name &&
+  eq_auto_tactic t1.code t2.code
+
+let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) =
+  let d = pri1 - pri2 in
+    if Int.equal d 0 then id2 - id1
+    else d
+
+let pri_order t1 t2 = pri_order_int t1 t2 <= 0
+
+(* Nov 98 -- Papageno *)
+(* Les Hints sont ré-organisés en plusieurs databases.
+
+  La table impérative "searchtable", de type "hint_db_table",
+   associe une database (hint_db) à chaque nom.
+
+  Une hint_db est une table d'association fonctionelle constr -> search_entry
+  Le constr correspond à la constante de tête de la conclusion.
+
+  Une search_entry est un triplet comprenant :
+     - la liste des tactiques qui n'ont pas de pattern associé
+     - la liste des tactiques qui ont un pattern
+     - un discrimination net borné (Btermdn.t) constitué de tous les
+       patterns de la seconde liste de tactiques *)
+
+type stored_data = int * pri_auto_tactic
+    (* First component is the index of insertion in the table, to keep most recent first semantics. *)
+
+module Bounded_net = Btermdn.Make(struct
+				    type t = stored_data
+				    let compare = pri_order_int
+				  end)
+
+type search_entry = stored_data list * stored_data list * Bounded_net.t * bool array list
+
+
+let empty_se = ([],[],Bounded_net.create (),[])
+
+let eq_pri_auto_tactic (_, x) (_, y) =
+  if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then
+    match x.code,y.code with
+      | Res_pf (cstr,_),Res_pf (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | Give_exact (cstr,_),Give_exact (cstr1,_)  -> 
+	  Term.eq_constr cstr cstr1
+      | Res_pf_THEN_trivial_fail (cstr,_)
+	  ,Res_pf_THEN_trivial_fail (cstr1,_) -> 
+	  Term.eq_constr cstr cstr1
+      | _,_ -> false
+  else
+    false
+
+let add_tac pat t st (l,l',dn,m) =
+  match pat with
+  | None -> 
+    if not (List.exists (eq_pri_auto_tactic t) l) then (List.insert pri_order t l, l', dn, m) 
+    else (l, l', dn, m)
+  | Some pat -> 
+    if not (List.exists (eq_pri_auto_tactic t) l')
+    then (l, List.insert pri_order t l', Bounded_net.add st dn (pat,t), m) else (l, l', dn, m)
+
+let rebuild_dn st ((l,l',dn,m) : search_entry) =
+  let dn' = 
+    List.fold_left 
+      (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t)))
+      (Bounded_net.create ()) l'
+  in
+    (l, l', dn', m)
+
+let lookup_tacs concl st (l,l',dn) =
+  let l'  = Bounded_net.lookup st dn concl in
+  let sl' = List.stable_sort pri_order_int l' in
+    List.merge pri_order_int l sl'
+
+module Constr_map = Map.Make(RefOrdered)
+
+let is_transparent_gr (ids, csts) = function
+  | VarRef id -> Id.Pred.mem id ids
+  | ConstRef cst -> Cpred.mem cst csts
+  | IndRef _ | ConstructRef _ -> false
+
+let strip_params env c = 
+  match kind_of_term c with
+  | App (f, args) -> 
+    (match kind_of_term f with
+    | Const (p,_) ->
+      let cb = lookup_constant p env in
+	(match cb.Declarations.const_proj with
+	| Some pb -> 
+	  let n = pb.Declarations.proj_npars in
+	    if Array.length args > n then
+	      mkApp (mkProj (Projection.make p false, args.(n)), 
+		     Array.sub args (n+1) (Array.length args - (n + 1)))
+	    else c
+	| None -> c)
+    | _ -> c)
+  | _ -> c
+
+let instantiate_hint p =
+  let mk_clenv c cty ctx =
+    let env = Global.env () in
+    let sigma = Evd.merge_context_set univ_flexible (Evd.from_env env) ctx in
+    let cl = mk_clenv_from_env (Global.env()) sigma None (c,cty) in 
+      {cl with templval = 
+	  { cl.templval with rebus = strip_params env cl.templval.rebus };
+	env = empty_env}
+  in
+  let code = match p.code with
+    | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx)
+    | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx)
+    | Res_pf_THEN_trivial_fail (c, cty, ctx) ->
+      Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx)
+    | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx)
+    | Unfold_nth e -> Unfold_nth e
+    | Extern t -> Extern t
+  in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code }
+
+let hints_path_atom_eq h1 h2 = match h1, h2 with
+| PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2
+| PathAny, PathAny -> true
+| _ -> false
+
+let rec hints_path_eq h1 h2 = match h1, h2 with
+| PathAtom h1, PathAtom h2 -> hints_path_atom_eq h1 h2
+| PathStar h1, PathStar h2 -> hints_path_eq h1 h2
+| PathSeq (l1, r1), PathSeq (l2, r2) ->
+  hints_path_eq l1 l2 && hints_path_eq r1 r2
+| PathOr (l1, r1), PathOr (l2, r2) ->
+  hints_path_eq l1 l2 && hints_path_eq r1 r2
+| PathEmpty, PathEmpty -> true
+| PathEpsilon, PathEpsilon -> true
+| _ -> false
+
+let path_matches hp hints =
+  let rec aux hp hints k =
+    match hp, hints with
+    | PathAtom _, [] -> false
+    | PathAtom PathAny, (_ :: hints') -> k hints'
+    | PathAtom p, (h :: hints') -> 
+      if hints_path_atom_eq p h then k hints' else false
+    | PathStar hp', hints -> 
+      k hints || aux hp' hints (fun hints' -> aux hp hints' k)
+    | PathSeq (hp, hp'), hints -> 
+      aux hp hints (fun hints' -> aux hp' hints' k)
+    | PathOr (hp, hp'), hints ->
+      aux hp hints k || aux hp' hints k
+    | PathEmpty, _ -> false
+    | PathEpsilon, hints -> k hints
+  in aux hp hints (fun hints' -> true)
+
+let rec matches_epsilon = function
+  | PathAtom _ -> false
+  | PathStar _ -> true
+  | PathSeq (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathOr (p, p') -> matches_epsilon p || matches_epsilon p'
+  | PathEmpty -> false
+  | PathEpsilon -> true
+
+let rec is_empty = function
+  | PathAtom _ -> false
+  | PathStar _ -> false
+  | PathSeq (p, p') -> is_empty p || is_empty p'
+  | PathOr (p, p') -> matches_epsilon p && matches_epsilon p'
+  | PathEmpty -> true
+  | PathEpsilon -> false
+
+let rec path_derivate hp hint =
+  let rec derivate_atoms hints hints' =
+    match hints, hints' with
+    | gr :: grs, gr' :: grs' when eq_gr gr gr' -> derivate_atoms grs grs'
+    | [], [] -> PathEpsilon
+    | [], hints -> PathEmpty
+    | grs, [] -> PathAtom (PathHints grs)
+    | _, _ -> PathEmpty 
+  in
+    match hp with
+    | PathAtom PathAny -> PathEpsilon
+    | PathAtom (PathHints grs) -> 
+      (match grs, hint with
+       | h :: hints, PathAny -> PathEmpty
+       | hints, PathHints hints' -> derivate_atoms hints hints'
+       | _, _ -> assert false)
+    | PathStar p -> if path_matches p [hint] then hp else PathEpsilon
+    | PathSeq (hp, hp') ->
+      let hpder = path_derivate hp hint in
+	if matches_epsilon hp then 
+	  PathOr (PathSeq (hpder, hp'), path_derivate hp' hint)
+	else if is_empty hpder then PathEmpty 
+	else PathSeq (hpder, hp')
+    | PathOr (hp, hp') ->
+      PathOr (path_derivate hp hint, path_derivate hp' hint)
+    | PathEmpty -> PathEmpty
+    | PathEpsilon -> PathEmpty
+
+let rec normalize_path h =
+  match h with
+  | PathStar PathEpsilon -> PathEpsilon
+  | PathSeq (PathEmpty, _) | PathSeq (_, PathEmpty) -> PathEmpty
+  | PathSeq (PathEpsilon, p) | PathSeq (p, PathEpsilon) -> normalize_path p
+  | PathOr (PathEmpty, p) | PathOr (p, PathEmpty) -> normalize_path p
+  | PathOr (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if hints_path_eq p p' && hints_path_eq q q' then h
+      else normalize_path (PathOr (p', q'))
+  | PathSeq (p, q) -> 
+    let p', q' = normalize_path p, normalize_path q in
+      if hints_path_eq p p' && hints_path_eq q q' then h
+      else normalize_path (PathSeq (p', q'))
+  | _ -> h
+
+let path_derivate hp hint = normalize_path (path_derivate hp hint)
+
+let rec pp_hints_path = function
+  | PathAtom (PathAny) -> str"."
+  | PathAtom (PathHints grs) -> pr_sequence pr_global grs
+  | PathStar p -> str "(" ++ pp_hints_path p ++ str")*"
+  | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p'
+  | PathOr (p, p') -> 
+    str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")"
+  | PathEmpty -> str"Ø"
+  | PathEpsilon -> str"ε"
+
+let subst_path_atom subst p =
+  match p with
+  | PathAny -> p
+  | PathHints grs ->
+    let gr' gr = fst (subst_global subst gr) in
+    let grs' = List.smartmap gr' grs in
+      if grs' == grs then p else PathHints grs'
+
+let rec subst_hints_path subst hp =
+  match hp with
+  | PathAtom p ->
+    let p' = subst_path_atom subst p in
+      if p' == p then hp else PathAtom p'
+  | PathStar p -> let p' = subst_hints_path subst p in
+      if p' == p then hp else PathStar p'
+  | PathSeq (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathSeq (p', q')
+  | PathOr (p, q) ->
+    let p' = subst_hints_path subst p in
+    let q' = subst_hints_path subst q in
+      if p' == p && q' == q then hp else PathOr (p', q')
+  | _ -> hp
+
+module Hint_db = struct
+
+  type t = {
+    hintdb_state : Names.transparent_state;
+    hintdb_cut : hints_path;
+    hintdb_unfolds : Id.Set.t * Cset.t;
+    mutable hintdb_max_id : int;
+    use_dn : bool;
+    hintdb_map : search_entry Constr_map.t;
+    (* A list of unindexed entries starting with an unfoldable constant
+       or with no associated pattern. *)
+    hintdb_nopat : (global_reference option * stored_data) list
+  }
+
+  let next_hint_id t = 
+    let h = t.hintdb_max_id in t.hintdb_max_id <- succ t.hintdb_max_id; h
+
+  let empty st use_dn = { hintdb_state = st;
+			  hintdb_cut = PathEmpty;
+			  hintdb_unfolds = (Id.Set.empty, Cset.empty);
+			  hintdb_max_id = 0;
+			  use_dn = use_dn;
+			  hintdb_map = Constr_map.empty;
+			  hintdb_nopat = [] }
+
+  let find key db =
+    try Constr_map.find key db.hintdb_map
+    with Not_found -> empty_se
+ 
+  let realize_tac (id,tac) = tac
+
+  let matches_mode args mode =
+    Array.length args == Array.length mode &&
+      Array.for_all2 (fun arg m -> not (m && occur_existential arg)) args mode
+      
+  let matches_modes args modes =
+    if List.is_empty modes then true
+    else List.exists (matches_mode args) modes
+
+  let map_none db =
+    List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) [])
+    
+  let map_all k db =
+    let (l,l',_,_) = find k db in
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
+	
+  (** Precondition: concl has no existentials *)
+  let map_auto (k,args) concl db =
+    let (l,l',dn,m) = find k db in
+    let st = if db.use_dn then  (Some db.hintdb_state) else None in
+    let l' = lookup_tacs concl st (l,l',dn) in
+      List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
+
+  let map_existential (k,args) concl db =
+    let (l,l',_,m) = find k db in
+      if matches_modes args m then
+	List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l')
+      else List.map realize_tac (List.map snd db.hintdb_nopat)
+
+  (* [c] contains an existential *)
+  let map_eauto (k,args) concl db =
+    let (l,l',dn,m) = find k db in
+      if matches_modes args m then
+	let st = if db.use_dn then Some db.hintdb_state else None in
+	let l' = lookup_tacs concl st (l,l',dn) in
+	  List.map realize_tac (Sort.merge pri_order (List.map snd db.hintdb_nopat) l')
+      else List.map realize_tac (List.map snd db.hintdb_nopat)
+
+  let is_exact = function
+    | Give_exact _ -> true
+    | _ -> false
+
+  let is_unfold = function
+    | Unfold_nth _ -> true
+    | _ -> false
+
+  let addkv gr id v db =
+    let idv = id, v in
+    let k = match gr with
+      | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr &&
+	  is_unfold v.code then None else Some gr
+      | None -> None
+    in
+    let dnst = if db.use_dn then Some db.hintdb_state else None in
+    let pat = if not db.use_dn && is_exact v.code then None else v.pat in
+      match k with
+      | None ->
+          (** ppedrot: this equality here is dubious. Maybe we can remove it? *)
+          let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in
+	  if not (List.exists is_present db.hintdb_nopat) then
+	    (** FIXME *)
+	    { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat }
+	  else db
+      | Some gr ->
+	  let oval = find gr db in
+	    { db with hintdb_map = Constr_map.add gr (add_tac pat idv dnst oval) db.hintdb_map }
+
+  let rebuild_db st' db =
+    let db' =
+      { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map;
+	hintdb_state = st'; hintdb_nopat = [] }
+    in
+      List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat
+
+  let add_one (k, v) db =
+    let v = instantiate_hint v in
+    let st',db,rebuild =
+      match v.code with
+      | Unfold_nth egr ->
+	  let addunf (ids,csts) (ids',csts') =
+	    match egr with
+	    | EvalVarRef id -> (Id.Pred.add id ids, csts), (Id.Set.add id ids', csts')
+	    | EvalConstRef cst -> (ids, Cpred.add cst csts), (ids', Cset.add cst csts')
+	  in 
+	  let state, unfs = addunf db.hintdb_state db.hintdb_unfolds in
+	    state, { db with hintdb_unfolds = unfs }, true
+      | _ -> db.hintdb_state, db, false
+    in
+    let db = if db.use_dn && rebuild then rebuild_db st' db else db
+    in addkv k (next_hint_id db) v db
+
+  let add_list l db = List.fold_left (fun db k -> add_one k db) db l
+
+  let remove_sdl p sdl = List.smartfilter p sdl 
+  let remove_he st p (sl1, sl2, dn, m as he) =
+    let sl1' = remove_sdl p sl1 and sl2' = remove_sdl p sl2 in
+      if sl1' == sl1 && sl2' == sl2 then he
+      else rebuild_dn st (sl1', sl2', dn, m)
+
+  let remove_list grs db =
+    let filter (_, h) =
+      match h.name with PathHints [gr] -> not (List.mem_f eq_gr gr grs) | _ -> true in
+    let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in
+    let hintnopat = List.smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
+      { db with hintdb_map = hintmap; hintdb_nopat = hintnopat }
+
+  let remove_one gr db = remove_list [gr] db
+
+  let iter f db =
+    f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat);
+    Constr_map.iter (fun k (l,l',_,m) -> f (Some k) m (List.map realize_tac (l@l'))) db.hintdb_map
+
+  let fold f db accu =
+    let accu = f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat) accu in
+    Constr_map.fold (fun k (l,l',_,m) -> f (Some k) m (List.map snd (l@l'))) db.hintdb_map accu
+
+  let transparent_state db = db.hintdb_state
+
+  let set_transparent_state db st =
+    if db.use_dn then rebuild_db st db
+    else { db with hintdb_state = st }
+
+  let add_cut path db =
+    { db with hintdb_cut = normalize_path (PathOr (db.hintdb_cut, path)) }
+
+  let add_mode gr m db =
+    let (l,l',dn,ms) = find gr db in
+      { db with hintdb_map = Constr_map.add gr (l,l',dn,m :: ms) db.hintdb_map }
+
+  let cut db = db.hintdb_cut
+
+  let unfolds db = db.hintdb_unfolds
+
+  let use_dn db = db.use_dn
+
+end
+
+module Hintdbmap = String.Map
+
+type hint_db = Hint_db.t
+
+type hint_db_table = hint_db Hintdbmap.t ref
+
+type hint_db_name = string
+
+(** Initially created hint databases, for typeclasses and rewrite *)
+
+let typeclasses_db = "typeclass_instances"
+let rewrite_db = "rewrite"
+
+let auto_init_db =
+  Hintdbmap.add typeclasses_db (Hint_db.empty full_transparent_state true)
+    (Hintdbmap.add rewrite_db (Hint_db.empty cst_full_transparent_state true)
+       Hintdbmap.empty)
+
+let searchtable : hint_db_table = ref auto_init_db
+
+let searchtable_map name =
+  Hintdbmap.find name !searchtable
+let searchtable_add (name,db) =
+  searchtable := Hintdbmap.add name db !searchtable
+let current_db_names () = Hintdbmap.domain !searchtable
+let current_db () = Hintdbmap.bindings !searchtable
+
+let current_pure_db () =
+  List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable))
+
+let error_no_such_hint_database x =
+  error ("No such Hint database: "^x^".")
+
+(**************************************************************************)
+(*                       Definition of the summary                        *)
+(**************************************************************************)
+
+let hints_init : (unit -> unit) ref = ref (fun () -> ())
+let add_hints_init f =
+  let init = !hints_init in
+  hints_init := (fun () -> init (); f ())
+
+let init     () = searchtable := auto_init_db; !hints_init ()
+let freeze   _ = !searchtable
+let unfreeze fs = searchtable := fs
+
+let _ = Summary.declare_summary "search"
+	  { Summary.freeze_function   = freeze;
+	    Summary.unfreeze_function = unfreeze;
+	    Summary.init_function     = init }
+
+(**************************************************************************)
+(*             Auxiliary functions to prepare AUTOHINT objects            *)
+(**************************************************************************)
+
+let rec nb_hyp c = match kind_of_term c with
+  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
+  | _ -> 0
+
+(* adding and removing tactics in the search table *)
+
+let try_head_pattern c =
+  try head_pattern_bound c
+  with BoundPattern -> error "Bound head variable."
+
+let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) =
+  let cty = strip_outer_cast cty in
+    match kind_of_term cty with
+    | Prod _ -> failwith "make_exact_entry"
+    | _ ->
+	let pat = snd (Patternops.pattern_of_constr env sigma cty) in
+	let hd =
+	  try head_pattern_bound pat
+	  with BoundPattern -> failwith "make_exact_entry"
+	in
+          (Some hd,
+	  { pri = (match pri with None -> 0 | Some p -> p);
+	    poly = poly;
+	    pat = Some pat;
+	    name = name;
+	    code = Give_exact (c, cty, ctx) })
+
+let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) =
+  let cty = if hnf then hnf_constr env sigma cty else cty in
+    match kind_of_term cty with
+    | Prod _ ->
+        let sigma' = Evd.merge_context_set univ_flexible sigma ctx in
+        let ce = mk_clenv_from_env env sigma' None (c,cty) in
+	let c' = clenv_type (* ~reduce:false *) ce in
+	let pat = snd (Patternops.pattern_of_constr env ce.evd c') in
+        let hd =
+	  try head_pattern_bound pat
+          with BoundPattern -> failwith "make_apply_entry" in
+        let nmiss = List.length (clenv_missing ce) in
+	if Int.equal nmiss 0 then
+	  (Some hd,
+          { pri = (match pri with None -> nb_hyp cty | Some p -> p);
+	    poly = poly;
+            pat = Some pat;
+	    name = name;
+            code = Res_pf(c,cty,ctx) })
+	else begin
+	  if not eapply then failwith "make_apply_entry";
+          if verbose then
+	    msg_warning (str "the hint: eapply " ++ pr_lconstr c ++
+	    str " will only be used by eauto");
+          (Some hd,
+           { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p);
+	     poly = poly;
+             pat = Some pat;
+	     name = name;
+             code = ERes_pf(c,cty,ctx) })
+        end
+    | _ -> failwith "make_apply_entry"
+
+(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose
+   c is a constr
+   cty is the type of constr *)
+
+let fresh_global_or_constr env sigma poly cr =
+  match cr with
+  | IsGlobRef gr -> Universes.fresh_global_instance env gr
+  | IsConstr (c, ctx) -> (c, ctx)
+
+let make_resolves env sigma flags pri poly ?name cr =
+  let c, ctx = fresh_global_or_constr env sigma poly cr in
+  let cty = Retyping.get_type_of env sigma c in
+  let try_apply f =
+    try Some (f (c, cty, ctx)) with Failure _ -> None in
+  let ents = List.map_filter try_apply
+    [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name]
+  in
+  if List.is_empty ents then
+    errorlabstrm "Hint"
+      (pr_lconstr c ++ spc() ++
+        (if pi1 flags then str"cannot be used as a hint."
+	else str "can be used as a hint only for eauto."));
+  ents
+
+(* used to add an hypothesis to the local hint database *)
+let make_resolve_hyp env sigma (hname,_,htyp) =
+  try
+    [make_apply_entry env sigma (true, true, false) None false
+       ~name:(PathHints [VarRef hname])
+       (mkVar hname, htyp, Univ.ContextSet.empty)]
+  with
+    | Failure _ -> []
+    | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp")
+
+(* REM : in most cases hintname = id *)
+let make_unfold eref =
+  let g = global_of_evaluable_reference eref in
+  (Some g,
+   { pri = 4;
+     poly = false;
+     pat = None;
+     name = PathHints [g];
+     code = Unfold_nth eref })
+
+let make_extern pri pat tacast =
+  let hdconstr = Option.map try_head_pattern pat in
+  (hdconstr,
+   { pri = pri;
+     poly = false;
+     pat = pat;
+     name = PathAny;
+     code = Extern tacast })  
+
+let make_mode ref m = 
+  let ty = Global.type_of_global_unsafe ref in
+  let ctx, t = decompose_prod ty in
+  let n = List.length ctx in
+  let m' = Array.of_list m in
+    if not (n == Array.length m') then
+      errorlabstrm "Hint"
+	(pr_global ref ++ str" has " ++ int n ++ 
+	   str" arguments while the mode declares " ++ int (Array.length m'))
+    else m'
+      
+let make_trivial env sigma poly ?(name=PathAny) r =
+  let c,ctx = fresh_global_or_constr env sigma poly r in
+  let sigma = Evd.merge_context_set univ_flexible sigma ctx in
+  let t = hnf_constr env sigma (type_of env sigma c) in
+  let hd = head_of_constr_reference (head_constr t) in
+  let ce = mk_clenv_from_env env sigma None (c,t) in
+  (Some hd, { pri=1;
+	      poly = poly;
+              pat = Some (snd (Patternops.pattern_of_constr env ce.evd (clenv_type ce)));
+	      name = name;
+              code=Res_pf_THEN_trivial_fail(c,t,ctx) })
+
+
+
+(**************************************************************************)
+(*               declaration of the AUTOHINT library object               *)
+(**************************************************************************)
+
+(* If the database does not exist, it is created *)
+(* TODO: should a warning be printed in this case ?? *)
+
+let get_db dbname =
+  try searchtable_map dbname
+  with Not_found -> Hint_db.empty empty_transparent_state false
+
+let add_hint dbname hintlist = 
+  let db = get_db dbname in
+  let db' = Hint_db.add_list hintlist db in
+    searchtable_add (dbname,db')
+
+let add_transparency dbname grs b =
+  let db = get_db dbname in
+  let st = Hint_db.transparent_state db in
+  let st' =
+    List.fold_left (fun (ids, csts) gr ->
+      match gr with
+      | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts)
+      | EvalVarRef v -> (if b then Id.Pred.add else Id.Pred.remove) v ids, csts)
+      st grs
+  in searchtable_add (dbname, Hint_db.set_transparent_state db st')
+
+let remove_hint dbname grs =
+  let db = get_db dbname in
+  let db' = Hint_db.remove_list grs db in
+    searchtable_add (dbname, db')
+
+type hint_action =
+  | CreateDB of bool * transparent_state
+  | AddTransparency of evaluable_global_reference list * bool
+  | AddHints of hint_entry list
+  | RemoveHints of global_reference list
+  | AddCut of hints_path
+  | AddMode of global_reference * bool array
+
+let add_cut dbname path =
+  let db = get_db dbname in
+  let db' = Hint_db.add_cut path db in
+    searchtable_add (dbname, db')
+
+let add_mode dbname l m =
+  let db = get_db dbname in
+  let db' = Hint_db.add_mode l m db in
+    searchtable_add (dbname, db')
+
+type hint_obj = bool * string * hint_action  (* locality, name, action *)
+
+let cache_autohint (_,(local,name,hints)) =
+  match hints with
+  | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b)
+  | AddTransparency (grs, b) -> add_transparency name grs b
+  | AddHints hints -> add_hint name hints
+  | RemoveHints grs -> remove_hint name grs
+  | AddCut path -> add_cut name path
+  | AddMode (l, m) -> add_mode name l m
+
+let subst_autohint (subst,(local,name,hintlist as obj)) =
+  let subst_key gr =
+    let (lab'', elab') = subst_global subst gr in
+    let gr' =
+      (try head_of_constr_reference (head_constr_bound elab')
+       with Bound -> lab'')
+    in if gr' == gr then gr else gr'
+  in
+  let subst_hint (k,data as hint) =
+    let k' = Option.smartmap subst_key k in
+    let pat' = Option.smartmap (subst_pattern subst) data.pat in
+    let code' = match data.code with
+      | Res_pf (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else Res_pf (c', t',ctx)
+      | ERes_pf (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t'==t then data.code else ERes_pf (c',t',ctx)
+      | Give_exact (c,t,ctx) ->
+          let c' = subst_mps subst c in
+	  let t' = subst_mps subst t in
+          if c==c' && t'== t then data.code else Give_exact (c',t',ctx)
+      | Res_pf_THEN_trivial_fail (c,t,ctx) ->
+          let c' = subst_mps subst c in
+          let t' = subst_mps subst t in
+          if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx)
+      | Unfold_nth ref ->
+          let ref' = subst_evaluable_reference subst ref in
+          if ref==ref' then data.code else Unfold_nth ref'
+      | Extern tac ->
+	  let tac' = Tacsubst.subst_tactic subst tac in
+	  if tac==tac' then data.code else Extern tac'
+    in
+    let name' = subst_path_atom subst data.name in
+    let data' =
+      if data.pat==pat' && data.name == name' && data.code==code' then data
+      else { data with pat = pat'; name = name'; code = code' }
+    in
+    if k' == k && data' == data then hint else (k',data')
+  in
+    match hintlist with
+    | CreateDB _ -> obj
+    | AddTransparency (grs, b) ->
+	let grs' = List.smartmap (subst_evaluable_reference subst) grs in
+	  if grs==grs' then obj else (local, name, AddTransparency (grs', b))
+    | AddHints hintlist ->
+	let hintlist' = List.smartmap subst_hint hintlist in
+	  if hintlist' == hintlist then obj else
+	    (local,name,AddHints hintlist')
+    | RemoveHints grs ->
+	let grs' = List.smartmap (subst_global_reference subst) grs in
+	  if grs==grs' then obj else (local, name, RemoveHints grs')
+    | AddCut path ->
+      let path' = subst_hints_path subst path in
+	if path' == path then obj else (local, name, AddCut path')
+    | AddMode (l,m) ->
+      let l' = subst_global_reference subst l in
+	(local, name, AddMode (l', m))
+
+let classify_autohint ((local,name,hintlist) as obj) =
+  match hintlist with
+  | AddHints [] -> Dispose
+  | _ -> if local then Dispose else Substitute obj
+
+let inAutoHint : hint_obj -> obj =
+  declare_object {(default_object "AUTOHINT") with
+                    cache_function = cache_autohint;
+		    load_function = (fun _ -> cache_autohint);
+		    subst_function = subst_autohint;
+		    classify_function = classify_autohint; }
+
+let create_hint_db l n st b =
+  Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st)))
+
+let remove_hints local dbnames grs =
+  let dbnames = if List.is_empty dbnames then ["core"] else dbnames in
+    List.iter
+      (fun dbname ->
+	 Lib.add_anonymous_leaf (inAutoHint(local, dbname, RemoveHints grs)))
+      dbnames
+
+(**************************************************************************)
+(*                     The "Hint" vernacular command                      *)
+(**************************************************************************)
+let add_resolves env sigma clist local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf
+	 (inAutoHint
+	    (local,dbname, AddHints
+     	      (List.flatten (List.map (fun (pri, poly, hnf, path, gr) ->
+	        make_resolves env sigma (true,hnf,Flags.is_verbose()) 
+		  pri poly ~name:path gr) clist)))))
+    dbnames
+
+let add_unfolds l local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddHints (List.map make_unfold l))))
+    dbnames
+
+let add_cuts l local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddCut l)))
+    dbnames
+
+let add_mode l m local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+      (let m' = make_mode l m in
+	 (inAutoHint (local,dbname, AddMode (l,m')))))
+    dbnames
+
+let add_transparency l b local dbnames =
+  List.iter
+    (fun dbname -> Lib.add_anonymous_leaf
+       (inAutoHint (local,dbname, AddTransparency (l, b))))
+    dbnames
+
+let add_extern pri pat tacast local dbname =
+  let pat = match pat with
+  | None -> None
+  | Some (_, pat) -> Some pat
+  in
+  let hint = local, dbname, AddHints [make_extern pri pat tacast] in
+  Lib.add_anonymous_leaf (inAutoHint hint)
+
+let add_externs pri pat tacast local dbnames =
+  List.iter (add_extern pri pat tacast local) dbnames
+
+let add_trivials env sigma l local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf (
+	 inAutoHint(local,dbname, 
+		    AddHints (List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l))))
+    dbnames
+
+let (forward_intern_tac, extern_intern_tac) = Hook.make ()
+
+type hnf = bool
+
+type hints_entry =
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
+  | HintsCutEntry of hints_path
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsModeEntry of global_reference * bool list
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * glob_tactic_expr
+
+let default_prepare_hint_ident = Id.of_string "H"
+
+exception Found of constr * types
+
+let prepare_hint check env init (sigma,c) =
+  let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in
+  (* We re-abstract over uninstantiated evars.
+     It is actually a bit stupid to generalize over evars since the first
+     thing make_resolves will do is to re-instantiate the products *)
+  let c = drop_extra_implicit_args (Evarutil.nf_evar sigma c) in
+  let vars = ref (collect_vars c) in
+  let subst = ref [] in
+  let rec find_next_evar c = match kind_of_term c with
+    | Evar (evk,args as ev) ->
+      (* We skip the test whether args is the identity or not *)
+      let t = Evarutil.nf_evar sigma (existential_type sigma ev) in
+      let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in
+      if not (Int.Set.is_empty (free_rels t)) then
+	error "Hints with holes dependent on a bound variable not supported.";
+      if occur_existential t then
+	(* Not clever enough to construct dependency graph of evars *)
+	error "Not clever enough to deal with evars dependent in other evars.";
+      raise (Found (c,t))
+    | _ -> iter_constr find_next_evar c in
+  let rec iter c =
+    try find_next_evar c; c
+    with Found (evar,t) ->
+      let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in
+      vars := Id.Set.add id !vars;
+      subst := (evar,mkVar id)::!subst;
+      mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in
+  let c' = iter c in
+    if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c';
+    let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in
+      IsConstr (c', diff)
+
+let interp_hints poly =
+  fun h ->
+  let f c =
+    let evd,c = Constrintern.interp_open_constr (Global.env()) Evd.empty c in
+      prepare_hint true (Global.env()) Evd.empty (evd,c) in
+  let fref r =
+    let gr = global_with_alias r in
+    Dumpglob.add_glob (loc_of_reference r) gr;
+    gr in
+  let fr r = 
+    evaluable_of_global_reference (Global.env()) (fref r)
+  in
+  let fi c =
+    match c with
+    | HintsReference c ->
+      let gr = global_with_alias c in
+	(PathHints [gr], poly, IsGlobRef gr)
+    | HintsConstr c -> (PathAny, poly, f c)
+  in
+  let fres (pri, b, r) =
+    let path, poly, gr = fi r in
+      (pri, poly, b, path, gr)
+  in
+  let fp = Constrintern.intern_constr_pattern (Global.env()) in
+  match h with
+  | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints)
+  | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints)
+  | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
+  | HintsTransparency (lhints, b) ->
+      HintsTransparencyEntry (List.map fr lhints, b)
+  | HintsMode (r, l) -> HintsModeEntry (fref r, l)
+  | HintsConstructors lqid ->
+      let constr_hints_of_ind qid =
+        let ind = global_inductive_with_alias qid in
+	let mib,_ = Global.lookup_inductive ind in
+	Dumpglob.dump_reference (fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind";
+          List.init (nconstructors ind) 
+	    (fun i -> let c = (ind,i+1) in
+		      let gr = ConstructRef c in
+			None, mib.Declarations.mind_polymorphic, true, 
+			PathHints [gr], IsGlobRef gr)
+      in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
+  | HintsExtern (pri, patcom, tacexp) ->
+      let pat =	Option.map fp patcom in
+      let l = match pat with None -> [] | Some (l, _) -> l in
+      let tacexp = Hook.get forward_intern_tac l tacexp in
+      HintsExternEntry (pri, pat, tacexp)
+
+let add_hints local dbnames0 h =
+  if String.List.mem "nocore" dbnames0 then
+    error "The hint database \"nocore\" is meant to stay empty.";
+  let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in
+  let env = Global.env() and sigma = Evd.empty in
+  match h with
+  | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames
+  | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames
+  | HintsCutEntry lhints -> add_cuts lhints local dbnames
+  | HintsModeEntry (l,m) -> add_mode l m local dbnames
+  | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames
+  | HintsTransparencyEntry (lhints, b) ->
+      add_transparency lhints b local dbnames
+  | HintsExternEntry (pri, pat, tacexp) ->
+      add_externs pri pat tacexp local dbnames
+
+let expand_constructor_hints env sigma lems =
+  List.map_append (fun (evd,lem) ->
+    match kind_of_term lem with
+    | Ind (ind,u) ->
+	List.init (nconstructors ind) 
+	  (fun i -> IsConstr (mkConstructU ((ind,i+1),u), 
+			      Univ.ContextSet.empty))
+    | _ ->
+	[prepare_hint false env sigma (evd,lem)]) lems
+
+(* builds a hint database from a constr signature *)
+(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
+
+let add_hint_lemmas env sigma eapply lems hint_db =
+  let lems = expand_constructor_hints env sigma lems in
+  let hintlist' =
+    List.map_append (make_resolves env sigma (eapply,true,false) None true) lems in
+  Hint_db.add_list hintlist' hint_db
+
+let make_local_hint_db env sigma ts eapply lems =
+  let sign = Environ.named_context env in
+  let ts = match ts with
+    | None -> Hint_db.transparent_state (searchtable_map "core") 
+    | Some ts -> ts
+  in
+  let hintlist = List.map_append (make_resolve_hyp env sigma) sign in
+  add_hint_lemmas env sigma eapply lems
+    (Hint_db.add_list hintlist (Hint_db.empty ts false))
+
+let make_local_hint_db = 
+  if Flags.profile then
+    let key = Profile.declare_profile "make_local_hint_db" in
+      Profile.profile4 key make_local_hint_db
+  else make_local_hint_db
+
+let make_local_hint_db env sigma ?ts eapply lems =
+  make_local_hint_db env sigma ts eapply lems
+
+let make_db_list dbnames =
+  let use_core = not (List.mem "nocore" dbnames) in
+  let dbnames = List.remove String.equal "nocore" dbnames in
+  let dbnames = if use_core then "core"::dbnames else dbnames in
+  let lookup db =
+    try searchtable_map db with Not_found -> error_no_such_hint_database db
+  in
+  List.map lookup dbnames
+
+(**************************************************************************)
+(*                    Functions for printing the hints                    *)
+(**************************************************************************)
+
+let pr_autotactic =
+  function
+  | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
+  | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
+  | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c)
+  | Res_pf_THEN_trivial_fail (c,clenv) ->
+      (str"apply " ++ pr_constr c ++ str" ; trivial")
+  | Unfold_nth c -> (str"unfold " ++  pr_evaluable_reference c)
+  | Extern tac ->
+      let env =
+        try
+          let (_, env) = Pfedit.get_current_goal_context () in
+          env
+        with e when Errors.noncritical e -> Global.env ()
+      in
+      (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac)
+
+let pr_hint (id, v) =
+  (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())
+
+let pr_hint_list hintlist =
+  (str "  " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ())
+
+let pr_hints_db (name,db,hintlist) =
+  (str "In the database " ++ str name ++ str ":" ++
+     if List.is_empty hintlist then (str " nothing" ++ fnl ())
+     else (fnl () ++ pr_hint_list hintlist))
+
+(* Print all hints associated to head c in any database *)
+let pr_hint_list_for_head c =
+  let dbs = current_db () in
+  let validate (name, db) =
+    let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in
+    (name, db, hints)
+  in
+  let valid_dbs = List.map validate dbs in
+  if List.is_empty valid_dbs then
+    (str "No hint declared for :" ++ pr_global c)
+  else
+    hov 0
+      (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++
+	 hov 0 (prlist pr_hints_db valid_dbs))
+
+let pr_hint_ref ref = pr_hint_list_for_head ref
+
+(* Print all hints associated to head id in any database *)
+
+let pr_hint_term cl =
+  try
+    let dbs = current_db () in
+    let valid_dbs =
+      let fn = try
+	  let hdc = decompose_app_bound cl in
+	    if occur_existential cl then
+	      Hint_db.map_existential hdc cl
+	    else Hint_db.map_auto hdc cl
+	with Bound -> Hint_db.map_none
+      in
+      let fn db = List.map (fun x -> 0, x) (fn db) in
+      List.map (fun (name, db) -> (name, db, fn db)) dbs
+    in
+      if List.is_empty valid_dbs then
+	(str "No hint applicable for current goal")
+      else
+	(str "Applicable Hints :" ++ fnl () ++
+	    hov 0 (prlist pr_hints_db valid_dbs))
+  with Match_failure _ | Failure _ ->
+    (str "No hint applicable for current goal")
+
+(* print all hints that apply to the concl of the current goal *)
+let pr_applicable_hint () =
+  let pts = get_pftreestate () in
+  let glss = Proof.V82.subgoals pts in
+  match glss.Evd.it with
+  | [] -> Errors.error "No focused goal."
+  | g::_ ->
+    pr_hint_term (Goal.V82.concl glss.Evd.sigma g)
+
+(* displays the whole hint database db *)
+let pr_hint_db db =
+  let pr_mode = prvect_with_sep spc (fun x -> if x then str"+" else str"-") in
+  let pr_modes l = 
+    if List.is_empty l then mt ()
+    else str" (modes " ++ prlist_with_sep pr_comma pr_mode l ++ str")"
+  in
+  let content =
+    let fold head modes hintlist accu =
+      let goal_descr = match head with
+      | None -> str "For any goal"
+      | Some head -> str "For " ++ pr_global head ++ pr_modes modes
+      in
+      let hints = pr_hint_list (List.map (fun x -> (0, x)) hintlist) in
+      let hint_descr = hov 0 (goal_descr ++ str " -> " ++ hints) in
+      accu ++ hint_descr
+    in
+    Hint_db.fold fold db (mt ())
+  in
+  let (ids, csts) = Hint_db.transparent_state db in
+  hov 0
+    ((if Hint_db.use_dn db then str"Discriminated database"
+      else str"Non-discriminated database")) ++ fnl () ++
+  hov 2 (str"Unfoldable variable definitions: " ++ pr_idpred ids) ++ fnl () ++
+  hov 2 (str"Unfoldable constant definitions: " ++ pr_cpred csts) ++ fnl () ++
+  hov 2 (str"Cut: " ++ pp_hints_path (Hint_db.cut db)) ++ fnl () ++
+  content
+
+let pr_hint_db_by_name dbname =
+  try
+    let db = searchtable_map dbname in pr_hint_db db
+  with Not_found ->
+    error_no_such_hint_database dbname
+
+(* displays all the hints of all databases *)
+let pr_searchtable () =
+  let fold name db accu =
+    accu ++ str "In the database " ++ str name ++ str ":" ++ fnl () ++
+    pr_hint_db db ++ fnl ()
+  in
+  Hintdbmap.fold fold !searchtable (mt ())
+
diff --git a/tactics/hints.mli b/tactics/hints.mli
new file mode 100644
index 00000000..45cf562c
--- /dev/null
+++ b/tactics/hints.mli
@@ -0,0 +1,227 @@
+(************************************************************************)
+(*  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 Pp
+open Util
+open Names
+open Term
+open Context
+open Environ
+open Globnames
+open Decl_kinds
+open Evd
+open Misctypes
+open Clenv
+open Pattern
+open Vernacexpr
+
+(** {6 General functions. } *)
+
+exception Bound
+
+val decompose_app_bound : constr -> global_reference * constr array
+
+(** Pre-created hint databases *)
+
+type 'a auto_tactic =
+  | Res_pf     of 'a (* Hint Apply *)
+  | ERes_pf    of 'a (* Hint EApply *)
+  | Give_exact of 'a
+  | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *)
+  | Unfold_nth of evaluable_global_reference       (* Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr       (* Hint Extern *)
+
+type hints_path_atom = 
+  | PathHints of global_reference list
+  | PathAny
+
+type 'a gen_auto_tactic = {
+  pri   : int;            (** A number between 0 and 4, 4 = lower priority *)
+  poly  : polymorphic;    (** Is the hint polymorpic and hence should be refreshed at each application *)
+  pat   : constr_pattern option; (** A pattern for the concl of the Goal *)
+  name  : hints_path_atom; (** A potential name to refer to the hint *) 
+  code  : 'a auto_tactic; (** the tactic to apply when the concl matches pat *)
+}
+
+type pri_auto_tactic = (constr * clausenv) gen_auto_tactic
+
+type search_entry
+
+(** The head may not be bound. *)
+
+type hint_entry = global_reference option * 
+  (constr * types * Univ.universe_context_set) gen_auto_tactic
+
+type hints_path =
+  | PathAtom of hints_path_atom
+  | PathStar of hints_path
+  | PathSeq of hints_path * hints_path
+  | PathOr of hints_path * hints_path
+  | PathEmpty
+  | PathEpsilon
+
+val normalize_path : hints_path -> hints_path
+val path_matches : hints_path -> hints_path_atom list -> bool
+val path_derivate : hints_path -> hints_path_atom -> hints_path
+val pp_hints_path : hints_path -> Pp.std_ppcmds
+
+module Hint_db :
+  sig
+    type t
+    val empty : transparent_state -> bool -> t
+    val find : global_reference -> t -> search_entry
+    val map_none : t -> pri_auto_tactic list
+
+    (** All hints associated to the reference *)
+    val map_all : global_reference -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments, _not_ using the discrimination net. *)
+    val map_existential : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments and using the discrimination net. *)
+    val map_eauto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    (** All hints associated to the reference, respecting modes if evars appear in the 
+	arguments. *)
+    val map_auto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list
+
+    val add_one : hint_entry -> t -> t
+    val add_list : (hint_entry) list -> t -> t
+    val remove_one : global_reference -> t -> t
+    val remove_list : global_reference list -> t -> t
+    val iter : (global_reference option -> bool array list -> pri_auto_tactic list -> unit) -> t -> unit
+
+    val use_dn : t -> bool
+    val transparent_state : t -> transparent_state
+    val set_transparent_state : t -> transparent_state -> t
+
+    val add_cut : hints_path -> t -> t
+    val cut : t -> hints_path
+
+    val unfolds : t -> Id.Set.t * Cset.t
+  end
+
+type hint_db_name = string
+
+type hint_db = Hint_db.t
+
+type hnf = bool
+
+type hint_term =
+  | IsGlobRef of global_reference
+  | IsConstr of constr * Univ.universe_context_set
+
+type hints_entry =
+  | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * 
+			  hint_term) list
+  | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list
+  | HintsCutEntry of hints_path
+  | HintsUnfoldEntry of evaluable_global_reference list
+  | HintsTransparencyEntry of evaluable_global_reference list * bool
+  | HintsModeEntry of global_reference * bool list      
+  | HintsExternEntry of
+      int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
+
+val searchtable_map : hint_db_name -> hint_db
+
+val searchtable_add : (hint_db_name * hint_db) -> unit
+
+(** [create_hint_db local name st use_dn].
+   [st] is a transparency state for unification using this db
+   [use_dn] switches the use of the discrimination net for all hints
+   and patterns. *)
+
+val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit
+
+val remove_hints : bool -> hint_db_name list -> global_reference list -> unit
+
+val current_db_names : unit -> String.Set.t
+
+val current_pure_db : unit -> hint_db list
+
+val interp_hints : polymorphic -> hints_expr -> hints_entry
+
+val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
+
+val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> 
+  open_constr -> hint_term
+
+(** [make_exact_entry pri (c, ctyp)].
+   [c] is the term given as an exact proof to solve the goal;
+   [ctyp] is the type of [c]. *)
+
+val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
+
+(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)].
+   [eapply] is true if this hint will be used only with EApply;
+   [hnf] should be true if we should expand the head of cty before searching for
+   products;
+   [c] is the term given as an exact proof to solve the goal;
+   [cty] is the type of [c]. *)
+
+val make_apply_entry :
+  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  (constr * types * Univ.universe_context_set) -> hint_entry
+
+(** A constr which is Hint'ed will be:
+   - (1) used as an Exact, if it does not start with a product
+   - (2) used as an Apply, if its HNF starts with a product, and
+         has no missing arguments.
+   - (3) used as an EApply, if its HNF starts with a product, and
+         has missing arguments. *)
+
+val make_resolves :
+  env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> 
+  hint_term -> hint_entry list
+
+(** [make_resolve_hyp hname htyp].
+   used to add an hypothesis to the local hint database;
+   Never raises a user exception;
+   If the hyp cannot be used as a Hint, the empty list is returned. *)
+
+val make_resolve_hyp :
+  env -> evar_map -> named_declaration -> hint_entry list
+
+(** [make_extern pri pattern tactic_expr] *)
+
+val make_extern :
+  int -> constr_pattern option -> Tacexpr.glob_tactic_expr
+      -> hint_entry
+
+val extern_intern_tac :
+  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t
+
+(** Create a Hint database from the pairs (name, constr).
+   Useful to take the current goal hypotheses as hints;
+   Boolean tells if lemmas with evars are allowed *)
+
+val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db
+
+val make_db_list : hint_db_name list -> hint_db list
+
+(** Initially created hint databases, for typeclasses and rewrite *)
+
+val typeclasses_db : hint_db_name
+val rewrite_db : hint_db_name
+
+(** Printing  hints *)
+
+val pr_searchtable : unit -> std_ppcmds
+val pr_applicable_hint : unit -> std_ppcmds
+val pr_hint_ref : global_reference -> std_ppcmds
+val pr_hint_db_by_name : hint_db_name -> std_ppcmds
+val pr_hint_db : Hint_db.t -> std_ppcmds
+val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds
+
+(** Hook for changing the initialization of auto *)
+
+val add_hints_init : (unit -> unit) -> unit
+
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index f8c1db27..4b94f420 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -1,29 +1,24 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
+(*i camlp4deps: "grammar/grammar.cma grammar/q_constr.cmo" i*)
 
 open Pp
+open Errors
 open Util
 open Names
-open Nameops
 open Term
-open Sign
 open Termops
-open Reductionops
 open Inductiveops
-open Evd
-open Environ
-open Clenv
-open Pattern
-open Matching
+open Constr_matching
 open Coqlib
 open Declarations
+open Tacmach.New
 
 (* I implemented the following functions which test whether a term t
    is an inductive but non-recursive type, a general conjuction, a
@@ -52,8 +47,8 @@ let match_with_non_recursive_type t =
     | App _ ->
         let (hdapp,args) = decompose_app t in
         (match kind_of_term hdapp with
-           | Ind ind ->
-               if not (Global.lookup_mind (fst ind)).mind_finite then
+           | Ind (ind,u) ->
+               if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then
 		 Some (hdapp,args)
 	       else
 		 None
@@ -83,55 +78,67 @@ let has_nodep_prod = has_nodep_prod_after 0
 
 (* style: None = record; Some false = conjunction; Some true = strict conj *)
 
-let match_with_one_constructor style allow_rec t =
+let is_strict_conjunction = function
+| Some true -> true
+| _ -> false
+
+let is_lax_conjunction = function
+| Some false -> true
+| _ -> false
+
+let match_with_one_constructor style onlybinary allow_rec t =
   let (hdapp,args) = decompose_app t in
-  match kind_of_term hdapp with
+  let res = match kind_of_term hdapp with
   | Ind ind ->
-      let (mib,mip) = Global.lookup_inductive ind in
-      if (Array.length mip.mind_consnames = 1)
-	&& (allow_rec or not (mis_is_recursive (ind,mib,mip)))
-        && (mip.mind_nrealargs = 0)
+      let (mib,mip) = Global.lookup_inductive (fst ind) in
+      if Int.equal (Array.length mip.mind_consnames) 1
+	&& (allow_rec || not (mis_is_recursive (fst ind,mib,mip)))
+        && (Int.equal mip.mind_nrealargs 0)
       then
-	if style = Some true (* strict conjunction *) then
+	if is_strict_conjunction style (* strict conjunction *) then
 	  let ctx =
 	    (prod_assum (snd
 	      (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in
 	  if
 	    List.for_all
-	      (fun (_,b,c) -> b=None && isRel c && destRel c = mib.mind_nparams) ctx
+	      (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx
 	  then
 	    Some (hdapp,args)
 	  else None
 	else
 	  let ctyp = prod_applist mip.mind_nf_lc.(0) args in
 	  let cargs = List.map pi3 ((prod_assum ctyp)) in
-	  if style <> Some false || has_nodep_prod ctyp then
+	  if not (is_lax_conjunction style) || has_nodep_prod ctyp then
 	    (* Record or non strict conjunction *)
 	    Some (hdapp,List.rev cargs)
 	  else
 	      None
       else
 	None
+  | _ -> None in
+  match res with
+  | Some (hdapp, args) when not onlybinary -> res
+  | Some (hdapp, [_; _]) -> res
   | _ -> None
 
-let match_with_conjunction ?(strict=false) t =
-  match_with_one_constructor (Some strict) false t
+let match_with_conjunction ?(strict=false) ?(onlybinary=false) t =
+  match_with_one_constructor (Some strict) onlybinary false t
 
 let match_with_record t =
-  match_with_one_constructor None false t
+  match_with_one_constructor None false false t
 
-let is_conjunction ?(strict=false) t =
-  op2bool (match_with_conjunction ~strict t)
+let is_conjunction ?(strict=false) ?(onlybinary=false) t =
+  op2bool (match_with_conjunction ~strict ~onlybinary t)
 
 let is_record t =
   op2bool (match_with_record t)
 
 let match_with_tuple t =
-  let t = match_with_one_constructor None true t in
+  let t = match_with_one_constructor None false true t in
   Option.map (fun (hd,l) ->
     let ind = destInd hd in
-    let (mib,mip) = Global.lookup_inductive ind in
-    let isrec = mis_is_recursive (ind,mib,mip) in
+    let (mib,mip) = Global.lookup_pinductive ind in
+    let isrec = mis_is_recursive (fst ind,mib,mip) in
     (hd,l,isrec)) t
 
 let is_tuple t =
@@ -143,20 +150,20 @@ let is_tuple t =
    "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *)
 
 let test_strict_disjunction n lc =
-  array_for_all_i (fun i c ->
+  Array.for_all_i (fun i c ->
     match (prod_assum (snd (decompose_prod_n_assum n c))) with
-    | [_,None,c] -> isRel c && destRel c = (n - i)
+    | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i)
     | _ -> false) 0 lc
 
-let match_with_disjunction ?(strict=false) t =
+let match_with_disjunction ?(strict=false) ?(onlybinary=false) t =
   let (hdapp,args) = decompose_app t in
-  match kind_of_term hdapp with
-  | Ind ind  ->
-      let car = mis_constr_nargs ind in
+  let res = match kind_of_term hdapp with
+  | Ind (ind,u)  ->
+      let car = constructors_nrealargs ind in
       let (mib,mip) = Global.lookup_inductive ind in
-      if array_for_all (fun ar -> ar = 1) car
-        && not (mis_is_recursive (ind,mib,mip))
-        && (mip.mind_nrealargs = 0)
+      if Array.for_all (fun ar -> Int.equal ar 1) car
+	&& not (mis_is_recursive (ind,mib,mip))
+        && (Int.equal mip.mind_nrealargs 0)
       then
 	if strict then
 	  if test_strict_disjunction mib.mind_nparams mip.mind_nf_lc then
@@ -170,10 +177,14 @@ let match_with_disjunction ?(strict=false) t =
 	  Some (hdapp,Array.to_list cargs)
       else
 	None
+  | _ -> None in
+  match res with
+  | Some (hdapp,args) when not onlybinary -> res
+  | Some (hdapp,[_; _]) -> res
   | _ -> None
 
-let is_disjunction ?(strict=false) t =
-  op2bool (match_with_disjunction ~strict t)
+let is_disjunction ?(strict=false) ?(onlybinary=false) t =
+  op2bool (match_with_disjunction ~strict ~onlybinary t)
 
 (* An empty type is an inductive type, possible with indices, that has no
    constructors *)
@@ -182,9 +193,9 @@ let match_with_empty_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 0 then Some hdapp else None
+	if Int.equal nconstr 0 then Some hdapp else None
     | _ ->  None
 
 let is_empty_type t = op2bool (match_with_empty_type t)
@@ -196,11 +207,11 @@ let match_with_unit_or_eq_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
+        let (mib,mip) = Global.lookup_pinductive ind in
         let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-        let zero_args c = nb_prod c = mib.mind_nparams in
-	if nconstr = 1 && zero_args constr_types.(0) then
+        let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in
+	if Int.equal nconstr 1 && zero_args constr_types.(0) then
 	  Some hdapp
 	else
 	  None
@@ -214,7 +225,7 @@ let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t)
 
 let is_unit_type t =
   match match_with_conjunction t with
-  | Some (_,t) when List.length t = 0 -> true
+  | Some (_,[]) -> true
   | _ -> false
 
 (* Checks if a given term is an application of an
@@ -232,27 +243,30 @@ let coq_refl_leibniz1_pattern = PATTERN [ forall x:_, _ x x ]
 let coq_refl_leibniz2_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ]
 let coq_refl_jm_pattern       = PATTERN [ forall A:_, forall x:A, _ A x A x ]
 
-open Libnames
+open Globnames
+
+let is_matching x y = is_matching (Global.env ()) Evd.empty x y
+let matches x y = matches (Global.env ()) Evd.empty x y
 
 let match_with_equation t =
   if not (isApp t) then raise NoEquationFound;
   let (hdapp,args) = destApp t in
   match kind_of_term hdapp with
-  | Ind ind ->
-      if IndRef ind = glob_eq then
+  | Ind (ind,u) ->
+      if eq_gr (IndRef ind) glob_eq then
 	Some (build_coq_eq_data()),hdapp,
 	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
-      else if IndRef ind = glob_identity then
+      else if eq_gr (IndRef ind) glob_identity then
 	Some (build_coq_identity_data()),hdapp,
 	PolymorphicLeibnizEq(args.(0),args.(1),args.(2))
-      else if IndRef ind = glob_jmeq then
+      else if eq_gr (IndRef ind) glob_jmeq then
 	Some (build_coq_jmeq_data()),hdapp,
 	HeterogenousEq(args.(0),args.(1),args.(2),args.(3))
       else
         let (mib,mip) = Global.lookup_inductive ind in
         let constr_types = mip.mind_nf_lc in
         let nconstr = Array.length mip.mind_consnames in
-	if nconstr = 1 then
+	if Int.equal nconstr 1 then
           if is_matching coq_refl_leibniz1_pattern constr_types.(0) then
 	    None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1))
 	  else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then
@@ -263,25 +277,41 @@ let match_with_equation t =
         else raise NoEquationFound
     | _ -> raise NoEquationFound
 
+(* Note: An "equality type" is any type with a single argument-free
+   constructor: it captures eq, eq_dep, JMeq, eq_true, etc. but also
+   True/unit which is the degenerate equality type (isomorphic to ()=());
+   in particular, True/unit are provable by "reflexivity" *)
+
 let is_inductive_equality ind =
   let (mib,mip) = Global.lookup_inductive ind in
   let nconstr = Array.length mip.mind_consnames in
-  nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0
+  Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0
 
 let match_with_equality_type t =
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
-  | Ind ind when is_inductive_equality ind -> Some (hdapp,args)
+  | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args)
   | _ -> None
 
 let is_equality_type t = op2bool (match_with_equality_type t)
 
+(* Arrows/Implication/Negation *)
+
 let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ]
 
 let match_arrow_pattern t =
-  match matches coq_arrow_pattern t with
-    | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
-    | _ -> anomaly "Incorrect pattern matching"
+  let result = matches coq_arrow_pattern t in
+  match Id.Map.bindings result with
+    | [(m1,arg);(m2,mind)] ->
+      assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind)
+    | _ -> anomaly (Pp.str "Incorrect pattern matching")
+
+let match_with_imp_term c=
+  match kind_of_term c with
+    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
+    | _              -> None
+
+let is_imp_term c = op2bool (match_with_imp_term c)
 
 let match_with_nottype t =
   try
@@ -291,6 +321,8 @@ let match_with_nottype t =
 
 let is_nottype t = op2bool (match_with_nottype t)
 
+(* Forall *)
+
 let match_with_forall_term c=
   match kind_of_term c with
     | Prod (nam,a,b) -> Some (nam,a,b)
@@ -298,24 +330,17 @@ let match_with_forall_term c=
 
 let is_forall_term c = op2bool (match_with_forall_term c)
 
-let match_with_imp_term c=
-  match kind_of_term c with
-    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
-    | _              -> None
-
-let is_imp_term c = op2bool (match_with_imp_term c)
-
 let match_with_nodep_ind t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
       | Ind ind  ->
-          let (mib,mip) = Global.lookup_inductive ind in
+          let (mib,mip) = Global.lookup_pinductive ind in
 	    if Array.length (mib.mind_packets)>1 then None else
 	      let nodep_constr = has_nodep_prod_after mib.mind_nparams in
-		if array_for_all nodep_constr mip.mind_nf_lc then
+		if Array.for_all nodep_constr mip.mind_nf_lc then
 		  let params=
-		    if mip.mind_nrealargs=0 then args else
-		      fst (list_chop mib.mind_nparams args) in
+		    if Int.equal mip.mind_nrealargs 0 then args else
+		      fst (List.chop mib.mind_nparams args) in
 		    Some (hdapp,params,mip.mind_nrealargs)
 		else
 		  None
@@ -327,10 +352,10 @@ let match_with_sigma_type t=
   let (hdapp,args) = decompose_app t in
   match (kind_of_term hdapp) with
     | Ind ind  ->
-        let (mib,mip) = Global.lookup_inductive ind in
-          if (Array.length (mib.mind_packets)=1) &&
-	    (mip.mind_nrealargs=0) &&
-	    (Array.length mip.mind_consnames=1) &&
+        let (mib,mip) = Global.lookup_pinductive ind in
+          if Int.equal (Array.length (mib.mind_packets)) 1 &&
+	    (Int.equal mip.mind_nrealargs 0) &&
+	    (Int.equal (Array.length mip.mind_consnames)1) &&
 	    has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then
 	      (*allowing only 1 existential*)
 	      Some (hdapp,args)
@@ -344,9 +369,10 @@ let is_sigma_type t=op2bool (match_with_sigma_type t)
 
 let rec first_match matcher = function
   | [] -> raise PatternMatchingFailure
-  | (pat,build_set)::l ->
-      try (build_set (),matcher pat)
-      with PatternMatchingFailure -> first_match matcher l
+  | (pat,check,build_set)::l when check () ->
+      (try (build_set (),matcher pat)
+       with PatternMatchingFailure -> first_match matcher l)
+  | _::l -> first_match matcher l
 
 (*** Equality *)
 
@@ -355,50 +381,48 @@ let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ]
 let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref
 let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref
 let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ]
-let coq_eq_true_pattern = lazy PATTERN [ %coq_eq_true_ref ?X1 ]
 
 let match_eq eqn eq_pat =
   let pat =
     try Lazy.force eq_pat
     with e when Errors.noncritical e -> raise PatternMatchingFailure
   in
-  match matches pat eqn with
+  match Id.Map.bindings (matches pat eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
-	PolymorphicLeibnizEq (t,x,y)
+	assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
+        PolymorphicLeibnizEq (t,x,y)
     | [(m1,t);(m2,x);(m3,t');(m4,x')] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3 & m4 = meta4);
+        assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3 && Id.equal m4 meta4);
 	HeterogenousEq (t,x,t',x')
-    | _ -> anomaly "match_eq: an eq pattern should match 3 or 4 terms"
+    | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 or 4 terms")
+
+let no_check () = true
+let check_jmeq_loaded () = Library.library_is_loaded Coqlib.jmeq_module
 
 let equalities =
-  [coq_eq_pattern, build_coq_eq_data;
-   coq_jmeq_pattern, build_coq_jmeq_data;
-   coq_identity_pattern, build_coq_identity_data]
+  [coq_eq_pattern, no_check, build_coq_eq_data;
+   coq_jmeq_pattern, check_jmeq_loaded, build_coq_jmeq_data;
+   coq_identity_pattern, no_check, build_coq_identity_data]
 
 let find_eq_data eqn = (* fails with PatternMatchingFailure *)
-  first_match (match_eq eqn) equalities
+  let d,k = first_match (match_eq eqn) equalities in
+  let hd,u = destInd (fst (destApp eqn)) in
+    d,u,k
 
 let extract_eq_args gl = function
   | MonomorphicLeibnizEq (e1,e2) ->
-      let t = Tacmach.pf_type_of gl e1 in (t,e1,e2)
+      let t = pf_type_of gl e1 in (t,e1,e2)
   | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2)
   | HeterogenousEq (t1,e1,t2,e2) ->
-      if Tacmach.pf_conv_x gl t1 t2 then (t1,e1,e2)
+      if pf_conv_x gl t1 t2 then (t1,e1,e2)
       else raise PatternMatchingFailure
 
 let find_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) = find_eq_data eqn in
-  (lbeq,extract_eq_args gl eq_args)
-
-let inversible_equalities =
-  [coq_eq_pattern, build_coq_inversion_eq_data;
-   coq_jmeq_pattern, build_coq_inversion_jmeq_data;
-   coq_identity_pattern, build_coq_inversion_identity_data;
-   coq_eq_true_pattern, build_coq_inversion_eq_true_data]
+  let (lbeq,u,eq_args) = find_eq_data eqn in
+  (lbeq,u,extract_eq_args gl eq_args)
 
 let find_this_eq_data_decompose gl eqn =
-  let (lbeq,eq_args) =
+  let (lbeq,u,eq_args) =
     try (*first_match (match_eq eqn) inversible_equalities*)
       find_eq_data eqn
     with PatternMatchingFailure ->
@@ -407,17 +431,14 @@ let find_this_eq_data_decompose gl eqn =
     try extract_eq_args gl eq_args
     with PatternMatchingFailure ->
       error "Don't know what to do with JMeq on arguments not of same type." in
-  (lbeq,eq_args)
-
-open Tacmach
-open Tacticals
+  (lbeq,u,eq_args)
 
 let match_eq_nf gls eqn eq_pat =
-  match pf_matches gls (Lazy.force eq_pat) eqn with
+  match Id.Map.bindings (pf_matches gls (Lazy.force eq_pat) eqn) with
     | [(m1,t);(m2,x);(m3,y)] ->
-	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+        assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
 	(t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y)
-    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+    | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms")
 
 let dest_nf_eq gls eqn =
   try
@@ -427,31 +448,24 @@ let dest_nf_eq gls eqn =
 
 (*** Sigma-types *)
 
-(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *)
-let coq_ex_pattern_gen ex = lazy PATTERN [ %ex ?X1 ?X2 ?X3 ?X4 ]
-let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref
-let coq_exist_pattern = coq_ex_pattern_gen coq_exist_ref
-
-let match_sigma ex ex_pat =
-  match matches (Lazy.force ex_pat) ex with
-    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] ->
-	assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4);
-	(a,p,car,cdr)
-    | _ ->
-	anomaly "match_sigma: a successful sigma pattern should match 4 terms"
-
+let match_sigma ex =
+  match kind_of_term ex with
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> 
+      build_sigma (), (snd (destConstruct f), a, p, car, cdr)
+  | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> 
+    build_sigma_type (), (snd (destConstruct f), a, p, car, cdr)
+  | _ -> raise PatternMatchingFailure
+    
 let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
-  first_match (match_sigma ex)
-    [coq_existT_pattern, build_sigma_type;
-     coq_exist_pattern, build_sigma]
+  match_sigma ex
 
 (* Pattern "(sig ?1 ?2)" *)
 let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ]
 
 let match_sigma t =
-  match matches (Lazy.force coq_sig_pattern) t with
+  match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with
     | [(_,a); (_,p)] -> (a,p)
-    | _ -> anomaly "Unexpected pattern"
+    | _ -> anomaly (Pp.str "Unexpected pattern")
 
 let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t
 
@@ -486,10 +500,10 @@ let match_eqdec t =
     try true,op_or,matches (Lazy.force coq_eqdec_pattern) t
     with PatternMatchingFailure ->
         false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in
-  match subst with
+  match Id.Map.bindings subst with
   | [(_,typ);(_,c1);(_,c2)] ->
-      eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ
-  | _ -> anomaly "Unexpected pattern"
+      eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ
+  | _ -> anomaly (Pp.str "Unexpected pattern")
 
 (* Patterns "~ ?" and "? -> False" *)
 let coq_not_pattern = lazy PATTERN [ ~ _ ]
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 31dd0361..c200871e 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -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 Util
 open Names
 open Term
-open Sign
 open Evd
-open Pattern
 open Coqlib
 
 (** High-order patterns *)
@@ -52,13 +49,13 @@ val is_non_recursive_type         : testing_function
 
 (** Non recursive type with no indices and exactly one argument for each
    constructor; canonical definition of n-ary disjunction if strict *)
-val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function
-val is_disjunction         : ?strict:bool -> testing_function
+val match_with_disjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function
+val is_disjunction         : ?strict:bool -> ?onlybinary:bool -> testing_function
 
 (** Non recursive tuple (one constructor and no indices) with no inner
    dependencies; canonical definition of n-ary conjunction if strict *)
-val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function
-val is_conjunction         : ?strict:bool -> testing_function
+val match_with_conjunction : ?strict:bool -> ?onlybinary:bool -> (constr * constr list) matching_function
+val is_conjunction         : ?strict:bool -> ?onlybinary:bool -> testing_function
 
 (** Non recursive tuple, possibly with inner dependencies *)
 val match_with_record      : (constr * constr list) matching_function
@@ -87,7 +84,7 @@ val is_equality_type       : testing_function
 val match_with_nottype     : (constr * constr) matching_function
 val is_nottype             : testing_function
 
-val match_with_forall_term    : (name * constr * constr) matching_function
+val match_with_forall_term    : (Name.t * constr * constr) matching_function
 val is_forall_term            : testing_function
 
 val match_with_imp_term    : (constr * constr) matching_function
@@ -123,20 +120,20 @@ val match_with_equation:
 
 (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] 
    Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *)
-val find_eq_data_decompose : Proof_type.goal sigma -> constr ->
-      coq_eq_data * (types * constr * constr)
+val find_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** Idem but fails with an error message instead of PatternMatchingFailure *)
-val find_this_eq_data_decompose : Proof_type.goal sigma -> constr ->
-      coq_eq_data * (types * constr * constr)
+val find_this_eq_data_decompose : [ `NF ] Proofview.Goal.t -> constr ->
+      coq_eq_data * Univ.universe_instance * (types * constr * constr)
 
 (** A variant that returns more informative structure on the equality found *)
-val find_eq_data : constr -> coq_eq_data * equation_kind
+val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind
 
 (** Match a term of the form [(existT A P t p)] 
    Returns associated lemmas and [A,P,t,p] *)
 val find_sigma_data_decompose : constr ->
-  coq_sigma_data * (constr * constr * constr * constr)
+  coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr)
 
 (** Match a term of the form [{x:A|P}], returns [A] and [P] *)
 val match_sigma : constr -> constr * constr
@@ -150,7 +147,7 @@ val match_eqdec : constr -> bool * constr * constr * constr * constr
 (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
 open Proof_type
 open Tacmach
-val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr)
+val dest_nf_eq : [ `NF ] Proofview.Goal.t -> constr -> (constr * constr * constr)
 
 (** Match a negation *)
 val is_matching_not : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 73edaf86..5502356f 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -1,63 +1,40 @@
 (************************************************************************)
 (*  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
 open Nameops
 open Term
+open Vars
+open Context
 open Termops
 open Namegen
-open Global
-open Sign
 open Environ
 open Inductiveops
 open Printer
-open Reductionops
 open Retyping
-open Tacmach
-open Proof_type
-open Evar_refiner
-open Clenv
-open Tactics
-open Tacticals
+open Tacmach.New
+open Tacticals.New
 open Tactics
 open Elim
 open Equality
-open Typing
-open Pattern
-open Matching
-open Glob_term
-open Genarg
+open Misctypes
 open Tacexpr
+open Proofview.Notations
 
-let collect_meta_variables c =
-  let rec collrec acc c = match kind_of_term c with
-    | Meta mv -> mv::acc
-    | _ -> fold_constr collrec acc c
-  in
-  collrec [] c
-
-let check_no_metas clenv ccl =
-  if occur_meta ccl then
-    let metas = List.filter (fun m -> not (Evd.meta_defined clenv.evd m))
-      (collect_meta_variables ccl) in
-    let metas = List.map (Evd.meta_name clenv.evd) metas in
-    errorlabstrm "inversion"
-      (str ("Cannot find an instantiation for variable"^
-	       (if List.length metas = 1 then " " else "s ")) ++
-	 prlist_with_sep pr_comma pr_name metas
-	 (* ajouter "in " ++ pr_lconstr ccl mais il faut le bon contexte *))
+let clear hyps = Proofview.V82.tactic (clear hyps)
 
 let var_occurs_in_pf gl id =
-  let env = pf_env gl in
-  occur_var env id (pf_concl gl) or
-  List.exists (occur_var_in_decl env id) (pf_hyps gl)
+  let env = Proofview.Goal.env gl in
+  occur_var env id (Proofview.Goal.concl gl) ||
+  List.exists (occur_var_in_decl env id) (Proofview.Goal.hyps gl)
 
 (* [make_inv_predicate (ity,args) C]
 
@@ -88,16 +65,16 @@ let var_occurs_in_pf gl id =
 type inversion_status = Dep of constr option | NoDep
 
 let compute_eqn env sigma n i ai =
-  (ai, (mkRel (n-i),get_type_of env sigma (mkRel (n-i))))
+  (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))
 
-let make_inv_predicate env sigma indf realargs id status concl =
+let make_inv_predicate env evd indf realargs id status concl =
   let nrealargs = List.length realargs in
   let (hyps,concl) =
     match status with
       | NoDep ->
 	  (* We push the arity and leave concl unchanged *)
 	  let hyps_arity,_ = get_arity env indf in
-	  (hyps_arity,concl)
+	    (hyps_arity,concl)
       | Dep dflt_concl ->
 	  if not (occur_var env id concl) then
 	    errorlabstrm "make_inv_predicate"
@@ -109,41 +86,53 @@ let make_inv_predicate env sigma indf realargs id status concl =
             match dflt_concl with
               | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
               | None ->
-		let sort = get_sort_family_of env sigma concl in
-		let p = make_arity env true indf (new_sort_in_family sort) in
-		Unification.abstract_list_all env (Evd.create_evar_defs sigma)
-		  p concl (realargs@[mkVar id]) in
+		let sort = get_sort_family_of env !evd concl in
+		let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in
+		let p = make_arity env true indf sort in
+		let evd',(p,ptyp) = Unification.abstract_list_all env
+                  !evd p concl (realargs@[mkVar id])
+		in evd := evd'; p in
 	  let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
 	  (* We lift to make room for the equations *)
 	  (hyps,lift nrealargs bodypred)
   in
   let nhyps = rel_context_length hyps in
   let env' = push_rel_context hyps env in
-  let realargs' = List.map (lift nhyps) realargs in
-  let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in
   (* Now the arity is pushed, and we need to construct the pairs
    * ai,mkRel(n-i+1) *)
   (* Now, we can recurse down this list, for each ai,(mkRel k) whether to
      push <Ai>(mkRel k)=ai (when   Ai is closed).
    In any case, we carry along the rest of pairs *)
-  let rec build_concl eqns n = function
-    | [] -> (it_mkProd concl eqns,n)
-    | (ai,(xi,ti))::restlist ->
+  let eqdata = Coqlib.build_coq_eq_data () in
+  let rec build_concl eqns args n = function
+    | [] -> it_mkProd concl eqns, Array.rev_of_list args
+    | ai :: restlist ->
+        let ai = lift nhyps ai in
+        let (xi, ti) = compute_eqn env' !evd nhyps n ai in
         let (lhs,eqnty,rhs) =
           if closed0 ti then
 	    (xi,ti,ai)
           else
-	    make_iterated_tuple env' sigma ai (xi,ti)
+	    let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in
+	      evd := sigma; res
 	in
-        let eq_term = Coqlib.build_coq_eq () in
-        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in
-	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
+        let eq_term = eqdata.Coqlib.eq in
+	let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in
+        let eqn = applist (eq,[eqnty;lhs;rhs]) in
+        let eqns = (Anonymous, lift n eqn) :: eqns in
+        let refl_term = eqdata.Coqlib.refl in
+	let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in
+        let refl = mkApp (refl_term, [|eqnty; rhs|]) in
+	let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd refl in
+        let args = refl :: args in
+        build_concl eqns args (succ n) restlist
   in
-  let (newconcl,neqns) = build_concl [] 0 pairs in
+  let (newconcl, args) = build_concl [] [] 0 realargs in
   let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in
+  let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd predicate in
   (* OK - this predicate should now be usable by res_elimination_then to
      do elimination on the conclusion. *)
-  (predicate,neqns)
+  predicate, args
 
 (* The result of the elimination is a bunch of goals like:
 
@@ -189,13 +178,13 @@ let make_inv_predicate env sigma indf realargs id status concl =
    and introduces generalized hypotheis.
    Precondition: t=(mkVar id) *)
 
-let rec dependent_hyps id idlist gl =
+let dependent_hyps env id idlist gl =
   let rec dep_rec =function
     | [] -> []
     | (id1,_,_)::l ->
 	(* Update the type of id1: it may have been subject to rewriting *)
-	let d = pf_get_hyp gl id1 in
-	if occur_var_in_decl (Global.env()) id d
+	let d = pf_get_hyp id1 gl in
+	if occur_var_in_decl env id d
         then d :: dep_rec l
         else dep_rec l
   in
@@ -207,8 +196,6 @@ let split_dep_and_nodep hyps gl =
        if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
     hyps ([],[])
 
-open Coqlib
-
 (* Computation of dids is late; must have been done in rewrite_equations*)
 (* Will keep generalizing and introducing back and forth... *)
 (* Moreover, others hyps depending of dids should have been *)
@@ -280,21 +267,62 @@ Summary: nine useless hypotheses!
 Nota: with Inversion_clear, only four useless hypotheses
 *)
 
-let generalizeRewriteIntros tac depids id gls =
-  let dids = dependent_hyps id depids gls in
-  (tclTHENSEQ
+let generalizeRewriteIntros as_mode tac depids id =
+  Proofview.tclENV >>= fun env ->
+  Proofview.Goal.nf_enter begin fun gl ->
+  let dids = dependent_hyps env id depids gl in
+  let reintros = if as_mode then intros_replacing else intros_possibly_replacing in
+  (tclTHENLIST
     [bring_hyps dids; tac;
      (* may actually fail to replace if dependent in a previous eq *)
-     intros_replacing (ids_of_named_context dids)])
-  gls
-
-let rec tclMAP_i n tacfun = function
-  | [] -> tclDO n (tacfun None)
-  | a::l ->
-      if n=0 then error "Too many names."
-      else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
+     reintros (ids_of_named_context dids)])
+  end
+
+let error_too_many_names pats =
+  let loc = Loc.join_loc (fst (List.hd pats)) (fst (List.last pats)) in
+  Proofview.tclENV >>= fun env ->
+  tclZEROMSG ~loc (
+    str "Unexpected " ++
+    str (String.plural (List.length pats) "introduction pattern") ++
+    str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (snd (c env Evd.empty)))) pats ++
+    str ".")
+
+let rec get_names (allow_conj,issimple) (loc,pat as x) = match pat with
+  | IntroNaming IntroAnonymous | IntroForthcoming _ ->
+      error "Anonymous pattern not allowed for inversion equations."
+  | IntroNaming (IntroFresh _) ->
+      error "Fresh pattern not allowed for inversion equations."
+  | IntroAction IntroWildcard ->
+      error "Discarding pattern not allowed for inversion equations."
+  | IntroAction (IntroRewrite _) ->
+      error "Rewriting pattern not allowed for inversion equations."
+  | IntroAction (IntroOrAndPattern [[]]) when allow_conj -> (None, [])
+  | IntroAction (IntroOrAndPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l])
+      when allow_conj -> (Some id,l)
+  | IntroAction (IntroOrAndPattern [_]) ->
+      if issimple then
+        error"Conjunctive patterns not allowed for simple inversion equations."
+      else
+        error"Nested conjunctive patterns not allowed for inversion equations."
+  | IntroAction (IntroInjection l) ->
+      error "Injection patterns not allowed for inversion equations."
+  | IntroAction (IntroOrAndPattern l) ->
+      error "Disjunctive patterns not allowed for inversion equations."
+  | IntroAction (IntroApplyOn (c,pat)) ->
+      error "Apply patterns not allowed for inversion equations."
+  | IntroNaming (IntroIdentifier id) ->
+      (Some id,[x])
+
+let rec tclMAP_i allow_conj n tacfun = function
+  | [] -> tclDO n (tacfun (None,[]))
+  | a::l as l' ->
+      if Int.equal n 0 then error_too_many_names l'
+      else
+        tclTHEN
+          (tacfun (get_names allow_conj a))
+          (tclMAP_i allow_conj (n-1) tacfun l)
 
-let remember_first_eq id x = if !x = no_move then x := MoveAfter id
+let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id
 
 (* invariant: ProjectAndApply is responsible for erasing the clause
    which it is given as input
@@ -304,217 +332,177 @@ let remember_first_eq id x = if !x = no_move then x := MoveAfter id
    If it can discriminate then the goal is proved, if not tries to use it as
    a rewrite rule. It erases the clause which is given as input *)
 
-let projectAndApply thin id eqname names depids gls =
+let projectAndApply as_mode thin avoid id eqname names depids =
   let subst_hyp l2r id =
     tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id)))
       (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC))
   in
-  let substHypIfVariable tac id gls =
-    let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in
+  let substHypIfVariable tac id =
+    Proofview.Goal.nf_enter begin fun gl ->
+    (** We only look at the type of hypothesis "id" *)
+    let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in
+    let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in
     match (kind_of_term t1, kind_of_term t2) with
-    | Var id1, _ -> generalizeRewriteIntros (subst_hyp true id) depids id1 gls
-    | _, Var id2 -> generalizeRewriteIntros (subst_hyp false id) depids id2 gls
-    | _ -> tac id gls
+    | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1
+    | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2
+    | _ -> tac id
+    end
   in
-  let deq_trailer id neqns =
-    tclTHENSEQ
-      [(if names <> [] then clear [id] else tclIDTAC);
-       (tclMAP_i neqns (fun idopt ->
+  let deq_trailer id clear_flag _ neqns =
+    assert (clear_flag == None);
+    tclTHENLIST
+      [if as_mode then clear [id] else tclIDTAC;
+       (tclMAP_i (false,false) neqns (function (idopt,_) ->
 	 tclTRY (tclTHEN
-	   (intro_move idopt no_move)
+	   (intro_move_avoid idopt avoid MoveLast)
 	   (* try again to substitute and if still not a variable after *)
 	   (* decomposition, arbitrarily try to rewrite RL !? *)
-	   (tclTRY (onLastHypId (substHypIfVariable (subst_hyp false))))))
+	   (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id))))))
 	 names);
-       (if names = [] then clear [id] else tclIDTAC)]
+       (if as_mode then tclIDTAC else clear [id])]
+          (* Doing the above late breaks the computation of dids in 
+             generalizeRewriteIntros, and hence breaks proper intros_replacing
+             but it is needed for compatibility *)
   in
   substHypIfVariable
     (* If no immediate variable in the equation, try to decompose it *)
     (* and apply a trailer which again try to substitute *)
     (fun id ->
       dEqThen false (deq_trailer id)
-	(Some (ElimOnConstr (mkVar id,NoBindings))))
+	(Some (None,ElimOnConstr (mkVar id,NoBindings))))
     id
-    gls
-
-(* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer
-   soi-meme (proposition de Valerie). *)
-let rewrite_equations_gene othin neqns ba gl =
-  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
-  let rewrite_eqns =
-    match othin with
-      | Some thin ->
-          onLastHypId
-            (fun last ->
-              tclTHENSEQ
-                [tclDO neqns
-                     (tclTHEN intro
-                        (onLastHypId
-                           (fun id ->
-                              tclTRY
-			        (projectAndApply thin id (ref no_move)
-				  [] depids))));
-                 onHyps (compose List.rev (afterHyp last)) bring_hyps;
-                 onHyps (afterHyp last)
-                   (compose clear ids_of_named_context)])
-      | None -> tclIDTAC
-  in
-  (tclTHENSEQ
-    [tclDO neqns intro;
-     bring_hyps nodepids;
-     clear (ids_of_named_context nodepids);
-     onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
-     onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
-     rewrite_eqns;
-     tclMAP (fun (id,_,_ as d) ->
-               (tclORELSE (clear [id])
-                 (tclTHEN (bring_hyps [d]) (clear [id]))))
-       depids])
-  gl
+
+let nLastDecls i tac =
+  Proofview.Goal.nf_enter (fun gl -> tac (nLastDecls gl i))
 
 (* Introduction of the equations on arguments
    othin: discriminates Simple Inversion, Inversion and Inversion_clear
      None: the equations are introduced, but not rewritten
      Some thin: the equations are rewritten, and cleared if thin is true *)
 
-let rec get_names allow_conj (loc,pat) = match pat with
-  | IntroWildcard ->
-      error "Discarding pattern not allowed for inversion equations."
-  | IntroAnonymous | IntroForthcoming _ ->
-      error "Anonymous pattern not allowed for inversion equations."
-  | IntroFresh _ ->
-      error "Fresh pattern not allowed for inversion equations."
-  | IntroRewrite _->
-      error "Rewriting pattern not allowed for inversion equations."
-  | IntroOrAndPattern [l] ->
-      if allow_conj then
-	if l = [] then (None,[]) else
-	  let l = List.map (fun id -> Option.get (fst (get_names false id))) l in
-	  (Some (List.hd l), l)
-      else
-	error"Nested conjunctive patterns not allowed for inversion equations."
-  | IntroOrAndPattern l ->
-      error "Disjunctive patterns not allowed for inversion equations."
-  | IntroIdentifier id ->
-      (Some id,[id])
-
-let extract_eqn_names = function
-  | None -> None,[]
-  | Some x -> x
-
-let rewrite_equations othin neqns names ba gl =
-  let names = List.map (get_names true) names in
-  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
-  let rewrite_eqns =
-    let first_eq = ref no_move in
-    match othin with
-      | Some thin ->
-          tclTHENSEQ
-            [onHyps (compose List.rev (nLastDecls neqns)) bring_hyps;
-             onHyps (nLastDecls neqns) (compose clear ids_of_named_context);
-	     tclMAP_i neqns (fun o ->
-	       let idopt,names = extract_eqn_names o in
+let rewrite_equations as_mode othin neqns names ba =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in
+  let first_eq = ref MoveLast in
+  let avoid = if as_mode then List.map pi1 nodepids else [] in
+  match othin with
+    | Some thin ->
+        tclTHENLIST
+            [tclDO neqns intro;
+             bring_hyps nodepids;
+             clear (ids_of_named_context nodepids);
+             (nLastDecls neqns (fun ctx -> bring_hyps (List.rev ctx)));
+             (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx)));
+	     tclMAP_i (true,false) neqns (fun (idopt,names) ->
                (tclTHEN
-		 (intro_move idopt no_move)
+		 (intro_move_avoid idopt avoid MoveLast)
 		 (onLastHypId (fun id ->
-		   tclTRY (projectAndApply thin id first_eq names depids)))))
+		   tclTRY (projectAndApply as_mode thin avoid id first_eq names depids)))))
 	       names;
-	     tclMAP (fun (id,_,_) gl ->
-	       intro_move None (if thin then no_move else !first_eq) gl)
+	     tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *)
+               let idopt = if as_mode then Some id else None in
+	       intro_move idopt (if thin then MoveLast else !first_eq))
 	       nodepids;
-	     tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids]
-      | None -> tclIDTAC
-  in
-  (tclTHENSEQ
-    [tclDO neqns intro;
-     bring_hyps nodepids;
-     clear (ids_of_named_context nodepids);
-     rewrite_eqns])
-  gl
+	     (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)]
+    | None ->
+        (* simple inversion *)
+        if as_mode then
+          tclMAP_i (false,true) neqns (fun (idopt,_) ->
+	    intro_move idopt MoveLast) names
+        else
+          (tclTHENLIST
+             [tclDO neqns intro;
+              bring_hyps nodepids;
+              clear (ids_of_named_context nodepids)])
+  end
 
 let interp_inversion_kind = function
   | SimpleInversion -> None
   | FullInversion -> Some false
   | FullInversionClear -> Some true
 
-let rewrite_equations_tac (gene, othin) id neqns names ba =
+let rewrite_equations_tac as_mode othin id neqns names ba =
   let othin = interp_inversion_kind othin in
-  let tac =
-    if gene then rewrite_equations_gene othin neqns ba
-    else rewrite_equations othin neqns names ba in
-  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then
+  let tac = rewrite_equations as_mode othin neqns names ba in
+  match othin with
+  | Some true (* if Inversion_clear, clear the hypothesis *) ->
     tclTHEN tac (tclTRY (clear [id]))
-  else
+  | _ ->
     tac
 
-
-let raw_inversion inv_kind id status names gl =
-  let env = pf_env gl and sigma = project gl in
-  let c = mkVar id in
-  let (ind,t) =
-    try pf_reduce_to_atomic_ind gl (pf_type_of gl c)
-    with UserError _ ->
-      errorlabstrm "raw_inversion"
-	(str ("The type of "^(string_of_id id)^" is not inductive.")) in
-  let indclause = mk_clenv_from gl (c,t) in
-  let ccl = clenv_type indclause in
-  check_no_metas indclause ccl;
-  let IndType (indf,realargs) = find_rectype env sigma ccl in
-  let (elim_predicate,neqns) =
-    make_inv_predicate env sigma indf realargs id status (pf_concl gl) in
-  let (cut_concl,case_tac) =
-    if status <> NoDep & (dependent c (pf_concl gl)) then
-      Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
-      case_then_using
-    else
-      Reduction.beta_appvect elim_predicate (Array.of_list realargs),
-      case_nodep_then_using
-  in
-  (tclTHENS
-     (assert_tac Anonymous cut_concl)
-     [case_tac names
-       (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
-       (Some elim_predicate) ([],[]) ind indclause;
-      onLastHypId
-        (fun id ->
-           (tclTHEN
-              (apply_term (mkVar id)
-                 (list_tabulate (fun _ -> Evarutil.mk_new_meta()) neqns))
-              reflexivity))])
-  gl
+let raw_inversion inv_kind id status names =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl gl in
+    let c = mkVar id in
+    let (ind, t) =
+      try pf_apply Tacred.reduce_to_atomic_ind gl (pf_type_of gl c)
+      with UserError _ ->
+        let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in
+        Errors.errorlabstrm "" msg
+    in
+    let IndType (indf,realargs) = find_rectype env sigma t in
+    let evdref = ref sigma in
+    let (elim_predicate, args) =
+      make_inv_predicate env evdref indf realargs id status concl in
+    let sigma = !evdref in
+    let (cut_concl,case_tac) =
+      if status != NoDep && (dependent c concl) then
+        Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
+        case_then_using
+      else
+        Reduction.beta_appvect elim_predicate (Array.of_list realargs),
+        case_nodep_then_using
+    in
+    let refined id =
+      let prf = mkApp (mkVar id, args) in
+      Proofview.Refine.refine (fun h -> h, prf)
+    in
+    let neqns = List.length realargs in
+    let as_mode = names != None in
+    tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+      (tclTHENS
+        (assert_before Anonymous cut_concl)
+        [case_tac names
+            (introCaseAssumsThen
+               (rewrite_equations_tac as_mode inv_kind id neqns))
+            (Some elim_predicate) ind (c, t);
+        onLastHypId (fun id -> tclTHEN (refined id) reflexivity)])
+  end
 
 (* Error messages of the inversion tactics *)
-let wrap_inv_error id = function
+let wrap_inv_error id = function (e, info) -> match e with
   | Indrec.RecursionSchemeError
       (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) ->
-      errorlabstrm ""
+      Proofview.tclENV >>= fun env ->
+      tclZEROMSG (
 	(strbrk "Inversion would require case analysis on sort " ++
-	pr_sort k ++
+	pr_sort Evd.empty k ++
 	strbrk " which is not allowed for inductive definition " ++
-	pr_inductive (Global.env()) i ++ str ".")
-  | e -> raise e
+	pr_inductive env (fst i) ++ str "."))
+  | e -> Proofview.tclZERO ~info e
 
 (* The most general inversion tactic *)
-let inversion inv_kind status names id gls =
-  try (raw_inversion inv_kind id status names) gls
-  with e when Errors.noncritical e -> wrap_inv_error id e
+let inversion inv_kind status names id =
+  Proofview.tclORELSE
+    (raw_inversion inv_kind id status names)
+    (wrap_inv_error id)
 
 (* Specializing it... *)
 
-let inv_gen gene thin status names =
-  try_intros_until (inversion (gene,thin) status names)
+let inv_gen thin status names =
+  try_intros_until (inversion thin status names)
 
 open Tacexpr
 
-let inv k = inv_gen false k NoDep
+let inv k = inv_gen k NoDep
 
-let half_inv_tac id  = inv SimpleInversion None (NamedHyp id)
 let inv_tac id       = inv FullInversion None (NamedHyp id)
 let inv_clear_tac id = inv FullInversionClear None (NamedHyp id)
 
-let dinv k c = inv_gen false k (Dep c)
+let dinv k c = inv_gen k (Dep c)
 
-let half_dinv_tac id  = dinv SimpleInversion None None (NamedHyp id)
 let dinv_tac id       = dinv FullInversion None None (NamedHyp id)
 let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
 
@@ -522,25 +510,30 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
  * perform inversion on the named hypothesis.  After, it will intro them
  * back to their places in the hyp-list. *)
 
-let invIn k names ids id gls =
-  let hyps = List.map (pf_get_hyp gls) ids in
-  let nb_prod_init = nb_prod (pf_concl gls) in
-  let intros_replace_ids gls =
-    let nb_of_new_hyp =
-      nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init)
+let invIn k names ids id =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = List.map (fun id -> pf_get_hyp id gl) ids in
+    let concl = Proofview.Goal.concl gl in
+    let nb_prod_init = nb_prod concl in
+    let intros_replace_ids =
+      Proofview.Goal.enter begin fun gl ->
+        let concl = pf_nf_concl gl in
+        let nb_of_new_hyp =
+          nb_prod concl - (List.length hyps + nb_prod_init)
+        in
+        if nb_of_new_hyp < 1 then
+          intros_replacing ids
+        else
+          tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)
+      end
     in
-    if nb_of_new_hyp < 1 then
-      intros_replacing ids gls
-    else
-      tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls
-  in
-  try
-    (tclTHENSEQ
-      [bring_hyps hyps;
-       inversion (false,k) NoDep names id;
-       intros_replace_ids])
-    gls
-  with e when Errors.noncritical e -> wrap_inv_error id e
+    Proofview.tclORELSE
+      (tclTHENLIST
+         [bring_hyps hyps;
+          inversion k NoDep names id;
+          intros_replace_ids])
+      (wrap_inv_error id)
+  end
 
 let invIn_gen k names idl = try_intros_until (invIn k names idl)
 
diff --git a/tactics/inv.mli b/tactics/inv.mli
index ca87e0fc..b3478dda 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -1,41 +1,30 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
 open Term
-open Tacmach
-open Genarg
+open Misctypes
 open Tacexpr
-open Glob_term
 
 type inversion_status = Dep of constr option | NoDep
 
-val inv_gen :
-  bool -> inversion_kind -> inversion_status ->
-    intro_pattern_expr located option -> quantified_hypothesis -> tactic
-val invIn_gen :
-  inversion_kind -> intro_pattern_expr located option -> identifier list ->
-    quantified_hypothesis -> tactic
-
 val inv_clause :
-  inversion_kind -> intro_pattern_expr located option -> identifier list ->
-    quantified_hypothesis -> tactic
+  inversion_kind -> or_and_intro_pattern option -> Id.t list ->
+    quantified_hypothesis -> unit Proofview.tactic
 
-val inv : inversion_kind -> intro_pattern_expr located option ->
-  quantified_hypothesis -> tactic
+val inv : inversion_kind -> or_and_intro_pattern option ->
+  quantified_hypothesis -> unit Proofview.tactic
 
 val dinv : inversion_kind -> constr option ->
-  intro_pattern_expr located option -> quantified_hypothesis -> tactic
+  or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic
 
-val half_inv_tac : identifier -> tactic
-val inv_tac : identifier -> tactic
-val inv_clear_tac : identifier -> tactic
-val half_dinv_tac : identifier -> tactic
-val dinv_tac : identifier -> tactic
-val dinv_clear_tac : identifier -> tactic
+val inv_tac : Id.t -> unit Proofview.tactic
+val inv_clear_tac : Id.t -> unit Proofview.tactic
+val dinv_tac : Id.t -> unit Proofview.tactic
+val dinv_clear_tac : Id.t -> unit Proofview.tactic
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index bae81df7..f00ecf8f 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -1,42 +1,36 @@
 (************************************************************************)
 (*  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
-open Nameops
 open Term
+open Vars
 open Termops
 open Namegen
-open Sign
+open Context
 open Evd
 open Printer
 open Reductionops
-open Declarations
 open Entries
 open Inductiveops
 open Environ
-open Tacmach
-open Proof_type
-open Pfedit
-open Evar_refiner
+open Tacmach.New
 open Clenv
 open Declare
-open Tacticals
+open Tacticals.New
 open Tactics
-open Inv
-open Vernacexpr
-open Safe_typing
 open Decl_kinds
 
-let no_inductive_inconstr env constr =
+let no_inductive_inconstr env sigma constr =
   (str "Cannot recognize an inductive predicate in " ++
-     pr_lconstr_env env constr ++
+     pr_lconstr_env env sigma constr ++
      str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++
      spc () ++ str "or of the type of constructors" ++ spc () ++
      str "is hidden by constant definitions.")
@@ -146,7 +140,7 @@ let rec add_prods_sign env sigma t =
 let compute_first_inversion_scheme env sigma ind sort dep_option =
   let indf,realargs = dest_ind_type ind in
   let allvars = ids_of_context env in
-  let p = next_ident_away (id_of_string "P") allvars in
+  let p = next_ident_away (Id.of_string "P") allvars in
   let pty,goal =
     if dep_option  then
       let pty = make_arity env true indf sort in
@@ -161,7 +155,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option =
       let revargs,ownsign =
 	fold_named_context
 	  (fun env (id,_,_ as d) (revargs,hyps) ->
-             if List.mem id ivars then
+             if Id.List.mem id ivars then
 	       ((mkVar id)::revargs,add_named_decl d hyps)
 	     else
 	       (revargs,hyps))
@@ -187,21 +181,24 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   let ind =
     try find_rectype env sigma i
     with Not_found ->
-      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i)
+      errorlabstrm "inversion_scheme" (no_inductive_inconstr env sigma i)
   in
   let (invEnv,invGoal) =
     compute_first_inversion_scheme env sigma ind sort dep_option
   in
   assert
-    (list_subset
+    (List.subset
        (global_vars env invGoal)
        (ids_of_named_context (named_context invEnv)));
   (*
     errorlabstrm "lemma_inversion"
     (str"Computed inversion goal was not closed in initial signature.");
   *)
-  let pf = Proof.start [invEnv,invGoal] in
-  Proof.run_tactic env (Proofview.V82.tactic (tclTHEN intro (onLastHypId inv_op))) pf;
+  let pf = Proof.start (Evd.from_env ~ctx:(evar_universe_context sigma) invEnv) [invEnv,invGoal] in
+  let pf =
+    fst (Proof.run_tactic env (
+      tclTHEN intro (onLastHypId inv_op)) pf)
+  in
   let pfterm = List.hd (Proof.partial_proof pf) in
   let global_named_context = Global.named_context () in
   let ownSign = ref begin
@@ -216,7 +213,7 @@ let inversion_scheme env sigma t sort dep_option inv_op =
   let rec fill_holes c =
     match kind_of_term c with
     | Evar (e,args) ->
-	let h = next_ident_away (id_of_string "H") !avoid in
+	let h = next_ident_away (Id.of_string "H") !avoid in
 	let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in
 	avoid := h::!avoid;
 	ownSign := add_named_decl (h,None,ty) !ownSign;
@@ -231,37 +228,21 @@ let inversion_scheme env sigma t sort dep_option inv_op =
 
 let add_inversion_lemma name env sigma t sort dep inv_op =
   let invProof = inversion_scheme env sigma t sort dep inv_op in
-  let _ =
-    declare_constant name
-    (DefinitionEntry
-       { const_entry_body = invProof;
-         const_entry_secctx = None;
-         const_entry_type = None;
-         const_entry_opaque = false },
-     IsProof Lemma)
-  in ()
+  let entry = definition_entry ~poly:true (*FIXME*) invProof in
+  let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in
+  ()
 
 (* inv_op = Inv (derives de complete inv. lemma)
  * inv_op = InvNoThining (derives de semi inversion lemma) *)
 
-let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op =
-  let pts = get_pftreestate() in
-  let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in
-  let gl = { it = List.nth gls (n-1) ; sigma=sigma } in
-  let t =
-    try pf_get_hyp_typ gl id
-    with Not_found -> Pretype_errors.error_var_not_found_loc loc id in
-  let env = pf_env gl and sigma = project gl in
-  add_inversion_lemma na env sigma t sort dep_option inv_op
-
 let add_inversion_lemma_exn na com comsort bool tac =
-  let env = Global.env () and sigma = Evd.empty in
-  let c = Constrintern.interp_type sigma env com in
-  let sort = Pretyping.interp_sort comsort in
+  let env = Global.env () and evd = ref Evd.empty in
+  let c = Constrintern.interp_type_evars env evd com in
+  let sigma, sort = Pretyping.interp_sort !evd comsort in
   try
     add_inversion_lemma na env sigma c sort bool tac
   with
-    |   UserError ("Case analysis",s) -> (* référence à Indrec *)
+    |   UserError ("Case analysis",s) -> (* Reference to Indrec *)
 	  errorlabstrm "Inv needs Nodep Prop Set" s
 
 (* ================================= *)
@@ -272,7 +253,7 @@ let lemInv id c gls =
   try
     let clause = mk_clenv_type_of gls c in
     let clause = clenv_constrain_last_binding (mkVar id) clause in
-    Clenvtac.res_pf clause ~flags:Unification.elim_flags gls
+    Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls
   with
     | NoSuchBinding ->
 	errorlabstrm ""
@@ -280,21 +261,24 @@ let lemInv id c gls =
     | UserError (a,b) ->
 	 errorlabstrm "LemInv"
 	   (str "Cannot refine current goal with the lemma " ++
-	      pr_lconstr_env (Global.env()) c)
-
-let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
-
-let lemInvIn id c ids gls =
-  let hyps = List.map (pf_get_hyp gls) ids in
-  let intros_replace_ids gls =
-    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in
-    if nb_of_new_hyp < 1  then
-      intros_replacing ids gls
-    else
-      (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls
-  in
-  ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
-    (intros_replace_ids)) gls)
+	      pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c)
+
+let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id
+
+let lemInvIn id c ids =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = List.map (fun id -> pf_get_hyp id gl) ids in
+    let intros_replace_ids =
+      let concl = Proofview.Goal.concl gl in
+      let nb_of_new_hyp  = nb_prod concl - List.length ids in
+      if nb_of_new_hyp < 1  then
+        intros_replacing ids
+      else
+        (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids))
+    in
+    ((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c)))
+        (intros_replace_ids)))
+  end
 
 let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
 
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
index 233aeba3..47a4de44 100644
--- a/tactics/leminv.mli
+++ b/tactics/leminv.mli
@@ -1,19 +1,20 @@
-open Util
+(************************************************************************)
+(*  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 Loc
 open Names
 open Term
-open Glob_term
-open Proof_type
-open Topconstr
-
-val lemInv_gen : quantified_hypothesis -> constr -> tactic
-val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic
+open Constrexpr
+open Misctypes
 
 val lemInv_clause :
-  quantified_hypothesis -> constr -> identifier list -> tactic
+  quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic
 
-val inversion_lemma_from_goal :
-  int -> identifier -> identifier located -> sorts -> bool ->
-    (identifier -> tactic) -> unit
 val add_inversion_lemma_exn :
-  identifier -> constr_expr -> glob_sort -> bool -> (identifier -> tactic) ->
+  Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) ->
     unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
deleted file mode 100644
index 6d0f862f..00000000
--- a/tactics/nbtermdn.ml
+++ /dev/null
@@ -1,146 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Names
-open Term
-open Libobject
-open Library
-open Pattern
-open Libnames
-
-(* Named, bounded-depth, term-discrimination nets.
-   Implementation:
-   Term-patterns are stored in discrimination-nets, which are
-   themselves stored in a hash-table, indexed by the first label.
-   They are also stored by name in a table on-the-side, so that we can
-   override them if needed. *)
-
-(* The former comments are from Chet.
-   See the module dn.ml for further explanations.
-   Eduardo (5/8/97) *)
-module Make = 
-  functor (Y:Map.OrderedType) ->
-struct
-  module X = struct
-    type t = constr_pattern*int
-    let compare = Pervasives.compare
-  end
-
-  module Term_dn = Termdn.Make(Y)
-  open Term_dn
-  module Z = struct 
-     type t = Term_dn.term_label
-     let compare x y =  
-       let make_name n =
-	 match n with
-	 | GRLabel(ConstRef con) -> 
-	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | GRLabel(IndRef (kn,i)) ->
-	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | GRLabel(ConstructRef ((kn,i),j ))->
-	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
-  end
-
-  module Dn = Dn.Make(X)(Z)(Y)
-  module Bounded_net = Btermdn.Make(Y)
-
-    
-type 'na t = {
-  mutable table : ('na,constr_pattern * Y.t) Gmap.t;
-  mutable patterns : (Term_dn.term_label option,Bounded_net.t) Gmap.t }
-
-
-type 'na frozen_t = 
-    ('na,constr_pattern * Y.t) Gmap.t
-    * (Term_dn.term_label option, Bounded_net.t) Gmap.t
-
-let create () =
-  { table = Gmap.empty;
-    patterns = Gmap.empty }
-
-let get_dn dnm hkey =
-  try Gmap.find hkey dnm with Not_found -> Bounded_net.create ()
-
-let add dn (na,(pat,valu)) =
-  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
-  dn.table <- Gmap.add na (pat,valu) dn.table;
-  let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Bounded_net.add None (get_dn dnm hkey) (pat,valu)) dnm
-
-let rmv dn na =
-  let (pat,valu) = Gmap.find na dn.table in
-  let hkey = Option.map fst (Term_dn.constr_pat_discr pat) in 
-  dn.table <- Gmap.remove na dn.table;
-  let dnm = dn.patterns in
-  dn.patterns <- Gmap.add hkey (Bounded_net.rmv None (get_dn dnm hkey) (pat,valu)) dnm
-
-let in_dn dn na = Gmap.mem na dn.table
-
-let remap ndn na (pat,valu) =
-  rmv ndn na;
-  add ndn (na,(pat,valu))
-
-let decomp = 
-  let rec decrec acc c = match kind_of_term c with
-    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-    | Cast (c1,_,_) -> decrec acc c1
-    | _ -> (c,acc)
-  in 
-  decrec []
-
-  let constr_val_discr t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-    | Var id -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-    | Const _ -> Dn.Everything
-    | _ -> Dn.Nothing
-
-let constr_val_discr_st (idpred,cpred) t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Dn.Everything else Dn.Label(Term_dn.GRLabel (ConstRef c),l)
-    | Ind ind_sp -> Dn.Label(Term_dn.GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Dn.Label(Term_dn.GRLabel (ConstructRef cstr_sp),l)
-    | Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
-    | Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
-    | Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
-    | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
-    | Evar _ -> Dn.Everything
-    | _ -> Dn.Nothing
-
-let lookup dn valu =
-  let hkey =
-    match (constr_val_discr valu) with
-    | Dn.Label(l,_) -> Some l
-    | _ -> None
-  in
-  try Bounded_net.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> []
-
-let app f dn = Gmap.iter f dn.table
-
-let dnet_depth = Btermdn.dnet_depth
-
-let freeze dn = (dn.table, dn.patterns)
-
-let unfreeze (fnm,fdnm) dn =
-  dn.table <- fnm;
-  dn.patterns <- fdnm
-
-let empty dn =
-  dn.table <- Gmap.empty;
-  dn.patterns <- Gmap.empty
-
-let to2lists dn =
-  (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
-end
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
deleted file mode 100644
index b15bc922..00000000
--- a/tactics/nbtermdn.mli
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Pattern
-open Libnames
-
-(** Named, bounded-depth, term-discrimination nets. *)
-module Make :
-  functor (Y:Map.OrderedType) ->
-sig
-  
-  module Term_dn : sig     
-    type term_label = 
-      | GRLabel of global_reference
-      | ProdLabel 
-      | LambdaLabel
-      | SortLabel
-  end 
-    
-  type 'na t
-  type 'na frozen_t
-    
-  val create : unit -> 'na t
-    
-  val add : 'na t -> ('na * (constr_pattern * Y.t)) -> unit
-  val rmv : 'na t -> 'na -> unit
-  val in_dn : 'na t -> 'na -> bool
-  val remap : 'na t -> 'na -> (constr_pattern * Y.t) -> unit
-    
-  val lookup : 'na t -> constr -> (constr_pattern * Y.t) list
-  val app : ('na -> (constr_pattern * Y.t) -> unit) -> 'na t -> unit
-    
-  val dnet_depth : int ref
-    
-
-  val freeze : 'na t -> 'na frozen_t
-  val unfreeze : 'na frozen_t -> 'na t -> unit
-  val empty : 'na t -> unit
-  val to2lists : 'na t -> ('na * (constr_pattern * Y.t)) list * 
-    (Term_dn.term_label option * Btermdn.Make(Y).t) list
-end
diff --git a/tactics/refine.ml b/tactics/refine.ml
deleted file mode 100644
index f0a3b352..00000000
--- a/tactics/refine.ml
+++ /dev/null
@@ -1,397 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* JCF -- 6 janvier 1998  EXPERIMENTAL *)
-
-(*
- *  L'idée est, en quelque sorte, d'avoir de "vraies" métavariables
- *  dans Coq, c'est-à-dire de donner des preuves incomplètes -- mais
- *  où les trous sont typés -- et que les sous-buts correspondants
- *  soient engendrés pour finir la preuve.
- *
- *  Exemple :
- *    J'ai le but
- *        forall (x:nat), { y:nat | (minus y x) = x }
- *    et je donne la preuve incomplète
- *        fun (x:nat) => exist nat [y:nat]((minus y x)=x) (plus x x) ?
- *    ce qui engendre le but
- *        (minus (plus x x) x) = x
- *)
-
-(*  Pour cela, on procède de la manière suivante :
- *
- *  1. Un terme de preuve incomplet est un terme contenant des variables
- *     existentielles Evar i.e. "_" en syntaxe concrète.
- *     La résolution de ces variables n'est plus nécessairement totale
- *     (ise_resolve called with fail_evar=false) et les variables
- *     existentielles restantes sont remplacées par des méta-variables
- *     castées par leur types (celui est connu : soit donné, soit trouvé
- *     pendant la phase de résolution).
- *
- *  2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au
- *     permier niveau et pour chacune d'elles, si nécessaire, on donne
- *     à son tour un terme de preuve incomplet pour la résoudre.
- *     Exemple: le terme (f a _ (fun (x:nat) => e _)) donne
- *         (f a ?1 ?2) avec:
- *           - ?2 := fun (x:nat) => ?3
- *           - ?3 := e ?4
- *         ?1 et ?4 donneront des buts
- *
- *  3. On écrit ensuite une tactique tcc qui engendre les sous-buts
- *     à partir d'une preuve incomplète.
- *)
-
-open Pp
-open Util
-open Names
-open Term
-open Termops
-open Namegen
-open Tacmach
-open Sign
-open Environ
-open Reduction
-open Typing
-open Tactics
-open Tacticals
-open Printer
-
-type term_with_holes = TH of constr * meta_type_map * sg_proofs
-and  sg_proofs       = (term_with_holes option) list
-
-(* pour debugger *)
-
-let rec pp_th (TH(c,mm,sg)) =
-  (str"TH=[ " ++ hov 0 (pr_lconstr c ++ fnl () ++
-			      (* pp_mm mm ++ fnl () ++ *)
-			   pp_sg sg) ++ str "]")
-and pp_mm l =
-  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
-	   (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l)
-and pp_sg sg =
-  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
-	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
-
-(*  compute_metamap : constr -> 'a evar_map -> term_with_holes
- *  réalise le 2. ci-dessus
- *
- *  Pour cela, on renvoie une meta_map qui indique pour chaque meta-variable
- *  si elle correspond à un but (None) ou si elle réduite à son tour
- *  par un terme de preuve incomplet (Some c).
- *
- *  On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1"
- *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y
- *  a de meta-variables dans c. On suppose de plus que l'ordre dans la
- *  meta_map correspond à celui des buts qui seront engendrés par le refine.
- *)
-
-let replace_by_meta env sigma = function
-  | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp
-  | (TH (c,mm,_)) as th ->
-      let n = Evarutil.new_meta() in
-      let m = mkMeta n in
-      (* quand on introduit une mv on calcule son type *)
-      let ty = match kind_of_term c with
-	| Lambda (Name id,c1,c2) when isCast c2 ->
-	    let _,_,t = destCast c2 in mkNamedProd id c1 t
-	| Lambda (Anonymous,c1,c2) when isCast c2 ->
-	    let _,_,t = destCast c2 in mkArrow c1 t
-	| _ -> (* (App _ | Case _) -> *)
-	    let sigma' =
-	      List.fold_right (fun (m,t) sigma -> Evd.meta_declare m t sigma)
-		mm sigma in
-	    Retyping.get_type_of env sigma' c
-	(*
-	| Fix ((_,j),(v,_,_)) ->
-	    v.(j) (* en pleine confiance ! *)
-	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)"
-        *)
-      in
-      mkCast (m,DEFAULTcast, ty),[n,ty],[Some th]
-
-exception NoMeta
-
-let replace_in_array keep_length env sigma a =
-  if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then
-    raise NoMeta;
-  let a' = Array.map (function
-			| (TH (c,mm,[])) when not keep_length -> c,mm,[]
-			| th -> replace_by_meta env sigma th) a
-  in
-  let v' = Array.map pi1 a' in
-  let mm = Array.fold_left (@) [] (Array.map pi2 a') in
-  let sgp = Array.fold_left (@) [] (Array.map pi3 a') in
-  v',mm,sgp
-
-let fresh env n =
-  let id = match n with Name x -> x | _ -> id_of_string "_H" in
-  next_ident_away_in_goal id (ids_of_named_context (named_context env))
-
-let rec compute_metamap env sigma c = match kind_of_term c with
-  (* le terme est directement une preuve *)
-  | (Const _ | Evar _ | Ind _ | Construct _ |
-    Sort _ | Var _ | Rel _) ->
-      TH (c,[],[])
-
-  (* le terme est une mv => un but *)
-  | Meta n ->
-      TH (c,[],[None])
-
-  | Cast (m,_, ty) when isMeta m ->
-      TH (c,[destMeta m,ty],[None])
-
-
-  (* abstraction => il faut décomposer si le terme dessous n'est pas pur
-   *    attention : dans ce cas il faut remplacer (Rel 1) par (Var x)
-   *    où x est une variable FRAICHE *)
-  | Lambda (name,c1,c2) ->
-      let v = fresh env name in
-      let env' = push_named (v,None,c1) env in
-      begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with
-	(* terme de preuve complet *)
-	| TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)
-	| th ->
-	    let m,mm,sgp = replace_by_meta env' sigma th in
-	    TH (mkLambda (Name v,c1,m), mm, sgp)
-      end
-
-  | LetIn (name, c1, t1, c2) ->
-      let v = fresh env name in
-      let th1 = compute_metamap env sigma c1 in
-      let env' = push_named (v,Some c1,t1) env in
-      let th2 = compute_metamap env' sigma (subst1 (mkVar v) c2) in
-      begin match th1,th2 with
-	(* terme de preuve complet *)
-	| TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[])
-	(* terme de preuve incomplet *)
-	| TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) ->
-	    let m1,mm1,sgp1 =
-              if sgp1=[] then (c1,mm1,[])
-              else replace_by_meta env sigma th1 in
-	    let m2,mm2,sgp2 =
-              if sgp2=[] then (c2,mm2,[])
-              else replace_by_meta env' sigma th2 in
-	    TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2)
-      end
-
-  (* 4. Application *)
-  | App (f,v) ->
-      let a = Array.map (compute_metamap env sigma) (Array.append [|f|] v) in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array false env sigma a in
-          let v'' = Array.sub v' 1 (Array.length v) in
-          TH (mkApp(v'.(0), v''),mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  | Case (ci,p,cc,v) ->
-      (* bof... *)
-      let nbr = Array.length v in
-      let v = Array.append [|p;cc|] v in
-      let a = Array.map (compute_metamap env sigma) v in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array false env sigma a in
-	  let v'' = Array.sub v' 2 nbr in
-	  TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  (* 5. Fix. *)
-  | Fix ((ni,i),(fi,ai,v)) ->
-      (* TODO: use a fold *)
-      let vi = Array.map (fresh env) fi in
-      let fi' = Array.map (fun id -> Name id) vi in
-      let env' = push_named_rec_types (fi',ai,v) env in
-      let a = Array.map
-		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
-      in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array true env' sigma a in
-	  let fix = mkFix ((ni,i),(fi',ai,v')) in
-	  TH (fix,mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-  (* Cast. Est-ce bien exact ? *)
-  | Cast (c,_,t) -> compute_metamap env sigma c
-      (*let TH (c',mm,sgp) = compute_metamap sign c in
-	TH (mkCast (c',t),mm,sgp) *)
-
-  (* Produit. Est-ce bien exact ? *)
-  | Prod (_,_,_) ->
-      if occur_meta c then
-	error "refine: proof term contains metas in a product."
-      else
-      	TH (c,[],[])
-
-  (* Cofix. *)
-  | CoFix (i,(fi,ai,v)) ->
-      let vi = Array.map (fresh env) fi in
-      let fi' = Array.map (fun id -> Name id) vi in
-      let env' = push_named_rec_types (fi',ai,v) env in
-      let a = Array.map
-		(compute_metamap env' sigma)
-		(Array.map (substl (List.map mkVar (Array.to_list vi))) v)
-      in
-      begin
-	try
-	  let v',mm,sgp = replace_in_array true env' sigma a in
-	  let cofix = mkCoFix (i,(fi',ai,v')) in
-	  TH (cofix,mm,sgp)
-	with NoMeta ->
-	  TH (c,[],[])
-      end
-
-
-(*  tcc_aux : term_with_holes -> tactic
- *
- *  Réalise le 3. ci-dessus
- *)
-
-let ensure_products n =
-  let p = ref 0 in
-  let rec aux n gl =
-    if n = 0 then tclFAIL 0 (mt()) gl
-    else
-      tclTHEN
-        (tclORELSE intro (fun gl -> incr p; introf gl))
-        (aux (n-1)) gl in
-  tclORELSE
-    (aux n)
-    (* Now we know how many red are needed *)
-    (fun gl -> tclDO !p red_in_concl gl)
-
-let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl =
-  let c = substl subst c in
-  match (kind_of_term c,sgp) with
-    (* mv => sous-but : on ne fait rien *)
-    | Meta _ , _ ->
-	tclIDTAC gl
-
-    | Cast (c,_,_), _ when isMeta c ->
-	tclIDTAC gl
-
-    (* terme pur => refine *)
-    | _,[] ->
-	refine c gl
-
-    (* abstraction => intro *)
-    | Lambda (Name id,_,m), _ ->
-	assert (isMeta (strip_outer_cast m));
-	begin match sgp with
-	  | [None] -> intro_mustbe_force id gl
-	  | [Some th] ->
-              tclTHEN (introduction id)
-                (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) gl
-	  | _ -> assert false
-	end
-
-    | Lambda (Anonymous,_,m), _ -> (* if anon vars are allowed in evars *)
-        assert (isMeta (strip_outer_cast m));
-	begin match sgp with
-	  | [None] -> tclTHEN intro (onLastHypId (fun id -> clear [id])) gl
-	  | [Some th] ->
-              tclTHEN
-                intro
-                (onLastHypId (fun id ->
-                  tclTHEN
-                    (clear [id])
-                    (tcc_aux (mkVar (*dummy*) id::subst) th))) gl
-	  | _ -> assert false
-	end
-
-    (* let in without holes in the body => possibly dependent intro *)
-    | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) ->
-	let c = pf_concl gl in
-	let newc = mkNamedLetIn id c1 t1 c in
-	tclTHEN
-	  (change_in_concl None newc)
-	  (match sgp with
-	     | [None] -> introduction id
-	     | [Some th] ->
-                 tclTHEN (introduction id)
-                   (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th))
-	     | _ -> assert false)
-	  gl
-
-    (* let in with holes in the body => unable to handle dependency
-       because of evars limitation, use non dependent assert instead *)
-    | LetIn (Name id,c1,t1,c2), _ ->
-	tclTHENS
-          (assert_tac (Name id) t1)
-	  [(match List.hd sgp with
-	     | None -> tclIDTAC
-	     | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th));
-           (match List.tl sgp with
-	     | [] -> refine (subst1 (mkVar id) c2)  (* a complete proof *)
-	     | [None] -> tclIDTAC                   (* a meta *)
-	     | [Some th] ->                         (* a partial proof *)
-                 onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)
-             | _ -> assert false)]
-          gl
-
-    (* fix => tactique Fix *)
-    | Fix ((ni,j),(fi,ai,_)) , _ ->
-	let out_name = function
-	  | Name id -> id
-          | _ -> error "Recursive functions must have names."
-	in
-	let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in
-	let firsts,lasts = list_chop j (Array.to_list fixes) in
-	tclTHENS
-	  (tclTHEN
-            (ensure_products (succ ni.(j)))
-            (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j))
-	  (List.map (function
-		       | None -> tclIDTAC
-		       | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-    (* cofix => tactique CoFix *)
-    | CoFix (j,(fi,ai,_)) , _ ->
-	let out_name = function
-	  | Name id -> id
-          | _ -> error "Recursive functions must have names."
-	in
-	let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in
-	let firsts,lasts = list_chop j (Array.to_list cofixes) in
-	tclTHENS
-	  (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j)
-	  (List.map (function
-		       | None -> tclIDTAC
-		       | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-    (* sinon on fait refine du terme puis appels rec. sur les sous-buts.
-     * c'est le cas pour App et MutCase. *)
-    | _ ->
-	tclTHENS
-	  (refine c)
-	  (List.map
-            (function None -> tclIDTAC | Some th -> tcc_aux subst th) sgp)
-	  gl
-
-(* Et finalement la tactique refine elle-même : *)
-
-let refine (evd,c) gl =
-  let sigma = project gl in
-  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in
-  let c = Evarutil.nf_evar evd c in
-  let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in
-  (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise
-     complicated to update meta types when passing through a binder *)
-  let th = compute_metamap (pf_env gl) evd c in
-  tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl
diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml
new file mode 100644
index 00000000..a3914da1
--- /dev/null
+++ b/tactics/rewrite.ml
@@ -0,0 +1,2099 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Names
+open Pp
+open Errors
+open Util
+open Nameops
+open Namegen
+open Term
+open Vars
+open Reduction
+open Tacticals
+open Tacmach
+open Tactics
+open Pretype_errors
+open Typeclasses
+open Classes
+open Constrexpr
+open Globnames
+open Evd
+open Misctypes
+open Locus
+open Locusops
+open Decl_kinds
+open Elimschemes
+open Environ
+open Termops
+open Libnames
+
+(** Typeclass-based generalized rewriting. *)
+
+(** Constants used by the tactic. *)
+
+let classes_dirpath =
+  Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"])
+
+let init_setoid () =
+  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
+  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
+
+let make_dir l = DirPath.make (List.rev_map Id.of_string l)
+
+let try_find_global_reference dir s =
+  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in
+    try Nametab.global_of_path sp
+    with Not_found -> 
+      anomaly (str ("Global reference " ^ s ^ " not found in generalized rewriting"))
+
+let find_reference dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun () -> Lazy.force gr
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+let find_global dir s =
+  let gr = lazy (try_find_global_reference dir s) in
+    fun (evd,cstrs) -> 
+      let evd, c = Evarutil.new_global evd (Lazy.force gr) in
+	(evd, cstrs), c
+
+(** Utility for dealing with polymorphic applications *)
+
+(** Global constants. *)
+
+let coq_eq_ref = find_reference ["Init"; "Logic"] "eq"
+let coq_eq = find_global ["Init"; "Logic"] "eq"
+let coq_f_equal = find_global ["Init"; "Logic"] "f_equal"
+let coq_all = find_global ["Init"; "Logic"] "all"
+let impl = find_global ["Program"; "Basics"] "impl"
+
+(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *)
+
+(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *)
+
+(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *)
+(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *)
+(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *)
+(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *)
+(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *)
+(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *)
+(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *)
+(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *)
+(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *)
+
+(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *)
+(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *)
+
+
+
+(** Bookkeeping which evars are constraints so that we can 
+    remove them at the end of the tactic. *)
+
+let goalevars evars = fst evars
+let cstrevars evars = snd evars
+
+let new_cstr_evar (evd,cstrs) env t =
+  let s = Typeclasses.set_resolvable Evd.Store.empty false in
+  let evd', t = Evarutil.new_evar ~store:s env evd t in
+  let ev, _ = destEvar t in
+    (evd', Evar.Set.add ev cstrs), t
+
+(** Building or looking up instances. *)
+let e_new_cstr_evar env evars t =
+  let evd', t = new_cstr_evar !evars env t in evars := evd'; t
+
+(** Building or looking up instances. *)
+
+let extends_undefined evars evars' =
+  let f ev evi found = found || not (Evd.mem evars ev)
+  in fold_undefined f evars' false
+
+let app_poly_check env evars f args =
+  let (evars, cstrs), fc = f evars in
+  let evdref = ref evars in 
+  let t = Typing.solve_evars env evdref (mkApp (fc, args)) in
+    (!evdref, cstrs), t
+
+let app_poly_nocheck env evars f args =
+  let evars, fc = f evars in 
+    evars, mkApp (fc, args)
+
+let app_poly_sort b =
+  if b then app_poly_nocheck
+  else app_poly_check
+    
+let find_class_proof proof_type proof_method env evars carrier relation =
+  try
+    let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in
+    let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in
+      if extends_undefined (goalevars evars) evars' then raise Not_found
+      else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |]
+  with e when Logic.catchable_exception e -> raise Not_found
+ 
+(** Utility functions *)
+
+module GlobalBindings (M : sig
+  val relation_classes : string list
+  val morphisms : string list
+  val relation : string list * string
+  val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr
+  val arrow : evars -> evars * constr
+end) = struct
+  open M
+  let relation : evars -> evars * constr = find_global (fst relation) (snd relation)
+
+  let reflexive_type = find_global relation_classes "Reflexive"
+  let reflexive_proof = find_global relation_classes "reflexivity"
+    
+  let symmetric_type = find_global relation_classes "Symmetric"
+  let symmetric_proof = find_global relation_classes "symmetry"
+
+  let transitive_type = find_global relation_classes "Transitive"
+  let transitive_proof = find_global relation_classes "transitivity"
+
+  let forall_relation = find_global morphisms "forall_relation"
+  let pointwise_relation = find_global morphisms "pointwise_relation"
+
+  let forall_relation_ref = find_reference morphisms "forall_relation"
+  let pointwise_relation_ref = find_reference morphisms "pointwise_relation"
+
+  let respectful = find_global morphisms "respectful"
+  let respectful_ref = find_reference morphisms "respectful"
+
+  let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation"
+
+  let coq_forall = find_global morphisms "forall_def"
+
+  let subrelation = find_global relation_classes "subrelation"
+  let do_subrelation = find_global morphisms "do_subrelation"
+  let apply_subrelation = find_global morphisms "apply_subrelation"
+
+  let rewrite_relation_class = find_global relation_classes "RewriteRelation"
+
+  let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper"))
+  let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy"))
+    
+  let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
+    
+  let proper_type = 
+    let l = lazy (Lazy.force proper_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+	
+  let proper_proxy_type = 
+    let l = lazy (Lazy.force proper_proxy_class).cl_impl in
+      fun (evd,cstrs) -> 
+	let evd, c = Evarutil.new_global evd (Lazy.force l) in
+	  (evd, cstrs), c
+
+  let proper_proof env evars carrier relation x =
+    let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in
+      new_cstr_evar evars env goal
+
+  let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
+  let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
+  let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
+
+  let mk_relation env evd a = 
+    app_poly env evd relation [| a |]
+
+  (** Build an infered signature from constraints on the arguments and expected output
+      relation *)
+    
+  let build_signature evars env m (cstrs : (types * types option) option list)
+      (finalcstr : (types * types option) option) =
+    let mk_relty evars newenv ty obj =
+      match obj with
+      | None | Some (_, None) ->
+	let evars, relty = mk_relation env evars ty in
+	  if closed0 ty then 
+	    let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
+	      new_cstr_evar evars env' relty
+	  else new_cstr_evar evars newenv relty
+      | Some (x, Some rel) -> evars, rel
+    in
+    let rec aux env evars ty l =
+      let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in
+	match kind_of_term t, l with
+	| Prod (na, ty, b), obj :: cstrs ->
+	  if noccurn 1 b (* non-dependent product *) then
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
+	    let evars, relty = mk_relty evars env ty obj in
+	    let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in
+	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
+	  else
+	    let (evars, b, arg, cstrs) = 
+	      aux (Environ.push_rel (na, None, ty) env) evars b cstrs 
+	    in
+	    let ty = Reductionops.nf_betaiota (goalevars evars) ty in
+	    let pred = mkLambda (na, ty, b) in
+	    let liftarg = mkLambda (na, ty, arg) in
+	    let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in
+	      if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
+	      else error "build_signature: no constraint can apply on a dependent argument"
+	| _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products")
+	| _, [] ->
+	  (match finalcstr with
+	  | None | Some (_, None) ->
+	    let t = Reductionops.nf_betaiota (fst evars) ty in
+	    let evars, rel = mk_relty evars env t None in
+	      evars, t, rel, [t, Some rel]
+	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
+    in aux env evars m cstrs
+
+  (** Folding/unfolding of the tactic constants. *)
+
+  let unfold_impl t =
+    match kind_of_term t with
+    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
+      mkProd (Anonymous, a, lift 1 b)
+    | _ -> assert false
+
+  let unfold_all t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let unfold_forall t =
+    match kind_of_term t with
+    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
+      (match kind_of_term b with
+      | Lambda (n, ty, b) -> mkProd (n, ty, b)
+      | _ -> assert false)
+    | _ -> assert false
+
+  let arrow_morphism env evd ta tb a b =
+    let ap = is_Prop ta and bp = is_Prop tb in
+      if ap && bp then app_poly env evd impl [| a; b |], unfold_impl
+      else if ap then (* Domain in Prop, CoDomain in Type *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+	(* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *)
+      else if bp then (* Dummy forall *)
+	(app_poly env evd coq_all [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
+      else (* None in Prop, use arrow *)
+	(app_poly env evd arrow [| a; b |]), unfold_impl
+
+  let rec decomp_pointwise n c =
+    if Int.equal n 0 then c
+    else
+      match kind_of_term c with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	decomp_pointwise (pred n) relb
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
+      | _ -> invalid_arg "decomp_pointwise"
+
+  let rec apply_pointwise rel = function
+    | arg :: args ->
+      (match kind_of_term rel with
+      | App (f, [| a; b; relb |]) when Globnames.is_global (pointwise_relation_ref ()) f ->
+	apply_pointwise relb args
+      | App (f, [| a; b; arelb |]) when Globnames.is_global (forall_relation_ref ()) f ->
+	apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
+      | _ -> invalid_arg "apply_pointwise")
+    | [] -> rel
+
+  let pointwise_or_dep_relation env evd n t car rel =
+    if noccurn 1 car && noccurn 1 rel then
+      app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |]
+    else
+      app_poly env evd forall_relation
+	[| t; mkLambda (n, t, car); mkLambda (n, t, rel) |]
+
+  let lift_cstr env evars (args : constr list) c ty cstr =
+    let start evars env car =
+      match cstr with
+      | None | Some (_, None) -> 
+	let evars, rel = mk_relation env evars car in
+	  new_cstr_evar evars env rel
+      | Some (ty, Some rel) -> evars, rel
+    in
+    let rec aux evars env prod n = 
+      if Int.equal n 0 then start evars env prod
+      else
+	match kind_of_term (Reduction.whd_betadeltaiota env prod) with
+	| Prod (na, ty, b) ->
+	  if noccurn 1 b then
+	    let b' = lift (-1) b in
+	    let evars, rb = aux evars env b' (pred n) in
+	      app_poly env evars pointwise_relation [| ty; b'; rb |]
+	  else
+	    let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in
+	      app_poly env evars forall_relation
+		[| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |]
+	| _ -> raise Not_found
+    in 
+    let rec find env c ty = function
+      | [] -> None
+      | arg :: args ->
+	try let evars, found = aux evars env ty (succ (List.length args)) in
+	      Some (evars, found, c, ty, arg :: args)
+	with Not_found ->
+	  let ty = whd_betadeltaiota env ty in
+	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
+    in find env c ty args
+
+  let unlift_cstr env sigma = function
+    | None -> None
+    | Some codom -> Some (decomp_pointwise 1 codom)
+
+  (** Looking up declared rewrite relations (instances of [RewriteRelation]) *)
+  let is_applied_rewrite_relation env sigma rels t =
+    match kind_of_term t with
+    | App (c, args) when Array.length args >= 2 ->
+      let head = if isApp c then fst (destApp c) else c in
+	if Globnames.is_global (coq_eq_ref ()) head then None
+	else
+	  (try
+	   let params, args = Array.chop (Array.length args - 2) args in
+	   let env' = Environ.push_rel_context rels env in
+	   let evars, (evar, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in
+	   let evars, inst = 
+	     app_poly env (evars,Evar.Set.empty)
+	       rewrite_relation_class [| evar; mkApp (c, params) |] in
+	   let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in
+	     Some (it_mkProd_or_LetIn t rels)
+	   with e when Errors.noncritical e -> None)
+  | _ -> None
+
+
+end
+
+(* let my_type_of env evars c = Typing.e_type_of env evars c *)
+(* let mytypeofkey = Profile.declare_profile "my_type_of";; *)
+(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *)
+
+
+let type_app_poly env env evd f args =
+  let evars, c = app_poly_nocheck env evd f args in
+  let evd', t = Typing.e_type_of env (goalevars evars) c in
+    (evd', cstrevars evars), c
+
+module PropGlobal = struct
+  module Consts =
+  struct 
+    let relation_classes = ["Classes"; "RelationClasses"]
+    let morphisms = ["Classes"; "Morphisms"]
+    let relation = ["Relations";"Relation_Definitions"], "relation"
+    let app_poly = app_poly_nocheck
+    let arrow = find_global ["Program"; "Basics"] "arrow"
+    let coq_inverse = find_global ["Program"; "Basics"] "flip"
+  end
+
+  module G = GlobalBindings(Consts)
+
+  include G
+  include Consts
+  let inverse env evd car rel = 
+    type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |]
+      (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *)
+
+end
+
+module TypeGlobal = struct
+  module Consts = 
+    struct 
+      let relation_classes = ["Classes"; "CRelationClasses"]
+      let morphisms = ["Classes"; "CMorphisms"]
+      let relation = relation_classes, "crelation"
+      let app_poly = app_poly_check
+      let arrow = find_global ["Classes"; "CRelationClasses"] "arrow"
+      let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip"
+    end
+
+  module G = GlobalBindings(Consts)
+  include G
+  include Consts
+
+
+  let inverse env (evd,cstrs) car rel = 
+    let evd, (sort,_) = Evarutil.new_type_evar env evd Evd.univ_flexible in
+      app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |]
+
+end
+
+let sort_of_rel env evm rel =
+  Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)
+
+let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation
+
+(* let _ = *)
+(*   Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *)
+
+let split_head = function
+    hd :: tl -> hd, tl
+  | [] -> assert(false)
+
+let evd_convertible env evd x y =
+  try
+    let evd = Evarconv.the_conv_x env x y evd in
+    (* Unfortunately, the_conv_x might say they are unifiable even if some
+        unsolvable constraints remain, so we check them here *)
+    let evd = Evarconv.consider_remaining_unif_problems env evd in
+    let () = Evarconv.check_problems_are_solved env evd in
+    Some evd
+  with e when Errors.noncritical e -> None
+
+let convertible env evd x y =
+  Reductionops.is_conv_leq env evd x y
+
+type hypinfo = {
+  env : env;
+  prf : constr;
+  car : constr;
+  rel : constr;
+  sort : bool; (* true = Prop; false = Type *)
+  c1 : constr;
+  c2 : constr;
+  holes : Clenv.hole list;
+}
+
+let get_symmetric_proof b = 
+  if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof
+
+let rec decompose_app_rel env evd t = 
+  (** Head normalize for compatibility with the old meta mechanism *)
+  let t = Reductionops.whd_betaiota evd t in
+  match kind_of_term t with
+  | App (f, [||]) -> assert false
+  | App (f, [|arg|]) ->
+    let (f', argl, argr) = decompose_app_rel env evd arg in
+    let ty = Typing.type_of env evd argl in
+    let f'' = mkLambda (Name default_dependent_ident, ty,
+      mkLambda (Name (Id.of_string "y"), lift 1 ty,
+        mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
+    in (f'', argl, argr)
+  | App (f, args) ->
+    let len = Array.length args in
+    let fargs = Array.sub args 0 (Array.length args - 2) in
+    mkApp (f, fargs), args.(len - 2), args.(len - 1)
+  | _ -> error "Cannot find a relation to rewrite."
+
+let decompose_applied_relation env sigma (c,l) =
+  let ctype = Retyping.get_type_of env sigma c in
+  let find_rel ty =
+    let sigma, cl = Clenv.make_evar_clause env sigma ty in
+    let sigma = Clenv.solve_evar_clause env sigma true cl l in
+    let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in
+    let (equiv, c1, c2) = decompose_app_rel env sigma t in
+    let ty1 = Retyping.get_type_of env sigma c1 in
+    let ty2 = Retyping.get_type_of env sigma c2 in
+    match evd_convertible env sigma ty1 ty2 with
+    | None -> None
+    | Some sigma ->
+      let sort = sort_of_rel env sigma equiv in
+      let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in
+      let value = mkApp (c, args) in
+        Some (sigma, { env=env; prf=value;
+                car=ty1; rel = equiv; sort = Sorts.is_prop sort;
+                c1=c1; c2=c2; holes })
+  in
+    match find_rel ctype with
+    | Some c -> c
+    | None ->
+	let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *)
+	match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with
+	| Some c -> c
+	| None -> error "Cannot find an homogeneous relation to rewrite."
+
+let decompose_applied_relation_expr env sigma (is, (c,l)) =
+  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in
+  decompose_applied_relation env sigma cbl
+
+let rewrite_db = "rewrite"
+
+let conv_transparent_state = (Id.Pred.empty, Cpred.full)
+
+let _ = 
+  Hints.add_hints_init
+    (fun () ->
+       Hints.create_hint_db false rewrite_db conv_transparent_state true)
+
+let rewrite_transparent_state () =
+  Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db)
+
+let rewrite_core_unif_flags = {
+  Unification.modulo_conv_on_closed_terms = None;
+  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
+  Unification.use_evars_eagerly_in_conv_on_closed_terms = true;
+  Unification.modulo_delta = empty_transparent_state;
+  Unification.modulo_delta_types = full_transparent_state;
+  Unification.check_applied_meta_types = true;
+  Unification.use_pattern_unification = true;
+  Unification.use_meta_bound_pattern_unification = true;
+  Unification.frozen_evars = Evar.Set.empty;
+  Unification.restrict_conv_on_strict_subterms = false;
+  Unification.modulo_betaiota = false;
+  Unification.modulo_eta = true;
+}
+
+(* Flags used for the setoid variant of "rewrite" and for the strategies
+   "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing
+   evars in "rewrite" (see unify_abs) *)
+let rewrite_unif_flags =
+  let flags = rewrite_core_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+let rewrite_core_conv_unif_flags = {
+  rewrite_core_unif_flags with
+    Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
+    Unification.modulo_delta_types = conv_transparent_state;
+    Unification.modulo_betaiota = true
+}
+
+(* Fallback flags for the setoid variant of "rewrite" *)
+let rewrite_conv_unif_flags =
+  let flags = rewrite_core_conv_unif_flags in {
+  Unification.core_unify_flags = flags;
+  Unification.merge_unify_flags = flags;
+  Unification.subterm_unify_flags = flags;
+  Unification.allow_K_in_toplevel_higher_order_unification = true;
+  Unification.resolve_evars = true
+  }
+
+(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *)
+let general_rewrite_unif_flags () =
+  let ts = rewrite_transparent_state () in
+  let core_flags =
+    { rewrite_core_unif_flags with
+      Unification.modulo_conv_on_closed_terms = Some ts;
+      Unification.use_evars_eagerly_in_conv_on_closed_terms = false;
+      Unification.modulo_delta = ts;
+      Unification.modulo_delta_types = ts;
+      Unification.modulo_betaiota = true }
+  in {
+    Unification.core_unify_flags = core_flags;
+    Unification.merge_unify_flags = core_flags;
+    Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state };
+    Unification.allow_K_in_toplevel_higher_order_unification = true;
+    Unification.resolve_evars = true
+  }
+
+let refresh_hypinfo env sigma hypinfo c =
+  let sigma, hypinfo = match hypinfo with
+  | None ->
+    decompose_applied_relation_expr env sigma c
+  | Some hypinfo ->
+    if hypinfo.env != env then
+      (* If the lemma actually generates existential variables, we cannot 
+          use it here as it will polute the evar map with existential variables
+          that might not ever get instantiated (e.g. if we rewrite under a
+          binder and need to refresh [c] again) *)
+      (* TODO: remove bindings in sigma corresponding to c *)
+      decompose_applied_relation_expr env sigma c
+    else sigma, hypinfo
+  in
+  let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+  sigma, (car, rel, prf, c1, c2, holes, sort)
+
+
+(** FIXME: write this in the new monad interface *)
+let solve_remaining_by env sigma holes by =
+  match by with
+  | None -> sigma
+  | Some tac ->
+    let map h =
+      if h.Clenv.hole_deps then None
+      else
+        let (evk, _) = destEvar (h.Clenv.hole_evar) in
+        Some evk
+    in
+    (** Only solve independent holes *)
+    let indep = List.map_filter map holes in
+    let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in
+    let solve sigma evk =
+      let evi =
+        try Some (Evd.find_undefined sigma evk)
+        with Not_found -> None
+      in
+      match evi with
+      | None -> sigma
+        (** Evar should not be defined, but just in case *)
+      | Some evi ->
+        let ctx = Evd.evar_universe_context sigma in
+        let env = Environ.reset_with_named_context evi.evar_hyps env in
+        let ty = evi.evar_concl in
+        let c, _, ctx = Pfedit.build_by_tactic env ctx ty solve_tac in
+        let sigma = Evd.set_universe_context sigma ctx in
+        Evd.define evk c sigma
+    in
+    List.fold_left solve sigma indep
+
+let no_constraints cstrs = 
+  fun ev _ -> not (Evar.Set.mem ev cstrs)
+
+let all_constraints cstrs = 
+  fun ev _ -> Evar.Set.mem ev cstrs
+
+let poly_inverse sort =
+  if sort then PropGlobal.inverse else TypeGlobal.inverse
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  | RewCast of cast_kind
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : rewrite_proof;
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types ->
+  (bool (* prop *) * constr option) -> evars -> 
+    'a * rewrite_result
+
+type strategy = unit pure_strategy
+
+let symmetry env sort rew =
+  let { rew_evars = evars; rew_car = car; } = rew in
+  let (rew_evars, rew_prf) = match rew.rew_prf with
+  | RewCast _ -> (rew.rew_evars, rew.rew_prf)
+  | RewPrf (rel, prf) ->
+    try
+      let evars, symprf = get_symmetric_proof sort env evars car rel in
+      let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in
+      (evars, RewPrf (rel, prf))
+    with Not_found ->
+      let evars, rel = poly_inverse sort env evars car rel in
+      (evars, RewPrf (rel, prf))
+  in
+  { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; }
+
+(* Matching/unifying the rewriting rule against [t] *)
+let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t =
+  try
+    let left = if l2r then c1 else c2 in
+    let sigma = Unification.w_unify ~flags env sigma CONV left t in
+    let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs)
+      ~fail:true env sigma in
+    let evd = solve_remaining_by env sigma holes by in
+    let nf c = Evarutil.nf_evar evd (Reductionops.nf_meta evd c) in
+    let c1 = nf c1 and c2 = nf c2
+    and rew_car = nf car and rel = nf rel
+    and prf = nf prf in
+    let ty1 = Retyping.get_type_of env evd c1 in
+    let ty2 = Retyping.get_type_of env evd c2 in
+    let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in
+    let rew_evars = evd, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some rew
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t =
+  try
+    let left = if l2r then c1 else c2 in
+    (* The pattern is already instantiated, so the next w_unify is
+       basically an eq_constr, except when preexisting evars occur in
+       either the lemma or the goal, in which case the eq_constr also
+       solved this evars *)
+    let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in
+    let rew_evars = sigma, cstrs in
+    let rew_prf = RewPrf (rel, prf) in
+    let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in
+    let rew = if l2r then rew else symmetry env sort rew in
+    Some ((), rew)
+  with 
+  | e when Class_tactics.catchable e -> None
+  | Reduction.NotConvertible -> None
+
+type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
+
+let default_flags = { under_lambdas = true; on_morphisms = true; }
+
+let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+
+let make_eq () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ())
+let make_eq_refl () =
+(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq_refl ())
+
+let get_rew_prf r = match r.rew_prf with
+  | RewPrf (rel, prf) -> rel, prf 
+  | RewCast c ->
+    let rel = mkApp (make_eq (), [| r.rew_car |]) in
+      rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]),
+		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
+
+let poly_subrelation sort = 
+  if sort then PropGlobal.subrelation else TypeGlobal.subrelation
+
+let resolve_subrelation env avoid car rel sort prf rel' res =
+  if eq_constr rel rel' then res
+  else
+    let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in
+    let evars, subrel = new_cstr_evar evars env app in
+    let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
+      { res with
+	rew_prf = RewPrf (rel', appsub);
+	rew_evars = evars }
+
+let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars =
+  let evars, morph_instance, proj, sigargs, m', args, args' =
+    let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with
+    | Some i -> i
+    | None -> invalid_arg "resolve_morphism" in
+    let morphargs, morphobjs = Array.chop first args in
+    let morphargs', morphobjs' = Array.chop first args' in
+    let appm = mkApp(m, morphargs) in
+    let appmtype = Typing.type_of env (goalevars evars) appm in
+    let cstrs = List.map 
+      (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) 
+      (Array.to_list morphobjs') 
+    in
+      (* Desired signature *)
+    let evars, appmtype', signature, sigargs = 
+      if b then PropGlobal.build_signature evars env appmtype cstrs cstr
+      else TypeGlobal.build_signature evars env appmtype cstrs cstr
+    in
+      (* Actual signature found *)
+    let cl_args = [| appmtype' ; signature ; appm |] in
+    let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type)
+      cl_args in
+    let env' = 
+      let dosub, appsub = 
+	if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation 
+	else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation
+      in
+	Environ.push_named
+	  (Id.of_string "do_subrelation", 
+	   Some (snd (app_poly_sort b env evars dosub [||])), 
+	   snd (app_poly_nocheck env evars appsub [||]))
+	  env
+    in
+    let evars, morph = new_cstr_evar evars env' app in
+      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
+  in
+  let projargs, subst, evars, respars, typeargs =
+    Array.fold_left2
+      (fun (acc, subst, evars, sigargs, typeargs') x y ->
+	let (carrier, relation), sigargs = split_head sigargs in
+	  match relation with
+	  | Some relation ->
+	      let carrier = substl subst carrier
+	      and relation = substl subst relation in
+	      (match y with
+	      | None ->
+		  let evars, proof = 
+		    (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) 
+		      env evars carrier relation x in
+		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
+	      | Some r ->
+		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, 
+	      sigargs, r.rew_to :: typeargs')
+	  | None ->
+	      if not (Option.is_empty y) then 
+		error "Cannot rewrite inside dependent arguments of a function";
+	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
+      ([], [], evars, sigargs, []) args args'
+  in
+  let proof = applistc proj (List.rev projargs) in
+  let newt = applistc m' (List.rev typeargs) in
+    match respars with
+	[ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt
+      | _ -> assert(false)
+
+let apply_constraint env avoid car rel prf cstr res =
+  match snd cstr with
+  | None -> res
+  | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res
+
+let coerce env avoid cstr res = 
+  let rel, prf = get_rew_prf res in
+    apply_constraint env avoid res.rew_car rel prf cstr res
+
+let apply_rule unify loccs : ('a * int) pure_strategy =
+  let (nowhere_except_in,occs) = convert_occs loccs in
+  let is_occ occ =
+    if nowhere_except_in 
+    then List.mem occ occs 
+    else not (List.mem occ occs) 
+  in
+    fun (hypinfo, occ) env avoid t ty cstr evars ->
+      let unif = if isEvar t then None else unify hypinfo env evars t in
+	match unif with
+	| None -> ((hypinfo, occ), Fail)
+        | Some (hypinfo', rew) ->
+	  let occ = succ occ in
+	    if not (is_occ occ) then ((hypinfo, occ), Fail)
+	    else if eq_constr t rew.rew_to then ((hypinfo, occ), Identity)
+	    else
+	      let res = { rew with rew_car = ty } in
+              let rel, prf = get_rew_prf res in
+	      let res = Success (apply_constraint env avoid rew.rew_car rel prf cstr res) in
+		((hypinfo', occ), res)
+		  
+let apply_lemma l2r flags oc by loccs : strategy =
+  fun () env avoid t ty cstr (sigma, cstrs) ->
+    let sigma, c = oc sigma in
+    let sigma, hypinfo = decompose_applied_relation env sigma c in
+    let { c1; c2; car; rel; prf; sort; holes } = hypinfo in
+    let rew = (car, rel, prf, c1, c2, holes, sort) in
+    let evars = (sigma, cstrs) in
+    let unify () env evars t =
+      let rew = unify_eqn rew l2r flags env evars by t in
+      match rew with
+      | None -> None
+      | Some rew -> Some ((), rew)
+    in
+    let _, res = apply_rule unify loccs ((), 0) env avoid t ty cstr evars in
+    (), res
+
+let e_app_poly env evars f args =
+  let evars', c = app_poly_nocheck env !evars f args in
+    evars := evars';
+    c
+
+let make_leibniz_proof env c ty r =
+  let evars = ref r.rew_evars in
+  let prf = 
+    match r.rew_prf with
+    | RewPrf (rel, prf) -> 
+	let rel = e_app_poly env evars coq_eq [| ty |] in
+	let prf =
+	  e_app_poly env evars coq_f_equal
+		[| r.rew_car; ty;
+		   mkLambda (Anonymous, r.rew_car, c);
+		   r.rew_from; r.rew_to; prf |]
+	in RewPrf (rel, prf)
+    | RewCast k -> r.rew_prf
+  in
+    { rew_car = ty; rew_evars = !evars;
+      rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
+
+let reset_env env =
+  let env' = Global.env_of_context (Environ.named_context_val env) in
+    Environ.push_rel_context (Environ.rel_context env) env'
+      
+let fold_match ?(force=false) env sigma c =
+  let (ci, p, c, brs) = destCase c in
+  let cty = Retyping.get_type_of env sigma c in
+  let dep, pred, exists, (sk,eff) = 
+    let env', ctx, body =
+      let ctx, pred = decompose_lam_assum p in
+      let env' = Environ.push_rel_context ctx env in
+	env', ctx, pred
+    in
+    let sortp = Retyping.get_sort_family_of env' sigma body in
+    let sortc = Retyping.get_sort_family_of env sigma cty in
+    let dep = not (noccurn 1 body) in
+    let pred = if dep then p else
+	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
+    in
+    let sk = 
+      if sortp == InProp then
+	if sortc == InProp then
+	  if dep then case_dep_scheme_kind_from_prop
+	  else case_scheme_kind_from_prop
+	else (
+	  if dep
+	  then case_dep_scheme_kind_from_type_in_prop
+	  else case_scheme_kind_from_type)
+      else ((* sortc <> InProp by typing *)
+	if dep
+	then case_dep_scheme_kind_from_type
+	else case_scheme_kind_from_type)
+    in 
+    let exists = Ind_tables.check_scheme sk ci.ci_ind in
+      if exists || force then
+	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
+      else raise Not_found
+  in
+  let app =
+    let ind, args = Inductive.find_rectype env cty in
+    let pars, args = List.chop ci.ci_npar args in
+    let meths = List.map (fun br -> br) (Array.to_list brs) in
+      applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
+  in 
+    sk, (if exists then env else reset_env env), app, eff
+
+let unfold_match env sigma sk app =
+  match kind_of_term app with
+  | App (f', args) when eq_constant (fst (destConst f')) sk ->
+      let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in
+	Reductionops.whd_beta sigma (mkApp (v, args))
+  | _ -> app
+
+let is_rew_cast = function RewCast _ -> true | _ -> false
+
+let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy =
+  let rec aux state env avoid t ty (prop, cstr) evars =
+    let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
+      match kind_of_term t with
+      | App (m, args) ->
+	  let rewrite_args state success =
+	    let state, (args', evars', progress) =
+	      Array.fold_left
+		(fun (state, (acc, evars, progress)) arg ->
+		  if not (Option.is_empty progress) && not all then 
+		    state, (None :: acc, evars, progress)
+		  else
+		    let argty = Retyping.get_type_of env (goalevars evars) arg in
+		    let state, res = s state env avoid arg argty (prop,None) evars in
+		    let res' = 
+		      match res with
+		      | Identity ->
+			let progress = if Option.is_empty progress then Some false else progress in
+			  (None :: acc, evars, progress)
+		      | Success r -> 
+			(Some r :: acc, r.rew_evars, Some true)
+		      | Fail -> (None :: acc, evars, progress)
+		    in state, res')
+		(state, ([], evars, success)) args
+	    in
+	    let res = 
+	      match progress with
+	      | None -> Fail
+	      | Some false -> Identity
+	      | Some true ->
+		let args' = Array.of_list (List.rev args') in
+		  if Array.exists
+		    (function 
+		      | None -> false 
+		      | Some r -> not (is_rew_cast r.rew_prf)) args'
+		  then
+		    let evars', prf, car, rel, c1, c2 = 
+		      resolve_morphism env avoid t m args args' (prop, cstr') evars' 
+		    in
+		    let res = { rew_car = ty; rew_from = c1;
+				rew_to = c2; rew_prf = RewPrf (rel, prf);
+				rew_evars = evars' } 
+		    in Success res
+		  else 
+		    let args' = Array.map2
+		      (fun aorig anew ->
+			match anew with None -> aorig
+			| Some r -> r.rew_to) args args' 
+		    in
+		    let res = { rew_car = ty; rew_from = t;
+				rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast;
+				rew_evars = evars' }
+		    in Success res
+	    in state, res
+	  in
+	    if flags.on_morphisms then
+	      let mty = Retyping.get_type_of env (goalevars evars) m in
+	      let evars, cstr', m, mty, argsl, args = 
+		let argsl = Array.to_list args in
+		let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in
+		  match lift env evars argsl m mty None with
+		  | Some (evars, cstr', m, mty, args) -> 
+		    evars, Some cstr', m, mty, args, Array.of_list args
+		  | None -> evars, None, m, mty, argsl, args
+	      in
+	      let state, m' = s state env avoid m mty (prop, cstr') evars in
+		match m' with
+		| Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *)
+		| Identity -> rewrite_args state (Some false)
+		| Success r ->
+		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
+		       We just apply it. *)
+		    let prf = match r.rew_prf with
+		      | RewPrf (rel, prf) ->
+			let app = if prop then PropGlobal.apply_pointwise 
+			  else TypeGlobal.apply_pointwise 
+			in
+			  RewPrf (app rel argsl, mkApp (prf, args))
+		      | x -> x
+		    in
+		    let res =
+		      { rew_car = prod_appvect r.rew_car args;
+			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
+			rew_prf = prf; rew_evars = r.rew_evars }
+		    in 
+		    let res = 
+		      match prf with
+		      | RewPrf (rel, prf) ->
+			Success (apply_constraint env avoid res.rew_car
+				      rel prf (prop,cstr) res)
+		      | _ -> Success res
+		    in state, res
+	    else rewrite_args state None
+	      
+      | Prod (n, x, b) when noccurn 1 b ->
+	  let b = subst1 mkProp b in
+	  let tx = Retyping.get_type_of env (goalevars evars) x 
+	  and tb = Retyping.get_type_of env (goalevars evars) b in
+	  let arr = if prop then PropGlobal.arrow_morphism 
+	    else TypeGlobal.arrow_morphism 
+	  in
+	  let (evars', mor), unfold = arr env evars tx tb x b in
+	  let state, res = aux state env avoid mor ty (prop,cstr) evars' in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+      (* 		if x' = None && flags.under_lambdas then *)
+      (* 		  let lam = mkLambda (n, x, b) in *)
+      (* 		  let lam', occ = aux env lam occ None in *)
+      (* 		  let res =  *)
+      (* 		    match lam' with *)
+      (* 		    | None -> None *)
+      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
+      (* 			Some (resolve_morphism env sigma t *)
+      (* 				 ~fnewt:unfold_all *)
+      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
+      (* 				 cstr evars) *)
+      (* 		  in res, occ *)
+      (* 		else *)
+
+      | Prod (n, dom, codom) ->
+	  let lam = mkLambda (n, dom, codom) in
+	  let (evars', app), unfold = 
+	    if eq_constr ty mkProp then
+	      (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all
+	    else 
+	      let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in
+		(app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall
+	  in
+	  let state, res = aux state env avoid app ty (prop,cstr) evars' in
+	  let res = 
+	    match res with
+	    | Success r -> Success { r with rew_to = unfold r.rew_to }
+	    | Fail | Identity -> res
+	  in state, res
+
+(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with 
+   H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this.
+   B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing
+   dependent relations and using projections to get them out.
+ *)
+      (* | Lambda (n, t, b) when flags.under_lambdas -> *)
+      (* 	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *)
+      (* 	  let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *)
+      (* 	  let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *)
+      (* 	  let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *)
+      (* 	  let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *)
+      (* 	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *)
+      (* 	    (match b' with *)
+      (* 	    | Some (Some r) -> *)
+      (* 		let prf = match r.rew_prf with *)
+      (* 		  | RewPrf (rel, prf) -> *)
+      (* 		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in *)
+      (* 		      let prf = mkLambda (n', t, prf) in *)
+      (* 			RewPrf (rel, prf) *)
+      (* 		  | x -> x *)
+      (* 		in *)
+      (* 		  Some (Some { r with *)
+      (* 		    rew_prf = prf; *)
+      (* 		    rew_car = mkProd (n, t, r.rew_car); *)
+      (* 		    rew_from = mkLambda(n, t, r.rew_from); *)
+      (* 		    rew_to = mkLambda (n, t, r.rew_to) }) *)
+      (* 	    | _ -> b') *)
+
+      | Lambda (n, t, b) when flags.under_lambdas ->
+	let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
+	let env' = Environ.push_rel (n', None, t) env in
+	let bty = Retyping.get_type_of env' (goalevars evars) b in
+	let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in
+	let state, b' = s state env' avoid b bty (prop, unlift env evars cstr) evars in
+	let res = 
+	  match b' with
+	  | Success r ->
+	    let r = match r.rew_prf with
+	      | RewPrf (rel, prf) ->
+		let point = if prop then PropGlobal.pointwise_or_dep_relation else
+		    TypeGlobal.pointwise_or_dep_relation
+		in
+		let evars, rel = point env r.rew_evars n' t r.rew_car rel in
+		let prf = mkLambda (n', t, prf) in
+		  { r with rew_prf = RewPrf (rel, prf); rew_evars = evars }
+	      | x -> r
+	    in
+	      Success { r with
+		rew_car = mkProd (n, t, r.rew_car);
+		rew_from = mkLambda(n, t, r.rew_from);
+		rew_to = mkLambda (n, t, r.rew_to) }
+	  | Fail | Identity -> b'
+	in state, res
+	    
+      | Case (ci, p, c, brs) ->
+	let cty = Retyping.get_type_of env (goalevars evars) c in
+	let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in
+	let cstr' = Some eqty in
+	let state, c' = s state env avoid c cty (prop, cstr') evars' in
+	let state, res = 
+	  match c' with
+	  | Success r ->
+	    let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in
+	    let res = make_leibniz_proof env case ty r in
+	      state, Success (coerce env avoid (prop,cstr) res)
+	  | Fail | Identity ->
+	    if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then
+	      let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in
+	      let cstr = Some eqty in
+	      let state, found, brs' = Array.fold_left 
+		(fun (state, found, acc) br ->
+		  if not (Option.is_empty found) then 
+		    (state, found, fun x -> lift 1 br :: acc x)
+		  else
+		    let state, res = s state env avoid br ty (prop,cstr) evars in
+		      match res with
+		      | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x)
+		      | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x))
+		(state, None, fun x -> []) brs
+	      in
+		match found with
+		| Some r ->
+		  let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in
+		    state, Success (make_leibniz_proof env ctxc ty r)
+		| None -> state, c'
+	    else
+	      match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
+	      | None -> state, c'
+	      | Some (cst, _, t', eff (*FIXME*)) ->
+		let state, res = aux state env avoid t' ty (prop,cstr) evars in
+		let res = 
+		  match res with
+		  | Success prf -> 
+		    Success { prf with
+		      rew_from = t; 
+		      rew_to = unfold_match env (goalevars evars) cst prf.rew_to }
+		  | x' -> c'
+		in state, res
+	in 
+	let res = 
+	  match res with
+	  | Success r ->  
+	    let rel, prf = get_rew_prf r in
+	      Success (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r)
+	  | Fail | Identity -> res
+	in state, res
+      | _ -> state, Fail
+  in aux
+
+let all_subterms = subterm true default_flags
+let one_subterm = subterm false default_flags
+
+(** Requires transitivity of the rewrite step, if not a reduction.
+    Not tail-recursive. *)
+
+let transitivity state env avoid prop (res : rewrite_result_info) (next : 'a pure_strategy) : 
+    'a * rewrite_result =
+  let state, nextres =
+    next state env avoid res.rew_to res.rew_car
+      (prop, get_opt_rew_rel res.rew_prf) res.rew_evars 
+  in 
+  let res = 
+    match nextres with
+    | Fail -> Fail
+    | Identity -> Success res
+    | Success res' ->
+      match res.rew_prf with
+      | RewCast c -> Success { res' with rew_from = res.rew_from }
+      | RewPrf (rew_rel, rew_prf) ->
+	match res'.rew_prf with
+	| RewCast _ -> Success { res with rew_to = res'.rew_to }
+	| RewPrf (res'_rel, res'_prf) ->
+	  let trans = 
+	    if prop then PropGlobal.transitive_type 
+	    else TypeGlobal.transitive_type
+	  in
+	  let evars, prfty = 
+	    app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] 
+	  in
+	  let evars, prf = new_cstr_evar evars env prfty in
+	  let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+				  rew_prf; res'_prf |])
+	  in Success { res' with rew_from = res.rew_from; 
+	    rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) }
+  in state, res
+
+(** Rewriting strategies.
+
+    Inspired by ELAN's rewriting strategies:
+    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
+*)
+
+module Strategies =
+  struct
+
+    let fail : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	state, Fail
+
+    let id : 'a pure_strategy =
+      fun state env avoid t ty cstr evars -> 
+	state, Identity
+
+    let refl : 'a pure_strategy =
+      fun state env avoid t ty (prop,cstr) evars ->
+	let evars, rel = match cstr with
+	  | None -> 
+	    let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in
+	    let evars, rty = mkr env evars ty in
+	      new_cstr_evar evars env rty
+	  | Some r -> evars, r
+	in
+	let evars, proof =
+	  let proxy = 
+	    if prop then PropGlobal.proper_proxy_type 
+	    else TypeGlobal.proper_proxy_type
+	  in
+	  let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in
+	    new_cstr_evar evars env mty
+	in
+	let res = Success { rew_car = ty; rew_from = t; rew_to = t;
+			       rew_prf = RewPrf (rel, proof); rew_evars = evars }
+	in state, res
+
+    let progress (s : 'a pure_strategy) : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = s state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> state, Fail
+	  | Success r -> state, Success r
+	    
+    let seq first snd : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = first state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> state, Fail
+	  | Identity -> snd state env avoid t ty cstr evars
+	  | Success res -> transitivity state env avoid (fst cstr) res snd
+	    
+    let choice fst snd : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+	let state, res = fst state env avoid t ty cstr evars in
+	  match res with
+	  | Fail -> snd state env avoid t ty cstr evars
+	  | Identity | Success _ -> state, res
+
+    let try_ str : 'a pure_strategy = choice str id
+
+    let check_interrupt str s e l c t r ev =
+      Control.check_for_interrupt ();
+      str s e l c t r ev
+    
+    let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy =
+      let rec aux state = f (fun state -> check_interrupt aux state) state in aux
+    
+    let any (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun any -> try_ (seq s any))
+
+    let repeat (s : 'a pure_strategy) : 'a pure_strategy =
+      seq s (any s)
+
+    let bu (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
+
+    let td (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
+
+    let innermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun ins -> choice (one_subterm ins) s)
+
+    let outermost (s : 'a pure_strategy) : 'a pure_strategy =
+      fix (fun out -> choice s (one_subterm out))
+
+    let lemmas cs : 'a pure_strategy =
+      List.fold_left (fun tac (l,l2r,by) ->
+	choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences))
+	fail cs
+
+    let inj_open hint = (); fun sigma ->
+      let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in
+      let sigma = Evd.merge_universe_context sigma ctx in
+      (sigma, (hint.Autorewrite.rew_lemma, NoBindings))
+
+    let old_hints (db : string) : 'a pure_strategy =
+      let rules = Autorewrite.find_rewrites db in
+	lemmas
+	  (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r,
+				  hint.Autorewrite.rew_tac)) rules)
+
+    let hints (db : string) : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+      let rules = Autorewrite.find_matches db t in
+      let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r,
+			hint.Autorewrite.rew_tac) in
+      let lems = List.map lemma rules in
+	lemmas lems state env avoid t ty cstr evars
+
+    let reduce (r : Redexpr.red_expr) : 'a pure_strategy =
+	fun state env avoid t ty cstr evars ->
+          let rfn, ckind = Redexpr.reduction_of_red_expr env r in
+	  let evars', t' = rfn env (goalevars evars) t in
+	    if eq_constr t' t then
+	      state, Identity
+	    else
+	      state, Success { rew_car = ty; rew_from = t; rew_to = t';
+			       rew_prf = RewCast ckind; 
+			       rew_evars = evars', cstrevars evars }
+	
+    let fold_glob c : 'a pure_strategy =
+      fun state env avoid t ty cstr evars ->
+(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
+	let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in
+	let unfolded =
+	  try Tacred.try_red_product env sigma c
+	  with e when Errors.noncritical e ->
+            error "fold: the term is not unfoldable !"
+	in
+	  try
+	    let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in
+	    let c' = Evarutil.nf_evar sigma c in
+	      state, Success { rew_car = ty; rew_from = t; rew_to = c';
+				  rew_prf = RewCast DEFAULTcast;
+				  rew_evars = (sigma, snd evars) }
+	  with e when Errors.noncritical e -> state, Fail
+  
+
+end
+
+(** The strategy for a single rewrite, dealing with occurences. *)
+
+(** A dummy initial clauseenv to avoid generating initial evars before
+    even finding a first application of the rewriting lemma, in setoid_rewrite
+    mode *)
+
+let rewrite_with l2r flags c occs : strategy =
+  fun () env avoid t ty cstr (sigma, cstrs) ->
+    let hypinfo = None in
+    let unify hypinfo env evars t =
+      let (sigma, cstrs) = evars in
+      let ans =
+        try Some (refresh_hypinfo env sigma hypinfo c)
+        with e when Class_tactics.catchable e -> None
+      in
+      match ans with
+      | None -> None
+      | Some (sigma, rew) ->
+        let rew = unify_eqn rew l2r flags env (sigma, cstrs) None t in
+        match rew with
+        | None -> None
+        | Some rew -> Some (None, rew) (** reset the hypinfo cache *)
+    in
+    let app = apply_rule unify occs in
+    let strat = 
+      Strategies.fix (fun aux -> 
+	Strategies.choice app (subterm true default_flags aux))
+    in
+    let _, res = strat (hypinfo, 0) env avoid t ty cstr (sigma, cstrs) in
+      ((), res)
+
+let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars =
+  let ty = Retyping.get_type_of env (goalevars evars) concl in
+  let _, res = s () env avoid concl ty (prop, Some cstr) evars in
+  res
+
+let solve_constraints env (evars,cstrs) =
+  let filter = all_constraints cstrs in
+    Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true 
+      (Typeclasses.mark_resolvables ~filter evars)
+      
+let nf_zeta =
+  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+
+exception RewriteFailure of Pp.std_ppcmds
+
+type result = (evar_map * constr option * types) option option
+
+let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
+  let evdref = ref sigma in
+  let sort = Typing.sort_of env evdref concl in
+  let evars = (!evdref, Evar.Set.empty) in
+  let evars, cstr =
+    let prop, (evars, arrow) = 
+      if is_prop_sort sort then true, app_poly_sort true env evars impl [||]
+      else false, app_poly_sort false env evars TypeGlobal.arrow [||]
+    in
+      match is_hyp with
+      | None -> 
+	let evars, t = poly_inverse prop env evars (mkSort sort) arrow in 
+	  evars, (prop, t)
+      | Some _ -> evars, (prop, arrow)
+  in
+  let eq = apply_strategy strat env avoid concl cstr evars in
+    match eq with
+    | Fail -> None
+    | Identity -> Some None
+    | Success res ->
+      let (_, cstrs) = res.rew_evars in
+      let evars' = solve_constraints env res.rew_evars in
+      let newt = Evarutil.nf_evar evars' res.rew_to in
+      let evars = (* Keep only original evars (potentially instantiated) and goal evars,
+		     the rest has been defined and substituted already. *)
+	Evar.Set.fold (fun ev acc -> Evd.remove acc ev) cstrs evars'
+      in
+      let res = match res.rew_prf with
+	| RewCast c -> None
+	| RewPrf (rel, p) ->
+	  let p = nf_zeta env evars' (Evarutil.nf_evar evars' p) in
+	  let term =
+	    match abs with
+	    | None -> p
+	    | Some (t, ty) ->
+              let t = Evarutil.nf_evar evars' t in
+              let ty = Evarutil.nf_evar evars' ty in
+		mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |])
+	  in
+	  let proof = match is_hyp with
+            | None -> term
+            | Some id -> mkApp (term, [| mkVar id |])
+          in Some proof
+      in Some (Some (evars, res, newt))
+
+let assert_replacing id newt tac = 
+  let prf = Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let nc' =
+      Environ.fold_named_context
+        (fun _ (n, b, t as decl) nc' ->
+          if Id.equal n id then (n, b, newt) :: nc'
+          else decl :: nc')
+        env ~init:[]
+    in
+    Proofview.Refine.refine ~unsafe:false begin fun sigma ->
+      let env' = Environ.reset_with_named_context (val_of_named_context nc') env in
+      let sigma, ev = Evarutil.new_evar env' sigma concl in
+      let sigma, ev' = Evarutil.new_evar env sigma newt in
+      let fold _ (n, b, t) inst =
+        if Id.equal n id then ev' :: inst
+        else mkVar n :: inst
+      in
+      let inst = fold_named_context fold env ~init:[] in
+      let (e, args) = destEvar ev in
+      sigma, mkEvar (e, Array.of_list inst)
+    end
+  end in
+  Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac)
+
+let newfail n s = 
+  Proofview.tclZERO (Refiner.FailError (n, lazy s))
+
+let cl_rewrite_clause_newtac ?abs ?origsigma strat clause =
+  let open Proofview.Notations in
+  let treat sigma (res, is_hyp) = 
+    match res with
+    | None -> newfail 0 (str "Nothing to rewrite")
+    | Some None -> Proofview.tclUNIT ()
+    | Some (Some res) ->
+        let (undef, prf, newt) = res in
+        let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in
+        let gls = List.rev (Evd.fold_undefined fold undef []) in
+	match is_hyp, prf with
+	| Some id, Some p ->
+            let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in
+            Proofview.Unsafe.tclEVARS undef <*>
+	    assert_replacing id newt tac
+	| Some id, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_hyp_no_check (id, None, newt)
+	| None, Some p ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            Proofview.Goal.enter begin fun gl ->
+            let env = Proofview.Goal.env gl in
+            let make sigma =
+              let (sigma, ev) = Evarutil.new_evar env sigma newt in
+              sigma, mkApp (p, [| ev |])
+            in
+            Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls
+            end
+	| None, None ->
+            Proofview.Unsafe.tclEVARS undef <*>
+            convert_concl_no_check newt DEFAULTcast
+  in
+  let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in
+  let beta = Proofview.V82.tactic (Tactics.reduct_in_concl (beta_red, DEFAULTcast)) in
+  let opt_beta = match clause with
+  | None -> Proofview.tclUNIT ()
+  | Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp))
+  in
+  Proofview.Goal.nf_enter begin fun gl ->
+    let concl = Proofview.Goal.concl gl in
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ty, is_hyp =
+      match clause with
+      | Some id -> Environ.named_type id env, Some id
+      | None -> concl, None
+    in
+    try
+      let res =
+        cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp
+      in
+      let sigma = match origsigma with None -> sigma | Some sigma -> sigma in
+      treat sigma (res, is_hyp) <*>
+      (** For compatibility *)
+      beta <*> opt_beta <*> Proofview.shelve_unifiable
+    with
+    | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) ->
+      raise (RewriteFailure (Himsg.explain_pretype_error env evd e))
+  end
+
+let tactic_init_setoid () = 
+  try init_setoid (); tclIDTAC
+  with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded")
+
+(** Setoid rewriting when called with "rewrite_strat" *)
+let cl_rewrite_clause_strat strat clause =
+  tclTHEN (tactic_init_setoid ())
+  (fun gl -> 
+     try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl
+     with RewriteFailure e ->
+       errorlabstrm "" (str"setoid rewrite failed: " ++ e)
+     | Refiner.FailError (n, pp) -> 
+       tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)
+
+(** Setoid rewriting when called with "setoid_rewrite" *)
+let cl_rewrite_clause l left2right occs clause gl =
+  let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in
+    cl_rewrite_clause_strat strat clause gl
+
+let apply_glob_constr c l2r occs = (); fun () env avoid t ty cstr evars ->
+  let c sigma =
+    let (sigma, c) = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  let flags = general_rewrite_unif_flags () in
+  apply_lemma l2r flags c None occs () env avoid t ty cstr evars
+
+let interp_glob_constr_list env =
+  let make c = (); fun sigma ->
+    let sigma, c = Pretyping.understand_tcc env sigma c in
+    (sigma, (c, NoBindings))
+  in
+  List.map (fun c -> make c, true, None)
+
+(* Syntax for rewriting with strategies *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
+  | StratId | StratFail | StratRefl as s -> s
+  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
+  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
+  | StratConstr (c, b) -> StratConstr (f c, b)
+  | StratTerms l -> StratTerms (List.map f l)
+  | StratHints (b, id) -> StratHints (b, id)
+  | StratEval r -> StratEval (g r)
+  | StratFold c -> StratFold (f c)
+
+let rec strategy_of_ast = function
+  | StratId -> Strategies.id
+  | StratFail -> Strategies.fail
+  | StratRefl -> Strategies.refl
+  | StratUnary (f, s) -> 
+    let s' = strategy_of_ast s in
+    let f' = match f with
+      | Subterms -> all_subterms
+      | Subterm -> one_subterm
+      | Innermost -> Strategies.innermost
+      | Outermost -> Strategies.outermost
+      | Bottomup -> Strategies.bu
+      | Topdown -> Strategies.td
+      | Progress -> Strategies.progress
+      | Try -> Strategies.try_
+      | Any -> Strategies.any
+      | Repeat -> Strategies.repeat
+    in f' s'
+  | StratBinary (f, s, t) ->
+    let s' = strategy_of_ast s in
+    let t' = strategy_of_ast t in
+    let f' = match f with
+      | Compose -> Strategies.seq
+      | Choice -> Strategies.choice
+    in f' s' t'
+  | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences
+  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
+  | StratTerms l -> 
+    (fun () env avoid t ty cstr evars ->
+     let l' = interp_glob_constr_list env (List.map fst l) in
+       Strategies.lemmas l' () env avoid t ty cstr evars)
+  | StratEval r -> 
+    (fun () env avoid t ty cstr evars ->
+     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
+       Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars))
+  | StratFold c -> Strategies.fold_glob (fst c)
+
+
+(* By default the strategy for "rewrite_db" is top-down *)
+
+let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l)
+
+let declare_an_instance n s args =
+  ((Loc.ghost,Name n), Explicit,
+  CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None),
+	   args))
+
+let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
+
+let anew_instance global binders instance fields =
+  new_instance (Flags.is_universe_polymorphism ()) 
+    binders instance (Some (true, CRecord (Loc.ghost,None,fields)))
+    ~global ~generalize:false None
+
+let declare_instance_refl global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)]
+
+let declare_instance_sym global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)]
+
+let declare_instance_trans global binders a aeq n lemma =
+  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
+  in anew_instance global binders instance
+       [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)]
+
+let declare_relation ?(binders=[]) a aeq n refl symm trans =
+  init_setoid ();
+  let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in
+  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
+  in ignore(anew_instance global binders instance []);
+  match (refl,symm,trans) with
+      (None, None, None) -> ()
+    | (Some lemma1, None, None) ->
+	ignore (declare_instance_refl global binders a aeq n lemma1)
+    | (None, Some lemma2, None) ->
+	ignore (declare_instance_sym global binders a aeq n lemma2)
+    | (None, None, Some lemma3) ->
+	ignore (declare_instance_trans global binders a aeq n lemma3)
+    | (Some lemma1, Some lemma2, None) ->
+	ignore (declare_instance_refl global binders a aeq n lemma1);
+	ignore (declare_instance_sym global binders a aeq n lemma2)
+    | (Some lemma1, None, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
+	in ignore(
+	    anew_instance global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1);
+	       (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)])
+    | (None, Some lemma2, Some lemma3) ->
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
+	in ignore(
+	    anew_instance global binders instance
+	      [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2);
+	       (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)])
+     | (Some lemma1, Some lemma2, Some lemma3) ->
+	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
+	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
+	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
+	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+	in ignore(
+	  anew_instance global binders instance
+	    [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2);
+	     (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)])
+
+let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None)
+
+let proper_projection r ty =
+  let ctx, inst = decompose_prod_assum ty in
+  let mor, args = destApp inst in
+  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
+  let app = mkApp (Lazy.force PropGlobal.proper_proj,
+		  Array.append args [| instarg |]) in
+    it_mkLambda_or_LetIn app ctx
+
+let declare_projection n instance_id r =
+  let c,uctx = Universes.fresh_global_instance (Global.env()) r in
+  let poly = Global.is_polymorphic r in
+  let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in
+  let term = proper_projection c ty in
+  let typ = Typing.type_of (Global.env ()) Evd.empty term in
+  let ctx, typ = decompose_prod_assum typ in
+  let typ =
+    let n =
+      let rec aux t =
+	match kind_of_term t with
+	| App (f, [| a ; a' ; rel; rel' |]) 
+	    when Globnames.is_global (PropGlobal.respectful_ref ()) f ->
+	  succ (aux rel')
+	| _ -> 0
+      in
+      let init =
+	match kind_of_term typ with
+	    App (f, args) when Globnames.is_global (PropGlobal.respectful_ref ()) f  ->
+	      mkApp (f, fst (Array.chop (Array.length args - 2) args))
+	  | _ -> typ
+      in aux init
+    in
+    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
+    in it_mkProd_or_LetIn ccl ctx
+  in
+  let typ = it_mkProd_or_LetIn typ ctx in
+  let cst = 
+    Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) 
+      term 
+  in
+    ignore(Declare.declare_constant n 
+	   (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
+
+let build_morphism_signature m =
+  let env = Global.env () in
+  let m,ctx = Constrintern.interp_constr env Evd.empty m in
+  let sigma = Evd.from_env ~ctx env in
+  let t = Typing.type_of env sigma m in
+  let cstrs =
+    let rec aux t =
+      match kind_of_term t with
+	| Prod (na, a, b) ->
+	    None :: aux b
+	| _ -> []
+    in aux t
+  in
+  let evars, t', sig_, cstrs = 
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in
+  let evd = ref evars in
+  let _ = List.iter
+    (fun (ty, rel) ->
+      Option.iter (fun rel ->
+	let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in
+	  ignore(e_new_cstr_evar env evd default))
+	rel)
+    cstrs
+  in
+  let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in
+  let evd = solve_constraints env !evd in
+  let m = Evarutil.nf_evar evd morph in
+    Evarutil.check_evars env Evd.empty evd m; m
+
+let default_morphism sign m =
+  let env = Global.env () in
+  let t = Typing.type_of env Evd.empty m in
+  let evars, _, sign, cstrs =
+    PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign)
+  in
+  let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in
+  let evars, mor = resolve_one_typeclass env (goalevars evars) morph in
+    mor, proper_projection mor morph
+
+let add_setoid global binders a aeq t n =
+  init_setoid ();
+  let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
+  let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
+  let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
+  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
+  in ignore(
+    anew_instance global binders instance
+      [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
+       (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
+
+
+let make_tactic name =
+  let open Tacexpr in
+  let loc = Loc.ghost in
+  let tacpath = Libnames.qualid_of_string name in
+  let tacname = Qualid (loc, tacpath) in
+  TacArg (loc, TacCall (loc, tacname, []))
+
+let add_morphism_infer glob m n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let instance = build_morphism_signature m in
+  let evd = Evd.empty (*FIXME *) in
+    if Lib.is_modtype () then
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
+				(Entries.ParameterEntry 
+				 (None,poly,(instance,Univ.UContext.empty),None), 
+				 Decl_kinds.IsAssumption Decl_kinds.Logical)
+      in
+	add_instance (Typeclasses.new_instance 
+			(Lazy.force PropGlobal.proper_class) None glob 
+			poly (ConstRef cst));
+	declare_projection n instance_id (ConstRef cst)
+    else
+      let kind = Decl_kinds.Global, poly, 
+	Decl_kinds.DefinitionBody Decl_kinds.Instance 
+      in
+      let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in
+      let hook _ = function
+	| Globnames.ConstRef cst ->
+	  add_instance (Typeclasses.new_instance 
+			  (Lazy.force PropGlobal.proper_class) None
+			  glob poly (ConstRef cst));
+	  declare_projection n instance_id (ConstRef cst)
+	| _ -> assert false
+      in
+      let hook = Lemmas.mk_hook hook in
+	Flags.silently
+	  (fun () ->
+	    Lemmas.start_proof instance_id kind evd instance hook;
+	    ignore (Pfedit.by (Tacinterp.interp tac))) ()
+
+let add_morphism glob binders m s n =
+  init_setoid ();
+  let poly = Flags.is_universe_polymorphism () in
+  let instance_id = add_suffix n "_Proper" in
+  let instance =
+    ((Loc.ghost,Name instance_id), Explicit,
+    CAppExpl (Loc.ghost,
+	     (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None),
+	     [cHole; s; m]))
+  in
+  let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in
+    ignore(new_instance ~global:glob poly binders instance 
+	     (Some (true, CRecord (Loc.ghost,None,[])))
+	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
+
+(** Bind to "rewrite" too *)
+
+(** Taken from original setoid_replace, to emulate the old rewrite semantics where
+    lemmas are first instantiated and then rewrite proceeds. *)
+
+let check_evar_map_of_evars_defs evd =
+ let metas = Evd.meta_list evd in
+ let check_freemetas_is_empty rebus =
+  Evd.Metaset.iter
+   (fun m ->
+     if Evd.meta_defined evd m then () else
+      raise
+	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
+ in
+  List.iter
+   (fun (_,binding) ->
+     match binding with
+        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
+         check_freemetas_is_empty rebus freemetas
+      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
+                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
+         check_freemetas_is_empty rebus1 freemetas1 ;
+         check_freemetas_is_empty rebus2 freemetas2
+   ) metas
+
+(* Find a subterm which matches the pattern to rewrite for "rewrite" *)
+let unification_rewrite l2r c1 c2 sigma prf car rel but env =
+  let (sigma,c') =
+    try
+      (* ~flags:(false,true) to allow to mark occurrences that must not be
+         rewritten simply by replacing them with let-defined definitions
+         in the context *)
+      Unification.w_unify_to_subterm 
+       ~flags:rewrite_unif_flags
+        env sigma ((if l2r then c1 else c2),but)
+    with
+    | ex when Pretype_errors.precatchable_exception ex ->
+	(* ~flags:(true,true) to make Ring work (since it really
+           exploits conversion) *)
+      Unification.w_unify_to_subterm 
+        ~flags:rewrite_conv_unif_flags
+        env sigma ((if l2r then c1 else c2),but)
+  in
+  let nf c = Evarutil.nf_evar sigma c in
+  let c1 = if l2r then nf c' else nf c1
+  and c2 = if l2r then nf c2 else nf c'
+  and car = nf car and rel = nf rel in
+  check_evar_map_of_evars_defs sigma;
+  let prf = nf prf in
+  let prfty = nf (Retyping.get_type_of env sigma prf) in
+  let sort = sort_of_rel env sigma but in
+  let abs = prf, prfty in
+  let prf = mkRel 1 in
+  let res = (car, rel, prf, c1, c2) in
+  abs, sigma, res, Sorts.is_prop sort
+
+let get_hyp gl (c,l) clause l2r =
+  let evars = project gl in
+  let env = pf_env gl in
+  let sigma, hi = decompose_applied_relation env evars (c,l) in
+  let but = match clause with
+    | Some id -> pf_get_hyp_typ gl id 
+    | None -> Evarutil.nf_evar evars (pf_concl gl)
+  in
+  unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env
+
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
+
+(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *)
+(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *)
+
+(** Setoid rewriting when called with "rewrite" *)
+let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
+  let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in
+  let unify () env evars t = unify_abs res l2r sort env evars t in
+  let app = apply_rule unify occs in
+  let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in
+  let substrat = Strategies.fix recstrat in
+  let strat () env avoid t ty cstr evars =
+    let _, res = substrat ((), 0) env avoid t ty cstr evars in
+    (), res
+  in
+  let origsigma = project gl in
+  init_setoid ();
+    try
+      tclWEAK_PROGRESS 
+	(tclTHEN
+           (Refiner.tclEVARS evd)
+	   (Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~abs:(Some abs) ~origsigma strat cl))) gl
+    with RewriteFailure e ->
+      tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl
+
+let general_s_rewrite_clause x =
+  match x with
+    | None -> general_s_rewrite None
+    | Some id -> general_s_rewrite (Some id)
+
+let general_s_rewrite_clause x y z w ~new_goals =
+  Proofview.V82.tactic (general_s_rewrite_clause x y z w ~new_goals)
+
+let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause
+
+(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
+
+let not_declared env ty rel =
+  Tacticals.New.tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++
+		str ty ++ str" relation. Maybe you need to require the Setoid library")
+
+let setoid_proof ty fn fallback =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Proofview.Goal.concl gl in
+    Proofview.tclORELSE
+      begin
+        try
+          let rel, _, _ = decompose_app_rel env sigma concl in
+          let evm = sigma in
+          let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
+	    (try init_setoid () with _ -> raise Not_found);
+            fn env sigma car rel
+        with e -> Proofview.tclZERO e
+      end
+      begin function
+        | e ->
+            Proofview.tclORELSE
+              fallback
+              begin function (e', info) -> match e' with
+                | Hipattern.NoEquationFound ->
+	            begin match e with
+	            | (Not_found, _) ->
+	                let rel, _, _ = decompose_app_rel env sigma concl in
+		        not_declared env ty rel
+	            | (e, info) -> Proofview.tclZERO ~info e
+                    end
+                | e' -> Proofview.tclZERO ~info e'
+              end
+      end
+  end
+
+let tac_open ((evm,_), c) tac = 
+  Proofview.V82.tactic 
+    (tclTHEN (Refiner.tclEVARS evm) (tac c))
+
+let poly_proof getp gett env evm car rel =
+  if Sorts.is_prop (sort_of_rel env evm rel) then
+    getp env (evm,Evar.Set.empty) car rel
+  else gett env (evm,Evar.Set.empty) car rel
+
+let setoid_reflexivity =
+  setoid_proof "reflexive"
+    (fun env evm car rel -> 
+      tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof
+		  env evm car rel) (fun c -> Proofview.V82.of_tactic (apply c)))
+    (reflexivity_red true)
+
+let setoid_symmetry =
+  setoid_proof "symmetric"
+    (fun env evm car rel -> 
+      tac_open
+	(poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof
+	   env evm car rel)
+	(fun c -> Proofview.V82.of_tactic (apply c)))
+    (symmetry_red true)
+    
+let setoid_transitivity c =
+  setoid_proof "transitive"
+    (fun env evm car rel ->
+      tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof
+	   env evm car rel)
+	(fun proof -> match c with
+	| None -> Proofview.V82.of_tactic (eapply proof)
+	| Some c -> Proofview.V82.of_tactic (apply_with_bindings (proof,ImplicitBindings [ c ]))))
+    (transitivity_red true c)
+    
+let setoid_symmetry_in id =
+  Proofview.V82.tactic (fun gl ->
+  let ctype = pf_type_of gl (mkVar id) in
+  let binders,concl = decompose_prod_assum ctype in
+  let (equiv, args) = decompose_app concl in
+  let rec split_last_two = function
+    | [c1;c2] -> [],(c1, c2)
+    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
+    | _ -> error "Cannot find an equivalence relation to rewrite."
+  in
+  let others,(c1,c2) = split_last_two args in
+  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
+  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
+  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
+   Proofview.V82.of_tactic
+    (Tacticals.New.tclTHENLAST
+      (Tactics.assert_after_replacing id new_hyp)
+      (Tacticals.New.tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ]))
+      gl)
+
+let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity
+let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry
+let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in
+let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity
+
+let get_lemma_proof f env evm x y = 
+  let (evm, _), c = f env (evm,Evar.Set.empty) x y in
+    evm, c
+
+let get_reflexive_proof =
+  get_lemma_proof PropGlobal.get_reflexive_proof
+
+let get_symmetric_proof = 
+  get_lemma_proof PropGlobal.get_symmetric_proof
+
+let get_transitive_proof = 
+  get_lemma_proof PropGlobal.get_transitive_proof
+  
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
deleted file mode 100644
index 41944125..00000000
--- a/tactics/rewrite.ml4
+++ /dev/null
@@ -1,2121 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Namegen
-open Term
-open Termops
-open Sign
-open Reduction
-open Proof_type
-open Declarations
-open Tacticals
-open Tacmach
-open Evar_refiner
-open Tactics
-open Pattern
-open Clenv
-open Auto
-open Glob_term
-open Hiddentac
-open Typeclasses
-open Typeclasses_errors
-open Classes
-open Topconstr
-open Pfedit
-open Command
-open Libnames
-open Evd
-open Compat
-
-(** Typeclass-based generalized rewriting. *)
-
-let classes_dirpath =
-  make_dirpath (List.map id_of_string ["Classes";"Coq"])
-
-let init_setoid () =
-  if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then ()
-  else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"]
-
-let proper_class =
-  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper"))))
-
-let proper_proxy_class =
-  lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.ProperProxy"))))
-
-let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs))))
-
-let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-
-let try_find_global_reference dir s =
-  let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in
-    Nametab.global_of_path sp
-
-let try_find_reference dir s =
-  constr_of_global (try_find_global_reference dir s)
-
-let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s
-let coq_eq = lazy(gen_constant ["Init"; "Logic"] "eq")
-let coq_f_equal = lazy (gen_constant ["Init"; "Logic"] "f_equal")
-let coq_all = lazy (gen_constant ["Init"; "Logic"] "all")
-let coq_forall = lazy (gen_constant ["Classes"; "Morphisms"] "forall_def")
-let impl = lazy (gen_constant ["Program"; "Basics"] "impl")
-let arrow = lazy (gen_constant ["Program"; "Basics"] "arrow")
-
-let reflexive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Reflexive")
-let reflexive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "reflexivity")
-
-let symmetric_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Symmetric")
-let symmetric_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "symmetry")
-
-let transitive_type = lazy (try_find_reference ["Classes"; "RelationClasses"] "Transitive")
-let transitive_proof = lazy (try_find_reference ["Classes"; "RelationClasses"] "transitivity")
-
-let coq_inverse = lazy (gen_constant (* ["Classes"; "RelationClasses"] "inverse" *)
-			   ["Program"; "Basics"] "flip")
-
-let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |])
-(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; new_Type (); rel |]) *)
-
-let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation")
-let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation")
-
-let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful")
-
-let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation")
-
-let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation")
-let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation")
-let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation")
-
-let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation")
-let mk_relation a = mkApp (Lazy.force coq_relation, [| a |])
-(* let mk_relation a = mkProd (Anonymous, a, mkProd (Anonymous, a, new_Type ())) *)
-
-let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation")
-
-let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl)
-
-let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl)
-
-let is_applied_rewrite_relation env sigma rels t =
-  match kind_of_term t with
-  | App (c, args) when Array.length args >= 2 ->
-      let head = if isApp c then fst (destApp c) else c in
-	if eq_constr (Lazy.force coq_eq) head then None
-	else
-	  (try
-	      let params, args = array_chop (Array.length args - 2) args in
-	      let env' = Environ.push_rel_context rels env in
-	      let evd, evar = Evarutil.new_evar sigma env' (new_Type ()) in
-	      let inst = mkApp (Lazy.force rewrite_relation_class, [| evar; mkApp (c, params) |]) in
-	      let _ = Typeclasses.resolve_one_typeclass env' evd inst in
-		Some (it_mkProd_or_LetIn t rels)
-	  with e when Errors.noncritical e -> None)
-  | _ -> None
-
-let _ =
-  Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation
-
-let split_head = function
-    hd :: tl -> hd, tl
-  | [] -> assert(false)
-
-let new_cstr_evar (goal,cstr) env t =
-  let cstr', t = Evarutil.new_evar cstr env t in
-    (goal, cstr'), t
-
-let new_goal_evar (goal,cstr) env t =
-  let goal', t = Evarutil.new_evar goal env t in
-    (goal', cstr), t
-
-let build_signature evars env m (cstrs : (types * types option) option list)
-    (finalcstr : (types * types option) option) =
-  let new_evar evars env t =
-    new_cstr_evar evars env
-      (* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
-  in
-  let mk_relty evars newenv ty obj =
-    match obj with
-      | None | Some (_, None) ->
-	  let relty = mk_relation ty in
-	    if closed0 ty then 
-	      let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in
-		new_evar evars env' relty
-	    else new_evar evars newenv relty
-      | Some (x, Some rel) -> evars, rel
-  in
-  let rec aux env evars ty l =
-    let t = Reductionops.whd_betadeltaiota env (fst evars) ty in
-      match kind_of_term t, l with
-      | Prod (na, ty, b), obj :: cstrs ->
-	  if noccurn 1 b (* non-dependent product *) then
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
-	    let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in
-	    let evars, relty = mk_relty evars env ty obj in
-	    let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in
-	      evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs
-	  else
-	    let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in
-	    let ty = Reductionops.nf_betaiota (fst evars) ty in
-	    let pred = mkLambda (na, ty, b) in
-	    let liftarg = mkLambda (na, ty, arg) in
-	    let arg' = mkApp (Lazy.force forall_relation, [| ty ; pred ; liftarg |]) in
-	      if obj = None then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs
-	      else error "build_signature: no constraint can apply on a dependent argument"
-      | _, obj :: _ -> anomaly "build_signature: not enough products"
-      | _, [] ->
-	  (match finalcstr with
-	  | None | Some (_, None) ->
-	      let t = Reductionops.nf_betaiota (fst evars) ty in
-	      let evars, rel = mk_relty evars env t None in
-		evars, t, rel, [t, Some rel]
-	  | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
-  in aux env evars m cstrs
-
-let proper_proof env evars carrier relation x =
-  let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |])
-  in new_cstr_evar evars env goal
-
-let extends_undefined evars evars' =
-  let f ev evi found = found || not (Evd.mem evars ev)
-  in fold_undefined f evars' false
-  
-
-let find_class_proof proof_type proof_method env evars carrier relation =
-  try
-    let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in
-    let evars', c = Typeclasses.resolve_one_typeclass env evars goal in
-      if extends_undefined evars evars' then raise Not_found
-      else mkApp (Lazy.force proof_method, [| carrier; relation; c |])
-  with e when Logic.catchable_exception e -> raise Not_found
-
-let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env
-let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env
-let get_transitive_proof env = find_class_proof transitive_type transitive_proof env
-
-exception FoundInt of int
-
-let array_find (arr: 'a array) (pred: int -> 'a -> bool): int =
-  try
-    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done;
-    raise Not_found
-  with FoundInt i -> i
-
-type hypinfo = {
-  cl : clausenv;
-  prf : constr;
-  car : constr;
-  rel : constr;
-  l2r : bool;
-  c1 : constr;
-  c2 : constr;
-  c  : (Tacinterp.interp_sign * Genarg.glob_constr_and_expr with_bindings) option;
-  abs : (constr * types) option;
-  flags : Unification.unify_flags;
-}
-
-let goalevars evars = fst evars
-let cstrevars evars = snd evars
-
-let evd_convertible env evd x y =
-  try ignore(Evarconv.the_conv_x env x y evd); true
-  with e when Errors.noncritical e -> false
-
-let rec decompose_app_rel env evd t = 
-  match kind_of_term t with
-  | App (f, args) -> 
-      if Array.length args > 1 then 
-	let fargs, args = array_chop (Array.length args - 2) args in
-	  mkApp (f, fargs), args
-      else 
-	let (f', args) = decompose_app_rel env evd args.(0) in
-	let ty = Typing.type_of env evd args.(0) in
-	let f'' = mkLambda (Name (id_of_string "x"), ty,
-	  mkLambda (Name (id_of_string "y"), lift 1 ty,
-	    mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
-	in (f'', args)
-  | _ -> error "The term provided is not an applied relation."
-
-(*   let nc, c', cl = push_rel_context_to_named_context env c in *)
-(*   let env' = reset_with_named_context nc env in *)
-
-let decompose_applied_relation env sigma flags orig (c,l) left2right =
-  let c' = c in
-  let ctype = Typing.type_of env sigma c' in
-  let find_rel ty =
-    let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
-    let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in
-    let c1 = args.(0) and c2 = args.(1) in 
-    let ty1, ty2 =
-      Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
-    in
-      if not (evd_convertible env eqclause.evd ty1 ty2) then None
-      else
-	Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
-	       car=ty1; rel = equiv;
-	       l2r=left2right; c1=c1; c2=c2; c=orig; abs=None;
-	       flags = flags }
-  in
-    match find_rel ctype with
-    | Some c -> c
-    | None ->
-	let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *)
-	match find_rel (it_mkProd_or_LetIn t' ctx) with
-	| Some c -> c
-	| None -> error "The term does not end with an applied homogeneous relation."
-
-open Tacinterp
-let decompose_applied_relation_expr env sigma flags (is, (c,l)) left2right =
-  let sigma, cbl = Tacinterp.interp_open_constr_with_bindings false is env sigma (c,l) in
-    decompose_applied_relation env sigma flags (Some (is, (c,l))) cbl left2right
-
-let rewrite_db = "rewrite"
-
-let conv_transparent_state = (Idpred.empty, Cpred.full)
-
-let _ = 
-  Auto.add_auto_init
-    (fun () ->
-       Auto.create_hint_db false rewrite_db conv_transparent_state true)
-
-let rewrite_transparent_state () =
-  Auto.Hint_db.transparent_state (Auto.searchtable_map rewrite_db)
-
-let rewrite_unif_flags = {
-  Unification.modulo_conv_on_closed_terms = None;
-  Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-  Unification.modulo_delta = empty_transparent_state;
-  Unification.modulo_delta_types = full_transparent_state;
-  Unification.modulo_delta_in_merge = None;
-  Unification.check_applied_meta_types = true;
-  Unification.resolve_evars = true;
-  Unification.use_pattern_unification = true;
-  Unification.use_meta_bound_pattern_unification = true;
-  Unification.frozen_evars = ExistentialSet.empty;
-  Unification.restrict_conv_on_strict_subterms = false;
-  Unification.modulo_betaiota = false;
-  Unification.modulo_eta = true;
-  Unification.allow_K_in_toplevel_higher_order_unification = true
-}
-
-let rewrite2_unif_flags =
-  {  Unification.modulo_conv_on_closed_terms = Some conv_transparent_state;
-     Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-     Unification.modulo_delta = empty_transparent_state;
-     Unification.modulo_delta_types = conv_transparent_state;
-     Unification.modulo_delta_in_merge = None;
-     Unification.check_applied_meta_types = true;
-     Unification.resolve_evars = true;
-     Unification.use_pattern_unification = true;
-     Unification.use_meta_bound_pattern_unification = true;
-     Unification.frozen_evars = ExistentialSet.empty;
-     Unification.restrict_conv_on_strict_subterms = false;
-     Unification.modulo_betaiota = true;
-     Unification.modulo_eta = true;
-     Unification.allow_K_in_toplevel_higher_order_unification = true
-  }
-
-let general_rewrite_unif_flags () = 
-  let ts = rewrite_transparent_state () in
-    {  Unification.modulo_conv_on_closed_terms = Some ts;
-       Unification.use_metas_eagerly_in_conv_on_closed_terms = true;
-       Unification.modulo_delta = ts;
-       Unification.modulo_delta_types = ts;
-       Unification.modulo_delta_in_merge = None;
-       Unification.check_applied_meta_types = true;
-       Unification.resolve_evars = true;
-       Unification.use_pattern_unification = true;
-       Unification.use_meta_bound_pattern_unification = true;
-       Unification.frozen_evars = ExistentialSet.empty;
-       Unification.restrict_conv_on_strict_subterms = false;
-       Unification.modulo_betaiota = true;
-       Unification.modulo_eta = true;
-       Unification.allow_K_in_toplevel_higher_order_unification = true }
-
-let convertible env evd x y =
-  Reductionops.is_conv env evd x y
-
-let refresh_hypinfo env sigma hypinfo =
-  if hypinfo.abs = None then
-    let {l2r=l2r; c=c;cl=cl;flags=flags} = hypinfo in
-      match c with
-	| Some c ->
-	    (* Refresh the clausenv to not get the same meta twice in the goal. *)
-	    decompose_applied_relation_expr env sigma flags c l2r;
-	| _ -> hypinfo
-  else hypinfo
-
-let unify_eqn env sigma hypinfo t =
-  if isEvar t then None
-  else try
-    let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in
-    let left = if l2r then c1 else c2 in
-    let env', prf, c1, c2, car, rel =
-      match abs with
-      | Some (absprf, absprfty) ->
-	  let env' = clenv_unify ~flags:rewrite_unif_flags CONV left t cl in
-	    env', prf, c1, c2, car, rel
-      | None ->
-	  let env' = clenv_unify ~flags:!hypinfo.flags CONV left t cl
-	  in
-	  let env' = Clenvtac.clenv_pose_dependent_evars true env' in
-(* 	  let env' = Clenv.clenv_pose_metas_as_evars env' (Evd.undefined_metas env'.evd) in *)
-	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env'.env env'.evd in
-	  let env' = { env' with evd = evd' } in
-	  let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in
-	  let c1 = nf c1 and c2 = nf c2
-	  and car = nf car and rel = nf rel
-	  and prf = nf (Clenv.clenv_value env') in
-	  let ty1 = Typing.type_of env'.env env'.evd c1
-	  and ty2 = Typing.type_of env'.env env'.evd c2
-	  in
-	    if convertible env env'.evd ty1 ty2 then (
-	      if occur_meta_or_existential prf then
-		hypinfo := refresh_hypinfo env env'.evd !hypinfo;
-	      env', prf, c1, c2, car, rel)
-	    else raise Reduction.NotConvertible
-    in
-    let res =
-      if l2r then (prf, (car, rel, c1, c2))
-      else
-	try (mkApp (get_symmetric_proof env env'.evd car rel,
-		   [| c1 ; c2 ; prf |]),
-	    (car, rel, c2, c1))
-	with Not_found ->
-	  (prf, (car, inverse car rel, c2, c1))
-    in Some (env'.evd, res)
-  with e when Class_tactics.catchable e -> None
-
-(* let unify_eqn env sigma hypinfo t = *)
-(*   if isEvar t then None *)
-(*   else try *)
-(*     let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in *)
-(*     let left = if l2r then c1 else c2 in *)
-(*     let evd', prf, c1, c2, car, rel = *)
-(*       match abs with *)
-(*       | Some (absprf, absprfty) -> *)
-(* 	  let env' = clenv_unify allowK ~flags:rewrite_unif_flags CONV left t cl in *)
-(* 	    env'.evd, prf, c1, c2, car, rel *)
-(*       | None -> *)
-(* 	  let cl' = Clenv.clenv_pose_metas_as_evars cl (Evd.undefined_metas cl.evd) in *)
-(* 	  let sigma = cl'.evd in *)
-(* 	  let c1 = Clenv.clenv_nf_meta cl' c1 *)
-(* 	  and c2 = Clenv.clenv_nf_meta cl' c2 *)
-(* 	  and prf = Clenv.clenv_nf_meta cl' prf *)
-(* 	  and car = Clenv.clenv_nf_meta cl' car *)
-(* 	  and rel = Clenv.clenv_nf_meta cl' rel *)
-(* 	  in *)
-(* 	  let sigma' = *)
-(* 	    try Evarconv.the_conv_x ~ts:empty_transparent_state env t c1 sigma *)
-(* 	    with Reduction.NotConvertible _ ->  *)
-(* 	      Evarconv.the_conv_x ~ts:conv_transparent_state env t c1 sigma *)
-(* 	  in *)
-(* 	  let sigma' = Evarconv.consider_remaining_unif_problems ~ts:conv_transparent_state env sigma' in *)
-(* 	  let evd' = Typeclasses.resolve_typeclasses ~fail:true env sigma' in *)
-(* 	  let nf c = Evarutil.nf_evar evd' c in *)
-(* 	  let c1 = nf c1 and c2 = nf c2 *)
-(* 	  and car = nf car and rel = nf rel *)
-(* 	  and prf' = nf prf in *)
-(* 	    if occur_meta_or_existential prf then *)
-(* 	      hypinfo := refresh_hypinfo env evd' !hypinfo; *)
-(* 	    evd', prf', c1, c2, car, rel *)
-(*     in *)
-(*     let res = *)
-(*       if l2r then (prf, (car, rel, c1, c2)) *)
-(*       else *)
-(* 	try (mkApp (get_symmetric_proof env Evd.empty car rel, *)
-(* 		   [| c1 ; c2 ; prf |]), *)
-(* 	    (car, rel, c2, c1)) *)
-(* 	with Not_found -> *)
-(* 	  (prf, (car, inverse car rel, c2, c1)) *)
-(*     in Some (evd', res) *)
-(*   with Reduction.NotConvertible -> None *)
-(*   | e when Class_tactics.catchable e -> None *)
-
-let unfold_impl t =
-  match kind_of_term t with
-    | App (arrow, [| a; b |])(*  when eq_constr arrow (Lazy.force impl) *) ->
-	mkProd (Anonymous, a, lift 1 b)
-    | _ -> assert false
-
-let unfold_all t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let unfold_forall t =
-  match kind_of_term t with
-    | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) ->
-	(match kind_of_term b with
-	  | Lambda (n, ty, b) -> mkProd (n, ty, b)
-	  | _ -> assert false)
-    | _ -> assert false
-
-let arrow_morphism ta tb a b =
-  let ap = is_Prop ta and bp = is_Prop tb in
-    if ap && bp then mkApp (Lazy.force impl, [| a; b |]), unfold_impl
-    else if ap then (* Domain in Prop, CoDomain in Type *)
-      mkProd (Anonymous, a, b), (fun x -> x)
-    else if bp then (* Dummy forall *)
-      mkApp (Lazy.force coq_all, [| a; mkLambda (Anonymous, a, b) |]), unfold_forall
-    else (* None in Prop, use arrow *)
-      mkApp (Lazy.force arrow, [| a; b |]), unfold_impl
-
-let rec decomp_pointwise n c =
-  if n = 0 then c
-  else
-    match kind_of_term c with
-    | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	decomp_pointwise (pred n) relb
-    | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
-    | _ -> raise (Invalid_argument "decomp_pointwise")
-	
-let rec apply_pointwise rel = function
-  | arg :: args ->
-      (match kind_of_term rel with
-      | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
-	  apply_pointwise relb args
-      | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
-	  apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
-      | _ -> raise (Invalid_argument "apply_pointwise"))
-  | [] -> rel
-
-let pointwise_or_dep_relation n t car rel =
-  if noccurn 1 car && noccurn 1 rel then
-    mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
-  else
-    mkApp (Lazy.force forall_relation, 
-	  [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
-
-let lift_cstr env sigma evars (args : constr list) c ty cstr =
-  let start env car =
-    match cstr with
-    | None | Some (_, None) ->
-	Evarutil.e_new_evar evars env (mk_relation car)
-    | Some (ty, Some rel) -> rel
-  in
-  let rec aux env prod n = 
-    if n = 0 then start env prod
-    else
-      match kind_of_term (Reduction.whd_betadeltaiota env prod) with
-      | Prod (na, ty, b) ->
-	  if noccurn 1 b then
-	    let b' = lift (-1) b in
-	    let rb = aux env b' (pred n) in
-	      mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
-	  else
-	    let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in
-	      mkApp (Lazy.force forall_relation, 
-		    [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |])
-      | _ -> raise Not_found
-  in 
-  let rec find env c ty = function
-    | [] -> None
-    | arg :: args ->
-	try Some (aux env ty (succ (List.length args)), c, ty, arg :: args)
-	with Not_found ->
-	  find env (mkApp (c, [| arg |])) (prod_applist ty [arg]) args
-  in find env c ty args
-
-let unlift_cstr env sigma = function
-  | None -> None
-  | Some codom -> Some (decomp_pointwise 1 codom)
-
-type rewrite_flags = { under_lambdas : bool; on_morphisms : bool }
-
-let default_flags = { under_lambdas = true; on_morphisms = true; }
-
-type evars = evar_map * evar_map (* goal evars, constraint evars *)
-
-type rewrite_proof = 
-  | RewPrf of constr * constr
-  | RewCast of cast_kind
-
-let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
-
-type rewrite_result_info = {
-  rew_car : constr;
-  rew_from : constr;
-  rew_to : constr;
-  rew_prf : rewrite_proof;
-  rew_evars : evars;
-}
-
-type rewrite_result = rewrite_result_info option
-
-type strategy = Environ.env -> identifier list -> constr -> types ->
-  constr option -> evars -> rewrite_result option
-
-let get_rew_rel r = match r.rew_prf with
-  | RewPrf (rel, prf) -> rel
-  | RewCast c -> mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |])
-
-let get_rew_prf r = match r.rew_prf with
-  | RewPrf (rel, prf) -> rel, prf 
-  | RewCast c ->
-    let rel = mkApp (Coqlib.build_coq_eq (), [| r.rew_car |]) in
-      rel, mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
-		   c, mkApp (rel, [| r.rew_from; r.rew_to |]))
-
-let resolve_subrelation env avoid car rel prf rel' res =
-  if eq_constr rel rel' then res
-  else
-(*   try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *)
-(* 	{ res with rew_evars = evd' } *)
-(*   with NotConvertible -> *)
-    let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in
-    let evars, subrel = new_cstr_evar res.rew_evars env app in
-    let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
-      { res with
-	rew_prf = RewPrf (rel', appsub);
-	rew_evars = evars }
-
-let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' cstr evars =
-  let evars, morph_instance, proj, sigargs, m', args, args' =
-    let first = try (array_find args' (fun i b -> b <> None)) 
-      with Not_found -> raise (Invalid_argument "resolve_morphism") in
-    let morphargs, morphobjs = array_chop first args in
-    let morphargs', morphobjs' = array_chop first args' in
-    let appm = mkApp(m, morphargs) in
-    let appmtype = Typing.type_of env (goalevars evars) appm in
-    let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
-      (* Desired signature *)
-    let evars, appmtype', signature, sigargs = 
-      build_signature evars env appmtype cstrs cstr
-    in
-      (* Actual signature found *)
-    let cl_args = [| appmtype' ; signature ; appm |] in
-    let app = mkApp (Lazy.force proper_type, cl_args) in
-    let env' = Environ.push_named
-      (id_of_string "do_subrelation", Some (Lazy.force do_subrelation), Lazy.force apply_subrelation)
-      env
-    in
-    let evars, morph = new_cstr_evar evars env' app in
-      evars, morph, morph, sigargs, appm, morphobjs, morphobjs'
-  in
-  let projargs, subst, evars, respars, typeargs =
-    array_fold_left2
-      (fun (acc, subst, evars, sigargs, typeargs') x y ->
-	let (carrier, relation), sigargs = split_head sigargs in
-	  match relation with
-	  | Some relation ->
-	      let carrier = substl subst carrier
-	      and relation = substl subst relation in
-	      (match y with
-	      | None ->
-		  let evars, proof = proper_proof env evars carrier relation x in
-		    [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
-	      | Some r ->
-		  [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
-	  | None ->
-	      if y <> None then error "Cannot rewrite the argument of a dependent function";
-	      x :: acc, x :: subst, evars, sigargs, x :: typeargs')
-      ([], [], evars, sigargs, []) args args'
-  in
-  let proof = applistc proj (List.rev projargs) in
-  let newt = applistc m' (List.rev typeargs) in
-    match respars with
-	[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
-      | _ -> assert(false)
-
-let apply_constraint env avoid car rel prf cstr res =
-  match cstr with
-  | None -> res
-  | Some r -> resolve_subrelation env avoid car rel prf r res
-
-let eq_env x y = x == y
-
-let apply_rule hypinfo loccs : strategy =
-  let (nowhere_except_in,occs) = loccs in
-  let is_occ occ =
-    if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in
-  let occ = ref 0 in
-    fun env avoid t ty cstr evars ->
-      if not (eq_env !hypinfo.cl.env env) then
-	hypinfo := refresh_hypinfo env (goalevars evars) !hypinfo;
-      let unif = unify_eqn env (goalevars evars) hypinfo t in
-	if unif <> None then incr occ;
-	match unif with
-	| Some (evd', (prf, (car, rel, c1, c2))) when is_occ !occ ->
-	    begin
-	      if eq_constr t c2 then Some None
-	      else
-		let res = { rew_car = ty; rew_from = c1;
-			    rew_to = c2; rew_prf = RewPrf (rel, prf); 
-			    rew_evars = evd', cstrevars evars }
-		in Some (Some (apply_constraint env avoid car rel prf cstr res))
-	    end
-	| _ -> None
-
-let apply_lemma flags (evm,c) left2right loccs : strategy =
-  fun env avoid t ty cstr evars ->
-    let hypinfo = ref (decompose_applied_relation env (goalevars evars) flags None c left2right) in
-      apply_rule hypinfo loccs env avoid t ty cstr evars
-
-let make_leibniz_proof c ty r =
-  let prf = 
-    match r.rew_prf with
-    | RewPrf (rel, prf) -> 
-	let rel = mkApp (Lazy.force coq_eq, [| ty |]) in
-	let prf =
-	  mkApp (Lazy.force coq_f_equal,
-		[| r.rew_car; ty;
-		   mkLambda (Anonymous, r.rew_car, c);
-		   r.rew_from; r.rew_to; prf |])
-	in RewPrf (rel, prf)
-    | RewCast k -> r.rew_prf
-  in
-    { r with rew_car = ty; 
-      rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf }
-
-open Elimschemes
-
-let reset_env env =
-  let env' = Global.env_of_context (Environ.named_context_val env) in
-    Environ.push_rel_context (Environ.rel_context env) env'
-      
-let fold_match ?(force=false) env sigma c =
-  let (ci, p, c, brs) = destCase c in
-  let cty = Retyping.get_type_of env sigma c in
-  let dep, pred, exists, sk = 
-    let env', ctx, body =
-      let ctx, pred = decompose_lam_assum p in
-      let env' = Environ.push_rel_context ctx env in
-	env', ctx, pred
-    in
-    let sortp = Retyping.get_sort_family_of env' sigma body in
-    let sortc = Retyping.get_sort_family_of env sigma cty in
-    let dep = not (noccurn 1 body) in
-    let pred = if dep then p else
-	it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
-    in
-    let sk = 
-      if sortp = InProp then
-	if sortc = InProp then
-	  if dep then case_dep_scheme_kind_from_prop
-	  else case_scheme_kind_from_prop
-	else (
-	  if dep
-	  then case_dep_scheme_kind_from_type_in_prop
-	  else case_scheme_kind_from_type)
-      else ((* sortc <> InProp by typing *)
-	if dep
-	then case_dep_scheme_kind_from_type
-	else case_scheme_kind_from_type)
-    in 
-    let exists = Ind_tables.check_scheme sk ci.ci_ind in
-      if exists || force then
-	dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
-      else raise Not_found
-  in
-  let app =
-    let ind, args = Inductive.find_rectype env cty in
-    let pars, args = list_chop ci.ci_npar args in
-    let meths = List.map (fun br -> br) (Array.to_list brs) in
-      applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
-  in 
-    sk, (if exists then env else reset_env env), app
-      
-let unfold_match env sigma sk app =
-  match kind_of_term app with
-  | App (f', args) when f' = mkConst sk ->
-      let v = Environ.constant_value (Global.env ()) sk in
-	Reductionops.whd_beta sigma (mkApp (v, args))
-  | _ -> app
-
-let is_rew_cast = function RewCast _ -> true | _ -> false
-
-let coerce env avoid cstr res = 
-  let rel, prf = get_rew_prf res in
-    apply_constraint env avoid res.rew_car rel prf cstr res
-
-let subterm all flags (s : strategy) : strategy =
-  let rec aux env avoid t ty cstr evars =
-    let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
-      match kind_of_term t with
-      | App (m, args) ->
-	  let rewrite_args success =
-	    let args', evars', progress =
-	      Array.fold_left
-		(fun (acc, evars, progress) arg ->
-		  if progress <> None && not all then (None :: acc, evars, progress)
-		  else
-		    let res = s env avoid arg (Typing.type_of env (goalevars evars) arg) None evars in
-		      match res with
-		      | Some None -> (None :: acc, evars, if progress = None then Some false else progress)
-		      | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true)
-		      | None -> (None :: acc, evars, progress))
-		([], evars, success) args
-	    in
-	      match progress with
-	      | None -> None
-	      | Some false -> Some None
-	      | Some true ->
-		  let args' = Array.of_list (List.rev args') in
-		    if array_exists
-		      (function 
-			 | None -> false 
-			 | Some r -> not (is_rew_cast r.rew_prf)) args'
-		    then
-		      let evars', prf, car, rel, c1, c2 = resolve_morphism env avoid t m args args' cstr' evars' in
-		      let res = { rew_car = ty; rew_from = c1;
-				  rew_to = c2; rew_prf = RewPrf (rel, prf);
-				  rew_evars = evars' } 
-		      in Some (Some res)
-		    else 
-		      let args' = array_map2
-			(fun aorig anew ->
-			   match anew with None -> aorig
-			   | Some r -> r.rew_to) args args' 
-		      in
-		      let res = { rew_car = ty; rew_from = t;
-				  rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast;
-				  rew_evars = evars' }
-		      in Some (Some res)
-
-	  in
-	    if flags.on_morphisms then
-	      let evarsref = ref (snd evars) in
-	      let mty = Typing.type_of env (goalevars evars) m in
-	      let cstr', m, mty, argsl, args = 
-		let argsl = Array.to_list args in
-		  match lift_cstr env (goalevars evars) evarsref argsl m mty None with
-		  | Some (cstr', m, mty, args) -> Some cstr', m, mty, args, Array.of_list args
-		  | None -> None, m, mty, argsl, args
-	      in
-	      let m' = s env avoid m mty cstr' (fst evars, !evarsref) in
-		match m' with
-		| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
-		| Some None -> rewrite_args (Some false)
-		| Some (Some r) ->
-		    (* We rewrote the function and get a proof of pointwise rel for the arguments.
-		       We just apply it. *)
-		    let prf = match r.rew_prf with
-		      | RewPrf (rel, prf) ->
-			  RewPrf (apply_pointwise rel argsl, mkApp (prf, args))
-		      | x -> x
-		    in
-		    let res =
-		      { rew_car = prod_appvect r.rew_car args;
-			rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
-			rew_prf = prf;
-			rew_evars = r.rew_evars }
-		    in 
-		      match prf with
-		      | RewPrf (rel, prf) ->
-			Some (Some (apply_constraint env avoid res.rew_car rel prf cstr res))
-		      | _ -> Some (Some res)
-	    else rewrite_args None
-	      
-      | Prod (n, x, b) when noccurn 1 b ->
-	  let b = subst1 mkProp b in
-	  let tx = Typing.type_of env (goalevars evars) x and tb = Typing.type_of env (goalevars evars) b in
-	  let mor, unfold = arrow_morphism tx tb x b in
-	  let res = aux env avoid mor ty cstr evars in
-	    (match res with
-	    | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
-	    | _ -> res)
-
-      (* 		if x' = None && flags.under_lambdas then *)
-      (* 		  let lam = mkLambda (n, x, b) in *)
-      (* 		  let lam', occ = aux env lam occ None in *)
-      (* 		  let res =  *)
-      (* 		    match lam' with *)
-      (* 		    | None -> None *)
-      (* 		    | Some (prf, (car, rel, c1, c2)) -> *)
-      (* 			Some (resolve_morphism env sigma t *)
-      (* 				 ~fnewt:unfold_all *)
-      (* 				 (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *)
-      (* 				 cstr evars) *)
-      (* 		  in res, occ *)
-      (* 		else *)
-
-      | Prod (n, dom, codom) ->
-	  let lam = mkLambda (n, dom, codom) in
-	  let app, unfold = 
-	    if eq_constr ty mkProp then
-	      mkApp (Lazy.force coq_all, [| dom; lam |]), unfold_all
-	    else mkApp (Lazy.force coq_forall, [| dom; lam |]), unfold_forall
-	  in
-	  let res = aux env avoid app ty cstr evars in
-	    (match res with
-	     | Some (Some r) -> Some (Some { r with rew_to = unfold r.rew_to })
-	     | _ -> res)
-
-      | Lambda (n, t, b) when flags.under_lambdas ->
-	  let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in
-	  let env' = Environ.push_rel (n', None, t) env in
-	  let b' = s env' avoid b (Typing.type_of env' (goalevars evars) b) (unlift_cstr env (goalevars evars) cstr) evars in
-	    (match b' with
-	    | Some (Some r) ->
-		let prf = match r.rew_prf with
-		  | RewPrf (rel, prf) ->
-		      let rel = pointwise_or_dep_relation n' t r.rew_car rel in
-		      let prf = mkLambda (n', t, prf) in
-			RewPrf (rel, prf)
-		  | x -> x
-		in
-		  Some (Some { r with
-		    rew_prf = prf;
-		    rew_car = mkProd (n, t, r.rew_car);
-		    rew_from = mkLambda(n, t, r.rew_from);
-		    rew_to = mkLambda (n, t, r.rew_to) })
-	    | _ -> b')
-
-      | Case (ci, p, c, brs) ->
-	  let cty = Typing.type_of env (goalevars evars) c in
-	  let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
-	  let c' = s env avoid c cty cstr' evars in
-	  let res = 
-	    match c' with
-	    | Some (Some r) ->
-		let res = make_leibniz_proof (mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs)) ty r in
-		  Some (Some (coerce env avoid cstr res))
-	    | x ->
-	      if array_for_all ((=) 0) ci.ci_cstr_ndecls then
-		let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in
-		let found, brs' = Array.fold_left 
-		  (fun (found, acc) br ->
-		   if found <> None then (found, fun x -> lift 1 br :: acc x)
-		   else
-		     match s env avoid br ty cstr evars with
-		     | Some (Some r) -> (Some r, fun x -> mkRel 1 :: acc x)
-		     | _ -> (None, fun x -> lift 1 br :: acc x))
-		  (None, fun x -> []) brs
-		in
-		  match found with
-		  | Some r ->
-		    let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' x))) in
-		      Some (Some (make_leibniz_proof ctxc ty r))
-		  | None -> x
-	      else
-		match try Some (fold_match env (goalevars evars) t) with Not_found -> None with
-		| None -> x
-		| Some (cst, _, t') ->
-		  match aux env avoid t' ty cstr evars with
-		  | Some (Some prf) -> 
-		    Some (Some { prf with
-				 rew_from = t; rew_to = unfold_match env (goalevars evars) cst prf.rew_to })
-		  | x' -> x
-	  in 
-	    (match res with
-	     | Some (Some r) ->  
-	       let rel, prf = get_rew_prf r in
-		 Some (Some (apply_constraint env avoid r.rew_car rel prf cstr r))
-	     | x -> x)
-      | _ -> None
-  in aux
-
-let all_subterms = subterm true default_flags
-let one_subterm = subterm false default_flags
-
-(** Requires transitivity of the rewrite step, if not a reduction.
-    Not tail-recursive. *)
-
-let transitivity env avoid (res : rewrite_result_info) (next : strategy) : rewrite_result option =
-  match next env avoid res.rew_to res.rew_car (get_opt_rew_rel res.rew_prf) res.rew_evars with
-  | None -> None
-  | Some None -> Some (Some res)
-  | Some (Some res') ->
-      match res.rew_prf with
-      | RewCast c -> Some (Some { res' with rew_from = res.rew_from })
-      | RewPrf (rew_rel, rew_prf) ->
-	  match res'.rew_prf with
-	  | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to }))
-	  | RewPrf (res'_rel, res'_prf) ->
-	      let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in
-	      let evars, prf = new_cstr_evar res'.rew_evars env prfty in
-	      let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
-				      rew_prf; res'_prf |])
-	      in Some (Some { res' with rew_from = res.rew_from; 
-		rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) })
-		
-(** Rewriting strategies.
-
-    Inspired by ELAN's rewriting strategies:
-    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049
-*)
-
-module Strategies =
-  struct
-
-    let fail : strategy =
-      fun env avoid t ty cstr evars -> None
-
-    let id : strategy =
-      fun env avoid t ty cstr evars -> Some None
-
-    let refl : strategy =
-      fun env avoid t ty cstr evars ->
-	let evars, rel = match cstr with
-	  | None -> new_cstr_evar evars env (mk_relation ty)
-	  | Some r -> evars, r
-	in
-	let evars, proof =
-	  let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in
-	    new_cstr_evar evars env mty
-	in
-	  Some (Some { rew_car = ty; rew_from = t; rew_to = t;
-		       rew_prf = RewPrf (rel, proof); rew_evars = evars })
-
-    let progress (s : strategy) : strategy =
-      fun env avoid t ty cstr evars ->
-	match s env avoid t ty cstr evars with
-	| None -> None
-	| Some None -> None
-	| r -> r
-
-    let seq fst snd : strategy =
-      fun env avoid t ty cstr evars ->
-	match fst env avoid t ty cstr evars with
-	| None -> None
-	| Some None -> snd env avoid t ty cstr evars
-	| Some (Some res) -> transitivity env avoid res snd
-
-    let choice fst snd : strategy =
-      fun env avoid t ty cstr evars ->
-	match fst env avoid t ty cstr evars with
-	| None -> snd env avoid t ty cstr evars
-	| res -> res
-
-    let try_ str : strategy = choice str id
-
-    let fix (f : strategy -> strategy) : strategy =
-      let rec aux env = f (fun env -> aux env) env in aux
-
-    let any (s : strategy) : strategy =
-      fix (fun any -> try_ (seq s any))
-
-    let repeat (s : strategy) : strategy =
-      seq s (any s)
-
-    let bu (s : strategy) : strategy =
-      fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s'))
-
-    let td (s : strategy) : strategy =
-      fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s'))
-
-    let innermost (s : strategy) : strategy =
-      fix (fun ins -> choice (one_subterm ins) s)
-
-    let outermost (s : strategy) : strategy =
-      fix (fun out -> choice s (one_subterm out))
-
-    let lemmas flags cs : strategy =
-      List.fold_left (fun tac (l,l2r) ->
-	choice tac (apply_lemma flags l l2r (false,[])))
-	fail cs
-
-    let inj_open c = (Evd.empty,c)
-
-    let old_hints (db : string) : strategy =
-      let rules = Autorewrite.find_rewrites db in
-	lemmas rewrite_unif_flags
-	  (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
-
-    let hints (db : string) : strategy =
-      fun env avoid t ty cstr evars ->
-      let rules = Autorewrite.find_matches db t in
-      let lemma hint = (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r) in
-      let lems = List.map lemma rules in
-	lemmas rewrite_unif_flags lems env avoid t ty cstr evars
-
-    let reduce (r : Redexpr.red_expr) : strategy =
-      let rfn, ckind = Redexpr.reduction_of_red_expr r in
-	fun env avoid t ty cstr evars ->
-	  let t' = rfn env (goalevars evars) t in
-	    if eq_constr t' t then
-	      Some None
-	    else
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = t';
-			   rew_prf = RewCast ckind; rew_evars = evars })
-	
-    let fold c : strategy =
-      fun env avoid t ty cstr evars ->
-(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
-	let sigma, c = Constrintern.interp_open_constr (goalevars evars) env c in
-	let unfolded =
-	  try Tacred.try_red_product env sigma c
-	  with e when Errors.noncritical e ->
-            error "fold: the term is not unfoldable !"
-	in
-	  try
-	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
-	    let c' = Evarutil.nf_evar sigma c in
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
-			   rew_prf = RewCast DEFAULTcast; 
-			   rew_evars = sigma, cstrevars evars })
-	  with e when Errors.noncritical e -> None
-
-    let fold_glob c : strategy =
-      fun env avoid t ty cstr evars ->
-(* 	let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *)
-	let sigma, c = Pretyping.Default.understand_tcc (goalevars evars) env c in
-	let unfolded =
-	  try Tacred.try_red_product env sigma c
-	  with e when Errors.noncritical e ->
-            error "fold: the term is not unfoldable !"
-	in
-	  try
-	    let sigma = Unification.w_unify env sigma CONV ~flags:Unification.elim_flags unfolded t in
-	    let c' = Evarutil.nf_evar sigma c in
-	      Some (Some { rew_car = ty; rew_from = t; rew_to = c';
-			   rew_prf = RewCast DEFAULTcast; 
-			   rew_evars = sigma, cstrevars evars })
-	  with e when Errors.noncritical e -> None
-  
-
-end
-
-(** The strategy for a single rewrite, dealing with occurences. *)
-
-let rewrite_strat flags occs hyp =
-  let app = apply_rule hyp occs in
-  let rec aux () =
-    Strategies.choice app (subterm true flags (fun env -> aux () env))
-  in aux ()
-
-let get_hypinfo_ids {c = opt} =
-  match opt with
-  | None -> []
-  | Some (is, gc) -> List.map fst is.lfun @ is.avoid_ids
-
-let rewrite_with flags c left2right loccs : strategy =
-  fun env avoid t ty cstr evars ->
-    let gevars = goalevars evars in
-    let hypinfo = ref (decompose_applied_relation_expr env gevars flags c left2right) in
-    let avoid = get_hypinfo_ids !hypinfo @ avoid in
-      rewrite_strat default_flags loccs hypinfo env avoid t ty cstr (gevars, cstrevars evars)
-
-let apply_strategy (s : strategy) env avoid concl cstr evars =
-  let res =
-    s env avoid
- concl (Typing.type_of env (goalevars evars) concl)
-      (Option.map snd cstr) evars
-  in
-    match res with
-    | None -> None
-    | Some None -> Some None
-    | Some (Some res) ->
-	Some (Some (res.rew_prf, res.rew_evars, res.rew_car, res.rew_from, res.rew_to))
-
-let merge_evars (goal,cstr) = Evd.merge goal cstr
-let solve_constraints env evars =
-  Typeclasses.resolve_typeclasses env ~split:false ~fail:true
-    (merge_evars evars)
-
-let nf_zeta =
-  Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
-
-let map_rewprf f = function
-  | RewPrf (rel, prf) -> RewPrf (f rel, f prf)
-  | RewCast c -> RewCast c
-
-type result = (evar_map * constr option * types) option option
-
-let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result =
-  let cstr =
-    let sort = mkProp in
-    let impl = Lazy.force impl in
-      match is_hyp with
-      | None -> (sort, inverse sort impl)
-      | Some _ -> (sort, impl)
-  in
-  let evars = (sigma, Evd.empty) in
-  let eq = apply_strategy strat env avoid concl (Some cstr) evars in
-    match eq with
-    | Some (Some (p, evars, car, oldt, newt)) ->
-	let evars' = solve_constraints env evars in
-	let p = map_rewprf (fun p -> nf_zeta env evars' (Evarutil.nf_evar evars' p)) p in
-	let newt = Evarutil.nf_evar evars' newt in
-	let abs = Option.map (fun (x, y) ->
-				Evarutil.nf_evar evars' x, Evarutil.nf_evar evars' y) abs in
-	let evars = (* Keep only original evars (potentially instantiated) and goal evars,
-		       the rest has been defined and substituted already. *)
-(* 	  let cstrs = cstrevars evars in *)
-	    (* cstrs is small *)
-	  let gevars = goalevars evars in
-	    Evd.fold (fun ev evi acc -> 
-			if Evd.mem gevars ev then Evd.add acc ev evi
-			else acc) evars' Evd.empty
-(* 	    Evd.fold (fun ev evi acc -> Evd.remove acc ev) cstrs evars' *)
-	in
-	let res =
-	  match is_hyp with
-	  | Some id ->
-	      (match p with
-	       | RewPrf (rel, p) ->
-		   let term =
-		     match abs with
-		     | None -> p
-		     | Some (t, ty) ->
-			 mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
-		   in
-		     Some (evars, Some (mkApp (term, [| mkVar id |])), newt)
-	       | RewCast c ->
-		   Some (evars, None, newt))
-		
-	  | None ->
-	      (match p with
-	       | RewPrf (rel, p) ->
-		   (match abs with
-		    | None -> Some (evars, Some p, newt)
-		    | Some (t, ty) ->
-			let proof = mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in
-			  Some (evars, Some proof, newt))
-	       | RewCast c -> Some (evars, None, newt))
-	in Some res
-    | Some None -> Some None
-    | None -> None
-		   
-let rewrite_refine (evd,c) = 
-  Tacmach.refine c
-
-let cl_rewrite_clause_tac ?abs strat meta clause gl =
-  let evartac evd = Refiner.tclEVARS evd in
-  let treat res =
-    match res with
-    | None -> tclFAIL 0 (str "Nothing to rewrite")
-    | Some None ->
-	tclFAIL 0 (str"No progress made")
-    | Some (Some (undef, p, newt)) ->
-	let tac = 
-	  match clause, p with
-	  | Some id, Some p ->
-	      cut_replacing id newt (Tacmach.refine p)
-	  | Some id, None -> 
-	      change_in_hyp None newt (id, InHypTypeOnly)
-	  | None, Some p ->
-	      let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-		tclTHENLAST
-		  (Tacmach.internal_cut_no_check false name newt)
-		  (tclTHEN (Tactics.revert [name]) (Tacmach.refine p))
-	  | None, None -> change_in_concl None newt
-	in tclTHEN (evartac undef) tac
-  in
-  let tac =
-    try
-      let concl, is_hyp =
-	match clause with
-	| Some id -> pf_get_hyp_typ gl id, Some id
-	| None -> pf_concl gl, None
-      in
-      let sigma = project gl in
-      let concl = Evarutil.nf_evar sigma concl in 
-      let res = cl_rewrite_clause_aux ?abs strat (pf_env gl) [] sigma concl is_hyp in
-	treat res
-    with
-    | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-    | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	Refiner.tclFAIL_lazy 0
-	  (lazy (str"Unable to satisfy the rewriting constraints."
-		 ++ fnl () ++ Himsg.explain_typeclass_error env e))
-  in tac gl
-
-open Goal
-open Environ
-
-let bind_gl_info f =
-  bind concl (fun c -> bind env (fun v -> bind defs (fun ev -> f c v ev))) 
-
-let fail l s =
-  raise (Refiner.FailError (l, lazy s))
-
-let new_refine c : Goal.subgoals Goal.sensitive =
-  let refable = Goal.Refinable.make
-    (fun handle -> Goal.Refinable.constr_of_open_constr handle true c) 
-  in Goal.bind refable Goal.refine
-
-let assert_replacing id newt tac = 
-  let sens = bind_gl_info 
-    (fun concl env sigma ->
-       let nc' = 
-	 Environ.fold_named_context
-	   (fun _ (n, b, t as decl) nc' ->
-	      if n = id then (n, b, newt) :: nc'
-	      else decl :: nc')
-	   env ~init:[]
-       in
-       let reft = Refinable.make 
-	 (fun h -> 
-	    Goal.bind (Refinable.mkEvar h
-			 (Environ.reset_with_named_context (val_of_named_context nc') env) concl)
-	      (fun ev -> 
-		 Goal.bind (Refinable.mkEvar h env newt)
-		   (fun ev' ->
-		      let inst = 
-			fold_named_context
-			  (fun _ (n, b, t) inst ->
-			     if n = id then ev' :: inst
-			     else if b = None then mkVar n :: inst else inst)
-			  env ~init:[]
-		      in
-		      let (e, args) = destEvar ev in
-			Goal.return (mkEvar (e, Array.of_list inst)))))
-       in Goal.bind reft Goal.refine)
-  in Proofview.tclTHEN (Proofview.tclSENSITIVE sens) 
-       (Proofview.tclFOCUS 2 2 tac)
-
-let newfail n s = 
-  Proofview.tclZERO (Refiner.FailError (n, lazy s))
-
-let cl_rewrite_clause_newtac ?abs strat clause =
-  let treat (res, is_hyp) = 
-    match res with
-    | None -> newfail 0 (str "Nothing to rewrite")
-    | Some None ->
-	newfail 0 (str"No progress made")
-    | Some (Some res) ->
-	match is_hyp, res with
-	| Some id, (undef, Some p, newt) ->
-	    assert_replacing id newt (Proofview.tclSENSITIVE (new_refine (undef, p)))
-	| Some id, (undef, None, newt) -> 
-	    Proofview.tclSENSITIVE (Goal.convert_hyp false (id, None, newt))
-	| None, (undef, Some p, newt) ->
-	    let refable = Goal.Refinable.make
-	      (fun handle -> 
-		 Goal.bind env
-		   (fun env -> Goal.bind (Refinable.mkEvar handle env newt)
-		      (fun ev ->
-			 Goal.Refinable.constr_of_open_constr handle true 
-			   (undef, mkApp (p, [| ev |])))))
-	    in
-	      Proofview.tclSENSITIVE (Goal.bind refable Goal.refine)
-	| None, (undef, None, newt) ->
-	    Proofview.tclSENSITIVE (Goal.convert_concl false newt)
-  in
-  let info =
-    bind_gl_info
-      (fun concl env sigma ->
-	 let ty, is_hyp =
-	   match clause with
-	   | Some id -> Environ.named_type id env, Some id
-	   | None -> concl, None
-	 in
-	 let res = 
-	   try cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp 
-	   with
-	   | Loc.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e)))
-	   | TypeClassError (env, (UnsatisfiableConstraints _ as e)) ->
-	       fail 0 (str"setoid rewrite failed: unable to satisfy the rewriting constraints."
-		       ++ fnl () ++ Himsg.explain_typeclass_error env e)
-	 in return (res, is_hyp))
-  in Proofview.tclGOALBINDU info (fun i -> treat i)
-  
-let cl_rewrite_clause_new_strat ?abs strat clause =
-  init_setoid ();
-  cl_rewrite_clause_newtac ?abs strat clause
-
-let cl_rewrite_clause_newtac' l left2right occs clause =
-  Proof_global.run_tactic 
-    (Proofview.tclFOCUS 1 1 
-       (cl_rewrite_clause_new_strat (rewrite_with rewrite_unif_flags l left2right occs) clause))
-
-
-let tactic_init_setoid () = 
-  init_setoid (); tclIDTAC
-
-let cl_rewrite_clause_strat strat clause =
-  tclTHEN (tactic_init_setoid ())
-  (fun gl ->
-   let meta = Evarutil.new_meta() in
-     try cl_rewrite_clause_tac strat (mkMeta meta) clause gl
-     with
-     | Refiner.FailError (n, pp) -> 
-       tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)
-
-let cl_rewrite_clause l left2right occs clause gl =
-  cl_rewrite_clause_strat (rewrite_with (general_rewrite_unif_flags ()) l left2right occs) clause gl
-
-open Pp
-open Pcoq
-open Names
-open Tacexpr
-open Tacinterp
-open Termops
-open Genarg
-open Extraargs
-
-let occurrences_of = function
-  | n::_ as nl when n < 0 -> (false,List.map abs nl)
-  | nl ->
-      if List.exists (fun n -> n < 0) nl then
-	error "Illegal negative occurrence number.";
-      (true,nl)
-
-let apply_constr_expr c l2r occs = fun env avoid t ty cstr evars ->
-  let evd, c = Constrintern.interp_open_constr (goalevars evars) env c in
-    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
-      l2r occs env avoid t ty cstr (evd, cstrevars evars)
-
-let apply_glob_constr c l2r occs = fun env avoid t ty cstr evars ->
-  let evd, c = (Pretyping.Default.understand_tcc (goalevars evars) env c) in
-    apply_lemma (general_rewrite_unif_flags ()) (evd, (c, NoBindings)) 
-      l2r occs env avoid t ty cstr (evd, cstrevars evars)
-
-let interp_constr_list env sigma =
-  List.map (fun c -> 
-	      let evd, c = Constrintern.interp_open_constr sigma env c in
-		(evd, (c, NoBindings)), true)
-
-let interp_glob_constr_list env sigma =
-  List.map (fun c -> 
-	      let evd, c = Pretyping.Default.understand_tcc sigma env c in
-		(evd, (c, NoBindings)), true)
-
-open Pcoq
-
-(* Syntax for rewriting with strategies *)
-
-type constr_expr_with_bindings = constr_expr with_bindings
-type glob_constr_with_bindings = glob_constr_and_expr with_bindings
-type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings
-
-let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
-let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
-let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
-let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
-let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
-let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
-
-
-ARGUMENT EXTEND glob_constr_with_bindings 
-    PRINTED BY pr_glob_constr_with_bindings_sign
-
-    INTERPRETED BY interp_glob_constr_with_bindings
-    GLOBALIZED BY glob_glob_constr_with_bindings
-    SUBSTITUTED BY subst_glob_constr_with_bindings
-
-    RAW_TYPED AS constr_expr_with_bindings
-    RAW_PRINTED BY pr_constr_expr_with_bindings
-
-    GLOB_TYPED AS glob_constr_with_bindings
-    GLOB_PRINTED BY pr_glob_constr_with_bindings
-   
-   [ constr_with_bindings(bl) ] -> [ bl ]
-END
-
-type ('constr,'redexpr) strategy_ast = 
-  | StratId | StratFail | StratRefl
-  | StratUnary of string * ('constr,'redexpr) strategy_ast
-  | StratBinary of string * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
-  | StratConstr of 'constr * bool
-  | StratTerms of 'constr list
-  | StratHints of bool * string
-  | StratEval of 'redexpr 
-  | StratFold of 'constr
-
-let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function
-  | StratId | StratFail | StratRefl as s -> s
-  | StratUnary (s, str) -> StratUnary (s, map_strategy f g str)
-  | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str')
-  | StratConstr (c, b) -> StratConstr (f c, b)
-  | StratTerms l -> StratTerms (List.map f l)
-  | StratHints (b, id) -> StratHints (b, id)
-  | StratEval r -> StratEval (g r)
-  | StratFold c -> StratFold (f c)
-
-let rec strategy_of_ast = function
-  | StratId -> Strategies.id
-  | StratFail -> Strategies.fail
-  | StratRefl -> Strategies.refl
-  | StratUnary (f, s) -> 
-    let s' = strategy_of_ast s in
-    let f' = match f with
-      | "subterms" -> all_subterms
-      | "subterm" -> one_subterm
-      | "innermost" -> Strategies.innermost
-      | "outermost" -> Strategies.outermost
-      | "bottomup" -> Strategies.bu
-      | "topdown" -> Strategies.td
-      | "progress" -> Strategies.progress
-      | "try" -> Strategies.try_
-      | "any" -> Strategies.any
-      | "repeat" -> Strategies.repeat
-      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
-    in f' s'
-  | StratBinary (f, s, t) ->
-    let s' = strategy_of_ast s in
-    let t' = strategy_of_ast t in
-    let f' = match f with
-      | "compose" -> Strategies.seq
-      | "choice" -> Strategies.choice
-      | _ -> anomalylabstrm "strategy_of_ast" (str"Unkwnon strategy: " ++ str f)
-    in f' s' t'
-  | StratConstr (c, b) -> apply_glob_constr (fst c) b all_occurrences
-  | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id
-  | StratTerms l -> 
-    (fun env avoid t ty cstr evars ->
-     let l' = interp_glob_constr_list env (goalevars evars) (List.map fst l) in
-       Strategies.lemmas rewrite_unif_flags l' env avoid t ty cstr evars)
-  | StratEval r -> 
-    (fun env avoid t ty cstr evars ->
-     let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
-       Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars))
-  | StratFold c -> Strategies.fold_glob (fst c)
-
-
-type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast
-type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast
-
-let interp_strategy ist gl s = 
-  let sigma = project gl in
-    sigma, strategy_of_ast s
-let glob_strategy ist s = map_strategy (Tacinterp.intern_constr ist) (fun c -> c) s
-let subst_strategy s str = str
-
-let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
-let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>"
-let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>"
-
-ARGUMENT EXTEND rewstrategy
-    PRINTED BY pr_strategy
-
-    INTERPRETED BY interp_strategy
-    GLOBALIZED BY glob_strategy
-    SUBSTITUTED BY subst_strategy
-
-    RAW_TYPED AS raw_strategy
-    RAW_PRINTED BY pr_raw_strategy
-
-    GLOB_TYPED AS glob_strategy
-    GLOB_PRINTED BY pr_glob_strategy
-
-    [ glob(c) ] -> [ StratConstr (c, true) ]
-  | [ "<-" constr(c) ] -> [ StratConstr (c, false) ]
-  | [ "subterms" rewstrategy(h) ] -> [ StratUnary ("all_subterms", h) ]
-  | [ "subterm" rewstrategy(h) ] -> [ StratUnary ("one_subterm", h) ]
-  | [ "innermost" rewstrategy(h) ] -> [ StratUnary("innermost", h) ]
-  | [ "outermost" rewstrategy(h) ] -> [ StratUnary("outermost", h) ]
-  | [ "bottomup" rewstrategy(h) ] -> [ StratUnary("bottomup", h) ]
-  | [ "topdown" rewstrategy(h) ] -> [ StratUnary("topdown", h) ]
-  | [ "id" ] -> [ StratId ]
-  | [ "fail" ] -> [ StratFail ]
-  | [ "refl" ] -> [ StratRefl ]
-  | [ "progress" rewstrategy(h) ] -> [ StratUnary ("progress", h) ]
-  | [ "try" rewstrategy(h) ] -> [ StratUnary ("try", h) ]
-  | [ "any" rewstrategy(h) ] -> [ StratUnary ("any", h) ]
-  | [ "repeat" rewstrategy(h) ] -> [ StratUnary ("repeat", h) ]
-  | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary ("compose", h, h') ]
-  | [ "(" rewstrategy(h) ")" ] -> [ h ]
-  | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary ("choice", h, h') ]
-  | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ]
-  | [ "hints" preident(h) ] -> [ StratHints (false, h) ]
-  | [ "terms" constr_list(h) ] -> [ StratTerms h ]
-  | [ "eval" red_expr(r) ] -> [ StratEval r ]
-  | [ "fold" constr(c) ] -> [ StratFold c ]
-END
-
-(* By default the strategy for "rewrite_db" is top-down *)
-
-let db_strat db = Strategies.td (Strategies.hints db)
-let cl_rewrite_clause_db db cl = cl_rewrite_clause_strat (db_strat db) cl
-
-TACTIC EXTEND rewrite_strat
-| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ]
-| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ]
-| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ]
-| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ]
-END
-
-let clsubstitute o c =
-  let is_tac id = match fst (fst (snd c)) with GVar (_, id') when id' = id -> true | _ -> false in
-    Tacticals.onAllHypsAndConcl
-      (fun cl ->
-	match cl with
-	  | Some id when is_tac id -> tclIDTAC
-	  | _ -> cl_rewrite_clause c o all_occurrences cl)
-
-open Extraargs
-
-TACTIC EXTEND substitute
-| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ]
-END
-
-
-(* Compatibility with old Setoids *)
-
-TACTIC EXTEND setoid_rewrite
-   [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ]
-   -> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
-      [ cl_rewrite_clause c o all_occurrences (Some id)]
- | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
- | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
-      [ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
-END
-
-let cl_rewrite_clause_newtac_tac c o occ cl gl =
-  cl_rewrite_clause_newtac' c o occ cl;
-  tclIDTAC gl
-  
-TACTIC EXTEND GenRew
-| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] ->
-    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
-| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] ->
-    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) (Some id) ]
-| [ "rew" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] ->
-    [ cl_rewrite_clause_newtac_tac c o all_occurrences (Some id) ]
-| [ "rew" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] ->
-    [ cl_rewrite_clause_newtac_tac c o (occurrences_of occ) None ]
-| [ "rew" orient(o) glob_constr_with_bindings(c) ] ->
-    [ cl_rewrite_clause_newtac_tac c o all_occurrences None ]
-END
-
-let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_string s))),l)
-
-let declare_an_instance n s args =
-  ((dummy_loc,Name n), Explicit,
-  CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)),
-	   args))
-
-let declare_instance a aeq n s = declare_an_instance n s [a;aeq]
-
-let anew_instance global binders instance fields =
-  new_instance binders instance (Some (CRecord (dummy_loc,None,fields)))
-    ~global:(not (Vernacexpr.use_section_locality ())) ~generalize:false None
-
-let declare_instance_refl global binders a aeq n lemma =
-  let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive"
-  in anew_instance global binders instance
-       [(Ident (dummy_loc,id_of_string "reflexivity"),lemma)]
-
-let declare_instance_sym global binders a aeq n lemma =
-  let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric"
-  in anew_instance global binders instance
-       [(Ident (dummy_loc,id_of_string "symmetry"),lemma)]
-
-let declare_instance_trans global binders a aeq n lemma =
-  let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive"
-  in anew_instance global binders instance
-       [(Ident (dummy_loc,id_of_string "transitivity"),lemma)]
-
-let declare_relation ?(binders=[]) a aeq n refl symm trans =
-  init_setoid ();
-  let global = not (Vernacexpr.use_section_locality ()) in
-  let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation"
-  in ignore(anew_instance global binders instance []);
-  match (refl,symm,trans) with
-      (None, None, None) -> ()
-    | (Some lemma1, None, None) ->
-	ignore (declare_instance_refl global binders a aeq n lemma1)
-    | (None, Some lemma2, None) ->
-	ignore (declare_instance_sym global binders a aeq n lemma2)
-    | (None, None, Some lemma3) ->
-	ignore (declare_instance_trans global binders a aeq n lemma3)
-    | (Some lemma1, Some lemma2, None) ->
-	ignore (declare_instance_refl global binders a aeq n lemma1);
-	ignore (declare_instance_sym global binders a aeq n lemma2)
-    | (Some lemma1, None, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
-	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder"
-	in ignore(
-	    anew_instance global binders instance
-	      [(Ident (dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1);
-	       (Ident (dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)])
-    | (None, Some lemma2, Some lemma3) ->
-	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER"
-	in ignore(
-	    anew_instance global binders instance
-	      [(Ident (dummy_loc,id_of_string "PER_Symmetric"), lemma2);
-	       (Ident (dummy_loc,id_of_string "PER_Transitive"),lemma3)])
-     | (Some lemma1, Some lemma2, Some lemma3) ->
-	let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in
-	let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in
-	let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in
-	let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
-	in ignore(
-	  anew_instance global binders instance
-	    [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1);
-	     (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
-	     (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
-
-type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
-
-let _, _, rawwit_binders =
- (Genarg.create_arg None "binders" :
-    Genarg.tlevel binders_argtype *
-    Genarg.glevel binders_argtype *
-    Genarg.rlevel binders_argtype)
-
-open Pcoq.Constr
-
-VERNAC COMMAND EXTEND AddRelation
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ]
-
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-	"as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None None ]
-  | [ "Add" "Relation" constr(a) constr(aeq)  "as" ident(n) ] ->
-      [ declare_relation a aeq n None None None ]
-END
-
-VERNAC COMMAND EXTEND AddRelation2
-    [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) None ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddRelation3
-    [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
-      "as" ident(n) ] ->
-      [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
-  | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->
-      [ declare_relation a aeq n None None (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1)
-	"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
-	"reflexivity" "proved" "by" constr(lemma1)
-	"as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)  "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None None None ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation2
-    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)  "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
-END
-
-VERNAC COMMAND EXTEND AddParametricRelation3
-    [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
-      "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
-      "as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
-  | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
-	"as" ident(n) ] ->
-      [ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
-END
-
-let cHole = CHole (dummy_loc, None)
-
-open Entries
-open Libnames
-
-let proper_projection r ty =
-  let ctx, inst = decompose_prod_assum ty in
-  let mor, args = destApp inst in
-  let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in
-  let app = mkApp (Lazy.force proper_proj,
-		  Array.append args [| instarg |]) in
-    it_mkLambda_or_LetIn app ctx
-
-let declare_projection n instance_id r =
-  let ty = Global.type_of_global r in
-  let c = constr_of_global r in
-  let term = proper_projection c ty in
-  let typ = Typing.type_of (Global.env ()) Evd.empty term in
-  let ctx, typ = decompose_prod_assum typ in
-  let typ =
-    let n =
-      let rec aux t =
-	match kind_of_term t with
-	    App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) ->
-	      succ (aux rel')
-	  | _ -> 0
-      in
-      let init =
-	match kind_of_term typ with
-	    App (f, args) when eq_constr f (Lazy.force respectful) ->
-	      mkApp (f, fst (array_chop (Array.length args - 2) args))
-	  | _ -> typ
-      in aux init
-    in
-    let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ
-    in it_mkProd_or_LetIn ccl ctx
-  in
-  let typ = it_mkProd_or_LetIn typ ctx in
-  let cst =
-    { const_entry_body = term;
-      const_entry_secctx = None;
-      const_entry_type = Some typ;
-      const_entry_opaque = false }
-  in
-    ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition))
-
-let build_morphism_signature m =
-  let env = Global.env () in
-  let m = Constrintern.interp_constr Evd.empty env m in
-  let t = Typing.type_of env Evd.empty m in
-  let isevars = ref (Evd.empty, Evd.empty) in
-  let cstrs =
-    let rec aux t =
-      match kind_of_term t with
-	| Prod (na, a, b) ->
-	    None :: aux b
-	| _ -> []
-    in aux t
-  in
-  let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None in
-  let _ = isevars := evars in
-  let _ = List.iter
-    (fun (ty, rel) ->
-      Option.iter (fun rel ->
-	let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in
-	let evars,c = new_cstr_evar !isevars env default in
-	  isevars := evars)
-	rel)
-    cstrs
-  in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sig_; m |])
-  in
-  let evd = solve_constraints env !isevars in
-  let m = Evarutil.nf_evar evd morph in
-    Evarutil.check_evars env Evd.empty evd m; m
-
-let default_morphism sign m =
-  let env = Global.env () in
-  let t = Typing.type_of env Evd.empty m in
-  let evars, _, sign, cstrs =
-    build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign)
-  in
-  let morph =
-    mkApp (Lazy.force proper_type, [| t; sign; m |])
-  in
-  let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in
-    mor, proper_projection mor morph
-
-let add_setoid global binders a aeq t n =
-  init_setoid ();
-  let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
-  let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
-  let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in
-  let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence"
-  in ignore(
-    anew_instance global binders instance
-      [(Ident (dummy_loc,id_of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]);
-       (Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]);
-       (Ident (dummy_loc,id_of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])])
-
-let add_morphism_infer glob m n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Proper" in
-  let instance = build_morphism_signature m in
-    if Lib.is_modtype () then
-      let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id
-				(Entries.ParameterEntry (None,instance,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
-      in
-	add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob (ConstRef cst));
-	declare_projection n instance_id (ConstRef cst)
-    else
-      let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
-	Flags.silently
-	  (fun () ->
-	    Lemmas.start_proof instance_id kind instance
-	      (fun _ -> function
-		Libnames.ConstRef cst ->
-		  add_instance (Typeclasses.new_instance (Lazy.force proper_class) None
-				   glob (ConstRef cst));
-		  declare_projection n instance_id (ConstRef cst)
-		| _ -> assert false);
-	    Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) ();
-	Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) ()
-
-let add_morphism glob binders m s n =
-  init_setoid ();
-  let instance_id = add_suffix n "_Proper" in
-  let instance =
-    ((dummy_loc,Name instance_id), Explicit,
-    CAppExpl (dummy_loc,
-	     (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")),
-	     [cHole; s; m]))
-  in
-  let tac = Tacinterp.interp <:tactic<add_morphism_tactic>> in
-    ignore(new_instance ~global:glob binders instance (Some (CRecord (dummy_loc,None,[])))
-	      ~generalize:false ~tac ~hook:(declare_projection n instance_id) None)
-
-VERNAC COMMAND EXTEND AddSetoid1
-   [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [ add_setoid (not (Vernacexpr.use_section_locality ())) [] a aeq t n ]
-  | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
-     [	add_setoid (not (Vernacexpr.use_section_locality ())) binders a aeq t n ]
-  | [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
-      [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ]
-  | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
-      [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ]
-  | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
-	"with" "signature" lconstr(s) "as" ident(n) ] ->
-      [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ]
-END
-
-(** Bind to "rewrite" too *)
-
-(** Taken from original setoid_replace, to emulate the old rewrite semantics where
-    lemmas are first instantiated and then rewrite proceeds. *)
-
-let check_evar_map_of_evars_defs evd =
- let metas = Evd.meta_list evd in
- let check_freemetas_is_empty rebus =
-  Evd.Metaset.iter
-   (fun m ->
-     if Evd.meta_defined evd m then () else
-      raise
-	(Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m])))
- in
-  List.iter
-   (fun (_,binding) ->
-     match binding with
-        Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) ->
-         check_freemetas_is_empty rebus freemetas
-      | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_),
-                 {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) ->
-         check_freemetas_is_empty rebus1 freemetas1 ;
-         check_freemetas_is_empty rebus2 freemetas2
-   ) metas
-
-let unification_rewrite flags l2r c1 c2 cl car rel but gl =
-  let env = pf_env gl in
-  let (evd',c') =
-    try
-      (* ~flags:(false,true) to allow to mark occurrences that must not be
-         rewritten simply by replacing them with let-defined definitions
-         in the context *)
-      Unification.w_unify_to_subterm ~flags:rewrite_unif_flags env cl.evd ((if l2r then c1 else c2),but)
-    with
-	Pretype_errors.PretypeError _ ->
-	  (* ~flags:(true,true) to make Ring work (since it really
-             exploits conversion) *)
-	  Unification.w_unify_to_subterm ~flags:flags
-	    env cl.evd ((if l2r then c1 else c2),but)
-  in
-  let evd' = Typeclasses.resolve_typeclasses ~fail:false env evd' in
-  let cl' = {cl with evd = evd'} in
-  let cl' = Clenvtac.clenv_pose_dependent_evars true cl' in
-  let nf c = Evarutil.nf_evar cl'.evd (Clenv.clenv_nf_meta cl' c) in
-  let c1 = if l2r then nf c' else nf c1
-  and c2 = if l2r then nf c2 else nf c'
-  and car = nf car and rel = nf rel in
-  check_evar_map_of_evars_defs cl'.evd;
-  let prf = nf (Clenv.clenv_value cl') and prfty = nf (Clenv.clenv_type cl') in
-  let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
-    {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty);
-     flags = flags}
-
-let get_hyp gl evars (c,l) clause l2r =
-  let flags = rewrite2_unif_flags in
-  let hi = decompose_applied_relation (pf_env gl) evars flags None (c,l) l2r in
-  let but = match clause with
-    | Some id -> pf_get_hyp_typ gl id 
-    | None -> Evarutil.nf_evar evars (pf_concl gl)
-  in
-    { unification_rewrite flags hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl with
-	flags = rewrite_unif_flags }
-
-let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
-
-let apply_lemma gl (c,l) cl l2r occs =
-  let sigma = project gl in
-  let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in
-  let app = apply_rule hypinfo occs in
-  let rec aux () =
-    Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env))
-  in !hypinfo, aux ()
-
-let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
-  let meta = Evarutil.new_meta() in
-  let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in
-    tclWEAK_PROGRESS 
-      (tclTHEN
-       (Refiner.tclEVARS hypinfo.cl.evd)
-       (cl_rewrite_clause_tac ~abs:hypinfo.abs strat (mkMeta meta) cl)) gl
-
-let general_s_rewrite_clause x =
-  init_setoid ();
-  match x with
-    | None -> general_s_rewrite None
-    | Some id -> general_s_rewrite (Some id)
-
-let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause
-
-(** [setoid_]{reflexivity,symmetry,transitivity} tactics *)
-
-let not_declared env ty rel =
-  tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++
-		str ty ++ str" relation. Maybe you need to require the Setoid library")
-
-let setoid_proof gl ty fn fallback =
-  let env = pf_env gl in
-    try
-      let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
-      let evm = project gl in
-      let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
-	fn env evm car rel gl
-    with e when Errors.noncritical e ->
-      try fallback gl
-      with Hipattern.NoEquationFound ->
-	  match e with
-	  | Not_found ->
-	      let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
-		not_declared env ty rel gl
-	  | _ -> raise e
-
-let setoid_reflexivity gl =
-  setoid_proof gl "reflexive"
-    (fun env evm car rel -> apply (get_reflexive_proof env evm car rel))
-    (reflexivity_red true)
-
-let setoid_symmetry gl =
-  setoid_proof gl "symmetric"
-    (fun env evm car rel -> apply (get_symmetric_proof env evm car rel))
-    (symmetry_red true)
-
-let setoid_transitivity c gl =
-  setoid_proof gl "transitive"
-    (fun env evm car rel ->
-      let proof = get_transitive_proof env evm car rel in
-      match c with
-      | None -> eapply proof
-      | Some c -> apply_with_bindings (proof,Glob_term.ImplicitBindings [ c ]))
-    (transitivity_red true c)
-
-let setoid_symmetry_in id gl =
-  let ctype = pf_type_of gl (mkVar id) in
-  let binders,concl = decompose_prod_assum ctype in
-  let (equiv, args) = decompose_app concl in
-  let rec split_last_two = function
-    | [c1;c2] -> [],(c1, c2)
-    | x::y::z -> let l,res = split_last_two (y::z) in x::l, res
-    | _ -> error "The term provided is not an equivalence."
-  in
-  let others,(c1,c2) = split_last_two args in
-  let he,c1,c2 =  mkApp (equiv, Array.of_list others),c1,c2 in
-  let new_hyp' =  mkApp (he, [| c2 ; c1 |]) in
-  let new_hyp = it_mkProd_or_LetIn new_hyp'  binders in
-    tclTHENS (Tactics.cut new_hyp)
-      [ intro_replacing id;
-	tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ] ]
-      gl
-
-let _ = Tactics.register_setoid_reflexivity setoid_reflexivity
-let _ = Tactics.register_setoid_symmetry setoid_symmetry
-let _ = Tactics.register_setoid_symmetry_in setoid_symmetry_in
-let _ = Tactics.register_setoid_transitivity setoid_transitivity
-
-TACTIC EXTEND setoid_symmetry
-   [ "setoid_symmetry" ] -> [ setoid_symmetry ]
- | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ]
-END
-
-TACTIC EXTEND setoid_reflexivity
-[ "setoid_reflexivity" ] -> [ setoid_reflexivity ]
-END
-
-TACTIC EXTEND setoid_transitivity
-  [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ]
-| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ]
-END
-
-let implify id gl =
-  let (_, b, ctype) = pf_get_hyp gl id in
-  let binders,concl = decompose_prod_assum ctype in
-  let ctype' =
-    match binders with
-    | (_, None, ty as hd) :: tl when noccurn 1 concl ->
-	let env = Environ.push_rel_context tl (pf_env gl) in
-	let sigma = project gl in
-	let tyhd = Typing.type_of env sigma ty
-	and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in
-	let app, unfold = arrow_morphism tyhd (subst1 mkProp tyconcl) ty (subst1 mkProp concl) in
-	  it_mkProd_or_LetIn app tl
-    | _ -> ctype
-  in convert_hyp_no_check (id, b, ctype') gl
-
-TACTIC EXTEND implify
-[ "implify" hyp(n) ] -> [ implify n ]
-END
-
-let rec fold_matches env sigma c =
-  map_constr_with_full_binders Environ.push_rel 
-    (fun env c ->
-      match kind_of_term c with
-      | Case _ ->
-          let cst, env, c' = fold_match ~force:true env sigma c in
-	    fold_matches env sigma c'
-      | _ -> fold_matches env sigma c)
-    env c
-
-TACTIC EXTEND fold_match
-[ "fold_match" constr(c) ] -> [ fun gl -> 
-  let _, _, c' = fold_match ~force:true (pf_env gl) (project gl) c in
-    change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
-END
-
-TACTIC EXTEND fold_matches
-| [ "fold_matches" constr(c) ] -> [ fun gl -> 
-  let c' = fold_matches (pf_env gl) (project gl) c in
-    change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
-END
-
-TACTIC EXTEND myapply
-| [ "myapply" global(id) constr_list(l) ] -> [ 
-    fun gl -> 
-      let gr = id in
-      let _, impls = List.hd (Impargs.implicits_of_global gr) in
-      let ty = Global.type_of_global gr in
-      let env = pf_env gl in
-      let evars = ref (project gl) in
-      let app =
-	let rec aux ty impls args args' =
-	  match impls, kind_of_term ty with
-	  | Some (_, _, (_, _)) :: impls, Prod (n, t, t') ->
-	      let arg = Evarutil.e_new_evar evars env t in
-		aux (subst1 arg t') impls args (arg :: args')
-	  | None :: impls, Prod (n, t, t') ->
-	      (match args with
-	       | [] ->
-		   if dependent (mkRel 1) t' then
-		     let arg = Evarutil.e_new_evar evars env t in
-		       aux (subst1 arg t') impls args (arg :: args')
-		   else
-		     let arg = Evarutil.mk_new_meta () in
-		       evars := meta_declare (destMeta arg) t !evars;
-		       aux (subst1 arg t') impls args (arg :: args')
-	       | arg :: args -> 
-		   aux (subst1 arg t') impls args (arg :: args'))
-	  | _, _ -> mkApp (constr_of_global gr, Array.of_list (List.rev args'))
-	in aux ty impls l []
-      in
-	tclTHEN (Refiner.tclEVARS !evars) (apply app) gl ]
-END
diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli
new file mode 100644
index 00000000..cae00f5a
--- /dev/null
+++ b/tactics/rewrite.mli
@@ -0,0 +1,117 @@
+(************************************************************************)
+(*  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 Names
+open Constr
+open Environ
+open Constrexpr
+open Tacexpr
+open Misctypes
+open Evd
+open Proof_type
+open Tacinterp
+
+(** TODO: document and clean me! *)
+
+type unary_strategy = 
+    Subterms | Subterm | Innermost | Outermost
+  | Bottomup | Topdown | Progress | Try | Any | Repeat
+
+type binary_strategy = 
+  | Compose | Choice
+
+type ('constr,'redexpr) strategy_ast = 
+  | StratId | StratFail | StratRefl
+  | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast
+  | StratBinary of binary_strategy 
+    * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast
+  | StratConstr of 'constr * bool
+  | StratTerms of 'constr list
+  | StratHints of bool * string
+  | StratEval of 'redexpr 
+  | StratFold of 'constr
+
+type rewrite_proof = 
+  | RewPrf of constr * constr
+  | RewCast of cast_kind
+
+type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *)
+
+type rewrite_result_info = {
+  rew_car : constr;
+  rew_from : constr;
+  rew_to : constr;
+  rew_prf : rewrite_proof;
+  rew_evars : evars;
+}
+
+type rewrite_result =
+| Fail
+| Identity
+| Success of rewrite_result_info
+
+type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types ->
+  (bool (* prop *) * constr option) -> evars -> 'a * rewrite_result
+
+type strategy = unit pure_strategy
+
+val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy
+
+val map_strategy : ('a -> 'b) -> ('c -> 'd) ->
+  ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast
+
+(** Entry point for user-level "rewrite_strat" *)
+val cl_rewrite_clause_strat : strategy -> Id.t option -> tactic
+
+(** Entry point for user-level "setoid_rewrite" *)
+val cl_rewrite_clause :
+  interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) ->
+  bool -> Locus.occurrences -> Id.t option -> tactic
+
+val is_applied_rewrite_relation :
+  env -> evar_map -> Context.rel_context -> constr -> types option
+
+val declare_relation :
+  ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t ->
+  constr_expr option -> constr_expr option -> constr_expr option -> unit
+
+val add_setoid :
+  bool -> local_binder list -> constr_expr -> constr_expr -> constr_expr ->
+  Id.t -> unit
+
+val add_morphism_infer : bool -> constr_expr -> Id.t -> unit
+
+val add_morphism :
+  bool -> local_binder list -> constr_expr -> constr_expr -> Id.t -> unit
+
+val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr
+
+val default_morphism :
+  (types * constr option) option list * (types * types option) option ->
+  constr -> constr * constr
+
+val setoid_symmetry : unit Proofview.tactic
+
+val setoid_symmetry_in : Id.t -> unit Proofview.tactic
+
+val setoid_reflexivity : unit Proofview.tactic
+
+val setoid_transitivity : constr option -> unit Proofview.tactic
+
+
+val apply_strategy :
+  strategy ->
+  Environ.env ->
+  Names.Id.t list ->
+  Term.constr ->
+  bool * Term.constr ->
+  evars -> rewrite_result
diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml
new file mode 100644
index 00000000..215713d9
--- /dev/null
+++ b/tactics/taccoerce.ml
@@ -0,0 +1,269 @@
+(************************************************************************)
+(*  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 Util
+open Names
+open Term
+open Pattern
+open Misctypes
+open Genarg
+open Stdarg
+open Constrarg
+
+exception CannotCoerceTo of string
+
+let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) =
+  Genarg.create_arg None "constr_context"
+
+(* includes idents known to be bound and references *)
+let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) =
+  Genarg.create_arg None "constr_under_binders"
+
+module Value =
+struct
+
+type t = tlevel generic_argument
+
+let rec normalize v =
+  if has_type v (topwit wit_genarg) then
+    normalize (out_gen (topwit wit_genarg) v)
+  else v
+
+let of_constr c = in_gen (topwit wit_constr) c
+
+let to_constr v =
+  let v = normalize v in
+  if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    Some c
+  else if has_type v (topwit wit_constr_under_binders) then
+    let vars, c = out_gen (topwit wit_constr_under_binders) v in
+    match vars with [] -> Some c | _ -> None
+  else None
+
+let of_uconstr c = in_gen (topwit wit_uconstr) c
+
+let to_uconstr v =
+  let v = normalize v in
+  if has_type v (topwit wit_uconstr) then
+    Some (out_gen (topwit wit_uconstr) v)
+  else None
+
+let of_int i = in_gen (topwit wit_int) i
+
+let to_int v =
+  let v = normalize v in
+  if has_type v (topwit wit_int) then
+    Some (out_gen (topwit wit_int) v)
+  else None
+
+let to_list v =
+  let v = normalize v in
+  let list_unpacker wit l = List.map (fun v -> in_gen (topwit wit) v) (top l) in
+  try Some (list_unpack { list_unpacker } v)
+  with Failure _ -> None
+
+end
+
+let is_variable env id =
+  Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env))
+
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
+
+(* Gives the constr corresponding to a Constr_context tactic_arg *)
+let coerce_to_constr_context v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_constr_context) then
+    out_gen (topwit wit_constr_context) v
+  else raise (CannotCoerceTo "a term context")
+
+(* Interprets an identifier which must be fresh *)
+let coerce_to_ident fresh env v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a fresh identifier") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    out_gen (topwit wit_var) v
+  else match Value.to_constr v with
+  | None -> fail ()
+  | Some c ->
+    (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
+    if isVar c && not (fresh && is_variable env (destVar c)) then
+      destVar c
+    else fail ()
+
+let coerce_to_intro_pattern env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    snd (out_gen (topwit wit_intro_pattern) v)
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    IntroNaming (IntroIdentifier id)
+  else match Value.to_constr v with
+  | Some c when isVar c ->
+      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
+      (* but also in "destruct H as (H,H')" *)
+      IntroNaming (IntroIdentifier (destVar c))
+  | _ -> raise (CannotCoerceTo "an introduction pattern")
+
+let coerce_to_intro_pattern_naming env v =
+  match coerce_to_intro_pattern env v with
+  | IntroNaming pat -> pat
+  | _ -> raise (CannotCoerceTo "a naming introduction pattern")
+
+let coerce_to_hint_base v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) -> Id.to_string id
+    | _ -> raise (CannotCoerceTo "a hint base name")
+  else raise (CannotCoerceTo "a hint base name")
+
+let coerce_to_int v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    out_gen (topwit wit_int) v
+  else raise (CannotCoerceTo "an integer")
+
+let coerce_to_constr env v =
+  let v = Value.normalize v in
+  let fail () = raise (CannotCoerceTo "a term") in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) ->
+      (try ([], constr_of_id env id) with Not_found -> fail ())
+    | _ -> fail ()
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    ([], c)
+  else if has_type v (topwit wit_constr_under_binders) then
+    out_gen (topwit wit_constr_under_binders) v
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    (try [], constr_of_id env id with Not_found -> fail ())
+  else fail ()
+
+let coerce_to_uconstr env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_uconstr) then
+    out_gen (topwit wit_uconstr) v
+  else
+    raise (CannotCoerceTo "an untyped term")
+
+let coerce_to_closed_constr env v =
+  let ids,c = coerce_to_constr env v in
+  let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in
+  c
+
+let coerce_to_evaluable_ref env v =
+  let fail () = raise (CannotCoerceTo "an evaluable reference") in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id
+    else fail ()
+  else
+    let ev = match Value.to_constr v with
+    | Some c when isConst c -> EvalConstRef (Univ.out_punivs (destConst c))
+    | Some c when isVar c -> EvalVarRef (destVar c)
+    | _ -> fail ()
+    in
+    if Tacred.is_evaluable env ev then ev else fail ()
+
+let coerce_to_constr_list env v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map v = coerce_to_closed_constr env v in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a term list")
+
+let coerce_to_intro_pattern_list loc env v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an intro pattern list")
+  | Some l ->
+    let map v = (loc, coerce_to_intro_pattern env v) in
+    List.map map l
+
+let coerce_to_hyp env v =
+  let fail () = raise (CannotCoerceTo "a variable") in
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    match out_gen (topwit wit_intro_pattern) v with
+    | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id
+    | _ -> fail ()
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    if is_variable env id then id else fail ()
+  else match Value.to_constr v with
+  | Some c when isVar c -> destVar c
+  | _ -> fail ()
+
+let coerce_to_hyp_list env v =
+  let v = Value.to_list v in
+  match v with
+  | Some l ->
+    let map n = coerce_to_hyp env n in
+    List.map map l
+  | None -> raise (CannotCoerceTo "a variable list")
+
+(* Interprets a qualified name *)
+let coerce_to_reference env v =
+  let v = Value.normalize v in
+  match Value.to_constr v with
+  | Some c ->
+    begin
+      try Globnames.global_of_constr c
+      with Not_found -> raise (CannotCoerceTo "a reference")
+    end
+  | None -> raise (CannotCoerceTo "a reference")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_quantified_hypothesis v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_intro_pattern) then
+    let v = out_gen (topwit wit_intro_pattern) v in
+    match v with
+    | _, IntroNaming (IntroIdentifier id) -> NamedHyp id
+    | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+  else if has_type v (topwit wit_var) then
+    let id = out_gen (topwit wit_var) v in
+    NamedHyp id
+  else if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else match Value.to_constr v with
+  | Some c when isVar c -> NamedHyp (destVar c)
+  | _ -> raise (CannotCoerceTo "a quantified hypothesis")
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let coerce_to_decl_or_quant_hyp env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_int) then
+    AnonHyp (out_gen (topwit wit_int) v)
+  else
+    try coerce_to_quantified_hypothesis v
+    with CannotCoerceTo _ ->
+      raise (CannotCoerceTo "a declared or quantified hypothesis")
+
+let coerce_to_int_or_var_list v =
+  match Value.to_list v with
+  | None -> raise (CannotCoerceTo "an int list")
+  | Some l ->
+    let map n = ArgArg (coerce_to_int n) in
+    List.map map l
diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli
new file mode 100644
index 00000000..85bad364
--- /dev/null
+++ b/tactics/taccoerce.mli
@@ -0,0 +1,95 @@
+(************************************************************************)
+(*  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 Util
+open Names
+open Term
+open Misctypes
+open Pattern
+open Genarg
+
+(** Coercions from highest level generic arguments to actual data used by Ltac
+    interpretation. Those functions examinate dynamic types and try to return
+    something sensible according to the object content. *)
+
+exception CannotCoerceTo of string
+(** Exception raised whenever a coercion failed. *)
+
+(** {5 High-level access to values}
+
+  The [of_*] functions cast a given argument into a value. The [to_*] do the
+  converse, and return [None] if there is a type mismatch.
+
+*)
+
+module Value :
+sig
+  type t = tlevel generic_argument
+  (** Tactics manipulate [tlevel generic_argument]. *)
+
+  val normalize : t -> t
+  (** Eliminated the leading dynamic type casts. *)
+
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_uconstr : Glob_term.closed_glob_constr -> t
+  val to_uconstr : t -> Glob_term.closed_glob_constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+end
+
+(** {5 Coercion functions} *)
+
+val coerce_to_constr_context : Value.t -> constr
+
+val coerce_to_ident : bool -> Environ.env -> Value.t -> Id.t
+
+val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr
+
+val coerce_to_intro_pattern_naming :
+  Environ.env -> Value.t -> intro_pattern_naming_expr
+
+val coerce_to_intro_pattern_naming :
+  Environ.env -> Value.t -> intro_pattern_naming_expr
+
+val coerce_to_hint_base : Value.t -> string
+
+val coerce_to_int : Value.t -> int
+
+val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders
+
+val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr
+
+val coerce_to_closed_constr : Environ.env -> Value.t -> constr
+
+val coerce_to_evaluable_ref :
+  Environ.env -> Value.t -> evaluable_global_reference
+
+val coerce_to_constr_list : Environ.env -> Value.t -> constr list
+
+val coerce_to_intro_pattern_list :
+  Loc.t -> Environ.env -> Value.t -> Tacexpr.intro_patterns
+
+val coerce_to_hyp : Environ.env -> Value.t -> Id.t
+
+val coerce_to_hyp_list : Environ.env -> Value.t -> Id.t list
+
+val coerce_to_reference : Environ.env -> Value.t -> Globnames.global_reference
+
+val coerce_to_quantified_hypothesis : Value.t -> quantified_hypothesis
+
+val coerce_to_decl_or_quant_hyp : Environ.env -> Value.t -> quantified_hypothesis
+
+val coerce_to_int_or_var_list : Value.t -> int or_var list
+
+(** {5 Missing generic arguments} *)
+
+val wit_constr_context : (Empty.t, Empty.t, constr) genarg_type
+
+val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type
diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml
new file mode 100644
index 00000000..cb20fc93
--- /dev/null
+++ b/tactics/tacenv.ml
@@ -0,0 +1,128 @@
+(************************************************************************)
+(*  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 Util
+open Genarg
+open Pp
+open Names
+open Tacexpr
+
+(** Tactic notations (TacAlias) *)
+
+type alias = KerName.t
+
+let alias_map = Summary.ref ~name:"tactic-alias"
+  (KNmap.empty : glob_tactic_expr KNmap.t)
+
+let register_alias key tac =
+  alias_map := KNmap.add key tac !alias_map
+
+let interp_alias key =
+  try KNmap.find key !alias_map
+  with Not_found -> Errors.anomaly (str "Unknown tactic alias: " ++ KerName.print key)
+
+(** ML tactic extensions (TacML) *)
+
+type ml_tactic =
+  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+
+module MLName =
+struct
+  type t = ml_tactic_name
+  let compare tac1 tac2 =
+    let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in
+    if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin
+    else c
+end
+
+module MLTacMap = Map.Make(MLName)
+
+let pr_tacname t =
+  t.mltac_plugin ^ "::" ^ t.mltac_tactic
+
+let tac_tab = ref MLTacMap.empty
+
+let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) =
+  let () =
+    if MLTacMap.mem s !tac_tab then
+      if overwrite then
+        let () = tac_tab := MLTacMap.remove s !tac_tab in
+        msg_warning (str ("Overwriting definition of tactic " ^ pr_tacname s))
+      else
+        Errors.anomaly (str ("Cannot redeclare tactic " ^ pr_tacname s ^ "."))
+  in
+  tac_tab := MLTacMap.add s t !tac_tab
+
+let interp_ml_tactic s =
+  try
+    MLTacMap.find s !tac_tab
+  with Not_found ->
+    Errors.errorlabstrm ""
+      (str "The tactic " ++ str (pr_tacname s) ++ str " is not installed.")
+
+(***************************************************************************)
+(* Tactic registration *)
+
+(* Summary and Object declaration *)
+
+open Nametab
+open Libnames
+open Libobject
+
+let mactab =
+  Summary.ref (KNmap.empty : (bool * glob_tactic_expr) KNmap.t)
+    ~name:"tactic-definition"
+
+let interp_ltac r = snd (KNmap.find r !mactab)
+
+let is_ltac_for_ml_tactic r = fst (KNmap.find r !mactab)
+
+(* Declaration of the TAC-DEFINITION object *)
+let add (kn,td) = mactab := KNmap.add kn td !mactab
+let replace (kn,td) = mactab := KNmap.add kn td !mactab
+
+let load_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Until i) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let open_md i ((sp, kn), (local, id, b, t)) = match id with
+| None ->
+  let () = if not local then Nametab.push_tactic (Exactly i) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let cache_md ((sp, kn), (local, id ,b, t)) = match id with
+| None ->
+  let () = Nametab.push_tactic (Until 1) sp kn in
+  add (kn, (b,t))
+| Some kn -> add (kn, (b,t))
+
+let subst_kind subst id = match id with
+| None -> None
+| Some kn -> Some (Mod_subst.subst_kn subst kn)
+
+let subst_md (subst, (local, id, b, t)) =
+  (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t)
+
+let classify_md (local, _, _, _ as o) = Substitute o
+
+let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj =
+  declare_object {(default_object "TAC-DEFINITION") with
+     cache_function  = cache_md;
+     load_function   = load_md;
+     open_function   = open_md;
+     subst_function = subst_md;
+     classify_function = classify_md}
+
+let register_ltac for_ml local id tac =
+  ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac)))
+
+let redefine_ltac local kn tac =
+  Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac))
diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli
new file mode 100644
index 00000000..29677fd4
--- /dev/null
+++ b/tactics/tacenv.mli
@@ -0,0 +1,55 @@
+(************************************************************************)
+(*  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 Genarg
+open Names
+open Tacexpr
+
+(** This module centralizes the various ways of registering tactics. *)
+
+(** {5 Tactic notations} *)
+
+type alias = KerName.t
+(** Type of tactic alias, used in the [TacAlias] node. *)
+
+val register_alias : alias -> glob_tactic_expr -> unit
+(** Register a tactic alias. *)
+
+val interp_alias : alias -> glob_tactic_expr
+(** Recover the the body of an alias. Raises an anomaly if it does not exist. *)
+
+(** {5 Coq tactic definitions} *)
+
+val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit
+(** Register a new Ltac with the given name and body.
+
+    The first boolean indicates whether this is done from ML side, rather than
+    Coq side. If the second boolean flag is set to true, then this is a local
+    definition. It also puts the Ltac name in the nametab, so that it can be
+    used unqualified. *)
+
+val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit
+(** Replace a Ltac with the given name and body. If the boolean flag is set
+    to true, then this is a local redefinition. *)
+
+val interp_ltac : KerName.t -> glob_tactic_expr
+(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *)
+
+val is_ltac_for_ml_tactic : KerName.t -> bool
+
+(** {5 ML tactic extensions} *)
+
+type ml_tactic =
+  typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic
+(** Type of external tactics, used by [TacML]. *)
+
+val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic -> unit
+(** Register an external tactic. *)
+
+val interp_ml_tactic : ml_tactic_name -> ml_tactic
+(** Get the named tactic. Raises a user error if it does not exist. *)
diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml
new file mode 100644
index 00000000..c8b9a208
--- /dev/null
+++ b/tactics/tacintern.ml
@@ -0,0 +1,867 @@
+(************************************************************************)
+(*  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 Pattern
+open Pp
+open Genredexpr
+open Glob_term
+open Tacred
+open Errors
+open Util
+open Names
+open Nameops
+open Libnames
+open Globnames
+open Nametab
+open Smartlocate
+open Constrexpr
+open Termops
+open Tacexpr
+open Genarg
+open Constrarg
+open Misctypes
+open Locus
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+let dloc = Loc.ghost
+
+let error_global_not_found_loc (loc,qid) =
+  error_global_not_found_loc loc qid
+
+let error_syntactic_metavariables_not_allowed loc =
+  user_err_loc
+    (loc,"out_ident",
+     str "Syntactic metavariables allowed only in quotations.")
+
+let error_tactic_expected loc =
+  user_err_loc (loc,"",str "Tactic expected.")
+
+(** Generic arguments *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
+  ltacrecvars : ltac_constant Id.Map.t;
+     (* ltac recursive names *)
+  genv : Environ.env }
+
+let fully_empty_glob_sign =
+  { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty; genv = Environ.empty_env }
+
+let make_empty_glob_sign () =
+  { fully_empty_glob_sign with genv = Global.env () }
+
+(* We have identifier <| global_reference <| constr *)
+
+let find_ident id ist =
+  Id.Set.mem id ist.ltacvars ||
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+let find_recvar qid ist = Id.Map.find qid ist.ltacrecvars
+
+(* a "var" is a ltac var or a var introduced by an intro tactic *)
+let find_var id ist = Id.Set.mem id ist.ltacvars
+
+let find_hyp id ist =
+  Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+
+(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
+(* be fresh in which case it is binding later on *)
+let intern_ident s ist id =
+  (* We use identifier both for variables and new names; thus nothing to do *)
+  if not (find_ident id ist) then s := Id.Set.add id !s;
+  id
+
+let intern_name l ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (intern_ident l ist id)
+
+let strict_check = ref false
+
+let adjust_loc loc = if !strict_check then dloc else loc
+
+(* Globalize a name which must be bound -- actually just check it is bound *)
+let intern_hyp ist (loc,id as locid) =
+  if not !strict_check then
+    locid
+  else if find_ident id ist then
+    (dloc,id)
+  else
+    Pretype_errors.error_var_not_found_loc loc id
+
+let intern_or_var f ist = function
+  | ArgVar locid -> ArgVar (intern_hyp ist locid)
+  | ArgArg x -> ArgArg (f x)
+
+let intern_int_or_var = intern_or_var (fun (n : int) -> n)
+let intern_id_or_var = intern_or_var (fun (id : Id.t) -> id)
+let intern_string_or_var = intern_or_var (fun (s : string) -> s)
+
+let intern_global_reference ist = function
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      try ArgArg (loc,locate_global_with_alias lqid)
+      with Not_found -> error_global_not_found_loc lqid
+
+let intern_ltac_variable ist = function
+  | Ident (loc,id) ->
+      if find_var id ist then
+	(* A local variable of any type *)
+	ArgVar (loc,id)
+      else
+      (* A recursive variable *)
+      ArgArg (loc,find_recvar id ist)
+  | _ ->
+      raise Not_found
+
+let intern_constr_reference strict ist = function
+  | Ident (_,id) as r when not strict && find_hyp id ist ->
+      GVar (dloc,id), Some (CRef (r,None))
+  | Ident (_,id) as r when find_var id ist ->
+      GVar (dloc,id), if strict then None else Some (CRef (r,None))
+  | r ->
+      let loc,_ as lqid = qualid_of_reference r in
+      GRef (loc,locate_global_with_alias lqid,None), 
+	if strict then None else Some (CRef (r,None))
+
+let intern_move_location ist = function
+  | MoveAfter id -> MoveAfter (intern_hyp ist id)
+  | MoveBefore id -> MoveBefore (intern_hyp ist id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
+
+(* Internalize an isolated reference in position of tactic *)
+
+let intern_isolated_global_tactic_reference r =
+  let (loc,qid) = qualid_of_reference r in
+  TacCall (loc,ArgArg (loc,locate_tactic qid),[])
+
+let intern_isolated_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A global tactic *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "constr:" *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+(* Internalize an applied tactic reference *)
+
+let intern_applied_global_tactic_reference r =
+  let (loc,qid) = qualid_of_reference r in
+  ArgArg (loc,locate_tactic qid)
+
+let intern_applied_tactic_reference ist r =
+  (* An ltac reference *)
+  try intern_ltac_variable ist r
+  with Not_found ->
+  (* A global tactic *)
+  try intern_applied_global_tactic_reference r
+  with Not_found ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+(* Intern a reference parsed in a non-tactic entry *)
+
+let intern_non_tactic_reference strict ist r =
+  (* An ltac reference *)
+  try Reference (intern_ltac_variable ist r)
+  with Not_found ->
+  (* A constr reference *)
+  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+  with Not_found ->
+  (* Tolerance for compatibility, allow not to use "ltac:" *)
+  try intern_isolated_global_tactic_reference r
+  with Not_found ->
+  (* By convention, use IntroIdentifier for unbound ident, when not in a def *)
+  match r with
+  | Ident (loc,id) when not strict ->
+    let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in
+    TacGeneric ipat
+  | _ ->
+  (* Reference not found *)
+  error_global_not_found_loc (qualid_of_reference r)
+
+let intern_message_token ist = function
+  | (MsgString _ | MsgInt _ as x) -> x
+  | MsgIdent id -> MsgIdent (intern_hyp ist id)
+
+let intern_message ist = List.map (intern_message_token ist)
+
+let intern_quantified_hypothesis ist = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
+      NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
+
+let intern_binding_name ist x =
+  (* We use identifier both for variables and binding names *)
+  (* Todo: consider the body of the lemma to which the binding refer
+     and if a term w/o ltac vars, check the name is indeed quantified *)
+  x
+
+let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c =
+  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
+  let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in
+  let ltacvars = {
+    Constrintern.ltac_vars = lfun;
+    ltac_bound = Id.Set.empty;
+  } in
+  let c' =
+    warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c
+  in
+  (c',if !strict_check then None else Some c)
+
+let intern_constr = intern_constr_gen false false
+let intern_type = intern_constr_gen false true
+
+(* Globalize bindings *)
+let intern_binding ist (loc,b,c) =
+  (loc,intern_binding_name ist b,intern_constr ist c)
+
+let intern_bindings ist = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
+
+let intern_constr_with_bindings ist (c,bl) =
+  (intern_constr ist c, intern_bindings ist bl)
+
+let intern_constr_with_bindings_arg ist (clear,c) =
+  (clear,intern_constr_with_bindings ist c)
+
+let rec intern_intro_pattern lf ist = function
+  | loc, IntroNaming pat ->
+      loc, IntroNaming (intern_intro_pattern_naming lf ist pat)
+  | loc, IntroAction pat ->
+      loc, IntroAction (intern_intro_pattern_action lf ist pat)
+  | loc, IntroForthcoming _ as x -> x
+
+and intern_intro_pattern_naming lf ist = function
+  | IntroIdentifier id ->
+      IntroIdentifier (intern_ident lf ist id)
+  | IntroFresh id ->
+      IntroFresh (intern_ident lf ist id)
+  | IntroAnonymous as x -> x
+
+and intern_intro_pattern_action lf ist = function
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
+  | IntroInjection l ->
+      IntroInjection (List.map (intern_intro_pattern lf ist) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+  | IntroApplyOn (c,pat) ->
+      IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat)
+
+and intern_or_and_intro_pattern lf ist =
+  List.map (List.map (intern_intro_pattern lf ist))
+
+let intern_or_and_intro_pattern_loc lf ist = function
+  | ArgVar (_,id) as x ->
+      if find_var id ist then x
+      else error "Disjunctive/conjunctive introduction pattern expected."
+  | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l)
+
+let intern_intro_pattern_naming_loc lf ist (loc,pat) =
+  (loc,intern_intro_pattern_naming lf ist pat)
+
+  (* TODO: catch ltac vars *)
+let intern_induction_arg ist = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent (loc,id) ->
+      if !strict_check then
+	(* If in a defined tactic, no intros-until *)
+	match intern_constr ist (CRef (Ident (dloc,id), None)) with
+	| GVar (loc,id),_ -> clear,ElimOnIdent (loc,id)
+	| c -> clear,ElimOnConstr (c,NoBindings)
+      else
+	clear,ElimOnIdent (loc,id)
+
+let short_name = function
+  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
+  | _ -> None
+
+let intern_evaluable_global_reference ist r =
+  let lqid = qualid_of_reference r in
+  try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid)
+  with Not_found ->
+  match r with
+  | Ident (loc,id) when not !strict_check -> EvalVarRef id
+  | _ -> error_global_not_found_loc lqid
+
+let intern_evaluable_reference_or_by_notation ist = function
+  | AN r -> intern_evaluable_global_reference ist r
+  | ByNotation (loc,ntn,sc) ->
+      evaluable_of_global_reference ist.genv
+      (Notation.interp_notation_as_global_reference loc
+        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
+
+(* Globalize a reduction expression *)
+let intern_evaluable ist = function
+  | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
+  | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist ->
+      ArgArg (EvalVarRef id, Some (loc,id))
+  | r ->
+      let e = intern_evaluable_reference_or_by_notation ist r in
+      let na = short_name r in
+      ArgArg (e,na)
+
+let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
+
+let intern_flag ist red =
+  { red with rConst = List.map (intern_evaluable ist) red.rConst }
+
+let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
+
+let intern_constr_pattern ist ~as_type ~ltacvars pc =
+  let ltacvars = {
+    Constrintern.ltac_vars = ltacvars;
+    ltac_bound = Id.Set.empty;
+  } in
+  let metas,pat = Constrintern.intern_constr_pattern
+    ist.genv ~as_type ~ltacvars pc
+  in
+  let c = intern_constr_gen true false ist pc in
+  metas,(c,pat)
+
+let dummy_pat = PRel 0
+
+let intern_typed_pattern ist p =
+  (* we cannot ensure in non strict mode that the pattern is closed *)
+  (* keeping a constr_expr copy is too complicated and we want anyway to *)
+  (* type it, so we remember the pattern as a glob_constr only *)
+  (intern_constr_gen true false ist p,dummy_pat)
+
+let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) =
+  let interp_ref r =
+    try l, Inl (intern_evaluable ist r)
+    with e when Logic.catchable_exception e ->
+      (* Compatibility. In practice, this means that the code above
+         is useless. Still the idea of having either an evaluable
+         ref or a pattern seems interesting, with "head" reduction
+         in case of an evaluable ref, and "strong" reduction in the
+         subterm matched when a pattern *)
+      let loc = loc_of_smart_reference r in
+      let r = match r with
+      | AN r -> r
+      | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in
+      let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in
+      let c = Constrintern.interp_reference sign r in
+      match c with
+      | GRef (_,r,None) ->
+          l, Inl (ArgArg (evaluable_of_global_reference ist.genv r,None))
+      | GVar (_,id) ->
+          let r = evaluable_of_global_reference ist.genv (VarRef id) in
+          l, Inl (ArgArg (r,None))
+      | _ ->
+          l, Inr ((c,None),dummy_pat) in
+  match p with
+  | Inl r -> interp_ref r
+  | Inr (CAppExpl(_,(None,r,None),[])) ->
+      (* We interpret similarly @ref and ref *)
+      interp_ref (AN r)
+  | Inr c ->
+      l, Inr (intern_typed_pattern ist c)
+
+(* This seems fairly hacky, but it's the first way I've found to get proper
+   globalization of [unfold].  --adamc *)
+let dump_glob_red_expr = function
+  | Unfold occs -> List.iter (fun (_, r) ->
+    try
+      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	(Smartlocate.smart_global r)
+    with e when Errors.noncritical e -> ()) occs
+  | Cbv grf | Lazy grf ->
+    List.iter (fun r ->
+      try
+        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
+	  (Smartlocate.smart_global r)
+      with e when Errors.noncritical e -> ()) grf.rConst
+  | _ -> ()
+
+let intern_red_expr ist = function
+  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
+  | Fold l -> Fold (List.map (intern_constr ist) l)
+  | Cbv f -> Cbv (intern_flag ist f)
+  | Cbn f -> Cbn (intern_flag ist f)
+  | Lazy f -> Lazy (intern_flag ist f)
+  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
+  | Simpl (f,o) ->
+     Simpl (intern_flag ist f,
+	    Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o)
+  | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r
+
+let intern_in_hyp_as ist lf (clear,id,ipat) =
+  (clear,intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat)
+
+let intern_hyp_list ist = List.map (intern_hyp ist)
+
+let intern_inversion_strength lf ist = function
+  | NonDepInversion (k,idl,ids) ->
+      NonDepInversion (k,intern_hyp_list ist idl,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | DepInversion (k,copt,ids) ->
+      DepInversion (k, Option.map (intern_constr ist) copt,
+      Option.map (intern_or_and_intro_pattern_loc lf ist) ids)
+  | InversionUsing (c,idl) ->
+      InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
+
+(* Interprets an hypothesis name *)
+let intern_hyp_location ist ((occs,id),hl) =
+  ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs,
+   intern_hyp ist id), hl)
+
+(* Reads a pattern *)
+let intern_pattern ist ?(as_type=false) ltacvars = function
+  | Subterm (b,ido,pc) ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
+      ido, metas, Subterm (b,ido,pc)
+  | Term pc ->
+      let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in
+      None, metas, Term pc
+
+let intern_constr_may_eval ist = function
+  | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
+  | ConstrContext (locid,c) ->
+      ConstrContext (intern_hyp ist locid,intern_constr ist c)
+  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
+  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
+
+let name_cons accu = function
+| Anonymous -> accu
+| Name id -> Id.Set.add id accu
+
+let opt_cons accu = function
+| None -> accu
+| Some id -> Id.Set.add id accu
+
+(* Reads the hypotheses of a "match goal" rule *)
+let rec intern_match_goal_hyps ist lfun = function
+  | (Hyp ((_,na) as locna,mp))::tl ->
+      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
+      let lfun' = name_cons (opt_cons lfun ido) na in
+      lfun', metas1@metas2, Hyp (locna,pat)::hyps
+  | (Def ((_,na) as locna,mv,mp))::tl ->
+      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
+      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
+      let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
+      let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in
+      lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
+  | [] -> lfun, [], []
+
+(* Utilities *)
+let extract_let_names lrc =
+  let fold accu ((loc, name), _) =
+    if Id.Set.mem name accu then user_err_loc
+      (loc, "glob_tactic", str "This variable is bound several times.")
+    else Id.Set.add name accu
+  in
+  List.fold_left fold Id.Set.empty lrc
+
+let clause_app f = function
+    { onhyps=None; concl_occs=nl } ->
+      { onhyps=None; concl_occs=nl }
+  | { onhyps=Some l; concl_occs=nl } ->
+      { onhyps=Some(List.map f l); concl_occs=nl}
+
+let map_raw wit f ist x =
+  in_gen (glbwit wit) (f ist (out_gen (rawwit wit) x))
+
+(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
+let rec intern_atomic lf ist x =
+  match (x:raw_atomic_tactic_expr) with
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
+  | TacIntroMove (ido,hto) ->
+      TacIntroMove (Option.map (intern_ident lf ist) ido,
+                    intern_move_location ist hto)
+  | TacExact c -> TacExact (intern_constr ist c)
+  | TacApply (a,ev,cb,inhyp) ->
+      TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb,
+                Option.map (intern_in_hyp_as ist lf) inhyp)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,intern_constr_with_bindings_arg ist cb,
+               Option.map (intern_constr_with_bindings ist) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb)
+  | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n)
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
+      TacMutualFix (intern_ident lf ist id, n, List.map f l)
+  | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
+      TacMutualCofix (intern_ident lf ist id, List.map f l)
+  | TacAssert (b,otac,ipat,c) ->
+      TacAssert (b,Option.map (intern_pure_tactic ist) otac,
+                 Option.map (intern_intro_pattern lf ist) ipat,
+                 intern_constr_gen false (not (Option.is_empty otac)) ist c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (fun (c,na) ->
+	               intern_constr_with_occurrences ist c,
+                       intern_name lf ist na) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
+  | TacLetTac (na,c,cls,b,eqpat) ->
+      let na = intern_name lf ist na in
+      TacLetTac (na,intern_constr ist c,
+                 (clause_app (intern_hyp_location ist) cls),b,
+		 (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat))
+
+  (* Automation tactics *)
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
+  | TacAuto (d,n,lems,l) ->
+      TacAuto (d,Option.map (intern_int_or_var ist) n,
+        List.map (intern_constr ist) lems,l)
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (ev,isrec,(l,el)) ->
+      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) ->
+	      (intern_induction_arg ist c,
+               (Option.map (intern_intro_pattern_naming_loc lf ist) ipato,
+               Option.map (intern_or_and_intro_pattern_loc lf ist) ipats),
+               Option.map (clause_app (intern_hyp_location ist)) cls)) l,
+               Option.map (intern_constr_with_bindings ist) el))
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = intern_quantified_hypothesis ist h1 in
+      let h2 = intern_quantified_hypothesis ist h2 in
+      TacDoubleInduction (h1,h2)
+  (* Context management *)
+  | TacClear (b,l) -> TacClear (b,List.map (intern_hyp ist) l)
+  | TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l)
+  | TacMove (id1,id2) ->
+    TacMove (intern_hyp ist id1,intern_move_location ist id2)
+  | TacRename l ->
+      TacRename (List.map (fun (id1,id2) ->
+			     intern_hyp ist id1,
+			     intern_hyp ist id2) l)
+
+  (* Constructors *)
+  | TacSplit (ev,bll) -> TacSplit (ev,List.map (intern_bindings ist) bll)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      dump_glob_red_expr r;
+      TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
+  | TacChange (None,c,cl) ->
+      let is_onhyps = match cl.onhyps with
+      | None | Some [] -> true
+      | _ -> false
+      in
+      let is_onconcl = match cl.concl_occs with
+      | AllOccurrences | NoOccurrences -> true
+      | _ -> false
+      in
+      TacChange (None,
+        (if is_onhyps && is_onconcl
+         then intern_type ist c else intern_constr ist c),
+	clause_app (intern_hyp_location ist) cl)
+  | TacChange (Some p,c,cl) ->
+      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
+	clause_app (intern_hyp_location ist) cl)
+
+  (* Equivalence relations *)
+  | TacSymmetry idopt ->
+      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite
+	(ev,
+	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l,
+	clause_app (intern_hyp_location ist) cl,
+	Option.map (intern_pure_tactic ist) by)
+  | TacInversion (inv,hyp) ->
+      TacInversion (intern_inversion_strength lf ist inv,
+        intern_quantified_hypothesis ist hyp)
+
+and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
+
+and intern_tactic_seq onlytac ist = function
+  | TacAtom (loc,t) ->
+      let lf = ref ist.ltacvars in
+      let t = intern_atomic lf ist t in
+      !lf, TacAtom (adjust_loc loc, t)
+  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
+  | TacLetIn (isrec,l,u) ->
+      let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in
+      let ist' = { ist with ltacvars } in
+      let l = List.map (fun (n,b) ->
+	  (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
+      ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
+
+  | TacMatchGoal (lz,lr,lmr) ->
+      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)
+  | TacMatch (lz,c,lmr) ->
+      ist.ltacvars,
+      TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
+  | TacId l -> ist.ltacvars, TacId (intern_message ist l)
+  | TacFail (g,n,l) ->
+      ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
+  | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac)
+  | TacAbstract (tac,s) ->
+      ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
+  | TacThen (t1,t2) ->
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
+      lfun'', TacThen (t1,t2)
+  | TacDispatch tl ->
+      ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      ist.ltacvars ,
+      TacExtendTac (Array.map (intern_pure_tactic ist) tf,
+                    intern_pure_tactic ist t,
+		    Array.map (intern_pure_tactic ist) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
+      let ist' = { ist with ltacvars = lfun' } in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
+		       Array.map (intern_pure_tactic ist') tl)
+  | TacThens (t,tl) ->
+      let lfun', t = intern_tactic_seq true ist t in
+      let ist' = { ist with ltacvars = lfun' } in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
+  | TacDo (n,tac) ->
+      ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
+  | TacTimeout (n,tac) ->
+      ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac)
+  | TacTime (s,tac) ->
+      ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac)
+  | TacOr (tac1,tac2) ->
+      ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacOnce tac ->
+      ist.ltacvars, TacOnce (intern_pure_tactic ist tac)
+  | TacExactlyOnce tac ->
+      ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      ist.ltacvars,
+      TacIfThenCatch (
+        intern_pure_tactic ist tac,
+        intern_pure_tactic ist tact,
+        intern_pure_tactic ist tace)
+  | TacOrelse (tac1,tac2) ->
+      ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
+  | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
+  | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
+
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
+      ist.ltacvars, TacAlias (loc,s,l)
+  | TacML (loc,opn,l) ->
+      let _ignore = Tacenv.interp_ml_tactic opn in
+      ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_genarg ist) l)
+
+and intern_tactic_as_arg loc onlytac ist a =
+  match intern_tacarg !strict_check onlytac ist a with
+  | TacCall _ | Reference _
+  | TacDynamic _ | TacGeneric _ as a -> TacArg (loc,a)
+  | Tacexp a -> a
+  | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a ->
+      if onlytac then error_tactic_expected loc else TacArg (loc,a)
+  | MetaIdArg _ -> assert false
+
+and intern_tactic_or_tacarg ist = intern_tactic false ist
+
+and intern_pure_tactic ist = intern_tactic true ist
+
+and intern_tactic_fun ist (var,body) =
+  let lfun = List.fold_left opt_cons ist.ltacvars var in
+  (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body)
+
+and intern_tacarg strict onlytac ist = function
+  | Reference r -> intern_non_tactic_reference strict ist r
+  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
+  | UConstr c -> UConstr (intern_constr ist c)
+  | MetaIdArg (loc,istac,s) ->
+      (* $id can occur in Grammar tactic... *)
+      let id = Id.of_string s in
+      if find_var id ist then
+	if istac then Reference (ArgVar (adjust_loc loc,id))
+	else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None))
+      else error_syntactic_metavariables_not_allowed loc
+  | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
+  | TacCall (loc,f,l) ->
+      TacCall (loc,
+        intern_applied_tactic_reference ist f,
+        List.map (intern_tacarg !strict_check false ist) l)
+  | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x)
+  | TacPretype c -> TacPretype (intern_constr ist c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
+  | TacGeneric arg ->
+    let (_, arg) = Genintern.generic_intern ist arg in
+    TacGeneric arg
+  | TacDynamic(loc,t) as x ->
+    if Dyn.has_tag t "tactic" || Dyn.has_tag t "value" then x
+    else if Dyn.has_tag t "constr" then
+      if onlytac then error_tactic_expected loc else x
+    else
+      let tag = Dyn.tag t in
+      anomaly ~loc (str "Unknown dynamic: <" ++ str tag ++ str ">")
+
+(* Reads the rules of a Match Context or a Match *)
+and intern_match_rule onlytac ist = function
+  | (All tc)::tl ->
+      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let {ltacvars=lfun; genv=env} = ist in
+      let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
+      let ido,metas2,pat = intern_pattern ist lfun mp in
+      let fold accu x = Id.Set.add x accu in
+      let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in
+      let ltacvars = List.fold_left fold ltacvars metas2 in
+      let ist' = { ist with ltacvars } in
+      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
+  | [] -> []
+
+and intern_genarg ist x =
+  match genarg_tag x with
+  | IntOrVarArgType -> map_raw wit_int_or_var intern_int_or_var ist x
+  | IdentArgType ->
+    let lf = ref Id.Set.empty in
+    map_raw wit_ident (intern_ident lf) ist x
+  | VarArgType ->
+    map_raw wit_var intern_hyp ist x
+  | GenArgType ->
+    map_raw wit_genarg intern_genarg ist x
+  | ConstrArgType ->
+    map_raw wit_constr intern_constr ist x
+  | ConstrMayEvalArgType ->
+    map_raw wit_constr_may_eval intern_constr_may_eval ist x
+  | QuantHypArgType ->
+    map_raw wit_quant_hyp intern_quantified_hypothesis ist x
+  | RedExprArgType ->
+    map_raw wit_red_expr intern_red_expr ist x
+  | OpenConstrArgType ->
+    map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x
+  | ConstrWithBindingsArgType ->
+    map_raw wit_constr_with_bindings intern_constr_with_bindings ist x
+  | BindingsArgType ->
+    map_raw wit_bindings intern_bindings ist x
+  | ListArgType _ ->
+      let list_unpacker wit l =
+        let map x =
+          let ans = intern_genarg ist (in_gen (rawwit wit) x) in
+          out_gen (glbwit wit) ans
+        in
+        in_gen (glbwit (wit_list wit)) (List.map map (raw l))
+      in
+      list_unpack { list_unpacker } x
+  | OptArgType _ ->
+      let opt_unpacker wit o = match raw o with
+      | None -> in_gen (glbwit (wit_opt wit)) None
+      | Some x ->
+        let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in
+        in_gen (glbwit (wit_opt wit)) (Some s)
+      in
+      opt_unpack { opt_unpacker } x
+  | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let p, q = raw o in
+        let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in
+        let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in
+        in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
+  | ExtraArgType s ->
+      snd (Genintern.generic_intern ist x)
+
+(** Other entry points *)
+
+let glob_tactic x =
+  Flags.with_option strict_check
+    (intern_pure_tactic (make_empty_glob_sign ())) x
+
+let glob_tactic_env l env x =
+  let ltacvars =
+    List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in
+  Flags.with_option strict_check
+  (intern_pure_tactic
+    { ltacvars; ltacrecvars = Id.Map.empty; genv = env })
+    x
+
+let split_ltac_fun = function
+  | TacFun (l,t) -> (l,t)
+  | t -> ([],t)
+
+let pr_ltac_fun_arg = function
+  | None -> spc () ++ str "_"
+  | Some id -> spc () ++ pr_id id
+
+let print_ltac id =
+ try
+  let kn = Nametab.locate_tactic id in
+  let l,t = split_ltac_fun (Tacenv.interp_ltac kn) in
+  hv 2 (
+    hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
+           prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
+    ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t)
+ with
+  Not_found ->
+   errorlabstrm "print_ltac"
+    (pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
+
+(** Registering *)
+
+let lift intern = (); fun ist x -> (ist, intern ist x)
+
+let () =
+  let intern_intro_pattern ist pat =
+    let lf = ref Id.Set.empty in
+    let ans = intern_intro_pattern lf ist pat in
+    let ist = { ist with ltacvars = !lf } in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_intro_pattern intern_intro_pattern
+
+let () =
+  let intern_clause ist cl =
+    let ans = clause_app (intern_hyp_location ist) cl in
+    (ist, ans)
+  in
+  Genintern.register_intern0 wit_clause_dft_concl intern_clause
+
+let () =
+  Genintern.register_intern0 wit_ref (lift intern_global_reference);
+  Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg);
+  Genintern.register_intern0 wit_sort (fun ist s -> (ist, s))
+
+let () =
+  Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c))
+
+(***************************************************************************)
+(* Backwarding recursive needs of tactic glob/interp/eval functions *)
+
+let _ =
+  let f l =
+    let ltacvars =
+      List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l
+    in
+    Flags.with_option strict_check
+    (intern_pure_tactic { (make_empty_glob_sign()) with ltacvars })
+  in
+  Hook.set Hints.extern_intern_tac f
diff --git a/tactics/tacintern.mli b/tactics/tacintern.mli
new file mode 100644
index 00000000..2e662e58
--- /dev/null
+++ b/tactics/tacintern.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(*  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 Pp
+open Names
+open Tacexpr
+open Genarg
+open Constrexpr
+open Misctypes
+open Nametab
+
+(** Globalization of tactic expressions :
+    Conversion from [raw_tactic_expr] to [glob_tactic_expr] *)
+
+type glob_sign = Genintern.glob_sign = {
+  ltacvars : Id.Set.t;
+  ltacrecvars : ltac_constant Id.Map.t;
+  genv : Environ.env }
+
+val fully_empty_glob_sign : glob_sign
+
+val make_empty_glob_sign : unit -> glob_sign
+ (** same as [fully_empty_glob_sign], but with [Global.env()] as
+     environment *)
+
+(** Main globalization functions *)
+
+val glob_tactic : raw_tactic_expr -> glob_tactic_expr
+
+val glob_tactic_env :
+  Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+
+(** Low-level variants *)
+
+val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr
+
+val intern_tactic_or_tacarg :
+  glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr
+
+val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr
+
+val intern_constr_with_bindings :
+  glob_sign -> constr_expr * constr_expr bindings ->
+  glob_constr_and_expr * glob_constr_and_expr bindings
+
+val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located
+
+(** Adds a globalization function for extra generic arguments *)
+
+val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument
+
+(** printing *)
+val print_ltac : Libnames.qualid -> std_ppcmds
+
+(** Reduction expressions *)
+
+val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr
+val dump_glob_red_expr : raw_red_expr -> unit
+
+(* Hooks *)
+val strict_check : bool ref
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index e5575a2c..23de47d5 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -1,1001 +1,287 @@
 (************************************************************************)
 (*  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 Constrintern
-open Closure
-open RedFlags
-open Declarations
-open Entries
-open Libobject
-open Pattern
-open Matching
+open Patternops
 open Pp
+open Genredexpr
 open Glob_term
-open Sign
+open Glob_ops
 open Tacred
+open Errors
 open Util
 open Names
 open Nameops
 open Libnames
+open Globnames
 open Nametab
-open Smartlocate
 open Pfedit
 open Proof_type
 open Refiner
 open Tacmach
 open Tactic_debug
-open Topconstr
+open Constrexpr
 open Term
 open Termops
 open Tacexpr
-open Safe_typing
-open Typing
-open Hiddentac
 open Genarg
-open Decl_kinds
-open Mod_subst
+open Stdarg
+open Constrarg
 open Printer
-open Inductiveops
-open Syntax_def
 open Pretyping
-open Pretyping.Default
-open Extrawit
-open Pcoq
-open Compat
+module Monad_ = Monad
 open Evd
+open Misctypes
+open Locus
+open Tacintern
+open Taccoerce
+open Proofview.Notations
 
 let safe_msgnl s =
-    try msgnl s with e when Errors.noncritical e ->
-      msgnl
-	(str "bug in the debugger: " ++
-         str "an exception is raised while printing debug information")
-
-let error_syntactic_metavariables_not_allowed loc =
-  user_err_loc
-    (loc,"out_ident",
-     str "Syntactic metavariables allowed only in quotations.")
-
-let error_tactic_expected loc =
-  user_err_loc (loc,"",str "Tactic expected.")
-
-let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid
-
-let skip_metaid = function
-  | AI x -> x
-  | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc
+  Proofview.NonLogical.catch
+    (Proofview.NonLogical.print (s++fnl()))
+    (fun _ -> Proofview.NonLogical.print (str "bug in the debugger: an exception is raised while printing debug information"++fnl()))
+
+type value = tlevel generic_argument
+
+(** Abstract application, to print ltac functions *)
+type appl =
+  | UnnamedAppl (** For generic applications: nothing is printed *)
+  | GlbAppl of (Names.kernel_name * typed_generic_argument list) list
+       (** For calls to global constants, some may alias other. *)
+let push_appl appl args =
+  match appl with
+  | UnnamedAppl -> UnnamedAppl
+  | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l)
+let pr_generic arg =
+  let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in
+  try
+    Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg
+  with e when Errors.noncritical e -> str"<generic>"
+let pr_appl h vs =
+  Pptactic.pr_ltac_constant  h ++ spc () ++
+  Pp.prlist_with_sep spc pr_generic vs
+let rec name_with_list appl t =
+  match appl with
+  | [] -> t
+  | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t)
+let name_if_glob appl t =
+  match appl with
+  | UnnamedAppl -> t
+  | GlbAppl l -> name_with_list l t
+let combine_appl appl1 appl2 =
+  match appl1,appl2 with
+  | UnnamedAppl,a | a,UnnamedAppl -> a
+  | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1)
 
 (* Values for interpretation *)
-type value =
-  | VRTactic of (goal list sigma) (* For Match results *)
-                                               (* Not a true value *)
-  | VFun of ltac_trace * (identifier*value) list *
-      identifier option list * glob_tactic_expr
-  | VVoid
-  | VInteger of int
-  | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
-                        (* bound as in "Intro H" but which may be bound *)
-                        (* later, as in "tac" in "Intro H; tac" *)
-  | VConstr of constr_under_binders
-                        (* includes idents known to be bound and references *)
-  | VConstr_context of constr
-  | VList of value list
-  | VRec of (identifier*value) list ref * glob_tactic_expr
-
-let dloc = dummy_loc
-
-let catch_error call_trace tac g =
-  if call_trace = [] then tac g else try tac g with
-  | LtacLocated _ as e -> raise e
-  | Loc.Exc_located (_,LtacLocated _) as e -> raise e
-  | e when Errors.noncritical e ->
-    let (nrep,loc',c),tail = list_sep_last call_trace in
-    let loc,e' = match e with Loc.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
-    if tail = [] then
-      let loc = if loc = dloc then loc' else loc in
-      raise (Loc.Exc_located(loc,e'))
-    else
-      raise (Loc.Exc_located(loc',LtacLocated((nrep,c,tail,loc),e')))
-
-(* Signature for interpretation: val_interp and interpretation functions *)
-type interp_sign =
-    { lfun : (identifier * value) list;
-      avoid_ids : identifier list; (* ids inherited from the call context
-				      (needed to get fresh ids) *)
-      debug : debug_info;
-      trace : ltac_trace }
-
-let check_is_value = function
-  | VRTactic _ -> (* These are goals produced by Match *)
-   error "Immediate match producing tactics not allowed in local definitions."
-  | _ -> ()
-
-(* Gives the constr corresponding to a Constr_context tactic_arg *)
-let constr_of_VConstr_context = function
-  | VConstr_context c -> c
-  | _ ->
-    errorlabstrm "constr_of_VConstr_context" (str "Not a context variable.")
-
-(* Displays a value *)
-let rec pr_value env = function
-  | VVoid -> str "()"
-  | VInteger n -> int n
-  | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr c ->
-      (match env with Some env ->
-	pr_lconstr_under_binders_env env c | _ -> str "a term")
-  | VConstr_context c ->
-      (match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
-  | (VRTactic _ | VFun _ | VRec _) -> str "a tactic"
-  | VList [] -> str "an empty list"
-  | VList (a::_) ->
-      str "a list (first element is " ++ pr_value env a ++ str")"
-
-(* Transforms an id into a constr if possible, or fails with Not_found *)
-let constr_of_id env id =
-  Term.mkVar (let _ = Environ.lookup_named id env in id)
+type tacvalue =
+  | VFun of appl*ltac_trace * value Id.Map.t *
+      Id.t option list * glob_tactic_expr
+  | VRec of value Id.Map.t ref * glob_tactic_expr
 
-(* To embed tactics *)
-let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
-     (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
-  Dyn.create "tactic"
+let (wit_tacvalue : (Empty.t, Empty.t, tacvalue) Genarg.genarg_type) =
+  Genarg.create_arg None "tacvalue"
 
-let ((value_in : value -> Dyn.t),
-     (value_out : Dyn.t -> value)) = Dyn.create "value"
+let of_tacvalue v = in_gen (topwit wit_tacvalue) v
+let to_tacvalue v = out_gen (topwit wit_tacvalue) v
 
-let valueIn t = TacDynamic (dummy_loc,value_in t)
-let valueOut = function
-  | TacDynamic (_,d) ->
-    if (Dyn.tag d) = "value" then
-      value_out d
-    else
-      anomalylabstrm "valueOut" (str "Dynamic tag should be value")
-  | ast ->
-    anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
+(** More naming applications *)
+let name_vfun appl vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+    match to_tacvalue vle with
+    | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t))
+    | _ -> vle
+  else vle
 
-(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
-let atomic_mactab = ref Idmap.empty
-let add_primitive_tactic s tac =
-  let id = id_of_string s in
-  atomic_mactab := Idmap.add id tac !atomic_mactab
+module TacStore = Geninterp.TacStore
 
-let _ =
-  let nocl = {onhyps=Some[];concl_occs=all_occurrences_expr} in
-  List.iter
-      (fun (s,t) -> add_primitive_tactic s (TacAtom(dloc,t)))
-      [ "red", TacReduce(Red false,nocl);
-        "hnf", TacReduce(Hnf,nocl);
-        "simpl", TacReduce(Simpl None,nocl);
-        "compute", TacReduce(Cbv all_flags,nocl);
-        "intro", TacIntroMove(None,no_move);
-        "intros", TacIntroPattern [];
-        "assumption", TacAssumption;
-        "cofix", TacCofix None;
-        "trivial", TacTrivial (Off,[],None);
-        "auto", TacAuto(Off,None,[],None);
-        "left", TacLeft(false,NoBindings);
-        "eleft", TacLeft(true,NoBindings);
-        "right", TacRight(false,NoBindings);
-        "eright", TacRight(true,NoBindings);
-        "split", TacSplit(false,false,[NoBindings]);
-        "esplit", TacSplit(true,false,[NoBindings]);
-        "constructor", TacAnyConstructor (false,None);
-        "econstructor", TacAnyConstructor (true,None);
-        "reflexivity", TacReflexivity;
-        "symmetry", TacSymmetry nocl
-      ];
-  List.iter
-      (fun (s,t) -> add_primitive_tactic s t)
-      [ "idtac",TacId [];
-        "fail", TacFail(ArgArg 0,[]);
-        "fresh", TacArg(dloc,TacFreshId [])
-      ]
-
-let lookup_atomic id = Idmap.find id !atomic_mactab
-let is_atomic_kn kn =
-  let (_,_,l) = repr_kn kn in
-  Idmap.mem (id_of_label l) !atomic_mactab
-
-(* Summary and Object declaration *)
-let mactab = ref Gmap.empty
-
-let lookup r = Gmap.find r !mactab
+let f_avoid_ids : Id.t list TacStore.field = TacStore.field ()
+(* ids inherited from the call context (needed to get fresh ids) *)
+let f_debug : debug_info TacStore.field = TacStore.field ()
+let f_trace : ltac_trace TacStore.field = TacStore.field ()
 
-let _ =
-  let init () = mactab := Gmap.empty in
-  let freeze () = !mactab in
-  let unfreeze fs = mactab := fs in
-  Summary.declare_summary "tactic-definition"
-    { Summary.freeze_function   = freeze;
-      Summary.unfreeze_function = unfreeze;
-      Summary.init_function     = init }
-
-(* Tactics table (TacExtend). *)
-
-let tac_tab = Hashtbl.create 17
-
-let add_tactic s t =
-  if Hashtbl.mem tac_tab s then
-    errorlabstrm ("Refiner.add_tactic: ")
-      (str ("Cannot redeclare tactic "^s^"."));
-  Hashtbl.add tac_tab s t
-
-let overwriting_add_tactic s t =
-  if Hashtbl.mem tac_tab s then begin
-    Hashtbl.remove tac_tab s;
-    msg_warn ("Overwriting definition of tactic "^s)
-  end;
-  Hashtbl.add tac_tab s t
-
-let lookup_tactic s =
-  try
-    Hashtbl.find tac_tab s
-  with Not_found ->
-    errorlabstrm "Refiner.lookup_tactic"
-      (str"The tactic " ++ str s ++ str" is not installed.")
-(*
-let vernac_tactic (s,args) =
-  let tacfun = lookup_tactic s args in
-  abstract_extended_tactic s args tacfun
-*)
-(* Interpretation of extra generic arguments *)
-type glob_sign = {
-  ltacvars : identifier list * identifier list;
-     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
-  ltacrecvars : (identifier * ltac_constant) list;
-     (* ltac recursive names *)
-  gsigma : Evd.evar_map;
-  genv : Environ.env }
-
-type interp_genarg_type =
-  (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-  (interp_sign -> goal sigma -> glob_generic_argument ->
-    Evd.evar_map * typed_generic_argument) *
-  (substitution -> glob_generic_argument -> glob_generic_argument)
-
-let extragenargtab =
-  ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
-let add_interp_genarg id f =
-  extragenargtab := Gmap.add id f !extragenargtab
-let lookup_genarg id =
-  try Gmap.find id !extragenargtab
-  with Not_found ->
-    let msg = "No interpretation function found for entry " ^ id in
-    msg_warn msg;
-    let f = (fun _ _ -> failwith msg), (fun _ _ _ -> failwith msg), (fun _ a -> a) in
-    add_interp_genarg id f;
-    f
-
-
-let lookup_genarg_glob   id = let (f,_,_) = lookup_genarg id in f
-let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
-let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
-
-let push_trace (loc,ck) = function
-  | (n,loc',ck')::trl when ck=ck' -> (n+1,loc,ck)::trl
-  | trl -> (1,loc,ck)::trl
-
-let propagate_trace ist loc id = function
-  | VFun (_,lfun,it,b) ->
-      let t = if it=[] then b else TacFun (it,b) in
-      VFun (push_trace(loc,LtacVarCall (id,t)) ist.trace,lfun,it,b)
-  | x -> x
-
-(* Dynamically check that an argument is a tactic *)
-let coerce_to_tactic loc id = function
-  | VFun _ | VRTactic _ as a -> a
-  | _ -> user_err_loc
-  (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
-
-(*****************)
-(* Globalization *)
-(*****************)
+(* Signature for interpretation: val_interp and interpretation functions *)
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
 
-(* We have identifier <| global_reference <| constr *)
+let extract_trace ist = match TacStore.get ist.extra f_trace with
+| None -> []
+| Some l -> l
 
-let find_ident id ist =
-  List.mem id (fst ist.ltacvars) or
-  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+module Value = struct
 
-let find_recvar qid ist = List.assoc qid ist.ltacrecvars
+  include Taccoerce.Value
 
-(* a "var" is a ltac var or a var introduced by an intro tactic *)
-let find_var id ist = List.mem id (fst ist.ltacvars)
+  let of_closure ist tac =
+    let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
+    of_tacvalue closure
 
-(* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *)
-let find_ctxvar id ist = List.mem id (snd ist.ltacvars)
+end
 
-(* a "ltacvar" is an ltac var (Let-In/Fun/...) *)
-let find_ltacvar id ist = find_var id ist & not (find_ctxvar id ist)
+let dloc = Loc.ghost
 
-let find_hyp id ist =
-  List.mem id (ids_of_named_context (Environ.named_context ist.genv))
+let catching_error call_trace fail (e, info) =
+  let inner_trace =
+    Option.default [] (Exninfo.get info ltac_trace_info)
+  in
+  if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info)
+  else begin
+    assert (Errors.noncritical e); (* preserved invariant *)
+    let new_trace = inner_trace @ call_trace in
+    let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in
+    fail located_exc
+  end
 
-(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
-(* be fresh in which case it is binding later on *)
-let intern_ident l ist id =
-  (* We use identifier both for variables and new names; thus nothing to do *)
-  if not (find_ident id ist) then l:=(id::fst !l,id::snd !l);
-  id
+let catch_error call_trace f x =
+  try f x
+  with e when Errors.noncritical e ->
+    let e = Errors.push e in
+    catching_error call_trace iraise e
 
-let intern_name l ist = function
-  | Anonymous -> Anonymous
-  | Name id -> Name (intern_ident l ist id)
+let catch_error_tac call_trace tac =
+  Proofview.tclORELSE
+    tac
+    (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e))
 
-let strict_check = ref false
+let curr_debug ist = match TacStore.get ist.extra f_debug with
+| None -> DebugOff
+| Some level -> level
 
-let adjust_loc loc = if !strict_check then dloc else loc
+(** TODO: unify printing of generic Ltac values in case of coercion failure. *)
 
-(* Globalize a name which must be bound -- actually just check it is bound *)
-let intern_hyp ist (loc,id as locid) =
-  if not !strict_check then
-    locid
-  else if find_ident id ist then
-    (dloc,id)
+(* Displays a value *)
+let pr_value env v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then str "a tactic"
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr) then
+    let c = out_gen (topwit wit_constr) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_env env sigma c
+    | _ -> str "a term"
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    match env with
+    | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c
+    | _ -> str "a term"
   else
-    Pretype_errors.error_var_not_found_loc loc id
-
-let intern_hyp_or_metaid ist id = intern_hyp ist (skip_metaid id)
-
-let intern_or_var ist = function
-  | ArgVar locid -> ArgVar (intern_hyp ist locid)
-  | ArgArg _ as x -> x
-
-let intern_inductive_or_by_notation = smart_global_inductive
-
-let intern_inductive ist = function
-  | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id)
-  | r -> ArgArg (intern_inductive_or_by_notation r)
-
-let intern_global_reference ist = function
-  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
-  | r ->
-      let loc,_ as lqid = qualid_of_reference r in
-      try ArgArg (loc,locate_global_with_alias lqid)
-      with Not_found ->
-	error_global_not_found_loc lqid
-
-let intern_ltac_variable ist = function
-  | Ident (loc,id) ->
-      if find_ltacvar id ist then
-	(* A local variable of any type *)
-	ArgVar (loc,id)
-      else
-      (* A recursive variable *)
-      ArgArg (loc,find_recvar id ist)
-  | _ ->
-      raise Not_found
-
-let intern_constr_reference strict ist = function
-  | Ident (_,id) as r when not strict & find_hyp id ist ->
-      GVar (dloc,id), Some (CRef r)
-  | Ident (_,id) as r when find_ctxvar id ist ->
-      GVar (dloc,id), if strict then None else Some (CRef r)
-  | r ->
-      let loc,_ as lqid = qualid_of_reference r in
-      GRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
-
-let intern_move_location ist = function
-  | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
-  | MoveBefore id -> MoveBefore (intern_hyp_or_metaid ist id)
-  | MoveToEnd toleft as x -> x
-
-(* Internalize an isolated reference in position of tactic *)
-
-let intern_isolated_global_tactic_reference r =
-  let (loc,qid) = qualid_of_reference r in
-  try TacCall (loc,ArgArg (loc,locate_tactic qid),[])
-  with Not_found ->
-  match r with
-  | Ident (_,id) -> Tacexp (lookup_atomic id)
-  | _ -> raise Not_found
+    str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v)
+
+let pr_closure env ist body =
+  let pp_body = Pptactic.pr_glob_tactic env body in
+  let pr_sep () = fnl () in
+  let pr_iarg (id, arg) =
+    let arg = pr_argument_type (genarg_tag arg) in
+    hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg)
+  in
+  let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in
+  pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs
+
+let pr_inspect env expr result =
+  let pp_expr = Pptactic.pr_glob_tactic env expr in
+  let pp_result =
+    if has_type result (topwit wit_tacvalue) then
+    match to_tacvalue result with
+    | VFun (_,_, ist, ul, b) ->
+      let body = if List.is_empty ul then b else (TacFun (ul, b)) in
+      str "a closure with body " ++ fnl() ++ pr_closure env ist body
+    | VRec (ist, body) ->
+      str "a recursive closure" ++ fnl () ++ pr_closure env !ist body
+    else
+      let pp_type = pr_argument_type (genarg_tag result) in
+      str "an object of type" ++ spc () ++ pp_type
+  in
+  pp_expr ++ fnl() ++ str "this is " ++ pp_result
 
-let intern_isolated_tactic_reference strict ist r =
-  (* An ltac reference *)
-  try Reference (intern_ltac_variable ist r)
-  with Not_found ->
-  (* A global tactic *)
-  try intern_isolated_global_tactic_reference r
-  with Not_found ->
-  (* Tolerance for compatibility, allow not to use "constr:" *)
-  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
-  with Not_found ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
+(* Transforms an id into a constr if possible, or fails with Not_found *)
+let constr_of_id env id =
+  Term.mkVar (let _ = Environ.lookup_named id env in id)
 
-(* Internalize an applied tactic reference *)
+(* To embed tactics *)
 
-let intern_applied_global_tactic_reference r =
-  let (loc,qid) = qualid_of_reference r in
-  ArgArg (loc,locate_tactic qid)
+let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
+     (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
+  Dyn.create "tactic"
 
-let intern_applied_tactic_reference ist r =
-  (* An ltac reference *)
-  try intern_ltac_variable ist r
-  with Not_found ->
-  (* A global tactic *)
-  try intern_applied_global_tactic_reference r
-  with Not_found ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
+let ((value_in : value -> Dyn.t),
+     (value_out : Dyn.t -> value)) = Dyn.create "value"
 
-(* Intern a reference parsed in a non-tactic entry *)
+let valueIn t = TacDynamic (Loc.ghost, value_in t)
+
+(** Generic arguments : table of interpretation functions *)
+
+let push_trace call ist = match TacStore.get ist.extra f_trace with
+| None -> [call]
+| Some trace -> call :: trace
+
+let propagate_trace ist loc id v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun (appl,_,lfun,it,b) ->
+        let t = if List.is_empty it then b else TacFun (it,b) in
+        let ans = VFun (appl,push_trace(loc,LtacVarCall (id,t)) ist,lfun,it,b) in
+        of_tacvalue ans
+    | _ ->  v
+  else v
+
+let append_trace trace v =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    match to_tacvalue v with
+    | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b))
+    | _ -> v
+  else v
 
-let intern_non_tactic_reference strict ist r =
-  (* An ltac reference *)
-  try Reference (intern_ltac_variable ist r)
-  with Not_found ->
-  (* A constr reference *)
-  try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
-  with Not_found ->
-  (* Tolerance for compatibility, allow not to use "ltac:" *)
-  try intern_isolated_global_tactic_reference r
-  with Not_found ->
-  (* By convention, use IntroIdentifier for unbound ident, when not in a def *)
-  match r with
-  | Ident (loc,id) when not strict -> IntroPattern (loc,IntroIdentifier id)
-  | _ ->
-  (* Reference not found *)
-  error_global_not_found_loc (qualid_of_reference r)
-
-let intern_message_token ist = function
-  | (MsgString _ | MsgInt _ as x) -> x
-  | MsgIdent id -> MsgIdent (intern_hyp_or_metaid ist id)
-
-let intern_message ist = List.map (intern_message_token ist)
-
-let rec intern_intro_pattern lf ist = function
-  | loc, IntroOrAndPattern l ->
-      loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
-  | loc, IntroIdentifier id ->
-      loc, IntroIdentifier (intern_ident lf ist id)
-  | loc, IntroFresh id ->
-      loc, IntroFresh (intern_ident lf ist id)
-  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
-      as x -> x
-
-and intern_or_and_intro_pattern lf ist =
-  List.map (List.map (intern_intro_pattern lf ist))
-
-let intern_quantified_hypothesis ist = function
-  | AnonHyp n -> AnonHyp n
-  | NamedHyp id ->
-      (* Uncomment to disallow "intros until n" in ltac when n is not bound *)
-      NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*))
-
-let intern_binding_name ist x =
-  (* We use identifier both for variables and binding names *)
-  (* Todo: consider the body of the lemma to which the binding refer
-     and if a term w/o ltac vars, check the name is indeed quantified *)
-  x
-
-let intern_constr_gen allow_patvar isarity {ltacvars=lfun; gsigma=sigma; genv=env} c =
-  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
-  let c' =
-    warn (Constrintern.intern_gen isarity ~allow_patvar ~ltacvars:(fst lfun,[]) sigma env) c
+(* Dynamically check that an argument is a tactic *)
+let coerce_to_tactic loc id v =
+  let v = Value.normalize v in
+  let fail () = user_err_loc
+    (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
   in
-  (c',if !strict_check then None else Some c)
-
-let intern_constr = intern_constr_gen false false
-let intern_type = intern_constr_gen false true
-
-(* Globalize bindings *)
-let intern_binding ist (loc,b,c) =
-  (loc,intern_binding_name ist b,intern_constr ist c)
-
-let intern_bindings ist = function
-  | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
-
-let intern_constr_with_bindings ist (c,bl) =
-  (intern_constr ist c, intern_bindings ist bl)
-
-  (* TODO: catch ltac vars *)
-let intern_induction_arg ist = function
-  | ElimOnConstr c -> ElimOnConstr (intern_constr_with_bindings ist c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) ->
-      if !strict_check then
-	(* If in a defined tactic, no intros-until *)
-	match intern_constr ist (CRef (Ident (dloc,id))) with
-	| GVar (loc,id),_ -> ElimOnIdent (loc,id)
-	| c -> ElimOnConstr (c,NoBindings)
-      else
-	ElimOnIdent (loc,id)
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let tacv = to_tacvalue v in
+    match tacv with
+    | VFun _ -> v
+    | _ -> fail ()
+  else fail ()
 
-let short_name = function
-  | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id)
-  | _ -> None
+let value_of_ident id =
+  in_gen (topwit wit_intro_pattern)
+    (Loc.ghost, IntroNaming (IntroIdentifier id))
 
-let intern_evaluable_global_reference ist r =
-  let lqid = qualid_of_reference r in
-  try evaluable_of_global_reference ist.genv (locate_global_with_alias lqid)
-  with Not_found ->
-  match r with
-  | Ident (loc,id) when not !strict_check -> EvalVarRef id
-  | _ -> error_global_not_found_loc lqid
-
-let intern_evaluable_reference_or_by_notation ist = function
-  | AN r -> intern_evaluable_global_reference ist r
-  | ByNotation (loc,ntn,sc) ->
-      evaluable_of_global_reference ist.genv
-      (Notation.interp_notation_as_global_reference loc
-        (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)
-
-(* Globalize a reduction expression *)
-let intern_evaluable ist = function
-  | AN (Ident (loc,id)) when find_ltacvar id ist -> ArgVar (loc,id)
-  | AN (Ident (loc,id)) when not !strict_check & find_hyp id ist ->
-      ArgArg (EvalVarRef id, Some (loc,id))
-  | AN (Ident (loc,id)) when find_ctxvar id ist ->
-      ArgArg (EvalVarRef id, if !strict_check then None else Some (loc,id))
-  | r ->
-      let e = intern_evaluable_reference_or_by_notation ist r in
-      let na = short_name r in
-      ArgArg (e,na)
-
-let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
-
-let intern_flag ist red =
-  { red with rConst = List.map (intern_evaluable ist) red.rConst }
-
-let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c)
-
-let intern_constr_pattern ist ltacvars pc =
-  let metas,pat =
-    Constrintern.intern_constr_pattern ist.gsigma ist.genv ~ltacvars pc in
-  let c = intern_constr_gen true false ist pc in
-  metas,(c,pat)
-
-let intern_typed_pattern ist p =
-  let dummy_pat = PRel 0 in
-  (* we cannot ensure in non strict mode that the pattern is closed *)
-  (* keeping a constr_expr copy is too complicated and we want anyway to *)
-  (* type it, so we remember the pattern as a glob_constr only *)
-  (intern_constr_gen true false ist p,dummy_pat)
-
-let intern_typed_pattern_with_occurrences ist (l,p) =
-  (l,intern_typed_pattern ist p)
-
-(* This seems fairly hacky, but it's the first way I've found to get proper
-   globalization of [unfold].  --adamc *)
-let dump_glob_red_expr = function
-  | Unfold occs -> List.iter (fun (_, r) ->
-    try
-      Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
-	(Smartlocate.smart_global r)
-    with e when Errors.noncritical e -> ()) occs
-  | Cbv grf | Lazy grf ->
-    List.iter (fun r ->
-      try
-        Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r)
-	  (Smartlocate.smart_global r)
-      with e when Errors.noncritical e -> ()) grf.rConst
-  | _ -> ()
-
-let intern_red_expr ist = function
-  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
-  | Fold l -> Fold (List.map (intern_constr ist) l)
-  | Cbv f -> Cbv (intern_flag ist f)
-  | Lazy f -> Lazy (intern_flag ist f)
-  | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l)
-  | Simpl o -> Simpl (Option.map (intern_typed_pattern_with_occurrences ist) o)
-  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r
-
-let intern_in_hyp_as ist lf (id,ipat) =
-  (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat)
-
-let intern_hyp_list ist = List.map (intern_hyp_or_metaid ist)
-
-let intern_inversion_strength lf ist = function
-  | NonDepInversion (k,idl,ids) ->
-      NonDepInversion (k,intern_hyp_list ist idl,
-      Option.map (intern_intro_pattern lf ist) ids)
-  | DepInversion (k,copt,ids) ->
-      DepInversion (k, Option.map (intern_constr ist) copt,
-      Option.map (intern_intro_pattern lf ist) ids)
-  | InversionUsing (c,idl) ->
-      InversionUsing (intern_constr ist c, intern_hyp_list ist idl)
-
-(* Interprets an hypothesis name *)
-let intern_hyp_location ist (((b,occs),id),hl) =
-  (((b,List.map (intern_or_var ist) occs),intern_hyp_or_metaid ist id), hl)
-
-(* Reads a pattern *)
-let intern_pattern ist ?(as_type=false) lfun = function
-  | Subterm (b,ido,pc) ->
-      let ltacvars = (lfun,[]) in
-      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
-      ido, metas, Subterm (b,ido,pc)
-  | Term pc ->
-      let ltacvars = (lfun,[]) in
-      let (metas,pc) = intern_constr_pattern ist ltacvars pc in
-      None, metas, Term pc
-
-let intern_constr_may_eval ist = function
-  | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c)
-  | ConstrContext (locid,c) ->
-      ConstrContext (intern_hyp ist locid,intern_constr ist c)
-  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
-  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
-
-(* External tactics *)
-let print_xml_term = ref (fun _ -> failwith "print_xml_term unset")
-let declare_xml_printer f = print_xml_term := f
-
-let internalise_tacarg ch = G_xml.parse_tactic_arg ch
-
-let extern_tacarg ch env sigma = function
-  | VConstr ([],c) -> !print_xml_term ch env sigma c
-  | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
-  | VIntroPattern _  | VRec _ | VList _ | VConstr _ ->
-      error "Only externing of closed terms is implemented."
-
-let extern_request ch req gl la =
-  output_string ch "<REQUEST req=\""; output_string ch req;
-  output_string ch "\">\n";
-  List.iter (pf_apply (extern_tacarg ch) gl) la;
-  output_string ch "</REQUEST>\n"
-
-let value_of_ident id = VIntroPattern (IntroIdentifier id)
+let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2
 
 let extend_values_with_bindings (ln,lm) lfun =
-  let lnames = List.map (fun (id,id') ->(id,value_of_ident id')) ln in
-  let lmatch = List.map (fun (id,(ids,c)) -> (id,VConstr (ids,c))) lm in
+  let of_cub c = match c with
+  | [], c -> Value.of_constr c
+  | _ -> in_gen (topwit wit_constr_under_binders) c
+  in
   (* For compatibility, bound variables are visible only if no other
      binding of the same name exists *)
-  lmatch@lfun@lnames
-
-(* Reads the hypotheses of a "match goal" rule *)
-let rec intern_match_goal_hyps ist lfun = function
-  | (Hyp ((_,na) as locna,mp))::tl ->
-      let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in
-      let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in
-      let lfun' = name_cons na (Option.List.cons ido lfun) in
-      lfun', metas1@metas2, Hyp (locna,pat)::hyps
-  | (Def ((_,na) as locna,mv,mp))::tl ->
-      let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in
-      let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in
-      let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in
-      let lfun' = name_cons na (Option.List.cons ido' (Option.List.cons ido lfun)) in
-      lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps
-  | [] -> lfun, [], []
-
-(* Utilities *)
-let extract_let_names lrc =
-  List.fold_right
-    (fun ((loc,name),_) l ->
-      if List.mem name l then
-	user_err_loc
-	  (loc, "glob_tactic", str "This variable is bound several times.");
-      name::l)
-    lrc []
-
-let clause_app f = function
-    { onhyps=None; concl_occs=nl } ->
-      { onhyps=None; concl_occs=nl }
-  | { onhyps=Some l; concl_occs=nl } ->
-      { onhyps=Some(List.map f l); concl_occs=nl}
-
-(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
-let rec intern_atomic lf ist x =
-  match (x:raw_atomic_tactic_expr) with
-  (* Basic tactics *)
-  | TacIntroPattern l ->
-      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
-  | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
-  | TacIntroMove (ido,hto) ->
-      TacIntroMove (Option.map (intern_ident lf ist) ido,
-                    intern_move_location ist hto)
-  | TacAssumption -> TacAssumption
-  | TacExact c -> TacExact (intern_constr ist c)
-  | TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
-  | TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c)
-  | TacApply (a,ev,cb,inhyp) ->
-      TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb,
-                Option.map (intern_in_hyp_as ist lf) inhyp)
-  | TacElim (ev,cb,cbo) ->
-      TacElim (ev,intern_constr_with_bindings ist cb,
-               Option.map (intern_constr_with_bindings ist) cbo)
-  | TacElimType c -> TacElimType (intern_type ist c)
-  | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings ist cb)
-  | TacCaseType c -> TacCaseType (intern_type ist c)
-  | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n)
-  | TacMutualFix (b,id,n,l) ->
-      let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in
-      TacMutualFix (b,intern_ident lf ist id, n, List.map f l)
-  | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt)
-  | TacMutualCofix (b,id,l) ->
-      let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
-      TacMutualCofix (b,intern_ident lf ist id, List.map f l)
-  | TacCut c -> TacCut (intern_type ist c)
-  | TacAssert (otac,ipat,c) ->
-      TacAssert (Option.map (intern_pure_tactic ist) otac,
-                 Option.map (intern_intro_pattern lf ist) ipat,
-                 intern_constr_gen false (otac<>None) ist c)
-  | TacGeneralize cl ->
-      TacGeneralize (List.map (fun (c,na) ->
-	               intern_constr_with_occurrences ist c,
-                       intern_name lf ist na) cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
-  | TacLetTac (na,c,cls,b,eqpat) ->
-      let na = intern_name lf ist na in
-      TacLetTac (na,intern_constr ist c,
-                 (clause_app (intern_hyp_location ist) cls),b,
-		 (Option.map (intern_intro_pattern lf ist) eqpat))
-
-  (* Automation tactics *)
-  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
-  | TacAuto (d,n,lems,l) ->
-      TacAuto (d,Option.map (intern_or_var ist) n,
-        List.map (intern_constr ist) lems,l)
-
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) ->
-      TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h)
-  | TacInductionDestruct (ev,isrec,(l,el,cls)) ->
-      TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats)) ->
-	      (intern_induction_arg ist c,
-               (Option.map (intern_intro_pattern lf ist) ipato,
-	        Option.map (intern_intro_pattern lf ist) ipats))) l,
-               Option.map (intern_constr_with_bindings ist) el,
-               Option.map (clause_app (intern_hyp_location ist)) cls))
-  | TacDoubleInduction (h1,h2) ->
-      let h1 = intern_quantified_hypothesis ist h1 in
-      let h2 = intern_quantified_hypothesis ist h2 in
-      TacDoubleInduction (h1,h2)
-  | TacDecomposeAnd c -> TacDecomposeAnd (intern_constr ist c)
-  | TacDecomposeOr c -> TacDecomposeOr (intern_constr ist c)
-  | TacDecompose (l,c) -> let l = List.map (intern_inductive ist) l in
-      TacDecompose (l,intern_constr ist c)
-  | TacSpecialize (n,l) -> TacSpecialize (n,intern_constr_with_bindings ist l)
-  | TacLApply c -> TacLApply (intern_constr ist c)
-
-  (* Context management *)
-  | TacClear (b,l) -> TacClear (b,List.map (intern_hyp_or_metaid ist) l)
-  | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
-  | TacMove (dep,id1,id2) ->
-    TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2)
-  | TacRename l ->
-      TacRename (List.map (fun (id1,id2) ->
-			     intern_hyp_or_metaid ist id1,
-			     intern_hyp_or_metaid ist id2) l)
-  | TacRevert l -> TacRevert (List.map (intern_hyp_or_metaid ist) l)
-
-  (* Constructors *)
-  | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl)
-  | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl)
-  | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (intern_bindings ist) bll)
-  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (intern_pure_tactic ist) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,intern_or_var ist n,intern_bindings ist bl)
-
-  (* Conversion *)
-  | TacReduce (r,cl) ->
-      dump_glob_red_expr r;
-      TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl)
-  | TacChange (None,c,cl) ->
-      TacChange (None,
-        (if (cl.onhyps = None or cl.onhyps = Some []) &
-	    (cl.concl_occs = all_occurrences_expr or
-	     cl.concl_occs = no_occurrences_expr)
-         then intern_type ist c else intern_constr ist c),
-	clause_app (intern_hyp_location ist) cl)
-  | TacChange (Some p,c,cl) ->
-      TacChange (Some (intern_typed_pattern ist p),intern_constr ist c,
-	clause_app (intern_hyp_location ist) cl)
-
-  (* Equivalence relations *)
-  | TacReflexivity -> TacReflexivity
-  | TacSymmetry idopt ->
-      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
-  | TacTransitivity c -> TacTransitivity (Option.map (intern_constr ist) c)
-
-  (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) ->
-      TacRewrite
-	(ev,
-	List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l,
-	clause_app (intern_hyp_location ist) cl,
-	Option.map (intern_pure_tactic ist) by)
-  | TacInversion (inv,hyp) ->
-      TacInversion (intern_inversion_strength lf ist inv,
-        intern_quantified_hypothesis ist hyp)
-
-  (* For extensions *)
-  | TacExtend (loc,opn,l) ->
-      let _ = lookup_tactic opn in
-      TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l)
-  | TacAlias (loc,s,l,(dir,body)) ->
-      let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
-      TacAlias (loc,s,l,(dir,body))
-
-and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac)
-
-and intern_tactic_seq onlytac ist = function
-  | TacAtom (loc,t) ->
-      let lf = ref ist.ltacvars in
-      let t = intern_atomic lf ist t in
-      !lf, TacAtom (adjust_loc loc, t)
-  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
-  | TacLetIn (isrec,l,u) ->
-      let (l1,l2) = ist.ltacvars in
-      let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in
-      let l = List.map (fun (n,b) ->
-	  (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in
-      ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u)
-
-  | TacMatchGoal (lz,lr,lmr) ->
-      ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)
-  | TacMatch (lz,c,lmr) ->
-      ist.ltacvars,
-      TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr)
-  | TacId l -> ist.ltacvars, TacId (intern_message ist l)
-  | TacFail (n,l) ->
-      ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l)
-  | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac)
-  | TacAbstract (tac,s) ->
-      ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s)
-  | TacThen (t1,[||],t2,[||]) ->
-      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
-      let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in
-      lfun'', TacThen (t1,[||],t2,[||])
-  | TacThen (t1,tf,t2,tl) ->
-      let lfun', t1 = intern_tactic_seq onlytac ist t1 in
-      let ist' = { ist with ltacvars = lfun' } in
-      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThen (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2,
-		       Array.map (intern_pure_tactic ist') tl)
-  | TacThens (t,tl) ->
-      let lfun', t = intern_tactic_seq true ist t in
-      let ist' = { ist with ltacvars = lfun' } in
-      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
-      lfun', TacThens (t, List.map (intern_pure_tactic ist') tl)
-  | TacDo (n,tac) ->
-      ist.ltacvars, TacDo (intern_or_var ist n,intern_pure_tactic ist tac)
-  | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac)
-  | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac)
-  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac)
-  | TacTimeout (n,tac) ->
-      ist.ltacvars, TacTimeout (intern_or_var ist n,intern_tactic onlytac ist tac)
-  | TacOrelse (tac1,tac2) ->
-      ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2)
-  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l)
-  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l)
-  | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac)
-  | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a
-
-and intern_tactic_as_arg loc onlytac ist a =
-  match intern_tacarg !strict_check onlytac ist a with
-  | TacCall _ | TacExternal _ | Reference _ | TacDynamic _ as a -> TacArg (loc,a)
-  | Tacexp a -> a
-  | TacVoid | IntroPattern _ | Integer _
-  | ConstrMayEval _ | TacFreshId _ as a ->
-      if onlytac then error_tactic_expected loc else TacArg (loc,a)
-  | MetaIdArg _ -> assert false
-
-and intern_tactic_or_tacarg ist = intern_tactic false ist
-
-and intern_pure_tactic ist = intern_tactic true ist
-
-and intern_tactic_fun ist (var,body) =
-  let (l1,l2) = ist.ltacvars in
-  let lfun' = List.rev_append (Option.List.flatten var) l1 in
-  (var,intern_tactic_or_tacarg { ist with ltacvars = (lfun',l2) } body)
-
-and intern_tacarg strict onlytac ist = function
-  | TacVoid -> TacVoid
-  | Reference r -> intern_non_tactic_reference strict ist r
-  | IntroPattern ipat ->
-      let lf = ref([],[]) in (*How to know what names the intropattern binds?*)
-      IntroPattern (intern_intro_pattern lf ist ipat)
-  | Integer n -> Integer n
-  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
-  | MetaIdArg (loc,istac,s) ->
-      (* $id can occur in Grammar tactic... *)
-      let id = id_of_string s in
-      if find_ltacvar id ist then
-	if istac then Reference (ArgVar (adjust_loc loc,id))
-	else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None))
-      else error_syntactic_metavariables_not_allowed loc
-  | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f
-  | TacCall (loc,f,l) ->
-      TacCall (loc,
-        intern_applied_tactic_reference ist f,
-        List.map (intern_tacarg !strict_check false ist) l)
-  | TacExternal (loc,com,req,la) ->
-      TacExternal (loc,com,req,List.map (intern_tacarg !strict_check false ist) la)
-  | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x)
-  | Tacexp t -> Tacexp (intern_tactic onlytac ist t)
-  | TacDynamic(loc,t) as x ->
-      (match Dyn.tag t with
-	| "tactic" | "value" -> x
-        | "constr" -> if onlytac then error_tactic_expected loc else x
-	| s -> anomaly_loc (loc, "",
-                 str "Unknown dynamic: <" ++ str s ++ str ">"))
-
-(* Reads the rules of a Match Context or a Match *)
-and intern_match_rule onlytac ist = function
-  | (All tc)::tl ->
-      All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl)
-  | (Pat (rl,mp,tc))::tl ->
-      let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
-      let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in
-      let ido,metas2,pat = intern_pattern ist lfun mp in
-      let metas = list_uniquize (metas1@metas2) in
-      let ist' = { ist with ltacvars = (metas@(Option.List.cons ido lfun'),l2) } in
-      Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl)
-  | [] -> []
-
-and intern_genarg ist x =
-  match genarg_tag x with
-  | BoolArgType -> in_gen globwit_bool (out_gen rawwit_bool x)
-  | IntArgType -> in_gen globwit_int (out_gen rawwit_int x)
-  | IntOrVarArgType ->
-      in_gen globwit_int_or_var
-        (intern_or_var ist (out_gen rawwit_int_or_var x))
-  | StringArgType ->
-      in_gen globwit_string (out_gen rawwit_string x)
-  | PreIdentArgType ->
-      in_gen globwit_pre_ident (out_gen rawwit_pre_ident x)
-  | IntroPatternArgType ->
-      let lf = ref ([],[]) in
-      (* how to know which names are bound by the intropattern *)
-      in_gen globwit_intro_pattern
-        (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
-  | IdentArgType b ->
-      let lf = ref ([],[]) in
-      in_gen (globwit_ident_gen b)
-	(intern_ident lf ist (out_gen (rawwit_ident_gen b) x))
-  | VarArgType ->
-      in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x))
-  | RefArgType ->
-      in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x))
-  | SortArgType ->
-      in_gen globwit_sort (out_gen rawwit_sort x)
-  | ConstrArgType ->
-      in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x))
-  | ConstrMayEvalArgType ->
-      in_gen globwit_constr_may_eval
-        (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x))
-  | QuantHypArgType ->
-      in_gen globwit_quant_hyp
-        (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x))
-  | RedExprArgType ->
-      in_gen globwit_red_expr (intern_red_expr ist (out_gen rawwit_red_expr x))
-  | OpenConstrArgType (b1,b2) ->
-      in_gen (globwit_open_constr_gen (b1,b2))
-        ((),intern_constr ist (snd (out_gen (rawwit_open_constr_gen (b1,b2)) x)))
-  | ConstrWithBindingsArgType ->
-      in_gen globwit_constr_with_bindings
-        (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x))
-  | BindingsArgType ->
-      in_gen globwit_bindings
-        (intern_bindings ist (out_gen rawwit_bindings x))
-  | List0ArgType _ -> app_list0 (intern_genarg ist) x
-  | List1ArgType _ -> app_list1 (intern_genarg ist) x
-  | OptArgType _ -> app_opt (intern_genarg ist) x
-  | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x
-  | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n) (intern_tactic_or_tacarg ist
-	    (out_gen (rawwit_tactic n) x))
-      | None ->
-          lookup_genarg_glob s ist x
-
-(************* End globalization ************)
+  let accu = Id.Map.map value_of_ident ln in
+  let accu = lfun +++ accu in
+  Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu
 
 (***************************************************************************)
 (* Evaluation/interpretation *)
 
 let is_variable env id =
-  List.mem id (ids_of_named_context (Environ.named_context env))
+  Id.List.mem id (ids_of_named_context (Environ.named_context env))
 
 (* Debug reference *)
 let debug = ref DebugOff
@@ -1006,11 +292,10 @@ let set_debug pos = debug := pos
 (* Gives the state of debug *)
 let get_debug () = !debug
 
-let debugging_step ist pp =
-  match ist.debug with
+let debugging_step ist pp = match curr_debug ist with
   | DebugOn lev ->
       safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl())
-  | _ -> ()
+  | _ -> Proofview.NonLogical.return ()
 
 let debugging_exception_step ist signal_anomaly e pp =
   let explain_exc =
@@ -1024,63 +309,40 @@ let error_ltac_variable loc id env v s =
    strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++
    strbrk "which cannot be coerced to " ++ str s ++ str".")
 
-exception CannotCoerceTo of string
-
 (* Raise Not_found if not in interpretation sign *)
 let try_interp_ltac_var coerce ist env (loc,id) =
-  let v = List.assoc id ist.lfun in
+  let v = Id.Map.find id ist.lfun in
   try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s
 
 let interp_ltac_var coerce ist env locid =
   try try_interp_ltac_var coerce ist env locid
-  with Not_found -> anomaly ("Detected '" ^ (string_of_id (snd locid)) ^ "' as ltac var at interning time")
-
-(* Interprets an identifier which must be fresh *)
-let coerce_to_ident fresh env = function
-  | VIntroPattern (IntroIdentifier id) -> id
-  | VConstr ([],c) when isVar c & not (fresh & is_variable env (destVar c)) ->
-      (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *)
-      destVar c
-  | v -> raise (CannotCoerceTo "a fresh identifier")
-
-let interp_ident_gen fresh ist env id =
-  try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id)
+  with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time")
+
+let interp_ident_gen fresh ist env sigma id =
+  try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some (env,sigma)) (dloc,id)
   with Not_found -> id
 
 let interp_ident = interp_ident_gen false
 let interp_fresh_ident = interp_ident_gen true
-let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl)
-let pf_interp_fresh_ident id gl = interp_ident_gen true id (pf_env gl)
+let pf_interp_ident id gl = interp_ident_gen false id (pf_env gl) (project gl)
 
 (* Interprets an optional identifier which must be fresh *)
-let interp_fresh_name ist env = function
+let interp_fresh_name ist env sigma = function
   | Anonymous -> Anonymous
-  | Name id -> Name (interp_fresh_ident ist env id)
-
-let coerce_to_intro_pattern env = function
-  | VIntroPattern ipat -> ipat
-  | VConstr ([],c) when isVar c ->
-      (* This happens e.g. in definitions like "Tac H = clear H; intro H" *)
-      (* but also in "destruct H as (H,H')" *)
-      IntroIdentifier (destVar c)
-  | v -> raise (CannotCoerceTo "an introduction pattern")
-
-let interp_intro_pattern_var loc ist env id =
-  try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env) (loc,id)
-  with Not_found -> IntroIdentifier id
+  | Name id -> Name (interp_fresh_ident ist env sigma id)
 
-let coerce_to_hint_base = function
-  | VIntroPattern (IntroIdentifier id) -> string_of_id id
-  | _ -> raise (CannotCoerceTo "a hint base name")
+let interp_intro_pattern_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroNaming (IntroIdentifier id)
+
+let interp_intro_pattern_naming_var loc ist env sigma id =
+  try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id)
+  with Not_found -> IntroIdentifier id
 
 let interp_hint_base ist s =
-  try try_interp_ltac_var coerce_to_hint_base ist None (dloc,id_of_string s)
+  try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s)
   with Not_found -> s
 
-let coerce_to_int = function
-  | VInteger n -> n
-  | v -> raise (CannotCoerceTo "an integer")
-
 let interp_int ist locid =
   try try_interp_ltac_var coerce_to_int ist None locid
   with Not_found ->
@@ -1091,252 +353,313 @@ let interp_int_or_var ist = function
   | ArgVar locid -> interp_int ist locid
   | ArgArg n -> n
 
-let int_or_var_list_of_VList = function
-  | VList l -> List.map (fun n -> ArgArg (coerce_to_int n)) l
-  | _ -> raise Not_found
-
 let interp_int_or_var_as_list ist = function
   | ArgVar (_,id as locid) ->
-      (try int_or_var_list_of_VList (List.assoc id ist.lfun)
+      (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun)
        with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)])
   | ArgArg n as x -> [x]
 
 let interp_int_or_var_list ist l =
   List.flatten (List.map (interp_int_or_var_as_list ist) l)
 
-let constr_of_value env = function
-  | VConstr csr -> csr
-  | VIntroPattern (IntroIdentifier id) -> ([],constr_of_id env id)
-  | _ -> raise Not_found
-
-let closed_constr_of_value env v =
-  let ids,c = constr_of_value env v in
-  if ids <> [] then raise Not_found;
-  c
-
-let coerce_to_hyp env = function
-  | VConstr ([],c) when isVar c -> destVar c
-  | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
-  | _ -> raise (CannotCoerceTo "a variable")
-
 (* Interprets a bound variable (especially an existing hypothesis) *)
-let interp_hyp ist gl (loc,id as locid) =
-  let env = pf_env gl in
+let interp_hyp ist env sigma (loc,id as locid) =
   (* Look first in lfun for a value coercible to a variable *)
-  try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid
+  try try_interp_ltac_var (coerce_to_hyp env) ist (Some (env,sigma)) locid
   with Not_found ->
   (* Then look if bound in the proof context at calling time *)
   if is_variable env id then id
-  else user_err_loc (loc,"eval_variable",
-    str "No such hypothesis: " ++ pr_id id ++ str ".")
-
-let hyp_list_of_VList env = function
-  | VList l -> List.map (coerce_to_hyp env) l
-  | _ -> raise Not_found
+  else Loc.raise loc (Logic.RefinerError (Logic.NoSuchHyp id))
 
-let interp_hyp_list_as_list ist gl (loc,id as x) =
-  try hyp_list_of_VList (pf_env gl) (List.assoc id ist.lfun)
-  with Not_found | CannotCoerceTo _ -> [interp_hyp ist gl x]
+let interp_hyp_list_as_list ist env sigma (loc,id as x) =
+  try coerce_to_hyp_list env (Id.Map.find id ist.lfun)
+  with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x]
 
-let interp_hyp_list ist gl l =
-  List.flatten (List.map (interp_hyp_list_as_list ist gl) l)
+let interp_hyp_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l)
 
-let interp_move_location ist gl = function
-  | MoveAfter id -> MoveAfter (interp_hyp ist gl id)
-  | MoveBefore id -> MoveBefore (interp_hyp ist gl id)
-  | MoveToEnd toleft as x -> x
+let interp_move_location ist env sigma = function
+  | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id)
+  | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id)
+  | MoveFirst -> MoveFirst
+  | MoveLast -> MoveLast
 
-(* Interprets a qualified name *)
-let coerce_to_reference env v =
-  try match v with
-  | VConstr ([],c) -> global_of_constr c (* may raise Not_found *)
-  | _ -> raise Not_found
-  with Not_found -> raise (CannotCoerceTo "a reference")
-
-let interp_reference ist env = function
+let interp_reference ist env sigma = function
   | ArgArg (_,r) -> r
-  | ArgVar locid ->
-      interp_ltac_var (coerce_to_reference env) ist (Some env) locid
-
-let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
-
-let coerce_to_inductive = function
-  | VConstr ([],c) when isInd c -> destInd c
-  | _ -> raise (CannotCoerceTo "an inductive type")
-
-let interp_inductive ist = function
-  | ArgArg r -> r
-  | ArgVar locid -> interp_ltac_var coerce_to_inductive ist None locid
-
-let coerce_to_evaluable_ref env v =
-  let ev = match v with
-    | VConstr ([],c) when isConst c -> EvalConstRef (destConst c)
-    | VConstr ([],c) when isVar c -> EvalVarRef (destVar c)
-    | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env)
-	-> EvalVarRef id
-    | _ -> raise (CannotCoerceTo "an evaluable reference")
-  in
-  if not (Tacred.is_evaluable env ev) then
-    raise (CannotCoerceTo "an evaluable reference")
-  else
-    ev
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try
+        let (v, _, _) = Environ.lookup_named id env in
+        VarRef v
+      with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)
 
-let interp_evaluable ist env = function
+let try_interp_evaluable env (loc, id) =
+  let v = Environ.lookup_named id env in
+  match v with
+  | (_, Some _, _) -> EvalVarRef id
+  | _ -> error_not_evaluable (VarRef id)
+
+let interp_evaluable ist env sigma = function
   | ArgArg (r,Some (loc,id)) ->
-      (* Maybe [id] has been introduced by Intro-like tactics *)
-      (try match Environ.lookup_named id env with
-       | (_,Some _,_) -> EvalVarRef id
-       | _ -> error_not_evaluable (VarRef id)
-       with Not_found ->
-       match r with
-       | EvalConstRef _ -> r
-       | _ -> error_global_not_found_loc (loc,qualid_of_ident id))
+    (* Maybe [id] has been introduced by Intro-like tactics *)
+    begin
+      try try_interp_evaluable env (loc, id)
+      with Not_found ->
+        match r with
+        | EvalConstRef _ -> r
+        | _ -> error_global_not_found_loc loc (qualid_of_ident id)
+    end
   | ArgArg (r,None) -> r
-  | ArgVar locid ->
-      interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid
+  | ArgVar (loc, id) ->
+    try try_interp_ltac_var (coerce_to_evaluable_ref env) ist (Some (env,sigma)) (loc, id)
+    with Not_found ->
+      try try_interp_evaluable env (loc, id)
+      with Not_found -> error_global_not_found_loc loc (qualid_of_ident id)
 
 (* Interprets an hypothesis name *)
-let interp_occurrences ist (b,occs) =
-  (b,interp_int_or_var_list ist occs)
+let interp_occurrences ist occs =
+  Locusops.occurrences_map (interp_int_or_var_list ist) occs
+
+let interp_hyp_location ist env sigma ((occs,id),hl) =
+  ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl)
 
-let interp_hyp_location ist gl ((occs,id),hl) =
-  ((interp_occurrences ist occs,interp_hyp ist gl id),hl)
+let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) =
+  match occs,hl with
+  | AllOccurrences,InHyp ->
+      List.map (fun id -> ((AllOccurrences,id),InHyp))
+        (interp_hyp_list_as_list ist env sigma id)
+  | _,_ -> [interp_hyp_location ist env sigma x]
 
-let interp_clause ist gl { onhyps=ol; concl_occs=occs } =
-  { onhyps=Option.map(List.map (interp_hyp_location ist gl)) ol;
+let interp_hyp_location_list ist env sigma l =
+  List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l)
+
+let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause =
+  { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol;
     concl_occs=interp_occurrences ist occs }
 
 (* Interpretation of constructions *)
 
 (* Extract the constr list from lfun *)
 let extract_ltac_constr_values ist env =
-  let rec aux = function
-  | (id,v)::tl ->
-      let (l1,l2) = aux tl in
-      (try ((id,constr_of_value env v)::l1,l2)
-       with Not_found ->
-	 let ido = match v with
-	   | VIntroPattern (IntroIdentifier id0) -> Some id0
-	   | _ -> None in
-	 (l1,(id,ido)::l2))
-  | [] -> ([],[]) in
-  aux ist.lfun
+  let fold id v accu =
+    try
+      let c = coerce_to_constr env v in
+      Id.Map.add id c accu
+    with CannotCoerceTo _ -> accu
+  in
+  Id.Map.fold fold ist.lfun Id.Map.empty
+(** ppedrot: I have changed the semantics here. Before this patch, closure was
+    implemented as a list and a variable could be bound several times with
+    different types, resulting in its possible appearance on both sides. This
+    could barely be defined as a feature... *)
 
 (* Extract the identifier list from lfun: join all branches (what to do else?)*)
 let rec intropattern_ids (loc,pat) = match pat with
-  | IntroIdentifier id -> [id]
-  | IntroOrAndPattern ll ->
+  | IntroNaming (IntroIdentifier id) -> [id]
+  | IntroAction (IntroOrAndPattern ll) ->
       List.flatten (List.map intropattern_ids (List.flatten ll))
-  | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _
+  | IntroAction (IntroInjection l) ->
+      List.flatten (List.map intropattern_ids l)
+  | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat
+  | IntroNaming (IntroAnonymous | IntroFresh _)
+  | IntroAction (IntroWildcard | IntroRewrite _)
   | IntroForthcoming _ -> []
 
-let rec extract_ids ids = function
-  | (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
-      intropattern_ids (dloc,ipat) @ extract_ids ids tl
-  | _::tl -> extract_ids ids tl
-  | [] -> []
+let extract_ids ids lfun =
+  let fold id v accu =
+    let v = Value.normalize v in
+    if has_type v (topwit wit_intro_pattern) then
+      let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
+      if Id.List.mem id ids then accu
+      else accu @ intropattern_ids (dloc, ipat)
+    else accu
+  in
+  Id.Map.fold fold lfun []
 
-let default_fresh_id = id_of_string "H"
+let default_fresh_id = Id.of_string "H"
 
-let interp_fresh_id ist env l =
-  let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in
-  let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in
+let interp_fresh_id ist env sigma l =
+  let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in
+  let avoid = match TacStore.get ist.extra f_avoid_ids with
+  | None -> []
+  | Some l -> l
+  in
+  let avoid = (extract_ids ids ist.lfun) @ avoid in
   let id =
-    if l = [] then default_fresh_id
+    if List.is_empty l then default_fresh_id
     else
       let s =
 	String.concat "" (List.map (function
 	  | ArgArg s -> s
-	  | ArgVar (_,id) -> string_of_id (interp_ident ist env id)) l) in
+	  | ArgVar (_,id) -> Id.to_string (interp_ident ist env sigma id)) l) in
       let s = if Lexer.is_keyword s then s^"0" else s in
-      id_of_string s in
+      Id.of_string s in
   Tactics.fresh_id_in_env avoid id env
 
-let pf_interp_fresh_id ist gl = interp_fresh_id ist (pf_env gl)
 
-let interp_gen kind ist allow_patvar expand_evar fail_evar use_classes env sigma (c,ce) =
-  let (ltacvars,unbndltacvars as vars) = extract_ltac_constr_values ist env in
+
+(* Extract the uconstr list from lfun *)
+let extract_ltac_constr_context ist env =
+  let open Glob_term in
+  let add_uconstr id env v map =
+    try Id.Map.add id (coerce_to_uconstr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_constr id env v map =
+    try Id.Map.add id (coerce_to_constr env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let add_ident id env v map =
+    try Id.Map.add id (coerce_to_ident false env v) map
+    with CannotCoerceTo _ -> map
+  in
+  let fold id v {idents;typed;untyped} =
+    let idents = add_ident id env v idents in
+    let typed = add_constr id env v typed in
+    let untyped = add_uconstr id env v untyped in
+    { idents ; typed ; untyped }
+  in
+  let empty =  { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in
+  Id.Map.fold fold ist.lfun empty
+
+(** Significantly simpler than [interp_constr], to interpret an
+    untyped constr, it suffices to adjoin a closure environment. *)
+let interp_uconstr ist env = function
+  | (term,None) ->
+      { closure = extract_ltac_constr_context ist env ; term }
+  | (_,Some ce) ->
+      let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env in
+      let ltacvars = {
+        Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped));
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      { closure ; term =  intern_gen WithoutTypeConstraint ~ltacvars env ce }
+
+let interp_gen kind ist allow_patvar flags env sigma (c,ce) =
+  let constrvars = extract_ltac_constr_context ist env in
+  let vars = {
+    Pretyping.ltac_constrs = constrvars.typed;
+    Pretyping.ltac_uconstrs = constrvars.untyped;
+    Pretyping.ltac_idents = constrvars.idents;
+    Pretyping.ltac_genargs = ist.lfun;
+  } in
   let c = match ce with
   | None -> c
     (* If at toplevel (ce<>None), the error can be due to an incorrect
        context at globalization time: we retype with the now known
        intros/lettac/inversion hypothesis names *)
   | Some c ->
-      let ltacdata = (List.map fst ltacvars,unbndltacvars) in
-      intern_gen (kind = IsType) ~allow_patvar ~ltacvars:ltacdata sigma env c
+      let constr_context =
+        Id.Set.union
+          (Id.Map.domain constrvars.typed)
+       (Id.Set.union
+          (Id.Map.domain constrvars.untyped)
+          (Id.Map.domain constrvars.idents))
+      in
+      let ltacvars = {
+        ltac_vars = constr_context;
+        ltac_bound = Id.Map.domain ist.lfun;
+      } in
+      intern_gen kind ~allow_patvar ~ltacvars env c
   in
-  let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in
-  let evdc =
-    catch_error trace 
-      (understand_ltac ~resolve_classes:use_classes expand_evar sigma env vars kind) c in
+  let trace =
+    push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in
   let (evd,c) =
-    if expand_evar then
-      solve_remaining_evars fail_evar use_classes
-        solve_by_implicit_tactic env sigma evdc
-    else
-      evdc in
-  db_constr ist.debug env c;
+    catch_error trace (understand_ltac flags env sigma vars kind) c
+  in
+  (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+     function already use effect, I call [run] hoping it doesn't mess
+     up with any assumption. *)
+  Proofview.NonLogical.run (db_constr (curr_debug ist) env c);
   (evd,c)
 
+let constr_flags = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = true;
+  expand_evars = true }
+
 (* Interprets a constr; expects evars to be solved *)
 let interp_constr_gen kind ist env sigma c =
-  interp_gen kind ist false true true true env sigma c
+  interp_gen kind ist false constr_flags env sigma c
 
-let interp_constr = interp_constr_gen (OfType None)
+let interp_constr = interp_constr_gen WithoutTypeConstraint
 
 let interp_type = interp_constr_gen IsType
 
-(* Interprets an open constr *)
-let interp_open_constr_gen kind ist =
-  interp_gen kind ist false true false false
+let open_constr_use_classes_flags = {
+  use_typeclasses = true;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let open_constr_no_classes_flags = {
+  use_typeclasses = false;
+  use_unif_heuristics = true;
+  use_hook = Some solve_by_implicit_tactic;
+  fail_evar = false;
+  expand_evars = true }
+
+let pure_open_constr_flags = {
+  use_typeclasses = false;
+  use_unif_heuristics = true;
+  use_hook = None;
+  fail_evar = false;
+  expand_evars = false }
 
-(* wTC is for retrocompatibility: TC resolution started only if needed *)
-let interp_open_constr ccl wTC ist e s t =
-  try interp_gen (OfType ccl) ist false true false (ccl<>None) e s t
-  with ex when Pretype_errors.precatchable_exception ex && ccl = None && wTC ->
-    interp_gen (OfType ccl) ist false true false true e s t
+(* Interprets an open constr *)
+let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist =
+  let flags =
+    if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags
+    else open_constr_use_classes_flags in
+  interp_gen expected_type ist false flags
 
 let interp_pure_open_constr ist =
-  interp_gen (OfType None) ist false false false false
+  interp_gen WithoutTypeConstraint ist false pure_open_constr_flags
 
 let interp_typed_pattern ist env sigma (c,_) =
   let sigma, c =
-    interp_gen (OfType None) ist true false false false env sigma c in
-  pattern_of_constr sigma c
+    interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in
+  pattern_of_constr env sigma c
 
 (* Interprets a constr expression casted by the current goal *)
 let pf_interp_casted_constr ist gl c =
-  interp_constr_gen (OfType (Some (pf_concl gl))) ist (pf_env gl) (project gl) c
+  interp_constr_gen (OfType (pf_concl gl)) ist (pf_env gl) (project gl) c
 
 (* Interprets a constr expression *)
 let pf_interp_constr ist gl =
   interp_constr ist (pf_env gl) (project gl)
 
-let constr_list_of_VList env = function
-  | VList l -> List.map (closed_constr_of_value env) l
-  | _ -> raise Not_found
+let new_interp_constr ist c k =
+  let open Proofview in
+  Proofview.Goal.enter begin fun gl ->
+    let (sigma, c) = interp_constr ist (Goal.env gl) (Goal.sigma gl) c in
+    Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c)
+  end
 
 let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l =
   let try_expand_ltac_var sigma x =
     try match dest_fun x with
-    | GVar (_,id), _ ->	
-        sigma,
-        List.map inj_fun (constr_list_of_VList env (List.assoc id ist.lfun))
+    | GVar (_,id), _ ->
+      let v = Id.Map.find id ist.lfun in
+      sigma, List.map inj_fun (coerce_to_constr_list env v)
     | _ ->
         raise Not_found
-    with Not_found ->
-      (*all of dest_fun, List.assoc, constr_list_of_VList may raise Not_found*)
+    with CannotCoerceTo _ | Not_found ->
+      (* dest_fun, List.assoc may raise Not_found *)
       let sigma, c = interp_fun ist env sigma x in
       sigma, [c] in
-  let sigma, l = list_fold_map try_expand_ltac_var sigma l in
+  let sigma, l = List.fold_map try_expand_ltac_var sigma l in
   sigma, List.flatten l
 
 let interp_constr_list ist env sigma c =
   interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c
 
 let interp_open_constr_list =
-  interp_constr_in_compound_list (fun x -> x) (fun x -> x)
-    (interp_open_constr None false)
+  interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr
 
 let interp_auto_lemmas ist env sigma lems =
   let local_sigma, lems = interp_open_constr_list ist env sigma lems in
@@ -1347,154 +670,231 @@ let pf_interp_type ist gl =
   interp_type ist (pf_env gl) (project gl)
 
 (* Interprets a reduction expression *)
-let interp_unfold ist env (occs,qid) =
-  (interp_occurrences ist occs,interp_evaluable ist env qid)
+let interp_unfold ist env sigma (occs,qid) =
+  (interp_occurrences ist occs,interp_evaluable ist env sigma qid)
 
-let interp_flag ist env red =
-  { red with rConst = List.map (interp_evaluable ist env) red.rConst }
+let interp_flag ist env sigma red =
+  { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst }
 
-let interp_constr_with_occurrences ist sigma env (occs,c) =
-  let (sigma,c_interp) = interp_constr ist sigma env c in
+let interp_constr_with_occurrences ist env sigma (occs,c) =
+  let (sigma,c_interp) = interp_constr ist env sigma c in
   sigma , (interp_occurrences ist occs, c_interp)
 
-let interp_typed_pattern_with_occurrences ist env sigma (occs,c) =
-  let sign,p = interp_typed_pattern ist env sigma c in
-  sign, (interp_occurrences ist occs, p)
-
-let interp_closed_typed_pattern_with_occurrences ist env sigma occl =
-  snd (interp_typed_pattern_with_occurrences ist env sigma occl)
+let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) =
+  let p = match a with
+  | Inl b -> Inl (interp_evaluable ist env sigma b)
+  | Inr c -> Inr (snd (interp_typed_pattern ist env sigma c)) in
+  interp_occurrences ist occs, p
 
 let interp_constr_with_occurrences_and_name_as_list =
   interp_constr_in_compound_list
-    (fun c -> ((all_occurrences_expr,c),Anonymous))
-    (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c
+    (fun c -> ((AllOccurrences,c),Anonymous))
+    (function ((occs,c),Anonymous) when occs == AllOccurrences -> c
       | _ -> raise Not_found)
     (fun ist env sigma (occ_c,na) ->
       let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in
       sigma, (c_interp,
-       interp_fresh_name ist env na))
+       interp_fresh_name ist env sigma na))
 
-let interp_red_expr ist sigma env = function
-  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env) l)
+let interp_red_expr ist env sigma = function
+  | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l)
   | Fold l ->
     let (sigma,l_interp) = interp_constr_list ist env sigma l in
     sigma , Fold l_interp
-  | Cbv f -> sigma , Cbv (interp_flag ist env f)
-  | Lazy f -> sigma , Lazy (interp_flag ist env f)
+  | Cbv f -> sigma , Cbv (interp_flag ist env sigma f)
+  | Cbn f -> sigma , Cbn (interp_flag ist env sigma f)
+  | Lazy f -> sigma , Lazy (interp_flag ist env sigma f)
   | Pattern l ->
-    let (sigma,l_interp) =
-      List.fold_right begin fun c (sigma,acc) ->
-	let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma c in
-	sigma , c_interp :: acc
-      end l (sigma,[])
-    in
-    sigma , Pattern l_interp
-  | Simpl o ->
-      sigma , Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
-  | (Red _ |  Hnf | ExtraRedExpr _ | CbvVm as r) -> sigma , r
-
-let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
-
-let interp_may_eval f ist gl = function
+      let (sigma,l_interp) =
+        Evd.MonadR.List.map_right
+          (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma
+      in
+      sigma , Pattern l_interp
+  | Simpl (f,o) ->
+     sigma , Simpl (interp_flag ist env sigma f,
+		    Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvVm o ->
+    sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | CbvNative o ->
+    sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
+  | (Red _ |  Hnf | ExtraRedExpr _ as r) -> sigma , r
+
+let interp_may_eval f ist env sigma = function
   | ConstrEval (r,c) ->
-      let (sigma,redexp) = pf_interp_red_expr ist gl r in
-      let (sigma,c_interp) = f ist { gl with sigma=sigma } c in
-      sigma , pf_reduction_of_red_expr gl redexp c_interp
+      let (sigma,redexp) = interp_red_expr ist env sigma r in
+      let (sigma,c_interp) = f ist env sigma c in
+      (fst (Redexpr.reduction_of_red_expr env redexp) env sigma c_interp)
   | ConstrContext ((loc,s),c) ->
       (try
-	let (sigma,ic) = f ist gl c
-	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
-	sigma , subst_meta [special_meta,ic] ctxt
+	let (sigma,ic) = f ist env sigma c in
+	let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in
+	let evdref = ref sigma in
+	let c = subst_meta [Constr_matching.special_meta,ic] ctxt in
+	let c = Typing.solve_evars env evdref c in
+	!evdref , c
       with
 	| Not_found ->
 	    user_err_loc (loc, "interp_may_eval",
 	    str "Unbound context identifier" ++ pr_id s ++ str"."))
   | ConstrTypeOf c ->
-      let (sigma,c_interp) = f ist gl c in
-      sigma , pf_type_of gl c_interp
+      let (sigma,c_interp) = f ist env sigma c in
+      Typing.e_type_of ~refresh:true env sigma c_interp
   | ConstrTerm c ->
      try
-	f ist gl c
+	f ist env sigma c
      with reraise ->
-       debugging_exception_step ist false reraise (fun () ->
-         str"interpretation of term " ++ pr_glob_constr_env (pf_env gl) (fst c));
-       raise reraise
+       let reraise = Errors.push reraise in
+       (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () ->
+         str"interpretation of term " ++ pr_glob_constr_env env (fst c)));
+       iraise reraise
 
 (* Interprets a constr expression possibly to first evaluate *)
-let interp_constr_may_eval ist gl c =
+let interp_constr_may_eval ist env sigma c =
   let (sigma,csr) =
     try
-      interp_may_eval pf_interp_constr ist gl c
+      interp_may_eval interp_constr ist env sigma c
     with reraise ->
-      debugging_exception_step ist false reraise (fun () ->
-        str"evaluation of term");
-      raise reraise
+      let reraise = Errors.push reraise in
+      (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+          function already use effect, I call [run] hoping it doesn't mess
+          up with any assumption. *)
+       Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term"));
+      iraise reraise
   in
   begin
-    db_constr ist.debug (pf_env gl) csr;
+    (* spiwack: to avoid unnecessary modifications of tacinterp, as this
+       function already use effect, I call [run] hoping it doesn't mess
+       up with any assumption. *)
+    Proofview.NonLogical.run (db_constr (curr_debug ist) env csr);
     sigma , csr
   end
 
-let rec message_of_value gl = function
-  | VVoid -> str "()"
-  | VInteger n -> int n
-  | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
-  | VConstr_context c -> pr_constr_env (pf_env gl) c
-  | VConstr c -> pr_constr_under_binders_env (pf_env gl) c
-  | VRec _ | VRTactic _ | VFun _ -> str "<tactic>"
-  | VList l -> prlist_with_sep spc (message_of_value gl) l
-
-let rec interp_message_token ist gl = function
-  | MsgString s -> str s
-  | MsgInt n -> int n
+(** TODO: should use dedicated printers *)
+let rec message_of_value v =
+  let v = Value.normalize v in
+  let open Tacmach.New in
+  let open Ftactic in
+  if has_type v (topwit wit_tacvalue) then
+    Ftactic.return (str "<tactic>")
+  else if has_type v (topwit wit_constr) then
+    let v = out_gen (topwit wit_constr) v in
+    Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) v) end
+  else if has_type v (topwit wit_constr_under_binders) then
+    let c = out_gen (topwit wit_constr_under_binders) v in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Proofview.Goal.sigma gl) c)
+    end
+  else if has_type v (topwit wit_unit) then
+    Ftactic.return (str "()")
+  else if has_type v (topwit wit_int) then
+    Ftactic.return (int (out_gen (topwit wit_int) v))
+  else if has_type v (topwit wit_intro_pattern) then
+    let p = out_gen (topwit wit_intro_pattern) v in
+    let print env sigma c = pr_constr_env env sigma (snd (c env Evd.empty)) in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Proofview.Goal.sigma gl) c) p)
+    end
+  else if has_type v (topwit wit_constr_context) then
+    let c = out_gen (topwit wit_constr_context) v in
+    Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Proofview.Goal.sigma gl) c) end
+  else if has_type v (topwit wit_uconstr) then
+    let c = out_gen (topwit wit_uconstr) v in
+    Ftactic.nf_enter begin fun gl ->
+      Ftactic.return (pr_closed_glob_env (pf_env gl)
+                        (Proofview.Goal.sigma gl) c)
+    end
+  else match Value.to_list v with
+  | Some l ->
+    Ftactic.List.map message_of_value l >>= fun l ->
+    Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+  | None ->
+    let tag = pr_argument_type (genarg_tag v) in
+    Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *)
+
+let interp_message_token ist = function
+  | MsgString s -> Ftactic.return (str s)
+  | MsgInt n -> Ftactic.return (int n)
   | MsgIdent (loc,id) ->
-      let v =
-	try List.assoc id ist.lfun
-	with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in
-      message_of_value gl v
-
-let rec interp_message_nl ist gl = function
-  | [] -> mt()
-  | l -> prlist_with_sep spc (interp_message_token ist gl) l ++ fnl()
-
-let interp_message ist gl l =
-  (* Force evaluation of interp_message_token so that potential errors
-     are raised now and not at printing time *)
-  prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist gl) l)
-
-let intro_pattern_list_of_Vlist loc env = function
-  | VList l -> List.map (fun a -> loc,coerce_to_intro_pattern env a) l
-  | _ -> raise Not_found
-
-let rec interp_intro_pattern ist gl = function
-  | loc, IntroOrAndPattern l ->
-      loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l)
-  | loc, IntroIdentifier id ->
-      loc, interp_intro_pattern_var loc ist (pf_env gl) id
-  | loc, IntroFresh id ->
-      loc, IntroFresh (interp_fresh_ident ist (pf_env gl) id)
-  | loc, (IntroWildcard | IntroAnonymous | IntroRewrite _ | IntroForthcoming _)
-      as x -> x
-
-and interp_or_and_intro_pattern ist gl =
-  List.map (interp_intro_pattern_list_as_list ist gl)
-
-and interp_intro_pattern_list_as_list ist gl = function
-  | [loc,IntroIdentifier id] as l ->
-      (try intro_pattern_list_of_Vlist loc (pf_env gl) (List.assoc id ist.lfun)
+    let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in
+    match v with
+    | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found."))
+    | Some v -> message_of_value v
+
+let interp_message ist l =
+  let open Ftactic in
+  Ftactic.List.map (interp_message_token ist) l >>= fun l ->
+  Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+
+let interp_message ist l =
+  let open Ftactic in
+  Ftactic.List.map (interp_message_token ist) l >>= fun l ->
+  Ftactic.return (prlist_with_sep spc (fun x -> x) l)
+
+let rec interp_intro_pattern ist env sigma = function
+  | loc, IntroAction pat ->
+      let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in
+      sigma, (loc, IntroAction pat)
+  | loc, IntroNaming (IntroIdentifier id) ->
+      sigma, (loc, interp_intro_pattern_var loc ist env sigma id)
+  | loc, IntroNaming pat ->
+      sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat))
+  | loc, IntroForthcoming _  as x -> sigma, x
+
+and interp_intro_pattern_naming loc ist env sigma = function
+  | IntroFresh id -> IntroFresh (interp_fresh_ident ist env sigma id)
+  | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id
+  | IntroAnonymous as x -> x
+
+and interp_intro_pattern_action ist env sigma = function
+  | IntroOrAndPattern l ->
+      let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in
+      sigma, IntroOrAndPattern l
+  | IntroInjection l ->
+      let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
+      sigma, IntroInjection l
+  | IntroApplyOn (c,ipat) ->
+      let c = fun env sigma -> interp_constr ist env sigma c in
+      let sigma,ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, IntroApplyOn (c,ipat)
+  | IntroWildcard | IntroRewrite _ as x -> sigma, x
+
+and interp_or_and_intro_pattern ist env sigma =
+  List.fold_map (interp_intro_pattern_list_as_list ist env) sigma
+
+and interp_intro_pattern_list_as_list ist env sigma = function
+  | [loc,IntroNaming (IntroIdentifier id)] as l ->
+      (try sigma, coerce_to_intro_pattern_list loc env (Id.Map.find id ist.lfun)
        with Not_found | CannotCoerceTo _ ->
-	List.map (interp_intro_pattern ist gl) l)
-  | l -> List.map (interp_intro_pattern ist gl) l
-
-let interp_in_hyp_as ist gl (id,ipat) =
-  (interp_hyp ist gl id,Option.map (interp_intro_pattern ist gl) ipat)
-
-(* Quantified named or numbered hypothesis or hypothesis in context *)
-(* (as in Inversion) *)
-let coerce_to_quantified_hypothesis = function
-  | VInteger n -> AnonHyp n
-  | VIntroPattern (IntroIdentifier id) -> NamedHyp id
-  | v -> raise (CannotCoerceTo "a quantified hypothesis")
+         List.fold_map (interp_intro_pattern ist env) sigma l)
+  | l -> List.fold_map (interp_intro_pattern ist env) sigma l
+
+let interp_intro_pattern_naming_option ist env sigma = function
+  | None -> None
+  | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat)
+
+let interp_or_and_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some (ArgVar (loc,id)) ->
+      (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with
+      | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l)
+      | _ ->
+        raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern"))
+  | Some (ArgArg (loc,l)) ->
+      let sigma,l = interp_or_and_intro_pattern ist env sigma l in
+      sigma, Some (loc,l)
+
+let interp_intro_pattern_option ist env sigma = function
+  | None -> sigma, None
+  | Some ipat ->
+      let sigma, ipat = interp_intro_pattern ist env sigma ipat in
+      sigma, Some ipat
+
+let interp_in_hyp_as ist env sigma (clear,id,ipat) =
+  let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in
+  sigma,(clear,interp_hyp ist env sigma id,ipat)
 
 let interp_quantified_hypothesis ist = function
   | AnonHyp n -> AnonHyp n
@@ -1511,25 +911,15 @@ let interp_binding_name ist = function
       try try_interp_ltac_var coerce_to_quantified_hypothesis ist None(dloc,id)
       with Not_found -> NamedHyp id
 
-(* Quantified named or numbered hypothesis or hypothesis in context *)
-(* (as in Inversion) *)
-let coerce_to_decl_or_quant_hyp env = function
-  | VInteger n -> AnonHyp n
-  | v ->
-      try NamedHyp (coerce_to_hyp env v)
-      with CannotCoerceTo _ ->
-	raise (CannotCoerceTo "a declared or quantified hypothesis")
-
-let interp_declared_or_quantified_hypothesis ist gl = function
+let interp_declared_or_quantified_hypothesis ist env sigma = function
   | AnonHyp n -> AnonHyp n
   | NamedHyp id ->
-      let env = pf_env gl in
       try try_interp_ltac_var
-	    (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id)
+	    (coerce_to_decl_or_quant_hyp env) ist (Some (env,sigma)) (dloc,id)
       with Not_found -> NamedHyp id
 
 let interp_binding ist env sigma (loc,b,c) =
-  let sigma, c = interp_open_constr None false ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (loc,interp_binding_name ist b,c)
 
 let interp_bindings ist env sigma = function
@@ -1539,63 +929,85 @@ let interp_bindings ist env sigma = function
     let sigma, l = interp_open_constr_list ist env sigma l in   
     sigma, ImplicitBindings l
 | ExplicitBindings l ->
-    let sigma, l = list_fold_map (interp_binding ist env) sigma l in
+    let sigma, l = List.fold_map (interp_binding ist env) sigma l in
     sigma, ExplicitBindings l
 
 let interp_constr_with_bindings ist env sigma (c,bl) =
   let sigma, bl = interp_bindings ist env sigma bl in
-  let sigma, c = interp_open_constr None false ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (c,bl)
 
-let interp_open_constr_with_bindings wTC ist env sigma (c,bl) =
+let interp_constr_with_bindings_arg ist env sigma (keep,c) =
+  let sigma, c = interp_constr_with_bindings ist env sigma c in
+  sigma, (keep,c)
+
+let interp_open_constr_with_bindings ist env sigma (c,bl) =
   let sigma, bl = interp_bindings ist env sigma bl in
-  let sigma, c = interp_open_constr None wTC ist env sigma c in
+  let sigma, c = interp_open_constr ist env sigma c in
   sigma, (c, bl)
 
+let interp_open_constr_with_bindings_arg ist env sigma (keep,c) =
+  let sigma, c = interp_open_constr_with_bindings ist env sigma c in
+  sigma,(keep,c)
+
 let loc_of_bindings = function
-| NoBindings -> dummy_loc
-| ImplicitBindings l -> loc_of_glob_constr (fst (list_last l))
-| ExplicitBindings l -> pi1 (list_last l)
+| NoBindings -> Loc.ghost
+| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l))
+| ExplicitBindings l -> pi1 (List.last l)
 
-let interp_open_constr_with_bindings_loc wTC ist env sigma ((c,_),bl as cb) =
+let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) =
   let loc1 = loc_of_glob_constr c in
   let loc2 = loc_of_bindings bl in
-  let loc = if loc2 = dummy_loc then loc1 else join_loc loc1 loc2 in
-  let sigma, cb = interp_open_constr_with_bindings wTC ist env sigma cb in
-  sigma, (loc,cb)
+  let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in
+  let f env sigma = interp_open_constr_with_bindings ist env sigma cb in
+    (loc,f)
 
 let interp_induction_arg ist gl arg =
-  let env = pf_env gl and sigma = project gl in
   match arg with
-  | ElimOnConstr c ->
-      ElimOnConstr (interp_constr_with_bindings ist env sigma c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent (loc,id) ->
+  | keep,ElimOnConstr c ->
+      keep,ElimOnConstr (fun env sigma -> interp_constr_with_bindings ist env sigma c)
+  | keep,ElimOnAnonHyp n as x -> x
+  | keep,ElimOnIdent (loc,id) ->
+      let error () = user_err_loc (loc, "",
+        strbrk "Cannot coerce " ++ pr_id id ++
+        strbrk " neither to a quantified hypothesis nor to a term.")
+      in
+      let try_cast_id id' =
+        if Tactics.is_quantified_hypothesis id' gl
+        then keep,ElimOnIdent (loc,id')
+        else
+          (try keep,ElimOnConstr (fun env sigma -> sigma,(constr_of_id env id',NoBindings))
+          with Not_found ->
+            user_err_loc (loc,"",
+            pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis."))
+      in
       try
-        match List.assoc id ist.lfun with
-	| VInteger n ->
-	    ElimOnAnonHyp n
-	| VIntroPattern (IntroIdentifier id') ->
-	    if Tactics.is_quantified_hypothesis id' gl
-	    then ElimOnIdent (loc,id')
-	    else
-	      (try ElimOnConstr (sigma,(constr_of_id env id',NoBindings))
-	       with Not_found ->
-		user_err_loc (loc,"",
-		pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis."))
-	| VConstr ([],c) ->
-	    ElimOnConstr (sigma,(c,NoBindings))
-	| _ -> user_err_loc (loc,"",
-	      strbrk "Cannot coerce " ++ pr_id id ++
-	      strbrk " neither to a quantified hypothesis nor to a term.")
+        (** FIXME: should be moved to taccoerce *)
+        let v = Id.Map.find id ist.lfun in
+        let v = Value.normalize v in
+        if has_type v (topwit wit_intro_pattern) then
+          let v = out_gen (topwit wit_intro_pattern) v in
+          match v with
+          | _, IntroNaming (IntroIdentifier id) -> try_cast_id id
+          | _ -> error ()
+        else if has_type v (topwit wit_var) then
+          let id = out_gen (topwit wit_var) v in
+          try_cast_id id
+        else if has_type v (topwit wit_int) then
+          keep,ElimOnAnonHyp (out_gen (topwit wit_int) v)
+        else match Value.to_constr v with
+        | None -> error ()
+        | Some c -> keep,ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))
       with Not_found ->
 	(* We were in non strict (interactive) mode *)
 	if Tactics.is_quantified_hypothesis id gl then
-          ElimOnIdent (loc,id)
+          keep,ElimOnIdent (loc,id)
 	else
-          let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
-          let (sigma,c) = interp_constr ist env sigma c in
-          ElimOnConstr (sigma,(c,NoBindings))
+          let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in
+          let f env sigma = 
+            let (sigma,c) = interp_open_constr ist env sigma c in
+            sigma,(c,NoBindings) in
+          keep,ElimOnConstr f
 
 (* Associates variables with values and gives the remaining variables and
    values *)
@@ -1609,12 +1021,11 @@ let head_with_value (lvar,lval) =
     | (vr,[]) -> (lacc,vr,[])
     | ([],ve) -> (lacc,[],ve)
   in
-    head_with_value_rec [] (lvar,lval)
+  head_with_value_rec [] (lvar,lval)
 
-(* Gives a context couple if there is a context identifier *)
-let give_context ctxt = function
-  | None -> []
-  | Some id -> [id,VConstr_context ctxt]
+(** [interp_context ctxt] interprets a context (as in
+    {!Matching.matching_result}) into a context value of Ltac.  *)
+let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt
 
 (* Reads a pattern by substituting vars of lfun *)
 let use_types = false
@@ -1623,7 +1034,7 @@ let eval_pattern lfun ist env sigma (_,pat as c) =
   if use_types then
     snd (interp_typed_pattern ist env sigma c)
   else
-    instantiate_pattern sigma lfun pat
+    instantiate_pattern env sigma lfun pat
 
 let read_pattern lfun ist env sigma = function
   | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c)
@@ -1631,9 +1042,9 @@ let read_pattern lfun ist env sigma = function
 
 (* Reads the hypotheses of a Match Context rule *)
 let cons_and_check_name id l =
-  if List.mem id l then
+  if Id.List.mem id l then
     user_err_loc (dloc,"read_match_goal_hyps",
-      strbrk ("Hypothesis pattern-matching variable "^(string_of_id id)^
+      strbrk ("Hypothesis pattern-matching variable "^(Id.to_string id)^
       " used twice in the same pattern."))
   else id::l
 
@@ -1656,1532 +1067,1267 @@ let rec read_match_rule lfun ist env sigma = function
       :: read_match_rule lfun ist env sigma tl
   | [] -> []
 
-(* For Match Context and Match *)
-exception Not_coherent_metas
-exception Eval_fail of std_ppcmds
-
-let is_match_catchable = function
-  | PatternMatchingFailure | Eval_fail _ -> true
-  | e -> Logic.catchable_exception e
-
-let equal_instances gl (ctx',c') (ctx,c) =
-  (* How to compare instances? Do we want the terms to be convertible?
-     unifiable? Do we want the universe levels to be relevant? 
-     (historically, conv_x is used) *)
-  ctx = ctx' & pf_conv_x gl c' c
-
-(* Verifies if the matched list is coherent with respect to lcm *)
-(* While non-linear matching is modulo eq_constr in matches, merge of *)
-(* different instances of the same metavars is here modulo conversion... *)
-let verify_metas_coherence gl (ln1,lcm) (ln,lm) =
-  let rec aux = function
-  | (id,c as x)::tl ->
-      if List.for_all (fun (id',c') -> id'<>id or equal_instances gl c' c) lcm
-      then
-	x :: aux tl
-      else
-	raise Not_coherent_metas
-  | [] -> lcm in
-  (ln@ln1,aux lm)
-
-let adjust (l,lc) = (l,List.map (fun (id,c) -> (id,([],c))) lc)
-
-(* Tries to match one hypothesis pattern with a list of hypotheses *)
-let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps =
-  let get_id_couple id = function
-    | Name idpat -> [idpat,VConstr ([],mkVar id)]
-    | Anonymous -> [] in
-  let match_pat lmatch hyp pat =
-    match pat with
-    | Term t ->
-        let lmeta = extended_matches t hyp in
-        (try
-            let lmeta = verify_metas_coherence gl lmatch lmeta in
-            ([],lmeta,(fun () -> raise PatternMatchingFailure))
-          with
-            | Not_coherent_metas -> raise PatternMatchingFailure);
-    | Subterm (b,ic,t) ->
-        let rec match_next_pattern find_next () =
-          let (lmeta,ctxt,find_next') = find_next () in
-          try
-            let lmeta = verify_metas_coherence gl lmatch (adjust lmeta) in
-            (give_context ctxt ic,lmeta,match_next_pattern find_next')
-          with
-            | Not_coherent_metas -> match_next_pattern find_next' () in
-        match_next_pattern (fun () -> match_subterm_gen b t hyp) () in
-  let rec apply_one_mhyp_context_rec = function
-    | (id,b,hyp as hd)::tl ->
-	(match patv with
-	| None ->
-            let rec match_next_pattern find_next () =
-              try
-                let (ids, lmeta, find_next') = find_next () in
-		(get_id_couple id hypname@ids, lmeta, hd,
-                 match_next_pattern find_next')
-              with
-                | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in
-            match_next_pattern (fun () ->
-	      let hyp = if b<>None then refresh_universes_strict hyp else hyp in
-	      match_pat lmatch hyp pat) ()
-	| Some patv ->
-	    match b with
-	    | Some body ->
-                let rec match_next_pattern_in_body next_in_body () =
-                  try
-                    let (ids,lmeta,next_in_body') = next_in_body() in
-                    let rec match_next_pattern_in_typ next_in_typ () =
-                      try
-                        let (ids',lmeta',next_in_typ') = next_in_typ() in
-		        (get_id_couple id hypname@ids@ids', lmeta', hd,
-                         match_next_pattern_in_typ next_in_typ')
-                      with
-                        | PatternMatchingFailure ->
-                            match_next_pattern_in_body next_in_body' () in
-                    match_next_pattern_in_typ
-                      (fun () ->
-			let hyp = refresh_universes_strict hyp in
-			match_pat lmeta hyp pat) ()
-                  with PatternMatchingFailure -> apply_one_mhyp_context_rec tl
-                in
-                match_next_pattern_in_body
-                  (fun () -> match_pat lmatch body patv) ()
-            | None -> apply_one_mhyp_context_rec tl)
-    | [] ->
-        db_hyp_pattern_failure ist.debug env (hypname,pat);
-        raise PatternMatchingFailure
-  in
-    apply_one_mhyp_context_rec lhyps
 
 (* misc *)
 
 let mk_constr_value ist gl c =
   let (sigma,c_interp) = pf_interp_constr ist gl c in
-  sigma,VConstr ([],c_interp)
-let mk_open_constr_value wTC ist gl c = 
-  let (sigma,c_interp) = pf_apply (interp_open_constr None wTC ist) gl c in
-  sigma,VConstr ([],c_interp)
-let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c))
-let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
-
-let pack_sigma (sigma,c) = {it=c;sigma=sigma}
+  sigma, Value.of_constr c_interp
+let mk_open_constr_value ist gl c = 
+  let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in
+  sigma, Value.of_constr c_interp
+let mk_hyp_value ist env sigma c =
+  Value.of_constr (mkVar (interp_hyp ist env sigma c))
+let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c)
 
-let extend_gl_hyps { it=gl ; sigma=sigma } sign =
-  Goal.V82.new_goal_with sigma gl sign
+let pack_sigma (sigma,c) = {it=c;sigma=sigma;}
 
 (* Interprets an l-tac expression into a value *)
-let rec val_interp ist gl (tac:glob_tactic_expr) =
+let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t =
+  (* The name [appl] of applied top-level Ltac names is ignored in
+     [value_interp]. It is installed in the second step by a call to
+     [name_vfun], because it gives more opportunities to detect a
+     [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never
+     register its name since it is syntactically a let, not a
+     function.  *)
   let value_interp ist = match tac with
-  (* Immediate evaluation *)
-  | TacFun (it,body) -> project gl , VFun (ist.trace,ist.lfun,it,body)
-  | TacLetIn (true,l,u) -> interp_letrec ist gl l u
-  | TacLetIn (false,l,u) -> interp_letin ist gl l u
-  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
-  | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
-  | TacArg (loc,a) -> interp_tacarg ist gl a
-  (* Delayed evaluation *)
-  | t -> project gl , VFun (ist.trace,ist.lfun,[],t)
-
-  in check_for_interrupt ();
-    match ist.debug with
-    | DebugOn lev ->
-	debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v})
-    | _ -> value_interp ist
-
-and eval_tactic ist = function
+  | TacFun (it, body) ->
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body)))
+  | TacLetIn (true,l,u) -> interp_letrec ist l u
+  | TacLetIn (false,l,u) -> interp_letin ist l u
+  | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr
+  | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr
+  | TacArg (loc,a) -> interp_tacarg ist a
+  | t ->
+    (** Delayed evaluation *)
+    Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t)))
+  in
+  let open Ftactic in
+  Control.check_for_interrupt ();
+  match curr_debug ist with
+  | DebugOn lev ->
+        let eval v =
+          let ist = { ist with extra = TacStore.set ist.extra f_debug v } in
+          value_interp ist >>= fun v -> return (name_vfun appl v)
+        in
+	Ftactic.debug_prompt lev tac eval
+  | _ -> value_interp ist >>= fun v -> return (name_vfun appl v)
+      
+
+and eval_tactic ist tac : unit Proofview.tactic = match tac with
   | TacAtom (loc,t) ->
-      fun gl ->
-	let box = ref None in abstract_tactic_box := box;
-	let call = LtacAtomCall (t,box) in
-	let tac = (* catch error in the interpretation *)
-	  catch_error (push_trace(dloc,call)ist.trace)
-	    (interp_atomic ist gl) t	in
-	(* catch error in the evaluation *)
-	catch_error (push_trace(loc,call)ist.trace) tac gl
+      let call = LtacAtomCall t in
+      catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t)
   | TacFun _ | TacLetIn _ -> assert false
   | TacMatchGoal _ | TacMatch _ -> assert false
-  | TacId s -> fun gl ->
-      let res = tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl in
-      db_breakpoint ist.debug s; res
-  | TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl
-  | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
+  | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) [])
+  | TacId s ->
+      let msgnl =
+        let open Ftactic in
+        interp_message ist s >>= fun msg ->
+        return (hov 0 msg , hov 0 msg)
+      in
+      let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print msgnl)) in
+      let log (msg,_) = Proofview.Trace.log (fun () -> msg) in
+      let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in
+      Ftactic.run msgnl begin fun msgnl ->
+        print msgnl <*> log msgnl <*> break
+      end
+  | TacFail (g,n,s) ->
+      let msg = interp_message ist s in
+      let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in
+      let tac =
+        match g with
+        | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l)
+        | TacGlobal -> tac
+      in
+      Ftactic.run msg tac
+  | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac)
+  | TacShowHyps tac ->
+         Proofview.V82.tactic begin
+           tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac))
+         end
   | TacAbstract (tac,ido) ->
-      fun gl -> Tactics.tclABSTRACT
-        (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) gl
-  | TacThen (t1,tf,t,tl) ->
-      tclTHENS3PARTS (interp_tactic ist t1)
+      Proofview.Goal.nf_enter begin fun gl -> Tactics.tclABSTRACT
+        (Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac)
+      end
+  | TacThen (t1,t) ->
+      Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t)
+  | TacDispatch tl ->
+      Proofview.tclDISPATCH (List.map (interp_tactic ist) tl)
+  | TacExtendTac (tf,t,tl) ->
+      Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf)
+                          (interp_tactic ist t)
+                          (Array.map_to_list (interp_tactic ist) tl)
+  | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
+  | TacThens3parts (t1,tf,t,tl) ->
+      Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1)
 	(Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl)
-  | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl)
-  | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
-  | TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
-  | TacTry tac -> tclTRY (interp_tactic ist tac)
-  | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
+  | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac)
+  | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac)
+  | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac)
+  | TacOr (tac1,tac2) ->
+      Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacOnce tac ->
+      Tacticals.New.tclONCE (interp_tactic ist tac)
+  | TacExactlyOnce tac ->
+      Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac)
+  | TacIfThenCatch (t,tt,te) ->
+      Tacticals.New.tclIFCATCH
+        (interp_tactic ist t)
+        (fun () -> interp_tactic ist tt)
+        (fun () -> interp_tactic ist te)
   | TacOrelse (tac1,tac2) ->
-        tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
-  | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l)
-  | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
-  | TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
+      Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l)
+  | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l)
+  | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac)
   | TacArg a -> interp_tactic ist (TacArg a)
   | TacInfo tac ->
       msg_warning
-	(str "The general \"info\" tactic is currently not working.\n" ++
-	 str "Some specific verbose tactics may exist instead, such as\n" ++
-	 str "info_trivial, info_auto, info_eauto.");
+	(strbrk "The general \"info\" tactic is currently not working." ++ spc()++
+           strbrk "There is an \"Info\" command to replace it." ++fnl () ++
+	   strbrk "Some specific verbose tactics may also exist, such as info_trivial, info_auto, info_eauto.");
       eval_tactic ist tac
-
-and force_vrec ist gl = function
-  | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
-  | v -> project gl , v
-
-and interp_ltac_reference loc' mustbetac ist gl = function
+  (* For extensions *)
+  | TacAlias (loc,s,l) ->
+      let body = Tacenv.interp_alias s in
+      let rec f x = match genarg_tag x with
+      | QuantHypArgType | RedExprArgType
+      | ConstrWithBindingsArgType
+      | BindingsArgType
+      | OptArgType _ | PairArgType _ -> (** generic handler *)
+        Ftactic.nf_enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          let concl = Proofview.Goal.concl gl in
+          let goal = Proofview.Goal.goal gl in
+          let (sigma, arg) = interp_genarg ist env sigma concl goal x in
+          Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg)
+        end
+      | _ as tag -> (** Special treatment. TODO: use generic handler  *)
+        Ftactic.nf_enter begin fun gl ->
+          let sigma = Proofview.Goal.sigma gl in
+          let env = Proofview.Goal.env gl in
+          match tag with
+          | IntOrVarArgType ->
+              Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x))
+          | IdentArgType ->
+              Ftactic.return (value_of_ident (interp_fresh_ident ist env sigma
+                                               (out_gen (glbwit wit_ident) x)))
+          | VarArgType ->
+              Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x))
+          | GenArgType -> f (out_gen (glbwit wit_genarg) x)
+          | ConstrArgType ->
+              let (sigma,v) =
+                Tacmach.New.of_old (fun gl -> mk_constr_value ist gl (out_gen (glbwit wit_constr) x)) gl
+              in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+          | OpenConstrArgType ->
+              let (sigma,v) =
+                Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+          | ConstrMayEvalArgType ->
+              let (sigma,c_interp) =
+                interp_constr_may_eval ist env sigma
+                  (out_gen (glbwit wit_constr_may_eval) x)
+              in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+          | ListArgType ConstrArgType ->
+              let wit = glbwit (wit_list wit_constr) in
+              let (sigma,l_interp) = Tacmach.New.of_old begin fun gl ->
+                Evd.MonadR.List.map_right
+                  (fun c sigma -> mk_constr_value ist { gl with sigma=sigma } c)
+                  (out_gen wit x)
+                  (project gl)
+              end gl in
+              Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (in_gen (topwit (wit_list wit_genarg)) l_interp))
+          | ListArgType VarArgType ->
+              let wit = glbwit (wit_list wit_var) in
+              Ftactic.return (
+                let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in
+                in_gen (topwit (wit_list wit_genarg)) ans
+              )
+          | ListArgType IntOrVarArgType ->
+              let wit = glbwit (wit_list wit_int_or_var) in
+              let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in
+              Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans)
+          | ListArgType IdentArgType ->
+              let wit = glbwit (wit_list wit_ident) in
+              let mk_ident x = value_of_ident (interp_fresh_ident ist env sigma x) in
+              let ans = List.map mk_ident (out_gen wit x) in
+              Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans)
+          | ListArgType t  ->
+              let open Ftactic in
+              let list_unpacker wit l =
+                let map x =
+                  f (in_gen (glbwit wit) x) >>= fun v ->
+                  Ftactic.return (out_gen (topwit wit) v)
+                in
+                Ftactic.List.map map (glb l) >>= fun l ->
+                Ftactic.return (in_gen (topwit (wit_list wit)) l)
+              in
+              list_unpack { list_unpacker } x
+          | ExtraArgType _ ->
+              (** Special treatment of tactics *)
+              if has_type x (glbwit wit_tactic) then
+                let tac = out_gen (glbwit wit_tactic) x in
+                val_interp ist tac
+              else
+                let goal = Proofview.Goal.goal gl in
+                let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in
+                Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v)
+          | _ -> assert false
+        end
+      in
+      let (>>=) = Ftactic.bind in
+      let interp_vars =
+        Ftactic.List.map (fun (x,v) -> f v >>= fun v -> Ftactic.return (x,v)) l
+      in
+      let addvar (x, v) accu = Id.Map.add x v accu in
+      let tac l =
+        let lfun = List.fold_right addvar l ist.lfun in
+        let trace = push_trace (loc,LtacNotationCall s) ist in
+        let ist = {
+          lfun = lfun;
+          extra = TacStore.set ist.extra f_trace trace; } in
+        val_interp ist body >>= fun v ->
+        Ftactic.lift (tactic_of_value ist v)
+      in
+      let tac =
+        Ftactic.with_env interp_vars >>= fun (env,l) ->
+        let name () = Pptactic.pr_tactic env (TacAlias(loc,s,l)) in
+        Proofview.Trace.name_tactic name (tac l)
+      (* spiwack: this use of name_tactic is not robust to a
+         change of implementation of [Ftactic]. In such a situation,
+         some more elaborate solution will have to be used. *)
+      in
+      Ftactic.run tac (fun () -> Proofview.tclUNIT ())
+
+  | TacML (loc,opn,l) when List.for_all global_genarg l ->
+      let trace = push_trace (loc,LtacMLCall tac) ist in
+      let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
+      (* spiwack: a special case for tactics (from TACTIC EXTEND) when
+         every argument can be interpreted without a
+         [Proofview.Goal.nf_enter]. *)
+      let tac = Tacenv.interp_ml_tactic opn in
+      (* dummy values, will be ignored *)
+      let env = Environ.empty_env in
+      let sigma = Evd.empty in
+      let concl = Term.mkRel (-1) in
+      let goal = Evar.unsafe_of_int (-1) in
+      (* /dummy values *)
+      let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in
+      let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in
+      Proofview.Trace.name_tactic name
+        (catch_error_tac trace (tac args ist))
+  | TacML (loc,opn,l) ->
+      let trace = push_trace (loc,LtacMLCall tac) ist in
+      let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let goal_sigma = Proofview.Goal.sigma gl in
+        let concl = Proofview.Goal.concl gl in
+        let goal = Proofview.Goal.goal gl in
+        let tac = Tacenv.interp_ml_tactic opn in
+        let (sigma,args) =
+          Evd.MonadR.List.map_right
+            (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma
+        in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in
+        Proofview.Trace.name_tactic name
+          (catch_error_tac trace (tac args ist))
+      end
+
+and force_vrec ist v : typed_generic_argument Ftactic.t =
+  let v = Value.normalize v in
+  if has_type v (topwit wit_tacvalue) then
+    let v = to_tacvalue v in
+    match v with
+    | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body
+    | v -> Ftactic.return (of_tacvalue v)
+  else Ftactic.return v
+
+and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t =
+  match r with
   | ArgVar (loc,id) ->
-      let v = List.assoc id ist.lfun in
-      let (sigma,v) = force_vrec ist gl v in
+      let v =
+        try Id.Map.find id ist.lfun
+        with Not_found -> in_gen (topwit wit_var) id
+      in
+      Ftactic.bind (force_vrec ist v) begin fun v ->
       let v = propagate_trace ist loc id v in
-      sigma , if mustbetac then coerce_to_tactic loc id v else v
+      if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v
+      end
   | ArgArg (loc,r) ->
       let ids = extract_ids [] ist.lfun in
-      let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in
-      let ist =
-        { lfun=[]; debug=ist.debug; avoid_ids=ids;
-          trace = push_trace loc_info ist.trace } in
-      val_interp ist gl (lookup r)
-
-and interp_tacarg ist gl arg =
-  let evdref = ref (project gl) in
-  let v = match arg with
-    | TacVoid -> VVoid
-    | Reference r ->
-      let (sigma,v) = interp_ltac_reference dloc false ist gl r in
-      evdref := sigma;
-      v
-    | Integer n -> VInteger n
-    | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
-    | ConstrMayEval c ->
-      let (sigma,c_interp) = interp_constr_may_eval ist gl c in
-      evdref := sigma;
-      VConstr ([],c_interp)
-    | MetaIdArg (loc,_,id) -> assert false
-    | TacCall (loc,r,[]) ->
-      let (sigma,v) = interp_ltac_reference loc true ist gl r in
-      evdref := sigma;
-      v
-    | TacCall (loc,f,l) ->
-        let (sigma,fv) = interp_ltac_reference loc true ist gl f in
-	let (sigma,largs) =
-	  List.fold_right begin fun a (sigma',acc) ->
-	    let (sigma', a_interp) = interp_tacarg ist gl a in
-	    sigma' , a_interp::acc
-	  end l (sigma,[])
-	in
-	List.iter check_is_value largs;
-	let (sigma,v) = interp_app loc ist { gl with sigma=sigma } fv largs in
-	evdref:= sigma;
-	v
-    | TacExternal (loc,com,req,la) ->
-        let (sigma,la_interp) =
-	  List.fold_right begin fun a (sigma,acc) ->
-	    let (sigma,a_interp) = interp_tacarg ist {gl with sigma=sigma} a in
-	    sigma , a_interp::acc
-	  end la (project gl,[])
-	in
-        let (sigma,v) = interp_external loc ist { gl with sigma=sigma } com req la_interp in
-	evdref := sigma;
-	v
-    | TacFreshId l ->
-        let id = pf_interp_fresh_id ist gl l in
-	VIntroPattern (IntroIdentifier id)
-    | Tacexp t ->
-      let (sigma,v) = val_interp ist gl t in
-      evdref := sigma;
-      v
-    | TacDynamic(_,t) ->
-        let tg = (Dyn.tag t) in
-	if tg = "tactic" then
-          let (sigma,v) = val_interp ist gl (tactic_out t ist) in
-	  evdref := sigma;
-	  v
-	else if tg = "value" then
-          value_out t
-	else if tg = "constr" then
-        VConstr ([],constr_out t)
-	else
-          anomaly_loc (dloc, "Tacinterp.val_interp",
-		       (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
-  in
-  !evdref , v
+      let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in
+      let extra = TacStore.set ist.extra f_avoid_ids ids in 
+      let extra = TacStore.set extra f_trace (push_trace loc_info ist) in
+      let ist = { lfun = Id.Map.empty; extra = extra; } in
+      let appl = GlbAppl[r,[]] in
+      val_interp ~appl ist (Tacenv.interp_ltac r)
+
+and interp_tacarg ist arg : typed_generic_argument Ftactic.t =
+  match arg with
+  | TacGeneric arg ->
+      Ftactic.nf_enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let goal = Proofview.Goal.goal gl in
+        let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v)
+      end
+  | Reference r -> interp_ltac_reference dloc false ist r
+  | ConstrMayEval c ->
+      Ftactic.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+      end
+  | UConstr c ->
+      Ftactic.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        Ftactic.return (Value.of_uconstr (interp_uconstr ist env c))
+      end
+  | MetaIdArg (loc,_,id) -> assert false
+  | TacCall (loc,r,[]) ->
+      interp_ltac_reference loc true ist r
+  | TacCall (loc,f,l) ->
+      let (>>=) = Ftactic.bind in
+      interp_ltac_reference loc true ist f >>= fun fv ->
+      Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs ->
+      interp_app loc ist fv largs
+  | TacFreshId l ->
+      Ftactic.enter begin fun gl ->
+        let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) l in
+        Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id)))
+      end
+  | TacPretype c ->
+      Ftactic.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let {closure;term} = interp_uconstr ist env c in
+        let vars = {
+          Pretyping.ltac_constrs = closure.typed;
+          Pretyping.ltac_uconstrs = closure.untyped;
+          Pretyping.ltac_idents = closure.idents;
+          Pretyping.ltac_genargs = ist.lfun;
+        } in
+        let (sigma,c_interp) =
+          Pretyping.understand_ltac constr_flags env sigma vars WithoutTypeConstraint term
+        in
+        Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp))
+      end
+  | TacNumgoals ->
+      Ftactic.lift begin
+        let open Proofview.Notations in
+        Proofview.numgoals >>= fun i ->
+        Proofview.tclUNIT (Value.of_int i)
+      end
+  | Tacexp t -> val_interp ist t
+  | TacDynamic(_,t) ->
+      let tg = (Dyn.tag t) in
+      if String.equal tg "tactic" then
+        val_interp ist (tactic_out t ist)
+      else if String.equal tg "value" then
+        Ftactic.return (value_out t)
+      else if String.equal tg "constr" then
+        Ftactic.return (Value.of_constr (constr_out t))
+      else
+        Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp"
+	  (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">")
 
 (* Interprets an application node *)
-and interp_app loc ist gl fv largs =
-  match fv with
+and interp_app loc ist fv largs : typed_generic_argument Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in
+  let fv = Value.normalize fv in
+  if has_type fv (topwit wit_tacvalue) then
+  match to_tacvalue fv with
      (* if var=[] and body has been delayed by val_interp, then body
          is not a tactic that expects arguments.
          Otherwise Ltac goes into an infinite loop (val_interp puts
          a VFun back on body, and then interp_app is called again...) *)
-    | (VFun(trace,olfun,(_::_ as var),body)
-      |VFun(trace,olfun,([] as var),
+    | (VFun(appl,trace,olfun,(_::_ as var),body)
+      |VFun(appl,trace,olfun,([] as var),
          (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) ->
-	let (newlfun,lvar,lval)=head_with_value (var,largs) in
-	if lvar=[] then
-	  let (sigma,v) =
-	    try
-	      catch_error trace
-		(val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body
-	    with reraise ->
-              debugging_exception_step ist false reraise
-                (fun () -> str "evaluation");
-	      raise reraise
-          in
-	  let gl = { gl with sigma=sigma } in
+	let (extfun,lvar,lval)=head_with_value (var,largs) in
+        let fold accu (id, v) = Id.Map.add id v accu in
+	let newlfun = List.fold_left fold olfun extfun in
+      if List.is_empty lvar then
+        begin Proofview.tclORELSE
+            begin
+              let ist = {
+                lfun = newlfun;
+                extra = TacStore.set ist.extra f_trace []; } in
+              catch_error_tac trace (val_interp ist body) >>= fun v ->
+              Ftactic.return (name_vfun (push_appl appl largs) v)
+            end
+	    begin fun (e, info) ->
+              Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*>
+	      Proofview.tclZERO ~info e
+            end
+        end >>= fun v ->
+        (* No errors happened, we propagate the trace *)
+        let v = append_trace trace v in
+        Proofview.tclLIFT begin
           debugging_step ist
 	    (fun () ->
-	       str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v);
-          if lval=[] then sigma,v else interp_app loc ist gl v lval
-	else
-          project gl , VFun(trace,newlfun@olfun,lvar,body)
-    | _ ->
-	user_err_loc (loc, "Tacinterp.interp_app",
-          (str"Illegal tactic application."))
+	      str"evaluation returns"++fnl()++pr_value None v)
+        end <*>
+        if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
+      else
+        Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body)))
+    | _ -> fail
+  else fail
 
 (* Gives the tactic corresponding to the tactic value *)
-and tactic_of_value ist vle g =
-  match vle with
-  | VRTactic res -> res
-  | VFun (trace,lfun,[],t) ->
-      let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
-      catch_error trace tac g
-  | (VFun _|VRec _) -> error "A fully applied tactic is expected."
-  | VConstr _ -> errorlabstrm "" (str"Value is a term. Expected a tactic.")
-  | VConstr_context _ ->
-      errorlabstrm "" (str"Value is a term context. Expected a tactic.")
-  | VIntroPattern _ ->
-      errorlabstrm "" (str"Value is an intro pattern. Expected a tactic.")
-  | _ -> errorlabstrm "" (str"Expression does not evaluate to a tactic.")
-
-(* Evaluation with FailError catching *)
-and eval_with_fail ist is_lazy goal tac =
-  try
-    let (sigma,v) = val_interp ist goal tac in
-    sigma ,
-    (match v with
-    | VFun (trace,lfun,[],t) when not is_lazy ->
-	let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
-	VRTactic (catch_error trace tac { goal with sigma=sigma })
-    | a -> a)
-  with
-    | FailError (0,s) | Loc.Exc_located(_, FailError (0,s))
-    | Loc.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
-	raise (Eval_fail (Lazy.force s))
-    | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
-    | Loc.Exc_located(s,FailError (lvl,s')) ->
-	raise (Loc.Exc_located(s,FailError (lvl - 1, s')))
-    | Loc.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
-	raise (Loc.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
+and tactic_of_value ist vle =
+  let vle = Value.normalize vle in
+  if has_type vle (topwit wit_tacvalue) then
+  match to_tacvalue vle with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace []; } in
+      let tac = name_if_glob appl (eval_tactic ist t) in
+      catch_error_tac trace tac
+  | (VFun _|VRec _) -> Proofview.tclZERO (UserError ("" , str "A fully applied tactic is expected."))
+  else if has_type vle (topwit wit_tactic) then
+    let tac = out_gen (topwit wit_tactic) vle in
+    eval_tactic ist tac
+  else Proofview.tclZERO (UserError ("" , str"Expression does not evaluate to a tactic."))
 
 (* Interprets the clauses of a recursive LetIn *)
-and interp_letrec ist gl llc u =
+and interp_letrec ist llc u =
+  Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *)
   let lref = ref ist.lfun in
-  let lve = list_map_left (fun ((_,id),b) -> (id,VRec (lref,TacArg (dloc,b)))) llc in
-  lref := lve@ist.lfun;
-  let ist = { ist with lfun = lve@ist.lfun } in
-  val_interp ist gl u
+  let fold accu ((_, id), b) =
+    let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in
+    Id.Map.add id v accu
+  in
+  let lfun = List.fold_left fold ist.lfun llc in
+  let () = lref := lfun in
+  let ist = { ist with lfun } in
+  val_interp ist u
 
 (* Interprets the clauses of a LetIn *)
-and interp_letin ist gl llc u =
-  let (sigma,lve) =
-    List.fold_right begin fun ((_,id),body) (sigma,acc) ->
-      let (sigma,v) = interp_tacarg ist { gl with sigma=sigma } body in
-      check_is_value v;
-      sigma, (id,v)::acc
-    end llc (project gl,[])
+and interp_letin ist llc u =
+  let rec fold lfun = function
+  | [] ->
+    let ist = { ist with lfun } in
+    val_interp ist u
+  | ((_, id), body) :: defs ->
+    Ftactic.bind (interp_tacarg ist body) (fun v ->
+    fold (Id.Map.add id v lfun) defs)
   in
-  let ist = { ist with lfun = lve@ist.lfun } in
-  val_interp ist { gl with sigma=sigma } u
+  fold ist.lfun llc
+
+(** [interp_match_success lz ist succ] interprets a single matching success
+    (of type {!Tactic_matching.t}). *)
+and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } =
+  let (>>=) = Ftactic.bind in
+  let lctxt = Id.Map.map interp_context context in
+  let hyp_subst = Id.Map.map Value.of_constr terms in
+  let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in
+  let ist = { ist with lfun } in
+  val_interp ist lhs >>= fun v ->
+  if has_type v (topwit wit_tacvalue) then match to_tacvalue v with
+  | VFun (appl,trace,lfun,[],t) ->
+      let ist = {
+        lfun = lfun;
+        extra = TacStore.set ist.extra f_trace trace; } in
+      let tac = eval_tactic ist t in
+      let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in
+      catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy))
+  | _ -> Ftactic.return v
+  else Ftactic.return v
+
+
+(** [interp_match_successes lz ist s] interprets the stream of
+    matching of successes [s]. If [lz] is set to true, then only the
+    first success is considered, otherwise further successes are tried
+    if the left-hand side fails. *)
+and interp_match_successes lz ist s =
+   let general =
+     let break (e, info) = match e with
+       | FailError (0, _) -> None
+       | FailError (n, s) -> Some (FailError (pred n, s), info)
+       | _ -> None
+     in
+     Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans
+   in
+    match lz with
+    | General ->
+        general
+    | Select ->
+      begin
+        (** Only keep the first matching result, we don't backtrack on it *)
+        let s = Proofview.tclONCE s in
+        s >>= fun ans -> interp_match_success ist ans
+      end
+    | Once ->
+        (** Once a tactic has succeeded, do not backtrack anymore *)
+        Proofview.tclONCE general
+
+(* Interprets the Match expressions *)
+and interp_match ist lz constr lmr =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+    (interp_ltac_constr ist constr)
+    begin function
+      | (e, info) ->
+          Proofview.tclLIFT (debugging_exception_step ist true e
+          (fun () -> str "evaluation of the matched expression")) <*>
+          Proofview.tclZERO ~info e
+    end
+  end >>= fun constr ->
+  Ftactic.enter begin fun gl ->
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+    interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr)
+  end
 
 (* Interprets the Match Context expressions *)
-and interp_match_goal ist goal lz lr lmr =
-  let (gl,sigma) = Goal.V82.nf_evar (project goal) (sig_it goal) in
-  let goal = { it = gl ; sigma = sigma } in
-  let hyps = pf_hyps goal in
-  let hyps = if lr then List.rev hyps else hyps in
-  let concl = pf_concl goal in
-  let env = pf_env goal in
-  let rec apply_goal_sub app ist (id,c) csr mt mhyps hyps =
-    let rec match_next_pattern find_next () =
-      let (lgoal,ctxt,find_next') = find_next () in
-      let lctxt = give_context ctxt id in
-      try apply_hyps_context ist env lz goal mt lctxt (adjust lgoal) mhyps hyps
-      with e when is_match_catchable e -> match_next_pattern find_next' () in
-    match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match_goal ist env goal nrs lex lpt =
-    begin
-      if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
-      match lpt with
-	| (All t)::tl ->
-	    begin
-              db_mc_pattern_success ist.debug;
-              try eval_with_fail ist lz goal t
-              with e when is_match_catchable e ->
-		apply_match_goal ist env goal (nrs+1) (List.tl lex) tl
-	    end
-	| (Pat (mhyps,mgoal,mt))::tl ->
-            let mhyps = List.rev mhyps (* Sens naturel *) in
-	    (match mgoal with
-             | Term mg ->
-		 (try
-		     let lmatch = extended_matches mg concl in
-		     db_matched_concl ist.debug env concl;
-		     apply_hyps_context ist env lz goal mt [] lmatch mhyps hyps
-		   with e when is_match_catchable e ->
-		     (match e with
-		       | PatternMatchingFailure -> db_matching_failure ist.debug
-		       | Eval_fail s -> db_eval_failure ist.debug s
-		       | _ -> db_logic_failure ist.debug e);
-		     apply_match_goal ist env goal (nrs+1) (List.tl lex) tl)
-	     | Subterm (b,id,mg) ->
-		 (try apply_goal_sub b ist (id,mg) concl mt mhyps hyps
-		   with
-		     | PatternMatchingFailure ->
-			 apply_match_goal ist env goal (nrs+1) (List.tl lex) tl))
-	| _ ->
-	    errorlabstrm "Tacinterp.apply_match_goal"
-              (v 0 (str "No matching clauses for match goal" ++
-		      (if ist.debug=DebugOff then
-			 fnl() ++ str "(use \"Set Ltac Debug\" for more info)"
-		       else mt()) ++ str"."))
-    end in
-    apply_match_goal ist env goal 0 lmr
-      (read_match_rule (fst (extract_ltac_constr_values ist env))
-	ist env (project goal) lmr)
-
-(* Tries to match the hypotheses in a Match Context *)
-and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps =
-  let rec apply_hyps_context_rec lfun lmatch lhyps_rest = function
-    | hyp_pat::tl ->
-	let (hypname, _, _ as hyp_pat) =
-	  match hyp_pat with
-	  | Hyp ((_,hypname),mhyp) -> hypname,  None, mhyp
-	  | Def ((_,hypname),mbod,mhyp) -> hypname, Some mbod, mhyp
-	in
-        let rec match_next_pattern find_next =
-          let (lids,lm,hyp_match,find_next') = find_next () in
-          db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
-	  try
-            let id_match = pi1 hyp_match in
-            let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in
-            apply_hyps_context_rec (lfun@lids) lm nextlhyps tl
-          with e when is_match_catchable e ->
-	    match_next_pattern find_next' in
-        let init_match_pattern () =
-          apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in
-        match_next_pattern init_match_pattern
-    | [] ->
-        let lfun = extend_values_with_bindings lmatch (lfun@ist.lfun) in
-        db_mc_pattern_success ist.debug;
-        eval_with_fail {ist with lfun=lfun} lz goal mt
-  in
-  apply_hyps_context_rec lctxt lgmatch hyps mhyps
-
-and interp_external loc ist gl com req la =
-  let f ch = extern_request ch req gl la in
-  let g ch = internalise_tacarg ch in
-  interp_tacarg ist gl (System.connect f g com)
-
-  (* Interprets extended tactic generic arguments *)
-and interp_genarg ist gl x =
-  let evdref = ref (project gl) in
-  let rec interp_genarg ist gl x =
-    let gl = { gl with sigma = !evdref } in
+and interp_match_goal ist lz lr lmr =
+    Ftactic.nf_enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let hyps = Proofview.Goal.hyps gl in
+      let hyps = if lr then List.rev hyps else hyps in
+      let concl = Proofview.Goal.concl gl in
+      let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in
+      interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr)
+    end
+
+(* Interprets extended tactic generic arguments *)
+(* spiwack: interp_genarg has an argument [concl] for the case of
+   "casted open constr". And [gl] for [Geninterp]. I haven't changed
+   the interface for geninterp yet as it is used by ARGUMENT EXTEND
+   (in turn used by plugins). At the time I'm writing this comment
+   though, the only concerned plugins are the declarative mode (which
+   needs the [extra] field of goals to interprete rules) and ssreflect
+   (a handful of time). I believe we'd need to address "casted open
+   constr" and the declarative mode rules to provide a reasonable
+   interface. *)
+and interp_genarg ist env sigma concl gl x =
+  let evdref = ref sigma in
+  let rec interp_genarg x =
     match genarg_tag x with
-    | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
-    | IntArgType -> in_gen wit_int (out_gen globwit_int x)
     | IntOrVarArgType ->
-      in_gen wit_int_or_var
-        (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
-    | StringArgType ->
-      in_gen wit_string (out_gen globwit_string x)
-    | PreIdentArgType ->
-      in_gen wit_pre_ident (out_gen globwit_pre_ident x)
-    | IntroPatternArgType ->
-      in_gen wit_intro_pattern
-        (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
-    | IdentArgType b ->
-      in_gen (wit_ident_gen b)
-        (pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
+      in_gen (topwit wit_int_or_var)
+        (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x)))
+    | IdentArgType ->
+      in_gen (topwit wit_ident)
+        (interp_fresh_ident ist env sigma (out_gen (glbwit wit_ident) x))
     | VarArgType ->
-      in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
-    | RefArgType ->
-      in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
-    | SortArgType ->
+      in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x))
+    | GenArgType ->
+      in_gen (topwit wit_genarg) (interp_genarg (out_gen (glbwit wit_genarg) x))
+    | ConstrArgType ->
       let (sigma,c_interp) =
-	pf_interp_constr ist gl
-	  (GSort (dloc,out_gen globwit_sort x), None)
+        interp_constr ist env !evdref (out_gen (glbwit wit_constr) x)
       in
       evdref := sigma;
-      in_gen wit_sort
-        (destSort c_interp)
-    | ConstrArgType ->
-      let (sigma,c_interp) = pf_interp_constr ist gl (out_gen globwit_constr x) in
-      evdref := sigma;
-      in_gen wit_constr c_interp
+      in_gen (topwit wit_constr) c_interp
     | ConstrMayEvalArgType ->
-      let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
+      let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in
       evdref := sigma;
-      in_gen wit_constr_may_eval c_interp
+      in_gen (topwit wit_constr_may_eval) c_interp
     | QuantHypArgType ->
-      in_gen wit_quant_hyp
-        (interp_declared_or_quantified_hypothesis ist gl
-           (out_gen globwit_quant_hyp x))
+      in_gen (topwit wit_quant_hyp)
+        (interp_declared_or_quantified_hypothesis ist env sigma
+           (out_gen (glbwit wit_quant_hyp) x))
     | RedExprArgType ->
-      let (sigma,r_interp) = pf_interp_red_expr ist gl (out_gen globwit_red_expr x) in
+      let (sigma,r_interp) =
+        interp_red_expr ist env !evdref (out_gen (glbwit wit_red_expr) x)
+      in
       evdref := sigma;
-      in_gen wit_red_expr r_interp
-    | OpenConstrArgType (casted,wTC) ->
-      in_gen (wit_open_constr_gen (casted,wTC))
-        (interp_open_constr (if casted then Some (pf_concl gl) else None) wTC
-           ist (pf_env gl) (project gl)
-           (snd (out_gen (globwit_open_constr_gen (casted,wTC)) x)))
+      in_gen (topwit wit_red_expr) r_interp
+    | OpenConstrArgType ->
+      let expected_type = WithoutTypeConstraint in
+      in_gen (topwit wit_open_constr)
+        (interp_open_constr ~expected_type
+           ist env !evdref
+           (snd (out_gen (glbwit wit_open_constr) x)))
     | ConstrWithBindingsArgType ->
-      in_gen wit_constr_with_bindings
-        (pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl)
-		       (out_gen globwit_constr_with_bindings x)))
+      in_gen (topwit wit_constr_with_bindings)
+        (pack_sigma (interp_constr_with_bindings ist env !evdref
+		       (out_gen (glbwit wit_constr_with_bindings) x)))
     | BindingsArgType ->
-      in_gen wit_bindings
-        (pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x)))
-    | List0ArgType ConstrArgType ->
-        let (sigma,v) = interp_genarg_constr_list0 ist gl x in
-	evdref := sigma;
-	v
-    | List1ArgType ConstrArgType ->
-        let (sigma,v) = interp_genarg_constr_list1 ist gl x in
+      in_gen (topwit wit_bindings)
+        (pack_sigma (interp_bindings ist env !evdref (out_gen (glbwit wit_bindings) x)))
+    | ListArgType ConstrArgType ->
+        let (sigma,v) = interp_genarg_constr_list ist env !evdref x in
 	evdref := sigma;
 	v
-    | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
-    | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
-    | List0ArgType _ -> app_list0 (interp_genarg ist gl) x
-    | List1ArgType _ -> app_list1 (interp_genarg ist gl) x
-    | OptArgType _ -> app_opt (interp_genarg ist gl) x
-    | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
+    | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x
+    | ListArgType _ ->
+      let list_unpacker wit l =
+        let map x =
+          out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x))
+        in
+        in_gen (topwit (wit_list wit)) (List.map map (glb l))
+      in
+      list_unpack { list_unpacker } x
+    | OptArgType _ ->
+      let opt_unpacker wit o = match glb o with
+      | None -> in_gen (topwit (wit_opt wit)) None
+      | Some x ->
+        let x = out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) in
+        in_gen (topwit (wit_opt wit)) (Some x)
+      in
+      opt_unpack { opt_unpacker } x
+    | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let (p, q) = glb o in
+        let p = out_gen (topwit wit1) (interp_genarg (in_gen (glbwit wit1) p)) in
+        let q = out_gen (topwit wit2) (interp_genarg (in_gen (glbwit wit2) q)) in
+        in_gen (topwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
     | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-        in_gen (wit_tactic n)
-	  (TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
-				    out_gen (globwit_tactic n) x))))
-      | None ->
-        let (sigma,v) = lookup_interp_genarg s ist gl x in
+        let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in
 	evdref:=sigma;
 	v
   in
-  let v = interp_genarg ist gl x in
+  let v = interp_genarg x in
   !evdref , v
 
-and interp_genarg_constr_list0 ist gl x =
-  let lc = out_gen (wit_list0 globwit_constr) x in
-  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
-  sigma , in_gen (wit_list0 wit_constr) lc
 
-and interp_genarg_constr_list1 ist gl x =
-  let lc = out_gen (wit_list1 globwit_constr) x in
-  let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
-  sigma , in_gen (wit_list1 wit_constr) lc
+(** returns [true] for genargs which have the same meaning
+    independently of goals. *)
 
-and interp_genarg_var_list0 ist gl x =
-  let lc = out_gen (wit_list0 globwit_var) x in
-  let lc = interp_hyp_list ist gl lc in
-  in_gen (wit_list0 wit_var) lc
+and global_genarg =
+  let rec global_tag = function
+    | IntOrVarArgType | GenArgType -> true
+    | ListArgType t | OptArgType t -> global_tag t
+    | PairArgType (t1,t2) -> global_tag t1 && global_tag t2
+    | _ -> false
+  in
+  fun x -> global_tag (genarg_tag x)
 
-and interp_genarg_var_list1 ist gl x =
-  let lc = out_gen (wit_list1 globwit_var) x in
-  let lc = interp_hyp_list ist gl lc in
-  in_gen (wit_list1 wit_var) lc
+and interp_genarg_constr_list ist env sigma x =
+  let lc = out_gen (glbwit (wit_list wit_constr)) x in
+  let (sigma,lc) = interp_constr_list ist env sigma lc in
+  sigma , in_gen (topwit (wit_list wit_constr)) lc
 
-(* Interprets the Match expressions *)
-and interp_match ist g lz constr lmr =
-  let rec apply_match_subterm app ist (id,c) csr mt =
-    let rec match_next_pattern find_next () =
-      let (lmatch,ctxt,find_next') = find_next () in
-      let lctxt = give_context ctxt id in
-      let lfun = extend_values_with_bindings (adjust lmatch) (lctxt@ist.lfun) in
-      try eval_with_fail {ist with lfun=lfun} lz g mt
-      with e when is_match_catchable e ->
-        match_next_pattern find_next' () in
-    match_next_pattern (fun () -> match_subterm_gen app c csr) () in
-  let rec apply_match ist sigma csr = let g = { g with sigma=sigma } in function
-    | (All t)::tl ->
-        (try eval_with_fail ist lz g t
-         with e when is_match_catchable e -> apply_match ist sigma csr tl)
-    | (Pat ([],Term c,mt))::tl ->
-        (try
-            let lmatch =
-              try extended_matches c csr
-              with reraise ->
-                debugging_exception_step ist false reraise (fun () ->
-                  str "matching with pattern" ++ fnl () ++
-                  pr_constr_pattern_env (pf_env g) c);
-                raise reraise
-            in
-            try
-              let lfun = extend_values_with_bindings lmatch ist.lfun in
-              eval_with_fail { ist with lfun=lfun } lz g mt
-            with reraise ->
-              debugging_exception_step ist false reraise (fun () ->
-                str "rule body for pattern" ++
-                pr_constr_pattern_env (pf_env g) c);
-              raise reraise
-         with e when is_match_catchable e ->
-           debugging_step ist (fun () -> str "switching to the next rule");
-           apply_match ist sigma csr tl)
-
-    | (Pat ([],Subterm (b,id,c),mt))::tl ->
-        (try apply_match_subterm b ist (id,c) csr mt
-         with PatternMatchingFailure -> apply_match ist sigma csr tl)
-    | _ ->
-      errorlabstrm "Tacinterp.apply_match" (str
-        "No matching clauses for match.") in
-  let (sigma,csr) =
-      try interp_ltac_constr ist g constr with reraise ->
-        debugging_exception_step ist true reraise
-          (fun () -> str "evaluation of the matched expression");
-        raise reraise in
-  let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in
-  let res =
-     try apply_match ist sigma csr ilr with reraise ->
-       debugging_exception_step ist true reraise
-         (fun () -> str "match expression");
-       raise reraise in
-  debugging_step ist (fun () ->
-    str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res));
-  res
+and interp_genarg_var_list ist env sigma x =
+  let lc = out_gen (glbwit (wit_list wit_var)) x in
+  let lc = interp_hyp_list ist env sigma lc in
+  in_gen (topwit (wit_list wit_var)) lc
 
 (* Interprets tactic expressions : returns a "constr" *)
-and interp_ltac_constr ist gl e =
-  let (sigma, result) =
-  try val_interp ist gl e with Not_found ->
-    debugging_step ist (fun () ->
-      str "evaluation failed for" ++ fnl() ++
-      Pptactic.pr_glob_tactic (pf_env gl) e);
-    raise Not_found in
+and interp_ltac_constr ist e : constr Ftactic.t =
+  let (>>=) = Ftactic.bind in
+  begin Proofview.tclORELSE
+      (val_interp ist e)
+      begin function (err, info) -> match err with
+        | Not_found ->
+            Ftactic.enter begin fun gl ->
+              let env = Proofview.Goal.env gl in
+              Proofview.tclLIFT begin
+                debugging_step ist (fun () ->
+                  str "evaluation failed for" ++ fnl() ++
+                    Pptactic.pr_glob_tactic env e)
+              end
+            <*> Proofview.tclZERO Not_found
+            end
+        | err -> Proofview.tclZERO ~info err
+      end
+  end >>= fun result ->
+  Ftactic.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let result = Value.normalize result in
   try
-    let cresult = constr_of_value (pf_env gl) result in
-    debugging_step ist (fun () ->
-      Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++
-      str " has value " ++ fnl() ++
-      pr_constr_under_binders_env (pf_env gl) cresult);
-    if fst cresult <> [] then raise Not_found;
-    sigma , snd cresult
-  with Not_found ->
-    errorlabstrm ""
+    let cresult = coerce_to_closed_constr env result in
+    Proofview.tclLIFT begin
+      debugging_step ist (fun () ->
+        Pptactic.pr_glob_tactic env e ++ fnl() ++
+          str " has value " ++ fnl() ++
+          pr_constr_env env sigma cresult)
+    end <*>
+    Ftactic.return cresult
+  with CannotCoerceTo _ ->
+    let env = Proofview.Goal.env gl in
+    Proofview.tclZERO (UserError ( "",
+      errorlabstrm ""
       (str "Must evaluate to a closed term" ++ fnl() ++
-	  str "offending expression: " ++ fnl() ++
-          Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++
-          (match result with
-            | VRTactic _ -> str "VRTactic"
-            | VFun (_,il,ul,b) ->
-                (str "VFun with body " ++ fnl() ++
-                    Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++
-		    str "instantiated arguments " ++ fnl() ++
-                    List.fold_right
-                    (fun p s ->
-                      let (i,v) = p in str (string_of_id i) ++ str ", " ++ s)
-                    il (str "") ++
-                    str "uninstantiated arguments " ++ fnl() ++
-                    List.fold_right
-                    (fun opt_id s ->
-                      (match opt_id with
-                          Some id -> str (string_of_id id)
-                        | None -> str "_") ++ str ", " ++ s)
-                    ul (mt()))
-            | VVoid -> str "VVoid"
-            | VInteger _ -> str "VInteger"
-            | VConstr _ -> str "VConstr"
-            | VIntroPattern _ -> str "VIntroPattern"
-            | VConstr_context _ -> str "VConstrr_context"
-            | VRec _ -> str "VRec"
-            | VList _ -> str "VList") ++ str".")
+      str "offending expression: " ++ fnl() ++ pr_inspect env e result)))
+  end
+
 
 (* Interprets tactic expressions : returns a "tactic" *)
-and interp_tactic ist tac gl =
-  let (sigma,v) = val_interp ist gl tac in
-  tactic_of_value ist v { gl with sigma=sigma }
+and interp_tactic ist tac : unit Proofview.tactic =
+  Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v)
+
+(* Provides a "name" for the trace to atomic tactics *)
+and name_atomic ?env tacexpr tac : unit Proofview.tactic =
+  begin match env with
+  | Some e -> Proofview.tclUNIT e
+  | None -> Proofview.tclENV
+  end >>= fun env ->
+  let name () = Pptactic.pr_tactic env (TacAtom (Loc.ghost,tacexpr)) in
+  Proofview.Trace.name_tactic name tac
 
 (* Interprets a primitive tactic *)
-and interp_atomic ist gl tac =
-  let env = pf_env gl and sigma = project gl in
+and interp_atomic ist tac : unit Proofview.tactic =
   match tac with
   (* Basic tactics *)
   | TacIntroPattern l ->
-      h_intro_patterns (interp_intro_pattern_list_as_list ist gl l)
-  | TacIntrosUntil hyp ->
-      h_intros_until (interp_quantified_hypothesis ist hyp)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacIntroPattern l)
+          (* spiwack: print uninterpreted, not sure if it is the
+             expected behaviour. *)
+          (Tactics.intros_patterns l')
+      end
   | TacIntroMove (ido,hto) ->
-      h_intro_move (Option.map (interp_fresh_ident ist env) ido)
-                   (interp_move_location ist gl hto)
-  | TacAssumption -> h_assumption
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let mloc = interp_move_location ist env sigma hto in
+        let ido = Option.map (interp_fresh_ident ist env sigma) ido in
+        name_atomic ~env
+          (TacIntroMove(ido,mloc))
+          (Tactics.intro_move ido mloc)
+      end
   | TacExact c ->
-      let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_exact c_interp)
-  | TacExactNoCheck c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_exact_no_check c_interp)
-  | TacVmCastNoCheck c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_vm_cast_no_check c_interp)
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<exact>") begin
+      Proofview.V82.tactic begin fun gl -> 
+        let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.exact_no_check c_interp)
+          gl
+      end
+      end
   | TacApply (a,ev,cb,cl) ->
-      let sigma, l =
-        list_fold_map (interp_open_constr_with_bindings_loc true ist env) sigma cb
-      in
-      let tac = match cl with
-        | None -> h_apply a ev
-        | Some cl ->
-            (fun l -> h_apply_in a ev l (interp_in_hyp_as ist gl cl)) in
-      tclWITHHOLES ev tac sigma l
-  | TacElim (ev,cb,cbo) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
-      tclWITHHOLES ev (h_elim ev cb) sigma cbo
-  | TacElimType c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_elim_type c_interp)
-  | TacCase (ev,cb) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      tclWITHHOLES ev (h_case ev) sigma cb
-  | TacCaseType c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_case_type c_interp)
-  | TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n
-  | TacMutualFix (b,id,n,l) ->
-      let f sigma (id,n,c) =
-	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
-	sigma , (interp_fresh_ident ist env id,n,c_interp) in
-      let (sigma,l_interp) =
-	List.fold_right begin fun c (sigma,acc) ->
-	  let (sigma,c_interp) = f sigma c in
-	  sigma , c_interp::acc
-	end l (project gl,[])
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_mutual_fix b (interp_fresh_ident ist env id) n l_interp)
-  | TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt)
-  | TacMutualCofix (b,id,l) ->
-      let f sigma (id,c) =
-	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
-	sigma , (interp_fresh_ident ist env id,c_interp) in
-      let (sigma,l_interp) =
-	List.fold_right begin fun c (sigma,acc) ->
-	  let (sigma,c_interp) = f sigma c in
-	  sigma , c_interp::acc
-	end l (project gl,[])
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_mutual_cofix b (interp_fresh_ident ist env id) l_interp)
-  | TacCut c ->
-      let (sigma,c_interp) = pf_interp_type ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_cut c_interp)
-  | TacAssert (t,ipat,c) ->
-      let (sigma,c) = (if t=None then interp_constr else interp_type) ist env sigma c in
-      tclTHEN
-	(tclEVARS sigma)
-	(abstract_tactic (TacAssert (t,ipat,c))
-           (Tactics.forward (Option.map (interp_tactic ist) t)
-	      (Option.map (interp_intro_pattern ist gl) ipat) c))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+	let l = List.map (fun (k,c) ->
+          let loc, f = interp_open_constr_with_bindings_loc ist c in
+	    (k,(loc,f))) cb 
+	in
+        let sigma,tac = match cl with
+          | None -> sigma, fun l -> Tactics.apply_with_delayed_bindings_gen a ev l
+          | Some cl ->
+              let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in
+              sigma, fun l -> Tactics.apply_delayed_in a ev clear id l cl in
+        Tacticals.New.tclWITHHOLES ev tac sigma l
+      end
+      end
+  | TacElim (ev,(keep,cb),cbo) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in 
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
+        let named_tac cbo =
+          let tac = Tactics.elim ev keep cb cbo in
+          name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma cbo
+      end
+  | TacCase (ev,(keep,cb)) ->
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cb = interp_constr_with_bindings ist env sigma cb in
+        let named_tac cb =
+          let tac = Tactics.general_case_analysis ev keep cb in
+          name_atomic ~env (TacCase(ev,(keep,cb))) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma cb
+      end
+  | TacFix (idopt,n) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in
+        name_atomic ~env
+          (TacFix(idopt,n))
+          (Proofview.V82.tactic (Tactics.fix idopt n))
+      end
+  | TacMutualFix (id,n,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin
+      Proofview.V82.tactic begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,n,c) =
+	  let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	  sigma , (interp_fresh_ident ist env sigma id,n,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.mutual_fix (interp_fresh_ident ist env sigma id) n l_interp 0)
+          gl
+      end
+      end
+  | TacCofix idopt ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let idopt = Option.map (interp_fresh_ident ist env sigma) idopt in
+        name_atomic ~env
+          (TacCofix (idopt))
+          (Proofview.V82.tactic (Tactics.cofix idopt))
+      end
+  | TacMutualCofix (id,l) ->
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin
+      Proofview.V82.tactic begin fun gl ->
+        let env = pf_env gl in
+        let f sigma (id,c) =
+	  let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
+	  sigma , (interp_fresh_ident ist env sigma id,c_interp) in
+        let (sigma,l_interp) =
+          Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl)
+        in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.mutual_cofix (interp_fresh_ident ist env sigma id) l_interp 0)
+          gl
+      end
+      end
+  | TacAssert (b,t,ipat,c) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c) = 
+          (if Option.is_empty t then interp_constr else interp_type) ist env sigma c
+        in
+        let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in
+        let tac = Option.map (interp_tactic ist) t in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacAssert(b,t,ipat,c))
+          (Tactics.forward b tac ipat' c)
+      end
   | TacGeneralize cl ->
-      let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
-      tclWITHHOLES false (h_generalize_gen) sigma cl
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacGeneralize cl)
+          (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))
+      end
   | TacGeneralizeDep c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_generalize_dep c_interp)
+      (new_interp_constr ist c) (fun c ->
+        name_atomic (* spiwack: probably needs a goal environment *)
+        (TacGeneralizeDep c)
+        (Proofview.V82.tactic (Tactics.generalize_dep c))
+       )
   | TacLetTac (na,c,clp,b,eqpat) ->
-      let clp = interp_clause ist gl clp in
-      let eqpat = Option.map (interp_intro_pattern ist gl) eqpat in
-      if clp = nowhere then
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let clp = interp_clause ist env sigma clp in
+        let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in
+        if Locusops.is_nowhere clp then
         (* We try to fully-typecheck the term *)
-	let (sigma,c_interp) = pf_interp_constr ist gl c in
-	tclTHEN
-	  (tclEVARS sigma)
-          (h_let_tac b (interp_fresh_name ist env na) c_interp clp eqpat)
-      else
+          let (sigma,c_interp) =
+            Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl
+          in
+          let let_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_tac with_eq na c None cl
+          in
+	  Proofview.Unsafe.tclEVARS sigma <*>
+          let na = interp_fresh_name ist env sigma na in
+          name_atomic ~env
+            (TacLetTac(na,c_interp,clp,b,eqpat))
+            (let_tac b na c_interp clp eqpat)
+        else
         (* We try to keep the pattern structure as much as possible *)
-        h_let_pat_tac b (interp_fresh_name ist env na)
-          (interp_pure_open_constr ist env sigma c) clp eqpat
+          let let_pat_tac b na c cl eqpat =
+            let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in
+            let with_eq = if b then None else Some (true,id) in
+            Tactics.letin_pat_tac with_eq na c cl
+          in
+          let (sigma',c) = interp_pure_open_constr ist env sigma c in
+          name_atomic ~env
+            (TacLetTac(na,c,clp,b,eqpat))
+	    (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
+               (let_pat_tac b (interp_fresh_name ist env sigma na)
+                  ((sigma,sigma'),c) clp) sigma' eqpat)
+      end
 
   (* Automation tactics *)
   | TacTrivial (debug,lems,l) ->
-      Auto.h_trivial ~debug
-	(interp_auto_lemmas ist env sigma lems)
-	(Option.map (List.map (interp_hint_base ist)) l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let lems = interp_auto_lemmas ist env sigma lems in
+        name_atomic ~env
+          (TacTrivial(debug,List.map snd lems,l))
+          (Auto.h_trivial ~debug
+	     lems
+	     (Option.map (List.map (interp_hint_base ist)) l))
+      end
   | TacAuto (debug,n,lems,l) ->
-      Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
-	(interp_auto_lemmas ist env sigma lems)
-	(Option.map (List.map (interp_hint_base ist)) l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let lems = interp_auto_lemmas ist env sigma lems in
+        name_atomic ~env
+          (TacAuto(debug,n,List.map snd lems,l))
+          (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
+	     lems
+	     (Option.map (List.map (interp_hint_base ist)) l))
+      end
 
   (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) ->
-      h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h)
-  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
-      let sigma, l =
-        list_fold_map (fun sigma (c,(ipato,ipats)) ->
-          let c = interp_induction_arg ist gl c in
-          (sigma,(c,
-            (Option.map (interp_intro_pattern ist gl) ipato,
-	     Option.map (interp_intro_pattern ist gl) ipats)))) sigma l in
-      let sigma,el =
-        Option.fold_map (interp_constr_with_bindings ist env) sigma el in
-      let cls = Option.map (interp_clause ist gl) cls in
-      tclWITHHOLES ev (h_induction_destruct isrec ev) sigma (l,el,cls)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      (* spiwack: some unknown part of destruct needs the goal to be
+         prenormalised. *)
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma,l =
+          List.fold_map begin fun sigma (c,(ipato,ipats),cls) ->
+            (* TODO: move sigma as a side-effect *)
+             (* spiwack: the [*p] variants are for printing *)
+            let cp = c in
+            let c = Tacmach.New.of_old (fun gl -> interp_induction_arg ist gl c) gl in
+            let ipato = interp_intro_pattern_naming_option ist env sigma ipato in
+            let ipatsp = ipats in
+            let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in
+            let cls = Option.map (interp_clause ist env sigma) cls in
+            sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls))
+          end sigma l
+        in
+        let l,lp = List.split l in
+        let sigma,el =
+          Option.fold_map (interp_constr_with_bindings ist env) sigma el in
+        name_atomic ~env
+          (TacInductionDestruct(isrec,ev,(lp,el)))
+          (Tacticals.New.tclTHEN
+             (Proofview.Unsafe.tclEVARS sigma)
+             (Tactics.induction_destruct isrec ev (l,el)))
+      end
   | TacDoubleInduction (h1,h2) ->
       let h1 = interp_quantified_hypothesis ist h1 in
       let h2 = interp_quantified_hypothesis ist h2 in
-      Elim.h_double_induction h1 h2
-  | TacDecomposeAnd c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose_and c_interp)
-  | TacDecomposeOr c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose_or c_interp)
-  | TacDecompose (l,c) ->
-      let l = List.map (interp_inductive ist) l in
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(Elim.h_decompose l c_interp)
-  | TacSpecialize (n,cb) ->
-      let sigma, cb = interp_constr_with_bindings ist env sigma cb in
-      tclWITHHOLES false (h_specialize n) sigma cb
-  | TacLApply c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_lapply c_interp)
-
+      name_atomic
+        (TacDoubleInduction (h1,h2))
+        (Elim.h_double_induction h1 h2)
   (* Context management *)
-  | TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)
-  | TacClearBody l -> h_clear_body (interp_hyp_list ist gl l)
-  | TacMove (dep,id1,id2) ->
-      h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2)
+  | TacClear (b,l) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l = interp_hyp_list ist env sigma l in
+        if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l)
+        else
+          (* spiwack: until the tactic is in the monad *)
+          let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in
+          Proofview.Trace.name_tactic (fun () -> Pp.str"<clear>") tac
+      end
+  | TacClearBody l ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l = interp_hyp_list ist env sigma l in
+        name_atomic ~env
+          (TacClearBody l)
+          (Tactics.clear_body l)
+      end
+  | TacMove (id1,id2) ->
+      Proofview.V82.tactic begin fun gl -> 
+        Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1)
+                   (interp_move_location ist (pf_env gl) (project gl) id2)
+                   gl
+      end
   | TacRename l ->
-      h_rename (List.map (fun (id1,id2) ->
-			    interp_hyp ist gl id1,
-			    interp_fresh_ident ist env (snd id2)) l)
-  | TacRevert l -> h_revert (interp_hyp_list ist gl l)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Tacmach.New.pf_env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let l =
+          List.map (fun (id1,id2) ->
+	    interp_hyp ist env sigma id1,
+	    interp_fresh_ident ist env sigma (snd id2)) l
+        in
+        name_atomic ~env
+          (TacRename l)
+          (Tactics.rename_hyp l)
+      end
 
   (* Constructors *)
-  | TacLeft (ev,bl) ->
-      let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_left ev) sigma bl
-  | TacRight (ev,bl) ->
-      let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_right ev) sigma bl
-  | TacSplit (ev,_,bll) ->
-      let sigma, bll = list_fold_map (interp_bindings ist env) sigma bll in
-      tclWITHHOLES ev (h_split ev) sigma bll
-  | TacAnyConstructor (ev,t) ->
-      abstract_tactic (TacAnyConstructor (ev,t))
-        (Tactics.any_constructor ev (Option.map (interp_tactic ist) t))
-  | TacConstructor (ev,n,bl) ->
-      let sigma, bl = interp_bindings ist env sigma bl in
-      tclWITHHOLES ev (h_constructor ev (interp_int_or_var ist n)) sigma bl
-
+  | TacSplit (ev,bll) ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in
+        let named_tac bll =
+          let tac = Tactics.split_with_bindings ev bll in
+          name_atomic ~env (TacSplit (ev, bll)) tac
+        in
+        Tacticals.New.tclWITHHOLES ev named_tac sigma bll
+      end
   (* Conversion *)
   | TacReduce (r,cl) ->
-      let (sigma,r_interp) = pf_interp_red_expr ist gl r in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_reduce r_interp (interp_clause ist gl cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<reduce>") begin
+      Proofview.V82.tactic begin fun gl -> 
+        let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in
+        tclTHEN
+	  (tclEVARS sigma)
+	  (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl))
+          gl
+      end
+      end
   | TacChange (None,c,cl) ->
-      let (sigma,c_interp) =
-	if (cl.onhyps = None or cl.onhyps = Some []) &
-	    (cl.concl_occs = all_occurrences_expr or
-	     cl.concl_occs = no_occurrences_expr)
-	 then pf_interp_type ist gl c
-	 else pf_interp_constr ist gl c
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_change None c_interp (interp_clause ist gl cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.V82.tactic begin fun gl ->
+        let is_onhyps = match cl.onhyps with
+          | None | Some [] -> true
+          | _ -> false
+        in
+        let is_onconcl = match cl.concl_occs with
+          | AllOccurrences | NoOccurrences -> true
+          | _ -> false
+        in
+        let c_interp sigma =
+	  if is_onhyps && is_onconcl
+	  then interp_type ist (pf_env gl) sigma c
+	  else interp_constr ist (pf_env gl) sigma c
+        in
+	  (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl))
+          gl
+      end
+      end
   | TacChange (Some op,c,cl) ->
-      let sign,op = interp_typed_pattern ist env sigma op in
-      (* spiwack: (2012/04/18) the evar_map output by pf_interp_constr
-	 is dropped as the evar_map taken as input (from
-	 extend_gl_hyps) is incorrect.  This means that evar
-	 instantiated by pf_interp_constr may be lost, there. *)
-      let (_,c_interp) =
-	try pf_interp_constr ist (extend_gl_hyps gl sign) c
-	with Not_found | Anomaly _ (* Hack *) ->
-	   errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
-      in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_change (Some op) c_interp (interp_clause ist { gl with sigma=sigma } cl))
+      (* spiwack: until the tactic is in the monad *)
+      Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin
+      Proofview.V82.nf_evar_goals <*>
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        Proofview.V82.tactic begin fun gl -> 
+          let sign,op = interp_typed_pattern ist env sigma op in
+          let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in
+	  let env' = Environ.push_named_context sign env in
+          let c_interp sigma =
+	      try interp_constr ist env' sigma c
+	      with e when to_catch e (* Hack *) ->
+		errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
+          in
+	      (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl))
+		gl
+        end
+      end
+      end
 
   (* Equivalence relations *)
-  | TacReflexivity -> h_reflexivity
-  | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
-  | TacTransitivity c ->
-    begin match c with
-    | None -> h_transitivity None
-    | Some c ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      tclTHEN
-	(tclEVARS sigma)
-	(h_transitivity (Some c_interp))
-    end
+  | TacSymmetry c ->
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let cl = interp_clause ist env sigma c in
+        name_atomic ~env
+          (TacSymmetry cl)
+          (Tactics.intros_symmetry cl)
+      end
 
   (* Equality and inversion *)
   | TacRewrite (ev,l,cl,by) ->
-      let l = List.map (fun (b,m,c) ->
-        let f env sigma = interp_open_constr_with_bindings false ist env sigma c in
-	(b,m,f)) l in
-      let cl = interp_clause ist gl cl in
-      Equality.general_multi_multi_rewrite ev l cl
-        (Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)
+      Proofview.Goal.enter begin fun gl ->
+        let l' = List.map (fun (b,m,(keep,c)) ->
+          let f env sigma = interp_open_constr_with_bindings ist env sigma c in
+	  (b,m,keep,f)) l in
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let cl = interp_clause ist env sigma cl in
+        name_atomic ~env
+          (TacRewrite (ev,l,cl,by))
+          (Equality.general_multi_rewrite ev l' cl
+             (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by),
+               Equality.Naive)
+                by))
+      end
   | TacInversion (DepInversion (k,c,ids),hyp) ->
-      let (sigma,c_interp) =
-	match c with
-	| None -> sigma , None
-	| Some c ->
-	  let (sigma,c_interp) = pf_interp_constr ist gl c in
-	  sigma , Some c_interp
-      in
-      Inv.dinv k c_interp
-        (Option.map (interp_intro_pattern ist gl) ids)
-        (interp_declared_or_quantified_hypothesis ist gl hyp)
+      Proofview.Goal.nf_enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c_interp) =
+          match c with
+          | None -> sigma , None
+          | Some c ->
+              let (sigma,c_interp) =
+                Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl
+              in
+              sigma , Some c_interp
+        in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion(DepInversion(k,c_interp,ids),dqhyps))
+          (Inv.dinv k c_interp ids_interp dqhyps)
+      end
   | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
-      Inv.inv_clause k
-        (Option.map (interp_intro_pattern ist gl) ids)
-        (interp_hyp_list ist gl idl)
-        (interp_declared_or_quantified_hypothesis ist gl hyp)
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let hyps = interp_hyp_list ist env sigma idl in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion (NonDepInversion (k,hyps,ids),dqhyps))
+          (Inv.inv_clause k ids_interp hyps dqhyps)
+      end
   | TacInversion (InversionUsing (c,idl),hyp) ->
-      let (sigma,c_interp) = pf_interp_constr ist gl c in
-      Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
-        c_interp
-        (interp_hyp_list ist gl idl)
-
-  (* For extensions *)
-  | TacExtend (loc,opn,l) ->
-      let tac = lookup_tactic opn in
-      let (sigma,args) = 
-	List.fold_right begin fun a (sigma,acc) ->
-	  let (sigma,a_interp) = interp_genarg ist { gl with sigma=sigma } a in
-	  sigma , a_interp::acc
-	end l (project gl,[])
-      in
-      abstract_extended_tactic opn args (tac args)
-  | TacAlias (loc,s,l,(_,body)) -> fun gl ->
-    let evdref = ref gl.sigma in
-    let rec f x = match genarg_tag x with
-    | IntArgType ->
-        VInteger (out_gen globwit_int x)
-    | IntOrVarArgType ->
-        mk_int_or_var_value ist (out_gen globwit_int_or_var x)
-    | PreIdentArgType ->
-	failwith "pre-identifiers cannot be bound"
-    | IntroPatternArgType ->
-	VIntroPattern
-	  (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)))
-    | IdentArgType b ->
-	value_of_ident (interp_fresh_ident ist env
-	  (out_gen (globwit_ident_gen b) x))
-    | VarArgType ->
-        mk_hyp_value ist gl (out_gen globwit_var x)
-    | RefArgType ->
-        VConstr ([],constr_of_global
-          (pf_interp_reference ist gl (out_gen globwit_ref x)))
-    | SortArgType ->
-        VConstr ([],mkSort (interp_sort (out_gen globwit_sort x)))
-    | ConstrArgType ->
-        let (sigma,v) = mk_constr_value ist gl (out_gen globwit_constr x) in
-	evdref := sigma;
-	v
-    | OpenConstrArgType (false,true) ->
-        let (sigma,v) = mk_open_constr_value true ist gl (snd (out_gen globwit_open_constr_wTC x)) in
-	evdref := sigma;
-	v
-    | OpenConstrArgType (false,false) ->
-        let (sigma,v) = mk_open_constr_value false ist gl (snd (out_gen globwit_open_constr x)) in
-	evdref := sigma;
-	v
-    | ConstrMayEvalArgType ->
-        let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
-	evdref := sigma;
-	VConstr ([],c_interp)
-    | ExtraArgType s when tactic_genarg_level s <> None ->
-          (* Special treatment of tactic arguments *)
-	let (sigma,v) = val_interp ist gl
-          (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
-	in
-	evdref := sigma;
-	v
-    | List0ArgType ConstrArgType ->
-        let wit = wit_list0 globwit_constr in
-	let (sigma,l_interp) =
-	  List.fold_right begin fun c (sigma,acc) ->
-	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
-	    sigma , c_interp::acc
-	  end (out_gen wit x) (project gl,[])
-	in
-	evdref := sigma;
-        VList (l_interp)
-    | List0ArgType VarArgType ->
-        let wit = wit_list0 globwit_var in
-        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List0ArgType IntArgType ->
-        let wit = wit_list0 globwit_int in
-        VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List0ArgType IntOrVarArgType ->
-        let wit = wit_list0 globwit_int_or_var in
-        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
-    | List0ArgType (IdentArgType b) ->
-        let wit = wit_list0 (globwit_ident_gen b) in
-	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
-        VList (List.map mk_ident (out_gen wit x))
-    | List0ArgType IntroPatternArgType ->
-        let wit = wit_list0 globwit_intro_pattern in
-	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
-        VList (List.map mk_ipat (out_gen wit x))
-    | List1ArgType ConstrArgType ->
-        let wit = wit_list1 globwit_constr in
-	let (sigma, l_interp) =
-	  List.fold_right begin fun c (sigma,acc) ->
-	    let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
-	    sigma , c_interp::acc
-	  end (out_gen wit x) (project gl,[])
-	in
-	evdref:=sigma;
-        VList l_interp
-    | List1ArgType VarArgType ->
-        let wit = wit_list1 globwit_var in
-        VList (List.map (mk_hyp_value ist gl) (out_gen wit x))
-    | List1ArgType IntArgType ->
-        let wit = wit_list1 globwit_int in
-        VList (List.map (fun x -> VInteger x) (out_gen wit x))
-    | List1ArgType IntOrVarArgType ->
-        let wit = wit_list1 globwit_int_or_var in
-        VList (List.map (mk_int_or_var_value ist) (out_gen wit x))
-    | List1ArgType (IdentArgType b) ->
-        let wit = wit_list1 (globwit_ident_gen b) in
-	let mk_ident x = value_of_ident (interp_fresh_ident ist env x) in
-        VList (List.map mk_ident (out_gen wit x))
-    | List1ArgType IntroPatternArgType ->
-        let wit = wit_list1 globwit_intro_pattern in
-	let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in
-        VList (List.map mk_ipat (out_gen wit x))
-    | StringArgType | BoolArgType
-    | QuantHypArgType | RedExprArgType
-    | OpenConstrArgType _ | ConstrWithBindingsArgType
-    | ExtraArgType _ | BindingsArgType
-    | OptArgType _ | PairArgType _
-    | List0ArgType _ | List1ArgType _
-	-> error "This argument type is not supported in tactic notations."
-
-    in
-    let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
-    let trace = push_trace (loc,LtacNotationCall s) ist.trace in
-    let gl = { gl with sigma = !evdref } in
-    interp_tactic { ist with lfun=lfun; trace=trace } body gl
-
-let make_empty_glob_sign () =
-  { ltacvars = ([],[]); ltacrecvars = [];
-    gsigma = Evd.empty; genv = Global.env() }
-
-let fully_empty_glob_sign =
-  { ltacvars = ([],[]); ltacrecvars = [];
-    gsigma = Evd.empty; genv = Environ.empty_env }
+      Proofview.Goal.enter begin fun gl ->
+        let env = Proofview.Goal.env gl in
+        let sigma = Proofview.Goal.sigma gl in
+        let (sigma,c_interp) = interp_constr ist env sigma c in
+        let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in
+        let hyps = interp_hyp_list ist env sigma idl in
+        Proofview.Unsafe.tclEVARS sigma <*>
+        name_atomic ~env
+          (TacInversion (InversionUsing (c_interp,hyps),dqhyps))
+          (Leminv.lemInv_clause dqhyps c_interp hyps)
+      end
 
 (* Initial call for interpretation *)
-let interp_tac_gen lfun avoid_ids debug t gl =
-  interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] }
-    (intern_tactic true {
-      ltacvars = (List.map fst lfun, []); ltacrecvars = [];
-      gsigma = project gl; genv = pf_env gl } t) gl
-
-let eval_tactic t gls =
-  db_initialize ();
-  interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] }
-    t gls
-
-let interp t = interp_tac_gen [] [] (get_debug()) t
-
-let eval_ltac_constr gl t =
-  interp_ltac_constr
-    { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl
-    (intern_tactic_or_tacarg (make_empty_glob_sign ()) t )
-
-(* Hides interpretation for pretty-print *)
-let hide_interp t ot gl =
-  let ist = { ltacvars = ([],[]); ltacrecvars = [];
-            gsigma = project gl; genv = pf_env gl } in
-  let te = intern_tactic true ist t in
-  let t = eval_tactic te in
-  match ot with
-  | None -> abstract_tactic_expr (TacArg (dloc,Tacexp te)) t gl
-  | Some t' ->
-      abstract_tactic_expr ~dflt:true (TacArg (dloc,Tacexp te)) (tclTHEN t t') gl
-
-(***************************************************************************)
-(* Substitution at module closing time *)
-
-let subst_quantified_hypothesis _ x = x
-
-let subst_declared_or_quantified_hypothesis _ x = x
-
-let subst_glob_constr_and_expr subst (c,e) =
-  assert (e=None); (* e<>None only for toplevel tactics *)
-  (Detyping.subst_glob_constr subst c,None)
-
-let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
-
-let subst_binding subst (loc,b,c) =
-  (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c)
-
-let subst_bindings subst = function
-  | NoBindings -> NoBindings
-  | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l)
-  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
-
-let subst_glob_with_bindings subst (c,bl) =
-  (subst_glob_constr subst c, subst_bindings subst bl)
-
-let subst_induction_arg subst = function
-  | ElimOnConstr c -> ElimOnConstr (subst_glob_with_bindings subst c)
-  | ElimOnAnonHyp n as x -> x
-  | ElimOnIdent id as x -> x
-
-let subst_and_short_name f (c,n) =
-(*  assert (n=None); *)(* since tacdef are strictly globalized *)
-  (f c,None)
-
-let subst_or_var f =  function
-  | ArgVar _ as x -> x
-  | ArgArg x -> ArgArg (f x)
-
-let subst_located f (_loc,id) = (dloc,f id)
-
-let subst_reference subst =
-  subst_or_var (subst_located (subst_kn subst))
-
-(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
-  to the syntactic non-terminals "global", used in commands such as
-  Print. It is also used for non-evaluable references. *)
-let subst_global_reference subst =
- let subst_global ref =
-  let ref',t' = subst_global subst ref in
-   if not (eq_constr (constr_of_global ref') t') then
-    ppnl (str "Warning: The reference " ++ pr_global ref ++ str " is not " ++
-          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
-          pr_global ref') ;
-   ref'
- in
-  subst_or_var (subst_located subst_global)
-
-let subst_evaluable subst =
-  let subst_eval_ref = subst_evaluable_reference subst in
-    subst_or_var (subst_and_short_name subst_eval_ref)
-
-let subst_unfold subst (l,e) =
-  (l,subst_evaluable subst e)
-
-let subst_flag subst red =
-  { red with rConst = List.map (subst_evaluable subst) red.rConst }
-
-let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c)
-
-let subst_glob_constr_or_pattern subst (c,p) =
-  (subst_glob_constr subst c,subst_pattern subst p)
-
-let subst_pattern_with_occurrences subst (l,p) =
-  (l,subst_glob_constr_or_pattern subst p)
-
-let subst_redexp subst = function
-  | Unfold l -> Unfold (List.map (subst_unfold subst) l)
-  | Fold l -> Fold (List.map (subst_glob_constr subst) l)
-  | Cbv f -> Cbv (subst_flag subst f)
-  | Lazy f -> Lazy (subst_flag subst f)
-  | Pattern l -> Pattern (List.map (subst_constr_with_occurrences subst) l)
-  | Simpl o -> Simpl (Option.map (subst_pattern_with_occurrences subst) o)
-  | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r) -> r
-
-let subst_raw_may_eval subst = function
-  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c)
-  | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c)
-  | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c)
-  | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
-
-let subst_match_pattern subst = function
-  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
-  | Term pc -> Term (subst_glob_constr_or_pattern subst pc)
-
-let rec subst_match_goal_hyps subst = function
-  | Hyp (locs,mp) :: tl ->
-      Hyp (locs,subst_match_pattern subst mp)
-      :: subst_match_goal_hyps subst tl
-  | Def (locs,mv,mp) :: tl ->
-      Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
-      :: subst_match_goal_hyps subst tl
-  | [] -> []
-
-let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
-  (* Basic tactics *)
-  | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
-  | TacAssumption as x -> x
-  | TacExact c -> TacExact (subst_glob_constr subst c)
-  | TacExactNoCheck c -> TacExactNoCheck (subst_glob_constr subst c)
-  | TacVmCastNoCheck c -> TacVmCastNoCheck (subst_glob_constr subst c)
-  | TacApply (a,ev,cb,cl) ->
-      TacApply (a,ev,List.map (subst_glob_with_bindings subst) cb,cl)
-  | TacElim (ev,cb,cbo) ->
-      TacElim (ev,subst_glob_with_bindings subst cb,
-               Option.map (subst_glob_with_bindings subst) cbo)
-  | TacElimType c -> TacElimType (subst_glob_constr subst c)
-  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings subst cb)
-  | TacCaseType c -> TacCaseType (subst_glob_constr subst c)
-  | TacFix (idopt,n) as x -> x
-  | TacMutualFix (b,id,n,l) ->
-      TacMutualFix(b,id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
-  | TacCofix idopt as x -> x
-  | TacMutualCofix (b,id,l) ->
-      TacMutualCofix (b,id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
-  | TacCut c -> TacCut (subst_glob_constr subst c)
-  | TacAssert (b,na,c) ->
-      TacAssert (Option.map (subst_tactic subst) b,na,subst_glob_constr subst c)
-  | TacGeneralize cl ->
-      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
-  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
-  | TacLetTac (id,c,clp,b,eqpat) ->
-    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
 
-  (* Automation tactics *)
-  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
-  | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
-
-  (* Derived basic tactics *)
-  | TacSimpleInductionDestruct (isrec,h) as x -> x
-  | TacInductionDestruct (isrec,ev,(l,el,cls)) ->
-      let l' = List.map (fun (c,ids) -> subst_induction_arg subst c, ids) l in
-      let el' = Option.map (subst_glob_with_bindings subst) el in
-      TacInductionDestruct (isrec,ev,(l',el',cls))
-  | TacDoubleInduction (h1,h2) as x -> x
-  | TacDecomposeAnd c -> TacDecomposeAnd (subst_glob_constr subst c)
-  | TacDecomposeOr c -> TacDecomposeOr (subst_glob_constr subst c)
-  | TacDecompose (l,c) ->
-      let l = List.map (subst_or_var (subst_inductive subst)) l in
-      TacDecompose (l,subst_glob_constr subst c)
-  | TacSpecialize (n,l) -> TacSpecialize (n,subst_glob_with_bindings subst l)
-  | TacLApply c -> TacLApply (subst_glob_constr subst c)
-
-  (* Context management *)
-  | TacClear _ as x -> x
-  | TacClearBody l as x -> x
-  | TacMove (dep,id1,id2) as x -> x
-  | TacRename l as x -> x
-  | TacRevert _ as x -> x
-
-  (* Constructors *)
-  | TacLeft (ev,bl) -> TacLeft (ev,subst_bindings subst bl)
-  | TacRight (ev,bl) -> TacRight (ev,subst_bindings subst bl)
-  | TacSplit (ev,b,bll) -> TacSplit (ev,b,List.map (subst_bindings subst) bll)
-  | TacAnyConstructor (ev,t) -> TacAnyConstructor (ev,Option.map (subst_tactic subst) t)
-  | TacConstructor (ev,n,bl) -> TacConstructor (ev,n,subst_bindings subst bl)
-
-  (* Conversion *)
-  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
-  | TacChange (op,c,cl) ->
-      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
-        subst_glob_constr subst c, cl)
-
-  (* Equivalence relations *)
-  | TacReflexivity | TacSymmetry _ as x -> x
-  | TacTransitivity c -> TacTransitivity (Option.map (subst_glob_constr subst) c)
-
-  (* Equality and inversion *)
-  | TacRewrite (ev,l,cl,by) ->
-      TacRewrite (ev,
-		  List.map (fun (b,m,c) ->
-			      b,m,subst_glob_with_bindings subst c) l,
-		 cl,Option.map (subst_tactic subst) by)
-  | TacInversion (DepInversion (k,c,l),hyp) ->
-     TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp)
-  | TacInversion (NonDepInversion _,_) as x -> x
-  | TacInversion (InversionUsing (c,cl),hyp) ->
-      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
-
-  (* For extensions *)
-  | TacExtend (_loc,opn,l) ->
-      TacExtend (dloc,opn,List.map (subst_genarg subst) l)
-  | TacAlias (_,s,l,(dir,body)) ->
-      TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
-        (dir,subst_tactic subst body))
-
-and subst_tactic subst (t:glob_tactic_expr) = match t with
-  | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
-  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
-  | TacLetIn (r,l,u) ->
-      let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in
-      TacLetIn (r,l,subst_tactic subst u)
-  | TacMatchGoal (lz,lr,lmr) ->
-      TacMatchGoal(lz,lr, subst_match_rule subst lmr)
-  | TacMatch (lz,c,lmr) ->
-      TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr)
-  | TacId _ | TacFail _ as x -> x
-  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
-  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
-  | TacThen (t1,tf,t2,tl) ->
-      TacThen (subst_tactic subst t1,Array.map (subst_tactic subst) tf,
-	       subst_tactic subst t2,Array.map (subst_tactic subst) tl)
-  | TacThens (t,tl) ->
-      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
-  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
-  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
-  | TacTry tac -> TacTry (subst_tactic subst tac)
-  | TacInfo tac -> TacInfo (subst_tactic subst tac)
-  | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
-  | TacOrelse (tac1,tac2) ->
-      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
-  | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
-  | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
-  | TacComplete tac -> TacComplete (subst_tactic subst tac)
-  | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
-
-and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
-
-and subst_tacarg subst = function
-  | Reference r -> Reference (subst_reference subst r)
-  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
-  | MetaIdArg (_loc,_,_) -> assert false
-  | TacCall (_loc,f,l) ->
-      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
-  | TacExternal (_loc,com,req,la) ->
-      TacExternal (_loc,com,req,List.map (subst_tacarg subst) la)
-  | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
-  | Tacexp t -> Tacexp (subst_tactic subst t)
-  | TacDynamic(the_loc,t) as x ->
-      (match Dyn.tag t with
-	| "tactic" | "value" -> x
-        | "constr" ->
-          TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
-	| s -> anomaly_loc (dloc, "Tacinterp.val_interp",
-                 str "Unknown dynamic: <" ++ str s ++ str ">"))
-
-(* Reads the rules of a Match Context or a Match *)
-and subst_match_rule subst = function
-  | (All tc)::tl ->
-      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
-  | (Pat (rl,mp,tc))::tl ->
-      let hyps = subst_match_goal_hyps subst rl in
-      let pat = subst_match_pattern subst mp in
-      Pat (hyps,pat,subst_tactic subst tc)
-      ::(subst_match_rule subst tl)
-  | [] -> []
+let default_ist () =
+  let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in
+  { lfun = Id.Map.empty; extra = extra }
+
+let eval_tactic t =
+  Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *)
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic (default_ist ()) t
+
+let eval_tactic_ist ist t =
+  Proofview.tclLIFT db_initialize <*>
+  interp_tactic ist t
+
+(* globalization + interpretation *)
+
+
+let interp_tac_gen lfun avoid_ids debug t =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let extra = TacStore.set TacStore.empty f_debug debug in
+  let extra = TacStore.set extra f_avoid_ids avoid_ids in
+  let ist = { lfun = lfun; extra = extra } in
+  let ltacvars = Id.Map.domain lfun in
+  interp_tactic ist
+    (intern_pure_tactic {
+      ltacvars; ltacrecvars = Id.Map.empty;
+      genv = env } t)
+  end
 
-and subst_genarg subst (x:glob_generic_argument) =
-  match genarg_tag x with
-  | BoolArgType -> in_gen globwit_bool (out_gen globwit_bool x)
-  | IntArgType -> in_gen globwit_int (out_gen globwit_int x)
-  | IntOrVarArgType -> in_gen globwit_int_or_var (out_gen globwit_int_or_var x)
-  | StringArgType -> in_gen globwit_string (out_gen globwit_string x)
-  | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x)
-  | IntroPatternArgType ->
-      in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x)
-  | IdentArgType b ->
-      in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x)
-  | VarArgType -> in_gen globwit_var (out_gen globwit_var x)
-  | RefArgType ->
-      in_gen globwit_ref (subst_global_reference subst
-	(out_gen globwit_ref x))
-  | SortArgType ->
-      in_gen globwit_sort (out_gen globwit_sort x)
-  | ConstrArgType ->
-      in_gen globwit_constr (subst_glob_constr subst (out_gen globwit_constr x))
-  | ConstrMayEvalArgType ->
-      in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
-  | QuantHypArgType ->
-      in_gen globwit_quant_hyp
-        (subst_declared_or_quantified_hypothesis subst
-          (out_gen globwit_quant_hyp x))
-  | RedExprArgType ->
-      in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
-  | OpenConstrArgType (b1,b2) ->
-      in_gen (globwit_open_constr_gen (b1,b2))
-        ((),subst_glob_constr subst (snd (out_gen (globwit_open_constr_gen (b1,b2)) x)))
-  | ConstrWithBindingsArgType ->
-      in_gen globwit_constr_with_bindings
-        (subst_glob_with_bindings subst (out_gen globwit_constr_with_bindings x))
-  | BindingsArgType ->
-      in_gen globwit_bindings
-        (subst_bindings subst (out_gen globwit_bindings x))
-  | List0ArgType _ -> app_list0 (subst_genarg subst) x
-  | List1ArgType _ -> app_list1 (subst_genarg subst) x
-  | OptArgType _ -> app_opt (subst_genarg subst) x
-  | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x
-  | ExtraArgType s ->
-      match tactic_genarg_level s with
-      | Some n ->
-          (* Special treatment of tactic arguments *)
-          in_gen (globwit_tactic n)
-            (subst_tactic subst (out_gen (globwit_tactic n) x))
-      | None ->
-          lookup_genarg_subst s subst x
+let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
+let _ = Proof_global.set_interp_tac interp
+
+(* Used to hide interpretation for pretty-print, now just launch tactics *)
+(* [global] means that [t] should be internalized outside of goals. *)
+let hide_interp global t ot =
+  let hide_interp env =
+    let ist = { ltacvars = Id.Set.empty; ltacrecvars = Id.Map.empty;
+                genv = env } in
+    let te = intern_pure_tactic ist t in
+    let t = eval_tactic te in
+    match ot with
+    | None -> t
+    | Some t' -> Tacticals.New.tclTHEN t t'
+  in
+  if global then
+    Proofview.tclENV >>= fun env ->
+    hide_interp env
+  else
+    Proofview.Goal.enter begin fun gl ->
+      hide_interp (Proofview.Goal.env gl)
+    end
 
 (***************************************************************************)
-(* Tactic registration *)
-
-(* Declaration of the TAC-DEFINITION object *)
-let add (kn,td) = mactab := Gmap.add kn td !mactab
-let replace (kn,td) = mactab := Gmap.add kn td (Gmap.remove kn !mactab)
-
-type tacdef_kind = | NewTac of identifier
-		   | UpdateTac of ltac_constant
-
-let load_md i ((sp,kn),(local,defs)) =
-  let dp,_ = repr_path sp in
-  let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) ->
-    match id with
-	NewTac id ->
-	  let sp = Libnames.make_path dp id in
-	  let kn = Names.make_kn mp dir (label_of_id id) in
-	    Nametab.push_tactic (Until i) sp kn;
-	    add (kn,t)
-      | UpdateTac kn -> replace (kn,t)) defs
-
-let open_md i ((sp,kn),(local,defs)) =
-  let dp,_ = repr_path sp in
-  let mp,dir,_ = repr_kn kn in
-  List.iter (fun (id,t) ->
-    match id with
-	NewTac id ->
-	  let sp = Libnames.make_path dp id in
-	  let kn = Names.make_kn mp dir (label_of_id id) in
-	    Nametab.push_tactic (Exactly i) sp kn
-      | UpdateTac kn -> ()) defs
-
-let cache_md x = load_md 1 x
-
-let subst_kind subst id =
-  match id with
-    | NewTac _ -> id
-    | UpdateTac kn -> UpdateTac (subst_kn subst kn)
-
-let subst_md (subst,(local,defs)) =
-  (local,
-   List.map (fun (id,t) -> (subst_kind subst id,subst_tactic subst t)) defs)
-
-let classify_md (local,defs as o) =
-  if local then Dispose else Substitute o
-
-let inMD : bool * (tacdef_kind * glob_tactic_expr) list -> obj =
-  declare_object {(default_object "TAC-DEFINITION") with
-     cache_function  = cache_md;
-     load_function   = load_md;
-     open_function   = open_md;
-     subst_function = subst_md;
-     classify_function = classify_md}
-
-let rec split_ltac_fun = function
-  | TacFun (l,t) -> (l,t)
-  | t -> ([],t)
-
-let pr_ltac_fun_arg = function
-  | None -> spc () ++ str "_"
-  | Some id -> spc () ++ pr_id id
-
-let print_ltac id =
- try
-  let kn = Nametab.locate_tactic id in
-  let l,t = split_ltac_fun (lookup kn) in
-  hv 2 (
-    hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++
-           prlist pr_ltac_fun_arg l ++ spc () ++ str ":=")
-    ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t)
- with
-  Not_found ->
-   errorlabstrm "print_ltac"
-    (pr_qualid id ++ spc() ++ str "is not a user defined tactic.")
-
-open Libnames
+(** Register standard arguments *)
+
+let def_intern ist x = (ist, x)
+let def_subst _ x = x
+let def_interp ist gl x = (project gl, x)
+
+let declare_uniform t =
+  Genintern.register_intern0 t def_intern;
+  Genintern.register_subst0 t def_subst;
+  Geninterp.register_interp0 t def_interp
+
+let () =
+  declare_uniform wit_unit
+
+let () =
+  declare_uniform wit_int
+
+let () =
+  declare_uniform wit_bool
+
+let () =
+  declare_uniform wit_string
+
+let () =
+  declare_uniform wit_pre_ident
+
+let () =
+  let interp ist gl ref = (project gl, interp_reference ist (pf_env gl) (project gl) ref) in
+  Geninterp.register_interp0 wit_ref interp;
+  let interp ist gl pat = interp_intro_pattern ist (pf_env gl) (project gl) pat in
+  Geninterp.register_interp0 wit_intro_pattern interp;
+  let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) (project gl) pat) in
+  Geninterp.register_interp0 wit_clause_dft_concl interp;
+  let interp ist gl s = interp_sort (project gl) s in
+  Geninterp.register_interp0 wit_sort interp
+
+let () =
+  let interp ist gl tac =
+    let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in
+    (project gl, TacArg (dloc, valueIn (of_tacvalue f)))
+  in
+  Geninterp.register_interp0 wit_tactic interp
 
-(* Adds a definition for tactics in the table *)
-let make_absolute_name ident repl =
-  let loc = loc_of_reference ident in
-  try
-    let id, kn =
-      if repl then None, Nametab.locate_tactic (snd (qualid_of_reference ident))
-      else let id = coerce_reference_to_id ident in
-	     Some id, Lib.make_kn id
-    in
-      if Gmap.mem kn !mactab then
-	if repl then id, kn
-	else
-	  user_err_loc (loc,"Tacinterp.add_tacdef",
-		       str "There is already an Ltac named " ++ pr_reference ident ++ str".")
-      else if is_atomic_kn kn then
-	user_err_loc (loc,"Tacinterp.add_tacdef",
-		     str "Reserved Ltac name " ++ pr_reference ident ++ str".")
-      else id, kn
-  with Not_found ->
-    user_err_loc (loc,"Tacinterp.add_tacdef",
-		 str "There is no Ltac named " ++ pr_reference ident ++ str".")
-
-let add_tacdef local isrec tacl =
-  let rfun = List.map (fun (ident, b, _) -> make_absolute_name ident b) tacl in
-  let ist =
-    {(make_empty_glob_sign()) with ltacrecvars =
-	if isrec then list_map_filter
-	  (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun
-	else []} in
-  let gtacl =
-    List.map2 (fun (_,b,def) (id, qid) ->
-      let k = if b then UpdateTac qid else NewTac (Option.get id) in
-      let t = Flags.with_option strict_check (intern_tactic_or_tacarg ist) def in
-	(k, t))
-      tacl rfun in
-  let id0 = fst (List.hd rfun) in
-  let _ = match id0 with
-    | Some id0 -> ignore(Lib.add_leaf id0 (inMD (local,gtacl)))
-    | _ -> Lib.add_anonymous_leaf (inMD (local,gtacl)) in
-  List.iter
-    (fun (id,b,_) ->
-      Flags.if_verbose msgnl (Libnames.pr_reference id ++
-				 (if b then str " is redefined"
-				   else str " is defined")))
-    tacl
+let () =
+  Geninterp.register_interp0 wit_uconstr (fun ist gl c ->
+     project gl , interp_uconstr ist (pf_env gl) c
+  )
 
 (***************************************************************************)
 (* Other entry points *)
 
-let glob_tactic x =
-  Flags.with_option strict_check (intern_tactic true (make_empty_glob_sign ())) x
+let val_interp ist tac k = Ftactic.run (val_interp ist tac) k
 
-let glob_tactic_env l env x =
-  Flags.with_option strict_check
-  (intern_pure_tactic
-    { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env })
-    x
+let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k
 
 let interp_redexp env sigma r =
-  let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in
-  let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
-  interp_red_expr ist sigma env (intern_red_expr gist r)
+  let ist = default_ist () in
+  let gist = { fully_empty_glob_sign with genv = env; } in
+  interp_red_expr ist env sigma (intern_red_expr gist r)
 
 (***************************************************************************)
 (* Embed tactics in raw or glob tactic expr *)
@@ -3190,30 +2336,80 @@ let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t))
 let tacticIn t =
   globTacticIn (fun ist ->
     try glob_tactic (t ist)
-    with e when Errors.noncritical e ->
-      anomalylabstrm "tacticIn"
+    with e when Errors.noncritical e -> anomaly ~label:"tacticIn"
       (str "Incorrect tactic expression. Received exception is:" ++
        Errors.print e))
 
-let tacticOut = function
-  | TacArg (_,TacDynamic (_,d)) ->
-    if (Dyn.tag d) = "tactic" then
-      tactic_out d
-    else
-      anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
-  | ast ->
-    anomalylabstrm "tacticOut"
-      (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
-
 (***************************************************************************)
 (* Backwarding recursive needs of tactic glob/interp/eval functions *)
 
-let _ = Auto.set_extern_interp
-  (fun l ->
-    let l = List.map (fun (id,c) -> (id,VConstr ([],c))) l in
-    interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]})
-let _ = Auto.set_extern_intern_tac
+let _ =
+  let eval ty env sigma lfun arg =
+    let ist = { lfun = lfun; extra = TacStore.empty; } in
+    if has_type arg (glbwit wit_tactic) then
+      let tac = out_gen (glbwit wit_tactic) arg in
+      let tac = interp_tactic ist tac in
+      (** Save the initial side-effects to restore them afterwards. We set the
+          current set of side-effects to be empty so that we can retrieve the
+          ones created during the tactic invocation easily. *)
+      let eff = Evd.eval_side_effects sigma in
+      let sigma = Evd.drop_side_effects sigma in
+      (** Start a proof *)
+      let prf = Proof.start sigma [env, ty] in
+      let (prf, _) =
+        try Proof.run_tactic env tac prf
+        with Logic_monad.TacticFailure e as src ->
+          (** Catch the inner error of the monad tactic *)
+          let (_, info) = Errors.push src in
+          iraise (e, info)
+      in
+      (** Plug back the retrieved sigma *)
+      let sigma = Proof.in_proof prf (fun sigma -> sigma) in
+      let ans = match Proof.initial_goals prf with
+      | [c, _] -> c
+      | _ -> assert false
+      in
+      let ans = Reductionops.nf_evar sigma ans in
+      (** [neff] contains the freshly generated side-effects *)
+      let neff = Evd.eval_side_effects sigma in
+      (** Reset the old side-effects *)
+      let sigma = Evd.drop_side_effects sigma in
+      let sigma = Evd.emit_side_effects eff sigma in
+      (** Get rid of the fresh side-effects by internalizing them in the term
+          itself. Note that this is unsound, because the tactic may have solved
+          other goals that were already present during its invocation, so that
+          those goals rely on effects that are not present anymore. Hopefully,
+          this hack will work in most cases. *)
+      let ans = Term_typing.handle_side_effects env ans neff in
+      ans, sigma
+    else
+      failwith "not a tactic"
+  in
+  Hook.set Pretyping.genarg_interp_hook eval
+
+let _ = Hook.set Auto.extern_interp
   (fun l ->
-    Flags.with_option strict_check
-    (intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
-let _ = Auto.set_extern_subst_tactic subst_tactic
+    let lfun = Id.Map.map (fun c -> Value.of_constr c) l in
+    let ist = { (default_ist ()) with lfun; } in
+    interp_tactic ist)
+
+(** Used in tactic extension **)
+
+let dummy_id = Id.of_string "_"
+
+let lift_constr_tac_to_ml_tac vars tac =
+  let tac _ ist = Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let map = function
+    | None -> None
+    | Some id ->
+      let c = Id.Map.find id ist.lfun in
+      try Some (coerce_to_closed_constr env c)
+      with CannotCoerceTo ty ->
+        error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty
+    in
+    let args = List.map_filter map vars in
+    tac args ist
+  end in
+  tac
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 5df6a6cd..7605c915 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -1,46 +1,49 @@
 (************************************************************************)
 (*  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 Names
-open Proof_type
-open Tacmach
 open Tactic_debug
 open Term
 open Tacexpr
 open Genarg
-open Topconstr
-open Mod_subst
 open Redexpr
+open Misctypes
+
+module Value :
+sig
+  type t = tlevel generic_argument
+  val of_constr : constr -> t
+  val to_constr : t -> constr option
+  val of_int : int -> t
+  val to_int : t -> int option
+  val to_list : t -> t list option
+  val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t
+end
 
 (** Values for interpretation *)
-type value =
-  | VRTactic of (goal list sigma)
-  | VFun of ltac_trace * (identifier*value) list *
-      identifier option list * glob_tactic_expr
-  | VVoid
-  | VInteger of int
-  | VIntroPattern of intro_pattern_expr
-  | VConstr of Pattern.constr_under_binders
-  | VConstr_context of constr
-  | VList of value list
-  | VRec of (identifier*value) list ref * glob_tactic_expr
+type value = Value.t
+
+module TacStore : Store.S with
+  type t = Geninterp.TacStore.t
+  and type 'a field = 'a Geninterp.TacStore.field
 
 (** Signature for interpretation: val\_interp and interpretation functions *)
-and interp_sign =
-  { lfun : (identifier * value) list;
-    avoid_ids : identifier list;
-    debug : debug_info;
-    trace : ltac_trace }
+type interp_sign = Geninterp.interp_sign = {
+  lfun : value Id.Map.t;
+  extra : TacStore.t }
+
+val f_avoid_ids : Id.t list TacStore.field
+val f_debug : debug_info TacStore.field
 
 val extract_ltac_constr_values : interp_sign -> Environ.env ->
-  Pretyping.ltac_var_map
+  Pattern.constr_under_binders Id.Map.t
+(** Given an interpretation signature, extract all values which are coercible to
+    a [constr]. *)
 
 (** To embed several objects in Coqast.t *)
 val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t
@@ -56,118 +59,67 @@ val set_debug : debug_info -> unit
 (** Gives the state of debug *)
 val get_debug : unit -> debug_info
 
-(** Adds a definition for tactics in the table *)
-val add_tacdef :
-  Vernacexpr.locality_flag -> bool ->
-  (Libnames.reference * bool * raw_tactic_expr) list -> unit
-val add_primitive_tactic : string -> glob_tactic_expr -> unit
-
-(** Tactic extensions *)
-val add_tactic :
-  string -> (typed_generic_argument list -> tactic) -> unit
-val overwriting_add_tactic :
-  string -> (typed_generic_argument list -> tactic) -> unit
-val lookup_tactic :
-  string -> (typed_generic_argument list) -> tactic
-
 (** Adds an interpretation function for extra generic arguments *)
-type glob_sign = {
-  ltacvars : identifier list * identifier list;
-  ltacrecvars : (identifier * Nametab.ltac_constant) list;
-  gsigma : Evd.evar_map;
-  genv : Environ.env }
-
-val fully_empty_glob_sign : glob_sign
-
-val add_interp_genarg :
-  string ->
-    (glob_sign -> raw_generic_argument -> glob_generic_argument) *
-    (interp_sign -> goal sigma -> glob_generic_argument ->
-      Evd.evar_map * typed_generic_argument) *
-    (substitution -> glob_generic_argument -> glob_generic_argument)
-    -> unit
-
-val interp_genarg :
-  interp_sign -> goal sigma -> glob_generic_argument -> Evd.evar_map * typed_generic_argument
-
-val intern_genarg :
-  glob_sign -> raw_generic_argument -> glob_generic_argument
 
-val intern_pure_tactic :
-  glob_sign -> raw_tactic_expr -> glob_tactic_expr
-
-val intern_constr :
-  glob_sign -> constr_expr -> glob_constr_and_expr
-
-val intern_constr_with_bindings :
-  glob_sign -> constr_expr * constr_expr Glob_term.bindings ->
-  glob_constr_and_expr * glob_constr_and_expr Glob_term.bindings
-
-val intern_hyp :
-  glob_sign -> identifier Util.located -> identifier Util.located
-
-val subst_genarg :
-  substitution -> glob_generic_argument -> glob_generic_argument
-
-val subst_glob_constr_and_expr :
-  substitution -> glob_constr_and_expr -> glob_constr_and_expr
-
-val subst_glob_with_bindings :
-  substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
+(* spiwack: the [Term.constr] argument is the conclusion of the goal,
+   for "casted open constr" *)
+val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal ->
+  glob_generic_argument -> Evd.evar_map * typed_generic_argument
 
 (** Interprets any expression *)
-val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> Evd.evar_map * value
+val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic
 
 (** Interprets an expression that evaluates to a constr *)
-val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
-  Evd.evar_map * constr
+val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
 
 (** Interprets redexp arguments *)
-val dump_glob_red_expr : raw_red_expr -> unit
 val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr
 
 (** Interprets tactic expressions *)
-val interp_tac_gen : (identifier * value) list -> identifier list ->
-                 debug_info -> raw_tactic_expr -> tactic
 
-val interp_hyp :  interp_sign -> goal sigma -> identifier located -> identifier
+val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map ->
+  Id.t Loc.located -> Id.t
 
-val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr Glob_term.bindings -> Evd.evar_map * constr Glob_term.bindings
+val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+ glob_constr_and_expr bindings -> Evd.evar_map * constr bindings
 
-(* first arguments mean wTC (with type classes resolution) *)
-val interp_open_constr_with_bindings : bool -> interp_sign -> Environ.env -> Evd.evar_map -> 
-  glob_constr_and_expr Glob_term.with_bindings -> Evd.evar_map * constr Glob_term.with_bindings
+val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map ->
+  glob_constr_and_expr with_bindings -> Evd.evar_map * constr with_bindings
 
 (** Initial call for interpretation *)
-val glob_tactic : raw_tactic_expr -> glob_tactic_expr
 
-val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+val eval_tactic : glob_tactic_expr -> unit Proofview.tactic
 
-val eval_tactic : glob_tactic_expr -> tactic
+val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic
+(** Same as [eval_tactic], but with the provided [interp_sign]. *)
 
-val interp : raw_tactic_expr -> tactic
+(** Globalization + interpretation *)
 
-val eval_ltac_constr : goal sigma -> raw_tactic_expr -> Evd.evar_map * constr
+val interp_tac_gen : value Id.Map.t -> Id.t list ->
+                 debug_info -> raw_tactic_expr -> unit Proofview.tactic
 
-val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+val interp : raw_tactic_expr -> unit Proofview.tactic
 
 (** Hides interpretation for pretty-print *)
 
-val hide_interp : raw_tactic_expr -> tactic option -> tactic
+val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic
 
-(** Declare the xml printer *)
-val declare_xml_printer :
-  (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit
+(** Internals that can be useful for syntax extensions. *)
 
-(** printing *)
-val print_ltac : Libnames.qualid -> std_ppcmds
+val interp_ltac_var : (value -> 'a) -> interp_sign ->
+  (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a
 
-(** Internals that can be useful for syntax extensions. *)
+val interp_int : interp_sign -> Id.t Loc.located -> int
 
-exception CannotCoerceTo of string
+val interp_int_or_var : interp_sign -> int or_var -> int
 
-val interp_ltac_var : (value -> 'a) -> interp_sign -> Environ.env option -> identifier located -> 'a
+val error_ltac_variable : Loc.t -> Id.t ->
+  (Environ.env * Evd.evar_map) option -> value -> string -> 'a
 
-val interp_int : interp_sign -> identifier located -> int
+(** Transforms a constr-expecting tactic into a tactic finding its arguments in
+    the Ltac environment according to the given names. *)
+val lift_constr_tac_to_ml_tac : Id.t option list ->
+  (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic
 
-val error_ltac_variable : loc -> identifier -> Environ.env option -> value -> string -> 'a
+val default_ist : unit -> Geninterp.interp_sign
+(** Empty ist with debug set on the current value. *)
diff --git a/tactics/tacsubst.ml b/tactics/tacsubst.ml
new file mode 100644
index 00000000..59cd065d
--- /dev/null
+++ b/tactics/tacsubst.ml
@@ -0,0 +1,360 @@
+(************************************************************************)
+(*  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 Util
+open Tacexpr
+open Mod_subst
+open Genarg
+open Constrarg
+open Misctypes
+open Globnames
+open Term
+open Genredexpr
+open Patternops
+open Pretyping
+
+(** Substitution of tactics at module closing time *)
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+let subst_quantified_hypothesis _ x = x
+
+let subst_declared_or_quantified_hypothesis _ x = x
+
+let subst_glob_constr_and_expr subst (c,e) =
+  assert (Option.is_empty e); (* e<>None only for toplevel tactics *)
+  (Detyping.subst_glob_constr subst c,None)
+
+let subst_glob_constr = subst_glob_constr_and_expr (* shortening *)
+
+let subst_binding subst (loc,b,c) =
+  (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c)
+
+let subst_bindings subst = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
+
+let subst_glob_with_bindings subst (c,bl) =
+  (subst_glob_constr subst c, subst_bindings subst bl)
+
+let subst_glob_with_bindings_arg subst (clear,c) =
+  (clear,subst_glob_with_bindings subst c)
+
+let rec subst_intro_pattern subst = function
+  | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p)
+  | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x
+
+and subst_intro_pattern_action subst = function
+  | IntroApplyOn (t,pat) ->
+      IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat)
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (List.map (List.map (subst_intro_pattern subst)) l)
+  | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
+  | IntroWildcard | IntroRewrite _ as x -> x
+
+let subst_induction_arg subst = function
+  | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c)
+  | clear,ElimOnAnonHyp n as x -> x
+  | clear,ElimOnIdent id as x -> x
+
+let subst_and_short_name f (c,n) =
+(*  assert (n=None); *)(* since tacdef are strictly globalized *)
+  (f c,None)
+
+let subst_or_var f =  function
+  | ArgVar _ as x -> x
+  | ArgArg x -> ArgArg (f x)
+
+let dloc = Loc.ghost
+
+let subst_located f (_loc,id) = (dloc,f id)
+
+let subst_reference subst =
+  subst_or_var (subst_located (subst_kn subst))
+
+(*CSC: subst_global_reference is used "only" for RefArgType, that propagates
+  to the syntactic non-terminals "global", used in commands such as
+  Print. It is also used for non-evaluable references. *)
+open Pp
+open Printer
+
+let subst_global_reference subst =
+ let subst_global ref =
+  let ref',t' = subst_global subst ref in
+   if not (eq_constr (Universes.constr_of_global ref') t') then
+    msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++
+          str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
+          pr_global ref') ;
+   ref'
+ in
+  subst_or_var (subst_located subst_global)
+
+let subst_evaluable subst =
+  let subst_eval_ref = subst_evaluable_reference subst in
+    subst_or_var (subst_and_short_name subst_eval_ref)
+
+let subst_unfold subst (l,e) =
+  (l,subst_evaluable subst e)
+
+let subst_flag subst red =
+  { red with rConst = List.map (subst_evaluable subst) red.rConst }
+
+let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c)
+
+let subst_glob_constr_or_pattern subst (c,p) =
+  (subst_glob_constr subst c,subst_pattern subst p)
+
+let subst_pattern_with_occurrences subst (l,p) =
+  (l,subst_glob_constr_or_pattern subst p)
+
+let subst_redexp subst =
+  Miscops.map_red_expr_gen
+    (subst_glob_constr subst)
+    (subst_evaluable subst)
+    (subst_glob_constr_or_pattern subst)
+
+let subst_raw_may_eval subst = function
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c)
+
+let subst_match_pattern subst = function
+  | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc))
+  | Term pc -> Term (subst_glob_constr_or_pattern subst pc)
+
+let rec subst_match_goal_hyps subst = function
+  | Hyp (locs,mp) :: tl ->
+      Hyp (locs,subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | Def (locs,mv,mp) :: tl ->
+      Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp)
+      :: subst_match_goal_hyps subst tl
+  | [] -> []
+
+let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
+  (* Basic tactics *)
+  | TacIntroPattern l -> TacIntroPattern (List.map (subst_intro_pattern subst) l)
+  | TacIntroMove _ as x -> x
+  | TacExact c -> TacExact (subst_glob_constr subst c)
+  | TacApply (a,ev,cb,cl) ->
+      TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl)
+  | TacElim (ev,cb,cbo) ->
+      TacElim (ev,subst_glob_with_bindings_arg subst cb,
+               Option.map (subst_glob_with_bindings subst) cbo)
+  | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb)
+  | TacFix (idopt,n) as x -> x
+  | TacMutualFix (id,n,l) ->
+      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
+  | TacCofix idopt as x -> x
+  | TacMutualCofix (id,l) ->
+      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
+  | TacAssert (b,otac,na,c) ->
+      TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c)
+  | TacGeneralize cl ->
+      TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c)
+  | TacLetTac (id,c,clp,b,eqpat) ->
+    TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
+
+  (* Automation tactics *)
+  | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
+  | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
+
+  (* Derived basic tactics *)
+  | TacInductionDestruct (isrec,ev,(l,el)) ->
+      let l' = List.map (fun (c,ids,cls) ->
+        subst_induction_arg subst c, ids, cls) l in
+      let el' = Option.map (subst_glob_with_bindings subst) el in
+      TacInductionDestruct (isrec,ev,(l',el'))
+  | TacDoubleInduction (h1,h2) as x -> x
+
+  (* Context management *)
+  | TacClear _ as x -> x
+  | TacClearBody l as x -> x
+  | TacMove (id1,id2) as x -> x
+  | TacRename l as x -> x
+
+  (* Constructors *)
+  | TacSplit (ev,bll) -> TacSplit (ev,List.map (subst_bindings subst) bll)
+
+  (* Conversion *)
+  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
+  | TacChange (op,c,cl) ->
+      TacChange (Option.map (subst_glob_constr_or_pattern subst) op,
+        subst_glob_constr subst c, cl)
+
+  (* Equivalence relations *)
+  | TacSymmetry _ as x -> x
+
+  (* Equality and inversion *)
+  | TacRewrite (ev,l,cl,by) ->
+      TacRewrite (ev,
+		  List.map (fun (b,m,c) ->
+			      b,m,subst_glob_with_bindings_arg subst c) l,
+		 cl,Option.map (subst_tactic subst) by)
+  | TacInversion (DepInversion (k,c,l),hyp) ->
+     TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp)
+  | TacInversion (NonDepInversion _,_) as x -> x
+  | TacInversion (InversionUsing (c,cl),hyp) ->
+      TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp)
+
+and subst_tactic subst (t:glob_tactic_expr) = match t with
+  | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t)
+  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
+  | TacLetIn (r,l,u) ->
+      let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in
+      TacLetIn (r,l,subst_tactic subst u)
+  | TacMatchGoal (lz,lr,lmr) ->
+      TacMatchGoal(lz,lr, subst_match_rule subst lmr)
+  | TacMatch (lz,c,lmr) ->
+      TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr)
+  | TacId _ | TacFail _ as x -> x
+  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
+  | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr)
+  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
+  | TacThen (t1,t2) ->
+      TacThen (subst_tactic subst t1, subst_tactic subst t2)
+  | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl)
+  | TacExtendTac (tf,t,tl) ->
+      TacExtendTac (Array.map (subst_tactic subst) tf,
+	            subst_tactic subst t,
+                    Array.map (subst_tactic subst) tl)
+  | TacThens (t,tl) ->
+      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
+  | TacThens3parts (t1,tf,t2,tl) ->
+      TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf,
+	       subst_tactic subst t2,Array.map (subst_tactic subst) tl)
+  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac)
+  | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac)
+  | TacTry tac -> TacTry (subst_tactic subst tac)
+  | TacInfo tac -> TacInfo (subst_tactic subst tac)
+  | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
+  | TacOr (tac1,tac2) ->
+      TacOr (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacOnce tac ->
+      TacOnce (subst_tactic subst tac)
+  | TacExactlyOnce tac ->
+      TacExactlyOnce (subst_tactic subst tac)
+  | TacIfThenCatch (tac,tact,tace) ->
+      TacIfThenCatch (
+        subst_tactic subst tac,
+        subst_tactic subst tact,
+        subst_tactic subst tace)
+  | TacOrelse (tac1,tac2) ->
+      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
+  | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
+  | TacComplete tac -> TacComplete (subst_tactic subst tac)
+  | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a)
+
+  (* For extensions *)
+  | TacAlias (_,s,l) ->
+      let s = subst_kn subst s in
+      TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l)
+  | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_genarg subst) l)
+
+and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
+
+and subst_tacarg subst = function
+  | Reference r -> Reference (subst_reference subst r)
+  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
+  | UConstr c -> UConstr (subst_glob_constr subst c)
+  | MetaIdArg (_loc,_,_) -> assert false
+  | TacCall (_loc,f,l) ->
+      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | TacFreshId _ as x -> x
+  | TacPretype c -> TacPretype (subst_glob_constr subst c)
+  | TacNumgoals -> TacNumgoals
+  | Tacexp t -> Tacexp (subst_tactic subst t)
+  | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg)
+  | TacDynamic(the_loc,t) as x ->
+      (match Dyn.tag t with
+	| "tactic" | "value" -> x
+        | "constr" ->
+          TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t)))
+	| s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp"
+                 (str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and subst_match_rule subst = function
+  | (All tc)::tl ->
+      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let hyps = subst_match_goal_hyps subst rl in
+      let pat = subst_match_pattern subst mp in
+      Pat (hyps,pat,subst_tactic subst tc)
+      ::(subst_match_rule subst tl)
+  | [] -> []
+
+and subst_genarg subst (x:glob_generic_argument) =
+  match genarg_tag x with
+  | IntOrVarArgType -> in_gen (glbwit wit_int_or_var) (out_gen (glbwit wit_int_or_var) x)
+  | IdentArgType ->
+      in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x)
+  | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x)
+  | GenArgType -> in_gen (glbwit wit_genarg) (subst_genarg subst (out_gen (glbwit wit_genarg) x))
+  | ConstrArgType ->
+      in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x))
+  | ConstrMayEvalArgType ->
+      in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x))
+  | QuantHypArgType ->
+      in_gen (glbwit wit_quant_hyp)
+        (subst_declared_or_quantified_hypothesis subst
+          (out_gen (glbwit wit_quant_hyp) x))
+  | RedExprArgType ->
+      in_gen (glbwit wit_red_expr) (subst_redexp subst (out_gen (glbwit wit_red_expr) x))
+  | OpenConstrArgType ->
+      in_gen (glbwit wit_open_constr)
+        ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x)))
+  | ConstrWithBindingsArgType ->
+      in_gen (glbwit wit_constr_with_bindings)
+        (subst_glob_with_bindings subst (out_gen (glbwit wit_constr_with_bindings) x))
+  | BindingsArgType ->
+      in_gen (glbwit wit_bindings)
+        (subst_bindings subst (out_gen (glbwit wit_bindings) x))
+  | ListArgType _ ->
+    let list_unpacker wit l =
+      let map x =
+        let ans = subst_genarg subst (in_gen (glbwit wit) x) in
+        out_gen (glbwit wit) ans
+      in
+      in_gen (glbwit (wit_list wit)) (List.map map (glb l))
+    in
+    list_unpack { list_unpacker } x
+  | OptArgType _ ->
+    let opt_unpacker wit o = match glb o with
+    | None -> in_gen (glbwit (wit_opt wit)) None
+    | Some x ->
+      let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in
+      in_gen (glbwit (wit_opt wit)) (Some s)
+    in
+    opt_unpack { opt_unpacker } x
+  | PairArgType _ ->
+      let pair_unpacker wit1 wit2 o =
+        let p, q = glb o in
+        let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in
+        let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in
+        in_gen (glbwit (wit_pair wit1 wit2)) (p, q)
+      in
+      pair_unpack { pair_unpacker } x
+  | ExtraArgType s ->
+      Genintern.generic_substitute subst x
+
+(** Registering *)
+
+let () =
+  Genintern.register_subst0 wit_ref subst_global_reference;
+  Genintern.register_subst0 wit_intro_pattern (fun _ v -> v);
+  Genintern.register_subst0 wit_tactic subst_tactic;
+  Genintern.register_subst0 wit_sort (fun _ v -> v);
+  Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v);
+  Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c)
diff --git a/tactics/tacsubst.mli b/tactics/tacsubst.mli
new file mode 100644
index 00000000..52f21ed7
--- /dev/null
+++ b/tactics/tacsubst.mli
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*  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 Tacexpr
+open Mod_subst
+open Genarg
+open Misctypes
+
+(** Substitution of tactics at module closing time *)
+
+val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+
+(** For generic arguments, we declare and store substitutions
+    in a table *)
+
+val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument
+
+(** Misc *)
+
+val subst_glob_constr_and_expr :
+  substitution -> glob_constr_and_expr -> glob_constr_and_expr
+
+val subst_glob_with_bindings : substitution ->
+  glob_constr_and_expr with_bindings ->
+  glob_constr_and_expr with_bindings
diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml
new file mode 100644
index 00000000..4e3624fb
--- /dev/null
+++ b/tactics/tactic_matching.ml
@@ -0,0 +1,373 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+open Names
+open Tacexpr
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : Term.constr Id.Map.t;
+  terms : Term.constr Id.Map.t;
+  lhs : 'a;
+}
+
+
+
+(** {6 Utilities} *)
+
+
+(** Some of the functions of {!Matching} return the substitution with a
+    [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces
+    substitution of the former type to the latter. *)
+let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map ->
+             Constr_matching.bound_ident_map * Pattern.extended_patvar_map =
+  fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc)
+
+
+(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *)
+let id_map_try_add id x m =
+  match id with
+  | Some id -> Id.Map.add id x m
+  | None -> m
+
+(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *)
+let id_map_try_add_name id x m =
+  match id with
+  | Name id -> Id.Map.add id x m
+  | Anonymous -> m
+
+(** Takes the union of two {!Id.Map.t}. If there is conflict,
+    the binding of the right-hand argument shadows that of the left-hand
+    argument. *)
+let id_map_right_biased_union m1 m2 =
+  if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *)
+  else Id.Map.fold Id.Map.add m2 m1
+
+(** Tests whether the substitution [s] is empty. *)
+let is_empty_subst (ln,lm) =
+  Id.Map.(is_empty ln && is_empty lm)
+
+(** {6 Non-linear patterns} *)
+
+
+(** The patterns of Ltac are not necessarily linear. Non-linear
+    pattern are partially handled by the {!Matching} module, however
+    goal patterns are not primitive to {!Matching}, hence we must deal
+    with non-linearity between hypotheses and conclusion. Subterms are
+    considered equal up to the equality implemented in
+    [equal_instances]. *)
+(* spiwack: it doesn't seem to be quite the same rule for non-linear
+   term patterns and non-linearity between hypotheses and/or
+   conclusion. Indeed, in [Matching], matching is made modulo
+   syntactic equality, and here we merge modulo conversion. It may be
+   a good idea to have an entry point of [Matching] with a partial
+   substitution as argument instead of merging substitution here. That
+   would ensure consistency. *)
+let equal_instances env sigma (ctx',c') (ctx,c) =
+  (* How to compare instances? Do we want the terms to be convertible?
+     unifiable? Do we want the universe levels to be relevant? 
+     (historically, conv_x is used) *)
+  CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c
+
+
+(** Merges two substitutions. Raises [Not_coherent_metas] when
+    encountering two instances of the same metavariable which are not
+    equal according to {!equal_instances}. *)
+exception Not_coherent_metas
+let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) =
+  let merge id oc1 oc2 = match oc1, oc2 with
+    | None, None -> None
+    | None, Some c | Some c, None -> Some c
+    | Some c1, Some c2 ->
+        if equal_instances env sigma c1 c2 then Some c1
+        else raise Not_coherent_metas
+  in
+  let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in
+  (** ppedrot: Is that even correct? *)
+  let merged = ln +++ ln1 in
+  (merged, Id.Map.merge merge lcm lm)
+
+let matching_error =
+  Errors.UserError ("tactic matching" , Pp.str "No matching clauses for match.")
+
+let imatching_error = (matching_error, Exninfo.null)
+
+(** A functor is introduced to share the environment and the
+    evar_map. They do not change and it would be a pity to introduce
+    closures everywhere just for the occasional calls to
+    {!equal_instances}. *)
+module type StaticEnvironment = sig
+  val env : Environ.env
+  val sigma : Evd.evar_map
+end
+module PatternMatching (E:StaticEnvironment) = struct
+
+
+  (** {6 The pattern-matching monad } *)
+
+
+  (** To focus on the algorithmic portion of pattern-matching, the
+      bookkeeping is relegated to a monad: the composition of the
+      bactracking monad of {!IStream.t} with a "writer" effect. *)
+  (* spiwack: as we don't benefit from the various stream optimisations
+     of Haskell, it may be costly to give the monad in direct style such as
+     here. We may want to use some continuation passing style. *)
+  type 'a tac = 'a Proofview.tactic
+  type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac }
+
+  (** The empty substitution. *)
+  let empty_subst = Id.Map.empty , Id.Map.empty
+
+  (** Composes two substitutions using {!verify_metas_coherence}. It
+      must be a monoid with neutral element {!empty_subst}. Raises
+      [Not_coherent_metas] when composition cannot be achieved. *)
+  let subst_prod s1 s2 =
+    if is_empty_subst s1 then s2
+    else if is_empty_subst s2 then s1
+    else verify_metas_coherence E.env E.sigma s1 s2
+
+  (** The empty context substitution. *)
+  let empty_context_subst = Id.Map.empty
+
+  (** Compose two context substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let context_subst_prod = id_map_right_biased_union
+
+  (** The empty term substitution. *)
+  let empty_term_subst = Id.Map.empty
+
+  (** Compose two terms substitutions, in case of conflict the
+      right hand substitution shadows the left hand one. *)
+  let term_subst_prod = id_map_right_biased_union
+
+  (** Merge two writers (and ignore the first value component). *)
+  let merge m1 m2 =
+    try Some {
+      subst = subst_prod m1.subst m2.subst;
+      context = context_subst_prod m1.context m2.context;
+      terms = term_subst_prod m1.terms m2.terms;
+      lhs = m2.lhs;
+    }
+    with Not_coherent_metas -> None
+
+  (** Monadic [return]: returns a single success with empty substitutions. *)
+  let return (type a) (lhs:a) : a m =
+    { stream = fun k ctx -> k lhs ctx }
+
+  (** Monadic bind: each success of [x] is replaced by the successes
+      of [f x]. The substitutions of [x] and [f x] are composed,
+      dropping the apparent successes when the substitutions are not
+      coherent. *)
+  let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m =
+    { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx }
+
+  (** A variant of [(>>=)] when the first argument returns [unit]. *)
+  let (<*>) (type a) (m:unit m) (y:a m) : a m =
+    { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx }
+
+  (** Failure of the pattern-matching monad: no success. *)
+  let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error }
+
+  let run (m : 'a m) =
+    let ctx = {
+      subst = empty_subst ;
+      context = empty_context_subst ;
+      terms = empty_term_subst ;
+      lhs = ();
+    } in
+    let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in
+    m.stream eval ctx
+
+  (** Chooses in a list, in the same order as the list *)
+  let rec pick (l:'a list) (e, info) : 'a m = match l with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | x :: l ->
+    { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) }
+
+  let pick l = pick l imatching_error
+
+  (** Declares a subsitution, a context substitution and a term substitution. *)
+  let put subst context terms : unit m =
+    let s = { subst ; context ; terms ; lhs = () } in
+    { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s }
+
+  (** Declares a substitution. *)
+  let put_subst subst : unit m = put subst empty_context_subst empty_term_subst
+
+  (** Declares a term substitution. *)
+  let put_terms terms : unit m = put empty_subst empty_context_subst terms
+
+
+
+  (** {6 Pattern-matching} *)
+
+
+  (** [wildcard_match_term lhs] matches a term against a wildcard
+      pattern ([_ => lhs]). It has a single success with an empty
+      substitution. *)
+  let wildcard_match_term = return
+
+  (** [pattern_match_term refresh pat term lhs] returns the possible
+      matchings of [term] with the pattern [pat => lhs]. If refresh is
+      true, refreshes the universes of [term]. *)
+  let pattern_match_term refresh pat term lhs = 
+(*     let term = if refresh then Termops.refresh_universes_strict term else term in *)
+    match pat with
+    | Term p ->
+        begin 
+          try
+            put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*>
+            return lhs
+          with Constr_matching.PatternMatchingFailure -> fail
+        end
+    | Subterm (with_app_context,id_ctxt,p) ->
+
+      let rec map s (e, info) =
+        { stream = fun k ctx -> match IStream.peek s with
+          | IStream.Nil -> Proofview.tclZERO ~info e
+          | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) ->
+            let subst = adjust m_sub in
+            let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in
+            let terms = empty_term_subst in
+            let nctx = { subst ; context ; terms ; lhs = () } in
+            match merge ctx nctx with
+            | None -> (map s (e, info)).stream k ctx
+            | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx)
+        }
+      in
+      map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error
+
+
+  (** [rule_match_term term rule] matches the term [term] with the
+      matching rule [rule]. *)
+  let rule_match_term term = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs
+    | Pat _ ->
+        (** Rules with hypotheses, only work in match goal. *)
+        fail
+
+  (** [match_term term rules] matches the term [term] with the set of
+      matching rules [rules].*)
+  let rec match_term (e, info) term rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_term term r in
+      let tail e = match_term e term rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+
+  (** [hyp_match_type hypname pat hyps] matches a single
+      hypothesis pattern [hypname:pat] against the hypotheses in
+      [hyps]. Tries the hypotheses in order. For each success returns
+      the name of the matched hypothesis. *)
+  let hyp_match_type hypname pat hyps =
+    pick hyps >>= fun (id,b,hyp) ->
+    let refresh = not (Option.is_empty b) in
+    pattern_match_term refresh pat hyp () <*>
+    put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*>
+    return id
+
+  (** [hyp_match_type hypname bodypat typepat hyps] matches a single
+      hypothesis pattern [hypname := bodypat : typepat] against the
+      hypotheses in [hyps].Tries the hypotheses in order. For each
+      success returns the name of the matched hypothesis. *)
+  let hyp_match_body_and_type hypname bodypat typepat hyps =
+    pick hyps >>= function
+      | (id,Some body,hyp) ->
+          pattern_match_term false bodypat body () <*>
+          pattern_match_term true typepat hyp () <*>
+          put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*>
+          return id
+      | (id,None,hyp) -> fail
+
+  (** [hyp_match pat hyps] dispatches to
+      {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether
+      [pat] is [Hyp _] or [Def _]. *)
+  let hyp_match pat hyps =
+    match pat with
+    | Hyp ((_,hypname),typepat) ->
+        hyp_match_type hypname typepat hyps
+    | Def ((_,hypname),bodypat,typepat) ->
+        hyp_match_body_and_type hypname bodypat typepat hyps
+
+  (** [hyp_pattern_list_match pats hyps lhs], matches the list of
+      patterns [pats] against the hypotheses in [hyps], and eventually
+      returns [lhs]. *)
+  let rec hyp_pattern_list_match pats hyps lhs =
+    match pats with
+    | pat::pats ->
+        hyp_match pat hyps >>= fun matched_hyp ->
+        (* spiwack: alternatively it is possible to return the list
+           with the matched hypothesis removed directly in
+           [hyp_match]. *)
+        let select_matched_hyp (id,_,_) = Id.equal id matched_hyp in
+        let hyps = CList.remove_first select_matched_hyp hyps in
+        hyp_pattern_list_match pats hyps lhs
+    | [] -> return lhs
+
+  (** [rule_match_goal hyps concl rule] matches the rule [rule]
+      against the goal [hyps|-concl]. *)
+  let rule_match_goal hyps concl = function
+    | All lhs -> wildcard_match_term lhs
+    | Pat (hyppats,conclpat,lhs) ->
+        (* the rules are applied from the topmost one (in the concrete
+           syntax) to the bottommost. *)
+        let hyppats = List.rev hyppats in
+        pattern_match_term false conclpat concl () <*>
+        hyp_pattern_list_match hyppats hyps lhs
+
+  (** [match_goal hyps concl rules] matches the goal [hyps|-concl]
+      with the set of matching rules [rules]. *)
+  let rec match_goal (e, info) hyps concl rules = match rules with
+  | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e }
+  | r :: rules ->
+    { stream = fun k ctx ->
+      let head = rule_match_goal hyps concl r in
+      let tail e = match_goal e hyps concl rules in
+      Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx)
+    }
+
+end
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+let match_term env sigma term rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_term imatching_error term rules)
+
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+let match_goal env sigma hyps concl rules =
+  let module E = struct
+    let env = env
+    let sigma = sigma
+  end in
+  let module M = PatternMatching(E) in
+  M.run (M.match_goal imatching_error hyps concl rules)
diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli
new file mode 100644
index 00000000..abeb47c3
--- /dev/null
+++ b/tactics/tactic_matching.mli
@@ -0,0 +1,49 @@
+ (************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** This file extends Matching with the main logic for Ltac's
+    (lazy)match and (lazy)match goal. *)
+
+
+(** [t] is the type of matching successes. It ultimately contains a
+    {!Tacexpr.glob_tactic_expr} representing the left-hand side of the
+    corresponding matching rule, a matching substitution to be
+    applied, a context substitution mapping identifier to context like
+    those of {!Matching.matching_result}), and a {!Term.constr}
+    substitution mapping corresponding to matched hypotheses. *)
+type 'a t = {
+  subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ;
+  context : Term.constr Names.Id.Map.t;
+  terms : Term.constr Names.Id.Map.t;
+  lhs : 'a;
+}
+
+
+(** [match_term env sigma term rules] matches the term [term] with the
+    set of matching rules [rules]. The environment [env] and the
+    evar_map [sigma] are not currently used, but avoid code
+    duplication. *)
+val match_term :
+  Environ.env ->
+  Evd.evar_map ->
+  Term.constr ->
+  (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
+
+(** [match_goal env sigma hyps concl rules] matches the goal
+    [hyps|-concl] with the set of matching rules [rules]. The
+    environment [env] and the evar_map [sigma] are used to check
+    convertibility for pattern variables shared between hypothesis
+    patterns or the conclusion pattern. *)
+val match_goal:
+  Environ.env ->
+  Evd.evar_map ->
+  Context.named_context ->
+  Term.constr ->
+  (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list ->
+  Tacexpr.glob_tactic_expr t Proofview.tactic
diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml
index 1ea8dbcb..34245c6a 100644
--- a/tactics/tactic_option.ml
+++ b/tactics/tactic_option.ml
@@ -1,29 +1,33 @@
 (************************************************************************)
 (*  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 Libobject
-open Proof_type
 open Pp
 
 let declare_tactic_option ?(default=Tacexpr.TacId []) name =
-  let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref default in
-  let default_tactic : Proof_type.tactic ref = ref (Tacinterp.eval_tactic !default_tactic_expr) in
-  let locality = ref false in
-  let set_default_tactic local t = 
+  let locality = Summary.ref false ~name:(name^"-locality") in
+  let default_tactic_expr : Tacexpr.glob_tactic_expr ref =
+    Summary.ref default ~name:(name^"-default-tacexpr")
+  in
+  let default_tactic : Tacexpr.glob_tactic_expr ref =
+    Summary.ref !default_tactic_expr ~name:(name^"-default-tactic")
+  in
+  let set_default_tactic local t =
     locality := local;
-    default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t 
+    default_tactic_expr := t;
+    default_tactic := t
   in
   let cache (_, (local, tac)) = set_default_tactic local tac in
   let load (_, (local, tac)) =
     if not local then set_default_tactic local tac
   in
   let subst (s, (local, tac)) =
-    (local, Tacinterp.subst_tactic s tac)
+    (local, Tacsubst.subst_tactic s tac)
   in
   let input : bool * Tacexpr.glob_tactic_expr -> obj =
     declare_object
@@ -39,17 +43,9 @@ let declare_tactic_option ?(default=Tacexpr.TacId []) name =
     set_default_tactic local tac;
     Lib.add_anonymous_leaf (input (local, tac))
   in
-  let get () = !locality, !default_tactic in
+  let get () = !locality, Tacinterp.eval_tactic !default_tactic in
   let print () = 
     Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++
       (if !locality then str" (locally defined)" else str" (globally defined)")
   in
-  let freeze () = !locality, !default_tactic_expr in
-  let unfreeze (local, t) = set_default_tactic local t in
-  let init () = () in
-    Summary.declare_summary name
-      { Summary.freeze_function = freeze;
-        Summary.unfreeze_function = unfreeze;
-        Summary.init_function = init };
-    put, get, print
-      
+  put, get, print
diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli
index 1e59b901..ffbd5116 100644
--- a/tactics/tactic_option.mli
+++ b/tactics/tactic_option.mli
@@ -1,16 +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 Proof_type
 open Tacexpr
 open Vernacexpr
 
 val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> 
   (* put *) (locality_flag -> glob_tactic_expr -> unit) *
-  (* get *) (unit -> locality_flag * tactic) *
+  (* get *) (unit -> locality_flag * unit Proofview.tactic) *
   (* print *) (unit -> Pp.std_ppcmds)
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index dcc70edb..cf2126f8 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -1,37 +1,27 @@
 (************************************************************************)
 (*  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
 open Term
 open Termops
-open Sign
+open Context
 open Declarations
-open Inductive
-open Reduction
-open Environ
-open Libnames
-open Refiner
 open Tacmach
 open Clenv
-open Clenvtac
-open Glob_term
-open Pattern
-open Matching
-open Genarg
-open Tacexpr
+open Misctypes
 
 (************************************************************************)
 (* Tacticals re-exported from the Refiner module                        *)
 (************************************************************************)
 
-let tclNORMEVAR      = Refiner.tclNORMEVAR
 let tclIDTAC         = Refiner.tclIDTAC
 let tclIDTAC_MESSAGE = Refiner.tclIDTAC_MESSAGE
 let tclORELSE0       = Refiner.tclORELSE0
@@ -58,9 +48,9 @@ let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
 let tclFAIL          = Refiner.tclFAIL
 let tclFAIL_lazy     = Refiner.tclFAIL_lazy
 let tclDO            = Refiner.tclDO
-let tclTIMEOUT       = Refiner.tclTIMEOUT
 let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
 let tclPROGRESS      = Refiner.tclPROGRESS
+let tclSHOWHYPS      = Refiner.tclSHOWHYPS
 let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
 let tclTHENTRY       = Refiner.tclTHENTRY
 let tclIFTHENELSE    = Refiner.tclIFTHENELSE
@@ -72,13 +62,6 @@ let tclIFTHENTRYELSEMUST = Refiner.tclIFTHENTRYELSEMUST
 
 let tclTHENSEQ       = tclTHENLIST
 
-(* Experimental *)
-
-let rec tclFIRST_PROGRESS_ON tac = function
-  | []    -> tclFAIL 0 (str "No applicable tactic")
-  | [a]   -> tac a (* so that returned failure is the one from last item *)
-  | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl)
-
 (************************************************************************)
 (* Tacticals applying on hypotheses                                     *)
 (************************************************************************)
@@ -95,7 +78,7 @@ let lastHypId gl  = nthHypId 1 gl
 let lastHyp gl    = nthHyp 1 gl
 
 let nLastDecls n gl =
-  try list_firstn n (pf_hyps gl)
+  try List.firstn n (pf_hyps gl)
   with Failure _ -> error "Not enough hypotheses in the goal."
 
 let nLastHypsId n gl = List.map pi1 (nLastDecls n gl)
@@ -116,7 +99,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac
 let onNLastHyps n tac   = onHyps (nLastHyps n) tac
 
 let afterHyp id gl =
-  fst (list_split_when (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
+  fst (List.split_when (fun (hyp,_,_) -> Id.equal hyp id) (pf_hyps gl))
 
 (***************************************)
 (*           Clause Tacticals          *)
@@ -130,53 +113,17 @@ let afterHyp id gl =
    --Eduardo (8/8/97)
 *)
 
-(* A [simple_clause] is a set of hypotheses, possibly extended with
-   the conclusion (conclusion is represented by None) *)
-
-type simple_clause = identifier option list
-
-(* An [clause] is the algebraic form of a
-   [concrete_clause]; it may refer to all hypotheses
-   independently of the effective contents of the current goal *)
-
-type clause = identifier gclause
-
-let allHypsAndConcl = { onhyps=None; concl_occs=all_occurrences_expr }
-let allHyps = { onhyps=None; concl_occs=no_occurrences_expr }
-let onConcl = { onhyps=Some[]; concl_occs=all_occurrences_expr }
-let onHyp id =
-  { onhyps=Some[((all_occurrences_expr,id),InHyp)];
-    concl_occs=no_occurrences_expr }
-
-let simple_clause_of cl gls =
-  let error_occurrences () =
-    error "This tactic does not support occurrences selection" in
-  let error_body_selection () =
-    error "This tactic does not support body selection" in
-  let hyps =
-    match cl.onhyps with
-    | None ->
-	List.map Option.make (pf_ids_of_hyps gls)
-    | Some l ->
-	List.map (fun ((occs,id),w) ->
-	  if occs <> all_occurrences_expr then error_occurrences ();
-	  if w = InHypValueOnly then error_body_selection ();
-	  Some id) l in
-  if cl.concl_occs = no_occurrences_expr then hyps
-  else
-    if cl.concl_occs <> all_occurrences_expr then error_occurrences ()
-    else None :: hyps
-
 let fullGoal gl = None :: List.map Option.make (pf_ids_of_hyps gl)
 
 let onAllHyps tac gl = tclMAP tac (pf_ids_of_hyps gl) gl
 let onAllHypsAndConcl tac gl = tclMAP tac (fullGoal gl) gl
 
-let tryAllHyps tac gl = tclFIRST_PROGRESS_ON tac (pf_ids_of_hyps gl) gl
-let tryAllHypsAndConcl tac gl = tclFIRST_PROGRESS_ON tac (fullGoal gl) gl
-
-let onClause tac cl gls = tclMAP tac (simple_clause_of cl gls) gls
-let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls
+let onClause tac cl gls =
+  let hyps () = pf_ids_of_hyps gls in
+  tclMAP tac (Locusops.simple_clause_of hyps cl) gls
+let onClauseLR tac cl gls =
+  let hyps () = pf_ids_of_hyps gls in
+  tclMAP tac (List.rev (Locusops.simple_clause_of hyps cl)) gls
 
 let ifOnHyp pred tac1 tac2 id gl =
   if pred (id,pf_get_hyp_typ gl id) then
@@ -184,52 +131,6 @@ let ifOnHyp pred tac1 tac2 id gl =
   else
     tac2 id gl
 
-
-(************************************************************************)
-(* An intermediate form of occurrence clause that select components     *)
-(* of a definition, hypotheses and possibly the goal                    *)
-(* (used for reduction tactics)                                         *)
-(************************************************************************)
-
-(* A [hyp_location] is an hypothesis together with a position, in
-   body if any, in type or in both *)
-
-type hyp_location = identifier * hyp_location_flag
-
-(* A [goal_location] is either an hypothesis (together with a position, in
-   body if any, in type or in both) or the goal *)
-
-type goal_location = hyp_location option
-
-(************************************************************************)
-(* An intermediate structure for dealing with occurrence clauses        *)
-(************************************************************************)
-
-(* [clause_atom] refers either to an hypothesis location (i.e. an
-   hypothesis with occurrences and a position, in body if any, in type
-   or in both) or to some occurrences of the conclusion *)
-
-type clause_atom =
-  | OnHyp of identifier * occurrences_expr * hyp_location_flag
-  | OnConcl of occurrences_expr
-
-(* A [concrete_clause] is an effective collection of
-  occurrences in the hypotheses and the conclusion *)
-
-type concrete_clause = clause_atom list
-
-let concrete_clause_of cl gls =
-  let hyps =
-    match cl.onhyps with
-    | None ->
-	let f id = OnHyp (id,all_occurrences_expr,InHyp) in
-	List.map f (pf_ids_of_hyps gls)
-    | Some l ->
-	List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in
-  if cl.concl_occs = no_occurrences_expr then hyps
-  else
-    OnConcl cl.concl_occs :: hyps
-
 (************************************************************************)
 (* Elimination Tacticals                                                *)
 (************************************************************************)
@@ -243,14 +144,14 @@ let concrete_clause_of cl gls =
   the elimination. *)
 
 type branch_args = {
-  ity        : inductive;   (* the type we were eliminating on *)
+  ity        : pinductive;   (* the type we were eliminating on *)
   largs      : constr list; (* its arguments *)
   branchnum  : int;         (* the branch number *)
   pred       : constr;      (* the predicate we used *)
   nassums    : int;         (* the number of assumptions to be introduced *)
   branchsign : bool list;   (* the signature of the branch.
                                true=recursive argument, false=constant *)
-  branchnames : intro_pattern_expr located list}
+  branchnames : Tacexpr.intro_patterns}
 
 type branch_assumptions = {
   ba        : branch_args;     (* the branch args *)
@@ -261,11 +162,13 @@ let fix_empty_or_and_pattern nv l =
      names and "[ ]" for no clause at all *)
   (* 2- More generally, we admit "[ ]" for any disjunctive pattern of
      arbitrary length *)
-  if l = [[]] then list_make nv [] else l
+  match l with
+  | [[]] -> List.make nv []
+  | _ -> l
 
 let check_or_and_pattern_size loc names n =
-  if List.length names <> n then
-    if n = 1 then
+  if not (Int.equal (List.length names) n) then
+    if Int.equal n 1 then
       user_err_loc (loc,"",str "Expects a conjunctive pattern.")
     else
       user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n
@@ -274,31 +177,29 @@ let check_or_and_pattern_size loc names n =
 let compute_induction_names n = function
   | None ->
       Array.make n []
-  | Some (loc,IntroOrAndPattern names) ->
+  | Some (loc,names) ->
       let names = fix_empty_or_and_pattern n names in
       check_or_and_pattern_size loc names n;
       Array.of_list names
-  | Some (loc,_) ->
-      user_err_loc (loc,"",str "Disjunctive/conjunctive introduction pattern expected.")
 
-let compute_construtor_signatures isrec (_,k as ity) =
+let compute_construtor_signatures isrec ((_,k as ity),u) =
   let rec analrec c recargs =
     match kind_of_term c, recargs with
     | Prod (_,_,c), recarg::rest ->
-	let b = match dest_recarg recarg with
+	let b = match Declareops.dest_recarg recarg with
 	  | Norec | Imbr _  -> false
-	  | Mrec (_,j)  -> isrec & j=k
+	  | Mrec (_,j)  -> isrec && Int.equal j k
 	in b :: (analrec c rest)
     | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
     | _, [] -> []
-    | _ -> anomaly "compute_construtor_signatures"
+    | _ -> anomaly (Pp.str "compute_construtor_signatures")
   in
   let (mib,mip) = Global.lookup_inductive ity in
   let n = mib.mind_nparams in
   let lc =
     Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in
-  let lrecargs = dest_subterms mip.mind_recargs in
-  array_map2 analrec lc lrecargs
+  let lrecargs = Declareops.dest_subterms mip.mind_recargs in
+  Array.map2 analrec lc lrecargs
 
 let elimination_sort_of_goal gl =
   pf_apply Retyping.get_sort_family_of gl (pf_concl gl)
@@ -310,67 +211,19 @@ let elimination_sort_of_clause = function
   | None -> elimination_sort_of_goal
   | Some id -> elimination_sort_of_hyp id
 
-(* Find the right elimination suffix corresponding to the sort of the goal *)
-(* c should be of type A1->.. An->B with B an inductive definition *)
-
-let general_elim_then_using mk_elim
-  isrec allnames tac predicate (indbindings,elimbindings)
-  ind indclause gl =
-  let elim = mk_elim ind gl in
-  (* applying elimination_scheme just a little modified *)
-  let indclause' = clenv_match_args indbindings indclause in
-  let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in
-  let indmv =
-    match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
-      | Meta mv -> mv
-      | _         -> anomaly "elimination"
-  in
-  let pmv =
-    let p, _ = decompose_app elimclause.templtyp.Evd.rebus in
-    match kind_of_term p with
-      | Meta p -> p
-      | _ ->
-	  let name_elim =
-	    match kind_of_term elim with
-	      | Const kn -> string_of_con kn
-	      | Var id -> string_of_id id
-	      | _ -> "\b"
-	  in
-	  error ("The elimination combinator " ^ name_elim ^ " is unknown.")
-  in
-  let elimclause' = clenv_fchain indmv elimclause indclause' in
-  let elimclause' = clenv_match_args elimbindings elimclause' in
-  let branchsigns = compute_construtor_signatures isrec ind in
-  let brnames = compute_induction_names (Array.length branchsigns) allnames in
-  let after_tac ce i gl =
-    let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in
-    let ba = { branchsign = branchsigns.(i);
-               branchnames = brnames.(i);
-               nassums =
-		 List.fold_left
-                   (fun acc b -> if b then acc+2 else acc+1)
-                   0 branchsigns.(i);
-               branchnum = i+1;
-               ity = ind;
-               largs = List.map (clenv_nf_meta ce) largs;
-               pred = clenv_nf_meta ce hd }
-    in
-    tac ba gl
-  in
-  let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in
-  let elimclause' =
-    match predicate with
-       | None   -> elimclause'
-       | Some p ->
-           clenv_unify ~flags:Unification.elim_flags
-             Reduction.CONV (mkMeta pmv) p elimclause'
-  in
-  elim_res_pf_THEN_i elimclause' branchtacs gl
+
+let pf_with_evars glsev k gls = 
+  let evd, a = glsev gls in
+    tclTHEN (Refiner.tclEVARS evd) (k a) gls
+
+let pf_constr_of_global gr k =
+  pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k
 
 (* computing the case/elim combinators *)
 
 let gl_make_elim ind gl =
-  Indrec.lookup_eliminator ind (elimination_sort_of_goal gl)
+  let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in
+    pf_apply Evd.fresh_global gl gr
 
 let gl_make_case_dep ind gl =
   pf_apply Indrec.build_case_analysis_scheme gl ind true
@@ -380,22 +233,6 @@ let gl_make_case_nodep ind gl =
   pf_apply Indrec.build_case_analysis_scheme gl ind false
     (elimination_sort_of_goal gl)
 
-let elimination_then_using tac predicate bindings c gl =
-  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let indclause  = mk_clenv_from gl (c,t) in
-  general_elim_then_using gl_make_elim
-    true None tac predicate bindings ind indclause gl
-
-let case_then_using =
-  general_elim_then_using gl_make_case_dep false
-
-let case_nodep_then_using =
-  general_elim_then_using gl_make_case_nodep false
-
-let elimination_then tac        = elimination_then_using tac None
-let simple_elimination_then tac = elimination_then tac ([],[])
-
-
 let make_elim_branch_assumptions ba gl =
   let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
     match lb,lc with
@@ -414,11 +251,11 @@ let make_elim_branch_assumptions ba gl =
 		   id::constargs,
 		   recargs,
 		   indargs) tl idtl
-      | (_, _) -> anomaly "make_elim_branch_assumptions"
+      | (_, _) -> anomaly (Pp.str "make_elim_branch_assumptions")
   in
   makerec ([],[],[],[],[]) ba.branchsign
-    (try list_firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly "make_elim_branch_assumptions")
+    (try List.firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions"))
 
 let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl
 
@@ -438,11 +275,435 @@ let make_case_branch_assumptions ba gl =
 		   id::cargs,
 		   recargs,
 		   id::constargs) tl idtl
-      | (_, _) -> anomaly "make_case_branch_assumptions"
+      | (_, _) -> anomaly (Pp.str "make_case_branch_assumptions")
   in
   makerec ([],[],[],[]) ba.branchsign
-    (try list_firstn ba.nassums (pf_hyps gl)
-     with Failure _ -> anomaly "make_case_branch_assumptions")
+    (try List.firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly (Pp.str "make_case_branch_assumptions"))
 
 let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl
 
+
+(** Tacticals of Ltac defined directly in term of Proofview *)
+module New = struct
+  open Proofview
+  open Proofview.Notations
+  open Tacmach.New
+
+  let tclIDTAC = tclUNIT ()
+
+  let tclTHEN t1 t2 =
+    t1 <*> t2
+
+  let tclFAIL lvl msg =
+    tclZERO (Refiner.FailError (lvl,lazy msg))
+
+  let tclZEROMSG ?loc msg =
+    let err = UserError ("", msg) in
+    let info = match loc with
+    | None -> Exninfo.null
+    | Some loc -> Loc.add_loc Exninfo.null loc
+    in
+    tclZERO ~info err
+
+  let catch_failerror e =
+    try
+      Refiner.catch_failerror e;
+      tclUNIT ()
+    with e -> tclZERO e
+
+  (* spiwack: I chose to give the Ltac + the same semantics as
+     [Proofview.tclOR], however, for consistency with the or-else
+     tactical, we may consider wrapping the first argument with
+     [tclPROGRESS]. It strikes me as a bad idea, but consistency can be
+     considered valuable. *)
+  let tclOR t1 t2 =
+    tclINDEPENDENT begin
+      Proofview.tclOR
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2
+        end
+    end
+
+  let tclORD t1 t2 =
+    tclINDEPENDENT begin
+      Proofview.tclOR
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2 ()
+        end
+    end
+
+  let tclONCE = Proofview.tclONCE
+
+  let tclEXACTLY_ONCE t = Proofview.tclEXACTLY_ONCE (Refiner.FailError(0,lazy (assert false))) t
+
+  let tclIFCATCH t tt te =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t
+        tt
+        (fun e -> catch_failerror e <*> te ())
+    end
+
+  let tclORELSE0 t1 t2 =
+    tclINDEPENDENT begin
+      tclORELSE
+        t1
+        begin fun e ->
+          catch_failerror e <*> t2
+        end
+    end
+  let tclORELSE t1 t2 =
+    tclORELSE0 (tclPROGRESS t1) t2
+
+  let tclTHENS3PARTS t1 l1 repeat l2 =
+    tclINDEPENDENT begin
+      t1 <*>
+        Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *)
+          begin tclEXTEND (Array.to_list l1) repeat (Array.to_list l2) end
+          begin function (e, info) -> match e with
+            | SizeMismatch (i,_)->
+                let errmsg =
+                  str"Incorrect number of goals" ++ spc() ++
+                  str"(expected "++int i++str(String.plural i " tactic") ++ str")"
+                in
+                tclFAIL 0 errmsg
+            | reraise -> tclZERO ~info reraise
+          end
+    end
+  let tclTHENSFIRSTn t1 l repeat =
+    tclTHENS3PARTS t1 l repeat [||]
+  let tclTHENFIRSTn t1 l =
+    tclTHENSFIRSTn t1 l (tclUNIT())
+  let tclTHENFIRST t1 t2 =
+    tclTHENFIRSTn t1 [|t2|]
+  let tclTHENLASTn t1 l =
+    tclTHENS3PARTS t1 [||] (tclUNIT()) l
+  let tclTHENLAST t1 t2 = tclTHENLASTn t1 [|t2|]
+  let tclTHENS t l =
+    tclINDEPENDENT begin
+      t <*>Proofview.tclORELSE (* converts the [SizeMismatch] error into an ltac error *)
+          begin tclDISPATCH l end
+          begin function (e, info) -> match e with
+            | SizeMismatch (i,_)->
+                let errmsg =
+                  str"Incorrect number of goals" ++ spc() ++
+                  str"(expected "++int i++str(String.plural i " tactic") ++ str")"
+                in
+                tclFAIL 0 errmsg
+            | reraise -> tclZERO ~info reraise
+          end
+    end
+  let tclTHENLIST l =
+    List.fold_left tclTHEN (tclUNIT()) l
+
+
+  (* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+  let tclMAP tacfun l =
+    List.fold_right (fun x -> (tclTHEN (tacfun x))) l (tclUNIT())
+
+  let tclTRY t =
+    tclORELSE0 t (tclUNIT ())
+
+  let tclIFTHENELSE t1 t2 t3 =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t1
+        (fun () -> t2)
+        (fun (e, info) -> Proofview.tclORELSE t3 (fun e' -> tclZERO ~info e))
+    end
+  let tclIFTHENSVELSE t1 a t3 =
+    Proofview.tclIFCATCH t1
+      (fun () -> tclDISPATCH (Array.to_list a))
+      (fun _ -> t3)
+  let tclIFTHENTRYELSEMUST t1 t2 =
+    tclIFTHENELSE t1 (tclTRY t2) t2
+
+  (* Try the first tactic that does not fail in a list of tactics *)
+  let rec tclFIRST = function
+    | [] -> tclZERO (Errors.UserError ("Tacticals.New.tclFIRST",str"No applicable tactic."))
+    |  t::rest -> tclORELSE0 t (tclFIRST rest)
+
+  let rec tclFIRST_PROGRESS_ON tac = function
+    | []    -> tclFAIL 0 (str "No applicable tactic")
+    | [a]   -> tac a (* so that returned failure is the one from last item *)
+    | a::tl -> tclORELSE (tac a) (tclFIRST_PROGRESS_ON tac tl)
+
+  let rec tclDO n t =
+    if n < 0 then
+      tclZERO (Errors.UserError (
+        "Refiner.tclDO",
+        str"Wrong argument : Do needs a positive integer.")
+      )
+    else if n = 0 then tclUNIT ()
+    else if n = 1 then t
+    else tclTHEN t (tclDO (n-1) t)
+
+  let rec tclREPEAT0 t =
+    tclINDEPENDENT begin
+      Proofview.tclIFCATCH t
+        (fun () -> tclCHECKINTERRUPT <*> tclREPEAT0 t)
+        (fun e -> catch_failerror e <*> tclUNIT ())
+    end
+  let tclREPEAT t =
+    tclREPEAT0 (tclPROGRESS t)
+  let rec tclREPEAT_MAIN0 t =
+    Proofview.tclIFCATCH t
+      (fun () -> tclTRYFOCUS 1 1 (tclREPEAT_MAIN0 t))
+      (fun e -> catch_failerror e <*> tclUNIT ())
+  let tclREPEAT_MAIN t =
+    tclREPEAT_MAIN0 (tclPROGRESS t)
+
+  let tclCOMPLETE t =
+    t >>= fun res ->
+      (tclINDEPENDENT
+         (tclZERO (Errors.UserError ("",str"Proof is not complete.")))
+      ) <*>
+        tclUNIT res
+
+  (* Try the first thats solves the current goal *)
+  let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl)
+
+  let tclPROGRESS t =
+    Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t)
+
+  (* Check that holes in arguments have been resolved *)
+
+  let check_evars env sigma extsigma origsigma =
+    let rec is_undefined_up_to_restriction sigma evk =
+      let evi = Evd.find sigma evk in
+      match Evd.evar_body evi with
+      | Evd.Evar_empty -> Some (evk,evi)
+      | Evd.Evar_defined c -> match Term.kind_of_term c with
+        | Term.Evar (evk,l) -> is_undefined_up_to_restriction sigma evk
+        | _ -> 
+          (* We make the assumption that there is no way to refine an
+            evar remaining after typing from the initial term given to
+            apply/elim and co tactics, is it correct? *)
+          None in
+    let rest =
+      Evd.fold_undefined (fun evk evi acc ->
+        match is_undefined_up_to_restriction sigma evk with
+        | Some (evk',evi) when not (Evd.mem origsigma evk) -> (evk',evi)::acc
+        | _ -> acc)
+        extsigma []
+    in
+    match rest with
+    | [] -> ()
+    | (evk,evi) :: _ ->
+      let (loc,_) = evi.Evd.evar_source in
+      Pretype_errors.error_unsolvable_implicit loc env sigma evk None
+
+  let tclWITHHOLES accept_unresolved_holes tac sigma x =
+    tclEVARMAP >>= fun sigma_initial ->
+      if sigma == sigma_initial then tac x
+      else
+        let check_evars env new_sigma sigma initial_sigma =
+          try
+            check_evars env new_sigma sigma initial_sigma;
+            tclUNIT ()
+          with e when Errors.noncritical e ->
+            tclZERO e
+        in
+        let check_evars_if =
+          if not accept_unresolved_holes then
+            tclEVARMAP >>= fun sigma_final ->
+              tclENV >>= fun env ->
+                check_evars env sigma_final sigma sigma_initial
+          else
+            tclUNIT ()
+        in
+        Proofview.Unsafe.tclEVARS sigma <*> tac x <*> check_evars_if
+
+  let tclTIMEOUT n t =
+    Proofview.tclOR
+      (Proofview.tclTIMEOUT n t)
+      begin function (e, info) -> match e with
+        | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (Errors.print e)))
+        | e -> Proofview.tclZERO ~info e
+      end
+
+  let tclTIME s t =
+    Proofview.tclTIME s t
+
+  let nthDecl m gl =
+    let hyps = Proofview.Goal.hyps gl in
+    try
+      List.nth hyps (m-1)
+    with Failure _ -> Errors.error "No such assumption."
+
+  let nLastDecls gl n =
+    try List.firstn n (Proofview.Goal.hyps gl)
+    with Failure _ -> error "Not enough hypotheses in the goal."
+
+  let nthHypId m gl =
+    (** We only use [id] *)
+    let gl = Proofview.Goal.assume gl in
+    let (id,_,_) = nthDecl m gl in
+    id
+  let nthHyp m gl = 
+    mkVar (nthHypId m gl)
+
+  let onNthHypId m tac =
+    Proofview.Goal.enter begin fun gl -> tac (nthHypId m gl) end
+  let onNthHyp m tac =
+    Proofview.Goal.enter begin fun gl -> tac (nthHyp m gl) end
+
+  let onLastHypId = onNthHypId 1
+  let onLastHyp   = onNthHyp 1
+
+  let onNthDecl m tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      Proofview.tclUNIT (nthDecl m gl) >>= tac
+    end
+  let onLastDecl  = onNthDecl 1
+
+  let ifOnHyp pred tac1 tac2 id =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let typ = Tacmach.New.pf_get_hyp_typ id gl in
+    if pred (id,typ) then
+      tac1 id
+    else
+      tac2 id
+    end
+
+  let onHyps find tac = Proofview.Goal.nf_enter (fun gl -> tac (find gl))
+
+  let afterHyp id tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let hyps = Proofview.Goal.hyps gl in
+    let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in
+    tac rem
+    end
+
+  let fullGoal gl =
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    None :: List.map Option.make hyps
+
+  let tryAllHyps tac =
+    Proofview.Goal.enter begin fun gl ->
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    tclFIRST_PROGRESS_ON tac hyps
+    end
+  let tryAllHypsAndConcl tac =
+    Proofview.Goal.enter begin fun gl ->
+      tclFIRST_PROGRESS_ON tac (fullGoal gl)
+    end
+
+  let onClause tac cl =
+    Proofview.Goal.enter begin fun gl ->
+    let hyps = Tacmach.New.pf_ids_of_hyps gl in
+    tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl)
+    end
+
+  (* Find the right elimination suffix corresponding to the sort of the goal *)
+  (* c should be of type A1->.. An->B with B an inductive definition *)
+  let general_elim_then_using mk_elim
+      isrec allnames tac predicate ind (c, t) =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in
+    (** FIXME: evar leak. *)
+    let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in
+    (* applying elimination_scheme just a little modified *)
+    let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in
+    let indmv =
+      match kind_of_term (last_arg elimclause.templval.Evd.rebus) with
+      | Meta mv -> mv
+      | _         -> anomaly (str"elimination")
+    in
+    let pmv =
+      let p, _ = decompose_app elimclause.templtyp.Evd.rebus in
+      match kind_of_term p with
+      | Meta p -> p
+      | _ ->
+	  let name_elim =
+	    match kind_of_term elim with
+	    | Const (kn, _) -> string_of_con kn
+	    | Var id -> string_of_id id
+	    | _ -> "\b"
+	  in
+	  error ("The elimination combinator " ^ name_elim ^ " is unknown.")
+    in
+    let elimclause' = clenv_fchain indmv elimclause indclause in
+    let branchsigns = compute_construtor_signatures isrec ind in
+    let brnames = compute_induction_names (Array.length branchsigns) allnames in
+    let flags = Unification.elim_flags () in
+    let elimclause' =
+      match predicate with
+      | None   -> elimclause'
+      | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause'
+    in
+    let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in
+    let after_tac i =
+      let (hd,largs) = decompose_app clenv'.templtyp.Evd.rebus in
+      let ba = { branchsign = branchsigns.(i);
+                 branchnames = brnames.(i);
+                 nassums =
+          List.fold_left
+            (fun acc b -> if b then acc+2 else acc+1)
+            0 branchsigns.(i);
+                 branchnum = i+1;
+                 ity = ind;
+                 largs = List.map (clenv_nf_meta clenv') largs;
+                 pred = clenv_nf_meta clenv' hd }
+      in
+      tac ba
+    in
+    let branchtacs = List.init (Array.length branchsigns) after_tac in
+    Proofview.tclTHEN
+      (Clenvtac.clenv_refine false clenv')
+      (Proofview.tclEXTEND [] tclIDTAC branchtacs)
+    end
+
+  let elimination_then tac c =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let isrec,mkelim =
+      match (Global.lookup_mind (fst (fst ind))).mind_record with
+      | None -> true,gl_make_elim
+      | Some _ -> false,gl_make_case_dep
+    in
+    general_elim_then_using mkelim isrec None tac None ind (c, t)
+    end
+
+  let case_then_using =
+    general_elim_then_using gl_make_case_dep false
+
+  let case_nodep_then_using =
+    general_elim_then_using gl_make_case_nodep false
+
+  let elim_on_ba tac ba =
+    Proofview.Goal.nf_enter begin fun gl ->
+    let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in
+    tac branches
+    end
+
+  let case_on_ba tac ba = 
+    Proofview.Goal.nf_enter begin fun gl ->
+    let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in
+    tac branches
+    end
+
+  let elimination_sort_of_goal gl =
+    (** Retyping will expand evars anyway. *)
+    let c = Proofview.Goal.concl (Goal.assume gl) in
+    pf_apply Retyping.get_sort_family_of gl c
+
+  let elimination_sort_of_hyp id gl =
+    (** Retyping will expand evars anyway. *)
+    let c = pf_get_hyp_typ id (Goal.assume gl) in
+    pf_apply Retyping.get_sort_family_of gl c
+
+  let elimination_sort_of_clause id gl = match id with
+  | None -> elimination_sort_of_goal gl
+  | Some id -> elimination_sort_of_hyp id gl
+
+  let pf_constr_of_global ref tac =
+    Proofview.Goal.nf_enter begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let (sigma, c) = Evd.fresh_global env sigma ref in
+      Proofview.Unsafe.tclEVARS sigma <*> (tac c)
+    end
+
+end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index ee88caa9..6249bbc5 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -1,29 +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 Loc
 open Pp
-open Util
 open Names
 open Term
-open Sign
+open Context
 open Tacmach
 open Proof_type
 open Clenv
-open Reduction
-open Pattern
-open Genarg
 open Tacexpr
-open Termops
-open Glob_term
+open Locus
+open Misctypes
 
 (** Tacticals i.e. functions from tactics to tactics. *)
 
-val tclNORMEVAR      : tactic
 val tclIDTAC         : tactic
 val tclIDTAC_MESSAGE : std_ppcmds -> tactic
 val tclORELSE0       : tactic -> tactic -> tactic
@@ -52,6 +48,7 @@ val tclFAIL_lazy     : int -> std_ppcmds Lazy.t -> tactic
 val tclDO            : int -> tactic -> tactic
 val tclWEAK_PROGRESS : tactic -> tactic
 val tclPROGRESS      : tactic -> tactic
+val tclSHOWHYPS      : tactic -> tactic
 val tclNOTSAMEGOAL   : tactic -> tactic
 val tclTHENTRY       : tactic -> tactic -> tactic
 val tclMAP           : ('a -> tactic) -> 'a list -> tactic
@@ -61,106 +58,57 @@ val tclIFTHENSELSE       : tactic -> tactic list -> tactic -> tactic
 val tclIFTHENSVELSE      : tactic -> tactic array -> tactic -> tactic
 val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic
 
-val tclFIRST_PROGRESS_ON : ('a -> tactic) -> 'a list -> tactic
-
 (** {6 Tacticals applying to hypotheses } *)
 
-val onNthHypId       : int -> (identifier -> tactic) -> tactic
+val onNthHypId       : int -> (Id.t -> tactic) -> tactic
 val onNthHyp         : int -> (constr -> tactic) -> tactic
 val onNthDecl        : int -> (named_declaration -> tactic) -> tactic
-val onLastHypId      : (identifier -> tactic) -> tactic
+val onLastHypId      : (Id.t -> tactic) -> tactic
 val onLastHyp        : (constr -> tactic) -> tactic
 val onLastDecl       : (named_declaration -> tactic) -> tactic
-val onNLastHypsId    : int -> (identifier list -> tactic) -> tactic
+val onNLastHypsId    : int -> (Id.t list -> tactic) -> tactic
 val onNLastHyps      : int -> (constr list -> tactic) -> tactic
 val onNLastDecls     : int -> (named_context -> tactic) -> tactic
 
-val lastHypId   : goal sigma -> identifier
+val lastHypId   : goal sigma -> Id.t
 val lastHyp     : goal sigma -> constr
 val lastDecl    : goal sigma -> named_declaration
-val nLastHypsId : int -> goal sigma -> identifier list
+val nLastHypsId : int -> goal sigma -> Id.t list
 val nLastHyps   : int -> goal sigma -> constr list
 val nLastDecls  : int -> goal sigma -> named_context
 
-val afterHyp    : identifier -> goal sigma -> named_context
+val afterHyp    : Id.t -> goal sigma -> named_context
 
-val ifOnHyp     : (identifier * types -> bool) ->
-                  (identifier -> tactic) -> (identifier -> tactic) ->
-		   identifier -> tactic
+val ifOnHyp     : (Id.t * types -> bool) ->
+                  (Id.t -> tactic) -> (Id.t -> tactic) ->
+		   Id.t -> tactic
 
 val onHyps      : (goal sigma -> named_context) ->
                   (named_context -> tactic) -> tactic
 
 (** {6 Tacticals applying to goal components } *)
 
-(** A [simple_clause] is a set of hypotheses, possibly extended with
-   the conclusion (conclusion is represented by None) *)
-
-type simple_clause = identifier option list
-
 (** A [clause] denotes occurrences and hypotheses in a
    goal; in particular, it can abstractly refer to the set of
    hypotheses independently of the effective contents of the current goal *)
 
-type clause = identifier gclause
-
-val simple_clause_of : clause -> goal sigma -> simple_clause
-
-val allHypsAndConcl : clause
-val allHyps         : clause
-val onHyp           : identifier -> clause
-val onConcl         : clause
-
-val tryAllHyps          : (identifier -> tactic) -> tactic
-val tryAllHypsAndConcl  : (identifier option -> tactic) -> tactic
-
-val onAllHyps           : (identifier -> tactic) -> tactic
-val onAllHypsAndConcl   : (identifier option -> tactic) -> tactic
-
-val onClause   : (identifier option -> tactic) -> clause -> tactic
-val onClauseLR : (identifier option -> tactic) -> clause -> tactic
-
-(** {6 An intermediate form of occurrence clause with no mention of occurrences } *)
-
-(** A [hyp_location] is an hypothesis together with a position, in
-   body if any, in type or in both *)
-
-type hyp_location = identifier * hyp_location_flag
-
-(** A [goal_location] is either an hypothesis (together with a position, in
-   body if any, in type or in both) or the goal *)
+val onAllHyps           : (Id.t -> tactic) -> tactic
+val onAllHypsAndConcl   : (Id.t option -> tactic) -> tactic
 
-type goal_location = hyp_location option
-
-(** {6 A concrete view of occurrence clauses } *)
-
-(** [clause_atom] refers either to an hypothesis location (i.e. an
-   hypothesis with occurrences and a position, in body if any, in type
-   or in both) or to some occurrences of the conclusion *)
-
-type clause_atom =
-  | OnHyp of identifier * occurrences_expr * hyp_location_flag
-  | OnConcl of occurrences_expr
-
-(** A [concrete_clause] is an effective collection of
-  occurrences in the hypotheses and the conclusion *)
-
-type concrete_clause = clause_atom list
-
-(** This interprets an [clause] in a given [goal] context *)
-val concrete_clause_of : clause -> goal sigma -> concrete_clause
+val onClause   : (Id.t option -> tactic) -> clause -> tactic
+val onClauseLR : (Id.t option -> tactic) -> clause -> tactic
 
 (** {6 Elimination tacticals. } *)
 
 type branch_args = {
-  ity        : inductive;   (** the type we were eliminating on *)
+  ity        : pinductive;   (** the type we were eliminating on *)
   largs      : constr list; (** its arguments *)
   branchnum  : int;         (** the branch number *)
   pred       : constr;      (** the predicate we used *)
   nassums    : int;         (** the number of assumptions to be introduced *)
   branchsign : bool list;   (** the signature of the branch.
                                true=recursive argument, false=constant *)
-  branchnames : intro_pattern_expr located list}
+  branchnames : intro_patterns}
 
 type branch_assumptions = {
   ba        : branch_args;     (** the branch args *)
@@ -169,47 +117,151 @@ type branch_assumptions = {
 (** [check_disjunctive_pattern_size loc pats n] returns an appropriate 
    error message if |pats| <> n *)
 val check_or_and_pattern_size :
-  Util.loc -> or_and_intro_pattern_expr -> int -> unit
+  Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> int -> unit
 
 (** Tolerate "[]" to mean a disjunctive pattern of any length *)
-val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr ->
-  or_and_intro_pattern_expr
+val fix_empty_or_and_pattern : int -> 
+  delayed_open_constr or_and_intro_pattern_expr ->
+  delayed_open_constr or_and_intro_pattern_expr
 
 (** Useful for [as intro_pattern] modifier *)
 val compute_induction_names :
-  int -> intro_pattern_expr located option ->
-    intro_pattern_expr located list array
+  int -> or_and_intro_pattern option -> intro_patterns array
 
 val elimination_sort_of_goal : goal sigma -> sorts_family
-val elimination_sort_of_hyp  : identifier -> goal sigma -> sorts_family
-val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family
+val elimination_sort_of_hyp  : Id.t -> goal sigma -> sorts_family
+val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family
 
-val general_elim_then_using :
-  (inductive -> goal sigma -> constr) -> rec_flag ->
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv ->
-    tactic
-
-val elimination_then_using :
-  (branch_args -> tactic) -> constr option ->
-    (arg_bindings * arg_bindings) -> constr -> tactic
-
-val elimination_then :
-  (branch_args -> tactic) ->
-    (arg_bindings * arg_bindings) -> constr -> tactic
-
-val case_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) ->
-      inductive -> clausenv -> tactic
-
-val case_nodep_then_using :
-  intro_pattern_expr located option -> (branch_args -> tactic) ->
-    constr option -> (arg_bindings * arg_bindings) ->
-      inductive -> clausenv -> tactic
-
-val simple_elimination_then :
-  (branch_args -> tactic) -> constr -> tactic
+val pf_with_evars :  (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic
+val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic
 
 val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
 val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic
+
+(** Tacticals defined directly in term of Proofview *)
+
+(** The tacticals in the module [New] are the tactical of Ltac. Their
+    semantics is an extension of the tacticals in this file for the
+    multi-goal backtracking tactics. They do not have the same
+    semantics as the similarly named tacticals in [Proofview]. The
+    tactical of [Proofview] are used in the definition of the
+    tacticals of [Tacticals.New], but they are more atomic. In
+    particular [Tacticals.New.tclORELSE] sees like of progress as a
+    failure, whereas [Proofview.tclORELSE] doesn't. Additionally every
+    tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY],
+    [tclREPEAt], etc…) are run into each goal independently (failures
+    and backtracks are localised to a given goal). *)
+module New : sig
+  open Proofview
+
+  (** [catch_failerror e] fails and decreases the level if [e] is an
+      Ltac error with level more than 0. Otherwise succeeds. *)
+  val catch_failerror : Util.iexn -> unit tactic
+
+  val tclIDTAC : unit tactic
+  val tclTHEN : unit tactic -> unit tactic -> unit tactic
+  (* [tclFAIL n msg] fails with [msg] as an error message at level [n]
+     (meaning that it will jump over [n] error catching tacticals FROM
+     THIS MODULE. *)
+  val tclFAIL : int -> Pp.std_ppcmds -> 'a tactic
+
+  val tclZEROMSG : ?loc:Loc.t -> Pp.std_ppcmds -> 'a tactic
+  (** Fail with a [User_Error] containing the given message. *)
+
+  val tclOR : unit tactic -> unit tactic -> unit tactic
+  val tclORD : unit tactic -> (unit -> unit tactic) -> unit tactic
+  (** Like {!tclOR} but accepts a delayed tactic as a second argument
+      in the form of a function which will be run only in case of
+      backtracking. *)
+
+  val tclONCE : unit tactic -> unit tactic
+  val tclEXACTLY_ONCE : unit tactic -> unit tactic
+
+  val tclIFCATCH :
+             unit tactic  ->
+    (unit -> unit tactic) ->
+    (unit -> unit tactic) -> unit tactic
+
+  val tclORELSE0 : unit tactic -> unit tactic -> unit tactic
+  val tclORELSE  : unit tactic -> unit tactic -> unit tactic
+
+  (** [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|]
+      gls] applies the tactic [tac1] to [gls] then, applies [t1], ...,
+      [tn] to the first [n] resulting subgoals, [t'1], ..., [t'm] to the
+      last [m] subgoals and [tac2] to the rest of the subgoals in the
+      middle. Raises an error if the number of resulting subgoals is
+      strictly less than [n+m] *)
+  val tclTHENS3PARTS     : unit tactic -> unit tactic array -> unit tactic -> unit tactic array -> unit tactic
+  val tclTHENSFIRSTn : unit tactic -> unit tactic array -> unit tactic -> unit tactic
+  val tclTHENFIRSTn : unit tactic -> unit tactic array -> unit tactic
+  (** [tclTHENFIRST tac1 tac2 gls] applies the tactic [tac1] to [gls]
+      and [tac2] to the first resulting subgoal *)
+  val tclTHENFIRST : unit tactic -> unit tactic -> unit tactic
+  val tclTHENLASTn : unit tactic -> unit tactic array -> unit tactic
+  val tclTHENLAST  : unit tactic -> unit tactic -> unit tactic
+  (* [tclTHENS t l = t <*> tclDISPATCH l] *)
+  val tclTHENS : unit tactic -> unit tactic list -> unit tactic
+  (* [tclTHENLIST [t1;…;tn]] is [t1<*>…<*>tn] *)
+  val tclTHENLIST : unit tactic list -> unit tactic
+
+  (** [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *)
+  val tclMAP : ('a -> unit tactic) -> 'a list -> unit tactic
+
+  val tclTRY : unit tactic -> unit tactic
+  val tclFIRST : unit tactic list -> unit tactic
+  val tclIFTHENELSE : unit tactic -> unit tactic -> unit tactic -> unit tactic
+  val tclIFTHENSVELSE : unit tactic -> unit tactic array -> unit tactic -> unit tactic
+  val tclIFTHENTRYELSEMUST : unit tactic -> unit tactic -> unit tactic
+
+  val tclDO : int -> unit tactic -> unit tactic
+  val tclREPEAT : unit tactic -> unit tactic
+  (* Repeat on the first subgoal (no failure if no more subgoal) *)
+  val tclREPEAT_MAIN : unit tactic -> unit tactic
+  val tclCOMPLETE : 'a tactic -> 'a tactic
+  val tclSOLVE : unit tactic list -> unit tactic
+  val tclPROGRESS : unit tactic -> unit tactic
+  val tclWITHHOLES : bool -> ('a -> unit tactic) -> Evd.evar_map -> 'a -> unit tactic
+
+  val tclTIMEOUT : int -> unit tactic -> unit tactic
+  val tclTIME : string option -> 'a tactic -> 'a tactic
+
+  val nLastDecls  : [ `NF ] Proofview.Goal.t -> int -> named_context
+
+  val ifOnHyp     : (identifier * types -> bool) ->
+    (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) ->
+    identifier -> unit Proofview.tactic
+
+  val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic
+  val onLastHypId      : (identifier -> unit tactic) -> unit tactic
+  val onLastHyp        : (constr -> unit tactic) -> unit tactic
+  val onLastDecl       : (named_declaration -> unit tactic) -> unit tactic
+
+  val onHyps      : ([ `NF ] Proofview.Goal.t -> named_context) ->
+                    (named_context -> unit tactic) -> unit tactic
+  val afterHyp    : Id.t -> (named_context -> unit tactic) -> unit tactic
+
+  val tryAllHyps          : (identifier -> unit tactic) -> unit tactic
+  val tryAllHypsAndConcl  : (identifier option -> unit tactic) -> unit tactic
+  val onClause   : (identifier option -> unit tactic) -> clause -> unit tactic
+
+  val elimination_sort_of_goal : 'a Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_hyp  : Id.t -> 'a Proofview.Goal.t -> sorts_family
+  val elimination_sort_of_clause : Id.t option -> 'a Proofview.Goal.t -> sorts_family
+
+  val elimination_then :
+    (branch_args -> unit Proofview.tactic) ->
+    constr -> unit Proofview.tactic
+
+  val case_then_using :
+    or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) ->
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
+
+  val case_nodep_then_using :
+    or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) ->
+    constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic
+
+  val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
+  val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args  -> unit Proofview.tactic
+
+  val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
+end
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index b6407340..f1f1248d 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1,52 +1,50 @@
 (************************************************************************)
 (*  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 Names
 open Nameops
-open Sign
 open Term
+open Vars
+open Context
 open Termops
+open Find_subterm
 open Namegen
 open Declarations
-open Inductive
 open Inductiveops
 open Reductionops
 open Environ
-open Libnames
+open Globnames
 open Evd
 open Pfedit
 open Tacred
-open Glob_term
+open Genredexpr
 open Tacmach
-open Proof_type
 open Logic
-open Evar_refiner
 open Clenv
-open Clenvtac
 open Refiner
 open Tacticals
 open Hipattern
 open Coqlib
-open Nametab
-open Genarg
 open Tacexpr
 open Decl_kinds
 open Evarutil
 open Indrec
 open Pretype_errors
 open Unification
+open Locus
+open Locusops
+open Misctypes
+open Proofview.Notations
 
-exception Bound
-
-let rec nb_prod x =
+let nb_prod x =
   let rec count n c =
     match kind_of_term c with
         Prod(_,_,t) -> count (n+1) t
@@ -55,14 +53,30 @@ let rec nb_prod x =
       | _ -> n
   in count 0 x
 
-let inj_with_occurrences e = (all_occurrences_expr,e)
+let inj_with_occurrences e = (AllOccurrences,e)
 
-let dloc = dummy_loc
+let dloc = Loc.ghost
 
 let typ_of = Retyping.get_type_of
 
-(* Option for 8.2 compatibility *)
+(* Option for 8.4 compatibility *)
 open Goptions
+let legacy_elim_if_not_fully_applied_argument = ref false
+
+let use_legacy_elim_if_not_fully_applied_argument () =
+  !legacy_elim_if_not_fully_applied_argument
+  || Flags.version_less_or_equal Flags.V8_4
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "partially applied elimination argument legacy";
+      optkey   = ["Legacy";"Partially";"Applied";"Elimination";"Argument"];
+      optread  = (fun () -> !legacy_elim_if_not_fully_applied_argument) ;
+      optwrite = (fun b -> legacy_elim_if_not_fully_applied_argument := b) }
+
+(* Option for 8.2 compatibility *)
 let dependent_propositions_elimination = ref true
 
 let use_dependent_propositions_elimination () =
@@ -78,86 +92,226 @@ let _ =
       optread  = (fun () -> !dependent_propositions_elimination) ;
       optwrite = (fun b -> dependent_propositions_elimination := b) }
 
-let finish_evar_resolution env initial_sigma c =
-  snd (Pretyping.solve_remaining_evars true true solve_by_implicit_tactic
-         env initial_sigma c)
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "trigger bugged context matching compatibility";
+      optkey   = ["Tactic";"Compat";"Context"];
+      optread  = (fun () -> !Flags.tactic_context_compat) ;
+      optwrite = (fun b -> Flags.tactic_context_compat := b) }
+
+let apply_solve_class_goals = ref (false)
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync = true; Goptions.optdepr = false;
+  Goptions.optname =
+    "Perform typeclass resolution on apply-generated subgoals.";
+  Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"];
+  Goptions.optread = (fun () -> !apply_solve_class_goals);
+  Goptions.optwrite = (fun a -> apply_solve_class_goals:=a);
+}
+
+let clear_hyp_by_default = ref false
+
+let use_clear_hyp_by_default () = !clear_hyp_by_default
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "default clearing of hypotheses after use";
+      optkey   = ["Default";"Clearing";"Used";"Hypotheses"];
+      optread  = (fun () -> !clear_hyp_by_default) ;
+      optwrite = (fun b -> clear_hyp_by_default := b) }
 
 (*********************************************)
 (*                 Tactics                   *)
 (*********************************************)
 
-(****************************************)
-(* General functions                    *)
-(****************************************)
-
-let string_of_inductive c =
-  try match kind_of_term c with
-  | Ind ind_sp ->
-      let (mib,mip) = Global.lookup_inductive ind_sp in
-      string_of_id mip.mind_typename
-  | _ -> raise Bound
-  with Bound -> error "Bound head variable."
-
-let rec head_constr_bound t =
-  let t = strip_outer_cast t in
-  let _,ccl = decompose_prod_assum t in
-  let hd,args = decompose_app ccl in
-  match kind_of_term hd with
-    | Const _ | Ind _ | Construct _ | Var _ -> (hd,args)
-    | _ -> raise Bound
-
-let head_constr c =
-  try head_constr_bound c with Bound -> error "Bound head variable."
-
 (******************************************)
 (*           Primitive tactics            *)
 (******************************************)
 
-let introduction    = Tacmach.introduction
+(** This tactic creates a partial proof realizing the introduction rule, but
+    does not check anything. *)
+let unsafe_intro env store (id, c, t) b =
+  Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+    let ctx = named_context_val env in
+    let nctx = push_named_context_val (id, c, t) ctx in
+    let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in
+    let ninst = mkRel 1 :: inst in
+    let nb = subst1 (mkVar id) b in
+    let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in
+    sigma, mkNamedLambda_or_LetIn (id, c, t) ev
+  end
+
+let introduction ?(check=true) id =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let hyps = Proofview.Goal.hyps gl in
+    let store = Proofview.Goal.extra gl in
+    let env = Proofview.Goal.env gl in
+    let () = if check && mem_named_context id hyps then
+      error ("Variable " ^ Id.to_string id ^ " is already declared.")
+    in
+    match kind_of_term (whd_evar sigma concl) with
+    | Prod (_, t, b) -> unsafe_intro env store (id, None, t) b
+    | LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b
+    | _ -> raise (RefinerError IntroNeedsProduct)
+  end
+
 let refine          = Tacmach.refine
-let convert_concl   = Tacmach.convert_concl
-let convert_hyp     = Tacmach.convert_hyp
-let thin_body       = Tacmach.thin_body
 
-let error_clear_dependency env id = function
+let convert_concl ?(check=true) ty k =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let store = Proofview.Goal.extra gl in
+    let conclty = Proofview.Goal.raw_concl gl in
+    Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+      let sigma =
+        if check then begin
+          ignore (Typing.type_of env sigma ty);
+          let sigma,b = Reductionops.infer_conv env sigma ty conclty in
+          if not b then error "Not convertible.";
+          sigma
+        end else sigma in
+      let (sigma,x) = Evarutil.new_evar env sigma ~principal:true ~store ty in
+      (sigma, if k == DEFAULTcast then x else mkCast(x,k,conclty))
+    end
+  end
+
+let convert_hyp ?(check=true) d =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ty = Proofview.Goal.raw_concl gl in
+    let store = Proofview.Goal.extra gl in
+    let sign = convert_hyp check (named_context_val env) sigma d in
+    let env = reset_with_named_context sign env in
+    Proofview.Refine.refine ~unsafe:true (fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty)
+  end
+
+let convert_concl_no_check = convert_concl ~check:false
+let convert_hyp_no_check = convert_hyp ~check:false
+
+let convert_gen pb x y =
+  Proofview.Goal.enter begin fun gl ->
+    try
+      let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in
+      Proofview.Unsafe.tclEVARS sigma
+    with (* Reduction.NotConvertible *) _ ->
+      (** FIXME: Sometimes an anomaly is raised from conversion *)
+      Tacticals.New.tclFAIL 0 (str "Not convertible")
+end
+
+let convert x y = convert_gen Reduction.CONV x y
+let convert_leq x y = convert_gen Reduction.CUMUL x y
+
+let clear_dependency_msg env sigma id = function
   | Evarutil.OccurHypInSimpleClause None ->
-      errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
+      pr_id id ++ str " is used in conclusion."
   | Evarutil.OccurHypInSimpleClause (Some id') ->
-      errorlabstrm ""
-        (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".")
+      pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str"."
   | Evarutil.EvarTypingBreak ev ->
-      errorlabstrm ""
-        (str "Cannot remove " ++ pr_id id ++
-	 strbrk " without breaking the typing of " ++
-	 Printer.pr_existential env ev ++ str".")
+      str "Cannot remove " ++ pr_id id ++
+      strbrk " without breaking the typing of " ++
+      Printer.pr_existential env sigma ev ++ str"."
 
-let thin l gl =
-  try thin l gl
-  with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+let error_clear_dependency env sigma id err =
+  errorlabstrm "" (clear_dependency_msg env sigma id err)
 
-let internal_cut_gen b d t gl =
-  try internal_cut b d t gl
-  with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+let replacing_dependency_msg env sigma id = function
+  | Evarutil.OccurHypInSimpleClause None ->
+      str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion."
+  | Evarutil.OccurHypInSimpleClause (Some id') ->
+      str "Cannot change " ++ pr_id id ++
+      strbrk ", it is used in hypothesis " ++ pr_id id' ++ str"."
+  | Evarutil.EvarTypingBreak ev ->
+      str "Cannot change " ++ pr_id id ++
+      strbrk " without breaking the typing of " ++
+      Printer.pr_existential env sigma ev ++ str"."
 
-let internal_cut = internal_cut_gen false
-let internal_cut_replace = internal_cut_gen true
+let error_replacing_dependency env sigma id err =
+  errorlabstrm "" (replacing_dependency_msg env sigma id err)
 
-let internal_cut_rev_gen b d t gl =
-  try internal_cut_rev b d t gl
+let thin l gl =
+  try thin l gl
   with Evarutil.ClearDependencyError (id,err) ->
-    error_clear_dependency (pf_env gl) id err
+    error_clear_dependency (pf_env gl) (project gl) id err
 
-let internal_cut_rev = internal_cut_rev_gen false
-let internal_cut_rev_replace = internal_cut_rev_gen true
+let thin_for_replacing l gl =
+  try Tacmach.thin l gl
+  with Evarutil.ClearDependencyError (id,err) ->
+    error_replacing_dependency (pf_env gl) (project gl) id err
+
+let apply_clear_request clear_flag dft c =
+  let check_isvar c =
+    if not (isVar c) then
+      error "keep/clear modifiers apply only to hypothesis names." in
+  let clear = match clear_flag with
+    | None -> dft && isVar c
+    | Some clear -> check_isvar c; clear in
+  if clear then Proofview.V82.tactic (thin [destVar c])
+  else Tacticals.New.tclIDTAC
 
 (* Moving hypotheses *)
-let move_hyp        = Tacmach.move_hyp
-
+let move_hyp id dest gl = Tacmach.move_hyp id dest gl
 
 (* Renaming hypotheses *)
-let rename_hyp      = Tacmach.rename_hyp
+let rename_hyp repl =
+  let fold accu (src, dst) = match accu with
+  | None -> None
+  | Some (srcs, dsts) ->
+    if Id.Set.mem src srcs then None
+    else if Id.Set.mem dst dsts then None
+    else
+      let srcs = Id.Set.add src srcs in
+      let dsts = Id.Set.add dst dsts in
+      Some (srcs, dsts)
+  in
+  let init = Some (Id.Set.empty, Id.Set.empty) in
+  let dom = List.fold_left fold init repl in
+  match dom with
+  | None -> Tacticals.New.tclZEROMSG (str "Not a one-to-one name mapping")
+  | Some (src, dst) ->
+    Proofview.Goal.enter begin fun gl ->
+      let gl = Proofview.Goal.assume gl in
+      let hyps = Proofview.Goal.hyps gl in
+      let concl = Proofview.Goal.concl gl in
+      let store = Proofview.Goal.extra gl in
+      (** Check that we do not mess variables *)
+      let fold accu (id, _, _) = Id.Set.add id accu in
+      let vars = List.fold_left fold Id.Set.empty hyps in
+      let () =
+        if not (Id.Set.subset src vars) then
+          let hyp = Id.Set.choose (Id.Set.diff src vars) in
+          raise (RefinerError (NoSuchHyp hyp))
+      in
+      let mods = Id.Set.diff vars src in
+      let () =
+        try
+          let elt = Id.Set.choose (Id.Set.inter dst mods) in
+          Errors.errorlabstrm "" (pr_id elt ++ str " is already used")
+        with Not_found -> ()
+      in
+      (** All is well *)
+      let make_subst (src, dst) = (src, mkVar dst) in
+      let subst = List.map make_subst repl in
+      let subst c = Vars.replace_vars subst c in
+      let map (id, body, t) =
+        let id = try List.assoc_f Id.equal id repl with Not_found -> id in
+        (id, Option.map subst body, subst t)
+      in
+      let nhyps = List.map map hyps in
+      let nconcl = subst concl in
+      let nctx = Environ.val_of_named_context nhyps in
+      let instance = List.map (fun (id, _, _) -> mkVar id) hyps in
+      Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+        Evarutil.new_evar_instance nctx sigma nconcl ~store instance
+      end
+    end
 
 (**************************************************************)
 (*          Fresh names                                       *)
@@ -169,6 +323,90 @@ let fresh_id_in_env avoid id env =
 let fresh_id avoid id gl =
   fresh_id_in_env avoid id (pf_env gl)
 
+let new_fresh_id avoid id gl =
+  fresh_id_in_env avoid id (Proofview.Goal.env gl)
+
+let id_of_name_with_default id = function
+  | Anonymous -> id
+  | Name id   -> id
+
+let default_id_of_sort s =
+  if Sorts.is_small s then default_small_ident else default_type_ident
+
+let default_id env sigma = function
+  | (name,None,t) ->
+      let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in
+      id_of_name_with_default dft name
+  | (name,Some b,_) -> id_of_name_using_hdchar env b name
+
+(* Non primitive introduction tactics are treated by intro_then_gen
+   There is possibly renaming, with possibly names to avoid and
+   possibly a move to do after the introduction *)
+
+type name_flag =
+  | NamingAvoid of Id.t list
+  | NamingBasedOn of Id.t * Id.t list
+  | NamingMustBe of Loc.t * Id.t
+
+let naming_of_name = function
+  | Anonymous -> NamingAvoid []
+  | Name id -> NamingMustBe (dloc,id)
+
+let find_name mayrepl decl naming gl = match naming with
+  | NamingAvoid idl ->
+      (* this case must be compatible with [find_intro_names] below. *)
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      new_fresh_id idl (default_id env sigma decl) gl
+  | NamingBasedOn (id,idl) ->  new_fresh_id idl id gl
+  | NamingMustBe (loc,id) ->
+      (* When name is given, we allow to hide a global name *)
+      let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in
+      let id' = next_ident_away id ids_of_hyps in
+      if not mayrepl && not (Id.equal id' id) then
+        user_err_loc (loc,"",pr_id id ++ str" is already used.");
+      id
+
+(**************************************************************)
+(*            Cut rule                                        *)
+(**************************************************************)
+
+let assert_before_then_gen b naming t tac =
+  Proofview.Goal.enter begin fun gl ->
+    let id = find_name b (Anonymous,None,t) naming gl in
+    Tacticals.New.tclTHENLAST
+      (Proofview.V82.tactic
+         (fun gl ->
+           try internal_cut b id t gl
+           with Evarutil.ClearDependencyError (id,err) ->
+             error_replacing_dependency (pf_env gl) (project gl) id err))
+      (tac id)
+  end
+
+let assert_before_gen b naming t =
+  assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ())
+
+let assert_before na = assert_before_gen false (naming_of_name na)
+let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id))
+
+let assert_after_then_gen b naming t tac =
+  Proofview.Goal.enter begin fun gl ->
+    let id = find_name b (Anonymous,None,t) naming gl in
+    Tacticals.New.tclTHENFIRST
+      (Proofview.V82.tactic
+         (fun gl ->
+           try internal_cut_rev b id t gl
+           with Evarutil.ClearDependencyError (id,err) ->
+             error_replacing_dependency (pf_env gl) (project gl) id err))
+      (tac id)
+  end
+
+let assert_after_gen b naming t =
+  assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ()))
+
+let assert_after na = assert_after_gen false (naming_of_name na)
+let assert_after_replacing id = assert_after_gen true (NamingMustBe (dloc,id))
+
 (**************************************************************)
 (*          Fixpoints and CoFixpoints                         *)
 (**************************************************************)
@@ -201,12 +439,12 @@ let pf_reduce_decl redfun where (id,c,ty) gl =
   let redfun' = pf_reduce redfun gl in
   match c with
   | None ->
-      if where = InHypValueOnly then
+      if where == InHypValueOnly then
 	errorlabstrm "" (pr_id id ++ str "has no value.");
       (id,None,redfun' ty)
   | Some b ->
-      let b' = if where <> InHypTypeOnly then redfun' b else b in
-      let ty' =	if where <> InHypValueOnly then redfun' ty else ty in
+      let b' = if where != InHypTypeOnly then redfun' b else b in
+      let ty' =	if where != InHypValueOnly then redfun' ty else ty in
       (id,Some b',ty')
 
 (* Possibly equip a reduction with the occurrences mentioned in an
@@ -227,11 +465,11 @@ let bind_change_occurrences occs = function
 
 let bind_red_expr_occurrences occs nbcl redexp =
   let has_at_clause = function
-    | Unfold l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
-    | Pattern l -> List.exists (fun (occl,_) -> occl <> all_occurrences_expr) l
-    | Simpl (Some (occl,_)) -> occl <> all_occurrences_expr
+    | Unfold l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l
+    | Pattern l -> List.exists (fun (occl,_) -> occl != AllOccurrences) l
+    | Simpl (_,Some (occl,_)) -> occl != AllOccurrences
     | _ -> false in
-  if occs = all_occurrences_expr then
+  if occs == AllOccurrences then
     if nbcl > 1 && has_at_clause redexp then
       error_illegal_non_atomic_clause ()
     else
@@ -241,24 +479,34 @@ let bind_red_expr_occurrences occs nbcl redexp =
     | Unfold (_::_::_) ->
 	error_illegal_clause ()
     | Unfold [(occl,c)] ->
-	if occl <> all_occurrences_expr then
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
 	  Unfold [(occs,c)]
     | Pattern (_::_::_) ->
 	error_illegal_clause ()
     | Pattern [(occl,c)] ->
-	if occl <> all_occurrences_expr then
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
 	  Pattern [(occs,c)]
-    | Simpl (Some (occl,c)) ->
-	if occl <> all_occurrences_expr then
+    | Simpl (f,Some (occl,c)) ->
+	if occl != AllOccurrences then
 	  error_illegal_clause ()
 	else
-	  Simpl (Some (occs,c))
-    | Red _ | Hnf | Cbv _ | Lazy _
-    | ExtraRedExpr _ | CbvVm | Fold _ | Simpl None ->
+	  Simpl (f,Some (occs,c))
+    | CbvVm (Some (occl,c)) ->
+        if occl != AllOccurrences then
+          error_illegal_clause ()
+        else
+          CbvVm (Some (occs,c))
+    | CbvNative (Some (occl,c)) ->
+        if occl != AllOccurrences then
+          error_illegal_clause ()
+        else
+          CbvNative (Some (occs,c))
+    | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _
+    | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None ->
 	error_occurrences_not_unsupported ()
     | Unfold [] | Pattern [] ->
 	assert false
@@ -268,71 +516,177 @@ let bind_red_expr_occurrences occs nbcl redexp =
    certain hypothesis *)
 
 let reduct_in_concl (redfun,sty) gl =
-  convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl
+  Proofview.V82.of_tactic (convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty) gl
 
-let reduct_in_hyp redfun (id,where) gl =
-  convert_hyp_no_check
-    (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl
+let reduct_in_hyp ?(check=false) redfun (id,where) gl =
+  Proofview.V82.of_tactic (convert_hyp ~check
+    (pf_reduce_decl redfun where (pf_get_hyp gl id) gl)) gl
 
 let revert_cast (redfun,kind as r) =
-  if kind = DEFAULTcast then (redfun,REVERTcast) else r
+  if kind == DEFAULTcast then (redfun,REVERTcast) else r
 
-let reduct_option redfun = function
-  | Some id -> reduct_in_hyp (fst redfun) id
+let reduct_option ?(check=false) redfun = function
+  | Some id -> reduct_in_hyp ~check (fst redfun) id
   | None    -> reduct_in_concl (revert_cast redfun)
 
-(* Now we introduce different instances of the previous tacticals *)
-let change_and_check cv_pb t env sigma c =
-  if is_fconv cv_pb env sigma t c then
-    t
+(** Tactic reduction modulo evars (for universes essentially) *)
+
+let pf_e_reduce_decl redfun where (id,c,ty) gl =
+  let sigma = project gl in
+  let redfun = redfun (pf_env gl) in
+  match c with
+  | None ->
+      if where == InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value.");
+    let sigma, ty' = redfun sigma ty in
+      sigma, (id,None,ty')
+  | Some b ->
+      let sigma, b' = if where != InHypTypeOnly then redfun sigma b else sigma, b in
+      let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in
+	sigma, (id,Some b',ty')
+
+let e_reduct_in_concl (redfun,sty) gl =
+  Proofview.V82.of_tactic
+    (let sigma, c' = (pf_apply redfun gl (pf_concl gl)) in
+       Proofview.Unsafe.tclEVARS sigma <*> 
+	 convert_concl_no_check c' sty) gl
+
+let e_reduct_in_hyp ?(check=false) redfun (id,where) gl =
+  Proofview.V82.of_tactic 
+    (let sigma, decl' = pf_e_reduce_decl redfun where (pf_get_hyp gl id) gl in
+       Proofview.Unsafe.tclEVARS sigma <*> 
+	 convert_hyp ~check decl') gl
+
+let e_reduct_option ?(check=false) redfun = function
+  | Some id -> e_reduct_in_hyp ~check (fst redfun) id
+  | None    -> e_reduct_in_concl (revert_cast redfun)
+
+(** Versions with evars to maintain the unification of universes resulting
+    from conversions. *)
+
+let tclWITHEVARS f k =
+  Proofview.Goal.enter begin fun gl ->
+  let evm, c' = f gl in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k c')
+  end
+
+let e_change_in_concl (redfun,sty) =
+  tclWITHEVARS
+    (fun gl -> redfun (Proofview.Goal.env gl) (Proofview.Goal.sigma gl)
+        (Proofview.Goal.raw_concl gl))
+    (fun c -> convert_concl_no_check c sty)
+
+let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma =
+  match c with
+  | None ->
+      if where == InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value.");
+    let sigma',ty' = redfun false env sigma ty in
+      sigma', (id,None,ty')
+  | Some b ->
+      let sigma',b' = if where != InHypTypeOnly then redfun true env sigma b else sigma, b in
+      let sigma',ty' = if where != InHypValueOnly then redfun false env sigma ty else sigma', ty in
+	sigma', (id,Some b',ty')
+
+let e_change_in_hyp redfun (id,where) =
+  tclWITHEVARS
+    (fun gl -> e_pf_change_decl redfun where
+      (Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl))
+      (Proofview.Goal.env gl) (Proofview.Goal.sigma gl))
+    convert_hyp
+
+type change_arg = evar_map -> evar_map * constr
+
+let check_types env sigma mayneedglobalcheck deep newc origc =
+  let t1 = Retyping.get_type_of env sigma newc in
+  if deep then begin
+    let t2 = Retyping.get_type_of env sigma origc in
+    let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in
+    if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then
+      if
+        isSort (whd_betadeltaiota env sigma t1) &&
+        isSort (whd_betadeltaiota env sigma t2)
+      then
+        mayneedglobalcheck := true
+      else
+        errorlabstrm "convert-check-hyp" (str "Types are incompatible.")
+  end
   else
-    errorlabstrm "convert-check-hyp" (str "Not convertible.")
+    if not (isSort (whd_betadeltaiota env sigma t1)) then
+      errorlabstrm "convert-check-hyp" (str "Not a type.")
+
+(* Now we introduce different instances of the previous tacticals *)
+let change_and_check cv_pb mayneedglobalcheck deep t env sigma c =
+  let sigma, t' = t sigma in
+  check_types env sigma mayneedglobalcheck deep t' c;
+  let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in
+  if not b then errorlabstrm "convert-check-hyp" (str "Not convertible.");
+  sigma, t'
+
+let change_and_check_subst cv_pb mayneedglobalcheck subst t env sigma c =
+  let t' sigma =
+    let sigma, t = t sigma in
+      sigma, replace_vars (Id.Map.bindings subst) t 
+  in change_and_check cv_pb mayneedglobalcheck true t' env sigma c
 
 (* Use cumulativity only if changing the conclusion not a subterm *)
-let change_on_subterm cv_pb t = function
-  | None -> change_and_check cv_pb t
+let change_on_subterm cv_pb deep t where env sigma c =
+  let mayneedglobalcheck = ref false in
+  let sigma,c = match where with
+  | None -> change_and_check cv_pb mayneedglobalcheck deep t env sigma c
   | Some occl ->
-      contextually false occl
-        (fun subst -> change_and_check Reduction.CONV (replace_vars subst t))
+      e_contextually false occl
+        (fun subst ->
+          change_and_check_subst Reduction.CONV mayneedglobalcheck subst t)
+        env sigma c in
+  if !mayneedglobalcheck then
+    begin
+      try ignore (Typing.type_of env sigma c)
+      with e when catchable_exception e ->
+        error "Replacement would lead to an ill-typed term."
+    end;
+  sigma,c
 
 let change_in_concl occl t =
-  reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast)
+  e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast)
 
 let change_in_hyp occl t id  =
-  with_check (reduct_in_hyp (change_on_subterm Reduction.CONV t occl) id)
+  e_change_in_hyp (fun x -> change_on_subterm Reduction.CONV x t occl) id
 
 let change_option occl t = function
   | Some id -> change_in_hyp occl t id
   | None -> change_in_concl occl t
 
 let change chg c cls gl =
-  let cls = concrete_clause_of cls gl in
-  tclMAP (function
+  let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in
+  Proofview.V82.of_tactic (Tacticals.New.tclMAP (function
     | OnHyp (id,occs,where) ->
        change_option (bind_change_occurrences occs chg) c (Some (id,where))
     | OnConcl occs ->
        change_option (bind_change_occurrences occs chg) c None)
-    cls gl
+    cls) gl
+
+let change_concl t = 
+  change_in_concl None (fun sigma -> sigma, t)
 
 (* Pour usage interne (le niveau User est pris en compte par reduce) *)
-let try_red_in_concl    = reduct_in_concl (try_red_product,REVERTcast)
 let red_in_concl        = reduct_in_concl (red_product,REVERTcast)
-let red_in_hyp          = reduct_in_hyp   red_product
+let red_in_hyp          = reduct_in_hyp    red_product
 let red_option          = reduct_option   (red_product,REVERTcast)
 let hnf_in_concl        = reduct_in_concl (hnf_constr,REVERTcast)
-let hnf_in_hyp          = reduct_in_hyp   hnf_constr
+let hnf_in_hyp          = reduct_in_hyp    hnf_constr
 let hnf_option          = reduct_option   (hnf_constr,REVERTcast)
 let simpl_in_concl      = reduct_in_concl (simpl,REVERTcast)
-let simpl_in_hyp        = reduct_in_hyp   simpl
+let simpl_in_hyp        = reduct_in_hyp    simpl
 let simpl_option        = reduct_option   (simpl,REVERTcast)
 let normalise_in_concl  = reduct_in_concl (compute,REVERTcast)
-let normalise_in_hyp    = reduct_in_hyp   compute
+let normalise_in_hyp    = reduct_in_hyp    compute
 let normalise_option    = reduct_option   (compute,REVERTcast)
 let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast)
 let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast)
 let unfold_in_hyp   loccname = reduct_in_hyp   (unfoldn loccname)
 let unfold_option   loccname = reduct_option (unfoldn loccname,DEFAULTcast)
-let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast)
+let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast)
 
 (* The main reduction function *)
 
@@ -345,10 +699,11 @@ let reduction_clause redexp cl =
 	(None, bind_red_expr_occurrences occs nbcl redexp)) cl
 
 let reduce redexp cl goal =
-  let cl = concrete_clause_of cl goal in
+  let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in
   let redexps = reduction_clause redexp cl in
   let tac = tclMAP (fun (where,redexp) ->
-    reduct_option (Redexpr.reduction_of_red_expr redexp) where) redexps in
+    e_reduct_option ~check:true
+      (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in
   match redexp with
   | Fold _ | Pattern _ -> with_check tac goal
   | _ -> tac goal
@@ -356,49 +711,14 @@ let reduce redexp cl goal =
 (* Unfolding occurrences of a constant *)
 
 let unfold_constr = function
-  | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp]
-  | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id]
+  | ConstRef sp -> unfold_in_concl [AllOccurrences,EvalConstRef sp]
+  | VarRef id -> unfold_in_concl [AllOccurrences,EvalVarRef id]
   | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
 
 (*******************************************)
 (*         Introduction tactics            *)
 (*******************************************)
 
-let id_of_name_with_default id = function
-  | Anonymous -> id
-  | Name id   -> id
-
-let hid = id_of_string "H"
-let xid = id_of_string "X"
-
-let default_id_of_sort = function Prop _ -> hid | Type _ -> xid
-
-let default_id env sigma = function
-  | (name,None,t) ->
-      let dft = default_id_of_sort (Typing.sort_of env sigma t) in
-      id_of_name_with_default dft name
-  | (name,Some b,_) -> id_of_name_using_hdchar env b name
-
-(* Non primitive introduction tactics are treated by central_intro
-   There is possibly renaming, with possibly names to avoid and
-   possibly a move to do after the introduction *)
-
-type intro_name_flag =
-  | IntroAvoid of identifier list
-  | IntroBasedOn of identifier * identifier list
-  | IntroMustBe of identifier
-
-let find_name loc decl gl = function
-  | IntroAvoid idl ->
-      (* this case must be compatible with [find_intro_names] below. *)
-      let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id
-  | IntroBasedOn (id,idl) -> fresh_id idl id gl
-  | IntroMustBe id ->
-      (* When name is given, we allow to hide a global name *)
-      let id' = next_ident_away id (pf_ids_of_hyps gl) in
-      if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used.");
-      id'
-
 (* Returns the names that would be created by intros, without doing
    intros.  This function is supposed to be compatible with an
    iteration of [find_name] above. As [default_id] checks the sort of
@@ -416,95 +736,138 @@ let find_intro_names ctxt gl =
   List.rev res
 
 let build_intro_tac id dest tac = match dest with
-  | MoveToEnd true -> tclTHEN (introduction id) (tac id)
-  | dest -> tclTHENLIST [introduction id; move_hyp true id dest; tac id]
-
-let rec intro_then_gen loc name_flag move_flag force_flag dep_flag tac gl =
-  match kind_of_term (pf_concl gl) with
-    | Prod (name,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag tac gl
-    | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) ->
-	build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag tac
-	  gl
+  | MoveLast -> Tacticals.New.tclTHEN (introduction id) (tac id)
+  | dest -> Tacticals.New.tclTHENLIST 
+    [introduction id; 
+     Proofview.V82.tactic (move_hyp id dest); tac id]
+    
+let rec intro_then_gen name_flag move_flag force_flag dep_flag tac =
+  Proofview.Goal.enter begin fun gl ->
+    let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    let concl = nf_evar (Proofview.Goal.sigma gl) concl in
+    match kind_of_term concl with
+    | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) ->
+        let name = find_name false (name,None,t) name_flag gl in
+	build_intro_tac name move_flag tac
+    | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) ->
+        let name = find_name false (name,Some b,t) name_flag gl in
+	build_intro_tac name move_flag tac
     | _ ->
-	if not force_flag then raise (RefinerError IntroNeedsProduct);
-	try
-	  tclTHEN try_red_in_concl
-	    (intro_then_gen loc name_flag move_flag force_flag dep_flag tac) gl
-	with Redelimination ->
-	  user_err_loc(loc,"Intro",str "No product even after head-reduction.")
-
-let intro_gen loc n m f d = intro_then_gen loc n m f d (fun _ -> tclIDTAC)
-let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true false
-let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false false
-let intro_then = intro_then_gen dloc (IntroAvoid []) no_move false false
-let intro = intro_gen dloc (IntroAvoid []) no_move false false
-let introf = intro_gen dloc (IntroAvoid []) no_move true false
-let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false false
-
-let intro_then_force = intro_then_gen dloc (IntroAvoid []) no_move true false
+	begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct)
+            (* Note: red_in_concl includes betaiotazeta and this was like *)
+            (* this since at least V6.3 (a pity *)
+            (* that intro do betaiotazeta only when reduction is needed; and *)
+            (* probably also a pity that intro does zeta *)
+          else Proofview.tclUNIT ()
+        end <*>
+	  Proofview.tclORELSE
+	  (Tacticals.New.tclTHEN (Proofview.V82.tactic hnf_in_concl)
+	     (intro_then_gen name_flag move_flag false dep_flag tac))
+          begin function (e, info) -> match e with
+            | RefinerError IntroNeedsProduct ->
+                Proofview.tclZERO 
+		  (Errors.UserError("Intro",str "No product even after head-reduction."))
+            | e -> Proofview.tclZERO ~info e
+          end
+  end
 
-(**** Multiple introduction tactics ****)
+let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ())
+let intro_mustbe_force id = intro_gen (NamingMustBe (dloc,id)) MoveLast true false
+let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false
 
-let rec intros_using = function
-  | []     -> tclIDTAC
-  | str::l -> tclTHEN (intro_using str) (intros_using l)
+let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false
+let intro = intro_gen (NamingAvoid []) MoveLast false false
+let introf = intro_gen (NamingAvoid []) MoveLast true false
+let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false
 
-let intros = tclREPEAT intro
+let intro_then_force = intro_then_gen (NamingAvoid []) MoveLast true false
 
-let intro_erasing id = tclTHEN (thin [id]) (introduction id)
+let intro_move_avoid idopt avoid hto = match idopt with
+  | None -> intro_gen (NamingAvoid avoid) hto true false
+  | Some id -> intro_gen (NamingMustBe (dloc,id)) hto true false
 
-let intro_forthcoming_then_gen loc name_flag move_flag dep_flag tac =
-  let rec aux ids =
-    tclORELSE0
-      (intro_then_gen loc name_flag  move_flag false dep_flag
-         (fun id -> aux (id::ids)))
-      (tac ids) in
-  aux []
+let intro_move idopt hto = intro_move_avoid idopt [] hto
 
-let rec get_next_hyp_position id = function
-  | [] -> error ("No such hypothesis: " ^ string_of_id id)
-  | (hyp,_,_) :: right ->
-      if hyp = id then
-	match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd true
-      else
-	get_next_hyp_position id right
+(**** Multiple introduction tactics ****)
 
-let thin_for_replacing l gl =
-  try Tacmach.thin l gl
-  with Evarutil.ClearDependencyError (id,err) -> match err with
-  | Evarutil.OccurHypInSimpleClause None ->
-      errorlabstrm ""
-      (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.")
-  | Evarutil.OccurHypInSimpleClause (Some id') ->
-      errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++
-	 strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".")
-  | Evarutil.EvarTypingBreak ev ->
-      errorlabstrm ""
-        (str "Cannot change " ++ pr_id id ++
-	 strbrk " without breaking the typing of " ++
-	 Printer.pr_existential (pf_env gl) ev ++ str".")
+let rec intros_using = function
+  | []     -> Proofview.tclUNIT()
+  | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l)
+
+let intros = Tacticals.New.tclREPEAT intro
+
+let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac =
+  let rec aux n ids =
+    (* Note: we always use the bound when there is one for "*" and "**" *)
+    if (match bound with None -> true | Some (_,p) -> n < p) then
+    Proofview.tclORELSE
+      begin
+      intro_then_gen name_flag move_flag false dep_flag
+         (fun id -> aux (n+1) (id::ids))
+      end
+      begin function (e, info) -> match e with
+      | RefinerError IntroNeedsProduct ->
+          tac ids
+      | e -> Proofview.tclZERO ~info e
+      end
+    else
+      tac ids
+  in
+  aux n []
 
-let intro_replacing id gl =
-  let next_hyp = get_next_hyp_position id (pf_hyps gl) in
-  tclTHENLIST
-    [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl
-
-let intros_replacing ids gl =
-  let rec introrec = function
-    | [] -> tclIDTAC
-    | id::tl ->
-	tclTHEN (tclORELSE (intro_replacing id) (intro_using id))
-           (introrec tl)
+let get_next_hyp_position id gl =
+  let rec get_next_hyp_position id = function
+  | [] -> raise (RefinerError (NoSuchHyp id))
+  | (hyp,_,_) :: right ->
+    if Id.equal hyp id then
+      match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast
+    else
+      get_next_hyp_position id right
   in
-  introrec ids gl
+  let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in
+  get_next_hyp_position id hyps
+
+let intro_replacing id =
+  Proofview.Goal.enter begin fun gl ->
+  let next_hyp = get_next_hyp_position id gl in
+  Tacticals.New.tclTHENLIST [
+    Proofview.V82.tactic (thin_for_replacing [id]);
+    introduction id;
+    Proofview.V82.tactic (move_hyp id next_hyp);
+  ]
+  end
 
-(* User-level introduction tactics *)
+(* We have e.g. [x, y, y', x', y'' |- forall y y' y'', G] and want to
+   reintroduce y, y,' y''. Note that we have to clear y, y' and y''
+   before introducing y because y' or y'' can e.g. depend on old y. *)
+
+(* This version assumes that replacement is actually possible *)
+(* (ids given in the introduction order) *)
+(* We keep a sub-optimality in cleaing for compatibility with *)
+(* the behavior of inversion *)
+let intros_possibly_replacing ids =
+  let suboptimal = true in
+  Proofview.Goal.enter begin fun gl ->
+    let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in
+    Tacticals.New.tclTHEN
+      (Tacticals.New.tclMAP (fun id -> 
+	Tacticals.New.tclTRY (Proofview.V82.tactic (thin_for_replacing [id])))
+	 (if suboptimal then ids else List.rev ids))
+      (Tacticals.New.tclMAP (fun (id,pos) ->
+        Tacticals.New.tclORELSE (intro_move (Some id) pos) (intro_using id))
+         posl)
+  end
+
+(* This version assumes that replacement is actually possible *)
+let intros_replacing ids =
+  Proofview.Goal.enter begin fun gl ->
+    let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in
+    Tacticals.New.tclTHEN
+      (Proofview.V82.tactic (thin_for_replacing ids))
+      (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl)
+  end
 
-let intro_move idopt hto = match idopt with
-  | None -> intro_gen dloc (IntroAvoid []) hto true false
-  | Some id -> intro_gen dloc (IntroMustBe id) hto true false
+(* User-level introduction tactics *)
 
 let pf_lookup_hypothesis_as_renamed env ccl = function
   | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n
@@ -516,15 +879,15 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl =
     match pf_lookup_hypothesis_as_renamed env ccl h with
       | None when red ->
           aux
-	    ((fst (Redexpr.reduction_of_red_expr (Red true)))
-	       env (project gl) ccl)
+	    (snd ((fst (Redexpr.reduction_of_red_expr env (Red true)))
+	       env (project gl) ccl))
       | x -> x
   in
   try aux (pf_concl gl)
   with Redelimination -> None
 
 let is_quantified_hypothesis id g =
-  match pf_lookup_hypothesis_as_renamed_gen true (NamedHyp id) g with
+  match pf_lookup_hypothesis_as_renamed_gen false (NamedHyp id) g with
     | Some _ -> true
     | None -> false
 
@@ -545,167 +908,167 @@ let depth_of_quantified_hypothesis red h gl =
 	  (if red then strbrk " even after head-reduction" else mt ()) ++
 	  str".")
 
-let intros_until_gen red h g =
-  tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g
+let intros_until_gen red h =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in
+  Tacticals.New.tclDO n (if red then introf else intro)
+  end
 
-let intros_until_id id = intros_until_gen true (NamedHyp id)
+let intros_until_id id = intros_until_gen false (NamedHyp id)
 let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
 
 let intros_until = intros_until_gen true
 let intros_until_n = intros_until_n_gen true
-let intros_until_n_wored = intros_until_n_gen false
 
 let tclCHECKVAR id gl = ignore (pf_get_hyp gl id); tclIDTAC gl
 
 let try_intros_until_id_check id =
-  tclORELSE (intros_until_id id) (tclCHECKVAR id)
+  Tacticals.New.tclORELSE (intros_until_id id) (Proofview.V82.tactic (tclCHECKVAR id))
 
 let try_intros_until tac = function
-  | NamedHyp id -> tclTHEN (try_intros_until_id_check id) (tac id)
-  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHypId tac)
+  | NamedHyp id -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (tac id)
+  | AnonHyp n -> Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHypId tac)
 
 let rec intros_move = function
-  | [] -> tclIDTAC
+  | [] -> Proofview.tclUNIT ()
   | (hyp,destopt) :: rest ->
-      tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false false)
+      Tacticals.New.tclTHEN (intro_gen (NamingMustBe (dloc,hyp)) destopt false false)
 	(intros_move rest)
 
-let dependent_in_decl a (_,c,t) =
-  match c with
-    | None -> dependent a t
-    | Some body -> dependent a body || dependent a t
-
 (* Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
-let onOpenInductionArg tac = function
-  | ElimOnConstr cbl ->
-      tac cbl
-  | ElimOnAnonHyp n ->
-      tclTHEN
+let onOpenInductionArg env sigma tac = function
+  | clear_flag,ElimOnConstr f ->
+      let (sigma',cbl) = f env sigma in
+      let pending = (sigma,sigma') in
+      Tacticals.New.tclTHEN
+        (Proofview.Unsafe.tclEVARS sigma')
+        (tac clear_flag (pending,cbl))
+  | clear_flag,ElimOnAnonHyp n ->
+      Tacticals.New.tclTHEN
         (intros_until_n n)
-        (onLastHyp (fun c -> tac (Evd.empty,(c,NoBindings))))
-  | ElimOnIdent (_,id) ->
+        (Tacticals.New.onLastHyp
+           (fun c ->
+             Proofview.Goal.enter begin fun gl ->
+             let sigma = Proofview.Goal.sigma gl in
+             let pending = (sigma,sigma) in
+             tac clear_flag (pending,(c,NoBindings))
+             end))
+  | clear_flag,ElimOnIdent (_,id) ->
       (* A quantified hypothesis *)
-      tclTHEN
+      Tacticals.New.tclTHEN
         (try_intros_until_id_check id)
-        (tac (Evd.empty,(mkVar id,NoBindings)))
+        (Proofview.Goal.enter begin fun gl ->
+         let sigma = Proofview.Goal.sigma gl in
+         let pending = (sigma,sigma) in
+         tac clear_flag (pending,(mkVar id,NoBindings))
+        end)
 
 let onInductionArg tac = function
-  | ElimOnConstr cbl ->
-      tac cbl
-  | ElimOnAnonHyp n ->
-      tclTHEN (intros_until_n n) (onLastHyp (fun c -> tac (c,NoBindings)))
-  | ElimOnIdent (_,id) ->
+  | clear_flag,ElimOnConstr cbl ->
+      tac clear_flag cbl
+  | clear_flag,ElimOnAnonHyp n ->
+      Tacticals.New.tclTHEN
+        (intros_until_n n)
+        (Tacticals.New.onLastHyp (fun c -> tac clear_flag (c,NoBindings)))
+  | clear_flag,ElimOnIdent (_,id) ->
       (* A quantified hypothesis *)
-      tclTHEN (try_intros_until_id_check id) (tac (mkVar id,NoBindings))
+      Tacticals.New.tclTHEN
+        (try_intros_until_id_check id)
+        (tac clear_flag (mkVar id,NoBindings))
 
 let map_induction_arg f = function
-  | ElimOnConstr (sigma,(c,bl)) -> ElimOnConstr (f (sigma,c),bl)
-  | ElimOnAnonHyp n -> ElimOnAnonHyp n
-  | ElimOnIdent id -> ElimOnIdent id
-
-(**************************)
-(*  Refinement tactics    *)
-(**************************)
+  | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (f g)
+  | clear_flag,ElimOnAnonHyp n as x -> x
+  | clear_flag,ElimOnIdent id as x -> x
 
-let apply_type hdcty argl gl =
-  refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
-
-let apply_term hdc argl gl =
-  refine (applist (hdc,argl)) gl
+(****************************************)
+(* tactic "cut" (actually modus ponens) *)
+(****************************************)
 
-let bring_hyps hyps =
-  if hyps = [] then Refiner.tclIDTAC
-  else
-    (fun gl ->
-      let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in
-      let f = mkCast (Evarutil.mk_new_meta(),DEFAULTcast, newcl) in
-      refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
-
-let resolve_classes gl =
-  let env = pf_env gl and evd = project gl in
-    if Evd.is_empty evd then tclIDTAC gl
+let cut c =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Tacmach.New.pf_nf_concl gl in
+    let is_sort =
+      try
+        (** Backward compat: ensure that [c] is well-typed. *)
+        let typ = Typing.type_of env sigma c in
+        let typ = whd_betadeltaiota env sigma typ in
+        match kind_of_term typ with
+        | Sort _ -> true
+        | _ -> false
+      with e when Pretype_errors.precatchable_exception e -> false
+    in
+    if is_sort then
+      let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in
+      (** Backward compat: normalize [c]. *)
+      let c = local_strong whd_betaiota sigma c in
+      Proofview.Refine.refine ~unsafe:true begin fun h ->
+        let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in
+        let (h, x) = Evarutil.new_evar env h c in
+        let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in
+        (h, mkApp (f, [|x|]))
+      end
     else
-      let evd' = Typeclasses.resolve_typeclasses env evd in
-	(tclTHEN (tclEVARS evd') tclNORMEVAR) gl
-
-(**************************)
-(*     Cut tactics        *)
-(**************************)
-
-let cut c gl =
-  match kind_of_term (pf_hnf_type_of gl c) with
-    | Sort _ ->
-        let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
-        let t = mkProd (Anonymous, c, pf_concl gl) in
-          tclTHENFIRST
-            (internal_cut_rev id c)
-            (tclTHEN (apply_type t [mkVar id]) (thin [id]))
-            gl
-    | _  -> error "Not a proposition or a type."
-
-let cut_intro t = tclTHENFIRST (cut t) intro
-
-(* [assert_replacing id T tac] adds the subgoals of the proof of [T]
-   before the current goal
-
-   id:T0                 id:T0    id:T     
-   =====   ------>   tac(=====) + ==== 
-    G                     T        G
-
-   It fails if the hypothesis to replace appears in the goal or in
-   another hypothesis.
-*) 
-
-let assert_replacing id t tac = tclTHENFIRST (internal_cut_replace id t) tac
-
-(* [cut_replacing id T tac] adds the subgoals of the proof of [T]
-   after the current goal
-
-   id:T0             id:T       id:T0
-   =====   ------>   ==== + tac(=====)
-    G                 G          T
-
-   It fails if the hypothesis to replace appears in the goal or in
-   another hypothesis.
-*)
-
-let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) tac
-
-let cut_in_parallel l =
-  let rec prec = function
-    | [] -> tclIDTAC
-    | h::t -> tclTHENFIRST (cut h) (prec t)
-  in
-    prec (List.rev l)
+      Tacticals.New.tclZEROMSG (str "Not a proposition or a type.")
+  end
 
 let error_uninstantiated_metas t clenv =
   let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in
-  let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta"
+  let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta")
   in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".")
 
+let check_unresolved_evars_of_metas sigma clenv =
+  (* This checks that Metas turned into Evars by *)
+  (* Refiner.pose_all_metas_as_evars are resolved *)
+  List.iter (fun (mv,b) -> match b with
+  | Clval (_,(c,_),_) ->
+    (match kind_of_term c.rebus with
+    | Evar (evk,_) when Evd.is_undefined clenv.evd evk
+                     && not (Evd.mem sigma evk) ->
+      error_uninstantiated_metas (mkMeta mv) clenv
+    | _ -> ())
+  | _ -> ())
+  (meta_list clenv.evd)
+
+let do_replace id = function
+  | NamingMustBe (_,id') when Option.equal Id.equal id (Some id') -> true
+  | _ -> false
+
 (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some
    goal [G], [clenv_refine_in] returns [n+1] subgoals, the [n] last
    ones (resp [n] first ones if [sidecond_first] is [true]) being the
    [Ti] and the first one (resp last one) being [G] whose hypothesis
    [id] is replaced by P using the proof given by [tac] *)
 
-let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id clenv gl =
-  let clenv = clenv_pose_dependent_evars with_evars clenv in
+let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) 
+    targetid id sigma0 clenv tac =
+  let clenv = Clenvtac.clenv_pose_dependent_evars with_evars clenv in
   let clenv =
     if with_classes then
-      { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd }
+      { clenv with evd = Typeclasses.resolve_typeclasses 
+	  ~fail:(not with_evars) clenv.env clenv.evd }
     else clenv
   in
   let new_hyp_typ = clenv_type clenv in
-  if not with_evars & occur_meta new_hyp_typ then
+  if not with_evars then check_unresolved_evars_of_metas sigma0 clenv;
+  if not with_evars && occur_meta new_hyp_typ then
     error_uninstantiated_metas new_hyp_typ clenv;
   let new_hyp_prf = clenv_value clenv in
-  tclTHEN
-    (tclEVARS clenv.evd)
-    ((if sidecond_first then assert_replacing else cut_replacing)
-      id new_hyp_typ (refine_no_check new_hyp_prf)) gl
+  let exact_tac = Proofview.V82.tactic (refine_no_check new_hyp_prf) in
+  let naming = NamingMustBe (dloc,targetid) in
+  let with_clear = do_replace (Some id) naming in
+  Tacticals.New.tclTHEN
+    (Proofview.Unsafe.tclEVARS clenv.evd)
+    (if sidecond_first then
+       Tacticals.New.tclTHENFIRST
+         (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac
+     else
+       Tacticals.New.tclTHENLAST
+         (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac)
 
 (********************************************)
 (*       Elimination tactics                *)
@@ -713,14 +1076,14 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) id c
 
 let last_arg c = match kind_of_term c with
   | App (f,cl) ->
-      array_last cl
-  | _ -> anomaly "last_arg"
+      Array.last cl
+  | _ -> anomaly (Pp.str "last_arg")
 
 let nth_arg i c =
-  if i = -1 then last_arg c else
+  if Int.equal i (-1) then last_arg c else
   match kind_of_term c with
   | App (f,cl) -> cl.(i)
-  | _ -> anomaly "nth_arg"
+  | _ -> anomaly (Pp.str "nth_arg")
 
 let index_of_ind_arg t =
   let rec aux i j t = match kind_of_term t with
@@ -733,7 +1096,51 @@ let index_of_ind_arg t =
       | None -> error "Could not find inductive argument of elimination scheme."
   in aux None 0 t
 
-let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indclause gl =
+let enforce_prop_bound_names rename tac =
+  match rename with
+  | Some (isrec,nn) when Namegen.use_h_based_elimination_names () ->
+      (* Rename dependent arguments in Prop with name "H" *)
+      (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *)
+      (* elim or induction with schemes built by Indrec.build_induction_scheme *)
+      let rec aux env sigma i t =
+        if i = 0 then t else match kind_of_term t with
+        | Prod (Name _ as na,t,t') ->
+            let very_standard = true in
+            let na =
+              if Retyping.get_sort_family_of env sigma t = InProp then
+                (* "very_standard" says that we should have "H" names only, but
+                   this would break compatibility even more... *)
+                let s = match Namegen.head_name t with
+                  | Some id when not very_standard -> string_of_id id
+                  | _ -> "" in
+                Name (add_suffix Namegen.default_prop_ident s)
+              else
+                na in
+            mkProd (na,t,aux (push_rel (na,None,t) env) sigma (i-1) t')
+        | Prod (Anonymous,t,t') ->
+            mkProd (Anonymous,t,aux (push_rel (Anonymous,None,t) env) sigma (i-1) t')
+        | LetIn (na,c,t,t') ->
+            mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t')
+        | _ -> print_int i; Pp.msg (print_constr t); assert false in
+      let rename_branch i =
+        Proofview.Goal.nf_enter begin fun gl ->
+          let env = Proofview.Goal.env gl in
+          let sigma = Proofview.Goal.sigma gl in
+          let t = Proofview.Goal.concl gl in
+          change_concl (aux env sigma i t)
+        end in
+      (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
+        tac
+        (Array.map rename_branch nn)
+  | _ ->
+      tac
+
+let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) 
+    rename i (elim, elimty, bindings) indclause =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv =
     (match kind_of_term (nth_arg i elimclause.templval.rebus) with
        | Meta mv -> mv
@@ -741,7 +1148,8 @@ let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indcla
              (str "The type of elimination clause is not well-formed."))
   in
   let elimclause' = clenv_fchain ~flags indmv elimclause indclause in
-  res_pf elimclause' ~with_evars:with_evars ~flags gl
+  enforce_prop_bound_names rename (Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags)
+  end
 
 (*
  * Elimination tactic with bindings and using an arbitrary
@@ -753,53 +1161,116 @@ let elimination_clause_scheme with_evars ?(flags=elim_flags) i elimclause indcla
 
 type eliminator = {
   elimindex : int option;  (* None = find it automatically *)
+  elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *)
   elimbody : constr with_bindings
 }
 
-let general_elim_clause_gen elimtac indclause elim gl =
+let general_elim_clause_gen elimtac indclause elim =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   let (elimc,lbindelimc) = elim.elimbody in
-  let elimt = pf_type_of gl elimc in
+  let elimt = Retyping.get_type_of env sigma elimc in
   let i =
     match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in
-  let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in
-  elimtac i elimclause indclause gl
+  elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause
+  end
 
-let general_elim_clause elimtac (c,lbindc) elim gl =
-  let ct = pf_type_of gl c in
-  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
-  let indclause  = make_clenv_binding gl (c,t) lbindc  in
-    general_elim_clause_gen elimtac indclause elim gl
+let general_elim with_evars clear_flag (c, lbindc) elim =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ct = Retyping.get_type_of env sigma c in
+  let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in
+  let elimtac = elimination_clause_scheme with_evars in
+  let indclause  = make_clenv_binding env sigma (c, t) lbindc in
+  Tacticals.New.tclTHEN
+    (general_elim_clause_gen elimtac indclause elim)
+    (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)
+  end
 
-let general_elim with_evars c e =
-  general_elim_clause (elimination_clause_scheme with_evars) c e
+(* Case analysis tactics *)
+
+let general_case_analysis_in_context with_evars clear_flag (c,lbindc) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let concl = Proofview.Goal.concl gl in
+  let t = Retyping.get_type_of env sigma c in
+  let (mind,_) = reduce_to_quantified_ind env sigma t in
+  let sort = Tacticals.New.elimination_sort_of_goal gl in
+  let sigma, elim =
+    if occur_term c concl then
+      build_case_analysis_scheme env sigma mind true sort
+    else
+      build_case_analysis_scheme_default env sigma mind sort in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma)
+  (general_elim with_evars clear_flag (c,lbindc)
+   {elimindex = None; elimbody = (elim,NoBindings);
+    elimrename = Some (false, constructors_nrealdecls (fst mind))})
+  end
+
+let general_case_analysis with_evars clear_flag (c,lbindc as cx) =
+  match kind_of_term c with
+    | Var id when lbindc == NoBindings ->
+	Tacticals.New.tclTHEN (try_intros_until_id_check id)
+	  (general_case_analysis_in_context with_evars clear_flag cx)
+    | _ ->
+        general_case_analysis_in_context with_evars clear_flag cx
+
+let simplest_case c = general_case_analysis false None (c,NoBindings)
 
 (* Elimination tactic with bindings but using the default elimination
  * constant associated with the type. *)
 
-let find_eliminator c gl =
-  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let c = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  {elimindex = None; elimbody = (c,NoBindings)}
+exception IsNonrec
+
+let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.BiFinite
 
-let default_elim with_evars (c,_ as cx) gl =
-  general_elim with_evars cx (find_eliminator c gl) gl
+let find_ind_eliminator ind s gl =
+  let gr = lookup_eliminator ind s in
+  let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in
+    evd, c
 
-let elim_in_context with_evars c = function
+let find_eliminator c gl =
+  let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_type_of gl c) in
+  if is_nonrec ind then raise IsNonrec;
+  let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in
+    evd, {elimindex = None; elimbody = (c,NoBindings);
+          elimrename = Some (true, constructors_nrealdecls ind)}
+
+let default_elim with_evars clear_flag (c,_ as cx) =
+  Proofview.tclORELSE
+    (Proofview.Goal.enter begin fun gl ->
+      let evd, elim = find_eliminator c gl in
+	Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd)
+	  (general_elim with_evars clear_flag cx elim)
+    end)
+    begin function (e, info) -> match e with
+      | IsNonrec ->
+          (* For records, induction principles aren't there by default
+             anymore.  Instead, we do a case analysis instead. *)
+          general_case_analysis with_evars clear_flag cx
+      | e -> Proofview.tclZERO ~info e
+    end
+
+let elim_in_context with_evars clear_flag c = function
   | Some elim ->
-      general_elim with_evars c {elimindex = Some (-1); elimbody = elim}
-  | None -> default_elim with_evars c
+      general_elim with_evars clear_flag c
+        {elimindex = Some (-1); elimbody = elim; elimrename = None}
+  | None -> default_elim with_evars clear_flag c
 
-let elim with_evars (c,lbindc as cx) elim =
+let elim with_evars clear_flag (c,lbindc as cx) elim =
   match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (try_intros_until_id_check id)
-	  (elim_in_context with_evars cx elim)
+    | Var id when lbindc == NoBindings ->
+	Tacticals.New.tclTHEN (try_intros_until_id_check id)
+	  (elim_in_context with_evars clear_flag cx elim)
     | _ ->
-	elim_in_context with_evars cx elim
+	elim_in_context with_evars clear_flag cx elim
 
 (* The simplest elimination tactic, with no substitutions at all. *)
 
-let simplest_elim c = default_elim false (c,NoBindings)
+let simplest_elim c = default_elim false None (c,NoBindings)
 
 (* Elimination in hypothesis *)
 (* Typically, elimclause := (eq_ind ?x ?P ?H ?y ?Heq : ?P ?y)
@@ -811,56 +1282,44 @@ let simplest_elim c = default_elim false (c,NoBindings)
    (e.g. it could replace id:A->B->C by id:C, knowing A/\B)
 *)
 
-let clenv_fchain_in id ?(flags=elim_flags) mv elimclause hypclause =
+let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause =
   try clenv_fchain ~flags mv elimclause hypclause
   with PretypeError (env,evd,NoOccurrenceFound (op,_)) ->
     (* Set the hypothesis name in the message *)
     raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id)))
 
-let elimination_in_clause_scheme with_evars ?(flags=elim_flags) id i elimclause indclause gl =
+let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) 
+    id rename i (elim, elimty, bindings) indclause =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in
   let indmv = destMeta (nth_arg i elimclause.templval.rebus) in
   let hypmv =
-    try match list_remove indmv (clenv_independent elimclause) with
+    try match List.remove Int.equal indmv (clenv_independent elimclause) with
       | [a] -> a
       | _ -> failwith ""
     with Failure _ -> errorlabstrm "elimination_clause"
           (str "The type of elimination clause is not well-formed.") in
   let elimclause'  = clenv_fchain ~flags indmv elimclause indclause in
   let hyp = mkVar id in
-  let hyp_typ = pf_type_of gl hyp in
-  let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
+  let hyp_typ = Retyping.get_type_of env sigma hyp in
+  let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in
   let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in
   let new_hyp_typ  = clenv_type elimclause'' in
-  if eq_constr hyp_typ new_hyp_typ then
+  if Term.eq_constr hyp_typ new_hyp_typ then
     errorlabstrm "general_rewrite_in"
       (str "Nothing to rewrite in " ++ pr_id id ++ str".");
-  clenv_refine_in with_evars id elimclause'' gl
-
-let general_elim_in with_evars id =
-  general_elim_clause (elimination_in_clause_scheme with_evars id)
-
-(* Case analysis tactics *)
-
-let general_case_analysis_in_context with_evars (c,lbindc) gl =
-  let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-  let sort = elimination_sort_of_goal gl in
-  let elim =
-    if occur_term c (pf_concl gl) then
-      pf_apply build_case_analysis_scheme gl mind true sort
-    else
-      pf_apply build_case_analysis_scheme_default gl mind sort in
-  general_elim with_evars (c,lbindc)
-    {elimindex = None; elimbody = (elim,NoBindings)} gl
-
-let general_case_analysis with_evars (c,lbindc as cx) =
-  match kind_of_term c with
-    | Var id when lbindc = NoBindings ->
-	tclTHEN (try_intros_until_id_check id)
-	  (general_case_analysis_in_context with_evars cx)
-    | _ ->
-	general_case_analysis_in_context with_evars cx
+  clenv_refine_in with_evars id id sigma elimclause''
+    (fun id -> Proofview.tclUNIT ())
+  end
 
-let simplest_case c = general_case_analysis false (c,NoBindings)
+let general_elim_clause with_evars flags id c e =
+  let elim = match id with
+  | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags
+  | Some id -> elimination_in_clause_scheme with_evars ~flags id
+  in
+  general_elim_clause_gen elim c e
 
 (* Apply a tactic below the products of the conclusion of a lemma *)
 
@@ -868,7 +1327,7 @@ type conjunction_status =
   | DefinedRecord of constant option list
   | NotADefinedRecordUseScheme of constr
 
-let make_projection sigma params cstr sign elim i n c =
+let make_projection env sigma params cstr sign elim i n c u =
   let elim = match elim with
   | NotADefinedRecordUseScheme elim ->
       (* bugs: goes from right to left when i increases! *)
@@ -878,111 +1337,205 @@ let make_projection sigma params cstr sign elim i n c =
       if
 	(* excludes dependent projection types *)
 	noccur_between 1 (n-i-1) t
-	(* excludes flexible projection types *)
+	(* to avoid surprising unifications, excludes flexible
+	projection types or lambda which will be instantiated by Meta/Evar *)
 	&& not (isEvar (fst (whd_betaiota_stack sigma t)))
+	&& not (isRel t && destRel t > n-i)
       then
         let t = lift (i+1-n) t in
-	Some (beta_applist (elim,params@[t;branch]),t)
+	let abselim = beta_applist (elim,params@[t;branch]) in
+	let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in
+	  Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign)
       else
 	None
   | DefinedRecord l ->
       (* goes from left to right when i increases! *)
       match List.nth l i with
       | Some proj ->
-	  let t = Typeops.type_of_constant (Global.env()) proj in
 	  let args = extended_rel_vect 0 sign in
-	  Some (beta_applist (mkConst proj,params),prod_applist t (params@[mkApp (c,args)]))
+	  let proj =
+	    if Environ.is_projection proj env then
+	      mkProj (Projection.make proj false, mkApp (c, args))
+	    else
+	      mkApp (mkConstU (proj,u), Array.append (Array.of_list params)
+		[|mkApp (c, args)|])
+	  in
+	  let app = it_mkLambda_or_LetIn proj sign in
+	  let t = Retyping.get_type_of env sigma app in
+	    Some (app, t)
       | None -> None
-  in Option.map (fun (abselim,elimt) -> 
-    let c = beta_applist (abselim,[mkApp (c,extended_rel_vect 0 sign)]) in
-    (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn elimt sign)) elim
+  in elim
 
-let descend_in_conjunctions tac exit c gl =
+let descend_in_conjunctions avoid tac exit c =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
   try
-    let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+    let t = Retyping.get_type_of env sigma c in
+    let ((ind,u),t) = reduce_to_quantified_ind env sigma t in
     let sign,ccl = decompose_prod_assum t in
     match match_with_tuple ccl with
     | Some (_,_,isrec) ->
-	let n = (mis_constr_nargs ind).(0) in
-	let sort = elimination_sort_of_goal gl in
-	let id = fresh_id [] (id_of_string "H") gl in
-	let IndType (indf,_) = pf_apply find_rectype gl ccl in
-	let params = snd (dest_ind_family indf) in
-	let cstr = (get_constructors (pf_env gl) indf).(0) in
+	let n = (constructors_nrealargs ind).(0) in
+	let sort = Tacticals.New.elimination_sort_of_goal gl in
+	let IndType (indf,_) = find_rectype env sigma ccl in
+	let (_,inst), params = dest_ind_family indf in
+	let cstr = (get_constructors env indf).(0) in
 	let elim =
 	  try DefinedRecord (Recordops.lookup_projections ind)
 	  with Not_found ->
-	    let elim = pf_apply build_case_analysis_scheme gl ind false sort in
-	    NotADefinedRecordUseScheme elim in
-	tclFIRST
-	  (list_tabulate (fun i gl ->
-	    match make_projection (project gl) params cstr sign elim i n c with
-	    | None -> tclFAIL 0 (mt()) gl
+	    let elim = build_case_analysis_scheme env sigma (ind,u) false sort in
+	    NotADefinedRecordUseScheme (snd elim) in
+	Tacticals.New.tclFIRST
+	  (List.init n (fun i ->
+            Proofview.Goal.enter begin fun gl ->
+            let env = Proofview.Goal.env gl in
+            let sigma = Proofview.Goal.sigma gl in
+	    match make_projection env sigma params cstr sign elim i n c u with
+	    | None -> Tacticals.New.tclFAIL 0 (mt())
 	    | Some (p,pt) ->
-	    tclTHENS
-	      (internal_cut id pt)
-	      [refine p; (* Might be ill-typed due to forbidden elimination. *)
-	       tclTHEN (tac (not isrec) (mkVar id)) (thin [id])] gl) n)
-	  gl
+	      Tacticals.New.tclTHENS
+		(assert_before_gen false (NamingAvoid avoid) pt)
+		[Proofview.V82.tactic (refine p);
+		 (* Might be ill-typed due to forbidden elimination. *)
+		 Tacticals.New.onLastHypId (tac (not isrec))]
+           end))
     | None ->
 	raise Exit
   with RefinerError _|UserError _|Exit -> exit ()
+  end
 
 (****************************************************)
 (*            Resolution tactics                    *)
 (****************************************************)
 
-let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 =
+let solve_remaining_apply_goals =
+  Proofview.Goal.nf_enter begin fun gl ->
+  if !apply_solve_class_goals then
+    try 
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let concl = Proofview.Goal.concl gl in
+      if Typeclasses.is_class_type sigma concl then
+        let evd', c' = Typeclasses.resolve_one_typeclass env sigma concl in
+	Tacticals.New.tclTHEN
+          (Proofview.Unsafe.tclEVARS evd')
+          (Proofview.V82.tactic (refine_no_check c'))
+	else Proofview.tclUNIT ()
+    with Not_found -> Proofview.tclUNIT ()
+  else Proofview.tclUNIT ()
+  end
+  
+let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let concl = Proofview.Goal.concl gl in
   let flags =
-    if with_delta then default_unify_flags else default_no_delta_unify_flags in
+    if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
   (* The actual type of the theorem. It will be matched against the
   goal. If this fails, then the head constant will be unfolded step by
   step. *)
-  let concl_nprod = nb_prod (pf_concl gl0) in
-  let rec try_main_apply with_destruct c gl =
-    let thm_ty0 = nf_betaiota (project gl) (pf_type_of gl c) in
+  let concl_nprod = nb_prod concl in
+  let rec try_main_apply with_destruct c =
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+
+    let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in
     let try_apply thm_ty nprod =
-      let n = nb_prod thm_ty - nprod in
-	if n<0 then error "Applied theorem has not enough premisses.";
-	let clause = make_clenv_binding_apply gl (Some n) (c,thm_ty) lbind in
-	Clenvtac.res_pf clause ~with_evars:with_evars ~flags:flags gl
+      try
+        let n = nb_prod thm_ty - nprod in
+        if n<0 then error "Applied theorem has not enough premisses.";
+        let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in
+        Clenvtac.res_pf clause ~with_evars ~flags
+      with UserError _ as exn ->
+        Proofview.tclZERO exn
     in
-      try try_apply thm_ty0 concl_nprod
-      with PretypeError _|RefinerError _|UserError _|Failure _ as exn ->
+    Proofview.tclORELSE
+      (try_apply thm_ty0 concl_nprod)
+      (function (e, info) -> match e with
+        | PretypeError _|RefinerError _|UserError _|Failure _ as exn0 ->
 	let rec try_red_apply thm_ty =
-	  try
+          try 
             (* Try to head-reduce the conclusion of the theorem *)
-            let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in
-              try try_apply red_thm concl_nprod
-              with PretypeError _|RefinerError _|UserError _|Failure _ ->
+            let red_thm = try_red_product env sigma thm_ty in
+            Proofview.tclORELSE
+              (try_apply red_thm concl_nprod)
+              (function (e, info) -> match e with
+              | PretypeError _|RefinerError _|UserError _|Failure _ ->
 		try_red_apply red_thm
-	  with Redelimination ->
+              | exn -> iraise (exn, info))
+          with Redelimination ->
             (* Last chance: if the head is a variable, apply may try
 	       second order unification *)
-	    try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit
-	    with PretypeError _|RefinerError _|UserError _|Failure _|Exit ->
+            let tac =
 	      if with_destruct then
-                descend_in_conjunctions
-                  try_main_apply (fun _ -> Loc.raise loc exn) c gl
+                descend_in_conjunctions []
+                  (fun b id ->
+                    Tacticals.New.tclTHEN
+                      (try_main_apply b (mkVar id))
+                      (Proofview.V82.tactic (thin [id])))
+                  (fun _ ->
+                    let info = Loc.add_loc info loc in
+                    Proofview.tclZERO ~info exn0) c
 	      else
-		Loc.raise loc exn
+                let info = Loc.add_loc info loc in
+		Proofview.tclZERO ~info exn0 in
+            if not (Int.equal concl_nprod 0) then
+              try
+                Proofview.tclORELSE
+                  (try_apply thm_ty 0)
+                  (function (e, info) -> match e with
+                  | PretypeError _|RefinerError _|UserError _|Failure _->
+                    tac
+                  | exn -> iraise (exn, info))
+              with UserError _ | Exit ->
+                tac
+            else
+              tac
 	in try_red_apply thm_ty0
+      | exn -> iraise (exn, info))
+    end
   in
-  try_main_apply with_destruct c gl0
+    Tacticals.New.tclTHENLIST [
+      try_main_apply with_destruct c;
+      solve_remaining_apply_goals;
+      apply_clear_request clear_flag (use_clear_hyp_by_default ()) c
+    ]
+  end
 
 let rec apply_with_bindings_gen b e = function
-  | [] -> tclIDTAC
-  | [cb] -> general_apply b b e cb
-  | cb::cbl ->
-      tclTHENLAST (general_apply b b e cb) (apply_with_bindings_gen b e cbl)
+  | [] -> Proofview.tclUNIT ()
+  | [k,cb] -> general_apply b b e k cb
+  | (k,cb)::cbl ->
+      Tacticals.New.tclTHENLAST
+        (general_apply b b e k cb)
+        (apply_with_bindings_gen b e cbl)
+
+let apply_with_delayed_bindings_gen b e l = 
+  let one k (loc, f) =
+    Proofview.Goal.enter begin fun gl ->
+      let sigma = Proofview.Goal.sigma gl in
+      let env = Proofview.Goal.env gl in
+      let sigma, cb = f env sigma in
+	Tacticals.New.tclWITHHOLES e
+          (general_apply b b e k) sigma (loc,cb)
+    end
+  in
+  let rec aux = function
+    | [] -> Proofview.tclUNIT ()
+    | [k,f] -> one k f
+    | (k,f)::cbl ->
+      Tacticals.New.tclTHENLAST
+        (one k f) (aux cbl)
+  in aux l
 
-let apply_with_bindings cb = apply_with_bindings_gen false false [dloc,cb]
+let apply_with_bindings cb = apply_with_bindings_gen false false [None,(dloc,cb)]
 
-let eapply_with_bindings cb = apply_with_bindings_gen false true [dloc,cb]
+let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(dloc,cb)]
 
-let apply c = apply_with_bindings_gen false false [dloc,(c,NoBindings)]
+let apply c = apply_with_bindings_gen false false [None,(dloc,(c,NoBindings))]
 
-let eapply c = apply_with_bindings_gen false true [dloc,(c,NoBindings)]
+let eapply c = apply_with_bindings_gen false true [None,(dloc,(c,NoBindings))]
 
 let apply_list = function
   | c::l -> apply_with_bindings (c,ImplicitBindings l)
@@ -1001,41 +1554,76 @@ let apply_list = function
 let find_matching_clause unifier clause =
   let rec find clause =
     try unifier clause
-    with exn when catchable_exception exn ->
+    with e when catchable_exception e ->
     try find (clenv_push_prod clause)
     with NotExtensibleClause -> failwith "Cannot apply"
   in find clause
 
 let progress_with_clause flags innerclause clause =
   let ordered_metas = List.rev (clenv_independent clause) in
-  if ordered_metas = [] then error "Statement without assumptions.";
+  if List.is_empty ordered_metas then error "Statement without assumptions.";
   let f mv =
-    find_matching_clause (clenv_fchain mv ~flags clause) innerclause in
-  try list_try_find f ordered_metas
-  with Failure _ -> error "Unable to unify."
+    try Some (find_matching_clause (clenv_fchain mv ~flags clause) innerclause)
+    with Failure _ -> None
+  in
+  try List.find_map f ordered_metas
+  with Not_found -> error "Unable to unify."
 
-let apply_in_once_main flags innerclause (d,lbind) gl =
-  let thm = nf_betaiota gl.sigma (pf_type_of gl d) in
+let apply_in_once_main flags innerclause env sigma (d,lbind) =
+  let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in
   let rec aux clause =
     try progress_with_clause flags innerclause clause
-    with err when Errors.noncritical err ->
+    with e when Errors.noncritical e ->
+    let e = Errors.push e in
     try aux (clenv_push_prod clause)
-    with NotExtensibleClause -> raise err in
-  aux (make_clenv_binding gl (d,thm) lbind)
-
-let apply_in_once sidecond_first with_delta with_destruct with_evars id
-  (loc,(d,lbind)) gl0 =
-  let flags = if with_delta then elim_flags else elim_no_delta_flags in
-  let t' = pf_get_hyp_typ gl0 id in
-  let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in
-  let rec aux with_destruct c gl =
+    with NotExtensibleClause -> iraise e
+  in
+  aux (make_clenv_binding env sigma (d,thm) lbind)
+
+let apply_in_once sidecond_first with_delta with_destruct with_evars naming
+    id (clear_flag,(loc,(d,lbind))) tac =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let flags =
+    if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
+  let t' = Tacmach.New.pf_get_hyp_typ id gl in
+  let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in
+  let targetid = find_name true (Anonymous,None,t') naming gl in
+  let rec aux idstoclear with_destruct c =
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
     try
-      let clause = apply_in_once_main flags innerclause (c,lbind) gl in
-      clenv_refine_in ~sidecond_first with_evars id clause gl
-    with exn when with_destruct ->
-      descend_in_conjunctions aux (fun _ -> raise exn) c gl
+      let clause = apply_in_once_main flags innerclause env sigma (c,lbind) in
+      clenv_refine_in ~sidecond_first with_evars targetid id sigma clause
+        (fun id ->
+          Tacticals.New.tclTHENLIST [
+            apply_clear_request clear_flag false c;
+            Proofview.V82.tactic (thin idstoclear);
+            tac id
+          ])
+    with e when with_destruct && Errors.noncritical e ->
+      let e = Errors.push e in
+        (descend_in_conjunctions [targetid]
+           (fun b id -> aux (id::idstoclear) b (mkVar id))
+           (fun _ -> iraise e) c)
+    end
   in
-  aux with_destruct d gl0
+  aux [] with_destruct d
+  end
+
+let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming
+    id (clear_flag,(loc,f)) tac =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let sigma, c = f env sigma in
+    Tacticals.New.tclWITHHOLES with_evars 
+      (apply_in_once sidecond_first with_delta with_destruct with_evars
+         naming id (clear_flag,(loc,c)))
+      sigma tac
+  end
 
 (* A useful resolution tactic which, if c:A->B, transforms |- C into
    |- B -> C and |- A
@@ -1054,26 +1642,45 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars id
   end.
 *)
 
-let cut_and_apply c gl =
-  let goal_constr = pf_concl gl in
-    match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
+let cut_and_apply c =
+  Proofview.Goal.nf_enter begin fun gl ->
+    match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_type_of gl c)) with
       | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
-	  tclTHENLAST
-	    (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())])
-	    (apply_term c [mkMeta (new_meta())]) gl
+        let concl = Proofview.Goal.concl gl in
+        let env = Tacmach.New.pf_env gl in
+        Proofview.Refine.refine begin fun sigma ->
+          let typ = mkProd (Anonymous, c2, concl) in
+          let (sigma, f) = Evarutil.new_evar env sigma typ in
+          let (sigma, x) = Evarutil.new_evar env sigma c1 in
+          let ans = mkApp (f, [|mkApp (c, [|x|])|]) in
+          (sigma, ans)
+        end
       | _ -> error "lapply needs a non-dependent product."
+  end
 
 (********************************************************************)
 (*               Exact tactics                                      *)
 (********************************************************************)
 
-let exact_check c gl =
-  let concl = (pf_concl gl) in
-  let ct = pf_type_of gl c in
-  if pf_conv_x_leq gl ct concl then
-    refine_no_check c gl
-  else
-    error "Not an exact proof."
+(* let convert_leqkey = Profile.declare_profile "convert_leq";; *)
+(* let convert_leq = Profile.profile3 convert_leqkey convert_leq *)
+
+(* let refine_no_checkkey = Profile.declare_profile "refine_no_check";; *)
+(* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *)
+
+let new_exact_no_check c =
+  Proofview.Refine.refine ~unsafe:true (fun h -> (h, c))
+
+let exact_check c =
+  Proofview.Goal.enter begin fun gl ->
+  (** We do not need to normalize the goal because we just check convertibility *)
+  let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let sigma, ct = Typing.e_type_of env sigma c in
+    Proofview.Unsafe.tclEVARS sigma <*>
+      Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c)
+  end
 
 let exact_no_check = refine_no_check
 
@@ -1083,23 +1690,35 @@ let vm_cast_no_check c gl =
 
 
 let exact_proof c gl =
-  (* on experimente la synthese d'ise dans exact *)
-  let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
-  in refine_no_check c gl
-
-let (assumption : tactic) = fun gl ->
-  let concl =  pf_concl gl in
-  let hyps = pf_hyps gl in
-  let rec arec only_eq = function
-    | [] ->
-        if only_eq then arec false hyps else error "No such assumption."
-    | (id,c,t)::rest ->
-	if (only_eq & eq_constr t concl)
-          or (not only_eq & pf_conv_x_leq gl t concl)
-        then refine_no_check (mkVar id) gl
-	else arec only_eq rest
+  let c,ctx = Constrintern.interp_casted_constr (pf_env gl) (project gl) c (pf_concl gl)
+  in tclTHEN (tclEVARUNIVCONTEXT ctx) (refine_no_check c) gl
+
+let assumption =
+  let rec arec gl only_eq = function
+  | [] ->
+    if only_eq then
+      let hyps = Proofview.Goal.hyps gl in
+      arec gl false hyps
+    else Tacticals.New.tclZEROMSG (str "No such assumption.")
+  | (id, c, t)::rest ->
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let (sigma, is_same_type) =
+      if only_eq then (sigma, Constr.equal t concl)
+      else
+        let env = Proofview.Goal.env gl in
+        infer_conv env sigma t concl
+    in
+    if is_same_type then
+      (Proofview.Unsafe.tclEVARS sigma) <*>
+	Proofview.Refine.refine ~unsafe:true (fun h -> (h, mkVar id))
+    else arec gl only_eq rest
+  in
+  let assumption_tac gl =
+    let hyps = Proofview.Goal.hyps gl in
+    arec gl true hyps
   in
-  arec true hyps
+  Proofview.Goal.nf_enter assumption_tac
 
 (*****************************************************************)
 (*          Modification of a local context                      *)
@@ -1111,52 +1730,111 @@ let (assumption : tactic) = fun gl ->
  * goal. *)
 
 let clear ids = (* avant seul dyn_clear n'echouait pas en [] *)
-  if ids=[] then tclIDTAC else thin ids
+  if List.is_empty ids then tclIDTAC else thin ids
+
+let on_the_bodies = function
+| [] -> assert false
+| [id] -> str " depends on the body of " ++ pr_id id
+| l -> str " depends on the bodies of " ++ pr_sequence pr_id l
+
+let check_is_type env ty msg =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let evdref = ref sigma in
+  try
+    let _ = Typing.sort_of env evdref ty in
+    Proofview.Unsafe.tclEVARS !evdref
+  with e when Errors.noncritical e ->
+    msg e
 
-let clear_body = thin_body
+let check_decl env (_, c, ty) msg =
+  Proofview.tclEVARMAP >>= fun sigma ->
+  let evdref = ref sigma in
+  try
+    let _ = Typing.sort_of env evdref ty in
+    let _ = match c with
+    | None -> ()
+    | Some c -> Typing.check env evdref c ty
+    in
+    Proofview.Unsafe.tclEVARS !evdref
+  with e when Errors.noncritical e ->
+    msg e
+
+let clear_body ids =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in
+    let ctx = named_context env in
+    let map (id, body, t as decl) = match body with
+    | None ->
+      let () = if List.mem_f Id.equal id ids then
+        errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition")
+      in
+      decl
+    | Some _ ->
+      if List.mem_f Id.equal id ids then (id, None, t) else decl
+    in
+    let ctx = List.map map ctx in
+    let base_env = reset_context env in
+    let env = push_named_context ctx base_env in
+    let check_hyps =
+      let check env (id, _, _ as decl) =
+        let msg _ = Tacticals.New.tclZEROMSG
+          (str "Hypothesis " ++ pr_id id ++ on_the_bodies ids)
+        in
+        check_decl env decl msg <*> Proofview.tclUNIT (push_named decl env)
+      in
+      let checks = Proofview.Monad.List.fold_left check base_env (List.rev ctx) in
+      Proofview.tclIGNORE checks
+    in
+    let check_concl =
+      let msg _ = Tacticals.New.tclZEROMSG
+        (str "Conclusion" ++ on_the_bodies ids)
+      in
+      check_is_type env concl msg
+    in
+    check_hyps <*> check_concl <*>
+    Proofview.Refine.refine ~unsafe:true begin fun sigma ->
+      Evarutil.new_evar env sigma concl
+    end
+  end
 
 let clear_wildcards ids =
-  tclMAP (fun (loc,id) gl ->
+  Proofview.V82.tactic (tclMAP (fun (loc,id) gl ->
     try with_check (Tacmach.thin_no_check [id]) gl
     with ClearDependencyError (id,err) ->
       (* Intercept standard [thin] error message *)
       Loc.raise loc
-        (error_clear_dependency (pf_env gl) (id_of_string "_") err))
-    ids
+        (error_clear_dependency (pf_env gl) (project gl) (Id.of_string "_") err))
+    ids)
 
 (*   Takes a list of booleans, and introduces all the variables
  *  quantified in the goal which are associated with a value
  *  true  in the boolean list. *)
 
 let rec intros_clearing = function
-  | []          -> tclIDTAC
-  | (false::tl) -> tclTHEN intro (intros_clearing tl)
+  | []          -> Proofview.tclUNIT ()
+  | (false::tl) -> Tacticals.New.tclTHEN intro (intros_clearing tl)
   | (true::tl)  ->
-      tclTHENLIST
-        [ intro; onLastHypId (fun id -> clear [id]); intros_clearing tl]
+      Tacticals.New.tclTHENLIST
+        [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl]
 
 (* Modifying/Adding an hypothesis  *)
 
-let specialize mopt (c,lbind) g =
+let specialize (c,lbind) g =
   let tac, term =
-    if lbind = NoBindings then 
+    if lbind == NoBindings then
       let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in
 	tclEVARS evd, nf_evar evd c
     else
-      let clause = make_clenv_binding g (c,pf_type_of g c) lbind in
-      let flags = { default_unify_flags with resolve_evars = true } in
+      let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in
+      let flags = { (default_unify_flags ()) with resolve_evars = true } in
       let clause = clenv_unify_meta_types ~flags clause in
-      let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in
-      let nargs = List.length tstack in
-      let tstack = match mopt with
-	| Some m ->
-	    if m < nargs then list_firstn m tstack else tstack
-	| None ->
-	    let rec chk = function
-	      | [] -> []
-	      | t::l -> if occur_meta t then [] else t :: chk l
-	    in chk tstack
+      let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in
+      let rec chk = function
+      | [] -> []
+      | t::l -> if occur_meta t then [] else t :: chk l
       in
+      let tstack = chk tstack in
       let term = applist(thd,List.map (nf_evar clause.evd) tstack) in
       if occur_meta term then
 	errorlabstrm "" (str "Cannot infer an instance for " ++
@@ -1165,55 +1843,69 @@ let specialize mopt (c,lbind) g =
        tclEVARS clause.evd, term
   in
   match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
-       | Var id when List.mem id (pf_ids_of_hyps g) ->
+       | Var id when Id.List.mem id (pf_ids_of_hyps g) ->
 	   tclTHEN tac
 	     (tclTHENFIRST
-	       (fun g -> internal_cut_replace id (pf_type_of g term) g)
+	       (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_type_of g term)) g)
 	       (exact_no_check term)) g
        | _ -> tclTHEN tac
 	   (tclTHENLAST
-              (fun g -> cut (pf_type_of g term) g)
+              (fun g -> Proofview.V82.of_tactic (cut (pf_type_of g term)) g)
               (exact_no_check term)) g
 
 (* Keeping only a few hypotheses *)
 
-let keep hyps gl =
-  let env = Global.env() in
-  let ccl = pf_concl gl in
+let keep hyps =
+  Proofview.Goal.nf_enter begin fun gl ->
+  Proofview.tclENV >>= fun env ->
+  let ccl = Proofview.Goal.concl gl in
   let cl,_ =
     fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
-      if List.mem hyp hyps
-	or List.exists (occur_var_in_decl env hyp) keep
-	or occur_var env hyp ccl
+      if Id.List.mem hyp hyps
+        || List.exists (occur_var_in_decl env hyp) keep
+	|| occur_var env hyp ccl
       then (clear,decl::keep)
       else (hyp::clear,keep))
-      ~init:([],[]) (pf_env gl)
-  in thin cl gl
+      ~init:([],[]) (Proofview.Goal.env gl)
+  in
+  Proofview.V82.tactic (fun gl -> thin cl gl)
+  end
 
 (************************)
 (* Introduction tactics *)
 (************************)
 
 let check_number_of_constructors expctdnumopt i nconstr =
-  if i=0 then error "The constructors are numbered starting from 1.";
+  if Int.equal i 0 then error "The constructors are numbered starting from 1.";
   begin match expctdnumopt with
-    | Some n when n <> nconstr ->
+    | Some n when not (Int.equal n nconstr) ->
 	error ("Not an inductive goal with "^
-	       string_of_int n^plural n " constructor"^".")
+	       string_of_int n ^ String.plural n " constructor"^".")
     | _ -> ()
   end;
   if i > nconstr then error "Not enough constructors."
 
-let constructor_tac with_evars expctdnumopt i lbind gl =
-  let cl = pf_concl gl in
-  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in
-  let nconstr =
-    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
-  check_number_of_constructors expctdnumopt i nconstr;
-  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
-  let apply_tac = general_apply true false with_evars (dloc,(cons,lbind)) in
-  (tclTHENLIST
-     [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl
+let constructor_tac with_evars expctdnumopt i lbind =
+  Proofview.Goal.enter begin fun gl ->
+    let cl = Tacmach.New.pf_nf_concl gl in
+    let reduce_to_quantified_ind =
+      Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
+    in
+    let (mind,redcl) = reduce_to_quantified_ind cl in
+    let nconstr =
+      Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
+      check_number_of_constructors expctdnumopt i nconstr;
+
+      let sigma, cons = Evd.fresh_constructor_instance
+	(Proofview.Goal.env gl) (Proofview.Goal.sigma gl) (fst mind, i) in
+      let cons = mkConstructU cons in
+	
+      let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in
+	(Tacticals.New.tclTHENLIST
+           [Proofview.Unsafe.tclEVARS sigma; 
+	    convert_concl_no_check redcl DEFAULTcast;
+	    intros; apply_tac])
+  end
 
 let one_constructor i lbind = constructor_tac false None i lbind
 
@@ -1222,21 +1914,30 @@ let one_constructor i lbind = constructor_tac false None i lbind
    Should be generalize in Constructor (Fun c : I -> tactic)
  *)
 
-let any_constructor with_evars tacopt gl =
-  let t = match tacopt with None -> tclIDTAC | Some t -> t in
-  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
-  let nconstr =
-    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
-  if nconstr = 0 then error "The type has no constructors.";
-  tclFIRST
-    (List.map
-      (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t)
-      (interval 1 nconstr)) gl
+let rec tclANY tac = function
+| [] -> Tacticals.New.tclZEROMSG (str "No applicable tactic.")
+| arg :: l ->
+  Tacticals.New.tclORD (tac arg) (fun () -> tclANY tac l)
+
+let any_constructor with_evars tacopt =
+  let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in
+  let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in
+  Proofview.Goal.enter begin fun gl ->
+    let cl = Tacmach.New.pf_nf_concl gl in
+    let reduce_to_quantified_ind =
+      Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl
+    in
+    let mind = fst (reduce_to_quantified_ind cl) in
+    let nconstr =
+      Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in
+    if Int.equal nconstr 0 then error "The type has no constructors.";
+    tclANY tac (List.interval 1 nconstr)
+ end
 
 let left_with_bindings  with_evars = constructor_tac with_evars (Some 2) 1
 let right_with_bindings with_evars = constructor_tac with_evars (Some 2) 2
 let split_with_bindings with_evars l =
-  tclMAP (constructor_tac with_evars (Some 1) 1) l
+  Tacticals.New.tclMAP (constructor_tac with_evars (Some 1) 1) l
 
 let left           = left_with_bindings false
 let simplest_left  = left NoBindings
@@ -1252,246 +1953,484 @@ let simplest_split = split NoBindings
 (*****************************)
 
 (* Rewriting function for rewriting one hypothesis at the time *)
-let forward_general_multi_rewrite =
-  ref (fun _ -> failwith "general_multi_rewrite undefined")
+let (forward_general_rewrite_clause, general_rewrite_clause) = Hook.make ()
 
 (* Rewriting function for substitution (x=t) everywhere at the same time *)
-let forward_subst_one =
-  ref (fun _ -> failwith "subst_one undefined")
-
-let register_general_multi_rewrite f =
-  forward_general_multi_rewrite := f
-
-let register_subst_one f =
-  forward_subst_one := f
+let (forward_subst_one, subst_one) = Hook.make ()
 
-let error_unexpected_extra_pattern loc nb pat =
+let error_unexpected_extra_pattern loc bound pat =
+  let _,nb = Option.get bound in
   let s1,s2,s3 = match pat with
-  | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
+  | IntroNaming (IntroIdentifier _) ->
+      "name", (String.plural nb " introduction pattern"), "no"
   | _ -> "introduction pattern", "", "none" in
   user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++
-    (if nb = 0 then (str s3 ++ str s2) else
+    (if Int.equal nb 0 then (str s3 ++ str s2) else
       (str "at most " ++ int nb ++ str s2)) ++ spc () ++
-       str (if nb = 1 then "was" else "were") ++
+       str (if Int.equal nb 1 then "was" else "were") ++
       strbrk " expected in the branch).")
 
-let intro_or_and_pattern loc b ll l' tac id gl =
-    let c = mkVar id in
-    let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
-    let nv = mis_constr_nargs ind in
-    let bracketed = b or not (l'=[]) in
-    let rec adjust_names_length nb n = function
-      | [] when n = 0 or not bracketed -> []
-      | [] -> (dloc,IntroAnonymous) :: adjust_names_length nb (n-1) []
-      | (loc',pat) :: _ as l when n = 0 ->
-	  if bracketed then error_unexpected_extra_pattern loc' nb pat;
-	  l
-      | ip :: l -> ip :: adjust_names_length nb (n-1) l in
-    let ll = fix_empty_or_and_pattern (Array.length nv) ll in
-    check_or_and_pattern_size loc ll (Array.length nv);
-    tclTHENLASTn
-      (tclTHEN (simplest_case c) (clear [id]))
-      (array_map2 (fun n l -> tac ((adjust_names_length n n l)@l'))
-	nv (Array.of_list ll))
-      gl
-
-let rewrite_hyp l2r id gl =
+let intro_decomp_eq_function = ref (fun _ -> failwith "Not implemented")
+
+let declare_intro_decomp_eq f = intro_decomp_eq_function := f
+
+let my_find_eq_data_decompose gl t =
+  try find_eq_data_decompose gl t
+  with e when is_anomaly e
+    (* Hack in case equality is not yet defined... one day, maybe,
+       known equalities will be dynamically registered *)
+      -> raise Constr_matching.PatternMatchingFailure
+
+let intro_decomp_eq loc l thin tac id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let c = mkVar id in
+  let t = Tacmach.New.pf_type_of gl c in
+  let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let eq,u,eq_args = my_find_eq_data_decompose gl t in
+  !intro_decomp_eq_function
+    (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l)
+    (eq,t,eq_args) (c, t)
+  end
+
+let intro_or_and_pattern loc bracketed ll thin tac id =
+  Proofview.Goal.enter begin fun gl ->
+  let c = mkVar id in
+  let t = Tacmach.New.pf_type_of gl c in
+  let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in
+  let nv = constructors_nrealargs ind in
+  let ll = fix_empty_or_and_pattern (Array.length nv) ll in
+  check_or_and_pattern_size loc ll (Array.length nv);
+  Tacticals.New.tclTHENLASTn
+    (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id])))
+    (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l)
+       nv (Array.of_list ll))
+  end
+
+let rewrite_hyp assert_style l2r id =
   let rew_on l2r =
-    !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) in
+    Hook.get forward_general_rewrite_clause l2r false (mkVar id,NoBindings) in
   let subst_on l2r x rhs =
-    !forward_subst_one true x (id,rhs,l2r) in
-  let clear_var_and_eq c =
-    tclTRY (tclTHEN (clear [id]) (tclTRY (clear [destVar c]))) in
-  let t = pf_whd_betadeltaiota gl (pf_type_of gl (mkVar id)) in
-  (* TODO: detect setoid equality? better detect the different equalities *)
-  match match_with_equality_type t with
-  | Some (hdcncl,[_;lhs;rhs]) ->
-      if l2r & isVar lhs & not (occur_var (pf_env gl) (destVar lhs) rhs) then
-	subst_on l2r (destVar lhs) rhs gl
-      else if not l2r & isVar rhs & not (occur_var (pf_env gl) (destVar rhs) lhs) then
-	subst_on l2r (destVar rhs) lhs gl
-      else
-	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
-  | Some (hdcncl,[c]) ->
-      let l2r = not l2r in (* equality of the form eq_true *)
-      if isVar c then
-	tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq c) gl
-      else
-	tclTHEN (rew_on l2r onConcl) (tclTRY (clear [id])) gl
-  | _ ->
-      error "Cannot find a known equation."
+    Hook.get forward_subst_one true x (id,rhs,l2r) in
+  let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let type_of = Tacmach.New.pf_type_of gl in
+    let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in
+    let t = whd_betadeltaiota (type_of (mkVar id)) in
+    match match_with_equality_type t with
+    | Some (hdcncl,[_;lhs;rhs]) ->
+        if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then
+          subst_on l2r (destVar lhs) rhs
+        else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then
+          subst_on l2r (destVar rhs) lhs
+        else
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+    | Some (hdcncl,[c]) ->
+        let l2r = not l2r in (* equality of the form eq_true *)
+        if isVar c then
+          Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) 
+	    (Proofview.V82.tactic (clear_var_and_eq c))
+        else
+          Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+    | _ ->
+        Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id]))
+  end
+
+let rec prepare_naming loc = function
+  | IntroIdentifier id -> NamingMustBe (loc,id)
+  | IntroAnonymous -> NamingAvoid []
+  | IntroFresh id -> NamingBasedOn (id,[])
 
 let rec explicit_intro_names = function
-| (_, IntroIdentifier id) :: l ->
-    id :: explicit_intro_names l
-| (_, (IntroWildcard | IntroAnonymous | IntroFresh _
-      | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l
-| (_, IntroOrAndPattern ll) :: l' ->
+| (_, IntroForthcoming _) :: l -> explicit_intro_names l
+| (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l
+| (_, IntroAction (IntroOrAndPattern ll)) :: l' ->
     List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
-| [] ->
-    []
+| (_, IntroAction (IntroInjection l)) :: l' ->
+    explicit_intro_names (l@l')
+| (_, IntroAction (IntroApplyOn (c,pat))) :: l' ->
+    explicit_intro_names (pat::l')
+| (_, (IntroNaming (IntroAnonymous | IntroFresh _)
+     | IntroAction (IntroWildcard | IntroRewrite _))) :: l ->
+     explicit_intro_names l
+| [] -> []
 
-let wild_id = id_of_string "_tmp"
+let wild_id = Id.of_string "_tmp"
 
 let rec list_mem_assoc_right id = function
   | [] -> false
-  | (x,id')::l -> id = id' || list_mem_assoc_right id l
+  | (x,id')::l -> Id.equal id id' || list_mem_assoc_right id l
 
 let check_thin_clash_then id thin avoid tac =
   if list_mem_assoc_right id thin then
     let newid = next_ident_away (add_suffix id "'") avoid in
     let thin =
-      List.map (on_snd (fun id' -> if id = id' then newid else id')) thin in
-    tclTHEN (rename_hyp [id,newid]) (tac thin)
+      List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in
+    Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin)
   else
     tac thin
 
+let make_tmp_naming avoid l = function
+  (* In theory, we could use a tmp id like "wild_id" for all actions
+     but we prefer to avoid it to avoid this kind of "ugly" names *)
+  (* Alternatively, we could have called check_thin_clash_then on
+     IntroAnonymous, but at the cost of a "renaming"; Note that in the
+     case of IntroFresh, we should use check_thin_clash_then anyway to
+     prevent the case of an IntroFresh precisely using the wild_id *)
+  | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l)
+  | _ -> NamingAvoid(avoid@explicit_intro_names l)
+
+let fit_bound n = function
+  | None -> true
+  | Some (use_bound,n') -> not use_bound || n = n'
+
+let exceed_bound n = function
+  | None -> false
+  | Some (use_bound,n') -> use_bound && n >= n'
+
   (* We delay thinning until the completion of the whole intros tactic
      to ensure that dependent hypotheses are cleared in the right
      dependency order (see bug #1000); we use fresh names, not used in
      the tactic, for the hyps to clear *)
-let rec intros_patterns b avoid ids thin destopt tac = function
-  | (loc, IntroWildcard) :: l ->
-      intro_then_gen loc (IntroBasedOn(wild_id,avoid@explicit_intro_names l))
-	no_move true false
-        (fun id -> intros_patterns b avoid ids ((loc,id)::thin) destopt tac l)
-  | (loc, IntroIdentifier id) :: l ->
+let rec intro_patterns_core b avoid ids thin destopt bound n tac = function
+  | [] when fit_bound n bound ->
+      tac ids thin
+  | [] ->
+      (* Behave as IntroAnonymous *)
+      intro_patterns_core b avoid ids thin destopt bound n tac
+        [dloc,IntroNaming IntroAnonymous]
+  | (loc,pat) :: l ->
+  if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else
+  match pat with
+  | IntroForthcoming onlydeps ->
+      intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l))
+	  destopt onlydeps n bound
+        (fun ids -> intro_patterns_core b avoid ids thin destopt bound
+          (n+List.length ids) tac l)
+  | IntroAction pat ->
+      intro_then_gen (make_tmp_naming avoid l pat)
+	MoveLast true false
+        (intro_pattern_action loc (b || not (List.is_empty l)) false pat thin
+          (fun thin bound' -> intro_patterns_core b avoid ids thin destopt bound' 0
+            (fun ids thin ->
+              intro_patterns_core b avoid ids thin destopt bound (n+1) tac l)))
+  | IntroNaming pat ->
+      intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l
+
+and intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l =
+  match pat with
+  | IntroIdentifier id ->
       check_thin_clash_then id thin avoid (fun thin ->
-        intro_then_gen loc (IntroMustBe id) destopt true false
-          (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l))
-  | (loc, IntroAnonymous) :: l ->
-      intro_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+        intro_then_gen (NamingMustBe (loc,id)) destopt true false
+          (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l))
+  | IntroAnonymous ->
+      intro_then_gen (NamingAvoid (avoid@explicit_intro_names l))
 	destopt true false
-        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
-  | (loc, IntroFresh id) :: l ->
+        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l)
+  | IntroFresh id ->
       (* todo: avoid thinned names to interfere with generation of fresh name *)
-      intro_then_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
+      intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l))
 	destopt true false
-        (fun id -> intros_patterns b avoid (id::ids) thin destopt tac l)
-  | (loc, IntroForthcoming onlydeps) :: l ->
-      intro_forthcoming_then_gen loc (IntroAvoid (avoid@explicit_intro_names l))
-	  destopt onlydeps
-        (fun ids -> intros_patterns b avoid ids thin destopt tac l)
-  | (loc, IntroOrAndPattern ll) :: l' ->
-      intro_then_force
-	(intro_or_and_pattern loc b ll l'
-	   (intros_patterns b avoid ids thin destopt tac))
-  | (loc, IntroRewrite l2r) :: l ->
-      intro_then_gen loc (IntroAvoid(avoid@explicit_intro_names l))
-	no_move true false
-        (fun id ->
-	  tclTHENLAST (* Skip the side conditions of the rewriting step *)
-	    (rewrite_hyp l2r id)
-	    (intros_patterns b avoid ids thin destopt tac l))
-  | [] -> tac ids thin
+        (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l)
+
+and intro_pattern_action loc b style pat thin tac id = match pat with
+  | IntroWildcard ->
+      tac ((loc,id)::thin) None []
+  | IntroOrAndPattern ll ->
+      intro_or_and_pattern loc b ll thin tac id
+  | IntroInjection l' ->
+      intro_decomp_eq loc l' thin tac id
+  | IntroRewrite l2r ->
+      Tacticals.New.tclTHENLAST
+        (* Skip the side conditions of the rewriting step *)
+	(rewrite_hyp style l2r id)
+        (tac thin None [])
+  | IntroApplyOn (f,(loc,pat)) ->
+      let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) pat in
+      Proofview.Goal.enter begin fun gl ->
+        let sigma = Proofview.Goal.sigma gl in
+        let env = Proofview.Goal.env gl in
+        let sigma,c = f env sigma in
+        Proofview.Unsafe.tclEVARS sigma <*>
+          (Tacticals.New.tclTHENFIRST
+             (* Skip the side conditions of the apply *)
+             (apply_in_once false true true true naming id
+                (None,(sigma,(c,NoBindings))) tac_ipat))
+	  (tac thin None [])
+      end
+
+and prepare_intros_loc loc dft = function
+  | IntroNaming ipat ->
+      prepare_naming loc ipat,
+      (fun _ -> Proofview.tclUNIT ())
+  | IntroAction ipat ->
+      prepare_naming loc dft,
+      (let tac thin bound =
+        intro_patterns_core true [] [] thin MoveLast bound 0
+          (fun _ l -> clear_wildcards l) in
+      fun id -> intro_pattern_action loc true true ipat [] tac id)
+  | IntroForthcoming _ -> user_err_loc
+      (loc,"",str "Introduction pattern for one hypothesis expected.")
+
+let intro_patterns_bound_to n destopt =
+  intro_patterns_core true [] [] [] destopt
+    (Some (true,n)) 0 (fun _ -> clear_wildcards)
+
+(* The following boolean governs what "intros []" do on examples such
+   as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]";
+   if false, it behaves as "intro H; case H; clear H" for fresh H.
+   Kept as false for compatibility.
+ *)
+let bracketing_last_or_and_intro_pattern = false 
+
+let intro_patterns_to destopt =
+  intro_patterns_core bracketing_last_or_and_intro_pattern
+    [] [] [] destopt None 0 (fun _ l -> clear_wildcards l)
 
-let intros_pattern destopt =
-  intros_patterns false [] [] [] destopt (fun _ -> clear_wildcards)
+let intro_pattern_to destopt pat =
+  intro_patterns_to destopt [dloc,pat]
 
-let intro_pattern destopt pat =
-  intros_pattern destopt [dloc,pat]
+let intro_patterns = intro_patterns_to MoveLast
 
-let intro_patterns = function
-  | [] -> tclREPEAT intro
-  | l  -> intros_pattern no_move l
+(* Implements "intros" *)
+let intros_patterns = function
+  | [] -> intros
+  | l -> intro_patterns_to MoveLast l
 
 (**************************)
-(*   Other cut tactics    *)
+(*   Forward reasoning    *)
 (**************************)
 
-let make_id s = fresh_id [] (default_id_of_sort s)
-
-let prepare_intros s ipat gl = match ipat with
-  | None -> make_id s gl, tclIDTAC
-  | Some (loc,ipat) -> match ipat with
-  | IntroIdentifier id -> id, tclIDTAC
-  | IntroAnonymous -> make_id s gl, tclIDTAC
-  | IntroFresh id -> fresh_id [] id gl, tclIDTAC
-  | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id]
-  | IntroRewrite l2r ->
-      let id = make_id s gl in
-      id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
-  | IntroOrAndPattern ll -> make_id s gl,
-      onLastHypId
-	(intro_or_and_pattern loc true ll []
-	  (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards)))
-  | IntroForthcoming _ -> user_err_loc
-      (loc,"",str "Introduction pattern for one hypothesis expected")
+let prepare_intros dft = function
+  | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ())
+  | Some (loc,ipat) -> prepare_intros_loc loc dft ipat
 
 let ipat_of_name = function
   | Anonymous -> None
-  | Name id -> Some (dloc, IntroIdentifier id)
+  | Name id -> Some (dloc, IntroNaming (IntroIdentifier id))
 
-let allow_replace c gl = function (* A rather arbitrary condition... *)
-  | Some (_, IntroIdentifier id) ->
-      let c = fst (decompose_app ((strip_lam_assum c))) in
-      isVar c && destVar c = id
-  | _ ->
-      false
-
-let assert_as first ipat c gl =
-  match kind_of_term (pf_hnf_type_of gl c) with
-  | Sort s ->
-      let id,tac = prepare_intros s ipat gl in
-      let repl = allow_replace c gl ipat in
-      tclTHENS
-	((if first then internal_cut_gen else internal_cut_rev_gen) repl id c)
-	(if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl
-  | _  -> error "Not a proposition or a type."
+ let head_ident c =
+   let c = fst (decompose_app ((strip_lam_assum c))) in
+   if isVar c then Some (destVar c) else None
 
-let assert_tac na = assert_as true (ipat_of_name na)
+let assert_as first ipat c =
+  let naming,tac = prepare_intros IntroAnonymous ipat in
+  let repl = do_replace (head_ident c) naming in
+  if first then assert_before_then_gen repl naming c tac
+  else assert_after_then_gen repl naming c tac
 
 (* apply in as *)
 
-let as_tac id ipat = match ipat with
-  | Some (loc,IntroRewrite l2r) ->
-      !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allHypsAndConcl
-  | Some (loc,IntroOrAndPattern ll) ->
-      intro_or_and_pattern loc true ll []
-        (intros_patterns true [] [] [] no_move (fun _ -> clear_wildcards))
-        id
-  | Some (loc,
-      (IntroIdentifier _ | IntroAnonymous | IntroFresh _ |
-       IntroWildcard | IntroForthcoming _)) ->
-      user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected")
-  | None -> tclIDTAC
-
-let tclMAPLAST tacfun l =
-  List.fold_right (fun x -> tclTHENLAST (tacfun x)) l tclIDTAC
-
-let tclMAPFIRST tacfun l =
-  List.fold_right (fun x -> tclTHENFIRST (tacfun x)) l tclIDTAC
-
-let general_apply_in sidecond_first with_delta with_destruct with_evars 
-    id lemmas ipat =
+let general_apply_in sidecond_first with_delta with_destruct with_evars
+    with_clear id lemmas ipat =
+  let tac (naming,lemma) tac id =
+    apply_in_delayed_once sidecond_first with_delta with_destruct with_evars
+      naming id lemma tac in
+  let naming,ipat_tac = prepare_intros (IntroIdentifier id) ipat in
+  let lemmas_target, last_lemma_target =
+    let last,first = List.sep_last lemmas in
+    List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last)
+  in
+  (* We chain apply_in_once, ending with an intro pattern *)
+  List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id
+
+(*
   if sidecond_first then
     (* Skip the side conditions of the applied lemma *)
-    tclTHENLAST
-      (tclMAPLAST
-	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
-	lemmas)
-      (as_tac id ipat)
-  else 
-    tclTHENFIRST
-      (tclMAPFIRST
-	(apply_in_once sidecond_first with_delta with_destruct with_evars id) 
-	lemmas)
-      (as_tac id ipat)
-
-let apply_in simple with_evars id lemmas ipat =
-  general_apply_in false simple simple with_evars id lemmas ipat
-
-let simple_apply_in id c =
-  general_apply_in false false false false id [dloc,(c,NoBindings)] None
+    Tacticals.New.tclTHENLAST (tclMAPLAST tac lemmas_target) (ipat_tac id)
+  else
+    Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id)
+*)
 
-(**************************)
-(*   Generalize tactics   *)
-(**************************)
+let apply_in simple with_evars clear_flag id lemmas ipat =
+  let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, fun _ sigma -> sigma, l)) lemmas in
+  general_apply_in false simple simple with_evars clear_flag id lemmas ipat
+
+let apply_delayed_in simple with_evars clear_flag id lemmas ipat =
+  general_apply_in false simple simple with_evars clear_flag id lemmas ipat
+
+(*****************************)
+(* Tactics abstracting terms *)
+(*****************************)
+
+(* Implementation without generalisation: abbrev will be lost in hyps in *)
+(* in the extracted proof *)
+
+let tactic_infer_flags with_evar = {
+  Pretyping.use_typeclasses = true;
+  Pretyping.use_unif_heuristics = true;
+  Pretyping.use_hook = Some solve_by_implicit_tactic;
+  Pretyping.fail_evar = not with_evar;
+  Pretyping.expand_evars = true }
+
+let decode_hyp = function
+  | None -> MoveLast
+  | Some id -> MoveAfter id
+
+(* [letin_tac b (... abstract over c ...) gl] transforms
+   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
+   [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
+   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
+*)
+
+let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let t = match ty with Some t -> t | _ -> typ_of env sigma c in
+    let eq_tac gl = match with_eq with
+      | Some (lr,(loc,ido)) ->
+          let heq = match ido with
+            | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl
+            | IntroFresh heq_base -> new_fresh_id [id] heq_base gl
+            | IntroIdentifier id -> id in
+          let eqdata = build_coq_eq_data () in
+          let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
+          let sigma, eq = Evd.fresh_global env sigma eqdata.eq in
+          let sigma, refl = Evd.fresh_global env sigma eqdata.refl in
+          let eq = applist (eq,args) in
+          let refl = applist (refl, [t;mkVar id]) in
+	  let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in
+	  let sigma, _ = Typing.e_type_of env sigma term in
+            sigma, term,
+            Tacticals.New.tclTHEN
+	      (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false)
+	      (clear_body [heq;id])
+      | None ->
+	  (sigma, mkNamedLetIn id c t ccl, Proofview.tclUNIT ()) in
+    let (sigma,newcl,eq_tac) = eq_tac gl in
+    Tacticals.New.tclTHENLIST
+      [ Proofview.Unsafe.tclEVARS sigma;
+	convert_concl_no_check newcl DEFAULTcast;
+        intro_gen (NamingMustBe (dloc,id)) (decode_hyp lastlhyp) true false;
+        Tacticals.New.tclMAP convert_hyp_no_check depdecls;
+        eq_tac ]
+  end
+
+let insert_before decls lasthyp env =
+  match lasthyp with
+  | None -> push_named_context decls env
+  | Some id ->
+  Environ.fold_named_context
+    (fun _ (id',_,_ as d) env ->
+      let env = if Id.equal id id' then push_named_context decls env else env in
+      push_named d env)
+    ~init:(reset_context env) env
+
+(* unsafe *)
+
+let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty =
+  let body = if dep then Some c else None in
+  let t = match ty with Some t -> t | _ -> typ_of env sigma c in
+  match with_eq with
+  | Some (lr,(loc,ido)) ->
+      let heq = match ido with
+      | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env
+      | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env
+      | IntroIdentifier id -> id in
+      let eqdata = build_coq_eq_data () in
+      let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
+      let sigma, eq = Evd.fresh_global env sigma eqdata.eq in
+      let sigma, refl = Evd.fresh_global env sigma eqdata.refl in
+      let eq = applist (eq,args) in
+      let refl = applist (refl, [t;mkVar id]) in
+      let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in
+      let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
+      (sigma,mkNamedLetIn id c t (mkNamedLetIn heq refl eq x))
+  | None ->
+      let newenv = insert_before [id,body,t] lastlhyp env in
+      let (sigma,x) = new_evar newenv sigma ~principal:true ~store ccl in
+      (sigma,mkNamedLetIn id c t x)
+
+let letin_tac with_eq id c ty occs =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let abs = AbstractExact (id,c,ty,occs,true) in
+    let (id,_,depdecls,lastlhyp,ccl,_) = make_abstraction env sigma ccl abs in
+    (* We keep the original term to match *)
+    letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty
+  end
+
+let letin_pat_tac with_eq id c occs =
+  Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let ccl = Proofview.Goal.concl gl in
+    let check t = true in
+    let abs = AbstractPattern (false,check,id,c,occs,false) in
+    let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in
+    let sigma,c = match res with
+    | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c
+    | Some (sigma,c) -> (sigma,c) in
+    Tacticals.New.tclTHEN
+      (Proofview.Unsafe.tclEVARS sigma)
+      (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None)
+  end
+
+(* Tactics "pose proof" (usetac=None) and "assert"/"enough" (otherwise) *)
+let forward b usetac ipat c =
+  match usetac with
+  | None ->
+      Proofview.Goal.enter begin fun gl ->
+      let t = Tacmach.New.pf_type_of gl  c in
+      Tacticals.New.tclTHENFIRST (assert_as true ipat t)
+	(Proofview.V82.tactic (exact_no_check c))
+      end
+  | Some tac ->
+      if b then
+        Tacticals.New.tclTHENFIRST (assert_as b ipat c) tac
+      else
+        Tacticals.New.tclTHENS3PARTS
+          (assert_as b ipat c) [||] tac [|Tacticals.New.tclIDTAC|]
+
+let pose_proof na c = forward true None (ipat_of_name na) c
+let assert_by na t tac = forward true (Some tac) (ipat_of_name na) t
+let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t
+
+(***************************)
+(*  Generalization tactics *)
+(***************************)
+
+(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)]
+   and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)],
+   this generalizes [hyps |- goal] into [hyps |- T] *)
+
+let apply_type hdcty argl gl =
+  refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl
+
+(* Given a context [hyps] with domain [x1..xn], possibly with let-ins,
+   and well-typed in the current goal, [bring_hyps hyps] generalizes
+   [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *)
+
+let bring_hyps hyps =
+  if List.is_empty hyps then Tacticals.New.tclIDTAC
+  else
+    Proofview.Goal.enter begin fun gl ->
+      let env = Proofview.Goal.env gl in
+      let concl = Tacmach.New.pf_nf_concl gl in
+      let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in
+      let args = Array.of_list (instance_from_named_context hyps) in
+      Proofview.Refine.refine begin fun sigma ->
+        let (sigma, ev) = Evarutil.new_evar env sigma newcl in
+        (sigma, (mkApp (ev, args)))
+      end
+    end
+
+let revert hyps = 
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in
+      (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps))
+  end
+
+(* Compute a name for a generalization *)
 
 let generalized_name c t ids cl = function
   | Name id as na ->
-      if List.mem id ids then
-	errorlabstrm "" (pr_id id ++ str " is already used");
+      if Id.List.mem id ids then
+	errorlabstrm "" (pr_id id ++ str " is already used.");
       na
   | Anonymous ->
       match kind_of_term c with
@@ -1505,72 +2444,105 @@ let generalized_name c t ids cl = function
                constante dont on aurait pu prendre directement le nom *)
 	    named_hd (Global.env()) t Anonymous
 
-let generalize_goal gl i ((occs,c,b),na) cl =
-  let t = pf_type_of gl c in
+(* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing
+   [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai]
+   but only those at [occs] in [T] *)
+
+let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) =
   let decls,cl = decompose_prod_n_assum i cl in
   let dummy_prod = it_mkProd_or_LetIn mkProp decls in
-  let newdecls,_ = decompose_prod_n_assum i (subst_term c dummy_prod) in
-  let cl' = subst_closed_term_occ occs c (it_mkProd_or_LetIn cl newdecls) in
-  let na = generalized_name c t (pf_ids_of_hyps gl) cl' na in
-    mkProd_or_LetIn (na,b,t) cl'
+  let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in
+  let cl',evd' = subst_closed_term_occ env evd (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in
+  let na = generalized_name c t ids cl' na in
+    mkProd_or_LetIn (na,b,t) cl', evd'
+
+let generalize_goal gl i ((occs,c,b),na as o) cl =
+  let t = pf_type_of gl c in
+  let env = pf_env gl in
+    generalize_goal_gen env (pf_ids_of_hyps gl) i o t cl
 
 let generalize_dep ?(with_let=false) c gl =
   let env = pf_env gl in
   let sign = pf_hyps gl in
   let init_ids = ids_of_named_context (Global.named_context()) in
-  let rec seek d toquant =
+  let seek d toquant =
     if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
-      or dependent_in_decl c d then
+      || dependent_in_decl c d then
       d::toquant
     else
       toquant in
-  let to_quantify = Sign.fold_named_context seek sign ~init:[] in
+  let to_quantify = Context.fold_named_context seek sign ~init:[] in
   let to_quantify_rev = List.rev to_quantify in
   let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in
-  let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in
+  let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in
   let tothin' =
     match kind_of_term c with
-      | Var id when mem_named_context id sign & not (List.mem id init_ids)
+      | Var id when mem_named_context id sign && not (Id.List.mem id init_ids)
 	  -> id::tothin
       | _ -> tothin
   in
   let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
-  let body = 
+  let body =
     if with_let then
-      match kind_of_term c with 
+      match kind_of_term c with
       | Var id -> pi2 (pf_get_hyp gl id)
       | _ -> None
     else None
   in
-  let cl'' = generalize_goal gl 0 ((all_occurrences,c,body),Anonymous) cl' in
-  let args = Array.to_list (instance_from_named_context to_quantify_rev) in
-  tclTHEN
-    (apply_type cl'' (if body = None then c::args else args))
-    (thin (List.rev tothin'))
+  let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous)
+    (cl',project gl) in
+  let args = instance_from_named_context to_quantify_rev in
+  tclTHENLIST
+    [tclEVARS evd;
+     apply_type cl'' (if Option.is_empty body then c::args else args);
+     thin (List.rev tothin')]
     gl
 
+(**  *)
 let generalize_gen_let lconstr gl =
-  let newcl =
-    list_fold_right_i (generalize_goal gl) 0 lconstr (pf_concl gl) in
-  apply_type newcl (list_map_filter (fun ((_,c,b),_) -> 
-    if b = None then Some c else None) lconstr) gl
+  let newcl, evd =
+    List.fold_right_i (generalize_goal gl) 0 lconstr
+      (pf_concl gl,project gl)
+  in
+  tclTHEN (tclEVARS evd)
+    (apply_type newcl (List.map_filter (fun ((_,c,b),_) ->
+      if Option.is_empty b then Some c else None) lconstr)) gl
+
+let new_generalize_gen_let lconstr =
+  Proofview.Goal.enter begin fun gl ->
+    let gl = Proofview.Goal.assume gl in
+    let concl = Proofview.Goal.concl gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let env = Proofview.Goal.env gl in
+    let ids = Tacmach.New.pf_ids_of_hyps gl in
+    let (newcl, sigma), args =
+      List.fold_right_i 
+	(fun i ((_,c,b),_ as o) (cl, args) ->
+	  let t = Tacmach.New.pf_type_of gl c in
+	  let args = if Option.is_empty b then c :: args else args in
+	    generalize_goal_gen env ids i o t cl, args)
+	0 lconstr ((concl, sigma), [])
+    in
+      Proofview.Unsafe.tclEVARS sigma <*>
+	Proofview.Refine.refine begin fun sigma ->
+          let (sigma, ev) = Evarutil.new_evar env sigma newcl in
+            (sigma, (applist (ev, args)))
+	end
+  end
 
 let generalize_gen lconstr =
   generalize_gen_let (List.map (fun ((occs,c),na) ->
     (occs,c,None),na) lconstr)
+
+let new_generalize_gen lconstr =
+  new_generalize_gen_let (List.map (fun ((occs,c),na) ->
+    (occs,c,None),na) lconstr)
     
 let generalize l =
-  generalize_gen_let (List.map (fun c -> ((all_occurrences,c,None),Anonymous)) l)
+  generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l)
 
-let pf_get_hyp_val gl id =
-  let (_, b, _) = pf_get_hyp gl id in
-    b
-
-let revert hyps gl = 
-  let lconstr = List.map (fun id -> 
-    ((all_occurrences, mkVar id, pf_get_hyp_val gl id), Anonymous)) 
-    hyps 
-  in tclTHEN (generalize_gen_let lconstr) (clear hyps) gl
+let new_generalize l =
+  new_generalize_gen_let (List.map (fun c -> ((AllOccurrences,c,None),Anonymous)) l)
 
 (* Faudra-t-il une version avec plusieurs args de generalize_dep ?
 Cela peut-être troublant de faire "Generalize Dependent H n" dans
@@ -1584,218 +2556,6 @@ let quantify lconstr =
    tclIDTAC
 *)
 
-(* A dependent cut rule à la sequent calculus
-   ------------------------------------------
-   Sera simplifiable le jour où il y aura un let in primitif dans constr
-
-   [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
-   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
-   [...x:T;Heqx:(x=c);x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
-   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
-
-   [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted;
-   if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted
-   wherever it occurs, otherwise [c] is substituted only in hyps
-   present in [occ_hyps] at the specified occurrences (everywhere if
-   the list of occurrences is empty), and in the goal at the specified
-   occurrences if [occ_goal] is not [None];
-
-   if name = Anonymous, the name is build from the first letter of the type;
-
-   The tactic first quantify the goal over x1, x2,... then substitute then
-   re-intro x1, x2,... at their initial place ([marks] is internally
-   used to remember the place of x1, x2, ...: it is the list of hypotheses on
-   the left of each x1, ...).
-*)
-
-let out_arg = function
-  | ArgVar _ -> anomaly "Unevaluated or_var variable"
-  | ArgArg x -> x
-
-let occurrences_of_hyp id cls =
-  let rec hyp_occ = function
-      [] -> None
-    | (((b,occs),id'),hl)::_ when id=id' -> Some ((b,List.map out_arg occs),hl)
-    | _::l -> hyp_occ l in
-  match cls.onhyps with
-      None -> Some (all_occurrences,InHyp)
-    | Some l -> hyp_occ l
-
-let occurrences_of_goal cls =
-  if cls.concl_occs = no_occurrences_expr then None
-  else Some (on_snd (List.map out_arg) cls.concl_occs)
-
-let in_every_hyp cls = (cls.onhyps=None)
-
-(*
-(* Implementation with generalisation then re-intro: introduces noise *)
-(* in proofs *)
-
-let letin_abstract id c occs gl =
-  let env = pf_env gl in
-  let compute_dependency _ (hyp,_,_ as d) ctxt =
-    let d' =
-      try
-	match occurrences_of_hyp hyp occs with
-	  | None -> raise Not_found
-	  | Some occ ->
-              let newdecl = subst_term_occ_decl occ c d in
-              if occ = [] & d = newdecl then
-		if not (in_every_hyp occs)
-		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
-		else raise Not_found
-              else
-		(subst1_named_decl (mkVar id) newdecl, true)
-	with Not_found ->
-	  (d,List.exists
-	      (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt)
-    in d'::ctxt
-  in
-  let ctxt' = fold_named_context compute_dependency env ~init:[] in
-  let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) =
-    if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp)
-    else (accu, Some hyp) in
-  let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in
-  let ccl = match occurrences_of_goal occs with
-    | None -> pf_concl gl
-    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl))
-  in
-  (depdecls,marks,ccl)
-
-let letin_tac with_eq name c occs gl =
-  let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
-  let id =
-    if name = Anonymous then fresh_id [] x gl else
-      if not (mem_named_context x (pf_hyps gl)) then x else
-	error ("The variable "^(string_of_id x)^" is already declared") in
-  let (depdecls,marks,ccl)= letin_abstract id c occs gl in
-  let t = pf_type_of gl c in
-  let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in
-  let args = Array.to_list (instance_from_named_context depdecls) in
-  let newcl = mkNamedLetIn id c t tmpcl in
-  let lastlhyp = if marks=[] then None else snd (List.hd marks) in
-  tclTHENLIST
-    [ apply_type newcl args;
-      thin (List.map (fun (id,_,_) -> id) depdecls);
-      intro_gen (IntroMustBe id) lastlhyp false;
-      if with_eq then tclIDTAC else thin_body [id];
-      intros_move marks ] gl
-*)
-
-(* Implementation without generalisation: abbrev will be lost in hyps in *)
-(* in the extracted proof *)
-
-let default_matching_flags sigma = {
-  modulo_conv_on_closed_terms = Some empty_transparent_state;
-  use_metas_eagerly_in_conv_on_closed_terms = false;
-  modulo_delta = empty_transparent_state;
-  modulo_delta_types = full_transparent_state;
-  modulo_delta_in_merge = Some full_transparent_state;
-  check_applied_meta_types = true;
-  resolve_evars = false;
-  use_pattern_unification = false;
-  use_meta_bound_pattern_unification = false;
-  frozen_evars =
-    fold_undefined (fun evk _ evars -> ExistentialSet.add evk evars)
-      sigma ExistentialSet.empty;
-  restrict_conv_on_strict_subterms = false;
-  modulo_betaiota = false;
-  modulo_eta = false;
-  allow_K_in_toplevel_higher_order_unification = false
-}
-
-let make_pattern_test env sigma0 (sigma,c) =
-  let flags = default_matching_flags sigma0 in
-  let matching_fun t =
-    try let sigma = w_unify env sigma Reduction.CONV ~flags c t in Some(sigma,t)
-    with e when Errors.noncritical e -> raise NotUnifiable in
-  let merge_fun c1 c2 =
-    match c1, c2 with
-    | Some (_,c1), Some (_,c2) when not (is_fconv Reduction.CONV env sigma0 c1 c2) ->
-        raise NotUnifiable
-    | _ -> c1 in
-  { match_fun = matching_fun; merge_fun = merge_fun; 
-    testing_state = None; last_found = None },
-  (fun test -> match test.testing_state with
-   | None -> finish_evar_resolution env sigma0 (sigma,c)
-   | Some (sigma,_) -> nf_evar sigma c)
-
-let letin_abstract id c (test,out) (occs,check_occs) gl =
-  let env = pf_env gl in
-  let compute_dependency _ (hyp,_,_ as d) depdecls =
-    match occurrences_of_hyp hyp occs with
-      | None -> depdecls
-      | Some occ ->
-          let newdecl = subst_closed_term_occ_decl_modulo occ test d in
-          if occ = (all_occurrences,InHyp) & eq_named_declaration d newdecl then
-	    if check_occs & not (in_every_hyp occs)
-	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
-	    else depdecls
-          else
-	    (subst1_named_decl (mkVar id) newdecl)::depdecls in
-  let depdecls = fold_named_context compute_dependency env ~init:[] in
-  let ccl = match occurrences_of_goal occs with
-    | None -> pf_concl gl
-    | Some occ ->
-        subst1 (mkVar id) (subst_closed_term_occ_modulo occ test None (pf_concl gl)) in
-  let lastlhyp =
-    if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in
-  (depdecls,lastlhyp,ccl,out test)
-
-let letin_tac_gen with_eq name (sigmac,c) test ty occs gl =
-  let id =
-    let t = match ty with Some t -> t | None -> typ_of (pf_env gl) sigmac c in
-    let x = id_of_name_using_hdchar (Global.env()) t name in
-    if name = Anonymous then fresh_id [] x gl else
-      if not (mem_named_context x (pf_hyps gl)) then x else
-	error ("The variable "^(string_of_id x)^" is already declared.") in
-  let (depdecls,lastlhyp,ccl,c) = letin_abstract id c test occs gl in
-  let t = match ty with Some t -> t | None -> pf_apply typ_of gl c in
-  let newcl,eq_tac = match with_eq with
-    | Some (lr,(loc,ido)) ->
-      let heq = match ido with
-        | IntroAnonymous -> fresh_id [id] (add_prefix "Heq" id) gl
-	| IntroFresh heq_base -> fresh_id [id] heq_base gl
-        | IntroIdentifier id -> id
-	| _ -> error"Expect an introduction pattern naming one hypothesis." in
-      let eqdata = build_coq_eq_data () in
-      let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
-      let eq = applist (eqdata.eq,args) in
-      let refl = applist (eqdata.refl, [t;mkVar id]) in
-      mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)),
-      tclTHEN
-	(intro_gen loc (IntroMustBe heq) lastlhyp true false)
-	(thin_body [heq;id])
-    | None ->
-	mkNamedLetIn id c t ccl, tclIDTAC in
-  tclTHENLIST
-    [ convert_concl_no_check newcl DEFAULTcast;
-      intro_gen dloc (IntroMustBe id) lastlhyp true false;
-      tclMAP convert_hyp_no_check depdecls;
-      eq_tac ] gl
-
-let make_eq_test c = (make_eq_test c,fun _ -> c)
-
-let letin_tac with_eq name c ty occs gl =
-  letin_tac_gen with_eq name (project gl,c) (make_eq_test c) ty (occs,true) gl
-
-let letin_pat_tac with_eq name c ty occs gl =
-  letin_tac_gen with_eq name c
-    (make_pattern_test (pf_env gl) (project gl) c)
-    ty (occs,true) gl
-
-(* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *)
-let forward usetac ipat c gl =
-  match usetac with
-  | None ->
-      let t = pf_type_of gl c in
-      tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl
-  | Some tac ->
-      tclTHENFIRST (assert_as true ipat c) tac gl
-
-let pose_proof na c = forward None (ipat_of_name na) c
-let assert_by na t tac = forward (Some tac) (ipat_of_name na) t
-
 (*****************************)
 (* Ad hoc unfold             *)
 (*****************************)
@@ -1805,7 +2565,7 @@ let assert_by na t tac = forward (Some tac) (ipat_of_name na) t
 let unfold_body x gl =
   let hyps = pf_hyps gl in
   let xval =
-    match Sign.lookup_named x hyps with
+    match Context.lookup_named x hyps with
         (_,Some xval,_) -> xval
       | _ -> errorlabstrm "unfold_body"
           (pr_id x ++ str" is not a defined hypothesis.") in
@@ -1817,14 +2577,6 @@ let unfold_body x gl =
     [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
      reduct_in_concl (rfun,DEFAULTcast)] gl
 
-(* Unfolds x by its definition everywhere and clear x. This may raise
-   an error if x is not defined. *)
-let unfold_all x gl =
-  let (_,xval,_) = pf_get_hyp gl x in
-  (* If x has a body, simply replace x with body and clear x *)
-  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl
-  else tclIDTAC gl
-
 (* Either unfold and clear if defined or simply clear if not a definition *)
 let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
 
@@ -1849,7 +2601,7 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
     move the subterms of [hyp0succ] in the i-th branch where it is supposed
     to be the i-th constructor of the inductive type.
 
-  Strategy: (cf in [induction_from_context])
+  Strategy: (cf in [induction_with_atomization_of_ind_arg])
   - requantify and clear all [dephyps]
   - apply induction on [hyp0]
   - clear [indhyps] and [hyp0]
@@ -1865,50 +2617,61 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id])
  *)
 
 let check_unused_names names =
-  if names <> [] & Flags.is_verbose () then
+  if not (List.is_empty names) && Flags.is_verbose () then
     msg_warning
-      (str"Unused introduction " ++ str (plural (List.length names) "pattern")
-       ++ str": " ++ prlist_with_sep spc pr_intro_pattern names)
+      (str"Unused introduction " ++ str (String.plural (List.length names) "pattern")
+       ++ str": " ++ prlist_with_sep spc 
+	 (Miscprint.pr_intro_pattern 
+	    (fun c -> Printer.pr_constr (snd (c (Global.env()) Evd.empty)))) names)
 
-let rec consume_pattern avoid id isdep gl = function
-  | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
-  | (loc,IntroAnonymous)::names ->
-      let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id gl)), names)
+let intropattern_of_name gl avoid = function
+  | Anonymous -> IntroNaming IntroAnonymous
+  | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl))
+
+let rec consume_pattern avoid na isdep gl = function
+  | [] -> ((dloc, intropattern_of_name gl avoid na), [])
   | (loc,IntroForthcoming true)::names when not isdep ->
-      consume_pattern avoid id isdep gl names
+      consume_pattern avoid na isdep gl names
   | (loc,IntroForthcoming _)::names as fullpat ->
       let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id gl)), fullpat)
-  | (loc,IntroFresh id')::names ->
+      ((loc,intropattern_of_name gl avoid na), fullpat)
+  | (loc,IntroNaming IntroAnonymous)::names ->
       let avoid = avoid@explicit_intro_names names in
-      ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
+      ((loc,intropattern_of_name gl avoid na), names)
+  | (loc,IntroNaming (IntroFresh id'))::names ->
+      let avoid = avoid@explicit_intro_names names in
+      ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names)
   | pat::names -> (pat,names)
 
 let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) =
-  let tophyp = match tophyp with None -> MoveToEnd true | Some hyp -> MoveAfter hyp in
+  let tophyp = match tophyp with None -> MoveLast | Some hyp -> MoveAfter hyp in
   let newlstatus = (* if some IH has taken place at the top of hyps *)
-    List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus
+    List.map (function (hyp,MoveLast) -> (hyp,tophyp) | x -> x) lstatus
   in
-  tclTHEN
+  Tacticals.New.tclTHEN
     (intros_move rstatus)
     (intros_move newlstatus)
 
-let update destopt tophyp = if destopt = no_move then tophyp else destopt
-
-let safe_dest_intros_patterns avoid thin dest pat tac gl =
-  try intros_patterns true avoid [] thin dest tac pat gl
-  with UserError ("move_hyp",_) ->
-    (* May happen if the lemma has dependent arguments that are resolved
-       only after cook_sign is called, e.g. as in "destruct dec" in context
-       "dec:forall x, {x=0}+{x<>0};  a:A  |- if dec a then True else False"
-       where argument a of dec will be found only lately *)
-    intros_patterns true avoid [] [] no_move tac pat gl
+let dest_intro_patterns avoid thin dest pat tac =
+  intro_patterns_core true avoid [] thin dest None 0 tac pat
+
+let safe_dest_intro_patterns avoid thin dest pat tac =
+  Proofview.tclORELSE
+    (dest_intro_patterns avoid thin dest pat tac)
+    begin function (e, info) -> match e with
+      | UserError ("move_hyp",_) ->
+       (* May happen e.g. with "destruct x using s" with an hypothesis
+          which is morally an induction hypothesis to be "MoveLast" if
+          known as such but which is considered instead as a subterm of
+          a constructor to be move at the place of x. *)
+          dest_intro_patterns avoid thin MoveLast pat tac
+      | e -> Proofview.tclZERO ~info e
+    end
 
 type elim_arg_kind = RecArg | IndArg | OtherArg
 
 type recarg_position =
-  | AfterFixedPosition of identifier option (* None = top of context *)
+  | AfterFixedPosition of Id.t option (* None = top of context *)
 
 let update_dest (recargdests,tophyp as dests) = function
   | [] -> dests
@@ -1920,7 +2683,7 @@ let update_dest (recargdests,tophyp as dests) = function
 
 let get_recarg_dest (recargdests,tophyp) =
   match recargdests with
-  | AfterFixedPosition None -> MoveToEnd true
+  | AfterFixedPosition None -> MoveLast
   | AfterFixedPosition (Some id) -> MoveAfter id
 
 (* Current policy re-introduces recursive arguments of destructed
@@ -1933,45 +2696,56 @@ let get_recarg_dest (recargdests,tophyp) =
    had to be introduced at the top of the context).
 *)
 
-let induct_discharge dests avoid' tac (avoid,ra) names gl =
+let induct_discharge dests avoid' tac (avoid,ra) names =
   let avoid = avoid @ avoid' in
-  let rec peel_tac ra dests names thin gl =
+  let rec peel_tac ra dests names thin =
     match ra with
     | (RecArg,deprec,recvarname) ::
         (IndArg,depind,hyprecname) :: ra' ->
-        let recpat,names = match names with
-          | [loc,IntroIdentifier id as pat] ->
+        Proofview.Goal.enter begin fun gl ->
+        let (recpat,names) = match names with
+          | [loc,IntroNaming (IntroIdentifier id) as pat] ->
               let id' = next_ident_away (add_prefix "IH" id) avoid in
-	      (pat, [dloc, IntroIdentifier id'])
-          | _ -> consume_pattern avoid recvarname deprec gl names in
-        let hyprec,names = consume_pattern avoid hyprecname depind gl names in
+	      (pat, [dloc, IntroNaming (IntroIdentifier id')])
+          | _ -> consume_pattern avoid (Name recvarname) deprec gl names in
         let dest = get_recarg_dest dests in
-        safe_dest_intros_patterns avoid thin dest [recpat] (fun ids thin ->
-	safe_dest_intros_patterns avoid thin no_move [hyprec] (fun ids' thin ->
-	peel_tac ra' (update_dest dests ids') names thin))
-          gl
+        dest_intro_patterns avoid thin dest [recpat] (fun ids thin ->
+        Proofview.Goal.enter begin fun gl ->
+          let (hyprec,names) =
+            consume_pattern avoid (Name hyprecname) depind gl names
+          in
+	  dest_intro_patterns avoid thin MoveLast [hyprec] (fun ids' thin ->
+	    peel_tac ra' (update_dest dests ids') names thin)
+        end)
+        end
     | (IndArg,dep,hyprecname) :: ra' ->
+        Proofview.Goal.enter begin fun gl ->
 	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
-        let pat,names = consume_pattern avoid hyprecname dep gl names in
-	safe_dest_intros_patterns avoid thin no_move [pat] (fun ids thin ->
-        peel_tac ra' (update_dest dests ids) names thin) gl
+        let pat,names =
+          consume_pattern avoid (Name hyprecname) dep gl names in
+	dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin ->
+        peel_tac ra' (update_dest dests ids) names thin)
+        end
     | (RecArg,dep,recvarname) :: ra' ->
-        let pat,names = consume_pattern avoid recvarname dep gl names in
+        Proofview.Goal.enter begin fun gl ->
+        let (pat,names) =
+          consume_pattern avoid (Name recvarname) dep gl names in
         let dest = get_recarg_dest dests in
-	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
-        peel_tac ra' dests names thin) gl
-    | (OtherArg,_,_) :: ra' ->
-        let pat,names = match names with
-          | [] -> (dloc, IntroAnonymous), []
-          | pat::names -> pat,names in
+	dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin)
+        end
+    | (OtherArg,dep,_) :: ra' ->
+        Proofview.Goal.enter begin fun gl ->
+        let (pat,names) = consume_pattern avoid Anonymous dep gl names in
         let dest = get_recarg_dest dests in
-	safe_dest_intros_patterns avoid thin dest [pat] (fun ids thin ->
-        peel_tac ra' dests names thin) gl
+	safe_dest_intro_patterns avoid thin dest [pat] (fun ids thin ->
+        peel_tac ra' dests names thin)
+        end
     | [] ->
         check_unused_names names;
-        tclTHEN (clear_wildcards thin) (tac dests) gl
+        Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests)
   in
-  peel_tac ra dests names [] gl
+  peel_tac ra dests names []
 
 (* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
      s'embêter à regarder si un letin_tac ne fait pas des
@@ -1979,58 +2753,67 @@ let induct_discharge dests avoid' tac (avoid,ra) names gl =
 
 (* Marche pas... faut prendre en compte l'occurrence précise... *)
 
-let atomize_param_of_ind (indref,nparams,_) hyp0 gl =
-  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
-  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in
+  let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in
+  let typ0 = reduce_to_quantified_ref indref tmptyp0 in
   let prods, indtyp = decompose_prod typ0 in
-  let argl = snd (decompose_app indtyp) in
-  let params = list_firstn nparams argl in
+  let hd,argl = decompose_app indtyp in
+  let params = List.firstn nparams argl in
   (* le gl est important pour ne pas préévaluer *)
-  let rec atomize_one i avoid gl =
-    if i<>nparams then
-      let tmptyp0 = pf_get_hyp_typ gl hyp0 in
-      (* If argl <> [], we expect typ0 not to be quantified, in order to
-         avoid bound parameters... then we call pf_reduce_to_atomic_ind *)
-      let indtyp = pf_apply reduce_to_atomic_ref gl indref tmptyp0 in
-      let argl = snd (decompose_app indtyp) in
+  let rec atomize_one i args avoid =
+    if Int.equal i nparams then
+      let t = applist (hd, params@args) in
+      Tacticals.New.tclTHEN
+        (change_in_hyp None (fun sigma -> sigma, t) (hyp0,InHypTypeOnly))
+        (tac avoid)
+    else
       let c = List.nth argl (i-1) in
       match kind_of_term c with
-	| Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->
-	    atomize_one (i-1) ((mkVar id)::avoid) gl
-	| Var id ->
-	    let x = fresh_id [] id gl in
-	    tclTHEN
-	      (letin_tac None (Name x) (mkVar id) None allHypsAndConcl)
-	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+	| Var id when not (List.exists (occur_var env id) args) &&
+                      not (List.exists (occur_var env id) params) ->
+            (* Based on the knowledge given by the user, all
+               constraints on the variable are generalizable in the
+               current environment so that it is clearable after destruction *)
+	    atomize_one (i-1) (c::args) (id::avoid)
 	| _ ->
-	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
-		       Anonymous in
-	    let x = fresh_id [] id gl in
-	    tclTHEN
+            if List.exists (dependent c) params ||
+               List.exists (dependent c) args
+            then
+              (* This is a case where the argument is constrained in a
+                 way which would require some kind of inversion; we
+                 follow the (old) discipline of not generalizing over
+                 this term, since we don't try to invert the
+                 constraint anyway. *)
+	      atomize_one (i-1) (c::args) avoid
+            else
+            (* We reason blindly on the term and do as if it were
+               generalizable, ignoring the constraints coming from
+               its structure *)
+            let id = match kind_of_term c with
+            | Var id -> id
+            | _ ->
+            let type_of = Tacmach.New.pf_type_of gl in
+            id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in
+            let x = fresh_id_in_env avoid id env in
+	    Tacticals.New.tclTHEN
 	      (letin_tac None (Name x) c None allHypsAndConcl)
-	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
-    else
-      tclIDTAC gl
+	      (atomize_one (i-1) (mkVar x::args) (x::avoid))
   in
-  atomize_one (List.length argl) params gl
+  atomize_one (List.length argl) [] []
+  end
 
 let find_atomic_param_of_ind nparams indtyp =
   let argl = snd (decompose_app indtyp) in
-  let argv = Array.of_list argl in
-  let params = list_firstn nparams argl in
-  let indvars = ref Idset.empty in
-  for i = nparams to (Array.length argv)-1 do
-    match kind_of_term argv.(i) with
-      | Var id
-          when not (List.exists (occur_var (Global.env()) id) params) ->
-	  indvars := Idset.add id !indvars
-      | _ -> ()
-  done;
-  Idset.elements !indvars;
-
-
-(* [cook_sign] builds the lists [indhyps] of hyps that must be
-   erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
+  let params,args = List.chop nparams argl in
+  let test c = isVar c && not (List.exists (dependent c) params) in
+  List.map destVar (List.filter test args)
+
+(* [cook_sign] builds the lists [beforetoclear] (preceding the
+   ind. var.) and [aftertoclear] (coming after the ind. var.)  of hyps
+   that must be erased, the lists of hyps to be generalize [decldeps] on the
    goal together with the places [(lstatus,rstatus)] where to re-intro
    them after induction. To know where to re-intro the dep hyp, we
    remember the name of the hypothesis [lhyp] after which (if the dep
@@ -2080,7 +2863,7 @@ let find_atomic_param_of_ind nparams indtyp =
    would have posed no problem. But for uniformity, we decided to use
    the right hyp for all hyps on the right of H4.
 
-   Others solutions are welcome
+   Other solutions are welcome
 
    PC 9 fev 06: Adapted to accept multi argument principle with no
    main arg hyp. hyp0 is now optional, meaning that it is possible
@@ -2092,72 +2875,81 @@ let find_atomic_param_of_ind nparams indtyp =
 
 *)
 
-exception Shunt of identifier move_location
+exception Shunt of Id.t move_location
 
-let cook_sign hyp0_opt indvars env =
-  let hyp0,inhyps =
-  match hyp0_opt with
-  | None -> List.hd (List.rev indvars), []
-  | Some (hyp0,at_least_in_hyps) -> hyp0, at_least_in_hyps in
+let cook_sign hyp0_opt inhyps indvars env =
   (* First phase from L to R: get [indhyps], [decldep] and [statuslist]
      for the hypotheses before (= more ancient than) hyp0 (see above) *)
-  let allindhyps = hyp0::indvars in
-  let indhyps = ref [] in
+  let toclear = ref [] in
+  let avoid = ref [] in
   let decldeps = ref [] in
   let ldeps = ref [] in
   let rstatus = ref [] in
   let lstatus = ref [] in
   let before = ref true in
+  let maindep = ref false in
   let seek_deps env (hyp,_,_ as decl) rhyp =
-    if hyp = hyp0 then begin
+    if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false)
+    then begin
       before:=false;
-      (* If there was no main induction hypotheses, then hyp is one of
-         indvars too, so add it to indhyps. *)
-      (if hyp0_opt=None then indhyps := hyp::!indhyps);
-      MoveToEnd false (* fake value *)
-    end else if List.mem hyp indvars then begin
-      (* warning: hyp can still occur after induction *)
-      (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
-      indhyps := hyp::!indhyps;
+      (* Note that if there was no main induction hypotheses, then hyp
+         is one of indvars too *)
+      toclear := hyp::!toclear;
+      MoveFirst (* fake value *)
+    end else if Id.List.mem hyp indvars then begin
+      (* The variables in indvars are such that they don't occur any
+         more after generalization, so declare them to clear. *)
+      toclear := hyp::!toclear;
       rhyp
     end else
-      if inhyps <> [] && List.mem hyp inhyps || inhyps = [] &&
-	(List.exists (fun id -> occur_var_in_decl env id decl) allindhyps ||
+      let dephyp0 = List.is_empty inhyps && 
+	(Option.cata (fun id -> occur_var_in_decl env id decl) false hyp0_opt)
+      in
+      let depother = List.is_empty inhyps &&
+	(List.exists (fun id -> occur_var_in_decl env id decl) indvars ||
          List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps)
+      in
+      if not (List.is_empty inhyps) && Id.List.mem hyp inhyps
+         || dephyp0 || depother
       then begin
 	decldeps := decl::!decldeps;
-	if !before then
+	avoid := hyp::!avoid;
+        maindep := dephyp0 || !maindep;
+	if !before then begin
+          toclear := hyp::!toclear;
 	  rstatus := (hyp,rhyp)::!rstatus
-	else
-	  ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
+        end
+	else begin
+	  toclear := hyp::!toclear;
+	  ldeps := hyp::!ldeps (* status computed in 2nd phase *)
+        end;
 	MoveBefore hyp end
       else
 	MoveBefore hyp
   in
-  let _ = fold_named_context seek_deps env ~init:(MoveToEnd false) in
+  let _ = fold_named_context seek_deps env ~init:MoveFirst in
   (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *)
   let compute_lstatus lhyp (hyp,_,_) =
-    if hyp = hyp0 then raise (Shunt lhyp);
-    if List.mem hyp !ldeps then begin
+    if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then
+      raise (Shunt lhyp);
+    if Id.List.mem hyp !ldeps then begin
       lstatus := (hyp,lhyp)::!lstatus;
       lhyp
     end else
-      if List.mem hyp !indhyps then lhyp else MoveAfter hyp
+      if Id.List.mem hyp !toclear then lhyp else MoveAfter hyp
   in
   try
     let _ =
-      fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
-    raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
+      fold_named_context_reverse compute_lstatus ~init:MoveLast env in
+    raise (Shunt MoveLast) (* ?? FIXME *)
   with Shunt lhyp0 ->
     let lhyp0 = match lhyp0 with
-      | MoveToEnd true -> None
+      | MoveLast -> None
       | MoveAfter hyp -> Some hyp
       | _ -> assert false in
     let statuslists = (!lstatus,List.rev !rstatus) in
-    let recargdests = AfterFixedPosition (if hyp0_opt=None then None else lhyp0) in
-    (statuslists, (recargdests,None),
-     !indhyps, !decldeps)
-
+    let recargdests = AfterFixedPosition (if Option.is_empty hyp0_opt then None else lhyp0) in
+    (statuslists, (recargdests,None), !toclear, !decldeps, !avoid, !maindep)
 
 (*
    The general form of an induction principle is the following:
@@ -2187,7 +2979,6 @@ type elim_scheme = {
   elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
-  index: int;              (* index of the elimination type in the scheme *)
   params: rel_context;     (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
   nparams: int;            (* number of parameters *)
   predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
@@ -2209,7 +3000,6 @@ let empty_scheme =
     elimc = None;
     elimt = mkProp;
     indref = None;
-    index = -1;
     params = [];
     nparams = 0;
     predicates = [];
@@ -2225,62 +3015,65 @@ let empty_scheme =
   }
 
 let make_base n id =
-  if n=0 or n=1 then id
+  if Int.equal n 0 || Int.equal n 1 then id
   else
     (* This extends the name to accept new digits if it already ends with *)
     (* digits *)
-    id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
+    Id.of_string (atompart_of_id (make_ident (Id.to_string id) (Some 0)))
 
 (* Builds two different names from an optional inductive type and a
    number, also deals with a list of names to avoid. If the inductive
    type is None, then hyprecname is IHi where i is a number. *)
 let make_up_names n ind_opt cname =
-  let is_hyp = atompart_of_id cname = "H" in
-  let base = string_of_id (make_base n cname) in
+  let is_hyp = String.equal (atompart_of_id cname) "H" in
+  let base = Id.to_string (make_base n cname) in
   let ind_prefix = "IH" in
   let base_ind =
     if is_hyp then
       match ind_opt with
-	| None -> id_of_string ind_prefix
+	| None -> Id.of_string ind_prefix
 	| Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id)
     else add_prefix ind_prefix cname in
   let hyprecname = make_base n base_ind in
   let avoid =
-    if n=1 (* Only one recursive argument *) or n=0 then []
+    if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then []
     else
       (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
       (* in order to get names such as f1, f2, ... *)
       let avoid =
-        (make_ident (string_of_id hyprecname) None) ::
-        (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
-      if atompart_of_id cname <> "H" then
+        (make_ident (Id.to_string hyprecname) None) ::
+        (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in
+      if not (String.equal (atompart_of_id cname) "H") then
         (make_ident base (Some 0)) :: (make_ident base None) :: avoid
       else avoid in
-  id_of_string base, hyprecname, avoid
+  Id.of_string base, hyprecname, avoid
 
 let error_ind_scheme s =
-  let s = if s <> "" then s^" " else s in
+  let s = if not (String.is_empty s) then s^" " else s in
   error ("Cannot recognize "^s^"an induction scheme.")
 
-let coq_eq = Lazy.lazy_from_fun Coqlib.build_coq_eq
-let coq_eq_refl = lazy ((Coqlib.build_coq_eq_data ()).Coqlib.refl)
+let glob = Universes.constr_of_global
+
+let coq_eq = lazy (glob (Coqlib.build_coq_eq ()))
+let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ()))
 
 let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")
 let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
 
-let mkEq t x y = 
-  mkApp (Lazy.force coq_eq, [| refresh_universes_strict t; x; y |])
-    
-let mkRefl t x = 
-  mkApp (Lazy.force coq_eq_refl, [| refresh_universes_strict t; x |])
+
+let mkEq t x y =
+  mkApp (Lazy.force coq_eq, [| t; x; y |])
+
+let mkRefl t x =
+  mkApp (Lazy.force coq_eq_refl, [| t; x |])
 
 let mkHEq t x u y =
   mkApp (Lazy.force coq_heq,
-	[| refresh_universes_strict t; x; refresh_universes_strict u; y |])
-    
+	[| t; x; u; y |])
+
 let mkHRefl t x =
   mkApp (Lazy.force coq_heq_refl,
-	[| refresh_universes_strict t; x |])
+	[| t; x |])
 
 let lift_togethern n l =
   let l', _ =
@@ -2295,26 +3088,26 @@ let lift_list l = List.map (lift 1) l
 let ids_of_constr ?(all=false) vars c =
   let rec aux vars c =
     match kind_of_term c with
-    | Var id -> Idset.add id vars
-    | App (f, args) -> 
+    | Var id -> Id.Set.add id vars
+    | App (f, args) ->
 	(match kind_of_term f with
-	| Construct (ind,_)
-	| Ind ind ->
+	| Construct ((ind,_),_)
+	| Ind (ind,_) ->
             let (mib,mip) = Global.lookup_inductive ind in
-	      array_fold_left_from
+	      Array.fold_left_from
 		(if all then 0 else mib.Declarations.mind_nparams)
 		aux vars args
 	| _ -> fold_constr aux vars c)
     | _ -> fold_constr aux vars c
   in aux vars c
-    
+
 let decompose_indapp f args =
   match kind_of_term f with
-  | Construct (ind,_) 
-  | Ind ind ->
+  | Construct ((ind,_),_)
+  | Ind (ind,_) ->
       let (mib,mip) = Global.lookup_inductive ind in
       let first = mib.Declarations.mind_nparams_rec in
-      let pars, args = array_chop first args in
+      let pars, args = Array.chop first args in
 	mkApp (f, pars), args
   | _ -> f, args
 
@@ -2354,41 +3147,42 @@ let make_abstract_generalize gl id concl dep ctx body c eqs args refls =
     mkApp (appeqs, abshypt)
 
 let hyps_of_vars env sign nogen hyps =
-  if Idset.is_empty hyps then [] 
+  if Id.Set.is_empty hyps then []
   else
     let (_,lh) =
-      Sign.fold_named_context_reverse
+      Context.fold_named_context_reverse
         (fun (hs,hl) (x,_,_ as d) ->
-	  if Idset.mem x nogen then (hs,hl)
-	  else if Idset.mem x hs then (hs,x::hl)
+	  if Id.Set.mem x nogen then (hs,hl)
+	  else if Id.Set.mem x hs then (hs,x::hl)
 	  else
 	    let xvars = global_vars_set_of_decl env d in
-	      if not (Idset.equal (Idset.diff xvars hs) Idset.empty) then
-		(Idset.add x hs, x :: hl)
+	      if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then
+		(Id.Set.add x hs, x :: hl)
 	      else (hs, hl))
         ~init:(hyps,[])
-        sign 
+        sign
     in lh
 
 exception Seen
 
-let linear vars args = 
+let linear vars args =
   let seen = ref vars in
-    try 
-      Array.iter (fun i -> 
-	let rels = ids_of_constr ~all:true Idset.empty i in
-	let seen' = 
-	  Idset.fold (fun id acc ->
-	    if Idset.mem id acc then raise Seen
-	    else Idset.add id acc)
+    try
+      Array.iter (fun i ->
+	let rels = ids_of_constr ~all:true Id.Set.empty i in
+	let seen' =
+	  Id.Set.fold (fun id acc ->
+	    if Id.Set.mem id acc then raise Seen
+	    else Id.Set.add id acc)
 	    rels !seen
 	in seen := seen')
 	args;
       true
     with Seen -> false
 
-let is_defined_variable env id =
-  pi2 (lookup_named id env) <> None
+let is_defined_variable env id = match lookup_named id env with
+| (_, None, _) -> false
+| (_, Some _, _) -> true
 
 let abstract_args gl generalize_vars dep id defined f args =
   let sigma = project gl in
@@ -2397,13 +3191,13 @@ let abstract_args gl generalize_vars dep id defined f args =
   let dep = dep || dependent (mkVar id) concl in
   let avoid = ref [] in
   let get_id name =
-    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in
+    let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in
       avoid := id :: !avoid; id
   in
     (* Build application generalized w.r.t. the argument plus the necessary eqs.
        From env |- c : forall G, T and args : G we build
        (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize)
-       
+
        eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *)
     *)
   let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg =
@@ -2412,15 +3206,14 @@ let abstract_args gl generalize_vars dep id defined f args =
 	List.hd rel, c
     in
     let argty = pf_type_of gl arg in
-    let argty = refresh_universes_strict argty in 
-    let ty = refresh_universes_strict ty in
+    let ty = (* refresh_universes_strict *) ty in
     let lenctx = List.length ctx in
     let liftargty = lift lenctx argty in
     let leq = constr_cmp Reduction.CUMUL liftargty ty in
       match kind_of_term arg with
-      | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) ->
+      | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) ->
       	  (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls,
-      	  Idset.add id nongenvars, Idset.remove id vars, env)
+      	  Id.Set.add id nongenvars, Id.Set.remove id vars, env)
       | _ ->
 	  let name = get_id name in
 	  let decl = (Name name, None, ty) in
@@ -2437,28 +3230,28 @@ let abstract_args gl generalize_vars dep id defined f args =
 	  let eqs = eq :: lift_list eqs in
 	  let refls = refl :: refls in
 	  let argvars = ids_of_constr vars arg in
-	    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, 
-	    nongenvars, Idset.union argvars vars, env)
-  in 
+	    (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls,
+	    nongenvars, Id.Set.union argvars vars, env)
+  in
   let f', args' = decompose_indapp f args in
   let dogen, f', args' =
-    let parvars = ids_of_constr ~all:true Idset.empty f' in
+    let parvars = ids_of_constr ~all:true Id.Set.empty f' in
       if not (linear parvars args') then true, f, args
       else
-	match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with
+	match Array.findi (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with
 	| None -> false, f', args'
 	| Some nonvar ->
-	    let before, after = array_chop nonvar args' in
+	    let before, after = Array.chop nonvar args' in
 	      true, mkApp (f', before), after
   in
     if dogen then
-      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = 
-	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Idset.empty,Idset.empty,env) args'
+      let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env =
+	Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args'
       in
       let args, refls = List.rev args, List.rev refls in
-      let vars = 
+      let vars =
 	if generalize_vars then
-	  let nogen = Idset.add id nogen in
+	  let nogen = Id.Set.add id nogen in
 	    hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars
 	else []
       in
@@ -2466,38 +3259,41 @@ let abstract_args gl generalize_vars dep id defined f args =
 	Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls,
 	     dep, succ (List.length ctx), vars)
     else None
-      
-let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id gl =
-  Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
-  let f, args, def, id, oldid = 
-    let oldid = pf_get_new_id id gl in
-    let (_, b, t) = pf_get_hyp gl id in
+
+let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id =
+  Proofview.Goal.nf_enter begin fun gl ->
+  Coqlib.check_required_library Coqlib.jmeq_module_name;
+  let (f, args, def, id, oldid) =
+    let oldid = Tacmach.New.pf_get_new_id id gl in
+    let (_, b, t) = Tacmach.New.pf_get_hyp id gl in
       match b with
       | None -> let f, args = decompose_app t in
-		  f, args, false, id, oldid
-      | Some t -> 
+	        (f, args, false, id, oldid)
+      | Some t ->
 	  let f, args = decompose_app t in
-	    f, args, true, id, oldid
+	  (f, args, true, id, oldid)
   in
-  if args = [] then tclIDTAC gl
-  else 
+  if List.is_empty args then Proofview.tclUNIT ()
+  else
     let args = Array.of_list args in
-    let newc = abstract_args gl generalize_vars force_dep id def f args in
+    let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in
       match newc with
-      | None -> tclIDTAC gl
-      | Some (newc, dep, n, vars) -> 
+      | None -> Proofview.tclUNIT ()
+      | Some (newc, dep, n, vars) ->
 	  let tac =
 	    if dep then
-	      tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; 
-			   generalize_dep ~with_let:true (mkVar oldid)]	      
+	      Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro;
+			   Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))]
 	    else
-	      tclTHENLIST [refine newc; clear [id]; tclDO n intro]
-	  in 
-	    if vars = [] then tac gl
-	    else tclTHEN tac 
-	      (fun gl -> tclFIRST [revert vars ;
-				   tclMAP (fun id -> 
-				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl
+	      Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); Proofview.V82.tactic (clear [id]); Tacticals.New.tclDO n intro]
+	  in
+	    if List.is_empty vars then tac
+	    else Tacticals.New.tclTHEN tac
+              (Tacticals.New.tclFIRST
+                [revert vars ;
+		 Proofview.V82.tactic (fun gl -> tclMAP (fun id ->
+				     tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)])
+  end
 
 let rec compare_upto_variables x y =
   if (isVar x || isRel x) && (isVar y || isRel y) then true
@@ -2507,34 +3303,34 @@ let specialize_eqs id gl =
   let env = pf_env gl in
   let ty = pf_get_hyp_typ gl id in
   let evars = ref (project gl) in
-  let unif env evars c1 c2 = 
-    compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 
+  let unif env evars c1 c2 =
+    compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2
   in
   let rec aux in_eqs ctx acc ty =
     match kind_of_term ty with
-    | Prod (na, t, b) -> 
+    | Prod (na, t, b) ->
 	(match kind_of_term t with
-	| App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) ->
+	| App (eq, [| eqty; x; y |]) when Term.eq_constr (Lazy.force coq_eq) eq ->
 	    let c = if noccur_between 1 (List.length ctx) x then y else x in
 	    let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
 	    let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
 	      if unif (push_rel_context ctx env) evars pt t then
 		aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
 	      else acc, in_eqs, ctx, ty
-	| App (heq, [| eqty; x; eqty'; y |]) when eq_constr heq (Lazy.force coq_heq) ->
+	| App (heq, [| eqty; x; eqty'; y |]) when Term.eq_constr heq (Lazy.force coq_heq) ->
 	    let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in
 	    let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in
 	    let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in
 	      if unif (push_rel_context ctx env) evars pt t then
 		aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
 	      else acc, in_eqs, ctx, ty
-	| _ -> 
+	| _ ->
 	    if in_eqs then acc, in_eqs, ctx, ty
-	    else 
-	      let e = e_new_evar evars (push_rel_context ctx env) t in
+	    else
+	      let e = e_new_evar (push_rel_context ctx env) evars t in
 		aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b)
     | t -> acc, in_eqs, ctx, ty
-  in 
+  in
   let acc, worked, ctx, ty = aux false [] (mkVar id) ty in
   let ctx' = nf_rel_context_evar !evars ctx in
   let ctx'' = List.map (fun (n,b,t as decl) ->
@@ -2544,38 +3340,27 @@ let specialize_eqs id gl =
   in
   let ty' = it_mkProd_or_LetIn ty ctx'' in
   let acc' = it_mkLambda_or_LetIn acc ctx'' in
-  let ty' = Tacred.whd_simpl env !evars ty' 
+  let ty' = Tacred.whd_simpl env !evars ty'
   and acc' = Tacred.whd_simpl env !evars acc' in
   let ty' = Evarutil.nf_evar !evars ty' in
     if worked then
       tclTHENFIRST (Tacmach.internal_cut true id ty')
-	(exact_no_check (refresh_universes_strict acc')) gl
+	(exact_no_check ((* refresh_universes_strict *) acc')) gl
     else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl
-      
+
 
 let specialize_eqs id gl =
   if
     (try ignore(clear [id] gl); false
      with e when Errors.noncritical e -> true)
   then
-    tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl 
+    tclFAIL 0 (str "Specialization not allowed on dependent hypotheses") gl
   else specialize_eqs id gl
 
 let occur_rel n c =
   let res = not (noccurn n c) in
   res
 
-(* cuts a list in two parts, first of size n. Size must be greater than n *)
-let cut_list n l =
-  let rec cut_list_aux acc n l =
-    if n<=0 then acc,l
-    else match l with
-      | [] -> assert false
-      | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in
-  let res = cut_list_aux [] n l in
-  res
-
-
 (* This function splits the products of the induction scheme [elimt] into four
    parts:
    - branches, easily detectable (they are not referred by rels in the subterm)
@@ -2607,39 +3392,20 @@ let decompose_paramspred_branch_args elimt =
      type (See for example Empty_set_ind, as False would actually be ok). Then
      we must find the predicate of the conclusion to separate params_pred from
      args. We suppose there is only one predicate here. *)
-  if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl
-  else
+  match acc2 with
+  | [] ->
     let hyps,ccl = decompose_prod_assum elimt in
     let hd_ccl_pred,_ = decompose_app ccl in
-    match kind_of_term hd_ccl_pred with
-      | Rel i  -> let acc3,acc1 = cut_list (i-1) hyps in acc1 , [] , acc3 , ccl
+    begin match kind_of_term hd_ccl_pred with
+      | Rel i  -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl
       | _ -> error_ind_scheme ""
+    end
+  | _ -> acc1, acc2 , acc3, ccl
 
 
 let exchange_hd_app subst_hd t =
   let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args)
 
-
-
-(* [rebuild_elimtype_from_scheme scheme] rebuilds the type of an
-   eliminator from its [scheme_info]. The idea is to build variants of
-   eliminator by modifying their scheme_info, then rebuild the
-   eliminator type, then prove it (with tactics). *)
-let rebuild_elimtype_from_scheme (scheme:elim_scheme): types =
-  let hiconcl =
-    match scheme.indarg with
-      | None -> scheme.concl
-      | Some x -> mkProd_or_LetIn x scheme.concl in
-  let xihiconcl = it_mkProd_or_LetIn hiconcl scheme.args in
-  let brconcl = it_mkProd_or_LetIn xihiconcl scheme.branches in
-  let predconcl = it_mkProd_or_LetIn brconcl scheme.predicates in
-  let paramconcl = it_mkProd_or_LetIn predconcl scheme.params in
-  paramconcl
-
-
-exception NoLastArg
-exception NoLastArgCcl
-
 (* Builds an elim_scheme from its type and calling form (const+binding). We
    first separate branches.  We obtain branches, hyps before (params + preds),
    hyps after (args <+ indarg if present>) and conclusion.  Then we proceed as
@@ -2660,10 +3426,10 @@ let compute_elim_sig ?elimc elimt =
   let params_preds,branches,args_indargs,conclusion =
     decompose_paramspred_branch_args elimt in
 
-  let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in
+  let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in
   let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in
-  let nparams = Intset.cardinal (free_rels concl_with_args) in
-  let preds,params = cut_list (List.length params_preds - nparams) params_preds in
+  let nparams = Int.Set.cardinal (free_rels concl_with_args) in
+  let preds,params = List.chop (List.length params_preds - nparams) params_preds in
 
   (* A first approximation, further analysis will tweak it *)
   let res = ref { empty_scheme with
@@ -2686,7 +3452,7 @@ let compute_elim_sig ?elimc elimt =
       raise Exit
     end;
     (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *)
-    if !res.nargs=0 then raise Exit;
+    if Int.equal !res.nargs 0 then raise Exit;
     (* 3- Look at last arg: is it the indarg? *)
     ignore (
       match List.hd args_indargs with
@@ -2701,9 +3467,9 @@ let compute_elim_sig ?elimc elimt =
 		| Construct _ -> true
 		| _ -> false in
 	    let hi_args_enough = (* hi a le bon nbre d'arguments *)
-	      List.length hi_args = List.length params + !res.nargs -1 in
+	      Int.equal (List.length hi_args) (List.length params + !res.nargs -1) in
 	    (* FIXME: Ces deux tests ne sont pas suffisants. *)
-	    if not (hi_is_ind & hi_args_enough) then raise Exit (* No indarg *)
+	    if not (hi_is_ind && hi_args_enough) then raise Exit (* No indarg *)
 	    else (* Last arg is the indarg *)
 	      res := {!res with
 		indarg = Some (List.hd !res.args);
@@ -2712,7 +3478,7 @@ let compute_elim_sig ?elimc elimt =
 	      };
 	    raise Exit);
     raise Exit(* exit anyway *)
-  with Exit -> (* Ending by computing indrev: *)
+  with Exit -> (* Ending by computing indref: *)
     match !res.indarg with
       | None -> !res (* No indref *)
       | Some ( _,Some _,_) -> error_ind_scheme ""
@@ -2720,7 +3486,7 @@ let compute_elim_sig ?elimc elimt =
 	  let indhd,indargs = decompose_app ind in
 	  try {!res with indref = Some (global_of_constr indhd) }
 	  with e when Errors.noncritical e ->
-            error "Cannot find the inductive type of the inductive scheme.";;
+            error "Cannot find the inductive type of the inductive scheme."
 
 let compute_scheme_signature scheme names_info ind_type_guess =
   let f,l = decompose_app scheme.concl in
@@ -2730,26 +3496,26 @@ let compute_scheme_signature scheme names_info ind_type_guess =
       | Some (_,Some _,_) ->
 	  error "Strange letin, cannot recognize an induction scheme."
       | None -> (* Non standard scheme *)
-	  let cond hd = eq_constr hd ind_type_guess && not scheme.farg_in_concl
+	  let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl
 	  in (cond, fun _ _ -> ())
       | Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
 	  let indhd,indargs = decompose_app ind in
-	  let cond hd = eq_constr hd indhd in
+	  let cond hd = Term.eq_constr hd indhd in
 	  let check_concl is_pred p =
 	    (* Check again conclusion *)
-	    let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in
+	    let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in
 	    let ind_is_ok =
-	      list_equal eq_constr
-		(list_lastn scheme.nargs indargs)
+	      List.equal Term.eq_constr
+		(List.lastn scheme.nargs indargs)
 		(extended_rel_list 0 scheme.args) in
-	    if not (ccl_arg_ok & ind_is_ok) then
+	    if not (ccl_arg_ok && ind_is_ok) then
 	      error_ind_scheme "the conclusion of"
 	  in (cond, check_concl)
   in
   let is_pred n c =
     let hd = fst (decompose_app c) in
     match kind_of_term hd with
-      | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
+      | Rel q when n < q && q <= n+scheme.npredicates -> IndArg
       | _ when cond hd -> RecArg
       | _ -> OtherArg
   in
@@ -2759,7 +3525,7 @@ let compute_scheme_signature scheme names_info ind_type_guess =
 	(is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c
       | LetIn (_,_,_,c) ->
 	(OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c
-      | _ when is_pred p c = IndArg -> []
+      | _ when is_pred p c == IndArg -> []
       | _ -> raise Exit
   in
   let rec find_branches p lbrch =
@@ -2768,12 +3534,12 @@ let compute_scheme_signature scheme names_info ind_type_guess =
 	(try
 	   let lchck_brch = check_branch p t in
 	   let n = List.fold_left
-	     (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in
+	     (fun n (b,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in
 	   let recvarname, hyprecname, avoid =
 	     make_up_names n scheme.indref names_info in
 	   let namesign =
 	     List.map (fun (b,dep) ->
-	       (b,dep,if b=IndArg then hyprecname else recvarname))
+	       (b, dep, if b == IndArg then hyprecname else recvarname))
 	       lchck_brch in
 	   (avoid,namesign) :: find_branches (p+1) brs
 	 with Exit-> error_ind_scheme "the branches of")
@@ -2789,88 +3555,80 @@ let compute_scheme_signature scheme names_info ind_type_guess =
    extra final argument of the form (f x y ...) in the conclusion. In
    the non standard case, naming of generated hypos is slightly
    different. *)
-let compute_elim_signature ((elimc,elimt),ind_type_guess) names_info =
+let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info =
   let scheme = compute_elim_sig ~elimc:elimc elimt in
-  compute_scheme_signature scheme names_info ind_type_guess, scheme
-
-let guess_elim isrec hyp0 gl =
-  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
-  let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
-  let s = elimination_sort_of_goal gl in
-  let elimc =
-    if isrec then lookup_eliminator mind s
+    evd, (compute_scheme_signature scheme names_info ind_type_guess, scheme)
+
+let guess_elim isrec dep s hyp0 gl =
+  let tmptyp0 =	Tacmach.New.pf_get_hyp_typ hyp0 gl in
+  let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in
+  let evd, elimc =
+    if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl
     else
-      if use_dependent_propositions_elimination () &&
-	dependent_no_evar (mkVar hyp0) (pf_concl gl)
+      if use_dependent_propositions_elimination () && dep
       then
-	pf_apply build_case_analysis_scheme gl mind true s
+	Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s
       else
-	pf_apply build_case_analysis_scheme_default gl mind s in
-  let elimt = pf_type_of gl elimc in
-  ((elimc, NoBindings), elimt), mkInd mind
+	Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in
+  let elimt = Tacmach.New.pf_type_of gl elimc in
+    evd, ((elimc, NoBindings), elimt), mkIndU mind
 
 let given_elim hyp0 (elimc,lbind as e) gl =
-  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+  let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in
   let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in
-  (e, pf_type_of gl elimc), ind_type_guess
-
-let find_elim isrec elim hyp0 gl =
-  match elim with
-    | None -> guess_elim isrec hyp0 gl
-    | Some e -> given_elim hyp0 e gl
+  Proofview.Goal.sigma gl, (e, Tacmach.New.pf_type_of gl elimc), ind_type_guess
 
 type scheme_signature =
-    (identifier list * (elim_arg_kind * bool * identifier) list) array
+    (Id.t list * (elim_arg_kind * bool * Id.t) list) array
 
 type eliminator_source =
   | ElimUsing of (eliminator * types) * scheme_signature
-  | ElimOver of bool * identifier
+  | ElimOver of bool * Id.t
 
 let find_induction_type isrec elim hyp0 gl =
   let scheme,elim =
     match elim with
     | None ->
-	let (elimc,elimt),_ = guess_elim isrec hyp0 gl in
+       let sort = Tacticals.New.elimination_sort_of_goal gl in
+       let _, (elimc,elimt),_ = 
+	 guess_elim isrec (* dummy: *) true sort hyp0 gl in
 	let scheme = compute_elim_sig ~elimc elimt in
 	(* We drop the scheme waiting to know if it is dependent *)
 	scheme, ElimOver (isrec,hyp0)
     | Some e ->
-	let (elimc,elimt),ind_guess = given_elim hyp0 e gl in
+	let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in
 	let scheme = compute_elim_sig ~elimc elimt in
-	if scheme.indarg = None then error "Cannot find induction type";
+	if Option.is_empty scheme.indarg then error "Cannot find induction type";
 	let indsign = compute_scheme_signature scheme hyp0 ind_guess in
-	let elim = ({elimindex = Some(-1); elimbody = elimc},elimt) in
+	let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in
 	scheme, ElimUsing (elim,indsign) in
-  Option.get scheme.indref,scheme.nparams, elim
+  (Option.get scheme.indref,scheme.nparams, elim)
 
-let find_elim_signature isrec elim hyp0 gl =
-  compute_elim_signature (find_elim isrec elim hyp0 gl) hyp0
+let get_elim_signature elim hyp0 gl =
+  compute_elim_signature (given_elim hyp0 elim gl) hyp0
 
-let is_functional_induction elim gl =
-  match elim with
-  | Some elimc ->
-      let scheme = compute_elim_sig ~elimc (pf_type_of gl (fst elimc)) in
-      (* The test is not safe: with non-functional induction on non-standard
-         induction scheme, this may fail *)
-      scheme.indarg = None
-  | None ->
-      false
+let is_functional_induction elimc gl =
+  let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_type_of gl (fst elimc)) in
+  (* The test is not safe: with non-functional induction on non-standard
+     induction scheme, this may fail *)
+  Option.is_empty scheme.indarg
 
 (* Wait the last moment to guess the eliminator so as to know if we
    need a dependent one or not *)
 
-let get_eliminator elim gl = match elim with
+let get_eliminator elim dep s gl = match elim with
   | ElimUsing (elim,indsign) ->
-      (* bugged, should be computed *) true, elim, indsign
+      Proofview.Goal.sigma gl, (* bugged, should be computed *) true, elim, indsign
   | ElimOver (isrec,id) ->
-      let (elimc,elimt),_ as elims = guess_elim isrec id gl in
-      isrec, ({elimindex = None; elimbody = elimc}, elimt),
-      fst (compute_elim_signature elims id)
+      let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in
+      let _, (l, s) = compute_elim_signature elims id in
+      let branchlengthes = List.map (fun (_,b,c) -> assert (b=None); pi1 (decompose_prod_letin c)) (List.rev s.branches) in
+      evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l
 
 (* Instantiate all meta variables of elimclause using lid, some elts
    of lid are parameters (first ones), the other are
    arguments. Returns the clause obtained.  *)
-let recolle_clenv nparams lid elimclause gl =
+let recolle_clenv i params args elimclause gl =
   let _,arr = destApp elimclause.templval.rebus in
   let lindmv =
     Array.map
@@ -2880,18 +3638,14 @@ let recolle_clenv nparams lid elimclause gl =
 	  | _  -> errorlabstrm "elimination_clause"
               (str "The type of the elimination clause is not well-formed."))
       arr in
-  let nmv = Array.length lindmv in
-  let lidparams,lidargs = cut_list nparams lid in
-  let nidargs = List.length lidargs in
+  let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in
   (* parameters correspond to first elts of lid. *)
   let clauses_params =
-    list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
-      0 lidparams in
-  (* arguments correspond to last elts of lid. *)
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
+      0 params in
   let clauses_args =
-    list_map_i
-      (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
-      0 lidargs in
+    List.map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(k+i))
+      0 args in
   let clauses = clauses_params@clauses_args in
   (* iteration of clenv_fchain with all infos we have. *)
   List.fold_right
@@ -2910,306 +3664,411 @@ let recolle_clenv nparams lid elimclause gl =
    (elimc ?i ?j ?k...?l). This solves partly meta variables (and may
     produce new ones). Then refine with the resulting term with holes.
 *)
-let induction_tac_felim with_evars indvars nparams elim gl =
-  let {elimbody=(elimc,lbindelimc)},elimt = elim in
+let induction_tac with_evars params indvars elim gl =
+  let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in
+  let i = match i with None -> index_of_ind_arg elimt | Some i -> i in
   (* elimclause contains this: (elimc ?i ?j ?k...?l) *)
+  let elimc = mkCast (elimc, DEFAULTcast, elimt) in
   let elimclause =
-    make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in
+    pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in
   (* elimclause' is built from elimclause by instanciating all args and params. *)
-  let elimclause' = recolle_clenv nparams indvars elimclause gl in
+  let elimclause' = recolle_clenv i params indvars elimclause gl in
   (* one last resolution (useless?) *)
-  let resolved = clenv_unique_resolver ~flags:elim_flags elimclause' gl in
-  clenv_refine with_evars resolved gl
+  let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in
+  Proofview.V82.of_tactic (enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved)) gl
 
-(* Apply induction "in place" replacing the hypothesis on which
+(* Apply induction "in place" taking into account dependent
+   hypotheses from the context, replacing the main hypothesis on which
    induction applies with the induction hypotheses *)
 
-let apply_induction_with_discharge induct_tac elim indhyps destopt avoid names tac gl =
-  let isrec, elim, indsign = get_eliminator elim gl in
-  let names = compute_induction_names (Array.length indsign) names in
-  (if isrec then tclTHENFIRSTn else tclTHENLASTn)
-    (tclTHEN
-       (induct_tac elim)
-       (tclMAP (fun id -> tclTRY (expand_hyp id)) (List.rev indhyps)))
-    (array_map2 (induct_discharge destopt avoid tac) indsign names) gl
+let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac =
+  Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    let concl = Tacmach.New.pf_nf_concl gl in
+    let statuslists,lhyp0,toclear,deps,avoid,dep = cook_sign hyp0 inhyps indvars env in
+    let dep = dep || Option.cata (fun id -> occur_var env id concl) false hyp0 in
+    let tmpcl = it_mkNamedProd_or_LetIn concl deps in
+    let s = Retyping.get_sort_family_of env sigma tmpcl in
+    let deps_cstr =
+      List.fold_left
+        (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in
+    let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in
+    let names = compute_induction_names (Array.length indsign) names in
+    (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn)
+      (Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma;
+        (* Generalize dependent hyps (but not args) *)
+        if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr);
+        (* side-conditions in elim (resp case) schemes come last (resp first) *)
+        induct_tac elim;
+        Proofview.V82.tactic (tclMAP expand_hyp toclear)
+      ])
+      (Array.map2
+         (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists))
+         indsign names)
+  end
 
-(* Apply induction "in place" taking into account dependent
-   hypotheses from the context *)
+let induction_with_atomization_of_ind_arg isrec with_evars elim names hyp0 inhyps =
+  Proofview.Goal.enter begin fun gl ->
+  let elim_info = find_induction_type isrec elim hyp0 (Proofview.Goal.assume gl) in
+  atomize_param_of_ind_then elim_info hyp0 (fun indvars ->
+    apply_induction_in_context (Some hyp0) inhyps (pi3 elim_info) indvars names
+      (fun elim -> Proofview.V82.tactic (induction_tac with_evars [] [hyp0] elim)))
+  end
 
-let apply_induction_in_context hyp0 elim indvars names induct_tac gl =
-  let env = pf_env gl in
-  let statuslists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
-  let deps = List.map (on_pi3 refresh_universes_strict) deps in
-  let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
-  let dephyps = List.map (fun (id,_,_) -> id) deps in
-  let deps_cstr =
-    List.fold_left
-      (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
-  tclTHENLIST
-    [
-      (* Generalize dependent hyps (but not args) *)
-      if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
-      (* clear dependent hyps *)
-      thin dephyps;
-      (* side-conditions in elim (resp case) schemes come last (resp first) *)
-      apply_induction_with_discharge
-	induct_tac elim (List.rev indhyps) lhyp0 (List.rev dephyps) names
-        (re_intro_dependent_hypotheses statuslists)
-    ]
-    gl
+let msg_not_right_number_induction_arguments scheme =
+  str"Not the right number of induction arguments (expected " ++
+  pr_enum (fun x -> x) [
+    if scheme.farg_in_concl then str "the function name" else mt();
+    if scheme.nparams != 0 then int scheme.nparams ++ str (String.plural scheme.nparams " parameter") else mt ();
+    if scheme.nargs != 0 then int scheme.nargs ++ str (String.plural scheme.nargs " argument") else mt ()] ++ str ")."
 
-(* Induction with several induction arguments, main differences with
-   induction_from_context is that there is no main induction argument,
-   so we choose one to be the positioning reference. On the other hand,
-   all args and params must be given, so we help a bit the unifier by
-   making the "pattern" by hand before calling induction_tac_felim
-   FIXME: REUNIF AVEC induction_tac_felim? *)
-let induction_from_context_l with_evars elim_info lid names gl =
-  let indsign,scheme = elim_info in
-  (* number of all args, counting farg and indarg if present. *)
-  let nargs_indarg_farg = scheme.nargs
-    + (if scheme.farg_in_concl then 1 else 0)
-    + (if scheme.indarg <> None then 1 else 0) in
-  (* Number of given induction args must be exact. *)
-  if List.length lid <> nargs_indarg_farg + scheme.nparams then
-      error "Not the right number of arguments given to induction scheme.";
-  (* hyp0 is used for re-introducing hyps at the right place afterward.
-     We chose the first element of the list of variables on which to
-     induct. It is probably the first of them appearing in the
-     context. *)
-  let hyp0,indvars,lid_params =
-    match lid with
-      | []  -> anomaly "induction_from_context_l"
-      | e::l ->
-	  let nargs_without_first = nargs_indarg_farg - 1 in
-	  let ivs,lp = cut_list nargs_without_first l in
-	  e, ivs, lp in
+(* Induction on a list of induction arguments. Analyze the elim
+   scheme (which is mandatory for multiple ind args), check that all
+   parameters and arguments are given (mandatory too).
+   Main differences with induction_from_context is that there is no
+   main induction argument. On the other hand, all args and params
+   must be given, so we help a bit the unifier by making the "pattern"
+   by hand before calling induction_tac *)
+let induction_without_atomization isrec with_evars elim names lid =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in
+  let nargs_indarg_farg =
+    scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in
+  if not (Int.equal (List.length lid) (scheme.nparams + nargs_indarg_farg))
+  then
+    Tacticals.New.tclZEROMSG (msg_not_right_number_induction_arguments scheme)
+  else
+  let indvars,lid_params = List.chop nargs_indarg_farg lid in
   (* terms to patternify we must patternify indarg or farg if present in concl *)
-  let lid_in_pattern =
-    if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars
-    else List.rev (hyp0::indvars) in
-  let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in
-  let realindvars = (* hyp0 is a real induction arg if it is not the
-		       farg in the conclusion of the induction scheme *)
-    List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in
-  let induct_tac elim = tclTHENLIST [
+  let realindvars = List.rev (if scheme.farg_in_concl then List.tl indvars else indvars) in
+  let lidcstr = List.map mkVar (List.rev indvars) in
+  let params = List.rev lid_params in
+  let indvars =
+    (* Temporary hack for compatibility, while waiting for better
+       analysis of the form of induction schemes: a scheme like
+       gt_wf_rec was taken as a functional scheme with no parameters,
+       but by chance, because of the addition of at least hyp0 for
+       cook_sign, it behaved as if there was a real induction arg. *)
+    if indvars = [] then [List.hd lid_params] else indvars in
+  let induct_tac elim = Proofview.V82.tactic (tclTHENLIST [
     (* pattern to make the predicate appear. *)
     reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
     (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
        possible holes using arguments given by the user (but the
        functional one). *)
     (* FIXME: Tester ca avec un principe dependant et non-dependant *)
-    induction_tac_felim with_evars realindvars scheme.nparams elim
-  ] in
-  let elim = ElimUsing (({elimindex = Some scheme.index; elimbody = Option.get scheme.elimc}, scheme.elimt), indsign) in
-  apply_induction_in_context
-    None elim (hyp0::indvars) names induct_tac gl
-
-(* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the
-   hypothesis on which the induction is made *)
-let induction_tac with_evars elim (varname,lbind) typ gl =
-  let ({elimindex=i;elimbody=(elimc,lbindelimc)},elimt) = elim in
-  let indclause = make_clenv_binding gl (mkVar varname,typ) lbind  in
-  let i = match i with None -> index_of_ind_arg elimt | Some i -> i in
-  let elimclause =
-    make_clenv_binding gl
-      (mkCast (elimc,DEFAULTcast,elimt),elimt) lbindelimc in
-  elimination_clause_scheme with_evars i elimclause indclause gl
-
-let induction_from_context isrec with_evars (indref,nparams,elim) (hyp0,lbind) names
-  inhyps gl =
-  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
-  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
-  let indvars = find_atomic_param_of_ind nparams ((strip_prod typ0)) in
-  let induct_tac elim = tclTHENLIST [
-    induction_tac with_evars elim (hyp0,lbind) typ0;
-    tclTRY (unfold_body hyp0);
-    thin [hyp0]
-  ] in
-  apply_induction_in_context
-    (Some (hyp0,inhyps)) elim indvars names induct_tac gl
-
-let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbind) inhyps gl =
-  let elim_info = find_induction_type isrec elim hyp0 gl in
-  tclTHEN
-    (atomize_param_of_ind elim_info hyp0)
-    (induction_from_context isrec with_evars elim_info
-      (hyp0,lbind) names inhyps) gl
-
-(* Induction on a list of induction arguments. Analyse the elim
-   scheme (which is mandatory for multiple ind args), check that all
-   parameters and arguments are given (mandatory too). *)
-let induction_without_atomization isrec with_evars elim names lid gl =
-  let (indsign,scheme as elim_info) =
-    find_elim_signature isrec elim (List.hd lid) gl in
-  let awaited_nargs =
-    scheme.nparams + scheme.nargs
-    + (if scheme.farg_in_concl then 1 else 0)
-    + (if scheme.indarg <> None then 1 else 0)
-  in
-  let nlid = List.length lid in
-  if nlid <> awaited_nargs
-  then error "Not the right number of induction arguments."
-  else induction_from_context_l with_evars elim_info lid names gl
-
-let has_selected_occurrences = function
-  | None -> false
-  | Some cls ->
-      cls.concl_occs <> all_occurrences_expr ||
-	cls.onhyps <> None && List.exists (fun ((occs,_),hl) ->
-          occs <> all_occurrences_expr || hl <> InHyp) (Option.get cls.onhyps)
+    induction_tac with_evars params realindvars elim
+  ]) in
+  let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in
+  apply_induction_in_context None [] elim indvars names induct_tac
+  end
 
 (* assume that no occurrences are selected *)
 let clear_unselected_context id inhyps cls gl =
-  match cls with
+  if occur_var (pf_env gl) id (pf_concl gl) &&
+    cls.concl_occs == NoOccurrences
+  then errorlabstrm ""
+    (str "Conclusion must be mentioned: it depends on " ++ pr_id id
+     ++ str ".");
+  match cls.onhyps with
+  | Some hyps ->
+      let to_erase (id',_,_ as d) =
+	if Id.List.mem id' inhyps then (* if selected, do not erase *) None
+	else
+	  (* erase if not selected and dependent on id or selected hyps *)
+	  let test id = occur_var_in_decl (pf_env gl) id d in
+	  if List.exists test (id::inhyps) then Some id' else None in
+      let ids = List.map_filter to_erase (pf_hyps gl) in
+      thin ids gl
   | None -> tclIDTAC gl
-  | Some cls ->
-      if occur_var (pf_env gl) id (pf_concl gl) &&
-	 cls.concl_occs = no_occurrences_expr
-      then errorlabstrm ""
-	    (str "Conclusion must be mentioned: it depends on " ++ pr_id id
-	     ++ str ".");
-      match cls.onhyps with
-      | Some hyps ->
-	  let to_erase (id',_,_ as d) =
-	    if List.mem id' inhyps then (* if selected, do not erase *) None
-	    else
-	      (* erase if not selected and dependent on id or selected hyps *)
-	      let test id = occur_var_in_decl (pf_env gl) id d in
-	      if List.exists test (id::inhyps) then Some id' else None in
-	  let ids = list_map_filter to_erase (pf_hyps gl) in
-	  thin ids gl
-      | None -> tclIDTAC gl
-
-let new_induct_gen isrec with_evars elim (eqname,names) (sigma,(c,lbind)) cls gl =
+
+let use_bindings env sigma elim (c,lbind) typ =
+  let typ =
+    if elim == None then
+      (* w/o an scheme, the term has to be applied at least until
+         obtaining an inductive type (even though the arity might be
+         known only by pattern-matching, as in the case of a term of
+         the form "nat_rect ?A ?o ?s n", with ?A to be inferred by
+         matching. *)
+      let sign,t = splay_prod env sigma typ in it_mkProd t sign
+    else
+      (* Otherwise, we exclude the case of an induction argument in an
+         explicitly functional type. Henceforth, we can complete the
+         pattern until it has as type an atomic type (even though this
+         atomic type can hide a functional type, for which the "using"
+         clause has a scheme). *)
+      typ in
+  let rec find_clause typ =
+    try
+      let indclause = make_clenv_binding env sigma (c,typ) lbind in
+      (* We lose the possibility of coercions in with-bindings *)
+      pose_all_metas_as_evars env indclause.evd (clenv_value indclause)
+    with e when catchable_exception e ->
+    try find_clause (try_red_product env sigma typ)
+    with Redelimination -> raise e in
+  find_clause typ
+
+let check_expected_type env sigma (elimc,bl) elimt =
+  (* Compute the expected template type of the term in case a using
+     clause is given *)
+  let sign,_ = splay_prod env sigma elimt in
+  let n = List.length sign in
+  if n == 0 then error "Scheme cannot be applied.";
+  let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in
+  let sigma = solve_evar_clause env sigma true cl bl in
+  let (_,u,_) = destProd cl.cl_concl in
+  fun t -> Evarconv.e_cumul env (ref sigma) t u
+
+let check_enough_applied env sigma elim =
+  (* A heuristic to decide whether the induction arg is enough applied *)
+  match elim with
+  | None ->
+      (* No eliminator given *)
+      fun u ->
+      let t,_ = decompose_app (whd_betadeltaiota env sigma u) in isInd t
+  | Some elimc ->
+      let elimt = typ_of env sigma (fst elimc) in
+      let scheme = compute_elim_sig ~elimc elimt in
+      match scheme.indref with
+      | None ->
+         (* in the absence of information, do not assume it may be
+            partially applied *)
+          fun _ -> true
+      | Some _ ->
+          (* Last argument is supposed to be the induction argument *)
+          check_expected_type env sigma elimc elimt
+
+let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim
+     id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac =
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ccl = Proofview.Goal.raw_concl gl in
+  let store = Proofview.Goal.extra gl in
+  let check = check_enough_applied env sigma elim in
+  let (sigma',c) = use_bindings env sigma elim (c0,lbind) t0 in
+  let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in
+  let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in
+  match res with
+  | None ->
+      (* pattern not found *)
+      let with_eq = Option.map (fun eq -> (false,eq)) eqname in
+      (* we restart using bindings after having tried type-class
+         resolution etc. on the term given by the user *)
+      let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in
+      let (sigma,c0) = finish_evar_resolution ~flags env sigma (pending,c0) in
+      (if isrec then
+          (* Historically, induction has side conditions last *)
+          Tacticals.New.tclTHENFIRST
+       else
+          (* and destruct has side conditions first *)
+          Tacticals.New.tclTHENLAST)
+      (Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma;
+        Proofview.Refine.refine ~unsafe:true (fun sigma ->
+          let (sigma,c) = use_bindings env sigma elim (c0,lbind) t0 in
+          let t = Retyping.get_type_of env sigma c in
+          mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t));
+        Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable);
+        if is_arg_pure_hyp
+        then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0]))
+        else Proofview.tclUNIT ();
+        if isrec then Proofview.cycle (-1) else Proofview.tclUNIT ()
+      ])
+      tac
+
+  | Some (sigma',c) ->
+      (* pattern found *)
+      let with_eq = Option.map (fun eq -> (false,eq)) eqname in
+      (* TODO: if ind has predicate parameters, use JMeq instead of eq *)
+      let env = reset_with_named_context sign env in
+      Tacticals.New.tclTHENLIST [
+        Proofview.Unsafe.tclEVARS sigma';
+        Proofview.Refine.refine ~unsafe:true (fun sigma ->
+          mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None);
+        tac
+      ]
+  end
+
+let has_generic_occurrences_but_goal cls id env ccl =
+  clause_with_generic_context_selection cls &&
+  (* TODO: whd_evar of goal *)
+  (cls.concl_occs != NoOccurrences || not (occur_var env id ccl))
+
+let induction_gen clear_flag isrec with_evars elim
+    ((_pending,(c,lbind)),(eqname,names) as arg) cls =
   let inhyps = match cls with
   | Some {onhyps=Some hyps} -> List.map (fun ((_,id),_) -> id) hyps
   | _ -> [] in
-  match kind_of_term c with
-    | Var id when not (mem_named_context id (Global.named_context()))
-	        & lbind = NoBindings & not with_evars & eqname = None
-                & not (has_selected_occurrences cls) ->
-	tclTHEN
-          (clear_unselected_context id inhyps cls)
-	  (induction_with_atomization_of_ind_arg
-	    isrec with_evars elim names (id,lbind) inhyps) gl
-    | _        ->
-	let x = id_of_name_using_hdchar (Global.env()) (typ_of (pf_env gl) sigma c)
-		  Anonymous in
-	let id = fresh_id [] x gl in
-	(* We need the equality name now *)
-	let with_eq = Option.map (fun eq -> (false,eq)) eqname in
-	(* TODO: if ind has predicate parameters, use JMeq instead of eq *)
-	tclTHEN
-          (* Warning: letin is buggy when c is not of inductive type *)
-	  (letin_tac_gen with_eq (Name id) (sigma,c)
-             (make_pattern_test (pf_env gl) (project gl) (sigma,c))
-             None (Option.default allHypsAndConcl cls,false))
-	  (induction_with_atomization_of_ind_arg
-	     isrec with_evars elim names (id,lbind) inhyps) gl
+  Proofview.Goal.enter begin fun gl ->
+  let env = Proofview.Goal.env gl in
+  let sigma = Proofview.Goal.sigma gl in
+  let ccl = Proofview.Goal.raw_concl gl in
+  let cls = Option.default allHypsAndConcl cls in
+  let t = typ_of env sigma c in
+  let is_arg_pure_hyp =
+    isVar c && not (mem_named_context (destVar c) (Global.named_context()))
+    && lbind == NoBindings && not with_evars && Option.is_empty eqname
+    && clear_flag == None
+    && has_generic_occurrences_but_goal cls (destVar c) env ccl in
+  let enough_applied = check_enough_applied env sigma elim t in
+  if is_arg_pure_hyp && enough_applied then
+    (* First case: induction on a variable already in an inductive type and
+       with maximal abstraction over the variable.
+       This is a situation where the induction argument is a
+       clearable variable of the goal w/o occurrence selection
+       and w/o equality kept: no need to generalize *)
+    let id = destVar c in
+    Tacticals.New.tclTHEN
+      (Proofview.V82.tactic (clear_unselected_context id inhyps cls))
+      (induction_with_atomization_of_ind_arg
+         isrec with_evars elim names id inhyps)
+  else
+  (* Otherwise, we look for the pattern, possibly adding missing arguments and
+     declaring the induction argument as a new local variable *)
+    let id =
+    (* Type not the right one if partially applied but anyway for internal use*)
+      let x = id_of_name_using_hdchar (Global.env()) t Anonymous in
+      new_fresh_id [] x gl in
+    let info_arg = (is_arg_pure_hyp, not enough_applied) in
+    pose_induction_arg_then
+      isrec with_evars info_arg elim id arg t inhyps cls
+    (induction_with_atomization_of_ind_arg
+       isrec with_evars elim names id inhyps)
+  end
 
 (* Induction on a list of arguments. First make induction arguments
    atomic (using letins), then do induction. The specificity here is
    that all arguments and parameters of the scheme are given
    (mandatory for the moment), so we don't need to deal with
-    parameters of the inductive type as in new_induct_gen. *)
-let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
-  if eqname <> None then
-    errorlabstrm "" (str "Do not know what to do with " ++
-      pr_intro_pattern (Option.get eqname));
+    parameters of the inductive type as in induction_gen. *)
+let induction_gen_l isrec with_evars elim names lc =
   let newlc = ref [] in
-  let letids = ref [] in
-  let rec atomize_list l gl =
+  let lc = List.map (function
+    | (c,None) -> c
+    | (c,Some(loc,eqname)) ->
+      user_err_loc (loc,"",str "Do not know what to do with " ++
+                         Miscprint.pr_intro_pattern_naming eqname)) lc in
+  let rec atomize_list l =
     match l with
-      | [] -> tclIDTAC gl
+      | [] -> Proofview.tclUNIT ()
       | c::l' ->
 	  match kind_of_term c with
 	    | Var id when not (mem_named_context id (Global.named_context()))
-		& not with_evars ->
+		&& not with_evars ->
 		let _ = newlc:= id::!newlc in
-		atomize_list l' gl
+		atomize_list l'
 
 	    | _ ->
-		let x =
-		  id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in
+                Proofview.Goal.enter begin fun gl ->
+                let type_of = Tacmach.New.pf_type_of gl in
+                let x =
+		  id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in
 
-		let id = fresh_id [] x gl in
+                let id = new_fresh_id [] x gl in
 		let newl' = List.map (replace_term c (mkVar id)) l' in
 		let _ = newlc:=id::!newlc in
-		let _ = letids:=id::!letids in
-		tclTHEN
+		Tacticals.New.tclTHEN
 		  (letin_tac None (Name id) c None allHypsAndConcl)
-		  (atomize_list newl') gl in
-  tclTHENLIST
+		  (atomize_list newl')
+                end in
+  Tacticals.New.tclTHENLIST
     [
       (atomize_list lc);
-      (fun gl' -> (* recompute each time to have the new value of newlc *)
-	induction_without_atomization isrec with_evars elim names !newlc gl') ;
-      (* after induction, try to unfold all letins created by atomize_list
-         FIXME: unfold_all does not exist anywhere else? *)
-      (fun gl' -> (* recompute each time to have the new value of letids *)
-	tclMAP (fun x -> tclTRY (unfold_all x)) !letids gl')
+      (Proofview.tclUNIT () >>= fun () -> (* ensure newlc has been computed *)
+	induction_without_atomization isrec with_evars elim names !newlc)
     ]
-    gl
 
 (* Induction either over a term, over a quantified premisse, or over
    several quantified premisses (like with functional induction
    principles).
    TODO: really unify induction with one and induction with several
    args *)
-let induct_destruct isrec with_evars (lc,elim,names,cls) gl =
-  assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
-  if List.length lc = 1 && not (is_functional_induction elim gl) then
-    (* standard induction *)
-    onOpenInductionArg
-      (fun c -> new_induct_gen isrec with_evars elim names c cls)
-      (List.hd lc) gl
-  else begin
-    (* functional induction *)
-    (* Several induction hyps: induction scheme is mandatory *)
-    if elim = None
-    then
-      errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypotheses are given.\n" ++
-      str "Example: induction x1 x2 x3 using my_scheme.");
-    if cls <> None then
-      error "'in' clause not supported here.";
-    let lc = List.map
-      (map_induction_arg (pf_apply finish_evar_resolution gl)) lc in
-    if List.length lc = 1 then
-      (* Hook to recover standard induction on non-standard induction schemes *)
+let induction_destruct isrec with_evars (lc,elim) =
+  match lc with
+  | [] -> assert false (* ensured by syntax, but if called inside caml? *)
+  | [c,(eqname,names as allnames),cls] ->
+    Proofview.Goal.nf_enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    match elim with
+    | Some elim when is_functional_induction elim gl ->
+      (* Standard induction on non-standard induction schemes *)
       (* will be removable when is_functional_induction will be more clever *)
+      if not (Option.is_empty cls) then error "'in' clause not supported here.";
+      let finish_evar_resolution f =
+        let (sigma',(c,lbind)) = f env sigma in
+        let pending = (sigma,sigma') in
+        snd (finish_evar_resolution env sigma' (pending,c)),lbind in
+      let c = map_induction_arg finish_evar_resolution c in
       onInductionArg
-	(fun (c,lbind) ->
-	  if lbind <> NoBindings then
+	(fun _clear_flag (c,lbind) ->
+	  if lbind != NoBindings then
 	    error "'with' clause not supported here.";
-	  new_induct_gen_l isrec with_evars elim names [c]) (List.hd lc) gl
-    else
+	  induction_gen_l isrec with_evars elim names [c,eqname]) c
+    | _ ->
+      (* standard induction *)
+      onOpenInductionArg env sigma
+      (fun clear_flag c -> induction_gen clear_flag isrec with_evars elim (c,allnames) cls) c
+    end
+  | _ ->
+    Proofview.Goal.enter begin fun gl ->
+    let env = Proofview.Goal.env gl in
+    let sigma = Proofview.Goal.sigma gl in
+    match elim with
+    | None ->
+      (* Several arguments, without "using" clause *)
+      (* TODO: Do as if the arguments after the first one were called with *)
+      (* "destruct", but selecting occurrences on the initial copy of *)
+      (* the goal *)
+      let (a,b,cl) = List.hd lc in
+      let l = List.tl lc in
+      (* TODO *)
+      Tacticals.New.tclTHEN
+        (onOpenInductionArg env sigma (fun clear_flag a ->
+          induction_gen clear_flag isrec with_evars None (a,b) cl) a)
+        (Tacticals.New.tclMAP (fun (a,b,cl) ->
+          Proofview.Goal.enter begin fun gl ->
+          let env = Proofview.Goal.env gl in
+          let sigma = Proofview.Goal.sigma gl in      
+          onOpenInductionArg env sigma (fun clear_flag a ->
+            induction_gen clear_flag false with_evars None (a,b) cl) a
+          end) l)
+    | Some elim ->
+      (* Several induction hyps with induction scheme *)
+      let finish_evar_resolution f =
+        let (sigma',(c,lbind)) = f env sigma in
+        let pending = (sigma,sigma') in
+	if lbind != NoBindings then
+	  error "'with' clause not supported here.";
+        snd (finish_evar_resolution env sigma' (pending,c)) in
+      let lc = List.map (on_pi1 (map_induction_arg finish_evar_resolution)) lc in
       let newlc =
-	List.map (fun x ->
+        List.map (fun (x,(eqn,names),cls) ->
+          if cls != None then error "'in' clause not yet supported here.";
 	  match x with (* FIXME: should we deal with ElimOnIdent? *)
-	  | ElimOnConstr (x,NoBindings) -> x
+          | _clear_flag,ElimOnConstr x ->
+              if eqn <> None then error "'eqn' clause not supported here.";
+              (x,names)
 	  | _ -> error "Don't know where to find some argument.")
 	  lc in
-      new_induct_gen_l isrec with_evars elim names newlc gl
-  end
-
-let induction_destruct isrec with_evars = function
-  | [],_,_ -> tclIDTAC
-  | [a,b],el,cl -> induct_destruct isrec with_evars ([a],el,b,cl)
-  | (a,b)::l,None,cl ->
-      tclTHEN
-        (induct_destruct isrec with_evars ([a],None,b,cl))
-        (tclMAP (fun (a,b) -> induct_destruct false with_evars ([a],None,b,cl)) l)
-  | l,Some el,cl ->
-      let check_basic_using = function
-        | a,(None,None) -> a
-	| _ -> error "Unsupported syntax for \"using\"."
-      in
-      let l' = List.map check_basic_using l in
-      induct_destruct isrec with_evars (l', Some el, (None,None), cl)
-
-let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls)
-let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
+      (* Check that "as", if any, is given only on the last argument *)
+      let names,rest = List.sep_last (List.map snd newlc) in
+      if List.exists (fun n -> not (Option.is_empty n)) rest then
+        error "'as' clause with multiple arguments and 'using' clause can only occur last.";
+      let newlc = List.map (fun (x,_) -> (x,None)) newlc in
+      induction_gen_l isrec with_evars elim names newlc
+    end
+
+let induction ev clr c l e =
+  induction_gen clr true ev e 
+    (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None
+
+let destruct ev clr c l e =
+  induction_gen clr false ev e
+    (((Evd.empty,Evd.empty),(c,NoBindings)),(None,l)) None
 
 (* The registered tactic, which calls the default elimination
  * if no elimination constant is provided. *)
@@ -3217,8 +4076,8 @@ let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
 (* Induction tactics *)
 
 (* This was Induction before 6.3 (induction only in quantified premisses) *)
-let simple_induct_id s = tclTHEN (intros_until_id s) (onLastHyp simplest_elim)
-let simple_induct_nodep n = tclTHEN (intros_until_n n) (onLastHyp simplest_elim)
+let simple_induct_id s = Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_elim)
+let simple_induct_nodep n = Tacticals.New.tclTHEN (intros_until_n n) (Tacticals.New.onLastHyp simplest_elim)
 
 let simple_induct = function
   | NamedHyp id -> simple_induct_id id
@@ -3227,9 +4086,9 @@ let simple_induct = function
 (* Destruction tactics *)
 
 let simple_destruct_id s    =
-  (tclTHEN (intros_until_id s) (onLastHyp simplest_case))
+  (Tacticals.New.tclTHEN (intros_until_id s) (Tacticals.New.onLastHyp simplest_case))
 let simple_destruct_nodep n =
-  (tclTHEN (intros_until_n n)    (onLastHyp simplest_case))
+  (Tacticals.New.tclTHEN (intros_until_n n)    (Tacticals.New.onLastHyp simplest_case))
 
 let simple_destruct = function
   | NamedHyp id -> simple_destruct_id id
@@ -3242,90 +4101,35 @@ let simple_destruct = function
  * May be they should be integrated into Elim ...
  *)
 
-let elim_scheme_type elim t gl =
-  let clause = mk_clenv_type_of gl elim in
+let elim_scheme_type elim t =
+  Proofview.Goal.nf_enter begin fun gl ->
+  let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in
   match kind_of_term (last_arg clause.templval.rebus) with
     | Meta mv ->
         let clause' =
 	  (* t is inductive, then CUMUL or CONV is irrelevant *)
-	  clenv_unify ~flags:elim_flags Reduction.CUMUL t
+	  clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t
             (clenv_meta_type clause mv) clause in
-	res_pf clause' ~flags:elim_flags gl
-    | _ -> anomaly "elim_scheme_type"
-
-let elim_type t gl =
-  let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = lookup_eliminator ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
-
-let case_type t gl =
-  let (ind,t) = pf_reduce_to_atomic_ind gl t in
-  let elimc = pf_apply build_case_analysis_scheme_default gl ind (elimination_sort_of_goal gl) in
-  elim_scheme_type elimc t gl
-
-
-(* Some eliminations frequently used *)
-
-(* These elimination tactics are particularly adapted for sequent
-   calculus.  They take a clause as argument, and yield the
-   elimination rule if the clause is of the form (Some id) and a
-   suitable introduction rule otherwise. They do not depend on
-   the name of the eliminated constant, so they can be also
-   used on ad-hoc disjunctions and conjunctions introduced by
-   the user.
-   -- Eduardo Gimenez (11/8/97)
-
-   HH (29/5/99) replaces failures by specific error messages
- *)
-
-let andE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_conjunction (pf_hnf_constr gl t) then
-    (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl
-  else
-    errorlabstrm "andE"
-      (str("Tactic andE expects "^(string_of_id id)^" is a conjunction."))
+	Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false
+    | _ -> anomaly (Pp.str "elim_scheme_type")
+  end
 
-let dAnd cls =
-  onClause
-    (function
-      | None    -> simplest_split
-      | Some id -> andE id)
-    cls
-
-let orE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_disjunction (pf_hnf_constr gl t) then
-    (tclTHEN (simplest_elim (mkVar id)) intro) gl
-  else
-    errorlabstrm "orE"
-      (str("Tactic orE expects "^(string_of_id id)^" is a disjunction."))
+let elim_type t =
+  Proofview.Goal.enter begin fun gl ->
+  let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in
+  let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
+  end
 
-let dorE b cls =
-  onClause
-    (function
-      | Some id -> orE id
-      | None    -> (if b then right else left) NoBindings)
-    cls
-
-let impE id gl =
-  let t = pf_get_hyp_typ gl id in
-  if is_imp_term (pf_hnf_constr gl t) then
-    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in
-    tclTHENLAST
-      (cut_intro rng)
-      (apply_term (mkVar id) [mkMeta (new_meta())]) gl
-  else
-    errorlabstrm "impE"
-      (str("Tactic impE expects "^(string_of_id id)^
-	      " is a an implication."))
+let case_type t =
+  Proofview.Goal.enter begin fun gl ->
+  let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in
+  let evd, elimc =
+    Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl)
+  in
+  Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (elim_scheme_type elimc t)
+  end
 
-let dImp cls =
-  onClause
-    (function
-      | None    -> intro
-      | Some id -> impE id)
-    cls
 
 (************************************************)
 (*  Tactics related with logic connectives      *)
@@ -3333,24 +4137,36 @@ let dImp cls =
 
 (* Reflexivity tactics *)
 
-let setoid_reflexivity = ref (fun _ -> assert false)
-let register_setoid_reflexivity f = setoid_reflexivity := f
+let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make ()
 
-let reflexivity_red allowred gl =
+let maybe_betadeltaiota_concl allowred gl =
+  let concl = Tacmach.New.pf_nf_concl gl in
+  let sigma = Proofview.Goal.sigma gl in
+  if not allowred then concl
+  else
+    let env = Proofview.Goal.env gl in
+    whd_betadeltaiota env sigma concl
+
+let reflexivity_red allowred =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual reflexivity don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl = if not allowred then pf_concl gl
-  else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl)
-  in
+    let concl = maybe_betadeltaiota_concl allowred gl in
     match match_with_equality_type concl with
-    | None -> raise NoEquationFound
-    | Some _ -> one_constructor 1 NoBindings gl
+    | None -> Proofview.tclZERO NoEquationFound
+    | Some _ -> one_constructor 1 NoBindings
+  end
 
-let reflexivity gl =
-  try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl
+let reflexivity =
+  Proofview.tclORELSE
+    (reflexivity_red false)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_reflexivity
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let intros_reflexivity  = (tclTHEN intros reflexivity)
+let intros_reflexivity  = (Tacticals.New.tclTHEN intros reflexivity)
 
 (* Symmetry tactics *)
 
@@ -3359,8 +4175,7 @@ let intros_reflexivity  = (tclTHEN intros reflexivity)
    defined and the conclusion is a=b, it solves the goal doing (Cut
    b=a;Intro H;Case H;Constructor 1) *)
 
-let setoid_symmetry = ref (fun _ -> assert false)
-let register_setoid_symmetry f = setoid_symmetry := f
+let (forward_setoid_symmetry, setoid_symmetry) = Hook.make ()
 
 (* This is probably not very useful any longer *)
 let prove_symmetry hdcncl eq_kind =
@@ -3369,51 +4184,70 @@ let prove_symmetry hdcncl eq_kind =
     | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|])
     | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|])
     | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in
-  tclTHENFIRST (cut symc)
-    (tclTHENLIST
+  Tacticals.New.tclTHENFIRST (cut symc)
+    (Tacticals.New.tclTHENLIST
       [ intro;
-        onLastHyp simplest_case;
+        Tacticals.New.onLastHyp simplest_case;
 	one_constructor 1 NoBindings ])
 
-let symmetry_red allowred gl =
+let match_with_equation c =
+  try
+    let res = match_with_equation c in
+    Proofview.tclUNIT res
+  with NoEquationFound ->
+    Proofview.tclZERO NoEquationFound
+
+let symmetry_red allowred =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual symmetry don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl =
-    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
-  in
-  match match_with_equation concl with
+  let concl = maybe_betadeltaiota_concl allowred gl in
+  match_with_equation concl >>= fun with_eqn ->
+  match with_eqn with
   | Some eq_data,_,_ ->
-      tclTHEN
+      Tacticals.New.tclTHEN
         (convert_concl_no_check concl DEFAULTcast)
-      (apply eq_data.sym) gl
-  | None,eq,eq_kind -> prove_symmetry eq eq_kind gl
+        (Tacticals.New.pf_constr_of_global eq_data.sym apply)
+  | None,eq,eq_kind -> prove_symmetry eq eq_kind
+  end
 
-let symmetry gl =
-  try symmetry_red false gl with NoEquationFound -> !setoid_symmetry gl
+let symmetry =
+  Proofview.tclORELSE
+    (symmetry_red false)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_symmetry
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let setoid_symmetry_in = ref (fun _ _ -> assert false)
-let register_setoid_symmetry_in f = setoid_symmetry_in := f
+let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make ()
 
-let symmetry_in id gl =
-  let ctype = pf_type_of gl (mkVar id) in
+
+let symmetry_in id =
+  Proofview.Goal.enter begin fun gl ->
+  let ctype = Tacmach.New.pf_type_of gl (mkVar id) in
   let sign,t = decompose_prod_assum ctype in
-  try
-    let _,hdcncl,eq = match_with_equation t in
-    let symccl = match eq with
-      | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |])
-      | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |])
-      | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in
-    tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
-      [ intro_replacing id;
-        tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
-      gl
-  with NoEquationFound -> !setoid_symmetry_in id gl
+  Proofview.tclORELSE
+    begin
+      match_with_equation t >>= fun (_,hdcncl,eq) ->
+        let symccl = match eq with
+          | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |])
+          | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |])
+          | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in
+        Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
+          [ intro_replacing id;
+            Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
+    end
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_symmetry_in id
+      | e -> Proofview.tclZERO ~info e
+    end
+  end
 
 let intros_symmetry =
-  onClause
+  Tacticals.New.onClause
     (function
-      | None -> tclTHEN intros symmetry
+      | None -> Tacticals.New.tclTHEN intros symmetry
       | Some id -> symmetry_in id)
 
 (* Transitivity tactics *)
@@ -3428,132 +4262,217 @@ let intros_symmetry =
    --Eduardo (19/8/97)
 *)
 
-let setoid_transitivity = ref (fun _ _ -> assert false)
-let register_setoid_transitivity f = setoid_transitivity := f
+let (forward_setoid_transitivity, setoid_transitivity) = Hook.make ()
+
 
 (* This is probably not very useful any longer *)
-let prove_transitivity hdcncl eq_kind t gl =
-  let eq1,eq2 =
-    match eq_kind with
-    | MonomorphicLeibnizEq (c1,c2) ->
-      (mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]))
+let prove_transitivity hdcncl eq_kind t =
+  Proofview.Goal.enter begin fun gl ->
+  let (eq1,eq2) = match eq_kind with
+  | MonomorphicLeibnizEq (c1,c2) ->
+      mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |])
   | PolymorphicLeibnizEq (typ,c1,c2) ->
-      (mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |]))
+      mkApp (hdcncl, [| typ; c1; t |]), mkApp (hdcncl, [| typ; t; c2 |])
   | HeterogenousEq (typ1,c1,typ2,c2) ->
-      let typt = pf_type_of gl t in
-      (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
-       mkApp(hdcncl, [| typt; t; typ2; c2 |])) in
-  tclTHENFIRST (cut eq2)
-    (tclTHENFIRST (cut eq1)
-      (tclTHENLIST
-	[ tclDO 2 intro;
-	  onLastHyp simplest_case;
-	  assumption ])) gl
-
-let transitivity_red allowred t gl =
+      let env = Proofview.Goal.env gl in
+      let sigma = Proofview.Goal.sigma gl in
+      let type_of = Typing.type_of env sigma in
+      let typt = type_of t in
+        (mkApp(hdcncl, [| typ1; c1; typt ;t |]),
+         mkApp(hdcncl, [| typt; t; typ2; c2 |]))
+  in
+  Tacticals.New.tclTHENFIRST (cut eq2)
+    (Tacticals.New.tclTHENFIRST (cut eq1)
+       (Tacticals.New.tclTHENLIST
+	  [ Tacticals.New.tclDO 2 intro;
+	    Tacticals.New.onLastHyp simplest_case;
+	    assumption ]))
+  end
+
+let transitivity_red allowred t =
+  Proofview.Goal.enter begin fun gl ->
   (* PL: usual transitivity don't perform any reduction when searching
      for an equality, but we may need to do some when called back from
      inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *)
-  let concl =
-    if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl)
-  in
-  match match_with_equation concl with
+  let concl = maybe_betadeltaiota_concl allowred gl in
+  match_with_equation concl >>= fun with_eqn ->
+  match with_eqn with
   | Some eq_data,_,_ ->
-      tclTHEN
+      Tacticals.New.tclTHEN
         (convert_concl_no_check concl DEFAULTcast)
         (match t with
-	 | None -> eapply eq_data.trans
-	 | Some t -> apply_list [eq_data.trans;t]) gl
-  | None,eq,eq_kind ->
+	  | None -> Tacticals.New.pf_constr_of_global eq_data.trans eapply
+	  | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t]))
+   | None,eq,eq_kind ->
       match t with
-      | None -> error "etransitivity not supported for this relation."
-      | Some t -> prove_transitivity eq eq_kind t gl
+      | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.")
+      | Some t -> prove_transitivity eq eq_kind t
+  end
 
-let transitivity_gen t gl =
-  try transitivity_red false t gl
-  with NoEquationFound -> !setoid_transitivity t gl
+let transitivity_gen t =
+  Proofview.tclORELSE
+    (transitivity_red false t)
+    begin function (e, info) -> match e with
+      | NoEquationFound -> Hook.get forward_setoid_transitivity t
+      | e -> Proofview.tclZERO ~info e
+    end
 
 let etransitivity = transitivity_gen None
 let transitivity t = transitivity_gen (Some t)
 
-let intros_transitivity  n  = tclTHEN intros (transitivity_gen n)
+let intros_transitivity  n  = Tacticals.New.tclTHEN intros (transitivity_gen n)
 
 (* tactical to save as name a subproof such that the generalisation of
    the current goal, abstracted with respect to the local signature,
    is solved by tac *)
 
-let interpretable_as_section_decl d1 d2 = match d1,d2 with
+(** d1 is the section variable in the global context, d2 in the goal context *)
+let interpretable_as_section_decl evd d1 d2 = match d2,d1 with
   | (_,Some _,_), (_,None,_) -> false
-  | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
-  | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
-
-let abstract_subproof id tac gl =
+  | (_,Some b1,t1), (_,Some b2,t2) -> 
+    e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2
+  | (_,None,t1), (_,_,t2) -> e_eq_constr_univs evd t1 t2
+
+let abstract_subproof id gk tac =
+  let open Tacticals.New in
+  let open Tacmach.New in
+  let open Proofview.Notations in
+  Proofview.Goal.nf_enter begin fun gl ->
   let current_sign = Global.named_context()
-  and global_sign = pf_hyps gl in
+  and global_sign = Proofview.Goal.hyps gl in
+  let evdref = ref (Proofview.Goal.sigma gl) in
   let sign,secsign =
     List.fold_right
       (fun (id,_,_ as d) (s1,s2) ->
-	if mem_named_context id current_sign &
-          interpretable_as_section_decl (Sign.lookup_named id current_sign) d
+	if mem_named_context id current_sign &&
+          interpretable_as_section_decl evdref (Context.lookup_named id current_sign) d
         then (s1,push_named_context_val d s2)
 	else (add_named_decl d s1,s2))
       global_sign (empty_named_context,empty_named_context_val) in
   let id = next_global_ident_away id (pf_ids_of_hyps gl) in
-  let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
+  let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in
   let concl =
-    try flush_and_check_evars (project gl) concl
+    try flush_and_check_evars !evdref concl
     with Uninstantiated_evar _ ->
       error "\"abstract\" cannot handle existentials." in
-  let const = Pfedit.build_constant_by_tactic id secsign concl
-    (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)) in
-  let cd = Entries.DefinitionEntry const in
-  let lem = mkConst (Declare.declare_constant ~internal:Declare.KernelSilent id (cd,IsProof Lemma)) in
-  exact_no_check
-    (applist (lem,List.rev (Array.to_list (instance_from_named_context sign))))
-    gl
 
-let tclABSTRACT name_op tac gl =
-  let s = match name_op with
-    | Some s -> s
-    | None   -> add_suffix (get_current_proof_name ()) "_subproof"
+  let evd, ctx, concl =
+    (* FIXME: should be done only if the tactic succeeds *)
+    let evd, nf = nf_evars_and_universes !evdref in
+    let ctx = Evd.universe_context_set evd in
+      evd, ctx, nf concl
   in
-  abstract_subproof s tac gl
-
+  let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in
+  let ectx = Evd.evar_universe_context evd in
+  let (const, safe, ectx) =
+    try Pfedit.build_constant_by_tactic ~goal_kind:gk id ectx secsign concl solve_tac
+    with Logic_monad.TacticFailure e as src ->
+    (* if the tactic [tac] fails, it reports a [TacticFailure e],
+       which is an error irrelevant to the proof system (in fact it
+       means that [e] comes from [tac] failing to yield enough
+       success). Hence it reraises [e]. *)
+    let (_, info) = Errors.push src in
+    iraise (e, info)
+  in
+  let cd = Entries.DefinitionEntry const in
+  let decl = (cd, IsProof Lemma) in
+  (** ppedrot: seems legit to have abstracted subproofs as local*)
+  let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in
+  (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *)
+  let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in
+  let evd = Evd.set_universe_context evd ectx in
+  let open Declareops in
+  let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in
+  let effs = cons_side_effects eff
+    Entries.(snd (Future.force const.const_entry_body)) in
+  let args = List.rev (instance_from_named_context sign) in
+  let solve =
+    Proofview.Unsafe.tclEVARS evd <*>
+    Proofview.tclEFFECTS effs <*>
+    new_exact_no_check (applist (lem, args))
+  in
+  if not safe then Proofview.mark_as_unsafe <*> solve else solve
+  end
 
-let admit_as_an_axiom gl =
-  let current_sign = Global.named_context()
-  and global_sign = pf_hyps gl in
-  let sign,secsign =
-    List.fold_right
-      (fun (id,_,_ as d) (s1,s2) ->
-	 if mem_named_context id current_sign &
-           interpretable_as_section_decl (Sign.lookup_named id current_sign) d
-         then (s1,add_named_decl d s2)
-	 else (add_named_decl d s1,s2))
-      global_sign (empty_named_context,empty_named_context) in
-  let name = add_suffix (get_current_proof_name ()) "_admitted" in
-  let na = next_global_ident_away name (pf_ids_of_hyps gl) in
-  let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in
-  if occur_existential concl then error"\"admit\" cannot handle existentials.";
-  let axiom =
-    let cd = 
-      Entries.ParameterEntry (Pfedit.get_used_variables(),concl,None) in
-    let con = Declare.declare_constant ~internal:Declare.KernelSilent na (cd,IsAssumption Logical) in
-    constr_of_global (ConstRef con)
+let anon_id = Id.of_string "anonymous"
+
+let tclABSTRACT name_op tac =
+  let open Proof_global in
+  let default_gk = (Global, false, Proof Theorem) in
+  let s, gk = match name_op with
+    | Some s ->
+      (try let _, gk, _ = current_proof_statement () in s, gk
+       with NoCurrentProof -> s, default_gk)
+    | None   ->
+      let name, gk =
+	try let name, gk, _ = current_proof_statement () in name, gk
+	with NoCurrentProof -> anon_id, default_gk in
+      add_suffix name "_subproof", gk
   in
-  exact_no_check
-    (applist (axiom,
-              List.rev (Array.to_list (instance_from_named_context sign))))
-    gl
+  abstract_subproof s gk tac
+
+let admit_as_an_axiom =
+  Proofview.tclUNIT () >>= fun () -> (* delay for Coqlib.build_coq_proof_admitted *)
+  simplest_case (Coqlib.build_coq_proof_admitted ()) <*>
+  Proofview.mark_as_unsafe
 
-let unify ?(state=full_transparent_state) x y gl =
+let unify ?(state=full_transparent_state) x y =
+  Proofview.Goal.nf_enter begin fun gl ->
   try
-    let flags =
-      {default_unify_flags with
+    let core_flags =
+      { (default_unify_flags ()).core_unify_flags with
 	modulo_delta = state;
-	modulo_conv_on_closed_terms = Some state}
+	modulo_conv_on_closed_terms = Some state} in
+    (* What to do on merge and subterm flags?? *)
+    let flags = { (default_unify_flags ()) with
+      core_unify_flags = core_flags;
+      merge_unify_flags = core_flags;
+      subterm_unify_flags = { core_flags with modulo_delta = empty_transparent_state } }
     in
-    let evd = w_unify (pf_env gl) (project gl) Reduction.CONV ~flags x y
-    in tclEVARS evd gl
-  with e when Errors.noncritical e ->
-    tclFAIL 0 (str"Not unifiable") gl
+    let evd = w_unify (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) Reduction.CONV ~flags x y
+    in Proofview.Unsafe.tclEVARS evd
+  with e when Errors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Not unifiable")
+  end
+
+module Simple = struct
+  (** Simplified version of some of the above tactics *)
+
+  let intro x = intro_move (Some x) MoveLast
+
+  let generalize_gen cl =
+    generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl)
+  let generalize cl =
+    generalize_gen (List.map (fun c -> ((AllOccurrences,c),Names.Anonymous))
+                        cl)
+
+  let apply c =
+    apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))]
+  let eapply c =
+    apply_with_bindings_gen false true [None,(Loc.ghost,(c,NoBindings))]
+  let elim c   = elim false None (c,NoBindings) None
+  let case   c = general_case_analysis false None (c,NoBindings)
+
+  let apply_in id c =
+    apply_in false false None id [None,(Loc.ghost, (c, NoBindings))] None
+
+end
+
+
+(** Tacticals defined directly in term of Proofview *)
+module New = struct
+  open Proofview.Notations
+
+  let exact_proof c = Proofview.V82.tactic (exact_proof c)
+
+  open Genredexpr
+  open Locus
+
+  let reduce_after_refine =
+    Proofview.V82.tactic (reduce
+      (Lazy {rBeta=true;rIota=true;rZeta=false;rDelta=false;rConst=[]})
+      {onhyps=None; concl_occs=AllOccurrences })
+
+  let refine ?unsafe c =
+    Proofview.Refine.refine ?unsafe c <*>
+    reduce_after_refine
+end
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index e82ee021..6025883f 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -1,133 +1,139 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
 open Term
+open Context
 open Environ
-open Sign
-open Tacmach
 open Proof_type
-open Reduction
 open Evd
-open Evar_refiner
 open Clenv
 open Redexpr
-open Tacticals
-open Libnames
-open Genarg
+open Globnames
 open Tacexpr
-open Nametab
-open Glob_term
 open Pattern
-open Termops
 open Unification
+open Misctypes
+open Locus
 
 (** Main tactics. *)
 
 (** {6 General functions. } *)
 
-val string_of_inductive : constr -> string
-val head_constr       : constr -> constr * constr list
-val head_constr_bound : constr -> constr * constr list
-val is_quantified_hypothesis : identifier -> goal sigma -> bool
-
-exception Bound
+val is_quantified_hypothesis : Id.t -> goal sigma -> bool
 
 (** {6 Primitive tactics. } *)
 
-val introduction    : identifier -> tactic
+val introduction    : ?check:bool -> Id.t -> unit Proofview.tactic
 val refine          : constr -> tactic
-val convert_concl   : constr -> cast_kind -> tactic
-val convert_hyp     : named_declaration -> tactic
-val thin            : identifier list -> tactic
+val convert_concl   : ?check:bool -> types -> cast_kind -> unit Proofview.tactic
+val convert_hyp     : ?check:bool -> named_declaration -> unit Proofview.tactic
+val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic
+val convert_hyp_no_check : named_declaration -> unit Proofview.tactic
+val thin            : Id.t list -> tactic
 val mutual_fix      :
-  identifier -> int -> (identifier * int * constr) list -> int -> tactic
-val fix             : identifier option -> int -> tactic
-val mutual_cofix    : identifier -> (identifier * constr) list -> int -> tactic
-val cofix           : identifier option -> tactic
+  Id.t -> int -> (Id.t * int * constr) list -> int -> tactic
+val fix             : Id.t option -> int -> tactic
+val mutual_cofix    : Id.t -> (Id.t * constr) list -> int -> tactic
+val cofix           : Id.t option -> tactic
+
+val convert         : constr -> constr -> unit Proofview.tactic
+val convert_leq     : constr -> constr -> unit Proofview.tactic
 
 (** {6 Introduction tactics. } *)
 
-val fresh_id_in_env : identifier list -> identifier -> env -> identifier
-val fresh_id : identifier list -> identifier -> goal sigma -> identifier
-val find_intro_names : rel_context -> goal sigma -> identifier list
+val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t
+val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t
+val find_intro_names : rel_context -> goal sigma -> Id.t list
 
-val intro                : tactic
-val introf               : tactic
-val intro_move        : identifier option -> identifier move_location -> tactic
+val intro                : unit Proofview.tactic
+val introf               : unit Proofview.tactic
+val intro_move        : Id.t option -> Id.t move_location -> unit Proofview.tactic
+val intro_move_avoid  : Id.t option -> Id.t list -> Id.t move_location -> unit Proofview.tactic
 
-  (** [intro_avoiding idl] acts as intro but prevents the new identifier
+  (** [intro_avoiding idl] acts as intro but prevents the new Id.t
      to belong to [idl] *)
-val intro_avoiding       : identifier list -> tactic
+val intro_avoiding       : Id.t list -> unit Proofview.tactic
 
-val intro_replacing      : identifier -> tactic
-val intro_using          : identifier -> tactic
-val intro_mustbe_force   : identifier -> tactic
-val intro_then           : (identifier -> tactic) -> tactic
-val intros_using         : identifier list -> tactic
-val intro_erasing        : identifier -> tactic
-val intros_replacing     : identifier list -> tactic
+val intro_replacing      : Id.t -> unit Proofview.tactic
+val intro_using          : Id.t -> unit Proofview.tactic
+val intro_mustbe_force   : Id.t -> unit Proofview.tactic
+val intro_then           : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic
+val intros_using         : Id.t list -> unit Proofview.tactic
+val intros_replacing     : Id.t list -> unit Proofview.tactic
+val intros_possibly_replacing : Id.t list -> unit Proofview.tactic
 
-val intros               : tactic
+val intros               : unit Proofview.tactic
 
 (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in
    the conclusion of goal [g], up to head-reduction if [b] is [true] *)
 val depth_of_quantified_hypothesis :
   bool -> quantified_hypothesis -> goal sigma -> int
 
-val intros_until_n_wored : int -> tactic
-val intros_until         : quantified_hypothesis -> tactic
+val intros_until         : quantified_hypothesis -> unit Proofview.tactic
 
-val intros_clearing      : bool list -> tactic
+val intros_clearing      : bool list -> unit Proofview.tactic
 
-(** Assuming a tactic [tac] depending on an hypothesis identifier,
+(** Assuming a tactic [tac] depending on an hypothesis Id.t,
    [try_intros_until tac arg] first assumes that arg denotes a
    quantified hypothesis (denoted by name or by index) and try to
    introduce it in context before to apply [tac], otherwise assume the
    hypothesis is already in context and directly apply [tac] *)
 
 val try_intros_until :
-  (identifier -> tactic) -> quantified_hypothesis -> tactic
+  (Id.t -> unit Proofview.tactic) -> quantified_hypothesis -> unit Proofview.tactic
 
 (** Apply a tactic on a quantified hypothesis, an hypothesis in context
    or a term with bindings *)
 
 val onInductionArg :
-  (constr with_bindings -> tactic) ->
-    constr with_bindings induction_arg -> tactic
+  (clear_flag -> constr with_bindings -> unit Proofview.tactic) ->
+    constr with_bindings induction_arg -> unit Proofview.tactic
+
+(** Tell if a used hypothesis should be cleared by default or not *)
+
+val use_clear_hyp_by_default : unit -> bool
 
 (** {6 Introduction tactics with eliminations. } *)
 
-val intro_pattern  : identifier move_location -> intro_pattern_expr -> tactic
-val intro_patterns : intro_pattern_expr located list -> tactic
-val intros_pattern :
-  identifier move_location -> intro_pattern_expr located list -> tactic
+val intro_patterns : intro_patterns -> unit Proofview.tactic
+val intro_patterns_to : Id.t move_location -> intro_patterns ->
+  unit Proofview.tactic
+val intro_patterns_bound_to : int -> Id.t move_location -> intro_patterns ->
+  unit Proofview.tactic
+val intro_pattern_to : Id.t move_location -> delayed_open_constr intro_pattern_expr ->
+  unit Proofview.tactic
+
+(** Implements user-level "intros", with [] standing for "**" *)
+val intros_patterns : intro_patterns -> unit Proofview.tactic
 
 (** {6 Exact tactics. } *)
 
-val assumption       : tactic
+val assumption       : unit Proofview.tactic
 val exact_no_check   : constr -> tactic
 val vm_cast_no_check : constr -> tactic
-val exact_check      : constr -> tactic
-val exact_proof      : Topconstr.constr_expr -> tactic
+val exact_check      : constr -> unit Proofview.tactic
+val exact_proof      : Constrexpr.constr_expr -> tactic
 
 (** {6 Reduction tactics. } *)
 
 type tactic_reduction = env -> evar_map -> constr -> constr
 
-val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
-val reduct_option     : tactic_reduction * cast_kind -> goal_location -> tactic
+type change_arg = evar_map -> evar_map * constr
+
+val reduct_in_hyp     : ?check:bool -> tactic_reduction -> hyp_location -> tactic
+val reduct_option     : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> tactic
 val reduct_in_concl   : tactic_reduction * cast_kind -> tactic
-val change_in_concl   : (occurrences * constr_pattern) option -> constr -> 
-                        tactic
-val change_in_hyp     : (occurrences * constr_pattern) option -> constr ->
-                        hyp_location -> tactic
+val change_in_concl   : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic
+val change_concl      : constr -> unit Proofview.tactic
+val change_in_hyp     : (occurrences * constr_pattern) option -> change_arg ->
+                        hyp_location -> unit Proofview.tactic
 val red_in_concl      : tactic
 val red_in_hyp        : hyp_location -> tactic
 val red_option        : goal_location -> tactic
@@ -148,7 +154,7 @@ val unfold_in_hyp     :
 val unfold_option     :
   (occurrences * evaluable_global_reference) list -> goal_location -> tactic
 val change            :
-  constr_pattern option -> constr -> clause -> tactic
+  constr_pattern option -> change_arg -> clause -> tactic
 val pattern_option    :
   (occurrences * constr) list -> goal_location -> tactic
 val reduce            : red_expr -> clause -> tactic
@@ -156,44 +162,50 @@ val unfold_constr     : global_reference -> tactic
 
 (** {6 Modification of the local context. } *)
 
-val clear         : identifier list -> tactic
-val clear_body    : identifier list -> tactic
-val keep          : identifier list -> tactic
+val clear         : Id.t list -> tactic
+val clear_body    : Id.t list -> unit Proofview.tactic
+val unfold_body   : Id.t -> tactic
+val keep          : Id.t list -> unit Proofview.tactic
+val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic
 
-val specialize    : int option -> constr with_bindings -> tactic
+val specialize    : constr with_bindings -> tactic
 
-val move_hyp      : bool -> identifier -> identifier move_location -> tactic
-val rename_hyp    : (identifier * identifier) list -> tactic
+val move_hyp      : Id.t -> Id.t move_location -> tactic
+val rename_hyp    : (Id.t * Id.t) list -> unit Proofview.tactic
 
-val revert        : identifier list -> tactic
+val revert        : Id.t list -> unit Proofview.tactic
 
 (** {6 Resolution tactics. } *)
 
 val apply_type : constr -> constr list -> tactic
-val apply_term : constr -> constr list -> tactic
-val bring_hyps : named_context -> tactic
+val bring_hyps : named_context -> unit Proofview.tactic
 
-val apply                 : constr -> tactic
-val eapply                : constr -> tactic
+val apply                 : constr -> unit Proofview.tactic
+val eapply                : constr -> unit Proofview.tactic
 
 val apply_with_bindings_gen :
-  advanced_flag -> evars_flag -> constr with_bindings located list -> tactic
+  advanced_flag -> evars_flag -> (clear_flag * constr with_bindings located) list -> unit Proofview.tactic
 
-val apply_with_bindings   : constr with_bindings -> tactic
-val eapply_with_bindings  : constr with_bindings -> tactic
+val apply_with_delayed_bindings_gen :
+  advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings located) list -> unit Proofview.tactic
 
-val cut_and_apply         : constr -> tactic
+val apply_with_bindings   : constr with_bindings -> unit Proofview.tactic
+val eapply_with_bindings  : constr with_bindings -> unit Proofview.tactic
+
+val cut_and_apply         : constr -> unit Proofview.tactic
 
 val apply_in :
-  advanced_flag -> evars_flag -> identifier -> 
-    constr with_bindings located list ->
-    intro_pattern_expr located option -> tactic
+  advanced_flag -> evars_flag -> clear_flag -> Id.t -> 
+    (clear_flag * constr with_bindings located) list ->
+    intro_pattern option -> unit Proofview.tactic
 
-val simple_apply_in : identifier -> constr -> tactic
+val apply_delayed_in :
+  advanced_flag -> evars_flag -> clear_flag -> Id.t -> 
+    (clear_flag * delayed_open_constr_with_bindings located) list ->
+    intro_pattern option -> unit Proofview.tactic
 
 (** {6 Elimination tactics. } *)
 
-
 (*
    The general form of an induction principle is the following:
 
@@ -223,7 +235,6 @@ type elim_scheme = {
   elimc: constr with_bindings option;
   elimt: types;
   indref: global_reference option;
-  index: int;              (** index of the elimination type in the scheme *)
   params: rel_context;     (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
   nparams: int;            (** number of parameters *)
   predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
@@ -240,150 +251,192 @@ type elim_scheme = {
   farg_in_concl: bool;     (** true if (f...) appears at the end of conclusion *)
 }
 
-
 val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme
-val rebuild_elimtype_from_scheme: elim_scheme -> types
 
 (** elim principle with the index of its inductive arg *)
 type eliminator = {
   elimindex : int option;  (** None = find it automatically *)
+  elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *)
   elimbody : constr with_bindings
 }
 
-val elimination_clause_scheme : evars_flag -> ?flags:unify_flags -> 
-  int -> clausenv -> clausenv -> tactic
+val general_elim  : evars_flag -> clear_flag ->
+  constr with_bindings -> eliminator -> unit Proofview.tactic
 
-val elimination_in_clause_scheme : evars_flag -> ?flags:unify_flags -> 
-  identifier -> int -> clausenv -> clausenv -> tactic
+val general_elim_clause : evars_flag -> unify_flags -> identifier option ->
+  clausenv -> eliminator -> unit Proofview.tactic
 
-val general_elim_clause_gen : (int -> Clenv.clausenv -> 'a -> tactic) ->
-  'a -> eliminator -> tactic
-
-val general_elim  : evars_flag ->
-  constr with_bindings -> eliminator -> tactic
-val general_elim_in : evars_flag -> identifier ->
-  constr with_bindings -> eliminator -> tactic
-
-val default_elim  : evars_flag -> constr with_bindings -> tactic
-val simplest_elim : constr -> tactic
+val default_elim  : evars_flag -> clear_flag -> constr with_bindings ->
+  unit Proofview.tactic
+val simplest_elim : constr -> unit Proofview.tactic
 val elim :
-  evars_flag -> constr with_bindings -> constr with_bindings option -> tactic
+  evars_flag -> clear_flag -> constr with_bindings -> constr with_bindings option -> unit Proofview.tactic
 
-val simple_induct : quantified_hypothesis -> tactic
+val simple_induct : quantified_hypothesis -> unit Proofview.tactic
 
-val new_induct : evars_flag -> 
-  (evar_map * constr with_bindings) induction_arg list ->
-  constr with_bindings option ->
-    intro_pattern_expr located option * intro_pattern_expr located option ->
-      clause option -> tactic
+val induction : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option ->
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Case analysis tactics. } *)
 
-val general_case_analysis : evars_flag -> constr with_bindings ->  tactic
-val simplest_case         : constr -> tactic
+val general_case_analysis : evars_flag -> clear_flag -> constr with_bindings ->  unit Proofview.tactic
+val simplest_case         : constr -> unit Proofview.tactic
 
-val simple_destruct          : quantified_hypothesis -> tactic
-val new_destruct : evars_flag ->
-  (evar_map * constr with_bindings) induction_arg list ->
-  constr with_bindings option ->
-    intro_pattern_expr located option * intro_pattern_expr located option ->
-      clause option -> tactic
+val simple_destruct       : quantified_hypothesis -> unit Proofview.tactic
+val destruct : evars_flag -> clear_flag -> constr -> or_and_intro_pattern option ->
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Generic case analysis / induction tactics. } *)
 
+(** Implements user-level "destruct" and "induction" *)
+
 val induction_destruct : rec_flag -> evars_flag ->
-  ((evar_map * constr with_bindings) induction_arg *
-  (intro_pattern_expr located option * intro_pattern_expr located option))
-  list *
-  constr with_bindings option *
-  clause option -> tactic
+  (delayed_open_constr_with_bindings induction_arg
+   * (intro_pattern_naming option * or_and_intro_pattern option)
+   * clause option) list *
+  constr with_bindings option -> unit Proofview.tactic
 
 (** {6 Eliminations giving the type instead of the proof. } *)
 
-val case_type         : constr  -> tactic
-val elim_type         : constr  -> tactic
+val case_type         : types -> unit Proofview.tactic
+val elim_type         : types -> unit Proofview.tactic
 
-(** {6 Some eliminations which are frequently used. } *)
+(** {6 Constructor tactics. } *)
 
-val impE : identifier -> tactic
-val andE : identifier -> tactic
-val orE  : identifier -> tactic
-val dImp : clause -> tactic
-val dAnd : clause -> tactic
-val dorE : bool -> clause ->tactic
+val constructor_tac      : evars_flag -> int option -> int ->
+  constr bindings -> unit Proofview.tactic
+val any_constructor      : evars_flag -> unit Proofview.tactic option -> unit Proofview.tactic
+val one_constructor      : int -> constr bindings  -> unit Proofview.tactic
 
+val left                 : constr bindings -> unit Proofview.tactic
+val right                : constr bindings -> unit Proofview.tactic
+val split                : constr bindings -> unit Proofview.tactic
 
-(** {6 Introduction tactics. } *)
+val left_with_bindings  : evars_flag -> constr bindings -> unit Proofview.tactic
+val right_with_bindings : evars_flag -> constr bindings -> unit Proofview.tactic
+val split_with_bindings : evars_flag -> constr bindings list -> unit Proofview.tactic
 
-val constructor_tac      : evars_flag -> int option -> int ->
-  constr bindings -> tactic
-val any_constructor      : evars_flag -> tactic option -> tactic
-val one_constructor      : int -> constr bindings  -> tactic
-
-val left                 : constr bindings -> tactic
-val right                : constr bindings -> tactic
-val split                : constr bindings -> tactic
-
-val left_with_bindings  : evars_flag -> constr bindings -> tactic
-val right_with_bindings : evars_flag -> constr bindings -> tactic
-val split_with_bindings : evars_flag -> constr bindings list -> tactic
-
-val simplest_left        : tactic
-val simplest_right       : tactic
-val simplest_split       : tactic
-
-(** {6 Logical connective tactics. } *)
-
-val register_setoid_reflexivity : tactic -> unit
-val reflexivity_red             : bool -> tactic
-val reflexivity                 : tactic
-val intros_reflexivity          : tactic
-
-val register_setoid_symmetry : tactic -> unit
-val symmetry_red                : bool -> tactic
-val symmetry                    : tactic
-val register_setoid_symmetry_in : (identifier -> tactic) -> unit
-val symmetry_in                 : identifier -> tactic
-val intros_symmetry             : clause -> tactic
-
-val register_setoid_transitivity : (constr option -> tactic) -> unit
-val transitivity_red            : bool -> constr option -> tactic
-val transitivity                : constr -> tactic
-val etransitivity               : tactic
-val intros_transitivity         : constr option -> tactic
-
-val cut                         : constr -> tactic
-val cut_intro                   : constr -> tactic
-val assert_replacing            : identifier -> types -> tactic -> tactic
-val cut_replacing               : identifier -> types -> tactic -> tactic
-val cut_in_parallel             : constr list -> tactic
-
-val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic
-val forward   : tactic option -> intro_pattern_expr located option -> constr -> tactic
-val letin_tac : (bool * intro_pattern_expr located) option -> name ->
-  constr -> types option -> clause -> tactic
-val letin_pat_tac : (bool * intro_pattern_expr located) option -> name ->
-  evar_map * constr -> types option -> clause -> tactic
-val assert_tac : name -> types -> tactic
-val assert_by  : name -> types -> tactic -> tactic
-val pose_proof : name -> constr -> tactic
+val simplest_left        : unit Proofview.tactic
+val simplest_right       : unit Proofview.tactic
+val simplest_split       : unit Proofview.tactic
+
+(** {6 Equality tactics. } *)
+
+val setoid_reflexivity : unit Proofview.tactic Hook.t
+val reflexivity_red             : bool -> unit Proofview.tactic
+val reflexivity                 : unit Proofview.tactic
+val intros_reflexivity          : unit Proofview.tactic
+
+val setoid_symmetry : unit Proofview.tactic Hook.t
+val symmetry_red                : bool -> unit Proofview.tactic
+val symmetry                    : unit Proofview.tactic
+val setoid_symmetry_in : (Id.t -> unit Proofview.tactic) Hook.t
+val intros_symmetry             : clause -> unit Proofview.tactic
+
+val setoid_transitivity : (constr option -> unit Proofview.tactic) Hook.t
+val transitivity_red            : bool -> constr option -> unit Proofview.tactic
+val transitivity                : constr -> unit Proofview.tactic
+val etransitivity               : unit Proofview.tactic
+val intros_transitivity         : constr option -> unit Proofview.tactic
+
+(** {6 Cut tactics. } *)
+
+val assert_before_replacing: Id.t -> types -> unit Proofview.tactic
+val assert_after_replacing : Id.t -> types -> unit Proofview.tactic
+val assert_before : Name.t -> types -> unit Proofview.tactic
+val assert_after  : Name.t -> types -> unit Proofview.tactic
+
+val assert_as     : (* true = before *) bool ->
+  intro_pattern option -> constr -> unit Proofview.tactic
+
+(** Implements the tactics assert, enough and pose proof; note that "by"
+    applies on the first goal for both assert and enough *)
+
+val assert_by  : Name.t -> types -> unit Proofview.tactic ->
+  unit Proofview.tactic
+val enough_by  : Name.t -> types -> unit Proofview.tactic ->
+  unit Proofview.tactic
+val pose_proof : Name.t -> constr ->
+  unit Proofview.tactic
+
+(** Common entry point for user-level "assert", "enough" and "pose proof" *)
+
+val forward   : bool -> unit Proofview.tactic option ->
+  intro_pattern option -> constr -> unit Proofview.tactic
+
+(** Implements the tactic cut, actually a modus ponens rule *)
+
+val cut        : types -> unit Proofview.tactic
+
+(** {6 Tactics for adding local definitions. } *)
+
+val letin_tac : (bool * intro_pattern_naming) option ->
+  Name.t -> constr -> types option -> clause -> unit Proofview.tactic
+
+(** Common entry point for user-level "set", "pose" and "remember" *)
+
+val letin_pat_tac : (bool * intro_pattern_naming) option ->
+  Name.t -> pending_constr -> clause -> unit Proofview.tactic
+
+(** {6 Generalize tactics. } *)
 
 val generalize      : constr list -> tactic
-val generalize_gen  : ((occurrences * constr) * name) list -> tactic
+val generalize_gen  : ((occurrences * constr) * Name.t) list -> tactic
+val new_generalize  : constr list -> unit Proofview.tactic
+val new_generalize_gen  : ((occurrences * constr) * Name.t) list -> unit Proofview.tactic
+
 val generalize_dep  : ?with_let:bool (** Don't lose let bindings *) -> constr  -> tactic
 
-val unify           : ?state:Names.transparent_state -> constr -> constr -> tactic
-val resolve_classes : tactic
+(** {6 Other tactics. } *)
+
+val unify           : ?state:Names.transparent_state -> constr -> constr -> unit Proofview.tactic
+
+val tclABSTRACT : Id.t option -> unit Proofview.tactic -> unit Proofview.tactic
+
+val admit_as_an_axiom : unit Proofview.tactic
+
+val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> Id.t -> unit Proofview.tactic
+val specialize_eqs : Id.t -> tactic
+
+val general_rewrite_clause :
+  (bool -> evars_flag -> constr with_bindings -> clause -> unit Proofview.tactic) Hook.t
+
+val subst_one :
+  (bool -> Id.t -> Id.t * constr * bool -> unit Proofview.tactic) Hook.t
+
+val declare_intro_decomp_eq :
+  ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types *
+   (types * constr * constr) ->
+   constr * types -> unit Proofview.tactic) -> unit
+
+(** {6 Simple form of basic tactics. } *)
+
+module Simple : sig
+  (** Simplified version of some of the above tactics *)
+
+  val intro           : Id.t -> unit Proofview.tactic
+  val generalize      : constr list -> tactic
+  val generalize_gen  : (constr Locus.with_occurrences * Name.t) list -> tactic
+
+  val apply  : constr -> unit Proofview.tactic
+  val eapply : constr -> unit Proofview.tactic
+  val elim   : constr -> unit Proofview.tactic
+  val case   : constr -> unit Proofview.tactic
+  val apply_in : identifier -> constr -> unit Proofview.tactic
+
+end
 
-val tclABSTRACT : identifier option -> tactic -> tactic
+(** {6 Tacticals defined directly in term of Proofview} *)
 
-val admit_as_an_axiom : tactic
+module New : sig
 
-val abstract_generalize : ?generalize_vars:bool -> ?force_dep:bool -> identifier -> tactic
-val specialize_eqs : identifier -> tactic
+  val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map*constr) -> unit Proofview.tactic
+  (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c]
+      followed by beta-iota-reduction of the conclusion. *)
 
-val register_general_multi_rewrite :
-  (bool -> evars_flag -> constr with_bindings -> clause -> tactic) -> unit
+  val reduce_after_refine : unit Proofview.tactic
+  (** The reducing tactic called after {!refine}. *)
 
-val register_subst_one :
-  (bool -> identifier -> identifier * constr * bool -> tactic) -> unit
+  open Proofview
+  val exact_proof : Constrexpr.constr_expr -> unit tactic
+end
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index f1324809..2c5edc20 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -1,21 +1,28 @@
+Ftactic
+Geninterp
+Dnet
 Dn
-Termdn
 Btermdn
-Nbtermdn
 Tacticals
 Hipattern
 Ind_tables
 Eqschemes
 Elimschemes
 Tactics
-Hiddentac
 Elim
-Auto
 Equality
 Contradiction
 Inv
 Leminv
+Tacsubst
+Taccoerce
+Tacenv
+Hints
+Auto
+Tacintern
+Tactic_matching
 Tacinterp
 Evar_tactics
+Term_dnet
 Autorewrite
 Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 042e2a7d..4b03ff24 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -1,48 +1,58 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Term
 open Hipattern
 open Names
-open Libnames
 open Pp
-open Proof_type
-open Tacticals
+open Genarg
+open Stdarg
 open Tacinterp
 open Tactics
+open Errors
 open Util
-open Genarg
+
+DECLARE PLUGIN "tauto"
 
 let assoc_var s ist =
-  match List.assoc (Names.id_of_string s) ist.lfun with
-    | VConstr ([],c) -> c
-    | _ -> failwith "tauto: anomaly"
+  let v = Id.Map.find (Names.Id.of_string s) ist.lfun in
+  match Value.to_constr v with
+    | Some c -> c
+    | None -> failwith "tauto: anomaly"
 
 (** Parametrization of tauto *)
 
+type tauto_flags = {
+
 (* Whether conjunction and disjunction are restricted to binary connectives *)
-(* (this is the compatibility mode) *)
-let binary_mode = true
+  binary_mode : bool;
+
+(* Whether compatibility for buggy detection of binary connective is on *)
+  binary_mode_bugged_detection : bool;
 
 (* Whether conjunction and disjunction are restricted to the connectives *)
 (* having the structure of "and" and "or" (up to the choice of sorts) in *)
-(* contravariant position in an hypothesis (this is the compatibility mode) *)
-let strict_in_contravariant_hyp = true
+(* contravariant position in an hypothesis *)
+  strict_in_contravariant_hyp : bool;
 
 (* Whether conjunction and disjunction are restricted to the connectives *)
 (* having the structure of "and" and "or" (up to the choice of sorts) in *)
 (* an hypothesis and in the conclusion *)
-let strict_in_hyp_and_ccl = false
+  strict_in_hyp_and_ccl : bool;
 
 (* Whether unit type includes equality types *)
-let strict_unit = false
+  strict_unit : bool;
+}
+
+(* Whether inner not are unfolded *)
+let negation_unfolding = ref true
 
 (* Whether inner iff are unfolded *)
 let iff_unfolding = ref false
@@ -54,13 +64,26 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
-      optname  = "unfolding of iff and not in intuition";
+      optname  = "unfolding of not in intuition";
+      optkey   = ["Intuition";"Negation";"Unfolding"];
+      optread  = (fun () -> !negation_unfolding);
+      optwrite = (:=) negation_unfolding }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "unfolding of iff in intuition";
       optkey   = ["Intuition";"Iff";"Unfolding"];
       optread  = (fun () -> !iff_unfolding);
       optwrite = (:=) iff_unfolding }
 
 (** Test *)
 
+let make_lfun l =
+  let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in
+  List.fold_left fold Id.Map.empty l
+
 let is_empty ist =
   if is_empty_type (assoc_var "X1" ist) then
     <:tactic<idtac>>
@@ -69,8 +92,8 @@ let is_empty ist =
 
 (* Strictly speaking, this exceeds the propositional fragment as it
    matches also equality types (and solves them if a reflexivity) *)
-let is_unit_or_eq ist =
-  let test = if strict_unit then is_unit_type else is_unit_or_eq_type in
+let is_unit_or_eq flags ist =
+  let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in
   if test (assoc_var "X1" ist) then
     <:tactic<idtac>>
   else
@@ -79,18 +102,18 @@ let is_unit_or_eq ist =
 let is_record t =
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-      | Ind ind  ->
+      | Ind (ind,u) ->
           let (mib,mip) = Global.lookup_inductive ind in
-	    mib.Declarations.mind_record
+	    mib.Declarations.mind_record <> None
       | _ -> false
 
-let is_binary t =
+let bugged_is_binary t =
   isApp t &&
   let (hdapp,args) = decompose_app t in
     match (kind_of_term hdapp) with
-    | Ind ind  ->
+    | Ind (ind,u)  ->
         let (mib,mip) = Global.lookup_inductive ind in
-	  mib.Declarations.mind_nparams = 2
+         Int.equal mib.Declarations.mind_nparams 2
     | _ -> false
 
 let iter_tac tacl =
@@ -98,70 +121,76 @@ let iter_tac tacl =
 
 (** Dealing with conjunction *)
 
-let is_conj ist =
+let is_conj flags ist =
   let ind = assoc_var "X1" ist in
-    if (not binary_mode || is_binary ind) (* && not (is_record ind) *)
-      && is_conjunction ~strict:strict_in_hyp_and_ccl ind
+    if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) &&
+       is_conjunction
+         ~strict:flags.strict_in_hyp_and_ccl
+         ~onlybinary:flags.binary_mode ind
     then
       <:tactic<idtac>>
     else
       <:tactic<fail>>
 
-let flatten_contravariant_conj ist =
+let flatten_contravariant_conj flags ist =
   let typ = assoc_var "X1" ist in
   let c = assoc_var "X2" ist in
   let hyp = assoc_var "id" ist in
-  match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with
+  match match_with_conjunction
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode typ
+  with
   | Some (_,args) ->
-      let i = List.length args in
-      if not binary_mode || i = 2 then
-	let newtyp = valueIn (VConstr ([],List.fold_right mkArrow args c)) in
-	let hyp = valueIn (VConstr ([],hyp)) in
-	let intros =
-	  iter_tac (List.map (fun _ -> <:tactic< intro >>) args)
-	  <:tactic< idtac >> in
-	<:tactic<
-          let newtyp := $newtyp in
-          let hyp := $hyp in
-	  assert newtyp by ($intros; apply hyp; split; assumption);
-	  clear hyp
-	>>
-      else
-	<:tactic<fail>>
+      let newtyp = valueIn (Value.of_constr (List.fold_right mkArrow args c)) in
+      let hyp = valueIn (Value.of_constr hyp) in
+      let intros =
+	iter_tac (List.map (fun _ -> <:tactic< intro >>) args)
+	<:tactic< idtac >> in
+      <:tactic<
+        let newtyp := $newtyp in
+        let hyp := $hyp in
+	assert newtyp by ($intros; apply hyp; split; assumption);
+	clear hyp
+      >>
   | _ ->
       <:tactic<fail>>
 
 (** Dealing with disjunction *)
 
-let is_disj ist =
+let constructor i =
+  let name = { Tacexpr.mltac_plugin = "coretactics"; mltac_tactic = "constructor" } in
+  let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in
+  Tacexpr.TacML (Loc.ghost, name, [i])
+
+let is_disj flags ist =
   let t = assoc_var "X1" ist in
-  if (not binary_mode || is_binary t) &&
-    is_disjunction ~strict:strict_in_hyp_and_ccl t
+  if (not flags.binary_mode_bugged_detection || bugged_is_binary t) &&
+     is_disjunction
+       ~strict:flags.strict_in_hyp_and_ccl
+       ~onlybinary:flags.binary_mode t
   then
     <:tactic<idtac>>
   else
     <:tactic<fail>>
 
-let flatten_contravariant_disj ist =
+let flatten_contravariant_disj flags ist =
   let typ = assoc_var "X1" ist in
   let c = assoc_var "X2" ist in
   let hyp = assoc_var "id" ist in
-  match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with
+  match match_with_disjunction
+          ~strict:flags.strict_in_contravariant_hyp
+          ~onlybinary:flags.binary_mode
+          typ with
   | Some (_,args) ->
-      let i = List.length args in
-      if not binary_mode || i = 2 then
-	let hyp = valueIn (VConstr ([],hyp)) in
-	iter_tac (list_map_i (fun i arg ->
-	  let typ = valueIn (VConstr ([],mkArrow arg c)) in
-	  let i = Tacexpr.Integer i in
-	  <:tactic<
-            let typ := $typ in
-            let hyp := $hyp in
-	    let i := $i in
-	    assert typ by (intro; apply hyp; constructor i; assumption)
-	  >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
-      else
-	<:tactic<fail>>
+      let hyp = valueIn (Value.of_constr hyp) in
+      iter_tac (List.map_i (fun i arg ->
+	let typ = valueIn (Value.of_constr (mkArrow arg c)) in
+	let ci = constructor i in
+	<:tactic<
+          let typ := $typ in
+          let hyp := $hyp in
+	  assert typ by (intro; apply hyp; $ci; assumption)
+	>>) 1 args) <:tactic< let hyp := $hyp in clear hyp >>
   | _ ->
       <:tactic<fail>>
 
@@ -171,30 +200,30 @@ let flatten_contravariant_disj ist =
 let not_dep_intros ist =
   <:tactic<
   repeat match goal with
-  | |- (?X1 -> ?X2) => intro
-  | |- (Coq.Init.Logic.not _)   => unfold Coq.Init.Logic.not at 1
-  | H:(Coq.Init.Logic.not _)|-_    => unfold Coq.Init.Logic.not at 1 in H
-  | H:(Coq.Init.Logic.not _)->_|-_    => unfold Coq.Init.Logic.not at 1 in H
+  | |- (forall (_: ?X1), ?X2) => intro
+  | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro
   end >>
 
-let axioms ist =
-  let t_is_unit_or_eq = tacticIn is_unit_or_eq
+let axioms flags ist =
+  let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags)
   and t_is_empty = tacticIn is_empty in
+  let c1 = constructor 1 in
     <:tactic<
     match reverse goal with
-      | |- ?X1 => $t_is_unit_or_eq; constructor 1
+      | |- ?X1 => $t_is_unit_or_eq; $c1
       | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
       | _:?X1 |- ?X1 => assumption
     end >>
 
 
-let simplif ist =
-  let t_is_unit_or_eq = tacticIn is_unit_or_eq
-  and t_is_conj = tacticIn is_conj
-  and t_flatten_contravariant_conj = tacticIn flatten_contravariant_conj
-  and t_flatten_contravariant_disj = tacticIn flatten_contravariant_disj
-  and t_is_disj = tacticIn is_disj
+let simplif flags ist =
+  let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags)
+  and t_is_conj = tacticIn (is_conj flags)
+  and t_flatten_contravariant_conj = tacticIn (flatten_contravariant_conj flags)
+  and t_flatten_contravariant_disj = tacticIn (flatten_contravariant_disj flags)
+  and t_is_disj = tacticIn (is_disj flags)
   and t_not_dep_intros = tacticIn not_dep_intros in
+  let c1 = constructor 1 in
   <:tactic<
     $t_not_dep_intros;
     repeat
@@ -203,25 +232,25 @@ let simplif ist =
         | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id
         | id: (Coq.Init.Logic.not _) |- _ => red in id
         | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id
-        | id0: ?X1 -> ?X2, id1: ?X1|- _ =>
+        | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ =>
 	    (* generalize (id0 id1); intro; clear id0 does not work
 	       (see Marco Maggiesi's bug PR#301)
 	    so we instead use Assert and exact. *)
 	    assert X2; [exact (id0 id1) | clear id0]
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_ : ?X1), ?X2|- _ =>
           $t_is_unit_or_eq; cut X2;
 	    [ intro; clear id
-	    | (* id : ?X1 -> ?X2 |- ?X2 *)
-	      cut X1; [exact id| constructor 1; fail]
+	    | (* id : forall (_: ?X1), ?X2 |- ?X2 *)
+	      cut X1; [exact id| $c1; fail]
 	    ]
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_ : ?X1), ?X2|- _ =>
           $t_flatten_contravariant_conj
 	  (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *)
-        | id: (Coq.Init.Logic.iff ?X1 ?X2) -> ?X3|- _ =>
-          assert ((X1 -> X2) -> (X2 -> X1) -> X3)
+        | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ =>
+          assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3)
 	    by (do 2 intro; apply id; split; assumption);
             clear id
-        | id: ?X1 -> ?X2|- _ =>
+        | id: forall (_:?X1), ?X2|- _ =>
           $t_flatten_contravariant_disj
 	  (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *)
         | |- ?X1 => $t_is_conj; split
@@ -230,75 +259,140 @@ let simplif ist =
         end;
         $t_not_dep_intros) >>
 
-let rec tauto_intuit t_reduce solver ist =
-  let t_axioms = tacticIn axioms
-  and t_simplif = tacticIn simplif
-  and t_is_disj = tacticIn is_disj
-  and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in
-  let t_solver = globTacticIn (fun _ist -> solver) in
-  <:tactic<
+let rec tauto_intuit flags t_reduce solver =
+  let t_axioms = tacticIn (axioms flags)
+  and t_simplif = tacticIn (simplif flags)
+  and t_is_disj = tacticIn (is_disj flags) in
+  let lfun = make_lfun [("t_solver", solver)] in
+  let ist = { default_ist () with lfun = lfun; } in
+  let vars = [Id.of_string "t_solver"] in
+  (vars, ist, <:tactic<
+   let rec t_tauto_intuit :=
    ($t_simplif;$t_axioms
    || match reverse goal with
-      | id:(?X1 -> ?X2)-> ?X3|- _ =>
+      | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ =>
 	  cut X3;
-	    [ intro; clear id; $t_tauto_intuit
-	    | cut (X1 -> X2);
+	    [ intro; clear id; t_tauto_intuit
+	    | cut (forall (_: X1), X2);
 		[ exact id
 		| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
-		  solve [ $t_tauto_intuit ]]]
+		  solve [ t_tauto_intuit ]]]
+      | id:forall (_:not ?X1), ?X3|- _ =>
+	  cut X3;
+	    [ intro; clear id; t_tauto_intuit
+	    | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]]
       | |- ?X1 =>
-          $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit]
+          $t_is_disj; solve [left;t_tauto_intuit | right;t_tauto_intuit]
       end
     ||
     (* NB: [|- _ -> _] matches any product *)
-    match goal with | |- _ -> _ => intro; $t_tauto_intuit
-    |  |- _  => $t_reduce;$t_solver
+    match goal with | |- forall (_ : _),  _ => intro; t_tauto_intuit
+    |  |- _  => $t_reduce;t_solver
     end
     ||
-    $t_solver
-   ) >>
-
-let reduction_not _ist =
-  if unfold_iff () then
-    <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
-  else
-    <:tactic< unfold Coq.Init.Logic.not in * >>
-
-let t_reduction_not = tacticIn reduction_not
-
-let intuition_gen tac =
-  interp (tacticIn (tauto_intuit t_reduction_not tac))
-
-let tauto_intuitionistic g =
-  try intuition_gen <:tactic<fail>> g
-  with
-    Refiner.FailError _ | UserError _ ->
-      errorlabstrm "tauto" (str "tauto failed.")
+    t_solver
+   ) in t_tauto_intuit >>)
+
+let reduction_not_iff _ist =
+  match !negation_unfolding, unfold_iff () with
+    | true, true -> <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >>
+    | true, false -> <:tactic< unfold Coq.Init.Logic.not in * >>
+    | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >>
+    | false, false -> <:tactic< idtac >>
+
+let t_reduction_not_iff = tacticIn reduction_not_iff
+
+let intuition_gen ist flags tac =
+  Proofview.Goal.enter begin fun gl ->
+  let tac = Value.of_closure ist tac in
+  let env = Proofview.Goal.env gl in
+  let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in
+  let glb_intuition = Tacintern.glob_tactic_env vars env intuition in
+  eval_tactic_ist ist glb_intuition
+  end
+
+let tauto_intuitionistic flags =
+  Proofview.tclORELSE
+    (intuition_gen (default_ist ()) flags <:tactic<fail>>)
+    begin function (e, info) -> match e with
+      | Refiner.FailError _ | UserError _ ->
+          Proofview.tclZERO (UserError ("tauto" , str "tauto failed."))
+      | e -> Proofview.tclZERO ~info e
+    end
 
 let coq_nnpp_path =
-  let dir = List.map id_of_string ["Classical_Prop";"Logic";"Coq"] in
-  Libnames.make_path (make_dirpath dir) (id_of_string "NNPP")
-
-let tauto_classical nnpp g =
-  try tclTHEN (apply nnpp) tauto_intuitionistic g
-  with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.")
+  let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in
+  Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP")
+
+let tauto_classical flags nnpp =
+  Proofview.tclORELSE
+    (Tacticals.New.tclTHEN (apply nnpp) (tauto_intuitionistic flags))
+    begin function (e, info) -> match e with
+      | UserError _ -> Proofview.tclZERO (UserError ("tauto" , str "Classical tauto failed."))
+      | e -> Proofview.tclZERO ~info e
+    end
 
-let tauto g =
-  try
-    let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in
+let tauto_gen flags =
+  (* spiwack: I use [tclBIND (tclUNIT ())] as a way to delay the effect
+     (in [constr_of_global]) to the application of the tactic. *)
+  Proofview.tclBIND
+    (Proofview.tclUNIT ())
+    begin fun () -> try
+      let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in
     (* try intuitionistic version first to avoid an axiom if possible *)
-    tclORELSE tauto_intuitionistic (tauto_classical nnpp) g
-  with Not_found ->
-    tauto_intuitionistic g
-
+      Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp)
+    with Not_found ->
+      tauto_intuitionistic flags
+    end
 
 let default_intuition_tac = <:tactic< auto with * >>
 
+(* This is the uniform mode dealing with ->, not, iff and types isomorphic to
+   /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types.
+   For the moment not and iff are still always unfolded. *)
+let tauto_uniform_unit_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = true;
+  strict_unit = false
+}
+
+(* This is the compatibility mode (not used) *)
+let tauto_legacy_flags = {
+  binary_mode = true;
+  binary_mode_bugged_detection = true;
+  strict_in_contravariant_hyp = true;
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+(* This is the improved mode *)
+let tauto_power_flags = {
+  binary_mode = false; (* support n-ary connectives *)
+  binary_mode_bugged_detection = false;
+  strict_in_contravariant_hyp = false; (* supports non-regular connectives *)
+  strict_in_hyp_and_ccl = false;
+  strict_unit = false
+}
+
+let tauto = tauto_gen tauto_uniform_unit_flags
+let dtauto = tauto_gen tauto_power_flags
+
 TACTIC EXTEND tauto
 | [ "tauto" ] -> [ tauto ]
 END
 
+TACTIC EXTEND dtauto
+| [ "dtauto" ] -> [ dtauto ]
+END
+
 TACTIC EXTEND intuition
-| [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
-| [ "intuition" tactic(t) ] -> [ intuition_gen t ]
+| [ "intuition" ] -> [ intuition_gen ist tauto_uniform_unit_flags default_intuition_tac ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen ist tauto_uniform_unit_flags t ]
+END
+
+TACTIC EXTEND dintuition
+| [ "dintuition" ] -> [ intuition_gen ist tauto_power_flags default_intuition_tac ]
+| [ "dintuition" tactic(t) ] -> [ intuition_gen ist tauto_power_flags t ]
 END
diff --git a/pretyping/term_dnet.ml b/tactics/term_dnet.ml
index 28a6c92c..e637b2e3 100644
--- a/pretyping/term_dnet.ml
+++ b/tactics/term_dnet.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        *)
@@ -9,9 +9,8 @@
 (*i*)
 open Util
 open Term
-open Sign
 open Names
-open Libnames
+open Globnames
 open Mod_subst
 open Pp (* debug *)
 (*i*)
@@ -49,10 +48,8 @@ struct
     | DCons   of ('t * 't option) * 't
     | DNil
 
-  type dconstr = dconstr t
-
   (* debug *)
-  let rec pr_dconstr f : 'a t -> std_ppcmds = function
+  let pr_dconstr f : 'a t -> std_ppcmds = function
     | DRel -> str "*"
     | DSort -> str "Sort"
     | DRef _ -> str "Ref"
@@ -84,17 +81,57 @@ struct
 	DCoFix (i,Array.map f ta,Array.map f ca)
     | DCons ((t,topt),u) -> DCons ((f t,Option.map f topt), f u)
 
-  let compare x y =
-    let make_name n =
-      match n with
-	| DRef(ConstRef con) ->
-	    DRef(ConstRef(constant_of_kn(canonical_con con)))
-	| DRef(IndRef (kn,i)) ->
-	    DRef(IndRef(mind_of_kn(canonical_mind kn),i))
-	| DRef(ConstructRef ((kn,i),j ))->
-	    DRef(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	| k -> k in
-    Pervasives.compare (make_name x) (make_name y)
+  let compare_ci ci1 ci2 =
+    let c = ind_ord ci1.ci_ind ci2.ci_ind in
+    if c = 0 then
+      let c = Int.compare ci1.ci_npar ci2.ci_npar in
+      if c = 0 then
+        let c = Array.compare Int.compare ci1.ci_cstr_ndecls ci2.ci_cstr_ndecls in
+        if c = 0 then
+          Array.compare Int.compare ci1.ci_cstr_nargs ci2.ci_cstr_nargs
+        else c
+      else c
+    else c
+
+  let compare cmp t1 t2 = match t1, t2 with
+  | DRel, DRel -> 0
+  | DSort, DSort -> 0
+  | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2
+  | DCtx (tl1, tr1), DCtx (tl2, tr2)
+  | DLambda (tl1, tr1), DCtx (tl2, tr2)
+  | DApp (tl1, tr1), DCtx (tl2, tr2) ->
+    let c = cmp tl1 tl2 in
+    if c = 0 then cmp tr1 tr2 else c
+
+  | DCase (ci1, c1, t1, p1), DCase (ci2, c2, t2, p2) ->
+    let c = cmp c1 c2 in
+    if c = 0 then
+      let c = cmp t1 t2 in
+      if c = 0 then
+        let c = Array.compare cmp p1 p2 in
+        if c = 0 then compare_ci ci1 ci2
+        else c
+      else c
+    else c
+
+  | DFix (i1, j1, tl1, pl1), DFix (i2, j2, tl2, pl2) ->
+    let c = Int.compare j1 j2 in
+    if c = 0 then
+      let c = Array.compare Int.compare i1 i2 in
+      if c = 0 then
+        let c = Array.compare cmp tl1 tl2 in
+        if c = 0 then Array.compare cmp pl1 pl2
+        else c
+      else c
+    else c
+  | DCoFix (i1, tl1, pl1), DCoFix (i2, tl2, pl2) ->
+    let c = Int.compare i1 i2 in
+    if c = 0 then
+      let c = Array.compare cmp tl1 tl2 in
+      if c = 0 then Array.compare cmp pl1 pl2
+      else c
+    else c
+  | _ -> Pervasives.compare t1 t2 (** OK **)
 
   let fold f acc = function
     | (DRel | DNil | DSort | DRef _) -> acc
@@ -118,9 +155,11 @@ struct
     | DCoFix (i,ta,ca) -> f ta.(0)
     | DCons ((t,topt),u) -> f u
 
+  let dummy_cmp () () = 0
+
   let fold2 (f:'a -> 'b -> 'c -> 'a) (acc:'a) (c1:'b t) (c2:'c t) : 'a =
     let head w = map (fun _ -> ()) w in
-    if compare (head c1) (head c2) <> 0
+    if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0)
     then invalid_arg "fold2:compare" else
       match c1,c2 with
 	| (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc
@@ -128,18 +167,18 @@ struct
 	  | DApp (c1,t1), DApp (c2,t2)
 	  | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2
 	| DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) ->
-	    array_fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2
+	    Array.fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2
 	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
-	    array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2
+	    Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2
 	| DCoFix(i,ta1,ca1), DCoFix(_,ta2,ca2) ->
-	    array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2
+	    Array.fold_left2 f (Array.fold_left2 f acc ta1 ta2) ca1 ca2
 	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
 	    f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2
 	| _ -> assert false
 
   let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t =
     let head w = map (fun _ -> ()) w in
-    if compare (head c1) (head c2) <> 0
+    if not (Int.equal (compare dummy_cmp (head c1) (head c2)) 0)
     then invalid_arg "map2_t:compare" else
       match c1,c2 with
 	| (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _) as cc ->
@@ -148,11 +187,11 @@ struct
 	| DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2)
 	| DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2)
 	| DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) ->
-	    DCase (ci, f p1 p2, f c1 c2, array_map2 f bl1 bl2)
+	    DCase (ci, f p1 p2, f c1 c2, Array.map2 f bl1 bl2)
 	| DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) ->
-	    DFix (ia,i,array_map2 f ta1 ta2,array_map2 f ca1 ca2)
+	    DFix (ia,i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2)
 	| DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) ->
-	    DCoFix (i,array_map2 f ta1 ta2,array_map2 f ca1 ca2)
+	    DCoFix (i,Array.map2 f ta1 ta2,Array.map2 f ca1 ca2)
 	| DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) ->
 	    DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2)
 	| _ -> assert false
@@ -160,6 +199,9 @@ struct
   let terminal = function
     | (DRel | DSort | DNil | DRef _) -> true
     | _ -> false
+
+  let compare t1 t2 = compare dummy_cmp t1 t2
+
 end
 
 (*
@@ -193,56 +235,67 @@ struct
 
   module TDnet : Dnet.S with type ident=Ident.t
 			and  type 'a structure = 'a DTerm.t
-			and  type meta = metavariable
-    = Dnet.Make(DTerm)(Ident)
-    (struct
-       type t = metavariable
-       let compare = Pervasives.compare
-     end)
+			and  type meta = int
+    = Dnet.Make(DTerm)(Ident)(Int)
 
   type t = TDnet.t
 
   type ident = TDnet.ident
 
-  type 'a pattern = 'a TDnet.pattern
-  type term_pattern = term_pattern DTerm.t pattern
-
-  type idset = TDnet.Idset.t
-
-  type result = ident * (constr*existential_key) * Termops.subst
+  (** We will freshen metas on the fly, to cope with the implementation defect
+      of Term_dnet which requires metas to be all distinct. *)
+  let fresh_meta =
+    let index = ref 0 in
+    fun () ->
+      let ans = !index in
+      let () = index := succ ans in
+      ans
 
   open DTerm
   open TDnet
 
-  let rec pat_of_constr c : term_pattern =
-    match kind_of_term c with
-      | Rel _          -> Term DRel
-      | Sort _         -> Term DSort
-      | Var i          -> Term (DRef (VarRef i))
-      | Const c        -> Term (DRef (ConstRef c))
-      | Ind i          -> Term (DRef (IndRef i))
-      | Construct c    -> Term (DRef (ConstructRef c))
-      | Term.Meta _    -> assert false
-      | Evar (i,_)     -> Meta i
-      | Case (ci,c1,c2,ca)     ->
-	  Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca))
-      | Fix ((ia,i),(_,ta,ca)) ->
-	  Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca))
-      | CoFix (i,(_,ta,ca))    ->
-	  Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca))
-      | Cast (c,_,_)   -> pat_of_constr c
-      | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c))
-      | (Prod (_,_,_) | LetIn(_,_,_,_))   ->
-	  let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c))
-      | App (f,ca)     ->
-	  Array.fold_left (fun c a -> Term (DApp (c,a)))
-	    (pat_of_constr f) (Array.map pat_of_constr ca)
-
-  and ctx_of_constr ctx c : term_pattern * term_pattern =
-    match kind_of_term c with
-      | Prod (_,t,c)   -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c
-      | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c
-      | _ -> ctx,pat_of_constr c
+  let pat_of_constr c : term_pattern =
+    (** To each evar we associate a unique identifier. *)
+    let metas = ref Evar.Map.empty in
+    let rec pat_of_constr c = match kind_of_term c with
+    | Rel _          -> Term DRel
+    | Sort _         -> Term DSort
+    | Var i          -> Term (DRef (VarRef i))
+    | Const (c,u)    -> Term (DRef (ConstRef c))
+    | Ind (i,u)      -> Term (DRef (IndRef i))
+    | Construct (c,u)-> Term (DRef (ConstructRef c))
+    | Term.Meta _    -> assert false
+    | Evar (i,_)     ->
+      let meta =
+        try Evar.Map.find i !metas
+        with Not_found ->
+          let meta = fresh_meta () in
+          let () = metas := Evar.Map.add i meta !metas in
+          meta
+      in
+      Meta meta
+    | Case (ci,c1,c2,ca)     ->
+      Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca))
+    | Fix ((ia,i),(_,ta,ca)) ->
+      Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca))
+    | CoFix (i,(_,ta,ca))    ->
+      Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca))
+    | Cast (c,_,_)   -> pat_of_constr c
+    | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c))
+    | (Prod (_,_,_) | LetIn(_,_,_,_))   ->
+      let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c))
+    | App (f,ca)     ->
+      Array.fold_left (fun c a -> Term (DApp (c,a)))
+        (pat_of_constr f) (Array.map pat_of_constr ca)
+    | Proj (p,c) -> 
+        Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c))
+
+    and ctx_of_constr ctx c = match kind_of_term c with
+    | Prod (_,t,c)   -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c
+    | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c
+    | _ -> ctx,pat_of_constr c
+    in
+    pat_of_constr c
 
   let empty_ctx : term_pattern -> term_pattern = function
     | Meta _ as c -> c
@@ -269,16 +322,8 @@ struct
     let c = empty_ctx (pat_of_constr c) in
     TDnet.add dn c id
 
-  let new_meta_no =
-    let ctr = ref 0 in
-    fun () -> decr ctr; !ctr
-
-  let new_meta_no = Evarutil.new_untyped_evar
 
-  let neutral_meta = new_meta_no()
-
-  let new_meta () = Meta (new_meta_no())
-  let new_evar () = mkEvar(new_meta_no(),[||])
+  let new_meta () = Meta (fresh_meta ())
 
   let rec remove_cap : term_pattern -> term_pattern = function
     | Term (DCons (t,u)) -> Term (DCons (t,remove_cap u))
@@ -291,91 +336,37 @@ struct
     | Meta m -> Term (DCtx(new_meta(), Meta m))
     | _ -> assert false
 
-  let init = let e = new_meta_no() in (mkEvar (e,[||]),e)
-
-  let rec e_subst_evar i (t:unit->constr) c =
-    match kind_of_term c with
-    | Evar (j,_) when i=j -> t()
-    | _ -> map_constr (e_subst_evar i t) c
-
-  let subst_evar i c = e_subst_evar i (fun _ -> c)
-
   (* debug *)
-  let rec pr_term_pattern p =
+(*  let rec pr_term_pattern p =
     (fun pr_t -> function
        | Term t -> pr_t t
-       | Meta m -> str"["++Util.pr_int (Obj.magic m)++str"]"
-    ) (pr_dconstr pr_term_pattern) p
+       | Meta m -> str"["++Pp.int (Obj.magic m)++str"]"
+    ) (pr_dconstr pr_term_pattern) p*)
 
-  let search_pat cpat dpat dn (up,plug) =
-    let whole_c = subst_evar plug cpat up in
+  let search_pat cpat dpat dn =
+    let whole_c = cpat in
     (* if we are at the root, add an empty context *)
-    let dpat = if isEvar_or_Meta up then under_prod (empty_ctx dpat) else dpat in
+    let dpat = under_prod (empty_ctx dpat) in
     TDnet.Idset.fold
       (fun id acc ->
 	 let c_id = Opt.reduce (Ident.constr_of id) in
 	 let (ctx,wc) =
 	   try Termops.align_prod_letin whole_c c_id
 	   with Invalid_argument _ -> [],c_id in
-	 let up = it_mkProd_or_LetIn up ctx in
 	 let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in
-	 try (id,(up,plug),Termops.filtering ctx Reduction.CUMUL wc whole_c)::acc
+	 try
+          let _ = Termops.filtering ctx Reduction.CUMUL wc whole_c in
+          id :: acc
 	 with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc
       ) (TDnet.find_match dpat dn) []
 
-  let fold_pattern_neutral f =
-    fold_pattern (fun acc (mset,m,dn) -> if m=neutral_meta then acc else f m dn acc)
-
-  let fold_pattern_nonlin f =
-    let defined = ref Gmap.empty in
-    fold_pattern_neutral
-      ( fun m dn acc ->
-	 let dn = try TDnet.inter dn (Gmap.find m !defined) with Not_found -> dn in
-	 defined := Gmap.add m dn !defined;
-	 f m dn acc )
-
-  let fold_pattern_up f acc dpat cpat dn (up,plug) =
-    fold_pattern_nonlin
-      ( fun m dn acc ->
-	  f dn (subst_evar plug (e_subst_evar neutral_meta new_evar cpat) up, m) acc
-      ) acc dpat dn
-
-  let possibly_under pat k dn (up,plug) =
-    let rec aux fst dn (up,plug) acc =
-      let cpat = pat() in
-      let dpat = pat_of_constr cpat in
-      let dpat = if fst then under_prod (empty_ctx dpat) else dpat in
-	(k dn (up,plug)) @
-	  snd (fold_pattern_up (aux false) acc dpat cpat dn (up,plug)) in
-      aux true dn (up,plug) []
-
-  let eq_pat eq () = mkApp(eq,[|mkEvar(neutral_meta,[||]);new_evar();new_evar()|])
-  let app_pat () = mkApp(new_evar(),[|mkEvar(neutral_meta,[||])|])
-
   (*
    * High-level primitives describing specific search problems
    *)
 
   let search_pattern dn pat =
     let pat = Opt.reduce pat in
-    search_pat pat (empty_ctx (pat_of_constr pat)) dn init
-
-  let search_concl dn pat =
-    let pat = Opt.reduce pat in
-    search_pat pat (under_prod (empty_ctx (pat_of_constr pat))) dn init
-
-  let search_eq_concl dn eq pat =
-    let pat = Opt.reduce pat in
-    let eq_pat = eq_pat eq () in
-    let eq_dpat = under_prod (empty_ctx (pat_of_constr eq_pat)) in
-    snd (fold_pattern_up
-      (fun dn up acc ->
-	 search_pat pat (pat_of_constr pat) dn up @ acc
-      ) [] eq_dpat eq_pat dn init)
-
-   let search_head_concl dn pat =
-    let pat = Opt.reduce pat in
-    possibly_under app_pat (search_pat pat (pat_of_constr pat)) dn init
+    search_pat pat (empty_ctx (pat_of_constr pat)) dn
 
   let find_all dn = Idset.elements (TDnet.find_all dn)
 
@@ -387,16 +378,11 @@ sig
   type t
   type ident
 
-  type result = ident * (constr*existential_key) * Termops.subst
-
   val empty : t
   val add : constr -> ident -> t -> t
   val union : t -> t -> t
   val subst : substitution -> t -> t
-  val search_pattern : t -> constr -> result list
-  val search_concl : t -> constr -> result list
-  val search_head_concl : t -> constr -> result list
-  val search_eq_concl : t -> constr -> constr -> result list
+  val search_pattern : t -> constr -> ident list
   val find_all : t -> ident list
   val map : (ident -> ident) -> t -> t
 end
diff --git a/pretyping/term_dnet.mli b/tactics/term_dnet.mli
index 9e629dcd..a5c80cc0 100644
--- a/pretyping/term_dnet.mli
+++ b/tactics/term_dnet.mli
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  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 Term
-open Sign
-open Libnames
 open Mod_subst
 
 (** Dnets on constr terms.
@@ -59,10 +57,6 @@ sig
   type t
   type ident
 
-  (** results of filtering : identifier, a context (term with Evar
-     hole) and the substitution in that context*)
-  type result = ident * (constr*existential_key) * Termops.subst
-
   val empty : t
 
   (** [add c i dn] adds the binding [(c,i)] to [dn]. [c] can be a
@@ -80,21 +74,7 @@ sig
 
   (** [search_pattern dn c] returns all terms/patterns in dn
      matching/matched by c *)
-  val search_pattern : t -> constr -> result list
-
-  (** [search_concl dn c] returns all matches under products and
-     letins, i.e. it finds subterms whose conclusion matches c. The
-     complexity depends only on c ! *)
-  val search_concl : t -> constr -> result list
-
-  (** [search_head_concl dn c] matches under products and applications
-     heads. Finds terms of the form [forall H_1...H_n, C t_1...t_n]
-     where C matches c *)
-  val search_head_concl : t -> constr -> result list
-
-  (** [search_eq_concl dn eq c] searches terms of the form [forall
-     H1...Hn, eq _ X1 X2] where either X1 or X2 matches c *)
-  val search_eq_concl : t -> constr -> constr -> result list
+  val search_pattern : t -> constr -> ident list
 
   (** [find_all dn] returns all idents contained in dn *)
   val find_all : t -> ident list
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
deleted file mode 100644
index 447ff327..00000000
--- a/tactics/termdn.ml
+++ /dev/null
@@ -1,135 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Names
-open Nameops
-open Term
-open Pattern
-open Glob_term
-open Libnames
-open Nametab
-
-(* Discrimination nets of terms.
-   See the module dn.ml for further explanations.
-   Eduardo (5/8/97) *)
-module Make =
-  functor (Z : Map.OrderedType) ->
-struct
-
-  module X = struct
-    type t = constr_pattern
-    let compare = Pervasives.compare
-  end
-
-  type term_label = 
-    | GRLabel of global_reference
-    | ProdLabel 
-    | LambdaLabel
-    | SortLabel
-	
-  module Y =  struct 
-     type t = term_label
-        let compare x y = 
-       let make_name n =
-	 match n with
-	 | GRLabel(ConstRef con) -> 
-	     GRLabel(ConstRef(constant_of_kn(canonical_con con)))
-	 | GRLabel(IndRef (kn,i)) ->
-	     GRLabel(IndRef(mind_of_kn(canonical_mind kn),i))
-	 | GRLabel(ConstructRef ((kn,i),j ))->
-	     GRLabel(ConstructRef((mind_of_kn(canonical_mind kn),i),j))
-	 | k -> k
-       in
-	 Pervasives.compare (make_name x) (make_name y)
-  end
-       
-      
-  module Dn = Dn.Make(X)(Y)(Z)
-      
-  type t = Dn.t
-
-  type 'a lookup_res = 'a Dn.lookup_res
-
-(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
-
-let decomp =
-  let rec decrec acc c = match kind_of_term c with
-    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
-    | Cast (c1,_,_) -> decrec acc c1
-    | _ -> (c,acc)
-  in
-  decrec []
-
-let decomp_pat =
-  let rec decrec acc = function
-    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
-    | c -> (c,acc)
-  in
-  decrec []
-
-let constr_pat_discr t =
-  if not (occur_meta_pattern t) then
-    None
-  else
-    match decomp_pat t with
-    | PRef ((IndRef _) as ref), args
-    | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
-    | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args)
-    | _ -> None
-
-let constr_pat_discr_st (idpred,cpred) t =
-  match decomp_pat t with
-  | PRef ((IndRef _) as ref), args
-  | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args)
-  | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) ->
-      Some(GRLabel ref,args)
-  | PVar v, args when not (Idpred.mem v idpred) ->
-      Some(GRLabel (VarRef v),args)
-  | PRef ((ConstRef c) as ref), args when not (Cpred.mem c cpred) ->
-      Some (GRLabel ref, args)
-  | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
-  | PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
-  | PSort s, [] -> Some (SortLabel, [])
-  | _ -> None
-
-open Dn
-
-let constr_val_discr t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
-    | Var id -> Label(GRLabel (VarRef id),l)
-    | Const _ -> Everything
-    | _ -> Nothing
-
-let constr_val_discr_st (idpred,cpred) t =
-  let c, l = decomp t in
-    match kind_of_term c with
-    | Const c -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l)
-    | Ind ind_sp -> Label(GRLabel (IndRef ind_sp),l)
-    | Construct cstr_sp -> Label(GRLabel (ConstructRef cstr_sp),l)
-    | Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l)
-    | Prod (n, d, c) -> Label(ProdLabel, [d; c])
-    | Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
-    | Sort _ -> Label (SortLabel, [])
-    | Evar _ -> Everything
-    | _ -> Nothing
-
-let create = Dn.create
-
-let add dn st = Dn.add dn (constr_pat_discr_st st)
-
-let rmv dn st = Dn.rmv dn (constr_pat_discr_st st)
-
-let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t
-
-let app f dn = Dn.app f dn
-
-end
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
deleted file mode 100644
index b13d639e..00000000
--- a/tactics/termdn.mli
+++ /dev/null
@@ -1,68 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Pattern
-open Libnames
-open Names
-
-(** Discrimination nets of terms. *)
-
-(** This module registers actions (typically tactics) mapped to patterns *)
-
-(** Patterns are stocked linearly as the list of its node in prefix
-order in such a way patterns having the same prefix have this common
-prefix shared and the seek for the action associated to the patterns
-that a term matches are found in time proportional to the maximal
-number of nodes of the patterns matching the term. The [transparent_state]
-indicates which constants and variables can be considered as rigid.
-These dnets are able to cope with existential variables as well, which match
-[Everything]. *)
-
-module Make :
-  functor (Z : Map.OrderedType) ->
-sig
-  
-  type t
-    
-  type 'a lookup_res
-    
-  val create : unit -> t
-    
-  (** [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
-    
-  val add : t -> transparent_state -> (constr_pattern * Z.t) -> t
-    
-  val rmv : t -> transparent_state -> (constr_pattern * Z.t) -> t
-    
-  (** [lookup t c] looks for patterns (with their action) matching term [c] *)
-    
-  val lookup : t -> transparent_state -> constr -> (constr_pattern * Z.t) list
-    
-  val app : ((constr_pattern * Z.t) -> unit) -> t -> unit
-
-    
-  (**/**)
-  (** These are for Nbtermdn *)
- 
-  type term_label = 
-    | GRLabel of global_reference
-    | ProdLabel 
-    | LambdaLabel
-    | SortLabel
-	
-  val constr_pat_discr_st : transparent_state ->
-    constr_pattern -> (term_label * constr_pattern list) option
-  val constr_val_discr_st : transparent_state ->
-    constr -> (term_label * constr list) lookup_res
-    
-  val constr_pat_discr : constr_pattern -> (term_label * constr_pattern list) option
-  val constr_val_discr : constr -> (term_label * constr list) lookup_res
-    
-  (**/**)
-end
diff --git a/test-suite/Makefile b/test-suite/Makefile
index ae1562c7..4a3a287c 100644
--- a/test-suite/Makefile
+++ b/test-suite/Makefile
@@ -30,15 +30,11 @@
 BIN := ../bin/
 LIB := ..
 
-ifeq ($(BEST),byte)
-  coqtop := $(BIN)coqtop.byte -boot -q -batch -I prerequisite
-  bincoqc := $(BIN)coqc -coqlib $(LIB) -byte -I prerequisite
-else
-  coqtop := $(BIN)coqtop -boot -q -batch -I prerequisite
-  bincoqc := $(BIN)coqc -coqlib $(LIB) -I prerequisite
-endif
+coqtop := $(BIN)coqtop -boot -q -batch -R prerequisite TestSuite
+bincoqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite
+bincoqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite
 
-command := $(coqtop) -top Top -load-vernac-source
+command := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source
 coqc := $(coqtop) -compile
 coqdep := $(BIN)coqdep -coqlib $(LIB)
 
@@ -46,7 +42,16 @@ SHOW := $(if $(VERBOSE),@true,@echo)
 HIDE := $(if $(VERBOSE),,@)
 REDIR := $(if $(VERBOSE),,> /dev/null 2>&1)
 
-bogomips :=
+# read out an emacs config and look for coq-prog-args; if such exists, return it
+get_coq_prog_args_helper = sed -n s'/^.*coq-prog-args:[[:space:]]*(\([^)]*\)).*/\1/p' $(1)
+get_coq_prog_args = $(strip $(filter-out "-emacs-U" "-emacs",$(shell $(call get_coq_prog_args_helper,$(1)))))
+SINGLE_QUOTE="
+#" # double up on the quotes, in a comment, to appease the emacs syntax highlighter
+# wrap the arguments in parens, but only if they exist
+get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1)))))
+
+
+bogomips:=
 ifneq (,$(wildcard /proc/cpuinfo))
   sedbogo := -e "s/bogomips.*: \([0-9]*\).*/\1/p" # i386, ppc
   sedbogo += -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" # sparc
@@ -59,6 +64,8 @@ ifeq (,$(bogomips))
 endif
 
 log_success = "==========> SUCCESS <=========="
+log_segfault = "==========> FAILURE <=========="
+log_anomaly = "==========> FAILURE <=========="
 log_failure = "==========> FAILURE <=========="
 log_intro = "==========> TESTING $(1) <=========="
 
@@ -69,14 +76,13 @@ log_intro = "==========> TESTING $(1) <=========="
 # Apart so that it can be easily skipped with overriding
 COMPLEXITY := $(if $(bogomips),complexity)
 
-BUGS := bugs/opened/shouldnotfail bugs/opened/shouldnotsucceed \
-  bugs/closed/shouldsucceed bugs/closed/shouldfail
+BUGS := bugs/opened bugs/closed
 
 VSUBSYSTEMS := prerequisite success failure $(BUGS) output \
-  interactive micromega $(COMPLEXITY) modules
+  interactive micromega $(COMPLEXITY) modules stm
 
 # All subsystems
-SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide
+SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk
 
 #######################################################################
 # Phony targets
@@ -93,11 +99,14 @@ bugs: $(BUGS)
 
 clean:
 	rm -f trace lia.cache
-	$(SHOW) "RM        <**/*.stamp> <**/*.vo> <**/*.log>"
+	$(SHOW) "RM        <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>"
 	$(HIDE)find . \( \
-	  -name '*.stamp' -o -name '*.vo' -o -name '*.log' \
+	  -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \
 	\) -print0 | xargs -0 rm -f
 
+distclean: clean
+	$(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f
+
 #######################################################################
 # Per-subsystem targets
 #######################################################################
@@ -113,7 +122,7 @@ $(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S))))
 # Summary
 #######################################################################
 
-summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort -g
+summary_dir = echo $(1); find $(2) -name '*.log' -print0 | xargs -0 -n 1 tail -n1 | sort
 
 .PHONY: summary summary.log
 
@@ -129,7 +138,10 @@ summary:
 	  $(call summary_dir, "Miscellaneous tests", misc); \
 	  $(call summary_dir, "Complexity tests", complexity); \
 	  $(call summary_dir, "Module tests", modules); \
+	  $(call summary_dir, "STM tests", stm); \
 	  $(call summary_dir, "IDE tests", ide); \
+	  $(call summary_dir, "VI tests", vio); \
+	  $(call summary_dir, "Coqchk tests", coqchk); \
 	  nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \
 	  nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \
 	  nb_tests=`expr $$nb_success + $$nb_failure`; \
@@ -152,32 +164,21 @@ summary.log:
 
 # All files are assumed to have <# of the bug>.v as a name
 
-# Opened bugs that should not succeed (FIXME: there were no such tests
-# at the time of writing this Makefile, but the possibility was in the
-# original shellscript... so left it here, but untested)
-$(addsuffix .log,$(wildcard bugs/opened/shouldnotsucceed/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
-	$(HIDE){ \
-	  $(call test_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
-	  if [ $$R = 0 ]; then \
-	    echo $(log_success); \
-	    echo "    $<...still active"; \
-	  else \
-	    echo $(log_failure); \
-	    echo "    $<...Error! (bug seems to be closed, please check)";
-	  fi;
-	} > "$@"
-
 # Opened bugs that should not fail
-$(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+$(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v
+	@echo "TEST      $<  $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
-	  if [ $$R != 0 ]; then \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...still active"; \
+	  elif [ $$R = 129 ]; then \
+	    echo $(log_anomaly); \
+	    echo "    $<...still active"; \
+	  elif [ $$R = 139 ]; then \
+	    echo $(log_segfault); \
+	    echo "    $<...still active"; \
 	  else \
 	    echo $(log_failure); \
 	    echo "    $<...Error! (bug seems to be closed, please check)"; \
@@ -185,11 +186,11 @@ $(addsuffix .log,$(wildcard bugs/opened/shouldnotfail/*.v)): %.v.log: %.v
 	} > "$@"
 
 # Closed bugs that should succeed
-$(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+$(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -199,30 +200,15 @@ $(addsuffix .log,$(wildcard bugs/closed/shouldsucceed/*.v)): %.v.log: %.v
 	  fi; \
 	} > "$@"
 
-# Closed bugs that should fail
-$(addsuffix .log,$(wildcard bugs/closed/shouldfail/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
-	$(HIDE){ \
-	  echo $(call log_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
-	  if [ $$R != 0 ]; then \
-	    echo $(log_success); \
-	    echo "    $<...Ok"; \
-	  else \
-	    echo $(log_failure); \
-	    echo "    $<...Error! (bug seems to be opened, please check)"; \
-	  fi; \
-	} > "$@"
-
 #######################################################################
 # Other generic tests
 #######################################################################
 
 $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(coqc) "$*" 2>&1; R=$$?; times; \
+	  $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R != 0 ]; then \
 	    echo $(log_failure); \
 	    echo "    $<...could not be prepared" ; \
@@ -233,11 +219,28 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v
 	} > "$@"
 
 $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
+	$(HIDE){ \
+	  opts="$(if $(findstring modules/,$<),-R modules Mods -impredicative-set)"; \
+	  echo $(call log_intro,$<); \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error! (should be accepted)"; \
+	  fi; \
+	} > "$@"
+
+stm: $(wildcard stm/*.v:%.v=%.v.log)
+$(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
-	  opts="$(if $(findstring modules/,$<),-I modules -impredicative-set)"; \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" $$opts 2>&1; R=$$?; times; \
+	  $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \
+	    -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \
+	    $$opts 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -248,11 +251,11 @@ $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.
 	} > "$@"
 
 $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
-	  if [ $$R != 0 ]; then \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
+	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
 	  else \
@@ -261,13 +264,14 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v
 	  fi; \
 	} > "$@"
 
-$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
 	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
-	  $(command) "$<" 2>&1 \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 \
 	    | grep -v "Welcome to Coq" \
+	    | grep -v "\[Loading ML file" \
 	    | grep -v "Skipping rcfile loading" \
 	    > $$tmpoutput; \
 	  diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \
@@ -282,10 +286,10 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v
 	} > "$@"
 
 $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(coqtop) < "$<" 2>&1; R=$$?; times; \
+	  $(coqtop) $(call get_coq_prog_args,"$<") < "$<" 2>&1; R=$$?; times; \
 	  if [ $$R = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -300,11 +304,11 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v
 # time is a 6120 bogomips cpu.
 ifneq (,$(bogomips))
 $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
 	  true "extract effective user time"; \
-	  res=`$(command) "$<" 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \
+	  res=`$(command) "$<" $(call get_coq_prog_args,"$<") 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1`; \
 	  R=$$?; times; \
 	  if [ $$R != 0 ]; then \
 	    echo $(log_failure); \
@@ -331,10 +335,10 @@ endif
 
 # Ideal-features tests
 $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v
-	@echo "TEST      $<"
+	@echo "TEST      $< $(call get_coq_prog_args_in_parens,"$<")"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(command) "$<" 2>&1; R=$$?; times; \
+	  $(command) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \
 	  if [ $$R != 0 ]; then \
 	      echo $(log_success); \
 	      echo "    $<...still wished"; \
@@ -346,35 +350,17 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v
 
 # Additionnal dependencies for module tests
 $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo
-%.vo: %.v
-	$(HIDE)$(coqtop) -compile $*
+modules/%.vo: modules/%.v
+	$(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=)
 
 #######################################################################
 # Miscellaneous tests
 #######################################################################
 
-misc: misc/xml.log misc/deps-order.log misc/universes.log
+misc: misc/deps-order.log misc/universes.log
 
-# Test xml compilation
-xml: misc/xml.log
-misc/xml.log:
-	@echo "TEST      misc/xml"
-	$(HIDE){ \
-	  echo $(call log_intro,xml); \
-	  rm -rf misc/xml; \
-	  COQ_XML_LIBRARY_ROOT=misc/xml \
-	  $(bincoqc) -xml misc/berardi_test 2>&1; times; \
-	  if [ ! -d misc/xml ]; then \
-	    echo $(log_failure); \
-	    echo "    misc/xml... failed"; \
-	  else \
-	    echo $(log_success); \
-	    echo "    misc/xml...apparently ok"; \
-	  fi; rm -rf misc/xml; \
-	} > "$@"
-
-# Check that both coqdep and coqtop/coqc takes the later -I/-R
-# Check that both coqdep and coqtop/coqc supports both -R and -I dir -as lib
+# Check that both coqdep and coqtop/coqc supports -R
+# Check that both coqdep and coqtop/coqc takes the later -R
 # See bugs 2242, 2337, 2339
 deps-order: misc/deps-order.log
 misc/deps-order.log:
@@ -383,12 +369,12 @@ misc/deps-order.log:
 	  echo $(call log_intro,deps-order); \
 	  rm -f misc/deps/*/*.vo; \
 	  tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \
-	  $(coqdep) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \
+	  $(coqdep) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 \
 	    | head -n 1 > $$tmpoutput; \
 	  diff -u misc/deps/deps.out $$tmpoutput 2>&1; R=$$?; times; \
-	  $(bincoqc) -I misc/deps/lib -as lib misc/deps/lib/foo.v 2>&1; \
-	  $(bincoqc) -I misc/deps/lib -as lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \
-	  $(coqtop) -I misc/deps/lib -as lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \
+	  $(bincoqc) -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1; \
+	  $(bincoqc) -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1; \
+	  $(coqtop) -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1; \
 	  S=$$?; times; \
 	  if [ $$R = 0 -a $$S = 0 ]; then \
 	    echo $(log_success); \
@@ -406,8 +392,8 @@ universes: misc/universes.log
 misc/universes.log: misc/universes/all_stdlib.v
 	@echo "TEST      misc/universes"
 	$(HIDE){ \
-	  $(bincoqc) -I misc/universes misc/universes/all_stdlib 2>&1; \
-	  $(bincoqc) -I misc/universes misc/universes/universes 2>&1; \
+	  $(bincoqc) -R misc/universes Universes misc/universes/all_stdlib 2>&1; \
+	  $(bincoqc) -R misc/universes Universes misc/universes/universes 2>&1; \
 	  mv universes.txt misc/universes; \
 	  N=`awk '{print $$3}' misc/universes/universes.txt | sort -u | wc -l`; \
 	  times; \
@@ -432,7 +418,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake))
 	@echo "TEST      $<"
 	$(HIDE){ \
 	  echo $(call log_intro,$<); \
-	  $(BIN)fake_ide "$(BIN)coqtop -boot" < $< 2>&1; \
+	  $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on" 2>&1; \
 	  if [ $$? = 0 ]; then \
 	    echo $(log_success); \
 	    echo "    $<...Ok"; \
@@ -441,3 +427,37 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake))
 	    echo "    $<...Error!"; \
 	  fi; \
 	} > "$@"
+
+vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v))
+
+%.vio.log:%.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  $(bincoqc) -quick -R vio vio $* 2>&1 && \
+	  $(coqtop) -R vio vio -vio2vo $*.vio 2>&1 && \
+	  $(bincoqchk) -R vio vio -norec $(subst /,.,$*) 2>&1; \
+	  if [ $$? = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error!"; \
+	  fi; \
+	} > "$@"
+
+coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v))
+
+%.chk.log:%.v
+	@echo "TEST      $<"
+	$(HIDE){ \
+	  $(bincoqc) -R coqchk coqchk $* 2>&1 && \
+	  $(bincoqchk) -R coqchk coqchk -norec $(subst /,.,$*) 2>&1; \
+	  if [ $$? = 0 ]; then \
+	    echo $(log_success); \
+	    echo "    $<...Ok"; \
+	  else \
+	    echo $(log_failure); \
+	    echo "    $<...Error!"; \
+	  fi; \
+	} > "$@"
+
diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v
index 92e50dba..352c7cea 100644
--- a/test-suite/bench/lists-100.v
+++ b/test-suite/bench/lists-100.v
@@ -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/test-suite/bench/lists_100.v b/test-suite/bench/lists_100.v
index 92e50dba..352c7cea 100644
--- a/test-suite/bench/lists_100.v
+++ b/test-suite/bench/lists_100.v
@@ -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/test-suite/bugs/2428.v b/test-suite/bugs/2428.v
new file mode 100644
index 00000000..a4f587a5
--- /dev/null
+++ b/test-suite/bugs/2428.v
@@ -0,0 +1,10 @@
+Axiom P : nat -> Prop.
+
+Definition myFact := forall x, P x.
+
+Hint Extern 1 (P _) => progress (unfold myFact in *).
+
+Lemma test : (True -> myFact) -> P 3.
+Proof. 
+  intros. debug eauto.
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/1100.v b/test-suite/bugs/closed/1100.v
index 32c78b4b..32c78b4b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1100.v
+++ b/test-suite/bugs/closed/1100.v
diff --git a/test-suite/bugs/closed/shouldsucceed/121.v b/test-suite/bugs/closed/121.v
index 8c5a3885..8c5a3885 100644
--- a/test-suite/bugs/closed/shouldsucceed/121.v
+++ b/test-suite/bugs/closed/121.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1243.v b/test-suite/bugs/closed/1243.v
index 7d6781db..7d6781db 100644
--- a/test-suite/bugs/closed/shouldsucceed/1243.v
+++ b/test-suite/bugs/closed/1243.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1302.v b/test-suite/bugs/closed/1302.v
index e94dfcfb..e94dfcfb 100644
--- a/test-suite/bugs/closed/shouldsucceed/1302.v
+++ b/test-suite/bugs/closed/1302.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1322.v b/test-suite/bugs/closed/1322.v
index 1ec7d452..1ec7d452 100644
--- a/test-suite/bugs/closed/shouldsucceed/1322.v
+++ b/test-suite/bugs/closed/1322.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1411.v b/test-suite/bugs/closed/1411.v
index a1a7b288..a1a7b288 100644
--- a/test-suite/bugs/closed/shouldsucceed/1411.v
+++ b/test-suite/bugs/closed/1411.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1414.v b/test-suite/bugs/closed/1414.v
index ee9e2504..ee9e2504 100644
--- a/test-suite/bugs/closed/shouldsucceed/1414.v
+++ b/test-suite/bugs/closed/1414.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1416.v b/test-suite/bugs/closed/1416.v
index ee092005..ee092005 100644
--- a/test-suite/bugs/closed/shouldsucceed/1416.v
+++ b/test-suite/bugs/closed/1416.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1419.v b/test-suite/bugs/closed/1419.v
index d021107d..d021107d 100644
--- a/test-suite/bugs/closed/shouldsucceed/1419.v
+++ b/test-suite/bugs/closed/1419.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1425.v b/test-suite/bugs/closed/1425.v
index 6be30174..6be30174 100644
--- a/test-suite/bugs/closed/shouldsucceed/1425.v
+++ b/test-suite/bugs/closed/1425.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1446.v b/test-suite/bugs/closed/1446.v
index 8cb2d653..8cb2d653 100644
--- a/test-suite/bugs/closed/shouldsucceed/1446.v
+++ b/test-suite/bugs/closed/1446.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1448.v b/test-suite/bugs/closed/1448.v
index fe3b4c8b..fe3b4c8b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1448.v
+++ b/test-suite/bugs/closed/1448.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1477.v b/test-suite/bugs/closed/1477.v
index dfc8c328..dfc8c328 100644
--- a/test-suite/bugs/closed/shouldsucceed/1477.v
+++ b/test-suite/bugs/closed/1477.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1483.v b/test-suite/bugs/closed/1483.v
index a3d7f168..a3d7f168 100644
--- a/test-suite/bugs/closed/shouldsucceed/1483.v
+++ b/test-suite/bugs/closed/1483.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/1507.v
index f2ab9100..f2ab9100 100644
--- a/test-suite/bugs/closed/shouldsucceed/1507.v
+++ b/test-suite/bugs/closed/1507.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1568.v b/test-suite/bugs/closed/1568.v
index 3609e9c8..3609e9c8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1568.v
+++ b/test-suite/bugs/closed/1568.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1576.v b/test-suite/bugs/closed/1576.v
index 3621f7a1..3621f7a1 100644
--- a/test-suite/bugs/closed/shouldsucceed/1576.v
+++ b/test-suite/bugs/closed/1576.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1582.v b/test-suite/bugs/closed/1582.v
index be5d3dd2..be5d3dd2 100644
--- a/test-suite/bugs/closed/shouldsucceed/1582.v
+++ b/test-suite/bugs/closed/1582.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1604.v b/test-suite/bugs/closed/1604.v
index 22c3df82..22c3df82 100644
--- a/test-suite/bugs/closed/shouldsucceed/1604.v
+++ b/test-suite/bugs/closed/1604.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1614.v b/test-suite/bugs/closed/1614.v
index 6bc165d4..6bc165d4 100644
--- a/test-suite/bugs/closed/shouldsucceed/1614.v
+++ b/test-suite/bugs/closed/1614.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1618.v b/test-suite/bugs/closed/1618.v
index a9b067ce..a9b067ce 100644
--- a/test-suite/bugs/closed/shouldsucceed/1618.v
+++ b/test-suite/bugs/closed/1618.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1634.v b/test-suite/bugs/closed/1634.v
index 0150c250..0150c250 100644
--- a/test-suite/bugs/closed/shouldsucceed/1634.v
+++ b/test-suite/bugs/closed/1634.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1643.v b/test-suite/bugs/closed/1643.v
index 879a65b1..879a65b1 100644
--- a/test-suite/bugs/closed/shouldsucceed/1643.v
+++ b/test-suite/bugs/closed/1643.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1680.v b/test-suite/bugs/closed/1680.v
index 524c7bab..524c7bab 100644
--- a/test-suite/bugs/closed/shouldsucceed/1680.v
+++ b/test-suite/bugs/closed/1680.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1683.v b/test-suite/bugs/closed/1683.v
index 3e99694b..3e99694b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1683.v
+++ b/test-suite/bugs/closed/1683.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1696.v b/test-suite/bugs/closed/1696.v
index 0826428a..0826428a 100644
--- a/test-suite/bugs/closed/shouldsucceed/1696.v
+++ b/test-suite/bugs/closed/1696.v
diff --git a/test-suite/bugs/closed/shouldfail/1703.v b/test-suite/bugs/closed/1703.v
index 6b5198cc..114e3185 100644
--- a/test-suite/bugs/closed/shouldfail/1703.v
+++ b/test-suite/bugs/closed/1703.v
@@ -4,4 +4,5 @@ Ltac intros_until n := intros until n.
 
 Goal forall i j m n : nat, i = 0 /\ j = 0 /\ m = 0 /\ n = 0.
 intro i.
-intros until i.
+Fail intros until i.
+Abort.
diff --git a/test-suite/bugs/closed/shouldsucceed/1704.v b/test-suite/bugs/closed/1704.v
index 4b02d5f9..4b02d5f9 100644
--- a/test-suite/bugs/closed/shouldsucceed/1704.v
+++ b/test-suite/bugs/closed/1704.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1711.v b/test-suite/bugs/closed/1711.v
index e16612e3..e16612e3 100644
--- a/test-suite/bugs/closed/shouldsucceed/1711.v
+++ b/test-suite/bugs/closed/1711.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1718.v b/test-suite/bugs/closed/1718.v
index 715fa941..715fa941 100644
--- a/test-suite/bugs/closed/shouldsucceed/1718.v
+++ b/test-suite/bugs/closed/1718.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1738.v b/test-suite/bugs/closed/1738.v
index c2926a2b..c2926a2b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1738.v
+++ b/test-suite/bugs/closed/1738.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1740.v b/test-suite/bugs/closed/1740.v
index ec4a7a6b..ec4a7a6b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1740.v
+++ b/test-suite/bugs/closed/1740.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1754.v b/test-suite/bugs/closed/1754.v
index 06b8dce8..06b8dce8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1754.v
+++ b/test-suite/bugs/closed/1754.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1773.v b/test-suite/bugs/closed/1773.v
index 211af89b..211af89b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1773.v
+++ b/test-suite/bugs/closed/1773.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1774.v b/test-suite/bugs/closed/1774.v
index 4c24b481..4c24b481 100644
--- a/test-suite/bugs/closed/shouldsucceed/1774.v
+++ b/test-suite/bugs/closed/1774.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1775.v b/test-suite/bugs/closed/1775.v
index 932949a3..932949a3 100644
--- a/test-suite/bugs/closed/shouldsucceed/1775.v
+++ b/test-suite/bugs/closed/1775.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1776.v b/test-suite/bugs/closed/1776.v
index 58491f9d..58491f9d 100644
--- a/test-suite/bugs/closed/shouldsucceed/1776.v
+++ b/test-suite/bugs/closed/1776.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1779.v b/test-suite/bugs/closed/1779.v
index 95bb66b9..95bb66b9 100644
--- a/test-suite/bugs/closed/shouldsucceed/1779.v
+++ b/test-suite/bugs/closed/1779.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1784.v b/test-suite/bugs/closed/1784.v
index fb2f0ca9..0b63d7b5 100644
--- a/test-suite/bugs/closed/shouldsucceed/1784.v
+++ b/test-suite/bugs/closed/1784.v
@@ -92,7 +92,7 @@ Next Obligation. intro H; inversion H; subst. Defined.
 Next Obligation.
   intro H1; contradict H. inversion H1; subst. assumption.
   contradict H0; assumption. Defined.
-Next Obligation.
+Next Obligation. 
   intro H1; contradict H0. inversion H1; subst. assumption. Defined.
 Next Obligation.
   intro H1; contradict H. inversion H1; subst. assumption. Defined.
diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/1791.v
index be0e8ae8..be0e8ae8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1791.v
+++ b/test-suite/bugs/closed/1791.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1834.v b/test-suite/bugs/closed/1834.v
index 947d15f0..884ac01c 100644
--- a/test-suite/bugs/closed/shouldsucceed/1834.v
+++ b/test-suite/bugs/closed/1834.v
@@ -53,7 +53,7 @@ Definition S1_1 y0 y1 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1) :=
    y1 e1.
 
 Definition eq_ok1 y0 y1 y2 (E: eq_1 y0 y1) :=
-  match E with exist e0 e1 => S1_1 y0 y1 e0 e1 = y2 end.
+  match E with exist _ e0 e1 => S1_1 y0 y1 e0 e1 = y2 end.
 
 Definition eq_2 y0 y1 y2 :=
   {E1:eq_1 y0 y1 | eq_ok1 y0 y1 y2 E1}.
@@ -81,7 +81,7 @@ Definition S2_2 y0 y1 y2 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
    y2 e2.
 
 Definition eq_ok2 y0 y1 y2 y3 (E: eq_2 y0 y1 y2) : Prop :=
-  match E with exist (exist e0 e1) e2 =>
+  match E with exist _ (exist _ e0 e1) e2 =>
      S2_2 y0 y1 y2 e0 e1 e2 = y3 end.
 
 Definition eq_3 y0 y1 y2 y3 :=
@@ -118,7 +118,7 @@ Definition S3_3 y0 y1 y2 y3 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
    y3 e3.
 
 Definition eq_ok3 y0 y1 y2 y3 y4 (E: eq_3 y0 y1 y2 y3) : Prop :=
-  match E with exist (exist (exist e0 e1) e2) e3 =>
+  match E with exist _ (exist _ (exist _ e0 e1) e2) e3 =>
      S3_3 y0 y1 y2 y3 e0 e1 e2 e3 = y4 end.
 
 Definition eq_4 y0 y1 y2 y3 y4 :=
@@ -165,7 +165,7 @@ Definition S4_4 y0 y1 y2 y3 y4 (e0:eq_0 y0) (e1:S0_0 y0 e0 = y1)
    y4 e4.
 
 Definition eq_ok4 y0 y1 y2 y3 y4 y5 (E: eq_4 y0 y1 y2 y3 y4) : Prop :=
-  match E with exist (exist (exist (exist e0 e1) e2) e3) e4 =>
+  match E with exist _ (exist _ (exist _ (exist _ e0 e1) e2) e3) e4 =>
      S4_4 y0 y1 y2 y3 y4 e0 e1 e2 e3 e4 = y5 end.
 
 Definition eq_5 y0 y1 y2 y3 y4 y5 :=
diff --git a/test-suite/bugs/closed/shouldsucceed/1844.v b/test-suite/bugs/closed/1844.v
index 17eeb352..17eeb352 100644
--- a/test-suite/bugs/closed/shouldsucceed/1844.v
+++ b/test-suite/bugs/closed/1844.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1865.v b/test-suite/bugs/closed/1865.v
index 17c19989..17c19989 100644
--- a/test-suite/bugs/closed/shouldsucceed/1865.v
+++ b/test-suite/bugs/closed/1865.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1891.v b/test-suite/bugs/closed/1891.v
index 2d90a2f1..68581117 100644
--- a/test-suite/bugs/closed/shouldsucceed/1891.v
+++ b/test-suite/bugs/closed/1891.v
@@ -7,7 +7,7 @@
 
   Lemma L (x: T unit): (unit -> T unit) -> unit.
   Proof.
-    refine (match x return _ with mkT n => fun g => f (g _) end).
+    refine (match x return _ with mkT _ n => fun g => f (g _) end).
     trivial.
   Qed.
 
diff --git a/test-suite/bugs/closed/shouldfail/1898.v b/test-suite/bugs/closed/1898.v
index 92490eb9..70461286 100644
--- a/test-suite/bugs/closed/shouldfail/1898.v
+++ b/test-suite/bugs/closed/1898.v
@@ -2,4 +2,5 @@
 
 Lemma bug_fold_unfold : True.
   set (h := 1).
-  fold h in h.
+  Fail fold h in h.
+  Abort.
diff --git a/test-suite/bugs/closed/shouldsucceed/1900.v b/test-suite/bugs/closed/1900.v
index cf03efda..cf03efda 100644
--- a/test-suite/bugs/closed/shouldsucceed/1900.v
+++ b/test-suite/bugs/closed/1900.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/1901.v
index 7d86adbf..7d86adbf 100644
--- a/test-suite/bugs/closed/shouldsucceed/1901.v
+++ b/test-suite/bugs/closed/1901.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1905.v b/test-suite/bugs/closed/1905.v
index 8c81d751..8c81d751 100644
--- a/test-suite/bugs/closed/shouldsucceed/1905.v
+++ b/test-suite/bugs/closed/1905.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1907.v b/test-suite/bugs/closed/1907.v
index 55fc8231..55fc8231 100644
--- a/test-suite/bugs/closed/shouldsucceed/1907.v
+++ b/test-suite/bugs/closed/1907.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1912.v b/test-suite/bugs/closed/1912.v
index 987a5417..987a5417 100644
--- a/test-suite/bugs/closed/shouldsucceed/1912.v
+++ b/test-suite/bugs/closed/1912.v
diff --git a/test-suite/bugs/closed/1915.v b/test-suite/bugs/closed/1915.v
new file mode 100644
index 00000000..7e62437d
--- /dev/null
+++ b/test-suite/bugs/closed/1915.v
@@ -0,0 +1,6 @@
+
+Require Import Setoid.
+
+Fail Goal forall x, impl True (x = 0) -> x = 0 -> False.
+(*intros x H E.
+rewrite H in E.*)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/1918.v
index 9d92fe12..9d92fe12 100644
--- a/test-suite/bugs/closed/shouldsucceed/1918.v
+++ b/test-suite/bugs/closed/1918.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/1925.v
index 4caee1c3..4caee1c3 100644
--- a/test-suite/bugs/closed/shouldsucceed/1925.v
+++ b/test-suite/bugs/closed/1925.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/1931.v
index 930ace1d..930ace1d 100644
--- a/test-suite/bugs/closed/shouldsucceed/1931.v
+++ b/test-suite/bugs/closed/1931.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/1935.v
index d5837619..d5837619 100644
--- a/test-suite/bugs/closed/shouldsucceed/1935.v
+++ b/test-suite/bugs/closed/1935.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1939.v b/test-suite/bugs/closed/1939.v
index 5e61529b..5e61529b 100644
--- a/test-suite/bugs/closed/shouldsucceed/1939.v
+++ b/test-suite/bugs/closed/1939.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1944.v b/test-suite/bugs/closed/1944.v
index ee2918c6..ee2918c6 100644
--- a/test-suite/bugs/closed/shouldsucceed/1944.v
+++ b/test-suite/bugs/closed/1944.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1951.v b/test-suite/bugs/closed/1951.v
index 12c0ef9b..7558b0b8 100644
--- a/test-suite/bugs/closed/shouldsucceed/1951.v
+++ b/test-suite/bugs/closed/1951.v
@@ -5,11 +5,11 @@ Set Printing Universes.
 
 Inductive enc (A:Type (*1*)) (* : Type.1 *) := C : A -> enc A.
 
-Definition id (X:Type(*5*)) (x:X) := x.
+Definition id (X:Type(*4*)) (x:X) := x.
 
-Lemma test : let S := Type(*6 : 7*) in enc S -> S.
+Lemma test : let S := Type(*5 : 6*) in enc S -> S.
 simpl; intros.
-apply enc.
+refine (enc _).
 apply id.
 apply Prop.
 Defined.
@@ -26,7 +26,7 @@ b : (list a) -> a.   (* i don't know if this *)
 Inductive sg : Type := Sg. (* single *)
 
 Definition ipl2 (P : a -> Type) :=   (* in Prop, that means P is true forall *)
-fold_right (fun x => prod (P x)) sg. (* the elements of a given list         *)
+  fold_right (fun x => fun A => prod (P x) A) sg. (* the elements of a given list         *)
 
 Definition ind
      : forall S : a -> Type,
@@ -55,7 +55,7 @@ Defined.
 
 Lemma k' : a -> Type. (* same lemma but with our bug *)
 intro;pattern H;apply ind;intros.
-  apply prod.
+  refine (prod _ _).
     induction ls.
       exact sg.
       exact sg.
diff --git a/test-suite/bugs/closed/shouldsucceed/1962.v b/test-suite/bugs/closed/1962.v
index a6b0fee5..a6b0fee5 100644
--- a/test-suite/bugs/closed/shouldsucceed/1962.v
+++ b/test-suite/bugs/closed/1962.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1963.v b/test-suite/bugs/closed/1963.v
index 11e2ee44..11e2ee44 100644
--- a/test-suite/bugs/closed/shouldsucceed/1963.v
+++ b/test-suite/bugs/closed/1963.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1977.v b/test-suite/bugs/closed/1977.v
index 28715040..28715040 100644
--- a/test-suite/bugs/closed/shouldsucceed/1977.v
+++ b/test-suite/bugs/closed/1977.v
diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/1981.v
index 99952682..99952682 100644
--- a/test-suite/bugs/closed/shouldsucceed/1981.v
+++ b/test-suite/bugs/closed/1981.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/2001.v
index d0b3bf17..d0b3bf17 100644
--- a/test-suite/bugs/closed/shouldsucceed/2001.v
+++ b/test-suite/bugs/closed/2001.v
diff --git a/test-suite/bugs/closed/shouldfail/2006.v b/test-suite/bugs/closed/2006.v
index 91a16f95..d353d0e2 100644
--- a/test-suite/bugs/closed/shouldfail/2006.v
+++ b/test-suite/bugs/closed/2006.v
@@ -1,7 +1,7 @@
 (* Take the type constraint on Record into account *)
 
 Definition Type1 := Type.
-Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *)
+Fail Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *)
 
 (*
 Remarks:
diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/2017.v
index df666148..df666148 100644
--- a/test-suite/bugs/closed/shouldsucceed/2017.v
+++ b/test-suite/bugs/closed/2017.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2021.v b/test-suite/bugs/closed/2021.v
index e598e5ae..e598e5ae 100644
--- a/test-suite/bugs/closed/shouldsucceed/2021.v
+++ b/test-suite/bugs/closed/2021.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2027.v b/test-suite/bugs/closed/2027.v
index fb53c6ef..fb53c6ef 100644
--- a/test-suite/bugs/closed/shouldsucceed/2027.v
+++ b/test-suite/bugs/closed/2027.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2083.v b/test-suite/bugs/closed/2083.v
index a6ce4de0..5f17f7af 100644
--- a/test-suite/bugs/closed/shouldsucceed/2083.v
+++ b/test-suite/bugs/closed/2083.v
@@ -15,7 +15,7 @@ Program Fixpoint check_n  (n : nat) (P : { i | i < n } -> bool) (p : nat)
 
 Require Import Omega.
 
-Solve Obligations using program_simpl ; auto with *; try omega.
+Solve Obligations with program_simpl ; auto with *; try omega.
 
 Next Obligation.
   apply H. simpl. omega.
diff --git a/test-suite/bugs/closed/shouldsucceed/2089.v b/test-suite/bugs/closed/2089.v
index aebccc94..aebccc94 100644
--- a/test-suite/bugs/closed/shouldsucceed/2089.v
+++ b/test-suite/bugs/closed/2089.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2095.v b/test-suite/bugs/closed/2095.v
index 28ea99df..28ea99df 100644
--- a/test-suite/bugs/closed/shouldsucceed/2095.v
+++ b/test-suite/bugs/closed/2095.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2108.v b/test-suite/bugs/closed/2108.v
index cad8baa9..cad8baa9 100644
--- a/test-suite/bugs/closed/shouldsucceed/2108.v
+++ b/test-suite/bugs/closed/2108.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2117.v b/test-suite/bugs/closed/2117.v
index 6377a8b7..6377a8b7 100644
--- a/test-suite/bugs/closed/shouldsucceed/2117.v
+++ b/test-suite/bugs/closed/2117.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2123.v b/test-suite/bugs/closed/2123.v
index 422a2c12..422a2c12 100644
--- a/test-suite/bugs/closed/shouldsucceed/2123.v
+++ b/test-suite/bugs/closed/2123.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2127.v b/test-suite/bugs/closed/2127.v
index 142ada26..142ada26 100644
--- a/test-suite/bugs/closed/shouldsucceed/2127.v
+++ b/test-suite/bugs/closed/2127.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2135.v b/test-suite/bugs/closed/2135.v
index 61882176..61882176 100644
--- a/test-suite/bugs/closed/shouldsucceed/2135.v
+++ b/test-suite/bugs/closed/2135.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2136.v b/test-suite/bugs/closed/2136.v
index d2b926f3..d2b926f3 100644
--- a/test-suite/bugs/closed/shouldsucceed/2136.v
+++ b/test-suite/bugs/closed/2136.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2137.v b/test-suite/bugs/closed/2137.v
index 6c2023ab..6c2023ab 100644
--- a/test-suite/bugs/closed/shouldsucceed/2137.v
+++ b/test-suite/bugs/closed/2137.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2139.v b/test-suite/bugs/closed/2139.v
index a7f35508..a7f35508 100644
--- a/test-suite/bugs/closed/shouldsucceed/2139.v
+++ b/test-suite/bugs/closed/2139.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2141.v b/test-suite/bugs/closed/2141.v
index 941ae530..941ae530 100644
--- a/test-suite/bugs/closed/shouldsucceed/2141.v
+++ b/test-suite/bugs/closed/2141.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/2145.v
index 4dc0de74..4dc0de74 100644
--- a/test-suite/bugs/closed/shouldsucceed/2145.v
+++ b/test-suite/bugs/closed/2145.v
diff --git a/test-suite/bugs/closed/2149.v b/test-suite/bugs/closed/2149.v
new file mode 100644
index 00000000..38c5f36a
--- /dev/null
+++ b/test-suite/bugs/closed/2149.v
@@ -0,0 +1,7 @@
+Lemma Foo : forall x y : nat, y = x -> y = x.
+Proof.
+intros x y.
+rename x into y, y into x.
+trivial.
+Qed.
+
diff --git a/test-suite/bugs/closed/2164.v b/test-suite/bugs/closed/2164.v
new file mode 100644
index 00000000..6adb3577
--- /dev/null
+++ b/test-suite/bugs/closed/2164.v
@@ -0,0 +1,334 @@
+(* Check that "inversion as" manages names as expected *)
+Inductive type: Set
+   := | int: type
+      | pointer: type -> type.
+Print type.
+
+Parameter value_set
+   : type -> Set.
+
+Parameter string : Set.
+
+Parameter Z : Set.
+
+Inductive lvalue (t: type): Set
+   := | var: string -> lvalue t (* name of the variable *)
+      | lvalue_loc: Z -> lvalue t (* address of the variable *)
+      | deref_l: lvalue (pointer t) -> lvalue t (* deref an lvalue ptr *)
+      | deref_r: rvalue (pointer t) -> lvalue t (* deref an rvalue ptr *)
+with rvalue (t: type): Set
+   := | value_of: lvalue t -> rvalue t (* variable as value *)
+      | mk_rvalue: value_set t -> rvalue t. (* literal value *)
+Print lvalue.
+
+Inductive statement: Set
+   := | void_stat: statement
+      | var_loc: (* to be destucted at end of scope *)
+           forall (t: type) (n: string) (loc: Z), statement
+      | var_ref: (* not to be destructed *)
+           forall (t: type) (n: string) (loc: Z), statement
+      | var_def: (* var def as typed in code *)
+           forall (t:type) (n: string) (val: rvalue t), statement
+      | assign:
+           forall (t: type) (var: lvalue t) (val: rvalue t), statement
+      | group:
+           forall (l: list statement), statement
+      | fun_def:
+           forall (s: string) (l: list statement), statement
+      | param_decl:
+           forall (t: type) (n: string), statement
+      | delete:
+           forall a: Z, statement.
+
+Inductive expr: Set
+:= | statement_to_expr: statement -> expr
+   | lvalue_to_expr: forall t: type, lvalue t -> expr
+   | rvalue_to_expr: forall t: type, rvalue t -> expr.
+
+Inductive executable_prim_expr: expr -> Set
+:=
+(* statements *)
+   | var_def_primitive:
+        forall (t: type) (n: string) (loc: Z),
+        executable_prim_expr
+           (statement_to_expr
+               (var_def t n
+                   (value_of t (lvalue_loc t loc))))
+   | assign_primitive:
+        forall (t: type) (loc1 loc2: Z),
+        executable_prim_expr
+           (statement_to_expr
+               (assign t (lvalue_loc t loc1)
+                   (value_of t (lvalue_loc t loc2))))
+(* rvalue *)
+   | mk_rvalue_primitive:
+        forall (t: type) (v: value_set t),
+        executable_prim_expr
+           (rvalue_to_expr t (mk_rvalue t v))
+(* lvalue *)
+   (* var *)
+   | var_primitive:
+        forall (t: type) (n: string),
+        executable_prim_expr (lvalue_to_expr t (var t n))
+   (* deref_l *)
+   | deref_l_primitive:
+        forall (t: type) (loc: Z),
+        executable_prim_expr
+           (lvalue_to_expr t
+               (deref_l t (lvalue_loc (pointer t) loc)))
+   (* deref_r *)
+   | deref_r_primitive:
+        forall (t: type) (loc: Z),
+        executable_prim_expr
+           (lvalue_to_expr t
+               (deref_r t
+                   (value_of (pointer t)
+                       (lvalue_loc (pointer t) loc)))).
+
+Inductive executable_sub_expr: expr -> Set
+:= | executable_sub_expr_prim:
+        forall e: expr,
+        executable_prim_expr e ->
+        executable_sub_expr e
+(* statements *)
+   | var_def_sub_rvalue:
+        forall (t: type) (n: string) (rv: rvalue t),
+        executable_sub_expr (rvalue_to_expr t rv) ->
+        executable_sub_expr (statement_to_expr (var_def t n rv))
+   | assign_sub_lvalue:
+        forall (t: type) (lv: lvalue t) (rv: rvalue t),
+        executable_sub_expr (lvalue_to_expr t lv) ->
+        executable_sub_expr (statement_to_expr (assign t lv rv))
+   | assign_sub_rvalue:
+        forall (t: type) (lv: lvalue t) (rv: rvalue t),
+        executable_sub_expr (rvalue_to_expr t rv) ->
+        executable_sub_expr (statement_to_expr (assign t lv rv))
+(* rvalue *)
+   | value_of_sub_lvalue:
+        forall (t: type) (lv: lvalue t),
+        executable_sub_expr (lvalue_to_expr t lv) ->
+        executable_sub_expr (rvalue_to_expr t (value_of t lv))
+(* lvalue *)
+   | deref_l_sub_lvalue:
+        forall (t: type) (lv: lvalue (pointer t)),
+        executable_sub_expr (lvalue_to_expr (pointer t) lv) ->
+        executable_sub_expr (lvalue_to_expr t (deref_l t lv))
+   | deref_r_sub_rvalue:
+        forall (t: type) (rv: rvalue (pointer t)),
+        executable_sub_expr (rvalue_to_expr (pointer t) rv) ->
+        executable_sub_expr (lvalue_to_expr t (deref_r t rv)).
+
+Inductive expr_kind: Set
+:= | statement_kind: expr_kind
+   | lvalue_kind: type -> expr_kind
+   | rvalue_kind: type -> expr_kind.
+
+Definition expr_to_kind: expr -> expr_kind.
+intro e.
+destruct e.
+exact statement_kind.
+exact (lvalue_kind t).
+exact (rvalue_kind t).
+Defined.
+
+Inductive def_sub_expr_subs:
+   forall e: expr,
+   forall ee: executable_sub_expr e,
+   forall ee': expr,
+   forall e': expr,
+   Prop
+:= | def_sub_expr_subs_prim:
+        forall e: expr,
+        forall p: executable_prim_expr e,
+        forall ee': expr,
+        expr_to_kind e = expr_to_kind ee' ->
+        def_sub_expr_subs e (executable_sub_expr_prim e p) ee' ee'
+   | def_sub_expr_subs_var_def_sub_rvalue:
+        forall (t: type) (n: string),
+        forall rv rv': rvalue t,
+        forall ee': expr,
+        forall se_rv: executable_sub_expr (rvalue_to_expr t rv),
+        def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee'
+           (rvalue_to_expr t rv') ->
+        def_sub_expr_subs
+           (statement_to_expr (var_def t n rv))
+           (var_def_sub_rvalue t n rv se_rv)
+           ee'
+           (statement_to_expr (var_def t n rv'))
+   | def_sub_expr_subs_assign_sub_lvalue:
+        forall t: type,
+        forall lv lv': lvalue t,
+        forall rv: rvalue t,
+        forall ee': expr,
+        forall se_lv: executable_sub_expr (lvalue_to_expr t lv),
+        def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee'
+           (lvalue_to_expr t lv') ->
+        def_sub_expr_subs
+           (statement_to_expr (assign t lv rv))
+           (assign_sub_lvalue t lv rv se_lv)
+           ee'
+           (statement_to_expr (assign t lv' rv))
+   | def_sub_expr_subs_assign_sub_rvalue:
+        forall t: type,
+        forall lv: lvalue t,
+        forall rv rv': rvalue t,
+        forall ee': expr,
+        forall se_rv: executable_sub_expr (rvalue_to_expr t rv),
+        def_sub_expr_subs (rvalue_to_expr t rv) se_rv ee'
+           (rvalue_to_expr t rv') ->
+        def_sub_expr_subs
+           (statement_to_expr (assign t lv rv))
+           (assign_sub_rvalue t lv rv se_rv)
+           ee'
+           (statement_to_expr (assign t lv rv'))
+   | def_sub_expr_subs_value_of_sub_lvalue:
+        forall t: type,
+        forall lv lv': lvalue t,
+        forall ee': expr,
+        forall se_lv: executable_sub_expr (lvalue_to_expr t lv),
+        def_sub_expr_subs (lvalue_to_expr t lv) se_lv ee'
+           (lvalue_to_expr t lv') ->
+        def_sub_expr_subs
+           (rvalue_to_expr t (value_of t lv))
+           (value_of_sub_lvalue t lv se_lv)
+           ee'
+           (rvalue_to_expr t (value_of t lv'))
+   | def_sub_expr_subs_deref_l_sub_lvalue:
+        forall t: type,
+        forall lv lv': lvalue (pointer t),
+        forall ee': expr,
+        forall se_lv: executable_sub_expr (lvalue_to_expr (pointer t) lv),
+        def_sub_expr_subs (lvalue_to_expr (pointer t) lv) se_lv ee'
+           (lvalue_to_expr (pointer t) lv') ->
+        def_sub_expr_subs
+           (lvalue_to_expr t (deref_l t lv))
+           (deref_l_sub_lvalue t lv se_lv)
+           ee'
+           (lvalue_to_expr t (deref_l t lv'))
+   | def_sub_expr_subs_deref_r_sub_rvalue:
+        forall t: type,
+        forall rv rv': rvalue (pointer t),
+        forall ee': expr,
+        forall se_rv: executable_sub_expr (rvalue_to_expr (pointer t) rv),
+        def_sub_expr_subs (rvalue_to_expr (pointer t) rv) se_rv ee'
+           (rvalue_to_expr (pointer t) rv') ->
+        def_sub_expr_subs
+           (lvalue_to_expr t (deref_r t rv))
+           (deref_r_sub_rvalue t rv se_rv)
+           ee'
+           (lvalue_to_expr t (deref_r t rv')).
+
+Lemma type_dec: forall t t': type, {t = t'} + {t <> t'}.
+Proof.
+intros t.
+induction t as [|t IH].
+destruct t'.
+tauto.
+right.
+discriminate.
+destruct t'.
+right.
+discriminate.
+destruct (IH t') as [H|H].
+left.
+f_equal.
+tauto.
+right.
+injection.
+tauto.
+Qed.
+Check type_dec.
+
+Definition sigT_get_proof:
+   forall T: Type,
+   forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'},
+   forall P: T -> Type,
+   forall t: T,
+   P t ->
+   sigT P ->
+      P t.
+intros T eq_dec_T P t H1 H2.
+destruct H2 as [t' H2].
+destruct (eq_dec_T t t') as [H3|H3].
+rewrite H3.
+exact H2.
+exact H1.
+Defined.
+
+Axiom sigT_get_proof_existT_same:
+   forall T: Type,
+   forall eq_dec_T: forall t t': T, {t = t'} + {~ t = t'},
+   forall P: T -> Type,
+   forall t: T,
+   forall H1 H2: P t,
+   sigT_get_proof T eq_dec_T P t H1 (existT P t H2) = H2.
+
+Theorem existT_injective:
+   forall T,
+   (forall t1 t2: T, { t1 = t2 } + { t1 <> t2 }) ->
+   forall P: T -> Type,
+   forall t: T,
+   forall pt1 pt2: P t,
+   existT P t pt1 = existT P t pt2 ->
+   pt1 = pt2.
+Proof.
+intros T T_dec P t pt1 pt2 H1.
+pose (H2 := f_equal (sigT_get_proof T T_dec P t pt1) H1).
+repeat rewrite sigT_get_proof_existT_same in H2.
+assumption.
+Qed.
+
+Ltac decide_equality_sub dec x x' H :=
+   destruct (dec x x') as [H|H];
+   [subst x'; try tauto|try(right; injection; tauto; fail)].
+
+Axiom value_set_dec:
+   forall t: type,
+   forall v v': value_set t,
+      {v = v'} + {v <> v'}.
+
+Theorem lvalue_dec:
+   forall (t: type) (l l': lvalue t), {l = l'} + {l <> l'}
+with rvalue_dec:
+   forall (t: type) (r r': rvalue t), {r = r'} + {r <> r'}.
+Admitted.
+
+Theorem sub_expr_subs_same_kind:
+   forall e: expr,
+   forall ee: executable_sub_expr e,
+   forall ee': expr,
+   forall e': expr,
+   def_sub_expr_subs e ee ee' e' ->
+   expr_to_kind e = expr_to_kind e'.
+Proof.
+intros e ee ee' e' H1.
+case H1; try (intros; tauto; fail).
+Qed.
+
+Theorem def_sub_expr_subs_assign_sub_lvalue_inversion:
+   forall t: type,
+   forall lv: lvalue t,
+   forall rv: rvalue t,
+   forall ee' e': expr,
+   forall ee_sub: executable_sub_expr (lvalue_to_expr t lv),
+   def_sub_expr_subs (statement_to_expr (assign t lv rv))
+      (assign_sub_lvalue t lv rv ee_sub) ee' e' ->
+   { lv': lvalue t
+   | def_sub_expr_subs (lvalue_to_expr t lv) ee_sub ee'
+        (lvalue_to_expr t lv')
+   & e' = statement_to_expr (assign t lv' rv) }.
+Proof.
+intros t lv rv ee' [s'|t' lv''|t' rv''] ee_sub H1;
+   try discriminate (sub_expr_subs_same_kind _ _ _ _ H1).
+destruct s' as [| | | |t' lv'' rv''| | | |];
+   try(assert (H2: False); [inversion H1|elim H2]; fail).
+destruct (type_dec t t') as [H2|H2];
+   [|assert (H3: False);
+     [|elim H3; fail]].
+2: inversion H1 as [];tauto.
+subst t'.
+exists lv''.
+ inversion H1 as
+   [| |t' lv''' lv'''' rv''' ee'' ee_sub' H2 (H3_1,H3_2,H3_3) (H4_1,H4_2,H4_3,H4_4,H4_5) H5 (H6_1,H6_2)| | | |].
+(* Check that all names are the given ones: *)
+clear t' lv''' lv'''' rv''' ee'' ee_sub' H2 H3_1 H3_2 H3_3 H4_1 H4_2 H4_3 H4_4 H4_5 H5 H6_1 H6_2.
diff --git a/test-suite/bugs/closed/shouldsucceed/2181.v b/test-suite/bugs/closed/2181.v
index 62820d86..62820d86 100644
--- a/test-suite/bugs/closed/shouldsucceed/2181.v
+++ b/test-suite/bugs/closed/2181.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2193.v b/test-suite/bugs/closed/2193.v
index fe258867..fe258867 100644
--- a/test-suite/bugs/closed/shouldsucceed/2193.v
+++ b/test-suite/bugs/closed/2193.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2230.v b/test-suite/bugs/closed/2230.v
index 5076fb2b..5076fb2b 100644
--- a/test-suite/bugs/closed/shouldsucceed/2230.v
+++ b/test-suite/bugs/closed/2230.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2231.v b/test-suite/bugs/closed/2231.v
index 03e2c9bb..03e2c9bb 100644
--- a/test-suite/bugs/closed/shouldsucceed/2231.v
+++ b/test-suite/bugs/closed/2231.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2244.v b/test-suite/bugs/closed/2244.v
index d499e515..d499e515 100644
--- a/test-suite/bugs/closed/shouldsucceed/2244.v
+++ b/test-suite/bugs/closed/2244.v
diff --git a/test-suite/bugs/closed/2250.v b/test-suite/bugs/closed/2250.v
new file mode 100644
index 00000000..565d7b68
--- /dev/null
+++ b/test-suite/bugs/closed/2250.v
@@ -0,0 +1,3 @@
+Check prod: Prop -> Prop -> Prop.
+(* (fun A B : Prop => (A * B)%type):Prop -> Prop -> Prop
+     : Prop -> Prop -> Prop *)
diff --git a/test-suite/bugs/closed/shouldfail/2251.v b/test-suite/bugs/closed/2251.v
index 642717f4..d0fa3f2b 100644
--- a/test-suite/bugs/closed/shouldfail/2251.v
+++ b/test-suite/bugs/closed/2251.v
@@ -2,4 +2,5 @@
 
 Lemma evar_rewrite : (forall a : nat, a = 0 -> True) -> True.
 intros; eapply H.  (* goal is  ?30 = nil  *)
-rewrite plus_n_Sm.
+Fail rewrite plus_n_Sm.
+Abort.
diff --git a/test-suite/bugs/closed/shouldsucceed/2255.v b/test-suite/bugs/closed/2255.v
index bf80ff66..bf80ff66 100644
--- a/test-suite/bugs/closed/shouldsucceed/2255.v
+++ b/test-suite/bugs/closed/2255.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2262.v b/test-suite/bugs/closed/2262.v
index b61f18b8..b61f18b8 100644
--- a/test-suite/bugs/closed/shouldsucceed/2262.v
+++ b/test-suite/bugs/closed/2262.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2281.v b/test-suite/bugs/closed/2281.v
index 40948d90..40948d90 100644
--- a/test-suite/bugs/closed/shouldsucceed/2281.v
+++ b/test-suite/bugs/closed/2281.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2295.v b/test-suite/bugs/closed/2295.v
index f5ca28dc..f5ca28dc 100644
--- a/test-suite/bugs/closed/shouldsucceed/2295.v
+++ b/test-suite/bugs/closed/2295.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2299.v b/test-suite/bugs/closed/2299.v
index c0552ca7..c0552ca7 100644
--- a/test-suite/bugs/closed/shouldsucceed/2299.v
+++ b/test-suite/bugs/closed/2299.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2300.v b/test-suite/bugs/closed/2300.v
index 4e587cbb..4e587cbb 100644
--- a/test-suite/bugs/closed/shouldsucceed/2300.v
+++ b/test-suite/bugs/closed/2300.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2303.v b/test-suite/bugs/closed/2303.v
index e614b9b5..e614b9b5 100644
--- a/test-suite/bugs/closed/shouldsucceed/2303.v
+++ b/test-suite/bugs/closed/2303.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2304.v b/test-suite/bugs/closed/2304.v
index 1ac2702b..1ac2702b 100644
--- a/test-suite/bugs/closed/shouldsucceed/2304.v
+++ b/test-suite/bugs/closed/2304.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2307.v b/test-suite/bugs/closed/2307.v
index 7c049495..7c049495 100644
--- a/test-suite/bugs/closed/shouldsucceed/2307.v
+++ b/test-suite/bugs/closed/2307.v
diff --git a/test-suite/bugs/opened/shouldnotfail/2310.v b/test-suite/bugs/closed/2310.v
index 8d1a5149..0be859ed 100644
--- a/test-suite/bugs/opened/shouldnotfail/2310.v
+++ b/test-suite/bugs/closed/2310.v
@@ -14,4 +14,4 @@ Definition replace a (y:Nest (prod a a)) : a = a -> Nest a.
    (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either
    leave P as subgoal or choose itself one solution *)
 
-intros. refine (Cons (cast H _ y)).
+intros. refine (Cons (cast H _ y)).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2320.v b/test-suite/bugs/closed/2320.v
index facb9ecf..facb9ecf 100644
--- a/test-suite/bugs/closed/shouldsucceed/2320.v
+++ b/test-suite/bugs/closed/2320.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2342.v b/test-suite/bugs/closed/2342.v
index 094e5466..6613b285 100644
--- a/test-suite/bugs/closed/shouldsucceed/2342.v
+++ b/test-suite/bugs/closed/2342.v
@@ -4,5 +4,5 @@
 Parameter A : Set.
 Parameter B : A -> Set.
 Parameter F : Set -> Prop. 
-Check (F (forall x, B x)). 
+Check (F (forall x, B x)).
 
diff --git a/test-suite/bugs/closed/shouldsucceed/2347.v b/test-suite/bugs/closed/2347.v
index e433f158..e433f158 100644
--- a/test-suite/bugs/closed/shouldsucceed/2347.v
+++ b/test-suite/bugs/closed/2347.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2350.v b/test-suite/bugs/closed/2350.v
index e91f22e2..e91f22e2 100644
--- a/test-suite/bugs/closed/shouldsucceed/2350.v
+++ b/test-suite/bugs/closed/2350.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2353.v b/test-suite/bugs/closed/2353.v
index b5c45c28..baae9a6e 100644
--- a/test-suite/bugs/closed/shouldsucceed/2353.v
+++ b/test-suite/bugs/closed/2353.v
@@ -4,9 +4,9 @@ Inductive term n := app (l : list term n).
 Definition term_list :=
   fix term_size n (t : term n) (acc : nat) {struct t} : nat :=
     match t with
-    | app l =>
+    | app _ l =>
       (fix term_list_size n (l : list term n) (acc : nat) {struct l} : nat :=
       match l with
-      | cons t q => term_list_size (S n) q (term_size n t acc)
+      | cons _ _ t q => term_list_size (S n) q (term_size n t acc)
       end) n l (S acc)
     end.
diff --git a/test-suite/bugs/closed/shouldsucceed/2360.v b/test-suite/bugs/closed/2360.v
index 4ae97c97..4ae97c97 100644
--- a/test-suite/bugs/closed/shouldsucceed/2360.v
+++ b/test-suite/bugs/closed/2360.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2362.v b/test-suite/bugs/closed/2362.v
index febb9c7b..febb9c7b 100644
--- a/test-suite/bugs/closed/shouldsucceed/2362.v
+++ b/test-suite/bugs/closed/2362.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2375.v b/test-suite/bugs/closed/2375.v
index c17c426c..c17c426c 100644
--- a/test-suite/bugs/closed/shouldsucceed/2375.v
+++ b/test-suite/bugs/closed/2375.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2378.v b/test-suite/bugs/closed/2378.v
index 7deec64d..35c69db2 100644
--- a/test-suite/bugs/closed/shouldsucceed/2378.v
+++ b/test-suite/bugs/closed/2378.v
@@ -66,9 +66,9 @@ Implicit Arguments lpSat.
 
 Fixpoint LPTransfo Pred1 Pred2 p2lp (f: LP Pred1): LP Pred2 :=
   match f with
-    LPPred p => p2lp p
-  | LPAnd f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2)
-  | LPNot f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1)
+    LPPred _ p => p2lp p
+  | LPAnd _ f1 f2 => LPAnd _ (LPTransfo Pred1 Pred2 p2lp f1) (LPTransfo Pred1 Pred2 p2lp f2)
+  | LPNot _ f1 => LPNot _ (LPTransfo Pred1 Pred2 p2lp f1)
   end.
 Implicit Arguments LPTransfo.
 
@@ -503,6 +503,9 @@ Qed.
 
 Require Export Coq.Logic.FunctionalExtensionality.
 Print PLanguage.
+
+Unset Standard Proposition Elimination Names.
+
 Program Definition PTransfo l1 l2 (tr: Transformation l1 l2) (h: isSharedTransfo l1 l2 tr): 
 Transformation (PLanguage l1) (PLanguage l2) :=
   mkTransformation (PLanguage l1) (PLanguage l2)
diff --git a/test-suite/bugs/closed/shouldsucceed/2388.v b/test-suite/bugs/closed/2388.v
index c7926711..c7926711 100644
--- a/test-suite/bugs/closed/shouldsucceed/2388.v
+++ b/test-suite/bugs/closed/2388.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2393.v b/test-suite/bugs/closed/2393.v
index fb4f9261..fb4f9261 100644
--- a/test-suite/bugs/closed/shouldsucceed/2393.v
+++ b/test-suite/bugs/closed/2393.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2404.v b/test-suite/bugs/closed/2404.v
index fe8eba54..8ac696e9 100644
--- a/test-suite/bugs/closed/shouldsucceed/2404.v
+++ b/test-suite/bugs/closed/2404.v
@@ -37,8 +37,8 @@ Definition Rweak : forall a b : bWorld, Type := RstarInv bwweak.
 
 Fixpoint exportRweak {a b} (aRWb : Rweak a b) (y : bName b) : option (bName a) :=
   match aRWb,y with
-  | starReflS a, y' => Some y'
-  | starTransS i j k jWk jRWi, y' =>
+  | starReflS _ a, y' => Some y'
+  | starTransS jWk jRWi, y' =>
     match (bexportw jWk y) with
     | Some x => exportRweak jRWi x
     | None   => None
diff --git a/test-suite/bugs/closed/2406.v b/test-suite/bugs/closed/2406.v
new file mode 100644
index 00000000..1bd66ffc
--- /dev/null
+++ b/test-suite/bugs/closed/2406.v
@@ -0,0 +1,6 @@
+(* Check correct handling of unsupported notations *)
+Notation "'Â’'" := (fun x => x) (at level 20).
+
+(* This fails with a syntax error but it is not catched by Fail
+Fail Definition crash_the_rooster f := Â’.
+*)
diff --git a/test-suite/bugs/closed/2447.v b/test-suite/bugs/closed/2447.v
new file mode 100644
index 00000000..fdeb69fc
--- /dev/null
+++ b/test-suite/bugs/closed/2447.v
@@ -0,0 +1,7 @@
+Record t := {x : bool; y : bool; z : bool}.
+
+Goal forall x1 x2 y z,
+  {| x := x1; y := y; z := z |} = {| x := x2; y := y; z := z |} -> x1 = x2.
+Proof.
+intros; congruence. (* was doing stack overflow *)
+Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2456.v b/test-suite/bugs/closed/2456.v
index 56f046c4..56f046c4 100644
--- a/test-suite/bugs/closed/shouldsucceed/2456.v
+++ b/test-suite/bugs/closed/2456.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2464.v b/test-suite/bugs/closed/2464.v
index af708587..af708587 100644
--- a/test-suite/bugs/closed/shouldsucceed/2464.v
+++ b/test-suite/bugs/closed/2464.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2467.v b/test-suite/bugs/closed/2467.v
index ad17814a..ad17814a 100644
--- a/test-suite/bugs/closed/shouldsucceed/2467.v
+++ b/test-suite/bugs/closed/2467.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2473.v b/test-suite/bugs/closed/2473.v
index 4c302512..4c302512 100644
--- a/test-suite/bugs/closed/shouldsucceed/2473.v
+++ b/test-suite/bugs/closed/2473.v
diff --git a/test-suite/bugs/closed/shouldfail/2586.v b/test-suite/bugs/closed/2586.v
index 6111a641..7e02e7f1 100644
--- a/test-suite/bugs/closed/shouldfail/2586.v
+++ b/test-suite/bugs/closed/2586.v
@@ -2,4 +2,5 @@ Require Import Setoid SetoidClass Program.
 
 Goal forall `(Setoid nat) x y, x == y -> S x == S y.
   intros.
-  clsubst H0.
\ No newline at end of file
+  Fail clsubst H0.
+  Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2603.v b/test-suite/bugs/closed/2603.v
index 371bfdc5..371bfdc5 100644
--- a/test-suite/bugs/closed/shouldsucceed/2603.v
+++ b/test-suite/bugs/closed/2603.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2608.v b/test-suite/bugs/closed/2608.v
index a4c95ff9..a4c95ff9 100644
--- a/test-suite/bugs/closed/shouldsucceed/2608.v
+++ b/test-suite/bugs/closed/2608.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2613.v b/test-suite/bugs/closed/2613.v
index 4f0470b1..4f0470b1 100644
--- a/test-suite/bugs/closed/shouldsucceed/2613.v
+++ b/test-suite/bugs/closed/2613.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2615.v b/test-suite/bugs/closed/2615.v
index 54e1a07c..dde6a6a5 100644
--- a/test-suite/bugs/closed/shouldsucceed/2615.v
+++ b/test-suite/bugs/closed/2615.v
@@ -12,3 +12,5 @@ Fail induction 1.
 refine (fun p => match p with _ => _ end).
 Undo.
 refine (fun p => match p with foo_intro _ _ => _ end).
+admit.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/2616.v b/test-suite/bugs/closed/2616.v
index 8758e32d..8758e32d 100644
--- a/test-suite/bugs/closed/shouldsucceed/2616.v
+++ b/test-suite/bugs/closed/2616.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2629.v b/test-suite/bugs/closed/2629.v
index 759cd3dd..759cd3dd 100644
--- a/test-suite/bugs/closed/shouldsucceed/2629.v
+++ b/test-suite/bugs/closed/2629.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2640.v b/test-suite/bugs/closed/2640.v
index da0cc68a..da0cc68a 100644
--- a/test-suite/bugs/closed/shouldsucceed/2640.v
+++ b/test-suite/bugs/closed/2640.v
diff --git a/test-suite/bugs/closed/2667.v b/test-suite/bugs/closed/2667.v
new file mode 100644
index 00000000..0631e535
--- /dev/null
+++ b/test-suite/bugs/closed/2667.v
@@ -0,0 +1,11 @@
+(* Check that extra arguments to Arguments Scope do not disturb use of *)
+(* scopes in constructors *)
+
+Inductive stmt : Type := Sskip: stmt | Scall : nat -> stmt.
+Bind Scope Cminor with stmt.
+
+(* extra argument is ok because of possible coercion to funclass *)
+Arguments Scope Scall [_ Cminor ].
+
+(* extra argument is ok because of possible coercion to funclass *)
+Fixpoint f (c: stmt) : Prop := match c with Scall _ => False | _ => False end.
diff --git a/test-suite/bugs/closed/shouldsucceed/2668.v b/test-suite/bugs/closed/2668.v
index 74c8fa34..74c8fa34 100644
--- a/test-suite/bugs/closed/shouldsucceed/2668.v
+++ b/test-suite/bugs/closed/2668.v
diff --git a/test-suite/bugs/closed/2670.v b/test-suite/bugs/closed/2670.v
new file mode 100644
index 00000000..c401420e
--- /dev/null
+++ b/test-suite/bugs/closed/2670.v
@@ -0,0 +1,21 @@
+(* Check that problems with several solutions are solved in 8.4 as in 8.2 and 8.3 *)
+
+Inductive Fin: nat -> Set :=
+| first k : Fin (S k)
+| succ k: Fin k -> Fin (S k).
+
+Lemma match_sym_eq_eq: forall (n1 n2: nat)(f: Fin n1)(e: n1 = n2),
+f = match sym_eq e in (_ = l) return (Fin l) with refl_equal =>
+    match e in (_ = l) return (Fin l) with refl_equal => f end end.
+Proof.
+  intros n1 n2 f e.
+  (* Next line has a dependent and a non dependent solution *)
+  (* 8.2 and 8.3 used to choose the dependent one which is the one to make *)
+  (* the goal progress *)
+  refine (match e return _ with refl_equal => _ end).
+  reflexivity.
+  Undo 2.
+  (* Next line similarly has a dependent and a non dependent solution *)
+  refine (match e with refl_equal => _ end).
+  reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/2680.v b/test-suite/bugs/closed/2680.v
new file mode 100644
index 00000000..0f573a28
--- /dev/null
+++ b/test-suite/bugs/closed/2680.v
@@ -0,0 +1,17 @@
+(* Tauto bug initially due to wrong test for binary connective *)
+
+Parameter A B : Type.
+
+Axiom P : A -> B ->  Prop.
+
+Inductive IP (a  : A) (b: B) : Prop :=
+| IP_def : P a b ->   IP a b.
+
+
+Goal forall (a : A) (b : B), IP a b ->  ~ IP a b -> False.
+Proof.
+  intros.
+  tauto.
+Qed.
+
+
diff --git a/test-suite/bugs/closed/2713.v b/test-suite/bugs/closed/2713.v
new file mode 100644
index 00000000..b5fc74bf
--- /dev/null
+++ b/test-suite/bugs/closed/2713.v
@@ -0,0 +1,17 @@
+Set Implicit Arguments.
+
+Definition pred_le A (P Q : A->Prop) := 
+  forall x, P x -> Q x.
+
+Lemma pred_le_refl : forall A (P:A->Prop),
+  pred_le P P.
+Proof. unfold pred_le. auto. Qed.
+
+Hint Resolve pred_le_refl.
+
+Lemma test : 
+  forall (P1 P2:nat->Prop), 
+  (forall Q, pred_le (fun a => P1 a /\ P2 a) Q -> True) ->
+   True.
+Proof. intros. eapply H. eauto. (* used to work *)
+       apply pred_le_refl. Qed.
diff --git a/test-suite/bugs/closed/2729.v b/test-suite/bugs/closed/2729.v
new file mode 100644
index 00000000..7929b881
--- /dev/null
+++ b/test-suite/bugs/closed/2729.v
@@ -0,0 +1,115 @@
+(* This bug report actually revealed two bugs in the reconstruction of
+   a term with "match" in the vm *)
+
+(* A simplified form of the first problem *)
+
+(* Reconstruction of terms normalized with vm when a constructor has *)
+(* let-ins arguments *)
+
+Record A : Type := C { a := 0 : nat; b : a=a }.
+Goal forall d:A, match d with C a b => b end = match d with C a b => b end.
+intro.
+vm_compute.
+(* Now check that it is well-typed *)
+match goal with |- ?c = _ => first [let x := type of c in idtac | fail 2] end.
+Abort.
+
+(* A simplified form of the second problem *)
+
+Parameter P : nat -> Type.
+
+Inductive box A := Box : A -> box A.
+
+Axiom com : {m : nat & box (P m) }.
+
+Lemma L :
+  (let (w, s) as com' return (com' = com -> Prop) := com in
+   let (s0) as s0
+     return (existT (fun m : nat => box (P m)) w s0 = com -> Prop) := s in
+   fun _ : existT (fun m : nat => box (P m)) w (Box (P w) s0) = com =>
+   True) eq_refl.
+Proof.
+vm_compute.
+(* Now check that it is well-typed (the "P w" used to be turned into "P s") *)
+match goal with |- ?c => first [let x := type of c in idtac | fail 2] end.
+Abort.
+
+(* Then the original report *)
+
+Require Import Equality.
+
+Parameter NameSet : Set.
+Parameter SignedName : Set.
+Parameter SignedName_compare : forall (x y : SignedName), comparison.
+Parameter pu_type : NameSet -> NameSet -> Type.
+Parameter pu_nameOf : forall {from to : NameSet}, pu_type from to -> SignedName.
+Parameter commute : forall {from mid1 mid2 to : NameSet},
+              pu_type from mid1 -> pu_type mid1 to
+           -> pu_type from mid2 -> pu_type mid2 to -> Prop.
+
+Program Definition castPatchFrom {from from' to : NameSet}
+                                 (HeqFrom : from = from')
+                                 (p : pu_type from to)
+                               : pu_type from' to
+    := p.
+
+Class PatchUniverse : Type := mkPatchUniverse {
+
+    commutable : forall {from mid1 to : NameSet},
+                        pu_type from mid1 -> pu_type mid1 to -> Prop
+        := fun {from mid1 to : NameSet}
+               (p : pu_type from mid1) (q : pu_type mid1 to) =>
+           exists mid2   : NameSet,
+           exists q' : pu_type from mid2,
+           exists p' : pu_type mid2 to,
+           commute p q q' p';
+
+    commutable_dec : forall {from mid to : NameSet}
+                            (p : pu_type from mid)
+                            (q : pu_type mid to),
+                     {mid2 : NameSet &
+                     { q' : pu_type from mid2 &
+                     { p' : pu_type mid2 to &
+                     commute p q q' p' }}}
+                   + {~(commutable p q)}
+}.
+
+Inductive SequenceBase (pu : PatchUniverse)
+                     : NameSet -> NameSet -> Type
+    := Nil : forall {cxt : NameSet},
+             SequenceBase pu cxt cxt
+     | Cons : forall {from mid to : NameSet}
+                     (p : pu_type from mid)
+                     (qs : SequenceBase pu mid to),
+              SequenceBase pu from to.
+Implicit Arguments Nil [pu cxt].
+Implicit Arguments Cons [pu from mid to].
+
+Program Fixpoint insertBase {pu : PatchUniverse}
+                            {from mid to : NameSet}
+                            (p : pu_type from mid)
+                            (qs : SequenceBase pu mid to)
+                          : SequenceBase pu from to
+    := match qs with
+       | Nil => Cons p Nil
+       | Cons q qs' =>
+           match SignedName_compare (pu_nameOf p) (pu_nameOf q) with
+           | Lt => Cons p qs
+           | _  => match commutable_dec p (castPatchFrom _ q) with
+                   | inleft (existT _ _ (existT _ q' (existT _ p' _))) => Cons q'
+(insertBase p' qs')
+                   | inright _ => Cons p qs
+                   end
+           end
+       end.
+
+Lemma insertBaseConsLt {pu : PatchUniverse}
+                       {o op opq opqr : NameSet}
+                       (p : pu_type o op)
+                       (q : pu_type op opq)
+                       (rs : SequenceBase pu opq opqr)
+                       (p_Lt_q : SignedName_compare (pu_nameOf p) (pu_nameOf q)
+= Lt)
+                     : insertBase p (Cons q rs) = Cons p (Cons q rs).
+Proof.
+vm_compute.
diff --git a/test-suite/bugs/closed/shouldsucceed/2732.v b/test-suite/bugs/closed/2732.v
index f22a8ccc..f22a8ccc 100644
--- a/test-suite/bugs/closed/shouldsucceed/2732.v
+++ b/test-suite/bugs/closed/2732.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2733.v b/test-suite/bugs/closed/2733.v
index fd7bd3bd..832de4f9 100644
--- a/test-suite/bugs/closed/shouldsucceed/2733.v
+++ b/test-suite/bugs/closed/2733.v
@@ -1,3 +1,5 @@
+Unset Asymmetric Patterns.
+
 Definition goodid : forall {A} (x: A), A := fun A x => x.
 Definition wrongid : forall A (x: A), A := fun {A} x => x.
 
@@ -17,9 +19,9 @@ end.
 Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 ->
 alt_list t1 t3 :=
   match l with
-  | nil _ => fun _ l2 => P l2
-  | Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2)
-  | Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2)
+  | nil => fun _ l2 => P l2
+  | Ncons n l1 => fun _ l2 => Ncons n (app (@P) l1 l2)
+  | Bcons b l1 => fun _ l2 => Bcons b (app (@P) l1 l2)
   end.
 
 Check (fun {t t'} (l: alt_list t t') =>
diff --git a/test-suite/bugs/closed/shouldsucceed/2734.v b/test-suite/bugs/closed/2734.v
index 826361be..826361be 100644
--- a/test-suite/bugs/closed/shouldsucceed/2734.v
+++ b/test-suite/bugs/closed/2734.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2750.v b/test-suite/bugs/closed/2750.v
index fc580f10..fc580f10 100644
--- a/test-suite/bugs/closed/shouldsucceed/2750.v
+++ b/test-suite/bugs/closed/2750.v
diff --git a/test-suite/bugs/closed/2810.v b/test-suite/bugs/closed/2810.v
new file mode 100644
index 00000000..a66078c6
--- /dev/null
+++ b/test-suite/bugs/closed/2810.v
@@ -0,0 +1,10 @@
+Section foo.
+  Variable A : Type.
+  Let B := A.
+
+  Hint Unfold B.
+
+  Goal False.
+    clear B. autounfold with core.
+  Abort.
+End foo.
diff --git a/test-suite/bugs/closed/shouldsucceed/2817.v b/test-suite/bugs/closed/2817.v
index 08dff992..08dff992 100644
--- a/test-suite/bugs/closed/shouldsucceed/2817.v
+++ b/test-suite/bugs/closed/2817.v
diff --git a/test-suite/bugs/closed/2818.v b/test-suite/bugs/closed/2818.v
new file mode 100644
index 00000000..010855cf
--- /dev/null
+++ b/test-suite/bugs/closed/2818.v
@@ -0,0 +1,11 @@
+Module M.
+
+Local Ltac t := exact I.
+Ltac u := t.
+
+End M.
+
+Goal True.
+Proof.
+M.u.
+Qed.
diff --git a/test-suite/bugs/closed/2828.v b/test-suite/bugs/closed/2828.v
new file mode 100644
index 00000000..0b8abace
--- /dev/null
+++ b/test-suite/bugs/closed/2828.v
@@ -0,0 +1,4 @@
+Parameter A B : Type.
+Coercion POL (p : prod A B) := fst p.
+Goal forall x : prod A B, A.
+  intro x. Fail exact x.
diff --git a/test-suite/bugs/closed/2830.v b/test-suite/bugs/closed/2830.v
new file mode 100644
index 00000000..b72c821d
--- /dev/null
+++ b/test-suite/bugs/closed/2830.v
@@ -0,0 +1,226 @@
+(* Bug report #2830 (evar defined twice) covers different bugs *)
+
+(* 1- This was submitted by qb.h.agws *)
+
+Module A.
+
+Set Implicit Arguments.
+
+Inductive Bit := O | I.
+
+Inductive BitString: nat -> Set :=
+| bit: Bit -> BitString 0
+| bitStr: forall n: nat, Bit -> BitString n -> BitString (S n).
+
+Definition BitOr (a b: Bit) :=
+  match a, b with
+  | O, O => O
+  | _, _ => I
+  end.
+
+(* Should fail with an error; used to failed in 8.4 and trunk with
+   anomaly Evd.define: cannot define an evar twice *)
+
+Fail Fixpoint StringOr (n m: nat) (a: BitString n) (b: BitString m) :=
+  match a with
+  | bit a' =>
+      match b with
+      | bit b' => bit (BitOr a' b')
+      | bitStr b' bT => bitStr b' (StringOr (bit a') bT)
+      end
+  | bitStr a' aT =>
+      match b with
+      | bit b' => bitStr a' (StringOr aT (bit b'))
+      | bitStr b' bT => bitStr (BitOr a' b') (StringOr aT bT)
+      end
+  end.
+
+End A.
+
+(* 2- This was submitted by Andrew Appel *)
+
+Module B.
+
+Require Import Program Relations.
+
+Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A)  :=
+{ af_unage : forall x x' y', level x' = level y' -> age1 x = Some x' -> exists y, age1 y = Some y'
+; af_level1 : forall x, age1 x = None <-> level x = 0
+; af_level2 : forall x y, age1 x = Some y -> level x = S (level y)
+}.
+
+Implicit Arguments af_unage [[A] [level] [age1]].
+Implicit Arguments af_level1 [[A] [level] [age1]].
+Implicit Arguments af_level2 [[A] [level] [age1]].
+
+Class ageable (A:Type) := mkAgeable
+{ level : A -> nat
+; age1 : A -> option A
+; age_facts : ageable_facts A level age1
+}.
+Definition age {A} `{ageable A} (x y:A) := age1 x = Some y.
+Definition necR   {A} `{ageable A} : relation A := clos_refl_trans A age.
+Delimit Scope pred with pred.
+Local Open Scope pred.
+
+Definition hereditary {A} (R:A->A->Prop) (p:A->Prop) :=
+  forall a a':A, R a a' -> p a -> p a'.
+
+Definition pred (A:Type) {AG:ageable A} :=
+  { p:A -> Prop | hereditary age p }.
+
+Bind Scope pred with pred.
+
+Definition app_pred {A} `{ageable A} (p:pred A) : A -> Prop := proj1_sig p.
+Definition pred_hereditary `{ageable} (p:pred A) := proj2_sig p.
+Coercion app_pred : pred >-> Funclass.
+Global Opaque pred.
+
+Definition derives {A} `{ageable A} (P Q:pred A) := forall a:A, P a -> Q a.
+Implicit Arguments derives.
+
+Program Definition andp {A} `{ageable A} (P Q:pred A) : pred A :=
+   fun a:A => P a /\ Q a.
+Next Obligation.
+  intros; intro; intuition;  apply pred_hereditary with a; auto.
+Qed.
+
+Program Definition imp {A} `{ageable A} (P Q:pred A) : pred A :=
+   fun a:A => forall a':A, necR a a' -> P a' -> Q a'.
+Next Obligation.
+  intros; intro; intuition.
+  apply H1; auto.
+  apply rt_trans with a'; auto.
+  apply rt_step; auto.
+Qed.
+
+Program Definition allp {A} `{ageable A} {B: Type} (f: B -> pred A) : pred A
+  := fun a => forall b, f b a.
+Next Obligation.
+  intros; intro; intuition.
+  apply pred_hereditary with a; auto.
+  apply H1.
+Qed.
+
+Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred.
+Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity).
+Notation "'All'  x ':' T  ',' P " := (allp (fun x:T => P%pred)) (at level 65, x at level 99) : pred.
+
+Lemma forall_pred_ext  {A} `{agA : ageable A}: forall B P Q,
+ (All x : B, (P x <--> Q x)) |-- (All x : B, P x) <--> (All x: B, Q x).
+Abort.
+
+End B.
+
+(* 3. *)
+
+(* This was submitted by Anthony Cowley *)
+
+Require Import Coq.Classes.Morphisms.
+Require Import Setoid.
+
+Module C.
+
+Reserved Notation "a ~> b" (at level 70, right associativity).
+Reserved Notation "a ≈ b" (at level 54).
+Generalizable All Variables.
+
+Class Category (Object:Type) (Hom:Object -> Object -> Type) := {
+    hom := Hom where "a ~> b" := (hom a b) : category_scope
+  ; ob := Object
+  ; id : forall a, hom a a
+  ; comp : forall c b a, hom b c -> hom a b -> hom a c
+    where "g ∘ f" := (comp _ _ _ g f)  : category_scope
+  ; eqv : forall a b, hom a b -> hom a b -> Prop
+    where "f ≈ g" := (eqv _ _ f g) : category_scope
+  ; eqv_equivalence : forall a b, Equivalence (eqv a b)
+  ; comp_respects : forall a b c,
+    Proper (eqv b c ==> eqv a b ==> eqv a c) (comp c b a)
+  ; left_identity : forall `(f:a ~> b), id b ∘ f ≈ f
+  ; right_identity : forall `(f:a ~> b), f ∘ id a ≈ f
+  ; associativity : forall `(f:a~>b) `(g:b~>c) `(h:c~>d),
+    h ∘ (g ∘ f) ≈ (h ∘ g) ∘ f
+}.
+Notation "a ~> b" := (@hom _ _ _ a b) : category_scope.
+Notation "g ∘ f" := (@comp _ _ _ _ _ _ g f) : category_scope.
+Notation "a ≈ b" := (@eqv _ _ _ _ _ a b) : category_scope.
+Notation "a ~{ C }~> b" := (@hom _ _ C a b) (at level 100) : category_scope.
+Coercion ob : Category >-> Sortclass.
+
+Open Scope category_scope.
+
+Add Parametric Relation `(C:Category Ob Hom) (a b : Ob) : (hom a b) (eqv a b)
+  reflexivity proved by (@Equivalence_Reflexive _ _ (eqv_equivalence a b))
+  symmetry proved by (@Equivalence_Symmetric _ _ (eqv_equivalence a b))
+  transitivity proved by (@Equivalence_Transitive _ _ (eqv_equivalence a b))
+  as parametric_relation_eqv.
+
+Add Parametric Morphism `(C:Category Ob Hom) (c b a : Ob) : (comp c b a)
+  with signature (eqv _ _ ==> eqv _ _ ==> eqv _ _) as parametric_morphism_comp.
+  intros x y Heq x' y'. apply comp_respects. exact Heq.
+  Defined.
+
+Class Functor `(C:Category) `(D:Category) (im : C -> D) := {
+  functor_im := im
+  ; fmap : forall {a b}, `(a ~> b) -> im a ~> im b
+  ; fmap_respects : forall a b (f f' : a ~> b), f ≈ f' -> fmap f ≈ fmap f'
+  ; fmap_preserves_id : forall a, fmap (id a) ≈ id (im a)
+  ; fmap_preserves_comp : forall `(f:a~>b) `(g:b~>c), 
+    fmap g ∘ fmap f ≈ fmap (g ∘ f)
+}.
+Coercion functor_im : Functor >-> Funclass.
+Implicit Arguments fmap [Object Hom C Object0 Hom0 D im a b].
+
+Add Parametric Morphism `(C:Category) `(D:Category)
+  (Im:C->D) (F:Functor C D Im) (a b:C) : (@fmap _ _ C _ _ D Im F a b)
+  with signature (@eqv C _ C a b ==> @eqv D _ D (Im a) (Im b)) 
+  as parametric_morphism_fmap.
+intros. apply fmap_respects. assumption. Qed.
+
+(* HERE IS THE PROBLEMATIC INSTANCE. If we change this to a regular Definition,
+   then the problem goes away. *)
+Instance functor_comp `{C:Category} `{D:Category} `{E:Category} 
+  {Gim} (G:Functor D E Gim) {Fim} (F:Functor C D Fim)
+  : Functor C E (Basics.compose Gim Fim).
+intros. apply Build_Functor with (fmap := fun a b f => fmap G (fmap F f)).
+abstract (intros; rewrite H; reflexivity).
+abstract (intros; repeat (rewrite fmap_preserves_id); reflexivity).
+abstract (intros; repeat (rewrite fmap_preserves_comp); reflexivity).
+Defined.
+
+Definition skel {A:Type} : relation A := @eq A.
+Instance skel_equiv A : Equivalence (@skel A).
+Admitted.
+
+Import FunctionalExtensionality.
+Instance set_cat : Category Type (fun A B => A -> B) := {
+  id := fun A => fun x => x
+  ; comp c b a f g := fun x => f (g x)
+  ; eqv := fun A B => @skel (A -> B)
+}.
+intros. compute. symmetry. apply eta_expansion.
+intros. compute. symmetry. apply eta_expansion.
+intros. compute. reflexivity. Defined.
+
+(* The [list] type constructor is a Functor. *)
+
+Import List.
+
+Definition setList (A:set_cat) := list A.
+Instance list_functor : Functor set_cat set_cat setList.
+apply Build_Functor with (fmap := @map).
+intros. rewrite H. reflexivity.
+intros; simpl; apply functional_extensionality. 
+  induction x; [auto|simpl]. rewrite IHx. reflexivity.
+intros; simpl; apply functional_extensionality.
+  induction x; [auto|simpl]. rewrite IHx. reflexivity.
+Defined.
+
+Local Notation "[ a , .. , b ]" := (a :: .. (b :: nil) ..) : list_scope.
+Definition setFmap {Fim} {F:Functor set_cat set_cat Fim} `(f:A~>B) (xs:Fim A) := fmap F f xs.
+
+(* We want to infer the [Functor] instance based on the value's
+   structure, but the [functor_comp] instance throws things awry. *)
+Eval cbv in setFmap (fun x => x * 3) [67,8].
+
+End C.
diff --git a/test-suite/bugs/closed/2834.v b/test-suite/bugs/closed/2834.v
new file mode 100644
index 00000000..6015c53b
--- /dev/null
+++ b/test-suite/bugs/closed/2834.v
@@ -0,0 +1,4 @@
+(* Testing typing of subst *)
+
+Lemma eqType2Set (a b : Set) (H : @eq Type a b) : @eq Set a b.
+Fail subst.
diff --git a/test-suite/bugs/closed/shouldsucceed/2836.v b/test-suite/bugs/closed/2836.v
index a948b75e..a948b75e 100644
--- a/test-suite/bugs/closed/shouldsucceed/2836.v
+++ b/test-suite/bugs/closed/2836.v
diff --git a/test-suite/bugs/closed/shouldsucceed/2837.v b/test-suite/bugs/closed/2837.v
index 5d984463..5d984463 100644
--- a/test-suite/bugs/closed/shouldsucceed/2837.v
+++ b/test-suite/bugs/closed/2837.v
diff --git a/test-suite/bugs/closed/2839.v b/test-suite/bugs/closed/2839.v
new file mode 100644
index 00000000..e396fe06
--- /dev/null
+++ b/test-suite/bugs/closed/2839.v
@@ -0,0 +1,10 @@
+(* Check a case where ltac typing error should result in error, not anomaly *)
+
+Goal forall (H : forall x : nat, x = x), False.
+intro.
+Fail
+  let H :=
+    match goal with
+    | [ H : appcontext G [@eq _ _] |- _ ] => let H' := context G[@plus 2] in H'
+    end
+  in pose H.
diff --git a/test-suite/bugs/closed/2846.v b/test-suite/bugs/closed/2846.v
new file mode 100644
index 00000000..8d6d348a
--- /dev/null
+++ b/test-suite/bugs/closed/2846.v
@@ -0,0 +1,3 @@
+Variable R : Type.
+
+Fail Inductive I : R := c : R.
diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v
new file mode 100644
index 00000000..de137d39
--- /dev/null
+++ b/test-suite/bugs/closed/2848.v
@@ -0,0 +1,9 @@
+Require Import Setoid.
+
+Parameter value' : Type.
+Parameter equiv' : value' -> value' -> Prop.
+
+Add Parametric Relation : _ equiv'
+  reflexivity proved by (Equivalence.equiv_reflexive _)
+  transitivity proved by (Equivalence.equiv_transitive _)
+    as apply_equiv'_rel.
diff --git a/test-suite/bugs/closed/2850.v b/test-suite/bugs/closed/2850.v
new file mode 100644
index 00000000..64a93aeb
--- /dev/null
+++ b/test-suite/bugs/closed/2850.v
@@ -0,0 +1,2 @@
+Definition id {A} (x : A) := x.
+Fail Compute id.
diff --git a/test-suite/bugs/closed/2854.v b/test-suite/bugs/closed/2854.v
new file mode 100644
index 00000000..14aee17f
--- /dev/null
+++ b/test-suite/bugs/closed/2854.v
@@ -0,0 +1,7 @@
+Section foo.
+  Let foo := Type.
+  Definition bar : foo -> foo := @id _.
+  Goal False.
+    subst foo.
+    Fail pose bar as f.
+    (* simpl in f. *)
diff --git a/test-suite/bugs/closed/2876.v b/test-suite/bugs/closed/2876.v
new file mode 100644
index 00000000..a66ee6b3
--- /dev/null
+++ b/test-suite/bugs/closed/2876.v
@@ -0,0 +1,11 @@
+Lemma test_bug : forall (R:nat->nat->Prop) n m m' (P: Prop),
+  P ->
+  (P -> R n m) ->
+  (P -> R n m') ->
+  (forall u, R n u -> u = u -> True) -> 
+  True.
+Proof.
+  intros * HP H1 H2 H3. eapply H3. 
+  eauto. (* H1 is used, but H2 should be used since it is the last hypothesis *)
+  auto.
+Qed.
diff --git a/test-suite/bugs/closed/2883.v b/test-suite/bugs/closed/2883.v
new file mode 100644
index 00000000..5a5d90a4
--- /dev/null
+++ b/test-suite/bugs/closed/2883.v
@@ -0,0 +1,34 @@
+Require Import List.
+Require Import Coq.Program.Equality.
+
+Inductive star {genv state : Type}
+  (step : genv -> state -> state -> Prop)
+  (ge : genv) : state -> state -> Prop :=
+  | star_refl : forall s : state, star step ge s s
+  | star_step :
+    forall (s1 : state) (s2 : state)
+      (s3 : state),
+      step ge s1 s2 ->
+      star step ge s2 s3 ->
+      star step ge s1 s3.
+
+Parameter genv expr env mem : Type.
+Definition genv' := genv.
+Inductive state : Type :=
+ | State : expr -> env -> mem -> state.
+Parameter step : genv' -> state -> state -> Prop.
+
+Section Test.
+
+Variable ge : genv'.
+
+Lemma compat_eval_steps:
+  forall a b e a' b',
+  star step ge (State a e b) (State a' e b') ->
+  True.
+Proof.
+  intros. dependent induction H.
+  trivial.
+  eapply IHstar; eauto.
+  replace s2 with (State a' e b') by admit. eauto.
+Qed. (* Oups *)
diff --git a/test-suite/bugs/closed/2900.v b/test-suite/bugs/closed/2900.v
new file mode 100644
index 00000000..8f4264e9
--- /dev/null
+++ b/test-suite/bugs/closed/2900.v
@@ -0,0 +1,28 @@
+(* Was raising stack overflow in 8.4 and assertion failed in future 8.5 *)
+Set Implicit Arguments.
+
+Require Import List.
+Require Import Coq.Program.Equality.
+
+(** Reflexive-transitive closure ( R* ) *)
+
+Inductive rtclosure (A : Type) (R : A-> A->Prop) : A->A->Prop :=
+  | rtclosure_refl : forall x,
+      rtclosure R x x
+  | rtclosure_step : forall y x z,
+      R x y -> rtclosure R y z -> rtclosure R x z.
+  (* bug goes away if rtclosure_step is commented out *)
+
+(** The closure of the trivial binary relation [eq] *)
+
+Definition tr (A:Type) := rtclosure (@eq A).
+
+(** The bug *)
+
+Lemma bug : forall A B (l t:list A) (r s:list B),
+    length l = length r ->
+    tr (combine l r) (combine t s) -> tr l t.
+Proof.
+  intros * E Hp.
+  (* bug goes away if [revert E] is called explicitly *)
+  dependent induction Hp.
diff --git a/test-suite/bugs/closed/2920.v b/test-suite/bugs/closed/2920.v
new file mode 100644
index 00000000..13548b9e
--- /dev/null
+++ b/test-suite/bugs/closed/2920.v
@@ -0,0 +1,2 @@
+Fail Definition my_f_equal {A B : Type} (f : A -> B) (a a' : A) (p : a = a') : f a = f a' :=
+  eq_ind _ _ (fun a' => f a = f a') _ _ p.
diff --git a/test-suite/bugs/closed/2923.v b/test-suite/bugs/closed/2923.v
new file mode 100644
index 00000000..8a0003a3
--- /dev/null
+++ b/test-suite/bugs/closed/2923.v
@@ -0,0 +1,12 @@
+Module Type SIGNATURE1.
+  Inductive IndType: Set :=
+    | AConstructor.
+End SIGNATURE1.
+
+Module Type SIGNATURE2.
+  Declare Module M1: SIGNATURE1.
+End SIGNATURE2.
+
+Module M2 (Module M1_: SIGNATURE1) : SIGNATURE2.
+  Module M1 := M1_.
+End M2.
diff --git a/test-suite/bugs/closed/shouldsucceed/2928.v b/test-suite/bugs/closed/2928.v
index 21e92ae2..21e92ae2 100644
--- a/test-suite/bugs/closed/shouldsucceed/2928.v
+++ b/test-suite/bugs/closed/2928.v
diff --git a/test-suite/bugs/closed/2930.v b/test-suite/bugs/closed/2930.v
new file mode 100644
index 00000000..0994b6fb
--- /dev/null
+++ b/test-suite/bugs/closed/2930.v
@@ -0,0 +1,12 @@
+(* Checking that let-in's hiding evars are expanded when enforcing
+   "occur-check" *)
+
+Require Import List.
+
+Definition foo x y :=
+let xy := (x, y) in
+let bar xys  :=
+      match xys with
+      | nil => xy :: nil
+      | xy' :: xys' => xy' :: xys'
+      end in bar (nil : list (nat * nat)).
diff --git a/test-suite/bugs/closed/2945.v b/test-suite/bugs/closed/2945.v
new file mode 100644
index 00000000..59b57c07
--- /dev/null
+++ b/test-suite/bugs/closed/2945.v
@@ -0,0 +1,5 @@
+Notation "f1 =1 f2 :> A" := (f1 = (f2 : A))
+  (at level 70, f2 at next level, A at level 90) : fun_scope.
+
+Notation "e :? pf" := (eq_rect _ (fun X : _ => X) e _ pf)
+  (no associativity, at level 90).
diff --git a/test-suite/bugs/closed/2966.v b/test-suite/bugs/closed/2966.v
new file mode 100644
index 00000000..debada85
--- /dev/null
+++ b/test-suite/bugs/closed/2966.v
@@ -0,0 +1,79 @@
+(** Non-termination and state monad with extraction *)
+Require Import List.
+
+Set Implicit Arguments.
+Set Asymmetric Patterns.
+
+Module MemSig.
+  Definition t: Type := list Type.
+  
+  Definition Nth (sig: t) (n: nat) :=
+    nth n sig unit.
+End MemSig.
+
+(** A memory of type [Mem.t s] is the union of cells whose type is specified
+    by [s]. *)
+Module Mem.
+  Inductive t: MemSig.t -> Type :=
+  | Nil: t nil
+  | Cons: forall (T: Type), option T -> forall (sig: MemSig.t), t sig ->
+    t (T :: sig).
+End Mem.
+
+Module Ref.
+  Inductive t (sig: MemSig.t) (T: Type): Type :=
+  | Input: t sig T.
+  
+  Definition Read (sig: MemSig.t) (T: Type) (ref: t sig T) (s: Mem.t sig)
+    : option T :=
+    match ref with
+    | Input => None
+    end.
+End Ref.
+
+Module Monad.
+  Definition t (sig: MemSig.t) (A: Type) :=
+    Mem.t sig -> option A * Mem.t sig.
+  
+  Definition Return (sig: MemSig.t) (A: Type) (x: A): t sig A :=
+    fun s =>
+      (Some x, s).
+  
+  Definition Bind (sig: MemSig.t) (A B: Type) (x: t sig A) (f: A -> t sig B)
+    : t sig B :=
+    fun s =>
+    match x s with
+    | (Some x', s') => f x' s'
+    | (None, s') => (None, s')
+    end.
+
+  Definition Select (T: Type) (f g: unit -> T): T :=
+    f tt.
+  
+  (** Read in a reference. *)
+  Definition Read (sig: MemSig.t) (T: Type) (ref: Ref.t sig T)
+    : t sig T :=
+    fun s =>
+      match Ref.Read ref s with
+      | None => (None, s)
+      | Some x => (Some x, s)
+      end.
+End Monad.
+
+Import Monad.
+
+Definition pop (sig: MemSig.t) (T: Type) (trace: Ref.t sig (list T))
+  : Monad.t sig T :=
+  Bind (Read trace) (fun _ s => (None, s)).
+
+Definition sig: MemSig.t := (list nat: Type) :: nil.
+
+Definition trace: Ref.t sig (list nat).
+Admitted.
+
+Definition Gre (sig: MemSig.t) (trace: _)
+    (f: bool -> bool): Monad.t sig nat :=
+    Select (fun _ => pop trace) (fun _ => Return 0).
+
+Definition Arg :=
+  Gre trace (fun _ => false).
diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v
new file mode 100644
index 00000000..ff75a1f3
--- /dev/null
+++ b/test-suite/bugs/closed/2969.v
@@ -0,0 +1,25 @@
+(* Check that Goal.V82.byps and Goal.V82.env are consistent *)
+
+(* This is a shorten variant of the initial bug which raised anomaly *)
+
+Goal forall x : nat, (forall z, (exists y:nat, z = y) -> True) -> True.
+evar nat.
+intros x H.
+apply (H n).
+unfold n. clear n.
+eexists.
+reflexivity.
+Grab Existential Variables.
+admit.
+
+(* Alternative variant which failed but without raising anomaly *)
+
+Goal forall x : nat, True.
+evar nat.
+intro x.
+evar nat.
+assert (H := eq_refl : n0 = n).
+clearbody n n0.
+exact I.
+Grab Existential Variables.
+admit.
diff --git a/test-suite/bugs/closed/2981.v b/test-suite/bugs/closed/2981.v
new file mode 100644
index 00000000..1facd9b7
--- /dev/null
+++ b/test-suite/bugs/closed/2981.v
@@ -0,0 +1,15 @@
+Check let TTT := Type in (fun (a b : @sigT TTT (fun A : TTT => A))
+             (f : @projT1 TTT (fun A : TTT => A) a ->
+                  @projT1 TTT (fun A : TTT => A) b) =>
+           @eq_refl
+             (@projT1 TTT (fun A : TTT => A) a ->
+              @projT1 TTT (fun A : TTT => A) b)
+             (fun x : @projT1 TTT (fun A : TTT => A) a => f x)) :
+           forall (a b : @sigT TTT (fun A : TTT => A))
+             (f : @projT1 TTT (fun A : TTT => A) a ->
+                  @projT1 TTT (fun A : TTT => A) b),
+           @eq
+             (@projT1 TTT (fun A : TTT => A) a ->
+              @projT1 TTT (fun A : TTT => A) b)
+             (fun x : @projT1 TTT (fun A : TTT => A) a => f x) f.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2983.v b/test-suite/bugs/closed/2983.v
index 15598352..15598352 100644
--- a/test-suite/bugs/closed/shouldsucceed/2983.v
+++ b/test-suite/bugs/closed/2983.v
diff --git a/test-suite/bugs/closed/2990.v b/test-suite/bugs/closed/2990.v
new file mode 100644
index 00000000..5f832626
--- /dev/null
+++ b/test-suite/bugs/closed/2990.v
@@ -0,0 +1,8 @@
+Goal True.
+Proof.
+  evar (pfT : Type).
+  cut pfT.
+  subst pfT.
+  intro pf.
+  refine ((fun A : Set => pf A) unit).
+Abort.
diff --git a/test-suite/bugs/closed/2994.v b/test-suite/bugs/closed/2994.v
new file mode 100644
index 00000000..457b1893
--- /dev/null
+++ b/test-suite/bugs/closed/2994.v
@@ -0,0 +1,2 @@
+(* Was an anomaly at some time *)
+Fail Class foo : Prop := { bar :> Set }.
diff --git a/test-suite/bugs/closed/shouldsucceed/2995.v b/test-suite/bugs/closed/2995.v
index ba3acd08..ba3acd08 100644
--- a/test-suite/bugs/closed/shouldsucceed/2995.v
+++ b/test-suite/bugs/closed/2995.v
diff --git a/test-suite/bugs/closed/2996.v b/test-suite/bugs/closed/2996.v
new file mode 100644
index 00000000..440cda61
--- /dev/null
+++ b/test-suite/bugs/closed/2996.v
@@ -0,0 +1,30 @@
+(* Test on definitions referring to section variables that are not any
+   longer in the current context *)
+
+Section x.
+
+  Hypothesis h : forall(n : nat), n < S n.
+
+  Definition f(n m : nat)(less : n < m) : nat := n + m.
+
+  Lemma a : forall(n : nat), f n (S n) (h n) = 1 + 2 * n.
+  Proof.
+    (* XXX *) admit.
+  Qed.
+
+  Lemma b : forall(n : nat), n < 3 + n.
+  Proof.
+    clear.
+    intros n.
+    Fail assert (H := a n).
+  Abort.
+
+  Let T := True.
+  Definition p := I : T.
+
+  Lemma paradox : False.
+  Proof.
+    clear.
+    set (T := False).
+    Fail pose proof p as H.
+  Abort.
diff --git a/test-suite/bugs/closed/shouldsucceed/3000.v b/test-suite/bugs/closed/3000.v
index 27de34ed..27de34ed 100644
--- a/test-suite/bugs/closed/shouldsucceed/3000.v
+++ b/test-suite/bugs/closed/3000.v
diff --git a/test-suite/bugs/closed/3001.v b/test-suite/bugs/closed/3001.v
new file mode 100644
index 00000000..6e565554
--- /dev/null
+++ b/test-suite/bugs/closed/3001.v
@@ -0,0 +1,21 @@
+Definition my_fun (n:nat) := n.
+
+Section My_Sec.
+  Global Arguments my_fun x : rename.
+End My_Sec.
+
+(* The following code suffices to trigger it, on my system:
+
+    Definition my_fun (n:nat) := n.
+
+    Section My_Sec.
+    Global Arguments my_fun x : rename.
+    End My_Sec.
+
+The `Global Arguments` declaration succeeds fine, but the `End My_Sec` fails, with `Anomaly: dirpath_prefix: empty dirpath. Please report.`
+
+If `Global` is removed, or if no arguments are renamed, then everything works as expected.
+
+If other declarations go between the `Global Arguments` and the `End My_Sec`, then the other declarations work normally, but the `End My_Sec` still fails.
+
+Previously reported at https://github.com/HoTT/coq/issues/24 .  Occurs in both 8.4 and current trunk. *)
diff --git a/test-suite/bugs/closed/shouldsucceed/3004.v b/test-suite/bugs/closed/3004.v
index 896b1958..896b1958 100644
--- a/test-suite/bugs/closed/shouldsucceed/3004.v
+++ b/test-suite/bugs/closed/3004.v
diff --git a/test-suite/bugs/closed/shouldsucceed/3008.v b/test-suite/bugs/closed/3008.v
index 3f3a979a..3f3a979a 100644
--- a/test-suite/bugs/closed/shouldsucceed/3008.v
+++ b/test-suite/bugs/closed/3008.v
diff --git a/test-suite/bugs/closed/3010b.v b/test-suite/bugs/closed/3010b.v
new file mode 100644
index 00000000..65fea424
--- /dev/null
+++ b/test-suite/bugs/closed/3010b.v
@@ -0,0 +1,5 @@
+Definition wtf (n : nat) : nat :=
+  (match n with
+       0 => (fun H : n = 0 => 0)
+     | S n' => (fun H : n = S n' => 0)
+   end) (eq_refl n).
diff --git a/test-suite/bugs/closed/3016.v b/test-suite/bugs/closed/3016.v
new file mode 100644
index 00000000..bd4f1dd8
--- /dev/null
+++ b/test-suite/bugs/closed/3016.v
@@ -0,0 +1,4 @@
+Section foo.
+  Variable C : Type.
+  Goal True.
+    change (eq (A := ?C) ?x ?y) with (eq).
diff --git a/test-suite/bugs/closed/3017.v b/test-suite/bugs/closed/3017.v
new file mode 100644
index 00000000..63a06bd3
--- /dev/null
+++ b/test-suite/bugs/closed/3017.v
@@ -0,0 +1,6 @@
+Class A := {}.
+  Class B {T} `(A) := { B_intro : forall t t' : T, t = t' }.
+  Lemma foo T (t t' : T) : t = t'.
+    erewrite @B_intro.
+    reflexivity.
+  Abort.
diff --git a/test-suite/bugs/closed/3022.v b/test-suite/bugs/closed/3022.v
new file mode 100644
index 00000000..dcfe7339
--- /dev/null
+++ b/test-suite/bugs/closed/3022.v
@@ -0,0 +1,8 @@
+Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x)
+     (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0),
+   match eq_sym e in (_ = y) return (T (f y) (f x)) with
+   | eq_refl => m (f x)
+   end = m (f x).
+intros.
+try case e.
+Abort.
diff --git a/test-suite/bugs/closed/3023.v b/test-suite/bugs/closed/3023.v
index ed489511..70a1491e 100644
--- a/test-suite/bugs/closed/3023.v
+++ b/test-suite/bugs/closed/3023.v
@@ -1,5 +1,3 @@
-(* Checking use of eta on Flexible/Rigid and SemiFlexible/Rigid unif problems *)
-
 Set Implicit Arguments.
 Generalizable All Variables.
 
@@ -14,6 +12,7 @@ Record Category {obj : Type} :=
 
 
 Section DiscreteAdjoints.
+
   Let C := {|
             Morphism := (fun X Y : Type => X -> Y);
             Identity := (fun X : Type => (fun x : X => x));
@@ -28,4 +27,7 @@ Section DiscreteAdjoints.
     revert ObjectFunctor.
     intro ObjectFunctor.
     simpl in ObjectFunctor.
-    revert ObjectFunctor. (* Used to failed in 8.4 up to 16 April 2013 *)
+    revert ObjectFunctor.
+  Abort.
+
+End DiscreteAdjoints.
diff --git a/test-suite/bugs/closed/3036.v b/test-suite/bugs/closed/3036.v
new file mode 100644
index 00000000..451bec9b
--- /dev/null
+++ b/test-suite/bugs/closed/3036.v
@@ -0,0 +1,169 @@
+(* Checking use of retyping in w_unify0 in the presence of unification
+problems of the form \x:Meta.Meta = \x:ind.match x with ... end *)
+
+Require Import List.
+Require Import QArith.
+Require Import Qcanon.
+
+Set Implicit Arguments.
+
+Inductive dynamic : Type :=
+  | Dyn : forall T, T -> dynamic.
+
+Definition perm := Qc.
+
+Locate Qle_bool.
+
+Definition compatibleb (p1 p2 : perm) : bool :=
+let p1pos := Qle_bool 00 p1 in
+  let p2pos := Qle_bool 00 p2 in
+    negb (
+         (p1pos && p2pos)
+      || ((p1pos || p2pos) && (negb (Qle_bool 00 ((p1 + p2)%Qc)))))%Qc.
+
+Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true.
+
+Definition perm_plus (p1 p2 : perm) : option perm :=
+  if compatibleb p1 p2 then Some (p1 + p2) else None.
+
+Infix "+p" := perm_plus (at level 60, no associativity).
+
+Axiom axiom_ptr : Set.
+
+Definition ptr := axiom_ptr.
+
+Axiom axiom_ptr_eq_dec : forall (a b : ptr), {a = b} + {a <> b}.
+
+Definition ptr_eq_dec := axiom_ptr_eq_dec.
+
+Definition hval := (dynamic * perm)%type.
+
+Definition heap := ptr -> option hval.
+
+Bind Scope heap_scope with heap.
+Delimit Scope heap_scope with heap.
+Local Open Scope heap_scope.
+
+Definition read (h : heap) (p : ptr) : option hval := h p.
+
+Notation "a # b" := (read a b) (at level 55, no associativity) : heap_scope.
+
+Definition val (v:hval) := fst v.
+Definition frac (v:hval) := snd v.
+
+Definition hval_plus (v1 v2 : hval) : option hval :=
+  match (frac v1) +p (frac v2) with
+    | None => None
+    | Some v1v2 => Some (val v1, v1v2)
+  end.
+
+Definition hvalo_plus (v1 v2 : option hval) :=
+  match v1 with
+    | None => v2
+    | Some v1' =>
+      match v2 with
+        | None => v1
+        | Some v2' => (hval_plus v1' v2')
+      end
+  end.
+
+Notation "v1 +o v2" := (hvalo_plus v1 v2) (at level 60, no associativity) : heap_scope.
+
+Definition join (h1 h2 : heap) : heap :=
+  (fun p => (h1 p) +o (h2 p)).
+
+Infix "*" := join (at level 40, left associativity) : heap_scope.
+
+Definition hprop := heap -> Prop.
+
+Bind Scope hprop_scope with hprop.
+Delimit Scope hprop_scope with hprop.
+
+Definition hprop_cell (p : ptr) T (v : T) (pi:Qc): hprop := fun h =>
+  h#p = Some (Dyn v, pi) /\ forall p', p' <> p -> h#p' = None.
+
+Notation "p ---> v" := (hprop_cell p v (0%Qc)) (at level 38, no associativity) : hprop_scope.
+
+Definition empty : heap := fun _ => None.
+
+Definition hprop_empty : hprop := eq empty.
+Notation "'emp'" := hprop_empty : hprop_scope.
+
+Definition hprop_inj (P : Prop) : hprop := fun h => h = empty /\ P.
+Notation "[ P ]" := (hprop_inj P) (at level 0, P at level 200) : hprop_scope.
+
+Definition hprop_imp (p1 p2 : hprop) : Prop := forall h, p1 h -> p2 h.
+Infix "==>" := hprop_imp (right associativity, at level 55).
+
+Definition hprop_ex T (p : T -> hprop) : hprop := fun h => exists v, p v h.
+Notation "'Exists' v :@ T , p" := (hprop_ex (fun v : T => p%hprop))
+  (at level 90, T at next level) : hprop_scope.
+
+Local Open Scope hprop_scope.
+Definition disjoint (h1 h2 : heap) : Prop :=
+  forall p,
+    match h1#p with
+      | None => True
+      | Some v1 => match h2#p with
+                     | None => True
+                     | Some v2 => val v1 = val v2
+                               /\ compatible (frac v1) (frac v2)
+                  end
+    end.
+
+Infix "<#>" := disjoint (at level 40, no associativity) : heap_scope.
+
+Definition split (h h1 h2 : heap) : Prop := h1 <#> h2 /\ h = h1 * h2.
+
+Notation "h ~> h1 * h2" := (split h h1 h2) (at level 40, h1 at next level, no associativity).
+
+Definition hprop_sep (p1 p2 : hprop) : hprop := fun h =>
+  exists h1, exists h2, h ~> h1 * h2
+    /\ p1 h1
+    /\ p2 h2.
+Infix "*" := hprop_sep (at level 40, left associativity) : hprop_scope.
+
+Section Stack.
+  Variable T : Set.
+
+  Record node : Set := Node {
+    data : T;
+    next : option ptr
+  }.
+
+  Fixpoint listRep (ls : list T) (hd : option ptr) {struct ls} : hprop :=
+    match ls with
+    | nil => [hd = None]
+    | h :: t =>
+      match hd with
+      | None => [False]
+      | Some hd' => Exists p :@ option ptr, hd' ---> Node h p * listRep t p
+      end
+    end%hprop.
+
+  Definition stack := ptr.
+
+  Definition rep q ls := (Exists po :@ option ptr, q ---> po * listRep ls po)%hprop.
+
+  Definition isExistential T (x : T) := True.
+
+  Theorem himp_ex_conc_trivial : forall T p p1 p2,
+    p ==> p1 * p2
+    -> T
+    -> p ==> hprop_ex (fun _ : T => p1) * p2.
+  Admitted.
+
+  Goal forall (s : ptr) (x : T) (nd : ptr) (v : unit) (x0 : list T) (v0 : option ptr)
+              (H0 : isExistential v0),
+  nd ---> {| data := x; next := v0 |} * (s ---> Some nd * listRep x0 v0) ==>
+  (Exists po :@ option ptr,
+    s ---> po *
+    match po with
+    | Some hd' =>
+        Exists p :@ option ptr,
+        hd' ---> {| data := x; next := p |} * listRep x0 p
+    | None => [False]
+    end) * emp.
+  Proof.
+    intros. 
+    try apply himp_ex_conc_trivial.
diff --git a/test-suite/bugs/closed/3037.v b/test-suite/bugs/closed/3037.v
new file mode 100644
index 00000000..baa7eff5
--- /dev/null
+++ b/test-suite/bugs/closed/3037.v
@@ -0,0 +1,11 @@
+(* Anomaly before 4a8950ec7a0d9f2b216e67e69b446c064590a8e9 *)
+
+Require Import Recdef.
+
+Function f_R (a: nat) {wf (fun x y: nat => False)  a}:Prop:=
+  match a:nat with
+    | 0 => True
+    | (S y') => f_R y'
+  end.
+(* Anomaly: File "plugins/funind/recdef.ml", line 916, characters 13-19: Assertion failed.
+Please report. *)
diff --git a/test-suite/bugs/closed/3043.v b/test-suite/bugs/closed/3043.v
new file mode 100644
index 00000000..654663b4
--- /dev/null
+++ b/test-suite/bugs/closed/3043.v
@@ -0,0 +1,4 @@
+Goal (fun A (P : A -> Prop) (X : sigT P) => proj1_sig (sig_of_sigT X)) =
+     (fun A (P : A -> Prop) (X : sigT P) => projT1 X).
+  reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/3045.v b/test-suite/bugs/closed/3045.v
new file mode 100644
index 00000000..ef110ad0
--- /dev/null
+++ b/test-suite/bugs/closed/3045.v
@@ -0,0 +1,34 @@
+
+Set Asymmetric Patterns.
+Generalizable All Variables.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type;
+
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+  }.
+
+Arguments Compose {obj} [C s d d'] m1 m2 : rename.
+
+Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type :=
+| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'.
+
+Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d :=
+  match m in @ReifiedMorphism objC C s d return Morphism C s d with
+    | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1)
+                                                         (@ReifiedMorphismDenote _ _ _ _ m2)
+  end.
+
+Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d)
+: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }.
+refine match m with
+         | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _
+       end; clear m.
+(* This fails with an error rather than an anomaly, but morally 
+   it should work, if destruct were able to do the good generalization
+   in advance, before doing the "intros []". *)
+Fail destruct (@ReifiedMorphismSimplifyWithProof T s1 d0 d0' m1) as [ [] ? ].
diff --git a/test-suite/bugs/closed/3050.v b/test-suite/bugs/closed/3050.v
new file mode 100644
index 00000000..4b187224
--- /dev/null
+++ b/test-suite/bugs/closed/3050.v
@@ -0,0 +1,7 @@
+Goal forall A B, A * B -> A.
+Proof.
+intros A B H.
+match goal with
+  | [ H : _ * _ |- _ ] => exact (fst H)
+end.
+Qed.
diff --git a/test-suite/bugs/closed/3054.v b/test-suite/bugs/closed/3054.v
new file mode 100644
index 00000000..936e58e1
--- /dev/null
+++ b/test-suite/bugs/closed/3054.v
@@ -0,0 +1,10 @@
+Section S.
+
+Let V := Type.
+
+Goal ~ true = false.
+Proof.
+congruence.
+Qed.
+
+End S.
diff --git a/test-suite/bugs/closed/3062.v b/test-suite/bugs/closed/3062.v
new file mode 100644
index 00000000..a7b5fab0
--- /dev/null
+++ b/test-suite/bugs/closed/3062.v
@@ -0,0 +1,5 @@
+Lemma foo : forall x y:nat, x < y -> False.
+Proof.
+  intros x y H.
+  induction H as [ |?y ?y ?y].
+Abort.
diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v
new file mode 100644
index 00000000..03e5af61
--- /dev/null
+++ b/test-suite/bugs/closed/3068.v
@@ -0,0 +1,63 @@
+Section Counted_list.
+
+  Variable A : Type.
+
+  Inductive counted_list : nat -> Type :=
+    | counted_nil : counted_list 0
+    | counted_cons : forall(n : nat), 
+        A -> counted_list n -> counted_list (S n).
+
+
+  Fixpoint counted_def_nth{n : nat}(l : counted_list n)
+                          (i : nat)(def : A) : A :=
+    match i with
+      | 0 => match l with
+               | counted_nil => def
+               | counted_cons _ a _ => a
+             end
+      | S i => match l with
+                 | counted_nil => def
+                 | counted_cons _ _ tl => counted_def_nth tl i def
+               end
+    end.
+
+
+  Lemma counted_list_equal_nth_char : 
+    forall(n : nat)(l1 l2 : counted_list n)(def : A),
+      (forall(i : nat), counted_def_nth l1 i def = counted_def_nth l2 i def) ->
+        l1 = l2.
+  Proof.
+    admit.
+  Qed.
+
+End Counted_list.
+
+Implicit Arguments counted_def_nth [A n].
+
+Section Finite_nat_set.
+
+  Variable set_size : nat.
+
+  Definition fnat_subset : Type := counted_list bool set_size.
+
+  Definition fnat_member(fs : fnat_subset)(n : nat) : Prop := 
+    is_true (counted_def_nth fs n false).
+
+
+  Lemma fnat_subset_member_eq : forall(fs1 fs2 : fnat_subset),
+    fs1 = fs2 <->
+      forall(n : nat), fnat_member fs1 n <-> fnat_member fs2 n.
+
+  Proof.
+    intros fs1 fs2.
+    split.
+      intros H n.
+      subst fs1.
+      apply iff_refl.
+    intros H.
+    eapply counted_list_equal_nth_char.
+    intros i.
+    destruct (counted_def_nth fs1 i _ ) eqn:H0.
+    (* This was not part of the initial bug report; this is to check that
+       the existential variable kept its name *)
+    change (true = counted_def_nth fs2 i ?def).
diff --git a/test-suite/bugs/closed/3088.v b/test-suite/bugs/closed/3088.v
new file mode 100644
index 00000000..3c362510
--- /dev/null
+++ b/test-suite/bugs/closed/3088.v
@@ -0,0 +1,12 @@
+Inductive R {A} : A -> A -> Type := c : forall x y, R x y.
+
+Goal forall A (x y : A) P (e : R x y) (f : forall x y, P x y (c x y)),
+  let g := match e in R x y return P x y e with c x y => f x y end in
+  True.
+Proof.
+intros A x y P e f g.
+let t := eval red in g in
+match t with
+  (match ?E as e in R x y return @?P x y e with c X Y => @?f X Y end) => idtac P f
+end.
+Abort.
diff --git a/test-suite/bugs/closed/3093.v b/test-suite/bugs/closed/3093.v
new file mode 100644
index 00000000..f6b4a03f
--- /dev/null
+++ b/test-suite/bugs/closed/3093.v
@@ -0,0 +1,6 @@
+Require Import FunctionalExtensionality.
+
+Goal forall y, @f_equal = y.
+  intro.
+  apply functional_extensionality_dep.
+Abort.
diff --git a/test-suite/bugs/closed/3142.v b/test-suite/bugs/closed/3142.v
new file mode 100644
index 00000000..988074e2
--- /dev/null
+++ b/test-suite/bugs/closed/3142.v
@@ -0,0 +1,9 @@
+(* Fixed together with #3262 in 48af6d1418282323b9fff0e789fed9478c064434 *)
+(* April 4, 2014 (non-progress in candidates was not detected) *)
+
+Definition eqbool_dep (P : bool -> Prop) (h1 : P true) (b : bool) (h2 : P b)
+  : Prop :=
+(match b (* return P b -> Prop *) with
+ | true => fun (h : P true) => h1 = h
+ | false => fun (_ : P false) => False
+end (* : P b -> Prop *)) h2.
diff --git a/test-suite/bugs/closed/3164.v b/test-suite/bugs/closed/3164.v
new file mode 100644
index 00000000..3c9af8d0
--- /dev/null
+++ b/test-suite/bugs/closed/3164.v
@@ -0,0 +1,49 @@
+(* Before 31a69c4d0fd7b8325187e8da697a9c283594047d, [case] would stack overflow *)
+Require Import Arith.
+
+Section Acc_generator.
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
+
+  (* *Lazily* add 2^n - 1 Acc_intro on top of wf.
+     Needed for fast reductions using Function and Program Fixpoint
+     and probably using Fix and Fix_F_2
+   *)
+  Fixpoint Acc_intro_generator n (wf : well_founded R)  :=
+    match n with
+        | O => wf
+        | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y)
+    end.
+
+
+End Acc_generator.
+
+Definition pred_F : (forall x : nat,
+        (forall y : nat, y < x -> (fun _ : nat => nat) y) ->
+        (fun _ : nat => nat) x).
+Proof.
+  intros x.
+  simpl.
+  case x.
+  exact (fun _ => 0).
+  intros n h.
+  apply (h n).
+  constructor.
+Defined.
+
+Definition my_pred :=  Fix lt_wf (fun _ => nat) pred_F.
+
+
+Lemma my_pred_is_pred : forall x, match my_pred x with | 0 => True | S n => False end.
+Proof.
+  intros x.
+  case x.
+Abort.
+
+Definition my_pred_bad :=  Fix (Acc_intro_generator _ _ 100 lt_wf) (fun _ => nat) pred_F.
+
+Lemma my_pred_is_pred : forall x, match my_pred_bad x with | 0 => True | S n => False end.
+Proof.
+  intros x.
+  Timeout 2 case x.
+Admitted.
diff --git a/test-suite/bugs/closed/3188.v b/test-suite/bugs/closed/3188.v
new file mode 100644
index 00000000..01176026
--- /dev/null
+++ b/test-suite/bugs/closed/3188.v
@@ -0,0 +1,22 @@
+(* File reduced by coq-bug-finder from 1656 lines to 221 lines to 26 lines to 7 lines. *)
+
+Module Long.
+  Require Import Coq.Classes.RelationClasses.
+
+  Hint Extern 0 => apply reflexivity : typeclass_instances.
+  Hint Extern 1 => symmetry.
+
+  Lemma foo : exists m' : Type, True.
+    intuition. (* Anomaly: Uncaught exception Not_found. Please report. *)
+  Abort.
+End Long.
+
+Module Short.
+  Require Import Coq.Classes.RelationClasses.
+
+  Hint Extern 0 => apply reflexivity : typeclass_instances.
+
+  Lemma foo : exists m' : Type, True.
+    try symmetry. (* Anomaly: Uncaught exception Not_found. Please report. *)
+  Abort.
+End Short.
diff --git a/test-suite/bugs/closed/3205.v b/test-suite/bugs/closed/3205.v
new file mode 100644
index 00000000..5c44f070
--- /dev/null
+++ b/test-suite/bugs/closed/3205.v
@@ -0,0 +1,26 @@
+Fail Fixpoint F (u : unit) : Prop :=
+  (fun p : {P : Prop & _} => match p with existT _ _ P => P end)
+  (existT (fun P => False -> P) (F tt) _).
+(* Anomaly: A universe comparison can only happen between variables.
+Please report. *)
+
+
+
+Definition g (x : Prop) := x.
+
+Definition h (y : Type) := y.
+
+Definition eq_hf : h = g :> (Prop -> Type) :=
+  @eq_refl (Prop -> Type) g.
+
+Set Printing All.
+Set Printing Universes.
+Fail Definition eq_hf : h = g :> (Prop -> Type) :=
+  eq_refl g.
+(* Originally an anomaly, now says
+Toplevel input, characters 48-57:
+Error:
+The term "@eq_refl (forall _ : Prop, Prop) g" has type
+ "@eq (forall _ : Prop, Prop) g g" while it is expected to have type
+ "@eq (forall _ : Prop, Type (* Top.16 *)) (fun y : Prop => h y) g"
+(Universe inconsistency: Cannot enforce Prop = Top.16)). *)
diff --git a/test-suite/bugs/closed/3212.v b/test-suite/bugs/closed/3212.v
new file mode 100644
index 00000000..53d8dfe3
--- /dev/null
+++ b/test-suite/bugs/closed/3212.v
@@ -0,0 +1,10 @@
+Lemma H : Prop = Prop.
+reflexivity.
+Qed.
+
+Lemma foo : match H in (_ = X) return X with
+  | eq_refl => True
+end.
+Proof.
+Fail destruct H.
+Abort.
diff --git a/test-suite/bugs/closed/3217.v b/test-suite/bugs/closed/3217.v
new file mode 100644
index 00000000..ec846bf9
--- /dev/null
+++ b/test-suite/bugs/closed/3217.v
@@ -0,0 +1,36 @@
+(** [Set Implicit Arguments] causes Coq to run out of memory on [Qed] before c3feef4ed5dec126f1144dec91eee9c0f0522a94 *)
+Set Implicit Arguments.
+
+Variable LEM: forall P : Prop, sumbool P (P -> False).
+
+Definition pmap := option (nat -> option nat).
+
+Definition pmplus (oha ohb: pmap) : pmap :=
+ match oha, ohb with
+ | Some ha, Some hb =>
+   if LEM (oha = ohb) then None else None
+ | _, _ => None
+ end.
+
+Definition pmemp: pmap := Some (fun _ => None).
+
+Lemma foo:
+ True ->
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+    (pmplus pmemp
+     pmemp))))))))))))
+    =
+    None -> True.
+Proof.
+  auto.
+Timeout 2 Qed.
diff --git a/test-suite/bugs/closed/3228.v b/test-suite/bugs/closed/3228.v
new file mode 100644
index 00000000..5d1a0ff8
--- /dev/null
+++ b/test-suite/bugs/closed/3228.v
@@ -0,0 +1,7 @@
+(* Check that variables in the context do not take precedence over
+   ltac variables *)
+
+Ltac bar x := exact x.
+Goal False -> False.
+  intro x.
+  Fail bar doesnotexist.
diff --git a/test-suite/bugs/closed/3242.v b/test-suite/bugs/closed/3242.v
new file mode 100644
index 00000000..805baee1
--- /dev/null
+++ b/test-suite/bugs/closed/3242.v
@@ -0,0 +1,2 @@
+Inductive Foo (x := Type) := C : Foo -> Foo.
+
diff --git a/test-suite/bugs/closed/3251.v b/test-suite/bugs/closed/3251.v
new file mode 100644
index 00000000..5a7ae200
--- /dev/null
+++ b/test-suite/bugs/closed/3251.v
@@ -0,0 +1,13 @@
+Goal True.
+Ltac foo := idtac.
+(* print out happens twice:
+foo is defined
+foo is defined
+
+... that's fishy.  But E. Tassi tells me that it's expected since "Ltac" generates a side
+effect that escapes the proof.  In the STM model this means the command is executed twice,
+once in the proof branch, and another time in the main branch *)
+Undo.
+Ltac foo := idtac.
+(* Before 5b39c3535f7b3383d89d7b844537244a4e7c0eca, this would print out: *)
+(* Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *)
diff --git a/test-suite/bugs/closed/3258.v b/test-suite/bugs/closed/3258.v
new file mode 100644
index 00000000..a1390e30
--- /dev/null
+++ b/test-suite/bugs/closed/3258.v
@@ -0,0 +1,35 @@
+Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid.
+
+Global Set Implicit Arguments.
+
+Hint Extern 0 => apply reflexivity : typeclass_instances.
+
+Inductive Comp : Type -> Type :=
+| Pick : forall A, (A -> Prop) -> Comp A.
+
+Axiom computes_to : forall A, Comp A -> A -> Prop.
+
+Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.
+
+Global Instance refine_PreOrder A : PreOrder (@refine A).
+Admitted.
+Add Parametric Morphism A
+: (@Pick A)
+    with signature
+    (pointwise_relation _ (flip impl))
+      ==> (@refine A)
+      as refine_flip_impl_Pick.
+  admit.
+Defined.
+Definition remove_forall_eq' A x B (P : A -> B -> Prop) : pointwise_relation _ impl (P x) (fun z => forall y : A, y = x -> P y z).
+  admit.
+Defined.
+Goal forall A B (x : A) (P : _ -> _ -> Prop),
+       refine (Pick (fun n : B => forall y, y = x -> P y n))
+              (Pick (fun n : B => P x n)).
+Proof.
+  intros.
+  setoid_rewrite (@remove_forall_eq' _ _ _ _).
+  Undo.
+  (* This failed with NotConvertible at some time *)
+  setoid_rewrite (@remove_forall_eq' _ _ _).
diff --git a/test-suite/bugs/closed/3259.v b/test-suite/bugs/closed/3259.v
new file mode 100644
index 00000000..0306c686
--- /dev/null
+++ b/test-suite/bugs/closed/3259.v
@@ -0,0 +1,21 @@
+Goal forall m n, n+n = m+m -> m+m = m+m.
+Proof.
+intros.
+set (k := n+n) in *.
+cut (n=m).
+intro.
+subst n.
+admit.
+admit.
+Qed.
+
+Goal forall m n, n+n = m+m -> n+n = m+m.
+Proof.
+intros.
+set (k := n+n).
+cut (n=m).
+intro.
+subst n.
+admit.
+admit.
+Qed.
diff --git a/test-suite/bugs/closed/3260.v b/test-suite/bugs/closed/3260.v
new file mode 100644
index 00000000..9f0231d9
--- /dev/null
+++ b/test-suite/bugs/closed/3260.v
@@ -0,0 +1,7 @@
+Require Import Setoid.
+Goal forall m n, n = m -> n+n = m+m.
+intros.
+replace n with m at 2.
+lazymatch goal with
+|- n + m = m + m => idtac
+end.
diff --git a/test-suite/bugs/closed/3262.v b/test-suite/bugs/closed/3262.v
new file mode 100644
index 00000000..70bfde29
--- /dev/null
+++ b/test-suite/bugs/closed/3262.v
@@ -0,0 +1,78 @@
+(* Not having a [return] clause causes the [refine] at the bottom to stack overflow before f65fa9de8a4c9c12d933188a755b51508bd51921 *)
+
+Require Import Coq.Lists.List.
+Require Import Relations RelationClasses.
+
+Set Implicit Arguments.
+Set Strict Implicit.
+Set Asymmetric Patterns.
+
+Section hlist.
+  Context {iT : Type}.
+  Variable F : iT -> Type.
+
+  Inductive hlist : list iT -> Type :=
+  | Hnil  : hlist nil
+  | Hcons : forall l ls, F l -> hlist ls -> hlist (l :: ls).
+
+  Definition hlist_hd {a b} (hl : hlist (a :: b)) : F a :=
+    match hl in hlist x return match x with
+                                 | nil => unit
+                                 | l :: _ => F l
+                               end with
+      | Hnil => tt
+      | Hcons _ _ x _ => x
+    end.
+
+  Definition hlist_tl {a b} (hl : hlist (a :: b)) : hlist b :=
+    match hl in hlist x return match x with
+                                 | nil => unit
+                                 | _ :: ls => hlist ls
+                               end with
+      | Hnil => tt
+      | Hcons _ _ _ x => x
+    end.
+
+  Lemma hlist_eta : forall ls (h : hlist ls),
+    h = match ls as ls return hlist ls -> hlist ls with
+          | nil => fun _ => Hnil
+          | a :: b => fun h => Hcons (hlist_hd h) (hlist_tl h)
+        end h.
+  Proof.
+    intros. destruct h; auto.
+  Qed.
+
+  Variable eqv : forall x, relation (F x).
+
+  Inductive equiv_hlist : forall ls, hlist ls -> hlist ls -> Prop :=
+  | hlist_eqv_nil : equiv_hlist Hnil Hnil
+  | hlist_eqv_cons : forall l ls x y h1 h2, eqv x y -> equiv_hlist h1 h2 ->
+                                            @equiv_hlist (l :: ls) (Hcons x h1) (Hcons y h2).
+
+  Global Instance Reflexive_equiv_hlist (R : forall t, Reflexive (@eqv t)) ls
+  : Reflexive (@equiv_hlist ls).
+  Proof.
+    red. induction x; constructor; auto. reflexivity.
+  Qed.
+
+  Global Instance Transitive_equiv_hlist (R : forall t, Transitive (@eqv t)) ls
+  : Transitive (@equiv_hlist ls).
+  Proof.
+    red. induction 1.
+    { intro; assumption. }
+    { rewrite (hlist_eta z).
+      Timeout 2 Fail refine
+        (fun H =>
+           match H in @equiv_hlist ls X Y
+                 return
+                 (* Uncommenting the following gives an immediate error in 8.4pl3; commented out results in a stack overflow *)
+                 match ls (*as ls return hlist ls -> hlist ls -> Type*) with
+                   | nil => fun _ _ : hlist nil => True
+                   | l :: ls => fun (X Y : hlist (l :: ls)) =>
+                                  equiv_hlist (Hcons x h1) Y
+                 end X Y
+           with
+             | hlist_eqv_nil => I
+             | hlist_eqv_cons l ls x y h1 h2 pf pf' =>
+               _
+           end).
diff --git a/test-suite/bugs/closed/3264.v b/test-suite/bugs/closed/3264.v
new file mode 100644
index 00000000..4eb21890
--- /dev/null
+++ b/test-suite/bugs/closed/3264.v
@@ -0,0 +1,45 @@
+Module File1.
+  Module Export DirA.
+    Module A.
+      Inductive paths {A : Type} (a : A) : A -> Type :=
+        idpath : paths a a.
+
+      Arguments idpath {A a} , [A] a.
+
+      Notation "x = y :> A" := (@paths A x y) : type_scope.
+      Notation "x = y" := (x = y :>_) : type_scope.
+    End A.
+  End DirA.
+End File1.
+
+Module File2.
+  Module Export DirA.
+    Module B.
+      Import File1.
+      Export A.
+      Lemma foo : forall x y : Type, x = y -> y = x.
+      Proof.
+        intros x y H.
+        rewrite <- H.
+        constructor.
+      Qed.
+    End B.
+  End DirA.
+End File2.
+
+Module File3.
+  Module Export DirA.
+    Module C.
+      Import File1.
+      Export A.
+      Lemma bar : forall x y : Type, x = y -> y = x.
+      Proof.
+        intros x y H.
+        rewrite <- H.
+        constructor.
+      Defined.
+      Definition bar'
+        := Eval cbv beta iota zeta delta [bar internal_paths_rew] in bar.
+    End C.
+  End DirA.
+End File3.
diff --git a/test-suite/bugs/closed/3265.v b/test-suite/bugs/closed/3265.v
new file mode 100644
index 00000000..269c7b74
--- /dev/null
+++ b/test-suite/bugs/closed/3265.v
@@ -0,0 +1,6 @@
+Require Import Setoid.
+Hint Extern 0 => apply reflexivity : typeclass_instances.
+Goal forall (B : Type) (P : B -> Prop), exists y : B, P y.
+  intros.
+  try reflexivity. (* Anomaly: Uncaught exception Not_found. Please report. *)
+Abort.
diff --git a/test-suite/bugs/closed/3266.v b/test-suite/bugs/closed/3266.v
new file mode 100644
index 00000000..fd4cbff8
--- /dev/null
+++ b/test-suite/bugs/closed/3266.v
@@ -0,0 +1,3 @@
+Class A := a : nat.
+Lemma p : True.
+Proof. cut A; [tauto | exact 1]. Qed.
diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v
new file mode 100644
index 00000000..5ce1ddf0
--- /dev/null
+++ b/test-suite/bugs/closed/3267.v
@@ -0,0 +1,36 @@
+Module a.
+  Local Hint Extern 0 => progress subst.
+  Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y.
+  Proof.
+    intros.
+    (* this should not fail *)
+    progress eauto.
+  Defined.
+End a.
+
+Module b.
+  Local Hint Extern 0 => progress subst.
+  Goal forall T (x y : T) (P Q : _ -> Prop), y = x -> (P x -> Q x) -> P y -> Q y.
+  Proof.
+    intros.
+    eauto.
+  Defined.
+End b.
+
+Module c.
+  Local Hint Extern 0 => progress subst; eauto.
+  Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y.
+  Proof.
+    intros.
+    eauto.
+  Defined.
+End c.
+
+Module d.
+  Local Hint Extern 0 => progress subst; repeat match goal with H : _ |- _ => revert H end.
+  Goal forall T (x y : T) (P Q : _ -> Prop), x = y -> (P x -> Q x) -> P y -> Q y.
+  Proof.
+    intros.
+    debug eauto.
+  Defined.
+End d.
diff --git a/test-suite/bugs/closed/328.v b/test-suite/bugs/closed/328.v
new file mode 100644
index 00000000..52cfbbc4
--- /dev/null
+++ b/test-suite/bugs/closed/328.v
@@ -0,0 +1,40 @@
+Module Type TITI.
+Parameter B:Set.
+Parameter x:B.
+Inductive A:Set:=
+a1:B->A.
+Definition f2: A ->B
+:= fun (a:A) =>
+match a with
+ (a1 b)=>b
+end.
+Definition f: A -> B:=fun (a:A) => x.
+End TITI.
+
+
+Module Type TIT.
+Declare Module t:TITI.
+End TIT.
+
+Module Seq(titi:TIT).
+Module t:=titi.t.
+Inductive toto:t.A->t.B->Set:=
+t1:forall (a:t.A), (toto a (t.f a))
+| t2:forall (a:t.A), (toto a (t.f2 a)).
+End Seq.
+
+Module koko(tit:TIT).
+Module seq:=Seq tit.
+Module t':=tit.t.
+
+Definition def:forall (a:t'.A), (seq.toto a (t'.f a)).
+intro ; constructor 1.
+Defined.
+
+Definition def2: forall (a:t'.A), (seq.toto a (t'.f2 a)).
+intro; constructor 2.
+(*  Toplevel input, characters 0-13
+  constructor 2.
+  ^^^^^^^^^^^^^
+Error: Impossible to unify (seq.toto ?3 (seq.t.f2 ?3)) with
+ (seq.toto a (t'.f2 a)).*)
diff --git a/test-suite/bugs/closed/3281.v b/test-suite/bugs/closed/3281.v
new file mode 100644
index 00000000..d340f0ca
--- /dev/null
+++ b/test-suite/bugs/closed/3281.v
@@ -0,0 +1,5 @@
+Fail Lemma foo : @eq _ nat Type.
+Fail Lemma foo : @eq Set nat Type.
+
+Lemma foo : @eq Type nat Type. Admitted.
+Lemma foo' : @eq _ Type nat. Admitted.
diff --git a/test-suite/bugs/closed/3282.v b/test-suite/bugs/closed/3282.v
new file mode 100644
index 00000000..ce7cab1c
--- /dev/null
+++ b/test-suite/bugs/closed/3282.v
@@ -0,0 +1,7 @@
+(* Check let-ins in fix and Fixpoint *)
+
+Definition foo := fix f (m : nat) (o := true) (n : nat) {struct n} :=
+  match n with 0 => 0 | S n' => f 0 n' end.
+
+Fixpoint f (m : nat) (o := true) (n : nat) {struct n} :=
+  match n with 0 => 0 | S n' => f 0 n' end.
diff --git a/test-suite/bugs/closed/3284.v b/test-suite/bugs/closed/3284.v
new file mode 100644
index 00000000..34cd09c6
--- /dev/null
+++ b/test-suite/bugs/closed/3284.v
@@ -0,0 +1,23 @@
+(* Several bugs:
+- wrong env in pose_all_metas_as_evars leading to out of scope instance of evar
+- check that metas posed as evars in pose_all_metas_as_evars were
+  resolved was not done
+*)
+
+Axiom functional_extensionality_dep :
+  forall {A : Type} {B : A -> Type} (f g : forall x : A, B x),
+    (forall x : A, f x = g x) -> f = g.
+
+Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True.
+Proof.
+  intros A B C f g x H.
+  Fail apply @functional_extensionality_dep in H.
+  Fail apply functional_extensionality_dep in H.
+  eapply functional_extensionality_dep in H.
+Abort.
+
+Goal forall A B C (f g : forall (x : A) (y : B x), C x y), forall x:A, (forall x y, f x y = g x y) -> True.
+Proof.
+  intros A B C f g x H.
+  specialize (H x).
+  apply functional_extensionality_dep in H.
diff --git a/test-suite/bugs/closed/3285.v b/test-suite/bugs/closed/3285.v
new file mode 100644
index 00000000..25162329
--- /dev/null
+++ b/test-suite/bugs/closed/3285.v
@@ -0,0 +1,7 @@
+Goal True.
+Proof.
+match goal with
+  | _ => let x := constr:($(fail)$) in idtac
+  | _ => idtac
+end.
+Abort.
diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v
new file mode 100644
index 00000000..b08b7ab3
--- /dev/null
+++ b/test-suite/bugs/closed/3286.v
@@ -0,0 +1,41 @@
+Require Import FunctionalExtensionality.
+
+Ltac make_apply_under_binders_in lem H :=
+  let tac := make_apply_under_binders_in in
+  match type of H with
+    | forall x : ?T, @?P x
+      => let ret := constr:(fun x' : T =>
+                              let Hx := H x' in
+                              $(let ret' := tac lem Hx in
+                                exact ret')$) in
+         match eval cbv zeta in ret with
+           | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in
+                                      constr:(Some P')
+         end
+    | _ => let ret := constr:($(match goal with
+                                  | _ => (let H' := fresh in
+                                          pose H as H';
+                                          apply lem in H';
+                                          exact (Some H'))
+                                  | _ => exact (@None nat)
+                                end
+                               )$) in
+           let ret' := (eval cbv beta zeta in ret) in
+           constr:(ret')
+    | _ => constr:(@None nat)
+  end.
+
+Ltac apply_under_binders_in lem H :=
+  let H' := make_apply_under_binders_in lem H in
+  let H'0 := match H' with Some ?H'0 => constr:(H'0) end in
+  let H'' := fresh in
+  pose proof H'0 as H'';
+    clear H;
+    rename H'' into H.
+
+Goal forall A B C (f g : forall (x : A) (y : B x), C x y), (forall x y, f x y = g x y) -> True.
+Proof.
+  intros A B C f g H.
+  let lem := constr:(@functional_extensionality_dep) in
+  apply_under_binders_in lem H.
+(* Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/3287.v b/test-suite/bugs/closed/3287.v
new file mode 100644
index 00000000..7c781312
--- /dev/null
+++ b/test-suite/bugs/closed/3287.v
@@ -0,0 +1,20 @@
+Module Foo.
+(* Definition foo := (I,I). *)
+Definition bar := true.
+End Foo.
+
+Recursive Extraction Foo.bar.
+
+Module Foo'.
+Definition foo := (I,I).
+Definition bar := true.
+End Foo'.
+
+Recursive Extraction Foo'.bar.
+
+Module Foo''.
+Definition foo := (I,I).
+Definition bar := true.
+End Foo''.
+
+Extraction Foo.bar.
diff --git a/test-suite/bugs/closed/3289.v b/test-suite/bugs/closed/3289.v
new file mode 100644
index 00000000..4542b015
--- /dev/null
+++ b/test-suite/bugs/closed/3289.v
@@ -0,0 +1,27 @@
+(* File reduced by coq-bug-finder from original input, then from 1829 lines to 37 lines, then from 47 lines to 18 lines *)
+
+Class Contr_internal (A : Type) :=
+  BuildContr { center : A ;
+               contr : (forall y : A, True) }.
+Class Contr A := Contr_is_contr : Contr_internal A.
+Inductive Unit : Set := tt.
+Instance contr_unit : Contr Unit | 0 :=
+  let x := {|
+        center := tt;
+        contr := fun t : Unit => I
+      |} in x. (* success *)
+
+Instance contr_internal_unit' : Contr_internal Unit | 0 :=
+  {|
+    center := tt;
+    contr := fun t : Unit => I
+  |}.
+
+Instance contr_unit' : Contr Unit | 0 :=
+  {|
+    center := tt;
+    contr := fun t : Unit => I
+  |}.
+(* Error: Mismatched contexts while declaring instance:
+ Expected: (Contr_is_contr : Contr_internal _UNBOUND_REL_1)
+ Found:   tt  (fun t : Unit => I) *)
diff --git a/test-suite/bugs/closed/329.v b/test-suite/bugs/closed/329.v
new file mode 100644
index 00000000..def6ed98
--- /dev/null
+++ b/test-suite/bugs/closed/329.v
@@ -0,0 +1,100 @@
+Module Sylvain_Boulme.
+Module Type Essai.
+Parameter T: Type.
+Parameter my_eq: T -> T -> Prop.
+Parameter my_eq_refl: forall (x:T), (my_eq x x).
+Parameter c: T.
+End Essai.
+
+Module Type Essai2.
+Declare Module M: Essai.
+Parameter c2: M.T.
+End Essai2.
+
+Module Type Essai3.
+Declare Module M: Essai.
+Parameter c3: M.T.
+End Essai3.
+
+Module Type Lift.
+Declare Module Core: Essai.
+Declare Module M: Essai.
+Parameter lift: Core.T -> M.T.
+Parameter lift_prop:forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c).
+End Lift.
+
+Module I2 (X:Essai) <: Essai2.
+ Module Core := X.
+ Module M<:Essai.
+  Definition T:Type :=Prop.
+  Definition my_eq:=(@eq Prop).
+  Definition c:=True.
+  Lemma my_eq_refl: forall (x:T), (my_eq x x).
+  Proof.
+    unfold my_eq; auto.
+  Qed.
+ End M.
+ Definition c2:=False.
+ Definition lift:=fun (_:Core.T) => M.c.
+ Definition lift_prop: forall (x:Core.T), (Core.my_eq x Core.c)->(M.my_eq (lift x) M.c).
+ Proof.
+   unfold lift, M.my_eq; auto.
+ Qed.
+End I2.
+
+Module I4(X:Essai3) (L: Lift with Module Core := X.M) <: Essai3 with Module
+M:=L.M.
+  Module M:=L.M.
+  Definition c3:=(L.lift X.c3).
+End I4.
+
+Module I5(X:Essai3).
+  Module Toto<:  Lift with Module Core := X.M := I2(X.M).
+  Module E4<: Essai3 with Module M:=Toto.M := I4(X)(Toto).
+(*
+Le typage de E4 echoue avec le message
+ Error: Signature components for label my_eq_refl do not match
+ *)
+
+  Module E3<: Essai3 := I4(X)(Toto).
+
+ Definition zarb: forall (x:Toto.M.T), (Toto.M.my_eq x x) := E3.M.my_eq_refl.
+End I5.
+End Sylvain_Boulme.
+
+
+Module Jacek.
+
+    Module Type SIG.
+    End SIG.
+    Module N.
+      Definition A:=Set.
+    End N.
+    Module Type SIG2.
+      Declare Module M:SIG.
+      Parameter B:Type.
+    End SIG2.
+    Module F(X:SIG2 with Module M:=N) (Y:SIG2 with Definition B:=X.M.A).
+    End F.
+End Jacek.
+
+
+Module anoun.
+    Module Type TITI.
+    Parameter X: Set.
+    End TITI.
+
+    Module Type Ex.
+    Declare Module t: TITI.
+    Parameter X : t.X -> t.X -> Set.
+    End Ex.
+
+    Module unionEx(X1: Ex) (X2:Ex with Module t :=X1.t): Ex.
+    Module t:=X1.t.
+    Definition X :=fun (a b:t.X) => ((X1.X a b)+(X2.X a b))%type.
+    End unionEx.
+End anoun.
+(* Le warning qui s'affiche lors de la compilation est le suivant :
+    TODO:replace module after with!
+    Est ce qu'il y'a qq1 qui pourrait m'aider à comprendre le probleme?!
+    Je vous remercie d'avance *)
diff --git a/test-suite/bugs/closed/3291.v b/test-suite/bugs/closed/3291.v
new file mode 100644
index 00000000..4ea748c0
--- /dev/null
+++ b/test-suite/bugs/closed/3291.v
@@ -0,0 +1,9 @@
+Require Import Setoid.
+
+Definition segv : forall x, (x = 0%nat) -> (forall (y : nat), (y < x)%nat -> nat) = forall (y : nat), (y < 0)%nat -> nat.
+intros x eq.
+assert (H : forall y, (y < x)%nat = (y < 0)%nat).
+rewrite -> eq. auto.
+Set Typeclasses Debug.
+Fail setoid_rewrite <- H. (* The command has indeed failed with message:
+=> Stack overflow. *)
diff --git a/test-suite/bugs/closed/3294.v b/test-suite/bugs/closed/3294.v
new file mode 100644
index 00000000..ed1a0c29
--- /dev/null
+++ b/test-suite/bugs/closed/3294.v
@@ -0,0 +1,6 @@
+Check (match true return
+    match eq_refl Type return Type with eq_refl => bool end
+  with _ => true end).
+Check (match true return
+    match eq_refl Type with eq_refl => bool end
+  with _ => true end).
diff --git a/test-suite/bugs/closed/3297.v b/test-suite/bugs/closed/3297.v
new file mode 100644
index 00000000..1cacb97f
--- /dev/null
+++ b/test-suite/bugs/closed/3297.v
@@ -0,0 +1,12 @@
+Goal forall (n : nat) (H := eq_refl : n = n) (H' : n = 0), H = eq_refl.
+  intros.
+  subst. (* Toplevel input, characters 15-20:
+Error: Abstracting over the term "n" leads to a term
+"λ n : nat, H = eq_refl" which is ill-typed. *)
+  Undo.
+  revert H.
+  subst. (* success *)
+  Undo.
+  intro.
+  clearbody H.
+  subst. (* success *)
diff --git a/test-suite/bugs/closed/3300.v b/test-suite/bugs/closed/3300.v
new file mode 100644
index 00000000..a28144b9
--- /dev/null
+++ b/test-suite/bugs/closed/3300.v
@@ -0,0 +1,7 @@
+Set Primitive Projections.
+Record Box (T : Type) : Prop := wrap {prop : T}.
+
+Definition down (x : Type) : Prop := Box x.
+Definition up (x : Prop) : Type := x.
+
+Fail Definition back A : up (down A) -> A := @prop A.
diff --git a/test-suite/bugs/closed/3305.v b/test-suite/bugs/closed/3305.v
new file mode 100644
index 00000000..f3f21952
--- /dev/null
+++ b/test-suite/bugs/closed/3305.v
@@ -0,0 +1,13 @@
+Require Export Coq.Classes.RelationClasses.
+
+Section defs.
+  Variable A : Type.
+  Variable lt : A -> A -> Prop.
+  Context {ltso : StrictOrder lt}.
+
+  Goal forall (a : A), lt a a -> False.
+  Proof.
+    intros a H.
+    contradict (irreflexivity H).
+  Qed.
+End defs.
diff --git a/test-suite/bugs/closed/3306.v b/test-suite/bugs/closed/3306.v
new file mode 100644
index 00000000..599e8391
--- /dev/null
+++ b/test-suite/bugs/closed/3306.v
@@ -0,0 +1,12 @@
+
+Inductive Foo(A : Type) : Prop :=
+  foo: A -> Foo A.
+
+Arguments foo [A] _.
+
+Scheme Foo_elim := Induction for Foo Sort Prop.
+
+Goal forall (fn : Foo nat), { x: nat | foo x = fn }.
+intro fn.
+Fail induction fn as [n] using Foo_elim. (* should fail in a non-Prop context *)
+Admitted. 
diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v
new file mode 100644
index 00000000..fcebdec7
--- /dev/null
+++ b/test-suite/bugs/closed/3309.v
@@ -0,0 +1,326 @@
+(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *)
+Set Universe Polymorphism.
+Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }.
+Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope.
+Arguments existT' {A} P _ _.
+Axiom admit : forall {T}, T.
+Notation paths := identity .
+
+Unset Automatic Introduction.
+
+Definition UU := Set.
+
+Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) .
+Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) .
+
+Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P.
+Proof.
+  intros X Y P xp yp X0 .
+  set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) .
+  apply ( xp ( int1 yp ) ) .
+Defined .
+Definition weq ( X Y : UU )  : UU .
+intros; exact ( sigT' (fun f:X->Y => admit) ).
+Defined.
+Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y).
+Coercion pr1weq : weq >-> Funclass.
+
+Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X .
+admit.
+Defined.
+
+Definition hProp := sigT' (fun X : Type => admit).
+
+Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}.
+intros; exact (existT' (fun X : UU => admit ) X is ).
+Defined.
+Definition hProptoType := @projT1' _ _ : hProp -> Type .
+Coercion hProptoType: hProp >-> Sortclass.
+
+Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ).
+
+Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit.
+
+Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y.
+intros X Y f; exact ( fun isx : ishinh X => fun P : _ =>  fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ).
+Defined.
+
+Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P.
+intros; exact (  wit P f ).
+Defined.
+
+Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ).
+intros; exact ( fun P:_  => ddualand (inx1 P) (iny1 P)) .
+Defined.
+
+Definition UU' := Type.
+Definition hSet:= sigT' (fun X : UU' => admit) .
+Definition hSetpair := existT' (fun X : UU' => admit).
+Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type.
+Coercion pr1hSet: hSet >-> Sortclass.
+
+Definition hPropset : hSet := existT' _ hProp admit .
+
+Definition hsubtypes ( X : UU ) : Type.
+intros; exact (X -> hProp ).
+Defined.
+Definition carrier { X : UU } ( A : hsubtypes X ) : Type.
+intros; exact (sigT' A).
+Defined.
+Coercion carrier : hsubtypes >-> Sortclass.
+
+Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ).
+admit.
+Defined.
+
+Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) .
+  admit.
+Defined.
+
+Lemma ishinhsubtypesdirprod  { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) .
+Proof .
+  intros .
+  apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) .
+  apply hinhand .
+  apply isa .
+  apply isb .
+Defined .
+
+Definition hrel ( X : UU ) : Type.
+intros; exact ( X -> X -> hProp).
+Defined.
+
+Definition iseqrel { X : UU } ( R : hrel X ) : Type.
+admit.
+Defined.
+
+Definition eqrel ( X : UU ) : Type.
+intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ).
+Defined.
+Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ .
+Coercion pr1eqrel : eqrel >-> Funclass .
+
+Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) .
+admit.
+Defined.
+Set Printing Universes.
+Print hProp.
+Print ishinh_UU.
+Print hProppair.
+Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type.
+intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 ->  A x2 -> R x1 x2 ) )) .
+Defined.
+Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 ->  A x2 -> R x1 x2 ) : iseqclass R A.
+intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2.
+Defined.
+
+Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X }  : iseqclass R A -> ishinh ( carrier A ) .
+intros X R A; exact ( fun is : iseqclass R A =>  projT1' _ is ).
+Defined.
+
+Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) .
+Proof .
+  intros .
+  set ( XY := dirprod X Y ) .
+  set ( AB := subtypesdirprod A B ) .
+  set ( RQ := hreldirprod R Q ) .
+  set ( ax0 := ishinhsubtypesdirprod  A B ( eqax0 isa ) admit ) .
+  apply ( iseqclassconstr _ ax0 admit admit ) .
+Defined .
+
+Definition image { X Y : UU } ( f : X -> Y ) : Type.
+intros; exact ( sigT' ( fun y : Y => admit ) ).
+Defined.
+Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y.
+intros X Y f; exact ( @projT1' _  ( fun y : Y => admit ) ).
+Defined.
+
+Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f.
+  admit.
+Defined.
+
+Definition setquot { X : UU } ( R : hrel X ) : Type.
+intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ).
+Defined.
+Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R.
+intros; exact (existT' _ A is ).
+Defined.
+Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ).
+intros X R.
+exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ).
+Defined.
+Coercion pr1setquot : setquot >-> hsubtypes .
+
+Definition setquotinset { X : UU } ( R : hrel X ) : hSet.
+intros; exact ( hSetpair (setquot R) admit) .
+Defined.
+
+Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ).
+intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _  ( projT2' _ cd ) ) ) ).
+Defined.
+
+Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' ->  R x0 x0' ->  paths ( f x x0 ) ( f x' x0' ) .
+
+Definition binop ( X : UU ) : Type.
+intros; exact ( X -> X -> X ).
+Defined.
+
+Definition setwithbinop : Type.
+exact (sigT' ( fun X : hSet => binop X ) ).
+Defined.
+Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}.
+unfold setwithbinop.
+exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ).
+Defined.
+Coercion pr1setwithbinop : setwithbinop >-> hSet .
+
+Definition op { X : setwithbinop } : binop X.
+intros; exact ( projT2' _ X ).
+Defined.
+
+Definition subsetswithbinop { X : setwithbinop } : Type.
+admit.
+Defined.
+
+Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop .
+admit.
+Defined.
+
+Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop .
+
+Definition binopeqrel { X : setwithbinop } : Type.
+intros; exact (sigT' ( fun R : eqrel X => admit ) ).
+Defined.
+Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ).
+Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X.
+intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) .
+Defined.
+Coercion pr1binopeqrel : binopeqrel >-> eqrel .
+
+Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop .
+admit.
+Defined.
+
+Definition monoid : Type.
+exact ( sigT' ( fun X : setwithbinop => admit ) ).
+Defined.
+Definition monoidpair := existT' ( fun X : setwithbinop => admit ) .
+Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ .
+Coercion pr1monoid : monoid >-> setwithbinop .
+
+Notation "x + y" := ( op x y ) : addmonoid_scope .
+
+Definition submonoids { X : monoid } : Type.
+admit.
+Defined.
+
+Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X.
+admit.
+Defined.
+Coercion  submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop .
+
+Definition abmonoid : Type.
+exact (sigT' ( fun X : setwithbinop => admit ) ).
+Defined.
+
+Definition abmonoidtomonoid : abmonoid -> monoid.
+exact (fun X : _ => monoidpair ( projT1' _ X ) admit ).
+Defined.
+Coercion abmonoidtomonoid : abmonoid >-> monoid .
+
+Definition subabmonoids { X : abmonoid } := @submonoids X .
+
+Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid .
+Proof .
+  intros .
+  unfold subabmonoids in A .
+  split with A .
+  admit.
+Defined .
+
+Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid .
+
+Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid .
+Proof .
+  intros .
+  split with ( setwithbinopdirprod X Y ) .
+  admit.
+Defined .
+
+Open Scope addmonoid_scope .
+
+Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ).
+admit.
+Defined.
+
+Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ).
+intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ).
+Defined.
+
+Theorem setquotuniv  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y .
+Proof.
+  intros.
+  apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) .
+  apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) .
+  pose ( eqax0 ( projT2' _ c ) )  as h.
+  simpl in *.
+  Set Printing Universes.
+  exact h.
+Defined .
+
+Definition setquotuniv2  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y .
+Proof.
+  intros .
+  set ( RR := hreldirprod R R ) .
+  apply (setquotuniv RR Y admit).
+  apply dirprodtosetquot.
+  apply dirprodpair.
+  exact c.
+  exact c0.
+Defined .
+
+Definition  setquotfun2  { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY .
+Proof .
+  intros .
+  apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) .
+Defined .
+
+Definition quotrel  { X : UU } { R : hrel X } : hrel ( setquot R ).
+intros; exact ( setquotuniv2 R hPropset admit admit ).
+Defined.
+
+Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop .
+Proof .
+  intros .
+  split with ( setquotinset R )  .
+  set ( qtmlt := setquotfun2 R R op ) .
+  simpl .
+  unfold binop .
+  apply qtmlt .
+Defined .
+
+Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid .
+Proof .
+  intros .
+  split with  ( setwithbinopquot R )  .
+  admit.
+Defined .
+
+Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid.
+intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ).
+Defined.
+
+Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) :  hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)).
+intros; exact (@quotrel _ _).
+Defined.
+
+Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit.
+
+Definition ispartlbinopabmonoidfracrel_type : Type :=
+  forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), 
+    @abmonoidfracrel X A ( ( admit + z ) )admit.
+
+Axiom ispartlbinopabmonoidfracrel : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in
+                                      ispartlbinopabmonoidfracrel_type in exact t)$.
+
diff --git a/test-suite/bugs/closed/331.v b/test-suite/bugs/closed/331.v
new file mode 100644
index 00000000..9ef796fa
--- /dev/null
+++ b/test-suite/bugs/closed/331.v
@@ -0,0 +1,20 @@
+Module Type TIT.
+
+Inductive X:Set:=
+ b:X.
+End TIT.
+
+
+Module Type TOTO.
+Declare Module t:TIT.
+Inductive titi:Set:=
+ a:t.X->titi.
+End TOTO.
+
+
+Module toto (ta:TOTO).
+Module ti:=ta.t.
+
+Definition ex1:forall (c d:ti.X), (ta.a d)=(ta.a c) -> d=c.
+intros.
+injection H.
diff --git a/test-suite/bugs/closed/3310.v b/test-suite/bugs/closed/3310.v
new file mode 100644
index 00000000..d6c31c6b
--- /dev/null
+++ b/test-suite/bugs/closed/3310.v
@@ -0,0 +1,11 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+
+CoInductive stream A := cons { hd : A; tl : stream A }.
+
+CoFixpoint id {A} (s : stream A) := cons (hd s) (id (tl s)).
+
+Lemma id_spec : forall A (s : stream A), id s = s.
+Proof.
+intros A s.
+Fail change (id s) with (cons (hd (id s)) (tl (id s))).
diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v
new file mode 100644
index 00000000..64786263
--- /dev/null
+++ b/test-suite/bugs/closed/3314.v
@@ -0,0 +1,147 @@
+Set Universe Polymorphism.
+Definition Lift
+: $(let U1 := constr:(Type) in
+    let U0 := constr:(Type : U1) in
+    exact (U0 -> U1))$
+  := fun T => T.
+
+Fail Check nat:Prop. (* The command has indeed failed with message:
+=> Error:
+The term "nat" has type "Set" while it is expected to have type "Prop". *)
+Set Printing All.
+Set Printing Universes.
+Fail Check Lift nat : Prop. (* Lift (* Top.8 Top.9 Top.10 *) nat:Prop
+     : Prop
+(* Top.10
+   Top.9
+   Top.8 |= Top.10 < Top.9
+             Top.9 < Top.8
+             Top.9 <= Prop
+              *)
+ *)
+Fail Eval compute in Lift nat : Prop.
+(*      = nat
+     : Prop *)
+
+Section Hurkens.
+
+  Monomorphic Definition Type2 := Type.
+  Monomorphic Definition Type1 := Type : Type2.
+
+  (** Assumption of a retract from Type into Prop *)
+
+  Variable down : Type1 -> Prop.
+  Variable up : Prop -> Type1.
+
+  Hypothesis back : forall A, up (down A) -> A.
+
+  Hypothesis forth : forall A, A -> up (down A).
+
+  Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A),
+                           P (back A (forth A a)) -> P a.
+
+  Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A),
+                             P a -> P (back A (forth A a)).
+
+  (** Proof *)
+
+  Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop.
+  Definition U : Type1 := V -> Prop.
+
+  Definition sb (z:V) : V := fun A r a => r (z A r) a.
+  Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)).
+  Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x).
+  Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x).
+  Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))).
+  Definition I (x:U) : Prop :=
+    (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False.
+
+  Lemma Omega : forall i:U -> Prop, induct i -> up (i WF).
+  Proof.
+    intros i y.
+    apply y.
+    unfold le, WF, induct.
+    apply forth.
+    intros x H0.
+    apply y.
+    unfold sb, le', le.
+    compute.
+    apply backforth_r.
+    exact H0.
+  Qed.
+
+  Lemma lemma1 : induct (fun u => down (I u)).
+  Proof.
+    unfold induct.
+    intros x p.
+    apply forth.
+    intro q.
+    generalize (q (fun u => down (I u)) p).
+    intro r.
+    apply back in r.
+    apply r.
+    intros i j.
+    unfold le, sb, le', le in j |-.
+                                apply backforth in j.
+    specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))).
+    apply q.
+    exact j.
+  Qed.
+
+  Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False.
+  Proof.
+    intro x.
+    generalize (x (fun u => down (I u)) lemma1).
+    intro r; apply back in r.
+    apply r.
+    intros i H0.
+    apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))).
+    unfold le, WF in H0.
+    apply back in H0.
+    exact H0.
+  Qed.
+
+  Theorem paradox : False.
+  Proof.
+    exact (lemma2 Omega).
+  Qed.
+
+End Hurkens.
+
+Definition informative (x : bool) :=
+  match x with
+    | true => Type
+    | false => Prop
+  end.
+
+Definition depsort (T : Type) (x : bool) : informative x :=
+  match x with
+    | true => T
+    | false => True
+  end.
+
+(** This definition should fail *)
+Definition Box (T : Type1) : Prop := Lift T.
+
+Definition prop {T : Type1} (t : Box T) : T := t.
+Definition wrap {T : Type1} (t : T) : Box T := t.
+
+Definition down (x : Type1) : Prop := Box x.
+Definition up (x : Prop) : Type1 := x.
+
+Fail Definition back A : up (down A) -> A := @prop A.
+
+Fail Definition forth (A : Type1) : A -> up (down A) := @wrap A.
+
+Fail Definition backforth (A:Type1) (P:A->Type) (a:A) :
+      P (back A (forth A a)) -> P a := fun H => H.
+
+Fail Definition backforth_r (A:Type1) (P:A->Type) (a:A) :
+      P a -> P (back A (forth A a)) := fun H => H.
+
+Theorem pandora : False.
+  Fail apply (paradox down up back forth backforth backforth_r).
+  admit.
+Qed.
+
+Print Assumptions pandora.
diff --git a/test-suite/bugs/closed/3315.v b/test-suite/bugs/closed/3315.v
new file mode 100644
index 00000000..b69097f9
--- /dev/null
+++ b/test-suite/bugs/closed/3315.v
@@ -0,0 +1,37 @@
+Set Universe Polymorphism.
+Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }.
+Arguments existT {A} _ _ _.
+Definition unpack_sigma' {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) :
+  Q (existT _ (projT1 u) (projT2 u)) -> Q u
+  :=
+  fun H =>
+    (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x : Q (existT _ _ p) => x) H. (* success *)
+Definition unpack_sigma {A} {P : A -> Type} (Q : sigT P -> Type) (u : sigT P) :
+  Q (existT _ (projT1 u) (projT2 u)) -> Q u
+  :=
+  fun H =>
+    (let (x,p) as u return (Q (existT _ (projT1 u) (projT2 u)) -> Q u) := u in fun x => x) H.
+(* Toplevel input, characters 219-229:
+Error:
+In environment
+A : Type
+P : A -> Type
+Q : sigT P -> Type
+u : sigT P
+H : Q {| projT1 := projT1 u; projT2 := projT2 u |}
+x : A
+p : P x
+The term
+ "fun
+    x : Q
+          {|
+          projT1 := projT1 {| projT1 := x; projT2 := p |};
+          projT2 := projT2 {| projT1 := x; projT2 := p |} |} => x" has type
+ "Q
+    {|
+    projT1 := projT1 {| projT1 := x; projT2 := p |};
+    projT2 := projT2 {| projT1 := x; projT2 := p |} |} ->
+... "
+*)
diff --git a/test-suite/bugs/closed/3317.v b/test-suite/bugs/closed/3317.v
new file mode 100644
index 00000000..8d152894
--- /dev/null
+++ b/test-suite/bugs/closed/3317.v
@@ -0,0 +1,94 @@
+Set Implicit Arguments. 
+Module A.
+  Set Universe Polymorphism.
+  Set Primitive Projections.
+  Set Asymmetric Patterns.
+  Inductive paths {A} (x : A) : A -> Type := idpath : paths x x
+                                                            where "x = y" := (@paths _ x y) : type_scope.
+  Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }.
+  Arguments existT {A} _ _ _.
+  Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+    match p with idpath => u end.
+  Notation "x .1" := (projT1 x) (at level 3).
+  Notation "x .2" := (projT2 x) (at level 3).
+  Notation "( x ; y )" := (existT _ x y).
+  Set Printing All.
+  Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+             (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2))
+  : u = v
+    := match pq with
+         | existT p q =>
+           match u, v return (forall p0 : (u.1 = v.1), (transport P p0 u.2 = v.2) -> (u=v)) with
+             | (x;y), (x';y') => fun p1 (q1 : transport P p1 (existT P x y).2 = (existT P x' y').2) =>
+                                   match p1 in (_ = x'') return (forall y'', (transport _ p1 y = y'') -> (x;y)=(x'';y'')) with
+                                     | idpath => fun y' (q2 : transport _ (@idpath _ _) y = y') =>
+                                                   match q2 in (_ = y'') return (x;y) = (x;y'') with
+                                                     | idpath => @idpath _ _
+                                                   end
+                                   end y' q1
+           end p q
+       end.
+  (* Toplevel input, characters 341-357:
+Error:
+In environment
+A : Type
+P : forall _ : A, Type
+u : @sigT A P
+v : @sigT A P
+pq :
+@sigT (@paths A (projT1 u) (projT1 v))
+  (fun p : @paths A (projT1 u) (projT1 v) =>
+   @paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u))
+     (projT2 v))
+p : @paths A (projT1 u) (projT1 v)
+q :
+@paths (P (projT1 v)) (@transport A P (projT1 u) (projT1 v) p (projT2 u))
+  (projT2 v)
+x : A
+y : P x
+x' : A
+y' : P x'
+p1 : @paths A (projT1 (@existT A P x y)) (projT1 (@existT A P x' y'))
+The term "projT2 (@existT A P x y)" has type "P (projT1 (@existT A P x y))"
+while it is expected to have type "P (projT1 (@existT A P x y))".
+   *)
+End A.
+
+Module B.
+  Set Universe Polymorphism.
+  Set Primitive Projections.
+  Set Asymmetric Patterns.
+  Inductive paths {A} (x : A) : A -> Type := idpath : paths x x
+                                                            where "x = y" := (@paths _ x y) : type_scope.
+  Record sigT {A : Type} (P : A -> Type) := existT { projT1 : A; projT2 : P projT1 }.
+  Arguments existT {A} _ _ _.
+  Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+    match p with idpath => u end.
+  Notation "x .1" := (projT1 x) (at level 3).
+  Notation "x .2" := (projT2 x) (at level 3).
+  Notation "( x ; y )" := (existT _ x y).
+  Set Printing All.
+
+  Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+             (pq : sigT (fun p : u.1 = v.1 => transport _ p u.2 = v.2))
+  : u = v.
+  Proof.
+    destruct u as [x y].
+    destruct v. (* Toplevel input, characters 0-11:
+Error: Illegal application:
+The term "transport" of type
+ "forall (A : Type) (P : forall _ : A, Type) (x y : A)
+    (_ : @paths A x y) (_ : P x), P y"
+cannot be applied to the terms
+ "A" : "Type"
+ "P" : "forall _ : A, Type"
+ "projT1 (@existT A P x y)" : "A"
+ "projT1 v" : "A"
+ "p" : "@paths A (projT1 (@existT A P x y)) (projT1 v)"
+ "projT2 (@existT A P x y)" : "P (projT1 (@existT A P x y))"
+The 5th term has type "@paths A (projT1 (@existT A P x y)) (projT1 v)"
+which should be coercible to
+ "@paths A (projT1 (@existT A P x y)) (projT1 v)".
+                 *)
+  Abort.
+End B.
diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v
new file mode 100644
index 00000000..bb5853dd
--- /dev/null
+++ b/test-suite/bugs/closed/3319.v
@@ -0,0 +1,25 @@
+(* File reduced by coq-bug-finder from original input, then from 5353 lines to 4545 lines, then from 4513 lines to 4504 lines, then from 4515 lines to 4508 lines, then from 4519 lines to 132 lines, then from 111 lines to 66 lines, then from 68 lines to 35 lines *)
+Set Implicit Arguments.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a
+                 where "x = y" := (@paths _ x y) : type_scope.
+
+Record PreCategory := { obj :> Type; morphism : obj -> obj -> Type }.
+Record NotionOfStructure (X : PreCategory) :=
+  { structure :> X -> Type;
+    is_structure_homomorphism
+    : forall x y (f : morphism X x y) (a : structure x) (b : structure y), Type }.
+
+Section precategory.
+  Variable X : PreCategory.
+  Variable P : NotionOfStructure X.
+  Local Notation object := { x : X & P x }.
+  Record morphism' (xa yb : object) := {}.
+
+  Lemma issig_morphism xa yb
+  : { f : morphism X (projT1 xa) (projT1 yb)
+    & is_structure_homomorphism _ _ _ f (projT2 xa) (projT2 yb) }
+    = morphism' xa yb. 
+  Proof.
+    admit.
+  Defined.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3321.v b/test-suite/bugs/closed/3321.v
new file mode 100644
index 00000000..07e3b3cb
--- /dev/null
+++ b/test-suite/bugs/closed/3321.v
@@ -0,0 +1,18 @@
+(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 103 lines to 83 lines, then from 86 lines to 36 lines, then from 37 lines to 17 lines *)
+
+Axiom admit : forall {T}, T.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
+Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
+Definition equiv_path (A B : Type) (p : A = B) : Equiv A B := admit.
+Class Univalence := { isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) }.
+Definition path_universe `{Univalence} {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B) := admit.
+Context `{ua:Univalence}.
+Variable A:Type.
+Goal forall (I : Type) (f : I -> A),
+       {p : I = {a : A & @hfiber I A f a} & True }.
+intros.
+clear.
+try exists (path_universe admit). (* Toplevel input, characters 15-44:
+Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/3322.v b/test-suite/bugs/closed/3322.v
new file mode 100644
index 00000000..925f22a2
--- /dev/null
+++ b/test-suite/bugs/closed/3322.v
@@ -0,0 +1,23 @@
+(* File reduced by coq-bug-finder from original input, then from 11971 lines to 11753 lines, then from 7702 lines to 564 lines, then from 571 lines to 61 lines *)
+Set Asymmetric Patterns.
+Axiom admit : forall {T}, T.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P)
+           (pq : {p : (projT1 u) = (projT1 v) &  transport _ p (projT2 u) = (projT2 v)})
+: u = v.
+Proof.
+  destruct pq as [p q], u as [x y], v as [x' y']; simpl in *.
+  destruct p, q; simpl; reflexivity.
+Defined.
+Arguments path_sigma_uncurried : simpl never.
+Section opposite.
+  Let opposite_functor_involutive_helper
+    := @path_sigma_uncurried admit admit (existT _ admit admit) admit (existT _ admit admit).
+
+  Goal True.
+  Opaque path_sigma_uncurried.
+  simpl in *.
+  Transparent path_sigma_uncurried.
+  (* This command should fail with "Error: Failed to progress.", as it does in 8.4; the simpl never directive should prevent simpl from progressing *)
+  Fail progress simpl in *.
diff --git a/test-suite/bugs/closed/3323.v b/test-suite/bugs/closed/3323.v
new file mode 100644
index 00000000..fb5a8a7e
--- /dev/null
+++ b/test-suite/bugs/closed/3323.v
@@ -0,0 +1,77 @@
+(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 5302 lines to 4649 lines, then from 4660 lines to 355 lines, then from 360 lines to 269 lines, then from 269 lines to 175 lines, then from 144 lines to 119 lines, then from 297 lines to 117 lines, then from 95 lines to 79 lines, then from 82 lines to 68 lines *)
+
+Set Universe Polymorphism.
+Generalizable All Variables.
+Inductive sigT {A:Type} (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P.
+Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
+Definition projT1 {A} {P : A -> Type} (x : sigT P) : A := let (a, _) := x in a.
+Definition projT2 {A} {P : A -> Type} (x : sigT P) : P (projT1 x) := let (a, h) return P (projT1 x) := x in h.
+Axiom admit : forall {T}, T.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
+Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Existing Instance equiv_isequiv.
+Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv (@equiv_inv _ _ f _) | 10000 := admit.
+Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P)
+: Equiv {p : projT1 u = projT1 v &  transport _ p (projT2 u) = projT2 v} (u = v) := admit.
+Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
+Definition path_universe {A B : Type} (f : A -> B) : (A = B) := admit.
+Section AssumeFunext.
+  Let equiv_fibration_replacement_eissect {B C f}
+  : forall x : {y : B & {x : C & f x = y}},
+      existT _ (f (projT1 (projT2 x))) (existT _ (projT1 (projT2 x)) idpath) = x.
+    admit.
+  Defined.
+  Definition equiv_fibration_replacement  {B C} (f:C ->B):
+    Equiv C {y:B & {x:C & f x = y}}.
+  Proof.
+    refine (BuildEquiv
+              _ _ _
+              (BuildIsEquiv
+                 C {y:B & {x:C & f x = y}}
+                 (fun c => existT _ (f c) (existT _ c idpath))
+                 (fun c => projT1 (projT2 c))
+                 equiv_fibration_replacement_eissect)).
+  Defined.
+  Definition equiv_total_paths (A : Type) (P : A-> Type) (x y : sigT P) :
+    Equiv (x = y) { p : projT1 x = projT1 y & transport P p (projT2 x) = (projT2 y) }
+    := BuildEquiv _ _ (@equiv_inv _ _ _ (equiv_path_sigma P x y)) _.
+  Variable A:Type.
+  Definition Fam A:=sigT (fun I:Type  => I->A).
+  Definition p2f: (A->Type)-> Fam A := fun Q:(A->Type) => existT _ (sigT Q) (@projT1 _ _).
+  Definition f2p: Fam A -> (A->Type) := fun F => let (I, f) := F in (fun a => (hfiber f a)).
+  Definition exp {U V:Type}(w:Equiv U V):Equiv (U->A) (V->A).
+    exists (fun f:(U->A)=> (fun x => (f (@equiv_inv _ _ w _ x)))).
+    admit.
+  Defined.
+  Goal { h : Fam A -> A -> Type & Sect h p2f }.
+  exists f2p.
+  intros [I f].
+  set (e:=@equiv_total_paths _ _ (@existT Type (fun I0 : Type => I0 -> A) I f)
+                             (existT _ {a : A & hfiber f a} (@projT1 _ _))).
+  simpl in e.
+  cut ( {p : I = {a : A & @hfiber I A f a} &
+                                           @transport _ (fun I0 : Type => I0 -> A) _ _ p f = @projT1 _ _}).
+  { intro X.
+    apply (inverse (@equiv_inv _ _ _ e X)). }
+  set (w:=@equiv_fibration_replacement A I f).
+  exists (path_universe w).
+  assert (forall x, (exp w) f x = projT1 x); [ | admit ].
+  intros [a [i p]].
+  exact p.
+  Qed.
+(* Toplevel input, characters 15-19:
+Error: In pattern-matching on term "x" the branch for constructor
+"existT(*Top.256 Top.258*)" has type
+ "forall (I : Type) (f : I -> A),
+  existT (fun I0 : Type => I0 -> A) {a : A & hfiber f a} projT1 =
+  existT (fun I0 : Type => I0 -> A) I f" which should be
+ "forall (x : Type) (H : x -> A),
+  p2f (f2p (existT (fun I : Type => I -> A) x H)) =
+  existT (fun I : Type => I -> A) x H".
+ *)
diff --git a/test-suite/bugs/closed/3324.v b/test-suite/bugs/closed/3324.v
new file mode 100644
index 00000000..9cd6e4c2
--- /dev/null
+++ b/test-suite/bugs/closed/3324.v
@@ -0,0 +1,47 @@
+Module ETassi.
+  Axiom admit : forall {T}, T.
+  Class IsHProp (A : Type) : Type := {}.
+  Class IsHSet (A : Type) : Type := {}.
+  Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}.
+  Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+  Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+  Global Instance isset_hProp : IsHSet hProp | 0.
+
+  Check (eq_refl _ : setT (default_HSet _ _) = hProp).
+  Check (eq_refl _ : setT _ = hProp).
+End ETassi.
+
+Module JGross.
+  (* File reduced by coq-bug-finder from original input, then from 6462 lines to 5760 lines, then from 5761 lines to 181 lines, then from 191 lines to 181 lines, then from 181 lines to 83 lines, then from 87 lines to 27 lines *)
+  Axiom admit : forall {T}, T.
+  Class IsHProp (A : Type) : Type := {}.
+  Class IsHSet (A : Type) : Type := {}.
+  Inductive Unit : Set := tt.
+  Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}.
+  Definition Unit_hp:hProp:=(hp Unit admit).
+  Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+  Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+  Global Instance isset_hProp : IsHSet hProp | 0.
+  Definition isepi {X Y} `(f:X->Y) := forall Z: hSet,
+                                      forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h.
+  Lemma isepi_issurj {X Y} (f:X->Y): isepi f -> True.
+  Proof.
+    intros epif.
+    set (g :=fun _:Y => Unit_hp).
+    pose proof (epif (default_HSet hProp isset_hProp) g).
+    specialize (epif _ g).
+    (* Toplevel input, characters 34-35:
+Error:
+In environment
+X : Type
+Y : Type
+f : X -> Y
+epif : isepi f
+g := fun _ : Y => Unit_hp : Y -> hProp
+H : forall h : Y -> default_HSet hProp isset_hProp,
+    (fun x : X => g (f x)) = (fun x : X => h (f x)) -> g = h
+The term "g" has type "Y -> hProp" while it is expected to have type
+ "Y -> ?30".
+     *)
+  Abort.
+End JGross.
diff --git a/test-suite/bugs/closed/3325.v b/test-suite/bugs/closed/3325.v
new file mode 100644
index 00000000..36c065eb
--- /dev/null
+++ b/test-suite/bugs/closed/3325.v
@@ -0,0 +1,48 @@
+Typeclasses eauto := debug.
+Set Printing All.
+
+Axiom SProp : Set.
+Axiom sp : SProp.
+
+(* If we hardcode valueType := nat, it goes through *)
+Class StateIs := {
+  valueType : Type;
+  stateIs : valueType -> SProp
+}.
+
+Instance NatStateIs : StateIs := {
+  valueType := nat;
+  stateIs := fun _ => sp
+}.
+Canonical Structure NatStateIs.
+
+Class LogicOps F := { land: F -> F }.
+Instance : LogicOps SProp. Admitted.
+Instance : LogicOps Prop. Admitted.
+
+Parameter (n : nat).
+(* If this is a [Definition], the resolution goes through fine. *)
+Notation vn := (@stateIs _ n).
+Definition vn' := (@stateIs _ n).
+Definition GOOD : SProp :=
+  @land _ _ vn'.
+(* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *)
+Definition BAD : SProp :=
+  @land _ _ vn.
+
+
+Class A T := { foo : T -> Prop }.
+Instance: A nat. Admitted.
+Instance: A Set. Admitted.
+
+Class B := { U : Type ; b : U }.
+Instance bi: B := {| U := nat ; b := 0 |}.
+Canonical Structure bi.
+
+Notation b0N := (@b _ : nat).
+Notation b0Ni := (@b bi : nat).
+Definition b0D := (@b _ : nat).
+Definition GOOD1 := (@foo _ _ b0D).
+Definition GOOD2 := (let x := b0N in @foo _ _ x).
+Definition GOOD3 := (@foo _ _ b0Ni).
+Definition BAD1 := (@foo _ _ b0N). (* Error: The term "b0Ni" has type "nat" while it is expected to have type "Set". *)
diff --git a/test-suite/bugs/closed/3326.v b/test-suite/bugs/closed/3326.v
new file mode 100644
index 00000000..4d7e9f77
--- /dev/null
+++ b/test-suite/bugs/closed/3326.v
@@ -0,0 +1,19 @@
+Class ORDER A := Order {
+  LEQ : A -> A -> bool; 
+  leqRefl: forall x, true = LEQ x x
+}.
+
+Section XXX.
+
+Variable A:Type.
+Variable (O:ORDER A).
+Definition aLeqRefl := @leqRefl _ O.
+
+Lemma OK : forall x, true = LEQ x x.
+Proof.
+  intros.
+  unfold LEQ.
+  destruct O.
+  clear.
+  Fail apply aLeqRefl.
+Abort.
diff --git a/test-suite/bugs/closed/3329.v b/test-suite/bugs/closed/3329.v
new file mode 100644
index 00000000..f7e368f8
--- /dev/null
+++ b/test-suite/bugs/closed/3329.v
@@ -0,0 +1,93 @@
+(* File reduced by coq-bug-finder from original input, then from 12095 lines to 869 lines, then from 792 lines to 504 lines, then from 487 lines to 353 lines, then from 258 lines to 174 lines, then from 164 lines to 132 lines, then from 129 lines to 99 lines *)
+Set Universe Polymorphism.
+Generalizable All Variables.
+Axiom admit : forall {T}, T.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Notation "g 'o' f" := (compose g f).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type := forall x:A, f x = g x.
+Hint Unfold pointwise_paths : typeclass_instances.
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+: forall x, f x = g x
+  := fun x => match h with idpath => idpath end.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
+Class IsHSet (A : Type) := { _ : False }.
+Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+    trunc_morphism : forall s d, IsHSet (morphism s d) }.
+
+Definition trunc_equiv `(f : A -> B) `{IsHSet A} `{IsEquiv A B f} : IsHSet B := admit.
+Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsHSet (P a)}
+: IsHSet (forall a, P a) | 100.
+Proof.
+  generalize dependent P.
+  intro P.
+  assert (f : forall a, P a) by admit.
+  assert (g : forall a, P a) by admit.
+  pose (@trunc_equiv (forall x : A, @paths (P x) (f x) (g x))
+                     (@paths (forall x : A, P x) f g)
+                     (@equiv_inv (@paths (forall x : A, P x) f g)
+                                 (forall x : A, @paths (P x) (f x) (g x))
+                                 (@apD10 A P f g) (@isequiv_apD10 H A P f g))).
+  admit.
+Defined.
+Record Functor (C D : PreCategory) := { object_of :> C -> D }.
+Definition identity C : Functor C C := Build_Functor C C admit.
+Notation "1" := (identity _) : functor_scope.
+Definition functor_category (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D) admit admit.
+Notation "C -> D" := (functor_category C D) : category_scope.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Global Existing Instance iss.
+Definition set_cat `{Funext} : PreCategory :=
+  @Build_PreCategory hSet
+                     (fun x y => x -> y)
+                     _.
+
+Section hom_functor.
+  Context `{Funext}.
+  Variable C : PreCategory.
+
+  Local Notation obj_of c'c :=
+    (BuildhSet
+       (morphism
+          C
+          c'c
+          c'c)
+       admit).
+  Let hom_functor_morphism_of s's d'd (hf : morphism C s's d'd)
+  : morphism set_cat (obj_of s's) (obj_of d'd)
+    := admit.
+
+  Definition hom_functor : Functor C set_cat := admit.
+End hom_functor.
+Local Open Scope category_scope.
+Local Open Scope functor_scope.
+Context `{Funext}.
+Variable D : PreCategory.
+Set Printing Universes.
+Check hom_functor D o 1.
+(* Toplevel input, characters 20-44:
+Error: Illegal application:
+The term "@set_cat" of type "(Funext -> PreCategory)%type"
+cannot be applied to the term
+ "H" : "Funext"
+This term has type "Funext" which should be coercible to
+"Funext". *)
+(* The command has indeed failed with message:
+=> Error: Illegal application:
+The term "@set_cat@{Top.345 Top.346 Top.331 Top.332 Top.337 Top.338 Top.339}"
+of type
+ "(Funext@{Top.346 Top.346 Top.331 Top.332 Top.346} -> PreCategory@{Top.345
+   Top.346})%type"
+cannot be applied to the term
+ "H@{Top.346 Top.330 Top.331 Top.332 Top.333}"
+   : "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}"
+This term has type "Funext@{Top.346 Top.330 Top.331 Top.332 Top.333}"
+which should be coercible to
+ "Funext@{Top.346 Top.346 Top.331 Top.332 Top.346}".
+*)
diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v
new file mode 100644
index 00000000..15303cca
--- /dev/null
+++ b/test-suite/bugs/closed/3330.v
@@ -0,0 +1,1110 @@
+(* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *)
+Set Universe Polymorphism.
+Definition setleq (A : Type@{i}) (B : Type@{j}) := A : Type@{j}.
+
+Inductive foo : Type@{l} := bar : foo . 
+Section MakeEq.
+  Variables (a : foo@{i}) (b : foo@{j}).
+
+  Let t := $(let ty := type of b in exact ty)$.
+  Definition make_eq (x:=b) := a : t.
+End MakeEq.
+
+Definition same (x : foo@{i}) (y : foo@{i}) := x.
+
+Section foo.
+
+  Variables x : foo@{i}.
+  Variables y : foo@{j}.
+  
+  Let AleqB := let foo := make_eq x y in (Type * Type)%type.
+
+  Definition baz := same x y.
+End foo.
+
+Definition baz' := Eval unfold baz in baz@{i j k l}.
+
+Module Export HoTT_DOT_Overture.
+Module Export HoTT.
+Module Export Overture.
+
+Definition relation (A : Type) := A -> A -> Type.
+Class Symmetric {A} (R : relation A) :=
+  symmetry : forall x y, R x y -> R y x.
+
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) :=
+  fun x => g (f x).
+
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+
+Open Scope function_scope.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Delimit Scope path_scope with path.
+
+Local Open Scope path_scope.
+
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
+  match p, q with idpath, idpath => idpath end.
+
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
+  := match p with idpath => idpath end.
+
+Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A.
+
+Notation "1" := idpath : path_scope.
+
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+
+Notation "p ^" := (inverse p) (at level 3) : path_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type
+  := forall x:A, f x = g x.
+
+Hint Unfold pointwise_paths : typeclass_instances.
+
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+  : f == g
+  := fun x => match h with idpath => 1 end.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : Sect equiv_inv f;
+  eissect : Sect f equiv_inv;
+  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Delimit Scope equiv_scope with equiv.
+
+Local Open Scope equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+
+Class Contr_internal (A : Type) := BuildContr {
+  center : A ;
+  contr : (forall y : A, center = y)
+}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint nat_to_trunc_index (n : nat) : trunc_index
+  := match n with
+       | 0 => trunc_S (trunc_S minus_two)
+       | S n' => trunc_S (nat_to_trunc_index n')
+     end.
+
+Coercion nat_to_trunc_index : nat >-> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation IsHSet := (IsTrunc 0).
+
+Class Funext :=
+  { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+
+Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) :
+  f == g -> f = g
+  :=
+  (@apD10 A P f g)^-1.
+
+End Overture.
+
+End HoTT.
+
+End HoTT_DOT_Overture.
+
+Module Export HoTT_DOT_categories_DOT_Category_DOT_Core.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Category.
+Module Export Core.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Delimit Scope morphism_scope with morphism.
+
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+
+Record PreCategory :=
+  Build_PreCategory' {
+      object :> Type;
+      morphism : object -> object -> Type;
+
+      identity : forall x, morphism x x;
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+
+      associativity : forall x1 x2 x3 x4
+                             (m1 : morphism x1 x2)
+                             (m2 : morphism x2 x3)
+                             (m3 : morphism x3 x4),
+                        (m3 o m2) o m1 = m3 o (m2 o m1);
+
+      associativity_sym : forall x1 x2 x3 x4
+                                 (m1 : morphism x1 x2)
+                                 (m2 : morphism x2 x3)
+                                 (m3 : morphism x3 x4),
+                            m3 o (m2 o m1) = (m3 o m2) o m1;
+
+      left_identity : forall a b (f : morphism a b), identity b o f = f;
+      right_identity : forall a b (f : morphism a b), f o identity a = f;
+
+      identity_identity : forall x, identity x o identity x = identity x;
+
+      trunc_morphism : forall s d, IsHSet (morphism s d)
+    }.
+
+Bind Scope category_scope with PreCategory.
+
+Arguments identity [!C%category] x%object : rename.
+Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+Definition Build_PreCategory
+           object morphism compose identity
+           associativity left_identity right_identity
+  := @Build_PreCategory'
+       object
+       morphism
+       compose
+       identity
+       associativity
+       (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _))
+       left_identity
+       right_identity
+       (fun _ => left_identity _ _ _).
+
+Existing Instance trunc_morphism.
+
+Hint Resolve @left_identity @right_identity @associativity : category morphism.
+
+Module Export CategoryCoreNotations.
+
+  Infix "o" := compose : morphism_scope.
+End CategoryCoreNotations.
+End Core.
+
+End Category.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Category_DOT_Core.
+
+Module Export HoTT_DOT_types_DOT_Forall.
+
+Module Export HoTT.
+Module Export types.
+Module Export Forall.
+Generalizable Variables A B f g e n.
+
+Section AssumeFunext.
+
+Global Instance trunc_forall `{P : A -> Type} `{forall a, IsTrunc n (P a)}
+  : IsTrunc n (forall a, P a) | 100.
+
+admit.
+Defined.
+End AssumeFunext.
+
+End Forall.
+
+End types.
+
+End HoTT.
+
+End HoTT_DOT_types_DOT_Forall.
+
+Module Export HoTT_DOT_types_DOT_Prod.
+
+Module Export HoTT.
+Module Export types.
+Module Export Prod.
+Local Open Scope path_scope.
+
+Definition path_prod_uncurried {A B : Type} (z z' : A * B)
+  (pq : (fst z = fst z') * (snd z = snd z'))
+  : (z = z')
+  := match pq with (p,q) =>
+       match z, z' return
+         (fst z = fst z') -> (snd z = snd z') -> (z = z') with
+         | (a,b), (a',b') => fun p q =>
+           match p, q with
+             idpath, idpath => 1
+           end
+       end p q
+     end.
+
+Definition path_prod {A B : Type} (z z' : A * B) :
+  (fst z = fst z') -> (snd z = snd z') -> (z = z')
+  := fun p q => path_prod_uncurried z z' (p,q).
+
+Definition path_prod' {A B : Type} {x x' : A} {y y' : B}
+  : (x = x') -> (y = y') -> ((x,y) = (x',y'))
+  := fun p q => path_prod (x,y) (x',y') p q.
+
+End Prod.
+
+End types.
+
+End HoTT.
+
+End HoTT_DOT_types_DOT_Prod.
+
+Module Export HoTT_DOT_categories_DOT_Functor_DOT_Core.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Functor.
+Module Export Core.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Delimit Scope functor_scope with functor.
+
+Local Open Scope morphism_scope.
+
+Section Functor.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Record Functor :=
+    {
+      object_of :> C -> D;
+      morphism_of : forall s d, morphism C s d
+                                -> morphism D (object_of s) (object_of d);
+      composition_of : forall s d d'
+                              (m1 : morphism C s d) (m2: morphism C d d'),
+                         morphism_of _ _ (m2 o m1)
+                         = (morphism_of _ _ m2) o (morphism_of _ _ m1);
+      identity_of : forall x, morphism_of _ _ (identity x)
+                              = identity (object_of x)
+    }.
+
+End Functor.
+Bind Scope functor_scope with Functor.
+
+Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Module Export FunctorCoreNotations.
+
+  Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+End FunctorCoreNotations.
+End Core.
+
+End Functor.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Functor_DOT_Core.
+
+Module Export HoTT_DOT_categories_DOT_Category_DOT_Morphisms.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Category.
+Module Export Morphisms.
+Set Universe Polymorphism.
+
+Local Open Scope morphism_scope.
+
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) :=
+  {
+    morphism_inverse : morphism C d s;
+    left_inverse : morphism_inverse o m = identity _;
+    right_inverse : m o morphism_inverse = identity _
+  }.
+
+Class Isomorphic {C : PreCategory} s d :=
+  {
+    morphism_isomorphic :> morphism C s d;
+    isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic
+  }.
+
+Module Export CategoryMorphismsNotations.
+
+  Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.
+
+End CategoryMorphismsNotations.
+End Morphisms.
+
+End Category.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Category_DOT_Morphisms.
+
+Module Export HoTT_DOT_categories_DOT_Category_DOT_Dual.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Category.
+Module Export Dual.
+Set Universe Polymorphism.
+
+Local Open Scope morphism_scope.
+
+Section opposite.
+
+  Definition opposite (C : PreCategory) : PreCategory
+    := @Build_PreCategory'
+         C
+         (fun s d => morphism C d s)
+         (identity (C := C))
+         (fun _ _ _ m1 m2 => m2 o m1)
+         (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _)
+         (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _)
+         (fun _ _ => @right_identity _ _ _)
+         (fun _ _ => @left_identity _ _ _)
+         (@identity_identity C)
+         _.
+End opposite.
+
+Module Export CategoryDualNotations.
+
+  Notation "C ^op" := (opposite C) (at level 3) : category_scope.
+End CategoryDualNotations.
+End Dual.
+
+End Category.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Category_DOT_Dual.
+
+Module Export HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Functor.
+Module Export Composition.
+Module Export Core.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Local Open Scope morphism_scope.
+
+Section composition.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable E : PreCategory.
+  Variable G : Functor D E.
+  Variable F : Functor C D.
+
+  Local Notation c_object_of c := (G (F c)) (only parsing).
+
+  Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing).
+
+  Let compose_composition_of' s d d'
+      (m1 : morphism C s d) (m2 : morphism C d d')
+  : c_morphism_of (m2 o m1) = c_morphism_of m2 o c_morphism_of m1.
+admit.
+Defined.
+  Definition compose_composition_of s d d' m1 m2
+    := Eval cbv beta iota zeta delta
+            [compose_composition_of'] in
+        @compose_composition_of' s d d' m1 m2.
+  Let compose_identity_of' x
+  : c_morphism_of (identity x) = identity (c_object_of x).
+
+admit.
+Defined.
+  Definition compose_identity_of x
+    := Eval cbv beta iota zeta delta
+            [compose_identity_of'] in
+        @compose_identity_of' x.
+  Definition compose : Functor C E
+    := Build_Functor
+         C E
+         (fun c => G (F c))
+         (fun _ _ m => morphism_of G (morphism_of F m))
+         compose_composition_of
+         compose_identity_of.
+
+End composition.
+Module Export FunctorCompositionCoreNotations.
+
+  Infix "o" := compose : functor_scope.
+End FunctorCompositionCoreNotations.
+End Core.
+
+End Composition.
+
+End Functor.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Functor_DOT_Composition_DOT_Core.
+
+Module Export HoTT_DOT_categories_DOT_Functor_DOT_Dual.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Functor.
+Module Export Dual.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+
+Section opposite.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Definition opposite (F : Functor C D) : Functor C^op D^op
+    := Build_Functor (C^op) (D^op)
+                     (object_of F)
+                     (fun s d => morphism_of F (s := d) (d := s))
+                     (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
+                     (identity_of F).
+
+End opposite.
+Module Export FunctorDualNotations.
+
+  Notation "F ^op" := (opposite F) : functor_scope.
+End FunctorDualNotations.
+End Dual.
+
+End Functor.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Functor_DOT_Dual.
+
+Module Export HoTT_DOT_categories_DOT_Functor_DOT_Identity.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Functor.
+Module Export Identity.
+Set Universe Polymorphism.
+
+Section identity.
+
+  Definition identity C : Functor C C
+    := Build_Functor C C
+                     (fun x => x)
+                     (fun _ _ x => x)
+                     (fun _ _ _ _ _ => idpath)
+                     (fun _ => idpath).
+End identity.
+Module Export FunctorIdentityNotations.
+
+  Notation "1" := (identity _) : functor_scope.
+End FunctorIdentityNotations.
+End Identity.
+
+End Functor.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Functor_DOT_Identity.
+
+Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core.
+
+Module Export HoTT.
+Module Export categories.
+Module Export NaturalTransformation.
+Module Export Core.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Local Open Scope morphism_scope.
+
+Section NaturalTransformation.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+
+  Record NaturalTransformation :=
+    Build_NaturalTransformation' {
+        components_of :> forall c, morphism D (F c) (G c);
+        commutes : forall s d (m : morphism C s d),
+                     components_of d o F _1 m = G _1 m o components_of s;
+
+        commutes_sym : forall s d (m : C.(morphism) s d),
+                         G _1 m o components_of s = components_of d o F _1 m
+      }.
+
+End NaturalTransformation.
+End Core.
+
+End NaturalTransformation.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Core.
+
+Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual.
+
+Module Export HoTT.
+Module Export categories.
+Module Export NaturalTransformation.
+Module Export Dual.
+Set Universe Polymorphism.
+
+Section opposite.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Definition opposite
+             (F G : Functor C D)
+             (T : NaturalTransformation F G)
+  : NaturalTransformation G^op F^op
+    := Build_NaturalTransformation' (G^op) (F^op)
+                                    (components_of T)
+                                    (fun s d => commutes_sym T d s)
+                                    (fun s d => commutes T d s).
+
+End opposite.
+
+End Dual.
+
+End NaturalTransformation.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Dual.
+
+Module Export HoTT_DOT_categories_DOT_Category_DOT_Strict.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Category.
+Module Export Strict.
+
+Export Category.Core.
+Set Universe Polymorphism.
+
+End Strict.
+
+End Category.
+
+End categories.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_Category_DOT_Strict.
+
+Module Export HoTT.
+Module Export categories.
+Module Export Category.
+Module Export Prod.
+Set Universe Polymorphism.
+
+Local Open Scope morphism_scope.
+
+Section prod.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Definition prod : PreCategory.
+
+    refine (@Build_PreCategory
+              (C * D)%type
+              (fun s d => (morphism C (fst s) (fst d)
+                           * morphism D (snd s) (snd d))%type)
+              (fun x => (identity (fst x), identity (snd x)))
+              (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))
+              _
+              _
+              _
+              _); admit.
+  Defined.
+End prod.
+Module Export CategoryProdNotations.
+
+  Infix "*" := prod : category_scope.
+End CategoryProdNotations.
+End Prod.
+
+End Category.
+
+End categories.
+
+End HoTT.
+
+Module Functor.
+Module Export Prod.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Local Open Scope morphism_scope.
+
+Section proj.
+
+  Context {C : PreCategory}.
+  Context {D : PreCategory}.
+  Definition fst : Functor (C * D) C
+    := Build_Functor (C * D) C
+                     (@fst _ _)
+                     (fun _ _ => @fst _ _)
+                     (fun _ _ _ _ _ => idpath)
+                     (fun _ => idpath).
+
+  Definition snd : Functor (C * D) D
+    := Build_Functor (C * D) D
+                     (@snd _ _)
+                     (fun _ _ => @snd _ _)
+                     (fun _ _ _ _ _ => idpath)
+                     (fun _ => idpath).
+
+End proj.
+
+Section prod.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable D' : PreCategory.
+  Definition prod (F : Functor C D) (F' : Functor C D')
+  : Functor C (D * D')
+    := Build_Functor
+         C (D * D')
+         (fun c => (F c, F' c))
+         (fun s d m => (F _1 m, F' _1 m))
+         (fun _ _ _ _ _ => path_prod' (composition_of F _ _ _ _ _)
+                                      (composition_of F' _ _ _ _ _))
+         (fun _ => path_prod' (identity_of F _) (identity_of F' _)).
+
+End prod.
+Local Infix "*" := prod : functor_scope.
+
+Section pair.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable C' : PreCategory.
+  Variable D' : PreCategory.
+  Variable F : Functor C D.
+  Variable F' : Functor C' D'.
+  Definition pair : Functor (C * C') (D * D')
+    := (F o fst) * (F' o snd).
+
+End pair.
+
+Module Export FunctorProdNotations.
+
+  Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : functor_scope.
+End FunctorProdNotations.
+End Prod.
+
+End Functor.
+
+Module Export HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.
+
+Module Export HoTT.
+Module categories.
+Module Export NaturalTransformation.
+Module Export Composition.
+Module Export Core.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Local Open Scope path_scope.
+
+Local Open Scope morphism_scope.
+
+Section composition.
+
+  Section compose.
+    Variable C : PreCategory.
+    Variable D : PreCategory.
+    Variables F F' F'' : Functor C D.
+    Variable T' : NaturalTransformation F' F''.
+
+    Variable T : NaturalTransformation F F'.
+    Local Notation CO c := (T' c o T c).
+
+    Definition compose_commutes s d (m : morphism C s d)
+    : CO d o morphism_of F m = morphism_of F'' m o CO s
+      := (associativity _ _ _ _ _ _ _ _)
+           @ ap (fun x => _ o x) (commutes T _ _ m)
+           @ (associativity_sym _ _ _ _ _ _ _ _)
+           @ ap (fun x => x o _) (commutes T' _ _ m)
+           @ (associativity _ _ _ _ _ _ _ _).
+
+    Definition compose_commutes_sym s d (m : morphism C s d)
+    : morphism_of F'' m o CO s = CO d o morphism_of F m
+      := (associativity_sym _ _ _ _ _ _ _ _)
+           @ ap (fun x => x o _) (commutes_sym T' _ _ m)
+           @ (associativity _ _ _ _ _ _ _ _)
+           @ ap (fun x => _ o x) (commutes_sym T _ _ m)
+           @ (associativity_sym _ _ _ _ _ _ _ _).
+
+    Definition compose
+    : NaturalTransformation F F''
+      := Build_NaturalTransformation' F F''
+                                      (fun c => CO c)
+                                      compose_commutes
+                                      compose_commutes_sym.
+
+  End compose.
+  End composition.
+Module Export NaturalTransformationCompositionCoreNotations.
+
+  Infix "o" := compose : natural_transformation_scope.
+End NaturalTransformationCompositionCoreNotations.
+End Core.
+
+End Composition.
+
+End NaturalTransformation.
+
+End categories.
+
+Set Universe Polymorphism.
+
+Section path_natural_transformation.
+
+  Context `{Funext}.
+  Variable C : PreCategory.
+
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+
+  Global Instance trunc_natural_transformation
+  : IsHSet (NaturalTransformation F G).
+
+admit.
+Defined.
+  Section path.
+
+    Variables T U : NaturalTransformation F G.
+
+    Lemma path'_natural_transformation
+    : components_of T = components_of U
+      -> T = U.
+
+admit.
+Defined.
+    Lemma path_natural_transformation
+    : components_of T == components_of U
+      -> T = U.
+
+    Proof.
+      intros.
+      apply path'_natural_transformation.
+      apply path_forall; assumption.
+    Qed.
+  End path.
+End path_natural_transformation.
+
+Ltac path_natural_transformation :=
+  repeat match goal with
+           | _ => intro
+           | _ => apply path_natural_transformation; simpl
+         end.
+
+Module Export Identity.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+Local Open Scope morphism_scope.
+
+Local Open Scope path_scope.
+Section identity.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Section generalized.
+
+    Variables F G : Functor C D.
+    Hypothesis HO : object_of F = object_of G.
+    Hypothesis HM : transport (fun GO => forall s d,
+                                           morphism C s d
+                                           -> morphism D (GO s) (GO d))
+                              HO
+                              (morphism_of F)
+                    = morphism_of G.
+    Local Notation CO c := (transport (fun GO => morphism D (F c) (GO c))
+                                      HO
+                                      (identity (F c))).
+
+    Definition generalized_identity_commutes s d (m : morphism C s d)
+    : CO d o morphism_of F m = morphism_of G m o CO s.
+
+    Proof.
+      case HM.
+case HO.
+      exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^).
+    Defined.
+    Definition generalized_identity_commutes_sym s d (m : morphism C s d)
+    : morphism_of G m o CO s = CO d o morphism_of F m.
+
+admit.
+Defined.
+    Definition generalized_identity
+    : NaturalTransformation F G
+      := Build_NaturalTransformation'
+           F G
+           (fun c => CO c)
+           generalized_identity_commutes
+           generalized_identity_commutes_sym.
+
+  End generalized.
+  Definition identity (F : Functor C D)
+  : NaturalTransformation F F
+    := Eval simpl in @generalized_identity F F 1 1.
+
+End identity.
+Module Export NaturalTransformationIdentityNotations.
+
+  Notation "1" := (identity _) : natural_transformation_scope.
+End NaturalTransformationIdentityNotations.
+End Identity.
+
+Module Export Laws.
+Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories.
+Set Universe Polymorphism.
+
+Local Open Scope natural_transformation_scope.
+Section natural_transformation_identity.
+
+  Context `{fs : Funext}.
+  Variable C : PreCategory.
+
+  Variable D : PreCategory.
+
+  Lemma left_identity (F F' : Functor C D)
+        (T : NaturalTransformation F F')
+  : 1 o T = T.
+
+  Proof.
+    path_natural_transformation; auto with morphism.
+  Qed.
+
+  Lemma right_identity (F F' : Functor C D)
+        (T : NaturalTransformation F F')
+  : T o 1 = T.
+
+  Proof.
+    path_natural_transformation; auto with morphism.
+  Qed.
+End natural_transformation_identity.
+Section associativity.
+
+  Section nt.
+
+    Context `{fs : Funext}.
+    Definition associativity
+               C D F G H I
+               (V : @NaturalTransformation C D F G)
+               (U : @NaturalTransformation C D G H)
+               (T : @NaturalTransformation C D H I)
+    : (T o U) o V = T o (U o V).
+
+    Proof.
+      path_natural_transformation.
+      apply associativity.
+    Qed.
+  End nt.
+End associativity.
+End Laws.
+
+Module Export FunctorCategory.
+Module Export Core.
+Import HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.HoTT.categories.
+Set Universe Polymorphism.
+
+Section functor_category.
+
+  Context `{Funext}.
+  Variable C : PreCategory.
+
+  Variable D : PreCategory.
+
+  Definition functor_category : PreCategory
+    := @Build_PreCategory (Functor C D)
+                          (@NaturalTransformation C D)
+                          (@identity C D)
+                          (@compose C D)
+                          (@associativity _ C D)
+                          (@left_identity _ C D)
+                          (@right_identity _ C D)
+                          _.
+
+End functor_category.
+Module Export FunctorCategoryCoreNotations.
+
+  Notation "C -> D" := (functor_category C D) : category_scope.
+End FunctorCategoryCoreNotations.
+End Core.
+
+End FunctorCategory.
+
+Module Export Morphisms.
+Set Universe Polymorphism.
+
+Set Implicit Arguments.
+
+Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G :=
+  @Isomorphic (C -> D) F G.
+
+Module Export FunctorCategoryMorphismsNotations.
+
+  Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.
+End FunctorCategoryMorphismsNotations.
+End Morphisms.
+
+Module Export HSet.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+
+Global Existing Instance iss.
+End HSet.
+
+Module Export Core.
+Set Universe Polymorphism.
+
+Notation cat_of obj :=
+  (@Build_PreCategory obj
+                      (fun x y => x -> y)
+                      (fun _ x => x)
+                      (fun _ _ _ f g => f o g)%core
+                      (fun _ _ _ _ _ _ _ => idpath)
+                      (fun _ _ _ => idpath)
+                      (fun _ _ _ => idpath)
+                      _).
+
+Definition set_cat `{Funext} : PreCategory := cat_of hSet.
+Set Universe Polymorphism.
+
+Local Open Scope morphism_scope.
+
+Section hom_functor.
+
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Local Notation obj_of c'c :=
+    (BuildhSet
+       (morphism
+          C
+          (fst (c'c : object (C^op * C)))
+          (snd (c'c : object (C^op * C))))
+       _).
+
+  Let hom_functor_morphism_of s's d'd (hf : morphism (C^op * C) s's d'd)
+  : morphism set_cat (obj_of s's) (obj_of d'd)
+    := fun g => snd hf o g o fst hf.
+
+  Definition hom_functor : Functor (C^op * C) set_cat.
+
+    refine (Build_Functor (C^op * C) set_cat
+                          (fun c'c => obj_of c'c)
+                          hom_functor_morphism_of
+                          _
+                          _);
+    subst hom_functor_morphism_of;
+    simpl; admit.
+  Defined.
+End hom_functor.
+Set Universe Polymorphism.
+
+Import Category.Dual Functor.Dual.
+Import Category.Prod Functor.Prod.
+Import Functor.Composition.Core.
+Import Functor.Identity.
+Set Universe Polymorphism.
+
+Local Open Scope functor_scope.
+Local Open Scope natural_transformation_scope.
+Section Adjunction.
+
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable F : Functor C D.
+  Variable G : Functor D C.
+
+  Let Adjunction_Type := 
+    Eval simpl in (hom_functor D) o (F^op, 1) <~=~> (hom_functor C) o (1, G).
+
+  Record AdjunctionHom :=
+    {
+      mate_of : 
+        @NaturalIsomorphism H
+                         (Prod.prod (Category.Dual.opposite C) D)
+                         (@set_cat H)
+                         (@compose (Prod.prod (Category.Dual.opposite C) D)
+                            (Prod.prod (Category.Dual.opposite D) D)
+                            (@set_cat H) (@hom_functor H D)
+                            (@pair (Category.Dual.opposite C)
+                               (Category.Dual.opposite D) D D
+                               (@opposite C D F) (identity D)))
+                         (@compose (Prod.prod (Category.Dual.opposite C) D)
+                            (Prod.prod (Category.Dual.opposite C) C)
+                            (@set_cat H) (@hom_functor H C)
+                            (@pair (Category.Dual.opposite C)
+                               (Category.Dual.opposite C) D C
+                               (identity (Category.Dual.opposite C)) G))
+    }.
+End Adjunction.
+(* Error: Illegal application:
+The term "NaturalIsomorphism" of type
+ "forall (H : Funext) (C D : PreCategory),
+  (C -> D)%category -> (C -> D)%category -> Type"
+cannot be applied to the terms
+ "H" : "Funext"
+ "(C ^op * D)%category" : "PreCategory"
+ "set_cat" : "PreCategory"
+ "hom_functor D o (F ^op, 1)" : "Functor (C ^op * D) set_cat"
+ "hom_functor C o (1, G)" : "Functor (C ^op * D) set_cat"
+The 5th term has type "Functor (C ^op * D) set_cat"
+which should be coercible to "object (C ^op * D -> set_cat)".
+*)
+End Core.
+
+End HoTT.
+
+End HoTT_DOT_categories_DOT_NaturalTransformation_DOT_Composition_DOT_Core.
diff --git a/test-suite/bugs/closed/3331.v b/test-suite/bugs/closed/3331.v
new file mode 100644
index 00000000..9cd44bd0
--- /dev/null
+++ b/test-suite/bugs/closed/3331.v
@@ -0,0 +1,31 @@
+(* File reduced by coq-bug-finder from original input, then from 6303 lines to 66 lines, then from 63 lines to 36 lines *)
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y :> A" := (@paths A x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (x = y :>_) : type_scope.
+Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }.
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A.
+Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) : IsTrunc n (x = y) := H x y.
+Notation Contr := (IsTrunc minus_two).
+Section groupoid_category.
+  Variable X : Type.
+  Context `{H : IsTrunc (trunc_S (trunc_S (trunc_S minus_two))) X}.
+  Goal X -> True.
+    intro d.
+    pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))) as H'. (* success *)
+    clear H'.
+    compute in H.
+    change (forall (x y : X) (p q : x = y) (r s : p = q), Contr (r = s)) in H.
+    assert (H' := H).
+    set (foo:=_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). (* success *)
+    clear H' foo.
+    Set Typeclasses Debug.
+    pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). 
+Abort. 
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3332.v b/test-suite/bugs/closed/3332.v
new file mode 100644
index 00000000..d86470cd
--- /dev/null
+++ b/test-suite/bugs/closed/3332.v
@@ -0,0 +1,6 @@
+(* -*- coq-prog-args: ("-emacs" "-time") -*- *)
+Definition foo : True.
+Proof.
+Abort. (* Toplevel input, characters 15-21:
+Anomaly: Backtrack.backto to a state with no vcs_backup. Please report. *)
+(* Anomaly: VernacAbort not handled by Stm. Please report. *)
diff --git a/test-suite/bugs/closed/3336.v b/test-suite/bugs/closed/3336.v
new file mode 100644
index 00000000..dc358c60
--- /dev/null
+++ b/test-suite/bugs/closed/3336.v
@@ -0,0 +1,9 @@
+Require Import Setoid.
+
+Goal forall x y : Type, x = y -> x = y.
+intros x y H.
+setoid_rewrite H.
+reflexivity.
+Defined.
+(* Toplevel input, characters 0-16:
+Anomaly: Uncaught exception Reduction.NotConvertible(_). Please report. *)
diff --git a/test-suite/bugs/closed/3337.v b/test-suite/bugs/closed/3337.v
new file mode 100644
index 00000000..cd7891f1
--- /dev/null
+++ b/test-suite/bugs/closed/3337.v
@@ -0,0 +1,4 @@
+Require Import Setoid.
+Goal forall x y : Set, x = y -> x = y.
+intros x y H.
+rewrite_strat subterms H.
diff --git a/test-suite/bugs/closed/3338.v b/test-suite/bugs/closed/3338.v
new file mode 100644
index 00000000..076cd5e6
--- /dev/null
+++ b/test-suite/bugs/closed/3338.v
@@ -0,0 +1,4 @@
+Require Import Setoid.
+Goal forall x y : Set, x = y -> y = y.
+intros x y H.
+rewrite_strat try topdown terms H.
diff --git a/test-suite/bugs/closed/3344.v b/test-suite/bugs/closed/3344.v
new file mode 100644
index 00000000..8255fd6c
--- /dev/null
+++ b/test-suite/bugs/closed/3344.v
@@ -0,0 +1,58 @@
+(* File reduced by coq-bug-finder from original input, then from 716 lines to 197 lines, then from 206 lines to 162 lines, then from 163 lines to 73 lines *)
+Require Import Coq.Sets.Ensembles.
+Require Import Coq.Strings.String.
+Global Set Implicit Arguments.
+Global Set Asymmetric Patterns.
+Ltac clearbodies := repeat match goal with | [ H := _ |- _ ] => clearbody H end.
+
+Inductive Comp : Type -> Type :=
+| Return : forall A, A -> Comp A
+| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B.
+Inductive computes_to : forall A, Comp A -> A -> Prop :=
+| ReturnComputes : forall A v, @computes_to A (Return v) v
+| BindComputes : forall A B comp_a f comp_a_value comp_b_value,
+                   @computes_to A comp_a comp_a_value
+                   -> @computes_to B (f comp_a_value) comp_b_value
+                   -> @computes_to B (Bind comp_a f) comp_b_value.
+
+Inductive is_computational : forall A, Comp A -> Prop :=
+| Return_is_computational : forall A (x : A), is_computational (Return x)
+| Bind_is_computational : forall A B (cA : Comp A) (f : A -> Comp B),
+                            is_computational cA
+                            -> (forall a,
+                                  @computes_to _ cA a -> is_computational (f a))
+                            -> is_computational (Bind cA f).
+Theorem is_computational_inv A (c : Comp A)
+: is_computational c
+  -> match c with
+       | Return _ _ => True
+       | Bind _ _ x f => is_computational x
+                         /\ forall v, computes_to x v
+                                      -> is_computational (f v)
+     end.
+  admit.
+Defined.
+Fixpoint is_computational_unique_val A (c : Comp A) {struct c}
+: is_computational c -> { a | unique (computes_to c) a }.
+Proof.
+  refine match c as c return is_computational c -> { a | unique (computes_to c) a } with
+           | Return T x => fun _ => exist (unique (computes_to (Return x)))
+                                          x
+                                          _
+           | Bind _ _ x f
+             => fun H
+                => let H' := is_computational_inv H in
+                   let xv := @is_computational_unique_val _ _ (proj1 H') in
+                   let fxv := @is_computational_unique_val _ _ (proj2 H' _ (proj1 (proj2_sig xv))) in
+                   exist (unique (computes_to _))
+                         (proj1_sig fxv)
+                         _
+         end;
+  clearbodies;
+  clear is_computational_unique_val;
+  clear;
+  first [ abstract admit
+        | abstract admit ].
+(* [Fail] does not catch the anomaly *)
+Defined.
+(* Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/3346.v b/test-suite/bugs/closed/3346.v
new file mode 100644
index 00000000..638404f2
--- /dev/null
+++ b/test-suite/bugs/closed/3346.v
@@ -0,0 +1,4 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Monomorphic Inductive paths (A : Type) (a : A) : A -> Type := idpath : paths A a a.
+(* This should fail with -indices-matter *)
+Fail Check paths nat O O : Prop.
diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v
new file mode 100644
index 00000000..37c0d87e
--- /dev/null
+++ b/test-suite/bugs/closed/3347.v
@@ -0,0 +1,39 @@
+(* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *)
+Set Universe Polymorphism.
+Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Inductive Unit : Type1 := tt : Unit.
+Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *)
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Record Functor (C D : PreCategory) := { object_of :> C -> D }.
+Definition indiscrete_category X : PreCategory := @Build_PreCategory X (fun _ _ => Unit).
+Definition from_terminal (C : PreCategory) one (c : C) := Build_Functor one C (fun _ => c).
+Local Notation "! x" := (from_terminal _ (indiscrete_category Unit) x) (at level 3).
+Record NaturalTransformation {C D} (F G : Functor C D) :=
+  { components_of :> forall c, morphism D (F c) (G c);
+    commutes : forall c, components_of c = components_of c }.
+Definition slice_category_induced_functor_nt (D : PreCategory) s d (m : morphism D s d)
+: NaturalTransformation !s !d.
+Proof.
+  exists (fun _ : Unit => m);
+  simpl; intros; clear;
+  abstract admit.
+Defined.
+(* Toplevel input, characters 15-23:
+Error: Illegal application:
+The term "Build_NaturalTransformation" of type
+ "forall (C D : PreCategory) (F G : Functor C D)
+    (components_of : forall c : C, morphism D (F c) (G c)),
+  (forall c : C, components_of c = components_of c) ->
+  NaturalTransformation F G"
+cannot be applied to the terms
+ "indiscrete_category Unit" : "PreCategory"
+ "D" : "PreCategory"
+ "! s" : "Functor (indiscrete_category Unit) D"
+ "! d" : "Functor (indiscrete_category Unit) D"
+ "fun _ : Unit => m" : "Unit -> morphism D s d"
+ "fun _ : Unit => slice_category_induced_functor_nt_subproof D s d m"
+   : "forall c : indiscrete_category Unit, m = m"
+The 5th term has type "Unit -> morphism D s d" which should be coercible to
+ "forall c : indiscrete_category Unit, morphism D (! s c) (! d c)".
+ *)
diff --git a/test-suite/bugs/closed/3348.v b/test-suite/bugs/closed/3348.v
new file mode 100644
index 00000000..d9ac09d8
--- /dev/null
+++ b/test-suite/bugs/closed/3348.v
@@ -0,0 +1,6 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Set Universe Polymorphism.
+Set Printing Universes.
+Inductive Empty : Set := .
+(* Toplevel input, characters 15-41:
+Error: Universe inconsistency. Cannot enforce Prop <= Set). *)
diff --git a/test-suite/bugs/closed/shouldsucceed/335.v b/test-suite/bugs/closed/335.v
index 166fa7a9..166fa7a9 100644
--- a/test-suite/bugs/closed/shouldsucceed/335.v
+++ b/test-suite/bugs/closed/335.v
diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v
new file mode 100644
index 00000000..30fdf169
--- /dev/null
+++ b/test-suite/bugs/closed/3350.v
@@ -0,0 +1,120 @@
+Require Coq.Vectors.Fin.
+Require Coq.Vectors.Vector.
+
+Local Generalizable All Variables.
+Set Implicit Arguments.
+
+Arguments Fin.F1 : clear implicits.
+
+Lemma fin_0_absurd : notT (Fin.t 0).
+Proof. hnf. apply Fin.case0. Qed.
+
+Axiom admit : forall {A}, A.
+
+Fixpoint lower {n:nat} (p:Fin.t (S n)) {struct p} :
+  forall (i:Fin.t (S n)), option (Fin.t n)
+  := match p in Fin.t (S n1)
+           return Fin.t (S n1) -> option (Fin.t n1)
+     with
+       | @Fin.F1 n1 =>
+         fun (i:Fin.t (S n1)) =>
+           match i in Fin.t (S n2) return option (Fin.t n2) with
+             | @Fin.F1 n2 => None
+             | @Fin.FS n2 i2 => Some i2
+           end
+       | @Fin.FS n1 p1 =>
+         fun (i:Fin.t (S n1)) =>
+           match i in Fin.t (S n2) return Fin.t n2 -> option (Fin.t n2) with
+             | @Fin.F1 n2 =>
+               match n2 as n3 return Fin.t n3 -> option (Fin.t n3) with
+                 | 0 => fun p2 => False_rect _ (fin_0_absurd p2)
+                 | S n3 => fun p2 => Some (Fin.F1 n3)
+               end
+             | @Fin.FS n2 i2 =>
+               match n2 as n3 return Fin.t n3 -> Fin.t n3 -> option (Fin.t n3) with
+                 | 0 => fun i3 p3 => False_rect _ (fin_0_absurd p3)
+                 | S n3 => fun (i3 p3:Fin.t (S n3)) =>
+                             option_map (@Fin.FS _) admit
+               end i2
+           end p1
+     end.
+
+Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop)
+      (c11 : forall n, P n (Fin.F1 n) (Fin.F1 n) None)
+      (c1S : forall n (i:Fin.t n), P n (Fin.F1 n) (Fin.FS i) (Some i))
+      (cS1 : forall n (p:Fin.t (S n)),
+               P (S n) (Fin.FS p) (Fin.F1 (S n)) (Some (Fin.F1 n)))
+      (cSSS : forall n (p i:Fin.t (S n)) (i':Fin.t n)
+                     (Elow:lower p i = Some i'),
+                P n p i (Some i') ->
+                P (S n) (Fin.FS p) (Fin.FS i) (Some (Fin.FS i')))
+      (cSSN : forall n (p i:Fin.t (S n))
+                (Elow:lower p i = None),
+                P n p i None ->
+                P (S n) (Fin.FS p) (Fin.FS i) None) :
+  forall n (p i:Fin.t (S n)), P n p i (lower p i).
+Proof.
+  fix 2. intros n p.
+  refine (match p as p1 in Fin.t (S n1)
+                return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1)
+          with
+            | @Fin.F1 n1 => _
+            | @Fin.FS n1 p1 => _
+          end); clear n p.
+  { revert n1. refine (@Fin.caseS _ _ _); cbn; intros.
+    apply c11. apply c1S. }
+  { intros i1. revert p1.
+    pattern n1, i1; refine (@Fin.caseS _ _ _ _ _);
+    clear n1 i1;
+    (intros [|n] i; [refine (False_rect _ (fin_0_absurd i)) | cbn ]).
+    { apply cS1. }
+    { intros p. pose proof (admit : P n p i (lower p i)) as H.
+      destruct (lower p i) eqn:E.
+      { admit; assumption. }
+      { cbn. apply admit; assumption. } } }
+Qed.
+
+Section squeeze.
+  Context {A:Type} (x:A).
+  Notation vec := (Vector.t A).
+
+  Fixpoint squeeze {n} (v:vec n) (i:Fin.t (S n)) {struct i} : vec (S n) :=
+    match i in Fin.t (S _n) return vec _n -> vec (S _n)
+    with
+      | @Fin.F1 n' => fun v' => Vector.cons _ x _ v'
+      | @Fin.FS n' i' =>
+        fun v' =>
+          match n' as _n return vec _n -> Fin.t _n -> vec (S _n)
+          with
+            | 0 => fun u i' => False_rect _ (fin_0_absurd i')
+            | S m =>
+              fun (u:vec (S m)) =>
+                match u in Vector.t _ (S _m)
+                      return Fin.t (S _m) -> vec (S (S _m))
+                with
+                  | Vector.nil _ => tt
+                  | Vector.cons _ h _ u' =>
+                    fun j' => Vector.cons _ h _ admit (* (squeeze u' j') *)
+                end
+          end v' i'
+    end v.
+End squeeze.
+
+Require Import Program.
+Lemma squeeze_nth (A:Type) (x:A) (n:nat) (v:Vector.t A n) p i :
+  Vector.nth (squeeze x v p) i = match lower p i with
+                                   | Some j => Vector.nth v j
+                                   | None => x
+                                 end.
+Proof.
+  (* alternatively: [functional induction (lower p i) using lower_ind] *)
+  revert v. pattern n, p, i, (lower p i).
+  refine (@lower_ind _ _ _ _ _ _ n p i);
+    intros; cbn; auto.
+
+  (*** Fails here with "Conversion test raised an anomaly" ***)
+  revert v.
+  admit.
+  admit.
+  admit.
+Qed.
diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v
new file mode 100644
index 00000000..b57b0a0f
--- /dev/null
+++ b/test-suite/bugs/closed/3352.v
@@ -0,0 +1,34 @@
+
+(*
+I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo].  (I think this worked in HoTT/coq, too.)  Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A].  (The issue is tricker when IsHProp uses [A] elsewhere, as in:
+*)
+
+(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *)
+Set Universe Polymorphism.
+Inductive Empty : Set := .
+Record IsHProp (A : Type) := { foo : True }.
+Definition hprop_Empty : IsHProp@{i} Empty := {| foo := I |}.
+Goal let U := Type in let gt := Set : U in IsHProp (Empty : U).
+simpl.
+Set Printing Universes.
+exact @hprop_Empty. (* Toplevel input, characters 21-32:
+Error:
+The term "hprop_Empty" has type "IsHProp (* Set *) Empty"
+while it is expected to have type "IsHProp (* Top.17 *) Empty"
+(Universe inconsistency: Cannot enforce Top.17 = Set because Set < Top.17)). *)
+Defined.
+
+Module B.
+(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 7725 lines to 78 lines, then from 51 lines to 13 lines *)
+Set Universe Polymorphism.
+Inductive paths {A} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Record Contr (A : Type) := { center : A }.
+Monomorphic Record IsHProp (A : Type) := { foo : forall x y : A, Contr (x = y) }.
+Definition hprop_Empty : IsHProp Empty := {| foo x y := match x : Empty with end |}.
+Goal let U := Type in let gt := Set : U in IsHProp (Empty : U).
+simpl.
+Set Printing Universes.
+exact hprop_Empty.
+Defined.
+End B.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v
new file mode 100644
index 00000000..14b66db3
--- /dev/null
+++ b/test-suite/bugs/closed/3354.v
@@ -0,0 +1,12 @@
+Set Universe Polymorphism.
+Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing).
+Inductive Empty : Type1 := .
+Fail Check Empty : Set.
+(* Toplevel input, characters 15-116:
+Error: Conversion test raised an anomaly *)
+(* Now we make sure it's not an anomaly *)
+Goal True.
+Proof.
+  try exact (let x := Empty : Set in I).
+  exact I.
+Defined.
diff --git a/test-suite/bugs/closed/3355.v b/test-suite/bugs/closed/3355.v
new file mode 100644
index 00000000..46a57147
--- /dev/null
+++ b/test-suite/bugs/closed/3355.v
@@ -0,0 +1,6 @@
+Inductive paths {A} (x : A) : A -> Type := idpath : paths x x.
+Goal forall A B : Set, @paths Type A B -> @paths Set A B.
+Proof.
+  intros A B H.
+  Fail exact H.
+Abort.
diff --git a/test-suite/bugs/closed/3368.v b/test-suite/bugs/closed/3368.v
new file mode 100644
index 00000000..1eff1dba
--- /dev/null
+++ b/test-suite/bugs/closed/3368.v
@@ -0,0 +1,16 @@
+(* File reduced by coq-bug-finder from 7411 lines to 2271 lines., then from 889 lines to 119 lines, then from 76 lines to 19 lines *)
+Set Universe Polymorphism.
+Set Implicit Arguments. 
+Set Primitive Projections.
+Record PreCategory := { object :> Type; morphism : object -> object -> Type }.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }.
+Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s).
+Definition opposite' C D (F : Functor C D)
+  := Build_Functor (opposite C) (opposite D)
+                   (object_of F)
+                   (fun s d => @morphism_of C D F d s).
+(* Toplevel input, characters 15-191:
+Anomaly: File "pretyping/reductionops.ml", line 149, characters 4-10: Assertion failed.
+Please report. *)
diff --git a/test-suite/bugs/closed/3372.v b/test-suite/bugs/closed/3372.v
new file mode 100644
index 00000000..91e3df76
--- /dev/null
+++ b/test-suite/bugs/closed/3372.v
@@ -0,0 +1,7 @@
+Set Universe Polymorphism.
+Definition hProp : Type := sigT (fun _ : Type => True).
+Goal Type.
+Fail exact hProp@{Set}. (* test that it fails, but is not an anomaly *)
+try (exact hProp@{Set}; fail 1). (* Toplevel input, characters 15-32:
+Anomaly: Uncaught exception Invalid_argument("Array.iter2", _).
+Please report. *)
diff --git a/test-suite/bugs/closed/3373.v b/test-suite/bugs/closed/3373.v
new file mode 100644
index 00000000..5ecf2801
--- /dev/null
+++ b/test-suite/bugs/closed/3373.v
@@ -0,0 +1,33 @@
+(* File reduced by coq-bug-finder from original input, then from 5968 lines to
+11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446
+lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then
+from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348
+lines to 320 lines, then from 328 lines to 302 lines, then from 332 lines to 21
+lines *)
+Set Universe Polymorphism.
+Module short.
+  Record foo := { bar : Type }.
+  Coercion baz (x : foo@{Set}) : Set := bar x.
+  Goal True.
+  Proof.
+    Fail pose ({| bar := Set |} : Type). (* check that it fails *)
+    try pose ({| bar := Set |} : Type). (* Anomaly: apply_coercion_args: mismatch between arguments and coercion.
+Please report. *)
+  Admitted.
+End short.
+
+Module long.
+  Axiom admit : forall {T}, T.
+  Definition UU := Set.
+  Definition UU' := Type.
+  Definition hSet:= sigT (fun X : UU' => admit) .
+  Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type.
+  Coercion pr1hSet: hSet >-> Sortclass.
+  Axiom binop : UU -> Type.
+  Axiom setwithbinop : Type.
+  Goal True.
+  Proof.
+    Fail pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it fails *)
+    try pose (( @projT1 _ ( fun X : hSet@{i j k} => binop X ) ) : _ -> hSet). (* check that it's not an anomaly *)
+  Admitted.
+End long.
diff --git a/test-suite/bugs/closed/3374.v b/test-suite/bugs/closed/3374.v
new file mode 100644
index 00000000..3c67703a
--- /dev/null
+++ b/test-suite/bugs/closed/3374.v
@@ -0,0 +1,51 @@
+(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 331 lines to 59 lines *)
+
+Set Universe Polymorphism.
+Axiom admit : forall {T}, T.
+Notation paths := identity .
+Definition UU := Set.
+Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) .
+Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) .
+Definition hProp := sigT (fun X : Type => admit).
+Definition hProptoType := @projT1 _ _ : hProp -> Type .
+Coercion hProptoType: hProp >-> Sortclass.
+Definition UU' := Type.
+Definition hSet:= sigT (fun X : UU' => admit) .
+Definition pr1hSet:= @projT1 UU (fun X : UU' => admit) : hSet -> Type.
+Coercion pr1hSet: hSet >-> Sortclass.
+Axiom hsubtypes : UU -> Type.
+Definition hrel ( X : UU ) := X -> X -> hProp.
+Axiom hreldirprod : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ), hrel ( dirprod X Y ) .
+Axiom iseqclass : forall { X : UU } ( R : hrel X ) ( A : hsubtypes X ), Type.
+Definition setquot { X : UU } ( R : hrel X ) : Type := sigT (fun A => iseqclass R A).
+Axiom dirprodtosetquot : forall { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ),
+                           setquot ( hreldirprod RX RY ).
+Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y )
+  := forall x x' x0 x0' : X , R x x' ->  R x0 x0' ->  paths ( f x x0 ) ( f x' x0' ) .
+Axiom setquotuniv : forall  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ), Y .
+Definition setquotuniv2  { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R )
+: Y .
+Proof.
+  intros .
+  set ( RR := hreldirprod R R ) .
+  apply (setquotuniv RR Y admit).
+  apply (dirprodtosetquot R R).
+  apply dirprodpair; [ exact c | exact c0 ].
+  Undo.
+  exact (dirprodpair c c0).
+Defined.
+  (* Toplevel input, characters 39-40:
+Error:
+In environment
+X : UU
+R : hrel X
+Y : hSet
+f : X -> X -> Y
+is : iscomprelfun2 R f
+c : setquot R
+c0 : setquot R
+RR := hreldirprod R R : hrel (dirprod X X)
+The term "c" has type "setquot R" while it is expected to have type
+"?42" (unable to find a well-typed instantiation for
+"?42": cannot unify"Type" and "UU").
+ *)
diff --git a/test-suite/bugs/closed/3375.v b/test-suite/bugs/closed/3375.v
new file mode 100644
index 00000000..fe323fcb
--- /dev/null
+++ b/test-suite/bugs/closed/3375.v
@@ -0,0 +1,48 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-impredicative-set") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines, then from 330 lines to 45 lines *)
+
+Set Universe Polymorphism.
+Axiom admit : forall {T}, T.
+Definition UU := Set.
+Definition dirprod ( X Y : UU ) := sigT ( fun x : X => Y ) .
+Definition dirprodpair { X Y : UU } := existT ( fun x : X => Y ) .
+Definition hProp := sigT (fun X : Type => admit).
+Axiom hProppair : forall ( X : UU ) ( is : admit ), hProp.
+Definition hProptoType := @projT1 _ _ : hProp -> Type .
+Coercion hProptoType: hProp >-> Sortclass.
+Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ).
+Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit.
+Definition hsubtypes ( X : UU ) : Type := X -> hProp.
+Axiom carrier : forall { X : UU } ( A : hsubtypes X ), Type.
+Definition hrel ( X : UU ) : Type := X -> X -> hProp.
+Set Printing Universes.
+Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type.
+  intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 )
+                                                             ( forall x1 x2 : X, A x1 ->  A x2 -> R x1 x2 ) )) .
+Defined.
+Definition iseqclassconstr' { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) )
+           ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 ->  A x2 -> R x1 x2 ) : iseqclass R A.
+  intros.
+  apply dirprodpair. { exact ax0. }
+                     apply dirprodpair. { exact ax1. } {exact ax2. }
+Defined.
+Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) )
+           ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 ->  A x2 -> R x1 x2 ) : iseqclass R A.
+  pose @iseqclassconstr'.
+  intros.
+  exact (dirprodpair ax0 (dirprodpair ax1 ax2)).
+Defined.
+(* Toplevel input, characters 15-23:
+Error: Illegal application:
+The term "dirprodpair" of type
+ "forall (X Y : UU) (x : X), (fun _ : X => Y) x -> {_ : X & Y}"
+cannot be applied to the terms
+ "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2"
+   : "Type@{max(Set, Top.476, Top.479)}"
+ "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2"
+   : "Type@{max(Set, Top.476, Top.479)}"
+ "ax1" : "forall x1 x2 : X, R x1 x2 -> A x1 -> A x2"
+ "ax2" : "forall x1 x2 : X, A x1 -> A x2 -> R x1 x2"
+The 1st term has type "Type@{max(Set, Top.476, Top.479)}"
+which should be coercible to "UU".
+ *)
diff --git a/test-suite/bugs/closed/3377.v b/test-suite/bugs/closed/3377.v
new file mode 100644
index 00000000..8e9e3933
--- /dev/null
+++ b/test-suite/bugs/closed/3377.v
@@ -0,0 +1,17 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod A B := pair { fst : A; snd : B}.
+
+Goal fst (@pair Type Type Type Type).
+Set Printing All.
+match goal with |- ?f ?x => set (foo := f x) end.
+
+Goal forall x : prod Set Set, x = @pair _ _ (fst x) (snd x).
+Proof.
+  intro x.
+  lazymatch goal with
+    | [ |- ?x = @pair _ _ (?f ?x) (?g ?x) ] => pose f
+  end.
+
+(* Toplevel input, characters 7-44:
+Error: No matching clauses for match. *)
diff --git a/test-suite/bugs/closed/3382.v b/test-suite/bugs/closed/3382.v
new file mode 100644
index 00000000..1d8e9167
--- /dev/null
+++ b/test-suite/bugs/closed/3382.v
@@ -0,0 +1,63 @@
+(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then from 7245 lines to 476 lines, then from 417 lines to 249 lines, then from 171 lines to 127 lines, then from 139 lines to 114 lines, then from 93 lines to 77 lines *)
+
+Set Implicit Arguments.
+Definition admit {T} : T.
+Admitted.
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope functor_scope with functor.
+Reserved Infix "o" (at level 40, left associativity).
+Record PreCategory :=
+  { Object :> Type;
+    Morphism : Object -> Object -> Type;
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g) }.
+Bind Scope category_scope with PreCategory.
+Infix "o" := (@Compose _ _ _ _) : morphism_scope.
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+  { ObjectOf :> C -> D;
+    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d);
+    FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'),
+                       MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1) }.
+Bind Scope functor_scope with Functor.
+Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Definition ComposeFunctors C D E
+           (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor C E (fun c => G (F c)) admit admit.
+Infix "o" := ComposeFunctors : functor_scope.
+Record NaturalTransformation C D (F G : Functor C D) :=
+  { ComponentsOf :> forall c, D.(Morphism) (F c) (G c);
+    Commutes : forall s d (m : C.(Morphism) s d),
+                 ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s }.
+Definition NTComposeT C D (F F' F'' : Functor C D)
+           (T' : NaturalTransformation F' F'')
+           (T : NaturalTransformation F F')
+           (CO := fun c => T' c o T c)
+: NaturalTransformation F F''.
+  exact (Build_NaturalTransformation F F''
+                                     (fun c => T' c o T c)
+                                     (admit : forall s d (m : Morphism C s d), CO d o MorphismOf F m = MorphismOf F'' m o CO s)).
+Defined.
+Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F')
+           (G : Functor C D)
+  := Build_NaturalTransformation (F o G) (F' o G) (fun c => T (G c)) admit.
+Axiom NTWhiskerR_CompositionOf
+: forall C D
+         (F G H : Functor C D)
+         (T : NaturalTransformation G H)
+         (T' : NaturalTransformation F G) B (I : Functor B C),
+    NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I) = NTWhiskerR (NTComposeT T T') I.
+Definition FunctorCategory C D : PreCategory
+  := @Build_PreCategory (Functor C D)
+                        (NaturalTransformation (C := C) (D := D))
+                        admit.
+Notation "[ C , D ]" := (FunctorCategory C D) : category_scope.
+Class silly {T} := term : T.
+Timeout 1 Fail Definition NTWhiskerR_Functorial (C D E : PreCategory) (G : [C, D]%category)
+: [[D, E], [C, E]]%category
+  := Build_Functor
+       [C, D] [C, E]
+       (fun F => _ : silly)
+       (fun _ _ T => _ : silly)
+       (fun _ _ _ _ _ => NTWhiskerR_CompositionOf _ _ _).
diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v
new file mode 100644
index 00000000..0e236c21
--- /dev/null
+++ b/test-suite/bugs/closed/3386.v
@@ -0,0 +1,16 @@
+Set Universe Polymorphism.
+Set Printing Universes.
+Record Cat := { Obj :> Type }.
+Definition set_cat := {| Obj := Type |}.
+Goal Type@{i} = Type@{j}.
+Proof.
+  (* 1 subgoals
+, subgoal 1 (ID 3)
+
+  ============================
+   Type@{Top.368} = Type@{Top.370}
+(dependent evars:) *)
+  Fail change Type@{i} with (Obj set_cat@{i}). (* check that it fails *)
+  try change Type@{i} with (Obj set_cat@{i}). (* check that it's not an anomaly *)
+(* Anomaly: Uncaught exception Invalid_argument("Array.iter2", _).
+Please report. *)
diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v
new file mode 100644
index 00000000..ae212caa
--- /dev/null
+++ b/test-suite/bugs/closed/3387.v
@@ -0,0 +1,21 @@
+Set Universe Polymorphism.
+Set Printing Universes.
+Record Cat := { Obj :> Type }.
+Definition set_cat := {| Obj := Type |}.
+Goal Type@{i} = Type@{j}.
+Proof.
+  (* 1 subgoals
+, subgoal 1 (ID 3)
+
+  ============================
+   Type@{Top.368} = Type@{Top.370}
+(dependent evars:) *)
+  let x := constr:(Type) in
+  let y := constr:(Obj set_cat) in
+  unify x y. (* success *)
+  let x := constr:(Type) in
+  let y := constr:(Obj set_cat) in
+  first [ unify x y | fail 2 "no unify" ];
+    change x with y at -1. (* Error: Not convertible. *)
+  reflexivity.
+Defined.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3388.v b/test-suite/bugs/closed/3388.v
new file mode 100644
index 00000000..78262804
--- /dev/null
+++ b/test-suite/bugs/closed/3388.v
@@ -0,0 +1,57 @@
+Inductive test : bool -> bool -> Type :=
+| test00 : test false false
+| test01 : test false true
+| test10 : test true false
+.
+
+(* This does not work *)
+Definition test_a (t : test true false) : test true false :=
+  match t with
+    | test10 => test10
+  end.
+
+(* The following definition shows that test_a SHOULD work *)
+Definition test_a_workaround (t : test true false) : test true false :=
+  match t with
+    | test10 => test10
+    | _ => tt
+  end.
+
+(* Surprisingly, this works *)
+Definition test_b (t : test false true) : test false true :=
+  match t with
+    | test01 => test01
+  end.
+
+
+(* This, too, works *)
+Definition test_c x (t : test false x) : test false x :=
+  match t with
+    | test00 => test00
+    | test01 => test01
+  end.
+
+Inductive test2 : bool -> bool -> Type :=
+| test201 : test2 false true
+| test210 : test2 true false
+| test211 : test2 true true
+.
+
+(* Now this works *)
+Definition test2_a (t : test2 true false) : test2 true false :=
+  match t with
+    | test210 => test210
+  end.
+
+(* Accordingly, this now fails *)
+Definition test2_b (t : test2 false true) : test2 false true :=
+  match t with
+    | test201 => test201
+  end.
+
+
+(* This, too, fails *)
+Definition test2_c x (t : test2 false x) : test2 false x :=
+  match t with
+    | test201 => test201
+  end.
diff --git a/test-suite/bugs/closed/3390.v b/test-suite/bugs/closed/3390.v
new file mode 100644
index 00000000..eb3c4f4b
--- /dev/null
+++ b/test-suite/bugs/closed/3390.v
@@ -0,0 +1,9 @@
+Tactic Notation "basicapply" open_constr(R) "using" tactic3(tac) "sideconditions" tactic0(tacfin) := idtac.
+Tactic Notation "basicapply" open_constr(R) := basicapply R using (fun Hlem => idtac) sideconditions (autounfold with spred; idtac).
+(* segfault in coqtop *)
+
+
+Tactic Notation "basicapply" tactic0(tacfin) := idtac.
+
+Goal True.
+basicapply subst.
diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v
new file mode 100644
index 00000000..29ee1487
--- /dev/null
+++ b/test-suite/bugs/closed/3392.v
@@ -0,0 +1,40 @@
+(* File reduced by coq-bug-finder from original input, then from 12105 lines to 142 lines, then from 83 lines to 57 lines *)
+Generalizable All Variables.
+Axiom admit : forall {T}, T.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): transport _ p (f x) = f y := admit.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+                                               equiv_inv : B -> A ;
+                                               eisretr : Sect equiv_inv f;
+                                               eissect : Sect f equiv_inv;
+                                               eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3).
+Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g.
+Axiom isequiv_adjointify : forall {A B} (f : A -> B) (g : B -> A) (isretr : Sect g f) (issect : Sect f g), IsEquiv f.
+Definition functor_forall `{P : A -> Type} `{Q : B -> Type} (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b)
+: (forall a:A, P a) -> (forall b:B, Q b) := (fun g b => f1 _ (g (f0 b))).
+Goal forall `{P : A -> Type} `{Q : B -> Type} `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)},
+       IsEquiv (functor_forall f g).
+Proof.
+  intros.
+  refine (isequiv_adjointify (functor_forall f g)
+                             (functor_forall (f^-1)
+                                             (fun (x:A) (y:Q (f^-1 x)) => @eisretr _ _ f _ x # (g (f^-1 x))^-1 y
+                             )) _ _); 
+  intros h.
+  - abstract (
+        apply path_forall; intros b; unfold functor_forall;
+        rewrite eisadj;
+        admit
+      ).
+  - abstract (
+        apply path_forall; intros a; unfold functor_forall;
+        rewrite eissect;
+        apply apD
+      ).
+Defined.
diff --git a/test-suite/bugs/closed/3393.v b/test-suite/bugs/closed/3393.v
new file mode 100644
index 00000000..ec25e682
--- /dev/null
+++ b/test-suite/bugs/closed/3393.v
@@ -0,0 +1,152 @@
+(* -*- coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *)
+Set Universe Polymorphism.
+Axiom admit : forall {T}, T.
+Set Implicit Arguments.
+Generalizable All Variables.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "a = b" := (@paths _ a b) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
+Delimit Scope equiv_scope with equiv.
+Local Open Scope equiv_scope.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : (forall x, f x = g x) -> f = g := (@apD10 A P f g)^-1.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+    compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' where "f 'o' g" := (compose f g);
+    associativity : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), (m3 o m2) o m1 = m3 o (m2 o m1)
+  }.
+Bind Scope category_scope with PreCategory.
+Bind Scope morphism_scope with morphism.
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+Delimit Scope functor_scope with functor.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }.
+Bind Scope functor_scope with Functor.
+Notation "F '_1' m" := (@morphism_of _ _ F _ _ m) (at level 10, no associativity) : morphism_scope.
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }.
+Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope.
+Class Isomorphic {C : PreCategory} s d :=
+  { morphism_isomorphic :> morphism C s d;
+    isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }.
+Coercion morphism_isomorphic : Isomorphic >-> morphism.
+Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}.
+
+Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) : IsIsomorphism (m0 o m1).
+Admitted.
+Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.
+Definition composef C D E (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor
+       C E
+       (fun c => G (F c))
+       (fun _ _ m => @morphism_of _ _ G _ _ (@morphism_of _ _ F _ _ m)).
+Infix "o" := composef : functor_scope.
+Delimit Scope natural_transformation_scope with natural_transformation.
+
+Local Open Scope morphism_scope.
+Record NaturalTransformation C D (F G : Functor C D) :=
+  { components_of :> forall c, morphism D (F c) (G c);
+    commutes : forall s d (m : morphism C s d), components_of d o F _1 m = G _1 m o components_of s }.
+
+Definition composet C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F')
+: NaturalTransformation F F''
+  := Build_NaturalTransformation F F'' (fun c => T' c o T c) admit.
+Infix "o" := composet : natural_transformation_scope.
+Section path_natural_transformation.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+  Section path.
+    Variables T U : NaturalTransformation F G.
+    Lemma path'_natural_transformation
+    : components_of T = components_of U
+      -> T = U.
+      admit.
+    Defined.
+    Lemma path_natural_transformation
+    : (forall x, components_of T x = components_of U x)
+      -> T = U.
+    Proof.
+      intros.
+      apply path'_natural_transformation.
+      apply path_forall; assumption.
+    Qed.
+  End path.
+End path_natural_transformation.
+Ltac path_natural_transformation :=
+  repeat match goal with
+           | _ => intro
+           | _ => apply path_natural_transformation; simpl
+         end.
+
+Local Open Scope natural_transformation_scope.
+Definition associativityt `{fs : Funext}
+           C D F G H I
+           (V : @NaturalTransformation C D F G)
+           (U : @NaturalTransformation C D G H)
+           (T : @NaturalTransformation C D H I)
+: (T o U) o V = T o (U o V).
+Proof.
+  path_natural_transformation.
+  apply associativity.
+Qed.
+Definition functor_category `{Funext} (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composet C D) (@associativityt _ C D).
+Notation "C -> D" := (functor_category C D) : category_scope.
+Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic (C -> D) F G.
+Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.
+Global Instance isisomorphism_compose' `{Funext}
+       `(T' : @NaturalTransformation C D F' F'')
+       `(T : @NaturalTransformation C D F F')
+       `{@IsIsomorphism (C -> D) F' F'' T'}
+       `{@IsIsomorphism (C -> D) F F' T}
+: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation
+  := @isisomorphism_compose (C -> D) _ _ T' _ _ T _.
+Section lemmas.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable F : C -> PreCategory.
+  Context
+    {w y z}
+    {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)}
+    {f2 : Functor (F y) (F z)}
+    {f5 : Functor (F w) (F z)}
+    {n2 : f <~=~> (f2 o f0)%functor}.
+  Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' XX
+  : @IsIsomorphism
+      (F w -> F z) f5 f
+      (n2 ^-1 o XX)%natural_transformation.
+  Proof.
+    eapply isisomorphism_compose'.
+    eapply isisomorphism_inverse. (* Toplevel input, characters 22-43:
+Error:
+In environment
+H : Funext
+C : PreCategory
+F : C -> PreCategory
+w : C
+y : C
+z : C
+f : Functor (F w) (F z)
+f0 : Functor (F w) (F y)
+f2 : Functor (F y) (F z)
+f5 : Functor (F w) (F z)
+n2 : f <~=~> (f2 o f0)%functor
+XX : NaturalTransformation f5 (f2 o f0)
+Unable to unify
+ "{|
+  object := Functor (F w) (F z);
+  morphism := NaturalTransformation (D:=F z);
+  compose := composet (D:=F z);
+  associativity := associativityt (D:=F z) |}" with
+ "{|
+  object := Functor (F w) (F z);
+  morphism := NaturalTransformation (D:=F z);
+  compose := composet (D:=F z);
+  associativity := associativityt (D:=F z) |}". *)
diff --git a/test-suite/bugs/closed/3402.v b/test-suite/bugs/closed/3402.v
new file mode 100644
index 00000000..ed47ec82
--- /dev/null
+++ b/test-suite/bugs/closed/3402.v
@@ -0,0 +1,7 @@
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+Goal forall A B (p : prod A B), p = let (x, y) := p in pair A B x y.
+Proof.
+  intros A B p.
+  exact eq_refl.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3408.v b/test-suite/bugs/closed/3408.v
new file mode 100644
index 00000000..b12b8c1a
--- /dev/null
+++ b/test-suite/bugs/closed/3408.v
@@ -0,0 +1,163 @@
+Require Import BinPos.
+
+Inductive expr : Type :=
+  Var : nat -> expr
+| App : expr -> expr -> expr
+| Abs : unit -> expr -> expr.
+
+Inductive expr_acc
+: expr -> expr -> Prop :=
+  acc_App_l : forall f a : expr,
+                expr_acc f (App f a)
+| acc_App_r : forall f a : expr,
+                expr_acc a (App f a)
+| acc_Abs : forall (t : unit) (e : expr),
+              expr_acc e (Abs t e).
+
+Theorem wf_expr_acc : well_founded expr_acc.
+Proof.
+  red.
+  refine (fix rec a : Acc expr_acc a :=
+            match a as a return Acc expr_acc a with
+              | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) =>
+                                        match _H in expr_acc z Z
+                                              return match Z return Prop with
+                                                         | Var _ => Acc _ y
+                                                         | _ => True
+                                                       end
+                                        with
+                                          | acc_App_l _ _ => I
+                                          | _ => I
+                                        end)
+              | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) =>
+                                          match pf in expr_acc z Z
+                                                return match Z return Prop with
+                                                         | App a b => f = a -> x = b -> Acc expr_acc z
+                                                         | _ => True
+                                                       end
+                                          with
+                                            | acc_App_l f' x' => fun pf _ => match pf in _ = z return
+                                                                                   Acc expr_acc z
+                                                                             with
+                                                                               | eq_refl => rec f
+                                                                             end
+                                            | acc_App_r f' x' => fun _ pf => match pf in _ = z return
+                                                                                   Acc expr_acc z
+                                                                             with
+                                                                               | eq_refl => rec x
+                                                                             end
+                                            | _ => I
+                                          end eq_refl eq_refl)
+              | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) =>
+                                          match pf in expr_acc z Z
+                                                return match Z return Prop with
+                                                         | Abs a b => e = b -> Acc expr_acc z
+                                                         | _ => True
+                                                       end
+                                          with
+                                            | acc_Abs f x => fun pf => match pf in _ = z return
+                                                                             Acc expr_acc z
+                                                                       with
+                                                                         | eq_refl => rec e
+                                                                       end
+                                            | _ => I
+                                          end eq_refl)
+            end).
+Defined.
+
+Theorem wf_expr_acc_delay : well_founded expr_acc.
+Proof.
+  red.
+  refine (fix rec a : Acc expr_acc a :=
+            match a as a return Acc expr_acc a with
+              | Var v => Acc_intro _ (fun y (_H : expr_acc y (Var v)) =>
+                                        match _H in expr_acc z Z
+                                              return match Z return Prop with
+                                                         | Var _ => Acc _ y
+                                                         | _ => True
+                                                       end
+                                        with
+                                          | acc_App_l _ _ => I
+                                          | _ => I
+                                        end)
+              | App f x => Acc_intro _ (fun y (pf : expr_acc y (App f x)) =>
+                                          match pf in expr_acc z Z
+                                                return match Z return Prop with
+                                                         | App a b => (unit -> Acc expr_acc a) -> (unit -> Acc expr_acc b) -> Acc expr_acc z
+                                                         | _ => True
+                                                       end
+                                          with
+                                            | acc_App_l f' x' => fun pf _ => pf tt
+                                            | acc_App_r f' x' => fun _ pf => pf tt
+                                            | _ => I
+                                          end (fun _ => rec f) (fun _ => rec x))
+              | Abs t e => Acc_intro _ (fun y (pf : expr_acc y (Abs t e)) =>
+                                          match pf in expr_acc z Z
+                                                return match Z return Prop with
+                                                         | Abs a b => (unit -> Acc expr_acc b) -> Acc expr_acc z
+                                                         | _ => True
+                                                       end
+                                          with
+                                            | acc_Abs f x => fun pf => pf tt
+                                            | _ => I
+                                          end (fun _ => rec e))
+            end); 
+    try solve [ inversion _H ].
+Defined.
+
+Fixpoint build_large (n : nat) : expr :=
+  match n with
+    | 0 => Var 0
+    | S n =>
+      let e := build_large n in
+      App e e
+  end.
+
+Section guard.
+  Context {A : Type} {R : A -> A -> Prop}.
+
+  Fixpoint guard  (n : nat) (wfR : well_founded R) : well_founded R :=
+    match n with
+      | 0 => wfR
+      | S n0 =>
+        fun x : A =>
+          Acc_intro x
+                    (fun (y : A) (_ : R y x) => guard n0 (guard n0 wfR) y)
+    end.
+End guard.
+
+
+Definition sizeF_delay : expr -> positive.
+refine
+  (@Fix expr (expr_acc)
+       (wf_expr_acc_delay)
+       (fun _ => positive)
+       (fun e =>
+          match e as e return (forall l, expr_acc l e -> positive) -> positive with
+            | Var _ => fun _ => 1
+            | App l r => fun rec => @rec l _ + @rec r _
+            | Abs _ e => fun rec => 1 + @rec e _
+          end%positive)).
+eapply acc_App_l.
+eapply acc_App_r.
+eapply acc_Abs.
+Defined.
+
+Definition sizeF_guard : expr -> positive.
+refine
+  (@Fix expr (expr_acc)
+       (guard 5 wf_expr_acc)
+       (fun _ => positive)
+       (fun e =>
+          match e as e return (forall l, expr_acc l e -> positive) -> positive with
+            | Var _ => fun _ => 1
+            | App l r => fun rec => @rec l _ + @rec r _
+            | Abs _ e => fun rec => 1 + @rec e _
+          end%positive)).
+eapply acc_App_l.
+eapply acc_App_r.
+eapply acc_Abs.
+Defined.
+
+Time Eval native_compute in sizeF_delay (build_large 2).
+Time Eval native_compute in sizeF_guard (build_large 2).
diff --git a/test-suite/bugs/closed/3416.v b/test-suite/bugs/closed/3416.v
new file mode 100644
index 00000000..5cfb8f1f
--- /dev/null
+++ b/test-suite/bugs/closed/3416.v
@@ -0,0 +1,12 @@
+Inductive list A := Node : node A -> list A
+with node A := Nil | Cons : A -> list A -> node A.
+
+Fixpoint app {A} (l1 l2 : list A) {struct l1} : list A
+with app_node {A} (n1 : node A) (l2 : list A) {struct n1} : node A.
+Proof.
++ destruct l1 as [n]; constructor.
+  exact (app_node _ n l2).
++ destruct n1 as [|x l1].
+  - destruct l2 as [n2]; exact n2.
+  - exact (Cons _ x (app _ l1 l2)).
+Qed.
diff --git a/test-suite/bugs/closed/3417.v b/test-suite/bugs/closed/3417.v
new file mode 100644
index 00000000..9d7c6f01
--- /dev/null
+++ b/test-suite/bugs/closed/3417.v
@@ -0,0 +1,7 @@
+Require Setoid.
+
+Goal forall {T}(a b : T), b=a -> {c | c=b}.
+Proof.
+intros T a b H.
+try setoid_rewrite H.
+Abort.
diff --git a/test-suite/bugs/closed/3422.v b/test-suite/bugs/closed/3422.v
new file mode 100644
index 00000000..d984f623
--- /dev/null
+++ b/test-suite/bugs/closed/3422.v
@@ -0,0 +1,208 @@
+Generalizable All Variables.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Axiom admit : forall {T}, T.
+Reserved Infix "o" (at level 40, left associativity).
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Existing Instance equiv_isequiv.
+Delimit Scope equiv_scope with equiv.
+Local Open Scope equiv_scope.
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+Axiom IsHSet : Type -> Type.
+Existing Class IsHSet.
+Definition trunc_equiv' `(f : A <~> B) `{IsHSet A} : IsHSet B := admit.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+
+    compose : forall s d d',
+                morphism d d'
+                -> morphism s d
+                -> morphism s d'
+                            where "f 'o' g" := (compose f g);
+
+    trunc_morphism : forall s d, IsHSet (morphism s d) }.
+
+Bind Scope category_scope with PreCategory.
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+
+Delimit Scope functor_scope with functor.
+
+Record Functor (C D : PreCategory) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d)
+  }.
+
+Bind Scope functor_scope with Functor.
+Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+Local Open Scope morphism_scope.
+
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }.
+
+Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope.
+
+Class Isomorphic {C : PreCategory} s d :=
+  {
+    morphism_isomorphic :> morphism C s d;
+    isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic
+  }.
+
+Coercion morphism_isomorphic : Isomorphic >-> morphism.
+
+Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.
+
+Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}.
+
+Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1)
+: IsIsomorphism (m0 o m1).
+admit.
+Defined.
+
+Section composition.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable E : PreCategory.
+  Variable G : Functor D E.
+  Variable F : Functor C D.
+
+  Definition composeF : Functor C E
+    := Build_Functor
+         C E
+         (fun c => G (F c))
+         (fun _ _ m => morphism_of G (morphism_of F m)).
+End composition.
+Infix "o" := composeF : functor_scope.
+
+Delimit Scope natural_transformation_scope with natural_transformation.
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+
+Section compose.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F F' F'' : Functor C D.
+
+  Variable T' : NaturalTransformation F' F''.
+  Variable T : NaturalTransformation F F'.
+
+  Local Notation CO c := (T' c o T c).
+
+  Definition composeT
+  : NaturalTransformation F F'' := Build_NaturalTransformation F F'' (fun c => CO c).
+
+End compose.
+
+Section whisker.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable E : PreCategory.
+
+  Section L.
+    Variable F : Functor D E.
+    Variables G G' : Functor C D.
+    Variable T : NaturalTransformation G G'.
+
+    Local Notation CO c := (morphism_of F (T c)).
+
+    Definition whisker_l
+      := Build_NaturalTransformation
+           (F o G) (F o G')
+           (fun c => CO c).
+
+  End L.
+
+  Section R.
+    Variables F F' : Functor D E.
+    Variable T : NaturalTransformation F F'.
+    Variable G : Functor C D.
+
+    Local Notation CO c := (T (G c)).
+
+    Definition whisker_r
+      := Build_NaturalTransformation
+           (F o G) (F' o G)
+           (fun c => CO c).
+  End R.
+End whisker.
+Infix "o" := composeT : natural_transformation_scope.
+Infix "oL" := whisker_l (at level 40, left associativity) : natural_transformation_scope.
+Infix "oR" := whisker_r (at level 40, left associativity) : natural_transformation_scope.
+
+Section path_natural_transformation.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+
+  Lemma equiv_sig_natural_transformation
+  : { CO : forall x, morphism D (F x) (G x)
+    | forall s d (m : morphism C s d),
+        CO d o F _1 m = G _1 m o CO s }
+      <~> NaturalTransformation F G.
+    admit.
+  Defined.
+
+  Global Instance trunc_natural_transformation
+  : IsHSet (NaturalTransformation F G).
+  Proof.
+    eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ].
+    admit.
+  Qed.
+
+End path_natural_transformation.
+Definition functor_category (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composeT C D) _.
+
+Notation "C -> D" := (functor_category C D) : category_scope.
+
+Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic (C -> D) F G.
+
+Coercion natural_transformation_of_natural_isomorphism C D F G (T : @NaturalIsomorphism C D F G) : NaturalTransformation F G
+  := T : morphism _ _ _.
+Local Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.
+Global Instance isisomorphism_compose'
+       `(T' : @NaturalTransformation C D F' F'')
+       `(T : @NaturalTransformation C D F F')
+       `{@IsIsomorphism (C -> D) F' F'' T'}
+       `{@IsIsomorphism (C -> D) F F' T}
+: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation
+  := @isisomorphism_compose (C -> D) _ _ T' _ _ T _.
+
+Section lemmas.
+  Local Open Scope natural_transformation_scope.
+
+  Variable C : PreCategory.
+  Variable F : C -> PreCategory.
+  Context
+    {w x y z}
+    {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)}
+    {f1 : Functor (F x) (F y)} {f2 : Functor (F y) (F z)}
+    {f3 : Functor (F w) (F x)} {f4 : Functor (F x) (F z)}
+    {f5 : Functor (F w) (F z)} {n : f5 <~=~> (f4 o f3)%functor}
+    {n0 : f4 <~=~> (f2 o f1)%functor} {n1 : f0 <~=~> (f1 o f3)%functor}
+    {n2 : f <~=~> (f2 o f0)%functor}.
+
+  Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper'
+  : @IsIsomorphism
+      (_ -> _) _ _
+      (n2 ^-1 o (f2 oL n1 ^-1 o (admit o (n0 oR f3 o n))))%natural_transformation.
+  Proof.
+    eapply isisomorphism_compose';
+    [ eapply isisomorphism_inverse
+    | eapply isisomorphism_compose';
+      [ admit
+      | eapply isisomorphism_compose';
+        [ admit |
+          eapply isisomorphism_compose'; [ admit | ]]]].
+    Set Printing All. Set Printing Universes.
+    apply @isisomorphism_isomorphic.
+  Qed.
+
+End lemmas.
diff --git a/test-suite/bugs/closed/3424.v b/test-suite/bugs/closed/3424.v
new file mode 100644
index 00000000..f9b2c386
--- /dev/null
+++ b/test-suite/bugs/closed/3424.v
@@ -0,0 +1,23 @@
+Set Universe Polymorphism.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Class Contr_internal (A : Type) := BuildContr { center : A ; contr : (forall y : A, center = y) }.
+Inductive trunc_index : Type := minus_two | trunc_S (x : trunc_index).
+Bind Scope trunc_scope with trunc_index.
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+Notation minus_one:=(trunc_S minus_two).
+Notation "0" := (trunc_S minus_one) : trunc_scope.
+Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A.
+Notation IsHProp := (IsTrunc minus_one).
+Notation IsHSet := (IsTrunc 0).
+Goal forall (A : Type) (a b : A) (H' : IsHSet A), { x : Type & IsHProp x }.
+Proof.
+intros.
+eexists.
+(* exact (H' a b). *)
+(* Undo. *)
+apply (H' a b).
+Qed.
diff --git a/test-suite/bugs/closed/3427.v b/test-suite/bugs/closed/3427.v
new file mode 100644
index 00000000..8483a4ec
--- /dev/null
+++ b/test-suite/bugs/closed/3427.v
@@ -0,0 +1,195 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 0 lines to 7171 lines, then from 7184 lines to 558 lines, then from 556 lines to 209 lines *)
+Generalizable All Variables.
+Set Universe Polymorphism.
+Notation Type0 := Set.
+Notation idmap := (fun x => x).
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Delimit Scope path_scope with path.
+Local Open Scope path_scope.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
+Notation "1" := idpath : path_scope.
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+Notation "p ^" := (inverse p) (at level 3) : path_scope.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A, f x = g x.
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+                                               equiv_inv : B -> A ;
+                                               eisretr : Sect equiv_inv f;
+                                               eissect : Sect f equiv_inv;
+                                               eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+                                             }.
+Record Equiv A B := BuildEquiv {
+                        equiv_fun :> A -> B ;
+                        equiv_isequiv :> IsEquiv equiv_fun
+                      }.
+
+Delimit Scope equiv_scope with equiv.
+
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+
+Class Contr_internal (A : Type) := BuildContr {
+                                       center : A ;
+                                       contr : (forall y : A, center = y)
+                                     }.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint nat_to_trunc_index (n : nat) : trunc_index
+  := match n with
+       | 0 => trunc_S (trunc_S minus_two)
+       | S n' => trunc_S (nat_to_trunc_index n')
+     end.
+
+Coercion nat_to_trunc_index : nat >-> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Notation minus_one:=(trunc_S minus_two).
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation Contr := (IsTrunc minus_two).
+Notation IsHProp := (IsTrunc minus_one).
+Notation IsHSet := (IsTrunc 0).
+
+Class Funext :=
+  { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+
+Definition concat_pV {A : Type} {x y : A} (p : x = y) :
+  p @ p^ = 1
+  :=
+    match p with idpath => 1 end.
+
+Definition concat_Vp {A : Type} {x y : A} (p : x = y) :
+  p^ @ p = 1
+  :=
+    match p with idpath => 1 end.
+
+Definition transport_pp {A : Type} (P : A -> Type) {x y z : A} (p : x = y) (q : y = z) (u : P x) :
+  p @ q # u = q # p # u :=
+  match q with idpath =>
+               match p with idpath => 1 end
+  end.
+
+Definition transport2 {A : Type} (P : A -> Type) {x y : A} {p q : x = y}
+           (r : p = q) (z : P x)
+: p # z = q # z
+  := ap (fun p' => p' # z) r.
+
+Inductive Unit : Type0 :=
+  tt : Unit.
+
+Instance contr_unit : Contr Unit | 0 := let x := {|
+                                              center := tt;
+                                              contr := fun t : Unit => match t with tt => 1 end
+                                            |} in x.
+
+Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000.
+admit.
+Defined.
+
+Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}.
+Definition Unit_hp:hProp:=(hp Unit _).
+
+Global Instance isequiv_ap_hproptype `{Funext} X Y : IsEquiv (@ap _ _ hproptype X Y).
+admit.
+Defined.
+
+Definition path_hprop `{Funext} X Y := (@ap _ _ hproptype X Y)^-1%equiv.
+
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Local Open Scope equiv_scope.
+
+Instance isequiv_path {A B : Type} (p : A = B)
+: IsEquiv (transport (fun X:Type => X) p) | 0
+  := BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^)
+                  (fun b => ((transport_pp idmap p^ p b)^ @ transport2 idmap (concat_Vp p) b))
+                  (fun a => ((transport_pp idmap p p^ a)^ @ transport2 idmap (concat_pV p) a))
+                  (fun a => match p in _ = C return
+                                  (transport_pp idmap p^ p (transport idmap p a))^ @
+                                                                                     transport2 idmap (concat_Vp p) (transport idmap p a) =
+                                  ap (transport idmap p) ((transport_pp idmap p p^ a) ^ @
+                                                                                          transport2 idmap (concat_pV p) a) with idpath => 1 end).
+
+Definition equiv_path (A B : Type) (p : A = B) : A <~> B
+  := BuildEquiv _ _ (transport (fun X:Type => X) p) _.
+
+Class Univalence := {
+                     isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B)
+                   }.
+
+Section Univalence.
+  Context `{Univalence}.
+
+  Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B
+    := (equiv_path A B)^-1 f.
+End Univalence.
+
+Local Inductive minus1Trunc (A :Type) : Type :=
+  min1 : A -> minus1Trunc A.
+
+Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0.
+admit.
+Defined.
+
+Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT  P).
+
+Section AssumingUA.
+
+  Definition isepi {X Y} `(f:X->Y) := forall Z: hSet,
+                                      forall g h: Y -> Z, g o f = h o f -> g = h.
+  Context {X Y : hSet} (f : X -> Y) (Hisepi : isepi f).
+
+  Goal forall (X Y : hSet) (f : forall _ : setT X, setT Y),
+         let fib :=
+             fun y : setT Y =>
+               hp (@hexists (setT X) (fun x : setT X => @paths (setT Y) (f x) y))
+                  (@minus1Trunc_is_prop
+                     (@sigT (setT X) (fun x : setT X => @paths (setT Y) (f x) y))) in
+         forall (x : setT X) (_ : Univalence) (_ : Funext),
+           @paths hProp (fib (f x)) Unit_hp.
+  intros.
+
+  apply path_hprop.
+  simpl.
+  Set Printing Universes.
+  Set Printing All.
+  refine (path_universe_uncurried _).
+  Undo.
+  apply path_universe_uncurried. (* Toplevel input, characters 21-44:
+Error: Refiner was given an argument
+ "@path_universe_uncurried (* Top.425 Top.426 Top.427 Top.428 Top.429 *) X1
+    (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0)
+       (fun x0 : setT (* Top.405 *) X0 =>
+        @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit
+    ?63" of type
+ "@paths (* Top.428 *) Type (* Top.425 *)
+    (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0)
+       (fun x0 : setT (* Top.405 *) X0 =>
+        @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit"
+instead of
+ "@paths (* Top.413 *) Type (* Set *)
+    (@hexists (* Top.405 Top.404 Set Set *) (setT (* Top.405 *) X0)
+       (fun x0 : setT (* Top.405 *) X0 =>
+        @paths (* Top.404 *) (setT (* Top.404 *) Y0) (f0 x0) (f0 x))) Unit".
+ *)
diff --git a/test-suite/bugs/closed/3428.v b/test-suite/bugs/closed/3428.v
new file mode 100644
index 00000000..3eb75e43
--- /dev/null
+++ b/test-suite/bugs/closed/3428.v
@@ -0,0 +1,35 @@
+(* File reduced by coq-bug-finder from original input, then from 2809 lines to 39 lines *)
+Set Primitive Projections.
+Set Implicit Arguments. 
+Module Export foo.
+  Record prod (A B : Type) := pair { fst : A ; snd : B }.
+End foo.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Axiom path_prod : forall {A B : Type} (z z' : prod A B), (fst z = fst z') -> (snd z = snd z') -> (z = z').
+Notation fst := (@fst _ _).
+Notation snd := (@snd _ _).
+Definition ap_fst_path_prod {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z')
+: ap fst (path_prod z z' p q) = p.
+Abort.
+
+Notation fstp x := (x.(foo.fst)).
+Notation fstap x := (foo.fst x).
+
+Definition ap_fst_path_prod' {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z')
+: ap (fun x => fstap x) (path_prod z z' p q) = p.
+
+Abort.
+
+(* Toplevel input, characters 137-138:
+Error:
+In environment
+A : Type
+B : Type
+z : prod A B
+z' : prod A B
+p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')
+q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z')
+The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')"
+while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v
new file mode 100644
index 00000000..bba6140f
--- /dev/null
+++ b/test-suite/bugs/closed/3439.v
@@ -0,0 +1,43 @@
+(* File reduced by coq-bug-finder from original input, then from 3154 lines to 149 lines, then from 89 lines to 55 lines, then from 44 lines to 20 lines *)
+Set Primitive Projections.
+Generalizable All Variables.
+Axiom IsHSet : Type -> Type.
+Existing Class IsHSet.
+Record PreCategory := { object :> Type }.
+Notation IsStrictCategory C := (IsHSet (object C)).
+Instance trunc_prod `{IsHSet A} `{IsHSet B} : IsHSet (A * B) | 100.
+admit.
+Defined.
+Typeclasses Transparent object.
+Definition prod (C D : PreCategory) : PreCategory := Build_PreCategory (Datatypes.prod C D).
+Global Instance isstrict_category_product `{IsStrictCategory C, IsStrictCategory D} : IsStrictCategory (prod C D).
+Proof.
+  typeclasses eauto.
+Defined.
+
+
+Set Typeclasses Debug.
+(* File reduced by coq-bug-finder from original input, then from 7425 lines to 154 lines, then from 116 lines to 20 lines *)
+Class Contr (A : Type) := { center : A }.
+Instance contr_unit : Contr unit | 0 := {| center := tt |}.
+Module non_prim.
+  Unset Primitive Projections.
+  Record PreCategory := { object :> Type }.
+  Lemma foo : Contr (object (@Build_PreCategory unit)).
+  Proof.
+    solve [ simpl; typeclasses eauto ] || fail "goal not solved".
+    Undo.
+    solve [ typeclasses eauto ].
+  Defined.
+End non_prim.
+
+Module prim.
+  Set Primitive Projections.
+  Record PreCategory := { object :> Type }.
+  Lemma foo : Contr (object (@Build_PreCategory unit)).
+  Proof.
+    solve [ simpl; typeclasses eauto ] || fail "goal not solved".
+    Undo.
+    solve [ typeclasses eauto ]. (*  Error: No applicable tactic. *)
+  Defined.
+End prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3453.v b/test-suite/bugs/closed/3453.v
new file mode 100644
index 00000000..4ee9b400
--- /dev/null
+++ b/test-suite/bugs/closed/3453.v
@@ -0,0 +1,10 @@
+Set Primitive Projections.
+Record Foo := { bar : Set }.
+Class Baz (F : Foo) := { qux : F.(bar) }.
+Coercion qux : Baz >-> bar.
+
+Definition f : Foo := {| bar := nat |}.
+Canonical Structure f.
+Check (fun b : Baz f => b : _.(bar)).
+
+(* Error: Found target class bar instead of bar. *)
diff --git a/test-suite/bugs/closed/3454.v b/test-suite/bugs/closed/3454.v
new file mode 100644
index 00000000..ca4d2380
--- /dev/null
+++ b/test-suite/bugs/closed/3454.v
@@ -0,0 +1,63 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+
+Record prod {A} {B}:= pair { fst : A ; snd : B }.
+Notation " A * B " := (@prod A B) : type_scope.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Notation pr1 := (@projT1 _ _).
+Arguments prod : clear implicits.
+
+Check (@projT1 _ (fun x : nat => x = x)).
+Check (fun s : @sigT nat (fun x : nat => x = x) => s.(projT1)).
+
+Record rimpl {b : bool} {n : nat} := { foo : forall {x : nat}, x = n }. 
+
+Check (fun r : @rimpl true 0 => r.(foo) (x:=0)).
+Check (fun r : @rimpl true 0 => @foo true 0 r 0).
+Check (fun r : @rimpl true 0 => foo r (x:=0)).
+Check (fun r : @rimpl true 0 => @foo _ _ r 0).
+Check (fun r : @rimpl true 0 => r.(@foo _ _)).
+Check (fun r : @rimpl true 0 => r.(foo)).
+
+Notation "{ x : T  & P }" := (@sigT T P).
+Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
+(* Notation "{ x : T * U  & P }" := (@sigT (T * U) P). *)
+
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Class IsEquiv {A B : Type} (f : A -> B) := {}.
+
+Local Instance isequiv_tgt_compose A B
+: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
+           (A -> B)
+           (@compose A {xy : B * B & fst xy = snd xy} B
+                     (@compose {xy : B * B & fst xy = snd xy} _ B (@snd B B) pr1)).
+(* Toplevel input, characters 220-223: *)
+(* Error: Cannot infer this placeholder. *)
+
+Local Instance isequiv_tgt_compose' A B
+: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
+           (A -> B)
+           (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) pr1)).
+(* Toplevel input, characters 221-232: *)
+(* Error: *)
+(* In environment *)
+(* A : Type *)
+(* B : Type *)
+(* The term "pr1" has type "sigT ?30 -> ?29" while it is expected to have type *)
+(*  "{xy : B * B & fst xy = snd xy} -> ?27 * B". *)
+
+Local Instance isequiv_tgt_compose'' A B
+: @IsEquiv (A -> {xy : B * B & fst xy = snd xy})
+           (A -> B)
+           (@compose A {xy : B * B & fst xy = snd xy} B (@compose {xy : B * B & fst xy = snd xy} _ B (@snd _ _) 
+                                                                  (fun s => s.(projT1)))).
+(* Toplevel input, characters 15-241:
+Error:
+Cannot infer an internal placeholder of type "Type" in environment:
+
+A : Type
+B : Type
+x : ?32
+. *)
diff --git a/test-suite/bugs/closed/3469.v b/test-suite/bugs/closed/3469.v
new file mode 100644
index 00000000..b09edc65
--- /dev/null
+++ b/test-suite/bugs/closed/3469.v
@@ -0,0 +1,29 @@
+(* File reduced by coq-bug-finder from original input, then from 538 lines to 31 lines *)
+Open Scope type_scope.
+Global Set Primitive Projections.
+Set Implicit Arguments.
+Record sig (A : Type) (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }.
+Notation sigT := sig (only parsing).
+Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
+Notation projT1 := proj1_sig (only parsing).
+Notation projT2 := proj2_sig (only parsing).
+Variables X : Type.
+Variable R : X -> X -> Type.
+Lemma dependent_choice :
+  (forall x:X, {y : _ & R x y}) ->
+  forall x0, {f : nat -> X & (f O = x0) * (forall n, R (f n) (f (S n)))}.
+Proof.
+  intros H x0.
+  set (f:=fix f n := match n with O => x0 | S n' => projT1 (H (f n')) end).
+  exists f.
+  split.
+  reflexivity.
+  induction n; simpl in *.
+  clear.
+  apply (proj2_sig (H x0)).
+  Undo.
+  apply @proj2_sig. 
+  
+
+(* Toplevel input, characters 21-31:
+Error: Found no subterm matching "proj1_sig ?206" in the current *)
diff --git a/test-suite/bugs/closed/3477.v b/test-suite/bugs/closed/3477.v
new file mode 100644
index 00000000..e9414864
--- /dev/null
+++ b/test-suite/bugs/closed/3477.v
@@ -0,0 +1,9 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod A B := pair { fst : A ; snd : B }.
+Goal forall A B : Set, True.
+Proof.
+  intros A B.
+  evar (a : prod A B); evar (f : (prod A B -> Set)).
+  let a' := (eval unfold a in a) in
+  set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))).
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/348.v b/test-suite/bugs/closed/348.v
index 28cc5cb1..28cc5cb1 100644
--- a/test-suite/bugs/closed/shouldsucceed/348.v
+++ b/test-suite/bugs/closed/348.v
diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v
new file mode 100644
index 00000000..99ac2efa
--- /dev/null
+++ b/test-suite/bugs/closed/3480.v
@@ -0,0 +1,47 @@
+Set Primitive Projections.
+Axiom admit : forall {T}, T.
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation "x .1" := (projT1 x) (at level 3) : fibration_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Set Implicit Arguments.
+Delimit Scope category_scope with category.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Local Open Scope category_scope.
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }.
+Class Isomorphic {C : PreCategory} s d := { morphism_isomorphic :> @morphism C s d ; isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }.
+Coercion morphism_isomorphic : Isomorphic >-> morphism.
+Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.
+Definition idtoiso (C : PreCategory) (x y : C) (H : x = y) : Isomorphic x y := admit.
+Record NotionOfStructure (X : PreCategory) := { structure :> X -> Type }.
+Record Smorphism (X : PreCategory) (P : NotionOfStructure X) (xa yb : { x : X & P x }) := { f : morphism X xa.1 yb.1 }.
+Definition precategory_of_structures X (P : NotionOfStructure X) : PreCategory.
+Proof.
+  refine (@Build_PreCategory _ (@Smorphism _ P)).
+Defined.
+Section sip.
+  Variable X : PreCategory.
+  Variable P : NotionOfStructure X.
+
+  Let StrX := @precategory_of_structures X P.
+
+  Definition sip_isotoid (xa yb : StrX) (f : xa <~=~> yb) : xa = yb.
+    admit.
+  Defined.
+
+  Lemma structure_identity_principle_helper (xa yb : StrX)
+        (x : xa <~=~> yb) : Smorphism P xa yb.
+  Proof.
+    refine ((idtoiso (precategory_of_structures P) (sip_isotoid x) : @morphism _ _ _) : morphism _ _ _).
+(* Toplevel input, characters 24-95:
+Error:
+In environment
+X : PreCategory
+P : NotionOfStructure X
+StrX := precategory_of_structures P : PreCategory
+xa : object StrX
+yb : object StrX
+x : xa <~=~> yb
+The term "morphism_isomorphic:@morphism (precategory_of_structures P) xa yb"
+has type "@morphism (precategory_of_structures P) xa yb"
+while it is expected to have type "morphism ?40 ?41 ?42". *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3481.v b/test-suite/bugs/closed/3481.v
new file mode 100644
index 00000000..89d476dc
--- /dev/null
+++ b/test-suite/bugs/closed/3481.v
@@ -0,0 +1,70 @@
+
+Set Implicit Arguments.
+
+Require Import Logic.
+Module NonPrim.
+Local Set Record Elimination Schemes.
+Record prodwithlet (A B : Type) : Type :=
+  pair' { fst : A; fst' := fst; snd : B }.
+
+Definition letreclet (p : prodwithlet nat nat) :=
+  let (x, x', y) := p in x + y.
+
+Definition pletreclet (p : prodwithlet nat nat) :=
+  let 'pair' x x' y := p in x + y + x'.
+
+Definition pletreclet2 (p : prodwithlet nat nat) :=
+  let 'pair' x y := p in x + y.
+
+Check (pair 0 0).
+End NonPrim.
+
+Global Set Universe Polymorphism.
+Global Set Asymmetric Patterns.
+Local Set Record Elimination Schemes.
+Local Set Primitive Projections.
+
+Record prod (A B : Type) : Type :=
+  pair { fst : A; snd : B }.
+
+Print prod_rect.
+
+(* What I really want: *)
+Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd))
+           (p : prod A B) : P p
+  := u (fst p) (snd p).
+
+Definition conv : @prod_rect = @prod_rect'.
+Proof. reflexivity. Defined.
+
+Definition imposs :=
+  (fun A B P f (p : prod A B) => match p as p0 return P p0 with
+                                   | {| fst := x ; snd := x0 |} => f x x0
+                                 end).
+
+Definition letrec (p : prod nat nat) :=
+  let (x, y) := p in x + y.
+Eval compute in letrec (pair 1 5).
+
+Goal forall p : prod nat nat, letrec p = fst p + snd p.
+Proof.
+  reflexivity.
+  Undo.
+  intros p.
+  case p. simpl. unfold letrec. simpl. reflexivity.
+Defined.
+
+Eval compute in conv. (* = eq_refl
+     : prod_rect = prod_rect' *)
+
+Check eq_refl : @prod_rect = @prod_rect'. (* Toplevel input, characters 6-13:
+Error:
+The term "eq_refl" has type "prod_rect = prod_rect"
+while it is expected to have type "prod_rect = prod_rect'"
+(cannot unify "prod_rect" and "prod_rect'"). *)
+
+Record sigma (A : Type) (B : A -> Type) : Type :=
+  dpair { pi1 : A ; pi2 : B pi1 }.
+
+
+
diff --git a/test-suite/bugs/closed/3482.v b/test-suite/bugs/closed/3482.v
new file mode 100644
index 00000000..34a5e73d
--- /dev/null
+++ b/test-suite/bugs/closed/3482.v
@@ -0,0 +1,11 @@
+Set Primitive Projections.
+Class Foo (F : False) := { foo : True }.
+Arguments foo F {Foo}.
+Print Implicit foo. (* foo : forall F : False, Foo F -> True
+
+Argument Foo is implicit and maximally inserted *)
+Check foo _. (* Toplevel input, characters 6-11:
+Error: Illegal application (Non-functional construction):
+The expression "foo" of type "True"
+cannot be applied to the term
+ "?36" : "?35" *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3483.v b/test-suite/bugs/closed/3483.v
new file mode 100644
index 00000000..2cc66186
--- /dev/null
+++ b/test-suite/bugs/closed/3483.v
@@ -0,0 +1,5 @@
+(* Check proper failing when using notation of non-constructors in
+   pattern-bmatching *)
+
+Fail Definition nonsense ( x : False ) := match x with y + 2 => 0 end.
+
diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v
new file mode 100644
index 00000000..6c40a426
--- /dev/null
+++ b/test-suite/bugs/closed/3484.v
@@ -0,0 +1,30 @@
+(* File reduced by coq-bug-finder from original input, then from 14259 lines to 305 lines, then from 237 lines to 120 lines, then from 100 lines to 30 lines *)
+Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT (A : Type) (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Notation "{ x : A & P }" := (@sigT A (fun x : A => P)) : type_scope.
+Notation pr1 := (@projT1 _ _).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Goal forall (T : Type) (H :  { g : T & g = g }) (x : T), projT1 H = projT1 (existT (fun g : T => g = g) x idpath).
+Proof.
+  intros.
+  let y := match goal with |- projT1 ?x = projT1 ?y => constr:(y) end in
+  apply (@ap _ _ pr1 _ y).
+  Undo.
+  Unset Printing Notations.
+  apply (ap pr1). 
+  Undo.
+  refine (ap pr1 _).
+admit. 
+Defined.
+
+(* Toplevel input, characters 22-28:
+Error:
+In environment
+T : Type
+H : sigT T (fun g : T => paths g g)
+x : T
+Unable to unify "paths (@projT1 ?24 ?23 ?25) (@projT1 ?24 ?23 ?26)" with
+ "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3485.v b/test-suite/bugs/closed/3485.v
new file mode 100644
index 00000000..ede6b3cb
--- /dev/null
+++ b/test-suite/bugs/closed/3485.v
@@ -0,0 +1,133 @@
+Set Universe Polymorphism.
+Set Primitive Projections.
+Reserved Infix "o" (at level 40, left associativity).
+Definition relation (A : Type) := A -> A -> Type.
+Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z.
+Tactic Notation "etransitivity" open_constr(y) :=
+  let R := match goal with |- ?R ?x ?z => constr:(R) end in
+  let x := match goal with |- ?R ?x ?z => constr:(x) end in
+  let z := match goal with |- ?R ?x ?z => constr:(z) end in
+  refine (@transitivity _ R _ x y z _ _).
+Tactic Notation "etransitivity" := etransitivity _.
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation "x .1" := (projT1 x) (at level 3) : fibration_scope.
+Notation "x .2" := (projT2 x) (at level 3) : fibration_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
+Instance transitive_paths {A} : Transitive (@paths A) | 0 := @concat A.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
+Generalizable Variables X A B C f g n.
+Definition projT1_path `{P : A -> Type} {u v : sigT P} (p : u = v) : u.1 = v.1 := ap (@projT1 _ _) p.
+Notation "p ..1" := (projT1_path p) (at level 3) : fibration_scope.
+Ltac simpl_do_clear tac term :=
+  let H := fresh in
+  assert (H := term);
+    simpl in H |- *;
+    tac H;
+    clear H.
+Set Implicit Arguments.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+
+    identity : forall x, morphism x x;
+    compose : forall s d d',
+                morphism d d'
+                -> morphism s d
+                -> morphism s d'
+                            where "f 'o' g" := (compose f g);
+
+    left_identity : forall a b (f : morphism a b), identity b o f = f;
+    right_identity : forall a b (f : morphism a b), f o identity a = f }.
+Arguments identity {C%category} / x%object : rename.
+Arguments compose {C%category} / {s d d'}%object (m1 m2)%morphism : rename.
+Infix "o" := compose : morphism_scope.
+Notation "1" := (identity _) : morphism_scope.
+Delimit Scope functor_scope with functor.
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d);
+    identity_of : forall x, morphism_of _ _ (identity x)
+                            = identity (object_of x) }.
+Bind Scope functor_scope with Functor.
+Arguments morphism_of [C%category] [D%category] F%functor / [s%object d%object] m%morphism : rename.
+Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+Section composition.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable E : PreCategory.
+  Variable G : Functor D E.
+  Variable F : Functor C D.
+
+  Local Notation c_object_of c := (G (F c)) (only parsing).
+  Local Notation c_morphism_of m := (morphism_of G (morphism_of F m)) (only parsing).
+
+  Definition compose_identity_of x
+  : c_morphism_of (identity x) = identity (c_object_of x)
+    := transport (@paths _ _)
+                 (identity_of G _)
+                 (ap (@morphism_of _ _ G _ _) (identity_of F x)).
+
+  Definition composeF : Functor C E
+    := Build_Functor
+         C E
+         (fun c => G (F c))
+         (fun _ _ m => morphism_of G (morphism_of F m))
+         compose_identity_of.
+End composition.
+Infix "o" := composeF : functor_scope.
+
+Definition identityF C : Functor C C
+  := Build_Functor C C
+                   (fun x => x)
+                   (fun _ _ x => x)
+                   (fun _ => idpath).
+Notation "1" := (identityF _) : functor_scope.
+
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+
+Section unit.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variable F : Functor C D.
+  Variable G : Functor D C.
+
+  Definition AdjunctionUnit :=
+    { T : NaturalTransformation 1 (G o F)
+                                & forall (c : C) (d : D) (f : morphism C c (G d)),
+                                    Contr_internal { g : morphism D (F c) d & G _1 g o T c = f }
+    }.
+End unit.
+Variable C : PreCategory.
+Variable D : PreCategory.
+Variable F : Functor C D.
+Variable G : Functor D C.
+
+Definition zig__of__adjunction_unit
+           (A : AdjunctionUnit F G)
+           (Y : C)
+           (eta := A.1)
+           (eps := fun X => (@center _ (A.2 (G X) X 1)).1)
+: G _1 (eps (F Y) o F _1 (eta Y)) o eta Y = eta Y
+  -> eps (F Y) o F _1 (eta Y) = 1.
+Proof.
+  intros.
+  etransitivity; [ symmetry | ];
+  simpl_do_clear
+    ltac:(fun H => apply H)
+           (fun y H => (@contr _ (A.2 _ _ (A.1 Y)) (y; H))..1);
+  try assumption.
+  simpl.
+  rewrite ?@identity_of, ?@left_identity, ?@right_identity;
+    reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v
new file mode 100644
index 00000000..03c60a8b
--- /dev/null
+++ b/test-suite/bugs/closed/3487.v
@@ -0,0 +1,8 @@
+Notation bar := $(exact I)$.
+Notation foo := bar (only parsing).
+Class baz := { x : False }.
+Instance: baz.
+Admitted.
+Definition baz0 := ((_ : baz) = (_ : baz)).
+Definition foo1 := (foo = foo).
+Definition baz1 := prod ((_ : baz) = (_ : baz)) (foo = foo).
diff --git a/test-suite/bugs/closed/3505.v b/test-suite/bugs/closed/3505.v
new file mode 100644
index 00000000..2695bc79
--- /dev/null
+++ b/test-suite/bugs/closed/3505.v
@@ -0,0 +1,44 @@
+(* File reduced by coq-bug-finder from original input, then from 7421 lines to 6082 lines, then from 5860 lines to 5369 lines, then from 5300 lines to 165 lines, then from 111 lines to 38 lines *)
+Set Implicit Arguments.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+    identity : forall x, morphism x x }.
+Bind Scope category_scope with PreCategory.
+Local Notation "1" := (identity _ _) : morphism_scope.
+Local Open Scope morphism_scope.
+Definition prod (C D : PreCategory) : PreCategory
+  := @Build_PreCategory
+       (C * D)%type
+       (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)
+       (fun x => (identity _ (fst x), identity _ (snd x))).
+Local Infix "*" := prod : category_scope.
+Module NonPrim.
+  Record Functor (C D : PreCategory) :=
+    { object_of :> C -> D;
+      morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
+      identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }.
+  Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope.
+  Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x).
+  Proof.
+    intros.
+    rewrite identity_of.
+    reflexivity.
+  Qed.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Record Functor (C D : PreCategory) :=
+    { object_of :> C -> D;
+      morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
+      identity_of : forall x, morphism_of _ _ (identity _ x) = identity _ (object_of x) }.
+  Notation "F '_1' m" := (morphism_of F _ _ m) (at level 10, no associativity) : morphism_scope.
+  Goal forall C1 C2 D (F : Functor (C1 * C2) D) x, F _1 (1, 1) = identity _ (F x).
+  Proof.
+    intros.
+    rewrite identity_of. (* Toplevel input, characters 0-20:
+Error:
+Found no subterm matching "morphism_of ?192 ?193 ?193 (identity ?190 ?193)" in the current goal. *)
+    reflexivity.
+  Qed.
+End Prim.
diff --git a/test-suite/bugs/closed/3520.v b/test-suite/bugs/closed/3520.v
new file mode 100644
index 00000000..c981207e
--- /dev/null
+++ b/test-suite/bugs/closed/3520.v
@@ -0,0 +1,12 @@
+Set Primitive Projections.
+
+Record foo (A : Type) := 
+  { bar : Type ; baz := Set; bad : baz = bar }.
+
+Set Record Elimination Schemes.
+
+Record notprim : Prop :=
+  { irrel : True; relevant : nat }.
+
+
+
diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v
new file mode 100644
index 00000000..fd080a6b
--- /dev/null
+++ b/test-suite/bugs/closed/3531.v
@@ -0,0 +1,53 @@
+(* File reduced by coq-bug-finder from original input, then from 270 lines to
+198 lines, then from 178 lines to 82 lines, then from 88 lines to 59 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 19 2014 14:40:15 with OCaml
+4.01.0
+  coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk
+(56ece74efc25af1b0e09265f3c7fcf74323abcaf) *)
+Require Import Coq.Lists.List.
+Set Implicit Arguments.
+Definition mem := nat -> option nat.
+Definition pred := mem -> Prop.
+Delimit Scope pred_scope with pred.
+Definition exis A (p : A -> pred) : pred := fun m => exists x, p x m.
+Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) :
+pred_scope.
+Definition emp : pred := fun m => forall a, m a = None.
+Definition lift_empty (P : Prop) : pred := fun m => P /\ forall a, m a = None.
+Notation "[[ P ]]" := (lift_empty P) : pred_scope.
+Definition pimpl (p q : pred) := forall m, p m -> q m.
+Notation "p ==> q" := (pimpl p%pred q%pred) (right associativity, at level 90).
+Definition piff (p q : pred) : Prop := (p ==> q) /\ (q ==> p).
+Notation "p <==> q" := (piff p%pred q%pred) (at level 90).
+Parameter sep_star : pred -> pred -> pred.
+Infix "*" := sep_star : pred_scope.
+Definition memis (m : mem) : pred := eq m.
+Definition mptsto (m : mem) (a : nat) (v : nat) := m a = Some v.
+Notation "m @ a |-> v" := (mptsto m a v) (a at level 34, at level 35).
+Lemma piff_trans: forall a b c, (a <==> b) -> (b <==> c) -> (a <==> c).
+Admitted.
+Lemma piff_refl: forall a, (a <==> a).
+Admitted.
+Definition stars (ps : list pred) := fold_left sep_star ps emp.
+Lemma flatten_exists: forall T PT p ps P,
+ (forall (a:T), (p a <==> exists (x:PT), stars (ps a x) * [[P a x]]))
+ -> (exists (a:T), p a) <==>
+     (exists (x:(T*PT)), stars (ps (fst x) (snd x)) * [[P (fst x) (snd x)]]).
+Admitted.
+Goal forall b, (exists e1 e2 e3,
+      (exists (m : mem) (v : nat) (F : pred), b)
+        <==> (exists x : e1, stars (e2 x) * [[e3 x]])).
+ intros. 
+ Set Printing Universes.
+ Show Universes.
+ do 3 eapply ex_intro.  
+ eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros.
+ eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros.
+ eapply piff_trans; [ apply flatten_exists | apply piff_refl ]; intros.
+ assert (H : False) by (clear; admit); destruct H.
+ Grab Existential Variables.
+ admit.
+ admit.
+ admit.
+ Show Universes.
+Time Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3537.v b/test-suite/bugs/closed/3537.v
new file mode 100644
index 00000000..158642f0
--- /dev/null
+++ b/test-suite/bugs/closed/3537.v
@@ -0,0 +1,12 @@
+(* Another instance of bug #3262, on looping in unification *)
+
+Inductive bool := true | false.
+
+Inductive RBT2 : forall a:bool, Type :=
+ Full2 : forall (a b c n:bool),
+            forall H:RBT2 n, RBT2 n.
+
+Definition balance4 color p q r :=
+  match color, p, q, r with
+      | _,_,_,_ => Full2 color p q r
+  end.
diff --git a/test-suite/bugs/closed/3539.v b/test-suite/bugs/closed/3539.v
new file mode 100644
index 00000000..c862965d
--- /dev/null
+++ b/test-suite/bugs/closed/3539.v
@@ -0,0 +1,66 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-no-native-compiler") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 11678 lines to 11330 lines, then from 10721 lines to 9544 lines, then from 9549 lines to 794 lines, then from 810 lines to 785 lines, then from 628 lines to 246 lines, then from 220 lines to 89 lines, then from 80 lines to 47 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 22 2014 4:17:28 with OCaml 4.01.0
+   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (a67cc6941434124465f20b14a1256f2ede31a60e) *)
+
+Set Implicit Arguments.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end.
+Local Set Primitive Projections.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Axiom path_prod : forall {A B : Type} (z z' : A * B), (fst z = fst z') -> (snd z = snd z') -> (z = z').
+Axiom transport_path_prod : forall A B (P : A * B -> Type) (x y : A * B) (HA : fst x = fst y) (HB : snd x = snd y) Px,
+                              transport P (path_prod _ _ HA HB) Px
+                              = transport (fun x => P (x, snd y)) HA (transport (fun y => P (fst x, y)) HB Px).
+Goal forall (T0 : Type) (snd1 snd0 f : T0) (p : @paths T0 f snd0)
+            (f0 : T0) (p1 : @paths T0 f0 snd1) (T1 : Type)
+            (fst1 fst0 : T1) (p0 : @paths T1 fst0 fst0) (p2 : @paths T1 fst1 fst1)
+            (T : Type) (x2 : T) (T2 : Type) (T3 : forall (_ : T2) (_ : T2), Type)
+            (x' : forall (_ : T1) (_ : T), T2) (m : T3 (x' fst1 x2) (x' fst0 x2)),
+       @paths (T3 (x' fst1 x2) (x' fst0 x2))
+              (@transport (prod T1 T0)
+                          (fun x : prod T1 T0 =>
+                             T3 (x' fst1 x2) (x' (fst x) x2))
+                          (@pair T1 T0 fst0 f) (@pair T1 T0 fst0 snd0)
+                          (@path_prod T1 T0 (@pair T1 T0 fst0 f)
+                                      (@pair T1 T0 fst0 snd0) p0 p)
+                          (@transport (prod T1 T0)
+                                      (fun x : prod T1 T0 =>
+                                         T3 (x' (fst x) x2) (x' fst0 x2))
+                                      (@pair T1 T0 fst1 f0) (@pair T1 T0 fst1 snd1)
+                                      (@path_prod T1 T0 (@pair T1 T0 fst1 f0)
+                                                  (@pair T1 T0 fst1 snd1) p2 p1) m)) m.
+  intros.
+  match goal with
+    | [ |- context[transport ?P (path_prod ?x ?y ?HA ?HB) ?Px] ]
+      => rewrite (transport_path_prod P x y HA HB Px)
+  end || fail "bad".
+  Undo.
+  Set Printing All.
+  rewrite transport_path_prod. (* Toplevel input, characters 15-43:
+Error:
+In environment
+T0 : Type
+snd1 : T0
+snd0 : T0
+f : T0
+p : @paths T0 f snd0
+f0 : T0
+p1 : @paths T0 f0 snd1
+T1 : Type
+fst1 : T1
+fst0 : T1
+p0 : @paths T1 fst0 fst0
+p2 : @paths T1 fst1 fst1
+T : Type
+x2 : T
+T2 : Type
+T3 : forall (_ : T2) (_ : T2), Type
+x' : forall (_ : T1) (_ : T), T2
+m : T3 (x' fst1 x2) (x' fst0 x2)
+Unable to unify "?25 (@pair ?23 ?24 (fst ?27) (snd ?27))" with
+"?25 ?27".
+ *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3542.v b/test-suite/bugs/closed/3542.v
new file mode 100644
index 00000000..b6837a0c
--- /dev/null
+++ b/test-suite/bugs/closed/3542.v
@@ -0,0 +1,6 @@
+Section foo.
+  Context {A:Type} {B : A -> Type}.
+  Context (f : forall x, B x).
+  Goal True.
+    pose (r := fun k => existT (fun g => forall x, f x = g x)
+                               (fun x => projT1 (k x)) (fun x => projT2 (k x))).
diff --git a/test-suite/bugs/closed/3546.v b/test-suite/bugs/closed/3546.v
new file mode 100644
index 00000000..55d718bd
--- /dev/null
+++ b/test-suite/bugs/closed/3546.v
@@ -0,0 +1,17 @@
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+Arguments pair {_ _} _ _.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y.
+Admitted.
+Goal forall x y z w : Set, (x, y) = (z, w).
+Proof.
+  intros.
+  apply ap11. (* Toplevel input, characters 21-25:
+Error: In environment
+x : Set
+y : Set
+z : Set
+w : Set
+Unable to unify "?31 ?191 = ?32 ?192" with "(x, y) = (z, w)".
+ *)
diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v
new file mode 100644
index 00000000..50645090
--- /dev/null
+++ b/test-suite/bugs/closed/3559.v
@@ -0,0 +1,86 @@
+(* File reduced by coq-bug-finder from original input, then from 8657 lines to
+4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines,
+then from 51 lines to 37 lines, then from 43 lines to 30 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml
+4.01.0
+  coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk
+(437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *)
+Require Import Coq.Init.Notations.
+Set Universe Polymorphism.
+Generalizable All Variables.
+Record prod A B := pair { fst : A ; snd : B }.
+Arguments pair {_ _} _ _.
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Reserved Notation "x <-> y" (at level 95, no associativity).
+Reserved Notation "x = y" (at level 70, no associativity).
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Open Scope type_scope.
+
+Definition iff A B := prod (A -> B) (B -> A).
+Infix "<->" := iff : type_scope.
+Inductive paths {A : Type@{i}} (a : A) : A -> Type@{i} := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center
+= y) }.
+Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index).
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type@{i}) : Type@{i} :=
+ match n with
+   | minus_two => Contr_internal A
+   | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+ end.
+Notation minus_one:=(trunc_S minus_two).
+Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc :
+IsTrunc_internal n A.
+Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A) :
+IsTrunc n (x = y) := H x y.
+
+Axiom cheat : forall {A}, A.
+
+Lemma paths_lift (A : Type@{i}) (x y : A) (p : x = y) : paths@{j} x y.
+Proof.
+  destruct p. apply idpath.
+Defined.
+
+Lemma paths_change (A : Type@{i}) (x y : A) : paths@{j} x y = paths@{i} x y.
+Proof. (* require Univalence *)
+  apply cheat.
+Defined.
+  
+Lemma IsTrunc_lift (n : trunc_index) :
+  forall (A : Type@{i}), IsTrunc_internal@{i} n A -> IsTrunc_internal@{j} n A.
+Proof.
+  induction n; simpl; intros. 
+  destruct X. exists center0. intros. apply (paths_lift _ _ _  (contr0 y)).
+
+  rewrite paths_change. 
+  apply IHn, X. 
+Defined.
+
+Notation IsHProp := (IsTrunc minus_one).
+(* Record hProp := hp { hproptype :> Type ; isp : IsTrunc minus_one hproptype}. *)
+(* Make the truncation proof polymorphic, i.e., available at any level greater or equal 
+   to the carrier type level j *)
+Record hProp := hp { hproptype :> Type@{j} ; isp : IsTrunc minus_one hproptype}.
+Axiom path_iff_hprop_uncurried : forall `{IsHProp A, IsHProp B}, (A <-> B) -> A
+= B.
+Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V.
+Axiom is0trunc_V : IsTrunc (trunc_S (trunc_S minus_two)) V.
+Axiom bisimulation : V@{U' U} -> V@{U' U} -> hProp@{U'}.
+Axiom bisimulation_refl : forall (v : V), bisimulation v v.
+Axiom bisimulation_eq : forall (u v : V), bisimulation u v -> u = v.
+Notation "u ~~ v" := (bisimulation u v) (at level 30).
+Lemma bisimulation_equals_id : forall u v : V@{i j}, (u = v) = (u ~~ v).
+Proof.
+ intros u v.
+ refine (@path_iff_hprop_uncurried _ _ _ _ _).
+(* path_iff_hprop_uncurried : *)
+(* forall A : Type@{Top.74}, *)
+(* IsHProp A -> forall B : Type@{Top.74}, IsHProp B -> A <-> B -> A = B *)
+(* (* Top.74 *)
+(*    Top.78 |= Top.74 < Top.78 *)
+(*                *) *)
+
+ Show Universes. 
+ exact (isp _).
+ split; intros. destruct X. apply bisimulation_refl.
+ apply bisimulation_eq, X.
+Defined.
diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v
new file mode 100644
index 00000000..b4dfd17f
--- /dev/null
+++ b/test-suite/bugs/closed/3561.v
@@ -0,0 +1,23 @@
+(* File reduced by coq-bug-finder from original input, then from 6343 lines to 2362 lines, then from 2115 lines to 303 lines, then from 321 lines to 90 lines, then from 95 lines to 41 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0
+   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *)
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
+Lemma ap_transport {A} {P Q : A -> Type} {x y : A} (p : x = y) (f : forall x, P x -> Q x) (z : P x) :
+  f y (p # z) = (p # (f x z)).
+Proof. admit.
+Defined.
+Lemma foo A B (f : A * B -> A) : f = f.
+Admitted.
+Goal forall (H0 H2 : Type) x p,
+       @transport (prod H0 H2)
+                  (fun GO : prod H0 H2 => x (fst GO)) = p.
+  intros. 
+  match goal with
+    | [ |- context[x (?f _)] ] => set(foo':=f)
+  end.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3562.v b/test-suite/bugs/closed/3562.v
new file mode 100644
index 00000000..1a1410a3
--- /dev/null
+++ b/test-suite/bugs/closed/3562.v
@@ -0,0 +1,6 @@
+(* Should not be an anomaly as it was at some time in
+   September/October 2014 but some "Disjunctive/conjunctive
+   introduction pattern expected" error *)
+
+Theorem t: True.
+Fail destruct 0 as x.
diff --git a/test-suite/bugs/closed/3563.v b/test-suite/bugs/closed/3563.v
new file mode 100644
index 00000000..67972166
--- /dev/null
+++ b/test-suite/bugs/closed/3563.v
@@ -0,0 +1,38 @@
+(* File reduced by coq-bug-finder from original input, then from 11716 lines to 11295 lines, then from 10518 lines to 21 lines, then \
+from 37 lines to 21 lines *)
+(* coqc version trunk (August 2014) compiled on Aug 31 2014 10:12:32 with OCaml 4.01.0
+   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (437b91a3ffd7327975a129b95b24d3f66ad7f3e4) *)
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+Arguments pair {A B} _ _.
+Arguments fst {A B} _ / .
+Arguments snd {A B} _ / .
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> H * H0)
+            (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) =
+                  H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2))),
+       transport (fun y : H1 -> H * H0 => H5 (fst (y H2))) H4 H6 = H7.
+  intros.
+  match goal with
+    | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?h (y H2)))) H4 H6] ]
+      => set(foo:=h); idtac
+  end.
+  match goal with
+    | [ |- appcontext ctx [transport (fun y => (?g (fst (y H2))))] ]
+      => idtac
+  end.
+Abort.
+Goal forall (H H0 H1 : Type) (H2 : H1) (H3 : H1 -> (H1 -> H) * H0)
+            (H4 : (fun c : H1 => (fst (H3 c), snd (H3 c))%core) =
+                  H3) (H5 : H -> Type) (H6 H7 : H5 (fst (H3 H2) H2)),
+       transport (fun y : H1 -> (H1 -> H) * H0 => H5 (fst (y H2) H2)) H4 H6 = H7.
+  intros.
+  match goal with
+    | [ |- appcontext ctx [transport (fun y => (?g (@fst ?C ?D (y H2) ?X)))] ]
+      => set(foo:=X)
+  end.
+(* Anomaly: Uncaught exception Not_found(_). Please report. *)
+
+(* Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v
new file mode 100644
index 00000000..b2aa8c3c
--- /dev/null
+++ b/test-suite/bugs/closed/3566.v
@@ -0,0 +1,22 @@
+Notation idmap := (fun x => x).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Delimit Scope path_scope with path.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x := match p with idpath => idpath end.
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope.
+Class IsEquiv {A B : Type} (f : A -> B) := {}.
+Axiom path_universe : forall {A B : Type} (f : A -> B) {feq : IsEquiv f}, (A = B).
+
+Definition Lift : Type@{i} -> Type@{j}
+  := Eval hnf in let lt := Type@{i} : Type@{j} in fun T => T.
+
+Definition lift {T} : T -> Lift T := fun x => x.
+
+Goal forall x y : Type, x = y.
+  intros.
+  pose proof ((fun H0 : idmap _ => (@path_universe _ _ (@lift x) (H0 x) @ 
+                                                   (@path_universe _ _ (@lift x) (H0 x))^)))%path as H''.
diff --git a/test-suite/bugs/closed/3567.v b/test-suite/bugs/closed/3567.v
new file mode 100644
index 00000000..cb16b3ae
--- /dev/null
+++ b/test-suite/bugs/closed/3567.v
@@ -0,0 +1,68 @@
+
+(* File reduced by coq-bug-finder from original input, then from 2901 lines to 69 lines, then from 80 lines to 63 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 2 2014 2:7:1 with OCaml 4.01.0
+   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3c5daf4e23ee20f0788c0deab688af452e83ccf0) *)
+
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Arguments fst {A B} _ / .
+Arguments snd {A B} _ / .
+Add Printing Let prod.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Unset Implicit Arguments.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) :=
+  { equiv_inv : B -> A ;
+    eisretr : Sect equiv_inv f;
+    eissect : Sect f equiv_inv;
+    eisadj : forall x : A, eisretr (f x) = ap f (eissect x) }.
+Definition path_prod_uncurried {A B : Type} (z z' : A * B) (pq : (fst z = fst z') * (snd z = snd z'))
+: (z = z')
+  := match fst pq in (_ = z'1), snd pq in (_ = z'2) return z = (z'1, z'2) with
+       | idpath, idpath => idpath
+     end.
+Definition path_prod {A B : Type} (z z' : A * B) :
+  (fst z = fst z') -> (snd z = snd z') -> (z = z')
+  := fun p q => path_prod_uncurried z z' (p,q).
+Definition path_prod' {A B : Type} {x x' : A} {y y' : B}
+: (x = x') -> (y = y') -> ((x,y) = (x',y'))
+  := fun p q => path_prod (x,y) (x',y') p q.
+Axiom ap_fst_path_prod : forall {A B : Type} {z z' : A * B}
+                                (p : fst z = fst z') (q : snd z = snd z'),
+                           ap fst (path_prod _ _ p q) = p.
+Axiom ap_snd_path_prod : forall {A B : Type} {z z' : A * B}
+                                (p : fst z = fst z') (q : snd z = snd z'),
+                           ap snd (path_prod _ _ p q) = q.
+Axiom eta_path_prod : forall {A B : Type} {z z' : A * B} (p : z = z'),
+                        path_prod _ _(ap fst p) (ap snd p) = p.
+Definition isequiv_path_prod {A B : Type} {z z' : A * B} : IsEquiv (path_prod_uncurried z z').
+Proof.
+  refine (Build_IsEquiv
+            _ _ _
+            (fun r => (ap fst r, ap snd r))
+            eta_path_prod
+            (fun pq => match pq with
+                         | (p,q) => path_prod'
+                                      (ap_fst_path_prod p q) (ap_snd_path_prod p q)
+                       end) _).
+  destruct z as [x y], z' as [x' y']. simpl.
+(* Toplevel input, characters 15-50:
+Error: Abstracting over the term "z" leads to a term
+fun z0 : A * B =>
+forall x : (fst z0 = fst z') * (snd z0 = snd z'),
+eta_path_prod (path_prod_uncurried z0 z' x) =
+ap (path_prod_uncurried z0 z')
+  (let (p, q) as pq
+       return
+         ((ap (fst) (path_prod_uncurried z0 z' pq),
+          ap (snd) (path_prod_uncurried z0 z' pq)) = pq) := x in
+   path_prod' (ap_fst_path_prod p q) (ap_snd_path_prod p q))
+which is ill-typed.
+Reason is: Pattern-matching expression on an object of inductive type prod
+has invalid information.
+ *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3584.v b/test-suite/bugs/closed/3584.v
new file mode 100644
index 00000000..3d4660b4
--- /dev/null
+++ b/test-suite/bugs/closed/3584.v
@@ -0,0 +1,16 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Definition eta_sigma {A} {P : A -> Type} (u : sigT P)
+  : existT _ (projT1 u) (projT2 u) = u
+  := match u with existT _ x y => eq_refl end. (* Toplevel input, characters 0-139:
+Error: Pattern-matching expression on an object of inductive type sigT
+has invalid information. *)
+Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B))
+: A + B
+  := match x with
+       | existT _ true a => inl a
+       | existT _ false b => inr b
+     end. (* Toplevel input, characters 0-182:
+Error: Pattern-matching expression on an object of inductive type sigT
+has invalid information. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3593.v b/test-suite/bugs/closed/3593.v
new file mode 100644
index 00000000..25f9db6b
--- /dev/null
+++ b/test-suite/bugs/closed/3593.v
@@ -0,0 +1,10 @@
+Set Universe Polymorphism.
+Set Printing All.
+Set Implicit Arguments.
+Record prod A B := pair { fst : A ; snd : B }.
+Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x.
+simpl; intros.
+  constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x).   
+  Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). 
+  reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/3594.v b/test-suite/bugs/closed/3594.v
new file mode 100644
index 00000000..d1aae7b4
--- /dev/null
+++ b/test-suite/bugs/closed/3594.v
@@ -0,0 +1,51 @@
+(* File reduced by coq-bug-finder from original input, then from 8752 lines to 735 lines, then from 735 lines to 310 lines, then from 228 lines to 105 lines, then from 98 lines to 41 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 6 2014 6:15:6 with OCaml 4.01.0
+   coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (3ea6d6888105edd5139ae0a4d8f8ecdb586aff6c) *)
+Notation idmap := (fun x => x).
+Axiom path_forall : forall {A : Type} {P : A -> Type} (f g : forall x : A, P x), (forall x, f x = g x) -> f = g.
+Local Set Primitive Projections.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Bind Scope category_scope with PreCategory.
+Set Implicit Arguments.
+Delimit Scope functor_scope with functor.
+Record Functor (C D : PreCategory) := {}.
+Definition opposite (C : PreCategory) : PreCategory := @Build_PreCategory C (fun s d => morphism C d s).
+Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope.
+Definition oppositeF C D (F : Functor C D) : Functor C^op D^op := Build_Functor (C^op) (D^op).
+Local Notation "F ^op" := (oppositeF F) (at level 3, format "F ^op") : functor_scope.
+Axiom oppositeF_involutive : forall C D (F : Functor C D), ((F^op)^op)%functor = F.
+Local Open Scope functor_scope.
+Goal forall C D : PreCategory,
+       (fun c : Functor C^op D^op => (c^op)^op) = idmap.
+  intros.
+  exact (path_forall (fun F : Functor C^op D^op => (F^op)^op) _ (@oppositeF_involutive _ _)).
+  Undo.
+  Unset Printing Notations.
+  Set Debug Unification.
+(*   Check (eq_refl : Build_PreCategory (opposite D).(object) *)
+(*                  (fun s d : (opposite D).(object) =>  *)
+(*                     (opposite D).(morphism) d s) =  *)
+(*                    @Build_PreCategory D (fun s d => morphism D d s)). *)
+(* opposite D). *)
+  exact (path_forall (fun F => (F^op)^op) _ (@oppositeF_involutive _ _)). 
+Qed.
+ (* Toplevel input, characters 22-101:
+Error:
+In environment
+C : PreCategory
+D : PreCategory
+The term
+ "path_forall
+    (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F))
+    (fun F : Functor (opposite C) (opposite D) => F)
+    (oppositeF_involutive (D:=opposite D))" has type
+ "eq (fun F : Functor (opposite C) (opposite D) => oppositeF (oppositeF F))
+    (fun F : Functor (opposite C) (opposite D) => F)"
+while it is expected to have type
+ "eq (fun c : Functor (opposite C) (opposite D) => oppositeF (oppositeF c))
+    (fun x : Functor (opposite C) (opposite D) => x)"
+(cannot unify "{|
+               object := opposite D;
+               morphism := fun s d : opposite D => morphism (opposite D) d s |}"
+and "opposite D").
+ *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v
new file mode 100644
index 00000000..d6c1c949
--- /dev/null
+++ b/test-suite/bugs/closed/3596.v
@@ -0,0 +1,18 @@
+Set Implicit Arguments.
+Record foo := { fx : nat }.
+Set Primitive Projections.
+Record bar := { bx : nat }.
+Definition Foo (f : foo) : f = f.
+  destruct f as [fx]; destruct fx; admit.
+Defined.
+Definition Bar (b : bar) : b = b.
+  destruct b as [fx]; destruct fx; admit.
+Defined.
+Goal forall f b, Bar b = Bar b -> Foo f = Foo f.
+  intros f b.
+  destruct f, b. 
+  simpl.
+  Fail progress unfold Bar. (* success *)
+  Fail progress unfold Foo. (* failed to progress *)
+  reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3616.v b/test-suite/bugs/closed/3616.v
new file mode 100644
index 00000000..68870026
--- /dev/null
+++ b/test-suite/bugs/closed/3616.v
@@ -0,0 +1,3 @@
+(* Was failing from April 2014 to September 2014 because of injection *)
+Goal forall P e es t, (e :: es = existT P tt t :: es)%list -> True.
+inversion 1.
diff --git a/test-suite/bugs/closed/3618.v b/test-suite/bugs/closed/3618.v
new file mode 100644
index 00000000..dc560ad5
--- /dev/null
+++ b/test-suite/bugs/closed/3618.v
@@ -0,0 +1,103 @@
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Notation "x = y" := (@paths _ x y) : type_scope.
+Definition concat {A} {x y z : A} : x = y -> y = z -> x = z. Admitted.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x. Admitted.
+Notation "p @ q" := (concat p q) (at level 20).
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y. Admitted.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y. Admitted.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : forall x, f (equiv_inv x) = x;
+  eissect : forall x, equiv_inv (f x) = x
+}.
+
+Class Contr_internal (A : Type).
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+Definition istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A)
+: IsTrunc n (x = y).
+Admitted.
+
+Hint Extern 4 (IsTrunc _ (_ = _)) => eapply @istrunc_paths : typeclass_instances.
+
+Class Funext.
+
+Instance isequiv_compose A B C f g `{IsEquiv A B f} `{IsEquiv B C g}
+  : IsEquiv (compose g f) | 1000.
+Admitted.
+
+Section IsEquivHomotopic.
+  Context (A B : Type) `(f : A -> B) `(g : A -> B) `{IsEquiv A B f} (h : forall x:A, f x = g x).
+  Let sect := (fun b:B => inverse (h (@equiv_inv _ _ f _ b)) @ @eisretr _ _ f _ b).
+  Let retr := (fun a:A => inverse (ap (@equiv_inv _ _ f _) (h a)) @ @eissect _ _ f _ a).
+  Global Instance isequiv_homotopic : IsEquiv g | 10000
+    := ( BuildIsEquiv _ _ g (@equiv_inv _ _ f _) sect retr).
+End IsEquivHomotopic.
+
+Instance trunc_succ A n `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000. Admitted.
+
+Global Instance trunc_forall A n `{P : A -> Type} `{forall a, IsTrunc n (P a)}
+  : IsTrunc n (forall a, P a) | 100.
+Admitted.
+
+Instance trunc_prod A B n `{IsTrunc n A} `{IsTrunc n B} : IsTrunc n (A * B) | 100.
+Admitted.
+
+Global Instance trunc_arrow n {A B : Type} `{IsTrunc n B} : IsTrunc n (A -> B) | 100.
+Admitted.
+
+Instance isequiv_pr1_contr {A} {P : A -> Type} `{forall a, IsTrunc minus_two (P a)}
+: IsEquiv (@projT1 A P) | 100.
+Admitted.
+
+Instance trunc_sigma n A `{P : A -> Type} `{IsTrunc n A} `{forall a, IsTrunc n (P a)}
+: IsTrunc n (sigT P) | 100.
+Admitted.
+
+Global Instance trunc_trunc `{Funext} A m n : IsTrunc (trunc_S n) (IsTrunc m A) | 0.
+Admitted.
+
+Definition BiInv {A B} (f : A -> B) : Type
+:= ( {g : B -> A & forall x, g (f x) = x} * {h : B -> A & forall x, f (h x) = x}).
+
+Global Instance isprop_biinv {A B} (f : A -> B) : IsTrunc (trunc_S minus_two) (BiInv f) | 0.
+Admitted.
+
+Instance isequiv_path {A B : Type} (p : A = B)
+: IsEquiv (transport (fun X:Type => X) p) | 0.
+Admitted.
+
+Class ReflectiveSubuniverse_internal :=
+  { inO_internal : Type -> Type ;
+    O : Type -> Type ;
+    O_unit : forall T, T -> O T }.
+
+Class ReflectiveSubuniverse :=
+  ReflectiveSubuniverse_wrap : Funext -> ReflectiveSubuniverse_internal.
+Global Existing Instance ReflectiveSubuniverse_wrap.
+
+Class inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) :=
+  isequiv_inO : inO_internal T.
+
+Global Instance hprop_inO {fs : Funext} {subU : ReflectiveSubuniverse} (T : Type) : IsTrunc (trunc_S minus_two) (inO T) .
+Admitted.
+
+(* To avoid looping class resolution *)
+Hint Mode IsEquiv - - + : typeclass_instances. 
+
+Fail Definition equiv_O_rectnd {fs : Funext} {subU : ReflectiveSubuniverse}
+           (P Q : Type) {Q_inO : inO_internal Q}
+: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3623.v b/test-suite/bugs/closed/3623.v
new file mode 100644
index 00000000..202b9001
--- /dev/null
+++ b/test-suite/bugs/closed/3623.v
@@ -0,0 +1,4 @@
+Require Import List.
+Goal  (1 :: 2 :: nil) ++ (3::nil) = (1::2::3::nil).
+change (@app nat (?a :: ?b) ?c) with (a :: @app nat b c).
+Abort.
diff --git a/test-suite/bugs/closed/3624.v b/test-suite/bugs/closed/3624.v
new file mode 100644
index 00000000..a05d5eb2
--- /dev/null
+++ b/test-suite/bugs/closed/3624.v
@@ -0,0 +1,11 @@
+Set Implicit Arguments.
+Module NonPrim.
+  Class foo (m : Set) := { pf : m = m }.
+  Notation pf' m := (pf (m := m)).
+End NonPrim.
+
+Module Prim.
+  Set Primitive Projections.
+  Class foo (m : Set) := { pf : m = m }.
+  Notation pf' m := (pf (m:=m)). (* Wrong argument name: m. *)
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3625.v b/test-suite/bugs/closed/3625.v
new file mode 100644
index 00000000..3d30b62f
--- /dev/null
+++ b/test-suite/bugs/closed/3625.v
@@ -0,0 +1,11 @@
+Set Implicit Arguments.
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+
+Goal forall x y : prod Set Set, x.(@fst _ _) = y.(@fst _ _).
+ intros.
+ refine (f_equal _ _).
+ Undo.
+ apply f_equal.
+ admit.
+Qed.
diff --git a/test-suite/bugs/closed/3628.v b/test-suite/bugs/closed/3628.v
new file mode 100644
index 00000000..4001cf7c
--- /dev/null
+++ b/test-suite/bugs/closed/3628.v
@@ -0,0 +1,9 @@
+Module NonPrim.
+  Class AClass := { x : Set }.
+  Arguments x {AClass}.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Class AClass := { x : Set }.
+  Arguments x {AClass}.
+End Prim.
diff --git a/test-suite/bugs/closed/3633.v b/test-suite/bugs/closed/3633.v
new file mode 100644
index 00000000..6a952377
--- /dev/null
+++ b/test-suite/bugs/closed/3633.v
@@ -0,0 +1,10 @@
+Set Typeclasses Strict Resolution.
+Class Contr (A : Type) := { center : A }.
+Definition foo {A} `{Contr A} : A.
+Proof.
+  apply center.
+  Undo.
+  (* Ensure the constraints are solved independently, otherwise a frozen ?A 
+  makes a search for Contr ?A fail when finishing to apply (fun x => x) *)
+  apply (fun x => x), center. 
+Qed.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3637.v b/test-suite/bugs/closed/3637.v
new file mode 100644
index 00000000..868f45c8
--- /dev/null
+++ b/test-suite/bugs/closed/3637.v
@@ -0,0 +1,11 @@
+
+Set Implicit Arguments.
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+Goal forall x y : prod Set Set, fst x = fst y.
+  intros.
+  lazymatch goal with
+    | [ |- context[@fst ?A ?B] ] => pose (@fst A B) as fst';
+                                   progress change (@fst Set Set) with fst'
+end.
+Abort.
diff --git a/test-suite/bugs/closed/3638.v b/test-suite/bugs/closed/3638.v
new file mode 100644
index 00000000..70144174
--- /dev/null
+++ b/test-suite/bugs/closed/3638.v
@@ -0,0 +1,25 @@
+(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from 104 lines to 28 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *)
+Set Primitive Projections.
+Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }.
+Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }.
+Global Existing Instance rsubu_usubu.
+Context {subU : ReflectiveSubuniverse}.
+Goal forall (A B : Type) (x : O A * O B) (x0 : B),
+       { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z)))
+                          (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) =
+                 g x0 }.
+  eexists.
+  Show Existentials. Set Printing Existential Instances. 
+  match goal with
+    | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in set (e' := e)
+  end.
+  
+
+(* Toplevel input, characters 15-114:
+Anomaly: Bad recursive type. Please report. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3640.v b/test-suite/bugs/closed/3640.v
new file mode 100644
index 00000000..bdbfbb15
--- /dev/null
+++ b/test-suite/bugs/closed/3640.v
@@ -0,0 +1,31 @@
+(* File reduced by coq-bug-finder from original input, then from 14990 lines to 70 lines, then from 44 lines to 29 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *)
+Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A} P := existT { pr1 : A ; pr2 : P pr1 }.
+Notation "{ x : A & P }" := (sigT (A := A) (fun x : A => P)) : type_scope.
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'").
+Notation "x .2" := (pr2 x) (at level 3, format "x '.2'").
+Record Equiv A B := { equiv_fun :> A -> B }.
+Notation "A <~> B" := (Equiv A B) (at level 85).
+Inductive Bool : Type := true | false.
+Definition negb (b : Bool) := if b then false else true.
+Axiom eval_bool_isequiv : forall (f : Bool -> Bool), f false = negb (f true).
+Lemma bool_map_equiv_not_idmap (f : { f : Bool <~> Bool & ~(forall x, f x = x) })
+: forall b, ~(f.1 b = b).
+Proof.
+  intro b.
+  intro H''.
+  apply f.2.
+  intro b'.
+  pose proof (eval_bool_isequiv f.1) as H.
+  destruct b', b.
+  Fail match type of H with
+    | _ = negb (f.1 true) => fail 1 "no f.1 true"
+  end. (* Error: No matching clauses for match. *)
+  destruct (f.1 true).
+  simpl in *.
+  Fail match type of H with
+    | _ = negb ?T => unify T (f.1 true); fail 1 "still has f.1 true"
+  end. (* Error: Tactic failure: still has f.1 true. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3641.v b/test-suite/bugs/closed/3641.v
new file mode 100644
index 00000000..f47f64ea
--- /dev/null
+++ b/test-suite/bugs/closed/3641.v
@@ -0,0 +1,21 @@
+(* File reduced by coq-bug-finder from original input, then from 7593 lines to 243 lines, then from 256 lines to 102 lines, then from\
+ 104 lines to 28 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 17 2014 0:22:30 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d34e1eed232c84590ddb80d70db9f7f7cf13584a) *)
+Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Class UnitSubuniverse := { O : Type -> Type ; O_unit : forall T, T -> O T }.
+Class ReflectiveSubuniverse := { rsubu_usubu : UnitSubuniverse ; O_rectnd : forall {P Q : Type} (f : P -> Q), O P -> Q }.
+Global Existing Instance rsubu_usubu.
+Context {subU : ReflectiveSubuniverse}.
+Goal forall (A B : Type) (x : O A * O B) (x0 : B),
+       { g : _ & O_rectnd (fun z : A * B => (O_unit (fst z), O_unit (snd z)))
+                          (O_rectnd (fun a : A => O_unit (a, x0)) (fst x)) =
+                 g x0 }.
+  eexists.
+  match goal with
+    | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in pose (e' := e)
+  end.
+  Fail change ?g with e'. (* Stack overflow *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v
new file mode 100644
index 00000000..cd542c8a
--- /dev/null
+++ b/test-suite/bugs/closed/3647.v
@@ -0,0 +1,652 @@
+Require Coq.Setoids.Setoid.
+
+Axiom BITS : nat -> Set.
+Definition n7 := 7.
+Definition n15 := 15.
+Definition n31 := 31.
+Notation n8 := (S n7).
+Notation n16 := (S n15).
+Notation n32 := (S n31).
+Inductive OpSize := OpSize1 | OpSize2 | OpSize4  .
+Definition VWORD s := BITS (match s with OpSize1 => n8 | OpSize2 => n16 | OpSize4 => n32   end).
+Definition BYTE   := VWORD OpSize1.
+Definition WORD   := VWORD OpSize2.
+Definition DWORD  := VWORD OpSize4.
+Ltac subst_body :=
+  repeat match goal with
+           | [ H := _ |- _ ] => subst H
+         end.
+Import Coq.Setoids.Setoid.
+Class Equiv (A : Type) := equiv : relation A.
+Infix "===" := equiv (at level 70, no associativity).
+Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv.
+Definition setoid_resp {T T'} (f : T -> T') `{e : type T} `{e' : type T'} := forall x y, x === y -> f x === f y.
+Record morphism T T' `{e : type T} `{e' : type T'} :=
+  mkMorph {
+      morph :> T -> T';
+      morph_resp : setoid_resp morph}.
+Implicit Arguments mkMorph [T T' e e0 e' e1].
+Infix "-s>" := morphism (at level 45, right associativity).
+Section Morphisms.
+  Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}.
+  Global Instance morph_equiv : Equiv (S -s> T).
+  admit.
+  Defined.
+
+  Global Instance morph_type : type (S -s> T).
+  admit.
+  Defined.
+
+  Program Definition mcomp (f: T -s> U) (g: S -s> T) : (S -s> U) :=
+    mkMorph (fun x => f (g x)) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End Morphisms.
+
+Infix "<<" := mcomp (at level 35).
+
+Section MorphConsts.
+  Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}.
+
+  Definition lift2s (f : S -> T -> U) p q : (S -s> T -s> U) :=
+    mkMorph (fun x => mkMorph (f x) (p x)) q.
+
+End MorphConsts.
+Instance Equiv_PropP : Equiv Prop.
+admit.
+Defined.
+
+Section SetoidProducts.
+  Context {A B : Type} `{eA : type A} `{eB : type B}.
+  Global Instance Equiv_prod : Equiv (A * B).
+  admit.
+  Defined.
+
+  Global Instance type_prod : type (A * B).
+  admit.
+  Defined.
+
+  Program Definition mfst : (A * B) -s> A :=
+    mkMorph (fun p => fst p) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition msnd : (A * B) -s> B :=
+    mkMorph (fun p => snd p) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Context {C} `{eC : type C}.
+
+  Program Definition mprod (f: C -s> A) (g: C -s> B) : C -s> (A * B) :=
+    mkMorph (fun c => (f c, g c)) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End SetoidProducts.
+
+Section IndexedProducts.
+
+  Record ttyp := {carr :> Type; eqc : Equiv carr; eqok : type carr}.
+  Global Instance ttyp_proj_eq {A : ttyp} : Equiv A.
+  admit.
+  Defined.
+  Global Instance ttyp_proj_prop {A : ttyp} : type A.
+  admit.
+  Defined.
+  Context {I : Type} {P : I -> ttyp}.
+
+  Global Program Instance Equiv_prodI : Equiv (forall i, P i) :=
+    fun p p' : forall i, P i => (forall i : I, @equiv _ (eqc _) (p i) (p' i)).
+
+  Global Instance type_prodI : type (forall i, P i).
+  admit.
+  Defined.
+
+  Program Definition mprojI (i : I) : (forall i, P i) -s> P i :=
+    mkMorph (fun X => X i) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Context {C : Type} `{eC : type C}.
+
+  Program Definition mprodI (f : forall i, C -s> P i) : C -s> (forall i, P i) :=
+    mkMorph (fun c i => f i c) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End IndexedProducts.
+
+Section Exponentials.
+
+  Context {A B C D} `{eA : type A} `{eB : type B} `{eC : type C} `{eD : type D}.
+
+  Program Definition comps : (B -s> C) -s> (A -s> B) -s> A -s> C :=
+    lift2s (fun f g => f << g) _ _.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition muncurry (f : A -s> B -s> C) : A * B -s> C :=
+    mkMorph (fun p => f (fst p) (snd p)) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition mcurry (f : A * B -s> C) : A -s> B -s> C :=
+    lift2s (fun a b => f (a, b)) _ _.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition meval : (B -s> A) * B -s> A :=
+    mkMorph (fun p => fst p (snd p)) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition mid : A -s> A := mkMorph (fun x => x) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition mconst (b : B) : A -s> B := mkMorph (fun _ => b) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End Exponentials.
+
+Inductive empty : Set := .
+Instance empty_Equiv : Equiv empty.
+admit.
+Defined.
+Instance empty_type : type empty.
+admit.
+Defined.
+
+Section Initials.
+  Context {A} `{eA : type A}.
+
+  Program Definition mzero_init : empty -s> A := mkMorph (fun x => match x with end) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End Initials.
+
+Section Subsetoid.
+
+  Context {A} `{eA : type A} {P : A -> Prop}.
+  Global Instance subset_Equiv : Equiv {a : A | P a}.
+  admit.
+  Defined.
+  Global Instance subset_type : type {a : A | P a}.
+  admit.
+  Defined.
+
+  Program Definition mforget : {a : A | P a} -s> A :=
+    mkMorph (fun x => x) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Context {B} `{eB : type B}.
+  Program Definition minherit (f : B -s> A) (HB : forall b, P (f b)) : B -s> {a : A | P a} :=
+    mkMorph (fun b => exist P (f b) (HB b)) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End Subsetoid.
+
+Section Option.
+
+  Context {A} `{eA : type A}.
+  Global Instance option_Equiv : Equiv (option A).
+  admit.
+  Defined.
+
+  Global Instance option_type : type (option A).
+  admit.
+  Defined.
+
+End Option.
+
+Section OptDefs.
+  Context {A B} `{eA : type A} `{eB : type B}.
+
+  Program Definition msome : A -s> option A := mkMorph (fun a => Some a) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+  Program Definition moptionbind (f : A -s> option B) : option A -s> option B :=
+    mkMorph (fun oa => match oa with None => None | Some a => f a end) _.
+  Next Obligation.
+    admit.
+  Defined.
+
+End OptDefs.
+
+Generalizable Variables Frm.
+
+Class ILogicOps Frm := {
+                        lentails: relation Frm;
+                        ltrue: Frm;
+                        lfalse: Frm;
+                        limpl: Frm -> Frm -> Frm;
+                        land: Frm -> Frm -> Frm;
+                        lor: Frm -> Frm -> Frm;
+                        lforall: forall {T}, (T -> Frm) -> Frm;
+                        lexists: forall {T}, (T -> Frm) -> Frm
+                      }.
+
+Infix "|--"  := lentails (at level 79, no associativity).
+Infix "//\\"   := land (at level 75, right associativity).
+Infix "\\//"   := lor (at level 76, right associativity).
+Infix "-->>"   := limpl (at level 77, right associativity).
+Notation "'Forall' x .. y , p" :=
+  (lforall (fun x => .. (lforall (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity).
+Notation "'Exists' x .. y , p" :=
+  (lexists (fun x => .. (lexists (fun y => p)) .. )) (at level 78, x binder, y binder, right associativity).
+
+Class ILogic Frm {ILOps: ILogicOps Frm} := {
+                                            lentailsPre:> PreOrder lentails;
+                                            ltrueR: forall C, C |-- ltrue;
+                                            lfalseL: forall C, lfalse |-- C;
+                                            lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C;
+                                            lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P;
+                                            lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C;
+                                            lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P;
+                                            landL1: forall P Q C, P |-- C  ->  P //\\ Q |-- C;
+                                            landL2: forall P Q C, Q |-- C  ->  P //\\ Q |-- C;
+                                            lorR1:  forall P Q C, C |-- P  ->  C |-- P \\// Q;
+                                            lorR2:  forall P Q C, C |-- Q  ->  C |-- P \\// Q;
+                                            landR:  forall P Q C, C |-- P  ->  C |-- Q  ->  C |-- P //\\ Q;
+                                            lorL:   forall P Q C, P |-- C  ->  Q |-- C  ->  P \\// Q |-- C;
+                                            landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q;
+                                            limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q)
+                                          }.
+Hint Extern 0 (?x |-- ?x) => reflexivity.
+
+Section ILogicExtra.
+  Context `{IL: ILogic Frm}.
+  Definition lpropand (p: Prop) Q := Exists _: p, Q.
+  Definition lpropimpl (p: Prop) Q := Forall _: p, Q.
+
+End ILogicExtra.
+
+Infix "/\\" := lpropand (at level 75, right associativity).
+Infix "->>" := lpropimpl (at level 77, right associativity).
+
+Section ILogic_Fun.
+  Context (T: Type) `{TType: type T}.
+  Context `{IL: ILogic Frm}.
+
+  Record ILFunFrm := mkILFunFrm {
+                         ILFunFrm_pred :> T -> Frm;
+                         ILFunFrm_closed: forall t t': T, t === t' ->
+                                                          ILFunFrm_pred t |-- ILFunFrm_pred t'
+                       }.
+
+  Notation "'mk'" := @mkILFunFrm.
+
+  Program Definition ILFun_Ops : ILogicOps ILFunFrm := {|
+                                                        lentails P Q := forall t:T, P t |-- Q t;
+                                                        ltrue        := mk (fun t => ltrue) _;
+                                                        lfalse       := mk (fun t => lfalse) _;
+                                                        limpl    P Q := mk (fun t => P t -->> Q t) _;
+                                                        land     P Q := mk (fun t => P t //\\ Q t) _;
+                                                        lor      P Q := mk (fun t => P t \\// Q t) _;
+                                                        lforall  A P := mk (fun t => Forall a, P a t) _;
+                                                        lexists  A P := mk (fun t => Exists a, P a t) _
+                                                      |}.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+
+End ILogic_Fun.
+
+Implicit Arguments ILFunFrm [[ILOps] [e]].
+Implicit Arguments mkILFunFrm [T Frm ILOps].
+
+Program Definition ILFun_eq {T R} {ILOps: ILogicOps R} {ILogic: ILogic R} (P : T -> R) :
+  @ILFunFrm T _ R ILOps :=
+  @mkILFunFrm T eq R ILOps P _.
+Next Obligation.
+  admit.
+Defined.
+
+Instance ILogicOps_Prop : ILogicOps Prop | 2 := {|
+                                                 lentails P Q := (P : Prop) -> Q;
+                                                 ltrue        := True;
+                                                 lfalse       := False;
+                                                 limpl    P Q := P -> Q;
+                                                 land     P Q := P /\ Q;
+                                                 lor      P Q := P \/ Q;
+                                                 lforall  T F := forall x:T, F x;
+                                                 lexists  T F := exists x:T, F x
+                                               |}.
+
+Instance ILogic_Prop : ILogic Prop.
+admit.
+Defined.
+
+Section FunEq.
+  Context A `{eT: type A}.
+
+  Global Instance FunEquiv {T} : Equiv (T -> A) := {
+                                                    equiv P Q := forall a, P a === Q a
+                                                  }.
+End FunEq.
+
+Section SepAlgSect.
+  Class SepAlgOps T `{eT : type T}:= {
+                                      sa_unit : T;
+
+                                      sa_mul : T -> T -> T -> Prop
+                                    }.
+
+  Class SepAlg T `{SAOps: SepAlgOps T} : Type := {
+                                                  sa_mul_eqL a b c d : sa_mul a b c -> c === d -> sa_mul a b d;
+                                                  sa_mul_eqR a b c d : sa_mul a b c -> sa_mul a b d -> c === d;
+                                                  sa_mon a b c   : a === b -> sa_mul a c === sa_mul b c;
+                                                  sa_mulC a b        : sa_mul a b === sa_mul b a;
+                                                  sa_mulA a b c      : forall bc abc, sa_mul a bc abc -> sa_mul b c bc ->
+                                                                                      exists ac, sa_mul b ac abc /\ sa_mul a c ac;
+                                                  sa_unitI a         : sa_mul a sa_unit a
+                                                }.
+
+End SepAlgSect.
+
+Section BILogic.
+
+  Class BILOperators (A : Type) := {
+                                    empSP : A;
+                                    sepSP : A -> A -> A;
+                                    wandSP : A -> A -> A
+                                  }.
+
+End BILogic.
+
+Notation "a '**' b"  := (sepSP a b)
+                          (at level 75, right associativity).
+
+Section BISepAlg.
+  Context {A} `{sa : SepAlg A}.
+  Context {B} `{IL: ILogic B}.
+
+  Program Instance SABIOps: BILOperators (ILFunFrm A B) := {
+                                                            empSP := mkILFunFrm e (fun x => sa_unit === x /\\ ltrue) _;
+                                                            sepSP P Q := mkILFunFrm e (fun x => Exists x1, Exists x2, sa_mul x1 x2 x /\\
+                                                                                                                             P x1 //\\ Q x2) _;
+                                                            wandSP P Q := mkILFunFrm e (fun x => Forall x1, Forall x2, sa_mul x x1 x2 ->>
+                                                                                                                              P x1 -->> Q x2) _
+                                                          }.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+  Next Obligation.
+    admit.
+  Defined.
+
+End BISepAlg.
+
+Set Implicit Arguments.
+
+Definition Chan := WORD.
+Definition Data := BYTE.
+
+Inductive Action :=
+| Out (c:Chan) (d:Data)
+| In (c:Chan) (d:Data).
+
+Definition Actions := list Action.
+
+Instance ActionsEquiv : Equiv Actions := {
+                                          equiv a1 a2 := a1 = a2
+                                        }.
+
+Definition OPred := ILFunFrm Actions Prop.
+Definition mkOPred (P : Actions -> Prop) : OPred.
+  admit.
+Defined.
+
+Definition eq_opred s := mkOPred (fun s' => s === s').
+Definition empOP : OPred.
+  exact (eq_opred nil).
+Defined.
+Definition catOP (P Q: OPred) : OPred.
+  admit.
+Defined.
+
+Class IsPointed (T : Type) := point : T.
+
+Generalizable All Variables.
+
+Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)).
+
+Record PointedOPred := mkPointedOPred {
+                           OPred_pred :> OPred;
+                           OPred_inhabited: IsPointed_OPred OPred_pred
+                         }.
+
+Existing Instance OPred_inhabited.
+
+Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred
+  := {| OPred_pred := O ; OPred_inhabited := _ |}.
+Instance IsPointed_eq_opred x : IsPointed_OPred (eq_opred x).
+admit.
+Defined.
+Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q).
+admit.
+Defined.
+
+Definition Flag  := BITS 5.
+Definition OF: Flag.
+  admit.
+Defined.
+
+Inductive FlagVal := mkFlag (b: bool) | FlagUnspecified.
+Coercion mkFlag : bool >-> FlagVal.
+Inductive NonSPReg := EAX | EBX | ECX | EDX | ESI | EDI | EBP.
+
+Inductive Reg := nonSPReg (r: NonSPReg) | ESP.
+
+Inductive AnyReg := regToAnyReg (r: Reg) | EIP.
+
+Inductive BYTEReg := AL|BL|CL|DL|AH|BH|CH|DH.
+
+Inductive WORDReg := mkWordReg (r:Reg).
+Definition PState : Type.
+admit.
+Defined.
+
+Instance PStateEquiv : Equiv PState.
+admit.
+Defined.
+
+Instance PStateType : type PState.
+admit.
+Defined.
+
+Instance PStateSepAlgOps: SepAlgOps PState.
+admit.
+Defined.
+Definition SPred : Type.
+exact (ILFunFrm PState Prop).
+Defined.
+
+Local Existing Instance ILFun_Ops.
+Local Existing Instance SABIOps.
+Axiom BYTEregIs : BYTEReg -> BYTE -> SPred.
+
+Inductive RegOrFlag :=
+| RegOrFlagDWORD :> AnyReg -> RegOrFlag
+| RegOrFlagWORD :> WORDReg -> RegOrFlag
+| RegOrFlagBYTE :> BYTEReg -> RegOrFlag
+| RegOrFlagF :> Flag -> RegOrFlag.
+
+Definition RegOrFlag_target rf :=
+  match rf with
+    | RegOrFlagDWORD _ => DWORD
+    | RegOrFlagWORD _  => WORD
+    | RegOrFlagBYTE _  => BYTE
+    | RegOrFlagF _     => FlagVal
+  end.
+
+Inductive Condition :=
+| CC_O | CC_B | CC_Z | CC_BE | CC_S | CC_P | CC_L | CC_LE.
+
+Section ILSpecSect.
+
+  Axiom spec : Type.
+  Global Instance ILOps: ILogicOps spec | 2.
+  admit.
+  Defined.
+
+End ILSpecSect.
+
+Axiom parameterized_basic : forall {T_OPred} {proj : T_OPred -> OPred} {T} (P : SPred) (c : T) (O : OPred) (Q : SPred), spec.
+Global Notation loopy_basic := (@parameterized_basic PointedOPred OPred_pred _).
+
+Axiom program : Type.
+
+Axiom ConditionIs : forall (cc : Condition) (cv : RegOrFlag_target OF), SPred.
+
+Axiom foldl : forall {T R}, (R -> T -> R) -> R -> list T -> R.
+Axiom nth : forall {T}, T -> list T -> nat -> T.
+Axiom while : forall (ptest: program)
+                     (cond: Condition) (value: bool)
+                     (pbody: program), program.
+
+Lemma while_rule_ind {quantT}
+      {ptest} {cond : Condition} {value : bool} {pbody}
+      {S}
+      {transition_body : quantT -> quantT}
+      {P : quantT -> SPred} {Otest : quantT -> OPred} {Obody : quantT -> OPred} {O : quantT -> PointedOPred}
+      {O_after_test : quantT -> PointedOPred}
+      {I_state : quantT -> bool -> SPred}
+      {I_logic : quantT -> bool -> bool}
+      {Q : quantT -> SPred}
+      (Htest : S |-- (Forall (x : quantT),
+                      (loopy_basic (P x)
+                                   ptest
+                                   (Otest x)
+                                   (Exists b, I_logic x b = true /\\ I_state x b ** ConditionIs cond b))))
+      (Hbody : S |-- (Forall (x : quantT),
+                      (loopy_basic (I_logic x value = true /\\ I_state x value ** ConditionIs cond value)
+                                   pbody
+                                   (Obody x)
+                                   (P (transition_body x)))))
+      (H_after_test : forall x, catOP (Otest x) (O_after_test x) |-- O x)
+      (H_body_after_test : forall x, I_logic x value = true -> catOP (Obody x) (O (transition_body x)) |-- O_after_test x)
+      (H_empty : forall x, I_logic x (negb value) = true -> empOP |-- O_after_test x)
+      (Q_correct : forall x, I_logic x (negb value) = true /\\ I_state x (negb value) ** ConditionIs cond (negb value) |-- Q x)
+      (Q_safe : forall x, I_logic x value = true -> Q (transition_body x) |-- Q x)
+: S |-- (Forall (x : quantT),
+         loopy_basic (P x)
+                     (while ptest cond value pbody)
+                     (O x)
+                     (Q x)).
+admit.
+Defined.
+Axiom behead : forall {T}, list T -> list T.
+Axiom all : forall {T}, (T -> bool) -> list T -> bool.
+Axiom all_behead : forall {T} (xs : list T) P, all P xs = true -> all P (behead xs) = true.
+Instance IsPointed_foldlOP A B C f g (init : A * B) `{IsPointed_OPred (g init)}
+         `{forall a acc, IsPointed_OPred (g acc) -> IsPointed_OPred (g (f acc a))}
+         (ls : list C)
+: IsPointed_OPred (g (foldl f init ls)).
+admit.
+Defined.
+Goal    forall (ptest : program) (cond : Condition) (value : bool)
+               (pbody : program) (T ioT : Type) (P : T -> SPred)
+               (I : T -> bool -> SPred) (accumulate : T -> ioT -> T)
+               (Otest Obody : T -> ioT -> PointedOPred)
+               (coq_test__is_finished : ioT -> bool) (S : spec)
+               (al : BYTE),
+          (forall (initial : T) (xs : list ioT) (x : ioT),
+             all (fun t : ioT => negb (coq_test__is_finished t)) xs = true ->
+             coq_test__is_finished x = true ->
+             S
+               |-- loopy_basic (P initial ** BYTEregIs AL al) ptest
+               (Otest initial (nth x xs 0))
+               (I initial
+                  (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end) **
+                  ConditionIs cond
+                  (match coq_test__is_finished (nth x xs 0) with true => negb value | false => value end))) ->
+          (forall (initial : T) (xs : list ioT) (x : ioT),
+             all (fun t : ioT => negb (coq_test__is_finished t)) xs = true ->
+             xs <> nil ->
+             coq_test__is_finished x = true ->
+             S
+               |-- loopy_basic (I initial value ** ConditionIs cond value) pbody
+               (Obody initial (nth x xs 0))
+               (P (accumulate initial (nth x xs 0)) ** BYTEregIs AL al)) ->
+          forall x : ioT,
+            coq_test__is_finished x = true ->
+            S
+              |-- Forall ixsp : {init_xs : T * list ioT &
+                                           all (fun t : ioT => negb (coq_test__is_finished t))
+                                               (snd init_xs) = true},
+  loopy_basic (P (fst (projT1 ixsp)) ** BYTEregIs AL al)
+              (while ptest cond value pbody)
+              (catOP
+                 (snd
+                    (foldl
+                       (fun (xy : T * OPred) (v : ioT) =>
+                          (accumulate (fst xy) v,
+                           catOP (catOP (Otest (fst xy) v) (Obody (fst xy) v))
+                                 (snd xy))) (fst (projT1 ixsp), empOP)
+                       (snd (projT1 ixsp))))
+                 (Otest (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp)))
+                        x))
+              (I (foldl accumulate (fst (projT1 ixsp)) (snd (projT1 ixsp)))
+                 (negb value) ** ConditionIs cond (negb value)).
+  intros.
+  eapply @while_rule_ind
+  with (I_logic := fun ixsp b => match (match (coq_test__is_finished (nth x (snd (projT1 ixsp)) 0)) with true => negb value | false => value end), b with true, true => true | false, false => true | _, _ => false end)
+         (Otest := fun ixsp => Otest (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0))
+         (Obody := fun ixsp => Obody (fst (projT1 ixsp)) (nth x (snd (projT1 ixsp)) 0))
+         (I_state := fun ixsp => I (fst (projT1 ixsp)))
+         (transition_body := fun ixsp => let initial := fst (projT1 ixsp) in
+                                         let xs := snd (projT1 ixsp) in
+                                         existT _ (accumulate initial (nth x xs 0), behead xs) _)
+         (O_after_test := fun ixsp => let initial := fst (projT1 ixsp) in
+                                      let xs := snd (projT1 ixsp) in
+                                      match xs with | nil => default_PointedOPred empOP | _ => Obody initial (nth x xs 0) end);
+    simpl projT1; simpl projT2; simpl fst; simpl snd; clear; let H := fresh in assert (H : False) by (clear; admit); destruct H.
+
+  Grab Existential Variables.
+  subst_body; simpl.
+  refine (all_behead (projT2 _)).
diff --git a/test-suite/bugs/closed/3648.v b/test-suite/bugs/closed/3648.v
new file mode 100644
index 00000000..ba6006ed
--- /dev/null
+++ b/test-suite/bugs/closed/3648.v
@@ -0,0 +1,83 @@
+(* File reduced by coq-bug-finder from original input, then from 8808 lines to 424 lines, then from 432 lines to 196 lines, then from\
+ 145 lines to 82 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *)
+
+Reserved Infix "o" (at level 40, left associativity).
+Global Set Primitive Projections.
+
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+
+    identity : forall x, morphism x x;
+    compose : forall s d d',
+                morphism d d'
+                -> morphism s d
+                -> morphism s d'
+    where "f 'o' g" := (compose f g)
+  }.
+Arguments identity {!C%category} / x%object : rename.
+
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+
+Local Open Scope morphism_scope.
+Definition prodC (C D : PreCategory) : PreCategory.
+  refine (@Build_PreCategory
+            (C * D)%type
+            (fun s d => (morphism C (fst s) (fst d)
+                         * morphism D (snd s) (snd d))%type)
+            (fun x => (identity (fst x), identity (snd x)))
+            (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))).
+Defined.
+
+Local Infix "*" := prodC : category_scope.
+
+Delimit Scope functor_scope with functor.
+
+Record Functor (C D : PreCategory) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d);
+    identity_of : forall x, morphism_of _ _ (identity x)
+                            = identity (object_of x)
+  }.
+Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+Axiom cheat : forall {A}, A.
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+Definition functor_category (C D : PreCategory) : PreCategory.
+  exact (@Build_PreCategory (Functor C D)
+                            (@NaturalTransformation C D) cheat cheat).
+Defined.
+
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Variable C1 : PreCategory.
+Variable C2 : PreCategory.
+Variable D : PreCategory.
+
+Definition functor_object_of
+: (C1 -> (C2 -> D))%category -> (C1 * C2 -> D)%category.
+Proof.
+  intro F; hnf in F |- *.
+  refine (Build_Functor
+            (prodC C1 C2) D
+            (fun c1c2 => F (fst c1c2) (snd c1c2))
+            (fun s d m => F (fst d) _1 (snd m) o (@morphism_of _ _ F _ _ (fst m)) (snd s))
+            _).
+  intros.
+  rewrite identity_of.
+  cbn.
+  rewrite (identity_of _ _ F (fst x)).
+  Undo.
+(* Toplevel input, characters 20-55:
+Error:
+Found no subterm matching "F _1 (identity (fst x))" in the current goal. *)
+  rewrite identity_of. (* Toplevel input, characters 15-34:
+Error:
+Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3652.v b/test-suite/bugs/closed/3652.v
new file mode 100644
index 00000000..86e06137
--- /dev/null
+++ b/test-suite/bugs/closed/3652.v
@@ -0,0 +1,101 @@
+Require Setoid.
+Require ZArith.
+Import ZArith.
+
+Inductive Erasable(A : Set) : Prop :=
+  erasable: A -> Erasable A.
+
+Arguments erasable [A] _.
+
+Hint Constructors Erasable.
+
+Scheme Erasable_elim := Induction for Erasable Sort Prop.
+
+Notation "## T" := (Erasable T) (at level 1, format "## T") : Erasable_scope.
+Notation "# x" := (erasable x) (at level 1, format "# x") : Erasable_scope.
+Open Scope Erasable_scope.
+
+Axiom Erasable_inj : forall {A : Set}{a b : A}, #a=#b -> a=b.
+
+Lemma Erasable_rw : forall (A: Set)(a b : A), (#a=#b) <-> (a=b).
+Proof.
+  intros A a b.
+  split.
+  - apply Erasable_inj.
+  - congruence.
+Qed.
+
+Open Scope Z_scope.
+Opaque Z.mul.
+
+Infix "^" := Zpower_nat : Z_scope.
+
+Notation "f ; v <- x" := (let (v) := x in f)
+                            (at level 199, left associativity) : Erasable_scope.
+Notation "f ; < v" := (f ; v <- v)
+                         (at level 199, left associativity) : Erasable_scope.
+Notation "f |# v <- x" := (#f ; v <- x)
+                          (at level 199, left associativity) : Erasable_scope.
+Notation "f |# < v" := (#f ; < v)
+                          (at level 199, left associativity) : Erasable_scope.
+
+Ltac name_evars id := 
+  repeat match goal with |- context[?V] => 
+                         is_evar V; let H := fresh id in set (H:=V) in * end.
+
+Lemma Twoto0 : 2^0 = 1.
+Proof. compute. reflexivity. Qed.
+
+Ltac ring_simplify' := rewrite ?Twoto0; ring_simplify.
+
+Definition mp2a1s(x : Z)(n : nat) := x * 2^n + (2^n-1).
+
+Hint Unfold mp2a1s.
+
+Definition zotval(n1s : nat)(is2 : bool)(next_value : Z) : Z :=
+  2 * mp2a1s next_value n1s + if is2 then 2 else 0.
+
+Inductive zot'(eis2 : ##bool)(value : ##Z) : Set :=
+| Zot'(is2 : bool)
+      (iseq : eis2=#is2)
+      {next_is2 : ##bool}
+      (ok : is2=true -> next_is2=#false)
+      {next_value : ##Z}
+      (n1s : nat)
+      (veq : value = (zotval n1s is2 next_value |#<next_value))
+      (next : zot' next_is2 next_value)
+  : zot' eis2 value.
+
+Definition de2{eis2 value}(z : zot' eis2 value) : zot' #false value.
+Proof.
+  case z.
+  intros is2 iseq next_is2 ok next_value n1s veq next. 
+  subst.
+  destruct is2.
+  2:trivial.
+  clear z.
+  specialize (ok eq_refl). subst.
+  destruct n1s.
+  - refine (Zot' _ _ _ _ _ _ _ _).
+    all:shelve_unifiable.
+    reflexivity.
+    discriminate.
+    name_evars e.
+    case_eq next_value. intros next_valueU next_valueEU.
+    case_eq e. intros eU eEU.
+    f_equal.
+    unfold zotval.
+    unfold mp2a1s.
+    ring_simplify'.
+    replace 2 with (2*1) at 2 7 by omega.
+    rewrite <-?Z.mul_assoc.
+    rewrite <-?Z.mul_add_distr_l.
+    rewrite <-Z.mul_sub_distr_l.
+    rewrite Z.mul_cancel_l by omega.
+    replace 1 with (2-1) at 1 by omega.
+    rewrite Z.add_sub_assoc.
+    rewrite Z.sub_cancel_r.
+    Unshelve.
+    all:case_eq next.
+Abort.
+
diff --git a/test-suite/bugs/closed/3653.v b/test-suite/bugs/closed/3653.v
new file mode 100644
index 00000000..947b3601
--- /dev/null
+++ b/test-suite/bugs/closed/3653.v
@@ -0,0 +1,12 @@
+Require Setoid.
+
+Variables P Q : forall {T : Set}, T -> Prop.
+
+Lemma rule{T : Set}{x : T} : Q x <-> P x. admit. Qed.
+
+Goal forall (T : Set)(x : T), Q x <-> P x.
+Proof.
+intros T x.
+setoid_rewrite rule.
+reflexivity.
+Qed.
diff --git a/test-suite/bugs/closed/3654.v b/test-suite/bugs/closed/3654.v
new file mode 100644
index 00000000..15277235
--- /dev/null
+++ b/test-suite/bugs/closed/3654.v
@@ -0,0 +1,7 @@
+Tactic Notation "mysimpl" "in" ne_hyp_list(hyps) := simpl in hyps.
+
+Goal 0+0=0->0+0=0->0=0.
+intros H1 H2.
+mysimpl in H1 H2.
+match goal with H:0=0 |- _ => exact H end.
+Qed.
diff --git a/test-suite/bugs/closed/3656.v b/test-suite/bugs/closed/3656.v
new file mode 100644
index 00000000..cbd773d0
--- /dev/null
+++ b/test-suite/bugs/closed/3656.v
@@ -0,0 +1,53 @@
+Module A.
+  Set Primitive Projections.
+  Record hSet : Type := BuildhSet { setT : Type;  iss : True }.
+  Ltac head_hnf_under_binders x :=
+  match eval hnf in x with
+    | ?f _ => head_hnf_under_binders f
+    | (fun y => ?f y) => head_hnf_under_binders f
+    | ?y => y
+  end.
+Goal forall s : hSet, True.
+intros. 
+let x := head_hnf_under_binders setT in pose x.
+
+set (foo := eq_refl (@setT )). generalize foo. simpl. cbn. 
+Abort.
+End A.
+
+Module A'.
+Set Universe Polymorphism.
+ Set Primitive Projections.
+Record hSet (A : Type) : Type := BuildhSet { setT : Type;  iss : True }.
+Ltac head_hnf_under_binders x :=
+  match eval compute in x with
+    | ?f _ => head_hnf_under_binders f
+    | (fun y => ?f y) => head_hnf_under_binders f
+    | ?y => y
+  end.
+Goal forall s : @hSet nat, True.
+intros.
+let x := head_hnf_under_binders setT in pose x.
+
+set (foo := eq_refl (@setT nat)). generalize foo. simpl. cbn. 
+Abort.
+End A'.
+
+Set Primitive Projections.
+Record hSet : Type := BuildhSet { setT : Type;  iss : True }.
+Ltac head_hnf_under_binders x :=
+  match eval hnf in x with
+    | ?f _ => head_hnf_under_binders f
+    | (fun y => ?f y) => head_hnf_under_binders f
+    | ?y => y
+  end.
+Goal setT = setT.
+ progress unfold setT. (* should not succeed *)
+ match goal with
+    | |- (fun h => setT h) = (fun h => setT h) => fail 1 "should not eta-expand"
+    | _ => idtac
+  end. (* should not fail *)
+Abort.
+
+Goal forall h, setT h = setT h.
+Proof. intro. progress unfold setT. 
diff --git a/test-suite/bugs/closed/3657.v b/test-suite/bugs/closed/3657.v
new file mode 100644
index 00000000..778fdab1
--- /dev/null
+++ b/test-suite/bugs/closed/3657.v
@@ -0,0 +1,12 @@
+(* Check typing of replaced objects in change - even though the failure
+   was already a proper error message (but with a helpless content) *)
+
+Class foo {A} {a : A} := { bar := a; baz : bar = bar }.
+Arguments bar {_} _ {_}.
+Instance: forall A a, @foo A a.
+intros; constructor.
+abstract reflexivity.
+Defined.
+Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat.
+Proof.
+  Fail change (bar (fun _ : Set => Set)) with (bar Set).
diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v
new file mode 100644
index 00000000..b1158b9a
--- /dev/null
+++ b/test-suite/bugs/closed/3658.v
@@ -0,0 +1,74 @@
+(* File reduced by coq-bug-finder from original input, then from 12178 lines to 457 lines, then from 500 lines to 147 lines, then from 175 lines to 56 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 21 2014 16:34:4 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (eaf864354c3fda9ddc1f03f0b1c7807b6fd44322) *)
+
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
+Module NonPrim.
+  Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
+  Arguments center A {_} / .
+  Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index).
+  Notation "-2" := minus_two (at level 0).
+  Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+    match n with
+      | -2 => Contr_internal A
+      | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+    end.
+  Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A.
+  Notation Contr := (IsTrunc -2).
+  Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+  Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type)
+              (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H)
+              (H5 : H0 (H4 (center H1)) (H4 H3))
+              (H6 : H0 (H4 (center H1)) (H4 (center H1))),
+         transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5.
+    intros.
+    match goal with
+      | [ |- context[contr (center _)] ] => fail 1 "bad"
+      | _ => idtac
+    end.
+    match goal with
+      | [ H : _ |- _ ] => destruct (contr H)
+    end.
+    match goal with
+      | [ |- context[contr (center ?x)] ] => fail 1 "bad" x
+      | _ => idtac
+    end.
+    admit.
+  Defined.
+End NonPrim.
+
+Module Prim.
+  Set Primitive Projections.
+  Class Contr_internal (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
+  Arguments center A {_} / .
+  Inductive trunc_index : Type := minus_two | trunc_S (_ : trunc_index).
+  Notation "-2" := minus_two (at level 0).
+  Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+    match n with
+      | -2 => Contr_internal A
+      | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+    end.
+  Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A.
+  Notation Contr := (IsTrunc -2).
+  Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+  Goal forall (H : Type) (H0 : H -> H -> Type) (H1 : Type)
+              (H2 : Contr H1) (H3 : H1) (H4 : H1 -> H)
+              (H5 : H0 (H4 (center H1)) (H4 H3))
+              (H6 : H0 (H4 (center H1)) (H4 (center H1))),
+         transport (fun y : H => H0 (H4 (center H1)) y) (ap H4 (contr H3)) H6 = H5.
+    intros.
+    match goal with
+      | [ |- context[contr (center _)] ] => fail 1 "bad"
+      | _ => idtac
+    end.
+    match goal with
+      | [ H : _ |- _ ] => destruct (contr H)
+    end.
+    match goal with
+      | [ |- context[contr (center ?x)] ] => fail 1 "bad" x
+      | _ => idtac
+    end. (* Error: Tactic failure: bad H1. *)
+    admit.
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3660.v b/test-suite/bugs/closed/3660.v
new file mode 100644
index 00000000..ed8964ce
--- /dev/null
+++ b/test-suite/bugs/closed/3660.v
@@ -0,0 +1,27 @@
+Generalizable All Variables.
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+Axiom IsHSet : Type -> Type.
+Instance isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} : IsEquiv (compose g f) | 1000.
+admit.
+Defined.
+Set Primitive Projections.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+Global Instance isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y).
+admit.
+Defined.
+Local Open Scope equiv_scope.
+Axiom equiv_path : forall (A B : Type) (p : A = B), A <~> B.
+
+Goal forall (C D : hSet), IsEquiv (fun x : C = D => (equiv_path C D (ap setT x))).
+  intros.
+  change (IsEquiv (equiv_path C D o @ap _ _ setT C D)).
+  apply @isequiv_compose; [ | admit ].
+  Set Typeclasses Debug. 
+  typeclasses eauto.
diff --git a/test-suite/bugs/closed/3661.v b/test-suite/bugs/closed/3661.v
new file mode 100644
index 00000000..fdca49bc
--- /dev/null
+++ b/test-suite/bugs/closed/3661.v
@@ -0,0 +1,88 @@
+(* File reduced by coq-bug-finder from original input, then from 11218 lines to 438 lines, then from 434 lines to 202 lines, then from 140 lines to 94 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Set Implicit Arguments.
+Delimit Scope morphism_scope with morphism.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Bind Scope category_scope with PreCategory.
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }.
+Set Primitive Projections.
+Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }.
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+Unset Primitive Projections.
+Class Isomorphic {C : PreCategory} s d :=
+  { morphism_isomorphic :> morphism C s d;
+    isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }.
+Arguments morphism_inverse {C s d} m {_} / .
+Local Notation "m ^-1" := (morphism_inverse m) (at level 3, format "m '^-1'") : morphism_scope.
+Definition functor_category (C D : PreCategory) : PreCategory.
+  exact (@Build_PreCategory (Functor C D)
+                            (@NaturalTransformation C D)).
+Defined.
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Generalizable All Variables.
+Definition isisomorphism_components_of `{@IsIsomorphism (C -> D) F G T} x : IsIsomorphism (T x).
+Proof.
+  constructor.
+  exact (T^-1 x).
+Defined.
+Hint Immediate isisomorphism_components_of : typeclass_instances.
+Goal forall (x3 x9 : PreCategory) (x12 f0 : Functor x9 x3)
+            (x35 : @Isomorphic (@functor_category x9 x3) f0 x12)
+            (x37 : object x9)
+            (H3 : morphism x3 (@object_of x9 x3 f0 x37)
+                           (@object_of x9 x3 f0 x37))
+            (x34 : @Isomorphic (@functor_category x9 x3) x12 f0)
+            (m : morphism x3 (x12 x37) (f0 x37) ->
+                 morphism x3 (f0 x37) (x12 x37) ->
+                 morphism x3 (f0 x37) (f0 x37)),
+       @paths
+         (morphism x3 (@object_of x9 x3 f0 x37) (@object_of x9 x3 f0 x37))
+         H3
+         (m
+            (@components_of x9 x3 x12 f0
+                            (@morphism_inverse (@functor_category x9 x3) f0 x12
+                                               (@morphism_isomorphic (@functor_category x9 x3) f0 x12 x35)
+                                               (@isisomorphism_isomorphic (@functor_category x9 x3) f0 x12
+                                                                          x35)) x37)
+            (@components_of x9 x3 f0 x12
+                            (@morphism_inverse (@functor_category x9 x3) x12 f0
+                                               (@morphism_isomorphic (@functor_category x9 x3) x12 f0 x34)
+                                               (@isisomorphism_isomorphic (@functor_category x9 x3) x12 f0
+                                                                          x34)) x37)).
+  Unset Printing All.
+  intros.
+  match goal with
+    | [ |- context[components_of ?T^-1 ?x] ]
+      => progress let T1 := constr:(T^-1 x) in
+                  let T2 := constr:((T x)^-1) in
+                  change T1 with T2 || fail 1 "too early"
+  end.
+
+  Undo.
+
+  match goal with
+    | [ |- context[components_of ?T^-1 ?x] ]
+      => progress let T1 := constr:(T^-1 x) in
+                  change T1 with ((T x)^-1) || fail 1 "too early 2"
+  end.
+
+  Undo.
+
+  match goal with
+    | [ |- context[components_of ?T^-1 ?x] ]
+      => progress let T2 := constr:((T x)^-1) in
+                  change (T^-1 x) with T2
+  end. (* not convertible *)
+
+(*
+
+  (@components_of x9 x3 x12 f0
+     (@morphism_inverse _ _ _
+        (@morphism_isomorphic (functor_category x9 x3) f0 x12 x35) _) x37)
+
+*)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3662.v b/test-suite/bugs/closed/3662.v
new file mode 100644
index 00000000..bd53389b
--- /dev/null
+++ b/test-suite/bugs/closed/3662.v
@@ -0,0 +1,47 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Record Elimination Schemes.
+Record prod A B := pair { fst : A ; snd : B }.
+Definition f : Set -> Type := fun x => x.
+
+Goal (fst (pair (fun x => x + 1) nat) 0) = 0.
+compute.
+Undo.
+cbv.
+Undo.
+Opaque fst.
+cbn.
+Transparent fst.
+cbn.
+Undo.
+simpl.
+Undo.
+Abort.
+
+Goal f (fst (pair nat nat)) = nat.
+compute.
+  match goal with
+    | [ |- fst ?x = nat ] => fail 1 "compute failed"
+    | [ |- nat = nat ] => idtac
+  end.
+  reflexivity.
+Defined.
+
+Goal fst (pair nat nat) = nat.
+  unfold fst. 
+  match goal with
+    | [ |- fst ?x = nat ] => fail 1 "compute failed"
+    | [ |- nat = nat ] => idtac
+  end.
+  reflexivity.
+Defined.
+
+Lemma eta A B : forall x : prod A B, x = pair (fst x) (snd x). reflexivity. Qed.
+
+Goal forall x : prod nat nat, fst x = 0.
+  intros. unfold fst.
+  Fail match goal with
+    | [ |- fst ?x = 0 ] => idtac
+  end.
+Abort.
+
diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v
new file mode 100644
index 00000000..41de74ff
--- /dev/null
+++ b/test-suite/bugs/closed/3664.v
@@ -0,0 +1,23 @@
+Module NonPrim.
+  Unset Primitive Projections.
+  Record c := { d : Set }.
+  Definition a x := d x.
+  Goal forall x, a x.
+    intro x.
+    Fail progress simpl. (* [progress simpl] fails correctly *)
+    Fail progress cbn. (* [progress cbn] fails correctly *)
+    admit.
+  Defined.
+End NonPrim.
+
+Module Prim.
+  Set Primitive Projections.
+  Record c := { d : Set }.
+  Definition a x := d x.
+  Goal forall x, a x.
+    intro x.
+    Fail progress simpl. (* [progress simpl] fails correctly *)
+    Fail progress cbn. (* [cbn] succeeds incorrectly, giving [d x] *)
+    admit.
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3665.v b/test-suite/bugs/closed/3665.v
new file mode 100644
index 00000000..f6a13596
--- /dev/null
+++ b/test-suite/bugs/closed/3665.v
@@ -0,0 +1,33 @@
+(* File reduced by coq-bug-finder from original input, then from 5449 lines to 44 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
+   coqtop version trunk (September 2014) *)
+Set Primitive Projections.
+
+Axiom IsHSet : Type -> Type.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+
+Module withdefault.
+Canonical Structure default_HSet := fun T P => (@BuildhSet T P).
+Goal forall (z : hSet) (T0 : Type -> Type),
+       (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) ->
+       forall x0 : setT z, Set.
+  clear; intros z T H.
+  Set Debug Unification.
+  Fail refine (H _ _). (* Timeout! *)
+Abort.
+End withdefault.
+
+Module withnondefault.
+Variable T0 : Type -> Type.
+Variable T0hset: forall A, IsHSet (T0 A).
+
+Canonical Structure nondefault_HSet := fun A =>(@BuildhSet (T0 A) (T0hset A)).
+Canonical Structure default_HSet := fun A P =>(@BuildhSet A P).
+Goal forall (z : hSet) (T0 : Type -> Type),
+       (forall (A : Type) (P : T0 A -> Type) (aa : T0 A), P aa) ->
+       forall x0 : setT z, Set.
+  clear; intros z T H.
+  Set Debug Unification.
+  Fail refine (H _ _). (* Timeout! *)
+Abort.
+End withnondefault.
diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v
new file mode 100644
index 00000000..a5b0e934
--- /dev/null
+++ b/test-suite/bugs/closed/3666.v
@@ -0,0 +1,50 @@
+(* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)
+
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
+Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V.
+Module NonPrim.
+  Record hProp := hp { hproptype :> Type ; isp : Set}.
+  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
+              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
+         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
+    intros A B H_f H_g C h b a c H3 H'.
+    exact (@transport hProp (fun x => x) _ _ H' H3).
+    Undo.
+    Set Debug Unification.
+    exact (H' # H3).
+  Defined.
+End NonPrim.
+
+Module Prim.
+  Set Primitive Projections.
+  Set Universe Polymorphism.
+  Record hProp := hp { hproptype :> Type ; isp : Set}.
+  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
+              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
+         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
+    intros A B H_f H_g C h b a c H3 H'.
+    exact (@transport hProp (fun x => x) _ _ H' H3).
+    Undo.
+    Set Debug Unification.
+    exact (H' # H3).
+    (* Toplevel input, characters 7-14:
+Error:
+In environment
+A : Type
+B : Type
+H_f : A -> V -> hProp
+H_g : B -> V -> hProp
+C : Type
+h : C -> V
+b : B
+a : A
+c : C
+H3 : H_f a (h c)
+H' : H_f a (h c) = H_g b (h c)
+Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))".
+ *)
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3667.v b/test-suite/bugs/closed/3667.v
new file mode 100644
index 00000000..d2fc4d9b
--- /dev/null
+++ b/test-suite/bugs/closed/3667.v
@@ -0,0 +1,25 @@
+
+Set Primitive Projections.
+Axiom ap10 : forall {A B} {f g:A->B} (h:f=g) x, f x = g x.
+Axiom IsHSet : Type -> Type.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d) }.
+Set Implicit Arguments.
+Record NaturalTransformation C D (F G : Functor C D) :=
+  { components_of :> forall c, morphism D (F c) (G c);
+    commutes : forall s d (m : morphism C s d), components_of s = components_of s }.
+Definition set_cat : PreCategory.
+  exact ((@Build_PreCategory hSet
+                             (fun x y => x -> y))).
+Defined.
+Goal forall (A : PreCategory) (F : Functor A set_cat)
+            (a : A) (x : F a) (nt :NaturalTransformation F F), x = x.
+  intros. 
+  pose (fun c d m => ap10 (commutes nt c d m)).
+
+
diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v
new file mode 100644
index 00000000..547159b9
--- /dev/null
+++ b/test-suite/bugs/closed/3668.v
@@ -0,0 +1,53 @@
+(* File reduced by coq-bug-finder from original input, then from 6329 lines to 110 lines, then from 115 lines to 88 lines, then from 93 lines to 72 lines *)
+(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)
+
+Notation "( x ; y )" := (existT _ x y).
+Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Notation "A <~> B" := (Equiv A B) (at level 85).
+Axiom IsHProp : Type -> Type.
+Inductive Bool := true | false.
+Definition negb (b : Bool) := if b then false else true.
+Hypothesis LEM : forall A : Type, IsHProp A -> A + (A -> False).
+Axiom cheat : forall {A},A.
+Module NonPrim.
+  Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
+  Definition Book_6_9 : forall X, X -> X.
+  Proof.
+    intro X.
+    pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv.
+    destruct contrXEquiv as [[f H]|H]; [ exact f.1 | exact (fun x => x) ].
+  Defined.
+  Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b.
+  Proof.
+    unfold Book_6_9.
+    destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H'].
+    match goal with
+      | [ |- equiv_fun Bool Bool f.1 b  = negb b ] => idtac
+      | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad"
+    end.
+    all:admit.
+  Defined.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Class Contr (A : Type) := { center : A ; contr : (forall y : A, center = y) }.
+  Definition Book_6_9 : forall X, X -> X.
+  Proof.
+    intro X.
+    pose proof (@LEM (Contr { f : X <~> X & ~(forall x, f x = x) }) cheat) as contrXEquiv.
+    destruct contrXEquiv as [[f H]|H]; [ exact (f.1) | exact (fun x => x) ].
+  Defined.
+  Lemma Book_6_9_not_id b : Book_6_9 Bool b = negb b.
+  Proof.
+    unfold Book_6_9.
+    destruct (@LEM (Contr { f : Bool <~> Bool & ~(forall x, f x = x) }) _) as [[f H']|H']. 
+    match goal with
+      | [ |- equiv_fun Bool Bool f.1 b  = negb b ] => idtac
+      | [ |- equiv_fun Bool Bool center.1 b = negb b ] => fail 1 "bad"
+    end. (* Tactic failure: bad *)
+    all:admit.
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3670.v b/test-suite/bugs/closed/3670.v
new file mode 100644
index 00000000..c0f03261
--- /dev/null
+++ b/test-suite/bugs/closed/3670.v
@@ -0,0 +1,23 @@
+Set Universe Polymorphism.
+Module Type FOO.
+  Parameter f : Type -> Type.
+  Parameter h : forall T, f T.
+End FOO.
+
+Module Type BAR.
+  Include FOO.
+End BAR.
+
+Module Type BAZ.
+  Include FOO.
+End BAZ.
+
+Module BAR_FROM_BAZ (baz : BAZ) <: BAR.
+
+  Definition f : Type -> Type. 
+  Proof. exact baz.f. Defined.
+
+  Definition h : forall T, f T.
+  Admitted.
+
+Fail End BAR_FROM_BAZ.
diff --git a/test-suite/bugs/closed/3672.v b/test-suite/bugs/closed/3672.v
new file mode 100644
index 00000000..283be495
--- /dev/null
+++ b/test-suite/bugs/closed/3672.v
@@ -0,0 +1,27 @@
+Set Primitive Projections.  (* No failures without this option. *)
+
+Record AT :=
+{ atype :> Type
+; coerce : atype -> Type
+}.
+Coercion coerce : atype >-> Sortclass.
+
+Record Ar C (A:AT) := { ar : forall (X Y : C), A }.
+
+Definition t := forall C A a X, coerce _ (ar C A a X X).
+Definition t' := forall C A a X, ar C A a X X.
+
+(* The command has indeed failed with message:
+=> Error: The term "ar C A a X X" has type "atype A" which is not a (co-)inductive type.
+*)
+
+Record Ar2 C (A:AT) := 
+{ ar2 : forall (X Y : C), A
+; id2 : forall X, coerce _ (ar2 X X) }.
+
+Record Ar3 C (A:AT) := 
+{ ar3 : forall (X Y : C), A
+; id3 : forall X, ar3 X X }.
+(* The command has indeed failed with message:
+=> Anomaly: Bad recursive type. Please report.
+*)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3675.v b/test-suite/bugs/closed/3675.v
new file mode 100644
index 00000000..93227ab8
--- /dev/null
+++ b/test-suite/bugs/closed/3675.v
@@ -0,0 +1,20 @@
+Set Primitive Projections.
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+Local Open Scope path_scope.
+Local Open Scope equiv_scope.
+Generalizable Variables A B C f g.
+Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
+: IsEquiv (compose g f).
+Proof.
+  refine (Build_IsEquiv A C
+                        (compose g f)
+                        (compose f^-1 g^-1) _).
+  exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)).
diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v
new file mode 100644
index 00000000..b8c5b4d5
--- /dev/null
+++ b/test-suite/bugs/closed/3682.v
@@ -0,0 +1,5 @@
+Class Foo.
+Definition bar `{Foo} (x : Set) := Set.
+Instance: Foo.
+Definition bar1 := bar nat.
+Definition bar2 := bar $(admit)$.
diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v
new file mode 100644
index 00000000..94ce4a60
--- /dev/null
+++ b/test-suite/bugs/closed/3684.v
@@ -0,0 +1,4 @@
+Definition foo : Set.
+Proof.
+  refine ($(abstract admit)$).
+Qed.
diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v
new file mode 100644
index 00000000..ee6b334b
--- /dev/null
+++ b/test-suite/bugs/closed/3686.v
@@ -0,0 +1,62 @@
+Set Universe Polymorphism.
+Set Implicit Arguments.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Bind Scope category_scope with PreCategory.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
+    identity_of : forall s m, morphism_of s s m = morphism_of s s m }.
+Definition sub_pre_cat (P : PreCategory -> Type) : PreCategory.
+Proof.
+  exact (@Build_PreCategory PreCategory Functor).
+Defined.
+Definition opposite (C : PreCategory) : PreCategory.
+Proof.
+  exact (@Build_PreCategory C (fun s d => morphism C d s)).
+Defined.
+Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope.
+Definition prod (C D : PreCategory) : PreCategory.
+Proof.
+  refine (@Build_PreCategory
+            (C * D)%type
+            (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)).
+Defined.
+Local Infix "*" := prod : category_scope.
+Axiom functor_category : PreCategory -> PreCategory -> PreCategory.
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Module Export PointwiseCore.
+  Definition pointwise
+             (C C' : PreCategory)
+             (F : Functor C' C)
+             (D D' : PreCategory)
+             (G : Functor D D')
+  : Functor (C -> D) (C' -> D').
+  Proof.
+    refine (Build_Functor
+              (C -> D) (C' -> D')
+              _
+              _
+              _);
+    abstract admit.
+  Defined.
+End PointwiseCore.
+Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G.
+Local Open Scope category_scope.
+Definition functor_uncurried (P : PreCategory -> Type)
+           (has_functor_categories : forall C D : @sub_pre_cat P, P (C -> D))
+: object (((@sub_pre_cat P)^op * (@sub_pre_cat P)) -> (@sub_pre_cat P)).
+Proof.
+  pose (let object_of := (fun CD => (((fst CD) -> (snd CD))))
+        in Build_Functor
+             ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P)
+             object_of
+             (fun CD C'D' FG => pointwise (fst FG) (snd FG))
+             (fun _ _ => Pidentity_of _ _)) || fail "early".
+  Include PointwiseCore.
+  pose (let object_of := (fun CD => (((fst CD) -> (snd CD))))
+        in Build_Functor
+             ((@sub_pre_cat P)^op * (@sub_pre_cat P)) (@sub_pre_cat P)
+             object_of
+             (fun CD C'D' FG => pointwise (fst FG) (snd FG))
+             (fun _ _ => Pidentity_of _ _)).
+Abort.
diff --git a/test-suite/bugs/closed/3692.v b/test-suite/bugs/closed/3692.v
new file mode 100644
index 00000000..72973a8d
--- /dev/null
+++ b/test-suite/bugs/closed/3692.v
@@ -0,0 +1,26 @@
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
+Reserved Notation "x = y" (at level 70, no associativity).
+Reserved Notation "x * y" (at level 40, left associativity).
+Delimit Scope core_scope with core.
+Open Scope core_scope.
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
+Global Set Primitive Projections.
+Global Set Implicit Arguments.
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
+Generalizable Variables X A B f g n.
+Axiom path_prod' : forall {A B : Type} {x x' : A} {y y' : B}, (x = x') -> (y = y') -> ((x,y) = (x',y')).
+Definition functor_prod {A A' B B' : Type} (f:A->A') (g:B->B')
+: A * B -> A' * B'.
+  exact (fun z => (f (fst z), g (snd z))).
+Defined.
+Definition isequiv_functor_prod `{IsEquiv A A' f} `{IsEquiv B B' g}
+: IsEquiv (functor_prod f g)
+  := @Build_IsEquiv
+       _ _ (functor_prod f g) (functor_prod f^-1 g^-1)
+       (fun z => path_prod' (@eisretr _ _ f _ (fst z)) (@eisretr _ _ g _ (snd z))).
diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v
new file mode 100644
index 00000000..3c53d243
--- /dev/null
+++ b/test-suite/bugs/closed/3698.v
@@ -0,0 +1,25 @@
+(* File reduced by coq-bug-finder from original input, then from 5479 lines to 4682 lines, then from 4214 lines to 86 lines, then from 60 lines to 25 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *)
+Set Primitive Projections.
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation pr1 := projT1.
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }.
+Record Equiv A B := { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Global Existing Instance equiv_isequiv.
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+Axiom IsHSet : Type -> Type.
+Local Open Scope equiv_scope.
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+Axiom issig_hSet: (sigT IsHSet) <~> hSet.
+Definition isequiv_ap_setT X Y : IsEquiv (@ap _ _ setT X Y).
+Proof.
+  assert (H'' : forall g : X = Y -> (issig_hSet^-1 X).1 = (issig_hSet^-1 Y).1,
+                  g = g -> IsEquiv g) by admit.
+  Eval compute in (@projT1 Type IsHSet (@equiv_inv _ _ _ (equiv_isequiv _ _ issig_hSet) X)).
+  Fail apply H''. (* stack overflow *)
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v
new file mode 100644
index 00000000..99b3d79e
--- /dev/null
+++ b/test-suite/bugs/closed/3699.v
@@ -0,0 +1,162 @@
+(* File reduced by coq-bug-finder from original input, then from 9593 lines to 104 lines, then from 187 lines to 103 lines, then from 113 lines to 90 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 1 2014 18:13:54 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (68846802a7be637ec805a5e374655a426b5723a5) *)
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Inductive trunc_index := minus_two | trunc_S (_ : trunc_index).
+Axiom IsTrunc : trunc_index -> Type -> Type.
+Existing Class IsTrunc.
+Axiom Contr : Type -> Type.
+Inductive Trunc (n : trunc_index) (A :Type) : Type := tr : A -> Trunc n A.
+Module NonPrim.
+  Unset Primitive Projections.
+  Set Implicit Arguments.
+  Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+  Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
+  Unset Implicit Arguments.
+  Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+  Open Scope fibration_scope.
+  Notation pr1 := projT1.
+  Notation pr2 := projT2.
+  Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+  Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.
+  Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
+  Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A).
+  Axiom isconnected_elim : forall {n} {A} `{IsConnected n A}
+                                  (C : Type) `{IsTrunc n C} (f : A -> C),
+                             { c:C & forall a:A, f a = c }.
+  Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B)
+    := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b).
+  Definition conn_map_elim {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall b:B, P b.
+  Proof.
+    intros b.
+    refine (pr1 (isconnected_elim _ _)).
+    2:exact b.
+    intro x.
+    exact (transport P x.2 (d x.1)).
+  Defined.
+
+  Definition conn_map_elim' {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall b:B, P b.
+  Proof.
+    intros b.
+    refine (pr1 (isconnected_elim _ _)).
+    2:exact b.
+    intros [a p].
+    exact (transport P p (d a)).
+  Defined.
+
+  Definition conn_map_comp {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a.
+  Proof.
+    intros a.
+    unfold conn_map_elim, conn_map_elim'.
+    Set Printing Coercions.
+    set (fibermap := fun a0p : hfiber f (f a)
+                     => let (a0, p) := a0p in transport P p (d a0)).
+    Set Printing Implicit.
+    let G := match goal with |- ?G => constr:G end in
+    first [ match goal with
+              | [ |- (@isconnected_elim n (@hfiber A B f (f a))
+                                        (@isconnected_hfiber_conn_map n A B f H (f a))
+                                        (P (f a)) (HP (f a))
+                                        (fun x : @hfiber A B f (f a) =>
+                                           @transport B P (f x.1) (f a) x.2 (d x.1))).1 =
+                     d a /\ _ ] => idtac
+            end
+          | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ];
+      first [ match goal with
+                | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a))
+                                               (@isconnected_hfiber_conn_map n A B f H (f a))
+                                               (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac
+              end
+            | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ].
+    admit.
+  Defined.
+End NonPrim.
+
+Module Prim.
+  Set Primitive Projections.
+  Set Implicit Arguments.
+  Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+  Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
+  Unset Implicit Arguments.
+  Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+  Open Scope fibration_scope.
+  Notation pr1 := projT1.
+  Notation pr2 := projT2.
+  Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+  Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope.
+  Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
+  Class IsConnected (n : trunc_index) (A : Type) := isconnected_contr_trunc :> Contr (Trunc n A).
+  Axiom isconnected_elim : forall {n} {A} `{IsConnected n A}
+                                  (C : Type) `{IsTrunc n C} (f : A -> C),
+                             { c:C & forall a:A, f a = c }.
+  Class IsConnMap (n : trunc_index) {A B : Type} (f : A -> B)
+    := isconnected_hfiber_conn_map :> forall b:B, IsConnected n (hfiber f b).
+  Definition conn_map_elim {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall b:B, P b.
+  Proof.
+    intros b.
+    refine (pr1 (isconnected_elim _ _)).
+    2:exact b.
+    intro x.
+    exact (transport P x.2 (d x.1)).
+  Defined.
+
+  Definition conn_map_elim' {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall b:B, P b.
+  Proof.
+    intros b.
+    refine (pr1 (isconnected_elim _ _)).
+    2:exact b.
+    intros [a p].
+    exact (transport P p (d a)).
+  Defined.
+
+  Definition conn_map_comp {n : trunc_index}
+             {A B : Type} (f : A -> B) `{IsConnMap n _ _ f}
+             (P : B -> Type) {HP : forall b:B, IsTrunc n (P b)}
+             (d : forall a:A, P (f a))
+  : forall a:A, conn_map_elim f P d (f a) = d a /\ conn_map_elim' f P d (f a) = d a.
+  Proof.
+    intros a.
+    unfold conn_map_elim, conn_map_elim'.
+    Set Printing Coercions.
+    set (fibermap := fun a0p : hfiber f (f a)
+                     => let (a0, p) := a0p in transport P p (d a0)).
+    Set Printing Implicit.
+    let G := match goal with |- ?G => constr:G end in
+    first [ match goal with
+              | [ |- (@isconnected_elim n (@hfiber A B f (f a))
+                                        (@isconnected_hfiber_conn_map n A B f H (f a))
+                                        (P (f a)) (HP (f a))
+                                        (fun x : @hfiber A B f (f a) =>
+                                           @transport B P (f x.1) (f a) x.2 (d x.1))).1 =
+                     d a /\ _ ] => idtac
+            end
+          | fail 1 "projection names should be folded, [let] should generate unfolded projections, goal:" G ];
+      first [ match goal with
+                | [ |- _ /\ (@isconnected_elim n (@hfiber A B f (f a))
+                                               (@isconnected_hfiber_conn_map n A B f H (f a))
+                                               (P (f a)) (HP (f a)) fibermap).1 = d a ] => idtac
+              end
+            | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ].
+    admit.
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3700.v b/test-suite/bugs/closed/3700.v
new file mode 100644
index 00000000..4e226524
--- /dev/null
+++ b/test-suite/bugs/closed/3700.v
@@ -0,0 +1,84 @@
+
+Set Implicit Arguments.
+Module NonPrim.
+  Unset Primitive Projections.
+  Record prod A B := pair { fst : A ; snd : B }.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Record prod A B := pair { fst : A ; snd : B }.
+End Prim.
+Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a)
+/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a).
+  Show. (* (forall x : NonPrim.prod Set Set, let (a, _) := x in a = a) /\
+   (forall x : Prim.prod Set Set,
+    let a := Prim.fst x in let b := Prim.snd x in a = a) *)
+  Set Printing All.
+  Show. (* and
+     (forall x : NonPrim.prod Set Set,
+      match x return Prop with
+      | NonPrim.pair a _ => @eq Set a a
+      end)
+     (forall x : Prim.prod Set Set,
+      let a := @Prim.fst Set Set x in
+      let b := @Prim.snd Set Set x in @eq Set a a) *)
+  Unset Printing All.
+Abort.
+Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a end)
+/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a end).
+  Show. (* (forall x : NonPrim.prod Set Set,
+    match x with
+    | {| NonPrim.fst := a |} => a = a
+    end) /\ (forall x : Prim.prod Set Set, Prim.fst x = Prim.fst x) *)
+  (** Wrong: [match] should generate unfolded things *)
+  Set Printing All.
+  Show. (* and
+     (forall x : NonPrim.prod Set Set,
+      match x return Prop with
+      | NonPrim.pair a _ => @eq Set a a
+      end)
+     (forall x : Prim.prod Set Set,
+      @eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) *)
+  Unset Printing All.
+Abort.
+Goal (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b)
+/\ (forall x : Prim.prod Set Set, let (a, b) := x in a = a /\ b = b).
+  Show. (* (forall x : NonPrim.prod Set Set, let (a, b) := x in a = a /\ b = b) /\
+   (forall x : Prim.prod Set Set,
+    let a := Prim.fst x in let b := Prim.snd x in a = a /\ b = b) *)
+  (** Understandably different, maybe, but should still be unfolded *)
+  Set Printing All.
+  Show. (* and
+     (forall x : NonPrim.prod Set Set,
+      match x return Prop with
+      | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b)
+      end)
+     (forall x : Prim.prod Set Set,
+      let a := @Prim.fst Set Set x in
+      let b := @Prim.snd Set Set x in and (@eq Set a a) (@eq Set b b)) *)
+  Unset Printing All.
+Abort.
+Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a /\ b = b end)
+/\ (forall x : Prim.prod Set Set, match x with Prim.pair a b => a = a /\ b = b end).
+  Show. (* (forall x : NonPrim.prod Set Set,
+    match x with
+    | {| NonPrim.fst := a; NonPrim.snd := b |} => a = a /\ b = b
+    end) /\
+   (forall x : Prim.prod Set Set,
+    Prim.fst x = Prim.fst x /\ Prim.snd x = Prim.snd x) *)
+  Set Printing All.
+  Show.
+
+  set(foo:=forall x : Prim.prod Set Set, match x return Set with
+                 | Prim.pair fst _ => fst
+                 end).
+  (* and
+     (forall x : NonPrim.prod Set Set,
+      match x return Prop with
+      | NonPrim.pair a b => and (@eq Set a a) (@eq Set b b)
+      end)
+     (forall x : Prim.prod Set Set,
+      and (@eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x))
+        (@eq Set (@Prim.snd Set Set x) (@Prim.snd Set Set x))) *)
+  Unset Printing All.
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3709.v b/test-suite/bugs/closed/3709.v
new file mode 100644
index 00000000..7f01be7a
--- /dev/null
+++ b/test-suite/bugs/closed/3709.v
@@ -0,0 +1,23 @@
+Module NonPrim.
+  Unset Primitive Projections.
+  Record hProp := hp { hproptype :> Type }.
+  Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f,
+         (forall y, h y = y) ->
+         h (fun b : Type => {| hproptype := f b |}) = k.
+  Proof.
+    intros h k f H.
+    etransitivity.
+    apply H.
+    admit.
+  Defined.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Record hProp := hp { hproptype :> Type }.
+  Goal forall (h : (Type -> hProp) -> (Type -> hProp)) k f,
+         (forall y, h y = y) ->
+         h (fun b : Type => {| hproptype := f b |}) = k.
+  Proof.
+    intros h k f H.
+    etransitivity.
+    apply H.
diff --git a/test-suite/bugs/closed/3710.v b/test-suite/bugs/closed/3710.v
new file mode 100644
index 00000000..b9e2798d
--- /dev/null
+++ b/test-suite/bugs/closed/3710.v
@@ -0,0 +1,48 @@
+(* File reduced by coq-bug-finder from original input, then from 13477 lines to 1457 lines, then from 1553 lines to 1586 lines, then \
+from 1574 lines to 823 lines, then from 837 lines to 802 lines, then from 793 lines to 657 lines, then from 661 lines to 233 lines, t\
+hen from 142 lines to 65 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 8 2014 13:38:17 with OCaml 4.01.0
+   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (335cf2860bfd9e714d14228d75a52fd2c88db386) *)
+Set Universe Polymorphism.
+Set Primitive Projections.
+Set Implicit Arguments.
+Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
+Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope.
+Definition relation (A : Type) := A -> A -> Type.
+Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x.
+Notation "( x ; y )" := (existT _ x y).
+Notation "x .1" := (projT1 x) (at level 3, format "x '.1'").
+Reserved Infix "o" (at level 40, left associativity).
+Delimit Scope category_scope with category.
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+    compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' }.
+Delimit Scope functor_scope with functor.
+Record Functor (C D : PreCategory) := { object_of :> C -> D }.
+Local Open Scope category_scope.
+Class Isomorphic {C : PreCategory} (s d : C) := {}.
+Axiom composeF : forall C D E (G : Functor D E) (F : Functor C D), Functor C E.
+Infix "o" := composeF : functor_scope.
+Local Open Scope functor_scope.
+Definition sub_pre_cat {P : PreCategory -> Type} : PreCategory.
+  exact (@Build_PreCategory
+           { C : PreCategory & P C }
+           (fun C D => Functor C.1 D.1)
+           (fun _ _ _ F G => F o G)).
+Defined.
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+Axiom composeT : forall C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F'),
+                   NaturalTransformation F F''.
+Definition functor_category (C D : PreCategory) : PreCategory.
+  exact (@Build_PreCategory (Functor C D)
+                            (@NaturalTransformation C D)
+                            (@composeT C D)).
+Defined.
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Definition NaturalIsomorphism (C D : PreCategory) F G : Type := @Isomorphic (C -> D) F G.
+Context `{P : PreCategory -> Type}.
+Local Notation cat := (@sub_pre_cat P).
+Goal forall (s d d' : cat) (m1 : morphism cat d d') (m2 : morphism cat s d),
+       NaturalIsomorphism (m1 o m2) (m1 o m2)%functor.
+Fail exact (fun _ _ _ _ _ => reflexivity _).
diff --git a/test-suite/bugs/closed/3723.v b/test-suite/bugs/closed/3723.v
new file mode 100644
index 00000000..d0b77c45
--- /dev/null
+++ b/test-suite/bugs/closed/3723.v
@@ -0,0 +1,6 @@
+(* Bugs #3787 and #3723 on reinitializing camlp5 levels *)
+
+Definition a := True.
+Reserved Notation "-- x" (at level 50, x at level 20).
+Reserved Notation "--- x" (at level 20).
+Reset a.
diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v
new file mode 100644
index 00000000..08d456fc
--- /dev/null
+++ b/test-suite/bugs/closed/3782.v
@@ -0,0 +1,63 @@
+(* File reduced by coq-bug-finder from original input, then from 2674 lines to 136 lines, then from 115 lines to 61 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 28 2014 14:33:38 with OCaml 4.01.0
+   coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,(no branch) (53bfe9cf58a3c40e6eb7120d25c1633a9cea3126) *)
+Class IsEquiv {A B : Type} (f : A -> B) := {}.
+Record Equiv A B := { equiv_fun : A -> B ; equiv_isequiv : IsEquiv equiv_fun }.
+Arguments equiv_fun {A B} _ _.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Set Printing Coercions.
+Set Printing Implicit.
+Module NonPrim.
+  Unset Primitive Projections.
+  Record TruncType (n : nat) := { trunctype_type :> Type }.
+  Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T).
+  Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d),
+          @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) ->
+  forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True.
+    intros isiso_isequiv' mc md e e'.
+    (pose (@isiso_isequiv'
+             _ _
+             (e
+              : (Build_TruncType 0 md) ->
+                (Build_TruncType 0 mc))
+             e') as i || fail "too early"); clear i.
+    pose (@isiso_isequiv'
+            _ _ _
+            e').
+    admit.
+  Defined.
+End NonPrim.
+Module Prim.
+  Set Primitive Projections.
+  Record TruncType (n : nat) := { trunctype_type :> Type }.
+  Canonical Structure default_TruncType := fun n T => (@Build_TruncType n T).
+  Goal (forall (s d : TruncType 0) (m : trunctype_type 0 s -> trunctype_type 0 d),
+          @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type) ->
+  forall (T T0 : Type) (m : T0 -> T), @IsEquiv T0 T m -> True.
+    intros isiso_isequiv' mc md e e'.
+    (pose (@isiso_isequiv'
+             _ _
+             (e
+              : (Build_TruncType 0 md) ->
+                (Build_TruncType 0 mc))
+             e') as i || fail "too early"); clear i.
+    Set Printing Existential Instances.
+    Set Debug Unification.
+    pose (@isiso_isequiv'
+            _ _ _
+            e'). (* Toplevel input, characters 48-50:
+Error:
+In environment
+isiso_isequiv' : forall (s d : TruncType 0)
+                   (m : trunctype_type 0 s -> trunctype_type 0 d),
+                 @IsEquiv (trunctype_type 0 s) (trunctype_type 0 d) m -> Type
+mc : Type
+md : Type
+e : md -> mc
+e' : @IsEquiv md mc e
+The term "e'" has type "@IsEquiv md mc e" while it is expected to have type
+ "@IsEquiv (trunctype_type 0 ?t) (trunctype_type 0 ?t0) ?t1".
+                  *)
+    admit.
+  Defined.
+End Prim.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/3788.v b/test-suite/bugs/closed/3788.v
new file mode 100644
index 00000000..2c5b9cb0
--- /dev/null
+++ b/test-suite/bugs/closed/3788.v
@@ -0,0 +1,6 @@
+Set Implicit Arguments.
+Global Set Primitive Projections.
+Record Functor (C D : Type) := { object_of :> forall _ : C, D }.
+Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G.
+Fail Lemma path_functor_uncurried_snd C D F G HO HM
+: (@path_functor_uncurried C D F G (existT _ HO HM)) = HM.
diff --git a/test-suite/bugs/closed/3792.v b/test-suite/bugs/closed/3792.v
new file mode 100644
index 00000000..39057b9c
--- /dev/null
+++ b/test-suite/bugs/closed/3792.v
@@ -0,0 +1,4 @@
+Fail Definition pull_if_dep
+: forall {A} (P : bool -> Type) (a : A true) (a' : A false)
+         (b : bool),
+    P (if b as b return A b then a else a').
diff --git a/test-suite/bugs/closed/shouldsucceed/38.v b/test-suite/bugs/closed/38.v
index 4fc8d7c9..4fc8d7c9 100644
--- a/test-suite/bugs/closed/shouldsucceed/38.v
+++ b/test-suite/bugs/closed/38.v
diff --git a/test-suite/bugs/closed/3804.v b/test-suite/bugs/closed/3804.v
new file mode 100644
index 00000000..da9290cb
--- /dev/null
+++ b/test-suite/bugs/closed/3804.v
@@ -0,0 +1,12 @@
+Set Universe Polymorphism.
+Module Foo.
+  Definition T : sigT (fun x => x).
+  Proof.
+    exists Set.
+    abstract exact nat.
+  Defined.
+End Foo.
+Module Bar.
+  Include Foo.
+End Bar.
+Definition foo := eq_refl : Foo.T = Bar.T.
diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v
new file mode 100644
index 00000000..8da4f736
--- /dev/null
+++ b/test-suite/bugs/closed/3821.v
@@ -0,0 +1,2 @@
+Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := .
+
diff --git a/test-suite/bugs/closed/3828.v b/test-suite/bugs/closed/3828.v
new file mode 100644
index 00000000..ae11c6c9
--- /dev/null
+++ b/test-suite/bugs/closed/3828.v
@@ -0,0 +1,2 @@
+Goal 0 = 0.
+Fail pose ?Goal.
diff --git a/test-suite/bugs/closed/3848.v b/test-suite/bugs/closed/3848.v
new file mode 100644
index 00000000..b66aecca
--- /dev/null
+++ b/test-suite/bugs/closed/3848.v
@@ -0,0 +1,21 @@
+Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B} (f : A -> B) := { equiv_inv : B -> A ; eisretr : Sect equiv_inv f }.
+Arguments eisretr {A B} f {_} _.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'").
+Generalizable Variables A B f g e n.
+Definition functor_forall `{P : A -> Type} `{Q : B -> Type}
+           (f0 : B -> A) (f1 : forall b:B, P (f0 b) -> Q b)
+: (forall a:A, P a) -> (forall b:B, Q b).
+  admit.
+Defined.
+
+Lemma isequiv_functor_forall `{P : A -> Type} `{Q : B -> Type}
+      `{IsEquiv B A f} `{forall b, @IsEquiv (P (f b)) (Q b) (g b)}
+: (forall b : B, Q b) -> forall a : A, P a.
+Proof.
+  refine (functor_forall
+            (f^-1)
+            (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)).
+Defined. (* Error: Attempt to save an incomplete proof *)
diff --git a/test-suite/bugs/closed/3854.v b/test-suite/bugs/closed/3854.v
new file mode 100644
index 00000000..f8329cdd
--- /dev/null
+++ b/test-suite/bugs/closed/3854.v
@@ -0,0 +1,21 @@
+Definition relation (A : Type) := A -> A -> Type.
+Class Reflexive {A} (R : relation A) := reflexivity : forall x : A, R x x.
+Axiom IsHProp : Type -> Type.
+Existing Class IsHProp.
+Inductive Empty : Set := .
+Notation "~ x" := (x -> Empty) : type_scope.
+Record hProp := BuildhProp { type :> Type ; trunc : IsHProp type }.
+Arguments BuildhProp _ {_}.
+Canonical Structure default_hProp := fun T P => (@BuildhProp T P).
+Generalizable Variables A B f g e n.
+Axiom trunc_forall : forall `{P : A -> Type}, IsHProp (forall a, P a).
+Existing Instance trunc_forall.
+Inductive V : Type := | set {A : Type} (f : A -> V) : V.
+Axiom mem : V -> V -> hProp.
+Axiom mem_induction
+: forall (C : V -> hProp), (forall v, (forall x, mem x v -> C x) -> C v) -> forall v, C v.
+Definition irreflexive_mem : forall x, (fun x y => ~ mem x y) x x.
+Proof.
+  pose (fun x => BuildhProp (~ mem x x)).
+  refine (mem_induction (fun x => BuildhProp (~ mem x x)) _); simpl in *.
+  admit.
diff --git a/test-suite/bugs/closed/3892.v b/test-suite/bugs/closed/3892.v
new file mode 100644
index 00000000..833722ba
--- /dev/null
+++ b/test-suite/bugs/closed/3892.v
@@ -0,0 +1,8 @@
+(* Check that notation variables do not capture names hidden behind
+   another notation. *)
+Notation "A <-> B" := ((A -> B) * (B -> A))%type : type_scope.
+Notation compose := (fun g f x => g (f x)).
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity).
+Definition iff_compose {A B C : Type} (g : B <-> C) (f : A <-> B) : A <-> C :=
+  (fst g o fst f , snd f o snd g).
+(* Used to fail with: This expression should be a name. *)
diff --git a/test-suite/bugs/closed/3895.v b/test-suite/bugs/closed/3895.v
new file mode 100644
index 00000000..8659ca2c
--- /dev/null
+++ b/test-suite/bugs/closed/3895.v
@@ -0,0 +1,22 @@
+Notation pr1 := (@projT1 _ _).
+Notation compose := (fun g' f' x => g' (f' x)).
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) :
+function_scope.
+Open Scope function_scope.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p
+with eq_refl => eq_refl end.
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) := forall x:A,
+f x = g x.
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) :
+type_scope.
+Theorem Univalence_implies_FunextNondep (A B : Type)
+: forall f g : A -> B, f == g -> f = g.
+Proof.
+  intros f g p.
+  pose (d := fun x : A => existT (fun xy => fst xy = snd xy) (f x, f x)
+(eq_refl (f x))).
+  pose (e := fun x : A => existT (fun xy => fst xy = snd xy) (f x, g x) (p x)).
+  change f with ((snd o pr1) o d).
+  change g with ((snd o pr1) o e).
+  apply (ap (fun g => snd o pr1 o g)).
+(* Used to raise a not Found due to a "typo" in solve_evar_evar *)
diff --git a/test-suite/bugs/closed/3896.v b/test-suite/bugs/closed/3896.v
new file mode 100644
index 00000000..b433922a
--- /dev/null
+++ b/test-suite/bugs/closed/3896.v
@@ -0,0 +1,4 @@
+Goal True.
+pose proof 0 as n.
+Fail apply pair in n.
+(* Used to be an anomaly for a while *)
diff --git a/test-suite/bugs/closed/3899.v b/test-suite/bugs/closed/3899.v
new file mode 100644
index 00000000..e83166aa
--- /dev/null
+++ b/test-suite/bugs/closed/3899.v
@@ -0,0 +1,11 @@
+Set Primitive Projections.
+Record unit : Set := tt {}.
+Fail Check fun x : unit => eq_refl : tt = x.
+Fail Check fun x : unit => eq_refl : x = tt.
+Fail Check fun x y : unit => (eq_refl : x = tt) : x = y.
+Fail Check fun x y : unit => eq_refl : x = y.
+
+Record ok : Set := tt' { a : unit }.
+
+Record nonprim : Prop := { undef : unit }.
+Record prim : Prop := { def : True }.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/545.v b/test-suite/bugs/closed/545.v
index 926af7dd..926af7dd 100644
--- a/test-suite/bugs/closed/shouldsucceed/545.v
+++ b/test-suite/bugs/closed/545.v
diff --git a/test-suite/bugs/closed/shouldsucceed/808_2411.v b/test-suite/bugs/closed/808_2411.v
index 1c13e745..1c13e745 100644
--- a/test-suite/bugs/closed/shouldsucceed/808_2411.v
+++ b/test-suite/bugs/closed/808_2411.v
diff --git a/test-suite/bugs/closed/shouldsucceed/846.v b/test-suite/bugs/closed/846.v
index ee5ec1fa..ee5ec1fa 100644
--- a/test-suite/bugs/closed/shouldsucceed/846.v
+++ b/test-suite/bugs/closed/846.v
diff --git a/test-suite/bugs/closed/shouldsucceed/931.v b/test-suite/bugs/closed/931.v
index 21f15e72..e86b3be6 100644
--- a/test-suite/bugs/closed/shouldsucceed/931.v
+++ b/test-suite/bugs/closed/931.v
@@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop.
 
 Goal Prop.
   refine (P _ _).
-  instantiate (1:=0).
+  2:instantiate (1:=0).
   trivial.
 Qed.
diff --git a/test-suite/bugs/closed/HoTT_coq_001.v b/test-suite/bugs/closed/HoTT_coq_001.v
new file mode 100644
index 00000000..bf1d024b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_001.v
@@ -0,0 +1,5 @@
+Record Foo : Set :=
+  {
+    A' : nat;
+    A : Prop := (A' = 0)
+  }. (* Anomaly: Uncaught exception Reduction.NotConvertible. Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v
new file mode 100644
index 00000000..ba69f6b1
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_002.v
@@ -0,0 +1,33 @@
+Set Implicit Arguments.
+
+Generalizable All Variables.
+
+Parameter SpecializedCategory : Type -> Type.
+Parameter Object : forall obj, SpecializedCategory obj -> Type.
+
+Section SpecializedFunctor.
+  (* Variable objC : Type. *)
+  Context `(C : SpecializedCategory objC).
+
+  Polymorphic Record SpecializedFunctor := {
+    ObjectOf' : objC -> Type;
+    ObjectC : Object C
+  }.
+End SpecializedFunctor.
+
+Section FunctorInterface.
+  Variable objC : Type.
+  Variable C : SpecializedCategory objC.
+  Variable F : SpecializedFunctor C.
+
+  Set Printing All.
+  Set Printing Universes.
+  Check @ObjectOf' objC C F. (* Toplevel input, characters 24-25:
+Error:
+In environment
+objC : Type (* Top.515 *)
+C : SpecializedCategory objC
+F : @SpecializedFunctor (* Top.516 *) objC C
+The term "F" has type "@SpecializedFunctor (* Top.516 *) objC C"
+ while it is expected to have type
+ "@SpecializedFunctor (* Top.519 Top.520 *) objC C". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_006.v b/test-suite/bugs/closed/HoTT_coq_006.v
new file mode 100644
index 00000000..c7943b84
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_006.v
@@ -0,0 +1,99 @@
+Module FirstIssue.
+  Set Implicit Arguments.
+
+  Record Cat (obj : Type) := {}.
+
+  Record Functor objC (C : Cat objC) objD (D : Cat objD) :=
+    {
+      ObjectOf' : objC -> objD
+    }.
+
+  Definition TypeCat : Cat Type. constructor. Defined.
+  Definition PropCat : Cat Prop. constructor. Defined.
+
+  Definition FunctorFrom_Type2Prop objC (C : Cat objC) (F : Functor TypeCat C) : Functor PropCat C.
+    Set Printing All.
+    Set Printing Universes.
+    Check F. (* F : @Functor Type (* Top.1201 *) TypeCat objC C *)
+    exact (Build_Functor PropCat C (ObjectOf' F)).
+    Show Proof. (* (fun (objC : Type (* Top.1194 *)) (C : Cat objC)
+   (F : @Functor Prop TypeCat objC C) =>
+ @Build_Functor Prop PropCat objC C
+   (@ObjectOf' Prop TypeCat objC C F)) *)
+  Defined.
+  (* Error: Illegal application (Type Error):
+The term "Functor" of type
+ "forall (objC : Type (* Top.1194 *)) (_ : Cat objC)
+    (objD : Type (* Top.1194 *)) (_ : Cat objD),
+  Type (* Top.1194 *)"
+cannot be applied to the terms
+ "Prop" : "Type (* (Set)+1 *)"
+ "TypeCat" : "Cat Type (* Top.1201 *)"
+ "objC" : "Type (* Top.1194 *)"
+ "C" : "Cat objC"
+The 2nd term has type "Cat Type (* Top.1201 *)"
+which should be coercible to "Cat Prop". *)
+End FirstIssue.
+
+Module SecondIssue.
+  Set Implicit Arguments.
+
+  Set Printing Universes.
+
+  Polymorphic Record Cat (obj : Type) :=
+    {
+      Object :> _ := obj;
+      Morphism' : obj -> obj -> Type
+    }.
+
+  Polymorphic Record Functor objC (C : Cat objC) objD (D : Cat objD) :=
+    {
+      ObjectOf' : objC -> objD;
+      MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d)
+    }.
+
+  Definition SetCat : Cat Set := @Build_Cat Set (fun x y => x -> y).
+  Definition PropCat : Cat Prop := @Build_Cat Prop (fun x y => x -> y).
+
+  Set Printing All.
+
+  Definition FunctorFrom_Set2Prop objC (C : Cat objC) (F : Functor SetCat C) : Functor PropCat C.
+    exact (Build_Functor PropCat C
+                         (ObjectOf' F)
+                         (MorphismOf' F)
+          ).
+  Defined. (* Error: Illegal application (Type Error):
+The term "Build_Functor (* Top.748 Prop Top.808 Top.809 *)" of type
+ "forall (objC : Type (* Top.748 *)) (C : Cat (* Top.748 Prop *) objC)
+    (objD : Type (* Top.808 *)) (D : Cat (* Top.808 Top.809 *) objD)
+    (ObjectOf' : forall _ : objC, objD)
+    (_ : forall (s d : objC) (_ : @Morphism' (* Top.748 Prop *) objC C s d),
+         @Morphism' (* Top.808 Top.809 *) objD D (ObjectOf' s) (ObjectOf' d)),
+  @Functor (* Top.748 Prop Top.808 Top.809 *) objC C objD D"
+cannot be applied to the terms
+ "Prop" : "Type (* (Set)+1 *)"
+ "PropCat" : "Cat (* Top.748 Prop *) Prop"
+ "objC" : "Type (* Top.808 *)"
+ "C" : "Cat (* Top.808 Top.809 *) objC"
+ "fun x : Prop =>
+  @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x"
+   : "forall _ : Prop, objC"
+ "@MorphismOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F"
+   : "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d),
+      @Morphism' (* Top.808 Top.809 *) objC C
+        (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s)
+        (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)"
+The 6th term has type
+ "forall (s d : Set) (_ : @Morphism' (* Top.744 Prop *) Set SetCat s d),
+  @Morphism' (* Top.808 Top.809 *) objC C
+    (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F s)
+    (@ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F d)"
+which should be coercible to
+ "forall (s d : Prop) (_ : @Morphism' (* Top.748 Prop *) Prop PropCat s d),
+  @Morphism' (* Top.808 Top.809 *) objC C
+    ((fun x : Prop =>
+      @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) s)
+    ((fun x : Prop =>
+      @ObjectOf' (* Top.744 Prop Top.808 Top.809 *) Set SetCat objC C F x) d)".
+            *)
+End SecondIssue.
diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v
new file mode 100644
index 00000000..8592c729
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_007.v
@@ -0,0 +1,112 @@
+Module Comment1.
+  Set Implicit Arguments.
+
+  Polymorphic Record Category (obj : Type) :=
+    {
+      Morphism : obj -> obj -> Type;
+      Identity : forall o, Morphism o o
+    }.
+
+  Polymorphic Record Functor objC (C :Category objC) objD (D : Category objD) :=
+    {
+      ObjectOf :> objC -> objD;
+      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d);
+      FIdentityOf : forall o, MorphismOf _ _ (C.(Identity) o) = D.(Identity) (ObjectOf o)
+    }.
+
+  Create HintDb functor discriminated.
+
+  Hint Rewrite @FIdentityOf : functor.
+
+  Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E.
+  refine {| ObjectOf := (fun c => G (F c));
+            MorphismOf := (fun _ _ m => G.(MorphismOf) _ _ (F.(MorphismOf) _ _ m))
+         |};
+    intros; autorewrite with functor; reflexivity.
+  Defined.
+
+  Definition Cat0 : Category@{i j} Empty_set.
+    refine {|
+        Morphism := fun s d : Empty_set => s = d;
+        Identity := fun o : Empty_set => eq_refl
+      |};
+    admit.
+  Defined.
+
+  Set Printing All.
+  Set Printing Universes.
+
+  Lemma foo objC (C : @Category objC) (C0 : Category (Functor Cat0 C)) (x : Functor Cat0 Cat0) 
+  : forall (y : Functor C0 Cat0) z, (ComposeFunctors y z = x). 
+    intro. intro.
+    unfold ComposeFunctors.     
+  Abort.
+End Comment1.
+
+Module Comment2.
+  Set Implicit Arguments.
+
+  Polymorphic Record Category (obj : Type) :=
+    {
+      Morphism : obj -> obj -> Type;
+
+      Identity : forall o, Morphism o o;
+      Compose : forall s d d2, Morphism d d2 -> Morphism s d -> Morphism s d2;
+
+      LeftIdentity : forall a b (f : Morphism a b), Compose (Identity b) f = f
+    }.
+
+  Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) :=
+    {
+      ObjectOf : objC -> objD;
+      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+    }.
+
+  Create HintDb morphism discriminated.
+
+  Polymorphic Hint Resolve @LeftIdentity : morphism.
+
+  Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type.
+  refine {|
+      Morphism := (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type);
+      Identity := (fun o => (Identity _ (fst o), Identity _ (snd o)));
+      Compose := (fun (s d d2 : (objC * objD)%type) m2 m1 => (C.(Compose) _ _ _ (fst m2) (fst m1), D.(Compose) _ _ _ (snd m2) (snd m1)))
+    |};
+    intros; apply injective_projections; simpl; auto with morphism. (* Replacing [auto with morphism] with [apply @LeftIdentity] removes the error *)
+  Defined.
+
+  Polymorphic Definition Cat0 : Category Empty_set.
+  refine {|
+      Morphism := fun s d : Empty_set => s = d;
+      Identity := fun o : Empty_set => eq_refl;
+      Compose := fun s d d2 m0 m1 => eq_trans m1 m0
+    |};
+    admit.
+  Defined.
+
+  Set Printing All.
+  Set Printing Universes.
+  Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0.
+  refine (Build_Functor (ProductCategory C Cat0) Cat0 _ _). (* Toplevel input, characters 15-71:
+Error: Refiner was given an argument
+ "prod (* Top.2289 Top.2289 *) objC Empty_set" of type
+"Type (* Top.2289 *)" instead of "Set". *)
+  Abort.
+  Polymorphic Definition ProductLaw0Functor (objC : Type) (C : Category objC) : Functor (ProductCategory C Cat0) Cat0.
+  econstructor. (* Toplevel input, characters 0-12:
+Error: No applicable tactic.
+                 *)
+  Abort.
+End Comment2.
+
+
+Module Comment3.
+  Polymorphic Lemma foo {obj : Type} : 1 = 1.
+  trivial.
+  Qed.
+
+  Polymorphic Hint Resolve foo. (* success *)
+  Polymorphic Hint Rewrite @foo. (* Success *)
+  Polymorphic Hint Resolve @foo. (* Error: @foo is a term and cannot be made a polymorphic hint, only global references can be polymorphic hints. *)
+  Fail Polymorphic Hint Rewrite foo. (* Error: Cannot infer the implicit parameter obj of foo. *)
+End Comment3.
diff --git a/test-suite/bugs/closed/HoTT_coq_010.v b/test-suite/bugs/closed/HoTT_coq_010.v
new file mode 100644
index 00000000..42b1244f
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_010.v
@@ -0,0 +1,3 @@
+SearchAbout and.
+(* Anomaly: Mismatched instance and context when building universe substitution.
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_012.v b/test-suite/bugs/closed/HoTT_coq_012.v
new file mode 100644
index 00000000..a3c697f8
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_012.v
@@ -0,0 +1,4 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+
+Definition UU := Type.
+Inductive toto (B : UU) : UU := c (x : B).
diff --git a/test-suite/bugs/closed/HoTT_coq_013.v b/test-suite/bugs/closed/HoTT_coq_013.v
new file mode 100644
index 00000000..13962d5b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_013.v
@@ -0,0 +1,24 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+
+Polymorphic Variant Category (obj : Type) :=.
+
+            Polymorphic Variant Functor objC (C : Category objC) objD (D : Category objD) :=.
+
+            Polymorphic Definition ComposeFunctors objC C objD D objE E (G : @Functor objD D objE E) (F : @Functor objC C objD D) : Functor C E.
+Admitted.
+
+Polymorphic Definition ProductCategory objC (C : Category objC) objD (D : Category objD) : @Category (objC * objD)%type.
+Admitted.
+
+Polymorphic Definition Cat0 : Category Empty_set.
+Admitted.
+
+Set Printing Universes.
+
+Lemma ProductLaw0 objC (C : Category objC) (F : Functor (ProductCategory C Cat0) Cat0) (G : Functor Cat0 (ProductCategory C Cat0)) x y :
+  ComposeFunctors F G = x /\
+  ComposeFunctors G F = y.
+Proof.
+  split. (* Error: Refiner was given an argument "(objC * 0)%type" of type "Type" instead of "Set". *)
+Abort.
diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v
new file mode 100644
index 00000000..63548a64
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_014.v
@@ -0,0 +1,200 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Universe Polymorphism.
+
+Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' {
+  Object :> _ := obj;
+  Morphism' : obj -> obj -> Type;
+
+  Identity' : forall o, Morphism' o o;
+  Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d'
+}.
+
+Polymorphic Definition Morphism obj (C : @SpecializedCategory obj) : forall s d : C, _ := Eval cbv beta delta [Morphism'] in C.(Morphism').
+
+(* eh, I'm not terribly happy.  meh. *)
+Polymorphic Definition SmallSpecializedCategory (obj : Set) (*mor : obj -> obj -> Set*) := SpecializedCategory@{Set Set} obj.
+Polymorphic Identity Coercion SmallSpecializedCategory_LocallySmallSpecializedCategory_Id : SmallSpecializedCategory >-> SpecializedCategory.
+
+Polymorphic Record Category := {
+  CObject : Type;
+
+  UnderlyingCategory :> @SpecializedCategory CObject
+}.
+
+Polymorphic Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category.
+  refine {| CObject := C.(Object) |}; auto.
+Defined.
+
+Polymorphic Coercion GeneralizeCategory : SpecializedCategory >-> Category.
+
+
+
+Section SpecializedFunctor.
+  Set Universe Polymorphism.
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Unset Universe Polymorphism.
+
+  Polymorphic Record SpecializedFunctor := {
+    ObjectOf' : objC -> objD;
+    MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d);
+    FCompositionOf' : forall s d d' (m1 : C.(Morphism') s d) (m2: C.(Morphism') d d'),
+      MorphismOf' _ _ (C.(Compose') _ _ _ m2 m1) = D.(Compose') _ _ _ (MorphismOf' _ _ m2) (MorphismOf' _ _ m1);
+    FIdentityOf' : forall o, MorphismOf' _ _ (C.(Identity') o) = D.(Identity') (ObjectOf' o)
+  }.
+End SpecializedFunctor.
+
+Global Polymorphic Coercion ObjectOf' : SpecializedFunctor >-> Funclass.
+Set Universe Polymorphism.
+Section Functor.
+  Variable C D : Category.
+
+  Polymorphic Definition Functor := SpecializedFunctor C D.
+End Functor.
+Unset Universe Polymorphism.
+
+Polymorphic Identity Coercion Functor_SpecializedFunctor_Id : Functor >-> SpecializedFunctor.
+Polymorphic Definition GeneralizeFunctor objC C objD D (F : @SpecializedFunctor objC C objD D) : Functor C D := F.
+Polymorphic Coercion GeneralizeFunctor : SpecializedFunctor >-> Functor.
+
+Arguments SpecializedFunctor {objC} C {objD} D.
+
+
+Polymorphic Record SmallCategory := {
+  SObject : Set;
+
+  SUnderlyingCategory :> @SmallSpecializedCategory SObject
+}.
+
+Polymorphic Definition GeneralizeSmallCategory `(C : @SmallSpecializedCategory obj) : SmallCategory.
+  refine {| SObject := obj |}; destruct C; econstructor; eassumption.
+Defined.
+
+Polymorphic Coercion GeneralizeSmallCategory : SmallSpecializedCategory >-> SmallCategory.
+
+Bind Scope category_scope with SmallCategory.
+
+
+Polymorphic Definition TypeCat : @SpecializedCategory Type := (@Build_SpecializedCategory' Type
+                                                                                          (fun s d => s -> d)
+                                                                                          (fun _ => (fun x => x))
+                                                                                          (fun _ _ _ f g => (fun x => f (g x)))).
+(*Unset Universe Polymorphism.*)
+Polymorphic Definition FunctorCategory objC (C : @SpecializedCategory objC) objD (D : @SpecializedCategory objD) :
+  @SpecializedCategory (SpecializedFunctor C D).
+Admitted.
+
+Polymorphic Definition DiscreteCategory (O : Type) : @SpecializedCategory O.
+Admitted.
+
+Polymorphic Definition ComputableCategory (I : Type) (Index2Object : I -> Type) (Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)) :
+  @SpecializedCategory I.
+Admitted.
+
+Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x.
+
+Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) :=
+    forall o', { m : C.(Morphism) o o' | is_unique m }.
+
+Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory.
+
+Lemma InitialCategory_Initial : InitialObject (C := SmallCat) (DiscreteCategory Empty_set : SmallSpecializedCategory _).
+  admit.
+Qed.
+
+Set Universe Polymorphism.
+Section GraphObj.
+  Context `(C : @SpecializedCategory objC).
+
+  Inductive GraphIndex := GraphIndexSource | GraphIndexTarget.
+
+  Definition GraphIndex_Morphism (a b : GraphIndex) : Set :=
+    match (a, b) with
+      | (GraphIndexSource, GraphIndexSource) => unit
+      | (GraphIndexTarget, GraphIndexTarget) => unit
+      | (GraphIndexTarget, GraphIndexSource) => Empty_set
+      | (GraphIndexSource, GraphIndexTarget) => GraphIndex
+    end.
+
+  Global Arguments GraphIndex_Morphism a b /.
+
+  Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) :
+    GraphIndex_Morphism s d'.
+  Admitted.
+
+   Definition GraphIndexingCategory : @SpecializedCategory GraphIndex.
+    refine {|
+      Morphism' := GraphIndex_Morphism;
+      Identity' := (fun x => match x with GraphIndexSource => tt | GraphIndexTarget => tt end);
+      Compose' := GraphIndex_Compose
+    |};
+    admit.
+  Defined.
+
+  Definition UnderlyingGraph_ObjectOf x :=
+    match x with
+      | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) }
+      | GraphIndexTarget => objC
+    end.
+
+  Global Arguments UnderlyingGraph_ObjectOf x /.
+
+  Definition UnderlyingGraph_MorphismOf s d (m : Morphism GraphIndexingCategory s d) :
+    UnderlyingGraph_ObjectOf s -> UnderlyingGraph_ObjectOf d.
+  Admitted.
+
+  Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
+  Proof.
+    match goal with
+      | [ |- SpecializedFunctor ?C ?D ] =>
+        refine (Build_SpecializedFunctor C D
+          UnderlyingGraph_ObjectOf
+          UnderlyingGraph_MorphismOf
+          _
+          _
+        )
+    end;
+    admit.
+  Defined.
+End GraphObj.
+
+Set Printing Universes.
+Set Printing All.
+
+Print Coercions.
+
+Section test.
+
+Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf' (C D : SmallCategory) (F : SpecializedFunctor C D) :
+    Morphism (FunctorCategory TypeCat GraphIndexingCategory)
+    (@UnderlyingGraph (SObject C)
+                     (SmallSpecializedCategory_LocallySmallSpecializedCategory_Id (SUnderlyingCategory C)))
+    (UnderlyingGraph D).
+ (* Toplevel input, characters 216-249:
+Error:
+In environment
+C : SmallCategory (* Top.594 *)
+D : SmallCategory (* Top.595 *)
+F :
+@SpecializedFunctor (* Top.25 Set Top.25 Set *) (SObject (* Top.25 *) C)
+  (SUnderlyingCategory (* Top.25 *) C) (SObject (* Top.25 *) D)
+  (SUnderlyingCategory (* Top.25 *) D)
+The term
+ "SUnderlyingCategory (* Top.25 *) C
+  :SpecializedCategory (* Top.25 Set *) (SObject (* Top.25 *) C)" has type
+ "SpecializedCategory (* Top.618 Top.619 *) (SObject (* Top.25 *) C)"
+while it is expected to have type
+ "SpecializedCategory (* Top.224 Top.225 *) (SObject (* Top.617 *) C)"
+(Universe inconsistency: Cannot enforce Set = Top.225)).
+ *)
+Fail Admitted.
+
+Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) :
+  Morphism (FunctorCategory TypeCat GraphIndexingCategory) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*)
+Fail Admitted.
+
+Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) :
+  Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*)
+Proof.
+Admitted.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/HoTT_coq_016.v b/test-suite/bugs/closed/HoTT_coq_016.v
new file mode 100644
index 00000000..4f12cf1a
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_016.v
@@ -0,0 +1,15 @@
+Set Printing Universes.
+Local Close Scope nat_scope.
+Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop)).
+(* fun ab : Prop * Prop =>
+(fst (* Top.5817 Top.5818 *) ab:Prop) * (snd (* Top.5817 Top.5818 *) ab:Prop)
+     : Prop * Prop -> Prop *)
+Check (fun ab : Prop * Prop => (fst ab : Prop) * (snd ab : Prop) : Prop).
+(* Toplevel input, characters 51-84:
+Error: In environment
+ab : Prop * Prop
+The term
+ "(fst (* Top.5833 Top.5834 *) ab:Prop) *
+  (snd (* Top.5833 Top.5834 *) ab:Prop)" has type
+ "Type (* max(Top.5829, Top.5830) *)" while it is expected to have type
+ "Prop". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_020.v b/test-suite/bugs/closed/HoTT_coq_020.v
new file mode 100644
index 00000000..b16c1df2
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_020.v
@@ -0,0 +1,95 @@
+Set Implicit Arguments.
+
+Generalizable All Variables.
+
+Set Asymmetric Patterns.
+
+Polymorphic Record Category (obj : Type) :=
+  Build_Category {
+      Object :> _ := obj;
+      Morphism : obj -> obj -> Type;
+
+      Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+    }.
+
+Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) :=
+  { ObjectOf :> objC -> objD }.
+
+Polymorphic Record NaturalTransformation objC C objD D (F G : Functor (objC := objC) C (objD := objD) D) :=
+  { ComponentsOf' :> forall c, D.(Morphism) (F.(ObjectOf) c) (G.(ObjectOf) c);
+    Commutes' : forall s d (m : C.(Morphism) s d), ComponentsOf' s = ComponentsOf' s }.
+
+Ltac present_obj from to :=
+  match goal with
+           | [ _ : appcontext[from ?obj ?C] |- _ ] => progress change (from obj C) with (to obj C) in *
+           | [ |- appcontext[from ?obj ?C] ] => progress change (from obj C) with (to obj C) in *
+         end.
+
+Section NaturalTransformationComposition.
+  Set Universe Polymorphism.
+  Context `(C : @Category objC).
+  Context `(D : @Category objD).
+  Context `(E : @Category objE).
+  Variables F F' F'' : Functor C D.
+  Unset Universe Polymorphism.
+
+  Polymorphic Definition NTComposeT (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') :
+    NaturalTransformation F F''.
+    exists (fun c => Compose _ _ _ _ (T' c) (T c)).
+    repeat progress present_obj @Morphism @Morphism. (* removing this line makes the error go away *)
+    intros. (* removing this line makes the error go away *)
+    admit.
+  Defined.
+End NaturalTransformationComposition.
+
+
+Polymorphic Definition FunctorCategory objC (C : Category objC) objD (D : Category objD) :
+  @Category (Functor C D)
+  := @Build_Category (Functor C D)
+                     (NaturalTransformation (C := C) (D := D))
+                     (NTComposeT (C := C) (D := D)).
+
+Polymorphic Definition Cat0 : Category Empty_set
+  := @Build_Category Empty_set
+                     (@eq _)
+                     (fun x => match x return _ with end).
+
+Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C
+  := Build_Functor Cat0 C (fun x => match x with end).
+
+Section Law0.
+  Variable objC : Type.
+  Variable C : Category objC.
+
+  Set Printing All.
+  Set Printing Universes.
+  Set Printing Existential Instances.
+
+  Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf' : Object (@FunctorCategory Empty_set Cat0 objC C).
+  (* In environment
+objC : Type (* Top.154 *)
+C : Category (* Top.155 Top.154 *) objC
+The term "objC" has type "Type (* Top.154 *)"
+while it is expected to have type "Type (* Top.184 *)"
+(Universe inconsistency: Cannot enforce Top.154 <= Set)). *)
+  Admitted.
+
+  Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf : Object (FunctorCategory Cat0 C).
+    hnf.
+    refine (@FunctorFrom0 _ _).
+
+    (* Toplevel input, characters 23-40:
+Error:
+In environment
+objC : Type (* Top.61069 *)
+C : Category (* Top.61069 Top.61071 *) objC
+The term
+ "@FunctorFrom0 (* Top.61077 Top.61078 *) ?69 (* [objC, C] *)
+    ?70 (* [objC, C] *)" has type
+ "@Functor (* Set Prop Top.61077 Top.61078 *) Empty_set Cat0
+    ?69 (* [objC, C] *) ?70 (* [objC, C] *)"
+ while it is expected to have type
+ "@Functor (* Set Prop Set Prop *) Empty_set Cat0 objC C".
+*)
+  Defined.
+End Law0.
diff --git a/test-suite/bugs/closed/HoTT_coq_023.v b/test-suite/bugs/closed/HoTT_coq_023.v
new file mode 100644
index 00000000..b52140de
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_023.v
@@ -0,0 +1,12 @@
+Set Universe Polymorphism.
+
+Record Type_Over (X : Type)
+:= { Domain :> Type;
+     proj : Domain -> X }.
+
+Definition Self_Over (X : Type)
+  := {| Domain := X; proj := (fun x => x) |}.
+
+Canonical Structure Self_Over. (* fails with Anomaly: Mismatched instance and context when building universe substitution. Please report. for polymorphic structures *)
+(* if monomorphic, Warning: No global reference exists for projection
+ valuefun x : _UNBOUND_REL_1 => x in instance Self_Over of proj, ignoring it. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_025.v b/test-suite/bugs/closed/HoTT_coq_025.v
new file mode 100644
index 00000000..b81b454d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_025.v
@@ -0,0 +1,29 @@
+Module monomorphic.
+  Class Inhabited (A : Type) : Prop := populate { _ : A }.
+  Arguments populate {_} _.
+
+  Instance prod_inhabited {A B : Type} (iA : Inhabited A)
+           (iB : Inhabited B) :   Inhabited (A * B) :=
+    match iA, iB with
+      | populate x, populate y => populate (x,y)
+    end.
+  (* Error: In environment
+A : Type
+B : Type
+iA : Inhabited A
+iB : Inhabited B
+The term "(A * B)%type" has type "Type" while it is expected to have type
+"Prop". *)
+End monomorphic.
+
+Module polymorphic.
+  Set Universe Polymorphism.
+  Class Inhabited (A : Type) : Prop := populate { _ : A }.
+  Arguments populate {_} _.
+
+  Instance prod_inhabited {A B : Type} (iA : Inhabited A)
+           (iB : Inhabited B) :   Inhabited (A * B) :=
+    match iA, iB with
+      | populate x, populate y => populate (x,y)
+    end.
+End polymorphic.
diff --git a/test-suite/bugs/closed/HoTT_coq_027.v b/test-suite/bugs/closed/HoTT_coq_027.v
new file mode 100644
index 00000000..27834cc4
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_027.v
@@ -0,0 +1,94 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Asymmetric Patterns.
+Set Universe Polymorphism.
+
+Record Category (obj : Type) := { Morphism : obj -> obj -> Type }.
+
+Record Functor `(C : Category objC) `(D : Category objD) :=
+  { ObjectOf :> objC -> objD;
+    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }.
+
+Definition TypeCat : @Category Type := @Build_Category Type (fun s d => s -> d).
+Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d).
+
+Definition FunctorToSet `(C : @Category objC) := Functor C SetCat.
+Definition FunctorToType `(C : @Category objC) := Functor C TypeCat.
+
+(* Removing the following line, as well as the [Definition] and [Identity Coercion] immediately following it, makes the file go through *)
+Identity Coercion FunctorToType_Id : FunctorToType >-> Functor.
+
+Set Printing Universes.
+Definition FunctorTo_Set2Type `(C : @Category objC) (F : FunctorToSet C)
+: FunctorToType C.
+  refine (@Build_Functor _ C _ TypeCat
+                         (fun x => F.(ObjectOf) x)
+                         (fun s d m => F.(MorphismOf) _ _ m)).
+(* ??? Toplevel input, characters 8-148:
+Error:
+In environment
+objC : Type{Top.100}
+C : Category@{Top.100 Top.101} objC
+F : FunctorToSet@{Top.100 Top.101 Top.99} C
+The term
+ "{|
+  ObjectOf := fun x : objC => F x;
+  MorphismOf := fun (s d : objC) (m : Morphism@{Top.100 Top.101} C s d) =>
+                MorphismOf@{Top.100 Top.101 Top.99 Set} F s d m |}" has type
+ "Functor@{Top.104 Top.105 Top.106 Top.107} C TypeCat@{Top.108 Top.109
+    Top.110}" while it is expected to have type
+ "FunctorToType@{Top.100 Top.101 Top.102 Top.103} C"
+(Universe inconsistency: Cannot enforce Set = Top.103)).
+ *)
+Defined. (* Toplevel input, characters 0-8:
+Error:
+The term
+ "fun (objC : Type) (C : Category objC) (F : FunctorToSet C) =>
+  {|
+  ObjectOf := fun x : objC => F x;
+  MorphismOf := fun (s d : objC) (m : Morphism C s d) => MorphismOf F s d m |}"
+has type
+ "forall (objC : Type) (C : Category objC),
+  FunctorToSet C -> Functor C TypeCat" while it is expected to have type
+ "forall (objC : Type) (C : Category objC), FunctorToSet C -> FunctorToType C".
+ *)
+
+Coercion FunctorTo_Set2Type : FunctorToSet >-> FunctorToType.
+
+Record GrothendieckPair `(C : @Category objC) (F : Functor C TypeCat) :=
+  { GrothendieckC : objC;
+    GrothendieckX : F GrothendieckC }.
+
+Record SetGrothendieckPair `(C : @Category objC) (F' : Functor C SetCat) :=
+  { SetGrothendieckC : objC;
+    SetGrothendieckX : F' SetGrothendieckC }.
+
+Section SetGrothendieckCoercion.
+  Context `(C : @Category objC).
+  Variable F : Functor C SetCat.
+  Let F' := (F : FunctorToSet _) : FunctorToType _. (* The command has indeed failed with message:
+=> Anomaly: apply_coercion_args: mismatch between arguments and coercion.
+Please report. *)
+
+  Set Printing Universes.
+  Definition SetGrothendieck2Grothendieck (G : SetGrothendieckPair F) : GrothendieckPair F'
+    := {| GrothendieckC := G.(SetGrothendieckC); GrothendieckX := G.(SetGrothendieckX) : F' _ |}.
+  (* Toplevel input, characters 0-187:
+Error: Illegal application:
+The term "ObjectOf (* Top.8375 Top.8376 Top.8379 Set *)" of type
+ "forall (objC : Type (* Top.8375 *))
+    (C : Category (* Top.8375 Top.8376 *) objC) (objD : Type (* Top.8379 *))
+    (D : Category (* Top.8379 Set *) objD),
+  Functor (* Top.8375 Top.8376 Top.8379 Set *) C D -> objC -> objD"
+cannot be applied to the terms
+ "objC" : "Type (* Top.8375 *)"
+ "C" : "Category (* Top.8375 Top.8376 *) objC"
+ "Type (* Set *)" : "Type (* Set+1 *)"
+ "TypeCat (* Top.8379 Set *)" : "Category (* Top.8379 Set *) Set"
+ "F'" : "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C"
+ "SetGrothendieckC (* Top.8375 Top.8376 Top.8379 *) G" : "objC"
+The 5th term has type "FunctorToType (* Top.8375 Top.8376 Top.8379 Set *) C"
+which should be coercible to
+ "Functor (* Top.8375 Top.8376 Top.8379 Set *) C TypeCat (* Top.8379 Set *)".
+ *)
+End SetGrothendieckCoercion.
diff --git a/test-suite/bugs/closed/HoTT_coq_028.v b/test-suite/bugs/closed/HoTT_coq_028.v
new file mode 100644
index 00000000..b0324140
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_028.v
@@ -0,0 +1,14 @@
+Goal forall (O obj : Type) (f : O -> obj) (x : O) (e : x = x)
+     (T : obj -> obj -> Type) (m : forall x0 : obj, T x0 x0),
+   match eq_sym e in (_ = y) return (T (f y) (f x)) with
+   | eq_refl => m (f x)
+   end = m (f x).
+intros.
+try case e.
+(* Toplevel input, characters 19-25:
+Error: Cannot instantiate metavariable P of type
+"forall a : O, x = a -> Prop" with abstraction
+"fun (x : O) (e : x = x) =>
+ match eq_sym e in (_ = y) return (T (f y) (f x)) with
+ | eq_refl => m (f x)
+ end = m (f x)" of incompatible type "forall x : O, x = x -> Prop". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_029.v b/test-suite/bugs/closed/HoTT_coq_029.v
new file mode 100644
index 00000000..4fd54b56
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_029.v
@@ -0,0 +1,335 @@
+Module FirstComment.
+  Set Implicit Arguments.
+  Generalizable All Variables.
+  Set Asymmetric Patterns.
+  Set Universe Polymorphism.
+
+  Reserved Notation "x # y" (at level 40, left associativity).
+  Reserved Notation "x #m y" (at level 40, left associativity).
+
+  Delimit Scope object_scope with object.
+  Delimit Scope morphism_scope with morphism.
+  Delimit Scope category_scope with category.
+
+  Record Category (obj : Type) :=
+    {
+      Object :> _ := obj;
+      Morphism : obj -> obj -> Type;
+
+      Identity : forall x, Morphism x x;
+      Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+    }.
+
+  Bind Scope object_scope with Object.
+  Bind Scope morphism_scope with Morphism.
+
+  Arguments Object {obj%type} C%category / : rename.
+  Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *)
+  Arguments Identity {obj%type} [!C%category] x%object : rename.
+  Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+  Bind Scope category_scope with Category.
+
+  Record Functor
+         `(C : @Category objC)
+         `(D : @Category objD)
+    := {
+        ObjectOf :> objC -> objD;
+        MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+      }.
+
+  Record NaturalTransformation
+         `(C : @Category objC)
+         `(D : @Category objD)
+         (F G : Functor C D)
+    := {
+        ComponentsOf :> forall c, D.(Morphism) (F c) (G c)
+      }.
+
+  Definition ProductCategory
+             `(C : @Category objC)
+             `(D : @Category objD)
+  : @Category (objC * objD)%type.
+    refine (@Build_Category _
+                            (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
+                            (fun o => (Identity (fst o), Identity (snd o)))
+                            (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))).
+
+  Defined.
+
+  Infix "*" := ProductCategory : category_scope.
+
+  Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) :=
+    {
+      IsomorphismOf_Morphism :> C.(Morphism) s d := m;
+      Inverse : C.(Morphism) d s
+    }.
+
+  Record NaturalIsomorphism
+         `(C : @Category objC)
+         `(D : @Category objD)
+         (F G : Functor C D)
+    := {
+        NaturalIsomorphism_Transformation :> NaturalTransformation F G;
+        NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x)
+      }.
+
+  Section PreMonoidalCategory.
+    Context `(C : @Category objC).
+
+    Variable TensorProduct : Functor (C * C) C.
+
+    Let src {C : @Category objC} {s d} (_ : Morphism C s d) := s.
+    Let dst {C : @Category objC} {s d} (_ : Morphism C s d) := d.
+
+    Local Notation "A # B" := (TensorProduct (A, B)).
+    Local Notation "A #m B" := (TensorProduct.(MorphismOf) ((@src _ _ _ A, @src _ _ _ B)) ((@dst _ _ _ A, @dst _ _ _ B)) (A, B)%morphism).
+
+    Let TriMonoidalProductL_ObjectOf (abc : C * C * C) : C :=
+      (fst (fst abc) # snd (fst abc)) # snd abc.
+
+    Let TriMonoidalProductR_ObjectOf (abc : C * C * C) : C :=
+      fst (fst abc) # (snd (fst abc) # snd abc).
+
+    Let TriMonoidalProductL_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) :
+      Morphism C (TriMonoidalProductL_ObjectOf s) (TriMonoidalProductL_ObjectOf d).
+    Admitted.
+
+    Let TriMonoidalProductR_MorphismOf (s d : C * C * C) (m : Morphism (C * C * C) s d) :
+      Morphism C (TriMonoidalProductR_ObjectOf s) (TriMonoidalProductR_ObjectOf d).
+    Admitted.
+
+    Definition TriMonoidalProductL : Functor (C * C * C) C.
+      refine (Build_Functor (C * C * C) C
+                            TriMonoidalProductL_ObjectOf
+                            TriMonoidalProductL_MorphismOf).
+    Defined.
+
+    Definition TriMonoidalProductR : Functor (C * C * C) C.
+      refine (Build_Functor (C * C * C) C
+                            TriMonoidalProductR_ObjectOf
+                            TriMonoidalProductR_MorphismOf).
+    Defined.
+
+    Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR.
+
+    Section AssociatorCoherenceCondition.
+      Variables a b c d : C.
+
+      (* going from top-left *)
+      Let AssociatorCoherenceConditionT0 : Morphism C (((a # b) # c) # d) ((a # (b # c)) # d)
+        := Associator (a, b, c) #m Identity (C := C) d.
+      Let AssociatorCoherenceConditionT1 : Morphism C ((a # (b # c)) # d) (a # ((b # c) # d))
+        := Associator (a, b # c, d).
+      Let AssociatorCoherenceConditionT2 : Morphism C (a # ((b # c) # d)) (a # (b # (c # d)))
+        := Identity (C := C) a #m Associator (b, c, d).
+      Let AssociatorCoherenceConditionB0 : Morphism C (((a # b) # c) # d) ((a # b) # (c # d))
+        := Associator (a # b, c, d).
+      Let AssociatorCoherenceConditionB1 : Morphism C ((a # b) # (c # d)) (a # (b # (c # d)))
+        := Associator (a, b, c # d).
+
+      Definition AssociatorCoherenceCondition' :=
+        Compose AssociatorCoherenceConditionT2 (Compose AssociatorCoherenceConditionT1 AssociatorCoherenceConditionT0)
+        = Compose AssociatorCoherenceConditionB1 AssociatorCoherenceConditionB0.
+    End AssociatorCoherenceCondition.
+
+    Definition AssociatorCoherenceCondition := Eval unfold AssociatorCoherenceCondition' in
+                                                forall a b c d : C, AssociatorCoherenceCondition' a b c d.
+  End PreMonoidalCategory.
+
+  Section MonoidalCategory.
+    Variable objC : Type.
+
+    Let AssociatorCoherenceCondition' := Eval unfold AssociatorCoherenceCondition in @AssociatorCoherenceCondition.
+
+    Record MonoidalCategory :=
+      {
+        MonoidalUnderlyingCategory :> @Category objC;
+        TensorProduct : Functor (MonoidalUnderlyingCategory * MonoidalUnderlyingCategory) MonoidalUnderlyingCategory;
+        IdentityObject : objC;
+        Associator : NaturalIsomorphism (TriMonoidalProductL TensorProduct) (TriMonoidalProductR TensorProduct);
+        AssociatorCoherent : AssociatorCoherenceCondition' Associator
+      }.
+  End MonoidalCategory.
+
+  Section EnrichedCategory.
+    Context `(M : @MonoidalCategory objM).
+    Let x : M := IdentityObject M.
+    (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report.  *)
+  End EnrichedCategory.
+End FirstComment.
+
+Module SecondComment.
+  Set Implicit Arguments.
+  Set Universe Polymorphism.
+  Generalizable All Variables.
+
+  Record prod (A B : Type) := pair { fst : A; snd : B }.
+  Arguments fst {A B} _.
+  Arguments snd {A B} _.
+  Infix "*" := prod : type_scope.
+  Notation " ( x , y ) " := (@pair _ _ x y).
+  Record Category (obj : Type) :=
+    Build_Category {
+        Object :> _ := obj;
+        Morphism : obj -> obj -> Type;
+
+        Identity : forall x, Morphism x x;
+        Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+      }.
+
+  Arguments Identity {obj%type} [!C] x : rename.
+  Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename.
+
+  Record > Category' :=
+    {
+      LSObject : Type;
+
+      LSUnderlyingCategory :> @Category LSObject
+    }.
+
+  Section Functor.
+    Context `(C : @Category objC).
+    Context `(D : @Category objD).
+
+
+    Record Functor :=
+      {
+        ObjectOf :> objC -> objD;
+        MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+      }.
+  End Functor.
+
+  Arguments MorphismOf {objC%type} [C] {objD%type} [D] F [s d] m : rename, simpl nomatch.
+
+  Section FunctorComposition.
+    Context `(C : @Category objC).
+    Context `(D : @Category objD).
+    Context `(E : @Category objE).
+
+    Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E.
+    Admitted.
+  End FunctorComposition.
+
+  Section IdentityFunctor.
+    Context `(C : @Category objC).
+
+
+    Definition IdentityFunctor : Functor C C.
+      refine {| ObjectOf := (fun x => x);
+                MorphismOf := (fun _ _ x => x)
+             |}.
+    Defined.
+  End IdentityFunctor.
+
+  Section ProductCategory.
+    Context `(C : @Category objC).
+    Context `(D : @Category objD).
+
+    Definition ProductCategory : @Category (objC * objD)%type.
+      refine (@Build_Category _
+                              (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
+                              (fun o => (Identity (fst o), Identity (snd o)))
+                              (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))).
+    Defined.
+  End ProductCategory.
+
+  Definition OppositeCategory `(C : @Category objC) : Category objC :=
+    @Build_Category objC
+                    (fun s d => Morphism C d s)
+                    (Identity (C := C))
+                    (fun _ _ _ m1 m2 => Compose m2 m1).
+
+  Parameter FunctorCategory : forall `(C : @Category objC) `(D : @Category objD), @Category (Functor C D).
+
+  Parameter TerminalCategory : Category unit.
+
+  Section ComputableCategory.
+    Variable I : Type.
+    Variable Index2Object : I -> Type.
+    Variable Index2Cat : forall i : I, @Category (@Index2Object i).
+
+    Local Coercion Index2Cat : I >-> Category.
+
+    Definition ComputableCategory : @Category I.
+      refine (@Build_Category _
+                              (fun C D : I => Functor C D)
+                              (fun o : I => IdentityFunctor o)
+                              (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))).
+    Defined.
+  End ComputableCategory.
+
+  Section SmallCat.
+    Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory.
+  End SmallCat.
+
+  Section CommaCategory.
+    Context `(A : @Category objA).
+    Context `(B : @Category objB).
+    Context `(C : @Category objC).
+    Variable S : Functor A C.
+    Variable T : Functor B C.
+
+    Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }.
+
+    Let SortPolymorphic_Helper (A T : Type) (Build_T : A -> T) := A.
+
+    Definition CommaCategory_ObjectT := Eval hnf in SortPolymorphic_Helper Build_CommaCategory_Object.
+    Definition Build_CommaCategory_Object' (mem : CommaCategory_ObjectT) := Build_CommaCategory_Object mem.
+    Global Coercion Build_CommaCategory_Object' : CommaCategory_ObjectT >-> CommaCategory_Object.
+
+    Definition CommaCategory : @Category CommaCategory_Object.
+    Admitted.
+  End CommaCategory.
+
+  Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C
+    := {| ObjectOf := (fun _ => a);
+          MorphismOf := (fun _ _ _ => Identity a)
+       |}.
+
+  Definition SliceCategoryOver
+  : forall (objC : Type) (C : Category objC) (a : C),
+      Category
+        (CommaCategory_Object (IdentityFunctor C)
+                              (SliceCategory_Functor C a)).
+    admit.
+  Defined.
+
+  Section CommaCategoryProjectionFunctor.
+    Context `(A : Category objA).
+    Context `(B : Category objB).
+    Context `(C : Category objC).
+
+    Variable S : (OppositeCategory (FunctorCategory A C)).
+    Variable T : (FunctorCategory B C).
+
+    Definition CommaCategoryProjection : Functor (CommaCategory S T) (ProductCategory A B).
+    Admitted.
+
+    Definition CommaCategoryProjectionFunctor_ObjectOf
+    : @SliceCategoryOver _ LocallySmallCat (ProductCategory A B)
+      :=
+        existT _
+               ((CommaCategory S T) : Category', tt)
+               (CommaCategoryProjection) :
+          CommaCategory_ObjectT (IdentityFunctor _)
+                                (SliceCategory_Functor LocallySmallCat
+                                                       (ProductCategory A B)).
+    (* Anomaly: apply_coercion_args: mismatch between arguments and coercion. Please report. *)
+    (* Toplevel input, characters 110-142:
+Error:
+In environment
+objA : Type
+A : Category objA
+objB : Type
+B : Category objB
+objC : Type
+C : Category objC
+S : OppositeCategory (FunctorCategory A C)
+T : FunctorCategory B C
+The term "ProductCategory A B:Category (objA * objB)" has type
+ "Category (objA * objB)" while it is expected to have type
+ "Object LocallySmallCat".
+ *)
+  End CommaCategoryProjectionFunctor.
+End SecondComment.
diff --git a/test-suite/bugs/closed/HoTT_coq_030.v b/test-suite/bugs/closed/HoTT_coq_030.v
new file mode 100644
index 00000000..fa5ee25c
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_030.v
@@ -0,0 +1,241 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Asymmetric Patterns.
+Set Universe Polymorphism.
+
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope functor_scope with functor.
+
+Local Open Scope category_scope.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type;
+
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+  }.
+
+Bind Scope category_scope with SpecializedCategory.
+Bind Scope object_scope with Object.
+Bind Scope morphism_scope with Morphism.
+
+Arguments Object {obj%type} C%category / : rename.
+Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *)
+Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+Record Category := {
+  CObject : Type;
+
+  UnderlyingCategory :> @SpecializedCategory CObject
+}.
+
+Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category.
+  refine {| CObject := C.(Object) |}; auto. (* Changing this [auto] to [assumption] removes the universe inconsistency. *)
+Defined.
+
+Coercion GeneralizeCategory : SpecializedCategory >-> Category.
+
+Record SpecializedFunctor
+       `(C : @SpecializedCategory objC)
+       `(D : @SpecializedCategory objD)
+  := {
+      ObjectOf :> objC -> objD;
+      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+    }.
+
+Section Functor.
+  Context (C D : Category).
+
+  Definition Functor := SpecializedFunctor C D.
+End Functor.
+
+Bind Scope functor_scope with SpecializedFunctor.
+Bind Scope functor_scope with Functor.
+
+Arguments SpecializedFunctor {objC} C {objD} D.
+Arguments Functor C D.
+Arguments ObjectOf {objC%type C%category objD%type D%category} F%functor c%object : rename, simpl nomatch.
+Arguments MorphismOf {objC%type} [C%category] {objD%type} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+
+Section FunctorComposition.
+  Context `(B : @SpecializedCategory objB).
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Context `(E : @SpecializedCategory objE).
+
+  Definition ComposeFunctors (G : SpecializedFunctor D E) (F : SpecializedFunctor C D) : SpecializedFunctor C E
+    := Build_SpecializedFunctor C E
+                                (fun c => G (F c))
+                                (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)).
+End FunctorComposition.
+
+Record SpecializedNaturalTransformation
+       `{C : @SpecializedCategory objC}
+       `{D : @SpecializedCategory objD}
+       (F G : SpecializedFunctor C D)
+  := {
+      ComponentsOf :> forall c, D.(Morphism) (F c) (G c)
+    }.
+
+Definition ProductCategory
+           `(C : @SpecializedCategory objC)
+           `(D : @SpecializedCategory objD)
+: @SpecializedCategory (objC * objD)%type
+  := @Build_SpecializedCategory _
+                                (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
+                                (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))).
+
+Infix "*" := ProductCategory : category_scope.
+
+Section ProductCategoryFunctors.
+  Context `{C : @SpecializedCategory objC}.
+  Context `{D : @SpecializedCategory objD}.
+
+  Definition fst_Functor : SpecializedFunctor (C * D) C
+    := Build_SpecializedFunctor (C * D) C
+                                (@fst _ _)
+                                (fun _ _ => @fst _ _).
+
+  Definition snd_Functor : SpecializedFunctor (C * D) D
+    := Build_SpecializedFunctor (C * D) D
+                                (@snd _ _)
+                                (fun _ _ => @snd _ _).
+End ProductCategoryFunctors.
+
+
+Definition OppositeCategory `(C : @SpecializedCategory objC) : @SpecializedCategory objC :=
+  @Build_SpecializedCategory objC
+                             (fun s d => Morphism C d s)
+                             (fun _ _ _ m1 m2 => Compose m2 m1).
+
+Section OppositeFunctor.
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Variable F : SpecializedFunctor C D.
+  Let COp := OppositeCategory C.
+  Let DOp := OppositeCategory D.
+
+  Definition OppositeFunctor : SpecializedFunctor COp DOp
+    := Build_SpecializedFunctor COp DOp
+                                (fun c : COp => F c : DOp)
+                                (fun (s d : COp) (m : C.(Morphism) d s) => MorphismOf F (s := d) (d := s) m).
+End OppositeFunctor.
+
+Section FunctorProduct.
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Context `(D' : @SpecializedCategory objD').
+
+  Definition FunctorProduct (F : Functor C D) (F' : Functor C D') : SpecializedFunctor C (D * D').
+    match goal with
+      | [ |- SpecializedFunctor ?C0 ?D0 ] =>
+        refine (Build_SpecializedFunctor
+                  C0 D0
+                  (fun c => (F c, F' c))
+                  (fun s d m => (MorphismOf F m, MorphismOf F' m)))
+    end.
+  Defined.
+End FunctorProduct.
+
+Section FunctorProduct'.
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Context `(C' : @SpecializedCategory objC').
+  Context `(D' : @SpecializedCategory objD').
+  Variable F : Functor C D.
+  Variable F' : Functor C' D'.
+
+  Definition FunctorProduct' : SpecializedFunctor  (C * C') (D * D')
+    := FunctorProduct (ComposeFunctors F fst_Functor) (ComposeFunctors F' snd_Functor).
+End FunctorProduct'.
+
+(** XXX TODO(jgross): Change this to [FunctorProduct]. *)
+Infix "*" := FunctorProduct' : functor_scope.
+
+Definition TypeCat : @SpecializedCategory Type :=
+  (@Build_SpecializedCategory Type
+                              (fun s d => s -> d)
+                              (fun _ _ _ f g => (fun x => f (g x)))).
+
+Section HomFunctor.
+  Context `(C : @SpecializedCategory objC).
+  Let COp := OppositeCategory C.
+
+  Definition CovariantHomFunctor (A : COp) : SpecializedFunctor C TypeCat
+    := Build_SpecializedFunctor C TypeCat
+                                (fun X : C => C.(Morphism) A X : TypeCat)
+                                (fun X Y f => (fun g : C.(Morphism) A X => Compose f g)).
+
+  Definition hom_functor_object_of (c'c : COp * C) := C.(Morphism) (fst c'c) (snd c'c) : TypeCat.
+
+  Definition hom_functor_morphism_of (s's : (COp * C)%type) (d'd : (COp * C)%type) (hf : (COp * C).(Morphism) s's d'd) :
+    TypeCat.(Morphism) (hom_functor_object_of s's) (hom_functor_object_of d'd).
+    unfold hom_functor_object_of in *.
+    destruct s's as [ s' s ], d'd as [ d' d ].
+    destruct hf as [ h f ].
+    intro g.
+    exact (Compose f (Compose g h)).
+  Defined.
+
+  Definition HomFunctor : SpecializedFunctor (COp * C) TypeCat
+    := Build_SpecializedFunctor (COp * C) TypeCat
+                                (fun c'c : COp * C => C.(Morphism) (fst c'c) (snd c'c) : TypeCat)
+                                (fun X Y (hf : (COp * C).(Morphism) X Y) => hom_functor_morphism_of hf).
+End HomFunctor.
+
+Section FullFaithful.
+  Context `(C : @SpecializedCategory objC).
+  Context `(D : @SpecializedCategory objD).
+  Variable F : SpecializedFunctor C D.
+  Let COp := OppositeCategory C.
+  Let DOp := OppositeCategory D.
+  Let FOp := OppositeFunctor F.
+
+  Definition InducedHomNaturalTransformation :
+    SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F))
+    := (Build_SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F))
+                                               (fun sd : (COp * C) =>
+                                                  MorphismOf F (s := _) (d := _))).
+End FullFaithful.
+
+Definition FunctorCategory
+           `(C : @SpecializedCategory objC)
+           `(D : @SpecializedCategory objD)
+: @SpecializedCategory (SpecializedFunctor C D).
+  refine (@Build_SpecializedCategory _
+                                     (SpecializedNaturalTransformation (C := C) (D := D))
+                                     _);
+  admit.
+Defined.
+
+Notation "C ^ D" := (FunctorCategory D C) : category_scope.
+
+Section Yoneda.
+  Context `(C : @SpecializedCategory objC).
+  Let COp := OppositeCategory C.
+
+  Section Yoneda.
+    Let Yoneda_NT s d (f : COp.(Morphism) s d) : SpecializedNaturalTransformation (CovariantHomFunctor C s) (CovariantHomFunctor C d)
+      := Build_SpecializedNaturalTransformation
+           (CovariantHomFunctor C s)
+           (CovariantHomFunctor C d)
+           (fun c : C => (fun m : C.(Morphism) _ _ => Compose m f)).
+
+    Definition Yoneda : SpecializedFunctor COp (TypeCat ^ C)
+      := Build_SpecializedFunctor COp (TypeCat ^ C)
+                                  (fun c : COp => CovariantHomFunctor C c : TypeCat ^ C)
+                                  (fun s d (f : Morphism COp s d) => Yoneda_NT s d f).
+  End Yoneda.
+End Yoneda.
+
+Section FullyFaithful.
+  Context `(C : @SpecializedCategory objC).
+
+  Set Printing Universes.
+  Check InducedHomNaturalTransformation (Yoneda C).
+  (* Error: Universe inconsistency (cannot enforce Top.865 = Top.851 because
+Top.851 < Top.869 <= Top.864 <= Top.865). *)
+End FullyFaithful.
diff --git a/test-suite/bugs/closed/HoTT_coq_032.v b/test-suite/bugs/closed/HoTT_coq_032.v
new file mode 100644
index 00000000..3f5d7b02
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_032.v
@@ -0,0 +1,22 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-xml") -*- *)
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Asymmetric Patterns.
+Set Universe Polymorphism.
+
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope functor_scope with functor.
+
+Local Open Scope category_scope.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type;
+
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+  }.
+(* Anomaly: Mismatched instance and context when building universe substitution.
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_034.v b/test-suite/bugs/closed/HoTT_coq_034.v
new file mode 100644
index 00000000..8d5201f6
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_034.v
@@ -0,0 +1,23 @@
+Module Short.
+  Set Universe Polymorphism.
+  Inductive relevant (A : Type) (B : Type) : Prop := .
+  Section foo.
+    Variables A B : Type.
+    Definition foo := prod (relevant A B) A.
+  End foo.
+
+  Section bar.
+    Variable A : Type.
+    Variable B : Type.
+    Definition bar := prod (relevant A B) A.
+  End bar.
+
+  Set Printing Universes.
+  Check bar nat Set : Set. (* success *)
+  Check foo nat Set : Set. (* Toplevel input, characters 6-17:
+Error:
+The term "foo (* Top.303 Top.304 *) nat Set" has type
+"Type (* Top.304 *)" while it is expected to have type
+"Set" (Universe inconsistency: Cannot enforce Top.304 = Set because Set
+< Top.304)). *)
+End Short.
diff --git a/test-suite/bugs/closed/HoTT_coq_035.v b/test-suite/bugs/closed/HoTT_coq_035.v
new file mode 100644
index 00000000..4ad2fc02
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_035.v
@@ -0,0 +1,19 @@
+Fail Check Prop : Prop. (* Prop:Prop
+     : Prop *)
+Fail Check Set : Prop. (* Set:Prop
+     : Prop *)
+Fail Check ((bool -> Prop) : Prop). (* bool -> Prop:Prop
+     : Prop *)
+Axiom proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2.
+Check ((True : Prop) : Set). (* (True:Prop):Set
+     : Set *)
+Goal (forall (v : Type) (f1 f0 : v -> Prop),
+        @eq (v -> Prop) f0 f1).
+intros.
+Fail apply proof_irrelevance.
+admit.
+Defined. (* Unnamed_thm is defined *)
+Set Printing Universes.
+Check ((True : Prop) : Set). (* Toplevel input, characters 0-28:
+Error: Universe inconsistency (cannot enforce Prop <= Set because Set
+< Prop). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v
new file mode 100644
index 00000000..4c3e078a
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_036.v
@@ -0,0 +1,135 @@
+Module Version1.
+  Set Implicit Arguments.
+  Set Universe Polymorphism.
+  Generalizable All Variables.
+
+  Record SpecializedCategory (obj : Type) :=
+    {
+      Object :> _ := obj
+    }.
+
+  Record > Category :=
+    {
+      CObject : Type;
+      UnderlyingCategory :> @SpecializedCategory CObject
+    }.
+
+  Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) :=
+    {
+      ObjectOf :> objC -> objD
+    }.
+
+  Definition Functor (C D : Category) := SpecializedFunctor C D.
+
+  Parameter TerminalCategory : SpecializedCategory unit.
+
+  Definition focus A (_ : A) := True.
+
+  Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type.
+    assert (Hf : focus ((S tt) = (S tt))) by constructor.
+    let C1 := constr:(CObject) in
+    let C2 := constr:(fun C => @Object (CObject C) C) in
+    unify C1 C2; idtac C1 C2. Show Universes.
+    progress change @CObject with (fun C => @Object (CObject C) C) in *. 
+    simpl in *.
+    match type of Hf with
+      | focus ?V => exact V
+    end.
+  Defined.
+
+  Definition Build_SliceCategory (A : Category) (F : Functor TerminalCategory A) := @Build_SpecializedCategory (CommaCategory_Object F).
+  Parameter SetCat : @SpecializedCategory Set.
+
+  Set Printing Universes.
+  Check (fun (A : Category) (F : Functor TerminalCategory A) => @Build_SpecializedCategory (CommaCategory_Object F)) SetCat.
+  (* (fun (A : Category (* Top.68 *))
+   (F : Functor (* Set Top.68 *) TerminalCategory A) =>
+ {|  |}) SetCat (* Top.68 *)
+     : forall
+         F : Functor (* Set Top.68 *) TerminalCategory SetCat (* Top.68 *),
+       let Object := CommaCategory_Object (* Top.68 Top.69 Top.68 *) F in
+       SpecializedCategory (* Top.69 *)
+         (CommaCategory_Object (* Top.68 Top.69 Top.68 *) F) *)
+  Check @Build_SliceCategory SetCat. (* Toplevel input, characters 0-34:
+Error: Universe inconsistency (cannot enforce Top.51 <= Set because Set
+< Top.51). *)
+End Version1.
+
+Module Version2.
+  Set Implicit Arguments.
+  Set Universe Polymorphism.
+
+  Record SpecializedCategory (obj : Type) :=
+    {
+      Object : _ := obj
+    }.
+
+  Record > Category :=
+    {
+      CObject : Type;
+      UnderlyingCategory :> @SpecializedCategory CObject
+    }.
+
+  Parameter TerminalCategory : SpecializedCategory unit.
+
+  Definition focus A (_ : A) := True.
+  Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC)
+                               (objD : Type) (D : SpecializedCategory objD), Prop.
+  Definition CommaCategory_Object (A : Category) : Type.
+    assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor.
+    progress change CObject with (fun C => @Object (CObject C) C) in *;
+      simpl in *.
+    match type of Hf with
+      | focus ?V => exact V
+    end.
+  Defined.
+
+  Definition Build_SliceCategory := @CommaCategory_Object.
+  Parameter SetCat : @SpecializedCategory Set.
+
+  Set Printing Universes.
+  Check @Build_SliceCategory SetCat.
+End Version2.
+
+Module OtherBug.
+  Set Implicit Arguments.
+  Set Universe Polymorphism.
+
+  Record SpecializedCategory (obj : Type) :=
+    {
+      Object : _ := obj
+    }.
+
+  Record > Category :=
+    {
+      CObject : Type;
+      UnderlyingCategory :> @SpecializedCategory CObject
+    }.
+
+  Parameter TerminalCategory : SpecializedCategory unit.
+
+  Definition focus A (_ : A) := True.
+
+  Parameter ObjectOf' : forall (objC : Type) (C : SpecializedCategory objC)
+                               (objD : Type) (D : SpecializedCategory objD), Prop.
+  Definition CommaCategory_Object (A : Category@{i}) : Type.
+    assert (Hf : focus (@ObjectOf' _ (@Build_Category unit TerminalCategory) _ A)) by constructor.
+    progress change CObject with (fun C => @Object (CObject C) C) in *;
+      simpl in *.
+    match type of Hf with
+      | focus ?V => exact V
+    end.
+  Defined.
+
+  Parameter SetCat : @SpecializedCategory Set.
+
+  Set Printing Universes.
+  Definition Build_SliceCategory := @CommaCategory_Object.
+  Check @CommaCategory_Object SetCat.
+  (* CommaCategory_Object (* Top.43 Top.44 Top.43 *) SetCat (* Top.43 *)
+     : Type (* Top.44 *) *)
+  Check @Build_SliceCategory SetCat.
+  (* Toplevel input, characters 0-34:
+Error: Universe inconsistency (cannot enforce Top.36 <= Set because Set
+< Top.36). *)
+End OtherBug.
diff --git a/test-suite/bugs/closed/HoTT_coq_037.v b/test-suite/bugs/closed/HoTT_coq_037.v
new file mode 100644
index 00000000..66476414
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_037.v
@@ -0,0 +1,16 @@
+Set Printing Universes.
+
+Fixpoint CardinalityRepresentative (n : nat) : Set :=
+  match n with
+    | O => Empty_set
+    | S n' => sum (CardinalityRepresentative n') unit
+  end.
+(* Toplevel input, characters 104-143:
+Error:
+In environment
+CardinalityRepresentative : nat -> Set
+n : nat
+n' : nat
+The term "(CardinalityRepresentative n' + unit)%type" has type
+ "Type (* max(Top.73, Top.74) *)" while it is expected to have type
+"Set". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_041.v b/test-suite/bugs/closed/HoTT_coq_041.v
new file mode 100644
index 00000000..79933bb8
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_041.v
@@ -0,0 +1,18 @@
+Set Printing All.
+Definition foo (s d : Prop)
+ : ((s : Set) -> (d : Set)) = ((s : Prop) -> (d : Prop))
+ := eq_refl. (* succeeds *)
+Definition bar (s d : Prop)
+ : ((fun x : Set => x) s -> (fun x : Set => x) d) = ((fun x : Prop => x) s -> (fun x : Prop => x) d)
+ := eq_refl. (* Toplevel input, characters 131-138:
+Error:
+In environment
+s : Prop
+d : Prop
+The term
+ "@eq_refl Set (forall _ : (fun x : Set => x) s, (fun x : Set => x) d)"
+has type "@eq Set (forall _ : s, d) (forall _ : s, d)"
+while it is expected to have type
+ "@eq Set (forall _ : s, d) (forall _ : s, d)"
+(cannot unify "forall _ : (fun x : Set => x) s, (fun x : Set => x) d" and
+"forall _ : (fun x : Prop => x) s, (fun x : Prop => x) d"). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_042.v b/test-suite/bugs/closed/HoTT_coq_042.v
new file mode 100644
index 00000000..6b206a2f
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_042.v
@@ -0,0 +1,27 @@
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Generalizable All Variables.
+
+Record Category (obj : Type) := { Morphism : obj -> obj -> Type }.
+
+Definition SetCat : @Category Set := @Build_Category Set (fun s d => s -> d).
+
+Record Foo := { foo : forall A (f : Morphism SetCat A A), True }.
+
+Local Notation PartialBuild_Foo pf := (@Build_Foo (fun A f => pf A f)).
+
+Set Printing Universes.
+Let SetCatFoo' : Foo.
+  let pf := fresh in
+  let pfT := fresh in
+  evar (pfT : Prop);
+    cut pfT;
+    [ subst pfT; intro pf;
+      let t := constr:(PartialBuild_Foo pf) in
+      let t' := (eval simpl in t) in
+      exact t'
+    | ].
+  admit.
+(* Toplevel input, characters 15-20:
+Error: Universe inconsistency (cannot enforce Set <= Prop).
+ *)
diff --git a/test-suite/bugs/closed/HoTT_coq_043.v b/test-suite/bugs/closed/HoTT_coq_043.v
new file mode 100644
index 00000000..5257a032
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_043.v
@@ -0,0 +1,15 @@
+Require Import Classes.RelationClasses List Setoid.
+
+Definition RowType := list Type.
+
+Inductive RowTypeDecidable (P : forall T, relation T) `(forall T, Equivalence (P T))
+: RowType -> Type :=
+| RTDecNil : RowTypeDecidable P _ nil
+| RTDecCons : forall T Ts, (forall t0 t1 : T,
+                              {P T t0 t1} + {~P T t0 t1})
+                           -> RowTypeDecidable P _ Ts
+                           -> RowTypeDecidable P _ (T :: Ts).
+(* Toplevel input, characters 15-378:
+Error:
+Last occurrence of "RowTypeDecidable" must have "H" as 2nd argument in
+ "RowTypeDecidable P (fun T : Type => H T) nil". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_044.v b/test-suite/bugs/closed/HoTT_coq_044.v
new file mode 100644
index 00000000..c824f53b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_044.v
@@ -0,0 +1,35 @@
+Require Import Classes.RelationClasses List Setoid.
+
+Definition eqT (T : Type) := @eq T.
+
+Set Universe Polymorphism.
+
+Definition RowType := list Type.
+
+
+Inductive Row : RowType -> Type :=
+| RNil : Row nil
+| RCons : forall T Ts, T -> Row Ts -> Row (T :: Ts).
+
+Inductive RowTypeDecidable (P : forall T, relation T) `(H : forall T, Equivalence (P T))
+: RowType -> Type :=
+| RTDecNil : RowTypeDecidable P H nil
+| RTDecCons : forall T Ts, (forall t0 t1 : T,
+                              {P T t0 t1} + {~P T t0 t1})
+                           -> RowTypeDecidable P H Ts
+                           -> RowTypeDecidable P H (T :: Ts).
+
+
+Set Printing Universes.
+
+Fixpoint Row_eq (Ts : RowType)
+: RowTypeDecidable (@eqT) _ Ts -> forall r1 r2 : Row Ts, {@eq (Row Ts) r1 r2} + {r1 <> r2}.
+(* Toplevel input, characters 81-87:
+Error:
+In environment
+Ts : RowType (* Top.53 Coq.Init.Logic.8 *)
+r1 : Row (* Top.54 Top.55 *) Ts
+r2 : Row (* Top.56 Top.57 *) Ts
+The term "Row (* Coq.Init.Logic.8 Top.59 *) Ts" has type
+ "Type (* max(Top.58+1, Top.59) *)" while it is expected to have type
+ "Type (* Coq.Init.Logic.8 *)" (Universe inconsistency). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_045.v b/test-suite/bugs/closed/HoTT_coq_045.v
new file mode 100644
index 00000000..00588ffb
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_045.v
@@ -0,0 +1,53 @@
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Generalizable All Variables.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj
+  }.
+
+Record > Category :=
+  {
+    CObject : Type;
+    UnderlyingCategory :> @SpecializedCategory CObject
+  }.
+
+Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) :=
+  {
+    ObjectOf :> objC -> objD
+  }.
+
+Definition Functor (C D : Category) := SpecializedFunctor C D.
+
+Parameter TerminalCategory : SpecializedCategory unit.
+
+Definition focus A (_ : A) := True.
+
+Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type.
+  assert (Hf : focus ((S tt) = (S tt))) by constructor.
+  let C1 := constr:(CObject) in
+  let C2 := constr:(fun C => @Object (CObject C) C) in
+  unify C1 C2.
+  progress change CObject with (fun C => @Object (CObject C) C) in *.
+  simpl in *.
+  let V := match type of Hf with
+             | focus ?V => constr:(V)
+           end
+  in exact V.
+(* Toplevel input, characters 89-96:
+Error: Illegal application:
+The term "ObjectOf" of type
+ "forall (objC : Set) (C : SpecializedCategory objC)
+    (objD : Type) (D : SpecializedCategory objD),
+  SpecializedFunctor C D -> objC -> objD"
+cannot be applied to the terms
+ "Object TerminalCategory" : "Type"
+ "TerminalCategory" : "SpecializedCategory unit"
+ "Object A" : "Type"
+ "UnderlyingCategory A" : "SpecializedCategory (CObject A)"
+ "S" : "Functor TerminalCategory A"
+ "tt" : "unit"
+The 1st term has type "Type" which should be coercible to
+"Set". *)
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_047.v b/test-suite/bugs/closed/HoTT_coq_047.v
new file mode 100644
index 00000000..29496be5
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_047.v
@@ -0,0 +1,46 @@
+Inductive nCk : nat -> nat -> Type :=
+  |zz : nCk 0 0
+  | incl { m n : nat } : nCk m n -> nCk (S m) (S n)
+  | excl { m n : nat } : nCk m n -> nCk (S m) n.
+
+Definition nCkComp { l m n : nat } :
+  nCk l m -> nCk m n -> nCk l n.
+Proof.
+  intro.
+  revert n.
+  induction H.
+  auto.
+(* ( incl w ) o zz -> contradiction *)
+  intros.
+    remember (S n) as sn.
+    destruct H0.
+      discriminate Heqsn.
+    apply incl.
+      apply IHnCk.
+      injection Heqsn.
+      intro.
+      rewrite <- H1.
+      auto.
+    apply excl.
+      apply IHnCk.
+      injection Heqsn.
+      intro. rewrite <- H1.
+      auto.
+  intros.
+  apply excl.
+  apply IHnCk.
+  auto.
+Defined.
+
+Lemma nCkEq { k l m n : nat } ( cs : nCk k l ) (ct : nCk l m) (cr : nCk m n ):
+  nCkComp cs (nCkComp ct cr) = nCkComp (nCkComp cs ct) cr.
+Proof.
+  revert m n ct cr.
+  induction cs.
+  intros. simpl. auto.
+  intros.
+  destruct n.
+   destruct m0.
+    destruct n0.
+     destruct cr.
+(* Anomaly: Evar ?nnn was not declared. Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_048.v b/test-suite/bugs/closed/HoTT_coq_048.v
new file mode 100644
index 00000000..831bb3fc
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_048.v
@@ -0,0 +1,7 @@
+(** This is not the issue of https://github.com/HoTT/coq/issues/48, but was mentioned there. *)
+Record Foo :=
+  {
+    foo := 1;
+    bar : foo = foo
+  }.
+(* Anomaly: lookup_projection: constant is not a projection. Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_049.v b/test-suite/bugs/closed/HoTT_coq_049.v
new file mode 100644
index 00000000..906ec329
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_049.v
@@ -0,0 +1,6 @@
+Require Import FunctionalExtensionality.
+
+Goal forall y, @f_equal = y.
+intro.
+apply functional_extensionality_dep.
+(* Error: Ill-typed evar instance in HoTT/coq, Anomaly: Uncaught exception Reductionops.NotASort(_). Please report. before that. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_050.v b/test-suite/bugs/closed/HoTT_coq_050.v
new file mode 100644
index 00000000..ce9b6b29
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_050.v
@@ -0,0 +1,33 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Asymmetric Patterns.
+Set Universe Polymorphism.
+Set Printing Universes.
+
+Set Printing All.
+
+Record PreCategory :=
+  {
+    Object :> Type;
+    Morphism : Object -> Object -> Type
+  }.
+
+Inductive paths A (x : A) : A -> Type := idpath : @paths A x x.
+Inductive Unit : Prop := tt. (* Changing this to [Set] fixes things *)
+Inductive Bool : Set := true | false.
+
+Definition DiscreteCategory X : PreCategory
+  := @Build_PreCategory X
+                        (@paths X).
+
+Definition IndiscreteCategory X : PreCategory
+  := @Build_PreCategory X
+                        (fun _ _ => Unit).
+
+Check (IndiscreteCategory Unit).
+Check (DiscreteCategory Bool).
+Definition NatCategory (n : nat) :=
+  match n with
+    | 0 => IndiscreteCategory Unit
+    | _ => DiscreteCategory Bool
+  end. (* Error: Universe inconsistency (cannot enforce Set <= Prop). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_052.v b/test-suite/bugs/closed/HoTT_coq_052.v
new file mode 100644
index 00000000..62bb9fa1
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_052.v
@@ -0,0 +1,22 @@
+Goal Type = Type.
+  Fail match goal with |- ?x = ?x => idtac end.
+Abort.
+
+Goal Prop.
+  Fail match goal with |- Type => idtac end.
+Abort.
+
+Goal Prop = Set.
+  (* This should fail *)
+ Fail match goal with |- ?x = ?x => idtac x end.
+Abort.
+
+Goal Type = Prop.
+  (* This should fail *)
+  Fail match goal with |- ?x = ?x => idtac end.
+Abort.
+
+Goal Type = Set.
+  (* This should fail *)
+  Fail match goal with |- ?x = ?x => idtac end.
+Abort.
diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v
new file mode 100644
index 00000000..a14fb6aa
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_053.v
@@ -0,0 +1,50 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Set Printing Universes.
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Asymmetric Patterns.
+Set Universe Polymorphism.
+
+Inductive Unit : Type :=
+    tt : Unit.
+
+Inductive Bool : Type :=
+  | true : Bool
+  | false : Bool.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Record PreCategory :=
+  {
+    Object :> Type;
+    Morphism : Object -> Object -> Type
+  }.
+
+Definition DiscreteCategory X : PreCategory
+  := @Build_PreCategory X
+                        (@paths X).
+
+Definition IndiscreteCategory X : PreCategory
+  := @Build_PreCategory X
+                         (fun _ _ => Unit).
+
+Definition NatCategory (n : nat) :=
+  match n with
+    | 0 => IndiscreteCategory Unit
+    | _ => DiscreteCategory Bool
+  end.
+(* Error: Universe inconsistency (cannot enforce Set <= Prop).*)
+
+Definition NatCategory' (n : nat) :=
+  match n with
+    | 0 => (fun X => @Build_PreCategory X
+                         (fun _ _ => Unit : Prop)) Unit
+    | _ => DiscreteCategory Bool
+  end.
+
+Definition NatCategory'' (n : nat) :=
+  match n with
+    | 0 => IndiscreteCategory Unit
+    | _ => DiscreteCategory Bool
+  end.
diff --git a/test-suite/bugs/closed/HoTT_coq_054.v b/test-suite/bugs/closed/HoTT_coq_054.v
new file mode 100644
index 00000000..c6879659
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_054.v
@@ -0,0 +1,94 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs") -*- *)
+Inductive Empty : Prop := .
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Arguments idpath {A a} , [A] a.
+
+Definition idmap {A : Type} : A -> A := fun x => x.
+
+Definition path_sum {A B : Type} (z z' : A + B)
+           (pq : match z, z' with
+                   | inl z0, inl z'0 => z0 = z'0
+                   | inr z0, inr z'0 => z0 = z'0
+                   | _, _ => Empty
+                 end)
+: z = z'.
+  destruct z, z', pq; exact idpath.
+Defined.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B)
+              (* Fortunately, this unifies properly *)
+              (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) :
+  let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in
+  ap f (path_sum x y pq) = path_sum (f x) (f y)
+     (* Coq appears to require *ALL* of the annotations *)
+     ((match x as x return match (x, y) with
+              (inl x', inl y') => x' = y'
+            | (inr x', inr y') => x' = y'
+            | _ => Empty
+          end -> match (f x, f y) with
+               | (inl x', inl y') => x' = y'
+               | (inr x', inr y') => x' = y'
+               | _ => Empty end with
+           | inl x' => match y as y return match y with
+                                               inl y' => x' = y'
+                                             | _ => Empty
+                                           end -> match f y with
+                                                    | inl y' => g x' = y'
+                                                    | _ => Empty end with
+                         | inl y' => ap g
+                         | inr y' => idmap
+                       end
+           | inr x' => match y as y return match y return Prop with
+                                               inr y' => x' = y'
+                                             | _ => Empty
+                                           end -> match f y return Prop with
+                                                    | inr y' => h x' = y'
+                                                    | _ => Empty end with
+                         | inl y' => idmap
+                         | inr y' => ap h
+                       end
+       end) pq).
+  destruct x; destruct y; destruct pq; reflexivity.
+Qed.
+(* Toplevel input, characters 1367-1374:
+Error:
+In environment
+A : Type
+B : Type
+A' : Type
+B' : Type
+g : A -> A'
+h : B -> B'
+x : A + B
+y : A + B
+pq :
+match x with
+| inl x' => match y with
+            | inl y' => x' = y'
+            | inr _ => Empty
+            end
+| inr x' => match y with
+            | inl _ => Empty
+            | inr y' => x' = y'
+            end
+end
+f :=
+fun z : A + B =>
+match z with
+| inl z' => inl (g z')
+| inr z' => inr (h z')
+end : A + B -> A' + B'
+x' : B
+y0 : A + B
+y' : B
+The term "x' = y'" has type "Type" while it is expected to have type
+"Prop" (Universe inconsistency). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_055.v b/test-suite/bugs/closed/HoTT_coq_055.v
new file mode 100644
index 00000000..92d70ad1
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_055.v
@@ -0,0 +1,53 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Set Universe Polymorphism.
+
+Inductive Empty : Prop := .
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Arguments idpath {A a} , [A] a.
+
+Definition idmap {A : Type} : A -> A := fun x => x.
+
+Definition path_sum {A B : Type} (z z' : A + B)
+           (pq : match z, z' with
+                   | inl z0, inl z'0 => z0 = z'0
+                   | inr z0, inr z'0 => z0 = z'0
+                   | _, _ => Empty
+                 end)
+: z = z'.
+
+  admit.
+Defined.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B)
+
+        (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) :
+  let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in
+  ap f (path_sum x y pq) = path_sum (f x) (f y)
+                                    ((match x as x return match (x, y) with
+                                                              (inl x', inl y') => x' = y'
+                                                            | (inr x', inr y') => x' = y'
+                                                            | _ => Empty
+                                                          end -> match (f x, f y) with
+                                                                   | (inl x', inl y') => x' = y'
+                                                                   | (inr x', inr y') => x' = y'
+                                                                   | _ => Empty end with
+                                        | inl x' => match y with
+                                                      | inl y' => ap g
+                                                      | inr y' => idmap
+                                                    end
+                                        | inr x' => match y with
+                                                      | inl y' => idmap
+                                                      | inr y' => ap h
+                                                    end
+                                      end) pq).
+
+Admitted.
+(* Toplevel input, characters 20-29:
+Error: Matching on term "f y" of type "A' + B'" expects 2 branches. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_056.v b/test-suite/bugs/closed/HoTT_coq_056.v
new file mode 100644
index 00000000..6e65320d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_056.v
@@ -0,0 +1,156 @@
+(* File reduced by coq-bug-finder from 10455 lines to 8350 lines, then from 7790 lines to 710 lines, then from 7790 lines to 710 lines, then from 566 lines to 340 lines, then from 191 lines to 171 lines, then from 191 lines to 171 lines. *)
+
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Reserved Notation "x ≅ y" (at level 70, no associativity).
+Reserved Notation "i ^op" (at level 3).
+Reserved Infix "∘" (at level 40, left associativity).
+Reserved Notation "F ⟨ x ⟩" (at level 10, no associativity, x at level 10).
+Reserved Notation "F ⟨ x , y ⟩" (at level 10, no associativity, x at level 10, y at level 10).
+Reserved Notation "F ⟨ ─ ⟩" (at level 10, no associativity).
+Reserved Notation "F ⟨ x , ─ ⟩" (at level 10, no associativity, x at level 10).
+Reserved Notation "F ⟨ ─ , y ⟩" (at level 10, no associativity, y at level 10).
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope functor_scope with functor.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Delimit Scope path_scope with path.
+Local Open Scope path_scope.
+
+Record PreCategory :=
+  Build_PreCategory' {
+      Object :> Type;
+      Morphism : Object -> Object -> Type
+    }.
+
+Bind Scope category_scope with PreCategory.
+
+Definition Build_PreCategory
+           Object Morphism
+  := @Build_PreCategory' Object
+                         Morphism.
+
+Record Functor (C D : PreCategory) :=
+  {
+    ObjectOf :> C -> D;
+    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+  }.
+Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Class Isomorphic {C : PreCategory} (s d : C) := {}.
+Definition ComposeFunctors C D E (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor C E
+                   (fun c => G (F c))
+                   (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)).
+
+Infix "∘" := ComposeFunctors : functor_scope.
+
+Definition IdentityFunctor C : Functor C C
+  := Build_Functor C C
+                   (fun x => x)
+                   (fun _ _ x => x).
+
+Notation "─" := (IdentityFunctor _) : functor_scope.
+Record NaturalTransformation C D (F G : Functor C D) :=
+  Build_NaturalTransformation' { }.
+
+Definition OppositeCategory (C : PreCategory) : PreCategory
+  := @Build_PreCategory' C
+                         (fun s d => Morphism C d s).
+
+Notation "C ^op" := (OppositeCategory C) : category_scope.
+
+Definition ProductCategory (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (C * D)%type
+                        (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type).
+
+Infix "*" := ProductCategory : category_scope.
+
+Definition OppositeFunctor C D (F : Functor C D) : Functor (C ^op) (D ^op)
+  := Build_Functor (C ^op) (D ^op)
+                   (ObjectOf F)
+                   (fun s d => MorphismOf F (s := d) (d := s)).
+Notation "F ^op" := (OppositeFunctor F) : functor_scope.
+
+Definition FunctorProduct' C D C' D' (F : Functor C D) (F' : Functor C' D') : Functor (C * C') (D * D')
+  := admit.
+
+Global Class FunctorApplicationInterpretable
+       {C D} (F : Functor C D)
+       {argsT : Type} (args : argsT)
+       {T : Type} (rtn : T)
+  := {}.
+Definition FunctorApplicationOf {C D} F {argsT} args {T} {rtn}
+           `{@FunctorApplicationInterpretable C D F argsT args T rtn}
+  := rtn.
+
+Global Arguments FunctorApplicationOf / {C} {D} F {argsT} args {T} {rtn} {_}.
+
+Global Instance FunctorApplicationDash C D (F : Functor C D)
+: FunctorApplicationInterpretable F (IdentityFunctor C) F | 0.
+Global Instance FunctorApplicationFunctorFunctor' A B C C' D (F : Functor (A * B) D) (G : Functor C A) (H : Functor C' B)
+: FunctorApplicationInterpretable F (G, H) (F ∘ (FunctorProduct' G H))%functor | 100.
+
+Notation "F ⟨ x ⟩" := (FunctorApplicationOf F%functor x%functor) : functor_scope.
+
+Notation "F ⟨ x , y ⟩" := (FunctorApplicationOf F%functor (x%functor , y%functor)) : functor_scope.
+
+Notation "F ⟨ ─ ⟩" := (F ⟨ ( ─ ) ⟩)%functor : functor_scope.
+
+Notation "F ⟨ x , ─ ⟩" := (F ⟨ x , ( ─ ) ⟩)%functor : functor_scope.
+
+Notation "F ⟨ ─ , y ⟩" := (F ⟨ ( ─ ) , y ⟩)%functor : functor_scope.
+
+Definition FunctorCategory (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D)
+                        (NaturalTransformation (C := C) (D := D)).
+
+Notation "[ C , D ]" := (FunctorCategory C D) : category_scope.
+
+Definition SetCat : PreCategory := @Build_PreCategory Type (fun x y => x -> y).
+
+Definition HomFunctor C : Functor (C^op * C) SetCat.
+admit.
+Defined.
+Definition NaturalIsomorphism (C D : PreCategory) F G := @Isomorphic [C, D] F G.
+Infix "≅" := NaturalIsomorphism : natural_transformation_scope.
+
+Local Open Scope functor_scope.
+Local Open Scope natural_transformation_scope.
+
+Section Adjunction.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Variable F : Functor C D.
+  Variable G : Functor D C.
+  Let Adjunction_Type := Eval simpl in HomFunctor D ⟨ F^op ⟨ ─ ⟩ , ─ ⟩ ≅ HomFunctor C ⟨ ─ , G ⟨ ─ ⟩ ⟩.
+  Record Adjunction := { AMateOf : Adjunction_Type }.
+End Adjunction.
+
+Section AdjunctionEquivalences.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Variable F : Functor C D.
+  Variable G : Functor D C.
+  Variable A : Adjunction F G.
+  Set Printing All.
+  Definition foo := @AMateOf C D F G A.
+(* File "./HoTT_coq_56.v", line 145, characters 37-38:
+Error:
+In environment
+C : PreCategory
+D : PreCategory
+F : Functor C D
+G : Functor D C
+A : @Adjunction C D F G
+The term "A" has type "@Adjunction C D F G" while it is expected to have type
+ "@Adjunction C D F G". *)
+End AdjunctionEquivalences.
diff --git a/test-suite/bugs/closed/HoTT_coq_057.v b/test-suite/bugs/closed/HoTT_coq_057.v
new file mode 100644
index 00000000..e72ce0c5
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_057.v
@@ -0,0 +1,33 @@
+Require Export Coq.Lists.List.
+
+Polymorphic Fixpoint LIn (A : Type) (a:A) (l:list A) : Type :=
+  match l with
+    | nil => False
+    | b :: m => (b = a) + LIn A a m
+  end.
+
+Polymorphic Inductive NTerm : Type :=
+| cterm : NTerm
+| oterm : list NTerm -> NTerm.
+
+Polymorphic Fixpoint dummy {A B} (x : list (A * B)) : list (A * B) :=
+  match x with
+    | nil => nil
+    | (_, _) :: _ => nil
+  end.
+
+Lemma foo :
+  forall v t sub vars,
+    LIn (nat * NTerm) (v, t) (dummy sub)
+    ->
+    (
+      LIn (nat * NTerm) (v, t) sub
+      *
+      notT (LIn nat v vars)
+    ).
+Proof.
+  induction sub; simpl; intros.
+  destruct H.
+  Set Printing Universes.
+  try (apply IHsub in X). (* Toplevel input, characters 5-21:
+Error: Universe inconsistency (cannot enforce Top.47 = Set). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_058.v b/test-suite/bugs/closed/HoTT_coq_058.v
new file mode 100644
index 00000000..9ce7dba9
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_058.v
@@ -0,0 +1,140 @@
+(* File reduced by coq-bug-finder from 10044 lines to 493 lines, then from 425 lines to 160 lines. *)
+Set Universe Polymorphism.
+Notation idmap := (fun x => x).
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+Notation "x .1" := (projT1 x) (at level 3) : fibration_scope.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Delimit Scope path_scope with path.
+Local Open Scope path_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+: forall x, f x = g x
+  := fun x => match h with idpath => idpath end.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
+
+Delimit Scope equiv_scope with equiv.
+Local Open Scope equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+
+Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+
+Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) :
+  (forall x, f x = g x) -> f = g
+  := (@apD10 A P f g)^-1.
+
+Inductive Unit : Set :=
+  tt : Unit.
+
+Definition path_prod_uncurried {A B : Type} (z z' : A * B)
+           (pq : (fst z = fst z') * (snd z = snd z'))
+: (z = z')
+  := match pq with (p,q) =>
+                   match z, z' return
+                         (fst z = fst z') -> (snd z = snd z') -> (z = z') with
+                     | (a,b), (a',b') => fun p q =>
+                                           match p, q with
+                                               idpath, idpath => idpath
+                                           end
+                   end p q
+     end.
+
+Definition path_prod {A B : Type} (z z' : A * B) :
+  (fst z = fst z') -> (snd z = snd z') -> (z = z')
+  := fun p q => path_prod_uncurried z z' (p,q).
+
+Definition path_prod' {A B : Type} {x x' : A} {y y' : B}
+: (x = x') -> (y = y') -> ((x,y) = (x',y'))
+  := fun p q => path_prod (x,y) (x',y') p q.
+
+Lemma path_forall_recr_beta `{Funext} A B x0 P f g e Px
+: @transport (forall a : A, B a)
+             (fun f => P f (f x0))
+             f
+             g
+             (@path_forall _ _ _ _ _ e)
+             Px
+  = @transport ((forall a, B a) * B x0)%type
+               (fun x => P (fst x) (snd x))
+               (f, f x0)
+               (g, g x0)
+               (path_prod' (@path_forall _ _ _ _ _ e) (e x0))
+               Px.
+
+  admit.
+Defined.
+Definition transport_path_prod'_beta' A B P (x x' : A) (y y' : B) (HA : x = x') (HB : y = y') (Px : P x y)
+: @transport (A * B) (fun xy => P (fst xy) (snd xy)) (x, y) (x', y') (@path_prod' A B x x' y y' HA HB) Px
+  = @transport A (fun x => P x y') x x' HA
+               (@transport B (fun y => P x y) y y' HB Px).
+  admit.
+Defined.
+Goal forall (T : Type) (T0 : T -> T -> Type)
+            (Pmor : forall s d : T, T0 s d -> Type) (x x0 : T)
+            (x1 : T0 x x0) (p : Pmor x x0 x1) (H : Funext),
+       transport
+         (fun x2 : {_ : T & Unit} -> {_ : T & Unit} =>
+            { x1 : _ & Pmor (x2 (x; tt)) .1 (x2 (x0; tt)) .1 x1})
+         (path_forall (fun c : {_ : T & Unit} => (c .1; tt)) idmap
+                      (fun x2 : {_ : T & Unit} =>
+                         let (x3, y) as s return ((s .1; tt) = s) := x2 in
+                         match y as y0 return ((x3; tt) = (x3; y0)) with
+                           | tt => idpath
+                         end)) (x1; p) = (x1; p).
+intros.
+let F := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(F) end in
+let H := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(H) end in
+let X := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(X) end in
+let T := match goal with |- appcontext[@transport _ (fun x0 => @?F x0) _ _ (@path_forall ?H ?X ?T ?f ?g ?e)] => constr:(T) end in
+let t0 := fresh "t0" in
+let t1 := fresh "t1" in
+let T1 := lazymatch type of F with (?T -> _) -> _ => constr:(T) end in
+    evar (t1 : T1);
+  let T0 := lazymatch type of F with (forall a : ?A, @?B a) -> ?C => constr:((forall a : A, B a) -> B t1 -> C) end in
+      evar (t0 : T0);
+
+    let dummy := fresh in
+    assert (dummy : forall x0, F x0 = t0 x0 (x0 t1));
+      [ let x0 := fresh in
+        intro x0;
+          simpl in *;
+          let GL0 := lazymatch goal with |- ?GL0 = _ => constr:(GL0) end in
+              let GL0' := fresh in
+              let GL1' := fresh in
+              set (GL0' := GL0);
+
+                let arg := match GL0 with appcontext[x0 ?arg] => constr:(arg) end in
+                assert (t1 = arg) by (subst t1; reflexivity); subst t1;
+                pattern (x0 arg) in GL0';
+                match goal with
+                  | [ GL0'' := ?GR _ |- _ ] => constr_eq GL0' GL0'';
+                                              pose GR as GL1'
+                end;
+
+                pattern x0 in GL1';
+                match goal with
+                  | [ GL1'' := ?GR _ |- _ ] => constr_eq GL1' GL1'';
+                                              assert (t0 = GR)
+                end;
+                subst t0; [ reflexivity | reflexivity ]
+            | clear dummy ];
+      let p := fresh in
+      pose (@path_forall_recr_beta H X T t1 t0) as p;
+        simpl in *;
+        rewrite p;
+        subst t0 t1 p.
+      rewrite transport_path_prod'_beta'.
+      (* Anomaly: Uncaught exception Invalid_argument("to_constraints: non-trivial algebraic constraint between universes", _).
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_059.v b/test-suite/bugs/closed/HoTT_coq_059.v
new file mode 100644
index 00000000..9c7e394d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_059.v
@@ -0,0 +1,17 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Set Universe Polymorphism.
+
+Inductive eq {A} (x : A) : A -> Type := eq_refl : eq x x.
+Notation "a = b" := (eq a b) : type_scope.
+
+Section foo.
+  Class Funext := { path_forall :> forall A P (f g : forall x : A, P x), (forall x, f x = g x) -> f = g }.
+  Context `{Funext, Funext}.
+
+  Set Printing Universes.
+
+  (** Typeclass resolution should pick up the different instances of Funext automatically *)
+  Definition foo := (@path_forall _ _ _ (@path_forall _ Set)).
+  (* Toplevel input, characters 0-60:
+Error: Universe inconsistency (cannot enforce Top.24 <= Top.23 because Top.23
+< Top.22 <= Top.24). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_061.v b/test-suite/bugs/closed/HoTT_coq_061.v
new file mode 100644
index 00000000..26c1f963
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_061.v
@@ -0,0 +1,132 @@
+(* There are some problems in materialize_evar with local definitions,
+   as CO below; this is not completely sorted out yet, but at least
+   it fails in a smooth way at the time of today [HH] *)
+
+(* File reduced by coq-bug-finder from 9039 lines to 7786 lines, then
+   from 7245 lines to 476 lines, then from 417 lines to 249 lines,
+   then from 171 lines to 127 lines. *)
+
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope functor_scope with functor.
+Delimit Scope natural_transformation_scope with natural_transformation.
+Reserved Infix "o" (at level 40, left associativity).
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
+  := match p with idpath => idpath end.
+
+Record PreCategory :=
+  {
+    Object :> Type;
+    Morphism : Object -> Object -> Type;
+
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' where "f 'o' g" := (Compose f g)
+  }.
+Bind Scope category_scope with PreCategory.
+
+Arguments Compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+Infix "o" := Compose : morphism_scope.
+Local Open Scope morphism_scope.
+
+Record Functor (C D : PreCategory) :=
+  {
+    ObjectOf :> C -> D;
+    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d);
+    FCompositionOf : forall s d d' (m1 : C.(Morphism) s d) (m2: C.(Morphism) d d'),
+                       MorphismOf _ _ (m2 o m1) = (MorphismOf _ _ m2) o (MorphismOf _ _ m1)
+  }.
+
+Bind Scope functor_scope with Functor.
+
+Arguments MorphismOf [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+
+Definition ComposeFunctors C D E
+           (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor C E
+                   (fun c => G (F c))
+                   admit
+                   admit.
+
+Infix "o" := ComposeFunctors : functor_scope.
+
+Record NaturalTransformation C D (F G : Functor C D) :=
+  {
+    ComponentsOf :> forall c, D.(Morphism) (F c) (G c);
+    Commutes : forall s d (m : C.(Morphism) s d),
+                 ComponentsOf d o F.(MorphismOf) m = G.(MorphismOf) m o ComponentsOf s
+  }.
+
+Generalizable All Variables.
+
+Section NTComposeT.
+
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Variables F F' F'' : Functor C D.
+
+  Variable T' : NaturalTransformation F' F''.
+  Variable T : NaturalTransformation F F'.
+  Let CO := fun c => T' c o T c.
+  Definition NTComposeT_Commutes s d (m : Morphism C s d)
+  : CO d o MorphismOf F m = MorphismOf F'' m o CO s.
+
+    admit.
+  Defined.
+  Definition NTComposeT
+  : NaturalTransformation F F''
+    := Build_NaturalTransformation F F''
+                                   (fun c => T' c o T c)
+                                   NTComposeT_Commutes.
+End NTComposeT.
+Definition NTWhiskerR C D E (F F' : Functor D E) (T : NaturalTransformation F F')
+           (G : Functor C D)
+  := Build_NaturalTransformation (F o G) (F' o G)
+                                 (fun c => T (G c))
+                                 admit.
+Global Class NTC_Composable A B (a : A) (b : B) (T : Type) (term : T) := {}.
+
+Definition NTC_Composable_term `{@NTC_Composable A B a b T term} := term.
+Notation "T 'o' U"
+  := (@NTC_Composable_term _ _ T%natural_transformation U%natural_transformation _ _ _)
+     : natural_transformation_scope.
+
+Local Open Scope natural_transformation_scope.
+
+Lemma NTWhiskerR_CompositionOf C D
+      (F G H : Functor C D)
+      (T : NaturalTransformation G H)
+      (T' : NaturalTransformation F G) B (I : Functor B C)
+: NTWhiskerR (NTComposeT T T') I = NTComposeT (NTWhiskerR T I) (NTWhiskerR T' I).
+
+  admit.
+Defined.
+Definition FunctorCategory C D : PreCategory
+  := @Build_PreCategory (Functor C D)
+                        (NaturalTransformation (C := C) (D := D))
+                        admit.
+
+Notation "[ C , D ]" := (FunctorCategory C D) : category_scope.
+
+Variable C : PreCategory.
+Variable D : PreCategory.
+Variable E : PreCategory.
+Fail Definition NTWhiskerR_Functorial (G : [C, D]%category)
+: [[D, E], [C, E]]%category
+  := Build_Functor
+       [C, D] [C, E]
+       (fun F => F o G)
+       (fun _ _ T => T o G)
+       (fun _ _ _ _ _ => inverse (NTWhiskerR_CompositionOf _ _ _)).
+(* Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v
new file mode 100644
index 00000000..db895316
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_062.v
@@ -0,0 +1,106 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *)
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Delimit Scope path_scope with path.
+Local Open Scope path_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y):
+  p # (f x) = f y
+  :=
+    match p with idpath => idpath end.
+
+Class IsEquiv {A B : Type} (f : A -> B) :=
+  BuildIsEquiv {
+      equiv_inv : B -> A
+    }.
+
+Record Equiv A B :=
+  BuildEquiv {
+      equiv_fun :> A -> B ;
+      equiv_isequiv :> IsEquiv equiv_fun
+    }.
+
+Existing Instance equiv_isequiv.
+
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+
+Inductive Bool : Type := true | false.
+
+Local Open Scope equiv_scope.
+Definition equiv_path (A B : Type) (p : A = B) : A <~> B
+  := BuildEquiv _ _ (transport (fun X:Type => X) p) admit.
+
+Class Univalence :=
+  isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B) .
+
+Section Univalence.
+  Context `{Univalence}.
+  Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B
+    := (equiv_path A B)^-1 f.
+
+  Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B)
+    := path_universe_uncurried (BuildEquiv _ _ f feq).
+End Univalence.
+
+Definition e : Equiv@{i j} Bool Bool.
+  admit.
+Defined.
+
+Definition p `{Univalence} : @paths Type Bool Bool := path_universe e.
+
+Theorem thm `{Univalence} : (forall A, ((A -> False) -> False) -> A) -> False.
+  intro f.
+  Set Printing Universes.
+  Set Printing All.
+  Show Universes.
+  pose proof (apD f p).
+  pose proof (apD f (path_universe e)).
+  admit.
+Defined.  (* ??? Toplevel input, characters 0-37:
+Error:
+Unable to satisfy the following constraints:
+In environment:
+H : Univalence@{Top.144 Top.145 Top.146 Top.147 Top.148}
+f : forall (A : Type{Top.150}) (_ : forall _ : forall _ : A, False, False), A
+
+?57 : "@IsEquiv@{Top.150 Top.145} Bool Bool (equiv_fun@{Set Set} Bool Bool e)" *)
+(* Toplevel input, characters 18-19:
+Error:
+In environment
+H : Univalence (* Top.148 Top.149 Top.150 Top.151 *)
+f : forall (A : Type (* Top.153 *))
+      (_ : forall _ : forall _ : A, False, False), A
+X : @paths (* Top.155 *)
+      ((fun A : Type (* Top.153 *) =>
+        forall _ : forall _ : forall _ : A, False, False, A) Bool)
+      (@transport (* Top.154 Top.155 *) Type (* Top.153 *)
+         (fun A : Type (* Top.153 *) =>
+          forall _ : forall _ : forall _ : A, False, False, A) Bool Bool
+         (@path_universe (* Top.148 Top.150 Top.151 Top.159 Top.153 Top.154
+            Top.149 Top.153 *) H Bool Bool
+            (equiv_fun (* Top.153 Top.153 *) Bool Bool e (* Top.153 *))
+            (equiv_isequiv (* Top.153 Top.153 *) Bool Bool e (* Top.153 *)))
+         (f Bool)) (f Bool)
+The term "@p (* Top.148 Top.172 Top.151 Top.150 Top.149 *) H" has type
+ "@paths (* Top.171 *) Set Bool Bool" while it is expected to have type
+ "@paths (* Top.169 *) Type (* Top.153 *) ?62 ?63"
+(Universe inconsistency: Cannot enforce Set = Top.153)). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_063.v b/test-suite/bugs/closed/HoTT_coq_063.v
new file mode 100644
index 00000000..777f6483
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_063.v
@@ -0,0 +1,34 @@
+Set Universe Polymorphism.
+Module A.
+  Inductive paths A (x : A) : A -> Type := idpath : paths A x x.
+
+  Notation "x = y" := (paths _ x y).
+
+  Inductive IsTrunc : nat -> Type -> Type :=
+  | BuildContr : forall A (center : A) (contr : forall y, center = y), IsTrunc 0 A
+  | trunc_S : forall A n, (forall x y : A, IsTrunc n (x = y)) -> IsTrunc (S n) A.
+
+  Existing Class IsTrunc.
+
+
+  Instance is_trunc_unit : IsTrunc 0 unit.
+  Proof. apply BuildContr with (center:=tt). now intros []. Defined.
+
+  Check (_ : IsTrunc 0 unit).
+End A.
+
+Module B.
+  Fixpoint IsTrunc (n : nat) (A : Type) : Type :=
+    match n with
+      | O => True
+      | S _ => False
+    end.
+
+  Existing Class IsTrunc.
+
+  Instance is_trunc_unit : IsTrunc 0 unit.
+  Proof. exact I. Defined.
+
+  Check (_ : IsTrunc 0 unit).
+  Fail Definition foo := (_ : IsTrunc 1 unit).
+End B.
diff --git a/test-suite/bugs/closed/HoTT_coq_064.v b/test-suite/bugs/closed/HoTT_coq_064.v
new file mode 100644
index 00000000..5f0a541b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_064.v
@@ -0,0 +1,190 @@
+(* File reduced by coq-bug-finder from 279 lines to 219 lines. *)
+
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Module Export Overture.
+  Reserved Notation "g 'o' f" (at level 40, left associativity).
+
+  Inductive paths {A : Type} (a : A) : A -> Type :=
+    idpath : paths a a.
+
+  Arguments idpath {A a} , [A] a.
+
+  Notation "x = y :> A" := (@paths A x y) : type_scope.
+
+  Notation "x = y" := (x = y :>_) : type_scope.
+
+  Delimit Scope path_scope with path.
+
+  Local Open Scope path_scope.
+
+  Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+    := match p with idpath => idpath end.
+
+  Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+  : forall x, f x = g x
+    := fun x => match h with idpath => idpath end.
+
+  Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
+
+  Delimit Scope equiv_scope with equiv.
+  Local Open Scope equiv_scope.
+
+  Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+
+  Class Funext.
+  Axiom isequiv_apD10 : `{Funext} -> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) .
+  Existing Instance isequiv_apD10.
+
+  Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) :
+    (forall x, f x = g x) -> f = g
+    :=
+      (@apD10 A P f g)^-1.
+
+End Overture.
+
+Module Export Core.
+
+  Set Implicit Arguments.
+  Delimit Scope morphism_scope with morphism.
+  Delimit Scope category_scope with category.
+  Delimit Scope object_scope with object.
+
+  Record PreCategory :=
+    {
+      object :> Type;
+      morphism : object -> object -> Type;
+
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+
+      associativity : forall x1 x2 x3 x4
+                             (m1 : morphism x1 x2)
+                             (m2 : morphism x2 x3)
+                             (m3 : morphism x3 x4),
+                        (m3 o m2) o m1 = m3 o (m2 o m1)
+    }.
+  Bind Scope category_scope with PreCategory.
+  Arguments compose [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+  Infix "o" := compose : morphism_scope.
+
+End Core.
+
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d)
+  }.
+
+Inductive Unit : Set :=
+  tt : Unit.
+
+Definition indiscrete_category (X : Type) : PreCategory
+  := @Build_PreCategory X
+                        (fun _ _ => Unit)
+                        (fun _ _ _ _ _ => tt)
+                        (fun _ _ _ _ _ _ _ => idpath).
+
+
+Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
+Section path_natural_transformation.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+
+  Section path.
+    Variables T U : NaturalTransformation F G.
+    Lemma path'_natural_transformation
+    : components_of T = components_of U
+      -> T = U.
+      admit.
+    Defined.
+    Lemma path_natural_transformation
+    : (forall x, T x = U x)
+      -> T = U.
+    Proof.
+      intros.
+      apply path'_natural_transformation.
+      apply path_forall; assumption.
+    Qed.
+  End path.
+End path_natural_transformation.
+Ltac path_natural_transformation :=
+  repeat match goal with
+           | _ => intro
+           | _ => apply path_natural_transformation; simpl
+         end.
+Definition comma_category A B C (S : Functor A C) (T : Functor B C)
+: PreCategory.
+  admit.
+Defined.
+Definition compose C D (F F' F'' : Functor C D)
+           (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F')
+: NaturalTransformation F F''
+  := Build_NaturalTransformation F F''
+                                 (fun c => T' c o T c).
+
+Infix "o" := compose : natural_transformation_scope.
+
+Local Open Scope natural_transformation_scope.
+
+Definition associativity `{fs : Funext}
+           C D F G H I
+           (V : @NaturalTransformation C D F G)
+           (U : @NaturalTransformation C D G H)
+           (T : @NaturalTransformation C D H I)
+: (T o U) o V = T o (U o V).
+Proof.
+  path_natural_transformation.
+
+  apply associativity.
+Qed.
+Definition functor_category `{Funext} (C D : PreCategory) : PreCategory
+  := @Build_PreCategory (Functor C D)
+                        (@NaturalTransformation C D)
+                        (@compose C D)
+                        (@associativity _ C D).
+
+Notation "C -> D" := (functor_category C D) : category_scope.
+
+Definition compose_functor `{Funext} (C D E : PreCategory) : object ((C -> D) -> ((D -> E) -> (C -> E))).
+  admit.
+
+Defined.
+
+Definition pullback_along `{Funext} (C C' D : PreCategory) (p : Functor C C')
+: object ((C' -> D) -> (C -> D))
+  := Eval hnf in compose_functor _ _ _ p.
+
+Definition IsColimit `{Funext} C D (F : Functor D C) 
+           (x : object
+                  (@comma_category (indiscrete_category Unit)
+                                   (@functor_category H (indiscrete_category Unit) C)
+                                   (@functor_category H D C)
+                                   admit
+                                   (@pullback_along H D (indiscrete_category Unit) C
+                                                    admit))) : Type
+  := admit.
+
+Generalizable All Variables.
+Axiom fs : Funext.
+
+Section bar.
+
+  Variable D : PreCategory.
+
+  Context `(has_colimits
+            : forall F : Functor D C,
+                @IsColimit _ C D F (colimits F)).
+(* Error: Unsatisfied constraints: Top.3773 <= Set
+ (maybe a bugged tactic). *)
+End bar.
diff --git a/test-suite/bugs/closed/HoTT_coq_067.v b/test-suite/bugs/closed/HoTT_coq_067.v
new file mode 100644
index 00000000..ad32a60c
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_067.v
@@ -0,0 +1,28 @@
+Set Universe Polymorphism.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Goal forall (A : Type) (P : forall _ : A, Type) (x0 : A)
+     (p : P x0) (q : @paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p)),
+   @paths (@paths (@sigT A P) (@existT A P x0 p) (@existT A P x0 p))
+     (@idpath (@sigT A P) (@existT A P x0 p))
+     (@idpath (@sigT A P) (@existT A P x0 p)).
+  intros.
+  induction q.
+  admit.
+Qed.
+(** Error: Illegal application:
+The term "paths_rect" of type
+ "forall (A : Type) (a : A) (P : forall a0 : A, paths a a0 -> Type),
+  P a (idpath a) -> forall (y : A) (p : paths a y), P y p"
+cannot be applied to the terms
+ "{x : _ & P x}" : "Type"
+ "s" : "{x : _ & P x}"
+ "fun (a : {x : _ & P x}) (_ : paths s a) => paths (idpath a) (idpath a)"
+   : "forall a : {x : _ & P x}, paths s a -> Type"
+ "match proof_admitted return (paths (idpath s) (idpath s)) with
+  end" : "paths (idpath s) (idpath s)"
+ "s" : "{x : _ & P x}"
+ "q" : "paths (existT P x0 p) (existT P x0 p)"
+The 3rd term has type "forall a : {x : _ & P x}, paths s a -> Type"
+which should be coercible to "forall a : {x : _ & P x}, paths s a -> Type". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_068.v b/test-suite/bugs/closed/HoTT_coq_068.v
new file mode 100644
index 00000000..f1cdcbf2
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_068.v
@@ -0,0 +1,61 @@
+Generalizable All Variables.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Module success.
+  Axiom bar : nat -> Type -> Type.
+
+  Definition foo (n : nat) (A : Type) : Type :=
+    match n with
+      | O => A
+      | S n' => forall x y : A, bar n' (x = y)
+    end.
+
+  Definition foo_succ n A : foo (S n) A.
+  Admitted.
+
+  Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y).
+  intros.
+  apply (foo_succ _ _).
+  Defined.
+End success.
+
+Module failure.
+  Fixpoint bar (n : nat) (A : Type) : Type :=
+    match n with
+      | O => A
+      | S n' => forall x y : A, bar n' (x = y)
+    end.
+
+  Definition foo_succ n A : bar (S n) A.
+  Admitted.
+
+  Goal forall n (X Y : Type) (y : X) (x : X), bar n (x = y).
+  intros.
+  apply foo_succ.
+  (* Toplevel input, characters 22-34:
+Error: In environment
+n : nat
+X : Type
+Y : Type
+y : X
+x : X
+Unable to unify
+ "forall x0 y0 : ?16,
+  (fix bar (n : nat) (A : Type) {struct n} : Type :=
+     match n with
+     | 0 => A
+     | S n' => forall x y : A, bar n' (x = y)
+     end) ?15 (x0 = y0)" with
+ "(fix bar (n : nat) (A : Type) {struct n} : Type :=
+     match n with
+     | 0 => A
+     | S n' => forall x y : A, bar n' (x = y)
+     end) n (x = y)".
+*)
+  Defined.
+End failure.
diff --git a/test-suite/bugs/closed/HoTT_coq_071.v b/test-suite/bugs/closed/HoTT_coq_071.v
new file mode 100644
index 00000000..b5a5ec1b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_071.v
@@ -0,0 +1,9 @@
+Set Universe Polymorphism.
+Definition foo : True.
+  abstract exact I.
+Defined.
+Eval hnf in foo. (* Should not be [I] *)
+Goal True.
+Proof.
+  Fail unify foo I.
+Abort.
diff --git a/test-suite/bugs/closed/HoTT_coq_074.v b/test-suite/bugs/closed/HoTT_coq_074.v
new file mode 100644
index 00000000..370c7d40
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_074.v
@@ -0,0 +1,10 @@
+Monomorphic Definition U1 := Type.
+Monomorphic Definition U2 := Type.
+
+Set Printing Universes.
+Definition foo : True.
+let t1 := type of U1 in
+let t2 := type of U2 in
+idtac t1 t2;
+pose (t1 : t2). exact I. 
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v
new file mode 100644
index 00000000..db3b60ed
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_077.v
@@ -0,0 +1,39 @@
+Set Implicit Arguments.
+
+Require Import Logic.
+
+Set Asymmetric Patterns.
+Set Record Elimination Schemes.
+Set Primitive Projections.
+
+Record prod (A B : Type) : Type :=
+  pair { fst : A; snd : B }.
+
+Print prod_rect.
+(** prod_rect =
+fun (A B : Type) (P : prod A B -> Type)
+  (f : forall (fst : A) (snd : B), P {| fst := fst; snd := snd |})
+  (p : prod A B) =>
+match p as p0 return (P p0) with
+| {| fst := x; snd := x0 |} => f x x0
+end
+     : forall (A B : Type) (P : prod A B -> Type),
+       (forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) ->
+       forall p : prod A B, P p
+
+Arguments A, B are implicit
+Argument scopes are [type_scope type_scope _ _ _]
+ *)
+
+(* What I really want: *)
+Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd))
+           (p : prod A B) : P p
+  := u (fst p) (snd p).
+
+Notation typeof x := ($(let T := type of x in exact T)$) (only parsing).
+
+(* Check for eta *)
+Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect').
+
+(* Check for the recursion principle I want *)
+Check eq_refl : @prod_rect = @prod_rect'.
diff --git a/test-suite/bugs/closed/HoTT_coq_078.v b/test-suite/bugs/closed/HoTT_coq_078.v
new file mode 100644
index 00000000..54cb68b0
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_078.v
@@ -0,0 +1,43 @@
+Set Implicit Arguments.
+Require Import Logic.
+
+(*Global Set Universe Polymorphism.*)
+Global Set Asymmetric Patterns.
+Local Set Primitive Projections.
+
+Local Open Scope type_scope.
+
+Record prod (A B : Type) : Type :=
+  pair { fst : A; snd : B }.
+
+Arguments pair {A B} _ _.
+
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+
+Generalizable Variables X A B f g n.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition transport_prod' {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
+  (z : P a * Q a)
+  : transport (fun a => P a * Q a) p z  =  (transport _ p (fst z), transport _ p (snd z))
+  := match p as p' return transport (fun a0 => P a0 * Q a0) p' z = (transport P p' (fst z), transport Q p' (snd z)) with
+       | idpath => idpath
+     end. (* success *)
+
+Definition transport_prod {A : Type} {P Q : A -> Type} {a a' : A} (p : a = a')
+  (z : P a * Q a)
+  : transport (fun a => P a * Q a) p z  =  (transport _ p (fst z), transport _ p (snd z))
+  := match p with
+       | idpath => idpath
+     end.
diff --git a/test-suite/bugs/closed/HoTT_coq_079.v b/test-suite/bugs/closed/HoTT_coq_079.v
new file mode 100644
index 00000000..e70de9ca
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_079.v
@@ -0,0 +1,16 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Inductive paths A (x : A) : A -> Type := idpath : paths x x.
+
+Notation "x = y :> A" := (@paths A x y).
+Notation "x = y" := (x = y :> _).
+
+Record foo := { x : Type; H : x = x }.
+
+Create HintDb bar discriminated.
+Hint Resolve H : bar.
+Goal forall y : foo, @x y = @x y.
+intro y.
+progress auto with bar. (* failed to progress *)
diff --git a/test-suite/bugs/closed/HoTT_coq_080.v b/test-suite/bugs/closed/HoTT_coq_080.v
new file mode 100644
index 00000000..6b07c304
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_080.v
@@ -0,0 +1,27 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Set Asymmetric Patterns.
+Set Printing Projections.
+Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B.
+Inductive Empty :=.
+
+Record category :=
+  { ob :> Type;
+    hom : ob -> ob -> Type
+  }.
+
+Definition sum_category (C D : category) : category :=
+  {|
+    ob := sum (ob C) (ob D);
+    hom x y := match x, y with
+                 | inl x, inl y => @hom C x y
+                 | inr x, inr y => @hom D x y
+                 | _, _ => Empty
+               end |}.
+
+Goal forall C D (x y : ob (sum_category C D)), Type.
+intros C D x y.
+hnf in x, y.
+exact (hom (sum_category _ _) x y). 
+Defined.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/HoTT_coq_081.v b/test-suite/bugs/closed/HoTT_coq_081.v
new file mode 100644
index 00000000..ac27dea7
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_081.v
@@ -0,0 +1,16 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Record category (A : Type) :=
+  { ob :> Type;
+    hom : ob -> ob -> Type
+  }.
+
+Record foo { A: Type } := { C : category A; x : ob C; y :> hom _ x x }.
+Definition comp A (C : category A) (x : C) (f : hom _ x x) := f.
+
+Definition bar A (f : @foo A) := @comp _ _ _ f.
+
+(* Toplevel input, characters 0-42:
+Error: Cannot find the target class. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_082.v b/test-suite/bugs/closed/HoTT_coq_082.v
new file mode 100644
index 00000000..ccba22ca
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_082.v
@@ -0,0 +1,19 @@
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Record category :=
+  { ob : Type }.
+
+Existing Class category. (*
+Toplevel input, characters 0-24:
+Anomaly: Mismatched instance and context when building universe substitution.
+Please report. *)
+
+Record category' :=
+  { ob' : Type;
+    hom' : ob' -> ob' -> Type }.
+
+Existing Class category'. (*
+Toplevel input, characters 0-24:
+Anomaly: Mismatched instance and context when building universe substitution.
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_083.v b/test-suite/bugs/closed/HoTT_coq_083.v
new file mode 100644
index 00000000..494b25c7
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_083.v
@@ -0,0 +1,29 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Record category :=
+  { ob : Type }.
+
+Goal forall C, ob C -> ob C.
+intros.
+generalize dependent (ob C).
+(* 1 subgoals, subgoal 1 (ID 7)
+
+  C : category
+  ============================
+   forall T : Type, T -> T
+(dependent evars:) *)
+intros T t.
+Undo 2.
+generalize dependent (@ob C).
+(* 1 subgoals, subgoal 1 (ID 6)
+
+  C : category
+  X : ob C
+  ============================
+   Type -> ob C
+(dependent evars:) *)
+intros T t.
+(* Toplevel input, characters 9-10:
+Error: No product even after head-reduction. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_084.v b/test-suite/bugs/closed/HoTT_coq_084.v
new file mode 100644
index 00000000..d007e4e2
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_084.v
@@ -0,0 +1,49 @@
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Module success.
+  Unset Primitive Projections.
+
+  Record group :=
+    { carrier : Type;
+      id : carrier }.
+
+  Notation "1" := (id _) : g_scope.
+
+  Delimit Scope g_scope with g.
+  Bind Scope g_scope with carrier.
+
+  Section foo.
+    Variable g : group.
+    Variable comp : carrier g -> carrier g -> carrier g.
+
+    Check comp 1 1.
+  End foo.
+End success.
+
+Module failure.
+  Set Primitive Projections.
+
+  Record group :=
+    { carrier : Type;
+      id : carrier }.
+
+  Notation "1" := (id _) : g_scope.
+
+  Delimit Scope g_scope with g.
+  Bind Scope g_scope with carrier.
+
+  Section foo.
+    Variable g : group.
+    Variable comp : carrier g -> carrier g -> carrier g.
+
+    Check comp 1 1.
+    (* Toplevel input, characters 11-12:
+Error:
+In environment
+g : group
+comp : carrier g -> carrier g -> carrier g
+The term "1" has type "nat" while it is expected to have type "carrier g".
+    *)
+  End foo.
+End failure.
diff --git a/test-suite/bugs/closed/HoTT_coq_085.v b/test-suite/bugs/closed/HoTT_coq_085.v
new file mode 100644
index 00000000..041c6799
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_085.v
@@ -0,0 +1,74 @@
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Module success.
+  Unset Primitive Projections.
+
+  Record category :=
+    { ob : Type;
+      hom : ob -> ob -> Type;
+      comp : forall x y z, hom y z -> hom x y -> hom x z }.
+
+  Delimit Scope hom_scope with hom.
+  Bind Scope hom_scope with hom.
+  Arguments hom : clear implicits.
+  Arguments comp _ _ _ _ _%hom _%hom : clear implicits.
+
+  Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope.
+
+  Record functor (C D : category) :=
+    { ob_of : ob C -> ob D;
+      hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }.
+
+  Delimit Scope functor_scope with functor.
+  Bind Scope functor_scope with functor.
+
+  Arguments hom_of _ _ _%functor _ _ _%hom.
+
+  Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope.
+
+  Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E.
+  Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope.
+
+  Check ((_ o _) _1 _)%hom. (* ((?16 o ?17) _1 ?20)%hom
+     : hom ?15 (ob_of (?16 o ?17) ?18) (ob_of (?16 o ?17) ?19) *)
+End success.
+
+Module failure.
+  Set Primitive Projections.
+
+  Record category :=
+    { ob : Type;
+      hom : ob -> ob -> Type;
+      comp : forall x y z, hom y z -> hom x y -> hom x z }.
+
+  Delimit Scope hom_scope with hom.
+  Bind Scope hom_scope with hom.
+  Arguments hom : clear implicits.
+  Arguments comp _ _ _ _ _%hom _%hom : clear implicits.
+
+  Notation "f 'o' g" := (comp _ _ _ _ f g) (at level 40, left associativity) : hom_scope.
+
+  Record functor (C D : category) :=
+    { ob_of : ob C -> ob D;
+      hom_of : forall x y, hom C x y -> hom D (ob_of x) (ob_of y) }.
+
+  Delimit Scope functor_scope with functor.
+  Bind Scope functor_scope with functor.
+
+  Arguments hom_of _ _ _%functor _ _ _%hom.
+
+  Notation "F '_1' m" := (hom_of F _ _ m) (at level 10, no associativity) : hom_scope.
+  Notation "F '_2' m" := (hom_of F%functor _ _ m) (at level 10, no associativity) : hom_scope.
+
+  Axiom f_comp : forall C D E, functor D E -> functor C D -> functor C E.
+  Notation "f 'o' g" := (@f_comp _ _ _ f g) (at level 40, left associativity) : functor_scope.
+
+  Check ((_ o _) _2 _)%hom. (* ((?14 o ?15)%functor _1 ?18)%hom
+     : hom ?13 (ob_of (?14 o ?15)%functor ?16)
+         (ob_of (?14 o ?15)%functor ?17) *)
+  Check ((_ o _) _1 _)%hom. (* Toplevel input, characters 7-19:
+Error:
+The term "(?23 o ?24)%hom" has type "hom ?19 ?20 ?22"
+while it is expected to have type "functor ?25 ?26". *)
+End failure.
diff --git a/test-suite/bugs/closed/HoTT_coq_087.v b/test-suite/bugs/closed/HoTT_coq_087.v
new file mode 100644
index 00000000..265310b1
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_087.v
@@ -0,0 +1,14 @@
+Structure type : Type := Pack { ob : Type }.
+Polymorphic Record category := { foo : Type }.
+Definition FuncComp := Pack category.
+Axiom C : category.
+
+Check (C : ob FuncComp). (* OK *)
+
+Canonical Structure FuncComp.
+
+Check (C : ob FuncComp).
+(* Toplevel input, characters 15-39:
+Error:
+The term "C" has type "category" while it is expected to have type
+ "ob FuncComp". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_088.v b/test-suite/bugs/closed/HoTT_coq_088.v
new file mode 100644
index 00000000..b3e1df57
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_088.v
@@ -0,0 +1,78 @@
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Arguments paths_ind [A] a P f y p.
+Arguments paths_rec [A] a P f y p.
+Arguments paths_rect [A] a P f y p.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+(** A typeclass that includes the data making [f] into an adjoint equivalence. *)
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : Sect equiv_inv f;
+  eissect : Sect f equiv_inv;
+  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Record Equiv A B := BuildEquiv {
+  equiv_fun :> A -> B ;
+  equiv_isequiv :> IsEquiv equiv_fun
+}.
+
+
+Definition equiv_path (A B : Type) (p : A = B) : Equiv A B.
+Admitted.
+
+Class Univalence := {
+  isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B)
+}.
+
+Definition ua_downward_closed `{Univalence} : Univalence.
+  constructor.
+  intros A B.
+  destruct H as [H].
+  generalize (fun A B => @eisretr _ _ _ (H (A : Type) (B : Type))).
+  generalize (fun A B => @eissect _ _ _ (H (A : Type) (B : Type))).
+  let g := match goal with |- _ -> _ -> ?g => constr:(g) end in
+  let U0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U0) end in
+  let U1 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U1) end in
+  let U2 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U2) end in
+  let U3 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(U3) end in
+  let f0 := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f) end in
+  let f' := match goal with |- (forall (A : ?U0) (B : ?U1), Sect (@?f A B) _) -> (forall (A : ?U2) (B : ?U3), Sect _ (@?f' A B)) -> ?g => constr:(f') end in
+  change ((forall (A : U0) (B : U1), Sect (f0 A B) ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B))
+          -> (forall (A : U2) (B : U3), Sect ((fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B)) A B) (f' A B))
+          -> g);
+    generalize (fun (A : U0) (B : U1) => @equiv_inv _ _ _ (H A B));
+    clear H;
+    simpl;
+    intros fi sect retr.
+  pose proof fi as fi'.
+  Set Printing All.
+  change (forall (A : Type) (B : Type) (_ : Equiv A B), @paths Type A B) in fi'.
+  (*refine (@isequiv_adjointify
+              _ _
+              _ _
+              _
+              _);
+    admit.
+  Grab Existential Variables.*)
+  admit.
+  (*destruct p.*)
+  (*specialize (H (A' : Type)).*)
+Defined.
+(* Error: Unsatisfied constraints:
+Top.62 < Top.61
+Top.64 <= Top.62
+Top.63 <= Top.62
+ (maybe a bugged tactic).*)
diff --git a/test-suite/bugs/closed/HoTT_coq_089.v b/test-suite/bugs/closed/HoTT_coq_089.v
new file mode 100644
index 00000000..2da4aff6
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_089.v
@@ -0,0 +1,44 @@
+Set Implicit Arguments. 
+Set Universe Polymorphism.
+Set Printing Universes.
+
+Inductive type_paths (A : Type) : Type -> Prop
+  := idtypepath : type_paths A A.
+Monomorphic Definition comp_type_paths := Eval compute in type_paths@{Type Type}.
+Check comp_type_paths.
+(* comp_type_paths
+     : Type (* Top.12 *) -> Type (* Top.12 *) -> Prop *)
+(* This is terrible. *)
+
+Inductive type_paths' (A : Type) : Type -> Prop
+  := idtypepath' : type_paths' A A
+   | other_type_path : False -> forall B : Type, type_paths' A B.
+Monomorphic Definition comp_type_paths' := Eval compute in type_paths'.
+Check comp_type_paths'.
+(* comp_type_paths'
+     : Type (* Top.24 *) -> Type (* Top.23 *) -> Prop *)
+(* Ok, then ... *)
+
+(** Fail if it's [U0 -> U0 -> _], but not on [U0 -> U1 -> _]. *)
+Goal Type.
+Proof.
+  match type of comp_type_paths' with
+    | ?U0 -> ?U1 -> ?R
+      => exact (@comp_type_paths' nat U0)
+  end.
+Defined.
+
+Goal Type.
+Proof.
+   match type of comp_type_paths with
+    | ?U0 -> ?U1 -> ?R
+      => exact (@comp_type_paths nat U0)
+  end.
+  (* Toplevel input, characters 110-112:
+Error:
+The term "Type (* Top.51 *)" has type "Type (* Top.51+1 *)"
+while it is expected to have type "Type (* Top.51 *)"
+(Universe inconsistency: Cannot enforce Top.51 < Top.51 because Top.51
+= Top.51)). *)
+  
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v
new file mode 100644
index 00000000..5c704147
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_090.v
@@ -0,0 +1,187 @@
+(** I'm not sure if this tests what I want it to test... *)
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Notation idmap := (fun x => x).
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Arguments paths_ind [A] a P f y p.
+Arguments paths_rec [A] a P f y p.
+Arguments paths_rect [A] a P f y p.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+(** A typeclass that includes the data making [f] into an adjoint equivalence. *)
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : Sect equiv_inv f;
+  eissect : Sect f equiv_inv;
+  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Arguments eisretr {A B} f {_} _.
+Arguments eissect {A B} f {_} _.
+Arguments eisadj {A B} f {_} _.
+
+
+Record Equiv A B := BuildEquiv {
+  equiv_fun :> A -> B ;
+  equiv_isequiv :> IsEquiv equiv_fun
+}.
+
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
+  match p, q with idpath, idpath => idpath end.
+
+(** See above for the meaning of [simpl nomatch]. *)
+Arguments concat {A x y z} p q : simpl nomatch.
+
+(** The inverse of a path. *)
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x
+  := match p with idpath => idpath end.
+
+(** Declaring this as [simpl nomatch] prevents the tactic [simpl] from expanding it out into [match] statements.  We only want [inverse] to simplify when applied to an identity path. *)
+Arguments inverse {A x y} p : simpl nomatch.
+
+(** Note that you can use the built-in Coq tactics [reflexivity] and [transitivity] when working with paths, but not [symmetry], because it is too smart for its own good.  Instead, you can write [apply symmetry] or [eapply symmetry]. *)
+
+(** The identity path. *)
+Notation "1" := idpath : path_scope.
+
+(** The composition of two paths. *)
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+
+(** The inverse of a path. *)
+Notation "p ^" := (inverse p) (at level 3) : path_scope.
+
+(** An alternative notation which puts each path on its own line.  Useful as a temporary device during proofs of equalities between very long composites; to turn it on inside a section, say [Open Scope long_path_scope]. *)
+Notation "p @' q" := (concat p q) (at level 21, left associativity,
+  format "'[v' p '/' '@''  q ']'") : long_path_scope.
+
+
+(** An important instance of [paths_rect] is that given any dependent type, one can _transport_ elements of instances of the type along equalities in the base.
+
+   [transport P p u] transports [u : P x] to [P y] along [p : x = y]. *)
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+(** See above for the meaning of [simpl nomatch]. *)
+Arguments transport {A} P {x y} p%path_scope u : simpl nomatch.
+
+
+
+Instance isequiv_path {A B : Type} (p : A = B)
+  : IsEquiv (transport (fun X:Type => X) p) | 0.
+Proof.
+  refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _);
+  admit.
+Defined.
+
+Definition equiv_path (A B : Type) (p : A = B) : Equiv A B
+  := @BuildEquiv _ _ (transport (fun X:Type => X) p) _.
+
+Arguments equiv_path : clear implicits.
+
+Definition equiv_adjointify A B (f : A -> B) (g : B -> A) (r : Sect g f) (s : Sect f g) : Equiv A B.
+Proof.
+  refine (@BuildEquiv A B f (@BuildIsEquiv A B f g r s _)).
+  admit.
+Defined.
+
+
+Set Printing Universes.
+
+Definition lift_id_type : Type.
+Proof.
+  let U0 := constr:(Type) in
+  let U1 := constr:(Type) in
+  let unif := constr:(U0 : U1) in
+  exact (forall (A : Type) (B : Type), @paths U0 A B -> @paths U1 A B).
+Defined.
+
+Definition lower_id_type : Type.
+Proof.
+  let U0 := constr:(Type) in
+  let U1 := constr:(Type) in
+  let unif := constr:(U0 : U1) in
+  exact ((forall (A : Type) (B : Type), IsEquiv (equiv_path (A : U0) (B : U0)))
+         -> forall (A : Type) (B : Type),  @paths U1 A B -> @paths U0 A B).
+Defined.
+
+Definition lift_id : lift_id_type :=
+  fun A B p => match p in @paths _ _ B return @paths Type (A : Type) (B : Type) with
+                 | idpath => idpath
+               end.
+
+Definition lower_id : lower_id_type.
+Proof.
+  intros ua A B p.
+  specialize (ua A B).
+  apply (@equiv_inv _ _ (equiv_path A B) _).
+  simpl.
+  pose (f := transport idmap p : A -> B).
+  pose (g := transport idmap p^ : B -> A).
+  refine (@equiv_adjointify
+            _ _
+            f g
+            _ _);
+    subst f g; unfold transport, inverse;
+    clear ua;
+    [ intro x
+    | exact match p as p in (_ = B) return
+                  (forall x : (A : Type),
+                     @paths (* Top.904 *)
+                       A
+                       match
+                         match
+                           p in (paths _ a)
+                           return (@paths (* Top.906 *) Type (* Top.900 *) a A)
+                         with
+                           | idpath => @idpath (* Top.906 *) Type (* Top.900 *) A
+                         end in (paths _ a) return a
+                       with
+                         | idpath => match p in (paths _ a) return a with
+                                       | idpath => x
+                                     end
+                       end x)
+            with
+              | idpath => fun _ => idpath
+            end ].
+
+  - pose proof (match p as p in (_ = B) return
+                      (forall x : (B : Type),
+                         match p in (_ = a) return (a : Type) with
+                           | idpath =>
+                             match
+                               match p in (_ = a) return (@paths Type (a : Type) (A : Type)) with
+                                 | idpath => idpath
+                               end in (_ = a) return (a : Type)
+                             with
+                               | idpath => x
+                             end
+                         end = x)
+                with
+                  | idpath => fun _ => idpath
+                end x) as p'.
+    admit.
+Defined.
+(* Error: Illegal application:
+The term "paths (* Top.96 *)" of type
+ "forall A : Type (* Top.96 *), A -> A -> Type (* Top.96 *)"
+cannot be applied to the terms
+ "Type (* Top.100 *)" : "Type (* Top.100+1 *)"
+ "a" : "Type (* Top.60 *)"
+ "A" : "Type (* Top.57 *)"
+The 2nd term has type "Type (* Top.60 *)" which should be coercible to
+ "Type (* Top.100 *)".
+ *)
diff --git a/test-suite/bugs/closed/HoTT_coq_091.v b/test-suite/bugs/closed/HoTT_coq_091.v
new file mode 100644
index 00000000..1e4497e7
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_091.v
@@ -0,0 +1,191 @@
+Set Implicit Arguments.
+
+Set Printing Universes.
+
+Set Asymmetric Patterns.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Arguments paths_ind [A] a P f y p.
+Arguments paths_rec [A] a P f y p.
+Arguments paths_rect [A] a P f y p.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+Arguments ap {A B} f {x y} p : simpl nomatch.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+(** A typeclass that includes the data making [f] into an adjoint equivalence. *)
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : Sect equiv_inv f;
+  eissect : Sect f equiv_inv;
+  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Arguments eisretr {A B} f {_} _.
+Arguments eissect {A B} f {_} _.
+Arguments eisadj {A B} f {_} _.
+
+
+Inductive type_eq (A : Type) : Type -> Type :=
+| type_eq_refl : type_eq A A
+| type_eq_impossible : False -> forall B : Type, type_eq A B.
+
+Definition type_eq_sym {A B} (p : type_eq A B) : type_eq B A
+  := match p in (type_eq _ B) return (type_eq B A) with
+       | type_eq_refl => type_eq_refl _
+       | type_eq_impossible f B => type_eq_impossible _ f A
+     end.
+
+Definition type_eq_sym_type_eq_sym {A B} (p : type_eq A B) : type_eq_sym (type_eq_sym p) = p
+  := match p as p return type_eq_sym (type_eq_sym p) = p with
+       | type_eq_refl => idpath
+       | type_eq_impossible f _ => idpath
+     end.
+
+Module Type LiftT.
+  Section local.
+    Let type_cast_up_type : Type.
+    Proof.
+      let U0 := constr:(Type) in
+      let U1 := constr:(Type) in
+      let unif := constr:(U0 : U1) in
+      exact (forall T : U0, { T' : U1 & type_eq T' T }).
+    Defined.
+
+    Axiom type_cast_up : type_cast_up_type.
+  End local.
+
+  Definition Lift (T : Type) := projT1 (type_cast_up T).
+  Definition lift {T} : T -> Lift T
+    := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with
+         | type_eq_refl => fun x => x
+         | type_eq_impossible bad _ => match bad with end
+       end.
+  Section equiv.
+    Definition lower' {T} : Lift T -> T
+      := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with
+           | type_eq_refl => fun x => x
+           | type_eq_impossible bad _ => match bad with end
+         end.
+    Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x.
+    Proof.
+      unfold lower', lift.
+      destruct (projT2 (type_cast_up T)) as [|[]].
+      reflexivity.
+    Defined.
+    Definition lower_lift {T} (x : T) : lower' (lift x) = x.
+    Proof.
+      unfold lower', lift, Lift in *.
+      destruct (type_cast_up T) as [T' p]; simpl.
+      let y := match goal with |- ?y => constr:(y) end in
+      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
+      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
+      generalize (type_eq_sym p); intro p'; clear p.
+      destruct p' as [|[]]; simpl.
+      reflexivity.
+    Defined.
+
+    Global Instance isequiv_lift A : IsEquiv (@lift A).
+    Proof.
+      refine (@BuildIsEquiv
+                _ _
+                lift lower'
+                lift_lower
+                lower_lift
+                _).
+      compute.
+      intro x.
+      destruct (type_cast_up A) as [T' p].
+      let y := match goal with |- ?y => constr:(y) end in
+      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
+      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
+      generalize (type_eq_sym p); intro p'; clear p.
+      destruct p' as [|[]]; simpl.
+      reflexivity.
+    Defined.
+  End equiv.
+  Definition lower {A} := (@equiv_inv _ _ (@lift A) _).
+End LiftT.
+
+Module Lift : LiftT.
+  Section local.
+    Let type_cast_up_type : Type.
+    Proof.
+      let U0 := constr:(Type) in
+      let U1 := constr:(Type) in
+      let unif := constr:(U0 : U1) in
+      exact (forall T : U0, { T' : U1 & type_eq T' T }).
+    Defined.
+
+    Definition type_cast_up : type_cast_up_type
+      := fun T => existT (fun T' => type_eq T' T) T (type_eq_refl _).
+  End local.
+
+  Definition Lift (T : Type) := projT1 (type_cast_up T).
+  Definition lift {T} : T -> Lift T
+    := match projT2 (type_cast_up T) in (type_eq _ T') return T' -> Lift T with
+         | type_eq_refl => fun x => x
+         | type_eq_impossible bad _ => match bad with end
+       end.
+  Section equiv.
+    Definition lower' {T} : Lift T -> T
+      := match projT2 (type_cast_up T) in (type_eq _ T') return Lift T -> T' with
+           | type_eq_refl => fun x => x
+           | type_eq_impossible bad _ => match bad with end
+         end.
+    Definition lift_lower {T} (x : Lift T) : lift (lower' x) = x.
+    Proof.
+      unfold lower', lift.
+      destruct (projT2 (type_cast_up T)) as [|[]].
+      reflexivity.
+    Defined.
+    Definition lower_lift {T} (x : T) : lower' (lift x) = x.
+    Proof.
+      unfold lower', lift, Lift in *.
+      destruct (type_cast_up T) as [T' p]; simpl.
+      let y := match goal with |- ?y => constr:(y) end in
+      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
+      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
+      generalize (type_eq_sym p); intro p'; clear p.
+      destruct p' as [|[]]; simpl.
+      reflexivity.
+    Defined.
+
+
+    Global Instance isequiv_lift A : IsEquiv (@lift A).
+    Proof.
+      refine (@BuildIsEquiv
+                _ _
+                lift lower'
+                lift_lower
+                lower_lift
+                _).
+      compute.
+      intro x.
+      destruct (type_cast_up A) as [T' p].
+      let y := match goal with |- ?y => constr:(y) end in
+      let P := match (eval pattern p in y) with ?f p => constr:(f) end in
+      apply (@transport _ P _ _ (type_eq_sym_type_eq_sym p)); simpl in *.
+      generalize (type_eq_sym p); intro p'; clear p.
+      destruct p' as [|[]]; simpl.
+      reflexivity.
+    Defined.
+  End equiv.
+  Definition lower {A} := (@equiv_inv _ _ (@lift A) _).
+End Lift.
+(* Toplevel input, characters 15-24:
+Anomaly: Invalid argument: enforce_eq_instances called with instances of different lengths.
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v
new file mode 100644
index 00000000..38943ab3
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_093.v
@@ -0,0 +1,27 @@
+(** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *)
+Set Printing All.
+Set Printing Implicit.
+Set Printing Universes.
+Set Universe Polymorphism.
+
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+
+Notation "x = y" := (@paths _ x y) : type_scope.
+
+Section lift.
+  Let lift_type : Type.
+  Proof.
+    let U0 := constr:(Type) in
+    let U1 := constr:(Type) in
+    let unif := constr:(U0 : U1) in
+    exact (U0 -> U1).
+  Defined.
+
+  Definition Lift (A : Type@{i}) : Type@{j} := A.
+End lift.
+
+Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y.
+intros A x y p.
+compute in *. destruct p. exact idpath.
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_094.v b/test-suite/bugs/closed/HoTT_coq_094.v
new file mode 100644
index 00000000..13e0605d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_094.v
@@ -0,0 +1,9 @@
+Record PreCategory :=  Build_PreCategory' { object :> Type }.
+Class Foo (X : Type) := {}.
+Class Bar := {}.
+Definition functor_category `{Bar} (C D : PreCategory)  `{Foo (object D)} : PreCategory.
+Admitted.
+Fail Definition functor_object_of `{Bar} (C1 C2 D : PreCategory) `{Foo (object D)}
+: functor_category C1 (functor_category C2 D) -> True.
+(** Anomaly: File "toplevel/himsg.ml", line ..., characters ...: Assertion failed.
+Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_097.v b/test-suite/bugs/closed/HoTT_coq_097.v
new file mode 100644
index 00000000..38e8007b
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_097.v
@@ -0,0 +1,5 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+Set Universe Polymorphism.
+Set Printing Universes.
+Inductive Empty : Set := .
+(* Error: Universe inconsistency. Cannot enforce Prop <= Set). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_098.v b/test-suite/bugs/closed/HoTT_coq_098.v
new file mode 100644
index 00000000..fc99daab
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_098.v
@@ -0,0 +1,63 @@
+Set Implicit Arguments.
+Generalizable All Variables.
+
+Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' {
+  Object :> _ := obj;
+  Morphism' : obj -> obj -> Type;
+
+  Identity' : forall o, Morphism' o o;
+  Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d'
+}.
+
+Polymorphic Definition TypeCat : @SpecializedCategory Type
+  := (@Build_SpecializedCategory' Type
+                                  (fun s d => s -> d)
+                                  (fun _ => (fun x => x))
+                                  (fun _ _ _ f g => (fun x => f (g x)))).
+
+Inductive GraphIndex := GraphIndexSource | GraphIndexTarget.
+Polymorphic Definition GraphIndexingCategory : @SpecializedCategory GraphIndex.
+Admitted.
+
+Module success.
+  Section SpecializedFunctor.
+    Set Universe Polymorphism.
+    Context `(C : @SpecializedCategory objC).
+    Context `(D : @SpecializedCategory objD).
+    Unset Universe Polymorphism.
+
+    Polymorphic Record SpecializedFunctor
+      := {
+          ObjectOf' : objC -> objD;
+          MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d)
+        }.
+  End SpecializedFunctor.
+
+  Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
+  Admitted.
+End success.
+
+Module success2.
+  Section SpecializedFunctor.
+    Polymorphic Context `(C : @SpecializedCategory objC).
+    Polymorphic Context `(D : @SpecializedCategory objD).
+
+    Polymorphic Record SpecializedFunctor
+      := {
+          ObjectOf' : objC -> objD;
+          MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d)
+        }.
+  End SpecializedFunctor.
+
+  Set Printing Universes.
+  Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
+  (* Toplevel input, characters 73-94:
+Error:
+The term "GraphIndexingCategory (* Top.563 *)" has type
+ "SpecializedCategory (* Top.563 Set *) GraphIndex"
+while it is expected to have type
+ "SpecializedCategory (* Top.550 Top.551 *) ?7"
+(Universe inconsistency: Cannot enforce Set = Top.551)). *)
+  admit.
+  Defined.
+End success2.
diff --git a/test-suite/bugs/closed/HoTT_coq_099.v b/test-suite/bugs/closed/HoTT_coq_099.v
new file mode 100644
index 00000000..9b6ace82
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_099.v
@@ -0,0 +1,61 @@
+(* File reduced by coq-bug-finder from 138 lines to 78 lines. *)
+Set Implicit Arguments.
+Generalizable All Variables.
+Set Universe Polymorphism.
+Delimit Scope object_scope with object.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Record Category (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type;
+
+    Identity : forall x, Morphism x x;
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+  }.
+
+Arguments Identity {obj%type} [!C%category] x%object : rename.
+Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+Bind Scope category_scope with Category.
+
+Record Functor `(C : @Category objC) `(D : @Category objD)
+  := { ObjectOf :> objC -> objD;
+       MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d) }.
+
+Record NaturalTransformation `(C : @Category objC) `(D : @Category objD) (F G : Functor C D)
+  := { ComponentsOf :> forall c, D.(Morphism) (F c) (G c) }.
+
+Definition ProductCategory `(C : @Category objC) `(D : @Category objD)
+: @Category (objC * objD)%type
+  := @Build_Category _
+                     (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
+                     (fun o => (Identity (fst o), Identity (snd o)))
+                     (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))).
+
+Infix "*" := ProductCategory : category_scope.
+
+Record IsomorphismOf `{C : @Category objC} {s d} (m : C.(Morphism) s d) :=
+  { IsomorphismOf_Morphism :> C.(Morphism) s d := m;
+    Inverse : C.(Morphism) d s }.
+
+Record NaturalIsomorphism `(C : @Category objC) `(D : @Category objD) (F G : Functor C D)
+  := { NaturalIsomorphism_Transformation :> NaturalTransformation F G;
+       NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x) }.
+
+Section PreMonoidalCategory.
+  Context `(C : @Category objC).
+  Definition TriMonoidalProductL : Functor (C * C * C) C.
+    admit.
+  Defined.
+  Definition TriMonoidalProductR : Functor (C * C * C) C.
+    admit.
+  Defined. (** Replacing [admit. Defined.] with [Admitted.] satisfies the constraints *)
+  Variable Associator : NaturalIsomorphism TriMonoidalProductL TriMonoidalProductR.
+  (* Toplevel input, characters 15-96:
+Error: Unsatisfied constraints:
+Coq.Init.Datatypes.28 <= Coq.Init.Datatypes.29
+Top.168 <= Coq.Init.Datatypes.29
+Top.168 <= Coq.Init.Datatypes.28
+Top.169 <= Coq.Init.Datatypes.29
+Top.169 <= Coq.Init.Datatypes.28
+ (maybe a bugged tactic). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_100.v b/test-suite/bugs/closed/HoTT_coq_100.v
new file mode 100644
index 00000000..c39b7093
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_100.v
@@ -0,0 +1,151 @@
+(* File reduced by coq-bug-finder from 335 lines to 115 lines. *)
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Generalizable All Variables.
+Record Category (obj : Type) :=
+  Build_Category {
+      Object :> _ := obj;
+      Morphism : obj -> obj -> Type;
+
+      Identity : forall x, Morphism x x;
+      Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+    }.
+
+Arguments Identity {obj%type} [!C] x : rename.
+
+Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename.
+Record > Category' :=
+  {
+    LSObject : Type;
+
+    LSUnderlyingCategory :> @Category LSObject
+  }.
+
+Section Functor.
+
+  Context `(C : @Category objC).
+  Context `(D : @Category objD).
+  Record Functor :=
+    {
+      ObjectOf :> objC -> objD;
+      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+    }.
+
+End Functor.
+Section FunctorComposition.
+
+  Context `(C : @Category objC).
+  Context `(D : @Category objD).
+  Context `(E : @Category objE).
+  Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E.
+
+  Admitted.
+End FunctorComposition.
+Section IdentityFunctor.
+
+  Context `(C : @Category objC).
+  Definition IdentityFunctor : Functor C C.
+
+    admit.
+  Defined.
+End IdentityFunctor.
+Section ProductCategory.
+
+  Context `(C : @Category objC).
+  Context `(D : @Category objD).
+  Definition ProductCategory : @Category (objC * objD)%type.
+
+    refine (@Build_Category _
+                            (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
+                            (fun o => (Identity (fst o), Identity (snd o)))
+                            (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))).
+  Defined.
+End ProductCategory.
+Parameter TerminalCategory : Category unit.
+
+Section ComputableCategory.
+
+  Variable I : Type.
+  Variable Index2Object : I -> Type.
+  Variable Index2Cat : forall i : I, @Category (@Index2Object i).
+  Local Coercion Index2Cat : I >-> Category.
+
+  Definition ComputableCategory : @Category I.
+
+    refine (@Build_Category _
+                            (fun C D : I => Functor C D)
+                            (fun o : I => IdentityFunctor o)
+                            (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))).
+  Defined.
+End ComputableCategory.
+Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory.
+Section CommaCategory.
+
+  Context `(A : @Category objA).
+  Context `(B : @Category objB).
+  Context `(C : @Category objC).
+  Variable S : Functor A C.
+  Variable T : Functor B C.
+  Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }.
+
+End CommaCategory.
+Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C
+  := {| ObjectOf := (fun _ => a);
+        MorphismOf := (fun _ _ _ => Identity a)
+     |}.
+
+Definition SliceCategoryOver
+: forall (objC : Type) (C : Category objC) (a : C),
+    Category
+      (CommaCategory_Object (IdentityFunctor C)
+                            (SliceCategory_Functor C a)).
+
+  admit.
+Defined.
+Section CommaCategoryProjectionFunctor.
+
+  Context `(A : Category objA).
+  Context `(B : Category objB).
+  Let X : LocallySmallCat.
+
+  Proof.
+    hnf.
+    pose (@SliceCategoryOver _ LocallySmallCat).
+    exact (ProductCategory A B).
+    Set Printing Universes.
+  Defined.
+(* Error: Illegal application:
+The term
+ "CommaCategory_Object (* Top.306 Top.307 Top.305 Top.300 Top.305 Top.306 *)"
+of type
+ "forall (objA : Type (* Top.305 *))
+    (A : Category (* Top.306 Top.305 *) objA) (objB : Type (* Top.307 *))
+    (B : Category (* Top.300 Top.307 *) objB) (objC : Type (* Top.305 *))
+    (C : Category (* Top.306 Top.305 *) objC),
+  Functor (* Top.306 Top.305 Top.305 Top.306 *) A C ->
+  Functor (* Top.300 Top.307 Top.305 Top.306 *) B C ->
+  Type (* max(Top.307, Top.305, Top.306) *)"
+cannot be applied to the terms
+ "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)"
+ "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)"
+   : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)"
+ "unit" : "Set"
+ "TerminalCategory (* Top.300 *)" : "Category (* Top.300 Set *) unit"
+ "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)"
+ "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)"
+   : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)"
+ "IdentityFunctor (* Top.299 Top.302 Top.301 Top.305 Top.306 *)
+    LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314
+    Top.306 Top.316 Top.305 *)"
+   : "Functor (* Top.306 Top.305 Top.305 Top.306 *) LocallySmallCat
+        (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316
+        Top.305 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313
+        Top.314 Top.306 Top.316 Top.305 *)"
+ "SliceCategory_Functor (* Top.305 Top.306 Top.307 Top.300 *) LocallySmallCat
+    (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316
+    Top.305 *) a"
+   : "Functor (* Top.300 Top.307 Top.305 Top.306 *) TerminalCategory
+        (* Top.300 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312
+        Top.313 Top.314 Top.306 Top.316 Top.305 *)"
+The 4th term has type "Category (* Top.300 Set *) unit"
+which should be coercible to "Category (* Top.300 Top.307 *) unit". *)
diff --git a/test-suite/bugs/closed/HoTT_coq_101.v b/test-suite/bugs/closed/HoTT_coq_101.v
new file mode 100644
index 00000000..9c89a6ab
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_101.v
@@ -0,0 +1,77 @@
+Set Universe Polymorphism.
+Set Implicit Arguments.
+Generalizable All Variables.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type
+  }.
+
+
+Record > Category :=
+  {
+    CObject : Type;
+
+    UnderlyingCategory :> @SpecializedCategory CObject
+  }.
+
+Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) :=
+  {
+    ObjectOf :> objC -> objD;
+    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
+  }.
+
+(* Replacing this with [Definition Functor (C D : Category) :=
+SpecializedFunctor C D.] gets rid of the universe inconsistency. *)
+Section Functor.
+  Variable C D : Category.
+
+  Definition Functor := SpecializedFunctor C D.
+End Functor.
+
+Record SpecializedNaturalTransformation `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) (F G : SpecializedFunctor C D) :=
+  {
+    ComponentsOf :> forall c, D.(Morphism) (F c) (G c)
+  }.
+
+Definition FunctorProduct' `(F : Functor C D) : SpecializedFunctor C D.
+admit.
+Defined.
+
+Definition TypeCat : @SpecializedCategory Type.
+  admit.
+Defined.
+
+
+Definition CovariantHomFunctor `(C : @SpecializedCategory objC) : SpecializedFunctor C TypeCat.
+  refine (Build_SpecializedFunctor C TypeCat
+                                   (fun X : C => C.(Morphism) X X)
+                                   _
+         ); admit.
+Defined.
+
+Definition FunctorCategory `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) : @SpecializedCategory (SpecializedFunctor C D).
+  refine (@Build_SpecializedCategory _
+                                     (SpecializedNaturalTransformation (C := C) (D := D))).
+Defined.
+
+Definition Yoneda `(C : @SpecializedCategory objC) : SpecializedFunctor C (FunctorCategory C TypeCat).
+  match goal with
+    | [ |- SpecializedFunctor ?C0 ?D0 ] =>
+      refine (Build_SpecializedFunctor C0 D0
+                                       (fun c => CovariantHomFunctor C)
+                                       _
+             )
+  end;
+  admit.
+Defined.
+
+Section FullyFaithful.
+  Context `(C : @SpecializedCategory objC).
+  Let TypeCatC := FunctorCategory C TypeCat.
+  Let YC := (Yoneda C).
+  Set Printing Universes.
+  Check @FunctorProduct' C TypeCatC YC. (* Toplevel input, characters 0-37:
+Error: Universe inconsistency. Cannot enforce Top.187 = Top.186 because
+Top.186 <= Top.189 < Top.191 <= Top.187). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_102.v b/test-suite/bugs/closed/HoTT_coq_102.v
new file mode 100644
index 00000000..71becfd2
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_102.v
@@ -0,0 +1,29 @@
+(* File reduced by coq-bug-finder from 64 lines to 30 lines. *)
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Generalizable All Variables.
+Record SpecializedCategory (obj : Type) := { Object :> _ := obj }.
+
+Record > Category :=
+  { CObject : Type;
+    UnderlyingCategory :> @SpecializedCategory CObject }.
+
+Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) :=
+  { ObjectOf :> objC -> objD }.
+
+Definition Functor (C D : Category) := SpecializedFunctor C D.
+
+Parameter TerminalCategory : SpecializedCategory unit.
+
+Definition focus A (_ : A) := True.
+
+Definition CommaCategory_Object (A : Category) (S : Functor TerminalCategory A) : Type.
+  assert (Hf : focus ((S tt) = (S tt))) by constructor.
+  let C1 := constr:(CObject) in
+  let C2 := constr:(fun C => @Object (CObject C) C) in
+  let check := constr:(eq_refl : C1 = C2) in
+  unify C1 C2.
+  progress change CObject with (fun C => @Object (CObject C) C) in *.
+  (* not convertible *)
+  admit.
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_103.v b/test-suite/bugs/closed/HoTT_coq_103.v
new file mode 100644
index 00000000..7ecf7671
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_103.v
@@ -0,0 +1,4 @@
+Fail Check (nat : Type) : Set.
+(* Error:
+The term "nat:Type" has type "Type" while it is expected to have type
+"Set" (Universe inconsistency). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_104.v b/test-suite/bugs/closed/HoTT_coq_104.v
new file mode 100644
index 00000000..5bb7fa8c
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_104.v
@@ -0,0 +1,13 @@
+Set Implicit Arguments.
+
+Require Import Logic.
+
+Global Set Universe Polymorphism.
+Global Set Asymmetric Patterns.
+Local Set Record Elimination Schemes.
+Local Set Primitive Projections.
+
+Record prod (A B : Type) : Type :=
+  pair { fst : A; snd : B }.
+
+Check fun x : prod Set Set => eq_refl : x = pair (fst x) (snd x).
diff --git a/test-suite/bugs/closed/HoTT_coq_105.v b/test-suite/bugs/closed/HoTT_coq_105.v
new file mode 100644
index 00000000..86001d26
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_105.v
@@ -0,0 +1,32 @@
+Set Primitive Projections.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+Set Asymmetric Patterns.
+
+Inductive sum A B := inl : A -> sum A B | inr : B -> sum A B.
+Inductive Empty :=.
+
+Record category :=
+  { ob :> Type;
+    hom : ob -> ob -> Type
+  }.
+Set Printing All.
+Definition sum_category (C D : category) : category :=
+  {|
+    ob := sum (ob C) (ob D);
+    hom x y := match x, y with
+                 | inl x, inl y => @hom _ x y (* Toplevel input, characters 177-178:
+Error:
+In environment
+C : category
+D : category
+x : sum (ob C) (ob D)
+y : sum (ob C) (ob D)
+x0 : ob C
+y0 : ob C
+The term "x0" has type "ob C" while it is expected to have type
+"ob ?6" (unable to find a well-typed instantiation for
+"?6": cannot unify"Type" and "category"). *)
+                 | inr x, inr y => @hom _ x y
+                 | _, _ => Empty
+               end |}.
diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v
new file mode 100644
index 00000000..c3a83627
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_107.v
@@ -0,0 +1,106 @@
+(* -*- mode: coq; coq-prog-args: ("-nois" "-emacs") -*- *)
+(* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *)
+(** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *)
+Require Import Coq.Init.Logic.
+Global Set Universe Polymorphism.
+Global Set Asymmetric Patterns.
+Set Implicit Arguments.
+
+Inductive sigT (A:Type) (P:A -> Type) : Type :=
+  existT : forall x:A, P x -> sigT P.
+
+Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
+
+Generalizable All Variables.
+Definition admit {T} : T.
+Admitted.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+Class Contr_internal (A : Type) :=
+  BuildContr {
+      center : A ;
+      contr : (forall y : A, center = y)
+    }.
+
+Arguments center A {_}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation Contr := (IsTrunc minus_two).
+
+Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+
+Definition path_contr `{Contr A} (x y : A) : x = y
+  := admit.
+
+Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'}
+           (p : x = x') (q : transport _ p y = y')
+: existT _ x y = existT _ x' y'
+  := admit.
+Instance trunc_sigma `{P : A -> Type}
+         `{IsTrunc n A} `{forall a, IsTrunc n (P a)}
+: IsTrunc n (sigT P) | 100.
+
+Proof.
+  generalize dependent A.
+  induction n; [ | admit ]; simpl; intros A P ac Pc.
+  (exists (existT _ (center A) (center (P (center A))))).
+  intros [a ?].
+  refine (path_sigma' P (contr a) (path_contr _ _)).
+Defined.
+Inductive Bool : Set := true | false.
+Definition trunc_sum' n A B `{IsTrunc n Bool, IsTrunc n A, IsTrunc n B}
+: (IsTrunc n { b : Bool & if b then A else B }).
+Proof.
+  Set Printing All.
+  Set Printing Universes.
+  refine (@trunc_sigma Bool (fun b => if b then A else B) n _ _).
+  (* Toplevel input, characters 23-76:
+Error:
+In environment
+n : trunc_index
+A : Type (* Top.193 *)
+B : Type (* Top.194 *)
+H : IsTrunc (* Set *) n Bool
+H0 : IsTrunc (* Top.193 *) n A
+H1 : IsTrunc (* Top.194 *) n B
+The term
+ "@trunc_sigma (* Top.198 Top.199 Top.200 Top.201 *) Bool
+    (fun b : Bool =>
+     match b return Type (* Top.199 *) with
+     | true => A
+     | false => B
+     end) n ?49 ?50" has type
+ "IsTrunc (* Top.200 *) n
+    (@sig (* Top.199 Top.199 *) Bool
+       (fun b : Bool =>
+        match b return Type (* Top.199 *) with
+        | true => A
+        | false => B
+        end))" while it is expected to have type
+ "IsTrunc (* Top.195 *) n
+    (@sig (* Set Top.197 *) Bool
+       (fun b : Bool =>
+        match b return Type (* Top.197 *) with
+        | true => A
+        | false => B
+        end))" (Universe inconsistency: Cannot enforce Top.197 = Set)).
+ *)
+  admit.
+Defined.
diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v
new file mode 100644
index 00000000..cc304802
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_108.v
@@ -0,0 +1,127 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *)
+(* NOTE: This bug is only triggered with -load-vernac-source / in interactive mode. *)
+(* File reduced by coq-bug-finder from 139 lines to 124 lines. *)
+Set Universe Polymorphism.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Generalizable All Variables.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+: forall x, f x = g x
+  := fun x => match h with idpath => idpath end.
+
+Definition ap11 {A B} {f g:A->B} (h:f=g) {x y:A} (p:x=y) : f x = g y.
+  admit.
+Defined.
+Class IsEquiv {A B : Type} (f : A -> B) := {}.
+Class Contr_internal (A : Type) := BuildContr {
+                                       center : A ;
+                                       contr : (forall y : A, center = y)
+                                     }.
+
+Arguments center A {_}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint nat_to_trunc_index (n : nat) : trunc_index
+  := match n with
+       | 0 => trunc_S (trunc_S minus_two)
+       | S n' => trunc_S (nat_to_trunc_index n')
+     end.
+
+Coercion nat_to_trunc_index : nat >-> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+
+Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A)
+: IsTrunc n (x = y)
+  := H x y.
+
+Notation Contr := (IsTrunc minus_two).
+
+Notation IsHSet := (IsTrunc 0).
+
+Class Funext :=
+  { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+Global Instance contr_forall `{Funext} `{P : A -> Type} `{forall a, Contr (P a)}
+: Contr (forall a, P a) | 100.
+admit.
+Defined.
+Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances.
+Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)}
+: IsTrunc n (forall a, P a) | 100.
+Proof.
+  generalize dependent P.
+  induction n as [ | n' IH]; [ | admit ]; simpl; intros P ?.
+                                                        exact _.
+Defined.
+Set Implicit Arguments.
+
+Record PreCategory :=
+  { object :> Type;
+    morphism : object -> object -> Type;
+    identity : forall x, morphism x x;
+    compose : forall s d d', morphism d d' -> morphism s d -> morphism s d';
+    trunc_morphism : forall s d, IsHSet (morphism s d) }.
+
+Existing Instance trunc_morphism.
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+Local Open Scope morphism_scope.
+
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d);
+    composition_of : forall s d d'
+                            (m1 : morphism C s d) (m2: morphism C d d'),
+                       morphism_of _ _ (m2 o m1)
+                       = (morphism_of _ _ m2) o (morphism_of _ _ m1);
+    identity_of : forall x, morphism_of _ _ (@identity _ x)
+                            = @identity _ (object_of x) }.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+Section path_functor.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Local Notation path_functor'_T F G
+    := { HO : object_of F = object_of G
+       | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d))
+                   HO
+                   (morphism_of F)
+         = morphism_of G }
+         (only parsing).
+  Definition path_functor'_sig (F G : Functor C D) : path_functor'_T F G -> F = G.
+  Proof.
+    intros [H' H''].
+    destruct F, G; simpl in *.
+    induction H'. (* while destruct H' works *) destruct H''.
+    apply ap11; [ apply ap | ];
+    apply center; abstract exact _.
+    Set Printing Universes.
+    (* Fail Defined.*)
+  (* The command has indeed failed with message:
+=> Error: path_functor'_sig_subproof already exists. *)
+  Defined.
+(* Anomaly: Backtrack.backto 55: a state with no vcs_backup. Please report. *)
+End path_functor.
diff --git a/test-suite/bugs/closed/HoTT_coq_110.v b/test-suite/bugs/closed/HoTT_coq_110.v
new file mode 100644
index 00000000..5ec40dbc
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_110.v
@@ -0,0 +1,23 @@
+Module X.
+  Inductive paths A (x : A) : A -> Type := idpath : paths A x x.
+  Notation "x = y" := (@paths _ x y) : type_scope.
+
+  Axioms A B : Type.
+  Axiom P : A = B.
+  Definition foo : A = B.
+    abstract (rewrite <- P; reflexivity).
+  (* Error: internal_paths_rew already exists. *)
+  Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *)
+End X.
+
+Module Y.
+  Inductive paths A (x : A) : A -> Type := idpath : paths A x x.
+  Notation "x = y" := (@paths _ x y) : type_scope.
+
+  Axioms A B : Type.
+  Axiom P : A = B.
+  Definition foo : (A = B) * (A = B).
+    split; abstract (rewrite <- P; reflexivity).
+  (* Error: internal_paths_rew already exists. *)
+  Defined. (* Anomaly: Uncaught exception Not_found(_). Please report. *)
+End Y.
diff --git a/test-suite/bugs/closed/HoTT_coq_111.v b/test-suite/bugs/closed/HoTT_coq_111.v
new file mode 100644
index 00000000..3b43f31d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_111.v
@@ -0,0 +1,24 @@
+
+Module X.
+  (*Set Universe Polymorphism.*)
+  Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x.
+  Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope.
+
+  Axioms A B : Type.
+  Axiom P : A = B.
+  Definition foo : A = B.
+    abstract (rewrite <- P; reflexivity).
+  Defined.
+End X.
+
+Module Y.
+  (*Set Universe Polymorphism.*)
+  Inductive paths A (x : A) : forall _ : A, Type := idpath : paths A x x.
+  Notation "x = y" := (@paths _ x y) (at level 70, no associativity) : type_scope.
+
+  Axioms A B : Type.
+  Axiom P : A = B.
+  Definition foo : (A = B) * (A = B).
+    split; abstract (rewrite <- P; reflexivity).
+  Defined.
+End Y.
diff --git a/test-suite/bugs/closed/HoTT_coq_112.v b/test-suite/bugs/closed/HoTT_coq_112.v
new file mode 100644
index 00000000..150f2ecc
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_112.v
@@ -0,0 +1,75 @@
+(* File reduced by coq-bug-finder from 4464 lines to 4137 lines, then from 3683 lines to 118 lines, then from 124 lines to 75 lines. *)
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y :=
+  match p with idpath => u end.
+
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
+  := match p with idpath => idpath end.
+
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+  : forall x, f x = g x
+  := fun x => match h with idpath => idpath end.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : forall x, f (equiv_inv x) = x
+}.
+
+Arguments eisretr {A B} f {_} _.
+
+Record Equiv A B := BuildEquiv {
+  equiv_fun :> A -> B ;
+  equiv_isequiv :> IsEquiv equiv_fun
+}.
+
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+Local Open Scope equiv_scope.
+
+Instance isequiv_path {A B : Type} (p : A = B)
+  : IsEquiv (transport (fun X:Type => X) p) | 0
+  := admit.
+Definition equiv_path (A B : Type) (p : A = B) : A <~> B
+  := BuildEquiv _ _ (transport (fun X:Type => X) p) _.
+
+Class Univalence := {
+  isequiv_equiv_path :> forall (A B : Type), IsEquiv (equiv_path A B)
+}.
+
+Section Univalence.
+  Context `{Univalence}.
+
+  Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B
+    := (equiv_path A B)^-1 f.
+
+  Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B)
+    := path_universe_uncurried (BuildEquiv _ _ f feq).
+
+  Set Printing Universes.
+  Definition transport_path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
+  : transport (fun X:Type => X) (path_universe f) z = f z
+    := apD10 (ap (equiv_fun A B) (eisretr (equiv_path A B) (BuildEquiv _ _ f feq))) z.
+  (* Toplevel input, characters 0-231:
+Error: Illegal application:
+The term "isequiv_equiv_path (* Top.1003 Top.1003 Top.1001 Top.997 *)"
+of type
+ "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *) ->
+  forall (A : Type (* Top.1003 *)) (B : Type (* Top.997 *)),
+  IsEquiv (* Top.1003 Top.1001 *)
+    (equiv_path (* Top.997 Top.1003 Top.1001 Top.1003 *) A B)"
+cannot be applied to the terms
+ "H" : "Univalence (* Top.934 Top.935 Top.936 Top.937 *)"
+ "A" : "Type (* Top.996 *)"
+ "B" : "Type (* Top.997 *)"
+The 1st term has type "Univalence (* Top.934 Top.935 Top.936 Top.937 *)"
+which should be coercible to
+ "Univalence (* Top.1003 Top.1003 Top.1001 Top.997 *)".
+ *)
diff --git a/test-suite/bugs/closed/HoTT_coq_113.v b/test-suite/bugs/closed/HoTT_coq_113.v
new file mode 100644
index 00000000..3ef531bc
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_113.v
@@ -0,0 +1,19 @@
+(* File reduced by coq-bug-finder from original input, then from 3329 lines to 153 lines, then from 118 lines to 49 lines, then from 55 lines to 38 lines, then from 46 lines to 16 lines *)
+
+Generalizable All Variables.
+Set Universe Polymorphism.
+Class Foo (A : Type) := {}.
+Definition Baz := Foo.
+Definition Bar {A B} `{Foo A, Foo B} : True.
+Proof.
+  Set Printing Universes.
+  (* [change] should give fresh universes for each [Foo] *)
+  change Foo with Baz in *.
+  admit.
+Defined.
+Definition foo := @Bar nat.
+Check @foo Set.
+(* Toplevel input, characters 26-29:
+Error:
+The term "Set" has type "Type (* Set+1 *)" while it is expected to have type
+ "Set" (Universe inconsistency: Cannot enforce Set < Set because Set = Set)). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v
new file mode 100644
index 00000000..34112833
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_114.v
@@ -0,0 +1 @@
+Inductive test : $(let U := type of Type in exact U)$ := t.
diff --git a/test-suite/bugs/closed/HoTT_coq_115.v b/test-suite/bugs/closed/HoTT_coq_115.v
new file mode 100644
index 00000000..c1e133ee
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_115.v
@@ -0,0 +1 @@
+Inductive T : let U := Type in U := t. (* Anomaly: not an arity. Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_116.v b/test-suite/bugs/closed/HoTT_coq_116.v
new file mode 100644
index 00000000..d408557d
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_116.v
@@ -0,0 +1,13 @@
+Set Universe Polymorphism.
+Section foo.
+  Let U := Type.
+  Let U' : Type.
+  Proof.
+    let U' := constr:(Type) in
+    let U_le_U' := constr:(fun x : U => (x : U')) in
+    exact U'.
+  Defined.
+  Inductive t : U' := .
+End foo.
+(* Toplevel input, characters 15-23:
+Error: No such section variable or assumption: U'. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_117.v b/test-suite/bugs/closed/HoTT_coq_117.v
new file mode 100644
index 00000000..5fbcfef4
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_117.v
@@ -0,0 +1,25 @@
+(* File reduced by coq-bug-finder from original input, then from 1461 lines to 81 lines, then from 84 lines to 40 lines, then from 50 lines to 24 lines *)
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Class Contr_internal (A : Type) := BuildContr {
+  center : A ;
+  contr : (forall y : A, center = y)
+}.
+Class Funext := {}.
+
+Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) :
+  (forall x, f x = g x) -> f = g.
+
+Admitted.
+
+Inductive Empty : Set := .
+Instance contr_from_Empty {_ : Funext} (A : Type) :
+  Contr_internal (Empty -> A) :=
+  BuildContr _
+             (Empty_rect (fun _ => A))
+             (fun f => path_forall _ f (fun x => Empty_rect _ x)).
+(* Toplevel input, characters 15-220:
+Anomaly: unknown meta ?190. Please report. *)
diff --git a/test-suite/bugs/closed/HoTT_coq_118.v b/test-suite/bugs/closed/HoTT_coq_118.v
new file mode 100644
index 00000000..14ad0e49
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_118.v
@@ -0,0 +1,35 @@
+(* File reduced by coq-bug-finder from original input, then from 5631 lines to 557 lines, then from 526 lines to 181 lines, then from 189 lines to 154 lines, then from 153 lines to 107 lines, then from 97 lines to 56 lines, then from 50 lines to 37 lines *)
+Generalizable All Variables.
+Set Universe Polymorphism.
+Definition admit {T} : T.
+Admitted.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (@paths _ x y) : type_scope.
+Class Contr_internal (A : Type) := BuildContr { center : A }.
+Arguments center A {_}.
+Instance contr_paths_contr `{Contr_internal A} (x y : A) : Contr_internal (x = y) := admit.
+Inductive Unit : Set := tt.
+Instance contr_unit : Contr_internal Unit | 0 := admit.
+Record PreCategory := { morphism : Type }.
+Class IsIsomorphism {C : PreCategory} (m : morphism C) := { left_inverse : m = m }.
+Definition indiscrete_category : PreCategory := @Build_PreCategory Unit.
+Goal forall (X : Type) (_ : forall x y : X, Contr_internal (@paths X x y)) (s : X),
+       @IsIsomorphism indiscrete_category tt -> True.
+Proof.
+  intros X H s [p].
+  simpl in *.
+  assert (idpath = p).
+  clear.
+  assert (H : forall p : tt = tt, idpath = p) by (intro; exact (center _)).
+  clear H.
+  exact (center _).
+  (* Toplevel input, characters 15-32:
+Error:
+Unable to satisfy the following constraints:
+In environment:
+p : tt = tt
+
+?46 : "Contr_internal (idpath = p)"
+ *)
diff --git a/test-suite/bugs/closed/HoTT_coq_121.v b/test-suite/bugs/closed/HoTT_coq_121.v
new file mode 100644
index 00000000..cce288cf
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_121.v
@@ -0,0 +1,18 @@
+(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines, then from 146 lines to 72 lines, then from 82 lines to 70 lines, then from 79 lines to 49 lines, then from 59 lines to 16 lines *)
+
+Set Universe Polymorphism.
+Generalizable All Variables.
+Record hSet := BuildhSet {setT:> Type}.
+Axiom minus1Trunc : Type -> Type.
+Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT  P).
+Definition issurj {X Y} (f:X->Y) := forall y:Y, hexists (fun x => (f x) = y).
+Lemma isepi_issurj {X Y} (f:X->Y): issurj f.
+Proof.
+  intros y.
+  admit.
+Defined. (* Toplevel input, characters 15-23:
+Error: Unsatisfied constraints:
+Top.38 <= Coq.Init.Specif.7
+Top.43 <= Top.38
+Top.43 <= Coq.Init.Specif.8
+ (maybe a bugged tactic). *)
diff --git a/test-suite/bugs/closed/HoTT_coq_122.v b/test-suite/bugs/closed/HoTT_coq_122.v
new file mode 100644
index 00000000..1ba8e5c3
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_122.v
@@ -0,0 +1,25 @@
+(* File reduced by coq-bug-finder from original input, then from 669 lines to 79 lines, then from 89 lines to 44 lines *)
+Set Primitive Projections.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Notation "x = y" := (@paths _ x y) : type_scope.
+
+Set Implicit Arguments.
+
+Record PreCategory :=
+  Build_PreCategory' {
+      object :> Type;
+      morphism : object -> object -> Type;
+
+      identity : forall x, morphism x x;
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+
+      left_identity : forall a b (f : morphism a b), identity b o f = f
+    }.
+
+Hint Rewrite @left_identity. (* stack overflow *)
diff --git a/test-suite/bugs/closed/HoTT_coq_123.v b/test-suite/bugs/closed/HoTT_coq_123.v
new file mode 100644
index 00000000..994dff63
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_123.v
@@ -0,0 +1,171 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") *)
+(* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *)
+Set Universe Polymorphism.
+Set Asymmetric Patterns.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Generalizable All Variables.
+Definition admit {T} : T.
+Admitted.
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (@paths _ x y) : type_scope.
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type
+  := forall x:A, f x = g x.
+Hint Unfold pointwise_paths : typeclass_instances.
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
+: forall x, f x = g x
+  := fun x => match h with idpath => idpath end.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
+
+Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
+Class Contr_internal (A : Type) := {}.
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+
+Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A)
+: IsTrunc n (x = y)
+  := H x y.
+
+Notation IsHSet := (IsTrunc minus_two).
+
+Class Funext :=
+  { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
+
+Local Open Scope equiv_scope.
+
+Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv f^-1 | 10000
+  := BuildIsEquiv B A f^-1 f.
+Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000.
+
+admit.
+
+Defined.
+Definition trunc_equiv `(f : A -> B)
+           `{IsTrunc n A} `{IsEquiv A B f}
+: IsTrunc n B.
+  admit.
+Defined.
+Definition trunc_equiv' `(f : A <~> B) `{IsTrunc n A}
+: IsTrunc n B
+  := admit.
+Set Implicit Arguments.
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory :=
+  Build_PreCategory {
+      object :> Type;
+      morphism : object -> object -> Type;
+
+      identity : forall x, morphism x x;
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+
+      associativity : forall x1 x2 x3 x4
+                             (m1 : morphism x1 x2)
+                             (m2 : morphism x2 x3)
+                             (m3 : morphism x3 x4),
+                        (m3 o m2) o m1 = m3 o (m2 o m1);
+
+      left_identity : forall a b (f : morphism a b), identity b o f = f;
+      right_identity : forall a b (f : morphism a b), f o identity a = f;
+
+      trunc_morphism : forall s d, IsHSet (morphism s d)
+    }.
+Existing Instance trunc_morphism.
+
+Infix "o" := (@compose _ _ _ _) : morphism_scope.
+Delimit Scope functor_scope with functor.
+
+Local Open Scope morphism_scope.
+Record Functor (C D : PreCategory) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d)
+  }.
+
+Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)}
+: IsTrunc n (forall a, P a) | 100.
+Proof.
+    generalize dependent P.
+  induction n as [ | n' IH]; (simpl; intros P ?).
+  - admit.
+  - pose (fun f g => trunc_equiv (@apD10 A P f g) ^-1); admit.
+Defined.
+Instance trunc_sigma `{P : A -> Type}
+         `{IsTrunc n A} `{forall a, IsTrunc n (P a)}
+: IsTrunc n (sigT P) | 100.
+admit.
+Defined.
+Record NaturalTransformation C D (F G : Functor C D) :=
+  Build_NaturalTransformation' {
+      components_of :> forall c, morphism D (F c) (G c)
+    }.
+Section path_natural_transformation.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+  Variables F G : Functor C D.
+  Lemma equiv_sig_natural_transformation
+  : { CO : forall x, morphism D (F x) (G x)
+    & forall s d (m : morphism C s d),
+        CO d o morphism_of F _ _ m = morphism_of G _ _ m o CO s }
+      <~> NaturalTransformation F G.
+
+    admit.
+  Defined.
+  Global Instance trunc_natural_transformation
+  : IsHSet (NaturalTransformation F G).
+  Proof.
+    eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ].
+    typeclasses eauto.
+  Qed.
+  Lemma path_natural_transformation (T U : NaturalTransformation F G)
+  : components_of T == components_of U
+    -> T = U.
+    admit.
+  Defined.
+End path_natural_transformation.
+Ltac path_natural_transformation :=
+  repeat match goal with
+           | _ => intro
+           | _ => apply path_natural_transformation; simpl
+         end.
+
+Section FunctorSectionCategory.
+  Context `{Funext}.
+  Variable C : PreCategory.
+  Variable D : PreCategory.
+
+  Definition category_of_sections : PreCategory.
+  Proof.
+    refine (@Build_PreCategory
+              (Functor D C)
+              (fun F G => NaturalTransformation F G)
+              admit
+              admit
+              _
+              _
+              _
+              _);
+    abstract (path_natural_transformation; admit).
+  Defined. (* Stack overflow *)
diff --git a/test-suite/bugs/closed/HoTT_coq_124.v b/test-suite/bugs/closed/HoTT_coq_124.v
new file mode 100644
index 00000000..e6e90ada
--- /dev/null
+++ b/test-suite/bugs/closed/HoTT_coq_124.v
@@ -0,0 +1,29 @@
+Set Implicit Arguments.
+Set Primitive Projections.
+
+Polymorphic Inductive eqp A (x : A) : A -> Type := eqp_refl : eqp x x.
+Monomorphic Inductive eqm A (x : A) : A -> Type := eqm_refl : eqm x x.
+
+Polymorphic Record prodp (A B : Type) : Type := pairp { fstp : A; sndp : B }.
+Monomorphic Record prodm (A B : Type) : Type := pairm { fstm : A; sndm : B }.
+
+Check eqm_refl _ : eqm (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *)
+Check eqp_refl _ : eqp (fun x : prodm Set Set => pairm (fstm x) (sndm x)) (fun x => x). (* success *)
+Check eqm_refl _ : eqm (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error:
+The term
+ "eqm_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
+has type
+ "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
+    (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
+while it is expected to have type
+ "eqm (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
+    (fun x : prodp Set Set => x)". *)
+Check eqp_refl _ : eqp (fun x : prodp Set Set => pairp (fstp x) (sndp x)) (fun x => x). (* Error:
+The term
+ "eqp_refl (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
+has type
+ "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
+    (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})"
+while it is expected to have type
+ "eqp (fun x : prodp Set Set => {| fstp := fstp x; sndp := sndp x |})
+    (fun x : prodp Set Set => x)". *)
diff --git a/test-suite/bugs/closed/shouldfail/1915.v b/test-suite/bugs/closed/shouldfail/1915.v
deleted file mode 100644
index a96a482c..00000000
--- a/test-suite/bugs/closed/shouldfail/1915.v
+++ /dev/null
@@ -1,6 +0,0 @@
-
-Require Import Setoid.
-
-Goal forall x, impl True (x = 0) -> x = 0 -> False.
-intros x H E.
-rewrite H in E.
\ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldfail/2406.v b/test-suite/bugs/closed/shouldfail/2406.v
deleted file mode 100644
index 112ea2bb..00000000
--- a/test-suite/bugs/closed/shouldfail/2406.v
+++ /dev/null
@@ -1,3 +0,0 @@
-(* Check correct handling of unsupported notations *)
-Notation "'Â’'" := (fun x => x) (at level 20).
-Definition crash_the_rooster f := Â’.
diff --git a/test-suite/bugs/closed/shouldsucceed/1041.v b/test-suite/bugs/closed/shouldsucceed/1041.v
deleted file mode 100644
index a5de82e0..00000000
--- a/test-suite/bugs/closed/shouldsucceed/1041.v
+++ /dev/null
@@ -1,13 +0,0 @@
-Goal Prop.
-
-pose (P:=(fun x y :Prop => y)).
-evar (Q: (forall X Y,P X Y -> Prop)) .
-
-instantiate (1:= fun _ => _ ) in (Value of Q).
-instantiate (1:= fun _ => _ ) in (Value of Q).
-instantiate (1:= fun _ => _ ) in (Value of Q).
-
-instantiate (1:=H) in (Value  of Q).
-
-Admitted.
-
diff --git a/test-suite/bugs/closed/shouldsucceed/1519.v b/test-suite/bugs/closed/shouldsucceed/1519.v
deleted file mode 100644
index 66bab241..00000000
--- a/test-suite/bugs/closed/shouldsucceed/1519.v
+++ /dev/null
@@ -1,14 +0,0 @@
-Section S.
-
-  Variable A:Prop.
-  Variable W:A.
-
-  Remark T: A -> A.
-    intro Z.
-    rename W into Z_.
-    rename Z into W.
-    rename Z_ into Z.
-    exact Z.
-  Qed.
-
-End S.
diff --git a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled b/test-suite/bugs/opened/1338.v-disabled
index f383d534..ab0f9820 100644
--- a/test-suite/bugs/opened/shouldnotfail/1338.v-disabled
+++ b/test-suite/bugs/opened/1338.v-disabled
@@ -8,5 +8,5 @@ x <> 0
 -> x <> 18 -> x <> 19 -> x <> 20 -> False.
 Proof.
   intros.
-  omega.
-Qed.
+  Fail omega.
+Abort.
diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/1501.v
index 1845dd1f..b36f21da 100644
--- a/test-suite/bugs/opened/shouldnotfail/1501.v
+++ b/test-suite/bugs/opened/1501.v
@@ -40,11 +40,13 @@ Parameter
 
 Hint Resolve equiv_refl equiv_sym equiv_trans: monad.
 
-Add Relation K equiv
- reflexivity proved by (@equiv_refl)
- symmetry proved by (@equiv_sym)
- transitivity proved by (@equiv_trans)
- as equiv_rel.
+Instance equiv_rel A: Equivalence (@equiv A).
+Proof.
+ constructor.
+ intros xa; apply equiv_refl.
+ intros xa xb; apply equiv_sym.
+ intros xa xb xc; apply equiv_trans.
+Defined.
 
 Definition fequiv (A B: Type)  (f g: A -> K B) := forall (x:A), (equiv (f x) (g
 x)).
@@ -67,17 +69,17 @@ Proof.
   unfold fequiv; intros; eapply equiv_trans; auto with monad.
 Qed.
 
-Add Relation (fun (A B:Type) => A -> K B) fequiv
- reflexivity proved by (@fequiv_refl)
- symmetry proved by (@fequiv_sym)
- transitivity proved by (@fequiv_trans)
- as fequiv_rel.
+Instance fequiv_re A B: Equivalence (@fequiv A B).
+Proof.
+ constructor.
+ intros f; apply fequiv_refl.
+ intros f g; apply fequiv_sym.
+ intros f g h; apply fequiv_trans.
+Defined.
 
-Add Morphism bind
- with signature equiv ==> fequiv ==> equiv
- as bind_mor.
+Instance bind_mor A B: Morphisms.Proper (@equiv _ ==> @fequiv _ _ ==> @equiv _) (@bind A B).
 Proof.
- unfold fequiv; intros; apply bind_compat; auto.
+ unfold fequiv; intros x y xy_equiv f g fg_equiv; apply bind_compat; auto.
 Qed.
 
 Lemma test:
@@ -88,6 +90,7 @@ Lemma test:
 Proof.
   intros A B m1 m2 m3 f H1 H2.
   setoid_rewrite H1. (* this works *)
-  setoid_rewrite H2.
-  trivial by equiv_refl.
-Qed.
+  Fail setoid_rewrite H2.
+Abort.
+(*  trivial by equiv_refl.
+Qed.*)
diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/1596.v
index de77e35d..7c5dc416 100644
--- a/test-suite/bugs/opened/shouldnotfail/1596.v
+++ b/test-suite/bugs/opened/1596.v
@@ -1,7 +1,10 @@
-
 Require Import Relations.
 Require Import FSets.
 Require Import Arith.
+Require Import Omega.
+Unset Standard Proposition Elimination Names.
+
+Set Keyed Unification.
 
 Lemma Bool_elim_bool : forall (b:bool),b=true \/ b=false.
   destruct b;try tauto.
@@ -100,6 +103,16 @@ Definition t := (X.t * Y.t)%type.
     left;trivial.
   Defined.
 
+  Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}.
+  Proof.
+    intros [xa xb] [ya yb]; simpl.
+    destruct (X.eq_dec xa ya).
+    destruct (Y.eq_dec xb yb).
+    + left; now split.
+    + right. now intros [eqa eqb].
+    + right. now intros [eqa eqb].
+  Defined.
+
   Hint Immediate eq_sym.
   Hint Resolve eq_refl eq_trans lt_not_eq lt_trans.
 End OrderedPair.
@@ -158,6 +171,14 @@ GT;simpl;trivial;fail).
       apply GT;trivial.
     Defined.
 
+    Definition eq_dec : forall (x y: t), { eq x y } + { ~ eq x y}.
+    Proof.
+    intros [i] [j]. unfold eq.
+    destruct (eq_nat_dec i j).
+    + left. now f_equal.
+    + right. intros meq; now inversion meq.
+    Defined.
+
     Hint Immediate eq_sym.
     Hint Resolve eq_refl eq_trans lt_not_eq lt_trans.
   End Ord.
@@ -235,8 +256,6 @@ n).
     induction m;simpl;intro.
     elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros.
     apply SynInc;apply H.mem_2;trivial.
-
-    rewrite H in H0. (* !! impossible here !! *)
-    discriminate H0.
+    rewrite H in H0. discriminate. (* !! impossible here !! *)
   Qed.
 End B.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/1671.v
index d95c2108..b4e653f6 100644
--- a/test-suite/bugs/opened/shouldnotfail/1671.v
+++ b/test-suite/bugs/opened/1671.v
@@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type :=
 Variable P : forall bo, hdlist bo -> Prop.
 Variable all : forall bo l, P bo l.
 
-Definition F (l:hdlist tt) : P tt l :=
+Fail Definition F (l:hdlist tt) : P tt l :=
 match l in hdlist u return P u l with
 | cons (cons l') => all tt _
 end.
diff --git a/test-suite/bugs/opened/1773.v b/test-suite/bugs/opened/1773.v
deleted file mode 100644
index 4aabf19c..00000000
--- a/test-suite/bugs/opened/1773.v
+++ /dev/null
@@ -1,10 +0,0 @@
-Goal forall B C : nat -> nat -> Prop, forall k, C 0 k ->
-  (exists A, (forall k', C A k' -> B A k') -> B A k).
-Proof.
-  intros B C k H.
-  econstructor.
-  intros X.
-  apply X.
-  apply H.
-Qed.
-
diff --git a/test-suite/bugs/opened/shouldnotfail/1811.v b/test-suite/bugs/opened/1811.v
index 037b7cb2..10c988fc 100644
--- a/test-suite/bugs/opened/shouldnotfail/1811.v
+++ b/test-suite/bugs/opened/1811.v
@@ -6,4 +6,5 @@ Proof. auto. Qed.
 Goal forall b1 b2, (negb b1 = b2)  ->  xorb true b1 = b2.
 Proof.
   intros b1 b2.
-  rewrite neg2xor.
\ No newline at end of file
+  Fail rewrite neg2xor.
+Abort.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/2572.v-disabled b/test-suite/bugs/opened/2572.v-disabled
new file mode 100644
index 00000000..3f6c6a0d
--- /dev/null
+++ b/test-suite/bugs/opened/2572.v-disabled
@@ -0,0 +1,187 @@
+Require Import List.
+Definition is_dec (P:Prop) := {P}+{~P}.
+Definition eq_dec (T:Type) := forall (t1 t2:T), is_dec (t1=t2).
+
+Record Label : Type := mkLabel {
+	LabElem: Type;
+	LabProd: LabElem -> LabElem -> option LabElem;
+	LabBot: LabElem -> Prop;
+	LabError: LabElem -> Prop
+}.
+
+Definition LProd (L1 L2: Label): Label := {|
+	LabElem := LabElem L1 * LabElem L2;
+	LabProd := fun lg ld => let (lg1,lg2) := lg in let (ld1,ld2) := ld in
+	  match LabProd L1 lg1 ld1, LabProd L2 lg2 ld2 with
+	    Some g, Some d => Some (g,d)
+	  | _,_ => None
+	  end;
+	LabBot l := let (l1,l2) := l in LabBot L1 l1 \/ LabBot L2 l2;
+	LabError l := let (l1,l2) := l in LabError L1 l1 \/ LabError L2 l2
+|}.
+
+Definition Lrestrict (L: Label) (S: LabElem L -> bool): Label := {|
+	LabElem := LabElem L;
+	LabProd l1 l2 := if andb (S l1) (S l2) then LabProd L l1 l2 else None;
+	LabBot l := LabBot L l;
+	LabError l := LabError L l
+|}.
+
+Notation "l1 ^* l2" := (LProd l1 l2) (at level 50).
+
+Record LTS(L:Type): Type := mkLTS {
+	State: Type;
+	Init: State -> Prop;
+	Next: State -> L -> State -> Prop
+}.
+Implicit Arguments State.
+Implicit Arguments Init.
+Implicit Arguments Next.
+
+Definition sound L (S: LTS (LabElem L)): Prop :=
+  forall s s' l, Next S s l s' -> ~LabError L l.
+
+Inductive PNext L (S1 S2:LTS (LabElem L)): State S1 * State S2 -> (LabElem L) -> State S1 * State S2 -> Prop :=
+  LNext: forall s1 s2 l1 s'1, Next S1 s1 l1 s'1 -> (forall l2, LabProd L l1 l2 = None) ->
+	PNext L S1 S2 (s1,s2) l1 (s'1,s2)
+| RNext: forall s1 s2 l2 s'2, (forall l1, LabProd L l1 l2 = None) -> Next S2 s2 l2 s'2 ->
+	PNext L S1 S2 (s1,s2) l2 (s1,s'2)
+| SNext: forall s1 s2 l1 l2 l s'1 s'2, Next S1 s1 l1 s'1 -> Next S2 s2 l2 s'2 ->
+	Some l = LabProd L l1 l2 -> PNext L S1 S2 (s1,s2) l (s'1,s'2).
+
+Definition Produit (L:Label) (S1 S2: LTS (LabElem L)): LTS (LabElem L) := {|
+	State := State S1 * State S2;
+	Init := fun s => let (s1,s2) := s in Init S1 s1 /\ Init S2 s2;
+	Next :=PNext L S1 S2
+|}.
+
+Parameter Time: Type.
+Parameter teq: forall t1 t2:Time, {t1=t2}+{t1<>t2}.
+
+Inductive TLabElem(L:Type): Type :=
+  Tdiscrete: L -> TLabElem L
+| Tdelay: Time -> TLabElem L
+| Tbot: TLabElem L.
+
+Definition TLabel L: Label := {| 
+    LabElem := TLabElem (LabElem L);
+    LabProd lt1 lt2 :=
+      match lt1, lt2 with
+        Tdiscrete l1, Tdiscrete l2 => match (LabProd L l1 l2) with Some l => Some (Tdiscrete (LabElem L) l) | None => None end
+      | Tdelay t1, Tdelay t2 => if teq t1 t2 then Some (Tdelay (LabElem L) t1) else Some  (Tbot (LabElem L))
+      | _,_ => None
+      end;
+    LabBot lt := match lt with
+      Tdiscrete l => LabBot L l
+        | Tbot => True
+        | _ => False
+    end;
+    LabError lt := match lt with
+      Tdiscrete l => LabError L l
+        | _ => False
+    end
+  |}.
+
+Parameter Var: Type.
+Parameter allv: forall P, (forall (v:Var), is_dec (P v)) -> is_dec (forall v, P v).
+Parameter DType: Type.
+Parameter Data: DType -> Type.
+Parameter vtype: Var -> DType.
+Parameter Deq: forall t (d1 d2: Data t), is_dec (d1=d2).
+
+Inductive Vctr(v:Var): Type :=
+  Wctr: Data (vtype v) -> Vctr v
+| Rctr: Data (vtype v) -> Vctr v
+| Fctr: Vctr v
+| Nctr: Vctr v.
+
+Definition isCmp v (c1 c2: Vctr v): Prop :=
+  match c1,c2 with
+    Wctr _, Nctr => True
+  | Rctr _, Rctr _  => True
+  | Rctr _, Nctr => True
+  | Rctr _, Fctr => True
+  | Nctr, _ => True
+  | _,_ => False
+  end.
+
+Lemma isCmp_dec: forall v (c1 c2: Vctr v), is_dec (isCmp v c1 c2).
+intros.
+induction c1; induction c2; simpl; intros; try (left; tauto); try (right; tauto).
+Qed.
+ 
+Definition Vprod v (c1 c2: Vctr v): (isCmp v c1 c2) -> Vctr v :=
+  match c1,c2 return isCmp v c1 c2 -> Vctr v with
+  | Wctr d, Nctr => fun h => Wctr v d
+  | Rctr d1, Rctr d2 => fun h => if Deq (vtype v) d1 d2 then Rctr v d1 else Fctr v
+  | Rctr d1, Nctr => fun h => Rctr v d1
+  | Rctr d1, Fctr => fun h => Fctr v
+  | Fctr, Rctr _ => fun h => Fctr v
+  | Fctr, Fctr  => fun h => Fctr v
+  | Fctr, Nctr => fun h => Fctr v
+  | Nctr, c2 => fun h => c2
+  | _,_ => fun h => match h with end
+  end.
+
+Inductive MLabElem: Type :=
+  Mctr: (forall v, Vctr v) -> MLabElem
+| Merr: MLabElem.
+
+Definition MProd (m1 m2: MLabElem): MLabElem :=
+  match m1,m2 with
+    Mctr c1, Mctr c2 => match allv (fun v => isCmp v (c1 v) (c2 v)) (fun v => isCmp_dec v (c1 v) (c2 v)) with
+      left h => Mctr (fun v => Vprod v (c1 v) (c2 v)  (h v))
+    | _ => Merr
+    end
+  | _,_ => Merr
+  end.
+
+Definition MLabel: Label := {|
+	LabElem := MLabElem;
+	LabProd m1 m2 := Some (MProd m1 m2);
+	LabBot m := exists c, m = Mctr c /\ exists v, c v = Fctr v;
+	LabError m := m = Merr  
+|}.
+
+Parameter Chan: Type.
+Parameter ch_eq: eq_dec Chan.
+
+Definition CLabel(S: Chan->bool): Label := {|
+	LabElem := Chan;
+	LabProd := fun c1 c2 => if ch_eq c1 c2 then if S c1 then Some c1 else None else None;
+	LabBot := fun _ => False;
+	LabError := fun _ => False
+|}.
+
+Definition FLabel(S: Chan->bool): Label :=
+	TLabel (CLabel S ^* MLabel ^* MLabel ^* MLabel).
+
+Definition FTS := LTS (LabElem (FLabel (fun _ => true))).
+Check (fun S (T1 T2: FTS) => Produit (FLabel S) T1 T2).
+(*
+Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS.
+unfold FTS in *; simpl in *.
+apply (Produit (FLabel S)).
+apply T1.
+apply T2.
+Defined.
+
+Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS :=
+	Produit (FLabel S) T1 T2.
+*)
+Lemma FTSirrel (S: Chan -> bool): FTS = LTS (LabElem (FLabel S)).
+Proof.
+ unfold FTS.
+ simpl.
+ reflexivity.
+Qed.
+
+Definition PAR (S: Chan -> bool) (T1 T2: FTS): FTS.
+revert T2; revert T1.
+rewrite (FTSirrel S).
+apply (Produit (FLabel S)).
+Defined.
+
+Record HTTS: Type := mkHTTS {
+	
+}.
diff --git a/test-suite/bugs/opened/2652a.v-disabled b/test-suite/bugs/opened/2652a.v-disabled
new file mode 100644
index 00000000..0274037b
--- /dev/null
+++ b/test-suite/bugs/opened/2652a.v-disabled
@@ -0,0 +1,106 @@
+Require Import Strings.String.
+Require Import Classes.EquivDec.
+Require Import Lists.List.
+
+Inductive Owner : Type :=
+ | server : Owner
+ | client : Owner.
+
+Inductive ClassName : Type :=
+ | className : string -> ClassName.
+
+Inductive Label : Type :=
+ | label : nat -> Owner -> Label.
+
+Inductive Var : Type :=
+ | var : string -> Var.
+
+Inductive FieldName : Type :=
+ | fieldName : string -> Owner -> FieldName.
+
+Inductive MethodCall : Type :=
+ | methodCall : string -> MethodCall.
+
+Inductive Exp : Type :=
+ | varExp : Var -> Exp
+ | fieldReference : Var -> FieldName -> Exp
+ | methodCallExp : Var -> MethodCall -> list Var -> Exp
+ | allocation : ClassName -> list Var -> Exp
+ | cast : ClassName -> Var -> Exp.
+
+Inductive Stmt : Type :=
+ | assignment : Var -> Exp -> Label -> Stmt
+ | returnStmt : Var -> Label -> Stmt
+ | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt.
+
+Inductive Konst : Type :=
+ | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst.
+
+Inductive Method : Type :=
+ | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method.
+
+Inductive Class : Type :=
+ | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class.
+
+Inductive Context : Type :=
+ | context : nat -> Context.
+
+Inductive HContext : Type :=
+ | heapContext : nat -> HContext.
+
+Inductive Location := loc : nat -> Location.
+
+Definition AbsLocation := ((Var * Context) +  (FieldName * HContext)) % type.
+
+Definition CallStack := list (Stmt * Context * Var) % type.
+
+Inductive TypeState : Type :=
+ | fresh : TypeState
+ | stale : TypeState.
+
+Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type.
+
+Definition Store := Location -> option Obj.
+
+Definition OwnerStore := Owner -> Store.
+
+Definition AbsStore := AbsLocation -> option (list Obj).
+
+Definition Stack := list (Var -> option Location).
+
+Definition Batch := list Location.
+
+Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type.
+
+Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) :=
+    fun k' => if equiv_decb k' k then v else f k'.
+  
+
+Definition transfer : Label -> OwnerStore -> Batch -> (OwnerStore * Batch) :=
+  fun _ o b => (o,b).
+
+Parameter succ : Label -> Stmt.
+
+Parameter owner : Label -> Owner.
+
+Inductive concreteSingleStep : Sigma -> Sigma -> Prop :=
+ | fieldAssignmentLocal : forall v f_do  f o  so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b',
+   (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh))
+   -> sigma' = update sigma so sigma'_so -> o = so -> (sigma'', b') = transfer l sigma' b ->
+   concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b)
+                      (succ(l), st, sigma'', absSigma, cst, c, b').
+
+ | fieldAssignmentRemote : forall v f_do  f o  so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b',
+   (f_do = fieldName f o) -> so = owner(l) -> sigma_so = sigma(so) -> (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (hc, update m f_do st(v'), fresh)
+   -> sigma' = update sigma so sigma'_so -> o <> so -> (sigma'', b') = transfer l sigma' (b ++ st(v)) ->
+   concreteSingleStep ((fieldUpdate v f_o (varExp v') l), st, sigma, absSigma, cst, c, b)
+                      (succ(l), st, sigma'', absSigma, cst, c, b'')
+ | variableStep : forall v v' l st st' sigma sigma' absSigma cst c b b', 
+   (st' = st ++ (update (fun _ => None) v st(v'))) -> (sigma',b') = transfer l sigma b ->
+   concreteSingleStep ((assignment v (varExp v') l), st, sigma, absSigma, cst, c, b) (succ(l), st', sigma', absSigma, cst, c, b')
+ | returnStep : forall v l st sigma absSigma cst c b v_ret s st' sigma' c' b',
+   (s,c',v_ret) = car(cst) -> st' = cdr(st) ++ update (fun _ => None) v_ret st(v) -> (sigma', b') = transfer l sigma b ->
+   concreteSingleStep ((returnStmt v l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cdr(cst), c', b')
+ | fieldReferenceStep : forall v v' f_do l st sigma absSigma cst c b so hc m' m st' sigma' absSigma cst c b',
+   so = owner(l) -> (hc, m', fresh) = sigma(so)(st(v')) -> m' = update m f_do l -> st' = st ++ update (fun _ => None) v l -> (sigma', b') = transfer l sigma b ->
+   concreteSingleStep ((assignment v (fieldReference v' f_do) l), st, sigma, absSigma, cst, c, b) (s, st', sigma', absSigma, cst, c, b').
diff --git a/test-suite/bugs/opened/2652b.v-disabled b/test-suite/bugs/opened/2652b.v-disabled
new file mode 100644
index 00000000..b340436d
--- /dev/null
+++ b/test-suite/bugs/opened/2652b.v-disabled
@@ -0,0 +1,88 @@
+(* This used to show a bug in evarutil. which is fixed in 8.4 *)
+Require Import Strings.String.
+Require Import Classes.EquivDec.
+Require Import Lists.List.
+
+Inductive Owner : Type :=
+ | server : Owner
+ | client : Owner.
+
+Inductive ClassName : Type :=
+ | className : string -> ClassName.
+
+Inductive Label : Type :=
+ | label : nat -> Owner -> Label.
+
+Inductive Var : Type :=
+ | var : string -> Var.
+
+Inductive FieldName : Type :=
+ | fieldName : string -> Owner -> FieldName.
+
+Inductive MethodCall : Type :=
+ | methodCall : string -> MethodCall.
+
+Inductive Exp : Type :=
+ | varExp : Var -> Exp
+ | fieldReference : Var -> FieldName -> Exp
+ | methodCallExp : Var -> MethodCall -> list Var -> Exp
+ | allocation : ClassName -> list Var -> Exp
+ | cast : ClassName -> Var -> Exp.
+
+Inductive Stmt : Type :=
+ | assignment : Var -> Exp -> Label -> Stmt
+ | returnStmt : Var -> Label -> Stmt
+ | fieldUpdate : Var -> FieldName -> Exp -> Label -> Stmt.
+
+Inductive Konst : Type :=
+ | konst : ClassName -> (list (ClassName * FieldName)) -> list FieldName -> (list FieldName * FieldName) -> Konst.
+
+Inductive Method : Type :=
+ | method : ClassName -> MethodCall -> list (ClassName * Var) -> list (ClassName * Var) -> (list Stmt) -> Method.
+
+Inductive Class : Type :=
+ | class : ClassName -> ClassName -> (list (ClassName * FieldName)) -> (Konst * (list Method)) -> Class.
+
+Inductive Context : Type :=
+ | context : nat -> Context.
+
+Inductive HContext : Type :=
+ | heapContext : nat -> HContext.
+
+Inductive Location := loc : nat -> Location.
+
+Definition AbsLocation := ((Var * Context) +  (FieldName * HContext)) % type.
+
+Definition CallStack := list (Stmt * Context * Var) % type.
+
+Inductive TypeState : Type :=
+ | fresh : TypeState
+ | stale : TypeState.
+
+Definition Obj := (HContext * (FieldName -> option AbsLocation) * TypeState) % type.
+
+Definition Store := Location -> option Obj.
+
+Definition OwnerStore := Owner -> Store.
+
+Definition AbsStore := AbsLocation -> option (list Obj).
+
+Definition Stack := list (Var -> option Location).
+
+Definition Batch := list Location.
+
+Definition Sigma := (Stmt * Stack * OwnerStore * AbsStore * CallStack * Context * Batch) % type.
+
+Definition update {A : Type} {B : Type} `{EqDec A} `{EqDec B} (f : A -> B) (k : A) (v : B) : (A -> B) :=
+    fun k' => if equiv_decb k' k then v else f k'.
+
+Parameter succ : Label -> Stmt.
+
+Inductive concreteSingleStep : Sigma -> Sigma -> Prop :=
+ | fieldAssignmentLocal : forall v f_do  f o  so sigma_so hc m sigma'_so v' l st sigma absSigma cst c b sigma' sigma'' b',
+   Some (hc, m, fresh) = sigma_so(st(v)) -> sigma'_so = update sigma_so st(v) (Some (hc, update m f_do st(v'), fresh))
+   -> 
+   concreteSingleStep ((fieldUpdate v f_do (varExp v') l), st, sigma, absSigma, cst, c, b)
+                      (succ(l), st, sigma'', absSigma, cst, c, b').
+
+.
diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/opened/2800.v
new file mode 100644
index 00000000..c559ab0c
--- /dev/null
+++ b/test-suite/bugs/opened/2800.v
@@ -0,0 +1,6 @@
+Goal False.
+
+Fail intuition
+  match goal with
+  | |- _ => idtac " foo"
+  end.
diff --git a/test-suite/bugs/opened/2814.v b/test-suite/bugs/opened/2814.v
new file mode 100644
index 00000000..a740b438
--- /dev/null
+++ b/test-suite/bugs/opened/2814.v
@@ -0,0 +1,5 @@
+Require Import Program.
+
+Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False.
+  intros.
+  Fail induction H.
diff --git a/test-suite/bugs/opened/2951.v b/test-suite/bugs/opened/2951.v
new file mode 100644
index 00000000..3739247b
--- /dev/null
+++ b/test-suite/bugs/opened/2951.v
@@ -0,0 +1 @@
+Class C (A: Type) : Type := { f: A }.
diff --git a/test-suite/bugs/opened/3010.v-disabled b/test-suite/bugs/opened/3010.v-disabled
new file mode 100644
index 00000000..f2906bd6
--- /dev/null
+++ b/test-suite/bugs/opened/3010.v-disabled
@@ -0,0 +1 @@
+Definition em {A R} (k : forall s : sum A _, match s with inl x => R x | inr y => R end) := k (inr (fun x => k (inl x))).
\ No newline at end of file
diff --git a/test-suite/bugs/opened/3045.v b/test-suite/bugs/opened/3045.v
new file mode 100644
index 00000000..b7f40b4a
--- /dev/null
+++ b/test-suite/bugs/opened/3045.v
@@ -0,0 +1,30 @@
+Set Asymmetric Patterns.
+Generalizable All Variables.
+Set Implicit Arguments.
+Set Universe Polymorphism.
+
+Record SpecializedCategory (obj : Type) :=
+  {
+    Object :> _ := obj;
+    Morphism : obj -> obj -> Type;
+
+    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
+  }.
+
+Arguments Compose {obj} [C s d d'] m1 m2 : rename.
+
+Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type :=
+| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'.
+
+Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d :=
+  match m in @ReifiedMorphism objC C s d return Morphism C s d with
+    | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1)
+                                                         (@ReifiedMorphismDenote _ _ _ _ m2)
+  end.
+
+Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d)
+: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }.
+refine match m with
+         | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _
+       end; clear m.
+Fail destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ [] ? ].
diff --git a/test-suite/bugs/opened/3071.v b/test-suite/bugs/opened/3071.v
new file mode 100644
index 00000000..611ac606
--- /dev/null
+++ b/test-suite/bugs/opened/3071.v
@@ -0,0 +1,5 @@
+Definition foo := True.
+
+Section foo.
+  Global Arguments foo / .
+Fail End foo.
diff --git a/test-suite/bugs/opened/3092.v b/test-suite/bugs/opened/3092.v
new file mode 100644
index 00000000..9db21d15
--- /dev/null
+++ b/test-suite/bugs/opened/3092.v
@@ -0,0 +1,9 @@
+Fail Fixpoint le_pred (n1 n2 : nat) (H1 : n1 <= n2) : pred n1 <= pred n2 :=
+  match H1 with
+  | le_n      => le_n (pred _)
+  | le_S _ H2 =>
+    match n2 with
+    | 0   => fun H3 => H3
+    | S _ => le_S _ _
+    end (le_pred _ _ H2)
+  end.
diff --git a/test-suite/bugs/opened/3100.v b/test-suite/bugs/opened/3100.v
new file mode 100644
index 00000000..6f35a74d
--- /dev/null
+++ b/test-suite/bugs/opened/3100.v
@@ -0,0 +1,9 @@
+Fixpoint F (n : nat) (A : Type) : Type :=
+  match n with
+  | 0 => True
+  | S n => forall (x : A), F n (x = x)
+  end.
+
+Goal forall A n, (forall (x : A) (e : x = x), F n (e = e)).
+intros A n.
+Fail change (forall x, F n (x = x)) with (F (S n)).
diff --git a/test-suite/bugs/opened/3166.v b/test-suite/bugs/opened/3166.v
new file mode 100644
index 00000000..e1c29a95
--- /dev/null
+++ b/test-suite/bugs/opened/3166.v
@@ -0,0 +1,83 @@
+Set Asymmetric Patterns.
+
+Section eq.
+  Let A := { X : Type & X }.
+  Let B := (fun x : A => projT1 x).
+  Let T := (fun (a' : A) (b' : B a') => projT2 a' = b').
+  Let T' := T.
+  Let t1T := (fun _ : A => unit).
+  Let f1 := (fun x (_ : t1T x) => projT2 x).
+  Let t1 := (fun x (y : t1T x) => @eq_refl (projT1 x) (projT2 x)).
+  Let t1T' := t1T.
+  Let f1' := f1.
+  Let t1' := t1.
+
+  Theorem eq_matches_commute
+          a' b' (t' : T a' b')
+          (rta : forall b'', T' a' b'' -> A)
+          (rtb : forall b'' t'', B (rta b'' t''))
+          (rt1 : forall y, T _ (rtb (f1' a' y) (@t1' a' y)))
+          (R : forall (b : B (rta b' t')), T _ b -> Type)
+          (r1 : forall y, R (f1 _ y) (@t1 _ y))
+  : match
+      match t' as t0' in (@eq _ _ b0') return T (rta b0' t0') (rtb b0' t0') with
+        | eq_refl => rt1 tt
+      end
+      as t0 in (@eq _ _ b0)
+      return R b0 t0
+    with
+      | eq_refl => r1 tt
+    end
+    =
+    match t'
+          as t0' in (@eq _ _ b0')
+          return (forall (R : forall (b : B (rta b0' t0')), T _ b -> Type)
+                         (r1 : forall y, R (f1 _ y) (@t1 _ y)),
+                    R _ (match t0' as t0'0 in (@eq _ _ b0'0) return T (rta b0'0 t0'0) (rtb b0'0 t0'0) with
+                           | eq_refl => rt1 tt
+                         end))
+    with
+      | eq_refl => fun _ r1 =>
+                      match rt1 tt with
+                        | eq_refl => r1 tt
+                      end
+    end R r1.
+  Proof.
+    destruct t'; reflexivity.
+  Defined.
+
+  Theorem eq_match_beta2
+          a b (t : T a b)
+          X
+          (R : forall b' (t' : T a b'), X b' -> Type)
+          (r1 : forall y x, R _ (@t1 _ y) x)
+          x
+  : match t as t' in (@eq _ _ b') return forall x, R b' t' x with
+      | eq_refl => r1 tt
+    end (x b)
+    =
+    match t as t' in (@eq _ _ b') return R b' t' (x b') with
+      | eq_refl => r1 tt (x _)
+    end.
+  Proof.
+    destruct t; reflexivity.
+  Defined.
+End eq.
+
+Definition typeof {T} (_ : T) := T.
+
+Eval compute in (eq_sym (eq_sym _)).
+Goal forall T (x y : T) (p : x = y), True.
+  intros.
+  pose proof
+       (@eq_matches_commute
+          (existT (fun T => T) T x) y p
+          (fun b'' _ => existT (fun T => T) T b'')
+          (fun _ _ => x)
+          (fun _ => eq_refl)
+          (fun x' _ => x' = y)
+          (fun _ => eq_refl)
+        ) as H0.
+  compute in H0.
+  change (fun (x' : T) (_ : y = x') => x' = y) with ((fun y => fun (x' : T) (_ : y = x') => x' = y) y) in H0.
+  Fail pose proof (fun k => @eq_trans _ _ _ k H0).
diff --git a/test-suite/bugs/opened/3186.v-disabled b/test-suite/bugs/opened/3186.v-disabled
new file mode 100644
index 00000000..d0bcb920
--- /dev/null
+++ b/test-suite/bugs/opened/3186.v-disabled
@@ -0,0 +1,4 @@
+Fixpoint a (_:unit):=
+match eq_refl with
+|eq_refl => a
+end.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/3209.v b/test-suite/bugs/opened/3209.v
new file mode 100644
index 00000000..3203afa1
--- /dev/null
+++ b/test-suite/bugs/opened/3209.v
@@ -0,0 +1,17 @@
+Inductive eqT {A} (x : A) : A -> Type :=
+  reflT : eqT x x.
+Definition Bi_inv (A B : Type) (f : (A -> B)) :=
+  sigT (fun (g : B -> A) =>
+          sigT (fun (h : B -> A) =>
+                  sigT (fun (α : forall b : B, eqT (f (g b)) b) =>
+                          forall a : A, eqT (h (f a)) a))).
+Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f).
+
+Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B).
+Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B :=
+  sigT_rect (fun _ => TEquiv A B)
+            (fun (f : TEquiv A B -> eqT A B) H =>
+               sigT_rect (fun _ => TEquiv A B)
+                         (fun g _ => g e)
+                         H)
+            (UA A B).
diff --git a/test-suite/bugs/opened/3230.v b/test-suite/bugs/opened/3230.v
new file mode 100644
index 00000000..265310b1
--- /dev/null
+++ b/test-suite/bugs/opened/3230.v
@@ -0,0 +1,14 @@
+Structure type : Type := Pack { ob : Type }.
+Polymorphic Record category := { foo : Type }.
+Definition FuncComp := Pack category.
+Axiom C : category.
+
+Check (C : ob FuncComp). (* OK *)
+
+Canonical Structure FuncComp.
+
+Check (C : ob FuncComp).
+(* Toplevel input, characters 15-39:
+Error:
+The term "C" has type "category" while it is expected to have type
+ "ob FuncComp". *)
diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v
new file mode 100644
index 00000000..9e7d1eb5
--- /dev/null
+++ b/test-suite/bugs/opened/3248.v
@@ -0,0 +1,17 @@
+Ltac ret_and_left f :=
+  let tac := ret_and_left in
+  let T := type of f in
+  lazymatch eval hnf in T with
+    | ?T' -> _ =>
+      let ret := constr:(fun x' : T' => $(tac (f x'))$) in
+      exact ret
+    | ?T' => exact f
+  end.
+
+Goal forall A B : Prop, forall x y : A, True.
+Proof.
+  intros A B x y.
+  pose (f := fun (x y : A) => conj x y).
+  pose (a := $(ret_and_left f)$).
+  Fail unify (a x y) (conj x y).
+Abort.
diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v
new file mode 100644
index 00000000..6de13f74
--- /dev/null
+++ b/test-suite/bugs/opened/3263.v
@@ -0,0 +1,231 @@
+(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines,  2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *)
+Generalizable All Variables.
+Set Implicit Arguments.
+
+Arguments fst {_ _} _.
+Arguments snd {_ _} _.
+
+Axiom cheat : forall {T}, T.
+
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (paths x y) : type_scope.
+
+Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x
+  := match p with idpath => idpath end.
+
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory (object : Type) :=
+  Build_PreCategory' {
+      object :> Type := object;
+      morphism : object -> object -> Type;
+      identity : forall x, morphism x x;
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+      associativity : forall x1 x2 x3 x4
+                             (m1 : morphism x1 x2)
+                             (m2 : morphism x2 x3)
+                             (m3 : morphism x3 x4),
+                        (m3 o m2) o m1 = m3 o (m2 o m1);
+      associativity_sym : forall x1 x2 x3 x4
+                                 (m1 : morphism x1 x2)
+                                 (m2 : morphism x2 x3)
+                                 (m3 : morphism x3 x4),
+                            m3 o (m2 o m1) = (m3 o m2) o m1;
+      left_identity : forall a b (f : morphism a b), identity b o f = f;
+      right_identity : forall a b (f : morphism a b), f o identity a = f;
+      identity_identity : forall x, identity x o identity x = identity x
+    }.
+Bind Scope category_scope with PreCategory.
+Arguments PreCategory {_}.
+Arguments identity {_} [!C%category] x%object : rename.
+
+Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+Infix "o" := compose : morphism_scope.
+
+Delimit Scope functor_scope with functor.
+Local Open Scope morphism_scope.
+Record Functor `(C : @PreCategory objC, D : @PreCategory objD) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d);
+    composition_of : forall s d d'
+                            (m1 : morphism C s d) (m2: morphism C d d'),
+                       morphism_of _ _ (m2 o m1)
+                       = (morphism_of _ _ m2) o (morphism_of _ _ m1);
+    identity_of : forall x, morphism_of _ _ (identity x)
+                            = identity (object_of x)
+  }.
+Bind Scope functor_scope with Functor.
+
+Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+
+Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+
+Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) :=
+  {
+    morphism_inverse : morphism C d s;
+    left_inverse : morphism_inverse o m = identity _;
+    right_inverse : m o morphism_inverse = identity _
+  }.
+
+Definition opposite `(C : @PreCategory objC) : PreCategory
+  := @Build_PreCategory'
+       C
+       (fun s d => morphism C d s)
+       (identity (C := C))
+       (fun _ _ _ m1 m2 => m2 o m1)
+       (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _)
+       (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _)
+       (fun _ _ => @right_identity _ _ _ _)
+       (fun _ _ => @left_identity _ _ _ _)
+       (@identity_identity _ C).
+
+Notation "C ^op" := (opposite C) (at level 3) : category_scope.
+
+Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD).
+  refine (@Build_PreCategory'
+            (C * D)%type
+            (fun s d => (morphism C (fst s) (fst d)
+                         * morphism D (snd s) (snd d))%type)
+            (fun x => (identity (fst x), identity (snd x)))
+            (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))
+            _
+            _
+            _
+            _
+            _); admit.
+Defined.
+Infix "*" := prod : category_scope.
+
+Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor
+       C E
+       (fun c => G (F c))
+       (fun _ _ m => morphism_of G (morphism_of F m))
+       cheat
+       cheat.
+
+Infix "o" := compose_functor : functor_scope.
+
+Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) :=
+  Build_NaturalTransformation' {
+      components_of :> forall c, morphism D (F c) (G c);
+      commutes : forall s d (m : morphism C s d),
+                   components_of d o F _1 m = G _1 m o components_of s;
+
+      commutes_sym : forall s d (m : C.(morphism) s d),
+                       G _1 m o components_of s = components_of d o F _1 m
+    }.
+Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory
+  := @Build_PreCategory' (Functor C D)
+                         (@NaturalTransformation _ C _ D)
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat.
+
+Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op
+  := Build_Functor (C^op) (D^op)
+                   (object_of F)
+                   (fun s d => morphism_of F (s := d) (d := s))
+                   (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
+                   (identity_of F).
+
+Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op
+  := Build_Functor C (D^op)
+                   (object_of F)
+                   (fun s d => morphism_of F (s := d) (d := s))
+                   (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
+                   (identity_of F).
+Notation "F ^op" := (opposite_functor F) : functor_scope.
+
+Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope.
+Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C
+  := Build_Functor (C * D) C
+                   (@fst _ _)
+                   (fun _ _ => @fst _ _)
+                   (fun _ _ _ _ _ => idpath)
+                   (fun _ => idpath).
+
+Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D
+  := Build_Functor (C * D) D
+                   (@snd _ _)
+                   (fun _ _ => @snd _ _)
+                   (fun _ _ _ _ _ => idpath)
+                   (fun _ => idpath).
+Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D')
+: Functor C (D * D')
+  := Build_Functor
+       C (D * D')
+       (fun c => (F c, F' c))
+       (fun s d m => (F _1 m, F' _1 m))%morphism
+       cheat
+       cheat.
+Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D')
+  := (prod_functor (F o fst) (F' o snd))%functor.
+Notation cat_of obj :=
+  (@Build_PreCategory' obj
+                       (fun x y => forall _ : x, y)
+                       (fun _ x => x)
+                       (fun _ _ _ f g x => f (g x))%core
+                       (fun _ _ _ _ _ _ _ => idpath)
+                       (fun _ _ _ _ _ _ _ => idpath)
+                       (fun _ _ _ => idpath)
+                       (fun _ _ _ => idpath)
+                       (fun _ => idpath)).
+
+Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type)
+  := Build_Functor _ _ cheat cheat cheat cheat.
+
+Definition induced_hom_natural_transformation `(F : @Functor objC C objD D)
+: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F)
+  := Build_NaturalTransformation' _ _ cheat cheat cheat.
+
+Class IsFullyFaithful `(F : @Functor objC C objD D)
+  := is_fully_faithful
+     : forall x y : C,
+         IsIsomorphism (induced_hom_natural_transformation F (x, y)).
+
+Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type))
+  := cheat.
+
+Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type))
+  := (((coyoneda A^op)^op'L)^op'L)%functor.
+Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A).
+Admitted.
+
+Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A).
+Proof.
+  intros a b.
+  pose proof (coyoneda_embedding A^op a b) as CYE.
+  unfold yoneda.
+  Time let t := (type of CYE) in
+  let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *)
+  Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in
+  let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE').
+  Time let t := match goal with |- ?G => constr:(G) end in
+  let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *)
+Fail Timeout 2 Defined.
+Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *)
+
+Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A).
+Proof.
+  intros a b.
+  pose proof (coyoneda_embedding A^op a b) as CYE.
+  unfold yoneda; simpl in *.
+  Fail Timeout 1 exact CYE.
+  Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *)
+Fail Timeout 60 Defined. (* Timeout! *)
diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v
new file mode 100644
index 00000000..19ed787d
--- /dev/null
+++ b/test-suite/bugs/opened/3277.v
@@ -0,0 +1,7 @@
+Tactic Notation "evarr" open_constr(x) := let y := constr:(x) in exact y.
+
+Goal True.
+  evarr _.
+Admitted.
+Goal True.
+  Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *)
diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v
new file mode 100644
index 00000000..ced535af
--- /dev/null
+++ b/test-suite/bugs/opened/3278.v
@@ -0,0 +1,25 @@
+Module a.
+  Check let x' := _ in
+             $(exact x')$.
+
+  Notation foo x := (let x' := x in $(exact x')$).
+
+  Fail Check foo _. (* Error:
+Cannot infer an internal placeholder of type "Type" in environment:
+
+x' := ?42 : ?41
+. *)
+End a.
+
+Module b.
+  Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I).
+  Notation bar x := (let x' := x in let y := (I : True) in I).
+
+  Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *)
+  Check bar _. (* let x' := ?9 in let y := I in I *)
+  Fail Check foo _. (* Error:
+Cannot infer an internal placeholder of type "Type" in environment:
+
+x' := ?42 : ?41
+. *)
+End b.
diff --git a/test-suite/bugs/opened/3283.v b/test-suite/bugs/opened/3283.v
new file mode 100644
index 00000000..3ab5416e
--- /dev/null
+++ b/test-suite/bugs/opened/3283.v
@@ -0,0 +1,28 @@
+Notation "P |-- Q" := (@eq nat P Q) (at level 80, Q at level 41, no associativity) .
+Notation "x &&& y" := (plus x y) (at level 40, left associativity, y at next level) .
+Notation "'Ex' x , P " := (plus x P) (at level 65, x at level 99, P at level 80).
+
+(* Succeed *)
+Check _ |-- _ &&& _ -> _.
+Check _ |-- _ &&& (Ex _, _ ) -> _.
+Check _ |-- (_ &&& Ex _, _ ) -> _.
+
+(* Why does this fail? *)
+Fail Check _ |-- _ &&& Ex _, _  -> _.
+(* The command has indeed failed with message:
+=> Error: The term "Ex ?17, ?18" has type "nat"
+which should be Set, Prop or Type. *)
+
+(* Just in case something is strange with -> *)
+Notation "P ----> Q" := (P -> Q) (right associativity, at level 99, Q at next level).
+
+(* Succeed *)
+Check _ |-- _ &&& _ ----> _.
+Check _ |-- _ &&& (Ex _, _ )  ----> _.
+Check _ |-- (_ &&& Ex _, _ )  ----> _.
+
+(* Why does this fail? *)
+Fail Check _ |-- _ &&& Ex _, _  ----> _.
+(* The command has indeed failed with message:
+=> Error: The term "Ex ?31, ?32" has type "nat"
+which should be Set, Prop or Type.*)
diff --git a/test-suite/bugs/opened/3295.v b/test-suite/bugs/opened/3295.v
new file mode 100644
index 00000000..2a156e33
--- /dev/null
+++ b/test-suite/bugs/opened/3295.v
@@ -0,0 +1,104 @@
+Require Export Morphisms Setoid.
+
+Class lops := lmk_ops {
+  car: Type;
+  weq: relation car
+}.
+
+Implicit Arguments car [].
+
+Coercion car: lops >-> Sortclass.
+
+Instance weq_Equivalence `{lops}: Equivalence weq.
+Proof.
+Admitted.
+
+Module lset.
+Canonical Structure lset_ops A := lmk_ops (list A) (fun h k => True).
+End lset.
+
+Class ops := mk_ops {
+  ob: Type;
+  mor: ob -> ob -> lops;
+  dot: forall n m p, mor n m -> mor m p -> mor n p
+}.
+Coercion mor: ops >-> Funclass.
+Implicit Arguments ob [].
+
+Instance dot_weq `{ops} n m p: Proper (weq ==> weq ==> weq) (dot n m p).
+Proof.
+Admitted.
+
+Section s.
+
+Import lset.
+
+Context `{X:lops} {I: Type}.
+
+Axiom sup : forall (f: I -> X) (J : list I), X.
+
+Global Instance sup_weq: Proper (pointwise_relation _ weq ==> weq ==> weq) sup.
+Proof.
+Admitted.
+
+End s.
+
+Axiom ord : forall (n : nat), Type.
+Axiom seq : forall n, list (ord n).
+
+Infix "=="   := weq (at level 79).
+Infix "*" := (dot _ _ _)      (left associativity, at level 40).
+
+Notation "∑_ ( i ∈ l ) f" := (@sup (mor _ _) _ (fun i => f) l)
+  (at level 41, f at level 41, i, l at level 50).
+
+Axiom dotxsum : forall `{X : ops} I J n m p (f: I -> X m n) (x: X p m) y,
+  x * (∑_(i∈ J) f i) == y.
+
+Definition mx X n m := ord n -> ord m -> X.
+
+Section bsl.
+Context `{X : ops} {u: ob X}.
+Notation U := (car (@mor X u u)).
+
+Lemma toto n m p q (M : mx U n m) N (P : mx U p q) Q i j : ∑_(j0 ∈ seq m) M i j0 * (∑_(j1 ∈ seq p) N j0 j1 * P j1 j) == Q.
+Proof.
+  Fail setoid_rewrite dotxsum.
+  (* Toplevel input, characters 0-22:
+Error:
+Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints.
+Unable to satisfy the following constraints:
+UNDEFINED EVARS:
+ ?101==[X u n m p q M N P Q i j j0 |- U] (goal evar)
+ ?106==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder)
+ ?107==[X u n m p q M N P Q i j |- relation (list (ord m))]
+         (internal placeholder)
+ ?108==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation)
+         |- Proper (pointwise_relation (ord m) weq ==> ?107 ==> ?106) sup]
+         (internal placeholder)
+ ?109==[X u n m p q M N P Q i j |- ProperProxy ?107 (seq m)]
+         (internal placeholder)
+ ?110==[X u n m p q M N P Q i j |- relation (X u u)] (internal placeholder)
+ ?111==[X u n m p q M N P Q i j (do_subrelation:=do_subrelation)
+         |- Proper (?106 ==> ?110 ==> Basics.flip Basics.impl) weq]
+         (internal placeholder)
+ ?112==[X u n m p q M N P Q i j |- ProperProxy ?110 Q] (internal placeholder)UNIVERSES:
+ {} |= Top.14 <= Top.37
+        Top.25 <= Top.24
+        Top.25 <= Top.32
+
+ALGEBRAIC UNIVERSES:{}
+UNDEFINED UNIVERSES:METAS:
+ 470[y] := ?101 : car (?99 ?467 ?465)
+ 469[x] := M i _UNBOUND_REL_1 : car (?99 ?467 ?466)  [type is checked]
+ 468[f] := fun i : ?463 => N _UNBOUND_REL_2 i * P i j :
+ ?463 -> ?99 ?466 ?465  [type is checked]
+ 467[p] := u : ob ?99  [type is checked]
+ 466[m] := u : ob ?99  [type is checked]
+ 465[n] := u : ob ?99  [type is checked]
+ 464[J] := seq p : list ?463  [type is checked]
+ 463[I] := ord p : Type  [type is checked]
+ *)
+Abort.
+
+End bsl.
diff --git a/test-suite/bugs/opened/3298.v b/test-suite/bugs/opened/3298.v
new file mode 100644
index 00000000..bce7c3f2
--- /dev/null
+++ b/test-suite/bugs/opened/3298.v
@@ -0,0 +1,23 @@
+Module JGross.
+  Hint Extern 1 => match goal with |- match ?E with end => case E end.
+
+  Goal forall H : False, match H return Set with end.
+  Proof.
+    intros.
+    Fail solve [ eauto ]. (* No applicable tactic *)
+    admit.
+  Qed.
+End JGross.
+
+Section BenDelaware.
+  Hint Extern 0 => admit.
+  Goal forall (H : False), id (match H return Set with end).
+  Proof.
+    eauto.
+  Qed.
+  Goal forall (H : False), match H return Set with end.
+  Proof.
+    Fail solve [ eauto ] .
+    admit.
+  Qed.
+End BenDelaware.
diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v
new file mode 100644
index 00000000..529cc737
--- /dev/null
+++ b/test-suite/bugs/opened/3304.v
@@ -0,0 +1,3 @@
+Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$.
+(* The command has indeed failed with message:
+=> Error: Special token .. is for use in the Notation command. *)
diff --git a/test-suite/bugs/opened/3311.v b/test-suite/bugs/opened/3311.v
new file mode 100644
index 00000000..1c66bc1e
--- /dev/null
+++ b/test-suite/bugs/opened/3311.v
@@ -0,0 +1,10 @@
+Require Import Setoid.
+Axiom bar : True = False.
+Goal True.
+  Fail setoid_rewrite bar. (* Toplevel input, characters 15-33:
+Error:
+Tactic failure:setoid rewrite failed: Unable to satisfy the rewriting constraints.
+
+Could not find an instance for "subrelation eq (Basics.flip Basics.impl)".
+With the following constraints:
+?3 : "True" *)
diff --git a/test-suite/bugs/opened/3312.v b/test-suite/bugs/opened/3312.v
new file mode 100644
index 00000000..749921e2
--- /dev/null
+++ b/test-suite/bugs/opened/3312.v
@@ -0,0 +1,5 @@
+Require Import Setoid.
+Axiom bar : 0 = 1.
+Goal 0 = 1.
+  Fail rewrite_strat bar. (* Toplevel input, characters 15-32:
+Error: Tactic failure:setoid rewrite failed: Nothing to rewrite. *)
diff --git a/test-suite/bugs/opened/3320.v b/test-suite/bugs/opened/3320.v
new file mode 100644
index 00000000..05cf7328
--- /dev/null
+++ b/test-suite/bugs/opened/3320.v
@@ -0,0 +1,4 @@
+Goal forall x : nat, True.
+  fix 1.
+  assumption.
+Fail Qed.
diff --git a/test-suite/bugs/opened/3326.v b/test-suite/bugs/opened/3326.v
new file mode 100644
index 00000000..f73117a2
--- /dev/null
+++ b/test-suite/bugs/opened/3326.v
@@ -0,0 +1,18 @@
+Class ORDER A := Order {
+  LEQ : A -> A -> bool;
+  leqRefl: forall x, true = LEQ x x
+}.
+
+Section XXX.
+
+Variable A:Type.
+Variable (O:ORDER A).
+Definition aLeqRefl := @leqRefl _ O.
+
+Lemma OK : forall x, true = LEQ x x.
+  intros.
+  unfold LEQ.
+  destruct O.
+  clear.
+  Fail apply aLeqRefl. (* Toplevel input, characters 15-30:
+Anomaly: Uncaught exception Not_found(_). Please report. *)
diff --git a/test-suite/bugs/opened/3343.v b/test-suite/bugs/opened/3343.v
new file mode 100644
index 00000000..6c5a85f9
--- /dev/null
+++ b/test-suite/bugs/opened/3343.v
@@ -0,0 +1,46 @@
+(* File reduced by coq-bug-finder from original input, then from 13699 lines to 656 lines, then from 584 lines to 200 lines *)
+Set Asymmetric Patterns.
+Require Export Coq.Lists.List.
+Export List.ListNotations.
+
+Record CFGV := { Terminal : Type; VarSym : Type }.
+
+Section Gram.
+  Context  {G : CFGV}.
+
+  Inductive  Pattern : (Terminal G) -> Type :=
+  | ptleaf : forall (T : Terminal G),
+               nat -> Pattern T
+  with Mixture : list (Terminal G) -> Type :=
+  | mtcons : forall {h: Terminal G}
+                    {tl: list (Terminal G)},
+               Pattern h -> Mixture tl -> Mixture (h::tl).
+
+  Variable vc : VarSym G.
+
+  Fixpoint pBVars {gs}  (p : Pattern gs) : (list nat) :=
+    match p with
+      | ptleaf _ _ => []
+    end
+  with mBVars {lgs} (pts : Mixture lgs) : (list nat) :=
+         match pts with
+           | mtcons _ _ _ tl =>  mBVars  tl
+         end.
+
+  Lemma mBndngVarsAsNth :
+    forall mp (m : @Mixture mp),
+      mBVars m = [2].
+  Proof.
+    intros.
+    induction m. progress simpl.
+  Admitted.
+End Gram.
+
+Lemma mBndngVarsAsNth' {G : CFGV} { vc  : VarSym G} :
+  forall mp (m : @Mixture G mp),
+    mBVars m = [2].
+Proof.
+  intros.
+  induction m.
+  Fail progress simpl.
+  (* simpl did nothing here, while it does something inside the section; this is probably a bug*)
diff --git a/test-suite/bugs/opened/3345.v b/test-suite/bugs/opened/3345.v
new file mode 100644
index 00000000..b61174a8
--- /dev/null
+++ b/test-suite/bugs/opened/3345.v
@@ -0,0 +1,144 @@
+(* File reduced by coq-bug-finder from original input, then from 1972 lines to 136 lines, then from 119 lines to 105 lines *)
+Global Set Implicit Arguments.
+Require Import Coq.Lists.List Program.
+Section IndexBound.
+  Context {A : Set}.
+  Class IndexBound (a : A) (Bound : list A) :=
+    { ibound :> nat;
+      boundi : nth_error Bound ibound = Some a}.
+  Global Arguments ibound [a Bound] _ .
+  Global Arguments boundi [a Bound] _.
+  Record BoundedIndex (Bound : list A) := { bindex :> A; indexb :> IndexBound bindex Bound }.
+End IndexBound.
+Context {A : Type} {C : Set}.
+Variable (projAC : A -> C).
+Lemma None_neq_Some
+: forall (AnyT AnyT' : Type) (a : AnyT),
+    None = Some a -> AnyT'.
+  admit.
+Defined.
+Program Definition nth_Bounded'
+           (Bound : list A)
+           (c : C)
+           (a_opt : option A)
+           (nth_n : option_map projAC a_opt = Some c)
+: A := match a_opt as x
+             return (option_map projAC x = Some c) -> A with
+         | Some a => fun _ => a
+         | None => fun f : None = Some _ => !
+       end nth_n.
+Lemma nth_error_map :
+  forall n As c_opt,
+    nth_error (map projAC As) n = c_opt
+    -> option_map projAC (nth_error As n) = c_opt.
+  admit.
+Defined.
+Definition nth_Bounded
+           (Bound : list A)
+           (idx : BoundedIndex (map projAC Bound))
+: A := nth_Bounded' Bound (nth_error Bound (ibound idx))
+                    (nth_error_map _ _ (boundi idx)).
+Program Definition nth_Bounded_ind2
+        (P : forall As, BoundedIndex (map projAC As)
+                        -> BoundedIndex (map projAC As)
+                        -> A -> A -> Prop)
+: forall (Bound : list A)
+         (idx : BoundedIndex (map projAC Bound))
+         (idx' : BoundedIndex (map projAC Bound)),
+    match nth_error Bound (ibound idx), nth_error Bound (ibound idx') with
+      | Some a, Some a' => P Bound idx idx' a a'
+      | _, _ => True
+    end
+    -> P Bound idx idx' (nth_Bounded _ idx) (nth_Bounded _ idx'):=
+  fun Bound idx idx' =>
+    match (nth_error Bound (ibound idx)) as e, (nth_error Bound (ibound idx')) as e'
+          return
+          (forall (f : option_map _ e = Some (bindex idx))
+                  (f' : option_map _ e' = Some (bindex idx')),
+             (match e, e' with
+                | Some a, Some a' => P Bound idx idx' a a'
+                | _, _ => True
+              end)
+             -> P Bound idx idx'
+                  (match e as e'' return
+                         option_map _ e'' = Some (bindex idx)
+                         -> A
+                   with
+                     | Some a => fun _ => a
+                     | _ => fun f => _
+                   end f)
+                  (match e' as e'' return
+                         option_map _ e'' = Some (bindex idx')
+                         -> A
+                   with
+                     | Some a => fun _ => a
+                     | _ => fun f => _
+                   end f')) with
+      | Some a, Some a' => fun _ _ H => _
+      | _, _ => fun f => _
+    end (nth_error_map _ _ (boundi idx))
+        (nth_error_map _ _ (boundi idx')).
+
+Lemma nth_Bounded_eq
+: forall (Bound : list A)
+         (idx idx' : BoundedIndex (map projAC Bound)),
+    ibound idx = ibound idx'
+    -> nth_Bounded Bound idx = nth_Bounded Bound idx'.
+Proof.
+  intros.
+  eapply nth_Bounded_ind2 with (idx := idx) (idx' := idx').
+  simpl.
+  (* The [case_eq] should not Fail.  More importantly, [Fail case_eq ...] should succeed if [case_eq ...] fails.  It doesn't!!!  So I resort to [Fail Fail try (case_eq ...)]. *)
+  Fail Fail try (case_eq (nth_error Bound (ibound idx'))).
+(* Toplevel input, characters 15-54:
+In nested Ltac calls to "case_eq" and "pattern x at - 1", last call failed.
+Error: The abstracted term
+"fun e : Exc A =>
+ forall e0 : nth_error Bound (ibound idx') = e,
+ match
+   nth_error Bound (ibound idx) as anonymous'0
+   return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop)
+ with
+ | Some a =>
+     match
+       e as anonymous'
+       return
+         (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop)
+     with
+     | Some a' =>
+         fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) =>
+         a = a'
+     | None =>
+         fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) =>
+         True
+     end
+ | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True
+ end eq_refl e0" is not well typed.
+Illegal application:
+The term
+ "match
+    nth_error Bound (ibound idx) as anonymous'0
+    return (anonymous'0 = nth_error Bound (ibound idx) -> e = e -> Prop)
+  with
+  | Some a =>
+      match
+        e as anonymous'
+        return
+          (Some a = nth_error Bound (ibound idx) -> anonymous' = e -> Prop)
+      with
+      | Some a' =>
+          fun (_ : Some a = nth_error Bound (ibound idx)) (_ : Some a' = e) =>
+          a = a'
+      | None =>
+          fun (_ : Some a = nth_error Bound (ibound idx)) (_ : None = e) =>
+          True
+      end
+  | None => fun (_ : None = nth_error Bound (ibound idx)) (_ : e = e) => True
+  end" of type
+ "nth_error Bound (ibound idx) = nth_error Bound (ibound idx) ->
+  e = e -> Prop"
+cannot be applied to the terms
+ "eq_refl" : "nth_error Bound (ibound idx) = nth_error Bound (ibound idx)"
+ "e0" : "nth_error Bound (ibound idx') = e"
+The 2nd term has type "nth_error Bound (ibound idx') = e"
+which should be coercible to "e = e". *)
diff --git a/test-suite/bugs/opened/3357.v b/test-suite/bugs/opened/3357.v
new file mode 100644
index 00000000..c4791588
--- /dev/null
+++ b/test-suite/bugs/opened/3357.v
@@ -0,0 +1,9 @@
+Notation D1 := (forall {T : Type} ( x : T ) , Type).
+
+Definition DD1 ( A : forall {T : Type} (x : T), Type ) := A 1.
+Fail Definition DD1' ( A : D1 ) := A 1. (* Toplevel input, characters 32-33:
+Error: In environment
+A : forall T : Type, T -> Type
+The term "1" has type "nat" while it is expected to have type
+"Type".
+ *)
diff --git a/test-suite/bugs/opened/3363.v b/test-suite/bugs/opened/3363.v
new file mode 100644
index 00000000..800d8957
--- /dev/null
+++ b/test-suite/bugs/opened/3363.v
@@ -0,0 +1,26 @@
+(** In this file, either all four [Check]s should fail, or all four should succeed. *)
+Module A.
+  Section HexStrings.
+    Require Import String.
+  End HexStrings.
+  Fail Check string.
+End A.
+
+Module B.
+  Section HexStrings.
+    Require String.
+    Import String.
+  End HexStrings.
+  Fail Check string.
+End B.
+
+Section HexStrings.
+  Require String.
+  Import String.
+End HexStrings.
+Fail Check string.
+
+Section HexStrings'.
+  Require Import String.
+End HexStrings'.
+Check string.
diff --git a/test-suite/bugs/opened/3370.v b/test-suite/bugs/opened/3370.v
new file mode 100644
index 00000000..4964bf96
--- /dev/null
+++ b/test-suite/bugs/opened/3370.v
@@ -0,0 +1,12 @@
+Require Import String.
+
+Local Ltac set_strings :=
+  let s := match goal with |- context[String ?s1 ?s2] => constr:(String s1 s2) end in
+  let H := fresh s in
+  set (H := s).
+
+Local Open Scope string_scope.
+
+Goal "asdf" = "bds".
+Fail set_strings. (* Error: Ltac variable s is bound to "asdf" which cannot be coerced to
+a fresh identifier. *)
diff --git a/test-suite/bugs/opened/3383.v b/test-suite/bugs/opened/3383.v
new file mode 100644
index 00000000..9a14641a
--- /dev/null
+++ b/test-suite/bugs/opened/3383.v
@@ -0,0 +1,7 @@
+Goal forall b : bool, match b as b' return if b' then True else True with true => I | false => I end = match b as b' return if b' then True else True with true => I | false => I end.
+intro.
+Fail lazymatch goal with
+| [ |- appcontext[match ?b as b' return @?P b' with true => ?t | false => ?f end] ]
+  => change (match b as b' return P b with true => t | false => f end) with (@bool_rect P t f)
+end. (* Toplevel input, characters 153-154:
+Error: The reference P was not found in the current environment. *)
diff --git a/test-suite/bugs/opened/3395.v b/test-suite/bugs/opened/3395.v
new file mode 100644
index 00000000..ff0dbf97
--- /dev/null
+++ b/test-suite/bugs/opened/3395.v
@@ -0,0 +1,230 @@
+(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines,  2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *)
+Generalizable All Variables.
+Set Implicit Arguments.
+
+Arguments fst {_ _} _.
+Arguments snd {_ _} _.
+
+Axiom cheat : forall {T}, T.
+
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (paths x y) : type_scope.
+
+Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x
+  := match p with idpath => idpath end.
+
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory (object : Type) :=
+  Build_PreCategory' {
+      object :> Type := object;
+      morphism : object -> object -> Type;
+      identity : forall x, morphism x x;
+      compose : forall s d d',
+                  morphism d d'
+                  -> morphism s d
+                  -> morphism s d'
+                              where "f 'o' g" := (compose f g);
+      associativity : forall x1 x2 x3 x4
+                             (m1 : morphism x1 x2)
+                             (m2 : morphism x2 x3)
+                             (m3 : morphism x3 x4),
+                        (m3 o m2) o m1 = m3 o (m2 o m1);
+      associativity_sym : forall x1 x2 x3 x4
+                                 (m1 : morphism x1 x2)
+                                 (m2 : morphism x2 x3)
+                                 (m3 : morphism x3 x4),
+                            m3 o (m2 o m1) = (m3 o m2) o m1;
+      left_identity : forall a b (f : morphism a b), identity b o f = f;
+      right_identity : forall a b (f : morphism a b), f o identity a = f;
+      identity_identity : forall x, identity x o identity x = identity x
+    }.
+Bind Scope category_scope with PreCategory.
+Arguments PreCategory {_}.
+Arguments identity {_} [!C%category] x%object : rename.
+
+Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.
+
+Infix "o" := compose : morphism_scope.
+
+Delimit Scope functor_scope with functor.
+Local Open Scope morphism_scope.
+Record Functor `(C : @PreCategory objC, D : @PreCategory objD) :=
+  {
+    object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d
+                              -> morphism D (object_of s) (object_of d);
+    composition_of : forall s d d'
+                            (m1 : morphism C s d) (m2: morphism C d d'),
+                       morphism_of _ _ (m2 o m1)
+                       = (morphism_of _ _ m2) o (morphism_of _ _ m1);
+    identity_of : forall x, morphism_of _ _ (identity x)
+                            = identity (object_of x)
+  }.
+Bind Scope functor_scope with Functor.
+
+Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+
+Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope.
+
+Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) :=
+  {
+    morphism_inverse : morphism C d s;
+    left_inverse : morphism_inverse o m = identity _;
+    right_inverse : m o morphism_inverse = identity _
+  }.
+
+Definition opposite `(C : @PreCategory objC) : PreCategory
+  := @Build_PreCategory'
+       C
+       (fun s d => morphism C d s)
+       (identity (C := C))
+       (fun _ _ _ m1 m2 => m2 o m1)
+       (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _)
+       (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _)
+       (fun _ _ => @right_identity _ _ _ _)
+       (fun _ _ => @left_identity _ _ _ _)
+       (@identity_identity _ C).
+
+Notation "C ^op" := (opposite C) (at level 3) : category_scope.
+
+Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD).
+  refine (@Build_PreCategory'
+            (C * D)%type
+            (fun s d => (morphism C (fst s) (fst d)
+                         * morphism D (snd s) (snd d))%type)
+            (fun x => (identity (fst x), identity (snd x)))
+            (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))
+            _
+            _
+            _
+            _
+            _); admit.
+Defined.
+Infix "*" := prod : category_scope.
+
+Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E
+  := Build_Functor
+       C E
+       (fun c => G (F c))
+       (fun _ _ m => morphism_of G (morphism_of F m))
+       cheat
+       cheat.
+
+Infix "o" := compose_functor : functor_scope.
+
+Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) :=
+  Build_NaturalTransformation' {
+      components_of :> forall c, morphism D (F c) (G c);
+      commutes : forall s d (m : morphism C s d),
+                   components_of d o F _1 m = G _1 m o components_of s;
+
+      commutes_sym : forall s d (m : C.(morphism) s d),
+                       G _1 m o components_of s = components_of d o F _1 m
+    }.
+Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory
+  := @Build_PreCategory' (Functor C D)
+                         (@NaturalTransformation _ C _ D)
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat
+                         cheat.
+
+Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op
+  := Build_Functor (C^op) (D^op)
+                   (object_of F)
+                   (fun s d => morphism_of F (s := d) (d := s))
+                   (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
+                   (identity_of F).
+
+Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op
+  := Build_Functor C (D^op)
+                   (object_of F)
+                   (fun s d => morphism_of F (s := d) (d := s))
+                   (fun d' d s m1 m2 => composition_of F s d d' m2 m1)
+                   (identity_of F).
+Notation "F ^op" := (opposite_functor F) : functor_scope.
+
+Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope.
+Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C
+  := Build_Functor (C * D) C
+                   (@fst _ _)
+                   (fun _ _ => @fst _ _)
+                   (fun _ _ _ _ _ => idpath)
+                   (fun _ => idpath).
+
+Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D
+  := Build_Functor (C * D) D
+                   (@snd _ _)
+                   (fun _ _ => @snd _ _)
+                   (fun _ _ _ _ _ => idpath)
+                   (fun _ => idpath).
+Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D')
+: Functor C (D * D')
+  := Build_Functor
+       C (D * D')
+       (fun c => (F c, F' c))
+       (fun s d m => (F _1 m, F' _1 m))%morphism
+       cheat
+       cheat.
+Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D')
+  := (prod_functor (F o fst) (F' o snd))%functor.
+Notation cat_of obj :=
+  (@Build_PreCategory' obj
+                       (fun x y => forall _ : x, y)
+                       (fun _ x => x)
+                       (fun _ _ _ f g x => f (g x))%core
+                       (fun _ _ _ _ _ _ _ => idpath)
+                       (fun _ _ _ _ _ _ _ => idpath)
+                       (fun _ _ _ => idpath)
+                       (fun _ _ _ => idpath)
+                       (fun _ => idpath)).
+
+Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type)
+  := Build_Functor _ _ cheat cheat cheat cheat.
+
+Definition induced_hom_natural_transformation `(F : @Functor objC C objD D)
+: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F)
+  := Build_NaturalTransformation' _ _ cheat cheat cheat.
+
+Class IsFullyFaithful `(F : @Functor objC C objD D)
+  := is_fully_faithful
+     : forall x y : C,
+         IsIsomorphism (induced_hom_natural_transformation F (x, y)).
+
+Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type))
+  := cheat.
+
+Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type))
+  := (((coyoneda A^op)^op'L)^op'L)%functor.
+Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A).
+Admitted.
+
+Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A).
+Proof.
+  intros a b.
+  pose proof (coyoneda_embedding A^op a b) as CYE.
+  unfold yoneda.
+  Time let t := (type of CYE) in
+  let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *)
+  Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in
+  let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE').
+  Time let t := match goal with |- ?G => constr:(G) end in
+  let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *)
+Fail Timeout 2 Defined.
+Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *)
+
+Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A).
+Proof.
+  intros a b.
+  pose proof (coyoneda_embedding A^op a b) as CYE.
+  unfold yoneda; simpl in *.
+  Fail Timeout 1 exact CYE.
+  Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *)
diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v
new file mode 100644
index 00000000..0d259181
--- /dev/null
+++ b/test-suite/bugs/opened/3410.v
@@ -0,0 +1 @@
+Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end.
diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v
new file mode 100644
index 00000000..9e6107b3
--- /dev/null
+++ b/test-suite/bugs/opened/3459.v
@@ -0,0 +1,31 @@
+(* Bad interaction between clear and the typability of ltac constr bindings *)
+
+(* Original report *)
+
+Goal 1 = 2.
+Proof.
+(* This line used to fail with a Not_found up to some point, and then
+   to produce an ill-typed term *)
+match goal with
+  | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in
+                                                       clear x;
+                                                       exact r)$) in
+                           pose y
+end.
+(* Add extra test for typability (should not fail when bug closed) *)
+Fail match goal with P:?c |- _ => try (let x := type of c in idtac) || fail 2 end.
+Abort.
+
+(* Second report raising a Not_found at the time of 21 Oct 2014 *)
+
+Section F.
+
+Variable x : nat.
+
+Goal True.
+evar (e : Prop).
+assert e.
+Fail let r := constr:(eq_refl x) in clear x; exact r.
+Abort.
+
+End F.
diff --git a/test-suite/bugs/opened/3461.v b/test-suite/bugs/opened/3461.v
new file mode 100644
index 00000000..1b625e6a
--- /dev/null
+++ b/test-suite/bugs/opened/3461.v
@@ -0,0 +1,5 @@
+Lemma foo (b : bool) :
+  exists x : nat, x = x.
+Proof.
+eexists. 
+Fail eexact (eq_refl b).
diff --git a/test-suite/bugs/opened/3463.v b/test-suite/bugs/opened/3463.v
new file mode 100644
index 00000000..541db37f
--- /dev/null
+++ b/test-suite/bugs/opened/3463.v
@@ -0,0 +1,13 @@
+Tactic Notation "test1" open_constr(t) ident(r):=
+  pose t.
+Tactic Notation "test2" constr(r) open_constr(t):=
+  pose t.
+Tactic Notation "test3" open_constr(t) constr(r):=
+  pose t.
+
+Goal True.
+  test1 (1 + _) nat.
+  test2 nat (1 + _).
+  test3 (1 + _) nat.
+  test3 (1 + _ : nat) nat.
+
diff --git a/test-suite/bugs/opened/3467.v b/test-suite/bugs/opened/3467.v
new file mode 100644
index 00000000..900bfc34
--- /dev/null
+++ b/test-suite/bugs/opened/3467.v
@@ -0,0 +1,6 @@
+Module foo.
+  Notation x := $(exact I)$.
+End foo.
+Module bar.
+  Fail Include foo.
+End bar.
diff --git a/test-suite/bugs/opened/3478.v-disabled b/test-suite/bugs/opened/3478.v-disabled
new file mode 100644
index 00000000..cc926b21
--- /dev/null
+++ b/test-suite/bugs/opened/3478.v-disabled
@@ -0,0 +1,8 @@
+Set Primitive Projections.
+Record foo := { foom :> Type }.
+Canonical Structure default_foo := fun T => {| foom := T |}.
+Record bar T := { bar1 : T }.
+Goal forall (s : foo) (x : foom s), True.
+Proof.
+  intros.
+  Timeout 1 pose (x : bar _) as x'.
\ No newline at end of file
diff --git a/test-suite/bugs/opened/3490.v b/test-suite/bugs/opened/3490.v
new file mode 100644
index 00000000..e7a5caa1
--- /dev/null
+++ b/test-suite/bugs/opened/3490.v
@@ -0,0 +1,27 @@
+Inductive T : Type :=                                                                                        
+| Var : nat -> T                                                                                                 
+| Arr : T -> T -> T.                                                                                             
+
+Inductive Tele : list T -> Type :=                                                                               
+| Tnil  : @Tele nil                                                                                              
+| Tcons : forall ls, forall (t : @Tele ls) (l : T), @Tele (l :: ls). 
+
+Fail Fixpoint TeleD (ls : list T) (t : Tele ls) {struct t}
+   : { x : Type & x -> nat -> Type } :=
+     match t return { x : Type & x -> nat -> Type } with
+       | Tnil => @existT Type (fun x => x -> nat -> Type) unit (fun (_ : unit) (_ : nat) => unit)
+       | Tcons ls t' l =>
+         let (result, get) := TeleD ls t' in
+         @existT Type (fun x => x -> nat -> Type)
+                 { v : result & (fix TD (t : T) {struct t} :=
+                                   match  t with
+                                     | Var n =>
+                                       get v n
+                                     | Arr a b => TD a -> TD b
+                                   end) l }
+                 (fun x n =>
+                    match n return Type with
+                      | 0 => projT2 x
+                      | S n => get (projT1 x) n
+                    end)
+     end.
diff --git a/test-suite/bugs/opened/3491.v b/test-suite/bugs/opened/3491.v
new file mode 100644
index 00000000..9837b0ec
--- /dev/null
+++ b/test-suite/bugs/opened/3491.v
@@ -0,0 +1,2 @@
+Fail Inductive list (A : Type) (T := A) : Type :=
+    nil : list A | cons : T -> list T -> list A.
diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v
new file mode 100644
index 00000000..02e47a8b
--- /dev/null
+++ b/test-suite/bugs/opened/3509.v
@@ -0,0 +1,18 @@
+Lemma match_bool_fn b A B xT xF
+: match b as b return forall x : A, B b x with
+    | true => xT
+    | false => xF
+  end
+  = fun x : A => match b as b return B b x with
+                   | true => xT x
+                   | false => xF x
+                 end.
+admit.
+Defined.
+Lemma match_bool_comm_1 (b : bool) A B (F : forall x : A, B x) t f
+: (if b as b return B (if b then t else f) then F t else F f)
+  = F (if b then t else f).
+admit.
+Defined.
+Hint Rewrite match_bool_fn : matchdb.
+Fail Hint Rewrite match_bool_comm_1 : matchdb.
diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v
new file mode 100644
index 00000000..25285636
--- /dev/null
+++ b/test-suite/bugs/opened/3510.v
@@ -0,0 +1,34 @@
+Lemma match_option_fn T (b : option T) A B s n
+: match b as b return forall x : A, B b x with
+    | Some k => s k
+    | None => n
+  end
+  = fun x : A => match b as b return B b x with
+                   | Some k => s k x
+                   | None => n x
+                 end.
+admit.
+Defined.
+Lemma match_option_comm_2 T (p : option T) A B R (f : forall (x : A) (y : B x), R x y) (s1 : T -> A) (s2 : forall x : T, B (s1 x)) n1 n2
+: match p as p return R match p with
+                          | Some k => s1 k
+                          | None => n1
+                        end
+                        match p as p return B match p with Some k => s1 k | None => n1 end with
+                          | Some k => s2 k
+                          | None => n2
+                        end with
+    | Some k => f (s1 k) (s2 k)
+    | None => f n1 n2
+  end
+  = f match p return A with
+        | Some k => s1 k
+        | None => n1
+      end
+      match p as p return B match p with Some k => s1 k | None => n1 end with
+        | Some k => s2 k
+        | None => n2
+      end.
+admit.
+Defined.
+Fail Hint Rewrite match_option_fn match_option_comm_2 : matchdb.
diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v
new file mode 100644
index 00000000..422c5770
--- /dev/null
+++ b/test-suite/bugs/opened/3554.v
@@ -0,0 +1 @@
+Fail Example foo (f : forall {_ : Type}, Type) : Type.
diff --git a/test-suite/bugs/opened/3562.v b/test-suite/bugs/opened/3562.v
new file mode 100644
index 00000000..04a1223b
--- /dev/null
+++ b/test-suite/bugs/opened/3562.v
@@ -0,0 +1,2 @@
+Theorem t: True.
+Fail destruct 0 as x.
diff --git a/test-suite/bugs/opened/3626.v b/test-suite/bugs/opened/3626.v
new file mode 100644
index 00000000..46a6c009
--- /dev/null
+++ b/test-suite/bugs/opened/3626.v
@@ -0,0 +1,7 @@
+Set Implicit Arguments.
+Set Primitive Projections.
+Record prod A B := pair { fst : A ; snd : B }.
+
+Fail Goal forall x y : prod Set Set, x.(@fst) = y.(@fst).
+(*  intros.
+    apply f_equal. *)
diff --git a/test-suite/bugs/opened/3655.v b/test-suite/bugs/opened/3655.v
new file mode 100644
index 00000000..841f77fe
--- /dev/null
+++ b/test-suite/bugs/opened/3655.v
@@ -0,0 +1,9 @@
+Ltac bar x := pose x.
+Tactic Notation "foo" open_constr(x) := bar x.
+Class baz := { baz' : Type }.
+Goal True.
+(* Original error was an anomaly which is fixed; now, it succeeds but
+   leaving an evar, while calling pose would not leave an evar, so I
+   guess it is still a bug in the sense that the semantics of pose is
+   not preserved *)
+  foo baz'.
diff --git a/test-suite/bugs/opened/3657.v b/test-suite/bugs/opened/3657.v
new file mode 100644
index 00000000..6faec076
--- /dev/null
+++ b/test-suite/bugs/opened/3657.v
@@ -0,0 +1,33 @@
+(* Set Primitive Projections. *)
+Class foo {A} {a : A} := { bar := a; baz : bar = bar }.
+Arguments bar {_} _ {_}.
+Instance: forall A a, @foo A a.
+intros; constructor.
+abstract reflexivity.
+Defined.
+Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat.
+Proof.
+  Check (bar Set).
+  Check (bar (fun _ : Set => Set)).
+  Fail change (bar (fun _ : Set => Set)) with (bar Set). (* Error: Conversion test raised an anomaly *)
+
+Abort.
+
+
+Module A.
+Universes i j.
+Constraint i < j.
+Variable  foo : Type@{i}.
+Goal Type@{i}.
+  Fail let t := constr:(Type@{j}) in
+  change Type with t.
+Abort.
+
+Goal Type@{j}.
+  Fail let t := constr:(Type@{i}) in
+  change Type with t.
+  let t := constr:(Type@{i}) in
+  change t. exact foo.
+Defined.
+
+End A.
diff --git a/test-suite/bugs/opened/3670.v b/test-suite/bugs/opened/3670.v
new file mode 100644
index 00000000..cf5e9b09
--- /dev/null
+++ b/test-suite/bugs/opened/3670.v
@@ -0,0 +1,19 @@
+Module Type FOO.
+  Parameters P Q : Type -> Type.
+End FOO.
+
+Module Type BAR.
+  Declare Module Export foo : FOO.
+  Parameter f : forall A, P A -> Q A -> A.
+End BAR.
+
+Module Type BAZ.
+  Declare Module Export foo : FOO.
+  Parameter g : forall A, P A -> Q A -> A.
+End BAZ.
+
+Module BAR_FROM_BAZ (baz : BAZ) : BAR.
+  Import baz.
+  Module foo <: FOO := foo.
+  Definition f : forall A, P A -> Q A -> A := g.
+End BAR_FROM_BAZ.
diff --git a/test-suite/bugs/opened/3675.v b/test-suite/bugs/opened/3675.v
new file mode 100644
index 00000000..93227ab8
--- /dev/null
+++ b/test-suite/bugs/opened/3675.v
@@ -0,0 +1,20 @@
+Set Primitive Projections.
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
+Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
+Arguments idpath {A a} , [A] a.
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
+Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }.
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+Local Open Scope path_scope.
+Local Open Scope equiv_scope.
+Generalizable Variables A B C f g.
+Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
+: IsEquiv (compose g f).
+Proof.
+  refine (Build_IsEquiv A C
+                        (compose g f)
+                        (compose f^-1 g^-1) _).
+  exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)).
diff --git a/test-suite/bugs/opened/3681.v b/test-suite/bugs/opened/3681.v
new file mode 100644
index 00000000..194113c6
--- /dev/null
+++ b/test-suite/bugs/opened/3681.v
@@ -0,0 +1,20 @@
+Module Type FOO.
+  Parameters P Q : Type -> Type.
+End FOO.
+
+Module Type BAR.
+  Declare Module Import foo : FOO.
+  Parameter f : forall A, P A -> Q A -> A.
+End BAR.
+
+Module Type BAZ.
+  Declare Module Export foo : FOO.
+  Parameter g : forall A, P A -> Q A -> A.
+End BAZ.
+
+Module BAR_FROM_BAZ (baz : BAZ) : BAR.
+  Import baz.
+  Module foo <: FOO := foo.
+  Import foo.
+  Definition f : forall A, P A -> Q A -> A := g.
+End BAR_FROM_BAZ.
diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/opened/3685.v
new file mode 100644
index 00000000..d647b5a8
--- /dev/null
+++ b/test-suite/bugs/opened/3685.v
@@ -0,0 +1,74 @@
+Set Universe Polymorphism.
+Class Funext := { }.
+Delimit Scope category_scope with category.
+Record PreCategory := { object :> Type ; morphism : object -> object -> Type }.
+Set Implicit Arguments.
+Record Functor (C D : PreCategory) :=
+  { object_of :> C -> D;
+    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d);
+    identity_of : forall s m, morphism_of s s m = morphism_of s s m }.
+Definition sub_pre_cat `{Funext} (P : PreCategory -> Type) : PreCategory.
+Proof.
+  exact (@Build_PreCategory PreCategory Functor).
+Defined.
+Definition opposite (C : PreCategory) : PreCategory.
+Proof.
+  exact (@Build_PreCategory C (fun s d => morphism C d s)).
+Defined.
+Local Notation "C ^op" := (opposite C) (at level 3, format "C '^op'") : category_scope.
+Definition prod (C D : PreCategory) : PreCategory.
+Proof.
+  refine (@Build_PreCategory
+            (C * D)%type
+            (fun s d => (morphism C (fst s) (fst d) * morphism D (snd s) (snd d))%type)).
+Defined.
+Local Infix "*" := prod : category_scope.
+Record NaturalTransformation C D (F G : Functor C D) := {}.
+Definition functor_category (C D : PreCategory) : PreCategory.
+Proof.
+  exact (@Build_PreCategory (Functor C D) (@NaturalTransformation C D)).
+Defined.
+Local Notation "C -> D" := (functor_category C D) : category_scope.
+Module Export PointwiseCore.
+  Local Open Scope category_scope.
+  Definition pointwise
+             (C C' : PreCategory)
+             (F : Functor C' C)
+             (D D' : PreCategory)
+             (G : Functor D D')
+  : Functor (C -> D) (C' -> D').
+  Proof.
+    refine (Build_Functor
+              (C -> D) (C' -> D')
+              _
+              _
+              _);
+    abstract admit.
+  Defined.
+End PointwiseCore.
+Axiom Pidentity_of : forall (C D : PreCategory) (F : Functor C C) (G : Functor D D), pointwise F G = pointwise F G.
+Local Open Scope category_scope.
+Module Success.
+  Definition functor_uncurried `{Funext} (P : PreCategory -> Type)
+             (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D))
+  : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P))
+    := Eval cbv zeta in
+        let object_of := (fun CD => (((fst CD) -> (snd CD))))
+        in Build_Functor
+             ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P)
+             object_of
+             (fun CD C'D' FG => pointwise (fst FG) (snd FG))
+             (fun _ _ => @Pidentity_of _ _ _ _).
+End Success.
+Module Bad.
+  Include PointwiseCore.
+  Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type)
+             (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D))
+  : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P))
+    := Eval cbv zeta in
+        let object_of := (fun CD => (((fst CD) -> (snd CD))))
+        in Build_Functor
+             ((sub_pre_cat P)^op * (sub_pre_cat P)) (sub_pre_cat P)
+             object_of
+             (fun CD C'D' FG => pointwise (fst FG) (snd FG))
+             (fun _ _ => @Pidentity_of _ _ _ _).
diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/opened/3753.v
new file mode 100644
index 00000000..05d77c83
--- /dev/null
+++ b/test-suite/bugs/opened/3753.v
@@ -0,0 +1,4 @@
+Axiom foo : Type -> Type.
+Axiom bar : forall (T : Type), T -> foo T.
+Arguments bar A x : rename.
+Fail About bar.
diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v
new file mode 100644
index 00000000..c7441882
--- /dev/null
+++ b/test-suite/bugs/opened/3754.v
@@ -0,0 +1,282 @@
+(* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *)
+(* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1
+   coqtop version trunk (October 2014) *)
+
+Notation Type0 := Set.
+
+Notation idmap := (fun x => x).
+
+Notation "( x ; y )" := (existT _ x y) : fibration_scope.
+Open Scope fibration_scope.
+
+Notation pr1 := projT1.
+
+Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope.
+
+Definition compose {A B C : Type} (g : B -> C) (f : A -> B) :=
+  fun x => g (f x).
+
+Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
+Open Scope function_scope.
+
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+
+Arguments idpath {A a} , [A] a.
+
+Notation "x = y :> A" := (@paths A x y) : type_scope.
+Notation "x = y" := (x = y :>_) : type_scope.
+Definition inverse {A : Type} {x y : A} (p : x = y) : y = x.
+admit.
+Defined.
+
+Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z :=
+  match p, q with idpath, idpath => idpath end.
+
+Notation "1" := idpath : path_scope.
+
+Notation "p @ q" := (concat p q) (at level 20) : path_scope.
+
+Notation "p ^" := (inverse p) (at level 3, format "p '^'") : path_scope.
+
+Notation "p @' q" := (concat p q) (at level 21, left associativity,
+  format "'[v' p '/' '@''  q ']'") : long_path_scope.
+Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y.
+exact (match p with idpath => u end).
+Defined.
+
+Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.
+Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y.
+exact (match p with idpath => idpath end).
+Defined.
+
+Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
+  := forall x:A, f x = g x.
+
+Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
+
+Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
+  forall x : A, r (s x) = x.
+
+Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
+  equiv_inv : B -> A ;
+  eisretr : Sect equiv_inv f;
+  eissect : Sect f equiv_inv;
+  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
+}.
+
+Arguments eisretr {A B} f {_} _.
+
+Record Equiv A B := BuildEquiv {
+  equiv_fun : A -> B ;
+  equiv_isequiv : IsEquiv equiv_fun
+}.
+
+Coercion equiv_fun : Equiv >-> Funclass.
+
+Global Existing Instance equiv_isequiv.
+
+Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
+
+Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
+
+Class Contr_internal (A : Type) := BuildContr {
+  center : A ;
+  contr : (forall y : A, center = y)
+}.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
+Local Open Scope trunc_scope.
+Notation "-2" := minus_two (at level 0) : trunc_scope.
+Notation "-1" := (-2.+1) (at level 0) : trunc_scope.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | -2 => Contr_internal A
+    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type :=
+  Trunc_is_trunc : IsTrunc_internal n A.
+Notation IsHProp := (IsTrunc -1).
+
+Monomorphic Axiom dummy_funext_type : Type0.
+Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.
+
+Local Open Scope path_scope.
+
+Definition concat_p1 {A : Type} {x y : A} (p : x = y) :
+  p @ 1 = p
+  :=
+  match p with idpath => 1 end.
+
+Definition concat_1p {A : Type} {x y : A} (p : x = y) :
+  1 @ p = p
+  :=
+  match p with idpath => 1 end.
+
+Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
+  p @ (q @ r) = (p @ q) @ r :=
+  match r with idpath =>
+    match q with idpath =>
+      match p with idpath => 1
+      end end end.
+
+Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) :
+  (p @ q) @ r = p @ (q @ r) :=
+  match r with idpath =>
+    match q with idpath =>
+      match p with idpath => 1
+      end end end.
+
+Definition moveL_Mp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : y = x) :
+  r^ @ q = p -> q = r @ p.
+admit.
+Defined.
+
+Ltac with_rassoc tac :=
+  repeat rewrite concat_pp_p;
+  tac;
+
+  repeat rewrite concat_p_pp.
+
+Ltac rewrite_moveL_Mp_p := with_rassoc ltac:(apply moveL_Mp).
+
+Definition ap_p_pp {A B : Type} (f : A -> B) {w : B} {x y z : A}
+  (r : w = f x) (p : x = y) (q : y = z) :
+  r @ (ap f (p @ q)) = (r @ ap f p) @ (ap f q).
+admit.
+Defined.
+
+Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
+  ap (g o f) p = ap g (ap f p)
+  :=
+  match p with idpath => 1 end.
+
+Definition concat_Ap {A B : Type} {f g : A -> B} (p : forall x, f x = g x) {x y : A} (q : x = y) :
+  (ap f q) @ (p y) = (p x) @ (ap g q)
+  :=
+  match q with
+    | idpath => concat_1p _ @ ((concat_p1 _) ^)
+  end.
+
+Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a -> Type)
+  {x1 x2 : A} (p : x1 = x2) (y : B x1) (z : C x1) (w : D x1 y z)
+  : D x2 (p # y) (p # z)
+  :=
+  match p with idpath => w end.
+Local Open Scope equiv_scope.
+
+Definition transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type}
+  {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) (y : B x2)
+  : (transport (fun x => B x -> C) p f) y  =  f (p^ # y).
+admit.
+Defined.
+
+Definition transport_arrow_fromconst {A B : Type} {C : A -> Type}
+  {x1 x2 : A} (p : x1 = x2) (f : B -> C x1) (y : B)
+  : (transport (fun x => B -> C x) p f) y  =  p # (f y).
+admit.
+Defined.
+
+Definition ap_transport_arrow_toconst {A : Type} {B : A -> Type} {C : Type}
+  {x1 x2 : A} (p : x1 = x2) (f : B x1 -> C) {y1 y2 : B x2} (q : y1 = y2)
+  : ap (transport (fun x => B x -> C) p f) q
+    @ transport_arrow_toconst p f y2
+    = transport_arrow_toconst p f y1
+    @ ap (fun y => f (p^ # y)) q.
+admit.
+Defined.
+
+Class Univalence.
+Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B).
+admit.
+Defined.
+Definition transport_path_universe
+           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
+  : transport (fun X:Type => X) (path_universe f) z = f z.
+admit.
+Defined.
+Definition transport_path_universe_V `{Funext}
+           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B)
+  : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z.
+admit.
+Defined.
+
+Ltac simpl_do_clear tac term :=
+  let H := fresh in
+  assert (H := term);
+    simpl in H |- *;
+    tac H;
+    clear H.
+
+Tactic Notation "simpl" "rewrite"      constr(term) := simpl_do_clear ltac:(fun H => rewrite    H) term.
+
+Global Instance Univalence_implies_Funext `{Univalence} : Funext.
+Admitted.
+
+Section Factorization.
+
+  Context {class1 class2 : forall (X Y : Type@{i}), (X -> Y) -> Type@{i}}
+          `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class1 _ _ g)}
+          `{forall (X Y : Type@{i}) (g:X->Y), IsHProp (class2 _ _ g)}
+          {A B : Type@{i}} {f : A -> B}.
+
+  Record Factorization :=
+    { intermediate : Type ;
+      factor1 : A -> intermediate ;
+      factor2 : intermediate -> B ;
+      fact_factors : factor2 o factor1 == f ;
+      inclass1 : class1 _ _ factor1 ;
+      inclass2 : class2 _ _ factor2
+    }.
+
+  Record PathFactorization {fact fact' : Factorization} :=
+    { path_intermediate : intermediate fact <~> intermediate fact' ;
+      path_factor1 : path_intermediate o factor1 fact == factor1 fact' ;
+      path_factor2 : factor2 fact == factor2 fact' o path_intermediate ;
+      path_fact_factors : forall a, path_factor2 (factor1 fact a)
+                          @ ap (factor2 fact') (path_factor1 a)
+                          @ fact_factors fact' a
+                          = fact_factors fact a
+    }.
+    Context `{Univalence} {fact fact' : Factorization}
+            (pf : @PathFactorization fact fact').
+
+    Let II := path_intermediate pf.
+    Let ff1 := path_factor1 pf.
+    Let ff2 := path_factor2 pf.
+Local Definition II' : intermediate fact = intermediate fact'.
+admit.
+Defined.
+
+    Local Definition fff' (a : A)
+    : (transportD2 (fun X => A -> X) (fun X => X -> B)
+                   (fun X g h => {_ : forall a : A, h (g a) = f a &
+                                  {_ : class1 A X g & class2 X B h}})
+                   II' (factor1 fact) (factor2 fact)
+                   (fact_factors fact; (inclass1 fact; inclass2 fact))).1 a =
+      ap (transport (fun X => X -> B) II' (factor2 fact))
+        (transport_arrow_fromconst II' (factor1 fact) a
+          @ transport_path_universe II (factor1 fact a)
+          @ ff1 a)
+        @ transport_arrow_toconst II' (factor2 fact) (factor1 fact' a)
+        @ ap (factor2 fact) (transport_path_universe_V II (factor1 fact' a))
+        @ ff2 (II^-1 (factor1 fact' a))
+        @ ap (factor2 fact') (eisretr II (factor1 fact' a))
+        @ fact_factors fact' a.
+    Proof.
+
+      Open Scope long_path_scope.
+
+      rewrite (ap_transport_arrow_toconst (B := idmap) (C := B)).
+
+      simpl rewrite (@ap_compose _ _ _ (transport idmap (path_universe II)^)
+                                 (factor2 fact)).
+      rewrite <- ap_p_pp; rewrite_moveL_Mp_p.
+      Set Debug Tactic Unification.
+      Fail rewrite (concat_Ap ff2).
diff --git a/test-suite/bugs/opened/3786.v b/test-suite/bugs/opened/3786.v
new file mode 100644
index 00000000..5a124115
--- /dev/null
+++ b/test-suite/bugs/opened/3786.v
@@ -0,0 +1,40 @@
+Require Coq.Lists.List.
+Require Coq.Sets.Ensembles.
+Import Coq.Sets.Ensembles.
+Global Set Implicit Arguments.
+Delimit Scope comp_scope with comp.
+Inductive Comp : Type -> Type :=
+| Return : forall A, A -> Comp A
+| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B
+| Pick : forall A, Ensemble A -> Comp A.
+Notation ret := Return.
+Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
+                           (at level 81, right associativity,
+                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.
+Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.
+Open Scope comp.
+Axiom elements : forall {A} (ls : list A), Ensemble A.
+Axiom to_list : forall {A} (S : Ensemble A), Comp (list A).
+Axiom finite_set_handle_cardinal : refine (ret 0) (ret 0).
+Definition sumUniqueSpec (ls : list nat) : Comp nat.
+  exact (ls' <- to_list (elements ls);
+         List.fold_right (fun a b' => Bind b' ((fun a b => ret (a + b)) a)) (ret 0) ls').
+Defined.
+Axiom admit : forall {T}, T.
+Definition sumUniqueImpl (ls : list nat)
+: { c : _ | refine (sumUniqueSpec ls) (ret c) }%type.
+Proof.
+  eexists.
+  match goal with
+    | [ |- refine ?a ?b ] => let a' := eval hnf in a in refine (_ : refine a' b)
+  end;
+  try setoid_rewrite (@finite_set_handle_cardinal).
+  Undo.
+  match goal with
+    | [ |- refine ?a ?b ] => let a' := eval hnf in a in change (refine a' b)
+  end.
+  try setoid_rewrite (@finite_set_handle_cardinal). (* Anomaly: Uncaught exception Invalid_argument("decomp_pointwise").
+Please report. *)
+  instantiate (1 := admit).
+  admit.
+Defined.
diff --git a/test-suite/bugs/opened/3788.v b/test-suite/bugs/opened/3788.v
new file mode 100644
index 00000000..8e605a00
--- /dev/null
+++ b/test-suite/bugs/opened/3788.v
@@ -0,0 +1,5 @@
+Set Implicit Arguments.
+Global Set Primitive Projections.
+Record Functor (C D : Type) := { object_of :> forall _ : C, D }.
+Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G.
+Fail Lemma path_functor_uncurried_snd C D F G HO HM : (@path_functor_uncurried C D F G (existT _ HO HM)) = HM.
diff --git a/test-suite/bugs/opened/3808.v b/test-suite/bugs/opened/3808.v
new file mode 100644
index 00000000..df40ca19
--- /dev/null
+++ b/test-suite/bugs/opened/3808.v
@@ -0,0 +1,2 @@
+Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i})
+  := foo : Foo.
diff --git a/test-suite/bugs/opened/3819.v b/test-suite/bugs/opened/3819.v
new file mode 100644
index 00000000..7105a658
--- /dev/null
+++ b/test-suite/bugs/opened/3819.v
@@ -0,0 +1,11 @@
+Set Universe Polymorphism.
+
+Record Op := { t : Type ; op : t -> t }.
+
+Canonical Structure OpType : Op := Build_Op Type (fun X => X).
+
+Lemma test1 (X:Type) : eq (op OpType X)  X.
+Proof eq_refl.
+
+Lemma test2 (A:Type) : eq (op _ A)  A.
+Fail Proof eq_refl.
diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/opened/3849.v
new file mode 100644
index 00000000..5290054a
--- /dev/null
+++ b/test-suite/bugs/opened/3849.v
@@ -0,0 +1,8 @@
+Tactic Notation "foo" hyp_list(hs) := clear hs.
+
+Tactic Notation "bar" hyp_list(hs) := foo hs.
+
+Goal True.
+do 5 pose proof 0 as ?n0.
+foo n1 n2.
+Fail bar n3 n4.
diff --git a/test-suite/bugs/opened/shouldnotfail/743.v b/test-suite/bugs/opened/743.v
index f1eee6c1..28257014 100644
--- a/test-suite/bugs/opened/shouldnotfail/743.v
+++ b/test-suite/bugs/opened/743.v
@@ -7,6 +7,6 @@ Qed.
 
 Lemma foo' : forall n m : nat, n <=  n + n * m.
 Proof.
-  intros. omega.
-Qed.
+  intros. Fail omega.
+Abort.
 
diff --git a/test-suite/bugs/opened/HoTT_coq_106.v b/test-suite/bugs/opened/HoTT_coq_106.v
new file mode 100644
index 00000000..a5664595
--- /dev/null
+++ b/test-suite/bugs/opened/HoTT_coq_106.v
@@ -0,0 +1,52 @@
+(* File reduced by coq-bug-finder from 520 lines to 9 lines. *)
+Set Universe Polymorphism.
+Class IsPointed (A : Type) := point : A.
+
+Generalizable Variables A B f.
+
+Instance ispointed_forall `{H : forall a : A, IsPointed (B a)}
+: IsPointed (forall a, B a)
+  := fun a => @point (B a) (H a).
+
+Instance ispointed_sigma `{IsPointed A} `{IsPointed (B (point A))}
+: IsPointed (sigT B).
+(* Message was at some time:
+Toplevel input, characters 20-108:
+Error: Unable to satisfy the following constraints:
+UNDEFINED EVARS:
+ ?8==[A H B |- IsPointed (forall x : Type, ?13)] (parameter IsPointed of
+       @point)
+ ?12==[A H {B} x |- Type] (parameter A of @point)
+ ?13==[A H {B} x |- Type] (parameter A of @point)
+ ?15==[A H {B} x |- Type] (parameter A of @point)UNIVERSES:
+ {Top.38 Top.30 Top.39 Top.40 Top.29 Top.36 Top.31 Top.35 Top.37 Top.34 Top.32 Top.33} |= Top.30 < Top.29
+                                                  Top.30 < Top.36
+                                                  Top.32 < Top.34
+                                                  Top.38 <= Top.37
+                                                  Top.38 <= Top.33
+                                                  Top.40 <= Top.38
+                                                  Top.40 <= Coq.Init.Specif.7
+                                                  Top.40 <= Top.39
+                                                  Top.36 <= Top.35
+                                                  Top.37 <= Top.35
+                                                  Top.34 <= Top.31
+                                                  Top.32 <= Top.39
+                                                  Top.32 <= Coq.Init.Specif.8
+                                                  Top.33 <= Top.31
+
+ALGEBRAIC UNIVERSES:
+ {Top.38 Top.40 Top.29 Top.36 Top.31 Top.37 Top.34 Top.33}
+UNDEFINED UNIVERSES:
+ Top.38
+ Top.30
+ Top.39
+ Top.40
+ Top.29
+ Top.36
+ Top.31
+ Top.35
+ Top.37
+ Top.34
+ Top.32
+ Top.33CONSTRAINTS:[] [A H B] |- ?13 == ?12
+[] [A H B H0] |- ?12 == ?15 *)
diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/opened/HoTT_coq_120.v
new file mode 100644
index 00000000..7847c5e4
--- /dev/null
+++ b/test-suite/bugs/opened/HoTT_coq_120.v
@@ -0,0 +1,136 @@
+(* File reduced by coq-bug-finder from original input, then from 8249 lines to 907 lines, then from 843 lines to 357 lines, then from 351 lines to 260 lines, then from 208 lines to 162 lines, then from 167 lines to 154 lines *)
+Set Universe Polymorphism.
+Generalizable All Variables.
+Reserved Notation "g 'o' f" (at level 40, left associativity).
+Inductive paths {A : Type} (a : A) : A -> Type :=
+  idpath : paths a a.
+Arguments idpath {A a} , [A] a.
+Notation "x = y" := (@paths _ x y) : type_scope.
+
+Class IsEquiv {A B : Type} (f : A -> B) := {}.
+
+Class Contr_internal (A : Type) := BuildContr {
+                                       center : A ;
+                                       contr : (forall y : A, center = y)
+                                     }.
+
+Inductive trunc_index : Type :=
+| minus_two : trunc_index
+| trunc_S : trunc_index -> trunc_index.
+
+Fixpoint nat_to_trunc_index (n : nat) : trunc_index
+  := match n with
+       | 0 => trunc_S (trunc_S minus_two)
+       | S n' => trunc_S (nat_to_trunc_index n')
+     end.
+
+Coercion nat_to_trunc_index : nat >-> trunc_index.
+
+Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
+  match n with
+    | minus_two => Contr_internal A
+    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
+  end.
+
+Notation minus_one:=(trunc_S minus_two).
+
+Class IsTrunc (n : trunc_index) (A : Type) : Type := Trunc_is_trunc : IsTrunc_internal n A.
+
+Notation Contr := (IsTrunc minus_two).
+Notation IsHProp := (IsTrunc minus_one).
+Notation IsHSet := (IsTrunc 0).
+
+Class Funext := {}.
+Inductive Unit : Set := tt.
+
+Instance contr_unit : Contr Unit | 0 := let x := {|
+                                              center := tt;
+                                              contr := fun t : Unit => match t with tt => idpath end
+                                            |} in x.
+Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000.
+admit.
+Defined.
+Record hProp := hp { hproptype :> Type ; isp : IsHProp hproptype}.
+Definition Unit_hp:hProp:=(hp Unit _).
+Record hSet := BuildhSet {setT:> Type; iss :> IsHSet setT}.
+Canonical Structure default_HSet:= fun T P => (@BuildhSet T P).
+Definition ismono {X Y} (f : X -> Y)
+  := forall Z : hSet,
+     forall g h : Z -> X, (fun x => f (g x)) = (fun x => f (h x)) -> g = h.
+
+Delimit Scope morphism_scope with morphism.
+Delimit Scope category_scope with category.
+Delimit Scope object_scope with object.
+Record PreCategory :=
+  Build_PreCategory {
+      object :> Type;
+      morphism : object -> object -> Type;
+      compose : forall s d d', morphism d d' -> morphism s d -> morphism s d'
+    }.
+Arguments compose [!C s d d'] m1 m2 : rename.
+
+Infix "o" := compose : morphism_scope.
+Local Open Scope morphism_scope.
+
+Class IsEpimorphism {C} {x y} (m : morphism C x y) :=
+  is_epimorphism : forall z (m1 m2 : morphism C y z),
+                     m1 o m = m2 o m
+                     -> m1 = m2.
+
+Class IsMonomorphism {C} {x y} (m : morphism C x y) :=
+  is_monomorphism : forall z (m1 m2 : morphism C z x),
+                      m o m1 = m o m2
+                      -> m1 = m2.
+Class Univalence := {}.
+Global Instance isset_hProp `{Funext} : IsHSet hProp | 0. Admitted.
+
+Definition set_cat : PreCategory
+  := @Build_PreCategory hSet
+                        (fun x y => forall _ : x, y)%core
+                        (fun _ _ _ f g x => f (g x))%core.
+Local Inductive minus1Trunc (A :Type) : Type := min1 : A -> minus1Trunc A.
+Instance minus1Trunc_is_prop {A : Type} : IsHProp (minus1Trunc A) | 0. Admitted.
+Definition hexists {X} (P:X->Type):Type:= minus1Trunc (sigT  P).
+Definition isepi {X Y} `(f:X->Y) := forall Z: hSet,
+                                    forall g h: Y -> Z, (fun x => g (f x)) = (fun x => h (f x)) -> g = h.
+Definition issurj {X Y} (f:X->Y) := forall y:Y , hexists (fun x => (f x) = y).
+Lemma isepi_issurj `{fs:Funext} `{ua:Univalence} `{fs' : Funext} {X Y} (f:X->Y): isepi f -> issurj f.
+Proof.
+  intros epif y.
+  set (g :=fun _:Y => Unit_hp).
+  set (h:=(fun y:Y => (hp (hexists (fun _ : Unit => {x:X & y = (f x)})) _ ))).
+  clear fs'.
+  hnf in epif.
+  specialize (epif (BuildhSet hProp _) g h).
+  admit.
+Defined.
+Definition isequiv_isepi_ismono `{Univalence, fs0 : Funext} (X Y : hSet) (f : X -> Y) (epif : isepi f) (monof : ismono f)
+: IsEquiv f.
+Proof.
+  pose proof (@isepi_issurj _ _ _ _ _ f epif) as surjf.
+  admit.
+Defined.
+Section fully_faithful_helpers.
+  Context `{fs0 : Funext}.
+  Variables x y : hSet.
+  Variable m : x -> y.
+
+  Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m).
+
+  Goal True.
+  Fail set (isequiv_isepimorphism_ismonomorphism
+       := fun `{Univalence}
+              (Hepi : IsEpimorphism (m : morphism set_cat x y))
+              (Hmono : IsMonomorphism (m : morphism set_cat x y))
+          => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)).
+  admit.
+  Undo.
+  Fail set (isequiv_isepimorphism_ismonomorphism'
+       := fun `{Univalence}
+              (Hepi : IsEpimorphism (m : morphism set_cat x y))
+              (Hmono : IsMonomorphism (m : morphism set_cat x y))
+          => ((let _ := @isequiv_isepimorphism_ismonomorphism _ Hepi Hmono in @isequiv_isepi_ismono _ fs0 x y m Hepi Hmono)
+              : @IsEquiv _ _ m)).
+  Set Printing Universes.
+  admit. (* Error: Universe inconsistency (cannot enforce Top.235 <= Set because Set
+< Top.235). *)
diff --git a/test-suite/check b/test-suite/check
index 48a67449..3d14f6bc 100755
--- a/test-suite/check
+++ b/test-suite/check
@@ -2,10 +2,6 @@
 
 MAKE="${MAKE:=make}"
 
-if [ "$1" = -byte ]; then
-  export BEST=byte
-fi
-
 ${MAKE} clean > /dev/null 2>&1
 ${MAKE} all > /dev/null 2>&1
 cat summary.log
diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v
index 335996c2..08f489d7 100644
--- a/test-suite/complexity/injection.v
+++ b/test-suite/complexity/injection.v
@@ -72,14 +72,14 @@ Definition own_join (a b c: own) : Prop :=
  match a , b , c with
   | NO , _ , _ =>  b=c
   | _ , NO , _ =>  a=c
-  | VAL' sa _ , VAL' sb _, VAL' sc _ => Share.j.(join) sa sb sc
-  | LK sa pa ha fa, LK sb pb hb fb, LK sc pc hc fc =>
+  | @VAL' sa _, @VAL' sb _, @VAL' sc _ => Share.j.(join) sa sb sc
+  | @LK sa pa ha fa, @LK sb pb hb fb, @LK sc pc hc fc =>
       Share.j.(join) sa sb sc /\
       Share.j.(join) ha hb hc /\
       fa=fc /\
       fb=fc
-  | CT sa pa , CT sb pb, CT sc pc => Share.j.(join) sa sb sc
-  | FUN sa pa fa, FUN sb pb fb, FUN sc pc fc =>
+  | @CT sa pa , @CT sb pb, @CT sc pc => Share.j.(join) sa sb sc
+  | @FUN sa pa fa, @FUN sb pb fb, @FUN sc pc fc =>
         Share.j.(join) sa sb sc /\ fa=fc /\ fb=fc
   | _ , _ , _ => False
  end.
diff --git a/test-suite/coqchk/univ.v b/test-suite/coqchk/univ.v
new file mode 100644
index 00000000..84a4009d
--- /dev/null
+++ b/test-suite/coqchk/univ.v
@@ -0,0 +1,35 @@
+
+Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P).
+
+Inductive equal T (x : T) : T -> Type := Equal : equal T x x.
+
+(* Arithmetic *)
+
+Inductive natural := Zero | Add_1_to (n : natural).
+
+Fixpoint add (m n : natural) : natural :=
+  match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end.
+
+Definition double (n : natural) : natural := add n n.
+
+Inductive odd (n : natural) :=
+  Odd (half : natural)
+    (n_odd : equal natural n (Add_1_to (double half))).
+
+Inductive less_than (m n : natural) :=
+  LessThan (diff : natural)
+    (m_lt_n : equal natural n (Add_1_to (add m diff))).
+
+(* Finite subsets *)
+
+Definition injective_in T R (D : T -> Type) (f : T -> R) :=
+  forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y.
+
+Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) :=
+  InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)).
+
+Inductive finite_of_order T (D : T -> Type) (n : natural) :=
+  FiniteOfOrder (rank : T -> natural)
+    (rank_injective : injective_in T natural D rank)
+    (rank_onto :
+       forall i, equivalent (less_than i n) (in_image T natural D rank i)).
diff --git a/test-suite/failure/Case1.v b/test-suite/failure/Case1.v
index df11ed38..6e76d42d 100644
--- a/test-suite/failure/Case1.v
+++ b/test-suite/failure/Case1.v
@@ -1,4 +1,4 @@
-Type match 0 with
+Fail Type match 0 with
      | x => 0
      | O => 1
      end.
diff --git a/test-suite/failure/Case10.v b/test-suite/failure/Case10.v
index 43cc1e34..661d98cd 100644
--- a/test-suite/failure/Case10.v
+++ b/test-suite/failure/Case10.v
@@ -1,3 +1,3 @@
-Type (fun x : nat => match x return nat with
+Fail Type (fun x : nat => match x return nat with
                      | S x as b => S b
                      end).
diff --git a/test-suite/failure/Case11.v b/test-suite/failure/Case11.v
index e76d0609..675f79e6 100644
--- a/test-suite/failure/Case11.v
+++ b/test-suite/failure/Case11.v
@@ -1,3 +1,3 @@
-Type (fun x : nat => match x return nat with
+Fail Type (fun x : nat => match x return nat with
                      | S x as b => S b x
                      end).
diff --git a/test-suite/failure/Case12.v b/test-suite/failure/Case12.v
index cf6c2026..4a77f139 100644
--- a/test-suite/failure/Case12.v
+++ b/test-suite/failure/Case12.v
@@ -1,5 +1,5 @@
 
-Type
+Fail Type
   (fun x : nat =>
    match x return nat with
    | S x as b => match x with
diff --git a/test-suite/failure/Case13.v b/test-suite/failure/Case13.v
index 994dfd20..5c0aa3e1 100644
--- a/test-suite/failure/Case13.v
+++ b/test-suite/failure/Case13.v
@@ -1,4 +1,4 @@
-Type
+Fail Type
   (fun x : nat =>
    match x return nat with
    | S x as b => match x with
diff --git a/test-suite/failure/Case14.v b/test-suite/failure/Case14.v
index ba0c51a1..29cae764 100644
--- a/test-suite/failure/Case14.v
+++ b/test-suite/failure/Case14.v
@@ -3,7 +3,7 @@ Inductive List (A : Set) : Set :=
   | Cons : A -> List A -> List A.
 
 Definition NIL := Nil nat.
-Type match Nil nat return (List nat) with
+Fail Type match Nil nat return (List nat) with
      | NIL => NIL
      | _ => NIL
      end.
diff --git a/test-suite/failure/Case15.v b/test-suite/failure/Case15.v
index 18faaf5c..ec08e614 100644
--- a/test-suite/failure/Case15.v
+++ b/test-suite/failure/Case15.v
@@ -1,6 +1,6 @@
 (* Non exhaustive pattern-matching *)
 
-Check
+Fail Check
   (fun x =>
    match x, x with
    | O, S (S y) => true
diff --git a/test-suite/failure/Case16.v b/test-suite/failure/Case16.v
index 3739adae..df15a428 100644
--- a/test-suite/failure/Case16.v
+++ b/test-suite/failure/Case16.v
@@ -1,6 +1,6 @@
 (* Check for redundant clauses *)
 
-Check
+Fail Check
   (fun x =>
    match x, x with
    | O, S (S y) => true
diff --git a/test-suite/failure/Case2.v b/test-suite/failure/Case2.v
index 7d81ee81..f8c95b1e 100644
--- a/test-suite/failure/Case2.v
+++ b/test-suite/failure/Case2.v
@@ -4,7 +4,7 @@ Inductive IFExpr : Set :=
   | Fa : IFExpr
   | IfE : IFExpr -> IFExpr -> IFExpr -> IFExpr.
 
-Type
+Fail Type
   (fun F : IFExpr =>
    match F return Prop with
    | IfE (Var _) H I => True
diff --git a/test-suite/failure/Case3.v b/test-suite/failure/Case3.v
index ca450d5b..eaafd41f 100644
--- a/test-suite/failure/Case3.v
+++ b/test-suite/failure/Case3.v
@@ -2,7 +2,7 @@ Inductive List (A : Set) : Set :=
   | Nil : List A
   | Cons : A -> List A -> List A.
 
-Type
+Fail Type
   (fun l : List nat =>
    match l return nat with
    | Nil nat => 0
diff --git a/test-suite/failure/Case4.v b/test-suite/failure/Case4.v
index de63c3f7..4da7ef0c 100644
--- a/test-suite/failure/Case4.v
+++ b/test-suite/failure/Case4.v
@@ -1,5 +1,5 @@
 
-Definition Berry (x y z : bool) :=
+Fail Definition Berry (x y z : bool) :=
   match x, y, z with
   | true, false, _ => 0
   | false, _, true => 1
diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v
index 494443f1..70e5b988 100644
--- a/test-suite/failure/Case5.v
+++ b/test-suite/failure/Case5.v
@@ -2,6 +2,6 @@ Inductive MS : Set :=
   | X : MS -> MS
   | Y : MS -> MS.
 
-Type (fun p : MS => match p return nat with
+Fail Type (fun p : MS => match p return nat with
                     | X x => 0
                     end).
diff --git a/test-suite/failure/Case6.v b/test-suite/failure/Case6.v
index fb8659bf..cb7b7de0 100644
--- a/test-suite/failure/Case6.v
+++ b/test-suite/failure/Case6.v
@@ -2,7 +2,7 @@ Inductive List (A : Set) : Set :=
   | Nil : List A
   | Cons : A -> List A -> List A.
 
-Type (match Nil nat return List nat with
+Fail Type (match Nil nat return List nat with
       | NIL   => NIL
       | (CONS _ _)  => NIL
       end).
diff --git a/test-suite/failure/Case7.v b/test-suite/failure/Case7.v
index 64453481..e1fd7df0 100644
--- a/test-suite/failure/Case7.v
+++ b/test-suite/failure/Case7.v
@@ -9,7 +9,7 @@ Definition length1 (n : nat) (l : listn n) :=
   | _ => 0
   end.
 
-Type
+Fail Type
   (fun (n : nat) (l : listn n) =>
    match n return nat with
    | O => 0
diff --git a/test-suite/failure/Case8.v b/test-suite/failure/Case8.v
index feae29a7..035629fe 100644
--- a/test-suite/failure/Case8.v
+++ b/test-suite/failure/Case8.v
@@ -2,7 +2,7 @@ Inductive List (A : Set) : Set :=
   | Nil : List A
   | Cons : A -> List A -> List A.
 
-Type match Nil nat return nat with
+Fail Type match Nil nat return nat with
      | b => b
      | Cons _ _ _ as d => d
      end.
diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v
index d63c4940..642f85d7 100644
--- a/test-suite/failure/Case9.v
+++ b/test-suite/failure/Case9.v
@@ -1,8 +1,8 @@
 Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}.
-Type
+Fail Type
   match compare 0 0 return nat with
 
-      (* k<i *) | left _ _ (left _ _ _) => 0
-   (* k=i *) | left _ _ _ => 0
-   (* k>i *) | right _ _ _ => 0
+      (* k<i *) | left _ (left _ _) => 0
+   (* k=i *) | left _ _ => 0
+   (* k>i *) | right _ _ => 0
   end.
diff --git a/test-suite/failure/ClearBody.v b/test-suite/failure/ClearBody.v
index 609d5b3b..e321e59f 100644
--- a/test-suite/failure/ClearBody.v
+++ b/test-suite/failure/ClearBody.v
@@ -5,4 +5,4 @@ Goal True.
 set (n := 0) in *.
 set (I := refl_equal 0) in *.
 change (n = 0) in (type of I).
-clearbody n.
+Fail clearbody n.
diff --git a/test-suite/failure/ImportedCoercion.v b/test-suite/failure/ImportedCoercion.v
index 0a69b851..1cac69f4 100644
--- a/test-suite/failure/ImportedCoercion.v
+++ b/test-suite/failure/ImportedCoercion.v
@@ -4,4 +4,4 @@ Require Import make_local.
 
 (* Local coercion must not be used *)
 
-Check (0 = true).
+Fail Check (0 = true).
diff --git a/test-suite/failure/Notations.v b/test-suite/failure/Notations.v
index 074e176a..83459de3 100644
--- a/test-suite/failure/Notations.v
+++ b/test-suite/failure/Notations.v
@@ -3,5 +3,5 @@
 Notation "! A" := (forall i:nat, A) (at level 60).
 
 (* Should fail: no dynamic capture *)
-Check ! (i=i).
+Fail Check ! (i=i).
 
diff --git a/test-suite/failure/Reordering.v b/test-suite/failure/Reordering.v
index 7b36d1c3..e79b2073 100644
--- a/test-suite/failure/Reordering.v
+++ b/test-suite/failure/Reordering.v
@@ -2,4 +2,4 @@
 
 Goal forall (A:Set) (x:A) (A':=A), True.
 intros.
-change ((fun (_:A') => Set) x) in (type of A).
+Fail change ((fun (_:A') => Set) x) in (type of A).
diff --git a/test-suite/failure/Sections.v b/test-suite/failure/Sections.v
index 9b3b35c1..928e214f 100644
--- a/test-suite/failure/Sections.v
+++ b/test-suite/failure/Sections.v
@@ -1,4 +1,4 @@
 Module A.
 Section	B.
-End A.
-End A.
+Fail End A.
+(*End A.*)
diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v
index 11b40951..749db000 100644
--- a/test-suite/failure/Tauto.v
+++ b/test-suite/failure/Tauto.v
@@ -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        *)
@@ -17,4 +17,4 @@
 (* Fails because Tauto does not perform any Apply *)
 Goal (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y.
 Proof.
-   tauto.
+   Fail tauto.
diff --git a/test-suite/failure/Uminus.v b/test-suite/failure/Uminus.v
index 3c3bf375..cc31c7ae 100644
--- a/test-suite/failure/Uminus.v
+++ b/test-suite/failure/Uminus.v
@@ -1,62 +1,21 @@
 (* Check that the encoding of system U- fails *)
 
-Inductive prop : Prop := down : Prop -> prop.
-
-Definition up (p:prop) : Prop := let (A) := p in A.
-
-Lemma p2p1 : forall A:Prop, up (down A) -> A.
-Proof.
-exact (fun A x => x).
-Qed.
+Require Hurkens.
 
-Lemma p2p2 : forall A:Prop, A -> up (down A).
-Proof.
-exact (fun A x => x).
-Qed.
-
-(** Hurkens' paradox *)
-
-Definition V := forall A:Prop, ((A -> prop) -> A -> prop) -> A -> prop.
-Definition U := V -> prop.
-Definition sb (z:V) : V := fun A r a => r (z A r) a.
-Definition le (i:U -> prop) (x:U) : prop :=
-  x (fun A r a => i (fun v => sb v A r a)).
-Definition induct (i:U -> prop) : Prop :=
-  forall x:U, up (le i x) -> up (i x).
-Definition WF : U := fun z => down (induct (z U le)).
-Definition I (x:U) : Prop :=
-  (forall i:U -> prop, up (le i x) -> up (i (fun v => sb v U le x))) -> False.
+Inductive prop : Prop := down : Prop -> prop.
 
-Lemma Omega : forall i:U -> prop, induct i -> up (i WF).
-Proof.
-intros i y.
-apply y.
-unfold le, WF, induct.
-intros x H0.
-apply y.
-exact H0.
-Qed.
+(* Coq should reject the following access of a Prop buried inside
+   a prop. *)
 
-Lemma lemma1 : induct (fun u => down (I u)).
-Proof.
-unfold induct.
-intros x p.
-intro q.
-apply (q (fun u => down (I u)) p).
-intro i.
-apply q with (i := fun y => i (fun v:V => sb v U le y)).
-Qed.
+Fail Definition up (p:prop) : Prop := let (A) := p in A.
 
-Lemma lemma2 : (forall i:U -> prop, induct i -> up (i WF)) -> False.
-Proof.
-intro x.
-apply (x (fun u => down (I u)) lemma1).
-intros i H0.
-apply (x (fun y => i (fun v => sb v U le y))).
-apply H0.
-Qed.
+(* Otherwise, we would have a proof of False via Hurkens' paradox *)
 
-Theorem paradox : False.
-Proof.
-exact (lemma2 Omega).
-Qed.
+Fail Definition paradox : False :=
+ Hurkens.NoRetractFromSmallPropositionToProp.paradox
+   prop
+   down
+   up
+   (fun (A:Prop) (x:up (down A)) => (x:A))
+   (fun (A:Prop) (x:A) => (x:up (down A)))
+   False.
diff --git a/test-suite/failure/autorewritein.v b/test-suite/failure/autorewritein.v
index dc17742a..191e035b 100644
--- a/test-suite/failure/autorewritein.v
+++ b/test-suite/failure/autorewritein.v
@@ -9,7 +9,7 @@ Hint Rewrite Ack0 Ack1 Ack2 : base0.
 Lemma ResAck2 : forall H:(Ack 2 2 = 7 -> False), H=H  -> False.
 Proof.
   intros.
-  autorewrite with base0 in * using try (apply H1;reflexivity).
+  Fail autorewrite with base0 in * using try (apply H1;reflexivity).
 
 
 
diff --git a/test-suite/failure/cases.v b/test-suite/failure/cases.v
index 18faaf5c..ec08e614 100644
--- a/test-suite/failure/cases.v
+++ b/test-suite/failure/cases.v
@@ -1,6 +1,6 @@
 (* Non exhaustive pattern-matching *)
 
-Check
+Fail Check
   (fun x =>
    match x, x with
    | O, S (S y) => true
diff --git a/test-suite/failure/check.v b/test-suite/failure/check.v
index 649fdd2d..a148ebe8 100644
--- a/test-suite/failure/check.v
+++ b/test-suite/failure/check.v
@@ -1,3 +1,3 @@
 Implicit Arguments eq [A].
 
-Check (bool = true).
+Fail Check (bool = true).
diff --git a/test-suite/failure/circular_subtyping1.v b/test-suite/failure/circular_subtyping.v
index 0b3a8688..ceccd460 100644
--- a/test-suite/failure/circular_subtyping1.v
+++ b/test-suite/failure/circular_subtyping.v
@@ -1,7 +1,10 @@
 (* subtyping verification in presence of  pseudo-circularity*)
 Module Type S. End S.
 Module Type T. Declare Module M:S. End T.
-
 Module N:S. End N.
 Module NN <: T. Module M:=N. End NN.
-Module P <: T with Module M:=NN := NN.
+
+Fail Module P <: T with Module M:=NN := NN.
+
+Module F (X:S) (Y:T with Module M:=X). End F.
+Fail Module G := F N N.
\ No newline at end of file
diff --git a/test-suite/failure/circular_subtyping2.v b/test-suite/failure/circular_subtyping2.v
deleted file mode 100644
index 3bacdc65..00000000
--- a/test-suite/failure/circular_subtyping2.v
+++ /dev/null
@@ -1,8 +0,0 @@
-(*subtyping verification in presence of  pseudo-circularity at functor application *)
-Module Type S. End S.
-Module Type T. Declare Module M:S. End T.
-Module N:S. End N.
-
-Module F (X:S) (Y:T with Module M:=X). End F.
-
-Module G := F N N.
\ No newline at end of file
diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v
index 17e56763..8e34ffbd 100644
--- a/test-suite/failure/clash_cons.v
+++ b/test-suite/failure/clash_cons.v
@@ -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        *)
@@ -11,5 +11,5 @@
 Inductive X : Set :=
     cons : X.
 
-Inductive Y : Set :=
+Fail Inductive Y : Set :=
     cons : Y.
diff --git a/test-suite/failure/clashes.v b/test-suite/failure/clashes.v
index 207d62b9..1a59ec66 100644
--- a/test-suite/failure/clashes.v
+++ b/test-suite/failure/clashes.v
@@ -5,5 +5,5 @@
 
 Section S.
 Variable n : nat.
-Inductive P : Set :=
+Fail Inductive P : Set :=
     n : P.
diff --git a/test-suite/failure/cofixpoint.v b/test-suite/failure/cofixpoint.v
new file mode 100644
index 00000000..cb39893f
--- /dev/null
+++ b/test-suite/failure/cofixpoint.v
@@ -0,0 +1,15 @@
+(* A bug in the guard checking of nested cofixpoints. *)
+(* Posted by Maxime Dénès on coqdev (Apr 9, 2014).    *)
+
+CoInductive CoFalse := .
+
+CoInductive CoTrue := I.
+
+Fail CoFixpoint loop : CoFalse :=
+  (cofix f := loop with g := loop for f).
+
+Fail CoFixpoint loop : CoFalse :=
+  (cofix f := I with g := loop for g).
+
+Fail CoFixpoint loop : CoFalse :=
+  (cofix f := loop with g := I for f).
\ No newline at end of file
diff --git a/test-suite/failure/coqbugs0266.v b/test-suite/failure/coqbugs0266.v
index 79eef5c9..cc3f307a 100644
--- a/test-suite/failure/coqbugs0266.v
+++ b/test-suite/failure/coqbugs0266.v
@@ -4,4 +4,4 @@ Section S.
 Let a := 0.
 Definition b := a.
 Goal b = b.
-clear a.
+Fail clear a.
diff --git a/test-suite/failure/evar1.v b/test-suite/failure/evar1.v
index 1a4e42a8..2b6fe765 100644
--- a/test-suite/failure/evar1.v
+++ b/test-suite/failure/evar1.v
@@ -1,3 +1,3 @@
 (* This used to succeed by producing an ill-typed term in v8.2 *)
 
-Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A).
+Fail Lemma u: forall A : Prop, (exist _ A A) = (exist _ A A).
diff --git a/test-suite/failure/evarclear1.v b/test-suite/failure/evarclear1.v
index 2e9fa0f3..60adadef 100644
--- a/test-suite/failure/evarclear1.v
+++ b/test-suite/failure/evarclear1.v
@@ -6,5 +6,5 @@ eexists.
 unfold z.
 clear y z.
 (* should fail because the evar should no longer be allowed to depend on z *)
-instantiate (1:=z).
+Fail instantiate (1:=z).
 
diff --git a/test-suite/failure/evarclear2.v b/test-suite/failure/evarclear2.v
index e606a06f..0f776811 100644
--- a/test-suite/failure/evarclear2.v
+++ b/test-suite/failure/evarclear2.v
@@ -6,4 +6,4 @@ eexists.
 rename y into z.
 unfold z at 1 2.
 (* should fail because the evar type depends on z *)
-clear z.
+Fail clear z.
diff --git a/test-suite/failure/evarlemma.v b/test-suite/failure/evarlemma.v
index ea753e79..ae40774c 100644
--- a/test-suite/failure/evarlemma.v
+++ b/test-suite/failure/evarlemma.v
@@ -1,3 +1,3 @@
 (* Check success of inference of evars in the context of lemmas *)
 
-Lemma foo x : True.
+Fail Lemma foo x : True.
diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v
index bea21f33..7b52316e 100644
--- a/test-suite/failure/fixpoint1.v
+++ b/test-suite/failure/fixpoint1.v
@@ -1,10 +1,10 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
-Fixpoint PreParadox (u : unit) : False := PreParadox u.
-Definition Paradox := PreParadox tt.
+Fail Fixpoint PreParadox (u : unit) : False := PreParadox u.
+(*Definition Paradox := PreParadox tt.*)
 
diff --git a/test-suite/failure/fixpoint2.v b/test-suite/failure/fixpoint2.v
index d2f02ea1..7f11a99b 100644
--- a/test-suite/failure/fixpoint2.v
+++ b/test-suite/failure/fixpoint2.v
@@ -3,4 +3,4 @@
 Goal nat->nat.
 fix f 1.
 intro n; apply f; assumption.
-Guarded.
+Fail Guarded.
diff --git a/test-suite/failure/fixpoint3.v b/test-suite/failure/fixpoint3.v
index 42f06916..7d1d3ee6 100644
--- a/test-suite/failure/fixpoint3.v
+++ b/test-suite/failure/fixpoint3.v
@@ -6,7 +6,7 @@ Inductive I : Prop :=
 
 Definition i0 := C (fun _ x => x).
 
-Definition Paradox : False :=
+Fail Definition Paradox : False :=
  (fix ni i : False :=
   match i with
   | C f => ni (f _ i)
diff --git a/test-suite/failure/fixpoint4.v b/test-suite/failure/fixpoint4.v
index fd956373..bf6133f1 100644
--- a/test-suite/failure/fixpoint4.v
+++ b/test-suite/failure/fixpoint4.v
@@ -8,7 +8,7 @@ Inductive IMP : Prop :=
 
 Definition i0 := (LIMP (fun _ => CIMP (fun _ x => x))).
 
-Definition Paradox : False :=
+Fail Definition Paradox : False :=
  (fix F y o {struct o} : False :=
   match y with
   | tt => fun f =>
diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v
new file mode 100644
index 00000000..64faa0ce
--- /dev/null
+++ b/test-suite/failure/guard-cofix.v
@@ -0,0 +1,43 @@
+(* This script shows, in two different ways, the inconsistency of the
+propositional extensionality axiom with the guard condition for cofixpoints. It
+is the dual of the problem on fixpoints (cf subterm.v, subterm2.v,
+subterm3.v). Posted on Coq-club by Maxime Dénès (02/26/2014). *)
+
+(* First example *)
+
+CoInductive CoFalse : Prop := CF : CoFalse -> False -> CoFalse.
+
+CoInductive Pandora : Prop := C : CoFalse -> Pandora.
+
+Axiom prop_ext : forall P Q : Prop, (P<->Q) -> P = Q.
+
+Lemma foo : Pandora = CoFalse.
+apply prop_ext.
+constructor.
+intro x; destruct x; assumption.
+exact C.
+Qed.
+
+Fail CoFixpoint loop : CoFalse :=
+match foo in (_ = T) return T with eq_refl => C loop end.
+
+Fail Definition ff : False := match loop with CF _ t => t end.
+
+(* Second example *)
+
+Inductive omega := Omega : omega -> omega.
+
+Lemma H : omega = CoFalse.
+Proof.
+apply prop_ext; constructor.
+  induction 1; assumption.
+destruct 1; destruct H0.
+Qed.
+
+Fail CoFixpoint loop' : CoFalse :=
+  match H in _ = T return T with
+    eq_refl =>
+    Omega match eq_sym H in _ = T return T with eq_refl => loop' end
+  end.
+
+Fail Definition ff' : False := match loop' with CF _ t => t end.
\ No newline at end of file
diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v
index 78a0782a..b3a0a335 100644
--- a/test-suite/failure/guard.v
+++ b/test-suite/failure/guard.v
@@ -1,16 +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        *)
 (************************************************************************)
-
+(*
 Fixpoint F (n:nat) : False := F (match F n with end).
-
+*)
 (* de Bruijn mix-up *)
 (* If accepted, Eval compute in f 0. loops *)
-Definition f :=
+Fail Definition f :=
   let f (f1 f2:nat->nat) := f1 in
   let _ := 0 in
   let _ := 0 in
diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v
index 5781c96b..7e4c5ac5 100644
--- a/test-suite/failure/illtype1.v
+++ b/test-suite/failure/illtype1.v
@@ -1,8 +1,8 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
-Check (S S).
+Fail Check (S S).
diff --git a/test-suite/failure/inductive.v b/test-suite/failure/inductive.v
new file mode 100644
index 00000000..f3e47bfd
--- /dev/null
+++ b/test-suite/failure/inductive.v
@@ -0,0 +1,27 @@
+(* A check that sort-polymorphic product is not set too low *)
+
+Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
+Fail Check (fun (A:Type) (B:Prop) => (prod A B : Prop)).
+Fail Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).
+
+(* Check that the nested inductive types positivity check avoids recursively
+   non uniform parameters (at least if these parameters break positivity) *)
+
+Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
+Fail Inductive u : Type := d : u | e : t u -> u.
+
+(* This used to succeed in versions 8.1 to 8.3 *)
+
+Require Import Logic.
+Require Hurkens.
+Definition Ti := Type.
+Inductive prod2 (X Y:Ti) := pair2 : X -> Y -> prod2 X Y.
+Fail Definition B : Prop := let F := prod2 True in F Prop. (* Aie! *)
+(*Definition p2b (P:Prop) : B := pair2 True Prop I P.
+Definition b2p (b:B) : Prop := match b with pair2 _ P => P end.
+Lemma L1 : forall A : Prop, b2p (p2b A) -> A.
+Proof (fun A x => x).
+Lemma L2 : forall A : Prop, A -> b2p (p2b A).
+Proof (fun A x => x).
+Check Hurkens.paradox B p2b b2p L1 L2.*)
+
diff --git a/test-suite/failure/inductive1.v b/test-suite/failure/inductive1.v
deleted file mode 100644
index 3b57d919..00000000
--- a/test-suite/failure/inductive1.v
+++ /dev/null
@@ -1,4 +0,0 @@
-(* A check that sort-polymorphic product is not set too low *)
-
-Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
-Check (fun (A:Type) (B:Prop) => (prod A B : Prop)).
diff --git a/test-suite/failure/inductive2.v b/test-suite/failure/inductive2.v
deleted file mode 100644
index b77474be..00000000
--- a/test-suite/failure/inductive2.v
+++ /dev/null
@@ -1,4 +0,0 @@
-(* A check that sort-polymorphic product is not set too low *)
-
-Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B.
-Check (fun (A:Prop) (B:Type) => (prod A B : Prop)).
diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v
deleted file mode 100644
index cf035edf..00000000
--- a/test-suite/failure/inductive3.v
+++ /dev/null
@@ -1,5 +0,0 @@
-(* Check that the nested inductive types positivity check avoids recursively
-   non uniform parameters (at least if these parameters break positivity) *)
-
-Inductive t (A:Type) : Type := c : t (A -> A) -> t A.
-Inductive u : Type := d : u | e : t u -> u.
diff --git a/test-suite/failure/inductive4.v b/test-suite/failure/inductive4.v
deleted file mode 100644
index 6ba36fd2..00000000
--- a/test-suite/failure/inductive4.v
+++ /dev/null
@@ -1,15 +0,0 @@
-(* This used to succeed in versions 8.1 to 8.3 *)
-
-Require Import Logic.
-Require Hurkens.
-Definition Ti := Type.
-Inductive prod (X Y:Ti) := pair : X -> Y -> prod X Y.
-Definition B : Prop := let F := prod True in F Prop. (* Aie! *)
-Definition p2b (P:Prop) : B := pair True Prop I P.
-Definition b2p (b:B) : Prop := match b with pair _ P => P end.
-Lemma L1 : forall A : Prop, b2p (p2b A) -> A.
-Proof (fun A x => x).
-Lemma L2 : forall A : Prop, A -> b2p (p2b A).
-Proof (fun A x => x).
-Check Hurkens.paradox B p2b b2p L1 L2.
-
diff --git a/test-suite/failure/ltac1.v b/test-suite/failure/ltac1.v
index 7b496a75..eef16525 100644
--- a/test-suite/failure/ltac1.v
+++ b/test-suite/failure/ltac1.v
@@ -4,4 +4,4 @@ Ltac X := match goal with
           end.
 Goal True -> True -> True.
 intros.
-X.
+Fail X.
diff --git a/test-suite/failure/ltac2.v b/test-suite/failure/ltac2.v
index 14436e58..d66fb680 100644
--- a/test-suite/failure/ltac2.v
+++ b/test-suite/failure/ltac2.v
@@ -1,6 +1,6 @@
 (* Check that Match arguments are forbidden *)
 Ltac E x := apply x.
 Goal True -> True.
-E ltac:(match goal with
+Fail E ltac:(match goal with
         |  |- _ => intro H
         end).
diff --git a/test-suite/failure/ltac4.v b/test-suite/failure/ltac4.v
index 41471275..5b0396d1 100644
--- a/test-suite/failure/ltac4.v
+++ b/test-suite/failure/ltac4.v
@@ -1,5 +1,6 @@
 (* Check static globalisation of tactic names *)
 (* Proposed by Benjamin (mars 2002) *)
 Goal forall n : nat, n = n.
-induction n; try REflexivity.
+induction n.
+Fail try REflexivity.
 
diff --git a/test-suite/failure/pattern.v b/test-suite/failure/pattern.v
index a24beaa2..216eb254 100644
--- a/test-suite/failure/pattern.v
+++ b/test-suite/failure/pattern.v
@@ -6,4 +6,4 @@ Variable P : forall m : nat, m = n -> Prop.
 
 Goal forall p : n = n, P n p.
 intro.
-pattern n, p.
+Fail pattern n, p.
diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v
index 1c1080d1..d44bccdf 100644
--- a/test-suite/failure/positivity.v
+++ b/test-suite/failure/positivity.v
@@ -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        *)
 (************************************************************************)
-Inductive t : Set :=
+Fail Inductive t : Set :=
     c : (t -> nat) -> t.
diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v
index 93e159e8..b62f9b68 100644
--- a/test-suite/failure/proofirrelevance.v
+++ b/test-suite/failure/proofirrelevance.v
@@ -6,6 +6,9 @@ Inductive bool_in_prop : Type := hide : bool -> bool_in_prop
 with bool : Type := true : bool | false : bool.
 
 Lemma not_proof_irrelevance : ~ forall (P:Prop) (p p':P), p=p'.
-intro H; pose proof (H bool_in_prop (hide true) (hide false)); discriminate.
-Qed.
+intro H.
+Fail pose proof (H bool_in_prop (hide true) (hide false)).
+Abort.
+(*discriminate.
+Qed.*)
 
diff --git a/test-suite/failure/prop-set-proof-irrelevance.v b/test-suite/failure/prop-set-proof-irrelevance.v
index ad494108..fee33432 100644
--- a/test-suite/failure/prop-set-proof-irrelevance.v
+++ b/test-suite/failure/prop-set-proof-irrelevance.v
@@ -1,12 +1,12 @@
 Require Import ProofIrrelevance.
 
 Lemma proof_irrelevance_set : forall (P : Set) (p1 p2 : P), p1 = p2.
-  exact proof_irrelevance.
-Qed.
+  Fail exact proof_irrelevance.
+(*Qed.
 
 Lemma paradox : False.
   assert (H : 0 <> 1) by discriminate.
   apply H.
   Fail apply proof_irrelevance. (* inlined version is rejected *)
   apply proof_irrelevance_set.
-Qed.
+Qed.*)
diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v
index ef6d01d0..e5db8176 100644
--- a/test-suite/failure/redef.v
+++ b/test-suite/failure/redef.v
@@ -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        *)
 (************************************************************************)
 Definition toto := Set.
-Definition toto := Set.
+Fail Definition toto := Set.
diff --git a/test-suite/failure/rewrite_in_goal.v b/test-suite/failure/rewrite_in_goal.v
index c11a6237..dedfdf01 100644
--- a/test-suite/failure/rewrite_in_goal.v
+++ b/test-suite/failure/rewrite_in_goal.v
@@ -1,3 +1,3 @@
 Goal forall T1 T2 (H:T1=T2) (f:T1->Prop) (x:T1) , f x -> Type.
   intros until x.
-  rewrite H in x.
+  Fail rewrite H in x.
diff --git a/test-suite/failure/rewrite_in_hyp.v b/test-suite/failure/rewrite_in_hyp.v
index 613d707c..1eef0fa0 100644
--- a/test-suite/failure/rewrite_in_hyp.v
+++ b/test-suite/failure/rewrite_in_hyp.v
@@ -1,3 +1,3 @@
 Goal forall (T1 T2 : Type) (f:T1 -> Prop) (x:T1) (H:T1=T2), f x -> 0=1.
   intros T1 T2 f x H fx.
-  rewrite H in x.
+  Fail rewrite H in x.
diff --git a/test-suite/failure/rewrite_in_hyp2.v b/test-suite/failure/rewrite_in_hyp2.v
index 1533966e..112a856e 100644
--- a/test-suite/failure/rewrite_in_hyp2.v
+++ b/test-suite/failure/rewrite_in_hyp2.v
@@ -5,4 +5,4 @@
 
 Goal forall b, S b = O -> (fun a => 0 = (S a)) b -> True.
   intros b H H0.
-  rewrite H in H0.
+  Fail rewrite H in H0.
diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v
index 9c35ecfb..a6e6bc48 100644
--- a/test-suite/failure/search.v
+++ b/test-suite/failure/search.v
@@ -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        *)
 (************************************************************************)
 
-SearchPattern (_ = _) outside n_existe_pas.
+Fail SearchPattern (_ = _) outside n_existe_pas.
diff --git a/test-suite/failure/sortelim.v b/test-suite/failure/sortelim.v
new file mode 100644
index 00000000..2b3cf106
--- /dev/null
+++ b/test-suite/failure/sortelim.v
@@ -0,0 +1,149 @@
+(* This is a proof of false which used to be accepted by Coq (Jan 12, 2014) due
+to a DeBruijn index error in the check for allowed elimination sorts.
+
+Proof by Maxime Dénès, using a proof of Hurkens' paradox by Hugo Herbelin to derive
+inconsistency. *)
+
+(* We start by adapting the proof of Hurkens' paradox by Hugo in
+theories/Logic/Hurkens.v, so that instead of requiring a retract
+from Type into Prop up to equality, we require it only up to
+equivalence.
+*)
+
+Section Hurkens.
+
+Definition Type2 := Type.
+Definition Type1 := Type : Type2.
+
+(** Assumption of a retract from Type into Prop *)
+
+Variable down : Type1 -> Prop.
+Variable up : Prop -> Type1.
+
+Hypothesis back : forall A, up (down A) -> A.
+
+Hypothesis forth : forall A, A -> up (down A).
+
+Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A),
+      P (back A (forth A a)) -> P a.
+
+Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A),
+      P a -> P (back A (forth A a)).
+
+(** Proof *)
+
+Definition V : Type1 := forall A:Prop, ((up A -> Prop) -> up A -> Prop) -> up A -> Prop.
+Definition U : Type1 := V -> Prop.
+
+Definition sb (z:V) : V := fun A r a => r (z A r) a.
+Definition le (i:U -> Prop) (x:U) : Prop := x (fun A r a => i (fun v => sb v A r a)).
+Definition le' (i:up (down U) -> Prop) (x:up (down U)) : Prop := le (fun a:U => i (forth _ a)) (back _ x).
+Definition induct (i:U -> Prop) : Type1 := forall x:U, up (le i x) -> up (i x).
+Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))).
+Definition I (x:U) : Prop :=
+  (forall i:U -> Prop, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False.
+
+Lemma Omega : forall i:U -> Prop, induct i -> up (i WF).
+Proof.
+intros i y.
+apply y.
+unfold le, WF, induct.
+apply forth.
+intros x H0.
+apply y.
+unfold sb, le', le.
+compute.
+apply backforth_r.
+exact H0.
+Qed.
+
+Lemma lemma1 : induct (fun u => down (I u)).
+Proof.
+unfold induct.
+intros x p.
+apply forth.
+intro q.
+generalize (q (fun u => down (I u)) p).
+intro r.
+apply back in r.
+apply r.
+intros i j.
+unfold le, sb, le', le in j |-.
+apply backforth in j.
+specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))).
+apply q.
+exact j.
+Qed.
+
+Lemma lemma2 : (forall i:U -> Prop, induct i -> up (i WF)) -> False.
+Proof.
+intro x.
+generalize (x (fun u => down (I u)) lemma1).
+intro r; apply back in r.
+apply r.
+intros i H0.
+apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))).
+unfold le, WF in H0.
+apply back in H0.
+exact H0.
+Qed.
+
+Theorem paradox : False.
+Proof.
+exact (lemma2 Omega).
+Qed.
+
+End Hurkens.
+
+(* Alright, now we use a DeBruijn index off-by-1 error to build a type
+satisfying the hypotheses of the paradox. What is tricky is that the pretyper is
+not affected by the bug (only the kernel is). Even worse, since our goal is to
+bypass the elimination restriction for types in Prop, we have to devise a way to
+feed the kernel with an illegal pattern matching without going through the
+pattern matching compiler (which calls the pretyper). The trick is to use the
+record machinery, which defines projections, checking if the kernel accepts
+it. *)
+
+Definition informative (x : bool) :=
+  match x with
+  | true => Type
+  | false => Prop
+  end.
+
+Definition depsort (T : Type) (x : bool) : informative x :=
+  match x with
+  | true => T
+  | false => True
+  end.
+
+(* The let-bound parameters in the record below trigger the error *)
+
+Record Box (ff := false) (tt := true) (T : Type) : Prop :=
+  wrap {prop : depsort T tt}.
+
+Definition down (x : Type) : Prop := Box x.
+Definition up (x : Prop) : Type := x.
+
+Fail Definition back A : up (down A) -> A := prop A.
+
+(* If the projection has been defined, the following script derives a proof of
+false.
+
+Definition forth A : A -> up (down A) := wrap A.
+
+Definition backforth (A:Type) (P:A->Type) (a:A) :
+      P (back A (forth A a)) -> P a := fun H => H.
+
+Definition backforth_r (A:Type) (P:A->Type) (a:A) :
+      P a -> P (back A (forth A a)) := fun H => H.
+
+(* Everything set up, we just check that we built the right context for the
+paradox to apply. *)
+
+Theorem pandora : False.
+apply (paradox down up back forth backforth backforth_r).
+Qed.
+
+Print Assumptions pandora.
+
+*)
\ No newline at end of file
diff --git a/test-suite/failure/subterm.v b/test-suite/failure/subterm.v
new file mode 100644
index 00000000..3798bc48
--- /dev/null
+++ b/test-suite/failure/subterm.v
@@ -0,0 +1,45 @@
+Module Foo. 
+  Inductive True2:Prop:= I2: (False->True2)->True2.
+
+  Axiom Heq: (False->True2)=True2.
+  
+  Fail Fixpoint con (x:True2) :False :=
+    match x with
+        I2 f => con (match Heq with @eq_refl _ _ => f end)
+    end.
+End Foo.
+
+Require Import ClassicalFacts.
+
+Inductive True1 : Prop := I1 : True1
+with True2 : Prop := I2 : True1 -> True2.
+
+Section func_unit_discr.
+
+Hypothesis Heq : True1 = True2.
+
+Fail Fixpoint contradiction (u : True2) : False :=
+contradiction (
+    match u with
+      | I2 Tr =>
+         match Heq in (_ = T) return T with
+         | eq_refl => Tr
+         end
+    end).
+
+End func_unit_discr.
+
+Require Import Vectors.VectorDef.
+
+About caseS.
+About tl.
+Open Scope vector_scope.
+Local Notation "[]" := (@nil _).
+Local Notation "h :: t" := (@cons _ h _ t) (at level 60, right associativity).
+Definition is_nil {A n} (v : t A n) : bool := match v with [] => true | _ => false end.
+
+Fixpoint id {A n} (v : t A n) : t A n :=
+  match v in t _ n' return t A n' with
+    | (h :: t) as v' => h :: id (tl v')
+    |_ => []
+  end.
diff --git a/test-suite/failure/subterm2.v b/test-suite/failure/subterm2.v
new file mode 100644
index 00000000..a420a4d7
--- /dev/null
+++ b/test-suite/failure/subterm2.v
@@ -0,0 +1,48 @@
+(* An example showing that prop-extensionality is incompatible with
+   powerful extensions of the guard condition.
+   Unlike the example in guard2, it is not exploiting the fact that
+   the elimination of False always produces a subterm.
+
+   Example due to Cristobal Camarero on Coq-Club.
+   Adapted to nested types by Bruno Barras.
+ *)
+
+Axiom prop_ext: forall P Q, (P<->Q)->P=Q.
+
+Module Unboxed.
+
+Inductive True2:Prop:= I2: (False->True2)->True2.
+
+Theorem Heq: (False->True2)=True2.
+Proof.
+apply prop_ext. split.
+- intros. constructor. exact H.
+- intros. exact H.
+Qed.
+
+Fail Fixpoint con (x:True2) :False :=
+match x with
+I2 f => con (match Heq in _=T return T with eq_refl => f end)
+end.
+
+End Unboxed.
+
+(* This boxed example shows that it is not enough to just require
+   that the return type of the match on Heq is an inductive type
+ *)
+Module Boxed.
+
+Inductive box (T:Type) := Box (_:T).
+Definition unbox {T} (b:box T) : T := let (x) := b in x.
+
+Inductive True2:Prop:= I2: box(False->True2)->True2.
+
+Definition Heq: (False->True2) <-> True2 :=
+  conj (fun f => I2 (Box _ f)) (fun x _ => x).
+
+Fail Fixpoint con (x:True2) :False :=
+match x with
+I2 f => con (unbox(match prop_ext _ _ Heq in _=T return box T with eq_refl => f end))
+end.
+
+End Boxed.
diff --git a/test-suite/failure/subterm3.v b/test-suite/failure/subterm3.v
new file mode 100644
index 00000000..2cef6357
--- /dev/null
+++ b/test-suite/failure/subterm3.v
@@ -0,0 +1,29 @@
+(* An example showing that prop-extensionality is incompatible with
+   powerful extensions of the guard condition.
+   This is a variation on the example in subterm2, exploiting
+   missing typing constraints in the commutative cut subterm rule
+   (subterm2 is using the same flaw but for the match rule).
+
+   Example due to Cristóbal Camarero on Coq-Club.
+ *)
+
+Axiom prop_ext: forall P Q, (P <-> Q) -> P=Q.
+
+Inductive True2 : Prop := I3 : (False -> True2) -> True2.
+
+Theorem T3T: True2 = True.
+Proof.
+apply prop_ext; split; auto.
+intros; constructor; apply False_rect.
+Qed.
+
+Theorem T3F_FT3F : (True2 -> False) = ((False -> True2) -> False).
+Proof.
+rewrite T3T.
+apply prop_ext; split; auto.
+Qed.
+
+Fail Fixpoint loop (x : True2) : False :=
+match x with
+I3 f => (match T3F_FT3F in _=T return T with eq_refl=> loop end) f
+end.
diff --git a/test-suite/failure/subtyping.v b/test-suite/failure/subtyping.v
index 127da851..e48c6689 100644
--- a/test-suite/failure/subtyping.v
+++ b/test-suite/failure/subtyping.v
@@ -18,4 +18,4 @@ Module TT : T.
  | L0
  | L1 :  (A -> Prop) -> L.
 
-End TT.
+Fail End TT.
diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v
index 48fc2fff..8b2dc1dc 100644
--- a/test-suite/failure/subtyping2.v
+++ b/test-suite/failure/subtyping2.v
@@ -242,4 +242,4 @@ Defined.
    with the constraint j >= i in the paradox.
 *)
 
-  Definition Paradox : False := Burali_Forti A0 i0' inj.
+  Fail Definition Paradox : False := Burali_Forti A0 i0' inj.
diff --git a/test-suite/failure/univ_include.v b/test-suite/failure/univ_include.v
index 56f04f9d..28a3263d 100644
--- a/test-suite/failure/univ_include.v
+++ b/test-suite/failure/univ_include.v
@@ -23,8 +23,8 @@ Module Mt.
   Definition t := T.
 End Mt.
 
-Module P := G Mt. (* should yield Universe inconsistency *)
+Fail Module P := G Mt. (* should yield Universe inconsistency *)
 (* ... otherwise the following command will show that T has type T! *)
-Eval cbv delta [P.elt Mt.t] in P.elt.
+(* Eval cbv delta [P.elt Mt.t] in P.elt. *)
 
 
diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v
index a8b5b975..e0168158 100644
--- a/test-suite/failure/universes-buraliforti-redef.v
+++ b/test-suite/failure/universes-buraliforti-redef.v
@@ -230,17 +230,17 @@ End Burali_Forti_Paradox.
 intros.
 change
   match i0 X1 R1, i0 X2 R2 with
-  | i1 x1 r1, i1 x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
+  | i1 _ _ x1 r1, i1 _ _ x2 r2 => exists f : _, morphism x1 r1 x2 r2 f
   end.
 case H; simpl.
 exists (fun x : X1 => x).
 red; trivial.
 Defined.
 
-(* The following command raises 'Error: Universe Inconsistency'.
+(* The following command should raise 'Error: Universe Inconsistency'.
    To allow large elimination of A0, i0 must not be a large constructor.
    Hence, the constraint Type_j' < Type_i' is added, which is incompatible
    with the constraint j >= i in the paradox.
 *)
 
-  Definition Paradox : False := Burali_Forti A0 i0 inj.
+  Fail Definition Paradox : False := Burali_Forti A0 i0 inj.
diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v
index 7b62a0c5..dba1a794 100644
--- a/test-suite/failure/universes-buraliforti.v
+++ b/test-suite/failure/universes-buraliforti.v
@@ -234,4 +234,4 @@ Defined.
    with the constraint j >= i in the paradox.
 *)
 
-  Definition Paradox : False := Burali_Forti A0 i0 inj.
+  Fail Definition Paradox : False := Burali_Forti A0 i0 inj.
diff --git a/test-suite/failure/universes-sections1.v b/test-suite/failure/universes-sections1.v
index 6cd04349..3f8e4446 100644
--- a/test-suite/failure/universes-sections1.v
+++ b/test-suite/failure/universes-sections1.v
@@ -5,4 +5,4 @@ Section A.
   Definition Type1 : Type2 := Type.
 End A.
 
-Definition Inconsistency : Type1 := Type2.
+Fail Definition Inconsistency : Type1 := Type2.
diff --git a/test-suite/failure/universes-sections2.v b/test-suite/failure/universes-sections2.v
index 98fdbc0d..34b2a11d 100644
--- a/test-suite/failure/universes-sections2.v
+++ b/test-suite/failure/universes-sections2.v
@@ -7,4 +7,4 @@ Section A.
   Definition Type1' := Type1.
 End A.
 
-Definition Inconsistency : Type1' := Type2.
+Fail Definition Inconsistency : Type1' := Type2.
diff --git a/test-suite/failure/universes.v b/test-suite/failure/universes.v
index 938c29b8..d708b01f 100644
--- a/test-suite/failure/universes.v
+++ b/test-suite/failure/universes.v
@@ -1,3 +1,3 @@
 Definition Type2 := Type.
 Definition Type1 : Type2 := Type.
-Definition Inconsistency : Type1 := Type2.
+Fail Definition Inconsistency : Type1 := Type2.
diff --git a/test-suite/failure/universes3.v b/test-suite/failure/universes3.v
index 8fb414d5..ee7a63c8 100644
--- a/test-suite/failure/universes3.v
+++ b/test-suite/failure/universes3.v
@@ -17,7 +17,7 @@ Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B).
 
 (* We cannot enforce Type1 < Type(6) while we already have
    Type(6) <= Type(7) < Type3 < Type1 *)
-Definition J := I Type1.
+Fail Definition J := I Type1.
 
 (* Open question: should the type of an inductive be the max of the
    types of the _arguments_ of its constructors (here B and Prop,
diff --git a/test-suite/ide/blocking-futures.fake b/test-suite/ide/blocking-futures.fake
new file mode 100644
index 00000000..b63f09bc
--- /dev/null
+++ b/test-suite/ide/blocking-futures.fake
@@ -0,0 +1,16 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# Extraction will force the future computation, assert it is blocking
+# Example courtesy of Jonathan (jonikelee)
+#
+ADD { Require Import List. }
+ADD { Import ListNotations. }
+ADD { Definition myrev{A}(l : list A) : {rl : list A | rl = rev l}. }
+ADD { Proof. }
+ADD {   induction l. }
+ADD {    eexists; reflexivity. }
+ADD {    cbn; destruct IHl as [rl' H]; rewrite <-H; eexists; reflexivity. }
+ADD { Qed. }
+ADD { Extraction myrev. }
+GOALS
diff --git a/test-suite/ide/undo001.fake b/test-suite/ide/undo001.fake
index bbaea7e7..55263615 100644
--- a/test-suite/ide/undo001.fake
+++ b/test-suite/ide/undo001.fake
@@ -3,8 +3,8 @@
 #
 # Simple backtrack by 1 between two global definitions
 #
-INTERP Definition foo := 0.
-INTERP Definition bar := 1.
-REWIND 1
-INTERPRAW Check foo.
-INTERPRAW Fail Check bar.
+ADD here { Definition foo := 0. }
+ADD { Definition bar := 1. }
+EDIT_AT here
+QUERY { Check foo. }
+QUERY { Fail Check bar. }
diff --git a/test-suite/ide/undo002.fake b/test-suite/ide/undo002.fake
index b855b6ea..5284c5d3 100644
--- a/test-suite/ide/undo002.fake
+++ b/test-suite/ide/undo002.fake
@@ -3,8 +3,8 @@
 #
 # Simple backtrack by 2 before two global definitions
 #
-INTERP Definition foo := 0.
-INTERP Definition bar := 1.
-REWIND 2
-INTERPRAW Fail Check foo.
-INTERPRAW Fail Check bar.
+ADD { Definition foo := 0. }
+ADD { Definition bar := 1. }
+EDIT_AT initial
+QUERY { Fail Check foo. }
+QUERY { Fail Check bar. }
diff --git a/test-suite/ide/undo003.fake b/test-suite/ide/undo003.fake
index 4c72e8dc..90757627 100644
--- a/test-suite/ide/undo003.fake
+++ b/test-suite/ide/undo003.fake
@@ -3,6 +3,6 @@
 #
 # Simple backtrack by 0 should be a no-op
 #
-INTERP Definition foo := 0.
-REWIND 0
-INTERPRAW Check foo.
+ADD here { Definition foo := 0. }
+EDIT_AT here
+QUERY { Check foo. }
diff --git a/test-suite/ide/undo004.fake b/test-suite/ide/undo004.fake
index c2ddfb8c..9029b03e 100644
--- a/test-suite/ide/undo004.fake
+++ b/test-suite/ide/undo004.fake
@@ -3,12 +3,12 @@
 #
 # Undoing arbitrary commands, as first step
 #
-INTERP Theorem a : O=O.
-INTERP Ltac f x := x.
-REWIND 1
+ADD here { Theorem a : O=O. }
+ADD { Ltac f x := x. }
+EDIT_AT here
 # <replay>
-INTERP Ltac f x := x.
+ADD { Ltac f x := x. }
 # <\replay>
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
+ADD { assert True by trivial. }
+ADD { trivial. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo005.fake b/test-suite/ide/undo005.fake
index 525b9f2a..7e31c0b0 100644
--- a/test-suite/ide/undo005.fake
+++ b/test-suite/ide/undo005.fake
@@ -3,13 +3,13 @@
 #
 # Undoing arbitrary commands, as non-first step
 #
-INTERP Theorem b : O=O.
-INTERP assert True by trivial.
-INTERP Ltac g x := x.
+ADD { Theorem b : O=O. }
+ADD here { assert True by trivial. }
+ADD { Ltac g x := x. }
 # <replay>
-REWIND 1
+EDIT_AT here
 # <\replay>
-INTERP Ltac g x := x.
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
+ADD { Ltac g x := x. }
+ADD { assert True by trivial. }
+ADD { trivial. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo006.fake b/test-suite/ide/undo006.fake
index ed88bef5..cdfdee1b 100644
--- a/test-suite/ide/undo006.fake
+++ b/test-suite/ide/undo006.fake
@@ -4,11 +4,11 @@
 # Undoing declarations, as first step
 # Was bugged in 8.1
 #
-INTERP Theorem c : O=O.
-INTERP Inductive T : Type := I.
-REWIND 1
+ADD here { Theorem c : O=O. }
+ADD { Inductive T : Type := I. }
+EDIT_AT here
 # <replay>
-INTERP Inductive T : Type := I.
+ADD { Inductive T : Type := I. }
 # <\replay>
-INTERP trivial.
-INTERP Qed.
+ADD { trivial. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo007.fake b/test-suite/ide/undo007.fake
deleted file mode 100644
index 87c06dbb..00000000
--- a/test-suite/ide/undo007.fake
+++ /dev/null
@@ -1,17 +0,0 @@
-# Script simulating a dialog between coqide and coqtop -ideslave
-# Run it via fake_ide
-#
-# Undoing declarations, as first step
-# new in 8.2
-#
-INTERP Theorem d : O=O.
-INTERP Definition e := O.
-INTERP Definition f := O.
-REWIND 1
-# <replay>
-INTERP Definition f := O.
-# <\replay>
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
-INTERPRAW Check e.
diff --git a/test-suite/ide/undo008.fake b/test-suite/ide/undo008.fake
index 1c46c1e8..72cab7a3 100644
--- a/test-suite/ide/undo008.fake
+++ b/test-suite/ide/undo008.fake
@@ -4,15 +4,15 @@
 # Undoing declarations, as non-first step
 # new in 8.2
 #
-INTERP Theorem h : O=O.
-INTERP assert True by trivial.
-INTERP Definition i := O.
-INTERP Definition j := O.
-REWIND 1
+ADD { Theorem h : O=O. }
+ADD { assert True by trivial. }
+ADD here { Definition i := O. }
+ADD { Definition j := O. }
+EDIT_AT here
 # <replay>
-INTERP Definition j := O.
+ADD { Definition j := O. }
 # <\replay>
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
-INTERPRAW Check i.
+ADD { assert True by trivial. }
+ADD { trivial. }
+ADD { Qed. }
+QUERY { Check i. }
diff --git a/test-suite/ide/undo009.fake b/test-suite/ide/undo009.fake
index 47c77d23..76f400ef 100644
--- a/test-suite/ide/undo009.fake
+++ b/test-suite/ide/undo009.fake
@@ -4,17 +4,18 @@
 # Undoing declarations, interleaved with proof steps
 # new in 8.2 *)
 #
-INTERP Theorem k : O=O.
-INTERP assert True by trivial.
-INTERP Definition l := O.
-INTERP assert True by trivial.
-INTERP Definition m := O.
-REWIND 3
+ADD { Theorem k : O=O. }
+ADD here { assert True by trivial. }
+ADD { Definition l := O. }
+ADD { assert True by trivial. }
+ADD { Definition m := O. }
+QUERY { Show. }
+EDIT_AT here
 # <replay>
-INTERP Definition l := O.
-INTERP assert True by trivial.
-INTERP Definition m := O.
+ADD { Definition l := O. }
+ADD { assert True by trivial. }
+ADD { Definition m := O. }
 # <\replay>
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
+ADD { assert True by trivial. }
+ADD { trivial. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo010.fake b/test-suite/ide/undo010.fake
index 4fe9df98..524416c3 100644
--- a/test-suite/ide/undo010.fake
+++ b/test-suite/ide/undo010.fake
@@ -4,25 +4,25 @@
 # Undoing declarations, interleaved with proof steps and commands *)
 # new in 8.2 *)
 #
-INTERP Theorem n : O=O.
-INTERP assert True by trivial.
-INTERP Definition o := O.
-INTERP Ltac h x := x.
-INTERP assert True by trivial.
-INTERP Focus.
-INTERP Definition p := O.
-REWIND 1
-REWIND 1
-REWIND 1
-REWIND 1
-REWIND 1
+ADD { Theorem n : O=O. }
+ADD s2 { assert True by trivial. }
+ADD s3 { Definition o := O. }
+ADD s4 { Ltac h x := x. }
+ADD s5 { assert True by trivial. }
+ADD s6 { Focus. }
+ADD { Definition p := O. }
+EDIT_AT s6
+EDIT_AT s5
+EDIT_AT s4
+EDIT_AT s3
+EDIT_AT s2
 # <replay>
-INTERP Definition o := O.
-INTERP Ltac h x := x.
-INTERP assert True by trivial.
-INTERP Focus.
-INTERP Definition p := O.
+ADD { Definition o := O. }
+ADD { Ltac h x := x. }
+ADD { assert True by trivial. } 
+ADD { Focus. }
+ADD { Definition p := O. }
 # </replay>
-INTERP assert True by trivial.
-INTERP trivial.
-INTERP Qed.
+ADD { assert True by trivial. }
+ADD { trivial. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo011.fake b/test-suite/ide/undo011.fake
index cc85a764..0be439b2 100644
--- a/test-suite/ide/undo011.fake
+++ b/test-suite/ide/undo011.fake
@@ -4,29 +4,31 @@
 # Bug 2082
 # Broken due to proof engine rewriting
 #
-INTERP Variable A : Prop.
-INTERP Variable B : Prop.
-INTERP Axiom OR : A \/ B.
-INTERP Lemma MyLemma2 : True.
-INTERP proof.
-INTERP per cases of (A \/ B) by OR.
-INTERP suppose A.
-INTERP     then (1 = 1).
-INTERP     then H1 : thesis.
-INTERP     thus thesis by H1.
-INTERP suppose B.
-REWIND 1
+ADD { Variable A : Prop. }
+ADD { Variable B : Prop. }
+ADD { Axiom OR : A \/ B. }
+ADD { Lemma MyLemma2 : True. }
+ADD { proof. }
+ADD { per cases of (A \/ B) by OR. }
+ADD { suppose A. }
+ADD {     then (1 = 1). }
+ADD there {     then H1 : thesis. }
+ADD here {     thus thesis by H1. }
+ADD { suppose B. }
+QUERY { Show. }
+EDIT_AT here
 # <replay>
-INTERP suppose B.
+ADD { suppose B. }
 # </replay>
-REWIND 2
+EDIT_AT there
 # <replay>
-INTERP     thus thesis by H1.
-INTERP suppose B.
+ADD {    thus thesis by H1. }
+ADD { suppose B. }
 # </replay>
-INTERP    then (1 = 1).
-INTERP    then H2 : thesis.
-INTERP    thus thesis by H2.
-INTERP end cases.
-INTERP end proof.
-INTERP Qed.
+QUERY { Show. }
+ADD {    then (1 = 1). }
+ADD {    then H2 : thesis. }
+ADD {    thus thesis by H2. }
+ADD { end cases. } 
+ADD { end proof. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo012.fake b/test-suite/ide/undo012.fake
index f9b29ca1..b3d1c6d5 100644
--- a/test-suite/ide/undo012.fake
+++ b/test-suite/ide/undo012.fake
@@ -2,25 +2,25 @@
 # Run it via fake_ide
 #
 # Test backtracking in presence of nested proofs
-# First, undoing the whole
 #
-INTERP Lemma aa : True -> True /\ True.
-INTERP intro H.
-INTERP split.
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-INTERP Qed.
-INTERP apply H.
-INTERP Qed.
-REWIND 1
-# We should now be just before aa, without opened proofs
-INTERPRAW Fail idtac.
-INTERPRAW Fail Check aa.
-INTERPRAW Fail Check bb.
-INTERPRAW Fail Check cc.
+ADD { Lemma aa : True -> True /\ True. }
+ADD { intro H. }
+ADD { split. }
+ADD { Lemma bb : False -> False. }
+ADD { intro H. }
+ADD { apply H. }
+ADD { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD { destruct H. }
+ADD { Qed. }
+QUERY { Show. }
+ADD here { apply H. }
+ADD { Qed. }
+EDIT_AT here
+# We should now be just before the Qed.
+QUERY { Fail Check aa. }
+QUERY { Check bb. }
+QUERY { Check cc. }
+ADD { Qed. }
diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake
index 3b1c61e6..f44156aa 100644
--- a/test-suite/ide/undo013.fake
+++ b/test-suite/ide/undo013.fake
@@ -2,30 +2,26 @@
 # Run it via fake_ide
 #
 # Test backtracking in presence of nested proofs
-# Second, trigger the full undo of an inner proof
+# Second, trigger the undo of an inner proof
 #
-INTERP Lemma aa : True -> True /\ True.
-INTERP intro H.
-INTERP split.
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-INTERP Qed.
-INTERP apply H.
-REWIND 2
-# We should now be just before "Lemma cc"
+ADD { Lemma aa : True -> True /\ True. }
+ADD { intro H. }
+ADD { split. }
+ADD { Lemma bb : False -> False. }
+ADD { intro H. }
+ADD { apply H. }
+ADD { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD here { destruct H. }
+ADD { Qed. }
+ADD { apply H. }
+EDIT_AT here
 # <replay>
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-INTERP Qed.
-INTERP apply H.
+ADD { Qed. }
+ADD { apply H. }
 # </replay>
-INTERP Qed.
-INTERPRAW Fail idtac.
-INTERPRAW Check (aa,bb,cc).
+ADD { Qed. }
+QUERY { Fail idtac. }
+QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake
index 5224b504..6d58b061 100644
--- a/test-suite/ide/undo014.fake
+++ b/test-suite/ide/undo014.fake
@@ -4,23 +4,23 @@
 # Test backtracking in presence of nested proofs
 # Third, undo inside an inner proof
 #
-INTERP Lemma aa : True -> True /\ True.
-INTERP intro H.
-INTERP split.
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-REWIND 1
+ADD { Lemma aa : True -> True /\ True. }
+ADD { intro H. }
+ADD { split. }
+ADD { Lemma bb : False -> False. }
+ADD { intro H. }
+ADD { apply H. }
+ADD { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD here { intro H. }
+ADD { destruct H. }
+EDIT_AT here
 # <replay>
-INTERP destruct H.
+ADD { destruct H. }
 # </replay>
-INTERP Qed.
-INTERP apply H.
-INTERP Qed.
-INTERPRAW Fail idtac.
-INTERPRAW Check (aa,bb,cc).
+ADD { Qed. }
+ADD { apply H. }
+ADD { Qed. }
+QUERY { Fail idtac. }
+QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake
index 32e46ec9..ac17985a 100644
--- a/test-suite/ide/undo015.fake
+++ b/test-suite/ide/undo015.fake
@@ -4,26 +4,26 @@
 # Test backtracking in presence of nested proofs
 # Fourth, undo from an inner proof to a above proof
 #
-INTERP Lemma aa : True -> True /\ True.
-INTERP intro H.
-INTERP split.
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-REWIND 4
+ADD { Lemma aa : True -> True /\ True. }
+ADD { intro H. }
+ADD { split. }
+ADD { Lemma bb : False -> False. }
+ADD { intro H. }
+ADD { apply H. }
+ADD here { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD { destruct H. }
+EDIT_AT here
 # <replay>
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD { destruct H. }
 # </replay>
-INTERP Qed.
-INTERP apply H.
-INTERP Qed.
-INTERPRAW Fail idtac.
-INTERPRAW Check (aa,bb,cc).
+ADD { Qed. }
+ADD { apply H. }
+ADD { Qed. }
+QUERY { Fail idtac. }
+QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake
index 2a6e512c..bdb81ecd 100644
--- a/test-suite/ide/undo016.fake
+++ b/test-suite/ide/undo016.fake
@@ -4,31 +4,28 @@
 # Test backtracking in presence of nested proofs
 # Fifth, undo from an inner proof to a previous inner proof
 #
-INTERP Lemma aa : True -> True /\ True.
-INTERP intro H.
-INTERP split.
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
-REWIND 6
-# We should be just before "Lemma bb"
+ADD { Lemma aa : True -> True /\ True. }
+ADD { intro H. }
+ADD { split. }
+ADD { Lemma bb : False -> False. }
+ADD here { intro H. }
+ADD { apply H. }
+ADD { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD { destruct H. }
+EDIT_AT here
 # <replay>
-INTERP Lemma bb : False -> False.
-INTERP intro H.
-INTERP apply H.
-INTERP Qed.
-INTERP apply H.
-INTERP Lemma cc : False -> True.
-INTERP intro H.
-INTERP destruct H.
+ADD { apply H. }
+ADD { Qed. }
+ADD { apply H. }
+ADD { Lemma cc : False -> True. }
+ADD { intro H. }
+ADD { destruct H. }
 # </replay>
-INTERP Qed.
-INTERP apply H.
-INTERP Qed.
-INTERPRAW Fail idtac.
-INTERPRAW Check (aa,bb,cc).
+ADD { Qed. }
+ADD { apply H. }
+ADD { Qed. }
+QUERY { Fail idtac. }
+QUERY { Check (aa,bb,cc). }
diff --git a/test-suite/ide/undo017.fake b/test-suite/ide/undo017.fake
index 232360e9..37423dc7 100644
--- a/test-suite/ide/undo017.fake
+++ b/test-suite/ide/undo017.fake
@@ -3,11 +3,11 @@
 #
 # bug #2569 : Undoing inside modules
 #
-INTERP Module M.
-INTERP Definition x := 0.
-INTERP End M.
-REWIND 1
+ADD { Module M. }
+ADD here { Definition x := 0. }
+ADD { End M. }
+EDIT_AT here
 # <replay>
-INTERP End M.
+ADD { End M. }
 # </replay>
-INTERPRAW Check M.x.
+QUERY { Check M.x. }
diff --git a/test-suite/ide/undo018.fake b/test-suite/ide/undo018.fake
index ef0945ab..11091bfa 100644
--- a/test-suite/ide/undo018.fake
+++ b/test-suite/ide/undo018.fake
@@ -3,11 +3,11 @@
 #
 # bug #2569 : Undoing inside section
 #
-INTERP Section M.
-INTERP Definition x := 0.
-INTERP End M.
-REWIND 1
+ADD { Section M. }
+ADD here { Definition x := 0. }
+ADD { End M. }
+EDIT_AT here
 # <replay>
-INTERP End M.
+ADD { End M. }
 # </replay>
-INTERPRAW Check x.
+QUERY { Check x. }
diff --git a/test-suite/ide/undo019.fake b/test-suite/ide/undo019.fake
index 70e70d7e..5df49ebb 100644
--- a/test-suite/ide/undo019.fake
+++ b/test-suite/ide/undo019.fake
@@ -3,12 +3,12 @@
 #
 # bug #2569 : Undoing a focused subproof
 #
-INTERP Goal True.
-INTERP {
-INTERP exact I.
-INTERP }
-REWIND 1
+ADD { Goal True. }
+ADD { \{ }
+ADD here { exact I. }
+ADD { \} }
+EDIT_AT here
 # <replay>
-INTERP }
+ADD { \} }
 # </replay>
-INTERP Qed.
+ADD { Qed. }
diff --git a/test-suite/ide/undo020.fake b/test-suite/ide/undo020.fake
new file mode 100644
index 00000000..2adde908
--- /dev/null
+++ b/test-suite/ide/undo020.fake
@@ -0,0 +1,27 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# focusing a broken proof and fixing it
+ 
+# first proof
+ADD { Lemma a : True. }
+ADD { Proof using. }
+ADD here { idtac. }
+ADD { exact Ix. }
+ADD { Qed. }
+# second proof
+ADD { Lemma b : False. }
+ADD { Proof using. }
+ADD { admit. }
+ADD last { Qed. }
+# We join and expect some proof to fail
+WAIT
+# Going back to the error
+EDIT_AT here
+# Fixing the proof
+ADD { exact I. }
+ADD { Qed. }
+# we are back at the end
+ASSERT TIP last
+QUERY { Check a. }
+QUERY { Check b. }
diff --git a/test-suite/ide/undo021.fake b/test-suite/ide/undo021.fake
new file mode 100644
index 00000000..0d83ad25
--- /dev/null
+++ b/test-suite/ide/undo021.fake
@@ -0,0 +1,29 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# jumping between broken proofs
+ 
+# first proof
+ADD { Lemma a : True. }
+ADD { Proof using. }
+ADD here { idtac. }
+ADD { exact Ix. }
+ADD { Qed. }
+# second proof
+ADD { Lemma b : True. }
+ADD here2 { Proof using. }
+ADD { exact Ix. }
+ADD { Qed. }
+# We wait all slaves and expect both proofs to fail
+WAIT
+# Going back to the error
+EDIT_AT here2
+# this is not implemented yet, all after here is erased 
+EDIT_AT here
+# Fixing the proof
+ADD { exact I. }
+ADD last { Qed. }
+ASSERT TIP last
+# we are back at the end
+QUERY { Check a. }
+QUERY { Fail Check b. }
diff --git a/test-suite/ide/undo022.fake b/test-suite/ide/undo022.fake
new file mode 100644
index 00000000..51d8d106
--- /dev/null
+++ b/test-suite/ide/undo022.fake
@@ -0,0 +1,41 @@
+# Script simulating a dialog between coqide and coqtop -ideslave
+# Run it via fake_ide
+#
+# jumping between broken proofs + interp error while fixing.
+# the error should note make the GUI unfocus the currently focused proof.
+ 
+# first proof
+ADD { Lemma a : True /\ True. }
+ADD { Proof using. }
+ADD here { split. }
+ADD { exact Ix. } # first error
+ADD { exact Ix. } # second error
+ADD { Qed. }
+# second proof
+ADD { Lemma b : True. }
+ADD { Proof using. }
+ADD { exact I. }
+ADD last { Qed. }
+# We wait all slaves and expect both proofs to fail
+WAIT
+# Going back to the error
+EDIT_AT here
+# Fixing the proof
+ADD fix { exact I. }
+# showing the goals
+GOALS
+# re adding the wrong step
+ADD { exact Ix. }
+# showing the goals (failure) and retracting to the safe state suggested by Coq
+FAILGOALS
+# we assert we jumped back to the state immediately before the last (erroneous) 
+# one
+ASSERT TIP fix
+# finish off the proof
+ADD { exact I. }
+ADD { Qed. }
+# here we unfocus, hence we jump back to the end of the document
+ASSERT TIP last
+# we are back at the end
+QUERY { Check a. }
+QUERY { Check b. }
diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v
index a4bbfba8..ed46eb22 100644
--- a/test-suite/ideal-features/Apply.v
+++ b/test-suite/ideal-features/Apply.v
@@ -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/test-suite/interactive/ParalITP.v b/test-suite/interactive/ParalITP.v
new file mode 100644
index 00000000..a96d4a5c
--- /dev/null
+++ b/test-suite/interactive/ParalITP.v
@@ -0,0 +1,47 @@
+(* Some boilerplate *)
+Fixpoint fib n := match n with
+  | O => 1
+  | S m => match m with
+    | O => 1
+    | S o => fib o + fib m end end.
+
+Ltac sleep n :=
+  try (cut (fib n = S (fib n)); reflexivity).
+
+(* Tune that depending on your PC *)
+Let time := 18.
+
+
+(* Beginning of demo *)
+
+Section Demo.
+
+Variable i : True.
+
+Lemma a : True.
+Proof using i.
+  sleep time.
+  idtac.
+  sleep time.
+  (* Error, jump back to fix it, then Qed again *)
+  exact (i i).
+Qed.
+
+Lemma b : True.
+Proof using i. 
+  sleep time.
+  idtac.
+  sleep time.
+  (* Here we use "a" *)
+  exact a.
+Qed.
+
+Lemma work_here : True /\ True.
+Proof using i.
+(* Jump directly here, Coq reacts immediately *)
+split.
+  exact b.  (* We can use the lemmas above *)
+exact a.
+Qed.
+
+End Demo.
\ No newline at end of file
diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v
new file mode 100755
index 00000000..0d75d52a
--- /dev/null
+++ b/test-suite/interactive/ParalITP_smallproofs.v
@@ -0,0 +1,3041 @@
+(* This program is free software; you can redistribute it and/or      *)
+(* modify it under the terms of the GNU Lesser General Public License *)
+(* as published by the Free Software Foundation; either version 2.1   *)
+(* of the License, or (at your option) any later version.             *)
+(*                                                                    *)
+(* This program is distributed in the hope that it will be useful,    *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
+(* GNU General Public License for more details.                       *)
+(*                                                                    *)
+(* You should have received a copy of the GNU Lesser General Public   *)
+(* License along with this program; if not, write to the Free         *)
+(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
+(* 02110-1301 USA                                                     *)
+
+
+(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful.
+*)
+
+Require Export ZArith.
+Require Export ZArithRing.
+
+Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d.
+
+Ltac Flip :=
+  apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption.
+
+Ltac Falsum :=
+  try intro; apply False_ind;
+   repeat
+    match goal with
+    | id1:(~ ?X1) |- ?X2 =>
+        (apply id1; assumption || reflexivity) || clear id1
+    end.
+
+
+Ltac Step_l a :=
+  match goal with
+  |  |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ]
+  end. 
+
+Ltac Step_r a :=
+  match goal with
+  |  |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ]
+  end. 
+
+Ltac CaseEq formula :=
+  generalize (refl_equal formula); pattern formula at -1 in |- *;
+   case formula.
+
+
+Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H).
+Proof.
+ intros.
+ case H.
+ intros. 
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma pair_2 :
+ forall (A B : Set) (H1 H2 : A * B),
+ fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2.
+Proof.
+ intros A B H1 H2.
+ case H1.
+ case H2.
+ simpl in |- *.
+ intros.
+ rewrite H.
+ rewrite H0.
+ reflexivity.
+Qed.
+
+
+Section projection.   
+ Variable A : Set.
+ Variable P : A -> Prop.
+ 
+ Definition projP1 (H : sig P) := let (x, h) := H in x.
+ Definition projP2 (H : sig P) :=
+   let (x, h) as H return (P (projP1 H)) := H in h.
+End projection.
+
+
+(*###########################################################################*)
+(* Declaring some realtions on natural numbers for stepl and stepr tactics.  *)
+(*###########################################################################*)
+
+Lemma le_stepl: forall x y z, le x y -> x=z -> le z y.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma le_stepr: forall x y z, le x y -> y=z -> le x z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+
+Declare Left Step le_stepl.
+Declare Right Step le_stepr.
+Declare Left Step lt_stepl.
+Declare Right Step lt_stepr.
+Declare Left Step neq_stepl.
+Declare Right Step neq_stepr.
+
+(*###########################################################################*)
+(** Some random facts about natural numbers, positive numbers and integers   *)
+(*###########################################################################*)
+
+
+Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}.
+Proof. 
+ intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ];
+  reflexivity. 
+Qed.
+  
+
+Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n).
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0.
+Proof. 
+ intros; omega.
+Qed.
+
+Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0.
+Proof. 
+ intros; omega.
+Qed.
+
+Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+
+(*###########################################################################*)
+(* Declaring some realtions on integers for stepl and stepr tactics.         *)
+(*###########################################################################*)
+
+Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma Zlt_stepl: forall x y z, (x<y)%Z -> x=z -> (z<y)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma Zlt_stepr: forall x y z, (x<y)%Z -> y=z -> (x<z)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma Zneq_stepl:forall (x y z:Z), (x<>y)%Z -> x=z -> (z<>y)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Declare Left Step Zle_stepl.
+Declare Right Step Zle_stepr.
+Declare Left Step Zlt_stepl.
+Declare Right Step Zlt_stepr.
+Declare Left Step Zneq_stepl.
+Declare Right Step Zneq_stepr.
+
+
+(*###########################################################################*)
+(** Informative case analysis                                                *)
+(*###########################################################################*)
+
+Lemma Zlt_cotrans :
+ forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x z).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zle_lt_trans with (m := x).
+ apply Zge_le.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zlt_cotrans_pos :
+ forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}.
+Proof.
+ intros.
+ case (Zlt_cotrans 0 (x + y) H x).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zplus_lt_reg_l with (p := x).
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zlt_cotrans_neg :
+ forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}.
+Proof.
+ intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
+  [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
+  assumption.
+Qed.
+
+
+
+Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}.
+Proof.
+ intros.
+ case Z_lt_ge_dec with x y.
+ intro.
+ left.
+ assumption.
+ intro H0.
+ generalize (Zge_le _ _ H0).
+ intro.
+ case (Z_le_lt_eq_dec _ _ H1).
+ intro.
+ right.
+ assumption.
+ intro.
+ apply False_rec.
+ apply H.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x y).
+ intro H.
+ left.
+ left.
+ assumption.
+ intro H.
+ generalize (Zge_le _ _ H).
+ intro H0.
+ case (Z_le_lt_eq_dec y x H0).
+ intro H1.
+ left.
+ right.
+ apply Zlt_gt.
+ assumption.
+ intro.
+ right.
+ symmetry  in |- *.
+ assumption.
+Qed.
+ 
+
+Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}.
+Proof.
+ intros x y.
+ case (Z_eq_dec x y); intro H;
+  [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
+Qed.
+
+Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x y).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zge_le.
+ assumption.
+Qed.
+
+Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}.
+Proof.
+ intros; case (Z_lt_le_dec y x); [ right | left ]; assumption.
+Qed.
+
+Lemma Z_lt_lt_S_eq_dec :
+ forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}.
+Proof.
+ intros.
+ generalize (Zlt_le_succ _ _ H).
+ unfold Zsucc in |- *.
+ apply Z_le_lt_eq_dec.
+Qed.
+
+Lemma quadro_leq_inf :
+ forall a b c d : Z,
+ {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}.
+Proof.
+ intros.
+ case (Z_lt_le_dec a c).
+ intro z.
+ right.
+ intro. 
+ elim H.
+ intros.
+ generalize z.
+ apply Zle_not_lt.
+ assumption.
+ intro.
+ case (Z_lt_le_dec b d).
+ intro z0.
+ right. 
+ intro. 
+ elim H.
+ intros.
+ generalize z0.
+ apply Zle_not_lt.
+ assumption.
+ intro.
+ left.
+ split.
+ assumption.
+ assumption. 
+Qed.
+
+(*###########################################################################*)
+(** General auxiliary lemmata                                                *)
+(*###########################################################################*)
+
+Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y.
+Proof.
+ intros.
+ apply Zplus_reg_l with (- y)%Z.
+ rewrite Zplus_opp_l.
+ unfold Zminus in H.
+ rewrite Zplus_comm.
+ assumption.
+Qed.
+
+Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z.
+Proof.
+ intros a b. 
+ intros.
+ apply Zplus_lt_reg_l with b.
+ unfold Zminus in |- *. 
+ rewrite (Zplus_comm a).
+ rewrite (Zplus_assoc b (- b)). 
+ rewrite Zplus_opp_r.
+ simpl in |- *. 
+ rewrite <- Zplus_0_r_reverse. 
+ assumption.
+Qed.
+
+
+Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z.
+Proof.
+ intros a b. 
+ intros.
+ apply Zplus_le_reg_l with b.
+ unfold Zminus in |- *. 
+ rewrite (Zplus_comm a).
+ rewrite (Zplus_assoc b (- b)). 
+ rewrite Zplus_opp_r.
+ simpl in |- *. 
+ rewrite <- Zplus_0_r_reverse. 
+ assumption.
+Qed.
+
+Lemma Zlt_plus_plus :
+ forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z.
+Proof.
+ intros.
+ apply Zlt_trans with (m := (n + p)%Z).
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with (n := n).
+ apply Zplus_lt_compat_l.
+ assumption.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zgt_plus_plus :
+ forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z.
+ intros.
+ apply Zgt_trans with (m := (n + p)%Z).
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with (n := n).
+ apply Zplus_gt_compat_l.
+ assumption.
+ apply Zplus_gt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zle_lt_plus_plus :
+ forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z.
+Proof.
+ intros.
+ case (Zle_lt_or_eq m n).
+ assumption.
+ intro.
+ apply Zlt_plus_plus.
+ assumption.
+ assumption.
+ intro.
+ rewrite H1.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zge_gt_plus_plus :
+ forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z.
+Proof.
+ intros.
+ case (Zle_lt_or_eq n m).
+ apply Zge_le.
+ assumption.
+ intro.
+ apply Zgt_plus_plus.
+ apply Zlt_gt.
+ assumption.
+ assumption.
+ intro.
+ rewrite H1.
+ apply Zplus_gt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zgt_ge_plus_plus :
+ forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z.
+Proof.
+ intros.
+ rewrite Zplus_comm.
+ replace (n + q)%Z with (q + n)%Z.
+ apply Zge_gt_plus_plus.
+ assumption.
+ assumption.
+ apply Zplus_comm.
+Qed.
+
+Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z.
+Proof.
+ intros.
+ rewrite <- Zplus_0_r with 0%Z.
+ apply Zlt_plus_plus; assumption.
+Qed.
+
+
+Lemma Zle_resp_neg :
+ forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z.
+Proof.
+ intros.
+ rewrite <- Zplus_0_r with 0%Z.
+ apply Zplus_le_compat; assumption.
+Qed.
+
+
+Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z.
+Proof.
+ intros.
+ apply Zplus_lt_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z.
+Proof.
+ intros.
+ apply Zplus_lt_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z.
+Proof. 
+ intros.
+ apply Zplus_le_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z.
+Proof. 
+ intros.
+ apply Zplus_le_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z.
+Proof.
+ intros.
+ apply Zle_ge.
+ apply Zplus_le_reg_l with (p := (x + y)%Z).
+ ring_simplify (x + y + - y)%Z (x + y + - x)%Z.
+ assumption.
+Qed.
+
+
+
+(* Omega can't solve this *)
+Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+
+
+Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith.
+
+
+Lemma Zle_reg_mult_l :
+ forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z.
+Proof.
+ intros.
+ apply Zplus_le_reg_l with (p := (- a * x)%Z).
+ ring_simplify (- a * x + a * x)%Z.
+ replace (- a * x + a * y)%Z with ((y - x) * a)%Z.
+ apply Zmult_gt_0_le_0_compat.
+ apply Zlt_gt.
+ assumption. 
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+ ring.
+Qed.
+
+Lemma Zsimpl_plus_l_dep :
+ forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n.
+Proof.
+ intros.
+ apply Zplus_reg_l with x.
+ rewrite <- H0 in H.
+ assumption.
+Qed.
+
+
+Lemma Zsimpl_plus_r_dep :
+ forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n.
+Proof.
+ intros.
+ apply Zplus_reg_l with x.
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with x n.
+ rewrite <- H0 in H.
+ assumption.
+Qed.
+
+Lemma Zmult_simpl :
+ forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z.
+Proof.
+ intros.
+ rewrite H.
+ rewrite H0.
+ reflexivity.
+Qed.
+ 
+Lemma Zsimpl_mult_l :
+ forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p.
+Proof.
+ intros.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + p)%Z with 0%Z.
+ apply Zmult_integral_l with (n := n).
+ assumption.
+ replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z.
+ apply Zegal_left.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+Lemma Zlt_reg_mult_l :
+ forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*)
+Proof.
+ intros.
+ case (Zcompare_Gt_spec x 0).
+ unfold Zgt in H.
+ assumption.
+ intros.
+ cut (x = Zpos x0). 
+ intro.
+ rewrite H2.
+ unfold Zlt in H0.
+ unfold Zlt in |- *.
+ cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z).
+ intro.
+ exact (trans_eq H3 H0).
+ apply Zcompare_mult_compat.
+ cut (x = (x + - (0))%Z).
+ intro.
+ exact (trans_eq H2 H1).
+ simpl in |- *.
+ apply (sym_eq (A:=Z)).
+ exact (Zplus_0_r x).
+Qed.
+
+
+Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*)
+Proof.
+ intros.
+ red in |- *.
+ apply sym_eq.
+ cut (Datatypes.Gt = (y ?= x)%Z).
+ intro.
+ cut ((y ?= x)%Z = (- x ?= - y)%Z).
+ intro.
+ exact (trans_eq H0 H1). 
+ exact (Zcompare_opp y x).
+ apply sym_eq.
+ exact (Zlt_gt x y H).
+Qed.
+
+
+Lemma Zlt_conv_mult_l :
+ forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*)
+Proof.
+ intros.
+ cut (- x > 0)%Z.
+ intro.
+ cut (- x * y < - x * z)%Z.
+ intro.
+ cut (- (- x * y) > - (- x * z))%Z.
+ intro.
+ cut (- - (x * y) > - - (x * z))%Z.
+ intro.
+ cut ((- - (x * y))%Z = (x * y)%Z).
+ intro.
+ rewrite H5 in H4.
+ cut ((- - (x * z))%Z = (x * z)%Z).
+ intro.
+ rewrite H6 in H4.
+ assumption.
+ exact (Zopp_involutive (x * z)).
+ exact (Zopp_involutive (x * y)).
+ cut ((- (- x * y))%Z = (- - (x * y))%Z).
+ intro.
+ rewrite H4 in H3.
+ cut ((- (- x * z))%Z = (- - (x * z))%Z). 
+ intro.
+ rewrite H5 in H3.
+ assumption.
+ cut ((- x * z)%Z = (- (x * z))%Z).
+ intro.
+ exact (f_equal Zopp H5).
+ exact (Zopp_mult_distr_l_reverse x z).
+ cut ((- x * y)%Z = (- (x * y))%Z).
+ intro.
+ exact (f_equal Zopp H4).
+ exact (Zopp_mult_distr_l_reverse x y).
+ exact (Zlt_opp (- x * y) (- x * z) H2).
+ exact (Zlt_reg_mult_l (- x) y z H1 H0).
+ exact (Zlt_opp x 0 H).
+Qed.
+
+Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y.   (*QA*)
+Proof.
+ intros.
+ cut (y < x)%Z.
+ intro.
+ cut (y <> x).
+ intro.
+ red in |- *.
+ intros.
+ cut (y = x).
+ intros.
+ apply H1.
+ assumption.
+ exact (sym_eq H2).
+ exact (Zorder.Zlt_not_eq y x H0).
+ exact (Zgt_lt x y H).
+Qed.
+
+Lemma Zmult_resp_nonzero :
+ forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z.
+Proof.
+ intros x y Hx Hy Hxy.
+ apply Hx. 
+ apply Zmult_integral_l with y; assumption.
+Qed.
+
+
+Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z.
+Proof.
+ intros.
+ intro.
+ apply H.
+ apply Zplus_reg_l with (- y)%Z.
+ rewrite Zplus_opp_l.
+ rewrite H0.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z.
+Proof.
+ intros a b H H0.
+ case (Z_le_lt_eq_dec _ _ H); trivial.
+ intro; apply False_ind; apply H0; symmetry  in |- *; assumption.
+Qed.
+
+Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z.
+Proof.
+ intros; apply Zgt_lt; apply Znot_le_gt; assumption.
+Qed.
+
+Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z.
+Proof.
+ intros x y H1 H2; apply H1; apply Zgt_lt; assumption.
+Qed.
+
+
+Lemma Zmult_absorb :
+ forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z.  (*QA*)
+Proof.
+ intros.
+ case (dec_eq y z).
+ intro.
+ assumption.
+ intro.
+ case (not_Zeq y z).
+ assumption.
+ intro.
+ case (not_Zeq x 0).
+ assumption.
+ intro.
+ apply False_ind.
+ cut (x * y > x * z)%Z.
+ intro.
+ cut ((x * y)%Z <> (x * z)%Z).
+ intro.
+ apply H5.
+ assumption.
+ exact (Zgt_not_eq (x * y) (x * z) H4).
+ exact (Zlt_conv_mult_l x y z H3 H2).
+ intro.
+ apply False_ind.
+ cut (x * y < x * z)%Z.
+ intro.
+ cut ((x * y)%Z <> (x * z)%Z).
+ intro.
+ apply H5.
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * y) (x * z) H4).
+ cut (x > 0)%Z.
+ intro.
+ exact (Zlt_reg_mult_l x y z H4 H2).
+ exact (Zlt_gt 0 x H3).
+ intro.
+ apply False_ind.
+ cut (x * z < x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H4.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * z) (x * y) H3).
+ apply False_ind.
+ case (not_Zeq x 0).
+ assumption.
+ intro.
+ cut (x * z > x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H5.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zgt_not_eq (x * z) (x * y) H4).
+ exact (Zlt_conv_mult_l x z y H3 H2).
+ intro.
+ cut (x * z < x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H5.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * z) (x * y) H4).
+ cut (x > 0)%Z.
+ intro.
+ exact (Zlt_reg_mult_l x z y H4 H2).
+ exact (Zlt_gt 0 x H3).
+Qed.
+
+Lemma Zlt_mult_mult :
+ forall a b c d : Z,
+ (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z.
+Proof.
+ intros.
+ apply Zlt_trans with (a * d)%Z.
+ apply Zlt_reg_mult_l.
+ Flip. 
+ assumption.
+ rewrite Zmult_comm.
+ rewrite Zmult_comm with b d.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+Qed.
+
+Lemma Zgt_mult_conv_absorb_l :
+ forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*)
+Proof.
+ intros.
+ case (dec_eq x y).
+ intro.
+ apply False_ind.
+ rewrite H1 in H0.
+ cut ((a * y)%Z = (a * y)%Z).
+ change ((a * y)%Z <> (a * y)%Z) in |- *.
+ apply Zgt_not_eq.
+ assumption.
+ trivial.
+ 
+ intro.
+ case (not_Zeq x y H1).
+ trivial.
+ 
+ intro.
+ apply False_ind.
+ cut (a * y > a * x)%Z.
+ apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z).
+ assumption.
+ apply Zlt_conv_mult_l.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zgt_mult_reg_absorb_l :
+ forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*)
+Proof.
+ intros.
+ cut (- - a > - - (0))%Z.
+ intro.
+ cut (- a < - (0))%Z.
+ simpl in |- *.
+ intro.
+ replace x with (- - x)%Z.
+ replace y with (- - y)%Z.
+ apply Zlt_opp.
+ apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z).
+ assumption.
+ rewrite Zmult_opp_opp.
+ rewrite Zmult_opp_opp.
+ assumption.
+ apply Zopp_involutive.
+ apply Zopp_involutive.
+ apply Zgt_lt.
+ apply Zlt_opp.
+ apply Zgt_lt.
+ assumption.
+ simpl in |- *.
+ rewrite Zopp_involutive.
+ assumption.
+Qed.
+
+Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z.
+Proof.
+ intros x y Hyx.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ replace (-1 * - y)%Z with y.
+ replace (-1 * - x)%Z with x.
+ Flip.
+ ring.
+ ring.
+Qed.
+
+
+Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z.
+Proof.
+ intros.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ replace (-1 * y)%Z with (- y)%Z.
+ replace (-1 * x)%Z with (- x)%Z.
+ apply Zlt_gt.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+Lemma Zmult_cancel_Zle :
+ forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z.
+Proof.
+ intros.
+ case (Z_le_gt_dec y x).
+ trivial.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl (a * x)).
+ apply Zle_lt_trans with (m := (a * y)%Z).
+ assumption.
+ apply Zgt_lt.
+ apply Zlt_conv_mult_l.
+ assumption.
+ apply Zgt_lt.
+ assumption.
+Qed.
+
+Lemma Zlt_mult_cancel_l :
+ forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z.
+Proof.
+ intros.
+ apply Zgt_lt.
+ apply Zgt_mult_reg_absorb_l with x.
+ apply Zlt_gt.
+ assumption. 
+ apply Zlt_gt.
+ assumption.
+Qed.
+ 
+
+Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z.
+Proof. 
+ intros.
+ apply Zmult_cancel_Zle with (a := (-1)%Z).
+ constructor.
+ replace (-1 * y)%Z with (- y)%Z.
+ replace (-1 * x)%Z with (- x)%Z.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+
+Lemma Zmult_resp_Zle :
+ forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z.
+Proof.
+ intros.
+ case (Z_le_gt_dec y x).
+ trivial.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl (a * y)).
+ apply Zle_lt_trans with (m := (a * x)%Z).
+ assumption.
+ apply Zlt_reg_mult_l.
+ apply Zlt_gt.
+ assumption.
+ apply Zgt_lt.
+ assumption.
+Qed.
+
+Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z.
+Proof. 
+ intros.
+ apply Zmult_cancel_Zle with (a := (-1)%Z).
+ constructor.
+ replace (-1 * - y)%Z with y.
+ replace (-1 * - x)%Z with x.
+ assumption.
+ clear y H; ring.
+ clear x H; ring.
+Qed.
+
+ 
+Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x.
+Proof.
+ intros.
+ case (Z_le_lt_eq_dec x y H).
+ intro H1.
+ apply False_ind.
+ generalize (Zlt_le_succ x y H1).
+ intro.
+ apply (Zlt_not_le y (x + 1) H0).  
+ replace (x + 1)%Z with (Zsucc x).
+ assumption.
+ reflexivity.
+ intro H1.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Zlt_le_eq_S :
+ forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z.
+Proof.
+ intros.
+ case (Z_le_lt_eq_dec y (x + 1) H0).
+ intro H1.
+ apply False_ind.
+ generalize (Zlt_le_succ x y H).
+ intro.
+ apply (Zlt_not_le y (x + 1) H1).  
+ replace (x + 1)%Z with (Zsucc x).
+ assumption.
+ reflexivity.
+ trivial.
+Qed.
+
+
+Lemma double_not_equal_zero :
+ forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z.
+Proof.
+ intros.
+ case (Z_zerop c).
+ intro.
+ rewrite e.  
+ left.
+ apply sym_not_eq. 
+ intro.
+ apply H; repeat split; assumption.
+ intro; right; assumption.
+Qed.
+
+Lemma triple_not_equal_zero :
+ forall a b c : Z,
+ ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z.
+Proof.
+ intros a b c H; case (Z_zerop a); intro Ha;
+            [ case (Z_zerop b); intro Hb;
+               [ case (Z_zerop c); intro Hc;
+                  [ apply False_ind; apply H; repeat split | right; right ]
+               | right; left ]
+            | left ]; assumption.
+Qed. 
+
+Lemma mediant_1 :
+ forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z.
+Proof.
+ intros. 
+ rewrite Zmult_plus_distr_r. 
+ rewrite Zmult_plus_distr_l.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+ 
+Lemma mediant_2 :
+ forall m n m' n' : Z,
+ (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. 
+Proof.
+ intros.
+ rewrite Zmult_plus_distr_l.
+ rewrite Zmult_plus_distr_r.
+ apply Zplus_lt_compat_r.
+ assumption.
+Qed.
+
+
+Lemma mediant_3 :
+ forall a b m n m' n' : Z,
+ (0 <= a * m + b * n)%Z ->
+ (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z.
+Proof.
+ intros.
+ replace (a * (m + m') + b * (n + n'))%Z with
+  (a * m + b * n + (a * m' + b * n'))%Z.
+ apply Zplus_le_0_compat.
+ assumption.
+ assumption.
+ ring.
+Qed. 
+
+Lemma fraction_lt_trans :
+ forall a b c d e f : Z,
+ (0 < b)%Z ->
+ (0 < d)%Z ->
+ (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z.
+Proof.
+ intros.
+ apply Zgt_lt.
+ apply Zgt_mult_reg_absorb_l with d.
+ Flip.
+ apply Zgt_trans with (c * b * f)%Z.
+ replace (d * (e * b))%Z with (b * (e * d))%Z.
+ replace (c * b * f)%Z with (b * (c * f))%Z.
+ apply Zlt_gt.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+ ring.
+ ring.
+ replace (c * b * f)%Z with (f * (c * b))%Z.  
+ replace (d * (a * f))%Z with (f * (a * d))%Z.
+ apply Zlt_gt.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z.
+Proof.
+ intros [| p| p]; intros; [ Falsum | constructor | constructor ].
+Qed.
+ 
+Hint Resolve square_pos: zarith.
+
+(*###########################################################################*)
+(** Properties of positive numbers, mapping between Z and nat                *)
+(*###########################################################################*)
+
+
+Definition Z2positive (z : Z) :=
+  match z with
+  | Zpos p => p
+  | Zneg p => p
+  | Z0 => 1%positive
+  end.
+
+
+Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*)
+Proof.
+ intro.
+ cut (exists h : nat, nat_of_P p = S h).
+ intro.
+ case H.
+ intros.
+ unfold Z_of_nat in |- *.
+ rewrite H0.
+ 
+ apply f_equal with (A := positive) (B := Z) (f := Zpos).
+ cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)).
+ intro.
+ rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1.
+ cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))).
+ intro.
+ rewrite Ppred_succ in H2.
+ simpl in H2.
+ rewrite Ppred_succ in H2.
+ apply sym_eq.
+ assumption.
+ apply f_equal with (A := positive) (B := positive) (f := Ppred).
+ assumption.
+ apply f_equal with (f := P_of_succ_nat).
+ assumption.
+ apply ZL4.
+Qed.
+
+Coercion Z_of_nat : nat >-> Z.
+
+Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z.
+Proof.
+ intros.
+ constructor.
+Qed.
+
+
+Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z.
+Proof.
+ intros.
+ apply sym_not_eq.
+ apply Zorder.Zlt_not_eq.
+ apply ZERO_lt_POS.
+Qed.
+
+Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z.
+Proof.
+ intros.
+ apply Zorder.Zlt_not_eq.
+ unfold Zlt in |- *.
+ constructor.
+Qed.
+
+
+Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1.
+Proof.
+ intros.
+ injection H.
+ trivial.
+Qed.
+
+Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*)
+Proof.
+ intros.
+ apply Zlt_gt.
+ cut (Z_of_nat m + 1 > 0)%Z.
+ intro.
+ cut (0 < Z_of_nat n + 1)%Z.
+ intro.
+ cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z.
+ rewrite Zmult_0_r.
+ intro.
+ assumption.
+ 
+ apply Zlt_reg_mult_l.
+ assumption.
+ assumption.
+ change (0 < Zsucc (Z_of_nat n))%Z in |- *.
+ apply Zle_lt_succ.
+ change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *.
+ apply Znat.inj_le.
+ apply le_O_n.
+ apply Zlt_gt.
+ change (0 < Zsucc (Z_of_nat m))%Z in |- *.
+ apply Zle_lt_succ.
+ change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *.
+ apply Znat.inj_le.
+ apply le_O_n.
+Qed.
+ 
+ 
+Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*)
+Proof.
+ intros.
+ case (O_or_S m).
+ intro.
+ case s.
+ intros.
+ rewrite <- e. 
+ rewrite <- pred_Sn with (n := x). 
+ trivial.
+ intro.
+ apply False_ind.
+ apply H.
+ apply sym_eq.
+ assumption.
+Qed.
+
+Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*)
+Proof.
+ intros.
+ case (dec_eq x 0).
+ intro.
+ assumption.
+ intro.
+ apply False_ind.
+ cut ((x < 0)%Z \/ (x > 0)%Z).
+ intro.
+ ElimCompare x 0%Z.
+ intro.
+ cut (x = 0%Z).
+ assumption.
+ cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z).
+ intro.
+ apply H3.
+ assumption.
+ apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq).
+ change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *.
+ apply Zcompare_Eq_iff_eq.
+ 
+ (***)
+ intro.
+ cut (exists h : nat, Zabs_nat x = S h).
+ intro.
+ case H3.
+ rewrite H.
+ exact O_S.
+ 
+ change (x < 0)%Z in H2.
+ cut (0 > x)%Z.
+ intro.
+ cut (exists p : positive, (0 + - x)%Z = Zpos p).
+ simpl in |- *.
+ intro.
+ case H4.
+ intros.
+ cut (exists q : positive, x = Zneg q).
+ intro.
+ case H6.
+ intros.
+ rewrite H7.
+ unfold Zabs_nat in |- *.
+ generalize x1.
+ exact ZL4.
+ cut (x = (- Zpos x0)%Z).
+ simpl in |- *.
+ intro.
+ exists x0.
+ assumption.
+ cut ((- - x)%Z = x).
+ intro.
+ rewrite <- H6.
+ exact (f_equal Zopp H5). 
+ apply Zopp_involutive.
+ apply Zcompare_Gt_spec.
+ assumption.
+ apply Zlt_gt.
+ assumption.
+ 
+ (***)
+ intro.
+ cut (exists h : nat, Zabs_nat x = S h).
+ intro.
+ case H3.
+ rewrite H.
+ exact O_S.
+ 
+ cut (exists p : positive, (x + - (0))%Z = Zpos p).
+ simpl in |- *.
+ rewrite Zplus_0_r.
+ intro.
+ case H3.
+ intros.
+ rewrite H4.
+ unfold Zabs_nat in |- *.
+ generalize x0.
+ exact ZL4.
+ apply Zcompare_Gt_spec.
+ assumption.
+ 
+ (***)
+ cut ((x < 0)%Z \/ (0 < x)%Z).
+ intro.
+ apply
+  or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zlt_gt.
+ assumption.
+ assumption.
+ apply not_Zeq.
+ assumption.
+Qed.
+
+Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*)
+Proof.
+ intros.
+ intro.
+ apply H.
+ apply absolu_1.
+ assumption.
+Qed.
+
+
+
+
+Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n.
+Proof.
+ simple induction n; simpl in |- *.
+ reflexivity.
+ intros.
+ apply nat_of_P_o_P_of_succ_nat_eq_succ.
+Qed.
+
+
+Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n.
+Proof.
+ intros.
+ generalize (f_equal Zabs_nat H). 
+ intro.
+ rewrite (absolu_inject_nat m) in H0.
+ rewrite (absolu_inject_nat n) in H0.
+ assumption.
+Qed.
+
+Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+
+Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}.
+Proof.
+ intros [| p| p] Hp; try discriminate Hp.
+ exists (pred (nat_of_P p)).
+ rewrite S_predn.
+ symmetry  in |- *; apply ZL9.
+ clear Hp;
+  apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P.
+Qed.
+
+
+
+Lemma le_absolu :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy Hxy;
+  apply le_O_n ||
+    (try
+      match goal with
+      | id1:(0 <= Zneg _)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      | id1:(Zpos _ <= 0)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      end).
+ simpl in |- *. 
+ apply le_inj.
+ do 2 rewrite ZL9.
+ assumption.
+Qed.
+
+Lemma lt_absolu :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy;
+  try
+   match goal with
+   | id1:(0 <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= 0)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; 
+  assumption.
+Qed.
+
+Lemma absolu_plus :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy; trivial;
+  try
+   match goal with
+   | id1:(0 <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= 0)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   end.
+ rewrite <- BinInt.Zpos_plus_distr.
+ unfold Zabs_nat in |- *.
+ apply nat_of_P_plus_morphism.
+Qed.
+
+Lemma pred_absolu :
+ forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1).
+Proof.
+ intros x Hx.
+ generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1];
+  [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1));
+     [ idtac | apply f_equal with Z; auto with zarith ];
+     rewrite absolu_plus;
+     [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega
+     | auto with zarith
+     | intro; discriminate ]
+  | rewrite <- H1; reflexivity ].
+Qed. 
+
+Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat.
+intros [| px| px] Hx; try abstract (discriminate Hx).
+exact (pred (nat_of_P px)).
+Defined.
+
+Lemma pred_nat_equal :
+ forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2.
+Proof.
+ intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial.
+Qed.
+
+Let pred_nat_unfolded_subproof px :
+  Pos.to_nat px <> 0.
+Proof.
+apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P.
+Qed.
+
+Lemma pred_nat_unfolded :
+ forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx).
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite S_predn.
+ symmetry  in |- *; apply ZL9.
+ clear Hx; apply pred_nat_unfolded_subproof.
+Qed.
+
+Lemma absolu_pred_nat :
+ forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m.
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite S_predn.
+ reflexivity.
+ apply pred_nat_unfolded_subproof.
+Qed.
+
+Lemma pred_nat_absolu :
+ forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1).
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite <- pred_absolu; reflexivity || assumption.
+Qed.
+
+Lemma minus_pred_nat :
+ forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z),
+ S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm).
+Proof.
+ intros.
+ simpl in |- *.  
+ destruct n; try discriminate Hn.
+ destruct m; try discriminate Hm.
+ unfold pred_nat at 1 2 in |- *.
+ rewrite minus_pred; try apply lt_O_nat_of_P.
+ apply eq_inj.
+ rewrite <- pred_nat_unfolded. 
+ rewrite Znat.inj_minus1.
+ repeat rewrite ZL9. 
+ reflexivity.
+ apply le_inj.
+ apply Zlt_le_weak.
+ repeat rewrite ZL9.
+ apply Zlt_O_minus_lt.
+ assumption.
+Qed.
+
+
+(*###########################################################################*)
+(** Properties of Zsgn                                                       *)
+(*###########################################################################*)
+
+
+Lemma Zsgn_1 :
+ forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*)
+Proof.
+ intros.
+ case x.
+ left.
+ left.
+ unfold Zsgn in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ left.
+ right.
+ reflexivity.
+ intro.
+ right.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z.   (*QF*)
+Proof.
+ intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H.
+Qed.
+
+
+Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z.   (*QF*)
+Proof.
+ intro.
+ case x.
+ intros.
+ apply False_ind.
+ apply H.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ discriminate.
+ intros.
+ simpl in |- *.
+ discriminate.
+Qed.
+
+
+
+
+Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z.  (*QF*)
+Proof.
+ intro.
+ case a.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ unfold Zsgn in |- *.
+ unfold Zabs_nat in |- *.
+ rewrite Zmult_1_l.
+ symmetry  in |- *.
+ apply ZL9.
+ intros.
+ unfold Zsgn in |- *.
+ unfold Zabs_nat in |- *.
+ rewrite ZL9.
+ constructor.
+Qed.
+
+
+Theorem Zsgn_5 :
+ forall a b x y : Z,
+ x <> 0%Z ->
+ y <> 0%Z ->
+ (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z.  (*QF*)
+Proof.
+ intros a b x y H H0.
+ case a.
+
+ case b.
+ simpl in |- *.
+ trivial.
+
+ intro.
+ unfold Zsgn in |- *.
+ intro.
+ rewrite Zmult_1_l in H1.
+ simpl in H1.
+ apply False_ind.
+ apply H0.
+ symmetry  in |- *.
+ assumption.
+ intro.
+ unfold Zsgn in |- *.
+ intro.
+ apply False_ind.
+ apply H0.
+ apply Zopp_inj.
+ simpl in |- *.
+ transitivity (-1 * y)%Z.
+ constructor.
+ transitivity (0 * x)%Z.
+ symmetry  in |- *.
+ assumption.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ unfold Zsgn at 1 in |- *.
+ unfold Zsgn at 2 in |- *.
+ intro.
+ transitivity y.
+ rewrite Zmult_1_l.
+ reflexivity.
+ transitivity (Zsgn b * (Zsgn b * y))%Z.
+ case (Zsgn_1 b).
+ intro.
+ case s.
+ intro.
+ apply False_ind.
+ apply H.
+ rewrite e in H1.
+ change ((1 * x)%Z = 0%Z) in H1.
+ rewrite Zmult_1_l in H1.
+ assumption.
+ intro.
+ rewrite e.
+ rewrite Zmult_1_l.
+ rewrite Zmult_1_l.
+ reflexivity.
+ intro.
+ rewrite e.
+ ring.
+ rewrite Zmult_1_l in H1.
+ rewrite H1.
+ reflexivity.
+ intro.
+ unfold Zsgn at 1 in |- *.
+ unfold Zsgn at 2 in |- *.
+ intro.
+ transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z.
+ case (Zsgn_1 b).
+ intros.
+ case s.
+ intro.
+ apply False_ind.
+ apply H.
+ apply Zopp_inj.
+ transitivity (-1 * x)%Z.
+ ring.
+ unfold Zopp in |- *.
+ rewrite e in H1.
+ transitivity (0 * y)%Z.
+ assumption.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ rewrite e.
+ ring.
+ intro.
+ rewrite e.
+ ring.
+ rewrite <- H1.
+ ring.
+Qed.
+
+Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z.
+Proof.
+ intros.
+ rewrite H.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ Flip.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ apply False_ind.
+ apply (Zlt_irrefl (Zneg p)).
+ apply Zlt_trans with 0%Z.
+ constructor.
+ Flip.
+Qed.
+
+
+Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z.
+Proof.
+ intros; apply Zsgn_7; Flip.
+Qed.
+
+
+Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ assumption.
+ intros.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ apply Zlt_trans with (Zpos p).
+ constructor.
+ assumption.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ simpl in H.
+ discriminate.
+ intros.
+ constructor.
+ intros.
+ apply False_ind.
+ discriminate.
+Qed.
+ 
+Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ discriminate.
+ intros.
+ apply False_ind.
+ discriminate.
+ intros.
+ constructor.
+Qed. 
+
+Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z.
+Proof.
+ intros.
+ apply Zsgn_10.
+ case (Zsgn_1 x).
+ intro.
+ apply False_ind.
+ case s.
+ intro.
+ generalize (Zorder.Zlt_not_eq _ _ H). 
+ intro.
+ apply (H0 e).
+ intro.
+ rewrite e in H.
+ generalize (Zorder.Zlt_not_eq _ _ H).
+ intro.
+ discriminate.
+ trivial.
+Qed. 
+
+Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z.
+Proof.
+ intros.
+ apply Zsgn_9.
+ case (Zsgn_1 x).
+ intro.
+ case s.
+ intro.
+ generalize (Zorder.Zlt_not_eq _ _ H). 
+ intro.
+ generalize (sym_eq e).
+ intro.
+ apply False_ind.
+ apply (H0 H1).
+ trivial.
+ intro.
+ rewrite e in H.
+ generalize (Zorder.Zlt_not_eq _ _ H).
+ intro.
+ apply False_ind.
+ discriminate.
+Qed.   
+
+Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z.
+Proof.
+ intros. 
+ case (Z_le_lt_eq_dec 0 (Zsgn x) H).
+ intro.
+ apply Zlt_le_weak.
+ apply Zsgn_12.
+ assumption. 
+ intro.
+ assert (x = 0%Z). 
+ apply Zsgn_2.
+ symmetry  in |- *.
+ assumption.
+ rewrite H0.
+ apply Zle_refl.
+Qed.
+
+Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z.
+Proof.
+ intros. 
+ case (Z_le_lt_eq_dec (Zsgn x) 0 H).
+ intro.
+ apply Zlt_le_weak.
+ apply Zsgn_11.
+ assumption. 
+ intro.
+ assert (x = 0%Z). 
+ apply Zsgn_2.
+ assumption.
+ rewrite H0.
+ apply Zle_refl.
+Qed.
+
+Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor.
+Qed.
+
+Lemma Zsgn_16 :
+ forall x y : Z,
+ Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right ]; repeat split.
+Qed. 
+
+Lemma Zsgn_17 :
+ forall x y : Z,
+ Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right ]; repeat split.
+Qed. 
+
+Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right | right ]; constructor.
+Qed. 
+
+
+
+Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  discriminate H || (constructor || apply Zsgn_12; assumption).
+Qed.
+
+Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  discriminate H || (constructor || apply Zsgn_11; assumption).
+Qed.
+
+
+Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0;
+  discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0;
+  discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z.
+Proof.
+ intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *;
+  intros H H0; discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z.
+Proof.
+ intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *;
+  intros H H0; discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z.
+Proof.
+ intros [| p1| p1]; simpl in |- *; reflexivity.
+Qed.
+
+
+Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z.
+Proof.
+ intros [| p| p] Hp; trivial.
+Qed.
+
+Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z.
+Proof.
+ intros [| p| p] Hp; trivial.
+Qed.
+
+Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8
+  Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17
+  Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26
+  Zsgn_27: zarith.
+
+(*###########################################################################*)
+(** Properties of Zabs                                                       *)
+(*###########################################################################*)
+
+Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z.
+Proof.
+ intros z p.
+ case z.
+ intros.
+ simpl in H.
+ split.
+ assumption.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl; trivial.
+ ring_simplify (-1 * - p)%Z (-1 * 0)%Z.
+ apply Zlt_gt.
+ assumption.
+
+ intros.
+ simpl in H.
+ split.
+ assumption.
+ apply Zlt_trans with (m := 0%Z).
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl; trivial.
+ ring_simplify (-1 * - p)%Z (-1 * 0)%Z.
+ apply Zlt_gt.
+ apply Zlt_trans with (m := Zpos p0).
+ constructor.
+ assumption.
+ constructor.
+
+ intros.
+ simpl in H.
+ split.
+ apply Zlt_trans with (m := Zpos p0).
+ constructor.
+ assumption.
+ 
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl;trivial.
+ ring_simplify (-1 * - p)%Z.
+ replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z.
+ replace (- Zneg p0)%Z with (Zpos p0). 
+ apply Zlt_gt.
+ assumption.
+ symmetry  in |- *.
+ apply Zopp_neg.
+ rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). 
+ simpl in |- *.
+ constructor.
+Qed.
+
+
+Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z.
+Proof.
+ intros z p.
+ case z.
+ intros.
+ simpl in H.
+ left.
+ assumption.
+
+ intros.
+ simpl in H.
+ left.
+ assumption.
+
+ intros.
+ simpl in H.
+ right.
+ apply Zlt_gt.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ ring_simplify (-1 * - p)%Z.
+ replace (-1 * Zneg p0)%Z with (Zpos p0).
+ assumption.
+ reflexivity.
+Qed.
+
+Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z.
+Proof.
+ intros z p.
+ case z.
+  intro. 
+  simpl in |- *.
+  elim H.
+  intros.
+  assumption.
+  
+  intros.
+  elim H.
+  intros.
+  simpl in |- *.
+  assumption.
+  
+  intros.
+  elim H.
+  intros.
+  simpl in |- *.
+  apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+  constructor.
+  replace (-1 * Zpos p0)%Z with (Zneg p0).
+  replace (-1 * p)%Z with (- p)%Z.
+  apply Zlt_gt.
+  assumption.
+  ring.  
+  simpl in |- *.
+  reflexivity.
+Qed.
+
+Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z.
+Proof.
+ intros.
+ split.
+ apply proj2 with (A := (z < p)%Z).
+ apply Zabs_1.
+ assumption.
+ apply proj1 with (B := (- p < z)%Z).
+ apply Zabs_1.
+ assumption.
+Qed.
+ 
+
+Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z.
+Proof.
+ intros.
+ split.
+ replace (- p)%Z with (Zsucc (- Zsucc p)).
+ apply Zlt_le_succ.
+ apply proj2 with (A := (z < Zsucc p)%Z).
+ apply Zabs_1.
+ apply Zle_lt_succ.
+ assumption.
+ unfold Zsucc in |- *.
+ ring.
+ apply Zlt_succ_le.
+ apply proj1 with (B := (- Zsucc p < z)%Z).
+ apply Zabs_1.
+ apply Zle_lt_succ.
+ assumption.
+Qed.
+
+Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z.
+Proof.
+ intros.
+ apply proj2 with (A := (- p <= z)%Z).
+ apply Zabs_5.
+ assumption.
+Qed.
+
+Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z.
+Proof.
+ intros.
+ apply proj1 with (B := (z <= p)%Z).
+ apply Zabs_5.
+ assumption.
+Qed.
+
+Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z.
+Proof.
+ intros.
+ apply Zlt_succ_le.
+ apply Zabs_3.
+ elim H.
+ intros.
+ split.
+ apply Zle_lt_succ.
+ assumption.
+ apply Zlt_le_trans with (m := (- p)%Z).
+ apply Zgt_lt. 
+ apply Zlt_opp.
+ apply Zlt_succ.
+ assumption.
+Qed.
+
+Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z).
+Proof.
+ intro.
+ case z.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zabs_9 :
+ forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z.
+Proof.
+ intros.
+ case H0.
+ intro.
+ replace (Zabs z) with z.
+ assumption.
+ symmetry  in |- *.
+ apply Zabs_eq.
+ apply Zlt_le_weak.
+ apply Zle_lt_trans with (m := p).
+ assumption.
+ assumption.
+ intro.
+ cut (Zabs z = (- z)%Z).
+ intro.
+ rewrite H2.
+ apply Zmin_cancel_Zlt.
+ ring_simplify (- - z)%Z.
+ assumption.
+ rewrite Zabs_min.
+ apply Zabs_eq.
+ apply Zlt_le_weak.
+ apply Zle_lt_trans with (m := p).
+ assumption.
+ apply Zmin_cancel_Zlt.
+ ring_simplify (- - z)%Z.
+ assumption.
+Qed.
+
+Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z.
+Proof.
+ intro.
+ case (Z_zerop z).
+ intro.
+ rewrite e.
+ simpl in |- *.
+ apply Zle_refl.
+ intro.
+ case (not_Zeq z 0 n).
+ intro.
+ apply Zlt_le_weak.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ right.
+ assumption.
+ intro.
+ apply Zlt_le_weak.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ left.
+ assumption.
+Qed.
+
+Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z.
+Proof.
+ intros.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ apply not_Zeq.
+ intro.
+ apply H.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}.
+Proof.
+ intros [| p| p] m; simpl in |- *; intros H;
+  [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ];
+  assumption.
+Qed.
+
+Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z.
+Proof.
+ intros.
+ case z.
+ simpl in |- *.
+ reflexivity.
+ case p.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ case p.
+ intro.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z.
+Proof.
+ intros.
+ case z.
+ simpl in |- *.
+ apply Zle_refl.
+ case p.
+ intro.
+ simpl in |- *.
+ apply Zle_refl.
+ intros.
+ simpl in |- *.
+ apply Zle_refl.
+ intros.
+ unfold Zabs at 2 in |- *.
+ unfold Zabs at 2 in |- *.
+ apply Zabs_8.
+ split.
+ apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z.
+ replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with
+  (- (Zpos p0 + Zneg p0))%Z.
+ replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z.
+ replace (- (Zpos p0 + Zneg p0))%Z with 0%Z.
+ apply Zmult_gt_0_le_0_compat.
+ constructor.
+ apply Zlt_le_weak.
+ constructor.
+ rewrite <- Zopp_neg with p0.
+ ring.
+ ring.
+ ring.
+ apply Zplus_le_compat.
+ apply Zle_refl.
+ apply Zlt_le_weak.
+ constructor.
+ 
+ case p.
+ simpl in |- *.
+ intro.
+ apply Zle_refl.
+ intros.
+ unfold Zabs at 2 in |- *.
+ unfold Zabs at 2 in |- *.
+ apply Zabs_8.
+ split.
+ apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z.
+ replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with
+  (Zneg p0 - Zpos p0)%Z.
+ replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z.
+ apply Zplus_le_reg_l with (Zpos p0).
+ replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0).
+ simpl in |- *.
+ apply Zlt_le_weak.
+ constructor.
+ ring.
+ replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with
+  (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z.
+ replace 0%Z with (0 + 0)%Z.
+ apply Zplus_eq_compat.
+ rewrite <- Zopp_neg with p1.
+ ring.
+ rewrite <- Zopp_neg with p0.
+ ring.
+ simpl in |- *.
+ constructor.
+ ring.
+ ring.
+ apply Zplus_le_compat.
+ apply Zlt_le_weak.
+ constructor.
+ apply Zle_refl.
+ intros.
+ simpl in |- *.
+ apply Zle_refl.
+Qed.
+
+Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z.
+Proof.
+ intro.
+ case z.
+ simpl in |- *.
+ intro.
+ reflexivity.
+ intros.
+ apply False_ind.
+ apply H.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z.
+Proof.
+ intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. 
+Qed.
+ 
+Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9
+  Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith.
+
+
+(*###########################################################################*)
+(** Induction on Z                                                           *)
+(*###########################################################################*)
+
+Lemma Zind :
+ forall (P : Z -> Prop) (p : Z),
+ P p ->
+ (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) ->
+ forall q : Z, (p <= q)%Z -> P q. 
+Proof.
+ intros P p.
+ intro.
+ intro.
+ cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z).
+ intro.
+ cut (forall k : nat, P (p + k)%Z).
+ intro.
+ intros.
+ cut (exists k : nat, q = (p + Z_of_nat k)%Z).
+ intro.
+ case H4.
+ intros.
+ rewrite H5.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ ring_simplify (p + 0)%Z.
+ assumption.
+ replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (Z_of_nat 0). 
+ ring_simplify (- p + (p + Z_of_nat k))%Z.
+ apply Znat.inj_le.
+ apply le_O_n.
+ ring_simplify; auto with arith. 
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ ring.
+ intros.
+ cut (exists k : nat, (q - p)%Z = Z_of_nat k).
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + q)%Z with (q - p)%Z.
+ rewrite H3.
+ ring.
+ ring.
+ apply Z_of_nat_complete.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec :
+ forall (P : Z -> Set) (p : Z),
+ P p ->
+ (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) ->
+ forall q : Z, (p <= q)%Z -> P q. 
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}).
+ intro.
+ cut (forall k : nat, F (p + k)%Z).
+ intro.
+ intros.
+ cut {k : nat | q = (p + Z_of_nat k)%Z}.
+ intro.
+ case H4.
+ intros.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ rewrite Zplus_0_r.
+ assumption.
+ replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (Z_of_nat 0). 
+ replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k).
+ apply Znat.inj_le.
+ apply le_O_n.
+ rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ rewrite Zplus_opp_l; reflexivity.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ apply Zplus_assoc_reverse.
+ intros.
+ cut {k : nat | (q - p)%Z = Z_of_nat k}.
+ intro H2.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + q)%Z with (q - p)%Z.
+ rewrite e.
+ rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ unfold Zminus in |- *.
+ apply Zplus_comm.
+ apply Z_of_nat_complete_inf.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec_down :
+ forall (P : Z -> Set) (p : Z),
+ P p ->
+ (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) ->
+ forall q : Z, (q <= p)%Z -> P q.
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}).
+ intro.
+ cut (forall k : nat, F (p - k)%Z).
+ intro.
+ intros.
+ cut {k : nat | q = (p - Z_of_nat k)%Z}.
+ intro.
+ case H4.
+ intros.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ replace (p - 0)%Z with p.
+ assumption.
+ unfold Zminus in |- *.
+ unfold Zopp in |- *.
+ rewrite Zplus_0_r; reflexivity.
+ replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (- Z_of_nat 0)%Z. 
+ replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z.
+ apply Zge_le.
+ apply Zge_opp.
+ apply Znat.inj_le.
+ apply le_O_n.
+ unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ rewrite Zplus_opp_l; reflexivity.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ unfold Zminus at 1 2 in |- *.
+ rewrite Zplus_assoc_reverse.
+ rewrite <- Zopp_plus_distr.
+ reflexivity.
+ intros.
+ cut {k : nat | (p - q)%Z = Z_of_nat k}.
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zopp_inj. 
+ apply Zplus_reg_l with (n := p).
+ replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). 
+ rewrite <- e.
+ reflexivity.
+ unfold Zminus in |- *.
+ rewrite Zopp_plus_distr.
+ rewrite Zplus_assoc.
+ rewrite Zplus_opp_r.
+ rewrite Zopp_involutive.
+ reflexivity.
+ apply Z_of_nat_complete_inf.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zind_down :
+ forall (P : Z -> Prop) (p : Z),
+ P p ->
+ (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) ->
+ forall q : Z, (q <= p)%Z -> P q.
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z).
+ intro.
+ cut (forall k : nat, F (p - k)%Z).
+ intro.
+ intros.
+ cut (exists k : nat, q = (p - Z_of_nat k)%Z).
+ intro.
+ case H4.
+ intros x e.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ replace (p - 0)%Z with p.
+ assumption.
+ ring.
+ replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (- Z_of_nat 0)%Z. 
+ replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z.
+ apply Zge_le.
+ apply Zge_opp.
+ apply Znat.inj_le.
+ apply le_O_n.
+ ring. 
+ ring_simplify; auto with arith.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ ring.
+ intros.
+ cut (exists k : nat, (p - q)%Z = Z_of_nat k).
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zopp_inj. 
+ apply Zplus_reg_l with (n := p).
+ replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). 
+ rewrite <- H3.
+ ring.
+ ring.
+ apply Z_of_nat_complete.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec_wf :
+ forall (P : Z -> Set) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ forall q : Z, (p <= q)%Z -> P q.
+Proof.
+ intros P p WF_ind_step q Hq.
+ cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y).
+ intro.
+ apply (H (Zsucc q)).
+ apply Zle_le_succ.
+ assumption.
+ 
+ split; [ assumption | exact (Zlt_succ q) ].
+
+ intros x0 Hx0; generalize Hx0; pattern x0 in |- *. 
+ apply Zrec with (p := p).
+ intros.
+ absurd (p <= p)%Z.
+ apply Zgt_not_le.
+ apply Zgt_le_trans with (m := y).
+ apply Zlt_gt.
+ elim H.
+ intros.
+ assumption.
+ elim H.
+ intros.
+ assumption.
+ apply Zle_refl.
+
+ intros. 
+ apply WF_ind_step. 
+ intros.
+ apply (H0 H).
+ split. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zlt_le_trans with y. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zgt_succ_le. 
+ apply Zlt_gt. 
+ elim H1.
+ intros.
+ unfold Zsucc in |- *.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zrec_wf2 :
+ forall (q : Z) (P : Z -> Set) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ (p <= q)%Z -> P q.
+Proof.
+ intros.
+ apply Zrec_wf with (p := p).
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zrec_wf_double :
+ forall (P : Z -> Z -> Set) (p0 q0 : Z),
+ (forall n m : Z,
+  (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) ->
+  (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) ->
+ forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q.
+Proof.
+ intros P p0 q0 Hrec p.
+ intros.
+ generalize q H.
+ pattern p in |- *.
+ apply Zrec_wf with (p := p0).
+ intros p1 H1.
+ intros.
+ pattern q1 in |- *.
+ apply Zrec_wf with (p := q0).
+ intros q2 H3.
+ apply Hrec.
+ intros.
+ apply H1.
+ assumption.
+ assumption.
+ intros.
+ apply H3.
+ assumption.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf :
+ forall (P : Z -> Prop) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ forall q : Z, (p <= q)%Z -> P q.
+Proof.
+ intros P p WF_ind_step q Hq.
+ cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y).
+ intro.
+ apply (H (Zsucc q)).
+ apply Zle_le_succ.
+ assumption.
+ 
+ split; [ assumption | exact (Zlt_succ q) ].
+
+ intros x0 Hx0; generalize Hx0; pattern x0 in |- *. 
+ apply Zind with (p := p).
+ intros.
+ absurd (p <= p)%Z.
+ apply Zgt_not_le.
+ apply Zgt_le_trans with (m := y).
+ apply Zlt_gt.
+ elim H.
+ intros.
+ assumption.
+ elim H.
+ intros.
+ assumption.
+ apply Zle_refl.
+
+ intros. 
+ apply WF_ind_step. 
+ intros.
+ apply (H0 H).
+ split. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zlt_le_trans with y. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zgt_succ_le. 
+ apply Zlt_gt. 
+ elim H1.
+ intros.
+ unfold Zsucc in |- *.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf2 :
+ forall (q : Z) (P : Z -> Prop) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ (p <= q)%Z -> P q.
+Proof.
+ intros.
+ apply Zind_wf with (p := p).
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf_double :
+ forall (P : Z -> Z -> Prop) (p0 q0 : Z),
+ (forall n m : Z,
+  (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) ->
+  (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) ->
+ forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q.
+Proof.
+ intros P p0 q0 Hrec p.
+ intros.
+ generalize q H.
+ pattern p in |- *.
+ apply Zind_wf with (p := p0).
+ intros p1 H1.
+ intros.
+ pattern q1 in |- *.
+ apply Zind_wf with (p := q0).
+ intros q2 H3.
+ apply Hrec.
+ intros.
+ apply H1.
+ assumption.
+ assumption.
+ intros.
+ apply H3.
+ assumption.
+ assumption.
+ assumption.
+Qed.
+
+(*###########################################################################*)
+(** Properties of Zmax                                                       *)
+(*###########################################################################*)
+
+Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z.
+
+Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1).
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z.
+ ring.
+ symmetry  in |- *.
+ change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *.
+ symmetry  in |- *.
+ apply Zmin_SS.
+Qed.
+
+Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z).
+ ring_simplify (- n + Zmin n m + n)%Z.
+ ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z.
+ apply Zle_min_r.
+Qed.
+
+Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z).
+ ring_simplify (- m + Zmin n m + m)%Z.
+ ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z.
+ apply Zle_min_l.
+Qed.
+
+
+Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec n m).
+ unfold Zmin in |- *.
+ unfold Zlt in |- *.
+ intro z.
+ rewrite z.
+ left.
+ reflexivity.
+ intro.
+ cut ({(n > m)%Z} + {n = m :>Z}).
+ intro.
+ case H.
+ intros z0.
+ unfold Zmin in |- *.
+ unfold Zgt in z0.
+ rewrite z0.
+ right.
+ reflexivity.
+ intro.
+ rewrite e.
+ right.
+ apply Zmin_n_n.
+ cut ({(m < n)%Z} + {m = n :>Z}).
+ intro.
+ elim H.
+ intro.
+ left.
+ apply Zlt_gt.
+ assumption.
+ intro.
+ right.
+ symmetry  in |- *.
+ assumption.
+ apply Z_le_lt_eq_dec. 
+ apply Zge_le.
+ assumption.
+Qed.
+
+Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m).
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ case Zmin_or_informative with (n := n) (m := m).
+ intro.
+ rewrite e.
+ cut ((n + m - n)%Z = m).
+ intro.
+ rewrite H1.
+ assumption.
+ ring.
+ intro.
+ rewrite e.
+ cut ((n + m - m)%Z = n).
+ intro.
+ rewrite H1.
+ assumption.
+ ring.
+Qed.
+ 
+Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. 
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ case Zmin_or_informative with (n := n) (m := m).
+ intro.
+ rewrite e.
+ right.
+ ring.
+ intro.
+ rewrite e.
+ left.
+ ring.
+Qed.
+
+Lemma Zmax_n_n : forall n : Z, Zmax n n = n.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ rewrite (Zmin_n_n n).
+ ring.
+Qed.
+
+Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith.
+
+(*###########################################################################*)
+(** Properties of Arity                                                      *)
+(*###########################################################################*)
+
+Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1).
+Proof.
+ exact Zeven.Zeven_Sn.
+Qed.
+
+Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). 
+Proof.
+ exact Zeven.Zeven_pred.
+Qed.
+
+(* This lemma used to be useful since it was mentioned with an unnecessary premise 
+   `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *)
+
+Definition Z_modulo_2_always :
+  forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} :=
+  Zeven.Z_modulo_2.
+
+(*###########################################################################*)
+(** Properties of Zdiv                                                       *)
+(*###########################################################################*)
+
+Lemma Z_div_mod_eq_2 :
+ forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z.
+Proof.
+ intros.
+ apply Zplus_minus_eq.
+ rewrite Zplus_comm.
+ apply Z_div_mod_eq.
+ Flip.
+Qed.
+
+Lemma Z_div_le :
+ forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. 
+Proof.
+ intros.
+ apply Zge_le.
+ apply Z_div_ge; Flip; assumption.
+Qed.
+
+Lemma Z_div_nonneg :
+ forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z.
+Proof.
+ intros.
+ apply Zge_le.
+ apply Z_div_ge0; Flip; assumption.
+Qed.
+
+Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z.
+Proof.
+ intros.
+ rewrite (Z_div_mod_eq a b) in H0.
+ elim (Z_mod_lt a b).
+ intros H1 _.
+ apply Znot_ge_lt.
+ intro.
+ apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0).
+ apply Zplus_le_0_compat.
+ apply Zmult_le_0_compat. 
+ apply Zlt_le_weak; assumption.
+ Flip.
+ assumption.
+ Flip.
+ Flip.
+Qed.
+
+Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith.
+
+(*###########################################################################*)
+(** Properties of Zpower                                                       *)
+(*###########################################################################*)
+
+Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a.
+Proof.
+ intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *;
+  auto with zarith.
+Qed.
+
+Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z.
+Proof.
+ intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *;
+  ring.
+Qed.
+
+Hint Resolve Zpower_1 Zpower_2: zarith.
diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v
index d648c2e4..25e4a09f 100644
--- a/test-suite/micromega/example.v
+++ b/test-suite/micromega/example.v
@@ -2,13 +2,12 @@
 (*                                                                      *)
 (* Micromega: A reflexive tactic using the Positivstellensatz           *)
 (*                                                                      *)
-(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
+(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
 (*                                                                      *)
 (************************************************************************)
 
 Require Import ZArith.
 Require Import Psatz.
-Require Import Ring_normalize.
 Open Scope Z_scope.
 Require Import ZMicromega.
 Require Import VarMap.
@@ -23,7 +22,7 @@ Proof.
 Qed.
 
 
-(* From Laurent Théry *)
+(* From Laurent Théry *)
 
 Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0.
 Proof.
diff --git a/test-suite/micromega/heap3_vcgen_25.v b/test-suite/micromega/heap3_vcgen_25.v
index efb5c7fd..00522f50 100644
--- a/test-suite/micromega/heap3_vcgen_25.v
+++ b/test-suite/micromega/heap3_vcgen_25.v
@@ -7,7 +7,7 @@
 (************************************************************************)
 
 Require Import ZArith.
-Require Import Psatz.
+Require Import Lia.
 
 Open Scope Z_scope.
 
diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v
index 76dc52e6..47e6005b 100644
--- a/test-suite/micromega/qexample.v
+++ b/test-suite/micromega/qexample.v
@@ -8,7 +8,6 @@
 
 Require Import Psatz.
 Require Import QArith.
-Require Import Ring_normalize.
 
 Lemma plus_minus : forall x y,
   0 == x + y -> 0 ==  x -y -> 0 == x /\ 0 == y.
diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v
index 9bb9dacc..2eed7e95 100644
--- a/test-suite/micromega/rexample.v
+++ b/test-suite/micromega/rexample.v
@@ -8,7 +8,6 @@
 
 Require Import Psatz.
 Require Import Reals.
-Require Import Ring_normalize.
 
 Open Scope R_scope.
 
diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v
index 3b246023..0ec1dbfb 100644
--- a/test-suite/micromega/zomicron.v
+++ b/test-suite/micromega/zomicron.v
@@ -1,5 +1,5 @@
 Require Import ZArith.
-Require Import Psatz.
+Require Import Lia.
 Open Scope Z_scope.
 
 Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False.
diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v
index 9f01c565..219686b9 100644
--- a/test-suite/misc/berardi_test.v
+++ b/test-suite/misc/berardi_test.v
@@ -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/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v
index 341805a1..7214287a 100644
--- a/test-suite/modules/Przyklad.v
+++ b/test-suite/modules/Przyklad.v
@@ -145,8 +145,8 @@ Module ListDict (E: ELEM).
   Definition add (e : elt) (s : T) := cons elt e s.
   Fixpoint find (e : elt) (s : T) {struct s} : bool :=
     match s with
-    | nil => false
-    | cons e' s' => ifte (E.eq_dec e e') true (find e s')
+    | nil _ => false
+    | cons _ e' s' => ifte (E.eq_dec e e') true (find e s')
     end.
 
   Definition find_empty_false (e : elt) := refl_equal false.
diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out
index 7c9b1e27..629a1ab6 100644
--- a/test-suite/output/Arguments.out
+++ b/test-suite/output/Arguments.out
@@ -1,94 +1,110 @@
-minus : nat -> nat -> nat
+Nat.sub : nat -> nat -> nat
 
+Nat.sub is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-The simpl tactic unfolds minus avoiding to expose match constructs
-minus is transparent
-Expands to: Constant Coq.Init.Peano.minus
-minus : nat -> nat -> nat
+The reduction tactics unfold Nat.sub but avoid exposing match constructs
+Nat.sub is transparent
+Expands to: Constant Coq.Init.Nat.sub
+Nat.sub : nat -> nat -> nat
 
+Nat.sub is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-The simpl tactic unfolds minus when applied to 1 argument
-  avoiding to expose match constructs
-minus is transparent
-Expands to: Constant Coq.Init.Peano.minus
-minus : nat -> nat -> nat
+The reduction tactics unfold Nat.sub when applied to 1 argument
+  but avoid exposing match constructs
+Nat.sub is transparent
+Expands to: Constant Coq.Init.Nat.sub
+Nat.sub : nat -> nat -> nat
 
+Nat.sub is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-The simpl tactic unfolds minus
+The reduction tactics unfold Nat.sub
   when the 1st argument evaluates to a constructor and
-  when applied to 1 argument avoiding to expose match constructs
-minus is transparent
-Expands to: Constant Coq.Init.Peano.minus
-minus : nat -> nat -> nat
+  when applied to 1 argument but avoid exposing match constructs
+Nat.sub is transparent
+Expands to: Constant Coq.Init.Nat.sub
+Nat.sub : nat -> nat -> nat
 
+Nat.sub is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-The simpl tactic unfolds minus
-  when the 1st and 2nd arguments evaluate to a constructor and
-  when applied to 2 arguments 
-minus is transparent
-Expands to: Constant Coq.Init.Peano.minus
-minus : nat -> nat -> nat
+The reduction tactics unfold Nat.sub when the 1st and
+  2nd arguments evaluate to a constructor and when applied to 2 arguments 
+Nat.sub is transparent
+Expands to: Constant Coq.Init.Nat.sub
+Nat.sub : nat -> nat -> nat
 
+Nat.sub is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-The simpl tactic unfolds minus
-  when the 1st and 2nd arguments evaluate to a constructor 
-minus is transparent
-Expands to: Constant Coq.Init.Peano.minus
+The reduction tactics unfold Nat.sub when the 1st and
+  2nd arguments evaluate to a constructor 
+Nat.sub is transparent
+Expands to: Constant Coq.Init.Nat.sub
 pf :
 forall D1 C1 : Type,
 (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2
 
+pf is not universe polymorphic
 Arguments D2, C2 are implicit
 Arguments D1, C1 are implicit and maximally inserted
 Argument scopes are [foo_scope type_scope _ _ _ _ _]
-The simpl tactic never unfolds pf
+The reduction tactics never unfold pf
 pf is transparent
 Expands to: Constant Top.pf
 fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C
 
+fcomp is not universe polymorphic
 Arguments A, B, C are implicit and maximally inserted
 Argument scopes are [type_scope type_scope type_scope _ _ _]
-The simpl tactic unfolds fcomp when applied to 6 arguments 
+The reduction tactics unfold fcomp when applied to 6 arguments 
 fcomp is transparent
 Expands to: Constant Top.fcomp
 volatile : nat -> nat
 
+volatile is not universe polymorphic
 Argument scope is [nat_scope]
-The simpl tactic always unfolds volatile
+The reduction tactics always unfold volatile
 volatile is transparent
 Expands to: Constant Top.volatile
 f : T1 -> T2 -> nat -> unit -> nat -> nat
 
+f is not universe polymorphic
 Argument scopes are [_ _ nat_scope _ nat_scope]
 f is transparent
 Expands to: Constant Top.S1.S2.f
 f : T1 -> T2 -> nat -> unit -> nat -> nat
 
+f is not universe polymorphic
 Argument scopes are [_ _ nat_scope _ nat_scope]
-The simpl tactic unfolds f
-  when the 3rd, 4th and 5th arguments evaluate to a constructor 
+The reduction tactics unfold f when the 3rd, 4th and
+  5th arguments evaluate to a constructor 
 f is transparent
 Expands to: Constant Top.S1.S2.f
 f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
 
+f is not universe polymorphic
 Argument T2 is implicit
 Argument scopes are [type_scope _ _ nat_scope _ nat_scope]
-The simpl tactic unfolds f
-  when the 4th, 5th and 6th arguments evaluate to a constructor 
+The reduction tactics unfold f when the 4th, 5th and
+  6th arguments evaluate to a constructor 
 f is transparent
 Expands to: Constant Top.S1.f
 f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
 
+f is not universe polymorphic
 Arguments T1, T2 are implicit
 Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope]
-The simpl tactic unfolds f
-  when the 5th, 6th and 7th arguments evaluate to a constructor 
+The reduction tactics unfold f when the 5th, 6th and
+  7th arguments evaluate to a constructor 
 f is transparent
 Expands to: Constant Top.f
+     = forall v : unit, f 0 0 5 v 3 = 2
+     : Prop
+     = 2 = 2
+     : Prop
 f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat
 
-The simpl tactic unfolds f
-  when the 5th, 6th and 7th arguments evaluate to a constructor 
+f is not universe polymorphic
+The reduction tactics unfold f when the 5th, 6th and
+  7th arguments evaluate to a constructor 
 f is transparent
 Expands to: Constant Top.f
 forall w : r, w 3 true = tt
diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v
index 573cfdab..05eeaac6 100644
--- a/test-suite/output/Arguments.v
+++ b/test-suite/output/Arguments.v
@@ -1,13 +1,13 @@
-Arguments minus n m : simpl nomatch. 
-About minus.
-Arguments minus n / m : simpl nomatch. 
-About minus.
-Arguments minus !n / m : simpl nomatch. 
-About minus.
-Arguments minus !n !m /.
-About minus.
-Arguments minus !n !m.
-About minus.
+Arguments Nat.sub n m : simpl nomatch.
+About Nat.sub.
+Arguments Nat.sub n / m : simpl nomatch.
+About Nat.sub.
+Arguments Nat.sub !n / m : simpl nomatch.
+About Nat.sub.
+Arguments Nat.sub !n !m /.
+About Nat.sub.
+Arguments Nat.sub !n !m.
+About Nat.sub.
 Definition pf (D1 C1 : Type) (f : D1 -> C1) (D2 C2 : Type) (g : D2 -> C2) := 
   fun x => (f (fst x), g (snd x)).
 Delimit Scope foo_scope with F.
@@ -36,13 +36,15 @@ End S2.
 About f.
 End S1.
 About f.
+Eval cbn in forall v, f 0 0 5 v 3 = 2.
+Eval cbn in f 0 0 5 tt 3 = 2.
 Arguments f : clear implicits and scopes.
 About f.
 Record r := { pi :> nat -> bool -> unit }.
 Notation "$" := 3 (only parsing) : foo_scope.
 Notation "$" := true (only parsing) : bar_scope.
 Delimit Scope bar_scope with B.
-Arguments pi _ _%F _%B. 
+Arguments pi _ _%F _%B.
 Check (forall w : r, pi w $ $ = tt).
 Fail Check (forall w : r, w $ $ = tt).
 Axiom w : r.
diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out
index 756e8ede..71d5fc78 100644
--- a/test-suite/output/ArgumentsScope.out
+++ b/test-suite/output/ArgumentsScope.out
@@ -1,61 +1,70 @@
 a : bool -> bool
 
+a is not universe polymorphic
 Argument scope is [bool_scope]
 Expands to: Variable a
 b : bool -> bool
 
+b is not universe polymorphic
 Argument scope is [bool_scope]
 Expands to: Variable b
 negb'' : bool -> bool
 
+negb'' is not universe polymorphic
 Argument scope is [bool_scope]
 negb'' is transparent
 Expands to: Constant Top.A.B.negb''
 negb' : bool -> bool
 
+negb' is not universe polymorphic
 Argument scope is [bool_scope]
 negb' is transparent
 Expands to: Constant Top.A.negb'
 negb : bool -> bool
 
+negb is not universe polymorphic
 Argument scope is [bool_scope]
 negb is transparent
 Expands to: Constant Coq.Init.Datatypes.negb
-Warning: Arguments Scope is deprecated; use Arguments instead
-Warning: Arguments Scope is deprecated; use Arguments instead
-Warning: Arguments Scope is deprecated; use Arguments instead
-Warning: Arguments Scope is deprecated; use Arguments instead
-Warning: Arguments Scope is deprecated; use Arguments instead
 a : bool -> bool
 
+a is not universe polymorphic
 Expands to: Variable a
 b : bool -> bool
 
+b is not universe polymorphic
 Expands to: Variable b
 negb : bool -> bool
 
+negb is not universe polymorphic
 negb is transparent
 Expands to: Constant Coq.Init.Datatypes.negb
 negb' : bool -> bool
 
+negb' is not universe polymorphic
 negb' is transparent
 Expands to: Constant Top.A.negb'
 negb'' : bool -> bool
 
+negb'' is not universe polymorphic
 negb'' is transparent
 Expands to: Constant Top.A.B.negb''
 a : bool -> bool
 
+a is not universe polymorphic
 Expands to: Variable a
 negb : bool -> bool
 
+negb is not universe polymorphic
 negb is transparent
 Expands to: Constant Coq.Init.Datatypes.negb
 negb' : bool -> bool
 
+negb' is not universe polymorphic
 negb' is transparent
 Expands to: Constant Top.negb'
 negb'' : bool -> bool
 
+negb'' is not universe polymorphic
 negb'' is transparent
 Expands to: Constant Top.negb''
diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out
index 17c80d13..c29f5649 100644
--- a/test-suite/output/Arguments_renaming.out
+++ b/test-suite/output/Arguments_renaming.out
@@ -6,7 +6,7 @@ The command has indeed failed with message:
 Argument A renamed to T.
 @eq_refl
      : forall (B : Type) (y : B), y = y
-eq_refl
+@eq_refl nat
      : forall x : nat, x = x
 Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
 
@@ -20,6 +20,7 @@ For eq: Argument scopes are [type_scope _ _]
 For eq_refl: Argument scopes are [type_scope _]
 eq_refl : forall (A : Type) (x : A), x = x
 
+eq_refl is not universe polymorphic
 Arguments are renamed to B, y
 When applied to no arguments:
   Arguments B, y are implicit and maximally inserted
@@ -35,6 +36,7 @@ For myEq: Argument scopes are [type_scope _ _]
 For myrefl: Argument scopes are [type_scope _ _]
 myrefl : forall (B : Type) (x : A), B -> myEq B x x
 
+myrefl is not universe polymorphic
 Arguments are renamed to C, x, _
 Argument C is implicit and maximally inserted
 Argument scopes are [type_scope _ _]
@@ -47,19 +49,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
   end
      : forall T : Type, T -> nat -> nat -> nat
 
+myplus is not universe polymorphic
 Arguments are renamed to Z, t, n, m
 Argument Z is implicit and maximally inserted
 Argument scopes are [type_scope _ nat_scope nat_scope]
 myplus : forall T : Type, T -> nat -> nat -> nat
 
+myplus is not universe polymorphic
 Arguments are renamed to Z, t, n, m
 Argument Z is implicit and maximally inserted
 Argument scopes are [type_scope _ nat_scope nat_scope]
-The simpl tactic unfolds myplus
-  when the 2nd and 3rd arguments evaluate to a constructor 
+The reduction tactics unfold myplus when the 2nd and
+  3rd arguments evaluate to a constructor 
 myplus is transparent
 Expands to: Constant Top.Test1.myplus
-myplus
+@myplus
      : forall Z : Type, Z -> nat -> nat -> nat
 Inductive myEq (A B : Type) (x : A) : A -> Prop :=
     myrefl : B -> myEq A B x x
@@ -70,6 +74,7 @@ For myEq: Argument scopes are [type_scope type_scope _ _]
 For myrefl: Argument scopes are [type_scope type_scope _ _]
 myrefl : forall (A B : Type) (x : A), B -> myEq A B x x
 
+myrefl is not universe polymorphic
 Arguments are renamed to A, C, x, _
 Argument C is implicit and maximally inserted
 Argument scopes are [type_scope type_scope _ _]
@@ -84,19 +89,21 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat :=
   end
      : forall T : Type, T -> nat -> nat -> nat
 
+myplus is not universe polymorphic
 Arguments are renamed to Z, t, n, m
 Argument Z is implicit and maximally inserted
 Argument scopes are [type_scope _ nat_scope nat_scope]
 myplus : forall T : Type, T -> nat -> nat -> nat
 
+myplus is not universe polymorphic
 Arguments are renamed to Z, t, n, m
 Argument Z is implicit and maximally inserted
 Argument scopes are [type_scope _ nat_scope nat_scope]
-The simpl tactic unfolds myplus
-  when the 2nd and 3rd arguments evaluate to a constructor 
+The reduction tactics unfold myplus when the 2nd and
+  3rd arguments evaluate to a constructor 
 myplus is transparent
 Expands to: Constant Top.myplus
-myplus
+@myplus
      : forall Z : Type, Z -> nat -> nat -> nat
 The command has indeed failed with message:
 => Error: All arguments lists must declare the same names.
diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out
index 1ec02c56..d5903483 100644
--- a/test-suite/output/Cases.out
+++ b/test-suite/output/Cases.out
@@ -2,13 +2,23 @@ t_rect =
 fun (P : t -> Type) (f : let x := t in forall x0 : x, P x0 -> P (k x0)) =>
 fix F (t : t) : P t :=
   match t as t0 return (P t0) with
-  | k _ x0 => f x0 (F x0)
+  | @k _ x0 => f x0 (F x0)
   end
      : forall P : t -> Type,
        (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t
+
+t_rect is not universe polymorphic
+     = fun d : TT => match d with
+                     | @CTT _ _ b => b
+                     end
+     : TT -> 0 = 0
+     = fun d : TT => match d with
+                     | @CTT _ _ b => b
+                     end
+     : TT -> 0 = 0
 proj = 
 fun (x y : nat) (P : nat -> Type) (def : P x) (prf : P y) =>
-match eq_nat_dec x y with
+match Nat.eq_dec x y with
 | left eqprf => match eqprf in (_ = z) return (P z) with
                 | eq_refl => def
                 end
@@ -16,6 +26,7 @@ match eq_nat_dec x y with
 end
      : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y
 
+proj is not universe polymorphic
 Argument scopes are [nat_scope nat_scope _ _ _]
 foo = 
 fix foo (A : Type) (l : list A) {struct l} : option A :=
@@ -26,6 +37,29 @@ fix foo (A : Type) (l : list A) {struct l} : option A :=
   end
      : forall A : Type, list A -> option A
 
+foo is not universe polymorphic
 Argument scopes are [type_scope list_scope]
+uncast = 
+fun (A : Type) (x : I A) => match x with
+                            | x0 <: _ => x0
+                            end
+     : forall A : Type, I A -> A
+
+uncast is not universe polymorphic
+Argument scopes are [type_scope _]
 foo' = if A 0 then true else false
      : bool
+
+foo' is not universe polymorphic
+f = 
+fun H : B =>
+match H with
+| AC x =>
+    (let b0 := b in
+     if b0 as b return (P b -> True)
+     then fun _ : P true => Logic.I
+     else fun _ : P false => Logic.I) x
+end
+     : B -> True
+
+f is not universe polymorphic
diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v
index b6337586..4116a5eb 100644
--- a/test-suite/output/Cases.v
+++ b/test-suite/output/Cases.v
@@ -5,6 +5,11 @@ Inductive t : Set :=
 
 Print t_rect.
 
+Record TT : Type := CTT { f1 := 0 : nat; f2: nat; f3 : f1=f1 }.
+
+Eval cbv in fun d:TT => match d return 0 = 0 with CTT a _ b => b end.
+Eval lazy in fun d:TT => match d return 0 = 0 with CTT a _ b => b end.
+
 (* Do not contract nested patterns with dependent return type *)
 (* see bug #1699 *)
 
@@ -34,6 +39,18 @@ Fixpoint foo (A:Type) (l:list A) : option A :=
 
 Print foo.
 
+(* Accept and use notation with binded parameters *)
+
+Inductive I (A: Type) : Type := C : A -> I A.
+Notation "x <: T" := (C T x) (at level 38).
+
+Definition uncast A (x : I A) :=
+match x with
+ | x <: _ => x
+end.
+
+Print uncast.
+
 (* Do not duplicate the matched term *)
 
 Axiom A : nat -> bool.
@@ -46,3 +63,17 @@ Definition foo' :=
 
 Print foo'.
 
+(* Was bug #3293 (eta-expansion at "match" printing time was failing because
+   of let-in's interpreted as being part of the expansion)  *)
+
+Variable b : bool.
+Variable P : bool -> Prop.
+Inductive B : Prop := AC : P b -> B.
+Definition f : B -> True.
+
+Proof.
+intros [].
+destruct b as [|] ; intros _ ; exact Logic.I.
+Defined.
+
+Print f.
diff --git a/test-suite/output/Errors.out b/test-suite/output/Errors.out
index f61b7ecf..bcc37b63 100644
--- a/test-suite/output/Errors.out
+++ b/test-suite/output/Errors.out
@@ -1,2 +1,7 @@
 The command has indeed failed with message:
 => Error: The field t is missing in Top.M.
+The command has indeed failed with message:
+=> Error: Unable to unify "nat" with "True".
+The command has indeed failed with message:
+=> In nested Ltac calls to "f" and "apply x", last call failed.
+Error: Unable to unify "nat" with "True".
diff --git a/test-suite/output/Errors.v b/test-suite/output/Errors.v
index 75763f3b..352c8738 100644
--- a/test-suite/output/Errors.v
+++ b/test-suite/output/Errors.v
@@ -7,3 +7,12 @@ Parameter t:Type.
 End S.
 Module M : S.
 Fail End M.
+
+(* A simple check of how Ltac trace are used or not *)
+(* Unfortunately, cannot test error location... *)
+
+Ltac f x := apply x.
+Goal True.
+Fail simpl; apply 0.
+Fail simpl; f 0.
+Abort.
diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out
index 2f756cbb..483a9ea7 100644
--- a/test-suite/output/Existentials.out
+++ b/test-suite/output/Existentials.out
@@ -1,3 +1,5 @@
-Existential 1 = ?10 : [q : nat  n : nat  m : nat |- n = ?9] 
-Existential 2 = ?9 : [n : nat  m : nat |- nat] 
-Existential 3 = ?7 : [p : nat  q := S p : nat  n : nat  m : nat |- ?9 = m] 
+Existential 1 =
+?Goal0 : [p : nat  q := S p : nat  n : nat  m : nat |- ?y = m] 
+Existential 2 =
+?y : [p : nat  q := S p : nat  n : nat  m : nat |- nat] (p, q cannot be used)
+Existential 3 = ?e : [q : nat  n : nat  m : nat |- n = ?y] 
diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v
index f5610efc..6c514b16 100644
--- a/test-suite/output/Extraction_matchs_2413.v
+++ b/test-suite/output/Extraction_matchs_2413.v
@@ -22,8 +22,8 @@ Inductive hole (A:Set) : Set := Hole | Hole2.
 
 Definition wrong_id (A B : Set) (x:hole A) : hole B :=
  match x with
-  | Hole => @Hole _
-  | Hole2 => @Hole2 _
+  | Hole _ => @Hole _
+  | Hole2 _ => @Hole2 _
  end.
 
 Extraction wrong_id. (** should _not_ be optimized as an identity *)
@@ -114,9 +114,9 @@ Definition decode_cond_mode (mode : Type) (f : word -> decoder_result mode)
     | Some oc =>
       match f w with
         | DecInst i => DecInst (g i oc)
-        | DecError m => @DecError inst m
-        | DecUndefined => @DecUndefined inst
-        | DecUnpredictable => @DecUnpredictable inst
+        | DecError _ m => @DecError inst m
+        | DecUndefined _ => @DecUndefined inst
+        | DecUnpredictable _ => @DecUnpredictable inst
       end
     | None => @DecUndefined inst
   end.
diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out
index 3b65003c..0b0f501f 100644
--- a/test-suite/output/Implicit.out
+++ b/test-suite/output/Implicit.out
@@ -5,6 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I
 d2 = fun x : nat => d1 (y:=x)
      : forall x x0 : nat, x0 = x -> x0 = x
 
+d2 is not universe polymorphic
 Arguments x, x0 are implicit
 Argument scopes are [nat_scope nat_scope _]
 map id (1 :: nil)
diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out
index 55017469..bbfd3405 100644
--- a/test-suite/output/InitSyntax.out
+++ b/test-suite/output/InitSyntax.out
@@ -1,5 +1,5 @@
 Inductive sig2 (A : Type) (P Q : A -> Prop) : Type :=
-    exist2 : forall x : A, P x -> Q x -> {x | P x & Q x}
+    exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x}
 
 For sig2: Argument A is implicit
 For exist2: Argument A is implicit
diff --git a/test-suite/output/Intuition.out b/test-suite/output/Intuition.out
index 5831c9f4..e99d9fde 100644
--- a/test-suite/output/Intuition.out
+++ b/test-suite/output/Intuition.out
@@ -1,7 +1,6 @@
 1 subgoal
   
-  m : Z
-  n : Z
+  m, n : Z
   H : (m >= n)%Z
   ============================
    (m >= m)%Z
diff --git a/test-suite/output/Match_subterm.out b/test-suite/output/Match_subterm.out
index 951a98db..c99c8905 100644
--- a/test-suite/output/Match_subterm.out
+++ b/test-suite/output/Match_subterm.out
@@ -1,5 +1,7 @@
 (0 = 1)
+(eq 0)
 eq
+@eq
 nat
 0
 1
diff --git a/test-suite/output/Nametab.out b/test-suite/output/Nametab.out
index b1883ec0..c11621d7 100644
--- a/test-suite/output/Nametab.out
+++ b/test-suite/output/Nametab.out
@@ -7,15 +7,15 @@ Constant Top.Q.N.K.foo
 Constant Top.Q.N.K.foo
 Constant Top.Q.N.K.foo
   (shorter name to refer to it in current context is Q.N.K.foo)
-No module is referred to by basename K
-No module is referred to by name N.K
+Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K)
+Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K)
 Module Top.Q.N.K
-Module Top.Q.N.K
-No module is referred to by basename N
-Module Top.Q.N
+Module Top.Q.N.K (shorter name to refer to it in current context is Q.N.K)
+Module Top.Q.N (shorter name to refer to it in current context is Q.N)
 Module Top.Q.N
+Module Top.Q.N (shorter name to refer to it in current context is Q.N)
 Module Top.Q
-Module Top.Q
+Module Top.Q (shorter name to refer to it in current context is Q)
 Constant Top.Q.N.K.foo
   (shorter name to refer to it in current context is K.foo)
 Constant Top.Q.N.K.foo
@@ -26,11 +26,11 @@ Constant Top.Q.N.K.foo
 Constant Top.Q.N.K.foo
   (shorter name to refer to it in current context is K.foo)
 Module Top.Q.N.K
-No module is referred to by name N.K
-Module Top.Q.N.K
-Module Top.Q.N.K
-No module is referred to by basename N
-Module Top.Q.N
+Module Top.Q.N.K (shorter name to refer to it in current context is K)
+Module Top.Q.N.K (shorter name to refer to it in current context is K)
+Module Top.Q.N.K (shorter name to refer to it in current context is K)
+Module Top.Q.N (shorter name to refer to it in current context is Q.N)
 Module Top.Q.N
+Module Top.Q.N (shorter name to refer to it in current context is Q.N)
 Module Top.Q
-Module Top.Q
+Module Top.Q (shorter name to refer to it in current context is Q)
diff --git a/test-suite/output/Naming.out b/test-suite/output/Naming.out
index df510063..f0d2562e 100644
--- a/test-suite/output/Naming.out
+++ b/test-suite/output/Naming.out
@@ -6,12 +6,8 @@
    (forall x2 x5 : nat, x2 + x1 = x4 + x5) -> x + x1 = x4 + x0
 1 subgoal
   
-  x3 : nat
-  x : nat
-  x1 : nat
-  x4 : nat
-  x0 : nat
-  H : forall x5 x6 : nat, x5 + x1 = x4 + x6
+  x3, x, x1, x4, x0 : nat
+  H : forall x x3 : nat, x + x1 = x4 + x3
   ============================
    x + x1 = x4 + x0
 1 subgoal
@@ -33,11 +29,7 @@
    forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
-  x3 : nat
-  x : nat
-  x1 : nat
-  x4 : nat
-  x0 : nat
+  x3, x, x1, x4, x0 : nat
   ============================
    (forall x2 x5 : nat,
     x2 + x1 = x4 + x5 ->
@@ -46,38 +38,26 @@
    forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
-  x3 : nat
-  x : nat
-  x1 : nat
-  x4 : nat
-  x0 : nat
-  H : forall x5 x6 : nat,
-      x5 + x1 = x4 + x6 ->
-      forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1)
+  x3, x, x1, x4, x0 : nat
+  H : forall x x3 : nat,
+      x + x1 = x4 + x3 ->
+      forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (S x + x1)
   H0 : x + x1 = x4 + x0
   ============================
    forall x5 x6 x7 S : nat, x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
-  x3 : nat
-  x : nat
-  x1 : nat
-  x4 : nat
-  x0 : nat
-  H : forall x5 x6 : nat,
-      x5 + x1 = x4 + x6 ->
-      forall x7 x8 x9 S : nat, x7 + S = x8 + x9 + (Datatypes.S x5 + x1)
+  x3, x, x1, x4, x0 : nat
+  H : forall x x3 : nat,
+      x + x1 = x4 + x3 ->
+      forall x0 x4 x5 S0 : nat, x0 + S0 = x4 + x5 + (Datatypes.S x + x1)
   H0 : x + x1 = x4 + x0
-  x5 : nat
-  x6 : nat
-  x7 : nat
-  S : nat
+  x5, x6, x7, S : nat
   ============================
    x5 + S = x6 + x7 + Datatypes.S x
 1 subgoal
   
-  x3 : nat
-  a : nat
-  H : a = 0 -> forall a0 : nat, a0 = 0
+  x3, a : nat
+  H : a = 0 -> forall a : nat, a = 0
   ============================
    a = 0
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 66307236..60ee72b3 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -2,23 +2,21 @@ true ? 0; 1
      : nat
 if true as x return (x ? nat; bool) then 0 else true
      : nat
-Identifier 'proj1' now a keyword
 fun e : nat * nat => proj1 e
      : nat * nat -> nat
-Identifier 'decomp' now a keyword
 decomp (true, true) as t, u in (t, u)
      : bool * bool
-!(0 = 0)
+! (0 = 0)
      : Prop
 forall n : nat, n = 0
      : Prop
-!(0 = 0)
+! (0 = 0)
      : Prop
-forall n : nat, #(n = n)
+forall n : nat, # (n = n)
      : Prop
-forall n n0 : nat, ##(n = n0)
+forall n n0 : nat, ## (n = n0)
      : Prop
-forall n n0 : nat, ###(n = n0)
+forall n n0 : nat, ### (n = n0)
      : Prop
 3 + 3
      : Z
@@ -28,21 +26,17 @@ forall n n0 : nat, ###(n = n0)
      : list nat
 (1; 2, 4)
      : nat * nat * nat
-Identifier 'ifzero' now a keyword
 ifzero 3
      : bool
-Identifier 'pred' now a keyword
 pred 3
      : nat
 fun n : nat => pred n
      : nat -> nat
 fun n : nat => pred n
      : nat -> nat
-Identifier 'ifn' now a keyword
-Identifier 'is' now a keyword
 fun x : nat => ifn x is succ n then n else 0
      : nat -> nat
-1-
+1 -
      : bool
 -4
      : Z
@@ -50,14 +44,12 @@ The command has indeed failed with message:
 => Error: x should not be bound in a recursive pattern of the right-hand side.
 The command has indeed failed with message:
 => Error: in the right-hand side, y and z should appear in
-   term position as part of a recursive pattern.
+term position as part of a recursive pattern.
 The command has indeed failed with message:
 => Error: The reference w was not found in the current environment.
 The command has indeed failed with message:
-=> Error: x is unbound in the right-hand side.
-The command has indeed failed with message:
 => Error: in the right-hand side, y and z should appear in
-   term position as part of a recursive pattern.
+term position as part of a recursive pattern.
 The command has indeed failed with message:
 => Error: z is expected to occur in binding position in the right-hand side.
 The command has indeed failed with message:
@@ -80,7 +72,6 @@ Nil
      : forall A : Type, list A
 NIL:list nat
      : list nat
-Identifier 'I' now a keyword
 (false && I 3)%bool /\ I 6
      : Prop
 [|1, 2, 3; 4, 5, 6|]
@@ -89,11 +80,11 @@ Identifier 'I' now a keyword
      : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool))
 fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z
      : (Z -> Z -> Z -> Z) -> Z
-plus
+Init.Nat.add
      : nat -> nat -> nat
 S
      : nat -> nat
-mult
+Init.Nat.mul
      : nat -> nat -> nat
 le
      : nat -> nat -> Prop
@@ -101,7 +92,7 @@ plus
      : nat -> nat -> nat
 succ
      : nat -> nat
-mult
+Init.Nat.mul
      : nat -> nat -> nat
 le
      : nat -> nat -> Prop
@@ -116,18 +107,24 @@ fun x : option Z => match x with
                     end
      : option Z -> Z
 fun x : option Z => match x with
-                    | SOME3 x0 => x0
-                    | NONE3 => 0
+                    | SOME2 x0 => x0
+                    | NONE2 => 0
                     end
      : option Z -> Z
+fun x : list ?T1 => match x with
+                    | NIL => NONE2
+                    | (_ :') t => SOME2 t
+                    end
+     : list ?T1 -> option (list ?T1)
+where
+?T1 : [x : list ?T1  x1 : list ?T1  x0 := x1 : list ?T1 |- Type] (x, x1,
+      x0 cannot be used)
 s
      : s
-Identifier 'foo' now a keyword
 10
      : nat
 fun _ : nat => 9
      : nat -> nat
-Identifier 'ONE' now a keyword
 fun (x : nat) (p : x = x) => match p with
                              | ONE => ONE
                              end = p
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index 612b5325..adba688e 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -68,7 +68,7 @@ Coercion Zpos: nat >-> znat.
 Delimit Scope znat_scope with znat.
 Open Scope znat_scope.
 
-Variable addz : znat -> znat -> znat.
+Parameter addz : znat -> znat -> znat.
 Notation "z1 + z2" := (addz z1 z2) : znat_scope.
 
   (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit,
@@ -133,7 +133,8 @@ Fail Notation "( x , y , .. , z )" := (pair x (pair y z)).
 Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..).
 
 (* Right-unbound variable *)
-Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..).
+(* Now allowed with an only parsing restriction *)
+Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..).
 
 (* Not the right kind of recursive pattern *)
 Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)).
@@ -244,7 +245,11 @@ Check (fun x => match x with SOME2 x => x | NONE2 => 0 end).
 
 Notation NONE3 := @None.
 Notation SOME3 := @Some.     
-Check (fun x => match x with SOME3 x => x | NONE3 => 0 end).
+Check (fun x => match x with SOME3 _ x => x | NONE3 _ => 0 end).
+
+Notation "a :'" := (cons a) (at level 12).
+
+Check (fun x => match x with | nil => NONE | h :' t => SOME3 _ t end).
 
 (* Check correct matching of "Type" in notations. Of course the
    notation denotes a term that will be reinterpreted with a different
@@ -275,3 +280,4 @@ Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p.
 
 Notation "1" := eq_refl.
 Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p.
+
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index cf45025e..58ec1de5 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -1,6 +1,6 @@
 2 3
      : PAIR
-2[+]3
+2 [+] 3
      : nat
 forall (A : Set) (le : A -> A -> Prop) (x y : A), le x y \/ le y x
      : Prop
@@ -10,7 +10,7 @@ end
      : nat
 let '(a, _, _) := (2, 3, 4) in a
      : nat
-exists myx (y : bool), myx = y
+exists myx y : bool, myx = y
      : Prop
 fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0
      : (nat -> nat -> Prop) -> nat -> Prop
@@ -24,7 +24,6 @@ let d := 2 in ∃ z : nat, let e := 3 in let f := 4 in x + y = z + d
      : Prop
 ∀ n p : nat, n + p = 0
      : Prop
-Identifier 'λ' now a keyword
 λ n p : nat, n + p = 0
      : nat -> nat -> Prop
 λ (A : Type) (n p : A), n = p
@@ -33,12 +32,11 @@ Identifier 'λ' now a keyword
      : Type -> Prop
 λ A : Type, ∀ n p : A, n = p
      : Type -> Prop
-Identifier 'let'' now a keyword
 let' f (x y : nat) (a:=0) (z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2
      : bool -> nat
 λ (f : nat -> nat) (x : nat), f(x) + S(x)
      : (nat -> nat) -> nat -> nat
-Notation plus2 n := (S (S n))
+Notation plus2 n := (S(S(n)))
 λ n : list(nat),
 match n with
 | nil => 2
diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out
index 23f33081..08df9150 100644
--- a/test-suite/output/PrintAssumptions.out
+++ b/test-suite/output/PrintAssumptions.out
@@ -2,6 +2,11 @@ Axioms:
 foo : nat
 Axioms:
 foo : nat
+Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZAdd
+Fetching opaque proofs from disk for Coq.Arith.PeanoNat
+Fetching opaque proofs from disk for Coq.Classes.Morphisms
+Fetching opaque proofs from disk for Coq.Init.Logic
+Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZBase
 Axioms:
 extensionality : forall (P Q : Type) (f g : P -> Q),
                  (forall x : P, f x = g x) -> f = g
diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out
index 598bb728..0457c860 100644
--- a/test-suite/output/PrintInfos.out
+++ b/test-suite/output/PrintInfos.out
@@ -1,16 +1,17 @@
-existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P
+existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x}
 
+existT is template universe polymorphic
 Argument A is implicit
 Argument scopes are [type_scope _ _ _]
 Expands to: Constructor Coq.Init.Specif.existT
 Inductive sigT (A : Type) (P : A -> Type) : Type :=
-    existT : forall x : A, P x -> sigT P
+    existT : forall x : A, P x -> {x : A & P x}
 
 For sigT: Argument A is implicit
 For existT: Argument A is implicit
 For sigT: Argument scopes are [type_scope type_scope]
 For existT: Argument scopes are [type_scope _ _ _]
-existT : forall (A : Type) (P : A -> Type) (x : A), P x -> sigT P
+existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x}
 
 Argument A is implicit
 Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
@@ -24,6 +25,7 @@ For eq: Argument scopes are [type_scope _ _]
 For eq_refl: Argument scopes are [type_scope _]
 eq_refl : forall (A : Type) (x : A), x = x
 
+eq_refl is not universe polymorphic
 When applied to no arguments:
   Arguments A, x are implicit and maximally inserted
 When applied to 1 argument:
@@ -36,28 +38,30 @@ When applied to no arguments:
   Arguments A, x are implicit and maximally inserted
 When applied to 1 argument:
   Argument A is implicit
-plus = 
-fix plus (n m : nat) {struct n} : nat :=
+Nat.add = 
+fix add (n m : nat) {struct n} : nat :=
   match n with
   | 0 => m
-  | S p => S (plus p m)
+  | S p => S (add p m)
   end
      : nat -> nat -> nat
 
+Nat.add is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-plus : nat -> nat -> nat
+Nat.add : nat -> nat -> nat
 
+Nat.add is not universe polymorphic
 Argument scopes are [nat_scope nat_scope]
-plus is transparent
-Expands to: Constant Coq.Init.Peano.plus
-plus : nat -> nat -> nat
+Nat.add is transparent
+Expands to: Constant Coq.Init.Nat.add
+Nat.add : nat -> nat -> nat
 
 plus_n_O : forall n : nat, n = n + 0
 
+plus_n_O is not universe polymorphic
 Argument scope is [nat_scope]
 plus_n_O is opaque
 Expands to: Constant Coq.Init.Peano.plus_n_O
-Warning: Implicit Arguments is deprecated; use Arguments instead
 Inductive le (n : nat) : nat -> Prop :=
     le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m
 
@@ -76,12 +80,13 @@ For le_n: Argument scope is [nat_scope]
 For le_S: Argument scopes are [nat_scope nat_scope _]
 comparison : Set
 
+comparison is not universe polymorphic
 Expands to: Inductive Coq.Init.Datatypes.comparison
 Inductive comparison : Set :=
     Eq : comparison | Lt : comparison | Gt : comparison
-Warning: Implicit Arguments is deprecated; use Arguments instead
 bar : foo
 
+bar is not universe polymorphic
 Expanded type for implicit arguments
 bar : forall x : nat, x = 0
 
@@ -89,12 +94,14 @@ Argument x is implicit and maximally inserted
 Expands to: Constant Top.bar
 *** [ bar : foo ]
 
+bar is not universe polymorphic
 Expanded type for implicit arguments
 bar : forall x : nat, x = 0
 
 Argument x is implicit and maximally inserted
 bar : foo
 
+bar is not universe polymorphic
 Expanded type for implicit arguments
 bar : forall x : nat, x = 0
 
@@ -102,6 +109,7 @@ Argument x is implicit and maximally inserted
 Expands to: Constant Top.bar
 *** [ bar : foo ]
 
+bar is not universe polymorphic
 Expanded type for implicit arguments
 bar : forall x : nat, x = 0
 
@@ -109,7 +117,6 @@ Argument x is implicit and maximally inserted
 Module Coq.Init.Peano
 Notation existS2 := existT2
 Expands to: Notation Coq.Init.Specif.existS2
-Warning: Implicit Arguments is deprecated; use Arguments instead
 Inductive eq (A : Type) (x : A) : A -> Prop :=  eq_refl : x = x
 
 For eq: Argument A is implicit and maximally inserted
@@ -128,3 +135,15 @@ For eq_refl, when applied to 1 argument:
   Argument A is implicit and maximally inserted
 For eq: Argument scopes are [type_scope _ _]
 For eq_refl: Argument scopes are [type_scope _]
+n:nat
+
+Hypothesis of the goal context.
+h:(n <> newdef n)
+
+Hypothesis of the goal context.
+g:(nat -> nat)
+
+Constant (let in) of the goal context.
+h:(n <> newdef n)
+
+Hypothesis of the goal context.
diff --git a/test-suite/output/PrintInfos.v b/test-suite/output/PrintInfos.v
index deeb1f65..3c623346 100644
--- a/test-suite/output/PrintInfos.v
+++ b/test-suite/output/PrintInfos.v
@@ -6,9 +6,9 @@ Print eq_refl.
 About eq_refl.
 Print Implicit eq_refl.
 
-Print plus.
-About plus.
-Print Implicit plus.
+Print Nat.add.
+About Nat.add.
+Print Implicit Nat.add.
 
 About plus_n_O.
 
@@ -39,3 +39,19 @@ Print eq_refl.
 
 Arguments eq_refl {A} {x}, {A} x. (* Test new syntax *)
 Print eq_refl.
+
+
+Definition newdef := fun x:nat => x.
+
+Goal forall n:nat, n <> newdef n -> newdef n <> n -> False.
+  intros n h h'.
+  About n.                              (* search hypothesis *)
+  About h.                              (* search hypothesis *)
+Abort.
+
+Goal forall n:nat, let g := newdef in n <> newdef n -> newdef n <> n -> False.
+  intros n g h h'.
+  About g.                              (* search hypothesis *)
+  About h.                              (* search hypothesis *)
+Abort.
+
diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out
index 5d8f98ed..c17b285b 100644
--- a/test-suite/output/Search.out
+++ b/test-suite/output/Search.out
@@ -1,24 +1,108 @@
-le_S: forall n m : nat, n <= m -> n <= S m
 le_n: forall n : nat, n <= n
-le_pred: forall n m : nat, n <= m -> pred n <= pred m
+le_S: forall n m : nat, n <= m -> n <= S m
+le_ind:
+  forall (n : nat) (P : nat -> Prop),
+  P n ->
+  (forall m : nat, n <= m -> P m -> P (S m)) ->
+  forall n0 : nat, n <= n0 -> P n0
+le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m
 le_S_n: forall n m : nat, S n <= S m -> n <= m
-false: bool
+le_0_n: forall n : nat, 0 <= n
+le_n_S: forall n m : nat, n <= m -> S n <= S m
+max_l: forall n m : nat, m <= n -> Nat.max n m = n
+max_r: forall n m : nat, n <= m -> Nat.max n m = m
+min_l: forall n m : nat, n <= m -> Nat.min n m = n
+min_r: forall n m : nat, m <= n -> Nat.min n m = m
 true: bool
-xorb: bool -> bool -> bool
+false: bool
+bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b
+bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b
+bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b
+andb: bool -> bool -> bool
 orb: bool -> bool -> bool
-negb: bool -> bool
 implb: bool -> bool -> bool
-andb: bool -> bool -> bool
-pred_Sn: forall n : nat, n = pred (S n)
-plus_n_Sm: forall n m : nat, S (n + m) = n + S m
+xorb: bool -> bool -> bool
+negb: bool -> bool
+andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
+andb_true_intro:
+  forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true
+eq_true: bool -> Prop
+eq_true_rect:
+  forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b
+eq_true_ind:
+  forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b
+eq_true_rec:
+  forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b
+is_true: bool -> Prop
+eq_true_ind_r:
+  forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true
+eq_true_rec_r:
+  forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true
+eq_true_rect_r:
+  forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true
+BoolSpec: Prop -> Prop -> bool -> Prop
+BoolSpec_ind:
+  forall (P Q : Prop) (P0 : bool -> Prop),
+  (P -> P0 true) ->
+  (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b
+Nat.eqb: nat -> nat -> bool
+Nat.leb: nat -> nat -> bool
+Nat.ltb: nat -> nat -> bool
+Nat.even: nat -> bool
+Nat.odd: nat -> bool
+Nat.testbit: nat -> nat -> bool
+Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat
+bool_choice:
+  forall (S : Set) (R1 R2 : S -> Prop),
+  (forall x : S, {R1 x} + {R2 x}) ->
+  {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x}
+eq_S: forall x y : nat, x = y -> S x = S y
+f_equal_nat: forall (B : Type) (f : nat -> B) (x y : nat), x = y -> f x = f y
+f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y
+pred_Sn: forall n : nat, n = Nat.pred (S n)
+eq_add_S: forall n m : nat, S n = S m -> n = m
+not_eq_S: forall n m : nat, n <> m -> S n <> S m
+O_S: forall n : nat, 0 <> S n
+n_Sn: forall n : nat, n <> S n
+f_equal2_plus:
+  forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2
+f_equal2_nat:
+  forall (B : Type) (f : nat -> nat -> B) (x1 y1 x2 y2 : nat),
+  x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2
 plus_n_O: forall n : nat, n = n + 0
-plus_Sn_m: forall n m : nat, S n + m = S (n + m)
 plus_O_n: forall n : nat, 0 + n = n
-mult_n_Sm: forall n m : nat, n * m + n = n * S m
+plus_n_Sm: forall n m : nat, S (n + m) = n + S m
+plus_Sn_m: forall n m : nat, S n + m = S (n + m)
+f_equal2_mult:
+  forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2
 mult_n_O: forall n : nat, 0 = n * 0
-min_r: forall n m : nat, m <= n -> min n m = m
-min_l: forall n m : nat, n <= m -> min n m = n
-max_r: forall n m : nat, n <= m -> max n m = m
-max_l: forall n m : nat, m <= n -> max n m = n
-eq_add_S: forall n m : nat, S n = S m -> n = m
-eq_S: forall x y : nat, x = y -> S x = S y
+mult_n_Sm: forall n m : nat, n * m + n = n * S m
+max_l: forall n m : nat, m <= n -> Nat.max n m = n
+max_r: forall n m : nat, n <= m -> Nat.max n m = m
+min_l: forall n m : nat, n <= m -> Nat.min n m = n
+min_r: forall n m : nat, m <= n -> Nat.min n m = m
+andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
+andb_true_intro:
+  forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true
+bool_choice:
+  forall (S : Set) (R1 R2 : S -> Prop),
+  (forall x : S, {R1 x} + {R2 x}) ->
+  {f : S -> bool | forall x : S, f x = true /\ R1 x \/ f x = false /\ R2 x}
+andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
+andb_true_intro:
+  forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true
+andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true
+h': newdef n <> n
+h: n <> newdef n
+h': newdef n <> n
+h: n <> newdef n
+h: n <> newdef n
+h: n <> newdef n
+h': ~ P n
+h: P n
+h': ~ P n
+h: P n
+h': ~ P n
+h: P n
+h: P n
+h: P n
diff --git a/test-suite/output/Search.v b/test-suite/output/Search.v
index f1489f22..2a0f0b40 100644
--- a/test-suite/output/Search.v
+++ b/test-suite/output/Search.v
@@ -3,3 +3,27 @@
 Search le.				(* app nodes *)
 Search bool. 				(* no apps *)
 Search (@eq nat).			(* complex pattern *)
+Search (@eq _ _ true).
+Search (@eq _ _ _) true -false.         (* andb_prop *)
+Search (@eq _ _ _) true -false "prop" -"intro".  (* andb_prop *)
+       
+Definition newdef := fun x:nat => x.
+
+Goal forall n:nat, n <> newdef n -> newdef n <> n -> False.
+  intros n h h'.
+  Search n.                             (* search hypothesis *)
+  Search newdef.                        (* search hypothesis *)
+  Search ( _ <> newdef _).              (* search hypothesis, pattern *)
+  Search ( _ <> newdef _) -"h'".        (* search hypothesis, pattern *)
+Abort.
+
+Goal forall n (P:nat -> Prop), P n -> ~P n -> False.
+  intros n P h h'.
+  Search P.                 (* search hypothesis also for patterns *)
+  Search (P _).             (* search hypothesis also for patterns *)
+  Search (P n).             (* search hypothesis also for patterns *)
+  Search (P _) -"h'".       (* search hypothesis also for patterns *)
+  Search (P _) -not.       (* search hypothesis also for patterns *)
+
+Abort.
+
diff --git a/test-suite/output/SearchHead.out b/test-suite/output/SearchHead.out
new file mode 100644
index 00000000..0d5924ec
--- /dev/null
+++ b/test-suite/output/SearchHead.out
@@ -0,0 +1,39 @@
+le_n: forall n : nat, n <= n
+le_S: forall n m : nat, n <= m -> n <= S m
+le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m
+le_S_n: forall n m : nat, S n <= S m -> n <= m
+le_0_n: forall n : nat, 0 <= n
+le_n_S: forall n m : nat, n <= m -> S n <= S m
+true: bool
+false: bool
+andb: bool -> bool -> bool
+orb: bool -> bool -> bool
+implb: bool -> bool -> bool
+xorb: bool -> bool -> bool
+negb: bool -> bool
+Nat.eqb: nat -> nat -> bool
+Nat.leb: nat -> nat -> bool
+Nat.ltb: nat -> nat -> bool
+Nat.even: nat -> bool
+Nat.odd: nat -> bool
+Nat.testbit: nat -> nat -> bool
+eq_S: forall x y : nat, x = y -> S x = S y
+f_equal_pred: forall x y : nat, x = y -> Nat.pred x = Nat.pred y
+pred_Sn: forall n : nat, n = Nat.pred (S n)
+eq_add_S: forall n m : nat, S n = S m -> n = m
+f_equal2_plus:
+  forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 + x2 = y1 + y2
+plus_n_O: forall n : nat, n = n + 0
+plus_O_n: forall n : nat, 0 + n = n
+plus_n_Sm: forall n m : nat, S (n + m) = n + S m
+plus_Sn_m: forall n m : nat, S n + m = S (n + m)
+f_equal2_mult:
+  forall x1 y1 x2 y2 : nat, x1 = y1 -> x2 = y2 -> x1 * x2 = y1 * y2
+mult_n_O: forall n : nat, 0 = n * 0
+mult_n_Sm: forall n m : nat, n * m + n = n * S m
+max_l: forall n m : nat, m <= n -> Nat.max n m = n
+max_r: forall n m : nat, n <= m -> Nat.max n m = m
+min_l: forall n m : nat, n <= m -> Nat.min n m = n
+min_r: forall n m : nat, m <= n -> Nat.min n m = m
+h: newdef n
+h: P n
diff --git a/test-suite/output/SearchHead.v b/test-suite/output/SearchHead.v
new file mode 100644
index 00000000..2ee8a0d1
--- /dev/null
+++ b/test-suite/output/SearchHead.v
@@ -0,0 +1,19 @@
+(* Some tests of the Search command *)
+
+SearchHead le.				(* app nodes *)
+SearchHead bool. 				(* no apps *)
+SearchHead (@eq nat).			(* complex pattern *)
+
+Definition newdef := fun x:nat => x = x.
+
+Goal forall n:nat, newdef n -> False.
+  intros n h.
+  SearchHead newdef.             (* search hypothesis *)
+Abort.
+
+
+Goal forall n (P:nat -> Prop), P n -> False.
+  intros n P h.
+  SearchHead P.                  (* search hypothesis also for patterns *)
+Abort.
+
diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out
index 9106a4e3..1eb7eca8 100644
--- a/test-suite/output/SearchPattern.out
+++ b/test-suite/output/SearchPattern.out
@@ -1,30 +1,83 @@
-false: bool
 true: bool
-xorb: bool -> bool -> bool
+false: bool
+andb: bool -> bool -> bool
 orb: bool -> bool -> bool
-negb: bool -> bool
 implb: bool -> bool -> bool
-andb: bool -> bool -> bool
-S: nat -> nat
+xorb: bool -> bool -> bool
+negb: bool -> bool
+Nat.eqb: nat -> nat -> bool
+Nat.leb: nat -> nat -> bool
+Nat.ltb: nat -> nat -> bool
+Nat.even: nat -> bool
+Nat.odd: nat -> bool
+Nat.testbit: nat -> nat -> bool
 O: nat
-pred: nat -> nat
-plus: nat -> nat -> nat
-mult: nat -> nat -> nat
-minus: nat -> nat -> nat
-min: nat -> nat -> nat
-max: nat -> nat -> nat
+S: nat -> nat
 length: forall A : Type, list A -> nat
+Nat.zero: nat
+Nat.one: nat
+Nat.two: nat
+Nat.succ: nat -> nat
+Nat.pred: nat -> nat
+Nat.add: nat -> nat -> nat
+Nat.double: nat -> nat
+Nat.mul: nat -> nat -> nat
+Nat.sub: nat -> nat -> nat
+Nat.max: nat -> nat -> nat
+Nat.min: nat -> nat -> nat
+Nat.pow: nat -> nat -> nat
+Nat.div: nat -> nat -> nat
+Nat.modulo: nat -> nat -> nat
+Nat.gcd: nat -> nat -> nat
+Nat.square: nat -> nat
+Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat
+Nat.sqrt: nat -> nat
+Nat.log2_iter: nat -> nat -> nat -> nat -> nat
+Nat.log2: nat -> nat
+Nat.div2: nat -> nat
+Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat
+Nat.land: nat -> nat -> nat
+Nat.lor: nat -> nat -> nat
+Nat.ldiff: nat -> nat -> nat
+Nat.lxor: nat -> nat -> nat
+
 S: nat -> nat
-pred: nat -> nat
-plus: nat -> nat -> nat
-mult: nat -> nat -> nat
-minus: nat -> nat -> nat
-min: nat -> nat -> nat
-max: nat -> nat -> nat
+Nat.succ: nat -> nat
+Nat.pred: nat -> nat
+Nat.add: nat -> nat -> nat
+Nat.double: nat -> nat
+Nat.mul: nat -> nat -> nat
+Nat.sub: nat -> nat -> nat
+Nat.max: nat -> nat -> nat
+Nat.min: nat -> nat -> nat
+Nat.pow: nat -> nat -> nat
+Nat.div: nat -> nat -> nat
+Nat.modulo: nat -> nat -> nat
+Nat.gcd: nat -> nat -> nat
+Nat.square: nat -> nat
+Nat.sqrt_iter: nat -> nat -> nat -> nat -> nat
+Nat.sqrt: nat -> nat
+Nat.log2_iter: nat -> nat -> nat -> nat -> nat
+Nat.log2: nat -> nat
+Nat.div2: nat -> nat
+Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat
+Nat.land: nat -> nat -> nat
+Nat.lor: nat -> nat -> nat
+Nat.ldiff: nat -> nat -> nat
+Nat.lxor: nat -> nat -> nat
 mult_n_Sm: forall n m : nat, n * m + n = n * S m
-le_n: forall n : nat, n <= n
 identity_refl: forall (A : Type) (a : A), identity a a
-eq_refl: forall (A : Type) (x : A), x = x
 iff_refl: forall A : Prop, A <-> A
+eq_refl: forall (A : Type) (x : A), x = x
+Nat.divmod: nat -> nat -> nat -> nat -> nat * nat
+le_n: forall n : nat, n <= n
 pair: forall A B : Type, A -> B -> A * B
 conj: forall A B : Prop, A -> B -> A /\ B
+Nat.divmod: nat -> nat -> nat -> nat -> nat * nat
+
+h: n <> newdef n
+h: n <> newdef n
+h: P n
+h': ~ P n
+h: P n
+h: P n
diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v
index 802d8c97..bde195a5 100644
--- a/test-suite/output/SearchPattern.v
+++ b/test-suite/output/SearchPattern.v
@@ -17,3 +17,20 @@ SearchPattern (forall (x:?A) (y:?B), _ ?A ?B).
 
 (* No delta-reduction *)
 SearchPattern (Exc _).
+
+Definition newdef := fun x:nat => x.
+
+Goal forall n:nat, n <> newdef n -> False.
+  intros n h.
+  SearchPattern ( _ <> newdef _).          (* search hypothesis *)
+  SearchPattern ( n <> newdef _).          (* search hypothesis *)
+Abort.
+
+Goal forall n (P:nat -> Prop), P n -> ~P n -> False.
+  intros n P h h'.
+  SearchPattern (P _).      (* search hypothesis also for patterns *)
+  Search (~P n).          (* search hypothesis also for patterns *)
+  Search (P _) -"h'".       (* search hypothesis also for patterns *)
+  Search (P _) -not.       (* search hypothesis also for patterns *)
+
+Abort.
\ No newline at end of file
diff --git a/test-suite/output/SearchRewrite.out b/test-suite/output/SearchRewrite.out
index f87aea1c..5edea5df 100644
--- a/test-suite/output/SearchRewrite.out
+++ b/test-suite/output/SearchRewrite.out
@@ -1,2 +1,5 @@
 plus_n_O: forall n : nat, n = n + 0
 plus_O_n: forall n : nat, 0 + n = n
+h: n = newdef n
+h: n = newdef n
+h: n = newdef n
diff --git a/test-suite/output/SearchRewrite.v b/test-suite/output/SearchRewrite.v
index 171a7363..53d043c6 100644
--- a/test-suite/output/SearchRewrite.v
+++ b/test-suite/output/SearchRewrite.v
@@ -2,3 +2,12 @@
 
 SearchRewrite (_+0). 			(* left *)
 SearchRewrite (0+_). 			(* right *)
+
+Definition newdef := fun x:nat => x.
+
+Goal forall n:nat, n = newdef n -> False.
+  intros n h.
+  SearchRewrite (newdef _).
+  SearchRewrite n.                (* use hypothesis for patterns *)
+  SearchRewrite (newdef n).       (* use hypothesis for patterns *)
+Abort.
diff --git a/test-suite/output/TranspModtype.out b/test-suite/output/TranspModtype.out
index f94ed642..67b65d4b 100644
--- a/test-suite/output/TranspModtype.out
+++ b/test-suite/output/TranspModtype.out
@@ -1,7 +1,15 @@
 TrM.A = M.A
      : Set
+
+TrM.A is not universe polymorphic
 OpM.A = M.A
      : Set
+
+OpM.A is not universe polymorphic
 TrM.B = M.B
      : Set
+
+TrM.B is not universe polymorphic
 *** [ OpM.B : Set ]
+
+OpM.B is not universe polymorphic
diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out
index 4f8de1dc..d69baaec 100644
--- a/test-suite/output/inference.out
+++ b/test-suite/output/inference.out
@@ -4,7 +4,17 @@ fun e : option L => match e with
                     | None => None
                     end
      : option L -> option L
-fun n : nat => let x := A n in ?12 ?15:T n
+
+P is not universe polymorphic
+fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H
+     : forall m n p : nat, S m <= S n + p -> m <= n + p
+fun n : nat => let x := A n in ?y ?y0:T n
      : forall n : nat, T n
-fun n : nat => ?20 ?23:T n
+where
+?y : [n : nat  x := A n : T n |- ?T0 -> T n] 
+?y0 : [n : nat  x := A n : T n |- ?T0] 
+fun n : nat => ?y ?y0:T n
      : forall n : nat, T n
+where
+?y : [n : nat |- ?T0 -> T n] 
+?y0 : [n : nat |- ?T0] 
diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v
index 2b564f48..cd9a4a12 100644
--- a/test-suite/output/inference.v
+++ b/test-suite/output/inference.v
@@ -13,6 +13,10 @@ Definition P (e:option L) :=
 
 Print P.
 
+(* Check that plus is folded even if reduction is involved *)
+Check (fun m n p (H : S m <= (S n) + p) => le_S_n _ _ H).
+
+
 (* Check that the heuristic to solve constraints is not artificially
    dependent on the presence of a let-in, and in particular that the
    second [_] below is not inferred to be n, as if obtained by
diff --git a/test-suite/output/names.out b/test-suite/output/names.out
new file mode 100644
index 00000000..2892dfd5
--- /dev/null
+++ b/test-suite/output/names.out
@@ -0,0 +1,6 @@
+The command has indeed failed with message:
+=> Error:
+In environment
+y : nat
+The term "a y" has type "{y0 : nat | y = y0}"
+while it is expected to have type "{x : nat | x = y}".
diff --git a/test-suite/output/names.v b/test-suite/output/names.v
new file mode 100644
index 00000000..b3b5071a
--- /dev/null
+++ b/test-suite/output/names.v
@@ -0,0 +1,5 @@
+(* Test no clash names occur *)
+(* see bug #2723 *)
+
+Parameter a : forall x, {y:nat|x=y}.
+Fail Definition b y : {x:nat|x=y} := a y.
diff --git a/test-suite/output/reduction.v b/test-suite/output/reduction.v
index c4592369..ab626282 100644
--- a/test-suite/output/reduction.v
+++ b/test-suite/output/reduction.v
@@ -1,6 +1,6 @@
 (* Test the behaviour of hnf and simpl introduced in revision *)
 
-Variable n:nat.
+Parameter n:nat.
 Definition a:=0.
 
 Eval simpl in (fix plus (n m : nat) {struct n} : nat :=
diff --git a/test-suite/output/set.out b/test-suite/output/set.out
index 333fbb86..4dfd2bc2 100644
--- a/test-suite/output/set.out
+++ b/test-suite/output/set.out
@@ -6,16 +6,13 @@
    x = x
 1 subgoal
   
-  y1 := 0 : nat
-  y2 := 0 : nat
+  y1, y2 := 0 : nat
   x := y2 + 0 : nat
   ============================
    x = x
 1 subgoal
   
-  y1 := 0 : nat
-  y2 := 0 : nat
-  y3 := 0 : nat
+  y1, y2, y3 := 0 : nat
   x := y2 + y3 : nat
   ============================
    x = x
diff --git a/test-suite/output/simpl.v b/test-suite/output/simpl.v
index 5f1926f1..89638eed 100644
--- a/test-suite/output/simpl.v
+++ b/test-suite/output/simpl.v
@@ -4,10 +4,10 @@ Goal forall x, 0+x = 1+x.
 intro x.
 simpl (_ + x).
 Show.
-Undo.
+Undo 2.
 simpl (_ + x) at 2.
 Show.
-Undo.
+Undo 2.
 simpl (0 + _).
 Show.
-Undo.
+Undo 2.
diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v
new file mode 100755
index 00000000..0d75d52a
--- /dev/null
+++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v
@@ -0,0 +1,3041 @@
+(* This program is free software; you can redistribute it and/or      *)
+(* modify it under the terms of the GNU Lesser General Public License *)
+(* as published by the Free Software Foundation; either version 2.1   *)
+(* of the License, or (at your option) any later version.             *)
+(*                                                                    *)
+(* This program is distributed in the hope that it will be useful,    *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
+(* GNU General Public License for more details.                       *)
+(*                                                                    *)
+(* You should have received a copy of the GNU Lesser General Public   *)
+(* License along with this program; if not, write to the Free         *)
+(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
+(* 02110-1301 USA                                                     *)
+
+
+(** This file includes random facts about Integers (and natural numbers) which are not found in the standard library. Some of the lemma here are not used in the QArith developement but are rather useful.
+*)
+
+Require Export ZArith.
+Require Export ZArithRing.
+
+Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d.
+
+Ltac Flip :=
+  apply Zgt_lt || apply Zlt_gt || apply Zle_ge || apply Zge_le; assumption.
+
+Ltac Falsum :=
+  try intro; apply False_ind;
+   repeat
+    match goal with
+    | id1:(~ ?X1) |- ?X2 =>
+        (apply id1; assumption || reflexivity) || clear id1
+    end.
+
+
+Ltac Step_l a :=
+  match goal with
+  |  |- (?X1 < ?X2)%Z => replace X1 with a; [ idtac | try ring ]
+  end. 
+
+Ltac Step_r a :=
+  match goal with
+  |  |- (?X1 < ?X2)%Z => replace X2 with a; [ idtac | try ring ]
+  end. 
+
+Ltac CaseEq formula :=
+  generalize (refl_equal formula); pattern formula at -1 in |- *;
+   case formula.
+
+
+Lemma pair_1 : forall (A B : Set) (H : A * B), H = pair (fst H) (snd H).
+Proof.
+ intros.
+ case H.
+ intros. 
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma pair_2 :
+ forall (A B : Set) (H1 H2 : A * B),
+ fst H1 = fst H2 -> snd H1 = snd H2 -> H1 = H2.
+Proof.
+ intros A B H1 H2.
+ case H1.
+ case H2.
+ simpl in |- *.
+ intros.
+ rewrite H.
+ rewrite H0.
+ reflexivity.
+Qed.
+
+
+Section projection.   
+ Variable A : Set.
+ Variable P : A -> Prop.
+ 
+ Definition projP1 (H : sig P) := let (x, h) := H in x.
+ Definition projP2 (H : sig P) :=
+   let (x, h) as H return (P (projP1 H)) := H in h.
+End projection.
+
+
+(*###########################################################################*)
+(* Declaring some realtions on natural numbers for stepl and stepr tactics.  *)
+(*###########################################################################*)
+
+Lemma le_stepl: forall x y z, le x y -> x=z -> le z y.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma le_stepr: forall x y z, le x y -> y=z -> le x z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma lt_stepl: forall x y z, lt x y -> x=z -> lt z y.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma lt_stepr: forall x y z, lt x y -> y=z -> lt x z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma neq_stepl:forall (x y z:nat), x<>y -> x=z -> z<>y.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Lemma neq_stepr:forall (x y z:nat), x<>y -> y=z -> x<>z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+
+Declare Left Step le_stepl.
+Declare Right Step le_stepr.
+Declare Left Step lt_stepl.
+Declare Right Step lt_stepr.
+Declare Left Step neq_stepl.
+Declare Right Step neq_stepr.
+
+(*###########################################################################*)
+(** Some random facts about natural numbers, positive numbers and integers   *)
+(*###########################################################################*)
+
+
+Lemma not_O_S : forall n : nat, n <> 0 -> {p : nat | n = S p}.
+Proof. 
+ intros [| np] Hn; [ exists 0; apply False_ind; apply Hn | exists np ];
+  reflexivity. 
+Qed.
+  
+
+Lemma lt_minus_neq : forall m n : nat, m < n -> n - m <> 0.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma lt_minus_eq_0 : forall m n : nat, m < n -> m - n = 0.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_plus_Sn_1_SSn : forall n : nat, S n + 1 <= S (S n).
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_plus_O_l : forall p q : nat, p + q <= 0 -> p = 0.
+Proof. 
+ intros; omega.
+Qed.
+
+Lemma le_plus_O_r : forall p q : nat, p + q <= 0 -> q = 0.
+Proof. 
+ intros; omega.
+Qed.
+
+Lemma minus_pred : forall m n : nat, 0 < n -> pred m - pred n = m - n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+
+(*###########################################################################*)
+(* Declaring some realtions on integers for stepl and stepr tactics.         *)
+(*###########################################################################*)
+
+Lemma Zle_stepl: forall x y z, (x<=y)%Z -> x=z -> (z<=y)%Z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma Zle_stepr: forall x y z, (x<=y)%Z -> y=z -> (x<=z)%Z.
+Proof.
+ intros x y z H_le H_eq; subst z; trivial.
+Qed.
+
+Lemma Zlt_stepl: forall x y z, (x<y)%Z -> x=z -> (z<y)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma Zlt_stepr: forall x y z, (x<y)%Z -> y=z -> (x<z)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst z; trivial.
+Qed.
+
+Lemma Zneq_stepl:forall (x y z:Z), (x<>y)%Z -> x=z -> (z<>y)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Lemma Zneq_stepr:forall (x y z:Z), (x<>y)%Z -> y=z -> (x<>z)%Z.
+Proof.
+ intros x y z H_lt H_eq; subst; assumption.
+Qed.
+
+Declare Left Step Zle_stepl.
+Declare Right Step Zle_stepr.
+Declare Left Step Zlt_stepl.
+Declare Right Step Zlt_stepr.
+Declare Left Step Zneq_stepl.
+Declare Right Step Zneq_stepr.
+
+
+(*###########################################################################*)
+(** Informative case analysis                                                *)
+(*###########################################################################*)
+
+Lemma Zlt_cotrans :
+ forall x y : Z, (x < y)%Z -> forall z : Z, {(x < z)%Z} + {(z < y)%Z}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x z).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zle_lt_trans with (m := x).
+ apply Zge_le.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zlt_cotrans_pos :
+ forall x y : Z, (0 < x + y)%Z -> {(0 < x)%Z} + {(0 < y)%Z}.
+Proof.
+ intros.
+ case (Zlt_cotrans 0 (x + y) H x).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zplus_lt_reg_l with (p := x).
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zlt_cotrans_neg :
+ forall x y : Z, (x + y < 0)%Z -> {(x < 0)%Z} + {(y < 0)%Z}.
+Proof.
+ intros x y H; case (Zlt_cotrans (x + y) 0 H x); intro Hxy;
+  [ right; apply Zplus_lt_reg_l with (p := x); rewrite Zplus_0_r | left ];
+  assumption.
+Qed.
+
+
+
+Lemma not_Zeq_inf : forall x y : Z, x <> y -> {(x < y)%Z} + {(y < x)%Z}.
+Proof.
+ intros.
+ case Z_lt_ge_dec with x y.
+ intro.
+ left.
+ assumption.
+ intro H0.
+ generalize (Zge_le _ _ H0).
+ intro.
+ case (Z_le_lt_eq_dec _ _ H1).
+ intro.
+ right.
+ assumption.
+ intro.
+ apply False_rec.
+ apply H.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Z_dec : forall x y : Z, {(x < y)%Z} + {(x > y)%Z} + {x = y}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x y).
+ intro H.
+ left.
+ left.
+ assumption.
+ intro H.
+ generalize (Zge_le _ _ H).
+ intro H0.
+ case (Z_le_lt_eq_dec y x H0).
+ intro H1.
+ left.
+ right.
+ apply Zlt_gt.
+ assumption.
+ intro.
+ right.
+ symmetry  in |- *.
+ assumption.
+Qed.
+ 
+
+Lemma Z_dec' : forall x y : Z, {(x < y)%Z} + {(y < x)%Z} + {x = y}.
+Proof.
+ intros x y.
+ case (Z_eq_dec x y); intro H;
+  [ right; assumption | left; apply (not_Zeq_inf _ _ H) ].
+Qed.
+
+Lemma Z_lt_le_dec : forall x y : Z, {(x < y)%Z} + {(y <= x)%Z}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec x y).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zge_le.
+ assumption.
+Qed.
+
+Lemma Z_le_lt_dec : forall x y : Z, {(x <= y)%Z} + {(y < x)%Z}.
+Proof.
+ intros; case (Z_lt_le_dec y x); [ right | left ]; assumption.
+Qed.
+
+Lemma Z_lt_lt_S_eq_dec :
+ forall x y : Z, (x < y)%Z -> {(x + 1 < y)%Z} + {(x + 1)%Z = y}.
+Proof.
+ intros.
+ generalize (Zlt_le_succ _ _ H).
+ unfold Zsucc in |- *.
+ apply Z_le_lt_eq_dec.
+Qed.
+
+Lemma quadro_leq_inf :
+ forall a b c d : Z,
+ {(c <= a)%Z /\ (d <= b)%Z} + {~ ((c <= a)%Z /\ (d <= b)%Z)}.
+Proof.
+ intros.
+ case (Z_lt_le_dec a c).
+ intro z.
+ right.
+ intro. 
+ elim H.
+ intros.
+ generalize z.
+ apply Zle_not_lt.
+ assumption.
+ intro.
+ case (Z_lt_le_dec b d).
+ intro z0.
+ right. 
+ intro. 
+ elim H.
+ intros.
+ generalize z0.
+ apply Zle_not_lt.
+ assumption.
+ intro.
+ left.
+ split.
+ assumption.
+ assumption. 
+Qed.
+
+(*###########################################################################*)
+(** General auxiliary lemmata                                                *)
+(*###########################################################################*)
+
+Lemma Zminus_eq : forall x y : Z, (x - y)%Z = 0%Z -> x = y.
+Proof.
+ intros.
+ apply Zplus_reg_l with (- y)%Z.
+ rewrite Zplus_opp_l.
+ unfold Zminus in H.
+ rewrite Zplus_comm.
+ assumption.
+Qed.
+
+Lemma Zlt_minus : forall a b : Z, (b < a)%Z -> (0 < a - b)%Z.
+Proof.
+ intros a b. 
+ intros.
+ apply Zplus_lt_reg_l with b.
+ unfold Zminus in |- *. 
+ rewrite (Zplus_comm a).
+ rewrite (Zplus_assoc b (- b)). 
+ rewrite Zplus_opp_r.
+ simpl in |- *. 
+ rewrite <- Zplus_0_r_reverse. 
+ assumption.
+Qed.
+
+
+Lemma Zle_minus : forall a b : Z, (b <= a)%Z -> (0 <= a - b)%Z.
+Proof.
+ intros a b. 
+ intros.
+ apply Zplus_le_reg_l with b.
+ unfold Zminus in |- *. 
+ rewrite (Zplus_comm a).
+ rewrite (Zplus_assoc b (- b)). 
+ rewrite Zplus_opp_r.
+ simpl in |- *. 
+ rewrite <- Zplus_0_r_reverse. 
+ assumption.
+Qed.
+
+Lemma Zlt_plus_plus :
+ forall m n p q : Z, (m < n)%Z -> (p < q)%Z -> (m + p < n + q)%Z.
+Proof.
+ intros.
+ apply Zlt_trans with (m := (n + p)%Z).
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with (n := n).
+ apply Zplus_lt_compat_l.
+ assumption.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zgt_plus_plus :
+ forall m n p q : Z, (m > n)%Z -> (p > q)%Z -> (m + p > n + q)%Z.
+ intros.
+ apply Zgt_trans with (m := (n + p)%Z).
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with (n := n).
+ apply Zplus_gt_compat_l.
+ assumption.
+ apply Zplus_gt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zle_lt_plus_plus :
+ forall m n p q : Z, (m <= n)%Z -> (p < q)%Z -> (m + p < n + q)%Z.
+Proof.
+ intros.
+ case (Zle_lt_or_eq m n).
+ assumption.
+ intro.
+ apply Zlt_plus_plus.
+ assumption.
+ assumption.
+ intro.
+ rewrite H1.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zge_gt_plus_plus :
+ forall m n p q : Z, (m >= n)%Z -> (p > q)%Z -> (m + p > n + q)%Z.
+Proof.
+ intros.
+ case (Zle_lt_or_eq n m).
+ apply Zge_le.
+ assumption.
+ intro.
+ apply Zgt_plus_plus.
+ apply Zlt_gt.
+ assumption.
+ assumption.
+ intro.
+ rewrite H1.
+ apply Zplus_gt_compat_l.
+ assumption.
+Qed.
+
+Lemma Zgt_ge_plus_plus :
+ forall m n p q : Z, (m > n)%Z -> (p >= q)%Z -> (m + p > n + q)%Z.
+Proof.
+ intros.
+ rewrite Zplus_comm.
+ replace (n + q)%Z with (q + n)%Z.
+ apply Zge_gt_plus_plus.
+ assumption.
+ assumption.
+ apply Zplus_comm.
+Qed.
+
+Lemma Zlt_resp_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x + y)%Z.
+Proof.
+ intros.
+ rewrite <- Zplus_0_r with 0%Z.
+ apply Zlt_plus_plus; assumption.
+Qed.
+
+
+Lemma Zle_resp_neg :
+ forall x y : Z, (x <= 0)%Z -> (y <= 0)%Z -> (x + y <= 0)%Z.
+Proof.
+ intros.
+ rewrite <- Zplus_0_r with 0%Z.
+ apply Zplus_le_compat; assumption.
+Qed.
+
+
+Lemma Zlt_pos_opp : forall x : Z, (0 < x)%Z -> (- x < 0)%Z.
+Proof.
+ intros.
+ apply Zplus_lt_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+Lemma Zlt_neg_opp : forall x : Z, (x < 0)%Z -> (0 < - x)%Z.
+Proof.
+ intros.
+ apply Zplus_lt_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zle_neg_opp : forall x : Z, (x <= 0)%Z -> (0 <= - x)%Z.
+Proof. 
+ intros.
+ apply Zplus_le_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+Lemma Zle_pos_opp : forall x : Z, (0 <= x)%Z -> (- x <= 0)%Z.
+Proof. 
+ intros.
+ apply Zplus_le_reg_l with x.
+ rewrite Zplus_opp_r.
+ rewrite Zplus_0_r.
+ assumption.
+Qed.
+
+
+Lemma Zge_opp : forall x y : Z, (x <= y)%Z -> (- x >= - y)%Z.
+Proof.
+ intros.
+ apply Zle_ge.
+ apply Zplus_le_reg_l with (p := (x + y)%Z).
+ ring_simplify (x + y + - y)%Z (x + y + - x)%Z.
+ assumption.
+Qed.
+
+
+
+(* Omega can't solve this *)
+Lemma Zmult_pos_pos : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_neg_neg : forall x y : Z, (x < 0)%Z -> (y < 0)%Z -> (0 < x * y)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_neg_pos : forall x y : Z, (x < 0)%Z -> (0 < y)%Z -> (x * y < 0)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+Lemma Zmult_pos_neg : forall x y : Z, (0 < x)%Z -> (y < 0)%Z -> (x * y < 0)%Z.
+Proof.
+ intros [| px| px] [| py| py] Hx Hy; trivial || constructor.
+Qed.
+
+
+
+Hint Resolve Zmult_pos_pos Zmult_neg_neg Zmult_neg_pos Zmult_pos_neg: zarith.
+
+
+Lemma Zle_reg_mult_l :
+ forall x y a : Z, (0 < a)%Z -> (x <= y)%Z -> (a * x <= a * y)%Z.
+Proof.
+ intros.
+ apply Zplus_le_reg_l with (p := (- a * x)%Z).
+ ring_simplify (- a * x + a * x)%Z.
+ replace (- a * x + a * y)%Z with ((y - x) * a)%Z.
+ apply Zmult_gt_0_le_0_compat.
+ apply Zlt_gt.
+ assumption. 
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+ ring.
+Qed.
+
+Lemma Zsimpl_plus_l_dep :
+ forall x y m n : Z, (x + m)%Z = (y + n)%Z -> x = y -> m = n.
+Proof.
+ intros.
+ apply Zplus_reg_l with x.
+ rewrite <- H0 in H.
+ assumption.
+Qed.
+
+
+Lemma Zsimpl_plus_r_dep :
+ forall x y m n : Z, (m + x)%Z = (n + y)%Z -> x = y -> m = n.
+Proof.
+ intros.
+ apply Zplus_reg_l with x.
+ rewrite Zplus_comm.
+ rewrite Zplus_comm with x n.
+ rewrite <- H0 in H.
+ assumption.
+Qed.
+
+Lemma Zmult_simpl :
+ forall n m p q : Z, n = m -> p = q -> (n * p)%Z = (m * q)%Z.
+Proof.
+ intros.
+ rewrite H.
+ rewrite H0.
+ reflexivity.
+Qed.
+ 
+Lemma Zsimpl_mult_l :
+ forall n m p : Z, n <> 0%Z -> (n * m)%Z = (n * p)%Z -> m = p.
+Proof.
+ intros.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + p)%Z with 0%Z.
+ apply Zmult_integral_l with (n := n).
+ assumption.
+ replace ((- p + m) * n)%Z with (n * m + - (n * p))%Z.
+ apply Zegal_left.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+Lemma Zlt_reg_mult_l :
+ forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. (*QA*)
+Proof.
+ intros.
+ case (Zcompare_Gt_spec x 0).
+ unfold Zgt in H.
+ assumption.
+ intros.
+ cut (x = Zpos x0). 
+ intro.
+ rewrite H2.
+ unfold Zlt in H0.
+ unfold Zlt in |- *.
+ cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z).
+ intro.
+ exact (trans_eq H3 H0).
+ apply Zcompare_mult_compat.
+ cut (x = (x + - (0))%Z).
+ intro.
+ exact (trans_eq H2 H1).
+ simpl in |- *.
+ apply (sym_eq (A:=Z)).
+ exact (Zplus_0_r x).
+Qed.
+
+
+Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. (*QA*)
+Proof.
+ intros.
+ red in |- *.
+ apply sym_eq.
+ cut (Datatypes.Gt = (y ?= x)%Z).
+ intro.
+ cut ((y ?= x)%Z = (- x ?= - y)%Z).
+ intro.
+ exact (trans_eq H0 H1). 
+ exact (Zcompare_opp y x).
+ apply sym_eq.
+ exact (Zlt_gt x y H).
+Qed.
+
+
+Lemma Zlt_conv_mult_l :
+ forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. (*QA*)
+Proof.
+ intros.
+ cut (- x > 0)%Z.
+ intro.
+ cut (- x * y < - x * z)%Z.
+ intro.
+ cut (- (- x * y) > - (- x * z))%Z.
+ intro.
+ cut (- - (x * y) > - - (x * z))%Z.
+ intro.
+ cut ((- - (x * y))%Z = (x * y)%Z).
+ intro.
+ rewrite H5 in H4.
+ cut ((- - (x * z))%Z = (x * z)%Z).
+ intro.
+ rewrite H6 in H4.
+ assumption.
+ exact (Zopp_involutive (x * z)).
+ exact (Zopp_involutive (x * y)).
+ cut ((- (- x * y))%Z = (- - (x * y))%Z).
+ intro.
+ rewrite H4 in H3.
+ cut ((- (- x * z))%Z = (- - (x * z))%Z). 
+ intro.
+ rewrite H5 in H3.
+ assumption.
+ cut ((- x * z)%Z = (- (x * z))%Z).
+ intro.
+ exact (f_equal Zopp H5).
+ exact (Zopp_mult_distr_l_reverse x z).
+ cut ((- x * y)%Z = (- (x * y))%Z).
+ intro.
+ exact (f_equal Zopp H4).
+ exact (Zopp_mult_distr_l_reverse x y).
+ exact (Zlt_opp (- x * y) (- x * z) H2).
+ exact (Zlt_reg_mult_l (- x) y z H1 H0).
+ exact (Zlt_opp x 0 H).
+Qed.
+
+Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y.   (*QA*)
+Proof.
+ intros.
+ cut (y < x)%Z.
+ intro.
+ cut (y <> x).
+ intro.
+ red in |- *.
+ intros.
+ cut (y = x).
+ intros.
+ apply H1.
+ assumption.
+ exact (sym_eq H2).
+ exact (Zorder.Zlt_not_eq y x H0).
+ exact (Zgt_lt x y H).
+Qed.
+
+Lemma Zmult_resp_nonzero :
+ forall x y : Z, x <> 0%Z -> y <> 0%Z -> (x * y)%Z <> 0%Z.
+Proof.
+ intros x y Hx Hy Hxy.
+ apply Hx. 
+ apply Zmult_integral_l with y; assumption.
+Qed.
+
+
+Lemma Zopp_app : forall y : Z, y <> 0%Z -> (- y)%Z <> 0%Z.
+Proof.
+ intros.
+ intro.
+ apply H.
+ apply Zplus_reg_l with (- y)%Z.
+ rewrite Zplus_opp_l.
+ rewrite H0.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zle_neq_Zlt : forall a b : Z, (a <= b)%Z -> b <> a -> (a < b)%Z.
+Proof.
+ intros a b H H0.
+ case (Z_le_lt_eq_dec _ _ H); trivial.
+ intro; apply False_ind; apply H0; symmetry  in |- *; assumption.
+Qed.
+
+Lemma not_Zle_lt : forall x y : Z, ~ (y <= x)%Z -> (x < y)%Z.
+Proof.
+ intros; apply Zgt_lt; apply Znot_le_gt; assumption.
+Qed.
+
+Lemma not_Zlt : forall x y : Z, ~ (y < x)%Z -> (x <= y)%Z.
+Proof.
+ intros x y H1 H2; apply H1; apply Zgt_lt; assumption.
+Qed.
+
+
+Lemma Zmult_absorb :
+ forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z.  (*QA*)
+Proof.
+ intros.
+ case (dec_eq y z).
+ intro.
+ assumption.
+ intro.
+ case (not_Zeq y z).
+ assumption.
+ intro.
+ case (not_Zeq x 0).
+ assumption.
+ intro.
+ apply False_ind.
+ cut (x * y > x * z)%Z.
+ intro.
+ cut ((x * y)%Z <> (x * z)%Z).
+ intro.
+ apply H5.
+ assumption.
+ exact (Zgt_not_eq (x * y) (x * z) H4).
+ exact (Zlt_conv_mult_l x y z H3 H2).
+ intro.
+ apply False_ind.
+ cut (x * y < x * z)%Z.
+ intro.
+ cut ((x * y)%Z <> (x * z)%Z).
+ intro.
+ apply H5.
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * y) (x * z) H4).
+ cut (x > 0)%Z.
+ intro.
+ exact (Zlt_reg_mult_l x y z H4 H2).
+ exact (Zlt_gt 0 x H3).
+ intro.
+ apply False_ind.
+ cut (x * z < x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H4.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * z) (x * y) H3).
+ apply False_ind.
+ case (not_Zeq x 0).
+ assumption.
+ intro.
+ cut (x * z > x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H5.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zgt_not_eq (x * z) (x * y) H4).
+ exact (Zlt_conv_mult_l x z y H3 H2).
+ intro.
+ cut (x * z < x * y)%Z.
+ intro.
+ cut ((x * z)%Z <> (x * y)%Z).
+ intro.
+ apply H5.
+ apply (sym_eq (A:=Z)).
+ assumption.
+ exact (Zorder.Zlt_not_eq (x * z) (x * y) H4).
+ cut (x > 0)%Z.
+ intro.
+ exact (Zlt_reg_mult_l x z y H4 H2).
+ exact (Zlt_gt 0 x H3).
+Qed.
+
+Lemma Zlt_mult_mult :
+ forall a b c d : Z,
+ (0 < a)%Z -> (0 < d)%Z -> (a < b)%Z -> (c < d)%Z -> (a * c < b * d)%Z.
+Proof.
+ intros.
+ apply Zlt_trans with (a * d)%Z.
+ apply Zlt_reg_mult_l.
+ Flip. 
+ assumption.
+ rewrite Zmult_comm.
+ rewrite Zmult_comm with b d.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+Qed.
+
+Lemma Zgt_mult_conv_absorb_l :
+ forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. (*QC*)
+Proof.
+ intros.
+ case (dec_eq x y).
+ intro.
+ apply False_ind.
+ rewrite H1 in H0.
+ cut ((a * y)%Z = (a * y)%Z).
+ change ((a * y)%Z <> (a * y)%Z) in |- *.
+ apply Zgt_not_eq.
+ assumption.
+ trivial.
+ 
+ intro.
+ case (not_Zeq x y H1).
+ trivial.
+ 
+ intro.
+ apply False_ind.
+ cut (a * y > a * x)%Z.
+ apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z).
+ assumption.
+ apply Zlt_conv_mult_l.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zgt_mult_reg_absorb_l :
+ forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. (*QC*)
+Proof.
+ intros.
+ cut (- - a > - - (0))%Z.
+ intro.
+ cut (- a < - (0))%Z.
+ simpl in |- *.
+ intro.
+ replace x with (- - x)%Z.
+ replace y with (- - y)%Z.
+ apply Zlt_opp.
+ apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z).
+ assumption.
+ rewrite Zmult_opp_opp.
+ rewrite Zmult_opp_opp.
+ assumption.
+ apply Zopp_involutive.
+ apply Zopp_involutive.
+ apply Zgt_lt.
+ apply Zlt_opp.
+ apply Zgt_lt.
+ assumption.
+ simpl in |- *.
+ rewrite Zopp_involutive.
+ assumption.
+Qed.
+
+Lemma Zopp_Zlt : forall x y : Z, (y < x)%Z -> (- x < - y)%Z.
+Proof.
+ intros x y Hyx.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ replace (-1 * - y)%Z with y.
+ replace (-1 * - x)%Z with x.
+ Flip.
+ ring.
+ ring.
+Qed.
+
+
+Lemma Zmin_cancel_Zlt : forall x y : Z, (- x < - y)%Z -> (y < x)%Z.
+Proof.
+ intros.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ replace (-1 * y)%Z with (- y)%Z.
+ replace (-1 * x)%Z with (- x)%Z.
+ apply Zlt_gt.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+Lemma Zmult_cancel_Zle :
+ forall a x y : Z, (a < 0)%Z -> (a * x <= a * y)%Z -> (y <= x)%Z.
+Proof.
+ intros.
+ case (Z_le_gt_dec y x).
+ trivial.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl (a * x)).
+ apply Zle_lt_trans with (m := (a * y)%Z).
+ assumption.
+ apply Zgt_lt.
+ apply Zlt_conv_mult_l.
+ assumption.
+ apply Zgt_lt.
+ assumption.
+Qed.
+
+Lemma Zlt_mult_cancel_l :
+ forall x y z : Z, (0 < x)%Z -> (x * y < x * z)%Z -> (y < z)%Z.
+Proof.
+ intros.
+ apply Zgt_lt.
+ apply Zgt_mult_reg_absorb_l with x.
+ apply Zlt_gt.
+ assumption. 
+ apply Zlt_gt.
+ assumption.
+Qed.
+ 
+
+Lemma Zmin_cancel_Zle : forall x y : Z, (- x <= - y)%Z -> (y <= x)%Z.
+Proof. 
+ intros.
+ apply Zmult_cancel_Zle with (a := (-1)%Z).
+ constructor.
+ replace (-1 * y)%Z with (- y)%Z.
+ replace (-1 * x)%Z with (- x)%Z.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+
+Lemma Zmult_resp_Zle :
+ forall a x y : Z, (0 < a)%Z -> (a * y <= a * x)%Z -> (y <= x)%Z.
+Proof.
+ intros.
+ case (Z_le_gt_dec y x).
+ trivial.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl (a * y)).
+ apply Zle_lt_trans with (m := (a * x)%Z).
+ assumption.
+ apply Zlt_reg_mult_l.
+ apply Zlt_gt.
+ assumption.
+ apply Zgt_lt.
+ assumption.
+Qed.
+
+Lemma Zopp_Zle : forall x y : Z, (y <= x)%Z -> (- x <= - y)%Z.
+Proof. 
+ intros.
+ apply Zmult_cancel_Zle with (a := (-1)%Z).
+ constructor.
+ replace (-1 * - y)%Z with y.
+ replace (-1 * - x)%Z with x.
+ assumption.
+ clear y H; ring.
+ clear x H; ring.
+Qed.
+
+ 
+Lemma Zle_lt_eq_S : forall x y : Z, (x <= y)%Z -> (y < x + 1)%Z -> y = x.
+Proof.
+ intros.
+ case (Z_le_lt_eq_dec x y H).
+ intro H1.
+ apply False_ind.
+ generalize (Zlt_le_succ x y H1).
+ intro.
+ apply (Zlt_not_le y (x + 1) H0).  
+ replace (x + 1)%Z with (Zsucc x).
+ assumption.
+ reflexivity.
+ intro H1.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Zlt_le_eq_S :
+ forall x y : Z, (x < y)%Z -> (y <= x + 1)%Z -> y = (x + 1)%Z.
+Proof.
+ intros.
+ case (Z_le_lt_eq_dec y (x + 1) H0).
+ intro H1.
+ apply False_ind.
+ generalize (Zlt_le_succ x y H).
+ intro.
+ apply (Zlt_not_le y (x + 1) H1).  
+ replace (x + 1)%Z with (Zsucc x).
+ assumption.
+ reflexivity.
+ trivial.
+Qed.
+
+
+Lemma double_not_equal_zero :
+ forall c d : Z, ~ (c = 0%Z /\ d = 0%Z) -> c <> d \/ c <> 0%Z.
+Proof.
+ intros.
+ case (Z_zerop c).
+ intro.
+ rewrite e.  
+ left.
+ apply sym_not_eq. 
+ intro.
+ apply H; repeat split; assumption.
+ intro; right; assumption.
+Qed.
+
+Lemma triple_not_equal_zero :
+ forall a b c : Z,
+ ~ (a = 0%Z /\ b = 0%Z /\ c = 0%Z) -> a <> 0%Z \/ b <> 0%Z \/ c <> 0%Z.
+Proof.
+ intros a b c H; case (Z_zerop a); intro Ha;
+            [ case (Z_zerop b); intro Hb;
+               [ case (Z_zerop c); intro Hc;
+                  [ apply False_ind; apply H; repeat split | right; right ]
+               | right; left ]
+            | left ]; assumption.
+Qed. 
+
+Lemma mediant_1 :
+ forall m n m' n' : Z, (m' * n < m * n')%Z -> ((m + m') * n < m * (n + n'))%Z.
+Proof.
+ intros. 
+ rewrite Zmult_plus_distr_r. 
+ rewrite Zmult_plus_distr_l.
+ apply Zplus_lt_compat_l.
+ assumption.
+Qed.
+ 
+Lemma mediant_2 :
+ forall m n m' n' : Z,
+ (m' * n < m * n')%Z -> (m' * (n + n') < (m + m') * n')%Z. 
+Proof.
+ intros.
+ rewrite Zmult_plus_distr_l.
+ rewrite Zmult_plus_distr_r.
+ apply Zplus_lt_compat_r.
+ assumption.
+Qed.
+
+
+Lemma mediant_3 :
+ forall a b m n m' n' : Z,
+ (0 <= a * m + b * n)%Z ->
+ (0 <= a * m' + b * n')%Z -> (0 <= a * (m + m') + b * (n + n'))%Z.
+Proof.
+ intros.
+ replace (a * (m + m') + b * (n + n'))%Z with
+  (a * m + b * n + (a * m' + b * n'))%Z.
+ apply Zplus_le_0_compat.
+ assumption.
+ assumption.
+ ring.
+Qed. 
+
+Lemma fraction_lt_trans :
+ forall a b c d e f : Z,
+ (0 < b)%Z ->
+ (0 < d)%Z ->
+ (0 < f)%Z -> (a * d < c * b)%Z -> (c * f < e * d)%Z -> (a * f < e * b)%Z.
+Proof.
+ intros.
+ apply Zgt_lt.
+ apply Zgt_mult_reg_absorb_l with d.
+ Flip.
+ apply Zgt_trans with (c * b * f)%Z.
+ replace (d * (e * b))%Z with (b * (e * d))%Z.
+ replace (c * b * f)%Z with (b * (c * f))%Z.
+ apply Zlt_gt.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+ ring.
+ ring.
+ replace (c * b * f)%Z with (f * (c * b))%Z.  
+ replace (d * (a * f))%Z with (f * (a * d))%Z.
+ apply Zlt_gt.
+ apply Zlt_reg_mult_l.
+ Flip.
+ assumption.
+ ring.
+ ring.
+Qed.
+
+
+Lemma square_pos : forall a : Z, a <> 0%Z -> (0 < a * a)%Z.
+Proof.
+ intros [| p| p]; intros; [ Falsum | constructor | constructor ].
+Qed.
+ 
+Hint Resolve square_pos: zarith.
+
+(*###########################################################################*)
+(** Properties of positive numbers, mapping between Z and nat                *)
+(*###########################################################################*)
+
+
+Definition Z2positive (z : Z) :=
+  match z with
+  | Zpos p => p
+  | Zneg p => p
+  | Z0 => 1%positive
+  end.
+
+
+Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. (*QF*)
+Proof.
+ intro.
+ cut (exists h : nat, nat_of_P p = S h).
+ intro.
+ case H.
+ intros.
+ unfold Z_of_nat in |- *.
+ rewrite H0.
+ 
+ apply f_equal with (A := positive) (B := Z) (f := Zpos).
+ cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)).
+ intro.
+ rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1.
+ cut (Ppred (Psucc p) = Ppred (P_of_succ_nat (S x))).
+ intro.
+ rewrite Ppred_succ in H2.
+ simpl in H2.
+ rewrite Ppred_succ in H2.
+ apply sym_eq.
+ assumption.
+ apply f_equal with (A := positive) (B := positive) (f := Ppred).
+ assumption.
+ apply f_equal with (f := P_of_succ_nat).
+ assumption.
+ apply ZL4.
+Qed.
+
+Coercion Z_of_nat : nat >-> Z.
+
+Lemma ZERO_lt_POS : forall p : positive, (0 < Zpos p)%Z.
+Proof.
+ intros.
+ constructor.
+Qed.
+
+
+Lemma POS_neq_ZERO : forall p : positive, Zpos p <> 0%Z.
+Proof.
+ intros.
+ apply sym_not_eq.
+ apply Zorder.Zlt_not_eq.
+ apply ZERO_lt_POS.
+Qed.
+
+Lemma NEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z.
+Proof.
+ intros.
+ apply Zorder.Zlt_not_eq.
+ unfold Zlt in |- *.
+ constructor.
+Qed.
+
+
+Lemma POS_resp_eq : forall p0 p1 : positive, Zpos p0 = Zpos p1 -> p0 = p1.
+Proof.
+ intros.
+ injection H.
+ trivial.
+Qed.
+
+Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. (*QF*)
+Proof.
+ intros.
+ apply Zlt_gt.
+ cut (Z_of_nat m + 1 > 0)%Z.
+ intro.
+ cut (0 < Z_of_nat n + 1)%Z.
+ intro.
+ cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z.
+ rewrite Zmult_0_r.
+ intro.
+ assumption.
+ 
+ apply Zlt_reg_mult_l.
+ assumption.
+ assumption.
+ change (0 < Zsucc (Z_of_nat n))%Z in |- *.
+ apply Zle_lt_succ.
+ change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *.
+ apply Znat.inj_le.
+ apply le_O_n.
+ apply Zlt_gt.
+ change (0 < Zsucc (Z_of_nat m))%Z in |- *.
+ apply Zle_lt_succ.
+ change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *.
+ apply Znat.inj_le.
+ apply le_O_n.
+Qed.
+ 
+ 
+Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. (*QF*)
+Proof.
+ intros.
+ case (O_or_S m).
+ intro.
+ case s.
+ intros.
+ rewrite <- e. 
+ rewrite <- pred_Sn with (n := x). 
+ trivial.
+ intro.
+ apply False_ind.
+ apply H.
+ apply sym_eq.
+ assumption.
+Qed.
+
+Lemma absolu_1 : forall x : Z, Zabs_nat x = 0 -> x = 0%Z. (*QF*)
+Proof.
+ intros.
+ case (dec_eq x 0).
+ intro.
+ assumption.
+ intro.
+ apply False_ind.
+ cut ((x < 0)%Z \/ (x > 0)%Z).
+ intro.
+ ElimCompare x 0%Z.
+ intro.
+ cut (x = 0%Z).
+ assumption.
+ cut ((x ?= 0)%Z = Datatypes.Eq -> x = 0%Z).
+ intro.
+ apply H3.
+ assumption.
+ apply proj1 with (B := x = 0%Z -> (x ?= 0)%Z = Datatypes.Eq).
+ change ((x ?= 0)%Z = Datatypes.Eq <-> x = 0%Z) in |- *.
+ apply Zcompare_Eq_iff_eq.
+ 
+ (***)
+ intro.
+ cut (exists h : nat, Zabs_nat x = S h).
+ intro.
+ case H3.
+ rewrite H.
+ exact O_S.
+ 
+ change (x < 0)%Z in H2.
+ cut (0 > x)%Z.
+ intro.
+ cut (exists p : positive, (0 + - x)%Z = Zpos p).
+ simpl in |- *.
+ intro.
+ case H4.
+ intros.
+ cut (exists q : positive, x = Zneg q).
+ intro.
+ case H6.
+ intros.
+ rewrite H7.
+ unfold Zabs_nat in |- *.
+ generalize x1.
+ exact ZL4.
+ cut (x = (- Zpos x0)%Z).
+ simpl in |- *.
+ intro.
+ exists x0.
+ assumption.
+ cut ((- - x)%Z = x).
+ intro.
+ rewrite <- H6.
+ exact (f_equal Zopp H5). 
+ apply Zopp_involutive.
+ apply Zcompare_Gt_spec.
+ assumption.
+ apply Zlt_gt.
+ assumption.
+ 
+ (***)
+ intro.
+ cut (exists h : nat, Zabs_nat x = S h).
+ intro.
+ case H3.
+ rewrite H.
+ exact O_S.
+ 
+ cut (exists p : positive, (x + - (0))%Z = Zpos p).
+ simpl in |- *.
+ rewrite Zplus_0_r.
+ intro.
+ case H3.
+ intros.
+ rewrite H4.
+ unfold Zabs_nat in |- *.
+ generalize x0.
+ exact ZL4.
+ apply Zcompare_Gt_spec.
+ assumption.
+ 
+ (***)
+ cut ((x < 0)%Z \/ (0 < x)%Z).
+ intro.
+ apply
+  or_ind with (A := (x < 0)%Z) (B := (0 < x)%Z) (P := (x < 0)%Z \/ (x > 0)%Z).
+ intro.
+ left.
+ assumption.
+ intro.
+ right.
+ apply Zlt_gt.
+ assumption.
+ assumption.
+ apply not_Zeq.
+ assumption.
+Qed.
+
+Lemma absolu_2 : forall x : Z, x <> 0%Z -> Zabs_nat x <> 0. (*QF*)
+Proof.
+ intros.
+ intro.
+ apply H.
+ apply absolu_1.
+ assumption.
+Qed.
+
+
+
+
+Lemma absolu_inject_nat : forall n : nat, Zabs_nat (Z_of_nat n) = n.
+Proof.
+ simple induction n; simpl in |- *.
+ reflexivity.
+ intros.
+ apply nat_of_P_o_P_of_succ_nat_eq_succ.
+Qed.
+
+
+Lemma eq_inj : forall m n : nat, m = n :>Z -> m = n.
+Proof.
+ intros.
+ generalize (f_equal Zabs_nat H). 
+ intro.
+ rewrite (absolu_inject_nat m) in H0.
+ rewrite (absolu_inject_nat n) in H0.
+ assumption.
+Qed.
+
+Lemma lt_inj : forall m n : nat, (m < n)%Z -> m < n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+Lemma le_inj : forall m n : nat, (m <= n)%Z -> m <= n.
+Proof.
+ intros.
+ omega.
+Qed.
+
+
+Lemma inject_nat_S_inf : forall x : Z, (0 < x)%Z -> {n : nat | x = S n}.
+Proof.
+ intros [| p| p] Hp; try discriminate Hp.
+ exists (pred (nat_of_P p)).
+ rewrite S_predn.
+ symmetry  in |- *; apply ZL9.
+ clear Hp;
+  apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P.
+Qed.
+
+
+
+Lemma le_absolu :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> (x <= y)%Z -> Zabs_nat x <= Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy Hxy;
+  apply le_O_n ||
+    (try
+      match goal with
+      | id1:(0 <= Zneg _)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      | id1:(Zpos _ <= 0)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+          apply False_ind; apply id1; constructor
+      end).
+ simpl in |- *. 
+ apply le_inj.
+ do 2 rewrite ZL9.
+ assumption.
+Qed.
+
+Lemma lt_absolu :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> (x < y)%Z -> Zabs_nat x < Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy Hxy; inversion Hxy;
+  try
+   match goal with
+   | id1:(0 <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= 0)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   end; simpl in |- *; apply lt_inj; repeat rewrite ZL9; 
+  assumption.
+Qed.
+
+Lemma absolu_plus :
+ forall x y : Z,
+ (0 <= x)%Z -> (0 <= y)%Z -> Zabs_nat (x + y) = Zabs_nat x + Zabs_nat y.
+Proof.
+ intros [| x| x] [| y| y] Hx Hy; trivial;
+  try
+   match goal with
+   | id1:(0 <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= 0)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   | id1:(Zpos _ <= Zneg _)%Z |- _ =>
+       apply False_ind; apply id1; constructor
+   end.
+ rewrite <- BinInt.Zpos_plus_distr.
+ unfold Zabs_nat in |- *.
+ apply nat_of_P_plus_morphism.
+Qed.
+
+Lemma pred_absolu :
+ forall x : Z, (0 < x)%Z -> pred (Zabs_nat x) = Zabs_nat (x - 1).
+Proof.
+ intros x Hx.
+ generalize (Z_lt_lt_S_eq_dec 0 x Hx); simpl in |- *; intros [H1| H1];
+  [ replace (Zabs_nat x) with (Zabs_nat (x - 1 + 1));
+     [ idtac | apply f_equal with Z; auto with zarith ];
+     rewrite absolu_plus;
+     [ unfold Zabs_nat at 2, nat_of_P, Piter_op in |- *; omega
+     | auto with zarith
+     | intro; discriminate ]
+  | rewrite <- H1; reflexivity ].
+Qed. 
+
+Definition pred_nat : forall (x : Z) (Hx : (0 < x)%Z), nat.
+intros [| px| px] Hx; try abstract (discriminate Hx).
+exact (pred (nat_of_P px)).
+Defined.
+
+Lemma pred_nat_equal :
+ forall (x : Z) (Hx1 Hx2 : (0 < x)%Z), pred_nat x Hx1 = pred_nat x Hx2.
+Proof.
+ intros [| px| px] Hx1 Hx2; try (discriminate Hx1); trivial.
+Qed.
+
+Let pred_nat_unfolded_subproof px :
+  Pos.to_nat px <> 0.
+Proof.
+apply sym_not_equal; apply lt_O_neq; apply lt_O_nat_of_P.
+Qed.
+
+Lemma pred_nat_unfolded :
+ forall (x : Z) (Hx : (0 < x)%Z), x = S (pred_nat x Hx).
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite S_predn.
+ symmetry  in |- *; apply ZL9.
+ clear Hx; apply pred_nat_unfolded_subproof.
+Qed.
+
+Lemma absolu_pred_nat :
+ forall (m : Z) (Hm : (0 < m)%Z), S (pred_nat m Hm) = Zabs_nat m.
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite S_predn.
+ reflexivity.
+ apply pred_nat_unfolded_subproof.
+Qed.
+
+Lemma pred_nat_absolu :
+ forall (m : Z) (Hm : (0 < m)%Z), pred_nat m Hm = Zabs_nat (m - 1).
+Proof.
+ intros [| px| px] Hx; try discriminate Hx.
+ unfold pred_nat in |- *.
+ rewrite <- pred_absolu; reflexivity || assumption.
+Qed.
+
+Lemma minus_pred_nat :
+ forall (n m : Z) (Hn : (0 < n)%Z) (Hm : (0 < m)%Z) (Hnm : (0 < n - m)%Z),
+ S (pred_nat n Hn) - S (pred_nat m Hm) = S (pred_nat (n - m) Hnm).
+Proof.
+ intros.
+ simpl in |- *.  
+ destruct n; try discriminate Hn.
+ destruct m; try discriminate Hm.
+ unfold pred_nat at 1 2 in |- *.
+ rewrite minus_pred; try apply lt_O_nat_of_P.
+ apply eq_inj.
+ rewrite <- pred_nat_unfolded. 
+ rewrite Znat.inj_minus1.
+ repeat rewrite ZL9. 
+ reflexivity.
+ apply le_inj.
+ apply Zlt_le_weak.
+ repeat rewrite ZL9.
+ apply Zlt_O_minus_lt.
+ assumption.
+Qed.
+
+
+(*###########################################################################*)
+(** Properties of Zsgn                                                       *)
+(*###########################################################################*)
+
+
+Lemma Zsgn_1 :
+ forall x : Z, {Zsgn x = 0%Z} + {Zsgn x = 1%Z} + {Zsgn x = (-1)%Z}. (*QF*)
+Proof.
+ intros.
+ case x.
+ left.
+ left.
+ unfold Zsgn in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ left.
+ right.
+ reflexivity.
+ intro.
+ right.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zsgn_2 : forall x : Z, Zsgn x = 0%Z -> x = 0%Z.   (*QF*)
+Proof.
+ intros [| p1| p1]; simpl in |- *; intro H; constructor || discriminate H.
+Qed.
+
+
+Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Zsgn x <> 0%Z.   (*QF*)
+Proof.
+ intro.
+ case x.
+ intros.
+ apply False_ind.
+ apply H.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ discriminate.
+ intros.
+ simpl in |- *.
+ discriminate.
+Qed.
+
+
+
+
+Theorem Zsgn_4 : forall a : Z, a = (Zsgn a * Zabs_nat a)%Z.  (*QF*)
+Proof.
+ intro.
+ case a.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ unfold Zsgn in |- *.
+ unfold Zabs_nat in |- *.
+ rewrite Zmult_1_l.
+ symmetry  in |- *.
+ apply ZL9.
+ intros.
+ unfold Zsgn in |- *.
+ unfold Zabs_nat in |- *.
+ rewrite ZL9.
+ constructor.
+Qed.
+
+
+Theorem Zsgn_5 :
+ forall a b x y : Z,
+ x <> 0%Z ->
+ y <> 0%Z ->
+ (Zsgn a * x)%Z = (Zsgn b * y)%Z -> (Zsgn a * y)%Z = (Zsgn b * x)%Z.  (*QF*)
+Proof.
+ intros a b x y H H0.
+ case a.
+
+ case b.
+ simpl in |- *.
+ trivial.
+
+ intro.
+ unfold Zsgn in |- *.
+ intro.
+ rewrite Zmult_1_l in H1.
+ simpl in H1.
+ apply False_ind.
+ apply H0.
+ symmetry  in |- *.
+ assumption.
+ intro.
+ unfold Zsgn in |- *.
+ intro.
+ apply False_ind.
+ apply H0.
+ apply Zopp_inj.
+ simpl in |- *.
+ transitivity (-1 * y)%Z.
+ constructor.
+ transitivity (0 * x)%Z.
+ symmetry  in |- *.
+ assumption.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ unfold Zsgn at 1 in |- *.
+ unfold Zsgn at 2 in |- *.
+ intro.
+ transitivity y.
+ rewrite Zmult_1_l.
+ reflexivity.
+ transitivity (Zsgn b * (Zsgn b * y))%Z.
+ case (Zsgn_1 b).
+ intro.
+ case s.
+ intro.
+ apply False_ind.
+ apply H.
+ rewrite e in H1.
+ change ((1 * x)%Z = 0%Z) in H1.
+ rewrite Zmult_1_l in H1.
+ assumption.
+ intro.
+ rewrite e.
+ rewrite Zmult_1_l.
+ rewrite Zmult_1_l.
+ reflexivity.
+ intro.
+ rewrite e.
+ ring.
+ rewrite Zmult_1_l in H1.
+ rewrite H1.
+ reflexivity.
+ intro.
+ unfold Zsgn at 1 in |- *.
+ unfold Zsgn at 2 in |- *.
+ intro.
+ transitivity (Zsgn b * (-1 * (Zsgn b * y)))%Z.
+ case (Zsgn_1 b).
+ intros.
+ case s.
+ intro.
+ apply False_ind.
+ apply H.
+ apply Zopp_inj.
+ transitivity (-1 * x)%Z.
+ ring.
+ unfold Zopp in |- *.
+ rewrite e in H1.
+ transitivity (0 * y)%Z.
+ assumption.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ rewrite e.
+ ring.
+ intro.
+ rewrite e.
+ ring.
+ rewrite <- H1.
+ ring.
+Qed.
+
+Lemma Zsgn_6 : forall x : Z, x = 0%Z -> Zsgn x = 0%Z.
+Proof.
+ intros.
+ rewrite H.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+
+Lemma Zsgn_7 : forall x : Z, (x > 0)%Z -> Zsgn x = 1%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ Flip.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ apply False_ind.
+ apply (Zlt_irrefl (Zneg p)).
+ apply Zlt_trans with 0%Z.
+ constructor.
+ Flip.
+Qed.
+
+
+Lemma Zsgn_7' : forall x : Z, (0 < x)%Z -> Zsgn x = 1%Z.
+Proof.
+ intros; apply Zsgn_7; Flip.
+Qed.
+
+
+Lemma Zsgn_8 : forall x : Z, (x < 0)%Z -> Zsgn x = (-1)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ assumption.
+ intros.
+ apply False_ind.
+ apply (Zlt_irrefl 0).
+ apply Zlt_trans with (Zpos p).
+ constructor.
+ assumption.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zsgn_9 : forall x : Z, Zsgn x = 1%Z -> (0 < x)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ simpl in H.
+ discriminate.
+ intros.
+ constructor.
+ intros.
+ apply False_ind.
+ discriminate.
+Qed.
+ 
+Lemma Zsgn_10 : forall x : Z, Zsgn x = (-1)%Z -> (x < 0)%Z.
+Proof.
+ intro.
+ case x.
+ intro.
+ apply False_ind.
+ discriminate.
+ intros.
+ apply False_ind.
+ discriminate.
+ intros.
+ constructor.
+Qed. 
+
+Lemma Zsgn_11 : forall x : Z, (Zsgn x < 0)%Z -> (x < 0)%Z.
+Proof.
+ intros.
+ apply Zsgn_10.
+ case (Zsgn_1 x).
+ intro.
+ apply False_ind.
+ case s.
+ intro.
+ generalize (Zorder.Zlt_not_eq _ _ H). 
+ intro.
+ apply (H0 e).
+ intro.
+ rewrite e in H.
+ generalize (Zorder.Zlt_not_eq _ _ H).
+ intro.
+ discriminate.
+ trivial.
+Qed. 
+
+Lemma Zsgn_12 : forall x : Z, (0 < Zsgn x)%Z -> (0 < x)%Z.
+Proof.
+ intros.
+ apply Zsgn_9.
+ case (Zsgn_1 x).
+ intro.
+ case s.
+ intro.
+ generalize (Zorder.Zlt_not_eq _ _ H). 
+ intro.
+ generalize (sym_eq e).
+ intro.
+ apply False_ind.
+ apply (H0 H1).
+ trivial.
+ intro.
+ rewrite e in H.
+ generalize (Zorder.Zlt_not_eq _ _ H).
+ intro.
+ apply False_ind.
+ discriminate.
+Qed.   
+
+Lemma Zsgn_13 : forall x : Z, (0 <= Zsgn x)%Z -> (0 <= x)%Z.
+Proof.
+ intros. 
+ case (Z_le_lt_eq_dec 0 (Zsgn x) H).
+ intro.
+ apply Zlt_le_weak.
+ apply Zsgn_12.
+ assumption. 
+ intro.
+ assert (x = 0%Z). 
+ apply Zsgn_2.
+ symmetry  in |- *.
+ assumption.
+ rewrite H0.
+ apply Zle_refl.
+Qed.
+
+Lemma Zsgn_14 : forall x : Z, (Zsgn x <= 0)%Z -> (x <= 0)%Z.
+Proof.
+ intros. 
+ case (Z_le_lt_eq_dec (Zsgn x) 0 H).
+ intro.
+ apply Zlt_le_weak.
+ apply Zsgn_11.
+ assumption. 
+ intro.
+ assert (x = 0%Z). 
+ apply Zsgn_2.
+ assumption.
+ rewrite H0.
+ apply Zle_refl.
+Qed.
+
+Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor.
+Qed.
+
+Lemma Zsgn_16 :
+ forall x y : Z,
+ Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right ]; repeat split.
+Qed. 
+
+Lemma Zsgn_17 :
+ forall x y : Z,
+ Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right ]; repeat split.
+Qed. 
+
+Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  try discriminate H; [ left | right | right ]; constructor.
+Qed. 
+
+
+
+Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  discriminate H || (constructor || apply Zsgn_12; assumption).
+Qed.
+
+Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H;
+  discriminate H || (constructor || apply Zsgn_11; assumption).
+Qed.
+
+
+Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z.
+Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0;
+  discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z.
+Proof.
+ Proof.
+ intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0;
+  discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z.
+Proof.
+ intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *;
+  intros H H0; discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z.
+Proof.
+ intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *;
+  intros H H0; discriminate H || discriminate H0.
+Qed.
+
+Lemma Zsgn_25 : forall x : Z, Zsgn (- x) = (- Zsgn x)%Z.
+Proof.
+ intros [| p1| p1]; simpl in |- *; reflexivity.
+Qed.
+
+
+Lemma Zsgn_26 : forall x : Z, (0 < x)%Z -> (0 < Zsgn x)%Z.
+Proof.
+ intros [| p| p] Hp; trivial.
+Qed.
+
+Lemma Zsgn_27 : forall x : Z, (x < 0)%Z -> (Zsgn x < 0)%Z.
+Proof.
+ intros [| p| p] Hp; trivial.
+Qed.
+
+Hint Resolve Zsgn_1 Zsgn_2 Zsgn_3 Zsgn_4 Zsgn_5 Zsgn_6 Zsgn_7 Zsgn_7' Zsgn_8
+  Zsgn_9 Zsgn_10 Zsgn_11 Zsgn_12 Zsgn_13 Zsgn_14 Zsgn_15 Zsgn_16 Zsgn_17
+  Zsgn_18 Zsgn_19 Zsgn_20 Zsgn_21 Zsgn_22 Zsgn_23 Zsgn_24 Zsgn_25 Zsgn_26
+  Zsgn_27: zarith.
+
+(*###########################################################################*)
+(** Properties of Zabs                                                       *)
+(*###########################################################################*)
+
+Lemma Zabs_1 : forall z p : Z, (Zabs z < p)%Z -> (z < p)%Z /\ (- p < z)%Z.
+Proof.
+ intros z p.
+ case z.
+ intros.
+ simpl in H.
+ split.
+ assumption.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl; trivial.
+ ring_simplify (-1 * - p)%Z (-1 * 0)%Z.
+ apply Zlt_gt.
+ assumption.
+
+ intros.
+ simpl in H.
+ split.
+ assumption.
+ apply Zlt_trans with (m := 0%Z).
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl; trivial.
+ ring_simplify (-1 * - p)%Z (-1 * 0)%Z.
+ apply Zlt_gt.
+ apply Zlt_trans with (m := Zpos p0).
+ constructor.
+ assumption.
+ constructor.
+
+ intros.
+ simpl in H.
+ split.
+ apply Zlt_trans with (m := Zpos p0).
+ constructor.
+ assumption.
+ 
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ replace (-1)%Z with (Zpred 0).
+ apply Zlt_pred.
+ simpl;trivial.
+ ring_simplify (-1 * - p)%Z.
+ replace (-1 * Zneg p0)%Z with (- Zneg p0)%Z.
+ replace (- Zneg p0)%Z with (Zpos p0). 
+ apply Zlt_gt.
+ assumption.
+ symmetry  in |- *.
+ apply Zopp_neg.
+ rewrite Zopp_mult_distr_l_reverse with (n := 1%Z). 
+ simpl in |- *.
+ constructor.
+Qed.
+
+
+Lemma Zabs_2 : forall z p : Z, (Zabs z > p)%Z -> (z > p)%Z \/ (- p > z)%Z.
+Proof.
+ intros z p.
+ case z.
+ intros.
+ simpl in H.
+ left.
+ assumption.
+
+ intros.
+ simpl in H.
+ left.
+ assumption.
+
+ intros.
+ simpl in H.
+ right.
+ apply Zlt_gt.
+ apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+ constructor.
+ ring_simplify (-1 * - p)%Z.
+ replace (-1 * Zneg p0)%Z with (Zpos p0).
+ assumption.
+ reflexivity.
+Qed.
+
+Lemma Zabs_3 : forall z p : Z, (z < p)%Z /\ (- p < z)%Z -> (Zabs z < p)%Z.
+Proof.
+ intros z p.
+ case z.
+  intro. 
+  simpl in |- *.
+  elim H.
+  intros.
+  assumption.
+  
+  intros.
+  elim H.
+  intros.
+  simpl in |- *.
+  assumption.
+  
+  intros.
+  elim H.
+  intros.
+  simpl in |- *.
+  apply Zgt_mult_conv_absorb_l with (a := (-1)%Z).
+  constructor.
+  replace (-1 * Zpos p0)%Z with (Zneg p0).
+  replace (-1 * p)%Z with (- p)%Z.
+  apply Zlt_gt.
+  assumption.
+  ring.  
+  simpl in |- *.
+  reflexivity.
+Qed.
+
+Lemma Zabs_4 : forall z p : Z, (Zabs z < p)%Z -> (- p < z < p)%Z.
+Proof.
+ intros.
+ split.
+ apply proj2 with (A := (z < p)%Z).
+ apply Zabs_1.
+ assumption.
+ apply proj1 with (B := (- p < z)%Z).
+ apply Zabs_1.
+ assumption.
+Qed.
+ 
+
+Lemma Zabs_5 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z <= p)%Z.
+Proof.
+ intros.
+ split.
+ replace (- p)%Z with (Zsucc (- Zsucc p)).
+ apply Zlt_le_succ.
+ apply proj2 with (A := (z < Zsucc p)%Z).
+ apply Zabs_1.
+ apply Zle_lt_succ.
+ assumption.
+ unfold Zsucc in |- *.
+ ring.
+ apply Zlt_succ_le.
+ apply proj1 with (B := (- Zsucc p < z)%Z).
+ apply Zabs_1.
+ apply Zle_lt_succ.
+ assumption.
+Qed.
+
+Lemma Zabs_6 : forall z p : Z, (Zabs z <= p)%Z -> (z <= p)%Z.
+Proof.
+ intros.
+ apply proj2 with (A := (- p <= z)%Z).
+ apply Zabs_5.
+ assumption.
+Qed.
+
+Lemma Zabs_7 : forall z p : Z, (Zabs z <= p)%Z -> (- p <= z)%Z.
+Proof.
+ intros.
+ apply proj1 with (B := (z <= p)%Z).
+ apply Zabs_5.
+ assumption.
+Qed.
+
+Lemma Zabs_8 : forall z p : Z, (- p <= z <= p)%Z -> (Zabs z <= p)%Z.
+Proof.
+ intros.
+ apply Zlt_succ_le.
+ apply Zabs_3.
+ elim H.
+ intros.
+ split.
+ apply Zle_lt_succ.
+ assumption.
+ apply Zlt_le_trans with (m := (- p)%Z).
+ apply Zgt_lt. 
+ apply Zlt_opp.
+ apply Zlt_succ.
+ assumption.
+Qed.
+
+Lemma Zabs_min : forall z : Z, Zabs z = Zabs (- z).
+Proof.
+ intro.
+ case z.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ reflexivity.
+ intro.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zabs_9 :
+ forall z p : Z, (0 <= p)%Z -> (p < z)%Z \/ (z < - p)%Z -> (p < Zabs z)%Z.
+Proof.
+ intros.
+ case H0.
+ intro.
+ replace (Zabs z) with z.
+ assumption.
+ symmetry  in |- *.
+ apply Zabs_eq.
+ apply Zlt_le_weak.
+ apply Zle_lt_trans with (m := p).
+ assumption.
+ assumption.
+ intro.
+ cut (Zabs z = (- z)%Z).
+ intro.
+ rewrite H2.
+ apply Zmin_cancel_Zlt.
+ ring_simplify (- - z)%Z.
+ assumption.
+ rewrite Zabs_min.
+ apply Zabs_eq.
+ apply Zlt_le_weak.
+ apply Zle_lt_trans with (m := p).
+ assumption.
+ apply Zmin_cancel_Zlt.
+ ring_simplify (- - z)%Z.
+ assumption.
+Qed.
+
+Lemma Zabs_10 : forall z : Z, (0 <= Zabs z)%Z.
+Proof.
+ intro.
+ case (Z_zerop z).
+ intro.
+ rewrite e.
+ simpl in |- *.
+ apply Zle_refl.
+ intro.
+ case (not_Zeq z 0 n).
+ intro.
+ apply Zlt_le_weak.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ right.
+ assumption.
+ intro.
+ apply Zlt_le_weak.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ left.
+ assumption.
+Qed.
+
+Lemma Zabs_11 : forall z : Z, z <> 0%Z -> (0 < Zabs z)%Z.
+Proof.
+ intros.
+ apply Zabs_9.
+ apply Zle_refl.
+ simpl in |- *.
+ apply not_Zeq.
+ intro.
+ apply H.
+ symmetry  in |- *.
+ assumption.
+Qed.
+
+Lemma Zabs_12 : forall z m : Z, (m < Zabs z)%Z -> {(m < z)%Z} + {(z < - m)%Z}.
+Proof.
+ intros [| p| p] m; simpl in |- *; intros H;
+  [ left | left | right; apply Zmin_cancel_Zlt; rewrite Zopp_involutive ];
+  assumption.
+Qed.
+
+Lemma Zabs_mult : forall z p : Z, Zabs (z * p) = (Zabs z * Zabs p)%Z.
+Proof.
+ intros.
+ case z.
+ simpl in |- *.
+ reflexivity.
+ case p.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ case p.
+ intro.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zabs_plus : forall z p : Z, (Zabs (z + p) <= Zabs z + Zabs p)%Z.
+Proof.
+ intros.
+ case z.
+ simpl in |- *.
+ apply Zle_refl.
+ case p.
+ intro.
+ simpl in |- *.
+ apply Zle_refl.
+ intros.
+ simpl in |- *.
+ apply Zle_refl.
+ intros.
+ unfold Zabs at 2 in |- *.
+ unfold Zabs at 2 in |- *.
+ apply Zabs_8.
+ split.
+ apply Zplus_le_reg_l with (Zpos p1 - Zneg p0)%Z.
+ replace (Zpos p1 - Zneg p0 + - (Zpos p1 + Zpos p0))%Z with
+  (- (Zpos p0 + Zneg p0))%Z.
+ replace (Zpos p1 - Zneg p0 + (Zpos p1 + Zneg p0))%Z with (2 * Zpos p1)%Z.
+ replace (- (Zpos p0 + Zneg p0))%Z with 0%Z.
+ apply Zmult_gt_0_le_0_compat.
+ constructor.
+ apply Zlt_le_weak.
+ constructor.
+ rewrite <- Zopp_neg with p0.
+ ring.
+ ring.
+ ring.
+ apply Zplus_le_compat.
+ apply Zle_refl.
+ apply Zlt_le_weak.
+ constructor.
+ 
+ case p.
+ simpl in |- *.
+ intro.
+ apply Zle_refl.
+ intros.
+ unfold Zabs at 2 in |- *.
+ unfold Zabs at 2 in |- *.
+ apply Zabs_8.
+ split.
+ apply Zplus_le_reg_l with (Zpos p1 + Zneg p0)%Z.
+ replace (Zpos p1 + Zneg p0 + - (Zpos p1 + Zpos p0))%Z with
+  (Zneg p0 - Zpos p0)%Z.
+ replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with 0%Z.
+ apply Zplus_le_reg_l with (Zpos p0).
+ replace (Zpos p0 + (Zneg p0 - Zpos p0))%Z with (Zneg p0).
+ simpl in |- *.
+ apply Zlt_le_weak.
+ constructor.
+ ring.
+ replace (Zpos p1 + Zneg p0 + (Zneg p1 + Zpos p0))%Z with
+  (Zpos p1 + Zneg p1 + (Zpos p0 + Zneg p0))%Z.
+ replace 0%Z with (0 + 0)%Z.
+ apply Zplus_eq_compat.
+ rewrite <- Zopp_neg with p1.
+ ring.
+ rewrite <- Zopp_neg with p0.
+ ring.
+ simpl in |- *.
+ constructor.
+ ring.
+ ring.
+ apply Zplus_le_compat.
+ apply Zlt_le_weak.
+ constructor.
+ apply Zle_refl.
+ intros.
+ simpl in |- *.
+ apply Zle_refl.
+Qed.
+
+Lemma Zabs_neg : forall z : Z, (z <= 0)%Z -> Zabs z = (- z)%Z.
+Proof.
+ intro.
+ case z.
+ simpl in |- *.
+ intro.
+ reflexivity.
+ intros.
+ apply False_ind.
+ apply H.
+ simpl in |- *.
+ reflexivity.
+ intros.
+ simpl in |- *.
+ reflexivity.
+Qed.
+
+Lemma Zle_Zabs: forall z, (z <= Zabs z)%Z.
+Proof.
+ intros [|z|z]; simpl; auto with zarith; apply Zle_neg_pos. 
+Qed.
+ 
+Hint Resolve Zabs_1 Zabs_2 Zabs_3 Zabs_4 Zabs_5 Zabs_6 Zabs_7 Zabs_8 Zabs_9
+  Zabs_10 Zabs_11 Zabs_12 Zabs_min Zabs_neg Zabs_mult Zabs_plus Zle_Zabs: zarith.
+
+
+(*###########################################################################*)
+(** Induction on Z                                                           *)
+(*###########################################################################*)
+
+Lemma Zind :
+ forall (P : Z -> Prop) (p : Z),
+ P p ->
+ (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) ->
+ forall q : Z, (p <= q)%Z -> P q. 
+Proof.
+ intros P p.
+ intro.
+ intro.
+ cut (forall q : Z, (p <= q)%Z -> exists k : nat, q = (p + k)%Z).
+ intro.
+ cut (forall k : nat, P (p + k)%Z).
+ intro.
+ intros.
+ cut (exists k : nat, q = (p + Z_of_nat k)%Z).
+ intro.
+ case H4.
+ intros.
+ rewrite H5.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ ring_simplify (p + 0)%Z.
+ assumption.
+ replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (Z_of_nat 0). 
+ ring_simplify (- p + (p + Z_of_nat k))%Z.
+ apply Znat.inj_le.
+ apply le_O_n.
+ ring_simplify; auto with arith. 
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ ring.
+ intros.
+ cut (exists k : nat, (q - p)%Z = Z_of_nat k).
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + q)%Z with (q - p)%Z.
+ rewrite H3.
+ ring.
+ ring.
+ apply Z_of_nat_complete.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec :
+ forall (P : Z -> Set) (p : Z),
+ P p ->
+ (forall q : Z, (p <= q)%Z -> P q -> P (q + 1)%Z) ->
+ forall q : Z, (p <= q)%Z -> P q. 
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (p <= q)%Z -> {k : nat | q = (p + k)%Z}).
+ intro.
+ cut (forall k : nat, F (p + k)%Z).
+ intro.
+ intros.
+ cut {k : nat | q = (p + Z_of_nat k)%Z}.
+ intro.
+ case H4.
+ intros.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ rewrite Zplus_0_r.
+ assumption.
+ replace (p + Z_of_nat (S k))%Z with (p + k + 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (Z_of_nat 0). 
+ replace (- p + (p + Z_of_nat k))%Z with (Z_of_nat k).
+ apply Znat.inj_le.
+ apply le_O_n.
+ rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ rewrite Zplus_opp_l; reflexivity.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ apply Zplus_assoc_reverse.
+ intros.
+ cut {k : nat | (q - p)%Z = Z_of_nat k}.
+ intro H2.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zplus_reg_l with (n := (- p)%Z).
+ replace (- p + q)%Z with (q - p)%Z.
+ rewrite e.
+ rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ unfold Zminus in |- *.
+ apply Zplus_comm.
+ apply Z_of_nat_complete_inf.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec_down :
+ forall (P : Z -> Set) (p : Z),
+ P p ->
+ (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) ->
+ forall q : Z, (q <= p)%Z -> P q.
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (q <= p)%Z -> {k : nat | q = (p - k)%Z}).
+ intro.
+ cut (forall k : nat, F (p - k)%Z).
+ intro.
+ intros.
+ cut {k : nat | q = (p - Z_of_nat k)%Z}.
+ intro.
+ case H4.
+ intros.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ replace (p - 0)%Z with p.
+ assumption.
+ unfold Zminus in |- *.
+ unfold Zopp in |- *.
+ rewrite Zplus_0_r; reflexivity.
+ replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (- Z_of_nat 0)%Z. 
+ replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z.
+ apply Zge_le.
+ apply Zge_opp.
+ apply Znat.inj_le.
+ apply le_O_n.
+ unfold Zminus in |- *; rewrite Zplus_assoc; rewrite Zplus_opp_l; reflexivity.
+ rewrite Zplus_opp_l; reflexivity.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ unfold Zminus at 1 2 in |- *.
+ rewrite Zplus_assoc_reverse.
+ rewrite <- Zopp_plus_distr.
+ reflexivity.
+ intros.
+ cut {k : nat | (p - q)%Z = Z_of_nat k}.
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zopp_inj. 
+ apply Zplus_reg_l with (n := p).
+ replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). 
+ rewrite <- e.
+ reflexivity.
+ unfold Zminus in |- *.
+ rewrite Zopp_plus_distr.
+ rewrite Zplus_assoc.
+ rewrite Zplus_opp_r.
+ rewrite Zopp_involutive.
+ reflexivity.
+ apply Z_of_nat_complete_inf.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zind_down :
+ forall (P : Z -> Prop) (p : Z),
+ P p ->
+ (forall q : Z, (q <= p)%Z -> P q -> P (q - 1)%Z) ->
+ forall q : Z, (q <= p)%Z -> P q.
+Proof.
+ intros F p.
+ intro.
+ intro.
+ cut (forall q : Z, (q <= p)%Z -> exists k : nat, q = (p - k)%Z).
+ intro.
+ cut (forall k : nat, F (p - k)%Z).
+ intro.
+ intros.
+ cut (exists k : nat, q = (p - Z_of_nat k)%Z).
+ intro.
+ case H4.
+ intros x e.
+ rewrite e.
+ apply H2.
+ apply H1.
+ assumption.
+ intro.
+ induction  k as [| k Hreck].
+ simpl in |- *.
+ replace (p - 0)%Z with p.
+ assumption.
+ ring.
+ replace (p - Z_of_nat (S k))%Z with (p - k - 1)%Z.
+ apply H0.
+ apply Zplus_le_reg_l with (p := (- p)%Z).
+ replace (- p + p)%Z with (- Z_of_nat 0)%Z. 
+ replace (- p + (p - Z_of_nat k))%Z with (- Z_of_nat k)%Z.
+ apply Zge_le.
+ apply Zge_opp.
+ apply Znat.inj_le.
+ apply le_O_n.
+ ring. 
+ ring_simplify; auto with arith.
+ assumption.
+ rewrite (Znat.inj_S k).
+ unfold Zsucc in |- *.
+ ring.
+ intros.
+ cut (exists k : nat, (p - q)%Z = Z_of_nat k).
+ intro.
+ case H2.
+ intro k.
+ intros.
+ exists k.
+ apply Zopp_inj. 
+ apply Zplus_reg_l with (n := p).
+ replace (p + - (p - Z_of_nat k))%Z with (Z_of_nat k). 
+ rewrite <- H3.
+ ring.
+ ring.
+ apply Z_of_nat_complete.
+ unfold Zminus in |- *.
+ apply Zle_left.
+ assumption.
+Qed.
+
+Lemma Zrec_wf :
+ forall (P : Z -> Set) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ forall q : Z, (p <= q)%Z -> P q.
+Proof.
+ intros P p WF_ind_step q Hq.
+ cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y).
+ intro.
+ apply (H (Zsucc q)).
+ apply Zle_le_succ.
+ assumption.
+ 
+ split; [ assumption | exact (Zlt_succ q) ].
+
+ intros x0 Hx0; generalize Hx0; pattern x0 in |- *. 
+ apply Zrec with (p := p).
+ intros.
+ absurd (p <= p)%Z.
+ apply Zgt_not_le.
+ apply Zgt_le_trans with (m := y).
+ apply Zlt_gt.
+ elim H.
+ intros.
+ assumption.
+ elim H.
+ intros.
+ assumption.
+ apply Zle_refl.
+
+ intros. 
+ apply WF_ind_step. 
+ intros.
+ apply (H0 H).
+ split. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zlt_le_trans with y. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zgt_succ_le. 
+ apply Zlt_gt. 
+ elim H1.
+ intros.
+ unfold Zsucc in |- *.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zrec_wf2 :
+ forall (q : Z) (P : Z -> Set) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ (p <= q)%Z -> P q.
+Proof.
+ intros.
+ apply Zrec_wf with (p := p).
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zrec_wf_double :
+ forall (P : Z -> Z -> Set) (p0 q0 : Z),
+ (forall n m : Z,
+  (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) ->
+  (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) ->
+ forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q.
+Proof.
+ intros P p0 q0 Hrec p.
+ intros.
+ generalize q H.
+ pattern p in |- *.
+ apply Zrec_wf with (p := p0).
+ intros p1 H1.
+ intros.
+ pattern q1 in |- *.
+ apply Zrec_wf with (p := q0).
+ intros q2 H3.
+ apply Hrec.
+ intros.
+ apply H1.
+ assumption.
+ assumption.
+ intros.
+ apply H3.
+ assumption.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf :
+ forall (P : Z -> Prop) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ forall q : Z, (p <= q)%Z -> P q.
+Proof.
+ intros P p WF_ind_step q Hq.
+ cut (forall x : Z, (p <= x)%Z -> forall y : Z, (p <= y < x)%Z -> P y).
+ intro.
+ apply (H (Zsucc q)).
+ apply Zle_le_succ.
+ assumption.
+ 
+ split; [ assumption | exact (Zlt_succ q) ].
+
+ intros x0 Hx0; generalize Hx0; pattern x0 in |- *. 
+ apply Zind with (p := p).
+ intros.
+ absurd (p <= p)%Z.
+ apply Zgt_not_le.
+ apply Zgt_le_trans with (m := y).
+ apply Zlt_gt.
+ elim H.
+ intros.
+ assumption.
+ elim H.
+ intros.
+ assumption.
+ apply Zle_refl.
+
+ intros. 
+ apply WF_ind_step. 
+ intros.
+ apply (H0 H).
+ split. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zlt_le_trans with y. 
+ elim H2.
+ intros.
+ assumption.
+ apply Zgt_succ_le. 
+ apply Zlt_gt. 
+ elim H1.
+ intros.
+ unfold Zsucc in |- *.
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf2 :
+ forall (q : Z) (P : Z -> Prop) (p : Z),
+ (forall q : Z, (forall r : Z, (p <= r < q)%Z -> P r) -> P q) ->
+ (p <= q)%Z -> P q.
+Proof.
+ intros.
+ apply Zind_wf with (p := p).
+ assumption.
+ assumption.
+Qed.
+
+Lemma Zind_wf_double :
+ forall (P : Z -> Z -> Prop) (p0 q0 : Z),
+ (forall n m : Z,
+  (forall p q : Z, (q0 <= q)%Z -> (p0 <= p < n)%Z -> P p q) ->
+  (forall p : Z, (q0 <= p < m)%Z -> P n p) -> P n m) ->
+ forall p q : Z, (q0 <= q)%Z -> (p0 <= p)%Z -> P p q.
+Proof.
+ intros P p0 q0 Hrec p.
+ intros.
+ generalize q H.
+ pattern p in |- *.
+ apply Zind_wf with (p := p0).
+ intros p1 H1.
+ intros.
+ pattern q1 in |- *.
+ apply Zind_wf with (p := q0).
+ intros q2 H3.
+ apply Hrec.
+ intros.
+ apply H1.
+ assumption.
+ assumption.
+ intros.
+ apply H3.
+ assumption.
+ assumption.
+ assumption.
+Qed.
+
+(*###########################################################################*)
+(** Properties of Zmax                                                       *)
+(*###########################################################################*)
+
+Definition Zmax (n m : Z) := (n + m - Zmin n m)%Z.
+
+Lemma ZmaxSS : forall n m : Z, (Zmax n m + 1)%Z = Zmax (n + 1) (m + 1).
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ replace (Zmin (n + 1) (m + 1)) with (Zmin n m + 1)%Z.
+ ring.
+ symmetry  in |- *.
+ change (Zmin (Zsucc n) (Zsucc m) = Zsucc (Zmin n m)) in |- *.
+ symmetry  in |- *.
+ apply Zmin_SS.
+Qed.
+
+Lemma Zle_max_l : forall n m : Z, (n <= Zmax n m)%Z.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ apply Zplus_le_reg_l with (p := (- n + Zmin n m)%Z).
+ ring_simplify (- n + Zmin n m + n)%Z.
+ ring_simplify (- n + Zmin n m + (n + m - Zmin n m))%Z.
+ apply Zle_min_r.
+Qed.
+
+Lemma Zle_max_r : forall n m : Z, (m <= Zmax n m)%Z.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ apply Zplus_le_reg_l with (p := (- m + Zmin n m)%Z).
+ ring_simplify (- m + Zmin n m + m)%Z.
+ ring_simplify (- m + Zmin n m + (n + m - Zmin n m))%Z.
+ apply Zle_min_l.
+Qed.
+
+
+Lemma Zmin_or_informative : forall n m : Z, {Zmin n m = n} + {Zmin n m = m}.
+Proof.
+ intros.
+ case (Z_lt_ge_dec n m).
+ unfold Zmin in |- *.
+ unfold Zlt in |- *.
+ intro z.
+ rewrite z.
+ left.
+ reflexivity.
+ intro.
+ cut ({(n > m)%Z} + {n = m :>Z}).
+ intro.
+ case H.
+ intros z0.
+ unfold Zmin in |- *.
+ unfold Zgt in z0.
+ rewrite z0.
+ right.
+ reflexivity.
+ intro.
+ rewrite e.
+ right.
+ apply Zmin_n_n.
+ cut ({(m < n)%Z} + {m = n :>Z}).
+ intro.
+ elim H.
+ intro.
+ left.
+ apply Zlt_gt.
+ assumption.
+ intro.
+ right.
+ symmetry  in |- *.
+ assumption.
+ apply Z_le_lt_eq_dec. 
+ apply Zge_le.
+ assumption.
+Qed.
+
+Lemma Zmax_case : forall (n m : Z) (P : Z -> Set), P n -> P m -> P (Zmax n m).
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ case Zmin_or_informative with (n := n) (m := m).
+ intro.
+ rewrite e.
+ cut ((n + m - n)%Z = m).
+ intro.
+ rewrite H1.
+ assumption.
+ ring.
+ intro.
+ rewrite e.
+ cut ((n + m - m)%Z = n).
+ intro.
+ rewrite H1.
+ assumption.
+ ring.
+Qed.
+ 
+Lemma Zmax_or_informative : forall n m : Z, {Zmax n m = n} + {Zmax n m = m}. 
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ case Zmin_or_informative with (n := n) (m := m).
+ intro.
+ rewrite e.
+ right.
+ ring.
+ intro.
+ rewrite e.
+ left.
+ ring.
+Qed.
+
+Lemma Zmax_n_n : forall n : Z, Zmax n n = n.
+Proof.
+ intros.
+ unfold Zmax in |- *.
+ rewrite (Zmin_n_n n).
+ ring.
+Qed.
+
+Hint Resolve ZmaxSS Zle_max_r Zle_max_l Zmax_n_n: zarith.
+
+(*###########################################################################*)
+(** Properties of Arity                                                      *)
+(*###########################################################################*)
+
+Lemma Zeven_S : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x + 1).
+Proof.
+ exact Zeven.Zeven_Sn.
+Qed.
+
+Lemma Zeven_pred : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). 
+Proof.
+ exact Zeven.Zeven_pred.
+Qed.
+
+(* This lemma used to be useful since it was mentioned with an unnecessary premise 
+   `x>=0` as Z_modulo_2 in ZArith, but the ZArith version has been fixed. *)
+
+Definition Z_modulo_2_always :
+  forall x : Z, {y : Z | x = (2 * y)%Z} + {y : Z | x = (2 * y + 1)%Z} :=
+  Zeven.Z_modulo_2.
+
+(*###########################################################################*)
+(** Properties of Zdiv                                                       *)
+(*###########################################################################*)
+
+Lemma Z_div_mod_eq_2 :
+ forall a b : Z, (0 < b)%Z -> (b * (a / b))%Z = (a - a mod b)%Z.
+Proof.
+ intros.
+ apply Zplus_minus_eq.
+ rewrite Zplus_comm.
+ apply Z_div_mod_eq.
+ Flip.
+Qed.
+
+Lemma Z_div_le :
+ forall a b c : Z, (0 < c)%Z -> (b <= a)%Z -> (b / c <= a / c)%Z. 
+Proof.
+ intros.
+ apply Zge_le.
+ apply Z_div_ge; Flip; assumption.
+Qed.
+
+Lemma Z_div_nonneg :
+ forall a b : Z, (0 < b)%Z -> (0 <= a)%Z -> (0 <= a / b)%Z.
+Proof.
+ intros.
+ apply Zge_le.
+ apply Z_div_ge0; Flip; assumption.
+Qed.
+
+Lemma Z_div_neg : forall a b : Z, (0 < b)%Z -> (a < 0)%Z -> (a / b < 0)%Z.
+Proof.
+ intros.
+ rewrite (Z_div_mod_eq a b) in H0.
+ elim (Z_mod_lt a b).
+ intros H1 _.
+ apply Znot_ge_lt.
+ intro.
+ apply (Zlt_not_le (b * (a / b) + a mod b) 0 H0).
+ apply Zplus_le_0_compat.
+ apply Zmult_le_0_compat. 
+ apply Zlt_le_weak; assumption.
+ Flip.
+ assumption.
+ Flip.
+ Flip.
+Qed.
+
+Hint Resolve Z_div_mod_eq_2 Z_div_le Z_div_nonneg Z_div_neg: zarith.
+
+(*###########################################################################*)
+(** Properties of Zpower                                                       *)
+(*###########################################################################*)
+
+Lemma Zpower_1 : forall a : Z, (a ^ 1)%Z = a.
+Proof.
+ intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *;
+  auto with zarith.
+Qed.
+
+Lemma Zpower_2 : forall a : Z, (a ^ 2)%Z = (a * a)%Z.
+Proof.
+ intros; unfold Zpower in |- *; unfold Zpower_pos in |- *; simpl in |- *;
+  ring.
+Qed.
+
+Hint Resolve Zpower_1 Zpower_2: zarith.
diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v
index 97cf316c..d819dc47 100644
--- a/test-suite/success/AdvancedCanonicalStructure.v
+++ b/test-suite/success/AdvancedCanonicalStructure.v
@@ -47,6 +47,24 @@ Goal forall a1 a2, eqA (plusA a1 zeroA) a2.
 change (eqB (plusB (phi a1) zeroB) (phi a2)).
 Admitted.
 
+Variable foo : A -> Type.
+
+Definition local0 := fun (a1 : A) (a2 : A) (a3 : A) =>
+                       (eq_refl : plusA a1 (plusA zeroA a2) = ia _).
+Definition local1 := 
+  fun (a1 : A) (a2 : A) (f : A -> A) => 
+    (eq_refl : plusA a1 (plusA zeroA (f a2)) = ia _).
+
+Definition local2 := 
+  fun (a1 : A) (f : A -> A) => 
+    (eq_refl : (f a1) = ia _).
+
+Goal forall a1 a2, eqA (plusA a1 zeroA) a2.
+  intros a1 a2.
+  refine  (eq_img _ _  _).
+change (eqB (plusB (phi a1) zeroB) (phi a2)).
+Admitted.
+
 End group_morphism.
 
 Open Scope type_scope.
@@ -129,13 +147,3 @@ Admitted.
 Check L : abs _ .
 
 End type_reification.
-
-
-
-
-
-
-
-
-
-
diff --git a/test-suite/success/Case11.v b/test-suite/success/Case11.v
index fd5d139c..445ffac8 100644
--- a/test-suite/success/Case11.v
+++ b/test-suite/success/Case11.v
@@ -1,5 +1,5 @@
-(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *)
-(* Problème rapporté par Solange Coupet *)
+(* L'algo d'inférence du prédicat doit gérer le K-rédex dans le type de b *)
+(* Problème rapporté par Solange Coupet *)
 
 Section A.
 
@@ -7,7 +7,7 @@ Variables (Alpha : Set) (Beta : Set).
 
 Definition nodep_prod_of_dep (c : sigS (fun a : Alpha => Beta)) :
   Alpha * Beta := match c with
-                  | existS a b => (a, b)
+                  | existS _ a b => (a, b)
                   end.
 
 End A.
diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v
index 729ab824..55e17fac 100644
--- a/test-suite/success/Case12.v
+++ b/test-suite/success/Case12.v
@@ -68,6 +68,6 @@ Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set :=
 Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m)
   {struct l} : nat :=
   match l with
-  | nil''' => 0
-  | cons''' _ m l0 => S (length''' A a m l0)
+  | nil''' _ _ => 0
+  | @cons''' _ _ _ _ m l0 => S (length''' A a m l0)
   end.
diff --git a/test-suite/success/Case16.v b/test-suite/success/Case16.v
index 77016bbf..ce9a0ecb 100644
--- a/test-suite/success/Case16.v
+++ b/test-suite/success/Case16.v
@@ -5,6 +5,6 @@
 Check
   (fun x : {b : bool | if b then True else False} =>
    match x return (let (b, _) := x in if b then True else False) with
-   | exist true y => y
-   | exist false z => z
+   | exist _ true y => y
+   | exist _ false z => z
    end).
diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v
index 66af9e0d..861d0466 100644
--- a/test-suite/success/Case17.v
+++ b/test-suite/success/Case17.v
@@ -19,10 +19,10 @@ Axiom HHH : forall A : Prop, A.
 
 Check
   (match rec l0 (HHH _) with
-   | inleft (existS (false :: l1) _) => inright _ (HHH _)
-   | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) =>
+   | inleft (existS _ (false :: l1) _) => inright _ (HHH _)
+   | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) =>
        inright _ (HHH _)
-   | inleft (existS _ _) => inright _ (HHH _)
+   | inleft (existS _ _ _) => inright _ (HHH _)
    | inright Hnp => inright _ (HHH _)
    end
    :{l'' : list bool &
@@ -39,10 +39,10 @@ Check
             {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} +
             {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) =>
    match rec l0 (HHH _) with
-   | inleft (existS (false :: l1) _) => inright _ (HHH _)
-   | inleft (existS (true :: l1) (exist t1 (conj Hp Hl))) =>
+   | inleft (existS _ (false :: l1) _) => inright _ (HHH _)
+   | inleft (existS _ (true :: l1) (exist _ t1 (conj Hp Hl))) =>
        inright _ (HHH _)
-   | inleft (existS _ _) => inright _ (HHH _)
+   | inleft (existS _ _ _) => inright _ (HHH _)
    | inright Hnp => inright _ (HHH _)
    end
    :{l'' : list bool &
diff --git a/test-suite/success/Case20.v b/test-suite/success/Case20.v
new file mode 100644
index 00000000..67eebf72
--- /dev/null
+++ b/test-suite/success/Case20.v
@@ -0,0 +1,35 @@
+(* Example taken from RelationAlgebra *)
+(* Was failing from r16205 up to now *)
+
+Require Import BinNums.
+
+Section A.
+
+Context (A:Type) {X: A} (tst:A->Type) (top:forall X, X).
+
+Inductive v: (positive -> A) -> Type :=
+| v_L: forall f', v f'
+| v_N: forall f', 
+  v (fun n => f' (xO n)) -> 
+  (positive -> tst (f' xH)) -> 
+  v (fun n => f' (xI n)) -> v f'.
+
+Fixpoint v_add f' (t: v f') n: (positive -> tst (f' n)) -> v f' :=
+  match t in (v o) return ((positive -> (tst (o n))) -> v o) with
+    | v_L f' => 
+        match n return ((positive ->  (tst (f' n))) -> v f') with
+        | xH => fun x => v_N _ (v_L _) x (v_L _)
+        | xO n => fun x => v_N _ 
+          (v_add (fun n => f' (xO n)) (v_L _) n x) (fun _ => top _) (v_L _)
+        | xI n => fun x => v_N _ 
+          (v_L _) (fun _ => top _) (v_add (fun n => f' (xI n)) (v_L _) n x)
+        end
+    | v_N f' l y r => 
+        match n with
+        | xH => fun x => v_N _ l x r
+        | xO n => fun x => v_N _ (v_add (fun n => f' (xO n)) l n x) y r
+        | xI n => fun x => v_N _ l y (v_add (fun n => f' (xI n)) r n x)
+        end
+    end.
+
+End A.
diff --git a/test-suite/success/Case21.v b/test-suite/success/Case21.v
new file mode 100644
index 00000000..db91eb40
--- /dev/null
+++ b/test-suite/success/Case21.v
@@ -0,0 +1,15 @@
+(* Check insertion of impossible case when there is no branch at all *)
+
+Inductive eq_true : bool -> Prop :=  is_eq_true : eq_true true.
+
+Check fun H:eq_true false => match H with end : False.
+
+Inductive I : bool -> bool -> Prop := C : I true true.
+
+Check fun x (H:I x false) => match H with end : False.
+
+Check fun x (H:I false x) => match H with end : False.
+
+Inductive I' : bool -> Type := C1  : I' true | C2 : I' true.
+
+Check fun x : I' false => match x with end : False.
diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v
new file mode 100644
index 00000000..4eb2dbe9
--- /dev/null
+++ b/test-suite/success/Case22.v
@@ -0,0 +1,7 @@
+(* Check typing in the presence of let-in in inductive arity *)
+
+Inductive I : let a := 1 in a=a -> let b := 2 in Type := C : I (eq_refl).
+Lemma a : forall x:I eq_refl, match x in I a b c return b = b with C => eq_refl end = eq_refl.
+intro.
+match goal with |- ?c => let x := eval cbv in c in change x end.
+Abort.
diff --git a/test-suite/success/Case7.v b/test-suite/success/Case7.v
index 6e4b2003..f95598aa 100644
--- a/test-suite/success/Case7.v
+++ b/test-suite/success/Case7.v
@@ -12,6 +12,6 @@ Parameter
 Type
   (fun (A : Set) (l : List A) =>
    match l return (Empty A l \/ ~ Empty A l) with
-   | Nil => or_introl (~ Empty A (Nil A)) (intro_Empty A)
-   | Cons a y as b => or_intror (Empty A b) (inv_Empty A a y)
+   | Nil _ => or_introl (~ Empty A (Nil A)) (intro_Empty A)
+   | Cons _ a y as b => or_intror (Empty A b) (inv_Empty A a y)
    end).
diff --git a/test-suite/success/Case9.v b/test-suite/success/Case9.v
index a8534a0b..e34e5b9b 100644
--- a/test-suite/success/Case9.v
+++ b/test-suite/success/Case9.v
@@ -36,10 +36,10 @@ Parameter
 Fixpoint eqlongdec (x y : List nat) {struct x} :
  eqlong x y \/ ~ eqlong x y :=
   match x, y return (eqlong x y \/ ~ eqlong x y) with
-  | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
-  | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
-  | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x)
-  | Cons a x as L1, Cons b y as L2 =>
+  | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
+  | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
+  | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x)
+  | Cons _ a x as L1, Cons _ b y as L2 =>
       match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
       | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
       | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
@@ -49,10 +49,10 @@ Fixpoint eqlongdec (x y : List nat) {struct x} :
 
 Type
   match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with
-  | Nil, Nil => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
-  | Nil, Cons a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
-  | Cons a x as L, Nil => or_intror (eqlong L (Nil nat)) (inv_l a x)
-  | Cons a x as L1, Cons b y as L2 =>
+  | Nil _, Nil _ => or_introl (~ eqlong (Nil nat) (Nil nat)) eql_nil
+  | Nil _, Cons _ a x as L => or_intror (eqlong (Nil nat) L) (inv_r a x)
+  | Cons _ a x as L, Nil _ => or_intror (eqlong L (Nil nat)) (inv_l a x)
+  | Cons _ a x as L1, Cons _ b y as L2 =>
       match eqlongdec x y return (eqlong L1 L2 \/ ~ eqlong L1 L2) with
       | or_introl h => or_introl (~ eqlong L1 L2) (eql_cons a b x y h)
       | or_intror h => or_intror (eqlong L1 L2) (nff a b x y h)
diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v
new file mode 100644
index 00000000..3679eead
--- /dev/null
+++ b/test-suite/success/CaseInClause.v
@@ -0,0 +1,22 @@
+(* in clause pattern *)
+Require Vector.
+Check (fun n (x: Vector.t True (S n)) =>
+  match x in Vector.t _ (S m) return True with
+    |Vector.cons _ h _ _ => h
+  end).
+
+(* Notation *)
+Import Vector.VectorNotations.
+Notation "A \dots n" := (Vector.t A n) (at level 200).
+Check (fun m (x: Vector.t nat m) =>
+  match x in _ \dots k return Vector.t nat (S k) with
+    | Vector.nil _ => 0 :: []
+    | Vector.cons _ h _ t => h :: h :: t
+  end).
+
+(* N should be a variable and not the inductiveRef *)
+Require Import NArith.
+Theorem foo : forall (n m : nat) (pf : n = m),
+                match pf in _ = N with 
+                  | eq_refl => unit
+                end.
diff --git a/test-suite/success/Cases-bug1834.v b/test-suite/success/Cases-bug1834.v
index 543ca0c9..cf102486 100644
--- a/test-suite/success/Cases-bug1834.v
+++ b/test-suite/success/Cases-bug1834.v
@@ -7,7 +7,7 @@ Definition T := sig P.
 Parameter Q : T -> Prop.
 Definition U := sig Q.
 Parameter a : U.
-Check (match a with exist (exist tt e2) e3 => e3=e3 end).
+Check (match a with exist _ (exist _ tt e2) e3 => e3=e3 end).
 
 (* There is still a form submitted by Pierre Corbineau (#1834) which fails *)
 
diff --git a/test-suite/success/Cases-bug3758.v b/test-suite/success/Cases-bug3758.v
new file mode 100644
index 00000000..e48f4523
--- /dev/null
+++ b/test-suite/success/Cases-bug3758.v
@@ -0,0 +1,17 @@
+(* There used to be an evar leak in the to_nat example *)
+
+Require Import Coq.Lists.List.
+Import ListNotations.
+
+Fixpoint Idx {A:Type} (l:list A) : Type :=
+  match l with
+  | [] => False
+  | _::l => True + Idx l
+  end.
+
+Fixpoint to_nat {A:Type} (l:list A) (i:Idx l) : nat :=
+  match l,i with
+  |  [] , i => match i with end
+  | _::_, inl _ => 0
+  | _::l, inr i => S (to_nat l i)
+  end.
diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v
index c9a3c08e..e4266350 100644
--- a/test-suite/success/Cases.v
+++ b/test-suite/success/Cases.v
@@ -2,21 +2,21 @@
 (* Pattern-matching when non inductive terms occur                          *)
 
 (* Dependent form of annotation *)
-Type match 0 as n, eq return nat with
+Type match 0 as n, @eq return nat with
      | O, x => 0
      | S x, y => x
      end.
-Type match 0, eq, 0 return nat with
+Type match 0, 0, @eq return nat with
      | O, x, y => 0
      | S x, y, z => x
      end.
-Type match 0, eq, 0 return _ with
+Type match 0, @eq, 0 return _ with
      | O, x, y => 0
      | S x, y, z => x
      end.
 
 (* Non dependent form of annotation *)
-Type match 0, eq return nat with
+Type match 0, @eq return nat with
      | O, x => 0
      | S x, y => x
      end.
@@ -309,43 +309,43 @@ Type
 Type
   (fun l : List nat =>
    match l return (List nat) with
-   | Nil => Nil nat
-   | Cons a l => l
+   | Nil _ => Nil nat
+   | Cons _ a l => l
    end).
 
 Type (fun l : List nat => match l with
-                          | Nil => Nil nat
-                          | Cons a l => l
+                          | Nil _ => Nil nat
+                          | Cons _ a l => l
                           end).
 
 Type match Nil nat return nat with
-     | Nil => 0
-     | Cons a l => S a
+     | Nil _ => 0
+     | Cons _ a l => S a
      end.
 Type match Nil nat with
-     | Nil => 0
-     | Cons a l => S a
+     | Nil _ => 0
+     | Cons _ a l => S a
      end.
 
 Type match Nil nat return (List nat) with
-     | Cons a l => l
+     | Cons _ a l => l
      | x => x
      end.
 
 Type match Nil nat with
-     | Cons a l => l
+     | Cons _ a l => l
      | x => x
      end.
 
 Type
   match Nil nat return (List nat) with
-  | Nil => Nil nat
-  | Cons a l => l
+  | Nil _ => Nil nat
+  | Cons _ a l => l
   end.
 
 Type match Nil nat with
-     | Nil => Nil nat
-     | Cons a l => l
+     | Nil _ => Nil nat
+     | Cons _ a l => l
      end.
 
 
@@ -353,8 +353,8 @@ Type
   match 0 return nat with
   | O => 0
   | S x => match Nil nat return nat with
-           | Nil => x
-           | Cons a l => x + a
+           | Nil _ => x
+           | Cons _ a l => x + a
            end
   end.
 
@@ -362,8 +362,8 @@ Type
   match 0 with
   | O => 0
   | S x => match Nil nat with
-           | Nil => x
-           | Cons a l => x + a
+           | Nil _ => x
+           | Cons _ a l => x + a
            end
   end.
 
@@ -372,8 +372,8 @@ Type
    match y with
    | O => 0
    | S x => match Nil nat with
-            | Nil => x
-            | Cons a l => x + a
+            | Nil _ => x
+            | Cons _ a l => x + a
             end
    end).
 
@@ -381,8 +381,8 @@ Type
 Type
   match 0, Nil nat return nat with
   | O, x => 0
-  | S x, Nil => x
-  | S x, Cons a l => x + a
+  | S x, Nil _ => x
+  | S x, Cons _ a l => x + a
   end.
 
 
@@ -597,71 +597,60 @@ Type
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l return nat with
-   | Niln => 0
-   | Consn n a Niln => 0
-   | Consn n a (Consn m b l) => n + m
+   | Niln _ => 0
+   | Consn _ n a (Niln _) => 0
+   | Consn _ n a (Consn _ m b l) => n + m
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l with
-   | Niln => 0
-   | Consn n a Niln => 0
-   | Consn n a (Consn m b l) => n + m
+   | Niln _ => 0
+   | Consn _ n a (Niln _) => 0
+   | Consn _ n a (Consn _ m b l) => n + m
    end).
 
-(* This example was deactivated in Cristina's code
-
 Type
   (fun (A:Set) (n:nat) (l:Listn A n) =>
     match l return Listn A O with
-      | Niln  as b => b
-      | Consn  n a (Niln  as b) => (Niln A)
-      | Consn  n a (Consn m b l) => (Niln A)
+      | Niln _ as b => b
+      | Consn _  n a (Niln _ as b) => (Niln A)
+      | Consn _ n a (Consn _ m b l) => (Niln A)
     end).
-*)
-
-(* This one is (still) failing: too weak unification
 
+(*
 Type
   (fun (A:Set) (n:nat) (l:Listn A n) =>
     match l with
-      | Niln  as b => b
-      | Consn  n a (Niln  as b) => (Niln A)
-      | Consn  n a (Consn m b l) => (Niln A)
+      | Niln _ as b => b
+      | Consn _ n a (Niln _ as b) => (Niln A)
+      | Consn _ n a (Consn _ m b l) => (Niln A)
     end).
 *)
 
-(* This one is failing: alias L not chosen of the right type
-
 Type
   (fun (A:Set) (n:nat) (l:Listn A n) =>
     match l return Listn A (S 0) with
-      | Niln  as b => Consn A O O b
-      | Consn n a Niln as L => L
-      | Consn n a _ => Consn A O O (Niln A)
+      | Niln _ as b => Consn A O O b
+      | Consn _ n a (Niln _) as L => L
+      | Consn _ n a _ => Consn A O O (Niln A)
     end).
-*)
-
-(******** This example (still) failed
 
 Type
   (fun (A:Set) (n:nat) (l:Listn A n) =>
     match l return Listn A (S 0) with
-      | Niln  as b => Consn A O O b
-      | Consn n a Niln as L => L
-      | Consn n a _ => Consn A O O (Niln A)
+      | Niln _ as b => Consn A O O b
+      | Consn _ n a (Niln _) as L => L
+      | Consn _ n a _ => Consn A O O (Niln A)
     end).
 
-**********)
-
 (* To test treatment of as-patterns in depth *)
 Type
   (fun (A : Set) (l : List A) =>
    match l with
-   | Nil as b => Nil A
-   | Cons a Nil as L => L
-   | Cons a (Cons b m) as L => L
+   | Nil _ as b => Nil A
+   | Cons _ a (Nil _) as L => L
+   | Cons _ a (Cons _ b m) as L => L
    end).
 
 
@@ -704,40 +693,40 @@ Type
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l with
-   | Niln as b => l
+   | Niln _ as b => l
    | _ => l
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l return (Listn A n) with
-   | Niln => l
-   | Consn n a Niln => l
-   | Consn n a (Consn m b c) => l
+   | Niln _ => l
+   | Consn _ n a (Niln _) => l
+   | Consn _ n a (Consn _ m b c) => l
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l with
-   | Niln => l
-   | Consn n a Niln => l
-   | Consn n a (Consn m b c) => l
+   | Niln _ => l
+   | Consn _ n a (Niln _) => l
+   | Consn _ n a (Consn _ m b c) => l
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l return (Listn A n) with
-   | Niln as b => l
-   | Consn n a (Niln as b) => l
-   | Consn n a (Consn m b _) => l
+   | Niln _ as b => l
+   | Consn _ n a (Niln _ as b) => l
+   | Consn _ n a (Consn _ m b _) => l
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l with
-   | Niln as b => l
-   | Consn n a (Niln as b) => l
-   | Consn n a (Consn m b _) => l
+   | Niln _ as b => l
+   | Consn _ n a (Niln _ as b) => l
+   | Consn _ n a (Consn _ m b _) => l
    end).
 
 
@@ -770,40 +759,40 @@ Type match LeO 0 with
 Type
   (fun (n : nat) (l : Listn nat n) =>
    match l return nat with
-   | Niln => 0
-   | Consn n a l => 0
+   | Niln _ => 0
+   | Consn _ n a l => 0
    end).
 
 
 Type
   (fun (n : nat) (l : Listn nat n) =>
    match l with
-   | Niln => 0
-   | Consn n a l => 0
+   | Niln _ => 0
+   | Consn _ n a l => 0
    end).
 
 
 Type match Niln nat with
-     | Niln => 0
-     | Consn n a l => 0
+     | Niln _ => 0
+     | Consn _ n a l => 0
      end.
 
 Type match LE_n 0 return nat with
-     | LE_n => 0
-     | LE_S m h => 0
+     | LE_n _ => 0
+     | LE_S _ m h => 0
      end.
 
 
 Type match LE_n 0 with
-     | LE_n => 0
-     | LE_S m h => 0
+     | LE_n _ => 0
+     | LE_S _ m h => 0
      end.
 
 
 
 Type match LE_n 0 with
-     | LE_n => 0
-     | LE_S m h => 0
+     | LE_n _ => 0
+     | LE_S _ m h => 0
      end.
 
 
@@ -825,16 +814,17 @@ Type
 
 Type
   match Niln nat return nat with
-  | Niln => 0
-  | Consn n a Niln => n
-  | Consn n a (Consn m b l) => n + m
+  | Niln _ => 0
+  | Consn _ n a (Niln _
+) => n
+  | Consn _ n a (Consn _ m b l) => n + m
   end.
 
 Type
   match Niln nat with
-  | Niln => 0
-  | Consn n a Niln => n
-  | Consn n a (Consn m b l) => n + m
+  | Niln _ => 0
+  | Consn _ n a (Niln _) => n
+  | Consn _ n a (Consn _ m b l) => n + m
   end.
 
 
@@ -1027,17 +1017,17 @@ Type
 
 Type
   match LE_n 0 return nat with
-  | LE_n => 0
-  | LE_S m LE_n => 0 + m
-  | LE_S m (LE_S y h) => 0 + m
+  | LE_n _ => 0
+  | LE_S _ m (LE_n _) => 0 + m
+  | LE_S _ m (LE_S _ y h) => 0 + m
   end.
 
 
 Type
   match LE_n 0 with
-  | LE_n => 0
-  | LE_S m LE_n => 0 + m
-  | LE_S m (LE_S y h) => 0 + m
+  | LE_n _ => 0
+  | LE_S _ m (LE_n _) => 0 + m
+  | LE_S _ m (LE_S _ y h) => 0 + m
   end.
 
 
@@ -1077,25 +1067,25 @@ Type
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l return (nat -> nat) with
-   | Niln => fun _ : nat => 0
-   | Consn n a Niln => fun _ : nat => n
-   | Consn n a (Consn m b l) => fun _ : nat => n + m
+   | Niln _ => fun _ : nat => 0
+   | Consn _ n a (Niln _) => fun _ : nat => n
+   | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m
    end).
 
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l with
-   | Niln => fun _ : nat => 0
-   | Consn n a Niln => fun _ : nat => n
-   | Consn n a (Consn m b l) => fun _ : nat => n + m
+   | Niln _ => fun _ : nat => 0
+   | Consn _ n a (Niln _) => fun _ : nat => n
+   | Consn _ n a (Consn _ m b l) => fun _ : nat => n + m
    end).
 
 (* Also tests for multiple _ patterns *)
 Type
   (fun (A : Set) (n : nat) (l : Listn A n) =>
    match l in (Listn _ n) return (Listn A n) with
-   | Niln as b => b
-   | Consn _ _ _ as b => b
+   | Niln _ as b => b
+   | Consn _ _ _ _ as b => b
    end).
 
 (** This one was said to raised once an "Horrible error message!" *)
@@ -1103,8 +1093,8 @@ Type
 Type
   (fun (A:Set) (n:nat) (l:Listn A n) =>
    match l with
-   | Niln as b => b
-   | Consn _ _ _  as b =>  b
+   | Niln _ as b => b
+   | Consn _ _ _ _  as b =>  b
    end).
 
 Type
@@ -1123,26 +1113,26 @@ Type
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h return (nat -> nat) with
-   | LE_n => fun _ : nat => n
-   | LE_S m LE_n => fun _ : nat => n + m
-   | LE_S m (LE_S y h) => fun _ : nat => m + y
+   | LE_n _ => fun _ : nat => n
+   | LE_S _ m (LE_n _) => fun _ : nat => n + m
+   | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y
    end).
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h with
-   | LE_n => fun _ : nat => n
-   | LE_S m LE_n => fun _ : nat => n + m
-   | LE_S m (LE_S y h) => fun _ : nat => m + y
+   | LE_n _ => fun _ : nat => n
+   | LE_S _ m (LE_n _) => fun _ : nat => n + m
+   | LE_S _ m (LE_S _ y h) => fun _ : nat => m + y
    end).
 
 
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h return nat with
-   | LE_n => n
-   | LE_S m LE_n => n + m
-   | LE_S m (LE_S y LE_n) => n + m + y
-   | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y')
+   | LE_n _ => n
+   | LE_S _ m (LE_n _) => n + m
+   | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y
+   | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y')
    end).
 
 
@@ -1150,28 +1140,28 @@ Type
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h with
-   | LE_n => n
-   | LE_S m LE_n => n + m
-   | LE_S m (LE_S y LE_n) => n + m + y
-   | LE_S m (LE_S y (LE_S y' h)) => n + m + (y + y')
+   | LE_n _ => n
+   | LE_S _ m (LE_n _) => n + m
+   | LE_S _ m (LE_S _ y (LE_n _)) => n + m + y
+   | LE_S _ m (LE_S _ y (LE_S _ y' h)) => n + m + (y + y')
    end).
 
 
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h return nat with
-   | LE_n => n
-   | LE_S m LE_n => n + m
-   | LE_S m (LE_S y h) => n + m + y
+   | LE_n _ => n
+   | LE_S _ m (LE_n _) => n + m
+   | LE_S _ m (LE_S _ y h) => n + m + y
    end).
 
 
 Type
   (fun (n m : nat) (h : LE n m) =>
    match h with
-   | LE_n => n
-   | LE_S m LE_n => n + m
-   | LE_S m (LE_S y h) => n + m + y
+   | LE_n _ => n
+   | LE_S _ m (LE_n _) => n + m
+   | LE_S _ m (LE_S _ y h) => n + m + y
    end).
 
 Type
@@ -1231,14 +1221,14 @@ Parameter B : Set.
 Type
   (fun (P : nat -> B -> Prop) (x : SStream B P) =>
    match x return B with
-   | scons _ a _ _ => a
+   | scons _ _ a _ _ => a
    end).
 
 
 Type
   (fun (P : nat -> B -> Prop) (x : SStream B P) =>
    match x with
-   | scons _ a _ _ => a
+   | scons _ _ a _ _ => a
    end).
 
 Type match (0, 0) return (nat * nat) with
@@ -1267,14 +1257,14 @@ Parameter concat : forall A : Set, List A -> List A -> List A.
 
 Type
   match Nil nat, Nil nat return (List nat) with
-  | Nil as b, x => concat nat b x
-  | Cons _ _ as d, Nil as c => concat nat d c
+  | Nil _ as b, x => concat nat b x
+  | Cons _ _ _ as d, Nil _ as c => concat nat d c
   | _, _ => Nil nat
   end.
 Type
   match Nil nat, Nil nat with
-  | Nil as b, x => concat nat b x
-  | Cons _ _ as d, Nil as c => concat nat d c
+  | Nil _ as b, x => concat nat b x
+  | Cons _ _ _ as d, Nil _ as c => concat nat d c
   | _, _ => Nil nat
   end.
 
@@ -1415,7 +1405,7 @@ Parameter p : eq_prf.
 
 Type
   match p with
-  | ex_intro c eqc =>
+  | ex_intro _ c eqc =>
       match eq_nat_dec c n with
       | right _ => refl_equal n
       | left y => (* c=n*)  refl_equal n
@@ -1438,7 +1428,7 @@ Type
   (fun N : nat =>
    match N_cla N with
    | inright H => match exist_U2 N H with
-                  | exist a b => a
+                  | exist _ a b => a
                   end
    | _ => 0
    end).
@@ -1636,8 +1626,8 @@ Parameter
 
 Type
   match Nil nat as l return (Empty nat l \/ ~ Empty nat l) with
-  | Nil => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat)
-  | Cons a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y)
+  | Nil _ => or_introl (~ Empty nat (Nil nat)) (intro_Empty nat)
+  | Cons _ a y => or_intror (Empty nat (Cons nat a y)) (inv_Empty nat a y)
   end.
 
 
@@ -1687,20 +1677,20 @@ Parameter
 
 Type
   match Nil nat as x, Nil nat as y return (eqlong x y \/ ~ eqlong x y) with
-  | Nil, Nil => V1
-  | Nil, Cons a x => V2 a x
-  | Cons a x, Nil => V3 a x
-  | Cons a x, Cons b y => V4 a x b y
+  | Nil _, Nil _ => V1
+  | Nil _, Cons _ a x => V2 a x
+  | Cons _ a x, Nil _ => V3 a x
+  | Cons _ a x, Cons _ b y => V4 a x b y
   end.
 
 
 Type
   (fun x y : List nat =>
    match x, y return (eqlong x y \/ ~ eqlong x y) with
-   | Nil, Nil => V1
-   | Nil, Cons a x => V2 a x
-   | Cons a x, Nil => V3 a x
-   | Cons a x, Cons b y => V4 a x b y
+   | Nil _, Nil _ => V1
+   | Nil _, Cons _ a x => V2 a x
+   | Cons _ a x, Nil _ => V3 a x
+   | Cons _ a x, Cons _ b y => V4 a x b y
    end).
 
 
diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v
index bfead53c..8d9edbd6 100644
--- a/test-suite/success/CasesDep.v
+++ b/test-suite/success/CasesDep.v
@@ -4,8 +4,8 @@ Check
   (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q)
      x =>
    match x return Q with
-   | exist O H => A H
-   | exist (S n) H => B n H
+   | exist _ O H => A H
+   | exist _ (S n) H => B n H
    end).
 
 (* Check dependencies in anonymous arguments (from FTA/listn.v) *)
@@ -21,30 +21,30 @@ Variable c : C.
 
 Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C :=
   match bs with
-  | niln => c
-  | consn b _ tl => g b (foldrn _ tl)
+  | niln _ => c
+  | consn _ b _ tl => g b (foldrn _ tl)
   end.
 End Folding.
 
 (** Testing post-processing of nested dependencies *)
 
 Check fun x:{x|x=0}*nat+nat => match x with
-      | inl ((exist 0 eq_refl),0) => None
+      | inl ((exist _ 0 eq_refl),0) => None
       | _ => Some 0
       end.
 
 Check fun x:{_:{x|x=0}|True}+nat => match x with
-      | inl (exist (exist 0 eq_refl) I) => None
+      | inl (exist _ (exist _ 0 eq_refl) I) => None
       | _ => Some 0
       end.
 
 Check fun x:{_:{x|x=0}|True}+nat => match x with
-      | inl (exist (exist 0 eq_refl) I) => None
+      | inl (exist _ (exist _ 0 eq_refl) I) => None
       | _ => Some 0
       end.
 
 Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with
-      | inl (exist (exist 0 eq_refl) I) => None
+      | inl (exist _ (exist _ 0 eq_refl) I) => None
       | _ => Some 0
       end.
 
@@ -52,11 +52,11 @@ Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with
   (* due to a bug in dependencies postprocessing (revealed by CoLoR) *)
 
 Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with
-      | exist2 (x,y) eq_refl I => None
+      | exist2 _ _ (x,y) eq_refl I => None
       end.
 
 Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with
-      | inl (exist (exist2 (x,y) eq_refl I) I) => None
+      | inl (exist _ (exist2 _ _ (x,y) eq_refl I) I) => None
       | _ => Some 0
       end.
 
@@ -521,8 +521,8 @@ end.
 
 Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) :=
   match v with
-    | niln => w
-    | consn a n' v' => consn _ a _ (app v' w)
+    | niln _ => w
+    | consn _ a n' v' => consn _ a _ (app v' w)
   end.
 
 (* Testing regression of bug 2106 *)
@@ -547,7 +547,7 @@ n'.
 
 Definition test (s:step E E) :=
   match s with
-    | Step nil _ (cons E nil) _ Plus l l' => true
+    | @Step nil _ (cons E nil) _ Plus l l' => true
     | _ => false
   end.
 
diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v
index 49c54916..87c38cfa 100644
--- a/test-suite/success/Check.v
+++ b/test-suite/success/Check.v
@@ -1,11 +1,11 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
-(* Compiling the theories allows to test parsing and typing but not printing *)
+(* Compiling the theories allows testing parsing and typing but not printing *)
 (* This file tests that pretty-printing does not fail                        *)
 (* Test of exact output is not specified                                     *)
 
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
index cdf9d6da..8db08b6d 100644
--- a/test-suite/success/Field.v
+++ b/test-suite/success/Field.v
@@ -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/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v
index 3a4f8899..5fc703cf 100644
--- a/test-suite/success/Fixpoint.v
+++ b/test-suite/success/Fixpoint.v
@@ -42,8 +42,8 @@ Variables (B C : Set) (g : B -> C -> C) (c : C).
 
 Fixpoint foldrn n bs :=
   match bs with
-  | Vnil => c
-  | Vcons b _ tl => g b (foldrn _ tl)
+  | Vnil _ => c
+  | Vcons _ b _ tl => g b (foldrn _ tl)
   end.
 
 End folding.
diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v
index ccce3bbe..3bf97c13 100644
--- a/test-suite/success/Funind.v
+++ b/test-suite/success/Funind.v
@@ -23,6 +23,7 @@ Function ftest (n m : nat) : nat :=
          end
   | S p => 0
   end.
+(* MS: FIXME: apparently can't define R_ftest_complete. Rest of the file goes through. *)
 
 Lemma test1 : forall n m : nat, ftest n m <= 2.
 intros n m.
@@ -150,7 +151,7 @@ Function nat_equal_bool (n m : nat) {struct n} : bool :=
 
 
 Require Export Div2.
-
+Require Import Nat.
 Functional Scheme div2_ind := Induction for div2 Sort Prop.
 Lemma div2_inf : forall n : nat, div2 n <= n.
 intros n.
@@ -233,11 +234,11 @@ Qed.
 Inductive istrue : bool -> Prop :=
     istrue0 : istrue true.
 
-Functional Scheme plus_ind := Induction for plus Sort Prop.
+Functional Scheme add_ind := Induction for add Sort Prop.
 
 Lemma inf_x_plusxy' : forall x y : nat, x <= x + y.
 intros n m.
- functional induction plus n m; intros.
+ functional induction add n m; intros.
 auto with arith.
 auto with arith.
 Qed.
diff --git a/test-suite/success/ImplicitArguments.v b/test-suite/success/ImplicitArguments.v
index 84ec298d..f702aa62 100644
--- a/test-suite/success/ImplicitArguments.v
+++ b/test-suite/success/ImplicitArguments.v
@@ -9,11 +9,15 @@ Require Import Coq.Program.Program.
 Program Definition head {A : Type} {n : nat} (v : vector A (S n)) : vector A n :=
   match v with
     | vnil => !
-    | vcons a n' v' => v'
+    | vcons a v' => v'
   end.
 
 Fixpoint app {A : Type} {n m : nat} (v : vector A n) (w : vector A m) : vector A (n + m) :=
   match v in vector _ n return vector A (n + m) with
     | vnil => w
-    | vcons a n' v' => vcons a (app v' w)
+    | vcons a v' => vcons a (app v' w)
   end.
+
+(* Test sharing information between different hypotheses *)
+
+Parameters (a:_) (b:a=0).
diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v
index da5dd5e4..3d425754 100644
--- a/test-suite/success/Inductive.v
+++ b/test-suite/success/Inductive.v
@@ -17,7 +17,7 @@ Check
  fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
    let B := A in
      fun (a : A) (e : eq1 A a) =>
-       match e in (eq1 A0 B0 a0) return (P A0 a0) with
+       match e in (@eq1 A0 B0 a0) return (P A0 a0) with
        | refl1 => f
        end.
 
@@ -37,8 +37,8 @@ Check
    fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type)
      (f : forall z : C, P z (I C D x y z)) (y0 : C)
      (a : A C D x y y0) =>
-   match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with
-   | I x0 => f x0
+   match a as a0 in (A _ _ _ _ y1) return (P y1 a0) with
+   | I _ _ _ _ x0 => f x0
    end).
 
 Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set :=  {p : C; q : E}.
@@ -51,7 +51,7 @@ Check
      (f : forall p0 q0 : C, P (Build_B C D x y p0 q0))
      (b : B C D x y) =>
    match b as b0 return (P b0) with
-   | Build_B x0 x1 => f x0 x1
+   | Build_B _ _ _ _ x0 x1 => f x0 x1
    end).
 
 (* Check inductive types with local definitions (constructors) *)
@@ -107,3 +107,17 @@ Set Implicit Arguments.
 Inductive I A : A->Prop := C a : (forall A, A) -> I a.
 
  *)
+
+(* Test recursively non-uniform parameters (was formerly in params_ind.v) *)
+
+Inductive list (A : Set) : Set :=
+  | nil : list A
+  | cons : A -> list (A -> A) -> list A.
+
+(* Check inference of evars in arity using information from constructors *)
+
+Inductive foo1 : forall p, Prop := cc1 : foo1 0.
+
+(* Check cross inference of evars from constructors *)
+
+Inductive foo2 : forall p, Prop := cc2 : forall q, foo2 q | cc3 : foo2 0.
diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v
index c5cd7380..6a488244 100644
--- a/test-suite/success/Injection.v
+++ b/test-suite/success/Injection.v
@@ -39,7 +39,7 @@ Qed.
 (* Test injection as *)
 
 Lemma l5 : forall x y z t : nat, (x,y) = (z,t) -> x=z.
-intros; injection H as Hyt Hxz.
+intros; injection H as Hxz Hyt.
 exact Hxz.
 Qed.
 
@@ -66,6 +66,56 @@ einjection (H O).
 instantiate (1:=O).
 Abort.
 
+(* Test the injection intropattern *)
+
+Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b.
+intros * [= H1 H2].
+exact H1.
+Qed.
+
+(* Test injection using K, knowing that an equality is decidable *)
+(* Basic case, using sigT *)
+
+Scheme Equality for nat.
+Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n,
+  existT P n H1 = existT P n H2 -> H1 = H2.
+intros.
+injection H.
+intro H0. exact H0.
+Abort.
+
+(* Test injection using K, knowing that an equality is decidable *)
+(* Basic case, using sigT, with "as" clause *)
+
+Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n,
+  existT P n H1 = existT P n H2 -> H1 = H2.
+intros.
+injection H as H.
+exact H.
+Abort.
+
+(* Test injection using K, knowing that an equality is decidable *)
+(* Dependent case not directly exposing sigT *)
+
+Inductive my_sig (A : Type) (P : A -> Type) : Type :=
+    my_exist : forall x : A, P x -> my_sig A P.
+
+Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n,
+  my_exist _ _ n H1 = my_exist _ _ n H2 -> H1 = H2.
+intros.
+injection H as H.
+exact H.
+Abort.
+
+(* Test injection using K, knowing that an equality is decidable *)
+(* Dependent case not directly exposing sigT deeply nested *)
+
+Goal forall n:nat, forall P:nat -> Type, forall H1 H2:P n,
+  (my_exist _ _ n H1,0) = (my_exist _ _ n H2,0) -> H1 = H2.
+intros * [= H].
+exact H.
+Abort.
+
 (* Injection does not projects at positions in Prop... allow it?
 
 Inductive t (A:Prop) : Set := c : A -> t A.
diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v
index b068f729..850f0943 100644
--- a/test-suite/success/Inversion.v
+++ b/test-suite/success/Inversion.v
@@ -136,3 +136,56 @@ Goal True -> True.
 intro.
 Fail inversion H using False.
 Fail inversion foo using True_ind.
+
+(* Was failing at some time between 7 and 10 September 2014 *)
+(* even though, it is not clear that the resulting context is interesting *)
+
+Parameter P:nat*nat->Prop.
+Inductive IND : nat * nat -> { x : nat * nat | P x } * nat -> Prop :=
+CONSTR a b (H:P (a,b)) c : IND (a,b) (exist _ (a,b) H, c).
+
+Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z.
+intros * Hyp.
+inversion Hyp.
+  (* By the way, why is "H" removed even in non-clear mode ? *)
+reflexivity.
+Qed.
+
+Goal forall x y z t u (H':P (z,t)), IND (x,y) (exist _ (z,t) H', u) -> x = z.
+intros * Hyp.
+inversion Hyp as (a,b,H,c,(H1_1,H1_2),(H2_1,H2_2,H2_3)).
+reflexivity.
+Qed.
+
+(* Up to September 2014, Mapp below was called MApp0 because of a bug
+   in intro_replacing (short version of bug 2164.v)
+   (example taken from CoLoR) *)
+
+Parameter Term : Type.
+Parameter isApp : Term -> Prop.
+Parameter appBodyL : forall M, isApp M -> Prop.
+Parameter lower : forall M Mapp, appBodyL M Mapp -> Term.
+
+Inductive BetaStep : Term -> Term -> Prop :=
+  Beta M Mapp Mabs : BetaStep M (lower M Mapp Mabs).
+
+Goal forall M N, BetaStep M N -> True.
+intros M N H.
+inversion H as (P,Mapp,Mabs,H0,H1).
+clear Mapp Mabs H0 H1.
+exact Logic.I.
+Qed.
+
+(* Up to September 2014, H0 below was renamed called H1 because of a collision
+   with the automaticallly generated names for equations.
+   (example taken from CoLoR) *)
+
+Inductive term := Var | Fun : term -> term -> term.
+Inductive lt : term -> term -> Prop :=
+  mpo f g ss ts : lt Var (Fun f ts) -> lt (Fun f ss) (Fun g ts).
+
+Goal forall f g ss ts, lt (Fun f ss) (Fun g ts) -> lt Var (Fun f ts).
+intros.
+inversion H as (f',g',ss',ts',H0).
+exact H0.
+Qed.
diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v
deleted file mode 100644
index 9b2a2c6a..00000000
--- a/test-suite/success/LegacyField.v
+++ /dev/null
@@ -1,76 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(**** Tests of Field with real numbers ****)
-
-Require Import Reals LegacyRfield.
-
-(* Example 1 *)
-Goal
-forall eps : R,
-(eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)))%R = (eps * (1 / 2))%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 2 *)
-Goal
-forall (f g : R -> R) (x0 x1 : R),
-((f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)))%R =
-((f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)))%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 3 *)
-Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 4 *)
-Goal
-forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 5 *)
-Goal forall a : R, 1%R = (1 * (1 / a) * a)%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 6 *)
-Goal forall a b : R, b = (b * / a * a)%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 7 *)
-Goal forall a b : R, b = (b * (1 / a) * a)%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
-
-(* Example 8 *)
-Goal
-forall x y : R,
-(x * (1 / x + x / (x + y)))%R =
-(- (1 / y) * y * (- (x * (x / (x + y))) - 1))%R.
-Proof.
-  intros.
-   legacy field.
-Abort.
diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v
index 4c790680..0e557aee 100644
--- a/test-suite/success/LetPat.v
+++ b/test-suite/success/LetPat.v
@@ -9,22 +9,22 @@ Print l3.
 
 Record someT (A : Type) := mkT { a : nat; b: A }.
 
-Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x.
+Definition l4 A (t : someT A) : nat := let 'mkT _ x y := t in x.
 Print l4.
 Print sigT.
 
 Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
-  let 'existT x y := t return B (projT1 t) in y.
+  let 'existT _ x y := t return B (projT1 t) in y.
 
 Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
-  let 'existT x y as t' := t return B (projT1 t') in y.
+  let 'existT _ x y as t' := t return B (projT1 t') in y.
 
 Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
-  let 'existT x y as t' in sigT _ := t return B (projT1 t') in y.
+  let 'existT _ x y as t' in sigT _ := t return B (projT1 t') in y.
 
 Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) :=
   match t with
-    existT x y => y
+    existT _ x y => y
   end.
 
 (** An example from algebra, using let' and inference of return clauses
diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v
index c2d87a44..7069bba4 100644
--- a/test-suite/success/MatchFail.v
+++ b/test-suite/success/MatchFail.v
@@ -4,7 +4,7 @@ Require Export ZArithRing.
 (* Cette tactique a pour objectif de remplacer toute instance
    de (POS (xI e)) ou de (POS (xO e)) par
    2*(POS e)+1  ou 2*(POS e), pour rendre les expressions plus
-   à même d'être utilisées par Ring, lorsque ces expressions contiennent
+   à même d'être utilisées par Ring, lorsque ces expressions contiennent
    des variables de type positive. *)
 Ltac compute_POS :=
   match goal with
diff --git a/test-suite/success/NumberScopes.v b/test-suite/success/NumberScopes.v
new file mode 100644
index 00000000..6d787210
--- /dev/null
+++ b/test-suite/success/NumberScopes.v
@@ -0,0 +1,62 @@
+
+(* We check that various definitions or lemmas have the correct
+   argument scopes, especially the ones created via functor application. *)
+
+Close Scope nat_scope.
+
+Require Import PArith.
+Check (Pos.add 1 2).
+Check (Pos.add_comm 1 2).
+Check (Pos.min_comm 1 2).
+Definition f_pos (x:positive) := x.
+Definition f_pos' (x:Pos.t) := x.
+Check (f_pos 1).
+Check (f_pos' 1).
+
+Require Import ZArith.
+Check (Z.add 1 2).
+Check (Z.add_comm 1 2).
+Check (Z.min_comm 1 2).
+Definition f_Z (x:Z) := x.
+Definition f_Z' (x:Z.t) := x.
+Check (f_Z 1).
+Check (f_Z' 1).
+
+Require Import NArith.
+Check (N.add 1 2).
+Check (N.add_comm 1 2).
+Check (N.min_comm 1 2).
+Definition f_N (x:N) := x.
+Definition f_N' (x:N.t) := x.
+Check (f_N 1).
+Check (f_N' 1).
+
+Require Import Arith.
+Check (Nat.add 1 2).
+Check (Nat.add_comm 1 2).
+Check (Nat.min_comm 1 2).
+Definition f_nat (x:nat) := x.
+Definition f_nat' (x:Nat.t) := x.
+Check (f_nat 1).
+Check (f_nat' 1).
+
+Require Import BigN.
+Check (BigN.add 1 2).
+Check (BigN.add_comm 1 2).
+Check (BigN.min_comm 1 2).
+Definition f_bigN (x:bigN) := x.
+Check (f_bigN 1).
+
+Require Import BigZ.
+Check (BigZ.add 1 2).
+Check (BigZ.add_comm 1 2).
+Check (BigZ.min_comm 1 2).
+Definition f_bigZ (x:bigZ) := x.
+Check (f_bigZ 1).
+
+Require Import BigQ.
+Check (BigQ.add 1 2).
+Check (BigQ.add_comm 1 2).
+Check (BigQ.min_comm 1 2).
+Definition f_bigQ (x:bigQ) := x.
+Check (f_bigQ 1).
\ No newline at end of file
diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v
index 3b7f0d84..681c4716 100644
--- a/test-suite/success/ProgramWf.v
+++ b/test-suite/success/ProgramWf.v
@@ -100,6 +100,6 @@ Next Obligation. simpl in *; intros.
   apply H. simpl. omega.
 Qed.
 
-Program Fixpoint check_n'  (n : nat) (m : nat | m = n) (p : nat) (q : nat | q = p)
+Program Fixpoint check_n'  (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p})
   {measure (p - n) p} : nat :=
-  _.
+  _.
\ No newline at end of file
diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v
index d8faa88a..3ffd41ea 100644
--- a/test-suite/success/Projection.v
+++ b/test-suite/success/Projection.v
@@ -1,3 +1,9 @@
+Record foo (A : Type) := { B :> Type }.
+
+Lemma bar (f : foo nat) (x : f) : x = x.
+  destruct f. simpl B. simpl B in x.
+Abort.
+
 Structure S : Type :=  {Dom : Type; Op : Dom -> Dom -> Dom}.
 
 Check (fun s : S => Dom s).
diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v
index 459645f6..11fbf24d 100644
--- a/test-suite/success/RecTutorial.v
+++ b/test-suite/success/RecTutorial.v
@@ -301,8 +301,8 @@ Section Le_case_analysis.
            (HS : forall m, n <= m -> Q (S m)).
  Check (
     match H in (_ <= q) return (Q q)  with
-    | le_n => H0
-    | le_S m Hm => HS m Hm
+    | le_n _ => H0
+    | le_S _ m Hm => HS m Hm
     end
   ).
 
@@ -320,8 +320,8 @@ Qed.
 Definition Vtail_total
    (A : Set) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):=
 match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with
-| Vector.nil => Vector.nil A
-| Vector.cons _ n0 v0 => v0
+| Vector.nil _ => Vector.nil A
+| Vector.cons _ _ n0 v0 => v0
 end.
 
 Definition Vtail' (A:Set)(n:nat)(v:Vector.t A n) : Vector.t A (pred n).
@@ -520,8 +520,7 @@ Inductive  typ : Type :=
 
 Definition typ_inject: typ.
 split.
-exact typ.
-Fail Defined.
+Fail exact typ.
 (*
 Error: Universe Inconsistency.
 *)
@@ -1060,8 +1059,8 @@ Fixpoint vector_nth (A:Set)(n:nat)(p:nat)(v:Vector.t A p){struct v}
                   : option A :=
   match n,v  with
     _   , Vector.nil => None
-  | 0   , Vector.cons b  _ _ => Some b
-  | S n', Vector.cons _  p' v' => vector_nth A n'  p' v'
+  | 0   , Vector.cons b _ => Some b
+  | S n', Vector.cons _ v' => vector_nth A n' _ v'
   end.
 
 Implicit Arguments vector_nth [A p].
diff --git a/test-suite/success/Scopes.v b/test-suite/success/Scopes.v
index a79d28fa..43e3493c 100644
--- a/test-suite/success/Scopes.v
+++ b/test-suite/success/Scopes.v
@@ -6,3 +6,17 @@ Module A.
 Definition opp := Z.opp.
 End A.
 Check (A.opp 3).
+
+(* Test extra scopes to be used in the presence of coercions *)
+
+Record B := { f :> Z -> Z }.
+Variable a:B.
+Arguments Scope a [Z_scope].
+Check a 0.
+
+(* Check that casts activate scopes if ever possible *)
+
+Inductive U := A.
+Bind Scope u with U.
+Notation "'ε'" := A : u.
+Definition c := ε : U.
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index ed445c63..01d9afb4 100644
--- a/test-suite/success/Tauto.v
+++ b/test-suite/success/Tauto.v
@@ -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/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v
index aecc9ed0..3090f40c 100644
--- a/test-suite/success/TestRefine.v
+++ b/test-suite/success/TestRefine.v
@@ -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        *)
@@ -53,7 +53,7 @@ Abort.
 
 Lemma essai2 : forall x : nat, x = x.
 
- refine (fix f (x : nat) : x = x := _).
+Fail refine (fix f (x : nat) : x = x := _).
 
 Restart.
 
@@ -119,7 +119,7 @@ Lemma essai : {x : nat | x = 1}.
 Restart.
 
 (* mais si on contraint par le but alors ca marche : *)
-(* Remarque : on peut toujours faire ça *)
+(* Remarque : on peut toujours faire ça *)
  refine (exist _ 1 _:{x : nat | x = 1}).
 
 Restart.
@@ -176,7 +176,7 @@ Restart.
     end).
 
 exists 1. trivial.
-elim (f0 p).
+elim (f p).
  refine
  (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _).
  rewrite h. auto.
@@ -184,7 +184,7 @@ Qed.
 
 
 
-(* Quelques essais de recurrence bien fondée *)
+(* Quelques essais de recurrence bien fondée *)
 
 Require Import Wf.
 Require Import Wf_nat.
diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v
index 0d8bf556..21b829aa 100644
--- a/test-suite/success/apply.v
+++ b/test-suite/success/apply.v
@@ -164,8 +164,8 @@ intros.
 apply H with (y:=y).
 (* [x] had two possible instances: [S 0], coming from unifying the
    type of [y] with [I ?n] and [succ 0] coming from the unification with
-   the goal; only the first one allows to make the next apply (which
-   does not work modulo delta) working *)
+   the goal; only the first one allows the next apply (which
+   does not work modulo delta) work *)
 apply H0.
 Qed.
 
@@ -336,25 +336,43 @@ Qed.
 (* From 12612, descent in conjunctions is more powerful *)
 (* The following, which was failing badly in bug 1980, is now
    properly rejected, as descend in conjunctions builds an
-   ill-formed elimination from Prop to Type. *)
+   ill-formed elimination from Prop to Type.
+
+   Added Aug 2014: why it fails is now that trivial unification ?x = goal is
+   rejected by the descent in conjunctions to avoid surprising results. *)
 
 Goal True.
 Fail eapply ex_intro.
 exact I.
 Qed.
 
-(* The following, which were not accepted, are now accepted as
-    expected by descent in conjunctions *)
+Goal True.
+Fail eapply (ex_intro _).
+exact I.
+Qed.
+
+(* Note: the following succeed directly (i.e. w/o "exact I") since
+   Aug 2014 since the descent in conjunction does not use a "cut"
+   anymore: the iota-redex is contracted and we get rid of the
+   uninstantiated evars
+
+   Is it good or not? Maybe it does not matter so much.
 
 Goal True.
 eapply (ex_intro (fun _ => True) I).    
-exact I.
+exact I. (* Not needed since Aug 2014 *)
+Qed.
+
+Goal True.
+eapply (ex_intro (fun _ => True) I _).    
+exact I. (* Not needed since Aug 2014 *)
 Qed.
 
 Goal True.
 eapply (fun (A:Prop) (x:A) => conj I x).
-exact I.
+exact I. (* Not needed since Aug 2014 *)
 Qed.
+*)
 
 (* The following was not accepted from r12612 to r12657 *)
 
@@ -430,3 +448,91 @@ Undo.
 (* H' is displayed as (forall n0, n=n0) *)
 apply H' with (n0:=0).
 Qed.
+
+(* Check that evars originally present in goal do not prevent apply in to work*)
+
+Goal (forall x, x <= 0 -> x = 0) -> exists x, x <= 0 -> 0 = 0.
+intros.
+eexists.
+intros.
+apply H in H0.
+Abort.
+
+(* Check correct failure of apply in when hypothesis is dependent *)
+
+Goal forall H:0=0, H = H.
+intros.
+Fail apply eq_sym in H.
+
+(* Check that unresolved evars not originally present in goal prevent
+   apply in to work*)
+
+Goal (forall x y, x <= 0 -> x + y = 0) -> exists x, x <= 0 -> 0 = 0.
+intros.
+eexists.
+intros.
+Fail apply H in H0.
+Abort.
+
+(* Check naming pattern in apply in *)
+
+Goal ((False /\ (True -> True))) -> True -> True.
+intros F H.
+apply F in H as H0. (* Check that H0 is not used internally *)
+exact H0.
+Qed.
+
+Goal ((False /\ (True -> True/\True))) -> True -> True/\True.
+intros F H.
+apply F in H as (?,?).
+split.
+exact H. (* Check that generated names are H and H0 *)
+exact H0.
+Qed.
+
+(* This failed at some time in between 18 August 2014 and 2 September 2014 *)
+
+Goal forall A B C: Prop, (True -> A -> B /\ C) -> A -> B.
+intros * H.
+apply H.
+Abort.
+
+(* This failed between 2 and 3 September 2014 *)
+
+Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A -> B.
+intros.
+apply H in H0.
+pose proof I as H1. (* Test that H1 does not exist *)
+Abort.
+
+Goal forall A B C D:Prop, (A<->B)/\(C<->D) -> A.
+intros.
+apply H.
+pose proof I as H0. (* Test that H0 does not exist *)
+Abort.
+
+(* The first example below failed at some time in between 18 August
+   2014 and 2 September 2014 *)
+
+Goal forall x, 2=0 -> x+1=2 -> (forall x, S x = 0) -> True.
+intros x H H0 H1.
+eapply eq_trans in H. 2:apply H0.
+rewrite H1 in H.
+change (x+0=0) in H. (* Check the result in H1 *)
+Abort.
+
+Goal forall x, 2=x+1 -> (forall x, S x = 0) -> 2 = 0.
+intros x H H0.
+eapply eq_trans. apply H.
+rewrite H0.
+change (x+0=0).
+Abort.
+
+(* 2nd order apply used to have delta on local definitions even though
+   it does not have delta on global definitions; keep it by
+   compatibility while finding a more uniform way to proceed. *)
+
+Goal forall f:nat->nat, (forall P x, P (f x)) -> let x:=f 0 in x = 0.
+intros f H x.
+apply H.
+Qed.
diff --git a/test-suite/success/applyTC.v b/test-suite/success/applyTC.v
new file mode 100644
index 00000000..c2debdec
--- /dev/null
+++ b/test-suite/success/applyTC.v
@@ -0,0 +1,15 @@
+Axiom P : nat -> Prop.
+
+Class class (A : Type) := { val : A }.
+
+Lemma usetc {t : class nat} : P (@val nat t).
+Admitted.
+
+Notation "{val:= v }" := (@val _ v).
+
+Instance zero : class nat := {| val := 0 |}.
+
+Lemma test : P 0.
+Fail apply usetc.
+pose (tmp := usetc); apply tmp; clear tmp.
+Qed.
diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v
index 9b691e25..db3b19af 100644
--- a/test-suite/success/auto.v
+++ b/test-suite/success/auto.v
@@ -14,7 +14,7 @@ Hint Resolve L.
 
 Goal G unit Q -> F (Q tt).
   intro.
-  auto.
+  eauto. 
 Qed.
 
 (* Test implicit arguments in "using" clause *)
@@ -24,3 +24,24 @@ auto using (pair O).
 Undo.
 eauto using (pair O).
 Qed.
+
+Create HintDb test discriminated.
+
+Parameter foo : forall x, x = x + 0.
+Hint Resolve foo : test.
+
+Variable C : nat -> Type -> Prop.
+
+Variable c_inst : C 0 nat.
+
+Hint Resolve c_inst : test.
+
+Hint Mode C - + : test.
+Hint Resolve c_inst : test2.
+Hint Mode C + + : test2.
+
+Goal exists n, C n nat.
+Proof.
+  eexists. Fail progress debug eauto with test2. 
+  progress eauto with test.
+Qed.
diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v
index b565183b..a70d9196 100644
--- a/test-suite/success/cc.v
+++ b/test-suite/success/cc.v
@@ -102,5 +102,32 @@ Proof.
   auto.
 Qed.
 
+(* bug 2447 is now closed (PC, 2014) *)
+
+Section bug_2447.
+
+Variable T:Type.
+
+Record R := mkR {x:T;y:T;z:T}.
+
+Variables a a' b b' c c':T.
+
+
+
+Lemma bug_2447: mkR a b c = mkR a' b c -> a = a'.
+congruence.
+Qed.
+
+Lemma bug_2447_variant1: mkR a b c = mkR a b' c -> b = b'.
+congruence.
+Qed.
+
+Lemma bug_2447_variant2: mkR a b c = mkR a b c' -> c = c'.
+congruence.
+Qed.
+
+
+End bug_2447.
+
 
 
diff --git a/test-suite/success/change.v b/test-suite/success/change.v
index 7bed7ecb..1f0b7d38 100644
--- a/test-suite/success/change.v
+++ b/test-suite/success/change.v
@@ -38,3 +38,24 @@ Fail change True with (let (x,a) := ex_intro _ True (eq_refl True) in x).
 Fail change True with
         match ex_intro _ True (eq_refl True) with ex_intro x _ => x end.
 Abort.
+
+(* Check absence of loop in identity substitution (was failing up to
+   Sep 2014, see #3641) *)
+
+Goal True.
+change ?x with x.
+Abort.
+
+(* Check typability after change of type subterms *)
+Goal nat = nat :> Set.
+Fail change nat with (@id Type nat). (* would otherwise be ill-typed *)
+Abort.
+
+(* Check typing env for rhs is the correct one *)
+
+Goal forall n, let x := n in id (fun n => n + x) 0 = 0.
+intros.
+unfold x.
+(* check that n in 0+n is not interpreted as the n from "fun n" *)
+change n with (0+n).
+Abort.
diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v
index 4292ecb6..b538d2ed 100644
--- a/test-suite/success/coercions.v
+++ b/test-suite/success/coercions.v
@@ -96,13 +96,13 @@ Inductive list (A : Type) : Type :=
   nil : list A | cons : A -> list A -> list A.
 Inductive vect (A : Type) : nat -> Type :=
   vnil : vect A 0 | vcons : forall n, A -> vect A n -> vect A (1+n).
-Fixpoint size A (l : list A) : nat := match l with nil => 0 | cons _ tl => 1+size _ tl end.
+Fixpoint size A (l : list A) : nat := match l with nil _ => 0 | cons _ _ tl => 1+size _ tl end.
 
 Section test_non_unif_but_complete.
 Fixpoint l2v A (l : list A) : vect A (size A l) :=
   match l as l return vect A (size A l) with
-  | nil => vnil A
-  | cons x xs => vcons A (size A xs) x (l2v A xs)
+  | nil _ => vnil A
+  | cons _ x xs => vcons A (size A xs) x (l2v A xs)
   end.
 
 Local Coercion l2v : list >-> vect.
@@ -121,8 +121,8 @@ Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C)
 
 Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) := 
   match l as l return vect B (size A l) with
-  | nil => vnil B
-  | cons x xs => vcons _ _ (c x) (l2v2 xs) end.
+  | nil _ => vnil B
+  | cons _ x xs => vcons _ _ (c x) (l2v2 xs) end.
 
 Local Coercion l2v2 : list >-> vect.
 
diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v
index 52575eca..58f79d45 100644
--- a/test-suite/success/decl_mode.v
+++ b/test-suite/success/decl_mode.v
@@ -67,7 +67,7 @@ proof.
 end proof.
 Qed.
 
-Require Omega.
+Require Import Omega.
 
 Lemma even_double_n: (forall m, even (double m)).
 proof.
diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v
index fc40ea96..83a33f75 100644
--- a/test-suite/success/destruct.v
+++ b/test-suite/success/destruct.v
@@ -37,7 +37,6 @@ Goal True.
 case Refl || ecase Refl.
 Abort.
 
-
 (* Submitted by B. Baydemir (bug #1882) *)
 
 Require Import List.
@@ -93,3 +92,339 @@ Goal let T:=nat in forall (x:nat) (g:T -> nat), g x = 0.
 intros.
 destruct (g _). (* This was failing in at least r14571 *)
 Abort.
+
+(* Check that subterm selection does not solve existing evars *)
+
+Goal exists x, S x = S 0.
+eexists.
+destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *)
+change (0 = S 0).
+Abort.
+
+Goal exists x, S 0 = S x.
+eexists.
+destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *)
+change (0 = S ?x).
+Abort.
+
+Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n.
+do 2 eexists.
+destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *)
+change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n).
+Abort.
+
+(* An example with incompatible but convertible occurrences *)
+
+Goal id (id 0) = 0.
+Fail destruct (id _) at 1 2.
+Abort.
+
+(* Avoid unnatural selection of a subterm larger than expected *)
+
+Goal let g := fun x:nat => x in g (S 0) = 0.
+intro.
+destruct S.
+(* Check that it is not the larger subterm "g (S 0)" which is
+   selected, as it was the case in 8.4 *)
+unfold g at 1.
+Abort.
+
+(* Some tricky examples convenient to support *)
+
+Goal forall x, nat_rect (fun _ => nat) O (fun x y => S x) x = nat_rect (fun _ => nat) O (fun x y => S x) x.
+intros.
+destruct (nat_rect _ _ _ _).
+Abort.
+(* Check compatibility in selecting what is open or "shelved" *)
+
+Goal (forall x, x=0 -> nat) -> True.
+intros.
+Fail destruct H.
+edestruct H.
+- reflexivity.
+- exact Logic.I.
+- exact Logic.I.
+Qed.
+
+(* Check an example which was working with case/elim in 8.4 but not with
+   destruct/induction *)
+
+Goal forall x, (True -> x = 0) -> 0=0. 
+intros.
+destruct H.
+- trivial.
+- apply (eq_refl x).
+Qed.
+
+(* Check an example which was working with case/elim in 8.4 but not with
+   destruct/induction (not the different order between induction/destruct) *)
+
+Goal forall x, (True -> x = 0) -> 0=0. 
+intros.
+induction H.
+- apply (eq_refl x).
+- trivial.
+Qed.
+
+(* This test assumes that destruct/induction on non-dependent hypotheses behave the same
+   when using holes or not
+
+Goal forall x, (True -> x = 0) -> 0=0. 
+intros.
+destruct (H _).
+- apply I.
+- apply (eq_refl x).
+Qed.
+*)
+
+(* Check destruct vs edestruct *)
+
+Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0.
+intros.
+Fail destruct H.
+edestruct H.
+- trivial.
+- apply (eq_refl x).
+Qed.
+
+Goal forall x, (forall y, y = 0 -> x = 0) -> 0=0.
+intros.
+Fail destruct (H _ _).
+(* Now a test which assumes that edestruct on non-dependent
+   hypotheses accept unresolved subterms in the induction argument.
+edestruct (H _ _).
+- trivial.
+- apply (eq_refl x).
+Qed.
+*)
+Abort.
+
+(* Test selection when not in an inductive type *)
+Parameter T:Type.
+Axiom elim: forall P, T -> P.
+Goal forall a:T, a = a.
+induction a using elim.
+Qed.
+
+Goal forall a:nat -> T, a 0 = a 1.
+intro a.
+induction (a 0) using elim.
+Qed.
+
+(* From Oct 2014, a subterm is found, as if without "using"; in 8.4,
+   it did not find a subterm *)
+
+Goal forall a:nat -> T, a 0 = a 1.
+intro a.
+induction a using elim.
+Qed.
+
+Goal forall a:nat -> T, forall b, a 0 = b.
+intros a b.
+induction a using elim.
+Qed.
+
+(* From Oct 2014, first subterm is found; in 8.4, it failed because it
+   found "a 0" and wanted to clear a *)
+
+Goal forall a:nat -> nat, a 0 = a 1.
+intro a.
+destruct a.
+change (0 = a 1).
+Abort.
+
+(* This example of a variable not fully applied in the goal was working in 8.4*)
+
+Goal forall H : 0<>0, H = H.
+destruct H.
+reflexivity.
+Qed.
+
+(* Check that variables not fully applied in the goal are not erased
+   (this example was failing in 8.4 because of a forbidden "clear H" in
+   the code of "destruct H" *)
+
+Goal forall H : True -> True, H = H.
+destruct H.
+- exact I.
+- reflexivity.
+Qed.
+
+(* Check destruct on idents with maximal implicit arguments - which did
+   not work in 8.4 *)
+
+Parameter g : forall {n:nat}, n=n -> nat.
+Goal g (eq_refl 0) = 0.
+destruct g.
+Abort.
+
+(* This one was working in 8.4 (because of full conv on closed arguments) *)
+
+Class E.
+Instance a:E.
+Goal forall h : E -> nat -> nat, h (id a) 0 = h a 0.
+intros.
+destruct (h _).
+change (0=0).
+Abort.
+
+(* This one was not working in 8.4 because an occurrence of f was
+   remaining, blocking the "clear f" *)
+
+Goal forall h : E -> nat -> nat, h a 0 = h a 1.
+intros.
+destruct h.
+Abort.
+
+(* This was not working in 8.4 *)
+
+Section S1.
+Variables x y : Type.
+Variable H : x = y.
+Goal True.
+destruct H. (* Was not working in 8.4 *)
+(* Now check that H statement has itself be subject of the rewriting *)
+change (x=x) in H.
+Abort.
+End S1.
+
+(* This was not working in 8.4 because of untracked dependencies *)
+Goal forall y, forall h:forall x, x = y, h 0 = h 0.
+intros.
+destruct (h 0).
+Abort.
+
+(* Check absence of useless local definitions *)
+
+Section S2.
+Variable H : 1=1.
+Goal 0=1.
+destruct H.
+Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *)
+Abort.
+End S2.
+
+Goal forall x:nat, x=x->x=1.
+intros x H.
+destruct H.
+Fail clear n. (* Check that there is no n as it was in Coq <= 8.4 *)
+Fail clear H. (* Check that H has been removed *)
+Abort.
+
+(* Check support for induction arguments which do not expose an inductive
+   type rightaway *)
+
+Definition U := nat -> nat.
+Definition S' := S : U.
+Goal forall n, S' n = 0.
+intro.
+destruct S'.
+Abort.
+
+(* This was working by chance in 8.4 thanks to "accidental" use of select
+   subterms _syntactically_ equal to the first matching one.
+
+Parameter f2:bool -> unit.
+Parameter r2:f2 true=f2 true.
+Goal forall (P: forall b, b=b -> Prop), f2 (id true) = tt -> P (f2 true) r2.
+intros.
+destruct f2.
+Abort.
+*)
+
+(* This did not work in 8.4, because of a clear failing *)
+
+Inductive IND : forall x y:nat, x=y -> Type := CONSTR : IND 0 0 eq_refl.
+Goal forall x y e (h:x=y -> y=x) (z:IND y x (h e)), e = e /\ z = z.
+intros.
+destruct z.
+Abort.
+
+(* The two following examples show how the variables occurring in the
+   term being destruct affects the generalization; don't know if these
+   behaviors are "good". None of them was working in 8.4. *)
+
+Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e.
+intros.
+destruct (z t).
+change (0=0) in t. (* Generalization made *)
+Abort.
+
+Goal forall x y e (t:x=y) (z:x=y -> IND y x e), e = e /\ z t = z t.
+intros.
+destruct (z t).
+change (0=0) in t. (* Generalization made *)
+Abort.
+
+(* Check that destruct on a scheme with a functional argument works *)
+
+Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat, h 0 = h 0.
+intros.
+destruct h using H.
+Qed.
+
+Goal (forall P:Prop, (nat->nat) -> P) -> forall h:nat->nat->nat, h 0 0 = h 1 0.
+intros.
+induction (h 1) using H.
+Qed.
+
+(* Check blocking generalization is not too strong (failed at some time) *)
+
+Goal (E -> 0=1) -> 1=0 -> True.
+intros.
+destruct (H _).
+change (0=0) in H0. (* Check generalization on H0 was made *)
+Abort.
+
+(* Check absence of anomaly (failed at some time) *)
+
+Goal forall A (a:A) (P Q:A->Prop), (forall a, P a -> Q a) -> True.
+intros.
+Fail destruct H.
+Abort.
+
+(* Check keep option (bug #3791) *)
+
+Goal forall b:bool, True.
+intro b.
+destruct !b.
+clear b. (* b has to be here *)
+Abort.
+
+(* Check clearing of names *)
+
+Inductive IND2 : nat -> Prop := CONSTR2 : forall y, y = y -> IND2 y.
+Goal forall x y z:nat, y = z -> x = y -> y = x -> x = y.
+intros * Heq H Heq'.
+destruct H.
+Abort.
+
+Goal 2=1 -> 1=0.
+intro H. destruct H.
+Fail (match goal with n:nat |- _ => unfold n end). (* Check that no let-in remains *)
+Abort.
+
+(* Check clearing of names *)
+
+Inductive eqnat (x : nat) : nat -> Prop :=
+  reflnat : forall y, x = y -> eqnat x y.
+
+Goal forall x z:nat, x = z -> eqnat x z -> True.
+intros * H1 H.
+destruct H.
+Fail clear z. (* Should not be here *)
+Abort.
+
+(* Check ok in the presence of an equation *)
+
+Goal forall b:bool, b = b.
+intros.
+destruct b eqn:H.
+
+(* Check natural instantiation behavior when the goal has already an evar *)
+
+Goal exists x, S x = x.
+eexists.
+destruct (S _).
+change (0 = ?x).
+Abort.
diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v
index b7b0f7fd..9e57801e 100644
--- a/test-suite/success/eauto.v
+++ b/test-suite/success/eauto.v
@@ -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/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v
index 044b41d3..1b5c7f18 100644
--- a/test-suite/success/eqdecide.v
+++ b/test-suite/success/eqdecide.v
@@ -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/test-suite/success/evars.v b/test-suite/success/evars.v
index e6088091..4e2bf451 100644
--- a/test-suite/success/evars.v
+++ b/test-suite/success/evars.v
@@ -1,3 +1,4 @@
+
 (* The "?" of cons and eq should be inferred *)
 Variable list : Set -> Set.
 Variable cons : forall T : Set, T -> list T -> list T.
@@ -44,13 +45,13 @@ Fixpoint build (nl : list nat) :
 
 
 (* Checks that disjoint contexts are correctly set by restrict_hyp *)
-(* Bug de 1999 corrigé en déc 2004 *)
+(* Bug de 1999 corrigé en déc 2004 *)
 
 Check
   (let p :=
      fun (m : nat) f (n : nat) =>
      match f m n with
-     | exist a b => exist _ a b
+     | exist _ a b => exist _ a b
      end in
    p
    :forall x : nat,
@@ -61,7 +62,7 @@ Check
 
 Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))).
 
-(* This used to fail with anomaly "evar was not declared" in V8.0pl3 *)
+(* This used to fail with anomaly (Pp.str "evar was not declared") in V8.0pl3 *)
 
 Theorem contradiction : forall p, ~ p -> p -> False.
 Proof. trivial. Qed.
@@ -177,9 +178,9 @@ refine
        | left _ => _
        | right _ =>
            match le_step s _ _ with
-           | exist s' h' =>
+           | exist _ s' h' =>
                match hr s' _ _ with
-               | exist s'' _ => exist _ s'' _
+               | exist _ s'' _ => exist _ s'' _
                end
            end
        end)).
@@ -203,7 +204,7 @@ Abort.
 Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) :=
   match l with
   | nil => nil
-  | (existT k v)::l' => (existT _ k v):: (filter A l')
+  | (existT _ k v)::l' => (existT _ k v):: (filter A l')
   end.
 
 (* Bug #2000: used to raise Out of memory in 8.2 while it should fail by
@@ -379,3 +380,38 @@ Section evar_evar_occur.
   (* Still evars in the resulting type, but constraints should be solved *)
   Check match g _ with conj a b => f _ a b end.
 End evar_evar_occur.
+
+(* Eta expansion (bug #2936) *)
+Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }.
+Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri {
+  tri0 : forall a b c, R a b -> S a c -> T b c
+}.
+Implicit Arguments mkTri [R S T].
+Definition tri_iffT : tri iffT iffT iffT :=
+  (mkTri
+    (fun X0 X1 X2 E01 E02 =>
+     (mkIff _ _ (fun x1 => iffLR _ _ E02 (iffRL _ _ E01 x1))
+     (fun x2 => iffLR _ _ E01 (iffRL _ _ E02 x2))))).
+
+(* Check that local defs names are preserved if possible during unification *)
+
+Goal forall x (x':=x) (f:forall y, y=y:>nat -> Prop), f _ (eq_refl x').
+intros.
+unfold x' at 2. (* A way to check that there are indeed 2 occurrences of x' *)
+Abort.
+
+(* A simple example we would like not to fail (it used to fail because of
+   not strict enough evar restriction) *)
+
+Check match Some _ with None => _ | _ => _ end.
+
+(* Used to fail for a couple of days in Nov 2014 *)
+
+Axiom test : forall P1 P2, P1 = P2 -> P1 -> P2.
+
+(* Check use of candidates *)
+
+Import EqNotations.
+Definition test2 {A B:Type} {H:A=B} (a:A) : B := rew H in a.
+
+
diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v
index eaed9616..57f3775d 100644
--- a/test-suite/success/extraction.v
+++ b/test-suite/success/extraction.v
@@ -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/test-suite/success/extraction_dep.v b/test-suite/success/extraction_dep.v
new file mode 100644
index 00000000..11bb25fd
--- /dev/null
+++ b/test-suite/success/extraction_dep.v
@@ -0,0 +1,46 @@
+
+(** Examples of code elimination inside modules during extraction *)
+
+(** NB: we should someday check the produced code instead of
+    simply running the commands. *)
+
+(** 1) Without signature ... *)
+
+Module A.
+ Definition u := 0.
+ Definition v := 1.
+ Module B.
+  Definition w := 2.
+  Definition x := 3.
+ End B.
+End A.
+
+Definition testA := A.u + A.B.x.
+
+Recursive Extraction testA. (* without: v w *)
+
+(** 1b) Same with an Include *)
+
+Module Abis.
+ Include A.
+ Definition y := 4.
+End Abis.
+
+Definition testAbis := Abis.u + Abis.y.
+
+Recursive Extraction testAbis. (* without: A B v w x *)
+
+(** 2) With signature, we only keep elements mentionned in signature. *)
+
+Module Type SIG.
+ Parameter u : nat.
+ Parameter v : nat.
+End SIG.
+
+Module Ater : SIG.
+ Include A.
+End Ater.
+
+Definition testAter := Ater.u.
+
+Recursive Extraction testAter. (* with only: u v *)
diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v
index 8623f718..ff34840d 100644
--- a/test-suite/success/fix.v
+++ b/test-suite/success/fix.v
@@ -9,12 +9,13 @@ Inductive rBoolOp : Set :=
   | rAnd : rBoolOp
   | rEq : rBoolOp.
 
-Definition rlt (a b : rNat) : Prop := Pos.compare_cont a b Eq = Lt.
+Definition rlt (a b : rNat) : Prop := Pos.compare_cont Eq a b = Lt.
 
 Definition rltDec : forall m n : rNat, {rlt m n} + {rlt n m \/ m = n}.
+Proof.
 intros n m; generalize (nat_of_P_lt_Lt_compare_morphism n m);
  generalize (nat_of_P_gt_Gt_compare_morphism n m);
- generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont n m Eq).
+ generalize (Pcompare_Eq_eq n m); case (Pos.compare_cont Eq n m).
 intros H' H'0 H'1; right; right; auto.
 intros H' H'0 H'1; left; unfold rlt.
 apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
@@ -25,6 +26,7 @@ Defined.
 
 
 Definition rmax : rNat -> rNat -> rNat.
+Proof.
 intros n m; case (rltDec n m); intros Rlt0.
 exact m.
 exact n.
diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v
index e8019a90..a0981311 100644
--- a/test-suite/success/implicit.v
+++ b/test-suite/success/implicit.v
@@ -61,7 +61,7 @@ Check (eq1 0 0).
 Check (eq2 0 0).
 Check (eq3 nat 0 0).
 
-(* Example submitted by Frédéric (interesting in v8 syntax) *)
+(* Example submitted by Frédéric (interesting in v8 syntax) *)
 
 Parameter f : nat -> nat * nat.
 Notation lhs := fst.
diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v
new file mode 100644
index 00000000..91b6dee2
--- /dev/null
+++ b/test-suite/success/indelim.v
@@ -0,0 +1,61 @@
+Inductive boolP : Prop :=
+| trueP : boolP
+| falseP : boolP.
+
+Fail Check boolP_rect.
+
+
+Inductive True : Prop := I : True.
+
+Inductive False : Prop :=.
+
+Inductive Empty_set : Set :=.
+
+Fail Inductive Large_set : Set :=
+  large_constr : forall A : Set, A -> Large_set.
+
+Inductive smallunitProp : Prop :=
+| onlyProps : True -> smallunitProp.
+
+Check smallunitProp_rect.
+
+Inductive nonsmallunitProp : Prop :=
+| notonlyProps : nat -> nonsmallunitProp.
+
+Fail Check nonsmallunitProp_rect.
+Set Printing Universes.
+Inductive inferProp :=
+| hasonlyProps : True -> nonsmallunitProp -> inferProp.
+
+Check (inferProp : Prop).
+
+Inductive inferSet :=
+| hasaset : nat -> True -> nonsmallunitProp -> inferSet.
+
+Fail Check (inferSet : Prop).
+
+Check (inferSet : Set).
+
+Inductive inferLargeSet :=
+| hasalargeset : Set -> True -> nonsmallunitProp -> inferLargeSet.
+
+Fail Check (inferLargeSet : Set).
+
+Inductive largeProp : Prop := somelargeprop : Set -> largeProp.
+
+
+Inductive comparison : Set :=
+  | Eq : comparison
+  | Lt : comparison
+  | Gt : comparison.
+
+Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type :=
+ | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq
+ | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt
+ | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt.
+
+Inductive color := Red | Black.
+
+Inductive option (A : Type) : Type :=
+| None : option A
+| Some : A -> option A.
\ No newline at end of file
diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v
index 83c90929..b733aef6 100644
--- a/test-suite/success/inds_type_sec.v
+++ b/test-suite/success/inds_type_sec.v
@@ -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/test-suite/success/induct.v b/test-suite/success/induct.v
index 75643d9d..7ae60d98 100644
--- a/test-suite/success/induct.v
+++ b/test-suite/success/induct.v
@@ -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        *)
@@ -25,7 +25,7 @@ Check
  fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
    let B := A in
      fun (a : A) (e : eq1 A a) =>
-       match e in (eq1 A0 B0 a0) return (P A0 a0) with
+       match e in (eq1 A0 a0) return (P A0 a0) with
        | refl1 => f
        end.
 
@@ -64,3 +64,90 @@ Undo 2.
 Fail induction (S _) in |- * at 4.
 Abort.
 
+(* Check use of "as" clause *)
+
+Inductive I := C : forall x, x<0 -> I -> I.
+
+Goal forall x:I, x=x.
+intros.
+induction x as [y * IHx].
+change (x = x) in IHx. (* We should have IHx:x=x *)
+Abort.
+
+(* This was not working in 8.4 *)
+
+Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2.
+intros.
+induction h.
+2:change (n = h 1 -> n = h 2) in IHn.
+Abort.
+
+(* This was not working in 8.4 *)
+
+Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. 
+intros h H H0.
+induction h in H |- *.
+Abort.
+
+(* "at" was not granted in 8.4 in the next two examples *)
+
+Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. 
+intros h H H0.
+induction h in H at 2, H0 at 1.
+change (h 0 = 0) in H.
+Abort.
+
+Goal forall h:nat->nat, h 0 = h 1 -> h 1 = h 2 -> h 0 = h 2. 
+intros h H H0.
+Fail induction h in H at 2 |- *. (* Incompatible occurrences *)
+Abort.
+
+(* Check generalization with dependencies in section variables *)
+
+Section S3.
+Variables x : nat.
+Definition cond := x = x.
+Goal cond -> x = 0.
+intros H.
+induction x as [|n IHn].
+2:change (n = 0) in IHn. (* We don't want a generalization over cond *)
+Abort.
+End S3.
+
+(* These examples show somehow arbitrary choices of generalization wrt
+   to indices, when those indices are not linear. We check here 8.4
+   compatibility: when an index is a subterm of a parameter of the
+   inductive type, it is not generalized. *)
+
+Inductive repr (x:nat) : nat -> Prop := reprc z : repr x z -> repr x z.
+
+Goal forall x, 0 = x -> repr x x -> True.
+intros x H1 H.
+induction H.
+change True in IHrepr.
+Abort.
+
+Goal forall x, 0 = S x -> repr (S x) (S x) -> True.
+intros x H1 H.
+induction H.
+change True in IHrepr.
+Abort.
+
+Inductive repr' (x:nat) : nat -> Prop := reprc' z : repr' x (S z) -> repr' x z.
+
+Goal forall x, 0 = x -> repr' x x -> True.
+intros x H1 H.
+induction H.
+change True in IHrepr'.
+Abort.
+
+(* In this case, generalization was done in 8.4 and we preserve it; this
+   is arbitrary choice  *)
+
+Inductive repr'' : nat -> nat -> Prop := reprc'' x z : repr'' x z -> repr'' x z.
+
+Goal forall x, 0 = x -> repr'' x x -> True.
+intros x H1 H.
+induction H.
+change (0 = z -> True) in IHrepr''.
+Abort.
diff --git a/test-suite/success/instantiate.v b/test-suite/success/instantiate.v
deleted file mode 100644
index 4224405d..00000000
--- a/test-suite/success/instantiate.v
+++ /dev/null
@@ -1,11 +0,0 @@
-(* Test régression bug #1041 *)
-
-Goal Prop.
-
-pose (P:= fun x y :Prop => y).
-evar (Q: forall X Y,P X Y -> Prop) .
-
-instantiate (1:= fun _ => _ ) in (Value of Q).
-instantiate (1:= fun _ => _ ) in (Value of Q).
-instantiate (1:= fun _ => _ ) in (Value of Q).
-instantiate (1:= H) in (Value of Q).
diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v
index 3599da4d..9443d01e 100644
--- a/test-suite/success/intros.v
+++ b/test-suite/success/intros.v
@@ -3,5 +3,33 @@
 
 Goal forall A, A -> True.
 intros _ _.
+Abort.
 
+(* This did not work until March 2013, because of underlying "red" *)
+Goal (fun x => True -> True) 0.
+intro H.
+Abort.
 
+(* This should still work, with "intro" calling "hnf" *)
+Goal (fun f => True -> f 0 = f 0) (fun x => x).
+intro H.
+match goal with [ |- 0 = 0 ] => reflexivity end.
+Abort.
+
+(* Somewhat related: This did not work until March 2013 *)
+Goal (fun f => f 0 = f 0) (fun x => x).
+hnf.
+match goal with [ |- 0 = 0 ] => reflexivity end.
+Abort.
+
+(* Fixing behavior of "*" and "**" in branches, so that they do not
+   introduce more than what the branch expects them to introduce at most *)
+Goal forall n p, n + p = 0.
+intros [|*]; intro p.
+Abort.
+
+(* Check non-interference of "_" with name generation *)
+Goal True -> True -> True.
+intros _ ?.
+exact H.
+Qed.
diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v
new file mode 100644
index 00000000..bbe9d4bf
--- /dev/null
+++ b/test-suite/success/keyedrewrite.v
@@ -0,0 +1,24 @@
+Set Keyed Unification.
+
+Section foo.
+Variable f : nat -> nat. 
+
+Definition g := f.
+
+Variable lem : g 0 = 0.
+
+Goal f 0 = 0.
+Proof.
+  Fail rewrite lem.
+Abort.
+
+Declare Equivalent Keys @g @f.
+(** Now f and g are considered equivalent heads for subterm selection *)
+Goal f 0 = 0.
+Proof.
+  rewrite lem.
+  reflexivity.
+Qed.
+
+Print Equivalent Keys.
+End foo.
diff --git a/test-suite/success/letproj.v b/test-suite/success/letproj.v
new file mode 100644
index 00000000..a183be62
--- /dev/null
+++ b/test-suite/success/letproj.v
@@ -0,0 +1,9 @@
+Set Primitive Projections.
+Set Record Elimination Schemes.
+Record Foo (A : Type) := { bar : A -> A; baz : A }.
+
+Definition test (A : Type) (f : Foo A) := 
+  let (x, y) := f in x.
+
+Scheme foo_case := Case for Foo Sort Type.
+
diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v
index c2eb8bd7..badce063 100644
--- a/test-suite/success/ltac.v
+++ b/test-suite/success/ltac.v
@@ -1,6 +1,6 @@
 (* The tactic language *)
 
-(* Submitted by Pierre Crégut *)
+(* Submitted by Pierre Crégut *)
 (* Checks substitution of x *)
 Ltac f x := unfold x; idtac.
 
@@ -9,7 +9,7 @@ f plus.
 reflexivity.
 Qed.
 
-(* Submitted by Pierre Crégut *)
+(* Submitted by Pierre Crégut *)
 (* Check syntactic correctness *)
 Ltac F x := idtac; G x
  with G y := idtac; F y.
@@ -143,7 +143,7 @@ Qed.
 
 Ltac check_binding y := cut ((fun y => y) = S).
 Goal True.
-check_binding true.
+check_binding ipattern:H.
 Abort.
 
 (* Check that variables explicitly parsed as ltac variables are not
@@ -211,7 +211,7 @@ is.
 exact I.
 Abort.
 
-(* Interférence entre espaces des noms *)
+(* Interférence entre espaces des noms *)
 
 Ltac O := intro.
 Ltac Z1 t := set (x:=t).
@@ -298,7 +298,3 @@ evar(foo:nat).
 let evval := eval compute in foo in not_eq evval 1.
 let evval := eval compute in foo in not_eq 1 evval.
 Abort.
-
-(* Check that this returns an error and not an anomaly (see r13667) *)
-
-Fail Local Tactic Notation "myintro" := intro.
diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v
new file mode 100644
index 00000000..8a08d646
--- /dev/null
+++ b/test-suite/success/ltac_plus.v
@@ -0,0 +1,12 @@
+(** Checks that Ltac's '+' tactical works as intended. *)
+
+Goal forall (A B C D:Prop), (A->C) -> (B->C) -> (D->C) -> B -> C.
+Proof.
+  intros A B C D h0 h1 h2 h3.
+  (* backtracking *)
+  (apply h0 + apply h1);apply h3.
+  Undo.
+  Fail ((apply h0+apply h2) || apply h1); apply h3.
+  (* interaction with || *)
+  ((apply h0+apply h1) || apply h2); apply h3.
+Qed.
\ No newline at end of file
diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v
index 05303f37..54cfa658 100644
--- a/test-suite/success/mutual_ind.v
+++ b/test-suite/success/mutual_ind.v
@@ -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/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v
new file mode 100644
index 00000000..059462fa
--- /dev/null
+++ b/test-suite/success/namedunivs.v
@@ -0,0 +1,102 @@
+(* Inductive paths {A} (x : A) : A -> Type := idpath : paths x x where "x = y" := (@paths _ x y) : type_scope. *)
+(* Goal forall A B : Set, @paths Type A B -> @paths Set A B. *)
+(*   intros A B H. *)
+(* Fail  exact H. *)
+(* Section . *)
+
+Section lift_strict.
+Polymorphic Definition liftlt := 
+  let t := Type@{i} : Type@{k} in
+  fun A : Type@{i} => A : Type@{k}.
+
+Polymorphic Definition liftle := 
+  fun A : Type@{i} => A : Type@{k}.
+End lift_strict.
+
+
+Set Universe Polymorphism.
+
+(* Inductive option (A : Type) : Type := *)
+(*   | None : option A *)
+(*   | Some : A -> option A. *)
+
+Inductive option (A : Type@{i}) : Type@{i} :=
+  | None : option A
+  | Some : A -> option A.
+
+Definition foo' {A : Type@{i}} (o : option@{i} A) : option@{i} A :=
+  o.
+
+Definition foo'' {A : Type@{i}} (o : option@{j} A) : option@{k} A :=
+  o.
+
+
+Definition testm (A : Type@{i}) : Type@{max(i,j)} := A.
+
+(* Inductive prod (A : Type@{i}) (B : Type@{j}) := *)
+(*   | pair : A -> B -> prod A B. *)
+
+(* Definition snd {A : Type@{i}} (B : Type@{j}) (p : prod A B) : B := *)
+(*   match p with *)
+(*     | pair _ _ a b => b *)
+(*   end. *)
+
+(* Definition snd' {A : Type@{i}} (B : Type@{i}) (p : prod A B) : B := *)
+(*   match p with *)
+(*     | pair _ _ a b => b *)
+(*   end. *)
+
+(* Inductive paths {A : Type} : A -> A -> Type := *)
+(* | idpath (a : A) : paths a a. *)
+
+Inductive paths {A : Type@{i}} : A -> A -> Type@{i} :=
+| idpath (a : A) : paths a a.
+
+Definition Funext := 
+  forall (A : Type) (B : A -> Type),
+  forall f g : (forall a, B a), (forall x : A, paths (f x) (g x)) -> paths f g.
+
+Definition paths_lift_closed (A : Type@{i}) (x y : A) :
+  paths x y -> @paths (liftle@{j Type} A) x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition paths_lift (A : Type@{i}) (x y : A) :
+  paths x y -> paths@{j} x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition paths_lift_closed_strict (A : Type@{i}) (x y : A) :
+  paths x y -> @paths (liftlt@{j Type} A) x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition paths_downward_closed_le (A : Type@{i}) (x y : A) :
+  paths@{j} (A:=liftle@{i j} A) x y -> paths@{i} x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition paths_downward_closed_lt (A : Type@{i}) (x y : A) :
+  @paths (liftlt@{j i} A) x y -> paths x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition paths_downward_closed_lt_nolift (A : Type@{i}) (x y : A) :
+  paths@{j} x y -> paths x y.
+Proof. 
+  intros. destruct X. exact (idpath _).
+Defined.
+
+Definition funext_downward_closed (F : Funext@{i' j' k'}) :
+  Funext@{i j k}. 
+Proof.
+  intros A B f g H. red in F.
+  pose (F A B f g (fun x => paths_lift _ _ _ (H x))).
+  apply paths_downward_closed_lt_nolift. apply p.
+Defined.
+
diff --git a/test-suite/success/paralleltac.v b/test-suite/success/paralleltac.v
new file mode 100644
index 00000000..94ff96ef
--- /dev/null
+++ b/test-suite/success/paralleltac.v
@@ -0,0 +1,46 @@
+Fixpoint fib n := match n with
+  | O => 1
+  | S m => match m with
+    | O => 1
+    | S o => fib o + fib m end end.
+Ltac sleep n :=
+  try (assert (fib n = S (fib n)) by reflexivity).
+(* Tune that depending on your PC *)
+Let time := 18.
+
+Axiom P : nat -> Prop.
+Axiom P_triv : Type -> forall x, P x.
+Ltac solve_P :=
+  match goal with |- P (S ?X) =>
+    sleep time; exact (P_triv Type _)
+  end.
+
+Lemma test_old x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x).
+Proof.
+repeat split.
+idtac "T1: linear".
+Time all: solve_P.
+Qed.
+
+Lemma test_ok x : P (S x) /\ P (S x) /\ P (S x) /\ P (S x).
+Proof.
+repeat split.
+idtac "T2: parallel".
+Time par: solve_P.
+Qed.
+
+Lemma test_fail x : P (S x) /\ P x /\ P (S x) /\ P (S x).
+Proof.
+repeat split.
+idtac "T3: linear failure".
+Fail Time all: solve_P.
+all: apply (P_triv Type).
+Qed.
+
+Lemma test_fail2 x : P (S x) /\ P x /\ P (S x) /\ P (S x).
+Proof.
+repeat split.
+idtac "T4: parallel failure".
+Fail Time par: solve_P.
+all: apply (P_triv Type).
+Qed.
diff --git a/test-suite/success/params_ind.v b/test-suite/success/params_ind.v
deleted file mode 100644
index 1bee31c8..00000000
--- a/test-suite/success/params_ind.v
+++ /dev/null
@@ -1,4 +0,0 @@
-Inductive list (A : Set) : Set :=
-  | nil : list A
-  | cons : A -> list (A -> A) -> list A.
-
diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v
index 56cab0f6..9167c9fc 100644
--- a/test-suite/success/polymorphism.v
+++ b/test-suite/success/polymorphism.v
@@ -1,12 +1,294 @@
+Module withoutpoly.
+
+Inductive empty :=. 
+
+Inductive emptyt : Type :=. 
+Inductive singleton : Type :=
+  single.
+Inductive singletoninfo : Type :=
+  singleinfo : unit -> singletoninfo.
+Inductive singletonset : Set :=
+  singleset.
+
+Inductive singletonnoninfo : Type :=
+  singlenoninfo : empty -> singletonnoninfo.
+
+Inductive singletoninfononinfo : Prop :=
+  singleinfononinfo : unit -> singletoninfononinfo.
+
+Inductive bool : Type := 
+  | true | false.
+
+Inductive smashedbool : Prop := 
+  | trueP | falseP.
+End withoutpoly.
+
+Set Universe Polymorphism.
+
+Inductive empty :=. 
+Inductive emptyt : Type :=. 
+Inductive singleton : Type :=
+  single.
+Inductive singletoninfo : Type :=
+  singleinfo : unit -> singletoninfo.
+Inductive singletonset : Set :=
+  singleset.
+
+Inductive singletonnoninfo : Type :=
+  singlenoninfo : empty -> singletonnoninfo.
+
+Inductive singletoninfononinfo : Prop :=
+  singleinfononinfo : unit -> singletoninfononinfo.
+
+Inductive bool : Type := 
+  | true | false.
+
+Inductive smashedbool : Prop := 
+  | trueP | falseP.
+
+Section foo.
+  Let T := Type.
+  Inductive polybool : T := 
+  | trueT | falseT.
+End foo.
+
+Inductive list (A: Type) : Type := 
+| nil : list A
+| cons : A -> list A -> list A.
+
+Module ftypSetSet.
+Inductive ftyp : Type :=
+  | Funit : ftyp 
+  | Ffun : list ftyp -> ftyp 
+  | Fref : area -> ftyp
+with area : Type := 
+  | Stored : ftyp -> area        
+.
+End ftypSetSet.
+
+
+Module ftypSetProp.
+Inductive ftyp : Type :=
+  | Funit : ftyp 
+  | Ffun : list ftyp -> ftyp 
+  | Fref : area -> ftyp
+with area : Type := 
+  | Stored : (* ftyp ->  *)area        
+.
+End ftypSetProp.
+
+Module ftypSetSetForced.
+Inductive ftyp : Type :=
+  | Funit : ftyp 
+  | Ffun : list ftyp -> ftyp 
+  | Fref : area -> ftyp
+with area : Set (* Type *) := 
+  | Stored : (* ftyp ->  *)area        
+.
+End ftypSetSetForced.
+
+Unset Universe Polymorphism.
+
+Set Printing Universes.  
+Module Easy.
+
+  Polymorphic Inductive prod (A : Type) (B : Type) : Type :=
+    pair : A -> B -> prod A B.
+  
+  Check prod nat nat.
+  Print Universes.
+
+
+  Polymorphic Inductive sum (A B:Type) : Type :=
+  | inl : A -> sum A B
+  | inr : B -> sum A B.
+  Print sum.
+  Check (sum nat nat).
+
+End Easy.
+
+Section Hierarchy.
+
+Definition Type3 := Type.
+Definition Type2 := Type : Type3.
+Definition Type1 := Type : Type2.
+
+Definition id1 := ((forall A : Type1, A) : Type2).
+Definition id2 := ((forall A : Type2, A) : Type3).
+Definition id1' := ((forall A : Type1, A) : Type3).
+Fail Definition id1impred := ((forall A : Type1, A) : Type1).
+
+End Hierarchy.
+
+Section structures.
+
+Record hypo : Type := mkhypo {
+   hypo_type : Type;
+   hypo_proof : hypo_type
+ }.
+
+Definition typehypo (A : Type) : hypo := {| hypo_proof := A |}.
+
+Polymorphic Record dyn : Type := 
+  mkdyn {
+      dyn_type : Type;
+      dyn_proof : dyn_type
+    }.
+
+Definition monotypedyn (A : Type) : dyn := {| dyn_proof := A |}.
+Polymorphic Definition typedyn (A : Type) : dyn := {| dyn_proof := A |}.
+
+Definition atypedyn : dyn := typedyn Type.
+
+Definition projdyn := dyn_type atypedyn.
+
+Definition nested := {| dyn_type := dyn; dyn_proof := atypedyn |}.
+
+Definition nested2 := {| dyn_type := dyn; dyn_proof := nested |}.
+
+Definition projnested2 := dyn_type nested2.
+
+Polymorphic Definition nest (d : dyn) := {| dyn_proof := d |}.
+
+Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d.
+
+End structures.
+
+Section cats.
+  Local Set Universe Polymorphism.
+  Require Import Utf8.
+  Definition fibration (A : Type) := A -> Type.
+  Definition Hom (A : Type) := A -> A -> Type.
+
+  Record sigma (A : Type) (P : fibration A) :=
+    { proj1 : A; proj2 : P proj1} .
+
+  Class Identity {A} (M : Hom A) :=
+    identity : ∀ x, M x x.
+  
+  Class Inverse {A} (M : Hom A) :=
+    inverse : ∀ x y:A, M x y -> M y x.
+  
+  Class Composition {A} (M : Hom A) :=
+    composition : ∀ {x y z:A}, M x y -> M y z -> M x z.
+  
+  Notation  "g ° f" := (composition f g) (at level 50). 
+  
+  Class Equivalence T (Eq : Hom T):= 
+    {
+      Equivalence_Identity :> Identity Eq ;
+      Equivalence_Inverse :> Inverse Eq ;
+      Equivalence_Composition :> Composition Eq 
+    }.
+
+  Class EquivalenceType (T : Type) : Type := 
+    {
+      m2: Hom T;
+      equiv_struct :> Equivalence T m2 }.
+  
+  Polymorphic Record cat (T : Type) := 
+    { cat_hom : Hom T;
+      cat_equiv : forall x y, EquivalenceType (cat_hom x y) }.
+
+  Definition catType := sigma Type cat.
+
+  Notation "[ T ]" := (proj1 T).
+
+  Require Import Program.
+
+  Program Definition small_cat : cat Empty_set :=
+    {| cat_hom x y := unit |}.
+  Next Obligation. 
+    refine ({|m2:=fun x y => True|}). 
+    constructor; red; intros; trivial.
+  Defined.
+
+  Record iso (T U : Set) := 
+    { f : T -> U;
+      g : U -> T }.
+
+  Program Definition Set_cat : cat Set :=
+    {| cat_hom := iso |}.
+  Next Obligation. 
+    refine ({|m2:=fun x y => True|}). 
+    constructor; red; intros; trivial.
+  Defined.
+
+  Record isoT (T U : Type) := 
+    { isoT_f : T -> U;
+      isoT_g : U -> T }.
+
+  Program Definition Type_cat : cat Type :=
+    {| cat_hom := isoT |}.
+  Next Obligation. 
+    refine ({|m2:=fun x y => True|}). 
+    constructor; red; intros; trivial.
+  Defined.
+    
+  Polymorphic Record cat1 (T : Type) := 
+    { cat1_car : Type;
+      cat1_hom : Hom cat1_car;
+      cat1_hom_cat : forall x y, cat (cat1_hom x y) }.
+End cats.  
+
+Polymorphic Definition id {A : Type} (a : A) : A := a.
+
+Definition typeid := (@id Type).
+
+
+Fail Check (Prop : Set).
+Fail Check (Set : Set).
+Check (Set : Type).
+Check (Prop : Type).
+Definition setType := $(let t := type of Set in exact t)$.
+
+Definition foo (A : Prop) := A.
+
+Fail Check foo Set.
+Check fun A => foo A.
+Fail Check fun A : Type => foo A.
+Check fun A : Prop => foo A.
+Fail Definition bar := fun A : Set => foo A.
+
+Fail Check (let A := Type in foo (id A)).
+
+Definition fooS (A : Set) := A.
+
+Check (let A := nat in fooS (id A)).
+Fail Check (let A := Set in fooS (id A)).
+Fail Check (let A := Prop in fooS (id A)).
+
 (* Some tests of sort-polymorphisme *)
 Section S.
-Variable A:Type.
+Polymorphic Variable A:Type.
 (*
 Definition f (B:Type) := (A * B)%type.
 *)
-Inductive I (B:Type) : Type := prod : A->B->I B.
+Polymorphic Inductive I (B:Type) : Type := prod : A->B->I B.
+
+Check I nat.
+
 End S.
 (*
 Check f nat nat : Set.
 *)
-Check I nat nat : Set.
\ No newline at end of file
+Definition foo' := I nat nat.
+Print Universes. Print foo. Set Printing Universes. Print foo.
+
+(* Polymorphic axioms: *)
+Polymorphic Axiom funext : forall (A B : Type) (f g : A -> B), 
+                 (forall x, f x = g x) -> f = g.
+
+(* Check @funext. *)
+(* Check funext. *)
+
+Polymorphic Definition fun_ext (A B : Type) := 
+  forall (f g : A -> B), 
+    (forall x, f x = g x) -> f = g.
+
+Polymorphic Class Funext A B := extensional : fun_ext A B.
+
+Section foo2. 
+  Context `{forall A B, Funext A B}.
+  Print Universes.
+End foo2.
diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v
new file mode 100644
index 00000000..068f8ac3
--- /dev/null
+++ b/test-suite/success/primitiveproj.v
@@ -0,0 +1,190 @@
+Set Primitive Projections.
+Set Record Elimination Schemes.
+Module Prim.
+
+Record F := { a : nat; b : a = a }.
+Record G (A : Type) := { c : A; d : F }.
+
+Check c.
+End Prim.
+Module Univ.
+Set Universe Polymorphism.
+Set Implicit Arguments.
+Record Foo (A : Type) := { foo : A }.
+
+Record G (A : Type) := { c : A; d : c = c; e : Foo A }.
+
+Definition Foon : Foo nat := {| foo := 0 |}.
+
+Definition Foonp : nat := Foon.(foo).
+
+Definition Gt : G nat := {| c:= 0; d:=eq_refl; e:= Foon |}.
+
+Check (Gt.(e)).
+
+Section bla.
+
+  Record bar := { baz : nat; def := 0; baz' : forall x, x = baz \/ x = def }.
+End bla.
+
+End Univ.
+
+Set Primitive Projections.
+Unset Elimination Schemes.
+Set Implicit Arguments.
+
+Check nat.
+
+(* Inductive X (U:Type) := Foo (k : nat) (x : X U).  *)
+(* Parameter x : X nat. *)
+(* Check x.(k). *)
+
+Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }.
+
+Parameter x:X nat.
+Check (a x : forall _ : @eq nat (k x) (k x), X nat).
+Check (b x : X nat).
+
+Inductive Y := { next : option Y }.
+
+Check _.(next) : option Y.
+Lemma eta_ind (y : Y) : y = Build_Y y.(next).
+Proof. reflexivity. Defined.
+
+Variable t : Y.
+
+Fixpoint yn (n : nat) (y : Y) : Y := 
+  match n with
+    | 0 => t
+    | S n => {| next := Some (yn n y) |}
+  end.
+
+Lemma eta_ind'  (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}.
+Proof. reflexivity. Defined.
+
+
+(* 
+  Rules for parsing and printing of primitive projections and their eta expansions.
+  If r : R A where R is a primitive record with implicit parameter A.
+  If p : forall {A} (r : R A) {A : Set}, list (A * B).
+*)
+
+Record R {A : Type} := { p : forall {X : Set}, A * X }.
+Arguments R : clear implicits.
+
+Record R' {A : Type} := { p' : forall X : Set, A * X }.
+Arguments R' : clear implicits.
+
+Unset Printing All.
+
+Parameter r : R nat.
+
+Check (r.(p)).
+Set Printing Projections.
+Check (r.(p)).
+Unset Printing Projections.
+Set Printing All.
+Check (r.(p)).
+Unset Printing All.
+  
+(* Check (r.(p)).
+   Elaborates to a primitive application, X arg implicit.
+   Of type nat * ?ex
+   No Printing All: p r
+   Set Printing Projections.: r.(p)
+   Printing All: r.(@p) ?ex
+ *)
+
+Check p r.
+Set Printing Projections.
+Check p r.
+Unset Printing Projections.
+Set Printing All.
+Check p r.
+Unset Printing All.
+
+Check p r (X:=nat).
+Set Printing Projections.
+Check p r (X:=nat).
+Unset Printing Projections.
+Set Printing All.
+Check p r (X:=nat).
+Unset Printing All.
+
+(* Same elaboration, printing for p r *)
+
+(** Explicit version of the primitive projection, under applied w.r.t implicit arguments
+      can be printed only using projection notation. r.(@p) *)
+Check r.(@p _). 
+Set Printing Projections.
+Check r.(@p _). 
+Unset Printing Projections.
+Set Printing All.
+Check r.(@p _).
+Unset Printing All.
+  
+(** Explicit version of the primitive projection, applied to its implicit arguments
+      can be printed using application notation r.(p), r.(@p) in fully explicit form *)
+Check r.(@p _) nat.
+Set Printing Projections.
+Check r.(@p _) nat. 
+Unset Printing Projections.
+Set Printing All.
+Check r.(@p _) nat.
+Unset Printing All.
+
+Parameter r' : R' nat.
+
+Check (r'.(p')).
+Set Printing Projections.
+Check (r'.(p')). 
+Unset Printing Projections.
+Set Printing All.
+Check (r'.(p')).
+Unset Printing All.
+  
+(* Check (r'.(p')).
+   Elaborates to a primitive application, X arg explicit.
+   Of type forall X : Set, nat * X
+   No Printing All: p' r'
+   Set Printing Projections.: r'.(p')
+   Printing All: r'.(@p')
+ *)
+
+Check p' r'.
+Set Printing Projections.
+Check p' r'.
+Unset Printing Projections.
+Set Printing All.
+Check p' r'.
+Unset Printing All.
+
+(* Same elaboration, printing for p r *)
+
+(** Explicit version of the primitive projection, under applied w.r.t implicit arguments
+      can be printed only using projection notation. r.(@p) *)
+Check r'.(@p' _). 
+Set Printing Projections.
+Check r'.(@p' _). 
+Unset Printing Projections.
+Set Printing All.
+Check r'.(@p' _).
+Unset Printing All.
+  
+(** Explicit version of the primitive projection, applied to its implicit arguments
+      can be printed only using projection notation r.(p), r.(@p) in fully explicit form *)
+Check p' r' nat. 
+Set Printing Projections.
+Check p' r' nat. 
+Unset Printing Projections.
+Set Printing All.
+Check p' r' nat. 
+Unset Printing All.
+
+Check (@p' nat).
+Check p'.
+Set Printing All.
+
+Check (@p' nat).
+Check p'.
+Unset Printing All.
diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v
index bf302df4..dbbd57ae 100644
--- a/test-suite/success/proof_using.v
+++ b/test-suite/success/proof_using.v
@@ -65,3 +65,56 @@ End S1.
 Check (deep 3 4 : 3 = 4).
 Check (deep2 3 4 : 3 = 4).
 
+
+Section P1.
+
+Variable x : nat.
+Variable y : nat.
+Variable z : nat.
+
+
+Collection TOTO := x y.
+
+Collection TITI := TOTO - x.
+
+Lemma t1 : True. Proof using TOTO. trivial. Qed.
+Lemma t2 : True. Proof using TITI. trivial. Qed.
+
+ Section P2.
+ Collection TOTO := x.
+ Lemma t3 : True. Proof using TOTO. trivial. Qed.
+ End P2.
+
+Lemma t4 : True. Proof using TOTO. trivial. Qed.
+
+End P1.
+
+Lemma t5 : True. Fail Proof using TOTO. trivial. Qed.
+
+Check (t1 1 2 : True).
+Check (t2 1 : True).
+Check (t3 1 : True).
+Check (t4 1 2 : True).
+
+
+Section T1.
+
+Variable x : nat.
+Hypothesis px : 1 = x.
+Let w := x + 1.
+
+Set Suggest Proof Using.
+
+Set Default Proof Using "Type".
+
+Lemma bla : 2 = w.
+Proof.
+admit.
+Qed.
+
+End T1.
+
+Check (bla 7 : 2 = 8).
+
+
+
diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v
index 4d743a6d..1e667884 100644
--- a/test-suite/success/refine.v
+++ b/test-suite/success/refine.v
@@ -62,14 +62,14 @@ Abort.
 Goal (forall n : nat, n = 0 -> Prop) -> Prop.
 intro P.
  refine (P _ _).
-reflexivity.
+2:reflexivity.
 Abort.
 
 (* Submitted by Jacek Chrzaszcz (bug #1102) *)
 
-(* le problème a été résolu ici par normalisation des evars présentes
-   dans les types d'evars, mais le problème reste a priori ouvert dans
-   le cas plus général d'evars non instanciées dans les types d'autres
+(* le problème a été résolu ici par normalisation des evars présentes
+   dans les types d'evars, mais le problème reste a priori ouvert dans
+   le cas plus général d'evars non instanciées dans les types d'autres
    evars *)
 
 Goal exists n:nat, n=n.
@@ -84,7 +84,7 @@ Definition div :
 refine
   (fun m div_rec n =>
      match div_rec m n with
-     | exist _ _ => _
+     | exist _ _ _ => _
      end).
 Abort.
 
diff --git a/test-suite/success/rewrite.v b/test-suite/success/rewrite.v
index 08c406be..6dcd6592 100644
--- a/test-suite/success/rewrite.v
+++ b/test-suite/success/rewrite.v
@@ -129,3 +129,22 @@ intros.
 Fail rewrite H in H0.
 Abort.
 
+(* Test subst in the presence of a dependent let-in *)
+(* Was not working prior to May 2014 *)
+
+Goal forall x y, x=y+0 -> let z := x+1 in x+1=y -> z=z -> z=x.
+intros.
+subst x. (* was failing *)
+subst z. 
+rewrite H0.
+auto with arith.
+Qed.
+
+(* Check that evars are instantiated when the term to rewrite is
+   closed, like in the case it is open *)
+
+Goal exists x, S 0 = 0 -> S x = 0.
+eexists. intro H.
+rewrite H.
+reflexivity.
+Abort.
diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v
new file mode 100644
index 00000000..fe250ae8
--- /dev/null
+++ b/test-suite/success/rewrite_dep.v
@@ -0,0 +1,33 @@
+Require Import Setoid.
+Require Import Morphisms.
+Require Vector.
+Notation vector := Vector.t.
+Notation Vcons n t := (@Vector.cons _ n _ t). 
+
+Class Equiv A := equiv : A -> A -> Prop.
+Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv).
+
+Instance vecequiv A `{Equiv A} n : Equiv (vector A n).
+admit.
+Qed.
+
+Global Instance vcons_proper A `{Equiv A} `{!Setoid A} :
+ Proper (equiv ==> forall_relation (fun k => equiv ==> equiv))
+        (@Vector.cons A).
+Proof. Admitted.
+
+Instance vecseotid A `{Setoid A} n : Setoid (vector A n).
+Proof. Admitted.
+
+(* Instance equiv_setoid A {e : Equiv A} {s : @Setoid A e} : Equivalence e. *)
+(* apply setoid_equiv. *)
+(* Qed. *)
+(* Typeclasses Transparent Equiv. *)
+
+Goal forall A `{Equiv A} `{!Setoid A} (f : A -> A) (a b : A) (H : equiv a b) n (v : vector A n), 
+       equiv (Vcons a v) (Vcons b v).
+Proof.
+  intros.
+  rewrite H0.
+  reflexivity.
+Qed.
\ No newline at end of file
diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v
new file mode 100644
index 00000000..04c67556
--- /dev/null
+++ b/test-suite/success/rewrite_strat.v
@@ -0,0 +1,53 @@
+Require Import Setoid. 
+
+Variable X : Set.
+
+Variable f : X -> X.
+Variable g : X -> X -> X.
+Variable h : nat -> X -> X.
+
+Variable lem0 : forall x, f (f x) = f x.
+Variable lem1 : forall x, g x x = f x.
+Variable lem2 : forall n x, h (S n) x = g (h n x) (h n x).
+Variable lem3 : forall x, h 0 x = x.
+
+Hint Rewrite lem0 lem1 lem2 lem3 : rew.
+
+Goal forall x, h 10 x = f x.
+Proof. 
+  intros.
+  Time autorewrite with rew. (* 0.586 *)
+  reflexivity.
+Time Qed. (* 0.53 *)
+
+Goal forall x, h 6 x = f x.
+intros.
+  Time rewrite_strat topdown lem2.
+  Time rewrite_strat topdown lem1.
+  Time rewrite_strat topdown lem0.
+  Time rewrite_strat topdown lem3.
+  reflexivity.
+Undo 5.
+  Time rewrite_strat topdown (choice lem2 lem1).
+  Time rewrite_strat topdown (choice lem0 lem3).
+  reflexivity.
+Undo 3. 
+  Time rewrite_strat (topdown (choice lem2 lem1); topdown (choice lem0 lem3)).
+  reflexivity.
+Undo 2.
+  Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))). 
+  reflexivity.  
+Undo 2.
+  Time rewrite_strat (topdown (choice lem2 (choice lem1 (choice lem0 lem3)))).
+  reflexivity.
+Qed.
+
+Goal forall x, h 10 x = f x.
+Proof. 
+  intros.
+  Time rewrite_strat topdown (hints rew). (* 0.38 *)
+  reflexivity.
+Time Qed. (* 0.06 s *)
+
+Set Printing All.
+Set Printing Depth 100000.
\ No newline at end of file
diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v
index 653b5bf9..be0d49e0 100644
--- a/test-suite/success/setoid_test.v
+++ b/test-suite/success/setoid_test.v
@@ -153,7 +153,7 @@ End mult.
    does not fix the instance at the first unification, use [at], or simply rewrite for 
    this semantics. *)
 
-Require Import Arith.
+Parameter beq_nat : forall x y : nat, bool.
 
 Class Foo (A : Type) := {foo_neg : A -> A ; foo_prf : forall x : A, x = foo_neg x}.
 Instance: Foo nat. admit. Defined.
diff --git a/test-suite/success/setoid_unif.v b/test-suite/success/setoid_unif.v
new file mode 100644
index 00000000..912596b4
--- /dev/null
+++ b/test-suite/success/setoid_unif.v
@@ -0,0 +1,27 @@
+(* An example of unification in rewrite which uses eager substitution
+   of metas (provided by Pierre-Marie).
+
+   Put in the test suite as an indication of what the use metas
+   eagerly flag provides, even though the concrete cases that use it
+   are seldom. Today supported thanks to a new flag for using evars
+   eagerly, after this variant of setoid rewrite started to use clause
+   environments based on evars (fbbe491cfa157da627) *)
+
+Require Import Setoid.
+
+Parameter elt : Type.
+Parameter T : Type -> Type.
+Parameter empty : forall A, T A.
+Parameter MapsTo : forall A : Type, elt -> A -> T A -> Prop.
+
+(* Definition In A x t := exists e, MapsTo A x e t. *)
+Axiom In : forall A, A -> T A -> Prop.
+Axiom foo : forall A x, In A x (empty A) <-> False.
+
+Record R := { t : T unit; s : unit }.
+Definition Empty := {| t := empty unit; s := tt |}.
+
+Goal forall x, ~ In _ x (t Empty).
+Proof.
+intros x.
+rewrite foo.
diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v
index 271e6ef7..b5330779 100644
--- a/test-suite/success/simpl.v
+++ b/test-suite/success/simpl.v
@@ -45,3 +45,55 @@ Goal forall A B (a:A) l f (i:B), fold_right f i ((a :: l))=i.
 simpl.
 admit.
 Qed. (* Qed will fail if simplification is incorrect (de Bruijn!) *)
+
+(* Check that maximally inserted arguments do not break interpretation
+   of references in simpl, vm_compute etc. *)
+
+Arguments fst {A} {B} p.
+
+Goal fst (0,0) = 0.
+simpl fst.
+Fail set (fst _).
+Abort.
+
+Goal fst (0,0) = 0.
+vm_compute fst.
+Fail set (fst _).
+Abort.
+
+Goal let f x := x + 0 in f 0 = 0.
+intro.
+vm_compute f.
+Fail set (f _).
+Abort.
+
+(* This is a change wrt 8.4 (waiting to know if it breaks script a lot or not)*)
+
+Goal 0+0=0.
+Fail simpl @eq.
+Abort.
+
+(* Check reference by notation in simpl *)
+
+Goal 0+0 = 0.
+simpl "+".
+Fail set (_ + _).
+Abort.
+
+(* Check occurrences *)
+
+Record box A := Box { unbox : A }.
+
+Goal unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) =
+     unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))).
+simpl (unbox _ (unbox _ _)) at 1.
+match goal with |- True = unbox _ (unbox _ (unbox _ (Box _ (Box _ (Box _ True))))) => idtac end.
+Undo 2.
+Fail simpl (unbox _ (unbox _ _)) at 5.
+simpl (unbox _ (unbox _ _)) at 1 4.
+match goal with |- True = unbox _ (Box _ True) => idtac end.
+Undo 2.
+Fail simpl (unbox _ (unbox _ _)) at 3 4. (* Nested and even overlapping *)
+simpl (unbox _ (unbox _ _)) at 2 4.
+match goal with |- unbox _ (Box _ True) = unbox _ (Box _ True) => idtac end.
+Abort.
diff --git a/test-suite/success/somatching.v b/test-suite/success/somatching.v
new file mode 100644
index 00000000..5ed833ec
--- /dev/null
+++ b/test-suite/success/somatching.v
@@ -0,0 +1,64 @@
+Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True.
+Proof.
+  intros A B C p x y.
+  match type of p with
+    | forall x y, @?F x y => pose F as C1
+  end.
+  match type of p with
+    | forall x y, @?F y x => pose F as C2
+  end.
+  assert (C1 x y) as ?.
+  assert (C2 y x) as ?.
+Abort.
+
+Goal forall A B C D (p : forall (x : A) (y : B) (z : C), D x y) (x : A) (y : B), True.
+Proof.
+  intros A B C D p x y.
+  match type of p with
+    | forall x y z, @?F x y => pose F as C1
+  end.
+  assert (C1 x y) as ?.
+Abort.
+
+Goal forall A B C D (p : forall (z : C) (x : A) (y : B), D x y) (x : A) (y : B), True.
+Proof.
+  intros A B C D p x y.
+  match type of p with
+    | forall z x y, @?F x y => pose F as C1
+  end.
+  assert (C1 x y) as ?.
+Abort.
+
+(** Those should fail *)
+
+Goal forall A B C (p : forall (x : A) (y : B), C x y) (x : A) (y : B), True.
+Proof.
+  intros A B C p x y.
+  Fail match type of p with
+    | forall x, @?F x y => pose F as C1
+  end.
+  Fail match type of p with
+    | forall x y, @?F x x y => pose F as C1
+  end.
+  Fail match type of p with
+    | forall x y, @?F x => pose F as C1
+  end.
+Abort.
+
+(** This one is badly typed *)
+
+Goal forall A (B : A -> Type) (C : forall x, B x -> Type), (forall x y, C x y) -> True.
+Proof.
+intros A B C p.
+Fail match type of p with
+| forall x y, @?F y x => idtac
+end.
+Abort.
+
+Goal forall A (B : A -> Type) (C : Type) (D : forall x, B x -> Type), (forall x (z : C) y, D x y) -> True.
+Proof.
+intros A B C D p.
+match type of p with
+| forall x z y, @?F x y => idtac
+end.
+Abort.
diff --git a/test-suite/success/unfold.v b/test-suite/success/unfold.v
index c067eb81..2954e255 100644
--- a/test-suite/success/unfold.v
+++ b/test-suite/success/unfold.v
@@ -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/test-suite/success/unicode_utf8.v b/test-suite/success/unicode_utf8.v
index 42e32ccc..50a65310 100644
--- a/test-suite/success/unicode_utf8.v
+++ b/test-suite/success/unicode_utf8.v
@@ -11,11 +11,12 @@ Parameter π : �.
 
 (** Check indices *)
 Definition test_indices : nat -> nat := fun x� => x�.
-Definition π₂ := snd.
+Definition π₂ := @snd.
 
 (** More unicode in identifiers *)
 Definition αβ_áà_�ב := 0.
 
+Notation "C 'áµ’áµ–'" := C (at level 30).
 
 (** UNICODE IN STRINGS *)
 
diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v
index 997dceb4..296686e1 100644
--- a/test-suite/success/unification.v
+++ b/test-suite/success/unification.v
@@ -1,3 +1,7 @@
+Let test_stack_unification_interaction_with_delta A
+  : (if negb _ then true else false) = if orb false (negb A) then true else false
+  := eq_refl.
+
 (* Test patterns unification *)
 
 Lemma l1 : (forall P, (exists x:nat, P x) -> False)
@@ -97,7 +101,7 @@ apply H.
 Qed.
 
 (* Feature deactivated in commit 14189 (see commit log)
-(* Test instanciation of evars by unification *)
+(* Test instantiation of evars by unification *)
 
 Goal (forall x, 0 + x = 0 -> True) -> True.
 intros; eapply H.
diff --git a/test-suite/success/univscompute.v b/test-suite/success/univscompute.v
new file mode 100644
index 00000000..1d60ab36
--- /dev/null
+++ b/test-suite/success/univscompute.v
@@ -0,0 +1,32 @@
+Set Universe Polymorphism.
+
+Polymorphic Definition id {A : Type} (a : A) := a.
+
+Eval vm_compute in id 1.
+
+Polymorphic Inductive ind (A : Type) := cons : A -> ind A.
+
+Eval vm_compute in ind unit.
+
+Check ind unit.
+
+Eval vm_compute in ind unit.
+
+Definition bar := Eval vm_compute in ind unit.
+Definition bar' := Eval vm_compute in id (cons _ tt).
+
+Definition bar'' := Eval native_compute in id 1.
+Definition bar''' := Eval native_compute in id (cons _ tt).
+
+Definition barty := Eval native_compute in id (cons _ Set).
+
+Definition one := @id.
+
+Monomorphic Definition sec := one.
+
+Eval native_compute in sec.
+Definition sec' := Eval native_compute in sec.
+Eval vm_compute in sec.
+Definition sec'' := Eval vm_compute in sec.
+
+
diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v
index 58668d03..6f37de65 100644
--- a/test-suite/typeclasses/NewSetoid.v
+++ b/test-suite/typeclasses/NewSetoid.v
@@ -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 @@
 
 (* Certified Haskell Prelude.
  * Author: Matthieu Sozeau
- * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
+ * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
  *              91405 Orsay, France *)
 
 Require Import Coq.Program.Program.
diff --git a/test-suite/typeclasses/backtrack.v b/test-suite/typeclasses/backtrack.v
new file mode 100644
index 00000000..fff740ed
--- /dev/null
+++ b/test-suite/typeclasses/backtrack.v
@@ -0,0 +1,84 @@
+(* Set Typeclasses Unique Instances *)
+(** This lets typeclass search assume that instance heads are unique,
+    so if one matches no other need to be tried,
+    avoiding backtracking (even in unique solutions mode) 
+    This is on a class-by-class basis.
+ *)
+
+(* Non unique *)
+Class B.
+Class A.
+Set Typeclasses Unique Instances.
+(* Unique *)
+Class D.
+Class C (A : Type) := c : A.
+
+Hint Mode C +.
+Fail Definition test := c.
+
+Unset Typeclasses Unique Instances.
+Instance : B -> D -> C nat := fun _ _ => 0.
+Instance : A -> D -> C nat := fun _ _ => 0.
+Instance : B -> C bool := fun _ => true.
+
+Instance : forall A, C A -> C (option A) := fun A _ => None.
+
+Set Typeclasses Debug.
+
+Set Typeclasses Unique Solutions.
+(** This forces typeclass resolution to fail if at least two solutions 
+   exist to a given set of constraints. This is a global setting.
+   For constraints involving assumed unique instances, it will not fail
+   if two such instances could apply, however it will fail if two different
+   instances of a unique class could apply.
+ *)
+Fail Definition foo (d d' : D) (b b' : B) (a' a'' : A) := c : nat.
+Definition foo (d d' : D) (b b' : B) (a' : A) := c : nat.
+
+Fail Definition foo' (b b' : B) := _ : B.
+Unset Typeclasses Unique Solutions.
+Definition foo' (b b' : B) := _ : B.
+
+Set Typeclasses Unique Solutions.
+Definition foo'' (d d' : D) := _ : D.
+
+(** Cut backtracking *)
+Module BacktrackGreenCut.
+  Unset Typeclasses Unique Solutions.
+  Class C (A : Type) := c : A.
+
+  Class D (A : Type) : Type := { c_of_d :> C A }.
+  
+  Instance D1 : D unit.
+  Admitted.
+  
+  Instance D2 : D unit.
+  Admitted.
+
+  (** Two instances of D unit, but when searching for [C unit], no 
+      backtracking on the second instance should be needed except
+      in dependent cases. Check by adding an unresolvable constraint.
+   *)
+
+  Variable f : D unit -> C bool -> True.
+  Fail Definition foo := f _ _. 
+  
+  Fail Definition foo' := let y := _ : D unit in let x := _ : C bool in f _ x. 
+  
+  Unset Typeclasses Strict Resolution.
+  Class Transitive (A : Type) := { trans : True }.
+  Class PreOrder (A : Type) := { preorder_trans :> Transitive A }.
+  Class PartialOrder (A : Type) := { partialorder_trans :> Transitive A }.
+  Class PartialOrder' (A : Type) := { partialorder_trans' :> Transitive A }.
+  
+  Instance: PreOrder nat. Admitted.
+  Instance: PartialOrder nat. Admitted.
+  
+  Class NoInst (A : Type) := {}.
+    
+  Variable foo : forall `{ T : Transitive nat } `{ NoInst (let x:=@trans _ T in nat) }, nat.
+  
+  Fail Definition bar := foo.
+
+
+End BacktrackGreenCut.
diff --git a/test-suite/typeclasses/deftwice.v b/test-suite/typeclasses/deftwice.v
new file mode 100644
index 00000000..439782c9
--- /dev/null
+++ b/test-suite/typeclasses/deftwice.v
@@ -0,0 +1,9 @@
+Class C (A : Type) := c : A -> Type.
+
+Record Inhab (A : Type) := { witness : A }. 
+
+Instance inhab_C : C Type := Inhab.
+
+Variable full : forall A (X : C A), forall x : A, c x.
+
+Definition truc {A : Type} : Inhab A := (full _ _ _).
\ No newline at end of file
diff --git a/test-suite/vio/seff.v b/test-suite/vio/seff.v
new file mode 100644
index 00000000..447e7798
--- /dev/null
+++ b/test-suite/vio/seff.v
@@ -0,0 +1,10 @@
+Inductive equal T (x : T) : T -> Type := Equal : equal T x x.
+
+Module bla.
+
+Lemma test n : equal nat n (n + n) -> equal nat (n + n + n) n.
+Proof using.
+intro H. rewrite <- H. rewrite <- H. exact (Equal nat n).
+Qed.
+
+End bla.
diff --git a/test-suite/vio/simple.v b/test-suite/vio/simple.v
new file mode 100644
index 00000000..407074c1
--- /dev/null
+++ b/test-suite/vio/simple.v
@@ -0,0 +1,2 @@
+Lemma simple : True.
+Proof using. trivial. Qed.
diff --git a/test-suite/vio/univ_constraints_statements.v b/test-suite/vio/univ_constraints_statements.v
new file mode 100644
index 00000000..bb6b9595
--- /dev/null
+++ b/test-suite/vio/univ_constraints_statements.v
@@ -0,0 +1,2 @@
+Lemma ssr_congr_arrow Plemma Pgoal : Plemma = Pgoal -> Plemma -> Pgoal.
+Proof using. intro H; rewrite H; trivial. Qed.
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
index 1ed22762..620a4201 100644
--- a/theories/Arith/Arith.v
+++ b/theories/Arith/Arith.v
@@ -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/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v
index 19803729..a99c4113 100644
--- a/theories/Arith/Arith_base.v
+++ b/theories/Arith/Arith_base.v
@@ -1,11 +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        *)
 (************************************************************************)
 
+Require Export PeanoNat.
+
 Require Export Le.
 Require Export Lt.
 Require Export Plus.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 3693bf22..06723541 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -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/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index 537ee5c3..f91f3340 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -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/theories/Arith/Compare.v b/theories/Arith/Compare.v
index e5c36cf4..400f2d81 100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -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/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index cdad6b35..a97cf6dc 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -1,15 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Le.
-Require Import Lt.
-Require Import Gt.
-Require Import Decidable.
+Require Import Le Lt Gt Decidable PeanoNat.
 
 Local Open Scope nat_scope.
 
@@ -29,31 +26,31 @@ Defined.
 
 Definition gt_eq_gt_dec n m : {m > n} + {n = m} + {n > m}.
 Proof.
-  intros; apply lt_eq_lt_dec; assumption.
+  now apply lt_eq_lt_dec.
 Defined.
 
 Definition le_lt_dec n m : {n <= m} + {m < n}.
 Proof.
   induction n in m |- *.
-  auto with arith.
-  destruct m.
-  auto with arith.
-  elim (IHn m); auto with arith.
+  - left; auto with arith.
+  - destruct m.
+    + right; auto with arith.
+    + elim (IHn m); [left|right]; auto with arith.
 Defined.
 
 Definition le_le_S_dec n m : {n <= m} + {S m <= n}.
 Proof.
-  intros; exact (le_lt_dec n m).
+  exact (le_lt_dec n m).
 Defined.
 
 Definition le_ge_dec n m : {n <= m} + {n >= m}.
 Proof.
-  intros; elim (le_lt_dec n m); auto with arith.
+  elim (le_lt_dec n m); auto with arith.
 Defined.
 
 Definition le_gt_dec n m : {n <= m} + {n > m}.
 Proof.
-  intros; exact (le_lt_dec n m).
+  exact (le_lt_dec n m).
 Defined.
 
 Definition le_lt_eq_dec n m : n <= m -> {n < m} + {n = m}.
@@ -62,162 +59,121 @@ Proof.
   intros; absurd (m < n); auto with arith.
 Defined.
 
-Theorem le_dec : forall n m, {n <= m} + {~ n <= m}.
+Theorem le_dec n m : {n <= m} + {~ n <= m}.
 Proof.
-  intros n m. destruct (le_gt_dec n m).
-   auto with arith.
-   right. apply gt_not_le. assumption.
+  destruct (le_gt_dec n m).
+  - now left.
+  - right. now apply gt_not_le.
 Defined.
 
-Theorem lt_dec : forall n m, {n < m} + {~ n < m}.
+Theorem lt_dec n m : {n < m} + {~ n < m}.
 Proof.
-  intros; apply le_dec.
+  apply le_dec.
 Defined.
 
-Theorem gt_dec : forall n m, {n > m} + {~ n > m}.
+Theorem gt_dec n m : {n > m} + {~ n > m}.
 Proof.
-  intros; apply lt_dec.
+  apply lt_dec.
 Defined.
 
-Theorem ge_dec : forall n m, {n >= m} + {~ n >= m}.
+Theorem ge_dec n m : {n >= m} + {~ n >= m}.
 Proof.
-  intros; apply le_dec.
+  apply le_dec.
 Defined.
 
 (** Proofs of decidability *)
 
-Theorem dec_le : forall n m, decidable (n <= m).
+Theorem dec_le n m : decidable (n <= m).
 Proof.
-  intros n m; destruct (le_dec n m); unfold decidable; auto.
+  apply Nat.le_decidable.
 Qed.
 
-Theorem dec_lt : forall n m, decidable (n < m).
+Theorem dec_lt n m : decidable (n < m).
 Proof.
-  intros; apply dec_le.
+  apply Nat.lt_decidable.
 Qed.
 
-Theorem dec_gt : forall n m, decidable (n > m).
+Theorem dec_gt n m : decidable (n > m).
 Proof.
-  intros; apply dec_lt.
+  apply Nat.lt_decidable.
 Qed.
 
-Theorem dec_ge : forall n m, decidable (n >= m).
+Theorem dec_ge n m : decidable (n >= m).
 Proof.
-  intros; apply dec_le.
+  apply Nat.le_decidable.
 Qed.
 
-Theorem not_eq : forall n m, n <> m -> n < m \/ m < n.
+Theorem not_eq n m : n <> m -> n < m \/ m < n.
 Proof.
-  intros x y H; elim (lt_eq_lt_dec x y);
-    [ intros H1; elim H1;
-      [ auto with arith | intros H2; absurd (x = y); assumption ]
-      | auto with arith ].
+  apply Nat.lt_gt_cases.
 Qed.
 
-
-Theorem not_le : forall n m, ~ n <= m -> n > m.
+Theorem not_le n m : ~ n <= m -> n > m.
 Proof.
-  intros x y H; elim (le_gt_dec x y);
-    [ intros H1; absurd (x <= y); assumption | trivial with arith ].
+  apply Nat.nle_gt.
 Qed.
 
-Theorem not_gt : forall n m, ~ n > m -> n <= m.
+Theorem not_gt n m : ~ n > m -> n <= m.
 Proof.
-  intros x y H; elim (le_gt_dec x y);
-    [ trivial with arith | intros H1; absurd (x > y); assumption ].
+  apply Nat.nlt_ge.
 Qed.
 
-Theorem not_ge : forall n m, ~ n >= m -> n < m.
+Theorem not_ge n m : ~ n >= m -> n < m.
 Proof.
-  intros x y H; exact (not_le y x H).
+  apply Nat.nle_gt.
 Qed.
 
-Theorem not_lt : forall n m, ~ n < m -> n >= m.
+Theorem not_lt n m : ~ n < m -> n >= m.
 Proof.
-  intros x y H; exact (not_gt y x H).
+  apply Nat.nlt_ge.
 Qed.
 
 
-(** A ternary comparison function in the spirit of [Z.compare]. *)
+(** A ternary comparison function in the spirit of [Z.compare].
+    See now [Nat.compare] and its properties.
+    In scope [nat_scope], the notation for [Nat.compare] is "?=" *)
 
-Fixpoint nat_compare n m :=
-  match n, m with
-   | O, O => Eq
-   | O, S _ => Lt
-   | S _, O => Gt
-   | S n', S m' => nat_compare n' m'
-  end.
+Notation nat_compare := Nat.compare (compat "8.4").
 
-Lemma nat_compare_S : forall n m, nat_compare (S n) (S m) = nat_compare n m.
-Proof.
- reflexivity.
-Qed.
+Notation nat_compare_spec := Nat.compare_spec (compat "8.4").
+Notation nat_compare_eq_iff := Nat.compare_eq_iff (compat "8.4").
+Notation nat_compare_S := Nat.compare_succ (compat "8.4").
 
-Lemma nat_compare_eq_iff : forall n m, nat_compare n m = Eq <-> n = m.
+Lemma nat_compare_lt n m : n<m <-> (n ?= m) = Lt.
 Proof.
-  induction n; destruct m; simpl; split; auto; try discriminate;
-   destruct (IHn m); auto.
+ symmetry. apply Nat.compare_lt_iff.
 Qed.
 
-Lemma nat_compare_eq : forall n m, nat_compare n m = Eq -> n = m.
+Lemma nat_compare_gt n m : n>m <-> (n ?= m) = Gt.
 Proof.
-  intros; apply -> nat_compare_eq_iff; auto.
+ symmetry. apply Nat.compare_gt_iff.
 Qed.
 
-Lemma nat_compare_lt : forall n m, n<m <-> nat_compare n m = Lt.
+Lemma nat_compare_le n m : n<=m <-> (n ?= m) <> Gt.
 Proof.
-  induction n; destruct m; simpl; split; auto with arith;
-   try solve [inversion 1].
-  destruct (IHn m); auto with arith.
-  destruct (IHn m); auto with arith.
+ symmetry. apply Nat.compare_le_iff.
 Qed.
 
-Lemma nat_compare_gt : forall n m, n>m <-> nat_compare n m = Gt.
+Lemma nat_compare_ge n m : n>=m <-> (n ?= m) <> Lt.
 Proof.
-  induction n; destruct m; simpl; split; auto with arith;
-   try solve [inversion 1].
-  destruct (IHn m); auto with arith.
-  destruct (IHn m); auto with arith.
+ symmetry. apply Nat.compare_ge_iff.
 Qed.
 
-Lemma nat_compare_le : forall n m, n<=m <-> nat_compare n m <> Gt.
-Proof.
-  split.
-  intros LE; contradict LE.
-   apply lt_not_le. apply <- nat_compare_gt; auto.
-  intros NGT. apply not_lt. contradict NGT.
-   apply -> nat_compare_gt; auto.
-Qed.
-
-Lemma nat_compare_ge : forall n m, n>=m <-> nat_compare n m <> Lt.
-Proof.
-  split.
-  intros GE; contradict GE.
-   apply lt_not_le. apply <- nat_compare_lt; auto.
-  intros NLT. apply not_lt. contradict NLT.
-   apply -> nat_compare_lt; auto.
-Qed.
+(** Some projections of the above equivalences. *)
 
-Lemma nat_compare_spec :
-  forall x y, CompareSpec (x=y) (x<y) (y<x) (nat_compare x y).
+Lemma nat_compare_eq n m : (n ?= m) = Eq -> n = m.
 Proof.
- intros.
- destruct (nat_compare x y) eqn:?; constructor.
- apply nat_compare_eq; auto.
- apply <- nat_compare_lt; auto.
- apply <- nat_compare_gt; auto.
+  apply Nat.compare_eq_iff.
 Qed.
 
-(** Some projections of the above equivalences. *)
-
-Lemma nat_compare_Lt_lt : forall n m, nat_compare n m = Lt -> n<m.
+Lemma nat_compare_Lt_lt n m : (n ?= m) = Lt -> n<m.
 Proof.
-  intros; apply <- nat_compare_lt; auto.
+  apply Nat.compare_lt_iff.
 Qed.
 
-Lemma nat_compare_Gt_gt : forall n m, nat_compare n m = Gt -> n>m.
+Lemma nat_compare_Gt_gt n m : (n ?= m) = Gt -> n>m.
 Proof.
-  intros; apply <- nat_compare_gt; auto.
+  apply Nat.compare_gt_iff.
 Qed.
 
 (** A previous definition of [nat_compare] in terms of [lt_eq_lt_dec].
@@ -230,70 +186,48 @@ Definition nat_compare_alt (n m:nat) :=
     | inright _ => Gt
   end.
 
-Lemma nat_compare_equiv: forall n m,
- nat_compare n m = nat_compare_alt n m.
+Lemma nat_compare_equiv n m : (n ?= m) = nat_compare_alt n m.
 Proof.
-  intros; unfold nat_compare_alt; destruct lt_eq_lt_dec as [[LT|EQ]|GT].
-  apply -> nat_compare_lt; auto.
-  apply <- nat_compare_eq_iff; auto.
-  apply -> nat_compare_gt; auto.
+  unfold nat_compare_alt; destruct lt_eq_lt_dec as [[|]|].
+  - now apply Nat.compare_lt_iff.
+  - now apply Nat.compare_eq_iff.
+  - now apply Nat.compare_gt_iff.
 Qed.
 
+(** A boolean version of [le] over [nat].
+    See now [Nat.leb] and its properties.
+    In scope [nat_scope], the notation for [Nat.leb] is "<=?" *)
 
-(** A boolean version of [le] over [nat]. *)
-
-Fixpoint leb (m:nat) : nat -> bool :=
-  match m with
-    | O => fun _:nat => true
-    | S m' =>
-      fun n:nat => match n with
-                     | O => false
-                     | S n' => leb m' n'
-                   end
-  end.
+Notation leb := Nat.leb (compat "8.4").
 
-Lemma leb_correct : forall m n, m <= n -> leb m n = true.
-Proof.
-  induction m as [| m IHm]. trivial.
-  destruct n. intro H. elim (le_Sn_O _ H).
-  intros. simpl. apply IHm. apply le_S_n. assumption.
-Qed.
+Notation leb_iff := Nat.leb_le (compat "8.4").
 
-Lemma leb_complete : forall m n, leb m n = true -> m <= n.
+Lemma leb_iff_conv m n : (n <=? m) = false <-> m < n.
 Proof.
-  induction m. trivial with arith.
-  destruct n. intro H. discriminate H.
-  auto with arith.
+ rewrite Nat.leb_nle. apply Nat.nle_gt.
 Qed.
 
-Lemma leb_iff : forall m n, leb m n = true <-> m <= n.
+Lemma leb_correct m n : m <= n -> (m <=? n) = true.
 Proof.
-  split; auto using leb_correct, leb_complete.
+ apply Nat.leb_le.
 Qed.
 
-Lemma leb_correct_conv : forall m n, m < n -> leb n m = false.
+Lemma leb_complete m n : (m <=? n) = true -> m <= n.
 Proof.
-  intros.
-  generalize (leb_complete n m).
-  destruct (leb n m); auto.
-  intros; elim (lt_not_le m n); auto.
+ apply Nat.leb_le.
 Qed.
 
-Lemma leb_complete_conv : forall m n, leb n m = false -> m < n.
+Lemma leb_correct_conv m n : m < n -> (n <=? m) = false.
 Proof.
-  intros m n EQ. apply not_le.
-  intro LE. apply leb_correct in LE. rewrite LE in EQ; discriminate.
+ apply leb_iff_conv.
 Qed.
 
-Lemma leb_iff_conv : forall m n, leb n m = false <-> m < n.
+Lemma leb_complete_conv m n : (n <=? m) = false -> m < n.
 Proof.
-  split; auto using leb_complete_conv, leb_correct_conv.
+ apply leb_iff_conv.
 Qed.
 
-Lemma leb_compare : forall n m, leb n m = true <-> nat_compare n m <> Gt.
+Lemma leb_compare n m : (n <=? m) = true <-> (n ?= m) <> Gt.
 Proof.
- split; intros.
- apply -> nat_compare_le. auto using leb_complete.
- apply leb_correct. apply <- nat_compare_le; auto.
+ rewrite Nat.compare_le_iff. apply Nat.leb_le.
 Qed.
-
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 45fddd72..1c65a192 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -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        *)
 (************************************************************************)
 
-Require Import Lt.
-Require Import Plus.
-Require Import Compare_dec.
-Require Import Even.
+(** Nota : this file is OBSOLETE, and left only for compatibility.
+    Please consider using [Nat.div2] directly, and results about it
+    (see file PeanoNat). *)
+
+Require Import PeanoNat Even.
 
 Local Open Scope nat_scope.
 
@@ -17,12 +18,7 @@ Implicit Type n : nat.
 
 (** Here we define [n/2] and prove some of its properties *)
 
-Fixpoint div2 n : nat :=
-  match n with
-  | O => 0
-  | S O => 0
-  | S (S n') => S (div2 n')
-  end.
+Notation div2 := Nat.div2 (compat "8.4").
 
 (** Since [div2] is recursively defined on [0], [1] and [(S (S n))], it is
     useful to prove the corresponding induction principle *)
@@ -31,53 +27,48 @@ Lemma ind_0_1_SS :
   forall P:nat -> Prop,
     P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n.
 Proof.
-  intros P H0 H1 Hn.
-  cut (forall n, P n /\ P (S n)).
-  intros H'n n. elim (H'n n). auto with arith.
-
-  induction n. auto with arith.
-  intros. elim IHn; auto with arith.
+  intros P H0 H1 H2.
+  fix 1.
+  destruct n as [|[|n]].
+  - exact H0.
+  - exact H1.
+  - apply H2, ind_0_1_SS.
 Qed.
 
 (** [0 <n  =>  n/2 < n] *)
 
-Lemma lt_div2 : forall n, 0 < n -> div2 n < n.
-Proof.
-  intro n. pattern n. apply ind_0_1_SS.
-  (* n = 0 *)
-  inversion 1.
-  (* n=1 *)
-  simpl; trivial.
-  (* n=S S n' *)
-  intro n'; case (zerop n').
-    intro n'_eq_0. rewrite n'_eq_0. auto with arith.
-    auto with arith.
-Qed.
+Lemma lt_div2 n : 0 < n -> div2 n < n.
+Proof. apply Nat.lt_div2. Qed.
 
 Hint Resolve lt_div2: arith.
 
 (** Properties related to the parity *)
 
-Lemma even_div2 : forall n, even n -> div2 n = div2 (S n)
-with odd_div2 : forall n, odd n -> S (div2 n) = div2 (S n).
+Lemma even_div2 n : even n -> div2 n = div2 (S n).
 Proof.
-  destruct n; intro H.
-    (* 0 *) trivial.
-    (* S n *) inversion_clear H. apply odd_div2 in H0 as <-. trivial.
-  destruct n; intro.
-    (* 0 *) inversion H.
-    (* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial.
+ rewrite Even.even_equiv. intros (p,->).
+ rewrite Nat.div2_succ_double. apply Nat.div2_double.
 Qed.
 
-Lemma div2_even n : div2 n = div2 (S n) -> even n
-with div2_odd n : S (div2 n) = div2 (S n) -> odd n.
+Lemma odd_div2 n : odd n -> S (div2 n) = div2 (S n).
 Proof.
-{ destruct n; intro H.
-  - constructor.
-  - constructor. apply div2_odd. rewrite H. trivial. }
-{ destruct n; intro H.
-  - discriminate.
-  - constructor. apply div2_even. injection H as <-. trivial. }
+ rewrite Even.odd_equiv. intros (p,->).
+ rewrite Nat.add_1_r, Nat.div2_succ_double.
+ simpl. f_equal. symmetry. apply Nat.div2_double.
+Qed.
+
+Lemma div2_even n : div2 n = div2 (S n) -> even n.
+Proof.
+ destruct (even_or_odd n) as [Ev|Od]; trivial.
+ apply odd_div2 in Od. rewrite <- Od. intro Od'.
+ elim (n_Sn _ Od').
+Qed.
+
+Lemma div2_odd n : S (div2 n) = div2 (S n) -> odd n.
+Proof.
+ destruct (even_or_odd n) as [Ev|Od]; trivial.
+ apply even_div2 in Ev. rewrite <- Ev. intro Ev'.
+ symmetry in Ev'. elim (n_Sn _ Ev').
 Qed.
 
 Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.
@@ -93,58 +84,52 @@ Qed.
 
 (** Properties related to the double ([2n]) *)
 
-Definition double n := n + n.
+Notation double := Nat.double (compat "8.4").
 
-Hint Unfold double: arith.
+Hint Unfold double Nat.double: arith.
 
-Lemma double_S : forall n, double (S n) = S (S (double n)).
+Lemma double_S n : double (S n) = S (S (double n)).
 Proof.
-  intro. unfold double. simpl. auto with arith.
+  apply Nat.add_succ_r.
 Qed.
 
-Lemma double_plus : forall n (m:nat), double (n + m) = double n + double m.
+Lemma double_plus n m : double (n + m) = double n + double m.
 Proof.
-  intros m n. unfold double.
-  do 2 rewrite plus_assoc_reverse. rewrite (plus_permute n).
-  reflexivity.
+  apply Nat.add_shuffle1.
 Qed.
 
 Hint Resolve double_S: arith.
 
-Lemma even_odd_double :
-  forall n,
-    (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
+Lemma even_odd_double n :
+  (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))).
 Proof.
-  intro n. pattern n. apply ind_0_1_SS.
-  (* n = 0 *)
-  split; split; auto with arith.
-  intro H. inversion H.
-  (* n = 1 *)
-  split; split; auto with arith.
-  intro H. inversion H. inversion H1.
-  (* n = (S (S n')) *)
-  intros. destruct H as ((IH1,IH2),(IH3,IH4)).
-  split; split.
-  intro H. inversion H. inversion H1.
-  simpl. rewrite (double_S (div2 n0)). auto with arith.
-  simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
-  intro H. inversion H. inversion H1.
-  simpl. rewrite (double_S (div2 n0)). auto with arith.
-  simpl. rewrite (double_S (div2 n0)). intro H. injection H. auto with arith.
+  revert n. fix 1. destruct n as [|[|n]].
+  - (* n = 0 *)
+    split; split; auto with arith. inversion 1.
+  - (* n = 1 *)
+    split; split; auto with arith. inversion_clear 1. inversion H0.
+  - (* n = (S (S n')) *)
+    destruct (even_odd_double n) as ((Ev,Ev'),(Od,Od')).
+    split; split; simpl div2; rewrite ?double_S.
+    + inversion_clear 1. inversion_clear H0. auto.
+    + injection 1. auto with arith.
+    + inversion_clear 1. inversion_clear H0. auto.
+    + injection 1. auto with arith.
 Qed.
+
 (** Specializations *)
 
-Lemma even_double : forall n, even n -> n = double (div2 n).
-Proof fun n => proj1 (proj1 (even_odd_double n)).
+Lemma even_double n : even n -> n = double (div2 n).
+Proof proj1 (proj1 (even_odd_double n)).
 
-Lemma double_even : forall n, n = double (div2 n) -> even n.
-Proof fun n => proj2 (proj1 (even_odd_double n)).
+Lemma double_even n : n = double (div2 n) -> even n.
+Proof proj2 (proj1 (even_odd_double n)).
 
-Lemma odd_double : forall n, odd n -> n = S (double (div2 n)).
-Proof fun n => proj1 (proj2 (even_odd_double n)).
+Lemma odd_double n : odd n -> n = S (double (div2 n)).
+Proof proj1 (proj2 (even_odd_double n)).
 
-Lemma double_odd : forall n, n = S (double (div2 n)) -> odd n.
-Proof fun n => proj2 (proj2 (even_odd_double n)).
+Lemma double_odd n : n = S (double (div2 n)) -> odd n.
+Proof proj2 (proj2 (even_odd_double n)).
 
 Hint Resolve even_double double_even odd_double double_odd: arith.
 
@@ -166,22 +151,8 @@ Defined.
 
 (** Doubling before dividing by two brings back to the initial number. *)
 
-Lemma div2_double : forall n:nat, div2 (2*n) = n.
-Proof.
-  induction n.
-  simpl; auto.
-  simpl.
-  replace (n+S(n+0)) with (S (2*n)).
-  f_equal; auto.
-  simpl; auto with arith.
-Qed.
+Lemma div2_double n : div2 (2*n) = n.
+Proof. apply Nat.div2_double. Qed.
 
-Lemma div2_double_plus_one : forall n:nat, div2 (S (2*n)) = n.
-Proof.
-  induction n.
-  simpl; auto.
-  simpl.
-  replace (n+S(n+0)) with (S (2*n)).
-  f_equal; auto.
-  simpl; auto with arith.
-Qed.
+Lemma div2_double_plus_one n : div2 (S (2*n)) = n.
+Proof. apply Nat.div2_succ_double. Qed.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index 597cd287..2771670e 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -1,16 +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        *)
 (************************************************************************)
 
-(** Equality on natural numbers *)
-
+Require Import PeanoNat.
 Local Open Scope nat_scope.
 
-Implicit Types m n x y : nat.
+(** Equality on natural numbers *)
 
 (** * Propositional equality  *)
 
@@ -22,28 +21,33 @@ Fixpoint eq_nat n m : Prop :=
     | S n1, S m1 => eq_nat n1 m1
   end.
 
-Theorem eq_nat_refl : forall n, eq_nat n n.
+Theorem eq_nat_refl n : eq_nat n n.
+Proof.
   induction n; simpl; auto.
 Qed.
 Hint Resolve eq_nat_refl: arith v62.
 
 (** [eq] restricted to [nat] and [eq_nat] are equivalent *)
 
-Lemma eq_eq_nat : forall n m, n = m -> eq_nat n m.
-  induction 1; trivial with arith.
+Theorem eq_nat_is_eq n m : eq_nat n m <-> n = m.
+Proof.
+  split.
+  - revert m; induction n; destruct m; simpl; contradiction || auto.
+  - intros <-; apply eq_nat_refl.
 Qed.
-Hint Immediate eq_eq_nat: arith v62.
 
-Lemma eq_nat_eq : forall n m, eq_nat n m -> n = m.
-  induction n; induction m; simpl; contradiction || auto with arith.
+Lemma eq_eq_nat n m : n = m -> eq_nat n m.
+Proof.
+ apply eq_nat_is_eq.
 Qed.
-Hint Immediate eq_nat_eq: arith v62.
 
-Theorem eq_nat_is_eq : forall n m, eq_nat n m <-> n = m.
+Lemma eq_nat_eq n m : eq_nat n m -> n = m.
 Proof.
-  split; auto with arith.
+ apply eq_nat_is_eq.
 Qed.
 
+Hint Immediate eq_eq_nat eq_nat_eq: arith v62.
+
 Theorem eq_nat_elim :
   forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m.
 Proof.
@@ -52,63 +56,47 @@ Qed.
 
 Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}.
 Proof.
-  induction n.
-  destruct m as [| n].
-  auto with arith.
-  intros; right; red; trivial with arith.
-  destruct m as [| n0].
-  right; red; auto with arith.
-  intros.
-  simpl.
-  apply IHn.
+  induction n; destruct m; simpl.
+  - left; trivial.
+  - right; intro; trivial.
+  - right; intro; trivial.
+  - apply IHn.
 Defined.
 
 
-(** * Boolean equality on [nat] *)
+(** * Boolean equality on [nat].
 
-Fixpoint beq_nat n m : bool :=
-  match n, m with
-    | O, O => true
-    | O, S _ => false
-    | S _, O => false
-    | S n1, S m1 => beq_nat n1 m1
-  end.
+   We reuse the one already defined in module [Nat].
+   In scope [nat_scope], the notation "=?" can be used. *)
 
-Lemma beq_nat_refl : forall n, true = beq_nat n n.
-Proof.
-  intro x; induction x; simpl; auto.
-Qed.
+Notation beq_nat := Nat.eqb (compat "8.4").
 
-Definition beq_nat_eq : forall x y, true = beq_nat x y -> x = y.
-Proof.
-  double induction x y; simpl.
-    reflexivity.
-    intros n H1 H2. discriminate H2.
-    intros n H1 H2. discriminate H2.
-    intros n H1 z H2 H3. case (H2 _ H3). reflexivity.
-Defined.
+Notation beq_nat_true_iff := Nat.eqb_eq (compat "8.4").
+Notation beq_nat_false_iff := Nat.eqb_neq (compat "8.4").
 
-Lemma beq_nat_true : forall x y, beq_nat x y = true -> x=y.
+Lemma beq_nat_refl n : true = (n =? n).
 Proof.
- induction x; destruct y; simpl; auto; intros; discriminate.
+ symmetry. apply Nat.eqb_refl.
 Qed.
 
-Lemma beq_nat_false : forall x y, beq_nat x y = false -> x<>y.
+Lemma beq_nat_true n m : (n =? m) = true -> n=m.
 Proof.
- induction x; destruct y; simpl; auto; intros; discriminate.
+ apply Nat.eqb_eq.
 Qed.
 
-Lemma beq_nat_true_iff : forall x y, beq_nat x y = true <-> x=y.
+Lemma beq_nat_false n m : (n =? m) = false -> n<>m.
 Proof.
- split. apply beq_nat_true.
- intros; subst; symmetry; apply beq_nat_refl.
+ apply Nat.eqb_neq.
 Qed.
 
-Lemma beq_nat_false_iff : forall x y, beq_nat x y = false <-> x<>y.
+(** TODO: is it really useful here to have a Defined ?
+    Otherwise we could use Nat.eqb_eq *)
+
+Definition beq_nat_eq : forall n m, true = (n =? m) -> n = m.
 Proof.
- intros x y.
- split. apply beq_nat_false.
- generalize (beq_nat_true_iff x y).
- destruct beq_nat; auto.
- intros IFF NEQ. elim NEQ. apply IFF; auto.
-Qed.
+  induction n; destruct m; simpl.
+  - reflexivity.
+  - discriminate.
+  - discriminate.
+  - intros H. case (IHn _ H). reflexivity.
+Defined.
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index 8748b726..eaacab02 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -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        *)
@@ -19,16 +19,12 @@ Inductive diveucl a b : Set :=
 
 Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
 Proof.
-  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
-  elim (le_gt_dec b n).
-  intro lebn.
-  elim (H0 (n - b)); auto with arith.
-  intros q r g e.
-  apply divex with (S q) r; simpl; auto with arith.
-  elim plus_assoc.
-  elim e; auto with arith.
-  intros gtbn.
-  apply divex with 0 n; simpl; auto with arith.
+  induction m as (m,H0) using gt_wf_rec.
+  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
+  destruct (H0 (m - n)) as (q,r,Hge0,Heq); auto with arith.
+  apply divex with (S q) r; trivial.
+  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
+  apply divex with 0 m; simpl; trivial.
 Defined.
 
 Lemma quotient :
@@ -36,17 +32,12 @@ Lemma quotient :
     n > 0 ->
     forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
 Proof.
-  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
-  elim (le_gt_dec b n).
-  intro lebn.
-  elim (H0 (n - b)); auto with arith.
-  intros q Hq; exists (S q).
-  elim Hq; intros r Hr.
-  exists r; simpl; elim Hr; intros.
-  elim plus_assoc.
-  elim H1; auto with arith.
-  intros gtbn.
-  exists 0; exists n; simpl; auto with arith.
+  induction m as (m,H0) using gt_wf_rec.
+  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
+  destruct (H0 (m - n)) as (q & Hq); auto with arith; exists (S q).
+  destruct Hq as (r & Heq & Hgt); exists r; split; trivial.
+  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
+  exists 0; exists m; simpl; auto with arith.
 Defined.
 
 Lemma modulo :
@@ -54,15 +45,10 @@ Lemma modulo :
     n > 0 ->
     forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
 Proof.
-  intros b H a; pattern a; apply gt_wf_rec; intros n H0.
-  elim (le_gt_dec b n).
-  intro lebn.
-  elim (H0 (n - b)); auto with arith.
-  intros r Hr; exists r.
-  elim Hr; intros q Hq.
-  elim Hq; intros; exists (S q); simpl.
-  elim plus_assoc.
-  elim H1; auto with arith.
-  intros gtbn.
-  exists n; exists 0; simpl; auto with arith.
+  induction m as (m,H0) using gt_wf_rec.
+  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
+  destruct (H0 (m - n)) as (r & Hr); auto with arith; exists r.
+  destruct Hr as (q & Heq & Hgt); exists (S q); split; trivial.
+  simpl; rewrite <- plus_assoc, <- Heq; auto with arith.
+  exists m; exists 0; simpl; auto with arith.
 Defined.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index 1e175971..0f94a8ed 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -1,21 +1,27 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
+(** Nota : this file is OBSOLETE, and left only for compatibility.
+    Please consider instead predicates [Nat.Even] and [Nat.Odd]
+    and Boolean functions [Nat.even] and [Nat.odd]. *)
+
 (** Here we define the predicates [even] and [odd] by mutual induction
     and we prove the decidability and the exclusion of those predicates.
     The main results about parity are proved in the module Div2. *)
 
+Require Import PeanoNat.
+
 Local Open Scope nat_scope.
 
 Implicit Types m n : nat.
 
 
-(** * Definition of [even] and [odd], and basic facts *)
+(** * Inductive definition of [even] and [odd] *)
 
 Inductive even : nat -> Prop :=
   | even_O : even 0
@@ -26,225 +32,150 @@ with odd : nat -> Prop :=
 Hint Constructors even: arith.
 Hint Constructors odd: arith.
 
-Lemma even_or_odd : forall n, even n \/ odd n.
+(** * Equivalence with predicates [Nat.Even] and [Nat.odd] *)
+
+Lemma even_equiv : forall n, even n <-> Nat.Even n.
+Proof.
+ fix 1.
+ destruct n as [|[|n]]; simpl.
+ - split; [now exists 0 | constructor].
+ - split.
+   + inversion_clear 1. inversion_clear H0.
+   + now rewrite <- Nat.even_spec.
+ - rewrite Nat.Even_succ_succ, <- even_equiv.
+   split.
+   + inversion_clear 1. now inversion_clear H0.
+   + now do 2 constructor.
+Qed.
+
+Lemma odd_equiv : forall n, odd n <-> Nat.Odd n.
+Proof.
+ fix 1.
+ destruct n as [|[|n]]; simpl.
+ - split.
+   + inversion_clear 1.
+   + now rewrite <- Nat.odd_spec.
+ - split; [ now exists 0 | do 2 constructor ].
+ - rewrite Nat.Odd_succ_succ, <- odd_equiv.
+   split.
+   + inversion_clear 1. now inversion_clear H0.
+   + now do 2 constructor.
+Qed.
+
+(** Basic facts *)
+
+Lemma even_or_odd n : even n \/ odd n.
 Proof.
   induction n.
-    auto with arith.
-    elim IHn; auto with arith.
+  - auto with arith.
+  - elim IHn; auto with arith.
 Qed.
 
-Lemma even_odd_dec : forall n, {even n} + {odd n}.
+Lemma even_odd_dec n : {even n} + {odd n}.
 Proof.
   induction n.
-    auto with arith.
-    elim IHn; auto with arith.
+  - auto with arith.
+  - elim IHn; auto with arith.
 Defined.
 
-Lemma not_even_and_odd : forall n, even n -> odd n -> False.
+Lemma not_even_and_odd n : even n -> odd n -> False.
 Proof.
   induction n.
-    intros even_0 odd_0. inversion odd_0.
-    intros even_Sn odd_Sn. inversion even_Sn. inversion odd_Sn. auto with arith.
+  - intros Ev Od. inversion Od.
+  - intros Ev Od. inversion Ev. inversion Od. auto with arith.
 Qed.
 
 
 (** * Facts about [even] & [odd] wrt. [plus] *)
 
-Lemma even_plus_split : forall n m,
-  (even (n + m) -> even n /\ even m \/ odd n /\ odd m)
-with odd_plus_split : forall n m,
+Ltac parity2bool :=
+ rewrite ?even_equiv, ?odd_equiv, <- ?Nat.even_spec, <- ?Nat.odd_spec.
+
+Ltac parity_binop_spec :=
+ rewrite ?Nat.even_add, ?Nat.odd_add, ?Nat.even_mul, ?Nat.odd_mul.
+
+Ltac parity_binop :=
+ parity2bool; parity_binop_spec; unfold Nat.odd;
+ do 2 destruct Nat.even; simpl; tauto.
+
+
+Lemma even_plus_split n m :
+  even (n + m) -> even n /\ even m \/ odd n /\ odd m.
+Proof. parity_binop. Qed.
+
+Lemma odd_plus_split n m :
   odd (n + m) -> odd n /\ even m \/ even n /\ odd m.
-Proof.
-intros. clear even_plus_split. destruct n; simpl in *.
- auto with arith.
- inversion_clear H;
-   apply odd_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith.
-intros. clear odd_plus_split. destruct n; simpl in *.
- auto with arith.
- inversion_clear H;
-   apply even_plus_split in H0 as [(H0,?)|(H0,?)]; auto with arith.
-Qed.
+Proof. parity_binop. Qed.
 
-Lemma even_even_plus : forall n m, even n -> even m -> even (n + m)
-with odd_plus_l : forall n m, odd n -> even m -> odd (n + m).
-Proof.
-intros n m [|] ?. trivial. apply even_S, odd_plus_l; trivial.
-intros n m [] ?. apply odd_S, even_even_plus; trivial.
-Qed.
+Lemma even_even_plus n m : even n -> even m -> even (n + m).
+Proof. parity_binop. Qed.
 
-Lemma odd_plus_r : forall n m, even n -> odd m -> odd (n + m)
-with odd_even_plus : forall n m, odd n -> odd m -> even (n + m).
-Proof.
-intros n m [|] ?. trivial. apply odd_S, odd_even_plus; trivial.
-intros n m [] ?. apply even_S, odd_plus_r; trivial.
-Qed.
+Lemma odd_plus_l n m : odd n -> even m -> odd (n + m).
+Proof. parity_binop. Qed.
+
+Lemma odd_plus_r n m : even n -> odd m -> odd (n + m).
+Proof. parity_binop. Qed.
 
-Lemma even_plus_aux : forall n m,
+Lemma odd_even_plus n m : odd n -> odd m -> even (n + m).
+Proof. parity_binop. Qed.
+
+Lemma even_plus_aux n m :
     (odd (n + m) <-> odd n /\ even m \/ even n /\ odd m) /\
     (even (n + m) <-> even n /\ even m \/ odd n /\ odd m).
-Proof.
-split; split; auto using odd_plus_split, even_plus_split.
-intros [[]|[]]; auto using odd_plus_r, odd_plus_l.
-intros [[]|[]]; auto using even_even_plus, odd_even_plus.
-Qed.
+Proof. parity_binop. Qed.
 
-Lemma even_plus_even_inv_r : forall n m, even (n + m) -> even n -> even m.
-Proof.
-  intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd n); auto.
-Qed.
+Lemma even_plus_even_inv_r n m : even (n + m) -> even n -> even m.
+Proof. parity_binop. Qed.
 
-Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n.
-Proof.
-  intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd m); auto.
-Qed.
+Lemma even_plus_even_inv_l n m : even (n + m) -> even m -> even n.
+Proof. parity_binop. Qed.
 
-Lemma even_plus_odd_inv_r : forall n m, even (n + m) -> odd n -> odd m.
-Proof.
-  intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd n); auto.
-Qed.
+Lemma even_plus_odd_inv_r n m : even (n + m) -> odd n -> odd m.
+Proof. parity_binop. Qed.
 
-Lemma even_plus_odd_inv_l : forall n m, even (n + m) -> odd m -> odd n.
-Proof.
-  intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd m); auto.
-Qed.
-Hint Resolve even_even_plus odd_even_plus: arith.
+Lemma even_plus_odd_inv_l n m : even (n + m) -> odd m -> odd n.
+Proof. parity_binop. Qed.
 
-Lemma odd_plus_even_inv_l : forall n m, odd (n + m) -> odd m -> even n.
-Proof.
-  intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd m); auto.
-Qed.
+Lemma odd_plus_even_inv_l n m : odd (n + m) -> odd m -> even n.
+Proof. parity_binop. Qed.
 
-Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m.
-Proof.
-  intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd n); auto.
-Qed.
+Lemma odd_plus_even_inv_r n m : odd (n + m) -> odd n -> even m.
+Proof. parity_binop. Qed.
 
-Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n.
-Proof.
-  intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd m); auto.
-Qed.
+Lemma odd_plus_odd_inv_l n m : odd (n + m) -> even m -> odd n.
+Proof. parity_binop. Qed.
 
-Lemma odd_plus_odd_inv_r : forall n m, odd (n + m) -> even n -> odd m.
-Proof.
-  intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto.
-  intro; destruct (not_even_and_odd n); auto.
-Qed.
-Hint Resolve odd_plus_l odd_plus_r: arith.
+Lemma odd_plus_odd_inv_r n m : odd (n + m) -> even n -> odd m.
+Proof. parity_binop. Qed.
 
 
 (** * Facts about [even] and [odd] wrt. [mult] *)
 
-Lemma even_mult_aux :
-  forall n m,
-    (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
-Proof.
-  intros n; elim n; simpl; auto with arith.
-  intros m; split; split; auto with arith.
-  intros H'; inversion H'.
-  intros H'; elim H'; auto.
-  intros n0 H' m; split; split; auto with arith.
-  intros H'0.
-  elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'3; intros H'1 H'2;
-    case H'1; auto.
-  intros H'5; elim H'5; intros H'6 H'7; auto with arith.
-  split; auto with arith.
-  case (H' m).
-  intros H'8 H'9; case H'9.
-  intros H'10; case H'10; auto with arith.
-  intros H'11 H'12; case (not_even_and_odd m); auto with arith.
-  intros H'5; elim H'5; intros H'6 H'7; case (not_even_and_odd (n0 * m)); auto.
-  case (H' m).
-  intros H'8 H'9; case H'9; auto.
-  intros H'0; elim H'0; intros H'1 H'2; clear H'0.
-  elim (even_plus_aux m (n0 * m)); auto.
-  intros H'0 H'3.
-  elim H'0.
-  intros H'4 H'5; apply H'5; auto.
-  left; split; auto with arith.
-  case (H' m).
-  intros H'6 H'7; elim H'7.
-  intros H'8 H'9; apply H'9.
-  left.
-  inversion H'1; auto.
-  intros H'0.
-  elim (even_plus_aux m (n0 * m)); intros H'3 H'4; case H'4.
-  intros H'1 H'2.
-  elim H'1; auto.
-  intros H; case H; auto.
-  intros H'5; elim H'5; intros H'6 H'7; auto with arith.
-  left.
-  case (H' m).
-  intros H'8; elim H'8.
-  intros H'9; elim H'9; auto with arith.
-  intros H'0; elim H'0; intros H'1.
-  case (even_or_odd m); intros H'2.
-  apply even_even_plus; auto.
-  case (H' m).
-  intros H H0; case H0; auto.
-  apply odd_even_plus; auto.
-  inversion H'1; case (H' m); auto.
-  intros H1; case H1; auto.
-  apply even_even_plus; auto.
-  case (H' m).
-  intros H H0; case H0; auto.
-Qed.
+Lemma even_mult_aux n m :
+  (odd (n * m) <-> odd n /\ odd m) /\ (even (n * m) <-> even n \/ even m).
+Proof. parity_binop. Qed.
 
-Lemma even_mult_l : forall n m, even n -> even (n * m).
-Proof.
-  intros n m; case (even_mult_aux n m); auto.
-  intros H H0; case H0; auto.
-Qed.
+Lemma even_mult_l n m : even n -> even (n * m).
+Proof. parity_binop. Qed.
 
-Lemma even_mult_r : forall n m, even m -> even (n * m).
-Proof.
-  intros n m; case (even_mult_aux n m); auto.
-  intros H H0; case H0; auto.
-Qed.
-Hint Resolve even_mult_l even_mult_r: arith.
+Lemma even_mult_r n m : even m -> even (n * m).
+Proof. parity_binop. Qed.
 
-Lemma even_mult_inv_r : forall n m, even (n * m) -> odd n -> even m.
-Proof.
-  intros n m H' H'0.
-  case (even_mult_aux n m).
-  intros H'1 H'2; elim H'2.
-  intros H'3; elim H'3; auto.
-  intros H; case (not_even_and_odd n); auto.
-Qed.
+Lemma even_mult_inv_r n m : even (n * m) -> odd n -> even m.
+Proof. parity_binop. Qed.
 
-Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n.
-Proof.
-  intros n m H' H'0.
-  case (even_mult_aux n m).
-  intros H'1 H'2; elim H'2.
-  intros H'3; elim H'3; auto.
-  intros H; case (not_even_and_odd m); auto.
-Qed.
+Lemma even_mult_inv_l n m : even (n * m) -> odd m -> even n.
+Proof. parity_binop. Qed.
 
-Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m).
-Proof.
-  intros n m; case (even_mult_aux n m); intros H; case H; auto.
-Qed.
-Hint Resolve even_mult_l even_mult_r odd_mult: arith.
+Lemma odd_mult n m : odd n -> odd m -> odd (n * m).
+Proof. parity_binop. Qed.
 
-Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n.
-Proof.
-  intros n m H'.
-  case (even_mult_aux n m).
-  intros H'1 H'2; elim H'1.
-  intros H'3; elim H'3; auto.
-Qed.
+Lemma odd_mult_inv_l n m : odd (n * m) -> odd n.
+Proof. parity_binop. Qed.
 
-Lemma odd_mult_inv_r : forall n m, odd (n * m) -> odd m.
-Proof.
-  intros n m H'.
-  case (even_mult_aux n m).
-  intros H'1 H'2; elim H'1.
-  intros H'3; elim H'3; auto.
-Qed.
+Lemma odd_mult_inv_r n m : odd (n * m) -> odd m.
+Proof. parity_binop. Qed.
+
+Hint Resolve
+ even_even_plus odd_even_plus odd_plus_l odd_plus_r
+ even_mult_l even_mult_r even_mult_l even_mult_r odd_mult : arith.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index 870ea4e1..7d29f23c 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -1,14 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Plus.
-Require Import Mult.
-Require Import Lt.
+Require Import PeanoNat Plus Mult Lt.
 Local Open Scope nat_scope.
 
 (** Factorial *)
@@ -21,28 +19,19 @@ Fixpoint fact (n:nat) : nat :=
 
 Arguments fact n%nat.
 
-Lemma lt_O_fact : forall n:nat, 0 < fact n.
+Lemma lt_O_fact n : 0 < fact n.
 Proof.
-  simple induction n; unfold lt; simpl; auto with arith.
+  induction n; simpl; auto with arith.
 Qed.
 
-Lemma fact_neq_0 : forall n:nat, fact n <> 0.
+Lemma fact_neq_0 n : fact n <> 0.
 Proof.
-  intro.
-  apply not_eq_sym.
-  apply lt_O_neq.
-  apply lt_O_fact.
+ apply Nat.neq_0_lt_0, lt_O_fact.
 Qed.
 
-Lemma fact_le : forall n m:nat, n <= m -> fact n <= fact m.
+Lemma fact_le n m : n <= m -> fact n <= fact m.
 Proof.
   induction 1.
-  apply le_n.
-  assert (1 * fact n <= S m * fact m).
-  apply mult_le_compat.
-  apply lt_le_S; apply lt_O_Sn.
-  assumption.
-  simpl (1 * fact n) in H0.
-  rewrite <- plus_n_O in H0.
-  assumption.
+  - apply le_n.
+  - simpl. transitivity (fact m). trivial. apply Nat.le_add_r.
 Qed.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index afd146e7..e406ff0d 100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -1,154 +1,145 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
+(** Theorems about [gt] in [nat].
+
+ This file is DEPRECATED now, see module [PeanoNat.Nat] instead,
+ which favor [lt] over [gt].
+
+ [gt] is defined in [Init/Peano.v] as:
 <<
 Definition gt (n m:nat) := m < n.
 >>
 *)
 
-Require Import Le.
-Require Import Lt.
-Require Import Plus.
+Require Import PeanoNat Le Lt Plus.
 Local Open Scope nat_scope.
 
-Implicit Types m n p : nat.
-
 (** * Order and successor *)
 
-Theorem gt_Sn_O : forall n, S n > 0.
-Proof.
-  auto with arith.
-Qed.
-Hint Resolve gt_Sn_O: arith v62.
+Theorem gt_Sn_O n : S n > 0.
+Proof Nat.lt_0_succ _.
 
-Theorem gt_Sn_n : forall n, S n > n.
-Proof.
-  auto with arith.
-Qed.
-Hint Resolve gt_Sn_n: arith v62.
+Theorem gt_Sn_n n : S n > n.
+Proof Nat.lt_succ_diag_r _.
 
-Theorem gt_n_S : forall n m, n > m -> S n > S m.
+Theorem gt_n_S n m : n > m -> S n > S m.
 Proof.
-  auto with arith.
+ apply Nat.succ_lt_mono.
 Qed.
-Hint Resolve gt_n_S: arith v62.
 
-Lemma gt_S_n : forall n m, S m > S n -> m > n.
+Lemma gt_S_n n m : S m > S n -> m > n.
 Proof.
-  auto with arith.
+ apply Nat.succ_lt_mono.
 Qed.
-Hint Immediate gt_S_n: arith v62.
 
-Theorem gt_S : forall n m, S n > m -> n > m \/ m = n.
+Theorem gt_S n m : S n > m -> n > m \/ m = n.
 Proof.
-  intros n m H; unfold gt; apply le_lt_or_eq; auto with arith.
+ intro. now apply Nat.lt_eq_cases, Nat.succ_le_mono.
 Qed.
 
-Lemma gt_pred : forall n m, m > S n -> pred m > n.
+Lemma gt_pred n m : m > S n -> pred m > n.
 Proof.
-  auto with arith.
+ apply Nat.lt_succ_lt_pred.
 Qed.
-Hint Immediate gt_pred: arith v62.
 
 (** * Irreflexivity *)
 
-Lemma gt_irrefl : forall n, ~ n > n.
-Proof lt_irrefl.
-Hint Resolve gt_irrefl: arith v62.
+Lemma gt_irrefl n : ~ n > n.
+Proof Nat.lt_irrefl _.
 
 (** * Asymmetry *)
 
-Lemma gt_asym : forall n m, n > m -> ~ m > n.
-Proof fun n m => lt_asym m n.
-
-Hint Resolve gt_asym: arith v62.
+Lemma gt_asym n m : n > m -> ~ m > n.
+Proof Nat.lt_asymm _ _.
 
 (** * Relating strict and large orders *)
 
-Lemma le_not_gt : forall n m, n <= m -> ~ n > m.
-Proof le_not_lt.
-Hint Resolve le_not_gt: arith v62.
-
-Lemma gt_not_le : forall n m, n > m -> ~ n <= m.
+Lemma le_not_gt n m : n <= m -> ~ n > m.
 Proof.
-auto with arith.
+ apply Nat.le_ngt.
 Qed.
 
-Hint Resolve gt_not_le: arith v62.
+Lemma gt_not_le n m : n > m -> ~ n <= m.
+Proof.
+ apply Nat.lt_nge.
+Qed.
 
-Theorem le_S_gt : forall n m, S n <= m -> m > n.
+Theorem le_S_gt n m : S n <= m -> m > n.
 Proof.
-  auto with arith.
+ apply Nat.le_succ_l.
 Qed.
-Hint Immediate le_S_gt: arith v62.
 
-Lemma gt_S_le : forall n m, S m > n -> n <= m.
+Lemma gt_S_le n m : S m > n -> n <= m.
 Proof.
-  intros n p; exact (lt_n_Sm_le n p).
+ apply Nat.succ_le_mono.
 Qed.
-Hint Immediate gt_S_le: arith v62.
 
-Lemma gt_le_S : forall n m, m > n -> S n <= m.
+Lemma gt_le_S n m : m > n -> S n <= m.
 Proof.
-  auto with arith.
+ apply Nat.le_succ_l.
 Qed.
-Hint Resolve gt_le_S: arith v62.
 
-Lemma le_gt_S : forall n m, n <= m -> S m > n.
+Lemma le_gt_S n m : n <= m -> S m > n.
 Proof.
-  auto with arith.
+ apply Nat.succ_le_mono.
 Qed.
-Hint Resolve le_gt_S: arith v62.
 
 (** * Transitivity *)
 
-Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
+Theorem le_gt_trans n m p : m <= n -> m > p -> n > p.
 Proof.
-  red; intros; apply lt_le_trans with m; auto with arith.
+ intros. now apply Nat.lt_le_trans with m.
 Qed.
 
-Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p.
+Theorem gt_le_trans n m p : n > m -> p <= m -> n > p.
 Proof.
-  red; intros; apply le_lt_trans with m; auto with arith.
+ intros. now apply Nat.le_lt_trans with m.
 Qed.
 
-Lemma gt_trans : forall n m p, n > m -> m > p -> n > p.
+Lemma gt_trans n m p : n > m -> m > p -> n > p.
 Proof.
-  red; intros n m p H1 H2.
-  apply lt_trans with m; auto with arith.
+ intros. now apply Nat.lt_trans with m.
 Qed.
 
-Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p.
+Theorem gt_trans_S n m p : S n > m -> m > p -> n > p.
 Proof.
-  red; intros; apply lt_le_trans with m; auto with arith.
+ intros. apply Nat.lt_le_trans with m; trivial. now apply Nat.succ_le_mono.
 Qed.
 
-Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
-
 (** * Comparison to 0 *)
 
-Theorem gt_0_eq : forall n, n > 0 \/ 0 = n.
+Theorem gt_0_eq n : n > 0 \/ 0 = n.
 Proof.
-  intro n; apply gt_S; auto with arith.
+ destruct n; [now right | left; apply Nat.lt_0_succ].
 Qed.
 
 (** * Simplification and compatibility *)
 
-Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
+Lemma plus_gt_reg_l n m p : p + n > p + m -> n > m.
 Proof.
-  red; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
+ apply Nat.add_lt_mono_l.
 Qed.
 
-Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
+Lemma plus_gt_compat_l n m p : n > m -> p + n > p + m.
 Proof.
-  auto with arith.
+ apply Nat.add_lt_mono_l.
 Qed.
+
+(** * Hints *)
+
+Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith v62.
+Hint Immediate gt_S_n gt_pred : arith v62.
+Hint Resolve gt_irrefl gt_asym : arith v62.
+Hint Resolve le_not_gt gt_not_le : arith v62.
+Hint Immediate le_S_gt gt_S_le : arith v62.
+Hint Resolve gt_le_S le_gt_S : arith v62.
+Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.
 Hint Resolve plus_gt_compat_l: arith v62.
 
 (* begin hide *)
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index 6a3a583c..875863e4 100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -1,12 +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        *)
 (************************************************************************)
 
-(** Order on natural numbers. [le] is defined in [Init/Peano.v] as:
+(** Order on natural numbers.
+
+ This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.
+
+ [le] is defined in [Init/Peano.v] as:
 <<
 Inductive le (n:nat) : nat -> Prop :=
   | le_n : n <= n
@@ -14,110 +18,58 @@ Inductive le (n:nat) : nat -> Prop :=
 
 where "n <= m" := (le n m) : nat_scope.
 >>
- *)
+*)
 
-Local Open Scope nat_scope.
+Require Import PeanoNat.
 
-Implicit Types m n p : nat.
+Local Open Scope nat_scope.
 
-(** * [le] is a pre-order *)
+(** * [le] is an order on [nat] *)
 
-(** Reflexivity *)
-Theorem le_refl : forall n, n <= n.
-Proof.
-  exact le_n.
-Qed.
+Notation le_refl := Nat.le_refl (compat "8.4").
+Notation le_trans := Nat.le_trans (compat "8.4").
+Notation le_antisym := Nat.le_antisymm (compat "8.4").
 
-(** Transitivity *)
-Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
-Proof.
-  induction 2; auto.
-Qed.
 Hint Resolve le_trans: arith v62.
+Hint Immediate le_antisym: arith v62.
 
-(** * Properties of [le] w.r.t. successor, predecessor and 0 *)
-
-(** Comparison to 0 *)
-
-Theorem le_0_n : forall n, 0 <= n.
-Proof.
-  induction n; auto.
-Qed.
-
-Theorem le_Sn_0 : forall n, ~ S n <= 0.
-Proof.
-  red; intros n H.
-  change (IsSucc 0); elim H; simpl; auto with arith.
-Qed.
+(** * Properties of [le] w.r.t 0 *)
 
-Hint Resolve le_0_n le_Sn_0: arith v62.
+Notation le_0_n := Nat.le_0_l (compat "8.4").  (* 0 <= n *)
+Notation le_Sn_0 := Nat.nle_succ_0 (compat "8.4").  (* ~ S n <= 0 *)
 
-Theorem le_n_0_eq : forall n, n <= 0 -> 0 = n.
+Lemma le_n_0_eq n : n <= 0 -> 0 = n.
 Proof.
-  induction n; auto with arith.
-  intro; contradiction le_Sn_0 with n.
+ intros. symmetry. now apply Nat.le_0_r.
 Qed.
-Hint Immediate le_n_0_eq: arith v62.
 
+(** * Properties of [le] w.r.t successor *)
 
-(** [le] and successor *)
+(** See also [Nat.succ_le_mono]. *)
 
 Theorem le_n_S : forall n m, n <= m -> S n <= S m.
-Proof.
-  induction 1; auto.
-Qed.
+Proof Peano.le_n_S.
 
-Theorem le_n_Sn : forall n, n <= S n.
-Proof.
-  auto.
-Qed.
+Theorem le_S_n : forall n m, S n <= S m -> n <= m.
+Proof Peano.le_S_n.
 
-Hint Resolve le_n_S le_n_Sn : arith v62.
+Notation le_n_Sn := Nat.le_succ_diag_r (compat "8.4"). (* n <= S n *)
+Notation le_Sn_n := Nat.nle_succ_diag_l (compat "8.4"). (* ~ S n <= n *)
 
 Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
-Proof.
-  intros n m H; apply le_trans with (S n); auto with arith.
-Qed.
-Hint Immediate le_Sn_le: arith v62.
+Proof Nat.lt_le_incl.
 
-Theorem le_S_n : forall n m, S n <= S m -> n <= m.
-Proof.
-  exact Peano.le_S_n.
-Qed.
-Hint Immediate le_S_n: arith v62.
+Hint Resolve le_0_n le_Sn_0: arith v62.
+Hint Resolve le_n_S le_n_Sn le_Sn_n : arith v62.
+Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith v62.
 
-Theorem le_Sn_n : forall n, ~ S n <= n.
-Proof.
-  induction n; auto with arith.
-Qed.
-Hint Resolve le_Sn_n: arith v62.
+(** * Properties of [le] w.r.t predecessor *)
 
-(** [le] and predecessor *)
+Notation le_pred_n := Nat.le_pred_l (compat "8.4"). (* pred n <= n *)
+Notation le_pred := Nat.pred_le_mono (compat "8.4"). (* n<=m -> pred n <= pred m *)
 
-Theorem le_pred_n : forall n, pred n <= n.
-Proof.
-  induction n; auto with arith.
-Qed.
 Hint Resolve le_pred_n: arith v62.
 
-Theorem le_pred : forall n m, n <= m -> pred n <= pred m.
-Proof.
-  exact Peano.le_pred.
-Qed.
-
-(** * [le] is a order on [nat] *)
-(** Antisymmetry *)
-
-Theorem le_antisym : forall n m, n <= m -> m <= n -> n = m.
-Proof.
-  intros n m H; destruct H as [|m' H]; auto with arith.
-  intros H1.
-  absurd (S m' <= m'); auto with arith.
-  apply le_trans with n; auto with arith.
-Qed.
-Hint Immediate le_antisym: arith v62.
-
-
 (** * A different elimination principle for the order on natural numbers *)
 
 Lemma le_elim_rel :
@@ -126,10 +78,10 @@ Lemma le_elim_rel :
    (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) ->
    forall n m, n <= m -> P n m.
 Proof.
-  induction n; auto with arith.
-  intros m Le.
-  elim Le; auto with arith.
-Qed.
+  intros P H0 HS.
+  induction n; trivial.
+  intros m Le. elim Le; auto with arith.
+ Qed.
 
 (* begin hide *)
 Notation le_O_n := le_0_n (only parsing).
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index 3ce42a6e..b783ca33 100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -1,190 +1,154 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as:
+(** Strict order on natural numbers.
+
+ This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.
+
+ [lt] is defined in library [Init/Peano.v] as:
 <<
 Definition lt (n m:nat) := S n <= m.
 Infix "<" := lt : nat_scope.
 >>
 *)
 
-Require Import Le.
-Local Open Scope nat_scope.
+Require Import PeanoNat.
 
-Implicit Types m n p : nat.
+Local Open Scope nat_scope.
 
 (** * Irreflexivity *)
 
-Theorem lt_irrefl : forall n, ~ n < n.
-Proof le_Sn_n.
+Notation lt_irrefl := Nat.lt_irrefl (compat "8.4"). (* ~ x < x *)
+
 Hint Resolve lt_irrefl: arith v62.
 
 (** * Relationship between [le] and [lt] *)
 
-Theorem lt_le_S : forall n m, n < m -> S n <= m.
+Theorem lt_le_S n m : n < m -> S n <= m.
 Proof.
-  auto with arith.
+ apply Nat.le_succ_l.
 Qed.
-Hint Immediate lt_le_S: arith v62.
 
-Theorem lt_n_Sm_le : forall n m, n < S m -> n <= m.
+Theorem lt_n_Sm_le n m : n < S m -> n <= m.
 Proof.
-  auto with arith.
+ apply Nat.lt_succ_r.
 Qed.
-Hint Immediate lt_n_Sm_le: arith v62.
 
-Theorem le_lt_n_Sm : forall n m, n <= m -> n < S m.
+Theorem le_lt_n_Sm n m : n <= m -> n < S m.
 Proof.
-  auto with arith.
+ apply Nat.lt_succ_r.
 Qed.
+
+Hint Immediate lt_le_S: arith v62.
+Hint Immediate lt_n_Sm_le: arith v62.
 Hint Immediate le_lt_n_Sm: arith v62.
 
-Theorem le_not_lt : forall n m, n <= m -> ~ m < n.
+Theorem le_not_lt n m : n <= m -> ~ m < n.
 Proof.
-  induction 1; auto with arith.
+ apply Nat.le_ngt.
 Qed.
 
-Theorem lt_not_le : forall n m, n < m -> ~ m <= n.
+Theorem lt_not_le n m : n < m -> ~ m <= n.
 Proof.
-  red; intros n m Lt Le; exact (le_not_lt m n Le Lt).
+ apply Nat.lt_nge.
 Qed.
+
 Hint Immediate le_not_lt lt_not_le: arith v62.
 
 (** * Asymmetry *)
 
-Theorem lt_asym : forall n m, n < m -> ~ m < n.
-Proof.
-  induction 1; auto with arith.
-Qed.
+Notation lt_asym := Nat.lt_asymm (compat "8.4"). (* n<m -> ~m<n *)
 
-(** * Order and successor *)
+(** * Order and 0 *)
 
-Theorem lt_n_Sn : forall n, n < S n.
-Proof.
-  auto with arith.
-Qed.
-Hint Resolve lt_n_Sn: arith v62.
+Notation lt_0_Sn := Nat.lt_0_succ (compat "8.4"). (* 0 < S n *)
+Notation lt_n_0 := Nat.nlt_0_r (compat "8.4"). (* ~ n < 0 *)
 
-Theorem lt_S : forall n m, n < m -> n < S m.
+Theorem neq_0_lt n : 0 <> n -> 0 < n.
 Proof.
-  auto with arith.
+ intros. now apply Nat.neq_0_lt_0, Nat.neq_sym.
 Qed.
-Hint Resolve lt_S: arith v62.
 
-Theorem lt_n_S : forall n m, n < m -> S n < S m.
+Theorem lt_0_neq n : 0 < n -> 0 <> n.
 Proof.
-  auto with arith.
+ intros. now apply Nat.neq_sym, Nat.neq_0_lt_0.
 Qed.
-Hint Resolve lt_n_S: arith v62.
 
-Theorem lt_S_n : forall n m, S n < S m -> n < m.
+Hint Resolve lt_0_Sn lt_n_0 : arith v62.
+Hint Immediate neq_0_lt lt_0_neq: arith v62.
+
+(** * Order and successor *)
+
+Notation lt_n_Sn := Nat.lt_succ_diag_r (compat "8.4"). (* n < S n *)
+Notation lt_S := Nat.lt_lt_succ_r (compat "8.4"). (* n < m -> n < S m *)
+
+Theorem lt_n_S n m : n < m -> S n < S m.
 Proof.
-  auto with arith.
+ apply Nat.succ_lt_mono.
 Qed.
-Hint Immediate lt_S_n: arith v62.
 
-Theorem lt_0_Sn : forall n, 0 < S n.
+Theorem lt_S_n n m : S n < S m -> n < m.
 Proof.
-  auto with arith.
+ apply Nat.succ_lt_mono.
 Qed.
-Hint Resolve lt_0_Sn: arith v62.
 
-Theorem lt_n_0 : forall n, ~ n < 0.
-Proof le_Sn_0.
-Hint Resolve lt_n_0: arith v62.
+Hint Resolve lt_n_Sn lt_S lt_n_S : arith v62.
+Hint Immediate lt_S_n : arith v62.
 
 (** * Predecessor *)
 
-Lemma S_pred : forall n m, m < n -> n = S (pred n).
+Lemma S_pred n m : m < n -> n = S (pred n).
 Proof.
-induction 1; auto with arith.
+ intros. symmetry. now apply Nat.lt_succ_pred with m.
 Qed.
 
-Lemma lt_pred : forall n m, S n < m -> n < pred m.
+Lemma lt_pred n m : S n < m -> n < pred m.
 Proof.
-induction 1; simpl; auto with arith.
+ apply Nat.lt_succ_lt_pred.
 Qed.
-Hint Immediate lt_pred: arith v62.
 
-Lemma lt_pred_n_n : forall n, 0 < n -> pred n < n.
-destruct 1; simpl; auto with arith.
+Lemma lt_pred_n_n n : 0 < n -> pred n < n.
+Proof.
+ intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0.
 Qed.
+
+Hint Immediate lt_pred: arith v62.
 Hint Resolve lt_pred_n_n: arith v62.
 
 (** * Transitivity properties *)
 
-Theorem lt_trans : forall n m p, n < m -> m < p -> n < p.
-Proof.
-  induction 2; auto with arith.
-Qed.
-
-Theorem lt_le_trans : forall n m p, n < m -> m <= p -> n < p.
-Proof.
-  induction 2; auto with arith.
-Qed.
-
-Theorem le_lt_trans : forall n m p, n <= m -> m < p -> n < p.
-Proof.
-  induction 2; auto with arith.
-Qed.
+Notation lt_trans := Nat.lt_trans (compat "8.4").
+Notation lt_le_trans := Nat.lt_le_trans (compat "8.4").
+Notation le_lt_trans := Nat.le_lt_trans (compat "8.4").
 
 Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62.
 
 (** * Large = strict or equal *)
 
-Theorem le_lt_or_eq : forall n m, n <= m -> n < m \/ n = m.
-Proof.
-  induction 1; auto with arith.
-Qed.
+Notation le_lt_or_eq_iff := Nat.lt_eq_cases (compat "8.4").
 
-Theorem le_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
+Theorem le_lt_or_eq n m : n <= m -> n < m \/ n = m.
 Proof.
-  split.
-  intros; apply le_lt_or_eq; auto.
-  destruct 1; subst; auto with arith.
+ apply Nat.lt_eq_cases.
 Qed.
 
-Theorem lt_le_weak : forall n m, n < m -> n <= m.
-Proof.
-  auto with arith.
-Qed.
+Notation lt_le_weak := Nat.lt_le_incl (compat "8.4").
+
 Hint Immediate lt_le_weak: arith v62.
 
 (** * Dichotomy *)
 
-Theorem le_or_lt : forall n m, n <= m \/ m < n.
-Proof.
-  intros n m; pattern n, m; apply nat_double_ind; auto with arith.
-  induction 1; auto with arith.
-Qed.
-
-Theorem nat_total_order : forall n m, n <> m -> n < m \/ m < n.
-Proof.
-  intros m n diff.
-  elim (le_or_lt n m); [ intro H'0 | auto with arith ].
-  elim (le_lt_or_eq n m); auto with arith.
-  intro H'; elim diff; auto with arith.
-Qed.
-
-(** * Comparison to 0 *)
+Notation le_or_lt := Nat.le_gt_cases (compat "8.4"). (* n <= m \/ m < n *)
 
-Theorem neq_0_lt : forall n, 0 <> n -> 0 < n.
+Theorem nat_total_order n m : n <> m -> n < m \/ m < n.
 Proof.
-  induction n; auto with arith.
-  intros; absurd (0 = 0); trivial with arith.
+ apply Nat.lt_gt_cases.
 Qed.
-Hint Immediate neq_0_lt: arith v62.
-
-Theorem lt_0_neq : forall n, 0 < n -> 0 <> n.
-Proof.
-  induction 1; auto with arith.
-Qed.
-Hint Immediate lt_0_neq: arith v62.
 
 (* begin hide *)
 Notation lt_O_Sn := lt_0_Sn (only parsing).
@@ -192,3 +156,7 @@ Notation neq_O_lt := neq_0_lt (only parsing).
 Notation lt_O_neq := lt_0_neq (only parsing).
 Notation lt_n_O := lt_n_0 (only parsing).
 (* end hide *)
+
+(** For compatibility, we "Require" the same files as before *)
+
+Require Import Le.
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index 721428e5..26875373 100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -1,19 +1,19 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *)
+(** THIS FILE IS DEPRECATED. Use [PeanoNat.Nat] instead. *)
 
-Require Import NPeano.
+Require Import PeanoNat.
 
 Local Open Scope nat_scope.
 Implicit Types m n p : nat.
 
-Notation max := Peano.max (only parsing).
+Notation max := Nat.max (only parsing).
 
 Definition max_0_l := Nat.max_0_l.
 Definition max_0_r := Nat.max_0_r.
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
index 206ebc4b..f2fa3aec 100644
--- a/theories/Arith/Min.v
+++ b/theories/Arith/Min.v
@@ -1,19 +1,19 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *)
+(** THIS FILE IS DEPRECATED. Use [PeanoNat.Nat] instead. *)
 
-Require Import NPeano.
+Require Import PeanoNat.
 
 Local Open Scope nat_scope.
 Implicit Types m n p : nat.
 
-Notation min := Peano.min (only parsing).
+Notation min := Nat.min (only parsing).
 
 Definition min_0_l := Nat.min_0_l.
 Definition min_0_r := Nat.min_0_r.
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
index 9bfced44..6e312e4f 100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -1,156 +1,119 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as:
+(** Properties of subtraction between natural numbers.
+
+ This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.
+
+ [minus] is now an alias for [Nat.sub], which is defined in [Init/Nat.v] as:
 <<
-Fixpoint minus (n m:nat) : nat :=
+Fixpoint sub (n m:nat) : nat :=
   match n, m with
-  | O, _ => n
-  | S k, O => S k
   | S k, S l => k - l
+  | _, _ => n
   end
-where "n - m" := (minus n m) : nat_scope.
+where "n - m" := (sub n m) : nat_scope.
 >>
 *)
 
-Require Import Lt.
-Require Import Le.
+Require Import PeanoNat Lt Le.
 
 Local Open Scope nat_scope.
 
-Implicit Types m n p : nat.
-
 (** * 0 is right neutral *)
 
-Lemma minus_n_O : forall n, n = n - 0.
+Lemma minus_n_O n : n = n - 0.
 Proof.
-  induction n; simpl; auto with arith.
+ symmetry. apply Nat.sub_0_r.
 Qed.
-Hint Resolve minus_n_O: arith v62.
 
 (** * Permutation with successor *)
 
-Lemma minus_Sn_m : forall n m, m <= n -> S (n - m) = S n - m.
+Lemma minus_Sn_m n m : m <= n -> S (n - m) = S n - m.
 Proof.
-  intros n m Le; pattern m, n; apply le_elim_rel; simpl;
-    auto with arith.
+ intros. symmetry. now apply Nat.sub_succ_l.
 Qed.
-Hint Resolve minus_Sn_m: arith v62.
 
-Theorem pred_of_minus : forall n, pred n = n - 1.
+Theorem pred_of_minus n : pred n = n - 1.
 Proof.
-  intro x; induction x; simpl; auto with arith.
+ symmetry. apply Nat.sub_1_r.
 Qed.
 
 (** * Diagonal *)
 
-Lemma minus_diag : forall n, n - n = 0.
-Proof.
-  induction n; simpl; auto with arith.
-Qed.
+Notation minus_diag := Nat.sub_diag (compat "8.4"). (* n - n = 0 *)
 
-Lemma minus_diag_reverse : forall n, 0 = n - n.
+Lemma minus_diag_reverse n : 0 = n - n.
 Proof.
-  auto using minus_diag.
+ symmetry. apply Nat.sub_diag.
 Qed.
-Hint Resolve minus_diag_reverse: arith v62.
 
 Notation minus_n_n := minus_diag_reverse.
 
 (** * Simplification *)
 
-Lemma minus_plus_simpl_l_reverse : forall n m p, n - m = p + n - (p + m).
+Lemma minus_plus_simpl_l_reverse n m p : n - m = p + n - (p + m).
 Proof.
-  induction p; simpl; auto with arith.
+ now rewrite Nat.sub_add_distr, Nat.add_comm, Nat.add_sub.
 Qed.
-Hint Resolve minus_plus_simpl_l_reverse: arith v62.
 
 (** * Relation with plus *)
 
-Lemma plus_minus : forall n m p, n = m + p -> p = n - m.
+Lemma plus_minus n m p : n = m + p -> p = n - m.
 Proof.
-  intros n m p; pattern m, n; apply nat_double_ind; simpl;
-    intros.
-  replace (n0 - 0) with n0; auto with arith.
-  absurd (0 = S (n0 + p)); auto with arith.
-  auto with arith.
+ symmetry. now apply Nat.add_sub_eq_l.
 Qed.
-Hint Immediate plus_minus: arith v62.
 
-Lemma minus_plus : forall n m, n + m - n = m.
-  symmetry ; auto with arith.
+Lemma minus_plus n m : n + m - n = m.
+Proof.
+ rewrite Nat.add_comm. apply Nat.add_sub.
 Qed.
-Hint Resolve minus_plus: arith v62.
 
-Lemma le_plus_minus : forall n m, n <= m -> m = n + (m - n).
+Lemma le_plus_minus_r n m : n <= m -> n + (m - n) = m.
 Proof.
-  intros n m Le; pattern n, m; apply le_elim_rel; simpl;
-    auto with arith.
+ rewrite Nat.add_comm. apply Nat.sub_add.
 Qed.
-Hint Resolve le_plus_minus: arith v62.
 
-Lemma le_plus_minus_r : forall n m, n <= m -> n + (m - n) = m.
+Lemma le_plus_minus n m : n <= m -> m = n + (m - n).
 Proof.
-  symmetry ; auto with arith.
+ intros. symmetry. rewrite Nat.add_comm. now apply Nat.sub_add.
 Qed.
-Hint Resolve le_plus_minus_r: arith v62.
 
 (** * Relation with order *)
 
-Theorem minus_le_compat_r : forall n m p : nat, n <= m -> n - p <= m - p.
-Proof.
-  intros n m p; generalize n m; clear n m; induction p as [|p HI].
-    intros n m; rewrite <- (minus_n_O n); rewrite <- (minus_n_O m); trivial.
-
-    intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); auto with arith.
-    intros q r H _. simpl. auto using HI.
-Qed.
-
-Theorem minus_le_compat_l : forall n m p : nat, n <= m -> p - m <= p - n.
-Proof.
-  intros n m p; generalize n m; clear n m; induction p as [|p HI].
-    trivial.
+Notation minus_le_compat_r :=
+  Nat.sub_le_mono_r (compat "8.4"). (* n <= m -> n - p <= m - p. *)
 
-    intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial.
-      intros q; destruct q; auto with arith.
-        simpl.
-        apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O];
-          auto with arith.
+Notation minus_le_compat_l :=
+  Nat.sub_le_mono_l (compat "8.4"). (* n <= m -> p - m <= p - n. *)
 
-      intros q r Hqr _. simpl. auto using HI.
-Qed.
+Notation le_minus := Nat.le_sub_l (compat "8.4"). (* n - m <= n *)
+Notation lt_minus := Nat.sub_lt (compat "8.4"). (* m <= n -> 0 < m -> n-m < n *)
 
-Corollary le_minus : forall n m, n - m <= n.
+Lemma lt_O_minus_lt n m : 0 < n - m -> m < n.
 Proof.
-  intros n m; rewrite minus_n_O; auto using minus_le_compat_l with arith.
+ apply Nat.lt_add_lt_sub_r.
 Qed.
 
-Lemma lt_minus : forall n m, m <= n -> 0 < m -> n - m < n.
+Theorem not_le_minus_0 n m : ~ m <= n -> n - m = 0.
 Proof.
-  intros n m Le; pattern m, n; apply le_elim_rel; simpl;
-    auto using le_minus with arith.
-    intros; absurd (0 < 0); auto with arith.
+ intros. now apply Nat.sub_0_le, Nat.lt_le_incl, Nat.lt_nge.
 Qed.
-Hint Resolve lt_minus: arith v62.
 
-Lemma lt_O_minus_lt : forall n m, 0 < n - m -> m < n.
-Proof.
-  intros n m; pattern n, m; apply nat_double_ind; simpl;
-    auto with arith.
-  intros; absurd (0 < 0); trivial with arith.
-Qed.
-Hint Immediate lt_O_minus_lt: arith v62.
+(** * Hints *)
 
-Theorem not_le_minus_0 : forall n m, ~ m <= n -> n - m = 0.
-Proof.
-  intros y x; pattern y, x; apply nat_double_ind;
-    [ simpl; trivial with arith
-      | intros n H; absurd (0 <= S n); [ assumption | apply le_O_n ]
-      | simpl; intros n m H1 H2; apply H1; unfold not; intros H3;
-	apply H2; apply le_n_S; assumption ].
-Qed.
+Hint Resolve minus_n_O: arith v62.
+Hint Resolve minus_Sn_m: arith v62.
+Hint Resolve minus_diag_reverse: arith v62.
+Hint Resolve minus_plus_simpl_l_reverse: arith v62.
+Hint Immediate plus_minus: arith v62.
+Hint Resolve minus_plus: arith v62.
+Hint Resolve le_plus_minus: arith v62.
+Hint Resolve le_plus_minus_r: arith v62.
+Hint Resolve lt_minus: arith v62.
+Hint Immediate lt_O_minus_lt: arith v62.
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index 588afde3..2d82920b 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -1,220 +1,144 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Export Plus.
-Require Export Minus.
-Require Export Lt.
-Require Export Le.
+(** * Properties of multiplication.
 
-Local Open Scope nat_scope.
+ This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.
+
+ [Nat.mul] is defined in [Init/Nat.v].
+*)
 
-Implicit Types m n p : nat.
+Require Import PeanoNat.
+(** For Compatibility: *)
+Require Export Plus Minus Le Lt.
 
-(** Theorems about multiplication in [nat]. [mult] is defined in module [Init/Peano.v]. *)
+Local Open Scope nat_scope.
 
 (** * [nat] is a semi-ring *)
 
 (** ** Zero property *)
 
-Lemma mult_0_r : forall n, n * 0 = 0.
-Proof.
-  intro; symmetry ; apply mult_n_O.
-Qed.
-
-Lemma mult_0_l : forall n, 0 * n = 0.
-Proof.
-  reflexivity.
-Qed.
+Notation mult_0_l := Nat.mul_0_l (compat "8.4"). (* 0 * n = 0 *)
+Notation mult_0_r := Nat.mul_0_r (compat "8.4"). (* n * 0 = 0 *)
 
 (** ** 1 is neutral *)
 
-Lemma mult_1_l : forall n, 1 * n = n.
-Proof.
-  simpl; auto with arith.
-Qed.
-Hint Resolve mult_1_l: arith v62.
+Notation mult_1_l := Nat.mul_1_l (compat "8.4"). (* 1 * n = n *)
+Notation mult_1_r := Nat.mul_1_r (compat "8.4"). (* n * 1 = n *)
 
-Lemma mult_1_r : forall n, n * 1 = n.
-Proof.
-  induction n; [ trivial |
-    simpl; rewrite IHn; reflexivity].
-Qed.
-Hint Resolve mult_1_r: arith v62.
+Hint Resolve mult_1_l mult_1_r: arith v62.
 
 (** ** Commutativity *)
 
-Lemma mult_comm : forall n m, n * m = m * n.
-Proof.
-intros; induction n; simpl; auto with arith.
-rewrite <- mult_n_Sm.
-rewrite IHn; apply plus_comm.
-Qed.
+Notation mult_comm := Nat.mul_comm (compat "8.4"). (* n * m = m * n *)
+
 Hint Resolve mult_comm: arith v62.
 
 (** ** Distributivity *)
 
-Lemma mult_plus_distr_r : forall n m p, (n + m) * p = n * p + m * p.
-Proof.
-  intros; induction n; simpl; auto with arith.
-  rewrite <- plus_assoc, IHn; auto with arith.
-Qed.
-Hint Resolve mult_plus_distr_r: arith v62.
+Notation mult_plus_distr_r :=
+  Nat.mul_add_distr_r (compat "8.4"). (* (n+m)*p = n*p + m*p *)
 
-Lemma mult_plus_distr_l : forall n m p, n * (m + p) = n * m + n * p.
-Proof.
-  induction n. trivial.
-  intros. simpl. rewrite IHn. symmetry. apply plus_permute_2_in_4.
-Qed.
+Notation mult_plus_distr_l :=
+  Nat.mul_add_distr_l (compat "8.4"). (* n*(m+p) = n*m + n*p *)
 
-Lemma mult_minus_distr_r : forall n m p, (n - m) * p = n * p - m * p.
-Proof.
-  intros; induction n, m using nat_double_ind; simpl; auto with arith.
-  rewrite <- minus_plus_simpl_l_reverse; auto with arith.
-Qed.
-Hint Resolve mult_minus_distr_r: arith v62.
+Notation mult_minus_distr_r :=
+  Nat.mul_sub_distr_r (compat "8.4"). (* (n-m)*p = n*p - m*p *)
 
-Lemma mult_minus_distr_l : forall n m p, n * (m - p) = n * m - n * p.
-Proof.
-  intros n m p.
-  rewrite mult_comm, mult_minus_distr_r, (mult_comm m n), (mult_comm p n); reflexivity.
-Qed.
+Notation mult_minus_distr_l :=
+  Nat.mul_sub_distr_l (compat "8.4"). (* n*(m-p) = n*m - n*p *)
+
+Hint Resolve mult_plus_distr_r: arith v62.
+Hint Resolve mult_minus_distr_r: arith v62.
 Hint Resolve mult_minus_distr_l: arith v62.
 
 (** ** Associativity *)
 
-Lemma mult_assoc_reverse : forall n m p, n * m * p = n * (m * p).
-Proof.
-  intros; induction n; simpl; auto with arith.
-  rewrite mult_plus_distr_r.
-  induction IHn; auto with arith.
-Qed.
-Hint Resolve mult_assoc_reverse: arith v62.
+Notation mult_assoc := Nat.mul_assoc (compat "8.4"). (* n*(m*p)=n*m*p *)
 
-Lemma mult_assoc : forall n m p, n * (m * p) = n * m * p.
+Lemma mult_assoc_reverse n m p : n * m * p = n * (m * p).
 Proof.
-  auto with arith.
+ symmetry. apply Nat.mul_assoc.
 Qed.
+
+Hint Resolve mult_assoc_reverse: arith v62.
 Hint Resolve mult_assoc: arith v62.
 
 (** ** Inversion lemmas *)
 
-Lemma mult_is_O : forall n m, n * m = 0 -> n = 0 \/ m = 0.
+Lemma mult_is_O n m : n * m = 0 -> n = 0 \/ m = 0.
 Proof.
-  destruct n as [| n]; simpl; intros m H.
-    left; trivial.
-    right; apply plus_is_O in H; destruct H; trivial.
+ apply Nat.eq_mul_0.
 Qed.
 
-Lemma mult_is_one : forall n m, n * m = 1 -> n = 1 /\ m = 1.
+Lemma mult_is_one n m : n * m = 1 -> n = 1 /\ m = 1.
 Proof.
-  destruct n as [|n]; simpl; intros m H.
-    edestruct O_S; eauto.
-    destruct plus_is_one with (1:=H) as [[-> Hnm] | [-> Hnm]].
-      simpl in H; rewrite mult_0_r in H; elim (O_S _ H).
-      rewrite mult_1_r in Hnm; auto.
+ apply Nat.eq_mul_1.
 Qed.
 
 (** ** Multiplication and successor *)
 
-Lemma mult_succ_l : forall n m:nat, S n * m = n * m + m.
-Proof.
-  intros; simpl. rewrite plus_comm. reflexivity.
-Qed.
-
-Lemma mult_succ_r : forall n m:nat, n * S m = n * m + n.
-Proof.
-  induction n as [| p H]; intro m; simpl.
-  reflexivity.
-  rewrite H, <- plus_n_Sm; apply f_equal; rewrite plus_assoc; reflexivity.
-Qed.
+Notation mult_succ_l := Nat.mul_succ_l (compat "8.4"). (* S n * m = n * m + m *)
+Notation mult_succ_r := Nat.mul_succ_r (compat "8.4"). (* n * S m = n * m + n *)
 
 (** * Compatibility with orders *)
 
-Lemma mult_O_le : forall n m, m = 0 \/ n <= m * n.
+Lemma mult_O_le n m : m = 0 \/ n <= m * n.
 Proof.
-  induction m; simpl; auto with arith.
+ destruct m; [left|right]; simpl; trivial using Nat.le_add_r.
 Qed.
 Hint Resolve mult_O_le: arith v62.
 
-Lemma mult_le_compat_l : forall n m p, n <= m -> p * n <= p * m.
+Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m.
 Proof.
-  induction p as [| p IHp]; intros; simpl.
-  apply le_n.
-  auto using plus_le_compat.
+ apply Nat.mul_le_mono_nonneg_l, Nat.le_0_l. (* TODO : get rid of 0<=n hyp *)
 Qed.
 Hint Resolve mult_le_compat_l: arith.
 
-
-Lemma mult_le_compat_r : forall n m p, n <= m -> n * p <= m * p.
+Lemma mult_le_compat_r n m p : n <= m -> n * p <= m * p.
 Proof.
-  intros m n p H; rewrite mult_comm, (mult_comm n); auto with arith.
+ apply Nat.mul_le_mono_nonneg_r, Nat.le_0_l.
 Qed.
 
-Lemma mult_le_compat :
-  forall n m p (q:nat), n <= m -> p <= q -> n * p <= m * q.
+Lemma mult_le_compat n m p q : n <= m -> p <= q -> n * p <= m * q.
 Proof.
-  intros m n p q Hmn Hpq; induction Hmn.
-  induction Hpq.
-  (* m*p<=m*p *)
-  apply le_n.
-  (* m*p<=m*m0 -> m*p<=m*(S m0) *)
-  rewrite <- mult_n_Sm; apply le_trans with (m * m0).
-  assumption.
-  apply le_plus_l.
-  (* m*p<=m0*q -> m*p<=(S m0)*q *)
-  simpl; apply le_trans with (m0 * q).
-  assumption.
-  apply le_plus_r.
+  intros. apply Nat.mul_le_mono_nonneg; trivial; apply Nat.le_0_l.
 Qed.
 
-Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p.
+Lemma mult_S_lt_compat_l n m p : m < p -> S n * m < S n * p.
 Proof.
-  induction n; intros; simpl in *.
-    rewrite <- 2 plus_n_O; assumption.
-    auto using plus_lt_compat.
+  apply Nat.mul_lt_mono_pos_l, Nat.lt_0_succ.
 Qed.
 
 Hint Resolve mult_S_lt_compat_l: arith.
 
-Lemma mult_lt_compat_l : forall n m p, n < m -> 0 < p -> p * n < p * m.
+Lemma mult_lt_compat_l n m p : n < m -> 0 < p -> p * n < p * m.
 Proof.
- intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp).
- now apply mult_S_lt_compat_l.
+ intros. now apply Nat.mul_lt_mono_pos_l.
 Qed.
 
-Lemma mult_lt_compat_r : forall n m p, n < m -> 0 < p -> n * p < m * p.
+Lemma mult_lt_compat_r n m p : n < m -> 0 < p -> n * p < m * p.
 Proof.
-  intros m n p H Hp. destruct p. elim (lt_irrefl _ Hp).
-  rewrite (mult_comm m), (mult_comm n). now apply mult_S_lt_compat_l.
+ intros. now apply Nat.mul_lt_mono_pos_r.
 Qed.
 
-Lemma mult_S_le_reg_l : forall n m p, S n * m <= S n * p -> m <= p.
+Lemma mult_S_le_reg_l n m p : S n * m <= S n * p -> m <= p.
 Proof.
-  intros m n p H; destruct (le_or_lt n p). trivial.
-  assert (H1:S m * n < S m * n).
-    apply le_lt_trans with (m := S m * p). assumption.
-    apply mult_S_lt_compat_l. assumption.
-  elim (lt_irrefl _ H1).
+ apply Nat.mul_le_mono_pos_l, Nat.lt_0_succ.
 Qed.
 
 (** * n|->2*n and n|->2n+1 have disjoint image *)
 
-Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q.
+Theorem odd_even_lem p q : 2 * p + 1 <> 2 * q.
 Proof.
-  induction p; destruct q.
-    discriminate.
-    simpl; rewrite plus_comm. discriminate.
-    discriminate.
-    intro H0; destruct (IHp q).
-    replace (2 * q) with (2 * S q - 2).
-      rewrite <- H0; simpl.
-      repeat rewrite (fun x y => plus_comm x (S y)); simpl;  auto.
-    simpl; rewrite (fun y => plus_comm q (S y)); destruct q; simpl; auto.
+ intro. apply (Nat.Even_Odd_False (2*q)).
+ - now exists q.
+ - now exists p.
 Qed.
 
 
@@ -232,10 +156,9 @@ Fixpoint mult_acc (s:nat) m n : nat :=
 
 Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n.
 Proof.
-  induction n as [| p IHp]; simpl; auto.
-  intros s m; rewrite <- plus_tail_plus; rewrite <- IHp.
-  rewrite <- plus_assoc_reverse; apply f_equal2; auto.
-  rewrite plus_comm; auto.
+  induction n as [| n IHn]; simpl; auto.
+  intros. rewrite Nat.add_assoc, IHn. f_equal.
+  rewrite Nat.add_comm. apply plus_tail_plus.
 Qed.
 
 Definition tail_mult n m := mult_acc 0 m n.
diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v
new file mode 100644
index 00000000..799031a2
--- /dev/null
+++ b/theories/Arith/PeanoNat.v
@@ -0,0 +1,755 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+(*                      Evgeny Makarov, INRIA, 2007                     *)
+(************************************************************************)
+
+Require Import NAxioms NProperties OrdersFacts.
+
+(** Implementation of [NAxiomsSig] by [nat] *)
+
+Module Nat
+ <: NAxiomsSig
+ <: UsualDecidableTypeFull
+ <: OrderedTypeFull
+ <: TotalOrder.
+
+(** Operations over [nat] are defined in a separate module *)
+
+Include Coq.Init.Nat.
+
+(** When including property functors, inline t eq zero one two lt le succ *)
+
+Set Inline Level 50.
+
+(** All operations are well-defined (trivial here since eq is Leibniz) *)
+
+Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence.
+Local Obligation Tactic := simpl_relation.
+Program Instance succ_wd : Proper (eq==>eq) S.
+Program Instance pred_wd : Proper (eq==>eq) pred.
+Program Instance add_wd : Proper (eq==>eq==>eq) plus.
+Program Instance sub_wd : Proper (eq==>eq==>eq) minus.
+Program Instance mul_wd : Proper (eq==>eq==>eq) mult.
+Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
+Program Instance div_wd : Proper (eq==>eq==>eq) div.
+Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
+Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
+Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit.
+
+(** Bi-directional induction. *)
+
+Theorem bi_induction :
+  forall A : nat -> Prop, Proper (eq==>iff) A ->
+    A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n.
+Proof.
+intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS.
+Qed.
+
+(** Recursion fonction *)
+
+Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A :=
+  nat_rect (fun _ => A).
+
+Instance recursion_wd {A} (Aeq : relation A) :
+ Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
+Proof.
+intros a a' Ha f f' Hf n n' Hn. subst n'.
+induction n; simpl; auto. apply Hf; auto.
+Qed.
+
+Theorem recursion_0 :
+  forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a.
+Proof.
+reflexivity.
+Qed.
+
+Theorem recursion_succ :
+  forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A),
+    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
+      forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
+Proof.
+unfold Proper, respectful in *; induction n; simpl; auto.
+Qed.
+
+(** ** Remaining constants not defined in Coq.Init.Nat *)
+
+(** NB: Aliasing [le] is mandatory, since only a Definition can implement
+    an interface Parameter... *)
+
+Definition eq := @Logic.eq nat.
+Definition le := Peano.le.
+Definition lt := Peano.lt.
+
+(** ** Basic specifications : pred add sub mul *)
+
+Lemma pred_succ n : pred (S n) = n.
+Proof.
+reflexivity.
+Qed.
+
+Lemma pred_0 : pred 0 = 0.
+Proof.
+reflexivity.
+Qed.
+
+Lemma one_succ : 1 = S 0.
+Proof.
+reflexivity.
+Qed.
+
+Lemma two_succ : 2 = S 1.
+Proof.
+reflexivity.
+Qed.
+
+Lemma add_0_l n : 0 + n = n.
+Proof.
+reflexivity.
+Qed.
+
+Lemma add_succ_l n m : (S n) + m = S (n + m).
+Proof.
+reflexivity.
+Qed.
+
+Lemma sub_0_r n : n - 0 = n.
+Proof.
+now destruct n.
+Qed.
+
+Lemma sub_succ_r n m : n - (S m) = pred (n - m).
+Proof.
+revert m. induction n; destruct m; simpl; auto. apply sub_0_r.
+Qed.
+
+Lemma mul_0_l n : 0 * n = 0.
+Proof.
+reflexivity.
+Qed.
+
+Lemma mul_succ_l n m : S n * m = n * m + m.
+Proof.
+assert (succ_r : forall x y, x+S y = S(x+y)) by now induction x.
+assert (comm : forall x y, x+y = y+x).
+{ induction x; simpl; auto. intros; rewrite succ_r; now f_equal. }
+now rewrite comm.
+Qed.
+
+Lemma lt_succ_r n m : n < S m <-> n <= m.
+Proof.
+split. apply Peano.le_S_n. induction 1; auto.
+Qed.
+
+(** ** Boolean comparisons *)
+
+Lemma eqb_eq n m : eqb n m = true <-> n = m.
+Proof.
+ revert m.
+ induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
+ - now intros ->.
+ - now injection 1.
+Qed.
+
+Lemma leb_le n m : (n <=? m) = true <-> n <= m.
+Proof.
+ revert m.
+ induction n; destruct m; simpl.
+ - now split.
+ - split; trivial. intros; apply Peano.le_0_n.
+ - now split.
+ - rewrite IHn; split.
+   + apply Peano.le_n_S.
+   + apply Peano.le_S_n.
+Qed.
+
+Lemma ltb_lt n m : (n <? m) = true <-> n < m.
+Proof.
+ apply leb_le.
+Qed.
+
+(** ** Decidability of equality over [nat]. *)
+
+Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
+Proof.
+  induction n; destruct m.
+  - now left.
+  - now right.
+  - now right.
+  - destruct (IHn m); [left|right]; auto.
+Defined.
+
+(** ** Ternary comparison *)
+
+(** With [nat], it would be easier to prove first [compare_spec],
+    then the properties below. But then we wouldn't be able to
+    benefit from functor [BoolOrderFacts] *)
+
+Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
+Proof.
+ revert m; induction n; destruct m; simpl; rewrite ?IHn; split; auto; easy.
+Qed.
+
+Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
+Proof.
+ revert m; induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
+ - intros _. apply Peano.le_n_S, Peano.le_0_n.
+ - apply Peano.le_n_S.
+ - apply Peano.le_S_n.
+Qed.
+
+Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
+Proof.
+ revert m; induction n; destruct m; simpl; rewrite ?IHn.
+ - now split.
+ - split; intros. apply Peano.le_0_n. easy.
+ - split. now destruct 1. inversion 1.
+ - split; intros. now apply Peano.le_n_S. now apply Peano.le_S_n.
+Qed.
+
+Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
+Proof.
+ revert m; induction n; destruct m; simpl; trivial.
+Qed.
+
+Lemma compare_succ n m : (S n ?= S m) = (n ?= m).
+Proof.
+ reflexivity.
+Qed.
+
+
+(* BUG: Ajout d'un cas * après preuve finie (deuxième niveau +++*** ) :
+    *  --->   Anomaly: Uncaught exception Proofview.IndexOutOfRange(_). Please report. *)
+
+(** ** Minimum, maximum *)
+
+Lemma max_l : forall n m, m <= n -> max n m = n.
+Proof.
+ exact Peano.max_l.
+Qed.
+
+Lemma max_r : forall n m, n <= m -> max n m = m.
+Proof.
+ exact Peano.max_r.
+Qed.
+
+Lemma min_l : forall n m, n <= m -> min n m = n.
+Proof.
+ exact Peano.min_l.
+Qed.
+
+Lemma min_r : forall n m, m <= n -> min n m = m.
+Proof.
+ exact Peano.min_r.
+Qed.
+
+(** Some more advanced properties of comparison and orders,
+    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)
+
+Include BoolOrderFacts.
+
+(** We can now derive all properties of basic functions and orders,
+    and use these properties for proving the specs of more advanced
+    functions. *)
+
+Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+(** ** Power *)
+
+Lemma pow_neg_r a b : b<0 -> a^b = 0. inversion 1. Qed.
+
+Lemma pow_0_r a : a^0 = 1.
+Proof. reflexivity. Qed.
+
+Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b.
+Proof. reflexivity. Qed.
+
+(** ** Square *)
+
+Lemma square_spec n : square n = n * n.
+Proof. reflexivity. Qed.
+
+(** ** Parity *)
+
+Definition Even n := exists m, n = 2*m.
+Definition Odd n := exists m, n = 2*m+1.
+
+Module Private_Parity.
+
+Lemma Even_1 : ~ Even 1.
+Proof.
+ intros ([|], H); try discriminate.
+ simpl in H. now rewrite <- plus_n_Sm in H.
+Qed.
+
+Lemma Even_2 n : Even n <-> Even (S (S n)).
+Proof.
+ split; intros (m,H).
+ - exists (S m). rewrite H. simpl. now rewrite plus_n_Sm.
+ - destruct m; try discriminate.
+   exists m. simpl in H. rewrite <- plus_n_Sm in H. now inversion H.
+Qed.
+
+Lemma Odd_0 : ~ Odd 0.
+Proof.
+ now intros ([|], H).
+Qed.
+
+Lemma Odd_2 n : Odd n <-> Odd (S (S n)).
+Proof.
+ split; intros (m,H).
+ - exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m).
+ - destruct m; try discriminate.
+   exists m. simpl in H. rewrite <- plus_n_Sm in H. inversion H.
+   simpl. now rewrite <- !plus_n_Sm, <- !plus_n_O.
+Qed.
+
+End Private_Parity.
+Import Private_Parity.
+
+Lemma even_spec : forall n, even n = true <-> Even n.
+Proof.
+ fix 1.
+  destruct n as [|[|n]]; simpl.
+  - split; [ now exists 0 | trivial ].
+  - split; [ discriminate | intro H; elim (Even_1 H) ].
+  - rewrite even_spec. apply Even_2.
+Qed.
+
+Lemma odd_spec : forall n, odd n = true <-> Odd n.
+Proof.
+ unfold odd.
+ fix 1.
+  destruct n as [|[|n]]; simpl.
+  - split; [ discriminate | intro H; elim (Odd_0 H) ].
+  - split; [ now exists 0 | trivial ].
+  - rewrite odd_spec. apply Odd_2.
+Qed.
+
+(** ** Division *)
+
+Lemma divmod_spec : forall x y q u, u <= y ->
+ let (q',u') := divmod x y q u in
+ x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y.
+Proof.
+ induction x.
+ - simpl; intuition.
+ - intros y q u H. destruct u; simpl divmod.
+   + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u').
+     intros (EQ,LE); split; trivial.
+     rewrite <- EQ, sub_0_r, sub_diag, add_0_r.
+     now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r.
+   + assert (H' : u <= y).
+     { apply le_trans with (S u); trivial. do 2 constructor. }
+     generalize (IHx y q u H'). destruct divmod as (q',u').
+     intros (EQ,LE); split; trivial.
+     rewrite <- EQ.
+     rewrite !add_succ_l, <- add_succ_r. f_equal. now rewrite <- sub_succ_l.
+Qed.
+
+Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y.
+Proof.
+ intros Hy.
+ destruct y; [ now elim Hy | clear Hy ].
+ unfold div, modulo.
+ generalize (divmod_spec x y 0 y (le_n y)).
+ destruct divmod as (q,u).
+ intros (U,V).
+ simpl in *.
+ now rewrite mul_0_r, sub_diag, !add_0_r in U.
+Qed.
+
+Lemma mod_bound_pos x y : 0<=x -> 0<y -> 0 <= x mod y < y.
+Proof.
+ intros Hx Hy. split. apply le_0_l.
+ destruct y; [ now elim Hy | clear Hy ].
+ unfold modulo.
+ apply lt_succ_r, le_sub_l.
+Qed.
+
+(** ** Square root *)
+
+Lemma sqrt_iter_spec : forall k p q r,
+ q = p+p -> r<=q ->
+ let s := sqrt_iter k p q r in
+ s*s <= k + p*p + (q - r) < (S s)*(S s).
+Proof.
+ induction k.
+ - (* k = 0 *)
+   simpl; intros p q r Hq Hr.
+   split.
+   + apply le_add_r.
+   + apply lt_succ_r.
+     rewrite mul_succ_r.
+     rewrite add_assoc, (add_comm p), <- add_assoc.
+     apply add_le_mono_l.
+     rewrite <- Hq. apply le_sub_l.
+ - (* k = S k' *)
+   destruct r.
+   + (* r = 0 *)
+     intros Hq _.
+     replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))).
+     * apply IHk.
+       simpl. now rewrite add_succ_r, Hq. apply le_n.
+     * rewrite sub_diag, sub_0_r, add_0_r. simpl.
+       rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal.
+       rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal.
+   + (* r = S r' *)
+     intros Hq Hr.
+     replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)).
+     * apply IHk; trivial. apply le_trans with (S r); trivial. do 2 constructor.
+     * simpl. rewrite <- add_succ_r. f_equal. rewrite <- sub_succ_l; trivial.
+Qed.
+
+Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n).
+Proof.
+ set (s:=sqrt n).
+ replace n with (n + 0*0 + (0-0)).
+ apply sqrt_iter_spec; auto.
+ simpl. now rewrite !add_0_r.
+Qed.
+
+Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a.
+
+Lemma sqrt_neg a : a<0 -> sqrt a = 0.
+Proof. inversion 1. Qed.
+
+(** ** Logarithm *)
+
+Lemma log2_iter_spec : forall k p q r,
+ 2^(S p) = q + S r -> r < 2^p ->
+ let s := log2_iter k p q r in
+ 2^s <= k + q < 2^(S s).
+Proof.
+ induction k.
+ - (* k = 0 *)
+   intros p q r EQ LT. simpl log2_iter. cbv zeta.
+   split.
+   + rewrite add_0_l.
+     rewrite (add_le_mono_l _ _ (2^p)).
+     simpl pow in EQ. rewrite add_0_r in EQ. rewrite EQ.
+     rewrite add_comm. apply add_le_mono_r. apply LT.
+   + rewrite EQ, add_comm. apply add_lt_mono_l.
+     apply lt_succ_r, le_0_l.
+ - (* k = S k' *)
+   intros p q r EQ LT. destruct r.
+   + (* r = 0 *)
+     rewrite add_succ_r, add_0_r in EQ.
+     rewrite add_succ_l, <- add_succ_r. apply IHk.
+     * rewrite <- EQ. remember (S p) as p'; simpl. now rewrite add_0_r.
+     * rewrite EQ. constructor.
+   + (* r = S r' *)
+     rewrite add_succ_l, <- add_succ_r. apply IHk.
+     * now rewrite add_succ_l, <- add_succ_r.
+     * apply le_lt_trans with (S r); trivial. do 2 constructor.
+Qed.
+
+Lemma log2_spec n : 0<n ->
+ 2^(log2 n) <= n < 2^(S (log2 n)).
+Proof.
+ intros.
+ set (s:=log2 n).
+ replace n with (pred n + 1).
+ apply log2_iter_spec; auto.
+ rewrite add_1_r.
+ apply succ_pred. now apply neq_sym, lt_neq.
+Qed.
+
+Lemma log2_nonpos n : n<=0 -> log2 n = 0.
+Proof.
+ inversion 1; now subst.
+Qed.
+
+(** ** Gcd *)
+
+Definition divide x y := exists z, y=z*x.
+Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.
+
+Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b).
+Proof.
+ fix 1.
+ intros [|a] b; simpl.
+ split.
+  now exists 0.
+  exists 1. simpl. now rewrite <- plus_n_O.
+ fold (b mod (S a)).
+ destruct (gcd_divide (b mod (S a)) (S a)) as (H,H').
+ set (a':=S a) in *.
+ split; auto.
+ rewrite (div_mod b a') at 2 by discriminate.
+ destruct H as (u,Hu), H' as (v,Hv).
+ rewrite mul_comm.
+ exists ((b/a')*v + u).
+ rewrite mul_add_distr_r.
+ now rewrite <- mul_assoc, <- Hv, <- Hu.
+Qed.
+
+Lemma gcd_divide_l : forall a b, (gcd a b | a).
+Proof.
+ intros. apply gcd_divide.
+Qed.
+
+Lemma gcd_divide_r : forall a b, (gcd a b | b).
+Proof.
+ intros. apply gcd_divide.
+Qed.
+
+Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b).
+Proof.
+ fix 1.
+ intros [|a] b; simpl; auto.
+ fold (b mod (S a)).
+ intros c H H'. apply gcd_greatest; auto.
+ set (a':=S a) in *.
+ rewrite (div_mod b a') in H' by discriminate.
+ destruct H as (u,Hu), H' as (v,Hv).
+ exists (v - (b/a')*u).
+ rewrite mul_comm in Hv.
+ rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu.
+ now rewrite add_comm, add_sub.
+Qed.
+
+Lemma gcd_nonneg a b : 0<=gcd a b.
+Proof. apply le_0_l. Qed.
+
+
+(** ** Bitwise operations *)
+
+Lemma div2_double n : div2 (2*n) = n.
+Proof.
+ induction n; trivial.
+ simpl mul. rewrite add_succ_r. simpl. now f_equal.
+Qed.
+
+Lemma div2_succ_double n : div2 (S (2*n)) = n.
+Proof.
+ induction n; trivial.
+ simpl. f_equal. now rewrite add_succ_r.
+Qed.
+
+Lemma le_div2 n : div2 (S n) <= n.
+Proof.
+ revert n.
+ fix 1.
+ destruct n; simpl; trivial. apply lt_succ_r.
+ destruct n; [simpl|]; trivial. now constructor.
+Qed.
+
+Lemma lt_div2 n : 0 < n -> div2 n < n.
+Proof.
+ destruct n.
+ - inversion 1.
+ - intros _. apply lt_succ_r, le_div2.
+Qed.
+
+Lemma div2_decr a n : a <= S n -> div2 a <= n.
+Proof.
+ destruct a; intros H.
+ - simpl. apply le_0_l.
+ - apply succ_le_mono in H.
+   apply le_trans with a; [ apply le_div2 | trivial ].
+Qed.
+
+Lemma double_twice : forall n, double n = 2*n.
+Proof.
+ simpl; intros. now rewrite add_0_r.
+Qed.
+
+Lemma testbit_0_l : forall n, testbit 0 n = false.
+Proof.
+ now induction n.
+Qed.
+
+Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
+Proof.
+ unfold testbit. rewrite odd_spec. now exists a.
+Qed.
+
+Lemma testbit_even_0 a : testbit (2*a) 0 = false.
+Proof.
+ unfold testbit, odd. rewrite (proj2 (even_spec _)); trivial.
+ now exists a.
+Qed.
+
+Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n.
+Proof.
+ unfold testbit; fold testbit.
+ rewrite add_1_r. f_equal.
+ apply div2_succ_double.
+Qed.
+
+Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n.
+Proof.
+ unfold testbit; fold testbit. f_equal. apply div2_double.
+Qed.
+
+Lemma shiftr_specif : forall a n m,
+ testbit (shiftr a n) m = testbit a (m+n).
+Proof.
+ induction n; intros m. trivial.
+ now rewrite add_0_r.
+ now rewrite add_succ_r, <- add_succ_l, <- IHn.
+Qed.
+
+Lemma shiftl_specif_high : forall a n m, n<=m ->
+ testbit (shiftl a n) m = testbit a (m-n).
+Proof.
+ induction n; intros m H. trivial.
+ now rewrite sub_0_r.
+ destruct m. inversion H.
+ simpl. apply succ_le_mono in H.
+ change (shiftl a (S n)) with (double (shiftl a n)).
+ rewrite double_twice, div2_double. now apply IHn.
+Qed.
+
+Lemma shiftl_spec_low : forall a n m, m<n ->
+ testbit (shiftl a n) m = false.
+Proof.
+ induction n; intros m H. inversion H.
+ change (shiftl a (S n)) with (double (shiftl a n)).
+ destruct m; simpl.
+ unfold odd. apply negb_false_iff.
+ apply even_spec. exists (shiftl a n). apply double_twice.
+ rewrite double_twice, div2_double. apply IHn.
+ now apply succ_le_mono.
+Qed.
+
+Lemma div2_bitwise : forall op n a b,
+ div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b).
+Proof.
+ intros. unfold bitwise; fold bitwise.
+ destruct (op (odd a) (odd b)).
+ now rewrite div2_succ_double.
+ now rewrite add_0_l, div2_double.
+Qed.
+
+Lemma odd_bitwise : forall op n a b,
+ odd (bitwise op (S n) a b) = op (odd a) (odd b).
+Proof.
+ intros. unfold bitwise; fold bitwise.
+ destruct (op (odd a) (odd b)).
+ apply odd_spec. rewrite add_comm. eexists; eauto.
+ unfold odd. apply negb_false_iff. apply even_spec.
+ rewrite add_0_l; eexists; eauto.
+Qed.
+
+Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) ->
+ forall n m a b, a<=n ->
+ testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
+Proof.
+ intros op Hop.
+ induction n; intros m a b Ha.
+ simpl. inversion Ha; subst. now rewrite testbit_0_l.
+ destruct m.
+ apply odd_bitwise.
+ unfold testbit; fold testbit. rewrite div2_bitwise.
+ apply IHn. now apply div2_decr.
+Qed.
+
+Lemma testbit_bitwise_2 : forall op, op false false = false ->
+ forall n m a b, a<=n -> b<=n ->
+ testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
+Proof.
+ intros op Hop.
+ induction n; intros m a b Ha Hb.
+ simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l.
+ destruct m.
+ apply odd_bitwise.
+ unfold testbit; fold testbit. rewrite div2_bitwise.
+ apply IHn; now apply div2_decr.
+Qed.
+
+Lemma land_spec a b n :
+ testbit (land a b) n = testbit a n && testbit b n.
+Proof.
+ unfold land. apply testbit_bitwise_1; trivial.
+Qed.
+
+Lemma ldiff_spec a b n :
+ testbit (ldiff a b) n = testbit a n && negb (testbit b n).
+Proof.
+ unfold ldiff. apply testbit_bitwise_1; trivial.
+Qed.
+
+Lemma lor_spec a b n :
+ testbit (lor a b) n = testbit a n || testbit b n.
+Proof.
+ unfold lor. apply testbit_bitwise_2.
+ - trivial.
+ - destruct (compare_spec a b).
+   + rewrite max_l; subst; trivial.
+   + apply lt_le_incl in H. now rewrite max_r.
+   + apply lt_le_incl in H. now rewrite max_l.
+ - destruct (compare_spec a b).
+   + rewrite max_r; subst; trivial.
+   + apply lt_le_incl in H. now rewrite max_r.
+   + apply lt_le_incl in H. now rewrite max_l.
+Qed.
+
+Lemma lxor_spec a b n :
+ testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
+Proof.
+ unfold lxor. apply testbit_bitwise_2.
+ - trivial.
+ - destruct (compare_spec a b).
+   + rewrite max_l; subst; trivial.
+   + apply lt_le_incl in H. now rewrite max_r.
+   + apply lt_le_incl in H. now rewrite max_l.
+ - destruct (compare_spec a b).
+   + rewrite max_r; subst; trivial.
+   + apply lt_le_incl in H. now rewrite max_r.
+   + apply lt_le_incl in H. now rewrite max_l.
+Qed.
+
+Lemma div2_spec a : div2 a = shiftr a 1.
+Proof.
+ reflexivity.
+Qed.
+
+(** Aliases with extra dummy hypothesis, to fulfil the interface *)
+
+Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n.
+Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n.
+Lemma testbit_neg_r a n (H:n<0) : testbit a n = false.
+Proof. inversion H. Qed.
+
+Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m.
+Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m.
+
+(** Properties of advanced functions (pow, sqrt, log2, ...) *)
+
+Include NExtraProp.
+
+End Nat.
+
+(** Re-export notations that should be available even when
+    the [Nat] module is not imported. *)
+
+Bind Scope nat_scope with Nat.t nat.
+
+Infix "^" := Nat.pow : nat_scope.
+Infix "=?" := Nat.eqb (at level 70) : nat_scope.
+Infix "<=?" := Nat.leb (at level 70) : nat_scope.
+Infix "<?" := Nat.ltb (at level 70) : nat_scope.
+Infix "?=" := Nat.compare (at level 70) : nat_scope.
+Infix "/" := Nat.div : nat_scope.
+Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope.
+
+Hint Unfold Nat.le : core.
+Hint Unfold Nat.lt : core.
+
+(** [Nat] contains an [order] tactic for natural numbers *)
+
+(** Note that [Nat.order] is domain-agnostic: it will not prove
+    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
+
+Section TestOrder.
+ Let test : forall x y, x<=y -> y<=x -> x=y.
+ Proof.
+ Nat.order.
+ Qed.
+End TestOrder.
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
index e288a43f..a7ede3fc 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -1,52 +1,61 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Decidable.
+Require Import Decidable PeanoNat.
 Require Eqdep_dec.
-Require Import Le Lt.
 Local Open Scope nat_scope.
 
 Implicit Types m n x y : nat.
 
-Theorem O_or_S : forall n, {m : nat | S m = n} + {0 = n}.
+Theorem O_or_S n : {m : nat | S m = n} + {0 = n}.
 Proof.
   induction n.
-  auto.
-  left; exists n; auto.
+  - now right.
+  - left; exists n; auto.
 Defined.
 
-Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}.
-Proof.
-  induction n; destruct m; auto.
-  elim (IHn m); auto.
-Defined.
+Notation eq_nat_dec := Nat.eq_dec (compat "8.4").
 
 Hint Resolve O_or_S eq_nat_dec: arith.
 
-Theorem dec_eq_nat : forall n m, decidable (n = m).
-  intros x y; unfold decidable; elim (eq_nat_dec x y); auto with arith.
+Theorem dec_eq_nat n m : decidable (n = m).
+Proof.
+  elim (Nat.eq_dec n m); [left|right]; trivial.
 Defined.
 
-Definition UIP_nat:= Eqdep_dec.UIP_dec eq_nat_dec.
+Definition UIP_nat:= Eqdep_dec.UIP_dec Nat.eq_dec.
 
-Lemma le_unique: forall m n (h1 h2: m <= n), h1 = h2.
+Import EqNotations.
+
+Lemma le_unique: forall m n (le_mn1 le_mn2 : m <= n), le_mn1 = le_mn2.
 Proof.
-fix 3.
-refine (fun m _ h1 => match h1 as h' in _ <= k return forall hh: m <= k, h' = hh
-  with le_n => _ |le_S i H => _ end).
-refine (fun hh => match hh as h' in _ <= k return forall eq: m = k, 
-  le_n m = match eq in _ = p return m <= p -> m <= m with |eq_refl => fun bli => bli end h' with
-    |le_n => fun eq => _ |le_S j H' => fun eq => _ end eq_refl).
-rewrite (UIP_nat _ _ eq eq_refl). reflexivity.
-subst m. destruct (Lt.lt_irrefl j H').
-refine (fun hh => match hh as h' in _ <= k return match k as k' return m <= k' -> Prop
-  with |0 => fun _ => True |S i' => fun h'' => forall H':m <= i', le_S m i' H' = h'' end h'
-    with |le_n => _ |le_S j H2 => fun H' => _ end H).
-destruct m. exact I. intros; destruct (Lt.lt_irrefl m H').
-f_equal. apply le_unique.
+intros m n.
+generalize (eq_refl (S n)).
+generalize n at -1.
+induction (S n) as [|n0 IHn0]; try discriminate.
+clear n; intros n H; injection H; clear H; intro H.
+rewrite <- H; intros le_mn1 le_mn2; clear n H.
+pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2).
+  2: reflexivity.
+generalize def_n2; revert le_mn1 le_mn2.
+generalize n0 at 1 4 5 7; intros n1 le_mn1.
+destruct le_mn1; intros le_mn2; destruct le_mn2.
++ now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl).
++ intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0.
+  now destruct (Nat.nle_succ_diag_l _ le_mn0).
++ intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0.
+  now destruct (Nat.nle_succ_diag_l _ le_mn0).
++ intros def_n0; injection def_n0; intros ->.
+  rewrite (UIP_nat _ _ def_n0 eq_refl); simpl.
+  assert (H : le_mn1 = le_mn2).
+    now apply IHn0.
+now rewrite H.
 Qed.
+
+(** For compatibility *)
+Require Import Le Lt.
\ No newline at end of file
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index 5428ada3..3b823da6 100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -6,176 +6,139 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
-(** Properties of addition. [add] is defined in [Init/Peano.v] as:
+(** Properties of addition.
+
+ This file is mostly OBSOLETE now, see module [PeanoNat.Nat] instead.
+
+ [Nat.add] is defined in [Init/Nat.v] as:
 <<
-Fixpoint plus (n m:nat) : nat :=
+Fixpoint add (n m:nat) : nat :=
   match n with
   | O => m
   | S p => S (p + m)
   end
-where "n + m" := (plus n m) : nat_scope.
+where "n + m" := (add n m) : nat_scope.
 >>
- *)
+*)
 
-Require Import Le.
-Require Import Lt.
+Require Import PeanoNat.
 
 Local Open Scope nat_scope.
 
-Implicit Types m n p q : nat.
-
-(** * Zero is neutral 
-Deprecated : Already in Init/Peano.v *)
-Notation plus_0_l := plus_O_n (only parsing).
-Definition plus_0_r n := eq_sym (plus_n_O n).
-
-(** * Commutativity *)
-
-Lemma plus_comm : forall n m, n + m = m + n.
-Proof.
-  intros n m; elim n; simpl; auto with arith.
-  intros y H; elim (plus_n_Sm m y); auto with arith.
-Qed.
-Hint Immediate plus_comm: arith v62.
-
-(** * Associativity *)
+(** * Neutrality of 0, commutativity, associativity *)
 
-Definition plus_Snm_nSm : forall n m, S n + m = n + S m:=
- plus_n_Sm.
+Notation plus_0_l := Nat.add_0_l (compat "8.4").
+Notation plus_0_r := Nat.add_0_r (compat "8.4").
+Notation plus_comm := Nat.add_comm (compat "8.4").
+Notation plus_assoc := Nat.add_assoc (compat "8.4").
 
-Lemma plus_assoc : forall n m p, n + (m + p) = n + m + p.
-Proof.
-  intros n m p; elim n; simpl; auto with arith.
-Qed.
-Hint Resolve plus_assoc: arith v62.
+Notation plus_permute := Nat.add_shuffle3 (compat "8.4").
 
-Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p).
-Proof.
-  intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith.
-Qed.
+Definition plus_Snm_nSm : forall n m, S n + m = n + S m :=
+ Peano.plus_n_Sm.
 
-Lemma plus_assoc_reverse : forall n m p, n + m + p = n + (m + p).
+Lemma plus_assoc_reverse n m p : n + m + p = n + (m + p).
 Proof.
-  auto with arith.
+  symmetry. apply Nat.add_assoc.
 Qed.
-Hint Resolve plus_assoc_reverse: arith v62.
 
 (** * Simplification *)
 
-Lemma plus_reg_l : forall n m p, p + n = p + m -> n = m.
+Lemma plus_reg_l n m p : p + n = p + m -> n = m.
 Proof.
-  intros m p n; induction n; simpl; auto with arith.
+ apply Nat.add_cancel_l.
 Qed.
 
-Lemma plus_le_reg_l : forall n m p, p + n <= p + m -> n <= m.
+Lemma plus_le_reg_l n m p : p + n <= p + m -> n <= m.
 Proof.
-  induction p; simpl; auto with arith.
+ apply Nat.add_le_mono_l.
 Qed.
 
-Lemma plus_lt_reg_l : forall n m p, p + n < p + m -> n < m.
+Lemma plus_lt_reg_l n m p : p + n < p + m -> n < m.
 Proof.
-  induction p; simpl; auto with arith.
+ apply Nat.add_lt_mono_l.
 Qed.
 
 (** * Compatibility with order *)
 
-Lemma plus_le_compat_l : forall n m p, n <= m -> p + n <= p + m.
+Lemma plus_le_compat_l n m p : n <= m -> p + n <= p + m.
 Proof.
-  induction p; simpl; auto with arith.
+ apply Nat.add_le_mono_l.
 Qed.
-Hint Resolve plus_le_compat_l: arith v62.
 
-Lemma plus_le_compat_r : forall n m p, n <= m -> n + p <= m + p.
+Lemma plus_le_compat_r n m p : n <= m -> n + p <= m + p.
 Proof.
-  induction 1; simpl; auto with arith.
+ apply Nat.add_le_mono_r.
 Qed.
-Hint Resolve plus_le_compat_r: arith v62.
 
-Lemma le_plus_l : forall n m, n <= n + m.
+Lemma plus_lt_compat_l n m p : n < m -> p + n < p + m.
 Proof.
-  induction n; simpl; auto with arith.
+ apply Nat.add_lt_mono_l.
 Qed.
-Hint Resolve le_plus_l: arith v62.
 
-Lemma le_plus_r : forall n m, m <= n + m.
+Lemma plus_lt_compat_r n m p : n < m -> n + p < m + p.
 Proof.
-  intros n m; elim n; simpl; auto with arith.
+ apply Nat.add_lt_mono_r.
 Qed.
-Hint Resolve le_plus_r: arith v62.
 
-Theorem le_plus_trans : forall n m p, n <= m -> n <= m + p.
+Lemma plus_le_compat n m p q : n <= m -> p <= q -> n + p <= m + q.
 Proof.
-  intros; apply le_trans with (m := m); auto with arith.
+ apply Nat.add_le_mono.
 Qed.
-Hint Resolve le_plus_trans: arith v62.
 
-Theorem lt_plus_trans : forall n m p, n < m -> n < m + p.
+Lemma plus_le_lt_compat n m p q : n <= m -> p < q -> n + p < m + q.
 Proof.
-  intros; apply lt_le_trans with (m := m); auto with arith.
+ apply Nat.add_le_lt_mono.
 Qed.
-Hint Immediate lt_plus_trans: arith v62.
 
-Lemma plus_lt_compat_l : forall n m p, n < m -> p + n < p + m.
+Lemma plus_lt_le_compat n m p q : n < m -> p <= q -> n + p < m + q.
 Proof.
-  induction p; simpl; auto with arith.
+ apply Nat.add_lt_le_mono.
 Qed.
-Hint Resolve plus_lt_compat_l: arith v62.
 
-Lemma plus_lt_compat_r : forall n m p, n < m -> n + p < m + p.
+Lemma plus_lt_compat n m p q : n < m -> p < q -> n + p < m + q.
 Proof.
-  intros n m p H; rewrite (plus_comm n p); rewrite (plus_comm m p).
-  elim p; auto with arith.
+ apply Nat.add_lt_mono.
 Qed.
-Hint Resolve plus_lt_compat_r: arith v62.
 
-Lemma plus_le_compat : forall n m p q, n <= m -> p <= q -> n + p <= m + q.
+Lemma le_plus_l n m : n <= n + m.
 Proof.
-  intros n m p q H H0.
-  elim H; simpl; auto with arith.
+ apply Nat.le_add_r.
 Qed.
 
-Lemma plus_le_lt_compat : forall n m p q, n <= m -> p < q -> n + p < m + q.
+Lemma le_plus_r n m : m <= n + m.
 Proof.
-  unfold lt. intros. change (S n + p <= m + q). rewrite plus_Snm_nSm.
-  apply plus_le_compat; assumption.
+ rewrite Nat.add_comm. apply Nat.le_add_r.
 Qed.
 
-Lemma plus_lt_le_compat : forall n m p q, n < m -> p <= q -> n + p < m + q.
+Theorem le_plus_trans n m p : n <= m -> n <= m + p.
 Proof.
-  unfold lt. intros. change (S n + p <= m + q). apply plus_le_compat; assumption.
+  intros. now rewrite <- Nat.le_add_r.
 Qed.
 
-Lemma plus_lt_compat : forall n m p q, n < m -> p < q -> n + p < m + q.
+Theorem lt_plus_trans n m p : n < m -> n < m + p.
 Proof.
-  intros. apply plus_lt_le_compat. assumption.
-  apply lt_le_weak. assumption.
+  intros. apply Nat.lt_le_trans with m. trivial. apply Nat.le_add_r.
 Qed.
 
 (** * Inversion lemmas *)
 
-Lemma plus_is_O : forall n m, n + m = 0 -> n = 0 /\ m = 0.
+Lemma plus_is_O n m : n + m = 0 -> n = 0 /\ m = 0.
 Proof.
-  intro m; destruct m as [| n]; auto.
-  intros. discriminate H.
+  destruct n; now split.
 Qed.
 
-Definition plus_is_one :
-  forall m n, m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}.
+Definition plus_is_one m n :
+  m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}.
 Proof.
-  intro m; destruct m as [| n]; auto.
-  destruct n; auto.
-  intros.
-  simpl in H. discriminate H.
+  destruct m as [| m]; auto.
+  destruct m; auto.
+  discriminate.
 Defined.
 
 (** * Derived properties *)
 
-Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q).
-Proof.
-  intros m n p q.
-  rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q).
-  rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc.
-Qed.
+Notation plus_permute_2_in_4 := Nat.add_shuffle1 (compat "8.4").
 
 (** * Tail-recursive plus *)
 
@@ -190,31 +153,37 @@ Fixpoint tail_plus n m : nat :=
   end.
 
 Lemma plus_tail_plus : forall n m, n + m = tail_plus n m.
+Proof.
 induction n as [| n IHn]; simpl; auto.
 intro m; rewrite <- IHn; simpl; auto.
 Qed.
 
 (** * Discrimination *)
 
-Lemma succ_plus_discr : forall n m, n <> S (plus m n).
+Lemma succ_plus_discr n m : n <> S (m+n).
 Proof.
-  intros n m; induction n as [|n IHn].
-  discriminate.
-  intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm;
-    reflexivity.
+ apply Nat.succ_add_discr.
 Qed.
 
-Lemma n_SSn : forall n, n <> S (S n).
-Proof.
-  intro n; exact (succ_plus_discr n 1).
-Qed.
+Lemma n_SSn n : n <> S (S n).
+Proof (succ_plus_discr n 1).
 
-Lemma n_SSSn : forall n, n <> S (S (S n)).
-Proof.
-  intro n; exact (succ_plus_discr n 2).
-Qed.
+Lemma n_SSSn n : n <> S (S (S n)).
+Proof (succ_plus_discr n 2).
 
-Lemma n_SSSSn : forall n, n <> S (S (S (S n))).
-Proof.
-  intro n; exact (succ_plus_discr n 3).
-Qed.
+Lemma n_SSSSn n : n <> S (S (S (S n))).
+Proof (succ_plus_discr n 3).
+
+
+(** * Compatibility Hints *)
+
+Hint Immediate plus_comm : arith v62.
+Hint Resolve plus_assoc plus_assoc_reverse : arith v62.
+Hint Resolve plus_le_compat_l plus_le_compat_r : arith v62.
+Hint Resolve le_plus_l le_plus_r le_plus_trans : arith v62.
+Hint Immediate lt_plus_trans : arith v62.
+Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith v62.
+
+(** For compatibility, we "Require" the same files as before *)
+
+Require Import Le Lt.
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index 8cd195f8..64764830 100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -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 @@
 
 (** Well-founded relations and natural numbers *)
 
-Require Import Lt.
+Require Import PeanoNat Lt.
 
 Local Open Scope nat_scope.
 
@@ -24,16 +24,12 @@ Definition gtof (a b:A) := f b > f a.
 
 Theorem well_founded_ltof : well_founded ltof.
 Proof.
-  red.
-  cut (forall n (a:A), f a < n -> Acc ltof a).
-  intros H a; apply (H (S (f a))); auto with arith.
-  induction n.
-  intros; absurd (f a < 0); auto with arith.
-  intros a ltSma.
-  apply Acc_intro.
-  unfold ltof; intros b ltfafb.
-  apply IHn.
-  apply lt_le_trans with (f a); auto with arith.
+  assert (H : forall n (a:A), f a < n -> Acc ltof a).
+  { induction n.
+    - intros; absurd (f a < 0); auto with arith.
+    - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb.
+      apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
+  intros a. apply (H (S (f a))). auto with arith.
 Defined.
 
 Theorem well_founded_gtof : well_founded gtof.
@@ -67,15 +63,13 @@ Theorem induction_ltof1 :
   forall P:A -> Set,
     (forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
 Proof.
-  intros P F; cut (forall n (a:A), f a < n -> P a).
-  intros H a; apply (H (S (f a))); auto with arith.
-  induction n.
-  intros; absurd (f a < 0); auto with arith.
-  intros a ltSma.
-  apply F.
-  unfold ltof; intros b ltfafb.
-  apply IHn.
-  apply lt_le_trans with (f a); auto with arith.
+  intros P F.
+  assert (H : forall n (a:A), f a < n -> P a).
+  { induction n.
+    - intros; absurd (f a < 0); auto with arith.
+    - intros a Ha. apply F. unfold ltof. intros b Hb.
+      apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
+  intros a. apply (H (S (f a))). auto with arith.
 Defined.
 
 Theorem induction_gtof1 :
@@ -108,16 +102,12 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y.
 
 Theorem well_founded_lt_compat : well_founded R.
 Proof.
-  red.
-  cut (forall n (a:A), f a < n -> Acc R a).
-  intros H a; apply (H (S (f a))); auto with arith.
-  induction n.
-  intros; absurd (f a < 0); auto with arith.
-  intros a ltSma.
-  apply Acc_intro.
-  intros b ltfafb.
-  apply IHn.
-  apply lt_le_trans with (f a); auto with arith.
+  assert (H : forall n (a:A), f a < n -> Acc R a).
+  { induction n.
+    - intros; absurd (f a < 0); auto with arith.
+    - intros a Ha. apply Acc_intro. intros b Hb.
+      apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
+  intros a. apply (H (S (f a))). auto with arith.
 Defined.
 
 End Well_founded_Nat.
@@ -208,6 +198,7 @@ End LT_WF_REL.
 
 Lemma well_founded_inv_rel_inv_lt_rel :
   forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F).
+Proof.
   intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial.
 Qed.
 
@@ -230,34 +221,20 @@ Proof.
   intros P Pdec (n0,HPn0).
   assert
     (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'')
-      \/(forall n', P n' -> n<=n')).
-  induction n.
-  right.
-  intros n' Hn'.
-  apply le_O_n.
-  destruct IHn.
-  left; destruct H as (n', (Hlt', HPn')).
-  exists n'; split.
-  apply lt_S; assumption.
-  assumption.
-  destruct (Pdec n).
-  left; exists n; split.
-  apply lt_n_Sn.
-  split; assumption.
-  right.
-  intros n' Hltn'.
-  destruct (le_lt_eq_dec n n') as [Hltn|Heqn].
-  apply H; assumption.
-  assumption.
-  destruct H0.
-  rewrite Heqn; assumption.
-  destruct (H n0) as [(n,(Hltn,(Hmin,Huniqn)))|]; [exists n | exists n0];
-    repeat split;
-      assumption || intros n' (HPn',Hminn'); apply le_antisym; auto.
+               \/ (forall n', P n' -> n<=n')).
+  { induction n.
+    - right. intros. apply Nat.le_0_l.
+    - destruct IHn as [(n' & IH1 & IH2)|IH].
+      + left. exists n'; auto with arith.
+      + destruct (Pdec n) as [HP|HP].
+        * left. exists n; auto with arith.
+        * right. intros n' Hn'.
+          apply Nat.le_neq; split; auto. intros <-. auto. }
+  destruct (H n0) as [(n & H1 & H2 & H3)|H0]; [exists n | exists n0];
+   repeat split; trivial;
+   intros n' (HPn',Hn'); apply Nat.le_antisymm; auto.
 Qed.
 
 Unset Implicit Arguments.
 
-Notation iter_nat := @nat_iter (only parsing).
-Notation iter_nat_plus := @nat_iter_plus (only parsing).
-Notation iter_nat_invariant := @nat_iter_invariant (only parsing).
+Notation iter_nat n A f x := (nat_rect (fun _ => A) x (fun _ => f) n) (only parsing).
diff --git a/theories/Arith/vo.itarget b/theories/Arith/vo.itarget
index 0b6564e1..0b3d31e9 100644
--- a/theories/Arith/vo.itarget
+++ b/theories/Arith/vo.itarget
@@ -1,3 +1,4 @@
+PeanoNat.vo
 Arith_base.vo
 Arith.vo
 Between.vo
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
index 5ec8f806..cc12cf47 100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -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        *)
@@ -458,16 +458,22 @@ Notation demorgan4 := orb_andb_distrib_l (only parsing).
 
 (** Absorption *)
 
-Lemma absoption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
+Lemma absorption_andb : forall b1 b2:bool, b1 && (b1 || b2) = b1.
 Proof.
   destr_bool.
 Qed.
 
-Lemma absoption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
+Lemma absorption_orb : forall b1 b2:bool, b1 || b1 && b2 = b1.
 Proof.
   destr_bool.
 Qed.
 
+(* begin hide *)
+(* Compatibility *)
+Notation absoption_andb := absorption_andb (only parsing).
+Notation absoption_orb := absorption_orb (only parsing).
+(* end hide *)
+
 (*********************************)
 (** * Properties of [xorb]       *)
 (*********************************)
diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v
index 53892754..11af2fd1 100644
--- a/theories/Bool/BoolEq.v
+++ b/theories/Bool/BoolEq.v
@@ -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/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index 2b0e40a3..7c63f069 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -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        *)
@@ -60,13 +60,13 @@ Definition Bhigh := @Vector.tl bool.
 
 Definition Bsign := @Vector.last bool.
 
-Definition Bneg n (v : Bvector n) := Vector.map negb v.
+Definition Bneg := @Vector.map _ _ negb.
 
-Definition BVand n (v : Bvector n) := Vector.map2 andb v.
+Definition BVand := @Vector.map2 _ _ _ andb.
 
-Definition BVor n (v : Bvector n) := Vector.map2 orb v.
+Definition BVor := @Vector.map2 _ _ _ orb.
 
-Definition BVxor n (v : Bvector n) := Vector.map2 xorb v.
+Definition BVxor := @Vector.map2 _ _ _ xorb.
 
 Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) :=
   Bcons carry n (Vector.shiftout bv).
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index e89d31a4..e0b8ec9b 100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -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/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index c371f584..a0acbe8c 100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -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/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
index 4b61ebe7..c2e9183b 100644
--- a/theories/Bool/Sumbool.v
+++ b/theories/Bool/Sumbool.v
@@ -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/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
index b23544b3..e146f25f 100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -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/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v
new file mode 100644
index 00000000..65353ed2
--- /dev/null
+++ b/theories/Classes/CEquivalence.v
@@ -0,0 +1,139 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Typeclass-based setoids. Definitions on [Equivalence].
+
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+Require Import Coq.Program.Basics.
+Require Import Coq.Program.Tactics.
+
+Require Import Coq.Classes.Init.
+Require Import Relation_Definitions.
+Require Export Coq.Classes.CRelationClasses.
+Require Import Coq.Classes.CMorphisms.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Generalizable Variables A R eqA B S eqB.
+Local Obligation Tactic := try solve [simpl_crelation].
+
+Local Open Scope signature_scope.
+
+Definition equiv `{Equivalence A R} : crelation A := R.
+
+(** Overloaded notations for setoid equivalence and inequivalence.
+    Not to be confused with [eq] and [=]. *)
+
+Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope.
+
+Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope.
+
+Local Open Scope equiv_scope.
+
+(** Overloading for [PER]. *)
+
+Definition pequiv `{PER A R} : crelation A := R.
+
+(** Overloaded notation for partial equivalence. *)
+
+Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope.
+
+(** Shortcuts to make proof search easier. *)
+
+Program Instance equiv_reflexive `(sa : Equivalence A) : Reflexive equiv.
+
+Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv.
+
+Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv.
+
+  Next Obligation.
+  Proof. intros A R sa x y z Hxy Hyz.
+         now transitivity y.
+  Qed.
+
+(** Use the [substitute] command which substitutes an equivalence in every hypothesis. *)
+
+Ltac setoid_subst H :=
+  match type of H with
+    ?x === ?y => substitute H ; clear H x
+  end.
+
+Ltac setoid_subst_nofail :=
+  match goal with
+    | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail
+    | _ => idtac
+  end.
+
+(** [subst*] will try its best at substituting every equality in the goal. *)
+
+Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail.
+
+(** Simplify the goal w.r.t. equivalence. *)
+
+Ltac equiv_simplify_one :=
+  match goal with
+    | [ H : ?x === ?x |- _ ] => clear H
+    | [ H : ?x === ?y |- _ ] => setoid_subst H
+    | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name
+    | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name
+  end.
+
+Ltac equiv_simplify := repeat equiv_simplify_one.
+
+(** "reify" relations which are equivalences to applications of the overloaded [equiv] method
+   for easy recognition in tactics. *)
+
+Ltac equivify_tac :=
+  match goal with
+    | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H
+    | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y)
+  end.
+
+Ltac equivify := repeat equivify_tac.
+
+Section Respecting.
+
+  (** Here we build an equivalence instance for functions which relates respectful ones only,
+     we do not export it. *)
+
+  Definition respecting `(eqa : Equivalence A (R : crelation A), 
+                          eqb : Equivalence B (R' : crelation B)) : Type :=
+    { morph : A -> B & respectful R R' morph morph }.
+
+  Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') :
+    Equivalence (fun (f g : respecting eqa eqb) => 
+                   forall (x y : A), R x y -> R' (projT1 f x) (projT1 g y)).
+
+  Solve Obligations with unfold respecting in * ; simpl_crelation ; program_simpl.
+
+  Next Obligation.
+  Proof. 
+    intros. intros f g h H H' x y Rxy.
+    unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder.
+  Qed.
+
+End Respecting.
+
+(** The default equivalence on function spaces, with higher-priority than [eq]. *)
+
+Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) :
+  Reflexive (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) :
+  Symmetric (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_transitive {A} `(transb : Transitive B eqB) :
+  Transitive (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) :
+  Equivalence (pointwise_relation A eqB) | 9.
+Proof. split; apply _. Qed.
diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v
new file mode 100644
index 00000000..073cd5e9
--- /dev/null
+++ b/theories/Classes/CMorphisms.v
@@ -0,0 +1,701 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Typeclass-based morphism definition and standard, minimal instances
+
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+Require Import Coq.Program.Basics.
+Require Import Coq.Program.Tactics.
+Require Export Coq.Classes.CRelationClasses.
+
+Generalizable Variables A eqA B C D R RA RB RC m f x y.
+Local Obligation Tactic := simpl_crelation.
+
+Set Universe Polymorphism.
+
+(** * Morphisms.
+
+   We now turn to the definition of [Proper] and declare standard instances.
+   These will be used by the [setoid_rewrite] tactic later. *)
+
+(** A morphism for a relation [R] is a proper element of the relation.
+   The relation [R] will be instantiated by [respectful] and [A] by an arrow
+   type for usual morphisms. *)
+Section Proper.
+  Context {A B : Type}.
+
+  Class Proper (R : crelation A) (m : A) :=
+    proper_prf : R m m.
+
+  (** Every element in the carrier of a reflexive relation is a morphism
+   for this relation.  We use a proxy class for this case which is used
+   internally to discharge reflexivity constraints.  The [Reflexive]
+   instance will almost always be used, but it won't apply in general to
+   any kind of [Proper (A -> B) _ _] goal, making proof-search much
+   slower. A cleaner solution would be to be able to set different
+   priorities in different hint bases and select a particular hint
+   database for resolution of a type class constraint. *)
+
+  Class ProperProxy (R : crelation A) (m : A) :=
+    proper_proxy : R m m.
+
+  Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x.
+  Proof. firstorder. Qed.
+  
+  Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x.
+  Proof. firstorder. Qed.
+
+  Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x.
+  Proof. firstorder. Qed.
+
+  (** Respectful morphisms. *)
+  
+  (** The fully dependent version, not used yet. *)
+  
+  Definition respectful_hetero
+  (A B : Type)
+  (C : A -> Type) (D : B -> Type)
+  (R : A -> B -> Type)
+  (R' : forall (x : A) (y : B), C x -> D y -> Type) :
+    (forall x : A, C x) -> (forall x : B, D x) -> Type :=
+    fun f g => forall x y, R x y -> R' x y (f x) (g y).
+
+  (** The non-dependent version is an instance where we forget dependencies. *)
+  
+  Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
+    Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').
+End Proper.
+
+(** We favor the use of Leibniz equality or a declared reflexive crelation 
+  when resolving [ProperProxy], otherwise, if the crelation is given (not an evar),
+  we fall back to [Proper]. *)
+Hint Extern 1 (ProperProxy _ _) => 
+  class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances.
+
+Hint Extern 2 (ProperProxy ?R _) => 
+  not_evar R; class_apply @proper_proper_proxy : typeclass_instances.
+
+(** Notations reminiscent of the old syntax for declaring morphisms. *)
+Delimit Scope signature_scope with signature.
+
+Module ProperNotations.
+
+  Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature))
+    (right associativity, at level 55) : signature_scope.
+
+  Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature))
+    (right associativity, at level 55) : signature_scope.
+
+  Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature))
+    (right associativity, at level 55) : signature_scope.
+
+End ProperNotations.
+
+Arguments Proper {A}%type R%signature m.
+Arguments respectful {A B}%type (R R')%signature _ _.
+
+Export ProperNotations.
+
+Local Open Scope signature_scope.
+
+(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f]
+    by repeated introductions and setoid rewrites. It should work
+    fine when [f] is a combination of already known morphisms and
+    quantifiers. *)
+
+Ltac solve_respectful t :=
+ match goal with
+   | |- respectful _ _ _ _ =>
+     let H := fresh "H" in
+     intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t)
+   | _ => t; reflexivity
+ end.
+
+Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac).
+
+(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences.
+    For example, if we know that [f] is a morphism for [E1==>E2==>E],
+    then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv]
+    into the subgoals [E1 x x'] and [E2 y y'].
+*)
+
+Ltac f_equiv :=
+ match goal with
+  | |- ?R (?f ?x) (?f' _) =>
+    let T := type of x in
+    let Rx := fresh "R" in
+    evar (Rx : crelation T);
+    let H := fresh in
+    assert (H : (Rx==>R)%signature f f');
+    unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ]
+  | |- ?R ?f ?f' =>
+    solve [change (Proper R f); eauto with typeclass_instances | reflexivity ]
+  | _ => idtac
+ end.
+
+Section Relations.
+  Context {A B : Type}. 
+
+  (** [forall_def] reifies the dependent product as a definition. *)
+  
+  Definition forall_def (P : A -> Type) : Type := forall x : A, P x.
+  
+  (** Dependent pointwise lifting of a crelation on the range. *)
+  
+  Definition forall_relation (P : A -> Type)
+             (sig : forall a, crelation (P a)) : crelation (forall x, P x) :=
+    fun f g => forall a, sig a (f a) (g a).
+
+  (** Non-dependent pointwise lifting *)
+  Definition pointwise_relation (R : crelation B) : crelation (A -> B) :=
+    fun f g => forall a, R (f a) (g a).
+
+  Lemma pointwise_pointwise (R : crelation B) :
+    relation_equivalence (pointwise_relation R) (@eq A ==> R).
+  Proof. intros. split. simpl_crelation. firstorder. Qed.
+  
+  (** Subcrelations induce a morphism on the identity. *)
+  
+  Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id.
+  Proof. firstorder. Qed.
+
+  (** The subrelation property goes through products as usual. *)
+  
+  Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') :
+    subrelation (RA ==> RB) (RA' ==> RB').
+  Proof. simpl_crelation. Qed.
+
+  (** And of course it is reflexive. *)
+  
+  Lemma subrelation_refl R : @subrelation A R R.
+  Proof. simpl_crelation. Qed.
+
+  (** [Proper] is itself a covariant morphism for [subrelation].
+   We use an unconvertible premise to avoid looping.
+   *)
+  
+  Lemma subrelation_proper `(mor : Proper A R' m) 
+        `(unc : Unconvertible (crelation A) R R')
+        `(sub : subrelation A R' R) : Proper R m.
+  Proof.
+    intros. apply sub. apply mor.
+  Qed.
+
+  Global Instance proper_subrelation_proper_arrow :
+    Proper (subrelation ++> eq ==> arrow) (@Proper A).
+  Proof. reduce. subst. firstorder. Qed.
+
+  Global Instance pointwise_subrelation `(sub : subrelation B R R') :
+    subrelation (pointwise_relation R) (pointwise_relation R') | 4.
+  Proof. reduce. unfold pointwise_relation in *. apply sub. auto. Qed.
+  
+  (** For dependent function types. *)
+  Lemma forall_subrelation (P : A -> Type) (R S : forall x : A, crelation (P x)) :
+    (forall a, subrelation (R a) (S a)) -> 
+    subrelation (forall_relation P R) (forall_relation P S).
+  Proof. reduce. firstorder. Qed.
+End Relations.
+Typeclasses Opaque respectful pointwise_relation forall_relation.
+Arguments forall_relation {A P}%type sig%signature _ _.
+Arguments pointwise_relation A%type {B}%type R%signature _ _.
+  
+Hint Unfold Reflexive : core.
+Hint Unfold Symmetric : core.
+Hint Unfold Transitive : core.
+
+(** Resolution with subrelation: favor decomposing products over applying reflexivity
+  for unconstrained goals. *)
+Ltac subrelation_tac T U :=
+  (is_ground T ; is_ground U ; class_apply @subrelation_refl) ||
+    class_apply @subrelation_respectful || class_apply @subrelation_refl.
+
+Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances.
+
+CoInductive apply_subrelation : Prop := do_subrelation.
+
+Ltac proper_subrelation :=
+  match goal with
+    [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper
+  end.
+
+Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances.
+
+(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *)
+
+Instance iff_impl_subrelation : subrelation iff impl | 2.
+Proof. firstorder. Qed.
+
+Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2.
+Proof. firstorder. Qed.
+
+(** Essential subrelation instances for [iffT] and [arrow]. *)
+
+Instance iffT_arrow_subrelation : subrelation iffT arrow | 2.
+Proof. firstorder. Qed.
+
+Instance iffT_flip_arrow_subrelation : subrelation iffT (flip arrow) | 2.
+Proof. firstorder. Qed.
+
+(** We use an extern hint to help unification. *)
+
+Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) =>
+  apply (@forall_subrelation A B R S) ; intro : typeclass_instances.
+
+Section GenericInstances.
+  (* Share universes *)
+  Context {A B C : Type}.
+
+  (** We can build a PER on the Coq function space if we have PERs on the domain and
+   codomain. *)
+  
+  Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R').
+
+  Next Obligation.
+  Proof with auto.
+    assert(R x0 x0).
+    transitivity y0... symmetry...
+    transitivity (y x0)...
+  Qed.
+
+  (** The complement of a crelation conserves its proper elements. *)
+  
+  Program Definition complement_proper
+          `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
+    Proper (RA ==> RA ==> iff) (complement R) := _.
+  
+  Next Obligation.
+  Proof.
+    unfold complement.
+    pose (mR x y X x0 y0 X0).
+    intuition.
+  Qed.
+ 
+  (** The [flip] too, actually the [flip] instance is a bit more general. *)
+
+  Program Definition flip_proper
+          `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
+    Proper (RB ==> RA ==> RC) (flip f) := _.
+  
+  Next Obligation.
+  Proof.
+    apply mor ; auto.
+  Qed.
+
+
+  (** Every Transitive crelation gives rise to a binary morphism on [impl],
+   contravariant in the first argument, covariant in the second. *)
+  
+  Global Program 
+  Instance trans_contra_co_type_morphism
+    `(Transitive A R) : Proper (R --> R ++> arrow) R.
+  
+  Next Obligation.
+  Proof with auto.
+    transitivity x...
+    transitivity x0...
+  Qed.
+
+  (** Proper declarations for partial applications. *)
+
+  Global Program 
+  Instance trans_contra_inv_impl_type_morphism
+  `(Transitive A R) : Proper (R --> flip arrow) (R x) | 3.
+
+  Next Obligation.
+  Proof with auto.
+    transitivity y...
+  Qed.
+
+  Global Program 
+  Instance trans_co_impl_type_morphism
+    `(Transitive A R) : Proper (R ++> arrow) (R x) | 3.
+
+  Next Obligation.
+  Proof with auto.
+    transitivity x0...
+  Qed.
+
+  Global Program 
+  Instance trans_sym_co_inv_impl_type_morphism
+    `(PER A R) : Proper (R ++> flip arrow) (R x) | 3.
+
+  Next Obligation.
+  Proof with auto.
+    transitivity y... symmetry...
+  Qed.
+
+  Global Program Instance trans_sym_contra_arrow_morphism
+    `(PER A R) : Proper (R --> arrow) (R x) | 3.
+
+  Next Obligation.
+  Proof with auto.
+    transitivity x0... symmetry...
+  Qed.
+
+  Global Program Instance per_partial_app_type_morphism
+  `(PER A R) : Proper (R ==> iffT) (R x) | 2.
+
+  Next Obligation.
+  Proof with auto.
+    split. intros ; transitivity x0...
+    intros.
+    transitivity y...
+    symmetry...
+  Qed.
+
+  (** Every Transitive crelation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *)
+
+  Global Program 
+  Instance trans_co_eq_inv_arrow_morphism
+  `(Transitive A R) : Proper (R ==> (@eq A) ==> flip arrow) R | 2.
+
+  Next Obligation.
+  Proof with auto.
+    transitivity y...
+  Qed.
+
+  (** Every Symmetric and Transitive crelation gives rise to an equivariant morphism. *)
+
+  Global Program 
+  Instance PER_type_morphism `(PER A R) : Proper (R ==> R ==> iffT) R | 1.
+
+  Next Obligation.
+  Proof with auto.
+    split ; intros.
+    transitivity x0... transitivity x... symmetry...
+
+    transitivity y... transitivity y0... symmetry...
+  Qed.
+
+  Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R).
+  Proof. firstorder. Qed.
+
+  Global Program Instance compose_proper RA RB RC :
+    Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C).
+
+  Next Obligation.
+  Proof.
+    simpl_crelation.
+    unfold compose. firstorder. 
+  Qed.
+
+  (** Coq functions are morphisms for Leibniz equality,
+     applied only if really needed. *)
+
+  Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') :
+    Reflexive (@Logic.eq A ==> R').
+  Proof. simpl_crelation. Qed.
+
+  (** [respectful] is a morphism for crelation equivalence . *)
+  Set Printing All. Set Printing Universes.
+  Global Instance respectful_morphism :
+    Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) 
+           (@respectful A B).
+  Proof. 
+    intros R R' HRR' S S' HSS' f g. 
+    unfold respectful , relation_equivalence in *; simpl in *.
+    split ; intros H x y Hxy.
+    apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)). 
+    apply (snd (HSS' _ _)). apply H. now apply (fst (HRR' _ _)). 
+  Qed.
+
+  (** [R] is Reflexive, hence we can build the needed proof. *)
+
+  Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
+    Proper R' (m x).
+  Proof. simpl_crelation. Qed.
+  
+  Class Params (of : A) (arity : nat).
+    
+  Lemma flip_respectful (R : crelation A) (R' : crelation B) :
+    relation_equivalence (flip (R ==> R')) (flip R ==> flip R').
+  Proof.
+    intros.
+    unfold flip, respectful.
+    split ; intros ; intuition.
+  Qed.
+
+  
+  (** Treating flip: can't make them direct instances as we
+   need at least a [flip] present in the goal. *)
+  
+  Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R.
+  Proof. firstorder. Qed.
+  
+  Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')).
+  Proof. firstorder. Qed.
+  
+  (** That's if and only if *)
+  
+  Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R.
+  Proof. simpl_crelation. Qed.
+
+  (** Once we have normalized, we will apply this instance to simplify the problem. *)
+  
+  Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor.
+  
+  (** Every reflexive crelation gives rise to a morphism, 
+  only for immediately solving goals without variables. *)
+  
+  Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x.
+  Proof. firstorder. Qed.
+  
+  Lemma proper_eq (x : A) : Proper (@eq A) x.
+  Proof. intros. apply reflexive_proper. Qed.
+  
+End GenericInstances.
+
+Class PartialApplication.
+
+CoInductive normalization_done : Prop := did_normalization.
+
+Ltac partial_application_tactic :=
+  let rec do_partial_apps H m cont := 
+    match m with
+      | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; 
+        [(do_partial_apps H m' ltac:idtac)|clear H]
+      | _ => cont
+    end
+  in
+  let rec do_partial H ar m := 
+    match ar with
+      | 0%nat => do_partial_apps H m ltac:(fail 1)
+      | S ?n' =>
+        match m with
+          ?m' ?x => do_partial H n' m'
+        end
+    end
+  in
+  let params m sk fk :=
+    (let m' := fresh in head_of_constr m' m ;
+     let n := fresh in evar (n:nat) ;
+     let v := eval compute in n in clear n ;
+      let H := fresh in
+        assert(H:Params m' v) by typeclasses eauto ;
+          let v' := eval compute in v in subst m';
+            (sk H v' || fail 1))
+    || fk
+  in
+  let on_morphism m cont :=
+    params m ltac:(fun H n => do_partial H n m)
+      ltac:(cont)
+  in
+  match goal with
+    | [ _ : normalization_done |- _ ] => fail 1
+    | [ _ : @Params _ _ _ |- _ ] => fail 1
+    | [ |- @Proper ?T _ (?m ?x) ] =>
+      match goal with
+        | [ H : PartialApplication |- _ ] =>
+          class_apply @Reflexive_partial_app_morphism; [|clear H]
+        | _ => on_morphism (m x)
+          ltac:(class_apply @Reflexive_partial_app_morphism)
+      end
+  end.
+
+(** Bootstrap !!! *)
+
+Instance proper_proper : Proper (relation_equivalence ==> eq ==> iffT) (@Proper A).
+Proof.
+  intros A R R' HRR' x y <-. red in HRR'.
+  split ; red ; intros. 
+  now apply (fst (HRR' _ _)). 
+  now apply (snd (HRR' _ _)).
+Qed.
+
+Ltac proper_reflexive :=
+  match goal with
+    | [ _ : normalization_done |- _ ] => fail 1
+    | _ => class_apply proper_eq || class_apply @reflexive_proper
+  end.
+
+
+Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances.
+Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances.
+
+Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper 
+  : typeclass_instances.
+Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper 
+  : typeclass_instances.
+Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper 
+  : typeclass_instances.
+Hint Extern 4 (@Proper _ _ _) => partial_application_tactic 
+  : typeclass_instances.
+Hint Extern 7 (@Proper _ _ _) => proper_reflexive 
+  : typeclass_instances.
+
+(** Special-purpose class to do normalization of signatures w.r.t. flip. *)
+
+Section Normalize.
+  Context (A : Type).
+
+  Class Normalizes (m : crelation A) (m' : crelation A) : Prop :=
+    normalizes : relation_equivalence m m'.
+  
+  (** Current strategy: add [flip] everywhere and reduce using [subrelation]
+   afterwards. *)
+
+  Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m.
+  Proof.
+    red in H, H0. red in H.
+    apply (snd (H _ _)). 
+    assumption.
+  Qed.
+
+  Lemma flip_atom R : Normalizes R (flip (flip R)).
+  Proof.
+    firstorder.
+  Qed.
+
+End Normalize.
+
+Lemma flip_arrow `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) :
+  Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature).
+Proof. 
+  unfold Normalizes in *. intros.
+  rewrite NA, NB. firstorder. 
+Qed.
+
+Ltac normalizes :=
+  match goal with
+    | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow
+    | _ => class_apply @flip_atom
+  end.
+
+Ltac proper_normalization :=
+  match goal with
+    | [ _ : normalization_done |- _ ] => fail 1
+    | [ _ : apply_subrelation |- @Proper _ ?R _ ] => 
+      let H := fresh "H" in
+      set(H:=did_normalization) ; class_apply @proper_normalizes_proper
+  end.
+
+Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances.
+Hint Extern 6 (@Proper _ _ _) => proper_normalization 
+  : typeclass_instances.
+
+(** When the crelation on the domain is symmetric, we can
+    flip the crelation on the codomain. Same for binary functions. *)
+
+Lemma proper_sym_flip :
+ forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f),
+ Proper (R1==>flip R2) f.
+Proof.
+intros A R1 Sym B R2 f Hf.
+intros x x' Hxx'. apply Hf, Sym, Hxx'.
+Qed.
+
+Lemma proper_sym_flip_2 :
+ forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f),
+ Proper (R1==>R2==>flip R3) f.
+Proof.
+intros A R1 Sym1 B R2 Sym2 C R3 f Hf.
+intros x x' Hxx' y y' Hyy'. apply Hf; auto.
+Qed.
+
+(** When the crelation on the domain is symmetric, a predicate is
+  compatible with [iff] as soon as it is compatible with [impl].
+  Same with a binary crelation. *)
+
+Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f),
+ Proper (R==>iff) f.
+Proof.
+intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto.
+Qed.
+
+Lemma proper_sym_arrow_iffT : forall `(Symmetric A R)`(Proper _ (R==>arrow) f),
+ Proper (R==>iffT) f.
+Proof.
+intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto.
+Qed.
+
+Lemma proper_sym_impl_iff_2 :
+ forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f),
+ Proper (R==>R'==>iff) f.
+Proof.
+intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'.
+repeat red in Hf. split; eauto.
+Qed.
+
+Lemma proper_sym_arrow_iffT_2 :
+ forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>arrow) f),
+ Proper (R==>R'==>iffT) f.
+Proof.
+intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'.
+repeat red in Hf. split; eauto.
+Qed.
+
+(** A [PartialOrder] is compatible with its underlying equivalence. *)
+Require Import Relation_Definitions.
+
+Instance PartialOrder_proper_type `(PartialOrder A eqA R) :
+  Proper (eqA==>eqA==>iffT) R.
+Proof.
+intros.
+apply proper_sym_arrow_iffT_2; auto with *.
+intros x x' Hx y y' Hy Hr.
+transitivity x.
+generalize (partial_order_equivalence x x'); compute; intuition.
+transitivity y; auto.
+generalize (partial_order_equivalence y y'); compute; intuition.
+Qed.
+
+(** From a [PartialOrder] to the corresponding [StrictOrder]:
+     [lt = le /\ ~eq].
+    If the order is total, we could also say [gt = ~le]. *)
+
+Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) :
+  StrictOrder (relation_conjunction R (complement eqA)).
+Proof.
+split; compute.
+intros x (_,Hx). apply Hx, Equivalence_Reflexive.
+intros x y z (Hxy,Hxy') (Hyz,Hyz'). split.
+apply PreOrder_Transitive with y; assumption.
+intro Hxz.
+apply Hxy'.
+apply partial_order_antisym; auto.
+rewrite Hxz. auto.
+Qed.
+
+(** From a [StrictOrder] to the corresponding [PartialOrder]:
+     [le = lt \/ eq].
+    If the order is total, we could also say [ge = ~lt]. *)
+
+Lemma StrictOrder_PreOrder
+ `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) :
+ PreOrder (relation_disjunction R eqA).
+Proof.
+split.
+intros x. right. reflexivity.
+intros x y z [Hxy|Hxy] [Hyz|Hyz].
+left. transitivity y; auto.
+left. rewrite <- Hyz; auto.
+left. rewrite Hxy; auto.
+right. transitivity y; auto.
+Qed.
+
+Hint Extern 4 (PreOrder (relation_disjunction _ _)) => 
+  class_apply StrictOrder_PreOrder : typeclass_instances.
+
+Lemma StrictOrder_PartialOrder
+  `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iffT) R) :
+  PartialOrder eqA (relation_disjunction R eqA).
+Proof.
+intros. intros x y. compute. intuition.
+elim (StrictOrder_Irreflexive x).
+transitivity y; auto.
+Qed.
+
+Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => 
+  class_apply PartialOrder_StrictOrder : typeclass_instances.
+
+Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => 
+  class_apply StrictOrder_PartialOrder : typeclass_instances.
diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v
new file mode 100644
index 00000000..35b2b8a3
--- /dev/null
+++ b/theories/Classes/CRelationClasses.v
@@ -0,0 +1,359 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Typeclass-based relations, tactics and standard instances
+
+   This is the basic theory needed to formalize morphisms and setoids.
+
+   Author: Matthieu Sozeau
+   Institution: LRI, CNRS UMR 8623 - University Paris Sud
+*)
+
+Require Export Coq.Classes.Init.
+Require Import Coq.Program.Basics.
+Require Import Coq.Program.Tactics.
+
+Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.
+
+Set Universe Polymorphism.
+
+Definition crelation (A : Type) := A -> A -> Type.
+
+Definition arrow (A B : Type) := A -> B.
+
+Definition flip {A B C : Type} (f : A -> B -> C) := fun x y => f y x.
+
+Definition iffT (A B : Type) := ((A -> B) * (B -> A))%type.
+
+(** We allow to unfold the [crelation] definition while doing morphism search. *)
+
+Section Defs.
+  Context {A : Type}.
+
+  (** We rebind crelational properties in separate classes to be able to overload each proof. *)
+
+  Class Reflexive (R : crelation A) :=
+    reflexivity : forall x : A, R x x.
+
+  Definition complement (R : crelation A) : crelation A := 
+    fun x y => R x y -> False.
+
+  (** Opaque for proof-search. *)
+  Typeclasses Opaque complement iffT.
+  
+  (** These are convertible. *)
+  Lemma complement_inverse R : complement (flip R) = flip (complement R).
+  Proof. reflexivity. Qed.
+
+  Class Irreflexive (R : crelation A) :=
+    irreflexivity : Reflexive (complement R).
+
+  Class Symmetric (R : crelation A) :=
+    symmetry : forall {x y}, R x y -> R y x.
+  
+  Class Asymmetric (R : crelation A) :=
+    asymmetry : forall {x y}, R x y -> (complement R y x : Type).
+  
+  Class Transitive (R : crelation A) :=
+    transitivity : forall {x y z}, R x y -> R y z -> R x z.
+
+  (** Various combinations of reflexivity, symmetry and transitivity. *)
+  
+  (** A [PreOrder] is both Reflexive and Transitive. *)
+
+  Class PreOrder (R : crelation A)  := {
+    PreOrder_Reflexive :> Reflexive R | 2 ;
+    PreOrder_Transitive :> Transitive R | 2 }.
+
+  (** A [StrictOrder] is both Irreflexive and Transitive. *)
+
+  Class StrictOrder (R : crelation A)  := {
+    StrictOrder_Irreflexive :> Irreflexive R ;
+    StrictOrder_Transitive :> Transitive R }.
+
+  (** By definition, a strict order is also asymmetric *)
+  Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R.
+  Proof. firstorder. Qed.
+
+  (** A partial equivalence crelation is Symmetric and Transitive. *)
+  
+  Class PER (R : crelation A)  := {
+    PER_Symmetric :> Symmetric R | 3 ;
+    PER_Transitive :> Transitive R | 3 }.
+
+  (** Equivalence crelations. *)
+
+  Class Equivalence (R : crelation A)  := {
+    Equivalence_Reflexive :> Reflexive R ;
+    Equivalence_Symmetric :> Symmetric R ;
+    Equivalence_Transitive :> Transitive R }.
+
+  (** An Equivalence is a PER plus reflexivity. *)
+  
+  Global Instance Equivalence_PER {R} `(Equivalence R) : PER R | 10 :=
+    { PER_Symmetric := Equivalence_Symmetric ;
+      PER_Transitive := Equivalence_Transitive }.
+
+  (** We can now define antisymmetry w.r.t. an equivalence crelation on the carrier. *)
+  
+  Class Antisymmetric eqA `{equ : Equivalence eqA} (R : crelation A) :=
+    antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.
+
+  Class subrelation (R R' : crelation A) :=
+    is_subrelation : forall {x y}, R x y -> R' x y.
+  
+  (** Any symmetric crelation is equal to its inverse. *)
+  
+  Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R.
+  Proof. hnf. intros x y H'. red in H'. apply symmetry. assumption. Qed.
+
+  Section flip.
+  
+    Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R).
+    Proof. tauto. Qed.
+    
+    Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) :=
+      irreflexivity (R:=R).
+    
+    Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) :=
+      fun x y H => symmetry (R:=R) H.
+    
+    Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) :=
+      fun x y H H' => asymmetry (R:=R) H H'.
+    
+    Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) :=
+      fun x y z H H' => transitivity (R:=R) H' H.
+
+    Program Definition flip_Antisymmetric `(Antisymmetric eqA R) :
+      Antisymmetric eqA (flip R).
+    Proof. firstorder. Qed.
+
+    (** Inversing the larger structures *)
+
+    Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_PER `(PER R) : PER (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R).
+    Proof. firstorder. Qed.
+
+  End flip.
+
+  Section complement.
+
+    Definition complement_Irreflexive `(Reflexive R)
+      : Irreflexive (complement R).
+    Proof. firstorder. Qed.
+
+    Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R).
+    Proof. firstorder. Qed.
+  End complement.
+
+
+  (** Rewrite crelation on a given support: declares a crelation as a rewrite
+   crelation for use by the generalized rewriting tactic.
+   It helps choosing if a rewrite should be handled
+   by the generalized or the regular rewriting tactic using leibniz equality.
+   Users can declare an [RewriteRelation A RA] anywhere to declare default
+   crelations. This is also done automatically by the [Declare Relation A RA]
+   commands. *)
+
+  Class RewriteRelation (RA : crelation A).
+
+  (** Any [Equivalence] declared in the context is automatically considered
+   a rewrite crelation. *)
+    
+  Global Instance equivalence_rewrite_crelation `(Equivalence eqA) : RewriteRelation eqA.
+
+  (** Leibniz equality. *)
+  Section Leibniz.
+    Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A.
+    Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A.
+    Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A.
+    
+    (** Leibinz equality [eq] is an equivalence crelation.
+        The instance has low priority as it is always applicable
+        if only the type is constrained. *)
+    
+    Global Program Instance eq_equivalence : Equivalence (@eq A) | 10.
+  End Leibniz.
+  
+End Defs.
+
+(** Default rewrite crelations handled by [setoid_rewrite]. *)
+Instance: RewriteRelation impl.
+Instance: RewriteRelation iff.
+
+(** Hints to drive the typeclass resolution avoiding loops
+ due to the use of full unification. *)
+Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
+Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
+Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances.
+
+Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
+Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
+Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
+Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
+Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances.
+Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
+Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances.
+Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances.
+
+Hint Extern 4 (subrelation (flip _) _) => 
+  class_apply @subrelation_symmetric : typeclass_instances.
+
+Hint Resolve irreflexivity : ord.
+
+Unset Implicit Arguments.
+
+(** A HintDb for crelations. *)
+
+Ltac solve_crelation :=
+  match goal with
+  | [ |- ?R ?x ?x ] => reflexivity
+  | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H
+  end.
+
+Hint Extern 4 => solve_crelation : crelations.
+
+(** We can already dualize all these properties. *)
+
+(** * Standard instances. *)
+
+Ltac reduce_hyp H :=
+  match type of H with
+    | context [ _ <-> _ ] => fail 1
+    | _ => red in H ; try reduce_hyp H
+  end.
+
+Ltac reduce_goal :=
+  match goal with
+    | [ |- _ <-> _ ] => fail 1
+    | _ => red ; intros ; try reduce_goal
+  end.
+
+Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid.
+
+Ltac reduce := reduce_goal.
+
+Tactic Notation "apply" "*" constr(t) :=
+  first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) |
+    refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ].
+
+Ltac simpl_crelation :=
+  unfold flip, impl, arrow ; try reduce ; program_simpl ;
+    try ( solve [ dintuition ]).
+
+Local Obligation Tactic := simpl_crelation.
+
+(** Logical implication. *)
+
+Program Instance impl_Reflexive : Reflexive impl.
+Program Instance impl_Transitive : Transitive impl.
+
+(** Logical equivalence. *)
+
+Instance iff_Reflexive : Reflexive iff := iff_refl.
+Instance iff_Symmetric : Symmetric iff := iff_sym.
+Instance iff_Transitive : Transitive iff := iff_trans.
+
+(** Logical equivalence [iff] is an equivalence crelation. *)
+
+Program Instance iff_equivalence : Equivalence iff. 
+Program Instance arrow_Reflexive : Reflexive arrow.
+Program Instance arrow_Transitive : Transitive arrow.
+
+Instance iffT_Reflexive : Reflexive iffT. 
+Proof. firstorder. Defined.
+Instance iffT_Symmetric : Symmetric iffT. 
+Proof. firstorder. Defined. 
+Instance iffT_Transitive : Transitive iffT.
+Proof. firstorder. Defined.
+
+(** We now develop a generalization of results on crelations for arbitrary predicates.
+   The resulting theory can be applied to homogeneous binary crelations but also to
+   arbitrary n-ary predicates. *)
+
+Local Open Scope list_scope.
+
+(** A compact representation of non-dependent arities, with the codomain singled-out. *)
+
+(** We define the various operations which define the algebra on binary crelations *)
+Section Binary.
+  Context {A : Type}.
+
+  Definition relation_equivalence : crelation (crelation A) :=
+    fun R R' => forall x y, iffT (R x y) (R' x y).
+
+  Global Instance: RewriteRelation relation_equivalence.
+  
+  Definition relation_conjunction (R : crelation A) (R' : crelation A) : crelation A :=
+    fun x y => prod (R x y) (R' x y).
+
+  Definition relation_disjunction (R : crelation A) (R' : crelation A) : crelation A :=
+    fun x y => sum (R x y) (R' x y).
+  
+  (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)
+  
+  Set Automatic Introduction.
+  
+  Global Instance relation_equivalence_equivalence :
+    Equivalence relation_equivalence.
+  Proof. split; red; unfold relation_equivalence, iffT. firstorder. 
+    firstorder. 
+    intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder.
+  Qed.
+    
+  Global Instance relation_implication_preorder : PreOrder (@subrelation A).
+  Proof. firstorder. Qed.
+
+  (** *** Partial Order.
+   A partial order is a preorder which is additionally antisymmetric.
+   We give an equivalent definition, up-to an equivalence crelation
+   on the carrier. *)
+
+  Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
+    partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)).
+  
+  (** The equivalence proof is sufficient for proving that [R] must be a
+   morphism for equivalence (see Morphisms).  It is also sufficient to
+   show that [R] is antisymmetric w.r.t. [eqA] *)
+
+  Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R.
+  Proof with auto.
+    reduce_goal.
+    apply H. firstorder.
+  Qed.
+
+  Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R).
+  Proof. unfold flip; constructor; unfold flip. intros. apply H. apply symmetry. apply X.
+         unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. Qed.
+End Binary.
+
+Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances.
+
+(** The partial order defined by subrelation and crelation equivalence. *)
+
+(* Program Instance subrelation_partial_order : *)
+(*   ! PartialOrder (crelation A) relation_equivalence subrelation. *)
+(* Obligation Tactic := idtac. *)
+
+(* Next Obligation. *)
+(* Proof. *)
+(*   intros x. refine (fun x => x). *)
+(* Qed. *)
+
+Typeclasses Opaque relation_equivalence.
+
+
diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v
new file mode 100644
index 00000000..9fe3d0fe
--- /dev/null
+++ b/theories/Classes/DecidableClass.v
@@ -0,0 +1,92 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * A typeclass to ease the handling of decidable properties. *)
+
+(** A proposition is decidable whenever it is reflected by a boolean. *)
+
+Class Decidable (P : Prop) := {
+  Decidable_witness : bool;
+  Decidable_spec : Decidable_witness = true <-> P
+}.
+
+(** Alternative ways of specifying the reflection property. *)
+
+Lemma Decidable_sound : forall P (H : Decidable P),
+  Decidable_witness = true -> P.
+Proof.
+intros P H Hp; apply -> Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_complete : forall P (H : Decidable P),
+  P -> Decidable_witness = true.
+Proof.
+intros P H Hp; apply <- Decidable_spec; assumption.
+Qed.
+
+Lemma Decidable_sound_alt : forall P (H : Decidable P),
+   ~ P -> Decidable_witness = false.
+Proof.
+intros P [wit spec] Hd; simpl; destruct wit; tauto.
+Qed.
+
+Lemma Decidable_complete_alt : forall P (H : Decidable P),
+  Decidable_witness = false -> ~ P.
+Proof.
+intros P [wit spec] Hd Hc; simpl in *; intuition congruence.
+Qed.
+
+(** The generic function that should be used to program, together with some
+  useful tactics. *)
+
+Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).
+
+Ltac _decide_ P H :=
+  let b := fresh "b" in
+  set (b := decide P) in *;
+  assert (H : decide P = b) by reflexivity;
+  clearbody b;
+  destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].
+
+Tactic Notation "decide" constr(P) "as" ident(H) :=
+  _decide_ P H.
+
+Tactic Notation "decide" constr(P) :=
+  let H := fresh "H" in _decide_ P H.
+
+(** Some usual instances. *)
+
+Require Import Bool Arith ZArith.
+
+Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
+  Decidable_witness := Bool.eqb x y
+}.
+Next Obligation.
+ apply eqb_true_iff.
+Qed.
+
+Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
+  Decidable_witness := Nat.eqb x y
+}.
+Next Obligation.
+ apply Nat.eqb_eq.
+Qed.
+
+Program Instance Decidable_le_nat : forall (x y : nat), Decidable (x <= y) := {
+  Decidable_witness := Nat.leb x y
+}.
+Next Obligation.
+ apply Nat.leb_le.
+Qed.
+
+Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
+  Decidable_witness := Z.eqb x y
+}.
+Next Obligation.
+ apply Z.eqb_eq.
+Qed.
diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v
index 8e3715ff..59e800c2 100644
--- a/theories/Classes/EquivDec.v
+++ b/theories/Classes/EquivDec.v
@@ -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        *)
@@ -53,7 +53,9 @@ Local Open Scope program_scope.
 
 (** Invert the branches. *)
 
-Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := swap_sumbool (x == y).
+Program Definition nequiv_dec `{EqDec A} (x y : A) : { x =/= y } + { x === y } := 
+          swap_sumbool (x == y).
+
 
 (** Overloaded notation for inequality. *)
 
@@ -138,8 +140,7 @@ Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq :=
       | _, _ => in_right
     end }.
 
-  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).
-
-  Next Obligation. destruct y ; intuition eauto. Defined.
+  Next Obligation. destruct y ; unfold not in *; eauto. Defined.
 
-  Solve Obligations using unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto).
+  Solve Obligations with unfold equiv, complement in * ; 
+    program_simpl ; intuition (discriminate || eauto).
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index 0e9adf64..c281af80 100644
--- a/theories/Classes/Equivalence.v
+++ b/theories/Classes/Equivalence.v
@@ -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        *)
@@ -24,7 +24,7 @@ Set Implicit Arguments.
 Unset Strict Implicit.
 
 Generalizable Variables A R eqA B S eqB.
-Local Obligation Tactic := simpl_relation.
+Local Obligation Tactic := try solve [simpl_relation].
 
 Local Open Scope signature_scope.
 
@@ -56,8 +56,8 @@ Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv.
 Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv.
 
   Next Obligation.
-  Proof.
-    transitivity y ; auto.
+  Proof. intros A R sa x y z Hxy Hyz.
+         now transitivity y.
   Qed.
 
 (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *)
@@ -105,27 +105,35 @@ Section Respecting.
   (** Here we build an equivalence instance for functions which relates respectful ones only,
      we do not export it. *)
 
-  Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type :=
+  Definition respecting `(eqa : Equivalence A (R : relation A), 
+                          eqb : Equivalence B (R' : relation B)) : Type :=
     { morph : A -> B | respectful R R' morph morph }.
 
   Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') :
-    Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)).
+    Equivalence (fun (f g : respecting eqa eqb) => 
+                   forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)).
 
-  Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl.
+  Solve Obligations with unfold respecting in * ; simpl_relation ; program_simpl.
 
   Next Obligation.
-  Proof.
-    unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity.
+  Proof. 
+    intros. intros f g h H H' x y Rxy.
+    unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder.
   Qed.
 
 End Respecting.
 
 (** The default equivalence on function spaces, with higher-priority than [eq]. *)
 
-Program Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) :
+Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) :
+  Reflexive (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) :
+  Symmetric (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_transitive {A} `(transb : Transitive B eqB) :
+  Transitive (pointwise_relation A eqB) | 9.
+Proof. firstorder. Qed.
+Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) :
   Equivalence (pointwise_relation A eqB) | 9.
-
-  Next Obligation.
-  Proof.
-    transitivity (y a) ; auto.
-  Qed.
+Proof. split; apply _. Qed.
diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v
index 1a56c1a3..9574cf85 100644
--- a/theories/Classes/Init.v
+++ b/theories/Classes/Init.v
@@ -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/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index 9d5a3233..1bdce654 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -18,7 +18,7 @@ Require Import Coq.Program.Tactics.
 Require Import Coq.Relations.Relation_Definitions.
 Require Export Coq.Classes.RelationClasses.
 
-Generalizable All Variables.
+Generalizable Variables A eqA B C D R RA RB RC m f x y.
 Local Obligation Tactic := simpl_relation.
 
 (** * Morphisms.
@@ -29,15 +29,39 @@ Local Obligation Tactic := simpl_relation.
 (** A morphism for a relation [R] is a proper element of the relation.
    The relation [R] will be instantiated by [respectful] and [A] by an arrow
    type for usual morphisms. *)
-
-Class Proper {A} (R : relation A) (m : A) : Prop :=
-  proper_prf : R m m.
-
-(** Respectful morphisms. *)
-
-(** The fully dependent version, not used yet. *)
-
-Definition respectful_hetero
+Section Proper.
+  Let U := Type.
+  Context {A B : U}.
+
+  Class Proper (R : relation A) (m : A) : Prop :=
+    proper_prf : R m m.
+
+  (** Every element in the carrier of a reflexive relation is a morphism
+   for this relation.  We use a proxy class for this case which is used
+   internally to discharge reflexivity constraints.  The [Reflexive]
+   instance will almost always be used, but it won't apply in general to
+   any kind of [Proper (A -> B) _ _] goal, making proof-search much
+   slower. A cleaner solution would be to be able to set different
+   priorities in different hint bases and select a particular hint
+   database for resolution of a type class constraint. *)
+
+  Class ProperProxy (R : relation A) (m : A) : Prop :=
+    proper_proxy : R m m.
+
+  Lemma eq_proper_proxy (x : A) : ProperProxy (@eq A) x.
+  Proof. firstorder. Qed.
+  
+  Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x.
+  Proof. firstorder. Qed.
+
+  Lemma proper_proper_proxy x `(Proper R x) : ProperProxy R x.
+  Proof. firstorder. Qed.
+
+  (** Respectful morphisms. *)
+  
+  (** The fully dependent version, not used yet. *)
+  
+  Definition respectful_hetero
   (A B : Type)
   (C : A -> Type) (D : B -> Type)
   (R : A -> B -> Prop)
@@ -45,18 +69,24 @@ Definition respectful_hetero
     (forall x : A, C x) -> (forall x : B, D x) -> Prop :=
     fun f g => forall x y, R x y -> R' x y (f x) (g y).
 
-(** The non-dependent version is an instance where we forget dependencies. *)
+  (** The non-dependent version is an instance where we forget dependencies. *)
+  
+  Definition respectful (R : relation A) (R' : relation B) : relation (A -> B) :=
+    Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').
 
-Definition respectful {A B : Type}
-  (R : relation A) (R' : relation B) : relation (A -> B) :=
-  Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').
+End Proper.
 
-(** Notations reminiscent of the old syntax for declaring morphisms. *)
+(** We favor the use of Leibniz equality or a declared reflexive relation 
+  when resolving [ProperProxy], otherwise, if the relation is given (not an evar),
+  we fall back to [Proper]. *)
+Hint Extern 1 (ProperProxy _ _) => 
+  class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances.
 
-Delimit Scope signature_scope with signature.
+Hint Extern 2 (ProperProxy ?R _) => 
+  not_evar R; class_apply @proper_proper_proxy : typeclass_instances.
 
-Arguments Proper {A}%type R%signature m.
-Arguments respectful {A B}%type (R R')%signature _ _.
+(** Notations reminiscent of the old syntax for declaring morphisms. *)
+Delimit Scope signature_scope with signature.
 
 Module ProperNotations.
 
@@ -66,11 +96,14 @@ Module ProperNotations.
   Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature))
     (right associativity, at level 55) : signature_scope.
 
-  Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature))
+  Notation " R --> R' " := (@respectful _ _ (flip (R%signature)) (R'%signature))
     (right associativity, at level 55) : signature_scope.
 
 End ProperNotations.
 
+Arguments Proper {A}%type R%signature m.
+Arguments respectful {A B}%type (R R')%signature _ _.
+
 Export ProperNotations.
 
 Local Open Scope signature_scope.
@@ -106,80 +139,89 @@ Ltac f_equiv :=
     assert (H : (Rx==>R)%signature f f');
     unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ]
   | |- ?R ?f ?f' =>
-    try reflexivity;
-    change (Proper R f); eauto with typeclass_instances; fail
+    solve [change (Proper R f); eauto with typeclass_instances | reflexivity ]
   | _ => idtac
  end.
 
-(** [forall_def] reifies the dependent product as a definition. *)
-
-Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x.
-
-(** Dependent pointwise lifting of a relation on the range. *)
-
-Definition forall_relation {A : Type} {B : A -> Type}
- (sig : forall a, relation (B a)) : relation (forall x, B x) :=
- fun f g => forall a, sig a (f a) (g a).
-
-Arguments forall_relation {A B}%type sig%signature _ _.
-
-(** Non-dependent pointwise lifting *)
+Section Relations.
+  Let U := Type.
+  Context {A B : U} (P : A -> U).
+
+  (** [forall_def] reifies the dependent product as a definition. *)
+  
+  Definition forall_def : Type := forall x : A, P x.
+  
+  (** Dependent pointwise lifting of a relation on the range. *)
+  
+  Definition forall_relation 
+             (sig : forall a, relation (P a)) : relation (forall x, P x) :=
+    fun f g => forall a, sig a (f a) (g a).
+
+  (** Non-dependent pointwise lifting *)
+  Definition pointwise_relation (R : relation B) : relation (A -> B) :=
+    fun f g => forall a, R (f a) (g a).
+
+  Lemma pointwise_pointwise (R : relation B) :
+    relation_equivalence (pointwise_relation R) (@eq A ==> R).
+  Proof. intros. split; reduce; subst; firstorder. Qed.
+  
+  (** Subrelations induce a morphism on the identity. *)
+  
+  Global Instance subrelation_id_proper `(subrelation A RA RA') : Proper (RA ==> RA') id.
+  Proof. firstorder. Qed.
+
+  (** The subrelation property goes through products as usual. *)
+  
+  Lemma subrelation_respectful `(subl : subrelation A RA' RA, subr : subrelation B RB RB') :
+    subrelation (RA ==> RB) (RA' ==> RB').
+  Proof. unfold subrelation in *; firstorder. Qed.
+
+  (** And of course it is reflexive. *)
+  
+  Lemma subrelation_refl R : @subrelation A R R.
+  Proof. unfold subrelation; firstorder. Qed.
+
+  (** [Proper] is itself a covariant morphism for [subrelation].
+   We use an unconvertible premise to avoid looping.
+   *)
+  
+  Lemma subrelation_proper `(mor : Proper A R' m) 
+        `(unc : Unconvertible (relation A) R R')
+        `(sub : subrelation A R' R) : Proper R m.
+  Proof.
+    intros. apply sub. apply mor.
+  Qed.
 
-Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) :=
-  Eval compute in forall_relation (B:=fun _ => B) (fun _ => R).
+  Global Instance proper_subrelation_proper :
+    Proper (subrelation ++> eq ==> impl) (@Proper A).
+  Proof. reduce. subst. firstorder. Qed.
 
-Lemma pointwise_pointwise A B (R : relation B) :
-  relation_equivalence (pointwise_relation A R) (@eq A ==> R).
-Proof. intros. split. simpl_relation. firstorder. Qed.
-
-(** We can build a PER on the Coq function space if we have PERs on the domain and
-   codomain. *)
+  Global Instance pointwise_subrelation `(sub : subrelation B R R') :
+    subrelation (pointwise_relation R) (pointwise_relation R') | 4.
+  Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed.
+  
+  (** For dependent function types. *)
+  Lemma forall_subrelation (R S : forall x : A, relation (P x)) :
+    (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S).
+  Proof. reduce. apply H. apply H0. Qed.
+End Relations.
 
+Typeclasses Opaque respectful pointwise_relation forall_relation.
+Arguments forall_relation {A P}%type sig%signature _ _.
+Arguments pointwise_relation A%type {B}%type R%signature _ _.
+  
 Hint Unfold Reflexive : core.
 Hint Unfold Symmetric : core.
 Hint Unfold Transitive : core.
 
-Typeclasses Opaque respectful pointwise_relation forall_relation.
-
-Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R').
-
-  Next Obligation.
-  Proof with auto.
-    assert(R x0 x0).
-    transitivity y0... symmetry...
-    transitivity (y x0)...
-  Qed.
-
-(** Subrelations induce a morphism on the identity. *)
-
-Instance subrelation_id_proper `(subrelation A R� R₂) : Proper (R� ==> R₂) id.
-Proof. firstorder. Qed.
-
-(** The subrelation property goes through products as usual. *)
-
-Lemma subrelation_respectful `(subl : subrelation A R₂ R�, subr : subrelation B S� S₂) :
-  subrelation (R� ==> S�) (R₂ ==> S₂).
-Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed.
-
-(** And of course it is reflexive. *)
-
-Lemma subrelation_refl A R : @subrelation A R R.
-Proof. simpl_relation. Qed.
-
+(** Resolution with subrelation: favor decomposing products over applying reflexivity
+  for unconstrained goals. *)
 Ltac subrelation_tac T U :=
   (is_ground T ; is_ground U ; class_apply @subrelation_refl) ||
     class_apply @subrelation_respectful || class_apply @subrelation_refl.
 
 Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances.
 
-(** [Proper] is itself a covariant morphism for [subrelation]. *)
-
-Lemma subrelation_proper `(mor : Proper A R� m, unc : Unconvertible (relation A) R� R₂,
-  sub : subrelation A R� R₂) : Proper R₂ m.
-Proof.
-  intros. apply sub. apply mor.
-Qed.
-
 CoInductive apply_subrelation : Prop := do_subrelation.
 
 Ltac proper_subrelation :=
@@ -189,117 +231,112 @@ Ltac proper_subrelation :=
 
 Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances.
 
-Instance proper_subrelation_proper :
-  Proper (subrelation ++> eq ==> impl) (@Proper A).
-Proof. reduce. subst. firstorder. Qed.
-
 (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *)
 
 Instance iff_impl_subrelation : subrelation iff impl | 2.
 Proof. firstorder. Qed.
 
-Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2.
+Instance iff_flip_impl_subrelation : subrelation iff (flip impl) | 2.
 Proof. firstorder. Qed.
 
-Instance pointwise_subrelation {A} `(sub : subrelation B R R') :
-  subrelation (pointwise_relation A R) (pointwise_relation A R') | 4.
-Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed.
-
-(** For dependent function types. *)
-Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) :
-  (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S).
-Proof. reduce. apply H. apply H0. Qed.
-
 (** We use an extern hint to help unification. *)
 
 Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) =>
   apply (@forall_subrelation A B R S) ; intro : typeclass_instances.
 
-(** Any symmetric relation is equal to its inverse. *)
-
-Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R.
-Proof. reduce. red in H0. symmetry. assumption. Qed.
+Section GenericInstances.
+  (* Share universes *)
+  Let U := Type.
+  Context {A B C : U}.
 
-Hint Extern 4 (subrelation (inverse _) _) => 
-  class_apply @subrelation_symmetric : typeclass_instances.
-
-(** The complement of a relation conserves its proper elements. *)
+  (** We can build a PER on the Coq function space if we have PERs on the domain and
+   codomain. *)
+  
+  Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R').
 
-Program Definition complement_proper
-  `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
-  Proper (RA ==> RA ==> iff) (complement R) := _.
+  Next Obligation.
+  Proof with auto.
+    assert(R x0 x0).
+    transitivity y0... symmetry...
+    transitivity (y x0)... 
+  Qed.
 
- Next Obligation.
+  (** The complement of a relation conserves its proper elements. *)
+  
+  Program Definition complement_proper
+          `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
+    Proper (RA ==> RA ==> iff) (complement R) := _.
+  
+  Next Obligation.
   Proof.
     unfold complement.
     pose (mR x y H x0 y0 H0).
     intuition.
   Qed.
  
-Hint Extern 1 (Proper _ (complement _)) => 
-  apply @complement_proper : typeclass_instances.
-
-(** The [inverse] too, actually the [flip] instance is a bit more general. *)
-
-Program Definition flip_proper
-  `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
-  Proper (RB ==> RA ==> RC) (flip f) := _.
+  (** The [flip] too, actually the [flip] instance is a bit more general. *)
 
+  Program Definition flip_proper
+          `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
+    Proper (RB ==> RA ==> RC) (flip f) := _.
+  
   Next Obligation.
   Proof.
     apply mor ; auto.
   Qed.
 
-Hint Extern 1 (Proper _ (flip _)) => 
-  apply @flip_proper : typeclass_instances.
 
-(** Every Transitive relation gives rise to a binary morphism on [impl],
+  (** Every Transitive relation gives rise to a binary morphism on [impl],
    contravariant in the first argument, covariant in the second. *)
-
-Program Instance trans_contra_co_morphism
-  `(Transitive A R) : Proper (R --> R ++> impl) R.
-
+  
+  Global Program 
+  Instance trans_contra_co_morphism
+    `(Transitive A R) : Proper (R --> R ++> impl) R.
+  
   Next Obligation.
   Proof with auto.
     transitivity x...
     transitivity x0...
   Qed.
 
-(** Proper declarations for partial applications. *)
+  (** Proper declarations for partial applications. *)
 
-Program Instance trans_contra_inv_impl_morphism
-  `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3.
+  Global Program 
+  Instance trans_contra_inv_impl_morphism
+  `(Transitive A R) : Proper (R --> flip impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
     transitivity y...
   Qed.
 
-Program Instance trans_co_impl_morphism
-  `(Transitive A R) : Proper (R ++> impl) (R x) | 3.
+  Global Program 
+  Instance trans_co_impl_morphism
+    `(Transitive A R) : Proper (R ++> impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
     transitivity x0...
   Qed.
 
-Program Instance trans_sym_co_inv_impl_morphism
-  `(PER A R) : Proper (R ++> inverse impl) (R x) | 3.
+  Global Program 
+  Instance trans_sym_co_inv_impl_morphism
+    `(PER A R) : Proper (R ++> flip impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
     transitivity y... symmetry...
   Qed.
 
-Program Instance trans_sym_contra_impl_morphism
-  `(PER A R) : Proper (R --> impl) (R x) | 3.
+  Global Program Instance trans_sym_contra_impl_morphism
+    `(PER A R) : Proper (R --> impl) (R x) | 3.
 
   Next Obligation.
   Proof with auto.
     transitivity x0... symmetry...
   Qed.
 
-Program Instance per_partial_app_morphism
+  Global Program Instance per_partial_app_morphism
   `(PER A R) : Proper (R ==> iff) (R x) | 2.
 
   Next Obligation.
@@ -310,20 +347,21 @@ Program Instance per_partial_app_morphism
     symmetry...
   Qed.
 
-(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof
-   to get an [R y z] goal. *)
+  (** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof to get an [R y z] goal. *)
 
-Program Instance trans_co_eq_inv_impl_morphism
-  `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2.
+  Global Program 
+  Instance trans_co_eq_inv_impl_morphism
+  `(Transitive A R) : Proper (R ==> (@eq A) ==> flip impl) R | 2.
 
   Next Obligation.
   Proof with auto.
     transitivity y...
   Qed.
 
-(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *)
+  (** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *)
 
-Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1.
+  Global Program 
+  Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1.
 
   Next Obligation.
   Proof with auto.
@@ -333,11 +371,11 @@ Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1.
     transitivity y... transitivity y0... symmetry...
   Qed.
 
-Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R).
-Proof. firstorder. Qed.
+  Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R).
+  Proof. firstorder. Qed.
 
-Program Instance compose_proper A B C R₀ R� R₂ :
-  Proper ((R� ==> R₂) ==> (R₀ ==> R�) ==> (R₀ ==> R₂)) (@compose A B C).
+  Global Program Instance compose_proper RA RB RC :
+    Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C).
 
   Next Obligation.
   Proof.
@@ -345,68 +383,84 @@ Program Instance compose_proper A B C R₀ R� R₂ :
     unfold compose. apply H. apply H0. apply H1.
   Qed.
 
-(** Coq functions are morphisms for Leibniz equality,
-   applied only if really needed. *)
-
-Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') :
-  Reflexive (@Logic.eq A ==> R').
-Proof. simpl_relation. Qed.
+  (** Coq functions are morphisms for Leibniz equality,
+     applied only if really needed. *)
 
-(** [respectful] is a morphism for relation equivalence. *)
-
-Instance respectful_morphism :
-  Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B).
-Proof.
-  reduce.
-  unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *.
-  split ; intros.
+  Global Instance reflexive_eq_dom_reflexive `(Reflexive B R') :
+    Reflexive (@Logic.eq A ==> R').
+  Proof. simpl_relation. Qed.
 
+  (** [respectful] is a morphism for relation equivalence. *)
+  
+  Global Instance respectful_morphism :
+    Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) 
+           (@respectful A B).
+  Proof.
+    reduce.
+    unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *.
+    split ; intros.
+    
     rewrite <- H0.
     apply H1.
     rewrite H.
     assumption.
-
+    
     rewrite H0.
     apply H1.
     rewrite <- H.
     assumption.
-Qed.
-
-(** Every element in the carrier of a reflexive relation is a morphism for this relation.
-   We use a proxy class for this case which is used internally to discharge reflexivity constraints.
-   The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of
-   [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able
-   to set different priorities in different hint bases and select a particular hint database for
-   resolution of a type class constraint.*)
-
-Class ProperProxy {A} (R : relation A) (m : A) : Prop :=
-  proper_proxy : R m m.
-
-Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x.
-Proof. firstorder. Qed.
-
-Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x.
-Proof. firstorder. Qed.
-
-Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x.
-Proof. firstorder. Qed.
-
-Hint Extern 1 (ProperProxy _ _) => 
-  class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances.
-Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances.
+  Qed.
 
-(** [R] is Reflexive, hence we can build the needed proof. *)
+  (** [R] is Reflexive, hence we can build the needed proof. *)
 
-Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
-   Proper R' (m x).
-Proof. simpl_relation. Qed.
+  Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
+    Proper R' (m x).
+  Proof. simpl_relation. Qed.
+  
+  Lemma flip_respectful (R : relation A) (R' : relation B) :
+    relation_equivalence (flip (R ==> R')) (flip R ==> flip R').
+  Proof.
+    intros.
+    unfold flip, respectful.
+    split ; intros ; intuition.
+  Qed.
 
-Class Params {A : Type} (of : A) (arity : nat).
+  
+  (** Treating flip: can't make them direct instances as we
+   need at least a [flip] present in the goal. *)
+  
+  Lemma flip1 `(subrelation A R' R) : subrelation (flip (flip R')) R.
+  Proof. firstorder. Qed.
+  
+  Lemma flip2 `(subrelation A R R') : subrelation R (flip (flip R')).
+  Proof. firstorder. Qed.
+  
+  (** That's if and only if *)
+  
+  Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R.
+  Proof. simpl_relation. Qed.
+
+  (** Once we have normalized, we will apply this instance to simplify the problem. *)
+  
+  Definition proper_flip_proper `(mor : Proper A R m) : Proper (flip R) m := mor.
+  
+  (** Every reflexive relation gives rise to a morphism, 
+  only for immediately solving goals without variables. *)
+  
+  Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x.
+  Proof. firstorder. Qed.
+  
+  Lemma proper_eq (x : A) : Proper (@eq A) x.
+  Proof. intros. apply reflexive_proper. Qed.
+  
+End GenericInstances.
 
 Class PartialApplication.
 
 CoInductive normalization_done : Prop := did_normalization.
 
+Class Params {A : Type} (of : A) (arity : nat).
+
 Ltac partial_application_tactic :=
   let rec do_partial_apps H m cont := 
     match m with
@@ -450,68 +504,6 @@ Ltac partial_application_tactic :=
       end
   end.
 
-Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances.
-
-Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B),
-  relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R').
-Proof.
-  intros.
-  unfold flip, respectful.
-  split ; intros ; intuition.
-Qed.
-
-(** Special-purpose class to do normalization of signatures w.r.t. inverse. *)
-
-Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop :=
-  normalizes : relation_equivalence m m'.
-
-(** Current strategy: add [inverse] everywhere and reduce using [subrelation]
-   afterwards. *)
-
-Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)).
-Proof.
-  firstorder.
-Qed.
-
-Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) :
-  Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature).
-Proof. unfold Normalizes in *. intros. 
-  rewrite NA, NB. firstorder.
-Qed.
-
-Ltac inverse :=
-  match goal with
-    | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow
-    | _ => class_apply @inverse_atom
-  end.
-
-Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances.
-
-(** Treating inverse: can't make them direct instances as we
-   need at least a [flip] present in the goal. *)
-
-Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R.
-Proof. firstorder. Qed.
-
-Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')).
-Proof. firstorder. Qed.
-
-Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances.
-Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances.
-
-(** That's if and only if *)
-
-Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R.
-Proof. simpl_relation. Qed.
-
-(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *)
-
-(** Once we have normalized, we will apply this instance to simplify the problem. *)
-
-Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor.
-
-Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances.
-
 (** Bootstrap !!! *)
 
 Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A).
@@ -525,46 +517,88 @@ Proof.
   apply H0.
 Qed.
 
-Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m.
-Proof.
-  red in H, H0.
-  setoid_rewrite H.
-  assumption.
-Qed.
-
-Ltac proper_normalization :=
+Ltac proper_reflexive :=
   match goal with
     | [ _ : normalization_done |- _ ] => fail 1
-    | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in
-      set(H:=did_normalization) ; class_apply @proper_normalizes_proper
+    | _ => class_apply proper_eq || class_apply @reflexive_proper
   end.
 
-Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances.
 
-(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *)
+Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances.
+Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances.
 
-Lemma reflexive_proper `{Reflexive A R} (x : A)
-   : Proper R x.
-Proof. firstorder. Qed.
+Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper 
+  : typeclass_instances.
+Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper 
+  : typeclass_instances.
+Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper 
+  : typeclass_instances.
+Hint Extern 4 (@Proper _ _ _) => partial_application_tactic 
+  : typeclass_instances.
+Hint Extern 7 (@Proper _ _ _) => proper_reflexive 
+  : typeclass_instances.
 
-Lemma proper_eq A (x : A) : Proper (@eq A) x.
-Proof. intros. apply reflexive_proper. Qed.
+(** Special-purpose class to do normalization of signatures w.r.t. flip. *)
 
-Ltac proper_reflexive :=
+Section Normalize.
+  Context (A : Type).
+
+  Class Normalizes (m : relation A) (m' : relation A) : Prop :=
+    normalizes : relation_equivalence m m'.
+  
+  (** Current strategy: add [flip] everywhere and reduce using [subrelation]
+   afterwards. *)
+
+  Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m.
+  Proof.
+    red in H, H0.
+    rewrite H.
+    assumption.
+  Qed.
+
+  Lemma flip_atom R : Normalizes R (flip (flip R)).
+  Proof.
+    firstorder.
+  Qed.
+
+End Normalize.
+
+Lemma flip_arrow {A : Type} {B : Type}
+      `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) :
+  Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature).
+Proof. 
+  unfold Normalizes in *. intros.
+  unfold relation_equivalence in *. 
+  unfold predicate_equivalence in *. simpl in *.
+  unfold respectful. unfold flip in *. firstorder.
+  apply NB. apply H. apply NA. apply H0.
+  apply NB. apply H. apply NA. apply H0.
+Qed.
+
+Ltac normalizes :=
   match goal with
-    | [ _ : normalization_done |- _ ] => fail 1
-    | _ => class_apply proper_eq || class_apply @reflexive_proper
+    | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @flip_arrow
+    | _ => class_apply @flip_atom
   end.
 
-Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances.
+Ltac proper_normalization :=
+  match goal with
+    | [ _ : normalization_done |- _ ] => fail 1
+    | [ _ : apply_subrelation |- @Proper _ ?R _ ] => 
+      let H := fresh "H" in
+      set(H:=did_normalization) ; class_apply @proper_normalizes_proper
+  end.
 
+Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances.
+Hint Extern 6 (@Proper _ _ _) => proper_normalization 
+  : typeclass_instances.
 
 (** When the relation on the domain is symmetric, we can
-    inverse the relation on the codomain. Same for binary functions. *)
+    flip the relation on the codomain. Same for binary functions. *)
 
 Lemma proper_sym_flip :
  forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f),
- Proper (R1==>inverse R2) f.
+ Proper (R1==>flip R2) f.
 Proof.
 intros A R1 Sym B R2 f Hf.
 intros x x' Hxx'. apply Hf, Sym, Hxx'.
@@ -572,7 +606,7 @@ Qed.
 
 Lemma proper_sym_flip_2 :
  forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f),
- Proper (R1==>R2==>inverse R3) f.
+ Proper (R1==>R2==>flip R3) f.
 Proof.
 intros A R1 Sym1 B R2 Sym2 C R3 f Hf.
 intros x x' Hxx' y y' Hyy'. apply Hf; auto.
@@ -627,8 +661,6 @@ apply partial_order_antisym; auto.
 rewrite Hxz; auto.
 Qed.
 
-Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => 
-  class_apply PartialOrder_StrictOrder : typeclass_instances.
 
 (** From a [StrictOrder] to the corresponding [PartialOrder]:
      [le = lt \/ eq].
@@ -659,5 +691,8 @@ elim (StrictOrder_Irreflexive x).
 transitivity y; auto.
 Qed.
 
+Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => 
+  class_apply PartialOrder_StrictOrder : typeclass_instances.
+
 Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => 
   class_apply StrictOrder_PartialOrder : typeclass_instances.
diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v
index c3737658..096c96e5 100644
--- a/theories/Classes/Morphisms_Prop.v
+++ b/theories/Classes/Morphisms_Prop.v
@@ -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        *)
@@ -16,7 +16,7 @@ Require Import Coq.Classes.Morphisms.
 Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 
-Local Obligation Tactic := simpl_relation.
+Local Obligation Tactic := try solve [simpl_relation | firstorder auto].
 
 (** Standard instances for [not], [iff] and [impl]. *)
 
@@ -52,61 +52,20 @@ Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl.
 
 Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A).
 
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation in H.
-    split ; intros.
-    destruct H0 as [x1 H1].
-    exists x1. rewrite H in H1. assumption.
-
-    destruct H0 as [x1 H1].
-    exists x1. rewrite H. assumption.
-  Qed.
-
 Program Instance ex_impl_morphism {A : Type} :
   Proper (pointwise_relation A impl ==> impl) (@ex A) | 1.
 
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation in H.
-    exists H0. apply H. assumption.
-  Qed.
-
-Program Instance ex_inverse_impl_morphism {A : Type} :
-  Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1.
-
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation in H.
-    exists H0. apply H. assumption.
-  Qed.
+Program Instance ex_flip_impl_morphism {A : Type} :
+  Proper (pointwise_relation A (flip impl) ==> flip impl) (@ex A) | 1.
 
 Program Instance all_iff_morphism {A : Type} :
   Proper (pointwise_relation A iff ==> iff) (@all A).
 
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation, all in *.
-    intuition ; specialize (H x0) ; intuition.
-  Qed.
-
 Program Instance all_impl_morphism {A : Type} :
   Proper (pointwise_relation A impl ==> impl) (@all A) | 1.
 
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation, all in *.
-    intuition ; specialize (H x0) ; intuition.
-  Qed.
-
-Program Instance all_inverse_impl_morphism {A : Type} :
-  Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1.
-
-  Next Obligation.
-  Proof.
-    unfold pointwise_relation, all in *.
-    intuition ; specialize (H x0) ; intuition.
-  Qed.
+Program Instance all_flip_impl_morphism {A : Type} :
+  Proper (pointwise_relation A (flip impl) ==> flip impl) (@all A) | 1.
 
 (** Equivalent points are simultaneously accessible or not *)
 
@@ -116,13 +75,13 @@ Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop)
 Proof.
  apply proper_sym_impl_iff; auto with *.
  intros x y EQ WF. apply Acc_intro; intros z Hz.
- rewrite <- EQ in Hz. now apply Acc_inv with x.
+rewrite <- EQ in Hz. now apply Acc_inv with x.
 Qed.
 
 (** Equivalent relations have the same accessible points *)
 
 Instance Acc_rel_morphism {A:Type} :
- Proper (@relation_equivalence A ==> Logic.eq ==> iff) (@Acc A).
+ Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A).
 Proof.
  apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry.
  intros R R' EQ a a' Ha WF. subst a'.
@@ -133,7 +92,7 @@ Qed.
 (** Equivalent relations are simultaneously well-founded or not *)
 
 Instance well_founded_morphism {A : Type} :
- Proper (@relation_equivalence A ==> iff) (@well_founded A).
+ Proper (relation_equivalence ==> iff) (@well_founded A).
 Proof.
  unfold well_founded. solve_proper.
 Qed.
diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v
index 34115e57..68a8c06a 100644
--- a/theories/Classes/Morphisms_Relations.v
+++ b/theories/Classes/Morphisms_Relations.v
@@ -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        *)
@@ -30,8 +30,6 @@ Instance relation_disjunction_morphism : Proper (relation_equivalence (A:=A) ==>
 
 (* Predicate equivalence is exactly the same as the pointwise lifting of [iff]. *)
 
-Require Import List.
-
 Lemma predicate_equivalence_pointwise (l : Tlist) :
   Proper (@predicate_equivalence l ==> pointwise_lifting iff l) id.
 Proof. do 2 red. unfold predicate_equivalence. auto. Qed.
@@ -40,7 +38,7 @@ Lemma predicate_implication_pointwise (l : Tlist) :
   Proper (@predicate_implication l ==> pointwise_lifting impl l) id.
 Proof. do 2 red. unfold predicate_implication. auto. Qed.
 
-(** The instanciation at relation allows to rewrite applications of relations
+(** The instantiation at relation allows rewriting applications of relations
     [R x y] to [R' x y]  when [R] and [R'] are in [relation_equivalence]. *)
 
 Instance relation_equivalence_pointwise :
@@ -52,6 +50,6 @@ Instance subrelation_pointwise :
 Proof. intro. apply (predicate_implication_pointwise (Tcons A (Tcons A Tnil))). Qed.
 
 
-Lemma inverse_pointwise_relation A (R : relation A) :
-  relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)).
+Lemma flip_pointwise_relation A (R : relation A) :
+  relation_equivalence (pointwise_relation A (flip R)) (flip (pointwise_relation A R)).
 Proof. intros. split; firstorder. Qed.
diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v
index 5c4dd532..1a40e5d5 100644
--- a/theories/Classes/RelationClasses.v
+++ b/theories/Classes/RelationClasses.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -20,43 +20,191 @@ Require Import Coq.Program.Basics.
 Require Import Coq.Program.Tactics.
 Require Import Coq.Relations.Relation_Definitions.
 
-(** We allow to unfold the [relation] definition while doing morphism search. *)
-
-Notation inverse R := (flip (R:relation _) : relation _).
-
-Definition complement {A} (R : relation A) : relation A := fun x y => R x y -> False.
-
-(** Opaque for proof-search. *)
-Typeclasses Opaque complement.
-
-(** These are convertible. *)
-
-Lemma complement_inverse : forall A (R : relation A), complement (inverse R) = inverse (complement R).
-Proof. reflexivity. Qed.
+Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.
 
-(** We rebind relations in separate classes to be able to overload each proof. *)
+(** We allow to unfold the [relation] definition while doing morphism search. *)
 
-Set Implicit Arguments.
-Unset Strict Implicit.
+Section Defs.
+  Context {A : Type}.
+
+  (** We rebind relational properties in separate classes to be able to overload each proof. *)
+
+  Class Reflexive (R : relation A) :=
+    reflexivity : forall x : A, R x x.
+
+  Definition complement (R : relation A) : relation A := fun x y => R x y -> False.
+
+  (** Opaque for proof-search. *)
+  Typeclasses Opaque complement.
+  
+  (** These are convertible. *)
+  Lemma complement_inverse R : complement (flip R) = flip (complement R).
+  Proof. reflexivity. Qed.
+
+  Class Irreflexive (R : relation A) :=
+    irreflexivity : Reflexive (complement R).
+
+  Class Symmetric (R : relation A) :=
+    symmetry : forall {x y}, R x y -> R y x.
+  
+  Class Asymmetric (R : relation A) :=
+    asymmetry : forall {x y}, R x y -> R y x -> False.
+  
+  Class Transitive (R : relation A) :=
+    transitivity : forall {x y z}, R x y -> R y z -> R x z.
+
+  (** Various combinations of reflexivity, symmetry and transitivity. *)
+  
+  (** A [PreOrder] is both Reflexive and Transitive. *)
+  
+  Class PreOrder (R : relation A) : Prop := {
+    PreOrder_Reflexive :> Reflexive R | 2 ;
+    PreOrder_Transitive :> Transitive R | 2 }.
+
+  (** A [StrictOrder] is both Irreflexive and Transitive. *)
+
+  Class StrictOrder (R : relation A) : Prop := {
+    StrictOrder_Irreflexive :> Irreflexive R ;
+    StrictOrder_Transitive :> Transitive R }.
+
+  (** By definition, a strict order is also asymmetric *)
+  Global Instance StrictOrder_Asymmetric `(StrictOrder R) : Asymmetric R.
+  Proof. firstorder. Qed.
+
+  (** A partial equivalence relation is Symmetric and Transitive. *)
+  
+  Class PER (R : relation A) : Prop := {
+    PER_Symmetric :> Symmetric R | 3 ;
+    PER_Transitive :> Transitive R | 3 }.
+
+  (** Equivalence relations. *)
+
+  Class Equivalence (R : relation A) : Prop := {
+    Equivalence_Reflexive :> Reflexive R ;
+    Equivalence_Symmetric :> Symmetric R ;
+    Equivalence_Transitive :> Transitive R }.
+
+  (** An Equivalence is a PER plus reflexivity. *)
+  
+  Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 :=
+    { }. 
+
+  (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)
+  
+  Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) :=
+    antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.
+
+  Class subrelation (R R' : relation A) : Prop :=
+    is_subrelation : forall {x y}, R x y -> R' x y.
+  
+  (** Any symmetric relation is equal to its inverse. *)
+  
+  Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R.
+  Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed.
+
+  Section flip.
+  
+    Lemma flip_Reflexive `{Reflexive R} : Reflexive (flip R).
+    Proof. tauto. Qed.
+    
+    Program Definition flip_Irreflexive `(Irreflexive R) : Irreflexive (flip R) :=
+      irreflexivity (R:=R).
+    
+    Program Definition flip_Symmetric `(Symmetric R) : Symmetric (flip R) :=
+      fun x y H => symmetry (R:=R) H.
+    
+    Program Definition flip_Asymmetric `(Asymmetric R) : Asymmetric (flip R) :=
+      fun x y H H' => asymmetry (R:=R) H H'.
+    
+    Program Definition flip_Transitive `(Transitive R) : Transitive (flip R) :=
+      fun x y z H H' => transitivity (R:=R) H' H.
+
+    Program Definition flip_Antisymmetric `(Antisymmetric eqA R) :
+      Antisymmetric eqA (flip R).
+    Proof. firstorder. Qed.
+
+    (** Inversing the larger structures *)
+
+    Lemma flip_PreOrder `(PreOrder R) : PreOrder (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_StrictOrder `(StrictOrder R) : StrictOrder (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_PER `(PER R) : PER (flip R).
+    Proof. firstorder. Qed.
+
+    Lemma flip_Equivalence `(Equivalence R) : Equivalence (flip R).
+    Proof. firstorder. Qed.
+
+  End flip.
+
+  Section complement.
+
+    Definition complement_Irreflexive `(Reflexive R)
+      : Irreflexive (complement R).
+    Proof. firstorder. Qed.
+
+    Definition complement_Symmetric `(Symmetric R) : Symmetric (complement R).
+    Proof. firstorder. Qed.
+  End complement.
+
+
+  (** Rewrite relation on a given support: declares a relation as a rewrite
+   relation for use by the generalized rewriting tactic.
+   It helps choosing if a rewrite should be handled
+   by the generalized or the regular rewriting tactic using leibniz equality.
+   Users can declare an [RewriteRelation A RA] anywhere to declare default
+   relations. This is also done automatically by the [Declare Relation A RA]
+   commands. *)
 
-Class Reflexive {A} (R : relation A) :=
-  reflexivity : forall x, R x x.
+  Class RewriteRelation (RA : relation A).
 
-Class Irreflexive {A} (R : relation A) :=
-  irreflexivity : Reflexive (complement R).
+  (** Any [Equivalence] declared in the context is automatically considered
+   a rewrite relation. *)
+    
+  Global Instance equivalence_rewrite_relation `(Equivalence eqA) : RewriteRelation eqA.
+
+  (** Leibniz equality. *)
+  Section Leibniz.
+    Global Instance eq_Reflexive : Reflexive (@eq A) := @eq_refl A.
+    Global Instance eq_Symmetric : Symmetric (@eq A) := @eq_sym A.
+    Global Instance eq_Transitive : Transitive (@eq A) := @eq_trans A.
+    
+    (** Leibinz equality [eq] is an equivalence relation.
+        The instance has low priority as it is always applicable
+        if only the type is constrained. *)
+    
+    Global Program Instance eq_equivalence : Equivalence (@eq A) | 10.
+  End Leibniz.
+  
+End Defs.
+
+(** Default rewrite relations handled by [setoid_rewrite]. *)
+Instance: RewriteRelation impl.
+Instance: RewriteRelation iff.
 
+(** Hints to drive the typeclass resolution avoiding loops
+ due to the use of full unification. *)
 Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
+Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
+Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances.
 
-Class Symmetric {A} (R : relation A) :=
-  symmetry : forall x y, R x y -> R y x.
+Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
+Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
+Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
+Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
+Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances.
+Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
+Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances.
+Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances.
 
-Class Asymmetric {A} (R : relation A) :=
-  asymmetry : forall x y, R x y -> R y x -> False.
+Hint Extern 4 (subrelation (flip _) _) => 
+  class_apply @subrelation_symmetric : typeclass_instances.
 
-Class Transitive {A} (R : relation A) :=
-  transitivity : forall x y z, R x y -> R y z -> R x z.
+Arguments irreflexivity {A R Irreflexive} [x] _.
 
-Hint Resolve @irreflexivity : ord.
+Hint Resolve irreflexivity : ord.
 
 Unset Implicit Arguments.
 
@@ -72,40 +220,6 @@ Hint Extern 4 => solve_relation : relations.
 
 (** We can already dualize all these properties. *)
 
-Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.
-
-Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R).
-Proof. tauto. Qed.
-
-Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
-
-Program Definition flip_Irreflexive `(Irreflexive A R) : Irreflexive (flip R) :=
-  irreflexivity (R:=R).
-
-Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) :=
-  fun x y H => symmetry (R:=R) H.
-
-Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) :=
-  fun x y H H' => asymmetry (R:=R) H H'.
-
-Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) :=
-  fun x y z H H' => transitivity (R:=R) H' H.
-
-Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances.
-Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances.
-Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances.
-Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances.
-
-Definition Reflexive_complement_Irreflexive `(Reflexive A (R : relation A))
-   : Irreflexive (complement R).
-Proof. firstorder. Qed.
-
-Definition complement_Symmetric `(Symmetric A (R : relation A)) : Symmetric (complement R).
-Proof. firstorder. Qed.
-
-Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances.
-Hint Extern 3 (Irreflexive (complement _)) => class_apply Reflexive_complement_Irreflexive : typeclass_instances.
-
 (** * Standard instances. *)
 
 Ltac reduce_hyp H :=
@@ -130,7 +244,7 @@ Tactic Notation "apply" "*" constr(t) :=
 
 Ltac simpl_relation :=
   unfold flip, impl, arrow ; try reduce ; program_simpl ;
-    try ( solve [ intuition ]).
+    try ( solve [ dintuition ]).
 
 Local Obligation Tactic := simpl_relation.
 
@@ -145,54 +259,6 @@ Instance iff_Reflexive : Reflexive iff := iff_refl.
 Instance iff_Symmetric : Symmetric iff := iff_sym.
 Instance iff_Transitive : Transitive iff := iff_trans.
 
-(** Leibniz equality. *)
-
-Instance eq_Reflexive {A} : Reflexive (@eq A) := @eq_refl A.
-Instance eq_Symmetric {A} : Symmetric (@eq A) := @eq_sym A.
-Instance eq_Transitive {A} : Transitive (@eq A) := @eq_trans A.
-
-(** Various combinations of reflexivity, symmetry and transitivity. *)
-
-(** A [PreOrder] is both Reflexive and Transitive. *)
-
-Class PreOrder {A} (R : relation A) : Prop := {
-  PreOrder_Reflexive :> Reflexive R | 2 ;
-  PreOrder_Transitive :> Transitive R | 2 }.
-
-(** A partial equivalence relation is Symmetric and Transitive. *)
-
-Class PER {A} (R : relation A) : Prop := {
-  PER_Symmetric :> Symmetric R | 3 ;
-  PER_Transitive :> Transitive R | 3 }.
-
-(** Equivalence relations. *)
-
-Class Equivalence {A} (R : relation A) : Prop := {
-  Equivalence_Reflexive :> Reflexive R ;
-  Equivalence_Symmetric :> Symmetric R ;
-  Equivalence_Transitive :> Transitive R }.
-
-(** An Equivalence is a PER plus reflexivity. *)
-
-Instance Equivalence_PER `(Equivalence A R) : PER R | 10 :=
-  { PER_Symmetric := Equivalence_Symmetric ;
-    PER_Transitive := Equivalence_Transitive }.
-
-(** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *)
-
-Class Antisymmetric A eqA `{equ : Equivalence A eqA} (R : relation A) :=
-  antisymmetry : forall {x y}, R x y -> R y x -> eqA x y.
-
-Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) :
-  Antisymmetric A eqA (flip R).
-Proof. firstorder. Qed.
-
-(** Leibinz equality [eq] is an equivalence relation.
-   The instance has low priority as it is always applicable
-   if only the type is constrained. *)
-
-Program Instance eq_equivalence : Equivalence (@eq A) | 10.
-
 (** Logical equivalence [iff] is an equivalence relation. *)
 
 Program Instance iff_equivalence : Equivalence iff.
@@ -203,9 +269,6 @@ Program Instance iff_equivalence : Equivalence iff.
 
 Local Open Scope list_scope.
 
-(* Notation " [ ] " := nil : list_scope. *)
-(* Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) (at level 1) : list_scope. *)
-
 (** A compact representation of non-dependent arities, with the codomain singled-out. *)
 
 (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *)
@@ -316,7 +379,8 @@ Notation "∙⊥∙" := false_predicate : predicate_scope.
 
 (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *)
 
-Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l).
+Program Instance predicate_equivalence_equivalence : 
+  Equivalence (@predicate_equivalence l).
 
   Next Obligation.
     induction l ; firstorder.
@@ -345,106 +409,66 @@ Program Instance predicate_implication_preorder :
 (** We define the various operations which define the algebra on binary relations,
    from the general ones. *)
 
-Definition relation_equivalence {A : Type} : relation (relation A) :=
-  @predicate_equivalence (_::_::Tnil).
-
-Class subrelation {A:Type} (R R' : relation A) : Prop :=
-  is_subrelation : @predicate_implication (A::A::Tnil) R R'.
-
-Arguments subrelation {A} R R'.
-
-Definition relation_conjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_intersection (A::A::Tnil) R R'.
-
-Definition relation_disjunction {A} (R : relation A) (R' : relation A) : relation A :=
-  @predicate_union (A::A::Tnil) R R'.
-
-(** Relation equivalence is an equivalence, and subrelation defines a partial order. *)
-
-Set Automatic Introduction.
-
-Instance relation_equivalence_equivalence (A : Type) :
-  Equivalence (@relation_equivalence A).
-Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed.
-
-Instance relation_implication_preorder A : PreOrder (@subrelation A).
-Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed.
-
-(** *** Partial Order.
+Section Binary.
+  Context {A : Type}.
+
+  Definition relation_equivalence : relation (relation A) :=
+    @predicate_equivalence (_::_::Tnil).
+
+  Global Instance: RewriteRelation relation_equivalence.
+  
+  Definition relation_conjunction (R : relation A) (R' : relation A) : relation A :=
+    @predicate_intersection (A::A::Tnil) R R'.
+
+  Definition relation_disjunction (R : relation A) (R' : relation A) : relation A :=
+    @predicate_union (A::A::Tnil) R R'.
+  
+  (** Relation equivalence is an equivalence, and subrelation defines a partial order. *)
+  
+  Set Automatic Introduction.
+  
+  Global Instance relation_equivalence_equivalence :
+    Equivalence relation_equivalence.
+  Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed.
+  
+  Global Instance relation_implication_preorder : PreOrder (@subrelation A).
+  Proof. exact (@predicate_implication_preorder (A::A::Tnil)). Qed.
+
+  (** *** Partial Order.
    A partial order is a preorder which is additionally antisymmetric.
    We give an equivalent definition, up-to an equivalence relation
    on the carrier. *)
 
-Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
-  partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)).
+  Class PartialOrder eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} :=
+    partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (flip R)).
+  
+  (** The equivalence proof is sufficient for proving that [R] must be a
+   morphism for equivalence (see Morphisms).  It is also sufficient to
+   show that [R] is antisymmetric w.r.t. [eqA] *)
+
+  Global Instance partial_order_antisym `(PartialOrder eqA R) : ! Antisymmetric A eqA R.
+  Proof with auto.
+    reduce_goal.
+    pose proof partial_order_equivalence as poe. do 3 red in poe.
+    apply <- poe. firstorder.
+  Qed.
 
-(** The equivalence proof is sufficient for proving that [R] must be a morphism
-   for equivalence (see Morphisms).
-   It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *)
 
-Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R.
-Proof with auto.
-  reduce_goal.
-  pose proof partial_order_equivalence as poe. do 3 red in poe.
-  apply <- poe. firstorder.
-Qed.
+  Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R).
+  Proof. firstorder. Qed.
+End Binary.
+
+Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances.
 
 (** The partial order defined by subrelation and relation equivalence. *)
 
 Program Instance subrelation_partial_order :
   ! PartialOrder (relation A) relation_equivalence subrelation.
 
-  Next Obligation.
-  Proof.
-    unfold relation_equivalence in *. compute; firstorder.
-  Qed.
+Next Obligation.
+Proof.
+  unfold relation_equivalence in *. compute; firstorder.
+Qed.
 
 Typeclasses Opaque arrows predicate_implication predicate_equivalence
-  relation_equivalence pointwise_lifting.
-
-(** Rewrite relation on a given support: declares a relation as a rewrite
-   relation for use by the generalized rewriting tactic.
-   It helps choosing if a rewrite should be handled
-   by the generalized or the regular rewriting tactic using leibniz equality.
-   Users can declare an [RewriteRelation A RA] anywhere to declare default
-   relations. This is also done automatically by the [Declare Relation A RA]
-   commands. *)
-
-Class RewriteRelation {A : Type} (RA : relation A).
-
-Instance: RewriteRelation impl.
-Instance: RewriteRelation iff.
-Instance: RewriteRelation (@relation_equivalence A).
-
-(** Any [Equivalence] declared in the context is automatically considered
-   a rewrite relation. *)
-
-Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA.
-
-(** Strict Order *)
-
-Class StrictOrder {A : Type} (R : relation A) : Prop := {
-  StrictOrder_Irreflexive :> Irreflexive R ;
-  StrictOrder_Transitive :> Transitive R
-}.
-
-Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R.
-Proof. firstorder. Qed.
-
-(** Inversing a [StrictOrder] gives another [StrictOrder] *)
-
-Lemma StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R).
-Proof. firstorder. Qed.
-
-(** Same for [PartialOrder]. *)
-
-Lemma PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R).
-Proof. firstorder. Qed.
-
-Hint Extern 3 (StrictOrder (inverse _)) => class_apply StrictOrder_inverse : typeclass_instances.
-Hint Extern 3 (PreOrder (inverse _)) => class_apply PreOrder_inverse : typeclass_instances.
-
-Lemma PartialOrder_inverse `(PartialOrder A eqA R) : PartialOrder eqA (inverse R).
-Proof. firstorder. Qed.
-
-Hint Extern 3 (PartialOrder (inverse _)) => class_apply PartialOrder_inverse : typeclass_instances.
+            relation_equivalence pointwise_lifting.
diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v
index 2b010206..cbde5f9a 100644
--- a/theories/Classes/RelationPairs.v
+++ b/theories/Classes/RelationPairs.v
@@ -9,8 +9,8 @@
 (** * Relations over pairs *)
 
 
+Require Import SetoidList.
 Require Import Relations Morphisms.
-
 (* NB: This should be system-wide someday, but for that we need to
     fix the simpl tactic, since "simpl fst" would be refused for
     the moment.
@@ -40,7 +40,7 @@ Generalizable Variables A B RA RB Ri Ro f.
 (** Any function from [A] to [B] allow to obtain a relation over [A]
     out of a relation over [B]. *)
 
-Definition RelCompFun {A B}(R:relation B)(f:A->B) : relation A :=
+Definition RelCompFun {A} {B : Type}(R:relation B)(f:A->B) : relation A :=
  fun a a' => R (f a) (f a').
 
 Infix "@@" := RelCompFun (at level 30, right associativity) : signature_scope.
@@ -62,13 +62,13 @@ Instance snd_measure : @Measure (A * B) B Snd.
 (** We define a product relation over [A*B]: each components should
     satisfy the corresponding initial relation. *)
 
-Definition RelProd {A B}(RA:relation A)(RB:relation B) : relation (A*B) :=
- relation_conjunction (RA @@1) (RB @@2).
+Definition RelProd {A : Type} {B : Type} (RA:relation A)(RB:relation B) : relation (A*B) :=
+ relation_conjunction (@RelCompFun (A * B) A RA fst) (RB @@2).
 
 Infix "*" := RelProd : signature_scope.
 
 Section RelCompFun_Instances.
-  Context {A B : Type} (R : relation B).
+  Context {A : Type} {B : Type} (R : relation B).
 
   Global Instance RelCompFun_Reflexive
     `(Measure A B f, Reflexive _ R) : Reflexive (R@@f).
@@ -94,57 +94,61 @@ Section RelCompFun_Instances.
 
 End RelCompFun_Instances.
 
-Instance RelProd_Reflexive {A B}(RA:relation A)(RB:relation B)
- `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
-Proof. firstorder. Qed.
-
-Instance RelProd_Symmetric {A B}(RA:relation A)(RB:relation B)
- `(Symmetric _ RA, Symmetric _ RB) : Symmetric (RA*RB).
-Proof. firstorder. Qed.
-
-Instance RelProd_Transitive {A B}(RA:relation A)(RB:relation B)
- `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
-Proof. firstorder. Qed.
-
-Program Instance RelProd_Equivalence {A B}(RA:relation A)(RB:relation B)
- `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).
-
-Lemma FstRel_ProdRel {A B}(RA:relation A) :
- relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)).
-Proof. firstorder. Qed.
-
-Lemma SndRel_ProdRel {A B}(RB:relation B) :
- relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB).
-Proof. firstorder. Qed.
-
-Instance FstRel_sub {A B} (RA:relation A)(RB:relation B):
- subrelation (RA*RB) (RA @@1).
-Proof. firstorder. Qed.
-
-Instance SndRel_sub {A B} (RA:relation A)(RB:relation B):
- subrelation (RA*RB) (RB @@2).
-Proof. firstorder. Qed.
-
-Instance pair_compat { A B } (RA:relation A)(RB:relation B) :
- Proper (RA==>RB==> RA*RB) (@pair _ _).
-Proof. firstorder. Qed.
-
-Instance fst_compat { A B } (RA:relation A)(RB:relation B) :
- Proper (RA*RB ==> RA) Fst.
-Proof.
-intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
-Qed.
-
-Instance snd_compat { A B } (RA:relation A)(RB:relation B) :
- Proper (RA*RB ==> RB) Snd.
-Proof.
-intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
-Qed.
-
-Instance RelCompFun_compat {A B}(f:A->B)(R : relation B)
- `(Proper _ (Ri==>Ri==>Ro) R) :
- Proper (Ri@@f==>Ri@@f==>Ro) (R@@f)%signature.
-Proof. unfold RelCompFun; firstorder. Qed.
+Section RelProd_Instances.
+
+  Context {A : Type} {B : Type} (RA : relation A) (RB : relation B).
+
+  Global Instance RelProd_Reflexive `(Reflexive _ RA, Reflexive _ RB) : Reflexive (RA*RB).
+  Proof. firstorder. Qed.
+
+  Global Instance RelProd_Symmetric `(Symmetric _ RA, Symmetric _ RB)
+  : Symmetric (RA*RB).
+  Proof. firstorder. Qed.
+
+  Global Instance RelProd_Transitive 
+           `(Transitive _ RA, Transitive _ RB) : Transitive (RA*RB).
+  Proof. firstorder. Qed.
+
+  Global Program Instance RelProd_Equivalence 
+          `(Equivalence _ RA, Equivalence _ RB) : Equivalence (RA*RB).
+
+  Lemma FstRel_ProdRel :
+    relation_equivalence (RA @@1) (RA*(fun _ _ : B => True)).
+  Proof. firstorder. Qed.
+  
+  Lemma SndRel_ProdRel :
+    relation_equivalence (RB @@2) ((fun _ _ : A =>True) * RB).
+  Proof. firstorder. Qed.
+  
+  Global Instance FstRel_sub :
+    subrelation (RA*RB) (RA @@1).
+  Proof. firstorder. Qed.
+
+  Global Instance SndRel_sub :
+    subrelation (RA*RB) (RB @@2).
+  Proof. firstorder. Qed.
+  
+  Global Instance pair_compat :
+    Proper (RA==>RB==> RA*RB) (@pair _ _).
+  Proof. firstorder. Qed.
+  
+  Global Instance fst_compat :
+    Proper (RA*RB ==> RA) Fst.
+  Proof.
+    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
+  Qed.
+
+  Global Instance snd_compat :
+    Proper (RA*RB ==> RB) Snd.
+  Proof.
+    intros (x,y) (x',y') (Hx,Hy); compute in *; auto.
+  Qed.
+
+  Global Instance RelCompFun_compat (f:A->B)
+           `(Proper _ (Ri==>Ri==>Ro) RB) :
+    Proper (Ri@@f==>Ri@@f==>Ro) (RB@@f)%signature.
+  Proof. unfold RelCompFun; firstorder. Qed.
+End RelProd_Instances.
 
 Hint Unfold RelProd RelCompFun.
 Hint Extern 2 (RelProd _ _ _ _) => split.
diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v
index e7b94081..f20100fe 100644
--- a/theories/Classes/SetoidClass.v
+++ b/theories/Classes/SetoidClass.v
@@ -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/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v
index 79168084..bf05934e 100644
--- a/theories/Classes/SetoidDec.v
+++ b/theories/Classes/SetoidDec.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -108,7 +108,7 @@ Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B))
       else in_right
     else in_right.
 
-  Solve Obligations using unfold complement ; program_simpl.
+  Solve Obligations with unfold complement ; program_simpl.
 
 (** Objects of function spaces with countable domains like bool
   have decidable equality. *)
@@ -121,7 +121,7 @@ Program Instance bool_function_eqdec `(! EqDec (eq_setoid A))
       else in_right
     else in_right.
 
-  Solve Obligations using try red ; unfold equiv, complement ; program_simpl.
+  Solve Obligations with try red ; unfold complement ; program_simpl.
 
   Next Obligation.
   Proof.
diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v
index 07d1203c..8ca93341 100644
--- a/theories/Classes/SetoidTactics.v
+++ b/theories/Classes/SetoidTactics.v
@@ -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        *)
@@ -12,6 +12,7 @@
    Institution: LRI, CNRS UMR 8623 - University Paris Sud
 *)
 
+Require Coq.Classes.CRelationClasses Coq.Classes.CMorphisms.
 Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop.
 Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions.
 Require Import Coq.Classes.Equivalence Coq.Program.Basics.
diff --git a/theories/Classes/vo.itarget b/theories/Classes/vo.itarget
index 9daf133b..18147f2a 100644
--- a/theories/Classes/vo.itarget
+++ b/theories/Classes/vo.itarget
@@ -1,3 +1,4 @@
+DecidableClass.vo
 Equivalence.vo
 EquivDec.vo
 Init.vo
@@ -9,3 +10,6 @@ SetoidClass.vo
 SetoidDec.vo
 SetoidTactics.vo
 RelationPairs.vo
+CRelationClasses.vo
+CMorphisms.vo
+CEquivalence.vo
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index c68216e6..c9e5b8dd 100644
--- a/theories/FSets/FMapAVL.v
+++ b/theories/FSets/FMapAVL.v
@@ -270,7 +270,7 @@ Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) :=
    | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l
   end.
 
-(** then [elements] is an instanciation with an empty [acc] *)
+(** then [elements] is an instantiation with an empty [acc] *)
 
 Definition elements := elements_aux nil.
 
@@ -342,7 +342,7 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
 
 Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
   match m with
-   | Leaf   => Leaf _
+   | Leaf _   => Leaf _
    | Node l x d r h => Node (map f l) x (f d) (map f r) h
   end.
 
@@ -350,7 +350,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
 
 Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
   match m with
-   | Leaf   => Leaf _
+   | Leaf _ => Leaf _
    | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
   end.
 
@@ -359,7 +359,7 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
 Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
   : t elt' :=
   match m with
-   | Leaf => Leaf _
+   | Leaf _ => Leaf _
    | Node l x d r h =>
       match f x d with
        | Some d' => join (map_option f l) x d' (map_option f r)
@@ -370,7 +370,7 @@ Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
 (** * Optimized map2
 
   Suggestion by B. Gregoire: a [map2] function with specialized
-  arguments allowing to bypass some tree traversal. Instead of one
+  arguments that allows bypassing some tree traversal. Instead of one
   [f0] of type [key -> option elt -> option elt' -> option elt''],
   we ask here for:
   - [f] which is a specialisation of [f0] when first option isn't [None]
@@ -389,8 +389,8 @@ Variable mapr : t elt' -> t elt''.
 
 Fixpoint map2_opt m1 m2 :=
  match m1, m2 with
-  | Leaf, _ => mapr m2
-  | _, Leaf => mapl m1
+  | Leaf _, _ => mapr m2
+  | _, Leaf _ => mapl m1
   | Node l1 x1 d1 r1 h1, _ =>
      let (l2',o2,r2') := split x1 m2 in
      match f x1 d1 o2 with
@@ -534,7 +534,7 @@ Ltac order := match goal with
  | _ => MX.order
 end.
 
-Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo).
+Ltac intuition_in := repeat (intuition; inv In; inv MapsTo).
 
 (* Function/Functional Scheme can't deal with internal fix.
    Let's do its job by hand: *)
@@ -1247,11 +1247,11 @@ Proof.
  intros m1 m2; functional induction (concat m1 m2); intros; auto;
  try factornode _x _x0 _x1 _x2 _x3 as m1.
  apply join_bst; auto.
- change (bst (m2',xd)#1); rewrite <-e1; eauto.
+ change (bst (m2',xd)#1). rewrite <-e1; eauto.
  intros y Hy.
  apply H1; auto.
  rewrite remove_min_in, e1; simpl; auto.
- change (gt_tree (m2',xd)#2#1 (m2',xd)#1); rewrite <-e1; eauto.
+ change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto.
 Qed.
 Hint Resolve concat_bst.
 
@@ -1270,10 +1270,10 @@ Proof.
 
  inv bst.
  rewrite H2, join_find; auto; clear H2.
- simpl; destruct X.compare; simpl; auto.
+ simpl; destruct X.compare as [Hlt| |Hlt]; simpl; auto.
  destruct (find y m2'); auto.
  symmetry; rewrite not_find_iff; auto; intro.
- apply (MX.lt_not_gt l); apply H1; auto; rewrite H3; auto.
+ apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto.
 
  intros z Hz; apply H1; auto; rewrite H3; auto.
 Qed.
@@ -1367,7 +1367,7 @@ Proof.
  induction s; simpl; intros; auto.
  rewrite IHs1, IHs2.
  unfold elements; simpl.
- rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
+ rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
 Qed.
 
 Lemma elements_node :
@@ -1376,7 +1376,7 @@ Lemma elements_node :
  elements (Node t1 x e t2 z) ++ l.
 Proof.
  unfold elements; simpl; intros.
- rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
+ rewrite !elements_app, !app_nil_r, !app_ass; auto.
 Qed.
 
 (** * Fold *)
@@ -1424,7 +1424,7 @@ Qed.
     i.e. the list of elements actually compared *)
 
 Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
-  | End => nil
+  | End _ => nil
   | More x e t r => (x,e) :: elements t ++ flatten_e r
  end.
 
@@ -1433,14 +1433,14 @@ Lemma flatten_e_elements :
  elements l ++ flatten_e (More x d r e) =
  elements (Node l x d r z) ++ flatten_e e.
 Proof.
- intros; simpl; apply elements_node.
+ intros; apply elements_node.
 Qed.
 
 Lemma cons_1 : forall (s:t elt) e,
   flatten_e (cons s e) = elements s ++ flatten_e e.
 Proof.
-  induction s; simpl; auto; intros.
-  rewrite IHs1; apply flatten_e_elements; auto.
+  induction s; auto; intros.
+  simpl flatten_e; rewrite IHs1; apply flatten_e_elements; auto.
 Qed.
 
 (** Proof of correction for the comparison *)
@@ -1478,7 +1478,7 @@ Lemma equal_cont_IfEq : forall m1 cont e2 l,
   (forall e, IfEq (cont e) l (flatten_e e)) ->
   IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2).
 Proof.
- induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto.
+ induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
  rewrite <- elements_node; simpl.
  apply Hl1; auto.
  clear e2; intros [|x2 d2 r2 e2].
@@ -1491,9 +1491,9 @@ Lemma equal_IfEq : forall (m1 m2:t elt),
   IfEq (equal cmp m1 m2) (elements m1) (elements m2).
 Proof.
  intros; unfold equal.
- rewrite (app_nil_end (elements m1)).
+ rewrite <- (app_nil_r (elements m1)).
  replace (elements m2) with (flatten_e (cons m2 (End _)))
-  by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto).
+  by (rewrite cons_1; simpl; rewrite app_nil_r; auto).
  apply equal_cont_IfEq.
  intros.
  apply equal_end_IfEq; auto.
@@ -1622,8 +1622,8 @@ Lemma map_option_find : forall (m:t elt)(x:key),
 Proof.
 intros m; functional induction (map_option f m); simpl; auto; intros;
  inv bst; rewrite join_find || rewrite concat_find; auto; simpl;
- try destruct X.compare; simpl; auto.
-rewrite (f_compat d e); auto.
+ try destruct X.compare as [Hlt|Heq|Hlt]; simpl; auto.
+rewrite (f_compat d Heq); auto.
 intros y H;
  destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
 intros y H;
@@ -1631,7 +1631,7 @@ intros y H;
 
 rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto.
 rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto.
-rewrite (f_compat d e); auto.
+rewrite (f_compat d Heq); auto.
 rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto.
  destruct (find x0 (map_option f r)); auto.
 
@@ -1930,7 +1930,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
  Lemma Equivb_Equivb : forall cmp m m',
   Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
  Proof.
- intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
+ intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. 
  generalize (H0 k); do 2 rewrite In_alt; intuition.
  generalize (H0 k); do 2 rewrite In_alt; intuition.
  generalize (H0 k); do 2 rewrite <- In_alt; intuition.
@@ -2016,7 +2016,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 :=
    match e2 with
-    | R.End => Gt
+    | R.End _ => Gt
     | R.More x2 d2 r2 e2 =>
        match X.compare x1 x2 with
         | EQ _ => match D.compare d1 d2 with
@@ -2033,7 +2033,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 :=
    match s1 with
-    | R.Leaf => cont e2
+    | R.Leaf _ => cont e2
     | R.Node l1 x1 d1 r1 _ =>
        compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
    end.
@@ -2041,7 +2041,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   (** Initial continuation *)
 
   Definition compare_end (e2:R.enumeration D.t) :=
-   match e2 with R.End => Eq | _ => Lt end.
+   match e2 with R.End _ => Eq | _ => Lt end.
 
   (** The complete comparison *)
 
@@ -2084,7 +2084,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
    (forall e, Cmp (cont e) l (P.flatten_e e)) ->
    Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2).
   Proof.
-   induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; simpl; intros; auto.
+   induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
    rewrite <- P.elements_node; simpl.
    apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2].
    simpl; auto.
@@ -2096,9 +2096,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
    Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2).
   Proof.
    intros; unfold compare_pure.
-   rewrite (app_nil_end (R.elements s1)).
+   rewrite <- (app_nil_r (R.elements s1)).
    replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by
-    (rewrite P.cons_1; simpl; rewrite <- app_nil_end; auto).
+    (rewrite P.cons_1; simpl; rewrite app_nil_r; auto).
    auto using compare_cont_Cmp, compare_end_Cmp.
   Qed.
 
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
index 0c1448c9..8c6f4b64 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -437,12 +437,6 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
 destruct (eq_dec x y); auto.
 Qed.
 
-Definition option_map (A B:Type)(f:A->B)(o:option A) : option B :=
- match o with
-  | Some a => Some (f a)
-  | None => None
- end.
-
 Lemma map_o : forall m x (f:elt->elt'),
  find x (map f m) = option_map f (find x m).
 Proof.
@@ -519,7 +513,7 @@ Proof.
 intros. rewrite eq_option_alt. intro e.
 rewrite <- find_mapsto_iff, elements_mapsto_iff.
 unfold eqb.
-rewrite <- findA_NoDupA; intuition; try apply elements_3w; eauto.
+rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto.
 Qed.
 
 Lemma elements_b : forall m x,
@@ -678,9 +672,9 @@ Qed.
 Add Parametric Morphism elt : (@Empty elt)
  with signature Equal ==> iff as Empty_m.
 Proof.
-unfold Empty; intros m m' Hm; intuition.
-rewrite <-Hm in H0; eauto.
-rewrite Hm in H0; eauto.
+unfold Empty; intros m m' Hm. split; intros; intro. 
+rewrite <-Hm in H0; eapply H, H0.
+rewrite Hm in H0; eapply H, H0.
 Qed.
 
 Add Parametric Morphism elt : (@is_empty elt)
@@ -708,18 +702,18 @@ Add Parametric Morphism elt : (@add elt)
  with signature E.eq ==> eq ==> Equal ==> Equal as add_m.
 Proof.
 intros k k' Hk e m m' Hm y.
-rewrite add_o, add_o; do 2 destruct eq_dec; auto.
-elim n; rewrite <-Hk; auto.
-elim n; rewrite Hk; auto.
+rewrite add_o, add_o; do 2 destruct eq_dec as [|?Hnot]; auto.
+elim Hnot; rewrite <-Hk; auto.
+elim Hnot; rewrite Hk; auto.
 Qed.
 
 Add Parametric Morphism elt : (@remove elt)
  with signature E.eq ==> Equal ==> Equal as remove_m.
 Proof.
 intros k k' Hk m m' Hm y.
-rewrite remove_o, remove_o; do 2 destruct eq_dec; auto.
-elim n; rewrite <-Hk; auto.
-elim n; rewrite Hk; auto.
+rewrite remove_o, remove_o; do 2 destruct eq_dec as [|?Hnot]; auto.
+elim Hnot; rewrite <-Hk; auto.
+elim Hnot; rewrite Hk; auto.
 Qed.
 
 Add Parametric Morphism elt elt' : (@map elt elt')
@@ -835,8 +829,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W :=
    fun p => f (fst p) (snd p).
 
-  Definition of_list (l : list (key*elt)) :=
-    List.fold_right (uncurry (@add _)) (empty _) l.
+  Definition of_list :=
+    List.fold_right (uncurry (@add _)) (empty elt).
 
   Definition to_list := elements.
 
@@ -867,7 +861,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
   inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
   specialize (IH k Hnodup'); clear Hnodup'.
   rewrite add_o, IH.
-  unfold eqb; do 2 destruct eq_dec; auto; elim n; eauto.
+  unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto.
   Qed.
 
   Lemma of_list_2 : forall l, NoDupA eqk l ->
@@ -934,7 +928,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
    apply InA_eqke_eqk with k e'; auto.
    rewrite <- of_list_1; auto.
    intro k'. rewrite Hsame, add_o, of_list_1b. simpl.
-   unfold eqb. do 2 destruct eq_dec; auto; elim n; eauto.
+   unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto.
    inversion_clear Hdup; auto.
   apply IHl.
    intros; eapply Hstep'; eauto.
@@ -1124,6 +1118,27 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E).
    auto with *.
   Qed.
 
+  Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j ->
+    eqA (fold f m1 i) (fold f m2 j).
+  Proof.
+  intros.
+  rewrite 2 fold_spec_right.
+  assert (NoDupA eqk (rev (elements m1))) by (auto with * ).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with * ).
+  apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke)
+  ; auto with *.
+  - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto.
+  - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto.
+  - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto.
+    rewrite h'.
+    auto.
+  - rewrite <- NoDupA_altdef; auto.
+  - intros (k,e).
+    rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H;
+      auto with *.
+  Qed.
+
+
   Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 ->
    eqA (fold f m2 i) (f k e (fold f m1 i)).
   Proof.
@@ -1871,14 +1886,9 @@ Module OrdProperties (M:S).
     find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
     add_mapsto_iff by (auto with *).
   unfold O.eqke, O.ltk; simpl.
-  destruct (E.compare t0 x); intuition.
-  right; split; auto; ME.order.
-  ME.order.
-  elim H.
-  exists e0; apply MapsTo_1 with t0; auto.
-  right; right; split; auto; ME.order.
-  ME.order.
-  right; split; auto; ME.order.
+  destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto.
+  - elim H; exists e0; apply MapsTo_1 with t0; auto.
+  - fold (~E.lt t0 x); auto.
   Qed.
 
   Lemma elements_Add_Above : forall m m' x e,
@@ -1901,7 +1911,7 @@ Module OrdProperties (M:S).
    find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
    add_mapsto_iff by (auto with *).
   unfold O.eqke; simpl. intuition.
-  destruct (E.eq_dec x t0); auto.
+  destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
   exfalso.
   assert (In t0 m).
    exists e0; auto.
@@ -1930,7 +1940,7 @@ Module OrdProperties (M:S).
     find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
     add_mapsto_iff by (auto with *).
   unfold O.eqke; simpl. intuition.
-  destruct (E.eq_dec x t0); auto.
+  destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
   exfalso.
   assert (In t0 m).
    exists e0; auto.
@@ -1986,7 +1996,7 @@ Module OrdProperties (M:S).
   inversion_clear H1; [ | inversion_clear H2; eauto ].
   red in H3; simpl in H3; destruct H3.
   destruct p as (p1,p2).
-  destruct (E.eq_dec p1 x).
+  destruct (E.eq_dec p1 x) as [Heq|Hneq].
   apply ME.lt_eq with p1; auto.
    inversion_clear H2.
    inversion_clear H5.
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
index e1c60351..a7be3232 100644
--- a/theories/FSets/FMapFullAVL.v
+++ b/theories/FSets/FMapFullAVL.v
@@ -660,7 +660,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
 
   Fixpoint cardinal_e (e:Raw.enumeration D.t) :=
     match e with
-     | Raw.End => 0%nat
+     | Raw.End _ => 0%nat
      | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
     end.
 
@@ -674,12 +674,14 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   Definition cardinal_e_2 ee :=
    (cardinal_e (fst ee) + cardinal_e (snd ee))%nat.
 
+  Local Unset Keyed Unification.
+
   Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t)
    { measure cardinal_e_2 ee } : comparison :=
   match ee with
-  | (Raw.End, Raw.End) => Eq
-  | (Raw.End, Raw.More _ _ _ _) => Lt
-  | (Raw.More _ _ _ _, Raw.End) => Gt
+  | (Raw.End _, Raw.End _) => Eq
+  | (Raw.End _, Raw.More _ _ _ _) => Lt
+  | (Raw.More _ _ _ _, Raw.End _) => Gt
   | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
       match X.compare x1 x2 with
       | EQ _ => match D.compare d1 d2 with
@@ -726,7 +728,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
   intros.
   assert (H1:=cons_1 m1 (Raw.End _)).
   assert (H2:=cons_1 m2 (Raw.End _)).
-  simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2.
+  simpl in *; rewrite app_nil_r in *; rewrite <-H1,<-H2.
   apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _),
                            Raw.cons m2 (Raw.End _))).
   Qed.
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index f15ab222..13cb559b 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -403,7 +403,7 @@ Proof.
  apply H1 with k; destruct (X.eq_dec x k); auto.
 
 
- destruct (X.compare x x'); try contradiction; clear y.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y.
  destruct (H0 x).
  assert (In x ((x',e')::l')).
   apply H; auto.
@@ -527,7 +527,7 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
    | nil => nil
    | (k,e)::m' => (k,f k e) :: mapi f m'
   end.
-
+ 
 End Elt.
 Section Elt2.
 (* A new section is necessary for previous definitions to work
@@ -543,14 +543,13 @@ Proof.
  intros m x e f.
  (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
  induction m.
- inversion 1.
+ inversion 1. 
 
  destruct a as (x',e').
  simpl.
- inversion_clear 1.
+ inversion_clear 1.  
  constructor 1.
  unfold eqke in *; simpl in *; intuition congruence.
- constructor 2.
  unfold MapsTo in *; auto.
 Qed.
 
@@ -799,7 +798,7 @@ Proof.
  intros.
  simpl.
  destruct a as (k,e); destruct a0 as (k',e').
- destruct (X.compare k k').
+ destruct (X.compare k k') as [Hlt|Heq|Hlt].
  inversion_clear Hm.
  constructor; auto.
  assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
@@ -868,8 +867,8 @@ Proof.
  induction m'.
  (* m' = nil *)
  intros; destruct a; simpl.
- destruct (X.compare x t0); simpl; auto.
- inversion_clear Hm; clear H0 l Hm' IHm t0.
+ destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto.
+ inversion_clear Hm; clear H0 Hlt Hm' IHm t0.
  induction m; simpl; auto.
  inversion_clear H.
  destruct a.
@@ -923,7 +922,7 @@ Proof.
  destruct o; destruct o'; simpl in *; try discriminate; auto.
  destruct a as (k,(oo,oo')); simpl in *.
  inversion_clear H2.
- destruct (X.compare x k); simpl in *.
+ destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *.
  (* x < k *)
  destruct (f' (oo,oo')); simpl.
  elim_comp.
@@ -959,7 +958,7 @@ Proof.
  destruct a as (k,(oo,oo')).
  simpl.
  inversion_clear H2.
- destruct (X.compare x k).
+ destruct (X.compare x k) as [Hlt|Heq|Hlt].
  (* x < k *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
@@ -1208,7 +1207,7 @@ Proof.
  destruct a as (x,e).
  destruct p as (x',e').
  unfold equal; simpl.
- destruct (X.compare x x'); simpl; intuition.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition.
  unfold cmp at 1.
  MD.elim_comp; clear H; simpl.
  inversion_clear Hl.
@@ -1245,21 +1244,21 @@ Lemma eq_refl : forall m : t, eq m m.
 Proof.
  intros (m,Hm); induction m; unfold eq; simpl; auto.
  destruct a.
- destruct (X.compare t0 t0); auto.
- apply (MapS.Raw.MX.lt_antirefl l); auto.
+ destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto.
+ apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
  split.
  apply D.eq_refl.
  inversion_clear Hm.
  apply (IHm H).
- apply (MapS.Raw.MX.lt_antirefl l); auto.
+ apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
 Qed.
 
-Lemma  eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
 Proof.
  intros (m,Hm); induction m;
  intros (m', Hm'); destruct m'; unfold eq; simpl;
  try destruct a as (x,e); try destruct p as (x',e'); auto.
- destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
+ destruct (X.compare x x')  as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition.
  inversion_clear Hm; inversion_clear Hm'.
  apply (IHm H0 (Build_slist H4)); auto.
 Qed.
@@ -1272,8 +1271,8 @@ Proof.
  try destruct a as (x,e);
  try destruct p as (x',e');
  try destruct p0 as (x'',e''); try contradiction; auto.
- destruct (X.compare x x');
-  destruct (X.compare x' x'');
+ destruct (X.compare x x') as [Hlt|Heq|Hlt];
+  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
    MapS.Raw.MX.elim_comp; intuition.
  apply D.eq_trans with e'; auto.
  inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
@@ -1288,8 +1287,8 @@ Proof.
  try destruct a as (x,e);
  try destruct p as (x',e');
  try destruct p0 as (x'',e''); try contradiction; auto.
- destruct (X.compare x x');
-  destruct (X.compare x' x'');
+ destruct (X.compare x x') as [Hlt|Heq|Hlt];
+  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
    MapS.Raw.MX.elim_comp; intuition.
  left; apply D.lt_trans with e'; auto.
  left; apply lt_eq with e'; auto.
@@ -1307,7 +1306,7 @@ Proof.
  intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
  try destruct a as (x,e);
  try destruct p as (x',e'); try contradiction; auto.
- destruct (X.compare x x'); auto.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto.
  intuition.
  exact (D.lt_not_eq H0 H1).
  inversion_clear Hm1; inversion_clear Hm2.
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index c59f7c22..3eac15b0 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -8,13 +8,11 @@
 
 (** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)
 
-Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface.
+Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface.
 
 Set Implicit Arguments.
 Local Open Scope positive_scope.
-
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
 
 (** This file is an adaptation to the [FMap] framework of a work by
   Xavier Leroy and Sandrine Blazy (used for building certified compilers).
@@ -71,7 +69,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Module E:=PositiveOrderedTypeBits.
   Module ME:=KeyOrderedType E.
 
-  Definition key := positive.
+  Definition key := positive : Type. 
 
   Inductive tree (A : Type) :=
     | Leaf : tree A
@@ -84,7 +82,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Section A.
   Variable A:Type.
 
-  Arguments Leaf [A].
+  Arguments Leaf {A}.
 
   Definition empty : t A := Leaf.
 
@@ -95,7 +93,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     | _ => false
    end.
 
-  Fixpoint find (i : positive) (m : t A) : option A :=
+  Fixpoint find (i : key) (m : t A) : option A :=
     match m with
     | Leaf => None
     | Node l o r =>
@@ -106,7 +104,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint mem (i : positive) (m : t A) : bool :=
+  Fixpoint mem (i : key) (m : t A) : bool :=
     match m with
     | Leaf => false
     | Node l o r =>
@@ -117,7 +115,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint add (i : positive) (v : A) (m : t A) : t A :=
+  Fixpoint add (i : key) (v : A) (m : t A) : t A :=
     match m with
     | Leaf =>
         match i with
@@ -133,7 +131,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint remove (i : positive) (m : t A) : t A :=
+  Fixpoint remove (i : key) (m : t A) : t A :=
     match i with
     | xH =>
         match m with
@@ -165,7 +163,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   (** [elements] *)
 
-    Fixpoint xelements (m : t A) (i : positive) : list (positive * A) :=
+    Fixpoint xelements (m : t A) (i : key) : list (key * A) :=
       match m with
       | Leaf => nil
       | Node l None r =>
@@ -192,33 +190,33 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Section CompcertSpec.
 
   Theorem gempty:
-    forall (i: positive), find i empty = None.
+    forall (i: key), find i empty = None.
   Proof.
     destruct i; simpl; auto.
   Qed.
 
   Theorem gss:
-    forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x.
+    forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x.
   Proof.
     induction i; destruct m; simpl; auto.
   Qed.
 
-  Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None.
+  Lemma gleaf : forall (i : key), find i (Leaf : t A) = None.
   Proof. exact gempty. Qed.
 
   Theorem gso:
-    forall (i j: positive) (x: A) (m: t A),
+    forall (i j: key) (x: A) (m: t A),
     i <> j -> find i (add j x m) = find i m.
   Proof.
     induction i; intros; destruct j; destruct m; simpl;
        try rewrite <- (gleaf i); auto; try apply IHi; congruence.
   Qed.
 
-  Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf.
+  Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
   Proof. destruct i; simpl; auto. Qed.
 
   Theorem grs:
-    forall (i: positive) (m: t A), find i (remove i m) = None.
+    forall (i: key) (m: t A), find i (remove i m) = None.
   Proof.
     induction i; destruct m.
      simpl; auto.
@@ -238,7 +236,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Theorem gro:
-    forall (i j: positive) (m: t A),
+    forall (i j: key) (m: t A),
     i <> j -> find i (remove j m) = find i m.
   Proof.
     induction i; intros; destruct j; destruct m;
@@ -267,11 +265,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Lemma xelements_correct:
-      forall (m: t A) (i j : positive) (v: A),
+      forall (m: t A) (i j : key) (v: A),
       find i m = Some v -> List.In (append j i, v) (xelements m j).
     Proof.
       induction m; intros.
-       rewrite (gleaf i) in H; congruence.
+       rewrite (gleaf i) in H; discriminate. 
        destruct o; destruct i; simpl; simpl in H.
         rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
           apply IHm2; auto.
@@ -284,14 +282,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
   Theorem elements_correct:
-    forall (m: t A) (i: positive) (v: A),
+    forall (m: t A) (i: key) (v: A),
     find i m = Some v -> List.In (i, v) (elements m).
   Proof.
     intros m i v H.
     exact (xelements_correct m i xH H).
   Qed.
 
-  Fixpoint xfind (i j : positive) (m : t A) : option A :=
+  Fixpoint xfind (i j : key) (m : t A) : option A :=
       match i, j with
       | _, xH => find i m
       | xO ii, xO jj => xfind ii jj m
@@ -300,7 +298,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       end.
 
    Lemma xfind_left :
-      forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A),
+      forall (j i : key) (m1 m2 : t A) (o : option A) (v : A),
       xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
     Proof.
       induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
@@ -308,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_ii :
-      forall (m: t A) (i j : positive) (v: A),
+      forall (m: t A) (i j : key) (v: A),
       List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
     Proof.
       induction m.
@@ -324,7 +322,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_io :
-      forall (m: t A) (i j : positive) (v: A),
+      forall (m: t A) (i j : key) (v: A),
       ~List.In (xI i, v) (xelements m (xO j)).
     Proof.
       induction m.
@@ -339,7 +337,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_oo :
-      forall (m: t A) (i j : positive) (v: A),
+      forall (m: t A) (i j : key) (v: A),
       List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
     Proof.
       induction m.
@@ -355,7 +353,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_oi :
-      forall (m: t A) (i j : positive) (v: A),
+      forall (m: t A) (i j : key) (v: A),
       ~List.In (xO i, v) (xelements m (xI j)).
     Proof.
       induction m.
@@ -370,7 +368,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_ih :
-      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      forall (m1 m2: t A) (o: option A) (i : key) (v: A),
       List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
     Proof.
       destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
@@ -383,7 +381,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_oh :
-      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
+      forall (m1 m2: t A) (o: option A) (i : key) (v: A),
       List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
     Proof.
       destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
@@ -396,7 +394,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_hi :
-      forall (m: t A) (i : positive) (v: A),
+      forall (m: t A) (i : key) (v: A),
       ~List.In (xH, v) (xelements m (xI i)).
     Proof.
       induction m; intros.
@@ -411,7 +409,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma xelements_ho :
-      forall (m: t A) (i : positive) (v: A),
+      forall (m: t A) (i : key) (v: A),
       ~List.In (xH, v) (xelements m (xO i)).
     Proof.
       induction m; intros.
@@ -426,13 +424,13 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
     Lemma find_xfind_h :
-      forall (m: t A) (i: positive), find i m = xfind i xH m.
+      forall (m: t A) (i: key), find i m = xfind i xH m.
     Proof.
       destruct i; simpl; auto.
     Qed.
 
     Lemma xelements_complete:
-      forall (i j : positive) (m: t A) (v: A),
+      forall (i j : key) (m: t A) (v: A),
       List.In (i, v) (xelements m j) -> xfind i j m = Some v.
     Proof.
       induction i; simpl; intros; destruct j; simpl.
@@ -460,7 +458,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
     Qed.
 
   Theorem elements_complete:
-    forall (m: t A) (i: positive) (v: A),
+    forall (m: t A) (i: key) (v: A),
     List.In (i, v) (elements m) -> find i m = Some v.
   Proof.
     intros m i v H.
@@ -481,22 +479,22 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   End CompcertSpec.
 
-  Definition MapsTo (i:positive)(v:A)(m:t A) := find i m = Some v.
+  Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.
 
-  Definition In (i:positive)(m:t A) := exists e:A, MapsTo i e m.
+  Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.
 
-  Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m.
+  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.
 
-  Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p').
+  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').
 
-  Definition eq_key_elt (p p':positive*A) :=
+  Definition eq_key_elt (p p':key*A) :=
           E.eq (fst p) (fst p') /\ (snd p) = (snd p').
 
-  Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p').
+  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').
 
-  Global Program Instance eqk_equiv : Equivalence eq_key.
-  Global Program Instance eqke_equiv : Equivalence eq_key_elt.
-  Global Program Instance ltk_strorder : StrictOrder lt_key.
+  Global Instance eqk_equiv : Equivalence eq_key := _.
+  Global Instance eqke_equiv : Equivalence eq_key_elt := _.
+  Global Instance ltk_strorder : StrictOrder lt_key := _.
 
   Lemma mem_find :
     forall m x, mem x m = match find x m with None => false | _ => true end.
@@ -717,8 +715,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Lemma elements_3w : NoDupA eq_key (elements m).
   Proof.
-  change eq_key with (@ME.eqk A).
-  apply ME.Sort_NoDupA; apply elements_3; auto.
+    apply ME.Sort_NoDupA.
+    apply elements_3.
   Qed.
 
   End FMapSpec.
@@ -729,9 +727,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Section Mapi.
 
-    Variable f : positive -> A -> B.
+    Variable f : key -> A -> B.
 
-    Fixpoint xmapi (m : t A) (i : positive) : t B :=
+    Fixpoint xmapi (m : t A) (i : key) : t B :=
        match m with
         | Leaf => @Leaf B
         | Node l o r => Node (xmapi l (append i (xO xH)))
@@ -748,7 +746,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   End A.
 
   Lemma xgmapi:
-      forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A),
+      forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A),
       find i (xmapi f m j) = option_map (f (append j i)) (find i m).
   Proof.
   induction i; intros; destruct m; simpl; auto.
@@ -758,7 +756,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Qed.
 
   Theorem gmapi:
-    forall (A B: Type) (f: positive -> A -> B) (i: positive) (m: t A),
+    forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A),
     find i (mapi f m) = option_map (f i) (find i m).
   Proof.
   intros.
@@ -814,7 +812,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Variable A B C : Type.
   Variable f : option A -> option B -> option C.
 
-  Arguments Leaf [A].
+  Arguments Leaf {A}.
 
   Fixpoint xmap2_l (m : t A) : t C :=
       match m with
@@ -822,7 +820,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
       end.
 
-  Lemma xgmap2_l : forall (i : positive) (m : t A),
+  Lemma xgmap2_l : forall (i : key) (m : t A),
           f None None = None -> find i (xmap2_l m) = f (find i m) None.
     Proof.
       induction i; intros; destruct m; simpl; auto.
@@ -834,7 +832,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
       | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
       end.
 
-  Lemma xgmap2_r : forall (i : positive) (m : t B),
+  Lemma xgmap2_r : forall (i : key) (m : t B),
           f None None = None -> find i (xmap2_r m) = f None (find i m).
     Proof.
       induction i; intros; destruct m; simpl; auto.
@@ -850,7 +848,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-    Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B),
+    Lemma gmap2: forall (i: key)(m1:t A)(m2: t B),
       f None None = None ->
       find i (_map2 m1 m2) = f (find i m1) (find i m2).
     Proof.
@@ -898,11 +896,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
   Section Fold.
 
     Variables A B : Type.
-    Variable f : positive -> A -> B -> B.
+    Variable f : key -> A -> B -> B.
 
-    Fixpoint xfoldi (m : t A) (v : B) (i : positive) :=
+    Fixpoint xfoldi (m : t A) (v : B) (i : key) :=
       match m with
-        | Leaf => v
+        | Leaf _ => v
         | Node l (Some x) r =>
           xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3)
         | Node l None r =>
@@ -940,8 +938,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
 
   Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
     match m1, m2 with
-      | Leaf, _ => is_empty m2
-      | _, Leaf => is_empty m1
+      | Leaf _, _ => is_empty m2
+      | _, Leaf _ => is_empty m1
       | Node l1 o1 r1, Node l2 o2 r2 =>
            (match o1, o2 with
              | None, None => true
@@ -1072,16 +1070,16 @@ Module PositiveMapAdditionalFacts.
 
   (* Derivable from the Map interface *)
   Theorem gsspec:
-    forall (A:Type)(i j: positive) (x: A) (m: t A),
+    forall (A:Type)(i j: key) (x: A) (m: t A),
     find i (add j x m) = if E.eq_dec i j then Some x else find i m.
   Proof.
     intros.
-    destruct (E.eq_dec i j); [ rewrite e; apply gss | apply gso; auto ].
+    destruct (E.eq_dec i j) as [ ->|]; [ apply gss | apply gso; auto ].
   Qed.
 
    (* Not derivable from the Map interface *)
   Theorem gsident:
-    forall (A:Type)(i: positive) (m: t A) (v: A),
+    forall (A:Type)(i: key) (m: t A) (v: A),
     find i m = Some v -> add i v m = m.
   Proof.
     induction i; intros; destruct m; simpl; simpl in H; try congruence.
@@ -1120,4 +1118,3 @@ Module PositiveMapAdditionalFacts.
   Qed.
 
 End PositiveMapAdditionalFacts.
-
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index 6c1e8ca8..0f11dd7a 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -146,9 +146,10 @@ Proof.
  induction m; simpl; auto; destruct a; intros.
  inversion_clear Hm.
  rewrite (IHm H1 x x'); auto.
- destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial.
- elim n; apply X.eq_trans with x; auto.
- elim n; apply X.eq_trans with x'; auto.
+ destruct (X.eq_dec x t0) as [|Hneq]; destruct (X.eq_dec x' t0) as [|?Hneq'];
+   trivial.
+ elim Hneq'; apply X.eq_trans with x; auto.
+ elim Hneq; apply X.eq_trans with x'; auto.
 Qed.
 
 (** * [add] *)
@@ -600,18 +601,18 @@ Definition combine_l (m:t elt)(m':t elt') : t oee' :=
 Definition combine_r (m:t elt)(m':t elt') : t oee' :=
   mapi (fun k e' => (find k m, Some e')) m'.
 
-Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) :=
-  List.fold_right (fun p => f (fst p) (snd p)) i l.
+Definition fold_right_pair (A B C:Type)(f:A->B->C->C) :=
+  List.fold_right (fun p => f (fst p) (snd p)).
 
 Definition combine (m:t elt)(m':t elt') : t oee' :=
   let l := combine_l m m' in
   let r := combine_r m m' in
-  fold_right_pair (add (elt:=oee')) l r.
+  fold_right_pair (add (elt:=oee')) r l.
 
 Lemma fold_right_pair_NoDup :
   forall l r (Hl: NoDupA (eqk (elt:=oee')) l)
     (Hl: NoDupA (eqk (elt:=oee')) r),
-    NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r).
+    NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l).
 Proof.
  induction l; simpl; auto.
  destruct a; simpl; auto.
@@ -733,7 +734,7 @@ Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
 Definition map2 m m' :=
   let m0 : t oee' := combine m m' in
   let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
-  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+  fold_right_pair (option_cons (A:=elt'')) nil m1.
 
 Lemma map2_NoDup :
   forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'),
@@ -787,14 +788,14 @@ Proof.
  destruct o; destruct o'; simpl in *; try discriminate; auto.
  destruct a as (k,(oo,oo')); simpl in *.
  inversion_clear H2.
- destruct (X.eq_dec x k); simpl in *.
+ destruct (X.eq_dec x k) as [|Hneq]; simpl in *.
  (* x = k *)
  assert (at_least_one_then_f o o' = f oo oo').
   destruct o; destruct o'; simpl in *; inversion_clear H; auto.
  rewrite H2.
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
- destruct (X.eq_dec x k); try contradict n; auto.
+ destruct (X.eq_dec x k) as [|Hneq]; try contradict Hneq; auto.
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
  case_eq (find x m0); intros; auto.
  elim H0.
@@ -804,7 +805,7 @@ Proof.
  (* k < x *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
- destruct (X.eq_dec x k); [ contradict n; auto | auto].
+ destruct (X.eq_dec x k); [ contradict Hneq; auto | auto].
  destruct (IHm0 H1) as (H3,_); apply H3; auto.
  destruct (IHm0 H1) as (H3,_); apply H3; auto.
 
@@ -812,13 +813,13 @@ Proof.
  destruct a as (k,(oo,oo')).
  simpl.
  inversion_clear H2.
- destruct (X.eq_dec x k).
+ destruct (X.eq_dec x k) as [|Hneq].
  (* x = k *)
  discriminate.
  (* k < x *)
  unfold f'; simpl.
  destruct (f oo oo'); simpl.
- destruct (X.eq_dec x k); [ contradict n; auto | auto].
+ destruct (X.eq_dec x k); [ contradict Hneq; auto | auto].
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
  destruct (IHm0 H1) as (_,H4); apply H4; auto.
 Qed.
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
index 1ac544e1..97f140b3 100644
--- a/theories/FSets/FSetBridge.v
+++ b/theories/FSets/FSetBridge.v
@@ -284,7 +284,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
 
   Lemma choose_equal : forall s s', Equal s s' ->
      match choose s, choose s' with
-       | inleft (exist x _), inleft (exist x' _) => E.eq x x'
+       | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x'
        | inright _, inright _  => True
        | _, _                        => False
      end.
@@ -423,7 +423,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Definition choose (s : t) : option elt :=
     match choose s with
-    | inleft (exist x _) => Some x
+    | inleft (exist _ x _) => Some x
     | inright _ => None
     end.
 
@@ -472,7 +472,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Definition min_elt (s : t) : option elt :=
     match min_elt s with
-    | inleft (exist x _) => Some x
+    | inleft (exist _ x _) => Some x
     | inright _ => None
     end.
 
@@ -500,7 +500,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
 
   Definition max_elt (s : t) : option elt :=
     match max_elt s with
-    | inleft (exist x _) => Some x
+    | inleft (exist _ x _) => Some x
     | inright _ => None
     end.
 
@@ -673,24 +673,24 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x (filter f s) -> In x s.
   Proof.
-    intros s x f; unfold filter; case M.filter; intuition.
-    generalize (i (compat_P_aux H)); firstorder.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
   Qed.
 
   Lemma filter_2 :
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x (filter f s) -> f x = true.
   Proof.
-    intros s x f; unfold filter; case M.filter; intuition.
-    generalize (i (compat_P_aux H)); firstorder.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
   Qed.
 
   Lemma filter_3 :
    forall (s : t) (x : elt) (f : elt -> bool),
    compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
   Proof.
-    intros s x f; unfold filter; case M.filter; intuition.
-    generalize (i (compat_P_aux H)); firstorder.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
   Qed.
 
   Definition for_all (f : elt -> bool) (s : t) : bool :=
diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v
index 6b3d86d3..b1769da3 100644
--- a/theories/FSets/FSetCompat.v
+++ b/theories/FSets/FSetCompat.v
@@ -283,6 +283,8 @@ Module Update_WSets
 
   Lemma is_empty_spec : is_empty s = true <-> Empty s.
   Proof. intros; symmetry; apply MF.is_empty_iff. Qed.
+  
+  Declare Equivalent Keys In M.In.
 
   Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
   Proof. intros. rewrite MF.add_iff. intuition. Qed.
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
index f64df9fe..ad067eb3 100644
--- a/theories/FSets/FSetDecide.v
+++ b/theories/FSets/FSetDecide.v
@@ -15,7 +15,7 @@
 (** This file implements a decision procedure for a certain
     class of propositions involving finite sets.  *)
 
-Require Import Decidable DecidableTypeEx FSetFacts.
+Require Import Decidable Setoid DecidableTypeEx FSetFacts.
 
 (** First, a version for Weak Sets in functorial presentation *)
 
@@ -115,8 +115,8 @@ the above form:
       not affect the namespace if you import the enclosing
       module [Decide]. *)
   Module FSetLogicalFacts.
-    Require Export Decidable.
-    Require Export Setoid.
+    Export Decidable.
+    Export Setoid.
 
     (** ** Lemmas and Tactics About Decidable Propositions *)
 
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index ac495c04..f2f4cc2c 100644
--- a/theories/FSets/FSetEqProperties.v
+++ b/theories/FSets/FSetEqProperties.v
@@ -822,7 +822,7 @@ Proof.
 intros.
 rewrite for_all_exists in H; auto.
 rewrite negb_true_iff in H.
-elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto.
+destruct (for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,p); auto.
 elim p;intros.
 exists x;split;auto.
 rewrite <-negb_false_iff; auto.
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
index a0361119..c791f49a 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -497,7 +497,7 @@ Module Type Sdep.
         in the dependent version of [choose], so we leave it separate. *)
   Parameter choose_equal : forall s s', Equal s s' ->
      match choose s, choose s' with
-       | inleft (exist x _), inleft (exist x' _) => E.eq x x'
+       | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x'
        | inright _, inright _  => True
        | _, _  => False
      end.
diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v
index e5d55ac5..7398c6d6 100644
--- a/theories/FSets/FSetPositive.v
+++ b/theories/FSets/FSetPositive.v
@@ -19,20 +19,15 @@
 Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface.
 
 Set Implicit Arguments.
-
 Local Open Scope lazy_bool_scope.
 Local Open Scope positive_scope.
-
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
-Local Unset Boolean Equality Schemes.
-
 
 Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Module E:=PositiveOrderedTypeBits.
 
-  Definition elt := positive.
+  Definition elt := positive : Type.
 
   Inductive tree :=
     | Leaf : tree
@@ -40,9 +35,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Scheme tree_ind := Induction for tree Sort Prop.
 
-  Definition t := tree.
+  Definition t := tree : Type.
 
-  Definition empty := Leaf.
+  Definition empty : t := Leaf.
 
   Fixpoint is_empty (m : t) : bool :=
    match m with
@@ -50,7 +45,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     | Node l b r => negb b &&& is_empty l &&& is_empty r
    end.
 
-  Fixpoint mem (i : positive) (m : t) : bool :=
+  Fixpoint mem (i : elt) (m : t) {struct m} : bool :=
     match m with
     | Leaf => false
     | Node l o r =>
@@ -61,7 +56,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint add (i : positive) (m : t) : t :=
+  Fixpoint add (i : elt) (m : t) : t :=
     match m with
     | Leaf =>
         match i with
@@ -81,13 +76,13 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** helper function to avoid creating empty trees that are not leaves *)
 
-  Definition node l (b: bool) r :=
+  Definition node (l : t) (b: bool) (r : t) : t :=
     if b then Node l b r else
      match l,r with
        | Leaf,Leaf => Leaf
        | _,_ => Node l false r end.
 
-  Fixpoint remove (i : positive) (m : t) : t :=
+  Fixpoint remove (i : elt) (m : t) {struct m} : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -98,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint union (m m': t) :=
+  Fixpoint union (m m': t) : t :=
     match m with
       | Leaf => m'
       | Node l o r =>
@@ -108,7 +103,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint inter (m m': t) :=
+  Fixpoint inter (m m': t) : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -118,7 +113,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint diff (m m': t) :=
+  Fixpoint diff (m m': t) : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -150,7 +145,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** reverses [y] and concatenate it with [x] *)
 
-  Fixpoint rev_append y x :=
+  Fixpoint rev_append (y x : elt) : elt :=
     match y with
       | 1 => x
       | y~1 => rev_append y x~1
@@ -161,8 +156,8 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Section Fold.
 
-    Variables B : Type.
-    Variable f : positive -> B -> B.
+    Variable B : Type.
+    Variable f : elt -> B -> B.
 
     (** the additional argument, [i], records the current path, in
        reverse order (this should be more efficient: we reverse this argument
@@ -170,7 +165,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
        we also use this convention in all functions below
      *)
 
-    Fixpoint xfold (m : t) (v : B) (i : positive) :=
+    Fixpoint xfold (m : t) (v : B) (i : elt) :=
       match m with
         | Leaf => v
         | Node l true r =>
@@ -184,9 +179,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Section Quantifiers.
 
-    Variable f : positive -> bool.
+    Variable f : elt -> bool.
 
-    Fixpoint xforall (m : t) (i : positive) :=
+    Fixpoint xforall (m : t) (i : elt) :=
       match m with
         | Leaf => true
         | Node l o r =>
@@ -194,21 +189,21 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       end.
     Definition for_all m := xforall m 1.
 
-    Fixpoint xexists (m : t) (i : positive) :=
+    Fixpoint xexists (m : t) (i : elt) :=
       match m with
         | Leaf => false
         | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
       end.
     Definition exists_ m := xexists m 1.
 
-    Fixpoint xfilter (m : t) (i : positive) :=
+    Fixpoint xfilter (m : t) (i : elt) : t :=
       match m with
         | Leaf => Leaf
         | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
       end.
     Definition filter m := xfilter m 1.
 
-    Fixpoint xpartition (m : t) (i : positive) :=
+    Fixpoint xpartition (m : t) (i : elt) : t * t :=
       match m with
         | Leaf => (Leaf,Leaf)
         | Node l o r =>
@@ -226,7 +221,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** uses [a] to accumulate values rather than doing a lot of concatenations *)
 
-  Fixpoint xelements (m : t) (i : positive) (a: list positive) :=
+  Fixpoint xelements (m : t) (i : elt) (a: list elt) :=
     match m with
       | Leaf => a
       | Node l false r => xelements l i~0 (xelements r i~1 a)
@@ -250,7 +245,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** would it be more efficient to use a path like in the above functions ? *)
 
-  Fixpoint choose (m: t) :=
+  Fixpoint choose (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r => if o then Some 1 else
@@ -260,7 +255,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint min_elt (m: t) :=
+  Fixpoint min_elt (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r =>
@@ -270,7 +265,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint max_elt (m: t) :=
+  Fixpoint max_elt (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r =>
@@ -311,6 +306,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
 
   Definition eq := Equal.
+
+  Declare Equivalent Keys Equal eq.
+
   Definition lt m m' := compare_fun m m' = Lt.
 
   (** Specification of [In] *)
@@ -355,10 +353,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     case o; trivial.
     destruct l; trivial.
     destruct r; trivial.
-    symmetry. destruct x.
-      apply mem_Leaf.
-      apply mem_Leaf.
-      reflexivity.
+    now destruct x.
   Qed.
   Local Opaque node.
 
@@ -367,8 +362,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true.
   Proof.
     unfold Empty, In.
-    induction s as [|l IHl o r IHr]; simpl.
-      setoid_rewrite mem_Leaf. firstorder.
+    induction s as [|l IHl o r IHr]; simpl. now split.
       rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr.
       destruct o; simpl; split.
         intro H. elim (H 1). reflexivity.
@@ -759,7 +753,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Proof. intros. rewrite diff_spec. split; assumption. Qed.
 
   (** Specification of [fold] *)
-
+  
   Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A),
       fold f s i = fold_left (fun a e => f e a) (elements s) i.
   Proof.
@@ -807,15 +801,15 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
        rewrite <- andb_lazy_alt. apply andb_true_iff.
   Qed.
 
-  Lemma filter_1 : forall s x f, compat_bool E.eq f ->
+  Lemma filter_1 : forall s x f, @compat_bool elt E.eq f ->
     In x (filter f s) -> In x s.
   Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
 
-  Lemma filter_2 : forall s x f, compat_bool E.eq f ->
+  Lemma filter_2 : forall s x f, @compat_bool elt E.eq f ->
     In x (filter f s) -> f x = true.
   Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
 
-  Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s ->
+  Lemma filter_3 : forall s x f, @compat_bool elt E.eq f -> In x s ->
     f x = true -> In x (filter f s).
   Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
 
@@ -826,8 +820,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
   Proof.
     unfold For_all, In. intro f.
-    induction s as [|l IHl o r IHr]; intros i; simpl.
-     setoid_rewrite mem_Leaf. intuition discriminate.
+    induction s as [|l IHl o r IHr]; intros i; simpl. now split.
      rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
      rewrite IHl, IHr. clear IHl IHr.
       split.
@@ -841,11 +834,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         apply H. assumption.
   Qed.
 
-  Lemma for_all_1 : forall s f, compat_bool E.eq f ->
+  Lemma for_all_1 : forall s f, @compat_bool elt E.eq f ->
     For_all (fun x => f x = true) s -> for_all f s = true.
   Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
 
-  Lemma for_all_2 : forall s f, compat_bool E.eq f ->
+  Lemma for_all_2 : forall s f, @compat_bool elt E.eq f ->
     for_all f s = true -> For_all (fun x => f x = true) s.
   Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
 
@@ -857,7 +850,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Proof.
     unfold Exists, In. intro f.
     induction s as [|l IHl o r IHr]; intros i; simpl.
-     setoid_rewrite mem_Leaf. firstorder.
+    split; [ discriminate | now intros  [ _ [? _]]].
      rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
      rewrite IHl, IHr. clear IHl IHr.
       split.
@@ -868,11 +861,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
        intros [[x|x|] H]; eauto.
   Qed.
 
-  Lemma exists_1 : forall s f, compat_bool E.eq f ->
+  Lemma exists_1 : forall s f, @compat_bool elt E.eq f ->
       Exists (fun x => f x = true) s -> exists_ f s = true.
   Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
 
-  Lemma exists_2 : forall s f, compat_bool E.eq f ->
+  Lemma exists_2 : forall s f, @compat_bool elt E.eq f ->
       exists_ f s = true -> Exists (fun x => f x = true) s.
   Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
 
@@ -888,11 +881,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       destruct o; simpl; rewrite IHl, IHr; reflexivity.
   Qed.
 
-  Lemma partition_1 : forall s f, compat_bool E.eq f ->
+  Lemma partition_1 : forall s f, @compat_bool elt E.eq f ->
       Equal (fst (partition f s)) (filter f s).
   Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
 
-  Lemma partition_2 : forall s f, compat_bool E.eq f ->
+  Lemma partition_2 : forall s f, @compat_bool elt E.eq f ->
       Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
   Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
 
@@ -909,7 +902,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; simpl.
       intros. split; intro H.
         left. assumption.
-        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx').
+        destruct H as [H|[x [Hx Hx']]]. assumption. discriminate.
 
       intros j acc y. case o.
         rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
@@ -1000,7 +993,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       constructor.
        intros x H. apply E.lt_not_eq in H. apply H. reflexivity.
        intro. apply E.lt_trans.
-      intros ? ? <- ? ? <-. reflexivity.
+     solve_proper.
       apply elements_3.
   Qed.
 
@@ -1111,7 +1104,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
           destruct (min_elt r).
             injection H. intros <-. clear H.
             destruct y as [z|z|].
-              apply (IHr p z); trivial.
+              apply (IHr e z); trivial.
               elim (Hp _ H').
               discriminate.
             discriminate.
@@ -1165,7 +1158,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
             injection H. intros <-. clear H.
             destruct y as [z|z|].
               elim (Hp _ H').
-              apply (IHl p z); trivial.
+              apply (IHl e z); trivial.
               discriminate.
             discriminate.
   Qed.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index d53ce0c8..25b042ca 100644
--- a/theories/FSets/FSetProperties.v
+++ b/theories/FSets/FSetProperties.v
@@ -995,8 +995,7 @@ Module OrdProperties (M:S).
    leb_1, gtb_1, (H0 a) by auto with *.
   intuition.
   destruct (E.compare a x); intuition.
-  right; right; split; auto with *.
-  ME.order.
+  fold (~E.lt a x); auto with *.
   Qed.
 
   Definition Above x s := forall y, In y s -> E.lt y x.
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index e7e6ed9e..de615301 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -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        *)
@@ -87,7 +87,7 @@ Hint Constructors eq_true : eq_true.
 Definition is_true b := b = true.
 
 (** [is_true] can be activated as a coercion by
-   (Local) Coercion is_true : bool >-> Prop.
+   ([Local]) [Coercion is_true : bool >-> Sortclass].
 *)
 
 (** Additional rewriting lemmas about [eq_true] *)
@@ -143,18 +143,20 @@ Arguments S _%nat.
 (********************************************************************)
 (** * Container datatypes *)
 
+(* Set Universe Polymorphism. *)
+
 (** [option A] is the extension of [A] with an extra element [None] *)
 
 Inductive option (A:Type) : Type :=
   | Some : A -> option A
   | None : option A.
 
-Arguments None [A].
+Arguments None {A}.
 
-Definition option_map (A B:Type) (f:A->B) o :=
+Definition option_map (A B:Type) (f:A->B) (o : option A) : option B :=
   match o with
-    | Some a => Some (f a)
-    | None => None
+    | Some a => @Some B (f a)
+    | None => @None B
   end.
 
 (** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)
@@ -182,7 +184,8 @@ Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
 Arguments pair {A B} _ _.
 
 Section projections.
-  Variables A B : Type.
+  Context {A : Type} {B : Type}.
+
   Definition fst (p:A * B) := match p with
 				| (x, y) => x
                               end.
@@ -221,7 +224,7 @@ Inductive list (A : Type) : Type :=
  | nil : list A
  | cons : A -> list A -> list A.
 
-Arguments nil [A].
+Arguments nil {A}.
 Infix "::" := cons (at level 60, right associativity) : list_scope.
 Delimit Scope list_scope with list.
 Bind Scope list_scope with list.
@@ -244,8 +247,10 @@ Definition app (A : Type) : list A -> list A -> list A :=
    | a :: l1 => a :: app l1 m
   end.
 
+
 Infix "++" := app (right associativity, at level 60) : list_scope.
 
+(* Unset Universe Polymorphism. *)
 
 (********************************************************************)
 (** * The comparison datatype *)
@@ -310,6 +315,7 @@ Defined.
 
 Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
  CompareSpec (eq x y) (lt x y) (lt y x).
+
 Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
  CompareSpecT (eq x y) (lt x y) (lt y x).
 Hint Unfold CompSpec CompSpecT.
@@ -339,6 +345,9 @@ Arguments identity_rect [A] a P f y i.
 Definition ID := forall A:Type, A -> A.
 Definition id : ID := fun A x => x.
 
+Definition IDProp := forall A:Prop, A -> A.
+Definition idProp : IDProp := fun A x => x.
+
 
 (* begin hide *)
 
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index e5f7a78b..d2971552 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -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,17 +8,23 @@
 
 Set Implicit Arguments.
 
-Require Import Notations.
+Require Export Notations.
+
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
 
 (** * Propositional connectives *)
 
 (** [True] is the always true proposition *)
+
 Inductive True : Prop :=
   I : True.
 
 (** [False] is the always false proposition *)
 Inductive False : Prop :=.
 
+(** [proof_admitted] is used to implement the admit tactic *)
+Axiom proof_admitted : False.
+
 (** [not A], written [~A], is the negation of [A] *)
 Definition not (A:Prop) := A -> False.
 
@@ -92,6 +98,36 @@ End Equivalence.
 
 Hint Unfold iff: extcore.
 
+(** Backward direction of the equivalences above does not need assumptions *)
+
+Theorem and_iff_compat_l : forall A B C : Prop,
+  (B <-> C) -> (A /\ B <-> A /\ C).
+Proof.
+  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ assumption | ]);
+  [apply Hl | apply Hr]; assumption.
+Qed.
+
+Theorem and_iff_compat_r : forall A B C : Prop,
+  (B <-> C) -> (B /\ A <-> C /\ A).
+Proof.
+  intros ? ? ? [Hl Hr]; split; intros [? ?]; (split; [ | assumption ]);
+  [apply Hl | apply Hr]; assumption.
+Qed.
+
+Theorem or_iff_compat_l : forall A B C : Prop,
+  (B <-> C) -> (A \/ B <-> A \/ C).
+Proof.
+  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left; assumption| right]);
+  [apply Hl | apply Hr]; assumption.
+Qed.
+
+Theorem or_iff_compat_r : forall A B C : Prop,
+  (B <-> C) -> (B \/ A <-> C \/ A).
+Proof.
+  intros ? ? ? [Hl Hr]; split; (intros [?|?]; [left| right; assumption]);
+  [apply Hl | apply Hr]; assumption.
+Qed.
+
 (** Some equivalences *)
 
 Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
@@ -104,73 +140,62 @@ Qed.
 Theorem and_cancel_l : forall A B C : Prop,
   (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
 Proof.
-  intros; tauto.
+  intros A B C Hl Hr.
+  split; [ | apply and_iff_compat_l]; intros [HypL HypR]; split; intros.
+  + apply HypL; split; [apply Hl | ]; assumption.
+  + apply HypR; split; [apply Hr | ]; assumption.
 Qed.
 
 Theorem and_cancel_r : forall A B C : Prop,
   (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
 Proof.
-  intros; tauto.
+  intros A B C Hl Hr.
+  split; [ | apply and_iff_compat_r]; intros [HypL HypR]; split; intros.
+  + apply HypL; split; [ | apply Hl ]; assumption.
+  + apply HypR; split; [ | apply Hr ]; assumption.
 Qed.
 
 Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
 Proof.
-  intros; tauto.
+  intros; split; intros [? ?]; split; assumption.
 Qed.
 
 Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
 Proof.
-  intros; tauto.
+  intros; split; [ intros [[? ?] ?]| intros [? [? ?]]]; repeat split; assumption.
 Qed.
 
 Theorem or_cancel_l : forall A B C : Prop,
   (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
 Proof.
-  intros; tauto.
+  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_l]; intros [Hl Hr]; split; intros.
+  { destruct Hl; [ right | destruct Fl | ]; assumption. }
+  { destruct Hr; [ right | destruct Fr | ]; assumption. }
 Qed.
 
 Theorem or_cancel_r : forall A B C : Prop,
   (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
 Proof.
-  intros; tauto.
+  intros ? ? ? Fl Fr; split; [ | apply or_iff_compat_r]; intros [Hl Hr]; split; intros.
+  { destruct Hl; [ left | | destruct Fl ]; assumption. }
+  { destruct Hr; [ left | | destruct Fr ]; assumption. }
 Qed.
 
 Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
 Proof.
-  intros; tauto.
+  intros; split; (intros [? | ?]; [ right | left ]; assumption).
 Qed.
 
 Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
 Proof.
-  intros; tauto.
-Qed.
-
-(** Backward direction of the equivalences above does not need assumptions *)
-
-Theorem and_iff_compat_l : forall A B C : Prop,
-  (B <-> C) -> (A /\ B <-> A /\ C).
-Proof.
-  intros; tauto.
-Qed.
-
-Theorem and_iff_compat_r : forall A B C : Prop,
-  (B <-> C) -> (B /\ A <-> C /\ A).
-Proof.
-  intros; tauto.
-Qed.
-
-Theorem or_iff_compat_l : forall A B C : Prop,
-  (B <-> C) -> (A \/ B <-> A \/ C).
-Proof.
-  intros; tauto.
-Qed.
-
-Theorem or_iff_compat_r : forall A B C : Prop,
-  (B <-> C) -> (B \/ A <-> C \/ A).
-Proof.
-  intros; tauto.
+  intros; split; [ intros [[?|?]|?]| intros [?|[?|?]]].
+  + left; assumption.
+  + right; left; assumption.
+  + right; right; assumption.
+  + left; left; assumption.
+  + left; right; assumption.
+  + right; assumption.
 Qed.
-
 Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
 Proof.
   intros A B []; split; trivial.
@@ -178,7 +203,7 @@ Qed.
 
 Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
 Proof.
-  intros; tauto.
+  intros; split; intros [Hl Hr]; (split; intros; [ apply Hl | apply Hr]); assumption.
 Qed.
 
 (** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
@@ -204,11 +229,6 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
     is provided too.
 *)
 
-(** Remark: [exists x, Q] denotes [ex (fun x => Q)] so that [exists x,
-   P x] is in fact equivalent to [ex (fun x => P x)] which may be not
-   convertible to [ex P] if [P] is not itself an abstraction *)
-
-
 Inductive ex (A:Type) (P:A -> Prop) : Prop :=
   ex_intro : forall x:A, P x -> ex (A:=A) P.
 
@@ -277,7 +297,8 @@ Arguments eq_ind [A] x P _ y _.
 Arguments eq_rec [A] x P _ y _.
 Arguments eq_rect [A] x P _ y _.
 
-Hint Resolve I conj or_introl or_intror eq_refl: core.
+Hint Resolve I conj or_introl or_intror : core. 
+Hint Resolve eq_refl: core. 
 Hint Resolve ex_intro ex_intro2: core.
 
 Section Logic_lemmas.
@@ -297,19 +318,16 @@ Section Logic_lemmas.
     Proof.
       destruct 1; trivial.
     Defined.
-    Opaque eq_sym.
 
     Theorem eq_trans : x = y -> y = z -> x = z.
     Proof.
       destruct 2; trivial.
     Defined.
-    Opaque eq_trans.
 
     Theorem f_equal : x = y -> f x = f y.
     Proof.
       destruct 1; trivial.
     Defined.
-    Opaque f_equal.
 
     Theorem not_eq_sym : x <> y -> y <> x.
     Proof.
@@ -320,7 +338,7 @@ Section Logic_lemmas.
 
   Definition eq_ind_r :
     forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
-    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
+    intros A x P H y H0. elim eq_sym with (1 := H0); assumption.
   Defined.
 
   Definition eq_rec_r :
@@ -336,13 +354,40 @@ End Logic_lemmas.
 
 Module EqNotations.
   Notation "'rew' H 'in' H'" := (eq_rect _ _ H' _ H)
-    (at level 10, H' at level 10).
+    (at level 10, H' at level 10,
+     format "'[' 'rew'  H  in  '/' H' ']'").
+  Notation "'rew' [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
+    (at level 10, H' at level 10,
+     format "'[' 'rew'  [ P ]  '/    ' H  in  '/' H' ']'").
   Notation "'rew' <- H 'in' H'" := (eq_rect_r _ H' H)
-    (at level 10, H' at level 10).
+    (at level 10, H' at level 10,
+     format "'[' 'rew'  <-  H  in  '/' H' ']'").
+  Notation "'rew' <- [ P ] H 'in' H'" := (eq_rect_r P H' H)
+    (at level 10, H' at level 10,
+     format "'[' 'rew'  <-  [ P ]  '/    ' H  in  '/' H' ']'").
   Notation "'rew' -> H 'in' H'" := (eq_rect _ _ H' _ H)
     (at level 10, H' at level 10, only parsing).
+  Notation "'rew' -> [ P ] H 'in' H'" := (eq_rect _ P H' _ H)
+    (at level 10, H' at level 10, only parsing).
+
 End EqNotations.
 
+Import EqNotations.
+
+Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a.
+Proof.
+intros.
+destruct H.
+reflexivity.
+Defined.
+
+Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a.
+Proof.
+intros.
+destruct H.
+reflexivity.
+Defined.
+
 Theorem f_equal2 :
   forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
     (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
@@ -376,6 +421,91 @@ Proof.
   destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
 Qed.
 
+Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b),
+  f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e.
+Proof.
+  destruct e. reflexivity.
+Defined.
+
+(** The goupoid structure of equality *)
+
+Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e.
+Proof.
+  destruct e. reflexivity.
+Defined.
+
+Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e.
+Proof.
+  destruct e. reflexivity.
+Defined.
+
+Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e.
+Proof.
+  destruct e; reflexivity.
+Defined.
+
+Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl.
+Proof.
+  destruct e; reflexivity.
+Defined.
+
+Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl.
+Proof.
+  destruct e; reflexivity.
+Defined.
+
+Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t),
+  eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''.
+Proof.
+  destruct e''; reflexivity.
+Defined.
+
+(** Extra properties of equality *)
+
+Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a).
+Proof.
+  intros.
+  unfold f_equal.
+  rewrite <- (eq_trans_sym_inv_l (Hf a)).
+  destruct (Hf a) at 1 2.
+  destruct (Hf a).
+  reflexivity.
+Defined.
+
+Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a).
+Proof.
+  intros.
+  unfold f_equal.
+  rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))).
+  set (Hfsymf := fun a => eq_sym (Hf a)).
+  change (eq_sym (Hf (f (f a)))) with (Hfsymf (f (f a))).
+  pattern (Hfsymf (f (f a))).
+  destruct (eq_id_comm_l f Hfsymf (f a)).
+  destruct (eq_id_comm_l f Hfsymf a).
+  unfold Hfsymf.
+  destruct (Hf a). simpl.
+  rewrite eq_trans_refl_l.
+  reflexivity.
+Defined.
+
+Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e').
+Proof.
+destruct e'.
+reflexivity.
+Defined.
+
+Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e).
+Proof.
+destruct e.
+reflexivity.
+Defined.
+
+Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e).
+Proof.
+destruct e, e'.
+reflexivity.
+Defined.
+
 (* Aliases *)
 
 Notation sym_eq := eq_sym (compat "8.3").
@@ -474,7 +604,7 @@ Declare Right Step eq_trans.
 
 Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
 Proof.
-  intros; tauto.
+  intros ? ? ? [? ?] [? ?]; split; intros; auto.
 Qed.
 
 Declare Left Step iff_stepl.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index b2f83e03..1e126463 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -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/theories/Init/Nat.v b/theories/Init/Nat.v
new file mode 100644
index 00000000..afb46436
--- /dev/null
+++ b/theories/Init/Nat.v
@@ -0,0 +1,297 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+Require Import Notations Logic Datatypes.
+
+Local Open Scope nat_scope.
+
+(**********************************************************************)
+(** * Peano natural numbers, definitions of operations *)
+(**********************************************************************)
+
+(** This file is meant to be used as a whole module,
+    without importing it, leading to qualified definitions
+    (e.g. Nat.pred) *)
+
+Definition t := nat.
+
+(** ** Constants *)
+
+Definition zero := 0.
+Definition one := 1.
+Definition two := 2.
+
+(** ** Basic operations *)
+
+Definition succ := S.
+
+Definition pred n :=
+  match n with
+    | 0 => n
+    | S u => u
+  end.
+
+Fixpoint add n m :=
+  match n with
+  | 0 => m
+  | S p => S (p + m)
+  end
+
+where "n + m" := (add n m) : nat_scope.
+
+Definition double n := n + n.
+
+Fixpoint mul n m :=
+  match n with
+  | 0 => 0
+  | S p => m + p * m
+  end
+
+where "n * m" := (mul n m) : nat_scope.
+
+(** Truncated subtraction: [n-m] is [0] if [n<=m] *)
+
+Fixpoint sub n m :=
+  match n, m with
+  | S k, S l => k - l
+  | _, _ => n
+  end
+
+where "n - m" := (sub n m) : nat_scope.
+
+(** ** Comparisons *)
+
+Fixpoint eqb n m : bool :=
+  match n, m with
+    | 0, 0 => true
+    | 0, S _ => false
+    | S _, 0 => false
+    | S n', S m' => eqb n' m'
+  end.
+
+Fixpoint leb n m : bool :=
+  match n, m with
+    | 0, _ => true
+    | _, 0 => false
+    | S n', S m' => leb n' m'
+  end.
+
+Definition ltb n m := leb (S n) m.
+
+Infix "=?" := eqb (at level 70) : nat_scope.
+Infix "<=?" := leb (at level 70) : nat_scope.
+Infix "<?" := ltb (at level 70) : nat_scope.
+
+Fixpoint compare n m : comparison :=
+  match n, m with
+   | 0, 0 => Eq
+   | 0, S _ => Lt
+   | S _, 0 => Gt
+   | S n', S m' => compare n' m'
+  end.
+
+Infix "?=" := compare (at level 70) : nat_scope.
+
+(** ** Minimum, maximum *)
+
+Fixpoint max n m :=
+  match n, m with
+    | 0, _ => m
+    | S n', 0 => n
+    | S n', S m' => S (max n' m')
+  end.
+
+Fixpoint min n m :=
+  match n, m with
+    | 0, _ => 0
+    | S n', 0 => 0
+    | S n', S m' => S (min n' m')
+  end.
+
+(** ** Parity tests *)
+
+Fixpoint even n : bool :=
+  match n with
+    | 0 => true
+    | 1 => false
+    | S (S n') => even n'
+  end.
+
+Definition odd n := negb (even n).
+
+(** ** Power *)
+
+Fixpoint pow n m :=
+  match m with
+    | 0 => 1
+    | S m => n * (n^m)
+  end
+
+where "n ^ m" := (pow n m) : nat_scope.
+
+(** ** Euclidean division *)
+
+(** This division is linear and tail-recursive.
+    In [divmod], [y] is the predecessor of the actual divisor,
+    and [u] is [y] minus the real remainder
+*)
+
+Fixpoint divmod x y q u :=
+  match x with
+    | 0 => (q,u)
+    | S x' => match u with
+                | 0 => divmod x' y (S q) y
+                | S u' => divmod x' y q u'
+              end
+  end.
+
+Definition div x y :=
+  match y with
+    | 0 => y
+    | S y' => fst (divmod x y' 0 y')
+  end.
+
+Definition modulo x y :=
+  match y with
+    | 0 => y
+    | S y' => y' - snd (divmod x y' 0 y')
+  end.
+
+Infix "/" := div : nat_scope.
+Infix "mod" := modulo (at level 40, no associativity) : nat_scope.
+
+
+(** ** Greatest common divisor *)
+
+(** We use Euclid algorithm, which is normally not structural,
+    but Coq is now clever enough to accept this (behind modulo
+    there is a subtraction, which now preserves being a subterm)
+*)
+
+Fixpoint gcd a b :=
+  match a with
+   | O => b
+   | S a' => gcd (b mod (S a')) (S a')
+  end.
+
+(** ** Square *)
+
+Definition square n := n * n.
+
+(** ** Square root *)
+
+(** The following square root function is linear (and tail-recursive).
+  With Peano representation, we can't do better. For faster algorithm,
+  see Psqrt/Zsqrt/Nsqrt...
+
+  We search the square root of n = k + p^2 + (q - r)
+  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
+  looking for the square root of n = k. Then we progressively
+  decrease k and r. When k = S k' and r=0, it means we can use (S p)
+  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
+  When k reaches 0, we have found the biggest p^2 square contained
+  in n, hence the square root of n is p.
+*)
+
+Fixpoint sqrt_iter k p q r :=
+  match k with
+    | O => p
+    | S k' => match r with
+                | O => sqrt_iter k' (S p) (S (S q)) (S (S q))
+                | S r' => sqrt_iter k' p q r'
+              end
+  end.
+
+Definition sqrt n := sqrt_iter n 0 0 0.
+
+(** ** Log2 *)
+
+(** This base-2 logarithm is linear and tail-recursive.
+
+  In [log2_iter], we maintain the logarithm [p] of the counter [q],
+  while [r] is the distance between [q] and the next power of 2,
+  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
+  recursive call, [q] goes up while [r] goes down. When [r]
+  is 0, we know that [q] has almost reached a power of 2,
+  and we increase [p] at the next call, while resetting [r]
+  to [q].
+
+  Graphically (numbers are [q], stars are [r]) :
+
+<<
+                    10
+                  9
+                8
+              7   *
+            6       *
+          5           ...
+        4
+      3   *
+    2       *
+  1   *       *
+0   *   *       *
+>>
+
+  We stop when [k], the global downward counter reaches 0.
+  At that moment, [q] is the number we're considering (since
+  [k+q] is invariant), and [p] its logarithm.
+*)
+
+Fixpoint log2_iter k p q r :=
+  match k with
+    | O => p
+    | S k' => match r with
+                | O => log2_iter k' (S p) (S q) q
+                | S r' => log2_iter k' p (S q) r'
+              end
+  end.
+
+Definition log2 n := log2_iter (pred n) 0 1 0.
+
+(** Iterator on natural numbers *)
+
+Definition iter (n:nat) {A} (f:A->A) (x:A) : A :=
+ nat_rect (fun _ => A) x (fun _ => f) n.
+
+(** Bitwise operations *)
+
+(** We provide here some bitwise operations for unary numbers.
+  Some might be really naive, they are just there for fullfiling
+  the same interface as other for natural representations. As
+  soon as binary representations such as NArith are available,
+  it is clearly better to convert to/from them and use their ops.
+*)
+
+Fixpoint div2 n :=
+  match n with
+  | 0 => 0
+  | S 0 => 0
+  | S (S n') => S (div2 n')
+  end.
+
+Fixpoint testbit a n : bool :=
+ match n with
+   | 0 => odd a
+   | S n => testbit (div2 a) n
+ end.
+
+Definition shiftl a := nat_rect _ a (fun _ => double).
+Definition shiftr a := nat_rect _ a (fun _ => div2).
+
+Fixpoint bitwise (op:bool->bool->bool) n a b :=
+ match n with
+  | 0 => 0
+  | S n' =>
+    (if op (odd a) (odd b) then 1 else 0) +
+    2*(bitwise op n' (div2 a) (div2 b))
+ end.
+
+Definition land a b := bitwise andb a a b.
+Definition lor a b := bitwise orb (max a b) a b.
+Definition ldiff a b := bitwise (fun b b' => andb b (negb b')) a a b.
+Definition lxor a b := bitwise xorb (max a b) a b.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index c745f9c9..424ca0c8 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -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        *)
@@ -10,6 +10,7 @@
 
 (** Notations for propositional connectives *)
 
+Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x <-> y" (at level 95, no associativity).
 Reserved Notation "x /\ y" (at level 80, right associativity).
 Reserved Notation "x \/ y" (at level 85, right associativity).
@@ -79,3 +80,13 @@ Delimit Scope core_scope with core.
 
 Open Scope core_scope.
 Open Scope type_scope.
+
+(** ML Tactic Notations *)
+
+Declare ML Module "coretactics".
+Declare ML Module "extratactics".
+Declare ML Module "eauto".
+Declare ML Module "g_class".
+Declare ML Module "g_eqdecide".
+Declare ML Module "g_rewrite".
+Declare ML Module "tauto".
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index ef2d9584..7a14ab39 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -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        *)
@@ -26,21 +26,22 @@
 Require Import Notations.
 Require Import Datatypes.
 Require Import Logic.
+Require Coq.Init.Nat.
 
 Open Scope nat_scope.
 
 Definition eq_S := f_equal S.
+Definition f_equal_nat := f_equal (A:=nat).
 
-Hint Resolve (f_equal S): v62.
-Hint Resolve (f_equal (A:=nat)): core.
+Hint Resolve eq_S: v62.
+Hint Resolve f_equal_nat: core.
 
 (** The predecessor function *)
 
-Definition pred (n:nat) : nat := match n with
-                                 | O => n
-                                 | S u => u
-                                 end.
-Hint Resolve (f_equal pred): v62.
+Notation pred := Nat.pred (compat "8.4").
+
+Definition f_equal_pred := f_equal pred.
+Hint Resolve f_equal_pred: v62.
 
 Theorem pred_Sn : forall n:nat, n = pred (S n).
 Proof.
@@ -80,16 +81,13 @@ Hint Resolve n_Sn: core.
 
 (** Addition *)
 
-Fixpoint plus (n m:nat) : nat :=
-  match n with
-  | O => m
-  | S p => S (p + m)
-  end
-
-where "n + m" := (plus n m) : nat_scope.
+Notation plus := Nat.add (compat "8.4").
+Infix "+" := Nat.add : nat_scope.
 
-Hint Resolve (f_equal2 plus): v62.
-Hint Resolve (f_equal2 (A1:=nat) (A2:=nat)): core.
+Definition f_equal2_plus := f_equal2 plus.
+Hint Resolve f_equal2_plus: v62.
+Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat). 
+Hint Resolve f_equal2_nat: core.
 
 Lemma plus_n_O : forall n:nat, n = n + 0.
 Proof.
@@ -99,7 +97,7 @@ Hint Resolve plus_n_O: core.
 
 Lemma plus_O_n : forall n:nat, 0 + n = n.
 Proof.
-  auto.
+  reflexivity.
 Qed.
 
 Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m.
@@ -110,7 +108,7 @@ Hint Resolve plus_n_Sm: core.
 
 Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m).
 Proof.
-  auto.
+  reflexivity.
 Qed.
 
 (** Standard associated names *)
@@ -120,15 +118,11 @@ Notation plus_succ_r_reverse := plus_n_Sm (compat "8.2").
 
 (** Multiplication *)
 
-Fixpoint mult (n m:nat) : nat :=
-  match n with
-  | O => 0
-  | S p => m + p * m
-  end
-
-where "n * m" := (mult n m) : nat_scope.
+Notation mult := Nat.mul (compat "8.4").
+Infix "*" := Nat.mul : nat_scope.
 
-Hint Resolve (f_equal2 mult): core.
+Definition f_equal2_mult := f_equal2 mult.
+Hint Resolve f_equal2_mult: core.
 
 Lemma mult_n_O : forall n:nat, 0 = n * 0.
 Proof.
@@ -151,14 +145,8 @@ Notation mult_succ_r_reverse := mult_n_Sm (compat "8.2").
 
 (** Truncated subtraction: [m-n] is [0] if [n>=m] *)
 
-Fixpoint minus (n m:nat) : nat :=
-  match n, m with
-  | O, _ => n
-  | S k, O => n
-  | S k, S l => k - l
-  end
-
-where "n - m" := (minus n m) : nat_scope.
+Notation minus := Nat.sub (compat "8.4").
+Infix "-" := Nat.sub : nat_scope.
 
 (** Definition of the usual orders, the basic properties of [le] and [lt]
     can be found in files Le and Lt *)
@@ -202,6 +190,16 @@ Proof.
 intros n m. exact (le_pred (S n) (S m)).
 Qed.
 
+Theorem le_0_n : forall n, 0 <= n.
+Proof.
+ induction n; constructor; trivial.
+Qed.
+
+Theorem le_n_S : forall n m, n <= m -> S n <= S m.
+Proof.
+ induction 1; constructor; trivial.
+Qed.
+
 (** Case analysis *)
 
 Theorem nat_case :
@@ -224,73 +222,48 @@ Qed.
 
 (** Maximum and minimum : definitions and specifications *)
 
-Fixpoint max n m : nat :=
-  match n, m with
-    | O, _ => m
-    | S n', O => n
-    | S n', S m' => S (max n' m')
-  end.
-
-Fixpoint min n m : nat :=
-  match n, m with
-    | O, _ => 0
-    | S n', O => 0
-    | S n', S m' => S (min n' m')
-  end.
+Notation max := Nat.max (compat "8.4").
+Notation min := Nat.min (compat "8.4").
 
-Theorem max_l : forall n m : nat, m <= n -> max n m = n.
+Lemma max_l n m : m <= n -> Nat.max n m = n.
 Proof.
-induction n; destruct m; simpl; auto. inversion 1.
-intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+ revert m; induction n; destruct m; simpl; trivial.
+ - inversion 1.
+ - intros. apply f_equal, IHn, le_S_n; trivial.
 Qed.
 
-Theorem max_r : forall n m : nat, n <= m -> max n m = m.
+Lemma max_r n m : n <= m -> Nat.max n m = m.
 Proof.
-induction n; destruct m; simpl; auto. inversion 1.
-intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+ revert m; induction n; destruct m; simpl; trivial.
+ - inversion 1.
+ - intros. apply f_equal, IHn, le_S_n; trivial.
 Qed.
 
-Theorem min_l : forall n m : nat, n <= m -> min n m = n.
+Lemma min_l n m : n <= m -> Nat.min n m = n.
 Proof.
-induction n; destruct m; simpl; auto. inversion 1.
-intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+ revert m; induction n; destruct m; simpl; trivial.
+ - inversion 1.
+ - intros. apply f_equal, IHn, le_S_n; trivial.
 Qed.
 
-Theorem min_r : forall n m : nat, m <= n -> min n m = m.
+Lemma min_r n m : m <= n -> Nat.min n m = m.
 Proof.
-induction n; destruct m; simpl; auto. inversion 1.
-intros. apply f_equal. apply IHn. apply le_S_n. trivial.
+ revert m; induction n; destruct m; simpl; trivial.
+ - inversion 1.
+ - intros. apply f_equal, IHn, le_S_n; trivial.
 Qed.
 
-(** [n]th iteration of the function [f] *)
 
-Fixpoint nat_iter (n:nat) {A} (f:A->A) (x:A) : A :=
-  match n with
-    | O => x
-    | S n' => f (nat_iter n' f x)
-  end.
-
-Lemma nat_iter_succ_r n {A} (f:A->A) (x:A) :
-  nat_iter (S n) f x = nat_iter n f (f x).
+Lemma nat_rect_succ_r {A} (f: A -> A) (x:A) n :
+  nat_rect (fun _ => A) x (fun _ => f) (S n) = nat_rect (fun _ => A) (f x) (fun _ => f) n.
 Proof.
   induction n; intros; simpl; rewrite <- ?IHn; trivial.
 Qed.
 
-Theorem nat_iter_plus :
+Theorem nat_rect_plus :
   forall (n m:nat) {A} (f:A -> A) (x:A),
-    nat_iter (n + m) f x = nat_iter n f (nat_iter m f x).
+    nat_rect (fun _ => A) x (fun _ => f) (n + m) =
+      nat_rect (fun _ => A) (nat_rect (fun _ => A) x (fun _ => f) m) (fun _ => f) n.
 Proof.
   induction n; intros; simpl; rewrite ?IHn; trivial.
 Qed.
-
-(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv],
-    then the iterates of [f] also preserve it. *)
-
-Theorem nat_iter_invariant :
-  forall (n:nat) {A} (f:A -> A) (P : A -> Prop),
-    (forall x, P x -> P (f x)) ->
-    forall x, P x -> P (nat_iter n f x).
-Proof.
-  induction n; simpl; trivial.
-  intros A f P Hf x Hx. apply Hf, IHn; trivial.
-Qed.
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 2614ce40..4894eba4 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -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,10 @@
 
 Require Export Notations.
 Require Export Logic.
+Require Export Logic_Type.
 Require Export Datatypes.
 Require Export Specif.
+Require Coq.Init.Nat.
 Require Export Peano.
 Require Export Coq.Init.Wf.
 Require Export Coq.Init.Tactics.
@@ -20,7 +22,5 @@ Declare ML Module "decl_mode_plugin".
 Declare ML Module "cc_plugin".
 Declare ML Module "ground_plugin".
 Declare ML Module "recdef_plugin".
-Declare ML Module "subtac_plugin".
-Declare ML Module "xml_plugin".
 (* Default substrings not considered by queries like SearchAbout *)
 Add Search Blacklist "_admitted" "_subproof" "Private_".
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index cc5a1932..1384901b 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -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        *)
@@ -45,11 +45,11 @@ Arguments sigT2 (A P Q)%type.
 
 Notation "{ x  |  P }" := (sig (fun x => P)) : type_scope.
 Notation "{ x  |  P  & Q }" := (sig2 (fun x => P) (fun x => Q)) : type_scope.
-Notation "{ x : A  |  P }" := (sig (fun x:A => P)) : type_scope.
-Notation "{ x : A  |  P  & Q }" := (sig2 (fun x:A => P) (fun x:A => Q)) :
+Notation "{ x : A  |  P }" := (sig (A:=A) (fun x => P)) : type_scope.
+Notation "{ x : A  |  P  & Q }" := (sig2 (A:=A) (fun x => P) (fun x => Q)) :
   type_scope.
-Notation "{ x : A  & P }" := (sigT (fun x:A => P)) : type_scope.
-Notation "{ x : A  & P  & Q }" := (sigT2 (fun x:A => P) (fun x:A => Q)) :
+Notation "{ x : A  & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
+Notation "{ x : A  & P  & Q }" := (sigT2 (A:=A) (fun x => P) (fun x => Q)) :
   type_scope.
 
 Add Printing Let sig.
@@ -65,24 +65,57 @@ Add Printing Let sigT2.
     [(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the
     proof of [(P a)] *)
 
-
+(* Set Universe Polymorphism. *)
 Section Subset_projections.
 
   Variable A : Type.
   Variable P : A -> Prop.
 
   Definition proj1_sig (e:sig P) := match e with
-                                    | exist a b => a
+                                    | exist _ a b => a
                                     end.
 
   Definition proj2_sig (e:sig P) :=
     match e return P (proj1_sig e) with
-    | exist a b => b
+    | exist _ a b => b
     end.
 
 End Subset_projections.
 
 
+(** [sig2] of a predicate can be projected to a [sig].
+
+    This allows [proj1_sig] and [proj2_sig] to be usable with [sig2].
+
+    The [let] statements occur in the body of the [exist] so that
+    [proj1_sig] of a coerced [X : sig2 P Q] will unify with [let (a,
+    _, _) := X in a] *)
+
+Definition sig_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sig P
+  := exist P
+           (let (a, _, _) := X in a)
+           (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p).
+
+(** Projections of [sig2]
+
+    An element [y] of a subset [{x:A | (P x) & (Q x)}] is the triple
+    of an [a] of type [A], a of a proof [h] that [a] satisfies [P],
+    and a proof [h'] that [a] satisfies [Q].  Then
+    [(proj1_sig (sig_of_sig2 y))] is the witness [a],
+    [(proj2_sig (sig_of_sig2 y))] is the proof of [(P a)], and 
+    [(proj3_sig y)] is the proof of [(Q a)]. *)
+
+Section Subset_projections2.
+
+  Variable A : Type.
+  Variables P Q : A -> Prop.
+
+  Definition proj3_sig (e : sig2 P Q) :=
+    let (a, b, c) return Q (proj1_sig (sig_of_sig2 e)) := e in c.
+
+End Subset_projections2.
+
+
 (** Projections of [sigT]
 
     An element [x] of a sigma-type [{y:A & P y}] is a dependent pair
@@ -90,31 +123,71 @@ End Subset_projections.
     [(projT1 x)] is the first projection and [(projT2 x)] is the
     second projection, the type of which depends on the [projT1]. *)
 
+
+
 Section Projections.
 
   Variable A : Type.
   Variable P : A -> Type.
 
   Definition projT1 (x:sigT P) : A := match x with
-                                      | existT a _ => a
+                                      | existT _ a _ => a
                                       end.
+
   Definition projT2 (x:sigT P) : P (projT1 x) :=
     match x return P (projT1 x) with
-    | existT _ h => h
+    | existT _ _ h => h
     end.
 
 End Projections.
 
+(** [sigT2] of a predicate can be projected to a [sigT].
+
+    This allows [projT1] and [projT2] to be usable with [sigT2].
+
+    The [let] statements occur in the body of the [existT] so that
+    [projT1] of a coerced [X : sigT2 P Q] will unify with [let (a,
+    _, _) := X in a] *)
+
+Definition sigT_of_sigT2 (A : Type) (P Q : A -> Type) (X : sigT2 P Q) : sigT P
+  := existT P
+            (let (a, _, _) := X in a)
+            (let (x, p, _) as s return (P (let (a, _, _) := s in a)) := X in p).
+
+(** Projections of [sigT2]
+
+    An element [x] of a sigma-type [{y:A & P y & Q y}] is a dependent
+    pair made of an [a] of type [A], an [h] of type [P a], and an [h']
+    of type [Q a].  Then, [(projT1 (sigT_of_sigT2 x))] is the first
+    projection, [(projT2 (sigT_of_sigT2 x))] is the second projection,
+    and [(projT3 x)] is the third projection, the types of which
+    depends on the [projT1]. *)
+
+Section Projections2.
+
+  Variable A : Type.
+  Variables P Q : A -> Type.
+
+  Definition projT3 (e : sigT2 P Q) :=
+    let (a, b, c) return Q (projT1 (sigT_of_sigT2 e)) := e in c.
+
+End Projections2.
+
 (** [sigT] of a predicate is equivalent to [sig] *)
 
-Lemma sig_of_sigT : forall (A:Type) (P:A->Prop), sigT P -> sig P.
-Proof. destruct 1 as (x,H); exists x; trivial. Defined.
+Definition sig_of_sigT (A : Type) (P : A -> Prop) (X : sigT P) : sig P
+  := exist P (projT1 X) (projT2 X).
+
+Definition sigT_of_sig (A : Type) (P : A -> Prop) (X : sig P) : sigT P
+  := existT P (proj1_sig X) (proj2_sig X).
 
-Lemma sigT_of_sig : forall (A:Type) (P:A->Prop), sig P -> sigT P.
-Proof. destruct 1 as (x,H); exists x; trivial. Defined.
+(** [sigT2] of a predicate is equivalent to [sig2] *)
 
-Coercion sigT_of_sig : sig >-> sigT.
-Coercion sig_of_sigT : sigT >-> sig.
+Definition sig2_of_sigT2 (A : Type) (P Q : A -> Prop) (X : sigT2 P Q) : sig2 P Q
+  := exist2 P Q (projT1 (sigT_of_sigT2 X)) (projT2 (sigT_of_sigT2 X)) (projT3 X).
+
+Definition sigT2_of_sig2 (A : Type) (P Q : A -> Prop) (X : sig2 P Q) : sigT2 P Q
+  := existT2 P Q (proj1_sig (sig_of_sig2 X)) (proj2_sig (sig_of_sig2 X)) (proj3_sig X).
 
 (** [sumbool] is a boolean type equipped with the justification of
     their value *)
@@ -142,6 +215,8 @@ Add Printing If sumor.
 Arguments inleft {A B} _ , [A] B _.
 Arguments inright {A B} _ , A [B] _.
 
+(* Unset Universe Polymorphism. *)
+
 (** Various forms of the axiom of choice for specifications *)
 
 Section Choice_lemmas.
@@ -187,10 +262,10 @@ Section Dependent_choice_lemmas.
     (forall x:X, {y | R x y}) ->
     forall x0, {f : nat -> X | f O = x0 /\ forall n, R (f n) (f (S n))}.
   Proof.
-    intros H x0.
+    intros H x0. 
     set (f:=fix f n := match n with O => x0 | S n' => proj1_sig (H (f n')) end).
     exists f.
-    split. reflexivity.
+    split. reflexivity. 
     induction n; simpl; apply proj2_sig.
   Defined.
 
@@ -203,12 +278,14 @@ End Dependent_choice_lemmas.
      [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)].
 
      It is implemented using the option type. *)
+Section Exc.
+  Variable A : Type.
 
-Definition Exc := option.
-Definition value := Some.
-Definition error := @None.
-
-Arguments error [A].
+  Definition Exc := option A.
+  Definition value := @Some A.
+  Definition error := @None A.
+End Exc.
+Arguments error {A}.
 
 Definition except := False_rec. (* for compatibility with previous versions *)
 
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 4a7b9283..9e828e6e 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -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        *)
@@ -68,7 +68,7 @@ Ltac absurd_hyp H :=
   let T := type of H in
   absurd T.
 
-(* A useful complement to contradict. Here H:A while G allows to conclude ~A *)
+(* A useful complement to contradict. Here H:A while G allows concluding ~A *)
 
 Ltac false_hyp H G :=
   let T := type of H in absurd T; [ apply G | assumption ].
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index 9db64787..6501b1e1 100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -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        *)
@@ -150,3 +150,23 @@ End Well_founded_2.
 
 Notation Acc_iter   := Fix_F   (only parsing). (* compatibility *)
 Notation Acc_iter_2 := Fix_F_2 (only parsing). (* compatibility *)
+
+
+
+(* Added by Julien Forest on 13/11/20 *)
+Section Acc_generator.
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
+
+  (* *Lazily* add 2^n - 1 Acc_intro on top of wf. 
+     Needed for fast reductions using Function and Program Fixpoint 
+     and probably using Fix and Fix_F_2 
+   *)    
+  Fixpoint Acc_intro_generator n (wf : well_founded R)  := 
+    match n with 
+        | O => wf
+        | S n => fun x => Acc_intro x (fun y _ => Acc_intro_generator n (Acc_intro_generator n wf) y)
+    end.
+
+
+End Acc_generator.
diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget
index f53d55e7..cc62e66c 100644
--- a/theories/Init/vo.itarget
+++ b/theories/Init/vo.itarget
@@ -7,3 +7,4 @@ Prelude.vo
 Specif.vo
 Tactics.vo
 Wf.vo
+Nat.vo
\ No newline at end of file
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index f5a12b09..3cba090f 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -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        *)
 (************************************************************************)
 
-Require Import Le Gt Minus Bool Setoid.
+Require Setoid.
+Require Import PeanoNat Le Gt Minus Bool.
 
 Set Implicit Arguments.
-
+(* Set Universe Polymorphism. *)
 
 (******************************************************************)
 (** * Basics: definition of polymorphic lists and some operations *)
@@ -20,6 +21,16 @@ Set Implicit Arguments.
 
 Open Scope list_scope.
 
+(** Standard notations for lists. 
+In a special module to avoid conflicts. *)
+Module ListNotations.
+Notation " [ ] " := nil (format "[ ]") : list_scope.
+Notation " [ x ] " := (cons x nil) : list_scope.
+Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
+End ListNotations.
+
+Import ListNotations.
+
 Section Lists.
 
   Variable A : Type.
@@ -28,44 +39,31 @@ Section Lists.
 
   Definition hd (default:A) (l:list A) :=
     match l with
-      | nil => default
+      | [] => default
       | x :: _ => x
     end.
 
   Definition hd_error (l:list A) :=
     match l with
-      | nil => error
+      | [] => error
       | x :: _ => value x
     end.
 
   Definition tl (l:list A) :=
     match l with
-      | nil => nil
+      | [] => nil
       | a :: m => m
     end.
 
   (** The [In] predicate *)
   Fixpoint In (a:A) (l:list A) : Prop :=
     match l with
-      | nil => False
+      | [] => False
       | b :: m => b = a \/ In a m
     end.
 
 End Lists.
 
-
-(** Standard notations for lists. 
-In a special module to avoid conflict. *)
-Module ListNotations.
-Notation " [ ] " := nil : list_scope.
-Notation " [ x ] " := (cons x nil) : list_scope.
-Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
-End ListNotations.
-
-Import ListNotations.
-
-(** ** Facts about lists *)
-
 Section Facts.
 
   Variable A : Type.
@@ -89,6 +87,24 @@ Section Facts.
     left; exists a, tail; reflexivity.
   Qed.
 
+  Lemma hd_error_tl_repr : forall l (a:A) r,
+    hd_error l = Some a /\ tl l = r <-> l = a :: r.
+  Proof. destruct l as [|x xs].
+    - unfold hd_error, tl; intros a r. split; firstorder discriminate.
+    - intros. simpl. split.
+      * intros (H1, H2). inversion H1. rewrite H2. reflexivity.
+      * inversion 1. subst. auto.
+  Qed.
+
+  Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil.
+  Proof. unfold hd_error. destruct l; now discriminate. Qed.
+
+  Theorem length_zero_iff_nil (l : list A):
+    length l = 0 <-> l=[].
+  Proof.
+    split; [now destruct l | now intros ->].
+  Qed.
+
   (** *** Head and tail *)
 
   Theorem hd_error_nil : hd_error (@nil A) = None.
@@ -119,6 +135,12 @@ Section Facts.
     simpl; auto.
   Qed.
 
+  Theorem not_in_cons (x a : A) (l : list A):
+    ~ In x (a::l) <-> x<>a /\ ~ In x l.
+  Proof.
+    simpl. intuition.
+  Qed.
+
   Theorem in_nil : forall a:A, ~ In a [].
   Proof.
     unfold not; intros a H; inversion_clear H.
@@ -130,7 +152,7 @@ Section Facts.
   subst a; auto.
   exists [], l; auto.
   destruct (IHl H) as (l1,(l2,H0)).
-  exists (a::l1), l2; simpl; f_equal; auto.
+  exists (a::l1), l2; simpl. apply f_equal. auto.
   Qed.
 
   (** Inversion *)
@@ -173,7 +195,7 @@ Section Facts.
   Qed.
 
   Theorem app_nil_r : forall l:list A, l ++ [] = l.
-  Proof.
+  Proof. 
     induction l; simpl; f_equal; auto.
   Qed.
 
@@ -228,10 +250,8 @@ Section Facts.
     intros.
     injection H.
     intro.
-    cut ([] = l ++ a0 :: l0); auto.
-    intro.
-    generalize (app_cons_not_nil _ _ _ H1); intro.
-    elim H2.
+    assert ([] = l ++ a0 :: l0) by auto.
+    apply app_cons_not_nil in H1 as [].
   Qed.
 
   Lemma app_inj_tail :
@@ -240,22 +260,20 @@ Section Facts.
     induction x as [| x l IHl];
       [ destruct y as [| a l] | destruct y as [| a l0] ];
       simpl; auto.
-    intros a b H.
-    injection H.
-    auto.
-    intros a0 b H.
-    injection H; intros.
-    generalize (app_cons_not_nil _ _ _ H0); destruct 1.
-    intros a b H.
-    injection H; intros.
-    cut ([] = l ++ [a]); auto.
-    intro.
-    generalize (app_cons_not_nil _ _ _ H2); destruct 1.
-    intros a0 b H.
-    injection H; intros.
-    destruct (IHl l0 a0 b H0).
-    split; auto.
-    rewrite <- H1; rewrite <- H2; reflexivity.
+    - intros a b H.
+      injection H.
+      auto.
+    - intros a0 b H.
+      injection H as H1 H0.
+      apply app_cons_not_nil in H0 as [].
+    - intros a b H.
+      injection H as H1 H0.
+      assert ([] = l ++ [a]) by auto.
+      apply app_cons_not_nil in H as [].
+    - intros a0 b H.
+      injection H as <- H0.
+      destruct (IHl l0 a0 b H0) as (<-,<-).
+      split; auto.
   Qed.
 
 
@@ -360,13 +378,12 @@ Section Elts.
 
   Lemma nth_in_or_default :
     forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
-  (* Realizer nth_ok. Program_all. *)
   Proof.
-    intros n l d; generalize n; induction l; intro n0.
-    right; case n0; trivial.
-    case n0; simpl.
-    auto.
-    intro n1; elim (IHl n1); auto.
+    intros n l d; revert n; induction l.
+    - right; destruct n; trivial.
+    - intros [|n]; simpl.
+      * left; auto.
+      * destruct (IHl n); auto.
   Qed.
 
   Lemma nth_S_cons :
@@ -395,60 +412,132 @@ Section Elts.
     unfold nth_default; induction n; intros [ | ] ?; simpl; auto.
   Qed.
 
+  (** Results about [nth] *)
+
   Lemma nth_In :
     forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.
-
   Proof.
     unfold lt; induction n as [| n hn]; simpl.
-    destruct l; simpl; [ inversion 2 | auto ].
-    destruct l as [| a l hl]; simpl.
-    inversion 2.
-    intros d ie; right; apply hn; auto with arith.
+    - destruct l; simpl; [ inversion 2 | auto ].
+    - destruct l as [| a l hl]; simpl.
+      * inversion 2.
+      * intros d ie; right; apply hn; auto with arith.
+  Qed.
+
+  Lemma In_nth l x d : In x l ->
+    exists n, n < length l /\ nth n l d = x.
+  Proof.
+    induction l as [|a l IH].
+    - easy.
+    - intros [H|H].
+      * subst; exists 0; simpl; auto with arith.
+      * destruct (IH H) as (n & Hn & Hn').
+        exists (S n); simpl; auto with arith.
   Qed.
 
   Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
   Proof.
     induction l; destruct n; simpl; intros; auto.
-    inversion H.
-    apply IHl; auto with arith.
+    - inversion H.
+    - apply IHl; auto with arith.
   Qed.
 
   Lemma nth_indep :
     forall l n d d', n < length l -> nth n l d = nth n l d'.
   Proof.
-    induction l; simpl; intros; auto.
-    inversion H.
-    destruct n; simpl; auto with arith.
+    induction l.
+    - inversion 1.
+    - intros [|n] d d'; simpl; auto with arith.
   Qed.
 
   Lemma app_nth1 :
     forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
   Proof.
     induction l.
-    intros.
-    inversion H.
-    intros l' d n.
-    case n; simpl; auto.
-    intros; rewrite IHl; auto with arith.
+    - inversion 1.
+    - intros l' d [|n]; simpl; auto with arith.
   Qed.
 
   Lemma app_nth2 :
     forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
   Proof.
-    induction l.
-    intros.
-    simpl.
-    destruct n; auto.
-    intros l' d n.
-    case n; simpl; auto.
-    intros.
-    inversion H.
-    intros.
-    rewrite IHl; auto with arith.
+    induction l; intros l' d [|n]; auto.
+    - inversion 1.
+    - intros; simpl; rewrite IHl; auto with arith.
+  Qed.
+
+  Lemma nth_split n l d : n < length l ->
+    exists l1, exists l2, l = l1 ++ nth n l d :: l2 /\ length l1 = n.
+  Proof.
+    revert l.
+    induction n as [|n IH]; intros [|a l] H; try easy.
+    - exists nil; exists l; now simpl.
+    - destruct (IH l) as (l1 & l2 & Hl & Hl1); auto with arith.
+      exists (a::l1); exists l2; simpl; split; now f_equal.
   Qed.
 
+  (** Results about [nth_error] *)
 
+  Lemma nth_error_In l n x : nth_error l n = Some x -> In x l.
+  Proof.
+    revert n. induction l as [|a l IH]; intros [|n]; simpl; try easy.
+    - injection 1; auto.
+    - eauto.
+  Qed.
 
+  Lemma In_nth_error l x : In x l -> exists n, nth_error l n = Some x.
+  Proof.
+    induction l as [|a l IH].
+    - easy.
+    - intros [H|H].
+      * subst; exists 0; simpl; auto with arith.
+      * destruct (IH H) as (n,Hn).
+        exists (S n); simpl; auto with arith.
+  Qed.
+
+  Lemma nth_error_None l n : nth_error l n = None <-> length l <= n.
+  Proof.
+    revert n. induction l; destruct n; simpl.
+    - split; auto.
+    - split; auto with arith.
+    - split; now auto with arith.
+    - rewrite IHl; split; auto with arith.
+  Qed.
+
+  Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l.
+  Proof.
+   revert n. induction l; destruct n; simpl.
+    - split; [now destruct 1 | inversion 1].
+    - split; [now destruct 1 | inversion 1].
+    - split; now auto with arith.
+    - rewrite IHl; split; auto with arith.
+  Qed.
+
+  Lemma nth_error_split l n a : nth_error l n = Some a ->
+    exists l1, exists l2, l = l1 ++ a :: l2 /\ length l1 = n.
+  Proof.
+    revert l.
+    induction n as [|n IH]; intros [|x l] H; simpl in *; try easy.
+    - exists nil; exists l. injection H; clear H; intros; now subst.
+    - destruct (IH _ H) as (l1 & l2 & H1 & H2).
+      exists (x::l1); exists l2; simpl; split; now f_equal.
+  Qed.
+
+  Lemma nth_error_app1 l l' n : n < length l ->
+    nth_error (l++l') n = nth_error l n.
+  Proof.
+    revert l.
+    induction n; intros [|a l] H; auto; try solve [inversion H].
+    simpl in *. apply IHn. auto with arith.
+  Qed.
+
+  Lemma nth_error_app2 l l' n : length l <= n ->
+    nth_error (l++l') n = nth_error l' (n-length l).
+  Proof.
+    revert l.
+    induction n; intros [|a l] H; auto; try solve [inversion H].
+    simpl in *. apply IHn. auto with arith.
+  Qed.
 
   (*****************)
   (** ** Remove    *)
@@ -541,19 +630,29 @@ Section Elts.
     match l with
       | [] => 0
       | y :: tl =>
-	let n := count_occ tl x in
-	  if eq_dec y x then S n else n
+        let n := count_occ tl x in
+        if eq_dec y x then S n else n
     end.
 
   (** Compatibility of count_occ with operations on list *)
-  Theorem count_occ_In (l : list A) (x : A) : In x l <-> count_occ l x > 0.
+  Theorem count_occ_In l x : In x l <-> count_occ l x > 0.
   Proof.
     induction l as [|y l]; simpl.
     - split; [destruct 1 | apply gt_irrefl].
     - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition.
   Qed.
 
-  Theorem count_occ_inv_nil (l : list A) :
+  Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0.
+  Proof.
+    rewrite count_occ_In. unfold gt. now rewrite Nat.nlt_ge, Nat.le_0_r.
+  Qed.
+
+  Lemma count_occ_nil x : count_occ [] x = 0.
+  Proof.
+    reflexivity.
+  Qed.
+
+  Theorem count_occ_inv_nil l :
     (forall x:A, count_occ l x = 0) <-> l = [].
   Proof.
     split.
@@ -563,27 +662,20 @@ Section Elts.
     - now intros ->.
   Qed.
 
-  Lemma count_occ_nil : forall (x : A), count_occ [] x = 0.
-  Proof.
-    intro x; simpl; reflexivity.
-  Qed.
-
-  Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
+  Lemma count_occ_cons_eq l x y :
+    x = y -> count_occ (x::l) y = S (count_occ l y).
   Proof.
-    intros l x y H; simpl.
-    destruct (eq_dec x y); [reflexivity | contradiction].
+    intros H. simpl. now destruct (eq_dec x y).
   Qed.
 
-  Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
+  Lemma count_occ_cons_neq l x y :
+    x <> y -> count_occ (x::l) y = count_occ l y.
   Proof.
-    intros l x y H; simpl.
-    destruct (eq_dec x y); [contradiction | reflexivity].
+    intros H. simpl. now destruct (eq_dec x y).
   Qed.
 
 End Elts.
 
-
-
 (*******************************)
 (** * Manipulating whole lists *)
 (*******************************)
@@ -739,6 +831,33 @@ Section ListOps.
 
   End Reverse_Induction.
 
+  (*************************)
+  (** ** Concatenation     *)
+  (*************************)
+
+  Fixpoint concat (l : list (list A)) : list A :=
+  match l with
+  | nil => nil
+  | cons x l => x ++ concat l
+  end.
+
+  Lemma concat_nil : concat nil = nil.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Lemma concat_cons : forall x l, concat (cons x l) = x ++ concat l.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
+  Proof.
+  intros l1; induction l1 as [|x l1 IH]; intros l2; simpl.
+  + reflexivity.
+  + rewrite IH; apply app_assoc.
+  Qed.
+
   (***********************************)
   (** ** Decidable equality on lists *)
   (***********************************)
@@ -759,15 +878,20 @@ End ListOps.
 (************)
 
 Section Map.
-  Variables A B : Type.
+  Variables (A : Type) (B : Type).
   Variable f : A -> B.
 
   Fixpoint map (l:list A) : list B :=
     match l with
-      | nil => nil
-      | cons a t => cons (f a) (map t)
+      | [] => []
+      | a :: t => (f a) :: (map t)
     end.
 
+  Lemma map_cons (x:A)(l:list A) : map (x::l) = (f x) :: (map l).
+  Proof.
+    reflexivity.
+  Qed.
+
   Lemma in_map :
     forall (l:list A) (x:A), In x l -> In (f x) (map l).
   Proof.
@@ -815,6 +939,25 @@ Section Map.
     destruct l; simpl; reflexivity || discriminate.
   Qed.
 
+  (** [map] and count of occurrences *)
+
+  Hypothesis decA: forall x1 x2 : A, {x1 = x2} + {x1 <> x2}.
+  Hypothesis decB: forall y1 y2 : B, {y1 = y2} + {y1 <> y2}.
+  Hypothesis Hfinjective: forall x1 x2: A, (f x1) = (f x2) -> x1 = x2.
+
+  Theorem count_occ_map x l:
+    count_occ decA l x = count_occ decB (map l) (f x).
+  Proof.
+    revert x. induction l as [| a l' Hrec]; intro x; simpl.
+    - reflexivity.
+    - specialize (Hrec x).
+      destruct (decA a x) as [H1|H1], (decB (f a) (f x)) as [H2|H2].
+      * rewrite Hrec. reflexivity.
+      * contradiction H2. rewrite H1. reflexivity.
+      * specialize (Hfinjective H2). contradiction H1.
+      * assumption.
+  Qed.
+
   (** [flat_map] *)
 
   Definition flat_map (f:A -> list B) :=
@@ -826,7 +969,7 @@ Section Map.
 
   Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
     In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
-  Proof.
+  Proof using A B.
     induction l; simpl; split; intros.
     contradiction.
     destruct H as (x,(H,_)); contradiction.
@@ -843,6 +986,21 @@ Section Map.
 
 End Map.
 
+Lemma flat_map_concat_map : forall A B (f : A -> list B) l,
+  flat_map f l = concat (map f l).
+Proof.
+intros A B f l; induction l as [|x l IH]; simpl.
++ reflexivity.
++ rewrite IH; reflexivity.
+Qed.
+
+Lemma concat_map : forall A B (f : A -> B) l, map f (concat l) = concat (map (map f) l).
+Proof.
+intros A B f l; induction l as [|x l IH]; simpl.
++ reflexivity.
++ rewrite map_app, IH; reflexivity.
+Qed.
+
 Lemma map_id : forall (A :Type) (l : list A),
   map (fun x => x) l = l.
 Proof.
@@ -869,7 +1027,7 @@ Qed.
 (************************************)
 
 Section Fold_Left_Recursor.
-  Variables A B : Type.
+  Variables (A : Type) (B : Type).
   Variable f : A -> B -> A.
 
   Fixpoint fold_left (l:list B) (a0:A) : A :=
@@ -893,10 +1051,8 @@ End Fold_Left_Recursor.
 Lemma fold_left_length :
   forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
 Proof.
-  intro A.
-  cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
-  intros.
-  exact (H l 0).
+  intros A l.
+  enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0).
   induction l; simpl; auto.
   intros; rewrite IHl.
   simpl; auto with arith.
@@ -907,7 +1063,7 @@ Qed.
 (************************************)
 
 Section Fold_Right_Recursor.
-  Variables A B : Type.
+  Variables (A : Type) (B : Type).
   Variable f : B -> A -> A.
   Variable a0 : A.
 
@@ -939,29 +1095,17 @@ End Fold_Right_Recursor.
   Qed.
 
   Theorem fold_symmetric :
-    forall (A:Type) (f:A -> A -> A),
-      (forall x y z:A, f x (f y z) = f (f x y) z) ->
-      (forall x y:A, f x y = f y x) ->
-      forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
+    forall (A : Type) (f : A -> A -> A),
+    (forall x y z : A, f x (f y z) = f (f x y) z) ->
+    forall (a0 : A), (forall y : A, f a0 y = f y a0) ->
+    forall (l : list A), fold_left f l a0 = fold_right f a0 l.
   Proof.
-    destruct l as [| a l].
-    reflexivity.
-    simpl.
-    rewrite <- H0.
-    generalize a0 a.
-    induction l as [| a3 l IHl]; simpl.
-    trivial.
-    intros.
-    rewrite H.
-    rewrite (H0 a2).
-    rewrite <- (H a1).
-    rewrite (H0 a1).
-    rewrite IHl.
-    reflexivity.
+    intros A f assoc a0 comma0 l.
+    induction l as [ | a1 l ]; [ simpl; reflexivity | ].
+    simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ auto | ].
+    simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto.
   Qed.
 
-
-
   (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
       indexed by elts of [x], sorted in lexicographic order. *)
 
@@ -1075,6 +1219,21 @@ End Fold_Right_Recursor.
 	| x :: tl => if f x then Some x else find tl
       end.
 
+    Lemma find_some l x : find l = Some x -> In x l /\ f x = true.
+    Proof.
+     induction l as [|a l IH]; simpl; [easy| ].
+     case_eq (f a); intros Ha Eq.
+     * injection Eq as ->; auto.
+     * destruct (IH Eq); auto.
+    Qed.
+
+    Lemma find_none l : find l = None -> forall x, In x l -> f x = false.
+    Proof.
+     induction l as [|a l IH]; simpl; [easy|].
+     case_eq (f a); intros Ha Eq x IN; [easy|].
+     destruct IN as [<-|IN]; auto.
+    Qed.
+
   (** [partition] *)
 
     Fixpoint partition (l:list A) : list A * list A :=
@@ -1084,6 +1243,53 @@ End Fold_Right_Recursor.
 	  if f x then (x::g,d) else (g,x::d)
       end.
 
+  Theorem partition_cons1 a l l1 l2:
+    partition l = (l1, l2) ->
+    f a = true ->
+    partition (a::l) = (a::l1, l2).
+  Proof.
+    simpl. now intros -> ->.
+  Qed.
+
+  Theorem partition_cons2 a l l1 l2:
+    partition l = (l1, l2) ->
+    f a=false ->
+    partition (a::l) = (l1, a::l2).
+  Proof.
+    simpl. now intros -> ->.
+  Qed.
+
+  Theorem partition_length l l1 l2:
+    partition l = (l1, l2) ->
+    length l = length l1 + length l2.
+  Proof.
+    revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2.
+    - now intros [= <- <- ].
+    - simpl. destruct (f a), (partition l') as (left, right);
+      intros [= <- <- ]; simpl; rewrite (Hrec left right); auto.
+  Qed.
+
+  Theorem partition_inv_nil (l : list A):
+    partition l = ([], []) <-> l = [].
+  Proof.
+    split.
+    - destruct l as [|a l' _].
+      * intuition.
+      * simpl. destruct (f a), (partition l'); now intros [= -> ->].
+    - now intros ->.
+  Qed.
+
+  Theorem elements_in_partition l l1 l2:
+    partition l = (l1, l2) ->
+    forall x:A, In x l <-> In x l1 \/ In x l2.
+  Proof.
+    revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x.
+    - injection Eq as <- <-. tauto.
+    - destruct (partition l') as (left, right).
+      specialize (Hrec left right eq_refl x).
+      destruct (f a); injection Eq as <- <-; simpl; tauto.
+  Qed.
+
   End Bool.
 
 
@@ -1094,14 +1300,14 @@ End Fold_Right_Recursor.
   (******************************************************)
 
   Section ListPairs.
-    Variables A B : Type.
+    Variables (A : Type) (B : Type).
 
   (** [split] derives two lists from a list of pairs *)
 
     Fixpoint split (l:list (A*B)) : list A * list B :=
       match l with
-	| nil => (nil, nil)
-	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
+	| [] => ([], [])
+	| (x,y) :: tl => let (left,right) := split tl in (x::left, y::right)
       end.
 
     Lemma in_split_l : forall (l:list (A*B))(p:A*B),
@@ -1479,6 +1685,61 @@ Section Cutting.
 
 End Cutting.
 
+(**********************************************************************)
+(** ** Predicate for List addition/removal (no need for decidability) *)
+(**********************************************************************)
+
+Section Add.
+
+  Variable A : Type.
+
+  (* [Add a l l'] means that [l'] is exactly [l], with [a] added
+     once somewhere *)
+  Inductive Add (a:A) : list A -> list A -> Prop :=
+    | Add_head l : Add a l (a::l)
+    | Add_cons x l l' : Add a l l' -> Add a (x::l) (x::l').
+
+  Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2).
+  Proof.
+   induction l1; simpl; now constructor.
+  Qed.
+
+  Lemma Add_split a l l' :
+    Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2.
+  Proof.
+   induction 1.
+   - exists nil; exists l; split; trivial.
+   - destruct IHAdd as (l1 & l2 & Hl & Hl').
+     exists (x::l1); exists l2; split; simpl; f_equal; trivial.
+  Qed.
+
+  Lemma Add_in a l l' : Add a l l' ->
+   forall x, In x l' <-> In x (a::l).
+  Proof.
+   induction 1; intros; simpl in *; rewrite ?IHAdd; tauto.
+  Qed.
+
+  Lemma Add_length a l l' : Add a l l' -> length l' = S (length l).
+  Proof.
+   induction 1; simpl; auto with arith.
+  Qed.
+
+  Lemma Add_inv a l : In a l -> exists l', Add a l' l.
+  Proof.
+   intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->).
+   exists (l1 ++ l2). apply Add_app.
+  Qed.
+
+  Lemma incl_Add_inv a l u v :
+    ~In a l -> incl (a::l) v -> Add a u v -> incl l u.
+  Proof.
+   intros Ha H AD y Hy.
+   assert (Hy' : In y (a::u)).
+   { rewrite <- (Add_in AD). apply H; simpl; auto. }
+   destruct Hy'; [ subst; now elim Ha | trivial ].
+  Qed.
+
+End Add.
 
 (********************************)
 (** ** Lists without redundancy *)
@@ -1492,31 +1753,187 @@ Section ReDun.
     | NoDup_nil : NoDup nil
     | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l).
 
-  Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
+  Lemma NoDup_Add a l l' : Add a l l' -> (NoDup l' <-> NoDup l /\ ~In a l).
   Proof.
-  induction l; simpl.
-  inversion_clear 1; auto.
-  inversion_clear 1.
-  constructor.
-  contradict H0.
-  apply in_or_app; destruct (in_app_or _ _ _ H0); simpl; tauto.
-  apply IHl with a0; auto.
+   induction 1 as [l|x l l' AD IH].
+   - split; [ inversion_clear 1; now split | now constructor ].
+   - split.
+     + inversion_clear 1. rewrite IH in *. rewrite (Add_in AD) in *.
+       simpl in *; split; try constructor; intuition.
+     + intros (N,IN). inversion_clear N. constructor.
+       * rewrite (Add_in AD); simpl in *; intuition.
+       * apply IH. split; trivial. simpl in *; intuition.
   Qed.
 
-  Lemma NoDup_remove_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l').
+  Lemma NoDup_remove l l' a :
+    NoDup (l++a::l') -> NoDup (l++l') /\ ~In a (l++l').
   Proof.
-  induction l; simpl.
-  inversion_clear 1; auto.
-  inversion_clear 1.
-  contradict H0.
-  destruct H0.
-  subst a0.
-  apply in_or_app; right; red; auto.
-  destruct (IHl _ _ H1); auto.
+  apply NoDup_Add. apply Add_app.
+  Qed.
+
+  Lemma NoDup_remove_1 l l' a : NoDup (l++a::l') -> NoDup (l++l').
+  Proof.
+  intros. now apply NoDup_remove with a.
+  Qed.
+
+  Lemma NoDup_remove_2 l l' a : NoDup (l++a::l') -> ~In a (l++l').
+  Proof.
+  intros. now apply NoDup_remove.
+  Qed.
+
+  Theorem NoDup_cons_iff a l:
+    NoDup (a::l) <-> ~ In a l /\ NoDup l.
+  Proof.
+    split.
+    + inversion_clear 1. now split.
+    + now constructor.
+  Qed.
+
+  (** Effective computation of a list without duplicates *)
+
+  Hypothesis decA: forall x y : A, {x = y} + {x <> y}.
+
+  Fixpoint nodup (l : list A) : list A :=
+    match l with
+      | [] => []
+      | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs)
+    end.
+
+  Lemma nodup_In l x : In x (nodup l) <-> In x l.
+  Proof.
+    induction l as [|a l' Hrec]; simpl.
+    - reflexivity.
+    - destruct (in_dec decA a l'); simpl; rewrite Hrec.
+      * intuition; now subst.
+      * reflexivity.
+  Qed.
+
+  Lemma NoDup_nodup l: NoDup (nodup l).
+  Proof.
+    induction l as [|a l' Hrec]; simpl.
+    - constructor.
+    - destruct (in_dec decA a l'); simpl.
+      * assumption.
+      * constructor; [ now rewrite nodup_In | assumption].
+  Qed.
+
+  Lemma nodup_inv k l a : nodup k = a :: l -> ~ In a l.
+  Proof.
+    intros H.
+    assert (H' : NoDup (a::l)).
+    { rewrite <- H. apply NoDup_nodup. }
+    now inversion_clear H'.
+  Qed.
+
+  Theorem NoDup_count_occ l:
+    NoDup l <-> (forall x:A, count_occ decA l x <= 1).
+  Proof.
+    induction l as [| a l' Hrec].
+    - simpl; split; auto. constructor.
+    - rewrite NoDup_cons_iff, Hrec, (count_occ_not_In decA). clear Hrec. split.
+      + intros (Ha, H) x. simpl. destruct (decA a x); auto.
+        subst; now rewrite Ha.
+      + split.
+        * specialize (H a). rewrite count_occ_cons_eq in H; trivial.
+          now inversion H.
+        * intros x. specialize (H x). simpl in *. destruct (decA a x); auto.
+          now apply Nat.lt_le_incl.
+  Qed.
+
+  Theorem NoDup_count_occ' l:
+    NoDup l <-> (forall x:A, In x l -> count_occ decA l x = 1).
+  Proof.
+    rewrite NoDup_count_occ.
+    setoid_rewrite (count_occ_In decA). unfold gt, lt in *.
+    split; intros H x; specialize (H x);
+    set (n := count_occ decA l x) in *; clearbody n.
+    (* the rest would be solved by omega if we had it here... *)
+    - now apply Nat.le_antisymm.
+    - destruct (Nat.le_gt_cases 1 n); trivial.
+      + rewrite H; trivial.
+      + now apply Nat.lt_le_incl.
+  Qed.
+
+  (** Alternative characterisations of being without duplicates,
+      thanks to [nth_error] and [nth] *)
+
+  Lemma NoDup_nth_error l :
+    NoDup l <->
+    (forall i j, i<length l -> nth_error l i = nth_error l j -> i = j).
+  Proof.
+    split.
+    { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi E.
+      - inversion Hi.
+      - destruct i, j; simpl in *; auto.
+        * elim Hal. eapply nth_error_In; eauto.
+        * elim Hal. eapply nth_error_In; eauto.
+        * f_equal. apply IH; auto with arith. }
+    { induction l as [|a l]; intros H; constructor.
+      * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn).
+        assert (n < length l) by (now rewrite <- nth_error_Some, Hn).
+        specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith.
+      * apply IHl.
+        intros i j Hi E. apply eq_add_S, H; simpl; auto with arith. }
+  Qed.
+
+  Lemma NoDup_nth l d :
+    NoDup l <->
+    (forall i j, i<length l -> j<length l ->
+       nth i l d = nth j l d -> i = j).
+  Proof.
+    split.
+    { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi Hj E.
+      - inversion Hi.
+      - destruct i, j; simpl in *; auto.
+        * elim Hal. subst a. apply nth_In; auto with arith.
+        * elim Hal. subst a. apply nth_In; auto with arith.
+        * f_equal. apply IH; auto with arith. }
+    { induction l as [|a l]; intros H; constructor.
+      * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn').
+        specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith.
+      * apply IHl.
+        intros i j Hi Hj E. apply eq_add_S, H; simpl; auto with arith. }
+  Qed.
+
+  (** Having [NoDup] hypotheses bring more precise facts about [incl]. *)
+
+  Lemma NoDup_incl_length l l' :
+    NoDup l -> incl l l' -> length l <= length l'.
+  Proof.
+   intros N. revert l'. induction N as [|a l Hal N IH]; simpl.
+   - auto with arith.
+   - intros l' H.
+     destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. }
+     rewrite (Add_length AD). apply le_n_S. apply IH.
+     now apply incl_Add_inv with a l'.
+  Qed.
+
+  Lemma NoDup_length_incl l l' :
+    NoDup l -> length l' <= length l -> incl l l' -> incl l' l.
+  Proof.
+   intros N. revert l'. induction N as [|a l Hal N IH].
+   - destruct l'; easy.
+   - intros l' E H x Hx.
+     destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. }
+     rewrite (Add_in AD) in Hx. simpl in Hx.
+     destruct Hx as [Hx|Hx]; [left; trivial|right].
+     revert x Hx. apply (IH l''); trivial.
+     * apply le_S_n. now rewrite <- (Add_length AD).
+     * now apply incl_Add_inv with a l'.
   Qed.
 
 End ReDun.
 
+(** NoDup and map *)
+
+(** NB: the reciprocal result holds only for injective functions,
+    see FinFun.v *)
+
+Lemma NoDup_map_inv A B (f:A->B) l : NoDup (map f l) -> NoDup l.
+Proof.
+ induction l; simpl; inversion_clear 1; subst; constructor; auto.
+ intro H. now apply (in_map f) in H.
+Qed.
 
 (***********************************)
 (** ** Sequence of natural numbers *)
@@ -1558,149 +1975,252 @@ Section NatSeq.
     auto with arith.
   Qed.
 
+  Lemma in_seq len start n :
+    In n (seq start len) <-> start <= n < start+len.
+  Proof.
+   revert start. induction len; simpl; intros.
+   - rewrite <- plus_n_O. split;[easy|].
+     intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')).
+   - rewrite IHlen, <- plus_n_Sm; simpl; split.
+     * intros [H|H]; subst; intuition auto with arith.
+     * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition.
+  Qed.
+
+  Lemma seq_NoDup len start : NoDup (seq start len).
+  Proof.
+   revert start; induction len; simpl; constructor; trivial.
+   rewrite in_seq. intros (H,_). apply (Lt.lt_irrefl _ H).
+  Qed.
+
 End NatSeq.
 
+Section Exists_Forall.
 
-(** * Existential and universal predicates over lists *)
+  (** * Existential and universal predicates over lists *)
 
-Inductive Exists {A} (P:A->Prop) : list A -> Prop :=
- | Exists_cons_hd : forall x l, P x -> Exists P (x::l)
- | Exists_cons_tl : forall x l, Exists P l -> Exists P (x::l).
-Hint Constructors Exists.
+  Variable A:Type.
 
-Lemma Exists_exists : forall A P (l:list A),
- Exists P l <-> (exists x, In x l /\ P x).
-Proof.
-split.
-induction 1; firstorder.
-induction l; firstorder; subst; auto.
-Qed.
+  Section One_predicate.
+
+    Variable P:A->Prop.
+
+    Inductive Exists : list A -> Prop :=
+      | Exists_cons_hd : forall x l, P x -> Exists (x::l)
+      | Exists_cons_tl : forall x l, Exists l -> Exists (x::l).
 
-Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False.
-Proof. split; inversion 1. Qed.
+    Hint Constructors Exists.
 
-Lemma Exists_cons : forall A (P:A->Prop) x l,
- Exists P (x::l) <-> P x \/ Exists P l.
-Proof. split; inversion 1; auto. Qed.
+    Lemma Exists_exists (l:list A) :
+      Exists l <-> (exists x, In x l /\ P x).
+    Proof.
+      split.
+      - induction 1; firstorder.
+      - induction l; firstorder; subst; auto.
+    Qed.
 
+    Lemma Exists_nil : Exists nil <-> False.
+    Proof. split; inversion 1. Qed.
+
+    Lemma Exists_cons x l:
+      Exists (x::l) <-> P x \/ Exists l.
+    Proof. split; inversion 1; auto. Qed.
+
+    Lemma Exists_dec l:
+      (forall x:A, {P x} + { ~ P x }) ->
+      {Exists l} + {~ Exists l}.
+    Proof.
+      intro Pdec. induction l as [|a l' Hrec].
+      - right. now rewrite Exists_nil.
+      - destruct Hrec as [Hl'|Hl'].
+        * left. now apply Exists_cons_tl.
+        * destruct (Pdec a) as [Ha|Ha].
+          + left. now apply Exists_cons_hd.
+          + right. now inversion_clear 1.
+    Qed.
 
-Inductive Forall {A} (P:A->Prop) : list A -> Prop :=
- | Forall_nil : Forall P nil
- | Forall_cons : forall x l, P x -> Forall P l -> Forall P (x::l).
+    Inductive Forall : list A -> Prop :=
+      | Forall_nil : Forall nil
+      | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l).
+
+    Hint Constructors Forall.
+
+    Lemma Forall_forall (l:list A):
+      Forall l <-> (forall x, In x l -> P x).
+    Proof.
+      split.
+      - induction 1; firstorder; subst; auto.
+      - induction l; firstorder.
+    Qed.
+
+    Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a.
+    Proof.
+      intros; inversion H; trivial.
+    Qed.
+
+    Lemma Forall_rect : forall (Q : list A -> Type),
+      Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l.
+    Proof.
+      intros Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
+    Qed.
+
+    Lemma Forall_dec :
+      (forall x:A, {P x} + { ~ P x }) ->
+      forall l:list A, {Forall l} + {~ Forall l}.
+    Proof.
+      intro Pdec. induction l as [|a l' Hrec].
+      - left. apply Forall_nil.
+      - destruct Hrec as [Hl'|Hl'].
+        + destruct (Pdec a) as [Ha|Ha].
+          * left. now apply Forall_cons.
+          * right. now inversion_clear 1.
+        + right. now inversion_clear 1.
+    Qed.
+
+  End One_predicate.
+
+  Lemma Forall_Exists_neg (P:A->Prop)(l:list A) :
+   Forall (fun x => ~ P x) l <-> ~(Exists P l).
+  Proof.
+   rewrite Forall_forall, Exists_exists. firstorder.
+  Qed.
+
+  Lemma Exists_Forall_neg (P:A->Prop)(l:list A) :
+    (forall x, P x \/ ~P x) ->
+    Exists (fun x => ~ P x) l <-> ~(Forall P l).
+  Proof.
+   intro Dec.
+   split.
+   - rewrite Forall_forall, Exists_exists; firstorder.
+   - intros NF.
+     induction l as [|a l IH].
+     + destruct NF. constructor.
+     + destruct (Dec a) as [Ha|Ha].
+       * apply Exists_cons_tl, IH. contradict NF. now constructor.
+       * now apply Exists_cons_hd.
+  Qed.
+
+  Lemma Forall_Exists_dec (P:A->Prop) :
+    (forall x:A, {P x} + { ~ P x }) ->
+    forall l:list A,
+    {Forall P l} + {Exists (fun x => ~ P x) l}.
+  Proof.
+    intros Pdec l.
+    destruct (Forall_dec P Pdec l); [left|right]; trivial.
+    apply Exists_Forall_neg; trivial.
+    intro x. destruct (Pdec x); [now left|now right].
+  Qed.
+
+  Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) ->
+    forall l, Forall P l -> Forall Q l.
+  Proof.
+    intros P Q H l. rewrite !Forall_forall. firstorder.
+  Qed.
+
+End Exists_Forall.
+
+Hint Constructors Exists.
 Hint Constructors Forall.
 
-Lemma Forall_forall : forall A P (l:list A),
- Forall P l <-> (forall x, In x l -> P x).
-Proof.
-split.
-induction 1; firstorder; subst; auto.
-induction l; firstorder.
-Qed.
+Section Forall2.
 
-Lemma Forall_inv : forall A P (a:A) l, Forall P (a :: l) -> P a.
-Proof.
-intros; inversion H; trivial.
-Defined.
+  (** [Forall2]: stating that elements of two lists are pairwise related. *)
 
-Lemma Forall_rect : forall A (P:A->Prop) (Q : list A -> Type),
-     Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall P l -> Q l.
-Proof.
-intros A P Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
-Defined.
+  Variables A B : Type.
+  Variable R : A -> B -> Prop.
 
-Lemma Forall_impl : forall A (P Q : A -> Prop), (forall a, P a -> Q a) ->
-  forall l, Forall P l -> Forall Q l.
-Proof.
-  intros A P Q Himp l H.
-  induction H; firstorder.
-Qed.
+  Inductive Forall2 : list A -> list B -> Prop :=
+    | Forall2_nil : Forall2 [] []
+    | Forall2_cons : forall x y l l',
+      R x y -> Forall2 l l' -> Forall2 (x::l) (y::l').
 
-(** [Forall2]: stating that elements of two lists are pairwise related. *)
+  Hint Constructors Forall2.
 
-Inductive Forall2 A B (R:A->B->Prop) : list A -> list B -> Prop :=
- | Forall2_nil : Forall2 R [] []
- | Forall2_cons : forall x y l l',
-    R x y -> Forall2 R l l' -> Forall2 R (x::l) (y::l').
-Hint Constructors Forall2.
+  Theorem Forall2_refl : Forall2 [] [].
+  Proof. intros; apply Forall2_nil. Qed.
+
+  Theorem Forall2_app_inv_l : forall l1 l2 l',
+    Forall2 (l1 ++ l2) l' ->
+    exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'.
+  Proof.
+    induction l1; intros.
+      exists [], l'; auto.
+      simpl in H; inversion H; subst; clear H.
+      apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
+      exists (y::l1'), l2'; simpl; auto.
+  Qed.
 
-Theorem Forall2_refl : forall A B (R:A->B->Prop), Forall2 R [] [].
-Proof. exact Forall2_nil. Qed.
+  Theorem Forall2_app_inv_r : forall l1' l2' l,
+    Forall2 l (l1' ++ l2') ->
+    exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2.
+  Proof.
+    induction l1'; intros.
+      exists [], l; auto.
+      simpl in H; inversion H; subst; clear H.
+      apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
+      exists (x::l1), l2; simpl; auto.
+  Qed.
 
-Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l',
-  Forall2 R (l1 ++ l2) l' ->
-  exists l1' l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'.
-Proof.
-  induction l1; intros.
-    exists [], l'; auto.
-    simpl in H; inversion H; subst; clear H.
-    apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
-    exists (y::l1'), l2'; simpl; auto.
-Qed.
+  Theorem Forall2_app : forall l1 l2 l1' l2',
+    Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2').
+  Proof.
+    intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
+  Qed.
+End Forall2.
 
-Theorem Forall2_app_inv_r : forall A B (R:A->B->Prop) l1' l2' l,
-  Forall2 R l (l1' ++ l2') ->
-  exists l1 l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2.
-Proof.
-  induction l1'; intros.
-    exists [], l; auto.
-    simpl in H; inversion H; subst; clear H.
-    apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
-    exists (x::l1), l2; simpl; auto.
-Qed.
+Hint Constructors Forall2.
 
-Theorem Forall2_app : forall A B (R:A->B->Prop) l1 l2 l1' l2',
-  Forall2 R l1 l1' -> Forall2 R l2 l2' -> Forall2 R (l1 ++ l2) (l1' ++ l2').
-Proof.
-  intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
-Qed.
+Section ForallPairs.
 
-(** [ForallPairs] : specifies that a certain relation should
+  (** [ForallPairs] : specifies that a certain relation should
     always hold when inspecting all possible pairs of elements of a list. *)
 
-Definition ForallPairs A (R : A -> A -> Prop) l :=
- forall a b, In a l -> In b l -> R a b.
+  Variable A : Type.
+  Variable R : A -> A -> Prop.
 
-(** [ForallOrdPairs] : we still check a relation over all pairs
+  Definition ForallPairs l :=
+    forall a b, In a l -> In b l -> R a b.
+
+  (** [ForallOrdPairs] : we still check a relation over all pairs
      of elements of a list, but now the order of elements matters. *)
 
-Inductive ForallOrdPairs A (R : A -> A -> Prop) : list A -> Prop :=
-  | FOP_nil : ForallOrdPairs R nil
-  | FOP_cons : forall a l,
-     Forall (R a) l -> ForallOrdPairs R l -> ForallOrdPairs R (a::l).
-Hint Constructors ForallOrdPairs.
+  Inductive ForallOrdPairs : list A -> Prop :=
+    | FOP_nil : ForallOrdPairs nil
+    | FOP_cons : forall a l,
+      Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l).
 
-Lemma ForallOrdPairs_In : forall A (R:A->A->Prop) l,
- ForallOrdPairs R l ->
- forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
-Proof.
- induction 1.
- inversion 1.
- simpl; destruct 1; destruct 1; repeat subst; auto.
- right; left. apply -> Forall_forall; eauto.
- right; right. apply -> Forall_forall; eauto.
-Qed.
+  Hint Constructors ForallOrdPairs.
 
+  Lemma ForallOrdPairs_In : forall l,
+    ForallOrdPairs l ->
+    forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
+  Proof.
+    induction 1.
+    inversion 1.
+    simpl; destruct 1; destruct 1; repeat subst; auto.
+    right; left. apply -> Forall_forall; eauto.
+    right; right. apply -> Forall_forall; eauto.
+  Qed.
 
-(** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
+  (** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
     only when [R] is symmetric and reflexive. *)
 
-Lemma ForallPairs_ForallOrdPairs : forall A (R:A->A->Prop) l,
- ForallPairs R l -> ForallOrdPairs R l.
-Proof.
- induction l; auto. intros H.
- constructor.
- apply <- Forall_forall. intros; apply H; simpl; auto.
- apply IHl. red; intros; apply H; simpl; auto.
-Qed.
+  Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l.
+  Proof.
+    induction l; auto. intros H.
+    constructor.
+    apply <- Forall_forall. intros; apply H; simpl; auto.
+    apply IHl. red; intros; apply H; simpl; auto.
+  Qed.
 
-Lemma ForallOrdPairs_ForallPairs : forall A (R:A->A->Prop),
- (forall x, R x x) ->
- (forall x y, R x y -> R y x) ->
- forall l, ForallOrdPairs R l -> ForallPairs R l.
-Proof.
- intros A R Refl Sym l Hl x y Hx Hy.
- destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
-Qed.
+  Lemma ForallOrdPairs_ForallPairs :
+    (forall x, R x x) ->
+    (forall x y, R x y -> R y x) ->
+    forall l, ForallOrdPairs l -> ForallPairs l.
+  Proof.
+    intros Refl Sym l Hl x y Hx Hy.
+    destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
+  Qed.
+End ForallPairs.
 
 (** * Inversion of predicates over lists based on head symbol *)
 
@@ -1767,3 +2287,28 @@ Notation AllS := Forall (only parsing). (* was formerly in TheoryList *)
 
 Hint Resolve app_nil_end : datatypes v62.
 (* end hide *)
+
+Section Repeat.
+
+  Variable A : Type.
+  Fixpoint repeat (x : A) (n: nat ) :=
+    match n with
+      | O => []
+      | S k => x::(repeat x k)
+    end.
+
+  Theorem repeat_length x n:
+    length (repeat x n) = n.
+  Proof.
+    induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity.
+  Qed.
+
+  Theorem repeat_spec n x y:
+    In y (repeat x n) -> y=x.
+  Proof.
+    induction n as [|k Hrec]; simpl; destruct 1; auto.
+  Qed.
+
+End Repeat.
+
+(* Unset Universe Polymorphism. *)
diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v
new file mode 100644
index 00000000..8bd2daaf
--- /dev/null
+++ b/theories/Lists/ListDec.v
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** Decidability results about lists *)
+
+Require Import List Decidable.
+Set Implicit Arguments.
+
+Definition decidable_eq A := forall x y:A, decidable (x=y).
+
+Section Dec_in_Prop.
+Variables (A:Type)(dec:decidable_eq A).
+
+Lemma In_decidable x (l:list A) : decidable (In x l).
+Proof using A dec.
+ induction l as [|a l IH].
+ - now right.
+ - destruct (dec a x).
+   + left. now left.
+   + destruct IH; simpl; [left|right]; tauto.
+Qed.
+
+Lemma incl_decidable (l l':list A) : decidable (incl l l').
+Proof using A dec.
+ induction l as [|a l IH].
+ - left. inversion 1.
+ - destruct (In_decidable a l') as [IN|IN].
+   + destruct IH as [IC|IC].
+     * left. destruct 1; subst; auto.
+     * right. contradict IC. intros x H. apply IC; now right.
+   + right. contradict IN. apply IN; now left.
+Qed.
+
+Lemma NoDup_decidable (l:list A) : decidable (NoDup l).
+Proof using A dec.
+ induction l as [|a l IH].
+ - left; now constructor.
+ - destruct (In_decidable a l).
+   + right. inversion_clear 1. tauto.
+   + destruct IH.
+     * left. now constructor.
+     * right. inversion_clear 1. tauto.
+Qed.
+
+End Dec_in_Prop.
+
+Section Dec_in_Type.
+Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}).
+
+Definition In_dec := List.In_dec dec. (* Already in List.v *)
+
+Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}.
+Proof using A dec.
+ induction l as [|a l IH].
+ - left. inversion 1.
+ - destruct (In_dec a l') as [IN|IN].
+   + destruct IH as [IC|IC].
+     * left. destruct 1; subst; auto.
+     * right. contradict IC. intros x H. apply IC; now right.
+   + right. contradict IN. apply IN; now left.
+Qed.
+
+Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}.
+Proof using A dec.
+ induction l as [|a l IH].
+ - left; now constructor.
+ - destruct (In_dec a l).
+   + right. inversion_clear 1. tauto.
+   + destruct IH.
+     * left. now constructor.
+     * right. inversion_clear 1. tauto.
+Qed.
+
+End Dec_in_Type.
+
+(** An extra result: thanks to decidability, a list can be purged
+    from redundancies. *)
+
+Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) :
+ exists l', NoDup (map f l') /\ incl (map f l) (map f l').
+Proof.
+ induction l.
+ - exists nil. simpl. split; [now constructor | red; trivial].
+ - destruct IHl as (l' & N & I).
+   destruct (In_decidable d (f a) (map f l')).
+   + exists l'; simpl; split; trivial.
+     intros x [Hx|Hx]. now subst. now apply I.
+   + exists (a::l'); simpl; split.
+     * now constructor.
+     * intros x [Hx|Hx]. subst; now left. right; now apply I.
+Qed.
+
+Lemma uniquify A (d:decidable_eq A)(l:list A) :
+ exists l', NoDup l' /\ incl l l'.
+Proof.
+ destruct (uniquify_map d id l) as (l',H).
+ exists l'. now rewrite !map_id in H.
+Qed.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index 37d051a3..0a0bf0de 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -1,16 +1,18 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** A Library for finite sets, implemented as lists *)
+(** A library for finite sets, implemented as lists *)
 
-(** List is loaded, but not exported.
-    This allow to "hide" the definitions, functions and theorems of List
-    and to see only the ones of ListSet *)
+(** This is a light implementation of finite sets as lists; for a more
+    extensive library, you might rather consider MSetWeakList.v. In
+    addition, if your domain is totally ordered, you might also
+    consider implementations of finite sets with access in logarithmic
+    time (e.g. MSetRBT.v which is based on red-black trees). *)
 
 Require Import List.
 
@@ -116,7 +118,7 @@ Section first_definitions.
     simple induction x; simpl; intros.
     apply H0; red; trivial.
     case (Aeq_dec a a0); auto with datatypes.
-    intro; apply H; intros; auto.
+    intro Hneg; apply H; intros; auto.
     apply H1; red; intro.
     case H3; auto.
   Qed.
@@ -147,8 +149,8 @@ Section first_definitions.
     simple induction x; simpl.
     tauto.
     intros a0 l; elim (Aeq_dec a a0).
-    intros; discriminate H0.
-    unfold not; intros; elim H1; auto with datatypes.
+    intros _ _ [=].
+    unfold not; intros H H0 H1 [|]; auto with datatypes.
   Qed.
 
   Lemma set_mem_complete2 :
@@ -157,7 +159,7 @@ Section first_definitions.
     simple induction x; simpl.
     tauto.
     intros a0 l; elim (Aeq_dec a a0).
-    intros; elim H0; auto with datatypes.
+    intros H H0 []; auto with datatypes.
     tauto.
   Qed.
 
@@ -204,7 +206,7 @@ Section first_definitions.
     simpl; do 3 intro.
     elim (Aeq_dec b a0).
     simpl; tauto.
-    simpl; intros; elim H0.
+    simpl; intros H0 [|].
     trivial with datatypes.
     tauto.
     tauto.
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
index 64c11cd8..f19d95a9 100644
--- a/theories/Lists/ListTactics.v
+++ b/theories/Lists/ListTactics.v
@@ -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/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index 0fd1693e..b57c3f04 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -11,7 +11,7 @@ Require Export Sorted.
 Require Export Setoid Basics Morphisms.
 Set Implicit Arguments.
 Unset Strict Implicit.
-
+(* Set Universe Polymorphism. *)
 (** * Logical relations over lists with respect to a setoid equality
       or ordering. *)
 
@@ -34,7 +34,7 @@ Hint Constructors InA.
     of the previous one. Having [InA = Exists eqA] raises too
     many compatibility issues. For now, we only state the equivalence: *)
 
-Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l.
+Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l. 
 Proof. split; induction 1; auto. Qed.
 
 Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
@@ -101,10 +101,12 @@ Proof. split; induction 1; auto. Qed.
 (** Results concerning lists modulo [eqA] *)
 
 Hypothesis eqA_equiv : Equivalence eqA.
-
-Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv).
-Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv).
-Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv).
+Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv).
+Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv).
+Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv).
+ 
+Hint Resolve eqarefl eqatrans.
+Hint Immediate eqasym.
 
 Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.
 
@@ -123,7 +125,6 @@ Proof.
  intros x y z H; revert z; induction H; auto.
  inversion 1; subst; auto. invlist eqlistA; eauto with *.
 Qed.
-
 (** Moreover, [eqlistA] implies [equivlistA]. A reverse result
     will be proved later for sorted list without duplicates. *)
 
@@ -149,7 +150,7 @@ Qed.
 
 Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
 Proof.
- intros l x y H H'. rewrite <- H; auto.
+ intros l x y H H'. rewrite <- H. auto.
 Qed.
 Hint Immediate InA_eqA.
 
@@ -496,7 +497,7 @@ Proof.
  apply Hrec; auto.
  inv; auto.
  eapply NoDupA_split; eauto.
- invlist ForallOrdPairs; auto.
+ invlist ForallOrdPairs; auto. 
  eapply equivlistA_NoDupA_split; eauto.
  transitivity (f y (fold_right f i (s1++s2))).
  apply Comp; auto. reflexivity.
@@ -545,6 +546,155 @@ Qed.
 
 End Fold.
 
+
+Section Fold2.
+
+Variable B:Type.
+Variable eqB:B->B->Prop.
+Variable st:Equivalence eqB.
+Variable f:A->B->B.
+Variable Comp:Proper (eqA==>eqB==>eqB) f.
+
+
+Lemma fold_right_eqlistA2 :
+  forall s s' (i j:B) (heqij: eqB i j) (heqss': eqlistA s s'),
+  eqB (fold_right f i s) (fold_right f j s').
+Proof.
+  intros s.
+  induction s;intros.
+  - inversion heqss'.
+    subst.
+    simpl.
+    assumption.
+  - inversion heqss'.
+    subst.
+    simpl.
+    apply Comp.
+    + assumption.
+    + apply IHs;assumption.
+Qed.
+
+Section Fold2_With_Restriction.
+
+Variable R : A -> A -> Prop.
+Hypothesis R_sym : Symmetric R.
+Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.
+
+(** Two-argument functions that allow to reorder their arguments. *)
+Definition transpose2 (f : A -> B -> B) :=
+  forall (x y : A) (z z': B), eqB z z' -> eqB (f x (f y z)) (f y (f x z')).
+
+(** A version of transpose with restriction on where it should hold *)
+Definition transpose_restr2 (R : A -> A -> Prop)(f : A -> B -> B) :=
+  forall (x y : A) (z z': B), R x y -> eqB z z' -> eqB (f x (f y z)) (f y (f x z')).
+
+Variable TraR :transpose_restr2 R f.
+
+Lemma fold_right_commutes_restr2 :
+  forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) ->
+  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))).
+Proof.
+induction s1; simpl; auto; intros.
+- apply Comp.
+  + destruct eqA_equiv. apply Equivalence_Reflexive.
+  + eapply fold_right_eqlistA2.
+    * assumption.
+    * reflexivity.
+- transitivity (f a (f x (fold_right f j (s1++s2)))).
+  apply Comp; auto.
+  eapply IHs1.
+  assumption.
+  invlist ForallOrdPairs; auto.
+  apply TraR.
+  invlist ForallOrdPairs; auto.
+  rewrite Forall_forall in H0; apply H0.
+  apply in_or_app; simpl; auto.
+  reflexivity.
+Qed.
+
+Lemma fold_right_equivlistA_restr2 :
+  forall s s' (i j:B) (heqij: eqB i j),
+    NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
+               eqB i j -> 
+  equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
+Proof.
+ simple induction s.
+ destruct s'; simpl.
+ intros. assumption.
+ unfold equivlistA; intros.
+ destruct (H3 a).
+ assert (InA a nil) by auto; inv.
+ intros x l Hrec s' i j heqij N N' F eqij E; simpl in *.
+ assert (InA x s') by (rewrite <- (E x); auto).
+ destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
+ subst s'.
+ transitivity (f x (fold_right f j (s1++s2))).
+ - apply Comp; auto.
+   apply Hrec; auto.
+   inv; auto.
+   eapply NoDupA_split; eauto.
+   invlist ForallOrdPairs; auto.
+   eapply equivlistA_NoDupA_split; eauto.
+ - transitivity (f y (fold_right f i (s1++s2))).
+   + apply Comp; auto.
+     symmetry.
+     apply fold_right_eqlistA2.
+     * assumption.
+     * reflexivity.
+   + symmetry.
+     apply fold_right_commutes_restr2.
+     symmetry.
+     assumption.
+     apply ForallOrdPairs_inclA with (x::l); auto.
+     red; intros; rewrite E; auto.
+Qed.
+
+
+Lemma fold_right_add_restr2 :
+  forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s ->
+  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
+Proof.
+ intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto.
+Qed.
+
+End Fold2_With_Restriction.
+
+Variable Tra :transpose2 f.
+
+Lemma fold_right_commutes2 : forall s1 s2 i x x',
+  eqA x x' -> 
+  eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))).
+Proof.
+  induction s1;simpl;intros.
+- apply Comp;auto.
+  reflexivity.
+- transitivity (f a (f x' (fold_right f i (s1++s2)))); auto.
+  + apply Comp;auto.
+  + apply Tra.
+    reflexivity.
+Qed.
+
+Lemma fold_right_equivlistA2 :
+  forall s s' i j, NoDupA s -> NoDupA s' -> eqB i j ->
+  equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
+Proof.
+red in Tra.
+intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True);
+repeat red; auto.
+apply ForallPairs_ForallOrdPairs; try red; auto.
+Qed.
+
+Lemma fold_right_add2 :
+  forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s ->
+  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
+Proof.
+ intros.
+ replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto.
+ eapply fold_right_equivlistA2;auto. 
+Qed.
+
+End Fold2.
+
 Section Remove.
 
 Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
@@ -582,14 +732,14 @@ split.
 intro; inv.
 destruct 1; inv.
 intros.
-destruct (eqA_dec x a); simpl; auto.
+destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto.
 rewrite IHl; split; destruct 1; split; auto.
 inv; auto.
 destruct H0; transitivity a; auto.
 split.
 intro; inv.
 split; auto.
-contradict n.
+contradict Hnot.
 transitivity y; auto.
 rewrite (IHl x y) in H0; destruct H0; auto.
 destruct 1; inv; auto.
@@ -633,7 +783,9 @@ Variable ltA : A -> A -> Prop.
 Hypothesis ltA_strorder : StrictOrder ltA.
 Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.
 
-Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder).
+Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder).
+
+Hint Resolve sotrans.
 
 Notation InfA:=(lelistA ltA).
 Notation SortA:=(sort ltA).
@@ -647,7 +799,7 @@ Proof.
 Qed.
 
 Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
-Proof.
+Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *)
  intros x x' Hxx' l l' Hll'.
  inversion_clear Hll'.
  intuition.
@@ -658,7 +810,7 @@ Qed.
 
 (** For compatibility, can be deduced from [InfA_compat] *)
 Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l.
-Proof.
+Proof using eqA_equiv ltA_compat.
  intros H; now rewrite H.
 Qed.
 Hint Immediate InfA_ltA InfA_eqA.
@@ -759,7 +911,7 @@ Qed.
 Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
 Proof.
 repeat red. intros.
-rewrite (app_nil_end (rev x)), (app_nil_end (rev y)).
+rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)).
 apply eqlistA_rev_app; auto.
 Qed.
 
@@ -815,13 +967,12 @@ intros.
 rewrite filter_In in H; destruct H.
 eapply SortA_InfA_InA; eauto.
 Qed.
-
 Arguments eq {A} x _.
 
 Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
  forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
 Proof.
-clear ltA ltA_compat ltA_strorder.
+clear sotrans ltA ltA_strorder ltA_compat.
 intros; do 2 rewrite InA_alt; intuition.
 destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
 destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
@@ -888,9 +1039,9 @@ split; intros.
 invlist InA.
 compute in H2; destruct H2. subst b'.
 destruct (eqA_dec a a'); intuition.
-destruct (eqA_dec a a'); simpl.
+destruct (eqA_dec a a') as [HeqA|]; simpl.
 contradict H0.
-revert e H2; clear - eqA_equiv.
+revert HeqA H2; clear - eqA_equiv.
 induction l.
 intros; invlist InA.
 intros; invlist InA; auto.
diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v
index b0657b63..afc7c25b 100644
--- a/theories/Lists/SetoidPermutation.v
+++ b/theories/Lists/SetoidPermutation.v
@@ -7,6 +7,7 @@
 (***********************************************************************)
 
 Require Import SetoidList.
+(* Set Universe Polymorphism. *)
 
 Set Implicit Arguments.
 Unset Strict Implicit.
@@ -88,7 +89,7 @@ Lemma PermutationA_cons_app l l� l₂ x :
   PermutationA l (l� ++ l₂) -> PermutationA (x :: l) (l� ++ x :: l₂).
 Proof.
  intros E. rewrite E.
- now rewrite app_comm_cons, PermutationA_cons_append, <-app_assoc.
+ now rewrite app_comm_cons, (PermutationA_cons_append l� x), <- app_assoc.
 Qed.
 
 Lemma PermutationA_middle l� l₂ x :
diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v
index fd5ab100..74d464c5 100644
--- a/theories/Lists/StreamMemo.v
+++ b/theories/Lists/StreamMemo.v
@@ -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/theories/Lists/Streams.v b/theories/Lists/Streams.v
index fa9b7873..cc4fb179 100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -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/theories/Lists/vo.itarget b/theories/Lists/vo.itarget
index 04994f59..82dd1be8 100644
--- a/theories/Lists/vo.itarget
+++ b/theories/Lists/vo.itarget
@@ -1,6 +1,7 @@
 ListSet.vo
 ListTactics.vo
 List.vo
+ListDec.vo
 SetoidList.vo
 SetoidPermutation.vo
 StreamMemo.vo
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index 9f01c565..d72f4072 100644
--- a/theories/Logic/Berardi.v
+++ b/theories/Logic/Berardi.v
@@ -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        *)
@@ -67,18 +67,13 @@ Variables A B : Prop.
 
 Record retract : Prop :=
   {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}.
-
 Record retract_cond : Prop :=
   {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}.
 
-
 (** The dependent elimination above implies the axiom of choice: *)
-Lemma AC : forall r:retract_cond, retract -> forall a:A, j2 r (i2 r a) = a.
-Proof.
-intros r.
-case r; simpl.
-trivial.
-Qed.
+
+Lemma AC : forall r:retract_cond, retract -> forall a:A, r.(j2) (r.(i2) a) = a.
+Proof. intros r. exact r.(inv2). Qed.
 
 End Retracts.
 
@@ -114,7 +109,7 @@ Proof.
 exists g f.
 intro a.
 unfold f, g; simpl.
-apply AC.
+apply AC. 
 exists (fun x:pow U => x) (fun x:pow U => x).
 trivial.
 Qed.
@@ -132,9 +127,10 @@ Lemma not_has_fixpoint : R R = Not_b (R R).
 Proof.
 unfold R at 1.
 unfold g.
-rewrite AC with (r := L1 U U) (a := fun u:U => Not_b (u U u)).
+rewrite AC.
+trivial.
+exists (fun x:pow U => x) (fun x:pow U => x).
 trivial.
-exists (fun x:pow U => x) (fun x:pow U => x); trivial.
 Qed.
 
 
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index d8fb5dd4..d2327498 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -52,7 +52,7 @@ We let also
 - IPL^2   = 2nd-order functional minimal predicate logic (with ex. quant.)
 - IPL_2^2 = 2nd-order impredicative, 2nd-order functional minimal pred. logic (with ex. quant.)
 
-with no prerequisite on the non-emptyness of domains
+with no prerequisite on the non-emptiness of domains
 
 Table of contents
 
@@ -89,12 +89,19 @@ intentional type theory, Journal of Symbolic Logic 70(2):488-514, 2005.
 *)
 
 Set Implicit Arguments.
+Local Unset Intuition Negation Unfolding.
 
 (**********************************************************************)
 (** * Definitions *)
 
 (** Choice, reification and description schemes *)
 
+(** We make them all polymorphic. Most of them have existentials as conclusion
+    so they require polymorphism otherwise their first application (e.g. to an
+    existential in [Set]) will fix the level of [A].
+*)
+(* Set Universe Polymorphism. *)
+
 Section ChoiceSchemes.
 
 Variables A B :Type.
@@ -216,39 +223,39 @@ End ChoiceSchemes.
 (** Generalized schemes *)
 
 Notation RelationalChoice :=
-  (forall A B, RelationalChoice_on A B).
+  (forall A B : Type, RelationalChoice_on A B).
 Notation FunctionalChoice :=
-  (forall A B, FunctionalChoice_on A B).
+  (forall A B : Type, FunctionalChoice_on A B).
 Definition FunctionalDependentChoice :=
-  (forall A, FunctionalDependentChoice_on A).
+  (forall A : Type, FunctionalDependentChoice_on A).
 Definition FunctionalCountableChoice :=
-  (forall A, FunctionalCountableChoice_on A).
+  (forall A : Type, FunctionalCountableChoice_on A).
 Notation FunctionalChoiceOnInhabitedSet :=
-  (forall A B, inhabited B -> FunctionalChoice_on A B).
+  (forall A B : Type, inhabited B -> FunctionalChoice_on A B).
 Notation FunctionalRelReification :=
-  (forall A B, FunctionalRelReification_on A B).
+  (forall A B : Type, FunctionalRelReification_on A B).
 
 Notation GuardedRelationalChoice :=
-  (forall A B, GuardedRelationalChoice_on A B).
+  (forall A B : Type, GuardedRelationalChoice_on A B).
 Notation GuardedFunctionalChoice :=
-  (forall A B, GuardedFunctionalChoice_on A B).
+  (forall A B : Type, GuardedFunctionalChoice_on A B).
 Notation GuardedFunctionalRelReification :=
-  (forall A B, GuardedFunctionalRelReification_on A B).
+  (forall A B : Type, GuardedFunctionalRelReification_on A B).
 
 Notation OmniscientRelationalChoice :=
-  (forall A B, OmniscientRelationalChoice_on A B).
+  (forall A B : Type, OmniscientRelationalChoice_on A B).
 Notation OmniscientFunctionalChoice :=
-  (forall A B, OmniscientFunctionalChoice_on A B).
+  (forall A B : Type, OmniscientFunctionalChoice_on A B).
 
 Notation ConstructiveDefiniteDescription :=
-  (forall A, ConstructiveDefiniteDescription_on A).
+  (forall A : Type, ConstructiveDefiniteDescription_on A).
 Notation ConstructiveIndefiniteDescription :=
-  (forall A, ConstructiveIndefiniteDescription_on A).
+  (forall A : Type, ConstructiveIndefiniteDescription_on A).
 
 Notation IotaStatement :=
-  (forall A, IotaStatement_on A).
+  (forall A : Type, IotaStatement_on A).
 Notation EpsilonStatement :=
-  (forall A, EpsilonStatement_on A).
+  (forall A : Type, EpsilonStatement_on A).
 
 (** Subclassical schemes *)
 
@@ -292,7 +299,7 @@ Proof.
 Qed.
 
 Lemma funct_choice_imp_rel_choice :
-  forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B.
+  forall A B : Type, FunctionalChoice_on A B -> RelationalChoice_on A B.
 Proof.
   intros A B FunCh R H.
   destruct (FunCh R H) as (f,H0).
@@ -305,7 +312,7 @@ Proof.
 Qed.
 
 Lemma funct_choice_imp_description :
-  forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
+  forall A B : Type, FunctionalChoice_on A B -> FunctionalRelReification_on A B.
 Proof.
   intros A B FunCh R H.
   destruct (FunCh R) as [f H0].
@@ -318,10 +325,10 @@ Proof.
 Qed.
 
 Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr :
-  forall A B, FunctionalChoice_on A B <->
+  forall A B : Type, FunctionalChoice_on A B <->
     RelationalChoice_on A B /\ FunctionalRelReification_on A B.
 Proof.
-  intros A B; split.
+  intros A B. split.
   intro H; split;
     [ exact (funct_choice_imp_rel_choice H)
       | exact (funct_choice_imp_description H) ].
@@ -333,7 +340,7 @@ Qed.
 
 (** We show that the guarded formulations of the axiom of choice
    are equivalent to their "omniscient" variant and comes from the non guarded
-   formulation in presence either of the independance of general premises
+   formulation in presence either of the independence of general premises
    or subset types (themselves derivable from subtypes thanks to proof-
    irrelevance) *)
 
@@ -362,7 +369,7 @@ Proof.
 Qed.
 
 Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice :
-  forall A B, inhabited B -> RelationalChoice_on A B ->
+  forall A B : Type, inhabited B -> RelationalChoice_on A B ->
     IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B.
 Proof.
   intros A B Inh AC_rel IndPrem P R H.
@@ -374,7 +381,7 @@ Proof.
 Qed.
 
 Lemma guarded_rel_choice_imp_rel_choice :
-  forall A B, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
+  forall A B : Type, GuardedRelationalChoice_on A B -> RelationalChoice_on A B.
 Proof.
   intros A B GAC_rel R H.
   destruct (GAC_rel (fun _ => True) R) as (R',(HR'R,H0)).
@@ -793,12 +800,13 @@ be applied on the same Type universes on both sides of the first
 Require Import Setoid.
 
 Theorem constructive_definite_descr_excluded_middle :
-  ConstructiveDefiniteDescription ->
+  (forall A : Type, ConstructiveDefiniteDescription_on A) ->
   (forall P:Prop, P \/ ~ P) -> (forall P:Prop, {P} + {~ P}).
 Proof.
   intros Descr EM P.
   pose (select := fun b:bool => if b then P else ~P).
   assert { b:bool | select b } as ([|],HP).
+  red in Descr.
   apply Descr.
   rewrite <- unique_existence; split.
   destruct (EM P).
@@ -814,14 +822,13 @@ Corollary fun_reification_descr_computational_excluded_middle_in_prop_context :
   (forall P:Prop, P \/ ~ P) ->
   forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
 Proof.
-  intros FunReify EM C H.
-  apply relative_non_contradiction_of_definite_descr; trivial.
-  auto using constructive_definite_descr_excluded_middle.
+  intros FunReify EM C H. intuition auto using
+    constructive_definite_descr_excluded_middle,
+    (relative_non_contradiction_of_definite_descr (C:=C)).
 Qed.
 
 (**********************************************************************)
 (** * Choice => Dependent choice => Countable choice *)
-
 (* The implications below are standard *)
 
 Require Import Arith.
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index 6085594b..600db472 100644
--- a/theories/Logic/Classical.v
+++ b/theories/Logic/Classical.v
@@ -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/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index ba7e87d1..07153b35 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -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/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index 7d79913a..bdad50e2 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -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/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
index 161db112..2d9a1ffd 100644
--- a/theories/Logic/ClassicalEpsilon.v
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index c6e140f5..6f736e45 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -339,8 +339,8 @@ Section Proof_irrelevance_EM_CC.
 
   (** [p2b] and [b2p] form a retract if [~b1=b2] *)
 
-  Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
-  Definition b2p b := b1 = b.
+  Let p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A).
+  Let b2p b := b1 = b.
 
   Lemma p2p1 : forall A:Prop, A -> b2p (p2b A).
   Proof.
@@ -367,16 +367,90 @@ Section Proof_irrelevance_EM_CC.
   Proof.
     refine (or_elim _ _ _ _ _ (em (b1 = b2))); intro H.
     trivial.
-    apply (paradox B p2b b2p (p2p2 H) p2p1).
+    apply (NoRetractFromSmallPropositionToProp.paradox B p2b b2p (p2p2 H) p2p1).
   Qed.
 
 End Proof_irrelevance_EM_CC.
 
-(** Remark: Hurkens' paradox still holds with a retract from the
-    _negative_ fragment of [Prop] into [bool], hence weak classical
-    logic, i.e. [forall A, ~A\/~~A], is enough for deriving
-    proof-irrelevance.
-*)
+(** Hurkens' paradox still holds with a retract from the _negative_
+    fragment of [Prop] into [bool], hence weak classical logic,
+    i.e. [forall A, ~A\/~~A], is enough for deriving a weak version of
+    proof-irrelevance. This is enough to derive a contradiction from a
+    [Set]-bound weak excluded middle wih an impredicative [Set]
+    universe. *)
+
+Section Proof_irrelevance_WEM_CC.
+
+  Variable or : Prop -> Prop -> Prop.
+  Variable or_introl : forall A B:Prop, A -> or A B.
+  Variable or_intror : forall A B:Prop, B -> or A B.
+  Hypothesis or_elim : forall A B C:Prop, (A -> C) -> (B -> C) -> or A B -> C.
+  Hypothesis
+    or_elim_redl :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (a:A),
+      f a = or_elim A B C f g (or_introl A B a).
+  Hypothesis
+    or_elim_redr :
+    forall (A B C:Prop) (f:A -> C) (g:B -> C) (b:B),
+      g b = or_elim A B C f g (or_intror A B b).
+  Hypothesis
+    or_dep_elim :
+    forall (A B:Prop) (P:or A B -> Prop),
+      (forall a:A, P (or_introl A B a)) ->
+      (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b.
+
+  Hypothesis wem : forall A:Prop, or (~~A) (~ A).
+
+  Local Notation NProp := NoRetractToNegativeProp.NProp.
+  Local Notation El := NoRetractToNegativeProp.El.
+  
+  Variable B : Prop.
+  Variables b1 b2 : B.
+
+  (** [p2b] and [b2p] form a retract if [~b1=b2] *)
+
+  Let p2b (A:NProp) := or_elim (~~El A) (~El A) B (fun _ => b1) (fun _ => b2) (wem (El A)).
+  Let b2p b : NProp := exist (fun P=>~~P -> P) (~~(b1 = b)) (fun h x => h (fun k => k x)).
+
+  Lemma wp2p1 : forall A:NProp, El A -> El (b2p (p2b A)).
+  Proof.
+    intros A. unfold p2b.
+    apply or_dep_elim with  (b := wem (El A)).
+    + intros nna a.
+      rewrite <- or_elim_redl.
+      cbn. auto.
+    + intros n x.
+      destruct (n x).
+  Qed.
+
+  Lemma wp2p2 : b1 <> b2 -> forall A:NProp, El (b2p (p2b A)) -> El A.
+  Proof.
+    intro not_eq_b1_b2.
+    intros A. unfold p2b.
+    apply or_dep_elim with  (b := wem (El A)).
+    + cbn.
+      intros x _.
+      destruct A. cbn in x |- *.
+      auto.
+    + intros na.
+      rewrite <- or_elim_redr. cbn.
+      intros h. destruct (h not_eq_b1_b2).
+  Qed.
+
+  (** By Hurkens's paradox, we get a weak form of proof irrelevance. *)
+
+  Theorem wproof_irrelevance_cc : ~~(b1 = b2).
+  Proof.
+    intros h.
+    refine (let NB := exist (fun P=>~~P -> P) B _ in _).
+    { exact (fun _ => b1). }
+    pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox.
+    refine (let F := exist (fun P=>~~P->P) False _ in _).
+    { auto. }
+    exact (paradox F).
+  Qed.
+
+End Proof_irrelevance_WEM_CC.
 
 (************************************************************************)
 (** ** CIC |- excluded-middle -> proof-irrelevance               *)
@@ -405,6 +479,23 @@ Section Proof_irrelevance_CCI.
 
 End Proof_irrelevance_CCI.
 
+(** The same holds with weak excluded middle. The proof is a little
+    more involved, however. *)
+
+
+
+Section Weak_proof_irrelevance_CCI.
+
+  Hypothesis wem : forall A:Prop, ~~A \/ ~ A.
+
+  Theorem wem_proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), ~~b1 = b2.
+  Proof.
+    exact (wproof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl
+      or_elim_redr or_indd wem).
+  Qed.
+
+End Weak_proof_irrelevance_CCI.
+
 (** Remark: in the Set-impredicative CCI, Hurkens' paradox still holds with
     [bool] in [Set] and since [~true=false] for [true] and [false]
     in [bool] from [Set], we get the inconsistency of
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
index 1cdff497..4b0ec15e 100644
--- a/theories/Logic/ClassicalUniqueChoice.v
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -42,8 +42,8 @@ intros A B.
 apply (dependent_unique_choice A (fun _ => B)).
 Qed.
 
-(** The following proof comes from [[ChicliPottierSimpson02]] *)
 
+(** The following proof comes from [[ChicliPottierSimpson02]] *)
 Require Import Setoid.
 
 Theorem classic_set_in_prop_context :
@@ -78,7 +78,7 @@ destruct (f P).
   right.
   destruct HfP as [[_ Hfalse]| [Hna _]].
     discriminate.
-    assumption.
+    assumption. 
 Qed.
 
 Corollary not_not_classic_set :
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
deleted file mode 100644
index d634217f..00000000
--- a/theories/Logic/Classical_Pred_Set.v
+++ /dev/null
@@ -1,48 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* File created for Coq V5.10.14b, Oct 1995, by duplication of
-   Classical_Pred_Type.v *)
-
-(** This file is obsolete, use Classical_Pred_Type.v via Classical.v
-instead *)
-
-(** Classical Predicate Logic on Set*)
-
-Require Import Classical_Pred_Type.
-
-Section Generic.
-Variable U : Set.
-
-(** de Morgan laws for quantifiers *)
-
-Lemma not_all_ex_not :
- forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
-Proof (Classical_Pred_Type.not_all_ex_not U).
-
-Lemma not_all_not_ex :
- forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
-Proof (Classical_Pred_Type.not_all_not_ex U).
-
-Lemma not_ex_all_not :
- forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
-Proof (Classical_Pred_Type.not_ex_all_not U).
-
-Lemma not_ex_not_all :
- forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
-Proof (Classical_Pred_Type.not_ex_not_all U).
-
-Lemma ex_not_not_all :
- forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
-Proof (Classical_Pred_Type.ex_not_not_all U).
-
-Lemma all_not_not_ex :
- forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
-Proof (Classical_Pred_Type.all_not_not_ex U).
-
-End Generic.
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
index 78eae431..8468ced3 100644
--- a/theories/Logic/Classical_Pred_Type.v
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -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/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index 7fbd6da8..be75c4e9 100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -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/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v
index 7403208a..6f5bfae4 100644
--- a/theories/Logic/ConstructiveEpsilon.v
+++ b/theories/Logic/ConstructiveEpsilon.v
@@ -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        *)
@@ -51,9 +51,9 @@ Hypothesis P_dec : forall n, {P n}+{~(P n)}.
 any number before any witness (not necessarily the [x] of [exists x :A, P x])
 makes the search eventually stops. *)
 
-Inductive before_witness : nat -> Prop :=
-  | stop : forall n, P n -> before_witness n
-  | next : forall n, before_witness (S n) -> before_witness n.
+Inductive before_witness (n:nat) : Prop :=
+  | stop : P n -> before_witness n
+  | next : before_witness (S n) -> before_witness n.
 
 (* Computation of the initial termination certificate *)
 Fixpoint O_witness (n : nat) : before_witness n -> before_witness 0 :=
@@ -67,9 +67,9 @@ is structurally smaller even in the [stop] case. *)
 Definition inv_before_witness :
   forall n, before_witness n -> ~(P n) -> before_witness (S n) :=
   fun n b =>
-    match b in before_witness n return ~ P n -> before_witness (S n) with
-      | stop n p => fun not_p => match (not_p p) with end
-      | next n b => fun _ => b
+    match b return ~ P n -> before_witness (S n) with
+      | stop _ p => fun not_p => match (not_p p) with end
+      | next _ b => fun _ => b
     end.
 
 Fixpoint linear_search m (b : before_witness m) : {n : nat | P n} :=
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index 3724d8e2..545f92bd 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -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        *)
@@ -175,7 +175,16 @@ Proof.
 unfold decidable. tauto.
 Qed.
 
+(* Functional relations on decidable co-domains are decidable *)
 
+Theorem dec_functional_relation :
+  forall (X Y : Type) (A:X->Y->Prop), (forall y y' : Y, decidable (y=y')) ->
+  (forall x, exists! y, A x y) -> forall x y, decidable (A x y).
+Proof.
+intros X Y A Hdec H x y.
+destruct (H x) as (y',(Hex,Huniq)).
+destruct (Hdec y y') as [->|Hnot]; firstorder.
+Qed.
 
 (** With the following hint database, we can leverage [auto] to check
     decidability of propositions. *)
diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v
index 69ed908f..70cc0787 100644
--- a/theories/Logic/Description.v
+++ b/theories/Logic/Description.v
@@ -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        *)
 (************************************************************************)
 
 (** This file provides a constructive form of definite description; it
-    allows to build functions from the proof of their existence in any
+    allows building functions from the proof of their existence in any
     context; this is weaker than Church's iota operator *)
 
 Require Import ChoiceFacts.
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 71458647..64517354 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -99,7 +99,7 @@ Lemma AC_bool_subset_to_bool :
 Proof.
   destruct (guarded_rel_choice _ _
    (fun Q:bool -> Prop =>  exists y : _, Q y)
-   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
+   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). 
     exact (fun _ H => H).
   exists R; intros P HP.
   destruct (HR P HP) as (y,(Hy,Huni)).
@@ -113,23 +113,23 @@ Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
 Proof.
 intro P.
 
-(** first we exhibit the choice functional relation R *)
+(* first we exhibit the choice functional relation R *)
 destruct AC_bool_subset_to_bool as [R H].
 
 set (class_of_true := fun b => b = true \/ P).
 set (class_of_false := fun b => b = false \/ P).
 
-(** the actual "decision": is (R class_of_true) = true or false? *)
+(* the actual "decision": is (R class_of_true) = true or false? *)
 destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
 exists true; left; reflexivity.
 destruct H0.
 
-(** the actual "decision": is (R class_of_false) = true or false? *)
+(* the actual "decision": is (R class_of_false) = true or false? *)
 destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
 exists false; left; reflexivity.
 destruct H1.
 
-(** case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
+(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
 right.
 intro HP.
 assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
@@ -145,7 +145,7 @@ rewrite <- H0''. reflexivity.
 rewrite Heq.
 assumption.
 
-(** cases where P is true *)
+(* cases where P is true *)
 left; assumption.
 left; assumption.
 
@@ -154,7 +154,7 @@ Qed.
 End PredExt_RelChoice_imp_EM.
 
 (**********************************************************************)
-(** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)
+(** * Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)
 
 (** This is an adaptation of Diaconescu's theorem, exploiting the
     form of extensionality provided by proof-irrelevance *)
@@ -172,7 +172,7 @@ Variables a1 a2 : A.
 
 (** We build the subset [A'] of [A] made of [a1] and [a2] *)
 
-Definition A' := sigT (fun x => x=a1 \/ x=a2).
+Definition A' := @sigT A (fun x => x=a1 \/ x=a2).
 
 Definition a1':A'.
 exists a1 ; auto.
diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v
index e4663604..fe17cde4 100644
--- a/theories/Logic/Epsilon.v
+++ b/theories/Logic/Epsilon.v
@@ -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/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index e6c38c77..d9ffe68d 100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v
index c0fc0d72..34aba486 100644
--- a/theories/Logic/EqdepFacts.v
+++ b/theories/Logic/EqdepFacts.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -52,6 +52,8 @@ Table of contents:
 
 Import EqNotations.
 
+(* Set Universe Polymorphism. *)
+
 Section Dependent_Equality.
 
   Variable U : Type.
@@ -140,7 +142,7 @@ Qed.
 Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing). (* Compat *)
 
 Lemma eq_sig_eq_dep :
-  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
     exist P p x = exist P q y -> eq_dep p x q y.
 Proof.
   intros.
@@ -149,24 +151,25 @@ Proof.
 Qed.
 
 Lemma eq_dep_eq_sig :
-  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
     eq_dep p x q y -> exist P p x = exist P q y.
 Proof.
   destruct 1; reflexivity.
 Qed.
 
 Lemma eq_sig_iff_eq_dep :
-  forall (U:Prop) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
+  forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
     exist P p x = exist P q y <-> eq_dep p x q y.
 Proof.
   split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
 Qed.
 
-(** Dependent equality is equivalent to a dependent pair of equalities *)
+(** Dependent equality is equivalent tco a dependent pair of equalities *)
 
 Set Implicit Arguments.
 
-Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}.
+Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <->
+                                                   {H:x1=x2 | rew H in H1 = H2}.
 Proof.
   intros; split; intro H.
   - change x2 with (projT1 (existT P x2 H2)).
@@ -234,82 +237,113 @@ Section Equivalences.
 
   (** Invariance by Substitution of Reflexive Equality Proofs *)
 
-  Definition Eq_rect_eq :=
-    forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
+  Definition Eq_rect_eq_on (p : U) (Q : U -> Type) (x : Q p) :=
+    forall (h : p = p), x = eq_rect p Q x p h.
+  Definition Eq_rect_eq := forall p Q x, Eq_rect_eq_on p Q x.
 
   (** Injectivity of Dependent Equality *)
 
-  Definition Eq_dep_eq :=
-    forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
+  Definition Eq_dep_eq_on (P : U -> Type) (p : U) (x : P p) :=
+    forall (y : P p), eq_dep p x p y -> x = y.
+  Definition Eq_dep_eq := forall P p x, Eq_dep_eq_on P p x.
 
   (** Uniqueness of Identity Proofs (UIP) *)
 
-  Definition UIP_ :=
-    forall (x y:U) (p1 p2:x = y), p1 = p2.
+  Definition UIP_on_ (x y : U) (p1 : x = y) :=
+    forall (p2 : x = y), p1 = p2.
+  Definition UIP_ := forall x y p1, UIP_on_ x y p1.
 
   (** Uniqueness of Reflexive Identity Proofs *)
 
-  Definition UIP_refl_ :=
-    forall (x:U) (p:x = x), p = eq_refl x.
+  Definition UIP_refl_on_ (x : U) :=
+    forall (p : x = x), p = eq_refl x.
+  Definition UIP_refl_ := forall x, UIP_refl_on_ x.
 
   (** Streicher's axiom K *)
 
-  Definition Streicher_K_ :=
-    forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
+  Definition Streicher_K_on_ (x : U) (P : x = x -> Prop) :=
+    P (eq_refl x) -> forall p : x = x, P p.
+  Definition Streicher_K_ := forall x P, Streicher_K_on_ x P.
 
   (** Injectivity of Dependent Equality is a consequence of *)
   (** Invariance by Substitution of Reflexive Equality Proof *)
 
-  Lemma eq_rect_eq__eq_dep1_eq :
-    Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
+  Lemma eq_rect_eq_on__eq_dep1_eq_on (p : U) (P : U -> Type) (y : P p) :
+    Eq_rect_eq_on p P y -> forall (x : P p), eq_dep1 p x p y -> x = y.
   Proof.
     intro eq_rect_eq.
     simple destruct 1; intro.
     rewrite <- eq_rect_eq; auto.
   Qed.
+  Lemma eq_rect_eq__eq_dep1_eq :
+    Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
+  Proof (fun eq_rect_eq P p y x =>
+           @eq_rect_eq_on__eq_dep1_eq_on p P x (eq_rect_eq p P x) y).
 
-  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
+  Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) :
+    Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x.
   Proof.
     intros eq_rect_eq; red; intros.
-    apply (eq_rect_eq__eq_dep1_eq eq_rect_eq); apply eq_dep_dep1; trivial.
+    symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq).
+    apply eq_dep_sym in H; apply eq_dep_dep1; trivial.
   Qed.
+  Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
+  Proof (fun eq_rect_eq P p x y =>
+           @eq_rect_eq_on__eq_dep_eq_on p P x (eq_rect_eq p P x) y).
 
   (** Uniqueness of Identity Proofs (UIP) is a consequence of *)
   (** Injectivity of Dependent Equality *)
 
-  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
+  Lemma eq_dep_eq_on__UIP_on (x y : U) (p1 : x = y) :
+    Eq_dep_eq_on (fun y => x = y) x eq_refl -> UIP_on_ x y p1.
   Proof.
     intro eq_dep_eq; red.
-    intros; apply eq_dep_eq with (P := fun y => x = y).
-    elim p2 using eq_indd.
     elim p1 using eq_indd.
+    intros; apply eq_dep_eq.
+    elim p2 using eq_indd.
     apply eq_dep_intro.
   Qed.
+  Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
+  Proof (fun eq_dep_eq x y p1 =>
+           @eq_dep_eq_on__UIP_on x y p1 (eq_dep_eq _ _ _)).
 
   (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *)
 
-  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
+  Lemma UIP_on__UIP_refl_on (x : U) :
+    UIP_on_ x x eq_refl -> UIP_refl_on_ x.
   Proof.
-    intro UIP; red; intros; apply UIP.
+    intro UIP; red; intros; symmetry; apply UIP.
   Qed.
+  Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
+  Proof (fun UIP x p =>
+           @UIP_on__UIP_refl_on x (UIP x x eq_refl) p).
 
   (** Streicher's axiom K is a direct consequence of Uniqueness of
       Reflexive Identity Proofs *)
 
-  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
+  Lemma UIP_refl_on__Streicher_K_on (x : U) (P : x = x -> Prop) :
+    UIP_refl_on_ x -> Streicher_K_on_ x P.
   Proof.
     intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
   Qed.
+  Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
+  Proof (fun UIP_refl x P =>
+           @UIP_refl_on__Streicher_K_on x P (UIP_refl x)).
 
   (** We finally recover from K the Invariance by Substitution of
       Reflexive Equality Proofs *)
 
-  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
+  Lemma Streicher_K_on__eq_rect_eq_on (p : U) (P : U -> Type) (x : P p) :
+    Streicher_K_on_ p (fun h => x = rew -> [P] h in x)
+    -> Eq_rect_eq_on p P x.
   Proof.
     intro Streicher_K; red; intros.
-    apply Streicher_K with (p := h).
+    apply Streicher_K.
     reflexivity.
   Qed.
+  Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
+  Proof (fun Streicher_K p P x =>
+           @Streicher_K_on__eq_rect_eq_on p P x (Streicher_K p _)).
 
 (** Remark: It is reasonable to think that [eq_rect_eq] is strictly
     stronger than [eq_rec_eq] (which is [eq_rect_eq] restricted on [Set]):
@@ -317,7 +351,7 @@ Section Equivalences.
    [Definition Eq_rec_eq :=
       forall (P:U -> Set) (p:U) (x:P p) (h:p = p), x = eq_rec p P x p h.]
 
-    Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what
+    Typically, [eq_rect_eq] allows proving UIP and Streicher's K what
     does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP]
     requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not
     in [Set].
@@ -325,22 +359,55 @@ Section Equivalences.
 
 End Equivalences.
 
+(** UIP_refl is downward closed (a short proof of the key lemma of Voevodsky's
+    proof of inclusion of h-level n into h-level n+1; see hlevelntosn
+    in https://github.com/vladimirias/Foundations.git). *)
+
+Theorem UIP_shift_on (X : Type) (x : X) :
+  UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y.
+Proof.
+  intros UIP_refl y.
+  rewrite (UIP_refl y).
+  intros z.
+  assert (UIP:forall y' y'' : x = x, y' = y'').
+  { intros. apply eq_trans with (eq_refl x). apply UIP_refl.
+    symmetry. apply UIP_refl. }
+  transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
+                         (eq_sym (UIP (eq_refl x) (eq_refl x)))).
+  - destruct z. destruct (UIP _ _). reflexivity.
+  - change
+      (match eq_refl x as y' in _ = x' return y' = y' -> Prop with
+       | eq_refl => fun z => z = (eq_refl (eq_refl x))
+       end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
+                     (eq_sym (UIP (eq_refl x) (eq_refl x))))).
+    destruct z. destruct (UIP _ _). reflexivity.
+Qed.
+Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x).
+Proof (fun U UIP_refl x =>
+         @UIP_shift_on U x (UIP_refl x)).
+
 Section Corollaries.
 
   Variable U:Type.
 
   (** UIP implies the injectivity of equality on dependent pairs in Type *)
 
- Definition Inj_dep_pair :=
-   forall (P:U -> Type) (p:U) (x y:P p), existT P p x = existT P p y -> x = y.
 
- Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
+ Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) :=
+   forall (y : P p), existT P p x = existT P p y -> x = y.
+ Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x.
+
+ Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) :
+   Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x.
  Proof.
    intro eq_dep_eq; red; intros.
    apply eq_dep_eq.
    apply eq_sigT_eq_dep.
    assumption.
  Qed.
+ Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
+ Proof (fun eq_dep_eq P p x =>
+          @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x)).
 
 End Corollaries.
 
@@ -412,5 +479,27 @@ Notation inj_pairT2 := inj_pair2.
 
 End EqdepTheory.
 
+(** Basic facts about eq_dep *)
+
+Lemma f_eq_dep :
+  forall U (P:U->Type) R p q x y (f:forall p, P p -> R p),
+    eq_dep p x q y -> eq_dep p (f p x) q (f q y).
+Proof.
+intros * []. reflexivity.
+Qed.
+
+Lemma eq_dep_non_dep :
+  forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y.
+Proof.
+intros * []. reflexivity.
+Qed.
+
+Lemma f_eq_dep_non_dep :
+  forall U (P:U->Type) R p q x y (f:forall p, P p -> R),
+    eq_dep p x q y -> f p x = f q y.
+Proof.
+intros * []. reflexivity.
+Qed.
+
 Arguments eq_dep  U P p x q _ : clear implicits.
 Arguments eq_dep1 U P p x q y : clear implicits.
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
index 015c7a5f..65011e8e 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -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        *)
@@ -35,6 +35,7 @@ Table of contents:
 (** * Streicher's K and injectivity of dependent pair hold on decidable types *)
 
 Set Implicit Arguments.
+(* Set Universe Polymorphism. *)
 
 Section EqdepDec.
 
@@ -49,12 +50,12 @@ Section EqdepDec.
     case u; trivial.
   Qed.
 
-  Variable eq_dec : forall x y:A, x = y \/ x <> y.
-
   Variable x : A.
 
+  Variable eq_dec : forall y:A, x = y \/ x <> y.
+
   Let nu (y:A) (u:x = y) : x = y :=
-    match eq_dec x y with
+    match eq_dec y with
       | or_introl eqxy => eqxy
       | or_intror neqxy => False_ind _ (neqxy u)
     end.
@@ -62,17 +63,17 @@ Section EqdepDec.
   Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v.
     intros.
     unfold nu.
-    case (eq_dec x y); intros.
+    destruct (eq_dec y) as [Heq|Hneq].
     reflexivity.
 
-    case n; trivial.
+    case Hneq; trivial.
   Qed.
 
 
   Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v.
 
 
-  Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u.
+  Remark nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u.
   Proof.
     intros.
     case u; unfold nu_inv.
@@ -80,20 +81,20 @@ Section EqdepDec.
   Qed.
 
 
-  Theorem eq_proofs_unicity : forall (y:A) (p1 p2:x = y), p1 = p2.
+  Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2.
   Proof.
     intros.
-    elim nu_left_inv with (u := p1).
-    elim nu_left_inv with (u := p2).
+    elim nu_left_inv_on with (u := p1).
+    elim nu_left_inv_on with (u := p2).
     elim nu_constant with y p1 p2.
     reflexivity.
   Qed.
 
-  Theorem K_dec :
+  Theorem K_dec_on :
     forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
   Proof.
     intros.
-    elim eq_proofs_unicity with x (eq_refl x) p.
+    elim eq_proofs_unicity_on with x (eq_refl x) p.
     trivial.
   Qed.
 
@@ -101,27 +102,26 @@ Section EqdepDec.
 
   Let proj (P:A -> Prop) (exP:ex P) (def:P x) : P x :=
     match exP with
-      | ex_intro x' prf =>
-        match eq_dec x' x with
-          | or_introl eqprf => eq_ind x' P prf x eqprf
+      | ex_intro _ x' prf =>
+        match eq_dec x' with
+          | or_introl eqprf => eq_ind x' P prf x (eq_sym eqprf)
           | _ => def
         end
     end.
 
 
-  Theorem inj_right_pair :
+  Theorem inj_right_pair_on :
     forall (P:A -> Prop) (y y':P x),
       ex_intro P x y = ex_intro P x y' -> y = y'.
   Proof.
     intros.
     cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y).
     simpl.
-    case (eq_dec x x).
-    intro e.
-    elim e using K_dec; trivial.
+    destruct (eq_dec x) as [Heq|Hneq].
+    elim Heq using K_dec_on; trivial.
 
     intros.
-    case n; trivial.
+    case Hneq; trivial.
 
     case H.
     reflexivity.
@@ -129,6 +129,28 @@ Section EqdepDec.
 
 End EqdepDec.
 
+(** Now we prove the versions that require decidable equality for the entire type
+    rather than just on the given element.  The rest of the file uses this total
+    decidable equality.  We could do everything using decidable equality at a point
+    (because the induction rule for [eq] is really an induction rule for
+    [{ y : A | x = y }]), but we don't currently, because changing everything
+    would break backward compatibility and no-one has yet taken the time to define
+    the pointed versions, and then re-define the non-pointed versions in terms of
+    those. *)
+
+Theorem eq_proofs_unicity A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
+: forall (y:A) (p1 p2:x = y), p1 = p2.
+Proof (@eq_proofs_unicity_on A x (eq_dec x)).
+
+Theorem K_dec A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
+: forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p.
+Proof (@K_dec_on A x (eq_dec x)).
+
+Theorem inj_right_pair A (eq_dec : forall x y : A, x = y \/ x <> y) (x : A)
+: forall (P:A -> Prop) (y y':P x),
+    ex_intro P x y = ex_intro P x y' -> y = y'.
+Proof (@inj_right_pair_on A x (eq_dec x)).
+
 Require Import EqdepFacts.
 
 (** We deduce axiom [K] for (decidable) types *)
@@ -181,7 +203,7 @@ Unset Implicit Arguments.
 
 Module Type DecidableType.
 
-  Parameter U:Type.
+  Monomorphic Parameter U:Type.
   Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.
 
 End DecidableType.
@@ -249,7 +271,7 @@ End DecidableEqDep.
 
 Module Type DecidableSet.
 
-  Parameter U:Type.
+  Parameter U:Set.
   Axiom eq_dec : forall x y:U, {x = y} + {x <> y}.
 
 End DecidableSet.
@@ -272,23 +294,23 @@ Module DecidableEqDepSet (M:DecidableSet).
 
   Theorem eq_dep_eq :
     forall (P:U->Type) (p:U) (x y:P p), eq_dep U P p x p y -> x = y.
-  Proof N.eq_dep_eq.
+  Proof (eq_rect_eq__eq_dep_eq U eq_rect_eq).
 
   (** Uniqueness of Identity Proofs (UIP) *)
 
   Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
-  Proof N.UIP.
+  Proof (eq_dep_eq__UIP U eq_dep_eq).
 
   (** Uniqueness of Reflexive Identity Proofs *)
 
   Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
-  Proof N.UIP_refl.
+  Proof (UIP__UIP_refl U UIP).
 
   (** Streicher's axiom K *)
 
   Lemma Streicher_K :
     forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
-  Proof N.Streicher_K.
+  Proof (K_dec_type eq_dec).
 
   (** Proof-irrelevance on subsets of decidable sets *)
 
@@ -318,7 +340,53 @@ Proof.
   intros A eq_dec.
   apply eq_dep_eq__inj_pair2.
   apply eq_rect_eq__eq_dep_eq.
-  unfold Eq_rect_eq.
-  apply eq_rect_eq_dec.
+  unfold Eq_rect_eq, Eq_rect_eq_on.
+  intros; apply eq_rect_eq_dec.
   apply eq_dec.
 Qed.
+
+  (** Examples of short direct proofs of unicity of reflexivity proofs
+      on specific domains *)
+
+Lemma UIP_refl_unit (x : tt = tt) : x = eq_refl tt.
+Proof.
+  change (match tt as b return tt = b -> Prop with
+          | tt => fun x => x = eq_refl tt
+          end x).
+  destruct x; reflexivity.
+Defined.
+
+Lemma UIP_refl_bool (b:bool) (x : b = b) : x = eq_refl.
+Proof.
+  destruct b.
+  - change (match true as b return true=b -> Prop with
+            | true => fun x => x = eq_refl
+            | _ => fun _ => True
+            end x).
+    destruct x; reflexivity.
+  - change (match false as b return false=b -> Prop with
+            | false => fun x => x = eq_refl
+            | _ => fun _ => True
+            end x).
+    destruct x; reflexivity.
+Defined.
+
+Lemma UIP_refl_nat (n:nat) (x : n = n) : x = eq_refl.
+Proof.
+  induction n.
+  - change (match 0 as n return 0=n -> Prop with
+            | 0 => fun x => x = eq_refl
+            | _ => fun _ => True
+            end x).
+    destruct x; reflexivity.
+  - specialize IHn with (f_equal pred x).
+    change eq_refl with (f_equal S (@eq_refl _ n)).
+    rewrite <- IHn; clear IHn.
+    change (match S n as n' return S n = n' -> Prop with
+            | 0 => fun _ => True
+            | S n' => fun x =>
+                x = f_equal S (f_equal pred x)
+            end x).
+  pattern (S n) at 2 3, x.
+  destruct x; reflexivity.
+Defined.
diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v
index 27fb147f..61ee9eb9 100644
--- a/theories/Logic/ExtensionalityFacts.v
+++ b/theories/Logic/ExtensionalityFacts.v
@@ -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/theories/Logic/FinFun.v b/theories/Logic/FinFun.v
new file mode 100644
index 00000000..670aa219
--- /dev/null
+++ b/theories/Logic/FinFun.v
@@ -0,0 +1,400 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Functions on finite domains *)
+
+(** Main result : for functions [f:A->A] with finite [A],
+    f injective <-> f bijective <-> f surjective. *)
+
+Require Import List Compare_dec EqNat Decidable ListDec. Require Fin.
+Set Implicit Arguments.
+
+(** General definitions *)
+
+Definition Injective {A B} (f : A->B) :=
+ forall x y, f x = f y -> x = y.
+
+Definition Surjective {A B} (f : A->B) :=
+ forall y, exists x, f x = y.
+
+Definition Bijective {A B} (f : A->B) :=
+ exists g:B->A, (forall x, g (f x) = x) /\ (forall y, f (g y) = y).
+
+(** Finiteness is defined here via exhaustive list enumeration *)
+
+Definition Full {A:Type} (l:list A) := forall a:A, In a l.
+Definition Finite (A:Type) := exists (l:list A), Full l.
+
+(** In many following proofs, it will be convenient to have
+    list enumerations without duplicates. As soon as we have
+    decidability of equality (in Prop), this is equivalent
+    to the previous notion. *)
+
+Definition Listing {A:Type} (l:list A) := NoDup l /\ Full l.
+Definition Finite' (A:Type) := exists (l:list A), Listing l.
+
+Lemma Finite_alt A (d:decidable_eq A) : Finite A <-> Finite' A.
+Proof.
+ split.
+ - intros (l,F). destruct (uniquify d l) as (l' & N & I).
+   exists l'. split; trivial.
+   intros x. apply I, F.
+ - intros (l & _ & F). now exists l.
+Qed.
+
+(** Injections characterized in term of lists *)
+
+Lemma Injective_map_NoDup A B (f:A->B) (l:list A) :
+ Injective f -> NoDup l -> NoDup (map f l).
+Proof.
+ intros Ij. induction 1 as [|x l X N IH]; simpl; constructor; trivial.
+ rewrite in_map_iff. intros (y & E & Y). apply Ij in E. now subst.
+Qed.
+
+Lemma Injective_list_carac A B (d:decidable_eq A)(f:A->B) :
+  Injective f <-> (forall l, NoDup l -> NoDup (map f l)).
+Proof.
+ split.
+ - intros. now apply Injective_map_NoDup.
+ - intros H x y E.
+   destruct (d x y); trivial.
+   assert (N : NoDup (x::y::nil)).
+   { repeat constructor; simpl; intuition. }
+   specialize (H _ N). simpl in H. rewrite E in H.
+   inversion_clear H; simpl in *; intuition.
+Qed.
+
+Lemma Injective_carac A B (l:list A) : Listing l ->
+   forall (f:A->B), Injective f <-> NoDup (map f l).
+Proof.
+ intros L f. split.
+ - intros Ij. apply Injective_map_NoDup; trivial. apply L.
+ - intros N x y E.
+   assert (X : In x l) by apply L.
+   assert (Y : In y l) by apply L.
+   apply In_nth_error in X. destruct X as (i,X).
+   apply In_nth_error in Y. destruct Y as (j,Y).
+   assert (X' := map_nth_error f _ _ X).
+   assert (Y' := map_nth_error f _ _ Y).
+   assert (i = j).
+   { rewrite NoDup_nth_error in N. apply N.
+     - rewrite <- nth_error_Some. now rewrite X'.
+     - rewrite X', Y'. now f_equal. }
+   subst j. rewrite Y in X. now injection X.
+Qed.
+
+(** Surjection characterized in term of lists *)
+
+Lemma Surjective_list_carac A B (f:A->B):
+  Surjective f <-> (forall lB, exists lA, incl lB (map f lA)).
+Proof.
+ split.
+ - intros Su.
+   induction lB as [|b lB IH].
+   + now exists nil.
+   + destruct (Su b) as (a,E).
+     destruct IH as (lA,IC).
+     exists (a::lA). simpl. rewrite E.
+     intros x [X|X]; simpl; intuition.
+ - intros H y.
+   destruct (H (y::nil)) as (lA,IC).
+   assert (IN : In y (map f lA)) by (apply (IC y); now left).
+   rewrite in_map_iff in IN. destruct IN as (x & E & _).
+   now exists x.
+Qed.
+
+Lemma Surjective_carac A B : Finite B -> decidable_eq B ->
+  forall f:A->B, Surjective f <-> (exists lA, Listing (map f lA)).
+Proof.
+ intros (lB,FB) d. split.
+ - rewrite Surjective_list_carac.
+   intros Su. destruct (Su lB) as (lA,IC).
+   destruct (uniquify_map d f lA) as (lA' & N & IC').
+   exists lA'. split; trivial.
+   intro x. apply IC', IC, FB.
+ - intros (lA & N & FA) y.
+   generalize (FA y). rewrite in_map_iff. intros (x & E & _).
+   now exists x.
+Qed.
+
+(** Main result : *)
+
+Lemma Endo_Injective_Surjective :
+ forall A, Finite A -> decidable_eq A ->
+  forall f:A->A, Injective f <-> Surjective f.
+Proof.
+ intros A F d f. rewrite (Surjective_carac F d). split.
+ - apply (Finite_alt d) in F. destruct F as (l,L).
+   rewrite (Injective_carac L); intros.
+   exists l; split; trivial.
+   destruct L as (N,F).
+   assert (I : incl l (map f l)).
+   { apply NoDup_length_incl; trivial.
+     - now rewrite map_length.
+     - intros x _. apply F. }
+   intros x. apply I, F.
+ - clear F d. intros (l,L).
+   assert (N : NoDup l). { apply (NoDup_map_inv f), L. }
+   assert (I : incl (map f l) l).
+   { apply NoDup_length_incl; trivial.
+     - now rewrite map_length.
+     - intros x _. apply L. }
+   assert (L' : Listing l).
+   { split; trivial.
+     intro x. apply I, L. }
+   apply (Injective_carac L'), L.
+Qed.
+
+(** An injective and surjective function is bijective.
+    We need here stronger hypothesis : decidability of equality in Type. *)
+
+Definition EqDec (A:Type) := forall x y:A, {x=y}+{x<>y}.
+
+(** First, we show that a surjective f has an inverse function g such that
+    f.g = id. *)
+
+(* NB: instead of (Finite A), we could ask for (RecEnum A) with:
+Definition RecEnum A := exists h:nat->A, surjective h.
+*)
+
+Lemma Finite_Empty_or_not A :
+  Finite A -> (A->False) \/ exists a:A,True.
+Proof.
+ intros (l,F).
+ destruct l.
+ - left; exact F.
+ - right; now exists a.
+Qed.
+
+Lemma Surjective_inverse :
+  forall A B, Finite A -> EqDec B ->
+   forall f:A->B, Surjective f ->
+    exists g:B->A, forall x, f (g x) = x.
+Proof.
+ intros A B F d f Su.
+ destruct (Finite_Empty_or_not F) as [noA | (a,_)].
+ - (* A is empty : g is obtained via False_rect *)
+   assert (noB : B -> False). { intros y. now destruct (Su y). }
+   exists (fun y => False_rect _ (noB y)).
+   intro y. destruct (noB y).
+ - (* A is inhabited by a : we use it in Option.get *)
+   destruct F as (l,F).
+   set (h := fun x k => if d (f k) x then true else false).
+   set (get := fun o => match o with Some y => y | None => a end).
+   exists (fun x => get (List.find (h x) l)).
+   intros x.
+   case_eq (find (h x) l); simpl; clear get; [intros y H|intros H].
+   * apply find_some in H. destruct H as (_,H). unfold h in H.
+     now destruct (d (f y) x) in H.
+   * exfalso.
+     destruct (Su x) as (y & Y).
+     generalize (find_none _ l H y (F y)).
+     unfold h. now destruct (d (f y) x).
+Qed.
+
+(** Same, with more knowledge on the inverse function: g.f = f.g = id *)
+
+Lemma Injective_Surjective_Bijective :
+ forall A B, Finite A -> EqDec B ->
+  forall f:A->B, Injective f -> Surjective f -> Bijective f.
+Proof.
+ intros A B F d f Ij Su.
+ destruct (Surjective_inverse F d Su) as (g, E).
+ exists g. split; trivial.
+ intros y. apply Ij. now rewrite E.
+Qed.
+
+
+(** An example of finite type : [Fin.t] *)
+
+Lemma Fin_Finite n : Finite (Fin.t n).
+Proof.
+ induction n.
+ - exists nil.
+   red;inversion a.
+ - destruct IHn as (l,Hl).
+   exists (Fin.F1 :: map Fin.FS l).
+   intros a. revert n a l Hl.
+   refine (@Fin.caseS _ _ _); intros.
+   + now left.
+   + right. now apply in_map.
+Qed.
+
+(** Instead of working on a finite subset of nat, another
+    solution is to use restricted [nat->nat] functions, and
+    to consider them only below a certain bound [n]. *)
+
+Definition bFun n (f:nat->nat) := forall x, x < n -> f x < n.
+
+Definition bInjective n (f:nat->nat) :=
+ forall x y, x < n -> y < n -> f x = f y -> x = y.
+
+Definition bSurjective n (f:nat->nat) :=
+ forall y, y < n -> exists x, x < n /\ f x = y.
+
+(** We show that this is equivalent to the use of [Fin.t n]. *)
+
+Module Fin2Restrict.
+
+Notation n2f := Fin.of_nat_lt.
+Definition f2n {n} (x:Fin.t n) := proj1_sig (Fin.to_nat x).
+Definition f2n_ok n (x:Fin.t n) : f2n x < n := proj2_sig (Fin.to_nat x).
+Definition n2f_f2n : forall n x, n2f (f2n_ok x) = x := @Fin.of_nat_to_nat_inv.
+Definition f2n_n2f x n h : f2n (n2f h) = x := f_equal (@proj1_sig _ _) (@Fin.to_nat_of_nat x n h).
+Definition n2f_ext : forall x n h h', n2f h = n2f h' := @Fin.of_nat_ext.
+Definition f2n_inj : forall n x y, f2n x = f2n y -> x = y := @Fin.to_nat_inj.
+
+Definition extend n (f:Fin.t n -> Fin.t n) : (nat->nat) :=
+ fun x =>
+   match le_lt_dec n x with
+     | left _ => 0
+     | right h => f2n (f (n2f h))
+   end.
+
+Definition restrict n (f:nat->nat)(hf : bFun n f) : (Fin.t n -> Fin.t n) :=
+ fun x => let (x',h) := Fin.to_nat x in n2f (hf _ h).
+
+Ltac break_dec H :=
+ let H' := fresh "H" in
+ destruct le_lt_dec as [H'|H'];
+  [elim (Lt.le_not_lt _ _ H' H)
+  |try rewrite (n2f_ext H' H) in *; try clear H'].
+
+Lemma extend_ok n f : bFun n (@extend n f).
+Proof.
+ intros x h. unfold extend. break_dec h. apply f2n_ok.
+Qed.
+
+Lemma extend_f2n n f (x:Fin.t n) : extend f (f2n x) = f2n (f x).
+Proof.
+ generalize (n2f_f2n x). unfold extend, f2n, f2n_ok.
+ destruct (Fin.to_nat x) as (x',h); simpl.
+ break_dec h.
+ now intros ->.
+Qed.
+
+Lemma extend_n2f n f x (h:x<n) : n2f (extend_ok f h) = f (n2f h).
+Proof.
+ generalize (extend_ok f h). unfold extend in *. break_dec h. intros h'.
+ rewrite <- n2f_f2n. now apply n2f_ext.
+Qed.
+
+Lemma restrict_f2n n f hf (x:Fin.t n) :
+ f2n (@restrict n f hf x) = f (f2n x).
+Proof.
+ unfold restrict, f2n. destruct (Fin.to_nat x) as (x',h); simpl.
+ apply f2n_n2f.
+Qed.
+
+Lemma restrict_n2f n f hf x (h:x<n) :
+ @restrict n f hf (n2f h) = n2f (hf _ h).
+Proof.
+ unfold restrict. generalize (f2n_n2f h). unfold f2n.
+ destruct (Fin.to_nat (n2f h)) as (x',h'); simpl. intros ->.
+ now apply n2f_ext.
+Qed.
+
+Lemma extend_surjective n f :
+  bSurjective n (@extend n f) <-> Surjective f.
+Proof.
+ split.
+ - intros hf y.
+   destruct (hf _ (f2n_ok y)) as (x & h & Eq).
+   exists (n2f h).
+   apply f2n_inj. now rewrite <- Eq, <- extend_f2n, f2n_n2f.
+ - intros hf y hy.
+   destruct (hf (n2f hy)) as (x,Eq).
+   exists (f2n x).
+   split.
+   + apply f2n_ok.
+   + rewrite extend_f2n, Eq. apply f2n_n2f.
+Qed.
+
+Lemma extend_injective n f :
+  bInjective n (@extend n f) <-> Injective f.
+Proof.
+ split.
+ - intros hf x y Eq.
+   apply f2n_inj. apply hf; try apply f2n_ok.
+   now rewrite 2 extend_f2n, Eq.
+ - intros hf x y hx hy Eq.
+   rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal.
+   apply hf.
+   rewrite <- 2 extend_n2f.
+   generalize (extend_ok f hx) (extend_ok f hy).
+   rewrite Eq. apply n2f_ext.
+Qed.
+
+Lemma restrict_surjective n f h :
+  Surjective (@restrict n f h) <-> bSurjective n f.
+Proof.
+ split.
+ - intros hf y hy.
+   destruct (hf (n2f hy)) as (x,Eq).
+   exists (f2n x).
+   split.
+   + apply f2n_ok.
+   + rewrite <- (restrict_f2n h), Eq. apply f2n_n2f.
+ - intros hf y.
+   destruct (hf _ (f2n_ok y)) as (x & hx & Eq).
+   exists (n2f hx).
+   apply f2n_inj. now rewrite restrict_f2n, f2n_n2f.
+Qed.
+
+Lemma restrict_injective n f h :
+  Injective (@restrict n f h) <-> bInjective n f.
+Proof.
+ split.
+ - intros hf x y hx hy Eq.
+   rewrite <- (f2n_n2f hx), <- (f2n_n2f hy). f_equal.
+   apply hf.
+   rewrite 2 restrict_n2f.
+   generalize (h x hx) (h y hy).
+   rewrite Eq. apply n2f_ext.
+ - intros hf x y Eq.
+   apply f2n_inj. apply hf; try apply f2n_ok.
+   now rewrite <- 2 (restrict_f2n h), Eq.
+Qed.
+
+End Fin2Restrict.
+Import Fin2Restrict.
+
+(** We can now use Proof via the equivalence ... *)
+
+Lemma bInjective_bSurjective n (f:nat->nat) :
+ bFun n f -> (bInjective n f <-> bSurjective n f).
+Proof.
+ intros h.
+ rewrite <- (restrict_injective h), <- (restrict_surjective h).
+ apply Endo_Injective_Surjective.
+ - apply Fin_Finite.
+ - intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial.
+Qed.
+
+Lemma bSurjective_bBijective n (f:nat->nat) :
+ bFun n f -> bSurjective n f ->
+ exists g, bFun n g /\ forall x, x < n -> g (f x) = x /\ f (g x) = x.
+Proof.
+ intro hf.
+ rewrite <- (restrict_surjective hf). intros Su.
+ assert (Ij : Injective (restrict hf)).
+ { apply Endo_Injective_Surjective; trivial.
+   - apply Fin_Finite.
+   - intros x y. destruct (Fin.eq_dec x y); [left|right]; trivial. }
+ assert (Bi : Bijective (restrict hf)).
+ { apply Injective_Surjective_Bijective; trivial.
+   - apply Fin_Finite.
+   - exact Fin.eq_dec. }
+ destruct Bi as (g & Hg & Hg').
+ exists (extend g).
+ split.
+ - apply extend_ok.
+ - intros x Hx. split.
+   + now rewrite <- (f2n_n2f Hx), <- (restrict_f2n hf), extend_f2n, Hg.
+   + now rewrite <- (f2n_n2f Hx), extend_f2n, <- (restrict_f2n hf), Hg'.
+Qed.
diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v
index 7d7792d5..eb50a3aa 100644
--- a/theories/Logic/FunctionalExtensionality.v
+++ b/theories/Logic/FunctionalExtensionality.v
@@ -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        *)
@@ -19,6 +19,12 @@ Proof.
   auto.
 Qed.
 
+Lemma equal_f_dep : forall {A B} {f g : forall (x : A), B x},
+  f = g -> forall x, f x = g x.
+Proof.
+intros A B f g <- H; reflexivity.
+Qed.
+
 (** Statements of functional extensionality for simple and dependent functions. *)
 
 Axiom functional_extensionality_dep : forall {A} {B : A -> Type},
@@ -31,13 +37,35 @@ Proof.
   intros ; eauto using @functional_extensionality_dep.
 Qed.
 
+(** Extensionality of [forall]s follows from functional extensionality. *)
+Lemma forall_extensionality {A} {B C : A -> Type} (H : forall x : A, B x = C x)
+: (forall x, B x) = (forall x, C x).
+Proof.
+  apply functional_extensionality in H. destruct H. reflexivity.
+Defined.
+
+Lemma forall_extensionalityP {A} {B C : A -> Prop} (H : forall x : A, B x = C x)
+: (forall x, B x) = (forall x, C x).
+Proof.
+  apply functional_extensionality in H. destruct H. reflexivity.
+Defined.
+
+Lemma forall_extensionalityS {A} {B C : A -> Set} (H : forall x : A, B x = C x)
+: (forall x, B x) = (forall x, C x).
+Proof.
+  apply functional_extensionality in H. destruct H. reflexivity.
+Defined.
+
 (** Apply [functional_extensionality], introducing variable x. *)
 
 Tactic Notation "extensionality" ident(x) :=
   match goal with
     [ |- ?X = ?Y ] =>
     (apply (@functional_extensionality _ _ X Y) ||
-     apply (@functional_extensionality_dep _ _ X Y)) ; intro x
+     apply (@functional_extensionality_dep _ _ X Y) ||
+     apply forall_extensionalityP ||
+     apply forall_extensionalityS ||
+     apply forall_extensionality) ; intro x
   end.
 
 (** Eta expansion follows from extensionality. *)
diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v
index 95e98038..ede51f57 100644
--- a/theories/Logic/Hurkens.v
+++ b/theories/Logic/Hurkens.v
@@ -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,74 +8,686 @@
 (*                              Hurkens.v                               *)
 (************************************************************************)
 
-(** This is Hurkens paradox [Hurkens] in system U-, adapted by Herman
-    Geuvers [Geuvers] to show the inconsistency in the pure calculus of
-    constructions of a retract from Prop into a small type.
+(** Exploiting Hurkens's paradox [[Hurkens95]] for system U- so as to
+    derive various contradictory contexts.
+
+    The file is divided into various sub-modules which all follow the
+    same structure: a section introduces the contradictory hypotheses
+    and a theorem named [paradox] concludes the module with a proof of
+    [False].
+
+    - The [Generic] module contains the actual Hurkens's paradox for a
+      postulated shallow encoding of system U- in Coq. This is an
+      adaptation by Arnaud Spiwack of a previous, more restricted
+      implementation by Herman Geuvers. It is used to derive every
+      other special cases of the paradox in this file.
+
+    - The [NoRetractToImpredicativeUniverse] module contains a simple
+      and effective formulation by Herman Geuvers [[Geuvers01]] of a
+      result by Thierry Coquand [[Coquand90]]. It states that no
+      impredicative sort can contain a type of which it is a
+      retract. This result implies that Coq with classical logic
+      stated in impredicative Set is inconsistent and that classical
+      logic stated in Prop implies proof-irrelevance (see
+      [ClassicalFacts.v])
+
+    - The [NoRetractFromSmallPropositionToProp] module is a
+      specialisation of the [NoRetractToImpredicativeUniverse] module
+      to the case where the impredicative sort is [Prop].
+
+    - The [NoRetractToModalProposition] module is a strengthening of
+      the [NoRetractFromSmallPropositionToProp] module.  It shows that
+      given a monadic modality (aka closure operator) [M], the type of
+      modal propositions (i.e. such that [M A -> A]) cannot be a
+      retract of a modal proposition. It is an example of use of the
+      paradox where the universes of system U- are not mapped to
+      universes of Coq.
+
+    - The [NoRetractToNegativeProp] module is the specialisation of
+      the [NoRetractFromSmallPropositionToProp] module where the
+      modality is double-negation. This result implies that the
+      principle of weak excluded middle ([forall A, ~~A\/~A]) implies
+      a weak variant of proof irrelevance.
+
+    - The [NoRetractFromTypeToProp] module proves that [Prop] cannot
+      be a retract of a larger type.
+
+    - The [TypeNeqSmallType] module proves that [Type] is different
+      from any smaller type.
+
+    - The [PropNeqType] module proves that [Prop] is different from
+      any larger [Type]. It is an instance of the previous result.
 
     References:
 
-    - [Hurkens] A. J. Hurkens, "A simplification of Girard's paradox",
+    - [[Coquand90]] T. Coquand, "Metamathematical Investigations of a
+      Calculus of Constructions", Proceedings of Logic in Computer
+      Science (LICS'90), 1990.
+
+    - [[Hurkens95]] A. J. Hurkens, "A simplification of Girard's paradox",
       Proceedings of the 2nd international conference Typed Lambda-Calculi
       and Applications (TLCA'95), 1995.
 
-    - [Geuvers] "Inconsistency of Classical Logic in Type Theory", 2001
-      (see http://www.cs.kun.nl/~herman/note.ps.gz).
+    - [[Geuvers01]] H. Geuvers, "Inconsistency of Classical Logic in Type
+      Theory", 2001, revised 2007
+      (see {{http://www.cs.ru.nl/~herman/PUBS/newnote.ps.gz}}).
 *)
 
+
+Set Universe Polymorphism.
+
+(* begin show *)
+
+(** * A modular proof of Hurkens's paradox. *)
+
+(** It relies on an axiomatisation of a shallow embedding of system U-
+    (i.e.  types of U- are interpreted by types of Coq). The
+    universes are encoded in a style, due to Martin-Löf, where they
+    are given by a set of names and a family [El:Name->Type] which
+    interprets each name into a type. This allows the encoding of
+    universe to be decoupled from Coq's universes. Dependent products
+    and abstractions are similarly postulated rather than encoded as
+    Coq's dependent products and abstractions. *)
+
+Module Generic.
+
+(* begin hide *)
+(* Notations used in the proof. Hidden in coqdoc. *)
+
+Reserved Notation "'∀�' x : A , B" (at level 200, x ident, A at level 200,right associativity).
+Reserved Notation "A '⟶�' B" (at level 99, right associativity, B at level 200).
+Reserved Notation "'λ�' x , u" (at level 200, x ident, right associativity).
+Reserved Notation "f '·�' x" (at level 5, left associativity).
+Reserved Notation "'∀₂' A , F" (at level 200, A ident, right associativity).
+Reserved Notation "'λ₂' x , u" (at level 200, x ident, right associativity).
+Reserved Notation "f '·�' [ A ]" (at level 5, left associativity).
+Reserved Notation "'∀₀' x : A , B" (at level 200, x ident, A at level 200,right associativity).
+Reserved Notation "A '⟶₀' B" (at level 99, right associativity, B at level 200).
+Reserved Notation "'λ₀' x , u" (at level 200, x ident, right associativity).
+Reserved Notation "f '·₀' x" (at level 5, left associativity).
+Reserved Notation "'∀₀¹' A : U , F" (at level 200, A ident, right associativity).
+Reserved Notation "'λ₀¹' x , u" (at level 200, x ident, right associativity).
+Reserved Notation "f '·₀' [ A ]" (at level 5, left associativity).
+
+(* end hide *)
+
+Section Paradox.
+
+(** ** Axiomatisation of impredicative universes in a Martin-Löf style *)
+
+(** System U- has two impredicative universes. In the proof of the
+    paradox they are slightly asymmetric (in particular the reduction
+    rules of the small universe are not needed).  Therefore, the
+    axioms are duplicated allowing for a weaker requirement than the
+    actual system U-. *)
+
+
+(** *** Large universe *)
+Variable U1 : Type.
+Variable El1 : U1 -> Type.
+(** **** Closure by small product *)
+Variable Forall1 : forall u:U1, (El1 u -> U1) -> U1.
+  Notation "'∀�' x : A , B" := (Forall1 A (fun x => B)).
+  Notation "A '⟶�' B" := (Forall1 A (fun _ => B)).
+Variable lam1 : forall u B, (forall x:El1 u, El1 (B x)) -> El1 (∀� x:u, B x).
+  Notation "'λ�' x , u" := (lam1 _ _ (fun x => u)).
+Variable app1 : forall u B (f:El1 (Forall1 u B)) (x:El1 u), El1 (B x).
+  Notation "f '·�' x" := (app1 _ _ f x).
+Variable beta1 : forall u B (f:forall x:El1 u, El1 (B x)) x,
+                   (λ� y, f y) ·� x = f x.
+(** **** Closure by large products *)
+(** [U1] only needs to quantify over itself. *)
+Variable ForallU1 : (U1->U1) -> U1.
+  Notation "'∀₂' A , F" := (ForallU1 (fun A => F)).
+Variable lamU1 : forall F, (forall A:U1, El1 (F A)) -> El1 (∀₂ A, F A).
+  Notation "'λ₂' x , u" := (lamU1 _ (fun x => u)).
+Variable appU1 : forall F (f:El1(∀₂ A,F A)) (A:U1), El1 (F A).
+  Notation "f '·�' [ A ]" := (appU1 _ f A).
+Variable betaU1 : forall F (f:forall A:U1, El1 (F A)) A,
+                    (λ₂ x, f x) ·� [ A ] = f A.
+
+(** *** Small universe *)
+(** The small universe is an element of the large one. *)
+Variable u0 : U1.
+Notation U0 := (El1 u0).
+Variable El0 : U0 -> Type.
+(** **** Closure by small product *)
+(** [U0] does not need reduction rules *)
+Variable Forall0 : forall u:U0, (El0 u -> U0) -> U0.
+  Notation "'∀₀' x : A , B" := (Forall0 A (fun x => B)).
+  Notation "A '⟶₀' B" := (Forall0 A (fun _ => B)).
+Variable lam0 : forall u B, (forall x:El0 u, El0 (B x)) -> El0 (∀₀ x:u, B x).
+  Notation "'λ₀' x , u" := (lam0 _ _ (fun x => u)).
+Variable app0 : forall u B (f:El0 (Forall0 u B)) (x:El0 u), El0 (B x).
+  Notation "f '·₀' x" := (app0 _ _ f x).
+(** **** Closure by large products *)
+Variable ForallU0 : forall u:U1, (El1 u->U0) -> U0.
+  Notation "'∀₀¹' A : U , F" := (ForallU0 U (fun A => F)).
+Variable lamU0 : forall U F, (forall A:El1 U, El0 (F A)) -> El0 (∀₀¹ A:U, F A).
+  Notation "'λ₀¹' x , u" := (lamU0 _ _ (fun x => u)).
+Variable appU0 : forall U F (f:El0(∀₀¹ A:U,F A)) (A:El1 U), El0 (F A).
+  Notation "f '·₀' [ A ]" := (appU0 _ _ f A).
+
+(** ** Automating the rewrite rules of our encoding. *)
+Local Ltac simplify :=
+  (* spiwack: ideally we could use [rewrite_strategy] here, but I am a tad
+     scared of the idea of depending on setoid rewrite in such a simple
+     file. *)
+  (repeat rewrite ?beta1, ?betaU1);
+  lazy beta.
+
+Local Ltac simplify_in h :=
+  (repeat rewrite ?beta1, ?betaU1 in h);
+  lazy beta in h.
+
+
+(** ** Hurkens's paradox. *)
+
+(** An inhabitant of [U0] standing for [False]. *)
+Variable F:U0.
+
+(** *** Preliminary definitions *)
+
+Definition V : U1 := ∀₂ A, ((A ⟶� u0) ⟶� A ⟶� u0) ⟶� A ⟶� u0.
+Definition U : U1 := V ⟶� u0.
+
+Definition sb (z:El1 V) : El1 V := λ₂ A, λ� r, λ� a, r ·� (z·�[A]·�r) ·� a.
+
+Definition le (i:El1 (U⟶�u0)) (x:El1 U) : U0 :=
+  x ·� (λ₂ A, λ� r, λ� a, i ·� (λ� v, (sb v) ·� [A] ·� r ·� a)).
+Definition le' : El1 ((U⟶�u0) ⟶� U ⟶� u0) := λ� i, λ� x, le i x.
+Definition induct (i:El1 (U⟶�u0)) : U0 :=
+  ∀₀¹ x:U, le i x ⟶₀ i ·� x.
+
+Definition WF : El1 U := λ� z, (induct (z·�[U] ·� le')).
+Definition I (x:El1 U) : U0 :=
+  (∀₀¹ i:U⟶�u0, le i x ⟶₀ i ·� (λ� v, (sb v) ·� [U] ·� le' ·� x)) ⟶₀ F
+.
+
+(** *** Proof *)
+
+Lemma Omega : El0 (∀₀¹ i:U⟶�u0, induct i ⟶₀ i ·� WF).
+Proof.
+  refine (λ₀¹ i, λ₀ y, _).
+  refine (y·₀[_]·₀_).
+  unfold le,WF,induct. simplify.
+  refine (λ₀¹ x, λ₀ h0, _). simplify.
+  refine (y·₀[_]·₀_).
+  unfold le. simplify.
+  unfold sb at 1. simplify.
+  unfold le' at 1. simplify.
+  exact h0.
+Qed.
+
+Lemma lemma1 : El0 (induct (λ� u, I u)).
+Proof.
+  unfold induct.
+  refine (λ₀¹ x, λ₀ p, _). simplify.
+  refine (λ₀ q,_).
+  assert (El0 (I (λ� v, (sb v)·�[U]·�le'·�x))) as h.
+  { generalize (q·₀[λ� u, I u]·₀p). simplify.
+    intros q'.
+    exact q'. }
+  refine (h·₀_).
+  refine (λ₀¹ i,_).
+  refine (λ₀ h', _).
+  generalize (q·₀[λ� y, i ·� (λ� v, (sb v)·�[U] ·� le' ·� y)]). simplify.
+  intros q'.
+  refine (q'·₀_). clear q'.
+  unfold le at 1 in h'. simplify_in h'.
+  unfold sb at 1 in h'. simplify_in h'.
+  unfold le' at 1 in h'. simplify_in h'.
+  exact h'.
+Qed.
+
+Lemma lemma2 : El0 ((∀₀¹i:U⟶�u0, induct i ⟶₀ i·�WF) ⟶₀ F).
+Proof.
+  refine (λ₀ x, _).
+  assert (El0 (I WF)) as h.
+  { generalize (x·₀[λ� u, I u]·₀lemma1). simplify.
+    intros q.
+    exact q. }
+  refine (h·₀_). clear h.
+  refine (λ₀¹ i, λ₀ h0, _).
+  generalize (x·₀[λ� y, i·�(λ� v, (sb v)·�[U]·�le'·�y)]). simplify.
+  intros q.
+  refine (q·₀_). clear q.
+  unfold le in h0. simplify_in h0.
+  unfold WF in h0. simplify_in h0.
+  exact h0.
+Qed.
+
+Theorem paradox : El0 F.
+Proof.
+  exact (lemma2·₀Omega).
+Qed.
+
+End Paradox.
+
+(** The [paradox] tactic can be called as a shortcut to use the paradox. *)
+Ltac paradox h :=
+  refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ));cycle 1.
+
+End Generic.
+
+(** * Impredicative universes are not retracts. *)
+
+(** There can be no retract to an impredicative Coq universe from a
+    smaller type. In this version of the proof, the impredicativity of
+    the universe is postulated with a pair of functions from the
+    universe to its type and back which commute with dependent product
+    in an appropriate way. *)
+
+Module NoRetractToImpredicativeUniverse.
+
 Section Paradox.
 
+Let      U2    := Type.
+Let      U1:U2 := Type.
+Variable U0:U1.
+
+(** *** [U1] is impredicative *)
+Variable u22u1 : U2 -> U1.
+Hypothesis u22u1_unit   : forall (c:U2), c -> u22u1 c.
+(** [u22u1_counit] and [u22u1_coherent] only apply to dependent
+    product so that the equations happen in the smaller [U1] rather
+    than [U2].  Indeed, it is not generally the case that one can
+    project from a large universe to an impredicative universe and
+    then get back the original type again. It would be too strong a
+    hypothesis to require (in particular, it is not true of
+    [Prop]). The formulation is reminiscent of the monadic
+    characteristic of the projection from a large type to [Prop].*)
+Hypothesis u22u1_counit : forall (F:U1->U1), u22u1 (forall A,F A) -> (forall A,F A).
+Hypothesis u22u1_coherent : forall (F:U1 -> U1) (f:forall x:U1, F x) (x:U1), 
+                              u22u1_counit _ (u22u1_unit _ f) x = f x.
+
+(** *** [U0] is a retract of [U1] *)
+Variable u02u1 : U0 -> U1.
+Variable u12u0 : U1 -> U0.
+Hypothesis u12u0_unit   : forall (b:U1), b -> u02u1 (u12u0 b).
+Hypothesis u12u0_counit : forall (b:U1), u02u1 (u12u0 b) -> b.
+
+(** ** Paradox *)
+
+Theorem paradox : forall F:U1, F.
+Proof.
+  intros F.
+  Generic.paradox h.
+  (** Large universe *)
+  + exact U1.
+  + exact (fun X => X).
+  + cbn. exact (fun u F => forall x:u, F x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. easy.
+  + cbn. exact (fun F => u22u1 (forall x, F x)).
+  + cbn. exact (fun _ x => u22u1_unit _ x).
+  + cbn. exact (fun _ x => u22u1_counit _ x).
+  + cbn. intros **. now rewrite u22u1_coherent.
+  (** Small universe *)
+  + exact U0.
+  (** The interpretation of the small universe is the image of
+      [U0] in [U1]. *)
+  + cbn. exact (fun X => u02u1 X).
+  + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))).
+  + cbn. intros * x. exact (u12u0_unit _ x).
+  + cbn. intros * x. exact (u12u0_counit _ x).
+  + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))).
+  + cbn. intros * x. exact (u12u0_unit _ x).
+  + cbn. intros * x. exact (u12u0_counit _ x).
+  + cbn. exact (u12u0 F).
+  + cbn in h.
+    exact (u12u0_counit _ h).
+Qed.
+
+End Paradox.
+
+End NoRetractToImpredicativeUniverse.
+
+(** * Prop is not a retract *)
+
+(** The existence in the pure Calculus of Constructions of a retract
+    from [Prop] into a small type of [Prop] is inconsistent. This is a
+    special case of the previous result. *)
+
+Module NoRetractFromSmallPropositionToProp.
+
+Section Paradox.
+
+(** ** Retract of [Prop] in a small type *)
+
+(** The retract is axiomatized using logical equivalence as the
+    equality on propositions. *)
+
 Variable bool : Prop.
 Variable p2b : Prop -> bool.
 Variable b2p : bool -> Prop.
 Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A.
 Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A).
-Variable B : Prop.
-
-Definition V := forall A:Prop, ((A -> bool) -> A -> bool) -> A -> bool.
-Definition U := V -> bool.
-Definition sb (z:V) : V := fun A r a => r (z A r) a.
-Definition le (i:U -> bool) (x:U) : bool :=
-  x (fun A r a => i (fun v => sb v A r a)).
-Definition induct (i:U -> bool) : Prop :=
-  forall x:U, b2p (le i x) -> b2p (i x).
-Definition WF : U := fun z => p2b (induct (z U le)).
-Definition I (x:U) : Prop :=
-  (forall i:U -> bool, b2p (le i x) -> b2p (i (fun v => sb v U le x))) -> B.
-
-Lemma Omega : forall i:U -> bool, induct i -> b2p (i WF).
+
+(** ** Paradox *)
+
+Theorem paradox : forall B:Prop, B.
 Proof.
-intros i y.
-apply y.
-unfold le, WF, induct.
-apply p2p2.
-intros x H0.
-apply y.
-exact H0.
+  intros B.
+  pose proof
+      (NoRetractToImpredicativeUniverse.paradox@{Type Prop}) as P.
+  refine (P _ _ _ _ _ _ _ _ _ _);clear P.
+  + exact bool.
+  + exact (fun x => forall P:Prop, (x->P)->P).
+  + cbn. exact (fun _ x P k => k x).
+  + cbn. intros F P x.
+    apply P.
+    intros f.
+    exact (f x).
+  + cbn. easy.
+  + exact b2p.
+  + exact p2b.
+  + exact p2p2.
+  + exact p2p1.
 Qed.
 
-Lemma lemma1 : induct (fun u => p2b (I u)).
+End Paradox.
+
+End NoRetractFromSmallPropositionToProp.
+
+(** * Modal fragments of [Prop] are not retracts *)
+
+(** In presence of a a monadic modality on [Prop], we can define a
+    subset of [Prop] of modal propositions which is also a complete
+    Heyting algebra. These cannot be a retract of a modal
+    proposition. This is a case where the universe in system U- are
+    not encoded as Coq universes. *)
+
+Module NoRetractToModalProposition.
+
+(** ** Monadic modality *)
+
+Section Paradox.
+
+Variable M : Prop -> Prop.
+Hypothesis unit : forall A:Prop, A -> M A.
+Hypothesis join : forall A:Prop, M (M A) -> M A.
+Hypothesis incr : forall A B:Prop, (A->B) -> M A -> M B.
+
+Lemma strength: forall A (P:A->Prop), M(forall x:A,P x) -> forall x:A,M(P x).
 Proof.
-unfold induct.
-intros x p.
-apply (p2p2 (I x)).
-intro q.
-apply (p2p1 (I (fun v:V => sb v U le x)) (q (fun u => p2b (I u)) p)).
-intro i.
-apply q with (i := fun y => i (fun v:V => sb v U le y)).
+  eauto.
 Qed.
 
-Lemma lemma2 : (forall i:U -> bool, induct i -> b2p (i WF)) -> B.
+(** ** The universe of modal propositions *)
+
+Definition MProp := { P:Prop | M P -> P }.
+Definition El : MProp -> Prop := @proj1_sig _ _.
+
+Lemma modal : forall P:MProp, M(El P) -> El P.
 Proof.
-intro x.
-apply (p2p1 (I WF) (x (fun u => p2b (I u)) lemma1)).
-intros i H0.
-apply (x (fun y => i (fun v => sb v U le y))).
-apply (p2p1 _ H0).
+  intros [P m]. cbn.
+  exact m.
 Qed.
 
-Theorem paradox : B.
+Definition Forall {A:Type} (P:A->MProp) : MProp.
+Proof.
+  refine (exist _ _ _).
+  + exact (forall x:A, El (P x)).
+  + intros h x.
+    eapply strength in h.
+    eauto using modal.
+Defined.
+
+(** ** Retract of the modal fragment of [Prop] in a small type *)
+
+(** The retract is axiomatized using logical equivalence as the
+    equality on propositions. *)
+
+Variable bool : MProp.
+Variable p2b : MProp -> El bool.
+Variable b2p : El bool -> MProp.
+Hypothesis p2p1 : forall A:MProp, El (b2p (p2b A)) -> El A.
+Hypothesis p2p2 : forall A:MProp, El A -> El (b2p (p2b A)).
+
+(** ** Paradox *)
+
+Theorem paradox : forall B:MProp, El B.
 Proof.
-exact (lemma2 Omega).
+  intros B.
+  Generic.paradox h.
+  (** Large universe *)
+  + exact MProp.
+  + exact El.
+  + exact (fun _ => Forall).
+  + cbn. exact (fun _ _ f => f).
+  + cbn. exact (fun _ _ f => f).
+  + cbn. easy.
+  + exact Forall.
+  + cbn. exact (fun _ f => f).
+  + cbn. exact (fun _ f => f).
+  + cbn. easy.
+  (** Small universe *)
+  + exact bool.
+  + exact (fun b => El (b2p b)).
+  + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))).
+  + cbn. auto.
+  + cbn. intros * f.
+    apply p2p1 in f. cbn in f.
+    exact f.
+  + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))).
+  + cbn. auto.
+  + cbn. intros * f.
+    apply p2p1 in f. cbn in f.
+    exact f.
+  + apply p2b.
+    exact B.
+  + cbn in h. auto.
 Qed.
 
 End Paradox.
+
+End NoRetractToModalProposition.
+
+(** * The negative fragment of [Prop] is not a retract *)
+
+(** The existence in the pure Calculus of Constructions of a retract
+    from the negative fragment of [Prop] into a negative proposition
+    is inconsistent. This is an instance of the previous result. *)
+
+Module NoRetractToNegativeProp.
+
+(** ** The universe of negative propositions. *)
+
+Definition NProp := { P:Prop | ~~P -> P }.
+Definition El : NProp -> Prop := @proj1_sig _ _.
+
+Section Paradox.
+
+(** ** Retract of the negative fragment of [Prop] in a small type *)
+
+(** The retract is axiomatized using logical equivalence as the
+    equality on propositions. *)
+
+Variable bool : NProp.
+Variable p2b : NProp -> El bool.
+Variable b2p : El bool -> NProp.
+Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A.
+Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)).
+
+(** ** Paradox *)
+
+Theorem paradox : forall B:NProp, El B.
+Proof.
+  intros B.
+  refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1.
+  + exact (fun P => ~~P).
+  + cbn. auto.
+  + cbn. auto.
+  + cbn. auto.
+  + exact bool.
+  + exact p2b.
+  + exact b2p.
+  + auto.
+  + auto.
+  + exact B.
+  + exact h.
+Qed.
+
+End Paradox.
+
+End NoRetractToNegativeProp.
+
+(** * Large universes are no retracts of [Prop]. *)
+
+(** The existence in the Calculus of Constructions with universes of a
+    retract from some [Type] universe into [Prop] is inconsistent. *)
+
+(* Note: Assuming the context [down:Type->Prop; up:Prop->Type; forth:
+      forall (A:Type), A -> up (down A); back: forall (A:Type), up
+      (down A) -> A; H: forall (A:Type) (P:A->Type) (a:A),
+      P (back A (forth A a)) -> P a] is probably enough.  *)
+
+Module NoRetractFromTypeToProp.
+
+Definition Type2 := Type.
+Definition Type1 := Type : Type2.
+
+Section Paradox.
+
+(** ** Assumption of a retract from Type into Prop *)
+
+Variable down : Type1 -> Prop.
+Variable up : Prop -> Type1.
+Hypothesis up_down : forall (A:Type1), up (down A) = A :> Type1.
+
+(** ** Paradox *)
+
+Theorem paradox : forall P:Prop, P.
+Proof.
+  intros P.
+  Generic.paradox h.
+  (** Large universe. *)
+  + exact Type1.
+  + exact (fun X => X).
+  + cbn. exact (fun u F => forall x, F x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. easy.
+  + exact (fun F => forall A:Prop, F(up A)).
+  + cbn. exact (fun F f A => f (up A)).
+  + cbn.
+    intros F f A.
+    specialize (f (down A)).
+    rewrite up_down in f.
+    exact f.
+  + cbn.
+    intros F f A.
+    destruct (up_down A). cbn.
+    reflexivity.
+  + exact Prop.
+  + cbn. exact (fun X => X).
+  + cbn. exact (fun A P => forall x:A, P x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun A P => forall x:A, P x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact P.
+  + exact h.
+Qed.
+
+End Paradox.
+
+End NoRetractFromTypeToProp.
+
+(** * [A<>Type] *)
+
+(** No Coq universe can be equal to one of its elements. *)
+
+Module TypeNeqSmallType.
+
+Section Paradox.
+
+(** ** Universe [U] is equal to one of its elements. *)
+
+Let U := Type.
+Variable A:U.
+Hypothesis h : U=A.
+
+(** ** Universe [U] is a retract of [A] *)
+
+(** The following context is actually sufficient for the paradox to
+    hold. The hypothesis [h:U=A] is only used to define [down], [up]
+    and [up_down]. *)
+
+Let down (X:U) : A := @eq_rect _ _ (fun X => X) X _ h.
+Let up   (X:A) : U := @eq_rect_r _ _ (fun X => X) X _ h.
+
+Lemma up_down : forall (X:U), up (down X) = X.
+Proof.
+  unfold up,down.
+  rewrite <- h.
+  reflexivity.
+Qed.
+
+
+Theorem paradox : False.
+Proof.
+  Generic.paradox p.
+  (** Large universe *)
+  + exact U.
+  + exact (fun X=>X).
+  + cbn. exact (fun X F => forall x:X, F x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. exact (fun _ _ x => x).
+  + cbn. easy.
+  + exact (fun F => forall x:A, F (up x)).
+  + cbn. exact (fun _ f => fun x:A => f (up x)).
+  + cbn. intros * f X.
+    specialize (f (down X)).
+    rewrite up_down in f.
+    exact f.
+  + cbn. intros ? f X.
+    destruct (up_down X). cbn.
+    reflexivity.
+  (** Small universe *)
+  + exact A.
+  (** The interpretation of [A] as a universe is [U]. *)
+  + cbn. exact up.
+  + cbn. exact (fun _ F => down (forall x, up (F x))).
+  + cbn. intros ? ? f.
+    rewrite up_down.
+    exact f.
+  + cbn. intros ? ? f.
+    rewrite up_down in f.
+    exact f.
+  + cbn. exact (fun _ F => down (forall x, up (F x))).
+  + cbn. intros ? ? f.
+    rewrite up_down.
+    exact f.
+  + cbn. intros ? ? f.
+    rewrite up_down in f.
+    exact f.
+  + cbn. exact (down False).
+  + rewrite up_down in p.
+    exact p.
+Qed.
+
+End Paradox.
+
+End TypeNeqSmallType.
+
+(** * [Prop<>Type]. *)
+
+(** Special case of [TypeNeqSmallType]. *)
+
+Module PropNeqType.
+
+Theorem paradox : Prop <> Type.
+Proof.
+  intros h.
+  refine (TypeNeqSmallType.paradox _ _).
+  + exact Prop.
+  + easy.
+Qed.
+
+End PropNeqType.
+
+(* end show *)
diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v
index 198b7292..9875710e 100644
--- a/theories/Logic/IndefiniteDescription.v
+++ b/theories/Logic/IndefiniteDescription.v
@@ -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        *)
 (************************************************************************)
 
 (** This file provides a constructive form of indefinite description that
-    allows to build choice functions; this is weaker than Hilbert's
+    allows building choice functions; this is weaker than Hilbert's
     epsilon operator (which implies weakly classical properties) but
     stronger than the axiom of choice (which cannot be used outside
     the context of a theorem proof). *)
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index 36e2d100..98cddf0a 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -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        *)
@@ -28,9 +28,11 @@ Arguments JMeq_refl {A x} , [A] x.
 
 Hint Resolve JMeq_refl.
 
+Definition JMeq_hom {A : Type} (x y : A) := JMeq x y.
+
 Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x.
-Proof.
-destruct 1; trivial.
+Proof. 
+intros; destruct H; trivial.
 Qed.
 
 Hint Immediate JMeq_sym.
diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v
index 5cd58419..eb00dedd 100644
--- a/theories/Logic/ProofIrrelevance.v
+++ b/theories/Logic/ProofIrrelevance.v
@@ -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/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v
index b80cfe52..6ab6abcf 100644
--- a/theories/Logic/ProofIrrelevanceFacts.v
+++ b/theories/Logic/ProofIrrelevanceFacts.v
@@ -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        *)
@@ -40,7 +40,7 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance).
   (** We derive the irrelevance of the membership property for subsets *)
 
   Lemma subset_eq_compat :
-    forall (U:Set) (P:U->Prop) (x y:U) (p:P x) (q:P y),
+    forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y),
       x = y -> exist P x p = exist P y q.
   Proof.
     intros.
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 1f700c6c..61598130 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -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/theories/Logic/SetIsType.v b/theories/Logic/SetIsType.v
index 412f8956..f110237e 100644
--- a/theories/Logic/SetIsType.v
+++ b/theories/Logic/SetIsType.v
@@ -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        *)
@@ -9,7 +9,7 @@
 (** * The Set universe seen as a synonym for Type *)
 
 (** After loading this file, Set becomes just another name for Type.
-    This allows to easily perform a Set-to-Type migration, or at least
+    This allows easily performing a Set-to-Type migration, or at least
     test whether a development relies or not on specific features of
     Set: simply insert some Require Export of this file at starting
     points of the development and try to recompile...  *)
diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v
new file mode 100644
index 00000000..408eca4a
--- /dev/null
+++ b/theories/Logic/WKL.v
@@ -0,0 +1,261 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** A constructive proof of a version of Weak König's Lemma over a
+    decidable predicate in the formulation of which infinite paths are
+    treated as predicates. The representation of paths as relations
+    avoid the need for classical logic and unique choice. The
+    decidability condition is sufficient to ensure that some required
+    instance of double negation for disjunction of finite paths holds.
+
+    The idea of the proof comes from the proof of the weak König's
+    lemma from separation in second-order arithmetic.
+
+    Notice that we do not start from a tree but just from an arbitrary
+    predicate. Original Weak Konig's Lemma is the instantiation of
+    the lemma to a tree *)
+
+Require Import WeakFan List.
+Import ListNotations.
+
+Require Import Omega.
+
+(** [is_path_from P n l] means that there exists a path of length [n]
+    from [l] on which [P] does not hold *)
+
+Inductive is_path_from (P:list bool -> Prop) : nat -> list bool -> Prop :=
+| here l : ~ P l -> is_path_from P 0 l
+| next_left l n : ~ P l -> is_path_from P n (true::l) -> is_path_from P (S n) l
+| next_right l n : ~ P l -> is_path_from P n (false::l) -> is_path_from P (S n) l.
+
+(** We give the characterization of is_path_from in terms of a more common arithmetical formula *)
+
+Proposition is_path_from_characterization P n l :
+  is_path_from P n l <-> exists l', length l' = n /\ forall n', n'<=n -> ~ P (rev (firstn n' l') ++ l).
+Proof.
+intros. split.
+- induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')].
+  + exists []. split. reflexivity. intros n <-/le_n_0_eq. assumption.
+  + exists (true :: l'). split. apply eq_S, Hl'. intros [|] H.
+    * assumption.
+    * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H.
+  + exists (false :: l'). split. apply eq_S, Hl'. intros [|] H.
+    * assumption.
+    * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H.
+- intros (l'& <- &HPl'). induction l' as [|[|]] in l, HPl' |- *.
+  + constructor. apply (HPl' 0). apply le_0_n.
+  + eapply next_left.
+    * apply (HPl' 0), le_0_n.
+    * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption.
+  + apply next_right.
+    * apply (HPl' 0), le_0_n.
+    * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption.
+Qed.
+
+(** [infinite_from P l] means that we can find arbitrary long paths
+    along which [P] does not hold above [l] *)
+
+Definition infinite_from (P:list bool -> Prop) l := forall n, is_path_from P n l.
+
+(** [has_infinite_path P] means that there is an infinite path
+    (represented as a predicate) along which [P] does not hold at all *)
+
+Definition has_infinite_path (P:list bool -> Prop) :=
+  exists (X:nat -> Prop), forall l, approx X l -> ~ P l.
+
+(** [inductively_barred_at P n l] means that [P] eventually holds above
+    [l] after at most [n] steps upwards *)
+
+Inductive inductively_barred_at (P:list bool -> Prop) : nat -> list bool -> Prop :=
+| now_at l n : P l -> inductively_barred_at P n l
+| propagate_at l n :
+    inductively_barred_at P n (true::l) ->
+    inductively_barred_at P n (false::l) ->
+    inductively_barred_at P (S n) l.
+
+(** The proof proceeds by building a set [Y] of finite paths
+   approximating either the smallest unbarred infinite path in [P], if
+   there is one (taking [true]>[false]), or the path
+   true::true::... if [P] happens to be inductively_barred *)
+
+Fixpoint Y P (l:list bool) :=
+  match l with
+  | [] => True
+  | b::l =>
+      Y P l /\
+      if b then exists n, inductively_barred_at P n (false::l) else infinite_from P (false::l)
+  end.
+
+Require Import Compare_dec Le Lt.
+
+Lemma is_path_from_restrict : forall P n n' l, n <= n' ->
+  is_path_from P n' l -> is_path_from P n l.
+Proof.
+intros * Hle H; induction H in n, Hle, H |- * ; intros.
+- apply le_n_0_eq in Hle as <-. apply here. assumption.
+- destruct n.
+  + apply here. assumption.
+  + apply next_left; auto using le_S_n.
+- destruct n.
+  + apply here. assumption.
+  + apply next_right; auto using le_S_n.
+Qed.
+
+Lemma inductively_barred_at_monotone : forall P l n n', n' <= n ->
+  inductively_barred_at P n' l -> inductively_barred_at P n l.
+Proof.
+intros * Hle Hbar.
+induction Hbar in n, l, Hle, Hbar |- *.
+- apply now_at; auto.
+- destruct n; [apply le_Sn_0 in Hle; contradiction|].
+  apply le_S_n in Hle.
+  apply propagate_at; auto.
+Qed.
+
+Definition demorgan_or (P:list bool -> Prop) l l' := ~ (P l /\ P l') -> ~ P l \/ ~ P l'.
+
+Definition demorgan_inductively_barred_at P :=
+  forall n l, demorgan_or (inductively_barred_at P n) (true::l) (false::l).
+
+Lemma inductively_barred_at_imp_is_path_from :
+  forall P, demorgan_inductively_barred_at P -> forall n l,
+  ~ inductively_barred_at P n l -> is_path_from P n l.
+Proof.
+intros P Hdemorgan; induction n; intros l H.
+- apply here.
+  intro. apply H.
+  apply now_at. auto.
+- assert (H0:~ (inductively_barred_at P n (true::l) /\ inductively_barred_at P n (false::l)))
+  by firstorder using inductively_barred_at.
+  assert (HnP:~ P l) by firstorder using inductively_barred_at.
+  apply Hdemorgan in H0 as [H0|H0]; apply IHn in H0; auto using is_path_from.
+Qed.
+
+Lemma is_path_from_imp_inductively_barred_at : forall P n l,
+   is_path_from P n l -> inductively_barred_at P n l -> False.
+Proof.
+intros P; induction n; intros l H1 H2.
+- inversion_clear H1. inversion_clear H2. auto.
+- inversion_clear H1.
+  + inversion_clear H2.
+    * auto.
+    * apply IHn with (true::l); auto.
+  + inversion_clear H2.
+    * auto.
+    * apply IHn with (false::l); auto.
+Qed.
+
+Lemma find_left_path : forall P l n,
+  is_path_from P (S n) l -> inductively_barred_at P n (false :: l) -> is_path_from P n (true :: l).
+Proof.
+inversion 1; subst; intros.
+- auto.
+- exfalso. eauto using is_path_from_imp_inductively_barred_at.
+Qed.
+
+Lemma Y_unique : forall P, demorgan_inductively_barred_at P ->
+  forall l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2.
+Proof.
+intros * DeMorgan. induction l1, l2.
+- trivial.
+- discriminate.
+- discriminate.
+- intros [= H] (HY1,H1) (HY2,H2).
+  pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1.
+  subst l1.
+  f_equal.
+  destruct a, b; try reflexivity.
+  + destruct H1 as (n,Hbar).
+    destruct (is_path_from_imp_inductively_barred_at _ _ _ (H2 n) Hbar).
+  + destruct H2 as (n,Hbar).
+    destruct (is_path_from_imp_inductively_barred_at _ _ _ (H1 n) Hbar).
+Qed.
+
+(** [X] is the translation of [Y] as a predicate *)
+
+Definition X P n := exists l, length l = n /\ Y P (true::l).
+
+Lemma Y_approx : forall P, demorgan_inductively_barred_at P ->
+  forall l, approx (X P) l -> Y P l.
+Proof.
+intros P DeMorgan. induction l.
+- trivial.
+- intros (H,Hb). split.
+  + auto.
+  + unfold X in Hb.
+    destruct a.
+    * destruct Hb as (l',(Hl',(HYl',HY))).
+      rewrite <- (Y_unique P DeMorgan l' l Hl'); auto.
+    * intro n. apply inductively_barred_at_imp_is_path_from. assumption.
+      firstorder.
+Qed.
+
+(** Main theorem *)
+
+Theorem PreWeakKonigsLemma : forall P,
+  demorgan_inductively_barred_at P -> infinite_from P [] -> has_infinite_path P.
+Proof.
+intros P DeMorgan Hinf.
+exists (X P). intros l Hl.
+assert (infinite_from P l).
+{ induction l.
+  - assumption.
+  - destruct Hl as (Hl,Ha).
+    intros n.
+    pose proof (IHl Hl) as IHl'. clear IHl.
+    apply Y_approx in Hl; [|assumption].
+    destruct a.
+    + destruct Ha as (l'&Hl'&HY'&n'&Hbar).
+      rewrite (Y_unique _ DeMorgan _ _ Hl' HY' Hl) in Hbar.
+      destruct (le_lt_dec n n') as [Hle|Hlt].
+      * specialize (IHl' (S n')).
+        apply is_path_from_restrict with n'; [assumption|].
+        apply find_left_path; trivial.
+      * specialize (IHl' (S n)).
+        apply inductively_barred_at_monotone with (n:=n) in Hbar; [|apply lt_le_weak, Hlt].
+        apply find_left_path; trivial.
+    + apply inductively_barred_at_imp_is_path_from; firstorder. }
+specialize (H 0). inversion H. assumption.
+Qed.
+
+Lemma inductively_barred_at_decidable :
+  forall P, (forall l, P l \/ ~ P l) -> forall n l, inductively_barred_at P n l \/ ~ inductively_barred_at P n l.
+Proof.
+intros P HP. induction n; intros.
+- destruct (HP l).
+  + left. apply now_at, H.
+  + right. inversion 1. auto.
+- destruct (HP l).
+  + left. apply now_at, H.
+  + destruct (IHn (true::l)).
+    * destruct (IHn (false::l)).
+      { left. apply propagate_at; assumption. }
+      { right. inversion_clear 1; auto. }
+    * right. inversion_clear 1; auto.
+Qed.
+
+Lemma inductively_barred_at_is_path_from_decidable :
+  forall P, (forall l, P l \/ ~ P l) -> demorgan_inductively_barred_at P.
+Proof.
+intros P Hdec n l H.
+destruct (inductively_barred_at_decidable P Hdec n (true::l)).
+- destruct (inductively_barred_at_decidable P Hdec n (false::l)).
+  + auto.
+  + auto.
+- auto.
+Qed.
+
+(** Main corollary *)
+
+Corollary WeakKonigsLemma : forall P, (forall l, P l \/ ~ P l) ->
+  infinite_from P [] -> has_infinite_path P.
+Proof.
+intros P Hdec Hinf.
+apply inductively_barred_at_is_path_from_decidable in Hdec.
+apply PreWeakKonigsLemma; assumption.
+Qed.
diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v
new file mode 100644
index 00000000..49cc12b8
--- /dev/null
+++ b/theories/Logic/WeakFan.v
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** A constructive proof of a non-standard version of the weak Fan Theorem
+    in the formulation of which infinite paths are treated as
+    predicates. The representation of paths as relations avoid the
+    need for classical logic and unique choice. The idea of the proof
+    comes from the proof of the weak König's lemma from separation in
+    second-order arithmetic [[Simpson99]].
+
+    [[Simpson99]] Stephen G. Simpson. Subsystems of second order
+    arithmetic, Cambridge University Press, 1999 *)
+
+Require Import List.
+Import ListNotations.
+
+(** [inductively_barred P l] means that P eventually holds above l *)
+
+Inductive inductively_barred P : list bool -> Prop :=
+| now l : P l -> inductively_barred P l
+| propagate l :
+    inductively_barred P (true::l) ->
+    inductively_barred P (false::l) ->
+    inductively_barred P l.
+
+(** [approx X l] says that [l] is a boolean representation of a prefix of [X] *)
+
+Fixpoint approx X (l:list bool) :=
+  match l with
+  | [] => True
+  | b::l => approx X l /\ (if b then X (length l) else ~ X (length l))
+  end.
+
+(** [barred P] means that for any infinite path represented as a predicate,
+    the property [P] holds for some prefix of the path *)
+
+Definition barred P :=
+  forall (X:nat -> Prop), exists l, approx X l /\ P l.
+
+(** The proof proceeds by building a set [Y] of finite paths
+   approximating either the smallest unbarred infinite path in [P], if
+   there is one (taking [true]>[false]), or the path [true::true::...]
+   if [P] happens to be inductively_barred *)
+
+Fixpoint Y P (l:list bool) :=
+  match l with
+  | [] => True
+  | b::l =>
+      Y P l /\
+      if b then inductively_barred P (false::l) else ~ inductively_barred P (false::l)
+  end.
+
+Lemma Y_unique : forall P l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2.
+Proof.
+induction l1, l2.
+- trivial.
+- discriminate.
+- discriminate.
+- intros H (HY1,H1) (HY2,H2).
+  injection H as H.
+  pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1.
+  subst l1.
+  f_equal.
+  destruct a, b; firstorder.
+Qed.
+
+(** [X] is the translation of [Y] as a predicate *)
+
+Definition X P n := exists l, length l = n /\ Y P (true::l).
+
+Lemma Y_approx : forall P l, approx (X P) l -> Y P l.
+Proof.
+induction l.
+- trivial.
+- intros (H,Hb). split.
+  + auto.
+  + unfold X in Hb.
+    destruct a.
+    * destruct Hb as (l',(Hl',(HYl',HY))).
+      rewrite <- (Y_unique P l' l Hl'); auto.
+    * firstorder.
+Qed.
+
+Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P [].
+Proof.
+intros P Hbar.
+destruct (Hbar (X P)) as (l,(Hd,HP)).
+assert (inductively_barred P l) by (apply (now P l), HP).
+clear Hbar HP.
+induction l.
+- assumption.
+- destruct Hd as (Hd,HX).
+  apply (IHl Hd). clear IHl.
+  destruct a; unfold X in HX; simpl in HX.
+  + apply propagate.
+    * apply H.
+    * destruct HX as (l',(Hl,(HY,Ht))); firstorder.
+      apply Y_approx in Hd. rewrite <- (Y_unique P l' l Hl); trivial.
+  + destruct HX. exists l. split; auto using Y_approx.
+Qed.
diff --git a/theories/Logic/vo.itarget b/theories/Logic/vo.itarget
index 46046897..32359739 100644
--- a/theories/Logic/vo.itarget
+++ b/theories/Logic/vo.itarget
@@ -4,10 +4,8 @@ ClassicalChoice.vo
 ClassicalDescription.vo
 ClassicalEpsilon.vo
 ClassicalFacts.vo
-Classical_Pred_Set.vo
 Classical_Pred_Type.vo
 Classical_Prop.vo
-Classical_Type.vo
 ClassicalUniqueChoice.vo
 Classical.vo
 ConstructiveEpsilon.vo
@@ -18,7 +16,10 @@ Epsilon.vo
 Eqdep_dec.vo
 EqdepFacts.vo
 Eqdep.vo
+WeakFan.vo
+WKL.vo
 FunctionalExtensionality.vo
+ExtensionalityFacts.vo
 Hurkens.vo
 IndefiniteDescription.vo
 JMeq.vo
@@ -26,3 +27,4 @@ ProofIrrelevanceFacts.vo
 ProofIrrelevance.vo
 RelationalChoice.vo
 SetIsType.vo
+FinFun.vo
\ No newline at end of file
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
index db12ee31..e1fc454a 100644
--- a/theories/MSets/MSetAVL.v
+++ b/theories/MSets/MSetAVL.v
@@ -38,7 +38,6 @@ Unset Strict Implicit.
 (* for nicer extraction, we create inductive principles
    only when needed *)
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
 
 (** * Ops : the pure functions *)
 
@@ -307,13 +306,13 @@ Include MSetGenTree.Props X I.
 Local Hint Immediate MX.eq_sym.
 Local Hint Unfold In lt_tree gt_tree Ok.
 Local Hint Constructors InT bst.
-Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok.
 Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
 Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
 Local Hint Resolve elements_spec2.
 
 (* Sometimes functional induction will expose too much of
-   a tree structure. The following tactic allows to factor back
+   a tree structure. The following tactic allows factoring back
    a Node whose internal parts occurs nowhere else. *)
 
 (* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *)
diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v
index eefd2951..f2555791 100644
--- a/theories/MSets/MSetDecide.v
+++ b/theories/MSets/MSetDecide.v
@@ -15,7 +15,7 @@
 (** This file implements a decision procedure for a certain
     class of propositions involving finite sets.  *)
 
-Require Import Decidable DecidableTypeEx MSetFacts.
+Require Import Decidable Setoid DecidableTypeEx MSetFacts.
 
 (** First, a version for Weak Sets in functorial presentation *)
 
@@ -115,8 +115,8 @@ the above form:
       not affect the namespace if you import the enclosing
       module [Decide]. *)
   Module MSetLogicalFacts.
-    Require Export Decidable.
-    Require Export Setoid.
+    Export Decidable.
+    Export Setoid.
 
     (** ** Lemmas and Tactics About Decidable Propositions *)
 
diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v
index 4f0d93fb..ae20edc8 100644
--- a/theories/MSets/MSetEqProperties.v
+++ b/theories/MSets/MSetEqProperties.v
@@ -819,8 +819,7 @@ Proof.
 intros.
 rewrite for_all_exists in H; auto.
 rewrite negb_true_iff in H.
-elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto.
-elim p;intros.
+destruct (@for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,[]); auto.
 exists x;split;auto.
 rewrite <-negb_false_iff; auto.
 Qed.
@@ -856,7 +855,7 @@ intros.
 rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H).
 rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H).
 rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto.
-intros; do 3 (rewrite fold_add; auto with *).
+intros. do 3 (rewrite fold_add; auto with *).
 do 3 rewrite fold_empty;auto.
 Qed.
 
diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v
index 704ff31b..154c2384 100644
--- a/theories/MSets/MSetGenTree.v
+++ b/theories/MSets/MSetGenTree.v
@@ -27,14 +27,13 @@
      - min_elt max_elt choose
 *)
 
-Require Import Orders OrdersFacts MSetInterface NPeano.
+Require Import Orders OrdersFacts MSetInterface PeanoNat.
 Local Open Scope list_scope.
 Local Open Scope lazy_bool_scope.
 
 (* For nicer extraction, we create induction principles
    only when needed *)
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
 
 Module Type InfoTyp.
  Parameter t : Set.
@@ -341,7 +340,7 @@ Module Import MX := OrderedTypeFacts X.
 Scheme tree_ind := Induction for tree Sort Prop.
 Scheme bst_ind := Induction for bst Sort Prop.
 
-Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok.
 Local Hint Immediate MX.eq_sym.
 Local Hint Unfold In lt_tree gt_tree.
 Local Hint Constructors InT bst.
@@ -378,7 +377,7 @@ Ltac invtree f :=
 
 Ltac inv := inv_ok; invtree InT.
 
-Ltac intuition_in := repeat progress (intuition; inv).
+Ltac intuition_in := repeat (intuition; inv).
 
 (** Helper tactic concerning order of elements. *)
 
@@ -963,13 +962,16 @@ Proof. firstorder. Qed.
 Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
 Proof.
  unfold eq, Equal, L.eq; intros.
- setoid_rewrite elements_spec1; firstorder.
+ setoid_rewrite elements_spec1.
+ firstorder. 
 Qed.
 
 Definition lt (s1 s2 : tree) : Prop :=
  exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
    /\ L.lt (elements s1') (elements s2').
 
+Declare Equivalent Keys L.eq equivlistA.
+
 Instance lt_strorder : StrictOrder lt.
 Proof.
  split.
@@ -1017,7 +1019,7 @@ Lemma flatten_e_elements :
  forall l x r c e,
  elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e.
 Proof.
- intros; simpl. now rewrite elements_node, app_ass.
+ intros. now rewrite elements_node, app_ass.
 Qed.
 
 Lemma cons_1 : forall s e,
@@ -1051,7 +1053,7 @@ Lemma compare_cont_Cmp : forall s1 cont e2 l,
  (forall e, Cmp (cont e) l (flatten_e e)) ->
  Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
 Proof.
- induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto.
+ induction s1 as [|c1 l1 Hl1 x1 r1 Hr1]; intros; auto.
  rewrite elements_node, app_ass; simpl.
  apply Hl1; auto. clear e2. intros [|x2 r2 e2].
  simpl; auto.
@@ -1063,9 +1065,9 @@ Lemma compare_Cmp : forall s1 s2,
  Cmp (compare s1 s2) (elements s1) (elements s2).
 Proof.
  intros; unfold compare.
- rewrite (app_nil_end (elements s1)).
+ rewrite <- (app_nil_r (elements s1)).
  replace (elements s2) with (flatten_e (cons s2 End)) by
-  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
+  (rewrite cons_1; simpl; rewrite app_nil_r; auto).
  apply compare_cont_Cmp; auto.
  intros.
  apply compare_end_Cmp; auto.
@@ -1129,14 +1131,14 @@ Proof.
 Qed.
 
 Lemma maxdepth_log_cardinal s : s <> Leaf ->
- log2 (cardinal s) < maxdepth s.
+ Nat.log2 (cardinal s) < maxdepth s.
 Proof.
  intros H.
  apply Nat.log2_lt_pow2. destruct s; simpl; intuition.
  apply maxdepth_cardinal.
 Qed.
 
-Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)).
+Lemma mindepth_log_cardinal s : mindepth s <= Nat.log2 (S (cardinal s)).
 Proof.
  apply Nat.log2_le_pow2. auto with arith.
  apply mindepth_cardinal.
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
index 6778deff..bd881168 100644
--- a/theories/MSets/MSetInterface.v
+++ b/theories/MSets/MSetInterface.v
@@ -431,7 +431,6 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E.
 
  (** We avoid creating induction principles for the Record *)
  Local Unset Elimination Schemes.
- Local Unset Case Analysis Schemes.
 
  Definition elt := E.t.
 
diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v
index d9b1fd9b..fb0d1ad9 100644
--- a/theories/MSets/MSetList.v
+++ b/theories/MSets/MSetList.v
@@ -56,7 +56,7 @@ Module Ops (X:OrderedType) <: WOps X.
 
   Definition singleton (x : elt) := x :: nil.
 
-  Fixpoint remove x s :=
+  Fixpoint remove x s : t :=
     match s with
     | nil => nil
     | y :: l =>
@@ -228,16 +228,14 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Notation Inf := (lelistA X.lt).
   Notation In := (InA X.eq).
 
-  (* TODO: modify proofs in order to avoid these hints *)
-  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
-  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
-  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).
+  Existing Instance X.eq_equiv.
+  Hint Extern 20 => solve [order].
 
   Definition IsOk s := Sort s.
 
   Class Ok (s:t) : Prop := ok : Sort s.
 
-  Hint Resolve @ok.
+  Hint Resolve ok.
   Hint Unfold Ok.
 
   Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }.
@@ -343,7 +341,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   induction s; simpl; intros.
   intuition. inv; auto.
   elim_compare x a; inv; rewrite !InA_cons, ?IHs; intuition.
-  left; order.
   Qed.
 
   Lemma remove_inf :
@@ -402,8 +399,8 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s').
   Proof.
   repeat rewrite <- isok_iff; revert s s'.
-  induction2; constructors; try apply @ok; auto.
-  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto.
+  induction2; constructors; try apply @ok; auto. 
+  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto; order.
   change (Inf x' (union (x :: l) l')); auto.
   Qed.
 
@@ -412,7 +409,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
    In x (union s s') <-> In x s \/ In x s'.
   Proof.
   induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
-  left; order.
   Qed.
 
   Lemma inter_inf :
@@ -440,7 +436,6 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
   Proof.
   induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
    try sort_inf_in; try order.
-  left; order.
   Qed.
 
   Lemma diff_inf :
@@ -477,7 +472,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
    equal s s' = true <-> Equal s s'.
   Proof.
   induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
-  intuition.
+  intuition reflexivity. 
   split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
   split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
   inv.
@@ -825,7 +820,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X.
 
   Lemma compare_spec_aux : forall s s', CompSpec eq L.lt s s' (compare s s').
   Proof.
-  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
+  induction s as [|x s IH]; intros [|x' s']; simpl; intuition. 
   elim_compare x x'; auto.
   Qed.
 
diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v
index e500602f..25a8c162 100644
--- a/theories/MSets/MSetPositive.v
+++ b/theories/MSets/MSetPositive.v
@@ -19,14 +19,9 @@
 Require Import Bool BinPos Orders MSetInterface.
 
 Set Implicit Arguments.
-
 Local Open Scope lazy_bool_scope.
 Local Open Scope positive_scope.
-
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
-Local Unset Boolean Equality Schemes.
-
 
 (** Even if [positive] can be seen as an ordered type with respect to the
   usual order (see above), we can also use a lexicographic order over bits
@@ -98,7 +93,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Module E:=PositiveOrderedTypeBits.
 
-  Definition elt := positive.
+  Definition elt := positive : Type.
 
   Inductive tree :=
     | Leaf : tree
@@ -106,9 +101,9 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   Scheme tree_ind := Induction for tree Sort Prop.
 
-  Definition t := tree.
+  Definition t := tree : Type.
 
-  Definition empty := Leaf.
+  Definition empty : t := Leaf.
 
   Fixpoint is_empty (m : t) : bool :=
    match m with
@@ -116,7 +111,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     | Node l b r => negb b &&& is_empty l &&& is_empty r
    end.
 
-  Fixpoint mem (i : positive) (m : t) : bool :=
+  Fixpoint mem (i : positive) (m : t) {struct m} : bool :=
     match m with
     | Leaf => false
     | Node l o r =>
@@ -147,13 +142,13 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** helper function to avoid creating empty trees that are not leaves *)
 
-  Definition node l (b: bool) r :=
+  Definition node (l : t) (b: bool) (r : t) : t :=
     if b then Node l b r else
      match l,r with
        | Leaf,Leaf => Leaf
        | _,_ => Node l false r end.
 
-  Fixpoint remove (i : positive) (m : t) : t :=
+  Fixpoint remove (i : positive) (m : t) {struct m} : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -164,7 +159,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint union (m m': t) :=
+  Fixpoint union (m m': t) : t :=
     match m with
       | Leaf => m'
       | Node l o r =>
@@ -174,7 +169,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint inter (m m': t) :=
+  Fixpoint inter (m m': t) : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -184,7 +179,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint diff (m m': t) :=
+  Fixpoint diff (m m': t) : t :=
     match m with
       | Leaf => Leaf
       | Node l o r =>
@@ -216,7 +211,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** reverses [y] and concatenate it with [x] *)
 
-  Fixpoint rev_append y x :=
+  Fixpoint rev_append (y x : elt) : elt :=
     match y with
       | 1 => x
       | y~1 => rev_append y x~1
@@ -267,14 +262,14 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       end.
     Definition exists_ m := xexists m 1.
 
-    Fixpoint xfilter (m : t) (i : positive) :=
+    Fixpoint xfilter (m : t) (i : positive) : t :=
       match m with
         | Leaf => Leaf
         | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
       end.
     Definition filter m := xfilter m 1.
 
-    Fixpoint xpartition (m : t) (i : positive) :=
+    Fixpoint xpartition (m : t) (i : positive) : t * t :=
       match m with
         | Leaf => (Leaf,Leaf)
         | Node l o r =>
@@ -316,7 +311,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
 
   (** would it be more efficient to use a path like in the above functions ? *)
 
-  Fixpoint choose (m: t) :=
+  Fixpoint choose (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r => if o then Some 1 else
@@ -326,7 +321,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint min_elt (m: t) :=
+  Fixpoint min_elt (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r =>
@@ -336,7 +331,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         end
     end.
 
-  Fixpoint max_elt (m: t) :=
+  Fixpoint max_elt (m: t) : option elt :=
     match m with
       | Leaf => None
       | Node l o r =>
@@ -414,10 +409,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     case o; trivial.
     destruct l; trivial.
     destruct r; trivial.
-    symmetry. destruct x.
-      apply mem_Leaf.
-      apply mem_Leaf.
-      reflexivity.
+    destruct x; reflexivity.
   Qed.
   Local Opaque node.
 
@@ -427,7 +419,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Proof.
     unfold Empty, In.
     induction s as [|l IHl o r IHr]; simpl.
-      setoid_rewrite mem_Leaf. firstorder.
+      firstorder.
       rewrite <- 2andb_lazy_alt, 2andb_true_iff, IHl, IHr. clear IHl IHr.
       destruct o; simpl; split.
         intuition discriminate.
@@ -813,7 +805,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
        rewrite <- andb_lazy_alt. apply andb_true_iff.
   Qed.
 
-  Lemma filter_spec: forall s x f, compat_bool E.eq f ->
+  Lemma filter_spec: forall s x f, @compat_bool elt E.eq f ->
     (In x (filter f s) <-> In x s /\ f x = true).
   Proof. intros. apply xfilter_spec. Qed.
 
@@ -824,7 +816,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Proof.
     unfold For_all, In. intro f.
     induction s as [|l IHl o r IHr]; intros i; simpl.
-     setoid_rewrite mem_Leaf. intuition discriminate.
+    intuition discriminate.
      rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
      rewrite IHl, IHr. clear IHl IHr.
       split.
@@ -838,7 +830,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
         apply H. assumption.
   Qed.
 
-  Lemma for_all_spec: forall s f, compat_bool E.eq f ->
+  Lemma for_all_spec: forall s f, @compat_bool elt E.eq f ->
     (for_all f s = true <-> For_all (fun x => f x = true) s).
   Proof. intros. apply xforall_spec. Qed.
 
@@ -849,7 +841,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
   Proof.
     unfold Exists, In. intro f.
     induction s as [|l IHl o r IHr]; intros i; simpl.
-     setoid_rewrite mem_Leaf. firstorder.
+     firstorder.
      rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
      rewrite IHl, IHr. clear IHl IHr.
       split.
@@ -860,7 +852,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
        intros [[x|x|] H]; eauto.
   Qed.
 
-  Lemma exists_spec : forall s f, compat_bool E.eq f ->
+  Lemma exists_spec : forall s f, @compat_bool elt E.eq f ->
     (exists_ f s = true <-> Exists (fun x => f x = true) s).
   Proof. intros. apply xexists_spec. Qed.
 
@@ -876,11 +868,11 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
       destruct o; simpl; rewrite IHl, IHr; reflexivity.
   Qed.
 
-  Lemma partition_spec1 : forall s f, compat_bool E.eq f ->
+  Lemma partition_spec1 : forall s f, @compat_bool elt E.eq f ->
       Equal (fst (partition f s)) (filter f s).
   Proof. intros. rewrite partition_filter. reflexivity. Qed.
 
-  Lemma partition_spec2 : forall s f, compat_bool E.eq f ->
+  Lemma partition_spec2 : forall s f, @compat_bool elt E.eq f ->
       Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
   Proof. intros. rewrite partition_filter. reflexivity. Qed.
 
@@ -897,7 +889,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
     induction s as [|l IHl o r IHr]; simpl.
       intros. split; intro H.
         left. assumption.
-        destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_spec Hx').
+        destruct H as [H|[x [Hx Hx']]]. assumption. discriminate.
 
       intros j acc y. case o.
         rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
@@ -1087,7 +1079,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
           destruct (min_elt r).
             injection H. intros <-. clear H.
             destruct y as [z|z|].
-              apply (IHr p z); trivial.
+              apply (IHr e z); trivial.
               elim (Hp _ H').
               discriminate.
             discriminate.
@@ -1141,7 +1133,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
             injection H. intros <-. clear H.
             destruct y as [z|z|].
               elim (Hp _ H').
-              apply (IHl p z); trivial.
+              apply (IHl e z); trivial.
               discriminate.
             discriminate.
   Qed.
diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v
index b838495f..751d4f35 100644
--- a/theories/MSets/MSetRBT.v
+++ b/theories/MSets/MSetRBT.v
@@ -31,13 +31,12 @@ Additional suggested reading:
 *)
 
 Require MSetGenTree.
-Require Import Bool List BinPos Pnat Setoid SetoidList NPeano.
+Require Import Bool List BinPos Pnat Setoid SetoidList PeanoNat.
 Local Open Scope list_scope.
 
 (* For nicer extraction, we create induction principles
    only when needed *)
 Local Unset Elimination Schemes.
-Local Unset Case Analysis Schemes.
 
 (** An extra function not (yet?) in MSetInterface.S *)
 
@@ -399,7 +398,7 @@ Definition skip_black t :=
 Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison :=
  match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with
  | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ =>
-   compare_height (skip_black s2x') s1' s2' (skip_black s2x')
+   compare_height (skip_black s1x') s1' s2' (skip_black s2x')
  | _, Leaf, _, Node _ _ _ _ => Lt
  | Node _ _ _ _, _, Leaf, _ => Gt
  | Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf =>
@@ -452,7 +451,7 @@ Local Notation Bk := (Node Black).
 Local Hint Immediate MX.eq_sym.
 Local Hint Unfold In lt_tree gt_tree Ok.
 Local Hint Constructors InT bst.
-Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans ok.
 Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
 Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
 Local Hint Resolve elements_spec2.
@@ -980,7 +979,7 @@ Proof.
   { transitivity size; trivial. subst. auto with arith. }
  destruct acc1 as [|x acc1].
   { exfalso. revert LE. apply Nat.lt_nge. subst.
-    rewrite <- app_nil_end, <- elements_cardinal; auto with arith. }
+    rewrite app_nil_r, <- elements_cardinal; auto with arith. }
  specialize (Hg acc1).
  destruct (g acc1) as (t2,acc2).
  destruct Hg as (Hg1,Hg2).
@@ -988,7 +987,7 @@ Proof.
     rewrite app_length, <- elements_cardinal. simpl.
     rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
     apply Nat.add_le_mono_l. }
- simpl. rewrite elements_node, app_ass. now subst.
+ rewrite elements_node, app_ass. now subst.
 Qed.
 
 Lemma treeify_aux_spec n (p:bool) :
@@ -1013,7 +1012,7 @@ Qed.
 Lemma plength_aux_spec l p :
   Pos.to_nat (plength_aux l p) = length l + Pos.to_nat p.
 Proof.
- revert p. induction l; simpl; trivial.
+ revert p. induction l; trivial. simpl plength_aux.
  intros. now rewrite IHl, Pos2Nat.inj_succ, Nat.add_succ_r.
 Qed.
 
@@ -1059,7 +1058,7 @@ Lemma filter_aux_elements s f acc :
  filter_aux f s acc = List.filter f (elements s) ++ acc.
 Proof.
  revert acc.
- induction s as [|c l IHl x r IHr]; simpl; trivial.
+ induction s as [|c l IHl x r IHr]; trivial.
  intros acc.
  rewrite elements_node, filter_app. simpl.
  destruct (f x); now rewrite IHl, IHr, app_ass.
@@ -1197,7 +1196,7 @@ Lemma INV_rev l1 l2 acc :
 Proof.
  intros. rewrite rev_append_rev.
  apply SortA_app with X.eq; eauto with *.
- intros x y. inA. eapply l1_lt_acc; eauto.
+ intros x y. inA. eapply @l1_lt_acc; eauto.
 Qed.
 
 (** ** union *)
@@ -1567,7 +1566,7 @@ Proof.
 Qed.
 
 Lemma maxdepth_upperbound s : Rbt s ->
- maxdepth s <= 2 * log2 (S (cardinal s)).
+ maxdepth s <= 2 * Nat.log2 (S (cardinal s)).
 Proof.
  intros (n,H).
  eapply Nat.le_trans; [eapply rb_maxdepth; eauto|].
@@ -1582,7 +1581,7 @@ Proof.
 Qed.
 
 Lemma maxdepth_lowerbound s : s<>Leaf ->
- log2 (cardinal s) < maxdepth s.
+ Nat.log2 (cardinal s) < maxdepth s.
 Proof.
  apply maxdepth_log_cardinal.
 Qed.
diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v
index fd4114cd..372acd56 100644
--- a/theories/MSets/MSetWeakList.v
+++ b/theories/MSets/MSetWeakList.v
@@ -56,8 +56,8 @@ Module Ops (X: DecidableType) <: WOps X.
         if X.eq_dec x y then l else y :: remove x l
     end.
 
-  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
-    fold_left (flip f) s i.
+  Definition fold (B : Type) (f : elt -> B -> B) : t -> B -> B :=
+    fold_left (flip f).
 
   Definition union (s : t) : t -> t := fold add s.
 
@@ -118,16 +118,18 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
   Notation In := (InA X.eq).
 
   (* TODO: modify proofs in order to avoid these hints *)
-  Hint Resolve (@Equivalence_Reflexive _ _ X.eq_equiv).
-  Hint Immediate (@Equivalence_Symmetric _ _ X.eq_equiv).
-  Hint Resolve (@Equivalence_Transitive _ _ X.eq_equiv).
+  Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv).
+  Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv).
+  Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv).
+  Hint Resolve eqr eqtrans.
+  Hint Immediate eqsym.
 
   Definition IsOk := NoDup.
 
   Class Ok (s:t) : Prop := ok : NoDup s.
 
   Hint Unfold Ok.
-  Hint Resolve @ok.
+  Hint Resolve ok.
 
   Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }.
 
@@ -215,10 +217,10 @@ Module MakeRaw (X:DecidableType) <: WRawSets X.
   Proof.
   induction s; simpl; intros.
   intuition; inv; auto.
-  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
+  destruct X.eq_dec as [|Hnot]; inv; rewrite !InA_cons, ?IHs; intuition.
   elim H. setoid_replace a with y; eauto.
   elim H3. setoid_replace x with y; eauto.
-  elim n. eauto.
+  elim Hnot. eauto.
   Qed.
 
   Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index 1023924e..641ec02f 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -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 @@
 
 Require Export BinNums.
 Require Import BinPos RelationClasses Morphisms Setoid
- Equalities OrdersFacts GenericMinMax Bool NAxioms NProperties.
+ Equalities OrdersFacts GenericMinMax Bool NAxioms NMaxMin NProperties.
 Require BinNatDef.
 
 (**********************************************************************)
@@ -66,6 +66,20 @@ Notation "( p | q )" := (divide p q) (at level 0) : N_scope.
 Definition Even n := exists m, n = 2*m.
 Definition Odd n := exists m, n = 2*m+1.
 
+(** Proofs of morphisms, obvious since eq is Leibniz *)
+
+Local Obligation Tactic := simpl_relation.
+Program Definition succ_wd : Proper (eq==>eq) succ := _.
+Program Definition pred_wd : Proper (eq==>eq) pred := _.
+Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
+Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
+Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
+Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
+Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
+Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
+Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
+Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
+
 (** Decidability of equality. *)
 
 Definition eq_dec : forall n m : N, { n = m } + { n <> m }.
@@ -138,6 +152,50 @@ Proof.
 apply peano_rect_succ.
 Qed.
 
+(** Generic induction / recursion *)
+
+Theorem bi_induction :
+  forall A : N -> Prop, Proper (Logic.eq==>iff) A ->
+    A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n.
+Proof.
+intros A A_wd A0 AS. apply peano_rect. assumption. intros; now apply -> AS.
+Qed.
+
+Definition recursion {A} : A -> (N -> A -> A) -> N -> A :=
+  peano_rect (fun _ => A).
+
+Instance recursion_wd {A} (Aeq : relation A) :
+ Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion.
+Proof.
+intros a a' Ea f f' Ef x x' Ex. subst x'.
+induction x using peano_ind.
+trivial.
+unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef.
+Qed.
+
+Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a.
+Proof. reflexivity. Qed.
+
+Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A):
+ Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f ->
+  forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
+Proof.
+unfold recursion; intros a_wd f_wd n. induction n using peano_ind.
+rewrite peano_rect_succ. now apply f_wd.
+rewrite !peano_rect_succ in *. now apply f_wd.
+Qed.
+
+(** Specification of constants *)
+
+Lemma one_succ : 1 = succ 0.
+Proof. reflexivity. Qed.
+
+Lemma two_succ : 2 = succ 1.
+Proof. reflexivity. Qed.
+
+Definition pred_0 : pred 0 = 0.
+Proof. reflexivity. Qed.
+
 (** Properties of mixed successor and predecessor. *)
 
 Lemma pos_pred_spec p : Pos.pred_N p = pred (pos p).
@@ -262,69 +320,30 @@ Qed.
 
 Include BoolOrderFacts.
 
-(** We regroup here some results used for proving the correctness
-    of more advanced functions. These results will also be provided
-    by the generic functor of properties about natural numbers
-    instantiated at the end of the file. *)
-
-Module Import Private_BootStrap.
-
-Theorem add_0_r n : n + 0 = n.
-Proof.
-now destruct n.
-Qed.
-
-Theorem add_comm n m : n + m = m + n.
-Proof.
-destruct n, m; simpl; try reflexivity. simpl. f_equal. apply Pos.add_comm.
-Qed.
-
-Theorem add_assoc n m p : n + (m + p) = n + m + p.
-Proof.
-destruct n; try reflexivity.
-destruct m; try reflexivity.
-destruct p; try reflexivity.
-simpl. f_equal. apply Pos.add_assoc.
-Qed.
-
-Lemma sub_add n m : n <= m -> m - n + n = m.
-Proof.
- destruct n as [|p], m as [|q]; simpl; try easy'. intros H.
- case Pos.sub_mask_spec; intros; simpl; subst; trivial.
- now rewrite Pos.add_comm.
- apply Pos.le_nlt in H. elim H. apply Pos.lt_add_r.
-Qed.
+(** Specification of minimum and maximum *)
 
-Theorem mul_comm n m : n * m = m * n.
+Theorem min_l n m : n <= m -> min n m = n.
 Proof.
-destruct n, m; simpl; trivial. f_equal. apply Pos.mul_comm.
+unfold min, le. case compare; trivial. now destruct 1.
 Qed.
 
-Lemma le_0_l n : 0<=n.
+Theorem min_r n m : m <= n -> min n m = m.
 Proof.
-now destruct n.
+unfold min, le. rewrite compare_antisym.
+case compare_spec; trivial. now destruct 2.
 Qed.
 
-Lemma leb_spec n m : BoolSpec (n<=m) (m<n) (n <=? m).
+Theorem max_l n m : m <= n -> max n m = n.
 Proof.
- unfold le, lt, leb. rewrite (compare_antisym n m).
- case compare; now constructor.
+unfold max, le. rewrite compare_antisym.
+case compare_spec; auto. now destruct 2.
 Qed.
 
-Lemma add_lt_cancel_l n m p : p+n < p+m -> n<m.
+Theorem max_r n m : n <= m -> max n m = m.
 Proof.
- intro H. destruct p. simpl; auto.
- destruct n; destruct m.
- elim (Pos.lt_irrefl _ H).
- red; auto.
- rewrite add_0_r in H. simpl in H.
- red in H. simpl in H.
- elim (Pos.lt_not_add_l _ _ H).
- now apply (Pos.add_lt_mono_l p).
+unfold max, le. case compare; trivial. now destruct 1.
 Qed.
 
-End Private_BootStrap.
-
 (** Specification of lt and le. *)
 
 Lemma lt_succ_r n m : n < succ m <-> n<=m.
@@ -334,6 +353,13 @@ split. now destruct p. now destruct 1.
 apply Pos.lt_succ_r.
 Qed.
 
+(** We can now derive all properties of basic functions and orders,
+    and use these properties for proving the specs of more advanced
+    functions. *)
+
+Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+
 (** Properties of [double] and [succ_double] *)
 
 Lemma double_spec n : double n = 2 * n.
@@ -395,30 +421,6 @@ Proof.
 Qed.
 
 
-(** Specification of minimum and maximum *)
-
-Theorem min_l n m : n <= m -> min n m = n.
-Proof.
-unfold min, le. case compare; trivial. now destruct 1.
-Qed.
-
-Theorem min_r n m : m <= n -> min n m = m.
-Proof.
-unfold min, le. rewrite compare_antisym.
-case compare_spec; trivial. now destruct 2.
-Qed.
-
-Theorem max_l n m : m <= n -> max n m = n.
-Proof.
-unfold max, le. rewrite compare_antisym.
-case compare_spec; auto. now destruct 2.
-Qed.
-
-Theorem max_r n m : n <= m -> max n m = m.
-Proof.
-unfold max, le. case compare; trivial. now destruct 1.
-Qed.
-
 (** 0 is the least natural number *)
 
 Theorem compare_0_r n : (n ?= 0) <> Lt.
@@ -560,13 +562,13 @@ Proof.
   (* a~1 *)
   destruct pos_div_eucl as (q,r); simpl in *.
   case leb_spec; intros H; simpl; trivial.
-  apply add_lt_cancel_l with b. rewrite add_comm, sub_add by trivial.
+  apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial.
   destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
   apply (succ_double_lt _ _ IHa).
   (* a~0 *)
   destruct pos_div_eucl as (q,r); simpl in *.
   case leb_spec; intros H; simpl; trivial.
-  apply add_lt_cancel_l with b. rewrite add_comm, sub_add by trivial.
+  apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial.
   destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
   now destruct r.
   (* 1 *)
@@ -754,7 +756,7 @@ Proof.
  destruct m. now destruct (shiftl a n).
  rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l.
  apply IHn.
- apply add_lt_cancel_l with 1. rewrite 2 (add_succ_l 0). simpl.
+ apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl.
  now rewrite succ_pos_pred.
 Qed.
 
@@ -833,71 +835,10 @@ Proof.
  apply pos_ldiff_spec.
 Qed.
 
-(** Specification of constants *)
-
-Lemma one_succ : 1 = succ 0.
-Proof. reflexivity. Qed.
-
-Lemma two_succ : 2 = succ 1.
-Proof. reflexivity. Qed.
-
-Definition pred_0 : pred 0 = 0.
-Proof. reflexivity. Qed.
-
-(** Proofs of morphisms, obvious since eq is Leibniz *)
-
-Local Obligation Tactic := simpl_relation.
-Program Definition succ_wd : Proper (eq==>eq) succ := _.
-Program Definition pred_wd : Proper (eq==>eq) pred := _.
-Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
-Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
-Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
-Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
-Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
-Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
-Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
-Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
-
-(** Generic induction / recursion *)
-
-Theorem bi_induction :
-  forall A : N -> Prop, Proper (Logic.eq==>iff) A ->
-    A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n.
-Proof.
-intros A A_wd A0 AS. apply peano_rect. assumption. intros; now apply -> AS.
-Qed.
-
-Definition recursion {A} : A -> (N -> A -> A) -> N -> A :=
-  peano_rect (fun _ => A).
+(** Instantiation of generic properties of advanced functions
+    (pow, sqrt, log2, div, gcd, ...) *)
 
-Instance recursion_wd {A} (Aeq : relation A) :
- Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion.
-Proof.
-intros a a' Ea f f' Ef x x' Ex. subst x'.
-induction x using peano_ind.
-trivial.
-unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef.
-Qed.
-
-Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a.
-Proof. reflexivity. Qed.
-
-Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A):
- Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f ->
-  forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
-Proof.
-unfold recursion; intros a_wd f_wd n. induction n using peano_ind.
-rewrite peano_rect_succ. now apply f_wd.
-rewrite !peano_rect_succ in *. now apply f_wd.
-Qed.
-
-(** Instantiation of generic properties of natural numbers *)
-
-(** The Bind Scope prevents N to stay associated with abstract_scope.
-    (TODO FIX) *)
-
-Include NProp. Bind Scope N_scope with N.
-Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+Include NExtraProp.
 
 (** In generic statements, the predicates [lt] and [le] have been
   favored, whereas [gt] and [ge] don't even exist in the abstract
@@ -946,7 +887,7 @@ Proof.
  destruct n as [|n]; simpl in *.
  destruct m. now destruct p. elim (Pos.nlt_1_r _ H).
  rewrite Pos.iter_succ. simpl.
- set (u:=Pos.iter n xO p) in *; clearbody u.
+ set (u:=Pos.iter xO p n) in *; clearbody u.
  destruct m as [|m]. now destruct u.
  rewrite <- (IHn (Pos.pred_N m)).
  rewrite <- (testbit_odd_succ _ (Pos.pred_N m)).
@@ -970,7 +911,7 @@ Proof.
  rewrite <- IHn.
  rewrite testbit_succ_r_div2 by apply le_0_l.
  f_equal. simpl. rewrite Pos.iter_succ.
- now destruct (Pos.iter n xO p).
+ now destruct (Pos.iter xO p n).
  apply succ_le_mono. now rewrite succ_pos_pred.
 Qed.
 
@@ -983,6 +924,8 @@ Qed.
 
 End N.
 
+Bind Scope N_scope with N.t N.
+
 (** Exportation of notations *)
 
 Infix "+" := N.add : N_scope.
diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v
index 9abf4955..9de2e7e1 100644
--- a/theories/NArith/BinNatDef.v
+++ b/theories/NArith/BinNatDef.v
@@ -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        *)
@@ -325,8 +325,8 @@ Definition lxor n m :=
 
 (** Shifts *)
 
-Definition shiftl_nat (a:N)(n:nat) := nat_iter n double a.
-Definition shiftr_nat (a:N)(n:nat) := nat_iter n div2 a.
+Definition shiftl_nat (a:N) := nat_rect _ a (fun _ => double).
+Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2).
 
 Definition shiftl a n :=
   match a with
@@ -337,7 +337,7 @@ Definition shiftl a n :=
 Definition shiftr a n :=
   match n with
     | 0 => a
-    | pos p => Pos.iter p div2 a
+    | pos p => Pos.iter div2 a p
   end.
 
 (** Checking whether a particular bit is set or not *)
@@ -375,7 +375,7 @@ Definition of_nat (n:nat) :=
 Definition iter (n:N) {A} (f:A->A) (x:A) : A :=
   match n with
     | 0 => x
-    | pos p => Pos.iter p f x
+    | pos p => Pos.iter f x p
   end.
 
 End N.
\ No newline at end of file
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
index ff0be4a3..43614543 100644
--- a/theories/NArith/NArith.v
+++ b/theories/NArith/NArith.v
@@ -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/theories/NArith/Ndec.v b/theories/NArith/Ndec.v
index e38ce5ba..5b1815bd 100644
--- a/theories/NArith/Ndec.v
+++ b/theories/NArith/Ndec.v
@@ -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        *)
@@ -119,11 +119,11 @@ Lemma Nneq_elim a a' :
    N.odd a = negb (N.odd a') \/
    N.eqb (N.div2 a) (N.div2 a') = false.
 Proof.
-  intros. cut (N.odd a = N.odd a' \/ N.odd a = negb (N.odd a')).
-  intros. elim H0. intro. right. apply Ndiv2_bit_neq. assumption.
-  assumption.
-  intro. left. assumption.
-  case (N.odd a), (N.odd a'); auto.
+  intros.
+  enough (N.odd a = N.odd a' \/ N.odd a = negb (N.odd a')) as [].
+  - right. apply Ndiv2_bit_neq; assumption.
+  - left. assumption.
+  - case (N.odd a), (N.odd a'); auto.
 Qed.
 
 Lemma Ndouble_or_double_plus_un a :
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
index 764ecc12..55ef451e 100644
--- a/theories/NArith/Ndigits.v
+++ b/theories/NArith/Ndigits.v
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Bool Morphisms Setoid Bvector BinPos BinNat Wf_nat
- Pnat Nnat Compare_dec Lt Minus.
+Require Import Bool Morphisms Setoid Bvector BinPos BinNat PeanoNat Pnat Nnat.
 
 Local Open Scope N_scope.
 
@@ -86,7 +85,7 @@ Lemma Nshiftl_nat_equiv :
  forall a n, N.shiftl_nat a (N.to_nat n) = N.shiftl a n.
 Proof.
  intros [|a] [|n]; simpl; unfold N.shiftl_nat; trivial.
- apply nat_iter_invariant; intros; now subst.
+ induction (Pos.to_nat n) as [|? H]; simpl; now try rewrite H.
  rewrite <- Pos2Nat.inj_iter. symmetry. now apply Pos.iter_swap_gen.
 Qed.
 
@@ -103,7 +102,7 @@ Lemma Nshiftr_nat_spec : forall a n m,
 Proof.
  induction n; intros m.
  now rewrite <- plus_n_O.
- simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn, Nshiftr_nat_S.
+ simpl. rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn.
  destruct (N.shiftr_nat a n) as [|[p|p|]]; simpl; trivial.
 Qed.
 
@@ -111,10 +110,12 @@ Lemma Nshiftl_nat_spec_high : forall a n m, (n<=m)%nat ->
   N.testbit_nat (N.shiftl_nat a n) m = N.testbit_nat a (m-n).
 Proof.
  induction n; intros m H.
- now rewrite <- minus_n_O.
- destruct m. inversion H. apply le_S_n in H.
- simpl. rewrite <- IHn, Nshiftl_nat_S; trivial.
- destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial.
+ - now rewrite Nat.sub_0_r.
+ - destruct m.
+   + inversion H.
+   + apply le_S_n in H.
+     simpl. rewrite <- IHn; trivial.
+     destruct (N.shiftl_nat a n) as [|[p|p|]]; simpl; trivial.
 Qed.
 
 Lemma Nshiftl_nat_spec_low : forall a n m, (m<n)%nat ->
@@ -123,9 +124,10 @@ Proof.
  induction n; intros m H. inversion H.
  rewrite Nshiftl_nat_S.
  destruct m.
- destruct (N.shiftl_nat a n); trivial.
- specialize (IHn m (lt_S_n _ _ H)).
- destruct (N.shiftl_nat a n); trivial.
+ - destruct (N.shiftl_nat a n); trivial.
+ - apply Lt.lt_S_n in H.
+   specialize (IHn m H).
+   destruct (N.shiftl_nat a n); trivial.
 Qed.
 
 (** A left shift for positive numbers (used in BigN) *)
@@ -148,7 +150,7 @@ Lemma Pshiftl_nat_plus : forall n m p,
   Pos.shiftl_nat p (m + n) = Pos.shiftl_nat (Pos.shiftl_nat p n) m.
 Proof.
  induction m; simpl; intros. reflexivity.
- rewrite 2 Pshiftl_nat_S. now f_equal.
+ now f_equal.
 Qed.
 
 (** Semantics of bitwise operations with respect to [N.testbit_nat] *)
@@ -446,49 +448,52 @@ Lemma Nless_trans :
    Nless a a' = true -> Nless a' a'' = true -> Nless a a'' = true.
 Proof.
   induction a as [|a IHa|a IHa] using N.binary_ind; intros a' a'' H H0.
-    case_eq (Nless N0 a'') ; intros Heqn. trivial.
-     rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
-    induction a' as [|a' _|a' _] using N.binary_ind.
-      rewrite (Nless_z (N.double a)) in H. discriminate H.
-      rewrite (Nless_def_1 a a') in H.
-       induction a'' using N.binary_ind.
-         rewrite (Nless_z (N.double a')) in H0. discriminate H0.
-         rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a'').
-          exact (IHa _ _ H H0).
-         apply Nless_def_3.
-      induction a'' as [|a'' _|a'' _] using N.binary_ind.
-        rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
-        rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
-        apply Nless_def_3.
-    induction a' as [|a' _|a' _] using N.binary_ind.
-      rewrite (Nless_z (N.succ_double a)) in H. discriminate H.
-      rewrite (Nless_def_4 a a') in H. discriminate H.
+  - case_eq (Nless N0 a'') ; intros Heqn.
+    + trivial.
+    + rewrite (N0_less_2 a'' Heqn), (Nless_z a') in H0. discriminate H0.
+  - induction a' as [|a' _|a' _] using N.binary_ind.
+    + rewrite (Nless_z (N.double a)) in H. discriminate H.
+    + rewrite (Nless_def_1 a a') in H.
       induction a'' using N.binary_ind.
-        rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
-        rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
-        rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
-          rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
+      * rewrite (Nless_z (N.double a')) in H0. discriminate H0.
+      * rewrite (Nless_def_1 a' a'') in H0. rewrite (Nless_def_1 a a'').
+        exact (IHa _ _ H H0).
+      * apply Nless_def_3.
+    + induction a'' as [|a'' _|a'' _] using N.binary_ind.
+      * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
+      * rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
+      * apply Nless_def_3.
+  - induction a' as [|a' _|a' _] using N.binary_ind.
+    + rewrite (Nless_z (N.succ_double a)) in H. discriminate H.
+    + rewrite (Nless_def_4 a a') in H. discriminate H.
+    + induction a'' using N.binary_ind.
+      * rewrite (Nless_z (N.succ_double a')) in H0. discriminate H0.
+      * rewrite (Nless_def_4 a' a'') in H0. discriminate H0.
+      * rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H.
+        rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0).
 Qed.
 
 Lemma Nless_total :
  forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}.
 Proof.
   induction a using N.binary_rec; intro a'.
-    case_eq (Nless N0 a') ; intros Heqb. left. left. auto.
-     right. rewrite (N0_less_2 a' Heqb). reflexivity.
-    induction a' as [|a' _|a' _] using N.binary_rec.
-      case_eq (Nless N0 (N.double a)) ; intros Heqb. left. right. auto.
-       right. exact (N0_less_2 _  Heqb).
-      rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
-        left. assumption.
-        right. reflexivity.
-    left. left. apply Nless_def_3.
-    induction a' as [|a' _|a' _] using N.binary_rec.
-      left. right. destruct a; reflexivity.
-      left. right. apply Nless_def_3.
-      rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->].
-        left. assumption.
-        right. reflexivity.
+  - case_eq (Nless N0 a') ; intros Heqb.
+    + left. left. auto.
+    + right. rewrite (N0_less_2 a' Heqb). reflexivity.
+  - induction a' as [|a' _|a' _] using N.binary_rec.
+    + case_eq (Nless N0 (N.double a)) ; intros Heqb.
+      * left. right. auto.
+      * right. exact (N0_less_2 _  Heqb).
+    + rewrite 2!Nless_def_1. destruct (IHa a') as [ | ->].
+      * left. assumption.
+      * right. reflexivity.
+    + left. left. apply Nless_def_3.
+  - induction a' as [|a' _|a' _] using N.binary_rec.
+    + left. right. destruct a; reflexivity.
+    + left. right. apply Nless_def_3.
+    + rewrite 2!Nless_def_2. destruct (IHa a') as [ | ->].
+      * left. assumption.
+      * right. reflexivity.
 Qed.
 
 (** Number of digits in a number *)
@@ -512,9 +517,9 @@ Definition N2Bv (n:N) : Bvector (N.size_nat n) :=
 
 Fixpoint Bv2N (n:nat)(bv:Bvector n) : N :=
   match bv with
-    | Vector.nil => N0
-    | Vector.cons false n bv => N.double (Bv2N n bv)
-    | Vector.cons true n bv => N.succ_double (Bv2N n bv)
+    | Vector.nil _ => N0
+    | Vector.cons _ false n bv => N.double (Bv2N n bv)
+    | Vector.cons _ true n bv => N.succ_double (Bv2N n bv)
   end.
 
 Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n.
@@ -622,7 +627,7 @@ induction bv; intros.
 inversion H.
 destruct p ; simpl.
   destruct (Bv2N n bv); destruct h; simpl in *; auto.
-  specialize IHbv with p (lt_S_n _ _ H).
+  specialize IHbv with p (Lt.lt_S_n _ _ H).
     simpl in * ; destruct (Bv2N n bv); destruct h; simpl in *; auto.
 Qed.
 
@@ -641,7 +646,7 @@ Proof.
 destruct n as [|n].
 inversion H.
 induction n ; destruct p ; unfold Vector.nth_order in *; simpl in * ; auto.
-intros H ; destruct (lt_n_O _ (lt_S_n _ _ H)).
+intros H ; destruct (Lt.lt_n_O _ (Lt.lt_S_n _ _ H)).
 Qed.
 
 (** Binary bitwise operations are the same in the two worlds. *)
diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v
index 0bff1a96..5467f9cb 100644
--- a/theories/NArith/Ndist.v
+++ b/theories/NArith/Ndist.v
@@ -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        *)
@@ -71,7 +71,7 @@ Proof.
   auto with bool arith.
   intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3.
   intros. simpl. unfold Nplength in H.
-  cut (ni (Pplength p0) = ni n0). intro. inversion H4. reflexivity.
+  enough (ni (Pplength p0) = ni n0) by (inversion H4; reflexivity).
   apply H. intros. change (N.testbit_nat (Npos (xO p0)) (S k) = false). apply H2. apply lt_n_S. exact H4.
   exact H3.
   intro. case n. trivial.
@@ -104,10 +104,9 @@ Lemma ni_min_comm : forall d d':natinf, ni_min d d' = ni_min d' d.
 Proof.
   simple induction d. simple induction d'; trivial.
   simple induction d'; trivial. elim n. simple induction n0; trivial.
-  intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0).
-  intro. unfold ni_min. simpl. rewrite H1. reflexivity.
-  cut (ni (min n0 n2) = ni (min n2 n0)). intros.
-  inversion H1; trivial.
+  intros. elim n1; trivial. intros. unfold ni_min in H.
+  enough (min n0 n2 = min n2 n0) by (unfold ni_min; simpl; rewrite H1; reflexivity).
+  enough (ni (min n0 n2) = ni (min n2 n0)) by (inversion H1; trivial).
   exact (H n2).
 Qed.
 
@@ -116,10 +115,10 @@ Lemma ni_min_assoc :
 Proof.
   simple induction d; trivial. simple induction d'; trivial.
   simple induction d''; trivial.
-  unfold ni_min. intro. cut (min (min n n0) n1 = min n (min n0 n1)).
-  intro. rewrite H. reflexivity.
-  generalize n0 n1. elim n; trivial.
-  simple induction n3; trivial. simple induction n5; trivial.
+  unfold ni_min. intro. 
+  enough (min (min n n0) n1 = min n (min n0 n1)) by (rewrite H; reflexivity).
+  induction n in n0, n1 |- *; trivial.
+  destruct n0; trivial. destruct n1; trivial.
   intros. simpl. auto.
 Qed.
 
@@ -174,15 +173,13 @@ Qed.
 
 Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'.
 Proof.
-  simple induction d. intro. right. exact (ni_min_inf_l d').
-  simple induction d'. left. exact (ni_min_inf_r (ni n)).
-  unfold ni_min. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0).
-  intros. case (H n0). intro. left. rewrite H0. reflexivity.
-  intro. right. rewrite H0. reflexivity.
-  elim n. intro. left. reflexivity.
-  simple induction n1. right. reflexivity.
-  intros. case (H n2). intro. left. simpl. rewrite H1. reflexivity.
-  intro. right. simpl. rewrite H1. reflexivity.
+  destruct d. right. exact (ni_min_inf_l d').
+  destruct d'. left. exact (ni_min_inf_r (ni n)).
+  unfold ni_min.
+  enough (min n n0 = n \/ min n n0 = n0) as [-> | ->].
+  left. reflexivity.
+  right. reflexivity.
+  destruct (Nat.min_dec n n0); [left|right]; assumption.
 Qed.
 
 Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d.
@@ -208,11 +205,7 @@ Qed.
 
 Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n).
 Proof.
-  cut (forall m n:nat, m <= n -> min m n = m).
-  intros. unfold ni_le, ni_min. rewrite (H m n H0). reflexivity.
-  simple induction m. trivial.
-  simple induction n0. intro. inversion H0.
-  intros. simpl. rewrite (H n1 (le_S_n n n1 H1)). reflexivity.
+  intros * H. unfold ni_le, ni_min. rewrite (Peano.min_l m n H). reflexivity.
 Qed.
 
 Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n.
@@ -298,30 +291,28 @@ Proof.
   rewrite (ni_min_inf_l (Nplength a')) in H.
   rewrite (Nplength_infty a' H). simpl. apply ni_le_refl.
   intros. unfold Nplength at 1. apply Nplength_lb. intros.
-  cut (forall a'':N, N.lxor (Npos p) a' = a'' -> N.testbit_nat a'' k = false).
-  intros. apply H1. reflexivity.
+  enough (forall a'':N, N.lxor (Npos p) a' = a'' -> N.testbit_nat a'' k = false).
+  { apply H1. reflexivity. }
   intro a''. case a''. intro. reflexivity.
   intros. rewrite <- H1. rewrite (Nxor_semantics (Npos p) a' k).
   rewrite
    (Nplength_zeros (Npos p) (Pplength p)
       (eq_refl (Nplength (Npos p))) k H0).
-  generalize H. case a'. trivial.
-  intros. cut (N.testbit_nat (Npos p1) k = false). intros. rewrite H3. reflexivity.
+  destruct a'. trivial.
+  enough (N.testbit_nat (Npos p1) k = false) as -> by reflexivity.
   apply Nplength_zeros with (n := Pplength p1). reflexivity.
   apply (lt_le_trans k (Pplength p) (Pplength p1)). exact H0.
-  apply ni_le_le. exact H2.
+  apply ni_le_le. exact H.
 Qed.
 
 Lemma Nplength_ultra :
  forall a a':N,
    ni_le (ni_min (Nplength a) (Nplength a')) (Nplength (N.lxor a a')).
 Proof.
-  intros. case (ni_le_total (Nplength a) (Nplength a')). intro.
-  cut (ni_min (Nplength a) (Nplength a') = Nplength a).
-  intro. rewrite H0. apply Nplength_ultra_1. exact H.
+  intros. destruct (ni_le_total (Nplength a) (Nplength a')).
+  enough (ni_min (Nplength a) (Nplength a') = Nplength a) as -> by (apply Nplength_ultra_1; exact H).
   exact H.
-  intro. cut (ni_min (Nplength a) (Nplength a') = Nplength a').
-  intro. rewrite H0. rewrite N.lxor_comm. apply Nplength_ultra_1. exact H.
+  enough (ni_min (Nplength a) (Nplength a') = Nplength a') as -> by (rewrite N.lxor_comm; apply Nplength_ultra_1; exact H).
   rewrite ni_min_comm. exact H.
 Qed.
 
diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v
index d21361cd..5ae388e3 100644
--- a/theories/NArith/Ndiv_def.v
+++ b/theories/NArith/Ndiv_def.v
@@ -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/theories/NArith/Ngcd_def.v b/theories/NArith/Ngcd_def.v
index 9faddddb..1750ffeb 100644
--- a/theories/NArith/Ngcd_def.v
+++ b/theories/NArith/Ngcd_def.v
@@ -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/theories/NArith/Nnat.v b/theories/NArith/Nnat.v
index 64c9a48e..0dcaa71d 100644
--- a/theories/NArith/Nnat.v
+++ b/theories/NArith/Nnat.v
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Arith_base Compare_dec Sumbool Div2 Min Max.
-Require Import BinPos BinNat Pnat.
+Require Import BinPos BinNat PeanoNat Pnat.
 
 (** * Conversions from [N] to [nat] *)
 
@@ -68,52 +67,58 @@ Qed.
 Lemma inj_sub a a' :
   N.to_nat (a - a') = N.to_nat a - N.to_nat a'.
 Proof.
- destruct a as [|a], a' as [|a']; simpl; auto with arith.
+ destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial.
  destruct (Pos.compare_spec a a').
- subst. now rewrite Pos.sub_mask_diag, <- minus_n_n.
- rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H.
- simpl; symmetry; apply not_le_minus_0; auto with arith.
- destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq).
- simpl. apply plus_minus. now rewrite <- Hq, Pos2Nat.inj_add.
+ - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag.
+ - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H.
+   simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl.
+ - destruct (Pos.sub_mask_pos' _ _ H) as (q & -> & Hq).
+   simpl; symmetry; apply Nat.add_sub_eq_l. now rewrite <- Hq, Pos2Nat.inj_add.
 Qed.
 
-Lemma inj_pred a : N.to_nat (N.pred a) = pred (N.to_nat a).
+Lemma inj_pred a : N.to_nat (N.pred a) = Nat.pred (N.to_nat a).
 Proof.
- intros. rewrite pred_of_minus, N.pred_sub. apply inj_sub.
+ rewrite <- Nat.sub_1_r, N.pred_sub. apply inj_sub.
 Qed.
 
-Lemma inj_div2 a : N.to_nat (N.div2 a) = div2 (N.to_nat a).
+Lemma inj_div2 a : N.to_nat (N.div2 a) = Nat.div2 (N.to_nat a).
 Proof.
  destruct a as [|[p|p| ]]; trivial.
- simpl N.to_nat. now rewrite Pos2Nat.inj_xI, div2_double_plus_one.
- simpl N.to_nat. now rewrite Pos2Nat.inj_xO, div2_double.
+ - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xI, Nat.div2_succ_double.
+ - unfold N.div2, N.to_nat. now rewrite Pos2Nat.inj_xO, Nat.div2_double.
 Qed.
 
 Lemma inj_compare a a' :
- (a ?= a')%N = nat_compare (N.to_nat a) (N.to_nat a').
+ (a ?= a')%N = (N.to_nat a ?= N.to_nat a').
 Proof.
  destruct a, a'; simpl; trivial.
- now destruct (Pos2Nat.is_succ p) as (n,->).
- now destruct (Pos2Nat.is_succ p) as (n,->).
- apply Pos2Nat.inj_compare.
+ - now destruct (Pos2Nat.is_succ p) as (n,->).
+ - now destruct (Pos2Nat.is_succ p) as (n,->).
+ - apply Pos2Nat.inj_compare.
 Qed.
 
 Lemma inj_max a a' :
-  N.to_nat (N.max a a') = max (N.to_nat a) (N.to_nat a').
+  N.to_nat (N.max a a') = Nat.max (N.to_nat a) (N.to_nat a').
 Proof.
  unfold N.max. rewrite inj_compare; symmetry.
- case nat_compare_spec; intros H; try rewrite H; auto with arith.
+ case Nat.compare_spec; intros.
+ - now apply Nat.max_r, Nat.eq_le_incl.
+ - now apply Nat.max_r, Nat.lt_le_incl.
+ - now apply Nat.max_l, Nat.lt_le_incl.
 Qed.
 
 Lemma inj_min a a' :
-  N.to_nat (N.min a a') = min (N.to_nat a) (N.to_nat a').
+  N.to_nat (N.min a a') = Nat.min (N.to_nat a) (N.to_nat a').
 Proof.
   unfold N.min; rewrite inj_compare. symmetry.
-  case nat_compare_spec; intros H; try rewrite H; auto with arith.
+  case Nat.compare_spec; intros.
+ - now apply Nat.min_l, Nat.eq_le_incl.
+ - now apply Nat.min_l, Nat.lt_le_incl.
+ - now apply Nat.min_r, Nat.lt_le_incl.
 Qed.
 
 Lemma inj_iter a {A} (f:A->A) (x:A) :
-  N.iter a f x = nat_iter (N.to_nat a) f x.
+  N.iter a f x = Nat.iter (N.to_nat a) f x.
 Proof.
  destruct a as [|a]. trivial. apply Pos2Nat.inj_iter.
 Qed.
@@ -166,7 +171,7 @@ Proof. nat2N. Qed.
 Lemma inj_succ n : N.of_nat (S n) = N.succ (N.of_nat n).
 Proof. nat2N. Qed.
 
-Lemma inj_pred n : N.of_nat (pred n) = N.pred (N.of_nat n).
+Lemma inj_pred n : N.of_nat (Nat.pred n) = N.pred (N.of_nat n).
 Proof. nat2N. Qed.
 
 Lemma inj_add n n' : N.of_nat (n+n') = (N.of_nat n + N.of_nat n')%N.
@@ -178,23 +183,23 @@ Proof. nat2N. Qed.
 Lemma inj_mul n n' : N.of_nat (n*n') = (N.of_nat n * N.of_nat n')%N.
 Proof. nat2N. Qed.
 
-Lemma inj_div2 n : N.of_nat (div2 n) = N.div2 (N.of_nat n).
+Lemma inj_div2 n : N.of_nat (Nat.div2 n) = N.div2 (N.of_nat n).
 Proof. nat2N. Qed.
 
 Lemma inj_compare n n' :
-  nat_compare n n' = (N.of_nat n ?= N.of_nat n')%N.
+  (n ?= n') = (N.of_nat n ?= N.of_nat n')%N.
 Proof. now rewrite N2Nat.inj_compare, !id. Qed.
 
 Lemma inj_min n n' :
-  N.of_nat (min n n') = N.min (N.of_nat n) (N.of_nat n').
+  N.of_nat (Nat.min n n') = N.min (N.of_nat n) (N.of_nat n').
 Proof. nat2N. Qed.
 
 Lemma inj_max n n' :
-  N.of_nat (max n n') = N.max (N.of_nat n) (N.of_nat n').
+  N.of_nat (Nat.max n n') = N.max (N.of_nat n) (N.of_nat n').
 Proof. nat2N. Qed.
 
 Lemma inj_iter n {A} (f:A->A) (x:A) :
-  nat_iter n f x = N.iter (N.of_nat n) f x.
+  Nat.iter n f x = N.iter (N.of_nat n) f x.
 Proof. now rewrite N2Nat.inj_iter, !id. Qed.
 
 End Nat2N.
diff --git a/theories/NArith/Nsqrt_def.v b/theories/NArith/Nsqrt_def.v
index d43c752d..da7829a9 100644
--- a/theories/NArith/Nsqrt_def.v
+++ b/theories/NArith/Nsqrt_def.v
@@ -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/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v
index 71bd4d50..6817947c 100644
--- a/theories/Numbers/BigNumPrelude.v
+++ b/theories/Numbers/BigNumPrelude.v
@@ -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/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v
index b9c37c72..1dd5d82a 100644
--- a/theories/Numbers/BinNums.v
+++ b/theories/Numbers/BinNums.v
@@ -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        *)
@@ -9,8 +9,6 @@
 (** * Binary Numerical Datatypes *)
 
 Set Implicit Arguments.
-(* For compatibility, we will not use generic equality functions *)
-Local Unset Boolean Equality Schemes.
 
 Declare ML Module "z_syntax_plugin".
 
diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
index 622ef225..8b84a484 100644
--- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
+++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
@@ -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        *)
@@ -88,8 +88,12 @@ Module ZnZ.
     is_even     : t -> bool;
     (* square root *)
     sqrt2       : t -> t -> t * carry t;
-    sqrt        : t -> t  }.
-
+    sqrt        : t -> t;
+    (* bitwise operations *)
+    lor         : t -> t -> t;
+    land        : t -> t -> t;
+    lxor        : t -> t -> t }.
+ 
  Section Specs.
  Context {t : Type}{ops : Ops t}.
 
@@ -98,10 +102,10 @@ Module ZnZ.
  Let wB := base digits.
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wB to_Z c)  (at level 0, x at level 99).
+   (interp_carry 1 wB to_Z c)  (at level 0, c at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wB to_Z c)  (at level 0, x at level 99).
+   (interp_carry (-1) wB to_Z c)  (at level 0, c at level 99).
 
  Notation "[|| x ||]" :=
    (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).
@@ -199,7 +203,10 @@ Module ZnZ.
           [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
           [+|r|] <= 2 * [|s|];
     spec_sqrt : forall x,
-       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2
+       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2;
+    spec_lor : forall x y, [|lor x y|] = Z.lor [|x|] [|y|];
+    spec_land : forall x y, [|land x y|] = Z.land [|x|] [|y|];
+    spec_lxor : forall x y, [|lxor x y|] = Z.lxor [|x|] [|y|]
   }.
 
  End Specs.
@@ -283,7 +290,7 @@ Module ZnZ.
  intros p Hp.
  generalize (spec_of_pos p).
  case (of_pos p); intros n w1; simpl.
- case n; simpl Npos; auto with zarith.
+ case n; auto with zarith.
  intros p1 Hp1; contradict Hp; apply Z.le_ngt.
  replace (base digits) with (1 * base digits + 0) by ring.
  rewrite Hp1.
diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
index d9089e18..8adeda37 100644
--- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v
+++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -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        *)
@@ -106,7 +106,7 @@ Qed.
 
 Theorem one_succ : one == succ zero.
 Proof.
-zify; simpl. now rewrite one_mod_wB.
+zify; simpl Z.add. now rewrite one_mod_wB.
 Qed.
 
 Theorem two_succ : two == succ one.
@@ -126,9 +126,7 @@ Let B (n : Z) := A (ZnZ.of_Z n).
 
 Lemma B0 : B 0.
 Proof.
-unfold B.
-setoid_replace (ZnZ.of_Z 0) with zero. assumption.
-red; zify. apply ZnZ.of_Z_correct. auto using gt_wB_0 with zarith.
+unfold B. apply A0.
 Qed.
 
 Lemma BS : forall n : Z, 0 <= n -> n < wB - 1 -> B n -> B (n + 1).
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
index 1b035948..a7c28862 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
@@ -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        *)
@@ -150,17 +150,17 @@ Section DoubleAdd.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[+[ c ]]" :=
    (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
   Variable spec_w_1   : [|w_1|] = 1.
@@ -194,9 +194,9 @@ Section DoubleAdd.
 
   Lemma spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
   Proof.
-   destruct x as [ |xh xl];simpl;trivial.
-   destruct y as [ |yh yl];simpl. rewrite Z.add_0_r;trivial.
-   replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
+   destruct x as [ |xh xl];trivial.
+   destruct y as [ |yh yl]. rewrite Z.add_0_r;trivial.
+   simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring.
    generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
     intros H;unfold interp_carry in H;rewrite <- H.
@@ -218,10 +218,11 @@ Section DoubleAdd.
 
    Lemma spec_ww_add_c_cont  : P x y (ww_add_c_cont x y).
    Proof.
-    destruct x as [ |xh xl];simpl;trivial.
+    destruct x as [ |xh xl];trivial.
     apply spec_f0;trivial.
-    destruct y as [ |yh yl];simpl.
-    apply spec_f0;simpl;rewrite Z.add_0_r;trivial.
+    destruct y as [ |yh yl].
+    apply spec_f0;rewrite Z.add_0_r;trivial.
+    simpl.
     generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
      intros H;unfold interp_carry in H.
     generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
@@ -234,10 +235,10 @@ Section DoubleAdd.
      as [h|h]; intros H1;unfold interp_carry in *.
     apply spec_f0;simpl;rewrite H1. rewrite Z.mul_add_distr_r.
     rewrite <- Z.add_assoc;rewrite H;ring.
-    apply spec_f1.  simpl;rewrite spec_w_WW;rewrite wwB_wBwB.
+    apply spec_f1. rewrite spec_w_WW;rewrite wwB_wBwB.
     rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r.
     rewrite Z.mul_1_l in H1;rewrite H1. rewrite Z.mul_add_distr_r.
-    rewrite <- Z.add_assoc;rewrite H;ring.
+    rewrite <- Z.add_assoc;rewrite H; simpl; ring.
    Qed.
 
   End Cont.
@@ -245,11 +246,11 @@ Section DoubleAdd.
   Lemma spec_ww_add_carry_c :
          forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1.
   Proof.
-   destruct x as [ |xh xl];intro y;simpl.
+   destruct x as [ |xh xl];intro y.
    exact (spec_ww_succ_c y).
-   destruct y as [ |yh yl];simpl.
+   destruct y as [ |yh yl].
    rewrite Z.add_0_r;exact (spec_ww_succ_c (WW xh xl)).
-   replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
+   simpl; replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
    with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
    generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
     as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
@@ -281,7 +282,7 @@ Section DoubleAdd.
 
   Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB.
   Proof.
-   destruct x as [ |xh xl];intros y;simpl.
+   destruct x as [ |xh xl];intros y.
    rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
    destruct y as [ |yh yl].
    change [[W0]] with 0;rewrite Z.add_0_r.
@@ -299,7 +300,7 @@ Section DoubleAdd.
   Lemma spec_ww_add_carry :
 	 forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB.
   Proof.
-   destruct x as [ |xh xl];intros y;simpl.
+   destruct x as [ |xh xl];intros y.
    exact (spec_ww_succ y).
    destruct y as [ |yh yl].
    change [[W0]] with 0;rewrite Z.add_0_r. exact (spec_ww_succ (WW xh xl)).
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
index 41a1d8ba..e68cd033 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
@@ -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        *)
@@ -149,9 +149,9 @@ Section DoubleBase.
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[[ x ]]" := (ww_to_Z x)  (at level 0, x at level 99).
   Notation "[+[ c ]]" :=
-   (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wwB ww_to_Z c) (at level 0, c at level 99).
   Notation "[-[ c ]]" :=
-   (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wwB ww_to_Z c) (at level 0, c at level 99).
   Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
@@ -287,7 +287,7 @@ Section DoubleBase.
   Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n).
   Proof.
    intros n;unfold double_wB;simpl.
-   unfold base. rewrite Pshiftl_nat_S, (Pos2Z.inj_xO (_ << _)).
+   unfold base. rewrite (Pos2Z.inj_xO (_ << _)).
    replace  (2 * Zpos (w_digits << n)) with
      (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring.
    symmetry; apply Zpower_exp;intro;discriminate.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
index e207d7eb..e137349e 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
@@ -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        *)
@@ -283,6 +283,27 @@ Section Z_2nZ.
   Eval lazy beta delta [ww_gcd] in
   ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.
 
+ Definition lor (x y : zn2z t) :=
+  match x, y with
+  | W0, _ => y
+  | _, W0 => x
+  | WW hx lx, WW hy ly => WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)
+  end.
+
+ Definition land (x y : zn2z t) :=
+  match x, y with
+  | W0, _ => W0
+  | _, W0 => W0
+  | WW hx lx, WW hy ly => WW (ZnZ.land hx hy) (ZnZ.land lx ly)
+  end.
+
+ Definition lxor (x y : zn2z t) :=
+  match x, y with
+  | W0, _ => y
+  | _, W0 => x
+  | WW hx lx, WW hy ly => WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)
+  end.
+
  (* ** Record of operators on 2 words *)
 
  Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 :=
@@ -303,7 +324,10 @@ Section Z_2nZ.
     pos_mod
     is_even
     sqrt2
-    sqrt.
+    sqrt
+    lor
+    land
+    lxor.
 
  Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 :=
    ZnZ.MkOps _ww_digits _ww_zdigits
@@ -323,10 +347,15 @@ Section Z_2nZ.
     pos_mod
     is_even
     sqrt2
-    sqrt.
+    sqrt
+    lor
+    land
+    lxor.
 
  (* Proof *)
  Context {specs : ZnZ.Specs ops}.
+ 
+ Create HintDb ZnZ.
 
  Hint Resolve
     ZnZ.spec_to_Z
@@ -370,24 +399,24 @@ Section Z_2nZ.
     ZnZ.spec_sqrt
     ZnZ.spec_WO
     ZnZ.spec_OW
-    ZnZ.spec_WW.
-
- Ltac wwauto := unfold ww_to_Z; auto.
+    ZnZ.spec_WW : ZnZ.
+ 
+ Ltac wwauto := unfold ww_to_Z; eauto with ZnZ.
 
  Let wwB := base _ww_digits.
 
  Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wwB to_Z c)  (at level 0, x at level 99).
+   (interp_carry 1 wwB to_Z c)  (at level 0, c at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wwB to_Z c)  (at level 0, x at level 99).
+   (interp_carry (-1) wwB to_Z c)  (at level 0, c at level 99).
 
  Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x)  (at level 0, x at level 99).
 
  Let spec_ww_to_Z   : forall x, 0 <= [| x |] < wwB.
- Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed.
+ Proof. refine (spec_ww_to_Z w_digits w_to_Z _); wwauto. Qed.
 
  Let spec_ww_of_pos : forall p,
      Zpos p = (Z.of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
@@ -411,15 +440,15 @@ Section Z_2nZ.
  Proof. reflexivity. Qed.
 
  Let spec_ww_1 : [|ww_1|] = 1.
- Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed.
+ Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);wwauto. Qed.
 
  Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1.
- Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.
+ Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);wwauto. Qed.
 
  Let spec_ww_compare :
   forall x y, compare x y = Z.compare [|x|] [|y|].
  Proof.
-  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto.
+  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);wwauto.
  Qed.
 
  Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0.
@@ -428,14 +457,14 @@ Section Z_2nZ.
  Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|].
  Proof.
   refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _);
-  auto.
+   wwauto.
  Qed.
 
  Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB.
  Proof.
   refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp
    w_digits w_to_Z _ _ _ _ _);
-  auto.
+  wwauto.
  Qed.
 
  Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1.
@@ -446,7 +475,7 @@ Section Z_2nZ.
 
  Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
  Proof.
-  refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto.
+  refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|].
@@ -468,7 +497,7 @@ Section Z_2nZ.
 
  Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB.
  Proof.
-  refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto.
+  refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB.
@@ -565,7 +594,7 @@ Section Z_2nZ.
       0 <= [|r|] < [|b|].
  Proof.
   refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z
-   _ _ _ _ _ _ _);wwauto.
+   _ _ _ _ _ _ _);wwauto. 
  Qed.
 
  Let spec_add2: forall x y,
@@ -581,13 +610,14 @@ Section Z_2nZ.
  Qed.
 
  Let spec_low: forall x,
-  w_to_Z (low x) = [|x|] mod wB.
+  w_to_Z (low x) = [|x|] mod wB. 
   intros x; case x; simpl low.
-    unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; auto.
+    unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; wwauto.
   intros xh xl; simpl.
   rewrite Z.add_comm; rewrite Z_mod_plus; auto with zarith.
   rewrite Zmod_small; auto with zarith.
-  unfold wB, base; auto with zarith.
+  unfold wB, base; eauto with ZnZ zarith.
+  unfold wB, base; eauto with ZnZ zarith.
  Qed.
 
  Let spec_ww_digits:
@@ -605,7 +635,7 @@ Section Z_2nZ.
  Proof.
  refine (spec_ww_head00 w_0 w_0W
                 w_compare w_head0 w_add2 w_zdigits _ww_zdigits
-                w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); auto.
+                w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto.
  exact ZnZ.spec_head00.
  exact ZnZ.spec_zdigits.
  Qed.
@@ -688,7 +718,7 @@ refine
       [|a|] = [|q|] * [|b|] + [|r|] /\
       0 <= [|r|] < [|b|].
  Proof.
-  refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto.
+  refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);wwauto.
  Qed.
 
  Let spec_ww_mod_gt : forall a b,
@@ -708,7 +738,7 @@ refine
 
  Let spec_ww_mod :  forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|].
  Proof.
-  refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto.
+  refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);wwauto.
  Qed.
 
  Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] ->
@@ -716,7 +746,7 @@ refine
  Proof.
   refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _
     w_0 w_0 w_eq0 w_gcd_gt _ww_digits
-  _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
+  _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto.
   refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
    w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
@@ -725,13 +755,13 @@ refine
   exact ZnZ.spec_zdigits.
   exact spec_ww_add_mul_div.
   refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
-   _ _);auto.
+   _ _);wwauto.
  Qed.
 
  Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
  Proof.
   refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt
-  _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
+  _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto.
   refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
    w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
    w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
@@ -740,7 +770,7 @@ refine
   exact ZnZ.spec_zdigits.
   exact spec_ww_add_mul_div.
   refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
-   _ _);auto.
+   _ _);wwauto.
  Qed.
 
  Let spec_ww_is_even : forall x,
@@ -779,7 +809,7 @@ refine
  refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1
            w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
                w_sqrt2 pred add_mul_div head0 compare
-            _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
+            _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
  exact ZnZ.spec_zdigits.
  exact ZnZ.spec_more_than_1_digit.
  exact ZnZ.spec_is_even.
@@ -787,6 +817,83 @@ refine
  exact ZnZ.spec_sqrt2.
  Qed.
 
+ Let wB_pos : 0 < wB.
+ Proof.
+ unfold wB, base; apply Z.pow_pos_nonneg; auto with zarith.
+ Qed.
+ 
+ Hint Transparent ww_to_Z.
+
+ Let ww_testbit_high n x y : Z.pos w_digits <= n ->
+  Z.testbit [|WW x y|] n =
+  Z.testbit (ZnZ.to_Z x) (n - Z.pos w_digits).
+ Proof.
+  intros Hn.
+  assert (E : ZnZ.to_Z x = [|WW x y|] / wB).
+  { simpl.
+    rewrite Z.div_add_l; eauto with ZnZ zarith.
+    now rewrite Z.div_small, Z.add_0_r; wwauto. }
+  rewrite E.
+  unfold wB, base. rewrite Z.div_pow2_bits.
+  - f_equal; auto with zarith.
+  - easy.
+  - auto with zarith.
+ Qed.
+
+ Let ww_testbit_low n x y : 0 <= n < Z.pos w_digits ->
+  Z.testbit [|WW x y|] n = Z.testbit (ZnZ.to_Z y) n.
+ Proof.
+  intros (Hn,Hn').
+  assert (E : ZnZ.to_Z y = [|WW x y|] mod wB).
+  { simpl; symmetry.
+    rewrite Z.add_comm, Z.mod_add; auto with zarith nocore.
+    apply Z.mod_small; eauto with ZnZ zarith. }
+  rewrite E.
+  unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto.
+ Qed.
+
+ Let spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|].
+ Proof.
+  destruct x as [ |hx lx]. trivial.
+  destruct y as [ |hy ly]. now rewrite Z.lor_comm.
+  change ([|WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)|] =
+          Z.lor [|WW hx lx|] [|WW hy ly|]).
+  apply Z.bits_inj'; intros n Hn.
+  rewrite Z.lor_spec.
+  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
+  - now rewrite !ww_testbit_high, ZnZ.spec_lor, Z.lor_spec.
+  - rewrite !ww_testbit_low; auto.
+    now rewrite ZnZ.spec_lor, Z.lor_spec.
+ Qed.
+
+ Let spec_land x y : [|land x y|] = Z.land [|x|] [|y|].
+ Proof.
+  destruct x as [ |hx lx]. trivial.
+  destruct y as [ |hy ly]. now rewrite Z.land_comm.
+  change ([|WW (ZnZ.land hx hy) (ZnZ.land lx ly)|] =
+          Z.land [|WW hx lx|] [|WW hy ly|]).
+  apply Z.bits_inj'; intros n Hn.
+  rewrite Z.land_spec.
+  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
+  - now rewrite !ww_testbit_high, ZnZ.spec_land, Z.land_spec.
+  - rewrite !ww_testbit_low; auto.
+    now rewrite ZnZ.spec_land, Z.land_spec.
+ Qed.
+
+ Let spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|].
+ Proof.
+  destruct x as [ |hx lx]. trivial.
+  destruct y as [ |hy ly]. now rewrite Z.lxor_comm.
+  change ([|WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)|] =
+          Z.lxor [|WW hx lx|] [|WW hy ly|]).
+  apply Z.bits_inj'; intros n Hn.
+  rewrite Z.lxor_spec.
+  destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT].
+  - now rewrite !ww_testbit_high, ZnZ.spec_lxor, Z.lxor_spec.
+  - rewrite !ww_testbit_low; auto.
+    now rewrite ZnZ.spec_lxor, Z.lxor_spec.
+ Qed.
+
  Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops.
  Proof.
   apply ZnZ.MkSpecs; auto.
@@ -816,6 +923,7 @@ refine
 
 End Z_2nZ.
 
+
 Section MulAdd.
 
   Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
index 08f05bbf..cd55f9d8 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
@@ -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        *)
@@ -97,8 +97,7 @@ Section POS_MOD.
  assert (HHHHH:= lt_0_wB w_digits).
  assert (F0: forall x y, x - y + y = x); auto with zarith.
  intros w1 p; case (spec_to_w_Z p); intros HH1 HH2.
- unfold ww_pos_mod; case w1.
- simpl; rewrite Zmod_small; split; auto with zarith.
+ unfold ww_pos_mod; case w1. reflexivity.
  intros xh xl; rewrite spec_ww_compare.
     case Z.compare_spec;
     rewrite spec_w_0W; rewrite spec_zdigits; fold wB;
@@ -211,8 +210,7 @@ Section DoubleDiv32.
  Variable w_div21       : w -> w -> w -> w*w.
  Variable ww_sub_c      : zn2z w -> zn2z w -> carry (zn2z w).
 
- Definition w_div32 a1 a2 a3 b1 b2 :=
-  Eval lazy beta iota delta [ww_add_c_cont ww_add] in
+ Definition w_div32_body a1 a2 a3 b1 b2 :=
   match w_compare a1 b1 with
   | Lt =>
     let (q,r) := w_div21 a1 a2 b1 in
@@ -233,6 +231,10 @@ Section DoubleDiv32.
   | Gt => (w_0, W0) (* cas absurde *)
   end.
 
+ Definition w_div32 a1 a2 a3 b1 b2 :=
+  Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in
+     w_div32_body a1 a2 a3 b1 b2.
+
  (* Proof *)
 
   Variable w_digits      : positive.
@@ -242,14 +244,14 @@ Section DoubleDiv32.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
 
   Variable spec_w_0   : [|w_0|] = 0.
@@ -312,26 +314,8 @@ Section DoubleDiv32.
    assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits).
    Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2.
    rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r.
-   change (w_div32 a1 a2 a3 b1 b2) with
-    match w_compare a1 b1 with
-    | Lt =>
-     let (q,r) := w_div21 a1 a2 b1 in
-     match ww_sub_c (w_WW r a3) (w_mul_c q b2) with
-     | C0 r1 => (q,r1)
-     | C1 r1 =>
-      let q := w_pred q in
-      ww_add_c_cont w_WW w_add_c w_add_carry_c
-      (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2)))
-      (fun r2 => (q,r2))
-      r1 (WW b1 b2)
-     end
-    | Eq =>
-     ww_add_c_cont w_WW w_add_c w_add_carry_c
-     (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2)))
-     (fun r => (w_Bm1,r))
-     (WW (w_sub a2 b2) a3) (WW b1 b2)
-    | Gt => (w_0, W0) (* cas absurde *)
-    end.
+   change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2).
+   unfold w_div32_body.
    rewrite spec_compare. case Z.compare_spec; intro Hcmp.
    simpl in Hlt.
    rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega.
@@ -520,7 +504,7 @@ Section DoubleDiv21.
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
   Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
@@ -782,7 +766,7 @@ Section DoubleDivGt.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
 
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
index 8e179ef6..6a1d741e 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
@@ -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        *)
@@ -160,7 +160,7 @@ Section GENDIVN1.
   Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (w_digits << n).
   Proof.
    induction n;simpl. trivial.
-   case (spec_to_Z p); rewrite Pshiftl_nat_S, Pos2Z.inj_xO;auto with zarith.
+   case (spec_to_Z p); rewrite Pos2Z.inj_xO;auto with zarith.
   Qed.
 
   Lemma spec_double_divn1_p : forall n r h l,
@@ -305,7 +305,6 @@ Section GENDIVN1.
  Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (w_digits << n).
  Proof.
   induction n;simpl;auto with zarith.
-  rewrite Pshiftl_nat_S.
   change (Zpos (xO (w_digits << n))) with
     (2*Zpos (w_digits << n)).
   assert (0 < Zpos w_digits) by reflexivity.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
index 2d0cc0fb..ff9f50a5 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
@@ -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/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
index 1c0fc68a..537f557d 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
@@ -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        *)
@@ -218,17 +218,17 @@ Section DoubleMul.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[+[ c ]]" :=
    (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
   Notation "[|| x ||]" :=
     (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x)  (at level 0, x at level 99).
@@ -328,7 +328,7 @@ Section DoubleMul.
    rewrite <- (Z.add_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith.
    simpl ww_to_Z in H1. assert (U:=spec_to_Z cch).
    assert ([|wc|]*wB + [|cch|] <= 2*wB - 3).
-    destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3));trivial.
+    destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3)) as [Hle|Hgt];trivial.
     assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2).
      ring_simplify ((2*wB - 4)*wB + 2).
      assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)).
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
index 149682f8..ab8c8617 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
@@ -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        *)
@@ -185,17 +185,17 @@ Section DoubleSqrt.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[+[ c ]]" :=
    (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
   Notation "[|| x ||]" :=
     (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x)  (at level 0, x at level 99).
@@ -266,8 +266,8 @@ Section DoubleSqrt.
       if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1.
 clear spec_more_than_1_digit.
 intros x; case x; simpl ww_is_even.
+ reflexivity.
  simpl.
- rewrite Zmod_small; auto with zarith.
  intros w1 w2; simpl.
  unfold base.
  rewrite Zplus_mod; auto with zarith.
@@ -692,7 +692,7 @@ intros x; case x; simpl ww_is_even.
  intros x y H; unfold ww_sqrt2.
  repeat match goal with |- context[split ?x] =>
    generalize (spec_split x); case (split x)
- end; simpl fst; simpl snd.
+ end; simpl @fst; simpl @snd.
  intros w0 w1 Hw0 w2 w3 Hw1.
  assert (U: wB/4 <= [|w2|]).
  case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1.
@@ -761,7 +761,7 @@ intros x; case x; simpl ww_is_even.
   auto.
  split.
  unfold zn2z_to_Z; rewrite <- Hw1.
- unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1.
+ unfold ww_to_Z, zn2z_to_Z in H1. rewrite H1.
  rewrite <- Hw0.
  match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U =>
   transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T)
@@ -1193,7 +1193,7 @@ Qed.
   rewrite <- wwB_4_wB_4; auto.
   generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith.
   case (w_sqrt2 w0 w1); intros w2 c.
-  simpl ww_to_Z; simpl fst.
+  simpl ww_to_Z; simpl @fst.
   case c; unfold interp_carry; autorewrite with rm10.
   intros w3 (H6, H7); rewrite H6.
   assert (V1 := spec_to_Z w3);auto with zarith.
@@ -1256,7 +1256,7 @@ Qed.
   generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith.
   case (w_sqrt2 w0 w1); intros w2 c.
   case (spec_to_Z w2); intros HH1 HH2.
-  simpl ww_to_Z; simpl fst.
+  simpl ww_to_Z; simpl @fst.
   assert (Hv3: [[ww_pred ww_zdigits]]
                  = Zpos (xO w_digits) - 1).
     rewrite spec_ww_pred; rewrite spec_ww_zdigits.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
index aaa93a21..a2df2600 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
@@ -1,6 +1,7 @@
+
 (************************************************************************)
 (*  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-2012     *)
 (*   \VV/  **************************************************************)
 (*    //   *      This file is distributed under the terms of the       *)
 (*         *       GNU Lesser General Public License Version 2.1        *)
@@ -159,17 +160,17 @@ Section DoubleSub.
   Notation wwB := (base (ww_digits w_digits)).
   Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
   Notation "[+| c |]" :=
-   (interp_carry 1 wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
   Notation "[-| c |]" :=
-   (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99).
+   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).
 
   Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
   Notation "[+[ c ]]" :=
    (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
   Notation "[-[ c ]]" :=
    (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
-   (at level 0, x at level 99).
+   (at level 0, c at level 99).
 
   Variable spec_w_0   : [|w_0|] = 0.
   Variable spec_w_Bm1   : [|w_Bm1|] = wB - 1.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
index 1ab75307..c1f314e9 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
@@ -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        *)
@@ -14,6 +14,7 @@ Require Import ZArith.
 Local Open Scope Z_scope.
 
 Definition base digits := Z.pow 2 (Zpos digits).
+Arguments base digits: simpl never.
 
 Section Carry.
 
@@ -53,7 +54,7 @@ Section Zn2Z.
 
 End Zn2Z.
 
-Arguments W0 [znz].
+Arguments W0 {znz}.
 
 (** From a cyclic representation [w], we iterate the [zn2z] construct
     [n] times, gaining the type of binary trees of depth at most [n],
diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v
index cef3ecae..aca57216 100644
--- a/theories/Numbers/Cyclic/Int31/Cyclic31.v
+++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v
@@ -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        *)
@@ -75,88 +75,87 @@ Section Basics.
 
  (** * Iterated shift to the right *)
 
- Definition nshiftr n x := iter_nat n _ shiftr x.
+ Definition nshiftr x := nat_rect _ x (fun _ => shiftr).
 
  Lemma nshiftr_S :
-  forall n x, nshiftr (S n) x = shiftr (nshiftr n x).
+  forall n x, nshiftr x (S n) = shiftr (nshiftr x n).
  Proof.
  reflexivity.
  Qed.
 
  Lemma nshiftr_S_tail :
-  forall n x, nshiftr (S n) x = nshiftr n (shiftr x).
+  forall n x, nshiftr x (S n) = nshiftr (shiftr x) n.
  Proof.
- induction n; simpl; auto.
- intros; rewrite nshiftr_S, IHn, nshiftr_S; auto.
+ intros n; elim n; simpl; auto.
+ intros; now f_equal.
  Qed.
 
- Lemma nshiftr_n_0 : forall n, nshiftr n 0 = 0.
+ Lemma nshiftr_n_0 : forall n, nshiftr 0 n = 0.
  Proof.
  induction n; simpl; auto.
- rewrite nshiftr_S, IHn; auto.
+ rewrite IHn; auto.
  Qed.
 
- Lemma nshiftr_size : forall x, nshiftr size x = 0.
+ Lemma nshiftr_size : forall x, nshiftr x size = 0.
  Proof.
  destruct x; simpl; auto.
  Qed.
 
  Lemma nshiftr_above_size : forall k x, size<=k ->
-  nshiftr k x = 0.
+  nshiftr x k = 0.
  Proof.
  intros.
  replace k with ((k-size)+size)%nat by omega.
  induction (k-size)%nat; auto.
   rewrite nshiftr_size; auto.
-  simpl; rewrite nshiftr_S, IHn; auto.
+  simpl; rewrite IHn; auto.
  Qed.
 
  (** * Iterated shift to the left *)
 
- Definition nshiftl n x := iter_nat n _ shiftl x.
+ Definition nshiftl x := nat_rect _ x (fun _ => shiftl).
 
  Lemma nshiftl_S :
-  forall n x, nshiftl (S n) x = shiftl (nshiftl n x).
+  forall n x, nshiftl x (S n) = shiftl (nshiftl x n).
  Proof.
  reflexivity.
  Qed.
 
  Lemma nshiftl_S_tail :
-  forall n x, nshiftl (S n) x = nshiftl n (shiftl x).
- Proof.
- induction n; simpl; auto.
- intros; rewrite nshiftl_S, IHn, nshiftl_S; auto.
+  forall n x, nshiftl x (S n) = nshiftl (shiftl x) n.
+ Proof. 
+ intros n; elim n; simpl; intros; now f_equal.
  Qed.
 
- Lemma nshiftl_n_0 : forall n, nshiftl n 0 = 0.
+ Lemma nshiftl_n_0 : forall n, nshiftl 0 n = 0.
  Proof.
  induction n; simpl; auto.
- rewrite nshiftl_S, IHn; auto.
+ rewrite IHn; auto.
  Qed.
 
- Lemma nshiftl_size : forall x, nshiftl size x = 0.
+ Lemma nshiftl_size : forall x, nshiftl x size = 0.
  Proof.
  destruct x; simpl; auto.
  Qed.
 
  Lemma nshiftl_above_size : forall k x, size<=k ->
-  nshiftl k x = 0.
+  nshiftl x k = 0.
  Proof.
  intros.
  replace k with ((k-size)+size)%nat by omega.
  induction (k-size)%nat; auto.
   rewrite nshiftl_size; auto.
-  simpl; rewrite nshiftl_S, IHn; auto.
+  simpl; rewrite IHn; auto.
  Qed.
 
  Lemma firstr_firstl :
-  forall x, firstr x = firstl (nshiftl (pred size) x).
+  forall x, firstr x = firstl (nshiftl x (pred size)).
  Proof.
  destruct x; simpl; auto.
  Qed.
 
  Lemma firstl_firstr :
-  forall x, firstl x = firstr (nshiftr (pred size) x).
+  forall x, firstl x = firstr (nshiftr x (pred size)).
  Proof.
  destruct x; simpl; auto.
  Qed.
@@ -164,23 +163,23 @@ Section Basics.
  (** More advanced results about [nshiftr] *)
 
  Lemma nshiftr_predsize_0_firstl : forall x,
-  nshiftr (pred size) x = 0 -> firstl x = D0.
+  nshiftr x (pred size) = 0 -> firstl x = D0.
  Proof.
  destruct x; compute; intros H; injection H; intros; subst; auto.
  Qed.
 
  Lemma nshiftr_0_propagates : forall n p x, n <= p ->
-  nshiftr n x = 0 -> nshiftr p x = 0.
+  nshiftr x n = 0 -> nshiftr x p = 0.
  Proof.
  intros.
  replace p with ((p-n)+n)%nat by omega.
  induction (p-n)%nat.
  simpl; auto.
- simpl; rewrite nshiftr_S; rewrite IHn0; auto.
+ simpl; rewrite IHn0; auto.
  Qed.
 
  Lemma nshiftr_0_firstl : forall n x, n < size ->
-  nshiftr n x = 0 -> firstl x = D0.
+  nshiftr x n = 0 -> firstl x = D0.
  Proof.
  intros.
  apply nshiftr_predsize_0_firstl.
@@ -197,15 +196,15 @@ Section Basics.
   forall x, P x.
  Proof.
  intros.
- assert (forall n, n<=size -> P (nshiftr (size - n) x)).
+ assert (forall n, n<=size -> P (nshiftr x (size - n))).
  induction n; intros.
  rewrite nshiftr_size; auto.
  rewrite sneakl_shiftr.
  apply H0.
- change (P (nshiftr (S (size - S n)) x)).
+ change (P (nshiftr x (S (size - S n)))).
  replace (S (size - S n))%nat with (size - n)%nat by omega.
  apply IHn; omega.
- change x with (nshiftr (size-size) x); auto.
+ change x with (nshiftr x (size-size)); auto.
  Qed.
 
  Lemma int31_ind_twice : forall P : int31->Prop,
@@ -236,19 +235,19 @@ Section Basics.
 
  Lemma recr_aux_converges :
   forall n p x, n <= size -> n <= p ->
-  recr_aux n A case0 caserec (nshiftr (size - n) x) =
-  recr_aux p A case0 caserec (nshiftr (size - n) x).
+  recr_aux n A case0 caserec (nshiftr x (size - n)) =
+  recr_aux p A case0 caserec (nshiftr x (size - n)).
  Proof.
  induction n.
- simpl; intros.
+ simpl minus; intros.
  rewrite nshiftr_size; destruct p; simpl; auto.
  intros.
  destruct p.
  inversion H0.
  unfold recr_aux; fold recr_aux.
- destruct (iszero (nshiftr (size - S n) x)); auto.
+ destruct (iszero (nshiftr x (size - S n))); auto.
  f_equal.
- change (shiftr (nshiftr (size - S n) x)) with (nshiftr (S (size - S n)) x).
+ change (shiftr (nshiftr x (size - S n))) with (nshiftr x (S (size - S n))).
  replace (S (size - S n))%nat with (size - n)%nat by omega.
  apply IHn; auto with arith.
  Qed.
@@ -259,7 +258,7 @@ Section Basics.
  Proof.
  intros.
  unfold recr.
- change x with (nshiftr (size - size) x).
+ change x with (nshiftr x (size - size)).
  rewrite (recr_aux_converges size (S size)); auto with arith.
  rewrite recr_aux_eqn; auto.
  Qed.
@@ -436,22 +435,22 @@ Section Basics.
 
  Lemma phibis_aux_bounded :
   forall n x, n <= size ->
-  (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z.of_nat n))%Z.
+  (phibis_aux n (nshiftr x (size-n)) < 2 ^ (Z.of_nat n))%Z.
  Proof.
  induction n.
- simpl; unfold phibis_aux; simpl; auto with zarith.
+ simpl minus; unfold phibis_aux; simpl; auto with zarith.
  intros.
  unfold phibis_aux, recrbis_aux; fold recrbis_aux;
-  fold (phibis_aux n (shiftr (nshiftr (size - S n) x))).
- assert (shiftr (nshiftr (size - S n) x) =  nshiftr (size-n) x).
+  fold (phibis_aux n (shiftr (nshiftr x (size - S n)))).
+ assert (shiftr (nshiftr x (size - S n)) =  nshiftr x (size-n)).
   replace (size - n)%nat with (S (size - (S n))) by omega.
   simpl; auto.
  rewrite H0.
  assert (H1 : n <= size) by omega.
  specialize (IHn x H1).
- set (y:=phibis_aux n (nshiftr (size - n) x)) in *.
+ set (y:=phibis_aux n (nshiftr x (size - n))) in *.
  rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith.
- case_eq (firstr (nshiftr (size - S n) x)); intros.
+ case_eq (firstr (nshiftr x (size - S n))); intros.
  rewrite Z.double_spec; auto with zarith.
  rewrite Z.succ_double_spec; auto with zarith.
  Qed.
@@ -462,12 +461,12 @@ Section Basics.
  rewrite <- phibis_aux_equiv.
  split.
  apply phibis_aux_pos.
- change x with (nshiftr (size-size) x).
+ change x with (nshiftr x (size-size)).
  apply phibis_aux_bounded; auto.
  Qed.
 
  Lemma phibis_aux_lowerbound :
-  forall n x, firstr (nshiftr n x) = D1 ->
+  forall n x, firstr (nshiftr x n) = D1 ->
   (2 ^ Z.of_nat n <= phibis_aux (S n) x)%Z.
  Proof.
  induction n.
@@ -509,7 +508,7 @@ Section Basics.
  (** After killing [n] bits at the left, are the numbers equal ?*)
 
  Definition EqShiftL n x y :=
-  nshiftl n x = nshiftl n y.
+  nshiftl x n = nshiftl y n.
 
  Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y.
  Proof.
@@ -529,7 +528,7 @@ Section Basics.
  remember (k'-k)%nat as n.
  clear Heqn H k'.
  induction n; simpl; auto.
- rewrite 2 nshiftl_S; f_equal; auto.
+ f_equal; auto.
  Qed.
 
  Lemma EqShiftL_firstr : forall k x y, k < size ->
@@ -601,7 +600,7 @@ Section Basics.
   end.
 
  Lemma i2l_nshiftl : forall n x, n<=size ->
-  i2l (nshiftl n x) = cstlist _ D0 n ++ firstn (size-n) (i2l x).
+  i2l (nshiftl x n) = cstlist _ D0 n ++ firstn (size-n) (i2l x).
  Proof.
  induction n.
  intros.
@@ -618,13 +617,13 @@ Section Basics.
  rewrite <- app_comm_cons; f_equal.
  rewrite IHn; [ | omega].
  rewrite removelast_app.
- f_equal.
+ apply f_equal.
  replace (size-n)%nat with (S (size - S n))%nat by omega.
  rewrite removelast_firstn; auto.
  rewrite i2l_length; omega.
  generalize (firstn_length (size-n) (i2l x)).
  rewrite i2l_length.
- intros H0 H1; rewrite H1 in H0.
+ intros H0 H1. rewrite H1 in H0.
  rewrite min_l in H0 by omega.
  simpl length in H0.
  omega.
@@ -636,7 +635,7 @@ Section Basics.
    EqShiftL k x y  <-> firstn (size-k) (i2l x) = firstn (size-k) (i2l y).
  Proof.
  intros.
- destruct (le_lt_dec size k).
+ destruct (le_lt_dec size k) as [Hle|Hlt].
  split; intros.
  replace (size-k)%nat with O by omega.
  unfold firstn; auto.
@@ -645,24 +644,24 @@ Section Basics.
  unfold EqShiftL.
  assert (k <= size) by omega.
  split; intros.
- assert (i2l (nshiftl k x) = i2l (nshiftl k y)) by (f_equal; auto).
+ assert (i2l (nshiftl x k) = i2l (nshiftl y k)) by (f_equal; auto).
  rewrite 2 i2l_nshiftl in H1; auto.
  eapply app_inv_head; eauto.
- assert (i2l (nshiftl k x) = i2l (nshiftl k y)).
+ assert (i2l (nshiftl x k) = i2l (nshiftl y k)).
   rewrite 2 i2l_nshiftl; auto.
   f_equal; auto.
- rewrite <- (l2i_i2l (nshiftl k x)), <- (l2i_i2l (nshiftl k y)).
+ rewrite <- (l2i_i2l (nshiftl x k)), <- (l2i_i2l (nshiftl y k)).
  f_equal; auto.
  Qed.
 
- (** This equivalence allows to prove easily the following delicate
+ (** This equivalence allows proving easily the following delicate
      result *)
 
  Lemma EqShiftL_twice_plus_one : forall k x y,
   EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y.
  Proof.
  intros.
- destruct (le_lt_dec size k).
+ destruct (le_lt_dec size k) as [Hle|Hlt].
  split; intros; apply EqShiftL_size; auto.
 
  rewrite 2 EqShiftL_i2l.
@@ -685,7 +684,7 @@ Section Basics.
   EqShiftL (S k) (shiftr x) (shiftr y).
  Proof.
  intros.
- destruct (le_lt_dec size (S k)).
+ destruct (le_lt_dec size (S k)) as [Hle|Hlt].
  apply EqShiftL_size; auto.
  case_eq (firstr x); intros.
  rewrite <- EqShiftL_twice.
@@ -819,30 +818,30 @@ Section Basics.
 
  Lemma phi_inv_phi_aux :
   forall n x, n <= size ->
-   phi_inv (phibis_aux n (nshiftr (size-n) x)) =
-   nshiftr (size-n) x.
+   phi_inv (phibis_aux n (nshiftr x (size-n))) =
+   nshiftr x (size-n).
  Proof.
  induction n.
- intros; simpl.
+ intros; simpl minus.
  rewrite nshiftr_size; auto.
  intros.
  unfold phibis_aux, recrbis_aux; fold recrbis_aux;
-  fold (phibis_aux n (shiftr (nshiftr (size-S n) x))).
- assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x).
+  fold (phibis_aux n (shiftr (nshiftr x (size-S n)))).
+ assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)).
   replace (size - n)%nat with (S (size - (S n))); auto; omega.
  rewrite H0.
- case_eq (firstr (nshiftr (size - S n) x)); intros.
+ case_eq (firstr (nshiftr x (size - S n))); intros.
 
  rewrite phi_inv_double.
  rewrite IHn by omega.
  rewrite <- H0.
- remember (nshiftr (size - S n) x) as y.
+ remember (nshiftr x (size - S n)) as y.
  destruct y; simpl in H1; rewrite H1; auto.
 
  rewrite phi_inv_double_plus_one.
  rewrite IHn by omega.
  rewrite <- H0.
- remember (nshiftr (size - S n) x) as y.
+ remember (nshiftr x (size - S n)) as y.
  destruct y; simpl in H1; rewrite H1; auto.
  Qed.
 
@@ -850,7 +849,7 @@ Section Basics.
  Proof.
  intros.
  rewrite <- phibis_aux_equiv.
- replace x with (nshiftr (size - size) x) by auto.
+ replace x with (nshiftr x (size - size)) by auto.
  apply phi_inv_phi_aux; auto.
  Qed.
 
@@ -875,28 +874,28 @@ Section Basics.
   end.
 
  Lemma p2ibis_bounded : forall n p,
-  nshiftr n (snd (p2ibis n p)) = 0.
+  nshiftr (snd (p2ibis n p)) n = 0.
  Proof.
  induction n.
  simpl; intros; auto.
- simpl; intros.
- destruct p; simpl.
+ simpl p2ibis; intros.
+ destruct p; simpl snd.
 
  specialize IHn with p.
- destruct (p2ibis n p); simpl in *.
+ destruct (p2ibis n p). simpl @snd in *.
  rewrite nshiftr_S_tail.
- destruct (le_lt_dec size n).
+ destruct (le_lt_dec size n) as [Hle|Hlt].
  rewrite nshiftr_above_size; auto.
- assert (H:=nshiftr_0_firstl _ _ l IHn).
+ assert (H:=nshiftr_0_firstl _ _ Hlt IHn).
  replace (shiftr (twice_plus_one i)) with i; auto.
- destruct i; simpl in *; rewrite H; auto.
+ destruct i; simpl in *. rewrite H; auto.
 
  specialize IHn with p.
- destruct (p2ibis n p); simpl in *.
+ destruct (p2ibis n p); simpl @snd in *.
  rewrite nshiftr_S_tail.
- destruct (le_lt_dec size n).
+ destruct (le_lt_dec size n) as [Hle|Hlt].
  rewrite nshiftr_above_size; auto.
- assert (H:=nshiftr_0_firstl _ _ l IHn).
+ assert (H:=nshiftr_0_firstl _ _ Hlt IHn).
  replace (shiftr (twice i)) with i; auto.
  destruct i; simpl in *; rewrite H; auto.
 
@@ -946,7 +945,7 @@ Section Basics.
  intros.
  simpl p2ibis; destruct p; [ | | red; auto];
   specialize IHn with p;
-  destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive;
+  destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive;
   rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice;
   replace (S (size - S n))%nat with (size - n)%nat by omega;
   apply IHn; omega.
@@ -1158,7 +1157,10 @@ Instance int31_ops : ZnZ.Ops int31 :=
   fun i => let (_,r) := i/2 in
   match r ?= 0 with Eq => true | _ => false end;
  sqrt2       := sqrt312;
- sqrt        := sqrt31
+ sqrt        := sqrt31;
+ lor         := lor31;
+ land        := land31;
+ lxor        := lxor31
 }.
 
 Section Int31_Specs.
@@ -1175,10 +1177,10 @@ Section Int31_Specs.
  Qed.
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wB phi c)  (at level 0, x at level 99).
+   (interp_carry 1 wB phi c)  (at level 0, c at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wB phi c)  (at level 0, x at level 99).
+   (interp_carry (-1) wB phi c)  (at level 0, c at level 99).
 
  Notation "[|| x ||]" :=
    (zn2z_to_Z wB phi x)  (at level 0, x at level 99).
@@ -1412,7 +1414,7 @@ Section Int31_Specs.
  generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros.
  assert ([|b|]>0) by (auto with zarith).
  generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4).
- unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]); simpl.
+ unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]).
  rewrite ?phi_phi_inv.
  destruct 1; intros.
  unfold phi2 in *.
@@ -1442,7 +1444,7 @@ Section Int31_Specs.
  unfold div31; intros.
  assert ([|b|]>0) by (auto with zarith).
  generalize (Z_div_mod [|a|] [|b|] H0) (Z_div_pos [|a|] [|b|] H0).
- unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]); simpl.
+ unfold Z.div; destruct (Z.div_eucl [|a|] [|b|]).
  rewrite ?phi_phi_inv.
  destruct 1; intros.
  rewrite H1, Z.mul_comm.
@@ -1465,7 +1467,7 @@ Section Int31_Specs.
  assert ([|b|]>0) by (auto with zarith).
  unfold Z.modulo.
  generalize (Z_div_mod [|a|] [|b|] H0).
- destruct (Z.div_eucl [|a|] [|b|]); simpl.
+ destruct (Z.div_eucl [|a|] [|b|]).
  rewrite ?phi_phi_inv.
  destruct 1; intros.
  generalize (phi_bounded b); intros.
@@ -1478,15 +1480,14 @@ Section Int31_Specs.
   unfold gcd31.
   induction (2*size)%nat; intros.
   reflexivity.
-  simpl.
+  simpl euler.
   unfold compare31.
   change [|On|] with 0.
   generalize (phi_bounded j)(phi_bounded i); intros.
   case_eq [|j|]; intros.
   simpl; intros.
   generalize (Zabs_spec [|i|]); omega.
-  simpl.
-  rewrite IHn, H1; f_equal.
+  simpl. rewrite IHn, H1; f_equal.
   rewrite spec_mod, H1; auto.
   rewrite H1; compute; auto.
   rewrite H1 in H; destruct H as [H _]; compute in H; elim H; auto.
@@ -1519,17 +1520,17 @@ Section Int31_Specs.
  simpl; auto.
  simpl; intros.
  case_eq (firstr i); intros H; rewrite 2 IHn;
-  unfold phibis_aux; simpl; rewrite H; fold (phibis_aux n (shiftr i));
+  unfold phibis_aux; simpl; rewrite ?H; fold (phibis_aux n (shiftr i));
   generalize (phibis_aux_pos n (shiftr i)); intros;
   set (z := phibis_aux n (shiftr i)) in *; clearbody z;
-  rewrite <- iter_nat_plus.
+  rewrite <- nat_rect_plus.
 
  f_equal.
  rewrite Z.double_spec, <- Z.add_diag.
  symmetry; apply Zabs2Nat.inj_add; auto with zarith.
 
- change (iter_nat (S (Z.abs_nat z + Z.abs_nat z)) A f a =
-         iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal.
+ change (iter_nat (S (Z.abs_nat z) + (Z.abs_nat z))%nat A f a =
+    iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal.
  rewrite Z.succ_double_spec, <- Z.add_diag.
  rewrite Zabs2Nat.inj_add; auto with zarith.
  rewrite Zabs2Nat.inj_add; auto with zarith.
@@ -1554,7 +1555,7 @@ Section Int31_Specs.
  intros.
  simpl addmuldiv31_alt.
  replace (S n) with (n+1)%nat by (rewrite plus_comm; auto).
- rewrite iter_nat_plus; simpl; auto.
+ rewrite nat_rect_plus; simpl; auto.
  Qed.
 
  Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 ->
@@ -1573,10 +1574,9 @@ Section Int31_Specs.
  clear p H; revert x y.
 
  induction n.
- simpl; intros.
- change (Z.pow_pos 2 31) with (2^31).
+ simpl Z.of_nat; intros.
  rewrite Z.mul_1_r.
- replace ([|y|] / 2^31) with 0.
+ replace ([|y|] / 2^(31-0)) with 0.
  rewrite Z.add_0_r.
  symmetry; apply Zmod_small; apply phi_bounded.
  symmetry; apply Zdiv_small; apply phi_bounded.
@@ -1627,7 +1627,7 @@ Section Int31_Specs.
  Lemma spec_pos_mod : forall w p,
        [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
  Proof.
- unfold ZnZ.pos_mod, int31_ops, compare31.
+ unfold int31_ops, ZnZ.pos_mod, compare31.
  change [|31|] with 31%Z.
  assert (forall w p, 31<=p -> [|w|] = [|w|] mod 2^p).
   intros.
@@ -1664,7 +1664,7 @@ Section Int31_Specs.
  Proof.
   intros.
   generalize (phi_inv_phi x).
-  rewrite H; simpl.
+  rewrite H; simpl phi_inv.
   intros H'; rewrite <- H'.
   simpl; auto.
  Qed.
@@ -1739,7 +1739,7 @@ Section Int31_Specs.
  Proof.
  intros.
  rewrite head031_equiv.
- assert (nshiftl size x = 0%int31).
+ assert (nshiftl x size = 0%int31).
   apply nshiftl_size.
  revert x H H0.
  unfold size at 2 5.
@@ -1772,7 +1772,7 @@ Section Int31_Specs.
  Proof.
   intros.
   generalize (phi_inv_phi x).
-  rewrite H; simpl.
+  rewrite H; simpl phi_inv.
   intros H'; rewrite <- H'.
   simpl; auto.
  Qed.
@@ -1837,7 +1837,7 @@ Section Int31_Specs.
  Proof.
  intros.
  rewrite tail031_equiv.
- assert (nshiftr size x = 0%int31).
+ assert (nshiftr x size = 0%int31).
   apply nshiftr_size.
  revert x H H0.
  induction size.
@@ -1957,7 +1957,7 @@ Section Int31_Specs.
 
  Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|].
  intros Hj; generalize (spec_div i j Hj).
- case div31; intros q r; simpl fst.
+ case div31; intros q r; simpl @fst.
  intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith.
  rewrite H1; ring.
  Qed.
@@ -2092,7 +2092,7 @@ Section Int31_Specs.
  generalize (spec_div21 ih il j Hj Hj1).
  case div3121; intros q r (Hq, Hr).
  apply Zdiv_unique with (phi r); auto with zarith.
- simpl fst; apply eq_trans with (1 := Hq); ring.
+ simpl @fst; apply eq_trans with (1 := Hq); ring.
  Qed.
 
  Lemma sqrt312_step_correct rec ih il j:
@@ -2119,7 +2119,7 @@ Section Int31_Specs.
  unfold phi2; rewrite Hc1.
  assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith).
  rewrite Z.mul_comm, Z_div_plus_full_l; unfold base; auto with zarith.
- unfold Z.pow, Z.pow_pos in Hj1; simpl in Hj1; auto with zarith.
+ simpl wB in Hj1. unfold Z.pow_pos in Hj1. simpl in Hj1. auto with zarith.
  case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj.
  rewrite spec_compare; case Z.compare_spec;
   rewrite div312_phi; auto; intros Hc;
@@ -2213,6 +2213,9 @@ Section Int31_Specs.
  apply Nat2Z.is_nonneg.
  Qed.
 
+ (* Avoid expanding [iter312_sqrt] before variables in the context. *)
+ Strategy 1 [iter312_sqrt].
+
  Lemma spec_sqrt2 : forall x y,
        wB/ 4 <= [|x|] ->
        let (s,r) := sqrt312 x y in
@@ -2230,7 +2233,7 @@ Section Int31_Specs.
    2: simpl; unfold Z.pow_pos; simpl; auto with zarith.
    case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4.
    unfold base, Z.pow, Z.pow_pos in H2,H4; simpl in H2,H4.
-   unfold phi2,Z.pow, Z.pow_pos. simpl Pos.iter; auto with zarith. }
+   unfold phi2. cbn [Z.pow Z.pow_pos Pos.iter]. auto with zarith. }
  case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith.
  change [|Tn|] with 2147483647; auto with zarith.
  intros j1 _ HH; contradict HH.
@@ -2255,9 +2258,8 @@ Section Int31_Specs.
  intros Hihl1.
  generalize (spec_sub_c il il1).
  case sub31c; intros il2 Hil2.
- simpl interp_carry in Hil2.
  rewrite spec_compare; case Z.compare_spec.
- unfold interp_carry.
+ unfold interp_carry in *.
  intros H1; split.
  rewrite Z.pow_2_r, <- Hihl1.
  unfold phi2; ring[Hil2 H1].
@@ -2274,7 +2276,7 @@ Section Int31_Specs.
  rewrite Z.mul_add_distr_r, Z.add_0_r; auto with zarith.
  case (phi_bounded il1); intros H3 _.
  apply Z.add_le_mono; auto with zarith.
- unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base.
+ unfold interp_carry in *; change (1 * 2 ^ Z.of_nat size) with base.
  rewrite Z.pow_2_r, <- Hihl1, Hil2.
  intros H1.
  rewrite <- Z.le_succ_l, <- Z.add_1_r in H1.
@@ -2378,8 +2380,8 @@ Qed.
 
  Lemma spec_eq0 : forall x, ZnZ.eq0 x = true -> [|x|] = 0.
  Proof.
- clear; unfold ZnZ.eq0; simpl.
- unfold compare31; simpl; intros.
+ clear; unfold ZnZ.eq0, int31_ops.
+ unfold compare31; intros.
  change [|0|] with 0 in H.
  apply Z.compare_eq.
  now destruct ([|x|] ?= 0).
@@ -2390,7 +2392,7 @@ Qed.
  Lemma spec_is_even : forall x,
       if ZnZ.is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
  Proof.
- unfold ZnZ.is_even; simpl; intros.
+ unfold ZnZ.is_even, int31_ops; intros.
  generalize (spec_div x 2).
  destruct (x/2)%int31 as (q,r); intros.
  unfold compare31.
@@ -2403,6 +2405,51 @@ Qed.
  apply Zmod_unique with [|q|]; auto with zarith.
  Qed.
 
+ (* Bitwise *)
+
+ Lemma log2_phi_bounded x : Z.log2 [|x|] < Z.of_nat size.
+ Proof.
+  destruct (phi_bounded x) as (H,H').
+  Z.le_elim H.
+  - now apply Z.log2_lt_pow2.
+  - now rewrite <- H.
+ Qed.
+
+ Lemma spec_lor x y : [| ZnZ.lor x y |] = Z.lor [|x|] [|y|].
+ Proof.
+ unfold ZnZ.lor,int31_ops. unfold lor31.
+ rewrite phi_phi_inv.
+ apply Z.mod_small; split; trivial.
+ - apply Z.lor_nonneg; split; apply phi_bounded.
+ - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy.
+   rewrite Z.log2_lor; try apply phi_bounded.
+   apply Z.max_lub_lt; apply log2_phi_bounded.
+ Qed.
+
+ Lemma spec_land x y : [| ZnZ.land x y |] = Z.land [|x|] [|y|].
+ Proof.
+ unfold ZnZ.land, int31_ops. unfold land31.
+ rewrite phi_phi_inv.
+ apply Z.mod_small; split; trivial.
+ - apply Z.land_nonneg; left; apply phi_bounded.
+ - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy.
+   eapply Z.le_lt_trans.
+   apply Z.log2_land; try apply phi_bounded.
+   apply Z.min_lt_iff; left; apply log2_phi_bounded.
+ Qed.
+
+ Lemma spec_lxor x y : [| ZnZ.lxor x y |] = Z.lxor [|x|] [|y|].
+ Proof.
+ unfold ZnZ.lxor, int31_ops. unfold lxor31.
+ rewrite phi_phi_inv.
+ apply Z.mod_small; split; trivial.
+ - apply Z.lxor_nonneg; split; intros; apply phi_bounded.
+ - apply Z.log2_lt_cancel. rewrite Z.log2_pow2 by easy.
+   eapply Z.le_lt_trans.
+   apply Z.log2_lxor; try apply phi_bounded.
+   apply Z.max_lub_lt; apply log2_phi_bounded.
+ Qed.
+
  Global Instance int31_specs : ZnZ.Specs int31_ops := {
     spec_to_Z   := phi_bounded;
     spec_of_pos := positive_to_int31_spec;
@@ -2446,7 +2493,10 @@ Qed.
     spec_pos_mod := spec_pos_mod;
     spec_is_even := spec_is_even;
     spec_sqrt2 := spec_sqrt2;
-    spec_sqrt := spec_sqrt }.
+    spec_sqrt := spec_sqrt;
+    spec_lor := spec_lor;
+    spec_land := spec_land;
+    spec_lxor := spec_lxor }.
 
 End Int31_Specs.
 
diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v
index 73f2816a..4e28b5b9 100644
--- a/theories/Numbers/Cyclic/Int31/Int31.v
+++ b/theories/Numbers/Cyclic/Int31/Int31.v
@@ -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        *)
@@ -335,6 +335,11 @@ Definition addmuldiv31 p i j :=
  in
  res.
 
+(** Bitwise operations *)
+
+Definition lor31 n m := phi_inv (Z.lor (phi n) (phi m)).
+Definition land31 n m := phi_inv (Z.land (phi n) (phi m)).
+Definition lxor31 n m := phi_inv (Z.lxor (phi n) (phi m)).
 
 Register add31 as int31 plus in "coq_int31" by True.
 Register add31c as int31 plusc in "coq_int31" by True.
@@ -345,9 +350,15 @@ Register sub31carryc as int31 minuscarryc in "coq_int31" by True.
 Register mul31 as int31 times in "coq_int31" by True.
 Register mul31c as int31 timesc in "coq_int31" by True.
 Register div3121 as int31 div21 in "coq_int31" by True.
-Register div31 as int31 div in "coq_int31" by True.
+Register div31 as int31 diveucl in "coq_int31" by True.
 Register compare31 as int31 compare in "coq_int31" by True.
 Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True.
+Register lor31 as int31 lor in "coq_int31" by True.
+Register land31 as int31 land in "coq_int31" by True.
+Register lxor31 as int31 lxor in "coq_int31" by True.
+
+Definition lnot31 n := lxor31 Tn n.
+Definition ldiff31 n m := land31 n (lnot31 m).
 
 Fixpoint euler (guard:nat) (i j:int31) {struct guard} :=
   match guard with
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
index b2857256..4fde3f53 100644
--- a/theories/Numbers/Cyclic/Int31/Ring31.v
+++ b/theories/Numbers/Cyclic/Int31/Ring31.v
@@ -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/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
index 673e4b1c..b93b4eb3 100644
--- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v
+++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
@@ -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        *)
@@ -38,10 +38,10 @@ Section ZModulo.
  Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).
 
  Notation "[+| c |]" :=
-   (interp_carry 1 wB to_Z c)  (at level 0, x at level 99).
+   (interp_carry 1 wB to_Z c)  (at level 0, c at level 99).
 
  Notation "[-| c |]" :=
-   (interp_carry (-1) wB to_Z c)  (at level 0, x at level 99).
+   (interp_carry (-1) wB to_Z c)  (at level 0, c at level 99).
 
  Notation "[|| x ||]" :=
    (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).
@@ -466,8 +466,8 @@ Section ZModulo.
  generalize (Zgcd_is_gcd a b); inversion_clear 1.
  destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4.
  assert (H4:=Z.gcd_nonneg a b).
- destruct (Z.eq_dec (Z.gcd a b) 0).
- rewrite e; generalize (Zmax_spec a b); omega.
+ destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq].
+ generalize (Zmax_spec a b); omega.
  assert (0 <= q).
   apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith.
  destruct (Z.eq_dec q 0).
@@ -796,6 +796,40 @@ Section ZModulo.
  exists 0; simpl; auto with zarith.
  Qed.
 
+ Definition lor := Z.lor.
+ Definition land := Z.land.
+ Definition lxor := Z.lxor.
+
+ Lemma spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|].
+ Proof.
+ unfold lor, to_Z.
+ apply Z.bits_inj'; intros n Hn. rewrite Z.lor_spec.
+ unfold wB, base.
+ destruct (Z.le_gt_cases (Z.pos digits) n).
+ - rewrite !Z.mod_pow2_bits_high; auto with zarith.
+ - rewrite !Z.mod_pow2_bits_low, Z.lor_spec; auto with zarith.
+ Qed.
+
+ Lemma spec_land x y : [|land x y|] = Z.land [|x|] [|y|].
+ Proof.
+ unfold land, to_Z.
+ apply Z.bits_inj'; intros n Hn. rewrite Z.land_spec.
+ unfold wB, base.
+ destruct (Z.le_gt_cases (Z.pos digits) n).
+ - rewrite !Z.mod_pow2_bits_high; auto with zarith.
+ - rewrite !Z.mod_pow2_bits_low, Z.land_spec; auto with zarith.
+ Qed.
+
+ Lemma spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|].
+ Proof.
+ unfold lxor, to_Z.
+ apply Z.bits_inj'; intros n Hn. rewrite Z.lxor_spec.
+ unfold wB, base.
+ destruct (Z.le_gt_cases (Z.pos digits) n).
+ - rewrite !Z.mod_pow2_bits_high; auto with zarith.
+ - rewrite !Z.mod_pow2_bits_low, Z.lxor_spec; auto with zarith.
+ Qed.
+
  (** Let's now group everything in two records *)
 
  Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps
@@ -849,7 +883,10 @@ Section ZModulo.
 
     (is_even     : t -> bool)
     (sqrt2       : t -> t -> t * carry t)
-    (sqrt        : t -> t).
+    (sqrt        : t -> t)
+    (lor         : t -> t -> t)
+    (land         : t -> t -> t)
+    (lxor         : t -> t -> t).
 
  Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs
     spec_to_Z
@@ -906,7 +943,10 @@ Section ZModulo.
 
     spec_is_even
     spec_sqrt2
-    spec_sqrt.
+    spec_sqrt
+    spec_lor
+    spec_land
+    spec_lxor.
 
 End ZModulo.
 
@@ -922,4 +962,3 @@ Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType.
  Instance ops : ZnZ.Ops t := zmod_ops P.p.
  Instance specs : ZnZ.Specs ops := zmod_specs P.not_one.
 End ZModuloCyclicType.
-
diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v
index e109948d..ec8801c4 100644
--- a/theories/Numbers/Integer/Abstract/ZAdd.v
+++ b/theories/Numbers/Integer/Abstract/ZAdd.v
@@ -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/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v
index a5023310..e341ea8a 100644
--- a/theories/Numbers/Integer/Abstract/ZAddOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -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/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v
index d6a9a6b3..2a9fa539 100644
--- a/theories/Numbers/Integer/Abstract/ZAxioms.v
+++ b/theories/Numbers/Integer/Abstract/ZAxioms.v
@@ -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/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v
index cb3c965b..6634eab1 100644
--- a/theories/Numbers/Integer/Abstract/ZBase.v
+++ b/theories/Numbers/Integer/Abstract/ZBase.v
@@ -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/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v
index f986b64b..9dd0ec0e 100644
--- a/theories/Numbers/Integer/Abstract/ZBits.v
+++ b/theories/Numbers/Integer/Abstract/ZBits.v
@@ -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/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v
index 06f6c903..d0df8fb4 100644
--- a/theories/Numbers/Integer/Abstract/ZDivEucl.v
+++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v
@@ -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/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v
index d38b2199..d5f3f4ad 100644
--- a/theories/Numbers/Integer/Abstract/ZDivFloor.v
+++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v
@@ -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/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
index fb4646f9..de2e99ec 100644
--- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v
+++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v
@@ -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/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v
index 6759662c..cf6ff79e 100644
--- a/theories/Numbers/Integer/Abstract/ZGcd.v
+++ b/theories/Numbers/Integer/Abstract/ZGcd.v
@@ -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/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v
index 8616343e..9a1768eb 100644
--- a/theories/Numbers/Integer/Abstract/ZLcm.v
+++ b/theories/Numbers/Integer/Abstract/ZLcm.v
@@ -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/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v
index f59b545f..6d0cdb01 100644
--- a/theories/Numbers/Integer/Abstract/ZLt.v
+++ b/theories/Numbers/Integer/Abstract/ZLt.v
@@ -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/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v
index 97bb074a..07c78ead 100644
--- a/theories/Numbers/Integer/Abstract/ZMaxMin.v
+++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v
@@ -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/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v
index d45fc2f5..2d78d8f3 100644
--- a/theories/Numbers/Integer/Abstract/ZMul.v
+++ b/theories/Numbers/Integer/Abstract/ZMul.v
@@ -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/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v
index 750c6ad3..487aaae1 100644
--- a/theories/Numbers/Integer/Abstract/ZMulOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v
@@ -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/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v
index 79ed9e4a..195a0277 100644
--- a/theories/Numbers/Integer/Abstract/ZParity.v
+++ b/theories/Numbers/Integer/Abstract/ZParity.v
@@ -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/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v
index d5a0a1a4..87de2c78 100644
--- a/theories/Numbers/Integer/Abstract/ZPow.v
+++ b/theories/Numbers/Integer/Abstract/ZPow.v
@@ -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/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v
index d278275a..5cfeeb21 100644
--- a/theories/Numbers/Integer/Abstract/ZProperties.v
+++ b/theories/Numbers/Integer/Abstract/ZProperties.v
@@ -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        *)
@@ -9,11 +9,22 @@
 Require Export ZAxioms ZMaxMin ZSgnAbs ZParity ZPow ZDivTrunc ZDivFloor
  ZGcd ZLcm NZLog NZSqrt ZBits.
 
-(** This functor summarizes all known facts about Z. *)
+(** The two following functors summarize all known facts about N.
 
-Module Type ZProp (Z:ZAxiomsSig) :=
- ZMaxMinProp Z <+ ZSgnAbsProp Z <+ ZParityProp Z <+ ZPowProp Z
- <+ NZSqrtProp Z Z <+ NZSqrtUpProp Z Z
- <+ NZLog2Prop Z Z Z <+ NZLog2UpProp Z Z Z
- <+ ZDivProp Z <+ ZQuotProp Z <+ ZGcdProp Z <+ ZLcmProp Z
- <+ ZBitsProp Z.
+    - [ZBasicProp] provides properties of basic functions:
+      + - * min max <= <
+
+    - [ZExtraProp] provides properties of advanced functions:
+      pow, sqrt, log2, div, gcd, and bitwise functions.
+
+    If necessary, the earlier all-in-one functor [ZProp]
+    could be re-obtained via [ZBasicProp <+ ZExtraProp] *)
+
+Module Type ZBasicProp (Z:ZAxiomsMiniSig) := ZMaxMinProp Z.
+
+Module Type ZExtraProp (Z:ZAxiomsSig)(P:ZBasicProp Z) :=
+ ZSgnAbsProp Z P <+ ZParityProp Z P <+ ZPowProp Z P
+ <+ NZSqrtProp Z Z P <+ NZSqrtUpProp Z Z P
+ <+ NZLog2Prop Z Z Z P <+ NZLog2UpProp Z Z Z P
+ <+ ZDivProp Z P <+ ZQuotProp Z P <+ ZGcdProp Z P <+ ZLcmProp Z P
+ <+ ZBitsProp Z P.
diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
index c708e883..b379853e 100644
--- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v
+++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v
@@ -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/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v
index 1e0cfa17..b28bc40f 100644
--- a/theories/Numbers/Integer/BigZ/BigZ.v
+++ b/theories/Numbers/Integer/BigZ/BigZ.v
@@ -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        *)
@@ -26,15 +26,13 @@ Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake.
 
 Delimit Scope bigZ_scope with bigZ.
 
-Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder.
- Include ZMake.Make BigN [scope abstract_scope to bigZ_scope].
- Bind Scope bigZ_scope with t t_.
- Include ZTypeIsZAxioms
- <+ ZProp [no inline]
+Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder :=
+ ZMake.Make BigN
+ <+ ZTypeIsZAxioms
+ <+ ZBasicProp [no inline] <+ ZExtraProp [no inline]
  <+ HasEqBool2Dec [no inline]
  <+ MinMaxLogicalProperties [no inline]
  <+ MinMaxDecProperties [no inline].
-End BigZ.
 
 (** For precision concerning the above scope handling, see comment in BigN *)
 
diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v
index b1f84393..af4f1d93 100644
--- a/theories/Numbers/Integer/BigZ/ZMake.v
+++ b/theories/Numbers/Integer/BigZ/ZMake.v
@@ -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        *)
@@ -29,8 +29,6 @@ Module Make (NN:NType) <: ZType.
 
  Definition t := t_.
 
- Bind Scope abstract_scope with t t_.
-
  Definition zero := Pos NN.zero.
  Definition one  := Pos NN.one.
  Definition two := Pos NN.two.
diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v
index a70a72ea..04208106 100644
--- a/theories/Numbers/Integer/Binary/ZBinary.v
+++ b/theories/Numbers/Integer/Binary/ZBinary.v
@@ -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/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
index 1f7d8dbc..02f02fbc 100644
--- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v
+++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
@@ -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        *)
@@ -332,9 +332,9 @@ and get their properties *)
 
 (* The following lines increase the compilation time at least twice *)
 (*
-Require Import NPeano.
+Require PeanoNat.
 
-Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod NPeanoAxiomsMod.
+Module Export ZPairsPeanoAxiomsMod := ZPairsAxiomsMod PeanoNat.Nat.
 Module Export ZPairsPropMod := ZPropFunct ZPairsPeanoAxiomsMod.
 
 Eval compute in (3, 5) * (4, 6).
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v
index eaa181a6..30ac32b5 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSig.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v
@@ -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/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
index 933b53e4..c9dc687c 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
@@ -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/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v
index 54542f64..6fdf0a2a 100644
--- a/theories/Numbers/NaryFunctions.v
+++ b/theories/Numbers/NaryFunctions.v
@@ -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/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v
index 2cef31ae..501583ae 100644
--- a/theories/Numbers/NatInt/NZAdd.v
+++ b/theories/Numbers/NatInt/NZAdd.v
@@ -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/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v
index c9bc8824..619a6634 100644
--- a/theories/Numbers/NatInt/NZAddOrder.v
+++ b/theories/Numbers/NatInt/NZAddOrder.v
@@ -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/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v
index e8f7def7..c88341fa 100644
--- a/theories/Numbers/NatInt/NZAxioms.v
+++ b/theories/Numbers/NatInt/NZAxioms.v
@@ -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        *)
@@ -19,7 +19,8 @@ Require Export Equalities Orders NumPrelude GenericMinMax.
 
 Module Type ZeroSuccPred (Import T:Typ).
  Parameter Inline(20) zero : t.
- Parameters Inline succ pred : t -> t.
+ Parameter Inline(50) succ : t -> t.
+ Parameter Inline pred : t -> t.
 End ZeroSuccPred.
 
 Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T).
diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v
index 56c999d4..c0afa098 100644
--- a/theories/Numbers/NatInt/NZBase.v
+++ b/theories/Numbers/NatInt/NZBase.v
@@ -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        *)
@@ -12,11 +12,6 @@ Require Import NZAxioms.
 
 Module Type NZBaseProp (Import NZ : NZDomainSig').
 
-(** An artificial scope meant to be substituted later *)
-
-Delimit Scope abstract_scope with abstract.
-Bind Scope abstract_scope with t.
-
 Include BackportEq NZ NZ. (** eq_refl, eq_sym, eq_trans *)
 
 Lemma eq_sym_iff : forall x y, x==y <-> y==x.
diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v
index 31e99340..1c118597 100644
--- a/theories/Numbers/NatInt/NZBits.v
+++ b/theories/Numbers/NatInt/NZBits.v
@@ -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/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v
index 339563c0..4a127216 100644
--- a/theories/Numbers/NatInt/NZDiv.v
+++ b/theories/Numbers/NatInt/NZDiv.v
@@ -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/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v
index c9001db2..ffb04f08 100644
--- a/theories/Numbers/NatInt/NZDomain.v
+++ b/theories/Numbers/NatInt/NZDomain.v
@@ -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        *)
@@ -14,14 +14,12 @@ Require Import NZBase NZOrder NZAddOrder Plus Minus.
     translation from Peano numbers [nat] into NZ.
 *)
 
-(** First, some complements about [nat_iter] *)
+Local Notation "f ^ n" := (fun x => nat_rect _ x (fun _ => f) n).
 
-Local Notation "f ^ n" := (nat_iter n f).
-
-Instance nat_iter_wd n {A} (R:relation A) :
- Proper ((R==>R)==>R==>R) (nat_iter n).
+Instance nat_rect_wd n {A} (R:relation A) :
+ Proper (R==>(R==>R)==>R) (fun x f => nat_rect (fun _ => _) x (fun _ => f) n).
 Proof.
-intros f f' Hf. induction n; simpl; red; auto.
+intros x y eq_xy f g eq_fg; induction n; [assumption | now apply eq_fg].
 Qed.
 
 Module NZDomainProp (Import NZ:NZDomainSig').
@@ -33,17 +31,24 @@ Include NZBaseProp NZ.
 
 Lemma itersucc_or_itersucc n m : exists k, n == (S^k) m \/ m == (S^k) n.
 Proof.
-nzinduct n m.
+revert n.
+apply central_induction with (z:=m).
+ { intros x y eq_xy; apply ex_iff_morphism.
+  intros n; apply or_iff_morphism.
+ + split; intros; etransitivity; try eassumption; now symmetry.
+ + split; intros; (etransitivity; [eassumption|]); [|symmetry];
+    (eapply nat_rect_wd; [eassumption|apply succ_wd]).
+ }
 exists 0%nat. now left.
 intros n. split; intros [k [L|R]].
 exists (Datatypes.S k). left. now apply succ_wd.
 destruct k as [|k].
 simpl in R. exists 1%nat. left. now apply succ_wd.
-rewrite nat_iter_succ_r in R. exists k. now right.
+rewrite nat_rect_succ_r in R. exists k. now right.
 destruct k as [|k]; simpl in L.
 exists 1%nat. now right.
 apply succ_inj in L. exists k. now left.
-exists (Datatypes.S k). right. now rewrite nat_iter_succ_r.
+exists (Datatypes.S k). right. now rewrite nat_rect_succ_r.
 Qed.
 
 (** Generalized version of [pred_succ] when iterating *)
@@ -53,7 +58,7 @@ Proof.
 induction k.
 simpl; auto with *.
 simpl; intros. apply pred_wd in H. rewrite pred_succ in H. apply IHk in H; auto.
-rewrite <- nat_iter_succ_r in H; auto.
+rewrite <- nat_rect_succ_r in H; auto.
 Qed.
 
 (** From a given point, all others are iterated successors
@@ -319,7 +324,7 @@ Lemma ofnat_add : forall n m, [n+m] == [n]+[m].
 Proof.
  intros. rewrite ofnat_add_l.
  induction n; simpl. reflexivity.
- rewrite ofnat_succ. now f_equiv.
+ now f_equiv.
 Qed.
 
 Lemma ofnat_mul : forall n m, [n*m] == [n]*[m].
@@ -327,15 +332,15 @@ Proof.
  induction n; simpl; intros.
  symmetry. apply mul_0_l.
  rewrite plus_comm.
- rewrite ofnat_succ, ofnat_add, mul_succ_l.
+ rewrite ofnat_add, mul_succ_l.
  now f_equiv.
 Qed.
 
 Lemma ofnat_sub_r : forall n m, n-[m] == (P^m) n.
 Proof.
  induction m; simpl; intros.
- rewrite ofnat_zero. apply sub_0_r.
- rewrite ofnat_succ, sub_succ_r. now f_equiv.
+ apply sub_0_r.
+ rewrite sub_succ_r. now f_equiv.
 Qed.
 
 Lemma ofnat_sub : forall n m, m<=n -> [n-m] == [n]-[m].
@@ -346,9 +351,10 @@ Proof.
  intros.
  destruct n.
  inversion H.
- rewrite nat_iter_succ_r.
+ rewrite nat_rect_succ_r.
  simpl.
- rewrite ofnat_succ, pred_succ; auto with arith.
+ etransitivity. apply IHm. auto with arith.
+    eapply nat_rect_wd; [symmetry;apply pred_succ|apply pred_wd].
 Qed.
 
 End NZOfNatOps.
diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v
index 0fd543c0..42bee315 100644
--- a/theories/Numbers/NatInt/NZGcd.v
+++ b/theories/Numbers/NatInt/NZGcd.v
@@ -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        *)
@@ -107,8 +107,8 @@ Proof.
  now rewrite Hr, Hq, mul_assoc.
 Qed.
 
-Instance divide_reflexive : Reflexive divide := divide_refl.
-Instance divide_transitive : Transitive divide := divide_trans.
+Instance divide_reflexive : Reflexive divide | 5 := divide_refl.
+Instance divide_transitive : Transitive divide | 5 := divide_trans.
 
 (** Due to sign, no general antisymmetry result *)
 
diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v
index 72f5e516..9cd1f877 100644
--- a/theories/Numbers/NatInt/NZLog.v
+++ b/theories/Numbers/NatInt/NZLog.v
@@ -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/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v
index a3419383..89ace4de 100644
--- a/theories/Numbers/NatInt/NZMul.v
+++ b/theories/Numbers/NatInt/NZMul.v
@@ -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/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v
index ef5250fa..e79e50a9 100644
--- a/theories/Numbers/NatInt/NZMulOrder.v
+++ b/theories/Numbers/NatInt/NZMulOrder.v
@@ -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/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v
index 0f7be085..c1e83529 100644
--- a/theories/Numbers/NatInt/NZOrder.v
+++ b/theories/Numbers/NatInt/NZOrder.v
@@ -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        *)
@@ -644,6 +644,8 @@ End NZOrderProp.
 (** If we have moreover a [compare] function, we can build
     an [OrderedType] structure. *)
 
+(* Temporary workaround for bug #2949: remove this problematic + unused functor
 Module NZOrderedType (NZ : NZDecOrdSig')
  <: DecidableTypeFull <: OrderedTypeFull
- := NZ <+ NZBaseProp <+ NZOrderProp NZ <+ Compare2EqBool <+ HasEqBool2Dec.
+ := NZ <+ NZBaseProp <+ NZOrderProp <+ Compare2EqBool <+ HasEqBool2Dec.
+*)
diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v
index 074fbfdd..6b9a680a 100644
--- a/theories/Numbers/NatInt/NZParity.v
+++ b/theories/Numbers/NatInt/NZParity.v
@@ -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        *)
@@ -95,7 +95,7 @@ Proof.
  intros.
  generalize (Even_or_Odd n) (Even_Odd_False n).
  rewrite <- even_spec, <- odd_spec.
- destruct (odd n), (even n); simpl; intuition.
+ destruct (odd n), (even n) ; simpl; intuition.
 Qed.
 
 Lemma negb_even : forall n, negb (even n) = odd n.
diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v
index d2d34190..38452119 100644
--- a/theories/Numbers/NatInt/NZPow.v
+++ b/theories/Numbers/NatInt/NZPow.v
@@ -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        *)
@@ -30,7 +30,7 @@ Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A).
 End NZPowSpec.
 
 (** The above [pow_neg_r] specification is useless (and trivially
-   provable) for N. Having it here allows to already derive
+   provable) for N. Having it here already allows deriving
    some slightly more general statements. *)
 
 Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A.
diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v
index f44f23e9..0f3a5caf 100644
--- a/theories/Numbers/NatInt/NZProperties.v
+++ b/theories/Numbers/NatInt/NZProperties.v
@@ -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/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v
index 304a84a8..894c0806 100644
--- a/theories/Numbers/NatInt/NZSqrt.v
+++ b/theories/Numbers/NatInt/NZSqrt.v
@@ -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        *)
@@ -66,7 +66,7 @@ Qed.
 Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b.
 Proof.
  intros a b (LEb,LTb).
- assert (Ha : 0<=a) by (transitivity b²; trivial using square_nonneg).
+ assert (Ha : 0<=a) by (transitivity (b²); trivial using square_nonneg).
  assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order).
  assert (Ha': 0<=√a) by now apply sqrt_nonneg.
  destruct (sqrt_spec a Ha) as (LEa,LTa).
@@ -438,7 +438,7 @@ Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up.
 Proof.
  assert (Proper (eq==>eq==>Logic.eq) compare).
   intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order.
- intros x x' Hx. unfold sqrt_up. rewrite Hx. case compare; now rewrite ?Hx.
+ intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx.
 Qed.
 
 (** The spec of [sqrt_up] indeed determines it *)
diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v
index e2dabf0e..638cfc7e 100644
--- a/theories/Numbers/Natural/Abstract/NAdd.v
+++ b/theories/Numbers/Natural/Abstract/NAdd.v
@@ -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/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v
index 94dc9e79..144bce72 100644
--- a/theories/Numbers/Natural/Abstract/NAddOrder.v
+++ b/theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -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/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v
index c783478d..d300f857 100644
--- a/theories/Numbers/Natural/Abstract/NAxioms.v
+++ b/theories/Numbers/Natural/Abstract/NAxioms.v
@@ -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/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v
index a2bf4109..40453214 100644
--- a/theories/Numbers/Natural/Abstract/NBase.v
+++ b/theories/Numbers/Natural/Abstract/NBase.v
@@ -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/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v
index d368cc4e..6f8a8fe5 100644
--- a/theories/Numbers/Natural/Abstract/NBits.v
+++ b/theories/Numbers/Natural/Abstract/NBits.v
@@ -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/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v
index 882bb850..892b9266 100644
--- a/theories/Numbers/Natural/Abstract/NDefOps.v
+++ b/theories/Numbers/Natural/Abstract/NDefOps.v
@@ -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        *)
@@ -133,7 +133,6 @@ Proof.
 intros m n; unfold ltb at 1.
 f_equiv.
 rewrite recursion_succ; f_equiv'.
-reflexivity.
 Qed.
 
 (* Above, we rewrite applications of function. Is it possible to rewrite
diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v
index 90a4e9e8..fb68c139 100644
--- a/theories/Numbers/Natural/Abstract/NDiv.v
+++ b/theories/Numbers/Natural/Abstract/NDiv.v
@@ -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/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v
index ff38b364..a1f4ddf8 100644
--- a/theories/Numbers/Natural/Abstract/NGcd.v
+++ b/theories/Numbers/Natural/Abstract/NGcd.v
@@ -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/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v
index 00f91311..c296315d 100644
--- a/theories/Numbers/Natural/Abstract/NIso.v
+++ b/theories/Numbers/Natural/Abstract/NIso.v
@@ -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/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v
index 6236360b..0fe8e105 100644
--- a/theories/Numbers/Natural/Abstract/NLcm.v
+++ b/theories/Numbers/Natural/Abstract/NLcm.v
@@ -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/theories/Numbers/Natural/Abstract/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v
index f3418ef8..605c0aad 100644
--- a/theories/Numbers/Natural/Abstract/NLog.v
+++ b/theories/Numbers/Natural/Abstract/NLog.v
@@ -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/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v
index 9fa4114b..e0710561 100644
--- a/theories/Numbers/Natural/Abstract/NMaxMin.v
+++ b/theories/Numbers/Natural/Abstract/NMaxMin.v
@@ -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/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v
index 2aaf20ef..c41275d2 100644
--- a/theories/Numbers/Natural/Abstract/NMulOrder.v
+++ b/theories/Numbers/Natural/Abstract/NMulOrder.v
@@ -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/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v
index a46207ec..90053a73 100644
--- a/theories/Numbers/Natural/Abstract/NOrder.v
+++ b/theories/Numbers/Natural/Abstract/NOrder.v
@@ -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/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v
index 62d71eae..b3526c9a 100644
--- a/theories/Numbers/Natural/Abstract/NParity.v
+++ b/theories/Numbers/Natural/Abstract/NParity.v
@@ -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/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v
index c35757af..9cc23004 100644
--- a/theories/Numbers/Natural/Abstract/NPow.v
+++ b/theories/Numbers/Natural/Abstract/NPow.v
@@ -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/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v
index 575ede4f..cb3501d4 100644
--- a/theories/Numbers/Natural/Abstract/NProperties.v
+++ b/theories/Numbers/Natural/Abstract/NProperties.v
@@ -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        *)
@@ -9,9 +9,20 @@
 Require Export NAxioms.
 Require Import NMaxMin NParity NPow NSqrt NLog NDiv NGcd NLcm NBits.
 
-(** This functor summarizes all known facts about N. *)
+(** The two following functors summarize all known facts about N.
 
-Module Type NProp (N:NAxiomsSig) :=
- NMaxMinProp N <+ NParityProp N <+ NPowProp N <+ NSqrtProp N
-  <+ NLog2Prop N <+ NDivProp N <+ NGcdProp N <+ NLcmProp N
-  <+ NBitsProp N.
+    - [NBasicProp] provides properties of basic functions:
+      + - * min max <= <
+
+    - [NExtraProp] provides properties of advanced functions:
+      pow, sqrt, log2, div, gcd, and bitwise functions.
+
+    If necessary, the earlier all-in-one functor [NProp]
+    could be re-obtained via [NBasicProp <+ NExtraProp] *)
+
+Module Type NBasicProp (N:NAxiomsMiniSig) := NMaxMinProp N.
+
+Module Type NExtraProp (N:NAxiomsSig)(P:NBasicProp N) :=
+ NParityProp N P <+ NPowProp N P <+ NSqrtProp N P
+  <+ NLog2Prop N P <+ NDivProp N P <+ NGcdProp N P <+ NLcmProp N P
+  <+ NBitsProp N P.
diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v
index bc989a81..8dc66884 100644
--- a/theories/Numbers/Natural/Abstract/NSqrt.v
+++ b/theories/Numbers/Natural/Abstract/NSqrt.v
@@ -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/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v
index 7ec44dec..896ffc18 100644
--- a/theories/Numbers/Natural/Abstract/NStrongRec.v
+++ b/theories/Numbers/Natural/Abstract/NStrongRec.v
@@ -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        *)
@@ -13,7 +13,7 @@ and proves its properties *)
 
 Require Export NSub.
 
-Ltac f_equiv' := repeat progress (f_equiv; try intros ? ? ?; auto).
+Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto).
 
 Module NStrongRecProp (Import N : NAxiomsRecSig').
 Include NSubProp N.
@@ -24,7 +24,7 @@ Variable A : Type.
 Variable Aeq : relation A.
 Variable Aeq_equiv : Equivalence Aeq.
 
-(** [strong_rec] allows to define a recursive function [phi] given by
+(** [strong_rec] allows defining a recursive function [phi] given by
     an equation [phi(n) = F(phi)(n)] where recursive calls to [phi]
     in [F] are made on strictly lower numbers than [n].
 
@@ -82,7 +82,6 @@ Proof.
 intros. unfold strong_rec0.
 f_equiv.
 rewrite recursion_succ; f_equiv'.
-reflexivity.
 Qed.
 
 Lemma strong_rec_0 : forall a,
diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v
index db61dd9b..18ebe77b 100644
--- a/theories/Numbers/Natural/Abstract/NSub.v
+++ b/theories/Numbers/Natural/Abstract/NSub.v
@@ -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/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v
index 89b65617..f7f4347b 100644
--- a/theories/Numbers/Natural/BigN/BigN.v
+++ b/theories/Numbers/Natural/BigN/BigN.v
@@ -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        *)
@@ -28,23 +28,13 @@ Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake
 
 Delimit Scope bigN_scope with bigN.
 
-Module BigN <: NType <: OrderedTypeFull <: TotalOrder.
- Include NMake.Make Int31Cyclic [scope abstract_scope to bigN_scope].
- Bind Scope bigN_scope with t t'.
- Include NTypeIsNAxioms
-  <+ NProp [no inline]
+Module BigN <: NType <: OrderedTypeFull <: TotalOrder :=
+  NMake.Make Int31Cyclic
+  <+ NTypeIsNAxioms
+  <+ NBasicProp [no inline] <+ NExtraProp [no inline]
   <+ HasEqBool2Dec [no inline]
   <+ MinMaxLogicalProperties [no inline]
   <+ MinMaxDecProperties [no inline].
-End BigN.
-
-(** Nota concerning scopes : for the first Include, we cannot bind
-    the scope bigN_scope to a type that doesn't exists yet.
-    We hence need to explicitely declare the scope substitution.
-    For the next Include, the abstract type t (in scope abstract_scope)
-    gets substituted to concrete BigN.t (in scope bigN_scope),
-    and the corresponding argument scope are fixed automatically.
-*)
 
 (** Notations about [BigN] *)
 
diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v
index d280a04b..bdcdd5ca 100644
--- a/theories/Numbers/Natural/BigN/NMake.v
+++ b/theories/Numbers/Natural/BigN/NMake.v
@@ -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        *)
@@ -146,7 +146,7 @@ Module Make (W0:CyclicType) <: NType.
  Theorem spec_add: forall x y, [add x y] = [x] + [y].
  Proof.
   intros x y. rewrite add_fold. apply spec_same_level; clear x y.
-  intros n x y. simpl.
+  intros n x y. cbv beta iota zeta.
   generalize (ZnZ.spec_add_c x y); case ZnZ.add_c; intros z H.
   rewrite spec_mk_t. assumption.
   rewrite spec_mk_t_S. unfold interp_carry in H.
@@ -242,8 +242,8 @@ Module Make (W0:CyclicType) <: NType.
  Definition comparen_m n :
   forall m, word (dom_t n) (S m) -> dom_t n -> comparison :=
   let op := dom_op n in
-  let zero := @ZnZ.zero _ op in
-  let compare := @ZnZ.compare _ op in
+  let zero := ZnZ.zero (Ops:=op) in
+  let compare := ZnZ.compare (Ops:=op) in
   let compare0 := compare zero in
   fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m).
 
@@ -273,7 +273,7 @@ Module Make (W0:CyclicType) <: NType.
 
  Local Notation compare_folded :=
    (iter_sym _
-      (fun n => @ZnZ.compare _ (dom_op n))
+      (fun n => ZnZ.compare (Ops:=dom_op n))
       comparen_m
       comparenm
       CompOpp).
@@ -358,13 +358,13 @@ Module Make (W0:CyclicType) <: NType.
 
  Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t :=
   let op := dom_op n in
-  let zero := @ZnZ.zero _ op in
-  let succ := @ZnZ.succ _ op in
-  let add_c := @ZnZ.add_c _ op in
-  let mul_c := @ZnZ.mul_c _ op in
+  let zero := ZnZ.zero in
+  let succ := ZnZ.succ (Ops:=op) in
+  let add_c := ZnZ.add_c (Ops:=op) in
+  let mul_c := ZnZ.mul_c (Ops:=op) in
   let ww := @ZnZ.WW _ op in
   let ow := @ZnZ.OW _ op in
-  let eq0 := @ZnZ.eq0 _ op in
+  let eq0 := ZnZ.eq0 in
   let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in
   let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in
   fun m x y =>
@@ -464,18 +464,18 @@ Module Make (W0:CyclicType) <: NType.
  Definition wn_divn1 n :=
   let op := dom_op n in
   let zd := ZnZ.zdigits op in
-  let zero := @ZnZ.zero _ op in
-  let ww := @ZnZ.WW _ op in
-  let head0 := @ZnZ.head0 _ op in
-  let add_mul_div := @ZnZ.add_mul_div _ op in
-  let div21 := @ZnZ.div21 _ op in
-  let compare := @ZnZ.compare _ op in
-  let sub := @ZnZ.sub _ op in
+  let zero := ZnZ.zero in
+  let ww := ZnZ.WW in
+  let head0 := ZnZ.head0 in
+  let add_mul_div := ZnZ.add_mul_div in
+  let div21 := ZnZ.div21 in
+  let compare := ZnZ.compare in
+  let sub := ZnZ.sub in
   let ddivn1 :=
     DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in
   fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v).
 
- Let div_gtnm n m wx wy :=
+ Definition div_gtnm n m wx wy :=
     let mn := Max.max n m in
     let d := diff n m in
     let op := make_op mn in
@@ -522,7 +522,7 @@ Module Make (W0:CyclicType) <: NType.
   case (ZnZ.spec_to_Z y); auto.
  Qed.
 
- Let spec_divn1 n :=
+ Definition spec_divn1 n :=
    DoubleDivn1.spec_double_divn1
     (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n)
     ZnZ.WW ZnZ.head0
@@ -633,17 +633,17 @@ Module Make (W0:CyclicType) <: NType.
  Definition wn_modn1 n :=
   let op := dom_op n in
   let zd := ZnZ.zdigits op in
-  let zero := @ZnZ.zero _ op in
-  let head0 := @ZnZ.head0 _ op in
-  let add_mul_div := @ZnZ.add_mul_div _ op in
-  let div21 := @ZnZ.div21 _ op in
-  let compare := @ZnZ.compare _ op in
-  let sub := @ZnZ.sub _ op in
+  let zero := ZnZ.zero in
+  let head0 := ZnZ.head0 in
+  let add_mul_div := ZnZ.add_mul_div in
+  let div21 := ZnZ.div21 in
+  let compare := ZnZ.compare in
+  let sub := ZnZ.sub in
   let dmodn1 :=
     DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in
   fun m x y => reduce n (dmodn1 (S m) x y).
 
- Let mod_gtnm n m wx wy :=
+ Definition mod_gtnm n m wx wy :=
     let mn := Max.max n m in
     let d := diff n m in
     let op := make_op mn in
@@ -671,7 +671,7 @@ Module Make (W0:CyclicType) <: NType.
   reflexivity.
  Qed.
 
- Let spec_modn1 n :=
+ Definition spec_modn1 n :=
    DoubleDivn1.spec_double_modn1
     (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n)
     ZnZ.WW ZnZ.head0
@@ -1617,40 +1617,90 @@ Module Make (W0:CyclicType) <: NType.
   rewrite spec_shiftr, spec_1. apply Z.div2_spec.
  Qed.
 
- (** TODO : provide efficient versions instead of just converting
-   from/to N (see with Laurent) *)
+ Local Notation lorn := (fun n =>
+  let op := dom_op n in
+  let lor := ZnZ.lor in
+  fun x y => reduce n (lor x y)).
+
+ Definition lor : t -> t -> t := Eval red_t in same_level lorn.
 
- Definition lor x y := of_N (N.lor (to_N x) (to_N y)).
- Definition land x y := of_N (N.land (to_N x) (to_N y)).
- Definition ldiff x y := of_N (N.ldiff (to_N x) (to_N y)).
- Definition lxor x y := of_N (N.lxor (to_N x) (to_N y)).
+ Lemma lor_fold : lor = same_level lorn.
+ Proof. red_t; reflexivity. Qed.
 
- Lemma spec_land: forall x y, [land x y] = Z.land [x] [y].
+ Theorem spec_lor x y : [lor x y] = Z.lor [x] [y].
  Proof.
-  intros x y. unfold land. rewrite spec_of_N. unfold to_N.
-  generalize (spec_pos x), (spec_pos y).
-  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+  rewrite lor_fold. apply spec_same_level; clear x y.
+  intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lor.
  Qed.
 
- Lemma spec_lor: forall x y, [lor x y] = Z.lor [x] [y].
+ Local Notation landn := (fun n =>
+  let op := dom_op n in
+  let land := ZnZ.land in
+  fun x y => reduce n (land x y)).
+
+ Definition land : t -> t -> t := Eval red_t in same_level landn.
+
+ Lemma land_fold : land = same_level landn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_land x y : [land x y] = Z.land [x] [y].
  Proof.
-  intros x y. unfold lor. rewrite spec_of_N. unfold to_N.
-  generalize (spec_pos x), (spec_pos y).
-  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+  rewrite land_fold. apply spec_same_level; clear x y.
+  intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_land.
  Qed.
 
- Lemma spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y].
+ Local Notation lxorn := (fun n =>
+  let op := dom_op n in
+  let lxor := ZnZ.lxor in
+  fun x y => reduce n (lxor x y)).
+
+ Definition lxor : t -> t -> t := Eval red_t in same_level lxorn.
+
+ Lemma lxor_fold : lxor = same_level lxorn.
+ Proof. red_t; reflexivity. Qed.
+
+ Theorem spec_lxor x y : [lxor x y] = Z.lxor [x] [y].
  Proof.
-  intros x y. unfold ldiff. rewrite spec_of_N. unfold to_N.
-  generalize (spec_pos x), (spec_pos y).
-  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+  rewrite lxor_fold. apply spec_same_level; clear x y.
+  intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lxor.
  Qed.
 
- Lemma spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y].
- Proof.
-  intros x y. unfold lxor. rewrite spec_of_N. unfold to_N.
-  generalize (spec_pos x), (spec_pos y).
-  destruct [x], [y]; trivial; (now destruct 1) || (now destruct 2).
+ Local Notation ldiffn := (fun n =>
+  let op := dom_op n in
+  let lxor := ZnZ.lxor in
+  let land := ZnZ.land in
+  let m1 := ZnZ.minus_one in
+  fun x y => reduce n (land x (lxor y m1))).
+
+ Definition ldiff : t -> t -> t := Eval red_t in same_level ldiffn.
+
+ Lemma ldiff_fold : ldiff = same_level ldiffn.
+ Proof. red_t; reflexivity. Qed.
+
+ Lemma ldiff_alt x y p :
+  0 <= x < 2^p -> 0 <= y < 2^p ->
+  Z.ldiff x y = Z.land x (Z.lxor y (2^p - 1)).
+ Proof.
+  intros (Hx,Hx') (Hy,Hy').
+  destruct p as [|p|p].
+  - simpl in *; replace x with 0; replace y with 0; auto with zarith.
+  - rewrite <- Z.shiftl_1_l. change (_ - 1) with (Z.ones (Z.pos p)).
+    rewrite <- Z.ldiff_ones_l_low; trivial.
+    rewrite !Z.ldiff_land, Z.land_assoc. f_equal.
+    rewrite Z.land_ones; try easy.
+    symmetry. apply Z.mod_small; now split.
+    Z.le_elim Hy.
+    + now apply Z.log2_lt_pow2.
+    + now subst.
+  - simpl in *; omega.
+ Qed.
+
+ Theorem spec_ldiff x y : [ldiff x y] = Z.ldiff [x] [y].
+ Proof.
+  rewrite ldiff_fold. apply spec_same_level; clear x y.
+  intros n x y. simpl. rewrite spec_reduce.
+  rewrite ZnZ.spec_land, ZnZ.spec_lxor, ZnZ.spec_m1.
+  symmetry. apply ldiff_alt; apply ZnZ.spec_to_Z.
  Qed.
 
 End Make.
diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml
index 9e4e88c5..6de77e0a 100644
--- a/theories/Numbers/Natural/BigN/NMake_gen.ml
+++ b/theories/Numbers/Natural/BigN/NMake_gen.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        *)
@@ -138,8 +138,6 @@ pr
   pr "";
   pr " Definition t := t'.";
   pr "";
-  pr " Bind Scope abstract_scope with t t'.";
-  pr "";
 
   pr " (** * A generic toolbox for building and deconstructing [t] *)";
   pr "";
@@ -234,7 +232,7 @@ pr
   | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1)
   end.
 
- Let eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m).
+ Definition eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m).
 
  Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x,
    nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x).
@@ -326,8 +324,13 @@ pr "
 
  Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z.
  Proof.
-  do_size (destruct n; [exact ZnZ.spec_0|]).
-  destruct n; auto. simpl. rewrite make_op_S. exact ZnZ.spec_0.
+   do_size (destruct n;
+            [match goal with
+             |- @eq Z (_ (zeron ?n)) _ => 
+               apply (ZnZ.spec_0 (Specs:=dom_spec n))
+             end|]).
+  destruct n; auto. simpl. rewrite make_op_S. fold word. 
+  apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))).
  Qed.
 
  (** * Digits *)
@@ -533,7 +536,7 @@ pr "
 for i = 0 to size-1 do
 let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in
 pr
-" Let mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in
+" Definition mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in
   match m return word w%i (S m) -> t with
     | %s as p => mk_t_w %i (S p)
     | p => mk_t (%i+p)
@@ -542,7 +545,7 @@ pr
 done;
 
 pr
-" Let mk_t_w' n : forall m, word (dom_t n) (S m) -> t :=
+" Definition mk_t_w' n : forall m, word (dom_t n) (S m) -> t :=
   match n return (forall m, word (dom_t n) (S m) -> t) with";
 for i = 0 to size-1 do pr "    | %i => mk_t_%iw" i i done;
 pr
@@ -958,6 +961,11 @@ pr "  end.";
 pr "";
 
 pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ",");
+pr "";
+for i = 0 to size do
+pr " Declare Equivalent Keys reduce reduce_%i." i;
+done;
+pr " Declare Equivalent Keys reduce_n reduce_%i." (size + 1);
 
 pr "
  Ltac solve_red :=
diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v
index e545508d..8fe9ea92 100644
--- a/theories/Numbers/Natural/BigN/Nbasic.v
+++ b/theories/Numbers/Natural/BigN/Nbasic.v
@@ -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        *)
@@ -320,6 +320,7 @@ Section CompareRec.
  Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n :=
    (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos).
 
+ Declare Equivalent Keys compare0_mn compare0_m.
 
  Lemma spec_compare0_mn: forall n x,
    compare0_mn n x = (0 ?= double_to_Z n x).
@@ -371,7 +372,7 @@ Section CompareRec.
  intros n (H0, H); split; auto.
  apply Z.lt_le_trans with (1:= H).
  unfold double_wB, DoubleBase.double_wB; simpl.
- rewrite Pshiftl_nat_S, base_xO.
+ rewrite base_xO.
  set (u := base (Pos.shiftl_nat wm_base n)).
  assert (0 < u).
   unfold u, base; auto with zarith.
diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v
index f95167ad..d54bedd1 100644
--- a/theories/Numbers/Natural/Binary/NBinary.v
+++ b/theories/Numbers/Natural/Binary/NBinary.v
@@ -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/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index f438df40..96eb7b35 100644
--- a/theories/Numbers/Natural/Peano/NPeano.v
+++ b/theories/Numbers/Natural/Peano/NPeano.v
@@ -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,806 +8,8 @@
 (*                      Evgeny Makarov, INRIA, 2007                     *)
 (************************************************************************)
 
-Require Import
- Bool Peano Peano_dec Compare_dec Plus Mult Minus Le Lt EqNat Div2 Wf_nat
- NAxioms NProperties.
+Require Import PeanoNat NAxioms.
 
-(** Functions not already defined *)
+(** * [PeanoNat.Nat] already implements [NAxiomSig] *)
 
-Fixpoint leb n m :=
-  match n, m with
-    | O, _ => true
-    | _, O => false
-    | S n', S m' => leb n' m'
-  end.
-
-Definition ltb n m := leb (S n) m.
-
-Infix "<=?" := leb (at level 70) : nat_scope.
-Infix "<?" := ltb (at level 70) : nat_scope.
-
-Lemma leb_le n m : (n <=? m) = true <-> n <= m.
-Proof.
- revert m.
- induction n. split; auto with arith.
- destruct m; simpl. now split.
- rewrite IHn. split; auto with arith.
-Qed.
-
-Lemma ltb_lt n m : (n <? m) = true <-> n < m.
-Proof.
- unfold ltb, lt. apply leb_le.
-Qed.
-
-Fixpoint pow n m :=
-  match m with
-    | O => 1
-    | S m => n * (pow n m)
-  end.
-
-Infix "^" := pow : nat_scope.
-
-Lemma pow_0_r : forall a, a^0 = 1.
-Proof. reflexivity. Qed.
-
-Lemma pow_succ_r : forall a b, 0<=b -> a^(S b) = a * a^b.
-Proof. reflexivity. Qed.
-
-Definition square n := n * n.
-
-Lemma square_spec n : square n = n * n.
-Proof. reflexivity. Qed.
-
-Definition Even n := exists m, n = 2*m.
-Definition Odd n := exists m, n = 2*m+1.
-
-Fixpoint even n :=
-  match n with
-    | O => true
-    | 1 => false
-    | S (S n') => even n'
-  end.
-
-Definition odd n := negb (even n).
-
-Lemma even_spec : forall n, even n = true <-> Even n.
-Proof.
- fix 1.
-  destruct n as [|[|n]]; simpl; try rewrite even_spec; split.
-  now exists 0.
-  trivial.
-  discriminate.
-  intros (m,H). destruct m. discriminate.
-   simpl in H. rewrite <- plus_n_Sm in H. discriminate.
-  intros (m,H). exists (S m). rewrite H. simpl. now rewrite plus_n_Sm.
-  intros (m,H). destruct m. discriminate. exists m.
-   simpl in H. rewrite <- plus_n_Sm in H. inversion H. reflexivity.
-Qed.
-
-Lemma odd_spec : forall n, odd n = true <-> Odd n.
-Proof.
- unfold odd.
- fix 1.
-  destruct n as [|[|n]]; simpl; try rewrite odd_spec; split.
-  discriminate.
-  intros (m,H). rewrite <- plus_n_Sm in H; discriminate.
-  now exists 0.
-  trivial.
-  intros (m,H). exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m).
-  intros (m,H). destruct m. discriminate. exists m.
-   simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl.
-   now rewrite <- !plus_n_Sm, <- !plus_n_O.
-Qed.
-
-Lemma Even_equiv : forall n, Even n <-> Even.even n.
-Proof.
- split. intros (p,->). apply Even.even_mult_l. do 3 constructor.
- intros H. destruct (even_2n n H) as (p,->).
- exists p. unfold double. simpl. now rewrite <- plus_n_O.
-Qed.
-
-Lemma Odd_equiv : forall n, Odd n <-> Even.odd n.
-Proof.
- split. intros (p,->). rewrite <- plus_n_Sm, <- plus_n_O.
- apply Even.odd_S. apply Even.even_mult_l. do 3 constructor.
- intros H. destruct (odd_S2n n H) as (p,->).
- exists p. unfold double. simpl. now rewrite <- plus_n_Sm, <- !plus_n_O.
-Qed.
-
-(* A linear, tail-recursive, division for nat.
-
-   In [divmod], [y] is the predecessor of the actual divisor,
-   and [u] is [y] minus the real remainder
-*)
-
-Fixpoint divmod x y q u :=
-  match x with
-    | 0 => (q,u)
-    | S x' => match u with
-                | 0 => divmod x' y (S q) y
-                | S u' => divmod x' y q u'
-              end
-  end.
-
-Definition div x y :=
-  match y with
-    | 0 => y
-    | S y' => fst (divmod x y' 0 y')
-  end.
-
-Definition modulo x y :=
-  match y with
-    | 0 => y
-    | S y' => y' - snd (divmod x y' 0 y')
-  end.
-
-Infix "/" := div : nat_scope.
-Infix "mod" := modulo (at level 40, no associativity) : nat_scope.
-
-Lemma divmod_spec : forall x y q u, u <= y ->
- let (q',u') := divmod x y q u in
- x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y.
-Proof.
- induction x. simpl. intuition.
- intros y q u H. destruct u; simpl divmod.
- generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u').
- intros (EQ,LE); split; trivial.
- rewrite <- EQ, <- minus_n_O, minus_diag, <- plus_n_O.
- now rewrite !plus_Sn_m, plus_n_Sm, <- plus_assoc, mult_n_Sm.
- generalize (IHx y q u (le_Sn_le _ _ H)). destruct divmod as (q',u').
- intros (EQ,LE); split; trivial.
- rewrite <- EQ.
- rewrite !plus_Sn_m, plus_n_Sm. f_equal. now apply minus_Sn_m.
-Qed.
-
-Lemma div_mod : forall x y, y<>0 -> x = y*(x/y) + x mod y.
-Proof.
- intros x y Hy.
- destruct y; [ now elim Hy | clear Hy ].
- unfold div, modulo.
- generalize (divmod_spec x y 0 y (le_n y)).
- destruct divmod as (q,u).
- intros (U,V).
- simpl in *.
- now rewrite <- mult_n_O, minus_diag, <- !plus_n_O in U.
-Qed.
-
-Lemma mod_bound_pos : forall x y, 0<=x -> 0<y -> 0 <= x mod y < y.
-Proof.
- intros x y Hx Hy. split. auto with arith.
- destruct y; [ now elim Hy | clear Hy ].
- unfold modulo.
- apply le_n_S, le_minus.
-Qed.
-
-(** Square root *)
-
-(** The following square root function is linear (and tail-recursive).
-  With Peano representation, we can't do better. For faster algorithm,
-  see Psqrt/Zsqrt/Nsqrt...
-
-  We search the square root of n = k + p^2 + (q - r)
-  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
-  looking for the square root of n = k. Then we progressively
-  decrease k and r. When k = S k' and r=0, it means we can use (S p)
-  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
-  When k reaches 0, we have found the biggest p^2 square contained
-  in n, hence the square root of n is p.
-*)
-
-Fixpoint sqrt_iter k p q r :=
-  match k with
-    | O => p
-    | S k' => match r with
-                | O => sqrt_iter k' (S p) (S (S q)) (S (S q))
-                | S r' => sqrt_iter k' p q r'
-              end
-  end.
-
-Definition sqrt n := sqrt_iter n 0 0 0.
-
-Lemma sqrt_iter_spec : forall k p q r,
- q = p+p -> r<=q ->
- let s := sqrt_iter k p q r in
- s*s <= k + p*p + (q - r) < (S s)*(S s).
-Proof.
- induction k.
- (* k = 0 *)
- simpl; intros p q r Hq Hr.
- split.
- apply le_plus_l.
- apply le_lt_n_Sm.
- rewrite <- mult_n_Sm.
- rewrite plus_assoc, (plus_comm p), <- plus_assoc.
- apply plus_le_compat; trivial.
- rewrite <- Hq. apply le_minus.
- (* k = S k' *)
- destruct r.
- (* r = 0 *)
- intros Hq _.
- replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))).
- apply IHk.
- simpl. rewrite <- plus_n_Sm. congruence.
- auto with arith.
- rewrite minus_diag, <- minus_n_O, <- plus_n_O. simpl.
- rewrite <- plus_n_Sm; f_equal. rewrite <- plus_assoc; f_equal.
- rewrite <- mult_n_Sm, (plus_comm p), <- plus_assoc. congruence.
- (* r = S r' *)
- intros Hq Hr.
- replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)).
- apply IHk; auto with arith.
- simpl. rewrite plus_n_Sm. f_equal. rewrite minus_Sn_m; auto.
-Qed.
-
-Lemma sqrt_spec : forall n,
- (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n).
-Proof.
- intros.
- set (s:=sqrt n).
- replace n with (n + 0*0 + (0-0)).
- apply sqrt_iter_spec; auto.
- simpl. now rewrite <- 2 plus_n_O.
-Qed.
-
-(** A linear tail-recursive base-2 logarithm
-
-  In [log2_iter], we maintain the logarithm [p] of the counter [q],
-  while [r] is the distance between [q] and the next power of 2,
-  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
-  recursive call, [q] goes up while [r] goes down. When [r]
-  is 0, we know that [q] has almost reached a power of 2,
-  and we increase [p] at the next call, while resetting [r]
-  to [q].
-
-  Graphically (numbers are [q], stars are [r]) :
-
-<<
-                    10
-                  9
-                8
-              7   *
-            6       *
-          5           ...
-        4
-      3   *
-    2       *
-  1   *       *
-0   *   *       *
->>
-
-  We stop when [k], the global downward counter reaches 0.
-  At that moment, [q] is the number we're considering (since
-  [k+q] is invariant), and [p] its logarithm.
-*)
-
-Fixpoint log2_iter k p q r :=
-  match k with
-    | O => p
-    | S k' => match r with
-                | O => log2_iter k' (S p) (S q) q
-                | S r' => log2_iter k' p (S q) r'
-              end
-  end.
-
-Definition log2 n := log2_iter (pred n) 0 1 0.
-
-Lemma log2_iter_spec : forall k p q r,
- 2^(S p) = q + S r -> r < 2^p ->
- let s := log2_iter k p q r in
- 2^s <= k + q < 2^(S s).
-Proof.
- induction k.
- (* k = 0 *)
- intros p q r EQ LT. simpl log2_iter. cbv zeta.
- split.
- rewrite plus_O_n.
- apply plus_le_reg_l with (2^p).
- simpl pow in EQ. rewrite <- plus_n_O in EQ. rewrite EQ.
- rewrite plus_comm. apply plus_le_compat_r. now apply lt_le_S.
- rewrite EQ, plus_comm. apply plus_lt_compat_l. apply lt_0_Sn.
- (* k = S k' *)
- intros p q r EQ LT. destruct r.
- (* r = 0 *)
- rewrite <- plus_n_Sm, <- plus_n_O in EQ.
- rewrite plus_Sn_m, plus_n_Sm. apply IHk.
- rewrite <- EQ. remember (S p) as p'; simpl. now rewrite <- plus_n_O.
- unfold lt. now rewrite EQ.
- (* r = S r' *)
- rewrite plus_Sn_m, plus_n_Sm. apply IHk.
- now rewrite plus_Sn_m, plus_n_Sm.
- unfold lt.
- now apply lt_le_weak.
-Qed.
-
-Lemma log2_spec : forall n, 0<n ->
- 2^(log2 n) <= n < 2^(S (log2 n)).
-Proof.
- intros.
- set (s:=log2 n).
- replace n with (pred n + 1).
- apply log2_iter_spec; auto.
- rewrite <- plus_n_Sm, <- plus_n_O.
- symmetry. now apply S_pred with 0.
-Qed.
-
-Lemma log2_nonpos : forall n, n<=0 -> log2 n = 0.
-Proof.
- inversion 1; now subst.
-Qed.
-
-(** * Gcd *)
-
-(** We use Euclid algorithm, which is normally not structural,
-    but Coq is now clever enough to accept this (behind modulo
-    there is a subtraction, which now preserves being a subterm)
-*)
-
-Fixpoint gcd a b :=
-  match a with
-   | O => b
-   | S a' => gcd (b mod (S a')) (S a')
-  end.
-
-Definition divide x y := exists z, y=z*x.
-Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.
-
-Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b).
-Proof.
- fix 1.
- intros [|a] b; simpl.
- split.
-  now exists 0.
-  exists 1. simpl. now rewrite <- plus_n_O.
- fold (b mod (S a)).
- destruct (gcd_divide (b mod (S a)) (S a)) as (H,H').
- set (a':=S a) in *.
- split; auto.
- rewrite (div_mod b a') at 2 by discriminate.
- destruct H as (u,Hu), H' as (v,Hv).
- rewrite mult_comm.
- exists ((b/a')*v + u).
- rewrite mult_plus_distr_r.
- now rewrite <- mult_assoc, <- Hv, <- Hu.
-Qed.
-
-Lemma gcd_divide_l : forall a b, (gcd a b | a).
-Proof.
- intros. apply gcd_divide.
-Qed.
-
-Lemma gcd_divide_r : forall a b, (gcd a b | b).
-Proof.
- intros. apply gcd_divide.
-Qed.
-
-Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b).
-Proof.
- fix 1.
- intros [|a] b; simpl; auto.
- fold (b mod (S a)).
- intros c H H'. apply gcd_greatest; auto.
- set (a':=S a) in *.
- rewrite (div_mod b a') in H' by discriminate.
- destruct H as (u,Hu), H' as (v,Hv).
- exists (v - (b/a')*u).
- rewrite mult_comm in Hv.
- now rewrite mult_minus_distr_r, <- Hv, <-mult_assoc, <-Hu, minus_plus.
-Qed.
-
-(** * Bitwise operations *)
-
-(** We provide here some bitwise operations for unary numbers.
-  Some might be really naive, they are just there for fullfiling
-  the same interface as other for natural representations. As
-  soon as binary representations such as NArith are available,
-  it is clearly better to convert to/from them and use their ops.
-*)
-
-Fixpoint testbit a n :=
- match n with
-   | O => odd a
-   | S n => testbit (div2 a) n
- end.
-
-Definition shiftl a n := iter_nat n _ double a.
-Definition shiftr a n := iter_nat n _ div2 a.
-
-Fixpoint bitwise (op:bool->bool->bool) n a b :=
- match n with
-  | O => O
-  | S n' =>
-    (if op (odd a) (odd b) then 1 else 0) +
-    2*(bitwise op n' (div2 a) (div2 b))
- end.
-
-Definition land a b := bitwise andb a a b.
-Definition lor a b := bitwise orb (max a b) a b.
-Definition ldiff a b := bitwise (fun b b' => b && negb b') a a b.
-Definition lxor a b := bitwise xorb (max a b) a b.
-
-Lemma double_twice : forall n, double n = 2*n.
-Proof.
- simpl; intros. now rewrite <- plus_n_O.
-Qed.
-
-Lemma testbit_0_l : forall n, testbit 0 n = false.
-Proof.
- now induction n.
-Qed.
-
-Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
-Proof.
- unfold testbit. rewrite odd_spec. now exists a.
-Qed.
-
-Lemma testbit_even_0 a : testbit (2*a) 0 = false.
-Proof.
- unfold testbit, odd. rewrite (proj2 (even_spec _)); trivial.
- now exists a.
-Qed.
-
-Lemma testbit_odd_succ a n : testbit (2*a+1) (S n) = testbit a n.
-Proof.
- unfold testbit; fold testbit.
- rewrite <- plus_n_Sm, <- plus_n_O. f_equal.
- apply div2_double_plus_one.
-Qed.
-
-Lemma testbit_even_succ a n : testbit (2*a) (S n) = testbit a n.
-Proof.
- unfold testbit; fold testbit. f_equal. apply div2_double.
-Qed.
-
-Lemma shiftr_spec : forall a n m,
- testbit (shiftr a n) m = testbit a (m+n).
-Proof.
- induction n; intros m. trivial.
- now rewrite <- plus_n_O.
- now rewrite <- plus_n_Sm, <- plus_Sn_m, <- IHn.
-Qed.
-
-Lemma shiftl_spec_high : forall a n m, n<=m ->
- testbit (shiftl a n) m = testbit a (m-n).
-Proof.
- induction n; intros m H. trivial.
- now rewrite <- minus_n_O.
- destruct m. inversion H.
- simpl. apply le_S_n in H.
- change (shiftl a (S n)) with (double (shiftl a n)).
- rewrite double_twice, div2_double. now apply IHn.
-Qed.
-
-Lemma shiftl_spec_low : forall a n m, m<n ->
- testbit (shiftl a n) m = false.
-Proof.
- induction n; intros m H. inversion H.
- change (shiftl a (S n)) with (double (shiftl a n)).
- destruct m; simpl.
- unfold odd. apply negb_false_iff.
- apply even_spec. exists (shiftl a n). apply double_twice.
- rewrite double_twice, div2_double. apply IHn.
- now apply lt_S_n.
-Qed.
-
-Lemma div2_bitwise : forall op n a b,
- div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b).
-Proof.
- intros. unfold bitwise; fold bitwise.
- destruct (op (odd a) (odd b)).
- now rewrite div2_double_plus_one.
- now rewrite plus_O_n, div2_double.
-Qed.
-
-Lemma odd_bitwise : forall op n a b,
- odd (bitwise op (S n) a b) = op (odd a) (odd b).
-Proof.
- intros. unfold bitwise; fold bitwise.
- destruct (op (odd a) (odd b)).
- apply odd_spec. rewrite plus_comm. eexists; eauto.
- unfold odd. apply negb_false_iff. apply even_spec.
- rewrite plus_O_n; eexists; eauto.
-Qed.
-
-Lemma div2_decr : forall a n, a <= S n -> div2 a <= n.
-Proof.
- destruct a; intros. apply le_0_n.
- apply le_trans with a.
- apply lt_n_Sm_le, lt_div2, lt_0_Sn. now apply le_S_n.
-Qed.
-
-Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) ->
- forall n m a b, a<=n ->
- testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
-Proof.
- intros op Hop.
- induction n; intros m a b Ha.
- simpl. inversion Ha; subst. now rewrite testbit_0_l.
- destruct m.
- apply odd_bitwise.
- unfold testbit; fold testbit. rewrite div2_bitwise.
- apply IHn; now apply div2_decr.
-Qed.
-
-Lemma testbit_bitwise_2 : forall op, op false false = false ->
- forall n m a b, a<=n -> b<=n ->
- testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
-Proof.
- intros op Hop.
- induction n; intros m a b Ha Hb.
- simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l.
- destruct m.
- apply odd_bitwise.
- unfold testbit; fold testbit. rewrite div2_bitwise.
- apply IHn; now apply div2_decr.
-Qed.
-
-Lemma land_spec : forall a b n,
- testbit (land a b) n = testbit a n && testbit b n.
-Proof.
- intros. unfold land. apply testbit_bitwise_1; trivial.
-Qed.
-
-Lemma ldiff_spec : forall a b n,
- testbit (ldiff a b) n = testbit a n && negb (testbit b n).
-Proof.
- intros. unfold ldiff. apply testbit_bitwise_1; trivial.
-Qed.
-
-Lemma lor_spec : forall a b n,
- testbit (lor a b) n = testbit a n || testbit b n.
-Proof.
- intros. unfold lor. apply testbit_bitwise_2. trivial.
- destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
- destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
-Qed.
-
-Lemma lxor_spec : forall a b n,
- testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
-Proof.
- intros. unfold lxor. apply testbit_bitwise_2. trivial.
- destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
- destruct (le_ge_dec a b). now rewrite max_r. now rewrite max_l.
-Qed.
-
-(** * Implementation of [NAxiomsSig] by [nat] *)
-
-Module Nat
- <: NAxiomsSig <: UsualDecidableTypeFull <: OrderedTypeFull <: TotalOrder.
-
-(** Bi-directional induction. *)
-
-Theorem bi_induction :
-  forall A : nat -> Prop, Proper (eq==>iff) A ->
-    A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n.
-Proof.
-intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS.
-Qed.
-
-(** Basic operations. *)
-
-Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence.
-Local Obligation Tactic := simpl_relation.
-Program Instance succ_wd : Proper (eq==>eq) S.
-Program Instance pred_wd : Proper (eq==>eq) pred.
-Program Instance add_wd : Proper (eq==>eq==>eq) plus.
-Program Instance sub_wd : Proper (eq==>eq==>eq) minus.
-Program Instance mul_wd : Proper (eq==>eq==>eq) mult.
-
-Theorem pred_succ : forall n : nat, pred (S n) = n.
-Proof.
-reflexivity.
-Qed.
-
-Theorem one_succ : 1 = S 0.
-Proof.
-reflexivity.
-Qed.
-
-Theorem two_succ : 2 = S 1.
-Proof.
-reflexivity.
-Qed.
-
-Theorem add_0_l : forall n : nat, 0 + n = n.
-Proof.
-reflexivity.
-Qed.
-
-Theorem add_succ_l : forall n m : nat, (S n) + m = S (n + m).
-Proof.
-reflexivity.
-Qed.
-
-Theorem sub_0_r : forall n : nat, n - 0 = n.
-Proof.
-intro n; now destruct n.
-Qed.
-
-Theorem sub_succ_r : forall n m : nat, n - (S m) = pred (n - m).
-Proof.
-induction n; destruct m; simpl; auto. apply sub_0_r.
-Qed.
-
-Theorem mul_0_l : forall n : nat, 0 * n = 0.
-Proof.
-reflexivity.
-Qed.
-
-Theorem mul_succ_l : forall n m : nat, S n * m = n * m + m.
-Proof.
-assert (add_S_r : forall n m, n+S m = S(n+m)) by (induction n; auto).
-assert (add_comm : forall n m, n+m = m+n).
- induction n; simpl; auto. intros; rewrite add_S_r; auto.
-intros n m; now rewrite add_comm.
-Qed.
-
-(** Order on natural numbers *)
-
-Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
-
-Theorem lt_succ_r : forall n m : nat, n < S m <-> n <= m.
-Proof.
-unfold lt; split. apply le_S_n. induction 1; auto.
-Qed.
-
-
-Theorem lt_eq_cases : forall n m : nat, n <= m <-> n < m \/ n = m.
-Proof.
-split.
-inversion 1; auto. rewrite lt_succ_r; auto.
-destruct 1; [|subst; auto]. rewrite <- lt_succ_r; auto.
-Qed.
-
-Theorem lt_irrefl : forall n : nat, ~ (n < n).
-Proof.
-induction n. intro H; inversion H. rewrite lt_succ_r; auto.
-Qed.
-
-(** Facts specific to natural numbers, not integers. *)
-
-Theorem pred_0 : pred 0 = 0.
-Proof.
-reflexivity.
-Qed.
-
-(** Recursion fonction *)
-
-Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A :=
-  nat_rect (fun _ => A).
-
-Instance recursion_wd {A} (Aeq : relation A) :
- Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
-Proof.
-intros a a' Ha f f' Hf n n' Hn. subst n'.
-induction n; simpl; auto. apply Hf; auto.
-Qed.
-
-Theorem recursion_0 :
-  forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a.
-Proof.
-reflexivity.
-Qed.
-
-Theorem recursion_succ :
-  forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A),
-    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
-      forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
-Proof.
-unfold Proper, respectful in *; induction n; simpl; auto.
-Qed.
-
-(** The instantiation of operations.
-    Placing them at the very end avoids having indirections in above lemmas. *)
-
-Definition t := nat.
-Definition eq := @eq nat.
-Definition eqb := beq_nat.
-Definition compare := nat_compare.
-Definition zero := 0.
-Definition one := 1.
-Definition two := 2.
-Definition succ := S.
-Definition pred := pred.
-Definition add := plus.
-Definition sub := minus.
-Definition mul := mult.
-Definition lt := lt.
-Definition le := le.
-Definition ltb := ltb.
-Definition leb := leb.
-
-Definition min := min.
-Definition max := max.
-Definition max_l := max_l.
-Definition max_r := max_r.
-Definition min_l := min_l.
-Definition min_r := min_r.
-
-Definition eqb_eq := beq_nat_true_iff.
-Definition compare_spec := nat_compare_spec.
-Definition eq_dec := eq_nat_dec.
-Definition leb_le := leb_le.
-Definition ltb_lt := ltb_lt.
-
-Definition Even := Even.
-Definition Odd := Odd.
-Definition even := even.
-Definition odd := odd.
-Definition even_spec := even_spec.
-Definition odd_spec := odd_spec.
-
-Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
-Definition pow_0_r := pow_0_r.
-Definition pow_succ_r := pow_succ_r.
-Lemma pow_neg_r : forall a b, b<0 -> a^b = 0. inversion 1. Qed.
-Definition pow := pow.
-
-Definition square := square.
-Definition square_spec := square_spec.
-
-Definition log2_spec := log2_spec.
-Definition log2_nonpos := log2_nonpos.
-Definition log2 := log2.
-
-Definition sqrt_spec a (Ha:0<=a) := sqrt_spec a.
-Lemma sqrt_neg : forall a, a<0 -> sqrt a = 0. inversion 1. Qed.
-Definition sqrt := sqrt.
-
-Definition div := div.
-Definition modulo := modulo.
-Program Instance div_wd : Proper (eq==>eq==>eq) div.
-Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
-Definition div_mod := div_mod.
-Definition mod_bound_pos := mod_bound_pos.
-
-Definition divide := divide.
-Definition gcd := gcd.
-Definition gcd_divide_l := gcd_divide_l.
-Definition gcd_divide_r := gcd_divide_r.
-Definition gcd_greatest := gcd_greatest.
-Lemma gcd_nonneg : forall a b, 0<=gcd a b.
-Proof. intros. apply le_O_n. Qed.
-
-Definition testbit := testbit.
-Definition shiftl := shiftl.
-Definition shiftr := shiftr.
-Definition lxor := lxor.
-Definition land := land.
-Definition lor := lor.
-Definition ldiff := ldiff.
-Definition div2 := div2.
-
-Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.
-Definition testbit_odd_0 := testbit_odd_0.
-Definition testbit_even_0 := testbit_even_0.
-Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ a n.
-Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ a n.
-Lemma testbit_neg_r a n (H:n<0) : testbit a n = false.
-Proof. inversion H. Qed.
-Definition shiftl_spec_low := shiftl_spec_low.
-Definition shiftl_spec_high a n m (_:0<=m) := shiftl_spec_high a n m.
-Definition shiftr_spec a n m (_:0<=m) := shiftr_spec a n m.
-Definition lxor_spec := lxor_spec.
-Definition land_spec := land_spec.
-Definition lor_spec := lor_spec.
-Definition ldiff_spec := ldiff_spec.
-Definition div2_spec a : div2 a = shiftr a 1 := eq_refl _.
-
-(** Generic Properties *)
-
-Include NProp
- <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
-
-End Nat.
-
-(** [Nat] contains an [order] tactic for natural numbers *)
-
-(** Note that [Nat.order] is domain-agnostic: it will not prove
-    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)
-
-Section TestOrder.
- Let test : forall x y, x<=y -> y<=x -> x=y.
- Proof.
- Nat.order.
- Qed.
-End TestOrder.
+Module Nat <: NAxiomsSig := Nat.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v
index 2b52bffe..1049c156 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSig.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSig.v
@@ -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/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
index e22627e8..11569b3f 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
@@ -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/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v
index eb5f4055..f67e0e96 100644
--- a/theories/Numbers/NumPrelude.v
+++ b/theories/Numbers/NumPrelude.v
@@ -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/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v
index 8a90cacd..b64cfb64 100644
--- a/theories/Numbers/Rational/BigQ/BigQ.v
+++ b/theories/Numbers/Rational/BigQ/BigQ.v
@@ -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        *)
@@ -33,14 +33,13 @@ Module BigN_BigZ <: NType_ZType BigN.BigN BigZ.
  Qed.
 End BigN_BigZ.
 
-(** This allows to build [BigQ] out of [BigN] and [BigQ] via [QMake] *)
+(** This allows building [BigQ] out of [BigN] and [BigQ] via [QMake] *)
 
 Delimit Scope bigQ_scope with bigQ.
 
 Module BigQ <: QType <: OrderedTypeFull <: TotalOrder.
- Include QMake.Make BigN BigZ BigN_BigZ [scope abstract_scope to bigQ_scope].
- Bind Scope bigQ_scope with t t_.
- Include !QProperties <+ HasEqBool2Dec
+ Include QMake.Make BigN BigZ BigN_BigZ
+  <+ !QProperties <+ HasEqBool2Dec
   <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties.
  Ltac order := Private_Tac.order.
 End BigQ.
@@ -89,6 +88,8 @@ exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0.
 exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l.
 Qed.
 
+Declare Equivalent Keys pow_N pow_pos.
+
 Lemma BigQpowerth :
  power_theory 1 BigQ.mul BigQ.eq Z.of_N BigQ.power.
 Proof.
diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v
index e2f53e12..c11e07fa 100644
--- a/theories/Numbers/Rational/BigQ/QMake.v
+++ b/theories/Numbers/Rational/BigQ/QMake.v
@@ -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        *)
@@ -39,8 +39,6 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
 
  Definition t := t_.
 
- Bind Scope abstract_scope with t t_.
-
  (** Specification with respect to [QArith] *)
 
  Local Open Scope Q_scope.
@@ -629,7 +627,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  assert (Hz := spec_irred_zero nx dy).
  assert (Hz':= spec_irred_zero ny dx).
  destruct irred as (n1,d1); destruct irred as (n2,d2).
- simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
+ simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
  rewrite spec_norm_denum.
  qsimpl.
 
@@ -667,7 +665,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  assert (Hgc := strong_spec_irred nx dy).
  assert (Hgc' := strong_spec_irred ny dx).
  destruct irred as (n1,d1); destruct irred as (n2,d2).
- simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
+ simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
 
  unfold norm_denum; qsimpl.
 
@@ -1033,7 +1031,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
 
  Definition of_Qc q := of_Q (this q).
 
- Definition to_Qc q := !! [q].
+ Definition to_Qc q := Q2Qc [q].
 
  Notation "[[ x ]]" := (to_Qc x).
 
@@ -1085,7 +1083,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
   [[add x y]] = [[x]] + [[y]].
  Proof.
  unfold to_Qc.
- transitivity (!! ([x] + [y])).
+ transitivity (Q2Qc ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_add; auto.
@@ -1099,7 +1097,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
   [[add_norm x y]] = [[x]] + [[y]].
  Proof.
  unfold to_Qc.
- transitivity (!! ([x] + [y])).
+ transitivity (Q2Qc ([x] + [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_add_norm; auto.
@@ -1147,7 +1145,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
   [[mul x y]] = [[x]] * [[y]].
  Proof.
  unfold to_Qc.
- transitivity (!! ([x] * [y])).
+ transitivity (Q2Qc ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_mul; auto.
@@ -1161,7 +1159,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
    [[mul_norm x y]] = [[x]] * [[y]].
  Proof.
  unfold to_Qc.
- transitivity (!! ([x] * [y])).
+ transitivity (Q2Qc ([x] * [y])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_mul_norm; auto.
@@ -1185,7 +1183,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
    [[inv x]] =  /[[x]].
  Proof.
  unfold to_Qc.
- transitivity (!! (/[x])).
+ transitivity (Q2Qc (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_inv; auto.
@@ -1199,7 +1197,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
    [[inv_norm x]] =  /[[x]].
  Proof.
  unfold to_Qc.
- transitivity (!! (/[x])).
+ transitivity (Q2Qc (/[x])).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_inv_norm; auto.
@@ -1247,12 +1245,12 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
  Theorem spec_squarec x: [[square x]] = [[x]]^2.
  Proof.
  unfold to_Qc.
- transitivity (!! ([x]^2)).
+ transitivity (Q2Qc ([x]^2)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_square; auto.
  simpl Qcpower.
- replace (!! [x] * 1) with (!![x]); try ring.
+ replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring.
  simpl.
  unfold Qcmult, Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
@@ -1264,7 +1262,7 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType.
    [[power_pos x p]] = [[x]] ^ Pos.to_nat p.
  Proof.
  unfold to_Qc.
- transitivity (!! ([x]^Zpos p)).
+ transitivity (Q2Qc ([x]^Zpos p)).
  unfold Q2Qc.
  apply Qc_decomp; intros _ _; unfold this.
  apply Qred_complete; apply spec_power_pos; auto.
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index 67a5f673..5f831bfc 100644
--- a/theories/Numbers/Rational/SpecViaQ/QSig.v
+++ b/theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -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        *)
@@ -104,7 +104,7 @@ Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl;
  try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *.
 
 (** NB: do not add [spec_0] in the autorewrite database. Otherwise,
-    after instanciation in BigQ, this lemma become convertible to 0=0,
+    after instantiation in BigQ, this lemma become convertible to 0=0,
     and autorewrite loops. Idem for [spec_1] and [spec_m1] *)
 
 (** Morphisms *)
diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v
index 5129a3ca..921e2d67 100644
--- a/theories/PArith/BinPos.v
+++ b/theories/PArith/BinPos.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -23,8 +23,6 @@ Require Export BinPosDef.
     are now defined in [BinNums.v] *)
 
 Local Open Scope positive_scope.
-Local Unset Boolean Equality Schemes.
-Local Unset Case Analysis Schemes.
 
 (** Every definitions and early properties about positive numbers
     are placed in a module [Pos] for qualification purpose. *)
@@ -578,21 +576,21 @@ Qed.
 
 Lemma iter_swap_gen : forall A B (f:A->B)(g:A->A)(h:B->B),
  (forall a, f (g a) = h (f a)) -> forall p a,
- f (iter p g a) = iter p h (f a).
+ f (iter g a p) = iter h (f a) p.
 Proof.
  induction p; simpl; intros; now rewrite ?H, ?IHp.
 Qed.
 
 Theorem iter_swap :
   forall p (A:Type) (f:A -> A) (x:A),
-    iter p f (f x) = f (iter p f x).
+    iter f (f x) p = f (iter f x p).
 Proof.
  intros. symmetry. now apply iter_swap_gen.
 Qed.
 
 Theorem iter_succ :
   forall p (A:Type) (f:A -> A) (x:A),
-    iter (succ p) f x = f (iter p f x).
+    iter f x (succ p) = f (iter f x p).
 Proof.
  induction p as [p IHp|p IHp|]; intros; simpl; trivial.
  now rewrite !IHp, iter_swap.
@@ -600,7 +598,7 @@ Qed.
 
 Theorem iter_add :
   forall p q (A:Type) (f:A -> A) (x:A),
-    iter (p+q) f x = iter p f (iter q f x).
+    iter f x (p+q) = iter f (iter f x q) p.
 Proof.
  induction p using peano_ind; intros.
  now rewrite add_1_l, iter_succ.
@@ -610,7 +608,7 @@ Qed.
 Theorem iter_invariant :
   forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop),
     (forall x:A, Inv x -> Inv (f x)) ->
-    forall x:A, Inv x -> Inv (iter p f x).
+    forall x:A, Inv x -> Inv (iter f x p).
 Proof.
  induction p as [p IHp|p IHp|]; simpl; trivial.
  intros A f Inv H x H0. apply H, IHp, IHp; trivial.
@@ -651,7 +649,7 @@ Theorem sub_mask_carry_spec p q :
   sub_mask_carry p q = pred_mask (sub_mask p q).
 Proof.
   revert q. induction p as [p IHp|p IHp| ]; destruct q; simpl;
-   try reflexivity; try rewrite IHp;
+   try reflexivity; rewrite ?IHp;
    destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto.
 Qed.
 
@@ -768,15 +766,15 @@ Definition switch_Eq c c' :=
  end.
 
 Lemma compare_cont_spec p q c :
-  compare_cont p q c = switch_Eq c (p ?= q).
+  compare_cont c p q = switch_Eq c (p ?= q).
 Proof.
   unfold compare.
   revert q c.
   induction p; destruct q; simpl; trivial.
   intros c.
-  rewrite 2 IHp. now destruct (compare_cont p q Eq).
+  rewrite 2 IHp. now destruct (compare_cont Eq p q).
   intros c.
-  rewrite 2 IHp. now destruct (compare_cont p q Eq).
+  rewrite 2 IHp. now destruct (compare_cont Eq p q).
 Qed.
 
 (** From this general result, we now describe particular cases
@@ -787,31 +785,31 @@ Qed.
 *)
 
 Theorem compare_cont_Eq p q c :
- compare_cont p q c = Eq -> c = Eq.
+ compare_cont c p q = Eq -> c = Eq.
 Proof.
   rewrite compare_cont_spec. now destruct (p ?= q).
 Qed.
 
 Lemma compare_cont_Lt_Gt p q :
-  compare_cont p q Lt = Gt <-> p > q.
+  compare_cont Lt p q = Gt <-> p > q.
 Proof.
   rewrite compare_cont_spec. unfold gt. destruct (p ?= q); now split.
 Qed.
 
 Lemma compare_cont_Lt_Lt p q :
-  compare_cont p q Lt = Lt <-> p <= q.
+  compare_cont Lt p q = Lt <-> p <= q.
 Proof.
   rewrite compare_cont_spec. unfold le. destruct (p ?= q); easy'.
 Qed.
 
 Lemma compare_cont_Gt_Lt p q :
-  compare_cont p q Gt = Lt <-> p < q.
+  compare_cont Gt p q = Lt <-> p < q.
 Proof.
   rewrite compare_cont_spec. unfold lt. destruct (p ?= q); now split.
 Qed.
 
 Lemma compare_cont_Gt_Gt p q :
-  compare_cont p q Gt = Gt <-> p >= q.
+  compare_cont Gt p q = Gt <-> p >= q.
 Proof.
   rewrite compare_cont_spec. unfold ge. destruct (p ?= q); easy'.
 Qed.
@@ -876,13 +874,13 @@ Qed.
 (** Basic facts about [compare_cont] *)
 
 Theorem compare_cont_refl p c :
-  compare_cont p p c = c.
+  compare_cont c p p = c.
 Proof.
   now induction p.
 Qed.
 
 Lemma compare_cont_antisym p q c :
-  CompOpp (compare_cont p q c) = compare_cont q p (CompOpp c).
+  CompOpp (compare_cont c p q) = compare_cont (CompOpp c) q p.
 Proof.
   revert q c.
   induction p as [p IHp|p IHp| ]; intros [q|q| ] c; simpl;
@@ -1840,6 +1838,8 @@ Qed.
 
 End Pos.
 
+Bind Scope positive_scope with Pos.t positive.
+
 (** Exportation of notations *)
 
 Infix "+" := Pos.add : positive_scope.
@@ -1903,7 +1903,7 @@ Notation Pdiv2 := Pos.div2 (compat "8.3").
 Notation Pdiv2_up := Pos.div2_up (compat "8.3").
 Notation Psize := Pos.size_nat (compat "8.3").
 Notation Psize_pos := Pos.size (compat "8.3").
-Notation Pcompare := Pos.compare_cont (compat "8.3").
+Notation Pcompare x y m := (Pos.compare_cont m x y) (compat "8.3").
 Notation Plt := Pos.lt (compat "8.3").
 Notation Pgt := Pos.gt (compat "8.3").
 Notation Ple := Pos.le (compat "8.3").
@@ -2062,11 +2062,11 @@ Lemma Pplus_one_succ_r p : Pos.succ p = p + 1.
 Proof (eq_sym (Pos.add_1_r p)).
 Lemma Pplus_one_succ_l p : Pos.succ p = 1 + p.
 Proof (eq_sym (Pos.add_1_l p)).
-Lemma Pcompare_refl p : Pos.compare_cont p p Eq = Eq.
+Lemma Pcompare_refl p : Pos.compare_cont Eq p p = Eq.
 Proof (Pos.compare_cont_refl p Eq).
-Lemma Pcompare_Eq_eq : forall p q, Pos.compare_cont p q Eq = Eq -> p = q.
+Lemma Pcompare_Eq_eq : forall p q, Pos.compare_cont Eq p q = Eq -> p = q.
 Proof Pos.compare_eq.
-Lemma ZC4 p q : Pos.compare_cont p q Eq = CompOpp (Pos.compare_cont q p Eq).
+Lemma ZC4 p q : Pos.compare_cont Eq p q = CompOpp (Pos.compare_cont Eq q p).
 Proof (Pos.compare_antisym q p).
 Lemma Ppred_minus p : Pos.pred p = p - 1.
 Proof (eq_sym (Pos.sub_1_r p)).
diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v
index 77239660..fefd1d76 100644
--- a/theories/PArith/BinPosDef.v
+++ b/theories/PArith/BinPosDef.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -18,7 +18,7 @@
 
 Require Export BinNums.
 
-(** Postfix notation for positive numbers, allowing to mimic
+(** Postfix notation for positive numbers, which allows mimicking
     the position of bits in a big-endian representation.
     For instance, we can write [1~1~0] instead of [(xO (xI xH))]
     for the number 6 (which is 110 in binary notation).
@@ -30,8 +30,6 @@ Notation "p ~ 0" := (xO p)
  (at level 7, left associativity, format "p '~' '0'") : positive_scope.
 
 Local Open Scope positive_scope.
-Local Unset Boolean Equality Schemes.
-Local Unset Case Analysis Schemes.
 
 Module Pos.
 
@@ -197,16 +195,16 @@ Infix "*" := mul : positive_scope.
 
 (** ** Iteration over a positive number *)
 
-Fixpoint iter (n:positive) {A} (f:A -> A) (x:A) : A :=
-  match n with
+Definition iter {A} (f:A -> A) : A -> positive -> A :=
+  fix iter_fix x n := match n with
     | xH => f x
-    | xO n' => iter n' f (iter n' f x)
-    | xI n' => f (iter n' f (iter n' f x))
+    | xO n' => iter_fix (iter_fix x n') n'
+    | xI n' => f (iter_fix (iter_fix x n') n')
   end.
 
 (** ** Power *)
 
-Definition pow (x y:positive) := iter y (mul x) 1.
+Definition pow (x:positive) := iter (mul x) 1.
 
 Infix "^" := pow : positive_scope.
 
@@ -257,20 +255,20 @@ Fixpoint size p :=
 
 (** ** Comparison on binary positive numbers *)
 
-Fixpoint compare_cont (x y:positive) (r:comparison) {struct y} : comparison :=
+Fixpoint compare_cont (r:comparison) (x y:positive) {struct y} : comparison :=
   match x, y with
-    | p~1, q~1 => compare_cont p q r
-    | p~1, q~0 => compare_cont p q Gt
+    | p~1, q~1 => compare_cont r p q
+    | p~1, q~0 => compare_cont Gt p q
     | p~1, 1 => Gt
-    | p~0, q~1 => compare_cont p q Lt
-    | p~0, q~0 => compare_cont p q r
+    | p~0, q~1 => compare_cont Lt p q
+    | p~0, q~0 => compare_cont r p q
     | p~0, 1 => Gt
     | 1, q~1 => Lt
     | 1, q~0 => Lt
     | 1, 1 => r
   end.
 
-Definition compare x y := compare_cont x y Eq.
+Definition compare := compare_cont Eq.
 
 Infix "?=" := compare (at level 70, no associativity) : positive_scope.
 
@@ -377,7 +375,7 @@ Fixpoint gcdn (n : nat) (a b : positive) : positive :=
 Definition gcd (a b : positive) := gcdn (size_nat a + size_nat b)%nat a b.
 
 (** Generalized Gcd, also computing the division of a and b by the gcd *)
-
+Set Printing Universes.
 Fixpoint ggcdn (n : nat) (a b : positive) : (positive*(positive*positive)) :=
   match n with
     | O => (1,(a,b))
@@ -484,19 +482,19 @@ Fixpoint lxor (p q:positive) : N :=
 
 (** Shifts. NB: right shift of 1 stays at 1. *)
 
-Definition shiftl_nat (p:positive)(n:nat) := nat_iter n xO p.
-Definition shiftr_nat (p:positive)(n:nat) := nat_iter n div2 p.
+Definition shiftl_nat (p:positive) := nat_rect _ p (fun _ => xO).
+Definition shiftr_nat (p:positive) := nat_rect _ p (fun _ => div2).
 
 Definition shiftl (p:positive)(n:N) :=
   match n with
     | N0 => p
-    | Npos n => iter n xO p
+    | Npos n => iter xO p n
   end.
 
 Definition shiftr (p:positive)(n:N) :=
   match n with
     | N0 => p
-    | Npos n => iter n div2 p
+    | Npos n => iter div2 p n
   end.
 
 (** Checking whether a particular bit is set or not *)
@@ -539,7 +537,7 @@ Definition iter_op {A}(op:A->A->A) :=
   end.
 
 Definition to_nat (x:positive) : nat := iter_op plus x (S O).
-
+Arguments to_nat x: simpl never.
 (** ** From Peano natural numbers to binary positive numbers *)
 
 (** A version preserving positive numbers, and sending 0 to 1. *)
@@ -559,4 +557,4 @@ Fixpoint of_succ_nat (n:nat) : positive :=
     | S x => succ (of_succ_nat x)
   end.
 
-End Pos.
\ No newline at end of file
+End Pos.
diff --git a/theories/PArith/PArith.v b/theories/PArith/PArith.v
index eac2b99b..93352c6b 100644
--- a/theories/PArith/PArith.v
+++ b/theories/PArith/PArith.v
@@ -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/theories/PArith/POrderedType.v b/theories/PArith/POrderedType.v
index e672ccff..92483ac8 100644
--- a/theories/PArith/POrderedType.v
+++ b/theories/PArith/POrderedType.v
@@ -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/theories/PArith/Pnat.v b/theories/PArith/Pnat.v
index 449a6700..e529a8c4 100644
--- a/theories/PArith/Pnat.v
+++ b/theories/PArith/Pnat.v
@@ -1,13 +1,13 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import BinPos Le Lt Gt Plus Mult Minus Compare_dec.
+Require Import BinPos PeanoNat.
 
 (** Properties of the injection from binary positive numbers
     to Peano natural numbers *)
@@ -25,7 +25,7 @@ Module Pos2Nat.
 Lemma inj_succ p : to_nat (succ p) = S (to_nat p).
 Proof.
  unfold to_nat. rewrite iter_op_succ. trivial.
- apply plus_assoc.
+ apply Nat.add_assoc.
 Qed.
 
 Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q.
@@ -99,38 +99,38 @@ Qed.
 
 (** [Pos.to_nat] is a morphism for comparison *)
 
-Lemma inj_compare p q : (p ?= q) = nat_compare (to_nat p) (to_nat q).
+Lemma inj_compare p q : (p ?= q)%positive = (to_nat p ?= to_nat q).
 Proof.
  revert q. induction p as [ |p IH] using peano_ind; intros q.
- destruct (succ_pred_or q) as [Hq|Hq]; [now subst|].
- rewrite <- Hq, lt_1_succ, inj_succ, inj_1, nat_compare_S.
- symmetry. apply nat_compare_lt, is_pos.
- destruct (succ_pred_or q) as [Hq|Hq]; [subst|].
- rewrite compare_antisym, lt_1_succ, inj_succ. simpl.
- symmetry. apply nat_compare_gt, is_pos.
- now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH.
+ - destruct (succ_pred_or q) as [Hq|Hq]; [now subst|].
+   rewrite <- Hq, lt_1_succ, inj_succ, inj_1, Nat.compare_succ.
+   symmetry. apply Nat.compare_lt_iff, is_pos.
+ - destruct (succ_pred_or q) as [Hq|Hq]; [subst|].
+   rewrite compare_antisym, lt_1_succ, inj_succ. simpl.
+   symmetry. apply Nat.compare_gt_iff, is_pos.
+   now rewrite <- Hq, 2 inj_succ, compare_succ_succ, IH.
 Qed.
 
 (** [Pos.to_nat] is a morphism for [lt], [le], etc *)
 
 Lemma inj_lt p q : (p < q)%positive <-> to_nat p < to_nat q.
 Proof.
- unfold lt. now rewrite inj_compare, nat_compare_lt.
+ unfold lt. now rewrite inj_compare, Nat.compare_lt_iff.
 Qed.
 
 Lemma inj_le p q : (p <= q)%positive <-> to_nat p <= to_nat q.
 Proof.
- unfold le. now rewrite inj_compare, nat_compare_le.
+ unfold le. now rewrite inj_compare, Nat.compare_le_iff.
 Qed.
 
 Lemma inj_gt p q : (p > q)%positive <-> to_nat p > to_nat q.
 Proof.
- unfold gt. now rewrite inj_compare, nat_compare_gt.
+ unfold gt. now rewrite inj_compare, Nat.compare_gt_iff.
 Qed.
 
 Lemma inj_ge p q : (p >= q)%positive <-> to_nat p >= to_nat q.
 Proof.
- unfold ge. now rewrite inj_compare, nat_compare_ge.
+ unfold ge. now rewrite inj_compare, Nat.compare_ge_iff.
 Qed.
 
 (** [Pos.to_nat] is a morphism for subtraction *)
@@ -138,64 +138,66 @@ Qed.
 Theorem inj_sub p q : (q < p)%positive ->
  to_nat (p - q) = to_nat p - to_nat q.
 Proof.
- intro H; apply plus_reg_l with (to_nat q); rewrite le_plus_minus_r.
- now rewrite <- inj_add, add_comm, sub_add.
- now apply lt_le_weak, inj_lt.
+ intro H. apply Nat.add_cancel_r with (to_nat q).
+ rewrite Nat.sub_add.
+ now rewrite <- inj_add, sub_add.
+ now apply Nat.lt_le_incl, inj_lt.
 Qed.
 
 Theorem inj_sub_max p q :
- to_nat (p - q) = Peano.max 1 (to_nat p - to_nat q).
+ to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q).
 Proof.
  destruct (ltb_spec q p).
- rewrite <- inj_sub by trivial.
- now destruct (is_succ (p - q)) as (m,->).
- rewrite sub_le by trivial.
- replace (to_nat p - to_nat q) with 0; trivial.
- apply le_n_0_eq.
- rewrite <- (minus_diag (to_nat p)).
- now apply minus_le_compat_l, inj_le.
+ - (* q < p *)
+   rewrite <- inj_sub by trivial.
+   now destruct (is_succ (p - q)) as (m,->).
+ - (* p <= q *)
+   rewrite sub_le by trivial.
+   apply inj_le, Nat.sub_0_le in H. now rewrite H.
 Qed.
 
 Theorem inj_pred p : (1 < p)%positive ->
- to_nat (pred p) = Peano.pred (to_nat p).
+ to_nat (pred p) = Nat.pred (to_nat p).
 Proof.
- intros H. now rewrite <- Pos.sub_1_r, inj_sub, pred_of_minus.
+ intros. now rewrite <- Pos.sub_1_r, inj_sub, Nat.sub_1_r.
 Qed.
 
 Theorem inj_pred_max p :
- to_nat (pred p) = Peano.max 1 (Peano.pred (to_nat p)).
+ to_nat (pred p) = Nat.max 1 (Peano.pred (to_nat p)).
 Proof.
- rewrite <- Pos.sub_1_r, pred_of_minus. apply inj_sub_max.
+ rewrite <- Pos.sub_1_r, <- Nat.sub_1_r. apply inj_sub_max.
 Qed.
 
 (** [Pos.to_nat] and other operations *)
 
 Lemma inj_min p q :
- to_nat (min p q) = Peano.min (to_nat p) (to_nat q).
+ to_nat (min p q) = Nat.min (to_nat p) (to_nat q).
 Proof.
  unfold min. rewrite inj_compare.
- case nat_compare_spec; intros H; symmetry.
- apply Peano.min_l. now rewrite H.
- now apply Peano.min_l, lt_le_weak.
- now apply Peano.min_r, lt_le_weak.
+ case Nat.compare_spec; intros H; symmetry.
+ - apply Nat.min_l. now rewrite H.
+ - now apply Nat.min_l, Nat.lt_le_incl.
+ - now apply Nat.min_r, Nat.lt_le_incl.
 Qed.
 
 Lemma inj_max p q :
- to_nat (max p q) = Peano.max (to_nat p) (to_nat q).
+ to_nat (max p q) = Nat.max (to_nat p) (to_nat q).
 Proof.
  unfold max. rewrite inj_compare.
- case nat_compare_spec; intros H; symmetry.
- apply Peano.max_r. now rewrite H.
- now apply Peano.max_r, lt_le_weak.
- now apply Peano.max_l, lt_le_weak.
+ case Nat.compare_spec; intros H; symmetry.
+ - apply Nat.max_r. now rewrite H.
+ - now apply Nat.max_r, Nat.lt_le_incl.
+ - now apply Nat.max_l, Nat.lt_le_incl.
 Qed.
 
 Theorem inj_iter :
   forall p {A} (f:A->A) (x:A),
-    Pos.iter p f x = nat_iter (to_nat p) f x.
+    Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p).
 Proof.
- induction p using peano_ind. trivial.
- intros. rewrite inj_succ, iter_succ. simpl. now f_equal.
+ induction p using peano_ind.
+ - trivial.
+ - intros. rewrite inj_succ, iter_succ. 
+  simpl. f_equal. apply IHp.
 Qed.
 
 End Pos2Nat.
@@ -209,7 +211,7 @@ Module Nat2Pos.
 Theorem id (n:nat) : n<>0 -> Pos.to_nat (Pos.of_nat n) = n.
 Proof.
  induction n as [|n H]; trivial. now destruct 1.
- intros _. simpl. destruct n. trivial.
+ intros _. simpl Pos.of_nat. destruct n. trivial.
  rewrite Pos2Nat.inj_succ. f_equal. now apply H.
 Qed.
 
@@ -257,11 +259,11 @@ Lemma inj_mul (n m : nat) : n<>0 -> m<>0 ->
 Proof.
 intros Hn Hm. apply Pos2Nat.inj.
 rewrite Pos2Nat.inj_mul, !id; trivial.
-intros H. apply mult_is_O in H. destruct H. now elim Hn. now elim Hm.
+intros H. apply Nat.mul_eq_0 in H. destruct H. now elim Hn. now elim Hm.
 Qed.
 
 Lemma inj_compare (n m : nat) : n<>0 -> m<>0 ->
- nat_compare n m = (Pos.of_nat n ?= Pos.of_nat m).
+ (n ?= m) = (Pos.of_nat n ?= Pos.of_nat m)%positive.
 Proof.
 intros Hn Hm. rewrite Pos2Nat.inj_compare, !id; trivial.
 Qed.
@@ -282,8 +284,9 @@ Proof.
  destruct n as [|n]. simpl. symmetry. apply Pos.min_l, Pos.le_1_l.
  destruct m as [|m]. simpl. symmetry. apply Pos.min_r, Pos.le_1_l.
  unfold Pos.min. rewrite <- inj_compare by easy.
- case nat_compare_spec; intros H; f_equal; apply min_l || apply min_r.
- rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak.
+ case Nat.compare_spec; intros H; f_equal;
+  apply Nat.min_l || apply Nat.min_r.
+ rewrite H; auto. now apply Nat.lt_le_incl. now apply Nat.lt_le_incl.
 Qed.
 
 Lemma inj_max (n m : nat) :
@@ -292,8 +295,9 @@ Proof.
  destruct n as [|n]. simpl. symmetry. apply Pos.max_r, Pos.le_1_l.
  destruct m as [|m]. simpl. symmetry. apply Pos.max_l, Pos.le_1_l.
  unfold Pos.max. rewrite <- inj_compare by easy.
- case nat_compare_spec; intros H; f_equal; apply max_l || apply max_r.
- rewrite H; auto. now apply lt_le_weak. now apply lt_le_weak.
+ case Nat.compare_spec; intros H; f_equal;
+  apply Nat.max_l || apply Nat.max_r.
+ rewrite H; auto. now apply Nat.lt_le_incl. now apply Nat.lt_le_incl.
 Qed.
 
 End Nat2Pos.
@@ -365,7 +369,7 @@ apply Pos2Nat.inj. now rewrite Pos2Nat.inj_succ, !id_succ.
 Qed.
 
 Lemma inj_compare n m :
- nat_compare n m = (Pos.of_succ_nat n ?= Pos.of_succ_nat m).
+ (n ?= m) = (Pos.of_succ_nat n ?= Pos.of_succ_nat m)%positive.
 Proof.
 rewrite Pos2Nat.inj_compare, !id_succ; trivial.
 Qed.
@@ -410,24 +414,24 @@ Notation P_of_succ_nat_o_nat_of_P_eq_succ := Pos2SuccNat.id_succ (compat "8.3").
 Notation pred_o_P_of_succ_nat_o_nat_of_P_eq_id := Pos2SuccNat.pred_id (compat "8.3").
 
 Lemma nat_of_P_minus_morphism p q :
- Pos.compare_cont p q Eq = Gt ->
+ Pos.compare_cont Eq p q = Gt ->
   Pos.to_nat (p - q) = Pos.to_nat p - Pos.to_nat q.
 Proof (fun H => Pos2Nat.inj_sub p q (Pos.gt_lt _ _ H)).
 
 Lemma nat_of_P_lt_Lt_compare_morphism p q :
- Pos.compare_cont p q Eq = Lt -> Pos.to_nat p < Pos.to_nat q.
+ Pos.compare_cont Eq p q = Lt -> Pos.to_nat p < Pos.to_nat q.
 Proof (proj1 (Pos2Nat.inj_lt p q)).
 
 Lemma nat_of_P_gt_Gt_compare_morphism p q :
- Pos.compare_cont p q Eq = Gt -> Pos.to_nat p > Pos.to_nat q.
+ Pos.compare_cont Eq p q = Gt -> Pos.to_nat p > Pos.to_nat q.
 Proof (proj1 (Pos2Nat.inj_gt p q)).
 
 Lemma nat_of_P_lt_Lt_compare_complement_morphism p q :
- Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont p q Eq = Lt.
+ Pos.to_nat p < Pos.to_nat q -> Pos.compare_cont Eq p q = Lt.
 Proof (proj2 (Pos2Nat.inj_lt p q)).
 
 Definition nat_of_P_gt_Gt_compare_complement_morphism p q :
- Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont p q Eq = Gt.
+ Pos.to_nat p > Pos.to_nat q -> Pos.compare_cont Eq p q = Gt.
 Proof (proj2 (Pos2Nat.inj_gt p q)).
 
 (** Old intermediate results about [Pmult_nat] *)
@@ -438,11 +442,11 @@ Lemma Pmult_nat_mult : forall p n,
  Pmult_nat p n = Pos.to_nat p * n.
 Proof.
  induction p; intros n; unfold Pos.to_nat; simpl.
- f_equal. rewrite 2 IHp. rewrite <- mult_assoc.
-  f_equal. simpl. now rewrite <- plus_n_O.
- rewrite 2 IHp. rewrite <- mult_assoc.
-  f_equal. simpl. now rewrite <- plus_n_O.
- simpl. now rewrite <- plus_n_O.
+ f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc.
+  f_equal. simpl. now rewrite Nat.add_0_r.
+ rewrite 2 IHp. rewrite <- Nat.mul_assoc.
+  f_equal. simpl. now rewrite Nat.add_0_r.
+ simpl. now rewrite Nat.add_0_r.
 Qed.
 
 Lemma Pmult_nat_succ_morphism :
@@ -454,7 +458,7 @@ Qed.
 Theorem Pmult_nat_l_plus_morphism :
  forall p q n, Pmult_nat (p + q) n = Pmult_nat p n + Pmult_nat q n.
 Proof.
- intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply mult_plus_distr_r.
+ intros. rewrite !Pmult_nat_mult, Pos2Nat.inj_add. apply Nat.mul_add_distr_r.
 Qed.
 
 Theorem Pmult_nat_plus_carry_morphism :
@@ -466,19 +470,19 @@ Qed.
 Lemma Pmult_nat_r_plus_morphism :
  forall p n, Pmult_nat p (n + n) = Pmult_nat p n + Pmult_nat p n.
 Proof.
- intros. rewrite !Pmult_nat_mult. apply mult_plus_distr_l.
+ intros. rewrite !Pmult_nat_mult. apply Nat.mul_add_distr_l.
 Qed.
 
 Lemma ZL6 : forall p, Pmult_nat p 2 = Pos.to_nat p + Pos.to_nat p.
 Proof.
- intros. rewrite Pmult_nat_mult, mult_comm. simpl. now rewrite <- plus_n_O.
+ intros. rewrite Pmult_nat_mult, Nat.mul_comm. simpl. now rewrite Nat.add_0_r.
 Qed.
 
 Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n.
 Proof.
  intros. rewrite Pmult_nat_mult.
- apply le_trans with (1*n). now rewrite mult_1_l.
- apply mult_le_compat_r. apply Pos2Nat.is_pos.
+ apply Nat.le_trans with (1*n). now rewrite Nat.mul_1_l.
+ apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos.
 Qed.
 
 End ObsoletePmultNat.
diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v
index 2c0f62ad..e5be0ca9 100644
--- a/theories/Program/Basics.v
+++ b/theories/Program/Basics.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/Program/Combinators.v b/theories/Program/Combinators.v
index 4d631e78..e246041b 100644
--- a/theories/Program/Combinators.v
+++ b/theories/Program/Combinators.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/Program/Equality.v b/theories/Program/Equality.v
index 04701ff5..a9aa30df 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -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        *)
@@ -263,7 +263,7 @@ Class DependentEliminationPackage (A : Type) :=
 
 Ltac elim_tac tac p :=
   let ty := type of p in
-  let eliminator := eval simpl in (elim (A:=ty)) in
+  let eliminator := eval simpl in (@elim (_ : DependentEliminationPackage ty)) in
     tac p eliminator.
 
 (** Specialization to do case analysis or induction.
diff --git a/theories/Program/Program.v b/theories/Program/Program.v
index 38f11231..5af6f4d7 100644
--- a/theories/Program/Program.v
+++ b/theories/Program/Program.v
@@ -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/theories/Program/Subset.v b/theories/Program/Subset.v
index 269556c2..50b89b5c 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -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        *)
@@ -61,12 +61,12 @@ Ltac pi_subset_proofs := repeat pi_subset_proof.
 Ltac clear_subset_proofs :=
   abstract_subset_proofs ; simpl in * |- ; pi_subset_proofs ; clear_dups.
 
-Ltac pi := repeat progress f_equal ; apply proof_irrelevance.
+Ltac pi := repeat f_equal ; apply proof_irrelevance.
 
 Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m.
 Proof.
-  induction n.
-  induction m.
+  destruct n as (x,p).
+  destruct m as (x',p').
   simpl.
   split ; intros ; subst.
 
@@ -79,14 +79,14 @@ Qed.
 (* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f]
    in tactics. *)
 
-Definition match_eq (A B : Type) (x : A) (fn : forall (y : A | y = x), B) : B :=
+Definition match_eq (A B : Type) (x : A) (fn : {y : A | y = x} -> B) : B :=
   fn (exist _ x eq_refl).
 
 (* This is what we want to be able to do: replace the originaly matched object by a new,
    propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *)
 
-Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B)
-  (y : A | y = x),
+Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B)
+  (y : {y:A | y = x}),
   match_eq A B x fn = fn y.
 Proof.
   intros.
diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v
index 269748b5..67e9a20c 100644
--- a/theories/Program/Syntax.v
+++ b/theories/Program/Syntax.v
@@ -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/theories/Program/Tactics.v b/theories/Program/Tactics.v
index fd55a553..0cf8d733 100644
--- a/theories/Program/Tactics.v
+++ b/theories/Program/Tactics.v
@@ -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/theories/Program/Utils.v b/theories/Program/Utils.v
index de2a76ab..e39128cb 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -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/theories/Program/Wf.v b/theories/Program/Wf.v
index 2a7a5e17..d89919b0 100644
--- a/theories/Program/Wf.v
+++ b/theories/Program/Wf.v
@@ -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        *)
@@ -11,6 +11,7 @@
 Require Import Coq.Init.Wf.
 Require Import Coq.Program.Utils.
 Require Import ProofIrrelevance.
+Require Import FunctionalExtensionality.
 
 Local Open Scope program_scope.
 
@@ -32,14 +33,13 @@ Section Well_founded.
   (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *)
   (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *)
 
-  Hypothesis
-    F_ext :
+  Hypothesis F_ext :
     forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
-      (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g.
+      (forall y:{y : A | R y x}, f y = g y) -> F_sub x f = F_sub x g.
 
   Lemma Fix_F_eq :
     forall (x:A) (r:Acc R x),
-      F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r.
+      F_sub x (fun y:{y:A | R y x} => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r.
   Proof.
     destruct r using Acc_inv_dep; auto.
   Qed.
@@ -50,7 +50,7 @@ Section Well_founded.
     rewrite (proof_irrelevance (Acc R x) r s) ; auto.
   Qed.
 
-  Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)).
+  Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun y:{ y:A | R y x} => Fix_sub (proj1_sig y)).
   Proof.
     intro x; unfold Fix_sub.
     rewrite <- (Fix_F_eq ).
@@ -62,7 +62,8 @@ Section Well_founded.
     forall x : A,
       Fix_sub x =
       let f_sub := F_sub in
-        f_sub x (fun (y : A | R y x) => Fix_sub (`y)).
+        f_sub x (fun y: {y : A | R y x} => Fix_sub (`y)).
+  Proof.
     exact Fix_eq.
   Qed.
 
@@ -153,7 +154,7 @@ Section Fix_rects.
 
   Hypothesis equiv_lowers:
     forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)),
-    (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) ->
+    (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist (*FIXME shouldn't be needed *) (fun y => R y x0) x p')) ->
       f g = f h.
 
   (* From equiv_lowers, it follows that
@@ -221,8 +222,6 @@ Ltac fold_sub f :=
 
 Module WfExtensionality.
 
-  Require Import FunctionalExtensionality.
-
   (** The two following lemmas allow to unfold a well-founded fixpoint definition without
      restriction using the functional extensionality axiom. *)
 
@@ -231,10 +230,10 @@ Module WfExtensionality.
   Program Lemma fix_sub_eq_ext :
     forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R)
       (P : A -> Type)
-      (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x),
+      (F_sub : forall x : A, (forall y:{y : A | R y x}, P (` y)) -> P x),
       forall x : A,
         Fix_sub A R Rwf P F_sub x =
-          F_sub x (fun (y : A | R y x) => Fix_sub A R Rwf P F_sub y).
+          F_sub x (fun y:{y : A | R y x} => Fix_sub A R Rwf P F_sub (` y)).
   Proof.
     intros ; apply Fix_eq ; auto.
     intros.
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
index 1a76d7e1..c32fb950 100644
--- a/theories/QArith/QArith.v
+++ b/theories/QArith/QArith.v
@@ -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/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
index 080d00d4..7f19b4ce 100644
--- a/theories/QArith/QArith_base.v
+++ b/theories/QArith/QArith_base.v
@@ -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        *)
@@ -925,8 +925,8 @@ Qed.
 
 (** * Rational to the n-th power *)
 
-Definition Qpower_positive (q:Q)(p:positive) : Q :=
- pow_pos Qmult q p.
+Definition Qpower_positive : Q -> positive -> Q :=
+ pow_pos Qmult.
 
 Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive.
 Proof.
diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v
index dc820e75..fa0b9209 100644
--- a/theories/QArith/QOrderedType.v
+++ b/theories/QArith/QOrderedType.v
@@ -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/theories/QArith/Qabs.v b/theories/QArith/Qabs.v
index 9b607f1b..f77f409e 100644
--- a/theories/QArith/Qabs.v
+++ b/theories/QArith/Qabs.v
@@ -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/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index a865a6cf..f7f83bf0 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -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        *)
@@ -70,7 +70,6 @@ Qed.
 
 Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q).
 Arguments Q2Qc q%Q.
-Notation " !! " := Q2Qc : Qc_scope.
 
 Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'.
 Proof.
@@ -87,8 +86,8 @@ Proof.
 Qed.
 Hint Resolve Qc_is_canon.
 
-Notation " 0 " := (!!0) : Qc_scope.
-Notation " 1 " := (!!1) : Qc_scope.
+Notation " 0 " := (Q2Qc 0) : Qc_scope.
+Notation " 1 " := (Q2Qc 1) : Qc_scope.
 
 Definition Qcle (x y : Qc) := (x <= y)%Q.
 Definition Qclt (x y : Qc) := (x < y)%Q.
@@ -144,15 +143,15 @@ Defined.
 (** The addition, multiplication and opposite are defined
    in the straightforward way: *)
 
-Definition Qcplus (x y : Qc) := !!(x+y).
+Definition Qcplus (x y : Qc) := Q2Qc (x+y).
 Infix "+" := Qcplus : Qc_scope.
-Definition Qcmult (x y : Qc) := !!(x*y).
+Definition Qcmult (x y : Qc) := Q2Qc (x*y).
 Infix "*" := Qcmult : Qc_scope.
-Definition Qcopp (x : Qc) := !!(-x).
+Definition Qcopp (x : Qc) := Q2Qc (-x).
 Notation "- x" := (Qcopp x) : Qc_scope.
 Definition Qcminus (x y : Qc) := x+-y.
 Infix "-" := Qcminus : Qc_scope.
-Definition Qcinv (x : Qc) := !!(/x).
+Definition Qcinv (x : Qc) := Q2Qc (/x).
 Notation "/ x" := (Qcinv x) : Qc_scope.
 Definition Qcdiv (x y : Qc) := x*/y.
 Infix "/" := Qcdiv : Qc_scope.
@@ -434,14 +433,14 @@ Qed.
 Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 <  z  -> x*z <= y*z -> x <= y.
 Proof.
   unfold Qcmult, Qcle, Qclt; intros; simpl in *.
-  repeat progress rewrite Qred_correct in * |-.
+  rewrite !Qred_correct in * |-.
   eapply Qmult_lt_0_le_reg_r; eauto.
 Qed.
 
 Lemma Qcmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
 Proof.
   unfold Qcmult, Qclt; intros; simpl in *.
-  repeat progress rewrite Qred_correct in *.
+  rewrite !Qred_correct in *.
   eapply Qmult_lt_compat_r; eauto.
 Qed.
 
@@ -460,13 +459,13 @@ Proof.
   induction n; simpl; auto with qarith.
   rewrite IHn; auto with qarith.
 Qed.
-
+Transparent Qred.
 Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0.
 Proof.
   destruct n; simpl.
   destruct 1; auto.
   intros.
-  now apply Qc_is_canon.
+  now apply Qc_is_canon. 
 Qed.
 
 Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n.
@@ -521,6 +520,7 @@ Add Field Qcfield : Qcft.
 (** A field tactic for rational numbers *)
 
 Example test_field : (forall x y : Qc, y<>0 -> (x/y)*y = x)%Qc.
+Proof.
 intros.
 field.
 auto.
diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v
index a1028ad9..083e40ae 100644
--- a/theories/QArith/Qfield.v
+++ b/theories/QArith/Qfield.v
@@ -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/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v
index 9a5a1cb1..0fd05325 100644
--- a/theories/QArith/Qminmax.v
+++ b/theories/QArith/Qminmax.v
@@ -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/theories/QArith/Qpower.v b/theories/QArith/Qpower.v
index 112b3738..8bd643aa 100644
--- a/theories/QArith/Qpower.v
+++ b/theories/QArith/Qpower.v
@@ -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        *)
@@ -41,6 +41,7 @@ try destruct (Qmult_integral _ _ H0); auto.
 Qed.
 
 Lemma Qpower_pos_positive : forall p n, 0 <= p -> 0 <= Qpower_positive p n.
+Proof.
 intros p n Hp.
 induction n; simpl; repeat apply Qmult_le_0_compat;assumption.
 Qed.
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index 029ae8e3..add43b96 100644
--- a/theories/QArith/Qreals.v
+++ b/theories/QArith/Qreals.v
@@ -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        *)
@@ -14,6 +14,7 @@ Require Export QArith_base.
 Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R.
 
 Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R.
+Proof.
 intros; apply not_O_IZR; auto with qarith.
 Qed.
 
@@ -162,19 +163,19 @@ field; auto.
 Qed.
 
 Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
+Proof.
 unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
 Qed.
 
 Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R.
 Proof.
-unfold Qinv, Q2R, Qeq; intros (x1, x2); unfold Qden, Qnum.
-case x1.
+unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden.
 simpl; intros; elim H; trivial.
-intros; field; auto.
+intros; field; auto. 
 intros;
   change (IZR (Zneg x2)) with (- IZR (' x2))%R;
   change (IZR (Zneg p)) with (- IZR (' p))%R;
-  field; (*auto 8 with real.*)
+  simpl; field; (*auto 8 with real.*)
   repeat split; auto; auto with real.
 Qed.
 
@@ -187,25 +188,3 @@ rewrite Q2R_inv; auto.
 Qed.
 
 Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.
-
-Section LegacyQField.
-
-(** In the past, the field tactic was not able to deal with setoid datatypes,
-    so translating from Q to R and applying field on reals was a workaround.
-    See now Qfield for a direct field tactic on Q. *)
-
-Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto.
-
-(** Examples of use: *)
-
-Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z).
-intros; QField.
-Qed.
-
-Let ex2 : forall x y : Q, ~ y==0 -> (x/y)*y == x.
-intros; QField.
-intro; apply H; apply eqR_Qeq.
-rewrite H0; unfold Q2R; simpl; field; auto with real.
-Qed.
-
-End LegacyQField.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index e8ccdee0..1d304964 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -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        *)
@@ -126,11 +126,13 @@ Proof.
 Qed.
 
 Add Morphism Qmult' : Qmult'_comp.
+Proof.
   intros; unfold Qmult'.
   rewrite H, H0; auto with qarith.
 Qed.
 
 Add Morphism Qminus' : Qminus'_comp.
+Proof.
   intros; unfold Qminus'.
   rewrite H, H0; auto with qarith.
 Qed.
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
index 9a76bed7..78c464ae 100644
--- a/theories/QArith/Qring.v
+++ b/theories/QArith/Qring.v
@@ -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/theories/QArith/Qround.v b/theories/QArith/Qround.v
index ed3d38b1..964a4bae 100644
--- a/theories/QArith/Qround.v
+++ b/theories/QArith/Qround.v
@@ -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/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index a8548eb7..e848e4df 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -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        *)
@@ -35,10 +35,8 @@ Proof.
     [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H0 (/ 2) H1); intros.
   exists (sum_f_R0 An x + 2 * An (S x)).
-  unfold is_upper_bound; intros; unfold EUn in H3; elim H3; intros.
-  rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
-  elim H5; intros.
-  elim a; intro.
+  unfold is_upper_bound; intros; unfold EUn in H3; destruct H3 as (x1,->).
+  destruct (lt_eq_lt_dec x1 x) as [[| -> ]|].
   replace (sum_f_R0 An x) with
     (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
   pattern (sum_f_R0 An x1) at 1; rewrite <- Rplus_0_r;
@@ -47,7 +45,7 @@ Proof.
   apply tech1; intros; apply H.
   apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
   symmetry ; apply tech2; assumption.
-  rewrite b; pattern (sum_f_R0 An x) at 1; rewrite <- Rplus_0_r;
+  pattern (sum_f_R0 An x) at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
   replace (sum_f_R0 An x1) with
@@ -68,7 +66,7 @@ Proof.
   pattern 2 at 3; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
     apply Rmult_le_compat_l.
   left; prove_sup0.
-  left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
+  left; apply Rplus_lt_reg_l with ((/ 2) ^ S (x1 - S x)).
   replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
     [ idtac | ring ].
   rewrite <- (Rplus_comm 1); pattern 1 at 1; rewrite <- Rplus_0_r;
@@ -86,8 +84,8 @@ Proof.
   apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
   left; apply Rinv_0_lt_compat; prove_sup0.
   intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
-  intro; replace (S x + S i)%nat with (S (S x + i)).
-  apply H6; unfold ge; apply tech8.
+  intro H4; replace (S x + S i)%nat with (S (S x + i)).
+  apply H4; unfold ge; apply tech8.
   apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
   intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
   apply Rinv_0_lt_compat; apply H.
@@ -101,17 +99,17 @@ Proof.
   unfold Rdiv; reflexivity.
   left; unfold Rdiv; change (0 < An (S n) * / An n);
     apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
-  red; intro; assert (H8 := H n); rewrite H7 in H8;
+  intro H5; assert (H8 := H n); rewrite H5 in H8;
     elim (Rlt_irrefl _ H8).
   replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
   symmetry ; apply tech2; assumption.
   exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity.
-  intro X; elim X; intros.
+  intros (x,H1).
   exists x; apply Un_cv_crit_lub;
     [ unfold Un_growing; intro; rewrite tech5;
       pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
-      | apply p ].
+      | apply H1 ].
 Defined.
 
 Lemma Alembert_C2 :
@@ -127,14 +125,12 @@ Proof.
   intro; cut (forall n:nat, 0 < Wn n).
   intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0).
   intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0).
-  intro; assert (H5 := Alembert_C1 Vn H1 H3).
-  assert (H6 := Alembert_C1 Wn H2 H4).
-  elim H5; intros.
-  elim H6; intros.
+  intro; pose proof (Alembert_C1 Vn H1 H3) as (x,p).
+  pose proof (Alembert_C1 Wn H2 H4) as (x0,p0).
   exists (x - x0); unfold Un_cv; unfold Un_cv in p;
     unfold Un_cv in p0; intros; cut (0 < eps / 2).
-  intro; elim (p (eps / 2) H8); clear p; intros.
-  elim (p0 (eps / 2) H8); clear p0; intros.
+  intro H6; destruct (p (eps / 2) H6) as (x1,H8). clear p.
+  destruct (p0 (eps / 2) H6) as (x2,H9). clear p0.
   set (N := max x1 x2).
   exists N; intros;
     replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
@@ -146,9 +142,9 @@ Proof.
   apply Rabs_triang.
   rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
   apply Rplus_lt_compat.
-  unfold R_dist in H9; apply H9; unfold ge; apply le_trans with N;
+  unfold R_dist in H8; apply H8; unfold ge; apply le_trans with N;
     [ unfold N; apply le_max_l | assumption ].
-  unfold R_dist in H10; apply H10; unfold ge; apply le_trans with N;
+  unfold R_dist in H9; apply H9; unfold ge; apply le_trans with N;
     [ unfold N; apply le_max_r | assumption ].
   right; symmetry ; apply double_var.
   symmetry ; apply tech11; intro; unfold Vn, Wn;
@@ -315,7 +311,7 @@ Proof.
   intro; unfold Wn; unfold Rdiv; rewrite <- (Rmult_0_r (/ 2));
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
-  apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus;
+  apply Rplus_lt_reg_l with (An n); rewrite Rplus_0_r; unfold Rminus;
     rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_l; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
@@ -325,7 +321,7 @@ Proof.
   intro; unfold Vn; unfold Rdiv; rewrite <- (Rmult_0_r (/ 2));
     rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
   apply Rinv_0_lt_compat; prove_sup0.
-  apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus;
+  apply Rplus_lt_reg_l with (- An n); rewrite Rplus_0_r; unfold Rminus;
     rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc;
       rewrite Rplus_opp_r; rewrite Rplus_0_r;
 	apply Rle_lt_trans with (Rabs (An n)).
@@ -344,9 +340,8 @@ Proof.
   intros; set (Bn := fun i:nat => An i * x ^ i).
   cut (forall n:nat, Bn n <> 0).
   intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0).
-  intro; assert (H4 := Alembert_C2 Bn H2 H3).
-  elim H4; intros.
-  exists x0; unfold Bn in p; apply tech12; assumption.
+  intro; destruct (Alembert_C2 Bn H2 H3) as (x0,H4).
+  exists x0; unfold Bn in H4; apply tech12; assumption.
   unfold Un_cv; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
   intro; elim (H1 (eps / Rabs x) H4); intros.
   exists x0; intros; unfold R_dist; unfold Rminus;
@@ -400,15 +395,14 @@ Theorem Alembert_C3 :
     Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
     { l:R | Pser An x l }.
 Proof.
-  intros; case (total_order_T x 0); intro.
-  elim s; intro.
+  intros; destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt].
   cut (x <> 0).
   intro; apply AlembertC3_step1; assumption.
-  red; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H1 in Hlt; elim (Rlt_irrefl _ Hlt).
   apply AlembertC3_step2; assumption.
   cut (x <> 0).
   intro; apply AlembertC3_step1; assumption.
-  red; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt).
 Defined.
 
 Lemma Alembert_C4 :
@@ -432,9 +426,7 @@ Proof.
   unfold is_upper_bound; intros; unfold EUn in H6.
   elim H6; intros.
   rewrite H7.
-  assert (H8 := lt_eq_lt_dec x2 x0).
-  elim H8; intros.
-  elim a; intro.
+  destruct (lt_eq_lt_dec x2 x0) as [[| -> ]|].
   replace (sum_f_R0 An x0) with
     (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
   pattern (sum_f_R0 An x2) at 1; rewrite <- Rplus_0_r.
@@ -443,14 +435,14 @@ Proof.
   apply tech1.
   intros; apply H.
   apply Rmult_lt_0_compat.
-  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+  apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r;
     replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
   apply H.
   symmetry ; apply tech2; assumption.
-  rewrite b; pattern (sum_f_R0 An x0) at 1; rewrite <- Rplus_0_r;
+  pattern (sum_f_R0 An x0) at 1; rewrite <- Rplus_0_r;
     apply Rplus_le_compat_l.
   left; apply Rmult_lt_0_compat.
-  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+  apply Rinv_0_lt_compat; apply Rplus_lt_reg_l with x; rewrite Rplus_0_r;
     replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
   apply H.
   replace (sum_f_R0 An x2) with
@@ -466,7 +458,7 @@ Proof.
   left; apply H.
   rewrite tech3.
   unfold Rdiv; apply Rmult_le_reg_l with (1 - x).
-  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+  apply Rplus_lt_reg_l with x; rewrite Rplus_0_r.
   replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
   do 2 rewrite (Rmult_comm (1 - x)).
   rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
@@ -480,11 +472,11 @@ Proof.
   elim Hyp; intros; assumption.
   elim H3; intros; assumption.
   apply Rminus_eq_contra.
-  red; intro.
-  elim H3; intros.
+  red; intro H10.
+  elim H3; intros H11 H12. 
   rewrite H10 in H12; elim (Rlt_irrefl _ H12).
-  red; intro.
-  elim H3; intros.
+  red; intro H10.
+  elim H3; intros H11 H12.
   rewrite H10 in H12; elim (Rlt_irrefl _ H12).
   replace (An (S x0)) with (An (S x0 + 0)%nat).
   apply (tech6 (fun i:nat => An (S x0 + i)%nat) x).
@@ -493,7 +485,7 @@ Proof.
   elim H3; intros; assumption.
   intro.
   cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n).
-  intro.
+  intro H9.
   replace (S x0 + S i)%nat with (S (S x0 + i)).
   apply H9.
   unfold ge.
@@ -515,18 +507,18 @@ Proof.
     apply Rmult_lt_0_compat.
   apply H.
   apply Rinv_0_lt_compat; apply H.
-  red; intro.
+  red; intro H10.
   assert (H11 := H n).
   rewrite H10 in H11; elim (Rlt_irrefl _ H11).
   replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
   symmetry ; apply tech2; assumption.
   exists (sum_f_R0 An 0); unfold EUn; exists 0%nat; reflexivity.
-  intro X; elim X; intros.
+  intros (x,H1).
   exists x; apply Un_cv_crit_lub;
     [ unfold Un_growing; intro; rewrite tech5;
       pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
 	apply Rplus_le_compat_l; left; apply H
-      | apply p ].
+      | apply H1].
 Qed.
 
 Lemma Alembert_C5 :
@@ -586,14 +578,13 @@ Lemma Alembert_C6 :
   elim X; intros.
   exists x0.
   apply tech12; assumption.
-  case (total_order_T x 0); intro.
-  elim s; intro.
+  destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt].
   eapply Alembert_C5 with (k * Rabs x).
   split.
   unfold Rdiv; apply Rmult_le_pos.
   left; assumption.
   left; apply Rabs_pos_lt.
-  red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H3 in Hlt; elim (Rlt_irrefl _ Hlt).
   apply Rmult_lt_reg_l with (/ k).
   apply Rinv_0_lt_compat; assumption.
   rewrite <- Rmult_assoc.
@@ -604,7 +595,7 @@ Lemma Alembert_C6 :
   intro; apply prod_neq_R0.
   apply H0.
   apply pow_nonzero.
-  red; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H3 in Hlt; elim (Rlt_irrefl _ Hlt).
   unfold Un_cv; unfold Un_cv in H1.
   intros.
   cut (0 < eps / Rabs x).
@@ -621,7 +612,7 @@ Lemma Alembert_C6 :
   rewrite Rabs_Rabsolu.
   apply Rmult_lt_reg_l with (/ Rabs x).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt).
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
@@ -629,7 +620,7 @@ Lemma Alembert_C6 :
   unfold R_dist in H5.
   unfold Rdiv; unfold Rdiv in H5; apply H5; assumption.
   apply Rabs_no_R0.
-  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt).
   unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add.
   simpl.
@@ -641,14 +632,14 @@ Lemma Alembert_C6 :
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
   apply pow_nonzero.
-  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt).
   apply H0.
   apply pow_nonzero.
-  red; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt).
   unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
+  red; intro H7; rewrite H7 in Hlt; elim (Rlt_irrefl _ Hlt).
   exists (An 0%nat).
   unfold Un_cv.
   intros.
@@ -661,14 +652,14 @@ Lemma Alembert_C6 :
   simpl; ring.
   rewrite tech5.
   rewrite <- Hrecn.
-  rewrite b; simpl; ring.
+  rewrite Heq; simpl; ring.
   unfold ge; apply le_O_n.
   eapply Alembert_C5 with (k * Rabs x).
   split.
   unfold Rdiv; apply Rmult_le_pos.
   left; assumption.
   left; apply Rabs_pos_lt.
-  red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H3 in Hgt; elim (Rlt_irrefl _ Hgt).
   apply Rmult_lt_reg_l with (/ k).
   apply Rinv_0_lt_compat; assumption.
   rewrite <- Rmult_assoc.
@@ -679,7 +670,7 @@ Lemma Alembert_C6 :
   intro; apply prod_neq_R0.
   apply H0.
   apply pow_nonzero.
-  red; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H3 in Hgt; elim (Rlt_irrefl _ Hgt).
   unfold Un_cv; unfold Un_cv in H1.
   intros.
   cut (0 < eps / Rabs x).
@@ -696,7 +687,7 @@ Lemma Alembert_C6 :
   rewrite Rabs_Rabsolu.
   apply Rmult_lt_reg_l with (/ Rabs x).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt).
   rewrite <- Rmult_assoc.
   rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l.
@@ -704,7 +695,7 @@ Lemma Alembert_C6 :
   unfold R_dist in H5.
   unfold Rdiv; unfold Rdiv in H5; apply H5; assumption.
   apply Rabs_no_R0.
-  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt).
   unfold Rdiv; replace (S n) with (n + 1)%nat; [ idtac | ring ].
   rewrite pow_add.
   simpl.
@@ -716,12 +707,12 @@ Lemma Alembert_C6 :
   rewrite <- Rinv_r_sym.
   rewrite Rmult_1_r; reflexivity.
   apply pow_nonzero.
-  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt).
   apply H0.
   apply pow_nonzero.
-  red; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt).
   unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt.
-  red; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
+  red; intro H7; rewrite H7 in Hgt; elim (Rlt_irrefl _ Hgt).
 Qed.
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index 6d54b791..3e99c989 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -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        *)
@@ -156,8 +156,7 @@ Proof.
   intros.
   assert (H2 := CV_ALT_step0 _ H).
   assert (H3 := CV_ALT_step4 _ H H0).
-  assert (X := growing_cv _ H2 H3).
-  elim X; intros.
+  destruct (growing_cv _ H2 H3) as (x,p).
   exists x.
   unfold Un_cv; unfold R_dist; unfold Un_cv in H1;
     unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
@@ -388,16 +387,13 @@ Proof.
   apply Rle_ge; apply PI_tg_pos.
   apply lt_le_trans with N; assumption.
   elim H1; intros H5 _.
-  assert (H6 := lt_eq_lt_dec 0 N).
-  elim H6; intro.
-  elim a; intro.
+  destruct (lt_eq_lt_dec 0 N) as [[| <- ]|H6].
   assumption.
-  rewrite <- b in H4.
   rewrite H4 in H5.
   simpl in H5.
   cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
-  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
-  elim (lt_n_O _ b).
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H6 H5)).
+  elim (lt_n_O _ H6).
   apply le_IZR.
   simpl.
   left; apply Rlt_trans with (/ (2 * eps)).
@@ -442,7 +438,7 @@ Proof.
   unfold Rdiv in H;
     apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
   simpl; unfold tg_alt; simpl; rewrite Rmult_1_l;
-    rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
+    rewrite Rmult_1_r; apply Rplus_lt_reg_l with (PI_tg 1).
   rewrite Rplus_0_r;
     replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
       [ unfold PI_tg | ring ].
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index cfc74fc4..c4e410ed 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -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        *)
@@ -105,14 +105,14 @@ Proof.
   exists (x - IZR k0 * y).
   split.
   ring.
-  unfold k0; case (Rcase_abs y); intro.
+  unfold k0; case (Rcase_abs y) as [Hlt|Hge].
   assert (H0 := archimed (x / - y)); rewrite <- Z_R_minus; simpl;
     unfold Rminus.
   replace (- ((1 + - IZR (up (x / - y))) * y)) with
     ((IZR (up (x / - y)) - 1) * y); [ idtac | ring ].
   split.
   apply Rmult_le_reg_l with (/ - y).
-  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt.
   rewrite Rmult_0_r; rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
     rewrite <- Ropp_inv_permute; [ idtac | assumption ].
   rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
@@ -125,14 +125,14 @@ Proof.
       (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1;
     [ idtac | ring ].
   elim H0; intros _ H1; unfold Rdiv in H1; exact H1.
-  rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y).
-  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact r.
+  rewrite (Rabs_left _ Hlt); apply Rmult_lt_reg_l with (/ - y).
+  apply Rinv_0_lt_compat; apply Ropp_0_gt_lt_contravar; exact Hlt.
   rewrite <- Rinv_l_sym.
   rewrite (Rmult_comm (/ - y)); rewrite Rmult_plus_distr_r;
     rewrite <- Ropp_inv_permute; [ idtac | assumption ].
   rewrite Rmult_assoc; repeat rewrite Ropp_mult_distr_r_reverse;
     rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ];
-      apply Rplus_lt_reg_r with (IZR (up (x / - y)) - 1).
+      apply Rplus_lt_reg_l with (IZR (up (x / - y)) - 1).
   replace (IZR (up (x / - y)) - 1 + 1) with (IZR (up (x / - y)));
     [ idtac | ring ].
   replace (IZR (up (x / - y)) - 1 + (- (x * / y) + - (IZR (up (x / - y)) - 1)))
@@ -157,22 +157,21 @@ Proof.
 	    (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with
 	    1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2;
 	      exact H2.
-  rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y).
+  rewrite (Rabs_right _ Hge); apply Rmult_lt_reg_l with (/ y).
   apply Rinv_0_lt_compat; assumption.
   rewrite <- (Rinv_l_sym _ H); rewrite (Rmult_comm (/ y));
     rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym;
       [ rewrite Rmult_1_r | assumption ];
-      apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1);
+      apply Rplus_lt_reg_l with (IZR (up (x / y)) - 1);
 	replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y)));
 	  [ idtac | ring ];
 	  replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with
 	    (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv;
 	      intros H2 _; exact H2.
-  case (total_order_T 0 y); intro.
-  elim s; intro.
+  destruct (total_order_T 0 y) as [[Hlt|Heq]|Hgt].
   assumption.
-  elim H; symmetry ; exact b.
-  assert (H1 := Rge_le _ _ r); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r0)).
+  elim H; symmetry ; exact Heq.
+  apply Rge_le in Hge; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hge Hgt)).
 Qed.
 
 Lemma tech8 : forall n i:nat, (n <= S n + i)%nat.
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index 3d6121b7..d48f42fc 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -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        *)
@@ -172,13 +172,12 @@ Proof.
   apply sum_eq.
   intros; apply H1.
   unfold N; apply le_lt_trans with n; [ assumption | apply lt_n_Sn ].
-  intros; unfold Bn, Cn.
-  replace (S N - S i)%nat with (N - i)%nat; reflexivity.
+  reflexivity.
   unfold An; fold N; rewrite <- minus_n_n; rewrite H0;
     simpl; ring.
   apply sum_eq.
-  intros; unfold An, Bn; replace (S N - S i)%nat with (N - i)%nat;
-    [ idtac | reflexivity ].
+  intros; unfold An, Bn.
+  change (S N - S i)%nat with (N - i)%nat.
   rewrite <- pascal;
     [ ring
       | apply le_lt_trans with n; [ assumption | unfold N; apply lt_n_Sn ] ].
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 34567cae..28de1186 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -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/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 71e8d024..49ba9a6e 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -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        *)
@@ -12,6 +12,7 @@ Require Import SeqSeries.
 Require Import Rtrigo_def.
 Require Import Cos_rel.
 Require Import Max.
+Require Import Omega.
 Local Open Scope nat_scope.
 Local Open Scope R_scope.
 
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index 63ab24fe..f5b34de9 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -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        *)
@@ -10,6 +10,7 @@ Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
 Require Import Rtrigo_def.
+Require Import Omega.
 Local Open Scope R_scope.
 
 Definition A1 (x:R) (N:nat) : R :=
@@ -257,49 +258,30 @@ Qed.
 
 Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
 intro.
-assert (H := exist_cos (x * x)).
-elim H; intros.
-assert (p_i := p).
-unfold cos_in in p.
-unfold cos_n, infinite_sum in p.
-unfold R_dist in p.
-cut (cos x = x0).
-intro.
-rewrite H0.
-unfold Un_cv; unfold R_dist; intros.
-elim (p eps H1); intros.
+unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p).
+unfold cos_in, cos_n, infinite_sum, R_dist in p.
+unfold Un_cv, R_dist; intros.
+destruct (p eps H) as (x1,H0).
 exists x1; intros.
 unfold A1.
 replace
  (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
-apply H2; assumption.
+apply H0; assumption.
 apply sum_eq.
 intros.
 replace ((x * x) ^ i) with (x ^ (2 * i)).
 reflexivity.
 apply pow_sqr.
-unfold cos.
-case (exist_cos (Rsqr x)).
-unfold Rsqr; intros.
-unfold cos_in in p_i.
-unfold cos_in in c.
-apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption.
 Qed.
 
 Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
 intros.
-assert (H := exist_cos ((x + y) * (x + y))).
-elim H; intros.
-assert (p_i := p).
-unfold cos_in in p.
-unfold cos_n, infinite_sum in p.
-unfold R_dist in p.
-cut (cos (x + y) = x0).
-intro.
-rewrite H0.
-unfold Un_cv; unfold R_dist; intros.
-elim (p eps H1); intros.
+unfold cos.
+destruct (exist_cos (Rsqr (x + y))) as (x0,p).
+unfold cos_in, cos_n, infinite_sum, R_dist in p.
+unfold Un_cv, R_dist; intros.
+destruct (p eps H) as (x1,H0).
 exists x1; intros.
 unfold C1.
 replace
@@ -307,19 +289,12 @@ replace
  with
  (sum_f_R0
     (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n).
-apply H2; assumption.
+apply H0; assumption.
 apply sum_eq.
 intros.
 replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
 reflexivity.
 apply pow_sqr.
-unfold cos.
-case (exist_cos (Rsqr (x + y))).
-unfold Rsqr; intros.
-unfold cos_in in p_i.
-unfold cos_in in c.
-apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
- assumption.
 Qed.
 
 Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
@@ -338,21 +313,14 @@ simpl; ring.
 rewrite tech5; rewrite <- Hrecn.
 simpl; ring.
 unfold ge; apply le_O_n.
-assert (H0 := exist_sin (x * x)).
-elim H0; intros.
-assert (p_i := p).
-unfold sin_in in p.
-unfold sin_n, infinite_sum in p.
-unfold R_dist in p.
-cut (sin x = x * x0).
-intro.
-rewrite H1.
-unfold Un_cv; unfold R_dist; intros.
+unfold sin. destruct (exist_sin (Rsqr x)) as (x0,p).
+unfold sin_in, sin_n, infinite_sum, R_dist in p.
+unfold Un_cv, R_dist; intros.
 cut (0 < eps / Rabs x);
  [ intro
  | unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
-elim (p (eps / Rabs x) H3); intros.
+destruct (p (eps / Rabs x) H1) as (x1,H2).
 exists x1; intros.
 unfold B1.
 replace
@@ -370,9 +338,7 @@ replace
 rewrite Rabs_mult.
 apply Rmult_lt_reg_l with (/ Rabs x).
 apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-rewrite <- Rmult_assoc.
-rewrite <- Rinv_l_sym.
-rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
+rewrite <- Rmult_assoc, <- Rinv_l_sym, Rmult_1_l, <- (Rmult_comm eps). apply H2;
  assumption.
 apply Rabs_no_R0; assumption.
 rewrite scal_sum.
@@ -382,12 +348,4 @@ rewrite pow_add.
 rewrite pow_sqr.
 simpl.
 ring.
-unfold sin.
-case (exist_sin (Rsqr x)).
-unfold Rsqr; intros.
-unfold sin_in in p_i.
-unfold sin_in in s.
-assert
- (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s).
-rewrite H1; reflexivity.
 Qed.
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 3a2d51f9..75fd4c0a 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -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        *)
@@ -11,16 +11,19 @@ Require Import Omega.
 Local Open Scope R_scope.
 
 Lemma Rlt_R0_R2 : 0 < 2.
+Proof.
 change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
 Qed.
 
 Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing).
 
 Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
+Proof.
 intros; rewrite H; reflexivity.
 Qed.
 
 Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2.
+Proof.
 intros; red; intro; elim H; apply eq_IZR; assumption.
 Qed.
 
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index 0d418bc3..be96b94e 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -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        *)
@@ -15,6 +15,7 @@ Require Import PSeries_reg.
 Require Import Div2.
 Require Import Even.
 Require Import Max.
+Require Import Omega.
 Local Open Scope nat_scope.
 Local Open Scope R_scope.
 
@@ -85,18 +86,17 @@ Qed.
 
 Lemma div2_not_R0 : forall N:nat, (1 < N)%nat -> (0 < div2 N)%nat.
 Proof.
-  intros; induction  N as [| N HrecN].
-  elim (lt_n_O _ H).
-  cut ((1 < N)%nat \/ N = 1%nat).
-  intro; elim H0; intro.
-  assert (H2 := even_odd_dec N).
-  elim H2; intro.
-  rewrite <- (even_div2 _ a); apply HrecN; assumption.
-  rewrite <- (odd_div2 _ b); apply lt_O_Sn.
-  rewrite H1; simpl; apply lt_O_Sn.
-  inversion H.
-  right; reflexivity.
-  left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
+  intros; induction N as [| N HrecN].
+  - elim (lt_n_O _ H).
+  - cut ((1 < N)%nat \/ N = 1%nat).
+    { intro; elim H0; intro.
+      + destruct (even_odd_dec N) as [Heq|Heq].
+        * rewrite <- (even_div2 _ Heq); apply HrecN; assumption.
+        * rewrite <- (odd_div2 _ Heq); apply lt_O_Sn.
+      + rewrite H1; simpl; apply lt_O_Sn. }
+    inversion H.
+    right; reflexivity.
+    left; apply lt_le_trans with 2%nat; [ apply lt_n_Sn | apply H1 ].
 Qed.
 
 Lemma Reste_E_maj :
@@ -173,8 +173,7 @@ Proof.
   apply pow_le; apply Rabs_pos.
   rewrite (Rmult_comm (/ INR (fact (S n0)))); apply Rmult_le_compat_l.
   apply pow_le; apply Rabs_pos.
-  apply Rle_Rinv.
-  apply INR_fact_lt_0.
+  apply Rinv_le_contravar.
   apply INR_fact_lt_0.
   apply le_INR; apply fact_le; apply le_n_S.
   apply le_plus_l.
@@ -254,8 +253,7 @@ Proof.
   do 2 rewrite <- (Rmult_comm (/ INR (fact (N - n0)))).
   apply Rmult_le_compat_l.
   left; apply Rinv_0_lt_compat; apply INR_fact_lt_0.
-  apply Rle_Rinv.
-  apply INR_fact_lt_0.
+  apply Rinv_le_contravar.
   apply INR_fact_lt_0.
   apply le_INR.
   apply fact_le.
@@ -724,15 +722,14 @@ Qed.
 (**********)
 Lemma exp_pos : forall x:R, 0 < exp x.
 Proof.
-  intro; case (total_order_T 0 x); intro.
-  elim s; intro.
-  apply (exp_pos_pos _ a).
-  rewrite <- b; rewrite exp_0; apply Rlt_0_1.
+  intro; destruct (total_order_T 0 x) as [[Hlt|<-]|Hgt].
+  apply (exp_pos_pos _ Hlt).
+  rewrite exp_0; apply Rlt_0_1.
   replace (exp x) with (1 / exp (- x)).
   unfold Rdiv; apply Rmult_lt_0_compat.
   apply Rlt_0_1.
   apply Rinv_0_lt_compat; apply exp_pos_pos.
-  apply (Ropp_0_gt_lt_contravar _ r).
+  apply (Ropp_0_gt_lt_contravar _ Hgt).
   cut (exp (- x) <> 0).
   intro; unfold Rdiv; apply Rmult_eq_reg_l with (exp (- x)).
   rewrite Rmult_1_l; rewrite <- Rinv_r_sym.
@@ -773,10 +770,10 @@ Proof.
   apply (not_eq_sym H6).
   rewrite Rminus_0_r; apply H7.
   unfold SFL.
-  case (cv 0); intros.
+  case (cv 0) as (x,Hu).
   eapply UL_sequence.
-  apply u.
-  unfold Un_cv, SP.
+  apply Hu.
+  unfold Un_cv, SP in |- *.
   intros; exists 1%nat; intros.
   unfold R_dist; rewrite decomp_sum.
   rewrite (Rplus_comm (fn 0%nat 0)).
@@ -793,14 +790,13 @@ Proof.
   unfold Rdiv; rewrite Rinv_1; rewrite Rmult_1_r; reflexivity.
   apply lt_le_trans with 1%nat; [ apply lt_n_Sn | apply H9 ].
   unfold SFL, exp.
-  case (cv h); case (exist_exp h); simpl; intros.
+  case (cv h) as (x0,Hu); case (exist_exp h) as (x,Hexp); simpl.
   eapply UL_sequence.
-  apply u.
+  apply Hu.
   unfold Un_cv; intros.
-  unfold exp_in in e.
-  unfold infinite_sum in e.
+  unfold exp_in, infinite_sum in Hexp.
   cut (0 < eps0 * Rabs h).
-  intro; elim (e _ H9); intros N0 H10.
+  intro; elim (Hexp _ H9); intros N0 H10.
   exists N0; intros.
   unfold R_dist.
   apply Rmult_lt_reg_l with (Rabs h).
@@ -860,8 +856,7 @@ Proof.
         Un_cv
         (fun n:nat =>
           sum_f_R0 (fun k:nat => Rabs (r ^ k / INR (fact (S k)))) n) l }.
-  intro X.
-  elim X; intros.
+  intros (x,p).
   exists x; intros.
   split.
   apply p.
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index 50b57374..222d106f 100644
--- a/theories/Reals/Integration.v
+++ b/theories/Reals/Integration.v
@@ -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/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v
deleted file mode 100644
index cc8a8f7c..00000000
--- a/theories/Reals/LegacyRfield.v
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export Raxioms.
-Require Export LegacyField.
-Import LegacyRing_theory.
-
-Section LegacyRfield.
-
-Open Scope R_scope.
-
-Lemma RLegacyTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
-  split.
-  exact Rplus_comm.
-  symmetry ; apply Rplus_assoc.
-  exact Rmult_comm.
-  symmetry ; apply Rmult_assoc.
-  intro; apply Rplus_0_l.
-  intro; apply Rmult_1_l.
-  exact Rplus_opp_r.
-  intros.
-  rewrite Rmult_comm.
-  rewrite (Rmult_comm n p).
-  rewrite (Rmult_comm m p).
-  apply Rmult_plus_distr_l.
-  intros; contradiction.
-Defined.
-
-End LegacyRfield.
-
-Add Legacy Field
-R Rplus Rmult 1%R 0%R Ropp (fun x y:R => false) Rinv RLegacyTheory Rinv_l
-  with minus := Rminus div := Rdiv.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index d3970069..59976957 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -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        *)
@@ -151,14 +151,14 @@ Proof.
   cut (forall c:R, a <= c <= b -> continuity_pt id c);
     [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
   assert (H2 := MVT f id a b X X0 H H0 H1).
-  elim H2; intros c H3; elim H3; intros.
+  destruct H2 as (c & P & H4).
   exists c; split.
-  cut (derive_pt id c (X0 c x) = derive_pt id c (derivable_pt_id c));
-    [ intro | apply pr_nu ].
+  cut (derive_pt id c (X0 c P) = derive_pt id c (derivable_pt_id c));
+    [ intro H5 | apply pr_nu ].
   rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
-    rewrite <- H4; replace (derive_pt f c (X c x)) with (derive_pt f c (pr c));
+    rewrite <- H4; replace (derive_pt f c (X c P)) with (derive_pt f c (pr c));
       [ idtac | apply pr_nu ]; apply Rmult_comm.
-  apply x.
+  apply P.
 Qed.
 
 Theorem MVT_cor2 :
@@ -173,14 +173,14 @@ Proof.
   intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
   intro X1; cut (forall c:R, a < c < b -> derivable_pt id c).
   intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c).
-  intro; elim (MVT f id a b X0 X2 H H1 H2); intros; elim H3; clear H3; intros;
-    exists x; split.
-  cut (derive_pt id x (X2 x x0) = 1).
-  cut (derive_pt f x (X0 x x0) = f' x).
+  intro; elim (MVT f id a b X0 X2 H H1 H2); intros x (P,H3).
+  exists x; split.
+  cut (derive_pt id x (X2 x P) = 1).
+  cut (derive_pt f x (X0 x P) = f' x).
   intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
     rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry ;
       assumption.
-  apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption.
+  apply derive_pt_eq_0; apply H0; elim P; intros; split; left; assumption.
   apply derive_pt_eq_0; apply derivable_pt_lim_id.
   assumption.
   intros; apply derivable_continuous_pt; apply X1; assumption.
@@ -217,12 +217,12 @@ Proof.
   assert (H3 := MVT f id a b pr H2 H0 H);
     assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
   intros; apply derivable_continuous; apply derivable_id.
-  elim (H3 H4); intros; elim H5; intros; exists x; exists x0; rewrite H1 in H6;
-    unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6;
-      rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
-        [ rewrite Rmult_0_r; apply H6
-          | apply Rminus_eq_contra; red; intro; rewrite H7 in H0;
-            elim (Rlt_irrefl _ H0) ].
+  destruct (H3 H4) as (c & P & H6). exists c; exists P; rewrite H1 in H6.
+  unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6.
+  rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
+    [ rewrite Rmult_0_r; apply H6
+      | apply Rminus_eq_contra; red; intro H7; rewrite H7 in H0;
+        elim (Rlt_irrefl _ H0) ].
 Qed.
 
 (**********)
@@ -233,21 +233,18 @@ Proof.
   intros.
   unfold increasing.
   intros.
-  case (total_order_T x y); intro.
-  elim s; intro.
+  destruct (total_order_T x y) as [[H1| ->]|H1].
   apply Rplus_le_reg_l with (- f x).
   rewrite Rplus_opp_l; rewrite Rplus_comm.
-  assert (H1 := MVT_cor1 f _ _ pr a).
-  elim H1; intros.
-  elim H2; intros.
+  pose proof (MVT_cor1 f _ _ pr H1) as (c & H3 & H4).
   unfold Rminus in H3.
   rewrite H3.
   apply Rmult_le_pos.
   apply H.
   apply Rplus_le_reg_l with x.
   rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
-  rewrite b; right; reflexivity.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+  right; reflexivity.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 H1)).
 Qed.
 
 (**********)
@@ -269,7 +266,7 @@ Proof.
     cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
   intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
   intro; unfold Rabs;
-    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
+    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge].
   intros;
     generalize
       (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
@@ -294,7 +291,7 @@ Proof.
   ring.
   intros.
   generalize
-    (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 r).
+    (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) _ Hge).
   rewrite Ropp_0.
   intro.
   elim
@@ -412,7 +409,7 @@ Proof.
   intros.
   unfold strict_increasing.
   intros.
-  apply Rplus_lt_reg_r with (- f x).
+  apply Rplus_lt_reg_l with (- f x).
   rewrite Rplus_opp_l; rewrite Rplus_comm.
   assert (H1 := MVT_cor1 f _ _ pr H0).
   elim H1; intros.
@@ -421,7 +418,7 @@ Proof.
   rewrite H3.
   apply Rmult_lt_0_compat.
   apply H.
-  apply Rplus_lt_reg_r with x.
+  apply Rplus_lt_reg_l with x.
   rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
 Qed.
 
@@ -517,7 +514,7 @@ Lemma derive_increasing_interv_ax :
 Proof.
   intros.
   split; intros.
-  apply Rplus_lt_reg_r with (- f x).
+  apply Rplus_lt_reg_l with (- f x).
   rewrite Rplus_opp_l; rewrite Rplus_comm.
   assert (H4 := MVT_cor1 f _ _ pr H3).
   elim H4; intros.
@@ -532,7 +529,7 @@ Proof.
   apply Rle_lt_trans with x; assumption.
   elim H2; intros.
   apply Rlt_le_trans with y; assumption.
-  apply Rplus_lt_reg_r with x.
+  apply Rplus_lt_reg_l with x.
   rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
   apply Rplus_le_reg_l with (- f x).
   rewrite Rplus_opp_l; rewrite Rplus_comm.
@@ -587,12 +584,8 @@ Theorem IAF :
     f b - f a <= k * (b - a).
 Proof.
   intros.
-  case (total_order_T a b); intro.
-  elim s; intro.
-  assert (H1 := MVT_cor1 f _ _ pr a0).
-  elim H1; intros.
-  elim H2; intros.
-  rewrite H3.
+  destruct (total_order_T a b) as [[H1| -> ]|H1].
+  pose proof (MVT_cor1 f _ _ pr H1) as (c & -> & H4).
   do 2 rewrite <- (Rmult_comm (b - a)).
   apply Rmult_le_compat_l.
   apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
@@ -600,10 +593,9 @@ Proof.
   apply H0.
   elim H4; intros.
   split; left; assumption.
-  rewrite b0.
   unfold Rminus; do 2 rewrite Rplus_opp_r.
   rewrite Rmult_0_r; right; reflexivity.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H H1)).
 Qed.
 
 Lemma IAF_var :
@@ -648,8 +640,7 @@ Lemma null_derivative_loc :
     (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
     constant_D_eq f (fun x:R => a <= x <= b) (f a).
 Proof.
-  intros; unfold constant_D_eq; intros; case (total_order_T a b); intro.
-  elim s; intro.
+  intros; unfold constant_D_eq; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
   assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
   intros; apply derivable_pt_id.
   assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
@@ -664,24 +655,25 @@ Proof.
   elim H1; intros; apply Rle_trans with x; assumption.
   elim H1; clear H1; intros; elim H1; clear H1; intro.
   assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
-  elim H7; intros; elim H8; intros; assert (H10 : a < x0 < b).
-  elim x1; intros; split.
-  assumption.
-  apply Rlt_le_trans with x; assumption.
-  assert (H11 : derive_pt f x0 (H4 x0 x1) = 0).
-  replace (derive_pt f x0 (H4 x0 x1)) with (derive_pt f x0 (pr x0 H10));
+  destruct H7 as (c & P & H9).
+  assert (H10 : a < c < b).
+  split.
+  apply P.
+  apply Rlt_le_trans with x; [apply P|assumption].
+  assert (H11 : derive_pt f c (H4 c P) = 0).
+  replace (derive_pt f c (H4 c P)) with (derive_pt f c (pr c H10));
   [ apply H0 | apply pr_nu ].
-  assert (H12 : derive_pt id x0 (H2 x0 x1) = 1).
+  assert (H12 : derive_pt id c (H2 c P) = 1).
   apply derive_pt_eq_0; apply derivable_pt_lim_id.
   rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
     rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry ;
       assumption.
   rewrite H1; reflexivity.
   assert (H2 : x = a).
-  rewrite <- b0 in H1; elim H1; intros; apply Rle_antisym; assumption.
+  rewrite <- Heq in H1; elim H1; intros; apply Rle_antisym; assumption.
   rewrite H2; reflexivity.
   elim H1; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) r)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) Hgt)).
 Qed.
 
 (* Unicity of the antiderivative *)
@@ -718,3 +710,32 @@ Proof.
     unfold constant_D_eq in H8; assert (H9 := H8 _ H2);
       unfold minus_fct in H9; rewrite <- H9; ring.
 Qed.
+
+(* A variant of MVT using absolute values. *)
+Lemma MVT_abs : 
+  forall (f f' : R -> R) (a b : R),
+  (forall c : R, Rmin a b <= c <= Rmax a b ->
+      derivable_pt_lim f c (f' c)) ->
+  exists c : R, Rabs (f b - f a) = Rabs (f' c) * Rabs (b - a) /\
+             Rmin a b <= c <= Rmax a b.
+Proof.
+intros f f' a b.
+destruct (Rle_dec a b) as [aleb | blta].
+ destruct (Req_dec a b) as [ab | anb].
+  unfold Rminus; intros _; exists a; split.
+   now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r.
+  split;[apply Rmin_l | apply Rmax_l].
+ rewrite Rmax_right, Rmin_left; auto; intros derv.
+ destruct (MVT_cor2 f f' a b) as [c [hc intc]];
+  [destruct aleb;[assumption | contradiction] | apply derv | ].
+ exists c; rewrite hc, Rabs_mult;split;
+  [reflexivity | unfold Rle; tauto].
+assert (b < a) by (apply Rnot_le_gt; assumption).
+assert (b <= a) by (apply Rlt_le; assumption).
+rewrite Rmax_left, Rmin_right; try assumption; intros derv.
+destruct (MVT_cor2 f f' b a) as [c [hc intc]];
+ [assumption | apply derv | ].
+exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult.
+split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto].
+Qed.
+
diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v
index 40a857e3..1a94f6a8 100644
--- a/theories/Reals/Machin.v
+++ b/theories/Reals/Machin.v
@@ -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        *)
@@ -16,6 +16,7 @@ Require Import Rseries.
 Require Import SeqProp.
 Require Import PartSum.
 Require Import Ratan.
+Require Import Omega.
 
 Local Open Scope R_scope.
 
@@ -27,6 +28,7 @@ Lemma atan_sub_correct :
  forall u v, 1 + u * v <> 0 -> -PI/2 < atan u - atan v < PI/2 ->
    -PI/2 < atan (atan_sub u v) < PI/2 ->
    atan u = atan v + atan (atan_sub u v).
+Proof.
 intros u v pn0 uvint aint.
 assert (cos (atan u) <> 0).
  destruct (atan_bound u); apply Rgt_not_eq, cos_gt_0; auto.
@@ -44,6 +46,7 @@ Qed.
 
 Lemma tech : forall x y , -1 <= x <= 1 -> -1 < y < 1 -> 
   -PI/2 < atan x - atan y < PI/2.
+Proof.
 assert (ut := PI_RGT_0).
 intros x y [xm1 x1] [ym1 y1].
 assert (-(PI/4) <= atan x).
@@ -67,6 +70,7 @@ Qed.
 
 (* A simple formula, reasonably efficient. *)
 Lemma Machin_2_3 : PI/4 = atan(/2) + atan(/3).
+Proof.
 assert (utility : 0 < PI/2) by (apply PI2_RGT_0).
 rewrite <- atan_1.
 rewrite (atan_sub_correct 1 (/2)).
@@ -77,6 +81,7 @@ apply atan_bound.
 Qed.
 
 Lemma Machin_4_5_239 : PI/4 = 4 * atan (/5) - atan(/239).
+Proof.
 rewrite <- atan_1.
 rewrite (atan_sub_correct 1 (/5));
  [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
@@ -105,6 +110,7 @@ unfold atan_sub; field.
 Qed.
 
 Lemma Machin_2_3_7 : PI/4 = 2 * atan(/3) + (atan (/7)).
+Proof.
 rewrite <- atan_1.
 rewrite (atan_sub_correct 1 (/3));
  [ | apply Rgt_not_eq; fourier | apply tech; try split; fourier |
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 8faf3b41..832e7adc 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -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        *)
@@ -63,14 +63,16 @@ Proof.
       [ apply derivable_pt_lim_const | apply derivable_pt_lim_id ]
       | unfold id, fct_cte; rewrite H2; ring ].
   right; reflexivity.
-Defined.
+Qed.
 
 (* $\int_a^a f = 0$ *)
 Lemma NewtonInt_P2 :
   forall (f:R -> R) (a:R), NewtonInt f a a (NewtonInt_P1 f a) = 0.
 Proof.
   intros; unfold NewtonInt; simpl;
-    unfold mult_fct, fct_cte, id; ring.
+    unfold mult_fct, fct_cte, id.
+  destruct NewtonInt_P1 as [g _].
+  now apply Rminus_diag_eq.
 Qed.
 
 (* If $\int_a^b f$ exists, then $\int_b^a f$ exists too *)
@@ -87,42 +89,7 @@ Lemma NewtonInt_P4 :
   forall (f:R -> R) (a b:R) (pr:Newton_integrable f a b),
     NewtonInt f a b pr = - NewtonInt f b a (NewtonInt_P3 f a b pr).
 Proof.
-  intros; unfold Newton_integrable in pr; elim pr; intros; elim p; intro.
-  unfold NewtonInt;
-    case
-    (NewtonInt_P3 f a b
-      (exist
-        (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
-        p)).
-  intros; elim o; intro.
-  unfold antiderivative in H0; elim H0; intros; elim H2; intro.
-  unfold antiderivative in H; elim H; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
-  rewrite H3; ring.
-  assert (H1 := antiderivative_Ucte f x x0 a b H H0); elim H1; intros;
-    unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  assert (H3 : a <= a <= b).
-  split; [ right; reflexivity | assumption ].
-  assert (H4 : a <= b <= b).
-  split; [ assumption | right; reflexivity ].
-  assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
-  unfold NewtonInt;
-    case
-    (NewtonInt_P3 f a b
-      (exist
-        (fun g:R -> R => antiderivative f g a b \/ antiderivative f g b a) x
-        p)); intros; elim o; intro.
-  assert (H1 := antiderivative_Ucte f x x0 b a H H0); elim H1; intros;
-    unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  assert (H3 : b <= a <= a).
-  split; [ assumption | right; reflexivity ].
-  assert (H4 : b <= b <= a).
-  split; [ right; reflexivity | assumption ].
-  assert (H5 := H2 _ H3); assert (H6 := H2 _ H4); rewrite H5; rewrite H6; ring.
-  unfold antiderivative in H0; elim H0; intros; elim H2; intro.
-  unfold antiderivative in H; elim H; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H5 H3)).
-  rewrite H3; ring.
+  intros f a b (x,H). unfold NewtonInt, NewtonInt_P3; simpl; ring.
 Qed.
 
 (* The set of Newton integrable functions is a vectorial space *)
@@ -133,7 +100,7 @@ Lemma NewtonInt_P5 :
     Newton_integrable (fun x:R => l * f x + g x) a b.
 Proof.
   unfold Newton_integrable; intros f g l a b X X0;
-    elim X; intros; elim X0; intros;
+    elim X; intros x p; elim X0; intros x0 p0;
       exists (fun y:R => l * x y + x0 y).
   elim p; intro.
   elim p0; intro.
@@ -227,10 +194,8 @@ Lemma NewtonInt_P6 :
     l * NewtonInt f a b pr1 + NewtonInt g a b pr2.
 Proof.
   intros f g l a b pr1 pr2; unfold NewtonInt;
-    case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1;
-      intros; case pr2; intros; case (total_order_T a b);
-        intro.
-  elim s; intro.
+    destruct (NewtonInt_P5 f g l a b pr1 pr2) as (x,o); destruct pr1 as (x0,o0);
+      destruct pr2 as (x1,o1); destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
   elim o; intro.
   elim o0; intro.
   elim o1; intro.
@@ -242,21 +207,21 @@ Proof.
   split; [ left; assumption | right; reflexivity ].
   assert (H7 := H4 _ H5); assert (H8 := H4 _ H6); rewrite H7; rewrite H8; ring.
   unfold antiderivative in H1; elim H1; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 a0)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hlt)).
   unfold antiderivative in H0; elim H0; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).
   unfold antiderivative in H; elim H; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 a0)).
-  rewrite b0; ring.
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hlt)).
+  rewrite Heq; ring.
   elim o; intro.
   unfold antiderivative in H; elim H; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 r)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 Hgt)).
   elim o0; intro.
   unfold antiderivative in H0; elim H0; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)).
   elim o1; intro.
   unfold antiderivative in H1; elim H1; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 Hgt)).
   assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1);
     assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2);
       elim H3; intros; assert (H5 : b <= a <= a).
@@ -277,14 +242,12 @@ Lemma antiderivative_P2 :
         | right _ => F1 x + (F0 b - F1 b)
       end) a c.
 Proof.
-  unfold antiderivative; intros; elim H; clear H; intros; elim H0;
-    clear H0; intros; split.
+  intros; destruct H as (H,H1), H0 as (H0,H2); split.
   2: apply Rle_trans with b; assumption.
-  intros; elim H3; clear H3; intros; case (total_order_T x b); intro.
-  elim s; intro.
+  intros x (H3,H4); destruct (total_order_T x b) as [[Hlt|Heq]|Hgt].
   assert (H5 : a <= x <= b).
   split; [ assumption | left; assumption ].
-  assert (H6 := H _ H5); elim H6; clear H6; intros;
+  destruct (H _ H5) as (x0,H6).
     assert
       (H7 :
         derivable_pt_lim
@@ -293,27 +256,26 @@ Proof.
             | left _ => F0 x
             | right _ => F1 x + (F0 b - F1 b)
           end) x (f x)).
-  unfold derivable_pt_lim; assert (H7 : derive_pt F0 x x0 = f x).
-  symmetry ; assumption.
-  assert (H8 := derive_pt_eq_1 F0 x (f x) x0 H7); unfold derivable_pt_lim in H8;
-    intros; elim (H8 _ H9); intros; set (D := Rmin x1 (b - x)).
+  unfold derivable_pt_lim. intros eps H9.
+  assert (H7 : derive_pt F0 x x0 = f x) by (symmetry; assumption).
+  destruct (derive_pt_eq_1 F0 x (f x) x0 H7 _ H9) as (x1,H10); set (D := Rmin x1 (b - x)).
   assert (H11 : 0 < D).
-  unfold D; unfold Rmin; case (Rle_dec x1 (b - x)); intro.
+  unfold D, Rmin; case (Rle_dec x1 (b - x)); intro.
   apply (cond_pos x1).
   apply Rlt_Rminus; assumption.
-  exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
-  case (Rle_dec (x + h) b); intro.
+  exists (mkposreal _ H11); intros h H12 H13. case (Rle_dec x b) as [|[]].
+  case (Rle_dec (x + h) b) as [|[]].
   apply H10.
   assumption.
   apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
-  elim n; left; apply Rlt_le_trans with (x + D).
+  left; apply Rlt_le_trans with (x + D).
   apply Rplus_lt_compat_l; apply Rle_lt_trans with (Rabs h).
   apply RRle_abs.
   apply H13.
   apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
     rewrite Rplus_0_l; rewrite Rplus_comm; unfold D;
       apply Rmin_r.
-  elim n; left; assumption.
+  left; assumption.
   assert
     (H8 :
       derivable_pt
@@ -348,7 +310,7 @@ Proof.
   unfold D; unfold Rmin; case (Rle_dec x2 x3); intro.
   apply (cond_pos x2).
   apply (cond_pos x3).
-  exists (mkposreal _ H16); intros; case (Rle_dec x b); intro.
+  exists (mkposreal _ H16); intros; case (Rle_dec x b) as [|[]].
   case (Rle_dec (x + h) b); intro.
   apply H15.
   assumption.
@@ -357,8 +319,8 @@ Proof.
   apply H14.
   assumption.
   apply Rlt_le_trans with D; [ assumption | unfold D; apply Rmin_l ].
-  rewrite b0; ring.
-  elim n; right; assumption.
+  rewrite Heq; ring.
+  right; assumption.
   assert
     (H14 :
       derivable_pt
@@ -388,12 +350,12 @@ Proof.
   unfold D; unfold Rmin; case (Rle_dec x1 (x - b)); intro.
   apply (cond_pos x1).
   apply Rlt_Rminus; assumption.
-  exists (mkposreal _ H11); intros; case (Rle_dec x b); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
-  case (Rle_dec (x + h) b); intro.
+  exists (mkposreal _ H11); intros; destruct (Rle_dec x b) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)).
+  destruct (Rle_dec (x + h) b) as [Hle'|Hnle'].
   cut (b < x + h).
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)).
-  apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h);
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14)).
+  apply Rplus_lt_reg_l with (- h - b); replace (- h - b + b) with (- h);
     [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b);
     [ idtac | ring ]; apply Rle_lt_trans with (Rabs h).
   rewrite <- Rabs_Ropp; apply RRle_abs.
@@ -425,8 +387,7 @@ Lemma antiderivative_P3 :
     antiderivative f F1 c a \/ antiderivative f F0 a c.
 Proof.
   intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
-    intros; case (total_order_T a c); intro.
-  elim s; intro.
+    intros; destruct (total_order_T a c) as [[Hle|Heq]|Hgt].
   right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ assumption | apply Rle_trans with c; assumption ].
@@ -448,8 +409,7 @@ Lemma antiderivative_P4 :
     antiderivative f F1 b c \/ antiderivative f F0 c b.
 Proof.
   intros; unfold antiderivative in H, H0; elim H; clear H; elim H0; clear H0;
-    intros; case (total_order_T c b); intro.
-  elim s; intro.
+    intros; destruct (total_order_T c b) as [[Hlt|Heq]|Hgt].
   right; unfold antiderivative; split.
   intros; apply H1; elim H3; intros; split;
     [ apply Rle_trans with c; assumption | assumption ].
@@ -499,10 +459,8 @@ Proof.
   intros.
   elim X; intros F0 H0.
   elim X0; intros F1 H1.
-  case (total_order_T a b); intro.
-  elim s; intro.
-  case (total_order_T b c); intro.
-  elim s0; intro.
+  destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
+  destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].
 (* a<b & b<c *)
   unfold Newton_integrable;
     exists
@@ -515,84 +473,81 @@ Proof.
   elim H1; intro.
   left; apply antiderivative_P2; assumption.
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a1)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')).
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).
 (* a<b & b=c *)
-  rewrite b0 in X; apply X.
+  rewrite Heq' in X; apply X.
 (* a<b & b>c *)
-  case (total_order_T a c); intro.
-  elim s0; intro.
+  destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt''].
   unfold Newton_integrable; exists F0.
   left.
   elim H1; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
   elim H0; intro.
   assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
   elim H3; intro.
   unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')).
   assumption.
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
-  rewrite b0; apply NewtonInt_P1.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).
+  rewrite Heq''; apply NewtonInt_P1.
   unfold Newton_integrable; exists F1.
   right.
   elim H1; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
   elim H0; intro.
   assert (H3 := antiderivative_P3 f F0 F1 a b c H2 H).
   elim H3; intro.
   assumption.
   unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')).
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt)).
 (* a=b *)
-  rewrite b0; apply X0.
-  case (total_order_T b c); intro.
-  elim s; intro.
+  rewrite Heq; apply X0.
+  destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].
 (* a>b & b<c *)
-  case (total_order_T a c); intro.
-  elim s0; intro.
+  destruct (total_order_T a c) as [[Hlt''|Heq'']|Hgt''].
   unfold Newton_integrable; exists F1.
   left.
   elim H1; intro.
 (*****************)
   elim H0; intro.
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hgt)).
   assert (H3 := antiderivative_P4 f F0 F1 b a c H2 H).
   elim H3; intro.
   assumption.
   unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 a1)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hlt'')).
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
-  rewrite b0; apply NewtonInt_P1.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt')).
+  rewrite Heq''; apply NewtonInt_P1.
   unfold Newton_integrable; exists F0.
   right.
   elim H0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
   elim H1; intro.
   assert (H3 := antiderivative_P4 f F0 F1 b a c H H2).
   elim H3; intro.
   unfold antiderivative in H4; elim H4; clear H4; intros _ H4.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 r0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 Hgt'')).
   assumption.
   unfold antiderivative in H2; elim H2; clear H2; intros _ H2.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H2 Hlt')).
 (* a>b & b=c *)
-  rewrite b0 in X; apply X.
+  rewrite Heq' in X; apply X.
 (* a>b & b>c *)
   assert (X1 := NewtonInt_P3 f a b X).
   assert (X2 := NewtonInt_P3 f b c X0).
   apply NewtonInt_P3.
   apply NewtonInt_P7 with b; assumption.
-Defined.
+Qed.
 
 (* Chasles' relation *)
 Lemma NewtonInt_P9 :
@@ -602,17 +557,15 @@ Lemma NewtonInt_P9 :
     NewtonInt f a b pr1 + NewtonInt f b c pr2.
 Proof.
   intros; unfold NewtonInt.
-  case (NewtonInt_P8 f a b c pr1 pr2); intros.
-  case pr1; intros.
-  case pr2; intros.
-  case (total_order_T a b); intro.
-  elim s; intro.
-  case (total_order_T b c); intro.
-  elim s0; intro.
+  case (NewtonInt_P8 f a b c pr1 pr2) as (x,Hor).
+  case pr1 as (x0,Hor0).
+  case pr2 as (x1,Hor1).
+  destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
+  destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].
 (* a<b & b<c *)
-  elim o0; intro.
-  elim o1; intro.
-  elim o; intro.
+  case Hor0; intro.
+  case Hor1; intro.
+  case Hor; intro.
   assert (H2 := antiderivative_P2 f x0 x1 a b c H H0).
   assert
     (H3 :=
@@ -628,23 +581,23 @@ Proof.
   assert (H6 : a <= c <= c).
   split; [ left; apply Rlt_trans with b; assumption | right; reflexivity ].
   rewrite (H4 _ H5); rewrite (H4 _ H6).
-  case (Rle_dec a b); intro.
-  case (Rle_dec c b); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a1)).
+  destruct (Rle_dec a b) as [Hlea|Hnlea].
+  destruct (Rle_dec c b) as [Hlec|Hnlec].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlec Hlt')).
   ring.
-  elim n; left; assumption.
+  elim Hnlea; left; assumption.
   unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ a0 a1))).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hlt Hlt'))).
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a1)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt')).
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).
 (* a<b & b=c *)
-  rewrite <- b0.
+  rewrite <- Heq'.
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
-  rewrite <- b0 in o.
-  elim o0; intro.
-  elim o; intro.
+  rewrite <- Heq' in Hor.
+  elim Hor0; intro.
+  elim Hor; intro.
   assert (H1 := antiderivative_Ucte f x x0 a b H0 H).
   elim H1; intros.
   rewrite (H2 b).
@@ -653,25 +606,25 @@ Proof.
   split; [ right; reflexivity | left; assumption ].
   split; [ left; assumption | right; reflexivity ].
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)).
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hlt)).
 (* a<b & b>c *)
-  elim o1; intro.
+  elim Hor1; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-  elim o0; intro.
-  elim o; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt')).
+  elim Hor0; intro.
+  elim Hor; intro.
   assert (H2 := antiderivative_P2 f x x1 a c b H1 H).
   assert (H3 := antiderivative_Ucte _ _ _ a b H0 H2).
   elim H3; intros.
   rewrite (H4 a).
   rewrite (H4 b).
-  case (Rle_dec b c); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 r)).
-  case (Rle_dec a c); intro.
+  destruct (Rle_dec b c) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt')).
+  destruct (Rle_dec a c) as [Hle'|Hnle'].
   ring.
-  elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+  elim Hnle'; unfold antiderivative in H1; elim H1; intros; assumption.
   split; [ left; assumption | right; reflexivity ].
   split; [ right; reflexivity | left; assumption ].
   assert (H2 := antiderivative_P2 _ _ _ _ _ _ H1 H0).
@@ -679,19 +632,19 @@ Proof.
   elim H3; intros.
   rewrite (H4 c).
   rewrite (H4 b).
-  case (Rle_dec b a); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 a0)).
-  case (Rle_dec c a); intro.
+  destruct (Rle_dec b a) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hlt)).
+  destruct (Rle_dec c a) as [Hle'|[]].
   ring.
-  elim n0; unfold antiderivative in H1; elim H1; intros; assumption.
+  unfold antiderivative in H1; elim H1; intros; assumption.
   split; [ left; assumption | right; reflexivity ].
   split; [ right; reflexivity | left; assumption ].
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt)).
 (* a=b *)
-  rewrite b0 in o; rewrite b0.
-  elim o; intro.
-  elim o1; intro.
+  rewrite Heq in Hor |- *.
+  elim Hor; intro.
+  elim Hor1; intro.
   assert (H1 := antiderivative_Ucte _ _ _ b c H H0).
   elim H1; intros.
   assert (H3 : b <= c).
@@ -705,7 +658,7 @@ Proof.
   unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
     assumption.
   rewrite H1; ring.
-  elim o1; intro.
+  elim Hor1; intro.
   assert (H1 : b = c).
   unfold antiderivative in H, H0; elim H; elim H0; intros; apply Rle_antisym;
     assumption.
@@ -720,25 +673,24 @@ Proof.
   split; [ assumption | right; reflexivity ].
   split; [ right; reflexivity | assumption ].
 (* a>b & b<c *)
-  case (total_order_T b c); intro.
-  elim s; intro.
-  elim o0; intro.
+  destruct (total_order_T b c) as [[Hlt'|Heq']|Hgt'].
+  elim Hor0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-  elim o1; intro.
-  elim o; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
+  elim Hor1; intro.
+  elim Hor; intro.
   assert (H2 := antiderivative_P2 _ _ _ _ _ _ H H1).
   assert (H3 := antiderivative_Ucte _ _ _ b c H0 H2).
   elim H3; intros.
   rewrite (H4 b).
   rewrite (H4 c).
-  case (Rle_dec b a); intro.
-  case (Rle_dec c a); intro.
+  case (Rle_dec b a) as [|[]].
+  case (Rle_dec c a) as [|].
   assert (H5 : a = c).
   unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
   rewrite H5; ring.
   ring.
-  elim n; left; assumption.
+  left; assumption.
   split; [ left; assumption | right; reflexivity ].
   split; [ right; reflexivity | left; assumption ].
   assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H1).
@@ -746,27 +698,27 @@ Proof.
   elim H3; intros.
   rewrite (H4 a).
   rewrite (H4 b).
-  case (Rle_dec b c); intro.
-  case (Rle_dec a c); intro.
+  case (Rle_dec b c) as [|[]].
+  case (Rle_dec a c) as [|].
   assert (H5 : a = c).
   unfold antiderivative in H1; elim H1; intros; apply Rle_antisym; assumption.
   rewrite H5; ring.
   ring.
-  elim n; left; assumption.
+  left; assumption.
   split; [ right; reflexivity | left; assumption ].
   split; [ left; assumption | right; reflexivity ].
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 a0)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hlt')).
 (* a>b & b=c *)
-  rewrite <- b0.
+  rewrite <- Heq'.
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r.
-  rewrite <- b0 in o.
-  elim o0; intro.
+  rewrite <- Heq' in Hor.
+  elim Hor0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-  elim o; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
+  elim Hor; intro.
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt)).
   assert (H1 := antiderivative_Ucte f x x0 b a H0 H).
   elim H1; intros.
   rewrite (H2 b).
@@ -775,15 +727,15 @@ Proof.
   split; [ left; assumption | right; reflexivity ].
   split; [ right; reflexivity | left; assumption ].
 (* a>b & b>c *)
-  elim o0; intro.
+  elim Hor0; intro.
   unfold antiderivative in H; elim H; clear H; intros _ H.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
-  elim o1; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
+  elim Hor1; intro.
   unfold antiderivative in H0; elim H0; clear H0; intros _ H0.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 r0)).
-  elim o; intro.
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 Hgt')).
+  elim Hor; intro.
   unfold antiderivative in H1; elim H1; clear H1; intros _ H1.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ r0 r))).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 (Rlt_trans _ _ _ Hgt' Hgt))).
   assert (H2 := antiderivative_P2 _ _ _ _ _ _ H0 H).
   assert (H3 := antiderivative_Ucte _ _ _ c a H1 H2).
   elim H3; intros.
@@ -791,11 +743,11 @@ Proof.
   unfold antiderivative in H1; elim H1; intros; assumption.
   rewrite (H4 c).
   rewrite (H4 a).
-  case (Rle_dec a b); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r1 r)).
-  case (Rle_dec c b); intro.
+  destruct (Rle_dec a b) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle Hgt)).
+  destruct (Rle_dec c b) as [|[]].
   ring.
-  elim n0; left; assumption.
+  left; assumption.
   split; [ assumption | right; reflexivity ].
   split; [ right; reflexivity | assumption ].
 Qed.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index 199c2014..30a26f77 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -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        *)
@@ -10,12 +10,116 @@ Require Import Rbase.
 Require Import Rfunctions.
 Require Import SeqSeries.
 Require Import Ranalysis1.
+Require Import MVT.
 Require Import Max.
 Require Import Even.
+Require Import Fourier.
 Local Open Scope R_scope.
 
+(* Boule is French for Ball *)
+
 Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
 
+(* General properties of balls. *)
+
+Lemma Boule_convex : forall c d x y z,
+  Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z.
+intros c d x y z bx b_y intz.
+unfold Boule in bx, b_y; apply Rabs_def2 in bx;
+apply Rabs_def2 in b_y; apply Rabs_def1;
+ [apply Rle_lt_trans with (y - c);[apply Rplus_le_compat_r|]|
+  apply Rlt_le_trans with (x - c);[|apply Rplus_le_compat_r]];tauto.
+Qed.
+
+Definition boule_of_interval x y (h : x < y) :
+  {c :R & {r : posreal | c - r = x /\ c + r = y}}.
+exists ((x + y)/2).
+assert (radius : 0 < (y - x)/2).
+ unfold Rdiv; apply Rmult_lt_0_compat.
+  apply Rlt_Rminus; assumption.
+ now apply Rinv_0_lt_compat, Rlt_0_2.
+ exists (mkposreal _ radius).
+ simpl; split; unfold Rdiv; field.
+Qed.
+
+Definition boule_in_interval x y z (h : x < z < y) :
+  {c : R & {r | Boule c r z /\  x < c - r /\ c + r < y}}.
+Proof.
+assert (cmp : x * /2 + z * /2 < z * /2 + y * /2).
+destruct h as [h1 h2].
+rewrite Rplus_comm; apply Rplus_lt_compat_l, Rmult_lt_compat_r.
+ apply Rinv_0_lt_compat, Rlt_0_2.
+apply Rlt_trans with z; assumption.
+destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]].
+assert (0 < /2) by (apply Rinv_0_lt_compat, Rlt_0_2).
+exists c, r; split.
+ destruct h; unfold Boule; simpl; apply Rabs_def1.
+  apply Rplus_lt_reg_l with c; rewrite P2;
+  replace (c + (z - c)) with (z * / 2 + z * / 2) by field.
+  apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption.
+ apply Rplus_lt_reg_l with c; change (c + - r) with (c - r);
+ rewrite P1;
+ replace (c + (z - c)) with (z * / 2 + z * / 2) by field.
+ apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption.
+destruct h; split.
+ replace x with (x * / 2 + x * / 2) by field; rewrite P1.
+ apply Rplus_lt_compat_l, Rmult_lt_compat_r;assumption.
+replace y with (y * / 2 + y * /2) by field; rewrite P2.
+apply Rplus_lt_compat_r, Rmult_lt_compat_r;assumption.
+Qed.
+
+Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
+  Boule c1 r1 x -> Boule c2 r2 x ->
+  {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
+intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
+assert (Rmax (c1 - r1)(c2 - r2) < x).
+ apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
+  apply Rabs_def2 in h; destruct h as [_ u];
+  apply (fun h => Rplus_lt_reg_r _ _ _ (Rle_lt_trans _ _ _ h u)), Req_le; ring.
+assert (x < Rmin (c1 + r1) (c2 + r2)).
+ apply Rmin_glb_lt;[revert in1 | revert in2]; intros h;
+ apply Rabs_def2 in h; destruct h as [u _];
+ apply (fun h => Rplus_lt_reg_r _ _ _ (Rlt_le_trans _ _ _ u h)), Req_le; ring.
+assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2))
+              (Rmin (c1 + r1) (c2 + r2) - x)).
+ apply Rmin_glb_lt; apply Rlt_Rminus; assumption.
+exists (mkposreal _ t).
+apply Rabs_def2 in in1; destruct in1.
+apply Rabs_def2 in in2; destruct in2.
+assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l.
+assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r.
+assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l.
+assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r.
+assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
+         (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2))
+ by apply Rmin_l.
+assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
+         (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x)
+ by apply Rmin_r.
+simpl.
+intros y h; apply Rabs_def2 in h; destruct h as [h h'].
+apply Rmin_Rgt in h; destruct h as [cmp1 cmp2].
+apply Rplus_lt_reg_r in cmp2; apply Rmin_Rgt in cmp2.
+rewrite Ropp_Rmin, Ropp_minus_distr in h'.
+apply Rmax_Rlt in h'; destruct h' as [cmp3 cmp4];
+apply Rplus_lt_reg_r in cmp3; apply Rmax_Rlt in cmp3;
+split; apply Rabs_def1.
+apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj1 cmp2))), Req_le;
+ ring.
+apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj1 cmp3) h)), Req_le;
+ ring.
+apply (fun h => Rplus_lt_reg_l _ _ _ (Rle_lt_trans _ _ _ h (proj2 cmp2))), Req_le;
+ ring.
+apply (fun h => Rplus_lt_reg_l _ _ _ (Rlt_le_trans _ _ _ (proj2 cmp3) h)), Req_le;
+ ring.
+Qed.
+
+Lemma Boule_center : forall x r, Boule x r x.
+Proof.
+intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r.
+rewrite Rabs_pos_eq;[assumption | apply Rle_refl].
+Qed.
+
 (** Uniform convergence *)
 Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R)
   (r:posreal) : Prop :=
@@ -153,7 +257,7 @@ Proof.
   unfold Boule; replace (y + h - x) with (h + (y - x));
     [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
   apply Rabs_triang.
-  apply Rplus_lt_reg_r with (- Rabs (x - y)).
+  apply Rplus_lt_reg_l with (- Rabs (x - y)).
   rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
   replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
   replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
@@ -161,7 +265,7 @@ Proof.
   ring.
   ring.
   unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
-    apply Rplus_lt_reg_r with (Rabs (y - x)).
+    apply Rplus_lt_reg_l with (Rabs (y - x)).
   rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
     [ apply H1 | ring ].
 Qed.
@@ -258,3 +362,242 @@ Proof.
       rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
   apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
 Qed.
+
+(* Uniform convergence implies pointwise simple convergence *)
+Lemma CVU_cv : forall f g c d, CVU f g c d ->
+   forall x, Boule c d x -> Un_cv (fun n => f n x) (g x).
+intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn].
+ exists N; intros n nN; rewrite R_dist_sym; apply Pn; assumption.
+Qed.
+
+(* convergence is preserved through extensional equality *)
+Lemma CVU_ext_lim :
+  forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) ->
+    CVU f g2 c d.
+intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn].
+exists N; intros; rewrite <- q; auto.
+Qed.
+
+(* When a sequence of derivable functions converge pointwise towards
+  a function g, with the derivatives converging uniformly towards
+  a function g', then the function g' is the derivative of g. *)
+
+Lemma CVU_derivable :
+  forall f f' g g' c d,
+   CVU f' g' c d ->
+   (forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) ->
+   (forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) ->
+   forall x, Boule c d x -> derivable_pt_lim g x (g' x).
+intros f f' g g' c d cvu cvp dff' x bx.
+set (rho_ :=
+       fun n y =>
+           if Req_EM_T y x then
+              f' n x
+           else ((f n y - f n x)/ (y - x))).
+set (rho := fun y =>
+               if Req_EM_T y x then
+                  g' x
+               else (g y - g x)/(y - x)).
+assert (ctrho : forall n z, Boule c d z -> continuity_pt (rho_ n) z).
+ intros n z bz.
+ destruct (Req_EM_T x z) as [xz | xnz].
+  rewrite <- xz.
+  intros eps' ep'.
+  destruct (dff' n x bx eps' ep') as [alp Pa].
+  exists (pos alp);split;[apply cond_pos | ].
+  intros z'; unfold rho_, D_x, dist, R_met; simpl; intros [[_ xnz'] dxz'].
+   destruct (Req_EM_T z' x) as [abs | _].
+    case xnz'; symmetry; exact abs.
+   destruct (Req_EM_T x x) as [_ | abs];[ | case abs; reflexivity].
+  pattern z' at 1; replace z' with (x + (z' - x)) by ring.
+  apply Pa;[intros h; case xnz';
+    replace z' with (z' - x + x) by ring; rewrite h, Rplus_0_l;
+       reflexivity | exact dxz'].
+ destruct (Ball_in_inter c c d d z bz bz) as [delta Pd].
+ assert (dz :  0 < Rmin delta (Rabs (z - x))).
+  now apply Rmin_glb_lt;[apply cond_pos | apply Rabs_pos_lt; intros zx0; case xnz;
+                       replace z with (z - x + x) by ring; rewrite zx0, Rplus_0_l].
+ assert (t' : forall y : R,
+      R_dist y z < Rmin delta (Rabs (z - x)) ->
+      (fun z : R => (f n z - f n x) / (z - x)) y = rho_ n y).
+  intros y dyz; unfold rho_; destruct (Req_EM_T y x) as [xy | xny].
+   rewrite xy in dyz.
+   destruct (Rle_dec  delta (Rabs (z - x))).
+    rewrite Rmin_left, R_dist_sym in dyz; unfold R_dist in dyz; fourier.
+   rewrite Rmin_right, R_dist_sym in dyz; unfold R_dist in dyz;
+      [case (Rlt_irrefl _ dyz) |apply Rlt_le, Rnot_le_gt; assumption].
+  reflexivity.
+ apply (continuity_pt_locally_ext (fun z => (f n z - f n x)/(z - x))
+             (rho_ n) _ z dz t'); clear t'.
+ apply continuity_pt_div.
+   apply continuity_pt_minus.
+    apply derivable_continuous_pt; eapply exist; apply dff'; assumption.
+   apply continuity_pt_const; intro; intro; reflexivity.
+  apply continuity_pt_minus;
+   [apply derivable_continuous_pt; exists 1; apply derivable_pt_lim_id
+   | apply continuity_pt_const; intro; reflexivity].
+ intros zx0; case xnz; replace z with (z - x + x) by ring.
+ rewrite zx0, Rplus_0_l; reflexivity.
+assert (CVU rho_ rho c d ).
+ intros eps ep.
+ assert (ep8 : 0 < eps/8).
+  fourier.
+ destruct (cvu _ ep8) as [N Pn1].
+ assert (cauchy1 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
+           forall z, Boule c d z -> Rabs (f' n z - f' p z) < eps/4).
+  intros n p nN pN z bz; replace (eps/4) with (eps/8 + eps/8) by field.
+  rewrite <- Rabs_Ropp.
+  replace (-(f' n z - f' p z)) with (g' z - f' n z - (g' z - f' p z)) by ring.
+  apply Rle_lt_trans with (1 := Rabs_triang _ _); rewrite Rabs_Ropp.
+  apply Rplus_lt_compat; apply Pn1; assumption.
+ assert (step_2 : forall n p, (N <= n)%nat -> (N <= p)%nat ->
+         forall y, Boule c d y -> x <> y ->
+         Rabs ((f n y - f n x)/(y - x) - (f p y - f p x)/(y - x)) < eps/4).
+  intros n p nN pN y b_y xny.
+  assert (mm0 : (Rmin x y = x /\ Rmax x y = y) \/ 
+                (Rmin x y = y /\ Rmax x y = x)).
+   destruct (Rle_dec x y) as [H | H].
+    rewrite Rmin_left, Rmax_right.
+      left; split; reflexivity.
+     assumption.
+    assumption.
+   rewrite Rmin_right, Rmax_left.
+     right; split; reflexivity.
+    apply Rlt_le, Rnot_le_gt; assumption.
+   apply Rlt_le, Rnot_le_gt; assumption.
+  assert (mm : Rmin x y < Rmax x y).
+   destruct mm0 as [[q1 q2] | [q1 q2]]; generalize (Rminmax x y); rewrite q1, q2.
+    intros h; destruct h;[ assumption| contradiction].
+   intros h; destruct h as [h | h];[assumption | rewrite h in xny; case xny; reflexivity].
+  assert (dm : forall z, Rmin x y <= z <= Rmax x y ->
+            derivable_pt_lim (fun x => f n x - f p x) z (f' n z - f' p z)).
+   intros z intz; apply derivable_pt_lim_minus.
+    apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
+      destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros;
+     try assumption.
+   apply dff'; apply Boule_convex with (Rmin x y) (Rmax x y);
+      destruct mm0 as [[q1 q2] | [q1 q2]]; revert intz; rewrite ?q1, ?q2; intros;
+     try assumption.
+
+  replace ((f n y - f n x) / (y - x) - (f p y - f p x) / (y - x))
+    with (((f n y - f p y) - (f n x - f p x))/(y - x)) by
+    (field; intros yx0; case xny; replace y with (y - x + x) by ring;
+     rewrite yx0, Rplus_0_l; reflexivity).
+  destruct (MVT_cor2 (fun x => f n x - f p x) (fun x => f' n x - f' p x)
+             (Rmin x y) (Rmax x y) mm dm) as [z [Pz inz]].
+  destruct mm0 as [[q1 q2] | [q1 q2]].
+   replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
+    ((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
+      (Rmax x y - Rmin x y)) by (rewrite q1, q2; reflexivity).
+   unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
+    apply cauchy1; auto.
+    apply Boule_convex with (Rmin x y) (Rmax x y);
+      revert inz; rewrite ?q1, ?q2; intros;
+     try assumption.
+    split; apply Rlt_le; tauto.
+   rewrite q1, q2; apply Rminus_eq_contra, not_eq_sym; assumption.
+  replace ((f n y - f p y - (f n x - f p x))/(y - x)) with
+    ((f n (Rmax x y) - f p (Rmax x y) - (f  n (Rmin x y) - f p (Rmin x y)))/
+      (Rmax x y - Rmin x y)).
+   unfold Rdiv; rewrite Pz, Rmult_assoc, Rinv_r, Rmult_1_r.
+    apply cauchy1; auto.
+    apply Boule_convex with (Rmin x y) (Rmax x y);
+     revert inz; rewrite ?q1, ?q2; intros;
+    try assumption; split; apply Rlt_le; tauto.
+   rewrite q1, q2; apply Rminus_eq_contra; assumption.
+  rewrite q1, q2; field; split; 
+    apply Rminus_eq_contra;[apply not_eq_sym |]; assumption.
+ assert (unif_ac :
+  forall n p, (N <= n)%nat -> (N <= p)%nat ->
+     forall y, Boule c d y ->
+       Rabs (rho_ n y - rho_ p y) <= eps/2).
+  intros n p nN pN y b_y.
+  destruct (Req_dec x y) as [xy | xny].
+   destruct (Ball_in_inter c c d d x bx bx) as [delta Pdelta].
+   destruct (ctrho n y b_y _ ep8) as [d' [dp Pd]].
+   destruct (ctrho p y b_y _ ep8) as [d2 [dp2 Pd2]].
+   assert (mmpos : 0 < (Rmin (Rmin d' d2) delta)/2).
+    apply Rmult_lt_0_compat; repeat apply Rmin_glb_lt; try assumption.
+     apply cond_pos.
+    apply Rinv_0_lt_compat, Rlt_0_2.
+   apply Rle_trans with (1 := R_dist_tri _ _ (rho_ n (y + Rmin (Rmin d' d2) delta/2))).
+   replace (eps/2) with (eps/8 + (eps/4 + eps/8)) by field.
+   apply Rplus_le_compat.
+    rewrite R_dist_sym; apply Rlt_le, Pd;split;[split;[exact I | ] | ].
+      apply Rminus_not_eq_right; rewrite Rplus_comm; unfold Rminus;
+      rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r; apply Rgt_not_eq; assumption.
+    simpl; unfold R_dist.
+    unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
+    rewrite Rabs_pos_eq;[ |apply Rlt_le; assumption ].
+    apply Rlt_le_trans with (Rmin (Rmin d' d2) delta);[fourier | ].
+    apply Rle_trans with (Rmin d' d2); apply Rmin_l.
+   apply Rle_trans with (1 := R_dist_tri _ _ (rho_ p (y + Rmin (Rmin d' d2) delta/2))).
+   apply Rplus_le_compat.
+    apply Rlt_le.
+    replace (rho_ n (y + Rmin (Rmin d' d2) delta / 2)) with
+          ((f n (y + Rmin (Rmin d' d2) delta / 2) - f n x)/
+            ((y + Rmin (Rmin d' d2) delta / 2) - x)).
+     replace (rho_ p (y + Rmin (Rmin d' d2) delta / 2)) with
+          ((f p (y + Rmin (Rmin d' d2) delta / 2) - f p x)/
+             ((y + Rmin (Rmin d' d2) delta / 2) - x)).
+      apply step_2; auto; try fourier.
+      assert (0 < pos delta) by (apply cond_pos).
+      apply Boule_convex with y (y + delta/2).
+        assumption.
+       destruct (Pdelta (y + delta/2)); auto.
+       rewrite xy; unfold Boule; rewrite Rabs_pos_eq; try fourier; auto.
+      split; try fourier.
+      apply Rplus_le_compat_l, Rmult_le_compat_r;[ | apply Rmin_r].
+       now apply Rlt_le, Rinv_0_lt_compat, Rlt_0_2.
+      apply Rminus_not_eq_right; rewrite xy; apply Rgt_not_eq; fourier.
+     unfold rho_.
+     destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta/2) x) as [ymx | ymnx].
+      case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier.
+     reflexivity.
+    unfold rho_.
+    destruct (Req_EM_T (y + Rmin (Rmin d' d2) delta / 2) x) as [ymx | ymnx].
+     case (RIneq.Rle_not_lt _ _ (Req_le _ _ ymx)); fourier.
+    reflexivity.
+   apply Rlt_le, Pd2; split;[split;[exact I | apply Rlt_not_eq; fourier] | ].
+   simpl; unfold R_dist.
+   unfold Rminus; rewrite (Rplus_comm y), Rplus_assoc, Rplus_opp_r, Rplus_0_r.
+   rewrite Rabs_pos_eq;[ | fourier].
+   apply Rlt_le_trans with (Rmin (Rmin d' d2) delta); [fourier |].
+   apply Rle_trans with (Rmin d' d2).
+    solve[apply Rmin_l].
+   solve[apply Rmin_r].
+  apply Rlt_le, Rlt_le_trans with (eps/4);[ | fourier].
+  unfold rho_; destruct (Req_EM_T y x); solve[auto].
+ assert (unif_ac' : forall p, (N <= p)%nat ->
+           forall y, Boule c d y -> Rabs (rho y - rho_ p y) < eps).
+  assert (cvrho : forall y, Boule c d y -> Un_cv (fun n => rho_ n y) (rho y)).
+   intros y b_y; unfold rho_, rho; destruct (Req_EM_T y x).
+    intros eps' ep'; destruct (cvu eps' ep') as [N2 Pn2].
+    exists N2; intros n nN2; rewrite R_dist_sym; apply Pn2; assumption.
+   apply CV_mult.
+    apply CV_minus.
+     apply cvp; assumption.
+    apply cvp; assumption.
+   intros eps' ep'; simpl; exists 0%nat; intros; rewrite R_dist_eq; assumption.
+  intros p pN y b_y.
+  replace eps with (eps/2 + eps/2) by field.
+  assert (ep2 : 0 < eps/2) by fourier.
+  destruct (cvrho y b_y _ ep2) as [N2 Pn2].
+  apply Rle_lt_trans with (1 := R_dist_tri _ _ (rho_ (max N N2) y)).
+  apply Rplus_lt_le_compat.
+   solve[rewrite R_dist_sym; apply Pn2, Max.le_max_r].
+  apply unif_ac; auto; solve [apply Max.le_max_l].
+ exists N; intros; apply unif_ac'; solve[auto].
+intros eps ep.
+destruct (CVU_continuity _ _ _ _ H ctrho x bx eps ep) as [delta [dp Pd]].
+exists (mkposreal _ dp); intros h hn0 dh.
+replace ((g (x + h) - g x) / h) with (rho (x + h)).
+ replace (g' x) with (rho x).
+  apply Pd; unfold D_x, no_cond;split;[split;[solve[auto] | ] | ].
+   intros xxh; case hn0; replace h with (x + h - x) by ring; rewrite <- xxh; ring.
+  simpl; unfold R_dist; replace (x + h - x) with h by ring; exact dh.
+ unfold rho; destruct (Req_EM_T x x) as [ _ | abs];[ | case abs]; reflexivity.
+unfold rho; destruct (Req_EM_T (x + h) x) as [abs | _];[ | ].
+ case hn0; replace h with (x + h - x) by ring; rewrite abs; ring.
+replace (x + h - x) with h by ring; reflexivity.
+Qed.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index 364d72cb..b710c75c 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -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        *)
@@ -180,12 +180,9 @@ Proof.
   replace (S (S (pred N))) with (S N).
   rewrite (HrecN H1); ring.
   rewrite H2; simpl; reflexivity.
-  assert (H2 := O_or_S N).
-  elim H2; intros.
-  elim a; intros.
-  rewrite <- p.
+  destruct (O_or_S N) as [(m,<-)|<-].
   simpl; reflexivity.
-  rewrite <- b in H1; elim (lt_irrefl _ H1).
+  elim (lt_irrefl _ H1).
   rewrite H1; simpl; reflexivity.
   inversion H.
   right; reflexivity.
@@ -395,9 +392,7 @@ Proof.
       (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
   assumption.
   apply H1; assumption.
-  assert (H4 := lt_eq_lt_dec n m).
-  elim H4; intro.
-  elim a; intro.
+  destruct (lt_eq_lt_dec n m) as [[ | -> ]|].
   rewrite (tech2 An n m); [ idtac | assumption ].
   rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
   unfold R_dist.
@@ -418,7 +413,6 @@ Proof.
   apply Rle_ge.
   apply cond_pos_sum.
   intro; apply Rabs_pos.
-  rewrite b.
   unfold R_dist.
   unfold Rminus; do 2 rewrite Rplus_opp_r.
   rewrite Rabs_R0; right; reflexivity.
@@ -451,8 +445,7 @@ Lemma cv_cauchy_1 :
     { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
     Cauchy_crit_series An.
 Proof.
-  intros An X.
-  elim X; intros.
+  intros An (x,p).
   unfold Un_cv in p.
   unfold Cauchy_crit_series; unfold Cauchy_crit.
   intros.
@@ -508,12 +501,11 @@ Lemma sum_incr :
     Un_cv (fun n:nat => sum_f_R0 An n) l ->
     (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
 Proof.
-  intros; case (total_order_T (sum_f_R0 An N) l); intro.
-  elim s; intro.
-  left; apply a.
-  right; apply b.
+  intros; destruct (total_order_T (sum_f_R0 An N) l) as [[Hlt|Heq]|Hgt].
+  left; apply Hlt.
+  right; apply Heq.
   cut (Un_growing (fun n:nat => sum_f_R0 An n)).
-  intro; set (l1 := sum_f_R0 An N) in r.
+  intro; set (l1 := sum_f_R0 An N) in Hgt.
   unfold Un_cv in H; cut (0 < l1 - l).
   intro; elim (H _ H2); intros.
   set (N0 := max x N); cut (N0 >= x)%nat.
@@ -522,21 +514,21 @@ Proof.
   intro; unfold R_dist in H5; rewrite Rabs_right in H5.
   cut (sum_f_R0 An N0 < l1).
   intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
-  apply Rplus_lt_reg_r with (- l).
+  apply Rplus_lt_reg_l with (- l).
   do 2 rewrite (Rplus_comm (- l)).
   apply H5.
   apply Rle_ge; apply Rplus_le_reg_l with l.
   rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
     [ idtac | ring ]; apply Rle_trans with l1.
-  left; apply r.
+  left; apply Hgt.
   apply H6.
   unfold l1; apply Rge_le;
     apply (growing_prop (fun k:nat => sum_f_R0 An k)).
   apply H1.
   unfold ge, N0; apply le_max_r.
   unfold ge, N0; apply le_max_l.
-  apply Rplus_lt_reg_r with l; rewrite Rplus_0_r;
-    replace (l + (l1 - l)) with l1; [ apply r | ring ].
+  apply Rplus_lt_reg_l with l; rewrite Rplus_0_r;
+    replace (l + (l1 - l)) with l1; [ apply Hgt | ring ].
   unfold Un_growing; intro; simpl;
     pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
       apply Rplus_le_compat_l; apply H0.
@@ -549,10 +541,9 @@ Lemma sum_cv_maj :
     Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
     (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
 Proof.
-  intros; case (total_order_T (Rabs l1) l2); intro.
-  elim s; intro.
-  left; apply a.
-  right; apply b.
+  intros; destruct (total_order_T (Rabs l1) l2) as [[Hlt|Heq]|Hgt].
+  left; apply Hlt.
+  right; apply Heq.
   cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
   intro; cut (0 < (Rabs l1 - l2) / 2).
   intro; unfold Un_cv in H, H0.
@@ -568,17 +559,17 @@ Proof.
   intro; assert (H11 := H2 N).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
   apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
-  case (Rcase_abs (Rabs l1 - Rabs (SP fn N x))); intro.
+  destruct (Rcase_abs (Rabs l1 - Rabs (SP fn N x))) as [Hlt|Hge].
   apply Rlt_trans with (Rabs l1).
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
   unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
     rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply r.
+  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply Hgt.
   discrR.
-  apply (Rminus_lt _ _ r0).
-  rewrite (Rabs_right _ r0) in H7.
-  apply Rplus_lt_reg_r with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
+  apply (Rminus_lt _ _ Hlt).
+  rewrite (Rabs_right _ Hge) in H7.
+  apply Rplus_lt_reg_l with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
   replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
   (Rabs l1 - Rabs (SP fn N x)).
   unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
@@ -586,18 +577,18 @@ Proof.
   unfold Rdiv; rewrite Rmult_plus_distr_r;
     rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
       repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1;
-        rewrite double_var; unfold Rdiv; ring.
-  case (Rcase_abs (sum_f_R0 An N - l2)); intro.
+        rewrite double_var; unfold Rdiv in |- *; ring.
+  destruct (Rcase_abs (sum_f_R0 An N - l2)) as [Hlt|Hge].
   apply Rlt_trans with l2.
-  apply (Rminus_lt _ _ r0).
+  apply (Rminus_lt _ _ Hlt).
   apply Rmult_lt_reg_l with 2.
   prove_sup0.
   rewrite (double l2); unfold Rdiv; rewrite (Rmult_comm 2);
     rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
   rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
-    apply r.
+    apply Hgt.
   discrR.
-  rewrite (Rabs_right _ r0) in H6; apply Rplus_lt_reg_r with (- l2).
+  rewrite (Rabs_right _ Hge) in H6; apply Rplus_lt_reg_l with (- l2).
   replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
   rewrite Rplus_comm; apply H6.
   unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
@@ -610,9 +601,9 @@ Proof.
   apply H4; unfold ge, N; apply le_max_l.
   apply H5; unfold ge, N; apply le_max_r.
   unfold Rdiv; apply Rmult_lt_0_compat.
-  apply Rplus_lt_reg_r with l2.
+  apply Rplus_lt_reg_l with l2.
   rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
-    [ apply r | ring ].
+    [ apply Hgt | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
   intros; induction  n0 as [| n0 Hrecn0].
   unfold SP; simpl; apply H1.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index b881250f..8dca0197 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -43,7 +43,7 @@ Hint Immediate Rge_refl: rorders.
 
 Lemma Rlt_irrefl : forall r, ~ r < r.
 Proof.
-  generalize Rlt_asym. intuition eauto.
+  intros r H; eapply Rlt_asym; eauto.
 Qed.
 Hint Resolve Rlt_irrefl: real.
 
@@ -64,7 +64,9 @@ Qed.
 (**********)
 Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2.
 Proof.
-  generalize Rlt_not_eq Rgt_not_eq. intuition eauto.
+  intuition.
+  - apply Rlt_not_eq in H1. eauto.
+  - apply Rgt_not_eq in H1. eauto.
 Qed.
 Hint Resolve Rlt_dichotomy_converse: real.
 
@@ -74,7 +76,7 @@ Hint Resolve Rlt_dichotomy_converse: real.
 Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2.
 Proof.
   intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
-    intuition eauto 3.
+    unfold not; intuition eauto 3.
 Qed.
 Hint Resolve Req_dec: real.
 
@@ -175,7 +177,7 @@ Proof. eauto using Rnot_gt_ge with rorders. Qed.
 Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2.
 Proof.
   generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle.
-  intuition eauto 3.
+  unfold not; intuition eauto 3.
 Qed.
 Hint Immediate Rlt_not_le: real.
 
@@ -407,11 +409,20 @@ Proof.
   rewrite Rplus_assoc; rewrite H; ring.
 Qed.
 
-Hint Resolve (f_equal (A:=R)): real.
+Definition f_equal_R := (f_equal (A:=R)).
+
+Hint Resolve f_equal_R : real.
 
 Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2.
 Proof.
-  auto with real.
+  intros r r1 r2.
+  apply f_equal.
+Qed.
+
+Lemma Rplus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r.
+Proof.
+  intros r r1 r2.
+  apply (f_equal (fun v => v + r)).
 Qed.
 
 (*i Old i*)Hint Resolve Rplus_eq_compat_l: v62.
@@ -427,6 +438,13 @@ Proof.
 Qed.
 Hint Resolve Rplus_eq_reg_l: real.
 
+Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r = r2 + r -> r1 = r2.
+Proof.
+  intros r r1 r2 H.
+  apply Rplus_eq_reg_l with r.
+  now rewrite 2!(Rplus_comm r).
+Qed.
+
 (**********)
 Lemma Rplus_0_r_uniq : forall r r1, r + r1 = r -> r1 = 0.
 Proof.
@@ -664,6 +682,11 @@ Hint Resolve Ropp_plus_distr: real.
 (** ** Opposite and multiplication                       *)
 (*********************************************************)
 
+Lemma Ropp_mult_distr_l : forall r1 r2, - (r1 * r2) = - r1 * r2.
+Proof.
+  intros; ring.
+Qed.
+
 Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2).
 Proof.
   intros; ring.
@@ -677,13 +700,18 @@ Proof.
 Qed.
 Hint Resolve Rmult_opp_opp: real.
 
+Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) = r1 * - r2.
+Proof.
+  intros; ring.
+Qed.
+
 Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 = - (r1 * r2).
 Proof.
   intros; ring.
 Qed.
 
 (*********************************************************)
-(** ** Substraction                                      *)
+(** ** Subtraction                                      *)
 (*********************************************************)
 
 Lemma Rminus_0_r : forall r, r - 0 = r.
@@ -794,7 +822,7 @@ Hint Resolve Rinv_involutive: real.
 Lemma Rinv_mult_distr :
   forall r1 r2, r1 <> 0 -> r2 <> 0 -> / (r1 * r2) = / r1 * / r2.
 Proof.
-  intros; field; auto.
+  intros; field; auto.  
 Qed.
 
 (*********)
@@ -969,7 +997,7 @@ Qed.
 
 (** *** Cancellation *)
 
-Lemma Rplus_lt_reg_r : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
+Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2.
 Proof.
   intros; cut (- r + r + r1 < - r + r + r2).
   rewrite Rplus_opp_l.
@@ -979,10 +1007,17 @@ Proof.
     apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H).
 Qed.
 
+Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2.
+Proof.
+  intros.
+  apply (Rplus_lt_reg_l r).
+  now rewrite 2!(Rplus_comm r).
+Qed.
+
 Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2.
 Proof.
   unfold Rle; intros; elim H; intro.
-  left; apply (Rplus_lt_reg_r r r1 r2 H0).
+  left; apply (Rplus_lt_reg_l r r1 r2 H0).
   right; apply (Rplus_eq_reg_l r r1 r2 H0).
 Qed.
 
@@ -995,7 +1030,7 @@ Qed.
 
 Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2.
 Proof.
-  unfold Rgt; intros; apply (Rplus_lt_reg_r r r2 r1 H).
+  unfold Rgt; intros; apply (Rplus_lt_reg_l r r2 r1 H).
 Qed.
 
 Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2.
@@ -1047,12 +1082,10 @@ Qed.
 Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2.
 Proof.
   unfold Rgt; intros.
-  apply (Rplus_lt_reg_r (r2 + r1)).
-  replace (r2 + r1 + - r1) with r2.
-  replace (r2 + r1 + - r2) with r1.
-  trivial.
-  ring.
-  ring.
+  apply (Rplus_lt_reg_l (r2 + r1)).
+  replace (r2 + r1 + - r1) with r2 by ring.
+  replace (r2 + r1 + - r2) with r1 by ring.
+  exact H.
 Qed.
 Hint Resolve Ropp_gt_lt_contravar.
 
@@ -1324,19 +1357,22 @@ Qed.
 
 Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0.
 Proof.
-  intros; apply (Rplus_lt_reg_r r2).
-  replace (r2 + (r1 - r2)) with r1.
-  replace (r2 + 0) with r2; auto with real.
-  ring.
+  intros; apply (Rplus_lt_reg_l r2).
+  replace (r2 + (r1 - r2)) with r1 by ring.
+  now rewrite Rplus_0_r.
 Qed.
 Hint Resolve Rlt_minus: real.
 
 Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0.
 Proof.
-  intros; apply (Rplus_lt_reg_r r2).
-  replace (r2 + (r1 - r2)) with r1.
-  replace (r2 + 0) with r2; auto with real.
-  ring.
+  intros; apply (Rplus_lt_reg_l r2).
+  replace (r2 + (r1 - r2)) with r1 by ring.
+  now rewrite Rplus_0_r.
+Qed.
+
+Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a.
+Proof.
+  intros a b; apply Rgt_minus.
 Qed.
 
 (**********)
@@ -1368,6 +1404,9 @@ Proof.
   ring.
 Qed.
 
+Lemma Rminus_gt_0_lt : forall a b, 0 < b - a -> a < b.
+Proof. intro; intro; apply Rminus_gt. Qed.
+
 (**********)
 Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2.
 Proof.
@@ -1625,7 +1664,7 @@ Proof.
     apply (Rlt_irrefl 0); auto.
   do 2 rewrite S_INR in H1; cut (INR n1 < INR n0).
   intro H2; generalize (H0 n0 H2); intro; auto with arith.
-  apply (Rplus_lt_reg_r 1 (INR n1) (INR n0)).
+  apply (Rplus_lt_reg_l 1 (INR n1) (INR n0)).
   rewrite Rplus_comm; rewrite (Rplus_comm 1 (INR n0)); trivial.
 Qed.
 Hint Resolve INR_lt: real.
@@ -1931,18 +1970,26 @@ Proof.
     apply (Rmult_le_compat_l x 0 y H H0).
 Qed.
 
+Lemma Rinv_le_contravar :
+  forall x y, 0 < x -> x <= y -> / y <= / x.
+Proof.
+  intros x y H1 [H2|H2].
+  apply Rlt_le.
+  apply Rinv_lt_contravar with (2 := H2).
+  apply Rmult_lt_0_compat with (1 := H1).
+  now apply Rlt_trans with x.
+  rewrite H2.
+  apply Rle_refl.
+Qed.
+
 Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x.
 Proof.
-  intros; apply Rmult_le_reg_l with x.
-  apply H.
-  rewrite <- Rinv_r_sym.
-  apply Rmult_le_reg_l with y.
-  apply H0.
-  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
-    rewrite <- Rinv_l_sym.
-  rewrite Rmult_1_r; apply H1.
-  red; intro; rewrite H2 in H0; elim (Rlt_irrefl _ H0).
-  red; intro; rewrite H2 in H; elim (Rlt_irrefl _ H).
+  intros x y H _.
+  apply Rinv_le_contravar with (1 := H).
+Qed.
+
+Lemma Ropp_div : forall x y, -x/y = - (x / y).
+intros x y; unfold Rdiv; ring.
 Qed.
 
 Lemma double : forall r1, 2 * r1 = r1 + r1.
@@ -2018,6 +2065,29 @@ Proof.
   intros; elim (completeness E H H0); intros; split with x; assumption.
 Qed.
 
+Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b.
+Proof. 
+intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption.
+Qed.
+
+Lemma Rdiv_plus_distr : forall a b c, (a + b)/c = a/c + b/c.
+intros a b c; apply Rmult_plus_distr_r.
+Qed.
+
+Lemma Rdiv_minus_distr : forall a b c, (a - b)/c = a/c - b/c.
+intros a b c; unfold Rminus, Rdiv; rewrite Rmult_plus_distr_r; ring.
+Qed.
+
+(* A test for equality function. *)
+Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
+Proof.
+  intros; destruct (total_order_T r1 r2) as [[H|]|H].
+  - right; red; intros ->; elim (Rlt_irrefl r2 H).
+  - left; assumption.
+  - right; red; intros ->; elim (Rlt_irrefl r2 H).
+Qed.
+
+
 (*********************************************************)
 (** * Definitions of new types                           *)
 (*********************************************************)
@@ -2035,6 +2105,7 @@ Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}.
 Record nonzeroreal : Type := mknonzeroreal
   {nonzero :> R; cond_nonzero : nonzero <> 0}.
 
+
 (** Compatibility *)
 
 Notation prod_neq_R0 := Rmult_integral_contrapositive_currified (only parsing).
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index ad3002b4..abf8a99d 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.v
@@ -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        *)
@@ -181,13 +181,13 @@ Proof.
   elim Hrecl; intros; assert (H3 := H1 H0); elim H3; intros; elim H4; intros;
     exists (S x0); split;
       [ simpl; apply lt_n_S; assumption | simpl; assumption ].
-  elim H; intros; elim H0; intros; elim (zerop x0); intro.
-  rewrite a in H2; simpl in H2; left; assumption.
-  right; elim Hrecl; intros; apply H4; assert (H5 : S (pred x0) = x0).
+  elim H; intros; elim H0; intros; destruct (zerop x0) as [->|].
+  simpl in H2; left; assumption.
+  right; elim Hrecl; intros H4 H5; apply H5; assert (H6 : S (pred x0) = x0).
   symmetry ; apply S_pred with 0%nat; assumption.
   exists (pred x0); split;
-    [ simpl in H1; apply lt_S_n; rewrite H5; assumption
-      | rewrite <- H5 in H2; simpl in H2; assumption ].
+    [ simpl in H1; apply lt_S_n; rewrite H6; assumption
+      | rewrite <- H6 in H2; simpl in H2; assumption ].
 Qed.
 
 Lemma Rlist_P1 :
@@ -208,11 +208,11 @@ Proof.
   assert (H3 := Hrecl H2); elim H1; intros; elim H3; intros; exists (cons x x0);
     intros; elim H5; clear H5; intros; split.
   simpl; rewrite H5; reflexivity.
-  intros; elim (zerop i); intro.
-  rewrite a; simpl; assumption.
-  assert (H8 : i = S (pred i)).
+  intros; destruct (zerop i) as [->|].
+  simpl; assumption.
+  assert (H9 : i = S (pred i)).
   apply S_pred with 0%nat; assumption.
-  rewrite H8; simpl; apply H6; simpl in H7; apply lt_S_n; rewrite <- H8;
+  rewrite H9; simpl; apply H6; simpl in H7; apply lt_S_n; rewrite <- H9;
     assumption.
 Qed.
 
diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v
index 1e92edd6..0531bd0a 100644
--- a/theories/Reals/ROrderedType.v
+++ b/theories/Reals/ROrderedType.v
@@ -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        *)
@@ -15,7 +15,7 @@ Local Open Scope R_scope.
 Lemma Req_dec : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
 Proof.
   intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse;
-    intuition eauto 3.
+    intuition eauto.
 Qed.
 
 Definition Reqb r1 r2 := if Req_dec r1 r2 then true else false.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index 4f4293f3..57ee1d9a 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -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/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index 5900a147..f1e2d6fa 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -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        *)
@@ -97,7 +97,7 @@ Qed.
 Lemma Rsqr_incr_0 :
   forall x y:R, Rsqr x <= Rsqr y -> 0 <= x -> 0 <= y -> x <= y.
 Proof.
-  intros; case (Rle_dec x y); intro;
+  intros; destruct (Rle_dec x y) as [Hle|Hnle];
     [ assumption
       | cut (y < x);
         [ intro; unfold Rsqr in H;
@@ -109,7 +109,7 @@ Qed.
 
 Lemma Rsqr_incr_0_var : forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> x <= y.
 Proof.
-  intros; case (Rle_dec x y); intro;
+  intros; destruct (Rle_dec x y) as [Hle|Hnle];
     [ assumption
       | cut (y < x);
         [ intro; unfold Rsqr in H;
@@ -146,8 +146,8 @@ Qed.
 Lemma Rsqr_neg_pos_le_0 :
   forall x y:R, Rsqr x <= Rsqr y -> 0 <= y -> - y <= x.
 Proof.
-  intros; case (Rcase_abs x); intro.
-  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
+  intros; destruct (Rcase_abs x) as [Hlt|Hle].
+  generalize (Ropp_lt_gt_contravar x 0 Hlt); rewrite Ropp_0; intro;
     generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H;
       generalize (Rsqr_incr_0 (- x) y H H2 H0); intro;
         rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar;
@@ -160,25 +160,23 @@ Qed.
 Lemma Rsqr_neg_pos_le_1 :
   forall x y:R, - y <= x -> x <= y -> 0 <= y -> Rsqr x <= Rsqr y.
 Proof.
-  intros; case (Rcase_abs x); intro.
-  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
-    generalize (Rlt_le 0 (- x) H2); intro;
-      generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
-        intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x);
-          apply Rsqr_incr_1; assumption.
-  generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption.
+  intros x y H H0 H1; destruct (Rcase_abs x) as [Hlt|Hle].
+  apply Ropp_lt_gt_contravar, Rlt_le in Hlt; rewrite Ropp_0 in Hlt;
+  apply Ropp_le_ge_contravar, Rge_le in H; rewrite Ropp_involutive in H;
+  rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
+  apply Rge_le in Hle; apply Rsqr_incr_1; assumption.
 Qed.
 
 Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y.
 Proof.
-  intros; case (Rcase_abs x); intro.
-  generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro;
-    generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive;
-      intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1);
-        intro; generalize (Rle_trans 0 (- x) y H4 H3); intro;
-          rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
-  generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro;
-    apply Rsqr_incr_1; assumption.
+  intros x y H H0; destruct (Rcase_abs x) as [Hlt|Hle].
+  apply Ropp_lt_gt_contravar, Rlt_le in Hlt; rewrite Ropp_0 in Hlt;
+  apply Ropp_le_ge_contravar, Rge_le in H; rewrite Ropp_involutive in H.
+  assert (0 <= y) by (apply Rle_trans with (-x); assumption).
+  rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption.
+  apply Rge_le in Hle;
+  assert (0 <= y) by (apply Rle_trans with x; assumption).
+  apply Rsqr_incr_1; assumption.
 Qed.
 
 Lemma Rsqr_abs : forall x:R, Rsqr x = Rsqr (Rabs x).
@@ -220,22 +218,22 @@ Qed.
 
 Lemma Rsqr_eq_abs_0 : forall x y:R, Rsqr x = Rsqr y -> Rabs x = Rabs y.
 Proof.
-  intros; unfold Rabs; case (Rcase_abs x); case (Rcase_abs y); intros.
-  rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H;
-    generalize (Ropp_lt_gt_contravar y 0 r);
-      generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
+  intros; unfold Rabs; case (Rcase_abs x) as [Hltx|Hgex];
+    case (Rcase_abs y) as [Hlty|Hgey].
+  rewrite (Rsqr_neg x), (Rsqr_neg y) in H;
+    generalize (Ropp_lt_gt_contravar y 0 Hlty);
+      generalize (Ropp_lt_gt_contravar x 0 Hltx); rewrite Ropp_0;
         intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1);
           intros; apply Rsqr_inj; assumption.
-  rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro;
-    generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0;
+  rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 Hgey); intro;
+    generalize (Ropp_lt_gt_contravar x 0 Hltx); rewrite Ropp_0;
       intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj;
         assumption.
-  rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro;
-    generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0;
+  rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 Hgex); intro;
+    generalize (Ropp_lt_gt_contravar y 0 Hlty); rewrite Ropp_0;
       intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj;
         assumption.
-  generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj;
-    assumption.
+  apply Rsqr_inj; auto using Rge_le.
 Qed.
 
 Lemma Rsqr_eq_asb_1 : forall x y:R, Rabs x = Rabs y -> Rsqr x = Rsqr y.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index 38a38400..20319a2b 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -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        *)
@@ -37,8 +37,8 @@ Lemma sqrt_sqrt : forall x:R, 0 <= x -> sqrt x * sqrt x = x.
 Proof.
   intros.
   unfold sqrt.
-  case (Rcase_abs x); intro.
-  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ r H)).
+  case (Rcase_abs x) as [Hlt|Hge].
+  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ Hlt H)).
   rewrite Rsqrt_Rsqrt; reflexivity.
 Qed.
 
@@ -94,6 +94,10 @@ Proof.
   intros; unfold Rsqr; apply sqrt_square; assumption.
 Qed.
 
+Lemma sqrt_pow2 : forall x, 0 <= x -> sqrt (x ^ 2) = x.
+intros; simpl; rewrite Rmult_1_r, sqrt_square; auto.
+Qed.
+
 Lemma sqrt_Rsqr_abs : forall x:R, sqrt (Rsqr x) = Rabs x.
 Proof.
   intro x; rewrite Rsqr_abs; apply sqrt_Rsqr; apply Rabs_pos.
@@ -517,3 +521,4 @@ Proof.
   reflexivity.
   reflexivity.
 Qed.
+
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index d656817e..3cda675a 100644
--- a/theories/Reals/Ranalysis.v
+++ b/theories/Reals/Ranalysis.v
@@ -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/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 2f39c00b..875eebbb 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -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        *)
@@ -77,6 +77,23 @@ Definition continuity f : Prop := forall x:R, continuity_pt f x.
 Arguments continuity_pt f%F x0%R.
 Arguments continuity f%F.
 
+Lemma continuity_pt_locally_ext :
+  forall f g a x, 0 < a -> (forall y, R_dist y x < a -> f y = g y) ->
+  continuity_pt f x -> continuity_pt g x.
+intros f g a x a0 q cf eps ep.
+destruct (cf eps ep) as [a' [a'p Pa']].
+exists (Rmin a a'); split.
+ unfold Rmin; destruct (Rle_dec a a').
+  assumption.
+ assumption.
+intros y cy; rewrite <- !q.
+  apply Pa'.
+  split;[| apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_r]];tauto.
+ rewrite R_dist_eq; assumption.   
+apply Rlt_le_trans with (Rmin a a');[ | apply Rmin_l]; tauto.
+Qed.
+
+
 (**********)
 Lemma continuity_pt_plus :
   forall f1 f2 (x0:R),
@@ -477,6 +494,47 @@ Proof.
   auto with real.
 Qed.
 
+(* Extensionally equal functions have the same derivative. *)
+
+Lemma derivable_pt_lim_ext : forall f g x l, (forall z, f z = g z) -> 
+  derivable_pt_lim f x l -> derivable_pt_lim g x l.
+intros f g x l fg df e ep; destruct (df e ep) as [d pd]; exists d; intros h;
+rewrite <- !fg; apply pd.
+Qed.
+
+(* extensionally equal functions have the same derivative, locally. *)
+
+Lemma derivable_pt_lim_locally_ext : forall f g x a b l, 
+  a < x < b ->
+  (forall z, a < z < b -> f z = g z) ->
+  derivable_pt_lim f x l -> derivable_pt_lim g x l.
+intros f g x a b l axb fg df e ep.
+destruct (df e ep) as [d pd].
+assert (d'h : 0 < Rmin d (Rmin (b - x) (x - a))).
+ apply Rmin_pos;[apply cond_pos | apply Rmin_pos; apply Rlt_Rminus; tauto].
+exists (mkposreal _ d'h); simpl; intros h hn0 cmp.
+rewrite <- !fg;[ |assumption | ].
+  apply pd;[assumption |].
+ apply Rlt_le_trans with (1 := cmp), Rmin_l.
+assert (-h < x - a).
+ apply Rle_lt_trans with (1 := Rle_abs _).
+ rewrite Rabs_Ropp; apply Rlt_le_trans with (1 := cmp).
+ rewrite Rmin_assoc; apply Rmin_r.
+assert (h < b - x).
+ apply Rle_lt_trans with (1 := Rle_abs _).
+ apply Rlt_le_trans with (1 := cmp).
+ rewrite Rmin_comm, <- Rmin_assoc; apply Rmin_l.
+split.
+ apply (Rplus_lt_reg_l (- h)).
+ replace ((-h) + (x + h)) with x by ring.
+ apply (Rplus_lt_reg_r (- a)).
+ replace (((-h) + a) + - a) with (-h) by ring.
+ assumption.
+apply (Rplus_lt_reg_r (- x)).
+replace (x + h + - x) with h by ring.
+assumption.
+Qed.
+
 
 (***********************************)
 (** * derivability -> continuity   *)
@@ -639,6 +697,24 @@ Proof.
   unfold mult_real_fct, mult_fct, fct_cte; reflexivity.
 Qed.
 
+Lemma derivable_pt_lim_div_scal :
+  forall f x l a, derivable_pt_lim f x l ->
+     derivable_pt_lim (fun y => f y / a) x (l / a).
+intros f x l a df;
+  apply (derivable_pt_lim_ext (fun y => /a * f y)).
+ intros z; rewrite Rmult_comm; reflexivity.
+unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption.
+Qed.
+
+Lemma derivable_pt_lim_scal_right :
+  forall f x l a, derivable_pt_lim f x l ->
+     derivable_pt_lim (fun y => f y * a) x (l * a).
+intros f x l a df;
+  apply (derivable_pt_lim_ext (fun y => a * f y)).
+ intros z; rewrite Rmult_comm; reflexivity.
+unfold Rdiv; rewrite Rmult_comm; apply derivable_pt_lim_scal; assumption.
+Qed.
+
 Lemma derivable_pt_lim_id : forall x:R, derivable_pt_lim id x 1.
 Proof.
   intro; unfold derivable_pt_lim.
@@ -1066,15 +1142,8 @@ Lemma pr_nu :
   forall f (x:R) (pr1 pr2:derivable_pt f x),
     derive_pt f x pr1 = derive_pt f x pr2.
 Proof.
-  intros.
-  unfold derivable_pt in pr1.
-  unfold derivable_pt in pr2.
-  elim pr1; intros.
-  elim pr2; intros.
-  unfold derivable_pt_abs in p.
-  unfold derivable_pt_abs in p0.
-  simpl.
-  apply (uniqueness_limite f x x0 x1 p p0).
+  intros f x (x0,H0) (x1,H1).
+  apply (uniqueness_limite f x x0 x1 H0 H1).
 Qed.
 
 
@@ -1123,7 +1192,7 @@ Proof.
     case
     (Rcase_abs
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-        Rmin (delta / 2) ((b + - c) / 2) + - l)); intro.
+        Rmin (delta / 2) ((b + - c) / 2) + - l)) as [Hlt|Hge].
   replace
   (-
     ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
@@ -1165,7 +1234,7 @@ Proof.
     (H20 :=
       Rge_le
       ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) /
-        Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r).
+        Rmin (delta / 2) ((b + - c) / 2) + - l) 0 Hge).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)).
   assumption.
   rewrite <- Ropp_0;
@@ -1242,17 +1311,16 @@ Proof.
         (mkposreal ((b - c) / 2) H8)).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-  unfold Rabs; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))).
-  intro.
+  unfold Rabs; case (Rcase_abs (Rmin (delta / 2) ((b - c) / 2))) as [Hlt|Hge].
   cut (0 < delta / 2).
   intro.
   generalize
     (Rmin_stable_in_posreal (mkposreal (delta / 2) H10)
       (mkposreal ((b - c) / 2) H8)); simpl; intro;
-    elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 r)).
+    elim (Rlt_irrefl 0 (Rlt_trans 0 (Rmin (delta / 2) ((b - c) / 2)) 0 H11 Hlt)).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
-  intro; apply Rle_lt_trans with (delta / 2).
+  apply Rle_lt_trans with (delta / 2).
   apply Rmin_l.
   unfold Rdiv; apply Rmult_lt_reg_l with 2.
   prove_sup0.
@@ -1311,13 +1379,12 @@ Proof.
     case
     (Rcase_abs
       ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-        Rmax (- (delta / 2)) ((a + - c) / 2) + - l)).
-  intro;
-    elim
+        Rmax (- (delta / 2)) ((a + - c) / 2) + - l)) as [Hlt|Hge].
+  elim
       (Rlt_irrefl 0
         (Rlt_trans 0
           ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) /
-            Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 r)).
+            Rmax (- (delta / 2)) ((a + - c) / 2) + - l) 0 H19 Hlt)).
   intros;
     generalize
       (Rplus_lt_compat_r l
@@ -1380,8 +1447,8 @@ Proof.
   apply Rplus_lt_compat_l; assumption.
   field; discrR.
   assumption.
-  unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))).
-  intro; generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
+  unfold Rabs; case (Rcase_abs (Rmax (- (delta / 2)) ((a - c) / 2))) as [Hlt|Hge].
+  generalize (RmaxLess1 (- (delta / 2)) ((a - c) / 2)); intro;
     generalize
       (Ropp_le_ge_contravar (- (delta / 2)) (Rmax (- (delta / 2)) ((a - c) / 2))
         H12); rewrite Ropp_involutive; intro;
@@ -1402,7 +1469,7 @@ Proof.
     generalize
       (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13)
         (mknegreal ((a - c) / 2) H12)); simpl;
-      intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r);
+      intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 Hge);
         intro;
           elim
             (Rlt_irrefl 0
@@ -1494,11 +1561,10 @@ Proof.
     cut (0 <= (f (x + delta / 2) - f x) / (delta / 2)).
   intro; cut (0 <= (f (x + delta / 2) - f x) / (delta / 2) - l).
   intro; unfold Rabs;
-    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)).
-  intro;
-    elim
+    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge].
+  elim
       (Rlt_irrefl 0
-        (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 r)).
+        (Rle_lt_trans 0 ((f (x + delta / 2) - f x) / (delta / 2) - l) 0 H12 Hlt)).
   intros;
     generalize
       (Rplus_lt_compat_r l ((f (x + delta / 2) - f x) / (delta / 2) - l)
@@ -1555,7 +1621,7 @@ Proof.
       [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
   unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse;
     apply Rmult_lt_0_compat.
-  apply Rplus_lt_reg_r with l.
+  apply Rplus_lt_reg_l with l.
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rplus_0_r; assumption.
   apply Rinv_0_lt_compat; prove_sup0.
 Qed.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index b070cdaa..eb646913 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -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        *)
@@ -9,6 +9,7 @@
 Require Import Rbase.
 Require Import Rfunctions.
 Require Import Ranalysis1.
+Require Import Omega.
 Local Open Scope R_scope.
 
 (**********)
@@ -432,17 +433,17 @@ Proof.
   unfold IZR; unfold INR, Pos.to_nat; simpl; intro;
     elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
   apply IZR_lt; omega.
-  unfold Rabs; case (Rcase_abs (/ 2)); intro.
+  unfold Rabs; case (Rcase_abs (/ 2)) as [Hlt|Hge].
   assert (Hyp : 0 < 2).
   prove_sup0.
-  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
+  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp Hlt); rewrite Rmult_0_r in H11;
     rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
   elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
   reflexivity.
   apply (Rabs_pos_lt _ H0).
   ring.
   assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
-  intro; rewrite <- H7; unfold dist, R_met; unfold R_dist;
+  intro; rewrite <- H7. unfold R_met, dist; unfold R_dist;
     unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
       apply Rabs_pos_lt.
   unfold Rdiv; apply prod_neq_R0;
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index 614f12bd..407f6410 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -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        *)
@@ -731,7 +731,7 @@ Proof.
   rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
   rewrite Ropp_minus_distr in H6.
   assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
-  apply Rplus_lt_reg_r with (- Rabs (f2 a) + Rabs (f2 x) / 2).
+  apply Rplus_lt_reg_l with (- Rabs (f2 a) + Rabs (f2 x) / 2).
   rewrite Rplus_assoc.
   rewrite <- double_var.
   do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index 2fa17e20..ae2013f0 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -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        *)
@@ -13,6 +13,7 @@ Require Import Rtrigo1.
 Require Import Ranalysis1.
 Require Import Ranalysis3.
 Require Import Exp_prop.
+Require Import MVT.
 Local Open Scope R_scope.
 
 (**********)
@@ -26,7 +27,7 @@ Proof.
   apply derivable_pt_const.
   assumption.
   assumption.
-  unfold div_fct, inv_fct, fct_cte; intro X0; elim X0; intros;
+  unfold div_fct, inv_fct, fct_cte; intros (x0,p);
     unfold derivable_pt; exists x0;
       unfold derivable_pt_abs; unfold derivable_pt_lim;
         unfold derivable_pt_abs in p; unfold derivable_pt_lim in p;
@@ -41,11 +42,7 @@ Lemma pr_nu_var :
   forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
     f = g -> derive_pt f x pr1 = derive_pt g x pr2.
 Proof.
-  unfold derivable_pt, derive_pt; intros.
-  elim pr1; intros.
-  elim pr2; intros.
-  simpl.
-  rewrite H in p.
+  unfold derivable_pt, derive_pt; intros f g x (x0,p0) (x1,p1) ->.
   apply uniqueness_limite with g x; assumption.
 Qed.
 
@@ -54,14 +51,11 @@ Lemma pr_nu_var2 :
   forall (f g:R -> R) (x:R) (pr1:derivable_pt f x) (pr2:derivable_pt g x),
     (forall h:R, f h = g h) -> derive_pt f x pr1 = derive_pt g x pr2.
 Proof.
-  unfold derivable_pt, derive_pt; intros.
-  elim pr1; intros.
-  elim pr2; intros.
-  simpl.
-  assert (H0 := uniqueness_step2 _ _ _ p).
-  assert (H1 := uniqueness_step2 _ _ _ p0).
+  unfold derivable_pt, derive_pt; intros f g x (x0,p0) (x1,p1) H.
+  assert (H0 := uniqueness_step2 _ _ _ p0).
+  assert (H1 := uniqueness_step2 _ _ _ p1).
   cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0).
-  intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2).
+  intro H2; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2).
   assumption.
   unfold limit1_in; unfold limit_in; unfold dist;
     simpl; unfold R_dist; unfold limit1_in in H1;
@@ -117,14 +111,14 @@ Proof.
   rewrite Rplus_opp_r; rewrite Rabs_R0; apply H0.
   apply H1.
   apply Rle_ge.
-  case (Rcase_abs h); intro.
-  rewrite (Rabs_left h r) in H2.
-  left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r;
+  destruct (Rcase_abs h) as [Hlt|Hgt].
+  rewrite (Rabs_left h Hlt) in H2.
+  left; rewrite Rplus_comm; apply Rplus_lt_reg_l with (- h); rewrite Rplus_0_r;
     rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l;
       apply H2.
   apply Rplus_le_le_0_compat.
   left; apply H.
-  apply Rge_le; apply r.
+  apply Rge_le; apply Hgt.
   left; apply H.
 Qed.
 
@@ -145,13 +139,13 @@ Proof.
   rewrite <- Rinv_r_sym.
   rewrite Ropp_involutive; rewrite Rplus_opp_l; rewrite Rabs_R0; apply H0.
   apply H2.
-  case (Rcase_abs h); intro.
+  destruct (Rcase_abs h) as [Hlt|Hgt].
   apply Ropp_lt_cancel.
   rewrite Ropp_0; rewrite Ropp_plus_distr; apply Rplus_lt_0_compat.
   apply H1.
-  apply Ropp_0_gt_lt_contravar; apply r.
-  rewrite (Rabs_right h r) in H3.
-  apply Rplus_lt_reg_r with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc;
+  apply Ropp_0_gt_lt_contravar; apply Hlt.
+  rewrite (Rabs_right h Hgt) in H3.
+  apply Rplus_lt_reg_l with (- x); rewrite Rplus_0_r; rewrite <- Rplus_assoc;
     rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H3.
   apply H.
   apply Ropp_0_gt_lt_contravar; apply H.
@@ -161,13 +155,12 @@ Qed.
 Lemma Rderivable_pt_abs : forall x:R, x <> 0 -> derivable_pt Rabs x.
 Proof.
   intros.
-  case (total_order_T x 0); intro.
-  elim s; intro.
+  destruct (total_order_T x 0) as [[Hlt|Heq]|Hgt].
   unfold derivable_pt; exists (-1).
-  apply (Rabs_derive_2 x a).
-  elim H; exact b.
+  apply (Rabs_derive_2 x Hlt).
+  elim H; exact Heq.
   unfold derivable_pt; exists 1.
-  apply (Rabs_derive_1 x r).
+  apply (Rabs_derive_1 x Hgt).
 Qed.
 
 (** Rabsolu is continuous for all x *)
@@ -406,3 +399,14 @@ Proof.
   intro; apply derive_pt_eq_0.
   apply derivable_pt_lim_sinh.
 Qed.
+
+Lemma sinh_lt : forall x y, x < y -> sinh x < sinh y.
+intros x y xy; destruct (MVT_cor2 sinh cosh x y xy) as [c [Pc _]].
+ intros; apply derivable_pt_lim_sinh.
+apply Rplus_lt_reg_l with (Ropp (sinh x)); rewrite Rplus_opp_l, Rplus_comm.
+unfold Rminus at 1 in Pc; rewrite Pc; apply Rmult_lt_0_compat;[ | ].
+ unfold cosh; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat, Rlt_0_2].
+ now apply Rplus_lt_0_compat; apply exp_pos.
+now apply Rlt_Rminus; assumption.
+Qed.
+
diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v
index 5c3b03fa..27615c59 100644
--- a/theories/Reals/Ranalysis5.v
+++ b/theories/Reals/Ranalysis5.v
@@ -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        *)
@@ -14,6 +14,7 @@ Require Import Fourier.
 Require Import RiemannInt.
 Require Import SeqProp.
 Require Import Max.
+Require Import Omega.
 Local Open Scope R_scope.
 
 (** * Preliminaries lemmas *)
@@ -164,8 +165,8 @@ assert (forall x l, lb < x < ub -> (derivable_pt_abs f x l <-> derivable_pt_abs
  apply Rlt_le_trans with (r2:=Rmin delta (Rmin (ub - a) (a - lb))) ; [| apply Rmin_r] ; assumption.
  unfold derivable_pt in Prf.
   unfold derivable_pt in Prg.
-  elim Prf; intros.
-  elim Prg; intros.
+  elim Prf; intros x0 p.
+  elim Prg; intros x1 p0.
   assert (Temp := p); rewrite H in Temp.
   unfold derivable_pt_abs in p.
   unfold derivable_pt_abs in p0.
@@ -294,8 +295,8 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). 
   generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). 
   intros X X0.
-  elim X; intros.
-  elim X0; intros.
+  elim X; intros x0 p.
+  elim X0; intros x1 p0.
   assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
   rewrite H4 in p0.
   exists x0.
@@ -337,14 +338,14 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   left; assumption.
   intro.
   unfold cond_positivity in |- *.
-  case (Rle_dec 0 z); intro.
+  destruct (Rle_dec 0 z) as [|Hnotle].
   split.
   intro; assumption.
   intro; reflexivity.
   split.
   intro feqt;discriminate feqt.
   intro.
-  elim n0; assumption.
+  elim Hnotle; assumption.
   unfold Vn in |- *.
   cut (forall z:R, cond_positivity z = false <-> z < 0).
   intros.
@@ -358,10 +359,10 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   assumption.
   intro.
   unfold cond_positivity in |- *.
-  case (Rle_dec 0 z); intro.
+  destruct (Rle_dec 0 z) as [Hle|].
   split.
   intro feqt; discriminate feqt.
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)).
   split.
   intro; auto with real.
   intro; reflexivity.
@@ -370,10 +371,9 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   assert (Temp : x <= x0 <= y).
    apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
   assert (H7 := continuity_seq f Wn x0 (H x0 Temp) H5).
-  case (total_order_T 0 (f x0)); intro.
-  elim s; intro.
+  destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
   left; assumption.
-  rewrite <- b; right; reflexivity.
+  right; reflexivity.
   unfold Un_cv in H7; unfold R_dist in H7.
   cut (0 < - f x0).
   intro.
@@ -383,7 +383,7 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   rewrite Rabs_right in H11.
   pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
   unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
-  assert (H12 := Rplus_lt_reg_r _ _ _ H11).
+  assert (H12 := Rplus_lt_reg_l _ _ _ H11).
   assert (H13 := H6 x2).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
   apply Rle_ge; left; unfold Rminus in |- *; apply Rplus_le_lt_0_compat.
@@ -396,29 +396,28 @@ intros. (* f x y f_cont_interv x_lt_y fx_neg fy_pos.*)
   assert (Temp : x <= x0 <= y).
    apply IVT_interv_prelim1 with (D:=(fun z : R => cond_positivity (f z))) ; assumption.
   assert (H7 := continuity_seq f Vn x0 (H x0 Temp) H5).
-  case (total_order_T 0 (f x0)); intro.
-  elim s; intro.
+  destruct (total_order_T 0 (f x0)) as [[Hlt|Heq]|].
   unfold Un_cv in H7; unfold R_dist in H7.
-  elim (H7 (f x0) a); intros.
-  cut (x2 >= x2)%nat; [ intro | unfold ge in |- *; apply le_n ].
+  elim (H7 (f x0) Hlt); intros.
+  cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
   assert (H10 := H8 x2 H9).
   rewrite Rabs_left in H10.
   pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
   rewrite Ropp_minus_distr' in H10.
   unfold Rminus in H10.
-  assert (H11 := Rplus_lt_reg_r _ _ _ H10).
+  assert (H11 := Rplus_lt_reg_l _ _ _ H10).
   assert (H12 := H6 x2).
   cut (0 < f (Vn x2)).
   intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
   rewrite <- (Ropp_involutive (f (Vn x2))).
   apply Ropp_0_gt_lt_contravar; assumption.
-  apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
+  apply Rplus_lt_reg_l with (f x0 - f (Vn x2)).
   rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
     [ unfold Rminus in |- *; apply Rplus_lt_le_0_compat | ring ].
   assumption.
   apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
-  right; rewrite <- b; reflexivity.
+  right; rewrite <- Heq; reflexivity.
   left; assumption.
   unfold Vn in |- *; assumption.
 Qed.
@@ -695,7 +694,7 @@ intros f g lb ub x Prf g_cont_pur lb_lt_ub x_encad Prg_incr f_eq_g df_neq.
        exists deltatemp ; exact Htemp.
     elim (Hf_deriv eps eps_pos).
     intros deltatemp Htemp.
-     red in Hlinv ; red in Hlinv ; simpl dist in Hlinv ; unfold R_dist in Hlinv.
+     red in Hlinv ; red in Hlinv ; unfold dist in Hlinv ; unfold R_dist in Hlinv.
      assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0).
      unfold limit1_in, limit_in, dist in Hlinv' ; simpl in Hlinv'. unfold R_dist in Hlinv'.
      assert (Premisse : (forall eps : R,
@@ -1038,62 +1037,6 @@ Definition mkposreal_lb_ub (x lb ub:R) (lb_lt_x:lb<x) (x_lt_ub:x<ub) : posreal.
 Defined.
 (* end hide *)
 
-Definition boule_of_interval x y (h : x < y) :
-  {c :R & {r : posreal | c - r = x /\ c + r = y}}.
-exists ((x + y)/2).
-assert (radius : 0 < (y - x)/2).
- unfold Rdiv; apply Rmult_lt_0_compat; fourier.
- exists (mkposreal _ radius).
- simpl; split; unfold Rdiv; field.
-Qed.
-
-Definition boule_in_interval x y z (h : x < z < y) :
-  {c : R & {r | Boule c r z /\  x < c - r /\ c + r < y}}.
-Proof.
-assert (cmp : x * /2 + z * /2 < z * /2 + y * /2).
-destruct h as [h1 h2]; fourier.
-destruct (boule_of_interval _ _ cmp) as [c [r [P1 P2]]].
-exists c, r; split.
- destruct h; unfold Boule; simpl; apply Rabs_def1; fourier.
-destruct h; split; fourier.
-Qed.
-
-Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
-  Boule c1 r1 x -> Boule c2 r2 x ->
-  {r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
-intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
-assert (Rmax (c1 - r1)(c2 - r2) < x).
- apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
-  apply Rabs_def2 in h; destruct h; fourier.
-assert (x < Rmin (c1 + r1) (c2 + r2)).
- apply Rmin_glb_lt;[revert in1 | revert in2]; intros h;
-  apply Rabs_def2 in h; destruct h; fourier.
-assert (t: 0 < Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
-              (Rmin (c1 + r1) (c2 + r2) - x)).
- apply Rmin_glb_lt; fourier.
-exists (mkposreal _ t).
-apply Rabs_def2 in in1; destruct in1.
-apply Rabs_def2 in in2; destruct in2.
-assert (c1 - r1 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_l.
-assert (c2 - r2 <= Rmax (c1 - r1) (c2 - r2)) by apply Rmax_r.
-assert (Rmin (c1 + r1) (c2 + r2) <= c1 + r1) by apply Rmin_l.
-assert (Rmin (c1 + r1) (c2 + r2) <= c2 + r2) by apply Rmin_r.
-assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
-         (Rmin (c1 + r1) (c2 + r2) - x) <= x - Rmax (c1 - r1) (c2 - r2))
- by apply Rmin_l.
-assert (Rmin (x - Rmax (c1 - r1) (c2 - r2)) 
-         (Rmin (c1 + r1) (c2 + r2) - x) <= Rmin (c1 + r1) (c2 + r2) - x)
- by apply Rmin_r.
-simpl.
-intros y h; apply Rabs_def2 in h; destruct h;split; apply Rabs_def1; fourier.
-Qed.
-
-Lemma Boule_center : forall x r, Boule x r x.
-Proof.
-intros x [r rpos]; unfold Boule, Rminus; simpl; rewrite Rplus_opp_r.
-rewrite Rabs_pos_eq;[assumption | apply Rle_refl].
-Qed.
-
 Lemma derivable_pt_lim_CVU : forall (fn fn':nat -> R -> R) (f g:R->R)
       (x:R) c r, Boule c r x ->
       (forall y n, Boule c r y -> derivable_pt_lim (fn n) y (fn' n y)) ->
diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v
index ea3899fc..4cf90886 100644
--- a/theories/Reals/Ranalysis_reg.v
+++ b/theories/Reals/Ranalysis_reg.v
@@ -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        *)
@@ -28,7 +28,10 @@ Require Export Ranalysis4.
 Require Export Rpower.
 Local Open Scope R_scope.
 
-Axiom AppVar : R.
+Definition AppVar : R.
+Proof.
+exact R0.
+Qed.
 
 (**********)
 Ltac intro_hyp_glob trm :=
diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v
index 096c75fe..68718db0 100644
--- a/theories/Reals/Ratan.v
+++ b/theories/Reals/Ratan.v
@@ -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        *)
@@ -18,6 +18,7 @@ Require Import SeqProp.
 Require Import Ranalysis5.
 Require Import SeqSeries.
 Require Import PartSum.
+Require Import Omega.
 
 Local Open Scope R_scope.
 
@@ -449,9 +450,9 @@ fourier.
 Qed.
 
 Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}.
-destruct (total_order_T (Rabs y) 1).
- assert (yle1 : Rabs y <= 1) by (destruct s; fourier).
- clear s; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ].
+destruct (total_order_T (Rabs y) 1) as [Hs|Hgt].
+ assert (yle1 : Rabs y <= 1) by (destruct Hs; fourier).
+ clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ].
  apply Rle_lt_trans with (1 := yle1); exact tan_1_gt_1.
 assert (0 < / (Rabs y + 1)).
  apply Rinv_0_lt_compat; fourier.
@@ -529,7 +530,7 @@ split.
     assumption.
    replace (/(Rabs y + 1)) with (2 * u).
     fourier.
-   unfold u; field; apply Rgt_not_eq; clear -r; fourier.
+   unfold u; field; apply Rgt_not_eq; clear -Hgt; fourier.
   solve[discrR].
  apply Rgt_not_eq; assumption.
 unfold tan.
@@ -735,6 +736,16 @@ replace (Rsqr x) with (x ^ 2) by (unfold Rsqr; ring).
 reflexivity.
 Qed.
 
+Lemma derivable_pt_lim_atan :
+  forall x, derivable_pt_lim atan x (/(1 + x^2)).
+Proof.
+intros x.
+apply derive_pt_eq_1 with (derivable_pt_atan x).
+replace (x ^ 2) with (x * x) by ring.
+rewrite <- (Rmult_1_l (Rinv _)).
+apply derive_pt_atan.
+Qed.
+
 (** * Definition of the arctangent function as the sum of the arctan power series *)
 (* Proof taken from Guillaume Melquiond's interval package for Coq *)
 
@@ -818,13 +829,11 @@ intros x Hx eps Heps.
    apply Rle_lt_trans with (/ INR (2 * N + 1))%R.
    unfold Rdiv.
    rewrite Rmult_1_l.
-   apply Rle_Rinv.
+   apply Rinv_le_contravar.
    apply lt_INR_0.
    omega.
-   replace 0 with (INR 0) by intuition.
-   apply lt_INR.
+   apply le_INR.
    omega.
-   intuition.
    rewrite <- (Rinv_involutive eps).
    apply Rinv_lt_contravar.
    apply Rmult_lt_0_compat.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index cf6fdbfd..f545d3a0 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -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/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
index 5541a0f9..7a879f45 100644
--- a/theories/Reals/Rbase.v
+++ b/theories/Reals/Rbase.v
@@ -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/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index 225186a6..bb30c0ef 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -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        *)
@@ -45,12 +45,12 @@ Qed.
 (*********)
 Lemma Rmin_Rgt_l : forall r1 r2 r, Rmin r1 r2 > r -> r1 > r /\ r2 > r.
 Proof.
-  intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2); intros.
+  intros r1 r2 r; unfold Rmin; case (Rle_dec r1 r2) as [Hle|Hnle]; intros.
   split.
   assumption.
-  unfold Rgt; unfold Rgt in H; exact (Rlt_le_trans r r1 r2 H r0).
+  unfold Rgt; exact (Rlt_le_trans r r1 r2 H Hle).
   split.
-  generalize (Rnot_le_lt r1 r2 n); intro; exact (Rgt_trans r1 r2 r H0 H).
+  generalize (Rnot_le_lt r1 r2 Hnle); intro; exact (Rgt_trans r1 r2 r H0 H).
   assumption.
 Qed.
 
@@ -168,10 +168,10 @@ Lemma Rmax_Rle : forall r1 r2 r, r <= Rmax r1 r2 <-> r <= r1 \/ r <= r2.
 Proof.
   intros; split.
   unfold Rmax; case (Rle_dec r1 r2); intros; auto.
-  intro; unfold Rmax; case (Rle_dec r1 r2); elim H; clear H; intros;
+  intro; unfold Rmax; case (Rle_dec r1 r2) as [|Hnle]; elim H; clear H; intros;
     auto.
   apply (Rle_trans r r1 r2); auto.
-  generalize (Rnot_le_lt r1 r2 n); clear n; intro; unfold Rgt in H0;
+  generalize (Rnot_le_lt r1 r2 Hnle); clear Hnle; intro; unfold Rgt in H0;
     apply (Rlt_le r r1 (Rle_lt_trans r r2 r1 H H0)).
 Qed.
 
@@ -262,6 +262,16 @@ Proof.
   intros; unfold Rmax; case (Rle_dec x y); intro; assumption.
 Qed.
 
+Lemma Rmax_Rlt : forall x y z, 
+  Rmax x y < z <-> x < z /\ y < z.
+Proof.
+intros x y z; split.
+ unfold Rmax; case (Rle_dec x y).
+  intros xy yz; split;[apply Rle_lt_trans with y|]; assumption.
+  intros xz xy; split;[|apply Rlt_trans with x;[apply Rnot_le_gt|]];assumption.
+ intros [h h']; apply Rmax_lub_lt; assumption.
+Qed.
+
 (*********)
 Lemma Rmax_neg : forall x y:R, x < 0 -> y < 0 -> Rmax x y < 0.
 Proof.
@@ -276,9 +286,9 @@ Qed.
 (*********)
 Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}.
 Proof.
-  intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X.
-  right; apply (Rle_ge 0 r a).
-  left; fold (0 > r); apply (Rnot_le_lt 0 r b).
+  intro; generalize (Rle_dec 0 r); intro X; elim X; intro H; clear X.
+  right; apply (Rle_ge 0 r H).
+  left; fold (0 > r); apply (Rnot_le_lt 0 r H).
 Qed.
 
 (*********)
@@ -320,9 +330,9 @@ Qed.
 (*********)
 Lemma Rabs_right : forall r, r >= 0 -> Rabs r = r.
 Proof.
-  intros; unfold Rabs; case (Rcase_abs r); intro.
+  intros; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge].
   absurd (r >= 0).
-  exact (Rlt_not_ge r 0 r0).
+  exact (Rlt_not_ge r 0 Hlt).
   assumption.
   trivial.
 Qed.
@@ -337,9 +347,9 @@ Qed.
 (*********)
 Lemma Rabs_pos : forall x:R, 0 <= Rabs x.
 Proof.
-  intros; unfold Rabs; case (Rcase_abs x); intro.
-  generalize (Ropp_lt_gt_contravar x 0 r); intro; unfold Rgt in H;
-    rewrite Ropp_0 in H; unfold Rle; left; assumption.
+  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge].
+  generalize (Ropp_lt_gt_contravar x 0 Hlt); intro; unfold Rgt in H;
+    rewrite Ropp_0 in H; left; assumption.
   apply Rge_le; assumption.
 Qed.
 
@@ -350,11 +360,18 @@ Qed.
 
 Definition RRle_abs := Rle_abs.
 
+Lemma Rabs_le : forall a b, -b <= a <= b -> Rabs a <= b.
+Proof.
+intros a b; unfold Rabs; case Rcase_abs.
+ intros _ [it _]; apply Ropp_le_cancel; rewrite Ropp_involutive; exact it.
+intros _ [_ it]; exact it.
+Qed.
+
 (*********)
 Lemma Rabs_pos_eq : forall x:R, 0 <= x -> Rabs x = x.
 Proof.
-  intros; unfold Rabs; case (Rcase_abs x); intro;
-    [ generalize (Rgt_not_le 0 x r); intro; exfalso; auto | trivial ].
+  intros; unfold Rabs; case (Rcase_abs x) as [Hlt|Hge];
+    [ generalize (Rgt_not_le 0 x Hlt); intro; exfalso; auto | trivial ].
 Qed.
 
 (*********)
@@ -366,100 +383,70 @@ Qed.
 (*********)
 Lemma Rabs_pos_lt : forall x:R, x <> 0 -> 0 < Rabs x.
 Proof.
-  intros; generalize (Rabs_pos x); intro; unfold Rle in H0; elim H0; intro;
-    auto.
-  exfalso; clear H0; elim H; clear H; generalize H1; unfold Rabs;
-    case (Rcase_abs x); intros; auto.
-  clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0);
-    rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x);
-      trivial.
+  intros; destruct (Rabs_pos x) as [|Heq]; auto.
+  apply Rabs_no_R0 in H; symmetry in Heq; contradiction.
 Qed.
 
 (*********)
 Lemma Rabs_minus_sym : forall x y:R, Rabs (x - y) = Rabs (y - x).
 Proof.
-  intros; unfold Rabs; case (Rcase_abs (x - y));
-    case (Rcase_abs (y - x)); intros.
-  generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros;
-    generalize (Rlt_asym x y H); intro; exfalso;
-      auto.
+  intros; unfold Rabs; case (Rcase_abs (x - y)) as [Hlt|Hge];
+    case (Rcase_abs (y - x)) as [Hlt'|Hge'].
+  apply Rminus_lt, Rlt_asym in Hlt; apply Rminus_lt in Hlt'; contradiction.
   rewrite (Ropp_minus_distr x y); trivial.
   rewrite (Ropp_minus_distr y x); trivial.
-  unfold Rge in r, r0; elim r; elim r0; intros; clear r r0.
-  generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y);
-    intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0);
-      intro; exfalso; auto.
-  rewrite (Rminus_diag_uniq x y H); trivial.
-  rewrite (Rminus_diag_uniq y x H0); trivial.
-  rewrite (Rminus_diag_uniq y x H0); trivial.
+  destruct Hge; destruct Hge'.
+  apply Ropp_lt_gt_0_contravar in H; rewrite (Ropp_minus_distr x y) in H;
+    apply Rlt_asym in H0; contradiction.
+  apply Rminus_diag_uniq in H0 as ->; trivial.
+  apply Rminus_diag_uniq in H as ->; trivial.
+  apply Rminus_diag_uniq in H0 as ->; trivial.
 Qed.
 
 (*********)
 Lemma Rabs_mult : forall x y:R, Rabs (x * y) = Rabs x * Rabs y.
 Proof.
-  intros; unfold Rabs; case (Rcase_abs (x * y)); case (Rcase_abs x);
-    case (Rcase_abs y); intros; auto.
-  generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro;
-    rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1);
-      intro; unfold Rgt in H; exfalso; rewrite (Rmult_comm y x) in H;
-        auto.
+  intros; unfold Rabs; case (Rcase_abs (x * y)) as [Hlt|Hge];
+    case (Rcase_abs x) as [Hltx|Hgex];
+    case (Rcase_abs y) as [Hlty|Hgey]; auto.
+  apply Rmult_lt_gt_compat_neg_l with (r:=x), Rlt_asym in Hlty; trivial.
+    rewrite Rmult_0_r in Hlty; contradiction.
   rewrite (Ropp_mult_distr_l_reverse x y); trivial.
   rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x);
     rewrite (Rmult_comm x y); trivial.
-  unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0.
-  generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1;
-    generalize (Rlt_asym (x * y) 0 r1); intro; exfalso;
-      auto.
-  rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0);
-    intro; exfalso; auto.
-  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
-    intro; exfalso; auto.
-  rewrite H0 in r1; rewrite (Rmult_0_r x) in r1; generalize (Rlt_irrefl 0);
-    intro; exfalso; auto.
+  destruct Hgex as [| ->], Hgey as [| ->].
+  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in H0; trivial.
+    rewrite Rmult_0_r in H0; contradiction.
+  rewrite Rmult_0_r in Hlt; contradiction (Rlt_irrefl 0).
+  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
+  rewrite Rmult_0_l in Hlt; contradiction (Rlt_irrefl 0).
   rewrite (Rmult_opp_opp x y); trivial.
-  unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H.
-  generalize (Rmult_lt_compat_l y x 0 H0 r0); intro;
-    rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1;
-      generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
-        auto.
-  generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0));
-    generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0));
-      intros; generalize (Rmult_integral x y H); intro;
-        elim H3; intro; exfalso; auto.
-  rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H;
-    generalize (Rlt_irrefl 0); intro; exfalso;
-      auto.
-  rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial.
-  unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros;
-    unfold Rgt in H0, H.
-  generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1;
-    generalize (Rlt_asym (x * y) 0 H1); intro; exfalso;
-      auto.
-  generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r));
-    generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0));
-      intros; generalize (Rmult_integral x y H); intro;
-        elim H3; intro; exfalso; auto.
-  rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H;
-    generalize (Rlt_irrefl 0); intro; exfalso;
-      auto.
-  rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial.
+  destruct Hge. destruct Hgey.
+  apply Rmult_lt_compat_r with (r:=y), Rlt_asym in Hltx; trivial.
+    rewrite Rmult_0_l in Hltx; contradiction.
+  rewrite H0, Rmult_0_r in H; contradiction (Rlt_irrefl 0).
+  rewrite <- Ropp_mult_distr_l, H, Ropp_0; trivial.
+  destruct Hge. destruct Hgex.
+  apply Rmult_lt_compat_l with (r:=x), Rlt_asym in Hlty; trivial.
+    rewrite Rmult_0_r in Hlty; contradiction.
+  rewrite H0, 2!Rmult_0_l; trivial.
+  rewrite <- Ropp_mult_distr_r, H, Ropp_0; trivial.
 Qed.
 
 (*********)
 Lemma Rabs_Rinv : forall r, r <> 0 -> Rabs (/ r) = / Rabs r.
 Proof.
-  intro; unfold Rabs; case (Rcase_abs r); case (Rcase_abs (/ r)); auto;
+  intro; unfold Rabs; case (Rcase_abs r) as [Hlt|Hge];
+    case (Rcase_abs (/ r)) as [Hlt'|Hge']; auto;
     intros.
   apply Ropp_inv_permute; auto.
-  generalize (Rinv_lt_0_compat r r1); intro; unfold Rge in r0; elim r0; intros.
-  unfold Rgt in H1; generalize (Rlt_asym 0 (/ r) H1); intro; exfalso;
-    auto.
-  generalize (Rlt_dichotomy_converse (/ r) 0 (or_introl (/ r > 0) H0)); intro;
-    exfalso; auto.
-  unfold Rge in r1; elim r1; clear r1; intro.
-  unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0));
-    intro; exfalso; auto.
-  exfalso; auto.
+  rewrite <- Ropp_inv_permute; trivial.
+  destruct Hge' as [| ->].
+  apply Rinv_lt_0_compat, Rlt_asym in Hlt; contradiction.
+  rewrite Ropp_0; trivial.
+  destruct Hge as [| ->].
+  apply Rinv_0_lt_compat, Rlt_asym in H0; contradiction.
+  contradiction (refl_equal 0).
 Qed.
 
 Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x.
@@ -483,13 +470,14 @@ Qed.
 (*********)
 Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
 Proof.
-  intros a b; unfold Rabs; case (Rcase_abs (a + b)); case (Rcase_abs a);
-    case (Rcase_abs b); intros.
+  intros a b; unfold Rabs; case (Rcase_abs (a + b)) as [Hlt|Hge];
+    case (Rcase_abs a) as [Hlta|Hgea];
+    case (Rcase_abs b) as [Hltb|Hgeb].
   apply (Req_le (- (a + b)) (- a + - b)); rewrite (Ropp_plus_distr a b);
     reflexivity.
 (**)
   rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b);
-    unfold Rle; unfold Rge in r; elim r; intro.
+    unfold Rle; elim Hgeb; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro;
     elim (Rplus_ne (- b)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H).
@@ -497,24 +485,24 @@ Proof.
 (**)
   rewrite (Ropp_plus_distr a b); rewrite (Rplus_comm (- a) (- b));
     rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a);
-      unfold Rle; unfold Rge in r0; elim r0; intro.
+      unfold Rle; elim Hgea; intro.
   left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro;
     elim (Rplus_ne (- a)); intros v w; rewrite v in H0;
       clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H).
   right; rewrite H; apply Ropp_0.
 (**)
-  exfalso; generalize (Rplus_ge_compat_l a b 0 r); intro;
+  exfalso; generalize (Rplus_ge_compat_l a b 0 Hgeb); intro;
     elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
-      generalize (Rge_trans (a + b) a 0 H r0); intro; clear H;
+      generalize (Rge_trans (a + b) a 0 H Hgea); intro; clear H;
         unfold Rge in H0; elim H0; intro; clear H0.
-  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto.
+  unfold Rgt in H; generalize (Rlt_asym (a + b) 0 Hlt); intro; auto.
   absurd (a + b = 0); auto.
   apply (Rlt_dichotomy_converse (a + b) 0); left; assumption.
 (**)
-  exfalso; generalize (Rplus_lt_compat_l a b 0 r); intro;
+  exfalso; generalize (Rplus_lt_compat_l a b 0 Hltb); intro;
     elim (Rplus_ne a); intros v w; rewrite v in H; clear v w;
-      generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H;
-        unfold Rge in r1; elim r1; clear r1; intro.
+      generalize (Rlt_trans (a + b) a 0 H Hlta); intro; clear H;
+        destruct Hge.
   unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro;
     apply (Rlt_irrefl (a + b)); assumption.
   rewrite H in H0; apply (Rlt_irrefl 0); assumption.
@@ -522,16 +510,16 @@ Proof.
   rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b);
     apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a));
       unfold Rminus; rewrite (Ropp_involutive a);
-        generalize (Rplus_lt_compat_l a a 0 r0); clear r r1;
+        generalize (Rplus_lt_compat_l a a 0 Hlta); clear Hge Hgeb;
           intro; elim (Rplus_ne a); intros v w; rewrite v in H;
-            clear v w; generalize (Rlt_trans (a + a) a 0 H r0);
+            clear v w; generalize (Rlt_trans (a + a) a 0 H Hlta);
               intro; apply (Rlt_le (a + a) 0 H0).
 (**)
   apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b));
     unfold Rminus; rewrite (Ropp_involutive b);
-      generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1;
+      generalize (Rplus_lt_compat_l b b 0 Hltb); clear Hge Hgea;
         intro; elim (Rplus_ne b); intros v w; rewrite v in H;
-          clear v w; generalize (Rlt_trans (b + b) b 0 H r);
+          clear v w; generalize (Rlt_trans (b + b) b 0 H Hltb);
             intro; apply (Rlt_le (b + b) 0 H0).
 (**)
   unfold Rle; right; reflexivity.
@@ -585,15 +573,15 @@ Qed.
 (*********)
 Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
 Proof.
-  unfold Rabs; intro x; case (Rcase_abs x); intros.
-  generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt; intro;
+  unfold Rabs; intro x; case (Rcase_abs x) as [Hlt|Hge]; intros.
+  generalize (Ropp_gt_lt_0_contravar x Hlt); unfold Rgt; intro;
     generalize (Rlt_trans 0 (- x) a H0 H); intro; split.
-  apply (Rlt_trans x 0 a r H1).
+  apply (Rlt_trans x 0 a Hlt H1).
   generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x);
     unfold Rgt; trivial.
-  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro;
+  fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H Hge); intro;
     generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a);
-      generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt;
+      generalize (Rge_gt_trans x 0 (- a) Hge H1); unfold Rgt;
         intro; split; assumption.
 Qed.
 
@@ -637,3 +625,51 @@ Proof.
   intros.
   now rewrite Rabs_Zabs.
 Qed.
+
+Lemma Ropp_Rmax : forall x y, - Rmax x y = Rmin (-x) (-y).
+intros x y; apply Rmax_case_strong.
+ now intros w; rewrite Rmin_left;[ | apply Rge_le, Ropp_le_ge_contravar].
+now intros w; rewrite Rmin_right; [ | apply Rge_le, Ropp_le_ge_contravar].
+Qed.
+
+Lemma Ropp_Rmin : forall x y, - Rmin x y = Rmax (-x) (-y).
+intros x y; apply Rmin_case_strong.
+ now intros w; rewrite Rmax_left;[ | apply Rge_le, Ropp_le_ge_contravar].
+now intros w; rewrite Rmax_right; [ | apply Rge_le, Ropp_le_ge_contravar].
+Qed.
+
+Lemma Rmax_assoc : forall a b c, Rmax a (Rmax b c) = Rmax (Rmax a b) c.
+Proof.
+intros a b c.
+unfold Rmax; destruct (Rle_dec b c); destruct (Rle_dec a b);
+  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
+  match goal with 
+  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
+   case id; apply Rle_trans with z; auto with real
+  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
+   case id; apply Rle_trans with z; auto with real
+  end.
+Qed.
+
+Lemma Rminmax : forall a b, Rmin a b <= Rmax a b.
+Proof.
+intros a b; destruct (Rle_dec a b).
+ rewrite Rmin_left, Rmax_right; assumption.
+now rewrite Rmin_right, Rmax_left; assumption ||
+  apply Rlt_le, Rnot_le_gt.
+Qed.
+
+Lemma Rmin_assoc : forall x y z, Rmin x (Rmin y z) =
+  Rmin (Rmin x y) z.
+Proof.
+intros a b c.
+unfold Rmin; destruct (Rle_dec b c); destruct (Rle_dec a b);
+  destruct (Rle_dec a c); destruct (Rle_dec b c); auto with real;
+  match goal with 
+  | id :  ~ ?x <= ?y, id2 : ?x <= ?z |- _ =>
+   case id; apply Rle_trans with z; auto with real
+  | id : ~ ?x <= ?y, id2 : ~ ?z <= ?x |- _ =>
+   case id; apply Rle_trans with z; auto with real
+  end.
+Qed.
+
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index 9b896bdd..1766f377 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -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        *)
@@ -27,21 +27,19 @@ Proof.
   intros.
   set (Vn := sequence_minorant Un (cauchy_min Un H)).
   set (Wn := sequence_majorant Un (cauchy_maj Un H)).
-  assert (H0 := maj_cv Un H).
-  fold Wn in H0.
-  assert (H1 := min_cv Un H).
-  fold Vn in H1.
-  elim H0; intros.
-  elim H1; intros.
+  pose proof (maj_cv Un H) as (x,p).
+  fold Wn in p.
+  pose proof (min_cv Un H) as (x0,p0).
+  fold Vn in p0.
   cut (x = x0).
-  intros.
+  intros H2.
   exists x.
   rewrite <- H2 in p0.
   unfold Un_cv.
   intros.
   unfold Un_cv in p; unfold Un_cv in p0.
   cut (0 < eps / 3).
-  intro.
+  intro H4.
   elim (p (eps / 3) H4); intros.
   elim (p0 (eps / 3) H4); intros.
   exists (max x1 x2).
@@ -83,20 +81,20 @@ Proof.
   [ apply Rabs_triang | ring ].
   apply Rlt_le_trans with (eps / 3 + eps / 3 + eps / 3).
   repeat apply Rplus_lt_compat.
-  unfold R_dist in H5.
-  apply H5.
+  unfold R_dist in H1.
+  apply H1.
   unfold ge; apply le_trans with (max x1 x2).
   apply le_max_l.
   assumption.
   rewrite <- Rabs_Ropp.
   replace (- (x - Vn n)) with (Vn n - x); [ idtac | ring ].
-  unfold R_dist in H6.
-  apply H6.
+  unfold R_dist in H3.
+  apply H3.
   unfold ge; apply le_trans with (max x1 x2).
   apply le_max_r.
   assumption.
-  unfold R_dist in H6.
-  apply H6.
+  unfold R_dist in H3.
+  apply H3.
   unfold ge; apply le_trans with (max x1 x2).
   apply le_max_r.
   assumption.
@@ -112,11 +110,11 @@ Proof.
   intro.
   unfold Un_cv in p; unfold Un_cv in p0.
   unfold R_dist in p; unfold R_dist in p0.
-  elim (p (eps / 5) H3); intros N1 H4.
-  elim (p0 (eps / 5) H3); intros N2 H5.
+  elim (p (eps / 5) H1); intros N1 H4.
+  elim (p0 (eps / 5) H1); intros N2 H5.
   unfold Cauchy_crit in H.
   unfold R_dist in H.
-  elim (H (eps / 5) H3); intros N3 H6.
+  elim (H (eps / 5) H1); intros N3 H6.
   set (N := max (max N1 N2) N3).
   apply Rle_lt_trans with (Rabs (x - Wn N) + Rabs (Wn N - x0)).
   replace (x - x0) with (x - Wn N + (Wn N - x0)); [ apply Rabs_triang | ring ].
@@ -146,12 +144,11 @@ Proof.
   cut
     (Vn N =
       minorant (fun k:nat => Un (N + k)%nat) (min_ss Un N (cauchy_min Un H))).
-  intros.
-  rewrite <- H9; rewrite <- H10.
-  rewrite <- H9 in H8.
-  rewrite <- H10 in H7.
-  elim (H7 (eps / 5) H3); intros k2 H11.
-  elim (H8 (eps / 5) H3); intros k1 H12.
+  intros H9 H10.
+  rewrite <- H9 in H8 |- *.
+  rewrite <- H10 in H7 |- *.
+  elim (H7 (eps / 5) H1); intros k2 H11.
+  elim (H8 (eps / 5) H1); intros k1 H12.
   apply Rle_lt_trans with
     (Rabs (Wn N - Un (N + k2)%nat) + Rabs (Un (N + k2)%nat - Vn N)).
   replace (Wn N - Vn N) with
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index 19cc2166..50eb59b2 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -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/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index 64b1b0d4..3a332d21 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -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        *)
@@ -162,9 +162,9 @@ Proof.
       (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2)
         (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro;
       rewrite eps2 in H10; assumption.
-  unfold Rabs; case (Rcase_abs 2); auto.
-  intro; cut (0 < 2).
-  intro ; elim (Rlt_asym 0 2 H7 r).
+  unfold Rabs; destruct (Rcase_abs 2) as [Hlt|Hge]; auto.
+  cut (0 < 2).
+  intro H7; elim (Rlt_asym 0 2 H7 Hlt).
   fourier.
   apply Rabs_no_R0.
   discrR.
@@ -193,11 +193,11 @@ Proof.
     unfold limit_in; intros; simpl; split with eps;
       split; auto.
   intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros;
-    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (not_eq_sym H3)));
-      unfold R_dist; rewrite (Rminus_diag_eq 1 1 (eq_refl 1));
-        unfold Rabs; case (Rcase_abs 0); intro.
+    rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3)));
+      unfold R_dist; rewrite (Rminus_diag_eq 1 1 (refl_equal 1));
+        unfold Rabs; case (Rcase_abs 0) as [Hlt|Hge].
   absurd (0 < 0); auto.
-  red; intro; apply (Rlt_irrefl 0 r).
+  red in |- *; intro; apply (Rlt_irrefl 0 Hlt).
   unfold Rgt in H; assumption.
 Qed.
 
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 8faa4e25..9cb8a10b 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -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/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index ee8988d8..1c353803 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -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        *)
@@ -489,16 +489,16 @@ Lemma pow_Rabs : forall (x:R) (n:nat), x ^ n <= Rabs x ^ n.
 Proof.
   intros; induction  n as [| n Hrecn].
   right; reflexivity.
-  simpl; case (Rcase_abs x); intro.
+  simpl; destruct (Rcase_abs x) as [Hlt|Hle].
   apply Rle_trans with (Rabs (x * x ^ n)).
   apply RRle_abs.
   rewrite Rabs_mult.
   apply Rmult_le_compat_l.
   apply Rabs_pos.
-  right; symmetry ; apply RPow_abs.
-  pattern (Rabs x) at 1; rewrite (Rabs_right x r);
+  right; symmetry; apply RPow_abs.
+  pattern (Rabs x) at 1; rewrite (Rabs_right x Hle);
     apply Rmult_le_compat_l.
-  apply Rge_le; exact r.
+  apply Rge_le; exact Hle.
   apply Hrecn.
 Qed.
 
@@ -520,14 +520,17 @@ Proof.
   apply Rle_trans with (Rabs y); [ apply Rabs_pos | exact H ].
 Qed.
 
+Lemma Rsqr_pow2 : forall x, Rsqr x = x ^ 2.
+Proof.
+intros; unfold Rsqr; simpl; rewrite Rmult_1_r; reflexivity.
+Qed.
+
+
 (*******************************)
 (** *       PowerRZ            *)
 (*******************************)
 (*i Due to L.Thery i*)
 
-Ltac case_eq name :=
-  generalize (eq_refl name); pattern name at -1; case name.
-
 Definition powerRZ (x:R) (n:Z) :=
   match n with
     | Z0 => 1
@@ -744,10 +747,10 @@ Qed.
 Lemma R_dist_sym : forall x y:R, R_dist x y = R_dist y x.
 Proof.
   unfold R_dist; intros; split_Rabs; try ring.
-  generalize (Ropp_gt_lt_0_contravar (y - x) r); intro;
-    rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0);
+  generalize (Ropp_gt_lt_0_contravar (y - x) Hlt0); intro;
+    rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 Hlt);
       intro; unfold Rgt in H; exfalso; auto.
-  generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro;
+  generalize (minus_Rge y x Hge0); intro; generalize (minus_Rge x y Hge); intro;
     generalize (Rge_antisym x y H0 H); intro; rewrite H1;
       ring.
 Qed.
@@ -786,6 +789,13 @@ Proof.
   ring.
 Qed.
 
+Lemma R_dist_mult_l : forall a b c,
+  R_dist (a * b) (a * c) = Rabs a * R_dist b c.
+Proof.
+unfold R_dist. 
+intros a b c; rewrite <- Rmult_minus_distr_l, Rabs_mult; reflexivity.
+Qed.
+
 (*******************************)
 (** *     Infinite Sum          *)
 (*******************************)
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
index afdf148e..d930c5aa 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -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/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index ce37fcba..856fff80 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -12,8 +12,6 @@ Require Import SeqSeries.
 Require Import Ranalysis_reg.
 Require Import Rbase.
 Require Import RiemannInt_SF.
-Require Import Classical_Prop.
-Require Import Classical_Pred_Type.
 Require Import Max.
 Local Open Scope R_scope.
 
@@ -51,8 +49,8 @@ Lemma RiemannInt_P1 :
   forall (f:R -> R) (a b:R),
     Riemann_integrable f a b -> Riemann_integrable f b a.
 Proof.
-  unfold Riemann_integrable; intros; elim (X eps); clear X; intros;
-    elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x)));
+  unfold Riemann_integrable; intros; elim (X eps); clear X; intros.
+  elim p; clear p; intros x0 p; exists (mkStepFun (StepFun_P6 (pre x)));
       exists (mkStepFun (StepFun_P6 (pre x0)));
         elim p; clear p; intros; split.
   intros; apply (H t); elim H1; clear H1; intros; split;
@@ -110,12 +108,10 @@ Proof.
   replace (vn n x + -1 * vn m x) with (vn n x - f x + (f x - vn m x));
   [ apply Rabs_triang | ring ].
   assert (H12 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with H0; reflexivity.
   assert (H13 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
-  rewrite <- H12 in H11; pattern b at 2 in H11; rewrite <- H13 in H11;
+  unfold Rmax; decide (Rle_dec a b) with H0; reflexivity.
+  rewrite <- H12 in H11; rewrite <- H13 in H11 at 2;
     rewrite Rmult_1_l; apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9.
   elim H11; intros; split; left; assumption.
@@ -142,7 +138,7 @@ Lemma RiemannInt_P3 :
       Rabs (RiemannInt_SF (wn n)) < un n) ->
     { l:R | Un_cv (fun N:nat => RiemannInt_SF (vn N)) l }.
 Proof.
-  intros; case (Rle_dec a b); intro.
+  intros; destruct (Rle_dec a b) as [Hle|Hnle].
   apply RiemannInt_P2 with f un wn; assumption.
   assert (H1 : b <= a); auto with real.
   set (vn' := fun n:nat => mkStepFun (StepFun_P6 (pre (vn n))));
@@ -153,49 +149,48 @@ Proof.
             (forall t:R,
               Rmin b a <= t <= Rmax b a -> Rabs (f t - vn' n t) <= wn' n t) /\
             Rabs (RiemannInt_SF (wn' n)) < un n).
-  intro; elim (H0 n0); intros; split.
-  intros; apply (H2 t); elim H4; clear H4; intros; split;
+  intro; elim (H0 n); intros; split.
+  intros t (H4,H5); apply (H2 t); split;
     [ apply Rle_trans with (Rmin b a); try assumption; right;
       unfold Rmin
       | apply Rle_trans with (Rmax b a); try assumption; right;
         unfold Rmax ];
-    (case (Rle_dec a b); case (Rle_dec b a); intros;
-      try reflexivity || apply Rle_antisym;
-        [ assumption | assumption | auto with real | auto with real ]).
-  generalize H3; unfold RiemannInt_SF; case (Rle_dec a b);
-    case (Rle_dec b a); unfold wn'; intros;
+    decide (Rle_dec a b) with Hnle; decide (Rle_dec b a) with H1; reflexivity.
+  generalize H3; unfold RiemannInt_SF; destruct (Rle_dec a b) as [Hleab|Hnleab];
+    destruct (Rle_dec b a) as [Hle'|Hnle']; unfold wn'; intros;
       (replace
-        (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n0)))))
-          (subdivision (mkStepFun (StepFun_P6 (pre (wn n0)))))) with
-        (Int_SF (subdivision_val (wn n0)) (subdivision (wn n0)));
+        (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (wn n)))))
+          (subdivision (mkStepFun (StepFun_P6 (pre (wn n)))))) with
+        (Int_SF (subdivision_val (wn n)) (subdivision (wn n)));
         [ idtac
-          | apply StepFun_P17 with (fe (wn n0)) a b;
+          | apply StepFun_P17 with (fe (wn n)) a b;
             [ apply StepFun_P1
               | apply StepFun_P2;
-                apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n0))))) ] ]).
+                apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (wn n))))) ] ]).
   apply H4.
   rewrite Rabs_Ropp; apply H4.
   rewrite Rabs_Ropp in H4; apply H4.
   apply H4.
-  assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros;
+  assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros x p;
     exists (- x); unfold Un_cv; unfold Un_cv in p;
       intros; elim (p _ H4); intros; exists x0; intros;
         generalize (H5 _ H6); unfold R_dist, RiemannInt_SF;
-          case (Rle_dec b a); case (Rle_dec a b); intros.
-  elim n; assumption.
+          destruct (Rle_dec b a) as [Hle'|Hnle']; destruct (Rle_dec a b) as [Hle''|Hnle''];
+          intros.
+  elim Hnle; assumption.
   unfold vn' in H7;
-    replace (Int_SF (subdivision_val (vn n0)) (subdivision (vn n0))) with
-    (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0)))))
-      (subdivision (mkStepFun (StepFun_P6 (pre (vn n0))))));
+    replace (Int_SF (subdivision_val (vn n)) (subdivision (vn n))) with
+    (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n)))))
+      (subdivision (mkStepFun (StepFun_P6 (pre (vn n))))));
     [ unfold Rminus; rewrite Ropp_involutive; rewrite <- Rabs_Ropp;
       rewrite Ropp_plus_distr; rewrite Ropp_involutive;
         apply H7
-      | symmetry ; apply StepFun_P17 with (fe (vn n0)) a b;
+      | symmetry ; apply StepFun_P17 with (fe (vn n)) a b;
         [ apply StepFun_P1
           | apply StepFun_P2;
-            apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n0))))) ] ].
-  elim n1; assumption.
-  elim n2; assumption.
+            apply (StepFun_P1 (mkStepFun (StepFun_P6 (pre (vn n))))) ] ].
+  elim Hnle'; assumption.
+  elim Hnle'; assumption.
 Qed.
 
 Lemma RiemannInt_exists :
@@ -244,7 +239,7 @@ Proof.
       (RiemannInt_SF (phi_sequence vn pr2 n) +
         -1 * RiemannInt_SF (phi_sequence un pr1 n)); [ idtac | ring ];
       rewrite <- StepFun_P30.
-  case (Rle_dec a b); intro.
+  destruct (Rle_dec a b) as [Hle|Hnle].
   apply Rle_lt_trans with
     (RiemannInt_SF
       (mkStepFun
@@ -263,13 +258,11 @@ Proof.
   (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
   [ apply Rabs_triang | ring ].
   assert (H10 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity.
   assert (H11 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hle; reflexivity.
   rewrite (Rplus_comm (psi_un x)); apply Rplus_le_compat.
-  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
+  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; destruct H5 as (H8,H9); apply H8.
   rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
   elim H6; intros; apply H8.
   rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
@@ -319,11 +312,9 @@ Proof.
   (phi_sequence vn pr2 n x - f x + (f x - phi_sequence un pr1 n x));
   [ apply Rabs_triang | ring ].
   assert (H10 : Rmin a b = b).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ elim n0; assumption | reflexivity ].
+  unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity.
   assert (H11 : Rmax a b = a).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ elim n0; assumption | reflexivity ].
+  unfold Rmax; decide (Rle_dec a b) with Hnle; reflexivity.
   apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim H5; intros; apply H8.
   rewrite H10; rewrite H11; elim H7; intros; split; left; assumption.
@@ -388,11 +379,9 @@ Proof.
     [ idtac
       | left; change (0 < / (INR n + 1)); apply Rinv_0_lt_compat;
         assumption ]; apply Rle_lt_trans with (/ (INR x + 1)).
-  apply Rle_Rinv.
+  apply Rinv_le_contravar.
   apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ].
-  assumption.
-  do 2 rewrite <- (Rplus_comm 1); apply Rplus_le_compat_l; apply le_INR;
-    apply H4.
+  apply Rplus_le_compat_r; apply le_INR; apply H4.
   rewrite <- (Rinv_involutive eps).
   apply Rinv_lt_contravar.
   apply Rmult_lt_0_compat.
@@ -405,6 +394,15 @@ Proof.
   red; intro; rewrite H6 in H; elim (Rlt_irrefl _ H).
 Qed.
 
+Lemma Riemann_integrable_ext :
+  forall f g a b, 
+    (forall x, Rmin a b <= x <= Rmax a b -> f x = g x) ->
+    Riemann_integrable f a b -> Riemann_integrable g a b.
+intros f g a b fg rif eps; destruct (rif eps) as [phi [psi [P1 P2]]].
+exists phi; exists psi;split;[ | assumption ].
+intros t intt; rewrite <- fg;[ | assumption].
+apply P1; assumption.
+Qed.
 (**********)
 Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R :=
   let (a,_) := RiemannInt_exists pr RinvN RinvN_cv in a.
@@ -414,10 +412,10 @@ Lemma RiemannInt_P5 :
     RiemannInt pr1 = RiemannInt pr2.
 Proof.
   intros; unfold RiemannInt;
-    case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x,HUn);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x0,HUn0);
       eapply UL_sequence;
-        [ apply u0
+        [ apply HUn
           | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ].
 Qed.
 
@@ -434,14 +432,13 @@ Proof.
   exists 0%nat; unfold I; rewrite Rmult_0_l; rewrite Rplus_0_r;
     assumption.
   cut (Nbound I).
-  intro; assert (H2 := Nzorn H0 H1); elim H2; intros; exists x; elim p; intros;
+  intro; assert (H2 := Nzorn H0 H1); elim H2; intros x p; exists x; elim p; intros;
     split.
   apply H3.
-  case (total_order_T (a + INR (S x) * del) b); intro.
-  elim s; intro.
-  assert (H5 := H4 (S x) a0); elim (le_Sn_n _ H5).
+  destruct (total_order_T (a + INR (S x) * del) b) as [[Hlt|Heq]|Hgt].
+  assert (H5 := H4 (S x) Hlt); elim (le_Sn_n _ H5).
   right; symmetry ; assumption.
-  left; apply r.
+  left; apply Hgt.
   assert (H1 : 0 <= (b - a) / del).
   unfold Rdiv; apply Rmult_le_pos;
     [ apply Rge_le; apply Rge_minus; apply Rle_ge; left; apply H
@@ -509,22 +506,24 @@ Proof.
             | apply Rmin_r ]
           | intros; apply H3; try assumption; apply Rlt_le_trans with (Rmin x (b - a));
             [ assumption | apply Rmin_l ] ].
-  assert (H3 := completeness E H1 H2); elim H3; intros; cut (0 < x <= b - a).
+  assert (H3 := completeness E H1 H2); elim H3; intros x p; cut (0 < x <= b - a).
   intro; elim H4; clear H4; intros; exists (mkposreal _ H4); split.
   apply H5.
   unfold is_lub in p; elim p; intros; unfold is_upper_bound in H6;
-    set (D := Rabs (x0 - y)); elim (classic (exists y : R, D < y /\ E y));
-      intro.
+    set (D := Rabs (x0 - y)).
+  assert (H11: ((exists y : R, D < y /\ E y) \/ (forall y : R, not (D < y /\ E y)) -> False) -> False).
+    clear; intros H; apply H.
+    right; intros y0 H0; apply H.
+    left; now exists y0.
+  apply Rnot_le_lt; intros H30.
+  apply H11; clear H11; intros H11.
+  revert H30; apply Rlt_not_le.
+  destruct H11 as [H11|H12].
   elim H11; intros; elim H12; clear H12; intros; unfold E in H13; elim H13;
     intros; apply H15; assumption.
-  assert (H12 := not_ex_all_not _ (fun y:R => D < y /\ E y) H11);
-    assert (H13 : is_upper_bound E D).
+  assert (H13 : is_upper_bound E D).
   unfold is_upper_bound; intros; assert (H14 := H12 x1);
-    elim (not_and_or (D < x1) (E x1) H14); intro.
-  case (Rle_dec x1 D); intro.
-  assumption.
-  elim H15; auto with real.
-  elim H15; assumption.
+    apply Rnot_lt_le; contradict H14; now split.
   assert (H14 := H7 _ H13); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H10)).
   unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros;
     split.
@@ -544,17 +543,16 @@ Lemma Heine_cor2 :
           a <= x <= b ->
           a <= y <= b -> Rabs (x - y) < delta -> Rabs (f x - f y) < eps }.
 Proof.
-  intro f; intros; case (total_order_T a b); intro.
-  elim s; intro.
-  assert (H0 := Heine_cor1 a0 H eps); elim H0; intros; exists x;
+  intro f; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
+  assert (H0 := Heine_cor1 Hlt H eps); elim H0; intros x p; exists x;
     elim p; intros; apply H2; assumption.
   exists (mkposreal _ Rlt_0_1); intros; assert (H3 : x = y);
-    [ elim H0; elim H1; intros; rewrite b0 in H3; rewrite b0 in H5;
+    [ elim H0; elim H1; intros; rewrite Heq in H3, H5;
       apply Rle_antisym; apply Rle_trans with b; assumption
       | rewrite H3; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
         apply (cond_pos eps) ].
   exists (mkposreal _ Rlt_0_1); intros; elim H0; intros;
-    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) r)).
+    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H3 H4) Hgt)).
 Qed.
 
 Lemma SubEqui_P1 :
@@ -567,7 +565,7 @@ Lemma SubEqui_P2 :
   forall (a b:R) (del:posreal) (h:a < b),
     pos_Rl (SubEqui del h) (pred (Rlength (SubEqui del h))) = b.
 Proof.
-  intros; unfold SubEqui; case (maxN del h); intros; clear a0;
+  intros; unfold SubEqui; destruct (maxN del h)as (x,_).
     cut
       (forall (x:nat) (a:R) (del:posreal),
         pos_Rl (SubEquiN (S x) a b del)
@@ -623,8 +621,8 @@ Proof.
     simpl in H; inversion H.
   rewrite (SubEqui_P6 del h (i:=(max_N del h))).
   replace (S (max_N del h)) with (pred (Rlength (SubEqui del h))).
-  rewrite SubEqui_P2; unfold max_N; case (maxN del h); intros; left;
-    elim a0; intros; assumption.
+  rewrite SubEqui_P2; unfold max_N; case (maxN del h) as (?&?&?); left;
+    assumption.
   rewrite SubEqui_P5; reflexivity.
   apply lt_n_Sn.
   repeat rewrite SubEqui_P6.
@@ -678,11 +676,11 @@ Proof.
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rlt_Rminus; assumption ] ].
   assert (H2 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; left; assumption ].
+  apply Rlt_le in H.
+  unfold Rmin; decide (Rle_dec a b) with H; reflexivity.
   assert (H3 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; left; assumption ].
+  apply Rlt_le in H.
+  unfold Rmax; decide (Rle_dec a b) with H; reflexivity.
   elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4;
     elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi;
       split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a)))));
@@ -727,7 +725,7 @@ Proof.
     elim (lt_n_O _ H9).
   unfold co_interval in H10; elim H10; clear H10; intros; rewrite Rabs_right.
   rewrite SubEqui_P5 in H9; simpl in H9; inversion H9.
-  apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)).
+  apply Rplus_lt_reg_l with (pos_Rl (SubEqui del H) (max_N del H)).
   replace
   (pos_Rl (SubEqui del H) (max_N del H) +
     (t - pos_Rl (SubEqui del H) (max_N del H))) with t;
@@ -738,10 +736,10 @@ Proof.
   rewrite H13 in H12; rewrite SubEqui_P2 in H12; apply H12.
   rewrite SubEqui_P6.
   2: apply lt_n_Sn.
-  unfold max_N; case (maxN del H); intros; elim a0; clear a0;
-    intros _ H13; replace (a + INR x * del + del) with (a + INR (S x) * del);
+  unfold max_N; destruct (maxN del H) as (?&?&H13);
+    replace (a + INR x * del + del) with (a + INR (S x) * del);
       [ assumption | rewrite S_INR; ring ].
-  apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) I);
+  apply Rplus_lt_reg_l with (pos_Rl (SubEqui del H) I);
     replace (pos_Rl (SubEqui del H) I + (t - pos_Rl (SubEqui del H) I)) with t;
     [ idtac | ring ];
     replace (pos_Rl (SubEqui del H) I + del) with (pos_Rl (SubEqui del H) (S I)).
@@ -759,7 +757,7 @@ Proof.
     intros; assumption.
   assert (H4 : Nbound I).
   unfold Nbound; exists (S (max_N del H)); intros; unfold max_N;
-    case (maxN del H); intros; elim a0; clear a0; intros _ H5;
+    destruct (maxN del H) as (?&_&H5);
       apply INR_le; apply Rmult_le_reg_l with (pos del).
   apply (cond_pos del).
   apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del);
@@ -767,12 +765,12 @@ Proof.
       apply Rle_trans with b; try assumption; elim H8; intros;
         assumption.
   elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat).
-  unfold max_N; case (maxN del H); intros; apply INR_lt;
+  unfold max_N; case (maxN del H) as (?&?&?); apply INR_lt;
     apply Rmult_lt_reg_l with (pos del).
   apply (cond_pos del).
-  apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del);
+  apply Rplus_lt_reg_l with a; do 2 rewrite (Rmult_comm del);
     apply Rle_lt_trans with t0; unfold I in H5; try assumption;
-      elim a0; intros; apply Rlt_le_trans with b; try assumption;
+      apply Rlt_le_trans with b; try assumption;
         elim H8; intros.
   elim H11; intro.
   assumption.
@@ -791,8 +789,8 @@ Proof.
   elim H0; assumption.
   rewrite SubEqui_P5; reflexivity.
   rewrite SubEqui_P6.
-  case (Rle_dec (a + INR (S N) * del) t0); intro.
-  assert (H11 := H6 (S N) r); elim (le_Sn_n _ H11).
+  destruct (Rle_dec (a + INR (S N) * del) t0) as [Hle|Hnle].
+  assert (H11 := H6 (S N) Hle); elim (le_Sn_n _ H11).
   auto with real.
   apply le_lt_n_Sm; assumption.
 Qed.
@@ -805,8 +803,8 @@ Proof.
   intros; simpl; unfold fct_cte; replace t with a.
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; right;
     reflexivity.
-  generalize H; unfold Rmin, Rmax; case (Rle_dec a a); intros; elim H0;
-    intros; apply Rle_antisym; assumption.
+  generalize H; unfold Rmin, Rmax; decide (Rle_dec a a) with (Rle_refl a).
+    intros (?,?); apply Rle_antisym; assumption.
   rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps).
 Qed.
 
@@ -815,10 +813,9 @@ Lemma continuity_implies_RiemannInt :
     a <= b ->
     (forall x:R, a <= x <= b -> continuity_pt f x) -> Riemann_integrable f a b.
 Proof.
-  intros; case (total_order_T a b); intro;
-    [ elim s; intro;
-      [ apply RiemannInt_P6; assumption | rewrite b0; apply RiemannInt_P7 ]
-      | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)) ].
+  intros; destruct (total_order_T a b) as [[Hlt| -> ]|Hgt];
+      [ apply RiemannInt_P6; assumption | apply RiemannInt_P7
+      | elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)) ].
 Qed.
 
 Lemma RiemannInt_P8 :
@@ -826,9 +823,9 @@ Lemma RiemannInt_P8 :
     (pr2:Riemann_integrable f b a), RiemannInt pr1 = - RiemannInt pr2.
 Proof.
   intro f; intros; eapply UL_sequence.
-  unfold RiemannInt; case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    intros; apply u.
-  unfold RiemannInt; case (RiemannInt_exists pr2 RinvN RinvN_cv);
+  unfold RiemannInt; destruct (RiemannInt_exists pr1 RinvN RinvN_cv) as (?,HUn);
+    apply HUn.
+  unfold RiemannInt; destruct (RiemannInt_exists pr2 RinvN RinvN_cv) as (?,HUn);
     intros;
       cut
         (exists psi1 : nat -> StepFun a b,
@@ -857,7 +854,7 @@ Proof.
     [ assumption
       | unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right;
         left; apply (cond_pos (RinvN n)) ].
-  clear H1; unfold Un_cv in u; elim (u _ H3); clear u; intros N1 H1;
+  clear H1; destruct (HUn _ H3) as (N1,H1);
     exists (max N0 N1); intros; unfold R_dist;
       apply Rle_lt_trans with
         (Rabs
@@ -881,7 +878,7 @@ Proof.
         -1 *
         RiemannInt_SF (mkStepFun (StepFun_P6 (pre (phi_sequence RinvN pr2 n)))));
       [ idtac | ring ]; rewrite <- StepFun_P30.
-  case (Rle_dec a b); intro.
+  destruct (Rle_dec a b) as [Hle|Hnle].
   apply Rle_lt_trans with
     (RiemannInt_SF
       (mkStepFun
@@ -903,11 +900,9 @@ Proof.
   (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
   [ apply Rabs_triang | ring ].
   assert (H7 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hle; reflexivity.
   assert (H8 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hle; reflexivity.
   apply Rplus_le_compat.
   elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
     rewrite H7; rewrite H8.
@@ -956,11 +951,9 @@ Proof.
   (phi_sequence RinvN pr1 n x0 - f x0 + (f x0 - phi_sequence RinvN pr2 n x0));
   [ apply Rabs_triang | ring ].
   assert (H7 : Rmin a b = b).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ elim n0; assumption | reflexivity ].
+  unfold Rmin; decide (Rle_dec a b) with Hnle; reflexivity.
   assert (H8 : Rmax a b = a).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ elim n0; assumption | reflexivity ].
+  unfold Rmax; decide (Rle_dec a b) with Hnle; reflexivity.
   apply Rplus_le_compat.
   elim (H0 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H9;
     rewrite H7; rewrite H8.
@@ -1007,15 +1000,6 @@ Proof.
       | discrR ].
 Qed.
 
-Lemma Req_EM_T : forall r1 r2:R, {r1 = r2} + {r1 <> r2}.
-Proof.
-  intros; elim (total_order_T r1 r2); intros;
-    [ elim a; intro;
-      [ right; red; intro; rewrite H in a0; elim (Rlt_irrefl r2 a0)
-        | left; assumption ]
-      | right; red; intro; rewrite H in b; elim (Rlt_irrefl r2 b) ].
-Qed.
-
 (* L1([a,b]) is a vectorial space *)
 Lemma RiemannInt_P10 :
   forall (f g:R -> R) (a b l:R),
@@ -1023,10 +1007,9 @@ Lemma RiemannInt_P10 :
     Riemann_integrable g a b ->
     Riemann_integrable (fun x:R => f x + l * g x) a b.
 Proof.
-  unfold Riemann_integrable; intros f g; intros; case (Req_EM_T l 0);
-    intro.
-  elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0;
-    intros; split; try assumption; rewrite e; intros;
+  unfold Riemann_integrable; intros f g; intros; destruct (Req_EM_T l 0) as [Heq|Hneq].
+  elim (X eps); intros x p; split with x; elim p; intros x0 p0; split with x0; elim p0;
+    intros; split; try assumption; rewrite Heq; intros;
       rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption.
   assert (H : 0 < eps / 2).
   unfold Rdiv; apply Rmult_lt_0_compat;
@@ -1036,9 +1019,9 @@ Proof.
     [ apply (cond_pos eps)
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
-  elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros;
+  elim (X (mkposreal _ H)); intros x p; elim (X0 (mkposreal _ H0)); intros x0 p0;
     split with (mkStepFun (StepFun_P28 l x x0)); elim p0;
-      elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2));
+      elim p; intros x1 p1 x2 p2. split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2));
         elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split.
   intros; simpl;
     apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))).
@@ -1113,18 +1096,14 @@ Proof.
   rewrite (Rplus_comm (psi1 n x)); apply Rplus_le_compat.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; elim (H1 n); intros; apply H7.
   assert (H10 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity.
   assert (H11 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity.
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   elim (H0 n); intros; apply H7; assert (H10 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity.
   assert (H11 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity.
   rewrite H10; rewrite H11; elim H6; intros; split; left; assumption.
   rewrite StepFun_P30; rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat.
   apply Rlt_trans with (pos (un n)).
@@ -1256,10 +1235,10 @@ Lemma RiemannInt_P12 :
 Proof.
   intro f; intros; case (Req_dec l 0); intro.
   pattern l at 2; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r;
-    unfold RiemannInt; case (RiemannInt_exists pr3 RinvN RinvN_cv);
-      case (RiemannInt_exists pr1 RinvN RinvN_cv); intros;
+    unfold RiemannInt; destruct (RiemannInt_exists pr3 RinvN RinvN_cv) as (?,HUn_cv);
+      destruct (RiemannInt_exists pr1 RinvN RinvN_cv) as (?,HUn_cv0); intros.
         eapply UL_sequence;
-          [ apply u0
+          [ apply HUn_cv
             | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n));
               set (psi2 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n));
                 apply RiemannInt_P11 with f RinvN (phi_sequence RinvN pr1) psi1 psi2;
@@ -1278,22 +1257,22 @@ Proof.
                             [ apply H2; assumption | rewrite H0; ring ] ]
                     | assumption ] ].
   eapply UL_sequence.
-  unfold RiemannInt; case (RiemannInt_exists pr3 RinvN RinvN_cv);
-    intros; apply u.
+  unfold RiemannInt; destruct (RiemannInt_exists pr3 RinvN RinvN_cv) as (?,HUn_cv);
+    intros; apply HUn_cv.
   unfold Un_cv; intros; unfold RiemannInt;
-    case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv); unfold Un_cv;
       intros; assert (H2 : 0 < eps / 5).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv);
+  elim (HUn_cv0 _ H2); clear HUn_cv0; intros N0 H3; assert (H4 := RinvN_cv);
     unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4;
       assert (H5 : 0 < eps / (5 * Rabs l)).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption
       | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;
         [ prove_sup0 | apply Rabs_pos_lt; assumption ] ].
-  elim (u _ H5); clear u; intros N2 H6; assert (H7 := RinvN_cv);
+  elim (HUn_cv _ H5); clear HUn_cv; intros N2 H6; assert (H7 := RinvN_cv);
     unfold Un_cv in H7; elim (H7 _ H5); clear H7 H5; intros N3 H5;
       unfold R_dist in H3, H4, H5, H6; set (N := max (max N0 N1) (max N2 N3)).
   assert (H7 : forall n:nat, (n >= N1)%nat -> RinvN n < eps / 5).
@@ -1381,11 +1360,9 @@ Proof.
         (RiemannInt_SF (phi_sequence RinvN pr1 n) +
           l * RiemannInt_SF (phi_sequence RinvN pr2 n)));
       [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with H; reflexivity.
   assert (H11 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with H; reflexivity.
   rewrite H10 in H7; rewrite H10 in H8; rewrite H10 in H9; rewrite H11 in H7;
     rewrite H11 in H8; rewrite H11 in H9;
       apply Rle_lt_trans with
@@ -1495,7 +1472,7 @@ Lemma RiemannInt_P13 :
     (pr3:Riemann_integrable (fun x:R => f x + l * g x) a b),
     RiemannInt pr3 = RiemannInt pr1 + l * RiemannInt pr2.
 Proof.
-  intros; case (Rle_dec a b); intro;
+  intros; destruct (Rle_dec a b) as [Hle|Hnle];
     [ apply RiemannInt_P12; assumption
       | assert (H : b <= a);
         [ auto with real
@@ -1526,9 +1503,9 @@ Lemma RiemannInt_P15 :
   forall (a b c:R) (pr:Riemann_integrable (fct_cte c) a b),
     RiemannInt pr = c * (b - a).
 Proof.
-  intros; unfold RiemannInt; case (RiemannInt_exists pr RinvN RinvN_cv);
+  intros; unfold RiemannInt; destruct (RiemannInt_exists pr RinvN RinvN_cv) as (?,HUn_cv);
     intros; eapply UL_sequence.
-  apply u.
+  apply HUn_cv.
   set (phi1 := fun N:nat => phi_sequence RinvN pr N);
     change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) (c * (b - a)));
       set (f := fct_cte c);
@@ -1574,18 +1551,18 @@ Lemma Rle_cv_lim :
   forall (Un Vn:nat -> R) (l1 l2:R),
     (forall n:nat, Un n <= Vn n) -> Un_cv Un l1 -> Un_cv Vn l2 -> l1 <= l2.
 Proof.
-  intros; case (Rle_dec l1 l2); intro.
+  intros; destruct (Rle_dec l1 l2) as [Hle|Hnle].
   assumption.
   assert (H2 : l2 < l1).
   auto with real.
-  clear n; assert (H3 : 0 < (l1 - l2) / 2).
+  assert (H3 : 0 < (l1 - l2) / 2).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ apply Rlt_Rminus; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   elim (H1 _ H3); elim (H0 _ H3); clear H0 H1; unfold R_dist; intros;
     set (N := max x x0); cut (Vn N < Un N).
   intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (H N) H4)).
   apply Rlt_trans with ((l1 + l2) / 2).
-  apply Rplus_lt_reg_r with (- l2);
+  apply Rplus_lt_reg_l with (- l2);
     replace (- l2 + (l1 + l2) / 2) with ((l1 - l2) / 2).
   rewrite Rplus_comm; apply Rle_lt_trans with (Rabs (Vn N - l2)).
   apply RRle_abs.
@@ -1596,7 +1573,7 @@ Proof.
         repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
           [ ring | discrR ]
       | discrR ].
-  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1;
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_l with l1;
     replace (l1 + - ((l1 + l2) / 2)) with ((l1 - l2) / 2).
   apply Rle_lt_trans with (Rabs (Un N - l1)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
@@ -1615,9 +1592,9 @@ Lemma RiemannInt_P17 :
     a <= b -> Rabs (RiemannInt pr1) <= RiemannInt pr2.
 Proof.
   intro f; intros; unfold RiemannInt;
-    case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
-      set (phi1 := phi_sequence RinvN pr1) in u0;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv);
+      set (phi1 := phi_sequence RinvN pr1) in HUn_cv0;
         set (phi2 := fun N:nat => mkStepFun (StepFun_P32 (phi1 N)));
           apply Rle_cv_lim with
             (fun N:nat => Rabs (RiemannInt_SF (phi1 N)))
@@ -1672,10 +1649,10 @@ Lemma RiemannInt_P18 :
     (forall x:R, a < x < b -> f x = g x) -> RiemannInt pr1 = RiemannInt pr2.
 Proof.
   intro f; intros; unfold RiemannInt;
-    case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv); intros;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x0,HUn_cv0);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x,HUn_cv);
       eapply UL_sequence.
-  apply u0.
+  apply HUn_cv0.
   set (phi1 := fun N:nat => phi_sequence RinvN pr1 N);
     change (Un_cv (fun N:nat => RiemannInt_SF (phi1 N)) x);
       assert
@@ -1718,48 +1695,48 @@ Proof.
   apply RinvN_cv.
   intro; elim (H2 n); intros; split; try assumption.
   intros; unfold phi2_m; simpl; unfold phi2_aux;
-    case (Req_EM_T t a); case (Req_EM_T t b); intros.
-  rewrite e0; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
+    destruct (Req_EM_T t a) as [Heqa|Hneqa]; destruct (Req_EM_T t b) as [Heqb|Hneqb].
+  rewrite Heqa; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern a at 3; rewrite <- e0; apply H3; assumption.
-  rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  pattern a at 3; rewrite <- Heqa; apply H3; assumption.
+  rewrite Heqa; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern a at 3; rewrite <- e; apply H3; assumption.
-  rewrite e; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
+  pattern a at 3; rewrite <- Heqa; apply H3; assumption.
+  rewrite Heqb; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     apply Rle_trans with (Rabs (g t - phi2 n t)).
   apply Rabs_pos.
-  pattern b at 3; rewrite <- e; apply H3; assumption.
+  pattern b at 3; rewrite <- Heqb; apply H3; assumption.
   replace (f t) with (g t).
   apply H3; assumption.
   symmetry ; apply H0; elim H5; clear H5; intros.
   assert (H7 : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n2; assumption ].
+  unfold Rmin; destruct (Rle_dec a b) as [Heqab|Hneqab];
+    [ reflexivity | elim Hneqab; assumption ].
   assert (H8 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n2; assumption ].
+  unfold Rmax; destruct (Rle_dec a b) as [Heqab|Hneqab];
+    [ reflexivity | elim Hneqab; assumption ].
   rewrite H7 in H5; rewrite H8 in H6; split.
-  elim H5; intro; [ assumption | elim n1; symmetry ; assumption ].
-  elim H6; intro; [ assumption | elim n0; assumption ].
+  elim H5; intro; [ assumption | elim Hneqa; symmetry ; assumption ].
+  elim H6; intro; [ assumption | elim Hneqb; assumption ].
   cut (forall N:nat, RiemannInt_SF (phi2_m N) = RiemannInt_SF (phi2 N)).
-  intro; unfold Un_cv; intros; elim (u _ H4); intros; exists x1; intros;
+  intro; unfold Un_cv; intros; elim (HUn_cv _ H4); intros; exists x1; intros;
     rewrite (H3 n); apply H5; assumption.
   intro; apply Rle_antisym.
   apply StepFun_P37; try assumption.
   intros; unfold phi2_m; simpl; unfold phi2_aux;
-    case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
-  elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
-  elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
-  elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+    destruct (Req_EM_T x1 a) as [Heqa|Hneqa]; destruct (Req_EM_T x1 b) as [Heqb|Hneqb].
+  elim H3; intros; rewrite Heqa in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite Heqa in H4; elim (Rlt_irrefl _ H4).
+  elim H3; intros; rewrite Heqb in H5; elim (Rlt_irrefl _ H5).
   right; reflexivity.
   apply StepFun_P37; try assumption.
   intros; unfold phi2_m; simpl; unfold phi2_aux;
-    case (Req_EM_T x1 a); case (Req_EM_T x1 b); intros.
-  elim H3; intros; rewrite e0 in H4; elim (Rlt_irrefl _ H4).
-  elim H3; intros; rewrite e in H4; elim (Rlt_irrefl _ H4).
-  elim H3; intros; rewrite e in H5; elim (Rlt_irrefl _ H5).
+    destruct (Req_EM_T x1 a) as [ -> |Hneqa].
+  elim H3; intros; elim (Rlt_irrefl _ H4).
+  destruct (Req_EM_T x1 b) as [ -> |Hneqb].
+  elim H3; intros; elim (Rlt_irrefl _ H5).
   right; reflexivity.
   intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2;
     unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2];
@@ -1775,21 +1752,19 @@ Proof.
   apply le_O_n.
   apply lt_trans with (pred (Rlength l)); [ assumption | apply lt_pred_n_n ].
   apply neq_O_lt; intro; rewrite <- H12 in H6; discriminate.
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with H; reflexivity.
   assert (H11 : pos_Rl l (S i) <= b).
   replace b with (Rmax a b).
   rewrite <- H4; elim (RList_P6 l); intros; apply H11.
   assumption.
   apply lt_le_S; assumption.
   apply lt_pred_n_n; apply neq_O_lt; intro; rewrite <- H13 in H6; discriminate.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  elim H7; clear H7; intros; unfold phi2_aux; case (Req_EM_T x1 a);
-    case (Req_EM_T x1 b); intros.
-  rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
-  rewrite e in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
-  rewrite e in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+  unfold Rmax; decide (Rle_dec a b) with H; reflexivity.
+  elim H7; clear H7; intros; unfold phi2_aux; destruct (Req_EM_T x1 a) as [Heq|Hneq];
+    destruct (Req_EM_T x1 b) as [Heq'|Hneq'].
+  rewrite Heq' in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
+  rewrite Heq in H7; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H10 H7)).
+  rewrite Heq' in H12; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H12)).
   reflexivity.
 Qed.
 
@@ -1852,17 +1827,17 @@ Proof.
   intros; replace (primitive h pr a) with 0.
   replace (RiemannInt pr0) with (primitive h pr b).
   ring.
-  unfold primitive; case (Rle_dec a b); case (Rle_dec b b); intros;
+  unfold primitive; destruct (Rle_dec a b) as [Hle|[]]; destruct (Rle_dec b b) as [Hle'|Hnle'];
     [ apply RiemannInt_P5
-      | elim n; right; reflexivity
-      | elim n; assumption
-      | elim n0; assumption ].
-  symmetry ; unfold primitive; case (Rle_dec a a);
-    case (Rle_dec a b); intros;
+      | destruct Hnle'; right; reflexivity
+      | assumption
+      | assumption].
+  symmetry ; unfold primitive; destruct (Rle_dec a a) as [Hle|[]];
+    destruct (Rle_dec a b) as [Hle'|Hnle'];
       [ apply RiemannInt_P9
-        | elim n; assumption
-        | elim n; right; reflexivity
-        | elim n0; right; reflexivity ].
+        | elim Hnle'; assumption
+        | right; reflexivity
+        | right; reflexivity ].
 Qed.
 
 Lemma RiemannInt_P21 :
@@ -1906,34 +1881,29 @@ Proof.
   intro; cut (IsStepFun psi3 a c).
   intro; split with (mkStepFun X); split with (mkStepFun X2); simpl;
     split.
-  intros; unfold phi3, psi3; case (Rle_dec t b); case (Rle_dec a t);
-    intros.
+  intros; unfold phi3, psi3; case (Rle_dec t b) as [|Hnle]; case (Rle_dec a t) as [|Hnle'].
   elim H1; intros; apply H3.
   replace (Rmin a b) with a.
   replace (Rmax a b) with b.
   split; assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  elim n; replace a with (Rmin a c).
+  unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity.
+  unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity.
+  elim Hnle'; replace a with (Rmin a c).
   elim H0; intros; assumption.
-  unfold Rmin; case (Rle_dec a c); intro;
-    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
+  unfold Rmin; case (Rle_dec a c) as [|[]];
+    [ reflexivity | apply Rle_trans with b; assumption ].
   elim H2; intros; apply H3.
   replace (Rmax b c) with (Rmax a c).
   elim H0; intros; split; try assumption.
   replace (Rmin b c) with b.
   auto with real.
-  unfold Rmin; case (Rle_dec b c); intro;
-    [ reflexivity | elim n0; assumption ].
-  unfold Rmax; case (Rle_dec a c); case (Rle_dec b c); intros;
-    try (elim n0; assumption || elim n0; apply Rle_trans with b; assumption).
-  reflexivity.
-  elim n; replace a with (Rmin a c).
+  unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity.
+  unfold Rmax; decide (Rle_dec b c) with Hyp2; case (Rle_dec a c) as [|[]];
+    [ reflexivity | apply Rle_trans with b; assumption ].
+  elim Hnle'; replace a with (Rmin a c).
   elim H0; intros; assumption.
-  unfold Rmin; case (Rle_dec a c); intro;
-    [ reflexivity | elim n1; apply Rle_trans with b; assumption ].
+  unfold Rmin; case (Rle_dec a c) as [|[]];
+    [ reflexivity | apply Rle_trans with b; assumption ].
   rewrite <- (StepFun_P43 X0 X1 X2).
   apply Rle_lt_trans with
     (Rabs (RiemannInt_SF (mkStepFun X0)) + Rabs (RiemannInt_SF (mkStepFun X1))).
@@ -1947,33 +1917,33 @@ Proof.
   apply Rle_antisym.
   apply StepFun_P37; try assumption.
   simpl; intros; unfold psi3; elim H0; clear H0; intros;
-    case (Rle_dec a x); case (Rle_dec x b); intros;
-      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+    destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle'];
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H0))
         | right; reflexivity
-        | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
-        | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+        | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ]
+        | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ].
   apply StepFun_P37; try assumption.
   simpl; intros; unfold psi3; elim H0; clear H0; intros;
-    case (Rle_dec a x); case (Rle_dec x b); intros;
-      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H0))
+    destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle'];
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H0))
         | right; reflexivity
-        | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
-        | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+        | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ]
+        | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ].
   apply Rle_antisym.
   apply StepFun_P37; try assumption.
   simpl; intros; unfold psi3; elim H0; clear H0; intros;
-    case (Rle_dec a x); case (Rle_dec x b); intros;
+    destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle'];
       [ right; reflexivity
-        | elim n; left; assumption
-        | elim n; left; assumption
-        | elim n0; left; assumption ].
+        | elim Hnle'; left; assumption
+        | elim Hnle; left; assumption
+        | elim Hnle; left; assumption ].
   apply StepFun_P37; try assumption.
   simpl; intros; unfold psi3; elim H0; clear H0; intros;
-    case (Rle_dec a x); case (Rle_dec x b); intros;
+    destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle'];
       [ right; reflexivity
-        | elim n; left; assumption
-        | elim n; left; assumption
-        | elim n0; left; assumption ].
+        | elim Hnle'; left; assumption
+        | elim Hnle; left; assumption
+        | elim Hnle; left; assumption ].
   apply StepFun_P46 with b; assumption.
   assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
@@ -1990,14 +1960,14 @@ Proof.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
     apply neq_O_lt; red; intro; rewrite <- H12 in H6;
       discriminate.
-  unfold Rmin; case (Rle_dec b c); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec b c) with Hyp2;
+    reflexivity.
   elim H7; intros; assumption.
-  case (Rle_dec a x); case (Rle_dec x b); intros;
-    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+  destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle'];
+    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H10))
       | reflexivity
-      | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
-      | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+      | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ]
+      | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ].
   assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
       split with lf1; unfold adapted_couple in H3; decompose [and] H3;
@@ -2012,8 +1982,7 @@ Proof.
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6;
     discriminate.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity.
   assert (H11 : a <= x).
   apply Rle_trans with (pos_Rl l1 i).
   replace a with (Rmin a b).
@@ -2022,11 +1991,9 @@ Proof.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
     apply neq_O_lt; red; intro; rewrite <- H13 in H6;
       discriminate.
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity.
   left; elim H7; intros; assumption.
-  case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n;
-    assumption.
+  decide (Rle_dec a x) with H11; decide (Rle_dec x b) with H10; reflexivity.
   apply StepFun_P46 with b.
   assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
@@ -2042,8 +2009,7 @@ Proof.
   rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption.
   apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H12 in H6;
     discriminate.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp1; reflexivity.
   assert (H11 : a <= x).
   apply Rle_trans with (pos_Rl l1 i).
   replace a with (Rmin a b).
@@ -2052,10 +2018,9 @@ Proof.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
     apply neq_O_lt; red; intro; rewrite <- H13 in H6;
       discriminate.
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp1; reflexivity.
   left; elim H7; intros; assumption.
-  unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros;
+  unfold phi3; decide (Rle_dec a x) with H11; decide (Rle_dec x b) with H10;
     reflexivity || elim n; assumption.
   assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3;
     elim H3; clear H3; intros l1 [lf1 H3]; split with l1;
@@ -2072,14 +2037,13 @@ Proof.
   apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n;
     apply neq_O_lt; red; intro; rewrite <- H12 in H6;
       discriminate.
-  unfold Rmin; case (Rle_dec b c); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec b c) with Hyp2; reflexivity.
   elim H7; intros; assumption.
-  unfold phi3; case (Rle_dec a x); case (Rle_dec x b); intros;
-    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10))
+  unfold phi3; destruct (Rle_dec a x) as [Hle|Hnle]; destruct (Rle_dec x b) as [Hle'|Hnle']; intros;
+    [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H10))
       | reflexivity
-      | elim n; apply Rle_trans with b; [ assumption | left; assumption ]
-      | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ].
+      | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ]
+      | elim Hnle; apply Rle_trans with b; [ assumption | left; assumption ] ].
 Qed.
 
 Lemma RiemannInt_P22 :
@@ -2098,21 +2062,10 @@ Proof.
   split; assumption.
   split with (mkStepFun H3); split with (mkStepFun H4); split.
   simpl; intros; apply H.
-  replace (Rmin a b) with (Rmin a c).
-  elim H5; intros; split; try assumption.
+  replace (Rmin a b) with (Rmin a c) by (rewrite 2!Rmin_left; eauto using Rle_trans).
+  destruct H5; split; try assumption.
   apply Rle_trans with (Rmax a c); try assumption.
-  replace (Rmax a b) with b.
-  replace (Rmax a c) with c.
-  assumption.
-  unfold Rmax; case (Rle_dec a c); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin; case (Rle_dec a c); case (Rle_dec a b); intros;
-    [ reflexivity
-      | elim n; apply Rle_trans with c; assumption
-      | elim n; assumption
-      | elim n0; assumption ].
+  apply Rle_max_compat_l; assumption.
   rewrite Rabs_right.
   assert (H5 : IsStepFun psi c b).
   apply StepFun_P46 with a.
@@ -2130,15 +2083,11 @@ Proof.
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
-  replace (Rmin a b) with a.
-  replace (Rmax a b) with b.
-  elim H6; intros; split; left.
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
+  destruct H6; split; left.
   apply Rle_lt_trans with c; assumption.
   assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
   apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
   apply RRle_abs.
@@ -2160,15 +2109,11 @@ Proof.
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
-  replace (Rmin a b) with a.
-  replace (Rmax a b) with b.
-  elim H5; intros; split; left.
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
+  destruct H5; split; left.
   assumption.
   apply Rlt_le_trans with c; assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
 Qed.
 
@@ -2191,18 +2136,10 @@ Proof.
   replace (Rmax a b) with (Rmax c b).
   elim H5; intros; split; try assumption.
   apply Rle_trans with (Rmin c b); try assumption.
-  replace (Rmin a b) with a.
-  replace (Rmin c b) with c.
-  assumption.
-  unfold Rmin; case (Rle_dec c b); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmax; case (Rle_dec c b); case (Rle_dec a b); intros;
-    [ reflexivity
-      | elim n; apply Rle_trans with c; assumption
-      | elim n; assumption
-      | elim n0; assumption ].
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
   rewrite Rabs_right.
   assert (H5 : IsStepFun psi a c).
   apply StepFun_P46 with b.
@@ -2220,15 +2157,11 @@ Proof.
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
-  replace (Rmin a b) with a.
-  replace (Rmax a b) with b.
-  elim H6; intros; split; left.
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
+  destruct H6; split; left.
   assumption.
   apply Rlt_le_trans with c; assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
   apply Rle_lt_trans with (Rabs (RiemannInt_SF psi)).
   apply RRle_abs.
@@ -2250,15 +2183,11 @@ Proof.
     apply Rle_trans with (Rabs (f x - phi x)).
   apply Rabs_pos.
   apply H.
-  replace (Rmin a b) with a.
-  replace (Rmax a b) with b.
-  elim H5; intros; split; left.
+  rewrite Rmin_left; eauto using Rle_trans.
+  rewrite Rmax_right; eauto using Rle_trans.
+  destruct H5; split; left.
   apply Rle_lt_trans with c; assumption.
   assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; apply Rle_trans with c; assumption ].
   rewrite StepFun_P18; ring.
 Qed.
 
@@ -2291,16 +2220,15 @@ Lemma RiemannInt_P25 :
     a <= b -> b <= c -> RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
 Proof.
   intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt;
-    case (RiemannInt_exists pr1 RinvN RinvN_cv);
-    case (RiemannInt_exists pr2 RinvN RinvN_cv);
-    case (RiemannInt_exists pr3 RinvN RinvN_cv); intros;
+    case (RiemannInt_exists pr1 RinvN RinvN_cv) as (x1,HUn_cv1);
+    case (RiemannInt_exists pr2 RinvN RinvN_cv) as (x0,HUn_cv0);
+    case (RiemannInt_exists pr3 RinvN RinvN_cv) as (x,HUn_cv);
       symmetry ; eapply UL_sequence.
-  apply u.
+  apply HUn_cv.
   unfold Un_cv; intros; assert (H0 : 0 < eps / 3).
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim (u1 _ H0); clear u1; intros N1 H1; elim (u0 _ H0); clear u0;
-    intros N2 H2;
+  destruct (HUn_cv1 _ H0) as (N1,H1); clear HUn_cv1; destruct (HUn_cv0 _ H0) as (N2,H2); clear HUn_cv0;
       cut
         (Un_cv
           (fun n:nat =>
@@ -2357,7 +2285,7 @@ Proof.
       do 2 rewrite (Rmult_comm 3); repeat rewrite Rmult_assoc;
         rewrite <- Rinv_l_sym; [ ring | discrR ]
       | discrR ].
-  clear x u x0 x1 eps H H0 N1 H1 N2 H2;
+  clear x HUn_cv x0 x1 eps H H0 N1 H1 N2 H2;
     assert
       (H1 :
         exists psi1 : nat -> StepFun a b,
@@ -2477,25 +2405,17 @@ Proof.
   apply Rplus_le_compat.
   apply H1.
   elim H14; intros; split.
-  replace (Rmin a c) with a.
+  rewrite Rmin_left; eauto using Rle_trans.
   apply Rle_trans with b; try assumption.
   left; assumption.
-  unfold Rmin; case (Rle_dec a c); intro;
-    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-  replace (Rmax a c) with c.
+  rewrite Rmax_right; eauto using Rle_trans.
   left; assumption.
-  unfold Rmax; case (Rle_dec a c); intro;
-    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   apply H3.
   elim H14; intros; split.
-  replace (Rmin b c) with b.
+  rewrite Rmin_left; eauto using Rle_trans.
   left; assumption.
-  unfold Rmin; case (Rle_dec b c); intro;
-    [ reflexivity | elim n0; assumption ].
-  replace (Rmax b c) with c.
+  rewrite Rmax_right; eauto using Rle_trans.
   left; assumption.
-  unfold Rmax; case (Rle_dec b c); intro;
-    [ reflexivity | elim n0; assumption ].
   do 2
     rewrite <-
       (Rplus_comm
@@ -2509,26 +2429,18 @@ Proof.
   apply Rplus_le_compat.
   apply H1.
   elim H14; intros; split.
-  replace (Rmin a c) with a.
+  rewrite Rmin_left; eauto using Rle_trans.
   left; assumption.
-  unfold Rmin; case (Rle_dec a c); intro;
-    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
-  replace (Rmax a c) with c.
+  rewrite Rmax_right; eauto using Rle_trans.
   apply Rle_trans with b.
   left; assumption.
   assumption.
-  unfold Rmax; case (Rle_dec a c); intro;
-    [ reflexivity | elim n0; apply Rle_trans with b; assumption ].
   apply H8.
   elim H14; intros; split.
-  replace (Rmin a b) with a.
+  rewrite Rmin_left; trivial.
   left; assumption.
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
-  replace (Rmax a b) with b.
+  rewrite Rmax_right; trivial.
   left; assumption.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n0; assumption ].
   do 2 rewrite StepFun_P30.
   do 2 rewrite Rmult_1_l;
     replace
@@ -2571,27 +2483,27 @@ Lemma RiemannInt_P26 :
     (pr2:Riemann_integrable f b c) (pr3:Riemann_integrable f a c),
     RiemannInt pr1 + RiemannInt pr2 = RiemannInt pr3.
 Proof.
-  intros; case (Rle_dec a b); case (Rle_dec b c); intros.
+  intros; destruct (Rle_dec a b) as [Hle|Hnle]; destruct (Rle_dec b c) as [Hle'|Hnle'].
   apply RiemannInt_P25; assumption.
-  case (Rle_dec a c); intro.
+  destruct (Rle_dec a c) as [Hle''|Hnle''].
   assert (H : c <= b).
   auto with real.
-  rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 r0 H);
+  rewrite <- (RiemannInt_P25 pr3 (RiemannInt_P1 pr2) pr1 Hle'' H);
     rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2)); ring.
   assert (H : c <= a).
   auto with real.
   rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
-    rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H r);
+    rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr3) pr1 (RiemannInt_P1 pr2) H Hle);
       rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
   assert (H : b <= a).
   auto with real.
-  case (Rle_dec a c); intro.
-  rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H r0);
+  destruct (Rle_dec a c) as [Hle''|Hnle''].
+  rewrite <- (RiemannInt_P25 (RiemannInt_P1 pr1) pr3 pr2 H Hle'');
     rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1)); ring.
   assert (H0 : c <= a).
   auto with real.
   rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
-    rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) r H0);
+    rewrite <- (RiemannInt_P25 pr2 (RiemannInt_P1 pr3) (RiemannInt_P1 pr1) Hle' H0);
       rewrite (RiemannInt_P8 pr3 (RiemannInt_P1 pr3)); ring.
   rewrite (RiemannInt_P8 pr1 (RiemannInt_P1 pr1));
     rewrite (RiemannInt_P8 pr2 (RiemannInt_P1 pr2));
@@ -2616,13 +2528,13 @@ Proof.
       assert (H4 : 0 < del).
   unfold del; unfold Rmin; case (Rle_dec (b - x) (x - a));
     intro.
-  case (Rle_dec x0 (b - x)); intro;
+  destruct (Rle_dec x0 (b - x)) as [Hle|Hnle];
     [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
-  case (Rle_dec x0 (x - a)); intro;
+  destruct (Rle_dec x0 (x - a)) as [Hle'|Hnle'];
     [ elim H3; intros; assumption | apply Rlt_Rminus; assumption ].
   split with (mkposreal _ H4); intros;
     assert (H7 : Riemann_integrable f x (x + h0)).
-  case (Rle_dec x (x + h0)); intro.
+  destruct (Rle_dec x (x + h0)) as [Hle''|Hnle''].
   apply continuity_implies_RiemannInt; try assumption.
   intros; apply C0; elim H7; intros; split.
   apply Rle_trans with x; [ left; assumption | assumption ].
@@ -2659,7 +2571,7 @@ Proof.
     with ((RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) / h0).
   replace (RiemannInt H7 - RiemannInt (RiemannInt_P14 x (x + h0) (f x))) with
   (RiemannInt (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x)))).
-  unfold Rdiv; rewrite Rabs_mult; case (Rle_dec x (x + h0)); intro.
+  unfold Rdiv; rewrite Rabs_mult; destruct (Rle_dec x (x + h0)) as [Hle|Hnle].
   apply Rle_lt_trans with
     (RiemannInt
       (RiemannInt_P16
@@ -2678,14 +2590,14 @@ Proof.
   apply Rabs_pos.
   apply RiemannInt_P19; try assumption.
   intros; replace (f x1 + -1 * fct_cte (f x) x1) with (f x1 - f x).
-  unfold fct_cte; case (Req_dec x x1); intro.
+  unfold fct_cte; destruct (Req_dec x x1) as [H9|H9].
   rewrite H9; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; left;
     assumption.
-  elim H3; intros; left; apply H11.
+  elim H3; intros; left; apply  H11.
   repeat split.
   assumption.
   rewrite Rabs_right.
-  apply Rplus_lt_reg_r with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
+  apply Rplus_lt_reg_l with x; replace (x + (x1 - x)) with x1; [ idtac | ring ].
   apply Rlt_le_trans with (x + h0).
   elim H8; intros; assumption.
   apply Rplus_le_compat_l; apply Rle_trans with del.
@@ -2707,8 +2619,8 @@ Proof.
   apply Rinv_r_sym.
   assumption.
   apply Rle_ge; left; apply Rinv_0_lt_compat.
-  elim r; intro.
-  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+  elim Hle; intro.
+  apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; assumption.
   elim H5; symmetry ; apply Rplus_eq_reg_l with x; rewrite Rplus_0_r;
     assumption.
   apply Rle_lt_trans with
@@ -2748,7 +2660,7 @@ Proof.
   repeat split.
   assumption.
   rewrite Rabs_left.
-  apply Rplus_lt_reg_r with (x1 - x0); replace (x1 - x0 + x0) with x1;
+  apply Rplus_lt_reg_l with (x1 - x0); replace (x1 - x0 + x0) with x1;
     [ idtac | ring ].
   replace (x1 - x0 + - (x1 - x)) with (x - x0); [ idtac | ring ].
   apply Rle_lt_trans with (x + h0).
@@ -2758,7 +2670,7 @@ Proof.
   apply Rle_trans with del;
     [ left; assumption | unfold del; apply Rmin_l ].
   elim H8; intros; assumption.
-  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
+  apply Rplus_lt_reg_l with x; rewrite Rplus_0_r;
     replace (x + (x1 - x)) with x1; [ elim H8; intros; assumption | ring ].
   unfold fct_cte; ring.
   rewrite RiemannInt_P15.
@@ -2778,7 +2690,7 @@ Proof.
   apply Rinv_lt_0_compat.
   assert (H8 : x + h0 < x).
   auto with real.
-  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r; assumption.
+  apply Rplus_lt_reg_l with x; rewrite Rplus_0_r; assumption.
   rewrite
     (RiemannInt_P13 H7 (RiemannInt_P14 x (x + h0) (f x))
       (RiemannInt_P10 (-1) H7 (RiemannInt_P14 x (x + h0) (f x))))
@@ -2792,9 +2704,11 @@ Proof.
   cut (a <= x + h0).
   cut (x + h0 <= b).
   intros; unfold primitive.
-  case (Rle_dec a (x + h0)); case (Rle_dec (x + h0) b); case (Rle_dec a x);
-  case (Rle_dec x b); intros; try (elim n; assumption || left; assumption).
-  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r0 r) H7 (FTC_P1 h C0 r2 r1)); ring.
+  assert (H10: a <= x) by (left; assumption).
+  assert (H11: x <= b) by (left; assumption).
+  decide (Rle_dec a (x + h0)) with H9; decide (Rle_dec (x + h0) b) with H8;
+  decide (Rle_dec a x) with H10; decide (Rle_dec x b) with H11.
+  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 H10 H11) H7 (FTC_P1 h C0 H9 H8)); ring.
   apply Rplus_le_reg_l with (- x); replace (- x + (x + h0)) with h0;
     [ idtac | ring ].
   rewrite Rplus_comm; apply Rle_trans with (Rabs h0).
@@ -2854,11 +2768,11 @@ Proof.
     unfold R_dist; intros; set (del := Rmin x0 (Rmin x1 (b - a)));
       assert (H10 : 0 < del).
   unfold del; unfold Rmin; case (Rle_dec x1 (b - a)); intros.
-  case (Rle_dec x0 x1); intro;
+  destruct (Rle_dec x0 x1) as [Hle|Hnle];
     [ apply (cond_pos x0) | elim H9; intros; assumption ].
-  case (Rle_dec x0 (b - a)); intro;
+  destruct (Rle_dec x0 (b - a)) as [Hle'|Hnle'];
     [ apply (cond_pos x0) | apply Rlt_Rminus; assumption ].
-  split with (mkposreal _ H10); intros; case (Rcase_abs h0); intro.
+  split with (mkposreal _ H10); intros; destruct (Rcase_abs h0) as [Hle|Hnle].
   assert (H14 : b + h0 < b).
   pattern b at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
@@ -2914,7 +2828,7 @@ Proof.
   repeat split.
   assumption.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
-  apply Rplus_lt_reg_r with (x2 - x1);
+  apply Rplus_lt_reg_l with (x2 - x1);
     replace (x2 - x1 + (b - x2)) with (b - x1); [ idtac | ring ].
   replace (x2 - x1 + x1) with x2; [ idtac | ring ].
   apply Rlt_le_trans with (b + h0).
@@ -2957,11 +2871,11 @@ Proof.
       | assumption ].
   cut (a <= b + h0).
   cut (b + h0 <= b).
-  intros; unfold primitive; case (Rle_dec a (b + h0));
-    case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b);
-    intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
-  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring.
-  elim n; assumption.
+  intros; unfold primitive; destruct (Rle_dec a (b + h0)) as [Hle'|Hnle'];
+    destruct (Rle_dec (b + h0) b) as [Hle''|[]]; destruct (Rle_dec a b) as [Hleab|[]]; destruct (Rle_dec b b) as [Hlebb|[]];
+    assumption || (right; reflexivity) || (try (left; assumption)).
+  rewrite <- (RiemannInt_P26 (FTC_P1 h C0 Hle' Hle'') H13 (FTC_P1 h C0 Hleab Hlebb)); ring.
+  elim Hnle'; assumption.
   left; assumption.
   apply Rplus_le_reg_l with (- a - h0).
   replace (- a - h0 + a) with (- h0); [ idtac | ring ].
@@ -2979,22 +2893,22 @@ Proof.
     [ assumption | unfold del; apply Rmin_l ].
   assert (H14 : b < b + h0).
   pattern b at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-  assert (H14 := Rge_le _ _ r); elim H14; intro.
+  assert (H14 := Rge_le _ _ Hnle); elim H14; intro.
   assumption.
   elim H11; symmetry ; assumption.
-  unfold primitive; case (Rle_dec a (b + h0));
-    case (Rle_dec (b + h0) b); intros;
-      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14))
+  unfold primitive; destruct (Rle_dec a (b + h0)) as [Hle|[]];
+    destruct (Rle_dec (b + h0) b) as [Hle'|Hnle'];
+      [ elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H14))
         | unfold f_b; reflexivity
-        | elim n; left; apply Rlt_trans with b; assumption
-        | elim n0; left; apply Rlt_trans with b; assumption ].
+        | left; apply Rlt_trans with b; assumption
+        | left; apply Rlt_trans with b; assumption ].
   unfold f_b; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rmult_0_r; rewrite Rplus_0_l; unfold primitive;
-      case (Rle_dec a b); case (Rle_dec b b); intros;
+      destruct (Rle_dec a b) as [Hle'|Hnle']; destruct (Rle_dec b b) as [Hle''|[]];
         [ apply RiemannInt_P5
-          | elim n; right; reflexivity
-          | elim n; left; assumption
-          | elim n; right; reflexivity ].
+          | right; reflexivity
+          | elim Hnle'; left; assumption
+          | right; reflexivity ].
 (*****)
   set (f_a := fun x:R => f a * (x - a)); rewrite <- H2;
     assert (H3 : derivable_pt_lim f_a a (f a)).
@@ -3028,16 +2942,18 @@ Proof.
   apply (cond_pos x0).
   apply Rlt_Rminus; assumption.
   split with (mkposreal _ H9).
-  intros; case (Rcase_abs h0); intro.
+  intros; destruct (Rcase_abs h0) as [Hle|Hnle].
   assert (H12 : a + h0 < a).
   pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
   unfold primitive.
-  case (Rle_dec a (a + h0)); case (Rle_dec (a + h0) b); case (Rle_dec a a);
-  case (Rle_dec a b); intros;
-    try (elim n; left; assumption) || (elim n; right; reflexivity).
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H12)).
-  elim n; left; apply Rlt_trans with a; assumption.
+  destruct (Rle_dec a (a + h0)) as [Hle'|Hnle'];
+  destruct (Rle_dec (a + h0) b) as [Hle''|Hnle''];
+  destruct (Rle_dec a a) as [Hleaa|[]];
+  destruct (Rle_dec a b) as [Hleab|[]];
+    try (left; assumption) || (right; reflexivity).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle' H12)).
+  elim Hnle''; left; apply Rlt_trans with a; assumption.
   rewrite RiemannInt_P9; replace 0 with (f_a a).
   replace (f a * (a + h0 - a)) with (f_a (a + h0)).
   apply H5; try assumption.
@@ -3045,10 +2961,10 @@ Proof.
     [ assumption | unfold del; apply Rmin_l ].
   unfold f_a; ring.
   unfold f_a; ring.
-  elim n; left; apply Rlt_trans with a; assumption.
+  elim Hnle''; left; apply Rlt_trans with a; assumption.
   assert (H12 : a < a + h0).
   pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-  assert (H12 := Rge_le _ _ r); elim H12; intro.
+  assert (H12 := Rge_le _ _ Hnle); elim H12; intro.
   assumption.
   elim H10; symmetry ; assumption.
   assert (H13 : Riemann_integrable f a (a + h0)).
@@ -3097,7 +3013,7 @@ Proof.
   elim H8; intros; left; apply H17; repeat split.
   assumption.
   rewrite Rabs_right.
-  apply Rplus_lt_reg_r with a; replace (a + (x2 - a)) with x2; [ idtac | ring ].
+  apply Rplus_lt_reg_l with a; replace (a + (x2 - a)) with x2; [ idtac | ring ].
   apply Rlt_le_trans with (a + h0).
   elim H14; intros; assumption.
   apply Rplus_le_compat_l; left; apply Rle_lt_trans with (Rabs h0).
@@ -3121,7 +3037,7 @@ Proof.
   rewrite Rplus_comm; unfold Rminus; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym;
       [ reflexivity | assumption ].
-  apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ r);
+  apply Rle_ge; left; apply Rinv_0_lt_compat; assert (H14 := Rge_le _ _ Hnle);
     elim H14; intro.
   assumption.
   elim H10; symmetry ; assumption.
@@ -3136,13 +3052,13 @@ Proof.
       rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ ring | assumption ].
   cut (a <= a + h0).
   cut (a + h0 <= b).
-  intros; unfold primitive; case (Rle_dec a (a + h0));
-    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
-    intros; try (elim n; right; reflexivity) || (elim n; left; assumption).
+  intros; unfold primitive.
+  decide (Rle_dec (a+h0) b) with H14.
+  decide (Rle_dec a a) with (Rle_refl a).
+  decide (Rle_dec a (a+h0)) with H15.
+  decide (Rle_dec a b) with h.
   rewrite RiemannInt_P9; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; apply RiemannInt_P5.
-  elim n; assumption.
-  elim n; assumption.
   2: left; assumption.
   apply Rplus_le_reg_l with (- a); replace (- a + (a + h0)) with h0;
     [ idtac | ring ].
@@ -3189,18 +3105,18 @@ Proof.
   unfold derivable_pt_lim; intros; elim (H2 _ H4); intros;
     elim (H3 _ H4); intros; set (del := Rmin x0 x1).
   assert (H7 : 0 < del).
-  unfold del; unfold Rmin; case (Rle_dec x0 x1); intro.
+  unfold del; unfold Rmin; destruct (Rle_dec x0 x1) as [Hle|Hnle].
   apply (cond_pos x0).
   apply (cond_pos x1).
-  split with (mkposreal _ H7); intros; case (Rcase_abs h0); intro.
+  split with (mkposreal _ H7); intros; destruct (Rcase_abs h0) as [Hle|Hnle].
   assert (H10 : a + h0 < a).
   pattern a at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
-  rewrite H1; unfold primitive; case (Rle_dec a (a + h0));
-    case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b);
-    intros; try (elim n; right; assumption || reflexivity).
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)).
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
+  rewrite H1; unfold primitive.
+  apply (decide_left (Rle_dec a b) h); intro h'.
+  assert (H11:~ a<=a+h0) by auto using Rlt_not_le.
+  decide (Rle_dec a (a+h0)) with H11.
+  decide (Rle_dec a a) with (Rle_refl a).
   rewrite RiemannInt_P9; replace 0 with (f_a a).
   replace (f a * (a + h0 - a)) with (f_a (a + h0)).
   apply H5; try assumption.
@@ -3208,27 +3124,26 @@ Proof.
   unfold del; apply Rmin_l.
   unfold f_a; ring.
   unfold f_a; ring.
-  elim n; rewrite <- H0; left; assumption.
   assert (H10 : a < a + h0).
   pattern a at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
-  assert (H10 := Rge_le _ _ r); elim H10; intro.
+  assert (H10 := Rge_le _ _ Hnle); elim H10; intro.
   assumption.
   elim H8; symmetry ; assumption.
-  rewrite H0 in H1; rewrite H1; unfold primitive;
-    case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b);
-    case (Rle_dec a b); case (Rle_dec b b); intros;
-      try (elim n; right; assumption || reflexivity).
-  rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)).
-  repeat rewrite RiemannInt_P9.
-  replace (RiemannInt (FTC_P1 h C0 r1 r0)) with (f_b b).
+  rewrite H0 in H1; rewrite H1; unfold primitive.
+  decide (Rle_dec a b) with h.
+  decide (Rle_dec b b) with (Rle_refl b).
+  assert (H12 : a<=b+h0) by (eauto using Rlt_le_trans with real).
+  decide (Rle_dec a (b+h0)) with H12.
+  rewrite H0 in H10.
+  assert (H13 : ~b+h0<=b) by (auto using Rlt_not_le).
+  decide (Rle_dec (b+h0) b) with H13.
+  replace (RiemannInt (FTC_P1 h C0 hbis H11)) with (f_b b).
   fold (f_b (b + h0)).
   apply H6; try assumption.
   apply Rlt_le_trans with del; try assumption.
   unfold del; apply Rmin_r.
   unfold f_b; unfold Rminus; rewrite Rplus_opp_r;
     rewrite Rmult_0_r; rewrite Rplus_0_l; apply RiemannInt_P5.
-  elim n; rewrite <- H0; left; assumption.
-  elim n0; rewrite <- H0; left; assumption.
 Qed.
 
 Lemma RiemannInt_P29 :
@@ -3266,7 +3181,7 @@ Qed.
 Lemma RiemannInt_P32 :
   forall (f:C1_fun) (a b:R), Riemann_integrable (derive f (diff0 f)) a b.
 Proof.
-  intro f; intros; case (Rle_dec a b); intro;
+  intro f; intros; destruct (Rle_dec a b) as [Hle|Hnle];
     [ apply continuity_implies_RiemannInt; try assumption; intros;
       apply (cont1 f)
       | assert (H : b <= a);
@@ -3296,10 +3211,45 @@ Lemma FTC_Riemann :
   forall (f:C1_fun) (a b:R) (pr:Riemann_integrable (derive f (diff0 f)) a b),
     RiemannInt pr = f b - f a.
 Proof.
-  intro f; intros; case (Rle_dec a b); intro;
+  intro f; intros; destruct (Rle_dec a b) as [Hle|Hnle];
     [ apply RiemannInt_P33; assumption
       | assert (H : b <= a);
         [ auto with real
           | assert (H0 := RiemannInt_P1 pr); rewrite (RiemannInt_P8 pr H0);
             rewrite (RiemannInt_P33 _ H0 H); ring ] ].
 Qed.
+
+(* RiemannInt *)
+Lemma RiemannInt_const_bound :
+  forall f a b l u (h : Riemann_integrable f a b), a <= b ->
+    (forall x, a < x < b -> l <= f x <= u) ->
+    l * (b - a) <= RiemannInt h <= u * (b - a).
+intros f a b l u ri ab intf.
+rewrite <- !(fun l => RiemannInt_P15 (RiemannInt_P14 a b l)).
+split; apply RiemannInt_P19; try assumption;
+ intros x intx; unfold fct_cte; destruct (intf x intx); assumption.
+Qed.
+
+Lemma Riemann_integrable_scal :
+  forall f a b k, 
+     Riemann_integrable f a b ->
+     Riemann_integrable (fun x => k * f x) a b.
+intros f a b k ri.
+apply Riemann_integrable_ext with
+   (f := fun x => 0 + k * f x).
+ intros; ring.
+apply (RiemannInt_P10 _ (RiemannInt_P14 _ _ 0) ri).
+Qed.
+
+Arguments Riemann_integrable_scal [f a b] k _ eps.
+
+Lemma Riemann_integrable_Ropp :
+  forall f a b, Riemann_integrable f a b -> 
+    Riemann_integrable (fun x => - f x) a b.
+intros ff a b h.
+apply Riemann_integrable_ext with (f := fun x => (-1) * ff x).
+intros; ring.
+apply Riemann_integrable_scal; assumption.
+Qed.
+
+Arguments Riemann_integrable_Ropp [f a b] _ eps.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index 8eb49bf3..1484ab2a 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -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        *)
@@ -40,26 +40,25 @@ Proof.
   assert (H2 :  exists x : R, E x).
   elim H; intros; exists (INR x); unfold E; exists x; split;
     [ assumption | reflexivity ].
-  assert (H3 := completeness E H1 H2); elim H3; intros; unfold is_lub in p;
-    elim p; clear p; intros; unfold is_upper_bound in H4, H5;
+  destruct (completeness E H1 H2) as (x,(H4,H5)); unfold is_upper_bound in H4, H5;
       assert (H6 : 0 <= x).
-  elim H2; intros; unfold E in H6; elim H6; intros; elim H7; intros;
+  destruct H2 as (x0,H6). remember H6 as H7. destruct H7 as (x1,(H8,H9)).
     apply Rle_trans with x0;
       [ rewrite <- H9; change (INR 0 <= INR x1); apply le_INR;
         apply le_O_n
         | apply H4; assumption ].
   assert (H7 := archimed x); elim H7; clear H7; intros;
     assert (H9 : x <= IZR (up x) - 1).
-  apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros;
-    elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1;
+  apply H5; intros x0 H9. assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros x1 (H12,<-).
+    apply Rplus_le_reg_l with 1;
       replace (1 + (IZR (up x) - 1)) with (IZR (up x));
       [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1));
       [ idtac | rewrite S_INR; ring ].
   assert (H14 : (0 <= up x)%Z).
   apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
-  assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15;
-    rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S;
-      apply INR_lt; rewrite H13; apply Rle_lt_trans with x;
+  destruct (IZN _ H14) as (x2,H15).
+    rewrite H15, <- INR_IZR_INZ; apply le_INR; apply lt_le_S.
+      apply INR_lt; apply Rle_lt_trans with x;
         [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ].
   assert (H10 : x = IZR (up x) - 1).
   apply Rle_antisym;
@@ -70,32 +69,32 @@ Proof.
         [ assumption | ring ] ].
   assert (H11 : (0 <= up x)%Z).
   apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ].
-  assert (H12 := IZN_var H11); elim H12; clear H12; intros; assert (H13 : E x).
+  assert (H12 := IZN_var H11); elim H12; clear H12; intros x0 H8; assert (H13 : E x).
   elim (classic (E x)); intro; try assumption.
   cut (forall y:R, E y -> y <= x - 1).
-  intro; assert (H14 := H5 _ H13); cut (x - 1 < x).
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)).
+  intro H13; assert (H14 := H5 _ H13); cut (x - 1 < x).
+  intro H15; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H14 H15)).
   apply Rminus_lt; replace (x - 1 - x) with (-1); [ idtac | ring ];
     rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply Rlt_0_1.
-  intros; assert (H14 := H4 _ H13); elim H14; intro; unfold E in H13; elim H13;
-    intros; elim H16; intros; apply Rplus_le_reg_l with 1.
+  intros y H13; assert (H14 := H4 _ H13); elim H14; intro H15; unfold E in H13; elim H13;
+    intros x1 H16; elim H16; intros H17 H18; apply Rplus_le_reg_l with 1.
   replace (1 + (x - 1)) with x; [ idtac | ring ]; rewrite <- H18;
     replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ].
   cut (x = INR (pred x0)).
-  intro; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18;
+  intro H19; rewrite H19; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H18;
     rewrite <- H19; assumption.
-  rewrite H10; rewrite p; rewrite <- INR_IZR_INZ; replace 1 with (INR 1);
+  rewrite H10; rewrite H8; rewrite <- INR_IZR_INZ; replace 1 with (INR 1);
     [ idtac | reflexivity ]; rewrite <- minus_INR.
   replace (x0 - 1)%nat with (pred x0);
   [ reflexivity
     | case x0; [ reflexivity | intro; simpl; apply minus_n_O ] ].
-  induction  x0 as [| x0 Hrecx0];
-    [ rewrite p in H7; rewrite <- INR_IZR_INZ in H7; simpl in H7;
-      elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H7))
-      | apply le_n_S; apply le_O_n ].
-  rewrite H15 in H13; elim H12; assumption.
+  induction x0 as [|x0 Hrecx0].
+    rewrite H8 in H3. rewrite <- INR_IZR_INZ in H3; simpl in H3.
+      elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 H3)).
+    apply le_n_S; apply le_O_n.
+    rewrite H15 in H13; elim H12; assumption.
   split with (pred x0); unfold E in H13; elim H13; intros; elim H12; intros;
-    rewrite H10 in H15; rewrite p in H15; rewrite <- INR_IZR_INZ in H15;
+    rewrite H10 in H15; rewrite H8 in H15; rewrite <- INR_IZR_INZ in H15;
       assert (H16 : INR x0 = INR x1 + 1).
   rewrite H15; ring.
   rewrite <- S_INR in H16; assert (H17 := INR_eq _ _ H16); rewrite H17;
@@ -144,7 +143,7 @@ Definition subdivision (a b:R) (f:StepFun a b) : Rlist := projT1 (pre f).
 
 Definition subdivision_val (a b:R) (f:StepFun a b) : Rlist :=
   match projT2 (pre f) with
-    | existT a b => a
+    | existT _ a b => a
   end.
 
 Fixpoint Int_SF (l k:Rlist) : R :=
@@ -173,8 +172,8 @@ Lemma StepFun_P1 :
   forall (a b:R) (f:StepFun a b),
     adapted_couple f a b (subdivision f) (subdivision_val f).
 Proof.
-  intros a b f; unfold subdivision_val; case (projT2 (pre f)); intros;
-    apply a0.
+  intros a b f; unfold subdivision_val; case (projT2 (pre f)) as (x,H);
+    apply H.
 Qed.
 
 Lemma StepFun_P2 :
@@ -201,19 +200,17 @@ Proof.
   intros; unfold adapted_couple; repeat split.
   unfold ordered_Rlist; intros; simpl in H0; inversion H0;
     [ simpl; assumption | elim (le_Sn_O _ H2) ].
-  simpl; unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  simpl; unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  simpl; unfold Rmin; decide (Rle_dec a b) with H; reflexivity.
+  simpl; unfold Rmax; decide (Rle_dec a b) with H; reflexivity.
   unfold constant_D_eq, open_interval; intros; simpl in H0;
     inversion H0; [ reflexivity | elim (le_Sn_O _ H3) ].
 Qed.
 
 Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b.
 Proof.
-  intros; unfold IsStepFun; case (Rle_dec a b); intro.
+  intros; unfold IsStepFun; destruct (Rle_dec a b) as [Hle|Hnle].
   apply existT with (cons a (cons b nil)); unfold is_subdivision;
-    apply existT with (cons c nil); apply (StepFun_P3 c r).
+    apply existT with (cons c nil); apply (StepFun_P3 c Hle).
   apply existT with (cons b (cons a nil)); unfold is_subdivision;
     apply existT with (cons c nil); apply StepFun_P2;
       apply StepFun_P3; auto with real.
@@ -244,17 +241,15 @@ Lemma StepFun_P7 :
 Proof.
   unfold adapted_couple; intros; decompose [and] H0; clear H0;
     assert (H5 : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with H; reflexivity.
   assert (H7 : r2 <= b).
   rewrite H5 in H2; rewrite <- H2; apply RList_P7;
     [ assumption | simpl; right; left; reflexivity ].
   repeat split.
   apply RList_P4 with r1; assumption.
-  rewrite H5 in H2; unfold Rmin; case (Rle_dec r2 b); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmax; case (Rle_dec r2 b); intro;
-    [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ].
+  rewrite H5 in H2; unfold Rmin; decide (Rle_dec r2 b) with H7; reflexivity.
+  unfold Rmax; decide (Rle_dec r2 b) with H7.
+    rewrite H5 in H2; rewrite <- H2; reflexivity.
   simpl in H4; simpl; apply INR_eq; apply Rplus_eq_reg_l with 1;
     do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR;
       rewrite H4; reflexivity.
@@ -340,33 +335,28 @@ Proof.
   apply H6.
   rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1;
     decompose [and] H1; clear H1; simpl in H9; rewrite H9;
-      unfold Rmin; case (Rle_dec a b); intro;
-        [ reflexivity | elim n; assumption ].
+      unfold Rmin; decide (Rle_dec a b) with H0; reflexivity.
   elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro.
   exists (cons a (cons b nil)); exists (cons r1 nil);
     unfold adapted_couple_opt; unfold adapted_couple;
       repeat split.
   unfold ordered_Rlist; intros; simpl in H8; inversion H8;
     [ simpl; assumption | elim (le_Sn_O _ H10) ].
-  simpl; unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  simpl; unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  simpl; unfold Rmin; decide (Rle_dec a b) with H0; reflexivity.
+  simpl; unfold Rmax; decide (Rle_dec a b) with H0; reflexivity.
   intros; simpl in H8; inversion H8.
   unfold constant_D_eq, open_interval; intros; simpl;
     simpl in H9; rewrite H3 in H1; unfold adapted_couple in H1;
       decompose [and] H1; apply (H16 0%nat).
   simpl; apply lt_O_Sn.
   unfold open_interval; simpl; rewrite H7; simpl in H13;
-    rewrite H13; unfold Rmin; case (Rle_dec a b);
-      intro; [ assumption | elim n; assumption ].
+    rewrite H13; unfold Rmin; decide (Rle_dec a b) with H0; assumption.
   elim (le_Sn_O _ H10).
   intros; simpl in H8; elim (lt_n_O _ H8).
   intros; simpl in H8; inversion H8;
     [ simpl; assumption | elim (le_Sn_O _ H10) ].
   assert (Hyp_min : Rmin t2 b = t2).
-  unfold Rmin; case (Rle_dec t2 b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec t2 b) with H5; reflexivity.
   unfold adapted_couple in H6; elim H6; clear H6; intros;
     elim (RList_P20 _ (StepFun_P9 H6 H7)); intros s1 [s2 [s3 H9]];
       induction  lf' as [| r2 lf' Hreclf'].
@@ -391,18 +381,16 @@ Proof.
     apply (H16 (S i)); simpl; assumption.
   simpl; simpl in H14; rewrite H14; reflexivity.
   simpl; simpl in H18; rewrite H18; unfold Rmax;
-    case (Rle_dec a b); case (Rle_dec t2 b); intros; reflexivity || elim n;
-      assumption.
+    decide (Rle_dec a b) with H0; decide (Rle_dec t2 b) with H5; reflexivity.
   simpl; simpl in H20; apply H20.
   intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
-  simpl; simpl in H6; case (total_order_T x t2); intro.
-  elim s; intro.
+  simpl; simpl in H6; destruct (total_order_T x t2) as [[Hlt|Heq]|Hgt].
   apply (H17 0%nat);
     [ simpl; apply lt_O_Sn
       | unfold open_interval; simpl; elim H6; intros; split;
         assumption ].
-  rewrite b0; assumption.
+  rewrite Heq; assumption.
   rewrite H10; apply (H22 0%nat);
     [ simpl; apply lt_O_Sn
       | unfold open_interval; simpl; replace s1 with t2;
@@ -440,8 +428,7 @@ Proof.
       assumption.
   simpl; simpl in H19; apply H19.
   rewrite H9; simpl; simpl in H13; rewrite H13; unfold Rmax;
-    case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
-      assumption.
+    decide (Rle_dec t2 b) with H5; decide (Rle_dec a b) with H0; reflexivity.
   rewrite H9; simpl; simpl in H15; rewrite H15; reflexivity.
   intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
@@ -483,8 +470,7 @@ Proof.
       assumption.
   simpl; simpl in H18; apply H18.
   rewrite H9; simpl; simpl in H12; rewrite H12; unfold Rmax;
-    case (Rle_dec t2 b); case (Rle_dec a b); intros; reflexivity || elim n;
-      assumption.
+    decide (Rle_dec t2 b) with H5; decide (Rle_dec a b) with H0; reflexivity.
   rewrite H9; simpl; simpl in H14; rewrite H14; reflexivity.
   intros; simpl in H1; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
@@ -511,8 +497,7 @@ Proof.
     clear H1; clear H H7 H9; cut (Rmax a b = b);
       [ intro; rewrite H in H5; rewrite <- H5; apply RList_P7;
         [ assumption | simpl; right; left; reflexivity ]
-        | unfold Rmax; case (Rle_dec a b); intro;
-          [ reflexivity | elim n; assumption ] ].
+        | unfold Rmax; decide (Rle_dec a b) with H0; reflexivity ].
 Qed.
 
 Lemma StepFun_P11 :
@@ -528,7 +513,7 @@ Proof.
   simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity.
   assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro.
   assert (H15 := H7 0%nat (lt_O_Sn _)); simpl in H15; elim H15; intro.
-  rewrite <- H12 in H1; case (Rle_dec r1 s2); intro; try assumption.
+  rewrite <- H12 in H1; destruct (Rle_dec r1 s2) as [Hle|Hnle]; try assumption.
   assert (H16 : s2 < r1); auto with real.
   induction  s3 as [| r0 s3 Hrecs3].
   simpl in H9; rewrite H9 in H16; cut (r1 <= Rmax a b).
@@ -662,12 +647,11 @@ Lemma StepFun_P13 :
     adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) ->
     adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2.
 Proof.
-  intros; case (total_order_T a b); intro.
-  elim s; intro.
-  eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ].
+  intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
+  eapply StepFun_P11; [ apply Hlt | apply H0 | apply H1 ].
   elim H; assumption.
   eapply StepFun_P11;
-    [ apply r0 | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ].
+    [ apply Hgt | apply StepFun_P2; apply H0 | apply StepFun_P12; apply H1 ].
 Qed.
 
 Lemma StepFun_P14 :
@@ -689,11 +673,9 @@ Proof.
     case (Req_dec a b); intro.
   rewrite (StepFun_P8 H2 H4); rewrite (StepFun_P8 H H4); reflexivity.
   assert (Hyp_min : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with H1; reflexivity.
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with H1; reflexivity.
   elim (RList_P20 _ (StepFun_P9 H H4)); intros s1 [s2 [s3 H5]]; rewrite H5 in H;
     rewrite H5; induction  lf1 as [| r3 lf1 Hreclf1].
   unfold adapted_couple in H2; decompose [and] H2;
@@ -883,8 +865,8 @@ Lemma StepFun_P15 :
     adapted_couple f a b l1 lf1 ->
     adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2.
 Proof.
-  intros; case (Rle_dec a b); intro;
-    [ apply (StepFun_P14 r H H0)
+  intros; destruct (Rle_dec a b) as [Hle|Hnle];
+    [ apply (StepFun_P14 Hle H H0)
       | assert (H1 : b <= a);
         [ auto with real
           | eapply StepFun_P14;
@@ -897,8 +879,8 @@ Lemma StepFun_P16 :
     exists l' : Rlist,
       (exists lf' : Rlist, adapted_couple_opt f a b l' lf').
 Proof.
-  intros; case (Rle_dec a b); intro;
-    [ apply (StepFun_P10 r H)
+  intros; destruct (Rle_dec a b) as [Hle|Hnle];
+    [ apply (StepFun_P10 Hle H)
       | assert (H1 : b <= a);
         [ auto with real
           | assert (H2 := StepFun_P10 H1 (StepFun_P2 H)); elim H2;
@@ -961,9 +943,8 @@ Lemma StepFun_P21 :
   forall (a b:R) (f:R -> R) (l:Rlist),
     is_subdivision f a b l -> adapted_couple f a b l (FF l f).
 Proof.
-  intros; unfold adapted_couple; unfold is_subdivision in X;
-    unfold adapted_couple in X; elim X; clear X; intros;
-      decompose [and] p; clear p; repeat split; try assumption.
+  intros * (x & H & H1 & H0 & H2 & H4).
+  repeat split; try assumption.
   apply StepFun_P20; rewrite H2; apply lt_O_Sn.
   intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5;
     unfold constant_D_eq, open_interval; intros;
@@ -1003,11 +984,9 @@ Lemma StepFun_P22 :
 Proof.
   unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity.
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity.
   apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0;
     decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0;
@@ -1221,13 +1200,13 @@ Proof.
   [ apply lt_n_S; assumption
     | symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
       intro; rewrite <- H22 in H21; elim (lt_n_O _ H21) ].
-  elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+  elim (Rle_dec (pos_Rl lf (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro a0.
   assert (H23 : (S x0 <= x0)%nat).
   apply H20; unfold I; split; assumption.
   elim (le_Sn_n _ H23).
   assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lf (S x0)).
   auto with real.
-  clear b0; apply RList_P17; try assumption.
+  clear a0; apply RList_P17; try assumption.
   apply RList_P2; assumption.
   elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left;
     elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27;
@@ -1255,11 +1234,9 @@ Lemma StepFun_P24 :
 Proof.
   unfold is_subdivision; intros a b f g lf lg Hyp X X0; elim X; elim X0;
     clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a).
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with Hyp; reflexivity.
   assert (Hyp_max : Rmax a b = b).
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with Hyp; reflexivity.
   apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0;
     decompose [and] p; decompose [and] p0; clear p p0;
       rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0;
@@ -1471,12 +1448,12 @@ Proof.
   apply lt_n_S; assumption.
   symmetry ; apply S_pred with 0%nat; apply neq_O_lt; red;
     intro; rewrite <- H22 in H21; elim (lt_n_O _ H21).
-  elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro.
+  elim (Rle_dec (pos_Rl lg (S x0)) (pos_Rl (cons_ORlist lf lg) i)); intro a0.
   assert (H23 : (S x0 <= x0)%nat);
     [ apply H20; unfold I; split; assumption | elim (le_Sn_n _ H23) ].
   assert (H23 : pos_Rl (cons_ORlist lf lg) i < pos_Rl lg (S x0)).
   auto with real.
-  clear b0; apply RList_P17; try assumption;
+  clear a0; apply RList_P17; try assumption;
     [ apply RList_P2; assumption
       | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right;
         elim (RList_P3 lg (pos_Rl lg (S x0))); intros;
@@ -1652,7 +1629,7 @@ Lemma StepFun_P34 :
     a <= b ->
     Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)).
 Proof.
-  intros; unfold RiemannInt_SF; case (Rle_dec a b); intro.
+  intros; unfold RiemannInt_SF; decide (Rle_dec a b) with H.
   replace
   (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f)))
     (subdivision (mkStepFun (StepFun_P32 f)))) with
@@ -1663,7 +1640,6 @@ Proof.
   apply StepFun_P17 with (fun x:R => Rabs (f x)) a b;
     [ apply StepFun_P31; apply StepFun_P1
       | apply (StepFun_P1 (mkStepFun (StepFun_P32 f))) ].
-  elim n; assumption.
 Qed.
 
 Lemma StepFun_P35 :
@@ -1741,24 +1717,21 @@ Lemma StepFun_P36 :
     (forall x:R, a < x < b -> f x <= g x) ->
     RiemannInt_SF f <= RiemannInt_SF g.
 Proof.
-  intros; unfold RiemannInt_SF; case (Rle_dec a b); intro.
+  intros; unfold RiemannInt_SF; decide (Rle_dec a b) with H.
   replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l).
   replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l).
   unfold is_subdivision in X; elim X; clear X; intros;
     unfold adapted_couple in p; decompose [and] p; clear p;
       assert (H5 : Rmin a b = a);
-        [ unfold Rmin; case (Rle_dec a b); intro;
-          [ reflexivity | elim n; assumption ]
+        [ unfold Rmin; decide (Rle_dec a b) with H; reflexivity
           | assert (H7 : Rmax a b = b);
-            [ unfold Rmax; case (Rle_dec a b); intro;
-              [ reflexivity | elim n; assumption ]
+            [ unfold Rmax; decide (Rle_dec a b) with H; reflexivity
               | rewrite H5 in H3; rewrite H7 in H2; eapply StepFun_P35 with a b;
                 assumption ] ].
   apply StepFun_P17 with (fe g) a b;
     [ apply StepFun_P21; assumption | apply StepFun_P1 ].
   apply StepFun_P17 with (fe f) a b;
     [ apply StepFun_P21; assumption | apply StepFun_P1 ].
-  elim n; assumption.
 Qed.
 
 Lemma StepFun_P37 :
@@ -1819,8 +1792,7 @@ Proof.
     induction  i as [| i Hreci].
   simpl; rewrite H12; replace (Rmin r1 b) with r1.
   simpl in H0; rewrite <- H0; apply (H 0%nat); simpl; apply lt_O_Sn.
-  unfold Rmin; case (Rle_dec r1 b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity.
   apply (H10 i); apply lt_S_n.
   replace (S (pred (Rlength lg))) with (Rlength lg).
   apply H9.
@@ -1829,8 +1801,7 @@ Proof.
   simpl; assert (H14 : a <= b).
   rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
     [ assumption | left; reflexivity ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec a b) with H14; reflexivity.
   assert (H14 : a <= b).
   rewrite <- H1; simpl in H0; rewrite <- H0; apply RList_P7;
     [ assumption | left; reflexivity ].
@@ -1838,14 +1809,13 @@ Proof.
   rewrite <- H11; induction  lg as [| r0 lg Hreclg].
   simpl in H13; discriminate.
   reflexivity.
-  unfold Rmax; case (Rle_dec a b); case (Rle_dec r1 b); intros;
-    reflexivity || elim n; assumption.
+  unfold Rmax; decide (Rle_dec a b) with H14; decide (Rle_dec r1 b) with H7;
+    reflexivity.
   simpl; rewrite H13; reflexivity.
   intros; simpl in H9; induction  i as [| i Hreci].
   unfold constant_D_eq, open_interval; simpl; intros;
     assert (H16 : Rmin r1 b = r1).
-  unfold Rmin; case (Rle_dec r1 b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity.
   rewrite H16 in H12; rewrite H12 in H14; elim H14; clear H14; intros _ H14;
     unfold g'; case (Rle_dec r1 x); intro r3.
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H14)).
@@ -1862,9 +1832,9 @@ Proof.
   assert (H18 := H16 H17); unfold constant_D_eq, open_interval in H18;
     unfold constant_D_eq, open_interval; intros;
       assert (H19 := H18 _ H14); rewrite <- H19; unfold g';
-        case (Rle_dec r1 x); intro.
+        case (Rle_dec r1 x) as [|[]].
   reflexivity.
-  elim n; replace r1 with (Rmin r1 b).
+  replace r1 with (Rmin r1 b).
   rewrite <- H12; elim H14; clear H14; intros H14 _; left;
     apply Rle_lt_trans with (pos_Rl lg i); try assumption.
   apply RList_P5.
@@ -1874,12 +1844,9 @@ Proof.
   apply lt_trans with (pred (Rlength lg)); try assumption.
   apply lt_pred_n_n; apply neq_O_lt; red; intro; rewrite <- H22 in H17;
     elim (lt_n_O _ H17).
-  unfold Rmin; case (Rle_dec r1 b); intro;
-    [ reflexivity | elim n0; assumption ].
+  unfold Rmin; decide (Rle_dec r1 b) with H7; reflexivity.
   exists (mkStepFun H8); split.
-  simpl; unfold g'; case (Rle_dec r1 b); intro.
-  assumption.
-  elim n; assumption.
+  simpl; unfold g'; decide (Rle_dec r1 b) with H7; assumption.
   intros; simpl in H9; induction  i as [| i Hreci].
   unfold constant_D_eq, co_interval; simpl; intros; simpl in H0;
     rewrite H0; elim H10; clear H10; intros; unfold g';
@@ -1896,9 +1863,9 @@ Proof.
   assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12;
     unfold constant_D_eq, co_interval; intros;
       rewrite <- (H12 _ H13); simpl; unfold g';
-        case (Rle_dec r1 x); intro.
+        case (Rle_dec r1 x) as [|[]].
   reflexivity.
-  elim n; elim H13; clear H13; intros;
+  elim H13; clear H13; intros;
     apply Rle_trans with (pos_Rl (cons r1 l) i); try assumption;
       change (pos_Rl (cons r1 l) 0 <= pos_Rl (cons r1 l) i);
         elim (RList_P6 (cons r1 l)); intros; apply H15;
@@ -1954,24 +1921,22 @@ Proof.
     unfold adapted_couple; decompose [and] H1;
       decompose [and] H2; clear H1 H2; repeat split.
   apply RList_P25; try assumption.
-  rewrite H10; rewrite H4; unfold Rmin, Rmax; case (Rle_dec a b);
-    case (Rle_dec b c); intros;
-      (right; reflexivity) || (elim n; left; assumption).
+  rewrite H10; rewrite H4; unfold Rmin, Rmax; case (Rle_dec a b) as [|[]];
+    case (Rle_dec b c) as [|[]];
+      (right; reflexivity) || (left; assumption).
   rewrite RList_P22.
-  rewrite H5; unfold Rmin, Rmax; case (Rle_dec a b); case (Rle_dec a c);
-    intros;
+  rewrite H5; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec a b) as [|[]];
       [ reflexivity
-        | elim n; apply Rle_trans with b; left; assumption
-        | elim n; left; assumption
-        | elim n0; left; assumption ].
+        | left; assumption
+        | apply Rle_trans with b; left; assumption
+        | left; assumption ].
   red; intro; rewrite H1 in H6; discriminate.
   rewrite RList_P24.
-  rewrite H9; unfold Rmin, Rmax; case (Rle_dec b c); case (Rle_dec a c);
-    intros;
+  rewrite H9; unfold Rmin, Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec b c) as [|[]];
       [ reflexivity
-        | elim n; apply Rle_trans with b; left; assumption
-        | elim n; left; assumption
-        | elim n0; left; assumption ].
+        | left; assumption
+        | apply Rle_trans with b; left; assumption
+        | left; assumption ].
   red; intro; rewrite H1 in H11; discriminate.
   apply StepFun_P20.
   rewrite RList_P23; apply neq_O_lt; red; intro.
@@ -2061,7 +2026,7 @@ Proof.
   assert (H16 : pos_Rl (cons_Rlist l1 l2) (S i) = b).
   rewrite RList_P29.
   rewrite H15; rewrite <- minus_n_n; rewrite H10; unfold Rmin;
-    case (Rle_dec b c); intro; [ reflexivity | elim n; left; assumption ].
+    case (Rle_dec b c) as [|[]]; [ reflexivity | left; assumption ].
   rewrite H15; apply le_n.
   induction  l1 as [| r l1 Hrecl1].
   simpl in H15; discriminate.
@@ -2069,8 +2034,8 @@ Proof.
   assert (H17 : pos_Rl (cons_Rlist l1 l2) i = b).
   rewrite RList_P26.
   replace i with (pred (Rlength l1));
-  [ rewrite H4; unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; left; assumption ]
+  [ rewrite H4; unfold Rmax; case (Rle_dec a b) as [|[]];
+    [ reflexivity | left; assumption ]
     | rewrite H15; reflexivity ].
   rewrite H15; apply lt_n_Sn.
   rewrite H16 in H2; rewrite H17 in H2; elim H2; intros;
@@ -2095,8 +2060,8 @@ Proof.
   discriminate.
   clear Hrecl1; induction  l1 as [| r0 l1 Hrecl1].
   simpl in H5; simpl in H4; assert (H0 : Rmin a b < Rmax a b).
-  unfold Rmin, Rmax; case (Rle_dec a b); intro;
-    [ assumption | elim n; left; assumption ].
+  unfold Rmin, Rmax; case (Rle_dec a b) as [|[]];
+    [ assumption | left; assumption ].
   rewrite <- H5 in H0; rewrite <- H4 in H0; elim (Rlt_irrefl _ H0).
   clear Hrecl1; simpl; repeat apply le_n_S; apply le_O_n.
   elim (RList_P20 _ H18); intros r1 [r2 [r3 H19]]; rewrite H19;
@@ -2222,9 +2187,9 @@ Proof.
     | left _ => Int_SF lf3 l3
     | right _ => - Int_SF lf3 l3
   end.
-  case (Rle_dec a b); case (Rle_dec b c); case (Rle_dec a c); intros.
-  elim r1; intro.
-  elim r0; intro.
+  case (Rle_dec a b) as [Hle|Hnle]; case (Rle_dec b c) as [Hle'|Hnle']; case (Rle_dec a c) as [Hle''|Hnle''].
+  elim Hle; intro.
+  elim Hle'; intro.
   replace (Int_SF lf3 l3) with
   (Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2)).
   replace (Int_SF lf1 l1) with (Int_SF (FF l1 f) l1).
@@ -2232,8 +2197,7 @@ Proof.
   symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H2; decompose [and] H1; decompose [and] H2;
     clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
-      case (Rle_dec a b); case (Rle_dec b c); intros; reflexivity || elim n;
-        assumption.
+      decide (Rle_dec a b) with Hle; decide (Rle_dec b c) with Hle'; reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2;
       assumption
@@ -2250,13 +2214,13 @@ Proof.
   rewrite Rplus_0_l; eapply StepFun_P17;
     [ apply H2 | rewrite H in H3; apply H3 ].
   symmetry ; eapply StepFun_P8; [ apply H1 | assumption ].
-  elim n; apply Rle_trans with b; assumption.
+  elim Hnle''; apply Rle_trans with b; assumption.
   apply Rplus_eq_reg_l with (Int_SF lf2 l2);
     replace (Int_SF lf2 l2 + (Int_SF lf1 l1 + - Int_SF lf2 l2)) with
     (Int_SF lf1 l1); [ idtac | ring ].
   assert (H : c < b).
   auto with real.
-  elim r; intro.
+  elim Hle''; intro.
   rewrite Rplus_comm;
     replace (Int_SF lf1 l1) with
     (Int_SF (FF (cons_Rlist l3 l2) f) (cons_Rlist l3 l2)).
@@ -2264,12 +2228,9 @@ Proof.
   replace (Int_SF lf2 l2) with (Int_SF (FF l2 f) l2).
   apply StepFun_P42.
   unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
-    clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin;
-      case (Rle_dec a c); case (Rle_dec b c); intros;
-        [ elim n; assumption
-          | reflexivity
-          | elim n0; assumption
-          | elim n1; assumption ].
+    clear H3 H2; rewrite H10; rewrite H6; unfold Rmax, Rmin.
+      decide (Rle_dec a c) with Hle''; decide (Rle_dec b c) with Hnle';
+        reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
@@ -2284,7 +2245,7 @@ Proof.
   symmetry ; eapply StepFun_P8; [ apply H3 | assumption ].
   replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
   ring.
-  elim r; intro.
+  elim Hle; intro.
   replace (Int_SF lf2 l2) with
   (Int_SF (FF (cons_Rlist l3 l1) f) (cons_Rlist l3 l1)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
@@ -2292,11 +2253,7 @@ Proof.
   symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
     clear H3 H1; rewrite H9; rewrite H5; unfold Rmax, Rmin;
-      case (Rle_dec a c); case (Rle_dec a b); intros;
-        [ elim n; assumption
-          | elim n1; assumption
-          | reflexivity
-          | elim n1; assumption ].
+      decide (Rle_dec a c) with Hnle''; decide (Rle_dec a b) with Hle; reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
@@ -2316,7 +2273,7 @@ Proof.
   auto with real.
   replace (Int_SF lf2 l2) with (Int_SF lf3 l3 + Int_SF lf1 l1).
   ring.
-  rewrite Rplus_comm; elim r; intro.
+  rewrite Rplus_comm; elim Hle''; intro.
   replace (Int_SF lf2 l2) with
   (Int_SF (FF (cons_Rlist l1 l3) f) (cons_Rlist l1 l3)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
@@ -2324,11 +2281,8 @@ Proof.
   symmetry ; apply StepFun_P42.
   unfold adapted_couple in H1, H3; decompose [and] H1; decompose [and] H3;
     clear H3 H1; rewrite H11; rewrite H5; unfold Rmax, Rmin;
-      case (Rle_dec a c); case (Rle_dec a b); intros;
-        [ elim n; assumption
-          | reflexivity
-          | elim n0; assumption
-          | elim n1; assumption ].
+      decide (Rle_dec a c) with Hle''; decide (Rle_dec a b) with Hnle;
+        reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf1; apply H1
       | assumption ].
@@ -2346,7 +2300,7 @@ Proof.
   auto with real.
   replace (Int_SF lf1 l1) with (Int_SF lf2 l2 + Int_SF lf3 l3).
   ring.
-  elim r; intro.
+  elim Hle'; intro.
   replace (Int_SF lf1 l1) with
   (Int_SF (FF (cons_Rlist l2 l3) f) (cons_Rlist l2 l3)).
   replace (Int_SF lf3 l3) with (Int_SF (FF l3 f) l3).
@@ -2354,11 +2308,8 @@ Proof.
   symmetry ; apply StepFun_P42.
   unfold adapted_couple in H2, H3; decompose [and] H2; decompose [and] H3;
     clear H3 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
-      case (Rle_dec a c); case (Rle_dec b c); intros;
-        [ elim n; assumption
-          | elim n1; assumption
-          | reflexivity
-          | elim n1; assumption ].
+      decide (Rle_dec a c) with Hnle''; decide (Rle_dec b c) with Hle';
+        reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
@@ -2371,8 +2322,8 @@ Proof.
   replace (Int_SF lf2 l2) with 0.
   rewrite Rplus_0_l; eapply StepFun_P17;
     [ apply H3 | rewrite H0 in H1; apply H1 ].
-  symmetry ; eapply StepFun_P8; [ apply H2 | assumption ].
-  elim n; apply Rle_trans with a; try assumption.
+  symmetry; eapply StepFun_P8; [ apply H2 | assumption ].
+  elim Hnle'; apply Rle_trans with a; try assumption.
   auto with real.
   assert (H : c < b).
   auto with real.
@@ -2387,11 +2338,8 @@ Proof.
   symmetry ; apply StepFun_P42.
   unfold adapted_couple in H2, H1; decompose [and] H2; decompose [and] H1;
     clear H1 H2; rewrite H11; rewrite H5; unfold Rmax, Rmin;
-      case (Rle_dec a b); case (Rle_dec b c); intros;
-        [ elim n1; assumption
-          | elim n1; assumption
-          | elim n0; assumption
-          | reflexivity ].
+      decide (Rle_dec a b) with Hnle; decide (Rle_dec b c) with Hnle';
+         reflexivity.
   eapply StepFun_P17;
     [ apply StepFun_P21; unfold is_subdivision; split with lf2; apply H2
       | assumption ].
@@ -2463,10 +2411,8 @@ Proof.
   replace a with (Rmin a b).
   pattern b at 2; replace b with (Rmax a b).
   rewrite <- H2; rewrite H3; reflexivity.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with H7; reflexivity.
+  unfold Rmin; decide (Rle_dec a b) with H7; reflexivity.
   split with (cons r nil); split with lf1; assert (H2 : c = b).
   rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
   rewrite H2; assumption.
@@ -2475,20 +2421,18 @@ Proof.
     discriminate.
   clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
   case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
-  elim H1; intro.
+  elim H1; intro a0.
   split with (cons r (cons c nil)); split with (cons r3 nil);
     unfold adapted_couple in H; decompose [and] H; clear H;
       assert (H6 : r = a).
-  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b); intro;
+  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]];
     [ reflexivity
-      | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+      | elim H0; intros; apply Rle_trans with c; assumption ].
   elim H0; clear H0; intros; unfold adapted_couple; repeat split.
   rewrite H6; unfold ordered_Rlist; intros; simpl in H8; inversion H8;
     [ simpl; assumption | elim (le_Sn_O _ H10) ].
-  simpl; unfold Rmin; case (Rle_dec a c); intro;
-    [ assumption | elim n; assumption ].
-  simpl; unfold Rmax; case (Rle_dec a c); intro;
-    [ reflexivity | elim n; assumption ].
+  simpl; unfold Rmin; decide (Rle_dec a c) with H; assumption.
+  simpl; unfold Rmax; decide (Rle_dec a c) with H; reflexivity.
   unfold constant_D_eq, open_interval; intros; simpl in H8;
     inversion H8.
   simpl; assert (H10 := H7 0%nat);
@@ -2508,8 +2452,8 @@ Proof.
         assert (H14 : a <= b).
   elim H0; intros; apply Rle_trans with c; assumption.
   assert (H16 : r = a).
-  simpl in H7; rewrite H7; unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  simpl in H7; rewrite H7; unfold Rmin; decide (Rle_dec a b) with H14;
+    reflexivity.
   induction  l1' as [| r4 l1' Hrecl1'].
   simpl in H13; discriminate.
   clear Hrecl1'; unfold adapted_couple; repeat split.
@@ -2517,18 +2461,18 @@ Proof.
   simpl; replace r4 with r1.
   apply (H5 0%nat).
   simpl; apply lt_O_Sn.
-  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c); intro;
-    [ reflexivity | elim n; left; assumption ].
+  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]];
+    [ reflexivity | left; assumption ].
   apply (H9 i); simpl; apply lt_S_n; assumption.
-  simpl; unfold Rmin; case (Rle_dec a c); intro;
-    [ assumption | elim n; elim H0; intros; assumption ].
+  simpl; unfold Rmin; case (Rle_dec a c) as [|[]];
+    [ assumption | elim H0; intros; assumption ].
   replace (Rmax a c) with (Rmax r1 c).
   rewrite <- H11; reflexivity.
-  unfold Rmax; case (Rle_dec r1 c); case (Rle_dec a c); intros;
-    [ reflexivity
-      | elim n; elim H0; intros; assumption
-      | elim n; left; assumption
-      | elim n0; left; assumption ].
+  unfold Rmax; case (Rle_dec a c) as [|[]]; case (Rle_dec r1 c) as [|[]];
+      [ reflexivity
+      | left; assumption
+      | elim H0; intros; assumption
+      | left; assumption ].
   simpl; simpl in H13; rewrite H13; reflexivity.
   intros; simpl in H; unfold constant_D_eq, open_interval; intros;
     induction  i as [| i Hreci].
@@ -2539,8 +2483,8 @@ Proof.
     elim H4; clear H4; intros; split; try assumption;
       replace r1 with r4.
   assumption.
-  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c); intro;
-    [ reflexivity | elim n; left; assumption ].
+  simpl in H12; rewrite H12; unfold Rmin; case (Rle_dec r1 c) as [|[]];
+    [ reflexivity | left; assumption ].
   clear Hreci; simpl; apply H15.
   simpl; apply lt_S_n; assumption.
   unfold open_interval; apply H4.
@@ -2578,10 +2522,8 @@ Proof.
   replace a with (Rmin a b).
   pattern b at 2; replace b with (Rmax a b).
   rewrite <- H2; rewrite H3; reflexivity.
-  unfold Rmax; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
-  unfold Rmin; case (Rle_dec a b); intro;
-    [ reflexivity | elim n; assumption ].
+  unfold Rmax; decide (Rle_dec a b) with H7; reflexivity.
+  unfold Rmin; decide (Rle_dec a b) with H7; reflexivity.
   split with (cons r nil); split with lf1; assert (H2 : c = b).
   rewrite H1 in H0; elim H0; intros; apply Rle_antisym; assumption.
   rewrite <- H2 in H1; rewrite <- H1; assumption.
@@ -2590,22 +2532,22 @@ Proof.
     discriminate.
   clear Hreclf1; assert (H1 : {c <= r1} + {r1 < c}).
   case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ].
-  elim H1; intro.
+  elim H1; intro a0.
   split with (cons c (cons r1 r2)); split with (cons r3 lf1);
     unfold adapted_couple in H; decompose [and] H; clear H;
       unfold adapted_couple; repeat split.
   unfold ordered_Rlist; intros; simpl in H; induction  i as [| i Hreci].
   simpl; assumption.
   clear Hreci; apply (H2 (S i)); simpl; assumption.
-  simpl; unfold Rmin; case (Rle_dec c b); intro;
-    [ reflexivity | elim n; elim H0; intros; assumption ].
+  simpl; unfold Rmin; case (Rle_dec c b) as [|[]];
+    [ reflexivity | elim H0; intros; assumption ].
   replace (Rmax c b) with (Rmax a b).
   rewrite <- H3; reflexivity.
-  unfold Rmax; case (Rle_dec a b); case (Rle_dec c b); intros;
+  unfold Rmax; case (Rle_dec c b) as [|[]]; case (Rle_dec a b) as [|[]];
     [ reflexivity
-      | elim n; elim H0; intros; assumption
-      | elim n; elim H0; intros; apply Rle_trans with c; assumption
-      | elim n0; elim H0; intros; apply Rle_trans with c; assumption ].
+      | elim H0; intros; apply Rle_trans with c; assumption
+      | elim H0; intros; assumption
+      | elim H0; intros; apply Rle_trans with c; assumption ].
   simpl; simpl in H5; apply H5.
   intros; simpl in H; induction  i as [| i Hreci].
   unfold constant_D_eq, open_interval; intros; simpl;
@@ -2615,9 +2557,9 @@ Proof.
     intros; split; try assumption; apply Rle_lt_trans with c;
       try assumption; replace r with a.
   elim H0; intros; assumption.
-  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b); intros;
+  simpl in H4; rewrite H4; unfold Rmin; case (Rle_dec a b) as [|[]];
     [ reflexivity
-      | elim n; elim H0; intros; apply Rle_trans with c; assumption ].
+      | elim H0; intros; apply Rle_trans with c; assumption ].
   clear Hreci; apply (H7 (S i)); simpl; assumption.
   cut (adapted_couple f r1 b (cons r1 r2) lf1).
   cut (r1 <= c <= b).
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index c3020611..c8887dfb 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -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        *)
@@ -164,7 +164,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X')
     eps > 0 ->
     exists alp : R,
       alp > 0 /\
-      (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps).
+      (forall x:Base X, D x /\ X.(dist) x x0 < alp -> X'.(dist) (f x) l < eps).
 
 (*******************************)
 (** **  R is a metric space    *)
@@ -174,6 +174,8 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X')
 Definition R_met : Metric_Space :=
   Build_Metric_Space R R_dist R_dist_pos R_dist_sym R_dist_refl R_dist_tri.
 
+Declare Equivalent Keys dist R_dist.
+
 (*******************************)
 (** *      Limit 1 arg         *)
 (*******************************)
@@ -191,9 +193,9 @@ Lemma tech_limit :
 Proof.
   intros f D l x0 H H0.
   case (Rabs_pos (f x0 - l)); intros H1.
-  absurd (dist R_met (f x0) l < dist R_met (f x0) l).
+  absurd (R_met.(@dist) (f x0) l < R_met.(@dist) (f x0) l).
   apply Rlt_irrefl.
-  case (H0 (dist R_met (f x0) l)); auto.
+  case (H0 (R_met.(@dist) (f x0) l)); auto.
   intros alpha1 [H2 H3]; apply H3; auto; split; auto.
   case (dist_refl R_met x0 x0); intros Hr1 Hr2; rewrite Hr2; auto.
   case (dist_refl R_met (f x0) l); intros Hr1 Hr2; symmetry; auto.
@@ -312,7 +314,7 @@ Proof.
   rewrite (Rplus_comm 1 (Rabs l)); unfold Rgt; apply Rle_lt_0_plus_1;
     exact (Rabs_pos l).
   unfold R_dist in H9;
-    apply (Rplus_lt_reg_r (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
+    apply (Rplus_lt_reg_l (- Rabs l) (Rabs (f x2)) (1 + Rabs l)).
   rewrite <- (Rplus_assoc (- Rabs l) 1 (Rabs l));
     rewrite (Rplus_comm (- Rabs l) 1);
       rewrite (Rplus_assoc 1 (- Rabs l) (Rabs l)); rewrite (Rplus_opp_l (Rabs l));
@@ -345,18 +347,19 @@ Lemma single_limit :
     adhDa D x0 -> limit1_in f D l x0 -> limit1_in f D l' x0 -> l = l'.
 Proof.
   unfold limit1_in; unfold limit_in; intros.
+  simpl in *.
   cut (forall eps:R, eps > 0 -> dist R_met l l' < 2 * eps).
-  clear H0 H1; unfold dist; unfold R_met; unfold R_dist;
-    unfold Rabs; case (Rcase_abs (l - l')); intros.
+  clear H0 H1; unfold dist in |- *; unfold R_met; unfold R_dist in |- *;
+    unfold Rabs; case (Rcase_abs (l - l')) as [Hlt|Hge]; intros.
   cut (forall eps:R, eps > 0 -> - (l - l') < eps).
   intro; generalize (prop_eps (- (l - l')) H1); intro;
-    generalize (Ropp_gt_lt_0_contravar (l - l') r); intro;
+    generalize (Ropp_gt_lt_0_contravar (l - l') Hlt); intro;
       unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3);
         intro; exfalso; auto.
   intros; cut (eps * / 2 > 0).
   intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
-  elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial.
+  elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. 
   apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro;
     unfold Rgt; generalize (Rplus_lt_compat_l 1 0 1 H3);
       intro; elim (Rplus_ne 1); intros a b; rewrite a in H4;
@@ -374,7 +377,7 @@ Proof.
     intros a b; clear b; apply (Rminus_diag_uniq l l');
       apply a; split.
   assumption.
-  apply (Rge_le (l - l') 0 r).
+  apply (Rge_le (l - l') 0 Hge).
   intros; cut (eps * / 2 > 0).
   intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2));
     rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2).
diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v
index 14dea1c6..07792942 100644
--- a/theories/Reals/Rlogic.v
+++ b/theories/Reals/Rlogic.v
@@ -1,261 +1,137 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(** * This module proves some logical properties of the axiomatics of Reals
+(** This module proves some logical properties of the axiomatic of Reals.
 
-1. Decidablity of arithmetical statements from
-   the axiom that the order of the real numbers is decidable.
-
-2. Derivability of the archimedean "axiom"
+- Decidability of arithmetical statements.
+- Derivability of the Archimedean "axiom".
+- Decidability of negated formulas.
 *)
 
-(** 1- Proof of the decidablity of arithmetical statements from
-excluded middle and the axiom that the order of the real numbers is
-decidable. *)
+Require Import RIneq.
 
-(** Assuming a decidable predicate [P n], A series is constructed whose
-[n]th term is 1/2^n if [P n] holds and 0 otherwise.  This sum reaches 2
-only if [P n] holds for all [n], otherwise the sum is less than 2.
-Comparing the sum to 2 decides if [forall n, P n] or [~forall n, P n] *)
+(** * Decidability of arithmetical statements *)
 
 (** One can iterate this lemma and use classical logic to decide any
 statement in the arithmetical hierarchy. *)
 
-(** Contributed by Cezary Kaliszyk and Russell O'Connor *)
-
-Require Import ConstructiveEpsilon.
-Require Import Rfunctions.
-Require Import PartSum.
-Require Import SeqSeries.
-Require Import RiemannInt.
-Require Import Fourier.
-
 Section Arithmetical_dec.
 
 Variable P : nat -> Prop.
 Hypothesis HP : forall n, {P n} + {~P n}.
 
-Let ge_fun_sums_ge_lemma : (forall (m n : nat) (f : nat -> R), (lt m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
-Proof.
-intros m n f mn fpos.
-replace (sum_f_R0 f m) with (sum_f_R0 f m + 0) by ring.
-rewrite (tech2 f m n mn).
-apply Rplus_le_compat_l.
- induction (n - S m)%nat; simpl in *.
- apply fpos.
-replace 0 with (0 + 0) by ring.
-apply (Rplus_le_compat _ _ _ _ IHn0 (fpos (S (m + S n0)%nat))).
-Qed.
-
-Let ge_fun_sums_ge : (forall (m n : nat) (f : nat -> R), (le m n) -> (forall i : nat, 0 <= f i) -> sum_f_R0 f m <= sum_f_R0 f n).
-Proof.
-intros m n f mn pos.
- elim (le_lt_or_eq _ _ mn).
- intro; apply ge_fun_sums_ge_lemma; assumption.
-intro H; rewrite H; auto with *.
-Qed.
-
-Let f:=fun n => (if HP n then (1/2)^n else 0)%R.
-
-Lemma cauchy_crit_geometric_dec_fun : Cauchy_crit_series f.
+Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}.
 Proof.
-intros e He.
-assert (X:(Pser (fun n:nat => 1) (1/2) (/ (1 - (1/2))))%R).
- apply GP_infinite.
- apply Rabs_def1; fourier.
-assert (He':e/2 > 0) by fourier.
-destruct (X _ He') as [N HN].
-clear X.
-exists N.
-intros n m Hn Hm.
-replace e with (e/2 + e/2)%R by field.
-set (g:=(fun n0 : nat => 1 * (1 / 2) ^ n0)) in *.
-assert (R_dist (sum_f_R0 g n) (sum_f_R0 g m) < e / 2 + e / 2).
- apply Rle_lt_trans with (R_dist (sum_f_R0 g n) 2+R_dist 2 (sum_f_R0 g m))%R.
-  apply R_dist_tri.
- replace (/(1 - 1/2)) with 2 in HN by field.
- cut (forall n, (n >= N)%nat -> R_dist (sum_f_R0 g n) 2 < e/2)%R.
-  intros Z.
-  apply Rplus_lt_compat.
-   apply Z; assumption.
-  rewrite R_dist_sym.
-  apply Z; assumption.
- clear - HN He.
- intros n Hn.
- apply HN.
- auto.
-eapply Rle_lt_trans;[|apply H].
-clear -ge_fun_sums_ge n.
-cut (forall n m, (m <= n)%nat -> R_dist (sum_f_R0 f n) (sum_f_R0 f m) <= R_dist (sum_f_R0 g n) (sum_f_R0 g m)).
- intros H.
- destruct (le_lt_dec m n).
-  apply H; assumption.
- rewrite R_dist_sym.
- rewrite (R_dist_sym (sum_f_R0 g n)).
- apply H; auto with *.
-clear n m.
-intros n m Hnm.
-unfold R_dist.
-cut (forall i : nat, (1 / 2) ^ i >= 0). intro RPosPow.
-rewrite Rabs_pos_eq.
- rewrite Rabs_pos_eq.
-  cut (sum_f_R0 g m - sum_f_R0 f m <=  sum_f_R0 g n - sum_f_R0 f n).
-   intros; fourier.
-   do 2 rewrite <- minus_sum.
-   apply (ge_fun_sums_ge m n (fun i : nat => g i - f i) Hnm).
-   intro i.
-   unfold f, g.
-   elim (HP i); intro; ring_simplify; auto with *.
-  cut (sum_f_R0 g m <= sum_f_R0 g n).
-   intro; fourier.
-  apply (ge_fun_sums_ge m n g Hnm).
-  intro. unfold g.
-  ring_simplify.
-  apply Rge_le.
-  apply RPosPow.
- cut (sum_f_R0 f m <= sum_f_R0 f n).
-  intro; fourier.
- apply (ge_fun_sums_ge m n f Hnm).
- intro; unfold f.
- elim (HP i); intro; simpl.
-  apply Rge_le.
-  apply RPosPow.
- auto with *.
-intro i.
-apply Rle_ge.
-apply pow_le.
-fourier.
-Qed.
-
-Lemma forall_dec : {forall n, P n} + {~forall n, P n}.
-Proof.
-destruct (cv_cauchy_2 _ cauchy_crit_geometric_dec_fun).
- cut (2 <= x <-> forall n : nat, P n).
- intro H.
- elim (Rle_dec 2 x); intro X.
- left; tauto.
- right; tauto.
-assert (A:Rabs(1/2) < 1) by (apply Rabs_def1; fourier).
-assert (A0:=(GP_infinite (1/2) A)).
-symmetry.
- split; intro.
- replace 2 with (/ (1 - (1 / 2))) by field.
- unfold Pser, infinite_sum in A0.
- eapply Rle_cv_lim;[|unfold Un_cv; apply A0 |apply u].
- intros n.
- clear -n H.
-  induction n; unfold f;simpl.
-  destruct (HP 0); auto with *.
-  elim n; auto.
- apply Rplus_le_compat; auto.
- destruct (HP (S n)); auto with *.
- elim n0; auto.
-intros n.
-destruct (HP n); auto.
-elim (RIneq.Rle_not_lt _ _ H).
-assert (B:0< (1/2)^n).
- apply pow_lt.
- fourier.
-apply Rle_lt_trans with (2-(1/2)^n);[|fourier].
-replace (/(1-1/2))%R with 2 in A0 by field.
-set (g:= fun m => if (eq_nat_dec m n) then (1/2)^n else 0).
-assert (Z:  Un_cv (fun N : nat => sum_f_R0 g N) ((1/2)^n)).
- intros e He.
- exists n.
- intros a Ha.
- replace (sum_f_R0 g a) with ((1/2)^n).
-  rewrite (R_dist_eq); assumption.
- symmetry.
- cut (forall a : nat, ((a >= n)%nat -> sum_f_R0 g a = (1 / 2) ^ n) /\ ((a < n)%nat -> sum_f_R0 g a = 0))%R.
-  intros H0.
-  destruct (H0 a).
-  auto.
- clear - g.
- induction a.
-  split;
-   intros H;
-   simpl; unfold g;
-   destruct (eq_nat_dec 0 n) as [t|f]; try reflexivity.
-   elim f; auto with *.
-  exfalso; omega.
- destruct IHa as [IHa0 IHa1].
- split;
-  intros H;
-  simpl; unfold g at 2;
-  destruct (eq_nat_dec (S a) n).
-    rewrite IHa1.
-     ring.
-    omega.
-   ring_simplify.
-   apply IHa0.
-   omega.
-  exfalso; omega.
- ring_simplify.
- apply IHa1.
- omega.
-assert (C:=CV_minus _ _ _ _ A0 Z).
-eapply Rle_cv_lim;[|apply u |apply C].
-clear - n0 B.
-intros m.
-simpl.
-induction m.
- simpl.
- unfold f, g.
- destruct (eq_nat_dec 0 n).
-  destruct (HP 0).
-   elim n0.
-   congruence.
-  clear -n.
-  induction n; simpl; fourier.
- destruct (HP); simpl; fourier.
-cut (f (S m) <= 1 * ((1 / 2) ^ (S m)) - g (S m)).
- intros L.
- eapply Rle_trans.
+assert (Hi: (forall n, 0 < INR n + 1)%R).
+  intros n.
+  apply Rle_lt_0_plus_1, pos_INR.
+set (u n := (if HP n then 0 else / (INR n + 1))%R).
+assert (Bu: forall n, (u n <= 1)%R).
+  intros n.
+  unfold u.
+  case HP ; intros _.
+  apply Rle_0_1.
+  rewrite <- S_INR, <- Rinv_1.
+  apply Rinv_le_contravar with (1 := Rlt_0_1).
+  apply (le_INR 1), le_n_S, le_0_n.
+set (E y := exists n, y = u n).
+destruct (completeness E) as [l [ub lub]].
+  exists R1.
+  intros y [n ->].
+  apply Bu.
+  exists (u O).
+  now exists O.
+assert (Hnp: forall n, not (P n) -> ((/ (INR n + 1) <= l)%R)).
+  intros n Hp.
+  apply ub.
+  exists n.
+  unfold u.
+  now destruct (HP n).
+destruct (Rle_lt_dec l 0) as [Hl|Hl].
+  right.
+  intros n.
+  destruct (HP n) as [H|H].
+  exact H.
+  exfalso.
+  apply Rle_not_lt with (1 := Hl).
+  apply Rlt_le_trans with (/ (INR n + 1))%R.
+  now apply Rinv_0_lt_compat.
+  now apply Hnp.
+left.
+set (N := Zabs_nat (up (/l) - 2)).
+assert (H1l: (1 <= /l)%R).
+  rewrite <- Rinv_1.
+  apply Rinv_le_contravar with (1 := Hl).
+  apply lub.
+  now intros y [m ->].
+assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R).
+  unfold N.
+  rewrite INR_IZR_INZ.
+  rewrite inj_Zabs_nat.
+  replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R.
+  apply (f_equal (fun v => IZR v + 1)%R).
+  apply Zabs_eq.
+  apply Zle_minus_le_0.
+  apply (Zlt_le_succ 1).
+  apply lt_IZR.
+  apply Rle_lt_trans with (1 := H1l).
+  apply archimed.
+  rewrite minus_IZR.
   simpl.
-  apply Rplus_le_compat.
-   apply IHm.
-  apply L.
- simpl; fourier.
-unfold f, g.
-destruct (eq_nat_dec (S m) n).
- destruct (HP (S m)).
-  elim n0.
-  congruence.
- rewrite e.
- fourier.
-destruct (HP (S m)).
- fourier.
+  ring.
+assert (Hl': (/ (INR (S N) + 1) < l)%R).
+  rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
+  apply Rinv_1_lt_contravar with (1 := H1l).
+  rewrite S_INR.
+  rewrite HN.
+  ring_simplify.
+  apply archimed.
+exists N.
+intros H.
+apply Rle_not_lt with (2 := Hl').
+apply lub.
+intros y [n ->].
+unfold u.
+destruct (HP n) as [_|Hp].
+  apply Rlt_le.
+  now apply Rinv_0_lt_compat.
+apply Rinv_le_contravar.
+apply Hi.
+apply Rplus_le_compat_r.
+apply le_INR.
+destruct (le_or_lt n N) as [Hn|Hn].
+  2: now apply lt_le_S.
+exfalso.
+destruct (le_lt_or_eq _ _ Hn) as [Hn'| ->].
+2: now apply Hp.
+apply Rlt_not_le with (2 := Hnp _ Hp).
+rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
+apply Rinv_1_lt_contravar.
+rewrite <- S_INR.
+apply (le_INR 1), le_n_S, le_0_n.
+apply Rlt_le_trans with (INR N + 1)%R.
+apply Rplus_lt_compat_r.
+now apply lt_INR.
+rewrite HN.
+apply Rplus_le_reg_r with (-/l + 1)%R.
 ring_simplify.
-apply pow_le.
-fourier.
-Qed.
-
-Lemma sig_forall_dec :  {n | ~P n}+{forall n, P n}.
-Proof.
-destruct forall_dec.
- right; assumption.
-left.
-apply constructive_indefinite_ground_description_nat; auto.
- clear - HP.
- firstorder.
-apply Classical_Pred_Type.not_all_ex_not.
-assumption.
+apply archimed.
 Qed.
 
 End Arithmetical_dec.
 
-(** 2- Derivability of the Archimedean axiom *)
+(** * Derivability of the Archimedean axiom *)
 
-(* This is a standard proof (it has been taken from PlanetMath). It is
+(** This is a standard proof (it has been taken from PlanetMath). It is
 formulated negatively so as to avoid the need for classical
-logic. Using a proof of {n | ~P n}+{forall n, P n} (the one above or a
-variant of it that does not need classical axioms) , we can in
-principle also derive [up] and its [specification] *)
+logic. Using a proof of [{n | ~P n}+{forall n, P n}], we can in
+principle also derive [up] and its specification. The proof above
+cannot be used for that purpose, since it relies on the [archimed] axiom. *)
 
 Theorem not_not_archimedean :
   forall r : R, ~ (forall n : nat, (INR n <= r)%R).
@@ -296,3 +172,33 @@ rewrite (Rplus_comm (INR n) 0) in H6.
 rewrite Rplus_0_l in H6.
 assumption.
 Qed.
+
+(** * Decidability of negated formulas *)
+
+Lemma sig_not_dec : forall P : Prop, {not (not P)} + {not P}.
+Proof.
+intros P.
+set (E := fun x => x = R0 \/ (x = R1 /\ P)).
+destruct (completeness E) as [x H].
+  exists R1.
+  intros x [->|[-> _]].
+  apply Rle_0_1.
+  apply Rle_refl.
+  exists R0.
+  now left.
+destruct (Rle_lt_dec 1 x) as [H'|H'].
+- left.
+  intros HP.
+  elim Rle_not_lt with (1 := H').
+  apply Rle_lt_trans with (2 := Rlt_0_1).
+  apply H.
+  intros y [->|[_ Hy]].
+  apply Rle_refl.
+  now elim HP.
+- right.
+  intros HP.
+  apply Rlt_not_le with (1 := H').
+  apply H.
+  right.
+  now split.
+Qed.
diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v
index 9121ccc2..ba1fe90f 100644
--- a/theories/Reals/Rminmax.v
+++ b/theories/Reals/Rminmax.v
@@ -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/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
index 0116e29a..1d697f3c 100644
--- a/theories/Reals/Rpow_def.v
+++ b/theories/Reals/Rpow_def.v
@@ -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/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index 014d7025..e30ea334 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -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        *)
@@ -20,8 +20,10 @@ Require Import Ranalysis1.
 Require Import Exp_prop.
 Require Import Rsqrt_def.
 Require Import R_sqrt.
+Require Import Sqrt_reg.
 Require Import MVT.
 Require Import Ranalysis4.
+Require Import Fourier.
 Local Open Scope R_scope.
 
 Lemma P_Rmin : forall (P:R -> Prop) (x y:R), P x -> P y -> P (Rmin x y).
@@ -43,7 +45,7 @@ Proof.
   rewrite Rmult_1_r; rewrite <- (Rmult_comm 3); rewrite <- Rmult_assoc;
     rewrite <- Rinv_l_sym.
   rewrite Rmult_1_l; replace (/ exp 1) with (exp (-1)).
-  unfold exp; case (exist_exp (-1)); intros; simpl;
+  unfold exp; case (exist_exp (-1)) as (?,e); simpl in |- *;
     unfold exp_in in e;
       assert (H := alternated_series_ineq (fun i:nat => / INR (fact i)) x 1).
   cut
@@ -137,7 +139,7 @@ Qed.
 
 Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x.
 Proof.
-  intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x));
+  intros; apply Rplus_lt_reg_l with (- exp 0); rewrite <- (Rplus_comm (exp x));
     assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0;
       intros; elim H1; intros; unfold Rminus in H2; rewrite H2;
         rewrite Ropp_0; rewrite Rplus_0_r;
@@ -178,13 +180,13 @@ Qed.
 (**********)
 Lemma ln_exists : forall y:R, 0 < y -> { z:R | y = exp z }.
 Proof.
-  intros; case (Rle_dec 1 y); intro.
-  apply (ln_exists1 _ r).
+  intros; destruct (Rle_dec 1 y) as [Hle|Hnle].
+  apply (ln_exists1 _ Hle).
   assert (H0 : 1 <= / y).
   apply Rmult_le_reg_l with y.
   apply H.
   rewrite <- Rinv_r_sym.
-  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ n).
+  rewrite Rmult_1_r; left; apply (Rnot_le_lt _ _ Hnle).
   red; intro; rewrite H0 in H; elim (Rlt_irrefl _ H).
   destruct (ln_exists1 _ H0) as (x,p); exists (- x);
     apply Rmult_eq_reg_l with (exp x / y).
@@ -213,12 +215,10 @@ Definition ln (x:R) : R :=
 
 Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x.
 Proof.
-  intros; unfold ln; case (Rlt_dec 0 x); intro.
+  intros; unfold ln; decide (Rlt_dec 0 x) with H.
   unfold Rln;
-    case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r)));
-    intros.
-  simpl in e; symmetry ; apply e.
-  elim n; apply H.
+    case (ln_exists (mkposreal x H) (cond_pos (mkposreal x H))) as (?,Hex).
+  symmetry; apply Hex.
 Qed.
 
 Theorem exp_inv : forall x y:R, exp x = exp y -> x = y.
@@ -313,12 +313,12 @@ Proof.
   red; apply P_Rmin.
   apply Rmult_lt_0_compat.
   assumption.
-  apply Rplus_lt_reg_r with 1.
+  apply Rplus_lt_reg_l with 1.
   rewrite Rplus_0_r; replace (1 + (exp eps - 1)) with (exp eps);
     [ apply H1 | ring ].
   apply Rmult_lt_0_compat.
   assumption.
-  apply Rplus_lt_reg_r with (exp (- eps)).
+  apply Rplus_lt_reg_l with (exp (- eps)).
   rewrite Rplus_0_r; replace (exp (- eps) + (1 - exp (- eps))) with 1;
     [ apply H2 | ring ].
   unfold dist, R_met, R_dist; simpl.
@@ -335,7 +335,7 @@ Proof.
   apply H.
   rewrite Hxyy.
   apply Ropp_lt_cancel.
-  apply Rplus_lt_reg_r with (r := y).
+  apply Rplus_lt_reg_l with (r := y).
   replace (y + - (y * exp (- eps))) with (y * (1 - exp (- eps)));
   [ idtac | ring ].
   replace (y + - x) with (Rabs (x - y)).
@@ -358,7 +358,7 @@ Proof.
   apply Rmult_lt_reg_l with (r := y).
   apply H.
   rewrite Hxyy.
-  apply Rplus_lt_reg_r with (r := - y).
+  apply Rplus_lt_reg_l with (r := - y).
   replace (- y + y * exp eps) with (y * (exp eps - 1)); [ idtac | ring ].
   replace (- y + x) with (Rabs (x - y)).
   apply Rlt_le_trans with (1 := H5); apply Rmin_l.
@@ -610,7 +610,7 @@ Proof.
     replace h with (x + h - x); [ idtac | ring ].
   apply H3; split.
   unfold D_x; split.
-  case (Rcase_abs h); intro.
+  destruct (Rcase_abs h) as [Hlt|Hgt].
   assert (H7 : Rabs h < x / 2).
   apply Rlt_le_trans with alp.
   apply H6.
@@ -619,13 +619,13 @@ Proof.
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
   rewrite Rabs_left in H7.
-  apply Rplus_lt_reg_r with (- h - x / 2).
+  apply Rplus_lt_reg_l with (- h - x / 2).
   replace (- h - x / 2 + x / 2) with (- h); [ idtac | ring ].
   pattern x at 2; rewrite double_var.
   replace (- h - x / 2 + (x / 2 + x / 2 + h)) with (x / 2); [ apply H7 | ring ].
-  apply r.
-  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply r ].
-  apply (not_eq_sym (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
+  apply Hlt.
+  apply Rplus_lt_le_0_compat; [ assumption | apply Rge_le; apply Hgt ].
+  apply (sym_not_eq (A:=R)); apply Rminus_not_eq; replace (x + h - x) with h;
     [ apply H5 | ring ].
   replace (x + h - x) with h;
   [ apply Rlt_le_trans with alp;
@@ -703,3 +703,128 @@ Proof.
   ring.
   apply derivable_pt_lim_exp.
 Qed.
+
+(* added later. *)
+
+Lemma Rpower_mult_distr :  
+  forall x y z, 0 < x -> 0 < y ->
+   Rpower x z * Rpower y z = Rpower (x * y) z.
+intros x y z x0 y0; unfold Rpower.
+rewrite <- exp_plus, ln_mult, Rmult_plus_distr_l; auto.
+Qed.
+
+Lemma Rle_Rpower_l a b c: 0 <= c -> 0 < a <= b -> Rpower a c <= Rpower b c. 
+Proof.
+intros [c0 | c0];
+ [ | intros; rewrite <- c0, !Rpower_O; [apply Rle_refl | |] ].
+  intros [a0 [ab|ab]].
+   left; apply exp_increasing.
+   now apply Rmult_lt_compat_l; auto; apply ln_increasing; fourier.
+  rewrite ab; apply Rle_refl.
+ apply Rlt_le_trans with a; tauto.
+tauto.
+Qed.
+
+(* arcsinh function *)
+
+Definition arcsinh x := ln (x + sqrt (x ^ 2 + 1)).
+
+Lemma arcsinh_sinh : forall x, arcsinh (sinh x) = x.
+intros x; unfold sinh, arcsinh.
+assert (Rminus_eq_0 : forall r, r - r = 0) by (intros; ring).
+pattern 1 at 5; rewrite <- exp_0, <- (Rminus_eq_0 x); unfold Rminus.
+rewrite exp_plus.
+match goal with |- context[sqrt ?a] => 
+  replace a with (((exp x + exp(-x))/2)^2) by field
+end.
+rewrite sqrt_pow2;
+ [|apply Rlt_le, Rmult_lt_0_compat;[apply Rplus_lt_0_compat; apply exp_pos |
+                            apply Rinv_0_lt_compat, Rlt_0_2]].
+match goal with |- context[ln ?a] => replace a with (exp x) by field end. 
+rewrite ln_exp; reflexivity.
+Qed.
+
+Lemma sinh_arcsinh x : sinh (arcsinh x) = x. 
+unfold sinh, arcsinh.
+assert (cmp : 0 < x + sqrt (x ^ 2 + 1)).
+ destruct (Rle_dec x 0).
+  replace (x ^ 2) with ((-x) ^ 2) by ring.
+  assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)).
+   apply sqrt_lt_1_alt.
+   split;[apply pow_le | ]; fourier.
+  pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
+   assert (t:= sqrt_pos ((-x)^2)); fourier.
+  simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive;[reflexivity | fourier].
+  apply Rplus_lt_le_0_compat;[apply Rnot_le_gt; assumption | apply sqrt_pos].
+rewrite exp_ln;[ | assumption].
+rewrite exp_Ropp, exp_ln;[ | assumption].
+assert (Rmult_minus_distr_r :
+         forall x y z, (x - y) * z = x * z - y * z) by (intros; ring).
+apply Rminus_diag_uniq; unfold Rdiv; rewrite Rmult_minus_distr_r.
+assert (t: forall x y z, x - z = y -> x - y - z = 0);[ | apply t; clear t].
+ intros a b c H; rewrite <- H; ring.
+apply Rmult_eq_reg_l with (2 * (x + sqrt (x ^ 2 + 1)));[ |
+ apply Rgt_not_eq, Rmult_lt_0_compat;[apply Rlt_0_2 | assumption]].
+assert (pow2_sqrt : forall x, 0 <= x -> sqrt x ^ 2 = x) by
+ (intros; simpl; rewrite Rmult_1_r, sqrt_sqrt; auto).
+field_simplify;[rewrite pow2_sqrt;[field | ] | apply Rgt_not_eq; fourier].
+apply Rplus_le_le_0_compat;[simpl; rewrite Rmult_1_r; apply (Rle_0_sqr x)|apply Rlt_le, Rlt_0_1].
+Qed.
+
+Lemma derivable_pt_lim_arcsinh :
+  forall x, derivable_pt_lim arcsinh x (/sqrt (x ^ 2 + 1)).
+intros x; unfold arcsinh.
+assert (0 < x + sqrt (x ^ 2 + 1)).
+ destruct (Rle_dec x 0);
+  [ | assert (0 < x) by (apply Rnot_le_gt; assumption);
+    apply Rplus_lt_le_0_compat; auto; apply sqrt_pos].
+ replace (x ^ 2) with ((-x) ^ 2) by ring.
+ assert (sqrt ((- x) ^ 2) < sqrt ((-x)^2+1)).
+  apply sqrt_lt_1_alt.
+  split;[apply pow_le|]; fourier.
+ pattern x at 1; replace x with (- (sqrt ((- x) ^ 2))).
+  assert (t:= sqrt_pos ((-x)^2)); fourier.
+ simpl; rewrite Rmult_1_r, sqrt_square, Ropp_involutive; auto; fourier.
+assert (0 < x ^ 2 + 1).
+ apply Rplus_le_lt_0_compat;[simpl; rewrite Rmult_1_r; apply Rle_0_sqr|fourier].
+replace (/sqrt (x ^ 2 + 1)) with
+ (/(x + sqrt (x ^ 2 + 1)) * 
+    (1 + (/(2 * sqrt (x ^ 2 + 1)) * (INR 2 * x ^ 1 + 0)))).
+apply (derivable_pt_lim_comp (fun x => x + sqrt (x ^ 2 + 1)) ln).
+ apply (derivable_pt_lim_plus).
+  apply derivable_pt_lim_id.
+   apply (derivable_pt_lim_comp (fun x => x ^ 2 + 1) sqrt x).
+    apply derivable_pt_lim_plus.
+     apply derivable_pt_lim_pow.
+    apply derivable_pt_lim_const.
+   apply derivable_pt_lim_sqrt; assumption.
+  apply derivable_pt_lim_ln; assumption.
+ replace (INR 2 * x ^ 1 + 0) with (2 * x) by (simpl; ring).
+replace (1 + / (2 * sqrt (x ^ 2 + 1)) * (2 * x)) with
+ (((sqrt (x ^ 2 + 1) + x))/sqrt (x ^ 2 + 1));
+ [ | field; apply Rgt_not_eq, sqrt_lt_R0; assumption].
+apply Rmult_eq_reg_l with (x + sqrt (x ^ 2 + 1));
+  [ | apply Rgt_not_eq; assumption].
+rewrite <- Rmult_assoc, Rinv_r;[field | ]; apply Rgt_not_eq; auto;
+  apply sqrt_lt_R0; assumption.
+Qed.
+
+Lemma arcsinh_lt : forall x y, x < y -> arcsinh x < arcsinh y.
+intros x y xy.
+case (Rle_dec (arcsinh y) (arcsinh x));[ | apply Rnot_le_lt ].
+intros abs; case (Rlt_not_le _ _ xy).
+rewrite <- (sinh_arcsinh y), <- (sinh_arcsinh x).
+destruct abs as [lt | q];[| rewrite q; fourier].
+apply Rlt_le, sinh_lt; assumption.
+Qed.
+
+Lemma arcsinh_le : forall x y, x <= y -> arcsinh x <= arcsinh y.
+intros x y [xy | xqy].
+ apply Rlt_le, arcsinh_lt; assumption.
+rewrite xqy; apply Rle_refl.
+Qed.
+
+Lemma arcsinh_0 : arcsinh 0 = 0.
+ unfold arcsinh; rewrite pow_ne_zero, !Rplus_0_l, sqrt_1, ln_1;
+  [reflexivity | discriminate].
+Qed.
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 341ec8fd..1ee9410f 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -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        *)
@@ -12,6 +12,7 @@ Require Import Rfunctions.
 Require Import Rseries.
 Require Import PartSum.
 Require Import Binomial.
+Require Import Omega.
 Local Open Scope R_scope.
 
 (** TT Ak; 0<=k<=N *)
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index c540a931..fd16ea61 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -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        *)
@@ -108,7 +108,7 @@ Section sequence.
     intros n H4.
     unfold R_dist.
     rewrite Rabs_left1, Ropp_minus_distr.
-    apply Rplus_lt_reg_r with (Un n - eps).
+    apply Rplus_lt_reg_l with (Un n - eps).
     apply Rlt_le_trans with (Un N).
     now replace (Un n - eps + (l - Un n)) with (l - eps) by ring.
     replace (Un n - eps + eps) with (Un n) by ring.
@@ -171,7 +171,7 @@ Section sequence.
     rewrite H1.
     apply Rle_trans with (1 := proj2 (Hsum n)).
     apply Rlt_le.
-    apply Rplus_lt_reg_r with ((/2)^n - 1).
+    apply Rplus_lt_reg_l with ((/2)^n - 1).
     now ring_simplify.
     exists 0. now exists O.
 
@@ -202,7 +202,7 @@ Section sequence.
     refine (False_ind _ (Rle_not_lt _ _ (H (l - eps) _) _)).
     intros x (n, H1).
     now rewrite H1.
-    apply Rplus_lt_reg_r with (eps - l).
+    apply Rplus_lt_reg_l with (eps - l).
     now ring_simplify.
 
     assert (Rabs (/2) < 1).
@@ -237,9 +237,9 @@ Section sequence.
     apply le_n_Sn.
     rewrite (IHN H6), Rplus_0_l.
     unfold test.
-    destruct Rle_lt_dec.
+    destruct Rle_lt_dec as [Hle|Hlt].
     apply eq_refl.
-    now elim Rlt_not_le with (1 := r).
+    now elim Rlt_not_le with (1 := Hlt).
 
     destruct (le_or_lt N n) as [Hn|Hn].
     rewrite le_plus_minus with (1 := Hn).
@@ -247,7 +247,7 @@ Section sequence.
     rewrite Hs, Rplus_0_l.
     set (k := (N + (n - N))%nat).
     apply Rlt_le.
-    apply Rplus_lt_reg_r with ((/2)^k - (/2)^N).
+    apply Rplus_lt_reg_l with ((/2)^k - (/2)^N).
     now ring_simplify.
     apply Rle_trans with (sum N).
     rewrite le_plus_minus with (1 := Hn).
@@ -261,7 +261,7 @@ Section sequence.
   Lemma Un_cv_crit : Un_growing -> bound EUn ->  exists l : R, Un_cv l.
   Proof.
     intros Hug Heub.
-    exists (projT1 (completeness EUn Heub EUn_noempty)).
+    exists (proj1_sig (completeness EUn Heub EUn_noempty)).
     destruct (completeness EUn Heub EUn_noempty) as (l, H).
     now apply Un_cv_crit_lub.
   Qed.
@@ -404,3 +404,26 @@ Proof.
   apply Rinv_neq_0_compat.
   assumption.
 Qed.
+
+(* Convergence is preserved after shifting the indices. *)
+Lemma CV_shift : 
+  forall f k l, Un_cv (fun n => f (n + k)%nat) l -> Un_cv f l.
+intros f' k l cvfk eps ep; destruct (cvfk eps ep) as [N Pn].
+exists (N + k)%nat; intros n nN; assert (tmp: (n = (n - k) + k)%nat).
+ rewrite Nat.sub_add;[ | apply le_trans with (N + k)%nat]; auto with arith.
+rewrite tmp; apply Pn; apply Nat.le_add_le_sub_r; assumption.
+Qed.
+
+Lemma CV_shift' : 
+  forall f k l, Un_cv f l -> Un_cv (fun n => f (n + k)%nat) l.
+intros f' k l cvf eps ep; destruct (cvf eps ep) as [N Pn].
+exists N; intros n nN; apply Pn; auto with arith.
+Qed.
+
+(* Growing property is preserved after shifting the indices (one way only) *)
+
+Lemma Un_growing_shift : 
+   forall k un, Un_growing un -> Un_growing (fun n => un (n + k)%nat).
+Proof.
+intros k un P n; apply P.
+Qed.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index 0dcb4b25..458d1f8c 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -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        *)
@@ -10,6 +10,7 @@ Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
 Require Import PartSum.
+Require Import Omega.
 Local Open Scope R_scope.
 
 Set Implicit Arguments.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index 307035ab..b8ec8d3c 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -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        *)
@@ -276,8 +276,7 @@ Proof.
   intros.
   unfold cv_infty.
   intro.
-  case (total_order_T 0 M); intro.
-  elim s; intro.
+  destruct (total_order_T 0 M) as [[Hlt|<-]|Hgt].
   set (N := up M).
   cut (0 <= N)%Z.
   intro.
@@ -302,7 +301,6 @@ Proof.
   assert (H0 := archimed M); elim H0; intros.
   left; apply Rlt_trans with M; assumption.
   exists 0%nat; intros.
-  rewrite <- b.
   unfold pow_2_n; apply pow_lt; prove_sup0.
   exists 0%nat; intros.
   apply Rlt_trans with 0.
@@ -342,8 +340,7 @@ Proof.
   unfold Un_cv; unfold R_dist.
   intros.
   assert (H4 := cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
-  case (total_order_T x y); intro.
-  elim s; intro.
+  destruct (total_order_T x y) as [[ Hlt | -> ]|Hgt].
   unfold Un_cv in H4; unfold R_dist in H4.
   cut (0 < y - x).
   intro Hyp.
@@ -373,19 +370,18 @@ Proof.
   assumption.
   unfold Rdiv; apply Rmult_lt_0_compat;
     [ assumption | apply Rinv_0_lt_compat; assumption ].
-  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
+  apply Rplus_lt_reg_l with x; rewrite Rplus_0_r.
   replace (x + (y - x)) with y; [ assumption | ring ].
   exists 0%nat; intros.
-  replace (dicho_lb x y P n - dicho_up x y P n - 0) with
-  (dicho_lb x y P n - dicho_up x y P n); [ idtac | ring ].
+  replace (dicho_lb y y P n - dicho_up y y P n - 0) with
+  (dicho_lb y y P n - dicho_up y y P n); [ idtac | ring ].
   rewrite <- Rabs_Ropp.
   rewrite Ropp_minus_distr'.
   rewrite dicho_lb_dicho_up.
-  rewrite b.
   unfold Rminus, Rdiv; rewrite Rplus_opp_r; rewrite Rmult_0_l;
     rewrite Rabs_R0; assumption.
   assumption.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H Hgt)).
 Qed.
 
 Definition cond_positivity (x:R) : bool :=
@@ -427,18 +423,15 @@ Lemma dicho_lb_car :
     P x = false -> P (dicho_lb x y P n) = false.
 Proof.
   intros.
-  induction  n as [| n Hrecn].
-  simpl.
-  assumption.
-  simpl.
-  assert
-    (X :=
-      sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
-  elim X; intro.
-  rewrite a.
-  unfold dicho_lb in Hrecn; assumption.
-  rewrite b.
-  assumption.
+  induction n as [| n Hrecn].
+  - assumption.
+  - simpl.
+    destruct
+        (sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq].
+    + rewrite Heq.
+      unfold dicho_lb in Hrecn; assumption.
+    + rewrite Heq.
+      assumption.
 Qed.
 
 Lemma dicho_up_car :
@@ -446,18 +439,23 @@ Lemma dicho_up_car :
     P y = true -> P (dicho_up x y P n) = true.
 Proof.
   intros.
-  induction  n as [| n Hrecn].
-  simpl.
-  assumption.
-  simpl.
-  assert
-    (X :=
-      sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))).
-  elim X; intro.
-  rewrite a.
-  unfold dicho_lb in Hrecn; assumption.
-  rewrite b.
-  assumption.
+  induction n as [| n Hrecn].
+  - assumption.
+  - simpl.
+    destruct
+      (sumbool_of_bool (P ((Dichotomy_lb x y P n + Dichotomy_ub x y P n) / 2))) as [Heq|Heq].
+    + rewrite Heq.
+      unfold dicho_lb in Hrecn; assumption.
+    + rewrite  Heq.
+      assumption.
+Qed.
+
+(* A general purpose corollary. *)
+Lemma cv_pow_half : forall a, Un_cv (fun n => a/2^n) 0.
+intros a; unfold Rdiv; replace 0 with (a * 0) by ring.
+apply CV_mult.
+ intros eps ep; exists 0%nat; rewrite R_dist_eq; intros n _; assumption.
+exact (cv_infty_cv_R0 pow_2_n pow_2_n_neq_R0 pow_2_n_infty).
 Qed.
 
 (** Intermediate Value Theorem *)
@@ -467,13 +465,9 @@ Lemma IVT :
     x < y -> f x < 0 -> 0 < f y -> { z:R | x <= z <= y /\ f z = 0 }.
 Proof.
   intros.
-  cut (x <= y).
-  intro.
-  generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3).
-  generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3).
-  intros X X0.
-  elim X; intros.
-  elim X0; intros.
+  assert (x <= y) by (left; assumption).
+  destruct (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3) as (x1,p0).
+  destruct (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3) as (x0,p).
   assert (H4 := cv_dicho _ _ _ _ _ H3 p0 p).
   rewrite H4 in p0.
   exists x0.
@@ -490,7 +484,6 @@ Proof.
   apply dicho_up_decreasing; assumption.
   assumption.
   right; reflexivity.
-  2: left; assumption.
   set (Vn := fun n:nat => dicho_lb x y (fun z:R => cond_positivity (f z)) n).
   set (Wn := fun n:nat => dicho_up x y (fun z:R => cond_positivity (f z)) n).
   cut ((forall n:nat, f (Vn n) <= 0) -> f x0 <= 0).
@@ -515,14 +508,14 @@ Proof.
   left; assumption.
   intro.
   unfold cond_positivity.
-  case (Rle_dec 0 z); intro.
+  case (Rle_dec 0 z) as [Hle|Hnle].
   split.
   intro; assumption.
   intro; reflexivity.
   split.
   intro feqt;discriminate feqt.
   intro.
-  elim n0; assumption.
+  contradiction.
   unfold Vn.
   cut (forall z:R, cond_positivity z = false <-> z < 0).
   intros.
@@ -536,20 +529,19 @@ Proof.
   assumption.
   intro.
   unfold cond_positivity.
-  case (Rle_dec 0 z); intro.
+  case (Rle_dec 0 z) as [Hle|Hnle].
   split.
   intro feqt; discriminate feqt.
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H7)).
+  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H7)).
   split.
   intro; auto with real.
   intro; reflexivity.
   cut (Un_cv Wn x0).
   intros.
   assert (H7 := continuity_seq f Wn x0 (H x0) H5).
-  case (total_order_T 0 (f x0)); intro.
-  elim s; intro.
+  destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
   left; assumption.
-  rewrite <- b; right; reflexivity.
+  right; reflexivity.
   unfold Un_cv in H7; unfold R_dist in H7.
   cut (0 < - f x0).
   intro.
@@ -559,7 +551,7 @@ Proof.
   rewrite Rabs_right in H11.
   pattern (- f x0) at 1 in H11; rewrite <- Rplus_0_r in H11.
   unfold Rminus in H11; rewrite (Rplus_comm (f (Wn x2))) in H11.
-  assert (H12 := Rplus_lt_reg_r _ _ _ H11).
+  assert (H12 := Rplus_lt_reg_l _ _ _ H11).
   assert (H13 := H6 x2).
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H12)).
   apply Rle_ge; left; unfold Rminus; apply Rplus_le_lt_0_compat.
@@ -570,29 +562,28 @@ Proof.
   cut (Un_cv Vn x0).
   intros.
   assert (H7 := continuity_seq f Vn x0 (H x0) H5).
-  case (total_order_T 0 (f x0)); intro.
-  elim s; intro.
+  destruct (total_order_T 0 (f x0)) as [[Hlt|<-]|Hgt].
   unfold Un_cv in H7; unfold R_dist in H7.
-  elim (H7 (f x0) a); intros.
+  elim (H7 (f x0) Hlt); intros.
   cut (x2 >= x2)%nat; [ intro | unfold ge; apply le_n ].
   assert (H10 := H8 x2 H9).
   rewrite Rabs_left in H10.
   pattern (f x0) at 2 in H10; rewrite <- Rplus_0_r in H10.
   rewrite Ropp_minus_distr' in H10.
   unfold Rminus in H10.
-  assert (H11 := Rplus_lt_reg_r _ _ _ H10).
+  assert (H11 := Rplus_lt_reg_l _ _ _ H10).
   assert (H12 := H6 x2).
   cut (0 < f (Vn x2)).
   intro.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H13 H12)).
   rewrite <- (Ropp_involutive (f (Vn x2))).
   apply Ropp_0_gt_lt_contravar; assumption.
-  apply Rplus_lt_reg_r with (f x0 - f (Vn x2)).
+  apply Rplus_lt_reg_l with (f x0 - f (Vn x2)).
   rewrite Rplus_0_r; replace (f x0 - f (Vn x2) + (f (Vn x2) - f x0)) with 0;
     [ unfold Rminus; apply Rplus_lt_le_0_compat | ring ].
   assumption.
   apply Ropp_0_ge_le_contravar; apply Rle_ge; apply H6.
-  right; rewrite <- b; reflexivity.
+  right; reflexivity.
   left; assumption.
   unfold Vn; assumption.
 Qed.
@@ -603,31 +594,23 @@ Lemma IVT_cor :
     x <= y -> f x * f y <= 0 -> { z:R | x <= z <= y /\ f z = 0 }.
 Proof.
   intros.
-  case (total_order_T 0 (f x)); intro.
-  case (total_order_T 0 (f y)); intro.
-  elim s; intro.
-  elim s0; intro.
+  destruct (total_order_T 0 (f x)) as [[Hltx|Heqx]|Hgtx].
+  destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty].
   cut (0 < f x * f y);
     [ intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H1 H2))
       | apply Rmult_lt_0_compat; assumption ].
   exists y.
   split.
   split; [ assumption | right; reflexivity ].
-  symmetry ; exact b.
-  exists x.
-  split.
-  split; [ right; reflexivity | assumption ].
-  symmetry ; exact b.
-  elim s; intro.
+  symmetry ; exact Heqy.
   cut (x < y).
   intro.
   assert (H3 := IVT (- f)%F x y (continuity_opp f H) H2).
   cut ((- f)%F x < 0).
   cut (0 < (- f)%F y).
   intros.
-  elim (H3 H5 H4); intros.
+  destruct (H3 H5 H4) as (x0,[]).
   exists x0.
-  elim p; intros.
   split.
   assumption.
   unfold opp_fct in H7.
@@ -635,25 +618,24 @@ Proof.
   apply Ropp_eq_0_compat; assumption.
   unfold opp_fct; apply Ropp_0_gt_lt_contravar; assumption.
   unfold opp_fct.
-  apply Rplus_lt_reg_r with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
+  apply Rplus_lt_reg_l with (f x); rewrite Rplus_opp_r; rewrite Rplus_0_r;
     assumption.
   inversion H0.
   assumption.
-  rewrite H2 in a.
-  elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+  rewrite H2 in Hltx.
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hgty Hltx)).
   exists x.
   split.
   split; [ right; reflexivity | assumption ].
   symmetry ; assumption.
-  case (total_order_T 0 (f y)); intro.
-  elim s; intro.
+  destruct (total_order_T 0 (f y)) as [[Hlty|Heqy]|Hgty].
   cut (x < y).
   intro.
   apply IVT; assumption.
   inversion H0.
   assumption.
-  rewrite H2 in r.
-  elim (Rlt_irrefl _ (Rlt_trans _ _ _ r a)).
+  rewrite H2 in Hgtx.
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ Hlty Hgtx)).
   exists y.
   split.
   split; [ assumption | right; reflexivity ].
@@ -676,8 +658,7 @@ Proof.
   intro.
   cut (continuity f).
   intro.
-  case (total_order_T y 1); intro.
-  elim s; intro.
+  destruct (total_order_T y 1) as [[Hlt| -> ]|Hgt].
   cut (0 <= f 1).
   intro.
   cut (f 0 * f 1 <= 0).
@@ -701,7 +682,7 @@ Proof.
   exists 1.
   split.
   left; apply Rlt_0_1.
-  rewrite b; symmetry ; apply Rsqr_1.
+  symmetry; apply Rsqr_1.
   cut (0 <= f y).
   intro.
   cut (f 0 * f y <= 0).
@@ -723,7 +704,7 @@ Proof.
   pattern y at 1; rewrite <- Rmult_1_r.
   unfold Rsqr; apply Rmult_le_compat_l.
   assumption.
-  left; exact r.
+  left; exact Hgt.
   replace f with (Rsqr - fct_cte y)%F.
   apply continuity_minus.
   apply derivable_continuous; apply derivable_Rsqr.
@@ -743,39 +724,31 @@ Definition Rsqrt (y:nonnegreal) : R :=
 Lemma Rsqrt_positivity : forall x:nonnegreal, 0 <= Rsqrt x.
 Proof.
   intro.
-  assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
-  elim X; intros.
+  destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2).
   cut (x0 = Rsqrt x).
   intros.
-  elim p; intros.
-  rewrite H in H0; assumption.
+  rewrite <- H; assumption.
   unfold Rsqrt.
-  case (Rsqrt_exists x (cond_nonneg x)).
-  intros.
-  elim p; elim a; intros.
+  case (Rsqrt_exists x (cond_nonneg x)) as (?,[]).
   apply Rsqr_inj.
   assumption.
   assumption.
-  rewrite <- H0; rewrite <- H2; reflexivity.
+  rewrite <- H0, <- H2; reflexivity.
 Qed.
 
 (**********)
 Lemma Rsqrt_Rsqrt : forall x:nonnegreal, Rsqrt x * Rsqrt x = x.
 Proof.
   intros.
-  assert (X := Rsqrt_exists (nonneg x) (cond_nonneg x)).
-  elim X; intros.
+  destruct (Rsqrt_exists (nonneg x) (cond_nonneg x)) as (x0 & H1 & H2).
   cut (x0 = Rsqrt x).
   intros.
   rewrite <- H.
-  elim p; intros.
-  rewrite H1; reflexivity.
+  rewrite H2; reflexivity.
   unfold Rsqrt.
-  case (Rsqrt_exists x (cond_nonneg x)).
-  intros.
-  elim p; elim a; intros.
+  case (Rsqrt_exists x (cond_nonneg x)) as (x1 & ? & ?).
   apply Rsqr_inj.
   assumption.
   assumption.
-  rewrite <- H0; rewrite <- H2; reflexivity.
+  rewrite <- H0, <- H2; reflexivity.
 Qed.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index 9a345153..72e4142b 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -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        *)
@@ -84,7 +84,7 @@ Proof.
     apply H4.
   unfold del; rewrite <- (Rabs_Ropp (x - x1)); rewrite Ropp_minus_distr;
     ring.
-  unfold del; apply Rplus_lt_reg_r with (Rabs (x - x1));
+  unfold del; apply Rplus_lt_reg_l with (Rabs (x - x1));
     rewrite Rplus_0_r;
       replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
       [ idtac | ring ].
@@ -139,7 +139,7 @@ Proof.
     apply H10.
   unfold del; simpl; rewrite <- (Rabs_Ropp (x - x1));
     rewrite Ropp_minus_distr; ring.
-  apply Rplus_lt_reg_r with (Rabs (x - x1)); rewrite Rplus_0_r;
+  apply Rplus_lt_reg_l with (Rabs (x - x1)); rewrite Rplus_0_r;
     replace (Rabs (x - x1) + (x0 - Rabs (x - x1))) with (pos x0);
     [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H6 | ring ].
 Qed.
@@ -254,7 +254,7 @@ Proof.
   apply H4.
   unfold del2; simpl; rewrite <- (Rabs_Ropp (x - x0));
     rewrite Ropp_minus_distr; ring.
-  apply Rplus_lt_reg_r with (Rabs (x - x0)); rewrite Rplus_0_r;
+  apply Rplus_lt_reg_l with (Rabs (x - x0)); rewrite Rplus_0_r;
     replace (Rabs (x - x0) + (del - Rabs (x - x0))) with (pos del);
     [ rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H2 | ring ].
   apply interior_P1.
@@ -623,87 +623,79 @@ Qed.
 (** Borel-Lebesgue's lemma *)
 Lemma compact_P3 : forall a b:R, compact (fun c:R => a <= c <= b).
 Proof.
-  intros; case (Rle_dec a b); intro.
-  unfold compact; intros;
+  intros a b; destruct (Rle_dec a b) as [Hle|Hnle].
+  unfold compact; intros f0 (H,H5);
     set
       (A :=
         fun x:R =>
           a <= x <= b /\
           (exists D : R -> Prop,
-            covering_finite (fun c:R => a <= c <= x) (subfamily f0 D)));
-      cut (A a).
-  intro; cut (bound A).
-  intro; cut (exists a0 : R, A a0).
-  intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3;
-    unfold is_lub in H3; cut (a <= m <= b).
-  intro; unfold covering_open_set in H; elim H; clear H; intros;
-    unfold covering in H; assert (H6 := H m H4); elim H6;
-      clear H6; intros y0 H6; unfold family_open_set in H5;
-        assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6);
-          unfold neighbourhood in H8; elim H8; clear H8; intros eps H8;
-            cut (exists x : R, A x /\ m - eps < x <= m).
-  intro; elim H9; clear H9; intros x H9; elim H9; clear H9; intros;
-    case (Req_dec m b); intro.
-  rewrite H11 in H10; rewrite H11 in H8; unfold A in H9; elim H9; clear H9;
-    intros; elim H12; clear H12; intros Dx H12;
-      set (Db := fun x:R => Dx x \/ x = y0); exists Db;
-        unfold covering_finite; split.
-  unfold covering; unfold covering_finite in H12; elim H12; clear H12;
-    intros; unfold covering in H12; case (Rle_dec x0 x);
-      intro.
-  cut (a <= x0 <= x).
-  intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
-    simpl in H16; simpl; unfold Db; elim H16;
-      clear H16; intros; split; [ apply H16 | left; apply H17 ].
-  split.
-  elim H14; intros; assumption.
-  assumption.
+            covering_finite (fun c:R => a <= c <= x) (subfamily f0 D))).
+  cut (A a); [intro H0|].
+  cut (bound A); [intro H1|].
+  cut (exists a0 : R, A a0); [intro H2|].
+  pose proof (completeness A H1 H2) as (m,H3); unfold is_lub in H3.
+  cut (a <= m <= b); [intro H4|].
+  unfold covering in H; pose proof (H m H4) as (y0,H6).
+  unfold family_open_set in H5; pose proof (H5 y0 m H6) as (eps,H8).
+  cut (exists x : R, A x /\ m - eps < x <= m);
+    [intros (x,((H9 & Dx & H12 & H13),(Hltx,_)))|].
+  destruct (Req_dec m b) as [->|H11].
+  set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+    unfold covering_finite; split.
+      unfold covering; intros x0 (H14,H18);
+      unfold covering in H12; destruct (Rle_dec x0 x) as [Hle'|Hnle'].
+  cut (a <= x0 <= x); [intro H15|].
+  pose proof (H12 x0 H15) as (x1 & H16 & H17); exists x1;
+    simpl; unfold Db; split; [ apply H16 | left; apply H17 ].
+  split; assumption.
   exists y0; simpl; split.
-  apply H8; unfold disc; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr;
-    rewrite Rabs_right.
+  apply H8; unfold disc;
+    rewrite <- Rabs_Ropp, Ropp_minus_distr, Rabs_right.
   apply Rlt_trans with (b - x).
-  unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
+  unfold Rminus; apply Rplus_lt_compat_l, Ropp_lt_gt_contravar;
     auto with real.
-  elim H10; intros H15 _; apply Rplus_lt_reg_r with (x - eps);
+  apply Rplus_lt_reg_l with (x - eps);
     replace (x - eps + (b - x)) with (b - eps);
-    [ replace (x - eps + eps) with x; [ apply H15 | ring ] | ring ].
-  apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15.
+    [ replace (x - eps + eps) with x; [ apply Hltx | ring ] | ring ].
+  apply Rge_minus, Rle_ge, H18.
   unfold Db; right; reflexivity.
-  unfold family_finite; unfold domain_finite;
-    unfold covering_finite in H12; elim H12; clear H12;
+  unfold family_finite, domain_finite.
       intros; unfold family_finite in H13; unfold domain_finite in H13;
-        elim H13; clear H13; intros l H13; exists (cons y0 l);
+        destruct H13 as (l,H13); exists (cons y0 l);
           intro; split.
-  intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
-    clear H13; intros; case (Req_dec x0 y0); intro.
+  intro H14; simpl in H14; unfold intersection_domain in H14;
+    specialize H13 with x0; destruct H13 as (H13,H15);
+    destruct (Req_dec x0 y0) as [H16|H16].
   simpl; left; apply H16.
   simpl; right; apply H13.
   simpl; unfold intersection_domain; unfold Db in H14;
     decompose [and or] H14.
   split; assumption.
   elim H16; assumption.
-  intro; simpl in H14; elim H14; intro; simpl;
+  intro H14; simpl in H14; destruct H14 as [H15|H15]; simpl;
     unfold intersection_domain.
   split.
-  apply (cond_fam f0); rewrite H15; exists m; apply H6.
+  apply (cond_fam f0); rewrite H15; exists b; apply H6.
   unfold Db; right; assumption.
   simpl; unfold intersection_domain; elim (H13 x0).
   intros _ H16; assert (H17 := H16 H15); simpl in H17;
     unfold intersection_domain in H17; split.
   elim H17; intros; assumption.
   unfold Db; left; elim H17; intros; assumption.
-  set (m' := Rmin (m + eps / 2) b); cut (A m').
-  intro; elim H3; intros; unfold is_upper_bound in H13;
-    assert (H15 := H13 m' H12); cut (m < m').
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H15 H16)).
-  unfold m'; unfold Rmin; case (Rle_dec (m + eps / 2) b); intro.
-  pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
-    unfold Rdiv; apply Rmult_lt_0_compat;
-      [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim H4; intros.
-  elim H17; intro.
-  assumption.
-  elim H11; assumption.
+  set (m' := Rmin (m + eps / 2) b).
+  cut (A m'); [intro H7|].
+    destruct H3 as (H14,H15); unfold is_upper_bound in H14.
+    assert (H16 := H14 m' H7).
+      cut (m < m'); [intro H17|].
+        elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H16 H17))...
+      unfold m', Rmin; destruct (Rle_dec (m + eps / 2) b) as [Hle'|Hnle'].
+        pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
+          unfold Rdiv; apply Rmult_lt_0_compat;
+          [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
+        destruct H4 as (_,[]).
+          assumption.
+          elim H11; assumption.
   unfold A; split.
   split.
   apply Rle_trans with m.
@@ -712,38 +704,32 @@ Proof.
   pattern m at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     unfold Rdiv; apply Rmult_lt_0_compat;
       [ apply (cond_pos eps) | apply Rinv_0_lt_compat; prove_sup0 ].
-  elim H4; intros.
-  elim H13; intro.
+  destruct H4.
   assumption.
-  elim H11; assumption.
   unfold m'; apply Rmin_r.
-  unfold A in H9; elim H9; clear H9; intros; elim H12; clear H12; intros Dx H12;
-    set (Db := fun x:R => Dx x \/ x = y0); exists Db;
-      unfold covering_finite; split.
-  unfold covering; unfold covering_finite in H12; elim H12; clear H12;
-    intros; unfold covering in H12; case (Rle_dec x0 x);
-      intro.
-  cut (a <= x0 <= x).
-  intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1;
-    simpl in H16; simpl; unfold Db.
-  elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ].
-  elim H14; intros; split; assumption.
+  set (Db := fun x:R => Dx x \/ x = y0); exists Db;
+    unfold covering_finite; split.
+      unfold covering; intros x0 (H14,H18);
+      unfold covering in H12; destruct (Rle_dec x0 x) as [Hle'|Hnle'].
+  cut (a <= x0 <= x); [intro H15|].
+  pose proof (H12 x0 H15) as (x1 & H16 & H17); exists x1;
+    simpl; unfold Db; split; [ apply H16 | left; apply H17 ].
+  split; assumption.
   exists y0; simpl; split.
-  apply H8; unfold disc; unfold Rabs; case (Rcase_abs (x0 - m));
-    intro.
+  apply H8; unfold disc, Rabs; destruct (Rcase_abs (x0 - m)) as [Hlt|Hge].
   rewrite Ropp_minus_distr; apply Rlt_trans with (m - x).
   unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_gt_contravar;
     auto with real.
-  apply Rplus_lt_reg_r with (x - eps);
+  apply Rplus_lt_reg_l with (x - eps);
     replace (x - eps + (m - x)) with (m - eps).
   replace (x - eps + eps) with x.
-  elim H10; intros; assumption.
+  assumption.
   ring.
   ring.
   apply Rle_lt_trans with (m' - m).
   unfold Rminus; do 2 rewrite <- (Rplus_comm (- m));
     apply Rplus_le_compat_l; elim H14; intros; assumption.
-  apply Rplus_lt_reg_r with m; replace (m + (m' - m)) with m'.
+  apply Rplus_lt_reg_l with m; replace (m + (m' - m)) with m'.
   apply Rle_lt_trans with (m + eps / 2).
   unfold m'; apply Rmin_l.
   apply Rplus_lt_compat_l; apply Rmult_lt_reg_l with 2.
@@ -755,22 +741,20 @@ Proof.
   discrR.
   ring.
   unfold Db; right; reflexivity.
-  unfold family_finite; unfold domain_finite;
-    unfold covering_finite in H12; elim H12; clear H12;
-      intros; unfold family_finite in H13; unfold domain_finite in H13;
-        elim H13; clear H13; intros l H13; exists (cons y0 l);
+  unfold family_finite, domain_finite;
+    unfold family_finite, domain_finite in H13;
+    destruct H13 as (l,H13); exists (cons y0 l);
           intro; split.
-  intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0);
-    clear H13; intros; case (Req_dec x0 y0); intro.
-  simpl; left; apply H16.
+  intro H14; simpl in H14; unfold intersection_domain in H14;
+    specialize (H13 x0); destruct H13 as (H13,H15);
+    destruct (Req_dec x0 y0) as [Heq|Hneq].
+  simpl; left; apply Heq.
   simpl; right; apply H13; simpl;
     unfold intersection_domain; unfold Db in H14;
       decompose [and or] H14.
   split; assumption.
-  elim H16; assumption.
-  intro; simpl in H14; elim H14; intro; simpl;
-    unfold intersection_domain.
-  split.
+  elim Hneq; assumption.
+  intros [H15|H15]. split.
   apply (cond_fam f0); rewrite H15; exists m; apply H6.
   unfold Db; right; assumption.
   elim (H13 x0); intros _ H16.
@@ -780,22 +764,22 @@ Proof.
   split.
   elim H17; intros; assumption.
   unfold Db; left; elim H17; intros; assumption.
-  elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro.
+  elim (classic (exists x : R, A x /\ m - eps < x <= m)); intro H9.
   assumption.
-  elim H3; intros; cut (is_upper_bound A (m - eps)).
-  intro; assert (H13 := H11 _ H12); cut (m - eps < m).
-  intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
+  elim H3; intros H10 H11; cut (is_upper_bound A (m - eps)).
+  intro H12; assert (H13 := H11 _ H12); cut (m - eps < m).
+  intro H14; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H13 H14)).
   pattern m at 2; rewrite <- Rplus_0_r; unfold Rminus;
     apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_involutive;
       rewrite Ropp_0; apply (cond_pos eps).
   set (P := fun n:R => A n /\ m - eps < n <= m);
     assert (H12 := not_ex_all_not _ P H9); unfold P in H12;
-      unfold is_upper_bound; intros;
+      unfold is_upper_bound; intros x H13;
         assert (H14 := not_and_or _ _ (H12 x)); elim H14;
-          intro.
+          intro H15.
   elim H15; apply H13.
-  elim (not_and_or _ _ H15); intro.
-  case (Rle_dec x (m - eps)); intro.
+  destruct (not_and_or _ _ H15) as [H16|H16].
+  destruct (Rle_dec x (m - eps)) as [H17|H17].
   assumption.
   elim H16; auto with real.
   unfold is_upper_bound in H10; assert (H17 := H10 x H13); elim H16; apply H17.
@@ -803,7 +787,8 @@ Proof.
   unfold is_upper_bound in H3.
   split.
   apply (H3 _ H0).
-  apply (H4 b); unfold is_upper_bound; intros; unfold A in H5; elim H5;
+  clear H5.
+  apply (H4 b); unfold is_upper_bound; intros x H5; unfold A in H5; elim H5;
     clear H5; intros H5 _; elim H5; clear H5; intros _ H5;
       apply H5.
   exists a; apply H0.
@@ -811,30 +796,28 @@ Proof.
     unfold A in H1; elim H1; clear H1; intros H1 _; elim H1;
       clear H1; intros _ H1; apply H1.
   unfold A; split.
-  split; [ right; reflexivity | apply r ].
-  unfold covering_open_set in H; elim H; clear H; intros; unfold covering in H;
-    cut (a <= a <= b).
-  intro; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
+  split; [ right; reflexivity | apply Hle ].
+  unfold covering in H; cut (a <= a <= b).
+  intro H1; elim (H _ H1); intros y0 H2; set (D' := fun x:R => x = y0); exists D';
     unfold covering_finite; split.
-  unfold covering; simpl; intros; cut (x = a).
-  intro; exists y0; split.
+  unfold covering; simpl; intros x H3; cut (x = a).
+  intro H4; exists y0; split.
   rewrite H4; apply H2.
   unfold D'; reflexivity.
   elim H3; intros; apply Rle_antisym; assumption.
   unfold family_finite; unfold domain_finite;
     exists (cons y0 nil); intro; split.
-  simpl; unfold intersection_domain; intro; elim H3; clear H3;
-    intros; unfold D' in H4; left; apply H4.
-  simpl; unfold intersection_domain; intro; elim H3; intro.
+  simpl; unfold intersection_domain; intros (H3,H4).
+    unfold D' in H4; left; apply H4.
+  simpl; unfold intersection_domain; intros [H4|[]].
   split; [ rewrite H4; apply (cond_fam f0); exists a; apply H2 | apply H4 ].
-  elim H4.
-  split; [ right; reflexivity | apply r ].
+  split; [ right; reflexivity | apply Hle ].
   apply compact_eqDom with (fun c:R => False).
   apply compact_EMP.
   unfold eq_Dom; split.
   unfold included; intros; elim H.
   unfold included; intros; elim H; clear H; intros;
-    assert (H1 := Rle_trans _ _ _ H H0); elim n; apply H1.
+    assert (H1 := Rle_trans _ _ _ H H0); elim Hnle; apply H1.
 Qed.
 
 Lemma compact_P4 :
@@ -982,12 +965,6 @@ Proof.
     intros; exists (f0 x0); apply H4.
 Qed.
 
-Lemma Rlt_Rminus : forall a b:R, a < b -> 0 < b - a.
-Proof.
-  intros; apply Rplus_lt_reg_r with a; rewrite Rplus_0_r;
-    replace (a + (b - a)) with b; [ assumption | ring ].
-Qed.
-
 Lemma prolongement_C0 :
   forall (f:R -> R) (a b:R),
     a <= b ->
@@ -1017,14 +994,14 @@ Proof.
         split.
   change (0 < a - x); apply Rlt_Rminus; assumption.
   intros; elim H5; clear H5; intros _ H5; unfold h.
-  case (Rle_dec x a); intro.
-  case (Rle_dec x0 a); intro.
-  unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-  elim n; left; apply Rplus_lt_reg_r with (- x);
+  case (Rle_dec x a) as [|[]].
+  case (Rle_dec x0 a) as [|[]].
+  unfold Rminus; rewrite Rplus_opp_r, Rabs_R0; assumption.
+  left; apply Rplus_lt_reg_l with (- x);
     do 2 rewrite (Rplus_comm (- x)); apply Rle_lt_trans with (Rabs (x0 - x)).
   apply RRle_abs.
   assumption.
-  elim n; left; assumption.
+  left; assumption.
   elim H3; intro.
   assert (H5 : a <= a <= b).
   split; [ right; reflexivity | left; assumption ].
@@ -1039,20 +1016,20 @@ Proof.
   elim H8; intros; assumption.
   change (0 < b - a); apply Rlt_Rminus; assumption.
   intros; elim H9; clear H9; intros _ H9; cut (x1 < b).
-  intro; unfold h; case (Rle_dec x a); intro.
-  case (Rle_dec x1 a); intro.
+  intro; unfold h; case (Rle_dec x a) as [|[]].
+  case (Rle_dec x1 a) as [Hlta|Hnlea].
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-  case (Rle_dec x1 b); intro.
+  case (Rle_dec x1 b) as [Hleb|[]].
   elim H8; intros; apply H12; split.
   unfold D_x, no_cond; split.
   trivial.
-  red; intro; elim n; right; symmetry ; assumption.
+  red; intro; elim Hnlea; right; symmetry ; assumption.
   apply Rlt_le_trans with (Rmin x0 (b - a)).
   rewrite H4 in H9; apply H9.
   apply Rmin_l.
-  elim n0; left; assumption.
-  elim n; right; assumption.
-  apply Rplus_lt_reg_r with (- a); do 2 rewrite (Rplus_comm (- a));
+  left; assumption.
+  right; assumption.
+  apply Rplus_lt_reg_l with (- a); do 2 rewrite (Rplus_comm (- a));
     rewrite H4 in H9; apply Rle_lt_trans with (Rabs (x1 - a)).
   apply RRle_abs.
   apply Rlt_le_trans with (Rmin x0 (b - a)).
@@ -1073,30 +1050,29 @@ Proof.
   assert (H12 : 0 < b - x).
   apply Rlt_Rminus; assumption.
   exists (Rmin x0 (Rmin (x - a) (b - x))); split.
-  unfold Rmin; case (Rle_dec (x - a) (b - x)); intro.
-  case (Rle_dec x0 (x - a)); intro.
+  unfold Rmin; case (Rle_dec (x - a) (b - x)) as [Hle|Hnle].
+  case (Rle_dec x0 (x - a)) as [Hlea|Hnlea].
   assumption.
   assumption.
-  case (Rle_dec x0 (b - x)); intro.
+  case (Rle_dec x0 (b - x)) as [Hleb|Hnleb].
   assumption.
   assumption.
-  intros; elim H13; clear H13; intros; cut (a < x1 < b).
-  intro; elim H15; clear H15; intros; unfold h; case (Rle_dec x a);
-    intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-  case (Rle_dec x b); intro.
-  case (Rle_dec x1 a); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H15)).
-  case (Rle_dec x1 b); intro.
+  intros x1 (H13,H14); cut (a < x1 < b).
+  intro; elim H15; clear H15; intros; unfold h; case (Rle_dec x a) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H4)).
+  case (Rle_dec x b) as [|[]].
+  case (Rle_dec x1 a) as [Hle0|].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle0 H15)).
+  case (Rle_dec x1 b) as [|[]].
   apply H10; split.
   assumption.
   apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
   assumption.
   apply Rmin_l.
-  elim n1; left; assumption.
-  elim n0; left; assumption.
+  left; assumption.
+  left; assumption.
   split.
-  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_l with x;
     apply Rle_lt_trans with (Rabs (x1 - x)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
   apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
@@ -1104,7 +1080,7 @@ Proof.
   apply Rle_trans with (Rmin (x - a) (b - x)).
   apply Rmin_r.
   apply Rmin_l.
-  apply Rplus_lt_reg_r with (- x); do 2 rewrite (Rplus_comm (- x));
+  apply Rplus_lt_reg_l with (- x); do 2 rewrite (Rplus_comm (- x));
     apply Rle_lt_trans with (Rabs (x1 - x)).
   apply RRle_abs.
   apply Rlt_le_trans with (Rmin x0 (Rmin (x - a) (b - x))).
@@ -1124,13 +1100,13 @@ Proof.
   elim H10; intros; assumption.
   change (0 < b - a); apply Rlt_Rminus; assumption.
   intros; elim H11; clear H11; intros _ H11; cut (a < x1).
-  intro; unfold h; case (Rle_dec x a); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-  case (Rle_dec x1 a); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H12)).
-  case (Rle_dec x b); intro.
-  case (Rle_dec x1 b); intro.
-  rewrite H6; elim H10; intros; elim r0; intro.
+  intro; unfold h; case (Rle_dec x a) as [Hlea|Hnlea].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlea H4)).
+  case (Rle_dec x1 a) as [Hlea'|Hnlea'].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hlea' H12)).
+  case (Rle_dec x b) as [Hleb|Hnleb].
+  case (Rle_dec x1 b) as [Hleb'|Hnleb'].
+  rewrite H6; elim H10; intros; destruct Hleb'.
   apply H14; split.
   unfold D_x, no_cond; split.
   trivial.
@@ -1142,8 +1118,8 @@ Proof.
     assumption.
   rewrite H6; unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0;
     assumption.
-  elim n1; right; assumption.
-  rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_r with b;
+  elim Hnleb; right; assumption.
+  rewrite H6 in H11; apply Ropp_lt_cancel; apply Rplus_lt_reg_l with b;
     apply Rle_lt_trans with (Rabs (x1 - b)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
   apply Rlt_le_trans with (Rmin x0 (b - a)).
@@ -1156,26 +1132,25 @@ Proof.
   change (0 < x - b); apply Rlt_Rminus; assumption.
   intros; elim H8; clear H8; intros.
   assert (H10 : b < x0).
-  apply Ropp_lt_cancel; apply Rplus_lt_reg_r with x;
+  apply Ropp_lt_cancel; apply Rplus_lt_reg_l with x;
     apply Rle_lt_trans with (Rabs (x0 - x)).
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply RRle_abs.
   assumption.
-  unfold h; case (Rle_dec x a); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H4)).
-  case (Rle_dec x b); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H6)).
-  case (Rle_dec x0 a); intro.
-  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 r))).
-  case (Rle_dec x0 b); intro.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r H10)).
+  unfold h; case (Rle_dec x a) as [Hle|Hnle].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hle H4)).
+  case (Rle_dec x b) as [Hleb|Hnleb].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hleb H6)).
+  case (Rle_dec x0 a) as [Hlea'|Hnlea'].
+  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H1 (Rlt_le_trans _ _ _ H10 Hlea'))).
+  case (Rle_dec x0 b) as [Hleb'|Hnleb'].
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ Hleb' H10)).
   unfold Rminus; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
-  intros; elim H3; intros; unfold h; case (Rle_dec c a); intro.
-  elim r; intro.
+  intros; elim H3; intros; unfold h; case (Rle_dec c a) as [[|]|].
   elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H4 H6)).
   rewrite H6; reflexivity.
-  case (Rle_dec c b); intro.
+  case (Rle_dec c b) as [|[]].
   reflexivity.
-  elim n0; assumption.
+  assumption.
   exists (fun _:R => f0 a); split.
   apply derivable_continuous; apply (derivable_const (f0 a)).
   intros; elim H2; intros; rewrite H1 in H3; cut (b = c).
@@ -1229,11 +1204,11 @@ Proof.
     apply Rplus_lt_compat_l; apply Ropp_lt_cancel; rewrite Ropp_0;
       rewrite Ropp_involutive; apply (cond_pos eps).
   unfold is_upper_bound, image_dir; intros; cut (x <= M).
-  intro; case (Rle_dec x (M - eps)); intro.
-  apply r.
+  intro; destruct (Rle_dec x (M - eps)) as [H13|].
+  apply H13.
   elim (H9 x); unfold intersection_domain, disc, image_dir; split.
   rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite Rabs_right.
-  apply Rplus_lt_reg_r with (x - eps);
+  apply Rplus_lt_reg_l with (x - eps);
     replace (x - eps + (M - x)) with (M - eps).
   replace (x - eps + eps) with x.
   auto with real.
@@ -1615,13 +1590,12 @@ Proof.
   apply H3.
   elim Hyp; intros; elim H4; intros; decompose [and] H5;
     assert (H10 := H3 _ H6); assert (H11 := H3 _ H8);
-      elim H10; intros; elim H11; intros; case (total_order_T x x0);
-        intro.
-  elim s; intro.
+      elim H10; intros; elim H11; intros;
+      destruct (total_order_T x x0) as [[|H15]|H15].
   assumption.
-  rewrite b in H13; rewrite b in H7; elim H9; apply Rle_antisym;
+  rewrite H15 in H13, H7; elim H9; apply Rle_antisym;
     apply Rle_trans with x0; assumption.
-  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) r)).
+  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H13 H14) H15)).
   elim X_enc; clear X_enc; intros m X_enc; elim X_enc; clear X_enc;
     intros M X_enc; elim X_enc; clear X_enc Hyp; intros X_enc Hyp;
       unfold uniform_continuity; intro;
@@ -1675,9 +1649,9 @@ Proof.
   apply H7; split.
   unfold D_x, no_cond; split; [ trivial | assumption ].
   apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H8 | apply Rmin_l ].
-  assert (H8 := completeness _ H6 H7); elim H8; clear H8; intros;
+  destruct (completeness _ H6 H7) as (x1,p).
     cut (0 < x1 <= M - m).
-  intro; elim H8; clear H8; intros; exists (mkposreal _ H8); split.
+  intros (H8,H9); exists (mkposreal _ H8); split.
   intros; cut (exists alp : R, Rabs (z - x) < alp <= x1 /\ E alp).
   intros; elim H11; intros; elim H12; clear H12; intros; unfold E in H13;
     elim H13; intros; apply H15.
@@ -1831,7 +1805,7 @@ Proof.
   apply H14; split;
     [ unfold D_x, no_cond; split; [ trivial | assumption ]
       | apply Rlt_le_trans with (Rmin x0 (M - m)); [ apply H15 | apply Rmin_l ] ].
-  assert (H13 := completeness _ H11 H12); elim H13; clear H13; intros;
+  destruct (completeness _ H11 H12) as (x0,p).
     cut (0 < x0 <= M - m).
   intro; elim H13; clear H13; intros; exists x0; split.
   assumption.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index 6818e9a1..44058358 100644
--- a/theories/Reals/Rtrigo.v
+++ b/theories/Reals/Rtrigo.v
@@ -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        *)
@@ -16,11 +16,10 @@ Require Export Cos_rel.
 Require Export Cos_plus.
 Require Import ZArith_base.
 Require Import Zcomplements.
-Require Import Classical_Prop.
 Require Import Fourier.
 Require Import Ranalysis1.
 Require Import Rsqrt_def. 
 Require Import PSeries_reg.
 Require Export Rtrigo1.
 Require Export Ratan.
-Require Export Machin.
\ No newline at end of file
+Require Export Machin.
diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v
index b940455f..9e485ec5 100644
--- a/theories/Reals/Rtrigo1.v
+++ b/theories/Reals/Rtrigo1.v
@@ -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        *)
@@ -16,7 +16,6 @@ Require Export Cos_rel.
 Require Export Cos_plus.
 Require Import ZArith_base.
 Require Import Zcomplements.
-Require Import Classical_Prop.
 Require Import Fourier.
 Require Import Ranalysis1.
 Require Import Rsqrt_def. 
@@ -40,7 +39,7 @@ Proof.
         (fun n:nat =>
           sum_f_R0 (fun k:nat => Rabs (/ INR (fact (2 * k)) * r ^ (2 * k)))
           n) l }.
-  intro X; elim X; intros.
+  intros (x,p).
   exists x.
   split.
   apply p.
@@ -148,11 +147,11 @@ Proof.
   apply H4.
   intros; rewrite (H0 x); rewrite (H0 x1); apply H5; apply H6.
   intro; unfold cos, SFL in |- *.
-  case (cv x); case (exist_cos (Rsqr x)); intros.
-  symmetry  in |- *; eapply UL_sequence.
-  apply u.
-  unfold cos_in in c; unfold infinite_sum in c; unfold Un_cv in |- *; intros.
-  elim (c _ H0); intros N0 H1.
+  case (cv x) as (x1,HUn); case (exist_cos (Rsqr x)) as (x0,Hcos); intros.
+  symmetry; eapply UL_sequence.
+  apply HUn.
+  unfold cos_in, infinite_sum in Hcos; unfold Un_cv in |- *; intros.
+  elim (Hcos _ H0); intros N0 H1.
   exists N0; intros.
   unfold R_dist in H1; unfold R_dist, SP in |- *.
   replace (sum_f_R0 (fun k:nat => fn k x) n) with
@@ -586,8 +585,8 @@ Qed.
 
 Lemma SIN_bound : forall x:R, -1 <= sin x <= 1.
 Proof.
-  intro; case (Rle_dec (-1) (sin x)); intro.
-  case (Rle_dec (sin x) 1); intro.
+  intro; destruct (Rle_dec (-1) (sin x)) as [Hle|Hnle].
+  destruct (Rle_dec (sin x) 1) as [Hle'|Hnle'].
   split; assumption.
   cut (1 < sin x).
   intro;
@@ -670,11 +669,11 @@ Proof.
     replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with
     (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ].
   apply Rplus_lt_0_compat.
-  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat);
+  unfold Rminus in |- *; apply Rplus_lt_reg_l with (Un 1%nat);
     rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat));
       rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
         apply H1.
-  unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat);
+  unfold Rminus in |- *; apply Rplus_lt_reg_l with (Un 3%nat);
     rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat));
       rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r;
         apply H1.
@@ -722,7 +721,7 @@ Proof.
     unfold INR in |- *.
   replace ((2 * x + 1 + 1 + 1) * (2 * x + 1 + 1)) with (4 * x * x + 10 * x + 6);
   [ idtac | ring ].
-  apply Rplus_lt_reg_r with (-4); rewrite Rplus_opp_l;
+  apply Rplus_lt_reg_l with (-4); rewrite Rplus_opp_l;
     replace (-4 + (4 * x * x + 10 * x + 6)) with (4 * x * x + 10 * x + 2);
     [ idtac | ring ].
   apply Rplus_le_lt_0_compat.
@@ -1201,7 +1200,7 @@ Proof.
   replace (- (PI - x)) with (x - PI).
   replace (- (PI - y)) with (y - PI).
   intros; change (sin (y - PI) < sin (x - PI)) in H8;
-    apply Rplus_lt_reg_r with (- PI); rewrite Rplus_comm;
+    apply Rplus_lt_reg_l with (- PI); rewrite Rplus_comm;
       replace (y + - PI) with (y - PI).
   rewrite Rplus_comm; replace (x + - PI) with (x - PI).
   apply (sin_increasing_0 (y - PI) (x - PI) H4 H5 H6 H7 H8).
@@ -1273,7 +1272,7 @@ Proof.
   replace (-3 * (PI / 2) + 2 * PI) with (PI / 2).
   replace (-3 * (PI / 2) + PI) with (- (PI / 2)).
   clear H1 H2 H3 H4; intros H1 H2 H3 H4;
-    apply Rplus_lt_reg_r with (-3 * (PI / 2));
+    apply Rplus_lt_reg_l with (-3 * (PI / 2));
       replace (-3 * (PI / 2) + x) with (x - 3 * (PI / 2)).
   replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)).
   apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5).
@@ -1352,7 +1351,7 @@ Proof.
             generalize (Rplus_le_compat_l PI 0 y H1);
               generalize (Rplus_le_compat_l PI y PI H2); rewrite Rplus_0_r.
   rewrite <- double.
-  clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_r with PI;
+  clear H H0 H1 H2 H3; intros; apply Rplus_lt_reg_l with PI;
     apply (cos_increasing_0 (PI + y) (PI + x) H0 H H2 H1 H4).
 Qed.
 
@@ -1919,7 +1918,7 @@ Proof.
       apply (Rmult_lt_reg_r PI); [apply PI_RGT_0|rewrite Rmult_1_l].
       replace (3*(PI/2)) with (PI/2 + PI) in GT by field.
       rewrite Rplus_comm in GT.
-      now apply Rplus_lt_reg_r in GT. }
+      now apply Rplus_lt_reg_l in GT. }
     omega.
 Qed.
 
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index cdc96f98..3d36cb34 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -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        *)
@@ -134,13 +134,13 @@ Proof.
   apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
   apply le_n_Sn.
   ring.
-  assert (X := exist_sin (Rsqr a)); elim X; intros.
-  cut (x = sin a / a).
-  intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv; unfold R_dist;
+  unfold sin.
+  destruct (exist_sin (Rsqr a)) as (x,p).
+  unfold sin_in, infinite_sum, R_dist in p;
+      unfold Un_cv, R_dist;
       intros.
   cut (0 < eps / Rabs a).
-  intro; elim (p _ H5); intros N H6.
+  intro H4; destruct (p _ H4) as (N,H6).
   exists N; intros.
   replace (sum_f_R0 (tg_alt Un) n0) with
   (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))).
@@ -151,12 +151,12 @@ Proof.
           rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a).
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
   pattern (/ Rabs a) at 1; rewrite <- (Rabs_Rinv a Hyp_a).
-  rewrite <- Rabs_mult; rewrite Rmult_plus_distr_l; rewrite <- Rmult_assoc;
-    rewrite <- Rinv_l_sym; [ rewrite Rmult_1_l | assumption ];
-      rewrite (Rmult_comm (/ a)); rewrite (Rmult_comm (/ Rabs a));
-        rewrite <- Rabs_Ropp; rewrite Ropp_plus_distr; rewrite Ropp_involutive;
-          unfold Rminus, Rdiv in H6; apply H6; unfold ge;
-            apply le_trans with n0; [ exact H7 | apply le_n_Sn ].
+  rewrite <- Rabs_mult, Rmult_plus_distr_l, <- 2!Rmult_assoc, <- Rinv_l_sym;
+    [ rewrite Rmult_1_l | assumption ];
+      rewrite (Rmult_comm (/ Rabs a)),
+        <- Rabs_Ropp, Ropp_plus_distr, Ropp_involutive, Rmult_1_l.
+          unfold Rminus, Rdiv in H6. apply H6; unfold ge;
+            apply le_trans with n0; [ exact H5 | apply le_n_Sn ].
   rewrite (decomp_sum (fun i:nat => sin_n i * Rsqr a ^ i) (S n0)).
   replace (sin_n 0) with 1.
   simpl; rewrite Rmult_1_r; unfold Rminus;
@@ -176,13 +176,6 @@ Proof.
   unfold Rdiv; apply Rmult_lt_0_compat.
   assumption.
   apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
-  unfold sin; case (exist_sin (Rsqr a)).
-  intros; cut (x = x0).
-  intro; rewrite H3; unfold Rdiv.
-  symmetry ; apply Rinv_r_simpl_m; assumption.
-  unfold sin_in in p; unfold sin_in in s; eapply uniqueness_sum.
-  apply p.
-  apply s.
   intros; elim H2; intros.
   replace (sin a - a) with (- (a - sin a)); [ idtac | ring ].
   split; apply Ropp_le_contravar; assumption.
@@ -318,12 +311,10 @@ Proof.
   apply le_n_2n.
   apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_Sn.
   apply (fun m n p:nat => mult_le_compat_l p n m); apply le_n_S; assumption.
-  assert (X := exist_cos (Rsqr a0)); elim X; intros.
-  cut (x = cos a0).
-  intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p;
-    unfold R_dist in p; unfold Un_cv; unfold R_dist;
-      intros.
-  elim (p _ H5); intros N H6.
+  unfold cos. destruct (exist_cos (Rsqr a0)) as (x,p).
+  unfold cos_in, infinite_sum, R_dist in p;
+   unfold Un_cv, R_dist; intros.
+  destruct (p _ H4) as (N,H6).
   exists N; intros.
   replace (sum_f_R0 (tg_alt Un) n1) with
   (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
@@ -334,7 +325,7 @@ Proof.
           rewrite Ropp_plus_distr; rewrite Ropp_involutive;
             unfold Rminus in H6; apply H6.
   unfold ge; apply le_trans with n1.
-  exact H7.
+  exact H5.
   apply le_n_Sn.
   rewrite (decomp_sum (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)).
   replace (cos_n 0) with 1.
@@ -354,10 +345,6 @@ Proof.
   unfold cos_n; unfold Rdiv; simpl; rewrite Rinv_1;
     rewrite Rmult_1_r; reflexivity.
   apply lt_O_Sn.
-  unfold cos; case (exist_cos (Rsqr a0)); intros; unfold cos_in in p;
-    unfold cos_in in c; eapply uniqueness_sum.
-  apply p.
-  apply c.
   intros; elim H3; intros; replace (cos a0 - 1) with (- (1 - cos a0));
     [ idtac | ring ].
   split; apply Ropp_le_contravar; assumption.
@@ -394,8 +381,7 @@ Proof.
   replace (2 * n0 + 1)%nat with (S (2 * n0)).
   apply lt_O_Sn.
   ring.
-  intros; case (total_order_T 0 a); intro.
-  elim s; intro.
+  intros; destruct (total_order_T 0 a) as [[Hlt|Heq]|Hgt].
   apply H; [ left; assumption | assumption ].
   apply H; [ right; assumption | assumption ].
   cut (0 < - a).
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index 2ad65a92..281c152b 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -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/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index 60df6f78..ef3e31f1 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -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        *)
@@ -221,6 +221,7 @@ Proof.
 Qed.
 
 Lemma cosn_no_R0 : forall n:nat, cos_n n <> 0.
+Proof.
   intro; unfold cos_n; unfold Rdiv; apply prod_neq_R0.
   apply pow_nonzero; discrR.
   apply Rinv_neq_0_compat.
@@ -233,6 +234,7 @@ Definition cos_in (x l:R) : Prop :=
 
 (**********)
 Lemma exist_cos : forall x:R, { l:R | cos_in x l }.
+Proof.
   intro; generalize (Alembert_C3 cos_n x cosn_no_R0 Alembert_cos).
   unfold Pser, cos_in; trivial.
 Qed.
@@ -338,7 +340,7 @@ Proof.
   apply INR_eq; repeat rewrite S_INR; rewrite plus_INR; repeat rewrite mult_INR;
     rewrite plus_INR; rewrite mult_INR; repeat rewrite S_INR;
       replace (INR 0) with 0; [ ring | reflexivity ].
-Defined.
+Qed.
 
 Lemma sin_no_R0 : forall n:nat, sin_n n <> 0.
 Proof.
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index bc2f62a8..b921ee7b 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -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        *)
@@ -20,80 +20,79 @@ Local Open Scope R_scope.
 Lemma Alembert_exp :
   Un_cv (fun n:nat => Rabs (/ INR (fact (S n)) * / / INR (fact n))) 0.
 Proof.
-  unfold Un_cv; intros; elim (Rgt_dec eps 1); intro.
-  split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist;
-    rewrite (Rminus_0_r (Rabs (/ INR (S n))));
-      rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
-  intro; rewrite (Rabs_pos_eq (/ INR (S n))).
-  cut (/ eps - 1 < 0).
-  intro; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n));
-    clear H2; intro; unfold Rminus in H2;
-      generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
-        replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
-  rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
-    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H);
-      intro; unfold Rgt in H3;
-        generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
-          intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
-            rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
-              in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
-                rewrite (Rmult_comm (/ INR (S n))) in H4;
-                  rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
-                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H4;
-                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4;
-                        assumption.
-  apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1;
-    apply (Rinv_lt_contravar 1 eps); auto;
-      rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H;
-        assumption.
-  unfold Rgt in H1; apply Rlt_le; assumption.
-  unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-(**)
-  cut (0 <= up (/ eps - 1))%Z.
-  intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
-    rewrite (simpl_fact n); unfold R_dist;
+  unfold Un_cv; intros; destruct (Rgt_dec eps 1) as [Hgt|Hnotgt].
+  - split with 0%nat; intros; rewrite (simpl_fact n); unfold R_dist;
       rewrite (Rminus_0_r (Rabs (/ INR (S n))));
         rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
-  intro; rewrite (Rabs_pos_eq (/ INR (S n))).
-  cut (/ eps - 1 < INR x).
-  intro ;
-    generalize
-      (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
-        (le_INR x n H2));
-      clear H4; intro; unfold Rminus in H4;
-        generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
-          replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
-  rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
-    generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H);
-      intro; unfold Rgt in H5;
-        generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
-          intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
-            rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
-              in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
-                rewrite (Rmult_comm (/ INR (S n))) in H6;
-                  rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
-                    rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H6;
-                      rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6;
-                        assumption.
-  cut (IZR (up (/ eps - 1)) = IZR (Z.of_nat x));
-    [ intro | rewrite H1; trivial ].
-  elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
-    rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
-  unfold Rgt in H1; apply Rlt_le; assumption.
-  unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
-  apply (le_O_IZR (up (/ eps - 1)));
-    apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
-  generalize (Rnot_gt_le eps 1 b); clear b; unfold Rle; intro; elim H0;
-    clear H0; intro.
-  left; unfold Rgt in H;
-    generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
-      rewrite
-        (Rinv_l eps
-          (not_eq_sym (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
-        ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1);
-          intro; fold (/ eps - 1 > 0); apply Rgt_minus;
-            unfold Rgt; assumption.
-  right; rewrite H0; rewrite Rinv_1; symmetry; apply Rminus_diag_eq; auto.
-  elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
-    assumption.
+    intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+    cut (/ eps - 1 < 0).
+    intro H2; generalize (Rlt_le_trans (/ eps - 1) 0 (INR n) H2 (pos_INR n));
+      clear H2; intro; unfold Rminus in H2;
+        generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2);
+          replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ].
+    rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2;
+      generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H);
+        intro; unfold Rgt in H3;
+          generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2);
+            intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4;
+              rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+                in H4; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H4;
+                  rewrite (Rmult_comm (/ INR (S n))) in H4;
+                    rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4;
+                      rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H4;
+                        rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4;
+                          assumption.
+    apply Rlt_minus; unfold Rgt in Hgt; rewrite <- Rinv_1;
+      apply (Rinv_lt_contravar 1 eps); auto;
+        rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H;
+          assumption.
+    unfold Rgt in H1; apply Rlt_le; assumption.
+    unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+  - cut (0 <= up (/ eps - 1))%Z.
+    intro; elim (IZN (up (/ eps - 1)) H0); intros; split with x; intros;
+      rewrite (simpl_fact n); unfold R_dist;
+        rewrite (Rminus_0_r (Rabs (/ INR (S n))));
+          rewrite (Rabs_Rabsolu (/ INR (S n))); cut (/ INR (S n) > 0).
+    intro; rewrite (Rabs_pos_eq (/ INR (S n))).
+    cut (/ eps - 1 < INR x).
+    intro ;
+      generalize
+        (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4
+          (le_INR x n H2));
+        clear H4; intro; unfold Rminus in H4;
+          generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4);
+            replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ].
+    rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4;
+      generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H);
+        intro; unfold Rgt in H5;
+          generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4);
+            intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6;
+              rewrite (Rinv_r eps (Rlt_dichotomy_converse eps 0 (or_intror (eps < 0) H)))
+                in H6; rewrite (let (H1, H2) := Rmult_ne (/ INR (S n)) in H1) in H6;
+                  rewrite (Rmult_comm (/ INR (S n))) in H6;
+                    rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6;
+                      rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (not_eq_sym (O_S n)))) in H6;
+                        rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6;
+                          assumption.
+    cut (IZR (up (/ eps - 1)) = IZR (Z.of_nat x));
+      [ intro | rewrite H1; trivial ].
+    elim (archimed (/ eps - 1)); intros; clear H6; unfold Rgt in H5;
+      rewrite H4 in H5; rewrite INR_IZR_INZ; assumption.
+    unfold Rgt in H1; apply Rlt_le; assumption.
+    unfold Rgt; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn.
+    apply (le_O_IZR (up (/ eps - 1)));
+      apply (Rle_trans 0 (/ eps - 1) (IZR (up (/ eps - 1)))).
+    generalize (Rnot_gt_le eps 1 Hnotgt); clear Hnotgt; unfold Rle; intro; elim H0;
+      clear H0; intro.
+    left; unfold Rgt in H;
+      generalize (Rmult_lt_compat_l (/ eps) eps 1 (Rinv_0_lt_compat eps H) H0);
+        rewrite
+          (Rinv_l eps
+            (not_eq_sym (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H))))
+          ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1);
+            intro; fold (/ eps - 1 > 0); apply Rgt_minus;
+              unfold Rgt; assumption.
+    right; rewrite H0; rewrite Rinv_1; symmetry; apply Rminus_diag_eq; auto.
+    elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le;
+      assumption.
 Qed.
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index 4e3d41e3..7845e6c4 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -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        *)
@@ -59,7 +59,7 @@ Proof.
           sum_f_R0
           (fun k:nat => Rabs (/ INR (fact (2 * k + 1)) * r ^ (2 * k))) n)
         l }.
-  intro X; elim X; intros.
+  intros (x,p).
   exists x.
   split.
   apply p.
@@ -176,14 +176,14 @@ Proof.
   intro; rewrite H9 in H8; rewrite H10 in H8.
   apply H8.
   unfold SFL, sin.
-  case (cv h); intros.
-  case (exist_sin (Rsqr h)); intros.
+  case (cv h) as (x,HUn).
+  case (exist_sin (Rsqr h)) as (x0,Hsin).
   unfold Rdiv; rewrite (Rinv_r_simpl_m h x0 H6).
   eapply UL_sequence.
-  apply u.
-  unfold sin_in in s; unfold sin_n, infinite_sum in s;
+  apply HUn.
+  unfold sin_in in Hsin; unfold sin_n, infinite_sum in Hsin;
     unfold SP, fn, Un_cv; intros.
-  elim (s _ H10); intros N0 H11.
+  elim (Hsin _ H10); intros N0 H11.
   exists N0; intros.
   unfold R_dist; unfold R_dist in H11.
   replace
@@ -194,9 +194,9 @@ Proof.
   apply sum_eq; intros; apply Rmult_eq_compat_l; unfold Rsqr;
     rewrite pow_sqr; reflexivity.
   unfold SFL, sin.
-  case (cv 0); intros.
+  case (cv 0) as (?,HUn).
   eapply UL_sequence.
-  apply u.
+  apply HUn.
   unfold SP, fn; unfold Un_cv; intros; exists 1%nat; intros.
   unfold R_dist;
     replace
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index fb2eacee..9a6fb945 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -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        *)
@@ -10,6 +10,7 @@ Require Import Rbase.
 Require Import Rfunctions.
 Require Import Rseries.
 Require Import Max.
+Require Import Omega.
 Local Open Scope R_scope.
 
 (*****************************************************************)
@@ -27,7 +28,7 @@ Lemma growing_cv :
   forall Un:nat -> R, Un_growing Un -> has_ub Un -> { l:R | Un_cv Un l }.
 Proof.
   intros Un Hug Heub.
-  exists (projT1 (completeness (EUn Un) Heub (EUn_noempty Un))).
+  exists (proj1_sig (completeness (EUn Un) Heub (EUn_noempty Un))).
   destruct (completeness _ Heub (EUn_noempty Un)) as (l, H).
   now apply Un_cv_crit_lub.
 Qed.
@@ -52,8 +53,7 @@ Proof.
   apply growing_cv.
   apply decreasing_growing; assumption.
   exact H0.
-  intro X.
-  elim X; intros.
+  intros (x,p).
   exists (- x).
   unfold Un_cv in p.
   unfold R_dist in p.
@@ -150,7 +150,7 @@ Definition sequence_lb (Un:nat -> R) (pr:has_lb Un)
 (* Compatibility *)
 Notation sequence_majorant := sequence_ub (only parsing).
 Notation sequence_minorant := sequence_lb (only parsing).
-
+Unset Standard Proposition Elimination Names.
 Lemma Wn_decreasing :
   forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr).
 Proof.
@@ -158,21 +158,15 @@ Proof.
   unfold Un_decreasing.
   intro.
   unfold sequence_ub.
-  assert (H := ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
-  assert (H0 := ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
-  elim H; intros.
-  elim H0; intros.
+  pose proof (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) as (x,(H1,H2)).
+  pose proof (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) as (x0,(H3,H4)).
   cut (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr) = x);
     [ intro Maj1; rewrite Maj1 | idtac ].
   cut (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr) = x0);
     [ intro Maj2; rewrite Maj2 | idtac ].
-  unfold is_lub in p.
-  unfold is_lub in p0.
-  elim p; intros.
   apply H2.
-  elim p0; intros.
   unfold is_upper_bound.
-  intros.
+  intros x1 H5.
   unfold is_upper_bound in H3.
   apply H3.
   elim H5; intros.
@@ -183,12 +177,10 @@ Proof.
   cut
     (is_lub (EUn (fun k:nat => Un (n + k)%nat))
       (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr))).
-  intro.
-  unfold is_lub in p0; unfold is_lub in H1.
-  elim p0; intros; elim H1; intros.
-  assert (H6 := H5 x0 H2).
+  intros (H5,H6).
+  assert (H7 := H6 x0 H3).
   assert
-    (H7 := H3 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H4).
+    (H8 := H4 (lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)) H5).
   apply Rle_antisym; assumption.
   unfold lub.
   case (ub_to_lub (fun k:nat => Un (n + k)%nat) (maj_ss Un n pr)).
@@ -196,13 +188,11 @@ Proof.
   cut
     (is_lub (EUn (fun k:nat => Un (S n + k)%nat))
       (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr))).
-  intro.
-  unfold is_lub in p; unfold is_lub in H1.
-  elim p; intros; elim H1; intros.
-  assert (H6 := H5 x H2).
+  intros (H5,H6).
+  assert (H7 := H6 x H1).
   assert
-    (H7 :=
-      H3 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H4).
+    (H8 :=
+      H2 (lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)) H5).
   apply Rle_antisym; assumption.
   unfold lub.
   case (ub_to_lub (fun k:nat => Un (S n + k)%nat) (maj_ss Un (S n) pr)).
@@ -460,8 +450,7 @@ Lemma cond_eq :
   forall x y:R, (forall eps:R, 0 < eps -> Rabs (x - y) < eps) -> x = y.
 Proof.
   intros.
-  case (total_order_T x y); intro.
-  elim s; intro.
+  destruct (total_order_T x y) as [[Hlt|Heq]|Hgt].
   cut (0 < y - x).
   intro.
   assert (H1 := H (y - x) H0).
@@ -470,7 +459,7 @@ Proof.
   rewrite Rabs_right in H1.
   elim (Rlt_irrefl _ H1).
   left; assumption.
-  apply Rplus_lt_reg_r with x.
+  apply Rplus_lt_reg_l with x.
   rewrite Rplus_0_r; replace (x + (y - x)) with y; [ assumption | ring ].
   assumption.
   cut (0 < x - y).
@@ -479,7 +468,7 @@ Proof.
   rewrite Rabs_right in H1.
   elim (Rlt_irrefl _ H1).
   left; assumption.
-  apply Rplus_lt_reg_r with y.
+  apply Rplus_lt_reg_l with y.
   rewrite Rplus_0_r; replace (y + (x - y)) with x; [ assumption | ring ].
 Qed.
 
@@ -860,7 +849,7 @@ Proof.
   split.
   pattern k at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l.
   unfold Rdiv; apply Rmult_lt_0_compat.
-  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
+  apply Rplus_lt_reg_l with k; rewrite Rplus_0_r; replace (k + (1 - k)) with 1;
     [ elim H; intros; assumption | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
   apply Rmult_lt_reg_l with 2.
@@ -881,12 +870,12 @@ Proof.
     apply Rle_lt_trans with (Rabs (Rabs (An (S n) / An n) - k) + Rabs k).
   apply Rabs_triang.
   rewrite (Rabs_right k).
-  apply Rplus_lt_reg_r with (- k); rewrite <- (Rplus_comm k);
+  apply Rplus_lt_reg_l with (- k); rewrite <- (Rplus_comm k);
     repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
       repeat rewrite Rplus_0_l; apply H4.
   apply Rle_ge; elim H; intros; assumption.
   unfold Rdiv; apply Rmult_lt_0_compat.
-  apply Rplus_lt_reg_r with k; rewrite Rplus_0_r; elim H; intros;
+  apply Rplus_lt_reg_l with k; rewrite Rplus_0_r; elim H; intros;
     replace (k + (1 - k)) with 1; [ assumption | ring ].
   apply Rinv_0_lt_compat; prove_sup0.
 Qed.
@@ -896,8 +885,7 @@ Lemma growing_ineq :
   forall (Un:nat -> R) (l:R),
     Un_growing Un -> Un_cv Un l -> forall n:nat, Un n <= l.
 Proof.
-  intros; case (total_order_T (Un n) l); intro.
-  elim s; intro.
+  intros; destruct (total_order_T (Un n) l) as [[Hlt|Heq]|Hgt].
   left; assumption.
   right; assumption.
   cut (0 < Un n - l).
@@ -916,7 +904,7 @@ Proof.
   apply tech9.
   assumption.
   unfold N; apply le_max_l.
-  apply Rplus_lt_reg_r with l.
+  apply Rplus_lt_reg_l with l.
   rewrite Rplus_0_r.
   replace (l + (Un n - l)) with (Un n); [ assumption | ring ].
 Qed.
@@ -1102,11 +1090,11 @@ Proof.
   apply (cv_infty_cv_R0 (fun n:nat => INR (S n))).
   intro; apply not_O_INR; discriminate.
   assumption.
-  unfold cv_infty; intro; case (total_order_T M0 0); intro.
-  elim s; intro.
+  unfold cv_infty; intro;
+    destruct (total_order_T M0 0) as [[Hlt|Heq]|Hgt].
   exists 0%nat; intros.
   apply Rlt_trans with 0; [ assumption | apply lt_INR_0; apply lt_O_Sn ].
-  exists 0%nat; intros; rewrite b; apply lt_INR_0; apply lt_O_Sn.
+  exists 0%nat; intros; rewrite Heq; apply lt_INR_0; apply lt_O_Sn.
   set (M0_z := up M0).
   assert (H10 := archimed M0).
   cut (0 <= M0_z)%Z.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index 5f2173c7..25fe4848 100644
--- a/theories/Reals/SeqSeries.v
+++ b/theories/Reals/SeqSeries.v
@@ -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        *)
@@ -222,39 +222,37 @@ Proof.
   intro; apply Rle_lt_trans with (R_dist (sum_f_R0 Bn n) (sum_f_R0 Bn m)).
   assumption.
   apply H2; assumption.
-  assert (H5 := lt_eq_lt_dec n m).
-  elim H5; intro.
-  elim a; intro.
-  rewrite (tech2 An n m); [ idtac | assumption ].
-  rewrite (tech2 Bn n m); [ idtac | assumption ].
-  unfold R_dist; unfold Rminus; do 2 rewrite Ropp_plus_distr;
-    do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
-      do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
-  apply sum_Rle; intros.
-  elim (H (S n + n0)%nat); intros.
-  apply H8.
-  apply Rle_ge; apply cond_pos_sum; intro.
-  elim (H (S n + n0)%nat); intros.
-  apply Rle_trans with (An (S n + n0)%nat); assumption.
-  apply Rle_ge; apply cond_pos_sum; intro.
-  elim (H (S n + n0)%nat); intros; assumption.
-  rewrite b; unfold R_dist; unfold Rminus;
+  destruct (lt_eq_lt_dec n m) as [[| -> ]|].
+  - rewrite (tech2 An n m); [ idtac | assumption ].
+    rewrite (tech2 Bn n m); [ idtac | assumption ].
+    unfold R_dist; unfold Rminus; do 2 rewrite Ropp_plus_distr;
+      do 2 rewrite <- Rplus_assoc; do 2 rewrite Rplus_opp_r;
+        do 2 rewrite Rplus_0_l; do 2 rewrite Rabs_Ropp; repeat rewrite Rabs_right.
+    apply sum_Rle; intros.
+    elim (H (S n + n0)%nat); intros H7 H8.
+    apply H8.
+    apply Rle_ge; apply cond_pos_sum; intro.
+    elim (H (S n + n0)%nat); intros.
+    apply Rle_trans with (An (S n + n0)%nat); assumption.
+    apply Rle_ge; apply cond_pos_sum; intro.
+    elim (H (S n + n0)%nat); intros; assumption.
+  - unfold R_dist; unfold Rminus;
     do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right;
       reflexivity.
-  rewrite (tech2 An m n); [ idtac | assumption ].
-  rewrite (tech2 Bn m n); [ idtac | assumption ].
-  unfold R_dist; unfold Rminus; do 2 rewrite Rplus_assoc;
-    rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
-      do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l;
-        do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
-  apply sum_Rle; intros.
-  elim (H (S m + n0)%nat); intros; apply H8.
-  apply Rle_ge; apply cond_pos_sum; intro.
-  elim (H (S m + n0)%nat); intros.
-  apply Rle_trans with (An (S m + n0)%nat); assumption.
-  apply Rle_ge.
-  apply cond_pos_sum; intro.
-  elim (H (S m + n0)%nat); intros; assumption.
+  - rewrite (tech2 An m n); [ idtac | assumption ].
+    rewrite (tech2 Bn m n); [ idtac | assumption ].
+    unfold R_dist; unfold Rminus; do 2 rewrite Rplus_assoc;
+      rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m));
+        do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l;
+          do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right.
+    apply sum_Rle; intros.
+    elim (H (S m + n0)%nat); intros H7 H8; apply H8.
+    apply Rle_ge; apply cond_pos_sum; intro.
+    elim (H (S m + n0)%nat); intros.
+    apply Rle_trans with (An (S m + n0)%nat); assumption.
+    apply Rle_ge.
+    apply cond_pos_sum; intro.
+    elim (H (S m + n0)%nat); intros; assumption.
 Qed.
 
 (** Cesaro's theorem *)
@@ -361,7 +359,7 @@ Proof with trivial.
   replace (sum_f_R0 (fun k:nat => An k * (Bn k - l)) n) with
   (sum_f_R0 (fun k:nat => An k * Bn k) n +
     sum_f_R0 (fun k:nat => An k * - l) n)...
-  rewrite <- (scal_sum An n (- l)); field...
+  rewrite <- (scal_sum An n (- l)); field... 
   rewrite <- plus_sum; apply sum_eq; intros; ring...
 Qed.
 
@@ -375,11 +373,11 @@ Proof with trivial.
   assert (H1 : forall n:nat, 0 < sum_f_R0 An n)...
   intro; apply tech1...
   assert (H2 : cv_infty (fun n:nat => sum_f_R0 An n))...
-  unfold cv_infty; intro; case (Rle_dec M 0); intro...
+  unfold cv_infty; intro; destruct (Rle_dec M 0) as [Hle|Hnle]...
   exists 0%nat; intros; apply Rle_lt_trans with 0...
   assert (H2 : 0 < M)...
   auto with real...
-  clear n; set (m := up M); elim (archimed M); intros;
+  clear Hnle; set (m := up M); elim (archimed M); intros;
     assert (H5 : (0 <= m)%Z)...
   apply le_IZR; unfold m; simpl; left; apply Rlt_trans with M...
   elim (IZN _ H5); intros; exists x; intros; unfold An; rewrite sum_cte;
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index 3557e2e9..64f4f1c9 100644
--- a/theories/Reals/SplitAbsolu.v
+++ b/theories/Reals/SplitAbsolu.v
@@ -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        *)
@@ -11,7 +11,7 @@ Require Import Rbasic_fun.
 Ltac split_case_Rabs :=
   match goal with
     |  |- context [(Rcase_abs ?X1)] =>
-      case (Rcase_abs X1); try split_case_Rabs
+      destruct (Rcase_abs X1) as [?Hlt|?Hge]; try split_case_Rabs
   end.
 
 
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 7380f8ad..fec28518 100644
--- a/theories/Reals/SplitRmult.v
+++ b/theories/Reals/SplitRmult.v
@@ -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/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index a74aeef2..dd8738e1 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -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        *)
@@ -18,8 +18,7 @@ Lemma sqrt_var_maj :
 Proof.
   intros; cut (0 <= 1 + h).
   intro; apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)).
-  case (total_order_T h 0); intro.
-  elim s; intro.
+  destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt].
   repeat rewrite Rabs_left.
   unfold Rminus; do 2 rewrite <- (Rplus_comm (-1)).
   do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
@@ -32,7 +31,7 @@ Proof.
   apply H0.
   pattern 1 at 2; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
     assumption.
-  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+  apply Rplus_lt_reg_l with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
     unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
       rewrite Rplus_0_r.
   pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1.
@@ -43,7 +42,7 @@ Proof.
     assumption.
   apply H0.
   left; apply Rlt_0_1.
-  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
+  apply Rplus_lt_reg_l with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
     unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
       rewrite Rplus_0_r.
   pattern 1 at 2; rewrite <- sqrt_1; apply sqrt_lt_1.
@@ -51,7 +50,7 @@ Proof.
   left; apply Rlt_0_1.
   pattern 1 at 2; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
     assumption.
-  rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
+  rewrite Heq; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
     reflexivity.
   repeat rewrite Rabs_right.
   unfold Rminus; do 2 rewrite <- (Rplus_comm (-1));
@@ -75,7 +74,7 @@ Proof.
     assumption.
   left; apply Rlt_0_1.
   apply H0.
-  apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
+  apply Rle_ge; left; apply Rplus_lt_reg_l with 1.
   rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus;
     rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
   pattern 1 at 1; rewrite <- sqrt_1; apply sqrt_lt_1.
@@ -86,16 +85,15 @@ Proof.
   rewrite sqrt_Rsqr.
   replace (1 + h - 1) with h; [ right; reflexivity | ring ].
   apply H0.
-  case (total_order_T h 0); intro.
-  elim s; intro.
-  rewrite (Rabs_left h a) in H.
+  destruct (total_order_T h 0) as [[Hlt|Heq]|Hgt].
+  rewrite (Rabs_left h Hlt) in H.
   apply Rplus_le_reg_l with (- h).
   rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H.
-  left; rewrite b; rewrite Rplus_0_r; apply Rlt_0_1.
+  left; rewrite Heq; rewrite Rplus_0_r; apply Rlt_0_1.
   left; apply Rplus_lt_0_compat.
   apply Rlt_0_1.
-  apply r.
+  apply Hgt.
 Qed.
 
 (** sqrt is continuous in 1 *)
@@ -203,8 +201,8 @@ Proof.
   left; apply Rlt_0_1.
   left; apply H.
   elim H6; intros.
-  case (Rcase_abs (x0 - x)); intro.
-  rewrite (Rabs_left (x0 - x) r) in H8.
+  destruct (Rcase_abs (x0 - x)) as [Hlt|Hgt].
+  rewrite (Rabs_left (x0 - x) Hlt) in H8.
   rewrite Rplus_comm.
   apply Rplus_le_reg_l with (- ((x0 - x) / x)).
   rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
@@ -220,7 +218,7 @@ Proof.
   apply Rplus_le_le_0_compat.
   left; apply Rlt_0_1.
   unfold Rdiv; apply Rmult_le_pos.
-  apply Rge_le; exact r.
+  apply Rge_le; exact Hgt.
   left; apply Rinv_0_lt_compat; apply H.
   unfold Rdiv; apply Rmult_lt_0_compat.
   apply H1.
@@ -273,8 +271,8 @@ Proof.
   apply Rplus_lt_le_0_compat.
   apply sqrt_lt_R0; apply H.
   apply sqrt_positivity; apply H10.
-  case (Rcase_abs h); intro.
-  rewrite (Rabs_left h r) in H9.
+  destruct (Rcase_abs h) as [Hlt|Hgt].
+  rewrite (Rabs_left h Hlt) in H9.
   apply Rplus_le_reg_l with (- h).
   rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
     rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
@@ -282,7 +280,7 @@ Proof.
   unfold alpha1; apply Rmin_r.
   apply Rplus_le_le_0_compat.
   left; assumption.
-  apply Rge_le; apply r.
+  apply Rge_le; apply Hgt.
   unfold alpha1; unfold Rmin; case (Rle_dec alpha x); intro.
   apply H5.
   apply H.
@@ -341,17 +339,16 @@ Proof.
   rewrite <- H1; rewrite sqrt_0; unfold Rminus; rewrite Ropp_0;
     rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
       rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
-  case (Rcase_abs x0); intro.
-  unfold sqrt; case (Rcase_abs x0); intro.
+  destruct (Rcase_abs x0) as [Hlt|Hgt]_eqn:Heqs.
+  unfold sqrt. rewrite Heqs.
   rewrite Rabs_R0; apply H2.
-  assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
   rewrite Rabs_right.
   apply Rsqr_incrst_0.
   rewrite Rsqr_sqrt.
-  rewrite (Rabs_right x0 r) in H5; apply H5.
-  apply Rge_le; exact r.
-  apply sqrt_positivity; apply Rge_le; exact r.
+  rewrite (Rabs_right x0 Hgt) in H5; apply H5.
+  apply Rge_le; exact Hgt.
+  apply sqrt_positivity; apply Rge_le; exact Hgt.
   left; exact H2.
-  apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact r.
+  apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact Hgt.
   elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H1 H)).
 Qed.
diff --git a/theories/Reals/vo.itarget b/theories/Reals/vo.itarget
index 36dd0f56..0c8f0b97 100644
--- a/theories/Reals/vo.itarget
+++ b/theories/Reals/vo.itarget
@@ -8,7 +8,6 @@ Cos_rel.vo
 DiscrR.vo
 Exp_prop.vo
 Integration.vo
-LegacyRfield.vo
 Machin.vo
 MVT.vo
 NewtonInt.vo
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index 4efc528e..95d9cfa9 100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -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        *)
@@ -17,6 +17,7 @@ Require Import Relation_Operators.
 
 Section Properties.
 
+  Arguments clos_refl [A] R x _.
   Arguments clos_refl_trans [A] R x _.
   Arguments clos_refl_trans_1n [A] R x _.
   Arguments clos_refl_trans_n1 [A] R x _.
@@ -34,7 +35,8 @@ Section Properties.
 
   Section Clos_Refl_Trans.
 
-    Local Notation "R *" := (clos_refl_trans R) (at level 8, left associativity).
+    Local Notation "R *" := (clos_refl_trans R)
+      (at level 8, left associativity, format "R *").
 
     (** Correctness of the reflexive-transitive closure operator *)
 
@@ -71,6 +73,26 @@ Section Properties.
       apply rst_trans with y; auto with sets.
     Qed.
 
+    (** Reflexive closure is included in the
+        reflexive-transitive closure *)
+
+    Lemma clos_r_clos_rt :
+      inclusion (clos_refl R) (clos_refl_trans R).
+    Proof.
+      induction 1 as [? ?| ].
+      constructor; auto.
+      constructor 2.
+    Qed.
+
+    Lemma clos_rt_t : forall x y z,
+      clos_refl_trans R x y -> clos_trans R y z ->
+      clos_trans R x z.
+    Proof.
+      induction 1 as [b d H1|b|a b d H1 H2 IH1 IH2]; auto.
+      intro H. apply t_trans with (y:=d); auto.
+      constructor. auto.
+    Qed.
+
     (** Correctness of the reflexive-symmetric-transitive closure *)
 
     Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R).
@@ -382,6 +404,13 @@ Section Properties.
 
   End Equivalences.
 
+  Lemma clos_trans_transp_permute : forall x y,
+    transp _ (clos_trans R) x y <-> clos_trans (transp _ R) x y.
+  Proof.
+    split; induction 1;
+    (apply t_step; assumption) || eapply t_trans; eassumption.
+  Qed.
+
 End Properties.
 
 (* begin hide *)
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index 390d38b5..a187f955 100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -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/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index 701bc073..4e52017e 100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -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        *)
@@ -46,6 +46,20 @@ Section Transitive_Closure.
 
 End Transitive_Closure.
 
+(** ** Reflexive closure *)
+
+Section Reflexive_Closure.
+  Variable A : Type.
+  Variable R : relation A.
+
+  (** Definition by direct transitive closure *)
+
+  Inductive clos_refl (x: A) : A -> Prop :=
+    | r_step (y:A) : R x y -> clos_refl x y
+    | r_refl : clos_refl x x.
+
+End Reflexive_Closure.
+
 (** ** Reflexive-transitive closure *)
 
 Section Reflexive_Transitive_Closure.
@@ -204,7 +218,7 @@ Section Lexicographic_Exponentiation.
     | d_nil : Desc Nil
     | d_one (x:A) : Desc (x :: Nil)
     | d_conc (x y:A) (l:List) :
-        leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).
+        clos_refl A leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil).
 
   Definition Pow : Set := sig Desc.
 
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 6e634db3..ce849a16 100644
--- a/theories/Relations/Relations.v
+++ b/theories/Relations/Relations.v
@@ -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/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index ccecb9a4..75cffa7f 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -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        *)
@@ -16,14 +16,17 @@ Definition Setoid_Theory := @Equivalence.
 Definition Build_Setoid_Theory := @Build_Equivalence.
 
 Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x.
+Proof.
   unfold Setoid_Theory in s. intros ; reflexivity.
 Defined.
 
 Definition Seq_sym A Aeq (s : Setoid_Theory A Aeq) : forall x y:A, Aeq x y -> Aeq y x.
+Proof.
   unfold Setoid_Theory in s. intros ; symmetry ; assumption.
 Defined.
 
 Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z.
+Proof.
   unfold Setoid_Theory in s. intros ; transitivity y ; assumption.
 Defined.
 
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index 44af113e..aa2c144b 100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -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        *)
@@ -26,7 +26,7 @@
 
 Require Export Ensembles.
 Require Export Constructive_sets.
-Require Export Classical_Type.
+Require Export Classical.
 
 Section Ensembles_classical.
   Variable U : Type.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index 49f0ead1..193bec78 100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -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/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index bfd0cf5a..f2fac097 100644
--- a/theories/Sets/Cpo.v
+++ b/theories/Sets/Cpo.v
@@ -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        *)
@@ -32,9 +32,9 @@ Section Bounds.
   Variable U : Type.
   Variable D : PO U.
 
-  Let C := Carrier_of U D.
+  Let C := @Carrier_of U D.
 
-  Let R := Rel_of U D.
+  Let R := @Rel_of U D.
 
   Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop :=
     Upper_Bound_definition :
@@ -103,6 +103,6 @@ Section Specific_orders.
 
   Record Chain : Type := Definition_of_chain
     {PO_of_chain : PO U;
-    Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}.
+    Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}.
 
 End Specific_orders.
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index 4730d029..c0cddbe1 100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -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/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index 34775862..22cb3dae 100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -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/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index c0305e91..b1c12c7f 100644
--- a/theories/Sets/Finite_sets_facts.v
+++ b/theories/Sets/Finite_sets_facts.v
@@ -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        *)
@@ -26,7 +26,7 @@
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
-Require Export Classical_Type.
+Require Export Classical.
 Require Export Classical_sets.
 Require Export Powerset.
 Require Export Powerset_facts.
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index b5ca19a8..6cf4d250 100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -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        *)
@@ -26,7 +26,7 @@
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
-Require Export Classical_Type.
+Require Export Classical.
 Require Export Classical_sets.
 Require Export Powerset.
 Require Export Powerset_facts.
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
index 3b7b129e..5860f960 100644
--- a/theories/Sets/Infinite_sets.v
+++ b/theories/Sets/Infinite_sets.v
@@ -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        *)
@@ -26,7 +26,7 @@
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
-Require Export Classical_Type.
+Require Export Classical.
 Require Export Classical_sets.
 Require Export Powerset.
 Require Export Powerset_facts.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 1e6430e4..944e0dd1 100644
--- a/theories/Sets/Integers.v
+++ b/theories/Sets/Integers.v
@@ -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        *)
@@ -26,7 +26,7 @@
 
 Require Export Finite_sets.
 Require Export Constructive_sets.
-Require Export Classical_Type.
+Require Export Classical.
 Require Export Classical_sets.
 Require Export Powerset.
 Require Export Powerset_facts.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index f6ebe42f..46dbe994 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -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/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index 909cd69b..35d5f91a 100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -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        *)
@@ -61,7 +61,7 @@ Section Partial_order_facts.
 
   Lemma Strict_Rel_Transitive_with_Rel :
     forall x y z:U,
-      Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z.
+      Strict_Rel_of U D x y -> @Rel_of U D y z -> Strict_Rel_of U D x z.
   Proof.
     unfold Strict_Rel_of at 1.
     red.
@@ -77,7 +77,7 @@ Section Partial_order_facts.
 
   Lemma Strict_Rel_Transitive_with_Rel_left :
     forall x y z:U,
-      Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
+      @Rel_of U D x y -> Strict_Rel_of U D y z -> Strict_Rel_of U D x z.
   Proof.
     unfold Strict_Rel_of at 1.
     red.
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
index 93d96ef3..c9c1e5b7 100644
--- a/theories/Sets/Permut.v
+++ b/theories/Sets/Permut.v
@@ -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/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index b761c972..587d48ab 100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -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/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 1071f2ce..40fd5e67 100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -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        *)
@@ -32,7 +32,7 @@ Require Export Partial_Order.
 Require Export Cpo.
 Require Export Powerset.
 Require Export Powerset_facts.
-Require Export Classical_Type.
+Require Export Classical.
 Require Export Classical_sets.
 
 Section Sets_as_an_algebra.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 4cbb1d7c..e9347ce3 100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -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/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index 8effeb95..c9148e00 100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -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/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
index ce6df104..f650a50c 100644
--- a/theories/Sets/Relations_1_facts.v
+++ b/theories/Sets/Relations_1_facts.v
@@ -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/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index 7ff57572..ea48fd91 100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -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/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
index 460255ab..e0543501 100644
--- a/theories/Sets/Relations_2_facts.v
+++ b/theories/Sets/Relations_2_facts.v
@@ -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/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index 2f6ef730..de6770ee 100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -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/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
index 8111afd9..0180c7d4 100644
--- a/theories/Sets/Relations_3_facts.v
+++ b/theories/Sets/Relations_3_facts.v
@@ -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/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index ce2f4004..86ba903f 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -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/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index 1cff280a..6313dbf6 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -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        *)
@@ -152,23 +152,23 @@ Section defs.
     revert l2 H0. fix 1. intros.
     destruct l2 as [|a0 l0]. 
     apply merge_exist with (a :: l); simpl; auto with datatypes. 
-    elim (leA_dec a a0); intros.
+    induction (leA_dec a a0) as [Hle|Hle].
 
     (* 1 (leA a a0) *)
     apply Sorted_inv in H. destruct H.
-    destruct (merge l H (a0 :: l0) H0).
+    destruct (merge l H (a0 :: l0) H0) as [l1 H2 H3 H4].
     apply merge_exist with (a :: l1). clear merge merge0.
       auto using cons_sort, cons_leA with datatypes.
-    simpl. rewrite m. now rewrite munion_ass. 
+    simpl. rewrite H3. now rewrite munion_ass.
     intros. apply cons_leA. 
     apply (@HdRel_inv _ leA) with l; trivial with datatypes.
 
     (* 2 (leA a0 a) *)
     apply Sorted_inv in H0. destruct H0.
-    destruct (merge0 l0 H0). clear merge merge0.  
+    destruct (merge0 l0 H0) as [l1 H2 H3 H4]. clear merge merge0.  
     apply merge_exist with (a0 :: l1); 
       auto using cons_sort, cons_leA with datatypes.
-    simpl; rewrite m. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm.
+    simpl; rewrite H3. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm.
     repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity.
     intros. apply cons_leA. 
     apply (@HdRel_inv _ leA) with l0; trivial with datatypes.
diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v
index b08e1e1e..593b2e9b 100644
--- a/theories/Sorting/Mergesort.v
+++ b/theories/Sorting/Mergesort.v
@@ -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/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
index 6579fcdb..9bae43c2 100644
--- a/theories/Sorting/PermutEq.v
+++ b/theories/Sorting/PermutEq.v
@@ -1,19 +1,19 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation.
+Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation Omega.
 
 Set Implicit Arguments.
 
 (** This file is similar to [PermutSetoid], except that the equality used here
     is Coq usual one instead of a setoid equality. In particular, we can then
-    prove the equivalence between [List.Permutation] and
-    [Permutation.permutation].
+    prove the equivalence between [Permutation.Permutation] and
+    [PermutSetoid.permutation].
 *)
 
 Section Perm.
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
index 681e8824..64dda448 100644
--- a/theories/Sorting/PermutSetoid.v
+++ b/theories/Sorting/PermutSetoid.v
@@ -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        *)
@@ -19,7 +19,7 @@ Require Import Omega Relations Multiset SetoidList.
     The relation between the two relations are in lemma
     [permutation_Permutation].
 
-    File [PermutEq] concerns Leibniz equality : it shows in particular
+    File [Permutation] concerns Leibniz equality : it shows in particular
     that [List.Permutation] and [permutation] are equivalent in this context.
 *)
 
@@ -179,7 +179,7 @@ Proof.
   simpl; trivial using permut_refl.
   simpl.
   apply permut_add_cons_inside.
-  rewrite <- app_nil_end. trivial.
+  rewrite app_nil_r. trivial.
 Qed.
 
 (** * Some inversion results. *)
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index 803e1083..fcb4e787 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -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        *)
@@ -13,12 +13,10 @@
 (* Adapted in May 2006 by Jean-Marc Notin from initial contents by
    Laurent Théry (Huffmann contribution, October 2003) *)
 
-Require Import List Setoid.
-
+Require Import List Setoid Compare_dec Morphisms FinFun.
+Import ListNotations. (* For notations [] and [a;b;c] *)
 Set Implicit Arguments.
-
-Local Notation "[ ]" := nil.
-Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).
+(* Set Universe Polymorphism. *)
 
 Section Permutation.
 
@@ -28,7 +26,8 @@ Inductive Permutation : list A -> list A -> Prop :=
 | perm_nil: Permutation [] []
 | perm_skip x l l' : Permutation l l' -> Permutation (x::l) (x::l')
 | perm_swap x y l : Permutation (y::x::l) (x::y::l)
-| perm_trans l l' l'' : Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+| perm_trans l l' l'' :
+    Permutation l l' -> Permutation l' l'' -> Permutation l l''.
 
 Local Hint Constructors Permutation.
 
@@ -41,7 +40,8 @@ Proof.
   induction HF; discriminate || auto.
 Qed.
 
-Theorem Permutation_nil_cons : forall (l : list A) (x : A), ~ Permutation nil (x::l).
+Theorem Permutation_nil_cons : forall (l : list A) (x : A),
+ ~ Permutation nil (x::l).
 Proof.
   intros l x HF.
   apply Permutation_nil in HF; discriminate.
@@ -54,13 +54,15 @@ Proof.
   induction l; constructor. exact IHl.
 Qed.
 
-Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l.
+Theorem Permutation_sym : forall l l' : list A,
+ Permutation l l' -> Permutation l' l.
 Proof.
   intros l l' Hperm; induction Hperm; auto.
   apply perm_trans with (l':=l'); assumption.
 Qed.
 
-Theorem Permutation_trans : forall l l' l'' : list A, Permutation l l' -> Permutation l' l'' -> Permutation l l''.
+Theorem Permutation_trans : forall l l' l'' : list A,
+ Permutation l l' -> Permutation l' l'' -> Permutation l l''.
 Proof.
   exact perm_trans.
 Qed.
@@ -83,11 +85,10 @@ Instance Permutation_Equivalence A : Equivalence (@Permutation A) | 10 := {
   Equivalence_Symmetric := @Permutation_sym A ;
   Equivalence_Transitive := @Permutation_trans A }.
 
-Add Parametric Morphism A (a:A) : (cons a)
-  with signature @Permutation A ==> @Permutation A
-  as Permutation_cons.
+Instance Permutation_cons A :
+ Proper (Logic.eq ==> @Permutation A ==> @Permutation A) (@cons A) | 10.
 Proof.
-  auto using perm_skip.
+  repeat intro; subst; auto using perm_skip.
 Qed.
 
 Section Permutation_properties.
@@ -99,35 +100,48 @@ Implicit Types l m : list A.
 
 (** Compatibility with others operations on lists *)
 
-Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'.
+Theorem Permutation_in : forall (l l' : list A) (x : A),
+ Permutation l l' -> In x l -> In x l'.
 Proof.
   intros l l' x Hperm; induction Hperm; simpl; tauto.
 Qed.
 
-Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl).
+Global Instance Permutation_in' :
+ Proper (Logic.eq ==> @Permutation A ==> iff) (@In A) | 10.
+Proof.
+  repeat red; intros; subst; eauto using Permutation_in.
+Qed.
+
+Lemma Permutation_app_tail : forall (l l' tl : list A),
+ Permutation l l' -> Permutation (l++tl) (l'++tl).
 Proof.
   intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
   eapply Permutation_trans with (l':=l'++tl); trivial.
 Qed.
 
-Lemma Permutation_app_head : forall (l tl tl' : list A), Permutation tl tl' -> Permutation (l++tl) (l++tl').
+Lemma Permutation_app_head : forall (l tl tl' : list A),
+ Permutation tl tl' -> Permutation (l++tl) (l++tl').
 Proof.
-  intros l tl tl' Hperm; induction l; [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
+  intros l tl tl' Hperm; induction l;
+   [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
 Qed.
 
-Theorem Permutation_app : forall (l m l' m' : list A), Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
+Theorem Permutation_app : forall (l m l' m' : list A),
+ Permutation l l' -> Permutation m m' -> Permutation (l++m) (l'++m').
 Proof.
-  intros l m l' m' Hpermll' Hpermmm'; induction Hpermll' as [|x l l'|x y l|l l' l'']; repeat rewrite <- app_comm_cons; auto.
+  intros l m l' m' Hpermll' Hpermmm';
+   induction Hpermll' as [|x l l'|x y l|l l' l''];
+    repeat rewrite <- app_comm_cons; auto.
   apply Permutation_trans with (l' := (x :: y :: l ++ m));
-	[idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
+   [idtac | repeat rewrite app_comm_cons; apply Permutation_app_head]; trivial.
   apply Permutation_trans with (l' := (l' ++ m')); try assumption.
   apply Permutation_app_tail; assumption.
 Qed.
 
-Add Parametric Morphism : (@app A)
-  with signature @Permutation A ==> @Permutation A ==> @Permutation A
-  as Permutation_app'.
-  auto using Permutation_app.
+Global Instance Permutation_app' :
+ Proper (@Permutation A ==> @Permutation A ==> @Permutation A) (@app A) | 10.
+Proof.
+  repeat intro; now apply Permutation_app.
 Qed.
 
 Lemma Permutation_add_inside : forall a (l l' tl tl' : list A),
@@ -146,20 +160,27 @@ Theorem Permutation_app_comm : forall (l l' : list A),
   Permutation (l ++ l') (l' ++ l).
 Proof.
   induction l as [|x l]; simpl; intro l'.
-  rewrite app_nil_r; trivial. rewrite IHl. 
-  rewrite app_comm_cons, Permutation_cons_append. 
-  now rewrite <- app_assoc. 
+  rewrite app_nil_r; trivial. rewrite IHl.
+  rewrite app_comm_cons, Permutation_cons_append.
+  now rewrite <- app_assoc.
 Qed.
 Local Hint Resolve Permutation_app_comm.
 
 Theorem Permutation_cons_app : forall (l l1 l2:list A) a,
   Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2).
-Proof. intros l l1 l2 a H. rewrite H.
-  rewrite app_comm_cons, Permutation_cons_append. 
-  now rewrite <- app_assoc. 
+Proof.
+  intros l l1 l2 a H. rewrite H.
+  rewrite app_comm_cons, Permutation_cons_append.
+  now rewrite <- app_assoc.
 Qed.
 Local Hint Resolve Permutation_cons_app.
 
+Lemma Permutation_Add a l l' : Add a l l' -> Permutation (a::l) l'.
+Proof.
+ induction 1; simpl; trivial.
+ rewrite perm_swap. now apply perm_skip.
+Qed.
+
 Theorem Permutation_middle : forall (l1 l2:list A) a,
   Permutation (a :: l1 ++ l2) (l1 ++ a :: l2).
 Proof.
@@ -169,18 +190,27 @@ Local Hint Resolve Permutation_middle.
 
 Theorem Permutation_rev : forall (l : list A), Permutation l (rev l).
 Proof.
-  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1. 
+  induction l as [| x l]; simpl; trivial. now rewrite IHl at 1.
 Qed.
 
-Add Parametric Morphism : (@rev A)
-  with signature @Permutation A ==> @Permutation A as Permutation_rev'.
-Proof. intros. now do 2 rewrite <- Permutation_rev. Qed.
+Global Instance Permutation_rev' :
+ Proper (@Permutation A ==> @Permutation A) (@rev A) | 10.
+Proof.
+  repeat intro; now rewrite <- 2 Permutation_rev.
+Qed.
 
-Theorem Permutation_length : forall (l l' : list A), Permutation l l' -> length l = length l'.
+Theorem Permutation_length : forall (l l' : list A),
+ Permutation l l' -> length l = length l'.
 Proof.
   intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
 Qed.
 
+Global Instance Permutation_length' :
+ Proper (@Permutation A ==> Logic.eq) (@length A) | 10.
+Proof.
+  exact Permutation_length.
+Qed.
+
 Theorem Permutation_ind_bis :
  forall P : list A -> list A -> Prop,
    P [] [] ->
@@ -200,73 +230,62 @@ Proof.
   eauto.
 Qed.
 
-Ltac break_list l x l' H :=
-  destruct l as [|x l']; simpl in *;
-  injection H; intros; subst; clear H.
-
-Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A), ~ Permutation nil (l++x::l').
+Theorem Permutation_nil_app_cons : forall (l l' : list A) (x : A),
+ ~ Permutation nil (l++x::l').
 Proof.
-  intros l l' x HF. 
+  intros l l' x HF.
   apply Permutation_nil in HF. destruct l; discriminate.
 Qed.
 
-Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a,
+Ltac InvAdd := repeat (match goal with
+ | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst
+ end).
+
+Ltac finish_basic_perms H :=
+  try constructor; try rewrite perm_swap; try constructor; trivial;
+  (rewrite <- H; now apply Permutation_Add) ||
+  (rewrite H; symmetry; now apply Permutation_Add).
+
+Theorem Permutation_Add_inv a l1 l2 :
+  Permutation l1 l2 -> forall l1' l2', Add a l1' l1 -> Add a l2' l2 ->
+   Permutation l1' l2'.
+Proof.
+ revert l1 l2. refine (Permutation_ind_bis _ _ _ _ _).
+ - (* nil *)
+   inversion_clear 1.
+ - (* skip *)
+   intros x l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
+   constructor. now apply IH.
+ - (* swap *)
+   intros x y l1 l2 PE IH. intros. InvAdd; try finish_basic_perms PE.
+   rewrite perm_swap; do 2 constructor. now apply IH.
+ - (* trans *)
+   intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
+   assert (Ha : In a l). { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
+   destruct (Add_inv _ _ Ha) as (l',AD).
+   transitivity l'; auto.
+Qed.
+
+Theorem Permutation_app_inv (l1 l2 l3 l4:list A) a :
   Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4).
 Proof.
-  set (P l l' :=
-         forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)).
-  cut (forall l l', Permutation l l' -> P l l').
-  intros; apply (H _ _ H0 a); auto.
-  intros; apply (Permutation_ind_bis P); unfold P; clear P; try clear H l l'; simpl; auto.
-(* nil *)
-  intros; destruct l1; simpl in *; discriminate.
-  (* skip *)
-  intros x l l' H IH; intros.
-  break_list l1 b l1' H0; break_list l3 c l3' H1.
-  auto. 
-  now rewrite H. 
-  now rewrite <- H. 
-  now rewrite (IH a _ _ _ _ eq_refl eq_refl).
-  (* contradict *)
-  intros x y l l' Hp IH; intros.
-  break_list l1 b l1' H; break_list l3 c l3' H0.
-  auto.
-  break_list l3' b l3'' H.
-  auto. 
-  rewrite <- Permutation_middle in Hp. now rewrite Hp. 
-  break_list l1' c l1'' H1.
-  auto. 
-  rewrite <- Permutation_middle in Hp. now rewrite Hp. 
-  break_list l3' d l3'' H; break_list l1' e l1'' H1.
-  auto.
-  rewrite <- Permutation_middle in Hp. rewrite perm_swap. auto. 
-  rewrite perm_swap, Permutation_middle. auto.
-  now rewrite perm_swap, (IH a _ _ _ _ eq_refl eq_refl).
-  (*trans*)
-  intros. 
-  destruct (In_split a l') as (l'1,(l'2,H6)).
-  apply (Permutation_in a H).
-  subst l.
-  apply in_or_app; right; red; auto.
-  apply perm_trans with (l'1++l'2).
-  apply (H0 _ _ _ _ _ H3 H6).
-  apply (H2 _ _ _ _ _ H6 H4).
+ intros. eapply Permutation_Add_inv; eauto using Add_app.
 Qed.
 
-Theorem Permutation_cons_inv :
-   forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'.
+Theorem Permutation_cons_inv l l' a :
+ Permutation (a::l) (a::l') -> Permutation l l'.
 Proof.
-  intros; exact (Permutation_app_inv [] l [] l' a H).
+  intro. eapply Permutation_Add_inv; eauto using Add_head.
 Qed.
 
-Theorem Permutation_cons_app_inv :
-   forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
+Theorem Permutation_cons_app_inv l l1 l2 a :
+ Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2).
 Proof.
-  intros; exact (Permutation_app_inv [] l l1 l2 a H).
+  intro. eapply Permutation_Add_inv; eauto using Add_head, Add_app.
 Qed.
 
-Theorem Permutation_app_inv_l :
-    forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
+Theorem Permutation_app_inv_l : forall l l1 l2,
+ Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2.
 Proof.
   induction l; simpl; auto.
   intros.
@@ -274,20 +293,16 @@ Proof.
   apply Permutation_cons_inv with a; auto.
 Qed.
 
-Theorem Permutation_app_inv_r :
-   forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
+Theorem Permutation_app_inv_r l l1 l2 :
+ Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2.
 Proof.
-  induction l.
-  intros l1 l2; do 2 rewrite app_nil_r; auto.
-  intros.
-  apply IHl.
-  apply Permutation_app_inv with a; auto.
+ rewrite 2 (Permutation_app_comm _ l). apply Permutation_app_inv_l.
 Qed.
 
 Lemma Permutation_length_1_inv: forall a l, Permutation [a] l -> l = [a].
 Proof.
   intros a l H; remember [a] as m in H.
-  induction H; try (injection Heqm as -> ->; clear Heqm);
+  induction H; try (injection Heqm as -> ->);
     discriminate || auto.
   apply Permutation_nil in H as ->; trivial.
 Qed.
@@ -318,32 +333,47 @@ Proof.
   apply Permutation_length_2_inv in H as [H|H]; injection H as -> ->; auto.
 Qed.
 
-Lemma NoDup_Permutation : forall l l',
-  NoDup l -> NoDup l' -> (forall x:A, In x l <-> In x l') -> Permutation l l'.
+Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' ->
+  (forall x:A, In x l <-> In x l') -> Permutation l l'.
 Proof.
-  induction l.
-  destruct l'; simpl; intros.
-  apply perm_nil.
-  destruct (H1 a) as (_,H2); destruct H2; auto.
-  intros.
-  destruct (In_split a l') as (l'1,(l'2,H2)).
-  destruct (H1 a) as (H2,H3); simpl in *; auto.
-  subst l'.
-  apply Permutation_cons_app.
-  inversion_clear H.
-  apply IHl; auto.
-  apply NoDup_remove_1 with a; auto.
-  intro x; split; intros.
-  assert (In x (l'1++a::l'2)).
-   destruct (H1 x); simpl in *; auto.
-  apply in_or_app; destruct (in_app_or _ _ _ H4); auto.
-  destruct H5; auto.
-  subst x; destruct H2; auto.
-  assert (In x (l'1++a::l'2)).
-    apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto.
-  destruct (H1 x) as (_,H5); destruct H5; auto.
-  subst x.
-  destruct (NoDup_remove_2 _ _ _ H0 H).
+ intros N. revert l'. induction N as [|a l Hal Hl IH].
+ - destruct l'; simpl; auto.
+   intros Hl' H. exfalso. rewrite (H a); auto.
+ - intros l' Hl' H.
+   assert (Ha : In a l') by (apply H; simpl; auto).
+   destruct (Add_inv _ _ Ha) as (l'' & AD).
+   rewrite <- (Permutation_Add AD).
+   apply perm_skip.
+   apply IH; clear IH.
+   * now apply (NoDup_Add AD).
+   * split.
+     + apply incl_Add_inv with a l'; trivial. intro. apply H.
+     + intro Hx.
+       assert (Hx' : In x (a::l)).
+       { apply H. rewrite (Add_in AD). now right. }
+       destruct Hx'; simpl; trivial. subst.
+       rewrite (NoDup_Add AD) in Hl'. tauto.
+Qed.
+
+Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' ->
+  length l' <= length l -> incl l l' -> Permutation l l'.
+Proof.
+ intros. apply NoDup_Permutation; auto.
+ split; auto. apply NoDup_length_incl; trivial.
+Qed.
+
+Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'.
+Proof.
+ induction 1; auto.
+ * inversion_clear 1; constructor; eauto using Permutation_in.
+ * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *.
+   constructor. simpl; intuition. constructor; intuition.
+Qed.
+
+Global Instance Permutation_NoDup' :
+ Proper (@Permutation A ==> iff) (@NoDup A) | 10.
+Proof.
+  repeat red; eauto using Permutation_NoDup.
 Qed.
 
 End Permutation_properties.
@@ -353,20 +383,194 @@ Section Permutation_map.
 Variable A B : Type.
 Variable f : A -> B.
 
-Add Parametric Morphism : (map f)
-  with signature (@Permutation A) ==> (@Permutation B) as Permutation_map_aux.
+Lemma Permutation_map l l' :
+  Permutation l l' -> Permutation (map f l) (map f l').
 Proof.
-  induction 1; simpl; eauto using Permutation.
+ induction 1; simpl; eauto.
 Qed.
 
-Lemma Permutation_map :
-  forall l l', Permutation l l' -> Permutation (map f l) (map f l').
+Global Instance Permutation_map' :
+  Proper (@Permutation A ==> @Permutation B) (map f) | 10.
 Proof.
-  exact Permutation_map_aux_Proper.
+  exact Permutation_map.
 Qed.
 
 End Permutation_map.
 
+Lemma nat_bijection_Permutation n f :
+ bFun n f ->
+ Injective f ->
+ let l := seq 0 n in Permutation (map f l) l.
+Proof.
+ intros Hf BD.
+ apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup.
+ * now rewrite map_length.
+ * intros x. rewrite in_map_iff. intros (y & <- & Hy').
+   rewrite in_seq in *. simpl in *.
+   destruct Hy' as (_,Hy'). auto with arith.
+Qed.
+
+Section Permutation_alt.
+Variable A:Type.
+Implicit Type a : A.
+Implicit Type l : list A.
+
+(** Alternative characterization of permutation
+    via [nth_error] and [nth] *)
+
+Let adapt f n :=
+ let m := f (S n) in if le_lt_dec m (f 0) then m else pred m.
+
+Let adapt_injective f : Injective f -> Injective (adapt f).
+Proof.
+ unfold adapt. intros Hf x y EQ.
+ destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT'].
+ - now apply eq_add_S, Hf.
+ - apply Lt.le_lt_or_eq in LE.
+   destruct LE as [LT|EQ']; [|now apply Hf in EQ'].
+   unfold lt in LT. rewrite EQ in LT.
+   rewrite <- (Lt.S_pred _ _ LT') in LT.
+   elim (Lt.lt_not_le _ _ LT' LT).
+ - apply Lt.le_lt_or_eq in LE'.
+   destruct LE' as [LT'|EQ']; [|now apply Hf in EQ'].
+   unfold lt in LT'. rewrite <- EQ in LT'.
+   rewrite <- (Lt.S_pred _ _ LT) in LT'.
+   elim (Lt.lt_not_le _ _ LT LT').
+ - apply eq_add_S, Hf.
+   now rewrite (Lt.S_pred _ _ LT), (Lt.S_pred _ _ LT'), EQ.
+Qed.
+
+Let adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 ->
+ forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n).
+Proof.
+ unfold adapt. intros Hf E n.
+ destruct le_lt_dec as [LE|LT].
+ - apply Lt.le_lt_or_eq in LE.
+   destruct LE as [LT|EQ]; [|now apply Hf in EQ].
+   rewrite <- E in LT.
+   rewrite 2 nth_error_app1; auto.
+ - rewrite (Lt.S_pred _ _ LT) at 1.
+   rewrite <- E, (Lt.S_pred _ _ LT) in LT.
+   rewrite 2 nth_error_app2; auto with arith.
+   rewrite <- Minus.minus_Sn_m; auto with arith.
+Qed.
+
+Lemma Permutation_nth_error l l' :
+ Permutation l l' <->
+  (length l = length l' /\
+   exists f:nat->nat,
+    Injective f /\ forall n, nth_error l' n = nth_error l (f n)).
+Proof.
+ split.
+ { intros P.
+   split; [now apply Permutation_length|].
+   induction P.
+   - exists (fun n => n).
+     split; try red; auto.
+   - destruct IHP as (f & Hf & Hf').
+     exists (fun n => match n with O => O | S n => S (f n) end).
+     split; try red.
+     * intros [|y] [|z]; simpl; now auto.
+     * intros [|n]; simpl; auto.
+   - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end).
+     split; try red.
+     * intros [|[|z]] [|[|t]]; simpl; now auto.
+     * intros [|[|n]]; simpl; auto.
+   - destruct IHP1 as (f & Hf & Hf').
+     destruct IHP2 as (g & Hg & Hg').
+     exists (fun n => f (g n)).
+     split; try red.
+     * auto.
+     * intros n. rewrite <- Hf'; auto. }
+ { revert l. induction l'.
+   - intros [|l] (E & _); now auto.
+   - intros l (E & f & Hf & Hf').
+     simpl in E.
+     assert (Ha : nth_error l (f 0) = Some a)
+      by (symmetry; apply (Hf' 0)).
+     destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1).
+     rewrite L12. rewrite <- Permutation_middle. constructor.
+     apply IHl'; split; [|exists (adapt f); split].
+     * revert E. rewrite L12, !app_length. simpl.
+       rewrite <- plus_n_Sm. now injection 1.
+     * now apply adapt_injective.
+     * intro n. rewrite <- (adapt_ok a), <- L12; auto.
+       apply (Hf' (S n)). }
+Qed.
+
+Lemma Permutation_nth_error_bis l l' :
+ Permutation l l' <->
+  exists f:nat->nat,
+    Injective f /\
+    bFun (length l) f /\
+    (forall n, nth_error l' n = nth_error l (f n)).
+Proof.
+ rewrite Permutation_nth_error; split.
+ - intros (E & f & Hf & Hf').
+   exists f. do 2 (split; trivial).
+   intros n Hn.
+   destruct (Lt.le_or_lt (length l) (f n)) as [LE|LT]; trivial.
+   rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE.
+   elim (Lt.lt_not_le _ _ Hn LE).
+ - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto].
+   assert (H : length l' <= length l') by auto with arith.
+   rewrite <- nth_error_None, Hf3, nth_error_None in H.
+   destruct (Lt.le_or_lt (length l) (length l')) as [LE|LT];
+    [|apply Hf2 in LT; elim (Lt.lt_not_le _ _ LT H)].
+   apply Lt.le_lt_or_eq in LE. destruct LE as [LT|EQ]; trivial.
+   rewrite <- nth_error_Some, Hf3, nth_error_Some in LT.
+   assert (Hf' : bInjective (length l) f).
+   { intros x y _ _ E. now apply Hf. }
+   rewrite (bInjective_bSurjective Hf2) in Hf'.
+   destruct (Hf' _ LT) as (y & Hy & Hy').
+   apply Hf in Hy'. subst y. elim (Lt.lt_irrefl _ Hy).
+Qed.
+
+Lemma Permutation_nth l l' d :
+ Permutation l l' <->
+  (let n := length l in
+   length l' = n /\
+   exists f:nat->nat,
+    bFun n f /\
+    bInjective n f /\
+    (forall x, x < n -> nth x l' d = nth (f x) l d)).
+Proof.
+ split.
+ - intros H.
+   assert (E := Permutation_length H).
+   split; auto.
+   apply Permutation_nth_error_bis in H.
+   destruct H as (f & Hf & Hf2 & Hf3).
+   exists f. split; [|split]; auto.
+   intros x y _ _ Hxy. now apply Hf.
+   intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default.
+    now rewrite Hf3.
+ - intros (E & f & Hf1 & Hf2 & Hf3).
+   rewrite Permutation_nth_error.
+   split; auto.
+   exists (fun n => if le_lt_dec (length l) n then n else f n).
+   split.
+   * intros x y.
+     destruct le_lt_dec as [LE|LT];
+      destruct le_lt_dec as [LE'|LT']; auto.
+     + apply Hf1 in LT'. intros ->.
+       elim (Lt.lt_irrefl (f y)). eapply Lt.lt_le_trans; eauto.
+     + apply Hf1 in LT. intros <-.
+       elim (Lt.lt_irrefl (f x)). eapply Lt.lt_le_trans; eauto.
+   * intros n.
+     destruct le_lt_dec as [LE|LT].
+     + assert (LE' : length l' <= n) by (now rewrite E).
+       rewrite <- nth_error_None in LE, LE'. congruence.
+     + assert (LT' : n < length l') by (now rewrite E).
+       specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3.
+       unfold nth_default in Hf3.
+       apply Hf1 in LT.
+       rewrite <- nth_error_Some in LT, LT'.
+       do 2 destruct nth_error; congruence.
+Qed.
+
+End Permutation_alt.
+
 (* begin hide *)
 Notation Permutation_app_swap := Permutation_app_comm (only parsing).
-(* end hide *)
\ No newline at end of file
+(* end hide *)
diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v
index fde796af..dc4a1e0a 100644
--- a/theories/Sorting/Sorted.v
+++ b/theories/Sorting/Sorted.v
@@ -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        *)
@@ -20,6 +20,8 @@
 
 Require Import List Relations Relations_1.
 
+(* Set Universe Polymorphism. *)
+
 (** Preambule *)
 
 Set Implicit Arguments.
@@ -67,7 +69,7 @@ Section defs.
       (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) ->
       forall l:list A, Sorted l -> P l.
   Proof.
-    induction l; firstorder using Sorted_inv.
+    induction l. firstorder using Sorted_inv. firstorder using Sorted_inv.
   Qed.
 
   Lemma Sorted_LocallySorted_iff : forall l, Sorted l <-> LocallySorted l.
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
index 6a9105ab..712b8fd6 100644
--- a/theories/Sorting/Sorting.v
+++ b/theories/Sorting/Sorting.v
@@ -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/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
index c2e88251..3dbd9cb4 100644
--- a/theories/Strings/Ascii.v
+++ b/theories/Strings/Ascii.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -10,7 +10,7 @@
 (** Contributed by Laurent Théry (INRIA);
     Adapted to Coq V8 by the Coq Development Team *)
 
-Require Import Bool BinPos BinNat Nnat.
+Require Import Bool BinPos BinNat PeanoNat Nnat.
 Declare ML Module "ascii_syntax_plugin".
 
 (** * Definition of ascii characters *)
@@ -34,6 +34,7 @@ Definition shift (c : bool) (a : ascii) :=
 (** Definition of a decidable function that is effective *)
 
 Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
+Proof.
   decide equality; apply bool_dec.
 Defined.
 
@@ -115,7 +116,7 @@ Proof.
  unfold N.lt.
  change 256%N with (N.of_nat 256).
  rewrite <- Nat2N.inj_compare.
- rewrite <- Compare_dec.nat_compare_lt. auto.
+ now apply Nat.compare_lt_iff.
 Qed.
 
 
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index 34adf332..ac1f158a 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -29,6 +29,7 @@ Local Open Scope string_scope.
 (** Equality is decidable *)
 
 Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
+Proof.
  decide equality; apply ascii_dec.
 Defined.
 
@@ -41,7 +42,6 @@ Fixpoint append (s1 s2 : string) : string :=
   | EmptyString => s2
   | String c s1' => String c (s1' ++ s2)
   end
-
 where "s1 ++ s2" := (append s1 s2) : string_scope.
 
 (******************************)
@@ -379,7 +379,7 @@ Definition findex n s1 s2 :=
 (**
   The concrete syntax for strings in scope string_scope follows the
   Coq convention for strings: all ascii characters of code less than
-  128 are litteral to the exception of the character `double quote'
+  128 are literals to the exception of the character `double quote'
   which must be doubled.
 
   Strings that involve ascii characters of code >= 128 which are not
diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v
index 79e81771..f85222df 100644
--- a/theories/Structures/DecidableType.v
+++ b/theories/Structures/DecidableType.v
@@ -80,13 +80,13 @@ Module KeyDecidableType(D:DecidableType).
   Lemma InA_eqke_eqk :
      forall x m, InA eqke x m -> InA eqk x m.
   Proof.
-    unfold eqke; induction 1; intuition.
+    unfold eqke; induction 1; intuition. 
   Qed.
   Hint Resolve InA_eqke_eqk.
 
   Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
   Proof.
-   intros; apply InA_eqA with p; auto with *.
+   intros; apply InA_eqA with p; auto with *. 
   Qed.
 
   Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v
index 971fcd7f..163a40f2 100644
--- a/theories/Structures/DecidableTypeEx.v
+++ b/theories/Structures/DecidableTypeEx.v
@@ -88,7 +88,7 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
  destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
  unfold eq, D1.eq, D2.eq in *; simpl;
  (left; f_equal; auto; fail) ||
- (right; intro H; injection H; auto).
+ (right; injection; auto).
  Defined.
 
 End PairUsualDecidableType.
diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v
index eb537385..747d03f8 100644
--- a/theories/Structures/Equalities.v
+++ b/theories/Structures/Equalities.v
@@ -126,14 +126,14 @@ Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation.
       [EqualityType] and [DecidableType] *)
 
 Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E.
- Definition eq_refl := @Equivalence_Reflexive _ _ F.eq_equiv.
- Definition eq_sym := @Equivalence_Symmetric _ _ F.eq_equiv.
- Definition eq_trans := @Equivalence_Transitive _ _ F.eq_equiv.
+ Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _). 
+ Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _).
+ Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _).
 End BackportEq.
 
 Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E.
  Instance eq_equiv : Equivalence E.eq.
- Proof. exact (Build_Equivalence _ _ F.eq_refl F.eq_sym F.eq_trans). Qed.
+ Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed.
 End UpdateEq.
 
 Module Backport_ET (E:EqualityType) <: EqualityTypeBoth
diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v
index c69885b4..11d94c11 100644
--- a/theories/Structures/EqualitiesFacts.v
+++ b/theories/Structures/EqualitiesFacts.v
@@ -166,7 +166,7 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
  destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
  unfold eq, D1.eq, D2.eq in *; simpl;
  (left; f_equal; auto; fail) ||
- (right; intro H; injection H; auto).
+ (right; intros [=]; auto).
  Defined.
 
 End PairUsualDecidableType.
diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v
index ffd0649a..ac52d1bb 100644
--- a/theories/Structures/GenericMinMax.v
+++ b/theories/Structures/GenericMinMax.v
@@ -110,7 +110,7 @@ Proof.
  intros x x' Hx y y' Hy.
  assert (H1 := max_spec x y). assert (H2 := max_spec x' y').
  set (m := max x y) in *; set (m' := max x' y') in *; clearbody m m'.
- rewrite <- Hx, <- Hy in *.
+ rewrite <- Hx, <- Hy in *. 
  destruct (lt_total x y); intuition order.
 Qed.
 
@@ -440,7 +440,7 @@ Qed.
 
 Lemma max_min_antimono f :
  Proper (eq==>eq) f ->
- Proper (le==>inverse le) f ->
+ Proper (le==>flip le) f ->
  forall x y, max (f x) (f y) == f (min x y).
 Proof.
  intros Eqf Lef x y.
@@ -452,7 +452,7 @@ Qed.
 
 Lemma min_max_antimono f :
  Proper (eq==>eq) f ->
- Proper (le==>inverse le) f ->
+ Proper (le==>flip le) f ->
  forall x y, min (f x) (f y) == f (max x y).
 Proof.
  intros Eqf Lef x y.
@@ -557,11 +557,11 @@ Module UsualMinMaxLogicalProperties
   forall x y, min (f x) (f y) = f (min x y).
  Proof. intros; apply min_mono; auto. congruence. Qed.
 
- Lemma min_max_antimonotone f : Proper (le ==> inverse le) f ->
+ Lemma min_max_antimonotone f : Proper (le ==> flip le) f ->
   forall x y, min (f x) (f y) = f (max x y).
  Proof. intros; apply min_max_antimono; auto. congruence. Qed.
 
- Lemma max_min_antimonotone f : Proper (le ==> inverse le) f ->
+ Lemma max_min_antimonotone f : Proper (le ==> flip le) f ->
   forall x y, max (f x) (f y) = f (min x y).
  Proof. intros; apply max_min_antimono; auto. congruence. Qed.
 
diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v
index 75578195..cc8c2261 100644
--- a/theories/Structures/OrderedType.v
+++ b/theories/Structures/OrderedType.v
@@ -49,7 +49,7 @@ Module Type OrderedType.
   Include MiniOrderedType.
 
   (** A [eq_dec] can be deduced from [compare] below. But adding this
-     redundant field allows to see an OrderedType as a DecidableType. *)
+     redundant field allows seeing an OrderedType as a DecidableType. *)
   Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }.
 
 End OrderedType.
@@ -85,16 +85,16 @@ Module OrderedTypeFacts (Import O: OrderedType).
 
   Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
   Proof.
-   intros; destruct (compare x z); auto.
+   intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto.
    elim (lt_not_eq H); apply eq_trans with z; auto.
-   elim (lt_not_eq (lt_trans l H)); auto.
+   elim (lt_not_eq (lt_trans Hlt H)); auto.
   Qed.
 
   Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
   Proof.
-   intros; destruct (compare x z); auto.
+   intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto.
    elim (lt_not_eq H0); apply eq_trans with x; auto.
-   elim (lt_not_eq (lt_trans H0 l)); auto.
+   elim (lt_not_eq (lt_trans H0 Hlt)); auto.
   Qed.
 
   Instance lt_compat : Proper (eq==>eq==>iff) lt.
@@ -225,7 +225,7 @@ Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
 Proof. exact (InfA_ltA lt_strorder). Qed.
 
 Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed.
+Proof. exact (InfA_eqA eq_equiv lt_compat). Qed.
 
 Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
 Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
@@ -398,7 +398,7 @@ Module KeyOrderedType(O:OrderedType).
   Qed.
 
   Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
-  Proof. exact (InfA_eqA eqk_equiv ltk_strorder ltk_compat). Qed.
+  Proof. exact (InfA_eqA eqk_equiv ltk_compat). Qed.
 
   Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
   Proof. exact (InfA_ltA ltk_strorder). Qed.
diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v
index 83130deb..3c6afc7b 100644
--- a/theories/Structures/OrderedTypeEx.v
+++ b/theories/Structures/OrderedTypeEx.v
@@ -279,7 +279,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType.
   Proof.
   induction x; destruct y.
   - (* I I *)
-    destruct (IHx y).
+    destruct (IHx y) as [l|e|g].
     apply LT; auto.
     apply EQ; rewrite e; red; auto.
     apply GT; auto.
@@ -290,7 +290,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType.
   - (* O I *)
     apply LT; simpl; auto.
   - (* O O *)
-    destruct (IHx y).
+    destruct (IHx y) as [l|e|g].
     apply LT; auto.
     apply EQ; rewrite e; red; auto.
     apply GT; auto.
diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v
index 1d025439..724690b4 100644
--- a/theories/Structures/Orders.v
+++ b/theories/Structures/Orders.v
@@ -15,11 +15,11 @@ Unset Strict Implicit.
 (** First, signatures with only the order relations *)
 
 Module Type HasLt (Import T:Typ).
-  Parameter Inline lt : t -> t -> Prop.
+  Parameter Inline(40) lt : t -> t -> Prop.
 End HasLt.
 
 Module Type HasLe (Import T:Typ).
-  Parameter Inline le : t -> t -> Prop.
+  Parameter Inline(40) le : t -> t -> Prop.
 End HasLe.
 
 Module Type EqLt := Typ <+ HasEq <+ HasLt.
@@ -95,7 +95,7 @@ Module Type OrderedTypeFull' :=
  OrderedTypeFull <+ EqLtLeNotation <+ CmpNotation.
 
 (** NB: in [OrderedType], an [eq_dec] could be deduced from [compare].
-  But adding this redundant field allows to see an [OrderedType] as a
+  But adding this redundant field allows seeing an [OrderedType] as a
   [DecidableType]. *)
 
 (** * Versions with [eq] being the usual Leibniz equality of Coq *)
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
index e071d053..acc7c767 100644
--- a/theories/Structures/OrdersEx.v
+++ b/theories/Structures/OrdersEx.v
@@ -11,16 +11,16 @@
  * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
  *              91405 Orsay, France *)
 
-Require Import Orders NPeano POrderedType NArith
- ZArith RelationPairs EqualitiesFacts.
+Require Import Orders PeanoNat POrderedType BinNat BinInt
+ RelationPairs EqualitiesFacts.
 
 (** * Examples of Ordered Type structures. *)
 
 
 (** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *)
 
-Module Nat_as_OT := NPeano.Nat.
-Module Positive_as_OT := POrderedType.Positive_as_OT.
+Module Nat_as_OT := PeanoNat.Nat.
+Module Positive_as_OT := BinPos.Pos.
 Module N_as_OT := BinNat.N.
 Module Z_as_OT := BinInt.Z.
 
diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v
index 2e9c0cf5..88fbd8c1 100644
--- a/theories/Structures/OrdersFacts.v
+++ b/theories/Structures/OrdersFacts.v
@@ -31,7 +31,7 @@ Module Type CompareFacts (Import O:DecStrOrder').
 
  Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x<y.
  Proof.
- case compare_spec; intro H; split; try easy; intro LT;
+  case compare_spec; intro H; split; try easy; intro LT;
   contradict LT; rewrite H; apply irreflexivity.
  Qed.
 
@@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull').
  Instance le_order : PartialOrder eq le.
  Proof. compute; iorder. Qed.
 
- Instance le_antisym : Antisymmetric _ eq le.
+ Instance le_antisym : Antisymmetric eq le.
  Proof. apply partial_order_antisym; auto with *. Qed.
 
  Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x.
diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v
index f83b6377..059992f5 100644
--- a/theories/Structures/OrdersLists.v
+++ b/theories/Structures/OrdersLists.v
@@ -32,7 +32,7 @@ Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
 Proof. exact (InfA_ltA lt_strorder). Qed.
 
 Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed.
+Proof. exact (InfA_eqA eq_equiv lt_compat). Qed.
 
 Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
 Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v
index 68ffc379..475a25a4 100644
--- a/theories/Structures/OrdersTac.v
+++ b/theories/Structures/OrdersTac.v
@@ -29,7 +29,7 @@ Set Implicit Arguments.
     [le x y -> le y z -> le x z].
 *)
 
-Inductive ord := OEQ | OLT | OLE.
+Inductive ord : Set := OEQ | OLT | OLE.
 Definition trans_ord o o' :=
  match o, o' with
  | OEQ, _ => o'
@@ -70,7 +70,7 @@ Lemma le_refl : forall x, x<=x.
 Proof. intros; rewrite P.le_lteq; right; reflexivity. Qed.
 
 Lemma lt_irrefl : forall x, ~ x<x.
-Proof. intros; apply StrictOrder_Irreflexive. Qed.
+Proof. intros. apply StrictOrder_Irreflexive. Qed.
 
 (** Symmetry rules *)
 
@@ -100,8 +100,9 @@ Local Notation "#" := interp_ord.
 
 Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z.
 Proof.
-destruct o, o'; simpl; intros x y z; rewrite ?P.le_lteq; intuition;
- subst_eqns; eauto using (StrictOrder_Transitive x y z) with *.
+destruct o, o'; simpl; intros x y z;
+rewrite ?P.le_lteq; intuition auto;
+subst_eqns; eauto using (StrictOrder_Transitive x y z) with *.
 Qed.
 
 Definition eq_trans x y z : x==y -> y==z -> x==z := @trans OEQ OEQ x y z.
diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v
index f9041aad..3b4beda9 100644
--- a/theories/Unicode/Utf8.v
+++ b/theories/Unicode/Utf8.v
@@ -1,7 +1,7 @@
 (* -*- coding:utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v
index 43ac9976..fe13f0ef 100644
--- a/theories/Unicode/Utf8_core.v
+++ b/theories/Unicode/Utf8_core.v
@@ -1,7 +1,7 @@
 (* -*- coding:utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -18,7 +18,7 @@ Notation "∃  x .. y , P" := (exists x, .. (exists y, P) ..)
 Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
 Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
 Notation "x → y" := (x -> y)
-  (at level 90, y at level 200, right associativity): type_scope.
+  (at level 99, y at level 200, right associativity): type_scope.
 
 Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
 Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v
index a5e37f34..b9bf6c7f 100644
--- a/theories/Vectors/Fin.v
+++ b/theories/Vectors/Fin.v
@@ -8,13 +8,14 @@
 
 Require Arith_base.
 
-(** [fin n] is a convinient way to represent \[1 .. n\]
+(** [fin n] is a convenient way to represent \[1 .. n\]
 
-[fin n] can be seen as a n-uplet of unit where [F1] is the first element of
-the n-uplet and [FS] set (n-1)-uplet of all the element but the first.
+[fin n] can be seen as a n-uplet of unit. [F1] is the first element of
+the n-uplet. If [f] is the k-th element of the (n-1)-uplet, [FS f] is the
+(k+1)-th element of  the n-uplet.
 
    Author: Pierre Boutillier
-   Institution: PPS, INRIA 12/2010-01/2012
+   Institution: PPS, INRIA 12/2010-01/2012-07/2012
 *)
 
 Inductive t : nat -> Set :=
@@ -23,76 +24,68 @@ Inductive t : nat -> Set :=
 
 Section SCHEMES.
 Definition case0 P (p: t 0): P p :=
-  match p as p' in t n return
-    match n as n' return t n' -> Type
-  with |0 => fun f0 => P f0 |S _ => fun _ => @ID end p'
-  with |F1 _ => @id |FS _ _ => @id end.
+  match p with | F1 | FS  _ => fun devil => False_rect (@IDProp) devil (* subterm !!! *) end.
 
-Definition caseS (P: forall {n}, t (S n) -> Type)
-  (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p))
-  {n} (p: t (S n)): P p :=
+Definition caseS' {n : nat} (p : t (S n)) : forall (P : t (S n) -> Type) 
+  (P1 : P F1) (PS : forall (p : t n), P (FS p)), P p :=
   match p with
-  |F1 k => P1 k
-  |FS k pp => PS pp
+  | @F1 k => fun P P1 PS => P1
+  | FS pp => fun P P1 PS => PS pp
   end.
 
+Definition caseS (P: forall {n}, t (S n) -> Type)
+  (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p))
+  {n} (p: t (S n)) : P p := caseS' p P (P1 n) PS.
+
 Definition rectS (P: forall {n}, t (S n) -> Type)
   (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)):
   forall {n} (p: t (S n)), P p :=
 fix rectS_fix {n} (p: t (S n)): P p:=
   match p with
-  |F1 k => P1 k
-  |FS 0 pp => case0 (fun f => P (FS f)) pp
-  |FS (S k) pp => PS pp (rectS_fix pp)
+  | @F1 k => P1 k
+  | @FS 0 pp => case0 (fun f => P (FS f)) pp
+  | @FS (S k) pp => PS pp (rectS_fix pp)
   end.
 
-Definition rect2 (P: forall {n} (a b: t n), Type)
-  (H0: forall n, @P (S n) F1 F1)
-  (H1: forall {n} (f: t n), P F1 (FS f))
-  (H2: forall {n} (f: t n), P (FS f) F1)
-  (HS: forall {n} (f g : t n), P f g -> P (FS f) (FS g)):
-    forall {n} (a b: t n), P a b :=
-fix rect2_fix {n} (a: t n): forall (b: t n), P a b :=
-match a with
-  |F1 m => fun (b: t (S m)) => match b as b' in t n'
-                   return match n',b' with
-                            |0,_ => @ID
-                            |S n0,b0 => P F1 b0
-                          end with
-                     |F1 m' => H0 m'
-                     |FS m' b' => H1 b'
-                   end
-  |FS m a' => fun (b: t (S m)) => match b with
-                         |F1 m' => fun aa: t m' => H2 aa
-                         |FS m' b' => fun aa: t m' => HS aa b' (rect2_fix aa b')
-                       end a'
-end.
+Definition rect2 (P : forall {n} (a b : t n), Type)
+  (H0 : forall n, @P (S n) F1 F1)
+  (H1 : forall {n} (f : t n), P F1 (FS f))
+  (H2 : forall {n} (f : t n), P (FS f) F1)
+  (HS : forall {n} (f g : t n), P f g -> P (FS f) (FS g)) :
+    forall {n} (a b : t n), P a b :=
+  fix rect2_fix {n} (a : t n) {struct a} : forall (b : t n), P a b :=
+    match a with
+    | @F1 m => fun (b : t (S m)) => caseS' b (P F1) (H0 _) H1
+    | @FS m a' => fun (b : t (S m)) =>
+      caseS' b (fun b => P (@FS m a') b) (H2 a') (fun b' => HS _ _ (rect2_fix a' b'))
+    end.
+
 End SCHEMES.
 
 Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y :=
 match eq in _ = a return
   match a as a' in t m return match m with |0 => Prop |S n' => t n' -> Prop end
-  with @F1 _ =>  fun _ => True |@FS _ y => fun x' => x' = y end x with
+  with F1 =>  fun _ => True |FS y => fun x' => x' = y end x with
   eq_refl => eq_refl
 end.
 
 (** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *)
 Fixpoint to_nat {m} (n : t m) : {i | i < m} :=
-  match n in t k return {i | i< k} with
-    |F1 j => exist (fun i => i< S j) 0 (Lt.lt_0_Sn j)
-    |FS _ p => match to_nat p with |exist i P => exist _ (S i) (Lt.lt_n_S _ _ P) end
+  match n with
+    |@F1 j => exist _ 0 (Lt.lt_0_Sn j)
+    |FS p => match to_nat p with |exist _ i P => exist _ (S i) (Lt.lt_n_S _ _ P) end
   end.
 
 (** [of_nat p n] answers the p{^ th} element of [fin n] if p < n or a proof of
 p >= n else *)
 Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } :=
   match n with
-   |0 => inright _ (ex_intro (fun x => p = 0 + x) p (@eq_refl _ p))
+   |0 => inright _ (ex_intro _ p eq_refl)
    |S n' => match p with
       |0 => inleft _ (F1)
       |S p' => match of_nat p' n' with
         |inleft f => inleft _ (FS f)
-        |inright arg => inright _ (match arg with |ex_intro m e =>
+        |inright arg => inright _ (match arg with |ex_intro _ m e =>
           ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end)
       end
     end
@@ -109,13 +102,35 @@ Fixpoint of_nat_lt {p n : nat} : p < n -> t n :=
     end
   end.
 
+Lemma of_nat_ext {p}{n} (h h' : p < n) : of_nat_lt h = of_nat_lt h'.
+Proof.
+ now rewrite (Peano_dec.le_unique _ _ h h').
+Qed.
+
 Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p.
 Proof.
-induction p.
- reflexivity.
- simpl; destruct (to_nat p). simpl. subst p; repeat f_equal. apply Peano_dec.le_unique.
+induction p; simpl.
+- reflexivity.
+- destruct (to_nat p); simpl in *. f_equal. subst p. apply of_nat_ext.
+Qed.
+
+Lemma to_nat_of_nat {p}{n} (h : p < n) : to_nat (of_nat_lt h) = exist _ p h.
+Proof.
+ revert n h.
+ induction p; (destruct n ; intros h; [ destruct (Lt.lt_n_O _ h) | cbn]);
+ [ | rewrite (IHp _ (Lt.lt_S_n p n h))];  f_equal; apply Peano_dec.le_unique.
+Qed.
+
+Lemma to_nat_inj {n} (p q : t n) :
+ proj1_sig (to_nat p) = proj1_sig (to_nat q) -> p = q.
+Proof.
+ intro H.
+ rewrite <- (of_nat_to_nat_inv p), <- (of_nat_to_nat_inv q).
+ destruct (to_nat p) as (np,hp), (to_nat q) as (nq,hq); simpl in *.
+ revert hp hq. rewrite H. apply of_nat_ext.
 Qed.
 
+
 (** [weak p f] answers a function witch is the identity for the p{^  th} first
 element of [fin (p + m)] and [FS (FS .. (FS (f k)))] for [FS (FS .. (FS k))]
 with p FSs *)
@@ -124,15 +139,15 @@ Fixpoint weak {m}{n} p (f : t m -> t n) :
 match p as p' return t (p' + m) -> t (p' + n) with
   |0 => f
   |S p' => fun x => match x with
-     |F1 n' => fun eq : n' = p' + m => F1
-     |FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq))
+     |@F1 n' => fun eq : n' = p' + m => F1
+     |@FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq))
   end (eq_refl _)
 end.
 
 (** The p{^ th} element of [fin m] viewed as the p{^ th} element of
 [fin (m + n)] *)
 Fixpoint L {m} n (p : t m) : t (m + n) :=
-  match p with |F1 _ => F1 |FS _ p' => FS (L n p') end.
+  match p with |F1 => F1 |FS p' => FS (L n p') end.
 
 Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p).
 Proof.
@@ -145,12 +160,13 @@ Qed.
 [fin (n + m)]
 Really really ineficient !!! *)
 Definition L_R {m} n (p : t m) : t (n + m).
+Proof.
 induction n.
   exact p.
   exact ((fix LS k (p: t k) :=
     match p with
-      |F1 k' => @F1 (S k')
-      |FS _ p' => FS (LS _ p')
+      |@F1 k' => @F1 (S k')
+      |FS p' => FS (LS _ p')
     end) _ IHn).
 Defined.
 
@@ -168,8 +184,8 @@ Qed.
 
 Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) :=
 match o with
-  |F1 m' => L (m' * n) p
-  |FS m' o' => R n (depair o' p)
+  |@F1 m' => L (m' * n) p
+  |FS o' => R n (depair o' p)
 end.
 
 Lemma depair_sanity {m n} (o : t m) (p : t n) :
@@ -182,3 +198,55 @@ induction o ; simpl.
   rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r.
     now rewrite (Plus.plus_comm n).
 Qed.
+
+Fixpoint eqb {m n} (p : t m) (q : t n) :=
+match p, q with
+| @F1 m', @F1 n' => EqNat.beq_nat m' n'
+| FS _, F1 => false
+| F1, FS _ => false
+| FS p', FS q' => eqb p' q'
+end.
+
+Lemma eqb_nat_eq : forall m n (p : t m) (q : t n), eqb p q = true -> m = n.
+Proof.
+intros m n p; revert n; induction p; destruct q; simpl; intros; f_equal.
++ now apply EqNat.beq_nat_true.
++ easy.
++ easy.
++ eapply IHp. eassumption.
+Qed.
+
+Lemma eqb_eq : forall n (p q : t n), eqb p q = true <-> p = q.
+Proof.
+apply rect2; simpl; intros.
+- split; intros ; [ reflexivity | now apply EqNat.beq_nat_true_iff ].
+- now split.
+- now split.
+- eapply iff_trans.
+ + eassumption.
+ + split.
+  * intros; now f_equal.
+  * apply FS_inj.
+Qed.
+
+Lemma eq_dec {n} (x y : t n): {x = y} + {x <> y}.
+Proof.
+ case_eq (eqb x y); intros.
+  + left; now apply eqb_eq.
+  + right. intros Heq. apply <- eqb_eq in Heq. congruence.
+Defined.
+
+Definition cast: forall {m} (v: t m) {n}, m = n -> t n.
+Proof.
+refine (fix cast {m} (v: t m) {struct v} :=
+ match v in t m' return forall n, m' = n -> t n with
+ |F1 => fun n => match n with
+   | 0 => fun H => False_rect _ _
+   | S n' => fun H => F1
+ end
+ |FS f => fun n => match n with
+   | 0 => fun H => False_rect _ _
+   | S n' => fun H => FS (cast f n' (f_equal pred H))
+ end
+end); discriminate.
+Defined.
diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v
index f3e5e338..672858fa 100644
--- a/theories/Vectors/Vector.v
+++ b/theories/Vectors/Vector.v
@@ -18,5 +18,7 @@ Based on contents from Util/VecUtil of the CoLoR contribution *)
 Require Fin.
 Require VectorDef.
 Require VectorSpec.
+Require VectorEq.
 Include VectorDef.
 Include VectorSpec.
+Include VectorEq.
\ No newline at end of file
diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v
index 32ffcb3d..45c13e5c 100644
--- a/theories/Vectors/VectorDef.v
+++ b/theories/Vectors/VectorDef.v
@@ -21,6 +21,8 @@ Require Vectors.Fin.
 Import EqNotations.
 Local Open Scope nat_scope.
 
+(* Set Universe Polymorphism. *)
+
 (**
 A vector is a list of size n whose elements belong to a set A. *)
 
@@ -40,72 +42,61 @@ Definition rectS {A} (P:forall {n}, t A (S n) -> Type)
  (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) :=
  fix rectS_fix {n} (v: t A (S n)) : P v :=
  match v with
- |nil => fun devil => False_rect (@ID) devil
- |cons a 0 v =>
-   match v as vnn in t _ nn
-       return
-         match nn,vnn with
-         |0,vm =>  P (a :: vm)
-         |S _,_ => _
-         end
-     with
-     |nil => bas a
-     |_ :: _ => fun devil => False_rect (@ID) devil
-     end
- |cons a (S nn') v => rect a v (rectS_fix v)
+ |@cons _ a 0 v =>
+   match v with
+     |nil _ => bas a
+     |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
+   end
+ |@cons _ a (S nn') v => rect a v (rectS_fix v)
+ |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
  end.
 
-(** An induction scheme for 2 vectors of same length *)
-Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
-  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
-    forall a b, P (a :: v1) (b :: v2)) :=
-fix rect2_fix {n} (v1:t A n):
-  forall v2 : t B n, P v1 v2 :=
-match v1 as v1' in t _ n1
-  return forall v2 : t B n1, P v1' v2 with
-  |[] => fun v2 =>
-     match v2 with
-       |[] => bas
-       |_ :: _ => fun devil => False_rect (@ID) devil
-     end
-  |h1 :: t1 => fun v2 =>
-    match v2 with
-      |[] => fun devil => False_rect (@ID) devil
-      |h2 :: t2 => fun t1' =>
-        rect (rect2_fix t1' t2) h1 h2
-    end t1
-end.
-
 (** A vector of length [0] is [nil] *)
 Definition case0 {A} (P:t A 0 -> Type) (H:P (nil A)) v:P v :=
 match v with
   |[] => H
+  |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
 end.
 
 (** A vector of length [S _] is [cons] *)
 Definition caseS {A} (P : forall {n}, t A (S n) -> Type)
   (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v :=
-match v as v' in t _ m return match m, v' with |0, _ => False -> True |S _, v0 => P v' end with
-  |[] => fun devil => False_rect _ devil (* subterm !!! *)
+match v with
   |h :: t => H h t
+  |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
 end.
+
+Definition caseS' {A} {n : nat} (v : t A (S n)) : forall (P : t A (S n) -> Type)
+  (H : forall h t, P (h :: t)), P v :=
+  match v with
+  | h :: t => fun P H => H h t
+  | _ => fun devil => False_rect (@IDProp) devil
+  end.
+
+(** An induction scheme for 2 vectors of same length *)
+Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
+  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
+    forall a b, P (a :: v1) (b :: v2)) :=
+  fix rect2_fix {n} (v1 : t A n) : forall v2 : t B n, P v1 v2 :=
+  match v1 with
+  | [] => fun v2 => case0 _ bas v2
+  | @cons _ h1 n' t1 => fun v2 =>
+    caseS' v2 (fun v2' => P (h1::t1) v2') (fun h2 t2 => rect (rect2_fix t1 t2) h1 h2)
+  end.
+
 End SCHEMES.
 
 Section BASES.
 (** The first element of a non empty vector *)
-Definition hd {A} {n} (v:t A (S n)) := Eval cbv delta beta in
-(caseS (fun n v => A) (fun h n t => h) v).
+Definition hd {A} := @caseS _ (fun n v => A) (fun h n t => h).
+Global Arguments hd {A} {n} v.
 
 (** The last element of an non empty vector *)
-Definition last {A} {n} (v : t A (S n)) := Eval cbv delta in
-(rectS (fun _ _ => A) (fun a => a) (fun _ _ _ H => H) v).
+Definition last {A} := @rectS _ (fun _ _ => A) (fun a => a) (fun _ _ _ H => H).
+Global Arguments last {A} {n} v.
 
 (** Build a vector of n{^ th} [a] *)
-Fixpoint const {A} (a:A) (n:nat) :=
-  match n return t A n with
-  | O => nil A
-  | S n => a :: (const a n)
-  end.
+Definition const {A} (a:A) := nat_rect _ [] (fun n x => cons _ a n x).
 
 (** The [p]{^ th} element of a vector of length [m].
 
@@ -114,8 +105,8 @@ ocaml function. *)
 Definition nth {A} := 
 fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A :=
 match p in Fin.t m' return t A m' -> A with
- |Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v
- |Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A)
+ |Fin.F1 => caseS (fun n v' => A) (fun h n t => h)
+ |Fin.FS p' => fun v => (caseS (fun n v' => Fin.t n -> A)
    (fun h n t p0 => nth_fix t p0) v) p'
 end v'.
 
@@ -126,9 +117,9 @@ Definition nth_order {A} {n} (v: t A n) {p} (H: p < n) :=
 (** Put [a] at the p{^ th} place of [v] *)
 Fixpoint replace {A n} (v : t A n) (p: Fin.t n) (a : A) {struct p}: t A n :=
   match p with
-  |Fin.F1 k => fun v': t A (S k) => caseS (fun n _ => t A (S n)) (fun h _ t => a :: t) v'
-  |Fin.FS k p' => fun v' =>
-    (caseS (fun n _ => Fin.t n -> t A (S n)) (fun h _ t p2 => h :: (replace t p2 a)) v') p'
+  | @Fin.F1 k => fun v': t A (S k) => caseS' v' _ (fun h t => a :: t)
+  | @Fin.FS k p' => fun v' : t A (S k) =>
+    (caseS' v' (fun _ => t A (S k)) (fun h t => h :: (replace t p' a)))
   end v.
 
 (** Version of replace with [lt] *)
@@ -136,13 +127,13 @@ Definition replace_order {A n} (v: t A n) {p} (H: p < n) :=
 replace v (Fin.of_nat_lt H).
 
 (** Remove the first element of a non empty vector *)
-Definition tl {A} {n} (v:t A (S n)) := Eval cbv delta beta in
-(caseS (fun n v => t A n) (fun h n t => t) v).
+Definition tl {A} := @caseS _ (fun n v => t A n) (fun h n t => t).
+Global Arguments tl {A} {n} v.
 
 (** Remove last element of a non-empty vector *)
-Definition shiftout {A} {n:nat} (v:t A (S n)) : t A n :=
-Eval cbv delta beta in (rectS (fun n _ => t A n) (fun a => [])
-  (fun h _ _ H => h :: H) v).
+Definition shiftout {A} := @rectS _ (fun n _ => t A n) (fun a => [])
+  (fun h _ _ H => h :: H).
+Global Arguments shiftout {A} {n} v.
 
 (** Add an element at the end of a vector *)
 Fixpoint shiftin {A} {n:nat} (a : A) (v:t A n) : t A (S n) :=
@@ -152,9 +143,9 @@ match v with
 end.
 
 (** Copy last element of a vector *)
-Definition shiftrepeat {A} {n} (v:t A (S n)) : t A (S (S n)) :=
-Eval cbv delta beta in (rectS (fun n _ => t A (S (S n)))
-  (fun h =>  h :: h :: []) (fun h _ _ H => h :: H) v).
+Definition shiftrepeat {A} := @rectS _ (fun n _ => t A (S (S n)))
+  (fun h =>  h :: h :: []) (fun h _ _ H => h :: H).
+Global Arguments shiftrepeat {A} {n} v.
 
 (** Remove [p] last elements of a vector *)
 Lemma trunc : forall {A} {n} (p:nat), n > p -> t A n
@@ -221,10 +212,10 @@ Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n :=
   end.
 
 (** map2 g [x1 .. xn] [y1 .. yn] = [(g x1 y1) .. (g xn yn)] *)
-Definition map2 {A B C} (g:A -> B -> C) {n} (v1:t A n) (v2:t B n)
-  : t C n :=
-Eval cbv delta beta in rect2 (fun n _ _ => t C n) (nil C)
-  (fun _ _ _ H a b => (g a b) :: H) v1 v2.
+Definition map2 {A B C} (g:A -> B -> C) :
+  forall (n : nat), t A n -> t B n -> t C n :=
+@rect2 _ _ (fun n _ _ => t C n) (nil C) (fun _ _ _ H a b => (g a b) :: H).
+Global Arguments map2 {A B C} g {n} v1 v2.
 
 (** fold_left f b [x1 .. xn] = f .. (f (f b x1) x2) .. xn *)
 Definition fold_left {A B:Type} (f:B->A->B): forall (b:B) {n} (v:t A n), B :=
@@ -242,24 +233,19 @@ Definition fold_right {A B : Type} (f : A->B->B) :=
     | a :: w => f a (fold_right_fix w b)
   end.
 
-(** fold_right2 g [x1 .. xn] [y1 .. yn] c = g x1 y1 (g x2 y2 .. (g xn yn c) .. ) *)
-Definition fold_right2 {A B C} (g:A -> B -> C -> C) {n} (v:t A n)
-  (w : t B n) (c:C) : C :=
-Eval cbv delta beta in rect2 (fun _ _ _ => C) c
-  (fun _ _ _ H a b => g a b H) v w.
+(** fold_right2 g c [x1 .. xn] [y1 .. yn] = g x1 y1 (g x2 y2 .. (g xn yn c) .. )
+    c is before the vectors to be compliant with "refolding". *)
+Definition fold_right2 {A B C} (g:A -> B -> C -> C) (c: C) :=
+@rect2 _ _ (fun _ _ _ => C) c (fun _ _ _ H a b => g a b H).
+
 
 (** fold_left2 f b [x1 .. xn] [y1 .. yn] = g .. (g (g a x1 y1) x2 y2) .. xn yn *)
 Definition fold_left2 {A B C: Type} (f : A -> B -> C -> A) :=
 fix fold_left2_fix (a : A) {n} (v : t B n) : t C n -> A :=
 match v in t _ n0 return t C n0 -> A with
-  |[] => fun w => match w in t _ n1
-    return match n1 with |0 => A |S _ => @ID end with
-    |[] => a
-    |_ :: _ => @id end
-  |cons vh vn vt => fun w => match w in t _ n1
-    return match n1 with |0 => @ID |S n => t B n -> A end with
-    |[] => @id
-    |wh :: wt => fun vt' => fold_left2_fix (f a vh wh) vt' wt end vt
+  |[] => fun w => case0 (fun _ => A) a w
+  |@cons _ vh vn vt => fun w =>
+    caseS' w (fun _ => A) (fun wh wt => fold_left2_fix (f a vh wh) vt wt)
 end.
 
 End ITERATORS.
diff --git a/theories/Vectors/VectorEq.v b/theories/Vectors/VectorEq.v
new file mode 100644
index 00000000..04c57073
--- /dev/null
+++ b/theories/Vectors/VectorEq.v
@@ -0,0 +1,80 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Equalities and Vector relations
+
+   Author: Pierre Boutillier
+   Institution: PPS, INRIA 07/2012
+*)
+
+Require Import VectorDef.
+Require Import VectorSpec.
+Import VectorNotations.
+
+Section BEQ.
+
+ Variables (A: Type) (A_beq: A -> A -> bool).
+ Hypothesis A_eqb_eq: forall x y, A_beq x y = true <-> x = y.
+
+ Definition eqb:
+   forall {m n} (v1: t A m) (v2: t A n), bool :=
+   fix fix_beq {m n} v1 v2 :=
+   match v1, v2 with
+     |[], [] => true
+     |_ :: _, [] |[], _ :: _ => false
+     |h1 :: t1, h2 :: t2 => A_beq h1 h2 && fix_beq t1 t2
+   end%bool.
+
+ Lemma eqb_nat_eq: forall m n (v1: t A m) (v2: t A n)
+  (Hbeq: eqb v1 v2 = true), m = n.
+ Proof.
+   intros m n v1; revert n.
+   induction v1; destruct v2;
+     [now constructor | discriminate | discriminate | simpl].
+   intros Hbeq; apply andb_prop in Hbeq; destruct Hbeq.
+   f_equal; eauto.
+ Qed.
+
+ Lemma eqb_eq: forall n (v1: t A n) (v2: t A n),
+  eqb v1 v2 = true <-> v1 = v2.
+ Proof.
+   refine (@rect2 _ _ _ _ _); [now constructor | simpl].
+   intros ? ? ? Hrec h1 h2; destruct Hrec; destruct (A_eqb_eq h1 h2); split.
+   + intros Hbeq. apply andb_prop in Hbeq; destruct Hbeq.
+     f_equal; now auto.
+   + intros Heq. destruct (cons_inj Heq). apply andb_true_intro.
+     split; now auto.
+ Qed.
+
+ Definition eq_dec n (v1 v2: t A n): {v1 = v2} + {v1 <> v2}.
+ Proof.
+ case_eq (eqb v1 v2); intros.
+  + left; now apply eqb_eq.
+  + right. intros Heq. apply <- eqb_eq in Heq. congruence.
+ Defined.
+
+End BEQ.
+
+Section CAST.
+
+ Definition cast: forall {A m} (v: t A m) {n}, m = n -> t A n.
+ Proof.
+ refine (fix cast {A m} (v: t A m) {struct v} :=
+  match v in t _ m' return forall n, m' = n -> t A n with
+  |[] => fun n => match n with
+    | 0 => fun _ => []
+    | S _ => fun H => False_rect _ _
+  end
+  |h :: w => fun n => match n with
+    | 0 => fun H => False_rect _ _
+    | S n' => fun H => h :: (cast w n' (f_equal pred H))
+  end
+ end); discriminate.
+ Defined.
+
+End CAST.
diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v
index 2f4086e5..7f4228dd 100644
--- a/theories/Vectors/VectorSpec.v
+++ b/theories/Vectors/VectorSpec.v
@@ -16,7 +16,7 @@ Require Fin.
 Require Import VectorDef.
 Import VectorNotations.
 
-Definition cons_inj A a1 a2 n (v1 v2 : t A n)
+Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n}
  (eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 :=
    match eq in _ = x return caseS _ (fun a2' _ v2' => fun v1' => a1 = a2' /\ v1' = v2') x v1
    with | eq_refl => conj eq_refl eq_refl
@@ -59,15 +59,15 @@ Qed.
 Lemma shiftrepeat_nth A: forall n k (v: t A (S n)),
   nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k.
 Proof.
-refine (@Fin.rectS _ _ _); intros.
+refine (@Fin.rectS _ _ _); lazy beta; [ intros n v | intros n p H v ].
   revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t.
   revert p H.
-  refine (match v as v' in t _ m return match m as m' return t A m' -> Type with
+  refine (match v as v' in t _ m return match m as m' return t A m' -> Prop with
     |S (S n) => fun v => forall p : Fin.t (S n),
       (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) ->
       (shiftrepeat v) [@Fin.L_R 1 (Fin.FS p)] = v [@Fin.FS p]
-    |_ => fun _ => @ID end v' with
-  |[] => @id |h :: t => _ end). destruct n0. exact @id. now simpl.
+    |_ => fun _ => True end v' with
+  |[] => I |h :: t => _ end). destruct n0. exact I. now simpl.
 Qed.
 
 Lemma shiftrepeat_last A: forall n (v: t A (S n)), last (shiftrepeat v) = last v.
@@ -105,7 +105,7 @@ Proof.
 assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h).
   induction v0.
     now simpl.
-    intros; simpl. rewrite<- IHv0. now f_equal.
+    intros; simpl. rewrite<- IHv0, assoc. now f_equal.
   induction v.
     reflexivity.
     simpl. intros; now rewrite<- (IHv).
diff --git a/theories/Vectors/vo.itarget b/theories/Vectors/vo.itarget
index 7f00d016..779b1821 100644
--- a/theories/Vectors/vo.itarget
+++ b/theories/Vectors/vo.itarget
@@ -1,4 +1,5 @@
 Fin.vo
 VectorDef.vo
 VectorSpec.vo
+VectorEq.vo
 Vector.vo
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
index c1a5f1b2..ee4329bd 100644
--- a/theories/Wellfounded/Disjoint_Union.v
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -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/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index 2250aec1..d09c4112 100644
--- a/theories/Wellfounded/Inclusion.v
+++ b/theories/Wellfounded/Inclusion.v
@@ -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/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index 551dd110..aa6fa6ee 100644
--- a/theories/Wellfounded/Inverse_Image.v
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -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/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index fb3ef1be..dd9e4c98 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -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        *)
@@ -13,8 +13,11 @@
 
 Require Import List.
 Require Import Relation_Operators.
+Require Import Operators_Properties.
 Require Import Transitive_Closure.
 
+Import ListNotations.
+
 Section Wf_Lexicographic_Exponentiation.
   Variable A : Set.
   Variable leA : A -> A -> Prop.
@@ -25,14 +28,11 @@ Section Wf_Lexicographic_Exponentiation.
   Notation Descl := (Desc A leA).
 
   Notation List := (list A).
-  Notation Nil := (nil (A:=A)).
-  (* useless but symmetric *)
-  Notation Cons := (cons (A:=A)).
   Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100).
 
   (* Hint Resolve d_one d_nil t_step. *)
 
-  Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z.
+  Lemma left_prefix : forall x y z : List, ltl (x ++ y) z -> ltl x z.
   Proof.
     simple induction x.
     simple induction z.
@@ -50,8 +50,9 @@ Section Wf_Lexicographic_Exponentiation.
 
 
   Lemma right_prefix :
-    forall x y z:List,
-      ltl x (y ++ z) -> ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
+    forall x y z : List,
+      ltl x (y ++ z) ->
+      ltl x y \/ (exists y' : List, x = y ++ y' /\ ltl y' z).
   Proof.
     intros x y; generalize x.
     elim y; simpl.
@@ -70,172 +71,98 @@ Section Wf_Lexicographic_Exponentiation.
     right; exists x2; auto with sets.
   Qed.
 
-  Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x.
+  Lemma desc_prefix : forall (x : List) (a : A), Descl (x ++ [a]) -> Descl x.
   Proof.
     intros.
     inversion H.
-    generalize (app_cons_not_nil _ _ _ H1); simple induction 1.
-    cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets.
-    intro.
-    generalize (app_eq_unit _ _ H0).
-    simple induction 1; simple induction 1; intros.
-    rewrite H4; auto using d_nil with sets.
-    discriminate H5.
-    generalize (app_inj_tail _ _ _ _ H0).
-    simple induction 1; intros.
-    rewrite <- H4; auto with sets.
+    - apply app_cons_not_nil in H1 as ().
+    - assert (x ++ [a] = [x0]) by auto with sets.
+      apply app_eq_unit in H0 as [(->, _)| (_, [=])].
+      auto using d_nil.
+    - apply app_inj_tail in H0 as (<-, _).
+      assumption.
   Qed.
 
   Lemma desc_tail :
-    forall (x:List) (a b:A),
-      Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b.
+    forall (x : List) (a b : A),
+      Descl (b :: x ++ [a]) -> clos_refl_trans A leA a b.
   Proof.
     intro.
     apply rev_ind with
-      (A := A)
-      (P := fun x:List =>
-        forall a b:A,
-          Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b).
-    intros.
-
-    inversion H.
-    cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil);
-      auto with sets; intro.
-    generalize H0.
-    intro.
-    generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4);
-      simple induction 1.
-    intros.
-
-    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
-    generalize H1.
-    rewrite <- H10; rewrite <- H7; intro.
-    apply (t_step A leA); auto with sets.
-
-    intros.
-    inversion H0.
-    generalize (app_cons_not_nil _ _ _ H3); intro.
-    elim H1.
-
-    generalize H0.
-    generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b);
-      simple induction 1.
-    intro.
-    generalize (desc_prefix (Cons b (l ++ Cons x0 Nil)) a H5); intro.
-    generalize (H x0 b H6).
-    intro.
-    apply t_trans with (A := A) (y := x0); auto with sets.
-
-    apply t_step.
-    generalize H1.
-    rewrite H4; intro.
-
-    generalize (app_inj_tail _ _ _ _ H8); simple induction 1.
-    intros.
-    generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b).
-    intro.
-    generalize H10.
-    rewrite H12; intro.
-    generalize (app_inj_tail _ _ _ _ H13); simple induction 1.
-    intros.
-    rewrite <- H11; rewrite <- H16; auto with sets.
+      (P := 
+        fun x : List =>
+        forall a b : A, Descl (b :: x ++ [a]) -> clos_refl_trans A leA a b);
+     intros.
+    - inversion H.
+      assert ([b; a] = ([] ++ [b]) ++ [a]) by auto with sets.
+      destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)/app_inj_tail, <-).
+      inversion H1; subst; [ apply rt_step; assumption | apply rt_refl ].
+    - inversion H0.
+      + apply app_cons_not_nil in H3 as ().
+      + rewrite app_comm_cons in H0, H1. apply desc_prefix in H0.
+        pose proof (H x0 b H0).
+        apply rt_trans with (y := x0); auto with sets.
+        enough (H5 : clos_refl A leA a x0)
+         by (inversion H5; subst; [ apply rt_step | apply rt_refl ];
+              assumption).
+        apply app_inj_tail in H1 as (H1, ->).
+        rewrite app_comm_cons in H1.
+        apply app_inj_tail in H1 as (_, <-).
+        assumption.
   Qed.
 
 
   Lemma dist_aux :
-    forall z:List, Descl z -> forall x y:List, z = x ++ y -> Descl x /\ Descl y.
+    forall z : List,
+      Descl z -> forall x y : List, z = x ++ y -> Descl x /\ Descl y.
   Proof.
     intros z D.
-    elim D.
-    intros.
-    cut (x ++ y = Nil); auto with sets; intro.
-    generalize (app_eq_nil _ _ H0); simple induction 1.
-    intros.
-    rewrite H2; rewrite H3; split; apply d_nil.
-
-    intros.
-    cut (x0 ++ y = Cons x Nil); auto with sets.
-    intros E.
-    generalize (app_eq_unit _ _ E); simple induction 1.
-    simple induction 1; intros.
-    rewrite H2; rewrite H3; split.
-    apply d_nil.
-
-    apply d_one.
-
-    simple induction 1; intros.
-    rewrite H2; rewrite H3; split.
-    apply d_one.
-
-    apply d_nil.
-
-    do 5 intro.
-    intros Hind.
-    do 2 intro.
-    generalize x0.
-    apply rev_ind with
-      (A := A)
-      (P := fun y0:List =>
-        forall x0:List,
-          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 ->
-          Descl x0 /\ Descl y0).
-
-    intro.
-    generalize (app_nil_end x1); simple induction 1; simple induction 1.
-    split. apply d_conc; auto with sets.
-
-    apply d_nil.
-
-    do 3 intro.
-    generalize x1.
-    apply rev_ind with
-      (A := A)
-      (P := fun l0:List =>
-        forall (x1:A) (x0:List),
-          (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ l0 ++ Cons x1 Nil ->
-          Descl x0 /\ Descl (l0 ++ Cons x1 Nil)).
-
-
-    simpl.
-    split.
-    generalize (app_inj_tail _ _ _ _ H2); simple induction 1.
-    simple induction 1; auto with sets.
-
-    apply d_one.
-    do 5 intro.
-    generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)).
-    simple induction 1.
-    generalize (app_ass x4 l1 (Cons x2 Nil)); simple induction 1.
-    intro E.
-    generalize (app_inj_tail _ _ _ _ E).
-    simple induction 1; intros.
-    generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros.
-    rewrite <- H7; rewrite <- H10; generalize H6.
-    generalize (app_ass x4 l1 (Cons x2 Nil)); intro E1.
-    rewrite E1.
-    intro.
-    generalize (Hind x4 (l1 ++ Cons x2 Nil) H11).
-    simple induction 1; split.
-    auto with sets.
-
-    generalize H14.
-    rewrite <- H10; intro.
-    apply d_conc; auto with sets.
+    induction D as [| | * H D Hind]; intros.
+    - assert (H0 : x ++ y = []) by auto with sets.
+      apply app_eq_nil in H0 as (->, ->).
+      split; apply d_nil.
+    - assert (E : x0 ++ y = [x]) by auto with sets.
+      apply app_eq_unit in E as [(->, ->)| (->, ->)].
+      + split.
+        apply d_nil.
+        apply d_one.
+      + split.
+        apply d_one.
+        apply d_nil.
+    - induction y0 using rev_ind in x0, H0 |- *.
+      + rewrite <- app_nil_end in H0.
+        rewrite <- H0.
+        split.
+        apply d_conc; auto with sets.
+        apply d_nil.
+      + induction y0 using rev_ind in x1, x0, H0 |- *.
+        * simpl.
+          split.
+          apply app_inj_tail in H0 as (<-, _). assumption.
+          apply d_one.
+        * rewrite <- 2!app_assoc_reverse in H0.
+          apply app_inj_tail in H0 as (H0, <-).
+          pose proof H0 as H0'.
+          apply app_inj_tail in H0' as (_, ->).
+          rewrite app_assoc_reverse in H0.
+          apply Hind in H0 as ().
+          split.
+          assumption.
+          apply d_conc; auto with sets.
   Qed.
 
 
 
   Lemma dist_Desc_concat :
-    forall x y:List, Descl (x ++ y) -> Descl x /\ Descl y.
+    forall x y : List, Descl (x ++ y) -> Descl x /\ Descl y.
   Proof.
     intros.
     apply (dist_aux (x ++ y) H x y); auto with sets.
   Qed.
 
   Lemma desc_end :
-    forall (a b:A) (x:List),
-      Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) ->
-      clos_trans A leA a b.
+    forall (a b : A) (x : List),
+      Descl (x ++ [a]) /\ ltl (x ++ [a]) [b] -> clos_trans A leA a b.
   Proof.
     intros a b x.
     case x.
@@ -246,11 +173,11 @@ Section Wf_Lexicographic_Exponentiation.
     inversion H3.
 
     simple induction 1.
-    generalize (app_comm_cons l (Cons a Nil) a0).
+    generalize (app_comm_cons l [a] a0).
     intros E; rewrite <- E; intros.
     generalize (desc_tail l a a0 H0); intro.
     inversion H1.
-    apply t_trans with (y := a0); auto with sets.
+    eapply clos_rt_t; [ eassumption | apply t_step; assumption ].
 
     inversion H4.
   Qed.
@@ -259,9 +186,8 @@ Section Wf_Lexicographic_Exponentiation.
 
 
   Lemma ltl_unit :
-    forall (x:List) (a b:A),
-      Descl (x ++ Cons a Nil) ->
-      ltl (x ++ Cons a Nil) (Cons b Nil) -> ltl x (Cons b Nil).
+    forall (x : List) (a b : A),
+      Descl (x ++ [a]) -> ltl (x ++ [a]) [b] -> ltl x [b].
   Proof.
     intro.
     case x.
@@ -276,9 +202,10 @@ Section Wf_Lexicographic_Exponentiation.
 
 
   Lemma acc_app :
-    forall (x1 x2:List) (y1:Descl (x1 ++ x2)),
+    forall (x1 x2 : List) (y1 : Descl (x1 ++ x2)),
       Acc Lex_Exp << x1 ++ x2, y1 >> ->
-      forall (x:List) (y:Descl x), ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
+      forall (x : List) (y : Descl x),
+        ltl x (x1 ++ x2) -> Acc Lex_Exp << x, y >>.
   Proof.
     intros.
     apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)).
@@ -297,8 +224,10 @@ Section Wf_Lexicographic_Exponentiation.
     unfold lex_exp at 1; simpl.
     apply rev_ind with
       (A := A)
-      (P := fun x:List =>
-	forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>).
+      (P := 
+        fun x : List =>
+        forall (x0 : List) (y : Descl x0),
+          ltl x0 x -> Acc Lex_Exp << x0, y >>).
     intros.
     inversion_clear H0.
 
@@ -306,14 +235,15 @@ Section Wf_Lexicographic_Exponentiation.
     generalize (well_founded_ind (wf_clos_trans A leA H)).
     intros GR.
     apply GR with
-      (P := fun x0:A =>
-        forall l:List,
-          (forall (x1:List) (y:Descl x1),
-            ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
-          forall (x1:List) (y:Descl x1),
-            ltl x1 (l ++ Cons x0 Nil) -> Acc Lex_Exp << x1, y >>).
+      (P := 
+        fun x0 : A =>
+        forall l : List,
+          (forall (x1 : List) (y : Descl x1),
+             ltl x1 l -> Acc Lex_Exp << x1, y >>) ->
+          forall (x1 : List) (y : Descl x1),
+            ltl x1 (l ++ [x0]) -> Acc Lex_Exp << x1, y >>).
     intro; intros HInd; intros.
-    generalize (right_prefix x2 l (Cons x1 Nil) H1).
+    generalize (right_prefix x2 l [x1] H1).
     simple induction 1.
     intro; apply (H0 x2 y1 H3).
 
@@ -324,9 +254,10 @@ Section Wf_Lexicographic_Exponentiation.
     rewrite H2.
     apply rev_ind with
       (A := A)
-      (P := fun x3:List =>
-        forall y1:Descl (l ++ x3),
-          ltl x3 (Cons x1 Nil) -> Acc Lex_Exp << l ++ x3, y1 >>).
+      (P := 
+        fun x3 : List =>
+        forall y1 : Descl (l ++ x3),
+          ltl x3 [x1] -> Acc Lex_Exp << l ++ x3, y1 >>).
     intros.
     generalize (app_nil_end l); intros Heq.
     generalize y1.
@@ -340,15 +271,15 @@ Section Wf_Lexicographic_Exponentiation.
     apply (H0 x4 y3); auto with sets.
 
     intros.
-    generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1).
+    generalize (dist_Desc_concat l (l0 ++ [x4]) y1).
     simple induction 1.
     intros.
     generalize (desc_end x4 x1 l0 (conj H8 H5)); intros.
     generalize y1.
-    rewrite <- (app_ass l l0 (Cons x4 Nil)); intro.
+    rewrite <- (app_assoc_reverse l l0 [x4]); intro.
     generalize (HInd x4 H9 (l ++ l0)); intros HInd2.
     generalize (ltl_unit l0 x4 x1 H8 H5); intro.
-    generalize (dist_Desc_concat (l ++ l0) (Cons x4 Nil) y2).
+    generalize (dist_Desc_concat (l ++ l0) [x4] y2).
     simple induction 1; intros.
     generalize (H4 H12 H10); intro.
     generalize (Acc_inv H14).
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index 7e3035d0..0d8ed8dd 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -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/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index 9e0b22f2..b76e9661 100644
--- a/theories/Wellfounded/Transitive_Closure.v
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -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/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index c5b2d53e..b2e8ea92 100644
--- a/theories/Wellfounded/Union.v
+++ b/theories/Wellfounded/Union.v
@@ -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/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index 56b8f985..f8a17b56 100644
--- a/theories/Wellfounded/Well_Ordering.v
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -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/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index 971c589e..a76d5e95 100644
--- a/theories/Wellfounded/Wellfounded.v
+++ b/theories/Wellfounded/Wellfounded.v
@@ -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/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index f238ef6e..cb0c6880 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -1,14 +1,14 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
 Require Export BinNums BinPos Pnat.
-Require Import BinNat Bool Plus Mult Equalities GenericMinMax
+Require Import BinNat Bool Equalities GenericMinMax
  OrdersFacts ZAxioms ZProperties.
 Require BinIntDef.
 
@@ -73,6 +73,23 @@ Proof.
  decide equality; apply Pos.eq_dec.
 Defined.
 
+(** * Proofs of morphisms, obvious since eq is Leibniz *)
+
+Local Obligation Tactic := simpl_relation.
+Program Definition succ_wd : Proper (eq==>eq) succ := _.
+Program Definition pred_wd : Proper (eq==>eq) pred := _.
+Program Definition opp_wd : Proper (eq==>eq) opp := _.
+Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
+Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
+Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
+Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
+Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
+Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
+Program Definition quot_wd : Proper (eq==>eq==>eq) quot := _.
+Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _.
+Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
+Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
+
 (** * Properties of [pos_sub] *)
 
 (** [pos_sub] can be written in term of positive comparison
@@ -138,15 +155,23 @@ Qed.
 
 Module Import Private_BootStrap.
 
-(** * Properties of addition *)
-
-(** ** Zero is neutral for addition *)
+(** ** Operations and constants *)
 
 Lemma add_0_r n : n + 0 = n.
 Proof.
  now destruct n.
 Qed.
 
+Lemma mul_0_r n : n * 0 = 0.
+Proof.
+ now destruct n.
+Qed.
+
+Lemma mul_1_l n : 1 * n = n.
+Proof.
+ now destruct n.
+Qed.
+
 (** ** Addition is commutative *)
 
 Lemma add_comm n m : n + m = m + n.
@@ -196,28 +221,25 @@ Proof.
    symmetry. now apply Pos.add_sub_assoc.
 Qed.
 
-Lemma add_assoc n m p : n + (m + p) = n + m + p.
+Local Arguments add !x !y.
+
+Lemma add_assoc_pos p n m : pos p + (n + m) = pos p + n + m.
 Proof.
- assert (AUX : forall x y z, pos x + (y + z) = pos x + y + z).
- { intros x [|y|y] [|z|z]; rewrite ?add_0_r; trivial.
-   - simpl. now rewrite Pos.add_assoc.
-   - simpl (_ + neg _). symmetry. apply pos_sub_add.
-   - simpl (neg _ + _); simpl (_ + neg _).
-     now rewrite (add_comm _ (pos _)), <- 2 pos_sub_add, Pos.add_comm.
-   - apply opp_inj. rewrite !opp_add_distr. simpl opp.
-     simpl (neg _ + _); simpl (_ + neg _).
-     rewrite add_comm, Pos.add_comm. apply pos_sub_add. }
- destruct n.
- - trivial.
- - apply AUX.
- - apply opp_inj. rewrite !opp_add_distr. simpl opp. apply AUX.
+ destruct n as [|n|n], m as [|m|m]; simpl; trivial.
+ - now rewrite Pos.add_assoc.
+ - symmetry. apply pos_sub_add.
+ - symmetry. apply add_0_r.
+ - now rewrite <- pos_sub_add, add_comm, <- pos_sub_add, Pos.add_comm.
+ - apply opp_inj. rewrite !opp_add_distr, !pos_sub_opp.
+   rewrite add_comm, Pos.add_comm. apply pos_sub_add.
 Qed.
 
-(** ** Subtraction and successor *)
-
-Lemma sub_succ_l n m : succ n - m = succ (n - m).
+Lemma add_assoc n m p : n + (m + p) = n + m + p.
 Proof.
- unfold sub, succ. now rewrite <- 2 add_assoc, (add_comm 1).
+ destruct n.
+ - trivial.
+ - apply add_assoc_pos.
+ - apply opp_inj. rewrite !opp_add_distr. simpl. apply add_assoc_pos.
 Qed.
 
 (** ** Opposite is inverse for addition *)
@@ -227,132 +249,34 @@ Proof.
  destruct n; simpl; trivial; now rewrite pos_sub_diag.
 Qed.
 
-Lemma add_opp_diag_l n : - n + n = 0.
-Proof.
- rewrite add_comm. apply add_opp_diag_r.
-Qed.
-
-(** ** Commutativity of multiplication *)
-
-Lemma mul_comm n m : n * m = m * n.
-Proof.
- destruct n, m; simpl; trivial; f_equal; apply Pos.mul_comm.
-Qed.
-
-(** ** Associativity of multiplication *)
-
-Lemma mul_assoc n m p : n * (m * p) = n * m * p.
-Proof.
- destruct n, m, p; simpl; trivial; f_equal; apply Pos.mul_assoc.
-Qed.
-
-(** Multiplication and constants *)
-
-Lemma mul_1_l n : 1 * n = n.
-Proof.
- now destruct n.
-Qed.
-
-Lemma mul_1_r n : n * 1 = n.
-Proof.
- destruct n; simpl; now rewrite ?Pos.mul_1_r.
-Qed.
-
 (** ** Multiplication and Opposite *)
 
-Lemma mul_opp_l n m : - n * m = - (n * m).
-Proof.
- now destruct n, m.
-Qed.
-
 Lemma mul_opp_r n m : n * - m = - (n * m).
 Proof.
  now destruct n, m.
 Qed.
 
-Lemma mul_opp_opp n m : - n * - m = n * m.
-Proof.
- now destruct n, m.
-Qed.
-
-Lemma mul_opp_comm n m : - n * m = n * - m.
-Proof.
- now destruct n, m.
-Qed.
-
 (** ** Distributivity of multiplication over addition *)
 
 Lemma mul_add_distr_pos (p:positive) n m :
- pos p * (n + m) = pos p * n + pos p * m.
-Proof.
- destruct n as [|n|n], m as [|m|m]; simpl; trivial;
- rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_l; try case Pos.compare_spec;
- intros; now rewrite ?Pos.mul_add_distr_l, ?Pos.mul_sub_distr_l.
-Qed.
-
-Lemma mul_add_distr_l n m p : n * (m + p) = n * m + n * p.
+ (n + m) * pos p = n * pos p + m * pos p.
 Proof.
- destruct n as [|n|n]. trivial.
- apply mul_add_distr_pos.
- change (neg n) with (- pos n).
- rewrite !mul_opp_l, <- opp_add_distr. f_equal.
- apply mul_add_distr_pos.
+ destruct n as [|n|n], m as [|m|m]; simpl; trivial.
+ - now rewrite Pos.mul_add_distr_r.
+ - rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_r; case Pos.compare_spec;
+   simpl; trivial; intros; now rewrite Pos.mul_sub_distr_r.
+ - rewrite ?pos_sub_spec, ?Pos.mul_compare_mono_r; case Pos.compare_spec;
+   simpl; trivial; intros; now rewrite Pos.mul_sub_distr_r.
+ - now rewrite Pos.mul_add_distr_r.
 Qed.
 
 Lemma mul_add_distr_r n m p : (n + m) * p = n * p + m * p.
 Proof.
- rewrite !(mul_comm _ p). apply mul_add_distr_l.
-Qed.
-
-(** ** Basic properties of divisibility *)
-
-Lemma divide_Zpos p q : (pos p|pos q) <-> (p|q)%positive.
-Proof.
- split.
- intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto.
- intros (r,H). exists (pos r); simpl; now f_equal.
-Qed.
-
-Lemma divide_Zpos_Zneg_r n p : (n|pos p) <-> (n|neg p).
-Proof.
- split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H.
-Qed.
-
-Lemma divide_Zpos_Zneg_l n p : (pos p|n) <-> (neg p|n).
-Proof.
- split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r.
-Qed.
-
-(** ** Conversions between [Z.testbit] and [N.testbit] *)
-
-Lemma testbit_of_N a n :
- testbit (of_N a) (of_N n) = N.testbit a n.
-Proof.
- destruct a as [|a], n; simpl; trivial. now destruct a.
-Qed.
-
-Lemma testbit_of_N' a n : 0<=n ->
- testbit (of_N a) n = N.testbit a (to_N n).
-Proof.
- intro Hn. rewrite <- testbit_of_N. f_equal.
- destruct n; trivial; now destruct Hn.
-Qed.
-
-Lemma testbit_Zpos a n : 0<=n ->
- testbit (pos a) n = N.testbit (N.pos a) (to_N n).
-Proof.
- intro Hn. now rewrite <- testbit_of_N'.
-Qed.
-
-Lemma testbit_Zneg a n : 0<=n ->
- testbit (neg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)).
-Proof.
- intro Hn.
- rewrite <- testbit_of_N' by trivial.
- destruct n as [ |n|n];
-  [ | simpl; now destruct (Pos.pred_N a) | now destruct Hn].
- unfold testbit.
- now destruct a as [|[ | | ]| ].
+ destruct p as [|p|p].
+ - now rewrite !mul_0_r.
+ - apply mul_add_distr_pos.
+ - apply opp_inj. rewrite opp_add_distr, <- !mul_opp_r.
+   apply mul_add_distr_pos.
 Qed.
 
 End Private_BootStrap.
@@ -397,6 +321,8 @@ Qed.
 
 (** ** Specification of successor and predecessor *)
 
+Local Arguments pos_sub : simpl nomatch.
+
 Lemma succ_pred n : succ (pred n) = n.
 Proof.
  unfold succ, pred. now rewrite <- add_assoc, add_opp_diag_r, add_0_r.
@@ -511,6 +437,45 @@ Proof.
  rewrite (compare_antisym n m). case compare_spec; intuition.
 Qed.
 
+(** ** Induction principles based on successor / predecessor *)
+
+Lemma peano_ind (P : Z -> Prop) :
+  P 0 ->
+  (forall x, P x -> P (succ x)) ->
+  (forall x, P x -> P (pred x)) ->
+  forall z, P z.
+Proof.
+ intros H0 Hs Hp z; destruct z.
+ assumption.
+ induction p using Pos.peano_ind.
+  now apply (Hs 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hs (pos p)).
+ induction p using Pos.peano_ind.
+  now apply (Hp 0).
+  rewrite <- Pos.add_1_r.
+  now apply (Hp (neg p)).
+Qed.
+
+Lemma bi_induction (P : Z -> Prop) :
+  Proper (eq ==> iff) P ->
+  P 0 ->
+  (forall x, P x <-> P (succ x)) ->
+  forall z, P z.
+Proof.
+ intros _ H0 Hs. induction z using peano_ind.
+ assumption.
+ now apply -> Hs.
+ apply Hs. now rewrite succ_pred.
+Qed.
+
+(** We can now derive all properties of basic functions and orders,
+    and use these properties for proving the specs of more advanced
+    functions. *)
+
+Include ZBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+
+
 (** ** Specification of absolute value *)
 
 Lemma abs_eq n : 0 <= n -> abs n = n.
@@ -693,7 +658,7 @@ Lemma div_eucl_eq a b : b<>0 ->
 Proof.
  destruct a as [ |a|a], b as [ |b|b]; unfold div_eucl; trivial;
   (now destruct 1) || intros _;
-  generalize (pos_div_eucl_eq a (pos b) (eq_refl _));
+  generalize (pos_div_eucl_eq a (pos b) Logic.eq_refl);
   destruct pos_div_eucl as (q,r); rewrite mul_comm.
  - (* pos pos *)
    trivial.
@@ -756,7 +721,7 @@ Proof.
  destruct a as [|a|a]; unfold modulo, div_eucl.
  now split.
  now apply pos_div_eucl_bound.
- generalize (pos_div_eucl_bound a (pos b) (eq_refl _)).
+ generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl).
  destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
  destruct r as [|r|r]; (now destruct Hr) || clear Hr.
  now split.
@@ -773,7 +738,7 @@ Proof.
  destruct b as [|b|b]; try easy; intros _.
  destruct a as [|a|a]; unfold modulo, div_eucl.
  now split.
- generalize (pos_div_eucl_bound a (pos b) (eq_refl _)).
+ generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl).
  destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
  destruct r as [|r|r]; (now destruct Hr) || clear Hr.
  now split.
@@ -783,7 +748,7 @@ Proof.
  change (neg b - neg r <= 0). unfold le, lt in *.
   rewrite <- compare_sub. simpl in *.
   now rewrite <- Pos.compare_antisym, Hr'.
- generalize (pos_div_eucl_bound a (pos b) (eq_refl _)).
+ generalize (pos_div_eucl_bound a (pos b) Logic.eq_refl).
  destruct pos_div_eucl as (q,r); unfold snd; intros (Hr,Hr').
  split; destruct r; try easy.
   red; simpl; now rewrite <- Pos.compare_antisym.
@@ -839,6 +804,25 @@ Proof. intros _. apply rem_opp_l'. Qed.
 Lemma rem_opp_r a b : b<>0 -> rem a (-b) = rem a b.
 Proof. intros _. apply rem_opp_r'. Qed.
 
+(** ** Extra properties about [divide] *)
+
+Lemma divide_Zpos p q : (pos p|pos q) <-> (p|q)%positive.
+Proof.
+ split.
+ intros ([ |r|r],H); simpl in *; destr_eq H. exists r; auto.
+ intros (r,H). exists (pos r); simpl; now f_equal.
+Qed.
+
+Lemma divide_Zpos_Zneg_r n p : (n|pos p) <-> (n|neg p).
+Proof.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- H.
+Qed.
+
+Lemma divide_Zpos_Zneg_l n p : (pos p|n) <-> (neg p|n).
+Proof.
+ split; intros (m,H); exists (-m); now rewrite mul_opp_l, <- mul_opp_r.
+Qed.
+
 (** ** Correctness proofs for gcd *)
 
 Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b.
@@ -898,6 +882,38 @@ Proof.
   destruct (Pos.ggcd a b) as (g,(aa,bb)); auto.
 Qed.
 
+(** ** Extra properties about [testbit] *)
+
+Lemma testbit_of_N a n :
+ testbit (of_N a) (of_N n) = N.testbit a n.
+Proof.
+ destruct a as [|a], n; simpl; trivial. now destruct a.
+Qed.
+
+Lemma testbit_of_N' a n : 0<=n ->
+ testbit (of_N a) n = N.testbit a (to_N n).
+Proof.
+ intro Hn. rewrite <- testbit_of_N. f_equal.
+ destruct n; trivial; now destruct Hn.
+Qed.
+
+Lemma testbit_Zpos a n : 0<=n ->
+ testbit (pos a) n = N.testbit (N.pos a) (to_N n).
+Proof.
+ intro Hn. now rewrite <- testbit_of_N'.
+Qed.
+
+Lemma testbit_Zneg a n : 0<=n ->
+ testbit (neg a) n = negb (N.testbit (Pos.pred_N a) (to_N n)).
+Proof.
+ intro Hn.
+ rewrite <- testbit_of_N' by trivial.
+ destruct n as [ |n|n];
+  [ | simpl; now destruct (Pos.pred_N a) | now destruct Hn].
+ unfold testbit.
+ now destruct a as [|[ | | ]| ].
+Qed.
+
 (** ** Proofs of specifications for bitwise operations *)
 
 Lemma div2_spec a : div2 a = shiftr a 1.
@@ -959,7 +975,7 @@ Proof.
   destruct m; easy || now destruct Hm.
  destruct a as [ |a|a].
  (* a = 0 *)
- replace (Pos.iter n div2 0) with 0
+ replace (Pos.iter div2 0 n) with 0
   by (apply Pos.iter_invariant; intros; subst; trivial).
  now rewrite 2 testbit_0_l.
  (* a > 0 *)
@@ -982,7 +998,7 @@ Proof.
   rewrite ?Pos.iter_succ; apply testbit_even_0.
  destruct a as [ |a|a].
  (* a = 0 *)
- replace (Pos.iter n (mul 2) 0) with 0
+ replace (Pos.iter (mul 2) 0 n) with 0
   by (apply Pos.iter_invariant; intros; subst; trivial).
  apply testbit_0_l.
  (* a > 0 *)
@@ -1013,7 +1029,7 @@ Proof.
   f_equal. now rewrite Pos.add_comm, Pos.add_sub.
  destruct a; unfold shiftl.
  (* ... a = 0 *)
- replace (Pos.iter n (mul 2) 0) with 0
+ replace (Pos.iter (mul 2) 0 n) with 0
   by (apply Pos.iter_invariant; intros; subst; trivial).
  now rewrite 2 testbit_0_l.
  (* ... a > 0 *)
@@ -1103,61 +1119,10 @@ Proof.
  now rewrite N.lxor_spec, xorb_negb_negb.
 Qed.
 
-(** ** Induction principles based on successor / predecessor *)
 
-Lemma peano_ind (P : Z -> Prop) :
-  P 0 ->
-  (forall x, P x -> P (succ x)) ->
-  (forall x, P x -> P (pred x)) ->
-  forall z, P z.
-Proof.
- intros H0 Hs Hp z; destruct z.
- assumption.
- induction p using Pos.peano_ind.
-  now apply (Hs 0).
-  rewrite <- Pos.add_1_r.
-  now apply (Hs (pos p)).
- induction p using Pos.peano_ind.
-  now apply (Hp 0).
-  rewrite <- Pos.add_1_r.
-  now apply (Hp (neg p)).
-Qed.
+(** Generic properties of advanced functions. *)
 
-Lemma bi_induction (P : Z -> Prop) :
-  Proper (eq ==> iff) P ->
-  P 0 ->
-  (forall x, P x <-> P (succ x)) ->
-  forall z, P z.
-Proof.
- intros _ H0 Hs. induction z using peano_ind.
- assumption.
- now apply -> Hs.
- apply Hs. now rewrite succ_pred.
-Qed.
-
-
-(** * Proofs of morphisms, obvious since eq is Leibniz *)
-
-Local Obligation Tactic := simpl_relation.
-Program Definition succ_wd : Proper (eq==>eq) succ := _.
-Program Definition pred_wd : Proper (eq==>eq) pred := _.
-Program Definition opp_wd : Proper (eq==>eq) opp := _.
-Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
-Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
-Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
-Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
-Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
-Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
-Program Definition quot_wd : Proper (eq==>eq==>eq) quot := _.
-Program Definition rem_wd : Proper (eq==>eq==>eq) rem := _.
-Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
-Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.
-
-(** The Bind Scope prevents Z to stay associated with abstract_scope.
-    (TODO FIX) *)
-
-Include ZProp. Bind Scope Z_scope with Z.
-Include UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.
+Include ZExtraProp.
 
 (** In generic statements, the predicates [lt] and [le] have been
   favored, whereas [gt] and [ge] don't even exist in the abstract
@@ -1277,6 +1242,8 @@ Qed.
 
 End Z.
 
+Bind Scope Z_scope with Z.t Z.
+
 (** Re-export Notations *)
 
 Infix "+" := Z.add : Z_scope.
@@ -1394,11 +1361,11 @@ Lemma inj_gcd p q : Z.pos (Pos.gcd p q) = Z.gcd (Z.pos p) (Z.pos q).
 Proof. reflexivity. Qed.
 
 Definition inj_divide p q : (Z.pos p|Z.pos q) <-> (p|q)%positive.
-Proof. apply Z.Private_BootStrap.divide_Zpos. Qed.
+Proof. apply Z.divide_Zpos. Qed.
 
 Lemma inj_testbit a n : 0<=n ->
  Z.testbit (Z.pos a) n = N.testbit (N.pos a) (Z.to_N n).
-Proof. apply Z.Private_BootStrap.testbit_Zpos. Qed.
+Proof. apply Z.testbit_Zpos. Qed.
 
 (** Some results concerning Z.neg *)
 
@@ -1436,14 +1403,14 @@ Lemma add_neg_pos p q : Z.neg p + Z.pos q = Z.pos_sub q p.
 Proof. reflexivity. Qed.
 
 Lemma divide_pos_neg_r n p : (n|Z.pos p) <-> (n|Z.neg p).
-Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_r. Qed.
+Proof. apply Z.divide_Zpos_Zneg_r. Qed.
 
 Lemma divide_pos_neg_l n p : (Z.pos p|n) <-> (Z.neg p|n).
-Proof. apply Z.Private_BootStrap.divide_Zpos_Zneg_l. Qed.
+Proof. apply Z.divide_Zpos_Zneg_l. Qed.
 
 Lemma testbit_neg a n : 0<=n ->
  Z.testbit (Z.neg a) n = negb (N.testbit (Pos.pred_N a) (Z.to_N n)).
-Proof. apply Z.Private_BootStrap.testbit_Zneg. Qed.
+Proof. apply Z.testbit_Zneg. Qed.
 
 End Pos2Z.
 
diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v
index 00387eec..9bb86fd5 100644
--- a/theories/ZArith/BinIntDef.v
+++ b/theories/ZArith/BinIntDef.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -126,7 +126,7 @@ Infix "*" := mul : Z_scope.
 
 (** ** Power function *)
 
-Definition pow_pos (z:Z) (n:positive) := Pos.iter n (mul z) 1.
+Definition pow_pos (z:Z) := Pos.iter (mul z) 1.
 
 Definition pow x y :=
   match y with
@@ -306,7 +306,7 @@ Definition to_pos (z:Z) : positive :=
 
 Definition iter (n:Z) {A} (f:A -> A) (x:A) :=
   match n with
-    | pos p => Pos.iter p f x
+    | pos p => Pos.iter f x p
     | _ => x
   end.
 
@@ -568,8 +568,8 @@ Definition testbit a n :=
 Definition shiftl a n :=
  match n with
    | 0 => a
-   | pos p => Pos.iter p (mul 2) a
-   | neg p => Pos.iter p div2 a
+   | pos p => Pos.iter (mul 2) a p
+   | neg p => Pos.iter div2 a p
  end.
 
 Definition shiftr a n := shiftl a (-n).
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index 5350f86d..09909bdb 100644
--- a/theories/ZArith/Wf_Z.v
+++ b/theories/ZArith/Wf_Z.v
@@ -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        *)
@@ -151,9 +151,7 @@ Section Efficient_Rec.
     forall P:Z -> Prop,
       (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> 0 <= x -> P x) ->
       forall x:Z, 0 <= x -> P x.
-  Proof.
-    exact Zlt_0_rec.
-  Qed.
+  Proof. intros; now apply Zlt_0_rec. Qed.
 
   (** Obsolete version of [Z.lt] induction principle on non-negative numbers *)
 
@@ -170,7 +168,7 @@ Section Efficient_Rec.
       (forall x:Z, (forall y:Z, 0 <= y < x -> P y) -> P x) ->
       forall x:Z, 0 <= x -> P x.
   Proof.
-    exact Z_lt_rec.
+    intros; now apply Z_lt_rec.
   Qed.
 
   (** An even more general induction principle using [Z.lt]. *)
@@ -196,7 +194,7 @@ Section Efficient_Rec.
       (forall x:Z, (forall y:Z, z <= y < x -> P y) -> z <= x -> P x) ->
       forall x:Z, z <= x -> P x.
   Proof.
-    exact Zlt_lower_bound_rec.
+    intros; now apply Zlt_lower_bound_rec with z.
   Qed.
 
 End Efficient_Rec.
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
index e9cac8e1..04cccd04 100644
--- a/theories/ZArith/ZArith.v
+++ b/theories/ZArith/ZArith.v
@@ -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/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
index 0891c60a..4c93173b 100644
--- a/theories/ZArith/ZArith_base.v
+++ b/theories/ZArith/ZArith_base.v
@@ -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/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
index e392c8b3..ac69cebd 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -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/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v
deleted file mode 100644
index 9fe3a365..00000000
--- a/theories/ZArith/ZOdiv.v
+++ /dev/null
@@ -1,88 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-Require Export ZOdiv_def.
-Require Import BinInt Zquot.
-
-Notation ZO_div_mod_eq := Z.quot_rem' (only parsing).
-Notation ZOmod_lt := Zrem_lt (only parsing).
-Notation ZOmod_sgn := Zrem_sgn (only parsing).
-Notation ZOmod_sgn2 := Zrem_sgn2 (only parsing).
-Notation ZOmod_lt_pos := Zrem_lt_pos (only parsing).
-Notation ZOmod_lt_neg := Zrem_lt_neg (only parsing).
-Notation ZOmod_lt_pos_pos := Zrem_lt_pos_pos (only parsing).
-Notation ZOmod_lt_pos_neg := Zrem_lt_pos_neg (only parsing).
-Notation ZOmod_lt_neg_pos := Zrem_lt_neg_pos (only parsing).
-Notation ZOmod_lt_neg_neg := Zrem_lt_neg_neg (only parsing).
-
-Notation ZOdiv_opp_l := Zquot_opp_l (only parsing).
-Notation ZOdiv_opp_r := Zquot_opp_r (only parsing).
-Notation ZOmod_opp_l := Zrem_opp_l (only parsing).
-Notation ZOmod_opp_r := Zrem_opp_r (only parsing).
-Notation ZOdiv_opp_opp := Zquot_opp_opp (only parsing).
-Notation ZOmod_opp_opp := Zrem_opp_opp (only parsing).
-
-Notation Remainder := Remainder (only parsing).
-Notation Remainder_alt := Remainder_alt (only parsing).
-Notation Remainder_equiv := Remainder_equiv (only parsing).
-Notation ZOdiv_mod_unique_full := Zquot_mod_unique_full (only parsing).
-Notation ZOdiv_unique_full := Zquot_unique_full (only parsing).
-Notation ZOdiv_unique := Zquot_unique (only parsing).
-Notation ZOmod_unique_full := Zrem_unique_full (only parsing).
-Notation ZOmod_unique := Zrem_unique (only parsing).
-
-Notation ZOmod_0_l := Zrem_0_l (only parsing).
-Notation ZOmod_0_r := Zrem_0_r (only parsing).
-Notation ZOdiv_0_l := Zquot_0_l (only parsing).
-Notation ZOdiv_0_r := Zquot_0_r (only parsing).
-Notation ZOmod_1_r := Zrem_1_r (only parsing).
-Notation ZOdiv_1_r := Zquot_1_r (only parsing).
-Notation ZOdiv_1_l := Zquot_1_l (only parsing).
-Notation ZOmod_1_l := Zrem_1_l (only parsing).
-Notation ZO_div_same := Z_quot_same (only parsing).
-Notation ZO_mod_same := Z_rem_same (only parsing).
-Notation ZO_mod_mult := Z_rem_mult (only parsing).
-Notation ZO_div_mult := Z_quot_mult (only parsing).
-
-Notation ZO_div_pos := Z_quot_pos (only parsing).
-Notation ZO_div_lt := Z_quot_lt (only parsing).
-Notation ZOdiv_small := Zquot_small (only parsing).
-Notation ZOmod_small := Zrem_small (only parsing).
-Notation ZO_div_monotone := Z_quot_monotone (only parsing).
-Notation ZO_mult_div_le := Z_mult_quot_le (only parsing).
-Notation ZO_mult_div_ge := Z_mult_quot_ge (only parsing).
-Definition ZO_div_exact_full_1 a b := proj1 (Z_quot_exact_full a b).
-Definition ZO_div_exact_full_2 a b := proj2 (Z_quot_exact_full a b).
-Notation ZOmod_le := Zrem_le (only parsing).
-Notation ZOdiv_le_upper_bound := Zquot_le_upper_bound (only parsing).
-Notation ZOdiv_lt_upper_bound := Zquot_lt_upper_bound (only parsing).
-Notation ZOdiv_le_lower_bound := Zquot_le_lower_bound (only parsing).
-Notation ZOdiv_sgn := Zquot_sgn (only parsing).
-
-Notation ZO_mod_plus := Z_rem_plus (only parsing).
-Notation ZO_div_plus := Z_quot_plus (only parsing).
-Notation ZO_div_plus_l := Z_quot_plus_l (only parsing).
-Notation ZOdiv_mult_cancel_r := Zquot_mult_cancel_r (only parsing).
-Notation ZOdiv_mult_cancel_l := Zquot_mult_cancel_l (only parsing).
-Notation ZOmult_mod_distr_l := Zmult_rem_distr_l (only parsing).
-Notation ZOmult_mod_distr_r := Zmult_rem_distr_r (only parsing).
-Notation ZOmod_mod := Zrem_rem (only parsing).
-Notation ZOmult_mod := Zmult_rem (only parsing).
-Notation ZOplus_mod := Zplus_rem (only parsing).
-Notation ZOplus_mod_idemp_l := Zplus_rem_idemp_l (only parsing).
-Notation ZOplus_mod_idemp_r := Zplus_rem_idemp_r (only parsing).
-Notation ZOmult_mod_idemp_l := Zmult_rem_idemp_l (only parsing).
-Notation ZOmult_mod_idemp_r := Zmult_rem_idemp_r (only parsing).
-Notation ZOdiv_ZOdiv := Zquot_Zquot (only parsing).
-Notation ZOdiv_mult_le := Zquot_mult_le (only parsing).
-Notation ZOmod_divides := Zrem_divides (only parsing).
-
-Notation ZOdiv_eucl_Zdiv_eucl_pos := Zquotrem_Zdiv_eucl_pos (only parsing).
-Notation ZOdiv_Zdiv_pos := Zquot_Zdiv_pos (only parsing).
-Notation ZOmod_Zmod_pos := Zrem_Zmod_pos (only parsing).
-Notation ZOmod_Zmod_zero := Zrem_Zmod_zero (only parsing).
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
index aa3d1188..146009bc 100644
--- a/theories/ZArith/Zabs.v
+++ b/theories/ZArith/Zabs.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
index 81e52728..61eb2a34 100644
--- a/theories/ZArith/Zbool.v
+++ b/theories/ZArith/Zbool.v
@@ -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/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v
index 6aa26d19..d4ac72e9 100644
--- a/theories/ZArith/Zcompare.v
+++ b/theories/ZArith/Zcompare.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index dceac4f2..9604a06e 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -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        *)
@@ -53,17 +53,18 @@ Theorem Z_lt_abs_rec :
     forall n:Z, P n.
 Proof.
   intros P HP p.
-  set (Q := fun z => 0 <= z -> P z * P (- z)) in *.
-  cut (Q (Z.abs p)); [ intros | apply (Z_lt_rec Q); auto with zarith ].
-  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
-  unfold Q; clear Q; intros.
+  set (Q := fun z => 0 <= z -> P z * P (- z)).
+  enough (H:Q (Z.abs p)) by
+    (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
+  apply (Z_lt_rec Q); auto with zarith.
+  subst Q; intros x H.
   split; apply HP.
-  rewrite Z.abs_eq; auto; intros.
-  elim (H (Z.abs m)); intros; auto with zarith.
-  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-  rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
-  elim (H (Z.abs m)); intros; auto with zarith.
-  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  - rewrite Z.abs_eq; auto; intros.
+    destruct (H (Z.abs m)); auto with zarith.
+    destruct (Zabs_dec m) as [-> | ->]; trivial.
+  - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
+    destruct (H (Z.abs m)); auto with zarith.
+    destruct (Zabs_dec m) as [-> | ->]; trivial.
 Qed.
 
 Theorem Z_lt_abs_induction :
@@ -73,16 +74,17 @@ Theorem Z_lt_abs_induction :
 Proof.
   intros P HP p.
   set (Q := fun z => 0 <= z -> P z /\ P (- z)) in *.
-  cut (Q (Z.abs p)); [ intros | apply (Z_lt_induction Q); auto with zarith ].
-  elim (Zabs_dec p); intro eq; rewrite eq; elim H; auto with zarith.
-  unfold Q; clear Q; intros.
+  enough (Q (Z.abs p)) by
+    (destruct (Zabs_dec p) as [-> | ->]; elim H; auto with zarith).
+  apply (Z_lt_induction Q); auto with zarith.
+  subst Q; intros.
   split; apply HP.
-  rewrite Z.abs_eq; auto; intros.
-  elim (H (Z.abs m)); intros; auto with zarith.
-  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
-  rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
-  elim (H (Z.abs m)); intros; auto with zarith.
-  elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  - rewrite Z.abs_eq; auto; intros.
+    elim (H (Z.abs m)); intros; auto with zarith.
+    elim (Zabs_dec m); intro eq; rewrite eq; trivial.
+  - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros.
+    destruct (H (Z.abs m)); auto with zarith.
+    destruct (Zabs_dec m) as [-> | ->]; trivial.
 Qed.
 
 (** To do case analysis over the sign of [z] *)
diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v
index bf19c8ec..b5d04719 100644
--- a/theories/ZArith/Zdigits.v
+++ b/theories/ZArith/Zdigits.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -41,7 +41,7 @@ Section VALUE_OF_BOOLEAN_VECTORS.
 
   Lemma binary_value : forall n:nat, Bvector n -> Z.
   Proof.
-    simple induction n; intros.
+    refine (nat_rect _ _ _); intros.
     exact 0%Z.
 
     inversion H0.
@@ -152,7 +152,7 @@ Section Z_BRIC_A_BRAC.
   Lemma binary_value_pos :
     forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
   Proof.
-    induction bv as [| a n v IHbv]; simpl.
+    induction bv as [| a n v IHbv]; cbn.
     omega.
 
     destruct a; destruct (binary_value n v); simpl; auto.
@@ -212,14 +212,11 @@ Section Z_BRIC_A_BRAC.
       (z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z.
   Proof.
     intros.
-    cut (2 * Z.div2 z < 2 * two_power_nat n)%Z; intros.
-    omega.
-
+    enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by omega.
     rewrite <- two_power_nat_S.
-    destruct (Zeven.Zeven_odd_dec z); intros.
+    destruct (Zeven.Zeven_odd_dec z) as [Heven|Hodd]; intros.
     rewrite <- Zeven.Zeven_div2; auto.
-
-    generalize (Zeven.Zodd_div2 z z0); omega.
+    generalize (Zeven.Zodd_div2 z Hodd); omega.
   Qed.
 
   Lemma Z_to_two_compl_Sn_z :
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index 2e3a2280..d0d10891 100644
--- a/theories/ZArith/Zdiv.v
+++ b/theories/ZArith/Zdiv.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -666,24 +666,22 @@ Theorem Zdiv_eucl_extended :
       {qr : Z * Z | let (q, r) := qr in a = b * q + r /\ 0 <= r < Z.abs b}.
 Proof.
   intros b Hb a.
-  elim (Z_le_gt_dec 0 b); intro Hb'.
-  cut (b > 0); [ intro Hb'' | omega ].
-  rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
-  cut (- b > 0); [ intro Hb'' | omega ].
-  elim (Zdiv_eucl_exist Hb'' a); intros qr.
-  elim qr; intros q r Hqr.
-  exists (- q, r).
-  elim Hqr; intros.
-  split.
-  rewrite <- Z.mul_opp_comm; assumption.
-  rewrite Z.abs_neq; [ assumption | omega ].
+  destruct (Z_le_gt_dec 0 b) as [Hb'|Hb'].
+  - assert (Hb'' : b > 0) by omega.
+    rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ].
+  - assert (Hb'' : - b > 0) by omega.
+    destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]).
+    exists (- q, r).
+    split.
+    + rewrite <- Z.mul_opp_comm; assumption.
+    + rewrite Z.abs_neq; [ assumption | omega ].
 Qed.
 
 Arguments Zdiv_eucl_extended : default implicits.
 
 (** * Division and modulo in Z agree with same in nat: *)
 
-Require Import NPeano.
+Require Import PeanoNat.
 
 Lemma div_Zdiv (n m: nat): m <> O ->
   Z.of_nat (n / m) = Z.of_nat n / Z.of_nat m.
diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v
index 39e846a0..f5cacc7e 100644
--- a/theories/ZArith/Zeuclid.v
+++ b/theories/ZArith/Zeuclid.v
@@ -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/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
index c83a863f..d88bf7a9 100644
--- a/theories/ZArith/Zeven.v
+++ b/theories/ZArith/Zeven.v
@@ -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        *)
@@ -197,12 +197,14 @@ Qed.
 Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2.
 Proof.
  assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2).
- { intros m Hm.
+  {
+   intros m Hm.
    apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0).
    now apply Z.lt_le_incl.
    rewrite Z.sgn_pos by trivial.
    destruct (Z.odd m); now split.
-   apply Zquot2_odd_eqn. }
+   apply Zquot2_odd_eqn.
+  }
  destruct (Z.lt_trichotomy 0 n) as [POS|[NUL|NEG]].
  - now apply AUX.
  - now subst.
diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v
index 1e19479e..14286bde 100644
--- a/theories/ZArith/Zgcd_alt.v
+++ b/theories/ZArith/Zgcd_alt.v
@@ -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        *)
@@ -23,6 +23,7 @@ Require Import ZArith_base.
 Require Import ZArithRing.
 Require Import Zdiv.
 Require Import Znumtheory.
+Require Import Omega.
 
 Open Scope Z_scope.
 
@@ -104,8 +105,7 @@ Open Scope Z_scope.
 
  Lemma fibonacci_pos : forall n, 0 <= fibonacci n.
  Proof.
-   cut (forall N n, (n<N)%nat -> 0<=fibonacci n).
-   eauto.
+   enough (forall N n, (n<N)%nat -> 0<=fibonacci n) by eauto.
    induction N.
    inversion 1.
    intros.
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index 411fec67..1942c2ab 100644
--- a/theories/ZArith/Zhints.v
+++ b/theories/ZArith/Zhints.v
@@ -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/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
index 59c16469..6e349569 100644
--- a/theories/ZArith/Zlogarithm.v
+++ b/theories/ZArith/Zlogarithm.v
@@ -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        *)
@@ -59,7 +59,7 @@ Section Log_pos. (* Log of positive integers *)
 
   Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p.
   Proof.
-   induction p; simpl.
+   induction p; simpl log_sup.
    - change (Zpos p~1) with (2*(Zpos p)+1).
      rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy.
      unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc.
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
index 78091794..c436b3ad 100644
--- a/theories/ZArith/Zmax.v
+++ b/theories/ZArith/Zmax.v
@@ -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/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index 98282b38..1cfa2e03 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -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/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v
index d3376a0e..05a94a8e 100644
--- a/theories/ZArith/Zminmax.v
+++ b/theories/ZArith/Zminmax.v
@@ -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/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index 203f9766..b401e6b6 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -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/theories/ZArith/Znat.v b/theories/ZArith/Znat.v
index 8031b357..20e7c2e8 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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        *)
@@ -271,7 +271,7 @@ Qed.
 
 Lemma inj_testbit a n :
  Z.testbit (Z.of_N a) (Z.of_N n) = N.testbit a n.
-Proof. apply Z.Private_BootStrap.testbit_of_N. Qed.
+Proof. apply Z.testbit_of_N. Qed.
 
 End N2Z.
 
@@ -426,7 +426,7 @@ Qed.
 
 Lemma inj_testbit a n : 0<=n ->
  Z.testbit (Z.of_N a) n = N.testbit a (Z.to_N n).
-Proof. apply Z.Private_BootStrap.testbit_of_N'. Qed.
+Proof. apply Z.testbit_of_N'. Qed.
 
 End Z2N.
 
@@ -637,7 +637,7 @@ Qed.
 
 (** [Z.of_nat] and usual operations *)
 
-Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = nat_compare n m.
+Lemma inj_compare n m : (Z.of_nat n ?= Z.of_nat m) = (n ?= m)%nat.
 Proof.
  now rewrite <-!nat_N_Z, N2Z.inj_compare, <- Nat2N.inj_compare.
 Qed.
@@ -690,23 +690,23 @@ Proof.
  now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub.
 Qed.
 
-Lemma inj_pred_max n : Z.of_nat (pred n) = Z.max 0 (Z.pred (Z.of_nat n)).
+Lemma inj_pred_max n : Z.of_nat (Nat.pred n) = Z.max 0 (Z.pred (Z.of_nat n)).
 Proof.
  now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max.
 Qed.
 
-Lemma inj_pred n : (0<n)%nat -> Z.of_nat (pred n) = Z.pred (Z.of_nat n).
+Lemma inj_pred n : (0<n)%nat -> Z.of_nat (Nat.pred n) = Z.pred (Z.of_nat n).
 Proof.
  rewrite nat_compare_lt, Nat2N.inj_compare. intros.
  now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred.
 Qed.
 
-Lemma inj_min n m : Z.of_nat (min n m) = Z.min (Z.of_nat n) (Z.of_nat m).
+Lemma inj_min n m : Z.of_nat (Nat.min n m) = Z.min (Z.of_nat n) (Z.of_nat m).
 Proof.
  now rewrite <- !nat_N_Z, Nat2N.inj_min, N2Z.inj_min.
 Qed.
 
-Lemma inj_max n m : Z.of_nat (max n m) = Z.max (Z.of_nat n) (Z.of_nat m).
+Lemma inj_max n m : Z.of_nat (Nat.max n m) = Z.max (Z.of_nat n) (Z.of_nat m).
 Proof.
  now rewrite <- !nat_N_Z, Nat2N.inj_max, N2Z.inj_max.
 Qed.
@@ -777,13 +777,13 @@ Proof.
  intros. now rewrite <- !Z_N_nat, Z2N.inj_sub, N2Nat.inj_sub.
 Qed.
 
-Lemma inj_pred n : Z.to_nat (Z.pred n) = pred (Z.to_nat n).
+Lemma inj_pred n : Z.to_nat (Z.pred n) = Nat.pred (Z.to_nat n).
 Proof.
  now rewrite <- !Z_N_nat, Z2N.inj_pred, N2Nat.inj_pred.
 Qed.
 
 Lemma inj_compare n m : 0<=n -> 0<=m ->
- nat_compare (Z.to_nat n) (Z.to_nat m) = (n ?= m).
+ (Z.to_nat n ?= Z.to_nat m)%nat = (n ?= m).
 Proof.
  intros Hn Hm. now rewrite <- Nat2Z.inj_compare, !id.
 Qed.
@@ -798,12 +798,12 @@ Proof.
  intros Hn Hm. unfold Z.lt. now rewrite nat_compare_lt, inj_compare.
 Qed.
 
-Lemma inj_min n m : Z.to_nat (Z.min n m) = min (Z.to_nat n) (Z.to_nat m).
+Lemma inj_min n m : Z.to_nat (Z.min n m) = Nat.min (Z.to_nat n) (Z.to_nat m).
 Proof.
  now rewrite <- !Z_N_nat, Z2N.inj_min, N2Nat.inj_min.
 Qed.
 
-Lemma inj_max n m : Z.to_nat (Z.max n m) = max (Z.to_nat n) (Z.to_nat m).
+Lemma inj_max n m : Z.to_nat (Z.max n m) = Nat.max (Z.to_nat n) (Z.to_nat m).
 Proof.
  now rewrite <- !Z_N_nat, Z2N.inj_max, N2Nat.inj_max.
 Qed.
@@ -876,13 +876,13 @@ Proof.
  intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_sub, N2Nat.inj_sub.
 Qed.
 
-Lemma inj_pred n : 0<n -> Z.abs_nat (Z.pred n) = pred (Z.abs_nat n).
+Lemma inj_pred n : 0<n -> Z.abs_nat (Z.pred n) = Nat.pred (Z.abs_nat n).
 Proof.
  intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_pred, N2Nat.inj_pred.
 Qed.
 
 Lemma inj_compare n m : 0<=n -> 0<=m ->
- nat_compare (Z.abs_nat n) (Z.abs_nat m) = (n ?= m).
+ (Z.abs_nat n ?= Z.abs_nat m)%nat = (n ?= m).
 Proof.
  intros. now rewrite <- !Zabs_N_nat, <- N2Nat.inj_compare, Zabs2N.inj_compare.
 Qed.
@@ -898,13 +898,13 @@ Proof.
 Qed.
 
 Lemma inj_min n m : 0<=n -> 0<=m ->
- Z.abs_nat (Z.min n m) = min (Z.abs_nat n) (Z.abs_nat m).
+ Z.abs_nat (Z.min n m) = Nat.min (Z.abs_nat n) (Z.abs_nat m).
 Proof.
  intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_min, N2Nat.inj_min.
 Qed.
 
 Lemma inj_max n m : 0<=n -> 0<=m ->
- Z.abs_nat (Z.max n m) = max (Z.abs_nat n) (Z.abs_nat m).
+ Z.abs_nat (Z.max n m) = Nat.max (Z.abs_nat n) (Z.abs_nat m).
 Proof.
  intros. now rewrite <- !Zabs_N_nat, Zabs2N.inj_max, N2Nat.inj_max.
 Qed.
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index 0f58f524..f69cf315 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -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        *)
@@ -308,11 +308,11 @@ Section extended_euclid_algorithm.
     intros v3 Hv3; generalize Hv3; pattern v3.
     apply Zlt_0_rec.
     clear v3 Hv3; intros.
-    elim (Z_zerop x); intro.
+    destruct (Z_zerop x) as [Heq|Hneq].
     apply Euclid_intro with (u := u1) (v := u2) (d := u3).
     assumption.
     apply H3.
-    rewrite a0; auto with zarith.
+    rewrite Heq; auto with zarith.
     set (q := u3 / x) in *.
     assert (Hq : 0 <= u3 - q * x < x).
     replace (u3 - q * x) with (u3 mod x).
@@ -605,11 +605,10 @@ Qed.
 Lemma prime_rel_prime :
   forall p:Z, prime p -> forall a:Z, ~ (p | a) -> rel_prime p a.
 Proof.
-  simple induction 1; intros.
-  constructor; intuition.
-  elim (prime_divisors p H x H3); intuition; subst; auto with zarith.
-  absurd (p | a); auto with zarith.
-  absurd (p | a); intuition.
+  intros; constructor; intros; auto with zarith.
+  apply prime_divisors in H1; intuition; subst; auto with zarith.
+  - absurd (p | a); auto with zarith.
+  - absurd (p | a); intuition.
 Qed.
 
 Hint Resolve prime_rel_prime: zarith.
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 39cf87fa..e090302e 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v
index a35dcb68..8f661a9c 100644
--- a/theories/ZArith/Zpow_alt.v
+++ b/theories/ZArith/Zpow_alt.v
@@ -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        *)
@@ -30,12 +30,12 @@ Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope.
 
 Lemma Piter_mul_acc : forall f,
  (forall x y:Z, (f x)*y = f (x*y)) ->
- forall p k, Pos.iter p f k = (Pos.iter p f 1)*k.
+ forall p k, Pos.iter f k p = (Pos.iter f 1 p)*k.
 Proof.
  intros f Hf.
  induction p; simpl; intros.
- - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Hf, Z.mul_assoc.
- - set (g := Pos.iter p f 1) in *. now rewrite !IHp, Z.mul_assoc.
+ - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Hf, Z.mul_assoc.
+ - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Z.mul_assoc.
  - now rewrite Hf, Z.mul_1_l.
 Qed.
 
diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v
index 2fbb70ba..740c45fd 100644
--- a/theories/ZArith/Zpow_def.v
+++ b/theories/ZArith/Zpow_def.v
@@ -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/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v
index 86dfce16..ac41a98f 100644
--- a/theories/ZArith/Zpow_facts.v
+++ b/theories/ZArith/Zpow_facts.v
@@ -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        *)
@@ -152,10 +152,8 @@ Qed.
 Theorem Zpow_mod_correct a m n :
  n <> 0 -> Zpow_mod a m n = (a ^ m) mod n.
 Proof.
-  intros Hn. destruct m; simpl.
-  - trivial.
+  intros Hn. destruct m; simpl; trivial.
   - apply Zpow_mod_pos_correct; auto with zarith.
-  - rewrite Z.mod_0_l; auto with zarith.
 Qed.
 
 (* Complements about power and number theory. *)
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index 27f0cfd2..747bd4fd 100644
--- a/theories/ZArith/Zpower.v
+++ b/theories/ZArith/Zpower.v
@@ -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        *)
@@ -25,7 +25,7 @@ Local Open Scope Z_scope.
 (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
     integer (type [nat]) and [z] a signed integer (type [Z]) *)
 
-Definition Zpower_nat (z:Z) (n:nat) := nat_iter n (Z.mul z) 1.
+Definition Zpower_nat (z:Z) := nat_rect _ 1 (fun _ => Z.mul z).
 
 Lemma Zpower_nat_0_r z : Zpower_nat z 0 = 1.
 Proof. reflexivity. Qed.
@@ -42,7 +42,7 @@ Lemma Zpower_nat_is_exp :
 Proof.
  induction n.
  - intros. now rewrite Zpower_nat_0_r, Z.mul_1_l.
- - intros. simpl. now rewrite 2 Zpower_nat_succ_r, IHn, Z.mul_assoc.
+ - intros. simpl. now rewrite IHn, Z.mul_assoc.
 Qed.
 
 (** Conversions between powers of unary and binary integers *)
@@ -94,12 +94,12 @@ Section Powers_of_2.
       calculus is possible. [shift n m] computes [2^n * m], i.e.
       [m] shifted by [n] positions *)
 
-  Definition shift_nat (n:nat) (z:positive) := nat_iter n xO z.
-  Definition shift_pos (n z:positive) := Pos.iter n xO z.
+  Definition shift_nat (n:nat) (z:positive) := nat_rect _ z (fun _ => xO) n.
+  Definition shift_pos (n z:positive) := Pos.iter xO z n.
   Definition shift (n:Z) (z:positive) :=
     match n with
       | Z0 => z
-      | Zpos p => Pos.iter p xO z
+      | Zpos p => Pos.iter xO z p
       | Zneg p => z
     end.
 
@@ -154,7 +154,7 @@ Section Powers_of_2.
   Lemma shift_nat_plus n m x :
     shift_nat (n + m) x = shift_nat n (shift_nat m x).
   Proof.
-   apply iter_nat_plus.
+   induction n; simpl; now f_equal.
   Qed.
 
   Theorem shift_nat_correct n x :
@@ -247,20 +247,20 @@ Section power_div_with_rest.
        end, 2 * d).
 
   Definition Zdiv_rest (x:Z) (p:positive) :=
-    let (qr, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in qr.
+    let (qr, d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in qr.
 
   Lemma Zdiv_rest_correct1 (x:Z) (p:positive) :
-    let (_, d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in
+    let (_, d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in
     d = two_power_pos p.
   Proof.
    rewrite Pos2Nat.inj_iter, two_power_pos_nat.
    induction (Pos.to_nat p); simpl; trivial.
-   destruct (nat_iter n Zdiv_rest_aux (x,0,1)) as ((q,r),d).
+   destruct (nat_rect _ _ _ _) as ((q,r),d).
    unfold Zdiv_rest_aux. rewrite two_power_nat_S; now f_equal.
   Qed.
 
   Lemma Zdiv_rest_correct2 (x:Z) (p:positive) :
-    let '(q,r,d) := Pos.iter p Zdiv_rest_aux (x, 0, 1) in
+    let '(q,r,d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in
     x = q * d + r /\ 0 <= r < d.
   Proof.
    apply Pos.iter_invariant; [|omega].
@@ -287,7 +287,7 @@ Section power_div_with_rest.
   Lemma Zdiv_rest_correct (x:Z) (p:positive) : Zdiv_rest_proofs x p.
   Proof.
     generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
-    destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d).
+    destruct (Pos.iter Zdiv_rest_aux (x, 0, 1) p) as ((q,r),d).
     intros (H1,(H2,H3)) ->. now exists q r.
   Qed.
 
@@ -299,7 +299,7 @@ Section power_div_with_rest.
   Proof.
    unfold Zdiv_rest.
    generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
-   destruct (Pos.iter p Zdiv_rest_aux (x, 0, 1)) as ((q,r),d).
+   destruct (Pos.iter Zdiv_rest_aux (x, 0, 1) p) as ((q,r),d).
    intros H ->. now rewrite two_power_pos_equiv in H.
   Qed.
 
diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v
index 7f064c2b..3ef11189 100644
--- a/theories/ZArith/Zquot.v
+++ b/theories/ZArith/Zquot.v
@@ -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/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v
index 24f3715e..65959a69 100644
--- a/theories/ZArith/Zsqrt_compat.v
+++ b/theories/ZArith/Zsqrt_compat.v
@@ -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        *)
@@ -53,7 +53,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
 	| xI xH => c_sqrt 3 1 2 _ _
 	| xO (xO p') =>
           match sqrtrempos p' with
-            | c_sqrt s' r' Heq Hint =>
+            | c_sqrt _ s' r' Heq Hint =>
               match Z_le_gt_dec (4 * s' + 1) (4 * r') with
 		| left Hle =>
                   c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1)
@@ -63,7 +63,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
           end
 	| xO (xI p') =>
           match sqrtrempos p' with
-            | c_sqrt s' r' Heq Hint =>
+            | c_sqrt _ s' r' Heq Hint =>
               match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with
 		| left Hle =>
                   c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1)
@@ -74,7 +74,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
           end
 	| xI (xO p') =>
           match sqrtrempos p' with
-            | c_sqrt s' r' Heq Hint =>
+            | c_sqrt _ s' r' Heq Hint =>
               match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with
 		| left Hle =>
                   c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1)
@@ -85,7 +85,7 @@ Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p).
           end
 	| xI (xI p') =>
           match sqrtrempos p' with
-            | c_sqrt s' r' Heq Hint =>
+            | c_sqrt _ s' r' Heq Hint =>
               match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with
 		| left Hle =>
                   c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1)
@@ -114,7 +114,7 @@ Definition Zsqrt :
 	| Zpos p =>
           fun h =>
             match sqrtrempos p with
-              | c_sqrt s r Heq Hint =>
+              | c_sqrt _ s r Heq Hint =>
 		existT
                 (fun s:Z =>
                   {r : Z |
@@ -150,7 +150,7 @@ Definition Zsqrt_plain (x:Z) : Z :=
   match x with
     | Zpos p =>
       match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with
-	| existT s _ => s
+	| existT _ s _ => s
       end
     | Zneg p => 0
     | Z0 => 0
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index 9d2e9cab..cba709e8 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -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/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index 929aedc9..25ef852a 100644
--- a/theories/ZArith/auxiliary.v
+++ b/theories/ZArith/auxiliary.v
@@ -1,7 +1,7 @@
 (* -*- coding: utf-8 -*- *)
 (************************************************************************)
 (*  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/theories/ZArith/vo.itarget b/theories/ZArith/vo.itarget
index 88751cc0..178111cd 100644
--- a/theories/ZArith/vo.itarget
+++ b/theories/ZArith/vo.itarget
@@ -23,8 +23,6 @@ Zmin.vo
 Zmisc.vo
 Znat.vo
 Znumtheory.vo
-ZOdiv_def.vo
-ZOdiv.vo
 Zquot.vo
 Zorder.vo
 Zpow_def.vo
diff --git a/tools/README.emacs b/tools/README.emacs
index 0d27b607..4d8e3697 100755
--- a/tools/README.emacs
+++ b/tools/README.emacs
@@ -10,14 +10,14 @@ Jean-Christophe Filliatre (jcfillia@lri.fr),
 
 CONTENTS:
 
-    coq.el         A major mode for editing Coq files in Gnu Emacs
+    gallina.el     A major mode for editing Coq files in Gnu Emacs
 
 USAGE:
 
 Add the following lines to your .emacs file:
 
 (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
-(autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+(autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t)
 
 The Coq major mode is triggered by visiting a file with extension .v,
 or manually by M-x coq-mode. It gives you the correct syntax table for
diff --git a/tools/beautify-archive b/tools/beautify-archive
index ccfeb3db..6bfa974a 100755
--- a/tools/beautify-archive
+++ b/tools/beautify-archive
@@ -30,7 +30,7 @@ beaufiles=`find . -name \*.v$BEAUTIFYSUFFIX`
 for i in $beaufiles; do
   j=`dirname $i`/`basename $i .v$BEAUTIFYSUFFIX`.v
   echo Upgrading $j in the beautification directory
-  mv -u -f $i $j
+  if [ $i -nt $j ]; then mv -f $i $j; fi
 done
 echo ---- Recompiling beautified files in the beautification directory -----
 make clean
@@ -44,7 +44,7 @@ vfiles=`find . -name \*.v`
 cd ..
 for i in $vfiles; do
   echo Upgrading $i in current directory
-  mv -u -f $NEWARCHIVE/$i $i
+  if [ $NEWARCHIVE/$i -nt $i ]; then mv -f $NEWARCHIVE/$i $i; fi
 done
 echo -------- Beautification completed -------------------------------------
 echo Old files are in directory '"'$OLDARCHIVE'"'
diff --git a/tools/compat5.ml b/tools/compat5.ml
index 11520c23..041ced00 100644
--- a/tools/compat5.ml
+++ b/tools/compat5.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        *)
diff --git a/tools/compat5.mlp b/tools/compat5.mlp
index e6252b11..91e3cdae 100644
--- a/tools/compat5.mlp
+++ b/tools/compat5.mlp
@@ -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/tools/compat5b.ml b/tools/compat5b.ml
index 7f6818ee..a2336e10 100644
--- a/tools/compat5b.ml
+++ b/tools/compat5b.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        *)
diff --git a/tools/compat5b.mlp b/tools/compat5b.mlp
index b61b08c7..d4dfcc07 100644
--- a/tools/compat5b.mlp
+++ b/tools/compat5b.mlp
@@ -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/tools/coq-font-lock.el b/tools/coq-font-lock.el
index 05618a04..068e6400 100644
--- a/tools/coq-font-lock.el
+++ b/tools/coq-font-lock.el
@@ -110,18 +110,18 @@ syntax colouring behaviour.")
 ;;A new face for tactics
 (defface coq-solve-tactics-face
   (proof-face-specs
-   (:foreground "forestgreen" t) ; pour les fonds clairs
-   (:foreground "forestgreen"  t) ; pour les fond foncés
-   ()) ; pour le noir et blanc
+   (:foreground "forestgreen" t) ; for bright backgrounds
+   (:foreground "forestgreen"  t) ; for dark backgrounds
+   ()) ; for black and white
   "Face for names of closing tactics in proof scripts."
   :group 'proof-faces)
 
 ;;A new face for tactics which fail when they don't kill the current goal
 (defface coq-solve-tactics-face
   (proof-face-specs
-   (:foreground "red" t) ; pour les fonds clairs
-   (:foreground "red"  t) ; pour les fond foncés
-   ()) ; pour le noir et blanc
+   (:foreground "red" t) ; for bright backgrounds
+   (:foreground "red"  t) ; for dark backgrounds
+   ()) ; for black and white
   "Face for names of closing tactics in proof scripts."
   :group 'proof-faces)
 
diff --git a/tools/coq-inferior.el b/tools/coq-inferior.el
index d4f96a16..b79d97d6 100644
--- a/tools/coq-inferior.el
+++ b/tools/coq-inferior.el
@@ -46,13 +46,13 @@
 
 ;;; Installation:
 
-;; You need to have coq.el already installed (it comes with the
+;; You need to have gallina.el already installed (it comes with the
 ;; standard Coq distribution) in order to use this code.  Put this
 ;; file somewhere in you load-path and add the following lines in your
 ;; "~/.emacs":
 ;;
 ;;   (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist))
-;;   (autoload 'coq-mode "coq" "Major mode for editing Coq vernacular." t)
+;;   (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t)
 ;;   (autoload 'run-coq "inferior-coq" "Run an inferior Coq process." t)
 ;;   (autoload 'run-coq-other-window "inferior-coq"
 ;;     "Run an inferior Coq process in a new window." t)
@@ -78,7 +78,7 @@
 ;; From -0.0 to 1.0 brought into existence.
 
 
-(require 'coq)
+(require 'gallina)
 (require 'comint)
 
 (setq coq-program-name "coqtop")
diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml
index 74266925..d660f420 100644
--- a/tools/coq_makefile.ml
+++ b/tools/coq_makefile.ml
@@ -1,12 +1,12 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(* créer un Makefile pour un développement Coq automatiquement *)
+(* Coq_makefile: automatically create a Makefile for a Coq development *)
 
 let output_channel = ref stdout
 let makefile_name = ref "Makefile"
@@ -32,38 +32,47 @@ let list_iter_i f =
 
 let section s =
   let l = String.length s in
-  let sep = String.make (l+5) '#'
-  and sep2 = String.make (l+5) ' ' in
-  String.set sep (l+4) '\n';
-  String.set sep2 0 '#';
-  String.set sep2 (l+3) '#';
-  String.set sep2 (l+4) '\n';
-  print sep;
-  print sep2;
+  let print_com s =
+    print "#";
+    print s;
+    print "#\n" in
+  print_com (String.make (l+2) '#');
+  print_com (String.make (l+2) ' ');
   print "# "; print s; print " #\n";
-  print sep2;
-  print sep;
+  print_com (String.make (l+2) ' ');
+  print_com (String.make (l+2) '#');
   print "\n"
 
 let usage () =
   output_string stderr "Usage summary:
 
-coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... [file.mllib]
-  ... [-custom command dependencies file] ... [-I dir] ... [-R physicalpath
-  logicalpath] ... [VARIABLE = value] ...  [-arg opt] ... [-opt|-byte]
-  [-no-install] [-f file] [-o file] [-h] [--help]
+coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ...
+  [file.ml{lib,pack}] ... [-extra[-phony] result dependencies command]
+  ... [-I dir] ... [-R physicalpath logicalpath] ... [VARIABLE = value]
+  ...  [-arg opt] ... [-opt|-byte] [-no-install] [-f file] [-o file]
+  [-h] [--help]
 
 [file.v]: Coq file to be compiled
 [file.ml[i4]?]: Objective Caml file to be compiled
-[file.mllib]: ocamlbuild file that describes a Objective Caml library
+[file.ml{lib,pack}]: ocamlbuild file that describes a Objective Caml
+  library/module
 [subdirectory] : subdirectory that should be \"made\" and has a
   Makefile itself to do so.
-[-custom command dependencies file]: add target \"file\" with command
-  \"command\" and dependencies \"dependencies\"
+[-extra result dependencies command]: add target \"result\" with command
+  \"command\" and dependencies \"dependencies\". If \"result\" is not
+  generic (do not contains a %), \"result\" is built by _make all_ and
+  deleted by _make clean_.
+[-extra-phony result dependencies command]: add a PHONY target \"result\"
+ with command \"command\" and dependencies \"dependencies\". Note that
+ _-extra-phony foo bar \"\"_ is a regular way to add the target \"bar\" as
+ as a dependencies of an already defined target \"foo\".
 [-I dir]: look for Objective Caml dependencies in \"dir\"
 [-R physicalpath logicalpath]: look for Coq dependencies resursively
   starting from \"physicalpath\". The logical path associated to the
   physical path is \"logicalpath\".
+[-Q physicalpath logicalpath]: look for Coq dependencies starting from
+  \"physicalpath\". The logical path associated to the physical path
+  is \"logicalpath\".
 [VARIABLE = value]: Add the variable definition \"VARIABLE=value\"
 [-byte]: compile with byte-code version of coq
 [-opt]: compile with native-code version of coq
@@ -78,7 +87,7 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml[i4]?] ... [file.mllib]
 [--help]: equivalent to [-h]\n";
   exit 1
 
-let is_genrule r =
+let is_genrule r = (* generic rule (like bar%foo: ...) *)
     let genrule = Str.regexp("%") in
       Str.string_match genrule r 0
 
@@ -89,11 +98,11 @@ let string_prefix a b =
 let is_prefix dir1 dir2 =
   let l1 = String.length dir1 in
   let l2 = String.length dir2 in
-    dir1 = dir2 or (l1 < l2 & String.sub dir2 0 l1 = dir1 & dir2.[l1] = '/')
+    dir1 = dir2 || (l1 < l2 && String.sub dir2 0 l1 = dir1 && dir2.[l1] = '/')
 
 let physical_dir_of_logical_dir ldir =
   let le = String.length ldir - 1 in
-  let pdir = if ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in
+  let pdir = if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in
   for i = 0 to le - 1 do
     if pdir.[i] = '.' then pdir.[i] <- '/';
   done;
@@ -107,14 +116,15 @@ let standard opt =
   print "\t$(MAKE) all \"OPT:="; print (if opt then "-opt" else "-byte");
   print "\"\n\n"
 
-let classify_files_by_root var files (inc_i,inc_r) =
-  if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) then
+let classify_files_by_root var files (inc_ml,inc_i,inc_r) =
+  if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r)
+    && not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_i) then
     begin
       let absdir_of_files = List.rev_map
-	(fun x -> Minilib.canonical_path_name (Filename.dirname x))
+	(fun x -> CUnix.canonical_path_name (Filename.dirname x))
 	files in
 	(* files in scope of a -I option (assuming they are no overlapping) *)
-      let has_inc_i = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in
+      let has_inc_i = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml in
 	if has_inc_i then
 	  begin
 	    printf "%sINC=" var;
@@ -123,128 +133,188 @@ let classify_files_by_root var files (inc_i,inc_r) =
 			 then printf
 			   "$(filter $(wildcard %s/*),$(%s)) "
 			   pdir var
-		      ) inc_i;
+		      ) inc_ml;
 	    printf "\n";
 	  end;
       (* Files in the scope of a -R option (assuming they are disjoint) *)
-	list_iter_i (fun i (pdir,ldir,abspdir) ->
+	list_iter_i (fun i (pdir,_,abspdir) ->
 		       if List.exists (is_prefix abspdir) absdir_of_files then
 			 printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n"
 			   var i pdir pdir var)
-	  inc_r;
+	  (inc_i@inc_r);
     end
 
-let install_include_by_root files_var files (inc_i,inc_r) =
-  try
+let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) =
+  let var_x_absdirs_l = List.rev_map
+    (fun (v,l) -> (v,List.rev_map (fun x -> CUnix.canonical_path_name (Filename.dirname x)) l))
+    var_x_files_l in
+  let var_filter f g = List.fold_left (fun acc (var,dirs) ->
+    if f dirs
+    then (g var)::acc else acc) [] var_x_absdirs_l in
     (* All files caught by a -R . option (assuming it is the only one) *)
-    let ldir = match inc_r with
-      |[(".",t,_)] -> t
-      |l -> let out = List.assoc "." (List.map (fun (p,l,_) -> (p,l)) inc_r) in
-	 let () = prerr_string "Warning: install rule assumes that -R . _ is the only -R option" in
-	   out in
-    let pdir = physical_dir_of_logical_dir ldir in
-      printf "\tfor i in $(%s); do \\\n" files_var;
-      printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir;
-      printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir;
-      printf "\tdone\n"
-  with Not_found ->
-    let absdir_of_files = List.rev_map
-      (fun x -> Minilib.canonical_path_name (Filename.dirname x))
-      files in
-    let has_inc_i_files =
-      List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_i in
-    let install_inc_i d =
-      printf "\tinstall -d $(DSTROOT)$(COQLIBINSTALL)/%s; \\\n" d;
-      printf "\tfor i in $(%sINC); do \\\n" files_var;
-      printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" d;
+  match inc_i@inc_r with
+  |[(".",t,_)] -> (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l])
+  |l ->
+    try
+      let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in
+      let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option" in
+      (None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l])
+    with Not_found ->
+      (
+      (* vars for -Q options *)
+	Some (var_filter (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml) (fun x -> x)),
+      (* (physical dir, physical dir of logical path,vars) for -R options
+	 (assuming physical dirs are disjoint) *)
+      if l = [] then
+	[".","$(INSTALLDEFAULTROOT)",[]]
+      else
+	Util.List.fold_left_i (fun i out (pdir,ldir,abspdir) ->
+	  let vars_r = var_filter (List.exists (is_prefix abspdir)) (fun x -> x^string_of_int i) in
+	  let pdir' = physical_dir_of_logical_dir ldir in
+	  (pdir,pdir',vars_r)::out) 1 [] l
+      )
+
+let install_include_by_root perms =
+  let install_dir for_i (pdir,pdir',vars) =
+    let b = vars <> [] in
+    if b then begin
+      printf "\tcd \"%s\" && for i in " pdir;
+      print_list " " (List.rev_map (Format.sprintf "$(%s)") vars);
+      print "; do \\\n";
+      printf "\t install -d \"`dirname \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i`\"; \\\n" pdir';
+      printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/$$i; \\\n" perms pdir';
+      printf "\tdone\n";
+    end;
+    for_i b pdir' in
+  let install_i = function
+    |[] -> fun _ _ -> ()
+    |l -> fun b d ->
+      if not b then printf "\tinstall -d \"$(DSTROOT)\"$(COQLIBINSTALL)/%s; \\\n" d;
+      print "\tfor i in ";
+      print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l);
+      print "; do \\\n";
+      printf "\t install -m %s $$i \"$(DSTROOT)\"$(COQLIBINSTALL)/%s/`basename $$i`; \\\n" perms d;
       printf "\tdone\n"
-    in
-      if inc_r = [] then
-	if has_inc_i_files then
-	  begin
-	    (* Files in the scope of a -I option *)
-	    install_inc_i "$(INSTALLDEFAULTROOT)";
-	  end else ()
+  in function
+  |None,l -> List.iter (install_dir (fun _ _ -> ())) l
+  |Some v_i,l -> List.iter (install_dir (install_i v_i)) l
+
+let uninstall_by_root =
+  let uninstall_dir for_i (pdir,pdir',vars) =
+    printf "\tprintf 'cd \"$${DSTROOT}\"$(COQLIBINSTALL)/%s" pdir';
+    if vars <> [] then begin
+      print " && rm -f ";
+      print_list " " (List.rev_map (Format.sprintf "$(%s)") vars);
+    end;
+    for_i ();
+    print " && find . -type d -and -empty -delete\\n";
+    print "cd \"$${DSTROOT}\"$(COQLIBINSTALL) && ";
+    printf "find \"%s\" -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" pdir'
+in
+  let uninstall_i = function
+    |[] -> ()
+    |l ->
+      print " && \\\\\\nfor i in ";
+      print_list " " (List.rev_map (Format.sprintf "$(%sINC)") l);
+      print "; do rm -f \"`basename \"$$i\"`\"; done"
+  in function
+  |None,l -> List.iter (uninstall_dir (fun _ -> ())) l
+  |Some v_i,l -> List.iter (uninstall_dir (fun () -> uninstall_i v_i)) l
+
+let where_put_doc = function
+    |_,[],[] -> "$(INSTALLDEFAULTROOT)";
+    |_,((_,lp,_)::q as inc_i),[] ->
+      let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in
+      if (pr <> "") &&
+	((List.exists (fun(_,b,_) -> b = pr) inc_i)
+	 || pr.[String.length pr - 1] = '.')
+      then
+	physical_dir_of_logical_dir pr
       else
-	(* Files in the scope of a -R option (assuming they are disjoint) *)
-	list_iter_i (fun i (pdir,ldir,abspdir) ->
-		       let has_inc_r_files = List.exists (is_prefix abspdir) absdir_of_files in
-		       let pdir' = physical_dir_of_logical_dir ldir in
-			 if has_inc_r_files then
-			   begin
-			     printf "\tcd %s; for i in $(%s%d); do \\\n" pdir files_var i;
-			     printf "\t install -d `dirname $(DSTROOT)$(COQLIBINSTALL)/%s/$$i`; \\\n" pdir';
-			     printf "\t install -m 0644 $$i $(DSTROOT)$(COQLIBINSTALL)/%s/$$i; \\\n" pdir';
-			     printf "\tdone\n";
-			   end;
-			 if has_inc_i_files then install_inc_i pdir'
-		    ) inc_r
-
-let install_doc some_vfiles some_mlifiles (_,inc_r) =
-  let install_one_kind kind dir =
-    printf "\tinstall -d $(DSTROOT)$(COQDOCINSTALL)/%s/%s\n" dir kind;
-    printf "\tfor i in %s/*; do \\\n" kind;
-    printf "\t install -m 0644 $$i $(DSTROOT)$(COQDOCINSTALL)/%s/$$i;\\\n" dir;
-    print "\tdone\n" in
-    print "install-doc:\n";
-    let () = match inc_r with
-      |[] ->
-	 if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)";
-	  if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)";
-      |(_,lp,_)::q ->
-	 let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in
-	   if (pr <> "") &&
-	     ((List.exists (fun(_,b,_) -> b = pr) inc_r) || pr.[String.length pr - 1] = '.')
-	   then begin
-	     let rt = physical_dir_of_logical_dir pr in
-	       if some_vfiles then install_one_kind "html" rt;
-	       if some_mlifiles then install_one_kind "mlihtml" rt;
-	   end else begin
-	     prerr_string "Warning: -R options don't have a correct common prefix,
- install-doc will put anything in $INSTALLDEFAULTROOT\n";
-	   if some_vfiles then install_one_kind "html" "$(INSTALLDEFAULTROOT)";
-	   if some_mlifiles then install_one_kind "mlihtml" "$(INSTALLDEFAULTROOT)";
-	   end in
-      print "\n"
+	let () = prerr_string "Warning: -Q options don't have a correct common prefix,
+ install-doc will put anything in $INSTALLDEFAULTROOT\n" in
+	"$(INSTALLDEFAULTROOT)"
+    |_,inc_i,((_,lp,_)::q as inc_r) ->
+      let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) lp q in
+      let pr = List.fold_left (fun a (_,b,_) -> string_prefix a b) pr inc_i in
+      if (pr <> "") &&
+	((List.exists (fun(_,b,_) -> b = pr) inc_r)
+	 || (List.exists (fun(_,b,_) -> b = pr) inc_i)
+	 || pr.[String.length pr - 1] = '.')
+      then
+	physical_dir_of_logical_dir pr
+      else
+	let () = prerr_string "Warning: -R/-Q options don't have a correct common prefix,
+ install-doc will put anything in $INSTALLDEFAULTROOT\n" in
+	"$(INSTALLDEFAULTROOT)"
 
 let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) inc = function
   |Project_file.NoInstall -> ()
   |is_install ->
+    let not_empty = function |[] -> false |_::_ -> true in
+    let cmofiles = List.rev_append mlpackfiles (List.rev_append mlfiles ml4files) in
+    let cmifiles = List.rev_append mlifiles cmofiles in
+    let cmxsfiles = List.rev_append cmofiles mllibfiles in
+    let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxsfiles)] inc in
+    let where_what_oth = vars_to_put_by_root
+      [("VOFILES",vfiles);("VFILES",vfiles);("GLOBFILES",vfiles);("NATIVEFILES",vfiles);("CMOFILES",cmofiles);("CMIFILES",cmifiles);("CMAFILES",mllibfiles)]
+      inc in
+    let doc_dir = where_put_doc inc in
     let () = if is_install = Project_file.UnspecInstall then
 	print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" in
-  let not_empty = function |[] -> false |_::_ -> true in
-  let cmofiles = mlpackfiles@mlfiles@ml4files in
-  let cmifiles = mlifiles@cmofiles in
-  let cmxsfiles = cmofiles@mllibfiles in
     if (not_empty cmxsfiles) then begin
       print "install-natdynlink:\n";
-      install_include_by_root "CMXSFILES" cmxsfiles inc;
+      install_include_by_root "0755" where_what_cmxs;
+      print "\n";
+    end;
+    if (not_empty cmxsfiles) then begin
+      print "install-toploop: $(MLLIBFILES:.mllib=.cmxs)\n";
+      printf "\t install -d \"$(DSTROOT)\"$(COQTOPINSTALL)/\n";
+      printf "\t install -m 0755 $?  \"$(DSTROOT)\"$(COQTOPINSTALL)/\n";
       print "\n";
     end;
     print "install:";
     if (not_empty cmxsfiles) then print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)";
     print "\n";
-    if not_empty vfiles then install_include_by_root "VOFILES" vfiles inc;
-    if (not_empty cmofiles) then
-      install_include_by_root "CMOFILES" cmofiles inc;
-    if (not_empty cmifiles) then
-      install_include_by_root "CMIFILES" cmifiles inc;
-    if (not_empty mllibfiles) then
-      install_include_by_root "CMAFILES" mllibfiles inc;
+    install_include_by_root "0644" where_what_oth;
     List.iter
       (fun x ->
-	 printf "\t(cd %s; $(MAKE) DSTROOT=$(DSTROOT) INSTALLDEFAULTROOT=$(INSTALLDEFAULTROOT)/%s install)\n" x x)
+	printf "\t+cd %s && $(MAKE) DSTROOT=\"$(DSTROOT)\" INSTALLDEFAULTROOT=\"$(INSTALLDEFAULTROOT)/%s\" install\n" x x)
       sds;
     print "\n";
-    install_doc (not_empty vfiles) (not_empty mlifiles) inc
+    let install_one_kind kind dir =
+      printf "\tinstall -d \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/%s\n" dir kind;
+      printf "\tfor i in %s/*; do \\\n" kind;
+      printf "\t install -m 0644 $$i \"$(DSTROOT)\"$(COQDOCINSTALL)/%s/$$i;\\\n" dir;
+      print "\tdone\n" in
+    print "install-doc:\n";
+    if not_empty vfiles then install_one_kind "html" doc_dir;
+    if not_empty mlifiles then install_one_kind "mlihtml" doc_dir;
+    print "\n";
+    let uninstall_one_kind kind dir =
+      printf "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL)/%s \\\\\\n' >> \"$@\"\n" dir;
+      printf "\tprintf '&& rm -f $(shell find \"%s\" -maxdepth 1 -and -type f -print)\\n' >> \"$@\"\n" kind;
+      print "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL) && ";
+      printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind
+    in
+    print "uninstall_me.sh:\n";
+    print "\techo '#!/bin/sh' > $@ \n";
+    if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs;
+    uninstall_by_root where_what_oth;
+    if not_empty vfiles then uninstall_one_kind "html" doc_dir;
+    if not_empty mlifiles then uninstall_one_kind "mlihtml" doc_dir;
+    print "\tchmod +x $@\n";
+    print "\n";
+    print "uninstall: uninstall_me.sh\n";
+    print "\tsh $<\n\n"
 
 let make_makefile sds =
   if !make_name <> "" then begin
     printf "%s: %s\n" !makefile_name !make_name;
     print "\tmv -f $@ $@.bak\n";
-    print "\t$(COQBIN)coq_makefile -f $< -o $@\n\n";
+    print "\t\"$(COQBIN)coq_makefile\" -f $< -o $@\n\n";
     List.iter
-      (fun x -> print "\t(cd "; print x; print " ; $(MAKE) Makefile)\n")
+      (fun x -> print "\t+cd "; print x; print " && $(MAKE) Makefile\n")
       sds;
     print "\n";
   end
@@ -257,71 +327,78 @@ let clean sds sps =
     print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n";
   end;
   if !some_vfile then
-    print "\trm -f $(VOFILES) $(VIFILES) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n";
+    begin
+      print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n";
+      print "\trm -f $(VOFILES) $(VOFILES:.vo=.vio) $(GFILES) $(VFILES:.v=.v.d) $(VFILES:=.beautified) $(VFILES:=.old)\n"
+    end;
   print "\trm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob $(VFILES:.v=.glob) $(VFILES:.v=.tex) $(VFILES:.v=.g.tex) all-mli.tex\n";
-  print "\t- rm -rf html mlihtml\n";
+  print "\t- rm -rf html mlihtml uninstall_me.sh\n";
   List.iter
-    (fun (file,_,_) ->
-       if not (is_genrule file) then
+    (fun (file,_,is_phony,_) ->
+       if not (is_phony || is_genrule file) then
 	 (print "\t- rm -rf "; print file; print "\n"))
     sps;
   List.iter
-    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) clean)\n")
+    (fun x -> print "\t+cd "; print x; print " && $(MAKE) clean\n")
     sds;
   print "\n";
   print "archclean:\n";
   print "\trm -f *.cmx *.o\n";
   List.iter
-    (fun x -> print "\t(cd "; print x; print " ; $(MAKE) archclean)\n")
+    (fun x -> print "\t+cd "; print x; print " && $(MAKE) archclean\n")
     sds;
   print "\n";
-  print "printenv:\n\t@$(COQBIN)coqtop -config\n";
-  print "\t@echo CAMLC =\t$(CAMLC)\n\t@echo CAMLOPTC =\t$(CAMLOPTC)\n\t@echo PP =\t$(PP)\n\t@echo COQFLAGS =\t$(COQFLAGS)\n";
-  print "\t@echo COQLIBINSTALL =\t$(COQLIBINSTALL)\n\t@echo COQDOCINSTALL =\t$(COQDOCINSTALL)\n\n"
+  print "printenv:\n\t@\"$(COQBIN)coqtop\" -config\n";
+  print "\t@echo 'CAMLC =\t$(CAMLC)'\n\t@echo 'CAMLOPTC =\t$(CAMLOPTC)'\n\t@echo 'PP =\t$(PP)'\n\t@echo 'COQFLAGS =\t$(COQFLAGS)'\n";
+  print "\t@echo 'COQLIBINSTALL =\t$(COQLIBINSTALL)'\n\t@echo 'COQDOCINSTALL =\t$(COQDOCINSTALL)'\n\n"
 
 let header_includes () = ()
 
 let implicit () =
     section "Implicit rules.";
   let mli_rules () =
-    print "%.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
-    print "%.mli.d: %.mli\n";
+    print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli\n";
     print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
   let ml4_rules () =
-    print "%.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
-    print "%.cmx: %.ml4\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
-    print "%.ml4.d: %.ml4\n";
-    print "\t$(COQDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+    print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
+    print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n";
+    print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n";
+    print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n";
+    print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
   let ml_rules () =
-    print "%.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
-    print "%.cmx: %.ml\n\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
-    print "%.ml.d: %.ml\n";
+    print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n";
+    print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n";
+    print "$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml\n";
     print "\t$(OCAMLDEP) -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
-  let cmxs_rules () =
-    print "%.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n";
-    print "%.cmxs: %.cmx\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n" in
+  let cmxs_rules () = (* order is important here when there is foo.ml and foo.mllib *)
+    print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx
+\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n";
+    print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n" in
   let mllib_rules () =
-    print "%.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
-    print "%.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
-    print "%.mllib.d: %.mllib\n";
-    print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
+    print "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n";
+    print "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n";
+    print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in
   let mlpack_rules () =
-    print "%.cmo: | %.mlpack\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
-    print "%.cmx: | %.mlpack\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
-    print "%.mlpack.d: %.mlpack\n";
-    print "\t$(COQDEP) -slash $(COQLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+    print "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
+    print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n";
+    print "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n";
+    print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
 in
   let v_rules () =
-    print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
-    print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n";
-    print "%.g: %.v\n\t$(GALLINA) $<\n\n";
-    print "%.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n";
-    print "%.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n";
-    print "%.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n";
-    print "%.g.html: %.v %.glob\n\t$(COQDOC)$(COQDOCFLAGS)  -html -g $< -o $@\n\n";
-    print "%.v.d: %.v\n";
-    print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
-    print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n"
+    print "$(VOFILES): %.vo: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "$(GLOBFILES): %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "$(VFILES:.v=.vio): %.vio: %.v\n\t$(COQC) -quick $(COQDEBUG) $(COQFLAGS) $*\n\n";
+    print "$(GFILES): %.g: %.v\n\t$(GALLINA) $<\n\n";
+    print "$(VFILES:.v=.tex): %.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n";
+    print "$(HTMLFILES): %.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n";
+    print "$(VFILES:.v=.g.tex): %.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n";
+    print "$(GHTMLFILES): %.g.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS)  -html -g $< -o $@\n\n";
+    print "$(addsuffix .d,$(VFILES)): %.v.d: %.v\n";
+    print "\t$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
+    print "$(addsuffix .beautified,$(VFILES)): %.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n"
   in
     if !some_mlifile then mli_rules ();
     if !some_ml4file then ml4_rules ();
@@ -350,100 +427,121 @@ let variables is_install opt (args,defs) =
     end;
     (* Coq executables and relative variables *)
     if !some_vfile || !some_mlpackfile || !some_mllibfile then
-      print "COQDEP?=$(COQBIN)coqdep -c\n";
+      print "COQDEP?=\"$(COQBIN)coqdep\" -c\n";
     if !some_vfile then begin
     print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
     print "COQCHKFLAGS?=-silent -o\n";
     print "COQDOCFLAGS?=-interpolate -utf8\n";
-    print "COQC?=$(COQBIN)coqc\n";
-    print "GALLINA?=$(COQBIN)gallina\n";
-    print "COQDOC?=$(COQBIN)coqdoc\n";
-    print "COQCHK?=$(COQBIN)coqchk\n\n";
+    print "COQC?=$(TIMER) \"$(COQBIN)coqc\"\n";
+    print "GALLINA?=\"$(COQBIN)gallina\"\n";
+    print "COQDOC?=\"$(COQBIN)coqdoc\"\n";
+    print "COQCHK?=\"$(COQBIN)coqchk\"\n";
+    print "COQMKTOP?=\"$(COQBIN)coqmktop\"\n\n";
     end;
     (* Caml executables and relative variables *)
     if !some_ml4file || !some_mlfile || !some_mlifile then begin
-    print "COQSRCLIBS?=-I $(COQLIB)kernel -I $(COQLIB)lib \\
-  -I $(COQLIB)library -I $(COQLIB)parsing \\
-  -I $(COQLIB)pretyping -I $(COQLIB)interp \\
-  -I $(COQLIB)proofs -I $(COQLIB)tactics \\
-  -I $(COQLIB)toplevel";
+    print "COQSRCLIBS?=-I \"$(COQLIB)kernel\" -I \"$(COQLIB)lib\" \\
+  -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)pretyping\" \\
+  -I \"$(COQLIB)interp\" -I \"$(COQLIB)printing\" -I \"$(COQLIB)intf\" \\
+  -I \"$(COQLIB)proofs\" -I \"$(COQLIB)tactics\" -I \"$(COQLIB)tools\" \\
+  -I \"$(COQLIB)toplevel\" -I \"$(COQLIB)stm\" -I \"$(COQLIB)grammar\" \\
+  -I \"$(COQLIB)config\"";
     List.iter (fun c -> print " \\
-  -I $(COQLIB)plugins/"; print c) Coq_config.plugins_dirs; print "\n";
+  -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n";
     print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n";
-    print "CAMLC?=$(OCAMLC) -c -rectypes\n";
-    print "CAMLOPTC?=$(OCAMLOPT) -c -rectypes\n";
-    print "CAMLLINK?=$(OCAMLC) -rectypes\n";
-    print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes\n";
+    print "CAMLC?=$(OCAMLC) -c -rectypes -thread\n";
+    print "CAMLOPTC?=$(OCAMLOPT) -c -rectypes -thread\n";
+    print "CAMLLINK?=$(OCAMLC) -rectypes -thread\n";
+    print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes -thread\n";
     print "GRAMMARS?=grammar.cma\n";
-    print "CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n";
-    print "CAMLP4OPTIONS?=-loc loc\n";
-    print "PP?=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n\n";
+    print "ifeq ($(CAMLP4),camlp5)
+CAMLP4EXTEND=pa_extend.cmo q_MLast.cmo pa_macro.cmo unix.cma threads.cma
+else
+CAMLP4EXTEND=
+endif\n";
+    print "PP?=-pp '$(CAMLP4O) -I $(CAMLLIB) -I $(CAMLLIB)threads/ $(COQSRCLIBS) compat5.cmo \\
+  $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl'\n\n";
     end;
     match is_install with
       | Project_file.NoInstall -> ()
       | Project_file.UnspecInstall ->
         section "Install Paths.";
 	print "ifdef USERINSTALL\n";
-        print "XDG_DATA_HOME?=$(HOME)/.local/share\n";
+        print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n";
         print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n";
         print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n";
 	print "else\n";
-        print "COQLIBINSTALL=${COQLIB}user-contrib\n";
-        print "COQDOCINSTALL=${DOCDIR}user-contrib\n";
+        print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n";
+        print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n";
+        print "COQTOPINSTALL=\"${COQLIB}toploop\"\n";
 	print "endif\n\n"
       | Project_file.TraditionalInstall ->
           section "Install Paths.";
-          print "COQLIBINSTALL=${COQLIB}user-contrib\n";
-          print "COQDOCINSTALL=${DOCDIR}user-contrib\n";
+          print "COQLIBINSTALL=\"${COQLIB}user-contrib\"\n";
+          print "COQDOCINSTALL=\"${DOCDIR}user-contrib\"\n";
+          print "COQTOPINSTALL=\"${COQLIB}toploop\"\n";
           print "\n"
       | Project_file.UserInstall ->
           section "Install Paths.";
-          print "XDG_DATA_HOME?=$(HOME)/.local/share\n";
+          print "XDG_DATA_HOME?=\"$(HOME)/.local/share\"\n";
           print "COQLIBINSTALL=$(XDG_DATA_HOME)/coq\n";
           print "COQDOCINSTALL=$(XDG_DATA_HOME)/doc/coq\n";
+          print "COQTOPINSTALL=$(XDG_DATA_HOME)/coq/toploop\n";
           print "\n"
 
 let parameters () =
   print ".DEFAULT_GOAL := all\n\n# \n";
   print "# This Makefile may take arguments passed as environment variables:\n";
   print "# COQBIN to specify the directory where Coq binaries resides;\n";
+  print "# TIMECMD set a command to log .v compilation time;\n";
+  print "# TIMED if non empty, use the default time command as TIMECMD;\n";
   print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n";
   print "# DSTROOT to specify a prefix to install path.\n\n";
   print "# Here is a hack to make $(eval $(shell works:\n";
   print "define donewline\n\n\nendef\n";
   print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n";
-  print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n"
-
-let include_dirs (inc_i,inc_r) =
-  let parse_includes l = List.map (fun (x,_) -> "-I " ^ x) l in
-  let parse_rec_includes l =
-    List.map (fun (p,l,_) ->
-      let l' = if l = "" then "\"\"" else l in "-R " ^ p ^ " " ^ l')
-      l in
-  let inc_i' = List.filter (fun (_,i) -> not (List.exists (fun (_,_,i') -> is_prefix i' i) inc_r)) inc_i in
+  print "$(call includecmdwithout@,$(COQBIN)coqtop -config)\n\n";
+  print "TIMED=\nTIMECMD=\nSTDTIME?=/usr/bin/time -f \"$* (user: %U mem: %M ko)\"\n";
+  print "TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD))\n\n";
+  print "vo_to_obj = $(addsuffix .o,\\\n";
+  print "  $(filter-out Warning: Error:,\\\n";
+  print "  $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1))))\n\n"
+
+let include_dirs (inc_ml,inc_i,inc_r) =
+  let parse_ml_includes l = List.map (fun (x,_) -> "-I \"" ^ x ^ "\"") l in
+  let parse_includes l = List.map (fun (x,l,_) ->
+				   let l' = if l = "" then "\"\"" else l in
+				   "-Q \"" ^ x ^ "\" " ^ l' ^"") l in
+  let parse_rec_includes l = List.map (fun (p,l,_) ->
+				       let l' = if l = "" then "\"\"" else l in
+				       "-R \"" ^ p ^ "\" " ^ l' ^"") l in
+  let str_ml = parse_ml_includes inc_ml in
   let str_i = parse_includes inc_i in
-  let str_i' = parse_includes inc_i' in
   let str_r = parse_rec_includes inc_r in
     section "Libraries definitions.";
     if !some_ml4file || !some_mlfile || !some_mlifile then begin
-      print "OCAMLLIBS?="; print_list "\\\n  " str_i; print "\n";
+      print "OCAMLLIBS?="; print_list "\\\n  " str_ml; print "\n";
     end;
     if !some_vfile || !some_mllibfile || !some_mlpackfile then begin
-      print "COQLIBS?="; print_list "\\\n  " str_i'; print " "; print_list "\\\n  " str_r; print "\n";
-      print "COQDOCLIBS?=";   print_list "\\\n  " str_r; print "\n\n";
+      print "COQLIBS?="; print_list "\\\n  " str_i;
+      List.iter (fun x -> print "\\\n  "; print x) str_r;
+      List.iter (fun x -> print "\\\n  "; print x) str_ml; print "\n";
+      print "COQDOCLIBS?="; print_list "\\\n  " str_i;
+      List.iter (fun x -> print "\\\n  "; print x) str_r; print "\n\n";
     end
 
 let custom sps =
-  let pr_path (file,dependencies,com) =
+  let pr_path (file,dependencies,is_phony,com) =
     print file; print ": "; print dependencies; print "\n";
-    if com <> "" then (print "\t"; print com); print "\n\n"
+    if com <> "" then (print "\t"; print com; print "\n");
+    print "\n"
   in
     if sps <> [] then section "Custom targets.";
     List.iter pr_path sps
 
 let subdirs sds =
   let pr_subdir s =
-    print s; print ":\n\tcd "; print s; print " ; $(MAKE) all\n\n"
+    print s; print ":\n\t+cd \""; print s; print "\" && $(MAKE) all\n\n"
   in
     if sds <> [] then section "Subdirectories.";
     List.iter pr_subdir sds
@@ -470,13 +568,17 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
   begin match vfiles with
     |[] -> ()
     |l ->
-      print "VOFILES:=$(VFILES:.v=.vo)\n";
+      print "VO=vo\n";
+      print "VOFILES:=$(VFILES:.v=.$(VO))\n";
       classify_files_by_root "VOFILES" l inc;
       print "GLOBFILES:=$(VFILES:.v=.glob)\n";
-      print "VIFILES:=$(VFILES:.v=.vi)\n";
       print "GFILES:=$(VFILES:.v=.g)\n";
       print "HTMLFILES:=$(VFILES:.v=.html)\n";
-      print "GHTMLFILES:=$(VFILES:.v=.g.html)\n"
+      print "GHTMLFILES:=$(VFILES:.v=.g.html)\n";
+      print "OBJFILES=$(call vo_to_obj,$(VOFILES))\n";
+      print "ALLNATIVEFILES=$(OBJFILES:.o=.cmi) $(OBJFILES:.o=.cmo) $(OBJFILES:.o=.cmx) $(OBJFILES:.o=.cmxs)\n";
+      print "NATIVEFILES=$(foreach f, $(ALLNATIVEFILES), $(wildcard $f))\n";
+      classify_files_by_root "NATIVEFILES" l inc
   end;
   decl_var "ML4FILES" ml4files;
   decl_var "MLFILES" mlfiles;
@@ -566,7 +668,9 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
     end;
   if !some_vfile then
     begin
-      print "spec: $(VIFILES)\n\n";
+      print "quick: $(VOFILES:.vo=.vio)\n\n";
+      print "vio2vo:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio)\n";
+      print "checkproofs:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio)\n";
       print "gallina: $(GFILES)\n\n";
       print "html: $(GLOBFILES) $(VFILES)\n";
       print "\t- mkdir -p html\n";
@@ -591,13 +695,18 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other
     end
 
 let all_target (vfiles, (_,_,_,_,mlpackfiles as mlfiles), sps, sds) inc =
-  let special_targets = List.filter (fun (n,_,_) -> not (is_genrule n)) sps in
-  let other_targets = List.map (function x,_,_ -> x) special_targets @ sds in
+  let other_targets = CList.map_filter
+    (fun (n,_,is_phony,_) -> if not (is_phony || is_genrule n) then Some n else None)
+    sps @ sds in
   main_targets vfiles mlfiles other_targets inc;
     print ".PHONY: ";
     print_list " "
-      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install"
-	:: "userinstall" :: "depend" :: "html" :: "validate" :: sds);
+      ("all" ::  "opt" :: "byte" :: "archclean" :: "clean" :: "install" ::
+	  "uninstall_me.sh" :: "uninstall" :: "userinstall" :: "depend" ::
+	  "html" :: "validate" ::
+	    (sds@(CList.map_filter
+		    (fun (n,_,is_phony,_) ->
+		     if is_phony then Some n else None) sps)));
     print "\n\n";
     custom sps;
     subdirs sds;
@@ -628,38 +737,38 @@ let command_line args =
   print_list args;
   print "\n#\n\n"
 
-let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((i_inc,r_inc) as l) =
+let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l) =
   let here = Sys.getcwd () in
   let not_tops =List.for_all (fun s -> s <> Filename.basename s) in
-  if List.exists (fun (_,x) -> x = here) i_inc
-    or List.exists (fun (_,_,x) -> is_prefix x here) r_inc
-    or (not_tops v && not_tops mli && not_tops ml4 && not_tops ml
+  if List.exists (fun (_,_,x) -> x = here) i_inc
+    || List.exists (fun (_,_,x) -> is_prefix x here) r_inc
+    || (not_tops v && not_tops mli && not_tops ml4 && not_tops ml
 	&& not_tops mllib && not_tops mlpack) then
     l
   else
-    ((".",here)::i_inc,r_inc)
+    ((".",here)::ml_inc,(".","Top",here)::i_inc,r_inc)
 
 let warn_install_at_root_directory
-    (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_i,inc_r) =
-  let inc_r_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r in
-  let inc_top = List.map (fun (p,_,_) -> p) inc_r_top in
+    (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) =
+  let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") inc_r@inc_i in
+  let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in
   let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in
-  if inc_r = [] || List.exists (fun f -> List.mem (Filename.dirname f) inc_top) files
+  if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files
   then
-    Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n"
-      (if inc_r_top = [] then "" else "with non trivial logical root ")
+    Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R or -Q %sis recommended\n"
+      (if inc_top = [] then "" else "with non trivial logical root ")
 
-let check_overlapping_include (_,inc_r) =
+let check_overlapping_include (_,inc_i,inc_r) =
   let pwd = Sys.getcwd () in
-  let rec aux = function
+  let aux = function
     | [] -> ()
     | (pdir,_,abspdir)::l ->
 	if not (is_prefix pwd abspdir) then
 	  Printf.eprintf "Warning: in option -R, %s is not a subdirectory of the current directory\n" pdir;
 	List.iter (fun (pdir',_,abspdir') ->
-	  if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then
+	  if is_prefix abspdir abspdir' || is_prefix abspdir' abspdir then
 	    Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l;
-  in aux inc_r
+  in aux (inc_i@inc_r)
 
 let do_makefile args =
   let has_file var = function
@@ -686,7 +795,7 @@ let do_makefile args =
     else if (Filename.check_suffix f ".mllib") then some_mllibfile := true
     else if (Filename.check_suffix f ".mlpack") then some_mlpackfile := true
   in
-  List.iter (fun (_,dependencies,_) ->
+  List.iter (fun (_,dependencies,_,_) ->
     List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps;
 
   let inc = ensure_root_dir targets inc in
diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml
index ca21f706..383a68df 100644
--- a/tools/coq_tex.ml
+++ b/tools/coq_tex.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        *)
@@ -79,7 +79,7 @@ let expos   = Str.regexp "^"
 
 let tex_escaped s =
   let dollar = "\\$" and  backslash = "\\\\" and expon = "\\^" in
-  let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>]") in
+  let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>']") in
   let adapt_delim = function
     | "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c
     | "\\" -> "{\\char'134}"
@@ -88,6 +88,7 @@ let tex_escaped s =
     | " " -> "~"
     | "<" -> "{<}"
     | ">" -> "{>}"
+    | "'" -> "{\\textquotesingle}"
     | _ -> assert false
   in
   let adapt = function
@@ -116,7 +117,7 @@ let insert texfile coq_output result =
   let next_block k =
     if !last_read = "" then last_read := input_line c_coq;
     (* skip k prompts *)
-    for i = 1 to k do
+    for _i = 1 to k do
       last_read := remove_prompt !last_read;
     done;
     (* read and return the following lines until a prompt is found *)
@@ -170,9 +171,10 @@ let insert texfile coq_output result =
     if Str.string_match end_coq_example s 0 then begin
       just_after ()
     end else begin
-      if !verbose then Printf.printf "Coq < %s\n" s;
-      if (not first_block) & k=0 then output_string c_out "\\medskip\n";
-      if show_questions then encapsule false c_out ("Coq < " ^ s);
+      let prompt = if k = 0 then "Coq < " else "      " in
+      if !verbose then Printf.printf "%s%s\n" prompt s;
+      if (not first_block) && k=0 then output_string c_out "\\medskip\n";
+      if show_questions then encapsule false c_out (prompt ^ s);
       if has_match dot_end_line s then begin
 	let bl = next_block (succ k) in
 	if !verbose then List.iter print_endline bl;
@@ -209,7 +211,7 @@ let insert texfile coq_output result =
 
 (* Process of one TeX file *)
 
-let rm f = try Sys.remove f with _ -> ()
+let rm f = try Sys.remove f with any -> ()
 
 let one_file texfile =
   let inputv = Filename.temp_file "coq_tex" ".v" in
@@ -233,9 +235,9 @@ let one_file texfile =
     insert texfile coq_output result;
     (* 4. clean up *)
     rm inputv; rm coq_output
-  with e -> begin
+  with reraise -> begin
     rm inputv; rm coq_output;
-    raise e
+    raise reraise
   end
 
 (* Parsing of the command line, check of the Coq command and process
diff --git a/scripts/coqc.ml b/tools/coqc.ml
index 8cdac0c5..f636ffd8 100644
--- a/scripts/coqc.ml
+++ b/tools/coqc.ml
@@ -1,72 +1,42 @@
 (************************************************************************)
 (*  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        *)
 (************************************************************************)
 
-(* Afin de rendre Coq plus portable, ce programme Caml remplace le script
-   coqc.
+(** Coq compiler : coqc *)
 
-   Ici, on trie la ligne de commande pour en extraire les fichiers à compiler,
-   puis on les compile un par un en passant le reste de la ligne de commande
-   à un process "coqtop -batch -load-vernac-source <fichier>".
+(** For improving portability, coqc is now an OCaml program instead
+    of a shell script. We use as much as possible the Sys and Filename
+    module for better portability, but the Unix module is still used
+    here and there (with explicitly qualified function names Unix.foo).
 
-   On essaye au maximum d'utiliser les modules Sys et Filename pour que la
-   portabilité soit maximale, mais il reste encore des appels à des fonctions
-   du module Unix. Ceux-ci sont préfixés par "Unix."
+    We process here the commmand line to extract names of files to compile,
+    then we compile them one by one while passing by the rest of the command
+    line to a process running "coqtop -batch -compile <file>".
 *)
 
-(* environment *)
+(* Environment *)
 
 let environment = Unix.environment ()
 
-let best = if Coq_config.arch = "win32" then "" else ("."^Coq_config.best)
-let binary = ref ("coqtop" ^ best)
+let binary = ref "coqtop"
 let image = ref ""
 
-(* coqc options *)
-
 let verbose = ref false
 
-(* Verifies that a string starts by a letter and do not contain
-   others caracters than letters, digits, or `_` *)
-
-let check_module_name s =
-  let err c =
-    output_string stderr "Invalid module name: ";
-    output_string stderr s;
-    output_string stderr " character ";
-    if c = '\'' then
-      output_string stderr "\"'\""
-    else
-      (output_string stderr"'"; output_char stderr c; output_string stderr"'");
-    output_string stderr " is not allowed in module names\n";
-    exit 1
-  in
-  match String.get s 0 with
-    | 'a' .. 'z' | 'A' .. 'Z' ->
-	for i = 1 to (String.length s)-1 do
-	  match String.get s i with
-	    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_'  -> ()
-	    | c -> err c
-	done
-    | c -> err c
-
 let rec make_compilation_args = function
   | [] -> []
   | file :: fl ->
-      let name_no_suffix =
+      let file_noext =
         if Filename.check_suffix file ".v" then
           Filename.chop_suffix file ".v"
-        else
-          file
+        else file
       in
-      let modulename = Filename.basename name_no_suffix  in
-      check_module_name modulename;
       (if !verbose then "-compile-verbose" else "-compile")
-      :: name_no_suffix :: (make_compilation_args fl)
+      :: file_noext :: (make_compilation_args fl)
 
 (* compilation of files [files] with command [command] and args [args] *)
 
@@ -86,47 +56,82 @@ let compile command args files =
   | _ ->
      Unix.execvpe command (Array.of_list args') environment
 
-(* parsing of the command line
- *
- * special treatment for -bindir and -i.
- * other options are passed to coqtop *)
-
 let usage () =
   Usage.print_usage_coqc () ;
   flush stderr ;
   exit 1
 
+(* parsing of the command line *)
+let extra_arg_needed = ref true
+
 let parse_args () =
   let rec parse (cfiles,args) = function
     | [] ->
 	List.rev cfiles, List.rev args
     | ("-verbose" | "--verbose") :: rem ->
 	verbose := true ; parse (cfiles,args) rem
-    | "-image" :: f :: rem ->
-	image := f; parse (cfiles,args) rem
-    | "-image" :: [] ->
-	usage ()
-    | "-byte" :: rem ->
-       binary := "coqtop.byte"; parse (cfiles,args) rem
-    | "-opt" :: rem ->
-       binary := "coqtop.opt"; parse (cfiles,args) rem
+    | "-image" :: f :: rem -> image := f; parse (cfiles,args) rem
+    | "-image" :: [] ->	usage ()
+    | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem
+    | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem
+
+(* Obsolete options *)
+
     | "-libdir" :: _ :: rem ->
-        print_string "Warning: option -libdir deprecated and ignored\n"; flush stdout;
+        print_string "Warning: option -libdir deprecated and ignored\n";
+        flush stdout;
         parse (cfiles,args) rem
     | ("-db"|"-debugger") :: rem ->
-        print_string "Warning: option -db/-debugger deprecated and ignored\n";flush stdout;
+        print_string "Warning: option -db/-debugger deprecated and ignored\n";
+        flush stdout;
         parse (cfiles,args) rem
 
+(* Informative options *)
+
     | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
+
+    | ("-v"|"--version") :: _ -> Usage.version 0
+
+    | ("-where") :: _ ->
+        Envars.set_coqlib (fun x -> x);
+        print_endline (Envars.coqlib ());
+        exit 0
+
+    | ("-config" | "--config") :: _ ->
+        Envars.set_coqlib (fun x -> x);
+        Usage.print_config ();
+        exit 0
+
+(* Options for coqtop : a) options with 0 argument *)
+
+    | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"
+      |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob"
+      |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet"
+      |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit"
+      |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs"
+      |"-impredicative-set"|"-vm"|"-no-native-compiler"
+      |"-verbose-compat-notations"|"-no-compat-notations"
+      |"-indices-matter"|"-quick"|"-color"
+      |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch"
+      as o) :: rem ->
+	parse (cfiles,o::args) rem
+
+(* Options for coqtop : b) options with 1 argument *)
+
     | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"
       |"-load-vernac-source"|"-l"|"-load-vernac-object"
       |"-load-ml-source"|"-require"|"-load-ml-object"
-      |"-init-file"|"-dump-glob"|"-compat"|"-coqlib" as o) :: rem ->
+      |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"
+      |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs"
+      as o) :: rem ->
 	begin
 	  match rem with
 	    | s :: rem' -> parse (cfiles,s::o::args) rem'
 	    | []        -> usage ()
 	end
+
+(* Options for coqtop : c) options with 1 argument and possibly more *)
+
     | ("-I"|"-include" as o) :: rem ->
 	begin
 	  match rem with
@@ -138,24 +143,14 @@ let parse_args () =
     | "-R" :: s :: "-as" :: t :: rem ->	parse (cfiles,t::"-as"::s::"-R"::args) rem
     | "-R" :: s :: "-as" :: [] -> usage ()
     | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem
+    | "-Q" :: s :: t :: rem -> parse (cfiles,t::s::"-Q"::args) rem
+    | ("-schedule-vio-checking"
+      |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem ->
+        let nodash, rem =
+          CList.split_when (fun x -> String.length x > 1 && x.[0] = '-') rem in
+        extra_arg_needed := false;
+        parse (cfiles, List.rev nodash @ s :: o :: args) rem
 
-    | ("-notactics"|"-debug"|"-nolib"|"-boot"
-      |"-batch"|"-nois"|"-noglob"|"-no-glob"
-      |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet"
-      |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit"
-      |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs"
-      |"-impredicative-set"|"-vm" as o) :: rem ->
-	parse (cfiles,o::args) rem
-
-    | ("-where") :: _ ->
-	(try print_endline (Envars.coqlib ())
-	 with Util.UserError(_,pps) -> Pp.msgerrnl (Pp.hov 0 pps));
-	exit 0
-
-    | ("-config" | "--config") :: _ -> Usage.print_config (); exit 0
-
-    | ("-v"|"--version") :: _ ->
-        Usage.version 0
     | f :: rem ->
 	if Sys.file_exists f then
 	  parse (f::cfiles,args) rem
@@ -175,7 +170,7 @@ let parse_args () =
 
 let main () =
   let cfiles, args = parse_args () in
-    if cfiles = [] then begin
+    if cfiles = [] && !extra_arg_needed then begin
       prerr_endline "coqc: too few arguments" ;
       usage ()
     end;
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index 21b4e576..2e0cce6e 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.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        *)
@@ -19,8 +19,9 @@ open Coqdep_common
 let option_D = ref false
 let option_w = ref false
 let option_sort = ref false
+let option_dump = ref None
 
-let rec warning_mult suf iter =
+let warning_mult suf iter =
   let tab = Hashtbl.create 151 in
   let check f d =
     begin try
@@ -35,11 +36,11 @@ let rec warning_mult suf iter =
   in
   iter check
 
-let add_coqlib_known phys_dir log_dir f =
+let add_coqlib_known recur phys_dir log_dir f =
   match get_extension f [".vo"] with
     | (basename,".vo") ->
         let name = log_dir@[basename] in
-	let paths = suffixes name in
+	let paths = if recur then suffixes name else [name] in
         List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths
     | _ -> ()
 
@@ -120,7 +121,7 @@ let traite_Declare f =
 	let s' = basename_noext s in
 	(match search_ml_known s with
 	   | Some mldir when not (List.mem s' !decl_list) ->
-	       let fullname = file_name (String.uncapitalize s') mldir in
+	       let fullname = file_name s' mldir in
 	       let depl = mL_dep_list s (fullname ^ ".ml") in
 	       treat depl;
 	       decl_list := s :: !decl_list
@@ -156,35 +157,319 @@ let declare_dependencies () =
        flush stdout)
     (List.rev !vAccu)
 
+(** DAGs guaranteed to be transitive reductions *)
+module DAG (Node : Set.OrderedType) :
+sig
+  type node = Node.t
+  type t
+  val empty : t
+  val add_transitive_edge : node -> node -> t -> t
+  val iter : (node -> node -> unit) -> t -> unit
+end =
+struct
+  type node = Node.t
+  module NSet = Set.Make(Node)
+  module NMap = Map.Make(Node)
+
+  (** Associate to a node the set of its neighbours *)
+  type _t = NSet.t NMap.t
+
+  (** Optimisation: construct the reverse graph at the same time *)
+  type t = { dir : _t; rev : _t; }
+
+
+  let node_equal x y = Node.compare x y = 0
+
+  let add_edge x y graph =
+    let set = try NMap.find x graph with Not_found -> NSet.empty in
+    NMap.add x (NSet.add y set) graph
+
+  let remove_edge x y graph =
+    let set = try NMap.find x graph with Not_found -> NSet.empty in
+    let set = NSet.remove y set in
+    if NSet.is_empty set then NMap.remove x graph
+    else NMap.add x set graph
+
+  let has_edge x y graph =
+    let set = try NMap.find x graph with Not_found -> NSet.empty in
+    NSet.mem y set
+
+  let connected x y graph =
+    let rec aux rem seen =
+      if NSet.is_empty rem then false
+      else
+        let x = NSet.choose rem in
+        if node_equal x y then true
+        else
+          let rem = NSet.remove x rem in
+          if NSet.mem x seen then
+            aux rem seen
+          else
+            let seen = NSet.add x seen in
+            let next = try NMap.find x graph with Not_found -> NSet.empty in
+            let rem = NSet.union next rem in
+            aux rem seen
+    in
+    aux (NSet.singleton x) NSet.empty
+
+  (** Check whether there is a path from a to b going through the edge
+      x -> y. *)
+  let connected_through a b x y graph =
+    let rec aux rem seen =
+      if NMap.is_empty rem then false
+      else
+        let (n, through) = NMap.choose rem in
+        if node_equal n b && through then true
+        else
+          let rem = NMap.remove n rem in
+          let is_seen = try Some (NMap.find n seen) with Not_found -> None in
+          match is_seen with
+          | None ->
+            let seen = NMap.add n through seen in
+            let next = try NMap.find n graph with Not_found -> NSet.empty in
+            let is_x = node_equal n x in
+            let push m accu =
+              let through = through || (is_x && node_equal m y) in
+              NMap.add m through accu
+            in
+            let rem = NSet.fold push next rem in
+            aux rem seen
+          | Some false ->
+            (** The path we took encountered x -> y but not the one in seen *)
+            if through then aux (NMap.add n true rem) (NMap.add n true seen)
+            else aux rem seen
+          | Some true -> aux rem seen
+    in
+    aux (NMap.singleton a false) NMap.empty
+
+  let closure x graph =
+    let rec aux rem seen =
+      if NSet.is_empty rem then seen
+      else
+        let x = NSet.choose rem in
+        let rem = NSet.remove x rem in
+        if NSet.mem x seen then 
+          aux rem seen
+        else
+          let seen = NSet.add x seen in
+          let next = try NMap.find x graph with Not_found -> NSet.empty in
+          let rem = NSet.union next rem in
+          aux rem seen
+    in
+    aux (NSet.singleton x) NSet.empty
+
+    let empty = { dir = NMap.empty; rev = NMap.empty; }
+
+    (** Online transitive reduction algorithm *)
+    let add_transitive_edge x y graph =
+      if connected x y graph.dir then graph
+      else
+        let dir = add_edge x y graph.dir in
+        let rev = add_edge y x graph.rev in
+        let graph = { dir; rev; } in
+        let ancestors = closure x rev in
+        let descendents = closure y dir in
+        let fold_ancestor a graph =
+          let fold_descendent b graph =
+            let to_remove = has_edge a b graph.dir in
+            let to_remove = to_remove && not (node_equal x a && node_equal y b) in
+            let to_remove = to_remove && connected_through a b x y graph.dir in
+            if to_remove then
+              let dir = remove_edge a b graph.dir in
+              let rev = remove_edge b a graph.rev in
+              { dir; rev; }
+            else graph
+          in
+          NSet.fold fold_descendent descendents graph
+        in
+        NSet.fold fold_ancestor ancestors graph
+
+  let iter f graph =
+    let iter x set = NSet.iter (fun y -> f x y) set in
+    NMap.iter iter graph.dir
+
+end
+
+module Graph =
+struct
+(** Dumping a dependency graph **)
+
+module DAG = DAG(struct type t = string let compare = compare end)
+
+(** TODO: we should share this code with Coqdep_common *)
+let treat_coq_file chan =
+  let buf = Lexing.from_channel chan in
+  let deja_vu_v = ref ([]: string list list)
+  and deja_vu_ml = ref ([] : string list) in
+  let mark_v_done acc str =
+    let seen = List.mem str !deja_vu_v in
+    if not seen then
+      let () = addQueue deja_vu_v str in
+      try
+        let file_str = Hashtbl.find vKnown str in
+        (canonize file_str, !suffixe) :: acc
+      with Not_found -> acc
+    else acc
+  in
+  let rec loop acc =
+    let token = try Some (coq_action buf) with Fin_fichier -> None in
+    match token with
+    | None -> acc
+    | Some action ->
+      let acc = match action with
+      | Require strl ->
+        List.fold_left mark_v_done acc strl
+      | RequireString s ->
+        let str = Filename.basename s in
+        mark_v_done acc [str]
+      | Declare sl ->
+        let declare suff dir s =
+          let base = file_name s dir in
+          let opt = if !option_natdynlk then " " ^ base ^ ".cmxs" else "" in
+          (escape base, suff ^ opt)
+        in
+        let decl acc str =
+          let s = basename_noext str in
+          if not (List.mem s !deja_vu_ml) then
+            let () = addQueue deja_vu_ml s in
+            match search_mllib_known s with
+            | Some mldir -> (declare ".cma" mldir s) :: acc
+            | None ->
+              match search_ml_known s with
+              | Some mldir -> (declare ".cmo" mldir s) :: acc
+              | None -> acc
+          else acc
+        in
+        List.fold_left decl acc sl
+      | Load str ->
+        let str = Filename.basename str in
+        let seen = List.mem [str] !deja_vu_v in
+        if not seen then
+          let () = addQueue deja_vu_v [str] in
+          try
+            let file_str = Hashtbl.find vKnown [str] in
+            (canonize file_str, ".v") :: acc
+          with Not_found -> acc
+        else acc
+      | AddLoadPath _ | AddRecLoadPath _ -> acc (** TODO *)
+      in
+      loop acc
+  in
+  loop []
+
+let treat_coq_file f =
+  let chan = try Some (open_in f) with Sys_error _ -> None in
+  match chan with
+  | None -> []
+  | Some chan ->
+    try
+      let ans = treat_coq_file chan in
+      let () = close_in chan in
+      ans
+    with Syntax_error (i, j) -> close_in chan; error_cannot_parse f (i, j)
+
+type graph =
+  | Element of string
+  | Subgraph of string * graph list
+
+let rec insert_graph name path graphs = match path, graphs with
+  | [] , graphs -> (Element name) :: graphs
+  | (box :: boxes), (Subgraph (hd, names)) :: tl when hd = box ->
+    Subgraph (hd, insert_graph name boxes names) :: tl
+  | _, hd :: tl -> hd :: (insert_graph name path tl)
+  | (box :: boxes), [] -> [ Subgraph (box, insert_graph name boxes []) ]
+
+let print_graphs chan graph =
+  let rec print_aux name = function
+  | [] -> name
+  | (Element str) :: tl -> fprintf chan "\"%s\";\n" str; print_aux name tl
+  | Subgraph (box, names) :: tl ->
+    fprintf chan "subgraph cluster%n {\nlabel=\"%s\";\n" name box;
+    let name = print_aux (name + 1) names in
+    fprintf chan "}\n"; print_aux name tl
+  in
+  ignore (print_aux 0 graph)
+
+let rec pop_common_prefix = function
+  | [Subgraph (_, graphs)] -> pop_common_prefix graphs
+  | graphs -> graphs
+
+let split_path = Str.split (Str.regexp "/")
+
+let rec pop_last = function
+  | [] -> []
+  | [ x ] -> []
+  | x :: xs -> x :: pop_last xs
+
+let get_boxes path = pop_last (split_path path)
+
+let insert_raw_graph file =
+  insert_graph file (get_boxes file)
+
+let rec get_dependencies name args =
+  let vdep  = treat_coq_file (name ^ ".v") in
+  let fold (deps, graphs, alseen) (dep, _) =
+    let dag = DAG.add_transitive_edge name dep deps in
+    if not (List.mem dep alseen) then
+      get_dependencies dep (dag, insert_raw_graph dep graphs, dep :: alseen)
+    else
+      (dag, graphs, alseen)
+  in
+  List.fold_left fold args vdep
+
+let coq_dependencies_dump chan dumpboxes =
+  let (deps, graphs, _) =
+    List.fold_left (fun ih (name, _) -> get_dependencies name ih)
+    (DAG.empty, List.fold_left (fun ih (file, _) -> insert_raw_graph file ih) [] !vAccu,
+    List.map fst !vAccu) !vAccu
+  in
+  fprintf chan "digraph dependencies {\n"; flush chan;
+  if dumpboxes then print_graphs chan (pop_common_prefix graphs)
+  else List.iter (fun (name, _) -> fprintf chan "\"%s\"[label=\"%s\"]\n" name (basename_noext name)) !vAccu;
+  DAG.iter (fun name dep -> fprintf chan "\"%s\" -> \"%s\"\n" dep name) deps;
+  fprintf chan "}\n"
+
+end
+
 let usage () =
   eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-R dir coqdir] <filename>+\n";
   eprintf " extra options:\n";
   eprintf "  -coqlib dir : set the coq standard library directory\n";
-  eprintf "  -exclude-dir f : skip subdirectories named f during -R search\n";
+  eprintf "  -exclude-dir f : skip subdirectories named 'f' during -R search\n";
+  eprintf "  -dumpgraph f : print a dot dependency graph in file 'f'\n";
   exit 1
 
+let split_period = Str.split (Str.regexp (Str.quote "."))
+
 let rec parse = function
   | "-c" :: ll -> option_c := true; parse ll
   | "-D" :: ll -> option_D := true; parse ll
   | "-w" :: ll -> option_w := true; parse ll
-  | "-boot" :: ll -> Flags.boot := true; parse ll
+  | "-boot" :: ll -> option_boot := true; parse ll
   | "-sort" :: ll -> option_sort := true; parse ll
   | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll
-  | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r [ln]; parse ll
+  | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r [];
+    add_dir add_known r (split_period ln);
+    parse ll
   | "-I" :: r :: "-as" :: [] -> usage ()
-  | "-I" :: r :: ll -> add_dir add_known r []; parse ll
+  | "-I" :: r :: ll -> add_caml_dir r; parse ll
   | "-I" :: [] -> usage ()
-  | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll
+  | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll
   | "-R" :: r :: "-as" :: [] -> usage ()
-  | "-R" :: r :: ln :: ll -> add_rec_dir add_known r [ln]; parse ll
+  | "-R" :: r :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll
+  | "-Q" :: r :: ln :: ll -> add_dir add_known r (split_period ln); parse ll
   | "-R" :: ([] | [_]) -> usage ()
+  | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll
+  | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll
   | "-exclude-dir" :: r :: ll -> norec_dirnames := r::!norec_dirnames; parse ll
   | "-exclude-dir" :: [] -> usage ()
   | "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll
   | "-coqlib" :: [] -> usage ()
   | "-suffix" :: s :: ll -> suffixe := s ; parse ll
   | "-suffix" :: [] -> usage ()
-  | "-slash" :: ll -> option_slash := true; parse ll
+  | "-slash" :: ll ->
+    Printf.eprintf "warning: option -slash has no effect and is deprecated.\n";
+    parse ll
   | ("-h"|"--help"|"-help") :: _ -> usage ()
   | f :: ll -> treat_file None f; parse ll
   | [] -> ()
@@ -194,26 +479,42 @@ let coqdep () =
   parse (List.tl (Array.to_list Sys.argv));
   if not Coq_config.has_natdynlink then option_natdynlk := false;
   (* NOTE: These directories are searched from last to first *)
-  if !Flags.boot then begin
+  if !option_boot then begin
     add_rec_dir add_known "theories" ["Coq"];
-    add_rec_dir add_known "plugins" ["Coq"]
+    add_rec_dir add_known "plugins" ["Coq"];
+    add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"];
+    add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"];
   end else begin
+    Envars.set_coqlib ~fail:Errors.error;
     let coqlib = Envars.coqlib () in
     add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"];
     add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"];
     let user = coqlib//"user-contrib" in
-    if Sys.file_exists user then add_rec_dir add_coqlib_known user [];
-    List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.xdg_dirs;
-    List.iter (fun s -> add_rec_dir add_coqlib_known s []) Envars.coqpath;
+    if Sys.file_exists user then add_dir add_coqlib_known user [];
+    List.iter (fun s -> add_dir add_coqlib_known s [])
+      (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x)));
+    List.iter (fun s -> add_dir add_coqlib_known s []) Envars.coqpath;
   end;
-  List.iter (fun (f,d) -> add_mli_known f d) !mliAccu;
-  List.iter (fun (f,d) -> add_mllib_known f d) !mllibAccu;
-  List.iter (fun (f,_,d) -> add_ml_known f d) !mlAccu;
+  List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu;
+  List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu;
+  List.iter (fun (f,suff,d) -> add_ml_known f d suff) !mlAccu;
   warning_mult ".mli" iter_mli_known;
   warning_mult ".ml" iter_ml_known;
   if !option_sort then begin sort (); exit 0 end;
   if !option_c && not !option_D then mL_dependencies ();
   if not !option_D then coq_dependencies ();
-  if !option_w || !option_D then declare_dependencies ()
+  if !option_w || !option_D then declare_dependencies ();
+  begin match !option_dump with
+  | None -> ()
+  | Some (box, file) ->
+    let chan = open_out file in
+    try Graph.coq_dependencies_dump chan box; close_out chan
+    with e -> close_out chan; raise e
+  end
 
-let _ = Printexc.catch coqdep ()
+let _ =
+  try
+    coqdep ()
+  with Errors.UserError(s,p) ->
+    let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in
+    Pp.msgerrnl pp
diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml
index bcc9f33f..bc3435a6 100644
--- a/tools/coqdep_boot.ml
+++ b/tools/coqdep_boot.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        *)
@@ -16,7 +16,6 @@ open Coqdep_common
 *)
 
 let rec parse = function
-  | "-slash" :: ll -> option_slash := true; parse ll
   | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll
   | "-c" :: ll -> option_c := true; parse ll
   | "-boot" :: ll -> parse ll (* We're already in boot mode by default *)
@@ -25,20 +24,26 @@ let rec parse = function
   | "-I" :: r :: ll ->
        (* To solve conflict (e.g. same filename in kernel and checker)
           we allow to state an explicit order *)
-       add_dir add_known r [];
+       add_caml_dir r;
        norec_dirs:=r::!norec_dirs;
        parse ll
   | f :: ll -> treat_file None f; parse ll
   | [] -> ()
 
 let coqdep_boot () =
+  let () = option_boot := true in
   if Array.length Sys.argv < 2 then exit 1;
   parse (List.tl (Array.to_list Sys.argv));
-  if !option_c then
-    add_rec_dir add_known "." []
+  if !option_c then begin
+    add_rec_dir add_known "." [];
+    add_rec_dir (fun _ -> add_caml_known) "." ["Coq"];
+  end
   else begin
     add_rec_dir add_known "theories" ["Coq"];
     add_rec_dir add_known "plugins" ["Coq"];
+    add_caml_dir "tactics";
+    add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"];
+    add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"];
   end;
   if !option_c then mL_dependencies ();
   coq_dependencies ()
diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml
index 253fb037..2e6a15ce 100644
--- a/tools/coqdep_common.ml
+++ b/tools/coqdep_common.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        *)
@@ -22,8 +22,8 @@ let stdout = Pervasives.stdout
 
 let option_c = ref false
 let option_noglob = ref false
-let option_slash = ref false
 let option_natdynlk = ref true
+let option_boot = ref false
 let option_mldep = ref None
 
 let norec_dirs = ref ([] : string list)
@@ -33,9 +33,19 @@ let suffixe = ref ".vo"
 
 type dir = string option
 
-(* filename for printing *)
-let (//) s1 s2 =
-  if !option_slash then s1^"/"^s2 else Filename.concat s1 s2
+(* Filename.concat but always with a '/' *)
+let is_dir_sep s i =
+  match Sys.os_type with
+  | "Unix" -> s.[i] = '/'
+  | "Cygwin" | "Win32" ->
+    let c = s.[i] in c = '/' || c = '\\' || c = ':'
+  | _ -> assert false
+
+let (//) dirname filename =
+  let l = String.length dirname in
+  if l = 0 || is_dir_sep dirname (l-1)
+  then dirname ^ filename
+  else dirname ^ "/" ^ filename
 
 (** [get_extension f l] checks whether [f] has one of the extensions
     listed in [l]. It returns [f] without its extension, alongside with
@@ -51,7 +61,7 @@ let rec get_extension f = function
 
 let basename_noext filename =
   let fn = Filename.basename filename in
-  try Filename.chop_extension fn with _ -> fn
+  try Filename.chop_extension fn with Invalid_argument _ -> fn
 
 (** ML Files specified on the command line. In the entries:
     - the first string is the basename of the file, without extension nor
@@ -76,10 +86,10 @@ let vAccu   = ref ([] : (string * string) list)
 
 let addQueue q v = q := v :: !q
 
-let safe_hash_add clq q (k,v) =
+let safe_hash_add cmp clq q (k,v) =
   try
     let v2 = Hashtbl.find q k in
-    if v<>v2 then
+    if not (cmp v v2) then
       let rec add_clash = function
           (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl
         | cl::cltl -> cl::add_clash cltl
@@ -91,19 +101,24 @@ let safe_hash_add clq q (k,v) =
 
 (** Files found in the loadpaths.
     For the ML files, the string is the basename without extension.
-    To allow ML source filename to be potentially capitalized,
-    we perform a double search.
 *)
 
+let warning_ml_clash x s suff s' suff' =
+  if suff = suff' then
+  eprintf
+    "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff
+    (match s with None -> "." | Some d -> d)
+    ((match s' with None -> "." | Some d -> d) // x) suff
+
 let mkknown () =
-  let h = (Hashtbl.create 19 : (string, dir) Hashtbl.t) in
-  let add x s = if Hashtbl.mem h x then () else Hashtbl.add h x s
-  and iter f = Hashtbl.iter f h
+  let h = (Hashtbl.create 19 : (string, dir * string) Hashtbl.t) in
+  let add x s suff =
+    try let s',suff' = Hashtbl.find h x in warning_ml_clash x s' suff' s suff
+    with Not_found -> Hashtbl.add h x (s,suff)
+  and iter f = Hashtbl.iter (fun x (s,_) -> f x s) h
   and search x =
-    try Some (Hashtbl.find h (String.uncapitalize x))
-    with Not_found ->
-      try Some (Hashtbl.find h (String.capitalize x))
-      with Not_found -> None
+    try Some (fst (Hashtbl.find h x))
+    with Not_found -> None
   in add, iter, search
 
 let add_ml_known, iter_ml_known, search_ml_known = mkknown ()
@@ -122,7 +137,7 @@ let error_cannot_parse s (i,j) =
 
 let warning_module_notfound f s =
   eprintf "*** Warning: in file %s, library " f;
-  eprintf "%s.v is required and has not been found in loadpath!\n"
+  eprintf "%s.v is required and has not been found in the loadpath!\n"
     (String.concat "." s);
   flush stderr
 
@@ -142,7 +157,7 @@ let warning_clash file dir =
       let f = Filename.basename f1 in
       let d1 = Filename.dirname f1 in
       let d2 = Filename.dirname f2 in
-      let dl = List.map Filename.dirname (List.rev fl) in
+      let dl = List.rev_map Filename.dirname fl in
       eprintf
         "*** Warning: in file %s, \n    required library %s matches several files in path\n    (found %s.v in "
         file (String.concat "." dir) f;
@@ -265,10 +280,10 @@ let escape =
     Buffer.clear s';
     for i = 0 to String.length s - 1 do
       let c = s.[i] in
-      if c = ' ' or c = '#' or c = ':' (* separators and comments *)
-	or c = '%' (* pattern *)
-	or c = '?' or c = '[' or c = ']' or c = '*' (* expansion in filenames *)
-	or i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 
+      if c = ' ' || c = '#' || c = ':' (* separators and comments *)
+        || c = '%' (* pattern *)
+	|| c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *)
+	|| i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || 
 	    'A' <= s.[1] && s.[1] <= 'Z' || 
 	    'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *)
       then begin
@@ -283,13 +298,16 @@ let escape =
     done;
     Buffer.contents s'
 
+let compare_file f1 f2 =
+  absolute_dir (Filename.dirname f1) = absolute_dir (Filename.dirname f2)
+
 let canonize f =
   let f' = absolute_dir (Filename.dirname f) // Filename.basename f in
   match List.filter (fun (_,full) -> f' = full) !vAccu with
     | (f,_) :: _ -> escape f
     | _ -> escape f
 
-let rec traite_fichier_Coq verbose f =
+let rec traite_fichier_Coq suffixe verbose f =
   try
     let chan = open_in f in
     let buf = Lexing.from_channel chan in
@@ -305,7 +323,7 @@ let rec traite_fichier_Coq verbose f =
 	          addQueue deja_vu_v str;
                   try
                     let file_str = safe_assoc verbose f str in
-                    printf " %s%s" (canonize file_str) !suffixe
+                    printf " %s%s" (canonize file_str) suffixe
                   with Not_found ->
 		    if verbose && not (Hashtbl.mem coqlibKnown str) then
                       warning_module_notfound f str
@@ -316,7 +334,7 @@ let rec traite_fichier_Coq verbose f =
 	        addQueue deja_vu_v [str];
                 try
                   let file_str = Hashtbl.find vKnown [str] in
-                  printf " %s%s" (canonize file_str) !suffixe
+                  printf " %s%s" (canonize file_str) suffixe
                 with Not_found ->
 		  if not (Hashtbl.mem coqlibKnown [str]) then
 		    warning_notfound f s
@@ -350,7 +368,7 @@ let rec traite_fichier_Coq verbose f =
                   let file_str = Hashtbl.find vKnown [str] in
                   let canon = canonize file_str in
                   printf " %s.v" canon;
-                  traite_fichier_Coq true (canon ^ ".v")
+                  traite_fichier_Coq suffixe true (canon ^ ".v")
                 with Not_found -> ()
        	      end
           | AddLoadPath _ | AddRecLoadPath _ -> (* TODO *) ()
@@ -408,7 +426,10 @@ let coq_dependencies () =
        let ename = escape name in
        let glob = if !option_noglob then "" else " "^ename^".glob" in
        printf "%s%s%s %s.v.beautified: %s.v" ename !suffixe glob ename ename;
-       traite_fichier_Coq true (name ^ ".v");
+       traite_fichier_Coq !suffixe true (name ^ ".v");
+       printf "\n";
+       printf "%s.vio: %s.v" ename ename;
+       traite_fichier_Coq ".vio" true (name ^ ".v");
        printf "\n";
        flush stdout)
     (List.rev !vAccu)
@@ -418,18 +439,28 @@ let rec suffixes = function
   | [name] -> [[name]]
   | dir::suffix as l -> l::suffixes suffix
 
-let add_known phys_dir log_dir f =
-  match get_extension f [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with
+let add_caml_known phys_dir _ f =
+  let basename,suff =
+    get_extension f [".ml";".mli";".ml4";".mllib";".mlpack"] in
+  match suff with
+    | ".ml"|".ml4" -> add_ml_known basename (Some phys_dir) suff
+    | ".mli" -> add_mli_known basename (Some phys_dir) suff
+    | ".mllib" -> add_mllib_known basename (Some phys_dir) suff
+    | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff
+    | _ -> ()
+
+let add_known recur phys_dir log_dir f =
+  match get_extension f [".v";".vo"] with
     | (basename,".v") ->
 	let name = log_dir@[basename] in
 	let file = phys_dir//basename in
-	let paths = suffixes name in
+	let paths = if recur then suffixes name else [name] in
 	List.iter
-	  (fun n -> safe_hash_add clash_v vKnown (n,file)) paths
-    | (basename,(".ml"|".ml4")) -> add_ml_known basename (Some phys_dir)
-    | (basename,".mli") -> add_mli_known basename (Some phys_dir)
-    | (basename,".mllib") -> add_mllib_known basename (Some phys_dir)
-    | (basename,".mlpack") -> add_mlpack_known basename (Some phys_dir)
+	  (fun n -> safe_hash_add compare_file clash_v vKnown (n,file)) paths
+    | (basename,".vo") when not(!option_boot) ->
+        let name = log_dir@[basename] in
+	let paths = if recur then suffixes name else [name] in
+        List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths
     | _ -> ()
 
 (* Visits all the directories under [dir], including [dir],
@@ -456,11 +487,18 @@ let rec add_directory recur add_file phys_dir log_dir =
     done
   with End_of_file -> closedir dirh
 
+(** -Q semantic: go in subdirs but only full logical paths are known. *)
 let add_dir add_file phys_dir log_dir =
-  try add_directory false add_file phys_dir log_dir with Unix_error _ -> ()
+  try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> ()
 
+(** -R semantic: go in subdirs and suffixes of logical paths are known. *)
 let add_rec_dir add_file phys_dir log_dir =
-  handle_unix_error (add_directory true add_file phys_dir) log_dir
+  handle_unix_error (add_directory true (add_file true) phys_dir) log_dir
+
+(** -I semantic: do not go in subdirs. *)
+let add_caml_dir phys_dir =
+  handle_unix_error (add_directory true add_caml_known phys_dir) []
+
 
 let rec treat_file old_dirname old_name =
   let name = Filename.basename old_name
diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli
index b2e01f58..71b96ca0 100644
--- a/tools/coqdep_common.mli
+++ b/tools/coqdep_common.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 @@
 
 val option_c : bool ref
 val option_noglob : bool ref
-val option_slash : bool ref
+val option_boot : bool ref
 val option_natdynlk : bool ref
 val option_mldep : string option ref
 val norec_dirs : string list ref
@@ -23,13 +23,13 @@ val mliAccu : (string * dir) list ref
 val mllibAccu : (string * dir) list ref
 val vAccu : (string * string) list ref
 val addQueue : 'a list ref -> 'a -> unit
-val add_ml_known : string -> dir -> unit
+val add_ml_known : string -> dir -> string -> unit
 val iter_ml_known : (string -> dir -> unit) -> unit
 val search_ml_known : string -> dir option
-val add_mli_known : string -> dir -> unit
+val add_mli_known : string -> dir -> string -> unit
 val iter_mli_known : (string -> dir -> unit) -> unit
 val search_mli_known : string -> dir option
-val add_mllib_known : string -> dir -> unit
+val add_mllib_known : string -> dir -> string -> unit
 val search_mllib_known : string -> dir option
 val vKnown : (string list, string) Hashtbl.t
 val coqlibKnown : (string list, unit) Hashtbl.t
@@ -39,12 +39,15 @@ val canonize : string -> string
 val mL_dependencies : unit -> unit
 val coq_dependencies : unit -> unit
 val suffixes : 'a list -> 'a list list
-val add_known : string -> string list -> string -> unit
+val add_known : bool -> string -> string list -> string -> unit
+val add_caml_known : string -> string list -> string -> unit
 val add_directory :
   bool ->
   (string -> string list -> string -> unit) -> string -> string list -> unit
+val add_caml_dir : string -> unit
 val add_dir :
-  (string -> string list -> string -> unit) -> string -> string list -> unit
+  (bool -> string -> string list -> string -> unit) -> string -> string list -> unit
 val add_rec_dir :
-  (string -> string list -> string -> unit) -> string -> string list -> unit
+  (bool -> string -> string list -> string -> unit) -> string -> string list -> unit
 val treat_file : dir -> string -> unit
+val error_cannot_parse : string -> int * int -> 'a
diff --git a/tools/coqdep_lexer.mli b/tools/coqdep_lexer.mli
index 4806fbb0..b447030a 100644
--- a/tools/coqdep_lexer.mli
+++ b/tools/coqdep_lexer.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/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
index 2cdc6b2e..8ecc419c 100644
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -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        *)
@@ -18,13 +18,11 @@
   type coq_token =
     | Require of qualid list
     | RequireString of string
-    | Declare of string list (* Names are assumed to be uncapitalized *)
+    | Declare of string list
     | Load of string
     | AddLoadPath of string
     | AddRecLoadPath of string * qualid
 
-  let comment_depth = ref 0
-
   exception Fin_fichier
   exception Syntax_error of int*int
 
@@ -49,6 +47,11 @@
 
   let syntax_error lexbuf =
     raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf))
+
+  (** This is the prefix that should be pre-prepended to files due to the use
+   ** of [From], i.e. [From Xxx... Require ...]
+   **)
+  let from_pre_ident = ref None
 }
 
 let space = [' ' '\t' '\n' '\r']
@@ -79,29 +82,72 @@ let dot = '.' ( space+ | eof)
 
 rule coq_action = parse
   | "Require" space+
-      { require_file lexbuf }
-  | "Require" space+ "Export" space+
-      { require_file lexbuf}
-  | "Require" space+ "Import" space+
-      { require_file lexbuf}
+      { require_modifiers lexbuf }
   | "Local"? "Declare" space+ "ML" space+ "Module" space+
-      { mllist := []; modules lexbuf}
+      { mllist := []; modules lexbuf }
   | "Load" space+
       { load_file lexbuf }
   | "Add" space+ "LoadPath" space+
       { add_loadpath lexbuf }
+  | "Time" space+
+      { coq_action lexbuf }
+  | "Timeout" space+ ['0'-'9']+ space+
+      { coq_action lexbuf }
+  | "From" space+
+      { from_rule lexbuf }
   | space+
       { coq_action lexbuf }
   | "(*"
-      { comment_depth := 1; comment lexbuf; coq_action lexbuf }
+      { comment lexbuf; coq_action lexbuf }
   | eof
       { raise Fin_fichier}
   | _
       { skip_to_dot lexbuf; coq_action lexbuf }
 
+and from_rule = parse
+  | "(*"
+      { comment lexbuf; from_rule lexbuf }
+  | space+
+      { from_rule lexbuf }
+  | coq_ident
+      { module_current_name := [Lexing.lexeme lexbuf];
+	from_pre_ident := Some (coq_qual_id_tail lexbuf);
+	module_names := [];
+	consume_require lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { syntax_error lexbuf }
+
+and require_modifiers = parse
+  | "(*"
+      { comment lexbuf; require_modifiers lexbuf }
+  | "Import" space+
+      { require_file lexbuf }
+  | "Export" space+
+      { require_file lexbuf }
+  | space+
+      { require_modifiers lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { backtrack lexbuf ; require_file lexbuf }
+
+and consume_require = parse
+  | "(*"
+      { comment lexbuf; consume_require lexbuf }
+  | space+
+      { consume_require lexbuf }
+  | "Require" space+
+      { require_modifiers lexbuf }
+  | eof
+      { syntax_error lexbuf }
+  | _
+      { syntax_error lexbuf }
+
 and add_loadpath = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; add_loadpath lexbuf }
+      { comment lexbuf; add_loadpath lexbuf }
   | space+
       { add_loadpath lexbuf }
   | eof
@@ -112,7 +158,7 @@ and add_loadpath = parse
 
 and add_loadpath_as = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; add_loadpath_as lexbuf }
+      { comment lexbuf; add_loadpath_as lexbuf }
   | space+
       { add_loadpath_as lexbuf }
   | "as"
@@ -148,8 +194,8 @@ and caml_action = parse
       { caml_action lexbuf }
   | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
       { caml_action lexbuf }
-  | "(*" (* "*)" *)
-      { comment_depth := 1; comment lexbuf; caml_action lexbuf }
+  | "(*"
+      { comment lexbuf; caml_action lexbuf }
   | "#" | "&"  | "&&" | "'" | "(" | ")" | "*" | "," | "?" | "->" | "." | ".."
    | ".(" | ".[" | ":" | "::" | ":=" | ";" | ";;" | "<-" | "=" | "[" | "[|"
    | "[<" | "]" | "_" | "{" | "|" | "||" | "|]" | ">]" | "}" | "!=" | "-"
@@ -174,11 +220,10 @@ and caml_action = parse
   | _ { caml_action lexbuf }
 
 and comment = parse
-  | "(*" (* "*)" *)
-      { comment_depth := succ !comment_depth; comment lexbuf }
+  | "(*"
+      { comment lexbuf; comment lexbuf }
   | "*)"
-      { comment_depth := pred !comment_depth;
-        if !comment_depth > 0 then comment lexbuf }
+      { () }
   | "'" [^ '\\' '\''] "'"
       { comment lexbuf }
   | "'" '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'"
@@ -218,7 +263,7 @@ and load_file = parse
 
 and require_file = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; require_file lexbuf }
+      { comment lexbuf; require_file lexbuf }
   | space+
       { require_file lexbuf }
   | coq_ident
@@ -226,7 +271,12 @@ and require_file = parse
         module_names := [coq_qual_id_tail lexbuf];
         let qid = coq_qual_id_list lexbuf in
         parse_dot lexbuf;
-        Require qid }
+	match !from_pre_ident with
+	  None ->
+          Require qid
+	| Some from ->
+	  (from_pre_ident := None ;
+	   Require (List.map (fun x -> from @ x) qid)) }
   | '"' [^'"']* '"' (*'"'*)
       { let s = Lexing.lexeme lexbuf in
         parse_dot lexbuf;
@@ -248,7 +298,7 @@ and parse_dot = parse
 
 and coq_qual_id = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; coq_qual_id lexbuf }
+      { comment lexbuf; coq_qual_id lexbuf }
   | space+
       { coq_qual_id lexbuf }
   | coq_ident
@@ -264,7 +314,7 @@ and coq_qual_id = parse
 
 and coq_qual_id_tail = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; coq_qual_id_tail lexbuf }
+      { comment lexbuf; coq_qual_id_tail lexbuf }
   | space+
       { coq_qual_id_tail lexbuf }
   | coq_field
@@ -281,7 +331,7 @@ and coq_qual_id_tail = parse
 
 and coq_qual_id_list = parse
   | "(*"
-      { comment_depth := 1; comment lexbuf; coq_qual_id_list lexbuf }
+      { comment lexbuf; coq_qual_id_list lexbuf }
   | space+
       { coq_qual_id_list lexbuf }
   | coq_ident
@@ -299,8 +349,7 @@ and modules = parse
   | space+
       { modules lexbuf }
   | "(*"
-      { comment_depth := 1; comment lexbuf;
-        modules lexbuf }
+      { comment lexbuf; modules lexbuf }
   | '"' [^'"']* '"'
       { let lex = (Lexing.lexeme lexbuf) in
 	let str = String.sub lex 1 (String.length lex - 2) in
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index 6a44684d..c3db3a26 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.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        *)
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
index 9d3593ea..46005741 100644
--- a/tools/coqdoc/alpha.mli
+++ b/tools/coqdoc/alpha.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/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml
index 443edc0b..de7290a4 100644
--- a/tools/coqdoc/cdglobals.ml
+++ b/tools/coqdoc/cdglobals.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        *)
@@ -25,12 +25,14 @@ let out_to = ref MultFiles
 
 let out_channel = ref stdout
 
+let ( / ) = Filename.concat
+
 let coqdoc_out f =
   if !output_dir <> "" && Filename.is_relative f then
     if not (Sys.file_exists !output_dir) then
       (Printf.eprintf "No such directory: %s\n" !output_dir; exit 1)
     else
-      Filename.concat !output_dir f
+      !output_dir / f
   else
     f
 
@@ -71,17 +73,19 @@ let normalize_filename f =
 (** A weaker analog of the function in Envars *)
 
 let guess_coqlib () =
-  let file = "states/initial.coq" in
+  let file = "theories/Init/Prelude.vo" in
   match Coq_config.coqlib with
-    | Some coqlib when Sys.file_exists (Filename.concat coqlib file) ->
-      coqlib
+    | Some coqlib when Sys.file_exists (coqlib / file) -> coqlib
     | Some _ | None ->
       let coqbin = normalize_path (Filename.dirname Sys.executable_name) in
       let prefix = Filename.dirname coqbin in
-      let rpath = if Coq_config.local then [] else
-	  (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in
-      let coqlib = List.fold_left Filename.concat prefix rpath in
-      if Sys.file_exists (Filename.concat coqlib file) then coqlib
+      let rpath =
+        if Coq_config.local then []
+        else if Coq_config.arch_is_win32 then ["lib"]
+        else ["lib/coq"]
+      in
+      let coqlib = List.fold_left (/) prefix rpath in
+      if Sys.file_exists (coqlib / file) then coqlib
       else prefix
 
 let header_trailer = ref true
diff --git a/tools/coqdoc/coqdoc.css b/tools/coqdoc/coqdoc.css
index ccd285f1..dbc930f5 100644
--- a/tools/coqdoc/coqdoc.css
+++ b/tools/coqdoc/coqdoc.css
@@ -75,7 +75,7 @@ h4.section {
                    padding-top: 0px; 
                    padding-bottom: 0px; 
                    font-size : 100%;
-                   font-style : bold;
+                   font-weight : bold;
                    text-decoration : underline;
  }
 
@@ -86,8 +86,7 @@ h4.section {
              max-width: 40em;
              color: black;
 	     padding: 10px;
-             background-color: #90bdff;
-             border-style: plain}
+             background-color: #90bdff }
 
 .inlinecode { 
     display: inline;
@@ -160,8 +159,65 @@ tr.infrulemiddle hr {
 #footer { font-size: 65%;
           font-family: sans-serif; }
 
+/* Identifiers: <span class="id" title="...">) */
+
 .id { display: inline; }
 
+.id[title="constructor"] {
+    color: rgb(60%,0%,0%);
+}
+
+.id[title="var"] {
+    color: rgb(40%,0%,40%);
+}
+
+.id[title="variable"] {
+    color: rgb(40%,0%,40%);
+}
+
+.id[title="definition"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="abbreviation"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="lemma"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="instance"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="projection"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="method"] {
+    color: rgb(0%,40%,0%);
+}
+
+.id[title="inductive"] {
+    color: rgb(0%,0%,80%);
+}
+
+.id[title="record"] {
+    color: rgb(0%,0%,80%);
+}
+
+.id[title="class"] {
+    color: rgb(0%,0%,80%);
+}
+
+.id[title="keyword"] {
+ color : #cf1d1d;
+/*     color: black; */
+}
+
+/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */
+
 .id[type="constructor"] { 
     color: rgb(60%,0%,0%);
 }
@@ -261,7 +317,6 @@ tr.infrulemiddle hr {
 #index #footer {
     position: absolute;
     bottom: 0;
-    text-align: bottom;
 }
 
 .paragraph {
diff --git a/tools/coqdoc/coqdoc.sty b/tools/coqdoc/coqdoc.sty
index 9de9a38f..f49f9f00 100644
--- a/tools/coqdoc/coqdoc.sty
+++ b/tools/coqdoc/coqdoc.sty
@@ -1,5 +1,5 @@
 
-% This is coqdoc.sty, by Jean-Christophe Filliâtre
+% This is coqdoc.sty, by Jean-Christophe Filliâtre
 % This LaTeX package is used by coqdoc (http://www.lri.fr/~filliatr/coqdoc)
 %
 % You can modify the following macros to customize the appearance
diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli
index 390e61d2..4e132ba0 100644
--- a/tools/coqdoc/cpretty.mli
+++ b/tools/coqdoc/cpretty.mli
@@ -1,12 +1,10 @@
 (************************************************************************)
 (*  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 Index
-
 val coq_file : string -> Cdglobals.coq_module -> unit
 val detect_subtitle : string -> Cdglobals.coq_module -> string option
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
index 300d104c..edf7ee8e 100644
--- a/tools/coqdoc/cpretty.mll
+++ b/tools/coqdoc/cpretty.mll
@@ -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        *)
@@ -12,13 +12,6 @@
   open Printf
   open Lexing
 
-  (* A function that emulates Lexing.new_line (which does not exist in OCaml < 3.11.0) *)
-  let new_line lexbuf =
-    let pos = lexbuf.lex_curr_p in
-      lexbuf.lex_curr_p <- { pos with
-	pos_lnum = pos.pos_lnum + 1;
-	pos_bol = pos.pos_cnum }
-
   (* A list function we need *)
   let rec take n ls =
     if n = 0 then [] else
@@ -75,7 +68,6 @@
   let brackets = ref 0
   let comment_level = ref 0
   let in_proof = ref None
-  let in_emph = ref false
 
   let in_env start stop = 
     let r = ref false in
@@ -102,8 +94,6 @@
             let length_skip = 1 + String.length s1 in
               lexbuf.lex_curr_pos <- lexbuf.lex_start_pos + length_skip
 
-  let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
-
   (* saving/restoring the PP state *)
 
   type state = {
@@ -127,8 +117,6 @@
 
   let without_light = without_ref Cdglobals.light
 
-  let show_all f = without_gallina (without_light f)
-
   let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false
   let end_show () = restore_state ()
 
@@ -251,14 +239,6 @@
     with _ ->
       ()
 
-  let extract_ident_re = Str.regexp "([ \t]*\\([^ \t]+\\)[ \t]*:="
-  let extract_ident s =
-    assert (String.length s >= 3);
-    if Str.string_match extract_ident_re s 0 then
-      Str.matched_group 1 s
-    else
-      String.sub s 1 (String.length s - 3)
-
   let output_indented_keyword s lexbuf =
     let nbsp,isp = count_spaces s in
     Output.indentation nbsp;
@@ -282,10 +262,8 @@ let firstchar =
   '\195' ['\152'-'\182'] |
   '\195' ['\184'-'\191'] |
   (* utf-8 letterlike symbols *)
-  (* '\206' ([ '\145' - '\183'] | '\187') | *)
-  (* '\xCF' [ '\x00' - '\xCE' ] |  *)
-  (* utf-8 letterlike symbols *)
-  '\206' (['\145'-'\161'] | ['\163'-'\187']) |
+  '\206' (['\145'-'\161'] | ['\163'-'\191']) |
+  '\207' (['\145'-'\191']) |
   '\226' ('\130' [ '\128'-'\137' ] (* subscripts *)
     | '\129' [ '\176'-'\187' ] (* superscripts *)
     | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143'])
@@ -333,6 +311,7 @@ let def_token =
   | "Boxed"
   | "CoFixpoint"
   | "Record"
+  | "Variant"
   | "Structure"
   | "Scheme"
   | "Inductive"
@@ -345,7 +324,7 @@ let def_token =
 let decl_token =
   "Hypothesis"
   | "Hypotheses"
-  | "Parameter"
+  | "Parameter" 's'?
   | "Axiom" 's'?
   | "Conjecture"
 
@@ -626,7 +605,7 @@ and coq = parse
 	    end
 	  else
 	    begin
-	      Output.ident s (lexeme_start lexbuf);
+	      Output.ident s None;
 	      let eol=body lexbuf in
 		if eol then coq_bol lexbuf else coq lexbuf
 	    end }
@@ -656,17 +635,17 @@ and coq = parse
 	if eol then coq_bol lexbuf else coq lexbuf }
   | gallina_kw
       { let s = lexeme lexbuf in
-	  Output.ident s (lexeme_start lexbuf);
+	  Output.ident s None;
 	let eol = body lexbuf in
 	  if eol then coq_bol lexbuf else coq lexbuf }
   | notation_kw
       { let s = lexeme lexbuf in
-	Output.ident s (lexeme_start lexbuf);
+	Output.ident s None;
 	let eol= start_notation_string lexbuf in
 	if eol then coq_bol lexbuf else coq lexbuf }
   | prog_kw
       { let s = lexeme lexbuf in
-	  Output.ident s (lexeme_start lexbuf);
+	  Output.ident s None;
 	let eol = body lexbuf in
 	  if eol then coq_bol lexbuf else coq lexbuf }
   | space+ { Output.char ' '; coq lexbuf }
@@ -914,11 +893,15 @@ and doc indents = parse
 and escaped_math_latex = parse
   | "$" { Output.stop_latex_math () }
   | eof { Output.stop_latex_math () }
+  | "*)"
+        { Output.stop_latex_math (); backtrack lexbuf }
   | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_math_latex lexbuf }
 
 and escaped_latex = parse
   | "%" { () }
   | eof { () }
+  | "*)"
+        { backtrack lexbuf }
   | _   { Output.latex_char (lexeme_char lexbuf 0); escaped_latex lexbuf }
 
 and escaped_html = parse
@@ -928,12 +911,15 @@ and escaped_html = parse
   | "##"
         { Output.html_char '#'; escaped_html lexbuf }
   | eof { () }
+  | "*)"
+        { backtrack lexbuf }
   | _   { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf }
 
 and verbatim inline = parse
   | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline }
   | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline }
   | ">>" { Output.stop_verbatim inline }
+  | "*)" { Output.stop_verbatim inline; backtrack lexbuf }
   | eof { Output.stop_verbatim inline }
   | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf }
 
@@ -953,11 +939,11 @@ and escaped_coq = parse
   | "]"
       { decr brackets;
 	if !brackets > 0 then
-	  (Output.sublexer ']' (lexeme_start lexbuf); escaped_coq lexbuf)
+	  (Output.sublexer_in_doc ']'; escaped_coq lexbuf)
 	else Tokens.flush_sublexer () }
   | "["
       { incr brackets;
-        Output.sublexer '[' (lexeme_start lexbuf); escaped_coq lexbuf }
+        Output.sublexer_in_doc '['; escaped_coq lexbuf }
   | "(*"
       { Tokens.flush_sublexer (); comment_level := 1;
         ignore (comment lexbuf); escaped_coq lexbuf }
@@ -967,7 +953,7 @@ and escaped_coq = parse
       { Tokens.flush_sublexer () }
   | (identifier '.')* identifier
       { Tokens.flush_sublexer();
-        Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
+        Output.ident (lexeme lexbuf) None;
         escaped_coq lexbuf }
   | space_nl*
       { let str = lexeme lexbuf in
@@ -979,7 +965,7 @@ and escaped_coq = parse
                                         else Output.start_inline_coq ());
           escaped_coq lexbuf }
   | _ 
-      { Output.sublexer (lexeme_char lexbuf 0) (lexeme_start lexbuf);
+      { Output.sublexer_in_doc (lexeme_char lexbuf 0);
         escaped_coq lexbuf }
 
 (*s Coq "Comments" command. *)
@@ -1078,7 +1064,7 @@ and body_bol = parse
   | _ { backtrack lexbuf; Output.indentation 0; body lexbuf }
 
 and body = parse
-  | nl {Tokens.flush_sublexer(); Output.line_break(); new_line lexbuf; body_bol lexbuf}
+  | nl {Tokens.flush_sublexer(); Output.line_break(); Lexing.new_line lexbuf; body_bol lexbuf}
   | nl+ space* "]]" space* nl
       { Tokens.flush_sublexer();
         if not !formatted then
@@ -1147,11 +1133,11 @@ and body = parse
 	     else body lexbuf }
   | "where" 
       { Tokens.flush_sublexer();
-        Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
+        Output.ident (lexeme lexbuf) None;
 	start_notation_string lexbuf }
   | identifier
       { Tokens.flush_sublexer();
-        Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
+        Output.ident (lexeme lexbuf) (Some (lexeme_start lexbuf));
 	body lexbuf }
   | ".."
       { Tokens.flush_sublexer(); Output.char '.'; Output.char '.';
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
index 8170e173..4a5ff592 100644
--- a/tools/coqdoc/index.ml
+++ b/tools/coqdoc/index.ml
@@ -1,13 +1,11 @@
 (************************************************************************)
 (*  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 Filename
-open Lexing
 open Printf
 open Cdglobals
 
@@ -36,7 +34,6 @@ type index_entry =
   | Def of string * entry_type
   | Ref of coq_module * string * entry_type
 
-let current_type : entry_type ref = ref Library
 let current_library = ref ""
   (** refers to the file being parsed *)
 
@@ -95,9 +92,6 @@ let empty_stack = []
 let module_stack = ref empty_stack
 let section_stack = ref empty_stack
 
-let init_stack () =
-  module_stack := empty_stack; section_stack := empty_stack
-
 let push st p = st := p::!st
 let pop st =
   match !st with
@@ -109,27 +103,6 @@ let head st =
     | [] -> ""
     | x::_ -> x
 
-let begin_module m = push module_stack m
-let begin_section s = push section_stack s
-
-let end_block id =
-  (** determines if it ends a module or a section and pops the stack *)
-  if ((String.compare (head !module_stack) id ) == 0) then
-    pop module_stack
-  else if ((String.compare (head !section_stack) id) == 0) then
-    pop section_stack
-  else
-    ()
-
-let make_fullid id =
-  (** prepends the current module path to an id *)
-  let path = string_of_stack !module_stack in
-    if String.length path > 0 then
-      path ^ "." ^ id
-    else
-      id
-
-
 (* Coq modules *)
 
 let split_sp s =
@@ -158,7 +131,7 @@ let find_external_library logicalpath =
   let rec aux = function
     | [] -> raise Not_found
     | (l,u)::rest ->
-        if String.length logicalpath > String.length l &
+        if String.length logicalpath > String.length l &&
           String.sub logicalpath 0 (String.length l + 1) = l ^"."
         then u
         else aux rest
@@ -208,10 +181,6 @@ let sort_entries el =
 
 let display_letter c = if c = '*' then "other" else String.make 1 c
 
-let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0
-
-let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h []
-
 let type_name = function
   | Library ->
       let ln = !lib_name in
@@ -304,9 +273,9 @@ let type_of_string = function
   | "def" | "coe" | "subclass" | "canonstruc" | "fix" | "cofix"
   | "ex" | "scheme" -> Definition
   | "prf" | "thm" -> Lemma
-  | "ind" | "coind" -> Inductive
+  | "ind" | "variant" | "coind" -> Inductive
   | "constr" -> Constructor
-  | "rec" | "corec" -> Record
+  | "indrec" | "rec" | "corec" -> Record
   | "proj" -> Projection
   | "class" -> Class
   | "meth" -> Method
@@ -319,7 +288,7 @@ let type_of_string = function
   | "mod" | "modtype" -> Module
   | "tac" -> TacticDefinition
   | "sec" -> Section
-  | s -> raise (Invalid_argument ("type_of_string:" ^ s))
+  | s -> invalid_arg ("type_of_string:" ^ s)
 
 let ill_formed_glob_file f =
   eprintf "Warning: ill-formed file %s (links will not be available)\n" f
@@ -370,9 +339,6 @@ let read_glob vfile f =
 		    done)
 	       with _ -> ())
 	  | _ ->
-	      try Scanf.sscanf s "not %d %s %s"
-		(fun loc sp id -> add_def loc loc (type_of_string "not") sp id)
-	      with Scanf.Scan_failure _ ->
 	      try Scanf.sscanf s "%s %d:%d %s %s"
 		(fun ty loc1 loc2 sp id ->
                   add_def loc1 loc2 (type_of_string ty) sp id)
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index 4c1a445c..69b4e4da 100644
--- a/tools/coqdoc/index.mli
+++ b/tools/coqdoc/index.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/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
index 59d1ac87..9531cd2b 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.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        *)
@@ -60,6 +60,7 @@ let usage () =
   prerr_endline "  --boot               run in boot mode";
   prerr_endline "  --coqlib_path <dir>  set the path where Coq files are installed";
   prerr_endline "  -R <dir> <coqdir>    map physical dir to Coq dir";
+  prerr_endline "  -Q <dir> <coqdir>    map physical dir to Coq dir";
   prerr_endline "  --latin1             set ISO-8859-1 input language";
   prerr_endline "  --utf8               set UTF-8 input language";
   prerr_endline "  --charset <string>   set HTML charset";
@@ -320,6 +321,10 @@ let parse () =
 	add_path path log; parse_rec rem
     | "-R" :: ([] | [_]) ->
 	usage ()
+    | "-Q" :: path :: log :: rem ->
+	add_path path log; parse_rec rem
+    | "-Q" :: ([] | [_]) ->
+	usage ()
     | ("-glob-from" | "--glob-from") :: f :: rem ->
 	glob_source := GlobFile f; parse_rec rem
     | ("-glob-from" | "--glob-from") :: [] ->
@@ -445,7 +450,7 @@ let gen_mult_files l =
       if (!header_trailer) then Output.trailer ();
       close_out_file()
     end
-      (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *)
+    (* NB: for latex and texmacs, a separated toc or index is meaningless... *)
 
 let read_glob_file vfile f =
   try Index.read_glob vfile f
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index 2d29c447..ae6e6388 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.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        *)
@@ -41,7 +41,7 @@ let is_keyword =
       "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed";
       "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes";
       "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem";
-      "Search"; "SearchAbout"; "SearchRewrite";
+      "Search"; "SearchAbout"; "SearchHead"; "SearchPattern"; "SearchRewrite";
       "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context";
       "Notation"; "Reserved Notation"; "Tactic Notation";
       "Delimit"; "Bind"; "Open"; "Scope"; "Inline";
@@ -50,6 +50,7 @@ let is_keyword =
       "subgoal"; "subgoals"; "vm_compute";
       "Opaque"; "Transparent"; "Time";
       "Extraction"; "Extract";
+      "Variant";
       (* Program *)
       "Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma";
       "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next";
@@ -59,7 +60,7 @@ let is_keyword =
       "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure";
       "fix"; "cofix";
       (* Ltac *)
-      "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta";
+      "before"; "after"; "constr"; "ltac"; "goal"; "context"; "beta"; "delta"; "iota"; "zeta"; "lazymatch";
       (* Notations *)
       "level"; "associativity"; "no"
        ]
@@ -210,6 +211,7 @@ module Latex = struct
       printf "\\usepackage{fullpage}\n";
       printf "\\usepackage{coqdoc}\n";
       printf "\\usepackage{amsmath,amssymb}\n";
+      printf "\\usepackage{url}\n";
       (match !toc_depth with
        | None -> ()
        | Some n -> printf "\\setcounter{tocdepth}{%i}\n" n);
@@ -383,6 +385,14 @@ module Latex = struct
     end;
     last_was_in := false
 
+  let sublexer_in_doc c =
+    if c = '*' && !last_was_in then begin
+      Tokens.flush_sublexer ();
+      output_char '*'
+    end else
+      Tokens.output_tagged_symbol_char None c;
+    last_was_in := false
+
   let initialize () =
     initialize_tex_html ();
     Tokens.token_tree := token_tree_latex;
@@ -399,8 +409,11 @@ module Latex = struct
   let ident s loc =
     last_was_in := s = "in";
     try
-      let tag = Index.find (get_module false) loc in
-      reference (translate s) tag
+      match loc with
+      | None -> raise Not_found
+      | Some loc ->
+          let tag = Index.find (get_module false) loc in
+          reference (translate s) tag
     with Not_found ->
       if is_tactic s then
 	printf "\\coqdoctac{%s}" (translate s)
@@ -522,8 +535,8 @@ module Html = struct
 	  printf "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n";
 	  printf "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n";
 	  printf "<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n";
-	  printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\"/>\n" !charset;
-	  printf "<link href=\"coqdoc.css\" rel=\"stylesheet\" type=\"text/css\"/>\n";
+	  printf "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\" />\n" !charset;
+	  printf "<link href=\"coqdoc.css\" rel=\"stylesheet\" type=\"text/css\" />\n";
 	  printf "<title>%s</title>\n</head>\n\n" !page_title;
 	  printf "<body>\n\n<div id=\"page\">\n\n<div id=\"header\">\n</div>\n\n";
 	  printf "<div id=\"main\">\n\n"
@@ -558,7 +571,7 @@ module Html = struct
           printf "<h1 class=\"libtitle\">%s %s</h1>\n\n" ln (get_module true)
     end
 
-  let indentation n = for i = 1 to n do printf "&nbsp;" done
+  let indentation n = for _i = 1 to n do printf "&nbsp;" done
 
   let line_break () = printf "<br/>\n"
 
@@ -573,9 +586,6 @@ module Html = struct
     | '&' -> printf "&amp;"
     | c -> output_char c
 
-  let raw_string s =
-    for i = 0 to String.length s - 1 do char s.[i] done
-
   let escaped =
     let buff = Buffer.create 5 in
     fun s ->
@@ -585,10 +595,24 @@ module Html = struct
 	| '<' -> Buffer.add_string buff "&lt;"
 	| '>' -> Buffer.add_string buff "&gt;"
 	| '&' -> Buffer.add_string buff "&amp;"
+        | '\'' -> Buffer.add_string buff "&acute;"
+        | '\"' -> Buffer.add_string buff "&quot;"
 	| c -> Buffer.add_char buff c
       done;
       Buffer.contents buff
 
+  let sanitize_name s =
+    let rec loop esc i =
+      if i < 0 then if esc then escaped s else s
+      else match s.[i] with
+      | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '_' -> loop esc (i-1)
+      | '<' | '>' | '&' | '\'' | '\"' -> loop true (i-1)
+      | _ ->
+        (* This name contains complex characters:
+           this is probably a notation string, we simply hash it. *)
+        Digest.to_hex (Digest.string s)
+    in loop false (String.length s - 1)
+
   let latex_char _ = ()
   let latex_string _ = ()
 
@@ -618,19 +642,19 @@ module Html = struct
   let ident_ref m fid typ s =
     match find_module m with
     | Local ->
-	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
-	printf "<span class=\"id\" type=\"%s\">%s</span></a>" typ s
+	printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid);
+	printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s
     | External m when !externals ->
-	printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
-	printf "<span class=\"id\" type=\"%s\">%s</span></a>" typ s
+	printf "<a class=\"idref\" href=\"%s.html#%s\">" m (sanitize_name fid);
+	printf "<span class=\"id\" title=\"%s\">%s</span></a>" typ s
     | External _ | Unknown ->
-	printf "<span class=\"id\" type=\"%s\">%s</span>" typ s
+	printf "<span class=\"id\" title=\"%s\">%s</span>" typ s
 
   let reference s r =
     match r with
     | Def (fullid,ty) ->
-	printf "<a name=\"%s\">" fullid;
-	printf "<span class=\"id\" type=\"%s\">%s</span></a>" (type_name ty) s
+	printf "<a name=\"%s\">" (sanitize_name fullid);
+	printf "<span class=\"id\" title=\"%s\">%s</span></a>" (type_name ty) s
     | Ref (m,fullid,ty) ->
 	ident_ref m fullid (type_name ty) s
 
@@ -640,7 +664,7 @@ module Html = struct
     | Some ref -> reference s ref
     | None ->
 	if issymbchar then output_string s
-	else printf "<span class=\"id\" type=\"var\">%s</span>" s
+	else printf "<span class=\"id\" title=\"var\">%s</span>" s
 
   let sublexer c loc =
     let tag =
@@ -648,6 +672,9 @@ module Html = struct
     in
     Tokens.output_tagged_symbol_char tag c
 
+  let sublexer_in_doc c =
+    Tokens.output_tagged_symbol_char None c
+
   let initialize () =
     initialize_tex_html();
     Tokens.token_tree := token_tree_html;
@@ -657,16 +684,20 @@ module Html = struct
     match Tokens.translate s with Some s -> s | None -> escaped s
 
   let keyword s loc = 
-    printf "<span class=\"id\" type=\"keyword\">%s</span>" (translate s)
+    printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s)
 
   let ident s loc =
     if is_keyword s then begin
-      printf "<span class=\"id\" type=\"keyword\">%s</span>" (translate s)
+      printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s)
     end else begin
-      try reference (translate s) (Index.find (get_module false) loc)
+      try
+        match loc with
+        | None -> raise Not_found
+        | Some loc ->
+            reference (translate s) (Index.find (get_module false) loc)
       with Not_found ->
 	if is_tactic s then
-	  printf "<span class=\"id\" type=\"tactic\">%s</span>" (translate s)
+	  printf "<span class=\"id\" title=\"tactic\">%s</span>" (translate s)
 	else
 	  if !Cdglobals.interpolate && !in_doc (* always a var otherwise *)
 	  then
@@ -818,7 +849,7 @@ module Html = struct
 	       "[library]", m ^ ".html", t
 	else
 	 sprintf "[%s, in <a href=\"%s.html\">%s</a>]" (type_name t) m m ,
-	sprintf "%s.html#%s" m s, t)
+	sprintf "%s.html#%s" m (sanitize_name s), t)
 
   let format_bytype_index = function
     | Library, idx ->
@@ -827,7 +858,7 @@ module Html = struct
 	Index.map
 	  (fun s m ->
 	     let text = sprintf "[in <a href=\"%s.html\">%s</a>]" m m in
-	       (text, sprintf "%s.html#%s" m s, t)) idx
+	       (text, sprintf "%s.html#%s" m (sanitize_name s), t)) idx
 
   (* Impression de la table d'index *)
   let print_index_table_item i =
@@ -923,8 +954,6 @@ module TeXmacs = struct
   let (preamble : string Queue.t) =
     in_doc := false; Queue.create ()
 
-  let push_in_preamble s = Queue.add s preamble
-
   let header () =
     output_string
       "(*i This file has been automatically generated with the command  \n";
@@ -989,6 +1018,9 @@ module TeXmacs = struct
   let sublexer c l =
     if !in_doc then Tokens.output_tagged_symbol_char None c else char c
 
+  let sublexer_in_doc c =
+    char c
+
   let initialize () =
     Tokens.token_tree := token_tree_texmacs;
     Tokens.outfun := output_sublexer_string
@@ -1045,8 +1077,6 @@ module TeXmacs = struct
 
   let paragraph () = printf "\n\n"
 
-  let line_break_true () = printf "<format|line break>"
-
   let line_break () = printf "\n"
 
   let empty_line_of_code () = printf "\n"
@@ -1107,12 +1137,13 @@ module Raw = struct
   let stop_quote () = printf "\""
 
   let indentation n =
-      for i = 1 to n do printf " " done
+      for _i = 1 to n do printf " " done
 
   let keyword s loc = raw_ident s
   let ident s loc = raw_ident s
 
   let sublexer c l = char c
+  let sublexer_in_doc c = char c
 
   let initialize () =
     Tokens.token_tree := ref Tokens.empty_ttree;
@@ -1226,6 +1257,7 @@ let char = select Latex.char Html.char TeXmacs.char Raw.char
 let keyword = select Latex.keyword Html.keyword TeXmacs.keyword Raw.keyword
 let ident = select Latex.ident Html.ident TeXmacs.ident Raw.ident
 let sublexer = select Latex.sublexer Html.sublexer TeXmacs.sublexer Raw.sublexer
+let sublexer_in_doc = select Latex.sublexer_in_doc Html.sublexer_in_doc TeXmacs.sublexer_in_doc Raw.sublexer_in_doc
 let initialize = select Latex.initialize Html.initialize TeXmacs.initialize Raw.initialize
 
 let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox
diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli
index 40fe69f7..c4628dd8 100644
--- a/tools/coqdoc/output.mli
+++ b/tools/coqdoc/output.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        *)
@@ -61,8 +61,9 @@ val rule : unit -> unit
 val nbsp : unit -> unit
 val char : char -> unit
 val keyword : string -> loc -> unit
-val ident : string -> loc -> unit
+val ident : string -> loc option -> unit
 val sublexer : char -> loc -> unit
+val sublexer_in_doc : char -> unit
 val initialize : unit -> unit
 
 val proofbox : unit -> unit
diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml
index 33560fce..a93ae855 100644
--- a/tools/coqdoc/tokens.ml
+++ b/tools/coqdoc/tokens.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        *)
@@ -9,15 +9,16 @@
 (* Application of printing rules based on a dictionary specific to the
    target language *)
 
-open Cdglobals
-
 (*s Dictionaries: trees annotated with string options, each node being a map
     from chars to dictionaries (the subtrees). A trie, in other words.
 
     (code copied from parsing/lexer.ml4 for the use of coqdoc, Apr 2010)
 *)
 
-module CharMap = Map.Make (struct type t = char let compare = compare end)
+module CharMap = Map.Make (struct
+  type t = char
+  let compare (x : t) (y : t) = compare x y
+end)
 
 type ttree = {
   node : string option;
diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli
index 898f2b5c..c4fe3bc8 100644
--- a/tools/coqdoc/tokens.mli
+++ b/tools/coqdoc/tokens.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/tools/coqmktop.ml b/tools/coqmktop.ml
new file mode 100644
index 00000000..be796e69
--- /dev/null
+++ b/tools/coqmktop.ml
@@ -0,0 +1,306 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** {1 Coqmktop} *)
+
+(** coqmktop is a script to link Coq, analogous to ocamlmktop.
+   The command line contains options specific to coqmktop, options for the
+   Ocaml linker and files to link (in addition to the default Coq files). *)
+
+(** {6 Utilities} *)
+
+(** Split a string at each blank
+*)
+let split_list =
+  let spaces = Str.regexp "[ \t\n]+" in
+  fun str -> Str.split spaces str
+
+let (/) = Filename.concat
+
+(** Which user files do we support (and propagate to ocamlopt) ?
+*)
+let supported_suffix f = match CUnix.get_extension f with
+  | ".ml" | ".cmx" | ".cmo" | ".cmxa" | ".cma" | ".c" -> true
+  | _ -> false
+
+(** From bytecode extension to native
+*)
+let native_suffix f = match CUnix.get_extension f with
+  | ".cmo" -> (Filename.chop_suffix f ".cmo") ^ ".cmx"
+  | ".cma" -> (Filename.chop_suffix f ".cma") ^ ".cmxa"
+  | ".a" -> f
+  | _ -> failwith ("File "^f^" has not extension .cmo, .cma or .a")
+
+(** Transforms a file name in the corresponding Caml module name.
+*)
+let module_of_file name =
+  String.capitalize
+    (try Filename.chop_extension name with Invalid_argument _ -> name)
+
+(** Run a command [prog] with arguments [args].
+    We do not use [Sys.command] anymore, see comment in [CUnix.sys_command].
+*)
+let run_command prog args =
+  match CUnix.sys_command prog args with
+  | Unix.WEXITED 127 -> failwith ("no such command "^prog)
+  | Unix.WEXITED n -> n
+  | Unix.WSIGNALED n -> failwith (prog^" killed by signal "^string_of_int n)
+  | Unix.WSTOPPED n -> failwith (prog^" stopped by signal "^string_of_int n)
+
+
+
+(** {6 Coqmktop options} *)
+
+let opt        = ref false
+let top        = ref false
+let echo       = ref false
+let no_start   = ref false
+
+let is_ocaml4 = Coq_config.caml_version.[0] <> '3'
+let is_camlp5 = Coq_config.camlp4 = "camlp5"
+
+
+(** {6 Includes options} *)
+
+(** Since the Coq core .cma are given with their relative paths
+    (e.g. "lib/clib.cma"), we only need to include directories mentionned in
+    the temp main ml file below (for accessing the corresponding .cmi). *)
+
+let std_includes basedir =
+  let rebase d = match basedir with None -> d | Some base -> base / d in
+  ["-I"; rebase ".";
+   "-I"; rebase "lib";
+   "-I"; rebase "toplevel";
+   "-I"; rebase "kernel/byterun";
+   "-I"; Envars.camlp4lib () ] @
+  (if is_ocaml4 then ["-I"; "+compiler-libs"] else [])
+
+(** For the -R option, visit all directories under [dir] and add
+    corresponding -I to the [opts] option list (in reversed order) *)
+let incl_all_subdirs dir opts =
+  let l = ref opts in
+  let add f = l := f :: "-I" :: !l in
+  let rec traverse dir =
+    if Sys.file_exists dir && Sys.is_directory dir then
+      let () = add dir in
+      let subdirs = try Sys.readdir dir with any -> [||] in
+      Array.iter (fun f -> traverse (dir/f)) subdirs
+  in
+  traverse dir; !l
+
+
+(** {6 Objects to link} *)
+
+(** NB: dynlink is now always linked, it is used for loading plugins
+    and compiled vm code (see native-compiler). We now reject platforms
+    with ocamlopt but no dynlink.cmxa during ./configure, and give
+    instructions there about how to build a dummy dynlink.cmxa,
+    cf. dev/dynlink.ml. *)
+
+(** OCaml + CamlpX libraries *)
+
+let ocaml_libs = ["str.cma";"unix.cma";"nums.cma";"dynlink.cma";"threads.cma"]
+let camlp4_libs = if is_camlp5 then ["gramlib.cma"] else ["camlp4lib.cma"]
+let libobjs = ocaml_libs @ camlp4_libs
+
+(** Toplevel objects *)
+
+let ocaml_topobjs =
+  if is_ocaml4 then
+    ["ocamlcommon.cma";"ocamlbytecomp.cma";"ocamltoplevel.cma"]
+  else
+    ["toplevellib.cma"]
+
+let camlp4_topobjs =
+  if is_camlp5 then
+    ["camlp5_top.cma"; "pa_o.cmo"; "pa_extend.cmo"]
+  else
+    [ "Camlp4Top.cmo";
+      "Camlp4Parsers/Camlp4OCamlRevisedParser.cmo";
+      "Camlp4Parsers/Camlp4OCamlParser.cmo";
+      "Camlp4Parsers/Camlp4GrammarParser.cmo" ]
+
+let topobjs = ocaml_topobjs @ camlp4_topobjs
+
+(** Coq Core objects *)
+
+let copts = (split_list Coq_config.osdeplibs) @ (split_list Tolink.copts)
+let core_objs = split_list Tolink.core_objs
+let core_libs = split_list Tolink.core_libs
+
+(** Build the list of files to link and the list of modules names
+*)
+let files_to_link userfiles =
+  let top = if !top then topobjs else [] in
+  let modules = List.map module_of_file (top @ core_objs @ userfiles) in
+  let objs = libobjs @ top @ core_libs in
+  let objs' = (if !opt then List.map native_suffix objs else objs) @ userfiles
+  in (modules, objs')
+
+
+(** {6 Parsing of the command-line} *)
+
+let usage () =
+  prerr_endline "Usage: coqmktop <options> <ocaml options> files\
+\nFlags are:\
+\n  -coqlib dir    Specify where the Coq object files are\
+\n  -camlbin dir   Specify where the OCaml binaries are\
+\n  -camlp4bin dir Specify where the Camlp4/5 binaries are\
+\n  -o exec-file   Specify the name of the resulting toplevel\
+\n  -boot          Run in boot mode\
+\n  -echo          Print calls to external commands\
+\n  -opt           Compile in native code\
+\n  -top           Build Coq on a OCaml toplevel (incompatible with -opt)\
+\n  -R dir         Add recursively dir to OCaml search path\
+\n";
+  exit 1
+
+let parse_args () =
+  let rec parse (op,fl) = function
+    | [] -> List.rev op, List.rev fl
+
+    (* Directories *)
+    | "-coqlib" :: d :: rem ->
+	Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem
+    | "-camlbin" :: d :: rem ->
+	Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem
+    | "-camlp4bin" :: d :: rem ->
+	Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem
+    | "-R" :: d :: rem -> parse (incl_all_subdirs d op,fl) rem
+    | ("-coqlib"|"-camlbin"|"-camlp4bin"|"-R") :: [] -> usage ()
+
+    (* Boolean options of coqmktop *)
+    | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem
+    | "-opt" :: rem -> opt := true ; parse (op,fl) rem
+    | "-top" :: rem -> top := true ; parse (op,fl) rem
+    | "-no-start" :: rem -> no_start:=true; parse (op, fl) rem
+    | "-echo" :: rem -> echo := true ; parse (op,fl) rem
+    | ("-v8"|"-full" as o) :: rem ->
+	Printf.eprintf "warning: option %s deprecated\n" o; parse (op,fl) rem
+
+    (* Extra options with arity 0 or 1, directly passed to ocamlc/ocamlopt *)
+    | ("-noassert"|"-compact"|"-g"|"-p"|"-thread"|"-dtypes" as o) :: rem ->
+        parse (o::op,fl) rem
+    | ("-cclib"|"-ccopt"|"-I"|"-o"|"-w" as o) :: rem' ->
+	begin
+	  match rem' with
+	    | a :: rem -> parse (a::o::op,fl) rem
+	    | []       -> usage ()
+	end
+
+    | ("-h"|"-help"|"--help") :: _ -> usage ()
+    | f :: rem when supported_suffix f -> parse (op,f::fl) rem
+    | f :: _ -> prerr_endline ("Don't know what to do with " ^ f); exit 1
+  in
+  parse ([],[]) (List.tl (Array.to_list Sys.argv))
+
+
+(** {6 Temporary main file} *)
+
+(** remove the temporary main file
+*)
+let clean file =
+  let rm f = if Sys.file_exists f then Sys.remove f in
+  let basename = Filename.chop_suffix file ".ml" in
+  if not !echo then begin
+    rm file;
+    rm (basename ^ ".o");
+    rm (basename ^ ".cmi");
+    rm (basename ^ ".cmo");
+    rm (basename ^ ".cmx")
+  end
+
+(** Initializes the kind of loading in the main program
+*)
+let declare_loading_string () =
+  if not !top then
+    "Mltop.remove ();;"
+  else
+    "begin try\
+\n       (* Enable rectypes in the toplevel if it has the directive #rectypes *)\
+\n       begin match Hashtbl.find Toploop.directive_table \"rectypes\" with\
+\n         | Toploop.Directive_none f -> f ()\
+\n         | _ -> ()\
+\n       end\
+\n     with\
+\n       | Not_found -> ()\
+\n     end;;\
+\n\
+\n     let ppf = Format.std_formatter;;\
+\n     Mltop.set_top\
+\n       {Mltop.load_obj=\
+\n         (fun f -> if not (Topdirs.load_file ppf f)\
+\n                   then Errors.error (\"Could not load plugin \"^f));\
+\n        Mltop.use_file=Topdirs.dir_use ppf;\
+\n        Mltop.add_dir=Topdirs.dir_directory;\
+\n        Mltop.ml_loop=(fun () -> Toploop.loop ppf) };;\
+\n"
+
+(** create a temporary main file to link
+*)
+let create_tmp_main_file modules =
+  let main_name,oc = Filename.open_temp_file "coqmain" ".ml" in
+  try
+    (* Add the pre-linked modules *)
+    output_string oc "List.iter Mltop.add_known_module [\"";
+    output_string oc (String.concat "\";\"" modules);
+    output_string oc "\"];;\n";
+    (* Initializes the kind of loading *)
+    output_string oc (declare_loading_string());
+    (* Start the toplevel loop *)
+    if not !no_start then output_string oc "Coqtop.start();;\n";
+    close_out oc;
+    main_name
+  with reraise ->
+    clean main_name; raise reraise
+
+
+(** {6 Main } *)
+
+let main () =
+  let (options, userfiles) = parse_args () in
+  (* Directories: *)
+  let () = Envars.set_coqlib ~fail:Errors.error in
+  let camlbin = Envars.camlbin () in
+  let basedir = if !Flags.boot then None else Some (Envars.coqlib ()) in
+  (* Which ocaml compiler to invoke *)
+  let prog = camlbin/(if !opt then "ocamlopt" else "ocamlc") in
+  (* Which arguments ? *)
+  if !opt && !top then failwith "no custom toplevel in native code !";
+  let flags = if !opt then [] else Coq_config.vmbyteflags in
+  let topstart = if !top then [ "topstart.cmo" ] else [] in
+  let (modules, tolink) = files_to_link userfiles in
+  let main_file = create_tmp_main_file modules in
+  try
+    (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper.
+       - With the coq .cma, we MUST use the -linkall option. *)
+    let args =
+      "-linkall" :: "-rectypes" :: flags @ copts @ options @
+      (std_includes basedir) @ tolink @ [ main_file ] @ topstart
+    in
+    if !echo then begin
+      let command = String.concat " " (prog::args) in
+      print_endline command;
+      print_endline
+	("(command length is " ^
+	    (string_of_int (String.length command)) ^ " characters)");
+      flush Pervasives.stdout
+    end;
+    let exitcode = run_command prog args in
+    clean main_file;
+    exitcode
+  with reraise -> clean main_file; raise reraise
+
+let pr_exn = function
+  | Failure msg -> msg
+  | Unix.Unix_error (err,fn,arg) -> fn^" "^arg^" : "^Unix.error_message err
+  | any -> Printexc.to_string any
+
+let _ =
+  try exit (main ())
+  with any -> Printf.eprintf "Error: %s\n" (pr_exn any); exit 1
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
index db927efb..417ec535 100644
--- a/tools/coqwc.mll
+++ b/tools/coqwc.mll
@@ -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        *)
 (************************************************************************)
 
 (* coqwc - counts the lines of spec, proof and comments in Coq sources
- * Copyright (C) 2003 Jean-Christophe Filliâtre *)
+ * Copyright (C) 2003 Jean-Christophe Filliâtre *)
 
 (*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source.
     It assumes the files to be lexically well-formed. *)
@@ -15,7 +15,6 @@
 (*i*){
 open Printf
 open Lexing
-open Filename
 (*i*)
 
 (*s Command-line options. *)
@@ -96,6 +95,8 @@ let stars = "(*" '*'* "*)"
 let dot = '.' (' ' | '\t' | '\n' | '\r' | eof)
 let proof_start =
   "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next"
+let def_start =
+  "Definition" | "Fixpoint" | "Instance"
 let proof_end =
   ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.'
 
@@ -108,14 +109,10 @@ rule spec = parse
   | '\n'   { newline (); spec lexbuf }
   | space+ | stars
            { spec lexbuf }
-  | proof_start space
+  | proof_start
            { seen_spec := true; spec_to_dot lexbuf; proof lexbuf }
-  | proof_start '\n'
-           { seen_spec := true; newline (); spec_to_dot lexbuf; proof lexbuf }
-  | "Program"? "Definition" space
+  | def_start
            { seen_spec := true; definition lexbuf }
-  | "Program"? "Fixpoint" space
-  	   { seen_spec := true; definition lexbuf }
   | character | _
 	   { seen_spec := true; spec lexbuf }
   | eof    { () }
@@ -134,7 +131,7 @@ and spec_to_dot = parse
 	   { seen_spec := true; spec_to_dot lexbuf }
   | eof    { () }
 
-(*s [definition] scans a definition; passes to [proof] is the body is
+(*s [definition] scans a definition; passes to [proof] if the body is
     absent, and to [spec] otherwise *)
 
 and definition = parse
@@ -160,6 +157,8 @@ and proof = parse
            { proof lexbuf }
   | '\n'   { newline (); proof lexbuf }
   | "Proof" space* '.'
+  | "Proof" space+ "with"
+  | "Proof" space+ "using"
            { seen_proof := true; proof lexbuf }
   | "Proof" space
            { proof_term lexbuf }
diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml
new file mode 100644
index 00000000..8c089150
--- /dev/null
+++ b/tools/coqworkmgr.ml
@@ -0,0 +1,222 @@
+(************************************************************************)
+(*  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 CoqworkmgrApi
+
+let debug = ref false
+
+type party = {
+          sock     : Unix.file_descr;
+          cout     : out_channel;
+  mutable tokens   : int;
+          priority : Flags.priority;
+}
+
+let answer party msg =
+  output_string party.cout (print_response msg); flush party.cout
+
+let mk_socket_channel () =
+  let open Unix in
+  let s = socket PF_INET SOCK_STREAM 0 in
+  bind s (ADDR_INET (inet_addr_loopback,0));
+  listen s 1;
+  match getsockname s with
+  | ADDR_INET(host, port) ->
+      s, string_of_inet_addr host ^":"^ string_of_int port
+  | _ -> assert false
+
+module Queue : sig
+  type t
+  val is_empty : t -> bool
+  val push : int * party -> t -> unit
+  val pop : t -> int * party
+  val create : unit -> t
+end = struct
+  type t = (int * party) list ref
+  let create () = ref []
+  let is_empty q = !q = []
+  let rec split acc = function
+    | [] -> List.rev acc, []
+    | (_, { priority = Flags.Low }) :: _ as l -> List.rev acc, l
+    | x :: xs -> split (x :: acc) xs
+  let push (_,{ priority } as item) q =
+    if priority = Flags.Low then q := !q @ [item]
+    else
+      let high, low = split [] !q in
+      q := high @ (item :: low)
+  let pop q = match !q with x :: xs -> q := xs; x | _ -> assert false
+end
+
+let read_fd fd s ~off ~len =
+  let rec loop () =
+    try Unix.read fd s off len
+    with Unix.Unix_error(Unix.EAGAIN,_,_) -> loop ()
+  in 
+    loop ()
+
+let really_read_fd fd s off len =
+  let i = ref 0 in
+  while !i < len do
+    let off = off + !i in
+    let len = len - !i in
+    let r = read_fd fd s ~off ~len in
+    if r = 0 then raise End_of_file;
+    i := !i + r
+  done
+
+let raw_input_line fd =
+  try
+    let b = Buffer.create 80 in
+    let s = String.make 1 '\000' in
+    while s <> "\n" do
+      really_read_fd fd s 0 1;
+      if s <> "\n" && s <> "\r" then Buffer.add_string b s;
+    done;
+    Buffer.contents b
+  with Unix.Unix_error _ -> raise End_of_file
+
+let accept s =
+  let cs, _ = Unix.accept s in
+  let cout = Unix.out_channel_of_descr cs in
+  set_binary_mode_out cout true;
+  match parse_request (raw_input_line cs) with
+  | Hello p -> { sock=cs; cout; tokens=0; priority=p }
+  | _ -> (try Unix.close cs with _ -> ()); raise End_of_file
+
+let parse s = ()
+
+let parties = ref []
+
+let max_tokens = ref 2
+let cur_tokens = ref 0
+
+let queue = Queue.create ()
+
+let rec allocate n party =
+  let extra = min n (!max_tokens - !cur_tokens) in
+  cur_tokens := !cur_tokens + extra;
+  party.tokens <- party.tokens + extra;
+  answer party (Tokens extra)
+
+and de_allocate n party =
+  let back = min party.tokens n in
+  party.tokens <- party.tokens - back;
+  cur_tokens := min (!cur_tokens - back) !max_tokens;
+  eventually_dequeue ()
+
+and eventually_dequeue () =
+  if Queue.is_empty queue || !cur_tokens >= !max_tokens then ()
+  else
+    let req, party = Queue.pop queue in
+    if List.exists (fun { sock } -> sock = party.sock) !parties
+    then allocate req party
+    else eventually_dequeue ()
+
+let chat s =
+  let party =
+    try List.find (fun { sock } -> sock = s) !parties
+    with Not_found -> Printf.eprintf "Internal error"; exit 1 in
+  try
+    match parse_request (raw_input_line party.sock) with
+    | Get n ->
+        if !cur_tokens < !max_tokens then allocate n party     
+        else Queue.push (n,party) queue
+    | TryGet n ->
+        if !cur_tokens < !max_tokens then allocate n party     
+        else answer party Noluck
+    | GiveBack n -> de_allocate n party
+    | Ping ->
+        answer party (Pong (!cur_tokens,!max_tokens,Unix.getpid ()));
+        raise End_of_file
+    | Hello _ -> raise End_of_file
+  with Failure _ | ParseError | Sys_error _ | End_of_file ->
+    (try Unix.close party.sock with _ -> ());
+    parties := List.filter (fun { sock } -> sock <> s) !parties;
+    de_allocate party.tokens party;
+    eventually_dequeue ()
+
+let check_alive s =
+  match CoqworkmgrApi.connect s with
+  | Some s ->
+      let cout = Unix.out_channel_of_descr s in
+      set_binary_mode_out cout true;
+      output_string cout (print_request (Hello Flags.Low)); flush cout;
+      output_string cout (print_request Ping); flush cout;
+      begin match Unix.select [s] [] [] 1.0 with
+      | [s],_,_ ->
+          let cin = Unix.in_channel_of_descr s in
+          set_binary_mode_in cin true;
+          begin match parse_response (input_line cin) with
+          | Pong (n,m,pid) -> n, m, pid
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      end
+  | _ -> raise Not_found
+
+let main () =
+  let args = [
+    "-j",Arg.Set_int max_tokens, "max number of concurrent jobs";
+    "-d",Arg.Set debug, "do not detach (debug)"] in
+  let usage =
+    "Prints on stdout an env variable assignement to be picked up by coq\n"^
+    "instances in order to limit the maximum number of concurrent workers.\n"^
+    "The default value is 2.\n"^
+    "Usage:" in
+  Arg.parse args (fun extra ->
+    Arg.usage args ("Unexpected argument "^extra^".\n"^usage))
+    usage;
+  try
+    let sock = Sys.getenv "COQWORKMGR_SOCK" in
+    if !debug then Printf.eprintf "Contacting %s\n%!" sock;
+    let cur, max, pid = check_alive sock in
+    Printf.printf "COQWORKMGR_SOCK=%s\n%!" sock;
+    Printf.eprintf
+      "coqworkmgr already up and running (pid=%d, socket=%s, j=%d/%d)\n%!"
+      pid sock cur max;
+    exit 0
+  with Not_found | Failure _ | Invalid_argument _ | Unix.Unix_error _ ->
+  if !debug then Printf.eprintf "No running instance. Starting a new one\n%!";
+  let master, str = mk_socket_channel () in
+  if not !debug then begin
+    let pid = Unix.fork () in
+    if pid <> 0 then begin
+      Printf.printf "COQWORKMGR_SOCK=%s\n%!" str;
+      exit 0 
+    end else begin
+      ignore(Unix.setsid ());
+      Unix.close Unix.stdin;
+      Unix.close Unix.stdout;
+    end;
+  end else begin
+    Printf.printf "COQWORKMGR_SOCK=%s\n%!" str;
+  end;
+  Sys.catch_break true;
+  try
+    while true do
+      if !debug then
+        Printf.eprintf "Status: #parties=%d tokens=%d/%d \n%!"
+          (List.length !parties) !cur_tokens !max_tokens;
+      let socks = master :: List.map (fun { sock } -> sock) !parties in
+      let r, _, _ = Unix.select socks [] [] (-1.0) in
+      List.iter (fun s ->
+        if s = master then begin
+          try parties := accept master :: !parties
+          with _ -> ()
+        end else chat s)
+      r
+    done;
+    exit 0
+  with Sys.Break ->
+    if !parties <> [] then begin
+      Printf.eprintf "Some coq processes still need me\n%!";
+      exit 1;
+    end else
+      exit 0
+
+let () = main ()
diff --git a/tools/escape_string.ml b/tools/escape_string.ml
deleted file mode 100644
index 50e8faad..00000000
--- a/tools/escape_string.ml
+++ /dev/null
@@ -1 +0,0 @@
-print_string (String.escaped Sys.argv.(1))
diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml
index a7203dc8..c2b12668 100644
--- a/tools/fake_ide.ml
+++ b/tools/fake_ide.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,77 +8,324 @@
 
 (** Fake_ide : Simulate a [coqide] talking to a [coqtop -ideslave] *)
 
-exception Comment
-
-let coqtop = ref (stdin, stdout)
-
-let p = Xml_parser.make ()
-let () = Xml_parser.check_eof p false
-
-let eval_call (call:'a Ide_intf.call) =
-  prerr_endline (Ide_intf.pr_call call);
-  let xml_query = Ide_intf.of_call call in
-  Xml_utils.print_xml (snd !coqtop) xml_query;
-  flush (snd !coqtop);
-  let xml_answer = Xml_parser.parse p (Xml_parser.SChannel (fst !coqtop)) in
-  let res = Ide_intf.to_answer xml_answer call in
-  prerr_endline (Ide_intf.pr_full_value call res);
-  match res with Interface.Fail _ -> exit 1 | _ -> ()
-
-let commands =
-  [ "INTERPRAWSILENT", (fun s -> eval_call (Ide_intf.interp (0,true,false,s)));
-    "INTERPRAW", (fun s -> eval_call (Ide_intf.interp (0,true,true,s)));
-    "INTERPSILENT", (fun s -> eval_call (Ide_intf.interp (0,false,false,s)));
-    "INTERP", (fun s -> eval_call (Ide_intf.interp (0,false,true,s)));
-    "REWIND", (fun s -> eval_call (Ide_intf.rewind (int_of_string s)));
-    "GOALS", (fun _ -> eval_call (Ide_intf.goals ()));
-    "HINTS", (fun _ -> eval_call (Ide_intf.hints ()));
-    "GETOPTIONS", (fun _ -> eval_call (Ide_intf.get_options ()));
-    "STATUS", (fun _ -> eval_call (Ide_intf.status ()));
-    "INLOADPATH", (fun s -> eval_call (Ide_intf.inloadpath s));
-    "MKCASES", (fun s -> eval_call (Ide_intf.mkcases s));
-    "#", (fun _ -> raise Comment);
-  ]
-
-let read_eval_print line =
-  let lline = String.length line in
-  let rec find_cmd = function
-    | [] -> prerr_endline ("Error: Unknown API Command :"^line); exit 1
-    | (cmd,fn) :: cmds ->
-      let lcmd = String.length cmd in
-      if lline >= lcmd && String.sub line 0 lcmd = cmd then
-	let arg = try String.sub line (lcmd+1) (lline-lcmd-1) with _ -> ""
-	in fn arg
-      else find_cmd cmds
+let error s =
+  prerr_endline ("fake_id: error: "^s);
+  exit 1
+
+type coqtop = {
+  xml_printer : Xml_printer.t;
+  xml_parser : Xml_parser.t;
+}
+
+let logger level content = prerr_endline content
+
+let base_eval_call ?(print=true) ?(fail=true) call coqtop =
+  if print then prerr_endline (Xmlprotocol.pr_call call);
+  let xml_query = Xmlprotocol.of_call call in
+  Xml_printer.print coqtop.xml_printer xml_query;
+  let rec loop () =
+    let xml = Xml_parser.parse coqtop.xml_parser in
+    if Pp.is_message xml then
+      let message = Pp.to_message xml in
+      let level = message.Pp.message_level in
+      let content = message.Pp.message_content in
+      logger level content;
+      loop ()
+    else if Feedback.is_feedback xml then
+      loop ()
+    else (Xmlprotocol.to_answer call xml)
   in
-  find_cmd commands
+  let res = loop () in
+  if print then prerr_endline (Xmlprotocol.pr_full_value call res);
+  match res with
+  | Interface.Fail (_,_,s) when fail -> error s
+  | Interface.Fail (_,_,s) as x -> prerr_endline s; x
+  | x -> x
+
+let eval_call c q = ignore(base_eval_call c q)
+
+module Parser = struct (* {{{ *)
+
+  exception Err of string
+  exception More
+
+  type token =
+    | Tok of string * string
+    | Top of token list
+
+  type grammar =
+    | Alt of grammar list
+    | Seq of grammar list
+    | Opt of grammar
+    | Item of (string * (string -> token * int))
+
+  let eat_rex x = x, fun s ->
+    if Str.string_match (Str.regexp x) s 0 then begin
+      let m = Str.match_end () in
+      let w = String.sub s 0 m in
+      Tok(x,w), m
+    end else raise (Err ("Regexp "^x^" not found in: "^s))
+
+  let eat_balanced c =
+    let c' = match c with
+      | '{' -> '}' | '(' -> ')' | '[' -> ']' | _ -> assert false in
+    let sc, sc' = String.make 1 c, String.make 1 c' in
+    let name = sc ^ "..." ^ sc' in
+    let unescape s =
+      Str.global_replace (Str.regexp ("\\\\"^sc)) sc
+        (Str.global_replace (Str.regexp ("\\\\"^sc')) sc' s) in
+    name, fun s ->
+    if s.[0] = c then
+      let rec find n m =
+        if String.length s <= m then raise More;
+        if s.[m] = c' then
+          if n = 0 then Tok (name, unescape (String.sub s 1 (m-1))), m+1
+          else find (n-1) (m+1)
+        else if s.[m] = c then find (n+1) (m+1)
+        else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c then
+          find n (m+2)
+        else if s.[m] = '\\' && String.length s > m+1 && s.[m+1] = c' then
+          find n (m+2)
+        else find n (m+1)
+      in find ~-1 0
+    else raise (Err ("Balanced "^String.make 1 c^" not found in: "^s))
+
+  let eat_blanks s = snd (eat_rex "[ \n\t]*") s
+
+  let s = ref ""
+
+  let parse g ic =
+    let read_more () = s := !s ^ input_line ic ^ "\n" in
+    let ensure_non_empty n = if n = String.length !s then read_more () in
+    let cut_after s n = String.sub s n (String.length s - n) in
+    let rec wrap f n =
+      try
+        ensure_non_empty n;
+        let _, n' = eat_blanks (cut_after !s n) in
+        ensure_non_empty n';
+        let t, m = f (cut_after !s (n+n')) in
+        let _, m' = eat_blanks (cut_after !s (n+n'+m)) in
+        t, n+n'+m+m'
+      with More -> read_more (); wrap f n in
+    let rec aux n g res : token list * int =
+      match g with
+      | Item (_,f) ->
+          let t, n = wrap f n in
+          t :: res, n
+      | Opt g ->
+          (try let res', n = aux n g [] in Top (List.rev res') :: res, n
+          with Err _ -> Top [] :: res, n)
+      | Alt gl ->
+          let rec fst = function
+            | [] -> raise (Err ("No more alternatives for: "^cut_after !s n))
+            | g :: gl ->
+               try aux n g res
+               with Err s -> fst gl in
+          fst gl
+      | Seq gl ->
+          let rec all (res,n) = function
+            | [] -> res, n
+            | g :: gl -> all (aux n g res) gl in
+          all (res,n) gl in
+    let res, n = aux 0 g [] in
+    s := cut_after !s n;
+    List.rev res
+
+  let clean s = Str.global_replace (Str.regexp "\n") "\\n" s
+
+  let rec print g =
+    match g with
+    | Item (s,_) -> Printf.sprintf "%s" (clean s)
+    | Opt g -> Printf.sprintf "[%s]" (print g)
+    | Alt gs -> Printf.sprintf "( %s )" (String.concat " | " (List.map print gs))
+    | Seq gs -> String.concat " " (List.map print gs)
+
+  let rec print_toklist = function
+    | [] -> ""
+    | Tok(k,v) :: rest when k = v -> clean k ^ " " ^ print_toklist rest
+    | Tok(k,v) :: rest -> clean k ^ " = \"" ^ clean v ^ "\" " ^ print_toklist rest
+    | Top l :: rest -> print_toklist l ^ " " ^ print_toklist rest
+
+end (* }}} *)
+
+type sentence = {
+  name : string;
+  text : string;
+  edit_id : int;
+}
+
+let doc : sentence Document.document = Document.create ()
+
+let tip_id () =
+  try Document.tip doc
+  with
+  | Document.Empty -> Stateid.initial
+  | Invalid_argument _ -> error "add_sentence on top of non assigned tip"
+
+let add_sentence =
+  let edit_id = ref 0 in
+  fun ?(name="") text ->
+    let tip_id = tip_id () in
+    decr edit_id;
+    Document.push doc { name; text; edit_id = !edit_id };
+    !edit_id, tip_id
+
+let print_document () =
+  let ellipsize s =
+          Str.global_replace (Str.regexp "^[\n ]*") ""
+      (if String.length s > 20 then String.sub s 0 17 ^ "..."
+       else s) in
+  prerr_endline (Pp.string_of_ppcmds
+    (Document.print doc
+      (fun b state_id { name; text } ->
+        Pp.str (Printf.sprintf "%s[%10s, %3s] %s"
+          (if b then "*" else " ")
+          name
+          (Stateid.to_string (Option.default Stateid.dummy state_id))
+          (ellipsize text)))))
+
+(* This module is the logic a GUI has to implement *)
+module GUILogic = struct
+
+  let after_add = function
+    | Interface.Fail (_,_,s) -> error s
+    | Interface.Good (id, (Util.Inl (), _)) ->
+        Document.assign_tip_id doc id
+    | Interface.Good (id, (Util.Inr tip, _)) ->
+        Document.assign_tip_id doc id;
+        Document.unfocus doc;
+        ignore(Document.cut_at doc tip);
+        print_document ()
+  
+  let at id id' _ = Stateid.equal id' id
+  
+  let after_edit_at (id,need_unfocus) = function
+    | Interface.Fail (_,_,s) -> error s
+    | Interface.Good (Util.Inl ()) ->
+        if need_unfocus then Document.unfocus doc;
+        ignore(Document.cut_at doc id);
+        print_document ()
+    | Interface.Good (Util.Inr (stop_id,(start_id,tip))) ->
+        if need_unfocus then Document.unfocus doc;
+        ignore(Document.cut_at doc tip);
+        Document.focus doc ~cond_top:(at start_id) ~cond_bot:(at stop_id);
+        ignore(Document.cut_at doc id);
+        print_document ()
+  
+  let get_id_pred pred =
+    try Document.find_id doc pred
+    with Not_found -> error "No state found"
+
+  let get_id id = get_id_pred (fun _ { name } -> name = id)
+  
+  let after_fail coq = function
+    | Interface.Fail (safe_id,_,s) ->
+        prerr_endline "The command failed as expected";
+        let to_id, need_unfocus =
+          get_id_pred (fun id _ -> Stateid.equal id safe_id) in
+        after_edit_at (to_id, need_unfocus)
+          (base_eval_call (Xmlprotocol.edit_at to_id) coq)
+    | Interface.Good _ -> error "The command was expected to fail but did not"
+
+end
+
+open GUILogic
+
+let eval_print l coq =
+  let open Parser in
+  let open Xmlprotocol in
+  (* prerr_endline ("Interpreting: " ^ print_toklist l); *)
+  match l with
+  | [ Tok(_,"ADD"); Top []; Tok(_,phrase) ] ->
+      let eid, tip = add_sentence phrase in
+      after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq)
+  | [ Tok(_,"ADD"); Top [Tok(_,name)]; Tok(_,phrase) ] ->
+      let eid, tip = add_sentence ~name phrase in
+      after_add (base_eval_call (add ((phrase,eid),(tip,true))) coq)
+  | [ Tok(_,"GOALS"); ] ->
+      eval_call (goals ()) coq
+  | [ Tok(_,"FAILGOALS"); ] ->
+      after_fail coq (base_eval_call ~fail:false (goals ()) coq)
+  | [ Tok(_,"EDIT_AT"); Tok(_,id) ] ->
+      let to_id, need_unfocus = get_id id in
+      after_edit_at (to_id, need_unfocus) (base_eval_call (edit_at to_id) coq)
+  | [ Tok(_,"QUERY"); Top []; Tok(_,phrase) ] ->
+      eval_call (query (phrase,tip_id())) coq
+  | [ Tok(_,"QUERY"); Top [Tok(_,id)]; Tok(_,phrase) ] ->
+      let to_id, _ = get_id id in
+      eval_call (query (phrase, to_id)) coq
+  | [ Tok(_,"WAIT") ] ->
+      let phrase = "Stm Wait." in
+      eval_call (query (phrase,tip_id())) coq
+  | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] ->
+      let to_id, _ = get_id id in
+      if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip"
+      else prerr_endline "Good tip"
+  | Tok("#[^\n]*",_) :: _  -> ()
+  | _ -> error "syntax error"
+
+let grammar =
+  let open Parser in
+  let eat_id = eat_rex "[a-zA-Z_][a-zA-Z0-9_]*" in
+  let eat_phrase = eat_balanced '{' in
+  Alt
+    [ Seq [Item (eat_rex "ADD"); Opt (Item eat_id); Item eat_phrase]
+    ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id]
+    ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase]
+    ; Seq [Item (eat_rex "WAIT")]
+    ; Seq [Item (eat_rex "GOALS")]
+    ; Seq [Item (eat_rex "FAILGOALS")]
+    ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ]
+    ; Item (eat_rex "#[^\n]*")
+    ]
+
+let read_command inc = Parser.parse grammar inc
 
 let usage () =
-  Printf.printf
+  error (Printf.sprintf
     "A fake coqide process talking to a coqtop -ideslave.\n\
-     Usage: %s [<coqtop>]\n\
-     Input syntax is one API call per line, the keyword coming first,\n\
-     with the rest of the line as string argument (e.g. INTERP Check plus.)\n\
-     Supported API keywords are:\n" (Filename.basename Sys.argv.(0));
-  List.iter (fun (s,_) -> Printf.printf "\t%s\n" s) commands;
-  exit 1
+     Usage: %s (file|-) [<coqtop>]\n\
+     Input syntax is the following:\n%s\n"
+     (Filename.basename Sys.argv.(0))
+     (Parser.print grammar))
+
+module Coqide = Spawn.Sync(struct end)
 
 let main =
   Sys.set_signal Sys.sigpipe
     (Sys.Signal_handle
        (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1));
-  let coqtop_name = match Array.length Sys.argv with
-    | 1 -> "coqtop"
-    | 2 when Sys.argv.(1) <> "-help" -> Sys.argv.(1)
-    | _ -> usage ()
-  in
-  coqtop := Unix.open_process (coqtop_name^" -ideslave");
+  let coqtop_name, coqtop_args, input_file = match Sys.argv with
+    | [| _; f |] -> "coqtop",[|"-ideslave"|], f
+    | [| _; f; ct |] ->
+        let ct = Str.split (Str.regexp " ") ct in
+        List.hd ct, Array.of_list ("-ideslave" :: List.tl ct), f
+    | _ -> usage () in
+  let inc = if input_file = "-" then stdin else open_in input_file in
+  let coq =
+    let _p, cin, cout = Coqide.spawn coqtop_name coqtop_args in
+    let ip = Xml_parser.make (Xml_parser.SChannel cin) in
+    let op = Xml_printer.make (Xml_printer.TChannel cout) in
+    Xml_parser.check_eof ip false;
+    { xml_printer = op; xml_parser = ip } in
+  let init () =
+    match base_eval_call ~print:false (Xmlprotocol.init None) coq with
+    | Interface.Good id ->
+        let dir = Filename.dirname input_file in
+        let phrase = Printf.sprintf "Add LoadPath \"%s\". " dir in
+        let eid, tip = add_sentence ~name:"initial" phrase in
+        after_add (base_eval_call (Xmlprotocol.add ((phrase,eid),(tip,true))) coq)
+    | Interface.Fail _ -> error "init call failed" in
+  let finish () =
+    match base_eval_call (Xmlprotocol.status true) coq with
+    | Interface.Good _ -> exit 0
+    | Interface.Fail (_,_,s) -> error s in
+  (* The main loop *)
+  init ();
   while true do
-    let l = try read_line () with End_of_file -> exit 0
-    in
-    try read_eval_print l
-    with
-      | Comment -> ()
-      | e ->
-	prerr_endline ("Uncaught exception" ^ Printexc.to_string e); exit 1
+    let cmd = try read_command inc with End_of_file -> finish () in
+    try eval_print cmd coq
+    with e -> error ("Uncaught exception " ^ Printexc.to_string e)
   done
+
+(* vim:set foldmethod=marker: *)
diff --git a/tools/coq-db.el b/tools/gallina-db.el
index 5081b10b..baabebb1 100644
--- a/tools/coq-db.el
+++ b/tools/gallina-db.el
@@ -1,4 +1,4 @@
-;;; coq-db.el --- coq keywords database utility functions
+;;; gallina-db.el --- coq keywords database utility functions
 ;;
 ;; Author: Pierre Courtieu <courtieu@lri.fr>
 ;; License:     GPL (GNU GENERAL PUBLIC LICENSE)
@@ -48,7 +48,7 @@ Is ok because the longer regexp is recognized first.
 
 If non-nil the optional INSERT-FUN is the function to be called when inserting
 the form (instead of inserting INSERT, except when using \\[expand-abbrev]). This
-allows to write functions asking for more information to assist the user.
+allows writing functions asking for more information to assist the user.
 
 If non-nil the optional HIDE specifies that this form should not appear in the
 menu but only in interactive completions.
@@ -231,9 +231,9 @@ Required so that 'proof-solve-tactics-face is a proper facename")
 
 
 
-(provide 'coq-db)
+(provide 'gallina-db)
 
-;;; coq-db.el ends here
+;;; gallina-db.el ends here
 
 ;** Local Variables: ***
 ;** fill-column: 80 ***
diff --git a/tools/coq-syntax.el b/tools/gallina-syntax.el
index 8630fb3a..c25abece 100644
--- a/tools/coq-syntax.el
+++ b/tools/gallina-syntax.el
@@ -1,14 +1,14 @@
-;; coq-syntax.el Font lock expressions for Coq
+;; gallina-syntax.el Font lock expressions for Coq
 ;; Copyright (C) 1997-2007 LFCS Edinburgh. 
 ;; Authors: Thomas Kleymann, Healfdene Goguen, Pierre Courtieu
 ;; License:     GPL (GNU GENERAL PUBLIC LICENSE)
 ;; Maintainer: Pierre Courtieu <courtieu@lri.fr>
 
-;; coq-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp
+;; gallina-syntax.el,v 9.9 2008/07/21 15:14:58 pier Exp
 
 ;(require 'proof-syntax)
 ;(require 'proof-utils)                  ; proof-locate-executable
-(require 'coq-db)
+(require 'gallina-db)
 
 
 
@@ -360,6 +360,11 @@
     ("Inductive (3 args)" "indv3" "Inductive # : # :=\n| # : #\n| # : #\n| # : #." t )
     ("Inductive (4 args)" "indv4" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t )
     ("Inductive (5 args)" "indv5" "Inductive # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t )
+    ("Variant" "indv" "Variant # : # := # : #." t "Variant")
+    ("Variant (2 args)" "indv2" "Variant # : # :=\n| # : #\n| # : #." t )
+    ("Variant (3 args)" "indv3" "Variant # : # :=\n| # : #\n| # : #\n| # : #." t )
+    ("Variant (4 args)" "indv4" "Variant # : # :=\n| # : #\n| # : #\n| # : #\n| # : #." t )
+    ("Variant (5 args)" "indv5" "Variant # : # :=\n| # : #\n| # : #\n| # : #\n| # : #\n| # : #." t )
     ("Let" "Let" "Let # : # := #." t "Let")
     ("Ltac" "ltac" "Ltac # := #" t "Ltac")
     ("Module :=" "mo" "Module # : # := #." t ) ; careful
@@ -618,7 +623,7 @@
 ;; proof-done-advancing-save in generic/proof-script.el) for coq <
 ;; 8.0. It is the test when looking backward the start of the proof.
 ;; It is NOT used for coq > v8.1
-;; (coq-find-and-forget in coq.el uses state numbers, proof numbers and
+;; (coq-find-and-forget in gallina.el uses state numbers, proof numbers and
 ;; lemma names given in the prompt)
 
 ;; compatibility with v8.0, will delete it some day
@@ -950,7 +955,7 @@ Used by `coq-goal-command-p'"
   (modify-syntax-entry ?\' "_")
   (modify-syntax-entry ?\| ".")
 
-;; should maybe be "_" but it makes coq-find-and-forget (in coq.el) bug
+;; should maybe be "_" but it makes coq-find-and-forget (in gallina.el) bug
   (modify-syntax-entry ?\. ".") 
 
   (condition-case nil
@@ -969,8 +974,8 @@ Used by `coq-goal-command-p'"
  		  1))
  	  (append coq-keywords-decl coq-keywords-defn coq-keywords-goal)))
 
-(provide 'coq-syntax)
- ;;; coq-syntax.el ends here
+(provide 'gallina-syntax)
+ ;;; gallina-syntax.el ends here
 
 ; Local Variables: ***
 ; indent-tabs-mode: nil ***
diff --git a/tools/coq.el b/tools/gallina.el
index f4c4b033..cbc13118 100644
--- a/tools/coq.el
+++ b/tools/gallina.el
@@ -1,15 +1,15 @@
-;; coq.el --- Coq mode editing commands for Emacs
+;; gallina.el --- Coq mode editing commands for Emacs
 ;;
 ;; Jean-Christophe Filliatre, march 1995
-;; Honteusement pompé de caml.el, Xavier Leroy, july 1993.
+;; Shamelessly copied from caml.el, Xavier Leroy, july 1993.
 ;;
-;; modified by Marco Maggesi <maggesi@math.unifi.it> for coq-inferior
+;; modified by Marco Maggesi <maggesi@math.unifi.it> for gallina-inferior
 
 ; compatibility code for proofgeneral files
 (require 'coq-font-lock)
 ; ProofGeneral files. remember to remove coq version tests in
-; coq-syntax.el
-(require 'coq-syntax)
+; gallina-syntax.el
+(require 'gallina-syntax)
 
 (defvar coq-mode-map nil
   "Keymap used in Coq mode.")
@@ -137,6 +137,6 @@ Does nothing otherwise."
              (coq-in-indentation))
         (backward-delete-char-untabify coq-mode-indentation))))
 
-;;; coq.el ends here
+;;; gallina.el ends here
 
-(provide 'coq)
+(provide 'gallina)
diff --git a/tools/gallina.ml b/tools/gallina.ml
index 2e9a17f6..279919c5 100644
--- a/tools/gallina.ml
+++ b/tools/gallina.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        *)
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
index e6f6f4b3..9dd49b90 100644
--- a/tools/gallina_lexer.mll
+++ b/tools/gallina_lexer.mll
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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 Lexing
 
  let chan_out = ref stdout
 
diff --git a/tools/mingwpath.ml b/tools/mingwpath.ml
deleted file mode 100644
index f01b62cc..00000000
--- a/tools/mingwpath.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-(** Mingwpath *)
-
-(** Converts mingw-encoded filenames such as:
-
-      /c/Program Files/Ocaml/bin
-
-    to a more windows-friendly form (but still with / instead of \) :
-
-      c:/Program Files/Ocaml/bin
-
-    This nice hack was suggested by Benjamin Monate (cf bug #2526)
-    to mimic the cygwin-specific tool cygpath
-*)
-
-print_string Sys.argv.(1)
diff --git a/tools/update-require b/tools/update-require
new file mode 100755
index 00000000..cc9a27b8
--- /dev/null
+++ b/tools/update-require
@@ -0,0 +1,103 @@
+#!/bin/sh
+
+# This script fully qualifies all the 'Require' statements of the given
+# targets (or the current directory if none).
+#
+# It assumes that all the prerequisites are already installed. The
+# install location is found using the COQLIB, COQC, COQBIN variables if
+# set, 'coqc' otherwise.
+#
+# Option --exclude can be used to ignore a given user contribution. In
+# particular, it can be used to ignore the current set of files if it
+# happens to be already installed.
+#
+# Option --stdlib can be used to also qualify the files from the standard
+# library.
+
+if test ! "$COQLIB"; then
+  if test ${COQBIN##*/}; then COQBIN=$COQBIN/; fi
+  if test ! "$COQC"; then COQC=`which ${COQBIN}coqc`; fi
+  COQLIB=`"$COQC" -where`
+fi
+
+stdlib=no
+exclude=""
+
+scan_dir () {
+  (cd $1 ; find $3 -name '*.vo' |
+  sed -e "s,^./,$2,;s,\([^./]*\)/,\1.,g;s,\([^.]*\).vo,\1,")
+}
+
+scan_all_dir () {
+  if test $stdlib = yes; then
+    scan_dir "$COQLIB/theories" "Coq."
+    scan_dir "$COQLIB/plugins" "Coq."
+  fi
+  scan_dir "$COQLIB/user-contrib" "" "$exclude"
+}
+
+create_script () {
+  echo "BEGIN {"
+  scan_all_dir |
+  while read file ; do
+    echo $file | sed -e "s,\(.*\)[.]\([^.]*\),  t[\"\2\"] = \"\1.\2\","
+  done
+  cat <<EOF
+}
+
+\$1 ~ "Require" {
+  for (i = 2; i <= NF; ++i) {
+    if (\$i ~ /[.]\$/) {
+      s = substr(\$i,1,length(\$i)-1)
+      if (t[s]) \$i = t[s] "."
+      break
+    } else if (t[\$i]) \$i = t[\$i]
+  }
+  print
+  next
+}
+
+{ print }
+EOF
+}
+
+usage () {
+  cat <<EOF
+Usage: $0 [OPTION...] [TARGET...]
+The default TARGET is the current directory.
+Available options:
+  --exclude CONTRIB        Do not qualify path to the given CONTRIB
+  --stdlib                 Qualify files from the standard library
+  --help                   Display this message
+EOF
+}
+
+dir=""
+while : ; do
+  case "$1" in
+    "")
+      break;;
+    -h|--help)
+      usage
+      exit 0;;
+    --exclude)
+      exclude="$exclude -path ./$2 -prune -type f -o"
+      shift;;
+    --stdlib)
+      stdlib=yes;;
+    -*)
+      echo "Unknown option $1" 1>&2
+      exit 1;;
+    *)
+      dir="$dir $1";;
+  esac
+  shift
+done
+
+script=`tempfile`
+create_script > $script
+find $dir -name '*.v' |
+while read file; do
+  mv $file $file.bak
+  awk -f $script $file.bak > $file
+done
diff --git a/tools/win32hack.mllib b/tools/win32hack.mllib
deleted file mode 100644
index 42395f65..00000000
--- a/tools/win32hack.mllib
+++ /dev/null
@@ -1 +0,0 @@
-Win32hack_filename
\ No newline at end of file
diff --git a/tools/win32hack_filename.ml b/tools/win32hack_filename.ml
deleted file mode 100644
index 74f70686..00000000
--- a/tools/win32hack_filename.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-(* The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
-   Let's tweak that... *)
-
-let _ = Filename.dir_sep.[0] <- '\\'
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 2e775f30..26b54a73 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.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        *)
@@ -10,24 +10,22 @@
    decidable equality, created by Vincent Siles, Oct 2007 *)
 
 open Tacmach
+open Errors
 open Util
-open Flags
-open Decl_kinds
 open Pp
-open Entries
+open Term
+open Vars
 open Termops
 open Declarations
-open Declare
-open Term
 open Names
-open Libnames
-open Goptions
-open Mod_subst
-open Indrec
+open Globnames
 open Inductiveops
 open Tactics
-open Tacticals
 open Ind_tables
+open Misctypes
+open Proofview.Notations
+
+let out_punivs = Univ.out_punivs
 
 (**********************************************************************)
 (* Generic synthesis of boolean equality *)
@@ -45,9 +43,9 @@ and aux = function
   if n > (List.length l) then failwith "quick_chop args"
   else kick_last (aux (n,l) )
 
-let rec deconstruct_type t =
+let deconstruct_type t =
   let l,r = decompose_prod t in
-    (List.map (fun (_,b) -> b) (List.rev l))@[r]
+  (List.rev_map snd l)@[r]
 
 exception EqNotFound of inductive * inductive
 exception EqUnknown of string
@@ -57,7 +55,9 @@ exception InductiveWithSort
 exception ParameterWithoutEquality of constant
 exception NonSingletonProp of inductive
 
-let dl = dummy_loc
+let dl = Loc.ghost
+
+let constr_of_global g = lazy (Universes.constr_of_global g)
 
 (* Some pre declaration of constant we are going to use *)
 let bb = constr_of_global Coqlib.glob_bool
@@ -77,27 +77,21 @@ let sumbool = Coqlib.build_coq_sumbool
 
 let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb
 
-let induct_on c =
-  new_induct false
-    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
-    None (None,None) None
+let induct_on c = induction false None c None None
+
+let destruct_on c = destruct false None c None None
 
 let destruct_on_using c id =
-  new_destruct false
-    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
-    None
-    (None,Some (dl,Genarg.IntroOrAndPattern [
-                                    [dl,Genarg.IntroAnonymous];
-                                    [dl,Genarg.IntroIdentifier id]]))
+  destruct false None c
+    (Some (dl,[[dl,IntroNaming IntroAnonymous];
+               [dl,IntroNaming (IntroIdentifier id)]]))
     None
 
-let destruct_on c =
-  new_destruct false
-    [Tacexpr.ElimOnConstr (Evd.empty,(c,Glob_term.NoBindings))]
-    None (None,None) None
+let destruct_on_as c l =
+  destruct false None c (Some (dl,l)) None
 
 (* reconstruct the inductive with the correct deBruijn indexes *)
-let mkFullInd ind n =
+let mkFullInd (ind,u) n =
   let mib = Global.lookup_mind (fst ind) in
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
@@ -105,12 +99,12 @@ let mkFullInd ind n =
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
   if nparrec > 0
-    then mkApp (mkInd ind,
+    then mkApp (mkIndU (ind,u),
       Array.of_list(extended_rel_list (nparrec+n) lnamesparrec))
-    else mkInd ind
+    else mkIndU (ind,u)
 
 let check_bool_is_defined () =
-  try let _ = Global.type_of_global Coqlib.glob_bool in ()
+  try let _ = Global.type_of_global_unsafe Coqlib.glob_bool in ()
   with e when Errors.noncritical e -> raise (UndefinedCst "bool")
 
 let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
@@ -131,22 +125,22 @@ let build_beq_scheme kn =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
   (* predef coq's boolean type *)
   (* rec name *)
-  let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^
+  let rec_name i =(Id.to_string (Array.get mib.mind_packets i).mind_typename)^
                     "_eqrec"
   in
   (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *)
   let create_input c =
     let myArrow u v = mkArrow u (lift 1 v)
     and eqName = function
-        | Name s -> id_of_string ("eq_"^(string_of_id s))
-        | Anonymous -> id_of_string "eq_A"
+        | Name s -> Id.of_string ("eq_"^(Id.to_string s))
+        | Anonymous -> Id.of_string "eq_A"
     in
     let ext_rel_list = extended_rel_list 0 lnamesparrec in
       let lift_cnt = ref 0 in
       let eqs_typ = List.map (fun aa ->
                                 let a = lift !lift_cnt aa in
                                   incr lift_cnt;
-                                  myArrow a (myArrow a bb)
+                                  myArrow a (myArrow a (Lazy.force bb))
                              ) ext_rel_list in
 
         let eq_input = List.fold_left2
@@ -159,15 +153,16 @@ let build_beq_scheme kn =
         List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *)
           (* Same here , hoping the auto renaming will do something good ;)  *)
           mkNamedLambda
-                (match n with Name s -> s | Anonymous ->  id_of_string "A")
+                (match n with Name s -> s | Anonymous ->  Id.of_string "A")
                 t  a) eq_input lnamesparrec
  in
  let make_one_eq cur =
-  let ind = kn,cur in
+  let u = Univ.Instance.empty in
+  let ind = (kn,cur),u (* FIXME *) in
   (* current inductive we are working on *)
-  let cur_packet = mib.mind_packets.(snd ind) in
+  let cur_packet = mib.mind_packets.(snd (fst ind)) in
   (* Inductive toto : [rettyp] := *)
-  let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in
+  let rettyp = Inductive.type_of_inductive env ((mib,cur_packet),u) in
   (* split rettyp in a list without the non rec params and the last ->
   e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *)
   let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in
@@ -182,31 +177,39 @@ let build_beq_scheme kn =
       let rec aux c =
 	let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in
 	match kind_of_term c with
-        | Rel x -> mkRel (x-nlist+ndx)
-        | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x)))
+        | Rel x -> mkRel (x-nlist+ndx), Declareops.no_seff
+        | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Declareops.no_seff
         | Cast (x,_,_) -> aux (applist (x,a))
         | App _ -> assert false
-        | Ind (kn',i as ind') -> if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1)
-                        else ( try
-			  let a = Array.of_list a in
-                          let eq = mkConst (find_scheme (!beq_scheme_kind_aux()) (kn',i))
-                          and eqa = Array.map aux a
-			  in
-                            let args = Array.append
-                                (Array.map (fun x->lift lifti x) a) eqa
-                            in if args = [||] then eq
-                               else mkApp (eq,Array.append
-                                      (Array.map (fun x->lift lifti x) a) eqa)
-                         with Not_found -> raise(EqNotFound (ind',ind))
-                        )
+        | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> 
+            if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Declareops.no_seff
+            else begin
+              try
+                let eq, eff =
+                  let c, eff = find_scheme (!beq_scheme_kind_aux()) (kn',i) in
+                  mkConst c, eff in
+                let eqa, eff =
+                  let eqa, effs = List.split (List.map aux a) in
+                  Array.of_list eqa,
+                  Declareops.union_side_effects
+                    (Declareops.flatten_side_effects (List.rev effs))
+                    eff in
+                let args =
+                  Array.append 
+                    (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in
+                if Int.equal (Array.length args) 0 then eq, eff
+                else mkApp (eq, args), eff
+              with Not_found -> raise(EqNotFound (ind', fst ind))
+            end
         | Sort _  -> raise InductiveWithSort
         | Prod _ -> raise InductiveWithProduct
         | Lambda _-> raise (EqUnknown "Lambda")
         | LetIn _ -> raise (EqUnknown "LetIn")
         | Const kn ->
-	    (match Environ.constant_opt_value env kn with
-	      | None -> raise (ParameterWithoutEquality kn)
+	    (match Environ.constant_opt_value_in env kn with
+	      | None -> raise (ParameterWithoutEquality (fst kn))
 	      | Some c -> aux (applist (c,a)))
+        | Proj _ -> raise (EqUnknown "Proj")
         | Construct _ -> raise (EqUnknown "Construct")
         | Case _ -> raise (EqUnknown "Case")
         | CoFix _ -> raise (EqUnknown "CoFix")
@@ -221,35 +224,37 @@ let build_beq_scheme kn =
      List.fold_left (fun a b -> mkLambda(Anonymous,b,a))
       (mkLambda (Anonymous,
                  mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1),
-                 bb))
+                 (Lazy.force bb)))
       (List.rev rettyp_l) in
   (* make_one_eq *)
   (* do the [| C1 ... =>  match Y with ... end
                ...
                Cn => match Y with ... end |]  part *)
-    let ci = make_case_info env ind MatchStyle in
+    let ci = make_case_info env (fst ind) MatchStyle in
     let constrs n = get_constructors env (make_ind_family (ind,
       extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in
     let constrsi = constrs (3+nparrec) in
     let n = Array.length constrsi in
-    let ar = Array.create n ff in
+    let ar = Array.make n (Lazy.force ff) in
+    let eff = ref Declareops.no_seff in
 	for i=0 to n-1 do
 	  let nb_cstr_args = List.length constrsi.(i).cs_args in
-	  let ar2 = Array.create n ff in
+	  let ar2 = Array.make n (Lazy.force ff) in
           let constrsj = constrs (3+nparrec+nb_cstr_args) in
 	    for j=0 to n-1 do
-	      if (i=j) then
+	      if Int.equal i j then
 		ar2.(j) <- let cc = (match nb_cstr_args with
-                    | 0 -> tt
-                    | _ -> let eqs = Array.make nb_cstr_args tt in
+                    | 0 -> Lazy.force tt
+                    | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in
                       for ndx = 0 to nb_cstr_args-1 do
                         let _,_,cc = List.nth constrsi.(i).cs_args ndx in
-                          let eqA = compute_A_equality rel_list
+                          let eqA, eff' = compute_A_equality rel_list
                                           nparrec
                                           (nparrec+3+2*nb_cstr_args)
                                           (nb_cstr_args+ndx+1)
                                           cc
                           in
+                          eff := Declareops.union_side_effects eff' !eff;
                           Array.set eqs ndx
                               (mkApp (eqA,
                                 [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|]
@@ -265,33 +270,40 @@ let build_beq_scheme kn =
                     (constrsj.(j).cs_args)
 		)
 	      else ar2.(j) <- (List.fold_left (fun a (p,q,r) ->
-			mkLambda (p,r,a)) ff (constrsj.(j).cs_args) )
+			mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) )
 	    done;
 
 	  ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a))
 			(mkCase (ci,do_predicate rel_list nb_cstr_args,
-				  mkVar (id_of_string "Y") ,ar2))
+				  mkVar (Id.of_string "Y") ,ar2))
 			 (constrsi.(i).cs_args))
 	done;
-        mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1))  (
-          mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2))  (
- 	    mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar)))
+        mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1))  (
+          mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2))  (
+ 	    mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))),
+        !eff
     in (* build_beq_scheme *)
     let names = Array.make nb_ind Anonymous and
         types = Array.make nb_ind mkSet and
         cores = Array.make nb_ind mkSet in
+    let eff = ref Declareops.no_seff in
+    let u = Univ.Instance.empty in
     for i=0 to (nb_ind-1) do
-        names.(i) <- Name (id_of_string (rec_name i));
-	types.(i) <- mkArrow (mkFullInd (kn,i) 0)
-                     (mkArrow (mkFullInd (kn,i) 1) bb);
-        cores.(i) <- make_one_eq i
+        names.(i) <- Name (Id.of_string (rec_name i));
+	types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0)
+                     (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb));
+        let c, eff' = make_one_eq i in
+        cores.(i) <- c;
+        eff := Declareops.union_side_effects eff' !eff
     done;
-    Array.init nb_ind (fun i ->
+      (Array.init nb_ind (fun i ->
       let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in
-	if not (List.mem InSet kelim) then
+	if not (Sorts.List.mem InSet kelim) then
 	  raise (NonSingletonProp (kn,i));
         let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in
-        create_input fix)
+        create_input fix),
+       Evd.empty_evar_universe_context (* FIXME *)),
+      !eff
 
 let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme
 
@@ -304,9 +316,8 @@ let destruct_ind c =
     try let u,v =  destApp c in
           let indc = destInd u in
             indc,v
-    with e when Errors.noncritical e ->
-      let indc = destInd c in
-      indc,[||]
+    with DestKO -> let indc = destInd c in
+            indc,[||]
 
 (*
   In the following, avoid is the list of names to avoid.
@@ -317,7 +328,7 @@ let destruct_ind c =
 so from Ai we can find the the correct eq_Ai bl_ai or lb_ai
 *)
 (* used in the leib -> bool side*)
-let do_replace_lb lb_scheme_key aavoid narg gls p q =
+let do_replace_lb lb_scheme_key aavoid narg p q =
   let avoid = Array.of_list aavoid in
   let do_arg v offset =
   try
@@ -325,47 +336,56 @@ let do_replace_lb lb_scheme_key aavoid narg gls p q =
     let s = destVar v in
     let n = Array.length avoid in
     let rec find i =
-      if avoid.(n-i) = s then avoid.(n-i-x)
+      if Id.equal avoid.(n-i) s then avoid.(n-i-x)
       else (if i<n then find (i+1)
-            else error ("Var "^(string_of_id s)^" seems unknown.")
+            else error ("Var "^(Id.to_string s)^" seems unknown.")
       )
     in mkVar (find 1)
   with e when Errors.noncritical e ->
       (* if this happen then the args have to be already declared as a
-         Parameter*)
+              Parameter*)
       (
-        let mp,dir,lbl = repr_con (destConst v) in
+        let mp,dir,lbl = repr_con (fst (destConst v)) in
           mkConst (make_con mp dir (mk_label (
-          if offset=1 then ("eq_"^(string_of_label lbl))
-                       else ((string_of_label lbl)^"_lb")
+          if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
+                       else ((Label.to_string lbl)^"_lb")
         )))
       )
   in
-  let type_of_pq = pf_type_of gls p in
+  Proofview.Goal.nf_enter begin fun gl ->
+    let type_of_pq = Tacmach.New.of_old (fun gl -> pf_type_of gl p) gl in
     let u,v = destruct_ind type_of_pq
     in let lb_type_of_p =
-        try mkConst (find_scheme lb_scheme_key u)
+        try
+          let c, eff = find_scheme lb_scheme_key (out_punivs u) (*FIXME*) in
+          Proofview.tclUNIT (mkConst c, eff)
         with Not_found ->
           (* spiwack: the format of this error message should probably
 	              be improved. *)
-          let err_msg = string_of_ppcmds
-	                              (str "Leibniz->boolean:" ++
-                                       str "You have to declare the" ++
-				       str "decidability over " ++
-				       Printer.pr_constr type_of_pq ++
-				       str " first.")
+          let err_msg =
+	    (str "Leibniz->boolean:" ++
+             str "You have to declare the" ++
+	     str "decidability over " ++
+	     Printer.pr_constr type_of_pq ++
+	     str " first.")
           in
-          error err_msg
-    in let lb_args = Array.append (Array.append
+          Proofview.tclZERO (Errors.UserError("",err_msg))
+       in
+       lb_type_of_p >>= fun (lb_type_of_p,eff) ->
+       let lb_args = Array.append (Array.append
                           (Array.map (fun x -> x) v)
                           (Array.map (fun x -> do_arg x 1) v))
                           (Array.map (fun x -> do_arg x 2) v)
-        in let app =  if lb_args = [||]
+        in let app =  if Array.equal eq_constr lb_args [||]
                        then lb_type_of_p else mkApp (lb_type_of_p,lb_args)
-            in [Equality.replace p q ; apply app ; Auto.default_auto]
+           in
+           Tacticals.New.tclTHENLIST [
+             Proofview.tclEFFECTS eff;
+             Equality.replace p q ; apply app ; Auto.default_auto]
+  end
 
 (* used in the bool -> leib side *)
-let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
+let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt =
   let avoid = Array.of_list aavoid in
   let do_arg v offset =
   try
@@ -373,36 +393,40 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
     let s = destVar v in
     let n = Array.length avoid in
     let rec find i =
-      if avoid.(n-i) = s then avoid.(n-i-x)
+      if Id.equal avoid.(n-i) s then avoid.(n-i-x)
       else (if i<n then find (i+1)
-            else error ("Var "^(string_of_id s)^" seems unknown.")
+            else error ("Var "^(Id.to_string s)^" seems unknown.")
       )
     in mkVar (find 1)
   with e when Errors.noncritical e ->
       (* if this happen then the args have to be already declared as a
          Parameter*)
       (
-        let mp,dir,lbl = repr_con (destConst v) in
+        let mp,dir,lbl = repr_con (fst (destConst v)) in
           mkConst (make_con mp dir (mk_label (
-          if offset=1 then ("eq_"^(string_of_label lbl))
-                       else ((string_of_label lbl)^"_bl")
+          if Int.equal offset 1 then ("eq_"^(Label.to_string lbl))
+                       else ((Label.to_string lbl)^"_bl")
         )))
       )
   in
 
   let rec aux l1 l2 =
     match (l1,l2) with
-    | (t1::q1,t2::q2) -> let tt1 = pf_type_of gls t1 in
-        if t1=t2 then aux q1 q2
+    | (t1::q1,t2::q2) ->
+        Proofview.Goal.enter begin fun gl ->
+        let tt1 = Tacmach.New.pf_type_of gl t1 in
+        if eq_constr t1 t2 then aux q1 q2
         else (
           let u,v = try  destruct_ind tt1
           (* trick so that the good sequence is returned*)
-                with e when Errors.noncritical e -> ind,[||]
-          in if u = ind
-             then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2)
+                with e when Errors.noncritical e -> indu,[||]
+          in if eq_ind (fst u) ind
+             then Tacticals.New.tclTHENLIST [Equality.replace t1 t2; Auto.default_auto ; aux q1 q2 ]
              else (
-               let bl_t1 =
-               try mkConst (find_scheme bl_scheme_key u)
+               let bl_t1, eff =
+               try 
+                 let c, eff = find_scheme bl_scheme_key (out_punivs u) (*FIXME*) in
+                 mkConst c, eff
                with Not_found ->
 		 (* spiwack: the format of this error message should probably
 	                     be improved. *)
@@ -420,33 +444,41 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
                           (Array.map (fun x -> do_arg x 1) v))
                           (Array.map (fun x -> do_arg x 2) v )
                 in
-                let app =  if bl_args = [||]
+                let app =  if Array.equal eq_constr bl_args [||]
                            then bl_t1 else mkApp (bl_t1,bl_args)
                 in
-                  (Equality.replace_by t1 t2
-                    (tclTHEN (apply app) (Auto.default_auto)))::(aux q1 q2)
+                Tacticals.New.tclTHENLIST [
+                  Proofview.tclEFFECTS eff;
+                  Equality.replace_by t1 t2
+                    (Tacticals.New.tclTHEN (apply app) (Auto.default_auto)) ;
+                  aux q1 q2 ]
               )
         )
-    | ([],[]) -> []
-    | _ -> error "Both side of the equality must have the same arity."
-  in
-  let (ind1,ca1) =
-    try destApp lft with e when Errors.noncritical e -> error "replace failed."
-  and (ind2,ca2) =
-    try destApp rgt with e when Errors.noncritical e -> error "replace failed."
+        end
+    | ([],[]) -> Proofview.tclUNIT ()
+    | _ -> Proofview.tclZERO (UserError ("" , str"Both side of the equality must have the same arity."))
   in
-  let (sp1,i1) =
-    try destInd ind1 with e when Errors.noncritical e ->
-      try fst (destConstruct ind1) with e when Errors.noncritical e ->
-        error "The expected type is an inductive one."
-  and (sp2,i2) =
-    try destInd ind2 with e when Errors.noncritical e ->
-      try fst (destConstruct ind2) with e when Errors.noncritical e ->
-        error "The expected type is an inductive one."
-  in
-    if (sp1 <> sp2) || (i1 <> i2)
-      then (error "Eq should be on the same type")
-      else (aux (Array.to_list ca1) (Array.to_list ca2))
+  begin try Proofview.tclUNIT (destApp lft)
+    with DestKO ->  Proofview.tclZERO (UserError ("" , str"replace failed."))
+  end >>= fun (ind1,ca1) ->
+  begin try Proofview.tclUNIT (destApp rgt)
+    with DestKO -> Proofview.tclZERO (UserError ("" , str"replace failed."))
+  end >>= fun (ind2,ca2) ->
+  begin try Proofview.tclUNIT (out_punivs (destInd ind1))
+    with DestKO ->
+      begin try Proofview.tclUNIT (fst (fst (destConstruct ind1)))
+        with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one."))
+      end
+  end >>= fun (sp1,i1) ->
+  begin try Proofview.tclUNIT (out_punivs (destInd ind2))
+    with DestKO ->
+      begin try Proofview.tclUNIT (fst (fst (destConstruct ind2)))
+        with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one."))
+      end
+  end >>= fun (sp2,i2) ->
+  if not (eq_mind sp1 sp2) || not (Int.equal i1 i2)
+  then Proofview.tclZERO (UserError ("" , str"Eq should be on the same type"))
+  else aux (Array.to_list ca1) (Array.to_list ca2)
 
 (*
   create, from a list of ids [i1,i2,...,in] the list
@@ -454,11 +486,11 @@ let do_replace_bl bl_scheme_key ind gls aavoid narg lft rgt =
 *)
 let list_id l = List.fold_left ( fun a (n,_,t) -> let s' =
       match n with
-        Name s -> string_of_id s
+        Name s -> Id.to_string s
       | Anonymous -> "A" in
-          (id_of_string s',id_of_string ("eq_"^s'),
-              id_of_string (s'^"_bl"),
-              id_of_string (s'^"_lb"))
+          (Id.of_string s',Id.of_string ("eq_"^s'),
+              Id.of_string (s'^"_bl"),
+              Id.of_string (s'^"_lb"))
             ::a
     ) [] l
 (*
@@ -468,52 +500,54 @@ let eqI ind l =
   let list_id = list_id l in
   let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@
                            (List.map (fun (_,seq,_,_)-> mkVar seq) list_id ))
-  and  e = try mkConst (find_scheme beq_scheme_kind ind) with
-    Not_found -> error
+  and e, eff = 
+    try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff 
+    with Not_found -> error
         ("The boolean equality on "^(string_of_mind (fst ind))^" is needed.");
-  in (if eA = [||] then e else mkApp(e,eA))
+  in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff
 
 (**********************************************************************)
 (* Boolean->Leibniz *)
 
 let compute_bl_goal ind lnamesparrec nparrec =
-  let eqI = eqI ind lnamesparrec in
+  let eqI, eff = eqI ind lnamesparrec in
   let list_id = list_id lnamesparrec in
   let create_input c =
-    let x = id_of_string "x" and
-        y = id_of_string "y" in
+    let x = Id.of_string "x" and
+        y = Id.of_string "y" in
       let bl_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
               mkArrow
-               ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|]))
-               ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|]))
+               ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|]))
+               ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|]))
           ))
         ) list_id in
       let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b ->
         mkNamedProd sbl b a
       ) c (List.rev list_id) (List.rev bl_typ) in
       let eqs_typ = List.map (fun (s,_,_,_) ->
-          mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb))
+          mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb)))
           ) list_id in
       let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b ->
         mkNamedProd seq b a
       ) bl_input (List.rev list_id) (List.rev eqs_typ) in
       List.fold_left (fun a (n,_,t) -> mkNamedProd
-                (match n with Name s -> s | Anonymous ->  id_of_string "A")
+                (match n with Name s -> s | Anonymous ->  Id.of_string "A")
                 t  a) eq_input lnamesparrec
     in
-      let n = id_of_string "x" and
-          m = id_of_string "y" in
+      let n = Id.of_string "x" and
+          m = Id.of_string "y" in
+      let u = Univ.Instance.empty in
      create_input (
-        mkNamedProd n (mkFullInd ind nparrec) (
-          mkNamedProd m (mkFullInd ind (nparrec+1)) (
+        mkNamedProd n (mkFullInd (ind,u) nparrec) (
+          mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
             mkArrow
-              (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
-              (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|]))
-        )))
+              (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|]))
+              (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|]))
+        ))), eff
 
-let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig =
+let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec =
   let list_id = list_id lnamesparrec in
   let avoid = ref [] in
       let first_intros =
@@ -521,83 +555,88 @@ let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec gsig =
         ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @
         ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id )
       in
-      let fresh_first_intros = List.map ( fun s ->
-        let fresh = fresh_id (!avoid) s gsig in
-        avoid := fresh::(!avoid); fresh ) first_intros in
-      let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
-      let freshm = avoid := freshn::(!avoid);
-            fresh_id (!avoid) (id_of_string "y") gsig in
-      let freshz = avoid := freshm::(!avoid);
-            fresh_id (!avoid) (id_of_string "Z") gsig in
+      let fresh_id s gl =
+        Tacmach.New.of_old begin fun gsig ->
+          let fresh = fresh_id (!avoid) s gsig in
+          avoid := fresh::(!avoid); fresh
+        end gl
+      in
+      Proofview.Goal.nf_enter begin fun gl ->
+      let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
+      let freshn = fresh_id (Id.of_string "x") gl in
+      let freshm = fresh_id (Id.of_string "y") gl in
+      let freshz = fresh_id (Id.of_string "Z") gl in
   (* try with *)
-      avoid := freshz::(!avoid);
-      tclTHENSEQ [ intros_using fresh_first_intros;
+      Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
                      intro_using freshn ;
                      induct_on (mkVar freshn);
                      intro_using freshm;
                      destruct_on (mkVar freshm);
                      intro_using freshz;
                      intros;
-                     tclTRY (
-                      tclORELSE reflexivity (Equality.discr_tac false None)
+                     Tacticals.New.tclTRY (
+                      Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
                      );
-                     simpl_in_hyp (freshz,InHyp);
+                     Proofview.V82.tactic (simpl_in_hyp (freshz,Locus.InHyp));
 (*
 repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]).
 *)
-                    tclREPEAT (
-                      tclTHENSEQ [
-                         simple_apply_in freshz (andb_prop());
-                         fun gl ->
-                           let fresht = fresh_id (!avoid) (id_of_string "Z") gsig
-                           in
-                            avoid := fresht::(!avoid);
-                            (new_destruct false [Tacexpr.ElimOnConstr
-                                      (Evd.empty,((mkVar freshz,Glob_term.NoBindings)))]
-                                  None
-                                  (None, Some (dl,Genarg.IntroOrAndPattern [[
-                                    dl,Genarg.IntroIdentifier fresht;
-                                    dl,Genarg.IntroIdentifier freshz]])) None) gl
+                    Tacticals.New.tclREPEAT (
+                      Tacticals.New.tclTHENLIST [
+                         Simple.apply_in freshz (andb_prop());
+                         Proofview.Goal.nf_enter begin fun gl ->
+                           let fresht = fresh_id (Id.of_string "Z") gl in
+                            (destruct_on_as (mkVar freshz)
+                                  [[dl,IntroNaming (IntroIdentifier fresht);
+                                    dl,IntroNaming (IntroIdentifier freshz)]])
+                         end
                         ]);
 (*
   Ci a1 ... an = Ci b1 ... bn
  replace bi with ai; auto || replace bi with ai by  apply typeofbi_prod ; auto
 *)
-                    fun gls-> let gl = pf_concl gls in
-                      match (kind_of_term gl) with
-                      | App (c,ca) -> (
-                        match (kind_of_term c) with
-                        | Ind indeq ->
-                            if IndRef indeq = Coqlib.glob_eq
-                            then (
-                              tclTHENSEQ ((do_replace_bl bl_scheme_key ind gls
-				                      (!avoid)
-                                                      nparrec (ca.(2))
-                              (ca.(1)))@[Auto.default_auto]) gls
-                            )
-                            else
-                              (error "Failure while solving Boolean->Leibniz.")
-                        | _ -> error "Failure while solving Boolean->Leibniz."
-                      )
-                      | _ -> error "Failure while solving Boolean->Leibniz."
-
-                    ] gsig
+                      Proofview.Goal.nf_enter begin fun gls ->
+                        let gl = Proofview.Goal.concl gls in
+                        match (kind_of_term gl) with
+                        | App (c,ca) -> (
+                          match (kind_of_term c) with
+                          | Ind (indeq, u) ->
+                              if eq_gr (IndRef indeq) Coqlib.glob_eq
+                              then
+                                Tacticals.New.tclTHEN
+                                  (do_replace_bl bl_scheme_key ind
+				     (!avoid)
+                                     nparrec (ca.(2))
+                                     (ca.(1)))
+                                  Auto.default_auto
+                              else
+                                Proofview.tclZERO (UserError ("",str"Failure while solving Boolean->Leibniz."))
+                          | _ -> Proofview.tclZERO (UserError ("", str"Failure while solving Boolean->Leibniz."))
+                        )
+                        | _ -> Proofview.tclZERO (UserError ("", str"Failure while solving Boolean->Leibniz."))
+                      end
+
+                    ]
+      end
 
 let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined")
 
 let make_bl_scheme mind =
   let mib = Global.lookup_mind mind in
-  if Array.length mib.mind_packets <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) then
     errorlabstrm ""
       (str "Automatic building of boolean->Leibniz lemmas not supported");
   let ind = (mind,0) in
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
-  let lnonparrec,lnamesparrec =
+  let lnonparrec,lnamesparrec = (* TODO subst *)
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic (Global.env())
-    (compute_bl_goal ind lnamesparrec nparrec)
-    (compute_bl_tact (!bl_scheme_kind_aux()) ind lnamesparrec nparrec)|]
+  let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in
+  let ctx = Evd.empty_evar_universe_context (*FIXME univs *) in
+  let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx bl_goal
+    (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec)
+  in
+  ([|ans|], ctx), eff
 
 let bl_scheme_kind = declare_mutual_scheme_object "_dec_bl" make_bl_scheme
 
@@ -608,10 +647,11 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind
 
 let compute_lb_goal ind lnamesparrec nparrec =
   let list_id = list_id lnamesparrec in
-  let eqI = eqI ind lnamesparrec in
+  let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
+  let eqI, eff = eqI ind lnamesparrec in
     let create_input c =
-      let x = id_of_string "x" and
-          y = id_of_string "y" in
+      let x = Id.of_string "x" and
+          y = Id.of_string "y" in
       let lb_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
@@ -630,20 +670,21 @@ let compute_lb_goal ind lnamesparrec nparrec =
         mkNamedProd seq b a
       ) lb_input (List.rev list_id) (List.rev eqs_typ) in
       List.fold_left (fun a (n,_,t) -> mkNamedProd
-                (match n with Name s -> s | Anonymous ->  id_of_string "A")
+                (match n with Name s -> s | Anonymous ->  Id.of_string "A")
                 t  a) eq_input lnamesparrec
     in
-      let n = id_of_string "x" and
-          m = id_of_string "y" in
+      let n = Id.of_string "x" and
+          m = Id.of_string "y" in
+      let u = Univ.Instance.empty in
       create_input (
-        mkNamedProd n (mkFullInd ind nparrec) (
-          mkNamedProd m (mkFullInd ind (nparrec+1)) (
+        mkNamedProd n (mkFullInd (ind,u) nparrec) (
+          mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) (
             mkArrow
-              (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|]))
+              (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|]))
               (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|]))
-        )))
+        ))), eff
 
-let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig =
+let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec =
   let list_id = list_id lnamesparrec in
     let avoid = ref [] in
       let first_intros =
@@ -651,55 +692,60 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec gsig =
         ( List.map (fun (_,seq,_,_) -> seq) list_id ) @
         ( List.map (fun (_,_,_,slb) -> slb) list_id )
       in
-      let fresh_first_intros = List.map ( fun s ->
-        let fresh = fresh_id (!avoid) s gsig in
-        avoid := fresh::(!avoid); fresh ) first_intros in
-      let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
-      let freshm = avoid := freshn::(!avoid);
-            fresh_id (!avoid) (id_of_string "y") gsig in
-      let freshz = avoid := freshm::(!avoid);
-            fresh_id (!avoid) (id_of_string "Z") gsig in
+      let fresh_id s gl =
+        Tacmach.New.of_old begin fun gsig ->
+          let fresh = fresh_id (!avoid) s gsig in
+          avoid := fresh::(!avoid); fresh
+        end gl
+      in
+      Proofview.Goal.nf_enter begin fun gl ->
+      let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
+      let freshn = fresh_id (Id.of_string "x") gl in
+      let freshm = fresh_id (Id.of_string "y") gl in
+      let freshz = fresh_id (Id.of_string "Z") gl in
   (* try with *)
-      avoid := freshz::(!avoid);
-      tclTHENSEQ [ intros_using fresh_first_intros;
+      Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros;
                      intro_using freshn ;
                      induct_on (mkVar freshn);
                      intro_using freshm;
                      destruct_on (mkVar freshm);
                      intro_using freshz;
                      intros;
-                     tclTRY (
-                      tclORELSE reflexivity (Equality.discr_tac false None)
+                     Tacticals.New.tclTRY (
+                      Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None)
                      );
-                     Equality.inj [] false (mkVar freshz,Glob_term.NoBindings);
-		     intros; simpl_in_concl;
+                     Equality.inj None false None (mkVar freshz,NoBindings);
+		     intros; (Proofview.V82.tactic simpl_in_concl);
                      Auto.default_auto;
-                     tclREPEAT (
-                      tclTHENSEQ [apply (andb_true_intro());
+                     Tacticals.New.tclREPEAT (
+                      Tacticals.New.tclTHENLIST [apply (andb_true_intro());
                                   simplest_split ;Auto.default_auto ]
                       );
-                      fun gls -> let gl = pf_concl gls in
-                  (* assume the goal to be eq (eq_type ...) = true *)
+                      Proofview.Goal.nf_enter begin fun gls ->
+                        let gl = Proofview.Goal.concl gls in
+                        (* assume the goal to be eq (eq_type ...) = true *)
                         match (kind_of_term gl) with
-                          | App(c,ca) -> (match (kind_of_term ca.(1)) with
-                              | App(c',ca') ->
-                                  let n = Array.length ca' in
-                                    tclTHENSEQ (do_replace_lb lb_scheme_key
-				                (!avoid)
-                                                nparrec gls
-                                                ca'.(n-2) ca'.(n-1)) gls
-                              | _ -> error
-                                "Failure while solving Leibniz->Boolean."
-                            )
-                          | _ -> error
-                                  "Failure while solving Leibniz->Boolean."
-                    ] gsig
+                        | App(c,ca) -> (match (kind_of_term ca.(1)) with
+                          | App(c',ca') ->
+                              let n = Array.length ca' in
+                              do_replace_lb lb_scheme_key
+				(!avoid)
+                                nparrec
+                                ca'.(n-2) ca'.(n-1)
+                          | _ ->
+                              Proofview.tclZERO (UserError ("",str"Failure while solving Leibniz->Boolean."))
+                        )
+                        | _ ->
+                            Proofview.tclZERO (UserError ("",str"Failure while solving Leibniz->Boolean."))
+                      end
+                    ]
+      end
 
 let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined")
 
 let make_lb_scheme mind =
   let mib = Global.lookup_mind mind in
-  if Array.length mib.mind_packets <> 1 then
+  if not (Int.equal (Array.length mib.mind_packets) 1) then
     errorlabstrm ""
       (str "Automatic building of Leibniz->boolean lemmas not supported");
   let ind = (mind,0) in
@@ -707,9 +753,12 @@ let make_lb_scheme mind =
   let nparrec = mib.mind_nparams_rec in
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic (Global.env())
-    (compute_lb_goal ind lnamesparrec nparrec)
-    (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)|]
+  let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in
+  let ctx = Evd.empty_evar_universe_context in
+  let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx lb_goal
+    (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec)
+  in
+  ([|ans|], ctx (* FIXME *)), eff
 
 let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme
 
@@ -725,10 +774,11 @@ let check_not_is_defined () =
 (* {n=m}+{n<>m}  part  *)
 let compute_dec_goal ind lnamesparrec nparrec =
   check_not_is_defined ();
+  let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in
   let list_id = list_id lnamesparrec in
     let create_input c =
-      let x = id_of_string "x" and
-          y = id_of_string "y" in
+      let x = Id.of_string "x" and
+          y = Id.of_string "y" in
       let lb_typ = List.map (fun (s,seq,_,_) ->
         mkNamedProd x (mkVar s) (
             mkNamedProd y (mkVar s) (
@@ -760,11 +810,11 @@ let compute_dec_goal ind lnamesparrec nparrec =
         mkNamedProd seq b a
       ) bl_input (List.rev list_id) (List.rev eqs_typ) in
       List.fold_left (fun a (n,_,t) -> mkNamedProd
-                (match n with Name s -> s | Anonymous ->  id_of_string "A")
+                (match n with Name s -> s | Anonymous ->  Id.of_string "A")
                 t  a) eq_input lnamesparrec
     in
-      let n = id_of_string "x" and
-          m = id_of_string "y" in
+      let n = Id.of_string "x" and
+          m = Id.of_string "y" in
         let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in
         create_input (
           mkNamedProd n (mkFullInd ind (2*nparrec)) (
@@ -774,9 +824,11 @@ let compute_dec_goal ind lnamesparrec nparrec =
         )
       )
 
-let compute_dec_tact ind lnamesparrec nparrec gsig =
+let compute_dec_tact ind lnamesparrec nparrec =
+  let eq = Lazy.force eq and tt = Lazy.force tt 
+  and ff = Lazy.force ff and bb = Lazy.force bb in
   let list_id = list_id lnamesparrec in
-  let eqI = eqI ind lnamesparrec in
+  let eqI, eff = eqI ind lnamesparrec in
   let avoid = ref [] in
   let eqtrue x = mkApp(eq,[|bb;x;tt|]) in
   let eqfalse x = mkApp(eq,[|bb;x;ff|]) in
@@ -786,85 +838,101 @@ let compute_dec_tact ind lnamesparrec nparrec gsig =
       ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @
       ( List.map (fun (_,_,_,slb) -> slb) list_id )
   in
-  let fresh_first_intros = List.map ( fun s ->
-    let fresh = fresh_id (!avoid) s gsig in
-    avoid := fresh::(!avoid); fresh ) first_intros in
-  let freshn = fresh_id (!avoid) (id_of_string "x") gsig in
-  let freshm = avoid := freshn::(!avoid);
-    fresh_id (!avoid) (id_of_string "y") gsig in
-  let freshH = avoid := freshm::(!avoid);
-    fresh_id (!avoid) (id_of_string "H") gsig in
+  let fresh_id s gl =
+    Tacmach.New.of_old begin fun gsig ->
+      let fresh = fresh_id (!avoid) s gsig in
+      avoid := fresh::(!avoid); fresh
+    end gl
+  in
+  Proofview.Goal.nf_enter begin fun gl ->
+  let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in
+  let freshn = fresh_id (Id.of_string "x") gl in
+  let freshm = fresh_id (Id.of_string "y") gl in
+  let freshH = fresh_id (Id.of_string "H") gl in
   let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in
-  avoid := freshH::(!avoid);
   let arfresh = Array.of_list fresh_first_intros in
   let xargs = Array.sub arfresh 0 (2*nparrec) in
-  let blI = try mkConst (find_scheme bl_scheme_kind ind) with
-            Not_found -> error (
-              "Error during the decidability part, boolean to leibniz"^
-              " equality is required.")
-  in
-  let lbI = try mkConst (find_scheme lb_scheme_kind ind) with
-            Not_found -> error (
-              "Error during the decidability part, leibniz to boolean"^
-              " equality is required.")
-  in
-  tclTHENSEQ [
+  begin try
+          let c, eff = find_scheme bl_scheme_kind ind in
+          Proofview.tclUNIT (mkConst c,eff) with
+    Not_found ->
+      Proofview.tclZERO (UserError ("",str"Error during the decidability part, boolean to leibniz"++
+        str" equality is required."))
+  end >>= fun (blI,eff') ->
+  begin try
+          let c, eff = find_scheme lb_scheme_kind ind in
+          Proofview.tclUNIT (mkConst c,eff) with
+    Not_found ->
+      Proofview.tclZERO (UserError ("",str"Error during the decidability part, leibniz to boolean"++
+        str" equality is required."))
+  end >>= fun (lbI,eff'') ->
+  let eff = (Declareops.union_side_effects eff'' (Declareops.union_side_effects eff' eff)) in
+  Tacticals.New.tclTHENLIST [
+        Proofview.tclEFFECTS eff;
         intros_using fresh_first_intros;
         intros_using [freshn;freshm];
 	(*we do this so we don't have to prove the same goal twice *)
         assert_by (Name freshH) (
           mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|])
 	)
-	  (tclTHEN (destruct_on eqbnm) Auto.default_auto);
-        (fun gsig ->
-	  let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in
-          avoid := freshH2::(!avoid);
-	  tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
+	  (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto);
+
+        Proofview.Goal.nf_enter begin fun gl ->
+          let freshH2 = fresh_id (Id.of_string "H") gl in
+	  Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [
 	    (* left *)
-	    tclTHENSEQ [
+	    Tacticals.New.tclTHENLIST [
 	      simplest_left;
               apply (mkApp(blI,Array.map(fun x->mkVar x) xargs));
               Auto.default_auto
-            ];
+            ]
+            ;
+
 	    (*right *)
-            (fun gsig ->
-	    let freshH3 = fresh_id (!avoid) (id_of_string "H") gsig in
-            avoid := freshH3::(!avoid);
-            tclTHENSEQ [
+            Proofview.Goal.nf_enter begin fun gl ->
+            let freshH3 = fresh_id (Id.of_string "H") gl in
+            Tacticals.New.tclTHENLIST [
 	      simplest_right ;
-              unfold_constr (Lazy.force Coqlib.coq_not_ref);
+              Proofview.V82.tactic (unfold_constr (Lazy.force Coqlib.coq_not_ref));
               intro;
-              Equality.subst_all;
+              Equality.subst_all ();
               assert_by (Name freshH3)
 		(mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))
-		(tclTHENSEQ [
+		(Tacticals.New.tclTHENLIST [
 		  apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs));
                   Auto.default_auto
 		]);
 	      Equality.general_rewrite_bindings_in true
-	                      all_occurrences true false
+	                      Locus.AllOccurrences true false
                               (List.hd !avoid)
                               ((mkVar (List.hd (List.tl !avoid))),
-                                Glob_term.NoBindings
+                                NoBindings
                               )
                               true;
               Equality.discr_tac false None
-	    ] gsig)
-	  ] gsig)
-  ] gsig
+	    ]
+            end
+	  ]
+        end
+  ]
+  end
 
 let make_eq_decidability mind =
   let mib = Global.lookup_mind mind in
-  if Array.length mib.mind_packets <> 1 then
-    anomaly "Decidability lemma for mutual inductive types not supported";
+  if not (Int.equal (Array.length mib.mind_packets) 1) then
+    anomaly (Pp.str "Decidability lemma for mutual inductive types not supported");
   let ind = (mind,0) in
   let nparams = mib.mind_nparams in
   let nparrec = mib.mind_nparams_rec in
+  let u = Univ.Instance.empty in
+  let ctx = Evd.empty_evar_universe_context (* FIXME *)in
   let lnonparrec,lnamesparrec =
     context_chop (nparams-nparrec) mib.mind_params_ctxt in
-  [|Pfedit.build_by_tactic (Global.env())
-    (compute_dec_goal ind lnamesparrec nparrec)
-    (compute_dec_tact ind lnamesparrec nparrec)|]
+  let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx
+    (compute_dec_goal (ind,u) lnamesparrec nparrec)
+    (compute_dec_tact ind lnamesparrec nparrec)
+  in
+  ([|ans|], ctx), Declareops.no_seff
 
 let eq_dec_scheme_kind =
   declare_mutual_scheme_object "_eq_dec" make_eq_decidability
diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli
index 1cb8b767..5dbd5379 100644
--- a/toplevel/auto_ind_decl.mli
+++ b/toplevel/auto_ind_decl.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,6 @@
 
 open Term
 open Names
-open Libnames
-open Mod_subst
-open Sign
-open Proof_type
 open Ind_tables
 
 (** This file is about the automatic generation of schemes about
@@ -30,17 +26,16 @@ exception ParameterWithoutEquality of constant
 exception NonSingletonProp of inductive
 
 val beq_scheme_kind : mutual scheme_kind
-val build_beq_scheme : mutual_inductive -> constr array
+val build_beq_scheme : mutual_scheme_object_function
 
 (** {6 Build equivalence between boolean equality and Leibniz equality } *)
 
 val lb_scheme_kind : mutual scheme_kind
-val make_lb_scheme : mutual_inductive -> constr array
-
+val make_lb_scheme : mutual_scheme_object_function
 val bl_scheme_kind : mutual scheme_kind
-val make_bl_scheme : mutual_inductive -> constr array
+val make_bl_scheme : mutual_scheme_object_function
 
 (** {6 Build decidability of equality } *)
 
 val eq_dec_scheme_kind : mutual scheme_kind
-val make_eq_decidability : mutual_inductive -> constr array
+val make_eq_decidability : mutual_scheme_object_function
diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml
deleted file mode 100644
index ff09f73d..00000000
--- a/toplevel/autoinstance.ml
+++ /dev/null
@@ -1,320 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(*i*)
-open Pp
-open Printer
-open Names
-open Term
-open Evd
-open Sign
-open Libnames
-(*i*)
-
-(*s
- * Automatic detection of (some) record instances
- *)
-
-(* Datatype for wannabe-instances: a signature is a typeclass along
-   with the collection of evars corresponding to the parameters/fields
-   of the class. Each evar can be uninstantiated (we're still looking
-   for them) or defined (the instance for the field is fixed) *)
-type signature = global_reference * evar list * evar_map
-
-type instance_decl_function = global_reference -> rel_context -> constr list -> unit
-
-(*
- * Search algorithm
- *)
-
-let rec subst_evar evar def n c =
-  match kind_of_term c with
-    | Evar (e,_) when e=evar -> lift n def
-    | _ -> map_constr_with_binders (fun n->n+1) (subst_evar evar def) n c
-
-let subst_evar_in_evm evar def evm =
-  Evd.fold
-    (fun ev evi acc ->
-       let evar_body = match evi.evar_body with
-	 | Evd.Evar_empty -> Evd.Evar_empty
-	 | Evd.Evar_defined c -> Evd.Evar_defined (subst_evar evar def 0 c) in
-       let evar_concl = subst_evar evar def 0 evi.evar_concl in
-       Evd.add acc ev {evi with evar_body=evar_body; evar_concl=evar_concl}
-    ) evm empty
-
-(* Tries to define ev by c in evd. Fails if ev := c1 and c1 /= c ev :
- * T1, c : T2 and T1 /= T2. Defines recursively all evars instantiated
- * by this definition. *)
-
-let rec safe_define evm ev c =
-  if not (closedn (-1) c) then raise Termops.CannotFilter else
-(*  msgnl(str"safe_define "++pr_evar_map evm++spc()++str" |- ?"++Util.pr_int ev++str" := "++pr_constr c);*)
-  let evi = (Evd.find evm ev) in
-  let define_subst evm sigma =
-    Util.Intmap.fold
-      ( fun ev (e,c) evm ->
-	  match kind_of_term c with Evar (i,_) when i=ev -> evm | _ ->
-	    safe_define evm ev (lift (-List.length e) c)
-      ) sigma evm in
-  match evi.evar_body with
-    | Evd.Evar_defined def ->
-	define_subst evm (Termops.filtering [] Reduction.CUMUL def c)
-    | Evd.Evar_empty ->
-	let t = Libtypes.reduce (Typing.type_of (Global.env()) evm c) in
-	let u = Libtypes.reduce (evar_concl evi) in
-	let evm = subst_evar_in_evm ev c evm in
-	define_subst (Evd.define ev c evm) (Termops.filtering [] Reduction.CUMUL t u)
-
-let add_gen_ctx (cl,gen,evm) ctx : signature * constr list =
-  let rec really_new_evar () =
-    let ev = Evarutil.new_untyped_evar() in
-    if Evd.is_evar evm ev then really_new_evar() else ev in
-  let add_gen_evar (cl,gen,evm) ev ty : signature =
-    let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val ty) in
-    (cl,ev::gen,evm) in
-  let rec mksubst b = function
-    | [] -> []
-    | a::tl -> b::(mksubst (a::b) tl) in
-  let evl = List.map (fun _ -> really_new_evar()) ctx in
-  let evcl = List.map (fun i -> mkEvar (i,[||])) evl in
-  let substl = List.rev (mksubst [] (evcl)) in
-  let ctx = List.map2 (fun s t -> substnl s 0 t) substl ctx in
-  let sign = List.fold_left2 add_gen_evar (cl,gen,evm) (List.rev evl) ctx in
-  sign,evcl
-
-(* TODO : for full proof-irrelevance in the search, provide a real
-   compare function for constr instead of Pervasive's one! *)
-module SubstSet : Set.S with type elt = Termops.subst
-  = Set.Make (struct type t = Termops.subst
-		     let compare = Util.Intmap.compare (Pervasives.compare)
-	      end)
-
-(* searches instatiations in the library for just one evar [ev] of a
-   signature. [k] is called on each resulting signature *)
-let complete_evar (cl,gen,evm:signature) (ev,evi) (k:signature -> unit) =
-  let ev_typ = Libtypes.reduce (evar_concl evi) in
-  let sort_is_prop = is_Prop (Typing.type_of (Global.env()) evm (evar_concl evi)) in
-(*  msgnl(str"cherche "++pr_constr ev_typ++str" pour "++Util.pr_int ev);*)
-  let substs = ref SubstSet.empty in
-  try List.iter
-    ( fun (gr,(pat,_),s) ->
-	let (_,genl,_) = Termops.decompose_prod_letin pat in
-	let genl = List.map (fun (_,_,t) -> t) genl in
-	let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) genl in
-	let def = applistc (Libnames.constr_of_global gr) argl in
-(*	msgnl(str"essayons  ?"++Util.pr_int ev++spc()++str":="++spc()
-	      ++pr_constr def++spc()++str":"++spc()++pr_constr (Global.type_of_global gr)*)
-	(*++spc()++str"dans"++spc()++pr_evar_map evm++spc());*)
-	try
- 	  let evm = safe_define evm ev def in
-	  k (cl,gen,evm);
-	  if sort_is_prop && SubstSet.mem s !substs then raise Exit;
-	  substs := SubstSet.add s !substs
-	with Termops.CannotFilter -> ()
-    ) (Libtypes.search_concl ev_typ)
-  with Exit -> ()
-
-let evm_fold_rev f evm acc =
-  let l = Evd.fold (fun ev evi acc -> (ev,evi)::acc) evm [] in
-  List.fold_left (fun acc (ev,evi) -> f ev evi acc) acc l
-
-exception Continue of Evd.evar * Evd.evar_info
-
-(* searches matches for all the uninstantiated evars of evd in the
-   context. For each totally instantiated evar_map found, apply
-   k. *)
-let rec complete_signature (k:signature -> unit) (cl,gen,evm:signature) =
-  try
-    evm_fold_rev
-      ( fun ev evi _ ->
-	  if not (is_defined evm ev) && not (List.mem ev gen) then
-	    raise (Continue (ev,evi))
-      ) evm (); k (cl,gen,evm)
-  with Continue (ev,evi) -> complete_evar (cl,gen,evm) (ev,evi) (complete_signature k)
-
-(* define all permutations of the evars to evd and call k on the
-   resulting evd *)
-let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit) : unit =
-  let rec aux evm = List.iter
-    ( fun (ctx,ev) ->
-	let tyl = List.map (fun (_,_,t) -> t) ctx in
-	let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) tyl in
-	let def = applistc c argl in
-(*	msgnl(str"trouvé def ?"++Util.pr_int ev++str" := "++pr_constr def++str " dans "++pr_evar_map evm);*)
-	try
-	  if not (Evd.is_defined evm ev) then
-	    let evm = safe_define evm ev def in
-	    aux evm; k (cl,gen,evm)
-	with Termops.CannotFilter -> ()
-    ) evl in
-  aux evm
-
-let new_inst_no =
-  let cnt = ref 0 in
-  fun () -> incr cnt; string_of_int !cnt
-
-let make_instance_ident gr =
-  Nameops.add_suffix (Nametab.basename_of_global gr) ("_autoinstance_"^new_inst_no())
-
-let new_instance_message ident typ def =
-  Flags.if_verbose
-  msgnl (str"new instance"++spc()
-	 ++Nameops.pr_id ident++spc()++str":"++spc()
-	 ++pr_constr typ++spc()++str":="++spc()
-	 ++pr_constr def)
-
-open Entries
-
-let rec deep_refresh_universes c =
-  match kind_of_term c with
-    | Sort (Type _) -> Termops.new_Type()
-    | _ -> map_constr deep_refresh_universes c
-
-let declare_record_instance gr ctx params =
-  let ident = make_instance_ident gr in
-  let def = it_mkLambda_or_LetIn (applistc (constr_of_global gr) params) ctx in
-  let def = deep_refresh_universes def in
-  let ce = { const_entry_body= def;
-             const_entry_secctx = None;
-	     const_entry_type=None;
-	     const_entry_opaque=false } in
-  let cst = Declare.declare_constant ident
-    (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in
-  new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def
-
-let declare_class_instance gr ctx params =
-  let ident = make_instance_ident gr in
-  let cl = Typeclasses.class_info gr in
-  let (def,typ) = Typeclasses.instance_constructor cl params in
-  let (def,typ) = it_mkLambda_or_LetIn (Option.get def) ctx, it_mkProd_or_LetIn typ ctx in
-  let def = deep_refresh_universes def in
-  let typ = deep_refresh_universes typ in
-  let ce = Entries.DefinitionEntry
-    {  const_entry_type = Some typ;
-       const_entry_secctx = None;
-       const_entry_body= def;
-       const_entry_opaque=false } in
-  try
-  let cst = Declare.declare_constant ident
-    (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in
-  Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true (ConstRef cst));
-  new_instance_message ident typ def
-  with e when Errors.noncritical e ->
-    msgnl (str"Error defining instance := "++pr_constr def++str" : "++pr_constr typ++str"  "++Errors.print e)
-
-let rec iter_under_prod (f:rel_context->constr->unit) (ctx:rel_context) t = f ctx t;
-  match kind_of_term t with
-    | Prod (n,t,c) -> iter_under_prod f ((n,None,t)::ctx) c
-    | _ -> ()
-
-(* main search function: search for total instances containing gr, and
-   apply k to each of them *)
-let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature -> unit) : unit =
-  let gr_c = Libnames.constr_of_global gr in
-  let (smap:(Libnames.global_reference * Evd.evar_map,
-   ('a * 'b * Term.constr) list * Evd.evar)
-  Gmapl.t ref) = ref Gmapl.empty in
-  iter_under_prod
-    ( fun ctx typ ->
-	List.iter
-	  (fun ((cl,ev,evm),_,_) ->
-(*	     msgnl(pr_global gr++str" : "++pr_constr typ++str" matche ?"++Util.pr_int ev++str " dans "++pr_evar_map evm);*)
-	     smap := Gmapl.add (cl,evm) (ctx,ev) !smap)
-	  (Recordops.methods_matching typ)
-    ) [] deftyp;
-  Gmapl.iter
-    ( fun (cl,evm) evl ->
-	let f = if Typeclasses.is_class cl then
-	  declare_class_instance else declare_record_instance in
-	complete_with_evars_permut (cl,[],evm) evl gr_c
-	  (fun sign -> complete_signature (k f) sign)
-    ) !smap
-
-(*
- * Interface with other parts: hooks & declaration
- *)
-
-
-let evar_definition evi = match evar_body evi with
-    Evar_empty -> assert false | Evar_defined c -> c
-
-let gen_sort_topo l evm =
-  let iter_evar f ev =
-    let rec aux c = match kind_of_term c with
-	Evar (e,_) -> f e
-      | _ -> iter_constr aux c in
-    aux (Evd.evar_concl (Evd.find evm ev));
-    if Evd.is_defined evm ev then aux (evar_definition (Evd.find evm ev)) in
-  let r = ref [] in
-  let rec dfs ev = iter_evar dfs ev;
-    if not(List.mem ev !r) then r := ev::!r in
-  List.iter dfs l; List.rev !r
-
-(* register real typeclass instance given a totally defined evd *)
-let declare_instance (k:global_reference -> rel_context -> constr list -> unit)
-    (cl,gen,evm:signature) =
-  let evm = Evarutil.nf_evar_map evm in
-  let gen = gen_sort_topo gen evm in
-  let (evm,gen) = List.fold_right
-    (fun ev (evm,gen) ->
-       if Evd.is_defined evm ev
-       then Evd.remove evm ev,gen
-       else evm,(ev::gen))
-    gen (evm,[]) in
-(*  msgnl(str"instance complète : ["++Util.prlist_with_sep (fun _ -> str";") Util.pr_int gen++str"] : "++spc()++pr_evar_map evm);*)
-  let ngen = List.length gen in
-  let (_,ctx,evm) = List.fold_left
-    ( fun (i,ctx,evm) ev ->
-	let ctx = (Anonymous,None,lift (-i) (Evd.evar_concl(Evd.find evm ev)))::ctx in
-	let evm = subst_evar_in_evm ev (mkRel i) (Evd.remove evm ev) in
-	(i-1,ctx,evm)
-    ) (ngen,[],evm) gen in
-  let fields = List.rev (Evd.fold ( fun ev evi l -> evar_definition evi::l ) evm []) in
-  k cl ctx fields
-
-let autoinstance_opt = ref true
-
-let search_declaration gr =
-  if !autoinstance_opt &&
-    not (Lib.is_modtype()) then
-    let deftyp = Global.type_of_global gr in
-    complete_signature_with_def gr deftyp declare_instance
-
-let search_record k cons sign =
-  if !autoinstance_opt && not (Lib.is_modtype()) then
-    complete_signature (declare_instance k) (cons,[],sign)
-
-(*
-let dh_key = Profile.declare_profile "declaration_hook"
-let ch_key = Profile.declare_profile "class_decl_hook"
-let declaration_hook = Profile.profile1 dh_key declaration_hook
-let class_decl_hook = Profile.profile1 ch_key class_decl_hook
-*)
-
-(*
- *  Options and bookeeping
- *)
-
-let begin_autoinstance () =
-  if not !autoinstance_opt then (
-    autoinstance_opt := true;
-  )
-
-let end_autoinstance () =
-  if !autoinstance_opt then (
-    autoinstance_opt := false;
- )
-
-let _ =
-  Goptions.declare_bool_option
-    { Goptions.optsync=true;
-      Goptions.optdepr=false;
-      Goptions.optkey=["Autoinstance"];
-      Goptions.optname="automatic typeclass instance recognition";
-      Goptions.optread=(fun () -> !autoinstance_opt);
-      Goptions.optwrite=(fun b -> if b then begin_autoinstance() else end_autoinstance()) }
diff --git a/toplevel/autoinstance.mli b/toplevel/autoinstance.mli
deleted file mode 100644
index 6e26a784..00000000
--- a/toplevel/autoinstance.mli
+++ /dev/null
@@ -1,34 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Libnames
-open Typeclasses
-open Names
-open Evd
-open Sign
-
-(** {6 Automatic detection of (some) record instances } *)
-
-(** What to do if we find an instance. Passed are : the reference
- * representing the record/class (definition or constructor) *)
-type instance_decl_function = global_reference -> rel_context -> constr list -> unit
-
-(** [search_declaration gr] Search in the library if the (new)
- * declaration gr can form an instance of a registered record/class *)
-val search_declaration : global_reference -> unit
-
-(** [search_record declf gr evm] Search the library for instances of
-   the (new) record/class declaration [gr], and register them using
-   [declf]. [evm] is the signature of the record (to avoid recomputing
-   it) *)
-val search_record : instance_decl_function -> global_reference -> evar_map -> unit
-
-(** Instance declaration for both scenarios *)
-val declare_record_instance : instance_decl_function
-val declare_class_instance : instance_decl_function
diff --git a/toplevel/backtrack.ml b/toplevel/backtrack.ml
deleted file mode 100644
index eb100379..00000000
--- a/toplevel/backtrack.ml
+++ /dev/null
@@ -1,243 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Names
-open Vernacexpr
-
-(** Command history stack
-
-    We maintain a stack of the past states of the system. Each
-    successfully interpreted command adds an [info] element
-    to this stack, storing what were the (label / current proof / ...)
-    just _after_ the interpretation of this command.
-
-    - A label is just an integer, starting from Lib.first_command_label
-      initially, and incremented at each new successful command.
-    - If some proofs are opened, we have their number in [nproofs],
-      the name of the current proof in [prfname], the current depth in
-      [prfdepth].
-    - Otherwise, [nproofs = 0], [prfname = None], [prfdepth = 0]
-    - The text of the command is stored (for Show Script currently).
-    - A command can be tagged later as non-"reachable" when the current proof
-      at the time of this command has been ended by Qed/Abort/Restart,
-      meaning we can't backtrack there.
-*)
-
-type info = {
-  label : int;
-  nproofs : int;
-  prfname : identifier option;
-  prfdepth : int;
-  ngoals : int;
-  cmd : vernac_expr;
-  mutable reachable : bool;
-}
-
-let history : info Stack.t = Stack.create ()
-
-(** Is this stack active (i.e. nonempty) ?
-    The stack is currently inactive when compiling files (coqc). *)
-
-let is_active () = not (Stack.is_empty history)
-
-(** For debug purpose, a dump of the history *)
-
-let dump_history () =
-  let l = ref [] in
-  Stack.iter (fun i -> l:=i::!l) history;
-  !l
-
-(** Basic manipulation of the command history stack *)
-
-exception Invalid
-
-let pop () = ignore (Stack.pop history)
-
-let npop n =
- (* Since our history stack always contains an initial entry,
-    it's invalid to try to completely empty it *)
- if n < 0 || n >= Stack.length history then raise Invalid
- else for i = 1 to n do pop () done
-
-let top () =
-  try Stack.top history with Stack.Empty -> raise Invalid
-
-(** Search the history stack for a suitable location. We perform first
-    a non-destructive search: in case of search failure, the stack is
-    unchanged. *)
-
-exception Found of info
-
-let search test =
-  try
-    Stack.iter (fun i -> if test i then raise (Found i)) history;
-    raise Invalid
-  with Found i ->
-    while i != Stack.top history do pop () done
-
-(** An auxiliary function to retrieve the number of remaining subgoals *)
-
-let get_ngoals () =
-  try
-    let prf = Proof_global.give_me_the_proof () in
-    List.length (Evd.sig_it (Proof.V82.background_subgoals prf))
-  with Proof_global.NoCurrentProof -> 0
-
-(** Register the end of a command and store the current state *)
-
-let mark_command ast =
-  Lib.add_frozen_state();
-  Lib.mark_end_of_command();
-  Stack.push
-    { label = Lib.current_command_label ();
-      nproofs = List.length (Pfedit.get_all_proof_names ());
-      prfname =
-        (try Some (Pfedit.get_current_proof_name ())
-         with Proof_global.NoCurrentProof -> None);
-      prfdepth = max 0 (Pfedit.current_proof_depth ());
-      reachable = true;
-      ngoals = get_ngoals ();
-      cmd = ast }
-    history
-
-(** Backtrack by aborting [naborts] proofs, then setting proof-depth back to
-    [pnum] and finally going to state number [snum]. *)
-
-let raw_backtrack snum pnum naborts =
-  for i = 1 to naborts do Pfedit.delete_current_proof () done;
-  Pfedit.undo_todepth pnum;
-  Lib.reset_label snum
-
-(** Re-sync the state of the system (label, proofs) with the top
-    of the history stack. We may end on some earlier state to avoid
-    re-opening proofs. This function will return the final label
-    and the number of extra backtracking steps performed. *)
-
-let sync nb_opened_proofs =
-  (* Backtrack by enough additional steps to avoid re-opening proofs.
-     Typically, when a Qed has been crossed, we backtrack to the proof start.
-     NB: We cannot reach the empty stack, since the first entry in the
-     stack has no opened proofs and is tagged as reachable.
-  *)
-  let extra = ref 0 in
-  while not (top()).reachable do incr extra; pop () done;
-  let target = top ()
-  in
-  (* Now the opened proofs at target is a subset of the opened proofs before
-     the backtrack, we simply abort the extra proofs (if any).
-     NB: It is critical here that proofs are nested in a regular way
-     (i.e. no more Resume or Suspend commands as earlier). This way, we can
-     simply count the extra proofs to abort instead of taking care of their
-     names.
-  *)
-  let naborts = nb_opened_proofs - target.nproofs in
-  (* We are now ready to do a low-level backtrack *)
-  raw_backtrack target.label target.prfdepth naborts;
-  (target.label, !extra)
-
-(** Backtracking by a certain number of (non-state-preserving) commands.
-    This is used by Coqide.
-    It may actually undo more commands than asked : for instance instead
-    of jumping back in the middle of a finished proof, we jump back before
-    this proof. The number of extra backtracked command is returned at
-    the end. *)
-
-let back count =
-  if count = 0 then 0
-  else
-    let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
-    npop count;
-    snd (sync nb_opened_proofs)
-
-(** Backtracking to a certain state number, and reset proofs accordingly.
-    We may end on some earlier state if needed to avoid re-opening proofs.
-    Return the final state number. *)
-
-let backto snum =
-  if snum = Lib.current_command_label () then snum
-  else
-    let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
-    search (fun i -> i.label = snum);
-    fst (sync nb_opened_proofs)
-
-(** Old [Backtrack] code with corresponding update of the history stack.
-    [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
-    compatibility with ProofGeneral. It's completely up to ProofGeneral
-    to decide where to go and how to adapt proofs. Note that the choices
-    of ProofGeneral are currently not always perfect (for instance when
-    backtracking an Undo). *)
-
-let backtrack snum pnum naborts =
-  raw_backtrack snum pnum naborts;
-  search (fun i -> i.label = snum)
-
-(** [reset_initial] resets the system and clears the command history
-    stack, only pushing back the initial entry. It should be equivalent
-    to [backto Lib.first_command_label], but sligthly more efficient. *)
-
-let reset_initial () =
-  let init_label = Lib.first_command_label in
-  if Lib.current_command_label () = init_label then ()
-  else begin
-    Pfedit.delete_all_proofs ();
-    Lib.reset_label init_label;
-    Stack.clear history;
-    Stack.push
-      { label = init_label;
-	nproofs = 0;
-	prfname = None;
-	prfdepth = 0;
-	ngoals = 0;
-	reachable = true;
-	cmd = VernacNop }
-      history
-  end
-
-(** Reset to the last known state just before defining [id] *)
-
-let reset_name id =
-  let lbl =
-    try Lib.label_before_name id with Not_found -> raise Invalid
-  in
-  ignore (backto lbl)
-
-(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
-    old proof steps should be marked differently to avoid jumping back
-    to them:
-     - either this proof isn't there anymore in the proof engine
-     - either it's there but it's a more recent attempt after a Restart,
-       so we shouldn't mix the two.
-    We also mark as unreachable the proof steps cancelled via a Undo. *)
-
-let mark_unreachable ?(after=0) prf_lst =
-  let fix i = match i.prfname with
-    | None -> raise Not_found (* stop hacking the history outside of proofs *)
-    | Some p ->
-      if List.mem p prf_lst && i.prfdepth > after
-      then i.reachable <- false
-  in
-  try Stack.iter fix history with Not_found -> ()
-
-(** Parse the history stack for printing the script of a proof *)
-
-let get_script prf =
-  let script = ref [] in
-  let select i = match i.prfname with
-    | None -> raise Not_found
-    | Some p when p=prf && i.reachable -> script := i :: !script
-    | _ -> ()
-  in
-  (try Stack.iter select history with Not_found -> ());
-  (* Get rid of intermediate commands which don't grow the proof depth *)
-  let rec filter n = function
-    | [] -> []
-    | {prfdepth=d; cmd=c; ngoals=ng}::l when n < d -> (c,ng) :: filter d l
-    | {prfdepth=d}::l -> filter d l
-  in
-  (* initial proof depth (after entering the lemma statement) is 1 *)
-  filter 1 !script
diff --git a/toplevel/backtrack.mli b/toplevel/backtrack.mli
deleted file mode 100644
index 315575dc..00000000
--- a/toplevel/backtrack.mli
+++ /dev/null
@@ -1,99 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Command history stack
-
-    We maintain a stack of the past states of the system after each
-    (non-state-preserving) interpreted commands
-*)
-
-(** [mark_command ast] marks the end of a command:
-    - it stores a frozen state and a end of command in the Lib stack,
-    - it stores the current state information in the command history
-    stack *)
-
-val mark_command : Vernacexpr.vernac_expr -> unit
-
-(** Is this history stack active (i.e. nonempty) ?
-    The stack is currently inactive when compiling files (coqc). *)
-
-val is_active : unit -> bool
-
-(** The [Invalid] exception is raised when one of the following function
-    tries to empty the history stack, or reach an unknown states, etc.
-    The stack is preserved in these cases. *)
-
-exception Invalid
-
-(** Nota Bene: it is critical for the following functions that proofs
-    are nested in a regular way (i.e. no more Resume or Suspend commands
-    as earlier). *)
-
-(** Backtracking by a certain number of (non-state-preserving) commands.
-    This is used by Coqide.
-    It may actually undo more commands than asked : for instance instead
-    of jumping back in the middle of a finished proof, we jump back before
-    this proof. The number of extra backtracked command is returned at
-    the end. *)
-
-val back : int -> int
-
-(** Backtracking to a certain state number, and reset proofs accordingly.
-    We may end on some earlier state if needed to avoid re-opening proofs.
-    Return the state number on which we finally end. *)
-
-val backto : int -> int
-
-(** Old [Backtrack] code with corresponding update of the history stack.
-    [Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
-    compatibility with ProofGeneral. It's completely up to ProofGeneral
-    to decide where to go and how to adapt proofs. Note that the choices
-    of ProofGeneral are currently not always perfect (for instance when
-    backtracking an Undo). *)
-
-val backtrack : int -> int -> int -> unit
-
-(** [reset_initial] resets the system and clears the command history
-    stack, only pushing back the initial entry. It should be equivalent
-    to [backto Lib.first_command_label], but sligthly more efficient. *)
-
-val reset_initial : unit -> unit
-
-(** Reset to the last known state just before defining [id] *)
-
-val reset_name : Names.identifier Util.located -> unit
-
-(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
-    old proof steps should be marked differently to avoid jumping back
-    to them:
-     - either this proof isn't there anymore in the proof engine
-     - either a proof with the same name is there, but it's a more recent
-       attempt after a Restart/Abort, we shouldn't mix the two.
-    We also mark as unreachable the proof steps cancelled via a Undo.
-*)
-
-val mark_unreachable : ?after:int -> Names.identifier list -> unit
-
-(** Parse the history stack for printing the script of a proof *)
-
-val get_script : Names.identifier -> (Vernacexpr.vernac_expr * int) list
-
-
-(** For debug purpose, a dump of the history *)
-
-type info = {
-  label : int;
-  nproofs : int;
-  prfname : Names.identifier option;
-  prfdepth : int;
-  ngoals : int;
-  cmd : Vernacexpr.vernac_expr;
-  mutable reachable : bool;
-}
-
-val dump_history : unit -> info list
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 76f020dd..22ea09c5 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -1,28 +1,30 @@
 (************************************************************************)
 (*  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 Util
+open Pp
+open Errors
 open Indtypes
 open Type_errors
 open Pretype_errors
 open Indrec
 
 let print_loc loc =
-  if loc = dummy_loc then
+  if Loc.is_ghost loc 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^"\""
 
+(** Invariant : exceptions embedded in EvaluatedError satisfy
+    Errors.noncritical *)
 
 exception EvaluatedError of std_ppcmds * exn option
 
@@ -33,20 +35,16 @@ exception EvaluatedError of std_ppcmds * exn option
 let explain_exn_default = function
   (* Basic interaction exceptions *)
   | Stream.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ "."))
-  | Token.Error txt ->  hov 0 (str ("Syntax error: " ^ txt ^ "."))
+  | Compat.Token.Error txt ->  hov 0 (str ("Syntax error: " ^ txt ^ "."))
   | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err))
   | Sys_error msg -> hov 0 (str ("System error: " ^ guill msg))
   | Out_of_memory -> hov 0 (str "Out of memory.")
   | Stack_overflow -> hov 0 (str "Stack overflow.")
   | Timeout -> hov 0 (str "Timeout!")
   | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.")
-  (* Meta-exceptions *)
-  | Loc.Exc_located (loc,exc) ->
-      hov 0 ((if loc = dummy_loc then (mt ())
-               else (str"At location " ++ print_loc loc ++ str":" ++ fnl ()))
-               ++ Errors.print_no_anomaly exc)
+  (* Exceptions with pre-evaluated error messages *)
   | EvaluatedError (msg,None) -> msg
-  | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print_no_anomaly reraise
+  | EvaluatedError (msg,Some reraise) -> msg ++ Errors.print reraise
   (* Otherwise, not handled here *)
   | _ -> raise Errors.Unhandled
 
@@ -55,67 +53,77 @@ let _ = Errors.register_handler explain_exn_default
 
 (** Pre-explain a vernac interpretation error *)
 
-let wrap_vernac_error strm =
-  EvaluatedError (hov 0 (str "Error:" ++ spc () ++ strm), None)
-
-let rec process_vernac_interp_error = function
-  | Univ.UniverseInconsistency (o,u,v) ->
-      let msg =
-	if !Constrextern.print_universes then
-	  spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++
-          str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=")
-	  ++ spc() ++ Univ.pr_uni v ++ str")"
-	else
-	  mt() in
-      wrap_vernac_error (str "Universe inconsistency" ++ msg ++ str ".")
+let wrap_vernac_error (exn, info) strm =
+  let header = Pp.tag (Pp.Tag.inj Ppstyle.error_tag Ppstyle.tag) (str "Error:") in
+  let e = EvaluatedError (hov 0 (header ++ spc () ++ strm), None) in
+  (e, info)
+
+let process_vernac_interp_error exn = match fst exn with
+  | Univ.UniverseInconsistency i ->
+    let msg =
+      if !Constrextern.print_universes then
+	str "." ++ spc() ++ 
+	  Univ.explain_universe_inconsistency Universes.pr_with_global_universes i
+      else
+	mt() in
+    wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".")
   | TypeError(ctx,te) ->
-      wrap_vernac_error (Himsg.explain_type_error ctx Evd.empty te)
+      wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te)
   | PretypeError(ctx,sigma,te) ->
-      wrap_vernac_error (Himsg.explain_pretype_error ctx sigma te)
+      wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te)
   | Typeclasses_errors.TypeClassError(env, te) ->
-      wrap_vernac_error (Himsg.explain_typeclass_error env te)
+      wrap_vernac_error exn (Himsg.explain_typeclass_error env te)
   | InductiveError e ->
-      wrap_vernac_error (Himsg.explain_inductive_error e)
+      wrap_vernac_error exn (Himsg.explain_inductive_error e)
   | Modops.ModuleTypingError e ->
-      wrap_vernac_error (Himsg.explain_module_error e)
+      wrap_vernac_error exn (Himsg.explain_module_error e)
   | Modintern.ModuleInternalizationError e ->
-      wrap_vernac_error (Himsg.explain_module_internalization_error e)
+      wrap_vernac_error exn (Himsg.explain_module_internalization_error e)
   | RecursionSchemeError e ->
-      wrap_vernac_error (Himsg.explain_recursion_scheme_error e)
-  | Cases.PatternMatchingError (env,e) ->
-      wrap_vernac_error (Himsg.explain_pattern_matching_error env e)
+      wrap_vernac_error exn (Himsg.explain_recursion_scheme_error e)
+  | Cases.PatternMatchingError (env,sigma,e) ->
+      wrap_vernac_error exn (Himsg.explain_pattern_matching_error env sigma e)
   | Tacred.ReductionTacticError e ->
-      wrap_vernac_error (Himsg.explain_reduction_tactic_error e)
+      wrap_vernac_error exn (Himsg.explain_reduction_tactic_error e)
   | Logic.RefinerError e ->
-      wrap_vernac_error (Himsg.explain_refiner_error e)
+      wrap_vernac_error exn (Himsg.explain_refiner_error e)
   | Nametab.GlobalizationError q ->
-      wrap_vernac_error
+      wrap_vernac_error exn
         (str "The reference" ++ spc () ++ Libnames.pr_qualid q ++
 	 spc () ++ str "was not found" ++
 	 spc () ++ str "in the current" ++ spc () ++ str "environment.")
-  | Nametab.GlobalizationConstantError q ->
-      wrap_vernac_error
-        (str "No constant of this name:" ++ spc () ++
-         Libnames.pr_qualid q ++ str ".")
   | Refiner.FailError (i,s) ->
-      wrap_vernac_error
+      let s = Lazy.force s in
+      wrap_vernac_error exn
 	(str "Tactic failure" ++
-           (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++
-           if i=0 then str "." else str " (level " ++ int i ++ str").")
+         (if Pp.is_empty s then s else str ": " ++ s) ++
+         if Int.equal i 0 then str "." else str " (level " ++ int i ++ str").")
   | AlreadyDeclared msg ->
-      wrap_vernac_error (msg ++ str ".")
-  | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () ->
-      process_vernac_interp_error exc
-  | Proof_type.LtacLocated (s,exc) ->
-      EvaluatedError (hov 0 (Himsg.explain_ltac_call_trace s ++ fnl()),
-        Some (process_vernac_interp_error exc))
-  | Loc.Exc_located (loc,exc) ->
-      Loc.Exc_located (loc,process_vernac_interp_error exc)
-  | exc ->
-      exc
+      wrap_vernac_error exn (msg ++ str ".")
+  | _ ->
+      exn
+
+let rec strip_wrapping_exceptions = function
+  | Logic_monad.TacticFailure e ->
+    strip_wrapping_exceptions e
+  | exc -> exc
+
+let process_vernac_interp_error (exc, info) =
+  let exc = strip_wrapping_exceptions exc in
+  let e = process_vernac_interp_error (exc, info) in
+  let ltac_trace = Exninfo.get info Proof_type.ltac_trace_info in
+  let loc = Option.default Loc.ghost (Loc.get_loc info) in
+  match ltac_trace with
+  | None -> e
+  | Some trace ->
+    let (e, info) = e in
+    match Himsg.extract_ltac_trace trace loc with
+    | None, loc -> (e, Loc.add_loc info loc)
+    | Some msg, loc ->
+      (EvaluatedError (msg, Some e), Loc.add_loc info loc)
 
 let _ = Tactic_debug.explain_logic_error :=
-  (fun e -> Errors.print (process_vernac_interp_error e))
+  (fun e -> Errors.print (fst (process_vernac_interp_error (e, Exninfo.null))))
 
 let _ = Tactic_debug.explain_logic_error_no_anomaly :=
-  (fun e -> Errors.print_no_report (process_vernac_interp_error e))
+  (fun e -> Errors.print_no_report (fst (process_vernac_interp_error (e, Exninfo.null))))
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index c9cada8c..1768af11 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -1,24 +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 Pp
-open Util
-
 (** Error report. *)
 
-val print_loc : loc -> std_ppcmds
+val print_loc : Loc.t -> Pp.std_ppcmds
 
 (** Pre-explain a vernac interpretation error *)
 
-val process_vernac_interp_error : exn -> exn
+val process_vernac_interp_error : Util.iexn -> Util.iexn
 
 (** General explain function. Should not be used directly now,
     see instead function [Errors.print] and variants *)
 
-val explain_exn_default : exn -> std_ppcmds
+val explain_exn_default : exn -> Pp.std_ppcmds
 
diff --git a/toplevel/class.ml b/toplevel/class.ml
index 214fbf5b..6a485d52 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -1,31 +1,29 @@
 (************************************************************************)
 (*  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 Pp
 open Names
-open Nameops
 open Term
+open Vars
 open Termops
-open Inductive
-open Declarations
 open Entries
 open Environ
-open Inductive
-open Lib
 open Classops
 open Declare
-open Libnames
+open Globnames
 open Nametab
 open Decl_kinds
-open Safe_typing
 
-let strength_min l = if List.mem Local l then Local else Global
+let strength_min l = if List.mem `LOCAL l then `LOCAL else `GLOBAL
+
+let loc_of_bool b = if b then `LOCAL else `GLOBAL
 
 (* Errors *)
 
@@ -38,7 +36,6 @@ type coercion_error_kind =
   | NoTarget
   | WrongTarget of cl_typ * cl_typ
   | NotAClass of global_reference
-  | NotEnoughClassArgs of cl_typ
 
 exception CoercionError of coercion_error_kind
 
@@ -65,18 +62,17 @@ let explain_coercion_error g = function
   | NotAClass ref ->
       (str "Type of " ++ Printer.pr_global ref ++
          str " does not end with a sort")
-  | NotEnoughClassArgs cl ->
-      (str"Wrong number of parameters for " ++ pr_class cl)
 
 (* Verifications pour l'ajout d'une classe *)
 
 let check_reference_arity ref =
-  if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global ref)) then
+  if not (Reductionops.is_arity (Global.env()) Evd.empty (Global.type_of_global_unsafe ref)) then
     raise (CoercionError (NotAClass ref))
 
 let check_arity = function
   | CL_FUN | CL_SORT -> ()
   | CL_CONST cst -> check_reference_arity (ConstRef cst)
+  | CL_PROJ cst -> check_reference_arity (ConstRef cst)
   | CL_SECVAR id -> check_reference_arity (VarRef id)
   | CL_IND kn -> check_reference_arity (IndRef kn)
 
@@ -84,7 +80,7 @@ let check_arity = function
 
 (* check that the computed target is the provided one *)
 let check_target clt = function
-  | Some cl when cl <> clt -> raise (CoercionError (WrongTarget(clt,cl)))
+  | Some cl when not (cl_typ_eq cl clt) -> raise (CoercionError (WrongTarget(clt,cl)))
   | _ -> ()
 
 (* condition d'heritage uniforme *)
@@ -94,13 +90,15 @@ let uniform_cond nargs lt =
     | (0,[]) -> true
     | (n,t::l) ->
       let t = strip_outer_cast t in
-      isRel t && destRel t = n && aux ((n-1),l)
+      isRel t && Int.equal (destRel t) n && aux ((n-1),l)
     | _ -> false
   in
   aux (nargs,lt)
 
 let class_of_global = function
-  | ConstRef sp -> CL_CONST sp
+  | ConstRef sp -> 
+    if Environ.is_projection sp (Global.env ()) 
+    then CL_PROJ sp else CL_CONST sp
   | IndRef sp -> CL_IND sp
   | VarRef id -> CL_SECVAR id
   | ConstructRef _ as c ->
@@ -123,19 +121,19 @@ l'indice de la classe source dans la liste lp
 let get_source lp source =
   match source with
     | None ->
-	let (cl1,lv1) =
+	let (cl1,u1,lv1) =
           match lp with
 	    | [] -> raise Not_found
             | t1::_ -> find_class_type Evd.empty t1
         in
-	(cl1,lv1,1)
+	(cl1,u1,lv1,1)
     | Some cl ->
 	let rec aux = function
 	  | [] -> raise Not_found
 	  | t1::lt ->
 	      try
-		let cl1,lv1 = find_class_type Evd.empty t1 in
-		if cl = cl1 then cl1,lv1,(List.length lt+1)
+		let cl1,u1,lv1 = find_class_type Evd.empty t1 in
+		if cl_typ_eq cl cl1 then cl1,u1,lv1,(List.length lt+1)
 		else raise Not_found
               with Not_found -> aux lt
 	in aux (List.rev lp)
@@ -144,7 +142,11 @@ let get_target t ind =
   if (ind > 1) then
     CL_FUN
   else
-    fst (find_class_type Evd.empty t)
+    match pi1 (find_class_type Evd.empty t) with
+    | CL_CONST p when Environ.is_projection p (Global.env ()) -> 
+      CL_PROJ p
+    | x -> x
+      
 
 let prods_of t =
   let rec aux acc d = match kind_of_term d with
@@ -155,9 +157,13 @@ let prods_of t =
   aux [] t
 
 let strength_of_cl = function
-  | CL_CONST kn -> Global
-  | CL_SECVAR id -> Local
-  | _ -> Global
+  | CL_CONST kn -> `GLOBAL
+  | CL_SECVAR id -> `LOCAL
+  | _ -> `GLOBAL
+
+let strength_of_global = function
+  | VarRef _ -> `LOCAL
+  | _ -> `GLOBAL
 
 let get_strength stre ref cls clt =
   let stres = strength_of_cl cls in
@@ -168,28 +174,28 @@ let get_strength stre ref cls clt =
 let ident_key_of_class = function
   | CL_FUN -> "Funclass"
   | CL_SORT -> "Sortclass"
-  | CL_CONST sp -> string_of_label (con_label sp)
-  | CL_IND (sp,_) -> string_of_label (mind_label sp)
-  | CL_SECVAR id -> string_of_id id
+  | CL_CONST sp | CL_PROJ sp -> Label.to_string (con_label sp)
+  | CL_IND (sp,_) -> Label.to_string (mind_label sp)
+  | CL_SECVAR id -> Id.to_string id
 
-(* coercion identité *)
+(* Identity coercion *)
 
 let error_not_transparent source =
   errorlabstrm "build_id_coercion"
     (pr_class source ++ str " must be a transparent constant.")
 
-let build_id_coercion idf_opt source =
+let build_id_coercion idf_opt source poly =
   let env = Global.env () in
-  let vs = match source with
-    | CL_CONST sp -> mkConst sp
+  let vs, ctx = match source with
+    | CL_CONST sp -> Universes.fresh_global_instance env (ConstRef sp)
     | _ -> error_not_transparent source in
-  let c = match constant_opt_value env (destConst vs) with
+  let c = match constant_opt_value_in env (destConst vs) with
     | Some c -> c
     | None -> error_not_transparent source in
   let lams,t = decompose_lam_assum c in
   let val_f =
     it_mkLambda_or_LetIn
-      (mkLambda (Name (id_of_string "x"),
+      (mkLambda (Name Namegen.default_dependent_ident,
 		 applistc vs (extended_rel_list 0 lams),
 		 mkRel 1))
        lams
@@ -212,17 +218,17 @@ let build_id_coercion idf_opt source =
     match idf_opt with
       | Some idf -> idf
       | None ->
-	  let cl,_ = find_class_type Evd.empty t in
-	  id_of_string ("Id_"^(ident_key_of_class source)^"_"^
+	  let cl,u,_ = find_class_type Evd.empty t in
+	  Id.of_string ("Id_"^(ident_key_of_class source)^"_"^
                         (ident_key_of_class cl))
   in
   let constr_entry = (* Cast is necessary to express [val_f] is identity *)
     DefinitionEntry
-      { const_entry_body = mkCast (val_f, DEFAULTcast, typ_f);
-        const_entry_secctx = None;
-	const_entry_type = Some typ_f;
-        const_entry_opaque = false } in
-  let kn = declare_constant idf (constr_entry,IsDefinition IdentityCoercion) in
+      (definition_entry ~types:typ_f ~poly ~univs:(Univ.ContextSet.to_context ctx)
+	 ~inline:true (mkCast (val_f, DEFAULTcast, typ_f)))
+  in
+  let decl = (constr_entry, IsDefinition IdentityCoercion) in
+  let kn = declare_constant idf decl in
   ConstRef kn
 
 let check_source = function
@@ -240,14 +246,14 @@ booleen "coercion identite'?"
 lorque source est None alors target est None aussi.
 *)
 
-let add_new_coercion_core coef stre source target isid =
+let add_new_coercion_core coef stre poly source target isid =
   check_source source;
-  let t = Global.type_of_global coef in
+  let t = Global.type_of_global_unsafe coef in
   if coercion_exists coef then raise (CoercionError AlreadyExists);
   let tg,lp = prods_of t in
   let llp = List.length lp in
-  if llp = 0 then raise (CoercionError NotAFunction);
-  let (cls,lvs,ind) =
+  if Int.equal llp 0 then raise (CoercionError NotAFunction);
+  let (cls,us,lvs,ind) =
     try
       get_source lp source
     with Not_found ->
@@ -255,7 +261,7 @@ let add_new_coercion_core coef stre source target isid =
   in
   check_source (Some cls);
   if not (uniform_cond (llp-ind) lvs) then
-    msg_warn (Pp.string_of_ppcmds (explain_coercion_error coef NotUniform));
+    msg_warning (explain_coercion_error coef NotUniform);
   let clt =
     try
       get_target tg ind
@@ -265,38 +271,55 @@ let add_new_coercion_core coef stre source target isid =
   check_target clt target;
   check_arity cls;
   check_arity clt;
-  let stre' = get_strength stre coef cls clt in
-  declare_coercion coef stre' ~isid ~src:cls ~target:clt ~params:(List.length lvs)
+  let local = match get_strength stre coef cls clt with
+  | `LOCAL -> true
+  | `GLOBAL -> false
+  in
+  declare_coercion coef ~local ~isid ~src:cls ~target:clt ~params:(List.length lvs)
+
 
-let try_add_new_coercion_core ref b c d e =
-  try add_new_coercion_core ref b c d e
+let try_add_new_coercion_core ref ~local c d e f =
+  try add_new_coercion_core ref (loc_of_bool local) c d e f
   with CoercionError e ->
       errorlabstrm "try_add_new_coercion_core"
         (explain_coercion_error ref e ++ str ".")
 
-let try_add_new_coercion ref stre =
-  try_add_new_coercion_core ref stre None None false
+let try_add_new_coercion ref ~local poly =
+  try_add_new_coercion_core ref ~local poly None None false
 
-let try_add_new_coercion_subclass cl stre =
-  let coe_ref = build_id_coercion None cl in
-  try_add_new_coercion_core coe_ref stre (Some cl) None true
+let try_add_new_coercion_subclass cl ~local poly =
+  let coe_ref = build_id_coercion None cl poly in
+  try_add_new_coercion_core coe_ref ~local poly (Some cl) None true
 
-let try_add_new_coercion_with_target ref stre ~source ~target =
-  try_add_new_coercion_core ref stre (Some source) (Some target) false
+let try_add_new_coercion_with_target ref ~local poly ~source ~target =
+  try_add_new_coercion_core ref ~local poly (Some source) (Some target) false
 
-let try_add_new_identity_coercion id stre ~source ~target =
-  let ref = build_id_coercion (Some id) source in
-  try_add_new_coercion_core ref stre (Some source) (Some target) true
+let try_add_new_identity_coercion id ~local poly ~source ~target =
+  let ref = build_id_coercion (Some id) source poly in
+  try_add_new_coercion_core ref ~local poly (Some source) (Some target) true
 
-let try_add_new_coercion_with_source ref stre ~source =
-  try_add_new_coercion_core ref stre (Some source) None false
+let try_add_new_coercion_with_source ref ~local poly ~source =
+  try_add_new_coercion_core ref ~local poly (Some source) None false
 
-let add_coercion_hook stre ref =
-  try_add_new_coercion ref stre;
-  Flags.if_verbose message
-    (string_of_qualid (shortest_qualid_of_global Idset.empty ref)
-    ^ " is now a coercion")
+let add_coercion_hook poly local ref =
+  let stre = match local with
+  | Local -> true
+  | Global -> false
+  | Discharge -> assert false
+  in
+  let () = try_add_new_coercion ref stre poly in
+  let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in
+  Flags.if_verbose msg_info msg
+
+let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly)
 
-let add_subclass_hook stre ref =
+let add_subclass_hook poly local ref =
+  let stre = match local with
+  | Local -> true
+  | Global -> false
+  | Discharge -> assert false
+  in
   let cl = class_of_global ref in
-  try_add_new_coercion_subclass cl stre
+  try_add_new_coercion_subclass cl stre poly
+
+let add_subclass_hook poly = Lemmas.mk_hook (add_subclass_hook poly)
diff --git a/toplevel/class.mli b/toplevel/class.mli
index d2e12de6..bd6c7a6d 100644
--- a/toplevel/class.mli
+++ b/toplevel/class.mli
@@ -1,49 +1,48 @@
 (************************************************************************)
 (*  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 Classops
-open Declare
-open Libnames
-open Decl_kinds
-open Nametab
+open Globnames
 
 (** Classes and coercions. *)
 
 (** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion
    from [src] to [tg] *)
-val try_add_new_coercion_with_target : global_reference -> locality ->
+val try_add_new_coercion_with_target : global_reference -> local:bool -> 
+  Decl_kinds.polymorphic ->
   source:cl_typ -> target:cl_typ ->  unit
 
 (** [try_add_new_coercion ref s] declares [ref], assumed to be of type
    [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *)
-val try_add_new_coercion : global_reference -> locality -> unit
+val try_add_new_coercion : global_reference -> local:bool -> 
+  Decl_kinds.polymorphic -> unit
 
 (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a
    transparent constant which unfolds to some class [tg]; it declares
    an identity coercion from [cst] to [tg], named something like
    ["Id_cst_tg"] *)
-val try_add_new_coercion_subclass : cl_typ -> locality -> unit
+val try_add_new_coercion_subclass : cl_typ -> local:bool -> 
+  Decl_kinds.polymorphic -> unit
 
 (** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion
    from [src] to [tg] where the target is inferred from the type of [ref] *)
-val try_add_new_coercion_with_source : global_reference -> locality ->
-  source:cl_typ -> unit
+val try_add_new_coercion_with_source : global_reference -> local:bool -> 
+  Decl_kinds.polymorphic -> source:cl_typ -> unit
 
 (** [try_add_new_identity_coercion id s src tg] enriches the
    environment with a new definition of name [id] declared as an
    identity coercion from [src] to [tg] *)
-val try_add_new_identity_coercion : identifier -> locality ->
-  source:cl_typ -> target:cl_typ -> unit
+val try_add_new_identity_coercion : Id.t -> local:bool -> 
+  Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit
 
-val add_coercion_hook : Tacexpr.declaration_hook
+val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
 
-val add_subclass_hook : Tacexpr.declaration_hook
+val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook
 
 val class_of_global : global_reference -> cl_typ
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index 3843ea83..f44ac367 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.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,80 +8,77 @@
 
 (*i*)
 open Names
-open Decl_kinds
 open Term
-open Sign
-open Entries
-open Evd
+open Vars
 open Environ
 open Nametab
-open Mod_subst
+open Errors
 open Util
 open Typeclasses_errors
 open Typeclasses
 open Libnames
+open Globnames
 open Constrintern
-open Glob_term
-open Topconstr
+open Constrexpr
 (*i*)
 
 open Decl_kinds
 open Entries
 
+let refine_instance = ref true
+
+let _ = Goptions.declare_bool_option {
+  Goptions.optsync  = true;
+  Goptions.optdepr  = false;
+  Goptions.optname  = "definition of instances by refining";
+  Goptions.optkey   = ["Refine";"Instance";"Mode"];
+  Goptions.optread  = (fun () -> !refine_instance);
+  Goptions.optwrite = (fun b -> refine_instance := b)
+}
+
 let typeclasses_db = "typeclass_instances"
 
 let set_typeclass_transparency c local b = 
-  Auto.add_hints local [typeclasses_db] 
-    (Auto.HintsTransparencyEntry ([c], b))
+  Hints.add_hints local [typeclasses_db] 
+    (Hints.HintsTransparencyEntry ([c], b))
     
 let _ =
-  Typeclasses.register_add_instance_hint
-    (fun inst local pri ->
-     let path =
-       try Auto.PathHints [global_of_constr inst]
-       with e when Errors.noncritical e -> Auto.PathAny
+  Hook.set Typeclasses.add_instance_hint_hook
+    (fun inst path local pri poly ->
+     let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty)
+       | IsGlobal gr -> Hints.IsGlobRef gr
      in
       Flags.silently (fun () ->
-	Auto.add_hints local [typeclasses_db]
-	  (Auto.HintsResolveEntry
-	     [pri, false, path, inst])) ());
-  Typeclasses.register_set_typeclass_transparency set_typeclass_transparency;
-  Typeclasses.register_classes_transparent_state 
-    (fun () -> Auto.Hint_db.transparent_state (Auto.searchtable_map typeclasses_db))
-    
-let declare_class g =
-  match global g with
-  | ConstRef x -> Typeclasses.add_constant_class x
-  | IndRef x -> Typeclasses.add_inductive_class x
-  | _ -> user_err_loc (loc_of_reference g, "declare_class", 
-		      Pp.str"Unsupported class type, only constants and inductives are allowed")
-    
+	Hints.add_hints local [typeclasses_db]
+	  (Hints.HintsResolveEntry
+	     [pri, poly, false, Hints.PathHints path, inst'])) ());
+  Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency;
+  Hook.set Typeclasses.classes_transparent_state_hook
+    (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db))
+        
 (** TODO: add subinstances *)
-let existing_instance glob g =
+let existing_instance glob g pri =
   let c = global g in
-  let instance = Typing.type_of (Global.env ()) Evd.empty (constr_of_global c) in
+  let instance = Global.type_of_global_unsafe c in
   let _, r = decompose_prod_assum instance in
     match class_of_constr r with
-      | Some (_, (tc, _)) -> add_instance (new_instance tc None glob c)
+      | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob 
+  (*FIXME*) (Flags.use_polymorphic_flag ()) c)
       | None -> user_err_loc (loc_of_reference g, "declare_instance",
 			     Pp.str "Constant does not build instances of a declared type class.")
 
 let mismatched_params env n m = mismatched_ctx_inst env Parameters n m
 let mismatched_props env n m = mismatched_ctx_inst env Properties n m
 
-type binder_list = (identifier located * bool * constr_expr) list
-
 (* Declare everything in the parameters as implicit, and the class instance as well *)
 
-open Topconstr
-
 let type_ctx_instance evars env ctx inst subst =
   let rec aux (subst, instctx) l = function
     (na, b, t) :: ctx ->
       let t' = substl subst t in
       let c', l =
 	match b with
-	| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
+	| None -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l
 	| Some b -> substl subst b, l
       in
       let d = na, Some c', t' in
@@ -89,11 +86,9 @@ let type_ctx_instance evars env ctx inst subst =
     | [] -> subst
   in aux (subst, []) inst (List.rev ctx)
 
-let refine_ref = ref (fun _ -> assert(false))
-
 let id_of_class cl =
   match cl.cl_impl with
-    | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l
+    | ConstRef kn -> let _,_,l = repr_con kn in Label.to_id l
     | IndRef (kn,i) ->
 	let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in
 	  mip.(0).Declarations.mind_typename
@@ -101,55 +96,53 @@ let id_of_class cl =
 
 open Pp
 
-let ($$) g f = fun x -> g (f x)
-
 let instance_hook k pri global imps ?hook cst =
   Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps;
   Typeclasses.declare_instance pri (not global) cst;
   (match hook with Some h -> h cst | None -> ())
 
-let declare_instance_constant k pri global imps ?hook id term termtype =
-  let cdecl =
-    let kind = IsDefinition Instance in
-    let entry =
-      { const_entry_body   = term;
-        const_entry_secctx = None;
-	const_entry_type   = Some termtype;
-	const_entry_opaque = false }
-    in DefinitionEntry entry, kind
+let declare_instance_constant k pri global imps ?hook id poly uctx term termtype =
+  let kind = IsDefinition Instance in
+  let entry = 
+    Declare.definition_entry ~types:termtype ~poly ~univs:uctx term
   in
+  let cdecl = (DefinitionEntry entry, kind) in
   let kn = Declare.declare_constant id cdecl in
     Declare.definition_message id;
     instance_hook k pri global imps ?hook (ConstRef kn);
     id
 
-let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
+let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) props
     ?(generalize=true)
-    ?(tac:Proof_type.tactic option) ?(hook:(global_reference -> unit) option) pri =
+    ?(tac:unit Proofview.tactic option) ?hook pri =
   let env = Global.env() in
-  let evars = ref Evd.empty in
+  let evars = ref (Evd.from_env env) in
   let tclass, ids =
     match bk with
     | Implicit ->
-	Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false
+	Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false
 	  (fun avoid (clname, (id, _, t)) ->
 	    match clname with
 	    | Some (cl, b) ->
-		let t = CHole (Util.dummy_loc, None) in
+		let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in
 		  t, avoid
 	    | None -> failwith ("new instance: under-applied typeclass"))
 	  cl
-    | Explicit -> cl, Idset.empty
+    | Explicit -> cl, Id.Set.empty
+  in
+  let tclass = 
+    if generalize then CGeneralization (Loc.ghost, Implicit, Some AbsPi, tclass) 
+    else tclass 
   in
-  let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
-  let k, cty, ctx', ctx, len, imps, subst =
-    let impls, ((env', ctx), imps) = interp_context_evars evars env ctx in
-    let c', imps' = interp_type_evars_impls ~impls ~evdref:evars ~fail_evar:false env' tclass in
+  let k, u, cty, ctx', ctx, len, imps, subst =
+    let impls, ((env', ctx), imps) = interp_context_evars env evars ctx in
+    let c', imps' = interp_type_evars_impls ~impls env' evars tclass in
     let len = List.length ctx in
     let imps = imps @ Impargs.lift_implicits len imps' in
     let ctx', c = decompose_prod_assum c' in
     let ctx'' = ctx' @ ctx in
-    let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+    let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+    let cl, u = Typeclasses.typeclass_univ_instance k in
     let _, args = 
       List.fold_right (fun (na, b, t) (args, args') ->
 	match b with
@@ -157,7 +150,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
 	| Some b -> (args, substl args' b :: args'))
 	(snd cl.cl_context) (args, [])
     in
-      cl, c', ctx', ctx, len, imps, args
+      cl, u, c', ctx', ctx, len, imps, args
   in
   let id =
     match snd instid with
@@ -172,158 +165,217 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
   in
   let env' = push_rel_context ctx env in
   evars := Evarutil.nf_evar_map !evars;
-  evars := resolve_typeclasses env !evars;
-  let sigma =  !evars in
-  let subst = List.map (Evarutil.nf_evar sigma) subst in
+  evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env !evars;
+  let subst = List.map (Evarutil.nf_evar !evars) subst in
     if abstract then
       begin
-	if not (Lib.is_modtype ()) then
-	  error "Declare Instance while not in Module Type.";
-	let _, ty_constr = instance_constructor k (List.rev subst) in
+	let subst = List.fold_left2
+	  (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst')
+	  [] subst (snd k.cl_context)
+	in
+	let (_, ty_constr) = instance_constructor (k,u) subst in
+	let nf, subst = Evarutil.e_nf_evars_and_universes evars in
 	let termtype =
 	  let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	    Evarutil.nf_evar !evars t
+	    nf t
 	in
 	Evarutil.check_evars env Evd.empty !evars termtype;
+	let ctx = Evd.universe_context !evars in
 	let cst = Declare.declare_constant ~internal:Declare.KernelSilent id
 	  (Entries.ParameterEntry 
-            (None,termtype,None), Decl_kinds.IsAssumption Decl_kinds.Logical)
+            (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical)
 	in instance_hook k None global imps ?hook (ConstRef cst); id
       end
-    else
-      begin
-	let props =
-	  match props with
-	  | Some (CRecord (loc, _, fs)) ->
-	      if List.length fs > List.length k.cl_props then
-		mismatched_props env' (List.map snd fs) k.cl_props;
-	      Some (Inl fs)
-	  | Some t -> Some (Inr t)
-	  | None -> None
-	in
-	let subst =
-	  match props with
-	  | None -> if k.cl_props = [] then Some (Inl subst) else None
-	  | Some (Inr term) ->
-	      let c = interp_casted_constr_evars evars env' term cty in
-		Some (Inr (c, subst))
-	  | Some (Inl props) ->
-	      let get_id =
-		function
-		  | Ident id' -> id'
-		  | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
-	      in
-	      let props, rest =
-		List.fold_left
-		  (fun (props, rest) (id,b,_) ->
-		    if b = None then
-		      try
-			let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in
-			let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in
-			let (loc, mid) = get_id loc_mid in
-			  List.iter (fun (n, _, x) -> 
-				       if n = Name mid then
-					 Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
-			    k.cl_projs;
-			  c :: props, rest'
-		      with Not_found ->
-			(CHole (Util.dummy_loc, None) :: props), rest
-		    else props, rest)
-		  ([], props) k.cl_props
-	      in
-		if rest <> [] then
-		  unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
-		else
-		  Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst))
-	in	  
+    else (
+      let props =
+	match props with
+	| Some (true, CRecord (loc, _, fs)) ->
+	    if List.length fs > List.length k.cl_props then
+	      mismatched_props env' (List.map snd fs) k.cl_props;
+	    Some (Inl fs)
+	| Some (_, t) -> Some (Inr t)
+	| None -> 
+	    if Flags.is_program_mode () then Some (Inl [])
+	    else None
+      in
+      let subst =
+	match props with
+	| None -> if List.is_empty k.cl_props then Some (Inl subst) else None
+	| Some (Inr term) ->
+	    let c = interp_casted_constr_evars env' evars term cty in
+	      Some (Inr (c, subst))
+	| Some (Inl props) ->
+	    let get_id =
+	      function
+		| Ident id' -> id'
+		| _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+	    in
+	    let props, rest =
+	      List.fold_left
+		(fun (props, rest) (id,b,_) ->
+		  if Option.is_empty b then 
+		    try
+		      let is_id (id', _) = match id, get_id id' with
+			| Name id, (_, id') -> Id.equal id id'
+			| Anonymous, _ -> false
+                      in
+		       let (loc_mid, c) =
+			 List.find is_id rest 
+		       in
+		       let rest' = 
+			 List.filter (fun v -> not (is_id v)) rest 
+		       in
+		       let (loc, mid) = get_id loc_mid in
+			 List.iter (fun (n, _, x) -> 
+				      if Name.equal n (Name mid) then
+					Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x)
+			   k.cl_projs;
+			 c :: props, rest'
+		     with Not_found ->
+		       (CHole (Loc.ghost, Some Evar_kinds.GoalEvar, Misctypes.IntroAnonymous, None) :: props), rest
+		   else props, rest)
+		([], props) k.cl_props
+	    in
+              match rest with
+              | (n, _) :: _ ->
+		unbound_method env' k.cl_impl (get_id n)
+              | _ ->
+		Some (Inl (type_ctx_instance evars (push_rel_context ctx' env') 
+			     k.cl_props props subst))
+      in	  
+      let term, termtype =
+	match subst with
+	| None -> let termtype = it_mkProd_or_LetIn cty ctx in
+	    None, termtype
+	| Some (Inl subst) ->
+	  let subst = List.fold_left2
+	    (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst')
+	    [] subst (k.cl_props @ snd k.cl_context)
+	  in
+	  let (app, ty_constr) = instance_constructor (k,u) subst in
+	  let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+	  let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
+	    Some term, termtype
+	| Some (Inr (def, subst)) ->
+	  let termtype = it_mkProd_or_LetIn cty ctx in
+	  let term = Termops.it_mkLambda_or_LetIn def ctx in
+	    Some term, termtype
+      in
+      let _ = 
 	evars := Evarutil.nf_evar_map !evars;
-	let term, termtype =
-	  match subst with
-	  | None -> let termtype = it_mkProd_or_LetIn cty ctx in
-	      None, termtype
-	  | Some (Inl subst) ->
-	      let subst = List.fold_left2
-		(fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
-		[] subst (k.cl_props @ snd k.cl_context)
+	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals_or_obligations ~fail:true
+          env !evars;
+	(* Try resolving fields that are typeclasses automatically. *)
+	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
+	  env !evars
+      in
+      let _ = evars := Evarutil.nf_evar_map_undefined !evars in
+      let evm, nf = Evarutil.nf_evar_map_universes !evars in
+      let termtype = nf termtype in
+      let _ = (* Check that the type is free of evars now. *)
+	Evarutil.check_evars env Evd.empty evm termtype
+      in
+      let term = Option.map nf term in
+	if not (Evd.has_undefined evm) && not (Option.is_empty term) then
+          let ctx = Evd.universe_context evm in
+	  declare_instance_constant k pri global imps ?hook id 
+            poly ctx (Option.get term) termtype
+	else if !refine_instance || Option.is_empty term then begin
+	  let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in
+	    if Flags.is_program_mode () then
+	      let hook vis gr =
+		let cst = match gr with ConstRef kn -> kn | _ -> assert false in
+		  Impargs.declare_manual_implicits false gr ~enriching:false [imps];
+		  Typeclasses.declare_instance pri (not global) (ConstRef cst)
 	      in
-	      let app, ty_constr = instance_constructor k subst in
-	      let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
-	      let term = Termops.it_mkLambda_or_LetIn (Option.get app) (ctx' @ ctx) in
-		Some term, termtype
-	  | Some (Inr (def, subst)) ->
-	      let termtype = it_mkProd_or_LetIn cty ctx in
-	      let term = Termops.it_mkLambda_or_LetIn def ctx in
-		Some term, termtype
-	in
-	let _ = 
-	  evars := Evarutil.nf_evar_map !evars;
-	  evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true
-            env !evars;
-	  (* Try resolving fields that are typeclasses automatically. *)
-	  evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
-	    env !evars
-	in
-	let termtype = Evarutil.nf_evar !evars termtype in
-	let term = Option.map (Evarutil.nf_evar !evars) term in
-	let evm = undefined_evars !evars in
-	Evarutil.check_evars env Evd.empty !evars termtype;
-	  if Evd.is_empty evm && term <> None then
-	    declare_instance_constant k pri global imps ?hook id (Option.get term) termtype
-	  else begin
-	    let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
-	      Flags.silently (fun () ->
-		Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook);
-		if term <> None then 
-		  Pfedit.by (!refine_ref (evm, Option.get term))
+	      let obls, constr, typ =
+		match term with 
+		| Some t -> 
+		  let obls, _, constr, typ = 
+		    Obligations.eterm_obligations env id evm 0 t termtype
+		  in obls, Some constr, typ
+		| None -> [||], None, termtype
+	      in
+              let hook = Lemmas.mk_hook hook in
+	      let ctx = Evd.evar_universe_context evm in
+		ignore (Obligations.add_definition id ?term:constr
+			typ ctx ~kind:(Global,poly,Instance) ~hook obls);
+		id
+	    else
+	      (Flags.silently 
+	       (fun () ->
+                  (* spiwack: it is hard to reorder the actions to do
+                     the pretyping after the proof has opened. As a
+                     consequence, we use the low-level primitives to code
+                     the refinement manually.*)
+		let gls = List.rev (Evd.future_goals evm) in
+                let evm = Evd.reset_future_goals evm in
+                Lemmas.start_proof id kind evm termtype
+		(Lemmas.mk_hook
+                  (fun _ -> instance_hook k pri global imps ?hook));
+                 (* spiwack: I don't know what to do with the status here. *)
+		if not (Option.is_empty term) then
+                  let init_refine =
+                    Tacticals.New.tclTHENLIST [
+                      Proofview.Refine.refine (fun evm -> evm, Option.get term);
+                      Proofview.Unsafe.tclNEWGOALS gls;
+                      Tactics.New.reduce_after_refine;
+                    ]
+                  in
+		  ignore (Pfedit.by init_refine)
 		else if Flags.is_auto_intros () then
-		  Pfedit.by (Refiner.tclDO len Tactics.intro);
-		(match tac with Some tac -> Pfedit.by tac | None -> ())) ();
-	      Flags.if_verbose (msg $$ Printer.pr_open_subgoals) ();
-	      id
-	  end
-      end
+		  ignore (Pfedit.by (Tacticals.New.tclDO len Tactics.intro));
+		(match tac with Some tac -> ignore (Pfedit.by tac) | None -> ())) ();
+	       id)
+	end
+      else Errors.error "Unsolved obligations remaining.")
 	
 let named_of_rel_context l =
   let acc, ctx =
     List.fold_right
       (fun (na, b, t) (subst, ctx) ->
-	let id = match na with Anonymous -> raise (Invalid_argument "named_of_rel_context") | Name id -> id in
+	let id = match na with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in
 	let d = (id, Option.map (substl subst) b, substl subst t) in
 	  (mkVar id :: subst, d :: ctx))
       l ([], [])
   in ctx
 
-let string_of_global r =
- string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
-      
-let context l =
+let context poly l =
   let env = Global.env() in
   let evars = ref Evd.empty in
-  let _, ((env', fullctx), impls) = interp_context_evars evars env l in
-  let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in
+  let _, ((env', fullctx), impls) = interp_context_evars env evars l in
+  let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in
+  let fullctx = Context.map_rel_context subst fullctx in
   let ce t = Evarutil.check_evars env Evd.empty !evars t in
-  List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx;
+  let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in
   let ctx =
     try named_of_rel_context fullctx
     with e when Errors.noncritical e ->
       error "Anonymous variables not allowed in contexts."
   in
-  let fn (id, _, t) =
+  let uctx = Evd.universe_context_set !evars in
+  let fn status (id, b, t) =
     if Lib.is_modtype () && not (Lib.sections_are_opened ()) then
-      let cst = Declare.declare_constant ~internal:Declare.KernelSilent id
-	(ParameterEntry (None,t,None), IsAssumption Logical)
-      in
+      let uctx = Univ.ContextSet.to_context uctx in	
+      let decl = (ParameterEntry (None,poly,(t,uctx),None), IsAssumption Logical) in
+      let cst = Declare.declare_constant ~internal:Declare.KernelSilent id decl in
 	match class_of_constr t with
-	| Some (rels, (tc, args) as _cl) ->
-	    add_instance (Typeclasses.new_instance tc None false (ConstRef cst))
+	| Some (rels, ((tc,_), args) as _cl) ->
+	    add_instance (Typeclasses.new_instance tc None false (*FIXME*)
+			    poly (ConstRef cst));
+            status
 	    (* declare_subclasses (ConstRef cst) cl *)
-	| None -> ()
-    else (
-      let impl = List.exists 
-	(fun (x,_) ->
-	   match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls
+	| None -> status
+    else
+      let test (x, _) = match x with
+      | ExplByPos (_, Some id') -> Id.equal id id'
+      | _ -> false
+      in
+      let impl = List.exists test impls in
+      let decl = (Discharge, poly, Definitional) in
+      let nstatus =
+        pi3 (Command.declare_assumption false decl (t, uctx) [] impl
+          Vernacexpr.NoInline (Loc.ghost, id))
       in
-	Command.declare_assumption false (Local (* global *), Definitional) t
-	  [] impl (* implicit *) None (* inline *) (dummy_loc, id))
-  in List.iter fn (List.rev ctx)
-       
+      status && nstatus
+  in List.fold_left fn true (List.rev ctx)
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index 97b363c2..0a351d3c 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -1,23 +1,17 @@
 (************************************************************************)
 (*  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 Decl_kinds
-open Term
-open Sign
+open Context
 open Evd
 open Environ
-open Nametab
-open Mod_subst
-open Topconstr
-open Util
+open Constrexpr
 open Typeclasses
-open Implicit_quantifiers
 open Libnames
 
 (** Errors *)
@@ -26,36 +20,36 @@ val mismatched_params : env -> constr_expr list -> rel_context -> 'a
 
 val mismatched_props : env -> constr_expr list -> rel_context -> 'a
 
-(** Post-hoc class declaration. *)
-
-val declare_class : reference -> unit
-
 (** Instance declaration *)
 
-val existing_instance : bool -> reference -> unit
+val existing_instance : bool -> reference -> int option -> unit
+(** globality, reference, priority *)
 
 val declare_instance_constant :
   typeclass ->
   int option -> (** priority *)
   bool -> (** globality *)
   Impargs.manual_explicitation list -> (** implicits *)
-  ?hook:(Libnames.global_reference -> unit) ->
-  identifier -> (** name *)
-  Term.constr -> (** body *)
+  ?hook:(Globnames.global_reference -> unit) ->
+  Id.t -> (** name *)
+  bool -> (* polymorphic *)
+  Univ.universe_context -> (* Universes *)
+  Constr.t -> (** body *)
   Term.types -> (** type *)
-  Names.identifier
+  Names.Id.t
 
 val new_instance :
   ?abstract:bool -> (** Not abstract by default. *)
   ?global:bool -> (** Not global by default. *)
+  Decl_kinds.polymorphic ->
   local_binder list ->
   typeclass_constraint ->
-  constr_expr option ->
+  (bool * constr_expr) option ->
   ?generalize:bool ->
-  ?tac:Proof_type.tactic  ->
-  ?hook:(Libnames.global_reference -> unit) ->
+  ?tac:unit Proofview.tactic  ->
+  ?hook:(Globnames.global_reference -> unit) ->
   int option ->
-  identifier
+  Id.t
 
 (** Setting opacity *)
 
@@ -63,12 +57,10 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u
 
 (** For generation on names based on classes only *)
 
-val id_of_class : typeclass -> identifier
+val id_of_class : typeclass -> Id.t
 
 (** Context command *)
 
-val context : local_binder list -> unit
-
-(** Forward ref for refine *)
-
-val refine_ref : (open_constr -> Proof_type.tactic) ref
+(** returns [false] if, for lack of section, it declares an assumption
+    (unless in a module type). *)
+val context : Decl_kinds.polymorphic -> local_binder list -> bool
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 6e1fb49c..9cb3bb86 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -1,15 +1,18 @@
 (************************************************************************)
 (*  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 Flags
 open Term
+open Vars
+open Context
 open Termops
 open Entries
 open Environ
@@ -17,7 +20,10 @@ open Redexpr
 open Declare
 open Names
 open Libnames
+open Globnames
 open Nameops
+open Constrexpr
+open Constrexpr_ops
 open Topconstr
 open Constrintern
 open Nametab
@@ -28,11 +34,15 @@ open Decl_kinds
 open Pretyping
 open Evarutil
 open Evarconv
-open Notation
 open Indschemes
+open Misctypes
+open Vernacexpr
+
+let do_universe l = Declare.do_universe l  
+let do_constraint l = Declare.do_constraint l
 
 let rec under_binders env f n c =
-  if n = 0 then f env Evd.empty c else
+  if Int.equal n 0 then snd (f env Evd.empty c) else
     match kind_of_term c with
       | Lambda (x,t,c) ->
 	  mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c)
@@ -43,14 +53,14 @@ let rec under_binders env f n c =
 let rec complete_conclusion a cs = function
   | CProdN (loc,bl,c) -> CProdN (loc,bl,complete_conclusion a cs c)
   | CLetIn (loc,b,t,c) -> CLetIn (loc,b,t,complete_conclusion a cs c)
-  | CHole (loc, k) ->
+  | CHole (loc, k, _, _) ->
       let (has_no_args,name,params) = a in
       if not has_no_args then
 	user_err_loc (loc,"",
 	  strbrk"Cannot infer the non constant arguments of the conclusion of "
 	  ++ pr_id cs ++ str ".");
-      let args = List.map (fun id -> CRef(Ident(loc,id))) params in
-      CAppExpl (loc,(None,Ident(loc,name)),List.rev args)
+      let args = List.map (fun id -> CRef(Ident(loc,id),None)) params in
+      CAppExpl (loc,(None,Ident(loc,name),None),List.rev args)
   | c -> c
 
 (* Commands of the interface *)
@@ -60,154 +70,254 @@ let rec complete_conclusion a cs = function
 let red_constant_entry n ce = function
   | None -> ce
   | Some red ->
-      let body = ce.const_entry_body in
-      { ce with const_entry_body =
-        under_binders (Global.env()) (fst (reduction_of_red_expr red)) n body }
-
-let interp_definition bl red_option c ctypopt =
+      let proof_out = ce.const_entry_body in
+      let env = Global.env () in
+      { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out
+        (fun ((body,ctx),eff) ->
+          (under_binders env
+             (fst (reduction_of_red_expr env red)) n body,ctx),eff) }
+
+let interp_definition bl p red_option c ctypopt =
   let env = Global.env() in
-  let evdref = ref Evd.empty in
-  let impls, ((env_bl, ctx), imps1) = interp_context_evars evdref env bl in
+  let evdref = ref (Evd.from_env env) in
+  let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in
   let nb_args = List.length ctx in
   let imps,ce =
     match ctypopt with
       None ->
-	let c, imps2 = interp_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c in
-	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
-	check_evars env Evd.empty !evdref body;
-	imps1@(Impargs.lift_implicits nb_args imps2),
-	{ const_entry_body = body;
-          const_entry_secctx = None;
-	  const_entry_type = None;
-          const_entry_opaque = false }
+        let subst = evd_comb0 Evd.nf_univ_variables evdref in
+	let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in
+	let env_bl = push_rel_context ctx env in
+	let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in
+        let nf,subst = Evarutil.e_nf_evars_and_universes evdref in
+        let body = nf (it_mkLambda_or_LetIn c ctx) in
+	let vars = Universes.universes_of_constr body in
+	let ctx = Universes.restrict_universe_context
+	  (Evd.universe_context_set !evdref) vars in
+ 	imps1@(Impargs.lift_implicits nb_args imps2),
+	  definition_entry ~univs:(Univ.ContextSet.to_context ctx) ~poly:p body
     | Some ctyp ->
-	let ty, impsty = interp_type_evars_impls ~impls ~evdref ~fail_evar:false env_bl ctyp in
-	let c, imps2 = interp_casted_constr_evars_impls ~impls ~evdref ~fail_evar:false env_bl c ty in
-	let body = nf_evar !evdref (it_mkLambda_or_LetIn c ctx) in
-	let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in
-	check_evars env Evd.empty !evdref body;
-	check_evars env Evd.empty !evdref typ;
-	(* Check that all implicit arguments inferable from the term is inferable from the type *)
-	if not (try List.for_all (fun (key,va) -> List.assoc key impsty = va) imps2 with Not_found -> false)
-	then warn (str "Implicit arguments declaration relies on type." ++
-		     spc () ++ str "The term declares more implicits than the type here.");
+	let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in
+	let subst = evd_comb0 Evd.nf_univ_variables evdref in
+	let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in
+	let env_bl = push_rel_context ctx env in
+	let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in
+	let nf, subst = Evarutil.e_nf_evars_and_universes evdref in
+	let body = nf (it_mkLambda_or_LetIn c ctx) in
+	let typ = nf (it_mkProd_or_LetIn ty ctx) in
+        let beq b1 b2 = if b1 then b2 else not b2 in
+        let impl_eq (x,y,z) (x',y',z') = beq x x' && beq y y' && beq z z' in
+	(* Check that all implicit arguments inferable from the term
+           are inferable from the type *)
+        let chk (key,va) =
+          impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *)
+        in
+	if not (try List.for_all chk imps2 with Not_found -> false)
+	then msg_warning
+          (strbrk "Implicit arguments declaration relies on type." ++ spc () ++
+	   strbrk "The term declares more implicits than the type here.");
+        let vars = Univ.LSet.union (Universes.universes_of_constr body) 
+          (Universes.universes_of_constr typ) in
+        let ctx = Universes.restrict_universe_context
+          (Evd.universe_context_set !evdref) vars in
 	imps1@(Impargs.lift_implicits nb_args impsty),
-	{ const_entry_body = body;
-          const_entry_secctx = None;
-	  const_entry_type = Some typ;
-          const_entry_opaque = false }
+	  definition_entry ~types:typ ~poly:p 
+	    ~univs:(Univ.ContextSet.to_context ctx) body
   in
-  red_constant_entry (rel_context_length ctx) ce red_option, imps
+  red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps
+
+let check_definition (ce, evd, imps) =
+  check_evars_are_solved (Global.env ()) evd (Evd.empty,evd);
+  ce
+
+let get_locality id = function
+| Discharge ->
+  (** If a Let is defined outside a section, then we consider it as a local definition *)
+  let msg = pr_id id ++ strbrk " is declared as a local definition" in
+  let () = msg_warning msg in
+  true
+| Local -> true
+| Global -> false
 
 let declare_global_definition ident ce local k imps =
-  let kn = declare_constant ident (DefinitionEntry ce,IsDefinition k) in
+  let local = get_locality ident local in
+  let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in
   let gr = ConstRef kn in
-    maybe_declare_manual_implicits false gr imps;
-    if local = Local && Flags.is_verbose() then
-      msg_warning (pr_id ident ++ str" is declared as a global definition");
-    definition_message ident;
-    Autoinstance.search_declaration (ConstRef kn);
-    gr
+  let () = maybe_declare_manual_implicits false gr imps in
+  let () = definition_message ident in
+  gr
 
 let declare_definition_hook = ref ignore
 let set_declare_definition_hook = (:=) declare_definition_hook
 let get_declare_definition_hook () = !declare_definition_hook
 
-let declare_definition ident (local,k) ce imps hook =
-  !declare_definition_hook ce;
+let declare_definition ident (local, p, k) ce imps hook =
+  let () = !declare_definition_hook ce in
   let r = match local with
-    | Local when Lib.sections_are_opened () ->
-        let c =
-          SectionLocalDef(ce.const_entry_body ,ce.const_entry_type,false) in
-        let _ = declare_variable ident (Lib.cwd(),c,IsDefinition k) in
-        definition_message ident;
-        if Pfedit.refining () then
-          Flags.if_warn msg_warning
-	    (str"Local definition " ++ pr_id ident ++
-             str" is not visible from current goals");
-        VarRef ident
-    | (Global|Local) ->
-        declare_global_definition ident ce local k imps in
-  hook local r
+  | Discharge when Lib.sections_are_opened () ->
+    let c = SectionLocalDef ce in
+    let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in
+    let () = definition_message ident in
+    let gr = VarRef ident in
+    let () = maybe_declare_manual_implicits false gr imps in
+    let () = if Pfedit.refining () then
+      let msg = strbrk "Section definition " ++
+        pr_id ident ++ strbrk " is not visible from current goals" in
+      msg_warning msg
+    in
+    gr
+  | Discharge | Local | Global ->
+    declare_global_definition ident ce local k imps in
+  Lemmas.call_hook (Future.fix_exn_of ce.Entries.const_entry_body) hook local r
+
+let _ = Obligations.declare_definition_ref := declare_definition
+
+let do_definition ident k bl red_option c ctypopt hook =
+  let (ce, evd, imps as def) = interp_definition bl (pi2 k) red_option c ctypopt in
+    if Flags.is_program_mode () then
+      let env = Global.env () in
+      let (c,ctx), sideff = Future.force ce.const_entry_body in
+      assert(Declareops.side_effects_is_empty sideff);
+      assert(Univ.ContextSet.is_empty ctx);
+      let typ = match ce.const_entry_type with 
+	| Some t -> t
+	| None -> Retyping.get_type_of env evd c
+      in 
+      Obligations.check_evars env evd;
+      let obls, _, c, cty = 
+	Obligations.eterm_obligations env ident evd 0 c typ
+      in
+      let ctx = Evd.evar_universe_context evd in
+	ignore(Obligations.add_definition
+          ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls)
+    else let ce = check_definition def in
+      ignore(declare_definition ident k ce imps
+        (Lemmas.mk_hook
+          (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r)))
 
 (* 2| Variable/Hypothesis/Parameter/Axiom declarations *)
 
-let declare_assumption is_coe (local,kind) c imps impl nl (_,ident) =
-  let r = match local with
-    | Local when Lib.sections_are_opened () ->
-        let _ =
-          declare_variable ident
-            (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in
-        assumption_message ident;
-        if is_verbose () & Pfedit.refining () then
-          msgerrnl (str"Warning: Variable " ++ pr_id ident ++
-          str" is not visible from current goals");
-	let r = VarRef ident in
-	  Typeclasses.declare_instance None true r; r
-    | (Global|Local) ->
-        let kn =
-          declare_constant ident 
-            (ParameterEntry (None,c,nl), IsAssumption kind) in
-	let gr = ConstRef kn in
-	  maybe_declare_manual_implicits false gr imps;
-        assumption_message ident;
-        if local=Local & Flags.is_verbose () then
-          msg_warning (pr_id ident ++ str" is declared as a parameter" ++
-          str" because it is at a global level");
-	Autoinstance.search_declaration (ConstRef kn);
-	Typeclasses.declare_instance None false gr;
-        gr 
+let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = match local with
+| Discharge when Lib.sections_are_opened () ->
+  let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in
+  let _ = declare_variable ident decl in
+  let () = assumption_message ident in
+  let () =
+    if is_verbose () && Pfedit.refining () then
+    msg_warning (str"Variable" ++ spc () ++ pr_id ident ++
+    strbrk " is not visible from current goals")
   in
-    if is_coe then Class.try_add_new_coercion r local
-
-let declare_assumptions_hook = ref ignore
-let set_declare_assumptions_hook = (:=) declare_assumptions_hook
+  let r = VarRef ident in
+  let () = Typeclasses.declare_instance None true r in
+  let () = if is_coe then Class.try_add_new_coercion r ~local:true false in
+  (r,Univ.Instance.empty,true)
+
+| Global | Local | Discharge ->
+  let local = get_locality ident local in
+  let inl = match nl with
+    | NoInline -> None
+    | DefaultInline -> Some (Flags.get_inline_level())
+    | InlineAt i -> Some i
+  in
+  let ctx = Univ.ContextSet.to_context ctx in
+  let decl = (ParameterEntry (None,p,(c,ctx),inl), IsAssumption kind) in
+  let kn = declare_constant ident ~local decl in
+  let gr = ConstRef kn in
+  let () = maybe_declare_manual_implicits false gr imps in
+  let () = assumption_message ident in
+  let () = Typeclasses.declare_instance None false gr in
+  let () = if is_coe then Class.try_add_new_coercion gr local p in
+  let inst = 
+    if p (* polymorphic *) then Univ.UContext.instance ctx 
+    else Univ.Instance.empty
+  in
+    (gr,inst,Lib.is_modtype_strict ())
 
-let interp_assumption bl c =
+let interp_assumption evdref env bl c =
   let c = prod_constr_expr c bl in
-  let env = Global.env () in
-  interp_type_evars_impls env c
+  let ty, impls = interp_type_evars_impls env evdref c in
+  let evd, nf = nf_evars_and_universes !evdref in
+  let ctx = Evd.universe_context_set evd in
+    ((nf ty, ctx), impls)
 
 let declare_assumptions idl is_coe k c imps impl_is_on nl =
-  !declare_assumptions_hook c;
-  List.iter (declare_assumption is_coe k c imps impl_is_on nl) idl
+  let refs, status =
+    List.fold_left (fun (refs,status) id ->
+      let ref',u',status' = declare_assumption is_coe k c imps impl_is_on nl id in
+      (ref',u')::refs, status' && status) ([],true) idl in
+  List.rev refs, status
+
+let do_assumptions (_, poly, _ as kind) nl l =
+  let env = Global.env () in
+  let evdref = ref (Evd.from_env env) in
+  let l = 
+    if poly then
+      (* Separate declarations so that A B : Type puts A and B in different levels. *)
+      List.fold_right (fun (is_coe,(idl,c)) acc ->
+        List.fold_right (fun id acc -> 
+	  (is_coe, ([id], c)) :: acc) idl acc)
+        l []
+    else l
+  in
+  let _,l = List.fold_map (fun env (is_coe,(idl,c)) ->
+    let (t,ctx),imps = interp_assumption evdref env [] c in
+    let env =
+      push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in
+      (env,((is_coe,idl),t,(ctx,imps)))) 
+    env l 
+  in
+  let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in
+  let l = List.map (on_pi2 (nf_evar evd)) l in
+  snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) ->
+    let t = replace_vars subst t in
+    let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) imps false nl in
+    let subst' = List.map2 
+      (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u)))
+      idl refs 
+    in
+      (subst'@subst, status' && status)) ([],true) l)
 
 (* 3a| Elimination schemes for mutual inductive definitions *)
 
 (* 3b| Mutual inductive definitions *)
 
-let push_named_types env idl tl =
-  List.fold_left2 (fun env id t -> Environ.push_named (id,None,t) env)
-    env idl tl
-
 let push_types env idl tl =
   List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env)
     env idl tl
 
 type structured_one_inductive_expr = {
-  ind_name : identifier;
+  ind_name : Id.t;
   ind_arity : constr_expr;
-  ind_lc : (identifier * constr_expr) list
+  ind_lc : (Id.t * constr_expr) list
 }
 
 type structured_inductive_expr =
   local_binder list * structured_one_inductive_expr list
 
-let minductive_message = function
+let minductive_message warn = function
   | []  -> error "No inductive definition."
-  | [x] -> (pr_id x ++ str " is defined")
+  | [x] -> (pr_id x ++ str " is defined" ++ 
+	    if warn then str " as a non-primitive record" else mt())
   | l   -> hov 0  (prlist_with_sep pr_comma pr_id l ++
 		     spc () ++ str "are defined")
 
 let check_all_names_different indl =
   let ind_names = List.map (fun ind -> ind.ind_name) indl in
-  let cstr_names = list_map_append (fun ind -> List.map fst ind.ind_lc) indl in
-  let l = list_duplicates ind_names in
-  if l <> [] then raise (InductiveError (SameNamesTypes (List.hd l)));
-  let l = list_duplicates cstr_names in
-  if l <> [] then raise (InductiveError (SameNamesConstructors (List.hd l)));
-  let l = list_intersect ind_names cstr_names in
-  if l <> [] then raise (InductiveError (SameNamesOverlap l))
+  let cstr_names = List.map_append (fun ind -> List.map fst ind.ind_lc) indl in
+  let l = List.duplicates Id.equal ind_names in
+  let () = match l with
+  | [] -> ()
+  | t :: _ -> raise (InductiveError (SameNamesTypes t))
+  in
+  let l = List.duplicates Id.equal cstr_names in
+  let () = match l with
+  | [] -> ()
+  | c :: _ -> raise (InductiveError (SameNamesConstructors (List.hd l)))
+  in
+  let l = List.intersect Id.equal ind_names cstr_names in
+  match l with
+  | [] -> ()
+  | _ -> raise (InductiveError (SameNamesOverlap l))
 
 let mk_mltype_data evdref env assums arity indname =
   let is_ml_type = is_sort env !evdref arity in
@@ -217,39 +327,176 @@ let prepare_param = function
   | (na,None,t) -> out_name na, LocalAssum t
   | (na,Some b,_) -> out_name na, LocalDef b
 
-let interp_ind_arity evdref env ind =
-  interp_type_evars_impls ~evdref env ind.ind_arity
+(** Make the arity conclusion flexible to avoid generating an upper bound universe now,
+    only if the universe does not appear anywhere else.
+    This is really a hack to stay compatible with the semantics of template polymorphic 
+    inductives which are recognized when a "Type" appears at the end of the conlusion in
+    the source syntax. *)
+    
+let rec check_anonymous_type ind =
+  let open Glob_term in
+    match ind with
+    | GSort (_, GType []) -> true
+    | GProd (_, _, _, _, e) 
+    | GLetIn (_, _, _, e)
+    | GLambda (_, _, _, _, e)
+    | GApp (_, e, _)
+    | GCast (_, e, _) -> check_anonymous_type e
+    | _ -> false
+
+let make_conclusion_flexible evdref ty poly =
+  if poly && isArity ty then
+    let _, concl = destArity ty in
+      match concl with
+      | Type u -> 
+        (match Univ.universe_level u with
+        | Some u -> 
+	  evdref := Evd.make_flexible_variable !evdref true u
+	| None -> ())
+      | _ -> ()
+  else () 
+	
+let is_impredicative env u = 
+  u = Prop Null || 
+  (engagement env = Some Declarations.ImpredicativeSet && u = Prop Pos)
+
+let interp_ind_arity env evdref ind =
+  let c = intern_gen IsType env ind.ind_arity in
+  let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
+  let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in
+  let pseudo_poly = check_anonymous_type c in
+  let () = if not (Reduction.is_arity env t) then
+    user_err_loc (constr_loc ind.ind_arity, "", str "Not an arity")
+  in
+    t, pseudo_poly, impls
 
 let interp_cstrs evdref env impls mldata arity ind =
   let cnames,ctyps = List.split ind.ind_lc in
   (* Complete conclusions of constructor types if given in ML-style syntax *)
   let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in
   (* Interpret the constructor types *)
-  let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls ~evdref env ~impls) ctyps') in
+  let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls evdref env ~impls) ctyps') in
     (cnames, ctyps'', cimpls)
 
-let interp_mutual_inductive (paramsl,indl) notations finite =
+let sign_level env evd sign =
+  fst (List.fold_right
+    (fun (_,b,t as d) (lev,env) ->
+      match b with
+      | Some _ -> (lev, push_rel d env)
+      | None ->
+	let s = destSort (Reduction.whd_betadeltaiota env 
+			    (nf_evar evd (Retyping.get_type_of env evd t)))
+	in
+	let u = univ_of_sort s in
+	  (Univ.sup u lev, push_rel d env))
+    sign (Univ.type0m_univ,env))
+
+let sup_list min = List.fold_left Univ.sup min
+
+let extract_level env evd min tys = 
+  let sorts = List.map (fun ty -> 
+    let ctx, concl = Reduction.dest_prod_assum env ty in
+      sign_level env evd ((Anonymous, None, concl) :: ctx)) tys 
+  in sup_list min sorts
+
+let inductive_levels env evdref poly arities inds =
+  let destarities = List.map (Reduction.dest_arity env) arities in
+  let levels = List.map (fun (ctx,a) -> 
+    if a = Prop Null then None
+    else Some (univ_of_sort a)) destarities
+  in
+  let cstrs_levels, min_levels, sizes = 
+    CList.split3
+      (List.map2 (fun (_,tys,_) (ctx,du) -> 
+	let len = List.length tys in
+	let minlev =
+	  if len > 1 && not (is_impredicative env du) then
+	    Univ.type0_univ
+	  else Univ.type0m_univ
+	in
+	let clev = extract_level env !evdref minlev tys in
+	  (clev, minlev, len)) inds destarities)
+  in
+  (* Take the transitive closure of the system of constructors *)
+  (* level constraints and remove the recursive dependencies *)
+  let levels' = Universes.solve_constraints_system (Array.of_list levels)
+    (Array.of_list cstrs_levels) (Array.of_list min_levels)
+  in
+  let evd =
+    CList.fold_left3 (fun evd cu (ctx,du) len ->
+      if is_impredicative env du then
+	(** Any product is allowed here. *)
+	evd
+      else (** If in a predicative sort, or asked to infer the type,
+	       we take the max of:
+	       - indices (if in indices-matter mode)
+	       - constructors
+	       - Type(1) if there is more than 1 constructor
+	   *)
+	let evd = 
+	  (** Indices contribute. *)
+	  if Indtypes.is_indices_matter () && List.length ctx > 0 then (
+	    let ilev = sign_level env !evdref ctx in
+	      Evd.set_leq_sort env evd (Type ilev) du)
+	  else evd
+	in
+        (** Constructors contribute. *)
+	let evd = 
+	  if Sorts.is_set du then
+	    if not (Evd.check_leq evd cu Univ.type0_univ) then 
+	      raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType)
+	    else evd
+	  else
+	    Evd.set_leq_sort env evd (Type cu) du
+	in
+	let evd = 
+	  if len >= 2 && Univ.is_type0m_univ cu then 
+	   (** "Polymorphic" type constraint and more than one constructor, 
+	       should not land in Prop. Add constraint only if it would
+	       land in Prop directly (no informative arguments as well). *)
+	    Evd.set_leq_sort env evd (Prop Pos) du
+	  else evd
+	in evd)
+    !evdref (Array.to_list levels') destarities sizes
+  in evdref := evd; arities
+
+let check_named (loc, na) = match na with
+| Name _ -> ()
+| Anonymous ->
+  let msg = str "Parameters must be named." in
+  user_err_loc (loc, "", msg)
+
+
+let check_param = function
+| LocalRawDef (na, _) -> check_named na
+| LocalRawAssum (nas, Default _, _) -> List.iter check_named nas
+| LocalRawAssum (nas, Generalized _, _) -> ()
+
+let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
   check_all_names_different indl;
+  List.iter check_param paramsl;
   let env0 = Global.env() in
-  let evdref = ref Evd.empty in
+  let evdref = ref Evd.(from_env env0) in
   let _, ((env_params, ctx_params), userimpls) =
-    interp_context_evars evdref env0 paramsl
+    interp_context_evars env0 evdref paramsl
   in
   let indnames = List.map (fun ind -> ind.ind_name) indl in
 
   (* Names of parameters as arguments of the inductive type (defs removed) *)
-  let assums = List.filter(fun (_,b,_) -> b=None) ctx_params in
+  let assums = List.filter(fun (_,b,_) -> Option.is_empty b) ctx_params in
   let params = List.map (fun (na,_,_) -> out_name na) assums in
 
   (* Interpret the arities *)
-  let arities = List.map (interp_ind_arity evdref env_params) indl in
-  let fullarities = List.map (fun (c, _) -> it_mkProd_or_LetIn c ctx_params) arities in
+  let arities = List.map (interp_ind_arity env_params evdref) indl in
+
+  let fullarities = List.map (fun (c, _, _) -> it_mkProd_or_LetIn c ctx_params) arities in
   let env_ar = push_types env0 indnames fullarities in
   let env_ar_params = push_rel_context ctx_params env_ar in
 
   (* Compute interpretation metadatas *)
-  let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (rel_context_nhyps ctx_params) impls) arities in
-  let arities = List.map fst arities in
+  let indimpls = List.map (fun (_, _, impls) -> userimpls @ 
+    lift_implicits (rel_context_nhyps ctx_params) impls) arities in
+  let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in
   let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in
   let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
 
@@ -258,29 +505,38 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
      (* Temporary declaration of notations and scopes *)
      List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
      (* Interpret the constructor types *)
-     list_map3 (interp_cstrs evdref env_ar_params impls) mldatas arities indl)
+     List.map3 (interp_cstrs env_ar_params evdref impls) mldatas arities indl)
      () in
 
-  (* Instantiate evars and check all are resolved *)
-  let evd = consider_remaining_unif_problems env_params !evdref in
-  let evd = Typeclasses.resolve_typeclasses ~filter:(Typeclasses.no_goals) ~fail:true env_params evd in
-  let sigma = evd in
-  let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in
-  let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in
-  let arities = List.map (nf_evar sigma) arities in
+  (* Try further to solve evars, and instantiate them *)
+  let sigma = solve_remaining_evars all_and_fail_flags env_params !evdref (Evd.empty,!evdref) in
+  evdref := sigma;
+  (* Compute renewed arities *)
+  let nf,_ = e_nf_evars_and_universes evdref in
+  let arities = List.map nf arities in
+  let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in
+  let _ = List.iter2 (fun ty poly -> make_conclusion_flexible evdref ty poly) arities aritypoly in
+  let arities = inductive_levels env_ar_params evdref poly arities constructors in
+  let nf',_ = e_nf_evars_and_universes evdref in
+  let nf x = nf' (nf x) in
+  let arities = List.map nf' arities in
+  let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in
+  let ctx_params = map_rel_context nf ctx_params in
+  let evd = !evdref in
   List.iter (check_evars env_params Evd.empty evd) arities;
-  Sign.iter_rel_context (check_evars env0 Evd.empty evd) ctx_params;
+  iter_rel_context (check_evars env0 Evd.empty evd) ctx_params;
   List.iter (fun (_,ctyps,_) ->
     List.iter (check_evars env_ar_params Evd.empty evd) ctyps)
     constructors;
 
   (* Build the inductive entries *)
-  let entries = list_map3 (fun ind arity (cnames,ctypes,cimpls) -> {
+  let entries = List.map4 (fun ind arity template (cnames,ctypes,cimpls) -> {
     mind_entry_typename = ind.ind_name;
     mind_entry_arity = arity;
+    mind_entry_template = template;
     mind_entry_consnames = cnames;
     mind_entry_lc = ctypes
-  }) indl arities constructors in
+  }) indl arities aritypoly constructors in
   let impls =
     let len = rel_context_nhyps ctx_params in
       List.map2 (fun indimpls (_,_,cimpls) ->
@@ -289,24 +545,17 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
   in
   (* Build the mutual inductive entry *)
   { mind_entry_params = List.map prepare_param ctx_params;
-    mind_entry_record = false;
+    mind_entry_record = None;
     mind_entry_finite = finite;
-    mind_entry_inds = entries },
+    mind_entry_inds = entries;
+    mind_entry_polymorphic = poly;
+    mind_entry_private = if prv then Some false else None;
+    mind_entry_universes = Evd.universe_context evd },
     impls
 
 (* Very syntactical equality *)
-let eq_local_binder d1 d2 = match d1,d2 with
-  | LocalRawAssum (nal1,k1,c1), LocalRawAssum (nal2,k2,c2) ->
-      List.length nal1 = List.length nal2 && k1 = k2 &&
-      List.for_all2 (fun (_,na1) (_,na2) -> na1 = na2) nal1 nal2 &&
-      Constrextern.is_same_type c1 c2
-  | LocalRawDef ((_,id1),c1), LocalRawDef ((_,id2),c2) ->
-      id1 = id2 && Constrextern.is_same_type c1 c2
-  | _ ->
-      false
-
 let eq_local_binders bl1 bl2 =
-  List.length bl1 = List.length bl2 && List.for_all2 eq_local_binder bl1 bl2
+  List.equal local_binder_eq bl1 bl2
 
 let extract_coercions indl =
   let mkqid (_,((_,id),_)) = qualid_of_ident id in
@@ -316,7 +565,7 @@ let extract_coercions indl =
 let extract_params indl =
   let paramsl = List.map (fun (_,params,_,_) -> params) indl in
   match paramsl with
-  | [] -> anomaly "empty list of inductive types"
+  | [] -> anomaly (Pp.str "empty list of inductive types")
   | params::paramsl ->
       if not (List.for_all (eq_local_binders params) paramsl) then error
 	"Parameters should be syntactically the same for each inductive type.";
@@ -325,7 +574,7 @@ let extract_params indl =
 let extract_inductive indl =
   List.map (fun ((_,indname),_,ar,lc) -> {
     ind_name = indname;
-    ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Glob_term.GType None)) ar;
+    ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar;
     ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc
   }) indl
 
@@ -336,43 +585,64 @@ let extract_mutual_inductive_declaration_components indl =
   let indl = extract_inductive indl in
   (params,indl), coes, List.flatten ntnl
 
-let declare_mutual_inductive_with_eliminations isrecord mie impls =
+let is_recursive mie =
+  let rec is_recursive_constructor lift typ =
+    match Term.kind_of_term typ with
+    | Prod (_,arg,rest) ->
+        Termops.dependent (mkRel lift) arg ||
+        is_recursive_constructor (lift+1) rest
+    | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest
+    | _ -> false
+  in
+  match mie.mind_entry_inds with
+  | [ind] ->
+      let nparams = List.length mie.mind_entry_params in
+      List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc
+  | _ -> false
+
+let declare_mutual_inductive_with_eliminations mie impls =
+  (* spiwack: raises an error if the structure is supposed to be non-recursive,
+        but isn't *)
+  begin match mie.mind_entry_finite with
+  | BiFinite when is_recursive mie ->
+      if Option.has_some mie.mind_entry_record then
+        error ("Records declared with the keywords Record or Structure cannot be recursive." ^
+                  "You can, however, define recursive records using the Inductive or CoInductive command.")
+      else
+        error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.")
+  | _ -> ()
+  end;
   let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in
-  let (_,kn) = declare_mind isrecord mie in
+  let (_, kn), prim = declare_mind mie in
   let mind = Global.mind_of_delta_kn kn in
-  list_iter_i (fun i (indimpls, constrimpls) ->
+  List.iteri (fun i (indimpls, constrimpls) ->
 		   let ind = (mind,i) in
-		     Autoinstance.search_declaration (IndRef ind);
 		     maybe_declare_manual_implicits false (IndRef ind) indimpls;
-		     list_iter_i
+		     List.iteri
 		       (fun j impls ->
-(*	    Autoinstance.search_declaration (ConstructRef (ind,j));*)
 			  maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls)
 		       constrimpls)
       impls;
-  if_verbose ppnl (minductive_message names);
-  declare_default_schemes mind;
+  let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in
+  if_verbose msg_info (minductive_message warn_prim names);
+  if mie.mind_entry_private == None
+  then declare_default_schemes mind;
   mind
 
-open Vernacexpr
-
 type one_inductive_impls =
   Impargs.manual_explicitation list (* for inds *)*
   Impargs.manual_explicitation list list (* for constrs *)
 
-type one_inductive_expr =
-  lident * local_binder list * constr_expr option * constructor_expr list
-
-let do_mutual_inductive indl finite =
+let do_mutual_inductive indl poly prv finite =
   let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in
   (* Interpret the types *)
-  let mie,impls = interp_mutual_inductive indl ntns finite in
+  let mie,impls = interp_mutual_inductive indl ntns poly prv finite in
   (* Declare the mutual inductive block with its associated schemes *)
-  ignore (declare_mutual_inductive_with_eliminations UserVerbose mie impls);
+  ignore (declare_mutual_inductive_with_eliminations mie impls);
   (* Declare the possible notations of inductive types *)
   List.iter Metasyntax.add_notation_interpretation ntns;
   (* Declare the coercions *)
-  List.iter (fun qid -> Class.try_add_new_coercion (locate qid) Global) coes
+  List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes
 
 (* 3c| Fixpoints and co-fixpoints *)
 
@@ -389,46 +659,47 @@ let do_mutual_inductive indl finite =
    partial_order : ('a * 'a list) list -> ('a * ('a,'a list) union) list
 *)
 
-let rec partial_order = function
+let rec partial_order cmp = function
   | [] -> []
   | (x,xge)::rest ->
     let rec browse res xge' = function
     | [] ->
 	let res = List.map (function
-	  | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge'))
+	  | (z, Inr zge) when List.mem_f cmp x zge ->
+            (z, Inr (List.union cmp zge xge'))
 	  | r -> r) res in
 	(x,Inr xge')::res
     | y::xge ->
       let rec link y =
-	try match List.assoc y res with
+	try match List.assoc_f cmp y res with
 	| Inl z -> link z
 	| Inr yge ->
-	  if List.mem x yge then
-	    let res = List.remove_assoc y res in
+	  if List.mem_f cmp x yge then
+	    let res = List.remove_assoc_f cmp y res in
 	    let res = List.map (function
 	      | (z, Inl t) ->
-		  if t = y then (z, Inl x) else (z, Inl t)
+		  if cmp t y then (z, Inl x) else (z, Inl t)
 	      | (z, Inr zge) ->
-		  if List.mem y zge then
-		    (z, Inr (list_add_set x (list_remove y zge)))
+		  if List.mem_f cmp y zge then
+		    (z, Inr (List.add_set cmp x (List.remove cmp y zge)))
 		  else
 		    (z, Inr zge)) res in
-	    browse ((y,Inl x)::res) xge' (list_union xge (list_remove x yge))
+	    browse ((y,Inl x)::res) xge' (List.union cmp xge (List.remove cmp x yge))
 	  else
-	    browse res (list_add_set y (list_union xge' yge)) xge
-	with Not_found -> browse res (list_add_set y xge') xge
+	    browse res (List.add_set cmp y (List.union cmp xge' yge)) xge
+	with Not_found -> browse res (List.add_set cmp y xge') xge
       in link y
-    in browse (partial_order rest) [] xge
+    in browse (partial_order cmp rest) [] xge
 
 let non_full_mutual_message x xge y yge isfix rest =
   let reason =
-    if List.mem x yge then
-      string_of_id y^" depends on "^string_of_id x^" but not conversely"
-    else if List.mem y xge then
-      string_of_id x^" depends on "^string_of_id y^" but not conversely"
+    if Id.List.mem x yge then
+      Id.to_string y^" depends on "^Id.to_string x^" but not conversely"
+    else if Id.List.mem y xge then
+      Id.to_string x^" depends on "^Id.to_string y^" but not conversely"
     else
-      string_of_id y^" and "^string_of_id x^" are not mutually dependent" in
-  let e = if rest <> [] then "e.g.: "^reason else reason in
+      Id.to_string y^" and "^Id.to_string x^" are not mutually dependent" in
+  let e = if List.is_empty rest then reason else "e.g.: "^reason in
   let k = if isfix then "fixpoint" else "cofixpoint" in
   let w =
     if isfix
@@ -441,52 +712,45 @@ let check_mutuality env isfix fixl =
   let names = List.map fst fixl in
   let preorder =
     List.map (fun (id,def) ->
-      (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names))
+      (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env id' def) names))
       fixl in
-  let po = partial_order preorder in
+  let po = partial_order Id.equal preorder in
   match List.filter (function (_,Inr _) -> true | _ -> false) po with
     | (x,Inr xge)::(y,Inr yge)::rest ->
-	if_warn msg_warning (non_full_mutual_message x xge y yge isfix rest)
+	msg_warning (non_full_mutual_message x xge y yge isfix rest)
     | _ -> ()
 
 type structured_fixpoint_expr = {
-  fix_name : identifier;
-  fix_annot : identifier located option;
+  fix_name : Id.t;
+  fix_annot : Id.t Loc.located option;
   fix_binders : local_binder list;
   fix_body : constr_expr option;
   fix_type : constr_expr
 }
 
-let interp_fix_context evdref env isfix fix =
+let interp_fix_context env evdref isfix fix =
   let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
-  let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in
-  let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in
+  let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in
+  let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env env' evdref after in
   let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
     ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot)
 
 let interp_fix_ccl evdref impls (env,_) fix =
-  interp_type_evars_impls ~impls ~evdref ~fail_evar:false env fix.fix_type
+  interp_type_evars_impls ~impls env evdref fix.fix_type
 
-let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
+let interp_fix_body env_rec evdref impls (_,ctx) fix ccl =
   Option.map (fun body ->
     let env = push_rel_context ctx env_rec in
-    let body = interp_casted_constr_evars evdref env ~impls body ccl in
+    let body = interp_casted_constr_evars env evdref ~impls body ccl in
     it_mkLambda_or_LetIn body ctx) fix.fix_body
 
 let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
 
-let declare_fix kind f def t imps =
-  let ce = {
-    const_entry_body = def;
-    const_entry_secctx = None;
-    const_entry_type = Some t;
-    const_entry_opaque = false }
-  in
-  let kn = declare_constant f (DefinitionEntry ce,IsDefinition kind) in
-  let gr = ConstRef kn in
-  Autoinstance.search_declaration (ConstRef kn);
-  maybe_declare_manual_implicits false gr imps;
-  gr
+let declare_fix (_,poly,_ as kind) ctx f ((def,_),eff) t imps =
+  let ce = definition_entry ~types:t ~poly ~univs:ctx ~eff def in
+  declare_definition f kind ce imps (Lemmas.mk_hook (fun _ r -> r))
+
+let _ = Obligations.declare_fix_ref := declare_fix
 
 let prepare_recursive_declaration fixnames fixtypes fixdefs =
   let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
@@ -504,27 +768,236 @@ let compute_possible_guardness_evidences (ids,_,na) =
 	 but doing it properly involves delta-reduction, and it finally
          doesn't seem to worth the effort (except for huge mutual
 	 fixpoints ?) *)
-      interval 0 (List.length ids - 1)
+      List.interval 0 (List.length ids - 1)
 
 type recursive_preentry =
-  identifier list * constr option list * types list
+  Id.t list * constr option list * types list
+
+(* Wellfounded definition *)
+
+open Coqlib
+
+let contrib_name = "Program"
+let subtac_dir = [contrib_name]
+let fixsub_module = subtac_dir @ ["Wf"]
+let tactics_module = subtac_dir @ ["Tactics"]
+
+let init_reference dir s () = Coqlib.gen_reference "Command" dir s
+let init_constant dir s () = Coqlib.gen_constant "Command" dir s
+let make_ref l s = init_reference l s
+let fix_proto = init_constant tactics_module "fix_proto"
+let fix_sub_ref = make_ref fixsub_module "Fix_sub"
+let measure_on_R_ref = make_ref fixsub_module "MR"
+let well_founded = init_constant ["Init"; "Wf"] "well_founded"
+let mkSubset name typ prop =
+  mkApp (Universes.constr_of_global (delayed_force build_sigma).typ,
+	 [| typ; mkLambda (name, typ, prop) |])
+let sigT = Lazy.lazy_from_fun build_sigma_type
+
+let make_qref s = Qualid (Loc.ghost, qualid_of_string s)
+let lt_ref = make_qref "Init.Peano.lt"
+
+let rec telescope = function
+  | [] -> assert false
+  | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
+  | (n, None, t) :: tl ->
+      let ty, tys, (k, constr) =
+	List.fold_left
+	  (fun (ty, tys, (k, constr)) (n, b, t) ->
+	    let pred = mkLambda (n, t, ty) in
+	    let ty = Universes.constr_of_global (Lazy.force sigT).typ in
+	    let intro = Universes.constr_of_global (Lazy.force sigT).intro in
+	    let sigty = mkApp (ty, [|t; pred|]) in
+	    let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in
+	      (sigty, pred :: tys, (succ k, intro)))
+	  (t, [], (2, mkRel 1)) tl
+      in
+      let (last, subst) = List.fold_right2
+	(fun pred (n, b, t) (prev, subst) ->
+	  let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in
+	  let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in
+	  let proj1 = applistc p1 [t; pred; prev] in
+	  let proj2 = applistc p2 [t; pred; prev] in
+	    (lift 1 proj2, (n, Some proj1, t) :: subst))
+	(List.rev tys) tl (mkRel 1, [])
+      in ty, ((n, Some last, t) :: subst), constr
+
+  | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in
+      ty, ((n, Some b, t) :: subst), lift 1 term
+
+let nf_evar_context sigma ctx =
+  List.map (fun (n, b, t) ->
+    (n, Option.map (Evarutil.nf_evar sigma) b, Evarutil.nf_evar sigma t)) ctx
+
+let build_wellfounded (recname,n,bl,arityc,body) r measure notation =
+  Coqlib.check_required_library ["Coq";"Program";"Wf"];
+  let env = Global.env() in
+  let evdref = ref (Evd.from_env env) in
+  let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in
+  let len = List.length binders_rel in
+  let top_env = push_rel_context binders_rel env in
+  let top_arity = interp_type_evars top_env evdref arityc in
+  let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
+  let argtyp, letbinders, make = telescope binders_rel in
+  let argname = Id.of_string "recarg" in
+  let arg = (Name argname, None, argtyp) in
+  let binders = letbinders @ [arg] in
+  let binders_env = push_rel_context binders_rel env in
+  let rel, _ = interp_constr_evars_impls env evdref r in
+  let () = check_evars_are_solved env !evdref (Evd.empty,!evdref)  in
+  let relty = Typing.type_of env !evdref rel in
+  let relargty =
+    let error () =
+      user_err_loc (constr_loc r,
+		    "Command.build_wellfounded",
+		    Printer.pr_constr_env env !evdref rel ++ str " is not an homogeneous binary relation.")
+    in
+      try
+	let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in
+	  match ctx, kind_of_term ar with
+	  | [(_, None, t); (_, None, u)], Sort (Prop Null)
+	      when Reductionops.is_conv env !evdref t u -> t
+	  | _, _ -> error ()
+      with e when Errors.noncritical e -> error ()
+  in
+  let measure = interp_casted_constr_evars binders_env evdref measure relargty in
+  let wf_rel, wf_rel_fun, measure_fn =
+    let measure_body, measure =
+      it_mkLambda_or_LetIn measure letbinders,
+      it_mkLambda_or_LetIn measure binders
+    in
+    let comb = Universes.constr_of_global (delayed_force measure_on_R_ref) in
+    let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
+    let wf_rel_fun x y =
+      mkApp (rel, [| subst1 x measure_body;
+ 		     subst1 y measure_body |])
+    in wf_rel, wf_rel_fun, measure
+  in
+  let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
+  let argid' = Id.of_string (Id.to_string argname ^ "'") in
+  let wfarg len = (Name argid', None,
+  		   mkSubset (Name argid') argtyp
+		    (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
+  in
+  let intern_bl = wfarg 1 :: [arg] in
+  let _intern_env = push_rel_context intern_bl env in
+  let proj = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1 in
+  let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
+  let projection = (* in wfarg :: arg :: before *)
+    mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
+  in
+  let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
+  let intern_arity = substl [projection] top_arity_let in
+  (* substitute the projection of wfarg for something,
+     now intern_arity is in wfarg :: arg *)
+  let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
+  let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
+  let curry_fun =
+    let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
+    let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in
+    let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
+    let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
+    let rcurry = mkApp (rel, [| measure; lift len measure |]) in
+    let lam = (Name (Id.of_string "recproof"), None, rcurry) in
+    let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
+    let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
+      (Name recname, Some body, ty)
+  in
+  let fun_bl = intern_fun_binder :: [arg] in
+  let lift_lets = Termops.lift_rel_context 1 letbinders in
+  let intern_body =
+    let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
+    let (r, l, impls, scopes) =
+      Constrintern.compute_internalization_data env
+	Constrintern.Recursive full_arity impls 
+    in
+    let newimpls = Id.Map.singleton recname
+      (r, l, impls @ [(Some (Id.of_string "recproof", Impargs.Manual, (true, false)))],
+       scopes @ [None]) in
+      interp_casted_constr_evars (push_rel_context ctx env) evdref
+        ~impls:newimpls body (lift 1 top_arity)
+  in
+  let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
+  let prop = mkLambda (Name argname, argtyp, top_arity_let) in
+  let def =
+    mkApp (Universes.constr_of_global (delayed_force fix_sub_ref),
+	  [| argtyp ; wf_rel ;
+	     Evarutil.e_new_evar env evdref
+	       ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof;
+	     prop |])
+  in
+  let def = Typing.solve_evars env evdref def in
+  let _ = evdref := Evarutil.nf_evar_map !evdref in
+  let def = mkApp (def, [|intern_body_lam|]) in
+  let binders_rel = nf_evar_context !evdref binders_rel in
+  let binders = nf_evar_context !evdref binders in
+  let top_arity = Evarutil.nf_evar !evdref top_arity in
+  let hook, recname, typ = 
+    if List.length binders_rel > 1 then
+      let name = add_suffix recname "_func" in
+      let hook l gr = 
+	let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in
+	let ty = it_mkProd_or_LetIn top_arity binders_rel in
+	let univs = Evd.universe_context !evdref in
+	  (*FIXME poly? *)
+	let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in
+	(** FIXME: include locality *)
+	let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
+	let gr = ConstRef c in
+	  if Impargs.is_implicit_args () || not (List.is_empty impls) then
+	    Impargs.declare_manual_implicits false gr [impls]
+      in
+      let typ = it_mkProd_or_LetIn top_arity binders in
+	hook, name, typ
+    else 
+      let typ = it_mkProd_or_LetIn top_arity binders_rel in
+      let hook l gr = 
+	if Impargs.is_implicit_args () || not (List.is_empty impls) then
+	  Impargs.declare_manual_implicits false gr [impls]
+      in hook, recname, typ
+  in
+  let hook = Lemmas.mk_hook hook in
+  let fullcoqc = Evarutil.nf_evar !evdref def in
+  let fullctyp = Evarutil.nf_evar !evdref typ in
+  Obligations.check_evars env !evdref;
+  let evars, _, evars_def, evars_typ = 
+    Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp 
+  in
+  let ctx = Evd.evar_universe_context !evdref in
+    ignore(Obligations.add_definition recname ~term:evars_def 
+	     evars_typ ctx evars ~hook)
 
 let interp_recursive isfix fixl notations =
   let env = Global.env() in
   let fixnames = List.map (fun fix -> fix.fix_name) fixl in
 
   (* Interp arities allowing for unresolved types *)
-  let evdref = ref Evd.empty in
+  let evdref = ref (Evd.from_env env) in
   let fixctxs, fiximppairs, fixannots =
-    list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in
+    List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in
   let fixctximpenvs, fixctximps = List.split fiximppairs in
-  let fixccls,fixcclimps = List.split (list_map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
+  let fixccls,fixcclimps = List.split (List.map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
   let fixtypes = List.map2 build_fix_type fixctxs fixccls in
   let fixtypes = List.map (nf_evar !evdref) fixtypes in
-  let fiximps = list_map3
+  let fiximps = List.map3
     (fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps))
     fixctximps fixcclimps fixctxs in
-  let env_rec = push_named_types env fixnames fixtypes in
+  let rec_sign =
+    List.fold_left2
+      (fun env' id t ->
+	 if Flags.is_program_mode () then
+	   let sort = Evarutil.evd_comb1 (Typing.e_type_of ~refresh:true env) evdref t in
+	   let fixprot =
+	     try 
+	       let app = mkApp (delayed_force fix_proto, [|sort; t|]) in
+		 Typing.solve_evars env evdref app
+	     with e  when Errors.noncritical e -> t
+	   in
+	     (id,None,fixprot) :: env'
+	 else (id,None,t) :: env')
+      [] fixnames fixtypes
+  in
+  let env_rec = push_named_context rec_sign env in
 
   (* Get interpretation metadatas *)
   let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in
@@ -533,72 +1006,99 @@ let interp_recursive isfix fixl notations =
   let fixdefs =
     Metasyntax.with_syntax_protection (fun () ->
       List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
-      list_map4
-	(fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls))
+      List.map4
+	(fun fixctximpenv -> interp_fix_body env_rec evdref (Id.Map.fold Id.Map.add fixctximpenv impls))
 	fixctximpenvs fixctxs fixl fixccls)
       () in
 
   (* Instantiate evars and check all are resolved *)
   let evd = consider_remaining_unif_problems env_rec !evdref in
-  let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in
-  let fixtypes = List.map (nf_evar evd) fixtypes in
+  let evd, nf = nf_evars_and_universes evd in
+  let fixdefs = List.map (Option.map nf) fixdefs in
+  let fixtypes = List.map nf fixtypes in
   let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in
-  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
-  List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs;
-  List.iter (check_evars env Evd.empty evd) fixtypes;
-  if not (List.mem None fixdefs) then begin
-    let fixdefs = List.map Option.get fixdefs in
-    check_mutuality env isfix (List.combine fixnames fixdefs)
-  end;
 
   (* Build the fix declaration block *)
-  (fixnames,fixdefs,fixtypes), list_combine3 fixctxnames fiximps fixannots
+  (env,rec_sign,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots
 
-let interp_fixpoint = interp_recursive true
-let interp_cofixpoint = interp_recursive false
-
-let declare_fixpoint ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
-  if List.mem None fixdefs then
+let check_recursive isfix env evd (fixnames,fixdefs,_) =
+  check_evars_are_solved env evd (Evd.empty,evd);
+  if List.for_all Option.has_some fixdefs then begin
+    let fixdefs = List.map Option.get fixdefs in
+    check_mutuality env isfix (List.combine fixnames fixdefs)
+  end
+
+let interp_fixpoint l ntns =
+  let (env,_,evd),fix,info = interp_recursive true l ntns in
+  check_recursive true env evd fix;
+  (fix,Evd.evar_universe_context evd,info)
+
+let interp_cofixpoint l ntns =
+  let (env,_,evd),fix,info = interp_recursive false l ntns in
+  check_recursive false  env evd fix;
+  fix,Evd.evar_universe_context evd,info
+    
+let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexes ntns =
+  if List.exists Option.is_empty fixdefs then
     (* Some bodies to define by proof *)
     let thms =
-      list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
+      List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
     let init_tac =
       Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
         fixdefs) in
-    Lemmas.start_proof_with_initialization (Global,DefinitionBody Fixpoint)
-      (Some(false,indexes,init_tac)) thms None (fun _ _ -> ())
+    let init_tac =
+      Option.map (List.map Proofview.V82.tactic) init_tac
+    in
+    let evd = Evd.from_env ~ctx Environ.empty_env in
+    Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint)
+      evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
   else begin
     (* We shortcut the proof process *)
     let fixdefs = List.map Option.get fixdefs in
     let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
-    let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in
+    let env = Global.env() in
+    let indexes = search_guard Loc.ghost env indexes fixdecls in
     let fiximps = List.map (fun (n,r,p) -> r) fiximps in
+    let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in
     let fixdecls =
-      list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
-    ignore (list_map4 (declare_fix Fixpoint) fixnames fixdecls fixtypes fiximps);
+      List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
+    let ctx = Evd.evar_universe_context_set ctx in
+    let ctx = Universes.restrict_universe_context ctx vars in
+    let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in
+    let ctx = Univ.ContextSet.to_context ctx in
+    ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx)
+	      fixnames fixdecls fixtypes fiximps);
     (* Declare the recursive definitions *)
     fixpoint_message (Some indexes) fixnames;
   end;
   (* Declare notations *)
   List.iter Metasyntax.add_notation_interpretation ntns
 
-let declare_cofixpoint ((fixnames,fixdefs,fixtypes),fiximps) ntns =
-  if List.mem None fixdefs then
+let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns =
+  if List.exists Option.is_empty fixdefs then
     (* Some bodies to define by proof *)
     let thms =
-      list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
+      List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
     let init_tac =
       Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
         fixdefs) in
-    Lemmas.start_proof_with_initialization (Global,DefinitionBody CoFixpoint)
-      (Some(true,[],init_tac)) thms None (fun _ _ -> ())
+    let init_tac =
+      Option.map (List.map Proofview.V82.tactic) init_tac
+    in
+    let evd = Evd.from_env ~ctx Environ.empty_env in
+    Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint)
+      evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ()))
   else begin
     (* We shortcut the proof process *)
     let fixdefs = List.map Option.get fixdefs in
     let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
-    let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
+    let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
+    let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in
     let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in
-    ignore (list_map4 (declare_fix CoFixpoint) fixnames fixdecls fixtypes fiximps);
+    let ctx = Evd.evar_universe_context_set ctx in
+    let ctx = Univ.ContextSet.to_context ctx in
+    ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) 
+	      fixnames fixdecls fixtypes fiximps);
     (* Declare the recursive definitions *)
     cofixpoint_message fixnames
   end;
@@ -624,13 +1124,91 @@ let extract_cofixpoint_components l =
     {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
   List.flatten ntnl
 
-let do_fixpoint l =
-  let fixl,ntns = extract_fixpoint_components true l in
-  let fix = interp_fixpoint fixl ntns in
-  let possible_indexes =
-    List.map compute_possible_guardness_evidences (snd fix) in
-  declare_fixpoint fix possible_indexes ntns
+let out_def = function
+  | Some def -> def
+  | None -> error "Program Fixpoint needs defined bodies."
 
-let do_cofixpoint l =
+let do_program_recursive local p fixkind fixl ntns =
+  let isfix = fixkind != Obligations.IsCoFixpoint in
+  let (env, rec_sign, evd), fix, info = 
+    interp_recursive isfix fixl ntns 
+  in
+    (* Program-specific code *)
+    (* Get the interesting evars, those that were not instanciated *)
+  let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
+    (* Solve remaining evars *)
+  let evd = nf_evar_map_undefined evd in
+  let collect_evars id def typ imps =
+    (* Generalize by the recursive prototypes  *)
+    let def =
+      nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign)
+    and typ =
+      nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign)
+    in
+    let evars, _, def, typ = 
+      Obligations.eterm_obligations env id evd
+	(List.length rec_sign) def typ
+    in (id, def, typ, imps, evars)
+  in
+  let (fixnames,fixdefs,fixtypes) = fix in
+  let fiximps = List.map pi2 info in
+  let fixdefs = List.map out_def fixdefs in
+  let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in
+  let () = if isfix then begin
+      let possible_indexes = List.map compute_possible_guardness_evidences info in
+      let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
+	Array.of_list fixtypes,
+	Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
+      in
+      let indexes = 
+	Pretyping.search_guard Loc.ghost (Global.env ()) possible_indexes fixdecls in
+	List.iteri (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) fixl
+  end in
+  let ctx = Evd.evar_universe_context evd in
+  let kind = match fixkind with
+  | Obligations.IsFixpoint _ -> (local, p, Fixpoint)
+  | Obligations.IsCoFixpoint -> (local, p, CoFixpoint)
+  in
+  Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind
+
+let do_program_fixpoint local poly l =
+  let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
+    match g, l with
+    | [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+	let recarg = 
+	  match n with
+	  | Some n -> mkIdentC (snd n)
+	  | None ->
+	      errorlabstrm "do_program_fixpoint"
+		(str "Recursive argument required for well-founded fixpoints")
+	in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn
+	     
+    | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] ->
+	build_wellfounded (id, n, bl, typ, out_def def)
+	  (Option.default (CRef (lt_ref,None)) r) m ntn
+	  
+    | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g ->
+	let fixl,ntns = extract_fixpoint_components true l in
+	let fixkind = Obligations.IsFixpoint g in
+	  do_program_recursive local poly fixkind fixl ntns
+
+    | _, _ ->
+	errorlabstrm "do_program_fixpoint"
+	  (str "Well-founded fixpoints not allowed in mutually recursive blocks")
+
+let do_fixpoint local poly l =
+  if Flags.is_program_mode () then do_program_fixpoint local poly l
+  else
+    let fixl, ntns = extract_fixpoint_components true l in
+    let fix = interp_fixpoint fixl ntns in
+    let possible_indexes =
+      List.map compute_possible_guardness_evidences (pi3 fix) in
+    declare_fixpoint local poly fix possible_indexes ntns
+
+let do_cofixpoint local poly l =
   let fixl,ntns = extract_cofixpoint_components l in
-  declare_cofixpoint (interp_cofixpoint fixl ntns) ntns
+    if Flags.is_program_mode () then
+      do_program_recursive local poly Obligations.IsCoFixpoint fixl ntns
+    else
+      let cofix = interp_cofixpoint fixl ntns in
+	declare_cofixpoint local poly cofix ntns
diff --git a/toplevel/command.mli b/toplevel/command.mli
index 456026bf..894333ad 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -1,54 +1,68 @@
 (************************************************************************)
 (*  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 Util
 open Names
 open Term
 open Entries
 open Libnames
+open Globnames
 open Tacexpr
 open Vernacexpr
-open Topconstr
+open Constrexpr
 open Decl_kinds
 open Redexpr
-open Constrintern
 open Pfedit
 
 (** This file is about the interpretation of raw commands into typed
     ones and top-level declaration of the main Gallina objects *)
 
+val do_universe : Id.t Loc.located list -> unit
+val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit
+
 (** {6 Hooks for Pcoq} *)
 
 val set_declare_definition_hook : (definition_entry -> unit) -> unit
 val get_declare_definition_hook : unit -> (definition_entry -> unit)
-val set_declare_assumptions_hook : (types -> unit) -> unit
 
 (** {6 Definitions/Let} *)
 
 val interp_definition :
-  local_binder list -> red_expr option -> constr_expr ->
-  constr_expr option -> definition_entry * Impargs.manual_implicits
+  local_binder list -> polymorphic -> red_expr option -> constr_expr ->
+  constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits
 
-val declare_definition : identifier -> locality * definition_object_kind ->
-  definition_entry -> Impargs.manual_implicits -> declaration_hook -> unit
+val declare_definition : Id.t -> definition_kind ->
+  definition_entry -> Impargs.manual_implicits ->
+    Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference
+
+val do_definition : Id.t -> definition_kind ->
+  local_binder list -> red_expr option -> constr_expr ->
+  constr_expr option -> unit Lemmas.declaration_hook -> unit
 
 (** {6 Parameters/Assumptions} *)
 
-val interp_assumption :
-  local_binder list -> constr_expr -> types * Impargs.manual_implicits
+(* val interp_assumption : env -> evar_map ref -> *)
+(*   local_binder list -> constr_expr ->  *)
+(*   types Univ.in_universe_context_set * Impargs.manual_implicits *)
 
-val declare_assumption : coercion_flag -> assumption_kind -> types ->
+(** returns [false] if the assumption is neither local to a section,
+    nor in a module type and meant to be instantiated. *)
+val declare_assumption : coercion_flag -> assumption_kind -> 
+  types Univ.in_universe_context_set ->
   Impargs.manual_implicits ->
-  bool (** implicit *) -> Entries.inline -> variable located -> unit
+  bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located ->
+  global_reference * Univ.Instance.t * bool
+
+val do_assumptions : locality * polymorphic * assumption_object_kind ->
+  Vernacexpr.inline -> simple_binder with_coercion list -> bool
 
-val declare_assumptions : variable located list ->
-  coercion_flag -> assumption_kind -> types -> Impargs.manual_implicits ->
-  bool -> Entries.inline -> unit
+(* val declare_assumptions : variable Loc.located list -> *)
+(*   coercion_flag -> assumption_kind -> types Univ.in_universe_context_set ->  *)
+(*   Impargs.manual_implicits -> bool -> Vernacexpr.inline -> bool *)
 
 (** {6 Inductive and coinductive types} *)
 
@@ -56,9 +70,9 @@ val declare_assumptions : variable located list ->
    inductive declarations *)
 
 type structured_one_inductive_expr = {
-  ind_name : identifier;
+  ind_name : Id.t;
   ind_arity : constr_expr;
-  ind_lc : (identifier * constr_expr) list
+  ind_lc : (Id.t * constr_expr) list
 }
 
 type structured_inductive_expr =
@@ -75,26 +89,28 @@ type one_inductive_impls =
   Impargs.manual_implicits list (** for constrs *)
 
 val interp_mutual_inductive :
-  structured_inductive_expr -> decl_notation list -> bool ->
+  structured_inductive_expr -> decl_notation list -> polymorphic ->
+    private_flag -> Decl_kinds.recursivity_kind ->
     mutual_inductive_entry * one_inductive_impls list
 
 (** Registering a mutual inductive definition together with its
    associated schemes *)
 
 val declare_mutual_inductive_with_eliminations :
-  Declare.internal_flag -> mutual_inductive_entry -> one_inductive_impls list ->
+  mutual_inductive_entry -> one_inductive_impls list ->
   mutual_inductive
 
 (** Entry points for the vernacular commands Inductive and CoInductive *)
 
 val do_mutual_inductive :
-  (one_inductive_expr * decl_notation list) list -> bool -> unit
+  (one_inductive_expr * decl_notation list) list -> polymorphic -> 
+  private_flag -> Decl_kinds.recursivity_kind -> unit
 
 (** {6 Fixpoints and cofixpoints} *)
 
 type structured_fixpoint_expr = {
-  fix_name : identifier;
-  fix_annot : identifier located option;
+  fix_name : Id.t;
+  fix_annot : Id.t Loc.located option;
   fix_binders : local_binder list;
   fix_body : constr_expr option;
   fix_type : constr_expr
@@ -114,37 +130,42 @@ val extract_cofixpoint_components :
 (** Typing global fixpoints and cofixpoint_expr *)
 
 type recursive_preentry =
-  identifier list * constr option list * types list
+  Id.t list * constr option list * types list
 
 val interp_fixpoint :
   structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * (name list * Impargs.manual_implicits * int option) list
+    recursive_preentry * Evd.evar_universe_context * 
+    (Name.t list * Impargs.manual_implicits * int option) list
 
 val interp_cofixpoint :
   structured_fixpoint_expr list -> decl_notation list ->
-    recursive_preentry * (name list * Impargs.manual_implicits * int option) list
+    recursive_preentry * Evd.evar_universe_context * 
+    (Name.t list * Impargs.manual_implicits * int option) list
 
 (** Registering fixpoints and cofixpoints in the environment *)
 
 val declare_fixpoint :
-  recursive_preentry * (name list * Impargs.manual_implicits * int option) list ->
+  locality -> polymorphic ->
+  recursive_preentry * Evd.evar_universe_context * 
+  (Name.t list * Impargs.manual_implicits * int option) list ->
   lemma_possible_guards -> decl_notation list -> unit
 
-val declare_cofixpoint :
-  recursive_preentry * (name list * Impargs.manual_implicits * int option) list ->
-    decl_notation list -> unit
+val declare_cofixpoint : locality -> polymorphic -> 
+  recursive_preentry * Evd.evar_universe_context * 
+  (Name.t list * Impargs.manual_implicits * int option) list ->
+  decl_notation list -> unit
 
 (** Entry points for the vernacular commands Fixpoint and CoFixpoint *)
 
 val do_fixpoint :
-  (fixpoint_expr * decl_notation list) list -> unit
+  locality -> polymorphic -> (fixpoint_expr * decl_notation list) list -> unit
 
 val do_cofixpoint :
-  (cofixpoint_expr * decl_notation list) list -> unit
+  locality -> polymorphic -> (cofixpoint_expr * decl_notation list) list -> unit
 
 (** Utils *)
 
-val check_mutuality : Environ.env -> bool -> (identifier * types) list -> unit
+val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit
 
-val declare_fix : definition_object_kind -> identifier ->
-  constr -> types -> Impargs.manual_implicits -> global_reference
+val declare_fix : definition_kind -> Univ.universe_context -> Id.t ->
+  Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 0b83bbb8..03074ced 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -1,18 +1,19 @@
 (************************************************************************)
 (*  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 Util
 open Pp
-open System
-open Toplevel
 
-let (/) s1 s2 = s1 ^ "/" ^ s2
+let ( / ) s1 s2 = s1 ^ "/" ^ s2
 
-let set_debug () = Flags.debug := true
+let set_debug () =
+  let () = Backtrace.record_backtrace true in
+  Flags.debug := true
 
 (* Loading of the ressource file.
    rcfile is either $XDG_CONFIG_HOME/.coqrc.VERSION, or $XDG_CONFIG_HOME/.coqrc if the first one
@@ -30,16 +31,19 @@ let load_rcfile() =
   if !load_rc then
     try
       if !rcfile_specified then
-        if file_readable_p !rcfile then
+        if CUnix.file_readable_p !rcfile then
           Vernac.load_vernac false !rcfile
         else raise (Sys_error ("Cannot read rcfile: "^ !rcfile))
-      else try let inferedrc = List.find file_readable_p [
-	Envars.xdg_config_home/rcdefaultname^"."^Coq_config.version;
-	Envars.xdg_config_home/rcdefaultname;
-	System.home/"."^rcdefaultname^"."^Coq_config.version;
-	System.home/"."^rcdefaultname;
-      ] in
-        Vernac.load_vernac false inferedrc
+      else
+	try
+	  let warn x = msg_warning (str x) in
+	  let inferedrc = List.find CUnix.file_readable_p [
+	    Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version;
+	    Envars.xdg_config_home warn / rcdefaultname;
+	    Envars.home ~warn / "."^rcdefaultname^"."^Coq_config.version;
+	    Envars.home ~warn / "."^rcdefaultname
+	  ] in
+          Vernac.load_vernac false inferedrc
 	with Not_found -> ()
 	(*
 	Flags.if_verbose
@@ -47,79 +51,74 @@ let load_rcfile() =
 			 " found. Skipping rcfile loading."))
 	*)
     with reraise ->
-      (msgnl (str"Load of rcfile failed.");
-       raise reraise)
+      let reraise = Errors.push reraise in
+      let () = msg_info (str"Load of rcfile failed.") in
+      iraise reraise
   else
-    Flags.if_verbose msgnl (str"Skipping rcfile loading.")
+    Flags.if_verbose msg_info (str"Skipping rcfile loading.")
 
 (* Puts dir in the path of ML and in the LoadPath *)
 let coq_add_path unix_path s =
-  Mltop.add_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root;Names.id_of_string s])
-let coq_add_rec_path unix_path = Mltop.add_rec_path ~unix_path ~coq_root:(Names.make_dirpath [Nameops.coq_root])
+  Mltop.add_path ~unix_path ~coq_root:(Names.DirPath.make [Nameops.coq_root;Names.Id.of_string s]) ~implicit:true;
+  Mltop.add_ml_dir unix_path
 
-(* By the option -include -I or -R of the command line *)
-let includes = ref []
-let push_include (s, alias) = includes := (s,alias,false) :: !includes
-let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes
+(* Recursively puts dir in the LoadPath if -nois was not passed *)
+let add_stdlib_path ~unix_path ~coq_root ~with_ml =
+  if !Flags.load_init then
+    Mltop.add_rec_path ~unix_path ~coq_root ~implicit:true
+  else
+    Mltop.add_path ~unix_path ~coq_root ~implicit:false;
+  if with_ml then
+    Mltop.add_rec_ml_dir unix_path
 
-(* The list of all theories in the standard library /!\ order does matter *)
-let theories_dirs_map = [
-    "theories/Unicode", "Unicode" ;
-    "theories/Classes", "Classes" ;
-    "theories/Program", "Program" ;
-    "theories/MSets", "MSets" ;
-    "theories/FSets", "FSets" ;
-    "theories/Reals", "Reals" ;
-    "theories/Strings", "Strings" ;
-    "theories/Sorting", "Sorting" ;
-    "theories/Setoids", "Setoids" ;
-    "theories/Sets", "Sets" ;
-    "theories/Structures", "Structures" ;
-    "theories/Lists", "Lists" ;
-    "theories/Vectors", "Vectors" ;
-    "theories/Wellfounded", "Wellfounded" ;
-    "theories/Relations", "Relations" ;
-    "theories/Numbers", "Numbers" ;
-    "theories/QArith", "QArith" ;
-    "theories/PArith", "PArith" ;
-    "theories/NArith", "NArith" ;
-    "theories/ZArith", "ZArith" ;
-    "theories/Arith", "Arith" ;
-    "theories/Bool", "Bool" ;
-    "theories/Logic", "Logic" ;
-    "theories/Init", "Init"
-  ]
+let add_userlib_path ~unix_path =
+  Mltop.add_path ~unix_path ~coq_root:Nameops.default_root_prefix ~implicit:false;
+  Mltop.add_rec_ml_dir unix_path
+
+(* Options -I, -I-as, and -R of the command line *)
+let includes = ref []
+let push_include s alias recursive implicit =
+  includes := (s,alias,recursive,implicit) :: !includes
+let ml_includes = ref []
+let push_ml_include s = ml_includes := s :: !ml_includes
 
 (* Initializes the LoadPath *)
 let init_load_path () =
   let coqlib = Envars.coqlib () in
   let user_contrib = coqlib/"user-contrib" in
-  let xdg_dirs = Envars.xdg_dirs in
+  let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> msg_warning (str x)) in
   let coqpath = Envars.coqpath in
-  let dirs = ["states";"plugins"] in
+  let coq_root = Names.DirPath.make [Nameops.coq_root] in
     (* NOTE: These directories are searched from last to first *)
     (* first, developer specific directory to open *)
     if Coq_config.local then coq_add_path (coqlib/"dev") "dev";
+    (* main loops *)
+    if Coq_config.local || !Flags.boot then begin
+      let () = Mltop.add_ml_dir (coqlib/"stm") in
+      Mltop.add_ml_dir (coqlib/"ide")
+    end;
+    Mltop.add_ml_dir (coqlib/"toploop");
     (* then standard library *)
-    List.iter
-      (fun (s,alias) -> Mltop.add_rec_path ~unix_path:(coqlib/s) ~coq_root:(Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root]))
-      theories_dirs_map;
-    (* then states and plugins *)
-    List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs;
+    add_stdlib_path ~unix_path:(coqlib/"theories") ~coq_root ~with_ml:false;
+    (* then plugins *)
+    add_stdlib_path ~unix_path:(coqlib/"plugins") ~coq_root ~with_ml:true;
     (* then user-contrib *)
     if Sys.file_exists user_contrib then
-      Mltop.add_rec_path ~unix_path:user_contrib ~coq_root:Nameops.default_root_prefix;
+      add_userlib_path ~unix_path:user_contrib;
     (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *)
-    List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) xdg_dirs;
+    List.iter (fun s -> add_userlib_path ~unix_path:s) xdg_dirs;
     (* then directories in COQPATH *)
-    List.iter (fun s -> Mltop.add_rec_path ~unix_path:s ~coq_root:Nameops.default_root_prefix) coqpath;
+    List.iter (fun s -> add_userlib_path ~unix_path:s) coqpath;
     (* then current directory *)
-    Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix;
-    (* additional loadpath, given with -I -include -R options *)
+    Mltop.add_path ~unix_path:"." ~coq_root:Nameops.default_root_prefix ~implicit:false;
+    (* additional loadpath, given with options -I-as, -Q, and -R *)
     List.iter
-      (fun (unix_path, coq_root, reci) ->
-	if reci then Mltop.add_rec_path ~unix_path ~coq_root else Mltop.add_path ~unix_path ~coq_root)
-      (List.rev !includes)
+      (fun (unix_path, coq_root, reci, implicit) ->
+        (if reci then Mltop.add_rec_path else Mltop.add_path)
+          ~unix_path ~coq_root ~implicit)
+      (List.rev !includes);
+    (* additional ml directories, given with option -I *)
+    List.iter Mltop.add_ml_dir (List.rev !ml_includes)
 
 let init_library_roots () =
   includes := []
@@ -134,12 +133,14 @@ let init_ocaml_path () =
     List.iter add_subdir
       [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ];
 	[ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ];
-	[ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ]
+	[ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ];
+        [ "grammar" ]; [ "ide" ] ]
 
 let get_compat_version = function
+  | "8.4" -> Flags.V8_4
   | "8.3" -> Flags.V8_3
   | "8.2" -> Flags.V8_2
   | ("8.1" | "8.0") as s ->
-    msg_warn ("Compatibility with version "^s^" not supported.");
+    msg_warning (strbrk ("Compatibility with version "^s^" not supported."));
     Flags.V8_2
-  | s -> Util.error ("Unknown compatibility version \""^s^"\".")
+  | s -> Errors.error ("Unknown compatibility version \""^s^"\".")
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index d9484443..5f7133c3 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.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        *)
@@ -15,8 +15,10 @@ val set_rcfile : string -> unit
 val no_load_rc : unit -> unit
 val load_rcfile : unit -> unit
 
-val push_include : string * Names.dir_path -> unit
-val push_rec_include : string * Names.dir_path -> unit
+val push_include : string -> Names.DirPath.t -> bool -> bool -> unit
+(** [push_include phys_path log_path recursive implicit] *)
+
+val push_ml_include : string -> unit
 
 val init_load_path : unit -> unit
 val init_library_roots : unit -> unit
diff --git a/toplevel/toplevel.ml b/toplevel/coqloop.ml
index d38b1f78..52fa9e01 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/coqloop.ml
@@ -1,19 +1,17 @@
 (************************************************************************)
 (*  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 Flags
-open Cerrors
 open Vernac
-open Vernacexpr
 open Pcoq
-open Compat
 
 (* A buffer for the character read from a channel. We store the command
  * entered to be able to report errors without pretty-printing. *)
@@ -22,7 +20,7 @@ type input_buffer = {
   mutable prompt : unit -> string;
   mutable str : string; (* buffer of already read characters *)
   mutable len : int;    (* number of chars in the buffer *)
-  mutable bols : int list; (* offsets in str of begining of lines *)
+  mutable bols : int list; (* offsets in str of beginning of lines *)
   mutable tokens : Gram.parsable; (* stream of tokens *)
   mutable start : int } (* stream count of the first char of the buffer *)
 
@@ -33,7 +31,7 @@ let resize_buffer ibuf =
   String.blit ibuf.str 0 nstr 0 (String.length ibuf.str);
   ibuf.str <- nstr
 
-(* Delete all irrelevent lines of the input buffer. Keep the last line
+(* Delete all irrelevant lines of the input buffer. Keep the last line
    in the buffer (useful when there are several commands on the same line. *)
 
 let resynch_buffer ibuf =
@@ -58,8 +56,8 @@ let emacs_prompt_endstring() = Printer.emacs_str "</prompt>"
    beginning of line. *)
 let prompt_char ic ibuf count =
   let bol = match ibuf.bols with
-    | ll::_ -> ibuf.len == ll
-    | [] -> ibuf.len == 0
+    | ll::_ -> Int.equal ibuf.len ll
+    | [] -> Int.equal ibuf.len 0
   in
   if bol && not !print_emacs then msgerr (str (ibuf.prompt()));
   try
@@ -88,7 +86,7 @@ let reset_input_buffer ic ibuf =
 
 let get_bols_of_loc ibuf (bp,ep) =
   let add_line (b,e) lines =
-    if b < 0 or e < b then anomaly "Bad location";
+    if b < 0 || e < b then anomaly (Pp.str "Bad location");
     match lines with
       | ([],None) -> ([], Some (b,e))
       | (fl,oe) -> ((b,e)::fl, oe)
@@ -118,13 +116,13 @@ let blanch_utf8_string s bp ep =
     fixed-size char and therefore contract all utf-8 code into one
     space; in any case, preserve tabulation so
     that its effective interpretation in terms of spacing is preserved *)
-    if s.[i] = '\t' then s'.[!j] <- '\t';
+    if s.[i] == '\t' then s'.[!j] <- '\t';
     if n < 0x80 || 0xC0 <= n then incr j
   done;
   String.sub s' 0 !j
 
 let print_highlight_location ib loc =
-  let (bp,ep) = unloc loc in
+  let (bp,ep) = Loc.unloc loc in
   let bp = bp - ib.start
   and ep = ep - ib.start in
   let highlight_lines =
@@ -146,68 +144,55 @@ let print_highlight_location ib loc =
                       str sn ++ str dn) in
 	  (l1 ++ li ++ ln)
   in
-  let loc = make_loc (bp,ep) in
+  let loc = Loc.make_loc (bp,ep) in
   (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++
      highlight_lines ++ fnl ())
 
 (* Functions to report located errors in a file. *)
 
-let print_location_in_file s inlibrary fname loc =
+let print_location_in_file {outer=s;inner=fname} loc =
   let errstrm = str"Error while reading " ++ str s in
-  if loc = dummy_loc then
+  if Loc.is_ghost loc then
     hov 1 (errstrm ++ spc() ++ str" (unknown location):") ++ fnl ()
   else
     let errstrm =
-      if s = fname then mt() else errstrm ++ str":" ++ fnl() in
-    if inlibrary then
-      hov 0 (errstrm ++ str"Module " ++ str ("\""^fname^"\"") ++ spc() ++
-             str"characters " ++ Cerrors.print_loc loc) ++ fnl ()
-    else
-      let (bp,ep) = unloc loc in
-      let ic = open_in fname in
-      let rec line_of_pos lin bol cnt =
-        if cnt < bp then
-          if input_char ic == '\n'
-          then line_of_pos (lin + 1) (cnt +1) (cnt+1)
-          else line_of_pos lin bol (cnt+1)
-        else (lin, bol)
-      in
+      if String.equal s fname then mt() else errstrm ++ str":" ++ fnl()
+    in
+    let (bp,ep) = Loc.unloc loc in
+    let line_of_pos lin bol cnt =
       try
-        let (line, bol) = line_of_pos 1 0 0 in
+        let ic = open_in fname in
+        let rec line_of_pos lin bol cnt =
+          if cnt < bp then
+            if input_char ic == '\n'
+            then line_of_pos (lin + 1) (cnt +1) (cnt+1)
+            else line_of_pos lin bol (cnt+1)
+          else (lin, bol)
+        in
+        let rc = line_of_pos lin bol cnt in
         close_in ic;
-        hov 0 (* No line break so as to follow emacs error message format *)
-          (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++
+        rc
+      with Sys_error _ -> 0, 0 in
+    try
+      let (line, bol) = line_of_pos 1 0 0 in
+      hov 0 (* No line break so as to follow emacs error message format *)
+        (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++
            str", line " ++ int line ++ str", characters " ++
-           Cerrors.print_loc (make_loc (bp-bol,ep-bol))) ++ str":" ++
+           Cerrors.print_loc (Loc.make_loc (bp-bol,ep-bol))) ++ str":" ++
         fnl ()
-      with e when Errors.noncritical e ->
-        (close_in ic;
-         hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ())
-
-let print_command_location ib dloc =
-  match dloc with
-    | Some (bp,ep) ->
-        (str"Error during interpretation of command:" ++ fnl () ++
-           str(String.sub ib.str (bp-ib.start) (ep-bp)) ++ fnl ())
-    | None -> (mt ())
-
-let valid_loc dloc loc =
-  loc <> dummy_loc
-  & match dloc with
-    | Some dloc ->
-	let (bd,ed) = unloc dloc in let (b,e) = unloc loc in bd<=b & e<=ed
-    | _ -> true
-
-let valid_buffer_loc ib dloc loc =
-  valid_loc dloc loc &
-  let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e
+    with e when Errors.noncritical e ->
+       hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()
+
+let valid_buffer_loc ib loc =
+  not (Loc.is_ghost loc) &&
+  let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e
 
 (*s The Coq prompt is the name of the focused proof, if any, and "Coq"
     otherwise. We trap all exceptions to prevent the error message printing
     from cycling. *)
 let make_prompt () =
   try
-    (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < "
+    (Names.Id.to_string (Pfedit.get_current_proof_name ())) ^ " < "
   with Proof_global.NoCurrentProof ->
     "Coq < "
 
@@ -216,7 +201,7 @@ let make_prompt () =
   let l' = ref l in
   let res =
     while List.length !l' > 1 do
-      pl := !pl ^ "|" Names.string_of_id x;
+      pl := !pl ^ "|" Names.Id.to_string x;
       l':=List.tl !l'
     done in
   let last = try List.hd !l' with _ ->   in
@@ -232,12 +217,12 @@ let make_prompt () =
    "n |lem1|lem2|lem3| p < "
 *)
 let make_emacs_prompt() =
-  let statnum = string_of_int (Lib.current_command_label ()) in
-  let dpth = Pfedit.current_proof_depth() in
-  let pending = Pfedit.get_all_proof_names() in
+  let statnum = Stateid.to_string (Stm.get_current_state ()) in
+  let dpth = Stm.current_proof_depth() in
+  let pending = Stm.get_all_proof_names() in
   let pendingprompt =
     List.fold_left
-      (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x)
+      (fun acc x -> acc ^ (if String.is_empty acc then "" else "|") ^ Names.Id.to_string x)
       "" pending in
   let proof_info = if dpth >= 0 then string_of_int dpth else "0" in
   if !Flags.print_emacs then statnum ^ " |" ^ pendingprompt ^ "| " ^ proof_info ^ " < "
@@ -267,113 +252,109 @@ let set_prompt prompt =
     ^ prompt ()
     ^ emacs_prompt_endstring())
 
-(* Removes and prints the location of the error. The following exceptions
-   need not be located. *)
-let rec is_pervasive_exn = function
-  | Out_of_memory | Stack_overflow | Sys.Break -> true
-  | Error_in_file (_,_,e) -> is_pervasive_exn e
-  | Loc.Exc_located (_,e) -> is_pervasive_exn e
-  | DuringCommandInterp (_,e) -> is_pervasive_exn e
-  | _ -> false
-
-(* Toplevel error explanation, dealing with locations, Drop, Ctrl-D
-   May raise only the following exceptions: Drop and End_of_input,
-   meaning we get out of the Coq loop *)
-let print_toplevel_error exc =
-  let (dloc,exc) =
-    match exc with
-      | DuringCommandInterp (loc,ie) ->
-          if loc = dummy_loc then (None,ie) else (Some loc, ie)
-      | _ -> (None, exc)
-  in
-  let (locstrm,exc) =
-    match exc with
-      | Loc.Exc_located (loc, ie) ->
-          if valid_buffer_loc top_buffer dloc loc then
-            (print_highlight_location top_buffer loc, ie)
-          else
-	    ((mt ()) (* print_command_location top_buffer dloc *), ie)
-      | Error_in_file (s, (inlibrary, fname, loc), ie) ->
-          (print_location_in_file s inlibrary fname loc, ie)
-      | _ ->
-	  ((mt ()) (* print_command_location top_buffer dloc *), exc)
+(* The following exceptions need not be located. *)
+
+let locate_exn = function
+  | Out_of_memory | Stack_overflow | Sys.Break -> false
+  | _ -> true
+
+(* Toplevel error explanation. *)
+
+let print_toplevel_error (e, info) =
+  let loc = Option.default Loc.ghost (Loc.get_loc info) in
+  let locmsg = match Vernac.get_exn_files info with
+    | Some files -> print_location_in_file files loc
+    | None ->
+      if locate_exn e && valid_buffer_loc top_buffer loc then
+        print_highlight_location top_buffer loc
+      else mt ()
   in
-  match exc with
-    | End_of_input ->
-	msgerrnl (mt ()); pp_flush(); exit 0
-    | Vernacexpr.Drop ->  (* Last chance *)
-        if Mltop.is_ocaml_top() then raise Vernacexpr.Drop;
-        (str"Error: There is no ML toplevel." ++ fnl ())
-    | Vernacexpr.Quit ->
-	raise Vernacexpr.Quit
-    | _ ->
-	(if is_pervasive_exn exc then (mt ()) else locstrm) ++
-        Errors.print exc
+  locmsg ++ Errors.iprint (e, info)
 
 (* Read the input stream until a dot is encountered *)
 let parse_to_dot =
-  let rec dot st = match get_tok (Stream.next st) with
-    | Tok.KEYWORD "." -> ()
+  let rec dot st = match Compat.get_tok (Stream.next st) with
+    | Tok.KEYWORD ("."|"...") -> ()
     | Tok.EOI -> raise End_of_input
     | _ -> dot st
   in
   Gram.Entry.of_parser "Coqtoplevel.dot" dot
 
-(* We assume that when a lexer error occurs, at least one char was eaten *)
+(* If an error occurred while parsing, we try to read the input until a dot
+   token is encountered.
+   We assume that when a lexer error occurs, at least one char was eaten *)
+
 let rec discard_to_dot () =
   try
     Gram.entry_parse parse_to_dot top_buffer.tokens
-  with Loc.Exc_located(_,(Token.Error _|Lexer.Error.E _)) ->
-    discard_to_dot()
-
-
-(* If the error occured while parsing, we read the input until a dot token
- * in encountered. *)
-
-let process_error = function
-  | DuringCommandInterp _ as e -> e
-  | e ->
-      if is_pervasive_exn e then
-	e
-      else
-        try
-	  discard_to_dot (); e
-	with
-          | End_of_input -> End_of_input
-          | any -> if is_pervasive_exn any then any else e
-
-(* do_vernac reads and executes a toplevel phrase, and print error
-   messages when an exception is raised, except for the following:
-     Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
+  with
+    | Compat.Token.Error _ | Lexer.Error.E _ -> discard_to_dot ()
+    | End_of_input -> raise End_of_input
+    | e when Errors.noncritical e -> ()
+
+let read_sentence () =
+  try Vernac.parse_sentence (top_buffer.tokens, None)
+  with reraise ->
+    let reraise = Errors.push reraise in
+    discard_to_dot ();
+    iraise reraise
+
+(** [do_vernac] reads and executes a toplevel phrase, and print error
+    messages when an exception is raised, except for the following:
+    - Drop: kill the Coq toplevel, going down to the Caml toplevel if it exists.
            Otherwise, exit.
-     End_of_input: Ctrl-D was typed in, we will quit *)
+    - End_of_input: Ctrl-D was typed in, we will quit.
+
+    In particular, this is normally the only place where a Sys.Break
+    is caught and handled (i.e. not re-raised).
+*)
+
 let do_vernac () =
   msgerrnl (mt ());
   if !print_emacs then msgerr (str (top_buffer.prompt()));
   resynch_buffer top_buffer;
-  begin
-    try
-      raw_do_vernac top_buffer.tokens
-    with any ->
-      msgnl (print_toplevel_error (process_error any))
-  end;
-  flush_all()
-
-(* coq and go read vernacular expressions until Drop is entered.
- * Ctrl-C will raise the exception Break instead of aborting Coq.
- * Here we catch the exceptions terminating the Coq loop, and decide
- * if we really must quit.
- *)
+  try
+    Vernac.eval_expr (read_sentence ())
+  with
+    | End_of_input | Errors.Quit ->
+        msgerrnl (mt ()); pp_flush(); raise Errors.Quit
+    | Errors.Drop ->  (* Last chance *)
+        if Mltop.is_ocaml_top() then raise Errors.Drop
+        else ppnl (str"Error: There is no ML toplevel." ++ fnl ())
+    | any ->
+        let any = Errors.push any in
+        Format.set_formatter_out_channel stdout;
+        let msg = print_toplevel_error any ++ fnl () in
+        pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg;
+        pp_flush ()
+
+(** Main coq loop : read vernacular expressions until Drop is entered.
+    Ctrl-C is handled internally as Sys.Break instead of aborting Coq.
+    Normally, the only exceptions that can come out of [do_vernac] and
+    exit the loop are Drop and Quit. Any other exception there indicates
+    an issue with [print_toplevel_error] above. *)
+
+(*
+let feed_emacs = function
+  | { Interface.id = Interface.State id;
+      Interface.content = Interface.GlobRef (_,a,_,c,_) }  -> 
+    prerr_endline ("<info>" ^"<id>"^Stateid.to_string id ^"</id>"
+		   ^a^" "^c^ "</info>")
+  | _  -> ()
+*)
 
 let rec loop () =
   Sys.catch_break true;
+  if !Flags.print_emacs then Vernacentries.qed_display_script := false;
+  Flags.coqtop_ui := true;
   try
     reset_input_buffer stdin top_buffer;
-    while true do do_vernac() done
+    while true do do_vernac(); flush_all() done
   with
-    | Vernacexpr.Drop -> ()
-    | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0
-    | Vernacexpr.Quit -> exit 0
+    | Errors.Drop -> ()
+    | Errors.Quit -> exit 0
     | any ->
-	msgerrnl (str"Anomaly. Please report.");
-	loop ()
+      msgerrnl (str"Anomaly: main loop exited with exception: " ++
+                str (Printexc.to_string any) ++
+                fnl() ++ str"Please report.");
+      loop ()
diff --git a/toplevel/toplevel.mli b/toplevel/coqloop.mli
index 3be3115f..8ed661e6 100644
--- a/toplevel/toplevel.mli
+++ b/toplevel/coqloop.mli
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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 Pcoq
 
 (** The Coq toplevel loop. *)
 
@@ -31,9 +30,9 @@ val set_prompt : (unit -> string) -> unit
   May raise only the following exceptions: [Drop] and [End_of_input],
   meaning we get out of the Coq loop. *)
 
-val print_toplevel_error : exn -> std_ppcmds
+val print_toplevel_error : Exninfo.iexn -> std_ppcmds
 
-(** Parse and execute a vernac command. *)
+(** Parse and execute one vernac command. *)
 
 val do_vernac : unit -> unit
 
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index d2eb7d9c..142f3386 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -1,36 +1,96 @@
 (************************************************************************)
 (*  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 System
 open Flags
 open Names
 open Libnames
-open Nameops
 open States
-open Toplevel
 open Coqinit
 
+let () = at_exit flush_all
+
+let ( / ) = Filename.concat
+
+let fatal_error info anomaly =
+  let msg = info ++ fnl () in
+  pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg;
+  flush_all ();
+  exit (if anomaly then 129 else 1)
+
 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 e when Errors.noncritical e ->
     (Coq_config.version,Coq_config.date)
 
 let print_header () =
-  let (ver,rev) = (get_version_date ()) in
-    Printf.printf "Welcome to Coq %s (%s)\n" ver rev;
-    flush stdout
+  let (ver,rev) = get_version_date () in
+  ppnl (str ("Welcome to Coq "^ver^" ("^rev^")"));
+  pp_flush ()
+
+let warning s = msg_warning (strbrk s)
+
+let toploop = ref None
+
+let color : [`ON | `AUTO | `OFF] ref = ref `AUTO
+let set_color = function
+| "on" -> color := `ON
+| "off" -> color := `OFF
+| "auto" -> color := `AUTO
+| _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1
+
+let init_color () =
+  let has_color = match !color with
+  | `OFF -> false
+  | `ON -> true
+  | `AUTO ->
+    Terminal.has_style Unix.stdout &&
+    Terminal.has_style Unix.stderr
+  in
+  if has_color then begin
+    let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in
+    match colors with
+    | None ->
+      (** Default colors *)
+      Ppstyle.init_color_output ()
+    | Some "" ->
+      (** No color output *)
+      ()
+    | Some s ->
+      (** Overwrite all colors *)
+      Ppstyle.clear_styles ();
+      Ppstyle.parse_config s;
+      Ppstyle.init_color_output ()
+  end
+
+let toploop_init = ref begin fun x ->
+  let () = init_color () in
+  let () = CoqworkmgrApi.(init !Flags.async_proofs_worker_priority) in
+  x
+  end
+
+let toploop_run = ref (fun () ->
+  if Dumpglob.dump () then begin
+    if_verbose warning "Dumpglob cannot be used in interactive mode.";
+    Dumpglob.noglob ()
+  end;
+  Coqloop.loop();
+  (* Initialise and launch the Ocaml toplevel *)
+  Coqinit.init_ocaml_path();
+  Mltop.ocaml_toploop())
 
 let output_context = ref false
 
@@ -38,7 +98,8 @@ let memory_stat = ref false
 
 let print_memory_stat () =
   if !memory_stat then
-    Format.printf "total heap size = %d kbytes\n" (heap_size_kb ())
+    ppnl
+      (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes")
 
 let _ = at_exit print_memory_stat
 
@@ -47,40 +108,40 @@ let set_engagement c = engagement := Some c
 let engage () =
   match !engagement with Some c -> Global.set_engagement c | None -> ()
 
+let type_in_type = ref false
+let set_type_in_type () = type_in_type := true
+let set_hierarchy () = if !type_in_type then Global.set_type_in_type ()
+
 let set_batch_mode () = batch_mode := true
 
-let toplevel_default_name = make_dirpath [id_of_string "Top"]
+let toplevel_default_name = DirPath.make [Id.of_string "Top"]
 let toplevel_name = ref (Some toplevel_default_name)
 let set_toplevel_name dir =
-  if dir = empty_dirpath then error "Need a non empty toplevel module name";
+  if DirPath.is_empty dir then error "Need a non empty toplevel module name";
   toplevel_name := Some dir
 let unset_toplevel_name () = toplevel_name := None
 
 let remove_top_ml () = Mltop.remove ()
 
-let inputstate = ref None
-let set_inputstate s = inputstate:= Some s
-let inputstate () =
-  match !inputstate with
-    | Some "" -> ()
-    | Some s -> intern_state s
-    | None -> intern_state "initial.coq"
+let inputstate = ref ""
+let set_inputstate s =
+  let () = msg_warning (str "The inputstate option is deprecated and discouraged.") in
+  inputstate:=s
+let inputstate () = if not (String.is_empty !inputstate) then intern_state !inputstate
 
 let outputstate = ref ""
-let set_outputstate s = outputstate:=s
-let outputstate () = if !outputstate <> "" then extern_state !outputstate
+let set_outputstate s =
+  let () = msg_warning (str "The outputstate option is deprecated and discouraged.") in
+  outputstate:=s
+let outputstate () = if not (String.is_empty !outputstate) then extern_state !outputstate
 
-let set_default_include d = push_include (d,Nameops.default_root_prefix)
-let set_include d p =
+let set_include d p recursive implicit =
   let p = dirpath_of_string p in
-  push_include (d,p)
-let set_rec_include d p =
-  let p = dirpath_of_string p in
-  push_rec_include(d,p)
+  push_include d p recursive implicit
 
 let load_vernacular_list = ref ([] : (string * bool) list)
 let add_load_vernacular verb s =
-  load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list
+  load_vernacular_list := ((CUnix.make_suffix s ".v"),verb) :: !load_vernacular_list
 let load_vernacular () =
   List.iter
     (fun (s,b) ->
@@ -96,29 +157,57 @@ let load_vernac_obj () =
   List.iter (fun f -> Library.require_library_from_file None f None)
     (List.rev !load_vernacular_obj)
 
+let require_prelude () =
+  let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in
+  let vio = Envars.coqlib () / "theories/Init/Prelude.vio" in
+  let m =
+    if Sys.file_exists vo then vo else
+    if Sys.file_exists vio then vio else vo in
+  Library.require_library_from_dirpath [Coqlib.prelude_module,m] (Some true)
+
 let require_list = ref ([] : string list)
 let add_require s = require_list := s :: !require_list
 let require () =
+  if !load_init then silently require_prelude ();
   List.iter (fun s -> Library.require_library_from_file None s (Some false))
     (List.rev !require_list)
 
 let compile_list = ref ([] : (bool * string) list)
+
+let glob_opt = ref false
+
 let add_compile verbose s =
   set_batch_mode ();
   Flags.make_silent true;
+  if not !glob_opt then Dumpglob.dump_to_dotglob ();
+  (** make the file name explicit; needed not to break up Coq loadpath stuff. *)
+  let s =
+    let open Filename in
+    if is_implicit s
+    then concat current_dir_name s
+    else s
+  in
   compile_list := (verbose,s) :: !compile_list
+
+let compile_file (v,f) =
+  if Flags.do_beautify () then
+    with_option beautify_file (Vernac.compile v) f
+  else
+    Vernac.compile v f
+
 let compile_files () =
-  let init_state = States.freeze() in
-  let coqdoc_init_state = Dumpglob.coqdoc_freeze () in
-    List.iter
-      (fun (v,f) ->
-	 States.unfreeze init_state;
-	 Dumpglob.coqdoc_unfreeze coqdoc_init_state;
-	 if Flags.do_beautify () then
-	   with_option beautify_file (Vernac.compile v) f
-	 else
-	   Vernac.compile v f)
-      (List.rev !compile_list)
+  match !compile_list with
+    | [] -> ()
+    | [vf] -> compile_file vf (* One compilation : no need to save init state *)
+    | l ->
+      let init_state = States.freeze ~marshallable:`No in
+      let coqdoc_init_state = Lexer.location_table () in
+      List.iter
+        (fun vf ->
+	  States.unfreeze init_state;
+	  Lexer.restore_location_table coqdoc_init_state;
+          compile_file vf)
+        (List.rev l)
 
 (*s options for the virtual machine *)
 
@@ -129,248 +218,402 @@ let set_vm_opt () =
   Vm.set_transp_values (not !boxed_val);
   Vconv.set_use_vm !use_vm
 
+(** Options for proof general *)
+
+let set_emacs () =
+  Flags.print_emacs := true;
+  Pp.make_pp_emacs ();
+  Vernacentries.qed_display_script := false;
+  color := `OFF
+
+(** GC tweaking *)
+
+(** Coq is a heavy user of persistent data structures and symbolic ASTs, so the
+    minor heap is heavily sollicited. Unfortunately, the default size is far too
+    small, so we enlarge it a lot (128 times larger).
+
+    To better handle huge memory consumers, we also augment the default major
+    heap increment and the GC pressure coefficient.
+*)
+
+let init_gc () =
+  let param =
+    try ignore (Sys.getenv "OCAMLRUNPARAM"); true
+    with Not_found -> false
+  in
+  let control = Gc.get () in
+  let tweaked_control = { control with
+    Gc.minor_heap_size = 33554432; (** 4M *)
+(*     Gc.major_heap_increment = 268435456; (** 32M *) *)
+    Gc.space_overhead = 120;
+  } in
+  if param then ()
+  else Gc.set tweaked_control
+
 (*s Parsing of the command line.
     We no longer use [Arg.parse], in order to use share [Usage.print_usage]
     between coqtop and coqc. *)
 
 let usage () =
-  if !batch_mode then
-    Usage.print_usage_coqc ()
-  else
-    Usage.print_usage_coqtop () ;
-  flush stderr ;
-  exit 1
+  Envars.set_coqlib Errors.error;
+  init_load_path ();
+  if !batch_mode then Usage.print_usage_coqc ()
+  else begin
+    Mltop.load_ml_objects_raw_rex
+      (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$"));
+    Usage.print_usage_coqtop ()
+  end
+
+let print_style_tags () =
+  let () = init_color () in
+  let tags = Ppstyle.dump () in
+  let iter (t, st) =
+    let st = match st with Some st -> st | None -> Terminal.make () in
+    let opt =
+      Terminal.eval st ^
+      String.concat "." (Ppstyle.repr t) ^
+      Terminal.reset ^ "\n"
+    in
+    print_string opt
+  in
+  List.iter iter tags;
+  flush_all ()
 
-let warning s = msg_warning (str s)
+let error_missing_arg s =
+  prerr_endline ("Error: extra argument expected after option "^s);
+  prerr_endline "See -help for the syntax of supported options";
+  exit 1
 
-let ide_slave = ref false
 let filter_opts = ref false
+let exitcode () = if !filter_opts then 2 else 0
 
 let verb_compat_ntn = ref false
 let no_compat_ntn = ref false
 
-let parse_args arglist =
-  let glob_opt = ref false in
-  let rec parse = function
-    | [] -> []
-    | "-with-geoproof" :: s :: rem ->
-	if s = "yes" then Coq_config.with_geoproof := true
-	else if s = "no" then Coq_config.with_geoproof := false
-	else usage ();
-	parse rem
-    | "-impredicative-set" :: rem ->
-        set_engagement Declarations.ImpredicativeSet; parse rem
-
-    | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem
-    | ("-I"|"-include") :: d :: "-as" :: [] -> usage ()
-    | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem
-    | ("-I"|"-include") :: []       -> usage ()
-
-    | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem
-    | "-R" :: d :: "-as" :: [] -> usage ()
-    | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem
-    | "-R" :: ([] | [_]) -> usage ()
-
-    | "-top" :: d :: rem -> set_toplevel_name (dirpath_of_string d); parse rem
-    | "-top" :: [] -> usage ()
-
-    | "-exclude-dir" :: f :: rem -> exclude_search_in_dirname f; parse rem
-    | "-exclude-dir" :: [] -> usage ()
-
-    | "-notop" :: rem -> unset_toplevel_name (); parse rem
-    | "-q" :: rem -> no_load_rc (); parse rem
-
-    | "-opt" :: rem -> warning "option -opt deprecated, call with .opt suffix\n"; parse rem
-    | "-byte" :: rem -> warning "option -byte deprecated, call with .byte suffix\n"; parse rem
-    | "-full" :: rem -> warning "option -full deprecated\n"; parse rem
-
-    | "-batch" :: rem -> set_batch_mode (); parse rem
-    | "-boot" :: rem -> boot := true; no_load_rc (); parse rem
-    | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem
-    | "-outputstate" :: s :: rem ->
-      Flags.load_proofs := Flags.Force; set_outputstate s; parse rem
-    | "-outputstate" :: []       -> usage ()
-
-    | "-nois" :: rem -> set_inputstate ""; parse rem
-
-    | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem
-    | ("-inputstate"|"-is") :: []       -> usage ()
+let print_where = ref false
+let print_config = ref false
+let print_tags = ref false
 
-    | "-load-ml-object" :: f :: rem -> Mltop.dir_ml_load f; parse rem
-    | "-load-ml-object" :: []       -> usage ()
+let get_priority opt s =
+  try Flags.priority_of_string s
+  with Invalid_argument _ ->
+    prerr_endline ("Error: low/high expected after "^opt); exit 1
 
-    | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem
-    | "-load-ml-source" :: []       -> usage ()
+let get_async_proofs_mode opt = function
+  | "off" -> Flags.APoff
+  | "on" -> Flags.APon
+  | "lazy" -> Flags.APonLazy
+  | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1
 
-    | ("-load-vernac-source"|"-l") :: f :: rem ->
-	add_load_vernacular false f; parse rem
-    | ("-load-vernac-source"|"-l") :: []       -> usage ()
+let get_cache opt = function
+  | "force" -> Some Flags.Force
+  | _ -> prerr_endline ("Error: force expected after "^opt); exit 1
 
-    | ("-load-vernac-source-verbose"|"-lv") :: f :: rem ->
-	add_load_vernacular true f; parse rem
-    | ("-load-vernac-source-verbose"|"-lv") :: []       -> usage ()
 
-    | "-load-vernac-object" :: f :: rem -> add_vernac_obj f; parse rem
-    | "-load-vernac-object" :: []       -> usage ()
+let set_worker_id opt s =
+  assert (s <> "master");
+  Flags.async_proofs_worker_id := s
 
-    | "-dump-glob" :: "stdout" :: rem -> Dumpglob.dump_to_stdout (); glob_opt := true; parse rem
-	  (* À ne pas documenter : l'option 'stdout' n'étant
-	     éventuellement utile que pour le debugging... *)
-    | "-dump-glob" :: f :: rem -> Dumpglob.dump_into_file f; glob_opt := true; parse rem
-    | "-dump-glob" :: []       -> usage ()
-    | ("-no-glob" | "-noglob") :: rem -> Dumpglob.noglob (); glob_opt := true; parse rem
+let get_bool opt = function
+  | "yes" -> true
+  | "no" -> false
+  | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1
 
-    | "-require" :: f :: rem -> add_require f; parse rem
-    | "-require" :: []       -> usage ()
+let get_int opt n =
+  try int_of_string n
+  with Failure _ ->
+    prerr_endline ("Error: integer expected after option "^opt); exit 1
 
-    | "-compile" :: f :: rem -> add_compile false f; if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem
-    | "-compile" :: []       -> usage ()
+let get_host_port opt s =
+  match CString.split ':' s with
+  | [host; port] -> Some (Spawned.Socket(host, int_of_string port))
+  | ["stdfds"] -> Some Spawned.AnonPipe
+  | _ ->
+     prerr_endline ("Error: host:port or stdfds expected after option "^opt);
+     exit 1
 
-    | "-compile-verbose" :: f :: rem -> add_compile true f;  if not !glob_opt then Dumpglob.dump_to_dotglob (); parse rem
-    | "-compile-verbose" :: []       -> usage ()
+let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s)
 
-    | "-force-load-proofs" :: rem -> Flags.load_proofs := Flags.Force; parse rem
-    | "-lazy-load-proofs" :: rem -> Flags.load_proofs := Flags.Lazy; parse rem
-    | "-dont-load-proofs" :: rem -> Flags.load_proofs := Flags.Dont; parse rem
+let vio_tasks = ref []
 
-    | "-beautify" :: rem -> make_beautify true; parse rem
-
-    | "-unsafe" :: f :: rem -> add_unsafe f; parse rem
-    | "-unsafe" :: []       -> usage ()
-
-    | "-debug" :: rem -> set_debug (); parse rem
-
-    | "-compat" :: v :: rem ->
-        Flags.compat_version := get_compat_version v; parse rem
-    | "-compat" :: []       -> usage ()
-
-    | "-verbose-compat-notations" :: rem -> verb_compat_ntn := true; parse rem
-    | "-no-compat-notations" :: rem -> no_compat_ntn := true; parse rem
-
-    | "-vm" :: rem -> use_vm := true; parse rem
-    | "-emacs" :: rem ->
-	Flags.print_emacs := true; Pp.make_pp_emacs();
-	Vernacentries.qed_display_script := false;
-	parse rem
-    | "-emacs-U" :: rem ->
-	warning "Obsolete option \"-emacs-U\", use -emacs instead.";	
-	parse ("-emacs" :: rem)
-
-    | "-unicode" :: rem -> add_require "Utf8_core"; parse rem
-
-    | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem
-    | "-coqlib" :: [] -> usage ()
-
-    | "-where" :: _ -> print_endline (Envars.coqlib ()); exit (if !filter_opts then 2 else 0)
-
-    | ("-config"|"--config") :: _ -> Usage.print_config (); exit (if !filter_opts then 2 else 0)
-
-    | ("-quiet"|"-silent") :: rem -> Flags.make_silent true; parse rem
-
-    | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage ()
-
-    | ("-v"|"--version") :: _ -> Usage.version (if !filter_opts then 2 else 0)
-
-    | "-init-file" :: f :: rem -> set_rcfile f; parse rem
-    | "-init-file" :: []       -> usage ()
-
-    | "-notactics" :: rem ->
-	warning "Obsolete option \"-notactics\".";
-	remove_top_ml (); parse rem
-
-    | "-just-parsing" :: rem -> Vernac.just_parsing := true; parse rem
-
-    | ("-m" | "--memory") :: rem -> memory_stat := true; parse rem
-
-    | "-xml" :: rem -> Flags.xml_export := true; parse rem
-
-    | "-output-context" :: rem -> output_context := true; parse rem
-
-    (* Scanned in Flags. *)
-    | "-v7" :: rem -> error "This version of Coq does not support v7 syntax"
-    | "-v8" :: rem -> parse rem
-
-    | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem
-
-    | "-ideslave" :: rem -> ide_slave := true; parse rem
+let add_vio_task f =
+  set_batch_mode ();
+  Flags.make_silent true;
+  vio_tasks := f :: !vio_tasks
+
+let check_vio_tasks () =
+  let rc =
+    List.fold_left (fun acc t -> Vio_checking.check_vio t && acc)
+      true (List.rev !vio_tasks) in
+  if not rc then exit 1
+
+let vio_files = ref []
+let vio_files_j = ref 0
+let vio_checking = ref false
+let add_vio_file f =
+  set_batch_mode ();
+  Flags.make_silent true;
+  vio_files := f :: !vio_files
+
+let set_vio_checking_j opt j =
+  try vio_files_j := int_of_string j
+  with Failure _ ->
+    prerr_endline ("The first argument of " ^ opt ^ " must the number");
+    prerr_endline "of concurrent workers to be used (a positive integer).";
+    prerr_endline "Makefiles generated by coq_makefile should be called";
+    prerr_endline "setting the J variable like in 'make vio2vo J=3'";
+    exit 1
+
+let is_not_dash_option = function
+  | Some f when String.length f > 0 && f.[0] <> '-' -> true
+  | _ -> false
+
+let schedule_vio_checking () =
+  if !vio_files <> [] && !vio_checking then
+    Vio_checking.schedule_vio_checking !vio_files_j !vio_files
+let schedule_vio_compilation () =
+  if !vio_files <> [] && not !vio_checking then
+    Vio_checking.schedule_vio_compilation !vio_files_j !vio_files
+
+let get_native_name s =
+  (* We ignore even critical errors because this mode has to be super silent *)
+  try
+    String.concat Filename.dir_sep [Filename.dirname s;
+      Nativelib.output_dir; Library.native_name_from_filename s]
+  with _ -> ""
 
-    | "-filteropts" :: rem -> filter_opts := true; parse rem
+let parse_args arglist =
+  let args = ref arglist in
+  let extras = ref [] in
+  let rec parse () = match !args with
+  | [] -> List.rev !extras
+  | opt :: rem ->
+    args := rem;
+    let next () = match !args with
+      | x::rem -> args := rem; x
+      | [] -> error_missing_arg opt
+    in
+    let peek_next () = match !args with
+      | x::_ -> Some x
+      | [] -> None
+    in
+    begin match opt with
+
+    (* Complex options with many args *)
+    |"-I"|"-include" ->
+      begin match rem with
+      | d :: "-as" :: p :: rem -> set_include d p false true; args := rem
+      | d :: "-as" :: [] -> error_missing_arg "-as"
+      | d :: rem -> push_ml_include d; args := rem
+      | [] -> error_missing_arg opt
+      end
+    |"-Q" ->
+      begin match rem with
+      | d :: p :: rem -> set_include d p true false; args := rem
+      | _ -> error_missing_arg opt
+      end
+    |"-R" ->
+      begin match rem with
+      | d :: "-as" :: [] -> error_missing_arg "-as"
+      | d :: "-as" :: p :: rem
+      | d :: p :: rem -> set_include d p true true; args := rem
+      | _ -> error_missing_arg opt
+      end
 
-    | s :: rem ->
-      if !filter_opts then
-       s :: (parse rem)
-      else
-       (prerr_endline ("Don't know what to do with " ^ s); usage ())
+    (* Options with two arg *)
+    |"-check-vio-tasks" ->
+        let tno = get_task_list (next ()) in
+        let tfile = next () in
+        add_vio_task (tno,tfile)
+    |"-schedule-vio-checking" ->
+        vio_checking := true;
+        set_vio_checking_j opt (next ());
+        add_vio_file (next ());
+        while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
+    |"-schedule-vio2vo" ->
+        set_vio_checking_j opt (next ());
+        add_vio_file (next ());
+        while is_not_dash_option (peek_next ()) do add_vio_file (next ()); done
+
+    (* Options with one arg *)
+    |"-coqlib" -> Flags.coqlib_spec:=true; Flags.coqlib:=(next ())
+    |"-async-proofs" ->
+        Flags.async_proofs_mode := get_async_proofs_mode opt (next())
+    |"-async-proofs-j" ->
+        Flags.async_proofs_n_workers := (get_int opt (next ()))
+    |"-async-proofs-cache" ->
+        Flags.async_proofs_cache := get_cache opt (next ())
+    |"-async-proofs-tac-j" ->
+        Flags.async_proofs_n_tacworkers := (get_int opt (next ()))
+    |"-async-proofs-worker-priority" ->
+        Flags.async_proofs_worker_priority := get_priority opt (next ())
+    |"-async-proofs-private-flags" ->
+        Flags.async_proofs_private_flags := Some (next ());
+    |"-worker-id" -> set_worker_id opt (next ())
+    |"-compat" -> Flags.compat_version := get_compat_version (next ())
+    |"-compile" -> add_compile false (next ())
+    |"-compile-verbose" -> add_compile true (next ())
+    |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true
+    |"-feedback-glob" -> Dumpglob.feedback_glob ()
+    |"-exclude-dir" -> exclude_search_in_dirname (next ())
+    |"-init-file" -> set_rcfile (next ())
+    |"-inputstate"|"-is" -> set_inputstate (next ())
+    |"-load-ml-object" -> Mltop.dir_ml_load (next ())
+    |"-load-ml-source" -> Mltop.dir_ml_use (next ())
+    |"-load-vernac-object" -> add_vernac_obj (next ())
+    |"-load-vernac-source"|"-l" -> add_load_vernacular false (next ())
+    |"-load-vernac-source-verbose"|"-lv" -> add_load_vernacular true (next ())
+    |"-outputstate" -> set_outputstate (next ())
+    |"-print-mod-uid" -> let s = String.concat " " (List.map get_native_name rem) in print_endline s; exit 0
+    |"-require" -> add_require (next ())
+    |"-top" -> set_toplevel_name (dirpath_of_string (next ()))
+    |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ())
+    |"-main-channel" -> Spawned.main_channel := get_host_port opt (next())
+    |"-control-channel" -> Spawned.control_channel := get_host_port opt (next())
+    |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo
+    |"-toploop" -> toploop := Some (next ())
+
+    (* Options with zero arg *)
+    |"-async-queries-always-delegate"
+    |"-async-proofs-always-delegate"
+    |"-async-proofs-full" ->
+        Flags.async_proofs_full := true;
+    |"-async-proofs-never-reopen-branch" ->
+        Flags.async_proofs_never_reopen_branch := true;
+    |"-batch" -> set_batch_mode ()
+    |"-beautify" -> make_beautify true
+    |"-boot" -> boot := true; no_load_rc ()
+    |"-bt" -> Backtrace.record_backtrace true
+    |"-color" -> set_color (next ())
+    |"-config"|"--config" -> print_config := true
+    |"-debug" -> set_debug ()
+    |"-emacs" -> set_emacs ()
+    |"-filteropts" -> filter_opts := true
+    |"-h"|"-H"|"-?"|"-help"|"--help" -> usage ()
+    |"-ideslave" -> toploop := Some "coqidetop"; Flags.ide_slave := true
+    |"-impredicative-set" -> set_engagement Declarations.ImpredicativeSet
+    |"-indices-matter" -> Indtypes.enforce_indices_matter ()
+    |"-just-parsing" -> Vernac.just_parsing := true
+    |"-m"|"--memory" -> memory_stat := true
+    |"-noinit"|"-nois" -> load_init := false
+    |"-no-compat-notations" -> no_compat_ntn := true
+    |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true
+    |"-no-native-compiler" -> no_native_compiler := true
+    |"-notop" -> unset_toplevel_name ()
+    |"-output-context" -> output_context := true
+    |"-q" -> no_load_rc ()
+    |"-quiet"|"-silent" -> Flags.make_silent true
+    |"-quick" -> Flags.compilation_mode := BuildVio
+    |"-list-tags" -> print_tags := true
+    |"-time" -> Flags.time := true
+    |"-type-in-type" -> set_type_in_type ()
+    |"-unicode" -> add_require "Utf8_core"
+    |"-v"|"--version" -> Usage.version (exitcode ())
+    |"-verbose-compat-notations" -> verb_compat_ntn := true
+    |"-vm" -> use_vm := true
+    |"-where" -> print_where := true
+
+    (* Deprecated options *)
+    |"-byte" -> warning "option -byte deprecated, call with .byte suffix"
+    |"-opt" -> warning "option -opt deprecated, call with .opt suffix"
+    |"-full" -> warning "option -full deprecated"
+    |"-notactics" -> warning "Obsolete option \"-notactics\"."; remove_top_ml ()
+    |"-emacs-U" ->
+      warning "Obsolete option \"-emacs-U\", use -emacs instead."; set_emacs ()
+    |"-v7" -> error "This version of Coq does not support v7 syntax"
+    |"-v8" -> warning "Obsolete option \"-v8\"."
+    |"-lazy-load-proofs" -> warning "Obsolete option \"-lazy-load-proofs\"."
+    |"-dont-load-proofs" -> warning "Obsolete option \"-dont-load-proofs\"."
+    |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"."
+    |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ())
+    |"-quality" -> warning "Obsolete option \"-quality\"."
+    |"-xml" -> warning "Obsolete option \"-xml\"."
+
+    (* Unknown option *)
+    | s -> extras := s :: !extras
+    end;
+    parse ()
   in
   try
-    parse arglist
+    parse ()
   with
-    | UserError(_,s) as e -> begin
-	try
-	  Stream.empty s; exit 1
-	with Stream.Failure ->
-	  msgnl (Errors.print e); exit 1
-      end
-    | any -> begin msgnl (Errors.print any); exit 1 end
+    | UserError(_, s) as e ->
+      if is_empty s then exit 1
+      else fatal_error (Errors.print e) false
+    | any -> fatal_error (Errors.print any) (Errors.is_anomaly any)
 
 let init arglist =
+  init_gc ();
   Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *)
   Lib.init();
   (* Default Proofb Mode starts with an alternative default. *)
   Goptions.set_string_option_value ["Default";"Proof";"Mode"] "Classic";
   begin
     try
-      let foreign_args = parse_args arglist in
-      if !filter_opts then
-        (print_string (String.concat "\n" foreign_args); exit 0);
-      if !ide_slave then begin
-        Flags.make_silent true;
-        Ide_slave.init_stdout ()
+      let extras = parse_args arglist in
+      (* If we have been spawned by the Spawn module, this has to be done
+       * early since the master waits us to connect back *)
+      Spawned.init_channels ();
+      Envars.set_coqlib Errors.error;
+      if !print_where then (print_endline(Envars.coqlib ()); exit(exitcode ()));
+      if !print_config then (Usage.print_config (); exit (exitcode ()));
+      if !print_tags then (print_style_tags (); exit (exitcode ()));
+      if !filter_opts then (print_string (String.concat "\n" extras); exit 0);
+      init_load_path ();
+      Option.iter Mltop.load_ml_object_raw !toploop;
+      let extras = !toploop_init extras in
+      if not (List.is_empty extras) then begin
+        prerr_endline ("Don't know what to do with "^String.concat " " extras);
+        prerr_endline "See -help for the list of supported options";
+        exit 1
       end;
       if_verbose print_header ();
-      init_load_path ();
       inputstate ();
       Mltop.init_known_plugins ();
       set_vm_opt ();
       engage ();
+      set_hierarchy ();
       (* Be careful to set these variables after the inputstate *)
       Syntax_def.set_verbose_compat_notations !verb_compat_ntn;
       Syntax_def.set_compat_notations (not !no_compat_ntn);
-      if (not !batch_mode|| !compile_list=[]) && Global.env_is_empty() then
-        Option.iter Declaremods.start_library !toplevel_name;
+      if (not !batch_mode || List.is_empty !compile_list)
+         && Global.env_is_initial ()
+      then Option.iter Declaremods.start_library !toplevel_name;
       init_library_roots ();
       load_vernac_obj ();
       require ();
+      Stm.init ();
       load_rcfile();
       load_vernacular ();
       compile_files ();
+      schedule_vio_checking ();
+      schedule_vio_compilation ();
+      check_vio_tasks ();
       outputstate ()
     with any ->
+      let any = Errors.push any in
       flush_all();
-      if not !batch_mode then message "Error during initialization:";
-      msgnl (Toplevel.print_toplevel_error any);
-      exit 1
+      let msg =
+        if !batch_mode then mt ()
+        else str "Error during initialization:" ++ fnl ()
+      in
+      fatal_error (msg ++ Coqloop.print_toplevel_error any) (Errors.is_anomaly (fst any))
   end;
-  if !batch_mode then
-    (flush_all();
-     if !output_context then
-       Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
-     Profile.print_profile ();
-     exit 0);
-  (* We initialize the command history stack with a first entry *)
-  Backtrack.mark_command Vernacexpr.VernacNop
+  if !batch_mode then begin
+    flush_all();
+    if !output_context then
+      Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
+    Profile.print_profile ();
+    exit 0
+  end
 
 let init_toplevel = init
 
 let start () =
-  init_toplevel (List.tl (Array.to_list Sys.argv));
-  if !ide_slave then
-    Ide_slave.loop ()
-  else
-    Toplevel.loop();
-  (* Initialise and launch the Ocaml toplevel *)
-  Coqinit.init_ocaml_path();
-  Mltop.ocaml_toploop();
+  let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in
+  (* In batch mode, Coqtop has already exited at this point. In interactive one,
+     dump glob is nothing but garbage ...  *)
+  !toploop_run ();
   exit 1
 
 (* [Coqtop.start] will be called by the code produced by coqmktop *)
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index 842ec4ef..356ccdcc 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.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        *)
@@ -9,8 +9,14 @@
 (** The Coq main module. The following function [start] will parse the
    command line, print the banner, initialize the load path, load the input
    state, load the files given on the command line, load the ressource file,
-   produce the output state if any, and finally will launch [Toplevel.loop]. *)
+   produce the output state if any, and finally will launch [Coqloop.loop]. *)
 
 val init_toplevel : string list -> unit
 
 val start : unit -> unit
+
+
+(* For other toploops *)
+val toploop_init : (string list -> string list) ref
+val toploop_run : (unit -> unit) ref
+
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index af0bbeaf..7d5d61fb 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -1,15 +1,17 @@
 (************************************************************************)
 (*  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 Errors
 open Util
-open Sign
+open Context
 open Term
+open Vars
 open Entries
 open Declarations
 open Cooking
@@ -20,7 +22,7 @@ open Cooking
 let detype_param = function
   | (Name id,None,p) -> id, Entries.LocalAssum p
   | (Name id,Some p,_) -> id, Entries.LocalDef p
-  | (Anonymous,_,_) -> anomaly"Unnamed inductive local variable"
+  | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable")
 
 (* Replace
 
@@ -37,29 +39,31 @@ let abstract_inductive hyps nparams inds =
   let ntyp = List.length inds in
   let nhyp = named_context_length hyps in
   let args = instance_from_named_context (List.rev hyps) in
-  let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in
+  let args = Array.of_list args in
+  let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in
   let inds' =
     List.map
-      (function (tname,arity,cnames,lc) ->
+      (function (tname,arity,template,cnames,lc) ->
 	let lc' = List.map (substl subs) lc in
 	let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
 	let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
-        (tname,arity',cnames,lc''))
+        (tname,arity',template,cnames,lc''))
       	inds in
   let nparams' = nparams + Array.length args in
 (* To be sure to be the same as before, should probably be moved to process_inductive *)
-  let params' = let (_,arity,_,_) = List.hd inds' in
+  let params' = let (_,arity,_,_,_) = List.hd inds' in
 		let (params,_) = decompose_prod_n_assum nparams' arity in
 		  List.map detype_param params
   in
   let ind'' =
   List.map
-    (fun (a,arity,c,lc) ->
+    (fun (a,arity,template,c,lc) ->
       let _, short_arity = decompose_prod_n_assum nparams' arity in
       let shortlc =
 	List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in
       { mind_entry_typename = a;
 	mind_entry_arity = short_arity;
+	mind_entry_template = template;
 	mind_entry_consnames = c;
 	mind_entry_lc = shortlc })
     inds'
@@ -67,27 +71,49 @@ let abstract_inductive hyps nparams inds =
 
 let refresh_polymorphic_type_of_inductive (_,mip) =
   match mip.mind_arity with
-  | Monomorphic s ->
-      s.mind_user_arity
-  | Polymorphic ar ->
-      let ctx = List.rev mip.mind_arity_ctxt in
-      mkArity (List.rev ctx,Termops.new_Type_sort())
+  | RegularArity s -> s.mind_user_arity, false
+  | TemplateArity ar ->
+    let ctx = List.rev mip.mind_arity_ctxt in
+      mkArity (List.rev ctx, Type ar.template_level), true
 
-let process_inductive sechyps modlist mib =
+let process_inductive (sechyps,abs_ctx) modlist mib =
   let nparams = mib.mind_nparams in
+  let subst, univs = 
+    if mib.mind_polymorphic then 
+      let inst = Univ.UContext.instance mib.mind_universes in
+      let cstrs = Univ.UContext.constraints mib.mind_universes in
+	inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs)
+    else Univ.Instance.empty, mib.mind_universes
+  in
   let inds =
-    array_map_to_list
+    Array.map_to_list
       (fun mip ->
-	 let arity = expmod_constr modlist (refresh_polymorphic_type_of_inductive (mib,mip)) in
-	 let lc = Array.map (expmod_constr modlist) mip.mind_user_lc in
-	 (mip.mind_typename,
-	  arity,
-	  Array.to_list mip.mind_consnames,
-	  Array.to_list lc))
+	let ty, template = refresh_polymorphic_type_of_inductive (mib,mip) in
+	let arity = expmod_constr modlist ty in
+	let arity = Vars.subst_instance_constr subst arity in
+	let lc = Array.map 
+	  (fun c -> Vars.subst_instance_constr subst (expmod_constr modlist c))
+	  mip.mind_user_lc 
+	in
+	  (mip.mind_typename,
+	   arity, template,
+	   Array.to_list mip.mind_consnames,
+	   Array.to_list lc))
       mib.mind_packets in
   let sechyps' = map_named_context (expmod_constr modlist) sechyps in
   let (params',inds') = abstract_inductive sechyps' nparams inds in
-  { mind_entry_record = mib.mind_record;
+  let abs_ctx = Univ.instantiate_univ_context abs_ctx in
+  let univs = Univ.UContext.union abs_ctx univs in
+  let record = match mib.mind_record with
+    | Some (Some (id, _, _)) -> Some (Some id)
+    | Some None -> Some None
+    | None -> None
+  in
+  { mind_entry_record = record;
     mind_entry_finite = mib.mind_finite;
     mind_entry_params = params';
-    mind_entry_inds = inds' }
+    mind_entry_inds = inds';
+    mind_entry_polymorphic = mib.mind_polymorphic;
+    mind_entry_private = mib.mind_private;
+    mind_entry_universes = univs
+  }
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index 297a0731..386e4e3e 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -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 Sign
-open Cooking
+open Context
 open Declarations
 open Entries
+open Opaqueproof
 
 val process_inductive :
-  named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
+  named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry
diff --git a/toplevel/g_obligations.ml4 b/toplevel/g_obligations.ml4
new file mode 100644
index 00000000..24661e12
--- /dev/null
+++ b/toplevel/g_obligations.ml4
@@ -0,0 +1,135 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+(*
+  Syntax for the subtac terms and types.
+  Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
+
+
+open Libnames
+open Constrexpr
+open Constrexpr_ops
+
+(* We define new entries for programs, with the use of this module
+ * Subtac. These entries are named Subtac.<foo>
+ *)
+
+module Gram = Pcoq.Gram
+module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
+
+open Pcoq
+
+let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
+
+type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
+
+let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type =
+  Genarg.create_arg None "withtac"
+
+let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac)
+
+GEXTEND Gram
+  GLOBAL: withtac;
+
+  withtac:
+    [ [ "with"; t = Tactic.tactic -> Some t
+      | -> None ] ]
+  ;
+
+  Constr.closed_binder:
+    [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
+	  let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
+          [LocalRawAssum ([id], default_binder_kind, typ)]
+    ] ];
+
+  END
+
+open Obligations
+
+let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater)
+
+VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) withtac(tac) ] ->
+    [ obligation (num, Some name, Some t) tac ]
+| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] ->
+    [ obligation (num, Some name, None) tac ]
+| [ "Obligation" integer(num) ":" lconstr(t) withtac(tac) ] ->
+    [ obligation (num, None, Some t) tac ]
+| [ "Obligation" integer(num) withtac(tac) ] ->
+    [ obligation (num, None, None) tac ]
+| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] ->
+    [ next_obligation (Some name) tac ]
+| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ]
+END
+
+VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF
+| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] ->
+    [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] ->
+    [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
+END
+
+VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF
+| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] ->
+    [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" "with" tactic(t) ] ->
+    [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" ] ->
+    [ try_solve_obligations None None ]
+END
+
+VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF
+| [ "Solve" "All" "Obligations" "with" tactic(t) ] ->
+    [ solve_all_obligations (Some (Tacinterp.interp t)) ]
+| [ "Solve" "All" "Obligations" ] ->
+    [ solve_all_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
+| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF
+| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
+    set_default_tactic
+      (Locality.make_section_locality (Locality.LocalityFixme.consume ()))
+      (Tacintern.glob_tactic t) ]
+END
+
+open Pp
+
+VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY
+| [ "Show" "Obligation" "Tactic" ] -> [
+    msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ]
+END
+
+VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY
+| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ]
+| [ "Obligations" ] -> [ show_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY
+| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ]
+| [ "Preterm" ] -> [ msg_info (show_term None) ]
+END
+
+open Pp
+
+(* Declare a printer for the content of Program tactics *)
+let () =
+  let printer _ _ _ = function
+  | None -> mt ()
+  | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac
+  in
+  (* should not happen *)
+  let dummy _ _ _ expr = assert false in
+  Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index 8dd18163..9341f2f7 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.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,32 +8,131 @@
 
 open Pp
 open Util
-open Flags
 open Names
 open Nameops
 open Namegen
 open Term
 open Termops
-open Inductive
 open Indtypes
-open Sign
 open Environ
 open Pretype_errors
 open Type_errors
 open Typeclasses_errors
 open Indrec
-open Reduction
 open Cases
 open Logic
 open Printer
-open Glob_term
 open Evd
-open Libnames
-open Declarations
+
+(* This simplifies the typing context of Cases clauses *)
+(* hope it does not disturb other typing contexts *)
+let contract env lc =
+  let l = ref [] in
+  let contract_context (na,c,t) env =
+    match c with
+      | Some c' when isRel c' ->
+          l := (Vars.substl !l c') :: !l;
+          env
+      | _ ->
+          let t' = Vars.substl !l t in
+          let c' = Option.map (Vars.substl !l) c in
+          let na' = named_hd env t' na in
+          l := (mkRel 1) :: List.map (Vars.lift 1) !l;
+          push_rel (na',c',t') env in
+  let env = process_rel_context contract_context env in
+  (env, List.map (Vars.substl !l) lc)
+
+let contract2 env a b = match contract env [a;b] with
+  | env, [a;b] -> env,a,b | _ -> assert false
+
+let contract3 env a b c = match contract env [a;b;c] with
+  | env, [a;b;c] -> env,a,b,c | _ -> assert false
+
+let contract4 env a b c d = match contract env [a;b;c;d] with
+  | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false
+
+let contract1_vect env a v =
+  match contract env (a :: Array.to_list v) with
+  | env, a::l -> env,a,Array.of_list l
+  | _ -> assert false
+
+let rec contract3' env a b c = function
+  | OccurCheck (evk,d) -> let x,d = contract4 env a b c d in x,OccurCheck(evk,d)
+  | NotClean ((evk,args),env',d) ->
+      let env',d,args = contract1_vect env' d args in
+      contract3 env a b c,NotClean((evk,args),env',d)
+  | ConversionFailed (env',t1,t2) ->
+      let (env',t1,t2) = contract2 env' t1 t2 in
+      contract3 env a b c, ConversionFailed (env',t1,t2)
+  | NotSameArgSize | NotSameHead | NoCanonicalStructure
+  | MetaOccurInBody _ | InstanceNotSameType _
+  | UnifUnivInconsistency _ as x -> contract3 env a b c, x
+  | CannotSolveConstraint ((pb,env,t,u),x) ->
+      let env,t,u = contract2 env t u in
+      let y,x = contract3' env a b c x in
+      y,CannotSolveConstraint ((pb,env,t,u),x)
+
+(** Printers *)
 
 let pr_lconstr c = quote (pr_lconstr c)
-let pr_lconstr_env e c = quote (pr_lconstr_env e c)
-let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t)
+let pr_lconstr_env e s c = quote (pr_lconstr_env e s c)
+let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t)
+
+(** A canonisation procedure for constr such that comparing there
+    externalisation catches more equalities *)
+let canonize_constr c =
+  (* replaces all the names in binders by [dn] ("default name"),
+     ensures that [alpha]-equivalent terms will have the same
+     externalisation. *)
+  let dn = Name.Anonymous in
+  let rec canonize_binders c =
+    match Term.kind_of_term c with
+    | Prod (_,t,b) -> mkProd(dn,t,b)
+    | Lambda (_,t,b) -> mkLambda(dn,t,b)
+    | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b)
+    | _ -> Term.map_constr canonize_binders c
+  in
+  canonize_binders c
+
+(** Tries to realize when the two terms, albeit different are printed the same. *)
+let display_eq ~flags env sigma t1 t2 =
+  (* terms are canonized, then their externalisation is compared syntactically *)
+  let open Constrextern in
+  let t1 = canonize_constr t1 in
+  let t2 = canonize_constr t2 in
+  let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in
+  let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in
+  Constrexpr_ops.constr_expr_eq ct1 ct2
+
+(** This function adds some explicit printing flags if the two arguments are
+    printed alike. *)
+let rec pr_explicit_aux env sigma t1 t2 = function
+| [] ->
+  (** no specified flags: default. *)
+  (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2))
+| flags :: rem ->
+  let equal = display_eq ~flags env sigma t1 t2 in
+  if equal then
+    (** The two terms are the same from the user point of view *)
+    pr_explicit_aux env sigma t1 t2 rem
+  else
+    let open Constrextern in
+    let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) ()
+    in
+    let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) ()
+    in
+    quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2)
+
+let explicit_flags =
+  let open Constrextern in
+  [ []; (** First, try with the current flags *)
+    [print_implicits]; (** Then with implicit *)
+    [print_universes]; (** Then with universes *)
+    [print_universes; print_implicits]; (** With universes AND implicits *)
+    [print_implicits; print_coercions; print_no_symbol]; (** Then more! *)
+    [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ]
+
+let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags
 
 let pr_db env i =
   try
@@ -42,8 +141,8 @@ let pr_db env i =
       | Anonymous, _, _ -> str "<>"
   with Not_found -> str "UNBOUND_REL_" ++ int i
 
-let explain_unbound_rel env n =
-  let pe = pr_ne_context_of (str "In environment") env in
+let explain_unbound_rel env sigma n =
+  let pe = pr_ne_context_of (str "In environment") env sigma in
   str "Unbound reference: " ++ pe ++
   str "The reference " ++ int n ++ str " is free."
 
@@ -52,24 +151,25 @@ let explain_unbound_var env v =
   str "No such section variable or assumption: " ++ var ++ str "."
 
 let explain_not_type env sigma j =
-  let j = j_nf_evar sigma j in
-  let pe = pr_ne_context_of (str "In environment") env in
-  let pc,pt = pr_ljudge_env env j in
+  let j = Evarutil.j_nf_evar sigma j in
+  let pe = pr_ne_context_of (str "In environment") env sigma in
+  let pc,pt = pr_ljudge_env env sigma j in
   pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++
   str "has type" ++ spc () ++ pt ++ spc () ++
   str "which should be Set, Prop or Type."
 
-let explain_bad_assumption env j =
-  let pe = pr_ne_context_of (str "In environment") env in
-  let pc,pt = pr_ljudge_env env j in
+let explain_bad_assumption env sigma j =
+  let pe = pr_ne_context_of (str "In environment") env sigma in
+  let pc,pt = pr_ljudge_env env sigma j in
   pe ++ str "Cannot declare a variable or hypothesis over the term" ++
   brk(1,1) ++ pc ++ spc () ++ str "of type" ++ spc () ++ pt ++ spc () ++
   str "because this term is not a type."
 
-let explain_reference_variables c =
-  let pc = pr_lconstr c in
-  str "The constant" ++ spc () ++ pc ++ spc () ++
-  str "refers to variables which are not in the context."
+let explain_reference_variables id c =
+  (* c is intended to be a global reference *)
+  let pc = pr_global (Globnames.global_of_constr c) in
+  pc ++ strbrk " depends on the variable " ++ pr_id id ++
+  strbrk " which is not declared in the context."
 
 let rec pr_disjunction pr = function
   | [a] -> pr  a
@@ -77,10 +177,16 @@ let rec pr_disjunction pr = function
   | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l
   | [] -> assert false
 
-let explain_elim_arity env ind sorts c pj okinds =
+let pr_puniverses f env (c,u) = 
+  f env c ++ 
+  (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then
+    str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)"
+  else mt())
+
+let explain_elim_arity env sigma ind sorts c pj okinds =
   let env = make_all_name_different env in
-  let pi = pr_inductive env ind in
-  let pc = pr_lconstr_env env c in
+  let pi = pr_inductive env (fst ind) in
+  let pc = pr_lconstr_env env sigma c in
   let msg = match okinds with
   | Some(kp,ki,explanation) ->
       let pki = pr_sort_family ki in
@@ -93,7 +199,7 @@ let explain_elim_arity env ind sorts c pj okinds =
 	| WrongArity ->
 	  "wrong arity" in
       let ppar = pr_disjunction (fun s -> quote (pr_sort_family s)) sorts in
-      let ppt = pr_lconstr_env env ((strip_prod_assum pj.uj_type)) in
+      let ppt = pr_lconstr_env env sigma ((strip_prod_assum pj.uj_type)) in
       hov 0
 	(str "the return type has sort" ++ spc () ++ ppt ++ spc () ++
 	 str "while it" ++ spc () ++ str "should be " ++ ppar ++ str ".") ++
@@ -112,10 +218,10 @@ let explain_elim_arity env ind sorts c pj okinds =
   fnl () ++ msg
 
 let explain_case_not_inductive env sigma cj =
-  let cj = j_nf_evar sigma cj in
+  let cj = Evarutil.j_nf_evar sigma cj in
   let env = make_all_name_different env in
-  let pc = pr_lconstr_env env cj.uj_val in
-  let pct = pr_lconstr_env env cj.uj_type in
+  let pc = pr_lconstr_env env sigma cj.uj_val in
+  let pct = pr_lconstr_env env sigma cj.uj_type in
     match kind_of_term cj.uj_type with
       | Evar _ ->
 	  str "Cannot infer a type for this expression."
@@ -125,116 +231,177 @@ let explain_case_not_inductive env sigma cj =
 	  str "which is not a (co-)inductive type."
 
 let explain_number_branches env sigma cj expn =
-  let cj = j_nf_evar sigma cj in
+  let cj = Evarutil.j_nf_evar sigma cj in
   let env = make_all_name_different env in
-  let pc = pr_lconstr_env env cj.uj_val in
-  let pct = pr_lconstr_env env cj.uj_type in
+  let pc = pr_lconstr_env env sigma cj.uj_val in
+  let pct = pr_lconstr_env env sigma cj.uj_type in
   str "Matching on term" ++ brk(1,1) ++ pc ++ spc () ++
   str "of type" ++ brk(1,1) ++ pct ++ spc () ++
   str "expects " ++  int expn ++ str " branches."
 
 let explain_ill_formed_branch env sigma c ci actty expty =
-  let simp t = Reduction.nf_betaiota (nf_evar sigma t) in
-  let c = nf_evar sigma c in
+  let simp t = Reduction.nf_betaiota env (Evarutil.nf_evar sigma t) in
+  let c = Evarutil.nf_evar sigma c in
   let env = make_all_name_different env in
-  let pc = pr_lconstr_env env c in
-  let pa = pr_lconstr_env env (simp actty) in
-  let pe = pr_lconstr_env env (simp expty) in
+  let pc = pr_lconstr_env env sigma c in
+  let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in
   strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++
   spc () ++ strbrk "the branch for constructor" ++ spc () ++
-  quote (pr_constructor env ci) ++
+  quote (pr_puniverses pr_constructor env ci) ++
   spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++
   str "which should be" ++ brk(1,1) ++ pe ++ str "."
 
-let explain_generalization env (name,var) j =
-  let pe = pr_ne_context_of (str "In environment") env in
-  let pv = pr_ltype_env env var in
-  let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) j in
+let explain_generalization env sigma (name,var) j =
+  let pe = pr_ne_context_of (str "In environment") env sigma in
+  let pv = pr_ltype_env env sigma var in
+  let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in
   pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++
   str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++
   str "it has type" ++ spc () ++ pt ++
   spc () ++ str "which should be Set, Prop or Type."
 
-let explain_actual_type env sigma j pt =
-  let j = j_nf_betaiotaevar sigma j in
-  let pt = Reductionops.nf_betaiota sigma pt in
-  let pe = pr_ne_context_of (str "In environment") env in
-  let (pc,pct) = pr_ljudge_env env j in
-  let pt = pr_lconstr_env env pt in
+let rec explain_unification_error env sigma p1 p2 = function
+  | None -> mt()
+  | Some e ->
+     let rec aux p1 p2 = function
+     | OccurCheck (evk,rhs) ->
+        let rhs = Evarutil.nf_evar sigma rhs in
+        [str "cannot define " ++ quote (pr_existential_key sigma evk) ++
+	strbrk " with term " ++ pr_lconstr_env env sigma rhs ++
+        strbrk " that would depend on itself"]
+     | NotClean ((evk,args),env,c) ->
+        let c = Evarutil.nf_evar sigma c in
+        let args = Array.map (Evarutil.nf_evar sigma) args in
+        [str "cannot instantiate " ++ quote (pr_existential_key sigma evk)
+        ++ strbrk " because " ++ pr_lconstr_env env sigma c ++
+	strbrk " is not in its scope" ++
+        (if Array.is_empty args then mt() else
+         strbrk ": available arguments are " ++
+         pr_sequence (pr_lconstr_env env sigma) (List.rev (Array.to_list args)))]
+     | NotSameArgSize | NotSameHead | NoCanonicalStructure ->
+        (* Error speaks from itself *) []
+     | ConversionFailed (env,t1,t2) ->
+        if Term.eq_constr t1 p1 && Term.eq_constr t2 p2 then [] else
+        let env = make_all_name_different env in
+        let t1 = Evarutil.nf_evar sigma t1 in
+        let t2 = Evarutil.nf_evar sigma t2 in
+        if not (Term.eq_constr t1 p1) || not (Term.eq_constr t2 p2) then
+          let t1, t2 = pr_explicit env sigma t1 t2 in
+          [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2]
+        else []
+     | MetaOccurInBody evk ->
+        [str "instance for " ++ quote (pr_existential_key sigma evk) ++
+	strbrk " refers to a metavariable - please report your example"]
+     | InstanceNotSameType (evk,env,t,u) ->
+        let t, u = pr_explicit env sigma t u in
+        [str "unable to find a well-typed instantiation for " ++
+        quote (pr_existential_key sigma evk) ++
+        strbrk ": cannot ensure that " ++
+        t ++ strbrk " is a subtype of " ++ u]
+     | UnifUnivInconsistency p ->
+        if !Constrextern.print_universes then
+	  [str "universe inconsistency: " ++
+          Univ.explain_universe_inconsistency Universes.pr_with_global_universes p]
+	else
+          [str "universe inconsistency"]
+     | CannotSolveConstraint ((pb,env,t,u),e) ->
+        let t = Evarutil.nf_evar sigma t in
+        let u = Evarutil.nf_evar sigma u in
+        (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++
+        str " == " ++ pr_lconstr_env env sigma u)
+        :: aux t u e
+     in
+     match aux p1 p2 e with
+     | [] -> mt ()
+     | l -> spc () ++ str "(" ++
+            prlist_with_sep pr_semicolon (fun x -> x) l ++ str ")"
+
+let explain_actual_type env sigma j t reason =
+  let env = make_all_name_different env in
+  let j = Evarutil.j_nf_betaiotaevar sigma j in
+  let t = Reductionops.nf_betaiota sigma t in
+  (** Actually print *)
+  let pe = pr_ne_context_of (str "In environment") env sigma in
+  let pc = pr_lconstr_env env sigma (Environ.j_val j) in
+  let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in
+  let ppreason = explain_unification_error env sigma j.uj_type t reason in
   pe ++
+  hov 0 (
   str "The term" ++ brk(1,1) ++ pc ++ spc () ++
-  str "has type" ++ brk(1,1) ++ pct ++ brk(1,1) ++
-  str "while it is expected to have type" ++ brk(1,1) ++ pt ++ str "."
+  str "has type" ++ brk(1,1) ++ pct ++ spc () ++
+  str "while it is expected to have type" ++ brk(1,1) ++ pt ++
+  ppreason ++ str ".")
 
 let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl =
-  let randl = jv_nf_betaiotaevar sigma randl in
-  let exptyp = nf_evar sigma exptyp in
+  let randl = Evarutil.jv_nf_betaiotaevar sigma randl in
+  let exptyp = Evarutil.nf_evar sigma exptyp in
   let actualtyp = Reductionops.nf_betaiota sigma actualtyp in
-  let rator = j_nf_evar sigma rator in
+  let rator = Evarutil.j_nf_evar sigma rator in
   let env = make_all_name_different env in
+  let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in
   let nargs = Array.length randl in
-(*  let pe = pr_ne_context_of (str "in environment") env in*)
-  let pr,prt = pr_ljudge_env env rator in
-  let term_string1 = str (plural nargs "term") in
+(*  let pe = pr_ne_context_of (str "in environment") env sigma in*)
+  let pr,prt = pr_ljudge_env env sigma rator in
+  let term_string1 = str (String.plural nargs "term") in
   let term_string2 =
-    if nargs>1 then str "The " ++ nth n ++ str " term" else str "This term" in
-  let appl = prvect_with_sep pr_fnl
+    if nargs>1 then str "The " ++ pr_nth n ++ str " term" else str "This term"
+  in
+  let appl = prvect_with_sep fnl
 	       (fun c ->
-		  let pc,pct = pr_ljudge_env env c in
+		  let pc,pct = pr_ljudge_env env sigma c in
 		  hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
   in
-  str "Illegal application (Type Error): " ++ (* pe ++ *) fnl () ++
+  str "Illegal application: " ++ (* pe ++ *) fnl () ++
   str "The term" ++ brk(1,1) ++ pr ++ spc () ++
   str "of type" ++ brk(1,1) ++ prt ++ spc () ++
   str "cannot be applied to the " ++ term_string1 ++ fnl () ++
   str " " ++ v 0 appl ++ fnl () ++ term_string2 ++ str " has type" ++
-  brk(1,1) ++ pr_lconstr_env env actualtyp ++ spc () ++
+  brk(1,1) ++ actualtyp ++ spc () ++
   str "which should be coercible to" ++ brk(1,1) ++
-  pr_lconstr_env env exptyp ++ str "."
+  exptyp ++ str "."
 
 let explain_cant_apply_not_functional env sigma rator randl =
-  let randl = jv_nf_evar sigma randl in
-  let rator = j_nf_evar sigma rator in
+  let randl = Evarutil.jv_nf_evar sigma randl in
+  let rator = Evarutil.j_nf_evar sigma rator in
   let env = make_all_name_different env in
   let nargs = Array.length randl in
-(*  let pe = pr_ne_context_of (str "in environment") env in*)
-  let pr = pr_lconstr_env env rator.uj_val in
-  let prt = pr_lconstr_env env rator.uj_type in
-  let appl = prvect_with_sep pr_fnl
+(*  let pe = pr_ne_context_of (str "in environment") env sigma in*)
+  let pr = pr_lconstr_env env sigma rator.uj_val in
+  let prt = pr_lconstr_env env sigma rator.uj_type in
+  let appl = prvect_with_sep fnl
 	       (fun c ->
-		  let pc = pr_lconstr_env env c.uj_val in
-		  let pct = pr_lconstr_env env c.uj_type in
+		  let pc = pr_lconstr_env env sigma c.uj_val in
+		  let pct = pr_lconstr_env env sigma c.uj_type in
 		  hov 2 (pc ++ spc () ++ str ": " ++ pct)) randl
   in
   str "Illegal application (Non-functional construction): " ++
   (* pe ++ *) fnl () ++
   str "The expression" ++ brk(1,1) ++ pr ++ spc () ++
   str "of type" ++ brk(1,1) ++ prt ++ spc () ++
-  str "cannot be applied to the " ++ str (plural nargs "term") ++ fnl () ++
-  str " " ++ v 0 appl
+  str "cannot be applied to the " ++ str (String.plural nargs "term") ++
+  fnl () ++ str " " ++ v 0 appl
 
 let explain_unexpected_type env sigma actual_type expected_type =
-  let actual_type = nf_evar sigma actual_type in
-  let expected_type = nf_evar sigma expected_type in
-  let pract = pr_lconstr_env env actual_type in
-  let prexp = pr_lconstr_env env expected_type in
+  let actual_type = Evarutil.nf_evar sigma actual_type in
+  let expected_type = Evarutil.nf_evar sigma expected_type in
+  let pract, prexp = pr_explicit env sigma actual_type expected_type in
   str "Found type" ++ spc () ++ pract ++ spc () ++
   str "where" ++ spc () ++ prexp ++ str " was expected."
 
 let explain_not_product env sigma c =
-  let c = nf_evar sigma c in
-  let pr = pr_lconstr_env env c in
+  let c = Evarutil.nf_evar sigma c in
+  let pr = pr_lconstr_env env sigma c in
   str "The type of this term is a product" ++ spc () ++
   str "while it is expected to be" ++
   (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "."
 
 (* TODO: use the names *)
 (* (co)fixpoints *)
-let explain_ill_formed_rec_body env err names i fixenv vdefj =
+let explain_ill_formed_rec_body env sigma err names i fixenv vdefj =
   let prt_name i =
     match names.(i) with
         Name id -> str "Recursive definition of " ++ pr_id id
-      | Anonymous -> str "The " ++ nth i ++ str " definition" in
+      | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in
 
   let st = match err with
 
@@ -242,175 +409,188 @@ let explain_ill_formed_rec_body env err names i fixenv vdefj =
   | NotEnoughAbstractionInFixBody ->
       str "Not enough abstractions in the definition"
   | RecursionNotOnInductiveType c ->
-      str "Recursive definition on" ++ spc () ++ pr_lconstr_env env c ++ spc () ++
-      str "which should be an inductive type"
+      str "Recursive definition on" ++ spc () ++ pr_lconstr_env env sigma c ++
+      spc () ++ str "which should be an inductive type"
   | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) ->
       let arg_env = make_all_name_different arg_env in
       let called =
         match names.(j) with
             Name id -> pr_id id
-          | Anonymous -> str "the " ++ nth i ++ str " definition" in
+          | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
       let pr_db x = quote (pr_db env x) in
       let vars =
         match (lt,le) with
             ([],[]) -> assert false
           | ([],[x]) -> str "a subterm of " ++ pr_db x
           | ([],_) -> str "a subterm of the following variables: " ++
-              prlist_with_sep pr_spc pr_db le
+              pr_sequence pr_db le
           | ([x],_) -> pr_db x
           | _ ->
               str "one of the following variables: " ++
-              prlist_with_sep pr_spc pr_db lt in
+              pr_sequence pr_db lt in
       str "Recursive call to " ++ called ++ spc () ++
       strbrk "has principal argument equal to" ++ spc () ++
-      pr_lconstr_env arg_env arg ++ strbrk " instead of " ++ vars
+      pr_lconstr_env arg_env sigma arg ++ strbrk " instead of " ++ vars
 
   | NotEnoughArgumentsForFixCall j ->
       let called =
         match names.(j) with
             Name id -> pr_id id
-          | Anonymous -> str "the " ++ nth i ++ str " definition" in
+          | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in
      str "Recursive call to " ++ called ++ str " has not enough arguments"
 
   (* CoFixpoint guard errors *)
   | CodomainNotInductiveType c ->
-      str "The codomain is" ++ spc () ++ pr_lconstr_env env c ++ spc () ++
+      str "The codomain is" ++ spc () ++ pr_lconstr_env env sigma c ++ spc () ++
       str "which should be a coinductive type"
   | NestedRecursiveOccurrences ->
       str "Nested recursive occurrences"
   | UnguardedRecursiveCall c ->
-      str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env c
+      str "Unguarded recursive call in" ++ spc () ++ pr_lconstr_env env sigma c
   | RecCallInTypeOfAbstraction c ->
       str "Recursive call forbidden in the domain of an abstraction:" ++
-      spc () ++ pr_lconstr_env env c
+      spc () ++ pr_lconstr_env env sigma c
   | RecCallInNonRecArgOfConstructor c ->
       str "Recursive call on a non-recursive argument of constructor" ++
-      spc () ++ pr_lconstr_env env c
+      spc () ++ pr_lconstr_env env sigma c
   | RecCallInTypeOfDef c ->
       str "Recursive call forbidden in the type of a recursive definition" ++
-      spc () ++ pr_lconstr_env env c
+      spc () ++ pr_lconstr_env env sigma c
   | RecCallInCaseFun c ->
-      str "Invalid recursive call in a branch of" ++ spc () ++ pr_lconstr_env env c
+      str "Invalid recursive call in a branch of" ++
+      spc () ++ pr_lconstr_env env sigma c
   | RecCallInCaseArg c ->
       str "Invalid recursive call in the argument of \"match\" in" ++ spc () ++
-      pr_lconstr_env env c
+      pr_lconstr_env env sigma c
   | RecCallInCasePred c ->
-      str "Invalid recursive call in the \"return\" clause of \"match\" in" ++  spc () ++
-      pr_lconstr_env env c
+      str "Invalid recursive call in the \"return\" clause of \"match\" in" ++
+      spc () ++ pr_lconstr_env env sigma c
   | NotGuardedForm c ->
-      str "Sub-expression " ++ pr_lconstr_env env c ++
+      str "Sub-expression " ++ pr_lconstr_env env sigma c ++
       strbrk " not in guarded form (should be a constructor," ++
       strbrk " an abstraction, a match, a cofix or a recursive call)"
+  | ReturnPredicateNotCoInductive c ->
+     str "The return clause of the following pattern matching should be" ++
+     strbrk " a coinductive type:" ++
+     spc () ++ pr_lconstr_env env sigma c
   in
   prt_name i ++ str " is ill-formed." ++ fnl () ++
-  pr_ne_context_of (str "In environment") env ++
+  pr_ne_context_of (str "In environment") env sigma ++
   st ++ str "." ++ fnl () ++
   (try (* May fail with unresolved globals. *)
       let fixenv = make_all_name_different fixenv in
-      let pvd = pr_lconstr_env fixenv vdefj.(i).uj_val in
+      let pvd = pr_lconstr_env fixenv sigma vdefj.(i).uj_val in
 	str"Recursive definition is:" ++ spc () ++ pvd ++ str "."
     with e when Errors.noncritical e -> mt ())
 
 let explain_ill_typed_rec_body env sigma i names vdefj vargs =
-  let vdefj = jv_nf_evar sigma vdefj in
-  let vargs = Array.map (nf_evar sigma) vargs in
+  let vdefj = Evarutil.jv_nf_evar sigma vdefj in
+  let vargs = Array.map (Evarutil.nf_evar sigma) vargs in
   let env = make_all_name_different env in
-  let pvd,pvdt = pr_ljudge_env env (vdefj.(i)) in
-  let pv = pr_lconstr_env env vargs.(i) in
+  let pvd = pr_lconstr_env env sigma vdefj.(i).uj_val in
+  let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in
   str "The " ++
-  (if Array.length vdefj = 1 then mt () else nth (i+1) ++ spc ()) ++
+  (match vdefj with [|_|] -> mt () | _ -> pr_nth (i+1) ++ spc ()) ++
   str "recursive definition" ++ spc () ++ pvd ++ spc () ++
   str "has type" ++ spc () ++ pvdt ++ spc () ++
   str "while it should be" ++ spc () ++ pv ++ str "."
 
 let explain_cant_find_case_type env sigma c =
-  let c = nf_evar sigma c in
+  let c = Evarutil.nf_evar sigma c in
   let env = make_all_name_different env in
-  let pe = pr_lconstr_env env c in
+  let pe = pr_lconstr_env env sigma c in
   str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "."
 
 let explain_occur_check env sigma ev rhs =
-  let rhs = nf_evar sigma rhs in
+  let rhs = Evarutil.nf_evar sigma rhs in
   let env = make_all_name_different env in
-  let id = Evd.string_of_existential ev in
-  let pt = pr_lconstr_env env rhs in
-  str "Cannot define " ++ str id ++ str " with term" ++ brk(1,1) ++
-  pt ++ spc () ++ str "that would depend on itself."
-
-let pr_ne_context_of header footer env =
-  if Environ.rel_context env = empty_rel_context &
-    Environ.named_context env = empty_named_context
-  then footer
-  else pr_ne_context_of header env
-
-let explain_hole_kind env evi = function
-  | QuestionMark _ -> str "this placeholder"
-  | CasesType ->
-      str "the type of this pattern-matching problem"
-  | BinderType (Name id) ->
-      str "the type of " ++ Nameops.pr_id id
-  | BinderType Anonymous ->
-      str "the type of this anonymous binder"
-  | ImplicitArg (c,(n,ido),b) ->
+  let pt = pr_lconstr_env env sigma rhs in
+  str "Cannot define " ++ pr_existential_key sigma ev ++ str " with term" ++
+  brk(1,1) ++ pt ++ spc () ++ str "that would depend on itself."
+
+let pr_trailing_ne_context_of env sigma =
+  if List.is_empty (Environ.rel_context env) &&
+    List.is_empty (Environ.named_context env)
+  then str "."
+  else (str " in environment:"++ pr_context_unlimited env sigma)
+
+let rec explain_evar_kind env sigma evk ty = function
+  | Evar_kinds.QuestionMark _ ->
+      strbrk "this placeholder of type " ++ ty
+  | Evar_kinds.CasesType false ->
+      strbrk "the type of this pattern-matching problem"
+  | Evar_kinds.CasesType true ->
+      strbrk "a subterm of type " ++ ty ++
+      strbrk " in the type of this pattern-matching problem"
+  | Evar_kinds.BinderType (Name id) ->
+      strbrk "the type of " ++ Nameops.pr_id id
+  | Evar_kinds.BinderType Anonymous ->
+      strbrk "the type of this anonymous binder"
+  | Evar_kinds.ImplicitArg (c,(n,ido),b) ->
       let id = Option.get ido in
-      str "the implicit parameter " ++
-      pr_id id ++ spc () ++ str "of" ++
-      spc () ++ Nametab.pr_global_env Idset.empty c
-  | InternalHole ->
-      str "an internal placeholder" ++
-	Option.cata (fun evi ->
-	  let env = Evd.evar_env evi in
-	    str " of type "  ++ pr_lconstr_env env evi.evar_concl ++
-	      pr_ne_context_of (str " in environment:"++ fnl ()) (mt ()) env)
-	(mt ()) evi
-  | TomatchTypeParameter (tyi,n) ->
-      str "the " ++ nth n ++
-      str " argument of the inductive type (" ++ pr_inductive env tyi ++
-      str ") of this term"
-  | GoalEvar ->
-      str "an existential variable"
-  | ImpossibleCase ->
-      str "the type of an impossible pattern-matching clause"
-  | MatchingVar _ ->
+      strbrk "the implicit parameter " ++ pr_id id ++ spc () ++ str "of" ++
+      spc () ++ Nametab.pr_global_env Id.Set.empty c ++
+      strbrk " whose type is " ++ ty
+  | Evar_kinds.InternalHole -> strbrk "an internal placeholder of type " ++ ty
+  | Evar_kinds.TomatchTypeParameter (tyi,n) ->
+      strbrk "the " ++ pr_nth n ++
+      strbrk " argument of the inductive type (" ++ pr_inductive env tyi ++
+      strbrk ") of this term"
+  | Evar_kinds.GoalEvar ->
+      strbrk "an existential variable of type " ++ ty
+  | Evar_kinds.ImpossibleCase ->
+      strbrk "the type of an impossible pattern-matching clause"
+  | Evar_kinds.MatchingVar _ ->
       assert false
-
-let explain_not_clean env sigma ev t k =
-  let t = nf_evar sigma t in
-  let env = make_all_name_different env in
-  let id = Evd.string_of_existential ev in
-  let var = pr_lconstr_env env t in
-  str "Tried to instantiate " ++ explain_hole_kind env None k ++
-  str " (" ++ str id ++ str ")" ++ spc () ++
-  str "with a term using variable " ++ var ++ spc () ++
-  str "which is not in its scope."
-
-let explain_unsolvability = function
-  | None -> mt()
-  | Some (SeveralInstancesFound n) ->
-      strbrk " (several distinct possible instances found)"
-
-let explain_typeclass_resolution env evi k =
+  | Evar_kinds.VarInstance id ->
+      strbrk "an instance of type " ++ ty ++
+      str " for the variable " ++ pr_id id
+  | Evar_kinds.SubEvar evk' ->
+      let evi = Evd.find sigma evk' in
+      let pc = match evi.evar_body with
+      | Evar_defined c -> pr_lconstr_env env sigma (Evarutil.nf_evar sigma c)
+      | Evar_empty -> assert false in
+      let ty' = Evarutil.nf_evar sigma evi.evar_concl in
+      pr_existential_key sigma evk ++ str " of type " ++ ty ++
+      str " in the partial instance " ++ pc ++
+      str " found for " ++ explain_evar_kind env sigma evk'
+      (pr_lconstr_env env sigma ty') (snd evi.evar_source)
+
+let explain_typeclass_resolution env sigma evi k =
   match Typeclasses.class_of_constr evi.evar_concl with
-  | Some c ->
-    let env = Evd.evar_env evi in
+  | Some _ ->
+    let env = Evd.evar_filtered_env evi in
       fnl () ++ str "Could not find an instance for " ++
-      pr_lconstr_env env evi.evar_concl ++
-      pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env
+      pr_lconstr_env env sigma evi.evar_concl ++
+      pr_trailing_ne_context_of env sigma
   | _ -> mt()
 
-let explain_unsolvable_implicit env evi k explain =
-  str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++
-  explain_unsolvability explain ++ str "." ++
-  explain_typeclass_resolution env evi k
+let explain_placeholder_kind env sigma c e =
+  match e with
+  | Some (SeveralInstancesFound n) ->
+      strbrk " (several distinct possible type class instances found)"
+  | None ->
+      match Typeclasses.class_of_constr c with
+      | Some _ -> strbrk " (no type class instance found)"
+      | _ -> mt ()
+
+let explain_unsolvable_implicit env sigma evk explain =
+  let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in
+  let env = Evd.evar_filtered_env evi in
+  let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in
+  let pe = pr_trailing_ne_context_of env sigma in
+  strbrk "Cannot infer " ++
+  explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++
+  explain_placeholder_kind env sigma evi.evar_concl explain ++ pe
 
 let explain_var_not_found env id =
   str "The variable" ++ spc () ++ pr_id id ++
   spc () ++ str "was not found" ++
   spc () ++ str "in the current" ++ spc () ++ str "environment" ++ str "."
 
-let explain_wrong_case_info env ind ci =
+let explain_wrong_case_info env (ind,u) ci =
   let pi = pr_inductive (Global.env()) ind in
-  if ci.ci_ind = ind then
+  if eq_ind ci.ci_ind ind then
     str "Pattern-matching expression on an object of inductive type" ++
     spc () ++ pi ++ spc () ++ str "has invalid information."
   else
@@ -419,71 +599,86 @@ let explain_wrong_case_info env ind ci =
     str "was given to a pattern-matching expression on the inductive type" ++
     spc () ++ pc ++ str "."
 
-let explain_cannot_unify env sigma m n =
-  let m = nf_evar sigma m in
-  let n = nf_evar sigma n in
-  let pm = pr_lconstr_env env m in
-  let pn = pr_lconstr_env env n in
-  str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++
-  str "with" ++ brk(1,1) ++ pn ++ str "."
+let explain_cannot_unify env sigma m n e =
+  let env = make_all_name_different env in
+  let m = Evarutil.nf_evar sigma m in
+  let n = Evarutil.nf_evar sigma n in
+  let pm, pn = pr_explicit env sigma m n in
+  let ppreason = explain_unification_error env sigma m n e in
+  let pe = pr_ne_context_of (str "In environment") env sigma in
+  pe ++ str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
+  str "with" ++ brk(1,1) ++ pn ++ ppreason ++ str "."
 
 let explain_cannot_unify_local env sigma m n subn =
-  let pm = pr_lconstr_env env m in
-  let pn = pr_lconstr_env env n in
-  let psubn = pr_lconstr_env env subn in
-    str "Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++
+  let pm = pr_lconstr_env env sigma m in
+  let pn = pr_lconstr_env env sigma n in
+  let psubn = pr_lconstr_env env sigma subn in
+    str "Unable to unify" ++ brk(1,1) ++ pm ++ spc () ++
       str "with" ++ brk(1,1) ++ pn ++ spc () ++ str "as" ++ brk(1,1) ++
       psubn ++ str " contains local variables."
 
-let explain_refiner_cannot_generalize env ty =
+let explain_refiner_cannot_generalize env sigma ty =
   str "Cannot find a well-typed generalisation of the goal with type: " ++
-  pr_lconstr_env env ty ++ str "."
+  pr_lconstr_env env sigma ty ++ str "."
 
-let explain_no_occurrence_found env c id =
-  str "Found no subterm matching " ++ pr_lconstr_env env c ++
+let explain_no_occurrence_found env sigma c id =
+  str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++
   str " in " ++
     (match id with
       | Some id -> pr_id id
       | None -> str"the current goal") ++ str "."
 
-let explain_cannot_unify_binding_type env m n =
-  let pm = pr_lconstr_env env m in
-  let pn = pr_lconstr_env env n in
+let explain_cannot_unify_binding_type env sigma m n =
+  let pm = pr_lconstr_env env sigma m in
+  let pn = pr_lconstr_env env sigma n in
   str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++
   str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "."
 
-let explain_cannot_find_well_typed_abstraction env p l =
+let explain_cannot_find_well_typed_abstraction env sigma p l e =
   str "Abstracting over the " ++
-  str (plural (List.length l) "term") ++ spc () ++
-  hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++
-  str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++
-  str "which is ill-typed."
+  str (String.plural (List.length l) "term") ++ spc () ++
+  hov 0 (pr_enum (pr_lconstr_env env sigma) l) ++ spc () ++
+  str "leads to a term" ++ spc () ++ pr_lconstr_goal_style_env env sigma p ++
+  spc () ++ str "which is ill-typed." ++
+  (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e)
+
+let explain_wrong_abstraction_type env sigma na abs expected result =
+  let ppname = match na with Name id -> pr_id id ++ spc () | _ -> mt () in
+  str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++
+  pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++
+  pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++
+  pr_lconstr_env env sigma result ++ str "."
 
 let explain_abstraction_over_meta _ m n =
   strbrk "Too complex unification problem: cannot find a solution for both " ++
   pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
 
-let explain_non_linear_unification env m t =
+let explain_non_linear_unification env sigma m t =
   strbrk "Cannot unambiguously instantiate " ++
   pr_name m ++ str ":" ++
   strbrk " which would require to abstract twice on " ++
-  pr_lconstr_env env t ++ str "."
+  pr_lconstr_env env sigma t ++ str "."
+
+let explain_unsatisfied_constraints env sigma cst =
+  strbrk "Unsatisfied constraints: " ++ 
+    Univ.pr_constraints (Evd.pr_evd_level sigma) cst ++ 
+    spc () ++ str "(maybe a bugged tactic)."
 
 let explain_type_error env sigma err =
   let env = make_all_name_different env in
   match err with
   | UnboundRel n ->
-      explain_unbound_rel env n
+      explain_unbound_rel env sigma n
   | UnboundVar v ->
       explain_unbound_var env v
   | NotAType j ->
       explain_not_type env sigma j
   | BadAssumption c ->
-      explain_bad_assumption env c
-  | ReferenceVariables id ->
-      explain_reference_variables id
+      explain_bad_assumption env sigma c
+  | ReferenceVariables (id,c) ->
+      explain_reference_variables id c
   | ElimArity (ind, aritylst, c, pj, okinds) ->
-      explain_elim_arity env ind aritylst c pj okinds
+      explain_elim_arity env sigma ind aritylst c pj okinds
   | CaseNotInductive cj ->
       explain_case_not_inductive env sigma cj
   | NumberBranches (cj, n) ->
@@ -491,42 +686,128 @@ let explain_type_error env sigma err =
   | IllFormedBranch (c, i, actty, expty) ->
       explain_ill_formed_branch env sigma c i actty expty
   | Generalization (nvar, c) ->
-      explain_generalization env nvar c
+      explain_generalization env sigma nvar c
   | ActualType (j, pt) ->
-      explain_actual_type env sigma j pt
+      explain_actual_type env sigma j pt None
   | CantApplyBadType (t, rator, randl) ->
       explain_cant_apply_bad_type env sigma t rator randl
   | CantApplyNonFunctional (rator, randl) ->
       explain_cant_apply_not_functional env sigma rator randl
   | IllFormedRecBody (err, lna, i, fixenv, vdefj) ->
-      explain_ill_formed_rec_body env err lna i fixenv vdefj
+      explain_ill_formed_rec_body env sigma err lna i fixenv vdefj
   | IllTypedRecBody (i, lna, vdefj, vargs) ->
      explain_ill_typed_rec_body env sigma i lna vdefj vargs
   | WrongCaseInfo (ind,ci) ->
       explain_wrong_case_info env ind ci
+  | UnsatisfiedConstraints cst ->
+      explain_unsatisfied_constraints env sigma cst
+
+let pr_position (cl,pos) =
+  let clpos = match cl with
+    | None -> str " of the goal"
+    | Some (id,Locus.InHyp) -> str " of hypothesis " ++ pr_id id
+    | Some (id,Locus.InHypTypeOnly) -> str " of the type of hypothesis " ++ pr_id id
+    | Some (id,Locus.InHypValueOnly) -> str " of the body of hypothesis " ++ pr_id id in
+  int pos ++ clpos
+
+let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1),t1) e =
+  if nested then
+    str "Found nested occurrences of the pattern at positions " ++
+    int pos1 ++ strbrk " and " ++ pr_position (cl2,pos2) ++ str "."
+  else
+    let ppreason = match e with None -> mt() | Some (c1,c2,e) -> explain_unification_error env sigma c1 c2 (Some e) in
+    str "Found incompatible occurrences of the pattern" ++ str ":" ++
+    spc () ++ str "Matched term " ++ pr_lconstr_env env sigma t2 ++
+    strbrk " at position " ++ pr_position (cl2,pos2) ++
+    strbrk " is not compatible with matched term " ++
+    pr_lconstr_env env sigma t1 ++ strbrk " at position " ++
+    pr_position (cl1,pos1) ++ ppreason ++ str "."
+
+let pr_constraints printenv env sigma evars cstrs =
+  let (ev, evi) = Evar.Map.choose evars in
+    if Evar.Map.for_all (fun ev' evi' ->
+      eq_named_context_val evi.evar_hyps evi'.evar_hyps) evars
+    then
+      let l = Evar.Map.bindings evars in
+      let env' = reset_with_named_context evi.evar_hyps env in
+      let pe =
+        if printenv then
+          pr_ne_context_of (str "In environment:") env' sigma
+        else mt ()
+      in
+      let evs =
+        prlist
+        (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++
+            str " : " ++ pr_lconstr_env env' sigma evi.evar_concl) l
+      in
+      h 0 (pe ++ evs ++ pr_evar_constraints cstrs)
+    else
+      let filter evk _ = Evar.Map.mem evk evars in
+      pr_evar_map_filter ~with_univs:false filter sigma
+
+let explain_unsatisfiable_constraints env sigma constr comp =
+  let (_, constraints) = Evd.extract_all_conv_pbs sigma in
+  let undef = Evd.undefined_map (Evarutil.nf_evar_map_undefined sigma) in
+  (** Only keep evars that are subject to resolution and members of the given
+     component. *)
+  let is_kept evk evi = match comp with
+  | None -> Typeclasses.is_resolvable evi
+  | Some comp -> Typeclasses.is_resolvable evi && Evar.Set.mem evk comp
+  in
+  let undef = 
+    let m = Evar.Map.filter is_kept undef in
+      if Evar.Map.is_empty m then undef
+      else m
+  in
+  match constr with
+  | None ->
+    str "Unable to satisfy the following constraints:" ++ fnl () ++
+    pr_constraints true env sigma undef constraints
+  | Some (ev, k) ->
+    let cstr =
+      let remaining = Evar.Map.remove ev undef in
+      if not (Evar.Map.is_empty remaining) then
+        str "With the following constraints:" ++ fnl () ++
+          pr_constraints false env sigma remaining constraints
+      else mt ()
+    in
+    let info = Evar.Map.find ev undef in
+    explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr
 
 let explain_pretype_error env sigma err =
-  let env = env_nf_betaiotaevar sigma env in
+  let env = Evarutil.env_nf_betaiotaevar sigma env in
   let env = make_all_name_different env in
   match err with
   | CantFindCaseType c -> explain_cant_find_case_type env sigma c
-  | OccurCheck (n,c) -> explain_occur_check env sigma n c
-  | NotClean (n,c,k) -> explain_not_clean env sigma n c k
-  | UnsolvableImplicit (evi,k,exp) -> explain_unsolvable_implicit env evi k exp
+  | ActualTypeNotCoercible (j,t,e) ->
+    let {uj_val = c; uj_type = actty} = j in
+    let (env, c, actty, expty), e = contract3' env c actty t e in
+    let j = {uj_val = c; uj_type = actty} in
+    explain_actual_type env sigma j t (Some e)
+  | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs
+  | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp
   | VarNotFound id -> explain_var_not_found env id
-  | UnexpectedType (actual,expect) -> explain_unexpected_type env sigma actual expect
+  | UnexpectedType (actual,expect) ->
+    let env, actual, expect = contract2 env actual expect in
+    explain_unexpected_type env sigma actual expect
   | NotProduct c -> explain_not_product env sigma c
-  | CannotUnify (m,n) -> explain_cannot_unify env sigma m n
+  | CannotUnify (m,n,e) ->
+    let env, m, n = contract2 env m n in
+    explain_cannot_unify env sigma m n e
   | CannotUnifyLocal (m,n,sn) -> explain_cannot_unify_local env sigma m n sn
-  | CannotGeneralize ty -> explain_refiner_cannot_generalize env ty
-  | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env c id
-  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env m n
-  | CannotFindWellTypedAbstraction (p,l) ->
-      explain_cannot_find_well_typed_abstraction env p l
+  | CannotGeneralize ty -> explain_refiner_cannot_generalize env sigma ty
+  | NoOccurrenceFound (c, id) -> explain_no_occurrence_found env sigma c id
+  | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type env sigma m n
+  | CannotFindWellTypedAbstraction (p,l,e) ->
+      explain_cannot_find_well_typed_abstraction env sigma p l
+        (Option.map (fun (env',e) -> explain_type_error env' sigma e) e)
+  | WrongAbstractionType (n,a,t,u) ->
+      explain_wrong_abstraction_type env sigma n a t u
   | AbstractionOverMeta (m,n) -> explain_abstraction_over_meta env m n
-  | NonLinearUnification (m,c) -> explain_non_linear_unification env m c
+  | NonLinearUnification (m,c) -> explain_non_linear_unification env sigma m c
   | TypingError t -> explain_type_error env sigma t
-
+  | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e
+  | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp
 (* Module errors *)
 
 open Modops
@@ -541,14 +822,14 @@ let explain_not_match_error = function
   | ModuleTypeFieldExpected ->
     strbrk "a module type is expected"
   | NotConvertibleInductiveField id | NotConvertibleConstructorField id ->
-    str "types given to " ++ str (string_of_id id) ++ str " differ"
+    str "types given to " ++ str (Id.to_string id) ++ str " differ"
   | NotConvertibleBodyField ->
     str "the body of definitions differs"
   | NotConvertibleTypeField (env, typ1, typ2) ->
     str "expected type" ++ spc ()  ++
-    quote (Printer.safe_pr_lconstr_env env typ2) ++ spc () ++
+    quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++
     str "but found type" ++ spc () ++
-    quote (Printer.safe_pr_lconstr_env env typ1)
+    quote (Printer.safe_pr_lconstr_env env Evd.empty typ1)
   | NotSameConstructorNamesField ->
     str "constructor names differ"
   | NotSameInductiveNameInBlockField ->
@@ -566,24 +847,45 @@ let explain_not_match_error = function
   | RecordProjectionsExpected nal ->
     (if List.length nal >= 2 then str "expected projection names are "
      else str "expected projection name is ") ++
-    pr_enum (function Name id -> str (string_of_id id) | _ -> str "_") nal
+    pr_enum (function Name id -> str (Id.to_string id) | _ -> str "_") nal
   | NotEqualInductiveAliases ->
     str "Aliases to inductive types do not match"
   | NoTypeConstraintExpected ->
-    strbrk "a definition whose type is constrained can only be subtype of a definition whose type is itself constrained"
+    strbrk "a definition whose type is constrained can only be subtype " ++
+    strbrk "of a definition whose type is itself constrained"
+  | PolymorphicStatusExpected b ->
+    let status b = if b then str"polymorphic" else str"monomorphic" in
+      str "a " ++ status b ++ str" declaration was expected, but a " ++ 
+	status (not b) ++ str" declaration was found"
+  | IncompatibleInstances -> 
+    str"polymorphic universe instances do not match"
+  | IncompatibleUniverses incon ->
+    str"the universe constraints are inconsistent: " ++
+      Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon
+  | IncompatiblePolymorphism (env, t1, t2) ->
+    str "conversion of polymorphic values generates additional constraints: " ++
+      quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++
+      str "compared to " ++ spc () ++
+      quote (Printer.safe_pr_lconstr_env env Evd.empty t2)
+  | IncompatibleConstraints cst ->
+    str " the expected (polymorphic) constraints do not imply " ++
+      quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst)
 
 let explain_signature_mismatch l spec why =
-  str "Signature components for label " ++ str (string_of_label l) ++
+  str "Signature components for label " ++ str (Label.to_string l) ++
   str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "."
 
 let explain_label_already_declared l =
-  str ("The label "^string_of_label l^" is already declared.")
+  str ("The label "^Label.to_string l^" is already declared.")
 
 let explain_application_to_not_path _ =
   str "Application of modules is restricted to paths."
 
-let explain_not_a_functor mtb =
-  str "Application of not a functor."
+let explain_not_a_functor () =
+  str "Application of a non-functor."
+
+let explain_is_a_functor () =
+  str "Illegal use of a functor."
 
 let explain_incompatible_module_types mexpr1 mexpr2 =
   str "Incompatible module types."
@@ -592,20 +894,11 @@ let explain_not_equal_module_paths mp1 mp2 =
   str "Non equal modules."
 
 let explain_no_such_label l =
-  str "No such label " ++ str (string_of_label l) ++ str "."
+  str "No such label " ++ str (Label.to_string l) ++ str "."
 
 let explain_incompatible_labels l l' =
   str "Opening and closing labels are not the same: " ++
-  str (string_of_label l) ++ str " <> " ++ str (string_of_label l') ++ str "!"
-
-let explain_signature_expected mtb =
-  str "Signature expected."
-
-let explain_no_module_to_end () =
-  str "No open module to end."
-
-let explain_no_module_type_to_end () =
-  str "No open module type to end."
+  str (Label.to_string l) ++ str " <> " ++ str (Label.to_string l') ++ str "!"
 
 let explain_not_a_module s =
   quote (str s) ++ str " is not a module."
@@ -614,45 +907,41 @@ let explain_not_a_module_type s =
   quote (str s) ++ str " is not a module type."
 
 let explain_not_a_constant l =
-  quote (pr_label l) ++ str " is not a constant."
+  quote (Label.print l) ++ str " is not a constant."
 
 let explain_incorrect_label_constraint l =
   str "Incorrect constraint for label " ++
-  quote (pr_label l) ++ str "."
+  quote (Label.print l) ++ str "."
 
 let explain_generative_module_expected l =
-  str "The module " ++ str (string_of_label l) ++
-  strbrk " is not generative. Only components of generative modules can be changed using the \"with\" construct."
-
-let explain_non_empty_local_context = function
-  | None -> str "The local context is not empty."
-  | Some l ->
-      str "The local context of the component " ++
-      str (string_of_label l) ++ str " is not empty."
+  str "The module " ++ str (Label.to_string l) ++ str " is not generative." ++
+  strbrk " Only components of generative modules can be changed" ++
+  strbrk " using the \"with\" construct."
 
 let explain_label_missing l s =
-  str "The field " ++ str (string_of_label l) ++ str " is missing in "
+  str "The field " ++ str (Label.to_string l) ++ str " is missing in "
   ++ str s ++ str "."
 
+let explain_higher_order_include () =
+  str "You cannot Include a higher-order structure."
+
 let explain_module_error = function
   | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err
   | LabelAlreadyDeclared l -> explain_label_already_declared l
   | ApplicationToNotPath mexpr -> explain_application_to_not_path mexpr
-  | NotAFunctor mtb -> explain_not_a_functor mtb
+  | NotAFunctor -> explain_not_a_functor ()
+  | IsAFunctor -> explain_is_a_functor ()
   | IncompatibleModuleTypes (m1,m2) -> explain_incompatible_module_types m1 m2
   | NotEqualModulePaths (mp1,mp2) -> explain_not_equal_module_paths mp1 mp2
   | NoSuchLabel l -> explain_no_such_label l
   | IncompatibleLabels (l1,l2) -> explain_incompatible_labels l1 l2
-  | SignatureExpected mtb -> explain_signature_expected mtb
-  | NoModuleToEnd -> explain_no_module_to_end ()
-  | NoModuleTypeToEnd -> explain_no_module_type_to_end ()
   | NotAModule s -> explain_not_a_module s
   | NotAModuleType s -> explain_not_a_module_type s
   | NotAConstant l -> explain_not_a_constant l
   | IncorrectWithConstraint l -> explain_incorrect_label_constraint l
   | GenerativeModuleExpected l -> explain_generative_module_expected l
-  | NonEmptyLocalContect lopt -> explain_non_empty_local_context lopt
   | LabelMissing (l,s) -> explain_label_missing l s
+  | HigherOrderInclude -> explain_higher_order_include ()
 
 (* Module internalization errors *)
 
@@ -681,72 +970,27 @@ let explain_module_internalization_error = function
 (* Typeclass errors *)
 
 let explain_not_a_class env c =
-  pr_constr_env env c ++ str" is not a declared type class."
+  pr_constr_env env Evd.empty c ++ str" is not a declared type class."
 
 let explain_unbound_method env cid id =
-  str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++
-    pr_global cid ++ str "."
+  str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++
+  str"of class" ++ spc () ++ pr_global cid ++ str "."
 
 let pr_constr_exprs exprs =
   hv 0 (List.fold_right
 	 (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps)
          exprs (mt ()))
 
-let explain_no_instance env (_,id) l =
-  str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++
-  str "applied to arguments" ++ spc () ++
-    prlist_with_sep pr_spc (pr_lconstr_env env) l
-
-let is_goal_evar evi = match evi.evar_source with (_, GoalEvar) -> true | _ -> false
-
-let pr_constraints printenv env evm =
-  let l = Evd.to_list evm in
-  assert(l <> []);
-  let (ev, evi) = List.hd l in
-    if List.for_all (fun (ev', evi') ->
-      eq_named_context_val evi.evar_hyps evi'.evar_hyps) l
-    then
-      let pe = pr_ne_context_of (str "In environment:") (mt ())
-	(reset_with_named_context evi.evar_hyps env) in
-	(if printenv then pe ++ fnl () else mt ()) ++
-	  prlist_with_sep (fun () -> fnl ())
-	  (fun (ev, evi) -> str(string_of_existential ev) ++ 
-	     str " : " ++ pr_lconstr evi.evar_concl) l ++ fnl() ++
-	  pr_evar_map_constraints evm
-    else
-      pr_evar_map None evm
-
-let explain_unsatisfiable_constraints env evd constr =
-  let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evd) in
-  (* Remove goal evars *)
-  let undef = fold_undefined 
-    (fun ev evi evm' -> 
-       if is_goal_evar evi then Evd.remove evm' ev else evm') evm evm
-  in
-  match constr with
-  | None ->
-      str"Unable to satisfy the following constraints:" ++ fnl() ++
-	pr_constraints true env undef
-  | Some (ev, k) ->
-      explain_typeclass_resolution env (Evd.find evm ev) k ++ fnl () ++
-	(let remaining = Evd.remove undef ev in
-	   if Evd.has_undefined remaining then
-	     str"With the following constraints:" ++ fnl() ++
-	       pr_constraints false env remaining
-	   else mt ())
-
 let explain_mismatched_contexts env c i j =
   str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++
-    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++
+    hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++
+    fnl () ++ brk (1,1) ++
     hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i)
 
-let explain_typeclass_error env err =
-  match err with
-    | NotAClass c -> explain_not_a_class env c
-    | UnboundMethod (cid, id) -> explain_unbound_method env cid id
-    | NoInstance (id, l) -> explain_no_instance env id l
-    | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c
-    | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j
+let explain_typeclass_error env = function
+  | NotAClass c -> explain_not_a_class env c
+  | UnboundMethod (cid, id) -> explain_unbound_method env cid id
+  | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j
 
 (* Refiner errors *)
 
@@ -758,7 +1002,7 @@ let explain_refiner_bad_type arg ty conclty =
 
 let explain_refiner_unresolved_bindings l =
   str "Unable to find an instance for the " ++
-  str (plural (List.length l) "variable") ++ spc () ++
+  str (String.plural (List.length l) "variable") ++ spc () ++
   prlist_with_sep pr_comma pr_name l ++ str"."
 
 let explain_refiner_cannot_apply t harg =
@@ -784,6 +1028,9 @@ let explain_meta_in_type c =
   str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++
   str " of another meta"
 
+let explain_no_such_hyp id =
+  str "No such hypothesis: " ++ pr_id id
+
 let explain_refiner_error = function
   | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty
   | UnresolvedBindings t -> explain_refiner_unresolved_bindings t
@@ -793,50 +1040,51 @@ let explain_refiner_error = function
   | DoesNotOccurIn (c,hyp) -> explain_does_not_occur_in c hyp
   | NonLinearProof c -> explain_non_linear_proof c
   | MetaInType c -> explain_meta_in_type c
+  | NoSuchHyp id -> explain_no_such_hyp id
 
 (* Inductive errors *)
 
-let error_non_strictly_positive env c v  =
-  let pc = pr_lconstr_env env c in
-  let pv = pr_lconstr_env env v in
+let error_non_strictly_positive env c v =
+  let pc = pr_lconstr_env env Evd.empty c in
+  let pv = pr_lconstr_env env Evd.empty v in
   str "Non strictly positive occurrence of " ++ pv ++ str " in" ++
   brk(1,1) ++ pc ++ str "."
 
 let error_ill_formed_inductive env c v =
-  let pc = pr_lconstr_env env c in
-  let pv = pr_lconstr_env env v in
+  let pc = pr_lconstr_env env Evd.empty c in
+  let pv = pr_lconstr_env env Evd.empty v in
   str "Not enough arguments applied to the " ++ pv ++
   str " in" ++ brk(1,1) ++ pc ++ str "."
 
 let error_ill_formed_constructor env id c v nparams nargs =
-  let pv = pr_lconstr_env env v in
-  let atomic = (nb_prod c = 0) in
+  let pv = pr_lconstr_env env Evd.empty v in
+  let atomic = Int.equal (nb_prod c) 0 in
   str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++
   str "is not valid;" ++ brk(1,1) ++
   strbrk (if atomic then "it must be " else "its conclusion must be ") ++
   pv ++
   (* warning: because of implicit arguments it is difficult to say which
      parameters must be explicitly given *)
-  (if nparams<>0 then
-    strbrk " applied to its " ++ str (plural nparams "parameter")
+  (if not (Int.equal nparams 0) then
+    strbrk " applied to its " ++ str (String.plural nparams "parameter")
   else
     mt()) ++
-  (if nargs<>0 then
-     str (if nparams<>0 then " and" else " applied") ++
-     strbrk " to some " ++ str (plural nargs "argument")
+  (if not (Int.equal nargs 0) then
+     str (if not (Int.equal nparams 0) then " and" else " applied") ++
+     strbrk " to some " ++ str (String.plural nargs "argument")
    else
      mt()) ++ str "."
 
 let pr_ltype_using_barendregt_convention_env env c =
   (* Use goal_concl_style as an approximation of Barendregt's convention (?) *)
-  quote (pr_goal_concl_style_env env c)
+  quote (pr_goal_concl_style_env env Evd.empty c)
 
 let error_bad_ind_parameters env c n v1 v2  =
   let pc = pr_ltype_using_barendregt_convention_env env c in
-  let pv1 = pr_lconstr_env env v1 in
-  let pv2 = pr_lconstr_env env v2 in
+  let pv1 = pr_lconstr_env env Evd.empty v1 in
+  let pv2 = pr_lconstr_env env Evd.empty v2 in
   str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++
-  str " as " ++ nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "."
+  str " as " ++ pr_nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "."
 
 let error_same_names_types id =
   str "The name" ++ spc () ++ pr_id id ++ spc () ++
@@ -852,7 +1100,8 @@ let error_same_names_overlap idl =
   prlist_with_sep pr_comma pr_id idl ++ str "."
 
 let error_not_an_arity env c =
-  str "The type" ++ spc () ++ pr_lconstr_env env c ++ spc () ++ str "is not an arity."
+  str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++
+  str "is not an arity."
 
 let error_bad_entry () =
   str "Bad inductive definition."
@@ -864,12 +1113,12 @@ let error_large_non_prop_inductive_not_in_type () =
 
 let error_not_allowed_case_analysis isrec kind i =
   str (if isrec then "Induction" else "Case analysis") ++
-  strbrk " on sort " ++ pr_sort kind ++
+  strbrk " on sort " ++ pr_sort Evd.empty kind ++
   strbrk " is not allowed for inductive definition " ++
-  pr_inductive (Global.env()) i ++ str "."
+  pr_inductive (Global.env()) (fst i) ++ str "."
 
 let error_not_mutual_in_scheme ind ind' =
-  if ind = ind' then
+  if eq_ind ind ind' then
     str "The inductive type " ++ pr_inductive (Global.env()) ind ++
     str " occurs twice."
   else
@@ -890,7 +1139,8 @@ let explain_inductive_error = function
   | SameNamesOverlap idl -> error_same_names_overlap idl
   | NotAnArity (env, c) -> error_not_an_arity env c
   | BadEntry -> error_bad_entry ()
-  | LargeNonPropInductiveNotInType -> error_large_non_prop_inductive_not_in_type ()
+  | LargeNonPropInductiveNotInType ->
+      error_large_non_prop_inductive_not_in_type ()
 
 (* Recursion schemes errors *)
 
@@ -901,9 +1151,9 @@ let explain_recursion_scheme_error = function
 
 (* Pattern-matching errors *)
 
-let explain_bad_pattern env cstr ty =
+let explain_bad_pattern env sigma cstr ty =
   let env = make_all_name_different env in
-  let pt = pr_lconstr_env env ty in
+  let pt = pr_lconstr_env env sigma ty in
   let pc = pr_constructor env cstr in
   str "Found the constructor " ++ pc ++ brk(1,1) ++
   str "while matching a term of type " ++ pt ++ brk(1,1) ++
@@ -918,128 +1168,134 @@ let explain_bad_constructor env cstr ind =
   str "is expected."
 
 let decline_string n s =
-  if n = 0 then "no "^s^"s"
-  else if n = 1 then "1 "^s
+  if Int.equal n 0 then "no "^s^"s"
+  else if Int.equal n 1 then "1 "^s
   else (string_of_int n^" "^s^"s")
 
 let explain_wrong_numarg_constructor env cstr n =
   str "The constructor " ++ pr_constructor env cstr ++
-  str " expects " ++ str (decline_string n "argument") ++ str "."
+  str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++
+  str ") expects " ++ str (decline_string n "argument") ++ str "."
 
 let explain_wrong_numarg_inductive env ind n =
   str "The inductive type " ++ pr_inductive env ind ++
   str " expects " ++ str (decline_string n "argument") ++ str "."
 
-let explain_wrong_predicate_arity env pred nondep_arity dep_arity=
-  let env = make_all_name_different env in
-  let pp = pr_lconstr_env env pred in
-  str "The elimination predicate " ++ spc () ++ pp ++ fnl () ++
-  str "should be of arity" ++ spc () ++
-  pr_lconstr_env env nondep_arity ++ spc () ++
-  str "(for non dependent case) or" ++
-  spc () ++ pr_lconstr_env env dep_arity ++ spc () ++ str "(for dependent case)."
-
-let explain_needs_inversion env x t =
-  let env = make_all_name_different env in
-  let px = pr_lconstr_env env x in
-  let pt = pr_lconstr_env env t in
-  str "Sorry, I need inversion to compile pattern matching on term " ++
-  px ++ str " of type: " ++ pt ++ str "."
-
 let explain_unused_clause env pats =
 (* Without localisation
   let s = if List.length pats > 1 then "s" else "" in
   (str ("Unused clause with pattern"^s) ++ spc () ++
-    hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats) ++ str ")")
+    hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")")
 *)
   str "This clause is redundant."
 
 let explain_non_exhaustive env pats =
   str "Non exhaustive pattern-matching: no clause found for " ++
-  str (plural (List.length pats) "pattern") ++
-  spc () ++ hov 0 (prlist_with_sep pr_spc pr_cases_pattern pats)
+  str (String.plural (List.length pats) "pattern") ++
+  spc () ++ hov 0 (pr_sequence pr_cases_pattern pats)
 
-let explain_cannot_infer_predicate env typs =
+let explain_cannot_infer_predicate env sigma typs =
   let env = make_all_name_different env in
   let pr_branch (cstr,typ) =
     let cstr,_ = decompose_app cstr in
-    str "For " ++ pr_lconstr_env env cstr ++ str ": " ++ pr_lconstr_env env typ
+    str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ
   in
   str "Unable to unify the types found in the branches:" ++
-  spc () ++ hov 0 (prlist_with_sep pr_fnl pr_branch (Array.to_list typs))
+  spc () ++ hov 0 (prlist_with_sep fnl pr_branch (Array.to_list typs))
 
-let explain_pattern_matching_error env = function
+let explain_pattern_matching_error env sigma = function
   | BadPattern (c,t) ->
-      explain_bad_pattern env c t
+      explain_bad_pattern env sigma c t
   | BadConstructor (c,ind) ->
       explain_bad_constructor env c ind
   | WrongNumargConstructor (c,n) ->
       explain_wrong_numarg_constructor env c n
   | WrongNumargInductive (c,n) ->
       explain_wrong_numarg_inductive env c n
-  | WrongPredicateArity (pred,n,dep) ->
-      explain_wrong_predicate_arity env pred n dep
-  | NeedsInversion (x,t) ->
-      explain_needs_inversion env x t
   | UnusedClause tms ->
       explain_unused_clause env tms
   | NonExhaustive tms ->
       explain_non_exhaustive env tms
   | CannotInferPredicate typs ->
-      explain_cannot_infer_predicate env typs
+      explain_cannot_infer_predicate env sigma typs
 
 let explain_reduction_tactic_error = function
-  | Tacred.InvalidAbstraction (env,c,(env',e)) ->
+  | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) ->
       str "The abstracted term" ++ spc () ++
-      quote (pr_goal_concl_style_env env c) ++
+      quote (pr_goal_concl_style_env env sigma c) ++
       spc () ++ str "is not well typed." ++ fnl () ++
       explain_type_error env' Evd.empty e
 
-let explain_ltac_call_trace (nrep,last,trace,loc) =
-  let calls =
-    (nrep,last) :: List.rev (List.map(fun(n,_,ck)->(n,ck))trace) in
-  let tacexpr_differ te te' =
-    (* NB: The following comparison may raise an exception
-       since a tacexpr may embed a functional part via a TacExtend *)
-    try te <> te' with Invalid_argument _ -> false
+let is_defined_ltac trace =
+  let rec aux = function
+  | (_, Proof_type.LtacNameCall f) :: tail ->
+      not (Tacenv.is_ltac_for_ml_tactic f)
+  | (_, Proof_type.LtacAtomCall _) :: tail ->
+      false
+  | _ :: tail -> aux tail
+  | [] -> false in
+  aux (List.rev trace)
+
+let explain_ltac_call_trace last trace loc =
+  let calls = last :: List.rev_map snd trace in
+  let pr_call ck = match ck with
+  | Proof_type.LtacNotationCall kn -> quote (KerName.print kn)
+  | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
+  | Proof_type.LtacMLCall t ->
+      quote (Pptactic.pr_glob_tactic (Global.env()) t)
+  | Proof_type.LtacVarCall (id,t) ->
+      quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
+        Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
+  | Proof_type.LtacAtomCall te ->
+      quote (Pptactic.pr_glob_tactic (Global.env())
+              (Tacexpr.TacAtom (Loc.ghost,te)))
+  | Proof_type.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) ->
+      quote (pr_glob_constr_env (Global.env()) c) ++
+        (if not (Id.Map.is_empty vars) then
+          strbrk " (with " ++
+            prlist_with_sep pr_comma
+            (fun (id,c) ->
+                pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c)
+            (List.rev (Id.Map.bindings vars)) ++ str ")"
+        else mt())
   in
-  let pr_call (n,ck) =
-    (match ck with
-       | Proof_type.LtacNotationCall s -> quote (str s)
-       | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst)
-       | Proof_type.LtacVarCall (id,t) ->
-	   quote (Nameops.pr_id id) ++ strbrk " (bound to " ++
-	     Pptactic.pr_glob_tactic (Global.env()) t ++ str ")"
-       | Proof_type.LtacAtomCall (te,otac) -> quote
-	   (Pptactic.pr_glob_tactic (Global.env())
-	      (Tacexpr.TacAtom (dummy_loc,te)))
-	   ++ (match !otac with
-		 | Some te' when tacexpr_differ (Obj.magic te') te ->
-		   strbrk " (expanded to " ++ quote
-		     (Pptactic.pr_tactic (Global.env())
-			(Tacexpr.TacAtom (dummy_loc,te')))
-		   ++ str ")"
-		 | _ -> mt ())
-       | Proof_type.LtacConstrInterp (c,(vars,unboundvars)) ->
-	   let filter =
-	     function (id,None) -> None | (id,Some id') -> Some(id,([],mkVar id')) in
-	   let unboundvars = list_map_filter filter unboundvars in
-	   quote (pr_glob_constr_env (Global.env()) c) ++
-	     (if unboundvars <> [] or vars <> [] then
-		strbrk " (with " ++
-		  prlist_with_sep pr_comma
-		  (fun (id,c) ->
-		     pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c)
-		  (List.rev vars @ unboundvars) ++ str ")"
-	      else mt())) ++
-      (if n=2 then str " (repeated twice)"
-       else if n>2 then str " (repeated "++int n++str" times)"
-       else mt()) in
-    if calls <> [] then
-      let kind_of_last_call = match list_last calls with
-    | (_,Proof_type.LtacConstrInterp _) -> ", last term evaluation failed."
-    | _ -> ", last call failed." in
+  match calls with
+  | [] -> mt ()
+  | _ ->
+    let kind_of_last_call = match List.last calls with
+    | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed."
+    | _ -> ", last call failed."
+    in
     hov 0 (str "In nested Ltac calls to " ++
            pr_enum pr_call calls ++ strbrk kind_of_last_call)
+
+let skip_extensions trace =
+  let rec aux = function
+  | (_,Proof_type.LtacNameCall f as tac) :: _ 
+      when Tacenv.is_ltac_for_ml_tactic f -> [tac]
+  | (_,(Proof_type.LtacNotationCall _ | Proof_type.LtacMLCall _) as tac)
+      :: _ -> [tac]
+  | t :: tail -> t :: aux tail
+  | [] -> [] in
+  List.rev (aux (List.rev trace))
+
+let extract_ltac_trace trace eloc =
+  let trace = skip_extensions trace in
+  let (loc,c),tail = List.sep_last trace in
+  if is_defined_ltac trace then
+    (* We entered a user-defined tactic,
+       we display the trace with location of the call *)
+    let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in
+    Some msg, loc
   else
-    mt ()
+    (* We entered a primitive tactic, we don't display trace but
+       report on the finest location *)
+    let best_loc =
+      if not (Loc.is_ghost eloc) then eloc else
+        (* trace is with innermost call coming first *)
+        let rec aux = function
+        | (loc,_)::tail when not (Loc.is_ghost loc) -> loc
+        | _::tail -> aux tail
+        | [] -> Loc.ghost in
+        aux trace in
+    None, best_loc
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
index b478497b..3d5442bb 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -1,13 +1,12 @@
 (************************************************************************)
 (*  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 Names
 open Indtypes
 open Environ
 open Type_errors
@@ -32,14 +31,13 @@ val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds
 val explain_refiner_error : refiner_error -> std_ppcmds
 
 val explain_pattern_matching_error :
-  env -> pattern_matching_error -> std_ppcmds
+  env -> Evd.evar_map -> pattern_matching_error -> std_ppcmds
 
 val explain_reduction_tactic_error :
   Tacred.reduction_tactic_error -> std_ppcmds
 
-val explain_ltac_call_trace :
-  int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc ->
-  std_ppcmds
+val extract_ltac_trace :
+  Proof_type.ltac_trace -> Loc.t -> std_ppcmds option * Loc.t
 
 val explain_module_error : Modops.module_typing_error -> std_ppcmds
 
diff --git a/toplevel/ide_intf.ml b/toplevel/ide_intf.ml
deleted file mode 100644
index cbb60b06..00000000
--- a/toplevel/ide_intf.ml
+++ /dev/null
@@ -1,713 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(** Protocol version of this file. This is the date of the last modification. *)
-
-(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
-
-let protocol_version = "20130425~2"
-
-(** * Interface of calls to Coq by CoqIde *)
-
-open Xml_parser
-open Interface
-
-type xml = Xml_parser.xml
-
-(** We use phantom types and GADT to protect ourselves against wild casts *)
-
-type 'a call =
-  | Interp     of interp_sty
-  | Rewind     of rewind_sty
-  | Goal       of goals_sty
-  | Evars      of evars_sty
-  | Hints      of hints_sty
-  | Status     of status_sty
-  | Search     of search_sty
-  | GetOptions of get_options_sty
-  | SetOptions of set_options_sty
-  | InLoadPath of inloadpath_sty
-  | MkCases    of mkcases_sty
-  | Quit       of quit_sty
-  | About      of about_sty
-
-type unknown
-
-(** The actual calls *)
-
-let interp x      : interp_rty call      = Interp x
-let rewind x      : rewind_rty call      = Rewind x
-let goals x       : goals_rty call       = Goal x
-let evars x       : evars_rty call       = Evars x
-let hints x       : hints_rty call       = Hints x
-let status x      : status_rty call      = Status x
-let get_options x : get_options_rty call = GetOptions x
-let set_options x : set_options_rty call = SetOptions x
-let inloadpath x  : inloadpath_rty call  = InLoadPath x
-let mkcases x     : mkcases_rty call     = MkCases x
-let search x      : search_rty call      = Search x
-let quit x        : quit_rty call        = Quit x
-
-(** * Coq answers to CoqIde *)
-
-let abstract_eval_call handler (c : 'a call) =
-  let mkGood x : 'a value = Good (Obj.magic x) in
-  try
-    match c with
-      | Interp x     -> mkGood (handler.interp x)
-      | Rewind x     -> mkGood (handler.rewind x)
-      | Goal x       -> mkGood (handler.goals x)
-      | Evars x      -> mkGood (handler.evars x)
-      | Hints x      -> mkGood (handler.hints x)
-      | Status x     -> mkGood (handler.status x)
-      | Search x     -> mkGood (handler.search x)
-      | GetOptions x -> mkGood (handler.get_options x)
-      | SetOptions x -> mkGood (handler.set_options x)
-      | InLoadPath x -> mkGood (handler.inloadpath x)
-      | MkCases x    -> mkGood (handler.mkcases x)
-      | Quit x       -> mkGood (handler.quit x)
-      | About x      -> mkGood (handler.about x)
-  with any ->
-    Fail (handler.handle_exn any)
-
-(* To read and typecheck the answers we give a description of the types,
-   and a way to statically check that the reified version is in sync *)
-module ReifType : sig
-
-  type 'a val_t
-
-  val unit_t         : unit val_t
-  val string_t       : string val_t
-  val int_t          : int val_t
-  val bool_t         : bool val_t
-  val goals_t        : goals val_t
-  val evar_t         : evar val_t
-  val state_t        : status val_t
-  val coq_info_t     : coq_info val_t
-  val option_state_t : option_state val_t
-  val option_t       : 'a val_t -> 'a option val_t
-  val list_t         : 'a val_t -> 'a list val_t
-  val coq_object_t   : 'a val_t -> 'a coq_object val_t
-  val pair_t         : 'a val_t -> 'b val_t -> ('a * 'b) val_t
-  val union_t        : 'a val_t -> 'b val_t -> ('a ,'b) Util.union val_t
-
-  type value_type = private
-    | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info
-    | Option of value_type
-    | List of value_type
-    | Coq_object of value_type
-    | Pair of value_type * value_type
-    | Union of value_type * value_type
-
-  val check : 'a val_t -> value_type
-
-end = struct
-
-  type value_type =
-    | Unit | String | Int | Bool | Goals | Evar | State | Option_state | Coq_info
-    | Option of value_type
-    | List of value_type
-    | Coq_object of value_type
-    | Pair of value_type * value_type
-    | Union of value_type * value_type
-
-  type 'a val_t = value_type
-  let check x = x
-
-  let unit_t         = Unit
-  let string_t       = String
-  let int_t          = Int
-  let bool_t         = Bool
-  let goals_t        = Goals
-  let evar_t         = Evar
-  let state_t        = State
-  let coq_info_t     = Coq_info
-  let option_state_t = Option_state
-  let option_t x     = Option x
-  let list_t x       = List x
-  let coq_object_t x = Coq_object x
-  let pair_t x y     = Pair (x, y)
-  let union_t x y    = Union (x, y)
-
-end
-
-open ReifType
-
-(* For every (call : 'a call), we build the reification of 'a.
- * In OCaml 4 we could use GATDs to do that I guess *)
-let expected_answer_type call : value_type =
-  let hint = list_t (pair_t string_t string_t) in
-  let hints = pair_t (list_t hint) hint in
-  let options = pair_t (list_t string_t) option_state_t in
-  let objs = coq_object_t string_t in
-  match call with
-  | Interp _     -> check (string_t                     : interp_rty      val_t)
-  | Rewind _     -> check (int_t                        : rewind_rty      val_t)
-  | Goal _       -> check (option_t goals_t             : goals_rty       val_t)
-  | Evars _      -> check (option_t (list_t evar_t)     : evars_rty       val_t)
-  | Hints  _     -> check (option_t hints               : hints_rty       val_t)
-  | Status _     -> check (state_t                      : status_rty      val_t)
-  | Search _     -> check (list_t objs                  : search_rty      val_t)
-  | GetOptions _ -> check (list_t options               : get_options_rty val_t)
-  | SetOptions _ -> check (unit_t                       : set_options_rty val_t)
-  | InLoadPath _ -> check (bool_t                       : inloadpath_rty  val_t)
-  | MkCases _    -> check (list_t (list_t string_t)     : mkcases_rty     val_t)
-  | Quit _       -> check (unit_t                       : quit_rty        val_t)
-  | About _      -> check (coq_info_t                   : about_rty       val_t)
-
-(** * XML data marshalling *)
-
-exception Marshal_error
-
-(** Utility functions *)
-
-let massoc x l =
-  try List.assoc x l
-  with Not_found -> raise Marshal_error
-
-let constructor t c args = Element (t, ["val", c], args)
-
-let do_match constr t mf = match constr with
-| Element (s, attrs, args) ->
-  if s = t then
-    let c = massoc "val" attrs in
-    mf c args
-  else raise Marshal_error
-| _ -> raise Marshal_error
-
-let singleton = function
-| [x] -> x
-| _ -> raise Marshal_error
-
-let raw_string = function
-| [] -> ""
-| [PCData s] -> s
-| _ -> raise Marshal_error
-
-let bool_arg tag b = if b then [tag, ""] else []
-
-(** Base types *)
-
-let of_unit () = Element ("unit", [], [])
-
-let to_unit : xml -> unit = function
-  | Element ("unit", [], []) -> ()
-  | _ -> raise Marshal_error
-
-let of_bool (b : bool) : xml =
-  if b then constructor "bool" "true" []
-  else constructor "bool" "false" []
-
-let to_bool xml : bool = do_match xml "bool"
-  (fun s _ -> match s with
-  | "true" -> true
-  | "false" -> false
-  | _ -> raise Marshal_error)
-
-let of_list (f : 'a -> xml) (l : 'a list) =
-  Element ("list", [], List.map f l)
-
-let to_list (f : xml -> 'a) : xml -> 'a list = function
-| Element ("list", [], l) ->
-  List.map f l
-| _ -> raise Marshal_error
-
-let of_option (f : 'a -> xml) : 'a option -> xml = function
-| None -> Element ("option", ["val", "none"], [])
-| Some x -> Element ("option", ["val", "some"], [f x])
-
-let to_option (f : xml -> 'a) : xml -> 'a option = function
-| Element ("option", ["val", "none"], []) -> None
-| Element ("option", ["val", "some"], [x]) -> Some (f x)
-| _ -> raise Marshal_error
-
-let of_string (s : string) : xml = Element ("string", [], [PCData s])
-
-let to_string : xml -> string = function
-| Element ("string", [], l) -> raw_string l
-| _ -> raise Marshal_error
-
-let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
-
-let to_int : xml -> int = function
-| Element ("int", [], [PCData s]) ->
-  (try int_of_string s with Failure _ -> raise Marshal_error)
-| _ -> raise Marshal_error
-
-let of_pair (f : 'a -> xml) (g : 'b -> xml) : 'a * 'b -> xml =
-  function (x,y) -> Element ("pair", [], [f x; g y])
-
-let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
-| Element ("pair", [], [x; y]) -> (f x, g y)
-| _ -> raise Marshal_error
-
-let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) Util.union -> xml =
-function
-| Util.Inl x -> Element ("union", ["val","in_l"], [f x])
-| Util.Inr x -> Element ("union", ["val","in_r"], [g x])
-
-let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) Util.union=
-function
-| Element ("union", ["val","in_l"], [x]) -> Util.Inl (f x)
-| Element ("union", ["val","in_r"], [x]) -> Util.Inr (g x)
-| _ -> raise Marshal_error
-
-(** More elaborate types *)
-
-let of_option_value = function
-| IntValue i ->
-  constructor "option_value" "intvalue" [of_option of_int i]
-| BoolValue b ->
-  constructor "option_value" "boolvalue" [of_bool b]
-| StringValue s ->
-  constructor "option_value" "stringvalue" [of_string s]
-
-let to_option_value xml = do_match xml "option_value"
-  (fun s args -> match s with
-  | "intvalue" -> IntValue (to_option to_int (singleton args))
-  | "boolvalue" -> BoolValue (to_bool (singleton args))
-  | "stringvalue" -> StringValue (to_string (singleton args))
-  | _ -> raise Marshal_error
-  )
-
-let of_option_state s =
-  Element ("option_state", [], [
-    of_bool s.opt_sync;
-    of_bool s.opt_depr;
-    of_string s.opt_name;
-    of_option_value s.opt_value]
-  )
-
-let to_option_state = function
-| Element ("option_state", [], [sync; depr; name; value]) ->
-  {
-    opt_sync = to_bool sync;
-    opt_depr = to_bool depr;
-    opt_name = to_string name;
-    opt_value = to_option_value value;
-  }
-| _ -> raise Marshal_error
-
-let of_search_constraint = function
-| Name_Pattern s ->
-  constructor "search_constraint" "name_pattern" [of_string s]
-| Type_Pattern s ->
-  constructor "search_constraint" "type_pattern" [of_string s]
-| SubType_Pattern s ->
-  constructor "search_constraint" "subtype_pattern" [of_string s]
-| In_Module m ->
-  constructor "search_constraint" "in_module" [of_list of_string m]
-| Include_Blacklist ->
-  constructor "search_constraint" "include_blacklist" []
-
-let to_search_constraint xml = do_match xml "search_constraint"
-  (fun s args -> match s with
-  | "name_pattern" -> Name_Pattern (to_string (singleton args))
-  | "type_pattern" -> Type_Pattern (to_string (singleton args))
-  | "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
-  | "in_module" -> In_Module (to_list to_string (singleton args))
-  | "include_blacklist" -> Include_Blacklist
-  | _ -> raise Marshal_error)
-
-let of_coq_object f ans =
-  let prefix = of_list of_string ans.coq_object_prefix in
-  let qualid = of_list of_string ans.coq_object_qualid in
-  let obj = f ans.coq_object_object in
-  Element ("coq_object", [], [prefix; qualid; obj])
-
-let to_coq_object f = function
-| Element ("coq_object", [], [prefix; qualid; obj]) ->
-  let prefix = to_list to_string prefix in
-  let qualid = to_list to_string qualid in
-  let obj = f obj in {
-    coq_object_prefix = prefix;
-    coq_object_qualid = qualid;
-    coq_object_object = obj;
-  }
-| _ -> raise Marshal_error
-
-let of_value f = function
-| Good x -> Element ("value", ["val", "good"], [f x])
-| Fail (loc, msg) ->
-  let loc = match loc with
-  | None -> []
-  | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)]
-  in
-  Element ("value", ["val", "fail"] @ loc, [PCData msg])
-
-let to_value f = function
-| Element ("value", attrs, l) ->
-  let ans = massoc "val" attrs in
-  if ans = "good" then Good (f (singleton l))
-  else if ans = "fail" then
-    let loc =
-      try
-        let loc_s = int_of_string (List.assoc "loc_s" attrs) in
-        let loc_e = int_of_string (List.assoc "loc_e" attrs) in
-        Some (loc_s, loc_e)
-      with Not_found | Failure _ -> None
-    in
-    let msg = raw_string l in
-    Fail (loc, msg)
-  else raise Marshal_error
-| _ -> raise Marshal_error
-
-let of_call = function
-| Interp (id,raw, vrb, cmd) ->
-  let flags = (bool_arg "raw" raw) @ (bool_arg "verbose" vrb) in
-  Element ("call", ("val", "interp") :: ("id", string_of_int id) :: flags,
-  [PCData cmd])
-| Rewind n ->
-  Element ("call", ("val", "rewind") :: ["steps", string_of_int n], [])
-| Goal () ->
-  Element ("call", ["val", "goal"], [])
-| Evars () ->
-  Element ("call", ["val", "evars"], [])
-| Hints () ->
-  Element ("call", ["val", "hints"], [])
-| Status () ->
-  Element ("call", ["val", "status"], [])
-| Search flags ->
-  let args = List.map (of_pair of_search_constraint of_bool) flags in
-  Element ("call", ["val", "search"], args)
-| GetOptions () ->
-  Element ("call", ["val", "getoptions"], [])
-| SetOptions opts ->
-  let args = List.map (of_pair (of_list of_string) of_option_value) opts in
-  Element ("call", ["val", "setoptions"], args)
-| InLoadPath file ->
-  Element ("call", ["val", "inloadpath"], [PCData file])
-| MkCases ind ->
-  Element ("call", ["val", "mkcases"], [PCData ind])
-| Quit () ->
-  Element ("call", ["val", "quit"], [])
-| About () ->
-  Element ("call", ["val", "about"], [])
-
-let to_call = function
-| Element ("call", attrs, l) ->
-  let ans = massoc "val" attrs in
-  begin match ans with
-  | "interp" -> begin
-    try
-      let id = List.assoc "id" attrs in
-      let raw = List.mem_assoc "raw" attrs in
-      let vrb = List.mem_assoc "verbose" attrs in
-      Interp (int_of_string id, raw, vrb, raw_string l)
-    with Not_found -> raise Marshal_error end
-  | "rewind" ->
-    let steps = int_of_string (massoc "steps" attrs) in
-    Rewind steps
-  | "goal" -> Goal ()
-  | "evars" -> Evars ()
-  | "status" -> Status ()
-  | "search" ->
-    let args = List.map (to_pair to_search_constraint to_bool) l in
-    Search args
-  | "getoptions" -> GetOptions ()
-  | "setoptions" ->
-    let args = List.map (to_pair (to_list to_string) to_option_value) l in
-    SetOptions args
-  | "inloadpath" -> InLoadPath (raw_string l)
-  | "mkcases" -> MkCases (raw_string l)
-  | "hints" -> Hints ()
-  | "quit" -> Quit ()
-  | "about" -> About ()
-  | _ -> raise Marshal_error
-  end
-| _ -> raise Marshal_error
-
-let of_status s =
-  let of_so = of_option of_string in
-  let of_sl = of_list of_string in
-  Element ("status", [],
-    [
-      of_sl s.status_path;
-      of_so s.status_proofname;
-      of_sl s.status_allproofs;
-      of_int s.status_statenum;
-      of_int s.status_proofnum;
-    ]
-  )
-
-let to_status = function
-| Element ("status", [], [path; name; prfs; snum; pnum]) ->
-  {
-    status_path = to_list to_string path;
-    status_proofname = to_option to_string name;
-    status_allproofs = to_list to_string prfs;
-    status_statenum = to_int snum;
-    status_proofnum = to_int pnum;
-  }
-| _ -> raise Marshal_error
-
-let of_evar s =
-  Element ("evar", [], [PCData s.evar_info])
-
-let to_evar = function
-| Element ("evar", [], data) -> { evar_info = raw_string data; }
-| _ -> raise Marshal_error
-
-let of_goal g =
-  let hyp = of_list of_string g.goal_hyp in
-  let ccl = of_string g.goal_ccl in
-  let id = of_string g.goal_id in
-  Element ("goal", [], [id; hyp; ccl])
-
-let to_goal = function
-| Element ("goal", [], [id; hyp; ccl]) ->
-  let hyp = to_list to_string hyp in
-  let ccl = to_string ccl in
-  let id = to_string id in
-  { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
-| _ -> raise Marshal_error
-
-let of_goals g =
-  let of_glist = of_list of_goal in
-  let fg = of_list of_goal g.fg_goals in
-  let bg = of_list (of_pair of_glist of_glist) g.bg_goals in
-  Element ("goals", [], [fg; bg])
-
-let to_goals = function
-| Element ("goals", [], [fg; bg]) ->
-  let to_glist = to_list to_goal in
-  let fg = to_list to_goal fg in
-  let bg = to_list (to_pair to_glist to_glist) bg in
-  { fg_goals = fg; bg_goals = bg; }
-| _ -> raise Marshal_error
-
-let of_coq_info info =
-  let version = of_string info.coqtop_version in
-  let protocol = of_string info.protocol_version in
-  let release = of_string info.release_date in
-  let compile = of_string info.compile_date in
-  Element ("coq_info", [], [version; protocol; release; compile])
-
-let to_coq_info = function
-| Element ("coq_info", [], [version; protocol; release; compile]) ->
-  {
-    coqtop_version = to_string version;
-    protocol_version = to_string protocol;
-    release_date = to_string release;
-    compile_date = to_string compile;
-  }
-| _ -> raise Marshal_error
-
-let of_message_level = function
-| Debug s -> constructor "message_level" "debug" [PCData s]
-| Info -> constructor "message_level" "info" []
-| Notice -> constructor "message_level" "notice" []
-| Warning -> constructor "message_level" "warning" []
-| Error -> constructor "message_level" "error" []
-
-let to_message_level xml = do_match xml "message_level"
-  (fun s args -> match s with
-  | "debug" -> Debug (raw_string args)
-  | "info" -> Info
-  | "notice" -> Notice
-  | "warning" -> Warning
-  | "error" -> Error
-  | _ -> raise Marshal_error)
-
-let of_message msg =
-  let lvl = of_message_level msg.message_level in
-  let content = of_string msg.message_content in
-  Element ("message", [], [lvl; content])
-
-let to_message xml = match xml with
-| Element ("message", [], [lvl; content]) ->
-  { message_level = to_message_level lvl; message_content = to_string content }
-| _ -> raise Marshal_error
-
-let is_message = function
-| Element ("message", _, _) -> true
-| _ -> false
-
-let of_loc loc =
-  let start, stop = loc in
-  Element ("loc",[("start",string_of_int start);("stop",string_of_int stop)],[])
-
-let to_loc xml = match xml with
-| Element ("loc", l,[]) ->
-    (try
-      let start = List.assoc "start" l in
-      let stop = List.assoc "stop" l in
-      (int_of_string start, int_of_string stop)
-    with Not_found | Invalid_argument _ -> raise Marshal_error)
-| _ -> raise Marshal_error
-
-let to_feedback_content xml = do_match xml "feedback_content"
-  (fun s args -> match s with
-  | "addedaxiom" -> AddedAxiom
-  | "processed" -> Processed
-  | "globref" ->
-       (match args with
-       | [loc; filepath; modpath; ident; ty] ->
-            GlobRef(to_loc loc, to_string filepath, to_string modpath,
-                    to_string ident, to_string ty)
-       | _ -> raise Marshal_error)
-  | _ -> raise Marshal_error)
-
-let of_feedback_content = function
-| AddedAxiom -> constructor "feedback_content" "addedaxiom" []
-| Processed -> constructor "feedback_content" "processed" []
-| GlobRef(loc, filepath, modpath, ident, ty) ->
-    constructor "feedback_content" "globref" [
-      of_loc loc;
-      of_string filepath;
-      of_string modpath;
-      of_string ident;
-      of_string ty
-    ]
-
-let of_feedback msg =
-  let content = of_feedback_content msg.content in
-  Element ("feedback", ["id",string_of_int msg.edit_id], [content])
-
-let to_feedback xml = match xml with
-| Element ("feedback", ["id",id], [content]) ->
-  { edit_id = int_of_string id;
-    content = to_feedback_content content }
-| _ -> raise Marshal_error
-
-let is_feedback = function
-| Element ("feedback", _, _) -> true
-| _ -> false
-
-(** Conversions between ['a value] and xml answers
-
-  When decoding an xml answer, we dynamically check that it is compatible
-  with the original call. For that we now rely on the fact that all
-  sub-fonctions [to_xxx : xml -> xxx] check that the current xml element
-  is "xxx", and raise [Marshal_error] if anything goes wrong.  *)
-
-let of_answer (q : 'a call) (r : 'a value) : xml =
-  let rec convert ty : 'a -> xml = match ty with
-    | Unit          -> Obj.magic of_unit
-    | Bool          -> Obj.magic of_bool
-    | String        -> Obj.magic of_string
-    | Int           -> Obj.magic of_int
-    | State         -> Obj.magic of_status
-    | Option_state  -> Obj.magic of_option_state
-    | Coq_info      -> Obj.magic of_coq_info
-    | Goals         -> Obj.magic of_goals
-    | Evar          -> Obj.magic of_evar
-    | List t        -> Obj.magic (of_list (convert t))
-    | Option t      -> Obj.magic (of_option (convert t))
-    | Coq_object t  -> Obj.magic (of_coq_object (convert t))
-    | Pair (t1,t2)  -> Obj.magic (of_pair (convert t1) (convert t2))
-    | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
-  in
-  of_value (convert (expected_answer_type q)) r
-
-let to_answer xml (c : 'a call) : 'a value =
-  let rec convert ty : xml -> 'a = match ty with
-    | Unit          -> Obj.magic to_unit
-    | Bool          -> Obj.magic to_bool
-    | String        -> Obj.magic to_string
-    | Int           -> Obj.magic to_int
-    | State         -> Obj.magic to_status
-    | Option_state  -> Obj.magic to_option_state
-    | Coq_info      -> Obj.magic to_coq_info
-    | Goals         -> Obj.magic to_goals
-    | Evar          -> Obj.magic to_evar
-    | List t        -> Obj.magic (to_list (convert t))
-    | Option t      -> Obj.magic (to_option (convert t))
-    | Coq_object t  -> Obj.magic (to_coq_object (convert t))
-    | Pair (t1,t2)  -> Obj.magic (to_pair (convert t1) (convert t2))
-    | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
-  in
-  to_value (convert (expected_answer_type c)) xml
-
-(** * Debug printing *)
-
-let pr_unit () = ""
-let pr_string s = Printf.sprintf "%S" s
-let pr_int i = string_of_int i
-let pr_bool b = Printf.sprintf "%B" b
-let pr_goal (g : goals) =
-  if g.fg_goals = [] then
-    if g.bg_goals = [] then "Proof completed."
-    else
-      let rec pr_focus _ = function
-        | [] -> assert false
-        | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg)
-        | (lg, rg) :: l ->
-          Printf.sprintf "%i:%a" (List.length lg + List.length rg) pr_focus l in
-      Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
-  else
-    let pr_menu s = s in
-    let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
-      "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
-          pr_menu goal ^ "]" in
-    String.concat " " (List.map pr_goal g.fg_goals)
-let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
-let pr_status (s : status) =
-  let path =
-    let l = String.concat "." s.status_path in
-    "path=" ^ l ^ ";" in
-  let name = match s.status_proofname with
-    | None -> "no proof;"
-    | Some n -> "proof = " ^ n ^ ";" in
-  "Status: " ^ path ^ name
-let pr_coq_info (i : coq_info) = "FIXME"
-let pr_option_value = function
-  | IntValue None -> "none"
-  | IntValue (Some i) -> string_of_int i
-  | StringValue s -> s
-  | BoolValue b -> if b then "true" else "false"
-let pr_option_state (s : option_state) =
-  Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n"
-    s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value)
-let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]"
-let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")"
-let pr_coq_object (o : 'a coq_object) = "FIXME"
-let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
-let pr_union pr1 pr2 = function Util.Inl x -> pr1 x | Util.Inr x -> pr2 x
-
-let pr_call = function
-  | Interp (id,r,b,s) ->
-    let raw = if r then "RAW" else "" in
-    let verb = if b then "" else "SILENT" in
-    "INTERP"^raw^verb^" "^string_of_int id^" ["^s^"]"
-  | Rewind i -> "REWIND "^(string_of_int i)
-  | Goal _ -> "GOALS"
-  | Evars _ -> "EVARS"
-  | Hints _ -> "HINTS"
-  | Status _ -> "STATUS"
-  | Search _ -> "SEARCH"
-  | GetOptions _ -> "GETOPTIONS"
-  | SetOptions l -> "SETOPTIONS" ^ " [" ^
-      String.concat ";"
-        (List.map (pr_pair (pr_list pr_string) pr_option_value) l) ^ "]"
-  | InLoadPath s -> "INLOADPATH "^s
-  | MkCases s -> "MKCASES "^s
-  | Quit _ -> "QUIT"
-  | About _ -> "ABOUT"
-let pr_value_gen pr = function
-  | Good v -> "GOOD " ^ pr v
-  | Fail (_,str) -> "FAIL ["^str^"]"
-let pr_value v = pr_value_gen (fun _ -> "FIXME") v
-let pr_full_value call value =
-  let rec pr = function
-  | Unit          -> Obj.magic pr_unit
-  | Bool          -> Obj.magic pr_bool
-  | String        -> Obj.magic pr_string
-  | Int           -> Obj.magic pr_int
-  | State         -> Obj.magic pr_status
-  | Option_state  -> Obj.magic pr_option_state
-  | Coq_info      -> Obj.magic pr_coq_info
-  | Goals         -> Obj.magic pr_goal
-  | Evar          -> Obj.magic pr_evar
-  | List t        -> Obj.magic (pr_list (pr t))
-  | Option t      -> Obj.magic (pr_option (pr t))
-  | Coq_object t  -> Obj.magic pr_coq_object
-  | Pair (t1,t2)  -> Obj.magic (pr_pair (pr t1) (pr t2))
-  | Union (t1,t2) -> Obj.magic (pr_union (pr t1) (pr t2))
-  in
-  pr_value_gen (pr (expected_answer_type call)) value
diff --git a/toplevel/ide_slave.ml b/toplevel/ide_slave.ml
deleted file mode 100644
index 9520a990..00000000
--- a/toplevel/ide_slave.ml
+++ /dev/null
@@ -1,466 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Vernacexpr
-open Names
-open Compat
-open Util
-open Pp
-open Printer
-open Namegen
-
-(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
-    function and a rewind function. This specialized loop is triggered
-    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
-    the only one using this mode, but we try here to be as generic as
-    possible, so this may change in the future... *)
-
-(** Signal handling: we postpone ^C during input and output phases,
-    but make it directly raise a Sys.Break during evaluation of the request. *)
-
-let catch_break = ref false
-
-let init_signal_handler () =
-  let f _ = if !catch_break then raise Sys.Break else Util.interrupt := true in
-  Sys.set_signal Sys.sigint (Sys.Signal_handle f)
-
-
-(** Redirection of standard output to a printable buffer *)
-
-let orig_stdout = ref stdout
-
-let init_stdout,read_stdout =
-  let out_buff = Buffer.create 100 in
-  let out_ft = Format.formatter_of_buffer out_buff in
-  let deep_out_ft = Format.formatter_of_buffer out_buff in
-  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
-  (fun () ->
-     flush_all ();
-     orig_stdout := Unix.out_channel_of_descr (Unix.dup Unix.stdout);
-     Unix.dup2 Unix.stderr Unix.stdout;
-     Pp_control.std_ft := out_ft;
-     Pp_control.err_ft := out_ft;
-     Pp_control.deep_ft := deep_out_ft;
-     set_binary_mode_out !orig_stdout true;
-     set_binary_mode_in stdin true;
-  ),
-  (fun () -> Format.pp_print_flush out_ft ();
-             let r = Buffer.contents out_buff in
-             Buffer.clear out_buff; r)
-
-let pr_debug s =
-  if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
-
-(** Categories of commands *)
-
-let coqide_known_option table = List.mem table [
-  ["Printing";"Implicit"];
-  ["Printing";"Coercions"];
-  ["Printing";"Matching"];
-  ["Printing";"Synth"];
-  ["Printing";"Notations"];
-  ["Printing";"All"];
-  ["Printing";"Records"];
-  ["Printing";"Existential";"Instances"];
-  ["Printing";"Universes"]]
-
-let is_known_option cmd = match cmd with
-  | VernacSetOption (_,o,BoolValue true)
-  | VernacUnsetOption (_,o) -> coqide_known_option o
-  | _ -> false
-
-let is_debug cmd = match cmd with
-  | VernacSetOption (_,["Ltac";"Debug"], _) -> true
-  | _ -> false
-
-let is_query cmd = match cmd with
-  | VernacChdir None
-  | VernacMemOption _
-  | VernacPrintOption _
-  | VernacCheckMayEval _
-  | VernacGlobalCheck _
-  | VernacPrint _
-  | VernacSearch _
-  | VernacLocate _ -> true
-  | _ -> false
-
-let is_undo cmd = match cmd with
-  | VernacUndo _ | VernacUndoTo _ -> true
-  | _ -> false
-
-(** Check whether a command is forbidden by CoqIDE *)
-
-let coqide_cmd_checks (loc,ast) =
-  let user_error s =
-    raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s)))
-  in
-  if is_debug ast then
-    user_error "Debug mode not available within CoqIDE";
-  if is_known_option ast then
-    user_error "Use CoqIDE display menu instead";
-  if is_navigation_vernac ast then
-    user_error "Use CoqIDE navigation instead";
-  if is_undo ast then
-    msgerrnl (str "Warning: rather use CoqIDE navigation instead");
-  if is_query ast then
-    msgerrnl (str "Warning: query commands should not be inserted in scripts")
-
-(** Interpretation (cf. [Ide_intf.interp]) *)
-
-let interp (id,raw,verbosely,s) =
-  let pa = Pcoq.Gram.parsable (Stream.of_string s) in
-  let loc_ast = Vernac.parse_sentence (pa,None) in
-  if not raw then coqide_cmd_checks loc_ast;
-  Flags.make_silent (not verbosely);
-  Vernac.eval_expr ~preserving:raw loc_ast;
-  Flags.make_silent true;
-  read_stdout ()
-
-(** Goal display *)
-
-let hyp_next_tac sigma env (id,_,ast) =
-  let id_s = Names.string_of_id id in
-  let type_s = string_of_ppcmds (pr_ltype_env env ast) in
-  [
-    ("clear "^id_s),("clear "^id_s^".");
-    ("apply "^id_s),("apply "^id_s^".");
-    ("exact "^id_s),("exact "^id_s^".");
-    ("generalize "^id_s),("generalize "^id_s^".");
-    ("absurd <"^id_s^">"),("absurd "^type_s^".")
-  ] @ [
-    ("discriminate "^id_s),("discriminate "^id_s^".");
-    ("injection "^id_s),("injection "^id_s^".")
-  ] @ [
-    ("rewrite "^id_s),("rewrite "^id_s^".");
-    ("rewrite <- "^id_s),("rewrite <- "^id_s^".")
-  ] @ [
-    ("elim "^id_s), ("elim "^id_s^".");
-    ("inversion "^id_s), ("inversion "^id_s^".");
-    ("inversion clear "^id_s), ("inversion_clear "^id_s^".")
-  ]
-
-let concl_next_tac sigma concl =
-  let expand s = (s,s^".") in
-  List.map expand ([
-    "intro";
-    "intros";
-    "intuition"
-  ] @ [
-    "reflexivity";
-    "discriminate";
-    "symmetry"
-  ] @ [
-    "assumption";
-    "omega";
-    "ring";
-    "auto";
-    "eauto";
-    "tauto";
-    "trivial";
-    "decide equality";
-    "simpl";
-    "subst";
-    "red";
-    "split";
-    "left";
-    "right"
-  ])
-
-let process_goal sigma g =
-  let env = Goal.V82.env sigma g in
-  let id = Goal.uid g in
-  let ccl =
-    let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
-    string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in
-  let process_hyp h_env d acc =
-    let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in
-    (string_of_ppcmds (pr_var_decl h_env d)) :: acc in
-  let hyps =
-    List.rev (Environ.fold_named_context process_hyp env ~init: []) in
-  { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
-
-let goals () =
-  try
-    let pfts = Proof_global.give_me_the_proof () in
-    let (goals, zipper, sigma) = Proof.proof pfts in
-    let fg = List.map (process_goal sigma) goals in
-    let map_zip (lg, rg) =
-      let lg = List.map (process_goal sigma) lg in
-      let rg = List.map (process_goal sigma) rg in
-      (lg, rg)
-    in
-    let bg = List.map map_zip zipper in
-    Some { Interface.fg_goals = fg; Interface.bg_goals = bg; }
-  with Proof_global.NoCurrentProof -> None
-
-let evars () =
-  try
-    let pfts = Proof_global.give_me_the_proof () in
-    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
-    let exl = Evarutil.non_instantiated sigma in
-    let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in
-    let el = List.map map_evar exl in
-    Some el
-  with Proof_global.NoCurrentProof -> None
-
-let hints () =
-  try
-    let pfts = Proof_global.give_me_the_proof () in
-    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
-    match all_goals with
-    | [] -> None
-    | g :: _ ->
-      let env = Goal.V82.env sigma g in
-      let hint_goal = concl_next_tac sigma g in
-      let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
-      let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
-      Some (hint_hyps, hint_goal)
-  with Proof_global.NoCurrentProof -> None
-
-(** Other API calls *)
-
-let inloadpath dir =
-  Library.is_in_load_paths (System.physical_path_of_string dir)
-
-let status () =
-  (** We remove the initial part of the current [dir_path]
-      (usually Top in an interactive session, cf "coqtop -top"),
-      and display the other parts (opened sections and modules) *)
-  let path =
-    let l = Names.repr_dirpath (Lib.cwd ()) in
-    List.rev_map Names.string_of_id l
-  in
-  let proof =
-    try Some (Names.string_of_id (Proof_global.get_current_proof_name ()))
-    with Proof_global.NoCurrentProof -> None
-  in
-  let allproofs =
-    let l = Proof_global.get_all_proof_names () in
-    List.map Names.string_of_id l
-  in
-  {
-    Interface.status_path = path;
-    Interface.status_proofname = proof;
-    Interface.status_allproofs = allproofs;
-    Interface.status_statenum = Lib.current_command_label ();
-    Interface.status_proofnum = Pfedit.current_proof_depth ();
-  }
-
-(** This should be elsewhere... *)
-let search flags =
-  let env = Global.env () in
-  let rec extract_flags name tpe subtpe mods blacklist = function
-  | [] -> (name, tpe, subtpe, mods, blacklist)
-  | (Interface.Name_Pattern s, b) :: l ->
-    let regexp =
-      try Str.regexp s
-      with e when Errors.noncritical e ->
-        Util.error ("Invalid regexp: " ^ s)
-    in
-    extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
-  | (Interface.Type_Pattern s, b) :: l ->
-    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
-    let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
-    extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
-  | (Interface.SubType_Pattern s, b) :: l ->
-    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
-    let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
-    extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
-  | (Interface.In_Module m, b) :: l ->
-    let path = String.concat "." m in
-    let m = Pcoq.parse_string Pcoq.Constr.global path in
-    let (_, qid) = Libnames.qualid_of_reference m in
-    let id =
-      try Nametab.full_name_module qid
-      with Not_found ->
-        Util.error ("Module " ^ path ^ " not found.")
-    in
-    extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
-  | (Interface.Include_Blacklist, b) :: l ->
-    extract_flags name tpe subtpe mods b l
-  in
-  let (name, tpe, subtpe, mods, blacklist) =
-    extract_flags [] [] [] [] false flags
-  in
-  let filter_function ref env constr =
-    let id = Names.string_of_id (Nametab.basename_of_global ref) in
-    let path = Libnames.dirpath (Nametab.path_of_global ref) in
-    let toggle x b = if x then b else not b in
-    let match_name (regexp, flag) =
-      toggle (Str.string_match regexp id 0) flag
-    in
-    let match_type (pat, flag) =
-      toggle (Matching.is_matching pat constr) flag
-    in
-    let match_subtype (pat, flag) =
-      toggle (Matching.is_matching_appsubterm ~closed:false pat constr) flag
-    in
-    let match_module (mdl, flag) =
-      toggle (Libnames.is_dirpath_prefix_of mdl path) flag
-    in
-    let in_blacklist =
-      blacklist || (Search.filter_blacklist ref env constr)
-    in
-    List.for_all match_name name &&
-    List.for_all match_type tpe &&
-    List.for_all match_subtype subtpe &&
-    List.for_all match_module mods && in_blacklist
-  in
-  let ans = ref [] in
-  let print_function ref env constr =
-     let fullpath = repr_dirpath (Nametab.dirpath_of_global ref) in
-     let qualid = Nametab.shortest_qualid_of_global Idset.empty ref in
-     let (shortpath, basename) = Libnames.repr_qualid qualid in
-     let shortpath = repr_dirpath shortpath in
-     (* [shortpath] is a suffix of [fullpath] and we're looking for the missing
-        prefix *)
-     let rec prefix full short accu = match full, short with
-     | _, [] ->
-       let full = List.rev_map string_of_id full in
-       (full, accu)
-     | _ :: full, m :: short ->
-       prefix full short (string_of_id m :: accu)
-     | _ -> assert false
-     in
-     let (prefix, qualid) = prefix fullpath shortpath [string_of_id basename] in
-     let answer = {
-       Interface.coq_object_prefix = prefix;
-       Interface.coq_object_qualid = qualid;
-       Interface.coq_object_object = string_of_ppcmds (pr_lconstr_env env constr);
-     } in
-    ans := answer :: !ans;
-  in
-  let () = Search.gen_filtered_search filter_function print_function in
-  !ans
-
-let get_options () =
-  let table = Goptions.get_tables () in
-  let fold key state accu = (key, state) :: accu in
-  Goptions.OptionMap.fold fold table []
-
-let set_options options =
-  let iter (name, value) = match value with
-  | BoolValue b -> Goptions.set_bool_option_value name b
-  | IntValue i -> Goptions.set_int_option_value name i
-  | StringValue s -> Goptions.set_string_option_value name s
-  in
-  List.iter iter options
-
-let about () = {
-  Interface.coqtop_version = Coq_config.version;
-  Interface.protocol_version = Ide_intf.protocol_version;
-  Interface.release_date = Coq_config.date;
-  Interface.compile_date = Coq_config.compile_date;
-}
-
-(** Grouping all call handlers together + error handling *)
-
-exception Quit
-
-let eval_call c =
-  let rec handle_exn e =
-    catch_break := false;
-    let pr_exn e = (read_stdout ())^("\n"^(string_of_ppcmds (Errors.print e))) in
-    match e with
-      | Quit ->
-        (* Here we do send an acknowledgement message to prove everything went 
-          OK. *)
-        let dummy = Interface.Good () in
-        let xml_answer = Ide_intf.of_answer (Ide_intf.quit ()) dummy in
-        let () = Xml_utils.print_xml !orig_stdout xml_answer in
-        let () = flush !orig_stdout in
-        let () = pr_debug "Exiting gracefully." in
-        exit 0
-      | Vernacexpr.Drop -> None, "Drop is not allowed by coqide!"
-      | Vernacexpr.Quit -> None, "Quit is not allowed by coqide!"
-      | Vernac.DuringCommandInterp (_,inner) -> handle_exn inner
-      | Error_in_file (_,_,inner) -> None, pr_exn inner
-      | Loc.Exc_located (loc, inner) when loc = dummy_loc -> None, pr_exn inner
-      | Loc.Exc_located (loc, inner) -> Some (Util.unloc loc), pr_exn inner
-      | e -> None, pr_exn e
-  in
-  let interruptible f x =
-    catch_break := true;
-    Util.check_for_interrupt ();
-    let r = f x in
-    catch_break := false;
-    r
-  in
-  let handler = {
-    Interface.interp = interruptible interp;
-    Interface.rewind = interruptible Backtrack.back;
-    Interface.goals = interruptible goals;
-    Interface.evars = interruptible evars;
-    Interface.hints = interruptible hints;
-    Interface.status = interruptible status;
-    Interface.search = interruptible search;
-    Interface.inloadpath = interruptible inloadpath;
-    Interface.get_options = interruptible get_options;
-    Interface.set_options = interruptible set_options;
-    Interface.mkcases = interruptible Vernacentries.make_cases;
-    Interface.quit = (fun () -> raise Quit);
-    Interface.about = interruptible about;
-    Interface.handle_exn = handle_exn; }
-  in
-  (* If the messages of last command are still there, we remove them *)
-  ignore (read_stdout ());
-  Ide_intf.abstract_eval_call handler c
-
-
-(** The main loop *)
-
-(** Exceptions during eval_call should be converted into [Interface.Fail]
-    messages by [handle_exn] above. Otherwise, we die badly, after having
-    tried to send a last message to the ide: trying to recover from errors
-    with the current protocol would most probably bring desynchronisation
-    between coqtop and ide. With marshalling, reading an answer to
-    a different request could hang the ide... *)
-
-let fail err =
-  Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err))
-
-let loop () =
-  let p = Xml_parser.make () in
-  let () = Xml_parser.check_eof p false in
-  init_signal_handler ();
-  catch_break := false;
-  (* We'll handle goal fetching and display in our own way *)
-  Vernacentries.enable_goal_printing := false;
-  Vernacentries.qed_display_script := false;
-  try
-    while true do
-      let xml_answer =
-        try
-          let xml_query = Xml_parser.parse p (Xml_parser.SChannel stdin) in
-          let q = Ide_intf.to_call xml_query in
-          let () = pr_debug ("<-- " ^ Ide_intf.pr_call q) in
-          let r = eval_call q in
-          let () = pr_debug ("--> " ^ Ide_intf.pr_full_value q r) in
-          Ide_intf.of_answer q r
-        with
-	| Xml_parser.Error (Xml_parser.Empty, _) ->
-	  pr_debug ("End of input, exiting");
-	  exit 0
-        | Xml_parser.Error (err, loc) ->
-          let msg = "Syntax error in query: " ^ Xml_parser.error_msg err in
-          fail msg
-        | Ide_intf.Marshal_error ->
-          fail "Incorrect query."
-      in
-      Xml_utils.print_xml !orig_stdout xml_answer;
-      flush !orig_stdout
-    done
-  with any ->
-    let msg = Printexc.to_string any in
-    let r = "Fatal exception in coqtop:\n" ^ msg in
-    pr_debug ("==> " ^ r);
-    (try
-      Xml_utils.print_xml !orig_stdout (fail r);
-      flush !orig_stdout
-    with any -> ());
-    exit 1
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
index 932bdfe7..138e5189 100644
--- a/toplevel/ind_tables.ml
+++ b/toplevel/ind_tables.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        *)
@@ -18,6 +18,7 @@ open Libobject
 open Nameops
 open Declarations
 open Term
+open Errors
 open Util
 open Declare
 open Entries
@@ -26,23 +27,28 @@ open Decl_kinds
 (**********************************************************************)
 (* Registering schemes in the environment *)
 
-type mutual_scheme_object_function = mutual_inductive -> constr array
-type individual_scheme_object_function = inductive -> constr
+
+type mutual_scheme_object_function =
+  mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects
+type individual_scheme_object_function =
+  inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects
 
 type 'a scheme_kind = string
 
-let scheme_map = ref Indmap.empty
+let scheme_map = Summary.ref Indmap.empty ~name:"Schemes"
+
+let pr_scheme_kind = Pp.str
 
 let cache_one_scheme kind (ind,const) =
-  let map = try Indmap.find ind !scheme_map with Not_found -> Stringmap.empty in
-  scheme_map := Indmap.add ind (Stringmap.add kind const map) !scheme_map
+  let map = try Indmap.find ind !scheme_map with Not_found -> String.Map.empty in
+  scheme_map := Indmap.add ind (String.Map.add kind const map) !scheme_map
 
 let cache_scheme (_,(kind,l)) =
   Array.iter (cache_one_scheme kind) l
 
-let subst_one_scheme subst ((mind,i),const) =
+let subst_one_scheme subst (ind,const) =
   (* Remark: const is a def: the result of substitution is a constant *)
-  ((subst_ind subst mind,i),fst (subst_con subst const))
+  (subst_ind subst ind,subst_constant subst const)
 
 let subst_scheme (subst,(kind,l)) =
   (kind,Array.map (subst_one_scheme subst) l)
@@ -60,36 +66,24 @@ let inScheme : string * (inductive * constant) array -> obj =
 		    discharge_function = discharge_scheme}
 
 (**********************************************************************)
-(* Saving/restoring the table of scheme *)
-
-let freeze_schemes () = !scheme_map
-let unfreeze_schemes sch = scheme_map := sch
-let init_schemes () = scheme_map := Indmap.empty
-
-let _ =
-  Summary.declare_summary "Schemes"
-    { Summary.freeze_function = freeze_schemes;
-      Summary.unfreeze_function = unfreeze_schemes;
-      Summary.init_function = init_schemes }
-
-(**********************************************************************)
 (* The table of scheme building functions *)
 
 type individual
 type mutual
 
 type scheme_object_function =
-  | MutualSchemeFunction of (mutual_inductive -> constr array)
-  | IndividualSchemeFunction of (inductive -> constr)
+  | MutualSchemeFunction of mutual_scheme_object_function
+  | IndividualSchemeFunction of individual_scheme_object_function
 
 let scheme_object_table =
   (Hashtbl.create 17 : (string, string * scheme_object_function) Hashtbl.t)
 
 let declare_scheme_object s aux f =
-  (try check_ident ("ind"^s)
-   with e when Errors.noncritical e ->
-     error ("Illegal induction scheme suffix: "^s));
-  let key = if aux = "" then s else aux in
+  let () =
+    if not (Id.is_valid ("ind" ^ s)) then
+      error ("Illegal induction scheme suffix: " ^ s)
+  in
+  let key = if String.is_empty aux then s else aux in
   try
     let _ = Hashtbl.find scheme_object_table key in
 (*    let aux_msg = if aux="" then "" else " (with key "^aux^")" in*)
@@ -110,6 +104,8 @@ let declare_individual_scheme_object s ?(aux="") f =
 let declare_scheme kind indcl =
   Lib.add_anonymous_leaf (inScheme (kind,indcl))
 
+let () = Declare.set_declare_scheme declare_scheme
+
 let is_visible_name id =
   try ignore (Nametab.locate (Libnames.qualid_of_ident id)); true
   with Not_found -> false
@@ -120,30 +116,39 @@ let compute_name internal id =
   | KernelSilent ->
       Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name
 
-let define internal id c =
+let define internal id c p univs =
   let fd = declare_constant ~internal in
   let id = compute_name internal id in
-  let kn = fd id
-    (DefinitionEntry
-      { const_entry_body = c;
-        const_entry_secctx = None;
-        const_entry_type = None;
-        const_entry_opaque = false },
-      Decl_kinds.IsDefinition Scheme) in
-  (match internal with
-  | KernelSilent -> ()
-  | _-> definition_message id);
+  let ctx = Evd.normalize_evar_universe_context univs in
+  let c = Vars.subst_univs_fn_constr 
+    (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in
+  let entry = {
+    const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), Declareops.no_seff);
+    const_entry_secctx = None;
+    const_entry_type = None;
+    const_entry_polymorphic = p;
+    const_entry_universes = Evd.evar_context_universe_context ctx;
+    const_entry_opaque = false;
+    const_entry_inline_code = false;
+    const_entry_feedback = None;
+  } in
+  let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in
+  let () = match internal with
+    | KernelSilent -> ()
+    | _-> definition_message id
+  in
   kn
 
 let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) =
-  let c = f ind in
+  let (c, ctx), eff = f ind in
   let mib = Global.lookup_mind mind in
   let id = match idopt with
     | Some id -> id
     | None -> add_suffix mib.mind_packets.(i).mind_typename suff in
-  let const = define internal id c in
+  let const = define internal id c mib.mind_polymorphic ctx in
   declare_scheme kind [|ind,const|];
-  const
+  const, Declareops.cons_side_effects
+     (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff
 
 let define_individual_scheme kind internal names (mind,i as ind) =
   match Hashtbl.find scheme_object_table kind with
@@ -152,14 +157,21 @@ let define_individual_scheme kind internal names (mind,i as ind) =
       define_individual_scheme_base kind s f internal names ind
 
 let define_mutual_scheme_base kind suff f internal names mind =
-  let cl = f mind in
+  let (cl, ctx), eff = f mind in
   let mib = Global.lookup_mind mind in
   let ids = Array.init (Array.length mib.mind_packets) (fun i ->
-      try List.assoc i names
+      try Int.List.assoc i names
       with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in
-  let consts = array_map2 (define internal) ids cl in
-  declare_scheme kind (Array.mapi (fun i cst -> ((mind,i),cst)) consts);
-  consts
+
+  let consts = Array.map2 (fun id cl -> 
+     define internal id cl mib.mind_polymorphic ctx) ids cl in
+  let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in
+  declare_scheme kind schemes;
+  consts,
+  Declareops.cons_side_effects 
+    (Safe_typing.sideff_of_scheme
+      kind (Global.safe_env()) (Array.to_list schemes))
+    eff 
 
 let define_mutual_scheme kind internal names mind =
   match Hashtbl.find scheme_object_table kind with
@@ -167,16 +179,23 @@ let define_mutual_scheme kind internal names mind =
   | s,MutualSchemeFunction f ->
       define_mutual_scheme_base kind s f internal names mind
 
+let find_scheme_on_env_too kind ind =
+  let s = String.Map.find kind (Indmap.find ind !scheme_map) in
+  s, Declareops.cons_side_effects
+      (Safe_typing.sideff_of_scheme
+            kind (Global.safe_env()) [ind, s])
+      Declareops.no_seff 
+
 let find_scheme kind (mind,i as ind) =
-  try Stringmap.find kind (Indmap.find ind !scheme_map)
+  try find_scheme_on_env_too kind ind
   with Not_found ->
   match Hashtbl.find scheme_object_table kind with
   | s,IndividualSchemeFunction f ->
       define_individual_scheme_base kind s f KernelSilent None ind
   | s,MutualSchemeFunction f ->
-      (define_mutual_scheme_base kind s f KernelSilent [] mind).(i)
+      let ca, eff = define_mutual_scheme_base kind s f KernelSilent [] mind in
+      ca.(i), eff
 
 let check_scheme kind ind =
-  try let _ = Stringmap.find kind (Indmap.find ind !scheme_map) in true
+  try let _ = find_scheme_on_env_too kind ind in true
   with Not_found -> false
-
diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli
index 3cb3541e..98eaac09 100644
--- a/toplevel/ind_tables.mli
+++ b/toplevel/ind_tables.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,6 @@
 
 open Term
 open Names
-open Libnames
-open Mod_subst
-open Sign
-open Declarations
 
 (** This module provides support for registering inductive scheme builders,
    declaring schemes and generating schemes on demand *)
@@ -22,8 +18,10 @@ type mutual
 type individual
 type 'a scheme_kind
 
-type mutual_scheme_object_function = mutual_inductive -> constr array
-type individual_scheme_object_function = inductive -> constr
+type mutual_scheme_object_function =
+  mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects
+type individual_scheme_object_function =
+  inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects
 
 (** Main functions to register a scheme builder *)
 
@@ -31,7 +29,8 @@ val declare_mutual_scheme_object : string -> ?aux:string ->
   mutual_scheme_object_function -> mutual scheme_kind
 
 val declare_individual_scheme_object : string -> ?aux:string ->
-  individual_scheme_object_function -> individual scheme_kind
+  individual_scheme_object_function ->
+  individual scheme_kind
 
 (*
 val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit
@@ -41,12 +40,15 @@ val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit
 
 val define_individual_scheme : individual scheme_kind -> 
   Declare.internal_flag (** internal *) ->
-  identifier option -> inductive -> constant
+  Id.t option -> inductive -> constant * Declareops.side_effects
 
 val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) ->
-  (int * identifier) list -> mutual_inductive -> constant array
+  (int * Id.t) list -> mutual_inductive -> constant array * Declareops.side_effects
 
 (** Main function to retrieve a scheme in the cache or to generate it *)
-val find_scheme : 'a scheme_kind -> inductive -> constant
+val find_scheme : 'a scheme_kind -> inductive -> constant * Declareops.side_effects
 
 val check_scheme : 'a scheme_kind -> inductive -> bool
+
+
+val pr_scheme_kind : 'a scheme_kind -> Pp.std_ppcmds
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
index b9888dcd..e6b23828 100644
--- a/toplevel/indschemes.ml
+++ b/toplevel/indschemes.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        *)
@@ -15,7 +15,7 @@
    declaring new schemes *)
 
 open Pp
-open Flags
+open Errors
 open Util
 open Names
 open Declarations
@@ -26,13 +26,11 @@ open Decl_kinds
 open Indrec
 open Declare
 open Libnames
+open Globnames
 open Goptions
 open Nameops
 open Termops
-open Typeops
-open Inductiveops
 open Pretyping
-open Topconstr
 open Nametab
 open Smartlocate
 open Vernacexpr
@@ -53,6 +51,24 @@ let _ =
       optread  = (fun () -> !elim_flag) ;
       optwrite = (fun b -> elim_flag := b) }
 
+let bifinite_elim_flag = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "automatic declaration of induction schemes for non-recursive types";
+      optkey   = ["Nonrecursive";"Elimination";"Schemes"];
+      optread  = (fun () -> !bifinite_elim_flag) ;
+      optwrite = (fun b -> bifinite_elim_flag := b) }
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = true; (* compatibility 2014-09-03*)
+      optname  = "automatic declaration of induction schemes for non-recursive types";
+      optkey   = ["Record";"Elimination";"Schemes"];
+      optread  = (fun () -> !bifinite_elim_flag) ;
+      optwrite = (fun b -> bifinite_elim_flag := b) }
+
 let case_flag = ref false
 let _ =
   declare_bool_option
@@ -69,7 +85,7 @@ let _ =
     { optsync  = true;
       optdepr  = false;
       optname  = "automatic declaration of boolean equality";
-      optkey   = ["Boolean";"Equality";"Schemes"];
+      optkey   = ["Equality";"Schemes"];
       optread  = (fun () -> !eq_flag) ;
       optwrite = (fun b -> eq_flag := b) }
 let _ = (* compatibility *)
@@ -105,14 +121,19 @@ let _ =
 
 (* Util *)
 
-let define id internal c t =
+let define id internal ctx c t =
   let f = declare_constant ~internal in
   let kn = f id
     (DefinitionEntry
       { const_entry_body = c;
         const_entry_secctx = None;
         const_entry_type = t;
-        const_entry_opaque = false },
+	const_entry_polymorphic = true;
+	const_entry_universes = Evd.universe_context ctx;
+        const_entry_opaque = false;
+        const_entry_inline_code = false;
+        const_entry_feedback = None;
+      },
       Decl_kinds.IsDefinition Scheme) in
   definition_message id;
   kn
@@ -128,7 +149,7 @@ let alarm what internal msg =
   | KernelVerbose 
   | KernelSilent ->
     (if debug then
-      Flags.if_warn Pp.msg_warning
+      msg_warning
 	(hov 0 msg ++ fnl () ++ what ++ str " not defined."))
   | _ -> errorlabstrm "" msg
 
@@ -161,14 +182,15 @@ let try_declare_scheme what f internal names kn =
         alarm what internal (msg ++ str ".")
     | e when Errors.noncritical e ->
 	alarm what internal
-	  (str "Unknown exception during scheme creation.")
+	  (str "Unknown exception during scheme creation: "++
+           str (Printexc.to_string e))
 
 let beq_scheme_msg mind =
   let mib = Global.lookup_mind mind in
   (* TODO: mutual inductive case *)
   str "Boolean equality on " ++
     pr_enum (fun ind -> quote (Printer.pr_inductive (Global.env()) ind))
-    (list_tabulate (fun i -> (mind,i)) (Array.length mib.mind_packets))
+    (List.init (Array.length mib.mind_packets) (fun i -> (mind,i)))
 
 let declare_beq_scheme_with l kn =
   try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn
@@ -185,12 +207,12 @@ let declare_beq_scheme = declare_beq_scheme_with []
 let declare_one_case_analysis_scheme ind =
   let (mib,mip) = Global.lookup_inductive ind in
   let kind = inductive_sort_family mip in
-  let dep = if kind = InProp then case_scheme_kind_from_prop else case_dep_scheme_kind_from_type in
+  let dep = if kind == InProp then case_scheme_kind_from_prop else case_dep_scheme_kind_from_type in
   let kelim = elim_sorts (mib,mip) in
     (* in case the inductive has a type elimination, generates only one
        induction scheme, the other ones share the same code with the
        apropriate type *)
-  if List.mem InType kelim then
+  if Sorts.List.mem InType kelim then
     ignore (define_individual_scheme dep KernelVerbose None ind)
 
 (* Induction/recursion schemes *)
@@ -208,18 +230,18 @@ let kinds_from_type =
 let declare_one_induction_scheme ind =
   let (mib,mip) = Global.lookup_inductive ind in
   let kind = inductive_sort_family mip in
-  let from_prop = kind = InProp in
+  let from_prop = kind == InProp in
   let kelim = elim_sorts (mib,mip) in
   let elims =
-    list_map_filter (fun (sort,kind) ->
-      if List.mem sort kelim then Some kind else None)
+    List.map_filter (fun (sort,kind) ->
+      if Sorts.List.mem sort kelim then Some kind else None)
       (if from_prop then kinds_from_prop else kinds_from_type) in
   List.iter (fun kind -> ignore (define_individual_scheme kind KernelVerbose None ind))
     elims
 
 let declare_induction_schemes kn =
   let mib = Global.lookup_mind kn in
-  if mib.mind_finite then begin
+  if mib.mind_finite <> Decl_kinds.CoFinite then begin
     for i = 0 to Array.length mib.mind_packets - 1 do
       declare_one_induction_scheme (kn,i);
     done;
@@ -229,7 +251,7 @@ let declare_induction_schemes kn =
 
 let declare_eq_decidability_gen internal names kn =
   let mib = Global.lookup_mind kn in
-  if mib.mind_finite then
+  if mib.mind_finite <> Decl_kinds.CoFinite then
     ignore (define_mutual_scheme eq_dec_scheme_kind internal names kn)
 
 let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *)
@@ -271,7 +293,7 @@ let declare_congr_scheme ind =
     then
       ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind)
     else
-      msg_warn "Cannot build congruence scheme because eq is not found"
+      msg_warning (strbrk "Cannot build congruence scheme because eq is not found")
   end
 
 let declare_sym_scheme ind =
@@ -281,6 +303,7 @@ let declare_sym_scheme ind =
 
 (* Scheme command *)
 
+let smart_global_inductive y = smart_global_inductive y
 let rec split_scheme l =
  let env = Global.env() in
  match l with
@@ -300,7 +323,7 @@ requested
       let names inds recs isdep y z =
         let ind = smart_global_inductive y in
         let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in
-        let z' = family_of_sort (interp_sort z) in
+        let z' = interp_elimination_sort z in
         let suffix = (
           match sort_of_ind with
           | InProp ->
@@ -323,7 +346,7 @@ requested
               | InType -> recs ^ "t_nodep")
         ) in
         let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
-        let newref = (dummy_loc,newid) in
+        let newref = (Loc.ghost,newid) in
           ((newref,isdep,ind,z)::l1),l2
       in
 	match t with
@@ -334,18 +357,20 @@ requested
 
 let do_mutual_induction_scheme lnamedepindsort =
   let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
-  and sigma = Evd.empty
   and env0 = Global.env() in
-  let lrecspec =
-    List.map
-      (fun (_,dep,ind,sort) -> (ind,dep,interp_elimination_sort sort))
-      lnamedepindsort
+  let sigma, lrecspec =
+    List.fold_right
+      (fun (_,dep,ind,sort) (evd, l) -> 
+        let evd, indu = Evd.fresh_inductive_instance env0 evd ind in
+          (evd, (indu,dep,interp_elimination_sort sort) :: l))
+    lnamedepindsort (Evd.from_env env0,[])
   in
-  let listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
-  let rec declare decl fi lrecref =
-    let decltype = Retyping.get_type_of env0 Evd.empty decl in
-    let decltype = refresh_universes decltype in
-    let cst = define fi UserVerbose decl (Some decltype) in
+  let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in
+  let declare decl fi lrecref =
+    let decltype = Retyping.get_type_of env0 sigma decl in
+    (* let decltype = refresh_universes decltype in *)
+    let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Declareops.no_seff) in
+    let cst = define fi UserVerbose sigma proof_output (Some decltype) in
     ConstRef cst :: lrecref
   in
   let _ = List.fold_right2 declare listdecl lrecnames [] in
@@ -354,25 +379,25 @@ let do_mutual_induction_scheme lnamedepindsort =
 let get_common_underlying_mutual_inductive = function
   | [] -> assert false
   | (id,(mind,i as ind))::l as all ->
-      match List.filter (fun (_,(mind',_)) -> mind <> mind') l with
+      match List.filter (fun (_,(mind',_)) -> not (eq_mind mind mind')) l with
       | (_,ind')::_ ->
 	  raise (RecursionSchemeError (NotMutualInScheme (ind,ind')))
       | [] ->
-	  if not (list_distinct (List.map snd (List.map snd all))) then
-	    error "A type occurs twice";
+	  if not (List.distinct_f Int.compare (List.map snd (List.map snd all)))
+          then error "A type occurs twice";
 	  mind,
-	  list_map_filter
+	  List.map_filter
 	    (function (Some id,(_,i)) -> Some (i,snd id) | (None,_) -> None) all
 
 let do_scheme l =
   let ischeme,escheme = split_scheme l in
 (* we want 1 kind of scheme at a time so we check if the user
 tried to declare different schemes at once *)
-    if (ischeme <> []) && (escheme <> [])
+    if not (List.is_empty ischeme) && not (List.is_empty escheme)
     then
       error "Do not declare equality and induction scheme at the same time."
     else (
-      if ischeme <> [] then do_mutual_induction_scheme ischeme
+      if not (List.is_empty ischeme) then do_mutual_induction_scheme ischeme
       else
 	let mind,l = get_common_underlying_mutual_inductive escheme in
 	declare_beq_scheme_with l mind;
@@ -385,17 +410,19 @@ tried to declare different schemes at once *)
 
 let list_split_rev_at index l =
   let rec aux i acc = function
-      hd :: tl when i = index -> acc, tl
+      hd :: tl when Int.equal i index -> acc, tl
     | hd :: tl -> aux (succ i) (hd :: acc) tl
-    | [] -> failwith "list_split_when: Invalid argument"
+    | [] -> failwith "List.split_when: Invalid argument"
   in aux 0 [] l
 
 let fold_left' f = function
-    [] -> raise (Invalid_argument "fold_left'")
+    [] -> invalid_arg "fold_left'"
   | hd :: tl -> List.fold_left f hd tl
 
 let build_combined_scheme env schemes =
-  let defs = List.map (fun cst -> (cst, Typeops.type_of_constant env cst)) schemes in
+  let defs = List.map (fun cst -> (* FIXME *)
+    let evd, c = Evd.fresh_constant_instance env Evd.empty cst in
+      (c, Typeops.type_of_constant_in env c)) schemes in
 (*   let nschemes = List.length schemes in *)
   let find_inductive ty =
     let (ctx, arity) = decompose_prod ty in
@@ -403,7 +430,7 @@ let build_combined_scheme env schemes =
       match kind_of_term last with
 	| App (ind, args) ->
 	    let ind = destInd ind in
-	    let (_,spec) = Inductive.lookup_mind_specif env ind in
+	    let (_,spec) = Inductive.lookup_mind_specif env (fst ind) in
 	      ctx, ind, spec.mind_nrealargs
 	| _ -> ctx, destInd last, 0
   in
@@ -414,8 +441,8 @@ let build_combined_scheme env schemes =
   let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in
   let relargs = rel_vect 0 prods in
   let concls = List.rev_map
-    (fun (cst, t) ->
-      mkApp(mkConst cst, relargs),
+    (fun (cst, t) -> (* FIXME *)
+      mkApp(mkConstU cst, relargs),
       snd (decompose_prod_n prods t)) defs in
   let concl_bod, concl_typ =
     fold_left'
@@ -440,18 +467,19 @@ let do_combined_scheme name schemes =
       schemes
   in
   let body,typ = build_combined_scheme (Global.env ()) csts in
-  ignore (define (snd name) UserVerbose body (Some typ));
+  let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Declareops.no_seff) in
+  ignore (define (snd name) UserVerbose Evd.empty proof_output (Some typ));
   fixpoint_message None [snd name]
 
 (**********************************************************************)
 
 let map_inductive_block f kn n = for i=0 to n-1 do f (kn,i) done
 
-let mutual_inductive_size kn = Array.length (Global.lookup_mind kn).mind_packets
-
 let declare_default_schemes kn =
-  let n = mutual_inductive_size kn in
-  if !elim_flag then declare_induction_schemes kn;
+  let mib = Global.lookup_mind kn in
+  let n = Array.length mib.mind_packets in
+  if !elim_flag && (mib.mind_finite <> BiFinite || !bifinite_elim_flag) then
+    declare_induction_schemes kn;
   if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n;
   if is_eq_flag() then try_declare_beq_scheme kn;
   if !eq_dec_flag then try_declare_eq_decidability kn;
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
index f6eb4fe1..98746107 100644
--- a/toplevel/indschemes.mli
+++ b/toplevel/indschemes.mli
@@ -1,20 +1,17 @@
 (************************************************************************)
 (*  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 Util
+open Loc
 open Names
 open Term
 open Environ
-open Libnames
-open Glob_term
-open Genarg
 open Vernacexpr
-open Ind_tables
+open Misctypes
 
 (** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *)
 
@@ -35,17 +32,17 @@ val declare_rewriting_schemes : inductive -> unit
 (** Mutual Minimality/Induction scheme *)
 
 val do_mutual_induction_scheme :
-  (identifier located * bool * inductive * glob_sort) list -> unit
+  (Id.t located * bool * inductive * glob_sort) list -> unit
 
 (** Main calls to interpret the Scheme command *)
 
-val do_scheme : (identifier located option * scheme) list -> unit
+val do_scheme : (Id.t located option * scheme) list -> unit
 
 (** Combine a list of schemes into a conjunction of them *)
 
 val build_combined_scheme : env -> constant list -> constr * types
 
-val do_combined_scheme : identifier located -> identifier located list -> unit
+val do_combined_scheme : Id.t located -> Id.t located list -> unit
 
 (** Hook called at each inductive type definition *)
 
diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml
deleted file mode 100644
index 4bc9cdb0..00000000
--- a/toplevel/lemmas.ml
+++ /dev/null
@@ -1,353 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(* Created by Hugo Herbelin from contents related to lemma proofs in
-   file command.ml, Aug 2009 *)
-
-open Util
-open Flags
-open Pp
-open Names
-open Term
-open Declarations
-open Entries
-open Environ
-open Nameops
-open Libnames
-open Decls
-open Decl_kinds
-open Declare
-open Pretyping
-open Termops
-open Namegen
-open Evd
-open Evarutil
-open Reductionops
-open Topconstr
-open Constrintern
-open Impargs
-open Tacticals
-
-(* Support for mutually proved theorems *)
-
-let retrieve_first_recthm = function
-  | VarRef id ->
-      (pi2 (Global.lookup_named id),variable_opacity id)
-  | ConstRef cst ->
-      let cb = Global.lookup_constant cst in
-      (Option.map Declarations.force (body_of_constant cb), is_opaque cb)
-  | _ -> assert false
-
-let adjust_guardness_conditions const = function
-  | [] -> const (* Not a recursive statement *)
-  | possible_indexes ->
-  (* Try all combinations... not optimal *)
-  match kind_of_term const.const_entry_body with
-  | Fix ((nv,0),(_,_,fixdefs as fixdecls)) ->
-(*      let possible_indexes =
-	List.map2 (fun i c -> match i with Some i -> i | None ->
-	  interval 0 (List.length ((lam_assum c))))
-	  lemma_guard (Array.to_list fixdefs) in
-*)
-      let indexes =
-	search_guard dummy_loc (Global.env()) possible_indexes fixdecls in
-      { const with const_entry_body = mkFix ((indexes,0),fixdecls) }
-  | c -> const
-
-let find_mutually_recursive_statements thms =
-    let n = List.length thms in
-    let inds = List.map (fun (id,(t,impls,annot)) ->
-      let (hyps,ccl) = decompose_prod_assum t in
-      let x = (id,(t,impls)) in
-      match annot with
-      (* Explicit fixpoint decreasing argument is given *)
-      | Some (Some (_,id),CStructRec) ->
-          let i,b,typ = lookup_rel_id id hyps in
-          (match kind_of_term t with
-          | Ind (kn,_ as ind) when
-              let mind = Global.lookup_mind kn in
-              mind.mind_finite & b = None ->
-              [ind,x,i],[]
-          | _ ->
-              error "Decreasing argument is not an inductive assumption.")
-      (* Unsupported cases *)
-      | Some (_,(CWfRec _|CMeasureRec _)) ->
-          error "Only structural decreasing is supported for mutual statements."
-      (* Cofixpoint or fixpoint w/o explicit decreasing argument *)
-      | None | Some (None, CStructRec) ->
-      let whnf_hyp_hds = map_rel_context_in_env
-        (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c))
-        (Global.env()) hyps in
-      let ind_hyps =
-        List.flatten (list_map_i (fun i (_,b,t) ->
-          match kind_of_term t with
-          | Ind (kn,_ as ind) when
-                let mind = Global.lookup_mind kn in
-                mind.mind_finite & b = None ->
-              [ind,x,i]
-          | _ ->
-              []) 0 (List.rev whnf_hyp_hds)) in
-      let ind_ccl =
-        let cclenv = push_rel_context hyps (Global.env()) in
-        let whnf_ccl,_ = whd_betadeltaiota_stack cclenv Evd.empty ccl in
-        match kind_of_term whnf_ccl with
-        | Ind (kn,_ as ind) when
-              let mind = Global.lookup_mind kn in
-              mind.mind_ntypes = n & not mind.mind_finite ->
-            [ind,x,0]
-        | _ ->
-            [] in
-      ind_hyps,ind_ccl) thms in
-    let inds_hyps,ind_ccls = List.split inds in
-    let of_same_mutind ((kn,_),_,_) = function ((kn',_),_,_) -> kn = kn' in
-    (* Check if all conclusions are coinductive in the same type *)
-    (* (degenerated cartesian product since there is at most one coind ccl) *)
-    let same_indccl =
-      list_cartesians_filter (fun hyp oks ->
-	if List.for_all (of_same_mutind hyp) oks
-	then Some (hyp::oks) else None) [] ind_ccls in
-    let ordered_same_indccl =
-      List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in
-    (* Check if some hypotheses are inductive in the same type *)
-    let common_same_indhyp =
-      list_cartesians_filter (fun hyp oks ->
-	if List.for_all (of_same_mutind hyp) oks
-	then Some (hyp::oks) else None) [] inds_hyps in
-    let ordered_inds,finite,guard =
-      match ordered_same_indccl, common_same_indhyp with
-      | indccl::rest, _ ->
-	  assert (rest=[]);
-          (* One occ. of common coind ccls and no common inductive hyps *)
-	  if common_same_indhyp <> [] then
-	    if_verbose msgnl (str "Assuming mutual coinductive statements.");
-	  flush_all ();
-          indccl, true, []
-      | [], _::_ ->
-	  if same_indccl <> [] &&
-	     list_distinct (List.map pi1 (List.hd same_indccl)) then
-	    if_verbose msgnl (strbrk "Coinductive statements do not follow the order of definition, assuming the proof to be by induction."); flush_all ();
-          let possible_guards = List.map (List.map pi3) inds_hyps in
-	  (* assume the largest indices as possible *)
-	  list_last common_same_indhyp, false, possible_guards
-      | _, [] ->
-	  error
-            ("Cannot find common (mutual) inductive premises or coinductive" ^
-             " conclusions in the statements.")
-    in
-    (finite,guard,None), ordered_inds
-
-let look_for_possibly_mutual_statements = function
-  | [id,(t,impls,None)] ->
-      (* One non recursively proved theorem *)
-      None,[id,(t,impls)],None
-  | _::_ as thms ->
-    (* More than one statement and/or an explicit decreasing mark: *)
-    (* we look for a common inductive hyp or a common coinductive conclusion *)
-    let recguard,ordered_inds = find_mutually_recursive_statements thms in
-    let thms = List.map pi2 ordered_inds in
-    Some recguard,thms, Some (List.map (fun (_,_,i) -> succ i) ordered_inds)
-  | [] -> anomaly "Empty list of theorems."
-
-(* Saving a goal *)
-
-let save id const do_guard (locality,kind) hook =
-  let const = adjust_guardness_conditions const do_guard in
-  let {const_entry_body = pft;
-       const_entry_type = tpo;
-       const_entry_opaque = opacity } = const in
-  let k = logical_kind_of_goal_kind kind in
-  let l,r = match locality with
-    | Local when Lib.sections_are_opened () ->
-	let c = SectionLocalDef (pft, tpo, opacity) in
-	let _ = declare_variable id (Lib.cwd(), c, k) in
-	(Local, VarRef id)
-    | Local | Global ->
-        let kn = declare_constant id (DefinitionEntry const, k) in
-	Autoinstance.search_declaration (ConstRef kn);
-	(Global, ConstRef kn) in
-  Pfedit.delete_current_proof ();
-  definition_message id;
-  hook l r
-
-let default_thm_id = id_of_string "Unnamed_thm"
-
-let compute_proof_name locality = function
-  | Some (loc,id) ->
-      (* We check existence here: it's a bit late at Qed time *)
-      if Nametab.exists_cci (Lib.make_path id) || is_section_variable id ||
-	 locality=Global && Nametab.exists_cci (Lib.make_path_except_section id)
-      then
-        user_err_loc (loc,"",pr_id id ++ str " already exists.");
-      id
-  | None ->
-      next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) 
-
-let save_remaining_recthms (local,kind) body opaq i (id,(t_i,(_,imps))) =
-  match body with
-  | None ->
-      (match local with
-      | Local ->
-          let impl=false in (* copy values from Vernacentries *)
-          let k = IsAssumption Conjectural in
-          let c = SectionLocalAssum (t_i,impl) in
-	  let _ = declare_variable id (Lib.cwd(),c,k) in
-          (Local,VarRef id,imps)
-      | Global ->
-          let k = IsAssumption Conjectural in
-          let kn = declare_constant id (ParameterEntry (None,t_i,None), k) in
-          (Global,ConstRef kn,imps))
-  | Some body ->
-      let k = logical_kind_of_goal_kind kind in
-      let body_i = match kind_of_term body with
-        | Fix ((nv,0),decls) -> mkFix ((nv,i),decls)
-        | CoFix (0,decls) -> mkCoFix (i,decls)
-        | _ -> anomaly "Not a proof by induction" in
-      match local with
-      | Local ->
-	  let c = SectionLocalDef (body_i, Some t_i, opaq) in
-	  let _ = declare_variable id (Lib.cwd(), c, k) in
-          (Local,VarRef id,imps)
-      | Global ->
-          let const =
-            { const_entry_body = body_i;
-              const_entry_secctx = None;
-              const_entry_type = Some t_i;
-              const_entry_opaque = opaq } in
-          let kn = declare_constant id (DefinitionEntry const, k) in
-          (Global,ConstRef kn,imps)
-
-let save_hook = ref ignore
-let set_save_hook f = save_hook := f
-
-let get_proof opacity =
-  let id,(const,do_guard,persistence,hook) = Pfedit.cook_proof !save_hook in
-  id,{const with const_entry_opaque = opacity},do_guard,persistence,hook
-
-let save_named opacity =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.transaction p begin fun () ->
-    let id,const,do_guard,persistence,hook = get_proof opacity in
-    save id const do_guard persistence hook
-  end
-
-let check_anonymity id save_ident =
-  if atompart_of_id id <> string_of_id (default_thm_id) then
-    error "This command can only be used for unnamed theorem."
-
-let save_anonymous opacity save_ident =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.transaction p begin fun () ->
-    let id,const,do_guard,persistence,hook = get_proof opacity in
-    check_anonymity id save_ident;
-    save save_ident const do_guard persistence hook
-  end
-
-let save_anonymous_with_strength kind opacity save_ident =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.transaction p begin fun () ->
-    let id,const,do_guard,_,hook = get_proof opacity in
-    check_anonymity id save_ident;
-    (* we consider that non opaque behaves as local for discharge *)
-    save save_ident const do_guard (Global, Proof kind) hook
-  end
-
-(* Starting a goal *)
-
-let start_hook = ref ignore
-let set_start_hook = (:=) start_hook
-
-let start_proof id kind c ?init_tac ?(compute_guard=[]) hook =
-  let sign = initialize_named_context_for_proof () in
-  !start_hook c;
-  Pfedit.start_proof id kind sign c ?init_tac ~compute_guard hook
-
-let rec_tac_initializer finite guard thms snl =
-  if finite then
-    match List.map (fun (id,(t,_)) -> (id,t)) thms with
-    | (id,_)::l -> Hiddentac.h_mutual_cofix true id l
-    | _ -> assert false
-  else
-    (* nl is dummy: it will be recomputed at Qed-time *)
-    let nl = match snl with 
-     | None -> List.map succ (List.map list_last guard)
-     | Some nl -> nl
-    in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with
-       | (id,n,_)::l -> Hiddentac.h_mutual_fix true id n l
-       | _ -> assert false
-
-let start_proof_with_initialization kind recguard thms snl hook =
-  let intro_tac (_, (_, (ids, _))) =
-    Refiner.tclMAP (function
-    | Name id -> Tactics.intro_mustbe_force id
-    | Anonymous -> Tactics.intro) (List.rev ids) in
-  let init_tac,guard = match recguard with
-  | Some (finite,guard,init_tac) ->
-      let rec_tac = rec_tac_initializer finite guard thms snl in
-      Some (match init_tac with
-        | None -> 
-            if Flags.is_auto_intros () then 
-              tclTHENS rec_tac (List.map intro_tac thms)
-            else
-              rec_tac
-        | Some tacl ->
-            tclTHENS rec_tac
-            (if Flags.is_auto_intros () then
-              List.map2 (fun tac thm -> tclTHEN tac (intro_tac thm)) tacl thms
-            else
-              tacl)),guard
-  | None ->
-      assert (List.length thms = 1);
-      (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in
-  match thms with
-  | [] -> anomaly "No proof to start"
-  | (id,(t,(_,imps)))::other_thms ->
-      let hook strength ref =
-        let other_thms_data =
-          if other_thms = [] then [] else
-            (* there are several theorems defined mutually *)
-            let body,opaq = retrieve_first_recthm ref in
-            list_map_i (save_remaining_recthms kind body opaq) 1 other_thms in
-        let thms_data = (strength,ref,imps)::other_thms_data in
-        List.iter (fun (strength,ref,imps) ->
-	  maybe_declare_manual_implicits false ref imps;
-	  hook strength ref) thms_data in
-      start_proof id kind t ?init_tac hook ~compute_guard:guard
-
-let start_proof_com kind thms hook =
-  let evdref = ref Evd.empty in
-  let env0 = Global.env () in
-  let thms = List.map (fun (sopt,(bl,t,guard)) ->
-    let impls, ((env, ctx), imps) = interp_context_evars evdref env0 bl in
-    let t', imps' = interp_type_evars_impls ~impls ~evdref env t in
-    Sign.iter_rel_context (check_evars env Evd.empty !evdref) ctx;
-    let ids = List.map pi1 ctx in
-      (compute_proof_name (fst kind) sopt,
-      (nf_evar !evdref (it_mkProd_or_LetIn t' ctx),
-       (ids, imps @ lift_implicits (List.length ids) imps'),
-       guard)))
-    thms in
-  let recguard,thms,snl = look_for_possibly_mutual_statements thms in
-  start_proof_with_initialization kind recguard thms snl hook
-
-(* Admitted *)
-
-let admit () =
-  let (id,k,typ,hook) = Pfedit.current_proof_statement () in
-  let e = Pfedit.get_used_variables(), typ, None in
-  let kn =
-    declare_constant id (ParameterEntry e,IsAssumption Conjectural) in
-  Pfedit.delete_current_proof ();
-  assumption_message id;
-  hook Global (ConstRef kn)
-
-(* Miscellaneous *)
-
-let get_current_context () =
-  try Pfedit.get_current_goal_context ()
-  with e when Logic.catchable_exception e ->
-    (Evd.empty, Global.env())
diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml
deleted file mode 100644
index b392f82c..00000000
--- a/toplevel/libtypes.ml
+++ /dev/null
@@ -1,111 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-open Summary
-open Libobject
-open Libnames
-open Names
-(*
- * Module construction
- *)
-
-(* let reduce c = Reductionops.head_unfold_under_prod *)
-(*   (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances")) *)
-(*   (Global.env()) Evd.empty c *)
-
-let reduce c = c
-
-module TypeDnet = Term_dnet.Make
-  (struct
-     type t = Libnames.global_reference
-     let compare = RefOrdered.compare
-     let subst s gr = fst (Libnames.subst_global s gr)
-     let constr_of = Global.type_of_global
-   end)
-  (struct let reduce = reduce
-	  let direction = false
-   end)
-
-type result = Libnames.global_reference * (constr*existential_key) * Termops.subst
-
-let all_types = ref TypeDnet.empty
-let defined_types = ref TypeDnet.empty
-
-(*
- * Bookeeping & States
- *)
-
-let freeze () =
-  (!all_types,!defined_types)
-
-let unfreeze (lt,dt) =
-  all_types := lt;
-  defined_types := dt
-
-let init () =
-  all_types := TypeDnet.empty;
-  defined_types := TypeDnet.empty
-
-let _ =
-  declare_summary "type-library-state"
-    { freeze_function = freeze;
-      unfreeze_function = unfreeze;
-      init_function = init }
-
-let load (_,d) =
-(*  Profile.print_logical_stats !all_types;
-  Profile.print_logical_stats d;*)
-  all_types := TypeDnet.union d !all_types
-
-let subst s t = TypeDnet.subst s t
-(*
-let subst_key = Profile.declare_profile "subst"
-let subst a b = Profile.profile2 subst_key TypeDnet.subst a b
-
-let load_key = Profile.declare_profile "load"
-let load a = Profile.profile1 load_key load a
-*)
-let input : TypeDnet.t -> obj =
-  declare_object
-    { (default_object "LIBTYPES") with
-	load_function = (fun _ -> load);
-	subst_function = (fun (s,t) -> subst s t);
-	classify_function = (fun x -> Substitute x)
-    }
-
-let update () = Lib.add_anonymous_leaf (input !defined_types)
-
-(*
- * Search interface
- *)
-
-let search_pattern pat = TypeDnet.search_pattern !all_types pat
-let search_concl pat = TypeDnet.search_concl !all_types pat
-let search_head_concl pat = TypeDnet.search_head_concl !all_types pat
-let search_eq_concl eq pat = TypeDnet.search_eq_concl !all_types eq pat
-
-let add typ gr =
-  defined_types := TypeDnet.add typ gr !defined_types;
-  all_types := TypeDnet.add typ gr !all_types
-(*
-let add_key = Profile.declare_profile "add"
-let add a b = Profile.profile1 add_key add a b
-*)
-
-(*
- * Hooks declaration
- *)
-
-let _ = Declare.add_cache_hook
-  ( fun sp ->
-      let gr = Nametab.global_of_path sp in
-      let ty = Global.type_of_global gr in
-      add ty gr )
-
-let _ = Declaremods.set_end_library_hook update
diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli
deleted file mode 100644
index f8d31edb..00000000
--- a/toplevel/libtypes.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Term
-
-(** Persistent library of all declared object, indexed by their types 
-    (uses Dnets) *)
-
-(** results are the reference of the object, together with a context
-(constr+evar) and a substitution under this context *)
-type result = Libnames.global_reference * (constr*existential_key) * Termops.subst
-
-(** this is the reduction function used in the indexing process *)
-val reduce : types -> types
-
-(** The different types of search available. 
-    See term_dnet.mli for more explanations *)
-val search_pattern : types -> result list
-val search_concl : types -> result list
-val search_head_concl : types -> result list
-val search_eq_concl : constr -> types -> result list
diff --git a/toplevel/locality.ml b/toplevel/locality.ml
new file mode 100644
index 00000000..f711dad9
--- /dev/null
+++ b/toplevel/locality.ml
@@ -0,0 +1,99 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Managing locality *)
+
+let local_of_bool = function
+  | true -> Decl_kinds.Local
+  | false -> Decl_kinds.Global
+
+let check_locality locality_flag =
+  match locality_flag with
+  | Some b ->
+    let s = if b then "Local" else "Global" in
+    Errors.error ("This command does not support the \""^s^"\" prefix.")
+  | None -> ()
+
+(** Extracting the locality flag *)
+
+(* Commands which supported an inlined Local flag *)
+
+let enforce_locality_full locality_flag local =
+  let local =
+    match locality_flag with
+    | Some false when local ->
+	Errors.error "Cannot be simultaneously Local and Global."
+    | Some true when local ->
+	Errors.error "Use only prefix \"Local\"."
+    | None ->
+	if local then begin
+          Pp.msg_warning (Pp.str "Obsolete syntax: use \"Local\" as a prefix.");
+	  Some true
+	end else
+	None
+    | Some b -> Some b in
+  local
+
+(** Positioning locality for commands supporting discharging and export
+     outside of modules *)
+
+(* For commands whose default is to discharge and export:
+   Global is the default and is neutral;
+   Local in a section deactivates discharge,
+   Local not in a section deactivates export *)
+let make_non_locality = function Some false -> false | _ -> true
+
+let make_locality = function Some true -> true | _ -> false
+
+let enforce_locality locality_flag local =
+   make_locality (enforce_locality_full locality_flag local)
+
+let enforce_locality_exp locality_flag local =
+  match locality_flag, local with
+  | None, Some local -> local
+  | Some b, None -> local_of_bool b
+  | None, None -> Decl_kinds.Global
+  | Some _, Some _ -> Errors.error "Local non allowed in this case"
+
+(* For commands whose default is to not discharge but to export:
+   Global in sections forces discharge, Global not in section is the default;
+   Local in sections is the default, Local not in section forces non-export *)
+
+let make_section_locality =
+  function Some b -> b | None -> Lib.sections_are_opened ()
+
+let enforce_section_locality locality_flag local =
+  make_section_locality (enforce_locality_full locality_flag local)
+
+(** Positioning locality for commands supporting export but not discharge *)
+
+(* For commands whose default is to export (if not in section):
+   Global in sections is forbidden, Global not in section is neutral;
+   Local in sections is the default, Local not in section forces non-export *)
+
+let make_module_locality = function
+  | Some false ->
+      if Lib.sections_are_opened () then
+	Errors.error
+	  "This command does not support the Global option in sections.";
+      false
+  | Some true -> true
+  | None -> false
+
+let enforce_module_locality locality_flag local =
+  make_module_locality (enforce_locality_full locality_flag local)
+
+module LocalityFixme = struct
+  let locality = ref None
+  let set l = locality := l
+  let consume () =
+    let l = !locality in
+    locality := None;
+    l
+  let assert_consumed () = check_locality !locality
+end
diff --git a/toplevel/locality.mli b/toplevel/locality.mli
new file mode 100644
index 00000000..c395fe92
--- /dev/null
+++ b/toplevel/locality.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  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        *)
+(************************************************************************)
+
+(** * Managing locality *)
+
+(** Commands which supported an inlined Local flag *)
+
+val enforce_locality_full : bool option -> bool -> bool option
+
+(** * Positioning locality for commands supporting discharging and export
+    outside of modules *)
+
+(** For commands whose default is to discharge and export:
+    Global is the default and is neutral;
+    Local in a section deactivates discharge,
+    Local not in a section deactivates export *)
+
+val make_locality : bool option -> bool
+val make_non_locality : bool option -> bool
+val enforce_locality : bool option -> bool -> bool
+val enforce_locality_exp :
+  bool option -> Decl_kinds.locality option -> Decl_kinds.locality
+
+(** For commands whose default is to not discharge but to export:
+    Global in sections forces discharge, Global not in section is the default;
+    Local in sections is the default, Local not in section forces non-export *)
+
+val make_section_locality : bool option -> bool
+val enforce_section_locality : bool option -> bool -> bool
+
+(** * Positioning locality for commands supporting export but not discharge *)
+
+(** For commands whose default is to export (if not in section):
+    Global in sections is forbidden, Global not in section is neutral;
+    Local in sections is the default, Local not in section forces non-export *)
+
+val make_module_locality : bool option -> bool
+val enforce_module_locality : bool option -> bool -> bool
+
+(* This is the old imperative interface that is still used for
+ * VernacExtend vernaculars.  Time permitting this could be trashed too *)
+module LocalityFixme : sig
+  val set : bool option -> unit
+  val consume : unit -> bool option
+  val assert_consumed : unit -> unit
+end
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index 5a20f1c1..161cf824 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.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,33 +8,34 @@
 
 open Pp
 open Flags
-open Compat
+open Errors
 open Util
 open Names
-open Topconstr
+open Constrexpr
+open Constrexpr_ops
+open Notation_term
+open Notation_ops
 open Ppextend
 open Extend
 open Libobject
-open Summary
 open Constrintern
 open Vernacexpr
 open Pcoq
-open Glob_term
 open Libnames
 open Tok
-open Lexer
-open Egrammar
+open Egramml
+open Egramcoq
 open Notation
 open Nameops
 
 (**********************************************************************)
 (* Tokens                                                             *)
 
-let cache_token (_,s) = add_keyword s
+let cache_token (_,s) = Lexer.add_keyword s
 
 let inToken : string -> obj =
   declare_object {(default_object "TOKEN") with
-       open_function = (fun i o -> if i=1 then cache_token o);
+       open_function = (fun i o -> if Int.equal i 1 then cache_token o);
        cache_function = cache_token;
        subst_function = Libobject.ident_subst_function;
        classify_function = (fun o -> Substitute o)}
@@ -60,113 +61,184 @@ let rec make_tags = function
   | GramNonTerminal (loc, etyp, _, po) :: l -> etyp :: make_tags l
   | [] -> []
 
-let cache_tactic_notation (_,(pa,pp)) =
-  Egrammar.extend_grammar (Egrammar.TacticGrammar pa);
-  Pptactic.declare_extra_tactic_pprule pp
+type tactic_grammar_obj = {
+  tacobj_local : locality_flag;
+  tacobj_tacgram : tactic_grammar;
+  tacobj_tacpp : Pptactic.pp_tactic;
+  tacobj_body : Tacexpr.glob_tactic_expr
+}
 
-let subst_tactic_parule subst (key,n,p,(d,tac)) =
-  (key,n,p,(d,Tacinterp.subst_tactic subst tac))
+let cache_tactic_notation ((_, key), tobj) =
+  Tacenv.register_alias key tobj.tacobj_body;
+  Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram;
+  Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp
 
-let subst_tactic_notation (subst,(pa,pp)) =
-  (subst_tactic_parule subst pa,pp)
+let open_tactic_notation i ((_, key), tobj) =
+  if Int.equal i 1 && not tobj.tacobj_local then
+    Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram
 
-type tactic_grammar_obj =
-    (string * int * grammar_prod_item list *
-       (dir_path * Tacexpr.glob_tactic_expr))
-    * (string * Genarg.argument_type list * (int * Pptactic.grammar_terminals))
+let load_tactic_notation i ((_, key), tobj) =
+  (** Only add the printing and interpretation rules. *)
+  Tacenv.register_alias key tobj.tacobj_body;
+  Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp;
+  if Int.equal i 1 && not tobj.tacobj_local then
+    Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram
+
+let subst_tactic_notation (subst, tobj) =
+  { tobj with tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; }
+
+let classify_tactic_notation tacobj = Substitute tacobj
 
 let inTacticGrammar : tactic_grammar_obj -> obj =
   declare_object {(default_object "TacticGrammar") with
-       open_function = (fun i o -> if i=1 then cache_tactic_notation o);
+       open_function = open_tactic_notation;
+       load_function = load_tactic_notation;
        cache_function = cache_tactic_notation;
        subst_function = subst_tactic_notation;
-       classify_function = (fun o -> Substitute o)}
+       classify_function = classify_tactic_notation}
 
 let cons_production_parameter l = function
   | GramTerminal _ -> l
   | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l
 
-let rec tactic_notation_key = function
-  | GramTerminal id :: _ -> id
-  | _ :: l -> tactic_notation_key l
-  | [] -> "terminal_free_notation"
-
-let rec next_key_away key t =
-  if Pptactic.exists_extra_tactic_pprule key t then next_key_away (key^"'") t
-  else key
-
-let add_tactic_notation (n,prods,e) =
+let add_tactic_notation (local,n,prods,e) =
   let prods = List.map (interp_prod_item n) prods in
   let tags = make_tags prods in
-  let key = next_key_away (tactic_notation_key prods) tags in
-  let pprule = (key,tags,(n,List.map make_terminal_status prods)) in
+  let pprule = {
+    Pptactic.pptac_args = tags;
+    pptac_prods = (n, List.map make_terminal_status prods);
+  } in
   let ids = List.fold_left cons_production_parameter [] prods in
-  let tac = Tacinterp.glob_tactic_env ids (Global.env()) e in
-  let parule = (key,n,prods,(Lib.cwd(),tac)) in
-  Lib.add_anonymous_leaf (inTacticGrammar (parule,pprule))
+  let tac = Tacintern.glob_tactic_env ids (Global.env()) e in
+  let parule = {
+    tacgram_level = n;
+    tacgram_prods = prods;
+  } in
+  let tacobj = {
+    tacobj_local = local;
+    tacobj_tacgram = parule;
+    tacobj_tacpp = pprule;
+    tacobj_body = tac;
+  } in
+  Lib.add_anonymous_leaf (inTacticGrammar tacobj)
+
+(**********************************************************************)
+(* ML Tactic entries                                                  *)
+
+type atomic_entry = string * Genarg.glob_generic_argument list option
+
+type ml_tactic_grammar_obj = {
+  mltacobj_name : Tacexpr.ml_tactic_name;
+  (** ML-side unique name *)
+  mltacobj_prod : grammar_prod_item list list;
+  (** Grammar rules generating the ML tactic. *)
+}
+
+(** ML tactic notations whose use can be restricted to an identifier are added
+    as true Ltac entries. *)
+let extend_atomic_tactic name entries =
+  let add_atomic (id, args) = match args with
+  | None -> ()
+  | Some args ->
+    let body = Tacexpr.TacML (Loc.ghost, name, args) in
+    Tacenv.register_ltac false false (Names.Id.of_string id) body
+  in
+  List.iter add_atomic entries
+
+let cache_ml_tactic_notation (_, obj) =
+  extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod
+
+let open_ml_tactic_notation i obj =
+  if Int.equal i 1 then cache_ml_tactic_notation obj
+
+let inMLTacticGrammar : ml_tactic_grammar_obj -> obj =
+  declare_object { (default_object "MLTacticGrammar") with
+    open_function = open_ml_tactic_notation;
+    cache_function = cache_ml_tactic_notation;
+    classify_function = (fun o -> Substitute o);
+    subst_function = (fun (_, o) -> o);
+  }
+
+let add_ml_tactic_notation name prods atomic =
+  let obj = {
+    mltacobj_name = name;
+    mltacobj_prod = prods;
+  } in
+  Lib.add_anonymous_leaf (inMLTacticGrammar obj);
+  extend_atomic_tactic name atomic
 
 (**********************************************************************)
 (* Printing grammar entries                                           *)
 
-let print_grammar = function
+let entry_buf = Buffer.create 64
+
+let pr_entry e =
+  let () = Buffer.clear entry_buf in
+  let ft = Format.formatter_of_buffer entry_buf in
+  let () = Gram.entry_print ft e in
+  str (Buffer.contents entry_buf)
+
+let pr_grammar = function
   | "constr" | "operconstr" | "binder_constr" ->
-      msgnl (str "Entry constr is");
-      Gram.entry_print Pcoq.Constr.constr;
-      msgnl (str "and lconstr is");
-      Gram.entry_print Pcoq.Constr.lconstr;
-      msgnl (str "where binder_constr is");
-      Gram.entry_print Pcoq.Constr.binder_constr;
-      msgnl (str "and operconstr is");
-      Gram.entry_print Pcoq.Constr.operconstr;
+      str "Entry constr is" ++ fnl () ++
+      pr_entry Pcoq.Constr.constr ++
+      str "and lconstr is" ++ fnl () ++
+      pr_entry Pcoq.Constr.lconstr ++
+      str "where binder_constr is" ++ fnl () ++
+      pr_entry Pcoq.Constr.binder_constr ++
+      str "and operconstr is" ++ fnl () ++
+      pr_entry Pcoq.Constr.operconstr
   | "pattern" ->
-      Gram.entry_print Pcoq.Constr.pattern
+      pr_entry Pcoq.Constr.pattern
   | "tactic" ->
-      msgnl (str "Entry tactic_expr is");
-      Gram.entry_print Pcoq.Tactic.tactic_expr;
-      msgnl (str "Entry binder_tactic is");
-      Gram.entry_print Pcoq.Tactic.binder_tactic;
-      msgnl (str "Entry simple_tactic is");
-      Gram.entry_print Pcoq.Tactic.simple_tactic;
+      str "Entry tactic_expr is" ++ fnl () ++
+      pr_entry Pcoq.Tactic.tactic_expr ++
+      str "Entry binder_tactic is" ++ fnl () ++
+      pr_entry Pcoq.Tactic.binder_tactic ++
+      str "Entry simple_tactic is" ++ fnl () ++
+      pr_entry Pcoq.Tactic.simple_tactic ++
+      str "Entry tactic_arg is" ++ fnl () ++
+      pr_entry Pcoq.Tactic.tactic_arg
   | "vernac" ->
-      msgnl (str "Entry vernac is");
-      Gram.entry_print Pcoq.Vernac_.vernac;
-      msgnl (str "Entry command is");
-      Gram.entry_print Pcoq.Vernac_.command;
-      msgnl (str "Entry syntax is");
-      Gram.entry_print Pcoq.Vernac_.syntax;
-      msgnl (str "Entry gallina is");
-      Gram.entry_print Pcoq.Vernac_.gallina;
-      msgnl (str "Entry gallina_ext is");
-      Gram.entry_print Pcoq.Vernac_.gallina_ext;
+      str "Entry vernac is" ++ fnl () ++
+      pr_entry Pcoq.Vernac_.vernac ++
+      str "Entry command is" ++ fnl () ++
+      pr_entry Pcoq.Vernac_.command ++
+      str "Entry syntax is" ++ fnl () ++
+      pr_entry Pcoq.Vernac_.syntax ++
+      str "Entry gallina is" ++ fnl () ++
+      pr_entry Pcoq.Vernac_.gallina ++
+      str "Entry gallina_ext is" ++ fnl () ++
+      pr_entry Pcoq.Vernac_.gallina_ext
   | _ -> error "Unknown or unprintable grammar entry."
 
 (**********************************************************************)
 (* Parse a format (every terminal starting with a letter or a single
    quote (except a single quote alone) must be quoted) *)
 
-let parse_format (loc,str) =
+let parse_format ((loc, str) : lstring) =
   let str = " "^str in
   let l = String.length str in
   let push_token a = function
     | cur::l -> (a::cur)::l
     | [] -> [[a]] in
   let push_white n l =
-    if n = 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
+    if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
   let close_box i b = function
     | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
     | _ -> error "Non terminated box in format." in
   let close_quotation i =
-    if i < String.length str & str.[i] = '\'' & (i+1 = l or str.[i+1] = ' ')
+    if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ')
     then i+1
     else error "Incorrectly terminated quoted expression." in
   let rec spaces n i =
-    if i < String.length str & str.[i] = ' ' then spaces (n+1) (i+1)
+    if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1)
     else n in
   let rec nonspaces quoted n i =
-    if i < String.length str & str.[i] <> ' ' then
-      if str.[i] = '\'' & quoted &
-        (i+1 >= String.length str or str.[i+1] = ' ')
-      then if n=0 then error "Empty quoted token." else n
+    if i < String.length str && str.[i] != ' ' then
+      if str.[i] == '\'' && quoted &&
+        (i+1 >= String.length str || str.[i+1] == ' ')
+      then if Int.equal n 0 then error "Empty quoted token." else n
       else nonspaces quoted (n+1) (i+1)
     else
       if quoted then error "Spaces are not allowed in (quoted) symbols."
@@ -177,7 +249,7 @@ let parse_format (loc,str) =
   and parse_quoted n i =
     if i < String.length str then match str.[i] with
       (* Parse " // " *)
-      | '/' when i <= String.length str & str.[i+1] = '/' ->
+      | '/' when i <= String.length str && str.[i+1] == '/' ->
           (* We forget the useless n spaces... *)
 	  push_token (UnpCut PpFnl)
             (parse_token (close_quotation (i+2)))
@@ -192,7 +264,7 @@ let parse_format (loc,str) =
       | '[' ->
 	  if i <= String.length str then match str.[i+1] with
 	    (* Parse " [h .. ",  *)
-	    | 'h' when i+1 <= String.length str & str.[i+2] = 'v' ->
+	    | 'h' when i+1 <= String.length str && str.[i+2] == 'v' ->
 		  (parse_box (fun n -> PpHVB n) (i+3))
 		(* Parse " [v .. ",  *)
 	    | 'v' ->
@@ -211,7 +283,7 @@ let parse_format (loc,str) =
 	  push_token (UnpTerminal (String.sub str (i-1) (n+2)))
 	    (parse_token (close_quotation (i+n))))
     else
-      if n = 0 then []
+      if Int.equal n 0 then []
       else error "Ending spaces non part of a format annotation."
   and parse_box box i =
     let n = spaces 0 i in
@@ -221,7 +293,7 @@ let parse_format (loc,str) =
     let i = i+n in
     if i < l then match str.[i] with
       (* Parse a ' *)
-      |	'\'' when i+1 >= String.length str or str.[i+1] = ' ' ->
+      |	'\'' when i+1 >= String.length str || str.[i+1] == ' ' ->
 	  push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1)))
       (* Parse the beginning of a quoted expression *)
       |	'\'' ->
@@ -232,13 +304,15 @@ let parse_format (loc,str) =
     else push_white n [[]]
   in
   try
-    if str <> "" then match parse_token 0 with
+    if not (String.is_empty str) then match parse_token 0 with
       | [l] -> l
       | _ -> error "Box closed without being opened in format."
     else
       error "Empty format."
-  with e when Errors.noncritical e ->
-    Loc.raise loc e
+  with reraise ->
+    let (e, info) = Errors.push reraise in
+    let info = Loc.add_loc info loc in
+    iraise (e, info)
 
 (***********************)
 (* Analyzing notations *)
@@ -247,16 +321,16 @@ type symbol_token = WhiteSpace of int | String of string
 
 let split_notation_string str =
   let push_token beg i l =
-    if beg = i then l else
+    if Int.equal beg i then l else
       let s = String.sub str beg (i - beg) in
       String s :: l
   in
   let push_whitespace beg i l =
-    if beg = i then l else WhiteSpace (i-beg) :: l
+    if Int.equal beg i then l else WhiteSpace (i-beg) :: l
   in
   let rec loop beg i =
     if i < String.length str then
-      if str.[i] = ' ' then
+      if str.[i] == ' ' then
 	push_token beg i (loop_on_whitespace (i+1) (i+1))
       else
 	loop beg (i+1)
@@ -264,7 +338,7 @@ let split_notation_string str =
       push_token beg i []
   and loop_on_whitespace beg i =
     if i < String.length str then
-      if str.[i] <> ' ' then
+      if str.[i] != ' ' then
 	push_whitespace beg i (loop i (i+1))
       else
 	loop_on_whitespace beg (i+1)
@@ -281,25 +355,25 @@ let msg_expected_form_of_recursive_notation =
   "In the notation, the special symbol \"..\" must occur in\na configuration of the form \"x symbs .. symbs y\"."
 
 let rec find_pattern nt xl = function
-  | Break n as x :: l, Break n' :: l' when n=n' ->
+  | Break n as x :: l, Break n' :: l' when Int.equal n n' ->
       find_pattern nt (x::xl) (l,l')
-  | Terminal s as x :: l, Terminal s' :: l' when s = s' ->
+  | Terminal s as x :: l, Terminal s' :: l' when String.equal s s' ->
       find_pattern nt (x::xl) (l,l')
   | [], NonTerminal x' :: l' ->
       (out_nt nt,x',List.rev xl),l'
-  | _, Terminal s :: _ | Terminal s :: _, _ ->
-      error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.")
   | _, Break s :: _ | Break s :: _, _ ->
       error ("A break occurs on one side of \"..\" but not on the other side.")
+  | _, Terminal s :: _ | Terminal s :: _, _ ->
+      error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.")
   | _, [] ->
       error msg_expected_form_of_recursive_notation
   | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
-      anomaly "Only Terminal or Break expected on left, non-SProdList on right"
+      anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right")
 
 let rec interp_list_parser hd = function
   | [] -> [], List.rev hd
-  | NonTerminal id :: tl when id = ldots_var ->
-      if hd = [] then error msg_expected_form_of_recursive_notation;
+  | NonTerminal id :: tl when Id.equal id ldots_var ->
+      if List.is_empty hd then error msg_expected_form_of_recursive_notation;
       let hd = List.rev hd in
       let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in
       let xyl,tl'' = interp_list_parser [] tl' in
@@ -307,7 +381,7 @@ let rec interp_list_parser hd = function
       (* remove the second copy of it afterwards *)
       (x,y)::xyl, SProdList (x,sl) :: tl''
   | (Terminal _ | Break _) as s :: tl ->
-      if hd = [] then
+      if List.is_empty hd then
         let yl,tl' = interp_list_parser [] tl in
         yl, s :: tl'
       else
@@ -315,7 +389,7 @@ let rec interp_list_parser hd = function
   | NonTerminal _ as x :: tl ->
       let xyl,tl' = interp_list_parser [x] tl in
       xyl, List.rev_append hd tl'
-  | SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser"
+  | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser")
 
 
 (* Find non-terminal tokens of notation *)
@@ -323,26 +397,25 @@ let rec interp_list_parser hd = function
 (* To protect alphabetic tokens and quotes from being seen as variables *)
 let quote_notation_token x =
   let n = String.length x in
-  let norm = is_ident x in
-  if (n > 0 & norm) or (n > 2 & x.[0] = '\'') then "'"^x^"'"
+  let norm = Lexer.is_ident x in
+  if (n > 0 && norm) || (n > 2 && x.[0] == '\'') then "'"^x^"'"
   else x
 
 let rec raw_analyze_notation_tokens = function
   | []    -> []
   | String ".." :: sl -> NonTerminal ldots_var :: raw_analyze_notation_tokens sl
   | String "_" :: _ -> error "_ must be quoted."
-  | String x :: sl when is_ident x ->
-      NonTerminal (Names.id_of_string x) :: raw_analyze_notation_tokens sl
+  | String x :: sl when Lexer.is_ident x ->
+      NonTerminal (Names.Id.of_string x) :: raw_analyze_notation_tokens sl
   | String s :: sl ->
-      Terminal (drop_simple_quotes s) :: raw_analyze_notation_tokens sl
+      Terminal (String.drop_simple_quotes s) :: raw_analyze_notation_tokens sl
   | WhiteSpace n :: sl ->
       Break n :: raw_analyze_notation_tokens sl
 
 let is_numeral symbs =
   match List.filter (function Break _ -> false | _ -> true) symbs with
   | ([Terminal "-"; Terminal x] | [Terminal x]) ->
-      (try let _ = Bigint.of_string x in true
-       with e when Errors.noncritical e -> false)
+      (try let _ = Bigint.of_string x in true with Failure _ -> false)
   | _ ->
       false
 
@@ -350,9 +423,9 @@ let rec get_notation_vars = function
   | [] -> []
   | NonTerminal id :: sl ->
       let vars = get_notation_vars sl in
-      if id = ldots_var then vars else
-	if List.mem id vars then
-	  error ("Variable "^string_of_id id^" occurs more than once.")
+      if Id.equal id ldots_var then vars else
+	if Id.List.mem id vars then
+	  error ("Variable "^Id.to_string id^" occurs more than once.")
 	else
           id::vars
   | (Terminal _ | Break _) :: sl -> get_notation_vars sl
@@ -362,18 +435,15 @@ let analyze_notation_tokens l =
   let l = raw_analyze_notation_tokens l in
   let vars = get_notation_vars l in
   let recvars,l = interp_list_parser [] l in
-  recvars, list_subtract vars (List.map snd recvars), l
+  recvars, List.subtract Id.equal vars (List.map snd recvars), l
 
 let error_not_same_scope x y =
-  error ("Variables "^string_of_id x^" and "^string_of_id y^
+  error ("Variables "^Id.to_string x^" and "^Id.to_string y^
     " must be in the same scope.")
 
 (**********************************************************************)
 (* Build pretty-printing rules                                        *)
 
-type printing_precedence = int * parenRelation
-type parsing_precedence = int option
-
 let prec_assoc = function
   | RightA -> (L,E)
   | LeftA -> (E,L)
@@ -382,7 +452,7 @@ let prec_assoc = function
 let precedence_of_entry_type from = function
   | ETConstr (NumLevel n,BorderProd (_,None)) -> n, Prec n
   | ETConstr (NumLevel n,BorderProd (b,Some a)) ->
-      n, let (lp,rp) = prec_assoc a in if b=Left then lp else rp
+      n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp
   | ETConstr (NumLevel n,InternalProd) -> n, Prec n
   | ETConstr (NextLevel,_) -> from, L
   | _ -> 0, E (* ?? *)
@@ -395,36 +465,50 @@ let precedence_of_entry_type from = function
 (* "{ x } + { y }" : "{ x } / + { y }" *)
 (* "< x , y > { z , t }" : "< x , / y > / { z , / t }" *)
 
+let starts_with_left_bracket s =
+  let l = String.length s in not (Int.equal l 0) &&
+  (s.[0] == '{' || s.[0] == '[' || s.[0] == '(')
+
+let ends_with_right_bracket s =
+  let l = String.length s in not (Int.equal l 0) &&
+  (s.[l-1] == '}' || s.[l-1] == ']' || s.[l-1] == ')')
+
 let is_left_bracket s =
-  let l = String.length s in l <> 0 &
-  (s.[0] = '{' or s.[0] = '[' or s.[0] = '(')
+  starts_with_left_bracket s && not (ends_with_right_bracket s)
 
 let is_right_bracket s =
-  let l = String.length s in l <> 0 &
-  (s.[l-1] = '}' or s.[l-1] = ']' or s.[l-1] = ')')
+  not (starts_with_left_bracket s) && ends_with_right_bracket s
 
 let is_comma s =
-  let l = String.length s in l <> 0 &
-  (s.[0] = ',' or s.[0] = ';')
+  let l = String.length s in not (Int.equal l 0) &&
+  (s.[0] == ',' || s.[0] == ';')
 
 let is_operator s =
-  let l = String.length s in l <> 0 &
-  (s.[0] = '+' or s.[0] = '*' or s.[0] = '=' or
-   s.[0] = '-' or s.[0] = '/' or s.[0] = '<' or s.[0] = '>' or
-   s.[0] = '@' or s.[0] = '\\' or s.[0] = '&' or s.[0] = '~' or s.[0] = '$')
+  let l = String.length s in not (Int.equal l 0) &&
+  (s.[0] == '+' || s.[0] == '*' || s.[0] == '=' ||
+   s.[0] == '-' || s.[0] == '/' || s.[0] == '<' || s.[0] == '>' ||
+   s.[0] == '@' || s.[0] == '\\' || s.[0] == '&' || s.[0] == '~' || s.[0] == '$')
 
-let is_prod_ident = function
-  | Terminal s when is_letter s.[0] or s.[0] = '_' -> true
-  | _ -> false
-
-let rec is_non_terminal = function
+let is_non_terminal = function
   | NonTerminal _ | SProdList _ -> true
   | _ -> false
 
+let is_next_non_terminal = function
+| [] -> false
+| pr :: _ -> is_non_terminal pr
+
+let is_next_terminal = function Terminal _ :: _ -> true | _ -> false
+
+let is_next_break = function Break _ :: _ -> true | _ -> false
+
 let add_break n l = UnpCut (PpBrk(n,0)) :: l
 
+let add_break_if_none n = function
+  | ((UnpCut (PpBrk _) :: _) | []) as l -> l
+  | l -> UnpCut (PpBrk(n,0)) :: l
+
 let check_open_binder isopen sl m =
-  if isopen & sl <> [] then
+  if isopen && not (List.is_empty sl) then
     errorlabstrm "" (str "as " ++ pr_id m ++
       str " is a non-closed binder, no such \"" ++
       prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl
@@ -432,84 +516,93 @@ let check_open_binder isopen sl m =
 
 (* Heuristics for building default printing rules *)
 
-type previous_prod_status = NoBreak | CanBreak
+let index_id id l = List.index Id.equal id l
 
 let make_hunks etyps symbols from =
   let vars,typs = List.split etyps in
-  let rec make ws = function
+  let rec make = function
     | NonTerminal m :: prods ->
-	let i = list_index m vars in
+	let i = index_id m vars in
 	let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
 	let u = UnpMetaVar (i,prec) in
-	if prods <> [] && is_non_terminal (List.hd prods) then
-	  u :: add_break 1 (make CanBreak prods)
+	if is_next_non_terminal prods then
+	  u :: add_break_if_none 1 (make prods)
 	else
-	  u :: make CanBreak prods
-
+	  u :: make_with_space prods
     | Terminal s :: prods when List.exists is_non_terminal prods ->
-        if is_comma s then
-	  UnpTerminal s :: add_break 1 (make NoBreak prods)
-	else if is_right_bracket s then
-	  UnpTerminal s :: add_break 0 (make NoBreak prods)
-	else if is_left_bracket s then
-          if ws = CanBreak then
-	    add_break 1 (UnpTerminal s :: make CanBreak prods)
-	  else
-	    UnpTerminal s :: make CanBreak prods
-	else if is_operator s then
-	  if ws = CanBreak then
-	    UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods)
-	  else
-	    UnpTerminal s :: add_break 1 (make NoBreak prods)
-	else if is_ident_tail s.[String.length s - 1] then
-	  let sep = if is_prod_ident (List.hd prods) then "" else " " in
-	  if ws = CanBreak then
-	    add_break 1 (UnpTerminal (s^sep) :: make CanBreak prods)
-	  else
-	    UnpTerminal (s^sep) :: make CanBreak prods
-	else if ws = CanBreak then
-	  add_break 1 (UnpTerminal (s^" ") :: make CanBreak prods)
-	else
-	  UnpTerminal s :: make CanBreak prods
+        if (is_comma s || is_operator s) then
+          (* Always a breakable space after comma or separator *)
+	  UnpTerminal s :: add_break_if_none 1 (make prods)
+	else if is_right_bracket s && is_next_terminal prods then
+          (* Always no space after right bracked, but possibly a break *)
+	  UnpTerminal s :: add_break_if_none 0 (make prods)
+        else if is_left_bracket s  && is_next_non_terminal prods then
+	  UnpTerminal s :: make prods
+	else if not (is_next_break prods) then
+          (* Add rigid space, no break, unless user asked for something *)
+          UnpTerminal (s^" ") :: make prods
+        else
+          (* Rely on user spaces *)
+          UnpTerminal s :: make prods
 
     | Terminal s :: prods ->
-	if is_right_bracket s then
-	  UnpTerminal s :: make NoBreak prods
-        else if ws = CanBreak then
-	  add_break 1 (UnpTerminal s :: make NoBreak prods)
-        else
-          UnpTerminal s :: make NoBreak prods
+        (* Separate but do not cut a trailing sequence of terminal *)
+        (match prods with
+        | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods
+        | _ -> UnpTerminal s :: make prods)
 
     | Break n :: prods ->
-	add_break n (make NoBreak prods)
+	add_break n (make prods)
 
     | SProdList (m,sl) :: prods ->
-	let i = list_index m vars in
+	let i = index_id m vars in
 	let typ = List.nth typs (i-1) in
 	let _,prec = precedence_of_entry_type from typ in
         let sl' =
           (* If no separator: add a break *)
-	  if sl = [] then add_break 1 []
+	  if List.is_empty sl then add_break 1 []
           (* We add NonTerminal for simulation but remove it afterwards *)
-	  else snd (list_sep_last (make NoBreak (sl@[NonTerminal m]))) in
+	  else snd (List.sep_last (make (sl@[NonTerminal m]))) in
 	let hunk = match typ with
 	  | ETConstr _ -> UnpListMetaVar (i,prec,sl')
 	  | ETBinder isopen ->
 	      check_open_binder isopen sl m;
 	      UnpBinderListMetaVar (i,isopen,sl')
 	  | _ -> assert false in
-	hunk :: make CanBreak prods
+	hunk :: make_with_space prods
 
     | [] -> []
 
-  in make NoBreak symbols
+  and make_with_space prods =
+    match prods with
+    | Terminal s' :: prods'->
+        if is_operator s' then
+          (* A rigid space before operator and a breakable after *)
+          UnpTerminal (" "^s') :: add_break_if_none 1 (make prods')
+        else if is_comma s' then
+          (* No space whatsoever before comma *)
+          make prods
+        else if is_right_bracket s' then
+          make prods
+        else
+          (* A breakable space between any other two terminals *)
+          add_break_if_none 1 (make prods)
+    | (NonTerminal _ | SProdList _) :: _ ->
+        (* A breakable space before a non-terminal *)
+        add_break_if_none 1 (make prods)
+    | Break _ :: _ ->
+        (* Rely on user wish *)
+        make prods
+    | [] -> []
+
+  in make symbols
 
 (* Build default printing rules from explicit format *)
 
 let error_format () = error "The format does not match the notation."
 
 let rec split_format_at_ldots hd = function
-  | UnpTerminal s :: fmt when s = string_of_id ldots_var -> List.rev hd, fmt
+  | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt
   | u :: fmt ->
       check_no_ldots_in_box u;
       split_format_at_ldots (u::hd) fmt
@@ -535,7 +628,7 @@ let read_recursive_format sl fmt =
     let sl = skip_var_in_recursive_format fmt in
     try split_format_at_ldots [] sl with Exit -> error_format () in
   let rec get_tail = function
-    | a :: sepfmt, b :: fmt when a = b -> get_tail (sepfmt, fmt)
+    | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
     | [], tail -> skip_var_in_recursive_format tail
     | _ -> error "The format is not the same on the right and left hand side of the special token \"..\"." in
   let slfmt, fmt = get_head fmt in
@@ -544,13 +637,13 @@ let read_recursive_format sl fmt =
 let hunks_of_format (from,(vars,typs)) symfmt =
   let rec aux = function
   | symbs, (UnpTerminal s' as u) :: fmt
-      when s' = String.make (String.length s') ' ' ->
+      when String.equal s' (String.make (String.length s') ' ') ->
       let symbs, l = aux (symbs,fmt) in symbs, u :: l
   | Terminal s :: symbs, (UnpTerminal s') :: fmt
-      when s = drop_simple_quotes s' ->
+      when String.equal s (String.drop_simple_quotes s') ->
       let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
-  | NonTerminal s :: symbs, UnpTerminal s' :: fmt when s = id_of_string s' ->
-      let i = list_index s vars in
+  | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') ->
+      let i = index_id s vars in
       let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
       let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
   | symbs, UnpBox (a,b) :: fmt ->
@@ -560,12 +653,12 @@ let hunks_of_format (from,(vars,typs)) symfmt =
   | symbs, (UnpCut _ as u) :: fmt ->
       let symbs, l = aux (symbs,fmt) in symbs, u :: l
   | SProdList (m,sl) :: symbs, fmt ->
-      let i = list_index m vars in
+      let i = index_id m vars in
       let typ = List.nth typs (i-1) in
       let _,prec = precedence_of_entry_type from typ in
       let slfmt,fmt = read_recursive_format sl fmt in
       let sl, slfmt = aux (sl,slfmt) in
-      if sl <> [] then error_format ();
+      if not (List.is_empty sl) then error_format ();
       let symbs, l = aux (symbs,fmt) in
       let hunk = match typ with
 	| ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
@@ -594,7 +687,7 @@ let is_not_small_constr = function
 let rec define_keywords_aux = function
   | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l
       when is_not_small_constr e ->
-      message ("Identifier '"^k^"' now a keyword");
+      Flags.if_verbose msg_info (strbrk ("Identifier '"^k^"' now a keyword"));
       Lexer.add_keyword k;
       n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | n :: l -> n :: define_keywords_aux l
@@ -603,7 +696,7 @@ let rec define_keywords_aux = function
   (* Ensure that IDENT articulation terminal symbols are keywords *)
 let define_keywords = function
   | GramConstrTerminal(IDENT k)::l ->
-      message ("Identifier '"^k^"' now a keyword");
+      Flags.if_verbose msg_info (strbrk ("Identifier '"^k^"' now a keyword"));
       Lexer.add_keyword k;
       GramConstrTerminal(KEYWORD k) :: define_keywords_aux l
   | l -> define_keywords_aux l
@@ -613,7 +706,7 @@ let distribute a ll = List.map (fun l -> a @ l) ll
   (* Expand LIST1(t,sep) into the combination of t and t;sep;LIST1(t,sep)
      as many times as expected in [n] argument *)
 let rec expand_list_rule typ tkl x n i hds ll =
-  if i = n then
+  if Int.equal i n then
     let hds =
       GramConstrListMark (n,true) :: hds
       @	[GramConstrNonTerminal (ETConstrList (typ,tkl), Some x)] in
@@ -633,14 +726,14 @@ let make_production etyps symbols =
 	    let typ = List.assoc m etyps in
 	    distribute [GramConstrNonTerminal (typ, Some m)] ll
         | Terminal s ->
-	    distribute [GramConstrTerminal (terminal s)] ll
+	    distribute [GramConstrTerminal (Lexer.terminal s)] ll
         | Break _ ->
             ll
         | SProdList (x,sl) ->
             let tkl = List.flatten
-              (List.map (function Terminal s -> [terminal s]
+              (List.map (function Terminal s -> [Lexer.terminal s]
                 | Break _ -> []
-                | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
+                | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in
 	    match List.assoc x etyps with
             | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll
             | ETBinder o ->
@@ -654,7 +747,7 @@ let make_production etyps symbols =
 let rec find_symbols c_current c_next c_last = function
   | [] -> []
   | NonTerminal id :: sl ->
-      let prec = if sl <> [] then c_current else c_last in
+      let prec = if not (List.is_empty sl) then c_current else c_last in
       (id, prec) :: (find_symbols c_next c_next c_last sl)
   | Terminal s :: sl -> find_symbols c_next c_next c_last sl
   | Break n :: sl -> find_symbols c_current c_next c_last sl
@@ -676,10 +769,10 @@ let recompute_assoc typs =
 (* Registration of syntax extensions (parsing/printing, no interpretation)*)
 
 let pr_arg_level from = function
-  | (n,L) when n=from -> str "at next level"
+  | (n,L) when Int.equal n from -> str "at next level"
   | (n,E) -> str "at level " ++ int n
   | (n,L) -> str "at level below " ++ int n
-  | (n,Prec m) when m=n -> str "at level " ++ int n
+  | (n,Prec m) when Int.equal m n -> str "at level " ++ int n
   | (n,_) -> str "Unknown level"
 
 let pr_level ntn (from,args) =
@@ -693,42 +786,51 @@ let error_incompatible_level ntn oldprec prec =
     spc() ++ str "while it is now required to be" ++ spc() ++
     pr_level ntn prec ++ str ".")
 
-let cache_one_syntax_extension (typs,prec,ntn,gr,pp) =
+type syntax_extension = {
+  synext_level : Notation.level;
+  synext_notation : notation;
+  synext_notgram : notation_grammar;
+  synext_unparsing : unparsing list;
+  synext_extra : (string * string) list;
+}
+
+type syntax_extension_obj = locality_flag * syntax_extension list
+
+let cache_one_syntax_extension se =
+  let ntn = se.synext_notation in
+  let prec = se.synext_level in
   try
     let oldprec = Notation.level_of_notation ntn in
-    if prec <> oldprec then error_incompatible_level ntn oldprec prec
+    if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec
   with Not_found ->
     (* Reserve the notation level *)
     Notation.declare_notation_level ntn prec;
     (* Declare the parsing rule *)
-    Egrammar.extend_grammar (Egrammar.Notation (prec,typs,gr));
+    Egramcoq.extend_constr_grammar prec se.synext_notgram;
     (* Declare the printing rule *)
-    Notation.declare_notation_printing_rule ntn (pp,fst prec)
+    Notation.declare_notation_printing_rule ntn
+      ~extra:se.synext_extra (se.synext_unparsing, fst prec)
 
-let cache_syntax_extension (_,(_,sy_rules)) =
-  List.iter cache_one_syntax_extension sy_rules
+let cache_syntax_extension (_, (_, sy)) =
+  List.iter cache_one_syntax_extension sy
 
 let subst_parsing_rule subst x = x
 
 let subst_printing_rule subst x = x
 
-let subst_syntax_extension (subst,(local,sy)) =
-  (local, List.map (fun (typs,prec,ntn,gr,pp) ->
-     (typs,prec,ntn,subst_parsing_rule subst gr,subst_printing_rule subst pp))
-    sy)
+let subst_syntax_extension (subst, (local, sy)) =
+  let map sy = { sy with
+    synext_notgram = subst_parsing_rule subst sy.synext_notgram;
+    synext_unparsing = subst_printing_rule subst sy.synext_unparsing;
+  } in
+  (local, List.map map sy)
 
-let classify_syntax_definition (local,_ as o) =
+let classify_syntax_definition (local, _ as o) =
   if local then Dispose else Substitute o
 
-type syntax_extension_obj =
-    bool *
-      (notation_var_internalization_type list * Notation.level *
-         notation * notation_grammar * unparsing list)
-      list
-
 let inSyntaxExtension : syntax_extension_obj -> obj =
   declare_object {(default_object "SYNTAX-EXTENSION") with
-       open_function = (fun i o -> if i=1 then cache_syntax_extension o);
+       open_function = (fun i o -> if Int.equal i 1 then cache_syntax_extension o);
        cache_function = cache_syntax_extension;
        subst_function = subst_syntax_extension;
        classify_function = classify_syntax_definition}
@@ -740,41 +842,49 @@ let inSyntaxExtension : syntax_extension_obj -> obj =
 
 let interp_modifiers modl =
   let onlyparsing = ref false in
-  let rec interp assoc level etyps format = function
+  let rec interp assoc level etyps format extra = function
     | [] ->
-	(assoc,level,etyps,!onlyparsing,format)
+	(assoc,level,etyps,!onlyparsing,format,extra)
     | SetEntryType (s,typ) :: l ->
-	let id = id_of_string s in
-	if List.mem_assoc id etyps then
+	let id = Id.of_string s in
+	if Id.List.mem_assoc id etyps then
 	  error (s^" is already assigned to an entry or constr level.");
-	interp assoc level ((id,typ)::etyps) format l
+	interp assoc level ((id,typ)::etyps) format extra l
     | SetItemLevel ([],n) :: l ->
-	interp assoc level etyps format l
+	interp assoc level etyps format extra l
     | SetItemLevel (s::idl,n) :: l ->
-	let id = id_of_string s in
-	if List.mem_assoc id etyps then
+	let id = Id.of_string s in
+	if Id.List.mem_assoc id etyps then
 	  error (s^" is already assigned to an entry or constr level.");
 	let typ = ETConstr (n,()) in
-	interp assoc level ((id,typ)::etyps) format (SetItemLevel (idl,n)::l)
+	interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l)
     | SetLevel n :: l ->
-	if level <> None then error "A level is given more than once.";
-	interp assoc (Some n) etyps format l
+	if not (Option.is_empty level) then error "A level is given more than once.";
+	interp assoc (Some n) etyps format extra l
     | SetAssoc a :: l ->
-	if assoc <> None then error"An associativity is given more than once.";
-	interp (Some a) level etyps format l
+	if not (Option.is_empty assoc) then error"An associativity is given more than once.";
+	interp (Some a) level etyps format extra l
     | SetOnlyParsing _ :: l ->
 	onlyparsing := true;
-	interp assoc level etyps format l
-    | SetFormat s :: l ->
-	if format <> None then error "A format is given more than once.";
-	interp assoc level etyps (Some s) l
-  in interp None None [] None modl
+	interp assoc level etyps format extra l
+    | SetFormat ("text",s) :: l ->
+	if not (Option.is_empty format) then error "A format is given more than once.";
+	interp assoc level etyps (Some s) extra l
+    | SetFormat (k,(_,s)) :: l ->
+	interp assoc level etyps format ((k,s) :: extra) l
+  in interp None None [] None [] modl
 
 let check_infix_modifiers modifiers =
-  let (assoc,level,t,b,fmt) = interp_modifiers modifiers in
-  if t <> [] then
+  let (assoc,level,t,b,fmt,extra) = interp_modifiers modifiers in
+  if not (List.is_empty t) then
     error "Explicit entry level or type unexpected in infix notation."
 
+let check_useless_entry_types recvars mainvars etyps =
+  let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in
+  match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with
+  | (x,_)::_ -> error (Id.to_string x ^ " is unbound in the notation.")
+  | _ -> ()
+
 let no_syntax_modifiers = function
   | [] | [SetOnlyParsing _] -> true
   | _ -> false
@@ -805,7 +915,7 @@ let join_auxiliary_recursive_types recvars etyps =
     | None, None -> typs
     | Some _, None -> typs
     | None, Some ytyp -> (x,ytyp)::typs
-    | Some xtyp, Some ytyp when xtyp = ytyp -> typs
+    | Some xtyp, Some ytyp when Pervasives.(=) xtyp ytyp -> typs (* FIXME *)
     | Some xtyp, Some ytyp ->
 	errorlabstrm ""
 	  (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++
@@ -821,12 +931,12 @@ let internalization_type_of_entry_type = function
   | ETBinderList _ | ETConstrList _ -> assert false
 
 let set_internalization_type typs =
-  List.map (down_snd internalization_type_of_entry_type) typs
+  List.map (fun (_, e) -> internalization_type_of_entry_type e) typs
 
 let make_internalization_vars recvars mainvars typs =
   let maintyps = List.combine mainvars typs in
   let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in
-  maintyps@extratyps
+  maintyps @ extratyps
 
 let make_interpretation_type isrec = function
   | NtnInternTypeConstr when isrec -> NtnTypeConstrList
@@ -835,14 +945,21 @@ let make_interpretation_type isrec = function
   | NtnInternTypeBinder -> error "Type not allowed in recursive notation."
 
 let make_interpretation_vars recvars allvars =
-  List.iter (fun (x,y) ->
-    if fst (List.assoc x allvars) <> fst (List.assoc y allvars) then
-      error_not_same_scope x y) recvars;
+  let eq_subscope (sc1, l1) (sc2, l2) =
+    Option.equal String.equal sc1 sc2 &&
+    List.equal String.equal l1 l2
+  in
+  let check (x, y) =
+    let (scope1, _) = Id.Map.find x allvars in
+    let (scope2, _) = Id.Map.find y allvars in
+    if not (eq_subscope scope1 scope2) then error_not_same_scope x y
+  in
+  let () = List.iter check recvars in
   let useless_recvars = List.map snd recvars in
   let mainvars =
-    List.filter (fun (x,_) -> not (List.mem x useless_recvars)) allvars in
-  List.map (fun (x,(sc,typ)) ->
-    (x,(sc,make_interpretation_type (List.mem_assoc x recvars) typ))) mainvars
+    Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in
+  Id.Map.mapi (fun x (sc, typ) ->
+    (sc, make_interpretation_type (Id.List.mem_assoc x recvars) typ)) mainvars
 
 let check_rule_productivity l =
   if List.for_all (function NonTerminal _ -> true | _ -> false) l then
@@ -850,9 +967,17 @@ let check_rule_productivity l =
   if (match l with SProdList _ :: _ -> true | _ -> false) then
     error "A recursive notation must start with at least one symbol."
 
-let is_not_printable = function
-  | AVar _ -> msg_warn "This notation will not be used for printing as it is bound to a \nsingle variable"; true
-  | _ -> false
+let is_not_printable onlyparse noninjective = function
+| NVar _ ->
+  let () = if not onlyparse then
+    msg_warning (strbrk "This notation will not be used for printing as it is bound to a single variable.")
+  in
+  true
+| _ ->
+  if not onlyparse && noninjective then
+    let () = msg_warning (strbrk "This notation will not be used for printing as it is not reversible.") in
+    true
+  else onlyparse
 
 let find_precedence lev etyps symbols =
   match symbols with
@@ -861,31 +986,32 @@ let find_precedence lev etyps symbols =
 	| ETConstr _ ->
 	    error "The level of the leftmost non-terminal cannot be changed."
 	| ETName | ETBigint | ETReference ->
-	    if lev = None then
-	      ([msgnl,str "Setting notation at level 0."],0)
-	    else
-	    if lev <> Some 0 then
+            begin match lev with
+            | None ->
+	      ([msg_info,strbrk "Setting notation at level 0."],0)
+            | Some 0 ->
+              ([],0)
+            | _ ->
 	      error "A notation starting with an atomic expression must be at level 0."
-	    else
-	      ([],0)
+            end
 	| ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *)
-	    if lev = None then
+	    if Option.is_empty lev then
 	      error "Need an explicit level."
 	    else [],Option.get lev
         | ETConstrList _ | ETBinderList _ ->
 	    assert false (* internally used in grammar only *)
       with Not_found ->
-	if lev = None then
+	if Option.is_empty lev then
 	  error "A left-recursive notation must have an explicit level."
 	else [],Option.get lev)
   | Terminal _ ::l when
-      (match list_last symbols with Terminal _ -> true |_ -> false)
+      (match List.last symbols with Terminal _ -> true |_ -> false)
       ->
-      if lev = None then
-	([msgnl,str "Setting notation at level 0."], 0)
+      if Option.is_empty lev then
+	([msg_info,strbrk "Setting notation at level 0."], 0)
       else [],Option.get lev
   | _ ->
-      if lev = None then error "Cannot determine the level.";
+      if Option.is_empty lev then error "Cannot determine the level.";
       [],Option.get lev
 
 let check_curly_brackets_notation_exists () =
@@ -908,9 +1034,9 @@ let remove_curly_brackets l =
             let br',next' = skip_break [] l' in
             (match next' with
               | Terminal "}" as t2 :: l'' as l1 ->
-                  if l <> l0 or l' <> l1 then
-                    msg_warn "Skipping spaces inside curly brackets";
-                  if deb & l'' = [] then [t1;x;t2] else begin
+                  if not (List.equal Notation.symbol_eq l l0) || not (List.equal Notation.symbol_eq l' l1) then
+                    msg_warning (strbrk "Skipping spaces inside curly brackets");
+                  if deb && List.is_empty l'' then [t1;x;t2] else begin
                     check_curly_brackets_notation_exists ();
                     x :: aux false l''
                   end
@@ -919,14 +1045,15 @@ let remove_curly_brackets l =
   | x :: l -> x :: aux false l
   in aux true l
 
-let compute_syntax_data (df,modifiers) =
-  let (assoc,n,etyps,onlyparse,fmt) = interp_modifiers modifiers in
+let compute_syntax_data df modifiers =
+  let (assoc,n,etyps,onlyparse,fmt,extra) = interp_modifiers modifiers in
   let assoc = match assoc with None -> (* default *) Some NonA | a -> a in
   let toks = split_notation_string df in
   let (recvars,mainvars,symbols) = analyze_notation_tokens toks in
+  let _ = check_useless_entry_types recvars mainvars etyps in
   let ntn_for_interp = make_notation_key symbols in
   let symbols' = remove_curly_brackets symbols in
-  let need_squash = (symbols <> symbols') in
+  let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in
   let ntn_for_grammar = make_notation_key symbols' in
   check_rule_productivity symbols';
   let msgs,n = find_precedence n etyps symbols' in
@@ -947,45 +1074,52 @@ let compute_syntax_data (df,modifiers) =
   let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
   let i_data = (onlyparse,recvars,mainvars,(ntn_for_interp,df')) in
   (* Return relevant data for interpretation and for parsing/printing *)
-  (msgs,i_data,i_typs,sy_fulldata)
+  (msgs,i_data,i_typs,sy_fulldata,extra)
 
-let compute_pure_syntax_data (df,mods) =
-  let (msgs,(onlyparse,_,_,_),_,sy_data) = compute_syntax_data (df,mods) in
+let compute_pure_syntax_data df mods =
+  let (msgs,(onlyparse,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in
   let msgs =
     if onlyparse then
       (msg_warning,
-      str "The only parsing modifier has no effect in Reserved Notation.")::msgs
+      strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs
     else msgs in
-  msgs, sy_data
+  msgs, sy_data, extra
 
 (**********************************************************************)
 (* Registration of notations interpretation                            *)
 
-let load_notation _ (_,(_,scope,pat,onlyparse,_)) =
-  Option.iter Notation.declare_scope scope
-
-let open_notation i (_,(_,scope,pat,onlyparse,(ntn,df))) =
-  if i=1 & not (Notation.exists_notation_in_scope scope ntn pat) then begin
+type notation_obj = {
+  notobj_local : bool;
+  notobj_scope : scope_name option;
+  notobj_interp : interpretation;
+  notobj_onlyparse : bool;
+  notobj_notation : notation * notation_location;
+}
+
+let load_notation _ (_, nobj) =
+  Option.iter Notation.declare_scope nobj.notobj_scope
+
+let open_notation i (_, nobj) =
+  let scope = nobj.notobj_scope in
+  let (ntn, df) = nobj.notobj_notation in
+  let pat = nobj.notobj_interp in
+  if Int.equal i 1 then begin
     (* Declare the interpretation *)
     Notation.declare_notation_interpretation ntn scope pat df;
     (* Declare the uninterpretation *)
-    if not onlyparse then
-      Notation.declare_uninterpretation (NotationRule (scope,ntn)) pat
+    if not nobj.notobj_onlyparse then
+      Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat
   end
 
 let cache_notation o =
   load_notation 1 o;
   open_notation 1 o
 
-let subst_notation (subst,(lc,scope,pat,b,ndf)) =
-  (lc,scope,subst_interpretation subst pat,b,ndf)
-
-let classify_notation (local,_,_,_,_ as o) =
-  if local then Dispose else Substitute o
+let subst_notation (subst, nobj) =
+  { nobj with notobj_interp = subst_interpretation subst nobj.notobj_interp; }
 
-type notation_obj =
-    bool * scope_name option * interpretation * bool *
-      (notation * notation_location)
+let classify_notation nobj =
+  if nobj.notobj_local then Dispose else Substitute nobj
 
 let inNotation : notation_obj -> obj =
   declare_object {(default_object "NOTATION") with
@@ -998,9 +1132,12 @@ let inNotation : notation_obj -> obj =
 (**********************************************************************)
 
 let with_lib_stk_protection f x =
-  let fs = Lib.freeze () in
+  let fs = Lib.freeze `No in
   try let a = f x in Lib.unfreeze fs; a
-  with reraise -> Lib.unfreeze fs; raise reraise
+  with reraise ->
+    let reraise = Errors.push reraise in
+    let () = Lib.unfreeze fs in
+    iraise reraise
 
 let with_syntax_protection f x =
   with_lib_stk_protection
@@ -1011,11 +1148,11 @@ let with_syntax_protection f x =
 (* Recovering existing syntax                                         *)
 
 let contract_notation ntn =
-  if ntn = "{ _ }" then ntn else
+  if String.equal ntn "{ _ }" then ntn else
   let rec aux ntn i =
     if i <= String.length ntn - 5 then
       let ntn' =
-        if String.sub ntn i 5 = "{ _ }" then
+        if String.is_sub "{ _ }" ntn i then
           String.sub ntn 0 i ^ "_" ^
           String.sub ntn (i+5) (String.length ntn -i-5)
         else ntn in
@@ -1029,58 +1166,94 @@ let recover_syntax ntn =
   try
     let prec = Notation.level_of_notation ntn in
     let pp_rule,_ = Notation.find_notation_printing_rule ntn in
-    let typs,pa_rule = Egrammar.recover_notation_grammar ntn prec in
-    (typs,prec,ntn,pa_rule,pp_rule)
+    let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in
+    let pa_rule = Egramcoq.recover_constr_grammar ntn prec in
+    { synext_level = prec;
+      synext_notation = ntn;
+      synext_notgram = pa_rule;
+      synext_unparsing = pp_rule;
+      synext_extra = pp_extra_rules }
   with Not_found ->
     raise NoSyntaxRule
 
-let recover_squash_syntax () = recover_syntax "{ _ }"
+let recover_squash_syntax sy =
+  let sq = recover_syntax "{ _ }" in
+  [sy; sq]
 
 let recover_notation_syntax rawntn =
   let ntn = contract_notation rawntn in
-  let (typs,_,_,_,_ as sy_rule) = recover_syntax ntn in
-  let need_squash = ntn<>rawntn in
-  typs,if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
+  let sy = recover_syntax ntn in
+  let need_squash = not (String.equal ntn rawntn) in
+  let rules = if need_squash then recover_squash_syntax sy else [sy] in
+  sy.synext_notgram.notgram_typs, rules
 
 (**********************************************************************)
 (* Main entry point for building parsing and printing rules           *)
 
-let make_pa_rule (n,typs,symbols,_) ntn =
+let make_pa_rule i_typs (n,typs,symbols,_) ntn =
   let assoc = recompute_assoc typs in
   let prod = make_production typs symbols in
-  (n,assoc,ntn,prod)
+  { notgram_level = n;
+    notgram_assoc = assoc;
+    notgram_notation = ntn;
+    notgram_prods = prod;
+    notgram_typs = i_typs; }
 
 let make_pp_rule (n,typs,symbols,fmt) =
   match fmt with
   | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
-  | Some fmt -> hunks_of_format (n,List.split typs) (symbols,parse_format fmt)
+  | Some fmt -> hunks_of_format (n, List.split typs) (symbols, parse_format fmt)
 
-let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) =
-  let pa_rule = make_pa_rule sy_data ntn in
+let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra =
+  let pa_rule = make_pa_rule i_typs sy_data ntn in
   let pp_rule = make_pp_rule sy_data in
-  let sy_rule = (i_typs,prec,ntn,pa_rule,pp_rule) in
+  let sy = {
+    synext_level = prec;
+    synext_notation = ntn;
+    synext_notgram = pa_rule;
+    synext_unparsing = pp_rule;
+    synext_extra = extra;
+  } in
   (* By construction, the rule for "{ _ }" is declared, but we need to
      redeclare it because the file where it is declared needs not be open
      when the current file opens (especially in presence of -nois) *)
-  if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
+  if need_squash then recover_squash_syntax sy else [sy]
 
 (**********************************************************************)
 (* Main functions about notations                                     *)
 
+let to_map l =
+  let fold accu (x, v) = Id.Map.add x v accu in
+  List.fold_left fold Id.Map.empty l
+
 let add_notation_in_scope local df c mods scope =
-  let (msgs,i_data,i_typs,sy_data) = compute_syntax_data (df,mods) in
+  let (msgs,i_data,i_typs,sy_data,extra) = compute_syntax_data df mods in
   (* Prepare the parsing and printing rules *)
-  let sy_rules = make_syntax_rules sy_data in
+  let sy_rules = make_syntax_rules sy_data extra in
   (* Prepare the interpretation *)
-  let (onlyparse,recvars,mainvars,df') = i_data in
+  let (onlyparse, recvars,mainvars, df') = i_data in
   let i_vars = make_internalization_vars recvars mainvars i_typs in
-  let (acvars,ac) = interp_aconstr i_vars recvars c in
-  let a = (make_interpretation_vars recvars acvars,ac) in
-  let onlyparse = onlyparse or is_not_printable ac in
+  let nenv = {
+    ninterp_var_type = to_map i_vars;
+    ninterp_rec_vars = to_map recvars;
+    ninterp_only_parse = false;
+  } in
+  let (acvars, ac) = interp_notation_constr nenv c in
+  let interp = make_interpretation_vars recvars acvars in
+  let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
+  let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in
+  let notation = {
+    notobj_local = local;
+    notobj_scope = scope;
+    notobj_interp = (List.map_filter map i_vars, ac);
+    (** Order is important here! *)
+    notobj_onlyparse = onlyparse;
+    notobj_notation = df';
+  } in
   (* Ready to change the global state *)
   Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
-  Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules));
-  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
+  Lib.add_anonymous_leaf (inSyntaxExtension (local, sy_rules));
+  Lib.add_anonymous_leaf (inNotation notation);
   df'
 
 let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse =
@@ -1095,17 +1268,31 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env)
   let path = (Lib.library_dp(),Lib.current_dirpath true) in
   let df' = (make_notation_key symbs,(path,df)) in
   let i_vars = make_internalization_vars recvars mainvars i_typs in
-  let (acvars,ac) = interp_aconstr ~impls i_vars recvars c in
-  let a = (make_interpretation_vars recvars acvars,ac) in
-  let onlyparse = onlyparse or is_not_printable ac in
-  Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
+  let nenv = {
+    ninterp_var_type = to_map i_vars;
+    ninterp_rec_vars = to_map recvars;
+    ninterp_only_parse = false;
+  } in
+  let (acvars, ac) = interp_notation_constr ~impls nenv c in
+  let interp = make_interpretation_vars recvars acvars in
+  let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in
+  let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in
+  let notation = {
+    notobj_local = local;
+    notobj_scope = scope;
+    notobj_interp = (List.map_filter map i_vars, ac);
+    (** Order is important here! *)
+    notobj_onlyparse = onlyparse;
+    notobj_notation = df';
+  } in
+  Lib.add_anonymous_leaf (inNotation notation);
   df'
 
 (* Notations without interpretation (Reserved Notation) *)
 
 let add_syntax_extension local ((loc,df),mods) =
-  let msgs,sy_data = compute_pure_syntax_data (df,mods) in
-  let sy_rules = make_syntax_rules sy_data in
+  let msgs, sy_data, extra = compute_pure_syntax_data df mods in
+  let sy_rules = make_syntax_rules sy_data extra in
   Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
   Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
 
@@ -1139,9 +1326,16 @@ let add_notation local c ((loc,df),modifiers) sc =
   in
   Dumpglob.dump_notation (loc,df') sc true
 
+let add_notation_extra_printing_rule df k v =
+  let notk = 
+    let dfs = split_notation_string df in
+    let _,_, symbs = analyze_notation_tokens dfs in
+    make_notation_key symbs in
+  Notation.add_notation_extra_printing_rule notk k v
+
 (* Infix notations *)
 
-let inject_var x = CRef (Ident (dummy_loc, id_of_string x))
+let inject_var x = CRef (Ident (Loc.ghost, Id.of_string x),None)
 
 let add_infix local ((loc,inf),modifiers) pr sc =
   check_infix_modifiers modifiers;
@@ -1154,16 +1348,16 @@ let add_infix local ((loc,inf),modifiers) pr sc =
 (**********************************************************************)
 (* Delimiters and classes bound to scopes                             *)
 
-type scope_command = ScopeDelim of string | ScopeClasses of Classops.cl_typ
+type scope_command = ScopeDelim of string | ScopeClasses of scope_class list
 
 let load_scope_command _ (_,(scope,dlm)) =
   Notation.declare_scope scope
 
 let open_scope_command i (_,(scope,o)) =
-  if i=1 then
+  if Int.equal i 1 then
     match o with
     | ScopeDelim dlm -> Notation.declare_delimiters scope dlm
-    | ScopeClasses cl -> Notation.declare_class_scope scope cl
+    | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl
 
 let cache_scope_command o =
   load_scope_command 1 o;
@@ -1171,7 +1365,10 @@ let cache_scope_command o =
 
 let subst_scope_command (subst,(scope,o as x)) = match o with
   | ScopeClasses cl ->
-      let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else
+      let cl' = List.map_filter (subst_scope_class subst) cl in
+      let cl' =
+        if List.for_all2eq (==) cl cl' then cl
+        else cl' in
       scope, ScopeClasses cl'
   | _ -> x
 
@@ -1192,19 +1389,28 @@ let add_class_scope scope cl =
 (* Check if abbreviation to a name and avoid early insertion of
    maximal implicit arguments *)
 let try_interp_name_alias = function
-  | [], CRef ref -> intern_reference ref
+  | [], CRef (ref,_) -> intern_reference ref
   | _ -> raise Not_found
 
 let add_syntactic_definition ident (vars,c) local onlyparse =
+  let nonprintable = ref false in
   let vars,pat =
-    try [], ARef (try_interp_name_alias (vars,c))
+    try [], NRef (try_interp_name_alias (vars,c))
     with Not_found ->
-      let i_vars = List.map (fun id -> (id,NtnInternTypeConstr)) vars in
-      let vars,pat = interp_aconstr i_vars [] c in
-      List.map (fun (id,(sc,kind)) -> (id,sc)) vars, pat
+      let fold accu id = Id.Map.add id NtnInternTypeConstr accu in
+      let i_vars = List.fold_left fold Id.Map.empty vars in
+      let nenv = {
+        ninterp_var_type = i_vars;
+        ninterp_rec_vars = Id.Map.empty;
+        ninterp_only_parse = false;
+      } in
+      let nvars, pat = interp_notation_constr nenv c in
+      let () = nonprintable := nenv.ninterp_only_parse in
+      let map id = let (sc, _) = Id.Map.find id nvars in (id, sc) in
+      List.map map vars, pat
   in
   let onlyparse = match onlyparse with
-    | None when (is_not_printable pat) -> Some Flags.Current
+    | None when (is_not_printable false !nonprintable pat) -> Some Flags.Current
     | p -> p
   in
   Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index f3bdf833..38a37757 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -1,27 +1,30 @@
 (************************************************************************)
 (*  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 Util
 open Names
-open Libnames
-open Ppextend
-open Extend
 open Tacexpr
 open Vernacexpr
 open Notation
-open Topconstr
+open Constrexpr
+open Notation_term
 
 val add_token_obj : string -> unit
 
 (** Adding a tactic notation in the environment *)
 
 val add_tactic_notation :
-  int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit
+  locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr ->
+    unit
+
+type atomic_entry = string * Genarg.glob_generic_argument list option
+
+val add_ml_tactic_notation : ml_tactic_name ->
+  Egramml.grammar_prod_item list list -> atomic_entry list -> unit
 
 (** Adding a (constr) notation in the environment*)
 
@@ -31,10 +34,12 @@ val add_infix : locality_flag -> (lstring * syntax_modifier list) ->
 val add_notation : locality_flag -> constr_expr ->
   (lstring * syntax_modifier list) -> scope_name option -> unit
 
+val add_notation_extra_printing_rule : string -> string -> string -> unit
+
 (** Declaring delimiter keys and default scopes *)
 
 val add_delimiters : scope_name -> string -> unit
-val add_class_scope : scope_name -> Classops.cl_typ -> unit
+val add_class_scope : scope_name -> scope_class list -> unit
 
 (** Add only the interpretation of a notation that already has pa/pp rules *)
 
@@ -53,12 +58,12 @@ val add_syntax_extension :
 
 (** Add a syntactic definition (as in "Notation f := ...") *)
 
-val add_syntactic_definition : identifier -> identifier list * constr_expr ->
+val add_syntactic_definition : Id.t -> Id.t list * constr_expr ->
   bool -> Flags.compat_version option -> unit
 
 (** Print the Camlp4 state of a grammar *)
 
-val print_grammar : string -> unit
+val pr_grammar : string -> Pp.std_ppcmds
 
 val check_infix_modifiers : syntax_modifier list -> unit
 
diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml
new file mode 100644
index 00000000..9dc1dd5b
--- /dev/null
+++ b/toplevel/mltop.ml
@@ -0,0 +1,439 @@
+(************************************************************************)
+(*  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 Errors
+open Util
+open Pp
+open Flags
+open Libobject
+open System
+
+(* Code to hook Coq into the ML toplevel -- depends on having the
+   objective-caml compiler mostly visible. The functions implemented here are:
+   \begin{itemize}
+   \item [dir_ml_load name]: Loads the ML module fname from the current ML
+     path.
+   \item [dir_ml_use]: Directive #use of Ocaml toplevel
+   \item [add_ml_dir]: Directive #directory of Ocaml toplevel
+   \end{itemize}
+
+   How to build an ML module interface with these functions.
+   The idea is that the ML directory path is like the Coq directory
+   path.  So we can maintain the two in parallel.
+   In the same way, we can use the "ml_env" as a kind of ML
+   environment, which we freeze, unfreeze, and add things to just like
+   to the other environments.
+   Finally, we can create an object which is an ML module, and require
+   that the "caching" of the ML module cause the loading of the
+   associated ML file, if that file has not been yet loaded.  Of
+   course, the problem is how to record dependencies between ML
+   modules.
+   (I do not know of a solution to this problem, other than to
+   put all the needed names into the ML Module object.) *)
+
+
+(* NB: this module relies on OCaml's Dynlink library. The bytecode version
+   of Dynlink is always available, but there are some architectures
+   with native compilation and no dynlink.cmxa. Instead of nasty IFDEF's
+   here for hiding the calls to Dynlink, we now simply reject this rather
+   rare situation during ./configure, and give instructions there about how
+   to build a dummy dynlink.cmxa, cf. dev/dynlink.ml. *)
+
+(* This path is where we look for .cmo *)
+let coq_mlpath_copy = ref ["."]
+let keep_copy_mlpath path =
+  let cpath = CUnix.canonical_path_name path in
+  let filter path' = not (String.equal cpath (CUnix.canonical_path_name path'))
+  in
+  coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy
+
+(* If there is a toplevel under Coq *)
+type toplevel = {
+  load_obj : string -> unit;
+  use_file : string -> unit;
+  add_dir  : string -> unit;
+  ml_loop  : unit -> unit }
+
+(* Determines the behaviour of Coq with respect to ML files (compiled
+   or not) *)
+type kind_load =
+  | WithTop of toplevel
+  | WithoutTop
+
+(* Must be always initialized *)
+let load = ref WithoutTop
+
+(* Are we in a native version of Coq? *)
+let is_native = Dynlink.is_native
+
+(* Sets and initializes a toplevel (if any) *)
+let set_top toplevel = load :=
+  WithTop toplevel;
+  Nativelib.load_obj := toplevel.load_obj
+
+(* Removes the toplevel (if any) *)
+let remove () =
+  load := WithoutTop;
+  Nativelib.load_obj := (fun x -> () : string -> unit)
+
+(* Tests if an Ocaml toplevel runs under Coq *)
+let is_ocaml_top () =
+  match !load with
+    | WithTop _ -> true
+    |_ -> false
+
+(* Tests if we can load ML files *)
+let has_dynlink = Coq_config.has_natdynlink || not is_native
+
+(* Runs the toplevel loop of Ocaml *)
+let ocaml_toploop () =
+  match !load with
+    | WithTop t -> Printexc.catch t.ml_loop ()
+    | _ -> ()
+
+(* Try to interpret load_obj's (internal) errors *)
+let report_on_load_obj_error exc =
+  let x = Obj.repr exc in
+  (* Try an horrible (fragile) hack to report on Symtable dynlink errors *)
+  (* (we follow ocaml's Printexc.to_string decoding of exceptions) *)
+  if Obj.is_block x && String.equal (Obj.magic (Obj.field (Obj.field x 0) 0)) "Symtable.Error"
+  then
+    let err_block = Obj.field x 1 in
+    if Int.equal (Obj.tag err_block) 0 then
+      (* Symtable.Undefined_global of string *)
+      str "reference to undefined global " ++
+      str (Obj.magic (Obj.field err_block 0))
+    else str (Printexc.to_string exc)
+  else str (Printexc.to_string exc)
+
+(* Dynamic loading of .cmo/.cma *)
+
+let ml_load s =
+  match !load with
+    | WithTop t ->
+      (try t.load_obj s; s
+       with
+       | e when Errors.noncritical e ->
+        let e = Errors.push e in
+        match fst e with
+        | (UserError _ | Failure _ | Not_found as u) -> Exninfo.iraise (u, snd e)
+        | exc ->
+            let msg = report_on_load_obj_error exc in
+            errorlabstrm "Mltop.load_object" (str"Cannot link ml-object " ++
+                  str s ++ str" to Coq code (" ++ msg ++ str ")."))
+    | WithoutTop ->
+        try
+          Dynlink.loadfile s; s
+	with Dynlink.Error a ->
+          errorlabstrm "Mltop.load_object"
+            (strbrk "while loading " ++ str s ++
+             strbrk ": " ++ str (Dynlink.error_message a))
+
+let dir_ml_load s =
+  match !load with
+    | WithTop _ -> ml_load s
+    | WithoutTop ->
+        let warn = Flags.is_verbose() in
+        let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in
+        ml_load gname
+
+(* Dynamic interpretation of .ml *)
+let dir_ml_use s =
+  match !load with
+    | WithTop t -> t.use_file s
+    | _ -> msg_warning (str "Cannot access the ML compiler")
+
+(* Adds a path to the ML paths *)
+let add_ml_dir s =
+  match !load with
+    | WithTop t -> t.add_dir s; keep_copy_mlpath s
+    | WithoutTop when has_dynlink -> keep_copy_mlpath s
+    | _ -> ()
+
+(* For Rec Add ML Path *)
+let add_rec_ml_dir unix_path =
+  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
+
+(* Adding files to Coq and ML loadpath *)
+
+let add_path ~unix_path:dir ~coq_root:coq_dirpath ~implicit =
+  if exists_dir dir then
+    begin
+      add_ml_dir dir;
+      Loadpath.add_load_path dir
+        (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath)
+        coq_dirpath
+    end
+  else
+    msg_warning (str ("Cannot open " ^ dir))
+
+let convert_string d =
+  try Names.Id.of_string d
+  with UserError _ ->
+    msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)"));
+    raise Exit
+
+let add_rec_path ~unix_path ~coq_root ~implicit =
+  if exists_dir unix_path then
+    let dirs = all_subdirs ~unix_path in
+    let prefix = Names.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
+    let () = add_ml_dir unix_path in
+    let add (path, dir) =
+      Loadpath.add_load_path path Loadpath.ImplicitPath dir in
+    let () = if implicit then List.iter add dirs in
+    Loadpath.add_load_path unix_path
+      (if implicit then Loadpath.ImplicitRootPath else Loadpath.RootPath)
+      coq_root
+  else
+    msg_warning (str ("Cannot open " ^ unix_path))
+
+(* convertit un nom quelconque en nom de fichier ou de module *)
+let mod_of_name name =
+    if Filename.check_suffix name ".cmo" then
+      Filename.chop_suffix name ".cmo"
+    else
+      name
+
+let get_ml_object_suffix name =
+  if Filename.check_suffix name ".cmo" then
+    Some ".cmo"
+  else if Filename.check_suffix name ".cma" then
+    Some ".cma"
+  else if Filename.check_suffix name ".cmxs" then
+    Some ".cmxs"
+  else
+    None
+
+let file_of_name name =
+  let suffix = get_ml_object_suffix name in
+  let fail s =
+    errorlabstrm "Mltop.load_object"
+      (str"File not found on loadpath : " ++ str s ++ str"\n" ++
+       str"Loadpath: " ++ str(String.concat ":" !coq_mlpath_copy)) in
+  if not (Filename.is_relative name) then
+    if Sys.file_exists name then name else fail name
+  else if is_native then
+    let name = match suffix with
+      | Some ((".cmo"|".cma") as suffix) ->
+          (Filename.chop_suffix name suffix) ^ ".cmxs"
+      | Some ".cmxs" -> name
+      | _ -> name ^ ".cmxs"
+    in
+    if is_in_path !coq_mlpath_copy name then name else fail name
+  else
+    let (full, base) = match suffix with
+      | Some ".cmo" | Some ".cma" -> true, name
+      | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs"
+      | _ -> false, name
+    in
+    if full then
+      if is_in_path !coq_mlpath_copy base then base else fail base
+    else
+      let name = base ^ ".cma" in
+      if is_in_path !coq_mlpath_copy name then name else
+        let name = base ^ ".cmo" in
+        if is_in_path !coq_mlpath_copy name then name else
+          fail (base ^ ".cm[ao]")
+
+(** Is the ML code of the standard library placed into loadable plugins
+    or statically compiled into coqtop ? For the moment this choice is
+    made according to the presence of native dynlink : even if bytecode
+    coqtop could always load plugins, we prefer to have uniformity between
+    bytecode and native versions. *)
+
+(* [known_loaded_module] contains the names of the loaded ML modules
+ * (linked or loaded with load_object). It is used not to load a
+ * module twice. It is NOT the list of ML modules Coq knows. *)
+
+let known_loaded_modules = ref String.Map.empty
+
+let add_known_module mname path =
+  if not (String.Map.mem mname !known_loaded_modules) ||
+     String.Map.find mname !known_loaded_modules = None then
+    known_loaded_modules := String.Map.add mname path !known_loaded_modules
+
+let module_is_known mname =
+  String.Map.mem mname !known_loaded_modules
+
+let known_module_path mname =
+  String.Map.find mname !known_loaded_modules
+
+(** A plugin is just an ML module with an initialization function. *)
+
+let known_loaded_plugins = ref String.Map.empty
+
+let add_known_plugin init name =
+  add_known_module name None;
+  known_loaded_plugins := String.Map.add name init !known_loaded_plugins
+
+let init_known_plugins () =
+  String.Map.iter (fun _ f -> f()) !known_loaded_plugins
+
+(** Registering functions to be used at caching time, that is when the Declare
+    ML module command is issued. *)
+
+let cache_objs = ref String.Map.empty
+
+let declare_cache_obj f name =
+  let objs = try String.Map.find name !cache_objs with Not_found -> [] in
+  let objs = f :: objs in
+  cache_objs := String.Map.add name objs !cache_objs
+
+let perform_cache_obj name =
+  let objs = try String.Map.find name !cache_objs with Not_found -> [] in
+  let objs = List.rev objs in
+  List.iter (fun f -> f ()) objs
+
+(** ml object = ml module or plugin *)
+
+let init_ml_object mname =
+  try String.Map.find mname !known_loaded_plugins ()
+  with Not_found -> ()
+
+let load_ml_object mname ?path fname=
+  let path = match path with
+    | None -> dir_ml_load fname
+    | Some p -> ml_load p in
+  add_known_module mname (Some path);
+  init_ml_object mname;
+  path
+
+let dir_ml_load m = ignore(dir_ml_load m)
+let add_known_module m = add_known_module m None
+let load_ml_object_raw fname = dir_ml_load (file_of_name fname)
+let load_ml_objects_raw_rex rex =
+  List.iter (fun (_,fp) ->
+    let name = file_of_name (Filename.basename fp) in
+    try dir_ml_load name
+    with e -> prerr_endline (Printexc.to_string e))
+    (System.where_in_path_rex !coq_mlpath_copy rex)
+
+(* Summary of declared ML Modules *)
+
+(* List and not String.Set because order is important: most recent first. *)
+
+let loaded_modules = ref []
+let get_loaded_modules () = List.rev !loaded_modules
+let add_loaded_module md path =
+  if not (List.mem_assoc md !loaded_modules) then
+    loaded_modules := (md,path) :: !loaded_modules
+let reset_loaded_modules () = loaded_modules := []
+
+let if_verbose_load verb f name ?path fname =
+  if not verb then f name ?path fname
+  else
+    let info = "[Loading ML file "^fname^" ..." in
+    try
+      let path = f name ?path fname in
+      msg_info (str (info^" done]"));
+      path
+    with reraise ->
+      msg_info (str (info^" failed]"));
+      raise reraise
+
+(** Load a module for the first time (i.e. dynlink it)
+    or simulate its reload (i.e. doing nothing except maybe
+    an initialization function). *)
+
+let trigger_ml_object verb cache reinit ?path name =
+  if module_is_known name then begin
+    if reinit then init_ml_object name;
+    add_loaded_module name (known_module_path name);
+    if cache then perform_cache_obj name
+  end else if not has_dynlink then
+    error ("Dynamic link not supported (module "^name^")")
+  else begin
+    let file = file_of_name (Option.default name path) in
+    let path =
+      if_verbose_load (verb && is_verbose ()) load_ml_object name ?path file in
+    add_loaded_module name (Some path);
+    if cache then perform_cache_obj name
+  end
+
+let load_ml_object n m = ignore(load_ml_object n m)
+
+let unfreeze_ml_modules x =
+  reset_loaded_modules ();
+  List.iter
+    (fun (name,path) -> trigger_ml_object false false false ?path name) x
+
+let _ =
+  Summary.declare_summary Summary.ml_modules
+    { Summary.freeze_function = (fun _ -> get_loaded_modules ());
+      Summary.unfreeze_function = unfreeze_ml_modules;
+      Summary.init_function = reset_loaded_modules }
+
+(* Liboject entries of declared ML Modules *)
+
+type ml_module_object = {
+  mlocal : Vernacexpr.locality_flag;
+  mnames : string list
+}
+
+let cache_ml_objects (_,{mnames=mnames}) =
+  let iter obj = trigger_ml_object true true true obj in
+  List.iter iter mnames
+
+let load_ml_objects _ (_,{mnames=mnames}) =
+  let iter obj = trigger_ml_object true false true obj in
+  List.iter iter mnames
+
+let classify_ml_objects ({mlocal=mlocal} as o) =
+  if mlocal then Dispose else Substitute o
+
+let inMLModule : ml_module_object -> obj =
+  declare_object
+    {(default_object "ML-MODULE") with
+      cache_function = cache_ml_objects;
+      load_function = load_ml_objects;
+      subst_function = (fun (_,o) -> o);
+      classify_function = classify_ml_objects }
+
+let declare_ml_modules local l =
+  let l = List.map mod_of_name l in
+  Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l})
+
+let print_ml_path () =
+  let l = !coq_mlpath_copy in
+  str"ML Load Path:" ++ fnl () ++ str"  " ++
+          hv 0 (prlist_with_sep fnl str l)
+
+(* Printing of loaded ML modules *)
+
+let print_ml_modules () =
+  let l = get_loaded_modules () in
+  str"Loaded ML Modules: " ++ pr_vertical_list str (List.map fst l)
+
+let print_gc () =
+  let stat = Gc.stat () in
+  let msg =
+    str "minor words: " ++ real stat.Gc.minor_words ++ fnl () ++
+    str "promoted words: " ++ real stat.Gc.promoted_words ++ fnl () ++
+    str "major words: " ++ real stat.Gc.major_words ++ fnl () ++
+    str "minor_collections: " ++ int stat.Gc.minor_collections ++ fnl () ++
+    str "major_collections: " ++ int stat.Gc.major_collections ++ fnl () ++
+    str "heap_words: " ++ int stat.Gc.heap_words ++ fnl () ++
+    str "heap_chunks: " ++ int stat.Gc.heap_chunks ++ fnl () ++
+    str "live_words: " ++ int stat.Gc.live_words ++ fnl () ++
+    str "live_blocks: " ++ int stat.Gc.live_blocks ++ fnl () ++
+    str "free_words: " ++ int stat.Gc.free_words ++ fnl () ++
+    str "free_blocks: " ++ int stat.Gc.free_blocks ++ fnl () ++
+    str "largest_free: " ++ int stat.Gc.largest_free ++ fnl () ++
+    str "fragments: " ++ int stat.Gc.fragments ++ fnl () ++
+    str "compactions: " ++ int stat.Gc.compactions ++ fnl () ++
+    str "top_heap_words: " ++ int stat.Gc.top_heap_words ++ fnl () ++
+    str "stack_size: " ++ int stat.Gc.stack_size
+  in
+  hv 0 msg
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
deleted file mode 100644
index bf7b995a..00000000
--- a/toplevel/mltop.ml4
+++ /dev/null
@@ -1,337 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Util
-open Pp
-open Flags
-open System
-open Libobject
-open Library
-open System
-open Vernacinterp
-
-(* Code to hook Coq into the ML toplevel -- depends on having the
-   objective-caml compiler mostly visible. The functions implemented here are:
-   \begin{itemize}
-   \item [dir_ml_load name]: Loads the ML module fname from the current ML
-     path.
-   \item [dir_ml_use]: Directive #use of Ocaml toplevel
-   \item [add_ml_dir]: Directive #directory of Ocaml toplevel
-   \end{itemize}
-
-   How to build an ML module interface with these functions.
-   The idea is that the ML directory path is like the Coq directory
-   path.  So we can maintain the two in parallel.
-   In the same way, we can use the "ml_env" as a kind of ML
-   environment, which we freeze, unfreeze, and add things to just like
-   to the other environments.
-   Finally, we can create an object which is an ML module, and require
-   that the "caching" of the ML module cause the loading of the
-   associated ML file, if that file has not been yet loaded.  Of
-   course, the problem is how to record dependencies between ML
-   modules.
-   (I do not know of a solution to this problem, other than to
-   put all the needed names into the ML Module object.) *)
-
-(* This path is where we look for .cmo *)
-let coq_mlpath_copy = ref ["."]
-let keep_copy_mlpath path =
-  let cpath = canonical_path_name path in
-  let filter path' = (cpath <> canonical_path_name path') in
-  coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy
-
-(* If there is a toplevel under Coq *)
-type toplevel = {
-  load_obj : string -> unit;
-  use_file : string -> unit;
-  add_dir  : string -> unit;
-  ml_loop  : unit -> unit }
-
-(* Determines the behaviour of Coq with respect to ML files (compiled
-   or not) *)
-type kind_load =
-  | WithTop of toplevel
-  | WithoutTop
-
-(* Must be always initialized *)
-let load = ref WithoutTop
-
-(* Are we in a native version of Coq? *)
-let is_native = IFDEF Byte THEN false ELSE true END
-
-(* Sets and initializes a toplevel (if any) *)
-let set_top toplevel = load := WithTop toplevel
-
-(* Removes the toplevel (if any) *)
-let remove ()= load := WithoutTop
-
-(* Tests if an Ocaml toplevel runs under Coq *)
-let is_ocaml_top () =
-  match !load with
-    | WithTop _ -> true
-    |_ -> false
-
-(* Tests if we can load ML files *)
-let has_dynlink = IFDEF HasDynlink THEN true ELSE false END
-
-(* Runs the toplevel loop of Ocaml *)
-let ocaml_toploop () =
-  match !load with
-    | WithTop t -> Printexc.catch t.ml_loop ()
-    | _ -> ()
-
-(* Dynamic loading of .cmo/.cma *)
-let dir_ml_load s =
-  match !load with
-    | WithTop t ->
-      (try t.load_obj s
-       with
-       | (UserError _ | Failure _ | Anomaly _ | Not_found as u) -> raise u
-       | e when Errors.noncritical e ->
-         errorlabstrm "Mltop.load_object"
-           (str"Cannot link ml-object " ++ str s ++ str" to Coq code."))
-(* TO DO: .cma loading without toplevel *)
-    | WithoutTop ->
-      IFDEF HasDynlink THEN
-	(* WARNING
-	 * if this code section starts to use a module not used elsewhere
-	 * in this file, the Makefile dependency logic needs to be updated.
-	 *)
-        let warn = Flags.is_verbose() in
-        let _,gname = find_file_in_path ~warn !coq_mlpath_copy s in
-        try
-          Dynlink.loadfile gname;
-	with | Dynlink.Error a ->
-          errorlabstrm "Mltop.load_object" (str (Dynlink.error_message a))
-      ELSE
-        errorlabstrm "Mltop.no_load_object"
-            (str"Loading of ML object file forbidden in a native Coq.")
-      END
-
-(* Dynamic interpretation of .ml *)
-let dir_ml_use s =
-  match !load with
-    | WithTop t -> t.use_file s
-    | _ -> msg_warn "Cannot access the ML compiler"
-
-(* Adds a path to the ML paths *)
-let add_ml_dir s =
-  match !load with
-    | WithTop t -> t.add_dir s; keep_copy_mlpath s
-    | WithoutTop when has_dynlink -> keep_copy_mlpath s
-    | _ -> ()
-
-(* For Rec Add ML Path *)
-let add_rec_ml_dir unix_path =
-  List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs ~unix_path)
-
-(* Adding files to Coq and ML loadpath *)
-
-let add_path ~unix_path:dir ~coq_root:coq_dirpath =
-  if exists_dir dir then
-    begin
-      add_ml_dir dir;
-      Library.add_load_path true (dir,coq_dirpath)
-    end
-  else
-    msg_warning (str ("Cannot open " ^ dir))
-
-let convert_string d =
-  try Names.id_of_string d
-  with e when Errors.noncritical e ->
-    if_warn msg_warning
-      (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)"));
-    flush_all ();
-    failwith "caught"
-
-let add_rec_path ~unix_path ~coq_root =
-  if exists_dir unix_path then
-    let dirs = all_subdirs ~unix_path in
-    let prefix = Names.repr_dirpath coq_root in
-    let convert_dirs (lp,cp) =
-      (lp,Names.make_dirpath (List.map convert_string (List.rev cp)@prefix)) in
-    let dirs = map_succeed convert_dirs dirs in
-    List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs;
-    add_ml_dir unix_path;
-    List.iter (Library.add_load_path false) dirs;
-    Library.add_load_path true (unix_path, coq_root)
-  else
-    msg_warning (str ("Cannot open " ^ unix_path))
-
-(* convertit un nom quelconque en nom de fichier ou de module *)
-let mod_of_name name =
-  let base =
-    if Filename.check_suffix name ".cmo" then
-      Filename.chop_suffix name ".cmo"
-    else
-      name
-  in
-  String.capitalize base
-
-let get_ml_object_suffix name =
-  if Filename.check_suffix name ".cmo" then
-    Some ".cmo"
-  else if Filename.check_suffix name ".cma" then
-    Some ".cma"
-  else if Filename.check_suffix name ".cmxs" then
-    Some ".cmxs"
-  else
-    None
-
-let file_of_name name =
-  let name = String.uncapitalize name in
-  let suffix = get_ml_object_suffix name in
-  let fail s =
-    errorlabstrm "Mltop.load_object"
-      (str"File not found on loadpath : " ++ str s) in
-  if is_native then
-    let name = match suffix with
-      | Some ((".cmo"|".cma") as suffix) ->
-          (Filename.chop_suffix name suffix) ^ ".cmxs"
-      | Some ".cmxs" -> name
-      | _ -> name ^ ".cmxs"
-    in
-    if is_in_path !coq_mlpath_copy name then name else fail name
-  else
-    let (full, base) = match suffix with
-      | Some ".cmo" | Some ".cma" -> true, name
-      | Some ".cmxs" -> false, Filename.chop_suffix name ".cmxs"
-      | _ -> false, name
-    in
-    if full then
-      if is_in_path !coq_mlpath_copy base then base else fail base
-    else
-      let name = base ^ ".cmo" in
-      if is_in_path !coq_mlpath_copy name then name else
-        let name = base ^ ".cma" in
-        if is_in_path !coq_mlpath_copy name then name else
-          fail (base ^ ".cm[oa]")
-
-(** Is the ML code of the standard library placed into loadable plugins
-    or statically compiled into coqtop ? For the moment this choice is
-    made according to the presence of native dynlink : even if bytecode
-    coqtop could always load plugins, we prefer to have uniformity between
-    bytecode and native versions. *)
-
-(* [known_loaded_module] contains the names of the loaded ML modules
- * (linked or loaded with load_object). It is used not to load a
- * module twice. It is NOT the list of ML modules Coq knows. *)
-
-let known_loaded_modules = ref Stringset.empty
-
-let add_known_module mname =
-  let mname = String.capitalize mname in
-  known_loaded_modules := Stringset.add mname !known_loaded_modules
-
-let module_is_known mname =
-  Stringset.mem (String.capitalize mname) !known_loaded_modules
-
-(** A plugin is just an ML module with an initialization function. *)
-
-let known_loaded_plugins = ref Stringmap.empty
-
-let add_known_plugin init name =
-  let name = String.capitalize name in
-  add_known_module name;
-  known_loaded_plugins := Stringmap.add name init !known_loaded_plugins
-
-let init_known_plugins () =
-  Stringmap.iter (fun _ f -> f()) !known_loaded_plugins
-
-(** ml object = ml module or plugin *)
-
-let init_ml_object mname =
-  try Stringmap.find mname !known_loaded_plugins ()
-  with Not_found -> ()
-
-let load_ml_object mname fname=
-  dir_ml_load fname;
-  add_known_module mname;
-  init_ml_object mname
-
-(* Summary of declared ML Modules *)
-
-(* List and not Stringset because order is important: most recent first. *)
-
-let loaded_modules = ref []
-let get_loaded_modules () = List.rev !loaded_modules
-let add_loaded_module md = loaded_modules := md :: !loaded_modules
-let reset_loaded_modules () = loaded_modules := []
-
-let if_verbose_load verb f name fname =
-  if not verb then f name fname
-  else
-    let info = "[Loading ML file "^fname^" ..." in
-    try
-      f name fname;
-      msgnl (str (info^" done]"));
-    with reraise ->
-      msgnl (str (info^" failed]"));
-      raise reraise
-
-(** Load a module for the first time (i.e. dynlink it)
-    or simulate its reload (i.e. doing nothing except maybe
-    an initialization function). *)
-
-let cache_ml_object verb reinit name =
-  begin
-    if module_is_known name then
-      (if reinit then init_ml_object name)
-    else if not has_dynlink then
-      error ("Dynamic link not supported (module "^name^")")
-    else
-      if_verbose_load (verb && is_verbose ())
-	load_ml_object name (file_of_name name)
-  end;
-  add_loaded_module name
-
-let unfreeze_ml_modules x =
-  reset_loaded_modules ();
-  List.iter (cache_ml_object false false) x
-
-let _ =
-  Summary.declare_summary "ML-MODULES"
-    { Summary.freeze_function = get_loaded_modules;
-      Summary.unfreeze_function = unfreeze_ml_modules;
-      Summary.init_function = reset_loaded_modules }
-
-(* Liboject entries of declared ML Modules *)
-
-type ml_module_object = {
-  mlocal : Vernacexpr.locality_flag;
-  mnames : string list
-}
-
-let cache_ml_objects (_,{mnames=mnames}) =
-  List.iter (cache_ml_object true true) mnames
-
-let classify_ml_objects ({mlocal=mlocal} as o) =
-  if mlocal then Dispose else Substitute o
-
-let inMLModule : ml_module_object -> obj =
-  declare_object
-    {(default_object "ML-MODULE") with
-      load_function = (fun _ -> cache_ml_objects);
-      cache_function = cache_ml_objects;
-      subst_function = (fun (_,o) -> o);
-      classify_function = classify_ml_objects }
-
-let declare_ml_modules local l =
-  let l = List.map mod_of_name l in
-  Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l})
-
-let print_ml_path () =
-  let l = !coq_mlpath_copy in
-  ppnl (str"ML Load Path:" ++ fnl () ++ str"  " ++
-          hv 0 (prlist_with_sep pr_fnl pr_str l))
-
-(* Printing of loaded ML modules *)
-
-let print_ml_modules () =
-  let l = get_loaded_modules () in
-  pp (str"Loaded ML Modules: " ++ pr_vertical_list pr_str l)
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index 4a6e1e0b..2a91afd8 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -1,11 +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        *)
 (************************************************************************)
 
+(** {5 Toplevel management} *)
+
 (** If there is a toplevel under Coq, it is described by the following
    record. *)
 type toplevel = {
@@ -26,12 +28,14 @@ val remove : unit -> unit
 (** Tests if an Ocaml toplevel runs under Coq *)
 val is_ocaml_top : unit -> bool
 
-(** Tests if we can load ML files *)
-val has_dynlink : bool
-
 (** Starts the Ocaml toplevel loop *)
 val ocaml_toploop : unit -> unit
 
+(** {5 ML Dynlink} *)
+
+(** Tests if we can load ML files *)
+val has_dynlink : bool
+
 (** Dynamic loading of .cmo *)
 val dir_ml_load : string -> unit
 
@@ -43,13 +47,17 @@ val add_ml_dir : string -> unit
 val add_rec_ml_dir : string -> unit
 
 (** Adds a path to the Coq and ML paths *)
-val add_path : unix_path:string -> coq_root:Names.dir_path -> unit
-val add_rec_path : unix_path:string -> coq_root:Names.dir_path -> unit
+val add_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
+val add_rec_path : unix_path:string -> coq_root:Names.DirPath.t -> implicit:bool -> unit
 
 (** List of modules linked to the toplevel *)
 val add_known_module : string -> unit
 val module_is_known : string -> bool
 val load_ml_object : string -> string -> unit
+val load_ml_object_raw : string -> unit
+val load_ml_objects_raw_rex : Str.regexp -> unit
+
+(** {5 Initialization functions} *)
 
 (** Declare a plugin and its initialization function.
     A plugin is just an ML module with an initialization function.
@@ -61,8 +69,19 @@ val add_known_plugin : (unit -> unit) -> string -> unit
 (** Calls all initialization functions in a non-specified order *)
 val init_known_plugins : unit -> unit
 
+(** Register a callback that will be called when the module is declared with
+    the Declare ML Module command. This is useful to define Coq objects at that
+    time only. Several functions can be defined for one module; they will be
+    called in the order of declaration, and after the ML module has been
+    properly initialized. *)
+val declare_cache_obj : (unit -> unit) -> string -> unit
+
+(** {5 Declaring modules} *)
+
 val declare_ml_modules : Vernacexpr.locality_flag -> string list -> unit
 
-val print_ml_path : unit -> unit
+(** {5 Utilities} *)
 
-val print_ml_modules : unit -> unit
+val print_ml_path : unit -> Pp.std_ppcmds
+val print_ml_modules : unit -> Pp.std_ppcmds
+val print_gc : unit -> Pp.std_ppcmds
diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml
new file mode 100644
index 00000000..aa068586
--- /dev/null
+++ b/toplevel/obligations.ml
@@ -0,0 +1,1075 @@
+open Printf
+open Globnames
+open Libobject
+open Entries
+open Decl_kinds
+open Declare
+
+(**
+   - Get types of existentials ;
+   - Flatten dependency tree (prefix order) ;
+   - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
+   - Apply term prefixed by quantification on "existentials".
+*)
+
+open Term
+open Context
+open Vars
+open Names
+open Evd
+open Pp
+open Errors
+open Util
+
+let declare_fix_ref = ref (fun _ _ _ _ _ _ -> assert false)
+let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false)
+
+let trace s =
+  if !Flags.debug then msg_debug s
+  else ()
+
+let succfix (depth, fixrels) =
+  (succ depth, List.map succ fixrels)
+
+let check_evars env evm =
+  Evar.Map.iter
+  (fun key evi ->
+   let (loc,k) = evar_source key evm in
+     match k with
+     | Evar_kinds.QuestionMark _
+     | Evar_kinds.ImplicitArg (_,_,false) -> ()
+     | _ ->
+       Pretype_errors.error_unsolvable_implicit loc env evm key None)
+  (Evd.undefined_map evm)
+
+type oblinfo =
+  { ev_name: int * Id.t;
+    ev_hyps: named_context;
+    ev_status: Evar_kinds.obligation_definition_status;
+    ev_chop: int option;
+    ev_src: Evar_kinds.t Loc.located;
+    ev_typ: types;
+    ev_tac: unit Proofview.tactic option;
+    ev_deps: Int.Set.t }
+
+(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *)
+let evar_tactic = Store.field ()
+
+(** Substitute evar references in t using De Bruijn indices,
+  where n binders were passed through. *)
+
+let subst_evar_constr evs n idf t = 
+  let seen = ref Int.Set.empty in
+  let transparent = ref Id.Set.empty in
+  let evar_info id = List.assoc_f Evar.equal id evs in
+  let rec substrec (depth, fixrels) c = match kind_of_term c with
+    | Evar (k, args) ->
+	let { ev_name = (id, idstr) ;
+	      ev_hyps = hyps ; ev_chop = chop } =
+	  try evar_info k
+	  with Not_found ->
+	    anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found")
+	in
+        seen := Int.Set.add id !seen;
+	  (* Evar arguments are created in inverse order,
+	     and we must not apply to defined ones (i.e. LetIn's)
+	  *)
+	let args =
+	  let n = match chop with None -> 0 | Some c -> c in
+	  let (l, r) = List.chop n (List.rev (Array.to_list args)) in
+	    List.rev r
+	in
+	let args =
+	  let rec aux hyps args acc =
+	     match hyps, args with
+		 ((_, None, _) :: tlh), (c :: tla) ->
+		   aux tlh tla ((substrec (depth, fixrels) c) :: acc)
+	       | ((_, Some _, _) :: tlh), (_ :: tla) ->
+		   aux tlh tla acc
+	       | [], [] -> acc
+	       | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
+	  in aux hyps args []
+	in
+	  if List.exists
+            (fun x -> match kind_of_term x with
+            | Rel n -> Int.List.mem n fixrels
+            | _ -> false) args
+          then
+	    transparent := Id.Set.add idstr !transparent;
+	  mkApp (idf idstr, Array.of_list args)
+    | Fix _ ->
+	map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
+    | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
+  in
+  let t' = substrec (0, []) t in
+    t', !seen, !transparent
+
+
+(** Substitute variable references in t using De Bruijn indices,
+  where n binders were passed through. *)
+let subst_vars acc n t =
+  let var_index id = Util.List.index Id.equal id acc in
+  let rec substrec depth c = match kind_of_term c with
+    | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
+    | _ -> map_constr_with_binders succ substrec depth c
+  in
+    substrec 0 t
+
+(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
+    to a product : forall H1 : t1, ..., forall Hn : tn, concl.
+    Changes evars and hypothesis references to variable references.
+*)
+let etype_of_evar evs hyps concl =
+  let rec aux acc n = function
+      (id, copt, t) :: tl ->
+	let t', s, trans = subst_evar_constr evs n mkVar t in
+	let t'' = subst_vars acc 0 t' in
+	let rest, s', trans' = aux (id :: acc) (succ n) tl in
+	let s' = Int.Set.union s s' in
+	let trans' = Id.Set.union trans trans' in
+	  (match copt with
+	      Some c -> 
+		let c', s'', trans'' = subst_evar_constr evs n mkVar c in
+		let c' = subst_vars acc 0 c' in
+		  mkNamedProd_or_LetIn (id, Some c', t'') rest,
+		Int.Set.union s'' s',
+		Id.Set.union trans'' trans'
+	    | None ->
+		mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
+    | [] ->
+	let t', s, trans = subst_evar_constr evs n mkVar concl in
+	  subst_vars acc 0 t', s, trans
+  in aux [] 0 (List.rev hyps)
+
+let trunc_named_context n ctx =
+  let len = List.length ctx in
+    List.firstn (len - n) ctx
+
+let rec chop_product n t =
+  if Int.equal n 0 then Some t
+  else
+    match kind_of_term t with
+      | Prod (_, _, b) ->  if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
+      | _ -> None
+
+let evar_dependencies evm oev =
+  let one_step deps =
+    Evar.Set.fold (fun ev s ->
+      let evi = Evd.find evm ev in
+      let deps' = evars_of_filtered_evar_info evi in
+      if Evar.Set.mem oev deps' then
+	invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ string_of_existential oev)
+      else Evar.Set.union deps' s)
+      deps deps
+  in
+  let rec aux deps =
+    let deps' = one_step deps in
+      if Evar.Set.equal deps deps' then deps
+      else aux deps'
+  in aux (Evar.Set.singleton oev)
+      
+let move_after (id, ev, deps as obl) l = 
+  let rec aux restdeps = function
+    | (id', _, _) as obl' :: tl -> 
+	let restdeps' = Evar.Set.remove id' restdeps in
+	  if Evar.Set.is_empty restdeps' then
+	    obl' :: obl :: tl
+	  else obl' :: aux restdeps' tl
+    | [] -> [obl]
+  in aux (Evar.Set.remove id deps) l
+    
+let sort_dependencies evl =
+  let rec aux l found list =
+    match l with
+    | (id, ev, deps) as obl :: tl ->
+	let found' = Evar.Set.union found (Evar.Set.singleton id) in
+	  if Evar.Set.subset deps found' then
+	    aux tl found' (obl :: list)
+	  else aux (move_after obl tl) found list
+    | [] -> List.rev list
+  in aux evl Evar.Set.empty []
+
+open Environ
+
+let eterm_obligations env name evm fs ?status t ty = 
+  (* 'Serialize' the evars *)
+  let nc = Environ.named_context env in
+  let nc_len = Context.named_context_length nc in
+  let evm = Evarutil.nf_evar_map_undefined evm in
+  let evl = Evarutil.non_instantiated evm in
+  let evl = Evar.Map.bindings evl in
+  let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
+  let sevl = sort_dependencies evl in
+  let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
+  let evn =
+    let i = ref (-1) in
+      List.rev_map (fun (id, ev) -> incr i;
+		      (id, (!i, Id.of_string
+			      (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))),
+		       ev)) evl
+  in
+  let evts =
+    (* Remove existential variables in types and build the corresponding products *)
+    List.fold_right
+      (fun (id, (n, nstr), ev) l ->
+	 let hyps = Evd.evar_filtered_context ev in
+	 let hyps = trunc_named_context nc_len hyps in
+	 let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
+	 let evtyp, hyps, chop =
+	   match chop_product fs evtyp with
+	   | Some t -> t, trunc_named_context fs hyps, fs
+	   | None -> evtyp, hyps, 0
+	 in
+	 let loc, k = evar_source id evm in
+	 let status = match k with Evar_kinds.QuestionMark o -> Some o | _ -> status in
+	 let status, chop = match status with
+	   | Some (Evar_kinds.Define true as stat) ->
+	       if not (Int.equal chop fs) then Evar_kinds.Define false, None
+	       else stat, Some chop
+	   | Some s -> s, None
+	   | None -> Evar_kinds.Define true, None
+	 in
+	 let tac = match Store.get ev.evar_extra evar_tactic with
+	   | Some t ->
+	       if Dyn.has_tag t "tactic" then
+		 Some (Tacinterp.interp 
+			  (Tacinterp.globTacticIn (Tacinterp.tactic_out t)))
+	       else None
+	   | None -> None
+	 in
+	 let info = { ev_name = (n, nstr);
+		      ev_hyps = hyps; ev_status = status; ev_chop = chop;
+		      ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
+	 in (id, info) :: l)
+      evn []
+  in
+  let t', _, transparent = (* Substitute evar refs in the term by variables *)
+    subst_evar_constr evts 0 mkVar t 
+  in
+  let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
+  let evars = 
+    List.map (fun (ev, info) ->
+      let { ev_name = (_, name); ev_status = status;
+	    ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info
+      in
+      let status = match status with
+	| Evar_kinds.Define true when Id.Set.mem name transparent ->
+	  Evar_kinds.Define false
+	| _ -> status
+      in name, typ, src, status, deps, tac) evts
+  in
+  let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in
+  let evmap f c = pi1 (subst_evar_constr evts 0 f c) in
+    Array.of_list (List.rev evars), (evnames, evmap), t', ty
+
+let tactics_module = ["Program";"Tactics"]
+let safe_init_constant md name () =
+  Coqlib.check_required_library ("Coq"::md);
+  Coqlib.gen_constant "Obligations" md name
+let hide_obligation = safe_init_constant tactics_module "obligation"
+
+let pperror cmd = Errors.errorlabstrm "Program" cmd
+let error s = pperror (str s)
+
+let reduce c =
+  Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c
+
+exception NoObligations of Id.t option
+
+let explain_no_obligations = function
+    Some ident -> str "No obligations for program " ++ str (Id.to_string ident)
+  | None -> str "No obligations remaining"
+
+type obligation_info =
+    (Names.Id.t * Term.types * Evar_kinds.t Loc.located *
+     Evar_kinds.obligation_definition_status * Int.Set.t * unit Proofview.tactic option) array
+
+type 'a obligation_body = 
+  | DefinedObl of 'a
+  | TermObl of constr
+
+type obligation =
+  { obl_name : Id.t;
+    obl_type : types;
+    obl_location : Evar_kinds.t Loc.located;
+    obl_body : constant obligation_body option;
+    obl_status : Evar_kinds.obligation_definition_status;
+    obl_deps : Int.Set.t;
+    obl_tac : unit Proofview.tactic option;
+  }
+
+type obligations = (obligation array * int)
+
+type fixpoint_kind =
+  | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
+  | IsCoFixpoint
+
+type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
+
+type program_info = {
+  prg_name: Id.t;
+  prg_body: constr;
+  prg_type: constr;
+  prg_ctx:  Evd.evar_universe_context;
+  prg_obligations: obligations;
+  prg_deps : Id.t list;
+  prg_fixkind : fixpoint_kind option ;
+  prg_implicits : (Constrexpr.explicitation * (bool * bool * bool)) list;
+  prg_notations : notations ;
+  prg_kind : definition_kind;
+  prg_reduce : constr -> constr;
+  prg_hook : unit Lemmas.declaration_hook;
+}
+
+let assumption_message = Declare.assumption_message
+
+let (set_default_tactic, get_default_tactic, print_default_tactic) = 
+  Tactic_option.declare_tactic_option "Program tactic"
+
+(* true = All transparent, false = Opaque if possible *)
+let proofs_transparency = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+open Goptions
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "transparency of Program obligations";
+      optkey   = ["Transparent";"Obligations"];
+      optread  = get_proofs_transparency;
+      optwrite = set_proofs_transparency; }
+
+(* true = hide obligations *)
+let hide_obligations = ref false
+
+let set_hide_obligations = (:=) hide_obligations
+let get_hide_obligations () = !hide_obligations
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Hidding of Program obligations";
+      optkey   = ["Hide";"Obligations"];
+      optread  = get_hide_obligations;
+      optwrite = set_hide_obligations; }
+
+let shrink_obligations = ref false
+
+let set_shrink_obligations = (:=) shrink_obligations
+let get_shrink_obligations () = !shrink_obligations
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "Shrinking of Program obligations";
+      optkey   = ["Shrink";"Obligations"];
+      optread  = get_shrink_obligations;
+      optwrite = set_shrink_obligations; }
+
+let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
+
+let get_body obl = 
+  match obl.obl_body with
+  | None -> assert false
+  | Some (DefinedObl c) ->
+    let ctx = Environ.constant_context (Global.env ()) c in
+    let pc = (c, Univ.UContext.instance ctx) in
+      DefinedObl pc
+  | Some (TermObl c) -> 
+      TermObl c
+
+let get_obligation_body expand obl =
+  let c = get_body obl in
+  let c' = 
+    if expand && obl.obl_status == Evar_kinds.Expand then
+      (match c with
+      | DefinedObl pc -> constant_value_in (Global.env ()) pc
+      | TermObl c -> c)
+    else (match c with
+    | DefinedObl pc -> mkConstU pc
+    | TermObl c -> c)
+  in c'
+
+let obl_substitution expand obls deps =
+  Int.Set.fold
+    (fun x acc ->
+       let xobl = obls.(x) in
+       let oblb =
+	 try get_obligation_body expand xobl
+	 with e when Errors.noncritical e -> assert false
+       in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc)
+    deps []
+
+let subst_deps expand obls deps t =
+  let osubst = obl_substitution expand obls deps in
+    (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t)
+
+let rec prod_app t n =
+  match kind_of_term (strip_outer_cast t) with
+    | Prod (_,_,b) -> subst1 n b
+    | LetIn (_, b, t, b') -> prod_app (subst1 b b') n
+    | _ ->
+	errorlabstrm "prod_app"
+	  (str"Needed a product, but didn't find one" ++ fnl ())
+
+
+(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
+let prod_applist t nL = List.fold_left prod_app t nL
+
+let replace_appvars subst =
+  let rec aux c = 
+    let f, l = decompose_app c in
+      if isVar f then
+	try
+	  let c' = List.map (map_constr aux) l in
+	  let (t, b) = Id.List.assoc (destVar f) subst in
+	    mkApp (delayed_force hide_obligation, 
+		   [| prod_applist t c'; applistc b c' |])
+	with Not_found -> map_constr aux c
+      else map_constr aux c
+  in map_constr aux
+       
+let subst_prog expand obls ints prg =
+  let subst = obl_substitution expand obls ints in
+    if get_hide_obligations () then
+      (replace_appvars subst prg.prg_body,
+       replace_appvars subst ((* Termops.refresh_universes *) prg.prg_type))
+    else 
+      let subst' = List.map (fun (n, (_, b)) -> n, b) subst in
+	(Vars.replace_vars subst' prg.prg_body,
+	 Vars.replace_vars subst' ((* Termops.refresh_universes *) prg.prg_type))
+
+let subst_deps_obl obls obl =
+  let t' = subst_deps true obls obl.obl_deps obl.obl_type in
+    { obl with obl_type = t' }
+
+module ProgMap = Map.Make(Id)
+
+let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
+
+let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
+
+let map_cardinal m =
+  let i = ref 0 in
+    ProgMap.iter (fun _ _ -> incr i) m;
+    !i
+
+exception Found of program_info
+
+let map_first m =
+  try
+    ProgMap.iter (fun _ v -> raise (Found v)) m;
+    assert(false)
+  with Found x -> x
+
+let from_prg : program_info ProgMap.t ref =
+  Summary.ref ProgMap.empty ~name:"program-tcc-table"
+
+let close sec =
+  if not (ProgMap.is_empty !from_prg) then
+    let keys = map_keys !from_prg in
+      errorlabstrm "Program" 
+	(str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++
+	   prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++
+	   (str (if Int.equal (List.length keys) 1 then " has " else " have ") ++
+	      str "unsolved obligations"))
+
+let input : program_info ProgMap.t -> obj =
+  declare_object
+    { (default_object "Program state") with
+      cache_function = (fun (na, pi) -> from_prg := pi);
+      load_function = (fun _ (_, pi) -> from_prg := pi);
+      discharge_function = (fun _ -> close "section"; None);
+      classify_function = (fun _ -> close "module"; Dispose) }
+    
+open Evd
+
+let progmap_remove prg =
+  Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg))
+  
+let progmap_add n prg =
+  Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg))
+
+let progmap_replace prg' = 
+  Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg))
+
+let rec intset_to = function
+    -1 -> Int.Set.empty
+  | n -> Int.Set.add n (intset_to (pred n))
+
+let subst_body expand prg =
+  let obls, _ = prg.prg_obligations in
+  let ints = intset_to (pred (Array.length obls)) in
+    subst_prog expand obls ints prg
+
+let declare_definition prg =
+  let body, typ = subst_body true prg in
+  let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None)
+    (Evd.evar_universe_context_subst prg.prg_ctx) in
+  let ce =
+    definition_entry ~types:(nf typ) ~poly:(pi2 prg.prg_kind) 
+      ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body)
+  in
+    progmap_remove prg;
+    !declare_definition_ref prg.prg_name 
+      prg.prg_kind ce prg.prg_implicits
+      (Lemmas.mk_hook (fun l r ->
+         Lemmas.call_hook (fun exn -> exn) prg.prg_hook l r; r))
+
+open Pp
+
+let rec lam_index n t acc =
+  match kind_of_term t with
+    | Lambda (Name n', _, _) when Id.equal n n' ->
+      acc
+    | Lambda (_, _, b) ->
+	lam_index n b (succ acc)
+    | _ -> raise Not_found
+
+let compute_possible_guardness_evidences (n,_) fixbody fixtype =
+  match n with
+  | Some (loc, n) -> [lam_index n fixbody 0]
+  | None ->
+      (* If recursive argument was not given by user, we try all args.
+	 An earlier approach was to look only for inductive arguments,
+	 but doing it properly involves delta-reduction, and it finally
+         doesn't seem to worth the effort (except for huge mutual
+	 fixpoints ?) *)
+      let m = nb_prod fixtype in
+      let ctx = fst (decompose_prod_n_assum m fixtype) in
+	List.map_i (fun i _ -> i) 0 ctx
+
+let mk_proof c = ((c, Univ.ContextSet.empty), Declareops.no_seff)
+
+let declare_mutual_definition l =
+  let len = List.length l in
+  let first = List.hd l in
+  let fixdefs, fixtypes, fiximps =
+    List.split3
+      (List.map (fun x -> 
+	let subs, typ = (subst_body true x) in
+	let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
+	let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
+	  x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
+  in
+(*   let fixdefs = List.map reduce_fix fixdefs in *)
+  let fixkind = Option.get first.prg_fixkind in
+  let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in
+  let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in
+  let (local,poly,kind) = first.prg_kind in
+  let fixnames = first.prg_deps in
+  let kind = if fixkind != IsCoFixpoint then Fixpoint else CoFixpoint in
+  let indexes, fixdecls =
+    match fixkind with
+      | IsFixpoint wfl ->
+	  let possible_indexes =
+	    List.map3 compute_possible_guardness_evidences
+              wfl fixdefs fixtypes in
+	  let indexes = 
+            Pretyping.search_guard Loc.ghost (Global.env())
+              possible_indexes fixdecls in
+          Some indexes, 
+          List.map_i (fun i _ ->
+            mk_proof (mkFix ((indexes,i),fixdecls))) 0 l
+      | IsCoFixpoint ->
+          None,
+          List.map_i (fun i _ ->
+            mk_proof (mkCoFix (i,fixdecls))) 0 l
+  in
+  (* Declare the recursive definitions *)
+  let ctx = Evd.evar_context_universe_context first.prg_ctx in
+  let kns = List.map4 (!declare_fix_ref (local, poly, kind) ctx) 
+    fixnames fixdecls fixtypes fiximps in
+    (* Declare notations *)
+    List.iter Metasyntax.add_notation_interpretation first.prg_notations;
+    Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames;
+    let gr = List.hd kns in
+    let kn = match gr with ConstRef kn -> kn | _ -> assert false in
+      Lemmas.call_hook (fun exn -> exn) first.prg_hook local gr;
+      List.iter progmap_remove l; kn
+
+let shrink_body c = 
+  let ctx, b = decompose_lam c in
+  let b', n, args = 
+    List.fold_left (fun (b, i, args) (n,t) ->
+      if noccurn 1 b then 
+	subst1 mkProp b, succ i, args
+      else mkLambda (n,t,b), succ i, mkRel i :: args)
+     (b, 1, []) ctx
+  in List.map (fun (c,t) -> (c,None,t)) ctx, b', Array.of_list args
+      
+let declare_obligation prg obl body ty uctx =
+  let body = prg.prg_reduce body in
+  let ty = Option.map prg.prg_reduce ty in
+  match obl.obl_status with
+  | Evar_kinds.Expand -> { obl with obl_body = Some (TermObl body) }
+  | Evar_kinds.Define opaque ->
+      let opaque = if get_proofs_transparency () then false else opaque in
+      let poly = pi2 prg.prg_kind in
+      let ctx, body, args = 
+	if get_shrink_obligations () && not poly then
+	  shrink_body body else [], body, [||] 
+      in
+      let ce = 
+        { const_entry_body = Future.from_val((body,Univ.ContextSet.empty),Declareops.no_seff);
+          const_entry_secctx = None;
+	  const_entry_type = if List.is_empty ctx then ty else None;
+	  const_entry_polymorphic = poly;
+	  const_entry_universes = uctx;
+	  const_entry_opaque = opaque;
+          const_entry_inline_code = false;
+          const_entry_feedback = None;
+      } in
+    (** ppedrot: seems legit to have obligations as local *)
+      let constant = Declare.declare_constant obl.obl_name ~local:true
+	(DefinitionEntry ce,IsProof Property)
+      in
+	if not opaque then
+	  Hints.add_hints false [Id.to_string prg.prg_name]
+	    (Hints.HintsUnfoldEntry [EvalConstRef constant]);
+	definition_message obl.obl_name;
+	{ obl with obl_body = 
+	    if poly then 
+	      Some (DefinedObl constant)
+	    else
+	      Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) }
+
+let init_prog_info n b t ctx deps fixkind notations obls impls kind reduce hook =
+  let obls', b = 
+    match b with
+    | None ->
+	assert(Int.equal (Array.length obls) 0);
+	let n = Nameops.add_suffix n "_obligation" in
+	  [| { obl_name = n; obl_body = None;
+	       obl_location = Loc.ghost, Evar_kinds.InternalHole; obl_type = t;
+	       obl_status = Evar_kinds.Expand; obl_deps = Int.Set.empty;
+	       obl_tac = None } |],
+	mkVar n
+    | Some b ->
+	Array.mapi
+	  (fun i (n, t, l, o, d, tac) ->
+            { obl_name = n ; obl_body = None; 
+	      obl_location = l; obl_type = reduce t; obl_status = o;
+	      obl_deps = d; obl_tac = tac })
+	  obls, b
+  in
+    { prg_name = n ; prg_body = b; prg_type = reduce t; 
+      prg_ctx = ctx; 
+      prg_obligations = (obls', Array.length obls');
+      prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
+      prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; 
+      prg_hook = hook; }
+
+let get_prog name =
+  let prg_infos = !from_prg in
+    match name with
+	Some n ->
+	  (try ProgMap.find n prg_infos
+	   with Not_found -> raise (NoObligations (Some n)))
+      | None ->
+	  (let n = map_cardinal prg_infos in
+	     match n with
+		 0 -> raise (NoObligations None)
+	       | 1 -> map_first prg_infos
+	       | _ -> 
+                   error ("More than one program with unsolved obligations: "^
+                    String.concat ", " 
+                     (List.map string_of_id
+                      (ProgMap.fold (fun k _ s -> k::s) prg_infos []))))
+
+let get_any_prog () =
+  let prg_infos = !from_prg in
+  let n = map_cardinal prg_infos in
+  if n > 0 then map_first prg_infos
+  else raise (NoObligations None)
+
+let get_prog_err n =
+  try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
+
+let get_any_prog_err () =
+  try get_any_prog () with NoObligations id -> pperror (explain_no_obligations id)
+
+let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0
+
+let all_programs () =
+  ProgMap.fold (fun k p l -> p :: l) !from_prg []
+
+type progress =
+    | Remain of int
+    | Dependent
+    | Defined of global_reference
+
+let obligations_message rem =
+  if rem > 0 then
+    if Int.equal rem 1 then
+      Flags.if_verbose msg_info (int rem ++ str " obligation remaining")
+    else
+      Flags.if_verbose msg_info (int rem ++ str " obligations remaining")
+  else
+    Flags.if_verbose msg_info (str "No more obligations remaining")
+
+let update_obls prg obls rem =
+  let prg' = { prg with prg_obligations = (obls, rem) } in
+    progmap_replace prg';
+    obligations_message rem;
+    if rem > 0 then Remain rem
+    else (
+      match prg'.prg_deps with
+      | [] ->
+	  let kn = declare_definition prg' in
+	    progmap_remove prg';
+	    Defined kn
+      | l ->
+	  let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
+	    if List.for_all (fun x -> obligations_solved x) progs then
+	      let kn = declare_mutual_definition progs in
+		Defined (ConstRef kn)
+	    else Dependent)
+
+let is_defined obls x = not (Option.is_empty obls.(x).obl_body)
+
+let deps_remaining obls deps =
+  Int.Set.fold
+    (fun x acc ->
+      if is_defined obls x then acc
+      else x :: acc)
+    deps []
+
+let dependencies obls n =
+  let res = ref Int.Set.empty in
+    Array.iteri
+      (fun i obl ->
+	if not (Int.equal i n) && Int.Set.mem n obl.obl_deps then
+	  res := Int.Set.add i !res)
+      obls;
+    !res
+
+let goal_kind poly = Decl_kinds.Local, poly, Decl_kinds.DefinitionBody Decl_kinds.Definition
+
+let goal_proof_kind poly = Decl_kinds.Local, poly, Decl_kinds.Proof Decl_kinds.Lemma
+
+let kind_of_obligation poly o =
+  match o with
+  | Evar_kinds.Define false | Evar_kinds.Expand -> goal_kind poly
+  | _ -> goal_proof_kind poly
+
+let not_transp_msg =
+  str "Obligation should be transparent but was declared opaque." ++ spc () ++
+    str"Use 'Defined' instead."
+
+let error_not_transp () = pperror not_transp_msg
+
+let rec string_of_list sep f = function
+    [] -> ""
+  | x :: [] -> f x
+  | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
+
+(* Solve an obligation using tactics, return the corresponding proof term *)
+
+let solve_by_tac name evi t poly ctx =
+  let id = name in
+  let concl = evi.evar_concl in
+  (* spiwack: the status is dropped. *)
+  let (entry,_,ctx') = Pfedit.build_constant_by_tactic 
+    id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in
+  let env = Global.env () in
+  let entry = Term_typing.handle_entry_side_effects env entry in
+  let body, eff = Future.force entry.Entries.const_entry_body in
+  assert(Declareops.side_effects_is_empty eff);
+  assert(Univ.ContextSet.is_empty (snd body));
+  Inductiveops.control_only_guard (Global.env ()) (fst body);
+  (fst body), entry.Entries.const_entry_type, ctx'
+
+let rec solve_obligation prg num tac =
+  let user_num = succ num in
+  let obls, rem = prg.prg_obligations in
+  let obl = obls.(num) in
+    if not (Option.is_empty obl.obl_body) then
+      pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")
+    else
+      match deps_remaining obls obl.obl_deps with
+      | [] ->
+          let obl = subst_deps_obl obls obl in
+          let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in
+            let evd = Evd.from_env ~ctx:prg.prg_ctx Environ.empty_env in
+            Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type
+              (fun ctx' -> Lemmas.mk_hook (fun strength gr ->
+		let cst = match gr with ConstRef cst -> cst | _ -> assert false in
+		let obl =
+		  let transparent = evaluable_constant cst (Global.env ()) in
+		  let body =
+		    match obl.obl_status with
+		    | Evar_kinds.Expand ->
+			if not transparent then error_not_transp ()
+			else DefinedObl cst
+		    | Evar_kinds.Define opaque ->
+			if not opaque && not transparent then error_not_transp ()
+			else DefinedObl cst
+		  in
+		    if transparent then
+		      Hints.add_hints true [Id.to_string prg.prg_name]
+			(Hints.HintsUnfoldEntry [EvalConstRef cst]);
+		    { obl with obl_body = Some body }
+		in
+		let obls = Array.copy obls in
+		let _ = obls.(num) <- obl in
+		let ctx' = 
+		  let ctx = 
+		    match ctx' with
+		    | None -> prg.prg_ctx
+		    | Some ctx' -> ctx'
+		  in
+  		    if not (pi2 prg.prg_kind) (* Not polymorphic *) then
+		      (* This context is already declared globally, we cannot 
+			 instantiate the rigid variables anymore *) 
+		      Evd.abstract_undefined_variables ctx
+		    else ctx
+		in
+		let res = 
+		  try update_obls 
+			{prg with prg_body = prg.prg_body;
+			  prg_type = prg.prg_type;
+			  prg_ctx = ctx' }
+			  
+			obls (pred rem)
+		  with e when Errors.noncritical e ->
+                    let e = Errors.push e in
+                    pperror (Errors.iprint (Cerrors.process_vernac_interp_error e))
+		in
+		  match res with
+		  | Remain n when n > 0 ->
+		      let deps = dependencies obls num in
+			if not (Int.Set.is_empty deps) then
+			  ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps)
+		  | _ -> ()));
+	    trace (str "Started obligation " ++ int user_num ++ str "  proof: " ++
+		     Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type);
+	    ignore (Pfedit.by (snd (get_default_tactic ())));
+	    Option.iter (fun tac -> Pfedit.set_end_tac tac) tac
+      | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
+		      ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
+
+and obligation (user_num, name, typ) tac =
+  let num = pred user_num in
+  let prg = get_prog_err name in
+  let obls, rem = prg.prg_obligations in
+    if num < Array.length obls then
+      let obl = obls.(num) in
+	match obl.obl_body with
+	    None -> solve_obligation prg num tac
+	  | Some r -> error "Obligation already solved"
+    else error (sprintf "Unknown obligation number %i" (succ num))
+
+
+and solve_obligation_by_tac prg obls i tac =
+  let obl = obls.(i) in
+    match obl.obl_body with
+    | Some _ -> false
+    | None ->
+	try
+	  if List.is_empty (deps_remaining obls obl.obl_deps) then
+	    let obl = subst_deps_obl obls obl in
+	    let tac =
+	      match tac with
+	      | Some t -> t
+	      | None ->
+		  match obl.obl_tac with
+		  | Some t -> t
+		  | None -> snd (get_default_tactic ())
+	    in
+	    let t, ty, ctx = 
+	      solve_by_tac obl.obl_name (evar_of_obligation obl) tac 
+	        (pi2 !prg.prg_kind) !prg.prg_ctx
+	    in
+	    let uctx = Evd.evar_context_universe_context ctx in
+	      prg := {!prg with prg_ctx = ctx};
+	      obls.(i) <- declare_obligation !prg obl t ty uctx;
+	      true
+	  else false
+	with e when Errors.noncritical e ->
+          let (e, _) = Errors.push e in
+          match e with
+	  | Refiner.FailError (_, s) ->
+	      user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s)
+          | e -> false
+
+and solve_prg_obligations prg ?oblset tac =
+  let obls, rem = prg.prg_obligations in
+  let rem = ref rem in
+  let obls' = Array.copy obls in
+  let set = ref Int.Set.empty in
+  let p = match oblset with
+    | None -> (fun _ -> true)
+    | Some s -> set := s;
+      (fun i -> Int.Set.mem i !set)
+  in
+  let prg = ref prg in
+  let _ =
+    Array.iteri (fun i x ->
+      if p i && solve_obligation_by_tac prg obls' i tac then
+ 	let deps = dependencies obls i in
+ 	  (set := Int.Set.union !set deps;
+ 	   decr rem))
+      obls'
+  in
+    update_obls !prg obls' !rem
+
+and solve_obligations n tac =
+  let prg = get_prog_err n in
+    solve_prg_obligations prg tac
+
+and solve_all_obligations tac =
+  ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
+
+and try_solve_obligation n prg tac =
+  let prg = get_prog prg in
+  let obls, rem = prg.prg_obligations in
+  let obls' = Array.copy obls in
+  let prgref = ref prg in
+    if solve_obligation_by_tac prgref obls' n tac then
+      ignore(update_obls !prgref obls' (pred rem));
+
+and try_solve_obligations n tac =
+  try ignore (solve_obligations n tac) with NoObligations _ -> ()
+
+and auto_solve_obligations n ?oblset tac : progress =
+  Flags.if_verbose msg_info (str "Solving obligations automatically...");
+  try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
+
+open Pp
+let show_obligations_of_prg ?(msg=true) prg =
+  let n = prg.prg_name in
+  let obls, rem = prg.prg_obligations in
+  let showed = ref 5 in
+    if msg then msg_info (int rem ++ str " obligation(s) remaining: ");
+    Array.iteri (fun i x ->
+		   match x.obl_body with
+		   | None ->
+		       if !showed > 0 then (
+			 decr showed;
+			 msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
+				   str "of" ++ spc() ++ str (Id.to_string n) ++ str ":" ++ spc () ++
+				   hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++
+					    str "." ++ fnl ())))
+		   | Some _ -> ())
+      obls
+
+let show_obligations ?(msg=true) n =
+  let progs = match n with
+    | None -> all_programs ()
+    | Some n ->
+	try [ProgMap.find n !from_prg]
+	with Not_found -> raise (NoObligations (Some n))
+  in List.iter (show_obligations_of_prg ~msg) progs
+
+let show_term n =
+  let prg = get_prog_err n in
+  let n = prg.prg_name in
+    (str (Id.to_string n) ++ spc () ++ str":" ++ spc () ++
+	     Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
+	    ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body)
+
+let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
+    ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) obls =
+  let info = str (Id.to_string n) ++ str " has type-checked" in
+  let prg = init_prog_info n term t ctx [] None [] obls implicits kind reduce hook in
+  let obls,_ = prg.prg_obligations in
+  if Int.equal (Array.length obls) 0 then (
+    Flags.if_verbose msg_info (info ++ str ".");
+    let cst = declare_definition prg in
+      Defined cst)
+  else (
+    let len = Array.length obls in
+    let _ = Flags.if_verbose msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in
+      progmap_add n prg;
+      let res = auto_solve_obligations (Some n) tactic in
+	match res with
+	| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
+	| _ -> res)
+
+let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
+    ?(hook=Lemmas.mk_hook (fun _ _ -> ())) notations fixkind =
+  let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
+    List.iter
+    (fun  (n, b, t, imps, obls) ->
+     let prg = init_prog_info n (Some b) t ctx deps (Some fixkind) 
+       notations obls imps kind reduce hook 
+     in progmap_add n prg) l;
+    let _defined =
+      List.fold_left (fun finished x ->
+	if finished then finished
+	else
+	  let res = auto_solve_obligations (Some x) tactic in
+	    match res with
+	    | Defined _ -> 
+		(* If one definition is turned into a constant, 
+		   the whole block is defined. *) true
+	    | _ -> false)
+	false deps
+    in ()
+
+let admit_prog prg =
+  let obls, rem = prg.prg_obligations in
+  let obls = Array.copy obls in
+    Array.iteri 
+      (fun i x ->
+        match x.obl_body with
+        | None ->
+            let x = subst_deps_obl obls x in
+	    let ctx = Evd.evar_context_universe_context prg.prg_ctx in
+            let kn = Declare.declare_constant x.obl_name ~local:true
+              (ParameterEntry (None,false,(x.obl_type,ctx),None), IsAssumption Conjectural)
+            in
+              assumption_message x.obl_name;
+              obls.(i) <- { x with obl_body = Some (DefinedObl kn) }
+        | Some _ -> ())
+      obls;
+    ignore(update_obls prg obls 0)
+
+let rec admit_all_obligations () =
+  let prg = try Some (get_any_prog ()) with NoObligations _ -> None in
+  match prg with
+  | None -> ()
+  | Some prg ->
+    admit_prog prg;
+    admit_all_obligations ()
+
+let admit_obligations n =
+  match n with
+  | None -> admit_all_obligations ()
+  | Some _ ->
+    let prg = get_prog_err n in
+    admit_prog prg
+
+let next_obligation n tac =
+  let prg = match n with
+  | None -> get_any_prog_err ()
+  | Some _ -> get_prog_err n
+  in
+  let obls, rem = prg.prg_obligations in
+  let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in
+  let i = match Array.findi is_open obls with
+  | Some i -> i
+  | None -> anomaly (Pp.str "Could not find a solvable obligation.")
+  in
+  solve_obligation prg i tac
+
+let init_program () =
+  Coqlib.check_required_library Coqlib.datatypes_module_name;
+  Coqlib.check_required_library ["Coq";"Init";"Specif"];
+  Coqlib.check_required_library ["Coq";"Program";"Tactics"]
+
+
+let set_program_mode c =
+  if c then
+    if !Flags.program_mode then ()
+    else begin
+      init_program ();
+      Flags.program_mode := true;
+    end
diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli
new file mode 100644
index 00000000..582b4935
--- /dev/null
+++ b/toplevel/obligations.mli
@@ -0,0 +1,116 @@
+(************************************************************************)
+(*  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 Environ
+open Term
+open Evd
+open Names
+open Pp
+open Globnames
+open Vernacexpr
+open Decl_kinds
+open Tacexpr
+
+(** Forward declaration. *)
+val declare_fix_ref : (definition_kind -> Univ.universe_context -> Id.t ->
+  Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref
+
+val declare_definition_ref :
+  (Id.t -> definition_kind ->
+     Entries.definition_entry -> Impargs.manual_implicits
+       -> global_reference Lemmas.declaration_hook -> global_reference) ref
+
+val check_evars : env -> evar_map -> unit
+
+val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t
+val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list
+
+(* env, id, evars, number of function prototypes to try to clear from
+   evars contexts, object and type *)
+val eterm_obligations : env -> Id.t -> evar_map -> int ->
+  ?status:Evar_kinds.obligation_definition_status -> constr -> types ->
+  (Id.t * types * Evar_kinds.t Loc.located * Evar_kinds.obligation_definition_status * Int.Set.t *
+      unit Proofview.tactic option) array
+    (* Existential key, obl. name, type as product, 
+       location of the original evar, associated tactic,
+       status and dependencies as indexes into the array *)
+  * ((existential_key * Id.t) list * ((Id.t -> constr) -> constr -> constr)) *
+    constr * types
+    (* Translations from existential identifiers to obligation identifiers 
+       and for terms with existentials to closed terms, given a 
+       translation from obligation identifiers to constrs, new term, new type *)
+
+type obligation_info =
+  (Id.t * Term.types * Evar_kinds.t Loc.located *
+      Evar_kinds.obligation_definition_status * Int.Set.t * unit Proofview.tactic option) array
+    (* ident, type, location, (opaque or transparent, expand or define),
+       dependencies, tactic to solve it *)
+
+type progress = (* Resolution status of a program *)
+  | Remain of int  (* n obligations remaining *)
+  | Dependent (* Dependent on other definitions *)
+  | Defined of global_reference (* Defined as id *)
+      
+val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit
+val get_default_tactic : unit -> locality_flag * unit Proofview.tactic
+val print_default_tactic : unit -> Pp.std_ppcmds
+
+val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
+val get_proofs_transparency : unit -> bool
+
+val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> 
+  Evd.evar_universe_context ->
+  ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list ->
+  ?kind:Decl_kinds.definition_kind ->
+  ?tactic:unit Proofview.tactic ->
+  ?reduce:(Term.constr -> Term.constr) ->
+  ?hook:unit Lemmas.declaration_hook -> obligation_info -> progress
+
+type notations =
+    (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list
+
+type fixpoint_kind =
+  | IsFixpoint of (Id.t Loc.located option * Constrexpr.recursion_order_expr) list
+  | IsCoFixpoint
+
+val add_mutual_definitions :
+  (Names.Id.t * Term.constr * Term.types *
+      (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
+  Evd.evar_universe_context ->
+  ?tactic:unit Proofview.tactic ->
+  ?kind:Decl_kinds.definition_kind ->
+  ?reduce:(Term.constr -> Term.constr) ->
+  ?hook:unit Lemmas.declaration_hook ->
+  notations ->
+  fixpoint_kind -> unit
+
+val obligation : int * Names.Id.t option * Constrexpr.constr_expr option ->
+  Tacexpr.raw_tactic_expr option -> unit
+
+val next_obligation : Names.Id.t option -> Tacexpr.raw_tactic_expr option -> unit
+
+val solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> progress
+(* Number of remaining obligations to be solved for this program *)
+
+val solve_all_obligations : unit Proofview.tactic option -> unit
+
+val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit
+
+val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit
+
+val show_obligations : ?msg:bool -> Names.Id.t option -> unit
+
+val show_term : Names.Id.t option -> std_ppcmds
+
+val admit_obligations : Names.Id.t option -> unit
+
+exception NoObligations of Names.Id.t option
+
+val explain_no_obligations : Names.Id.t option -> Pp.std_ppcmds
+
+val set_program_mode : bool -> unit
diff --git a/toplevel/record.ml b/toplevel/record.ml
index 86a9411f..55f53351 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -1,107 +1,169 @@
 (************************************************************************)
 (*  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
-open Libnames
+open Globnames
 open Nameops
 open Term
+open Context
+open Vars
 open Environ
 open Declarations
 open Entries
 open Declare
-open Nametab
 open Constrintern
-open Command
-open Inductive
-open Safe_typing
 open Decl_kinds
-open Indtypes
 open Type_errors
-open Topconstr
+open Constrexpr
+open Constrexpr_ops
+open Goptions
 
 (********** definition d'un record (structure) **************)
 
-let interp_evars evdref env impls k typ =
-  let typ' = intern_gen true ~impls !evdref env typ in
-  let imps = Implicit_quantifiers.implicits_of_glob_constr typ' in
-    imps, Pretyping.Default.understand_tcc_evars evdref env k typ'
+(** Flag governing use of primitive projections. Disabled by default. *)
+let primitive_flag = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "use of primitive projections";
+      optkey   = ["Primitive";"Projections"];
+      optread  = (fun () -> !primitive_flag) ;
+      optwrite = (fun b -> primitive_flag := b) }
 
-let interp_fields_evars evars env impls_env nots l =
+let typeclasses_strict = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "strict typeclass resolution";
+      optkey   = ["Typeclasses";"Strict";"Resolution"];
+      optread  = (fun () -> !typeclasses_strict);
+      optwrite = (fun b -> typeclasses_strict := b); }
+
+let typeclasses_unique = ref false
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "unique typeclass instances";
+      optkey   = ["Typeclasses";"Unique";"Instances"];
+      optread  = (fun () -> !typeclasses_unique);
+      optwrite = (fun b -> typeclasses_unique := b); }
+
+let interp_fields_evars env evars impls_env nots l =
   List.fold_left2
     (fun (env, uimpls, params, impls) no ((loc, i), b, t) ->
-      let impl, t' = interp_evars evars env impls Pretyping.IsType t in
-      let b' = Option.map (fun x -> snd (interp_evars evars env impls (Pretyping.OfType (Some t')) x)) b in
+      let t', impl = interp_type_evars_impls env evars ~impls t in
+      let b' = Option.map (fun x -> fst (interp_casted_constr_evars_impls env evars ~impls x t')) b in
       let impls =
 	match i with
 	| Anonymous -> impls
-	| Name id -> Idmap.add id (compute_internalization_data env Constrintern.Method t' impl) impls
+	| Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls
       in
       let d = (i,b',t') in
       List.iter (Metasyntax.set_notation_for_interpretation impls) no;
       (push_rel d env, impl :: uimpls, d::params, impls))
     (env, [], [], impls_env) nots l
 
+let compute_constructor_level evars env l =
+  List.fold_right (fun (n,b,t as d) (env, univ) ->
+    let univ = 
+      if b = None then 
+	let s = Retyping.get_sort_of env evars t in
+	  Univ.sup (univ_of_sort s) univ 
+      else univ
+    in (push_rel d env, univ)) 
+    l (env, Univ.type0m_univ)
+
 let binder_of_decl = function
   | Vernacexpr.AssumExpr(n,t) -> (n,None,t)
-  | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None))
+  | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c | None -> CHole (fst n, None, Misctypes.IntroAnonymous, None))
 
 let binders_of_decls = List.map binder_of_decl
 
-let typecheck_params_and_fields id t ps nots fs =
+let typecheck_params_and_fields def id t ps nots fs =
   let env0 = Global.env () in
-  let evars = ref Evd.empty in
+  let evars = ref (Evd.from_env env0) in
   let _ = 
     let error bk (loc, name) = 
-      match bk with
-      | Default _ ->
-	  if name = Anonymous then 
-	    user_err_loc (loc, "record", str "Record parameters must be named")
+      match bk, name with
+      | Default _, Anonymous ->
+        user_err_loc (loc, "record", str "Record parameters must be named")
       | _ -> ()
     in
       List.iter 
 	(function LocalRawDef (b, _) -> error default_binder_kind b
 	   | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls) ps
   in 
-  let impls_env, ((env1,newps), imps) = interp_context_evars evars env0 ps in
-  let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (Termops.new_Type ()) t) newps in
+  let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in
+  let t', template = match t with 
+    | Some t -> 
+       let env = push_rel_context newps env0 in
+       let s = interp_type_evars env evars ~impls:empty_internalization_env t in
+       let sred = Reductionops.whd_betadeltaiota env !evars s in
+	 (match kind_of_term sred with
+	 | Sort s' -> 
+	   (match Evd.is_sort_variable !evars s' with
+	   | Some l -> evars := Evd.make_flexible_variable !evars true (* (not def) *) l; 
+	     sred, true
+	   | None -> s, false)
+	 | _ -> user_err_loc (constr_loc t,"", str"Sort expected."))
+    | None -> 
+      let uvarkind = if (* not def *) true then Evd.univ_flexible_alg else Evd.univ_flexible in
+	mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), false
+  in
+  let fullarity = it_mkProd_or_LetIn t' newps in
   let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in
   let env2,impls,newfs,data =
-    interp_fields_evars evars env_ar impls_env nots (binders_of_decls fs)
+    interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs)
   in
-  let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in
-  let evars = Typeclasses.resolve_typeclasses env_ar evars in
-  let sigma =  evars in
-  let newps = Evarutil.nf_rel_context_evar sigma newps in
-  let newfs = Evarutil.nf_rel_context_evar sigma newfs in
+  let sigma = 
+    Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars (Evd.empty,!evars) in
+  let evars, nf = Evarutil.nf_evars_and_universes sigma in
+  let arity = nf t' in
+  let evars = 
+    let _, univ = compute_constructor_level evars env_ar newfs in
+    let ctx, aritysort = Reduction.dest_arity env0 arity in
+      assert(List.is_empty ctx); (* Ensured by above analysis *)
+      if Sorts.is_prop aritysort || 
+	(Sorts.is_set aritysort && engagement env0 = Some ImpredicativeSet) then
+	evars
+      else Evd.set_leq_sort env_ar evars (Type univ) aritysort
+  in
+  let evars, nf = Evarutil.nf_evars_and_universes evars in
+  let newps = map_rel_context nf newps in
+  let newfs = map_rel_context nf newfs in
   let ce t = Evarutil.check_evars env0 Evd.empty evars t in
     List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps);
     List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs);
-    imps, newps, impls, newfs
+    Evd.universe_context evars, nf arity, template, imps, newps, impls, newfs
 
 let degenerate_decl (na,b,t) =
   let id = match na with
     | Name id -> id
-    | Anonymous -> anomaly "Unnamed record variable" in
+    | Anonymous -> anomaly (Pp.str "Unnamed record variable") in
   match b with
     | None -> (id, Entries.LocalAssum t)
     | Some b -> (id, Entries.LocalDef b)
 
 type record_error =
-  | MissingProj of identifier * identifier list
-  | BadTypedProj of identifier * env * Type_errors.type_error
+  | MissingProj of Id.t * Id.t list
+  | BadTypedProj of Id.t * env * Type_errors.type_error
 
 let warning_or_error coe indsp err =
   let st = match err with
     | MissingProj (fi,projs) ->
 	let s,have = if List.length projs > 1 then "s","were" else "","was" in
-        (str(string_of_id fi) ++
+        (str(Id.to_string fi) ++
 	   strbrk" cannot be defined because the projection" ++ str s ++ spc () ++
            prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++
 	   strbrk " not defined.")
@@ -121,10 +183,10 @@ let warning_or_error coe indsp err =
               (pr_id fi ++ strbrk " cannot be defined because it is not typable.")
   in
   if coe then errorlabstrm "structure" st;
-  Flags.if_verbose ppnl (hov 0 (str"Warning: " ++ st))
+  Flags.if_verbose msg_warning (hov 0 st)
 
 type field_status =
-  | NoProjection of name
+  | NoProjection of Name.t
   | Projection of constr
 
 exception NotDefinable of record_error
@@ -148,7 +210,7 @@ let subst_projection fid l c =
 	    | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k
 	    | NoProjection Anonymous ->
                 errorlabstrm "" (str "Field " ++ pr_id fid ++
-                  str " depends on the " ++ str (ordinal (k-depth-1)) ++ str
+                  str " depends on the " ++ pr_nth (k-depth-1) ++ str
                   " field which has no name.")
         else
 	  mkRel (k-lv)
@@ -156,88 +218,121 @@ let subst_projection fid l c =
   in
   let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *)
   let c'' = substrec 0 c' in
-  if !bad_projs <> [] then
+  if not (List.is_empty !bad_projs) then
     raise (NotDefinable (MissingProj (fid,List.rev !bad_projs)));
   c''
 
-let instantiate_possibly_recursive_type indsp paramdecls fields =
-  let subst = list_map_i (fun i _ -> mkRel i) 1 paramdecls in
-  Termops.substl_rel_context (subst@[mkInd indsp]) fields
+let instantiate_possibly_recursive_type indu paramdecls fields =
+  let subst = List.map_i (fun i _ -> mkRel i) 1 paramdecls in
+  Termops.substl_rel_context (subst@[mkIndU indu]) fields
 
 (* We build projections *)
-let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls fields =
+let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields =
   let env = Global.env() in
   let (mib,mip) = Global.lookup_inductive indsp in
-  let paramdecls = mib.mind_params_ctxt in
-  let r = mkInd indsp in
+  let u = Declareops.inductive_instance mib in
+  let paramdecls = Inductive.inductive_paramdecls (mib, u) in
+  let poly = mib.mind_polymorphic and ctx = Univ.instantiate_univ_context mib.mind_universes in
+  let indu = indsp, u in
+  let r = mkIndU (indsp,u) in
   let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in
   let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*)
-  let x = match name with Some n -> Name n | None -> Namegen.named_hd (Global.env()) r Anonymous in
-  let fields = instantiate_possibly_recursive_type indsp paramdecls fields in
+  let x = Name binder_name in
+  let fields = instantiate_possibly_recursive_type indu paramdecls fields in
   let lifted_fields = Termops.lift_rel_context 1 fields in
-  let (_,kinds,sp_projs,_) =
-    list_fold_left3
-      (fun (nfi,kinds,sp_projs,subst) coe (fi,optci,ti) impls ->
-	let (sp_projs,subst) =
+  let primitive = 
+    if !primitive_flag then 
+      let is_primitive = 
+	match mib.mind_record with
+	| Some (Some _) -> true
+	| Some None | None -> false
+      in
+	if not is_primitive then 
+	  Flags.if_verbose msg_warning
+	    (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ 
+		      str" could not be defined as a primitive record"));
+	is_primitive
+    else false
+  in
+  let (_,_,kinds,sp_projs,_) =
+    List.fold_left3
+      (fun (nfi,i,kinds,sp_projs,subst) coe (fi,optci,ti) impls ->
+	let (sp_projs,i,subst) =
 	  match fi with
 	  | Anonymous ->
-	      (None::sp_projs,NoProjection fi::subst)
-	  | Name fid ->
-            try
-              let ccl = subst_projection fid subst ti in
-	      let body = match optci with
-              | Some ci -> subst_projection fid subst ci
-              | None ->
-	        (* [ccl] is defined in context [params;x:rp] *)
-		(* [ccl'] is defined in context [params;x:rp;x:rp] *)
-		let ccl' = liftn 1 2 ccl in
-		let p = mkLambda (x, lift 1 rp, ccl') in
-		let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
-		let ci = Inductiveops.make_case_info env indsp LetStyle in
-		mkCase (ci, p, mkRel 1, [|branch|]) in
-	      let proj =
-	        it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
-              let projtyp =
-                it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
-	      let kn =
+	      (None::sp_projs,i,NoProjection fi::subst)
+	  | Name fid -> try
+	    let kn, term = 
+	      if optci = None && primitive then 
+		(** Already defined in the kernel silently *)
+		let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in
+		  Declare.definition_message fid;
+		  kn, mkProj (Projection.make kn false,mkRel 1)
+	      else
+		let ccl = subst_projection fid subst ti in
+		let body = match optci with
+		  | Some ci -> subst_projection fid subst ci
+		  | None ->
+	            (* [ccl] is defined in context [params;x:rp] *)
+		    (* [ccl'] is defined in context [params;x:rp;x:rp] *)
+		    let ccl' = liftn 1 2 ccl in
+		    let p = mkLambda (x, lift 1 rp, ccl') in
+		    let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in
+		    let ci = Inductiveops.make_case_info env indsp LetStyle in
+		      mkCase (ci, p, mkRel 1, [|branch|]) 
+		in
+		let proj =
+	          it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in
+		let projtyp =
+                  it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in
 	        try
-		  let cie = {
-		    const_entry_body = proj;
-                    const_entry_secctx = None;
-                    const_entry_type = Some projtyp;
-                    const_entry_opaque = false } in
-		  let k = (DefinitionEntry cie,IsDefinition kind) in
+		  let entry = {
+		    const_entry_body =
+		      Future.from_val (Term_typing.mk_pure_proof proj);
+		    const_entry_secctx = None;
+		    const_entry_type = Some projtyp;
+		    const_entry_polymorphic = poly;
+		    const_entry_universes = ctx;
+		    const_entry_opaque = false;
+		    const_entry_inline_code = false;
+		    const_entry_feedback = None } in
+		  let k = (DefinitionEntry entry,IsDefinition kind) in
 		  let kn = declare_constant ~internal:KernelSilent fid k in
-		  Flags.if_verbose message (string_of_id fid ^" is defined");
-		  kn
+		  let constr_fip =
+		    let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
+		      applist (mkConstU (kn,u),proj_args) 
+		  in
+		    Declare.definition_message fid;
+		    kn, constr_fip
                 with Type_errors.TypeError (ctx,te) ->
-                  raise (NotDefinable (BadTypedProj (fid,ctx,te))) in
-	      let refi = ConstRef kn in
-	      let constr_fi = mkConst kn in
-	      Impargs.maybe_declare_manual_implicits false refi impls;
-	      if coe then begin
-	        let cl = Class.class_of_global (IndRef indsp) in
-	        Class.try_add_new_coercion_with_source refi Global ~source:cl
-	      end;
-	      let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in
-	      let constr_fip = applist (constr_fi,proj_args) in
-	      (Some kn::sp_projs, Projection constr_fip::subst)
+                  raise (NotDefinable (BadTypedProj (fid,ctx,te))) 
+	    in
+	    let refi = ConstRef kn in
+	    Impargs.maybe_declare_manual_implicits false refi impls;
+	    if coe then begin
+	      let cl = Class.class_of_global (IndRef indsp) in
+	        Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl
+	    end;
+	    let i = if Option.is_empty optci then i+1 else i in
+	      (Some kn::sp_projs, i, Projection term::subst)
             with NotDefinable why ->
 	      warning_or_error coe indsp why;
-	      (None::sp_projs,NoProjection fi::subst) in
-      (nfi-1,(fi, optci=None)::kinds,sp_projs,subst))
-      (List.length fields,[],[],[]) coers (List.rev fields) (List.rev fieldimpls)
+	      (None::sp_projs,i,NoProjection fi::subst) in
+      (nfi-1,i,(fi, Option.is_empty optci)::kinds,sp_projs,subst))
+      (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls)
   in (kinds,sp_projs)
 
 let structure_signature ctx =
   let rec deps_to_evar evm l =
     match l with [] -> Evd.empty
-      | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar())
-	  (Evd.make_evar Environ.empty_named_context_val typ)
+      | [(_,_,typ)] ->
+        let env = Environ.empty_named_context_val in
+        let (evm, _) = Evarutil.new_pure_evar env evm typ in
+        evm
       | (_,_,typ)::tl ->
-	  let ev = Evarutil.new_untyped_evar() in
-	  let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val typ) in
-	  let new_tl = Util.list_map_i
+          let env = Environ.empty_named_context_val in
+          let (evm, ev) = Evarutil.new_pure_evar env evm typ in
+	  let new_tl = Util.List.map_i
 	    (fun pos (n,c,t) -> n,c,
 	       Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in
 	  deps_to_evar evm new_tl in
@@ -245,45 +340,43 @@ let structure_signature ctx =
 
 open Typeclasses
 
-let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields
-    ?(kind=StructureComponent) ?name is_coe coers sign =
+let declare_structure finite poly ctx id idbuild paramimpls params arity template 
+    fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign =
   let nparams = List.length params and nfields = List.length fields in
   let args = Termops.extended_rel_list nfields params in
   let ind = applist (mkRel (1+nparams+nfields), args) in
   let type_constructor = it_mkProd_or_LetIn ind fields in
+  let binder_name = 
+    match name with
+    | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) 
+    | Some n -> n
+  in
   let mie_ind =
     { mind_entry_typename = id;
       mind_entry_arity = arity;
+      mind_entry_template = not poly && template;
       mind_entry_consnames = [idbuild];
       mind_entry_lc = [type_constructor] }
   in
-  (* spiwack: raises an error if the structure is supposed to be non-recursive,
-        but isn't *)
-  (* there is probably a way to push this to "declare_mutual" *)
-  begin match  finite with
-  | BiFinite ->
-      if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
-	error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command."
-  | _ -> ()
-  end;
   let mie =
     { mind_entry_params = List.map degenerate_decl params;
-      mind_entry_record = true;
-      mind_entry_finite = recursivity_flag_of_kind finite;
-      mind_entry_inds = [mie_ind] } in
-  let kn = Command.declare_mutual_inductive_with_eliminations KernelVerbose mie [(paramimpls,[])] in
+      mind_entry_record = Some (if !primitive_flag then Some binder_name else None);
+      mind_entry_finite = finite;
+      mind_entry_inds = [mie_ind];
+      mind_entry_polymorphic = poly;
+      mind_entry_private = None;
+      mind_entry_universes = ctx } in
+  let kn = Command.declare_mutual_inductive_with_eliminations mie [(paramimpls,[])] in
   let rsp = (kn,0) in (* This is ind path of idstruc *)
   let cstr = (rsp,1) in
-  let kinds,sp_projs = declare_projections rsp ~kind ?name coers fieldimpls fields in
+  let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in
   let build = ConstructRef cstr in
-  if is_coe then Class.try_add_new_coercion build Global;
+  let () = if is_coe then Class.try_add_new_coercion build ~local:false poly in
   Recordops.declare_structure(rsp,cstr,List.rev kinds,List.rev sp_projs);
-  if infer then
-    Evd.fold (fun ev evi () -> Recordops.declare_method (ConstructRef cstr) ev sign) sign ();
   rsp
 
 let implicits_of_context ctx =
-  list_map_i (fun i name ->
+  List.map_i (fun i name ->
     let explname =
       match name with
       | Name n -> Some n
@@ -291,44 +384,32 @@ let implicits_of_context ctx =
     in ExplByPos (i, explname), (true, true, true))
     1 (List.rev (Anonymous :: (List.map pi1 ctx)))
 
-let declare_instance_cst glob con pri =
-  let instance = Typeops.type_of_constant (Global.env ()) con in
-  let _, r = decompose_prod_assum instance in
-    match class_of_constr r with
-      | Some (_, (tc, _)) -> add_instance (new_instance tc pri glob (ConstRef con))
-      | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.")
-
-let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields
-    ?(kind=StructureComponent) ?name is_coe coers priorities sign =
+let declare_class finite def poly ctx id idbuild paramimpls params arity 
+    template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign =
   let fieldimpls =
-    (* Make the class and all params implicits in the projections *)
-    let ctx_impls = implicits_of_context params in
-    let len = succ (List.length params) in
-      List.map (fun x -> ctx_impls @ Impargs.lift_implicits len x) fieldimpls
+    (* Make the class implicit in the projections, and the params if applicable. *)
+    let len = List.length params in
+    let impls = implicits_of_context params in
+      List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls
   in
+  let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in
   let impl, projs =
     match fields with
     | [(Name proj_name, _, field)] when def ->
 	let class_body = it_mkLambda_or_LetIn field params in
-	let class_type = Option.map (fun ar -> it_mkProd_or_LetIn ar params) arity in
-	let class_entry =
-	  { const_entry_body = class_body;
-            const_entry_secctx = None;
-	    const_entry_type = class_type;
-	    const_entry_opaque = false }
-	in
+        let _class_type = it_mkProd_or_LetIn arity params in
+	let class_entry = 
+	  Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in
 	let cst = Declare.declare_constant (snd id)
 	  (DefinitionEntry class_entry, IsDefinition Definition)
 	in
-	let inst_type = appvectc (mkConst cst) (Termops.rel_vect 0 (List.length params)) in
-	let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in
-	let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in
-	let proj_entry =
-	  { const_entry_body = proj_body;
-            const_entry_secctx = None;
-	    const_entry_type = Some proj_type;
-	    const_entry_opaque = false }
-	in
+	let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in
+	let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in
+	let proj_type =
+	  it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in
+	let proj_body =
+	  it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in
+	let proj_entry = Declare.definition_entry ~types:proj_type ~poly ~univs:ctx proj_body in
 	let proj_cst = Declare.declare_constant proj_name
 	  (DefinitionEntry proj_entry, IsDefinition Definition)
 	in
@@ -336,54 +417,87 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls
 	Impargs.declare_manual_implicits false cref [paramimpls];
 	Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls];
 	Classes.set_typeclass_transparency (EvalConstRef cst) false false;
-	if infer then Evd.fold (fun ev evi _ -> Recordops.declare_method (ConstRef cst) ev sign) sign ();
-	let sub = match List.hd coers with Some b -> Some ((if b then Backward else Forward), List.hd priorities) | None -> None in
+	let sub = match List.hd coers with
+	  | Some b -> Some ((if b then Backward else Forward), List.hd priorities) 
+	  | None -> None 
+	in
 	  cref, [Name proj_name, sub, Some proj_cst]
     | _ ->
-	let idarg = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in
-	let ind = declare_structure BiFinite infer (snd id) idbuild paramimpls
-	  params (Option.default (Termops.new_Type ()) arity) fieldimpls fields
-	  ~kind:Method ~name:idarg false (List.map (fun _ -> false) fields) sign
+	let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls
+	  params arity template fieldimpls fields
+	  ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign
 	in
 	let coers = List.map2 (fun coe pri -> 
-			       Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) 
-	  coers priorities 
+			       Option.map (fun b -> 
+			         if b then Backward, pri else Forward, pri) coe) 
+	  coers priorities
 	in
-	  IndRef ind, (list_map3 (fun (id, _, _) b y -> (id, b, y))
+	  IndRef ind, (List.map3 (fun (id, _, _) b y -> (id, b, y))
 			 (List.rev fields) coers (Recordops.lookup_projections ind))
   in
   let ctx_context =
     List.map (fun (na, b, t) ->
       match Typeclasses.class_of_constr t with
-      | Some (_, (cl, _)) -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*)
+      | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true)
       | None -> None)
       params, params
   in
   let k =
     { cl_impl = impl;
+      cl_strict = !typeclasses_strict;
+      cl_unique = !typeclasses_unique;
       cl_context = ctx_context;
       cl_props = fields;
       cl_projs = projs }
   in
-(*     list_iter3 (fun p sub pri -> *)
-(*       if sub then match p with (_, _, Some p) -> declare_instance_cst true p pri | _ -> ()) *)
-(*       k.cl_projs coers priorities; *)
-  add_class k; impl
+    add_class k; impl
+
+
+let add_constant_class cst =
+  let ty = Universes.unsafe_type_of_global (ConstRef cst) in
+  let ctx, arity = decompose_prod_assum ty in
+  let tc = 
+    { cl_impl = ConstRef cst;
+      cl_context = (List.map (const None) ctx, ctx);
+      cl_props = [(Anonymous, None, arity)];
+      cl_projs = [];
+      cl_strict = !typeclasses_strict;
+      cl_unique = !typeclasses_unique
+    }
+  in add_class tc;
+    set_typeclass_transparency (EvalConstRef cst) false false
+      
+let add_inductive_class ind =
+  let mind, oneind = Global.lookup_inductive ind in
+  let k =
+    let ctx = oneind.mind_arity_ctxt in
+    let inst = Univ.UContext.instance mind.mind_universes in
+    let ty = Inductive.type_of_inductive_knowing_parameters
+      (push_rel_context ctx (Global.env ()))
+      ((mind,oneind),inst)
+      (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx))
+    in
+      { cl_impl = IndRef ind;
+	cl_context = List.map (const None) ctx, ctx;
+	cl_props = [Anonymous, None, ty];
+	cl_projs = [];
+	cl_strict = !typeclasses_strict;
+	cl_unique = !typeclasses_unique }
+  in add_class k
 
-let interp_and_check_sort sort =
-  Option.map (fun sort ->
-    let env = Global.env() and sigma = Evd.empty in
-    let s = interp_constr sigma env sort in
-    if isSort (Reductionops.whd_betadeltaiota env sigma s) then s
-    else user_err_loc (constr_loc sort,"", str"Sort expected.")) sort
+let declare_existing_class g =
+  match g with
+  | ConstRef x -> add_constant_class x
+  | IndRef x -> add_inductive_class x
+  | _ -> user_err_loc (Loc.dummy_loc, "declare_existing_class", 
+		      Pp.str"Unsupported class type, only constants and inductives are allowed")
 
 open Vernacexpr
-open Autoinstance
 
 (* [fs] corresponds to fields and [ps] to parameters; [coers] is a
    list telling if the corresponding fields must me declared as coercions 
    or subinstances *)
-let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
+let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) =
   let cfs,notations = List.split cfs in
   let cfs,priorities = List.split cfs in
   let coers,fs = List.split cfs in
@@ -392,26 +506,26 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil
     | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc
     | _ -> acc in
   let allnames =  idstruc::(List.fold_left extract_name [] fs) in
-  if not (list_distinct allnames) then error "Two objects have the same name";
-  if not (kind = Class false) && List.exists ((<>) None) priorities then
+  if not (List.distinct_f Id.compare allnames)
+  then error "Two objects have the same name";
+  let isnot_class = match kind with Class false -> false | _ -> true in
+  if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then
     error "Priorities only allowed for type class substructures";
   (* Now, younger decl in params and fields is on top *)
-  let sc = interp_and_check_sort s in
-  let implpars, params, implfs, fields =
+  let ctx, arity, template, implpars, params, implfs, fields =
     States.with_state_protection (fun () ->
-      typecheck_params_and_fields idstruc sc ps notations fs) () in
+      typecheck_params_and_fields (kind = Class true) idstruc s ps notations fs) () in
   let sign = structure_signature (fields@params) in
     match kind with
     | Class def ->
-	let gr = declare_class finite def infer (loc,idstruc) idbuild
-	  implpars params sc implfs fields is_coe coers priorities sign in
-	if infer then search_record declare_class_instance gr sign;
+	let gr = declare_class finite def poly ctx (loc,idstruc) idbuild
+	  implpars params arity template implfs fields is_coe coers priorities sign in
 	gr
     | _ ->
-	let arity = Option.default (Termops.new_Type ()) sc in
 	let implfs = List.map
-	  (fun impls -> implpars @ Impargs.lift_implicits (succ (List.length params)) impls) implfs in
-	let ind = declare_structure finite infer idstruc idbuild implpars params arity implfs 
-	  fields is_coe (List.map (fun coe -> coe <> None) coers) sign in
-	if infer then search_record declare_record_instance (ConstructRef (ind,1)) sign;
+	  (fun impls -> implpars @ Impargs.lift_implicits
+	    (succ (List.length params)) impls) implfs in
+	let ind = declare_structure finite poly ctx idstruc 
+	  idbuild implpars params arity template implfs 
+	  fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in
 	IndRef ind
diff --git a/toplevel/record.mli b/toplevel/record.mli
index 721d0d97..91dccb96 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.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,32 +8,38 @@
 
 open Names
 open Term
-open Sign
+open Context
 open Vernacexpr
-open Topconstr
+open Constrexpr
 open Impargs
-open Libnames
+open Globnames
+
+val primitive_flag : bool ref
 
 (** [declare_projections ref name coers params fields] declare projections of
    record [ref] (if allowed) using the given [name] as argument, and put them
    as coercions accordingly to [coers]; it returns the absolute names of projections *)
 
 val declare_projections :
-  inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
+  inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t ->
   coercion_flag list -> manual_explicitation list list -> rel_context ->
-  (name * bool) list * constant option list
+  (Name.t * bool) list * constant option list
 
 val declare_structure : Decl_kinds.recursivity_kind ->
-  bool (**infer?*) -> identifier -> identifier ->
+  bool (** polymorphic?*) -> Univ.universe_context ->
+  Id.t -> Id.t ->
   manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *)
+  bool (** template arity ? *) ->
   Impargs.manual_explicitation list list -> rel_context -> (** fields *)
-  ?kind:Decl_kinds.definition_object_kind -> ?name:identifier ->
+  ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t ->
   bool -> (** coercion? *)
   bool list -> (** field coercions *)
   Evd.evar_map ->
   inductive
 
 val definition_structure :
-  inductive_kind * Decl_kinds.recursivity_kind * bool(**infer?*)* lident with_coercion * local_binder list *
+  inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * lident with_coercion * local_binder list *
   (local_decl_expr with_instance with_priority with_notation) list *
-  identifier * constr_expr option -> global_reference
+  Id.t * constr_expr option -> global_reference
+
+val declare_existing_class : global_reference -> unit
diff --git a/toplevel/search.ml b/toplevel/search.ml
index 28c14a77..59283edf 100644
--- a/toplevel/search.ml
+++ b/toplevel/search.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        *)
@@ -9,19 +9,23 @@
 open Pp
 open Util
 open Names
-open Nameops
 open Term
-open Glob_term
 open Declarations
 open Libobject
-open Declare
 open Environ
 open Pattern
-open Matching
 open Printer
 open Libnames
+open Globnames
 open Nametab
 
+type filter_function = global_reference -> env -> constr -> bool
+type display_function = global_reference -> env -> constr -> unit
+
+type glob_search_about_item =
+  | GlobSearchSubPattern of constr_pattern
+  | GlobSearchString of string
+
 module SearchBlacklist =
   Goptions.MakeStringTable
     (struct
@@ -32,215 +36,302 @@ module SearchBlacklist =
       let synchronous = true
      end)
 
-(* The functions print_constructors and crible implement the behavior needed
-   for the Coq searching commands.
+(* The functions iter_constructors and iter_declarations implement the behavior
+   needed for the Coq searching commands.
    These functions take as first argument the procedure
    that will be called to treat each entry.  This procedure receives the name
    of the object, the assumptions that will make it possible to print its type,
    and the constr term that represent its type. *)
 
-let print_constructors indsp fn env nconstr =
+let iter_constructors indsp u fn env nconstr =
   for i = 1 to nconstr do
-    fn (ConstructRef (indsp,i)) env (Inductiveops.type_of_constructor env (indsp,i))
+    let typ = Inductiveops.type_of_constructor env ((indsp, i), u) in
+    fn (ConstructRef (indsp, i)) env typ
   done
 
-let rec head_const c = match kind_of_term c with
-  | Prod (_,_,d) -> head_const d
-  | LetIn (_,_,_,d) -> head_const d
-  | App (f,_)   -> head_const f
-  | Cast (d,_,_)   -> head_const d
-  | _            -> c
+let iter_named_context_name_type f = List.iter (fun (nme,_,typ) -> f nme typ) 
 
-(* General search, restricted to head constant if [only_head] *)
+(* General search over hypothesis of a goal *)
+let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) =
+  let env = Global.env () in
+  let iter_hyp idh typ = fn (VarRef idh) env typ in
+  let evmap,e = Pfedit.get_goal_context glnum in
+  let pfctxt = named_context e in
+  iter_named_context_name_type iter_hyp pfctxt
 
-let gen_crible refopt (fn : global_reference -> env -> constr -> unit) =
+(* General search over declarations *)
+let iter_declarations (fn : global_reference -> env -> constr -> unit) =
   let env = Global.env () in
-  let crible_rec (sp,kn) lobj = match object_tag lobj with
-    | "VARIABLE" ->
-	(try
-	   let (id,_,typ) = Global.lookup_named (basename sp) in
-           if refopt = None
-	     || head_const typ = constr_of_global (Option.get refopt)
-	   then
-	     fn (VarRef id) env typ
-	 with Not_found -> (* we are in a section *) ())
-    | "CONSTANT" ->
-	let cst = Global.constant_of_delta_kn kn in
-	let typ = Typeops.type_of_constant env cst in
-        if refopt = None
-	  || head_const typ = constr_of_global (Option.get refopt)
-	then
-	  fn (ConstRef cst) env typ
-    | "INDUCTIVE" ->
-	let mind = Global.mind_of_delta_kn kn in
-        let mib = Global.lookup_mind mind in
-        (match refopt with
-	  | Some (IndRef ((kn',tyi) as ind)) when eq_mind mind kn' ->
-	      print_constructors ind fn env
-	        (Array.length (mib.mind_packets.(tyi).mind_user_lc))
-          | Some _ -> ()
-	  | _ ->
-              Array.iteri
-	        (fun i mip -> print_constructors (mind,i) fn env
-	          (Array.length mip.mind_user_lc)) mib.mind_packets)
-    | _ -> ()
+  let iter_obj (sp, kn) lobj = match object_tag lobj with
+  | "VARIABLE" ->
+    begin try
+      let (id, _, typ) = Global.lookup_named (basename sp) in
+      fn (VarRef id) env typ
+    with Not_found -> (* we are in a section *) () end
+  | "CONSTANT" ->
+    let cst = Global.constant_of_delta_kn kn in
+    let gr = ConstRef cst in
+    let typ = Global.type_of_global_unsafe gr in
+      fn gr env typ
+  | "INDUCTIVE" ->
+    let mind = Global.mind_of_delta_kn kn in
+    let mib = Global.lookup_mind mind in
+    let iter_packet i mip =
+      let ind = (mind, i) in
+      let u = Declareops.inductive_instance mib in
+      let i = (ind, u) in
+      let typ = Inductiveops.type_of_inductive env i in
+      let () = fn (IndRef ind) env typ in
+      let len = Array.length mip.mind_user_lc in
+      iter_constructors ind u fn env len
+    in
+    Array.iteri iter_packet mib.mind_packets
+  | _ -> ()
   in
-  try
-    Declaremods.iter_all_segments crible_rec
-  with Not_found ->
-    ()
-
-let crible ref = gen_crible (Some ref)
-
-(* Fine Search. By Yves Bertot. *)
+  try Declaremods.iter_all_segments iter_obj
+  with Not_found -> ()
 
-exception No_full_path
+let generic_search glnumopt fn =
+  (match glnumopt with
+  | None -> ()
+  | Some glnum ->  iter_hypothesis glnum fn);
+  iter_declarations fn
 
-let rec head c =
-  let c = strip_outer_cast c in
-  match kind_of_term c with
-  | Prod (_,_,c) -> head c
-  | LetIn (_,_,_,c) -> head c
-  | _              -> c
+(** Standard display *)
 
-let xor a b = (a or b) & (not (a & b))
-
-let plain_display ref a c =
-  let pc = pr_lconstr_env a c in
+let plain_display accu ref env c =
+  let pc = pr_lconstr_env env Evd.empty c in
   let pr = pr_global ref in
-  msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ())
-
-let filter_by_module (module_list:dir_path list) (accept:bool)
-  (ref:global_reference) _ _ =
-  try
-    let sp = path_of_global ref in
-    let sl = dirpath sp in
-    let rec filter_aux = function
-      | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl)
-      | [] -> true
-    in
-    xor accept (filter_aux module_list)
-  with No_full_path ->
-    false
-
-let ref_eq = Libnames.encode_mind Coqlib.logic_module (id_of_string "eq"), 0
-let c_eq = mkInd ref_eq
-let gref_eq = IndRef ref_eq
-
-let mk_rewrite_pattern1 eq pattern =
-  PApp (PRef eq, [| PMeta None; pattern; PMeta None |])
-
-let mk_rewrite_pattern2 eq pattern =
-  PApp (PRef eq, [| PMeta None; PMeta None; pattern |])
-
-let pattern_filter pat _ a c =
-  try
-    try
-      is_matching pat (head c)
-    with e when Errors.noncritical e ->
-      is_matching
-	pat (head (Typing.type_of (Global.env()) Evd.empty c))
-    with UserError _ ->
-      false
-
-let filtered_search filter_function display_function ref =
-  crible ref
-    (fun s a c -> if filter_function s a c then display_function s a c)
-
-let rec id_from_pattern = function
-  | PRef gr -> gr
-(* should be appear as a PRef (VarRef sp) !!
-  | PVar id -> Nametab.locate (make_qualid [] (string_of_id id))
- *)
-  | PApp (p,_) -> id_from_pattern p
-  | _ -> error "The pattern is not simple enough."
-
-let raw_pattern_search extra_filter display_function pat =
-  let name = id_from_pattern pat in
-  filtered_search
-    (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c)
-    display_function name
-
-let raw_search_rewrite extra_filter display_function pattern =
-  filtered_search
-    (fun s a c ->
-       ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) ||
-        (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c))
-       && extra_filter s a c)
-    display_function gref_eq
-
-let raw_search_by_head extra_filter display_function pattern =
-  Util.todo "raw_search_by_head"
-
-let name_of_reference ref = string_of_id (basename_of_global ref)
+  accu := hov 2 (pr ++ str":" ++ spc () ++ pc) :: !accu
+
+let format_display l = prlist_with_sep fnl (fun x -> x) (List.rev l)
+
+(** Filters *)
+
+(** This function tries to see whether the conclusion matches a pattern. *)
+(** FIXME: this is quite dummy, we may find a more efficient algorithm. *)
+let rec pattern_filter pat ref env typ =
+  let typ = strip_outer_cast typ in
+  if Constr_matching.is_matching env Evd.empty pat typ then true
+  else match kind_of_term typ with
+  | Prod (_, _, typ)
+  | LetIn (_, _, _, typ) -> pattern_filter pat ref env typ
+  | _ -> false
+
+let rec head_filter pat ref env typ =
+  let typ = strip_outer_cast typ in
+  if Constr_matching.is_matching_head env Evd.empty pat typ then true
+  else match kind_of_term typ with
+  | Prod (_, _, typ)
+  | LetIn (_, _, _, typ) -> head_filter pat ref env typ
+  | _ -> false
 
 let full_name_of_reference ref =
   let (dir,id) = repr_path (path_of_global ref) in
-  string_of_dirpath dir ^ "." ^ string_of_id id
-
-(*
- * functions to use the new Libtypes facility
- *)
+  DirPath.to_string dir ^ "." ^ Id.to_string id
 
-let raw_search search_function extra_filter display_function pat =
-  let env = Global.env() in
-  List.iter
-    (fun (gr,_,_) ->
-       let typ = Global.type_of_global gr in
-       if extra_filter gr env typ then
-	 display_function gr env typ
-    ) (search_function pat)
-
-let text_pattern_search extra_filter =
-  raw_search Libtypes.search_concl extra_filter plain_display
-
-let text_search_rewrite extra_filter =
-  raw_search (Libtypes.search_eq_concl c_eq) extra_filter plain_display
-
-let text_search_by_head extra_filter =
-  raw_search Libtypes.search_head_concl extra_filter plain_display
-
-let filter_by_module_from_list = function
-  | [], _ -> (fun _ _ _ -> true)
-  | l, outside -> filter_by_module l (not outside)
-
-let filter_blacklist gr _ _ =
-  let name = full_name_of_reference gr in
+(** Whether a reference is blacklisted *)
+let blacklist_filter ref env typ =
   let l = SearchBlacklist.elements () in
-  List.for_all (fun str -> not (string_string_contains ~where:name ~what:str)) l
+  let name = full_name_of_reference ref in
+  let is_not_bl str = not (String.string_contains ~where:name ~what:str) in
+  List.for_all is_not_bl l
+
+let module_filter (mods, outside) ref env typ =
+  let sp = path_of_global ref in
+  let sl = dirpath sp in
+  let is_outside md = not (is_dirpath_prefix_of md sl) in
+  let is_inside md = is_dirpath_prefix_of md sl in
+  if outside then List.for_all is_outside mods
+  else List.is_empty mods || List.exists is_inside mods
+
+let name_of_reference ref = Id.to_string (basename_of_global ref)
+
+let search_about_filter query gr env typ = match query with
+| GlobSearchSubPattern pat ->
+  Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat typ
+| GlobSearchString s ->
+  String.string_contains ~where:(name_of_reference gr) ~what:s
+
+
+(** SearchPattern *)
+
+let search_pattern gopt pat mods =
+  let ans = ref [] in
+  let filter ref env typ =
+    let f_module = module_filter mods ref env typ in
+    let f_blacklist = blacklist_filter ref env typ in
+    let f_pattern () = pattern_filter pat ref env typ in
+    f_module && f_pattern () && f_blacklist
+  in
+  let iter ref env typ =
+    if filter ref env typ then plain_display ans ref env typ
+  in
+  let () = generic_search gopt iter in
+  format_display !ans
 
-let (&&&&&) f g x y z = f x y z && g x y z
+(** SearchRewrite *)
 
-let search_by_head pat inout =
-  text_search_by_head (filter_by_module_from_list inout &&&&& filter_blacklist) pat
+let eq = Coqlib.glob_eq
 
-let search_rewrite pat inout =
-  text_search_rewrite (filter_by_module_from_list inout &&&&& filter_blacklist) pat
+let rewrite_pat1 pat =
+  PApp (PRef eq, [| PMeta None; pat; PMeta None |])
 
-let search_pattern pat inout =
-  text_pattern_search (filter_by_module_from_list inout &&&&& filter_blacklist) pat
+let rewrite_pat2 pat =
+  PApp (PRef eq, [| PMeta None; PMeta None; pat |])
 
-let gen_filtered_search filter_function display_function =
-  gen_crible None
-    (fun s a c -> if filter_function s a c then display_function s a c)
+let search_rewrite gopt pat mods =
+  let pat1 = rewrite_pat1 pat in
+  let pat2 = rewrite_pat2 pat in
+  let ans = ref [] in
+  let filter ref env typ =
+    let f_module = module_filter mods ref env typ in
+    let f_blacklist = blacklist_filter ref env typ in
+    let f_pattern () =
+      pattern_filter pat1 ref env typ ||
+      pattern_filter pat2 ref env typ
+    in
+    f_module && f_pattern () && f_blacklist
+  in
+  let iter ref env typ =
+    if filter ref env typ then plain_display ans ref env typ
+  in
+  let () = generic_search gopt iter in
+  format_display !ans
+
+(** Search *)
+
+let search_by_head gopt pat mods =
+  let ans = ref [] in
+  let filter ref env typ =
+    let f_module = module_filter mods ref env typ in
+    let f_blacklist = blacklist_filter ref env typ in
+    let f_pattern () = head_filter pat ref env typ in
+    f_module && f_pattern () && f_blacklist
+  in
+  let iter ref env typ =
+    if filter ref env typ then plain_display ans ref env typ
+  in
+  let () = generic_search gopt iter in
+  format_display !ans
 
 (** SearchAbout *)
 
-type glob_search_about_item =
-  | GlobSearchSubPattern of constr_pattern
-  | GlobSearchString of string
-
-let search_about_item (itemref,typ) = function
-  | GlobSearchSubPattern pat -> is_matching_appsubterm ~closed:false pat typ
-  | GlobSearchString s -> string_string_contains ~where:(name_of_reference itemref) ~what:s
-
-let raw_search_about filter_modules display_function l =
-  let filter ref' env typ =
-    filter_modules ref' env typ &&
-    List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l &&
-      filter_blacklist ref' () ()
+let search_about gopt items mods =
+  let ans = ref [] in
+  let filter ref env typ =
+    let eqb b1 b2 = if b1 then b2 else not b2 in
+    let f_module = module_filter mods ref env typ in
+    let f_about (b, i) = eqb b (search_about_filter i ref env typ) in
+    let f_blacklist = blacklist_filter ref env typ in
+    f_module && List.for_all f_about items && f_blacklist
   in
-  gen_filtered_search filter display_function
-
-let search_about ref inout =
-  raw_search_about (filter_by_module_from_list inout) plain_display ref
+  let iter ref env typ =
+    if filter ref env typ then plain_display ans ref env typ
+  in
+  let () = generic_search gopt iter in
+  format_display !ans
+
+type search_constraint =
+  | Name_Pattern of string
+  | Type_Pattern of string
+  | SubType_Pattern of string
+  | In_Module of string list
+  | Include_Blacklist
+
+type 'a coq_object = {
+  coq_object_prefix : string list;
+  coq_object_qualid : string list;
+  coq_object_object : 'a;
+}
+
+let interface_search flags =
+  let env = Global.env () in
+  let rec extract_flags name tpe subtpe mods blacklist = function
+  | [] -> (name, tpe, subtpe, mods, blacklist)
+  | (Name_Pattern s, b) :: l ->
+    let regexp =
+      try Str.regexp s
+      with e when Errors.noncritical e ->
+        Errors.error ("Invalid regexp: " ^ s)
+    in
+    extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
+  | (Type_Pattern s, b) :: l ->
+    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+    let (_, pat) = Constrintern.intern_constr_pattern env constr in
+    extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
+  | (SubType_Pattern s, b) :: l ->
+    let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
+    let (_, pat) = Constrintern.intern_constr_pattern env constr in
+    extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
+  | (In_Module m, b) :: l ->
+    let path = String.concat "." m in
+    let m = Pcoq.parse_string Pcoq.Constr.global path in
+    let (_, qid) = Libnames.qualid_of_reference m in
+    let id =
+      try Nametab.full_name_module qid
+      with Not_found ->
+        Errors.error ("Module " ^ path ^ " not found.")
+    in
+    extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
+  | (Include_Blacklist, b) :: l ->
+    extract_flags name tpe subtpe mods b l
+  in
+  let (name, tpe, subtpe, mods, blacklist) =
+    extract_flags [] [] [] [] false flags
+  in
+  let filter_function ref env constr =
+    let id = Names.Id.to_string (Nametab.basename_of_global ref) in
+    let path = Libnames.dirpath (Nametab.path_of_global ref) in
+    let toggle x b = if x then b else not b in
+    let match_name (regexp, flag) =
+      toggle (Str.string_match regexp id 0) flag
+    in
+    let match_type (pat, flag) =
+      toggle (Constr_matching.is_matching env Evd.empty pat constr) flag
+    in
+    let match_subtype (pat, flag) =
+      toggle
+        (Constr_matching.is_matching_appsubterm ~closed:false 
+	   env Evd.empty pat constr) flag
+    in
+    let match_module (mdl, flag) =
+      toggle (Libnames.is_dirpath_prefix_of mdl path) flag
+    in
+    let in_blacklist =
+      blacklist || (blacklist_filter ref env constr)
+    in
+    List.for_all match_name name &&
+    List.for_all match_type tpe &&
+    List.for_all match_subtype subtpe &&
+    List.for_all match_module mods && in_blacklist
+  in
+  let ans = ref [] in
+  let print_function ref env constr =
+    let fullpath = DirPath.repr (Nametab.dirpath_of_global ref) in
+    let qualid = Nametab.shortest_qualid_of_global Id.Set.empty ref in
+    let (shortpath, basename) = Libnames.repr_qualid qualid in
+    let shortpath = DirPath.repr shortpath in
+    (* [shortpath] is a suffix of [fullpath] and we're looking for the missing
+       prefix *)
+    let rec prefix full short accu = match full, short with
+    | _, [] ->
+      let full = List.rev_map Id.to_string full in
+      (full, accu)
+    | _ :: full, m :: short ->
+      prefix full short (Id.to_string m :: accu)
+    | _ -> assert false
+    in
+    let (prefix, qualid) = prefix fullpath shortpath [Id.to_string basename] in
+    let answer = {
+      coq_object_prefix = prefix;
+      coq_object_qualid = qualid;
+      coq_object_object = string_of_ppcmds (pr_lconstr_env env Evd.empty constr);
+    } in
+    ans := answer :: !ans;
+  in
+  let iter ref env typ =
+    if filter_function ref env typ then print_function ref env typ
+  in
+  let () = generic_search None iter in (* TODO: chose a goal number? *)
+  !ans
diff --git a/toplevel/search.mli b/toplevel/search.mli
index b6cca47d..f69489c3 100644
--- a/toplevel/search.mli
+++ b/toplevel/search.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        *)
@@ -11,8 +11,7 @@ open Names
 open Term
 open Environ
 open Pattern
-open Libnames
-open Nametab
+open Globnames
 
 (** {6 Search facilities. } *)
 
@@ -20,33 +19,55 @@ type glob_search_about_item =
   | GlobSearchSubPattern of constr_pattern
   | GlobSearchString of string
 
-val search_by_head : constr -> dir_path list * bool -> unit
-val search_rewrite : constr -> dir_path list * bool -> unit
-val search_pattern : constr -> dir_path list * bool -> unit
-val search_about  :
-  (bool * glob_search_about_item) list -> dir_path list * bool -> unit
-
-(** The filtering function that is by standard search facilities.
-   It can be passed as argument to the raw search functions.
-   It is used in pcoq. *)
-
-val filter_by_module_from_list :
-  dir_path list * bool -> global_reference -> env -> 'a -> bool
-
-val filter_blacklist : global_reference -> env -> constr -> bool
-
-(** raw search functions can be used for various extensions.
-   They are also used for pcoq. *)
-val gen_filtered_search : (global_reference -> env -> constr -> bool) ->
-      (global_reference -> env -> constr -> unit) -> unit
-val filtered_search : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) -> global_reference -> unit
-val raw_pattern_search : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
-val raw_search_rewrite : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
-val raw_search_about : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) ->
-      (bool * glob_search_about_item) list -> unit
-val raw_search_by_head : (global_reference -> env -> constr -> bool) ->
-  (global_reference -> env -> constr -> unit) -> constr_pattern -> unit
+type filter_function = global_reference -> env -> constr -> bool
+type display_function = global_reference -> env -> constr -> unit
+
+(** {6 Generic filter functions} *)
+
+val blacklist_filter : filter_function
+(** Check whether a reference is blacklisted. *)
+
+val module_filter : DirPath.t list * bool -> filter_function
+(** Check whether a reference pertains or not to a set of modules *)
+
+val search_about_filter : glob_search_about_item -> filter_function
+(** Check whether a reference matches a SearchAbout query. *)
+
+(** {6 Specialized search functions}
+
+[search_xxx gl pattern modinout] searches the hypothesis of the [gl]th
+goal and the global environment for things matching [pattern] and
+satisfying module exclude/include clauses of [modinout]. *)
+
+val search_by_head : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds
+val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds
+val search_pattern : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds
+val search_about   : int option -> (bool * glob_search_about_item) list
+  -> DirPath.t list * bool -> std_ppcmds
+
+type search_constraint =
+  (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
+  | Name_Pattern of string
+  (** Whether the object type satisfies a pattern *)
+  | Type_Pattern of string
+  (** Whether some subtype of object type satisfies a pattern *)
+  | SubType_Pattern of string
+  (** Whether the object pertains to a module *)
+  | In_Module of string list
+  (** Bypass the Search blacklist *)
+  | Include_Blacklist
+
+type 'a coq_object = {
+  coq_object_prefix : string list;
+  coq_object_qualid : string list;
+  coq_object_object : 'a;
+}
+
+val interface_search : (search_constraint * bool) list ->
+  string coq_object list
+
+(** {6 Generic search function} *)
+
+val generic_search : int option -> display_function -> unit
+(** This function iterates over all hypothesis of the goal numbered
+    [glnum] (if present) and all known declarations. *)
diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib
index e1e349a6..d22524e5 100644
--- a/toplevel/toplevel.mllib
+++ b/toplevel/toplevel.mllib
@@ -1,27 +1,21 @@
 Himsg
 Cerrors
 Class
-Vernacexpr
+Locality
 Metasyntax
 Auto_ind_decl
-Libtypes
 Search
-Autoinstance
-Lemmas
 Indschemes
+Obligations
 Command
 Classes
 Record
-Ppvernac
-Backtrack
 Vernacinterp
 Mltop
 Vernacentries
 Whelp
 Vernac
-Ide_intf
-Ide_slave
-Toplevel
 Usage
+Coqloop
 Coqinit
 Coqtop
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index 52bd2d33..d4d44569 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.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        *)
@@ -14,23 +14,25 @@ let version ret =
 
 (* print the usage of coqtop (or coqc) on channel co *)
 
+let extra_usage = ref []
+let add_to_usage name text = extra_usage := (name,text) :: !extra_usage
+
 let print_usage_channel co command =
   output_string co command;
   output_string co "Coq options are:\n";
   output_string co
-"  -I dir -as coqdir      map physical dir to logical coqdir\
-\n  -I dir                 map directory dir to the empty logical path\
+"  -I dir                 look for ML files in dir\
 \n  -include dir           (idem)\
+\n  -I dir -as coqdir      implicitly map physical dir to logical coqdir\
 \n  -R dir -as coqdir      recursively map physical dir to logical coqdir\
 \n  -R dir coqdir          (idem)\
+\n  -Q dir coqdir          map physical dir to logical coqdir\
 \n  -top coqdir            set the toplevel name to be coqdir instead of Top\
 \n  -notop                 set the toplevel name to be the empty logical path\
 \n  -exclude-dir f         exclude subdirectories named f for option -R\
 \n\
-\n  -inputstate f          read state from file f.coq\
-\n  -is f                  (idem)\
-\n  -nois                  start with an empty state\
-\n  -outputstate f         write state in file f.coq\
+\n  -noinit                start without loading the Init library\
+\n  -nois                  (idem)\
 \n  -compat X.Y            provides compatibility support for Coq version X.Y\
 \n  -verbose-compat-notations  be warned when using compatibility notations\
 \n  -no-compat-notations   get an error when using compatibility notations\
@@ -46,47 +48,54 @@ let print_usage_channel co command =
 \n  -compile f             compile Coq file f.v (implies -batch)\
 \n  -compile-verbose f     verbosely compile Coq file f.v (implies -batch)\
 \n\
-\n  -opt                   run the native-code version of Coq\
-\n  -byte                  run the bytecode version of Coq\
-\n\
 \n  -where                 print Coq's standard library location and exit\
 \n  -config                print Coq's configuration information and exit\
 \n  -v                     print Coq version and exit\
+\n  -list-tags             print highlight color tags known by Coq and exit\
 \n\
 \n  -q                     skip loading of rcfile\
 \n  -init-file f           set the rcfile to f\
 \n  -batch                 batch mode (exits just after arguments parsing)\
 \n  -boot                  boot mode (implies -q and -batch)\
+\n  -bt                    print backtraces (requires configure debug flag)\
+\n  -debug                 debug mode (implies -bt)\
 \n  -emacs                 tells Coq it is executed under Emacs\
+\n  -color (on|off|auto)   configure color output (only active through coqtop)\
 \n  -noglob                do not dump globalizations\
 \n  -dump-glob f           dump globalizations in file f (to be used by coqdoc)\
 \n  -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\
 \n  -impredicative-set     set sort Set impredicative\
-\n  -force-load-proofs     load opaque proofs in memory initially\
-
-\n  -lazy-load-proofs      load opaque proofs in memory by necessity (default)\
-\n  -dont-load-proofs      see opaque proofs as axioms instead of loading them\
-\n  -xml                   export XML files either to the hierarchy rooted in\
-\n                         the directory $COQ_XML_LIBRARY_ROOT (if set) or to\
-\n                         stdout (if unset)\
-\n  -quality               improve the legibility of the proof terms produced by\
-\n                         some tactics\
-\n  -h, --help             print this list of options\
-\n"
+\n  -indices-matter        levels of indices (and nonuniform parameters) contribute to the level of inductives\
+\n  -time                  display the time taken by each command\
+\n  -no-native-compiler    disable the native_compute reduction machinery\
+\n  -h, -help              print this list of options\
+\n";
+  List.iter (fun (name, text) ->
+    output_string co
+     ("\nWith the flag '-toploop "^name^
+        "' these extra option are also available:\n"^
+      text^"\n"))
+    !extra_usage
 
 (* print the usage on standard error *)
 
 let print_usage = print_usage_channel stderr
 
 let print_usage_coqtop () =
-  print_usage "Usage: coqtop <options>\n\n"
+  print_usage "Usage: coqtop <options>\n\n";
+  flush stderr ;
+  exit 1
 
 let print_usage_coqc () =
   print_usage "Usage: coqc <options> <Coq options> file...\n\
 \noptions are:\
 \n  -verbose  compile verbosely\
 \n  -image f  specify an alternative executable for Coq\
-\n  -t        keep temporary files\n\n"
+\n  -opt      run the native-code version of Coq\
+\n  -byte     run the bytecode version of Coq\
+\n  -t        keep temporary files\n\n";
+  flush stderr ;
+  exit 1
 
 (* Print the configuration information *)
 
@@ -101,6 +110,8 @@ let print_config () =
   Printf.printf "CAMLBIN=%s/\n" (Envars.camlbin ());
   Printf.printf "CAMLLIB=%s/\n" (Envars.camllib ());
   Printf.printf "CAMLP4=%s\n" Coq_config.camlp4;
+  Printf.printf "CAMLP4O=%s\n" Coq_config.camlp4o;
   Printf.printf "CAMLP4BIN=%s/\n" (Envars.camlp4bin ());
   Printf.printf "CAMLP4LIB=%s\n" (Envars.camlp4lib ());
+  Printf.printf "CAMLP4OPTIONS=%s\n" Coq_config.camlp4compat;
   Printf.printf "HASNATDYNLINK=%s\n" (if Coq_config.has_natdynlink then "true" else "false")
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index c3533b95..ed0cd477 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.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        *)
@@ -13,6 +13,9 @@ val version : int -> 'a
 (** {6 Prints the usage on the error output, preceeded by a user-provided message. } *)
 val print_usage : string -> unit
 
+(** {6 Enable toploop plugins to insert some text in the usage message. } *)
+val add_to_usage : string -> string -> unit
+
 (** {6 Prints the usage on the error output. } *)
 val print_usage_coqtop : unit -> unit
 val print_usage_coqc : unit -> unit
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index cb90909e..176a6c33 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.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        *)
@@ -9,22 +9,38 @@
 (* Parsing of vernacular. *)
 
 open Pp
-open Lexer
+open Errors
 open Util
 open Flags
 open System
 open Vernacexpr
-open Vernacinterp
-open Ppvernac
-open Compat
 
 (* The functions in this module may raise (unexplainable!) exceptions.
    Use the module Coqtoplevel, which catches these exceptions
    (the exceptions are explained only at the toplevel). *)
 
-exception DuringCommandInterp of Util.loc * exn
+(* The navigation vernac commands will be handled separately *)
 
-exception HasNotFailed
+let rec is_navigation_vernac = function
+  | VernacResetInitial
+  | VernacResetName _
+  | VernacBacktrack _
+  | VernacBackTo _
+  | VernacBack _ -> true
+  | VernacTime l ->
+    List.exists
+      (fun (_,c) -> is_navigation_vernac c) l (* Time Back* is harmless *)
+  | c -> is_deep_navigation_vernac c
+
+and is_deep_navigation_vernac = function
+  | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c
+  | _ -> false
+
+(* NB: Reset is now allowed again as asked by A. Chlipala *)
+
+let is_reset = function
+  | VernacResetInitial | VernacResetName _ -> true
+  | _ -> false
 
 (* When doing Load on a file, two behaviors are possible:
 
@@ -50,85 +66,35 @@ let _ =
       Goptions.optread  = (fun () -> !atomic_load);
       Goptions.optwrite = ((:=) atomic_load) }
 
-(* Specifies which file is read. The intermediate file names are
-   discarded here. The Drop exception becomes an error. We forget
-   if the error ocurred during interpretation or not *)
-
-let raise_with_file file exc =
-  let (cmdloc,re) =
-    match exc with
-      | DuringCommandInterp(loc,e) -> (loc,e)
-      | e -> (dummy_loc,e)
-  in
-  let (inner,inex) =
-    match re with
-      | Error_in_file (_, (b,f,loc), e) when loc <> dummy_loc ->
-          ((b, f, loc), e)
-      | Loc.Exc_located (loc, e) when loc <> dummy_loc ->
-          ((false,file, loc), e)
-      | Loc.Exc_located (_, e) | e -> ((false,file,cmdloc), e)
-  in
-  raise (Error_in_file (file, inner, disable_drop inex))
-
-let real_error = function
-  | Loc.Exc_located (_, e) -> e
-  | Error_in_file (_, _, e) -> e
-  | e -> e
-
-let user_error loc s = Util.user_err_loc (loc,"_",str s)
+(* In case of error, register the file being currently Load'ed and the
+   inner file in which the error has been encountered. Any intermediate files
+   between the two are discarded. *)
 
-(** Timeout handling *)
+type location_files = { outer : string; inner : string }
 
-(** A global default timeout, controled by option "Set Default Timeout n".
-    Use "Unset Default Timeout" to deactivate it (or set it to 0). *)
+let files_of_exn : location_files Exninfo.t = Exninfo.make ()
 
-let default_timeout = ref None
+let get_exn_files e = Exninfo.get e files_of_exn
 
-let _ =
-  Goptions.declare_int_option
-    { Goptions.optsync  = true;
-      Goptions.optdepr  = false;
-      Goptions.optname  = "the default timeout";
-      Goptions.optkey   = ["Default";"Timeout"];
-      Goptions.optread  = (fun () -> !default_timeout);
-      Goptions.optwrite = ((:=) default_timeout) }
-
-(** When interpreting a command, the current timeout is initially
-    the default one, but may be modified locally by a Timeout command. *)
-
-let current_timeout = ref None
+let add_exn_files e f = Exninfo.add e files_of_exn f
 
-(** Installing and de-installing a timer.
-    Note: according to ocaml documentation, Unix.alarm isn't available
-    for native win32. *)
+let raise_with_file f (e, info) =
+  let inner_f = match get_exn_files info with None -> f | Some ff -> ff.inner in
+  iraise (e, add_exn_files info { outer = f; inner = inner_f })
 
-let timeout_handler _ = raise Timeout
-
-let set_timeout n =
-  let psh =
-    Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in
-  ignore (Unix.alarm n);
-  Some psh
-
-let default_set_timeout () =
-  match !current_timeout with
-    | Some n -> set_timeout n
-    | None -> None
-
-let restore_timeout = function
-  | None -> ()
-  | Some psh ->
-    (* stop alarm *)
-    ignore(Unix.alarm 0);
-    (* restore handler *)
-    Sys.set_signal Sys.sigalrm psh
+let disable_drop = function
+  | Drop -> Errors.error "Drop is forbidden."
+  | e -> e
 
+let user_error loc s = Errors.user_err_loc (loc,"_",str s)
 
 (* Open an utf-8 encoded file and skip the byte-order mark if any *)
 
 let open_utf8_file_in fname =
   let is_bom s =
-    Char.code s.[0] = 0xEF && Char.code s.[1] = 0xBB && Char.code s.[2] = 0xBF
+    Int.equal (Char.code s.[0]) 0xEF &&
+    Int.equal (Char.code s.[1]) 0xBB &&
+    Int.equal (Char.code s.[2]) 0xBF
   in
   let in_chan = open_in fname in
   let s = "   " in
@@ -141,7 +107,7 @@ let open_utf8_file_in fname =
    the file we parse seems a bit risky to me.  B.B.  *)
 
 let open_file_twice_if verbosely fname =
-  let paths = Library.get_load_paths () in
+  let paths = Loadpath.get_paths () in
   let _,longfname =
     find_file_in_path ~warn:(Flags.is_verbose()) paths fname in
   let in_chan = open_utf8_file_in longfname in
@@ -159,23 +125,24 @@ let close_input in_chan (_,verb) =
   with e when Errors.noncritical e -> ()
 
 let verbose_phrase verbch loc =
-  let loc = unloc loc in
+  let loc = Loc.unloc loc in
   match verbch with
     | Some ch ->
 	let len = snd loc - fst loc in
 	let s = String.create len in
         seek_in ch (fst loc);
         really_input ch s 0 len;
-        message s;
+        ppnl (str s);
         pp_flush()
-    | _ -> ()
+    | None -> ()
 
 exception End_of_input
 
-let parse_sentence (po, verbch) =
+let parse_sentence = Flags.with_option Flags.we_are_parsing
+  (fun (po, verbch) ->
   match Pcoq.Gram.entry_parse Pcoq.main_entry po with
     | Some (loc,_ as com) -> verbose_phrase verbch loc; com
-    | None -> raise End_of_input
+    | None -> raise End_of_input)
 
 (* vernac parses the given stream, executes interpfun on the syntax tree it
  * parses, and is verbose on "primitives" commands if verbosely is true *)
@@ -191,120 +158,106 @@ let set_formatter_translator() =
   Format.set_max_boxes max_int
 
 let pr_new_syntax loc ocom =
-  let loc = unloc loc in
+  let loc = Loc.unloc loc in
   if !beautify_file then set_formatter_translator();
-  let fs = States.freeze () in
+  let fs = States.freeze ~marshallable:`No in
   let com = match ocom with
     | Some VernacNop -> mt()
-    | Some com -> pr_vernac com
+    | Some com -> Ppvernac.pr_vernac com
     | None -> mt() in
   if !beautify_file then
     msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc)))
   else
-    msgnl (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
+    msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com)));
   States.unfreeze fs;
   Format.set_formatter_out_channel stdout
 
-let rec vernac_com interpfun checknav (loc,com) =
-  let rec interp = function
-    | VernacLoad (verbosely, fname) ->
-	let fname = expand_path_macros fname in
-        (* translator state *)
-        let ch = !chan_beautify in
-        let cs = Lexer.com_state() in
-        let cl = !Pp.comments in
-        (* end translator state *)
-        (* coqdoc state *)
-        let cds = Dumpglob.coqdoc_freeze() in
-          if !Flags.beautify_file then
-	    begin
-              let _,f = find_file_in_path ~warn:(Flags.is_verbose())
-		(Library.get_load_paths ())
-		(make_suffix fname ".v") in
-		chan_beautify := open_out (f^beautify_suffix);
-		Pp.comments := []
-            end;
-          begin
-	    try
-	      read_vernac_file verbosely (make_suffix fname ".v");
-              if !Flags.beautify_file then close_out !chan_beautify;
-              chan_beautify := ch;
-              Lexer.restore_com_state cs;
-              Pp.comments := cl;
-              Dumpglob.coqdoc_unfreeze cds
-	    with reraise ->
-	      if !Flags.beautify_file then close_out !chan_beautify;
-              chan_beautify := ch;
-              Lexer.restore_com_state cs;
-              Pp.comments := cl;
-              Dumpglob.coqdoc_unfreeze cds;
-	      raise reraise
-	  end
-
-    | VernacList l -> List.iter (fun (_,v) -> interp v) l
-
-    | v when !just_parsing -> ()
+let save_translator_coqdoc () =
+  (* translator state *)
+  let ch = !chan_beautify in
+  let cl = !Pp.comments in
+  let cs = Lexer.com_state() in
+  (* end translator state *)
+  let coqdocstate = Lexer.location_table () in
+  ch,cl,cs,coqdocstate
+
+let restore_translator_coqdoc (ch,cl,cs,coqdocstate) =
+  if !Flags.beautify_file then close_out !chan_beautify;
+  chan_beautify := ch;
+  Pp.comments := cl;
+  Lexer.restore_com_state cs;
+  Lexer.restore_location_table coqdocstate
+
+(* For coqtop -time, we display the position in the file,
+   and a glimpse of the executed command *)
+
+let display_cmd_header loc com =
+  let shorten s = try (String.sub s 0 30)^"..." with _ -> s in
+  let noblank s =
+    for i = 0 to String.length s - 1 do
+      match s.[i] with
+	| ' ' | '\n' | '\t' | '\r' -> s.[i] <- '~'
+	| _ -> ()
+    done;
+    s
+  in
+  let (start,stop) = Loc.unloc loc in
+  let safe_pr_vernac x =
+    try Ppvernac.pr_vernac x
+    with e -> str (Printexc.to_string e) in
+  let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com)))
+  in
+  Pp.pp (str "Chars " ++ int start ++ str " - " ++ int stop ++
+	 str (" ["^cmd^"] "));
+  Pp.flush_all ()
 
-    | VernacFail v ->
-	begin try
-	  (* If the command actually works, ignore its effects on the state *)
-	  States.with_state_protection
-	    (fun v -> interp v; raise HasNotFailed) v
-	with e when Errors.noncritical e -> match real_error e with
-	  | HasNotFailed ->
-	      errorlabstrm "Fail" (str "The command has not failed !")
-	  | e ->
-	      (* Anomalies are re-raised by the next line *)
-	      let msg = Errors.print_no_anomaly e in
-	      if_verbose msgnl
-		(str "The command has indeed failed with message:" ++
-		 fnl () ++ str "=> " ++ hov 0 msg)
+let rec vernac_com verbosely checknav (loc,com) =
+  let interp = function
+    | VernacLoad (verbosely, fname) ->
+	let fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in
+	let st = save_translator_coqdoc () in
+	if !Flags.beautify_file then
+	  begin
+            let paths = Loadpath.get_paths () in
+            let _,f = find_file_in_path ~warn:(Flags.is_verbose())
+	      paths
+	      (CUnix.make_suffix fname ".v") in
+	    chan_beautify := open_out (f^beautify_suffix);
+	    Pp.comments := []
+          end;
+	begin
+	  try
+            read_vernac_file verbosely (CUnix.make_suffix fname ".v");
+	    restore_translator_coqdoc st;
+	  with reraise ->
+            let reraise = Errors.push reraise in
+	    restore_translator_coqdoc st;
+	    iraise reraise
 	end
 
-    | VernacTime v ->
-	  let tstart = System.get_time() in
-          interp v;
-	  let tend = System.get_time() in
-          msgnl (str"Finished transaction in " ++
-                   System.fmt_time_difference tstart tend)
-
-    | VernacTimeout(n,v) ->
-	  current_timeout := Some n;
-	  interp v
+    | v when !just_parsing -> ()
 
-    | v ->
-	  let psh = default_set_timeout () in
-	  try
-            States.with_heavy_rollback interpfun
-              Cerrors.process_vernac_interp_error v;
-	    restore_timeout psh
-	  with reraise -> restore_timeout psh; raise reraise
+    | v -> Stm.interp verbosely (loc,v)
   in
     try
       checknav loc com;
-      current_timeout := !default_timeout;
       if do_beautify () then pr_new_syntax loc (Some com);
+      if !Flags.time then display_cmd_header loc com;
+      let com = if !Flags.time then VernacTime [loc,com] else com in
       interp com
-    with any ->
+    with reraise ->
+      let (reraise, info) = Errors.push reraise in
       Format.set_formatter_out_channel stdout;
-      raise (DuringCommandInterp (loc, any))
+      let loc' = Option.default Loc.ghost (Loc.get_loc info) in
+      if Loc.is_ghost loc' then iraise (reraise, Loc.add_loc info loc)
+      else iraise (reraise, info)
 
 and read_vernac_file verbosely s =
   Flags.make_warn verbosely;
-  let interpfun =
-    if verbosely then Vernacentries.interp
-    else Flags.silently Vernacentries.interp
-  in
   let checknav loc cmd =
     if is_navigation_vernac cmd && not (is_reset cmd) then
 	user_error loc "Navigation commands forbidden in files"
   in
-  let end_inner_command cmd =
-    if !atomic_load || is_reset cmd then
-      Lib.mark_end_of_command () (* for Reset in coqc or coqtop -l *)
-    else
-      Backtrack.mark_command cmd; (* for Show Script, cf bug #2820 *)
-  in
   let (in_chan, fname, input) =
     open_file_twice_if verbosely s in
   try
@@ -312,19 +265,20 @@ and read_vernac_file verbosely s =
      * raised, which means that we raised the end of the file being loaded *)
     while true do
       let loc_ast = parse_sentence input in
-      vernac_com interpfun checknav loc_ast;
-      end_inner_command (snd loc_ast);
+      vernac_com verbosely checknav loc_ast;
       pp_flush ()
     done
-  with reraise ->   (* whatever the exception *)
+  with any ->   (* whatever the exception *)
+    let (e, info) = Errors.push any in
     Format.set_formatter_out_channel stdout;
     close_input in_chan input;    (* we must close the file first *)
-    match real_error reraise with
+    match e with
       | End_of_input ->
-          if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None
-      | _ -> raise_with_file fname reraise
+          if do_beautify () then
+            pr_new_syntax (Loc.make_loc (max_int,max_int)) None
+      | _ -> raise_with_file fname (disable_drop e, info)
 
-(** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit]
+(** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit]
    It executes one vernacular command. By default the command is
    considered as non-state-preserving, in which case we add it to the
    Backtrack stack (triggering a save of a frozen state and the generation
@@ -335,43 +289,64 @@ let checknav loc ast =
   if is_deep_navigation_vernac ast then
     user_error loc "Navigation commands forbidden in nested commands"
 
-let eval_expr ?(preserving=false) loc_ast =
-  vernac_com Vernacentries.interp checknav loc_ast;
-  if not preserving && not (is_navigation_vernac (snd loc_ast)) then
-    Backtrack.mark_command (snd loc_ast)
-
-(* raw_do_vernac : Pcoq.Gram.parsable -> unit
- * vernac_step . parse_sentence *)
-let raw_do_vernac po = eval_expr (parse_sentence (po,None))
-
-(* XML output hooks *)
-let xml_start_library = ref (fun _ -> ())
-let xml_end_library = ref (fun _ -> ())
-
-let set_xml_start_library f = xml_start_library := f
-let set_xml_end_library f = xml_end_library := f
+let eval_expr loc_ast = vernac_com (Flags.is_verbose()) checknav loc_ast
 
 (* Load a vernac file. Errors are annotated with file and location *)
 let load_vernac verb file =
   chan_beautify :=
     if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout;
   try
-    Lib.mark_end_of_command (); (* in case we're still in coqtop init *)
     read_vernac_file verb file;
     if !Flags.beautify_file then close_out !chan_beautify;
-  with reraise ->
+  with any ->
+    let (e, info) = Errors.push any in
     if !Flags.beautify_file then close_out !chan_beautify;
-    raise_with_file file reraise
+    raise_with_file file (disable_drop e, info)
 
 (* Compile a vernac file (f is assumed without .v suffix) *)
 let compile verbosely f =
-  let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in
-  Dumpglob.start_dump_glob long_f_dot_v;
-  Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n");
-  if !Flags.xml_export then !xml_start_library ();
-  let _ = load_vernac verbosely long_f_dot_v in
-  if Pfedit.get_all_proof_names () <> [] then
-    (message "Error: There are pending proofs"; exit 1);
-  if !Flags.xml_export then !xml_end_library ();
-  Dumpglob.end_dump_glob ();
-  Library.save_library_to ldir (long_f_dot_v ^ "o")
+  let check_pending_proofs () =
+    let pfs = Pfedit.get_all_proof_names () in
+    if not (List.is_empty pfs) then
+      (msg_error (str "There are pending proofs"); flush_all (); exit 1) in
+  match !Flags.compilation_mode with
+  | BuildVo ->
+      let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in
+      Stm.set_compilation_hints long_f_dot_v;
+      Aux_file.start_aux_file_for long_f_dot_v;
+      Dumpglob.start_dump_glob long_f_dot_v;
+      Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n");
+      let wall_clock1 = Unix.gettimeofday () in
+      let _ = load_vernac verbosely long_f_dot_v in
+      Stm.join ();
+      let wall_clock2 = Unix.gettimeofday () in
+      check_pending_proofs ();
+      Library.save_library_to ldir long_f_dot_v (Global.opaque_tables ());
+      Aux_file.record_in_aux_at Loc.ghost "vo_compile_time"
+        (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1));
+      Aux_file.stop_aux_file ();
+      Dumpglob.end_dump_glob ()
+  | BuildVio ->
+      let ldir, long_f_dot_v = Flags.verbosely Library.start_library f in
+      Dumpglob.noglob ();
+      Stm.set_compilation_hints long_f_dot_v;
+      let _ = load_vernac verbosely long_f_dot_v in
+      Stm.finish ();
+      check_pending_proofs ();
+      Stm.snapshot_vio ldir long_f_dot_v;
+      Stm.reset_task_queue ()
+  | Vio2Vo ->
+      let open Filename in
+      let open Library in
+      Dumpglob.noglob ();
+      let f = if check_suffix f ".vio" then chop_extension f else f in
+      let lfdv, lib, univs, disch, tasks, proofs = load_library_todo f in
+      Stm.set_compilation_hints lfdv;
+      let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in
+      Library.save_library_raw lfdv lib univs proofs
+
+let compile v f = 
+  ignore(CoqworkmgrApi.get 1);
+  compile v f;
+  CoqworkmgrApi.giveback 1
+
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index c1ac2154..affc2171 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.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        *)
@@ -12,28 +12,16 @@
    Raises [End_of_file] if EOF (or Ctrl-D) is reached. *)
 
 val parse_sentence : Pcoq.Gram.parsable * in_channel option ->
- Util.loc * Vernacexpr.vernac_expr
+ Loc.t * Vernacexpr.vernac_expr
 
 (** Reads and executes vernac commands from a stream.
    The boolean [just_parsing] disables interpretation of commands. *)
 
-exception DuringCommandInterp of Util.loc * exn
 exception End_of_input
 
 val just_parsing : bool ref
 
-(** [eval_expr] executes one vernacular command. By default the command is
-   considered as non-state-preserving, in which case we add it to the
-   Backtrack stack (triggering a save of a frozen state and the generation
-   of a new state label). An example of state-preserving command is one coming
-   from the query panel of Coqide. *)
-
-val eval_expr : ?preserving:bool -> Util.loc * Vernacexpr.vernac_expr -> unit
-val raw_do_vernac : Pcoq.Gram.parsable -> unit
-
-(** Set XML hooks *)
-val set_xml_start_library : (unit -> unit) -> unit
-val set_xml_end_library   : (unit -> unit) -> unit
+val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit
 
 (** Load a vernac file, verbosely or not. Errors are annotated with file
    and location *)
@@ -44,3 +32,11 @@ val load_vernac : bool -> string -> unit
 (** Compile a vernac file, verbosely or not (f is assumed without .v suffix) *)
 
 val compile : bool -> string -> unit
+
+val is_navigation_vernac : Vernacexpr.vernac_expr -> bool
+
+(** Has an exception been annotated with some file locations ? *)
+
+type location_files = { outer : string; inner : string }
+
+val get_exn_files : Exninfo.info -> location_files option
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 394b58bd..fb12edfb 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.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        *)
@@ -9,10 +9,10 @@
 (* Concrete syntax of the mathematical vernacular MV V2.6 *)
 
 open Pp
+open Errors
 open Util
 open Flags
 open Names
-open Entries
 open Nameops
 open Term
 open Pfedit
@@ -24,39 +24,28 @@ open Tacinterp
 open Command
 open Goptions
 open Libnames
-open Nametab
+open Globnames
 open Vernacexpr
 open Decl_kinds
-open Topconstr
-open Pretyping
+open Constrexpr
 open Redexpr
-open Syntax_def
 open Lemmas
-open Declaremods
-
-(* Pcoq hooks *)
-
-type pcoq_hook = {
-  start_proof : unit -> unit;
-  solve : int -> unit;
-  abort : string -> unit;
-  search : searchable -> dir_path list * bool -> unit;
-  print_name : reference Genarg.or_by_notation -> unit;
-  print_check : Environ.env -> Environ.unsafe_judgment -> unit;
-  print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
-    Environ.unsafe_judgment -> unit;
-  show_goal : goal_reference -> unit
-}
+open Misctypes
+open Locality
 
-let pcoq = ref None
-let set_pcoq_hook f = pcoq := Some f
+let debug = false
+let prerr_endline =
+  if debug then prerr_endline else fun _ -> ()
 
 (* Misc *)
 
 let cl_of_qualid = function
   | FunClass -> Classops.CL_FUN
   | SortClass -> Classops.CL_SORT
-  | RefClass r -> Class.class_of_global (Smartlocate.smart_global r)
+  | RefClass r -> Class.class_of_global (Smartlocate.smart_global ~head:true r)
+
+let scope_class_of_qualid qid =
+  Notation.scope_class_of_reference (Smartlocate.smart_global qid)
 
 (*******************)
 (* "Show" commands *)
@@ -65,77 +54,31 @@ let show_proof () =
   (* spiwack: this would probably be cooler with a bit of polishing. *)
   let p = Proof_global.give_me_the_proof () in
   let pprf = Proof.partial_proof p in
-  msgnl (Util.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
+  msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf)
 
 let show_node () =
   (* spiwack: I'm have little clue what this function used to do. I deactivated it, 
       could, possibly, be cleaned away. (Feb. 2010) *)
   ()
 
-(* indentation code for Show Script, initially contributed
-   by D. de Rauglaudre *)
-
-let indent_script_item ((ng1,ngl1),nl,beginend,ppl) (cmd,ng) =
-  (* ng1 : number of goals remaining at the current level (before cmd)
-     ngl1 : stack of previous levels with their remaining goals
-     ng : number of goals after the execution of cmd
-     beginend : special indentation stack for { } *)
-  let ngprev = List.fold_left (+) ng1 ngl1 in
-  let new_ngl =
-    if ng > ngprev then
-      (* We've branched *)
-      (ng - ngprev + 1, ng1 - 1 :: ngl1)
-    else if ng < ngprev then
-      (* A subgoal have been solved. Let's compute the new current level
-	 by discarding all levels with 0 remaining goals. *)
-      let _ = assert (ng = ngprev - 1) in
-      let rec loop = function
-	| (0, ng2::ngl2) -> loop (ng2,ngl2)
-	| p -> p
-      in loop (ng1-1, ngl1)
-    else
-      (* Standard case, same goal number as before *)
-      (ng1, ngl1)
-  in
-  (* When a subgoal have been solved, separate this block by an empty line *)
-  let new_nl = (ng < ngprev)
-  in
-  (* Indentation depth *)
-  let ind = List.length ngl1
-  in
-  (* Some special handling of bullets and { }, to get a nicer display *)
-  let pred n = max 0 (n-1) in
-  let ind, nl, new_beginend = match cmd with
-    | VernacSubproof _ -> pred ind, nl, (pred ind)::beginend
-    | VernacEndSubproof -> List.hd beginend, false, List.tl beginend
-    | VernacBullet _ -> pred ind, nl, beginend
-    | _ -> ind, nl, beginend
-  in
-  let pp =
-    (if nl then fnl () else mt ()) ++
-    (hov (ind+1) (str (String.make ind ' ') ++ Ppvernac.pr_vernac cmd))
-  in
-  (new_ngl, new_nl, new_beginend, pp :: ppl)
-
-let show_script () =
-  let prf = Pfedit.get_current_proof_name () in
-  let cmds = Backtrack.get_script prf in
-  let _,_,_,indented_cmds =
-    List.fold_left indent_script_item ((1,[]),false,[],[]) cmds
-  in
-  let indented_cmds = List.rev (indented_cmds) in
-  msgnl (v 0 (Util.prlist_with_sep Pp.fnl (fun x -> x) indented_cmds))
-
 let show_thesis () =
-     msgnl (anomaly "TODO" )
+     msg_error (anomaly (Pp.str "TODO") )
 
 let show_top_evars () =
   (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
   let pfts = get_pftreestate () in
   let gls = Proof.V82.subgoals pfts in
   let sigma = gls.Evd.sigma in
-  msg (pr_evars_int 1 (Evarutil.non_instantiated sigma))
-  
+  msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma))
+
+let show_universes () =
+  let pfts = get_pftreestate () in
+  let gls = Proof.V82.subgoals pfts in
+  let sigma = gls.Evd.sigma in
+  let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in
+  let cstrs = Univ.merge_constraints (Univ.ContextSet.constraints ctx) Univ.empty_universes in
+    msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma));
+    msg_notice (str"Normalized constraints: " ++ Univ.pr_universes (Evd.pr_evd_level sigma) cstrs)
 
 let show_prooftree () =
   (* Spiwack: proof tree is currently not working *)
@@ -145,7 +88,9 @@ let enable_goal_printing = ref true
 
 let print_subgoals () =
   if !enable_goal_printing && is_verbose ()
-  then msg (pr_open_subgoals ())
+  then begin
+    msg_notice (pr_open_subgoals ())
+  end
 
 let try_print_subgoals () =
   Pp.flush_all();
@@ -156,18 +101,18 @@ let try_print_subgoals () =
 
 let show_intro all =
   let pf = get_pftreestate() in
-  let {Evd.it=gls ; sigma=sigma} = Proof.V82.subgoals pf in
-  let gl = {Evd.it=List.hd gls ; sigma = sigma} in
+  let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
+  let gl = {Evd.it=List.hd gls ; sigma = sigma; } in
   let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in
   if all
   then
     let lid = Tactics.find_intro_names l gl in
-    msgnl (hov 0 (prlist_with_sep  spc pr_id lid))
+    msg_notice (hov 0 (prlist_with_sep  spc pr_id lid))
   else
     try
-      let n = list_last l in
-      msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
-    with Failure "list_last" -> message ""
+      let n = List.last l in
+      msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl)))
+    with Failure "List.last" -> ()
 
 (** Prepare a "match" template for a given inductive type.
     For each branch of the match, we list the constructor name
@@ -179,21 +124,21 @@ let make_cases s =
   let qualified_name = Libnames.qualid_of_string s in
   let glob_ref = Nametab.locate qualified_name in
   match glob_ref with
-    | Libnames.IndRef i ->
+    | Globnames.IndRef i ->
 	let {Declarations.mind_nparams = np}
 	    , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr }
 	      = Global.lookup_inductive i in
-	Util.array_fold_right2
+	Util.Array.fold_right2
 	  (fun consname typ l ->
-	     let al = List.rev (fst (Term.decompose_prod typ)) in
-	     let al = Util.list_skipn np al in
+	     let al = List.rev (fst (decompose_prod typ)) in
+	     let al = Util.List.skipn np al in
 	     let rec rename avoid = function
 	       | [] -> []
 	       | (n,_)::l ->
-		   let n' = Namegen.next_name_away_in_cases_pattern n avoid in
-		   string_of_id n' :: rename (n'::avoid) l in
+		   let n' = Namegen.next_name_away_in_cases_pattern ([],mkMeta 0) n avoid in
+		   Id.to_string n' :: rename (n'::avoid) l in
 	     let al' = rename [] al in
-	     (string_of_id consname :: al') :: l)
+	     (Id.to_string consname :: al') :: l)
 	  carr tarr []
     | _ -> raise Not_found
 
@@ -201,36 +146,41 @@ let make_cases s =
 
 let show_match id =
   let patterns =
-    try make_cases (string_of_id (snd id))
+    try make_cases (Id.to_string (snd id))
     with Not_found -> error "Unknown inductive type."
   in
   let pr_branch l =
     str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>"
   in
-  msg (v 1 (str "match # with" ++ fnl () ++
+  msg_notice (v 1 (str "match # with" ++ fnl () ++
 	    prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ()))
 
 (* "Print" commands *)
 
-let print_path_entry (s,l) =
-  (str (string_of_dirpath l) ++ str " " ++ tbrk (0,0) ++ str s)
+let print_path_entry p =
+  let dir = str (DirPath.to_string (Loadpath.logical p)) in
+  let path = str (Loadpath.physical p) in
+  (dir ++ str " " ++ tbrk (0, 0) ++ path)
 
 let print_loadpath dir =
-  let l = Library.get_full_load_paths () in
+  let l = Loadpath.get_load_paths () in
   let l = match dir with
-    | None -> l
-    | Some dir -> List.filter (fun (s,l) -> is_dirpath_prefix_of dir l) l in
-  msgnl (Pp.t (str "Logical Path:                 " ++
-		 tab () ++ str "Physical path:" ++ fnl () ++
-		 prlist_with_sep pr_fnl print_path_entry l))
+  | None -> l
+  | Some dir ->
+    let filter p = is_dirpath_prefix_of dir (Loadpath.logical p) in
+    List.filter filter l
+  in
+  Pp.t (str "Logical Path:                 " ++
+                tab () ++ str "Physical path:" ++ fnl () ++
+                prlist_with_sep fnl print_path_entry l)
 
 let print_modules () =
   let opened = Library.opened_libraries ()
   and loaded = Library.loaded_libraries () in
   (* we intersect over opened to preserve the order of opened since *)
   (* non-commutative operations (e.g. visibility) are done at import time *)
-  let loaded_opened = list_intersect opened loaded
-  and only_loaded = list_subtract loaded opened in
+  let loaded_opened = List.intersect DirPath.equal opened loaded
+  and only_loaded = List.subtract DirPath.equal loaded opened in
   str"Loaded and imported library files: " ++
   pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++
   str"Loaded and not imported library files: " ++
@@ -243,23 +193,131 @@ let print_module r =
     let globdir = Nametab.locate_dir qid in
       match globdir with
 	  DirModule (dirpath,(mp,_)) ->
-	    msgnl (Printmod.print_module (Printmod.printable_body dirpath) mp)
+	    msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp)
 	| _ -> raise Not_found
   with
-      Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid)
+      Not_found -> msg_error (str"Unknown Module " ++ pr_qualid qid)
 
 let print_modtype r =
   let (loc,qid) = qualid_of_reference r in
   try
     let kn = Nametab.locate_modtype qid in
-    msgnl (Printmod.print_modtype kn)
+    msg_notice (Printmod.print_modtype kn)
   with Not_found ->
     (* Is there a module of this name ? If yes we display its type *)
     try
       let mp = Nametab.locate_module qid in
-      msgnl (Printmod.print_module false mp)
+      msg_notice (Printmod.print_module false mp)
     with Not_found ->
-      msgnl (str"Unknown Module Type or Module " ++ pr_qualid qid)
+      msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid)
+
+let print_namespace ns =
+  let ns = List.rev (Names.DirPath.repr ns) in
+  (* [match_dirpath], [match_modulpath] are helpers for [matches]
+     which checks whether a constant is in the namespace [ns]. *)
+  let rec match_dirpath ns = function
+    | [] -> Some ns
+    | id::dir ->
+        begin match match_dirpath ns dir with
+        | Some [] as y -> y
+        | Some (a::ns') ->
+            if Names.Id.equal a id then Some ns'
+            else None
+        | None -> None
+        end
+  in
+  let rec match_modulepath ns = function
+    | MPbound _ -> None (* Not a proper namespace. *)
+    | MPfile dir -> match_dirpath ns (Names.DirPath.repr dir)
+    | MPdot (mp,lbl) ->
+        let id = Names.Label.to_id lbl in
+        begin match match_modulepath ns mp with
+        | Some [] as y -> y
+        | Some (a::ns') ->
+            if Names.Id.equal a id then Some ns'
+            else None
+        | None -> None
+        end
+  in
+  (* [qualified_minus n mp] returns a list of qualifiers representing
+     [mp] except the [n] first (in the concrete syntax order).  The
+     idea is that if [mp] matches [ns], then [qualified_minus mp
+     (length ns)] will be the correct representation of [mp] assuming
+     [ns] is imported. *)
+  (* precondition: [mp] matches some namespace of length [n] *)
+  let qualified_minus n mp =
+    let rec list_of_modulepath = function
+      | MPbound _ -> assert false (* MPbound never matches *)
+      | MPfile dir -> Names.DirPath.repr dir
+      | MPdot (mp,lbl) -> (Names.Label.to_id lbl)::(list_of_modulepath mp)
+    in
+    snd (Util.List.chop n (List.rev (list_of_modulepath mp)))
+  in
+  let print_list pr l = prlist_with_sep (fun () -> str".") pr l in
+  let print_kn kn =
+    (* spiwack: I'm ignoring the dirpath, is that bad? *)
+    let (mp,_,lbl) = Names.repr_kn kn in
+    let qn = (qualified_minus (List.length ns) mp)@[Names.Label.to_id lbl] in
+    print_list pr_id qn
+  in
+  let print_constant k body =
+    (* FIXME: universes *)
+    let t = Typeops.type_of_constant_type (Global.env ()) body.Declarations.const_type in
+    print_kn k ++ str":" ++ spc() ++ Printer.pr_type t
+  in
+  let matches mp = match match_modulepath ns mp with
+  | Some [] -> true
+  | _ -> false in
+  let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in
+  let constants_in_namespace =
+    Cmap_env.fold (fun c (body,_) acc ->
+      let kn = user_con c in
+      if matches (modpath kn) then
+        acc++fnl()++hov 2 (print_constant kn body)
+      else
+        acc
+    ) constants (str"")
+  in
+  msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace)
+
+let print_strategy r =
+  let open Conv_oracle in
+  let pr_level = function
+  | Expand -> str "expand"
+  | Level 0 -> str "transparent"
+  | Level n -> str "level" ++ spc() ++ int n
+  | Opaque -> str "opaque"
+  in
+  let pr_strategy (ref, lvl) = pr_global ref ++ str " : " ++ pr_level lvl in
+  let oracle = Environ.oracle (Global.env ()) in
+  match r with
+  | None ->
+    let fold key lvl (vacc, cacc) = match key with
+    | VarKey id -> ((VarRef id, lvl) :: vacc, cacc)
+    | ConstKey cst -> (vacc, (ConstRef cst, lvl) :: cacc)
+    | RelKey _ -> (vacc, cacc)
+    in
+    let var_lvl, cst_lvl = fold_strategy fold oracle ([], []) in
+    let var_msg =
+      if List.is_empty var_lvl then mt ()
+      else str "Variable strategies" ++ fnl () ++
+        hov 0 (prlist_with_sep fnl pr_strategy var_lvl) ++ fnl ()
+    in
+    let cst_msg =
+      if List.is_empty cst_lvl then mt ()
+      else str "Constant strategies" ++ fnl () ++
+        hov 0 (prlist_with_sep fnl pr_strategy cst_lvl)
+    in
+    msg_notice (var_msg ++ cst_msg)
+  | Some r ->
+    let r = Smartlocate.smart_global r in
+    let key = match r with
+    | VarRef id -> VarKey id
+    | ConstRef cst -> ConstKey cst
+    | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable"
+    in
+    let lvl = get_strategy oracle key in
+    msg_notice (pr_strategy (r, lvl))
 
 let dump_universes_gen g s =
   let output = open_out s in
@@ -293,9 +351,11 @@ let dump_universes_gen g s =
   try
     Univ.dump_universes output_constraint g;
     close ();
-    msgnl (str ("Universes written to file \""^s^"\"."))
-  with
-      reraise -> close (); raise reraise
+    msg_info (str ("Universes written to file \""^s^"\"."))
+  with reraise ->
+    let reraise = Errors.push reraise in
+    close ();
+    iraise reraise
 
 let dump_universes sorted s =
   let g = Global.universes () in
@@ -306,111 +366,109 @@ let dump_universes sorted s =
 (* "Locate" commands *)
 
 let locate_file f =
-  let _,file = System.find_file_in_path ~warn:false (Library.get_load_paths ()) f in
-  msgnl (str file)
+  let paths = Loadpath.get_paths () in
+  let _, file = System.find_file_in_path ~warn:false paths f in
+  str file
 
 let msg_found_library = function
   | Library.LibLoaded, fulldir, file ->
-      msgnl (hov 0
+      msg_info (hov 0
 	(pr_dirpath fulldir ++ strbrk " has been loaded from file " ++
 	 str file))
   | Library.LibInPath, fulldir, file ->
-      msgnl (hov 0
+      msg_info (hov 0
 	(pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file))
-let msg_notfound_library loc qid = function
-  | Library.LibUnmappedDir ->
-      let dir = fst (repr_qualid qid) in
-      user_err_loc (loc,"locate_library",
-        strbrk "Cannot find a physical path bound to logical path " ++
-           pr_dirpath dir ++ str".")
-  | Library.LibNotFound ->
-      msgnl (hov 0
-	(strbrk "Unable to locate library " ++ pr_qualid qid ++ str"."))
-  | e -> assert false
 
-let print_located_library r =
-  let (loc,qid) = qualid_of_reference r in
-  try msg_found_library (Library.locate_qualified_library false qid)
-  with e when Errors.noncritical e -> msg_notfound_library loc qid e
+let err_unmapped_library loc qid =
+  let dir = fst (repr_qualid qid) in
+  user_err_loc
+    (loc,"locate_library",
+     strbrk "Cannot find a physical path bound to logical path " ++
+       pr_dirpath dir ++ str".")
 
-let print_located_module r =
-  let (loc,qid) = qualid_of_reference r in
-  let msg =
-    try
-      let dir = Nametab.full_name_module qid in
-      str "Module " ++ pr_dirpath dir
-    with Not_found ->
-      (if fst (repr_qualid qid) = empty_dirpath then
-	str "No module is referred to by basename "
-      else
-	str "No module is referred to by name ") ++ pr_qualid qid
-  in msgnl msg
+let err_notfound_library loc qid =
+  msg_error
+    (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str"."))
 
-let print_located_tactic r =
+let print_located_library r =
   let (loc,qid) = qualid_of_reference r in
-  msgnl
-    (try
-      str "Ltac " ++
-      pr_path (Nametab.path_of_tactic (Nametab.locate_tactic qid))
-     with Not_found ->
-	str "No Ltac definition is referred to by " ++ pr_qualid qid)
+  try msg_found_library (Library.locate_qualified_library false qid)
+  with
+    | Library.LibUnmappedDir -> err_unmapped_library loc qid
+    | Library.LibNotFound -> err_notfound_library loc qid
 
 let smart_global r =
   let gr = Smartlocate.smart_global r in
-    Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr;
+    Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr;
     gr
 
 let dump_global r =
   try
     let gr = Smartlocate.smart_global r in
-    Dumpglob.add_glob (Genarg.loc_of_or_by_notation loc_of_reference r) gr
+    Dumpglob.add_glob (Constrarg.loc_of_or_by_notation loc_of_reference r) gr
   with e when Errors.noncritical e -> ()
 (**********)
 (* Syntax *)
 
-let vernac_syntax_extension = Metasyntax.add_syntax_extension
+let vernac_syntax_extension locality local =
+  let local = enforce_module_locality locality local in
+  Metasyntax.add_syntax_extension local
 
 let vernac_delimiters = Metasyntax.add_delimiters
 
 let vernac_bind_scope sc cll =
-  List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll
+  Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll)
 
-let vernac_open_close_scope = Notation.open_close_scope
+let vernac_open_close_scope locality local (b,s) =
+  let local = enforce_section_locality locality local in
+  Notation.open_close_scope (local,b,s)
 
-let vernac_arguments_scope local r scl =
+let vernac_arguments_scope locality r scl =
+  let local = make_section_locality locality in
   Notation.declare_arguments_scope local (smart_global r) scl
 
-let vernac_infix = Metasyntax.add_infix
+let vernac_infix locality local =
+  let local = enforce_module_locality locality local in
+  Metasyntax.add_infix local
 
-let vernac_notation = Metasyntax.add_notation
+let vernac_notation locality local =
+  let local = enforce_module_locality locality local in
+  Metasyntax.add_notation local
 
 (***********)
 (* Gallina *)
 
-let start_proof_and_print k l hook =
-  check_locality (); (* early check, cf #2975 *)
-  start_proof_com k l hook;
-  print_subgoals ();
-  if !pcoq <> None then (Option.get !pcoq).start_proof ()
+let start_proof_and_print k l hook = start_proof_com k l hook
+
+let no_hook = Lemmas.mk_hook (fun _ _ -> ())
 
-let vernac_definition (local,k) (loc,id as lid) def hook =
-  if local = Local then Dumpglob.dump_definition lid true "var"
-  else Dumpglob.dump_definition lid false "def";
+let vernac_definition_hook p = function
+| Coercion -> Class.add_coercion_hook p
+| CanonicalStructure ->
+    Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure)
+| SubClass -> Class.add_subclass_hook p
+| _ -> no_hook
+
+let vernac_definition locality p (local,k) (loc,id as lid) def =
+  let local = enforce_locality_exp locality local in
+  let hook = vernac_definition_hook p k in
+  let () = match local with
+  | Discharge -> Dumpglob.dump_definition lid true "var"
+  | Local | Global -> Dumpglob.dump_definition lid false "def"
+  in
   (match def with
     | ProveBody (bl,t) ->   (* local binders, typ *)
- 	let hook _ _ = () in
- 	  start_proof_and_print (local,DefinitionBody Definition)
-	    [Some lid, (bl,t,None)] hook
+ 	  start_proof_and_print (local,p,DefinitionBody Definition)
+	    [Some lid, (bl,t,None)] no_hook
     | DefineBody (bl,red_option,c,typ_opt) ->
  	let red_option = match red_option with
           | None -> None
           | Some r ->
 	      let (evc,env)= get_current_context () in
  		Some (snd (interp_redexp env evc r)) in
-	let ce,imps = interp_definition bl red_option c typ_opt in
-	declare_definition id (local,k) ce imps hook)
+	do_definition id (local,p,k) bl red_option c typ_opt hook)
 
-let vernac_start_proof kind l lettop hook =
+let vernac_start_proof p kind l lettop =
   if Dumpglob.dump () then
     List.iter (fun (id, _) ->
       match id with
@@ -420,23 +478,16 @@ let vernac_start_proof kind l lettop hook =
     if lettop then
       errorlabstrm "Vernacentries.StartProof"
 	(str "Let declarations can only be used in proof editing mode.");
-  start_proof_and_print (Global, Proof kind) l hook
+  start_proof_and_print (Global, p, Proof kind) l no_hook
 
 let qed_display_script = ref true
 
-let vernac_end_proof = function
-  | Admitted ->
-    Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
-    admit ()
-  | Proved (is_opaque,idopt) ->
-    let prf = Pfedit.get_current_proof_name () in
-    if is_verbose () && !qed_display_script then (show_script (); msg (fnl()));
-    begin match idopt with
-    | None -> save_named is_opaque
-    | Some ((_,id),None) -> save_anonymous is_opaque id
-    | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id
-    end;
-    Backtrack.mark_unreachable [prf]
+let vernac_end_proof ?proof = function
+  | Admitted -> save_proof ?proof Admitted
+  | Proved (_,_) as e ->
+    if is_verbose () && !qed_display_script && !Flags.coqtop_ui then
+      Stm.show_script ?proof ();
+    save_proof ?proof e
 
   (* A stupid macro that should be replaced by ``Exact c. Save.'' all along
      the theories [??] *)
@@ -444,22 +495,23 @@ let vernac_end_proof = function
 let vernac_exact_proof c =
   (* spiwack: for simplicity I do not enforce that "Proof proof_term" is
      called only at the begining of a proof. *)
-  let prf = Pfedit.get_current_proof_name () in
-  by (Tactics.exact_proof c);
-  save_named true;
-  Backtrack.mark_unreachable [prf]
-
-let vernac_assumption kind l nl=
-  let global = fst kind = Global in
-    List.iter (fun (is_coe,(idl,c)) ->
-      if Dumpglob.dump () then
-	List.iter (fun lid ->
-	  if global then Dumpglob.dump_definition lid false "ax"
-	  else Dumpglob.dump_definition lid true "var") idl;
-      let t,imps = interp_assumption [] c in
-      declare_assumptions idl is_coe kind t imps false nl) l
-
-let vernac_record k finite infer struc binders sort nameopt cfs =
+  let status = by (Tactics.New.exact_proof c) in
+  save_proof (Vernacexpr.Proved(true,None));
+  if not status then Pp.feedback Feedback.AddedAxiom
+
+let vernac_assumption locality poly (local, kind) l nl =
+  let local = enforce_locality_exp locality local in
+  let global = local == Global in
+  let kind = local, poly, kind in
+  List.iter (fun (is_coe,(idl,c)) ->
+    if Dumpglob.dump () then
+      List.iter (fun lid ->
+	if global then Dumpglob.dump_definition lid false "ax"
+	else Dumpglob.dump_definition lid true "var") idl) l;
+  let status = do_assumptions kind nl l in
+  if not status then Pp.feedback Feedback.AddedAxiom
+
+let vernac_record k poly finite struc binders sort nameopt cfs =
   let const = match nameopt with
     | None -> add_prefix "Build_" (snd (snd struc))
     | Some (_,id as lid) ->
@@ -470,9 +522,9 @@ let vernac_record k finite infer struc binders sort nameopt cfs =
 	match x with
 	| Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj"
 	| _ -> ()) cfs);
-    ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort))
+    ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort))
 
-let vernac_inductive finite infer indl =
+let vernac_inductive poly lo finite indl =
   if Dumpglob.dump () then
     List.iter (fun (((coe,lid), _, _, _, cstrs), _) ->
       match cstrs with
@@ -483,37 +535,45 @@ let vernac_inductive finite infer indl =
 	| _ -> () (* dumping is done by vernac_record (called below) *) )
       indl;
   match indl with
+  | [ ( _ , _ , _ ,Record, Constructors _ ),_ ] ->
+      Errors.error "The Record keyword cannot be used to define a variant type. Use Variant instead."
+  | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] ->
+      Errors.error "The Variant keyword cannot be used to define a record type. Use Record instead."
   | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] ->
       vernac_record (match b with Class true -> Class false | _ -> b)
-	finite infer id bl c oc fs
+	poly finite id bl c oc fs
   | [ ( id , bl , c , Class true, Constructors [l]), _ ] ->
       let f =
 	let (coe, ((loc, id), ce)) = l in
 	let coe' = if coe then Some true else None in
 	  (((coe', AssumExpr ((loc, Name id), ce)), None), [])
-      in vernac_record (Class true) finite infer id bl c None [f]
+      in vernac_record (Class true) poly finite id bl c None [f]
   | [ ( id , bl , c , Class true, _), _ ] ->
-      Util.error "Definitional classes must have a single method"
+      Errors.error "Definitional classes must have a single method"
   | [ ( id , bl , c , Class false, Constructors _), _ ] ->
-      Util.error "Inductive classes not supported"
+      Errors.error "Inductive classes not supported"
   | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] ->
-      Util.error "where clause not supported for (co)inductive records"
+      Errors.error "where clause not supported for (co)inductive records"
   | _ -> let unpack = function
-      | ( (_, id) , bl , c , _ , Constructors l ) , ntn  -> ( id , bl , c , l ) , ntn
-      | _ -> Util.error "Cannot handle mutually (co)inductive records."
+      | ( (false, id) , bl , c , _ , Constructors l ) , ntn  -> ( id , bl , c , l ) , ntn
+      | ( (true,_),_,_,_,Constructors _),_ ->
+          Errors.error "Variant types do not handle the \"> Name\" syntax, which is reserved for records. Use the \":>\" syntax on constructors instead."
+      | _ -> Errors.error "Cannot handle mutually (co)inductive records."
     in
     let indl = List.map unpack indl in
-    do_mutual_inductive indl (recursivity_flag_of_kind finite)
+    do_mutual_inductive indl poly lo finite
 
-let vernac_fixpoint l =
+let vernac_fixpoint locality poly local l =
+  let local = enforce_locality_exp locality local in
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_fixpoint l
+  do_fixpoint local poly l
 
-let vernac_cofixpoint l =
+let vernac_cofixpoint locality poly local l =
+  let local = enforce_locality_exp locality local in
   if Dumpglob.dump () then
     List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l;
-  do_cofixpoint l
+  do_cofixpoint local poly l
 
 let vernac_scheme l =
   if Dumpglob.dump () then
@@ -528,9 +588,12 @@ let vernac_scheme l =
 let vernac_combined_scheme lid l =
   if Dumpglob.dump () then
     (Dumpglob.dump_definition lid false "def";
-     List.iter (fun lid -> dump_global (Genarg.AN (Ident lid))) l);
+     List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l);
  Indschemes.do_combined_scheme lid l
 
+let vernac_universe l = do_universe l
+let vernac_constraint l = do_constraint l
+
 (**********************)
 (* Modules            *)
 
@@ -548,19 +611,18 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast =
     error "Modules and Module Types are not allowed inside sections.";
   let binders_ast = List.map
    (fun (export,idl,ty) ->
-     if export <> None then
+     if not (Option.is_empty export) then
       error ("Arguments of a functor declaration cannot be exported. " ^
        "Remove the \"Export\" and \"Import\" keywords from every functor " ^
        "argument.")
      else (idl,ty)) binders_ast in
-  let mp = Declaremods.declare_module
-    Modintern.interp_modtype Modintern.interp_modexpr
-    Modintern.interp_modexpr_or_modtype
-    id binders_ast (Enforce mty_ast) []
+  let mp =
+    Declaremods.declare_module Modintern.interp_module_ast
+      id binders_ast (Enforce mty_ast) []
   in
-    Dumpglob.dump_moddef loc mp "mod";
-    if_verbose message ("Module "^ string_of_id id ^" is declared");
-    Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
+  Dumpglob.dump_moddef loc mp "mod";
+  if_verbose msg_info (str ("Module "^ Id.to_string id ^" is declared"));
+  Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
 
 let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
   (* We check the state of the system (in section, in module type)
@@ -575,40 +637,40 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
          (fun (export,idl,ty) (args,argsexport) ->
            (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
              ([],[]) in
-       let mp = Declaremods.start_module Modintern.interp_modtype export
-	 id binders_ast mty_ast_o
+       let mp =
+         Declaremods.start_module Modintern.interp_module_ast
+           export id binders_ast mty_ast_o
        in
-	 Dumpglob.dump_moddef loc mp "mod";
-	 if_verbose message
-	   ("Interactive Module "^ string_of_id id ^" started") ;
-         List.iter
-           (fun (export,id) ->
-             Option.iter
-               (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
-           ) argsexport
+       Dumpglob.dump_moddef loc mp "mod";
+       if_verbose msg_info
+         (str ("Interactive Module "^ Id.to_string id ^" started"));
+       List.iter
+         (fun (export,id) ->
+           Option.iter
+             (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
+         ) argsexport
     | _::_ ->
        let binders_ast = List.map
         (fun (export,idl,ty) ->
-          if export <> None then
+          if not (Option.is_empty export) then
            error ("Arguments of a functor definition can be imported only if" ^
                   " the definition is interactive. Remove the \"Export\" and " ^
                   "\"Import\" keywords from every functor argument.")
           else (idl,ty)) binders_ast in
-       let mp =	Declaremods.declare_module
-	  Modintern.interp_modtype Modintern.interp_modexpr
-          Modintern.interp_modexpr_or_modtype
-	  id binders_ast mty_ast_o mexpr_ast_l
+       let mp =
+         Declaremods.declare_module Modintern.interp_module_ast
+	   id binders_ast mty_ast_o mexpr_ast_l
        in
-	 Dumpglob.dump_moddef loc mp "mod";
-	 if_verbose message
-	   ("Module "^ string_of_id id ^" is defined");
-         Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)])
-           export
+       Dumpglob.dump_moddef loc mp "mod";
+       if_verbose msg_info
+	 (str ("Module "^ Id.to_string id ^" is defined"));
+       Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)])
+         export
 
 let vernac_end_module export (loc,id as lid) =
   let mp = Declaremods.end_module () in
   Dumpglob.dump_modref loc mp "mod";
-  if_verbose message ("Module "^ string_of_id id ^" is defined") ;
+  if_verbose msg_info (str ("Module "^ Id.to_string id ^" is defined"));
   Option.iter (fun export -> vernac_import export [Ident lid]) export
 
 let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
@@ -618,45 +680,48 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
   match mty_ast_l with
     | [] ->
        check_no_pending_proofs ();
-       let binders_ast,argsexport =       
+       let binders_ast,argsexport =
 	 List.fold_right
          (fun (export,idl,ty) (args,argsexport) ->
            (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast
              ([],[]) in
-       
-       let mp = Declaremods.start_modtype
-	 Modintern.interp_modtype id binders_ast mty_sign in
-        Dumpglob.dump_moddef loc mp "modtype";
-	if_verbose message
-	  ("Interactive Module Type "^ string_of_id id ^" started");
-        List.iter
+
+       let mp =
+         Declaremods.start_modtype Modintern.interp_module_ast
+           id binders_ast mty_sign
+       in
+       Dumpglob.dump_moddef loc mp "modtype";
+       if_verbose msg_info
+	 (str ("Interactive Module Type "^ Id.to_string id ^" started"));
+       List.iter
          (fun (export,id) ->
            Option.iter
-            (fun export -> vernac_import export [Ident (dummy_loc,id)]) export
+             (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export
          ) argsexport
 
     | _ :: _ ->
 	let binders_ast = List.map
           (fun (export,idl,ty) ->
-            if export <> None then
+            if not (Option.is_empty export) then
               error ("Arguments of a functor definition can be imported only if" ^
 			" the definition is interactive. Remove the \"Export\" " ^
 			"and \"Import\" keywords from every functor argument.")
             else (idl,ty)) binders_ast in
-	let mp = Declaremods.declare_modtype Modintern.interp_modtype
-          Modintern.interp_modexpr_or_modtype
-	  id binders_ast mty_sign mty_ast_l in
-          Dumpglob.dump_moddef loc mp "modtype";
-	  if_verbose message
-	    ("Module Type "^ string_of_id id ^" is defined")
+	let mp =
+          Declaremods.declare_modtype Modintern.interp_module_ast
+	    id binders_ast mty_sign mty_ast_l
+        in
+        Dumpglob.dump_moddef loc mp "modtype";
+	if_verbose msg_info
+	  (str ("Module Type "^ Id.to_string id ^" is defined"))
 
 let vernac_end_modtype (loc,id) =
   let mp = Declaremods.end_modtype () in
   Dumpglob.dump_modref loc mp "modtype";
-  if_verbose message ("Module Type "^ string_of_id id ^" is defined")
+  if_verbose msg_info (str ("Module Type "^ Id.to_string id ^" is defined"))
 
 let vernac_include l =
-  Declaremods.declare_include Modintern.interp_modexpr_or_modtype l
+  Declaremods.declare_include Modintern.interp_module_ast l
 
 (**********************)
 (* Gallina extensions *)
@@ -670,9 +735,11 @@ let vernac_begin_section (_, id as lid) =
 
 let vernac_end_section (loc,_) =
   Dumpglob.dump_reference loc
-    (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec";
+    (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec";
   Lib.close_section ()
 
+let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set
+
 (* Dispatcher of the "End" command *)
 
 let vernac_end_segment (_,id as lid) =
@@ -685,9 +752,9 @@ let vernac_end_segment (_,id as lid) =
 
 (* Libraries *)
 
-let vernac_require import _ qidl =
+let vernac_require import qidl =
   let qidl = List.map qualid_of_reference qidl in
-  let modrefl = Flags.silently (List.map Library.try_locate_qualified_library) qidl in
+  let modrefl = List.map Library.try_locate_qualified_library qidl in
   if Dumpglob.dump () then
     List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref loc dp "lib") qidl (List.map fst modrefl);
   Library.require_library_from_dirpath modrefl import
@@ -697,32 +764,36 @@ let vernac_require import _ qidl =
 let vernac_canonical r =
   Recordops.declare_canonical_structure (smart_global r)
 
-let vernac_coercion stre ref qids qidt =
+let vernac_coercion locality poly local ref qids qidt =
+  let local = enforce_locality locality local in
   let target = cl_of_qualid qidt in
   let source = cl_of_qualid qids in
   let ref' = smart_global ref in
-  Class.try_add_new_coercion_with_target ref' stre ~source ~target;
-  if_verbose msgnl (pr_global ref' ++ str " is now a coercion")
+  Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target;
+  if_verbose msg_info (pr_global ref' ++ str " is now a coercion")
 
-let vernac_identity_coercion stre id qids qidt =
+let vernac_identity_coercion locality poly local id qids qidt =
+  let local = enforce_locality locality local in
   let target = cl_of_qualid qidt in
   let source = cl_of_qualid qids in
-  Class.try_add_new_identity_coercion id stre ~source ~target
+  Class.try_add_new_identity_coercion id ~local poly ~source ~target
 
 (* Type classes *)
 
-let vernac_instance abst glob sup inst props pri =
+let vernac_instance abst locality poly sup inst props pri =
+  let global = not (make_section_locality locality) in
   Dumpglob.dump_constraint inst false "inst";
-  ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri)
+  ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri)
 
-let vernac_context l =
-  Classes.context l
+let vernac_context poly l =
+  if not (Classes.context poly l) then Pp.feedback Feedback.AddedAxiom
 
-let vernac_declare_instances glob ids =
-  List.iter (fun (id) -> Classes.existing_instance glob id) ids
+let vernac_declare_instances locality ids pri =
+  let glob = not (make_section_locality locality) in
+  List.iter (fun id -> Classes.existing_instance glob id pri) ids
 
 let vernac_declare_class id =
-  Classes.declare_class id
+  Record.declare_existing_class (Nametab.global id)
 
 (***********)
 (* Solving *)
@@ -731,18 +802,32 @@ let command_focus = Proof.new_focus_kind ()
 let focus_command_cond = Proof.no_cond command_focus
 
 
-let vernac_solve n tcom b =
+let print_info_trace = ref None
+
+let _ = let open Goptions in declare_int_option {
+  optsync = true;
+  optdepr = false;
+  optname = "print info trace";
+  optkey = ["Info" ; "Level"];
+  optread = (fun () -> !print_info_trace);
+  optwrite = fun n -> print_info_trace := n;
+}
+
+let vernac_solve n info tcom b =
   if not (refining ()) then
     error "Unknown command of the non proof-editing mode.";
-  let p = Proof_global.give_me_the_proof () in
-  Proof.transaction p begin fun () ->
-    solve_nth n (Tacinterp.hide_interp tcom None) ~with_end_tac:b;
+  let status = Proof_global.with_current_proof (fun etac p ->
+    let with_end_tac = if b then Some etac else None in
+    let global = match n with SelectAll -> true | _ -> false in
+    let info = Option.append info !print_info_trace in
+    let (p,status) =
+      solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p
+    in
     (* in case a strict subtree was completed,
        go back to the top of the prooftree *)
-    Proof_global.maximal_unfocus command_focus p;
-    print_subgoals();
-    if !pcoq <> None then (Option.get !pcoq).solve n
-  end
+    let p = Proof.maximal_unfocus command_focus p in
+    p,status) in
+    if not status then Pp.feedback Feedback.AddedAxiom
  
 
   (* A command which should be a tactic. It has been
@@ -756,54 +841,69 @@ let vernac_solve_existential = instantiate_nth_evar_com
 let vernac_set_end_tac tac =
   if not (refining ()) then
     error "Unknown command of the non proof-editing mode.";
-  if tac <> (Tacexpr.TacId []) then set_end_tac (Tacinterp.interp tac) else ()
+  match tac with
+  | Tacexpr.TacId [] -> ()
+  | _ -> set_end_tac tac
     (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*)
 
-let vernac_set_used_variables l =
-  let l = List.map snd l in
-  if not (list_distinct l) then error "Used variables list contains duplicates";
-  let vars = Environ.named_context (Global.env ()) in
+let vernac_set_used_variables e =
+  let env = Global.env () in
+  let tys =
+    List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in
+  let l = Proof_using.process_expr env e tys in
+  let vars = Environ.named_context env in
   List.iter (fun id -> 
-    if not (List.exists (fun (id',_,_) -> id = id') vars) then
-      error ("Unknown variable: " ^ string_of_id id))
+    if not (List.exists (fun (id',_,_) -> Id.equal id id') vars) then
+      error ("Unknown variable: " ^ Id.to_string id))
     l;
-  set_used_variables l
+  let closure_l = List.map pi1 (set_used_variables l) in
+  let closure_l = List.fold_right Id.Set.add closure_l Id.Set.empty in
+  let vars_of = Environ.global_vars_set in
+  let aux env entry (all_safe,rest as orig) =
+    match entry with
+    | (x,None,_) ->
+       if Id.Set.mem x all_safe then orig else (all_safe, (Loc.ghost,x)::rest) 
+    | (x,Some bo, ty) ->
+       let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in
+       if Id.Set.subset vars all_safe then (Id.Set.add x all_safe, rest)
+       else (all_safe, (Loc.ghost,x) :: rest) in
+  let _,to_clear = Environ.fold_named_context aux env ~init:(closure_l,[]) in
+  vernac_solve
+    SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false
+
 
 (*****************************)
 (* Auxiliary file management *)
 
-let vernac_require_from export spec filename =
-  Library.require_library_from_file None
-    (System.expand_path_macros filename)
-    export
+let expand filename =
+  Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) filename
 
 let vernac_add_loadpath isrec pdir ldiropt =
-  let pdir = System.expand_path_macros pdir in
-  let alias = match ldiropt with
-    | None -> Nameops.default_root_prefix
-    | Some ldir -> ldir in
-  (if isrec then Mltop.add_rec_path else Mltop.add_path) ~unix_path:pdir ~coq_root:alias
+  let pdir = expand pdir in
+  let alias = Option.default Nameops.default_root_prefix ldiropt in
+  (if isrec then Mltop.add_rec_path else Mltop.add_path)
+    ~unix_path:pdir ~coq_root:alias ~implicit:true
 
 let vernac_remove_loadpath path =
-  Library.remove_load_path (System.expand_path_macros path)
+  Loadpath.remove_load_path (expand path)
 
   (* Coq syntax for ML or system commands *)
 
 let vernac_add_ml_path isrec path =
-  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir)
-    (System.expand_path_macros path)
+  (if isrec then Mltop.add_rec_ml_dir else Mltop.add_ml_dir) (expand path)
 
-let vernac_declare_ml_module local l =
-  Mltop.declare_ml_modules local (List.map System.expand_path_macros l)
+let vernac_declare_ml_module locality l =
+  let local = make_locality locality in
+  Mltop.declare_ml_modules local (List.map expand l)
 
 let vernac_chdir = function
-  | None -> message (Sys.getcwd())
+  | None -> msg_notice (str (Sys.getcwd()))
   | Some path ->
       begin
-	try Sys.chdir (System.expand_path_macros path)
-	with Sys_error str -> msg_warn ("Cd failed: " ^ str)
+	try Sys.chdir (expand path)
+	with Sys_error err -> msg_warning (str ("Cd failed: " ^ err))
       end;
-      if_verbose message (Sys.getcwd())
+      if_verbose msg_info (str (Sys.getcwd()))
 
 
 (********************)
@@ -820,42 +920,118 @@ let vernac_restore_state file =
 (************)
 (* Commands *)
 
-let vernac_declare_tactic_definition (local,x,def) =
-  Tacinterp.add_tacdef local x def
+type tacdef_kind =
+  | NewTac of Id.t
+  | UpdateTac of Nametab.ltac_constant
+
+let is_defined_tac kn =
+  try ignore (Tacenv.interp_ltac kn); true with Not_found -> false
+
+let make_absolute_name ident repl =
+  let loc = loc_of_reference ident in
+  if repl then
+    let kn =
+      try Nametab.locate_tactic (snd (qualid_of_reference ident))
+      with Not_found ->
+        Errors.user_err_loc (loc, "",
+                    str "There is no Ltac named " ++ pr_reference ident ++ str ".")
+    in
+    UpdateTac kn
+  else
+    let id = Constrexpr_ops.coerce_reference_to_id ident in
+    let kn = Lib.make_kn id in
+    let () = if is_defined_tac kn then
+      Errors.user_err_loc (loc, "",
+        str "There is already an Ltac named " ++ pr_reference ident ++ str".")
+    in
+    let is_primitive =
+      try
+        match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with
+        | Tacexpr.TacArg _ -> false
+        | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *)
+      with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *)
+    in
+    let () = if is_primitive then
+      msg_warning (str "The Ltac name " ++ pr_reference ident ++
+        str " may be unusable because of a conflict with a notation.")
+    in
+    NewTac id
+
+let register_ltac local isrec tacl =
+  let map (ident, repl, body) =
+    let name = make_absolute_name ident repl in
+    (name, body)
+  in
+  let rfun = List.map map tacl in
+  let ltacrecvars =
+    let fold accu (op, _) = match op with
+    | UpdateTac _ -> accu
+    | NewTac id -> Id.Map.add id (Lib.make_kn id) accu
+    in
+    if isrec then List.fold_left fold Id.Map.empty rfun
+    else Id.Map.empty
+  in
+  let ist = { (Tacintern.make_empty_glob_sign ()) with Genintern.ltacrecvars; } in
+  let map (name, body) =
+    let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in
+    (name, body)
+  in
+  let defs = List.map map rfun in
+  let iter (def, tac) = match def with
+  | NewTac id ->
+    Tacenv.register_ltac false local id tac;
+    Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined")
+  | UpdateTac kn ->
+    Tacenv.redefine_ltac local kn tac;
+    let name = Nametab.shortest_qualid_of_tactic kn in
+    Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined")
+  in
+  List.iter iter defs
 
-let vernac_create_hintdb local id b =
-  Auto.create_hint_db local id full_transparent_state b
+let vernac_declare_tactic_definition locality (x,def) =
+  let local = make_module_locality locality in
+  register_ltac local x def
 
-let vernac_remove_hints local dbs ids =
-  Auto.remove_hints local dbs (List.map Smartlocate.global_with_alias ids)
+let vernac_create_hintdb locality id b =
+  let local = make_module_locality locality in
+  Hints.create_hint_db local id full_transparent_state b
 
-let vernac_hints local lb h =
-  Auto.add_hints local lb (Auto.interp_hints h)
+let vernac_remove_hints locality dbs ids =
+  let local = make_module_locality locality in
+  Hints.remove_hints local dbs (List.map Smartlocate.global_with_alias ids)
 
-let vernac_syntactic_definition lid =
+let vernac_hints locality poly local lb h =
+  let local = enforce_module_locality locality local in
+  Hints.add_hints local lb (Hints.interp_hints poly h)
+
+let vernac_syntactic_definition locality lid x local y =
   Dumpglob.dump_definition lid false "syndef";
-  Metasyntax.add_syntactic_definition (snd lid)
+  let local = enforce_module_locality locality local in
+  Metasyntax.add_syntactic_definition (snd lid) x local y
 
-let vernac_declare_implicits local r = function
+let vernac_declare_implicits locality r l =
+  let local = make_section_locality locality in
+  match l with
   | [] ->
       Impargs.declare_implicits local (smart_global r)
   | _::_ as imps ->
       Impargs.declare_manual_implicits local (smart_global r) ~enriching:false
 	(List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps)
 
-let vernac_declare_arguments local r l nargs flags =
+let vernac_declare_arguments locality r l nargs flags =
   let extra_scope_flag = List.mem `ExtraScopes flags in
   let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
   let names, rest = List.hd names, List.tl names in
   let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in
-  if List.exists ((<>) names) rest then
+  if List.exists (fun na -> not (List.equal Name.equal na names)) rest then
     error "All arguments lists must declare the same names.";
-  if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then
-    error "Arguments names must be distinct.";
+  if not (List.distinct_f Name.compare (List.filter ((!=) Anonymous) names))
+  then error "Arguments names must be distinct.";
   let sr = smart_global r in
   let inf_names =
-    Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in
-  let string_of_name = function Anonymous -> "_" | Name id -> string_of_id id in
+    let ty = Global.type_of_global_unsafe sr in
+      Impargs.compute_implicits_names (Global.env ()) ty in
+  let string_of_name = function Anonymous -> "_" | Name id -> Id.to_string id in
   let rec check li ld ls = match li, ld, ls with
     | [], [], [] -> ()
     | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls
@@ -866,18 +1042,23 @@ let vernac_declare_arguments local r l nargs flags =
        (String.concat ", " (List.map string_of_name l)) ^ ".")
     | _::li, _::ld, _::ls -> check li ld ls 
     | _ -> assert false in
-  if l <> [[]] then
-    List.iter2 (fun l -> check inf_names l) (names :: rest) scopes;
+  let () = match l with
+  | [[]] -> ()
+  | _ ->
+    List.iter2 (fun l -> check inf_names l) (names :: rest) scopes
+  in
   (* we take extra scopes apart, and we check they are consistent *)
   let l, scopes = 
     let scopes, rest = List.hd scopes, List.tl scopes in
-    if List.exists (List.exists ((<>) None)) rest then
+    if List.exists (List.exists ((!=) None)) rest then
       error "Notation scopes can be given only once";
     if not extra_scope_flag then l, scopes else
-    let l, _ = List.split (List.map (list_chop (List.length inf_names)) l) in
+    let l, _ = List.split (List.map (List.chop (List.length inf_names)) l) in
     l, scopes in
   (* we interpret _ as the inferred names *)
-  let l = if l = [[]] then l else
+  let l = match l with
+  | [[]] -> l
+  | _ ->
     let name_anons = function
       | (Anonymous, a,b,c,d), Name id -> Name id, a,b,c,d
       | x, _ -> x in
@@ -885,81 +1066,103 @@ let vernac_declare_arguments local r l nargs flags =
   let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
   let renamed_arg = ref None in
   let set_renamed a b =
-    if !renamed_arg = None && a <> b then renamed_arg := Some(b,a) in
+    if Option.is_empty !renamed_arg && not (Id.equal a b) then renamed_arg := Some(b,a) in
   let pr_renamed_arg () = match !renamed_arg with None -> ""
     | Some (o,n) ->
        "\nArgument "^string_of_id o ^" renamed to "^string_of_id n^"." in
   let some_renaming_specified =
-    try Arguments_renaming.arguments_names sr <> names_decl
+    try
+      let names = Arguments_renaming.arguments_names sr in
+      not (List.equal (List.equal Name.equal) names names_decl)
     with Not_found -> false in
   let some_renaming_specified, implicits =
-    if l = [[]] then false, [[]] else
-    Util.list_fold_map (fun sr il ->
-      let sr', impl = Util.list_fold_map (fun b -> function
+    match l with
+    | [[]] -> false, [[]]
+    | _ ->
+    List.fold_map (fun sr il ->
+      let sr', impl = List.fold_map (fun b -> function
         | (Anonymous, _,_, true, max), Name id -> assert false
         | (Name x, _,_, true, _), Anonymous ->
-            error ("Argument "^string_of_id x^" cannot be declared implicit.")
+            error ("Argument "^Id.to_string x^" cannot be declared implicit.")
         | (Name iid, _,_, true, max), Name id ->
            set_renamed iid id;
-           b || iid <> id, Some (ExplByName id, max, false)
+           b || not (Id.equal iid id), Some (ExplByName id, max, false)
         | (Name iid, _,_, _, _), Name id ->
            set_renamed iid id;
-           b || iid <> id, None
+           b || not (Id.equal iid id), None
         | _ -> b, None)
         sr (List.combine il inf_names) in
-      sr || sr', Util.list_map_filter (fun x -> x) impl)
+      sr || sr', List.map_filter (fun x -> x) impl)
       some_renaming_specified l in
   if some_renaming_specified then
     if not (List.mem `Rename flags) then
       error ("To rename arguments the \"rename\" flag must be specified."
         ^ pr_renamed_arg ())
-    else Arguments_renaming.rename_arguments local sr names_decl;
+    else
+      Arguments_renaming.rename_arguments
+        (make_section_locality locality) sr names_decl;
   (* All other infos are in the first item of l *)
   let l = List.hd l in
-  let some_implicits_specified = implicits <> [[]] in
+  let some_implicits_specified = match implicits with
+  | [[]] -> false | _ -> true in
   let scopes = List.map (function
     | None -> None
-    | Some (o, k) -> 
-        try Some(ignore(Notation.find_scope k); k)
-        with e when Errors.noncritical e ->
+    | Some (o, k) ->
+        try ignore (Notation.find_scope k); Some k
+        with UserError _ ->
           Some (Notation.find_delimiters_scope o k)) scopes
   in
-  let some_scopes_specified = List.exists ((<>) None) scopes in
+  let some_scopes_specified = List.exists ((!=) None) scopes in
   let rargs =
-    Util.list_map_filter (function (n, true) -> Some n | _ -> None)
-      (Util.list_map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in
+    Util.List.map_filter (function (n, true) -> Some n | _ -> None)
+      (Util.List.map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in
   if some_scopes_specified || List.mem `ClearScopes flags then
-    vernac_arguments_scope local r scopes;
+    vernac_arguments_scope locality r scopes;
   if not some_implicits_specified && List.mem `DefaultImplicits flags then
-    vernac_declare_implicits local r []
+    vernac_declare_implicits locality r []
   else if some_implicits_specified || List.mem `ClearImplicits flags then
-    vernac_declare_implicits local r implicits;
+    vernac_declare_implicits locality r implicits;
   if nargs >= 0 && nargs < List.fold_left max 0 rargs then
     error "The \"/\" option must be placed after the last \"!\".";
   let rec narrow = function
-    | #Tacred.simpl_flag as x :: tl -> x :: narrow tl
+    | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl
     | [] -> [] | _ :: tl -> narrow tl in
   let flags = narrow flags in
-  if rargs <> [] || nargs >= 0 || flags <> [] then
+  let some_simpl_flags_specified =
+    not (List.is_empty rargs) || nargs >= 0 || not (List.is_empty flags) in
+  if some_simpl_flags_specified then begin
     match sr with
     | ConstRef _ as c ->
-       Tacred.set_simpl_behaviour local c (rargs, nargs, flags)
+       Reductionops.ReductionBehaviour.set
+         (make_section_locality locality) c (rargs, nargs, flags)
     | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.")
+  end;
+  if not (some_renaming_specified ||
+          some_implicits_specified ||
+          some_scopes_specified ||
+          some_simpl_flags_specified) &&
+     List.length flags = 0 then
+    msg_warning (strbrk "This command is just asserting the number and names of arguments of " ++ pr_global sr ++ strbrk". If this is what you want add ': assert' to silence the warning. If you want to clear implicit arguments add ': clear implicits'. If you want to clear notation scopes add ': clear scopes'")
+
+
+let default_env () = {
+  Notation_term.ninterp_var_type = Id.Map.empty;
+  ninterp_rec_vars = Id.Map.empty;
+  ninterp_only_parse = false;
+}
 
 let vernac_reserve bl =
   let sb_decl = (fun (idl,c) ->
-    let t = Constrintern.interp_type Evd.empty (Global.env()) c in
-    let t = Detyping.detype false [] [] t in
-    let t = aconstr_of_glob_constr [] [] t in
+    let env = Global.env() in
+    let t,ctx = Constrintern.interp_type env Evd.empty c in
+    let t = Detyping.detype false [] env Evd.empty t in
+    let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in
     Reserve.declare_reserved_type idl t)
   in List.iter sb_decl bl
 
-let vernac_generalizable = Implicit_quantifiers.declare_generalizable
-
-let make_silent_if_not_pcoq b =
-  if !pcoq <> None then
-    error "Turning on/off silent flag is not supported in Pcoq mode."
-  else make_silent b
+let vernac_generalizable locality =
+  let local = make_non_locality locality in
+  Implicit_quantifiers.declare_generalizable local
 
 let _ =
   declare_bool_option
@@ -968,7 +1171,7 @@ let _ =
       optname  = "silent";
       optkey   = ["Silent"];
       optread  = is_silent;
-      optwrite = make_silent_if_not_pcoq }
+      optwrite = make_silent }
 
 let _ =
   declare_bool_option
@@ -1048,8 +1251,8 @@ let _ =
       optdepr  = false;
       optname  = "printing of existential variable instances";
       optkey   = ["Printing";"Existential";"Instances"];
-      optread  = (fun () -> !Constrextern.print_evar_arguments);
-      optwrite = (:=) Constrextern.print_evar_arguments }
+      optread  = (fun () -> !Detyping.print_evar_arguments);
+      optwrite = (:=) Detyping.print_evar_arguments }
 
 let _ =
   declare_bool_option
@@ -1109,6 +1312,24 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
+      optname  = "use of the program extension";
+      optkey   = ["Program";"Mode"];
+      optread  = (fun () -> !Flags.program_mode);
+      optwrite = (fun b -> Flags.program_mode:=b) }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
+      optname  = "universe polymorphism";
+      optkey   = ["Universe"; "Polymorphism"];
+      optread  = Flags.is_universe_polymorphism;
+      optwrite = Flags.make_universe_polymorphism }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
       optname  = "use of virtual machine inside the kernel";
       optkey   = ["Virtual";"Machine"];
       optread  = (fun () -> Vconv.use_vm ());
@@ -1129,6 +1350,15 @@ let _ =
   declare_bool_option
     { optsync  = true;
       optdepr  = false;
+      optname  = "kernel term sharing";
+      optkey   = ["Kernel"; "Term"; "Sharing"];
+      optread  = (fun () -> !Closure.share);
+      optwrite = (fun b -> Closure.share := b) }
+
+let _ =
+  declare_bool_option
+    { optsync  = true;
+      optdepr  = false;
       optname  = "use of boxed values";
       optkey   = ["Boxed";"Values"];
       optread  = (fun _ -> not (Vm.transp_values ()));
@@ -1191,7 +1421,7 @@ let _ =
       optdepr  = false;
       optname  = "Ltac debug";
       optkey   = ["Ltac";"Debug"];
-      optread  = (fun () -> get_debug () <> Tactic_debug.DebugOff);
+      optread  = (fun () -> get_debug () != Tactic_debug.DebugOff);
       optwrite = vernac_debug }
 
 let _ =
@@ -1203,15 +1433,27 @@ let _ =
       optread  = (fun () -> !Constrintern.parsing_explicit);
       optwrite = (fun b ->  Constrintern.parsing_explicit := b) }
 
-let vernac_set_opacity local str =
+let vernac_set_strategy locality l =
+  let local = make_locality locality in
+  let glob_ref r =
+    match smart_global r with
+      | ConstRef sp -> EvalConstRef sp
+      | VarRef id -> EvalVarRef id
+      | _ -> error
+          "cannot set an inductive type or a constructor as transparent" in
+  let l = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) l in
+  Redexpr.set_strategy local l
+
+let vernac_set_opacity locality (v,l) =
+  let local = make_non_locality locality in
   let glob_ref r =
     match smart_global r with
       | ConstRef sp -> EvalConstRef sp
       | VarRef id -> EvalVarRef id
       | _ -> error
           "cannot set an inductive type or a constructor as transparent" in
-  let str = List.map (fun (lev,ql) -> (lev,List.map glob_ref ql)) str in
-  Redexpr.set_strategy local str
+  let l = List.map glob_ref l in
+  Redexpr.set_strategy local [v,l]
 
 let vernac_set_option locality key = function
   | StringValue s -> set_string_option_value_gen locality key s
@@ -1255,91 +1497,138 @@ let get_current_context_of_args = function
   | None -> get_current_context ()
 
 let vernac_check_may_eval redexp glopt rc =
-  let module P = Pretype_errors in
   let (sigma, env) = get_current_context_of_args glopt in
-  let sigma', c = interp_open_constr sigma env rc in
+  let sigma', c = interp_open_constr env sigma rc in
   let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in
+  Evarconv.check_problems_are_solved env sigma';
+  let sigma',nf = Evarutil.nf_evars_and_universes sigma' in
+  let uctx = Evd.universe_context sigma' in
+  let env = Environ.push_context uctx env in
+  let c = nf c in
   let j =
-    try
-      Evarutil.check_evars env sigma sigma' c;
-      Arguments_renaming.rename_typing env c
-    with P.PretypeError (_,_,P.UnsolvableImplicit _)
-      | Compat.Loc.Exc_located (_,P.PretypeError (_,_,P.UnsolvableImplicit _)) ->
-      Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) in
+    if Evarutil.has_undefined_evars sigma' c then
+      Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c)
+    else
+      (* OK to call kernel which does not support evars *)
+      Arguments_renaming.rename_typing env c in
   match redexp with
     | None ->
-	if !pcoq <> None then (Option.get !pcoq).print_check env j
-	else msg (print_judgment env j)
+        let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in
+        let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in
+	msg_notice (print_judgment env sigma' j ++
+                    (if l != Evar.Set.empty then
+                        let l = Evar.Set.fold (fun ev -> Evar.Map.add ev (Evarutil.nf_evar_info sigma' (Evd.find sigma' ev))) l Evar.Map.empty in
+                        (fnl () ++ str "where" ++ fnl () ++ pr_evars sigma' l)
+                     else
+                        mt ()) ++
+                     Printer.pr_universe_ctx uctx)
     | Some r ->
-        Tacinterp.dump_glob_red_expr r;
+        Tacintern.dump_glob_red_expr r;
         let (sigma',r_interp) = interp_redexp env sigma' r in
-	let redfun = fst (reduction_of_red_expr r_interp) in
-	if !pcoq <> None
-	then (Option.get !pcoq).print_eval redfun env sigma' rc j
-	else msg (print_eval redfun env sigma' rc j)
+	let redfun env evm c = snd (fst (reduction_of_red_expr env r_interp) env evm c) in
+	msg_notice (print_eval redfun env sigma' rc j)
 
 let vernac_declare_reduction locality s r =
-  declare_red_expr locality s (snd (interp_redexp (Global.env()) Evd.empty r))
+  let local = make_locality locality in
+  declare_red_expr local s (snd (interp_redexp (Global.env()) Evd.empty r))
 
   (* The same but avoiding the current goal context if any *)
 let vernac_global_check c =
-  let evmap = Evd.empty in
   let env = Global.env() in
-  let c = interp_constr evmap env c in
+  let sigma = Evd.from_env env in
+  let c,ctx = interp_constr env sigma c in
   let senv = Global.safe_env() in
+  let cstrs = snd (Evd.evar_universe_context_set ctx) in
+  let senv = Safe_typing.add_constraints cstrs senv in
   let j = Safe_typing.typing senv c in
-  msg (print_safe_judgment env j)
+  let env = Safe_typing.env_of_safe_env senv in
+    msg_notice (print_safe_judgment env sigma j)
+
 
+let get_nth_goal n =
+  let pf = get_pftreestate() in
+  let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in
+  let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in
+  gl
+  
+exception NoHyp
+(* Printing "About" information of a hypothesis of the current goal.
+   We only print the type and a small statement to this comes from the
+   goal. Precondition: there must be at least one current goal. *)
+let print_about_hyp_globs ref_or_by_not glnumopt =
+  try
+    let gl,id =
+      match glnumopt,ref_or_by_not with
+      | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *)
+	 (try get_nth_goal 1,id with _ -> raise NoHyp)
+      | Some n,AN (Ident (_loc,id)) ->  (* goal number given, catch if wong *)
+	 (try get_nth_goal n,id
+	  with
+	    Failure _ -> Errors.error ("No such goal: "^string_of_int n^"."))
+      | _ , _ -> raise NoHyp in
+    let hyps = pf_hyps gl in
+    let (id,bdyopt,typ) = Context.lookup_named id hyps in
+    let natureofid = match bdyopt with
+      | None -> "Hypothesis"
+      | Some bdy ->"Constant (let in)" in
+    v 0 (str (Id.to_string id) ++ str":" ++ pr_constr typ ++ fnl() ++ fnl()
+	 ++ str natureofid ++ str " of the goal context.")
+  with (* fallback to globals *)
+    | NoHyp | Not_found -> print_about ref_or_by_not
+
+	       
 let vernac_print = function
-  | PrintTables -> print_tables ()
-  | PrintFullContext-> msg (print_full_context_typ ())
-  | PrintSectionContext qid -> msg (print_sec_context_typ qid)
-  | PrintInspect n -> msg (inspect n)
-  | PrintGrammar ent -> Metasyntax.print_grammar ent
-  | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir
-  | PrintModules -> msg (print_modules ())
+  | PrintTables -> msg_notice (print_tables ())
+  | PrintFullContext-> msg_notice (print_full_context_typ ())
+  | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid)
+  | PrintInspect n -> msg_notice (inspect n)
+  | PrintGrammar ent -> msg_notice (Metasyntax.pr_grammar ent)
+  | PrintLoadPath dir -> (* For compatibility ? *) msg_notice (print_loadpath dir)
+  | PrintModules -> msg_notice (print_modules ())
   | PrintModule qid -> print_module qid
   | PrintModuleType qid -> print_modtype qid
-  | PrintMLLoadPath -> Mltop.print_ml_path ()
-  | PrintMLModules -> Mltop.print_ml_modules ()
-  | PrintName qid ->
-      if !pcoq <> None then (Option.get !pcoq).print_name qid
-      else msg (print_name qid)
-  | PrintGraph -> ppnl (Prettyp.print_graph())
-  | PrintClasses -> ppnl (Prettyp.print_classes())
-  | PrintTypeClasses -> ppnl (Prettyp.print_typeclasses())
-  | PrintInstances c -> ppnl (Prettyp.print_instances (smart_global c))
-  | PrintLtac qid -> ppnl (Tacinterp.print_ltac (snd (qualid_of_reference qid)))
-  | PrintCoercions -> ppnl (Prettyp.print_coercions())
+  | PrintNamespace ns -> print_namespace ns
+  | PrintMLLoadPath -> msg_notice (Mltop.print_ml_path ())
+  | PrintMLModules -> msg_notice (Mltop.print_ml_modules ())
+  | PrintDebugGC -> msg_notice (Mltop.print_gc ())
+  | PrintName qid -> dump_global qid; msg_notice (print_name qid)
+  | PrintGraph -> msg_notice (Prettyp.print_graph())
+  | PrintClasses -> msg_notice (Prettyp.print_classes())
+  | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses())
+  | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c))
+  | PrintLtac qid -> msg_notice (Tacintern.print_ltac (snd (qualid_of_reference qid)))
+  | PrintCoercions -> msg_notice (Prettyp.print_coercions())
   | PrintCoercionPaths (cls,clt) ->
-      ppnl (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
-  | PrintCanonicalConversions -> ppnl (Prettyp.print_canonical_projections ())
+      msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt))
+  | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ())
   | PrintUniverses (b, None) ->
     let univ = Global.universes () in
     let univ = if b then Univ.sort_universes univ else univ in
-    pp (Univ.pr_universes univ)
+    msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ)
   | PrintUniverses (b, Some s) -> dump_universes b s
-  | PrintHint r -> Auto.print_hint_ref (smart_global r)
-  | PrintHintGoal -> Auto.print_applicable_hint ()
-  | PrintHintDbName s -> Auto.print_hint_db_by_name s
-  | PrintRewriteHintDbName s -> Autorewrite.print_rewrite_hintdb s
-  | PrintHintDb -> Auto.print_searchtable ()
+  | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r))
+  | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ())
+  | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s)
+  | PrintRewriteHintDbName s -> msg_notice (Autorewrite.print_rewrite_hintdb s)
+  | PrintHintDb -> msg_notice (Hints.pr_searchtable ())
   | PrintScopes ->
-      pp (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
+      msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr))
   | PrintScope s ->
-      pp (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s)
+      msg_notice (Notation.pr_scope (Constrextern.without_symbols pr_lglob_constr) s)
   | PrintVisibility s ->
-      pp (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
-  | PrintAbout qid -> 
-    msg (print_about qid)
-  | PrintImplicit qid -> 
-    dump_global qid; msg (print_impargs qid)
-  | PrintAssumptions (o,r) ->
+      msg_notice (Notation.pr_visibility (Constrextern.without_symbols pr_lglob_constr) s)
+  | PrintAbout (ref_or_by_not,glnumopt) ->
+     msg_notice (print_about_hyp_globs ref_or_by_not glnumopt)
+  | PrintImplicit qid ->
+    dump_global qid; msg_notice (print_impargs qid)
+  | PrintAssumptions (o,t,r) ->
       (* Prints all the axioms and section variables used by a term *)
-      let cstr = constr_of_global (smart_global r) in
-      let st = Conv_oracle.get_transp_state () in
-      let nassums = Assumptions.assumptions st ~add_opaque:o cstr in
-      msg (Printer.pr_assumptionset (Global.env ()) nassums)
+      let cstr = printable_constr_of_global (smart_global r) in
+      let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in
+      let nassums =
+	Assumptions.assumptions st ~add_opaque:o ~add_transparent:t cstr in
+      msg_notice (Printer.pr_assumptionset (Global.env ()) nassums)
+  | PrintStrategy r -> print_strategy r
 
 let global_module r =
   let (loc,qid) = qualid_of_reference r in
@@ -1354,177 +1643,89 @@ let interp_search_restriction = function
 
 open Search
 
-let is_ident s = try ignore (check_ident s); true with UserError _ -> false
-
-let interp_search_about_item = function
+let interp_search_about_item env =
+  function
   | SearchSubPattern pat ->
-      let _,pat = intern_constr_pattern Evd.empty (Global.env()) pat in
+      let _,pat = intern_constr_pattern env pat in
       GlobSearchSubPattern pat
-  | SearchString (s,None) when is_ident s ->
+  | SearchString (s,None) when Id.is_valid s ->
       GlobSearchString s
   | SearchString (s,sc) ->
       try
 	let ref =
-	  Notation.interp_notation_as_global_reference dummy_loc
+	  Notation.interp_notation_as_global_reference Loc.ghost
 	    (fun _ -> true) s sc in
 	GlobSearchSubPattern (Pattern.PRef ref)
       with UserError _ ->
 	error ("Unable to interp \""^s^"\" either as a reference or \
           	as an identifier component")
 
-let vernac_search s r =
+let vernac_search s gopt r =
   let r = interp_search_restriction r in
-  if !pcoq <> None then (Option.get !pcoq).search s r else
+  let env,gopt =
+    match gopt with | None ->
+      (* 1st goal by default if it exists, otherwise no goal at all *)
+      (try snd (Pfedit.get_goal_context 1) , Some 1
+       with _ -> Global.env (),None)
+    (* if goal selector is given and wrong, then let exceptions be raised. *)
+    | Some g -> snd (Pfedit.get_goal_context g) , Some g
+  in
+  let get_pattern c = snd (intern_constr_pattern env c) in
   match s with
   | SearchPattern c ->
-      let (_,c) = interp_open_constr_patvar Evd.empty (Global.env()) c in
-      Search.search_pattern c r
+      msg_notice (Search.search_pattern gopt (get_pattern c) r)
   | SearchRewrite c ->
-      let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in
-      Search.search_rewrite pat r
+      msg_notice (Search.search_rewrite gopt (get_pattern c) r)
   | SearchHead c ->
-      let _,pat = interp_open_constr_patvar Evd.empty (Global.env()) c in
-      Search.search_by_head pat r
+      msg_notice (Search.search_by_head gopt (get_pattern c) r)
   | SearchAbout sl ->
-      Search.search_about (List.map (on_snd interp_search_about_item) sl) r
+     msg_notice (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r)
 
 let vernac_locate = function
-  | LocateTerm (Genarg.AN qid) -> msgnl (print_located_qualid qid)
-  | LocateTerm (Genarg.ByNotation (_,ntn,sc)) ->
-      ppnl
+  | LocateAny (AN qid) -> msg_notice (print_located_qualid qid)
+  | LocateTerm (AN qid) -> msg_notice (print_located_term qid)
+  | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *)
+  | LocateTerm (ByNotation (_, ntn, sc)) ->
+      msg_notice
         (Notation.locate_notation
           (Constrextern.without_symbols pr_lglob_constr) ntn sc)
   | LocateLibrary qid -> print_located_library qid
-  | LocateModule qid -> print_located_module qid
-  | LocateTactic qid -> print_located_tactic qid
-  | LocateFile f -> locate_file f
-
-(****************)
-(* Backtracking *)
-
-(** NB: these commands are now forbidden in non-interactive use,
-    e.g. inside VernacLoad, VernacList, ... *)
-
-let vernac_backto lbl =
-  try
-    let lbl' = Backtrack.backto lbl in
-    if lbl <> lbl' then
-      Pp.msg_warning
-	(str "Actually back to state "++ Pp.int lbl' ++ str ".");
-    try_print_subgoals ()
-  with Backtrack.Invalid -> error "Invalid backtrack."
-
-let vernac_back n =
-  try
-    let extra = Backtrack.back n in
-    if extra <> 0 then
-      Pp.msg_warning
-	(str "Actually back by " ++ Pp.int (extra+n) ++ str " steps.");
-    try_print_subgoals ()
-  with Backtrack.Invalid -> error "Invalid backtrack."
-
-let vernac_reset_name id =
-  try
-    let globalized =
-      try
-	let gr = Smartlocate.global_with_alias (Ident id) in
-	Dumpglob.add_glob (fst id) gr;
-	true
-      with e when Errors.noncritical e -> false in
-
-    if not globalized then begin
-       try begin match Lib.find_opening_node (snd id) with
-          | Lib.OpenedSection _ -> Dumpglob.dump_reference (fst id)
-              (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec";
-          (* Might be nice to implement module cases, too.... *)
-          | _ -> ()
-       end with UserError _ -> ()
-    end;
-
-    if Backtrack.is_active () then
-      (Backtrack.reset_name id; try_print_subgoals ())
-    else
-      (* When compiling files, Reset is now allowed again
-	 as asked by A. Chlipala. we emulate a simple reset,
-	 that discards all proofs. *)
-      let lbl = Lib.label_before_name id in
-      Pfedit.delete_all_proofs ();
-      Pp.msg_warning (str "Reset command occurred in non-interactive mode.");
-      Lib.reset_label lbl
-  with Backtrack.Invalid | Not_found -> error "Invalid Reset."
-
-
-let vernac_reset_initial () =
-  if Backtrack.is_active () then
-    Backtrack.reset_initial ()
-  else begin
-    Pp.msg_warning (str "Reset command occurred in non-interactive mode.");
-    Lib.reset_label Lib.first_command_label
-  end
-
-(* For compatibility with ProofGeneral: *)
-
-let vernac_backtrack snum pnum naborts =
-  Backtrack.backtrack snum pnum naborts;
-  try_print_subgoals ()
-
+  | LocateModule qid -> msg_notice (print_located_module qid)
+  | LocateTactic qid -> msg_notice (print_located_tactic qid)
+  | LocateFile f -> msg_notice (locate_file f)
+
+let vernac_register id r =
+ if Pfedit.refining () then
+    error "Cannot register a primitive while in proof editing mode.";
+  let t = (Constrintern.global_reference (snd id)) in
+  if not (isConst t) then
+    error "Register inline: a constant is expected";
+  let kn = destConst t in
+  match r with
+  | RegisterInline -> Global.register_inline (Univ.out_punivs kn)
 
 (********************)
 (* Proof management *)
 
-let vernac_abort = function
-  | None ->
-      Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
-      delete_current_proof ();
-      if_verbose message "Current goal aborted";
-      if !pcoq <> None then (Option.get !pcoq).abort ""
-  | Some id ->
-      Backtrack.mark_unreachable [snd id];
-      delete_proof id;
-      let s = string_of_id (snd id) in
-      if_verbose message ("Goal "^s^" aborted");
-      if !pcoq <> None then (Option.get !pcoq).abort s
-
-let vernac_abort_all () =
-  if refining() then begin
-    Backtrack.mark_unreachable (Pfedit.get_all_proof_names ());
-    delete_all_proofs ();
-    message "Current goals aborted"
-  end else
-    error "No proof-editing in progress."
-
-let vernac_restart () =
-  Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
-  restart_proof(); print_subgoals ()
-
-let vernac_undo n =
-  let d = Pfedit.current_proof_depth () - n in
-  Backtrack.mark_unreachable ~after:d [Pfedit.get_current_proof_name ()];
-  Pfedit.undo n; print_subgoals ()
-
-let vernac_undoto n =
-  Backtrack.mark_unreachable ~after:n [Pfedit.get_current_proof_name ()];
-  Pfedit.undo_todepth n;
-  print_subgoals ()
-
 let vernac_focus gln =
-  let p = Proof_global.give_me_the_proof () in
-  let n = match gln with None -> 1 | Some n -> n in
-  if n = 0 then
-    Util.error "Invalid goal number: 0. Goal numbering starts with 1."
-  else
-    Proof.focus focus_command_cond () n p; print_subgoals ()
+  Proof_global.simple_with_current_proof (fun _ p ->
+    match gln with
+      | None -> Proof.focus focus_command_cond () 1 p
+      | Some 0 ->
+         Errors.error "Invalid goal number: 0. Goal numbering starts with 1."
+      | Some n ->
+         Proof.focus focus_command_cond () n p)
 
   (* Unfocuses one step in the focus stack. *)
 let vernac_unfocus () =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.unfocus command_focus p; print_subgoals ()
+  Proof_global.simple_with_current_proof
+    (fun _ p -> Proof.unfocus command_focus p ())
 
 (* Checks that a proof is fully unfocused. Raises an error if not. *)
 let vernac_unfocused () =
   let p = Proof_global.give_me_the_proof () in
   if Proof.unfocused p then
-    msg (str"The proof is indeed fully unfocused.")
+    msg_notice (str"The proof is indeed fully unfocused.")
   else
     error "The proof is not fully unfocused."
 
@@ -1539,44 +1740,39 @@ let subproof_kind = Proof.new_focus_kind ()
 let subproof_cond = Proof.done_cond subproof_kind
 
 let vernac_subproof gln =
-  let p = Proof_global.give_me_the_proof () in
-  begin match gln with
-  | None -> Proof.focus subproof_cond () 1 p
-  | Some n -> Proof.focus subproof_cond () n p
-  end ;
-  print_subgoals ()
+  Proof_global.simple_with_current_proof (fun _ p ->
+    match gln with
+    | None -> Proof.focus subproof_cond () 1 p
+    | Some n -> Proof.focus subproof_cond () n p)
 
 let vernac_end_subproof () =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.unfocus subproof_kind p ; print_subgoals ()
-
+  Proof_global.simple_with_current_proof (fun _ p ->
+    Proof.unfocus subproof_kind p ())
 
 let vernac_bullet (bullet:Proof_global.Bullet.t) =
-  let p = Proof_global.give_me_the_proof () in
-  Proof.transaction p 
-    (fun () -> Proof_global.Bullet.put p bullet);
-  (* Makes the focus visible in emacs by re-printing the goal. *)
-  if !Flags.print_emacs then print_subgoals ()
-
+  Proof_global.simple_with_current_proof (fun _ p ->
+    Proof_global.Bullet.put p bullet)
 
 let vernac_show = function
   | ShowGoal goalref ->
-      if !pcoq <> None then (Option.get !pcoq).show_goal goalref
-      else msg (match goalref with
-	| OpenSubgoals -> pr_open_subgoals ()
-	| NthGoal n -> pr_nth_open_subgoal n
-        | GoalId id -> pr_goal_by_id id)
+    let info = match goalref with
+      | OpenSubgoals -> pr_open_subgoals ()
+      | NthGoal n -> pr_nth_open_subgoal n
+      | GoalId id -> pr_goal_by_id id
+    in
+    msg_notice info
   | ShowGoalImplicitly None ->
-      Constrextern.with_implicits msg (pr_open_subgoals ())
+      Constrextern.with_implicits msg_notice (pr_open_subgoals ())
   | ShowGoalImplicitly (Some n) ->
-      Constrextern.with_implicits msg (pr_nth_open_subgoal n)
+      Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n)
   | ShowProof -> show_proof ()
   | ShowNode -> show_node ()
-  | ShowScript -> show_script ()
+  | ShowScript -> Stm.show_script ()
   | ShowExistentials -> show_top_evars ()
+  | ShowUniverses -> show_universes ()
   | ShowTree -> show_prooftree ()
   | ShowProofNames ->
-      msgnl (prlist_with_sep pr_spc pr_id (Pfedit.get_all_proof_names()))
+      msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names()))
   | ShowIntros all -> show_intro all
   | ShowMatch id -> show_match id
   | ShowThesis -> show_thesis ()
@@ -1594,34 +1790,82 @@ let vernac_check_guard () =
     with UserError(_,s) ->
       (str ("Condition violated: ") ++s)
   in
-  msgnl message
-
-let interp c = match c with
-  (* Control (done in vernac) *)
-  | (VernacTime _|VernacList _|VernacLoad _|VernacTimeout _|VernacFail _) ->
-      assert false
+  msg_notice message
+
+exception End_of_input
+
+let vernac_load interp fname =
+  let parse_sentence = Flags.with_option Flags.we_are_parsing
+    (fun po ->
+    match Pcoq.Gram.entry_parse Pcoq.main_entry po with
+      | Some x -> x
+      | None -> raise End_of_input) in
+  let open_utf8_file_in fname =
+    let is_bom s =
+      Int.equal (Char.code s.[0]) 0xEF &&
+      Int.equal (Char.code s.[1]) 0xBB &&
+      Int.equal (Char.code s.[2]) 0xBF
+    in
+    let in_chan = open_in fname in
+    let s = "   " in
+    if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0;
+    in_chan in
+  let fname =
+    Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in
+  let fname = CUnix.make_suffix fname ".v" in
+  let input =
+    let paths = Loadpath.get_paths () in
+    let _,longfname =
+      System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in
+    let in_chan = open_utf8_file_in longfname in
+    Pcoq.Gram.parsable (Stream.of_channel in_chan) in
+  try while true do interp (snd (parse_sentence input)) done
+  with End_of_input -> ()
+
+
+(* "locality" is the prefix "Local" attribute, while the "local" component
+ * is the outdated/deprecated "Local" attribute of some vernacular commands
+ * still parsed as the obsolete_locality grammar entry for retrocompatibility *)
+let interp ?proof locality poly c =
+  prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c));
+  match c with
+  (* Done later in this file *)
+  | VernacLoad _ -> assert false
+  | VernacFail _ -> assert false
+  | VernacTime _ -> assert false
+  | VernacTimeout _ -> assert false
+  | VernacStm _ -> assert false
+
+  | VernacError e -> raise e
 
   (* Syntax *)
-  | VernacTacticNotation (n,r,e) -> Metasyntax.add_tactic_notation (n,r,e)
-  | VernacSyntaxExtension (lcl,sl) -> vernac_syntax_extension lcl sl
+  | VernacTacticNotation (n,r,e) ->
+      Metasyntax.add_tactic_notation (make_module_locality locality,n,r,e)
+  | VernacSyntaxExtension (local,sl) ->
+      vernac_syntax_extension locality local sl
   | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr
   | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl
-  | VernacOpenCloseScope sc -> vernac_open_close_scope sc
-  | VernacArgumentsScope (lcl,qid,scl) -> vernac_arguments_scope lcl qid scl
-  | VernacInfix (local,mv,qid,sc) -> vernac_infix local mv qid sc
-  | VernacNotation (local,c,infpl,sc) -> vernac_notation local c infpl sc
+  | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s
+  | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope locality qid scl
+  | VernacInfix (local,mv,qid,sc) -> vernac_infix locality local mv qid sc
+  | VernacNotation (local,c,infpl,sc) ->
+      vernac_notation locality local c infpl sc
+  | VernacNotationAddFormat(n,k,v) ->
+      Metasyntax.add_notation_extra_printing_rule n k v
 
   (* Gallina *)
-  | VernacDefinition (k,lid,d,f) -> vernac_definition k lid d f
-  | VernacStartTheoremProof (k,l,top,f) -> vernac_start_proof k l top f
-  | VernacEndProof e -> vernac_end_proof e
+  | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d
+  | VernacStartTheoremProof (k,l,top) -> vernac_start_proof poly k l top
+  | VernacEndProof e -> vernac_end_proof ?proof e
   | VernacExactProof c -> vernac_exact_proof c
-  | VernacAssumption (stre,nl,l) -> vernac_assumption stre l nl
-  | VernacInductive (finite,infer,l) -> vernac_inductive finite infer l
-  | VernacFixpoint l -> vernac_fixpoint l
-  | VernacCoFixpoint l -> vernac_cofixpoint l
+  | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl
+  | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l
+  | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l
+  | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l
   | VernacScheme l -> vernac_scheme l
   | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l
+  | VernacUniverse l -> vernac_universe l
+  | VernacConstraint l -> vernac_constraint l
 
   (* Modules *)
   | VernacDeclareModule (export,lid,bl,mtyo) ->
@@ -1637,29 +1881,31 @@ let interp c = match c with
 
   | VernacEndSegment lid -> vernac_end_segment lid
 
-  | VernacRequire (export,spec,qidl) -> vernac_require export spec qidl
+  | VernacNameSectionHypSet (lid, set) -> vernac_name_sec_hyp lid set
+
+  | VernacRequire (export, qidl) -> vernac_require export qidl
   | VernacImport (export,qidl) -> vernac_import export qidl
   | VernacCanonical qid -> vernac_canonical qid
-  | VernacCoercion (str,r,s,t) -> vernac_coercion str r s t
-  | VernacIdentityCoercion (str,(_,id),s,t) -> vernac_identity_coercion str id s t
+  | VernacCoercion (local,r,s,t) -> vernac_coercion locality poly local r s t
+  | VernacIdentityCoercion (local,(_,id),s,t) ->
+      vernac_identity_coercion locality poly local id s t
 
   (* Type classes *)
-  | VernacInstance (abst, glob, sup, inst, props, pri) ->
-      vernac_instance abst glob sup inst props pri
-  | VernacContext sup -> vernac_context sup
-  | VernacDeclareInstances (glob, ids) -> vernac_declare_instances glob ids
+  | VernacInstance (abst, sup, inst, props, pri) ->
+      vernac_instance abst locality poly sup inst props pri
+  | VernacContext sup -> vernac_context poly sup
+  | VernacDeclareInstances (ids, pri) -> vernac_declare_instances locality ids pri
   | VernacDeclareClass id -> vernac_declare_class id
 
   (* Solving *)
-  | VernacSolve (n,tac,b) -> vernac_solve n tac b
+  | VernacSolve (n,info,tac,b) -> vernac_solve n info tac b
   | VernacSolveExistential (n,c) -> vernac_solve_existential n c
 
   (* Auxiliary file and library management *)
-  | VernacRequireFrom (exp,spec,f) -> vernac_require_from exp spec f
   | VernacAddLoadPath (isrec,s,alias) -> vernac_add_loadpath isrec s alias
   | VernacRemoveLoadPath s -> vernac_remove_loadpath s
   | VernacAddMLPath (isrec,s) -> vernac_add_ml_path isrec s
-  | VernacDeclareMLModule (local, l) -> vernac_declare_ml_module local l
+  | VernacDeclareMLModule l -> vernac_declare_ml_module locality l
   | VernacChdir s -> vernac_chdir s
 
   (* State management *)
@@ -1667,45 +1913,52 @@ let interp c = match c with
   | VernacRestoreState s -> vernac_restore_state s
 
   (* Resetting *)
-  | VernacResetName id -> vernac_reset_name id
-  | VernacResetInitial -> vernac_reset_initial ()
-  | VernacBack n -> vernac_back n
-  | VernacBackTo n -> vernac_backto n
+  | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm")
+  | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
+  | VernacBack _ -> anomaly (str "VernacBack not handled by Stm")
+  | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
 
   (* Commands *)
-  | VernacDeclareTacticDefinition def -> vernac_declare_tactic_definition def
-  | VernacCreateHintDb (local,dbname,b) -> vernac_create_hintdb local dbname b
-  | VernacRemoveHints (local,dbnames,ids) -> vernac_remove_hints local dbnames ids
-  | VernacHints (local,dbnames,hints) -> vernac_hints local dbnames hints
-  | VernacSyntacticDefinition (id,c,l,b) ->vernac_syntactic_definition id c l b
-  | VernacDeclareImplicits (local,qid,l) ->vernac_declare_implicits local qid l
-  | VernacArguments (local, qid, l, narg, flags) -> vernac_declare_arguments local qid l narg flags 
+  | VernacDeclareTacticDefinition def ->
+      vernac_declare_tactic_definition locality def
+  | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b
+  | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids
+  | VernacHints (local,dbnames,hints) ->
+      vernac_hints locality poly local dbnames hints
+  | VernacSyntacticDefinition (id,c,local,b) ->
+      vernac_syntactic_definition locality  id c local b
+  | VernacDeclareImplicits (qid,l) ->
+      vernac_declare_implicits locality qid l
+  | VernacArguments (qid, l, narg, flags) ->
+      vernac_declare_arguments locality qid l narg flags 
   | VernacReserve bl -> vernac_reserve bl
-  | VernacGeneralizable (local,gen) -> vernac_generalizable local gen
-  | VernacSetOpacity (local,qidl) -> vernac_set_opacity local qidl
-  | VernacSetOption (locality,key,v) -> vernac_set_option locality key v
-  | VernacUnsetOption (locality,key) -> vernac_unset_option locality key
+  | VernacGeneralizable gen -> vernac_generalizable locality gen
+  | VernacSetOpacity qidl -> vernac_set_opacity locality qidl
+  | VernacSetStrategy l -> vernac_set_strategy locality l
+  | VernacSetOption (key,v) -> vernac_set_option locality key v
+  | VernacUnsetOption key -> vernac_unset_option locality key
   | VernacRemoveOption (key,v) -> vernac_remove_option key v
   | VernacAddOption (key,v) -> vernac_add_option key v
   | VernacMemOption (key,v) -> vernac_mem_option key v
   | VernacPrintOption key -> vernac_print_option key
   | VernacCheckMayEval (r,g,c) -> vernac_check_may_eval r g c
-  | VernacDeclareReduction (b,s,r) -> vernac_declare_reduction b s r
+  | VernacDeclareReduction (s,r) -> vernac_declare_reduction locality s r
   | VernacGlobalCheck c -> vernac_global_check c
   | VernacPrint p -> vernac_print p
-  | VernacSearch (s,r) -> vernac_search s r
+  | VernacSearch (s,g,r) -> vernac_search s g r
   | VernacLocate l -> vernac_locate l
-  | VernacComments l -> if_verbose message ("Comments ok\n")
+  | VernacRegister (id, r) -> vernac_register id r
+  | VernacComments l -> if_verbose msg_info (str "Comments ok\n")
   | VernacNop -> ()
 
   (* Proof management *)
-  | VernacGoal t -> vernac_start_proof Theorem [None,([],t,None)] false (fun _ _->())
-  | VernacAbort id -> vernac_abort id
-  | VernacAbortAll -> vernac_abort_all ()
-  | VernacRestart -> vernac_restart ()
-  | VernacUndo n -> vernac_undo n
-  | VernacUndoTo n -> vernac_undoto n
-  | VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts
+  | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false
+  | VernacAbort id -> anomaly (str "VernacAbort not handled by Stm")
+  | VernacAbortAll -> anomaly (str "VernacAbortAll not handled by Stm")
+  | VernacRestart -> anomaly (str "VernacRestart not handled by Stm")
+  | VernacUndo _ -> anomaly (str "VernacUndo not handled by Stm")
+  | VernacUndoTo _ -> anomaly (str "VernacUndoTo not handled by Stm")
+  | VernacBacktrack _ -> anomaly (str "VernacBacktrack not handled by Stm")
   | VernacFocus n -> vernac_focus n
   | VernacUnfocus -> vernac_unfocus ()
   | VernacUnfocused -> vernac_unfocused ()
@@ -1714,17 +1967,182 @@ let interp c = match c with
   | VernacEndSubproof -> vernac_end_subproof ()
   | VernacShow s -> vernac_show s
   | VernacCheckGuard -> vernac_check_guard ()
-  | VernacProof (None, None) -> print_subgoals ()
-  | VernacProof (Some tac, None) -> vernac_set_end_tac tac ; print_subgoals ()
-  | VernacProof (None, Some l) -> vernac_set_used_variables l ; print_subgoals ()
+  | VernacProof (None, None) -> ()
+  | VernacProof (Some tac, None) -> vernac_set_end_tac tac
+  | VernacProof (None, Some l) -> vernac_set_used_variables l
   | VernacProof (Some tac, Some l) -> 
-      vernac_set_end_tac tac; vernac_set_used_variables l ; print_subgoals ()
+      vernac_set_end_tac tac; vernac_set_used_variables l
   | VernacProofMode mn -> Proof_global.set_proof_mode mn
   (* Toplevel control *)
   | VernacToplevelControl e -> raise e
 
   (* Extensions *)
-  | VernacExtend (opn,args) -> Vernacinterp.call (opn,args)
+  | VernacExtend (opn,args) -> Vernacinterp.call ?locality (opn,args)
+
+  (* Handled elsewhere *)
+  | VernacProgram _
+  | VernacPolymorphic _
+  | VernacLocal _ -> assert false
+
+(* Vernaculars that take a locality flag *)
+let check_vernac_supports_locality c l =
+  match l, c with
+  | None, _ -> ()
+  | Some _, (
+      VernacTacticNotation _
+    | VernacOpenCloseScope _
+    | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _
+    | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
+    | VernacAssumption _
+    | VernacCoercion _ | VernacIdentityCoercion _
+    | VernacInstance _ | VernacDeclareInstances _
+    | VernacDeclareMLModule _
+    | VernacDeclareTacticDefinition _
+    | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _
+    | VernacSyntacticDefinition _
+    | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _
+    | VernacGeneralizable _
+    | VernacSetOpacity _ | VernacSetStrategy _
+    | VernacSetOption _ | VernacUnsetOption _
+    | VernacDeclareReduction _
+    | VernacExtend _ 
+    | VernacInductive _) -> ()
+  | Some _, _ -> Errors.error "This command does not support Locality"
+
+(* Vernaculars that take a polymorphism flag *)
+let check_vernac_supports_polymorphism c p =
+  match p, c with
+  | None, _ -> ()
+  | Some _, (
+      VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _
+    | VernacAssumption _ | VernacInductive _ 
+    | VernacStartTheoremProof _
+    | VernacCoercion _ | VernacIdentityCoercion _
+    | VernacInstance _ | VernacDeclareInstances _
+    | VernacHints _ | VernacContext _
+    | VernacExtend _ ) -> ()
+  | Some _, _ -> Errors.error "This command does not support Polymorphism"
+
+let enforce_polymorphism = function
+  | None -> Flags.is_universe_polymorphism ()
+  | Some b -> b
+
+(** A global default timeout, controled by option "Set Default Timeout n".
+    Use "Unset Default Timeout" to deactivate it (or set it to 0). *)
+
+let default_timeout = ref None
 
-let interp c = interp c ; check_locality ()
+let _ =
+  Goptions.declare_int_option
+    { Goptions.optsync  = true;
+      Goptions.optdepr  = false;
+      Goptions.optname  = "the default timeout";
+      Goptions.optkey   = ["Default";"Timeout"];
+      Goptions.optread  = (fun () -> !default_timeout);
+      Goptions.optwrite = ((:=) default_timeout) }
+
+(** When interpreting a command, the current timeout is initially
+    the default one, but may be modified locally by a Timeout command. *)
+
+let current_timeout = ref None
+
+let vernac_timeout f =
+  match !current_timeout, !default_timeout with
+    | Some n, _ | None, Some n ->
+      let f () = f (); current_timeout := None in
+      Control.timeout n f Timeout
+    | None, None -> f ()
+
+let restore_timeout () = current_timeout := None
+
+let locate_if_not_already loc (e, info) =
+  match Loc.get_loc info with
+  | None -> (e, Loc.add_loc info loc)
+  | Some l -> if Loc.is_ghost l then (e, Loc.add_loc info loc) else (e, info)
+
+exception HasNotFailed
+exception HasFailed of string
+
+let with_fail b f =
+  if not b then f ()
+  else begin try
+      (* If the command actually works, ignore its effects on the state.
+       * Note that error has to be printed in the right state, hence
+       * within the purified function *)
+      Future.purify
+        (fun v ->
+           try f v; raise HasNotFailed
+           with
+           | HasNotFailed as e -> raise e
+           | e ->
+              let e = Errors.push e in
+              raise (HasFailed (Pp.string_of_ppcmds
+              (Errors.iprint (Cerrors.process_vernac_interp_error e)))))
+        ()
+    with e when Errors.noncritical e -> 
+      let (e, _) = Errors.push e in
+      match e with
+      | HasNotFailed ->
+          errorlabstrm "Fail" (str "The command has not failed!")
+      | HasFailed msg ->
+          if is_verbose () || !Flags.ide_slave then msg_info
+    	(str "The command has indeed failed with message:" ++
+    	 fnl () ++ str "=> " ++ hov 0 (str msg))
+      | _ -> assert false
+  end
+
+let interp ?(verbosely=true) ?proof (loc,c) =
+  let orig_program_mode = Flags.is_program_mode () in
+  let rec aux ?locality ?polymorphism isprogcmd = function
+    | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c
+    | VernacProgram _ -> Errors.error "Program mode specified twice"
+    | VernacLocal (b, c) when Option.is_empty locality -> 
+      aux ~locality:b ?polymorphism isprogcmd c
+    | VernacPolymorphic (b, c) when polymorphism = None -> 
+      aux ?locality ~polymorphism:b isprogcmd c
+    | VernacPolymorphic (b, c) -> Errors.error "Polymorphism specified twice"
+    | VernacLocal _ -> Errors.error "Locality specified twice"
+    | VernacStm (Command c) -> aux ?locality ?polymorphism isprogcmd c
+    | VernacStm (PGLast c) -> aux ?locality ?polymorphism isprogcmd c
+    | VernacStm _ -> assert false (* Done by Stm *)
+    | VernacFail v ->
+        with_fail true (fun () -> aux ?locality ?polymorphism isprogcmd v)
+    | VernacTimeout (n,v) ->
+        current_timeout := Some n;
+        aux ?locality ?polymorphism isprogcmd v
+    | VernacTime v ->
+        System.with_time !Flags.time
+          (aux_list ?locality ?polymorphism isprogcmd) v;
+    | VernacLoad (_,fname) -> vernac_load (aux false) fname
+    | c -> 
+        check_vernac_supports_locality c locality;
+        check_vernac_supports_polymorphism c polymorphism;
+	let poly = enforce_polymorphism polymorphism in
+        Obligations.set_program_mode isprogcmd;
+        try
+          vernac_timeout begin fun () ->
+          if verbosely then Flags.verbosely (interp ?proof locality poly) c
+                       else Flags.silently  (interp ?proof locality poly) c;
+          if orig_program_mode || not !Flags.program_mode || isprogcmd then
+            Flags.program_mode := orig_program_mode
+          end
+        with
+        | reraise when
+              (match reraise with
+              | Timeout -> true
+              | e -> Errors.noncritical e)
+          ->
+            let e = Errors.push reraise in
+            let e = locate_if_not_already loc e in
+            let () = restore_timeout () in
+            Flags.program_mode := orig_program_mode;
+            iraise e
+  and aux_list ?locality ?polymorphism isprogcmd l =
+    List.iter (aux false) (List.map snd l)
+  in
+    if verbosely then Flags.verbosely (aux false) c
+    else aux false c
 
+let () = Hook.set Stm.interp_hook interp
+let () = Hook.set Stm.process_error_hook Cerrors.process_vernac_interp_error
+let () = Hook.set Stm.with_fail_hook with_fail
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 9a400fe6..4b1cd7a0 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -1,52 +1,36 @@
 (************************************************************************)
 (*  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 Vernacinterp
-open Vernacexpr
-open Topconstr
+open Misctypes
 
-val dump_global : Libnames.reference Genarg.or_by_notation -> unit
+val dump_global : Libnames.reference or_by_notation -> unit
 
 (** Vernacular entries *)
 
-val show_script : unit -> unit
 val show_prooftree : unit -> unit
 
 val show_node : unit -> unit
 
 (** This function can be used by any command that want to observe terms
-   in the context of the current goal, as for instance in pcoq *)
+   in the context of the current goal *)
 val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
 
-type pcoq_hook = {
-  start_proof : unit -> unit;
-  solve : int -> unit;
-  abort : string -> unit;
-  search : searchable -> dir_path list * bool -> unit;
-  print_name : Libnames.reference Genarg.or_by_notation -> unit;
-  print_check : Environ.env -> Environ.unsafe_judgment -> unit;
-  print_eval : Reductionops.reduction_function -> Environ.env -> Evd.evar_map -> constr_expr ->
-    Environ.unsafe_judgment -> unit;
-  show_goal : goal_reference -> unit
-}
-
-val set_pcoq_hook : pcoq_hook -> unit
-
 (** The main interpretation function of vernacular expressions *)
-
-val interp : Vernacexpr.vernac_expr -> unit
+val interp : 
+  ?verbosely:bool ->
+  ?proof:Proof_global.closed_proof ->
+    Loc.t * Vernacexpr.vernac_expr -> unit
 
 (** Print subgoals when the verbose flag is on.
     Meant to be used inside vernac commands from plugins. *)
 
 val print_subgoals : unit -> unit
+val try_print_subgoals : unit -> unit
 
 (** The printing of goals via [print_subgoals] or during
     [interp] can be controlled by the following flag.
@@ -67,3 +51,8 @@ val qed_display_script : bool ref
     a known inductive type. *)
 
 val make_cases : string -> string list list
+
+val vernac_end_proof :
+  ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit
+
+val with_fail : bool -> (unit -> unit) -> unit
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
deleted file mode 100644
index 02e3eec1..00000000
--- a/toplevel/vernacexpr.ml
+++ /dev/null
@@ -1,508 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2014     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-open Compat
-open Util
-open Names
-open Tacexpr
-open Extend
-open Genarg
-open Topconstr
-open Decl_kinds
-open Ppextend
-open Declaremods
-
-(* Toplevel control exceptions *)
-exception Drop
-exception Quit
-
-open Libnames
-open Nametab
-
-type lident = identifier located
-type lname = name located
-type lstring = string located
-type lreference = reference
-
-type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation
-
-type goal_identifier = string
-
-type goal_reference =
-  | OpenSubgoals
-  | NthGoal of int
-  | GoalId of goal_identifier
-
-type printable =
-  | PrintTables
-  | PrintFullContext
-  | PrintSectionContext of reference
-  | PrintInspect of int
-  | PrintGrammar of string
-  | PrintLoadPath of dir_path option
-  | PrintModules
-  | PrintModule of reference
-  | PrintModuleType of reference
-  | PrintMLLoadPath
-  | PrintMLModules
-  | PrintName of reference or_by_notation
-  | PrintGraph
-  | PrintClasses
-  | PrintTypeClasses
-  | PrintInstances of reference or_by_notation
-  | PrintLtac of reference
-  | PrintCoercions
-  | PrintCoercionPaths of class_rawexpr * class_rawexpr
-  | PrintCanonicalConversions
-  | PrintUniverses of bool * string option
-  | PrintHint of reference or_by_notation
-  | PrintHintGoal
-  | PrintHintDbName of string
-  | PrintRewriteHintDbName of string
-  | PrintHintDb
-  | PrintScopes
-  | PrintScope of string
-  | PrintVisibility of string option
-  | PrintAbout of reference or_by_notation
-  | PrintImplicit of reference or_by_notation
-  | PrintAssumptions of bool * reference or_by_notation
-
-type search_about_item =
-  | SearchSubPattern of constr_pattern_expr
-  | SearchString of string * scope_name option
-
-type searchable =
-  | SearchPattern of constr_pattern_expr
-  | SearchRewrite of constr_pattern_expr
-  | SearchHead of constr_pattern_expr
-  | SearchAbout of (bool * search_about_item) list
-
-type locatable =
-  | LocateTerm of reference or_by_notation
-  | LocateLibrary of reference
-  | LocateModule of reference
-  | LocateTactic of reference
-  | LocateFile of string
-
-type showable =
-  | ShowGoal of goal_reference
-  | ShowGoalImplicitly of int option
-  | ShowProof
-  | ShowNode
-  | ShowScript
-  | ShowExistentials
-  | ShowTree
-  | ShowProofNames
-  | ShowIntros of bool
-  | ShowMatch of lident
-  | ShowThesis
-
-type comment =
-  | CommentConstr of constr_expr
-  | CommentString of string
-  | CommentInt of int
-
-type hints_expr =
-  | HintsResolve of (int option * bool * constr_expr) list
-  | HintsImmediate of constr_expr list
-  | HintsUnfold of reference list
-  | HintsTransparency of reference list * bool
-  | HintsConstructors of reference list
-  | HintsExtern of int * constr_expr option * raw_tactic_expr
-
-type search_restriction =
-  | SearchInside of reference list
-  | SearchOutside of reference list
-
-type rec_flag       = bool (* true = Rec;           false = NoRec          *)
-type verbose_flag   = bool (* true = Verbose;       false = Silent         *)
-type opacity_flag   = bool (* true = Opaque;        false = Transparent    *)
-type locality_flag  = bool (* true = Local;         false = Global         *)
-type coercion_flag  = bool (* true = AddCoercion    false = NoCoercion     *)
-type instance_flag  = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *)
-type export_flag    = bool (* true = Export;        false = Import         *)
-type specif_flag    = bool (* true = Specification; false = Implementation *)
-type inductive_flag = Decl_kinds.recursivity_kind
-type infer_flag     = bool (* true = try to Infer record; false = nothing  *)
-type full_locality_flag = bool option (* true = Local; false = Global      *)
-type onlyparsing_flag = Flags.compat_version option
- (* Some v = Parse only;  None = Print also.
-    If v<>Current, it contains the name of the coq version
-    which this notation is trying to be compatible with *)
-
-type option_value = Goptionstyp.option_value =
-  | BoolValue of bool
-  | IntValue of int option
-  | StringValue of string
-
-type option_ref_value =
-  | StringRefValue of string
-  | QualidRefValue of reference
-
-type sort_expr = Glob_term.glob_sort
-
-type definition_expr =
-  | ProveBody of local_binder list * constr_expr
-  | DefineBody of local_binder list * raw_red_expr option * constr_expr
-      * constr_expr option
-
-type fixpoint_expr =
-    identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option
-
-type cofixpoint_expr =
-    identifier located * local_binder list * constr_expr * constr_expr option
-
-type local_decl_expr =
-  | AssumExpr of lname * constr_expr
-  | DefExpr of lname * constr_expr * constr_expr option
-
-type inductive_kind = Inductive_kw | CoInductive | Record | Structure | Class of bool (* true = definitional, false = inductive *)
-type decl_notation = lstring * constr_expr * scope_name option
-type simple_binder = lident list  * constr_expr
-type class_binder = lident * constr_expr list
-type 'a with_coercion = coercion_flag * 'a
-type 'a with_instance = instance_flag * 'a
-type 'a with_notation = 'a * decl_notation list
-type 'a with_priority = 'a * int option
-type constructor_expr = (lident * constr_expr) with_coercion
-type constructor_list_or_record_decl_expr =
-  | Constructors of constructor_expr list
-  | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list
-type inductive_expr =
-  lident with_coercion * local_binder list * constr_expr option * inductive_kind *
-    constructor_list_or_record_decl_expr
-
-type one_inductive_expr =
-  lident * local_binder list * constr_expr option * constructor_expr list
-
-type module_ast_inl = module_ast annotated
-type module_binder = bool option * lident list * module_ast_inl
-
-type grammar_tactic_prod_item_expr =
-  | TacTerm of string
-  | TacNonTerm of loc * string * (Names.identifier * string) option
-
-type syntax_modifier =
-  | SetItemLevel of string list * production_level
-  | SetLevel of int
-  | SetAssoc of gram_assoc
-  | SetEntryType of string * simple_constr_prod_entry_key
-  | SetOnlyParsing of Flags.compat_version
-  | SetFormat of string located
-
-type proof_end =
-  | Admitted
-  | Proved of opacity_flag * (lident * theorem_kind option) option
-
-type scheme =
-  | InductionScheme of bool * reference or_by_notation * sort_expr
-  | CaseScheme of bool * reference or_by_notation * sort_expr
-  | EqualityScheme of reference or_by_notation
-
-type inline = int option (* inlining level, none for no inlining *)
-
-type bullet =
-    | Dash
-    | Star
-    | Plus
-
-type vernac_expr =
-  (* Control *)
-  | VernacList of located_vernac_expr list
-  | VernacLoad of verbose_flag * string
-  | VernacTime of vernac_expr
-  | VernacTimeout of int * vernac_expr
-  | VernacFail of vernac_expr
-
-  (* Syntax *)
-  | VernacTacticNotation of int * grammar_tactic_prod_item_expr list * raw_tactic_expr
-  | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list)
-  | VernacOpenCloseScope of (locality_flag * bool * scope_name)
-  | VernacDelimiters of scope_name * string
-  | VernacBindScope of scope_name * class_rawexpr list
-  | VernacInfix of locality_flag * (lstring * syntax_modifier list) *
-      constr_expr * scope_name option
-  | VernacNotation of
-      locality_flag * constr_expr * (lstring * syntax_modifier list) *
-      scope_name option
-
-  (* Gallina *)
-  | VernacDefinition of definition_kind * lident * definition_expr *
-      declaration_hook
-  | VernacStartTheoremProof of theorem_kind *
-      (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list *
-        bool * declaration_hook
-  | VernacEndProof of proof_end
-  | VernacExactProof of constr_expr
-  | VernacAssumption of assumption_kind * inline * simple_binder with_coercion list
-  | VernacInductive of inductive_flag * infer_flag * (inductive_expr * decl_notation list) list
-  | VernacFixpoint of (fixpoint_expr * decl_notation list) list
-  | VernacCoFixpoint of (cofixpoint_expr * decl_notation list) list
-  | VernacScheme of (lident option * scheme) list
-  | VernacCombinedScheme of lident * lident list
-
-  (* Gallina extensions *)
-  | VernacBeginSection of lident
-  | VernacEndSegment of lident
-  | VernacRequire of
-      export_flag option * specif_flag option * lreference list
-  | VernacImport of export_flag * lreference list
-  | VernacCanonical of reference or_by_notation
-  | VernacCoercion of locality * reference or_by_notation *
-      class_rawexpr * class_rawexpr
-  | VernacIdentityCoercion of locality * lident *
-      class_rawexpr * class_rawexpr
-
-  (* Type classes *)
-  | VernacInstance of
-      bool * (* abstract instance *)
-      bool * (* global *)
-      local_binder list * (* super *)
-	typeclass_constraint * (* instance name, class name, params *)
-	constr_expr option * (* props *)
-	int option (* Priority *)
-
-  | VernacContext of local_binder list
-
-  | VernacDeclareInstances of
-      bool (* global *) * reference list (* instance names *)
-
-  | VernacDeclareClass of reference (* inductive or definition name *)
-
-  (* Modules and Module Types *)
-  | VernacDeclareModule of bool option * lident *
-      module_binder list * module_ast_inl
-  | VernacDefineModule of bool option * lident *
-      module_binder list * module_ast_inl module_signature * module_ast_inl list
-  | VernacDeclareModuleType of lident *
-      module_binder list * module_ast_inl list * module_ast_inl list
-  | VernacInclude of module_ast_inl list
-
-  (* Solving *)
-
-  | VernacSolve of int * raw_tactic_expr * bool
-  | VernacSolveExistential of int * constr_expr
-
-  (* Auxiliary file and library management *)
-  | VernacRequireFrom of export_flag option * specif_flag option * string
-  | VernacAddLoadPath of rec_flag * string * dir_path option
-  | VernacRemoveLoadPath of string
-  | VernacAddMLPath of rec_flag * string
-  | VernacDeclareMLModule of locality_flag * string list
-  | VernacChdir of string option
-
-  (* State management *)
-  | VernacWriteState of string
-  | VernacRestoreState of string
-
-  (* Resetting *)
-  | VernacResetName of lident
-  | VernacResetInitial
-  | VernacBack of int
-  | VernacBackTo of int
-
-  (* Commands *)
-  | VernacDeclareTacticDefinition of
-      (locality_flag * rec_flag * (reference * bool * raw_tactic_expr) list)
-  | VernacCreateHintDb of locality_flag * string * bool
-  | VernacRemoveHints of locality_flag * string list * reference list
-  | VernacHints of locality_flag * string list * hints_expr
-  | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) *
-      locality_flag * onlyparsing_flag
-  | VernacDeclareImplicits of locality_flag * reference or_by_notation *
-      (explicitation * bool * bool) list list
-  | VernacArguments of locality_flag * reference or_by_notation * 
-      ((name * bool * (loc * string) option * bool * bool) list) list *
-      int * [ `SimplDontExposeCase | `SimplNeverUnfold | `Rename | `ExtraScopes
-            | `ClearImplicits | `ClearScopes | `DefaultImplicits ] list
-  | VernacArgumentsScope of locality_flag * reference or_by_notation *
-      scope_name option list
-  | VernacReserve of simple_binder list
-  | VernacGeneralizable of locality_flag * (lident list) option
-  | VernacSetOpacity of
-      locality_flag * (Conv_oracle.level * reference or_by_notation list) list
-  | VernacUnsetOption of full_locality_flag * Goptions.option_name
-  | VernacSetOption of full_locality_flag * Goptions.option_name * option_value
-  | VernacAddOption of Goptions.option_name * option_ref_value list
-  | VernacRemoveOption of Goptions.option_name * option_ref_value list
-  | VernacMemOption of Goptions.option_name * option_ref_value list
-  | VernacPrintOption of Goptions.option_name
-  | VernacCheckMayEval of raw_red_expr option * int option * constr_expr
-  | VernacGlobalCheck of constr_expr
-  | VernacDeclareReduction of locality_flag * string * raw_red_expr
-  | VernacPrint of printable
-  | VernacSearch of searchable * search_restriction
-  | VernacLocate of locatable
-  | VernacComments of comment list
-  | VernacNop
-
-  (* Proof management *)
-  | VernacGoal of constr_expr
-  | VernacAbort of lident option
-  | VernacAbortAll
-  | VernacRestart
-  | VernacUndo of int
-  | VernacUndoTo of int
-  | VernacBacktrack of int*int*int
-  | VernacFocus of int option
-  | VernacUnfocus
-  | VernacUnfocused
-  | VernacBullet of bullet
-  | VernacSubproof of int option
-  | VernacEndSubproof
-  | VernacShow of showable
-  | VernacCheckGuard
-  | VernacProof of raw_tactic_expr option * lident list option
-  | VernacProofMode of string
-  (* Toplevel control *)
-  | VernacToplevelControl of exn
-
-  (* For extension *)
-  | VernacExtend of string * raw_generic_argument list
-
-and located_vernac_expr = loc * vernac_expr
-
-
-(** Categories of [vernac_expr] *)
-
-let rec strip_vernac = function
-  | VernacTime c | VernacTimeout(_,c) | VernacFail c -> strip_vernac c
-  | c -> c (* TODO: what about VernacList ? *)
-
-let rec is_navigation_vernac = function
-  | VernacResetInitial
-  | VernacResetName _
-  | VernacBacktrack _
-  | VernacBackTo _
-  | VernacBack _ -> true
-  | VernacTime c -> is_navigation_vernac c (* Time Back* is harmless *)
-  | c -> is_deep_navigation_vernac c
-
-and is_deep_navigation_vernac = function
-  | VernacTimeout (_,c) | VernacFail c -> is_navigation_vernac c
-  | VernacList l -> List.exists (fun (_,c) -> is_navigation_vernac c) l
-  | _ -> false
-
-(* NB: Reset is now allowed again as asked by A. Chlipala *)
-
-let is_reset = function
-  | VernacResetInitial | VernacResetName _ -> true
-  | _ -> false
-
-(* Locating errors raised just after the dot is parsed but before the
-   interpretation phase *)
-
-let syntax_checking_error loc s = user_err_loc (loc,"",Pp.str s)
-
-(**********************************************************************)
-(* Managing locality *)
-
-let locality_flag = ref None
-
-let local_of_bool = function true -> Local | false -> Global
-
-let check_locality () =
-  match !locality_flag with
-  | Some (loc,true) -> 
-      syntax_checking_error loc
-	"This command does not support the \"Local\" prefix.";
-  | Some (loc,false) -> 
-      syntax_checking_error loc
-	"This command does not support the \"Global\" prefix."
-  | None -> ()
-
-(** Extracting the locality flag *)
-
-(* Commands which supported an inlined Local flag *)
-
-let enforce_locality_full local =
-  let local =
-    match !locality_flag with
-    | Some (_,false) when local ->
-	error "Cannot be simultaneously Local and Global."
-    | Some (_,true) when local ->
-	error "Use only prefix \"Local\"."
-    | None ->
-	if local then begin
-	  Flags.if_warn
-	   Pp.msg_warning (Pp.str"Obsolete syntax: use \"Local\" as a prefix.");
-	  Some true
-	end else
-	None
-    | Some (_,b) -> Some b in
-  locality_flag := None;
-  local
-
-(* Commands which did not supported an inlined Local flag (synonym of
-   [enforce_locality_full false]) *)
-
-let use_locality_full () =
-  let r = Option.map snd !locality_flag in
-  locality_flag := None;
-   r
-
-(** Positioning locality for commands supporting discharging and export
-     outside of modules *)
-
-(* For commands whose default is to discharge and export:
-   Global is the default and is neutral;
-   Local in a section deactivates discharge, 
-   Local not in a section deactivates export *)
-
-let make_locality = function Some true -> true | _ -> false
-
-let use_locality () = make_locality (use_locality_full ())
-
-let use_locality_exp () = local_of_bool (use_locality ())
-
-let enforce_locality local = make_locality (enforce_locality_full local)
-
-let enforce_locality_exp local = local_of_bool (enforce_locality local)
-
-(* For commands whose default is not to discharge and not to export:
-   Global forces discharge and export;
-   Local is the default and is neutral *)
-
-let use_non_locality () =
-  match use_locality_full () with Some false -> false | _ -> true
-
-(* For commands whose default is to not discharge but to export:
-   Global in sections forces discharge, Global not in section is the default;
-   Local in sections is the default, Local not in section forces non-export *)
-
-let make_section_locality =
-  function Some b -> b | None -> Lib.sections_are_opened ()
-
-let use_section_locality () =
-  make_section_locality (use_locality_full ())
-
-let enforce_section_locality local =
-  make_section_locality (enforce_locality_full local)
-
-(** Positioning locality for commands supporting export but not discharge *)
-
-(* For commands whose default is to export (if not in section):
-   Global in sections is forbidden, Global not in section is neutral;
-   Local in sections is the default, Local not in section forces non-export *)
-
-let make_module_locality = function
-  | Some false ->
-      if Lib.sections_are_opened () then
-	error "This command does not support the Global option in sections.";
-      false
-  | Some true -> true
-  | None -> false
-
-let use_module_locality () =
-  make_module_locality (use_locality_full ())
-
-let enforce_module_locality local =
-  make_module_locality (enforce_locality_full local)
-
-(**********************************************************************)
-
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index 0a94c050..17f971fd 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -1,35 +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 Pp
 open Util
-open Names
-open Libnames
-open Himsg
-open Proof_type
-open Tacinterp
-open Vernacexpr
-
-let disable_drop e =
-  if e <> Drop then e
-  else UserError("Vernac.disable_drop",(str"Drop is forbidden."))
+open Pp
+open Errors
 
 (* Table of vernac entries *)
 let vernac_tab =
   (Hashtbl.create 51 :
-    (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t)
+    (Vernacexpr.extend_name, (Genarg.raw_generic_argument list -> unit -> unit)) Hashtbl.t)
 
 let vinterp_add s f =
   try
     Hashtbl.add vernac_tab s f
   with Failure _ ->
     errorlabstrm "vinterp_add"
-      (str"Cannot add the vernac command " ++ str s ++ str" twice.")
+      (str"Cannot add the vernac command " ++ str (fst s) ++ str" twice.")
 
 let overwriting_vinterp_add s f =
   begin
@@ -42,25 +33,28 @@ let overwriting_vinterp_add s f =
 let vinterp_map s =
   try
     Hashtbl.find vernac_tab s
-  with Not_found ->
+  with Failure _ | Not_found ->
     errorlabstrm "Vernac Interpreter"
-      (str"Cannot find vernac command " ++ str s ++ str".")
+      (str"Cannot find vernac command " ++ str (fst s) ++ str".")
 
 let vinterp_init () = Hashtbl.clear vernac_tab
 
 (* Interpretation of a vernac command *)
 
-let call (opn,converted_args) =
+let call ?locality (opn,converted_args) =
   let loc = ref "Looking up command" in
   try
     let callback = vinterp_map opn in
     loc:= "Checking arguments";
     let hunk = callback converted_args in
     loc:= "Executing command";
-    hunk()
+    Locality.LocalityFixme.set locality;
+    hunk();
+    Locality.LocalityFixme.assert_consumed()
   with
     | Drop -> raise Drop
     | reraise ->
+        let reraise = Errors.push reraise in
         if !Flags.debug then
-	  msgnl (str"Vernac Interpreter " ++ str !loc);
-        raise reraise
+	  msg_debug (str"Vernac Interpreter " ++ str !loc);
+        iraise reraise
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index f3ae0b7a..38fce5d1 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -1,20 +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 Tacexpr
-
 (** Interpretation of extended vernac phrases. *)
 
-val disable_drop : exn -> exn
-
-val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit
+val vinterp_add : Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit
 val overwriting_vinterp_add :
-  string -> (raw_generic_argument list -> unit -> unit) -> unit
+  Vernacexpr.extend_name -> (Genarg.raw_generic_argument list -> unit -> unit) -> unit
 
 val vinterp_init : unit -> unit
-val call : string * raw_generic_argument list -> unit
+val call : ?locality:bool -> Vernacexpr.extend_name * Genarg.raw_generic_argument list -> unit
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
index 888a4f1a..daedc30f 100644
--- a/toplevel/whelp.ml4
+++ b/toplevel/whelp.ml4
@@ -1,31 +1,28 @@
 (************************************************************************)
 (*  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 camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
 
 open Flags
 open Pp
-open Util
-open System
+open Errors
 open Names
 open Term
-open Environ
 open Glob_term
 open Libnames
+open Globnames
 open Nametab
 open Detyping
 open Constrintern
 open Dischargedhypsmap
-open Command
 open Pfedit
-open Refiner
 open Tacmach
-open Syntax_def
+open Misctypes
 
 (* Coq interface to the Whelp query engine developed at
    the University of Bologna *)
@@ -60,8 +57,8 @@ let make_whelp_request req c =
 let b = Buffer.create 16
 
 let url_char c =
-  if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or
-     '0' <= c & c <= '9' or c ='.'
+  if 'A' <= c && c <= 'Z' || 'a' <= c && c <= 'z' ||
+     '0' <= c && c <= '9' || c ='.'
   then Buffer.add_char b c
   else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c))
 
@@ -72,13 +69,13 @@ let rec url_list_with_sep sep f = function
   | [a] -> f a
   | a::l -> f a; url_string sep; url_list_with_sep sep f l
 
-let url_id id = url_string (string_of_id id)
+let url_id id = url_string (Id.to_string id)
 
 let uri_of_dirpath dir =
   url_string "cic:/"; url_list_with_sep "/" url_id (List.rev dir)
 
 let error_whelp_unknown_reference ref =
-  let qid = Nametab.shortest_qualid_of_global Idset.empty ref in
+  let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in
   errorlabstrm ""
     (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++
      strbrk ", are not supported in Whelp.")
@@ -86,7 +83,7 @@ let error_whelp_unknown_reference ref =
 let uri_of_repr_kn ref (mp,dir,l) =
   match mp with
     | MPfile sl ->
-        uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl)
+        uri_of_dirpath (Label.to_id l :: DirPath.repr dir @ DirPath.repr sl)
     | _ ->
         error_whelp_unknown_reference ref
 
@@ -94,8 +91,8 @@ let url_paren f l = url_char '('; f l; url_char ')'
 let url_bracket f l = url_char '['; f l; url_char ']'
 
 let whelp_of_glob_sort = function
-  | GProp Null -> "Prop"
-  | GProp Pos -> "Set"
+  | GProp -> "Prop"
+  | GSet -> "Set"
   | GType _ -> "Type"
 
 let uri_int n = Buffer.add_string b (string_of_int n)
@@ -105,7 +102,7 @@ let uri_of_ind_pointer l =
 
 let uri_of_global ref =
   match ref with
-  | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".")
+  | VarRef id -> error ("Unknown Whelp reference: "^(Id.to_string id)^".")
   | ConstRef cst ->
       uri_of_repr_kn ref (repr_con cst); url_string ".con"
   | IndRef (kn,i) ->
@@ -113,7 +110,7 @@ let uri_of_global ref =
   | ConstructRef ((kn,i),j) ->
       uri_of_repr_kn ref (repr_mind kn); uri_of_ind_pointer [1;i+1;j]
 
-let whelm_special = id_of_string "WHELM_ANON_VAR"
+let whelm_special = Id.of_string "WHELM_ANON_VAR"
 
 let url_of_name = function
   | Name id -> url_id id
@@ -129,9 +126,9 @@ let uri_params f = function
 let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp)
 
 let section_parameters = function
-  | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_))) ->
+  | GRef (_,(ConstructRef ((induri,_),_) | IndRef (induri,_)),_) ->
       get_discharged_hyp_names (path_of_global (IndRef(induri,0)))
-  | GRef (_,(ConstRef cst as ref)) ->
+  | GRef (_,(ConstRef cst as ref),_) ->
       get_discharged_hyp_names (path_of_global ref)
   | _ -> []
 
@@ -144,10 +141,9 @@ let merge vl al =
 let rec uri_of_constr c =
   match c with
   | GVar (_,id) -> url_id id
-  | GRef (_,ref) ->  uri_of_global ref
+  | GRef (_,ref,_) ->  uri_of_global ref
   | GHole _ | GEvar _ -> url_string "?"
   | GSort (_,s) -> url_string (whelp_of_glob_sort s)
-  | _ -> url_paren (fun () -> match c with
   | GApp (_,f,args) ->
       let inst,rest = merge (section_parameters f) args in
       uri_of_constr f; url_char ' '; uri_params uri_of_constr inst;
@@ -163,30 +159,30 @@ let rec uri_of_constr c =
   | GLetIn (_,na,b,c) ->
       url_string "let "; url_of_name na; url_string "\\def ";
       uri_of_constr b; url_string " in "; uri_of_constr c
-  | GCast (_,c, CastConv (_,t)) ->
+  | GCast (_,c, (CastConv t|CastVM t|CastNative t)) ->
       uri_of_constr c; url_string ":"; uri_of_constr t
   | GRec _ | GIf _ | GLetTuple _ | GCases _ ->
       error "Whelp does not support pattern-matching and (co-)fixpoint."
-  | GVar _ | GRef _ | GHole _ | GEvar _ | GSort _ | GCast (_,_, CastCoerce) ->
-      anomaly "Written w/o parenthesis"
+  | GCast (_,_, CastCoerce) ->
+      anomaly (Pp.str "Written w/o parenthesis")
   | GPatVar _ ->
-      anomaly "Found constructors not supported in constr") ()
+      anomaly (Pp.str "Found constructors not supported in constr")
 
 let make_string f x = Buffer.reset b; f x; Buffer.contents b
 
 let send_whelp req s =
   let url = make_whelp_request req s in
-  let command = subst_command_placeholder browser_cmd_fmt url in
-  let _ = run_command (fun x -> x) print_string command in ()
+  let command = Util.subst_command_placeholder browser_cmd_fmt url in
+  let _ = CUnix.run_command ~hook:print_string command in ()
 
-let whelp_constr req c =
-  let c = detype false [whelm_special] [] c in
+let whelp_constr env sigma req c =
+  let c = detype false [whelm_special] env sigma c in
   send_whelp req (make_string uri_of_constr c)
 
 let whelp_constr_expr req c =
   let (sigma,env)= Lemmas.get_current_context () in
-  let _,c = interp_open_constr sigma env c in
-  whelp_constr req c
+  let _,c = interp_open_constr env sigma c in
+  whelp_constr env sigma req c
 
 let whelp_locate s =
   send_whelp "locate" s
@@ -195,9 +191,9 @@ let whelp_elim ind =
   send_whelp "elim" (make_string uri_of_global (IndRef ind))
 
 let on_goal f =
-  let { Evd.it=goals ; sigma=sigma } = Proof.V82.subgoals (get_pftreestate ()) in
-  let gls = { Evd.it=List.hd goals ; sigma = sigma }  in
-  f (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
+  let gls = Proof.V82.subgoals (get_pftreestate ()) in
+  let gls = { gls with Evd.it = List.hd gls.Evd.it }  in
+  f (pf_env gls) (project gls) (Termops.it_mkNamedProd_or_LetIn (pf_concl gls) (pf_hyps gls))
 
 type whelp_request =
   | Locate of string
@@ -207,21 +203,22 @@ type whelp_request =
 let whelp = function
   | Locate s -> whelp_locate s
   | Elim ind -> whelp_elim ind
-  | Constr (s,c) -> whelp_constr s c
+  | Constr (s,c) -> whelp_constr (Global.env()) (Evd.empty) s c
 
 VERNAC ARGUMENT EXTEND whelp_constr_request
 | [ "Match" ] -> [ "match" ]
 | [ "Instance" ] -> [ "instance" ]
 END
 
-VERNAC COMMAND EXTEND Whelp
+VERNAC COMMAND EXTEND Whelp CLASSIFIED AS QUERY
 | [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ]
 | [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ]
 | [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ]
 | [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c]
 END
 
-VERNAC COMMAND EXTEND WhelpHint
+VERNAC COMMAND EXTEND WhelpHint CLASSIFIED AS QUERY
 | [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ]
-| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ]
+| [ "Whelp" "Hint" ] => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] ->
+  [ on_goal (fun env sigma -> whelp_constr env sigma "hint") ]
 END
diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli
index dbdecee8..62272c50 100644
--- a/toplevel/whelp.mli
+++ b/toplevel/whelp.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        *)
@@ -11,8 +11,6 @@
 
 open Names
 open Term
-open Topconstr
-open Environ
 
 type whelp_request =
   | Locate of string